Make loop more efficient

Question

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?

Answer 1

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;
]

Answer 2

working with the given Subscript form:

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

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]] 

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}]