1
$\begingroup$

I have lots of functions of the form $-x_4^2+x_0 x_4-x_1 x_3-x_5 x_7+x_1 x_{13}+x_2 x_{22}$ (this is $eq_4$ see below). I want to replace each pair $x_i x_j$ by $y_l=x_i x_j$. How is it possible to do it?

 Do[{i, j, k} = {0, 0, IntegerDigits[l, 3][[1]]}; 
 Co[i, j, k] = Subscript[x, l], {l, 0, 2, 1}]
Do[{i, j, k} = {0, IntegerDigits[l, 3][[1]], 
   IntegerDigits[l, 3][[2]]}; 
 Co[i, j, k] = Subscript[x, l], {l, 3, 8, 1}]
Do[{i, j, k} = {IntegerDigits[l, 3][[1]], IntegerDigits[l, 3][[2]], 
   IntegerDigits[l, 3][[3]]}; 
 Co[i, j, k] = Subscript[x, l], {l, 9, 26, 1}]
Do[lam = j 3^3 + k 3^2 + n 3 + s; 
 Subscript[eq, lam] = 
  Sum[Co[j, k, m]*Co[m, n, s] - Co[k, n, m]*Co[j, m, s], {m, 0, 2, 
    1}], {j, 0, 2, 1}, {k, 0, 2, 1}, {n, 0, 2, 1}, {s, 0, 2, 1}]

Here $eq_k$ are the expressions containing $x_ix_j$. Below I define $y[l]$

 l = 0;
 Do[Do[y[l] = Subscript[x, i] Subscript[x, j]; 
  l = l + 1, {j, i, 26}], {i, 0, 26}]
$\endgroup$
  • $\begingroup$ Easiest way is probably using Eliminate. $\endgroup$ – Thies Heidecke Nov 30 '18 at 17:22
  • $\begingroup$ You can generate the replacement equations via replacementeqs=With[{indices = {0, 1, 3, 4, 5, 7, 13, 22}}, Equal @@@ (Transpose[{y /@ Range[Length[#]], #}] &[ Times @@@ Tuples[Table[x[i], {i, indices}], 2]])]. Rest should be relatively straight forward. $\endgroup$ – Thies Heidecke Nov 30 '18 at 17:44
1
$\begingroup$
Do[{i, j, k} = {0, 0, IntegerDigits[l, 3][[1]]};
 Co[i, j, k] = Subscript[x, l], {l, 0, 2, 1}]
Do[{i, j, k} = {0, IntegerDigits[l, 3][[1]], IntegerDigits[l, 3][[2]]};
 Co[i, j, k] = Subscript[x, l], {l, 3, 8, 1}]
Do[{i, j, k} = {IntegerDigits[l, 3][[1]], IntegerDigits[l, 3][[2]], 
   IntegerDigits[l, 3][[3]]};
 Co[i, j, k] = Subscript[x, l], {l, 9, 26, 1}]
Do[lam = j 3^3 + k 3^2 + n 3 + s;
 Subscript[eq, lam] = 
  Sum[Co[j, k, m]*Co[m, n, s] - Co[k, n, m]*Co[j, m, s], {m, 0, 2, 
    1}], {j, 0, 2, 1}, {k, 0, 2, 1}, {n, 0, 2, 1}, {s, 0, 2, 1}]
p = Flatten[Table[Subscript[x, i] Subscript[x, j] -> y[i + j],
    {j, 1, 26}, {i, 1, 26}]];
 Subscript[eq, 0] /. p

(*Out[]= -y[4] - y[8] + y[10] + y[20]*)

 Subscript[eq, 80] /. p

(*Out[]= y[32] + y[42] - y[44] - y[48]*)
| improve this answer | |
$\endgroup$
  • $\begingroup$ Thanks. However, your definition of y[k] (Subscript[x, i] Subscript[x, j] -> y[i + j]) doesnt coincide with mine. Is it possible to mix loop and table? $\endgroup$ – Chipa-Chipa Dec 1 '18 at 8:51
  • 1
    $\begingroup$ @Chipa-Chipa I just showed how to use the rule xx->y. You can use any rule that does not violate symmetry $x_ix_j=x_jx_i$. $\endgroup$ – Alex Trounev Dec 1 '18 at 11:06
0
$\begingroup$

Define equations

 Do[{i, j, k} = {0, 0, IntegerDigits[l, 3][[1]]}; 
 Co[i, j, k] = Subscript[x, l], {l, 0, 2, 1}]
Do[{i, j, k} = {0, IntegerDigits[l, 3][[1]], 
   IntegerDigits[l, 3][[2]]}; 
 Co[i, j, k] = Subscript[x, l], {l, 3, 8, 1}]
Do[{i, j, k} = {IntegerDigits[l, 3][[1]], IntegerDigits[l, 3][[2]], 
   IntegerDigits[l, 3][[3]]}; 
 Co[i, j, k] = Subscript[x, l], {l, 9, 26, 1}]
Do[lam = j 3^3 + k 3^2 + n 3 + s; 
 Subscript[eq, lam] = 
  Sum[Co[j, k, m]*Co[m, n, s] - Co[k, n, m]*Co[j, m, s], {m, 0, 2, 
    1}], {j, 0, 2, 1}, {k, 0, 2, 1}, {n, 0, 2, 1}, {s, 0, 2, 1}]

Define rules

sss = {}; l = 0;
Do[Do[AppendTo[sss, Subscript[x, i] Subscript[x, j] -> y[l]]; 
   l = l + 1, {j, i, 26}], {i, 0, 26}];

New equations in terms of the new variables

Do[Subscript[eqq, k] = Subscript[eq, k] /. sss, {k, 0, 80}];
| improve this answer | |
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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