6
$\begingroup$

I'm trying to find all perfect matchings for some bipartite graphs. For example

    Graph[{1, 2, 4, 6, 3, 8, 5, 7}, {1 <-> 2, 1 <-> 4, 1 <-> 6, 3 <-> 4, 
    3 <-> 6, 3 <-> 8, 5 <-> 6, 5 <-> 8, 5 <-> 2, 7 <-> 8, 7 <-> 2, 
    7 <-> 4}]

Now I can use 

    FindIndependentEdgeSet[%]

which indeed gives me a perfect matching, but it does not give me all. Is there a way to easily find all perfect matchings?

Improve this question
$\endgroup$
1
  • 1
    $\begingroup$ Counting perfect matchings of a bipartite graph is equivalent to computing the permanent of a 01-matrix, which is #P-complete (thus there is no easy way in this sense). $\endgroup$
    – Juho
    Mar 16, 2015 at 13:23

3 Answers 3

Reset to default
6
$\begingroup$

A quick way to program this is through finding all maximum independent vertex sets of the line graph:

lg = LineGraph[g];
EdgeList[g][[#]] & /@ 
 FindIndependentVertexSet[lg, Length /@ FindIndependentVertexSet[lg], All]

HighlightGraph[g, #] & /@ %

enter image description here

Improve this answer
$\endgroup$
3
  • $\begingroup$ What if you want to include the non-perfect ones as well? You can take subsets? $\endgroup$
    – apg
    Feb 14, 2019 at 14:51
  • $\begingroup$ I used Flatten[Subsets[#] & /@ edges, 1] where edges=EdgeList[g][[#]] & /@ FindIndependentVertexSet[lg, Length /@ FindIndependentVertexSet[lg], All], then HighlightGraph[g,%] $\endgroup$
    – apg
    Feb 14, 2019 at 15:04
  • $\begingroup$ This only works if there are perfect matchings to begin with ... otherwise, the program suggested will only give maximum matchings, which may not be perfect ... am I correct? There is a function that finds a maximum matching in a graph in IGraph, it would be nice if it could be asked to find any given number of them, or All (which may be unfeasible if there is too many of them ... the number of them grows very quickly ... $\endgroup$
    – EGME
    Nov 18, 2019 at 19:11
5
$\begingroup$

I've implemented the algorithm given in the paper

Algorithms for Enumerating All Perfect, Maximum and Maximal Matchings in Bipartite Graphs.

This algorithm takes as input a directed bipartite graph and should give a list of all perfect matchings as output. 

EnumPerfectMatchings[G_] := 
 EnumPerfectMatchingsIter[G, FindIndependentEdgeSet[G]]

EnumPerfectMatchingsIter[G_, M_] := If[
  Length[EdgeList[G]] == 0,
  {M},
  Module[{DGM, DM, DG, NewM, c, e, Gp, Gm, p},
   DM = M;
   DG = DirectedEdge @@@ 
     Reverse /@ List @@@ Complement[EdgeList[G], M];
   DGM = Graph[VertexList[G], Join[DM, DG]];
   c = FindCycle[DGM];
   If[Length[c] != 0, c = Flatten[c], Return[{M}]];
   c = Transpose@Partition[c, 2];
   If[MemberQ[DG, c[[1, 1]]], c = Reverse[c]];
   c = {c[[1]], DirectedEdge @@@ Reverse /@ List @@@ c[[2]]};
   NewM = Join[Complement[M, c[[1]]], c[[2]]];
   e = c[[1, 1]];
   p = List @@ e;
   Gp = Graph[Complement[VertexList[G], p], 
     Select[EdgeList[G], Intersection[List @@ #, p] == {} &]];
   Gm = Graph[VertexList[G], Complement[EdgeList[G], {e}]];
   Join[EnumPerfectMatchingsIter[Gm, NewM], 
    Map[Append[#, e] &, 
     EnumPerfectMatchingsIter[Gp, Complement[M, {e}]]]]
   ]
  ]

For the graph given in the question it returns the correct result 0.007 sec on my machine.

Improve this answer
$\endgroup$
2
  • $\begingroup$ Trying to run this in M11.3 will blow up my session irreparably $\endgroup$
    – Szabolcs
    Dec 4, 2018 at 17:37
  • $\begingroup$ @Szabolcs Yes, it does the same for me now too. I seem to remember it working quite well at the time. I do not think it will be very useful to find out what has changed in the meantime, since your posted answer is much more concise anyway. $\endgroup$
    – Pjotr5
    Dec 4, 2018 at 17:41
3
$\begingroup$

You can do this with the following code:

points = {1, 2, 4, 6, 3, 8, 5, 7};
edges = {1 <-> 2, 1 <-> 4, 1 <-> 6, 3 <-> 4, 3 <-> 6, 3 <-> 8, 
          5 <-> 6, 5 <-> 8, 5 <-> 2, 7 <-> 8, 7 <-> 2, 7 <-> 4};

tmp=Table[FindIndependentEdgeSet[Graph[i, edges]], {i,Permutations[points]}]// DeleteDuplicates;
tmp=tmp/.UndirectedEdge[x_, y_] /; x > y :> UndirectedEdge[y, x];
Table[Sort[i, #1[[1]] < #2[[1]] &], {i, tmp}] // DeleteDuplicates

which will try all vertex permutations, whose order in turn is used by FindIndependentEdgeSet to produce its result.

{{1 <-> 2, 3 <-> 6, 4 <-> 7, 5 <-> 8}, {1 <-> 2, 3 <-> 4, 5 <-> 6, 
  7 <-> 8}, {1 <-> 2, 3 <-> 8, 4 <-> 7, 5 <-> 6}, {1 <-> 4, 2 <-> 5, 
  3 <-> 6, 7 <-> 8}, {1 <-> 4, 2 <-> 7, 3 <-> 6, 5 <-> 8}, {1 <-> 4, 
  2 <-> 7, 3 <-> 8, 5 <-> 6}, {1 <-> 6, 2 <-> 5, 3 <-> 4, 
  7 <-> 8}, {1 <-> 6, 2 <-> 7, 3 <-> 4, 5 <-> 8}, {1 <-> 6, 2 <-> 5, 
  3 <-> 8, 4 <-> 7}}
Improve this answer
$\endgroup$
2
  • $\begingroup$ @Pjotr5: Did my answer work out for you? $\endgroup$
    – Jinxed
    Mar 21, 2015 at 16:20
  • 1
    $\begingroup$ Thank you for your answer. I'm sorry I took so long to respond. Your code was helpful and I did use it on that day, but because it has to calculate all vertex permutations it is really only usable for relatively small graphs. I've implemented another algorithm which I found online. This algorithm goes about it in a slightly more efficient way. I've posted the code as an answer to the question. $\endgroup$
    – Pjotr5
    May 8, 2015 at 8:01

Your Answer

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

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