# How to generate all possible orderless partitions of a list according to another list?

This question is hard to describe in plain text. So I will post an example and a working code (brute force) to illustrate.

For example I have a list: {1, 2, 3, 4, 5} and a partition list {2, 2, 1}. I will first choose 2 elements (there are 10 ways to do so), and then choose another 2 elements from the rest of the list (of length 3 and there are 3 ways to do so). The output is

{{{1, 2}, {3, 4}, {5}}, {{1, 2}, {3, 5}, {4}}, {{1, 2}, {4,
5}, {3}}, {{1, 3}, {2, 4}, {5}}, {{1, 3}, {2, 5}, {4}}, {{1,
3}, {4, 5}, {2}}, {{1, 4}, {2, 3}, {5}}, {{1, 4}, {2,
5}, {3}}, {{1, 4}, {3, 5}, {2}}, {{1, 5}, {2, 3}, {4}}, {{1,
5}, {2, 4}, {3}}, {{1, 5}, {3, 4}, {2}}, {{2, 3}, {1,
4}, {5}}, {{2, 3}, {1, 5}, {4}}, {{2, 3}, {4, 5}, {1}}, {{2,
4}, {1, 3}, {5}}, {{2, 4}, {1, 5}, {3}}, {{2, 4}, {3,
5}, {1}}, {{2, 5}, {1, 3}, {4}}, {{2, 5}, {1, 4}, {3}}, {{2,
5}, {3, 4}, {1}}, {{3, 4}, {1, 2}, {5}}, {{3, 4}, {1,
5}, {2}}, {{3, 4}, {2, 5}, {1}}, {{3, 5}, {1, 2}, {4}}, {{3,
5}, {1, 4}, {2}}, {{3, 5}, {2, 4}, {1}}, {{4, 5}, {1,
2}, {3}}, {{4, 5}, {1, 3}, {2}}, {{4, 5}, {2, 3}, {1}}}


The current working code is very memory-inefficient because it generates unnecessary lists first and deletes them later. Here it is:

