Transformation rule for arbitrary number of argument expressions

Question

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.

Answer 1

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.

Answer 2

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

Answer 3

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.