Ordered Partitions

From Rosetta Code
Jump to: navigation, search
Task
Ordered Partitions
You are encouraged to solve this task according to the task description, using any language you may know.

In this task we want to find the ordered partitions into fixed-size blocks. This task is related to Combinations in that it has to do with discrete mathematics and moreover a helper function to compute combinations is (probably) needed to solve this task.

partitions(arg1,arg2,...,argn) should generate all distributions of the elements in \{1,...,\Sigma_{i=1}^n\mathit{arg}_i\} into n blocks of respective size arg1,arg2,...,argn.

Example 1: partitions(2,0,2) would create:

{({1, 2}, {}, {3, 4}), 
 ({1, 3}, {}, {2, 4}), 
 ({1, 4}, {}, {2, 3}), 
 ({2, 3}, {}, {1, 4}), 
 ({2, 4}, {}, {1, 3}), 
 ({3, 4}, {}, {1, 2})}

Example 2: partitions(1,1,1) would create:

{({1}, {2}, {3}), 
 ({1}, {3}, {2}), 
 ({2}, {1}, {3}), 
 ({2}, {3}, {1}), 
 ({3}, {1}, {2}), 
 ({3}, {2}, {1})}

Note that the number of elements in the list is

{\mathit{arg}_1+\mathit{arg}_2+...+\mathit{arg}_n \choose \mathit{arg}_1} \cdot {\mathit{arg}_2+\mathit{arg}_3+...+\mathit{arg}_n \choose \mathit{arg}_2} \cdot \ldots \cdot {\mathit{arg}_n \choose \mathit{arg}_n}

(see the definition of the binomial coefficient if you are not familiar with this notation) and the number of elements remains the same regardless of how the argument is permuted (i.e. the multinomial coefficient). Also, partitions(1,1,1) creates the permutations of {1,2,3} and thus there would be 3! = 6 elements in the list.

Note: Do not use functions that are not in the standard library of the programming language you use. Your file should be written so that it can be executed on the command line and by default outputs the result of partitions(2,0,2). If the programming language does not support polyvariadic functions pass a list as an argument.

Notation

Remarks on the used notation for the task in order to understand it easierly.

\{1, \ldots, n\} denotes the set of consecutive numbers from 1 to n, e.g. {1,2,3} if n = 3. Σ is the mathematical notation for summation, e.g. \Sigma_{i=1}^3 i = 6 (see also [1]). arg1,arg2,...,argn are the arguments — natural numbers — that the sought function receives.

Contents

[edit] Ada

partitions.ads:

with Ada.Containers.Indefinite_Ordered_Sets;
with Ada.Containers.Ordered_Sets;
package Partitions is
-- Argument type for Create_Partitions: Array of Numbers
type Arguments is array (Positive range <>) of Natural;
package Number_Sets is new Ada.Containers.Ordered_Sets
(Natural);
type Partition is array (Positive range <>) of Number_Sets.Set;
function "<" (Left, Right : Partition) return Boolean;
package Partition_Sets is new Ada.Containers.Indefinite_Ordered_Sets
(Partition);
function Create_Partitions (Args : Arguments) return Partition_Sets.Set;
end Partitions;

partitions.adb:

