# 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? – march Jul 26 '16 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. – march Jul 26 '16 at 18:01
• @march Your proposed replacement doesn't seem to work for me. Could you check it? – MarcoB Jul 26 '16 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 '16 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 '16 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. – olafur Jul 26 '16 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)]. – J. M.'s discontentment Jul 26 '16 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 '16 at 21:28
• @J.M. I used your example, if that is not a problem :) – Kuba Jul 27 '16 at 5:33
• I'm happy you did. – J. M.'s discontentment Jul 27 '16 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.