Doyle Graph

Author

Eric W. Weisstein
October 26, 2023

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

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

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

Additional Authors

Some Doyle graph embeddings by Ed Pegg Jr.
September 19, 2002 and March 2007

Non-vertex-edge-degenerate unit-distance embedding from Jeremy Tan
Communicated by Ed Pegg. Jr.
October 16, 2021

Torus embedding turned into a near-grid embedding by Ed Pegg Jr., Oct. 22, 2021
 Starting from a physical construction communicated by Peter Doyle, Oct. 2021

Quartic VT 27-node graphs

GraphData[{"Symmetric","Quartic"},27]

quartic27=GraphData["Quartic",27]

GraphData/@quartic27

With[{props={"#","Quartic","ArcTransitive","EdgeTransitive","VertexTransitive","Symmetric"}},
TextGrid[Prepend[GraphData[#,{"#","Quartic","ArcTransitive","EdgeTransitive","VertexTransitive","Symmetric"}]&/@quartic27,Thread[Style[props,Bold]]],Dividers->All]
]

Properties

Smallest (known) nonempty symmetric graph that is not arc-transitive:

GraphData["DoyleGraph",{"ArcTransitive","EdgeTransitive","VertexTransitive","Symmetric"}]

TextGrid[Sort[GraphData[#,{"V","#"}]&/@Complement[GraphData[{"Nonempty","Symmetric"}],GraphData["ArcTransitive"]]],Dividers->All]

Embeddings

<<MathWorld`Graphs`

Names

GraphData["DoyleGraph","StandardName"]

GraphData["DoyleGraph","StandardNames"]

Primary

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

All

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

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData["DoyleGraph","EdgeList"]]

Default embedding

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

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

RecognizeGraph[g]

Degenerate

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

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

Perspective

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

Perspective construction

GraphData["DoyleGraph","Polyhedron"]

Bilateral

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

Circular

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

Torus

GetGraphData["DoyleGraph","ToroidalCrossingNumber"]

GetGraphData["DoyleGraph","CrossingNumber"]

GraphData["DoyleGraph","Graph","Torus"]//StyleGraphs

"Stacked" toroidal?

Rest@GraphData["DoyleGraph","Graph","Degenerate"]//StyleGraphs

Planar

GraphData["DoyleGraph","Planar"]

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

MinimalCrossing

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

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

MinimalCrossing construction

(cn=CrossingNumber[GraphData["DoyleGraph"],TimeConstraint->1])//AbsoluteTiming

(cn=CrossingNumber[GraphData["DoyleGraph"],TimeConstraint->10])//AbsoluteTiming

(g=MinimalCrossingGraph[GraphData["DoyleGraph"],"CrossingNumber"->cn])//PolyhedralGraphQ

faces=ReverseSort@SymmetricallyDistinctFaces[g]

Tally[ReverseSort[Length/@faces]]

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

Union[Select[Table[RotateGraph[MinimalCrossingGraph[GraphData["DoyleGraph"],"CrossingNumber"->cn,RandomSeed->n]],{n,500}],Max[OuterFace[#]]<=GraphData["DoyleGraph","V"]&]]//Timing

Table[MinimalCrossingGraph[GraphData["DoyleGraph"],"CrossingNumber"->cn,RandomSeed->i],{i,50}]//Union

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData["DoyleGraph","Circulant"]

GraphData["DoyleGraph","Graph","Circulant"]//StyleGraphs

Complement graph

GraphData["DoyleGraph","ComplementGraph","Name"]

Line graph

GraphData["DoyleGraph","Line"]

LineGraphQ[GraphData["DoyleGraph"]]//Timing

RootGraph

Select[GraphData[All],GraphData[#,"LineGraph","Name"]=== "DoyleGraph"&]

RootGraph[GraphData["DoyleGraph"]]

Halin

GraphData["DoyleGraph","Halin"]

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

Rigid

GraphData["DoyleGraph","Rigid"]

GraphData["DoyleGraph","Graph","Rigid"]//StyleGraphs

Flexible

GraphData["DoyleGraph","Flexible"]

GraphData["DoyleGraph","Graph","Flexible"]//StyleGraphs

LCF

GraphData["DoyleGraph","LCF"]

GraphData["DoyleGraph","HamiltonianCycleCount"]

GraphData["DoyleGraph","LCFSignature"]

GraphData["DoyleGraph","LCFNotations"]

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

Tally[LCFNotation[#][[2]]&/@%]

LCF compute all

Length[FindHamiltonianCycle[GraphData["DoyleGraph"],All][[All,All,1]]]//Timing

Tally[(lcf=LCF[GraphData["DoyleGraph"],All])[[All,2]]]//Timing

MaxMemoryUsed[]/10.^9 "GB"

Tally[(lcf=ReadProperty["LCFNotations",GraphNameToFileName["DoyleGraph",".m.gz"]])[[All,2]]]//Timing

DeleteCases[lcf,{_,1}]

LCFGraph@@@DeleteCases[lcf,{_,1}]//StyleGraphs

Tally[LCFNotation[#][[-1]]&/@(gs=NiceLCFGraphs[lcf,2,None])]//Timing

Length[gs]

gs

UnitDistance

GraphData["DoyleGraph","UnitDistance"]

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

ud=GraphData["DoyleGraph","Graph","UnitDistance"]//StyleGraphs

GraphicsRow[ud]

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

UnitDistance by refinement

UnitDistanceEmbeddingRefine[Graph[GraphData["DoyleGraph","VertexList"],GraphData["DoyleGraph","EdgeList"]],MaxIterations->500]

UnitDistanceGraphEmbeddingQ[%]

UnitDistanceEmbeddingRefine[Annotate[#,VertexCoordinates->N[GraphEmbedding[#]]],MaxIterations->500]&/@Complement@@(GraphData["DoyleGraph","Graph",#]&/@{"All","UnitDistance"})

Select[%,UnitDistanceGraphEmbeddingQ]

LabelGraph/@%129

UnitDistance by FindUnitDistanceEmbedding

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

FindUnitDistanceEmbedding[GraphData["DoyleGraph"],MaxIterations->5000,"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance by FindSubgraphUnitDistanceEmbedding

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

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

Matchstick

GraphData["DoyleGraph","Matchstick"]

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

3D default

Graph3D[GraphData["DoyleGraph","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["DoyleGraph","Polyhedral"]

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

Construction

From mod relation (Holt paper)

Holt paper

v=Flatten[Outer[List,Range[9],Range[3]],1]

g=MakeUndirected@MakeGraph[Flatten[Outer[List,Range[9],Range[3]],1],
((Mod[4#1[[1]]+1-#2[[1]],9]==0||Mod[4#1[[1]]-1-#2[[1]],9]==0)&&Mod[#2[[2]]-(#1[[2]]-1),3]==0)||
((Mod[7#1[[1]]+7-#2[[1]],9]==0||Mod[7#1[[1]]-7-#2[[1]],9]==0)&&Mod[#2[[2]]-(#1[[2]]+1),3]==0)&,Type->Directed]

ShowLabeledGraph[g]

RecognizeGraph[g]

ChangeVertices[g,Flatten[Table[{i,j},{i,9},{j,3}],1]]//ShowGraph

Contract points at distance 5 to get the Doyle graph

OneDiffersQ[a_,b_,i_,n_]:=Module[{d=DeleteCases[Transpose[{a,b}],_?(Equal@@#&)],𝒶,𝒷},
If[
Length[d]==1,{𝒶,𝒷}=d[[1]];Mod[𝒷-(𝒶+2^i),n]==0,
False]
]

BouwerEdgeQ[m_,n_,{{i1_,a__},{i2_,b__}}]:=And[
Mod[i2-i1,m]==1&&({a}=={b}||OneDiffersQ[{a},{b},i1,n])
]

BouwerGraph[nn_,m_,n_]:=MakeUndirected[MakeGraph[Flatten[Outer[List,Range[0,m-1],Sequence@@Table[Range[0,n-1],{nn-1}]],nn-1],BouwerEdgeQ[m,n,{#1,#2}]&,Type->Directed]]

g=BouwerGraph[2,6,9];

p=Union[Sort/@Position[GraphDistanceMatrix[g],5]]

g2=FromUnorderedPairs[Union[Sort/@(Edges[g]/.Rule@@@Reverse/@p)]]

RecognizeGraph[g2]

Jeremy Tan (non-degenerate UD embedding)

By Jeremy Tan
Communicated by Ed Pegg, Jr.
Oct. 16, 2021

Original

radius[i_]:=Module[{t=4Cos[2^i Pi/9]^2},{1,-1,-1}[[i+1]]Sqrt[Root[#^3+(1-t)#^2+t#-t/3&,1]]]

Table[radius[i],{i,0,2}]

%//InputForm

N[%]

holtverts=ReIm/@Flatten[Table[radius[i]Exp[2j I Pi/9],{i,0,2},{j,0,8}]]//FullSimplify

N[%]

Converted to algebraic root objects

Eric Weisstein, Oct, 18, 2021

{1,-1,-1}RootReduce@Sqrt[Flatten[x/.Table[Solve[RootReduce[FirstCase[radius[i],Root[r_,__]:>r[x],Null,∞]]==0,x,Reals],{i,0,2}]]]

radius2[i_]:={(NumericalApproximation[Root, (RowDefault["0.675", FEExpressionsNumericalApproximationElider]), Root[-1+9 ((#1)^2)-9 ((#1)^4)-54 ((#1)^6)+81 ((#1)^8)+54 ((#1)^10)-135 ((#1)^12)+162 ((#1)^14)-81 ((#1)^16)+27 ((#1)^18)&,6], ]),-(NumericalApproximation[Root, (RowDefault["0.630", FEExpressionsNumericalApproximationElider]), Root[-1+9 ((#1)^2)-9 ((#1)^4)-54 ((#1)^6)+81 ((#1)^8)+54 ((#1)^10)-135 ((#1)^12)+162 ((#1)^14)-81 ((#1)^16)+27 ((#1)^18)&,5], ]),-(NumericalApproximation[Root, (RowDefault["0.384", FEExpressionsNumericalApproximationElider]), Root[-1+9 ((#1)^2)-9 ((#1)^4)-54 ((#1)^6)+81 ((#1)^8)+54 ((#1)^10)-135 ((#1)^12)+162 ((#1)^14)-81 ((#1)^16)+27 ((#1)^18)&,4], ])}[[i+1]]

holtverts=ReIm/@Flatten[Table[radius2[i]Exp[2j I Pi/9],{i,0,2},{j,0,8}]]//RootReduce

holtedges=UnitEdges[holtverts]

g=Graph[Range[Length[holtverts]],holtedges,VertexCoordinates->holtverts]

RecognizeGraph[g]

UnitDistanceGraphEmbeddingQ[g]

DegenerateGraphEmbeddingTypes[g]

Marusic et al.

l=;

GraphPlot[g=LinesToGraph[l],Method->None,ImageSize->200]

RecognizeGraph[g]

LCF embedding [Gallery of named graphs]

Gallery of named graphs
with tkz-berge.sty by AlainMatthes
http://www.altermundus.fr/pages/downloads/NamedGraphs

ExtendLine[{v1_,v2_},r_]:=Module[{dv=Normalize[v2-v1]},Line[{v1-r dv,v2+r dv}]]

page=Import["/Volumes/Users/eww/Mathematica/Paclets/GraphData/Collections/NamedGraphs.pdf",{"Pages",37}]

g=;

Length[l=Cases[g,_Line,{1,∞}]]

Graphics[gg=l/.Line[x_]:>ExtendLine[x,12],ImageSize->200]

GraphPlot[g=MakeUndirected[RemoveMultipleEdges[LinesToGraph[Graphics[gg],10]]],Method->None,ImageSize->200]

r=RecognizeGraph[g]

FastIsomorphicQ[g,Graph["DoyleGraph"]]

Through[{V,M,FastAutomorphismCount}[g]]

GraphData["DoyleGraph","|HC|"]

Degenerate (needs work)

page=Import["~/Desktop/NamedGraphs.pdf",{"Pages",35}]

g=;

Length[l=Cases[g,_Line,{1,∞}]]

Graphics[gg=l/.Line[x_]:>ExtendLine[x,11]]

GraphPlot[g=RemoveMultipleEdges[LinesToGraph[Graphics[gg],10]],Method->None,VertexLabeling->True]

Edges[g]

g2=g

Degrees[g2]

Position[%,3]//Flatten

Position[Normal@AdjacencyMatrix[g][[8]],1]//Flatten

RecognizeGraph[g2=AddEdges[g,{{3,16},{6,25},{7,4},{8,}]]

GraphData["DoyleGraph","DegreeSequence"]

{SymmetricQ[g],QuarticQ[g]}

Degrees[g]

r=RecognizeGraph[g]

Take[GraphData[r,"AllImages"],8]

GetGraphData[r,"File"]

Insert[Take[GraphData[r,"Embeddings"],8],ToCommonEdges[g,Graph[r]],2]

Another Quartic Symmetric 27-node graph that is not Doyle's

page=Import["~/Desktop/NamedGraphs.pdf",{"Pages",38}]

g=;

Length[l=Cases[g,_Line,{1,∞}]]

Graphics[gg=l/.Line[x_]:>ExtendLine[x,9],ImageSize->200]

GraphPlot[g=MakeUndirected[RemoveMultipleEdges[LinesToGraph[Graphics[gg],10]]],Method->None,ImageSize->200]

RecognizeGraph[ToCombinatoricaGraph[]]

HamiltonianCycles[g,All]//Length//Timing

Through[{V,M,FastAutomorphismCount,SymmetricQ,QuarticQ}[g]]

FastIsomorphicQ[g,Graph["DoyleGraph"]]

GraphData[{"Symmetric","Quartic"},27]

r=RecognizeGraph[g]

Gerbracht (V-E generate)

E. Gerbracht
Dec 27, 2009

g=Import["~/DoyleLookalike.pdf"]

g=;

g2=DeleteCases[g,{___,_Dashing,___}|_CapForm,{1,∞}]

pts=Cases[g2,HoldPattern[BezierCurve[{x_},SplineClosed->True,SplineDegree->3]]:>Mean[x],{1,∞}]

Mean[pts]

Nearest[pts,Mean[pts],2]

Graphics[Point[pts2=Complement[pts,%42]]]

Length[gr2]

Graphics[gr]

Length[%]

lines=Cases[g2,HoldPattern[BezierCurve[{x_},SplineDegree->3]]:>{First[x],Last[x]},{1,∞}]

Sort[Norm/@(Subtract@@@lines)]

lines2=Select[lines,50<Norm[Subtract@@#]<200&]

l=Graphics[Line/@lines2]

g=RemoveMultipleEdges[LinesToGraph[l]]

GraphPlot[g,VertexLabeling->True,Method->None]

Edges[g]

Select[Edges[g],MemberQ[#,15]&]

RecognizeGraph[g]

Degrees[g]

Position[%,Except[4]]//Flatten

g2=DeleteEdges[g,{{15,16},{16,20}}]

g2//InputForm

g2=Graph[{{{1, 2}}, {{1, 3}}, {{1, 7}}, {{1, 9}}, {{2, 4}}, {{2, 6}}, {{2, 8}}, {{3, 12}}, {{3, 13}}, {{3, 15}}, {{4, 11}}, {{4, 15}}, 
  {{4, 16}}, {{5, 7}}, {{5, 8}}, {{5, 12}}, {{5, 17}}, {{6, 17}}, {{6, 19}}, {{6, 20}}, {{7, 19}}, {{7, 21}}, {{8, 10}}, {{8, 22}}, 
  {{9, 11}}, {{9, 18}}, {{9, 20}}, {{10, 16}}, {{10, 19}}, {{10, 23}}, {{11, 22}}, {{11, 23}}, {{12, 14}}, {{12, 18}}, {{13, 16}}, 
  {{13, 21}}, {{13, 25}}, {{14, 16}}, {{14, 22}}, {{14, 24}}, {{15, 20}}, {{15, 24}}, {{17, 24}}, {{17, 26}}, {{18, 21}}, {{18, 26}}, 
  {{19, 25}}, {{20, 27}}, {{21, 23}}, {{22, 26}}, {{23, 27}}, {{24, 25}}, {{25, 27}}, {{26, 27}}}, 
 {{{0.008092300000000002, 0.04284658000000001}}, {{0.010751980000000003, 0.027773300000000008}}, {{0.015743769999999997, 0.05610285}}, 
  {{0.018402880000000003, 0.041031200000000004}}, {{0.019817140000000004, 0.033010170000000005}}, {{0.02247485, 0.037616109999999994}}, 
  {{0.02247522, 0.048084770000000006}}, {{0.022478240000000003, 0.017936220000000003}}, {{0.023399410000000002, 0.04285122}}, 
  {{0.025131729999999998, 0.03301156}}, {{0.026056450000000002, 0.027774900000000005}}, {{0.027472659999999996, 0.04626718999999999}}, 
  {{0.03012612, 0.06133957}}, {{0.030126689999999998, 0.031192000000000004}}, {{0.03012879, 0.0508704}}, 
  {{0.03278887, 0.046265820000000006}}, {{0.034201169999999996, 0.027774900000000005}}, {{0.03512261, 0.033008920000000004}}, 
  {{0.03686024, 0.04284762}}, {{0.0377819, 0.03761211}}, {{0.03778232, 0.048084770000000006}}, {{0.03778425, 0.017938000000000003}}, 
  {{0.04044043, 0.033010160000000004}}, {{0.041854670000000004, 0.041031200000000004}}, {{0.04450975000000001, 0.05610631}}, 
  {{0.04950826, 0.02777789}}, {{0.052164329999999995, 0.04285171}}}];

v=Vertices[g2];

v2=(#-Mean[v])&/@v

GraphPlot[g2,Method->None,ImageSize->200]

Sort[Norm/@pts//N]

rA=Sin[1/2*(Pi-2*k/n*Pi)]/Sin[k*2*Pi/n]/.{n->9,k->2};
rB=-Sin[1/2*(Pi-2*k/n*Pi)]/Sin[k*2*Pi/n]/.{n->9,k->4};
rD=Sin[1/2*(Pi-2*k/n*Pi)]/Sin[k*2*Pi/n]/.{n->9,k->1};
pts={{rA*Sin[0],rA*Cos[0]},
{rA*Sin[2*Pi/9],rA*Cos[2*Pi/9]},
{rA*Sin[2*2*Pi/9],rA*Cos[2*2*Pi/9]},
{rA*Sin[3*2*Pi/9],rA*Cos[3*2*Pi/9]},
{rA*Sin[4*2*Pi/9],rA*Cos[4*2*Pi/9]},
{rA*Sin[5*2*Pi/9],rA*Cos[5*2*Pi/9]},
{rA*Sin[6*2*Pi/9],rA*Cos[6*2*Pi/9]},
{rA*Sin[7*2*Pi/9],rA*Cos[7*2*Pi/9]},
{rA*Sin[8*2*Pi/9],rA*Cos[8*2*Pi/9]},
{rB*Sin[0],rB*Cos[0]},
{rB*Sin[2*Pi/9],rB*Cos[2*Pi/9]},
{rB*Sin[2*2*Pi/9],rB*Cos[2*2*Pi/9]},
{rB*Sin[3*2*Pi/9],rB*Cos[3*2*Pi/9]},
{rB*Sin[4*2*Pi/9],rB*Cos[4*2*Pi/9]},
{rB*Sin[5*2*Pi/9],rB*Cos[5*2*Pi/9]},
{rB*Sin[6*2*Pi/9],rB*Cos[6*2*Pi/9]},
{rB*Sin[7*2*Pi/9],rB*Cos[7*2*Pi/9]},
{rB*Sin[8*2*Pi/9],rB*Cos[8*2*Pi/9]},
{rD*Sin[0*2*Pi/9],rD*Cos[0*2*Pi/9]},
{rD*Sin[1*2*Pi/9],rD*Cos[1*2*Pi/9]},
{rD*Sin[2*2*Pi/9],rD*Cos[2*2*Pi/9]},
{rD*Sin[3*2*Pi/9],rD*Cos[3*2*Pi/9]},
{rD*Sin[4*2*Pi/9],rD*Cos[4*2*Pi/9]},
{rD*Sin[5*2*Pi/9],rD*Cos[5*2*Pi/9]},
{rD*Sin[6*2*Pi/9],rD*Cos[6*2*Pi/9]},
{rD*Sin[7*2*Pi/9],rD*Cos[7*2*Pi/9]},
{rD*Sin[8*2*Pi/9],rD*Cos[8*2*Pi/9]}
};

Graphics[{PointSize[.02],Red,Point[pts]},ImageSize->200]

GraphData["DoyleGraph","Classes"]

Through[{QuarticQ,SymmetricGraphQ}[g2]]

RecognizeGraph[g2]

GetGraphData["DoyleGraph","File"]

Mean[v]

Max[Norm/@v2]

1.4619022000815438`/0.022375982737812338`

Sort[65.33354164646944`Norm/@v2]

pts2=Nearest[pts,#,1][[1]]&/@(65.33354164646944`v2)

pts2={{-Cos[(π/18)] Cos[(π/9)] Csc[((2 π)/9)],Cos[(π/9)] Csc[((2 π)/9)] Sin[(π/18)]},{-(1/2) (Sqrt[3]) Cos[(π/9)] Csc[((2 π)/9)],-(1/2) Cos[(π/9)] Csc[((2 π)/9)]},{-Cos[(π/9)],Cos[(π/9)] Cot[((2 π)/9)]},{-Cos[((2 π)/9)],Cos[((2 π)/9)] Tan[(π/18)]},{-(1/2) (Sqrt[3]) Cos[((2 π)/9)] Sec[(π/18)],-(1/2) Cos[((2 π)/9)] Sec[(π/18)]},{-Cos[(π/18)] Csc[(π/9)] Sin[(π/18)],-Csc[(π/9)] ((Sin[(π/18)])^2)},{-Cos[((2 π)/9)] Sec[(π/18)] Sin[((2 π)/9)],((Cos[((2 π)/9)])^2) Sec[(π/18)]},{-Cos[(π/9)] Csc[((2 π)/9)] Sin[(π/9)],-((Cos[(π/9)])^2) Csc[((2 π)/9)]},{-(1/2) (Sqrt[3]) Csc[(π/9)] Sin[(π/18)],(1/2) Csc[(π/9)] Sin[(π/18)]},{-Csc[(π/9)] Sin[(π/18)] Sin[((2 π)/9)],-Cos[((2 π)/9)] Csc[(π/9)] Sin[(π/18)]},{-Cos[((2 π)/9)] Sec[(π/18)] Sin[(π/9)],-Cos[(π/9)] Cos[((2 π)/9)] Sec[(π/18)]},{-Sin[(π/18)],Cot[(π/9)] Sin[(π/18)]},{0,Cos[(π/9)] Csc[((2 π)/9)]},{0,-Csc[(π/9)] Sin[(π/18)]},{0,Cos[((2 π)/9)] Sec[(π/18)]},{Sin[(π/18)],Cot[(π/9)] Sin[(π/18)]},{Cos[((2 π)/9)] Sec[(π/18)] Sin[(π/9)],-Cos[(π/9)] Cos[((2 π)/9)] Sec[(π/18)]},{Csc[(π/9)] Sin[(π/18)] Sin[((2 π)/9)],-Cos[((2 π)/9)] Csc[(π/9)] Sin[(π/18)]},{(1/2) (Sqrt[3]) Csc[(π/9)] Sin[(π/18)],(1/2) Csc[(π/9)] Sin[(π/18)]},{Cos[(π/18)] Csc[(π/9)] Sin[(π/18)],-Csc[(π/9)] ((Sin[(π/18)])^2)},{Cos[((2 π)/9)] Sec[(π/18)] Sin[((2 π)/9)],((Cos[((2 π)/9)])^2) Sec[(π/18)]},{Cos[(π/9)] Csc[((2 π)/9)] Sin[(π/9)],-((Cos[(π/9)])^2) Csc[((2 π)/9)]},{(1/2) (Sqrt[3]) Cos[((2 π)/9)] Sec[(π/18)],-(1/2) Cos[((2 π)/9)] Sec[(π/18)]},{Cos[((2 π)/9)],Cos[((2 π)/9)] Tan[(π/18)]},{Cos[(π/9)],Cos[(π/9)] Cot[((2 π)/9)]},{(1/2) (Sqrt[3]) Cos[(π/9)] Csc[((2 π)/9)],-(1/2) Cos[(π/9)] Csc[((2 π)/9)]},{Cos[(π/18)] Cos[(π/9)] Csc[((2 π)/9)],Cos[(π/9)] Csc[((2 π)/9)] Sin[(π/18)]}};

Graphics[Point[pts2]]

RecognizeGraph[ChangeVertices[g2,pts2]]

GraphPlot[ChangeVertices[g2,pts2],Method->None]

new=FullSimplify[ToCommonEdges[ChangeVertices[g2,pts2],Graph["DoyleGraph"]]]

GetGraphData["DoyleGraph","File"]

ReplacePart[GraphData["DoyleGraph","Embeddings"],2->new]

Torus embedding

Original photo

From Peter Doyle, Oct. 21, 2021

As an offset grid graph

From Ed Pegg, Jr.
Oct 22, 2021

Seems doable with a toroidal type embedding.  I should make a proper function for them.
https://demonstrations.wolfram.com/EmbeddingsOfGraphsInATorusAndInAMoebiusStrip/ has a nice interface, I should put the Doyle graph into that.
The attached shows it's fairly straightforward ... in the standard embedding with nested 9-cycles, just move the cycles to be top / center / bottom and things line up.  But it needs more clean-up to account for toroidal wrapping.

plot=;

Offset grid

g0=GraphicsToGraph[plot,VertexLabels->Automatic]

RecognizeGraph[g0]

v=GraphEmbedding[g0]

(#-Mean[v])&/@v

MinMax[%37]

Mean[Abs[%]]

newv=Round[(#-Mean[v])/2&/@v,1/10]

MapIndexed[{#2[[1]],#}&,newv]

gridv=With[{t=1/10},
{{1,{-(11/10),(1/10)}},{2,{-1-t,1+t}},{3,{-(11/10),-1-t}},{4,{0-t,1+t}},{5,{1,-(9/10)}},{6,{1,0}},{7,{t,(1/10)}},{8,{-(1/10),-(9/10)}},{9,{-(9/10),-(9/10)}},{10,{(9/10),1+t}},{11,{1+t,(4/5)+t}},{12,{0,-(11/10)}},{13,{0,0}},{14,{-1,1}},{15,{1+t,(1/10)}},{16,{(9/10),-1}},{17,{0,(9/10)+t}},{18,{(1/10),(4/5)+t}},{19,{-(9/10),-t}},{20,{9/10,-(11/10)}},{21,{9/10,-(1/10)}},{22,{-t,-t}},{23,{(1/10),-1}},{24,{1,(9/10)+t}},{25,{-1,0}},{26,{-(9/10),(4/5)+t}},{27,{-1,-1}}}];
g=Graph[Range[27],EdgeList[g0],VertexCoordinates->gridv[[All,2]],VertexLabels->Automatic]

GraphEmbedding[g]

As a (degenerate) grid graph

MinMax[v]

newv=Round[(#-Mean[v])/2&/@v]

g=Graph[Range[27],EdgeList[g0],VertexCoordinates->newv]

RecognizeGraph[g]

Subgraph of {"Hamming", {3, 3}} (gives both Tan and a new V-E degenerate embedding)

E. Weisstein, Oct. 26, 2023

g1=LabelGraph@CenterGraph@

Length/@(sets={{15,18,27,21,4,9,6,17,3},{19,10,8,1,24,12,25,11,23},{22,2,16,13,14,5,7,26,20}})

Mod[Subtract@@@#&/@(Partition[#,2,1,1]&/@Map[ArcTan@@v1[[#]]&,sets,{2}]),2Pi]

{a,b,c}=Mean[Norm/@v1[[#]]]&/@sets

v=Join[CirclePoints[{a,Pi/2},9],CirclePoints[{b,Pi/2},9],CirclePoints[{c,-Pi/2},9]];

ee=List@@@UnitEdges[v,Tolerance->.01]

g1=Graph[Range@Length@v,UndirectedEdge@@@ee,VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@g1

hamming=GraphData[{"Hamming",{3,3}},"Graph","UnitDistance"][[1]]

RecognizeGraph@hamming

ee1=Complement[
ee,
Sort/@Partition[Range[9],2,1,1],
Sort/@Partition[{10,17,15,13,11,18,16,14,12},2,1,1],
Sort/@Partition[{19,23,27,22,26,21,25,20,24},2,1,1]
]

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

RecognizeGraph@g

DegenerateGraphEmbeddingTypes[g]

v=Join[CirclePoints[{a,Pi/2},9],CirclePoints[{b,Pi/2},9],CirclePoints[{c,-Pi/2},9]];

ee=EdgeList[g];

eqn=UnitEdgeEquations[v,ee]//RootReduce//FullSimplify//Union

soln=Solve[eqn,{a,b,c},Reals]

Graph[Range[27],ee,VertexCoordinates->(v/.#)]&/@soln

(vsimp=Map[ToAlgebraicRoot,v/.soln[[1]],{2}])//Timing

g=Graph[Range[27],ee,VertexCoordinates->vsimp]

GraphData

GraphClasses

GraphClassString["DoyleGraph"]

GraphDataString

GraphDataString[g,
"StandardName"->{"QuarticSymmetric",{27,1}},
"Name"->"27-quartic symmetric graph 1",
Debug->True,
TimeConstraint->600,
"Information"->"DoyleGraph"
]