Szekeres Snark

Author

Eric W. Weisstein
June 19, 2023

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

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

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

Embeddings

Names

GraphData["SzekeresSnark","StandardName"]

GraphData["SzekeresSnark","StandardNames"]

Primary

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

Construction from Read and Wilson

p. 281

Import["/Users/eww/Downloads/Untitled.pdf"][[-1]]

v=Join[CirclePoints[10],CirclePoints[3/4,20],CirclePoints[5/8,5],c=CirclePoints[3/8,10],Mean/@Partition[c,2]];
g=Graph[Range@Length@v,UndirectedEdge@@@{e[10,1,13,31],e[12,2,3,17,32,16,4,5,21,33,20,6,7,25,34,24,8,9,29,35,28,10],e[1,11,36],e[10,30,45],e[2,14,37],e[3,15,38],e[5,19,40],e[6,22,41],e[7,23,42],e[9,27,44],e[8,26,43],{33,48},{32,47},{35,50},{34,49},e[28,44,41,21],e[20,40,37,13],e[4,18,39],e[24,42,39,17],e[25,43,36,12],e[29,45,38,16],e[23,49,26],e[22,48,19],e[18,47,15],e[27,50,30],e[11,46,14],e[46,31,12]},VertexCoordinates->v,VertexLabels->Automatic]

VertexDegree[g]

RecognizeGraph@g

All

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

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData["SzekeresSnark","EdgeList"]]

Default embedding

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

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

v={#/12,#2/11}&@@@{{0,0},{4,0},{8,0},{12,0},{2,1},{3,1},{4,1},{8,1},{9,1},{10,1},{0,2},{3,2},{9,2},{12,2},{3,3},{9,3},{3,4},{9,4},{0,5},{2,5},{3,5},{4,5},{8,5},{9,5},{10,5},{12,5},{2,6},{10,6},{0,7},{1,7},{3,7},{9,7},{11,7},{12,7},{2,8},{3,8},{9,8},{10,8},{4,9},{8,9},{5,10},{6,10},{7,10},{0,11},{3,11},{4,11},{6,11},{8,11},{9,11},{12,11}};
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[1,2,3,4,14,26,34,50,49,48,47,46,45,44,29,19,11,1,5,17,22],e[23,18,10,4],{11,12},{13,14},e[5,6,7],e[8,9,10],e[2,7,22,39,46],e[3,8,23,40,48],e[45,41,42,43,49],{39,43},{40,41},e[44,35,36,37,38,50],{30,27},{33,28},e[6,12,15,17],e[9,13,16,18],e[19,20,21,16],e[26,25,24,15],e[29,30,31],e[32,33,34],e[20,27,35],e[24,32,37],e[25,28,38],e[21,31,36],{42,47}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@g

RectilinearCrossingCount@g

c=CirclePoints[5];
v=Flatten[MapIndexed[CirclePoints[#,{1/3,2Pi(#2[[1]]+2)/5-Pi/2},9]&,c],1];
v=Join[v,c];
g=Graph[Range@Length@v,UndirectedEdge@@@{{5,15},{41,6},{32,42},{33,23},{24,14},{8,21},{26,39},{30,17},{35,3},{44,12},e[2,6,7,8,9,1,2,3,4,5,9],e[11,15,16,17,18,10,11,12,13,14,18],e[20,24,25,26,27,19,20,21,22,23,27],e[29,33,34,35,36,28,29,30,31,32,36],e[38,42,43,44,45,37,38,39,40,41,45],e[25,48,22],{19,48},e[16,47,13],{10,47},e[31,49,34],e[40,50,43],e[4,46,7],{28,49},{37,50},{1,46}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@g

Degenerate

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

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

Bilateral

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

Circular

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

Planar

GraphData["SzekeresSnark","Planar"]

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

MinimalCrossing

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

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

MinimalCrossing construction

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

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

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

faces=ReverseSort@SymmetricallyDistinctFaces[g]

Tally[ReverseSort[Length/@faces]]

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

Select[%,Max[OuterFace[#]]<=GraphData["SzekeresSnark","V"]&]

IGLayoutDavidsonHarel[
IGVertexMap[#&,VertexCoordinates->(Rescale@GraphEmbedding[#,"PlanarEmbedding"]&),],
"Continue"->True,"EdgeCrossingWeight"->1000,VertexLabels->Automatic
]

GraphPlot@UnlabelGraph@RotateGraph[%,{50,21}]

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

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

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData["SzekeresSnark","Circulant"]

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

Line graph

GraphData["SzekeresSnark","Line"]

LineGraphQ[GraphData["SzekeresSnark"]]//Timing

RootGraph

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

RootGraph[GraphData["SzekeresSnark"]]

Halin

GraphData["SzekeresSnark","Halin"]

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

Rigid

GraphData["SzekeresSnark","Rigid"]

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

Flexible

GraphData["SzekeresSnark","Flexible"]

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

LCF

GraphData["SzekeresSnark","LCF"]

GraphData["SzekeresSnark","HamiltonianCycleCount"]

GraphData["SzekeresSnark","LCFSignature"]

GraphData["SzekeresSnark","LCFNotations"]

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

UnitDistance

GraphData["SzekeresSnark","UnitDistance"]

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

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

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

UnitDistance by refinement

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

UnitDistanceGraphEmbeddingQ[%]

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

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

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

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

UnitDistance by FindSubgraphUnitDistanceEmbedding

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

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

Matchstick

GraphData["SzekeresSnark","Matchstick"]

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

3D default

Graph3D[GraphData["SzekeresSnark","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["SzekeresSnark","Polyhedral"]