4
$\begingroup$

It might well turn out that this question has already been asked; my problem is that I don't know how to describe it succinctly enough to search.

I have a list of 12 elements. If I take 2 elements from the list at a time, how many complete (i.e., 6-pair) pair-wise partitionings of the list are there. I think that this is:

Binomial[12,2]*Binomial[10,2]*Binomial[8,2]*Binomial[6,2]*Binomial[4,2]*Binomial[2,2]

which gives 7,484,400 but since I don't care about how each choice of 6 pairs is ordered, I can reduce that number to 7,484,400 / 6! giving 10,395.

I'd like to generate those 10,395 6-pair sets. How can I do that?

$\endgroup$

3 Answers 3

5
$\begingroup$

Rather than filtering 7M+ partitions, we can directly generate the desired partitions using ReplaceList and Nest:

ClearAll[rule, twoPartitions]

rule = {a_List, x_, b___, y_, c___} :> {Join[a, {{x, y}}], b, c};

twoPartitions[list_List /; EvenQ[Length @ list]] := Map[Splice]@
  Nest[Catenate @* Map[ReplaceList[rule]], {Prepend[{}] @ list}, Length[list]/2]

twoPartitions[n_Integer?EvenQ] := twoPartitions[Range[n]]

Examples:

Length @ twoPartitions[12]
10395
Short[twoPartitions[12] , 5]

enter image description here

Timing comparisons:

First @ RepeatedTiming[res1 = twoPartitions[12]]
0.0453613
Needs["Combinatorica`"]
First @ RepeatedTiming[res2 = Cases[KSetPartitions[12, 6], p : {{_, _} ..} :> p]]
3.35389
kSP = ResourceFunction["KSetPartitions"];
First @ RepeatedTiming[res3 = Cases[kSP[12, 6], p : {{_, _} ..} :> p]]
3.44554
Equal @@ (Sort /@ {res1, res2, res3})
True

Further examples:

Row[Column @* twoPartitions /@ Range[2, 6, 2], Spacer[10]]

enter image description here

twoPartitions[CharacterRange["A", "F"]] // Column

enter image description here

$\endgroup$
4
$\begingroup$
Needs["Combinatorica`"]
t = Cases[KSetPartitions[Range[12], 6], p : {{_, _} ..} :> p]
Length@t

10395

$\endgroup$
2
  • $\begingroup$ Thank you. I can see how the KSetPartitions function is working. I'd be very grateful if you could briefly explain the parts of the pattern used in the Cases function, and the use of the :> operator there. $\endgroup$ Jul 28, 2023 at 12:03
  • $\begingroup$ {{_, _} ..} is a repeating list pattern of two element sublists. :> may not be necessary but I usually default to it instead of ->. KSetPartitions generates 6 partitions of various lengths and the list is huge, but we are only interested in six pairs of two elements each that are selected by the Cases command. $\endgroup$
    – Syed
    Jul 28, 2023 at 12:08
0
$\begingroup$

We can generalize the method in this answer to partitions with arbitrary length sub-lists.

First a function to generate replacement rules:

ClearAll[makeRule]

makeRule[m_Integer] := Module[
 {$symbols = Map[$s |-> Map[Symbol[$s <> ToString@#] &]@Range[m]]@{"$x", "$y"}},
   RuleDelayed @@ 
    {Prepend[Pattern[$a, Blank[List]]] @
       Apply[Riffle] @
       MapThread[Thread @ Pattern[#, #2[]] &] @
       {$symbols, {Blank, BlankNullSequence}}, 
     Apply[{Join[$a, {#}], ## & @@ #2} &] @ $symbols}];

Examples:

makeRule[2]
{$a_List, $x1_, $y1___, $x2_, $y2___} :>   
  {Join[$a, {{$x1, $x2}}],    $y1, $y2}
makeRule[3]
{$a_List, $x1_, $y1___, $x2_, $y2___, $x3_, $y3___} :>   
 {Join[$a,     {{$x1, $x2, $x3}}], $y1, $y2, $y3}

Use makeRule with ReplaceList + Nest to generate the desired list of partitions:

ClearAll[kPartitions]  

kPartitions[list_List, k_Integer] /; Divisible[Length @ list, k] := 
  Map[Splice] @ Nest[Catenate@*Map[ReplaceList[makeRule @ k]], 
     {Prepend[{}] @ list}, Length[list]/k]

kPartitions[n_Integer, k_Integer] /; Divisible[n, k] := kPartitions[Range[n], k]

Examples:

Length @ kPartitions[12, #] & /@ Rest[Most @ Divisors[12]]
{10395, 15400, 5775, 462}
Length @ kPartitions[15, #] & /@ Rest[Most @ Divisors[15]]
{1401400, 126126}
Length @ kPartitions[16, #] & /@ Rest[Most @ Divisors[16]]
{2027025, 2627625, 6435}
Short[kPartitions[CharacterRange["A", "Z"][[;; 12]], 2], 10]

enter image description here

Short[kPartitions[CharacterRange["A", "Z"][[;; 12]], 3], 10]

enter image description here

Short[kPartitions[CharacterRange["A", "Z"][[;; 16]], 8], 10]

enter image description here

Note/Warning: For {n, k} pairs that generate a large number of partitions you will get a kernel crash.

$\endgroup$

Your Answer

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

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