Dürer Graph

Author

Eric W. Weisstein
March 15, 2024

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

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

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

Embeddings

<<MathWorld`Graphs`

Names

GraphData["DuererGraph","StandardName"]

GraphData["DuererGraph","StandardNames"]

Primary

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

All

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

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData["DuererGraph","EdgeList"]]

Default embedding

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

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

RecognizeGraph[g]

RotateGraph[,-Pi/6]

v=Join[CirclePoints[3],CirclePoints[{1/3,4Pi/12},3],CirclePoints[{3/5,2Pi/12},3]];
v=Join[v,v[[#]]+1/4(v[[#2]]-v[[#]])&@@@{{3,7},{1,8},{2,9}}];
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[1,2,3,1,11,8,12],e[7,4,5,6,4],e[2,12,9,10],e[3,10,7,11],{5,8},{6,9}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

GraphData["DuererGraph","Graphics","All"][[2]]

v=Join[CirclePoints[{1,π/2},6],CirclePoints[2/3,3],CirclePoints[{1/5,-π/2},3]];
g=Graph[Range[Length[v]],UndirectedEdge@@@Join[
Partition[Range[6],2,1,1],
Partition[Range[7,9],2,1,1],Partition[Range[10,12],2,1,1],{{3,9},{4,10},{5,7},{1,8},{2,12},{6,11}}],VertexCoordinates->v,VertexLabels->"Name"]

RecognizeGraph[g]

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

RecognizeGraph@g

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

RecognizeGraph@g

Degenerate

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

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

Bilateral

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

Circular

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

Planar

GraphData["DuererGraph","Planar"]

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

GeneralizedPetersen

GraphData["DuererGraph","GeneralizedPetersen"]

Cases[GraphData["DuererGraph","StandardNames"],{"GeneralizedPetersen",_}]

GraphData["DuererGraph","NotationRules","GeneralizedPetersen"]

GraphData["DuererGraph","Graph","GeneralizedPetersen"]//StyleGraphs

Tutte embeddings

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

Tally[ReverseSort[Length/@faces]]

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

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

RecognizeGraph/@gs

Tutte embedding construction 5

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

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

RecognizeGraph[g]

eqn=SquaredEuclideanDistance[{x,y},#]==SquaredEuclideanDistance@@v[[{8,9}]]&/@v[[{8,9}]]

p={x,y}/.Solve[eqn,{x,y}]//FullSimplify

p2=Mean[{v[[6,2]],v[[1,2]]}]//FullSimplify

v=Join[CirclePoints[5],CirclePoints[{1/3,-π/2},5],p[[{2}]],{{0,p2}}];
g=Graph[Range[Length[v]],UndirectedEdge@@@Join[
Partition[Range[5],2,1,1],
Partition[Range[6,10],2,1,1],
{{4,10},{2,7},{9,11},{8,11},{3,11},{5,12},{1,12},{6,12}}],VertexCoordinates->v,VertexLabels->"Name"]

RecognizeGraph[g]

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

RecognizeGraph@g

Tutte embedding construction 3

GraphPlot[RotateGraph[]]

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

RecognizeGraph[g]

v=Join[CirclePoints[3],CirclePoints[{1/3,-π/2},6],CirclePoints[{1/8,-π/2},3]];
g=Graph[Range[Length[v]],UndirectedEdge@@@Join[
Partition[Range[3],2,1,1],
Partition[Range[4,9],2,1,1],Partition[Range[10,12],2,1,1],{{3,9},{1,5},{2,7},{4,10},{8,12},{6,11}}],VertexCoordinates->v,VertexLabels->"Name"]

RecognizeGraph[g]

MinimalCrossing

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

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

LCF

GraphData["DuererGraph","LCFNotations"]

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

Perspective

GraphData["DuererGraph","Graph","Perspective"]//StyleGraphs

UnitDistance

GraphData["DuererGraph","UnitDistance"]

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

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

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

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

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

UnitDistance FindSubgraphUnitDistanceEmbedding

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

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

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

UnitDistance construction

s=Sqrt[3]/2;
v={{0,-z-1},{-1/2,z+1-s},{-1/2,-(z+1-s)},{0,z+1},{1/2,-(z+1-s)},{1/2,z+1-s},{0,-z},{-x,-1/2},{-x,1/2},{0,z},{x,1/2},{x,-1/2}};

eqn=FullSimplify[UnitEdgeEquations[v,EdgeList[]]]//Union

var=Variables[Subtract@@@eqn]

Length/@{eqn,var}

soln=Solve[eqn,var]//FullSimplify

ee=UnitEdges[v];
gs=Graph[Range[Length[v]],UnitEdges[v/.#],VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@soln

RecognizeGraph/@gs

Matchstick

GraphData["DuererGraph","Matchstick"]

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

3D default

Graph3D[GraphData["DuererGraph","Edges"]]

3D All

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

3D "Barrel"

GeneralizedPetersenGraph[6,2,GraphLayout->"BarrelEmbedding"]

3D UnitDistance

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

3D Polyhedron

GraphData["DuererGraph","Polyhedral"]

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

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

3D Canonical

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

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

Perspective projections

PolyhedronProjectionGraph[PolyhedronData["DuerersSolid","Polyhedron"],#,"Simplification"->FullSimplify[RootReduce[#]&]]&/@{{0,0,1,Pi/6},{1,.02,0,ArcTan[(Sqrt[2+(6/(Sqrt[5]))])]},{0,(NumericalApproximation[Root, (RowDefault["0.924", FEExpressionsNumericalApproximationElider]), Root[-5+5 ((#1)^2)+((#1)^4)&,2], ]),1},{0,(NumericalApproximation[Root, (RowDefault["0.162", FEExpressionsNumericalApproximationElider]), Root[-5+140 ((#1)^2)+1936 ((#1)^4)&,2], ]),-1},{0,((5+(Sqrt[5]))/(4 (5^(3/4)))),1},{0,(NumericalApproximation[Root, (RowDefault["0.324", FEExpressionsNumericalApproximationElider]), Root[-5+35 ((#1)^2)+121 ((#1)^4)&,2], ]),1},{(Sqrt[(3/8)+(9/(8 (Sqrt[5])))]),((5+(Sqrt[5]))/(4 (5^(3/4)))),1,-ArcCot[(NumericalApproximation[Root, (RowDefault["1.18", FEExpressionsNumericalApproximationElider]), Root[5-5 ((#1)^2)+((#1)^4)&,3], ])]},{(Sqrt[-(3/8)+(9/(8 (Sqrt[5])))]),-(Sqrt[-(5/8)+((3 (Sqrt[5]))/8)]),1},{0,(Sqrt[-(5/8)+((3 (Sqrt[5]))/8)]),-1},{(NumericalApproximation[Root, (RowDefault["0.561", FEExpressionsNumericalApproximationElider]), Root[-45+105 ((#1)^2)+121 ((#1)^4)&,2], ]),-(NumericalApproximation[Root, (RowDefault["0.324", FEExpressionsNumericalApproximationElider]), Root[-5+35 ((#1)^2)+121 ((#1)^4)&,2], ]),-1,ArcTan[(11/(Sqrt[17+18 (Sqrt[5])]))]},
{(Sqrt[3]),1,0,Pi/2},{1,1,1,Pi/2-ArcTan[3 (-2+(Sqrt[3]))]},{1,(1/(Sqrt[3])),(Sqrt[(1/30) (5+3 (Sqrt[5]))]),-ArcTan[(Sqrt[-3+2 (Sqrt[5])])]},{1,(1/(Sqrt[3])),-(4/(Sqrt[60+27 (Sqrt[5])])),Pi/2-ArcTan[2 (Sqrt[(1/19) (8-3 (Sqrt[5]))])]}}

{,,,,,,,,,,,,,}

GraphData["DuererGraph","Graph","Perspective"]