How to replace the first Head of a currying expression like "a" in a[b,c][d]?

Question

How do we replace the first Head of a currying expression such as a[b,c][d]? When accessing the 0th element of an expression like a[b,c][d], a[b,c] is given as the Head. We would like to instead replace a with, say, w.

Answer 1

For arbitrarily nested heads I would use recursion and pattern matching, like this:

ClearAll[replaceFirstHead]
replaceFirstHead[head_[body___], newHead_] := replaceFirstHead[head, newHead][body]
replaceFirstHead[head_, newHead_] := newHead

replaceFirstHead[a[1][2][3][4, 5, 6], x]
(* x[1][2][3][4, 5, 6] *)

There is no need to test for _Symbol or _?AtomQ on the head but the order of definitions is critical.

I find this paradigm very natural for Mathematica. Pattern matching and multiple definitions are often more convenient than explicit If and explicit extraction or structure manipulation (Part, Head, ReplacePart, etc.)

---

As @Itai notes in the comments, this function will replace atomic expressions, e.g.

replaceFirstHead[1, x]

Whether this is desirable or not depends on the particular applications. The following wrapper can prevent this for atoms that cannot be decomposed into a head and arguments using pattern matching:

replaceFirstHead2[arg : _[___], newHead_] := replaceFirstHead[arg, newHead]
replaceFirstHead2[arg_, newHead_] := arg

Do keep in mind though that some atoms act as if they were compound in some pattern matching operations. The basic examples are Rational and Complex. Thus:

replaceFirstHead2[1/2, h]
(* h[1, 2] *)

replaceFirstHead2[I, h]
(* h[0, 1] *)

Other atoms cannot be decomposed by pattern matching, even though their InputForm appears compound. One example is Graph:

replaceFirstHead2[ Graph[{1 <-> 2}], h ]
(* output: unchanged graph *)

When dealing with atoms in Mathematica, there are no consistent rules. Therefore it is hard to make a clear decision about what should be considered the "correct behaviour". It is best to think about the particular way that this function will be used, and consider special cases.

The following wrapper simply prevents it from operating on any atom, but may not be the best solution for all applications:

replaceFirstHead3[atom_?AtomQ, newHead_] := atom
replaceFirstHead3[compound_, newHead_] := replaceFirstHead[compound, newHead]

Answer 2

y = a[b, c][d];
y[[0, 0]] = w;
y

(*  w[b, c][d]  *)

Answer 3

One can use Operate[] with Apply[]:

Operate[w @@ # &, a[b, c][d]]
 (*  w[b, c][d]  *)

Or leave out Apply and write:

Operate[w &, a[b, c][d], 2]
 (*  w[b, c][d]  *)

With deeper expressions:

Operate[w &, a[b][c][d], 3]
 (*  w[b][c][d]  *)

Answer 4

Update to add an actual reasonable solution

This is actually very straightforward with Position, if you limit it to returning only the first result when you match everything.

Pillsy`ReplaceFirstHead[expr_, new_] :=
 ReplacePart[expr, Position[expr, _, All, 1] -> new]

Old, silly approach

Nothing says clear, maintainable code like using ReplaceRepeated with a painstakingly ordered set of rules and Throw/Catch!

Pillsy`ReplaceFirstHead[expr_, new_] :=
 Module[{head, tail, reapply, end},
  Attributes[head] = Attributes[tail] = Attributes[reapply] =       
      {HoldAllComplete};
  Catch[ 
   expr //. {
     h : (Except[head | tail | reapply][x___]) :> head[h, head[]],
     head[h_[x___], link_head] :> head[h, head[link, tail[x]]], 
     head[_ : Except[head], h_head] :> reapply[new, h],
     reapply[h_, head[m_head, tail[x___]]] :>
       reapply[h[x], m],
     reapply[h_, head[m_head, tail[x___]]] :>
       reapply[h[x], m],
     reapply[x_, head[]] :> Throw[x, end]
     }, end]];

It works on a moderately convoluted test case, at least:

In[2]:= Pillsy`ReplaceFirstHead[a[1][2][3, x[y, z]][q[4, 5, 6], 7], x]
Out[2]= x[1][2][3, x[y, z]][q[4, 5, 6], 7]

Answer 5

Update 2: Fixed! (I believe)

With help from this answer.

Clear[replaceFirstHead]
replaceFirstHead[newHead_, expr_] := Module[{cond = True}
  , expr /. _Symbol[x__] :> newHead[x] /; If[cond, cond = False; True, False]
 ]
replaceFirstHead[newHead_][expr_] := replaceFirstHead[newHead, expr]

Then:

replaceFirstHead[w] /@ {a[y[z]][x[a]], a[b], z[b, c][d][e], x[y[z]]}
(* {w[y[z]][x[a]], w[b], w[b, c][d][e], w[y[z]]} *)

Update 3

And, because I'm having fun, here's a version that automates Mike Honeychurch's version using ideas from SquareOne's solution:

ClearAll[replaceFirstHead]
replaceFirstHead[newHead_, expr_] := Module[{y = expr}
  , y[[Sequence @@ ConstantArray[0, -3 + Length@FixedPointList[Head, y]]]] = newHead
  ; y
 ]

Update 1: not entirely general

Here is a situation in which this method breaks down, apparently:

replaceFirstHead[w][a[y[z]][x[a]]]
(* w[y[z]][w[a]] *)

The reason is that the [x[a]]] part is in some sense not a sub-expression of the entire expression, so a[y[z] gets replaced by w[y[z] and the y doesn't get replaced because it is "inside" the expression, whereas [x[a]]] is "attached", and so x gets replaced by w.

Original post

With replacement rules if the structure of the expression doesn't change:

a[b, c][d] /. _Symbol[x__][y_] :> w[x][y]
(* w[b, c][d] *)

I believe that this can be directly generalized:

a[b, c, d[e]][f, g][x][y, c] /. _Symbol[x__] :> w[x]
(* w[b, c, d[e]][f, g][x][y, c] *)

This takes advantage of the fact that once an expression has been modified, subexpressions of that expression can't be modified.

It can finally be functionalized:

Clear[replaceFirstHead]
replaceFirstHead[newHead_, expr_] := expr /. _Symbol[x__] :> newHead[x]
replaceFirstHead[newHead_][expr_] := replaceFirstHead[newHead, expr]

and

replaceFirstHead[w] /@ {a[b], z[b, c][d][e], a[b, c, d[e]][f, g][x][y, c]}
(* {w[b], w[b, c][d][e], w[b, c, d[e]][f, g][x][y, c]} *)

Answer 6

replaceFirstHead[expr_, newHead_Symbol] := 
 Apply[newHead, expr, {Length@FixedPointList[Head, expr] - 4}, Heads -> True]

then

replaceFirstHead[a[b], newhead]
replaceFirstHead[a[b][c, d], newhead]
replaceFirstHead[a[b][c, d][e], newhead]

newhead[b]  
newhead[b][c, d]  
newhead[b][c, d][e]

Answer 7

This works:

replaceFirstHead[expression_, replacement_] :=
 If[
  Head[expression] === Symbol,
  replacement,
  ReplacePart[
   expression,
   0 -> replaceFirstHead[expression[[0]], replacement]
   ]
  ]

Answer 8

MapAt[w&, #, Position[#, _][[1]]] & [a[b, c][d]]

w[b, c][d]

MapAt[x&, #, Position[#, _][[1]]] &[a[1][2][3][4, 5, 6]]

x[1][2][3][4, 5, 6]