1
$\begingroup$

I'm wondering how to speed up the following code so it actually computes for $n=2$:

f[n_] := Expand[Sum[FunctionExpand[QBinomial[n, j, q]]*q^(j^2), {j, 0, n}]]

lhs[n_] := Sum[(-1)^j*q^(j(5j + 1)/2), {j, -n, n}]

rhs3[a_, b_, c_, d_, e_, g_, h_] := 
  Expand[q^a - f[1]*q^b*Product[1 - q^i, {i, c, d}] + f[2]*q^e*Product[1 - q^i, {i, g, h}]]

B[n_] := 
  Do[
    If[CoefficientList[lhs[n], q] == CoefficientList[rhs3[a_, b_, c_, d_, e_, g_, h_], q], 
      Print[{a,b,c,d,e,g,h}]], 
    {a, 0, 15}, {b, 0, 15}, {c, 1, 5}, {d, 1, 5}, {e, 0,15}, {g, 1, 5}, {h, 1, 5}]

A Do loop with this many iterators may be too much computing, but there must be some built-in constructs which allow for an effective implementation.

Sample input would be B[2]. Sample output would be {11,1,1,1,1,2,3} (which is actually one possible solution. However, the point is to print all possible solutions, so the actual output would be a number of such lists.)

Edit:

I want to emphasize that I would like to see an approach that will work for more complicated functions for rhs3[a_, ...] that involve a few more iterator variables. To be specific, I would like to execute the comparison at least somewhat quickly for the following RHS with $n=3$ (and I'll label it as rhs3):

rhs3[a_, b_, c_, d_, e_, g_, h_, j_, k_, l_, x_, r_, y_] := 
  Expand[-f[3*x + y]*q^a + f[3*x + r + y]*q^b*Product[1 - q^i, {i, c, d}] 
    - f[3*x + 2*r + y]*q^e*Product[1 - q^i, {i, g, h}]] 
      + f[3*x + 3*r + y]*q^j*Product[1 - q^i, {i, k, l}]]

with the following variable ranges: {a, 0, 30}, {b, 0, 25}, {c, 1, 7}, {d, c, 7}, {e, 0, 20}, {g, 1, 7}, {h, g, 7}, {j, 0, 15}, {k, 1, 7}, {l, k, 7}, {x, 0, 5}, {r, -5, 5}, {y, -5, 5}. This is of course asking for a lot, but I want to state the nature of the problem in full generality for future visitors.

||improve this question
$\endgroup$
  • $\begingroup$ You could clarify the question by adding a sample input together with the desired output. $\endgroup$ – Yves Klett Jun 17 '14 at 15:43
  • $\begingroup$ You don't define lhs. $\endgroup$ – m_goldberg Jun 17 '14 at 17:37
  • $\begingroup$ Sure, but you might attract more takers if the gist of the question (as hinted at in the title) is immediately obvious in a MWE. This would also make it possibly more useful for future visitors. $\endgroup$ – Yves Klett Jun 17 '14 at 18:03
  • 1
    $\begingroup$ There are 16^3 5^4 == 2560000 iterations. Calculating and comparing the coefficient lists takes an average of 0.001110 sec. each (the average over the first five seconds worth) on my MacBook Pro. That gives an estimate of over 2800 seconds of running time to do all the comparisons. To be faster than that, it seems you would have to speed up the calculation of the coefficient lists, which I don't know how to do. $\endgroup$ – Michael E2 Jun 17 '14 at 18:27
  • 1
    $\begingroup$ Your Do iterators can depend on those to the left, ie. Do[ ... {g,1,5},{h,g,5} ] to get only h>=g $\endgroup$ – george2079 Jun 17 '14 at 18:41
2
$\begingroup$

You had the right idea..: work with a specific q:

 rhs32[a_, b_, c_, d_, e_, g_, h_] := 
        With[{q = 2}, 
            Expand[q^a - f[1]*q^b*Product[1 - q^i, {i, c, d}] + 
             f[2]*q^e*Product[1 - q^i, {i, g, h}]]]

 (list = Flatten[
        Table[{{a, b, c, d, e, g, h}, rhs32[a, b, c, d, e, g, h]}, {a, 0,15},
           {b, 0, 15}, {c, 1, 5}, {d, c, 5}, {e, 0, 15},
           {g, 1, 5}, {h, g, 5}], 6]) // AbsoluteTiming // First

352.067372 ( 6 minutes )

