3
$\begingroup$

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}}
$\endgroup$

3 Answers 3

4
$\begingroup$

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}

$\endgroup$
4
  • $\begingroup$ 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. $\endgroup$
    – Wiliam
    Sep 21, 2018 at 15:31
  • 1
    $\begingroup$ @William I modified the code as requested. Note that my answer is over an order of magnitude faster than the accepted answer. $\endgroup$
    – Carl Woll
    Sep 21, 2018 at 15:46
  • 1
    $\begingroup$ Yes, this is much nicer for the task at hand (and I for one upvoted). $\endgroup$ Sep 21, 2018 at 15:49
  • $\begingroup$ @CarlWoll & Daniel I have changed my acceptation. due to timing. Thanks again. $\endgroup$
    – Wiliam
    Sep 21, 2018 at 16:01
4
$\begingroup$

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.

$\endgroup$
2
$\begingroup$

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.

$\endgroup$
1
  • $\begingroup$ 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. $\endgroup$
    – Wiliam
    Sep 21, 2018 at 13:59

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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