# Insert abs into two adjacent terms of the expression

Give an expression

expr = a - b - c - d - e;


I need to add abs between adjacent letters, the desired result is

list1 = {Abs[a-b]-c-d-e, a-Abs[b-c]-d-e, a-b-Abs[c-d]-e, a-b-c-Abs[d-e]};
list2 = {Abs[a-b]-Abs[c-d]-e, Abs[a-b]-c-Abs[d-e], a-Abs[b-c]-Abs[d-e]};


I tried to use ReplaceList, but couldn't get the correct result

ReplaceList[expr, a_ - b_ + c__ /; Length[a - b] == 2 -> Abs[a - b] + c]


Do you know the right way?

• (1) Plus is Orderless and "adjacent" depends on the ordering. Conceptually, "adjacent" and "orderless" are incompatible, but Orderless in Plus means that terms will be put in the standard order (as defined by Mathematica), which may not be the order the user expects. Is that how you want to apply Abs? Additionally, Orderless affects pattern matching. -- (2) You give two different results, together called "the" desired result. Does that mean you want separate codes for each? Jan 10 at 18:45

These give the two desired results. I had some doubt about the apparent rule for signs, but the following gets the results. Maybe someone clever can find a better way to do the second list.

ReplaceList[List @@ expr,
{w___, PatternSequence[x_, y_], z___} :>
With[{s = (-1)^Boole@InternalSyntacticNegativeQ[x]},
w + s*Abs[s*x + y] + z]]
(*
{-c - d - e + Abs[a - b],
a - d - e - Abs[b - c],
a - b - e - Abs[c - d],
a - b - c - Abs[d - e]}
*)

