Soifer Graph

Author

Eric W. Weisstein
May 16, 2022

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

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

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

Additional Author

Name from
Stan Wagon
Fri, 7 Mar 2008 16:26:39 -0700

Relation to the Fritsch graph

RecognizeGraph[s=//StyleGraphs]

g=HighlightGraph[EdgeAdd[s,3\[UndirectedEdge]4]//StyleGraphs,Style[3\[UndirectedEdge]4,Directive[AbsoluteThickness[1.5],AbsoluteDashing[4]]]]

RecognizeGraph@g

With[{style=LabelStyle->Directive[Italic,14,Black,FontFamily->"Times"]},GraphicsRow[{Show[s,PlotLabel->"Soifer graph",style],Style["→",24],Show[g,PlotLabel->"Fritsch graph",style]},Alignment->Center,Spacings->-5]]

Embeddings

GraphData["SoiferGraph","StandardName"]

Primary

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

All

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

GraphicsRow[%]

Planar

GraphData["SoiferGraph","Planar"]

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

Tutte embeddings

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

Tally[ReverseSort[Length/@faces]]

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

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

Tutte embedding construction 4

GraphPlot[RotateGraph[,3Pi/4]]

v=Join[UnitCirclePoints[4,0],CirclePoints[1/4,4]];
AppendTo[v,Mean[v[[{6,7}]]]];
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[1,2,3,4,1,6,2,7,3,8,4,5,1],e[6,9,7,8,5,6],e[8,9,5],{2,9}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

s=Sqrt[3]/2;
a=1/5;
v={{0,-1},{1,0},{0,1},{-1,0},{-a,0},{a,0},{0,2a s},{-2a,2 a s},{2a,2 a s}};
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[1,2,3,4,1,5,7,6,1],e[4,5,6,2,9,7,8,4],e[7,3,8,5],e[3,9,6]},VertexCoordinates->v,VertexLabels->Automatic]

Tutte embedding construction 3 #1

GraphPlot[RotateGraph[]]

v=Join[{{-1,0},{1,0},{0,Sqrt[3]},{-1/4,1/4},{0,1/4},{1/4,1/4},{-1/4,3/4},{0,3/4},{1/4,3/4}}];
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[1,2,3,1,4,5,6,9,8,7,4,8,6,2,9,3,7,1,5,2],{3,8}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

Tutte embedding construction 3 #2

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

v=Join[{{-1,0},{1,0},{0,Sqrt[3]},{-1/4,1/4},{0,1/4},{1/4,1/4},{-1/4,3/4},{0,3/4},{1/4,3/4}}];
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[1,2,3,1,4,5,6,2,5,1,7,8,9,2],e[4,7,3,9,6,8,4],{5,8}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

Tutte embedding construction 3 #3

GraphPlot[RotateGraph[,2Pi/3]]

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

RecognizeGraph[g]

Tutte embedding construction 3 #4

GraphPlot[RotateGraph[]]

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

RecognizeGraph[g]

Tutte embedding construction 3 #5

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

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

RecognizeGraph[g]

Tutte embedding construction 3 #6

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

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

RecognizeGraph[g]

Tutte embedding construction 3 #7

GraphPlot[RotateGraph[,2Pi/3]]

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

RecognizeGraph[g]

Halin

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

LCF

GraphData["SoiferGraph","LCFSignature"]

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

Manual construction

Name and vertices from
Stan Wagon
Fri, 7 Mar 2008 16:26:39 -0700

g=Graph[Range[9],UndirectedEdge@@@{{1,3},{1,4},{1,6},{1,7},{1,9},{2,4},{2,6},{2,9},{2,8},{2,5},{3,8},{3,5},{3,7},{4,6},{4,8},{5,7},{5,9},{5,8},{6,9},{7,9}},VertexCoordinates->{{5,0},{2.5`,2.35`},{0,0},{3.2`,3.`},{1.8`,1.7`},{3.2`,1.7`},{1.4`,0.6`},{1.8`,3.`},{2.5`,1.05`}}]

UnitDistance

GraphData["SoiferGraph","UnitDistance"]

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

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

Matchstick

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

Default embedding

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

e[l__]:=Sequence@@Partition[{l},2,1];
v={{0,0},{1/2,0},{1,0},{1,1},{1/2,1},{0,1},{1/4,1/2},{3/4,1/2},{1/2,3/4}};
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[1,2,3,4,5,6,1,9,3,8,5,7,1],e[6,7,2,8,4,9,6],{7,8},{5,9}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

3D default

Graph3D[GraphData["SoiferGraph","Edges"]]

3D All

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

3D Polyhedron

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

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

3D Canonical

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

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

3D Polyhedron construction

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

(can=FindCanonicalPolyhedron[poly,WorkingPrecision->1000,MaxIterations->10000,PrecisionGoal->20])//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["SoiferGraph"]

GraphDataString

file=OpenWrite["soifer.m"]

WriteString[file,GraphDataString[g,
"StandardName"->"Soifer",
"Name"->{"Soifer graph"},
"AlternateStandardNames"->{9,271429},
"AlternateNames"->{"9-graph 271429"},
"Information"->"SoiferGraph",
Debug->True
]]

Close[file]