# Transformation rule for arbitrary number of argument expressions

I am failing to write a Mathematica transformation rule that replaces e.g. f[a + 3, b + 3, c + 3] with f[a, b, c] + 3 for an arbitrary number of arguments. However, f[a + 3, b + 3, c + 2] should remain untouched after the transformation.

• f[a + 3, b + 3, c + 3] /. f[pat : (_ + n_) ..] :> f @@ ({pat} - n) + n. Would you be willing to show what you've tried so that we can get a handle on where you're at, Mathematica-knowledge-wise? Jul 26, 2016 at 17:57
• In addition, can you expand on your problem? It's not specified enough, and so it's quite possible that people will spend time figuring out how to answer your question, and then you'll show a different example on which it fails. Or maybe it'll be a case where you want to specify what number (e.g. 3) gets pulled out. Please include more information in your post, and then I will consider posting an answer. Jul 26, 2016 at 18:01
• @march Your proposed replacement doesn't seem to work for me. Could you check it? Jul 26, 2016 at 18:03
• @Mr.Wizard and rest, isn't it a reordering somewhere what causes that? _+n_ stays the same while a+3 is 3+a so repeated element is the first one, not the second like in pattern. This works well MatchQ[ f[a + 3, b + 3, c + 3], f[Verbatim[Plus][n_, _] ..] ] but I don't know how OS affects that.
– Kuba
Jul 26, 2016 at 18:35
• @march Here is your replacement rule compatible with Windows :P f[p : Verbatim[Plus][___, n_, ___] ..] :> n + f @@ ({p} - n). Please consider posting an answer.
– Kuba
Jul 26, 2016 at 18:40

Since the problem is specified without context, here is a very specific solution:

expr = f[a + 3, b + 3, c + 3, d + 3, e + 3];

Thread[expr, Plus] /. f[n_ ..] :> n

3 + f[a, b, c, d, e]


Leaving aside the curious question of pattern matching raised in the comments here is a baroque approach that should at least be applicable in a number of cases.

rep[a : f[__Plus]] :=
With[
{out = Plus @@ f @@@ Factor[Plus @@ Times @@@ (a /. n_?NumericQ :> Hold[n])]},
(out /. {Hold[n_] :> n, f[x_] :> x}) /; Length[out] == 2
]


Test:

f[a + 3, b + 3, c + 3, 3 + d] // rep
f[1 + x, 2 + x, 3 + x]        // rep
f[1 + x, 2 + x, x + y]        // rep

3 + f[a, b, c, d]

x + f[1, 2, 3]

x + f[y, 1, 2]


There must be a better way but I am too distracted by the patten matching issue to refine this now.

• Thanks! It works great for the question I posed. I added a second example to clarify what I had initially omitted to explain. Jul 26, 2016 at 18:28

Maybe this will fit your needs

ReplaceAll[
{
f[a + 3, b + 3, c + 3],
f[x + 3, x + 3, x + 1],
f[x + 2, y + 3, x + 1]
},
f[p__] :> With[{c = Intersection[p]}, c + f @@ ({p} - c)]
(*thanks to J.M.*)
]
]

{
3 + f[a, b, c],
x + f[3, 3, 1],
f[2 + x, 3 + y, 1 + x]
}


Earlier I overdid it with f[p__] :> With[{c = Plus @@ Intersection @@ (List @@@ {p})}, f @@ (# - c & /@ {p}) + c

• ...or, f[p__] :> With[{c = Intersection[p]}, c + f @@ ({p} - c)]. Jul 26, 2016 at 21:09
• @J.M. That is indeed better. I have overdid it because of some f values hanging around and messing with my code :)
– Kuba
Jul 26, 2016 at 21:28
• @J.M. I used your example, if that is not a problem :)
– Kuba
Jul 27, 2016 at 5:33
• I'm happy you did. Jul 27, 2016 at 6:35

With a typed pattern.

ClearAll[Evaluate[Context[] <> "*"]];
k = 1;
ReplaceAll[
{f[a + 1, b + 1, k + c], g[x - π, y - π, -π + z], h[u + 1, v + 2, w + 3]},
f_[p : ((_Symbol + n_?NumericQ) ..)] :> n + f[Sequence @@ Cases[{p}, _Symbol, 2]]
]

(* {1 + f[a, b, c], -π + g[x, y, z], h[1 + u, 2 + v, 3 + w]} *)


Hope this helps.