3

Let $a\in\mathbb{N}^n$ and $k\in\mathbb{N}\!=\!\{0,1,2,\ldots\}$. How can I efficiently generate the list $$\{(a_1,\ldots,a_k); a_1,\ldots,a_k\!\in\!\mathbb{N}^n\!\setminus\!\{0\}, a_1\!+\!\ldots\!+\!a_k\!=\!a\}?$$

It would also be desirable for the code to be short. My current, highly inefficient solution is: 

Select[Tuples[Tuples[Range[0, Max @@ a], Length@a], k], 
  Plus @@ # == a && !MemberQ[#, Table[0, {i, n}]]&]
J. M.'s missing motivation
  • 124,525
  • 11
  • 401
  • 574
Leo
  • 1,155
  • 5
  • 14
  • If there were a function that would produce all ordered partitions of length $k$ (containing zeros) of a given $x\in\mathbb{N}$, then taking tuples would solve the problem. – Leo Mar 23 '14 at 03:10
  • Look at IntegerPartitions... – ciao Mar 23 '14 at 03:31
  • Or better yet, Needs["Combinatorica`"] Compositions[5,3]. – Leo Mar 23 '14 at 03:36
  • Just be aware of compatibility issues if you're on recent version of Mathematica, some posts here cover such, and docs has guide.... – ciao Mar 23 '14 at 03:41

2 Answers2

7

Let's start by defining a helper function that will find all of the partitions of an integer that contains exactly k components:

partitions[n_, k_] :=
  Composition[Union, Permutations, PadRight[#, k]&] /@ IntegerPartitions[n, k] //
  Flatten[#, 1]& //
  Sort

We let IntegerPartitions do the heavy-lifting, but pad the results with zeroes so that there are always exactly k components. We permute each of the results and eliminate duplicates. Flatten is used to undo the extra list level introduced by Permutations. Finally, we Sort the result to impose a canonical order (this step is optional).

Here it is in action:

partitions[3, 3]
(*{{0,0,3},{0,1,2},{0,2,1},{0,3,0},{1,0,2},{1,1,1},{1,2,0},{2,0,1},{2,1,0},{3,0,0}}*)

We then use this helper function to define the main function:

setPartitions[a_, k_] :=
  Module[{n = Length@a, z = 0 a}
  , partitions[#, k]& /@ a //
    Tuples //
    Transpose[#, {1, 3, 2}]& //
    Select[#, FreeQ[#, z]&]&
  ]

This invokes the helper function on each element of a. All possible combinations of the individual element partitions are then assembled using Tuples. Transpose generates the result vector sets. Finally, any combination involving the zero vector is removed.

Sample use:

setPartitions[{1, 2}, 2]
(*{{{0, 1}, {1, 1}}, {{0, 2}, {1, 0}}, {{1, 0}, {0, 2}}, {{1, 1}, {0, 1}}}*)

setPartitions[{3, 5, 7}, 2] generates the same 190 sets as the code exhibited in the question applied to the same parameters. On my machine, the original code took 1.89s to run whereas setPartitions was too fast to measure (0s reported). Notwithstanding this improvement, beware that this problem generates very large solution sets for even small increases in magnitude of k, n or the individual a[[i]]. For example, setPartitions[{3, 5, 7}, 5] took 9.08s to generate 856,985 solutions.

Edit

At the suggestion of @rasher, partitions can be expressed more concisely thus:

partitions[n_, k_] :=
    Join @@ (Permutations /@ IntegerPartitions[n, {k}, Range[0, n]]) // Sort

Once again, the Sort is optional and is only there to obtain the same order of results as the code in the question. I would recommend removing the Sort if that order is not crucial.

WReach
  • 68,832
  • 4
  • 164
  • 269
  • Nice, but "helper" is doing much more work than needed, try e.g. this, order of magnitude faster on smallish, faster yet as results size increases: fastComp[n_, k_] := Join @@ (Permutations /@ IntegerPartitions[n, {k}, Range[0, n]]) – ciao Mar 23 '14 at 06:57
  • @rasher Much nicer, thanks. I have incorporated your suggestion as an addendum. For setPartitions[{3, 5, 7}, 5], the main function still dominates the run time as the helper optimization only shaved off about 0.12s off total time on my machine. – WReach Mar 23 '14 at 14:00
  • I have another question: How can I remove from this list all tuples of vectors $(a_1,\ldots,a_k)$, where at least one $a_i$ is componentwise $\geq(1,\ldots,1)$? – Leo Mar 24 '14 at 02:03
  • The filtering is done in the call to FreeQ. We could add another pattern, e.g. FreeQ[#, z|u]&, where u = z + 1. – WReach Mar 24 '14 at 03:55
0

The answer I was looking for, using

Needs["Combinatorica`"]

is:

a={2,2,1}; n=Length@a; k=3;

Select[Transpose/@Tuples[Table[Compositions[a[[i]],k],{i,n}]], !MemberQ[#,Table[0,{i,n}]]&]

If furthermore all tuples with at least one vector without a $0$ entry are removed, then:

complex = Table[Select[Transpose/@Tuples[Table[Compositions[a[[i]],k],{i,n}]], 
       !MemberQ[#,Table[0,{i,n}]] && (And@@(MemberQ[#,0]&/@#))&],{k,deg}];
Column/@complex
march
  • 23,399
  • 2
  • 44
  • 100
Leo
  • 1,155
  • 5
  • 14