7
$\begingroup$

Introduction

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

For example, in the case of K3 = {{1, 2}, {1, 3}, {2, 3}}, the near-perfect matchings would be
{{{1, 2}}, {{1, 3}}, {{2, 3}}}. For K4 = {{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:

Nifty

The number of 1-factors of Kn 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?

$\endgroup$
3
  • $\begingroup$ I added an answer; please tell me if my understanding is correct. $\endgroup$
    – Mr.Wizard
    Mar 17, 2014 at 11:57
  • $\begingroup$ @JacobAkkerboom: Yes, you warned me about that in chat a little while ago. I did change Permutations[n] to Permutations[Range[n]], which I believe does not require Combinatorica`. $\endgroup$
    – hftf
    Mar 17, 2014 at 12:18
  • $\begingroup$ @hftf wups, sorry about that :) $\endgroup$ Mar 17, 2014 at 12:19

3 Answers 3

3
$\begingroup$

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.)

$\endgroup$
9
  • $\begingroup$ Hi @Jacob :-) -- okay, I guess I didn't understand after all. $\endgroup$
    – Mr.Wizard
    Mar 17, 2014 at 12:01
  • $\begingroup$ Hm, I also kept misinterpreting the question for a long while (in chat) (missing the symmetry). Oh well :) $\endgroup$ Mar 17, 2014 at 12:04
  • $\begingroup$ Hi @Mr.Wizard: Your solution returns {} for n < 4, and for n ≥ 4 only matches up the first two pairs of elements (vertices) instead of all floor(n/2) pairs. (Of course, for n = 4 or 5, there are two pairs in each 1-factor, so that part is right.) $\endgroup$
    – hftf
    Mar 17, 2014 at 12:16
  • $\begingroup$ I see how your "smarter brute force" works. Instead of considering $n!$ permutations, you considered only ${n\choose2}\choose{\lfloor n/2 \rfloor}$ subsets of subsets. Too bad it still takes the same 3 seconds for $f(10)$, though! $\endgroup$
    – hftf
    Mar 17, 2014 at 13:02
  • $\begingroup$ @hftf Please see my updated answer. $\endgroup$
    – Mr.Wizard
    Mar 17, 2014 at 15:08
3
$\begingroup$

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
$\endgroup$
2
  • 2
    $\begingroup$ Would you be kind enough to explain how this works? The functions are so deeply nested I'm having a hard time trying to pick out each layer and understand it. $\endgroup$
    – hftf
    Mar 17, 2014 at 14:00
  • 2
    $\begingroup$ After a rewrite, it's clearer and 2x faster, so I'll add the explanation to the updated answer. $\endgroup$ Mar 17, 2014 at 16:48
1
$\begingroup$

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.

$\endgroup$
4
  • $\begingroup$ Also in this answer it is silly to permute the firsts rather than the seconds, because that will probably require more sorting afterwards. $\endgroup$ Mar 17, 2014 at 12:06
  • $\begingroup$ This appears to be really fast, but as you say it only works for even numbers. $\endgroup$
    – Mr.Wizard
    Mar 17, 2014 at 12:26
  • $\begingroup$ @Mr.Wizard maybe I should just fix that and not be too perfectionistic. There is another Q&A on this site where I got so perfectionistic I ended up never even answering :P $\endgroup$ Mar 17, 2014 at 12:27
  • $\begingroup$ @Mr.Wizard (I think) I made it work for odd n by paring one "vertex"/number with 0, and then removing the 0's. $\endgroup$ Mar 17, 2014 at 13:05

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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