Errera Graph

Author

Eric W. Weisstein
August 29, 2022

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

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

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

Graph

Primary

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

All

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

Planar

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

MinimalCrossing

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

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

MinimalCrossing construction

GraphPlot@RotateGraph[MinimalCrossingGraph[GraphData["ErreraGraph"],"CrossingNumber"->-1]]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Tutte embeddings

<<IGraphM`

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

Tally[ReverseSort[Length/@faces]]

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

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

Tutte embedding construction 3 #1

GraphPlot[RotateGraph[,-2Pi/3]]

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

RecognizeGraph[g]

Tutte embedding construction 3 #2

GraphPlot[RotateGraph[,2Pi/3]]

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

RecognizeGraph[g]

Tutte embedding construction 3 #3

GraphPlot[RotateGraph[,2Pi/3]]

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

RecognizeGraph[g]

LCF

GraphData["ErreraGraph","LCFSignature"]

GraphData["ErreraGraph","Graph","LCF"]

UnitDistance

UnitDistanceGraphQ[GraphData["ErreraGraph"],Debug->True]

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

GraphData["ErreraGraph","Graph","UnitDistance"]

Matchstick

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

Default embedding

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

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

RecognizeGraph[g]

3D default

Graph3D[GraphData["ErreraGraph","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

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

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

3D Canonical

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

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

3D Canonical construction

<<MathWorld`Graphs`

Graphics3D[{FaceForm[Green,Red],poly=GraphPolyhedron[GraphData["ErreraGraph"],-1]}]

(can=FindCanonicalPolyhedron[poly,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]

Construction

UnitDistance approximation (local minimum)

g=CenterGraph@RotateGraph[LabelGraph@UnitDistanceEmbeddingRefine[AdjacencyGraph[GraphData["ErreraGraph","AdjacencyMatrix"]],Debug->True],{5,4}]

EdgeLengths[g]

Polyhedron

Graph3D[GraphData["ErreraGraph","Edges"]]

UnitDistanceEmbeddingRefine[Graph3D@AdjacencyGraph[GraphData["ErreraGraph","AdjacencyMatrix"]]]

v=PolyhedronData["Icosahedron","Vertices"];

Graphics3D[{PolyhedronData["Icosahedron","Polyhedron"],MapIndexed[Text[#2[[1]],#,Background->White]&,v]},Axes->True,AxesOrigin->0,AxesLabel->{x,y,z},Ticks->None]

Select[PolyhedronData[All],PolyhedronData[#,"FaceCountRules"]==={3->15,5->1}&]

PolyhedronData["GyroelongatedPentagonalPyramid"]

top=Rest[(#-{0,0,v[[9,3]]})&/@v]//FullSimplify//ToRadicals

Length[vnew=Union[{#,#2,-#3}&@@@top,top]]

e=UnitEdges[vnew]

g=Graph[Range[17],e,VertexCoordinates->vnew]

RecognizeGraph[g]

EdgeLengths[g]//FullSimplify//Union

Projection from infinity

LabelGraph@PolyhedronProjectionGraph[GraphData["ErreraGraph","Polyhedron"],{0,1,0}]

Default

Graph[GraphData["ErreraGraph","Edges"]]

Projections

Graphics3D[GraphData["ErreraGraph","Polyhedron"],Axes->True,Ticks->None,AxesLabel->{x,y,z}]

poly=GraphData["ErreraGraph","Polyhedron"];

v=PolyhedronCoordinates[poly];

v1={#2,#3,#1}&@@@v;
v2=(#-Mean[v1])&/@v1;

Graphics3D[{Opacity[.2],poly2=Polyhedron[v2,poly[[2]]]},Axes->True,AxesOrigin->{0,0,0},Ticks->None,AxesLabel->{x,y,z},Boxed->False]

GraphData["ErreraGraph","Graph","3D"]

GraphicsGrid[Partition[Table[Show[SkeletonGraph[poly2,r,.35+If[r<.9,Pi,0]],PlotLabel->r],{r,.1,2,.1}],UpTo[5]]]

Table[SkeletonGraph[poly2,r,.35+If[r<.9,Pi,0]],{r,.1,2,.1}]

Table[SkeletonGraph[poly2,r,.35],{r,{4.2,10,1000}}]

Four-coloring

<<Wagon1998`GraphColoring`

Wagon's package must be run in v4.1 using the old Combinatorica package

?ErreraGraph

FourColoring[ErreraGraph]

GraphData

GraphClassString

GraphClassString["ErreraGraph"]