# Generating all complete pair-wise listing of a starting list

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?

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]


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


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


Needs["Combinatorica"]
t = Cases[KSetPartitions[Range[12], 6], p : {{_, _} ..} :> p]
Length@t


10395

• 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. Jul 28, 2023 at 12:03
• {{_, _} ..} 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.
– Syed
Jul 28, 2023 at 12:08

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]


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


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


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