Perfect Matching

Author

Eric W. Weisstein
May 29, 2017

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/PerfectMatching.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/PerfectMatching.html.

©2017 Wolfram Research, Inc. except for portions noted otherwise

Counts

Simple

A218462

Do[Print[{n,Total[Boole[PerfectMatchingGraphQ/@Graphs[n]]]//Timing}]//Timing,{n,10}]

Total[Boole[Get[#]]]&/@FileNames["*.m",FileNameJoin[{$GraphDataDirectory,"Nodes","PerfectMatching"}]]

Table[Count[Graphs[n],_?PerfectMatchingGraphQ],{n,8}]//Timing

%[[2;;All;;2]]

Length/@Table[GraphData["PerfectMatching",n],{n,2,7,2}]

Connected

A218463

Table[Count[ConnectedGraphs[n],_?PerfectMatchingQ],{n,8}]//Timing

Do[Print[{n,Total[Boole[PerfectMatchingGraphQ/@ConnectedGraphs[n]]]//Timing}]//Timing,{n,10}]

Table[Total[Boole[Get[FileNameJoin[{$GraphDataDirectory,"Nodes","PerfectMatching","PerfectMatching_"<>If[n<10,"0",""]<>ToString[n]<>".m"}]][[ConnectedGraphIndices[n]]]]],{n,10}]

%[[2;;All;;2]]

Length/@Table[GraphData[{"Connected","PerfectMatching"},n],{n,2,7,2}]

Disconnected

A287652

Table[Total[Boole[Get["PerfectMatching_"<>If[n<10,"0",""]<>ToString[n]<>".m"][[DisconnectedGraphIndices[n]]]]],{n,10}]

%[[2;;All;;2]]

Length/@Table[GraphData[{"Disconnected","PerfectMatching"},n],{n,2,7,2}]

Euler Transform

EulerTransform[{0,1,0,6,0,101,0,10413}]

InverseEulerTransform[{0,1,0,5,0,95,0,10297}]

Example

m=AllMaximumIndependentEdgeSets[GraphData["Q3"]]

SetProperty[GraphData["Q3"],EdgeLabels->MapIndexed[#->#2[[1]]&,EdgeList[GraphData["Q3"]]]]

Select[m,PerfectMatchingQ[GraphData["Q3"],#]&]

GraphicsGrid[Partition[HighlightGraph[SetProperty[GraphData["Q3"],{System`VertexStyle->Red,System`EdgeStyle->Black,VertexSize->Scaled[.07]}],Style[GraphData["Q3","EdgeSet"][[#]],Directive[Red,Thick]]]&/@m,5,5,{1,1},{}],ImageSize->400]

"NoPerfectMatching" Graph

Show[GraphData["NoPerfectMatchingGraph"],PlotRangePadding->0,ImageSize->200]

V[NoPerfectMatchingGraph]

g=GraphData["NoPerfectMatchingGraph","Graph","Labeled"]

GraphData[gn="HouseXGraph","Graph","All"]

GraphData[gn,"Embeddings"]//FullForm

Sqrt[3]/2.

l={{gn,{0,emb=GraphData[gn,"Embeddings"]/.{.866->Sqrt[3]/2,-.866->-Sqrt[3]/2,.5->1/2,-.5->-1/2,0.->0,1.->1}}}}

PropertyReplace[l,"Embeddings"]

RenameGraphFiles[]

House embedding

e={-1/2+#[[1]],2+((Sqrt[3])/2)-#[[2]]}&/@emb[[1]]

el=EdgeList@Subgraph[GraphData[gn],Range[5]]

gnew=EdgeAdd[System`Graph[Range[16],Join@@Table[el/.n_Integer:>n+5 i,{i,0,2}],VertexCoordinates->FullSimplify@Append[Join@@Table[RotationMatrix[2π i/3].#&/@e,{i,0,2}],{0,0}],VertexLabels->"Name"],UndirectedEdge@@@Table[{16,i},{i,{2,7,12}}]]

g=RecognizeGraph[gnew]

GraphEmbedding[gnew]

Tetrahedron embedding

e={#[[1]],2+#[[2]]}&/@emb[[2]]

gnew2=EdgeAdd[System`Graph[Range[16],Join@@Table[el/.n_Integer:>n+5 i,{i,0,2}],VertexCoordinates->FullSimplify@Append[Join@@Table[RotationMatrix[2π i/3].#&/@e,{i,0,2}],{0,0}],VertexLabels->"Name"],UndirectedEdge@@@Table[{16,i},{i,{2,7,12}}]]

RecognizeGraph[gnew2]

GraphEmbedding[gnew2]

Replace

l={{g,{0,ToCommonEdges[#,GraphData[g]]&/@{gnew,gnew2}}}}

PropertyReplace[l,"Embeddings","11.3"]

RenameGraphFiles[]

GraphData[g,"EmbeddingClasses"]

l={{g,{0,{{"Primary"},{"MinimalCrossing","MinimalRectilinearCrossing","Planar"}}}}};

PropertyReplace[l,"EmbeddingClasses","11.3"]

RenameGraphFiles[]

Petersen’s Theorem

Every cubic graph with 0, 1, or 2 bridges has a perfect matching.

Select[GraphData["Cubic"],GraphData[#,"PerfectMatching"]===False&&Length[GraphData[#,"Bridges"]]<3&]

Select[GraphData["Cubic"],GraphData[#,"PerfectMatching"]===False&&Length[GraphData[#,"Bridges"]]==3&]

Show[GraphData[{"Cubic",{16,14}},"Image"],ImageSize->300]

Select[GraphData["Cubic"],GraphData[#,"PerfectMatching"]===False&&Length[GraphData[#,"Bridges"]]>2&]

Old Inefficient Algorithm

PerfectMatchingQ1[g_] := Module[{n = V[g]},
  If[OddQ[n],
    False,
  (* Else *)
    Not[(Count[Length /@ ConnectedComponents[DeleteVertices[g, #]], _?OddQ] > Length[#]) & /@ Or @@ Subsets[Range[n]]]]
]

GraphData[;;6]

GraphData["PerfectMatching",;;6]

Select[GraphData[;;6],PerfectMatchingQ[Graph[#]]=!=(Length[MaximalMatching[Graph[#]]]==GraphData[#,"V"]/2)&]

GraphData[{6,51}]

ToMatchingGeneratingPolynomial[p_,x_]:=Module[{n=Exponent[p,x]},
Expand[(-I)^n x^(n/2)Function[x,p][I/Sqrt[x]]]]

ToMatchingPolynomial[p_,x_]:=Module[{n=Exponent[p,x]},
Expand[ x^(2n) Function[x,p][-x^-2]]]

ToMatchingGeneratingPolynomial[GraphData[{6,51},"MatchingPolynomial"][x],x]

GraphData["EGraph","MatchingPolynomial"][x]//Expand

ToMatchingGeneratingPolynomial[GraphData["EGraph","MatchingPolynomial"][x],x]

GraphData["BannerGraph"]

GraphData["BannerGraph","MatchingPolynomial"][x]//Expand

ToMatchingGeneratingPolynomial[GraphData["BannerGraph","MatchingPolynomial"][x],x]

AGraph

GraphData[6]

MaximalMatching[Graph[{6,51}]]

PerfectMatchingQ[Graph[{6,51}]]

Select[GraphData[;;5],PerfectMatchingQ[Graph[#]]=!=PerfectMatchingQ1[Graph[#]]&]

Select[GraphData[;;6],PerfectMatchingQ[Graph[#]]=!=PerfectMatchingQ2[Graph[#]]&]

Select[GraphData[;;6],GraphData[#,"PerfectMatching"]=!=PerfectMatchingQ2[Graph[#]]&]

PerfectMatchingQ[Graph["NoPerfectMatchingGraph"]]

{#,GraphData[#,"PerfectMatching"],PerfectMatchingQ[Graph[#]],PerfectMatchingQ2[Graph[#]]}&/@GraphData[;;5]//Column

Select[GraphData["PerfectMatching"],PGraph[

ShowLabeledGraph[Graph["PawGraph"]]

MaximalMatching[Graph[{"Path",3}]]

MaximalMatching[Graph["PawGraph"]]

MaximalMatching[Graph["SquareGraph"]]

MaximalMatching[Graph["TetrahedralGraph"]]

....

PerfectMatchingQ2[Graph["ButterflyGraph"]]

PerfectMatchingQ2[Graph["PawGraph"]]