ReplaceList[#,
{w___, PatternSequence[x_, y_]?(FreeQ[#, Abs] &), z___} :>
With[{s = (-1)^Boole@InternalSyntacticNegativeQ[x]},
w + s*Abs[s*x + y] + z]] & /@ ReplaceList[List @@ expr,
{w___, PatternSequence[x_, y_], z___} :>
With[{s = (-1)^Boole@InternalSyntacticNegativeQ[x]}, {w,
s*Abs[s*x + y], z}]] // Flatten // DeleteDuplicates
(*
{-e + Abs[a - b] - Abs[c - d],
-c + Abs[a - b] - Abs[d - e],
a - Abs[b - c] - Abs[d - e]}
*)


The following was not asked for, but it gives all possible pairings, including no pairing:

    Total /@ FixedPoint[
Composition[
DeleteDuplicates,
Flatten[#, 1] &,
Map[ReplaceList[
{
{w___, PatternSequence[x_, y_]?(FreeQ[#, Abs] &), z___} :>
With[{s = (-1)^Boole@InternalSyntacticNegativeQ[x]}, {w,
s*Abs[s*x + y], z}],
x_ :> x}]]
],
{List @@ expr}]
(*
{-e + Abs[a - b] - Abs[c - d],
-c + Abs[a - b] - Abs[d - e],
-c - d - e + Abs[a - b],
a - Abs[b - c] - Abs[d - e],
a - d - e - Abs[b - c],
a - b - e - Abs[c - d],
a - b - c - Abs[d - e],
a - b - c - d - e}
*)


If you do not remove Plus with List @@ expr, then you get more pairings, since the Orderless attribute of Plus allows PatternSequence[x_, y_] to match any pair in any order.

• Note that (1) you don't need PatternSequence, and (2) you can write just one replacement rule: ReplaceList[List @@ expr, {w1___, x_, y_, w2___, q_, r_, w3___} :> With[{s1 = (-1)^Boole@InternalSyntacticNegativeQ[x], s2 = (-1)^Boole@InternalSyntacticNegativeQ[q]}, w1 + s1*Abs[s1 x + y] + w2 + s2 Abs[s2 q + r] + w3]] Jan 11 at 11:44
• @Domen Thanks!! Jan 11 at 15:45

For the first solution, we may define a rule that is applied by "ReplaceParts". The rule will replace to successive characters by the absolute value of their difference. As we use the rule in a function, we need to prevent too early evaluation by "Hold":

expr = a - b - c - d - e;
rule = {i ->
If[i == 1,
Abs[expr[[i]] + expr[[i + 1]]], -Abs[-expr[[i]] + expr[[i + 1]]]],  i + 1 -> Sequence[]};

Table[ReplacePart[expr, rule], {i, Length[expr] - 1}]

{-c - d - e + Abs[a - b], a - d - e - Abs[b - c], a - b - e - Abs[c - d], a - b - c - Abs[d - e]}


For the second solution, we need a more complicated rule because we now need 2 absolute values. In addition we need the indices of the 2 tuples that we store in the variable "pos". And instead of "Table" we use an function, that is applied to "pos":

rule0 :=
Hold@{#[[1]] :>
If[#[[1]] == 1,
Abs[expr[[#[[1]]]] +
expr[[#[[1]] + 1]]], -Abs[-expr[[#[[1]]]] +
expr[[#[[1]] + 1]]]], #[[1]] + 1 -> Sequence[],
#[[2]] :>
If[#[[2]] == 1,
Abs[expr[[#[[2]]]] +
expr[[#[[2]] + 1]]], -Abs[-expr[[#[[2]]]] +
expr[[#[[2]] + 1]]]], #[[2]] + 1 -> Sequence[]
};

pos = Table[i, {i, 1, Length[expr]}];
pos = Delete[pos, #][[1 ;; ;; 2]] & /@
Table[i, {i, Length[expr], 1, -2}];

With[{rule = rule0},
ReplacePart[expr, (rule // ReleaseHold)] & /@ pos
]

{-e + Abs[a - b] - Abs[c - d], -c + Abs[a - b] - Abs[d - e],
a - Abs[b - c] - Abs[d - e]}

expr = a - b - c - d - e;
lst =List@@expr;
signs=(-1)^Boole[InternalSyntacticNegativeQ @ #] &/@lst

(* {1,-1,-1,-1,-1} *)

Flatten[#].Most@signs&/@(MapAt[Abs[First@#-Last@#]&,{2}]/@(TakeList[lst signs,
{#,2,All}]&/@Range[0,Length@lst-2]))

(* {-c -d -e + Abs[a-b],
a -d -e - Abs[b-c],
a -b -e - Abs[c-d],
a -b -c - Abs[d-e]} *)



Example 2

expr2 = Join[{a},-Array[x, {9}]]
signs2=(-1)^Boole[InternalSyntacticNegativeQ @ #] &/@expr2

(*
{a,-x[1],-x[2],-x[3],-x[4],-x[5],-x[6],-x[7],-x[8],-x[9]}
{1,-1,-1,-1,-1,-1,-1,-1,-1,-1}
*)


Flatten[#].Most@signs2&/@(MapAt[Abs[First@#-Last@#]&,{2}]/@(TakeList[expr2 signs2,
{#,2,All}]&/@Range[0,Length@expr2-2]))

(*
{Abs[a-x[1]]-x[2]-x[3]-x[4]-x[5]-x[6]-x[7]-x[8]-x[9],
a-Abs[x[1]-x[2]]-x[3]-x[4]-x[5]-x[6]-x[7]-x[8]-x[9],
a-Abs[x[2]-x[3]]-x[1]-x[4]-x[5]-x[6]-x[7]-x[8]-x[9],
a-Abs[x[3]-x[4]]-x[1]-x[2]-x[5]-x[6]-x[7]-x[8]-x[9],
a-Abs[x[4]-x[5]]-x[1]-x[2]-x[3]-x[6]-x[7]-x[8]-x[9],
a-Abs[x[5]-x[6]]-x[1]-x[2]-x[3]-x[4]-x[7]-x[8]-x[9],
a-Abs[x[6]-x[7]]-x[1]-x[2]-x[3]-x[4]-x[5]-x[8]-x[9],
a-Abs[x[7]-x[8]]-x[1]-x[2]-x[3]-x[4]-x[5]-x[6]-x[9],
a-Abs[x[8]-x[9]]-x[1]-x[2]-x[3]-x[4]-x[5]-x[6]-x[7]}
*)