16
$\begingroup$

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.

$\endgroup$
12
$\begingroup$

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]
$\endgroup$
  • $\begingroup$ What do you mean by "order of definitions"? $\endgroup$ – user Oct 27 '15 at 14:49
  • $\begingroup$ @user The order in which you issue the two definitions for replaceFirstHead. Well, it turns out I was wrong in this case, as Mathematica considers the first one to be more specific. But in general, the ordering matters. The points is that the replaceFirstHead[head_[body___], newHead_] transformation must be tried before the replaceFirstHead[head_, newHead_] := newHead one. $\endgroup$ – Szabolcs Oct 27 '15 at 15:02
  • 4
    $\begingroup$ I'd argue this isn't quite right, since for any atom, replaceFirstHead[atom,x] would return x rather than atom. But it's easy enough to create a wrap function which only applies these definitions if its argument is not atomic (or not _String | _Symbol | _?NumberQ depending on how you feel about fake atomic things like SparseArray). $\endgroup$ – Itai Seggev Aug 18 '17 at 0:33
  • $\begingroup$ @ItaiSeggev I updated the answer. $\endgroup$ – Szabolcs Aug 18 '17 at 8:42
16
$\begingroup$
y = a[b, c][d];
y[[0, 0]] = w;
y

(*  w[b, c][d]  *)
$\endgroup$
  • $\begingroup$ This works with held expressions, too! $\endgroup$ – Mr.Wizard Feb 6 '17 at 19:25
8
$\begingroup$

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]  *)
$\endgroup$
  • $\begingroup$ This doesn't work on expressions like a[b][c][d] where the depth is more than two. $\endgroup$ – user Oct 26 '15 at 22:29
  • 1
    $\begingroup$ Then you should have mentioned that you were also interested in things like that in your question. Anyway... Operate[w @@ # &, a[b][c][d], 2]. $\endgroup$ – J. M. is away Oct 26 '15 at 22:31
  • $\begingroup$ Operate does allow for a little different take on my answer replaceFirstHead[expression_, replacement_] := If[ Head[expression] === Symbol, replacement, Operate[replaceFirstHead[#, replacement] &, expression] ] $\endgroup$ – user Oct 26 '15 at 22:42
  • $\begingroup$ I'm of the opinion that one should strive for a nonrecursive route: Operate[w @@ # &, #, Length[FirstPosition[#, a]] - 1] & /@ {a[b, c][d], a[b][c][d]}. $\endgroup$ – J. M. is away Oct 26 '15 at 22:49
6
$\begingroup$

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]
$\endgroup$
  • $\begingroup$ Your "actual reasonable solution" should be the Accepted answer to this problem IMHO. To make this fully flexible one may like to add Unevaluated i.e. fn[expr_, new_] := ReplacePart[Unevaluated @ expr, Position[Unevaluated @ expr, _, All, 1] -> new] $\endgroup$ – Mr.Wizard Feb 6 '17 at 19:34
  • 1
    $\begingroup$ Using Position here is really clever. Good one! $\endgroup$ – Sjoerd Smit Aug 18 '17 at 9:09
6
$\begingroup$

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]} *)
$\endgroup$
3
$\begingroup$
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]
$\endgroup$
2
$\begingroup$

This works:

replaceFirstHead[expression_, replacement_] :=
 If[
  Head[expression] === Symbol,
  replacement,
  ReplacePart[
   expression,
   0 -> replaceFirstHead[expression[[0]], replacement]
   ]
  ]
$\endgroup$
0
$\begingroup$
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]

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.