Enumerate the 1-factors (perfect matchings) of $K_n$

Question

Introduction

I would like to enumerate the 1-factors, or (near-)perfect matchings, of the complete graph K_n. The adjacency list representation for K_n is basically { (x, y) | 1 ≤ x < y ≤ n }.

For example, in the case of K₃ = {{1, 2}, {1, 3}, {2, 3}}, the near-perfect matchings would be
{{{1, 2}}, {{1, 3}}, {{2, 3}}}. For K₄ = {{1, 2}, {1, 3}, {1, 4}, {2, 3}, {2, 4}, {3, 4}}, the perfect matchings would be {{{1, 2}, {3, 4}}, {{1, 3}, {2, 4}}, {{1, 4}, {2, 3}}}.

Here's a nifty little illustration of this inspired by an example from the documentation:

The number of 1-factors of K_n is given by the odd double factorial: n!! if n is odd, and (n – 1)!! if n is even. See how this function grows (as the even double factorial) compared to n! below:

n        1       2       3       4       5       6       7       8       9      10
n!!      1       1       3       3      15      15     105     105     945     945
n!       1       2       6      24     120     720    5040   40320  362880 3628800

n!/n!!   1       2       2       8       8      48      48     384     384    3840

(For the sake of brevity, I am ignoring parity when using the n!! notation in the row headers.)

Attempt

My current solution generates the n! permutations, partitions each into pairs, and filters them.

p[n_] := Partition[#, 2] & /@ Permutations[Range[n]];
one[p_] := Select[p, OrderedQ @ # && And @@ OrderedQ /@ # &];
two[p_] := Select[p, # === Intersection@(Intersection /@ #) &];

Solution one filters the permutations by requiring each element and each of its contents be sorted.
Solution two does the same thing by exploiting the fact that order is ignored in sets.

The first solution can be a magnitude faster than the second solution:

With[{n = 9}, TableForm[Table[
   With[{ptemp = p[i]},
    tone = one@ptemp // Timing // First;
    ttwo = two@ptemp // Timing // First;
    {tone, ttwo, ttwo/tone}]
   , {i, n}], 
  TableHeadings -> {Range[n], {"one", "two", "one faster by"}}]]

    one         two         one faster by
1   0.000017    0.000011    0.6
2   0.000013    0.000019    1.
3   0.000025    0.000037    1.5
4   0.000066    0.000186    2.8
5   0.000520    0.001044    2.01
6   0.001274    0.007714    6.05
7   0.010958    0.047812    4.363
8   0.065019    0.446901    6.873
9   0.572954    3.941633    6.8795

Question

How can achieve this without doing n!! times as much work generating all the permutations?

Answer 1

New answer

I think I had an epiphany. If correct this question can be recast as Partition a set into subsets of size $k$.
Borrowing ideas from Rojo's excellent answer I wrote:

match[x : {_, _}] := {{x}}
match[{a_, b__}] :=
  Join @@ Table[{{a, x}, ##} & @@@ match[{b} ~DeleteCases~ x], {x, {b}}]

match[n_?EvenQ] := match @ Range[n]
match[n_?OddQ]  := DeleteCases[match @ Range[n + 1], {___, n + 1, ___}, {2}]

Now:

match[13] // Length // Timing
match[14] // Length // Timing

{1.154, 135135}

{0.936, 135135}

---

(See edit history for my old answer.)

Answer 2

We iteratively build up a list of matchings from K2 to Kn. Consider K6. We know that each matching has to contain exactly one of edge 1-2, 1-3, 1-4, 1-5, or 1-6, otherwise vertex 1 is excluded or it's covered more than once. So the matchings of K6 can be split into 5 independent sets, each containing matchings including one of the edges touching vertex 1. Each of the matchings in those sets contains the edge incident to vertex 1 plus the matchings of a K4 subgraph. For example, the first set contains all of the K4 matchings for the subraph with vertices 3, 4, 5, and 6 with edge 1-2 added to each of those matchings. So we just use the matchings for Kn to construct the matchings for K(n+2).

For odd n, we just consider n+1 and delete the edges that contain the extra vertex. The Outer command generates all of the matchings for the K(n-2) subgraphs of Kn using the matchings just computed for K(n-2). The MapIndexed and Prepend then add edge 1-2, 1-3, 1-4, etc to the matchings for the subgraphs.

perfectMatchingsOfComplete[n_?EvenQ] := 
 Nest[Flatten[
      MapIndexed[Prepend[#, {1, First@#2 + 1}] &, 
       Outer[#[[#2]] &, Reverse@Subsets[Range[2, #2], {#2 - 2}], #, 1,
         2], {2}], 1] &[#, 
    2 Length@First@# + 2] &, {{{1, 2}}}, (n - 2)/2]

perfectMatchingsOfComplete[n_?OddQ] := 
 Select[#, ! MemberQ[#, n + 1] &] & /@ 
  perfectMatchingsOfComplete[n + 1]

Result lengths:

Length@perfectMatchingsOfComplete@# & /@ Range@14    
{1, 1, 3, 3, 15, 15, 105, 105, 945, 945, 10395, 10395, \
135135, 135135}

~20 seconds for n=16:

perfectMatchingsOfComplete@16 // Timing // First
19.734

Answer 3

I believe this now also works for odd n.

three[n_] :=
 Block[
  {m = Quotient[n, 2], firstsSeconds, firstsPermuted, dupePairs, 
   sortPairs, range, strange}
  ,
  range = Range[n];
  strange = If[EvenQ[n], range, Range[0, m]];
  firstsSeconds = {If[EvenQ@n, #, #~Append~0] &@#, 
      Complement[range, #]} & /@ Subsets[range, {m}]; ;
  firstsPermuted =
   Function[{firsts, seconds}, {#, seconds} & /@ 
      Permutations[firsts]] @@@ firstsSeconds; ;
  dupePairs = Transpose /@ Flatten[firstsPermuted, 1]; ;
  sortPairs = Map[Sort, #, {1, 2}] &;
  Sort[
   If[OddQ[n], #[[All, 2 ;;]], #] &@
    DeleteDuplicates[sortPairs@dupePairs]
   ]
  ]

We have

n = 10;
(a = three[n]) //Timing//First
(b = one[p[n]])//Timing//First
a === b

7.042475
0.108956
True

and

three[5] == one[p[5]]

True

There are still issues with the code though. First and foremost it is O((n/2)!), which should not be necessary.