Now find possible matches to lhs'[n]

  pmatch = Select[list, #[[2]] == (lhs[2] /. q -> 2) & ]

{{{3, 1, 1, 3, 0, 3, 4}, 2549},
   {{7, 1, 1, 1, 0, 3, 4}, 2549},
   {{9, 0, 3, 5, 4, 1, 3}, 2549},
   {{11, 1, 2, 2, 0, 2, 3},2549}}

now go back and check analytically:

 Select[ {#[[1]], CoefficientList[rhs3 @@ #[[1]], q]} & /@ 
       pmatch , #[[2]] === CoefficientList[lhs[2], q] &]

{{{11, 1, 2, 2, 0, 2, 3}, {1, 0, -1, -1, 0, 0, 0, 0, 0, 1, 0, 1}}}

||improve this answer
$\endgroup$
  • $\begingroup$ no, that's the value of lhs[2] with q=2 . That Table takes a few minutes but not unreasonable (and note you only do it once, not for each n. ) $\endgroup$ – george2079 Jun 17 '14 at 19:08
  • $\begingroup$ Ok six minutes is not unreasonable, but it quickly becomes unreasonable once I introduce three more parameters and a function with one more Product (which I don't think is asking too much from Mathematica.) Any ways to shave off some time here? This is still much in the same vein as what I proposed in my original post. Is Mathematica really not designed to handle simple guessing problems like this? $\endgroup$ – Jonny Jun 17 '14 at 21:49
  • $\begingroup$ This needs about 10 seconds: AbsoluteTiming[f[n_, q_] := f[n, q] = Expand[Sum[FunctionExpand[QBinomial[n, j, q]]*q^j^2, {j, 0, n}]]; lhs[n_, q_] := lhs[n, q] = Sum[(-1)^j*q^(j*((5*j + 1)/2)), {j, -n, n}]; rhs32[q_, a_, b_, c_, d_, e_, g_, h_] := Expand[q^a - f[1, q]*q^b*Product[1 - q^i, {i, c, d}] + f[2, q]*q^e*Product[1 - q^i, {i, g, h}]]; list = Flatten[ParallelTable[{{a, b, c, d, e, g, h}, rhs32[2, a, b, c, d, e, g, h]}, {a, 0, 15}, {b, 0, 15}, {c, 1, 5}, {d, c, 5}, {e, 0, 15}, {g, 1, 5}, {h, g, 5}], 6]; pmatch = Select[list, #1[[2]] == lhs[2, 2] & ]] $\endgroup$ – Rolf Mertig Jun 18 '14 at 11:05
  • $\begingroup$ It still takes a long time to generate the following table: rhs23[a_, b_, c_, d_, e_, g_, h_, j_, k_, l_] := With[{q = 2}, Expand[-q^a + f[1]*q^b*Product[1 - q^i, {i, c, d}] - f[2]*q^e*Product[1 - q^i, {i, g, h}] + f[3]*q^j*Product[1 - q^i, {i, k, l}]]]; list = Flatten[ParallelTable[{{a, b, c, d, e, g, h, j, k, l}, rhs23[a, b, c, d, e, g, h, j, k, l]}, {a, 0, 25}, {b, 0, 15}, {c, 1, 10}, {d, c, 10}, {e, 0, 15}, {g, 1, 10}, {h, g, 10}, {j, 0, 5}, {k, 1, 10}, {l, k, 10}], 9] // AbsoluteTiming $\endgroup$ – Jonny Jun 18 '14 at 14:12
  • $\begingroup$ By how much is Parallel supposed to cut down the time? Because I ran what was in the previous comment overnight using george2079's approach with no success. $\endgroup$ – Jonny Jun 18 '14 at 14:31
2
$\begingroup$

As you suggested and @george2079 showed, using a specific value of q can help avoid the slowness of CoefficientList by eliminating many cases. Compiling can speed up the process more -- well, a lot more on a 4(8)-core i7.

Here params represents {a, b, c, d, e, g, h}. The values to iterate through are stored in iter. We use Pick to pick out the one(s) for which equality holds. The coefficients can be checked

Clear[bC];

bC = With[{f1 = f[1], f2 = f[2], lhs2 = lhs[2], prod0 = 1 - q^# & /@ Range[5]},
   Compile[{{q, _Integer}, {params, _Integer, 1}},
    Module[{prod = prod0},
     If[params[[3]] > params[[4]] || params[[6]] > params[[7]],
      1,                              (* nonzero for out-of-order parameters *)
      q^params[[1]] -                 (* rhs - lhs *)
       Fold[#1*#2 &, f1*q^params[[2]], 
        prod[[ params[[3]] ;; params[[4]] ]] ] + 
       Fold[#1*#2 &, f2*q^params[[5]], 
        prod[[ params[[6]] ;; params[[7]] ]] ] - lhs2]
     ],
    RuntimeAttributes -> {Listable}, Parallelization -> True]
   ];

(iter = Tuples[{Range[0, 15], Range[0, 15], Range[5], Range[5], 
     Range[0, 15], Range[5], Range[5]}];
 Pick[iter, bC[3, iter], 0]) // AbsoluteTiming
(*
  {1.415915, {{11, 1, 2, 2, 0, 2, 3}}}
*)

CoefficientList[lhs[2], q] == CoefficientList[rhs3 @@ %[[-1, 1]], q]
(*
  True
*)

[Note: The general form of Table used by @george2079 does not compile, so I used all of the tuples. Maybe there's another way to generate only the proper ones.]

||improve this answer
$\endgroup$
  • $\begingroup$ Actually, Flatten[Table[{a, b, c, d, e, g, h}, {a, 0, 15}, {b, 0, 15}, {c, 1, 5}, {d, c, 5}, {e, 0, 15}, {g, 1, 5}, {h, g, 5}], 6] // Developer`ToPackedArray takes less than a second. It uses ~170 MB of memory that are packed down to 50 MB. But if the next three parameters each have a range of 1 to 5, then that translates to 20 GB packed down to 6 GB, a lot more if the range is 1 to 15. You might be able to chunk it. $\endgroup$ – Michael E2 Jun 19 '14 at 15:04
  • $\begingroup$ Please look at my response to your comment above and edit to the original post. $\endgroup$ – Jonny Jun 19 '14 at 17:37

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.