9
$\begingroup$

This question already has an answer here:

Can anyone suggest a good way to find permutations of 12 digits, 0 to 4, totalling 24.

I.e. two such permutations:-

{2, 1, 4, 1, 2, 2, 2, 2, 2, 2, 1, 3} // Total

24

{4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0} // Total

24

I am trying this, but it takes too long:-

FromDigits[{4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0}, 5]

244125000

list = {};
Array[If[Total[IntegerDigits[#, 5]] == 24, list = {list, #}] &, 244125000];
$\endgroup$

marked as duplicate by Mr.Wizard Dec 4 '15 at 1:13

This question has been asked before and already has an answer. If those answers do not fully address your question, please ask a new question.

  • $\begingroup$ You want all of them? Because there will be quite a few (as in 10's of millions). $\endgroup$ – Daniel Lichtblau Oct 12 '14 at 20:58
  • $\begingroup$ So I see, 19,611,175. Just a better method than counting through would be good. I'll see about editing the question. $\endgroup$ – Chris Degnen Oct 12 '14 at 21:01
  • $\begingroup$ This problem is NP-complete so it's not very likely that you will find a much better algorithm. The best known algorithm seems to have complexity O(2^(N/2)). doi:10.1145/321812.321823 $\endgroup$ – paw Oct 12 '14 at 21:17
  • $\begingroup$ From the examples you give my understanding is that you are not looking for permutations (whose total sum would be a constant) ; the Horowitz/Sahni paper would thus not be relevant. Am I correct in assuming that what you want is to list all vectors of $\{0,1,2,3,4\}^{12}$ that sum to 24? $\endgroup$ – A.G. Oct 12 '14 at 22:03
  • $\begingroup$ Related $\endgroup$ – Jacob Akkerboom Oct 15 '14 at 15:17
7
$\begingroup$

Use the following

IntegerPartitions[24, {12}, {0, 1, 2, 3, 4}]

(* Out = {{4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0}, {4, 4, 4, 4, 4, 3, 1, 0, 0, 0, 
  0, 0}, {4, 4, 4, 4, 4, 2, 2, 0, 0, 0, 0, 0}, {4, 4, 4, 4, 4, 2, 1, 
  1, 0, 0, 0, 0}, {4, 4, 4, 4, 4, 1, 1, 1, 1, 0, 0, 0}, {4, 4, 4, 4, 
  3, 3, 2, 0, 0, 0, 0, 0}, {4, 4, 4, 4, 3, 3, 1, 1, 0, 0, 0, 0}, {4, 
  4, 4, 4, 3, 2, 2, 1, 0, 0, 0, 0}, {4, 4, 4, 4, 3, 2, 1, 1, 1, 0, 0, 
  0}, {4, 4, 4, 4, 3, 1, 1, 1, 1, 1, 0, 0}, {4, 4, 4, 4, 2, 2, 2, 2, 
  0, 0, 0, 0}, {4, 4, 4, 4, 2, 2, 2, 1, 1, 0, 0, 0}, {4, 4, 4, 4, 2, 
  2, 1, 1, 1, 1, 0, 0}, {4, 4, 4, 4, 2, 1, 1, 1, 1, 1, 1, 0}, {4, 4, 
  4, 4, 1, 1, 1, 1, 1, 1, 1, 1}.... *)
$\endgroup$
  • $\begingroup$ I believe you still have to find all the permutations of each of the partitions. (Permutations/@) $\endgroup$ – DavidC Oct 13 '14 at 1:22
  • $\begingroup$ +1 But your approach is very straightforward. $\endgroup$ – DavidC Oct 13 '14 at 1:53
  • 3
    $\begingroup$ Very nice. 13 seconds for all permutations: Timing[Partition[ Flatten[Permutations /@ IntegerPartitions[24, {12}, {0, 1, 2, 3, 4}]], 12];] $\endgroup$ – Chris Degnen Oct 13 '14 at 11:25
  • $\begingroup$ 11.13secs in my machine $\endgroup$ – thils Oct 13 '14 at 22:22
10
$\begingroup$

Could do this with Solve (should take under an hour).

vars = Array[x, 12];

Timing[soln = 
   Solve[Flatten[{Total[vars] == 24, Map[0 <= # <= 4 &, vars]}], vars,
     Integers];]

(Breaking report: this eventually finished, in around 23 minutes.)

Somewhat faster is to find the degree 24 coefficient of a particular polynomial. The slow step is to massage it into an expanded form wherein the individual solutions become evident.

vars = Array[x, 12];
prod = Apply[Times, Total[Transpose[Map[#^Range[0, 4] &, t*vars]]]];
count = Coefficient[prod /. Thread[vars -> 1], t^24]
Timing[solns = 
   GroebnerBasis`DistributedTermsList[Expand[Coefficient[prod, t^24]],
      vars][[1, All, 1]];]

(* Out[3]= 19611175

Out[4]= {389.784744, Null} *)

In[5]:= solns[[1;;4]]                                                           

(* Out[5]= {{4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0}, 
    {4, 4, 4, 4, 4, 3, 1, 0, 0, 0, 0, 0}, 
     {4, 4, 4, 4, 4, 3, 0, 1, 0, 0, 0, 0}, 
     {4, 4, 4, 4, 4, 3, 0, 0, 1, 0, 0, 0}} *)

You might fare better using IntegerPartitions and then forming, for each one, all its distinct rearrangements.

$\endgroup$
  • $\begingroup$ See my solution:-) $\endgroup$ – xyz Oct 13 '14 at 3:23
  • $\begingroup$ @ShutaoTang It is a reasonable way to generate the partitions (as is Integerpartitions). Then one needs to allow for all possible permutations of each partition. $\endgroup$ – Daniel Lichtblau Oct 13 '14 at 14:48
4
$\begingroup$
ip = IntegerPartitions[24, 12];
pck = Pick[ip, Max[#] <= 4 & /@ ip];
base = PadRight[pck];
num = Total[Multinomial @@ Last[Transpose@Tally[#]] & /@ base]

ip is candidate partitions

pck selects from candidates

base: just pads to length 12 with 0

num is the number of permutations: 19611175

You could just sample from base then "sample from sample"

$\endgroup$
3
$\begingroup$

For a premutation,which contained $n_0$ 0,$n_1$ 1,$n_2$ 2,$n_3$ 3,$n_4$4, So I can achieve two equtions:

$$0\times n_0+ 1\times n_1+2\times n_2+3\times n_3+4\times n_4=24 \\ n_0+n_1+n_2+n_3+n_4=12$$

Reduce[n0 + n1 + n2 + n3 + n4 == 12 && n1 + 2 n2 + 3 n3 + 4 n4 == 24 &&
 0 <= n1 <= n2 <= n3 <= n4 <= 12, {n0, n1, n2, n3, n4}, Integers]
  (n0 == 3 && n1 == 2 && n2 == 2 && n3 == 2 && n4 == 3) 
 || (n0 == 4 && n1 == 1 && n2 == 1 && n3 == 3 && n4 == 3) 
 || (n0 == 5 && n1 == 0 &&n2 == 1 && n3 == 2 && n4 == 4) 
 || (n0 == 6 && n1 == 0 && n2 == 0 &&n3 == 0 && n4 == 6)

Update

 permutation[n0_, n1_, n2_, n3_, n4_] := 
  Flatten@(PadRight[{}, ##] & @@@ 
    Thread@{{n0, n1, n2, n3, n4}, Range[0, 4]})

 sol = {n0, n1, n2, n3, n4} /. 
  Solve[
   {n0 + n1 + n2 + n3 + n4 == 12, n1 + 2 n2 + 3 n3 + 4 n4 == 24,
    0 <= n0 <= 12, 0 <= n1 <= 12, 0 <= n2 <= 12, 0 <= n3 <= 12, 0 <= n4 <= 12}, 
   {n0, n1, n2, n3, n4}, Integers];

So we can achieve all possible premutations:

 permutation @@@ sol
  {{2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2}, {1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3},
     {1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3}, {1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 4},
     {1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3}, {1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 3, 4},
     {1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3}, {1, 1, 1, 1, 2, 2, 2, 2, 2, 3, 3, 4},
     {1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 4, 4}, {1, 1, 1, 1, 1, 2, 2, 3, 3, 3, 3, 3}, 
     {1, 1, 1, 1, 1, 2, 2, 2, 3, 3, 3, 4}, ...}

The number of all permutations:

  permutation @@@ sol // Length
 86
$\endgroup$
3
$\begingroup$

IntegerPartitions is the most straightforward way of finding all of the 86 combinations of {0,1,2,3,4} with 12 elements that sum to 24. thils' used IntegerPartitions. So let's find another way.

Combinations

FrobeniusSolve[{1, 2, 3, 4}, 24] finds all the combinations of {1,2,3,4} having a sum of 24. Some of those will be too long (nSummands > 12). Select...Length[#]<13 eliminates those overly long combinations.

PadLeft (with zeros) ensures that each of the remaining combinations has 12 summands.

combos=PadLeft[#, 12] & /@ Select[FrobeniusSolve[{1, 2, 3, 4}, 24] 
/. {a_, b_, c_, d_} :> Flatten[Thread[z[{1, 2, 3, 4}, {a, b, c, d}]] 
/. z :> ConstantArray], Length[#] < 13 &]

{{0, 0, 0, 0, 0, 0, 4, 4, 4, 4, 4, 4}, {0, 0, 0, 0, 0, 3, 3, 3, 3, 4, 4, 4}, {0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 3}, {0, 0, 0, 0, 0, 2, 3, 3, 4, 4, 4, 4}, {0, 0, 0, 0, 2, 3, 3, 3, 3, 3, 3, 4}, {0, 0, 0, 0, 0, 2, 2, 4, 4, 4, 4, 4}, {0, 0, 0, 0, 2, 2, 3, 3, 3, 3, 4, 4}, {0, 0, 0, 0, 2, 2, 2, 3, 3, 4, 4, 4}, {0, 0, 0, 2, 2, 2, 3, 3, 3, 3, 3, 3},
...,{1, 1, 1, 1, 1, 1, 1, 1, 4, 4, 4, 4}}


Length[combos]

86


Permutations

We still need to permute each of the accepted combinations.

Let's check to see how many permutations will be output.

Length[Permutations[#]] & /@ combos // Total

19611175

$\endgroup$
  • 1
    $\begingroup$ (1) "thils' approach"? I mean, seriously. (2) To account for all possibilities one needs to use an appropriate multinomial coefficient for the given partition. If there are three 4's, two 3's, two 2's, four 1's and one 0, then the multiplier would be Multinomial[3,2,2,4,1]. $\endgroup$ – Daniel Lichtblau Oct 13 '14 at 2:45
  • $\begingroup$ +1 But I used Partition[Flatten[Permutations /@ combos], 12] // Length to obtain the 19611175 permutations. $\endgroup$ – Chris Degnen Oct 13 '14 at 9:01
  • $\begingroup$ Actually FrobeniusSolve does not use Groebner bases. In principle it could, but that is really a very different approach. There is a brief account of this GB qpproach at the nb available here, in the slides "A Frobenius instance via toric Gröbner bases". A description of the ILP method actually sued by Mathematica is here. $\endgroup$ – Daniel Lichtblau Oct 13 '14 at 15:00
  • $\begingroup$ My last remark was intended as a technical comment on what goes on under the hood. Regardless, FrobeniusSolve can be used to find the partitions as above. $\endgroup$ – Daniel Lichtblau Oct 13 '14 at 15:01
  • $\begingroup$ @ David Carraher - Your total comes out right (19.6m). Try running Length[Permutations[#]] & /@ combos // Total again. $\endgroup$ – Chris Degnen Oct 13 '14 at 15:49
2
$\begingroup$

This question showed up in the "Hot Network Questions" over on StackExchange. I'm not a Mathematica user, so I have no useful answer as to how to solve this with that tool, but I was curious how I'd solve this with programming techniques I know.

I've been working on a functional programming library for Javascript, Ramda, and using that I wrote the following solutions to count the solutions (not to enumerate them):

(function f(digits, count, total) {
    return (total < 0) ? 0 : (count === 1) ? (total <= digits) ? 1 : 0 : 
       R.sum(R.map(function(n) {return f(digits, count - 1, total - n)}, R.range(0, digits + 1)));
})(4, 12, 24)

Running in Node, this takes under 4 seconds to compute the correct answer of 19611175, even though Javascript is known to be poor at recursion.

In other words, a simple recursive solution will work quickly enough as well as the other sophisticated techniques described here.


Update

A comment by @MrWizard asked for this to be spelled out more clearly. Let me see if I can do that. This is a function f, which might be defined as:

var f = function(digits, count, total) {
    if (total < 0) {return 0;}
    if (count == 1) {
        if (total <= digits) {
            return 1;
        } else {
            return 0;
        }
    } else {
        // return value of the (recursive) formula below
    }
}

Where the formula in question is

$\sum\limits_{n=0}^{digits} f(digits, count - 1, total - n)$

In other words, it's a simple recursive solution with a number of annoying base cases, and a recursive case which involves trying each allowed digit in the first position and then solving for a smaller subproblem involving one fewer positions and totaling to a value smaller than the parent problem by the value of the digit tested.

I hope that's more clear.

$\endgroup$
  • $\begingroup$ Hello Scott. Since you cannot provide a Mathematica-specific answer would you mind giving that algorithm in the most basic pseudo-code (or perhaps Python), or describing its steps? I might (or might not) be able to guess how this is read but I shouldn't have to. $\endgroup$ – Mr.Wizard Oct 13 '14 at 20:57
  • 1
    $\begingroup$ @Mr.Wizard: Updated with what I hope is a more readable version of the code. $\endgroup$ – Scott Sauyet Oct 14 '14 at 3:51

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