How to mark leaves of polynomial based on its position in tree

Question

I've been struggling with this for a few days, and so I thought I might ask this here. Part of the problem lies in the fact that I do not even know the mathematical solution, which runs the risk of this question falling out of the scope of this site. Nevertheless, I'll proceed:

Consider this unexpanded polynomial of Symbols constructed out of heads Plus and Times only:

poly = ((a + b) (c + d (e + f)) + (g + h) i) j + k

What I'd like to do: Without expanding the polynomial, mark the leaves of the polynomial by integers based on its position in the tree. This labeling of leaves must have the property such that

1. When Expanded, each factor in each term is given a unique label
2. No more labels are used than necessary for the whole polynomial (number of distinct labels equals overall order of polynomial in all its variables).

For poly, a solution is

((a[1] + b[1]) (c[2] + d[2] (e[3] + f[3])) + (g[2] + h[2]) i[1]) j[0] + k[0]

The result is not unique, but observe that the expanded form satisfies both requirements 1 and 2.

a[1] c[2] j[0] + b[1] c[2] j[0] + a[1] d[2] e[3] j[0] + 
  b[1] d[2] e[3] j[0] + a[1] d[2] f[3] j[0] + b[1] d[2] f[3] j[0] + 
  g[2] i[1] j[0] + h[2] i[1] j[0] + k[0]

It is not necessary that terms with fewer factors use specific labels in any order: for example a labeling of the polynomial in which the 2nd last term of the expanded form is h[1] i[3] j[0] (missing label 2) or in which the last term is k[2] is acceptable.

Moreover I'd like a solution that is faster than just expanding the polynomial and labeling each term.

---

My original attempt was based on traversing the tree,

and raising/lowering the value of the label based on whether it passes through Plus or Times. Unfortunately, none of my solutions based on this give the correct answer.

Answer 1

Here's a first attempt, I wouldn't be surprised if a sufficiently complicated monomial group fails to expand under this:

First, a helper function: We need to be able to determine the order of a polynomial in a multiplication term to determine how many indices to allocate for that term:

polyorder[p__Plus] := Max[polyorder[#] & /@ (List @@ p)];
polyorder[Times[k_?NumericQ, p__]] := polyorder[Times[p]];
polyorder[p__Times] := Total[polyorder /@ (List@@p)];
polyorder[b_^e_] := e;
polyorder[p_Symbol] := 1;
polyorder[p_?NumericQ] := 0;

polyorder solves that problem by exhaustive pattern matching: sums do not increase order, they simply match the highest order of their members. Numeric constants do not contribute to multiplicative order. Multiplicative order is determined by a combination of the highest order in all multiplication terms plus the number of terms added. The order of a power is the exponent. The order of a lone symbol is 1, and the polynomial order of a number is 0.

Then, in a similar recursive form, we can define a labeling function:

polylabel[x__Plus, n_] := Plus @@ (polylabel[#, n] & /@ (List @@ x));
polylabel[Times[k_?NumericQ, x__], n_] := k polylabel[Times[x], n];
polylabel[x__Times, n_] := Block[{o = n},
   Times @@ 
    Table[(o = #2 + polyorder[#1]; polylabel[#1, #2]) &[iter, o],
     {iter, List @@ x}
     ]
   ];
polylabel[b_^e_, n_] := 
   Times @@ Table[polylabel[b, n + polyorder[b] (iter - 1)], {iter, 1, e}];
polylabel[x_Symbol, n_] := x[n];
polylabel[x_?NumericQ, n_] := x;

This recursively expands the tree of the expression over Plus and Times. All members of the same sum receive the same index, since they will never be multiplied with each other. Within a Times block, sufficient indices are allocated for the order of the expression. Finally, when a lone symbol is encountered, the label is baked in and the fully labeled expression is returned.

Usage of this function is:

polylabel[poly, 0]

a[0] c[1] j[3] + b[0] c[1] j[3] + a[0] d[1] e[2] j[3] + 
  b[0] d[1] e[2] j[3] + a[0] d[1] f[2] j[3] + b[0] d[1] f[2] j[3] + 
  g[0] i[1] j[3] + h[0] i[1] j[3] + k[0]

This is not the same labeling as your given example, but all labels in each term are unique for this polynomial (and the few others I've tried).

Answer 2

MinimumVertexColoring

Constructing an adjacency graph (two variables are adjacent if they appear in the same term in the expansion of the polynomial) and using MinimumVertexColoring (from the Combinatorica` package) to identify a minimum labeling of the variables in the polynomial:

Needs["Combinatorica`"]
minimumLabeling = Module[{al = Variables /@ Expand[#] /. Plus -> List, edges, ag},
   edges = DeleteDuplicates[UndirectedEdge @@@ (Join @@ (Subsets[#, {2}] & /@ al))];
   ag = FromAdjacencyMatrix@Normal[AdjacencyMatrix[System`Graph[Variables[#], edges]]];
   # /. (Thread[Variables[#] -> MinimumVertexColoring[ag] - 1] /. 
     Rule[a_, b_] :> Rule[a, a[b]])] &;

Examples:

minimumLabeling @ poly

((a[0] + b[0]) (c[1] + d[1] (e[3] + f[3])) + (g[0] + h[0]) i[1]) j[ 2] + k[0]

Expand @ minimumLabeling @ poly

a[0] c[1] j[2] + b[0] c[1] j[2] + a[0] d[1] e[3] j[2] + b[0] d[1] e[3] j[2] + a[0] d[1] f[3] j[2] + b[0] d[1] f[3] j[2] + g[0] i[1] j[2] + h[0] i[1] j[2] + k[0]

minimumLabeling[(a + b) (a + b)]

(a[0] + b[1])^2

Expand @ minimumLabeling[(a + b) (a + b)]

a[0]^2 + 2 a[0] b[1] + b[1]^2

Note: For versions 10+, one can use the function IGMinimumVertexColoring in @Szabolcs's IGraph/M package (see this answer).