7
$\begingroup$

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?

$\endgroup$
1
  • 3
    $\begingroup$ (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? $\endgroup$
    – Goofy
    Commented Jan 10 at 18:45

3 Answers 3

8
$\begingroup$

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@Internal`SyntacticNegativeQ[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@Internal`SyntacticNegativeQ[x]}, 
       w + s*Abs[s*x + y] + z]] & /@ ReplaceList[List @@ expr,
    {w___, PatternSequence[x_, y_], z___} :> 
     With[{s = (-1)^Boole@Internal`SyntacticNegativeQ[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@Internal`SyntacticNegativeQ[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.

$\endgroup$
2
  • 2
    $\begingroup$ 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@Internal`SyntacticNegativeQ[x], s2 = (-1)^Boole@Internal`SyntacticNegativeQ[q]}, w1 + s1*Abs[s1 x + y] + w2 + s2 Abs[s2 q + r] + w3]] $\endgroup$
    – Domen
    Commented Jan 11 at 11:44
  • $\begingroup$ @Domen Thanks!! $\endgroup$
    – Goofy
    Commented Jan 11 at 15:45
4
$\begingroup$

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]}
$\endgroup$
2
$\begingroup$
expr = a - b - c - d - e;
lst =List@@expr;
signs=(-1)^Boole[Internal`SyntacticNegativeQ @ #] &/@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[Internal`SyntacticNegativeQ @ #] &/@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]}
 *)
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.