I have asked a question here. I want to reproduce the coefficients of a generating function of the form: $$(1 + x)^2 (1 + x + x^2 + x^3+\cdots+x^n)^{n-1}$$ It is important that $x_0$ and $x_n$ to be strictly 0 or 1 and $x_1$ to $x_2$ can be any number within 0 and n (nothing higher). Here are two examples: For $n=3$ we have:

In: (1 + x)^2 (1 + x + x^2 + x^3)^2 // Expand
Out: 1 + 4 x + 8 x^2 + 12 x^3 + 14 x^4 + 12 x^5 + 8 x^6 + 4 x^7 + x^8

We can produce the coefficients as:

n = 3;
m = n + 1;
tabel = Table[
v = Array[x, m, 0];
eqn = Total[v] == t;
constraints = 
And[0 <= v[[1]] <= 1, 0 <= v[[2]] <= n, 0 <= v[[3]] <= n, 
 0 <= v[[4]] <= 1];
v /. Solve[{eqn, constraints}, v, Integers], {t, 0, 8}];
Table[Length[tabel[[i]]], {i, Length[tabel]}]

which gives:

{1, 4, 8, 12, 14, 12, 8, 4, 1}

as desired. For $n=4$ one had to add extra constraint and change the $t$ range. We have:

In: (1 + x)^2 (1 + x + x^2 + x^3 + x^4)^3 // Expand
Out: 1 + 5 x + 13 x^2 + 25 x^3 + 41 x^4 + 58 x^5 + 70 x^6 + 74 x^7 + 
70 x^8 + 58 x^9 + 41 x^10 + 25 x^11 + 13 x^12 + 5 x^13 + x^14

thus $t$ should be from 0 to 14, so we have:

n = 4;
m = n + 1;
tabel = Table[
v = Array[x, m, 0];
eqn = Total[v] == t;
constraints = 
And[0 <= v[[1]] <= 1, 0 <= v[[2]] <= n, 0 <= v[[3]] <= n, 
 0 <= v[[4]] <= n, 0 <= v[[5]] <= 1];
v /. Solve[{eqn, constraints}, v, Integers], {t, 0, 14}];
Table[Length[tabel[[i]]], {i, Length[tabel]}]

I wonder if these modifications can be done automatically so that one doesn't have to add a constraint by hand and change the range.

Note: I want the output table to be in a format so that I can see all of the possibilities of the sums. For instance, for n=3, table[[2]] should give all of the possibilities such that the total is equal to 1.

{{0, 0, 0, 1}, {0, 0, 1, 0}, {0, 1, 0, 0}, {1, 0, 0, 0}}
up vote 4 down vote accepted

Update

An even faster method (I also modified the order of each possibility as requested in the comments):

tups[n_] := Values @ GroupBy[
    Tuples[Join[{Range[2]}, ConstantArray[Range[n+1], n-1], {Range[2]}] - 1],
    Total
]

A comparison with the accepted answer:

r1 = tups[3]; //AbsoluteTiming
r2 = gen[3]; //AbsoluteTiming

Sort /@ r1 === Sort /@ Reverse @ r2[[All, 2]]

{0.000123, Null}

{0.001075, Null}

True

Almost an order of magnitude faster for $n=3$. For $n=7$:

r1 = tups[7]; //AbsoluteTiming
r2 = gen[7]; //AbsoluteTiming

Sort /@ r1 === Sort /@ Reverse @ r2[[All, 2]]

{0.195056, Null}

{29.7257, Null}

True

Original method

Here's a modification of @kglr's answer to your linked question:

