# Find all the ways to split a list into sets of lists of given length

NOTE

I'm sorry, my question was not clear. I want to know all the ways to split a list with a given length simply, rather than split a cyclic substitution. If a given list has length $$N$$ and the rule is $${m, n, p, ...}$$, we should get a list of length $${}_{N} C_{m} {}_{N-m} C_{n} {}_{N-m-n} C_{p} \dots = \frac{N!}{m! n! p! \cdots}$$ if all elements of $$N$$ are independent.

Other examples: Length@partitionList[{a, b, c, d, e, f, g, h}, {2, 2, 4}] returns $$420 = \frac{8!}{2! 2! 4!}$$

Length@partitionList[{a, b, b, c, d, e, e, f}, {2, 2, 4}] returns 173

Question

I want to split a given list into sets of lists, whose lengths are given. For example, this means if we split a list {a, b, c, d} (length 4) to two lists with length {1, 3} (the sum of lengths should be 4), we obtain

{{{a}, {b, c, d}}, {{b}, {c, d, a}}, {{c}, {d, e, a}}, {{d}, {e, a, b}}


(here, we don't care about ordering for elements in each sublist).

To achieve this, I prepared the following function:

partitionList[l_List, p_List] :=
DeleteDuplicates@(Module[{$tmp,$deleteList, $lastchoose, l2 = Range[Length@l]},$tmp = Subsets[l2, {p[]}];
$deleteList = Flatten /@$tmp;
If[Length@p > 1,
Do[
$lastchoose = Table[Subsets[ Delete[l2, {#} & /@$deleteList[[$j]]], {p[[$i]]}], {$j, Length@$deleteList}];
$tmp = Replace[Flatten[ Tuples /@ Transpose[{{#} & /@$tmp, $lastchoose}], 1], x_ /; Depth@x > 2 :> Sequence @@ x, {2} ];$deleteList = Flatten /@ $tmp; , {$i, 2, Length@p}]
];
Map[l[[#]] &, $tmp, {2}] ] )  Here, the argument $$l$$ is a list which we want to split, and $$p$$ is a list of lengths of sublists. In the previous example, $$l$$ is {a, b, c, d} and $$p$$ is {1, 3}. However, since it is based on procedural programming, I believe there are more efficient ways. Could you please suggest such a method? • Try: Select[Subsets[ Subsets[{a, b, c, d}]], (! MemberQ[#, {}] && Length[Flatten@#] == 4) &] Mar 3, 2022 at 17:41 • Perhaps 263461 has a few pointers. Also please take a look at an answer I just wrote. – Syed Mar 3, 2022 at 17:49 • @DanielHuber Thank you! but based on your method we have to pick some lists which satisfy the given condition.. Mar 3, 2022 at 17:52 • does the input list have duplicates? – kglr Mar 3, 2022 at 17:54 • @kglr It may do. Mar 3, 2022 at 17:55 ## 3 Answers kSP = ResourceFunction["KSetPartitions"]; partitionLst[a_, p_] := Select[Sort@Map[Length] @ # == Sort @ p &][ DeleteDuplicates @ Sort @ kSP[a, Length @ p]] partitionLst[{a, b, c, d}, {1, 3}]  {{{a}, {b, c, d}}, {{a, b, c}, {d}}, {{a, b, d}, {c}}, {{a, c, d}, {b}}}  partitionLst[{a, b, c, d}, {2, 2}]  {{{a, b}, {c, d}}, {{a, c}, {b, d}}, {{a, d}, {b, c}}}  • It will have duplicates. Mar 3, 2022 at 17:52 • Thank you @ShinKim; good point. – kglr Mar 3, 2022 at 17:56 • My function partitionList and your suggestion partitionLst do actually different results, for example Length@partitionList[{a, b, c, d, e, f}, {1, 2, 3}] $\neq$Length@partitionLst[{a, b, c, d, e, f}, {1, 2, 3}]. Mar 3, 2022 at 17:58 • @kglr I am now imagining that we could combine your Split[] method in your other question just now with Permutation[]. Mar 3, 2022 at 18:00 • @Keyspire That formula doesn't work if$p\$ has a repeating index. For example {a,b,c,d} having {1,1,1,1} (formula gives 24 but should be 1) or {1,1,2} (gives 12, but should be 6) or {2,2} (gives 6 but there are only 3). Mar 4, 2022 at 6:49
TakeDrop[#,1]&/@NestList[RotateLeft, {a,b,c,d},3]

(* {{{a}, {b, c, d}}, {{b}, {c, d, a}}, {{c}, {d, a, b}},
{{d}, {a, b, c}}} *)


And

TakeDrop[#,2]&/@NestList[RotateLeft, {a,b,c,d},3]

( {{{a, b}, {c, d}}, {{b, c}, {d, a}}, {{c, d}, {a, b}},
{{d, a}, {b, c}}} *)


This isn't any faster than the original code, just a different approach.

partitionList2[list_, pat_] := Module[{rn, p},
rn = Range@Length@pat;
DeleteDuplicates@
Table[Flatten /@ Reap[MapThread[Sow, {list, q}], rn][], {q, Permutations[p]}]]

AbsoluteTiming[
a = partitionList[Range, {3, 1, 4, 2, 2}];]
(* {27.6628, Null} *)

AbsoluteTiming[
b = partitionList2[Range, {3, 1, 4, 2, 2}];]
(* {27.5801, Null} *)

Sort[a] == Sort[b]
(* True *)