Tutte's Graph

Author

Eric W. Weisstein
June 19, 2023

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

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

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

Construction of Tutte graph via variant with no apex

tuttefragment=GraphData["TutteFragment"];

v=GraphEmbedding[tuttefragment];

n=Length[v]

vs=Append[Flatten[Table[RotationMatrix[Pi+2Pi i/3].#&/@v,{i,0,2}],1],{0,0}];

g=EdgeAdd[Graph[
Range[3Length[v]+1],
UndirectedEdge@@@Flatten[Table[EdgeList[tuttefragment]/.k_Integer:>k+i n,{i,0,2}],1],VertexCoordinates->vs,VertexLabels->Automatic],UndirectedEdge@@@{{1,33},{18,31},{3,16},{2,46},{17,46},{32,46}}]

EuclideanDistance[v[[1]],v[[4]]]//N

extendedtuttefragment=EdgeAdd[Graph[Range[18],UndirectedEdge@@@EdgeList[tuttefragment],VertexLabels->Automatic,VertexCoordinates->With[{v=GraphEmbedding[tuttefragment]},Join[v,{v[[2]]+{0,1/4},v[[1]]+(v[[1]]-v[[4]]),v[[3]]+(v[[3]]-v[[7]])}]]],UndirectedEdge@@@{{2,16},{1,17},{3,18}}]

g1=Annotate[extendedtuttefragment,{VertexSize->Table[i->0,{i,16,18}],VertexStyle->Directive[Red],EdgeStyle->Black,EdgeStyle->Table[i->{Black,Thick,Dashed},{i,{1\[UndirectedEdge]17,2\[UndirectedEdge]16,3\[UndirectedEdge]18}}],VertexLabels->None}]

g2=Annotate[HighlightGraph[,Partition[Range[45],15]],VertexLabels->None];

GraphicsRow[{g1,Style["-> ",40],g2}]

EuclideanDistance@@GraphEmbedding[g][[{1,33}]]//FullSimplify

EuclideanDistance@@GraphEmbedding[g][[{1,3}]]//FullSimplify

g2=Graph[VertexList[g],Sort[Sort/@EdgeList[g]],VertexCoordinates->GraphEmbedding[g]]

RecognizeGraph@g

VertexCount[g]

Embeddings

GraphData["TutteGraph","StandardName"]

Primary

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

Construction from Read and Wilson

All

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

Planar

GraphData["TutteGraph","Planar"]

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

Tutte embeddings

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

Tally[ReverseSort[Length/@faces]]

gs=IGLayoutTutte[GraphData["TutteGraph"],"OuterFace"->#]&/@faces

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

RecognizeGraph/@gs

Tutte embedding construction

GraphPlot[RotateGraph[]]

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

RecognizeGraph[g]

Halin

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

LCF

GraphData["TutteGraph","LCFSignature"]

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

UnitDistance

GraphData["TutteGraph","UnitDistance"]

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

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

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

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

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

UnitDistance FindSubgraphUnitDistanceEmbedding

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

gs=UniqueEmbeddings[l]

Matchstick

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

Default embedding

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

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

RecognizeGraph[g]

3D default

Graph3D[GraphData["TutteGraph","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

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

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

3D Canonical

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

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

3D Polyhedron Canonical construction

Graphics3D[{FaceForm[Green,Red],poly=GraphPolyhedron[GraphData["TutteGraph"],1,"Normalize"->True]}]

Graphics3D[{Point[{0,0,0}],Opacity[.5],Red,poly,Yellow,Sphere[]}]

v=poly[[1]];
v={.8#,.8#2,1.1Clip[#3,{-.3,1}]}&@@@v;
v=ReplacePart[v,(#->{.8,.8,1}v[[#]])&/@{11,12,13}];
v=ReplacePart[v,{1->{1,1,1.2}v[[1]]}];
poly2=Polyhedron[1.25v,poly[[2]]];
Graphics3D[{Point[{0,0,0}],{Opacity[.5],Red,poly2,Yellow,Sphere[]}
(*MapIndexed[Text[#2[[1]],#,Background->White]&,poly2[[1]]]*)}]

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

can=Polyhedron[];

<<MathWorld`Graphs`

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

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

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

can=Polyhedron[];

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

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

SimplePolyhedronQ[can]

(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["TutteGraph","Graph","Planar"]

g=GraphData["TutteGraph","Graph","Planar"][[3]]

g=PlanarGraph[GraphData["TutteGraph","Edges"]]

Show[g2=PolyhedralEmbedding[g,"Circular"->True,"Scale"->4.],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.05v,faces]}]]

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

Graphics3D[can]

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]

GrapData

Matrices

GraphicsRow[GraphMatrixPlot[GraphData["TutteGraph"]]]

Subject

GraphClassString["TutteGraph"]