Watkins Snark

Author

Eric W. Weisstein
June 19, 2023

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

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

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

Snark

SnarkQ[GraphData["WatkinsSnark"],Debug->True]//Timing

Embeddings

Names

GraphData["WatkinsSnark","StandardName"]

GraphData["WatkinsSnark","StandardNames"]

Primary

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

Construction from Read and Wilson

p. 281

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

g=Graph[Range[50],UndirectedEdge@@@{{1,2},{1,4},{1,15},{2,3},{2,8},{3,6},{3,37},{4,6},{4,7},{5,10},{5,11},{5,22},{6,9},{7,8},{7,12},{8,9},{9,14},{10,13},{10,17},{11,16},{11,18},{12,14},{12,33},{13,15},{13,16},{14,20},{15,21},{16,19},{17,18},{17,19},{18,30},{19,21},{20,24},{20,26},{21,50},{22,23},{22,27},{23,24},{23,25},{24,29},{25,26},{25,28},{26,31},{27,28},{27,48},{28,29},{29,31},{30,32},{30,36},{31,36},{32,34},{32,35},{33,34},{33,40},{34,41},{35,38},{35,40},{36,38},{37,39},{37,42},{38,41},{39,44},{39,46},{40,46},{41,46},{42,43},{42,45},{43,44},{43,49},{44,47},{45,47},{45,48},{47,50},{48,49},{49,50}},VertexCoordinates->(10^(-4)){{4488,-10499},{5443,-7556},{6399,-4614},{6471,-9575},{7013,-18274},{7460,-6528},{7994,-10070},{8488,-8546},{8983,-7023},{9160,-17855},{9514,-20092},{9516,-10565},{10101,-16559},{10505,-7518},{11042,-15263},{11396,-17501},{11750,-19738},{12015,-21911},{12691,-18442},{13008,191},{13632,-17146},{14499,-4614},{14499,-3012},{14499,-1410},{16100,-3012},{16100,191},{17701,-4614},{17701,-3012},{17701,-1410},{18569,-17146},{19192,191},{19510,-18442},{20185,-21911},{20450,-19738},{20805,-17501},{21159,-15263},{21695,-7518},{22100,-16559},{22684,-10565},{22686,-20092},{23040,-17855},{23217,-7023},{23712,-8546},{24207,-10070},{24740,-6528},{25188,-18274},{25729,-9575},{25801,-4614},{26757,-7556},{27712,-10499}}]

RecognizeGraph@g

All

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

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData["WatkinsSnark","EdgeList"]]

Default embedding

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

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

RecognizeGraph[g]

Degenerate

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

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

Bilateral

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

Circular

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

Planar

GraphData["WatkinsSnark","Planar"]

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

MinimalCrossing

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

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

MinimalCrossing construction

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

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

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

faces=ReverseSort@SymmetricallyDistinctFaces[g]

Tally[ReverseSort[Length/@faces]]

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

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

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

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

GraphPlot@RotateGraph[MinimalCrossingGraph[GraphData["WatkinsSnark"],"CrossingNumber"->9],-1.7]

GraphData["WatkinsSnark","V"]

e[l__]:=Sequence@@Partition[{l},2,1]

v[[35]]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData["WatkinsSnark","Circulant"]

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

Line graph

GraphData["WatkinsSnark","Line"]

LineGraphQ[GraphData["WatkinsSnark"]]//Timing

RootGraph

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

RootGraph[GraphData["WatkinsSnark"]]

Halin

GraphData["WatkinsSnark","Halin"]

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

Rigid

GraphData["WatkinsSnark","Rigid"]

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

Flexible

GraphData["WatkinsSnark","Flexible"]

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

LCF

GraphData["WatkinsSnark","LCF"]

GraphData["WatkinsSnark","HamiltonianCycleCount"]

GraphData["WatkinsSnark","LCFSignature"]

GraphData["WatkinsSnark","LCFNotations"]

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

UnitDistance

GraphData["WatkinsSnark","UnitDistance"]

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

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

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

UnitDistance by refinement

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

UnitDistanceGraphEmbeddingQ[%]

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

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

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

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

UnitDistance by FindSubgraphUnitDistanceEmbedding

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

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

Matchstick

GraphData["WatkinsSnark","Matchstick"]

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

3D default

Graph3D[GraphData["WatkinsSnark","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["WatkinsSnark","Polyhedral"]