package body Partitions is
-- compare number sets (not provided)
function "<" (Left, Right : Number_Sets.Set) return Boolean is
use type Ada.Containers.Count_Type;
use Number_Sets;
Left_Pos  : Cursor := Left.First;
Right_Pos : Cursor := Right.First;
begin
-- compare each element, until one or both lists finishes
while Left_Pos /= No_Element and then Right_Pos /= No_Element loop
-- compare elements
if Element (Left_Pos) < Element (Right_Pos) then
return True;
elsif Element (Left_Pos) > Element (Right_Pos) then
return False;
end if;
-- increase iterator
Next (Left_Pos);
Next (Right_Pos);
end loop;
-- Right is longer
if Right_Pos /= No_Element then
return True;
else
-- Left is longer, or Left and Right are identical.
return False;
end if;
end "<";
-- compare two Partitions
function "<" (Left, Right : Partition) return Boolean is
use type Ada.Containers.Count_Type;
use type Number_Sets.Set;
begin
-- check length
if Left'Length < Right'Length then
return True;
elsif Left'Length > Right'Length then
return False;
end if;
-- same length
if Left'Length > 0 then
for I in Left'Range loop
if Left (I) < Right (I) then
return True;
elsif Left (I) /= Right (I) then
return False;
end if;
end loop;
end if;
-- length = 0 are always smallest
return False;
end "<";
-- create partitions (as the task describes)
function Create_Partitions (Args : Arguments) return Partition_Sets.Set is
-- permutations needed
type Permutation is array (Positive range <>) of Natural;
-- exception to be thrown after last permutation reached
No_More_Permutations : exception;
-- get initial permutation (ordered small->big)
function Initial_Permutation (Max : Natural) return Permutation is
Result : Permutation (1 .. Max);
begin
for I in 1 .. Max loop
Result (I) := I;
end loop;
return Result;
end Initial_Permutation;
-- get next permutation
function Next_Permutation (Current : Permutation) return Permutation is
K  : Natural  := Current'Last - 1;
L  : Positive  := Current'Last;
Result : Permutation := Current;
begin
-- 1. Find the largest index k such that a[k] < a[k + 1].
while K /= 0 and then Current (K) > Current (K + 1) loop
K := K - 1;
end loop;
-- If no such index exists, the permutation is the last permutation.
if K = 0 then
raise No_More_Permutations;
end if;
-- 2. Find the largest index l such that a[k] < a[l].
-- Since k + 1 is such an index, l is well defined
-- and satisfies k < l.
while Current (K) > Current (L) loop
L := L - 1;
end loop;
-- 3. Swap a[k] with a[l].
Result (K) := Current (L);
Result (L) := Current (K);
-- 4. Reverse the sequence from a[k + 1] up to and including the
-- final element a[n].
for I in 1 .. (Result'Last - K) / 2 loop
declare
Temp : constant Natural := Result (K + I);
begin
Result (K + I)  := Result (Result'Last - I + 1);
Result (Result'Last - I + 1) := Temp;
end;
end loop;
return Result;
end Next_Permutation;
Result : Partition_Sets.Set;
Sum  : Natural := 0;
begin
-- get number of elements
for I in Args'Range loop
Sum := Sum + Args (I);
end loop;
declare
-- initial permutation
Current_Permutation : Permutation := Initial_Permutation (Sum);
begin
-- loop through permutations
loop
-- create Partition (same count of Number_Sets.Set as Args)
declare
Item  : Natural := Current_Permutation'First;
Current_Partition : Partition (Args'Range);
begin
-- loop each partition
for I in Args'Range loop
-- fill in the number of elements requested
for J in 1 .. Args (I) loop
Current_Partition (I).Insert
(New_Item => Current_Permutation (Item));
Item := Item + 1;
end loop;
end loop;
-- insert partition into result set
Result.Insert (New_Item => Current_Partition);
exception
when Constraint_Error =>
-- partition was already inserted, ignore it.
-- this happens when one of the args > 1.
null;
end;
-- create next permutation
Current_Permutation := Next_Permutation (Current_Permutation);
end loop;
exception
when No_More_Permutations =>
-- no more permutations, we are finished
null;
end;
return Result;
end Create_Partitions;
end Partitions;

example main.adb:

with Ada.Text_IO;
with Partitions;
procedure Main is
package Natural_IO is new Ada.Text_IO.Integer_IO (Natural);
Example_Partitions : Partitions.Partition_Sets.Set;
begin
Ada.Text_IO.Put_Line ("Partitions for (2, 0, 2):");
-- create partition
Example_Partitions := Partitions.Create_Partitions (Args => (2, 0, 2));
-- pretty print the result
declare
use type Partitions.Partition_Sets.Cursor;
Position : Partitions.Partition_Sets.Cursor := Example_Partitions.First;
begin
Ada.Text_IO.Put ('{');
while Position /= Partitions.Partition_Sets.No_Element loop
if Position /= Example_Partitions.First then
Ada.Text_IO.Put (' ');
end if;
declare
Current_Partition : constant Partitions.Partition :=
Partitions.Partition_Sets.Element (Position);
begin
Ada.Text_IO.Put ('(');
for I in Current_Partition'Range loop
Ada.Text_IO.Put ('{');
declare
use type Partitions.Number_Sets.Cursor;
Current_Number : Partitions.Number_Sets.Cursor :=
Current_Partition (I).First;
begin
while Current_Number /= Partitions.Number_Sets.No_Element
loop
Natural_IO.Put
(Item =>
Partitions.Number_Sets.Element (Current_Number),
Width => 1);
Partitions.Number_Sets.Next (Current_Number);
if Current_Number /=
Partitions.Number_Sets.No_Element then
Ada.Text_IO.Put (',');
end if;
end loop;
end;
Ada.Text_IO.Put ('}');
if I /= Current_Partition'Last then
Ada.Text_IO.Put (", ");
end if;
end loop;
end;
Ada.Text_IO.Put (')');
Partitions.Partition_Sets.Next (Position);
if Position /= Partitions.Partition_Sets.No_Element then
Ada.Text_IO.Put (',');
Ada.Text_IO.New_Line;
end if;
end loop;
Ada.Text_IO.Put ('}');
Ada.Text_IO.New_Line;
end;
end Main;

Output:

Partitions for (2, 0, 2):
{({1,2}, {}, {3,4}),
 ({1,3}, {}, {2,4}),
 ({1,4}, {}, {2,3}),
 ({2,3}, {}, {1,4}),
 ({2,4}, {}, {1,3}),
 ({3,4}, {}, {1,2})}

[edit] BBC BASIC

      DIM list1%(2) : list1%() = 2, 0, 2
PRINT "partitions(2,0,2):"
PRINT FNpartitions(list1%())
DIM list2%(2) : list2%() = 1, 1, 1
PRINT "partitions(1,1,1):"
PRINT FNpartitions(list2%())
DIM list3%(3) : list3%() = 1, 2, 0, 1
PRINT "partitions(1,2,0,1):"
PRINT FNpartitions(list3%())
END
 
DEF FNpartitions(list%())
LOCAL i%, j%, n%, p%, o$, x%()
n% = DIM(list%(),1)
DIM x%(SUM(list%())-1)
FOR i% = 0 TO n%
IF list%(i%) THEN
FOR j% = 1 TO list%(i%)
x%(p%) = i%
p% += 1
NEXT
ENDIF
NEXT i%
REPEAT
FOR i% = 0 TO n%
o$ += " ( "
FOR j% = 0 TO DIM(x%(),1)
IF x%(j%) = i% o$ += STR$(j%+1) + " "
NEXT
o$ += ")"
NEXT i%
o$ += CHR$13 + CHR$10
UNTIL NOT FNperm(x%())
= o$
 
DEF FNperm(x%())
LOCAL i%, j%
FOR i% = DIM(x%(),1)-1 TO 0 STEP -1
IF x%(i%) < x%(i%+1) EXIT FOR
NEXT
IF i% < 0 THEN = FALSE
j% = DIM(x%(),1)
WHILE x%(j%) <= x%(i%) j% -= 1 : ENDWHILE
SWAP x%(i%), x%(j%)
i% += 1
j% = DIM(x%(),1)
WHILE i% < j%
SWAP x%(i%), x%(j%)
i% += 1
j% -= 1
ENDWHILE
= TRUE

Output:

partitions(2,0,2):
 ( 1 2 ) ( ) ( 3 4 )
 ( 1 3 ) ( ) ( 2 4 )
 ( 1 4 ) ( ) ( 2 3 )
 ( 2 3 ) ( ) ( 1 4 )
 ( 2 4 ) ( ) ( 1 3 )
 ( 3 4 ) ( ) ( 1 2 )

partitions(1,1,1):
 ( 1 ) ( 2 ) ( 3 )
 ( 1 ) ( 3 ) ( 2 )
 ( 2 ) ( 1 ) ( 3 )
 ( 3 ) ( 1 ) ( 2 )
 ( 2 ) ( 3 ) ( 1 )
 ( 3 ) ( 2 ) ( 1 )

partitions(1,2,0,1):
 ( 1 ) ( 2 3 ) ( ) ( 4 )
 ( 1 ) ( 2 4 ) ( ) ( 3 )
 ( 1 ) ( 3 4 ) ( ) ( 2 )
 ( 2 ) ( 1 3 ) ( ) ( 4 )
 ( 2 ) ( 1 4 ) ( ) ( 3 )
 ( 3 ) ( 1 2 ) ( ) ( 4 )
 ( 4 ) ( 1 2 ) ( ) ( 3 )
 ( 3 ) ( 1 4 ) ( ) ( 2 )
 ( 4 ) ( 1 3 ) ( ) ( 2 )
 ( 2 ) ( 3 4 ) ( ) ( 1 )
 ( 3 ) ( 2 4 ) ( ) ( 1 )
 ( 4 ) ( 2 3 ) ( ) ( 1 )

[edit] C

Watch out for blank for loops. Iterative permutation generation is described at [[2]]; code messness is purely mine.

#include <stdio.h>
 
int next_perm(int size, int * nums)
{
int *l, *k, tmp;
 
for (k = nums + size - 2; k >= nums && k[0] >= k[1]; k--) {};
if (k < nums) return 0;
 
for (l = nums + size - 1; *l <= *k; l--) {};
tmp = *k; *k = *l; *l = tmp;
 
for (l = nums + size - 1, k++; k < l; k++, l--) {
tmp = *k; *k = *l; *l = tmp;
}
 
return 1;
}
 
void make_part(int n, int * sizes)
{
int x[1024], i, j, *ptr, len = 0;
 
for (ptr = x, i = 0; i < n; i++)
for (j = 0, len += sizes[i]; j < sizes[i]; j++, *(ptr++) = i);
 
do {
for (i = 0; i < n; i++) {
printf(" { ");
for (j = 0; j < len; j++)
if (x[j] == i) printf("%d ", j);
 
printf("}");
}
printf("\n");
} while (next_perm(len, x));
}
 
int main()
{
int s1[] = {2, 0, 2};
int s2[] = {1, 2, 3, 4};
 
printf("Part 2 0 2:\n");
make_part(3, s1);
 
printf("\nPart 1 2 3 4:\n");
make_part(4, s2);
 
return 1;
}

Output:

Part 2 0 2:
 { 0 1 } { } { 2 3 }
 { 0 2 } { } { 1 3 }
 { 0 3 } { } { 1 2 }
 { 1 2 } { } { 0 3 }
 { 1 3 } { } { 0 2 }
 { 2 3 } { } { 0 1 }

Part 1 2 3 4:
 { 0 } { 1 2 } { 3 4 5 } { 6 7 8 9 }
 { 0 } { 1 2 } { 3 4 6 } { 5 7 8 9 }
 { 0 } { 1 2 } { 3 4 7 } { 5 6 8 9 }
 { 0 } { 1 2 } { 3 4 8 } { 5 6 7 9 }
 { 0 } { 1 2 } { 3 4 9 } { 5 6 7 8 }
 { 0 } { 1 2 } { 3 5 6 } { 4 7 8 9 }
....
With bitfield:
#include <stdio.h>
 
typedef unsigned int uint;
 
int parts[] = {2, 1, 2};
#define n_parts sizeof(parts)/sizeof(parts[0])
int bits[n_parts];
 
void show_part(uint x)
{
uint i;
putchar('{');
for (i = 0; (1 << i) <= x; i ++)
if (x & (1 << i)) printf(" %d", i + 1);
 
printf("%s", " } ");
}
 
void gen_bits(uint mask, uint all, uint res, int n, int pid)
{
uint i;
while (!n) {
bits[pid++] = res;
if (pid == n_parts) {
for (i = 0; i < n_parts; i++)
show_part(bits[i]);
putchar('\n');
return;
}
mask = all &= ~res;
res = 0;
n = parts[pid];
}
 
while (mask) {
mask &= ~(i = mask & -(int)mask);
gen_bits(mask, all, res | i, n - 1, pid);
}
}
 
int main(void)
{
uint i, m;
for (m = 1, i = 0; i < n_parts; i++)
m <<= parts[i];
m--;
 
gen_bits(m, m, 0, parts[0], 0);
 
return 0;
}

[edit] Common Lisp

Lexicographical generation of partitions. Pros: can handle duplicate elements; probably faster than some methods generating all permutations then throwing bad ones out. Cons: clunky (which is probably my fault).

(defun fill-part (x i j l)
(let ((e (elt x i)))
(loop for c in l do
(loop while (>= j (length e)) do
(setf j 0 e (elt x (incf i))))
(setf (elt e j) c)
(incf j))))
 
;;; take a list of lists and return next partitioning
;;; it's caller's responsibility to ensure each sublist is sorted
(defun next-part (list cmp)
(let* ((l (coerce list 'vector))
(i (1- (length l)))
(e (elt l i)))
(loop while (<= 0 (decf i)) do
;; e holds all the right most elements
(let ((p (elt l i)) (q (car (last e))))
;; find the right-most list that has an element that's smaller
;; than _something_ in later lists
(when (and p (funcall cmp (first p) q))
;; find largest element that can be increased
(loop for j from (1- (length p)) downto 0 do
(when (funcall cmp (elt p j) q)
;; find the smallest element that's larger than
;; that largest
(loop for x from 0 to (1- (length e)) do
(when (funcall cmp (elt p j) (elt e x))
(rotatef (elt p j) (elt e x))
(loop while (< (incf j) (length p)) do
(setf (elt p j) (elt e (incf x))
(elt e x) nil))
(fill-part l i j (remove nil e))
(return-from next-part l))))
(setf e (append e (list (elt p j))))))
(setf e (append e p))))))
 
(let ((a '#((1 2) () (3 4))))
(loop while a do
(format t "~a~%" a)
(setf a (next-part a #'<))))
 
(write-line "with dupe elements:")
(let ((a '#((a c) (c c d))))
(loop while a do
(format t "~a~%" a)
(setf a (next-part a #'string<))))
output
#((1 2) NIL (3 4))
#((1 3) NIL (2 4))
#((1 4) NIL (2 3))
#((2 3) NIL (1 4))
#((2 4) NIL (1 3))
#((3 4) NIL (1 2))
with dupe elements:
#((A C) (C C D))
#((A D) (C C C))
#((C C) (A C D))
#((C D) (A C C))

[edit] D

Translation of: Python

Using code from this lexicographical Combination (version 4).

import std.stdio, std.algorithm, std.range, std.array, std.conv;
import combinations4: Comb;
 
alias iRNG = int[];
 
iRNG setDiff(iRNG s, iRNG c) {
return setDifference(s, c).array;
}
 
iRNG[][] orderPart(iRNG blockSize...) {
iRNG sum = iota(1, 1 + blockSize.sum).array;
 
iRNG[][] p(iRNG s, in iRNG b) {
if (b.length == 0)
return [[]];
iRNG[][] res;
foreach (c; Comb.On(s, b[0]))
foreach (r; p(setDiff(s, c), b.dropOne))
res ~= c.dup ~ r;
return res;
}
 
return p(sum, blockSize);
}
 
void main(in string[] args) {
auto b = args.length > 1 ? args.dropOne.to!(int[]) : [2, 0, 2];
writefln("%(%s\n%)", b.orderPart);
}
Output:
[[1, 2], [], [3, 4]]
[[1, 3], [], [2, 4]]
[[1, 4], [], [2, 3]]
[[2, 3], [], [1, 4]]
[[2, 4], [], [1, 3]]
[[3, 4], [], [1, 2]]

[edit] GAP

FixedPartitions := function(arg)
local aux;
aux := function(i, u)
local r, v, w;
if i = Size(arg) then
return [[u]];
else
r := [ ];
for v in Combinations(u, arg[i]) do
for w in aux(i + 1, Difference(u, v)) do
Add(r, Concatenation([v], w));
od;
od;
return r;
fi;
end;
return aux(1, [1 .. Sum(arg)]);
end;
 
 
FixedPartitions(2, 0, 2);
# [ [ [ 1, 2 ], [ ], [ 3, 4 ] ], [ [ 1, 3 ], [ ], [ 2, 4 ] ],
# [ [ 1, 4 ], [ ], [ 2, 3 ] ], [ [ 2, 3 ], [ ], [ 1, 4 ] ],
# [ [ 2, 4 ], [ ], [ 1, 3 ] ], [ [ 3, 4 ], [ ], [ 1, 2 ] ] ]
 
FixedPartitions(1, 1, 1);
# [ [ [ 1 ], [ 2 ], [ 3 ] ], [ [ 1 ], [ 3 ], [ 2 ] ], [ [ 2 ], [ 1 ], [ 3 ] ],
# [ [ 2 ], [ 3 ], [ 1 ] ], [ [ 3 ], [ 1 ], [ 2 ] ], [ [ 3 ], [ 2 ], [ 1 ] ] ]

[edit] Go

package main
 
import (
"fmt"
"os"
"strconv"
)
 
func gen_part(n, res []int, pos int) {
if pos == len(res) {
x := make([][]int, len(n))
for i, c := range res {
x[c] = append(x[c], i+1)
}
 
fmt.Println(x)
return
}
 
for i := range n {
if n[i] == 0 {
continue
}
n[i], res[pos] = n[i]-1, i
gen_part(n, res, pos+1)
n[i]++
}
}
 
func ordered_part(n_parts []int) {
fmt.Println("Ordered", n_parts)
 
sum := 0
for _, c := range n_parts {
sum += c
}
 
gen_part(n_parts, make([]int, sum), 0)
}
 
func main() {
if len(os.Args) < 2 {
ordered_part([]int{2, 0, 2})
return
}
n := make([]int, len(os.Args)-1)
var err error
for i, a := range os.Args[1:] {
n[i], err = strconv.Atoi(a)
if err != nil {
fmt.Println(err)
return
}
if n[i] < 0 {
fmt.Println("negative partition size not meaningful")
return
}
}
ordered_part(n)
}

Example command line use:

> op
Ordered [2 0 2]
[[1 2] [] [3 4]]
[[1 3] [] [2 4]]
[[1 4] [] [2 3]]
[[2 3] [] [1 4]]
[[2 4] [] [1 3]]
[[3 4] [] [1 2]]

> op 1 1 1
Ordered [1 1 1]
[[1] [2] [3]]
[[1] [3] [2]]
[[2] [1] [3]]
[[3] [1] [2]]
[[2] [3] [1]]
[[3] [2] [1]]

> op 1 2 3 4 | head
Ordered [1 2 3 4]
[[1] [2 3] [4 5 6] [7 8 9 10]]
[[1] [2 3] [4 5 7] [6 8 9 10]]
[[1] [2 3] [4 5 8] [6 7 9 10]]
[[1] [2 3] [4 5 9] [6 7 8 10]]
[[1] [2 3] [4 5 10] [6 7 8 9]]
[[1] [2 3] [4 6 7] [5 8 9 10]]
[[1] [2 3] [4 6 8] [5 7 9 10]]
[[1] [2 3] [4 6 9] [5 7 8 10]]
[[1] [2 3] [4 6 10] [5 7 8 9]]

[edit] Groovy

Solution:

def partitions = { int... sizes ->
int n = (sizes as List).sum()
def perms = n == 0 ? [[]] : (1..n).permutations()
Set parts = perms.collect { p -> sizes.collect { s -> (0..<s).collect { p.pop() } as Set } }
parts.sort{ a, b ->
if (!a) return 0
def comp = [a,b].transpose().find { it[0] != it[1] }
if (!comp) return 0
def recomp = comp.collect{ it as List }.transpose().find { it[0] != it[1] }
if (!recomp) return 0
return recomp[0] <=> recomp[1]
}
}

Test:

partitions(2, 0, 2).each {
println it
}

Output:

[[1, 2], [], [3, 4]]
[[1, 3], [], [2, 4]]
[[1, 4], [], [2, 3]]
[[2, 3], [], [1, 4]]
[[2, 4], [], [1, 3]]
[[3, 4], [], [1, 2]]

[edit] Haskell

import Data.List ((\\))
 
comb :: Int -> [a] -> [[a]]
comb 0 _ = [[]]
comb _ [] = []
comb k (x:xs) = map (x:) (comb (k-1) xs) ++ comb k xs
 
partitions :: [Int] -> [[[Int]]]
partitions xs = p [1..sum xs] xs
where p _ [] = [[]]
p xs (k:ks) = [ cs:rs | cs <- comb k xs, rs <- p (xs \\ cs) ks ]
 
main = print $ partitions [2,0,2]

An alternative where \\ is not needed anymore because comb now not only keeps the chosen elements but also the not chosen elements together in a tuple.

comb :: Int -> [a] -> [([a],[a])]
comb 0 xs = [([],xs)]
comb _ [] = []
comb k (x:xs) = [ (x:cs,zs) | (cs,zs) <- comb (k-1) xs ] ++
[ (cs,x:zs) | (cs,zs) <- comb k xs ]
 
partitions :: [Int] -> [[[Int]]]
partitions xs = p [1..sum xs] xs
where p _ [] = [[]]
p xs (k:ks) = [ cs:rs | (cs,zs) <- comb k xs, rs <- p zs ks ]
 
main = print $ partitions [2,0,2]

Output:

[[[1,2],[],[3,4]],[[1,3],[],[2,4]],[[1,4],[],[2,3]],[[2,3],[],[1,4]],[[2,4],[],[1,3]],[[3,4],[],[1,2]]]

Faster by keeping track of the length of lists:

-- choose m out of n items, return tuple of chosen and the rest
choose aa _ 0 = [([], aa)]
choose aa@(a:as) n m
| n == m = [(aa, [])]
| otherwise = map (\(x,y) -> (a:x, y)) (choose as (n-1) (m-1)) ++
map (\(x,y) -> (x, a:y)) (choose as (n-1) m)
 
partitions x = combos [1..n] n x where
n = sum x
combos _ _ [] = [[]]
combos s n (x:xs) = [ l : r | (l,rest) <- choose s n x,
r <- combos rest (n - x) xs]
 
 
main = mapM_ print $ partitions [5,5,5]

[edit] J

Brute force approach:

require'stats'
partitions=: ([,] {L:0 (i.@#@, -. [)&;)/"1@>@,@{@({@comb&.> +/\.)

First we compute each of the corresponding combinations for each argument, then we form their cartesian product and then we restructure each of those products by: eliminating from values populating the the larger set combinations the combinations already picked from the smaller set and using the combinations from the larger set to index into the options which remain.

Examples:

   partitions 2 0 2
┌───┬┬───┐
0 1││2 3
├───┼┼───┤
0 2││1 3
├───┼┼───┤
0 3││1 2
├───┼┼───┤
1 2││0 3
├───┼┼───┤
1 3││0 2
├───┼┼───┤
2 3││0 1
└───┴┴───┘
partitions 1 1 1
┌─┬─┬─┐
012
├─┼─┼─┤
021
├─┼─┼─┤
102
├─┼─┼─┤
120
├─┼─┼─┤
201
├─┼─┼─┤
210
└─┴─┴─┘
#partitions 2 3 5
2520
#partitions 5 7 11
|out of memory: partitions
| # partitions 5 7 11
*/ (! +/\.)5 7 11
1070845776
#partitions 3 5 7
360360
*/ (! +/\.)3 5 7
360360

[edit] Lua

A pretty verbose solution. Maybe somebody can replace with something terser/better.

--- Create a list {1,...,n}.
local function range(n)
local res = {}
for i=1,n do
res[i] = i
end
return res
end
 
--- Return true if the element x is in t.
local function isin(t, x)
for _,x_t in ipairs(t) do
if x_t == x then return true end
end
return false
end
 
--- Return the sublist from index u to o (inclusive) from t.
local function slice(t, u, o)
local res = {}
for i=u,o do
res[#res+1] = t[i]
end
return res
end
 
--- Compute the sum of the elements in t.
-- Assume that t is a list of numbers.
local function sum(t)
local s = 0
for _,x in ipairs(t) do
s = s + x
end
return s
end
 
--- Generate all combinations of t of length k (optional, default is #t).
local function combinations(m, r)
local function combgen(m, n)
if n == 0 then coroutine.yield({}) end
for i=1,#m do
if n == 1 then coroutine.yield({m[i]})
else
for m0 in coroutine.wrap(function() combgen(slice(m, i+1, #m), n-1) end) do
coroutine.yield({m[i], unpack(m0)})
end
end
end
end
return coroutine.wrap(function() combgen(m, r) end)
end
 
--- Generate a list of partitions into fized-size blocks.
local function partitions(...)
local function helper(s, ...)
local args = {...}
if #args == 0 then return {% templatetag openvariable %}{% templatetag closevariable %} end
local res = {}
for c in combinations(s, args[1]) do
local s0 = {}
for _,x in ipairs(s) do if not isin(c, x) then s0[#s0+1] = x end end
for _,r in ipairs(helper(s0, unpack(slice(args, 2, #args)))) do
res[#res+1] = {{unpack(c)}, unpack(r)}
end
end
return res
end
return helper(range(sum({...})), ...)
end
 
-- Print the solution
io.write "["
local parts = partitions(2,0,2)
for i,tuple in ipairs(parts) do
io.write "("
for j,set in ipairs(tuple) do
io.write "{"
for k,element in ipairs(set) do
io.write(element)
if k ~= #set then io.write(", ") end
end
io.write "}"
if j ~= #tuple then io.write(", ") end
end
io.write ")"
if i ~= #parts then io.write(", ") end
end
io.write "]"
io.write "\n"

Output:

[({1, 2}, {}, {3, 4}), ({1, 3}, {}, {2, 4}), ({1, 4}, {}, {2, 3}), ({2, 3}, {}, {1, 4}), ({2, 4}, {}, {1, 3}), ({3, 4}, {}, {1, 2})]


[edit] Mathematica

This code works as follows:

Permutations finds all permutations of the numbers ranging from 1 to n.

w finds the required partition for an individual permutation.

m finds partitions for all permutations.

Sort and Union eliminate duplicates.

 
w[partitions_]:=Module[{s={},t=Total@partitions,list=partitions,k}, n=Length[list];
While[n>0,s=Join[s,{Take[t,(k=First[list])]}];t=Drop[t,k];list=Rest[list];n--]; s]
 
m[p_]:=(Sort/@#)&/@(w[#,p]&/@Permutations[Range@Total[p]])//Union
 


Usage

Grid displays the output in a table.

 
Grid@m[{2, 0, 2}]
 
Grid@m[{1, 1, 1}]
 

Example.png

[edit] Perl

Code 1: threaded generator method. This code demonstrates how to make something like Python's generators or Go's channels by using Thread::Queue. Granted, this is horribly inefficient, with constantly creating and killing threads and whatnot (every time a partition is created, a thread is made to produce the next partition, so thousands if not millions of threads live and die, depending on the problem size). But algorithms are often more naturally expressed in a coroutine manner -- for this example, "making a new partition" and "picking elements for a partition" can be done in separate recursions cleanly if so desired. It's about 20 times slower than the next code example, so there.

use Thread 'async';
use Thread::Queue;
 
sub make_slices {
my ($n, @avail) = (shift, @{ +shift });
 
my ($q, @part, $gen);
$gen = sub {
my $pos = shift; # where to start in the list
if (@part == $n) {
# we accumulated enough for a partition, emit them and
# wait for main thread to pick them up, then back up
$q->enqueue(\@part, \@avail);
return;
}
 
# obviously not enough elements left to make a partition, back up
return if (@part + @avail < $n);
 
for my $i ($pos .. @avail - 1) { # try each in turn
push @part, splice @avail, $i, 1; # take one
$gen->($i); # go deeper
splice @avail, $i, 0, pop @part; # put it back
}
};
 
$q = new Thread::Queue;
(async{ &$gen; # start the main work load
$q->enqueue(undef) # signal that there's no more data
})->detach; # let the thread clean up after itself, not my problem
 
return $q;
}
 
my $qa = make_slices(4, [ 0 .. 9 ]);
while (my $a = $qa->dequeue) {
my $qb = make_slices(2, $qa->dequeue);
 
while (my $b = $qb->dequeue) {
my $rb = $qb->dequeue;
print "@$a | @$b | @$rb\n";
}
}
 

Code 2: Ugly but simple recursion method.

sub partitions {
my $sum = 0;
$sum += $_ for @_; # total number of elements
make_part ( $_[-1], # desired partition size
0, # initial trial position
[ (0) x $sum ], # table recording of used element
[], # current pick for current partition
[ $#_, # total number of partitions
\@_, # partition sizes
[] # for output, each partition's elements
] # Note: last group of args wrapped in array ref
); # to reduce argument passing overhead
}
 
sub make_part {
my ($n, $pos, $used, $picked, $more) = @_;
return if $pos > @$used;
 
# the making-next-partition part
if (!$n) {
my ($part_idx, $sizes, $q) = @$more;
push @$q, $picked;
if ($part_idx > 1) {
make_part($sizes->[$part_idx-1], 0, $used, [],
[ $part_idx-1, $sizes, $q]);
} else {
my @x = grep { !$used->[$_] } 0 .. (@$used-1);
print "[ @$_ ]" for @$q;
print "[ @x ]\n";
}
pop @$q;
return;
}
 
# the picking-element-to-make-partition part
for my $i ($pos .. @$used - 1) {
next if $used->[$i];
push @$picked, $i;
$used->[$i] = 1;
 
make_part($n - 1, $i + 1, $used, $picked, $more);
 
$used->[$i] = 0;
pop @$picked;
}
}
 
partitions(4, 2, 4);
 

[edit] Perl 6

Works with: niecza version 2012-06
sub partition(@mask is copy) {
my $last = [+] @mask or return [[] xx @mask];
sort gather for @mask.kv -> $k,$v {
next unless $v;
temp @mask[$k] -= 1;
for partition @mask { .take.[$k].push($last) }
}
}
 
.perl.say for partition [2,0,2];
Output:
[[1, 2], [], [3, 4]]
[[1, 3], [], [2, 4]]
[[2, 3], [], [1, 4]]
[[1, 4], [], [2, 3]]
[[2, 4], [], [1, 3]]
[[3, 4], [], [1, 2]]

[edit] PicoLisp

Uses the 'comb' function from Combinations#PicoLisp

(de partitions (Args)
(let Lst (range 1 (apply + Args))
(recur (Args Lst)
(ifn Args
'(NIL)
(mapcan
'((L)
(mapcar
'((R) (cons L R))
(recurse (cdr Args) (diff Lst L)) ) )
(comb (car Args) Lst) ) ) ) ) )

Output:

: (more (partitions (2 0 2)))
((1 2) NIL (3 4))
((1 3) NIL (2 4))
((1 4) NIL (2 3))
((2 3) NIL (1 4))
((2 4) NIL (1 3))
((3 4) NIL (1 2))
-> NIL

: (more (partitions (1 1 1)))
((1) (2) (3))
((1) (3) (2))
((2) (1) (3))
((2) (3) (1))
((3) (1) (2))
((3) (2) (1))
-> NIL

[edit] Python

from itertools import combinations
 
def partitions(*args):
def p(s, *args):
if not args: return [[]]
res = []
for c in combinations(s, args[0]):
s0 = [x for x in s if x not in c]
for r in p(s0, *args[1:]):
res.append([c] + r)
return res
s = range(sum(args))
return p(s, *args)
 
print partitions(2, 0, 2)

An equivalent but terser solution.

from itertools import combinations as comb
 
def partitions(*args):
def minus(s1, s2): return [x for x in s1 if x not in s2]
def p(s, *args):
if not args: return [[]]
return [[c] + r for c in comb(s, args[0]) for r in p(minus(s, c), *args[1:])]
return p(range(1, sum(args) + 1), *args)
 
print partitions(2, 0, 2)

Output:

[[(0, 1), (), (2, 3)], [(0, 2), (), (1, 3)], [(0, 3), (), (1, 2)], [(1, 2), (), (0, 3)], [(1, 3), (), (0, 2)], [(2, 3), (), (0, 1)]]

[edit] Racket

Translation of: Haskell
 
#lang racket
(define (comb k xs)
(cond [(zero? k) (list (cons '() xs))]
[(null? xs) '()]
[else (append (for/list ([cszs (comb (sub1 k) (cdr xs))])
(cons (cons (car xs) (car cszs)) (cdr cszs)))
(for/list ([cszs (comb k (cdr xs))])
(cons (car cszs) (cons (car xs) (cdr cszs)))))]))
(define (partitions xs)
(define (p xs ks)
(if (null? ks)
'(())
(for*/list ([cszs (comb (car ks) xs)] [rs (p (cdr cszs) (cdr ks))])
(cons (car cszs) rs))))
(p (range 1 (add1 (foldl + 0 xs))) xs))
 
(define (run . xs)
(printf "partitions~s:\n" xs)
(for ([x (partitions xs)]) (printf " ~s\n" x))
(newline))
 
(run 2 0 2)
(run 1 1 1)
 

Output:

partitions(2 0 2):
  ((1 2) () (3 4))
  ((1 3) () (2 4))
  ((1 4) () (2 3))
  ((2 3) () (1 4))
  ((2 4) () (1 3))
  ((3 4) () (1 2))

partitions(1 1 1):
  ((1) (2) (3))
  ((1) (3) (2))
  ((2) (1) (3))
  ((2) (3) (1))
  ((3) (1) (2))
  ((3) (2) (1))

[edit] Ruby

def partition(mask)
return [[]] if mask.empty?
a = (0...mask.inject(:+)).to_a
res = a.permutation.map do |perm|
mask.map {|num_elts| perm.shift(num_elts).sort }
end
res.uniq
end
 
[[],[0,0,0],[1,1,1],[2,0,2]].each do |test_case|
p test_case
partition(test_case).each{|part| p part }
puts
end
Output:

[] []

[0, 0, 0] [[], [], []]

[1, 1, 1] [[1], [2], [3]] [[1], [3], [2]] [[2], [1], [3]] [[2], [3], [1]] [[3], [1], [2]] [[3], [2], [1]]

[2, 0, 2] [[1, 2], [], [3, 4]] [[1, 3], [], [2, 4]] [[1, 4], [], [2, 3]] [[2, 3], [], [1, 4]] [[2, 4], [], [1, 3]] [[3, 4], [], [1, 2]]

[edit] Tcl

Library: Tcllib (Package: struct::set)
package require Tcl 8.5
package require struct::set
 
# Selects all k-sized combinations from a list.
# "Borrowed" from elsewhere on RC
proc selectCombinationsFrom {k l} {
if {$k == 0} {return {}} elseif {$k == [llength $l]} {return [list $l]}
set all {}
set n [expr {[llength $l] - [incr k -1]}]
for {set i 0} {$i < $n} {} {
set first [lindex $l $i]
incr i
if {$k == 0} {
lappend all $first
} else {
foreach s [selectCombinationsFrom $k [lrange $l $i end]] {
lappend all [list $first {*}$s]
}
}
}
return $all
}
 
# Construct the partitioning of a given list
proc buildPartitions {lst n args} {
# Base case when we have no further partitions to process
if {[llength $args] == 0} {
return [list [list $lst]]
}
set result {}
set c [selectCombinationsFrom $n $lst]
if {[llength $c] == 0} {set c [list $c]}
foreach comb $c {
# Sort necessary for "nice" order
set rest [lsort -integer [struct::set difference $lst $comb]]
foreach p [buildPartitions $rest {*}$args] {
lappend result [list $comb {*}$p]
}
}
return $result
}
 
# Wrapper that assembles the initial list and calls the partitioner
proc partitions args {
set sum [tcl::mathop::+ {*}$args]
set startingSet {}
for {set i 1} {$i <= $sum} {incr i} {
lappend startingSet $i
}
 
return [buildPartitions $startingSet {*}$args]
}

Demonstration code:

puts [partitions 1 1 1]
puts [partitions 2 2]
puts [partitions 2 0 2]
puts [partitions 2 2 0]

Output:

{1 2 3} {1 3 2} {2 1 3} {2 3 1} {3 1 2} {3 2 1}
{{1 2} {3 4}} {{1 3} {2 4}} {{1 4} {2 3}} {{2 3} {1 4}} {{2 4} {1 3}} {{3 4} {1 2}}
{{1 2} {} {3 4}} {{1 3} {} {2 4}} {{1 4} {} {2 3}} {{2 3} {} {1 4}} {{2 4} {} {1 3}} {{3 4} {} {1 2}}
{{1 2} {3 4} {}} {{1 3} {2 4} {}} {{1 4} {2 3} {}} {{2 3} {1 4} {}} {{2 4} {1 3} {}} {{3 4} {1 2} {}}

[edit] Ursala

#import std
#import nat
 
opart =
 
-+
~&art^?\~&alNCNC ^|JalSPfarSPMplrDSL/~& ^DrlPrrPlXXS/~&rt ^DrlrjXS/~&l choices@lrhPX,
^\~& nrange/1+ sum:-0+-
The library function choices used in this solution takes a pair (s,k) and returns the set of all subsets of s having cardinality k. The library function nrange takes a pair of natural numbers to the minimum consecutive sequence containing them. The sum function adds a pair of natural numbers.
#cast %nLLL
 
test = opart <2,0,2>

output:

<
   <<1,2>,<>,<3,4>>,
   <<1,3>,<>,<2,4>>,
   <<1,4>,<>,<2,3>>,
   <<2,3>,<>,<1,4>>,
   <<2,4>,<>,<1,3>>,
   <<3,4>,<>,<1,2>>>
Personal tools
Namespaces

Variants
Actions
Community
Explore
Misc
Toolbox