5
$\begingroup$

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?

$\endgroup$
6
  • $\begingroup$ Try: Select[Subsets[ Subsets[{a, b, c, d}]], (! MemberQ[#, {}] && Length[Flatten@#] == 4) &] $\endgroup$ Mar 3, 2022 at 17:41
  • 1
    $\begingroup$ Perhaps 263461 has a few pointers. Also please take a look at an answer I just wrote. $\endgroup$
    – Syed
    Mar 3, 2022 at 17:49
  • $\begingroup$ @DanielHuber Thank you! but based on your method we have to pick some lists which satisfy the given condition.. $\endgroup$
    – Keyspire
    Mar 3, 2022 at 17:52
  • $\begingroup$ does the input list have duplicates? $\endgroup$
    – kglr
    Mar 3, 2022 at 17:54
  • $\begingroup$ @kglr It may do. $\endgroup$
    – Keyspire
    Mar 3, 2022 at 17:55

3 Answers 3

4
$\begingroup$
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}}}
$\endgroup$
8
  • $\begingroup$ It will have duplicates. $\endgroup$
    – Shin Kim
    Mar 3, 2022 at 17:52
  • $\begingroup$ Thank you @ShinKim; good point. $\endgroup$
    – kglr
    Mar 3, 2022 at 17:56
  • $\begingroup$ 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}]. $\endgroup$
    – Keyspire
    Mar 3, 2022 at 17:58
  • $\begingroup$ @kglr I am now imagining that we could combine your Split[] method in your other question just now with Permutation[]. $\endgroup$
    – Keyspire
    Mar 3, 2022 at 18:00
  • 1
    $\begingroup$ @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). $\endgroup$
    – Shin Kim
    Mar 4, 2022 at 6:49
2
$\begingroup$
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}}} *)
$\endgroup$
2
$\begingroup$

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 *)
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.