Loupekine Snarks

Author

Eric W. Weisstein
June 19, 2023

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

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

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

Graphic

snarks=GraphData["Loupekine*"]

GraphicsRow[Show[GraphData[#]//StyleGraphs,PlotLabel->Style[GraphData[#,"Name"],Directive[Black,Italic,FontFamily->"Times"]]]&/@snarks,ImageSize->500,Dividers->All]

GraphData[#,{"VertexCount","EdgeCount"}]&/@snarks

Embeddings

<<MathWorld`Graphs`

"LoupekineSnark1"

Names

GraphData["LoupekineSnark1","StandardName"]

GraphData["LoupekineSnark1","StandardNames"]

Primary

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

All

GraphData["LoupekineSnark1","Graph","All"]//StyleGraphs

Construction from Read and Wilson

p. 281

Inexact:

g=Graph[Range[22],UndirectedEdge@@@{{1,2},{1,3},{1,10},{2,4},{2,21},{3,6},{3,7},{4,5},{4,7},{5,6},{5,8},{6,17},{7,11},{8,13},{8,15},{9,10},{9,12},{9,15},{10,14},{11,12},{11,16},{12,13},{13,14},{14,22},{15,18},{16,19},{16,20},{17,18},{17,20},{18,19},{19,21},{20,22},{21,22}},VertexCoordinates->(10^(-4)){{6493,-15743},{7956,-18277},{9026,-14279},{10489,-16814},{10984,-12105},{13350,-16205},{13656,-13295},{13823,-7186},{14727,-4403},{14727,-1476},{16189,-11832},{16189,-8906},{17652,-4403},{17652,-1476},{18556,-7186},{18722,-13295},{19028,-16205},{21395,-12105},{21889,-16814},{23352,-14279},{24423,-18277},{25885,-15743}}]

RecognizeGraph@g

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData["LoupekineSnark1","EdgeList"]]

Default embedding

GraphPlot[GraphData["LoupekineSnark1","Edges"],GraphLayout->"HighDimensionalEmbedding",VertexLabels->None]

EuclideanDistance@@v[[{2,5}]]//FullSimplify

EuclideanDistance@@v[[{3,4}]]//FullSimplify

EuclideanDistance@@v[[{5,9}]]//FullSimplify

Solve[EuclideanDistance@@v[[{5,9}]]==(1/2) (1+(Sqrt[5]))]//FullSimplify

v1=Join[CirclePoints[{1/(NumericalApproximation[Root, (RowDefault["1.18", FEExpressionsNumericalApproximationElider]), Root[5-5 ((#1)^2)+((#1)^4)&,3], ]),-Pi/2},5]];
v1=Join[v1,{v1[[4]]+{0,1},v1[[3]]+{0,1}}];
v1=(#+{0,(1/2) (Sqrt[5+(7/(Sqrt[5]))+(Sqrt[6+(6/(Sqrt[5]))])])})&/@v1;
v=Join[Flatten[Table[RotationMatrix[2Pi i/3].#&/@v1,{i,0,2}],1],{{0,0}}];
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[13,21,20,7,6,14,13,11,8,10,14],e[21,17,15,18,20],e[6,4,1,3,7],e[11,9,12,10],e[18,16,19,17],e[4,2,5,3],e[8,22,15],{1,22},{9,5},{2,19},{12,16}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

Degenerate

GraphData["LoupekineSnark1","Graph","Degenerate"]//StyleGraphs

DegenerateGraphEmbeddingTypes/@GraphData["LoupekineSnark1","Graph","Degenerate"]

Bilateral

GraphData["LoupekineSnark1","Graph","Bilateral"]//StyleGraphs

Circular

GraphData["LoupekineSnark1","Graph","Circular"]//StyleGraphs

Circular construction

Length[hc=FindHamiltonianCycle[GraphData["LoupekineSnark1"],All][[All,All,1]]]

Radial construction

Collier and Schmeichel (1978)

g=Graph[Range[22],
UndirectedEdge@@@Join[Partition[Range[2,22],2,1,1],{{1,2},{1,17},{1,8},{21,4},{19,6},{20,16},{15,10},{18,14},{11,7},{9,5},{12,22},{13,3}}],VertexCoordinates->Join[{{0,0}},CirclePoints[{1,Pi/2},21]]]

RecognizeGraph@g

Planar

GraphData["LoupekineSnark1","Planar"]

GraphData["LoupekineSnark1","Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData["LoupekineSnark1",{"RCN","CN"}]

GraphData["LoupekineSnark1","Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

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

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

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

faces=ReverseSort@SymmetricallyDistinctFaces[g]

Tally[ReverseSort[Length/@faces]]

IGLayoutTutte[g,"OuterFace"->#]&/@faces

GraphPlot@

v={{0,0},{6,0},{1,1},{2,1},{4,1},{5,1},{1,2},{2,2},{3,2},{4,2},{5,2},{1,3},{3,3},{5,3},{1,4},{5,4},{1,5},{2,5},{4,5},{5,5},{0,6},{6,6}}/6;
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[1,2,16,14,11,22,21,7,12,15,1,3,4,5,6,11],{3,7},e[15,17,18,19,20,16],{20,22},{17,21},{2,6},e[12,13,14],e[4,8,19],e[5,10,18],e[8,9,10],{9,13}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

RectilinearCrossingCount[g]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Union[Select[Table[RotateGraph[MinimalCrossingGraph[GraphData["LoupekineSnark1"],"CrossingNumber"->cn,RandomSeed->n]],{n,500}],Max[OuterFace[#]]<=GraphData["LoupekineSnark1","V"]&]]//Timing

Table[MinimalCrossingGraph[GraphData["LoupekineSnark1"],"CrossingNumber"->cn,RandomSeed->i],{i,500}]//Union

GraphPlot@RotateGraph[,Pi/6]

v[[6]]

v=Join[{{0,0},{1,0},{1,1},{0,1}},Delete[Subdivide[{0,2/5},{1,2/5},12],7],{{(1/3),(1/5)},{(2/3),(1/5)},{(2/12),(4/5)},{(1/2),(4/5)},{(10/12),(4/5)},{(1/2),(3/5)}}];
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[1,2,16,3,4,5,1,8],{13,2},e[4,19,11],e[10,21,3],e[{5,15},16],e[6,17,18,15],e[19,20,21],{9,17},{12,18},e[7,22,14],{20,22}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

RectilinearCrossingCount[g]

GraphPlot@RotateGraph[,Pi/7]

v={#/8,#2/6}&@@@{{0,0},{4,0},{8,0},{1,1},{2,1},{6,1},{7,1},{0,2},{2,2},{3,2},{5,2},{6,2},{8,2},{3,3},{4,3},{5,3},{3,4},{5,4},{1,5},{7,5},{0,6},{8,6}};
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[1,2,3,13,22,21,8,1,4,5,6,7,3],e[8,9,10,11,12,13],e[4,19,18,17,20,7],{5,9},{6,12},e[10,14,17],e[11,16,18],e[14,15,16],{2,15},{19,21},{20,22}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

RectilinearCrossingCount[g]

gs=UnlabelGraph/@{,,}

GraphPlot@RotateGraph[MinimalCrossingGraph[GraphData["LoupekineSnark1"],"CrossingNumber"->5]]

v={{0,0},{10,0},{1,1},{8,1},{1,2},{2,2},{4,2},{5,2},{6,2},{7,2},{2,3},{3,3},{4,3},{6,3},{7,3},{8,3},{9,3},{5,4},{5,5},{0,6},{5,6},{10,6}};
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[2,22,21,20,1,10,9,8,7,3,2,17,19],e[8,18,19,21],e[20,11,12,13,14,15,16,17],e[1,5,6,4,16],{3,5},{12,18},{6,11},{7,13},{9,14},{15,22},{4,10}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData["LoupekineSnark1","Circulant"]

GraphData["LoupekineSnark1","Graph","Circulant"]//StyleGraphs

Line graph

GraphData["LoupekineSnark1","Line"]

LineGraphQ[GraphData["LoupekineSnark1"]]//Timing

RootGraph

Select[GraphData[All],GraphData[#,"LineGraph","Name"]=== "LoupekineSnark1"&]

RootGraph[GraphData["LoupekineSnark1"]]

Halin

GraphData["LoupekineSnark1","Halin"]

GraphData["LoupekineSnark1","Graph","Halin"]//StyleGraphs

Rigid

GraphData["LoupekineSnark1","Rigid"]

GraphData["LoupekineSnark1","Graph","Rigid"]//StyleGraphs

Flexible

GraphData["LoupekineSnark1","Flexible"]

GraphData["LoupekineSnark1","Graph","Flexible"]//StyleGraphs

LCF

GraphData["LoupekineSnark1","LCF"]

GraphData["LoupekineSnark1","HamiltonianCycleCount"]

GraphData["LoupekineSnark1","LCFSignature"]

GraphData["LoupekineSnark1","LCFNotations"]

GraphData["LoupekineSnark1","Graph","LCF"]//StyleGraphs

UnitDistance

GraphData["LoupekineSnark1","UnitDistance"]

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

GraphData["LoupekineSnark1","Graph","UnitDistance"]//StyleGraphs

Select[%,!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&]

UnitDistance by refinement

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

UnitDistanceGraphEmbeddingQ[%]

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

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

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

FindUnitDistanceEmbedding[GraphData["LoupekineSnark1"],MaxIterations->5000,"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance by FindSubgraphUnitDistanceEmbedding

{"LoupekineSnark1",l=FindSubgraphUnitDistanceEmbedding[GraphData["LoupekineSnark1"],TimeConstraint->300,"Results"->All]//Timing}

gs=SortBy[UniqueEmbeddings[l],Replace[RectilinearCrossingCount[#],Infinity->0]&]

Matchstick

GraphData["LoupekineSnark1","Matchstick"]

GraphData["LoupekineSnark1","Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData["LoupekineSnark1","Edges"]]

3D All

GraphData["LoupekineSnark1","Graph",{"3D","All"}]

3D UnitDistance

GraphData["LoupekineSnark1","Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData["LoupekineSnark1","Polyhedral"]

"LoupekineSnark2"

Names

GraphData["LoupekineSnark2","StandardName"]

GraphData["LoupekineSnark2","StandardNames"]

Primary

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

Construction from Read and Wilson

Inexact:

g=Graph[Range[22],UndirectedEdge@@@{{1,2},{1,3},{1,10},{2,4},{2,17},{3,6},{3,7},{4,5},{4,7},{5,6},{5,8},{6,21},{7,11},{8,13},{8,15},{9,10},{9,12},{9,15},{10,14},{11,12},{11,16},{12,13},{13,14},{14,22},{15,18},{16,19},{16,20},{17,18},{17,20},{18,19},{19,21},{20,22},{21,22}},VertexCoordinates->(10^(-4)){{6493,-14860},{7956,-17394},{9026,-13396},{10489,-15931},{10984,-11222},{13350,-15322},{13656,-12412},{13823,-6303},{14727,-3520},{14727,-593},{16189,-10949},{16189,-8023},{17652,-3520},{17652,-593},{18556,-6303},{18722,-12412},{19028,-15322},{21395,-11222},{21889,-15931},{23352,-13396},{24423,-17394},{25885,-14860}}]

RecognizeGraph@g

Exact:

EuclideanDistance@@v[[{2,5}]]//FullSimplify

EuclideanDistance@@v[[{3,4}]]//FullSimplify

EuclideanDistance@@v[[{5,9}]]//FullSimplify

Solve[EuclideanDistance@@v[[{5,9}]]==(1/2) (1+(Sqrt[5]))]//FullSimplify

v1=Join[CirclePoints[{1/(NumericalApproximation[Root, (RowDefault["1.18", FEExpressionsNumericalApproximationElider]), Root[5-5 ((#1)^2)+((#1)^4)&,3], ]),-Pi/2},5]];
v1=Join[v1,{v1[[4]]+{0,1},v1[[3]]+{0,1}}];
v1=(#+{0,(1/2) (Sqrt[5+(7/(Sqrt[5]))+(Sqrt[6+(6/(Sqrt[5]))])])})&/@v1;
v=Join[Flatten[Table[RotationMatrix[2Pi i/3].#&/@v1,{i,0,2}],1],{{0,0}}];
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[13,16],e[21,20,7,6,14,13,11,8,10,14],e[21,17,15,18,20],e[6,4,1,3,7],e[11,9,12,10],e[18,16,19,17],e[4,2,5,3],e[8,22,15],{1,22},{9,5},{2,19},{12,21}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

All

GraphData["LoupekineSnark2","Graph","All"]//StyleGraphs

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData["LoupekineSnark2","EdgeList"]]

Default embedding

GraphPlot@GraphData["LoupekineSnark2","Edges"]

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

RecognizeGraph[g]

Degenerate

GraphData["LoupekineSnark2","Graph","Degenerate"]//StyleGraphs

DegenerateGraphEmbeddingTypes/@GraphData["LoupekineSnark2","Graph","Degenerate"]

Bilateral

GraphData["LoupekineSnark2","Graph","Bilateral"]//StyleGraphs

Circular

GraphData["LoupekineSnark2","Graph","Circular"]//StyleGraphs

Radial construction

Collier and Schmeichel (1978)

g=Graph[Range[22],
UndirectedEdge@@@Join[Partition[Range[2,22],2,1,1],{{1,2},{21,4},{22,12},{13,3},{16,20},{5,9},{15,6},{1,17},{1,8},{10,19},{14,18},{11,7}}],VertexCoordinates->Join[{{0,0}},CirclePoints[{1,Pi/2},21]]]

RecognizeGraph[%]

Planar

GraphData["LoupekineSnark2","Planar"]

GraphData["LoupekineSnark2","Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData["LoupekineSnark2",{"RCN","CN"}]

GraphData["LoupekineSnark2","Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

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

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

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

faces=ReverseSort@SymmetricallyDistinctFaces[g]

Tally[ReverseSort[Length/@faces]]

IGLayoutTutte[g,"OuterFace"->#]&/@faces

GraphPlot@RotateGraph[,-2Pi/5]

v={#/6,#2/7}&@@@{{0,0},{6,0},{1,1},{2,1},{3,1},{4,1},{5,1},{2,2},{4,2},{2,3},{4,3},{2,4},{3,4},{4,4},{2,5},{3+1/2,5},{4,5},{2,6},{3,6},{4,6},{0,7},{6,7}};
g=Graph[Range@Length@v,UndirectedEdge@@@{e[1,2,22,18,19,20,21,1,3,4,5,6,7,2],e[4,8,10,12,15,18],e[6,9,11,14,17,20],{8,21},{9,22},{10,11},{3,12},{7,14},e[15,16,17],e[5,13,19],{13,16}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@g

RectilinearCrossingCount@g

Union[Select[Table[RotateGraph[MinimalCrossingGraph[GraphData["LoupekineSnark2"],"CrossingNumber"->cn,RandomSeed->n]],{n,1000}],Max[OuterFace[#]]<=GraphData["LoupekineSnark2","V"]&]]//Timing

Table[MinimalCrossingGraph[GraphData["LoupekineSnark2"],"CrossingNumber"->cn,RandomSeed->i],{i,1000}]//Union

GraphPlot@

GraphPlot@RotateGraph[,-Pi/7]

GraphPlot@

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

GraphPlot@RotateGraph[MinimalCrossingGraph[GraphData["LoupekineSnark2"],"CrossingNumber"->5]]

v={#+If[#>5,3,0],#2}&@@@{{0,0},{3,0},{5,0},{7,0},{3,1},{6,1},{3,2},{5,2},{3,3},{5,3},{1,4},{2,4},{4,4},{5,4},{2,5},{3,5},{4,5},{0,6},{1,6},{6,6},{7,6},{2,7}};
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[1,2,3,4,21,22,18,1,12,13,14],e[18,19,20,21],e[19,11,7,5,2],e[3,8,10,14,20],e[4,6,17,16,15,11],{15,22},{5,6},{7,8},e[16,9,10],{13,17},{9,12}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData["LoupekineSnark2","Circulant"]

GraphData["LoupekineSnark2","Graph","Circulant"]//StyleGraphs

Line graph

GraphData["LoupekineSnark2","Line"]

LineGraphQ[GraphData["LoupekineSnark2"]]//Timing

RootGraph

Select[GraphData[All],GraphData[#,"LineGraph","Name"]=== "LoupekineSnark2"&]

RootGraph[GraphData["LoupekineSnark2"]]

Halin

GraphData["LoupekineSnark2","Halin"]

GraphData["LoupekineSnark2","Graph","Halin"]//StyleGraphs

Rigid

GraphData["LoupekineSnark2","Rigid"]

GraphData["LoupekineSnark2","Graph","Rigid"]//StyleGraphs

Flexible

GraphData["LoupekineSnark2","Flexible"]

GraphData["LoupekineSnark2","Graph","Flexible"]//StyleGraphs

LCF

GraphData["LoupekineSnark2","LCF"]

GraphData["LoupekineSnark2","HamiltonianCycleCount"]

GraphData["LoupekineSnark2","LCFSignature"]

GraphData["LoupekineSnark2","LCFNotations"]

GraphData["LoupekineSnark2","Graph","LCF"]//StyleGraphs

UnitDistance

GraphData["LoupekineSnark2","UnitDistance"]

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

GraphData["LoupekineSnark2","Graph","UnitDistance"]//StyleGraphs

Select[%,!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&]

UnitDistance by refinement

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

UnitDistanceGraphEmbeddingQ[%]

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

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

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

FindUnitDistanceEmbedding[GraphData["LoupekineSnark2"],MaxIterations->5000,"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance by FindSubgraphUnitDistanceEmbedding

{"LoupekineSnark2",l=FindSubgraphUnitDistanceEmbedding[GraphData["LoupekinesSnark2"],TimeConstraint->300,"Results"->All]//Timing}

gs=SortBy[UniqueEmbeddings[l],Replace[RectilinearCrossingCount[#],Infinity->0]&]

Matchstick

GraphData["LoupekineSnark2","Matchstick"]

GraphData["LoupekineSnark2","Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData["LoupekineSnark2","Edges"]]

3D All

GraphData["LoupekineSnark2","Graph",{"3D","All"}]

3D UnitDistance

GraphData["LoupekineSnark2","Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData["LoupekineSnark2","Polyhedral"]

GraphData

GraphClassString[GraphData["LoupekinesSnark*"]]