I will include all parts of the algorithm that I want to be implemented, although it is really part 2 that I need help with (especially in the form discussed in the beginning of part 3).

I have homogeneous polynomials of the form say $x_1^2x_2x_3+ 2x_2^2x_3^2$. I'm looking to do the following to it:

  1. Find the monomial list of it, which is easily done with MonomialList[].
  2. Choose a monomial say $2x_2^2x_3^2$ which is (like every other monomial) of degree $4$. Transform the monomial into $$ 2x_2^2x_3^2\to 2x_2 x_2 x_3x_3\to 2x_{2,1}x_{2,2}x_{3,3}x_{3,4} $$ where the second transform takes the $i$th variable appearing, say it is $x_k$, and transforms it into $x_{k,i}$. In other words when $x_{k,j}$ appears in the final result, it means in the original monomial at position j, the variable $x_k$ happens. The final result $2x_{2,1}x_{2,2}x_{3,3}x_{3,4}$ is supposed to be an expression NOT just a display.

  3. In fact for the intermediate transformation $2x_2^2x_3^2\to 2x_2 x_2 x_3x_3$ it is convenient if it is done as $2x_2^2x_3^2\to \{2, \{x_2, x_2, x_3, x_3\}\}$. This is because later on in the algorithm I will need the average over over all permutations of $\{x_2, x_2, x_3,x_3\}$ in the following sense $$ 2x_2^2x_3^2\to \frac{1}{4!}\sum_{\sigma\in \mathrm{SymGrp}(4)} 2x_{2,\sigma(1)}x_{2,\sigma(2)}x_{3,\sigma(3)}x_{3,\sigma(4)} $$ I know how to do it if I have the list $\{x_2, x_2, x_3, x_3\}$.

  4. Finally we fix an integer $n>0$, make a table

Table[Subscript[x, i, j]-> Subscript[R,j]^i Subscript[S,j]^(n - i), {i, 3},{j,4}]

And after flattening it, we make a replacement via the condition defined above, which essentially replaces $x_{i,j}\to (R_j)^i (S_j)^{n-i}$. This is the final thing I'm looking for.

All the steps are straightforward for me, except step 2. I'm asking how to do step 2. However I shared the whole process because someone might have a better idea altogether.


3 Answers 3

f[expr_] := Block[{m = expr, v, e, t, c},
  v = Variables[m];
  e = Exponent[m, #] & /@ v;
  t = Transpose@{v, e};
  c = m/Times @@ (#[[1]]^#[[2]] & /@ t);
  {c}~Join~{Flatten[ConstantArray[##] & @@@ t]}

m = 5 x^2 y^3 z^4;



{5, {x, x, y, y, y, z, z, z, z}}

f1 = Block[{Times = List, Power = ConstantArray}, {First@#, Join @@ Rest@#}] &;

f1[5 x^2 y^3 z^4]

Mathematica graphics

f1@(5 Subscript[x, 1]^2 Subscript[x, 2]^3 Subscript[x, 3]^4)

Mathematica graphics

f2 = With[{lst = Block[{Times = List, Power = ConstantArray}, #]}, 
    Times[First@#, Times @@ MapIndexed[Subscript[#, #2[[1]]] &, Join @@ Rest@lst]] /. 
      Subscript[Subscript[a_, b_], c_] :> Subscript[a, Row[{b, ",", c}]]] &;


f2[5 x^2 y^3 z^4]

Mathematica graphics

f2[5 Subscript[x, 1]^2 Subscript[x, 2]^3 Subscript[x, 3]^4]

Mathematica graphics


Here is how to do your steps 1 and 2 all at once, using an undocumented function:

poly = x^2 y z + 2 y^2 z^2; vars = Variables[poly];
dtl = Reverse /@ First[GroebnerBasis`DistributedTermsList[poly, vars]];
MapAt[Flatten[MapThread[ConstantArray, {vars, #}]] &, dtl, {All, -1}]
   {{1, {x, x, y, z}}, {2, {y, y, z, z}}}

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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