9
$\begingroup$

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];
Improve this question
$\endgroup$
5
  • $\begingroup$ You want all of them? Because there will be quite a few (as in 10's of millions). $\endgroup$
    – Daniel Lichtblau
    Oct 12, 2014 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, 2014 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, 2014 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, 2014 at 22:03
  • $\begingroup$ Related $\endgroup$
    – Jacob Akkerboom
    Oct 15, 2014 at 15:17

6 Answers 6

Reset to default
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}.... *)
Improve this answer
$\endgroup$
4
  • $\begingroup$ I believe you still have to find all the permutations of each of the partitions. (Permutations/@) $\endgroup$
    – DavidC
    Oct 13, 2014 at 1:22
  • $\begingroup$ +1 But your approach is very straightforward. $\endgroup$
    – DavidC
    Oct 13, 2014 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, 2014 at 11:25
  • $\begingroup$ 11.13secs in my machine $\endgroup$
    – thils
    Oct 13, 2014 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.

Improve this answer
$\endgroup$
2
  • $\begingroup$ See my solution:-) $\endgroup$
    – xyz
    Oct 13, 2014 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, 2014 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"

Improve this answer
$\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
Improve this answer
$\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

Improve this answer
$\endgroup$
6
  • 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, 2014 at 2:45
  • $\begingroup$ +1 But I used Partition[Flatten[Permutations /@ combos], 12] // Length to obtain the 19611175 permutations. $\endgroup$
    – Chris Degnen
    Oct 13, 2014 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, 2014 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, 2014 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, 2014 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.

Improve this answer
$\endgroup$
2
  • $\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, 2014 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, 2014 at 3:51

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