# Fast way to pick up certain terms in Polynomial multiplication?

I have one case (Nn=1) for 7 Polynomials as following:

p1= a*b + c*d + e*f + g*h;
p2= a*c + b*d + e*g + f*h;
p3= a*d + b*c + e*h + f*g;
p4= a*e + b*f + c*g + d*h;
p5= a*f + b*e + c*h + d*g;
p6= a*g + b*h + c*e + d*f;
p7= a*h + b*g + c*f + d*e;



and I want to pick up 4 terms from the 7*4=28 terms such as a*b, c*d and so on, which gives me the output in the form of a[x1]*b[x2]*c[x3]*d[x4]*e[x5]*f[x6]*g[x7]*h[x8] (we can later write it as FF[x1,x2,x3,x4,x5,x6,x7,x8]).

The way I do is as following:

outputstemp={};
outputs={};
FFnCaseList={a[c1_]*b[c2_]*c[c3_]*d[c4_]*e[c5_]*f[c6_]*g[c7_]*h[c8_]->FF[c1,c2,c3,c4,c5,c6,c7,c8], a[_]->0, b[_]->0, c[_]->0,  d[_]->0, e[_]->0, f[_]->0, g[_]->0, h[_]->0,  x_[_]^n_->0};

AllRows = (p1+p2+p3+p4+p5+p6+p7)^4;
AppendTo[outputstemp, ExpandAll[AllRows]];

Timing[AppendTo[outputs, outputstemp/.FFnCaseList];]



the time is {10.2344, Null}

So is there any quick way to do this? If I have many different cases (for example Nn=6000) of 7 Polynomials, then I can make a loop that run similar things Nn times (6000*10s). That will takes roughly 16.7 hours!!!

Any comments or suggestions are appreciated! Thank you very much!

I would use Coefficient after mopdifying so that terms of the desired form have a unique power in a new variable.

p1 = a*b + c*d + e*f + g*h;
p2 = a*c + b*d + e*g + f*h;
p3 = a*d + b*c + e*h + f*g;
p4 = a*e + b*f + c*g + d*h;
p5 = a*f + b*e + c*h + d*g;
p6 = a*g + b*h + c*e + d*f;
p7 = a*h + b*g + c*f + d*e;


Multiply each variable by t^2^j where j is the index of that variable in the list {a,b,c,d,e,f,g,h}.

polys = {p1, p2, p3, p4, p5, p6, p7} /.
Thread[{v_a, v_b, v_c, v_d, v_e, v_f, v_g, v_h} ->
v*t^(2^Range[0, 7])]

(* Out= {t^3 a b + t^12 c d + t^48 e f +
t^192 g h,
t^5 a c + t^10 b d + t^80 e g + t^160 f h,
t^6 b c + t^9 a d + t^96 f g + t^144 e h,
t^17 a e + t^34 b f + t^68 c g + t^136 d h,
t^18 b e + t^33 a f + t^72 d g + t^132 c h,
t^20 c e + t^40 d f + t^65 a g + t^130 b h,
t^24 d e + t^36 c f + t^66 b g + t^129 a h} *)


Pull out terms that have t to the power 1+2+4+...+128, or 255. In order to speed the conversion to the FF[...] notation I replace sums and products by lists (this speeds otherwise slow pattern match). In a more general setting one might have to canonicalize the ordering using Sort.

Timing[
allvarsmonoms =
Expand[Coefficient[(Apply[Plus, polys])^4, t^Total[2^Range[0, 7]]]];
res0 = Apply[List, allvarsmonoms];
res1 = res0 /. {Plus -> List, Times -> List};
res = Apply[Plus,
res1 /. {num_, a[v1_], b[v2_], c[v3_], d[v4_], e[v5_], f[v6_],
g[v7_], h[v8_]} -> num*FF[v1, v2, v3, v4, v5, v6, v7, v8]];]
Length[res]

(* Out= {0.0625, Null}

Out= 105 *)

• Thank you very much! If variable in the list is {a,b,c,d,e,f}, should I use v*t^(2^Range[0, 5])? Apr 21, 2020 at 17:25
• Yes. For cleaner code, I should have defined the variable symbols in a list as vars and then used Length[vars] for that exponent. Apr 21, 2020 at 18:04
• Thank you! that speed up a lot. Very interesting! Apr 21, 2020 at 18:17

I am sure there is a less awkward method than the following proposal:

n = 4;
expr = p1 + p2 + p3 + p4 + p5 + p6 + p7;

Nest[Map[If[Signature[Head /@ (List @@ #)] == 0, 0, #] &, Expand[expr * #]] &, 1, n] /.
(a[c1_] b[c2_] c[c3_] d[c4_] e[c5_] f[c6_] g[c7_] h[c8_]) :>
FF[c1, c2, c3, c4, c5, c6, c7, c8]


which yields 24 a b c d e f g h + ... 24 a b c d e f g h in about a hundredth of the time taken for the OP's original code.

• wow, that's amazing. Well, i didn't saw hundredth of time from my computer but factor of 20 is quite good! Thank you! Apr 20, 2020 at 18:44
• changing the replacement rule to {Times -> (# FF[##2] &), Alternatives[a, b, c, d, e, f, g, h] -> Identity} seems to double the speed. (+1)
– kglr
Apr 20, 2020 at 19:36
• @kglr, yes, that's cool! Thank you very much! Apr 20, 2020 at 19:53
• @Xuemei, your "additional" question should surely be a separate question. Apr 21, 2020 at 0:50
• @J.M., thank you very much and I have posted it as a separate question here. Could you have a look? would be extremely helpful and thank you a lot! Apr 21, 2020 at 7:02
expr  = p1 + p2 + p3 + p4 + p5 + p6 + p7;

res = Total[Multinomial[1, 1, 1, 1] FF @@@
(ReplaceAll[ _[a_] :> a] @ Select[DuplicateFreeQ @* Map[Head]]@
Apply[Sort@*Join, Subsets[expr /. Plus|Times -> List, {4}],  {-4}])]; //
RepeatedTiming // First

 .16


this gives the same result as J.M.'s approach:

res2 = Nest[Map[If[Signature[Head /@ (List @@ #)] == 0, 0, #] &,
Expand[expr*#]] &, 1, n] /.
(a[c1_] b[c2_] c[c3_] d[c4_] e[c5_] f[c6_] g[c7_] h[c8_]) :>
FF[c1, c2, c3, c4, c5, c6, c7, c8]; //  RepeatedTiming // First

0.54

res == res2

True

• thank you very much and I have posted it as a separate question here. Could you have a look? would be extremely helpful and thank you a lot! Apr 21, 2020 at 7:05