f[list_, partition_] :=
DeleteDuplicates[
Sort /@ InternalPartitionRagged[#, partition] & /@
Permutations[list]]


I am also working on using Subsets to generate directly, but I have got lost in Folding with brackets, and the code is very long. Any elegant or efficient solutions would be appreciated.

• Related: (3044), (8528), (19672). Somewhat less related: (5036) Commented Aug 13, 2016 at 15:01
• Is it intentional that the desired result contains both {{1, 2}, {3, 4}, {5}} and {{3, 4}, {1, 2}, {5}}? They differ only in order, albeit at a higher level than the raw elements. Commented Aug 13, 2016 at 15:32
• @WReach yes, the groups are distinct. Commented Aug 13, 2016 at 15:55

A solution using Repeated, ReplaceList, and the Orderless attribute.

part[a_List, p_List] :=
Module[{f, sym},
Attributes[f] = Orderless;
sym = Unique["x", Temporary] & /@ p;
ReplaceList[
f @@ a,
f @@ MapThread[Pattern[#, Repeated[_, {#2}]] &, {sym, p}] -> List /@ sym
]
]

part[{1, 2, 3, 4, 5}, {2, 2, 1}]

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


This proves to be an order of magnitude faster than BoLe's code:

SeedRandom[1]
p = RandomInteger[{1, 3}, 6];
a = Range @ Tr @ p;

Flatten[split[a, p]] /. sol -> List  // Length // RepeatedTiming

part[a, p]                           // Length // RepeatedTiming

{0.7517, 45360}

{0.0766, 45360}


### Relation to Permutations

Note: I completely overlooked Simon Woods's answer before starting on this section. Nevertheless after reading and digesting his answer I believe I have something unique to offer.

I was reminded of a different approach to this problem using Permutations thanks to an apparently coincidental vote on an old answer of mine:

Consider that there is a one-to-one mapping between your target list and this:

Permutations[{1, 1, 2, 2, 3}]

{{1, 1, 2, 2, 3}, {1, 1, 2, 3, 2}, . . ., {3, 2, 1, 2, 1}, {3, 2, 2, 1, 1}}


Permutations by itself is very efficient. It is nearly two orders of magnitude better than part defined above, and its output takes a fraction of the memory:

maskFn = Permutations @* Flatten @* MapIndexed[Table[#2, {#}] &];

a = Range @ 12;
p = {2, 3, 1, 3, 2, 1};

part[a, p] // ByteCount // RepeatedTiming

{6.49, 2075673680}

{0.0984, 319334552}


If you can write whatever operations follow this in terms of the permutation masks rather than the partitions there is clearly the potential for a major optimization.

Now, after reading Simon's answer and being inspired by it, I offer the following solution.

We can use Ordering as Simon did to convert the permutations, and then split the result using a slight modification of my dynP from:

This provides my second proposal:

maskFn = Permutations @* Flatten @* MapIndexed[Table[#2, {#}] &];

dynP2[m_, p_] :=
m[[All, # ;; #2]] &,
{{0} ~Join~ Most@# + 1, #} & @ Accumulate @ p
]\[Transpose]

part2[a_List, p_List] := dynP2[a[[ Ordering @ # ]] & /@ maskFn[p], p]


Comparing (in v10.1) the performance of both of my functions to Simon's parts:

a = Alphabet[] ~Take~ 11;
p = {2, 1, 3, 1, 2, 2};

RepeatedTiming @ Length @ #[a, p] & /@ {part, part2, parts}

{{1.452, 831600}, {2.052, 831600}, {2.30, 831600}}


And again but with a packable a list:

a = Range @ 11;
p = {2, 1, 3, 1, 2, 2};

RepeatedTiming @ Length @ #[a, p] & /@ {part, part2, parts}

{{1.45, 831600}, {1.59, 831600}, {1.43, 831600}}


It seems to me that part is still the best general function, but Simon's code is slightly faster in the case of a packed/packable input list.

Permutations treats repeated elements as identical, so you can get a flattened version of the desired result with something like

Ordering /@ Permutations[{1, 1, 2, 2, 3}]

(* {{1, 2, 3, 4, 5}, {1, 2, 3, 5, 4}, {1, 2, 4, 5, 3} ... {4, 5, 2, 3, 1} *)


A simple solution based on this idea:

parts[list_, p_] := Module[{q},
InternalPartitionRagged[list[[Ordering[#]]], p] & /@ Permutations[q]]


Unforunately InternalPartitionRagged is rather slow; it is faster (though less elegant) to create a function which does the reshaping:

parts[list_, p_] := Module[{q, f, slot},
f = Function @@ {InternalPartitionRagged[Array[slot, Length@list], p]} /. slot -> Slot;
f @@@ (list[[Ordering[#]]] & /@ Permutations[q])]


This is comparable to Mr Wizard's in terms of speed.

• Nuts! Why do I always see these answers after I update my posts? Commented Aug 14, 2016 at 20:18

It's far from pretty, using pattern matching (OrderlessPatternSequence):

ReplaceList[#1,
Module[{names = Unique[] & /@ #1, partitions},
partitions = InternalPartitionRagged[names, #2];
Activate[{OrderlessPatternSequence @@ (Pattern[#, _] & /@ names)} /;
Evaluate[And @@ (Inactive@OrderedQ /@ partitions)] :>
Evaluate@partitions]]] &[Range@5, {2, 2, 1}]


The pattern we construct for the case of these arguments is:

{OrderlessPatternSequence[$3_,$4_, $5_,$6_, $7_]} /; OrderedQ[{$3, $4}] && OrderedQ[{$5, $6}] && OrderedQ[{$7}] :>
{{$3,$4}, {$5,$6}, {\$7}}

split1[s_List, p_List] :=
(Fold[#1 /. temp[b___List] :> Map[
temp[b, #] &, Subsets[Complement[s, b], {#2}]] &,
temp[], p] // Flatten) /. temp -> List


Edit: I cleaned the code slightly, as the temporary head is unnecessary.

split2[s_List, p_List] :=
Fold[#1 /. {x : {__Integer} ..} :> Sequence @@ Map[
{x, #} &, Subsets[Complement[s, x], {#2}]] &,
List /@ Subsets[s, {First@p}], Rest@p]


The code is always an order of magnitude slower than the fastest, yet it seems to share the computational complexity with them.

problem[n_] := {Range@Total@#, #} &@RandomInteger[{1, 3}, n]

timing[n_, methods__] := Module[{pr},
pr = problem[n];
Table[{n, RepeatedTiming[m @@ pr;][[1]]}, {m, {methods}}]]

data = Table[timing[n, split1, split2, parts], {n, 6}];

ListLogPlot[Transpose[data],
Joined -> True,
Mesh -> All,
PlotRange -> All,
PlotLegends -> {"BoLe 1", "BoLe 2", "Simon Woods"}]


• Now I feel like an idiot for not using Complement[], which would have made a generic version of my answer so much simpler. Commented Aug 13, 2016 at 14:59
g[l_, {n1_, n2_}] := (sb = Subsets[l, {n1}];
Flatten[
Table[{i1 = sb[[i]], i2 = Subsets[Complement[l, i1], {n2}][[j]],
Complement[l, {i1, i2}]}, {j, Length[l] - n1 - 1}, {i,
Length[sb]}], 1])
AbsoluteTiming[g[l, {2, 2}]]


0.000256

AbsoluteTiming[f[l, {2, 2, 1}]]


0.002062

• thanks, but actually the partition list is not limited to length 2 Commented Aug 13, 2016 at 12:09
• @happyfish This code works for any partition of 3, for example try AbsoluteTiming[g[Range[9], {4, 3}]] for {4,3,2} Commented Aug 13, 2016 at 12:16
• yes, I meant, partitions like {2, 3, 3, 3} Commented Aug 13, 2016 at 12:17
• @happyfish I see, well kirma 's already works for any kind, so rather than me expanding mine, you can accept his ;) Commented Aug 13, 2016 at 12:20

FoldPairList, introduced in version 10.2 (but still [[EXPERIMENTAL]]), combined with the use of Ordering and Permutations, does what you want:

FoldPairList[TakeDrop, #, {2, 2, 1}] & /@ (Ordering /@ Permutations[{1, 1, 2, 2, 3}])
`