Heawood Four-Color Graph

Author

Eric W. Weisstein
May 26, 2022

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/HeawoodFour-ColorGraph.nb.

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

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

Embeddings

"HeawoodFourColorGraph"

GraphData["HeawoodFourColorGraph","StandardName"]

All

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

Halin

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

LCF

GraphData["HeawoodFourColorGraph","LCFSignature"]

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

UnitDistance

GraphData["HeawoodFourColorGraph","UnitDistance"]

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

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

Matchstick

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

MinimalCrossing

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

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

Default embedding

g=Graph@GraphData["HeawoodFourColorGraph","Edges"]

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

RecognizeGraph[g]

Planar construction

Import["/Volumes/Users/eww/GethnerOnKempe.pdf",{"Pages",10}]

l=;

g=LabelGraph@LinesToGraph[l]

RecognizeGraph[g]

g2=With[{verts={9,17,22,16,3,10,7,21,4,24,1,6,18,8,25,2,15,13,23,19,12,20,5,11,14}},Graph[verts,EdgeList[g]/.Thread[Range[25]->verts],VertexCoordinates->GraphEmbedding[g],VertexLabels->Automatic]]

IsomorphicGraphQ[g,g2]

RecognizeGraph[g2]

MinimalCrossing Construction

GraphPlot@RotateGraph[MinimalCrossingGraph[GraphData["HeawoodFourColorGraph"]]]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

3D default

Graph3D[GraphData["HeawoodFourColorGraph","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

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

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

3D Canonical

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

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

3D Canonical construction from PolyhedralEmbedding moving a few points

g=GraphData["HeawoodFourColorGraph"]

Show[g2=PolyhedralEmbedding[g,"Circular"->True,"Scale"->5],Boxed->True]

v=GraphEmbedding@g2;
v=ReplacePart[v,{5->Mean[v[[{1,13}]]]}];

With[
{faces=PlanarFaceList[Graph[EdgeList[g2]]]},
Graphics3D[{Point[{0,0,0}],Opacity[.5],Sphere[],FaceForm[Green,Red],
poly=Polyhedron[1.2v,faces],MapIndexed[Text[#2[[1]],#,Background->White]&,v]}]]

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

Graphics3D[can]

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

can=Polyhedron[];

Graphics3D[can]

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

Graphics3D[can]

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

Graphics3D[can]

can=Polyhedron[];

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

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

SimplePolyhedronQ[can]

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

GraphClassString["HeawoodFourColorGraph"]

GraphDataString

WriteString[file,GraphDataString[g2,
"StandardName"->"HeawoodFourColorGraph",
"Name"->"Heawood four-color graph",
"Classes"->{"KempeCounterexample"},
"Information"->"HeawoodFour-ColorGraph",
Debug->True,
TimeConstraint->120
]]