Какой самый простой способ построить дерево разложения в Mathematica?

Question

Я бы хотел построить «дерево разложения» в Mathematica.

У меня есть функция f, которая принимает объект и возвращает все компоненты этого объекта в виде списка. Для целей этого вопроса, давайте просто разложим выражения Mathematica следующим образом (мой фактический f полагается на внешнюю базу данных для разложения различных типов объектов, поэтому я не могу легко опубликовать это):

f[e_?AtomQ] := {}
f[e_] := List @@ e

Я хотел бы создать древовидный график, который показывает, как объект декомпозируется, поскольку мы рекурсивно продолжаем применять f. Для конкретного примера f выше мы должны получить что-то очень похожее на вывод TreeForm, за исключением того, что полное выражение должно отображаться (а не просто голова) на каждом узле. Дочерние узлы будут его компонентами, которые будут возвращены f.

Обратите внимание, что элементы могут повторяться в дереве декомпозиции, как это, но элементы не повторяются при выводе TreePlot, так как он работает с графиками. Одна из идей заключается в том, чтобы сгенерировать уникальное «внутреннее имя» для каждого узла, построить график и использовать TreePlot, задав для него отображение фактической формы узлов, а не их «внутреннего имени»

Answer 1

Как насчет этого?

tf[x_] := f[x] /. {{} :> x, r_ :> x @@ tf /@ r}

Если какое-либо из терминов не является инертным, этот «простой» (?) Подход не будет работать.

Answer 2

Я не уверен, что он отвечает на ваш вопрос, но вот как я бы реализовал элементарную TreeForm:

decompose[expr_?AtomQ] := expr
decompose[expr_] := Block[{lev = Level[expr, {1}]},
  Sow[Thread[expr -> lev]]; decompose /@ lev;]

treeForm[expr_] := Reap[decompose[expr]][[-1, 1]] // Flatten

Тогда:

EDIT Да, вы правы, это не дерево. Чтобы сделать его деревом, каждое выражение должно иметь свою позицию. Вроде как так:

ClearAll[treePlot, node, decompose2];
SetAttributes[{treePlot, node, decompose2}, HoldAll];
decompose2[expr_] /; AtomQ[Unevaluated[expr]] := node[expr];
decompose2[expr_] := Module[{pos, list},
  pos = SortBy[
    Position[Unevaluated[expr], _, {0, Infinity}, Heads -> False], 
    Length];
  list = Extract[Unevaluated[expr], pos, node];
  list = MapThread[Append, {list, pos}];
  ReplaceList[
   list, {___, node[e1_, p1_], ___, node[e2_, p2_], ___} /; 
     Length[p2] == Length[p1] + 1 && 
      Most[p2] == p1 :> (node[e1, p1] -> node[e2, p2])]
  ]

Тогда

treePlot2[expr_] := 
 Module[{data = decompose2[a^2 + Subscript[b, 2] + 3 c], gr, vlbls},
  gr = Graph[data];
  vlbls = Table[vl -> (HoldForm @@ {vl[[1]]}), {vl, VertexList[gr]}];
  Graph[data, VertexLabels -> vlbls, ImagePadding -> 50]
  ]