Getting the "root" Head

Question

I have a dynamic list of function names, like {f1, f2, f3, ...}, and they will enter in computation in various forms f1[_][_,_,_], f2[_,_], ..., etc.

I am hoping for a function to automatically extract their root function names f1, f2, ...; so far I am brute-force checking if Head[exp] or Nest[Head, exp, 2], ... but clearly it's ugly.

Answer 1

With a few functions to try, defined in differentfunctions, try this headF:

differentfunctions = {f1[a][x, y], f2[a, b, c], f3[a, 2][3]};
headF = FixedPointList[Head, #][[-3]] &;

headF /@ differentfunctions

(* Out: {f1, f2, f3} *)

It relies on the fact that, at some point, repeated application of Head will return Symbol, and head of Symbol is also Symbol, so repeated application gets to a fixed point. You then extract the last head before Symbol was returned, which is the third-from-last element returned by FixedPointList (the last two always being the same, and equal to the fixed point value).

Answer 2

You may use ReplaceRepeated.

With

differentfunctions = {f1[a][x, y], f2[a, b, c], f3[a, 2][3]};

Then

ReplaceRepeated[h_[___] :> h] /@ differentfunctions

{f1, f2, f3}

Hope this helps.

Answer 3

There is a built-in function BoxForm`UltimateHead that extracts the head wrapped with HoldComplete. So wrapping the output from this function with ReleaseHold gives the desired result:

topHead = ReleaseHold @* BoxForm`UltimateHead;

topHead /@ {f1[a][x, y], f2[a, b, c], f3[a, 2][x, y, g[z][1, 2, 3]]}

{f1, f2, f3}

Answer 4

Another solution:

head[e_Symbol] := e
head[e_] := head@Head@e

head /@ {f1[a][x, y], f2[a, b, c], f3[a, 2][3]}
(* {f1,f2,f3} *)

Answer 5

I think Level might be the purest way to handle this.

dh = Level[#, {-1}, # &, Heads -> True] &;

dh /@ {f1[a][x, y], f2[a, b, c], f3[a, 2][3]}

{f1, f2, f3}

---

Other perhaps useful or entertaining methods:

lst = {f1[a][x, y], f2[a, b, c], f3[a, 2][3]};

Scan[Return, #, {-1}, Heads -> True] & /@ lst

Do @ MapAll[Break, #, Heads -> True] & /@ lst

# ~Extract~ Position[#, _, {-1}, 1][[1]] & /@ lst

FirstCase[#, _, , {-1}, Heads -> True] & /@ lst

Catch @ Operate[Throw@*#0, #] & /@ lst

Answer 6

Another approach (with Mr.Wizard's suggestion of x_?AtomQ instead of x_Symbol):

f[x][y][z] /. x_?AtomQ :> Return[x, ReplaceAll]
(*  f  *)

Function:

rootHead = # /. x_?AtomQ :> Return[x, ReplaceAll] &;

MarcoB's examples:

lst = {f1[a][x, y], f2[a, b, c], f3[a, 2][3]};

rootHead /@ lst
(*  {f1, f2, f3}  *)

Answer 7

NestWhile

rootHead = NestWhile[Head, #, # =!= Symbol &, 1, ∞, -1] &;

rootHead /@ {f1[a][x, y], f2[a, b, c], f3[a, 2][3]}

{f1, f2, f3}