Htydjtk

Consider the following expression.

expr = {a, {b1, b2}, {c, {d1, d2}}};

One can get the levels in an expression as follows:

ClearAll[levels];

SetAttributes[levels, {HoldAllComplete}];

levels[expr_] := 

  Column @ Table[Level[expr, {level}, Heads -> True], {level, 0, Depth[expr]-1}];

levels[expr]

But when I look at the TreeForm of it expr

TreeForm[expr]

I don't see what I expected: the leaf count for this expression should be 10.

LeafCount[expr]

One can try to get the true level tree as follows:

Graph[

  {

    Sequence @@ (expr[UndirectedEdge]#& /@ {List, a, {b1, b2}, {c,{d1, d2}}}),

    Sequence @@ (expr[[2]][UndirectedEdge]#& /@ {List2, b1, b2}),

    Sequence @@ (expr[[3]][UndirectedEdge]#& /@ {List3, c, {d1, d2}}),

    Sequence @@ (expr[[3,2]][UndirectedEdge]#& /@ {List4, d1, d2})

  }, VertexLabels -> "Name"]

Is there a way to produce this graph for arbitrary expression?

Also, multiple vertices with the same name List get joined so I have to rename them to List1, List2, ..., etc. Is there a way to fix this while keeping the layout of the graph?
`
asically, I want to display heads at the same level as their parts, which is their true position in the tree.

GraphComputation`ExpressionGraph[expr /. List -> (List[List, ##] &)]

TreeForm[expr /. List -> (List[List, ##] &)]

rules = List @@@ SparseArray`ExpressionToTree[expr /. List -> (List[List, ##] &)];

edges = DirectedEdge @@@ (rules[[All, All, 2]] + 1);

vertices = Property[#2 + 1, {VertexLabels -> #3}] & @@@ DeleteDuplicates[Flatten[rules, 1]];



TreeGraph[vertices, edges, ImagePadding -> 40, ImageSize -> 600,  VertexSize -> Medium]

Update: An alternative approach is to use the original expression with ExpressionToTree and add new edges:

g1 = Graph[SparseArray`ExpressionToTree[{a, {b1, b2}, {c, foo[d1, d2]}}], 

  VertexLabels -> "Name", VertexLabelStyle -> 14, ImageSize -> 600]

newedges = # [DirectedEdge] 

    {Symbol[ToString[Head[First@Last[#]]] <> ToString[#[[2]]]]} & /@ 

   Select[VertexList[g1], Head[#[[1]]] === Symbol &];

VertexReplace[EdgeAdd[g1, newedges], v_ :> Last[v]]

Try the code

levelTree[expr_] := Replace[expr, {h_[x___] -> {h, x}}, {0, Infinity}];    

levelTree @ {a, {b1, b2}, {c, {d1, d2}}}    

which returns

{List, a, {List, b1, b2}, {List, c, {List, d1, d2}}}

A simple exmaple

levelTree[a b + c d]

which returns

{Plus, {Times, a, b}, {Times, c, d}}

I like the lispy variation

levelTree[expr_] := Replace[expr, (h : Except[List])[x___] -> {h, x}, {0, Infinity}];

levelTree @ plus[car[{1, 2}], cdr[{3, 4}]]

which returns

{plus, {car, {1, 2}}, {cdr, {3, 4}}}

Given any of these results, you can now use TreeForm or ExpressionGraph or some other custom Graph display.