5
$\begingroup$

I am having difficulty in improving some code. I have written the following code, which I think is not efficient at all. First I define some variables using table:

vars = Table[
If[i <= j + 2 && Mod[i + j, 2] == 0, Subscript[p, i, j], 0], {i, 1, 
7}, {j, 1, 3}]

The output is

{{Subscript[p, 1, 1], 0, Subscript[p, 1, 3]}, {0, Subscript[p, 2, 2], 
0}, {Subscript[p, 3, 1], 0, Subscript[p, 3, 3]}, {0, Subscript[p, 4,
 2], 0}, {0, 0, Subscript[p, 5, 3]}, {0, 0, 0}, {0, 0, 0}}

The point here is that I am only allowed to use $p_{i,j}$ for some specific values of $i$ and $j$.

Now that I have defined my variables, I want to find all monomials of degree 2 in these variables, such that the sum of the first indices is 8 and the sum of the second indices is 6. I am not allowed to use $p_{1,1}$ by the way. So $p_{3,3}p_{5,3}$ is an example (actually this is the only possibility). The code I am using is

polynomials1 = 
DeleteDuplicates[
DeleteCases[
Flatten@Table[
 If[i + k == 8 && j + l == 6 && i + j > 2 && k + l > 2 , 
  vars[[i, j]]*vars[[k, l]], 0], {i, 1, 7}, {j, 1, 
  3}, {k, 1, 7}, {l, 1, 3}], 0]]

The first two conditions in the If statement are the ones I stated above, the last two statements prohibits the usage of $p_{1,1}$.

This gives the desired output, namely $p_{3,3}p_{5,3}$, but I can see that it is not efficient. This is because the variables $p_{i,j}$ commute with themselves. For example, $i=3,j=3$ and $k=5,l=3$ and $i=5,j=3$ and $k=3,l=3$ give the same solution.

If I want to this for monomials of higher degree, then it becomes slow very quickly (at degree 5 it becomes really slow). How can we calculate this in a more efficient way?

$\endgroup$
5
$\begingroup$

This might do the trick, sorry for the slightly terse code...

First generate all valid subscript pairs:

vars = Select[Flatten[Table[{i, j}, {j, 1, 3}, {i, j + 2}], 1], EvenQ[Total[#]] &]

{{1, 1}, {3, 1}, {2, 2}, {4, 2}, {1, 3}, {3, 3}, {5, 3}}

Next pick those pairs (change the 2 to 5 for degree five monomials) whose sums give the totals 8 and 6. Note that the use of Subsets prevents duplicate symmetric solutions.

valid = Select[Subsets[vars, {2}], Total[#] == {8, 6} &]

{{{3, 3}, {5, 3}}}

Finally, if you wish, format the output back into your $p_{i,j}$ style:

out = (Times @@ Function[{l}, Subscript[p, Sequence @@ l]] /@ #) & /@  valid

{Subscript[p, 3, 3] Subscript[p, 5, 3]}

Faster Middle Step

If you scale up to $i,j \le 7$ and looking for fifth order monomials you might notice the middle step slowing down.. This is much faster:

s = Subsets[vars, {2}];
valid = s[[Flatten@Position[Total /@ s, {8, 6}]]];

In total:

order = 5;
target = {13, 11};

RepeatedTiming[
 vars = Select[Flatten[Table[{i, j}, {j, 1, 7}, {i, j + 2}], 1], EvenQ[Total[#]] &];
 s = Subsets[vars, {order}];
 valid = s[[Flatten@Position[Total /@ s, target]]];
 out = (Times @@ Function[{l}, Subscript[p, Sequence @@ l]] /@ #) & /@ valid;
]
$\endgroup$
  • 1
    $\begingroup$ +1, I was thinking in the same manner. But: there's a requirement that $p_{1,1}$ cannot be used, so I suggest DeleteCases or sth to delete {1,1} from the Subsets. $\endgroup$ – corey979 Nov 17 '16 at 22:46
  • $\begingroup$ Thanks, I think I understand this. $\endgroup$ – Badshah Nov 17 '16 at 22:52
  • $\begingroup$ Actually, this also uses $p_{1,1}$ in the polynomials if I look at degree 5... $\endgroup$ – Badshah Nov 18 '16 at 8:55
  • $\begingroup$ I just found out that it also does not cover the cases where the monomials can have powers of a variable. $\endgroup$ – Badshah Nov 18 '16 at 9:01
5
$\begingroup$

working with the given Subscript form:

mon = Join[Subsets[#, {2}], {#, #} & /@ # ] &@
   Cases[vars, _Subscript, 2];

enter image description here

Times @@@ 
  Select[ mon , 
    Plus @@ #[[All, 2]] == 8 && 
    Plus @@ #[[All, 3]] == 6 && 
    Plus @@ #[[1, 2 ;;]] > 2 &&
    Plus @@ #[[2, 2 ;;]] > 2 & ]

{Subscript[p, 3, 3] Subscript[p, 5, 3]}

note the trick to pulling the indices back out of Subscript objects:

vars[[1, 3]] 

enter image description here

If you take parts, the first part is the symbol p and the indices are parts 2&3:

vars[[1,3]][[{2,3}]] 

{1,3}

note an alternate way to construct your vars array:

vars = SparseArray[ {i_, j_} /; (i <= j + 2 && Mod[i + j, 2] == 0) -> 
   Subscript[p, i, j], {7, 3}]
$\endgroup$
  • $\begingroup$ I am new to Mathematica and I dont really understand your code. If you could explain how your code works, I would really appreciate. $\endgroup$ – Badshah Nov 17 '16 at 22:51

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.