sums[n_]:= Last @ Reap[
    Array[Sow[{##}, Plus[##]]&, Join[{2}, ConstantArray[n+1, n-1], {2}], 0],
    _,
    #2&
]

For $n=3$:

sums[3][[2]]

{{0, 0, 0, 1}, {0, 0, 1, 0}, {0, 1, 0, 0}, {1, 0, 0, 0}}

And a couple checks:

Length /@ sums[3]
Length /@ sums[4]

{1, 4, 8, 12, 14, 12, 8, 4, 1}

{1, 5, 13, 25, 41, 58, 70, 74, 70, 58, 41, 25, 13, 5, 1}

  • Thanks Carl, while it produces the correct answer, I need the elements to be in right place, as I will use them later as a list for other computation, If you try sums[3][[3]] you'd see the first element is not right, {0, 0, 0, 2} the first and last element of this must be 0 or 1, so the only way to assign 2 is {0, 2, 0, 0} and {0,0,2,0} to produce the sum of 2 without violating the constraints. This was happening at kglr's answer. – William Sep 21 at 15:31
  • 1
    @William I modified the code as requested. Note that my answer is over an order of magnitude faster than the accepted answer. – Carl Woll Sep 21 at 15:46
  • 1
    Yes, this is much nicer for the task at hand (and I for one upvoted). – Daniel Lichtblau Sep 21 at 15:49
  • @CarlWoll & Daniel I have changed my acceptation. due to timing. Thanks again. – William Sep 21 at 16:01

One can automate the generating construction readily enough using Product and Sum. Getting total degrees and then the subsets of balues that give them is a bit more work. I show one method below.

gen[n_] := Module[
  {vars, x, t, genFunc, coeffs},
  vars = Array[x, n + 1, 0];
  genFunc = (1 + First[vars])*(1 + Last[vars])*
     Product[Sum[vars[[j]]^k, {k, 0, n}], {j, 2, n}] /. 
    Thread[vars -> t*vars];
  coeffs = GroebnerBasis`DistributedTermsList[genFunc, t][[1]];
  Map[{#[[1, 1]], 
     GroebnerBasis`DistributedTermsList[#[[2]], vars][[1, All, 1]]} &,
    coeffs]
  ]

Example:

gen[3]

(* Out[59]= {{8, {{1, 3, 3, 1}}}, {7, {{1, 3, 3, 0}, {1, 3, 2, 1}, {1, 2,
     3, 1}, {0, 3, 3, 1}}}, {6, {{1, 3, 2, 0}, {1, 3, 1, 1}, {1, 2, 3,
     0}, {1, 2, 2, 1}, {1, 1, 3, 1}, {0, 3, 3, 0}, {0, 3, 2, 1}, {0, 
    2, 3, 1}}}, {5, {{1, 3, 1, 0}, {1, 3, 0, 1}, {1, 2, 2, 0}, {1, 2, 
    1, 1}, {1, 1, 3, 0}, {1, 1, 2, 1}, {1, 0, 3, 1}, {0, 3, 2, 0}, {0,
     3, 1, 1}, {0, 2, 3, 0}, {0, 2, 2, 1}, {0, 1, 3, 1}}}, {4, {{1, 3,
     0, 0}, {1, 2, 1, 0}, {1, 2, 0, 1}, {1, 1, 2, 0}, {1, 1, 1, 
    1}, {1, 0, 3, 0}, {1, 0, 2, 1}, {0, 3, 1, 0}, {0, 3, 0, 1}, {0, 2,
     2, 0}, {0, 2, 1, 1}, {0, 1, 3, 0}, {0, 1, 2, 1}, {0, 0, 3, 
    1}}}, {3, {{1, 2, 0, 0}, {1, 1, 1, 0}, {1, 1, 0, 1}, {1, 0, 2, 
    0}, {1, 0, 1, 1}, {0, 3, 0, 0}, {0, 2, 1, 0}, {0, 2, 0, 1}, {0, 1,
     2, 0}, {0, 1, 1, 1}, {0, 0, 3, 0}, {0, 0, 2, 1}}}, {2, {{1, 1, 0,
     0}, {1, 0, 1, 0}, {1, 0, 0, 1}, {0, 2, 0, 0}, {0, 1, 1, 0}, {0, 
    1, 0, 1}, {0, 0, 2, 0}, {0, 0, 1, 1}}}, {1, {{1, 0, 0, 0}, {0, 1, 
    0, 0}, {0, 0, 1, 0}, {0, 0, 0, 1}}}, {0, {{0, 0, 0, 0}}}} *)

Looks spiffier if one uses TableForm or similar.

Perhaps I didn't understand your question, but

Table[ CoefficientList[(1 + x)^2 (Sum[x^i, {i, 0, n}])^(n - 1),x] , {n, 1, 5}]

evaluates the list of coefficients you're looking for.

  • Yes this is wrong. As I said I need to know the possible sum. The table there gives me all the possible sums but yours does not. – William Sep 21 at 13:59

Your Answer

By clicking "Post Your Answer", you acknowledge that you have read our updated terms of service, privacy policy and cookie policy, and that your continued use of the website is subject to these policies.

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