Vertex Contraction

Author

Eric W. Weisstein
October 23, 2024

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

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

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

Figure

{g=Contract[g1=RandomGraph[10,.5],r=Table[Random[Integer,{1,10}],{2}]]}

r

Show[GraphicsArray[{
showLabeledGraph[g1,{},.15,PointSize[.04]],
showLabeledGraph[ChangeVertices[g,CircularVertices[10][[Join[Complement[Range[10],r],{r[[1]]}]]]],Join[Range[8],{"v"}],.15,PointSize[.04]]
}]]

Embeddings

<<MathWorld`Graphs`

Select[GraphData[All],MatchQ[#,s_String?(StringContainsQ["."])]&]

"K3,3.K3,3"

GraphData["K3,3.K3,3","StandardName"]

Primary

GraphData["K3,3.K3,3"]//StyleGraphs[#,ImageSize->Small]&

All

GraphData["K3,3.K3,3","Graph","All"]//StyleGraphs

Inexact

Select[GraphData["K3,3.K3,3","Graph","All"],(!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&)]//StyleGraphs

Embedding types

GraphDataEmbeddings[GraphData["K3,3.K3,3","EdgeList"]]

Construction from Mohar and Thomassen 2001

Using the numbering of Glover et al. 1979 for projective planar forbidden topological minors

Rotate[,Pi/2]

v[[1]]//FullSimplify

c={(Sqrt[(1/10) (5+(Sqrt[5]))]),0};

v=FullSimplify@Join[CirclePoints[-c,{Csc[Pi/5]/2,0},5],CirclePoints[c,{Csc[Pi/5]/2,Pi},5]];
v=DeleteDuplicates@Join[v,{-c,c}];
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[5,4,10,1,9,8,6,1,2,3,5,1,11,7,6],e[2,4],{3,10},{8,11},{9,7}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@g

v={{-3,-1},{-3/2,-1},{3/2,-1},{3,-1},{3,1},{3/2,1},{-3/2,1},{-3,1},{0,0},{3/2,0},{-3/2,0}};
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[1,2,9,7,8,11,1,7],{2,8},e[11,9,10,5,6,9,3,4,10],{4,6},{3,5}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@g

gs={,};

Construction from Glover et al. 1979

H. Glover, J. Huneke, and C. S. Wang, 103 graphs that are irreducible for the projective plane. J. Combinatorial Theory Ser. B 27 3 (1979).

v1=Flatten[Table[{i,j},{i,0,1},{j,0,2}],1];
v=DeleteDuplicates@FullSimplify@Join[v1,{1,0}+RotationMatrix[-Pi/4].#&/@v1];
g0=Graph[Range[Length[v]],Sort[Sort/@(UndirectedEdge@@@{e[4,5,6,3,2,1,4,9,10,11,8,7,4],{7,10},{2,5},
Sequence@@(curvededges={{1,6},{4,3},{4,11},{8,9}})})],VertexCoordinates->v,VertexLabels->Automatic]

{3,#}&/@curvededges

g=CurvedEdges[g0,{{3,{1,6}},{-3,{4,3}},{-3,{4,11}},{3,{8,9}}}]

RecognizeGraph[g]

{CircuitRank[g],VertexCount[g],ReverseSort@VertexDegree[g]}

ProjectivePlanarGraphQ[g,Debug->True]//Timing

g=RotateGraph[g0,Pi/8]

DegenerateGraphEmbeddingQ[g]

Default embedding

GraphPlot@GraphData["K3,3.K3,3","Edges"]

v=Delete[Flatten[Table[{i,j},{i,0,4},{j,0,2}],1],List/@{3,6,10,13}];
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[1,2,3,6,5,4,1,6,11,10,9,6,7,8,11],{3,4},{8,9},{2,5},{7,10}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

v=Delete[Flatten[Table[{i,j},{i,0,4},{j,0,2}],1],List/@{3,6,10,13}];
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[6,4,2,1,3,5,6,7,9,11,10,8,6,1],{2,5},{3,4},{8,9},{7,10},{6,11}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@g

v=DeleteDuplicates@FullSimplify@Join[CirclePoints[{-1,0},1,6],CirclePoints[{1,0},1,6]];
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[2,3,4,5,6,1,2,10,9,8,7,11,2,5],{1,4},{3,6},{11,9},{10,7},{2,8}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@g

gs={,};

g1=TranslateGraph[RotateGraph[,-Pi/2,VertexLabels->Automatic],3]

RecognizeGraph@g1

v1=GraphEmbedding[g1];
v=DeleteDuplicates@FullSimplify@Join[v1,{-#,#2}&@@@v1];
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[3,1,6,5,4,2,3,7,11,10,9,8,3],{1,4},{2,6},{7,9},{8,11},e[5,3,10]},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@g

Degenerate

GraphData["K3,3.K3,3","Graph","Degenerate"]//StyleGraphs

DegenerateGraphEmbeddingTypes/@GraphData["K3,3.K3,3","Graph","Degenerate"]

Bilateral

GraphData["K3,3.K3,3","Graph","Bilateral"]//StyleGraphs

Circular

GraphData["K3,3.K3,3","Graph","Circular"]//StyleGraphs

Planar

GraphData["K3,3.K3,3","Planar"]

GraphData["K3,3.K3,3","Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData["K3,3.K3,3",{"RCN","CN"}]

GraphData["K3,3.K3,3","Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

(cn=CrossingNumber[GraphData["K3,3.K3,3"],TimeConstraint->1])//AbsoluteTiming

Table[MinimalCrossingGraph[GraphData["K3,3.K3,3"],"CrossingNumber"->cn,RandomSeed->i],{i,50}]//Union

v={};
g=Graph[Range[Length[v]],UndirectedEdge@@@{},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData["K3,3.K3,3","Circulant"]

GraphData["K3,3.K3,3","Graph","Circulant"]//StyleGraphs

Halin

GraphData["K3,3.K3,3","Halin"]

GraphData["K3,3.K3,3","Graph","Halin"]//StyleGraphs

Rigid

GraphData["K3,3.K3,3","Rigid"]

GraphData["K3,3.K3,3","Graph","Rigid"]//StyleGraphs

Flexible

GraphData["K3,3.K3,3","Flexible"]

GraphData["K3,3.K3,3","Graph","Flexible"]//StyleGraphs

LCF

GraphData["K3,3.K3,3","LCF"]

GraphData["K3,3.K3,3","HamiltonianCycleCount"]

GraphData["K3,3.K3,3","LCFSignature"]

GraphData["K3,3.K3,3","LCFNotations"]

GraphData["K3,3.K3,3","Graph","LCF"]//StyleGraphs

UnitDistance

GraphData["K3,3.K3,3","UnitDistance"]

UnitDistanceGraphQ[GraphData["K3,3.K3,3"],Debug->True]//Timing

GraphData["K3,3.K3,3","Graph","UnitDistance"]//StyleGraphs

Matchstick

GraphData["K3,3.K3,3","Matchstick"]

GraphData["K3,3.K3,3","Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData["K3,3.K3,3","Edges"]]

3D All

GraphData["K3,3.K3,3","Graph",{"3D","All"}]

3D UnitDistance

GraphData["K3,3.K3,3","Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData["K3,3.K3,3","Polyhedral"]

GraphData["K3,3.K3,3","Graph",{"3D","Polyhedron"}]

"K5.K3,3"

GraphData["K5.K3,3","StandardName"]

Primary

GraphData["K5.K3,3"]//StyleGraphs[#,ImageSize->Small]&

All

GraphData["K5.K3,3","Graph","All"]//StyleGraphs

Inexact

Select[GraphData["K5.K3,3","Graph","All"],(!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&)]//StyleGraphs

Embedding types

GraphDataEmbeddings[GraphData["K5.K3,3","EdgeList"]]

Construction from Mohar and Thomassen 2001

Using the numbering of Glover et al. 1979 for projective planar forbidden topological minors

Rotate[,-Pi/2]

v[[1]]

v=DeleteDuplicates@FullSimplify@Join[CirclePoints[{-1,0},{1,0},5],CirclePoints[{1,0},{1,-Pi},5]];
v=Append[v,Mean[v[[{6,9}]]]];
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[1,3,5,2,4,1,2,3,4,5,1,9,8],e[7,6,1,10,8,6],e[9,7,10]},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@g

Default embedding

GraphPlot@GraphData["K5.K3,3","Edges"]

c=UnitCirclePoints[5];

v[[6]]-v[[11]]//FullSimplify

v=DeleteDuplicates[FullSimplify@Join[Flatten[Table[{i,j},{i,0,2},{j,0,1}],1],#+{(5/2),1+(Sqrt[(1/4)+(1/(2 (Sqrt[5])))])}&/@c]];
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[3,4,1,2,3,6,5,4],{2,5},e[1,6,7,8,9,10,6,8,10,7,9,6]},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

Degenerate

GraphData["K5.K3,3","Graph","Degenerate"]//StyleGraphs

DegenerateGraphEmbeddingTypes/@GraphData["K5.K3,3","Graph","Degenerate"]

Bilateral

GraphData["K5.K3,3","Graph","Bilateral"]//StyleGraphs

Circular

GraphData["K5.K3,3","Graph","Circular"]//StyleGraphs

Planar

GraphData["K5.K3,3","Planar"]

GraphData["K5.K3,3","Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData["K5.K3,3",{"RCN","CN"}]

GraphData["K5.K3,3","Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

(cn=CrossingNumber[GraphData["K5.K3,3"],TimeConstraint->1])//AbsoluteTiming

Union[Select[Table[RotateGraph[MinimalCrossingGraph[GraphData["K5.K3,3"],"CrossingNumber"->cn,RandomSeed->n]],{n,50}],Max[OuterFace[#]]<=GraphData["K5.K3,3","V"]&]]//Timing

Table[MinimalCrossingGraph[GraphData["K5.K3,3"],"CrossingNumber"->cn,RandomSeed->i],{i,50}]//Union

v={};
g=Graph[Range[Length[v]],UndirectedEdge@@@{},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData["K5.K3,3","Circulant"]

GraphData["K5.K3,3","Graph","Circulant"]//StyleGraphs

Halin

GraphData["K5.K3,3","Halin"]

GraphData["K5.K3,3","Graph","Halin"]//StyleGraphs

Rigid

GraphData["K5.K3,3","Rigid"]

GraphData["K5.K3,3","Graph","Rigid"]//StyleGraphs

Flexible

GraphData["K5.K3,3","Flexible"]

GraphData["K5.K3,3","Graph","Flexible"]//StyleGraphs

LCF

GraphData["K5.K3,3","LCF"]

GraphData["K5.K3,3","HamiltonianCycleCount"]

GraphData["K5.K3,3","LCFSignature"]

GraphData["K5.K3,3","LCFNotations"]

GraphData["K5.K3,3","Graph","LCF"]//StyleGraphs

UnitDistance

GraphData["K5.K3,3","UnitDistance"]

UnitDistanceGraphQ[GraphData["K5.K3,3"],Debug->True]//Timing

GraphData["K5.K3,3","Graph","UnitDistance"]//StyleGraphs

Matchstick

GraphData["K5.K3,3","Matchstick"]

GraphData["K5.K3,3","Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData["K5.K3,3","Edges"]]

3D All

GraphData["K5.K3,3","Graph",{"3D","All"}]

3D UnitDistance

GraphData["K5.K3,3","Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData["K5.K3,3","Polyhedral"]

GraphData["K5.K3,3","Graph",{"3D","Polyhedron"}]

"K5.K5"

Names

GraphData["K5.K5","StandardName"]

GraphData["K5.K5","StandardNames"]

Construction as join

g=GraphJoin[GraphData["2K4"],GraphData["K1"]]

RecognizeGraph@g

Construction from Mohar and Thomassen 2001

Using the numbering of Glover et al. 1979 for projective planar forbidden topological minors

Construction from Glover et al. 1979

H. Glover, J. Huneke, and C. S. Wang, 103 graphs that are irreducible for the projective plane. J. Combinatorial Theory Ser. B 27 3 (1979).

v={{0,0},{1,0},{0,-1},{1,-1},{1/2,-1/2},{-1,0},{-1/2,1/2},{-1,1},{0,1}};
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[3,4,2,1,3,5,2],e[4,5,1,7,8,9,7,6,1,9],{6,8},
{2,3},{4,1},{1,8},{6,9}},VertexCoordinates->v,VertexLabels->Automatic]

g=CurvedEdges[g,{#,3}&/@{{1,4},{1,8},{2,3},{6,9}}]

RecognizeGraph[g]

{CircuitRank[g],VertexCount[g],ReverseSort@VertexDegree[g]}

ProjectivePlanarGraphQ[g,Debug->True]//Timing

ProjectivePlanarGraphQ[g,Debug->True]//Timing

Construction as contraction

g=VertexContract[MyGraphUnion[GraphData@"K5",2],{1,6}]

RecognizeGraph@g

Primary

GraphData["K5.K5"]//StyleGraphs[#,ImageSize->Small]&

All

GraphData["K5.K5","Graph","All"]//StyleGraphs

Inexact

Select[GraphData["K5.K5","Graph","All"],(!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&)]//StyleGraphs

Embedding types

GraphDataEmbeddings[GraphData["K5.K5","EdgeList"]]

Default embedding

GraphPlot@GraphData["K5.K5","Edges"]

v={};
g=Graph[Range[Length[v]],UndirectedEdge@@@{},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

Degenerate

GraphData["K5.K5","Graph","Degenerate"]//StyleGraphs

DegenerateGraphEmbeddingTypes/@GraphData["K5.K5","Graph","Degenerate"]

Bilateral

GraphData["K5.K5","Graph","Bilateral"]//StyleGraphs

Bilateral

GraphData["K5.K5","Graph","Bilateral"]//StyleGraphs

Grid[DeleteCases[Monitor[{g=#,BilateralGraphEmbeddingTypes[#],GraphSymmetryGroup[#]}&/@GraphData["K5.K5","Graph","All"],g],{_,_,TransformationGroup[{}]}],Dividers->All,Alignment->{{Center,{Left}}}]

Circular

GraphData["K5.K5","Graph","Circular"]//StyleGraphs

Circular construction

GraphData["K5.K5","Hamiltonian"]

GraphData["K5.K5","HamiltonianCycleCount"]

Length[hc=FindHamiltonianCycle[GraphData["K5.K5"],All][[All,All,1]]]//Timing

(circ=CircularEmbeddingFromHamiltonianCycle[GraphData["K5.K5"],#]&/@hc);//Timing

sym={#,GraphSymmetryGroup[#]}&/@circ;//Timing

Tally[sym[[All,-1]]]

DeleteCases[sym,{_,TransformationGroup[{}]}]

Length[bilat=DeleteDuplicatesBy[
DeleteMissing[BilaterallyRotatedGraph/@circ],
CircularCanonicalGraphEmbedding]]//Timing

gs=bilat

Length[quad=DeleteDuplicatesBy[Union@Select[bilat,BilateralGraphEmbeddingQ[#,Axis->"X"]&],CircularCanonicalGraphEmbedding[#,4]&]]

quad

Planar

GraphData["K5.K5","Planar"]

GraphData["K5.K5","Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData["K5.K5",{"RCN","CN"}]

GraphData["K5.K5","Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

(cn=CrossingNumber[GraphData["K5.K5"],TimeConstraint->1])//AbsoluteTiming

(cn=CrossingNumber[GraphData["K5.K5"],TimeConstraint->10])//AbsoluteTiming

(cn=CrossingNumber[GraphData["K5.K5"],TimeConstraint->60])//AbsoluteTiming

(cn=CrossingNumber[GraphData["K5.K5"],TimeConstraint->3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData["K5.K5"],TimeConstraint->5 3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData["K5.K5"],TimeConstraint->86400])//AbsoluteTiming

(g=MinimalCrossingGraph[GraphData["K5.K5"],"CrossingNumber"->cn])//PolyhedralGraphQ

(gs=Union[Select[Table[RotateGraph[MinimalCrossingGraph[GraphData["K5.K5"],"CrossingNumber"->cn,RandomSeed->n]],{n,50}],Max[OuterFace[#]]<=GraphData["K5.K5","V"]&]])//Timing

Select[gs,GraphSymmetryGroup[#,AdditionalData->Join[Table[True,GraphData["K5.K5","V"]],Table[False,cn]],SameTest->Equal]=!=TransformationGroup[{}]&]

(gs=Table[MinimalCrossingGraph[GraphData["K5.K5"],"CrossingNumber"->cn,RandomSeed->i],{i,50}]//Union)//Timing

Select[gs,GraphSymmetryGroup[#,AdditionalData->Join[Table[True,GraphData["K5.K5","V"]],Table[False,cn]],SameTest->Equal]=!=TransformationGroup[{}]&]

v={};
g=Graph[Range[Length[v]],UndirectedEdge@@@{},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

RectilinearCrossingCount[g]

RectilinearLocalCrossingCount[g]

Circulant

GraphData["K5.K5","Circulant"]

GraphData["K5.K5","Graph","Circulant"]//StyleGraphs

Circulant construction

CirculantGraph1@@@CirculantIndices[GraphData["K5.K5"]]

gs=CirculantGraph1@@@Cases[GraphData["K5.K5","StandardNames"],{"Circulant",i_}:>i]

Halin

GraphData["K5.K5","Halin"]

GraphData["K5.K5","Graph","Halin"]//StyleGraphs

Rigid

GraphData["K5.K5","Rigid"]

GraphData["K5.K5","Graph","Rigid"]//StyleGraphs

Flexible

GraphData["K5.K5","Flexible"]

GraphData["K5.K5","Graph","Flexible"]//StyleGraphs

LCF

GraphData["K5.K5","LCF"]

GraphData["K5.K5","HamiltonianCycleCount"]

GraphData["K5.K5","LCFSignature"]

GraphData["K5.K5","LCFNotations"]

GraphData["K5.K5","Graph","LCF"]//StyleGraphs

Tally[LCFNotation[#][[2]]&/@%]

UnitDistance

GraphData["K5.K5","UnitDistance"]

UnitDistanceGraphQ[GraphData["K5.K5"],Debug->True]//Timing

GraphData["K5.K5","Graph","UnitDistance"]//StyleGraphs

UnitDistance by refinement

UnitDistanceEmbeddingRefine[Graph[GraphData["K5.K5","VertexList"],GraphData["K5.K5","EdgeList"]],MaxIterations->500]

UnitDistanceEmbeddingRefine[Annotate[#,VertexCoordinates->N[GraphEmbedding[#]]],MaxIterations->500]&/@Complement@@(GraphData["K5.K5","Graph",#]&/@{"All","UnitDistance"})

UnitDistance by FindUnitDistanceEmbedding

FindUnitDistanceEmbedding[GraphData["K5.K5"],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

Matchstick

GraphData["K5.K5","Matchstick"]

GraphData["K5.K5","Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData["K5.K5","Edges"]]

3D All

GraphData["K5.K5","Graph",{"3D","All"}]

3D UnitDistance

GraphData["K5.K5","Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData["K5.K5","Polyhedral"]

GraphData["K5.K5","Graph",{"3D","Polyhedron"}]