Construct an infix operation from a list

Question

Inspired by this question, if I have a list

{a, p, b, q, c}

where p and q are binary operators, such as Plus and Times, how would I construct the expression

a ~ p ~ b ~ q ~ c

and execute it?

Obviously, the solution proposed in the other question of constructing it via strings is the most straightforward approach, but I would like to know if the infix formulation, above, is doable without resorting to string manipulation.

Answer 1

Two variants:

(* left-associative *)
Hold[a, Times, b, Plus, c, Subtract, f] //. f_[a_, p_, b_, c___] :> f[p[a, b], c]
 (* Hold[(a b + c) - f] *)

(* right-associative *)
Hold[a, Times, b, Plus, c, Subtract, f] //. f_[c___, a_, p_, b_] :> f[c, p[a, b]]
 (* Hold[a (b + (c - f))] *)

after which one can apply ReleaseHold[]...

Answer 2

Looks like I'm late to the party but I can still have fun with the existing answers.

Terse form of István's method:

x = {a, p, b, q, c, r, d, s, e};

First@Nest[{#2[#, #3], ##4} & @@ # &, x, (Length@x - 1)/2]

With two-parameter Fold syntax kguler's foldF can be written:

Fold[{##} /. {{x_, f_}, y_} :> x ~f~ y &, #] &

Last but not least a method based on Rojo's answer:

infixate =
  Module[{f},
    SetAttributes[f, HoldAll];
    f @@ # //. {f@i_ :> i, f[a1__, h_, a2_] :> h[f@a1, a2]}
  ] &;

{a, p, b} // infixate

p[a, b]

Hold[a, Print, 2 + 2, q, 8/4, r, d, Hold, e] // infixate

Hold[r[q[Print[a, 2 + 2], 8/4], d], e]

Here's one more I couldn't pass by, even though it is string-based:

x = {a, Times, b, Plus, c, Subtract, f};

ToExpression@ToString@Row[x, "~"]

a b + c - f

Answer 3

Is this what you want?

f[{i_}] := i;
f[{a1__, h_, a2_}] := h[f[{a1}], a2]

So

{a, p, b, q, c}//f

(* q[p[a, b], c] *)

It doesn't respect holding attributes, but Plus and Times don't hold their arguments anyway

Answer 4

Implementation with Nest. Note, that this version is left-associative, and requires an input list of $2n+1$ elements (with $n$ infix operators):

x = {a, p, b, q, c, r, d, s, e};

First@Nest[{#[[2]][#[[1]], #[[3]]], Sequence @@ Drop[#, 3]} &, x, (Length@x - 1)/2]

s[r[q[p[a, b], c], d], e]

Right-associative:

First@Nest[{Sequence @@ Drop[#, -3], #[[-2]][#[[-3]], #[[-1]]]} &, x, (Length@x - 1)/2]

p[a, q[b, r[c, s[d, e]]]]

Answer 5

 foldF = Fold[{#1, #2} /. {{x_, f_}, y_} :> f[x, y] &, First@#, Rest@#] &;
 foldF /@ {{a, p, b, q, c, r, d, s, e},
     {a, Times, b, Plus, c, Subtract, d, Divide, e},
     {2, Times, 3, Plus, 4, Subtract, 5, Divide, 2}}
 (* {s[r[q[p[a,b],c],d],e], (a*b+c-d)/e, 5/2} *)

---

  ClearAll[fldInfiX, infiX, evaluateF];
  evaluateF = # //. Infix[x__] :> x &;
  infiX[x_] := x;
  infiX[f_[x_, y_]] := Infix[f[x, y]];
  fldInfiX = Function[{lst}, Fold[{#1, #2} /. {{x_, f_}, y_} :> infiX[f[x, y]] &,
       First@lst, Rest@lst]];
  fldInfiX /@ {{a, op1, b, op2, c},
     {a, Times, b, Plus, c}, {1, Times, 2, Plus, 3},
    {5, Subtract, 2, Plus, 12, Divide, 2}}
  (* {(a~op1~b)~op2~c, c~Plus~(a~Times~b), 5, 15~Rational~2}  *)
  evaluateF /@ %
  (* {op2[op1[a, b], c], a*b + c, 5, 15/2}  *)

Answer 6

You need to reformulate the question: you can't do this generally without declaring the precedence of p and q. If p takes precedence of q, your expression is fully represented as

{{a,p,b},q,c}

otherwise it is

{a,p,{b,q,c}}

Once you've done that, use this replacement:

{a, p, {b, q, c}} //. {x_, f_, y_} -> Infix@f[x, y]
{{a, p, b}, q, c} //. {x_, f_, y_} -> Infix@f[x, y]

For this output:

a~p~(b~q~c)
(a~p~b)~q~c

What you probably want though, is the Notations package:

Needs["Notation`"]
InfixNotation[ParsedBoxWrapper["\"~p~\""], p]
InfixNotation[ParsedBoxWrapper["\"~q~\""], q]

Then, when you enter

p[a, q[b,c]]

the output is automatically

a ~p~ (b ~q~ c)

but the internal representation is still p[a, q[b,c]].