Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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?

share|improve this question
    
I added an answer; please tell me if my understanding is correct. –  Mr.Wizard Mar 17 at 11:57
    
@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`. –  hftf Mar 17 at 12:18
    
@hftf wups, sorry about that :) –  Jacob Akkerboom Mar 17 at 12:19

3 Answers 3

up vote 3 down vote accepted

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

share|improve this answer
    
Hi @Jacob :-) -- okay, I guess I didn't understand after all. –  Mr.Wizard Mar 17 at 12:01
    
Hm, I also kept misinterpreting the question for a long while (in chat) (missing the symmetry). Oh well :) –  Jacob Akkerboom Mar 17 at 12:04
    
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.) –  hftf Mar 17 at 12:16
    
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! –  hftf Mar 17 at 13:02
    
@hftf Please see my updated answer. –  Mr.Wizard Mar 17 at 15:08

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
share|improve this answer
2  
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. –  hftf Mar 17 at 14:00
2  
After a rewrite, it's clearer and 2x faster, so I'll add the explanation to the updated answer. –  Michael Hale Mar 17 at 16:48

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.

share|improve this answer
    
Also in this answer it is silly to permute the firsts rather than the seconds, because that will probably require more sorting afterwards. –  Jacob Akkerboom Mar 17 at 12:06
    
This appears to be really fast, but as you say it only works for even numbers. –  Mr.Wizard Mar 17 at 12:26
    
@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 –  Jacob Akkerboom Mar 17 at 12:27
    
@Mr.Wizard (I think) I made it work for odd n by paring one "vertex"/number with 0, and then removing the 0's. –  Jacob Akkerboom Mar 17 at 13:05

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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