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

Question

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[[1]]}];
   $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?

Answer 1

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}}}

Answer 2

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}}} *)

Answer 3

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

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

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

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

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