Walther Graphs

Author

Eric W. Weisstein
June 8, 2023

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

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

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

Embeddings

<<MathWorld`Graphs`

"WaltherGraph25"

Construnction

From Pemmaraju and Skiena

Appears on p. 23 with no additional information.  Combinatorica.m itself also contains no comments other than a definition with edges and vertices.

GraphData["WaltherGraph"]

Names

GraphData["WaltherGraph","StandardName"]

GraphData["WaltherGraph","StandardNames"]

Default

GraphData["WaltherGraph25"]//StyleGraphs

GraphPlot@

All

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

Circulant

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

Halin

GraphData["WaltherGraph25","Halin"]

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

LCF

GraphData["WaltherGraph25","LCF"]

GraphData["WaltherGraph25","LCFSignature"]

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

UnitDistance

GraphData["WaltherGraph25","UnitDistance"]

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

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

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

Select[UnitDistanceEmbeddingRefine/@Complement@@(GraphData["WaltherGraph25","Graph",#]&/@{"All","UnitDistance"}),UnitDistanceGraphEmbeddingQ]

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

UnitDistance FindSubgraphUnitDistanceEmbedding

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

gs=UniqueEmbeddings[l]

gs={,,,,,,,,,,,,,,,,,,,};

Matchstick

GraphData["WaltherGraph25","Matchstick"]

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

MinimalCrossing

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

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

Default embedding

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

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

RecognizeGraph[g]

MinimalCrossing construction

g=RotateGraph[MinimalCrossingGraph[GraphData["WaltherGraph25"],"CrossingNumber"->0]]

RecognizeGraph[g]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

3D default

Graph3D[GraphData["WaltherGraph25","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["WaltherGraph25","Polyhedral"]

GraphData["WaltherGraph25","Graph",{"3D","Polyhedron"}]

"WaltherGraph162"

Construction

Grünbaum 2003, pp. 365–366

G.D. Birkhoff [1] reduced the four-color problem to cyclically 5-connected 3-polytopes and Hunter [1] conjectured that these all admit Hamiltonian circuits, but a counterexample was recently found by Walther [1] (see figure 17.1.9).

v=Join[{{0,0},{24,0},{0,16},{12,16},{24,16}},Sequence@@Table[{i,j},{j,{1,15}},{i,Join[Range[4],{6},Range[8,16],{18},Range[20,23]]}],Sequence@@Table[{i,j},{j,{2,6,10,14}},{i,{4,8,16,20}}],Sequence@@Table[{i,j},{j,{3,5,11,13}},{i,{3,4,8,9,15,16,20,21}}],Sequence@@Table[{i,j},{j,{4,12}},{i,{2,3,5,6,7,9,10,14,15,17,18,19,21,22}}],Sequence@@Table[{i,j},{j,{7,9}},{i,{1,2,3,4,6,8,9,10,11,13,14,15,16,18,20,21,22,23}}],Table[{i,8},{i,{1,6,11,12,13,18,23}}]];
g=Graph[Range@Length@v,Sort[Sort/@(UndirectedEdge@@@{e[1,2,5,4,3,1,{6,24},2],e[3,{25,43},5],{4,34},e[6,120,156,138,25],e[24,137,162,155,43],{10,95},{20,102},{29,109},{39,116},{92,93},{60,61},{68,69},e[44,94,95,96,45],{70,71},{62,63},{48,94},{49,96},e[{120,128}],e[{129,137}],e[{138,146}],e[{147,155}],e[124,157,142],e[133,161,151],{156,157},{161,162},e[14,128,158,146,33],e[16,129,160,147,35],e[158,159,160],{15,159},e[7,92,121],e[8,60,93,68,122],e[9,44,61,69,48,123],e[11,45,62,70,49,125],e[12,63,97,71,126],{97,98},{99,100},{72,73},{64,65},{74,75},{66,67},e[13,98,127],e[17,99,130],e[18,64,100,72,131],e[19,46,65,73,50,132],e[50,101,46],e[101,102,103],e[104,105],e[51,103,47],e[21,47,66,74,51,134],e[22,67,104,75,135],e[23,105,136],{106,107},{84,85},{76,77},e[108,109,110],e[115,116,117],{86,87},{78,79},{113,114},{88,89},{80,81},e[52,108,56],e[57,110,53],e[58,115,54],e[59,117,55],{90,91},{82,83},{118,119},e[139,106,26],e[140,76,107,84,27],e[141,52,77,85,56,28],e[143,53,78,86,57,30],e[144,79,111,87,31],e[145,112,32],e[148,113,36],e[149,80,114,88,37],e[150,54,81,89,58,38],e[152,55,82,90,59,40],e[153,83,118,91,41],e[154,119,42],{111,112}})],VertexCoordinates->v]

StyleGraphs[g,VertexSize->.4]

VertexCount[g]

VertexDegree[g]//Union

HamiltonianGraphQ[g]//Timing

PolyhedralGraphQ[g]

RecognizeGraph@g

Should be 5:

FindCyclicEdgeCut[,Method->"SymmetricallyDistinctEdgeSubsets",Debug->True]

Names

GraphData["WaltherGraph162","StandardName"]

GraphData["WaltherGraph162","StandardNames"]

Primary

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

All

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

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData["WaltherGraph162","EdgeList"]]

Default embedding

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

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

RecognizeGraph[g]

Degenerate

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

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

Bilateral

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

Circular

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

Planar

GraphData["WaltherGraph162","Planar"]

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

Tutte embeddings

faces=ReverseSort@SymmetricallyDistinctFaces[GraphData["WaltherGraph162"]]

Tally[ReverseSort[Length/@faces]]

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

gs=Annotate[#,{VertexLabels->None,ImageSize->Tiny}]&/@{,,}

RecognizeGraph/@gs

Tutte embedding construction  21

g=RotateGraph[]

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

RecognizeGraph[g]

Tutte embedding construction  8

g=RotateGraph[,5Pi/8]

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

RecognizeGraph[g]

Tutte embedding construction  5

g=RotateGraph[,-2Pi/5]

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

RecognizeGraph[g]

MinimalCrossing

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

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

Circulant

GraphData["WaltherGraph162","Circulant"]

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

Line graph

GraphData["WaltherGraph162","Line"]

LineGraphQ[GraphData["WaltherGraph162"]]//Timing

RootGraph

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

RootGraph[GraphData["WaltherGraph162"]]

Halin

GraphData["WaltherGraph162","Halin"]

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

Rigid

GraphData["WaltherGraph162","Rigid"]

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

Flexible

GraphData["WaltherGraph162","Flexible"]

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

LCF

FindHamiltonianCycle[GraphData["WaltherGraph162"]]//Timing

HamiltonianGraphQ[GraphData["WaltherGraph162"]]//Timing

GraphData["WaltherGraph162","LCF"]

GraphData["WaltherGraph162","HamiltonianCycleCount"]

GraphData["WaltherGraph162","LCFSignature"]

GraphData["WaltherGraph162","LCFNotations"]

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

UnitDistance

GraphData["WaltherGraph162","UnitDistance"]

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

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

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

UnitDistance by refinement

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

UnitDistanceGraphEmbeddingQ[%]

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

Select[%,UnitDistanceGraphEmbeddingQ]

gs={,,};

UnitDistance by FindUnitDistanceEmbedding

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

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

UnitDistance by FindSubgraphUnitDistanceEmbedding

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

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

Matchstick

GraphData["WaltherGraph162","Matchstick"]

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

3D default

Graph3D[GraphData["WaltherGraph162","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["WaltherGraph162","Polyhedral"]

GraphData["WaltherGraph162","Graph",{"3D","Polyhedron"}]

Graphics3D[{FaceForm[Green,Red],GraphData["WaltherGraph162","Polyhedron"]}]

3D Canonical

GraphData["WaltherGraph162","Graph",{"3D","Canonical"}]

Graphics3D[{Opacity[.5],Red,GraphData["WaltherGraph162","Polyhedron","Canonical"],Yellow,Sphere[]}]

3D Canonical construction

Graphics3D[{FaceForm[Green,Red],poly=GraphPolyhedron[GraphData["WaltherGraph162","Graph",1],-1,GraphLayout->Automatic]}]

(can=FindCanonicalPolyhedron[poly,WorkingPrecision->50,MaxIterations->5000,PrecisionGoal->20,"ProgressInterval"->1000,"TangentFactor"->1/100,"PlanarFactor"->1/100,Debug->True])//Timing

SimplePolyhedronQ[can]

If[%===False,Quit[]]

Graphics3D[{Opacity[.5],Red,can,Yellow,Sphere[]}]

(lens=Mean/@Split[Sort[PolyhedronEdgeLengths[can]],Abs[#1-#2]<1.*^-10&])//N

v=PolyhedronCoordinates[can];

colors=With[{n=Length[lens]},Table[Hue[i/n],{i,0,n-1}]]

Graphics3D[{Thick,Sequence@@Nearest[Thread[lens->colors],EuclideanDistance@@v[[#]]],Line[v[[#]]]}&/@PolyhedronEdges[can],Boxed->False]

g=PolyhedronGraph[can]

3D Canonical construction from PolyhedralEmbedding

GraphData["WaltherGraph162","Graph","All"]

g=;

Show[g2=PolyhedralEmbedding[g,"Circular"->True,"Scale"->2.5],Boxed->True]//Quiet

With[
{faces=PlanarFaceList[Graph[EdgeList[g2]]],v=GraphEmbedding@g2},
Graphics3D[{Point[{0,0,0}],Opacity[.5],Sphere[],FaceForm[Green,Red],
poly=Polyhedron[1.v,faces]}]]

(can=FindCanonicalPolyhedron[poly,WorkingPrecision->100,MaxIterations->1000,PrecisionGoal->20,"ProgressInterval"->100,"TangentFactor"->1/5,"PlanarFactor"->1/5,Debug->True])//Timing

SimplePolyhedronQ[can]

If[%===False,Quit[]]

Graphics3D[{Opacity[.5],Red,can,Yellow,Sphere[]}]

(lens=Mean/@Split[Sort[PolyhedronEdgeLengths[can]],Abs[#1-#2]<1.*^-10&])//N

v=PolyhedronCoordinates[can];

colors=With[{n=Length[lens]},Table[Hue[i/n],{i,0,n-1}]]

Graphics3D[{Thick,Sequence@@Nearest[Thread[lens->colors],EuclideanDistance@@v[[#]]],Line[v[[#]]]}&/@PolyhedronEdges[can],Boxed->False]

g=PolyhedronGraph[can]

GraphData

GraphClassString

GraphDataClassString["WaltherGraph162"]

GraphDataString

file=OpenWrite["~/walther.m"]

WriteString[file,GraphDataString[,
"StandardName"->"WaltherGraph162",
"Name"->"Walther graph 162",
"Information"->"WaltherGraphs",
"Skip"->{"Arboricity""ChromaticPolynomial","Circumference","ConnectedInducedSubgraphPolynomial","ConnectedInducedSubgraphs","ConstructionNumber","CyclePolynomial","Cycles","CyclicEdgeConnectivity","HadwigerNumber",
"HamiltonianCycles","HamiltonianCycle","HamiltonianWalks","IdiosyncraticPolynomial","IndependendenceNumber","IndependencePolynomial","LowerMatchingNumber","MatchingGeneratingPolynomial","MaximumIndependentEdgeSets","MaximumIndependentEdgeSet","MaximumIndependentEdgeSetCount","MaximumIndependentVertexSet","MaximumIndependentVertexSetCount","MaximumIndependentVertexSets","MetricDimension","MinimumCyclicEdgeCuts","MinimumCyclicEdgeCut","MinimumEdgeCuts","MinimumWeightFractionalColoring","Minors","Pathwidth","Treewidth","TuttePolynomial"}
]]

Close[file]