Uniquely Pancyclic Graph

Author

Eric W. Weisstein
August 25, 2022

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

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

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

Figure

up=SortBy[GraphData["UniquelyPancyclic"],GraphData[#,"V"]&]

GraphicsGrid[Partition[
Show[StyleGraphs[GraphData[#],VertexSize->{"Scaled",.05}],PlotLabel->TextCell[Style[GraphData[#,"Name"],Directive[Black,14,Italic,FontFamily->"Times"]],TextAlignment->Center,PageWidth->100]]&/@up,UpTo[4]],Dividers->All,ImageSize->500,Alignment->Center]

Embeddings

{"UniquelyPancyclic", {14, 1}}

GraphData[{"UniquelyPancyclic",{14,1}},"StandardName"]

Primary

GraphData[{"UniquelyPancyclic",{14,1}}]//StyleGraphs

All

GraphData[{"UniquelyPancyclic",{14,1}},"Graph","All"]//StyleGraphs

Inexact

Select[GraphData[{"UniquelyPancyclic",{14,1}},"Graph","All"],(!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&)]//StyleGraphs

Embedding types

GraphDataEmbeddings[GraphData[{"UniquelyPancyclic",{14,1}},"EdgeList"]]

Default embedding

GraphPlot@GraphData[{"UniquelyPancyclic",{14,1}},"Edges"]

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

RecognizeGraph[g]

Degenerate

GraphData[{"UniquelyPancyclic",{14,1}},"Graph","Degenerate"]//StyleGraphs

Bilateral

GraphData[{"UniquelyPancyclic",{14,1}},"Graph","Bilateral"]//StyleGraphs

Circular

GraphData[{"UniquelyPancyclic",{14,1}},"Graph","Circular"]//StyleGraphs

Circular construction

Length[hc=FindHamiltonianCycle[GraphData[{"UniquelyPancyclic",{14,1}}],All][[All,All,1]]]

Length[bilat=DeleteDuplicatesBy[
DeleteMissing[BilaterallyRotatedGraph@CircularEmbeddingFromHamiltonianCycle[GraphData[{"UniquelyPancyclic",{14,1}}],#]&/@hc],
CircularCanonicalGraphEmbedding]]//Timing

Planar

GraphData[{"UniquelyPancyclic",{14,1}},"Planar"]

GraphData[{"UniquelyPancyclic",{14,1}},"Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData[{"UniquelyPancyclic",{14,1}},{"RCN","CN"}]

GraphData[{"UniquelyPancyclic",{14,1}},"Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

GraphPlot[MinimalCrossingGraph[GraphData[{"UniquelyPancyclic",{14,1}}],"CrossingNumber"->0]]

RecognizeGraph[g]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData[{"UniquelyPancyclic",{14,1}},"Graph","Circulant"]//StyleGraphs

Halin

GraphData[{"UniquelyPancyclic",{14,1}},"Halin"]

GraphData[{"UniquelyPancyclic",{14,1}},"Graph","Halin"]//StyleGraphs

LCF

GraphData[{"UniquelyPancyclic",{14,1}},"LCF"]

GraphData[{"UniquelyPancyclic",{14,1}},"LCFSignature"]

GraphData[{"UniquelyPancyclic",{14,1}},"Graph","LCF"]//StyleGraphs

UnitDistance

GraphData[{"UniquelyPancyclic",{14,1}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"UniquelyPancyclic",{14,1}}],Debug->True]//Timing

GraphData[{"UniquelyPancyclic",{14,1}},"Graph","UnitDistance"]//StyleGraphs

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

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

FindUnitDistanceEmbedding[GraphData[{"UniquelyPancyclic",{14,1}}],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

Exact UnitDistance construction 1

LabelGraph@

v=UnitCirclePoints[9];
v=Join[v,{UnitDistancePoint[Sequence@@v[[{4,5}]],1]}];
ee=UnitEdges[v];
g=Graph[Range[Length[v]],ee,VertexCoordinates->v,VertexLabels->Automatic]

v=Join[v,{{x,y},{a,b},2{a,b}-{x,y},v[[10]]+{a,b}-{x,y}}];

eqn1=FullSimplify@RootReduce@{
SquaredEuclideanDistance[v[[6]],{x,y}]==1,
SquaredEuclideanDistance[{x,y},{a,b}]==1,
SquaredEuclideanDistance[v[[10]],{a,b}]==1,
SquaredEuclideanDistance[{x,y},v[[5]]]==1}/.Abs->Identity

Hangs:

Solve[eqn1,{x,y,a,b},Reals];//Timing

soln=NSolve[eqn1,{x,y,a,b},Reals,WorkingPrecision->10000];//Timing

gs=Graph[Range[Length[v]],Complement[UnitEdges[v/.#],{5\[UndirectedEdge]11}],VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@N[soln]

RecognizeGraph/@gs

soln[[1]]//N

{x0,y0,a0,b0}=RootApproximant[N[{x,y,a,b}/.soln[[1]],5000],16]

N[{x0,y0,a0,b0}-({x,y,a,b}/.soln[[1]]),10^4]

v1=v/.Thread[{x,y,a,b}->{x0,y0,a0,b0}]//FullSimplify

g1=Graph[Range[Length[v]],Complement[UnitEdges[v1],{5\[UndirectedEdge]11}],VertexCoordinates->v1,VertexLabels->Automatic]

RecognizeGraph[g1]

UnitDistanceGraphEmbeddingQ[g1,WorkingPrecision->Infinity]

rt=RightAngleEquation[v,{12,10,14}]//RootReduce//FullSimplify

eqn2=RootReduce@{
SquaredEuclideanDistance[v[[6]],{x,y}]==1,
SquaredEuclideanDistance[{x,y},{a,b}]==1,
SquaredEuclideanDistance[v[[10]],{a,b}]==1,
rt}/.Abs->Identity

Hangs:

Solve[eqn2,{x,y,a,b},Reals];

soln2=NSolve[eqn2,{x,y,a,b},Reals,WorkingPrecision->10000];

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

RecognizeGraph/@gs

soln2[[2]]//N

{x0,y0,a0,b0}=RootApproximant[N[{x,y,a,b}/.soln2[[2]],5000],16]

N[{x0,y0,a0,b0}-({x,y,a,b}/.soln2[[2]]),10^4]

v2=v/.Thread[{x,y,a,b}->{x0,y0,a0,b0}]//FullSimplify

g2=Graph[Range[Length[v]],Complement[UnitEdges[v2],{5\[UndirectedEdge]11}],VertexCoordinates->v2,VertexLabels->Automatic]

RecognizeGraph[g2]

gs={g1,g2}

Exact UnitDistance construction 2

e[[1]]

GraphData[gn,{"#","V","RCN","Planar"}]

GraphData[gn,"EmbeddingClasses"]

GraphData[gn,"Graphics"]

GraphPlot[g=System`Graph[GraphData[gn,"EdgeList"]]]

v[[10]]+RotationMatrix[π/2].(v[[10]]-v[[5]])//FullSimplify

π-PlanarAngle[v[[6]]->v[[{5,7}]]]//FullSimplify

v[[6]]+RotationMatrix[2 2π/9].(v[[5]]-v[[6]])//FullSimplify

N[%]

EuclideanDistance@@v[[{11,12}]]//N

eqns={SquaredEuclideanDistance[{x1,y1},v[[6]]]==1,SquaredEuclideanDistance[{x2,y2},v[[10]]]==1,(x1-x2)^2+(y1-y2)^2==1,({x2,y2}-v[[10]]).(v[[10]]-v[[5]])=={x1-x2,y1-y2}.({x2,y2}-v[[10]])}/.Abs[x_]^2:>x^2

eqns//RootReduce//FullSimplify

eqns={(((x1+Root[-1-6 #1+8 ((#1)^3)&,3]))^2)+(((y1+Root[-1+60 ((#1)^2)-288 ((#1)^4)+192 ((#1)^6)&,1]))^2)==1,(((x2+Root[-1-6 #1+8 ((#1)^3)&,1]))^2)+(((y2+Root[-1+60 ((#1)^2)-864 ((#1)^4)+192 ((#1)^6)&,1]))^2)==1,(((x1-x2))^2)+(((y1-y2))^2)==1,x1 (x2+Root[-1-6 #1+8 ((#1)^3)&,1])+y2 (y1-y2+Root[-1+6 ((#1)^2)-9 ((#1)^4)+3 ((#1)^6)&,6])+y1 Root[-1+60 ((#1)^2)-864 ((#1)^4)+192 ((#1)^6)&,1]==(x2^2)+Root[3+18 #1+24 ((#1)^2)+8 ((#1)^3)&,1]};

solns=({{x1,y1},{x2,y2}}/.NSolve[eqns,{x1,x2,y1,y2},Reals,WorkingPrecision->100])

solns//N

Graphics[{Point[Join[CirclePoints[Csc[Pi/9]/2,9],{{Root[1-6 #1+8 ((#1)^3)&,3],(1/2) Cos[(π/9)] ((Sqrt[3])+Cot[(π/9)])}}]],{Red,Map[Point,solns,{2}]}},Axes->True]

solns/.x_?NumericQ:>Sign[x]//Column

(soln=Solve[Join[eqns,{x1<0}],{x1,x2,y1,y2},Reals])//Timing

v[[12]]+RotationMatrix[π/2].(v[[10]]-v[[12]])

soln=Solve[eqns,{x1,x2,y1,y2},Reals]

GraphEmbedding[g]

RootApproximant[solns[[1]],8]

s=Sqrt[3]/2;
v=Join[CirclePoints[Csc[Pi/9]/2,9],{{Root[1-6 #1+8 ((#1)^3)&,3],(1/2) Cos[(π/9)] ((Sqrt[3])+Cot[(π/9)])},
Sequence@@solns[[1]],
v[[12]]+RotationMatrix[π/2].(v[[10]]-v[[12]]),
v[[10]]+RotationMatrix[π/2].(v[[10]]-v[[12]])
}];
g=System`Graph[Range[Length[v]],UndirectedEdge@@@Sort[Sort/@{Sequence@@Partition[Range[9],2,1,1],{5,10},{4,10},{6,11},{11,12},{10,12},{12,13},{13,14},{10,14}}],VertexCoordinates->(v/.x_?InexactNumberQ:>N[x]),VertexLabels->"Name"]

Remaining points

e=GraphData[{"UniquelyPancyclic",{14,1}},"Embeddings","UnitDistance"][[1]]

Position[e,_?InexactNumberQ]

HighlightGraph[GraphData[{"UniquelyPancyclic",{14,1}},"Graph",{"UnitDistance","Labeled"}][[1]],Position[e,_?InexactNumberQ][[All,1]]//Flatten]

eqns={SquaredEuclideanDistance[e[[6]],{x5,y5}]-1,SquaredEuclideanDistance[{x5,y5},{x4,y4}]-1,SquaredEuclideanDistance[e[[1]],{x4,y4}]-1}/.Abs[x_]^2:>x^2

NSolve[eqns,{x4,y4,x5,y5}]

UnitDistance FindSubgraphUnitDistanceEmbedding

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

gs=UniqueEmbeddings[l]

g=;

Matchstick

GraphData[{"UniquelyPancyclic",{14,1}},"Matchstick"]

GraphData[{"UniquelyPancyclic",{14,1}},"Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData[{"UniquelyPancyclic",{14,1}},"Edges"]]

3D All

GraphData[{"UniquelyPancyclic",{14,1}},"Graph",{"3D","All"}]

3D UnitDistance

GraphData[{"UniquelyPancyclic",{14,1}},"Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData[{"UniquelyPancyclic",{14,1}},"Polyhedral"]

GraphData[{"UniquelyPancyclic",{14,1}},"Graph",{"3D","Polyhedron"}]

{"UniquelyPancyclic", {14, 2}}

GraphData[{"UniquelyPancyclic",{14,2}},"StandardName"]

Primary

GraphData[{"UniquelyPancyclic",{14,2}}]//StyleGraphs

Default embedding

GraphPlot@GraphData[{"UniquelyPancyclic",{14,2}},"Edges"]

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

RecognizeGraph[g]

All

GraphData[{"UniquelyPancyclic",{14,2}},"Graph","All"]//StyleGraphs

Degenerate

GraphData[{"UniquelyPancyclic",{14,2}},"Graph","Degenerate"]//StyleGraphs

Circular construction

Length[hc=FindHamiltonianCycle[GraphData[{"UniquelyPancyclic",{14,2}}],All][[All,All,1]]]

Length[bilat=DeleteDuplicatesBy[
DeleteMissing[BilaterallyRotatedGraph@CircularEmbeddingFromHamiltonianCycle[GraphData[{"UniquelyPancyclic",{14,2}}],#]&/@hc],
CircularCanonicalGraphEmbedding]]//Timing

Planar

GraphData[{"UniquelyPancyclic",{14,2}},"Planar"]

GraphData[{"UniquelyPancyclic",{14,2}},"Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData[{"UniquelyPancyclic",{14,2}},{"RCN","CN"}]

GraphData[{"UniquelyPancyclic",{14,2}},"Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

GraphPlot[MinimalCrossingGraph[GraphData[{"UniquelyPancyclic",{14,2}}],"CrossingNumber"->1]]

RecognizeGraph[g]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData[{"UniquelyPancyclic",{14,2}},"Graph","Circulant"]//StyleGraphs

Halin

GraphData[{"UniquelyPancyclic",{14,2}},"Halin"]

GraphData[{"UniquelyPancyclic",{14,2}},"Graph","Halin"]//StyleGraphs

LCF

GraphData[{"UniquelyPancyclic",{14,2}},"LCF"]

GraphData[{"UniquelyPancyclic",{14,2}},"LCFSignature"]

GraphData[{"UniquelyPancyclic",{14,2}},"Graph","LCF"]//StyleGraphs

UnitDistance

GraphData[{"UniquelyPancyclic",{14,2}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"UniquelyPancyclic",{14,2}}],Debug->True]//Timing

GraphData[{"UniquelyPancyclic",{14,2}},"Graph","UnitDistance"]//StyleGraphs

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

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

FindUnitDistanceEmbedding[GraphData[{"UniquelyPancyclic",{14,2}}],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

Exact UnitDistance construction 1

GraphData[gn={"UniquelyPancyclic",{14,2}},{"#","V","RCN","Planar"}]

GraphData[gn,"EmbeddingClasses"]

GraphData[gn,"Graphics"]

GraphPlot[g=System`Graph[GraphData[gn,"EdgeList"]]]

v[[10]]+RotationMatrix[π/2].(v[[10]]-v[[5]])//FullSimplify

π-PlanarAngle[v[[6]]->v[[{5,7}]]]//FullSimplify

v[[6]]+RotationMatrix[2 2π/9].(v[[5]]-v[[6]])//FullSimplify

N[%]

EuclideanDistance@@v[[{11,12}]]//N

eqns={SquaredEuclideanDistance[{x1,y1},v[[6]]]==1,SquaredEuclideanDistance[{x2,y2},v[[10]]]==1,(x1-x2)^2+(y1-y2)^2==1,({x2,y2}-v[[10]]).(v[[10]]-v[[5]])=={x1-x2,y1-y2}.({x2,y2}-v[[10]])}/.Abs[x_]^2:>x^2

eqns//RootReduce//FullSimplify

Solve[(((x1-x2))^2)+(((y1-y2))^2)==1,y2]

solns=({{x1,y1},{x2,y2}}/.NSolve[eqns,{x1,x2,y1,y2},Reals,WorkingPrecision->100])

v[[12]]+RotationMatrix[π/2].(v[[10]]-v[[12]])

soln=Solve[eqns,{x1,x2,y1,y2},Reals]

GraphEmbedding[g]

RootApproximant[solns[[1]],8]

s=Sqrt[3]/2;
v=Join[CirclePoints[Csc[Pi/9]/2,9],{{Root[1-6 #1+8 ((#1)^3)&,3],(1/2) Cos[(π/9)] ((Sqrt[3])+Cot[(π/9)])},
Sequence@@solns[[1]],
v[[12]]+RotationMatrix[-π/2].(v[[11]]-v[[12]]),
v[[11]]+RotationMatrix[-π/2].(v[[11]]-v[[12]])
}];
g=System`Graph[Range[Length[v]],UndirectedEdge@@@Sort[Sort/@{Sequence@@Partition[Range[9],2,1,1],{5,10},{4,10},{6,11},{11,12},{10,12},{12,13},{13,14},{11,14}}],VertexCoordinates->(v/.x_?InexactNumberQ:>N[x]),VertexLabels->"Name"]

UnitDistanceGraphQ[g]

r=RecognizeGraph[g]

rcn=RectilinearCrossingCount[g]

vs=ToCommonEdges[g,GraphData[r]]//FullSimplify

Exact UnitDistance construction 2

LabelGraph@

v=UnitCirclePoints[9];
v=Join[v,{UnitDistancePoint[Sequence@@v[[{4,5}]],1]}];
ee=UnitEdges[v];
g=Graph[Range[Length[v]],ee,VertexCoordinates->v,VertexLabels->Automatic]

v=Join[v,{{x,y},{a,b},{x,y}+{a,b}-v[[10]],2{a,b}-v[[10]]}];

eqn1=FullSimplify@RootReduce@{
SquaredEuclideanDistance[v[[6]],{x,y}]==1,
SquaredEuclideanDistance[{x,y},{a,b}]==1,
SquaredEuclideanDistance[v[[10]],{a,b}]==1,
SquaredEuclideanDistance[{x,y},v[[5]]]==1}/.Abs->Identity

Hangs:

Solve[eqn1,{x,y,a,b},Reals];//Timing

soln=NSolve[eqn1,{x,y,a,b},Reals,WorkingPrecision->10000];//Timing

gs=Graph[Range[Length[v]],Complement[UnitEdges[v/.#],{5\[UndirectedEdge]11}],VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@N[soln]

RecognizeGraph/@gs

soln[[1]]//N

{x0,y0,a0,b0}=RootApproximant[N[{x,y,a,b}/.soln[[1]],5000],16]

N[{x0,y0,a0,b0}-({x,y,a,b}/.soln[[1]]),10^4]

v1=v/.Thread[{x,y,a,b}->{x0,y0,a0,b0}]//FullSimplify

g1=Graph[Range[Length[v]],Complement[UnitEdges[v1],{5\[UndirectedEdge]11}],VertexCoordinates->v1,VertexLabels->Automatic]

RecognizeGraph[g1]

UnitDistanceGraphEmbeddingQ[g1,WorkingPrecision->Infinity]

rt=RightAngleEquation[v,{13,11,12}]//RootReduce//FullSimplify

eqn2=RootReduce@{
SquaredEuclideanDistance[v[[6]],{x,y}]==1,
SquaredEuclideanDistance[{x,y},{a,b}]==1,
SquaredEuclideanDistance[v[[10]],{a,b}]==1,
rt}/.Abs->Identity

Hangs:

Solve[eqn2,{x,y,a,b},Reals];

soln2=NSolve[eqn2,{x,y,a,b},Reals,WorkingPrecision->10000];

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

RecognizeGraph/@gs

soln2[[2]]//N

{x0,y0,a0,b0}=RootApproximant[N[{x,y,a,b}/.soln2[[2]],5000],16]

N[{x0,y0,a0,b0}-({x,y,a,b}/.soln2[[2]]),10^4]

v2=v/.Thread[{x,y,a,b}->{x0,y0,a0,b0}]

v2={{(1/2),-(1/2) Cot[(π/9)]},{(1/4) (Sqrt[3]) Csc[(π/9)],-(1/4) Csc[(π/9)]},{(1/2) Cos[(π/18)] Csc[(π/9)],(1/2) Csc[(π/9)] Sin[(π/18)]},{(1/2) Csc[(π/9)] Sin[((2 π)/9)],(1/2) Cos[((2 π)/9)] Csc[(π/9)]},{0,(1/2) Csc[(π/9)]},{-(1/2) Csc[(π/9)] Sin[((2 π)/9)],(1/2) Cos[((2 π)/9)] Csc[(π/9)]},{-(1/2) Cos[(π/18)] Csc[(π/9)],(1/2) Csc[(π/9)] Sin[(π/18)]},{-(1/4) (Sqrt[3]) Csc[(π/9)],-(1/4) Csc[(π/9)]},{-(1/2),-(1/2) Cot[(π/9)]},{(1/4) Csc[(π/9)] Sin[((2 π)/9)]-(-(1/2) Csc[(π/9)]+(1/2) Cos[((2 π)/9)] Csc[(π/9)]) (Sqrt[-(1/4)+(1/((((-(1/2) Csc[(π/9)]+(1/2) Cos[((2 π)/9)] Csc[(π/9)]))^2)+(1/4) ((Csc[(π/9)])^2) ((Sin[((2 π)/9)])^2)))]),(1/2) ((1/2) Csc[(π/9)]+(1/2) Cos[((2 π)/9)] Csc[(π/9)])+(1/2) Csc[(π/9)] Sin[((2 π)/9)] (Sqrt[-(1/4)+(1/((((-(1/2) Csc[(π/9)]+(1/2) Cos[((2 π)/9)] Csc[(π/9)]))^2)+(1/4) ((Csc[(π/9)])^2) ((Sin[((2 π)/9)])^2)))])},{(NumericalApproximation[Root, (RowDefault["-0.648", FEExpressionsNumericalApproximationElider]), Root[1-30 #1+24 ((#1)^2)+192 ((#1)^3)-144 ((#1)^4)-288 ((#1)^5)+192 ((#1)^6)&,1], ]),(NumericalApproximation[Root, (RowDefault["2.08", FEExpressionsNumericalApproximationElider]), Root[11881-139548 ((#1)^2)+574560 ((#1)^4)-1012992 ((#1)^6)+831744 ((#1)^8)-304128 ((#1)^10)+36864 ((#1)^12)&,12], ])},{(NumericalApproximation[Root, (RowDefault["0.0449", FEExpressionsNumericalApproximationElider]), Root[1-576 ((#1)^2)-2304 ((#1)^3)+69696 ((#1)^4)+476928 ((#1)^5)+138240 ((#1)^6)-3299328 ((#1)^7)-479232 ((#1)^8)+8699904 ((#1)^9)-4423680 ((#1)^10)-3538944 ((#1)^11)+2359296 ((#1)^12)&,7], ]),(NumericalApproximation[Root, (RowDefault["2.80", FEExpressionsNumericalApproximationElider]), Root[90037+303408 #1-1891680 ((#1)^2)-9627840 ((#1)^3)-2328768 ((#1)^4)+58569984 ((#1)^5)+131767296 ((#1)^6)+104896512 ((#1)^7)-1069056 ((#1)^8)-47333376 ((#1)^9)-18579456 ((#1)^10)+3538944 ((#1)^11)+2359296 ((#1)^12)&,12], ])},{(NumericalApproximation[Root, (RowDefault["-0.648", FEExpressionsNumericalApproximationElider]), Root[1-30 #1+24 ((#1)^2)+192 ((#1)^3)-144 ((#1)^4)-288 ((#1)^5)+192 ((#1)^6)&,1], ])+(NumericalApproximation[Root, (RowDefault["0.0449", FEExpressionsNumericalApproximationElider]), Root[1-576 ((#1)^2)-2304 ((#1)^3)+69696 ((#1)^4)+476928 ((#1)^5)+138240 ((#1)^6)-3299328 ((#1)^7)-479232 ((#1)^8)+8699904 ((#1)^9)-4423680 ((#1)^10)-3538944 ((#1)^11)+2359296 ((#1)^12)&,7], ])-(1/4) Csc[(π/9)] Sin[((2 π)/9)]+(-(1/2) Csc[(π/9)]+(1/2) Cos[((2 π)/9)] Csc[(π/9)]) (Sqrt[-(1/4)+(1/((((-(1/2) Csc[(π/9)]+(1/2) Cos[((2 π)/9)] Csc[(π/9)]))^2)+(1/4) ((Csc[(π/9)])^2) ((Sin[((2 π)/9)])^2)))]),(1/2) (-(1/2) Csc[(π/9)]-(1/2) Cos[((2 π)/9)] Csc[(π/9)])+(NumericalApproximation[Root, (RowDefault["2.08", FEExpressionsNumericalApproximationElider]), Root[11881-139548 ((#1)^2)+574560 ((#1)^4)-1012992 ((#1)^6)+831744 ((#1)^8)-304128 ((#1)^10)+36864 ((#1)^12)&,12], ])+(NumericalApproximation[Root, (RowDefault["2.80", FEExpressionsNumericalApproximationElider]), Root[90037+303408 #1-1891680 ((#1)^2)-9627840 ((#1)^3)-2328768 ((#1)^4)+58569984 ((#1)^5)+131767296 ((#1)^6)+104896512 ((#1)^7)-1069056 ((#1)^8)-47333376 ((#1)^9)-18579456 ((#1)^10)+3538944 ((#1)^11)+2359296 ((#1)^12)&,12], ])-(1/2) Csc[(π/9)] Sin[((2 π)/9)] (Sqrt[-(1/4)+(1/((((-(1/2) Csc[(π/9)]+(1/2) Cos[((2 π)/9)] Csc[(π/9)]))^2)+(1/4) ((Csc[(π/9)])^2) ((Sin[((2 π)/9)])^2)))])},{2 (NumericalApproximation[Root, (RowDefault["0.0449", FEExpressionsNumericalApproximationElider]), Root[1-576 ((#1)^2)-2304 ((#1)^3)+69696 ((#1)^4)+476928 ((#1)^5)+138240 ((#1)^6)-3299328 ((#1)^7)-479232 ((#1)^8)+8699904 ((#1)^9)-4423680 ((#1)^10)-3538944 ((#1)^11)+2359296 ((#1)^12)&,7], ])-(1/4) Csc[(π/9)] Sin[((2 π)/9)]+(-(1/2) Csc[(π/9)]+(1/2) Cos[((2 π)/9)] Csc[(π/9)]) (Sqrt[-(1/4)+(1/((((-(1/2) Csc[(π/9)]+(1/2) Cos[((2 π)/9)] Csc[(π/9)]))^2)+(1/4) ((Csc[(π/9)])^2) ((Sin[((2 π)/9)])^2)))]),(1/2) (-(1/2) Csc[(π/9)]-(1/2) Cos[((2 π)/9)] Csc[(π/9)])+2 (NumericalApproximation[Root, (RowDefault["2.80", FEExpressionsNumericalApproximationElider]), Root[90037+303408 #1-1891680 ((#1)^2)-9627840 ((#1)^3)-2328768 ((#1)^4)+58569984 ((#1)^5)+131767296 ((#1)^6)+104896512 ((#1)^7)-1069056 ((#1)^8)-47333376 ((#1)^9)-18579456 ((#1)^10)+3538944 ((#1)^11)+2359296 ((#1)^12)&,12], ])-(1/2) Csc[(π/9)] Sin[((2 π)/9)] (Sqrt[-(1/4)+(1/((((-(1/2) Csc[(π/9)]+(1/2) Cos[((2 π)/9)] Csc[(π/9)]))^2)+(1/4) ((Csc[(π/9)])^2) ((Sin[((2 π)/9)])^2)))])}};

(v3=ToRadicals[v2]//RootReduce//FullSimplify)//Timing

g2=Graph[Range[Length[v3]],Complement[UnitEdges[v3],{5\[UndirectedEdge]11}],VertexCoordinates->v3,VertexLabels->Automatic]

RecognizeGraph[g2]

gs={g1,g2}

UnitDistance FindSubgraphUnitDistanceEmbedding

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

gs=UniqueEmbeddings[l]

gs={,,};

Matchstick

GraphData[{"UniquelyPancyclic",{14,2}},"Matchstick"]

GraphData[{"UniquelyPancyclic",{14,2}},"Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData[{"UniquelyPancyclic",{14,2}},"Edges"]]

3D All

GraphData[{"UniquelyPancyclic",{14,2}},"Graph",{"3D","All"}]

3D UnitDistance

GraphData[{"UniquelyPancyclic",{14,2}},"Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData[{"UniquelyPancyclic",{14,2}},"Polyhedral"]

GraphData[{"UniquelyPancyclic",{14,2}},"Graph",{"3D","Polyhedron"}]

{"UniquelyPancyclic", {14, 3}}

GraphData[{"UniquelyPancyclic",{14,3}},"StandardName"]

Primary

GraphData[{"UniquelyPancyclic",{14,3}}]//StyleGraphs

Default embedding

GraphPlot@GraphData[{"UniquelyPancyclic",{14,3}},"Edges"]

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

RecognizeGraph[g]

All

GraphData[{"UniquelyPancyclic",{14,3}},"Graph","All"]//StyleGraphs

Degenerate

GraphData[{"UniquelyPancyclic",{14,3}},"Graph","Degenerate"]//StyleGraphs

Circular construction

Length[hc=FindHamiltonianCycle[GraphData[{"UniquelyPancyclic",{14,3}}],All][[All,All,1]]]

Length[bilat=DeleteDuplicatesBy[
DeleteMissing[BilaterallyRotatedGraph@CircularEmbeddingFromHamiltonianCycle[GraphData[{"UniquelyPancyclic",{14,3}}],#]&/@hc],
CircularCanonicalGraphEmbedding]]//Timing

Planar

GraphData[{"UniquelyPancyclic",{14,3}},"Planar"]

GraphData[{"UniquelyPancyclic",{14,3}},"Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData[{"UniquelyPancyclic",{14,3}},{"RCN","CN"}]

GraphData[{"UniquelyPancyclic",{14,3}},"Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

g=RotateGraph[MinimalCrossingGraph[GraphData[{"UniquelyPancyclic",{14,3}}],"CrossingNumber"->-1]]

RecognizeGraph[g]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData[{"UniquelyPancyclic",{14,3}},"Graph","Circulant"]//StyleGraphs

Halin

GraphData[{"UniquelyPancyclic",{14,3}},"Halin"]

GraphData[{"UniquelyPancyclic",{14,3}},"Graph","Halin"]//StyleGraphs

LCF

GraphData[{"UniquelyPancyclic",{14,3}},"LCF"]

GraphData[{"UniquelyPancyclic",{14,3}},"LCFSignature"]

GraphData[{"UniquelyPancyclic",{14,3}},"Graph","LCF"]//StyleGraphs

UnitDistance

GraphData[{"UniquelyPancyclic",{14,3}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"UniquelyPancyclic",{14,3}}],Debug->True]//Timing

GraphData[{"UniquelyPancyclic",{14,3}},"Graph","UnitDistance"]//StyleGraphs

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

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

FindUnitDistanceEmbedding[GraphData[{"UniquelyPancyclic",{14,3}}],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

Exact UnitDistance construction 1

GraphData[gn={"UniquelyPancyclic",{14,3}},{"#","V","RCN","Planar"}]

GraphData[gn,"EmbeddingClasses"]

GraphData[gn,"Graphics"]

GraphPlot[g=System`Graph[GraphData[gn,"EdgeList"]]]

v[[10]]+RotationMatrix[π/2].(v[[10]]-v[[5]])//FullSimplify

π-PlanarAngle[v[[6]]->v[[{5,7}]]]//FullSimplify

v[[6]]+RotationMatrix[2 2π/9].(v[[5]]-v[[6]])//FullSimplify

N[%]

EuclideanDistance@@v[[{11,12}]]//N

eqns={SquaredEuclideanDistance[{x1,y1},v[[6]]]==1,SquaredEuclideanDistance[{x2,y2},v[[10]]]==1,(x1-x2)^2+(y1-y2)^2==1,({x2,y2}-v[[10]]).(v[[10]]-v[[5]])=={x1-x2,y1-y2}.({x2,y2}-v[[10]])}/.Abs[x_]^2:>x^2

eqns//RootReduce//FullSimplify

Solve[(((x1-x2))^2)+(((y1-y2))^2)==1,y2]

solns=({{x1,y1},{x2,y2}}/.NSolve[eqns,{x1,x2,y1,y2},Reals,WorkingPrecision->100])

v[[12]]+RotationMatrix[π/2].(v[[10]]-v[[12]])

soln=Solve[eqns,{x1,x2,y1,y2},Reals]

GraphEmbedding[g]

RootApproximant[solns[[1]],8]

s=Sqrt[3]/2;
v=Join[CirclePoints[Csc[Pi/9]/2,9],{{Root[1-6 #1+8 ((#1)^3)&,3],(1/2) Cos[(π/9)] ((Sqrt[3])+Cot[(π/9)])},
Sequence@@solns[[1]],
v[[6]]+RotationMatrix[-π/2].(v[[6]]-v[[11]]),
v[[11]]+RotationMatrix[-π/2].(v[[6]]-v[[11]])
}];
g=System`Graph[Range[Length[v]],UndirectedEdge@@@Sort[Sort/@{Sequence@@Partition[Range[9],2,1,1],{5,10},{4,10},{6,11},{11,12},{10,12},{6,13},{13,14},{11,14}}],VertexCoordinates->(v/.x_?InexactNumberQ:>N[x]),VertexLabels->"Name"]

UnitDistanceGraphQ[g]

r=RecognizeGraph[g]

rcn=RectilinearCrossingCount[g]

vs=ToCommonEdges[g,GraphData[r]]//FullSimplify

UnitDistanceConstruction 2

LabelGraph@

v=UnitCirclePoints[9];
v=Join[v,{UnitDistancePoint[Sequence@@v[[{4,5}]],1]}];
ee=UnitEdges[v];
g=Graph[Range[Length[v]],ee,VertexCoordinates->v,VertexLabels->Automatic]

v=Join[v,{{x,y},{a,b},{x,y}+{a,b}-v[[10]],v[[6]]+{a,b}-v[[10]]}];

eqn1=FullSimplify@RootReduce@{
SquaredEuclideanDistance[v[[6]],{x,y}]==1,
SquaredEuclideanDistance[{x,y},{a,b}]==1,
SquaredEuclideanDistance[v[[10]],{a,b}]==1,
SquaredEuclideanDistance[{x,y},v[[5]]]==1}/.Abs->Identity

Hangs:

Solve[eqn1,{x,y,a,b},Reals];//Timing

soln=NSolve[eqn1,{x,y,a,b},Reals,WorkingPrecision->10000];//Timing

gs=Graph[Range[Length[v]],Complement[UnitEdges[v/.#],{5\[UndirectedEdge]11,11\[UndirectedEdge]14}],VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@N[soln]

RecognizeGraph/@gs

soln[[1]]//N

{x0,y0,a0,b0}=RootApproximant[N[{x,y,a,b}/.soln[[1]],5000],16]

N[{x0,y0,a0,b0}-({x,y,a,b}/.soln[[1]]),10^4]

v1=v/.Thread[{x,y,a,b}->{x0,y0,a0,b0}]//FullSimplify

g1=Graph[Range[Length[v]],Complement[UnitEdges[v1],{5\[UndirectedEdge]11,11\[UndirectedEdge]14}],VertexCoordinates->v1,VertexLabels->Automatic]

RecognizeGraph[g1]

g=g1

UnitDistanceGraphEmbeddingQ[g1,WorkingPrecision->Infinity]

rt=RightAngleEquation[v,{14,13,11}]//RootReduce//FullSimplify

eqn2=RootReduce@{
SquaredEuclideanDistance[v[[6]],{x,y}]==1,
SquaredEuclideanDistance[{x,y},{a,b}]==1,
SquaredEuclideanDistance[v[[10]],{a,b}]==1,
rt}/.Abs->Identity

Hangs:

Solve[eqn2,{x,y,a,b},Reals];

soln2=NSolve[eqn2,{x,y,a,b},Reals,WorkingPrecision->10000];//Timing

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

RecognizeGraph/@gs

soln2[[4]]//N

{x0,y0,a0,b0}=RootApproximant[N[{x,y,a,b}/.soln2[[2]],5000],16]

N[{x0,y0,a0,b0}-({x,y,a,b}/.soln2[[2]]),10^4]

v2=v/.Thread[{x,y,a,b}->{x0,y0,a0,b0}]

g2=Graph[Range[Length[v]],Complement[UnitEdges[v2],{5\[UndirectedEdge]11}],VertexCoordinates->v2,VertexLabels->Automatic]

RecognizeGraph[g2]

gs={g1,g2}

UnitDistance FindSubgraphUnitDistanceEmbedding

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

gs=UniqueEmbeddings[l]

gs={,};

Matchstick

GraphData[{"UniquelyPancyclic",{14,3}},"Matchstick"]

GraphData[{"UniquelyPancyclic",{14,3}},"Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData[{"UniquelyPancyclic",{14,3}},"Edges"]]

3D All

GraphData[{"UniquelyPancyclic",{14,3}},"Graph",{"3D","All"}]

3D UnitDistance

GraphData[{"UniquelyPancyclic",{14,3}},"Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData[{"UniquelyPancyclic",{14,3}},"Polyhedral"]

GraphData[{"UniquelyPancyclic",{14,3}},"Graph",{"3D","Polyhedron"}]

Construction

http://math.fau.edu/locke/UPCGraph.htm

https://link.springer.com/chapter/10.1007/978-3-319-31951-3_ 5

https://www.sciencedirect.com/science/article/pii/0012365X86900786

http://isu.indstate.edu/ge/Graphs/PANCYCLIC/index.html

A graph is uniquely pancyclic if it contains exactly one cycle for each possible length (from 3 to the order of the graph). There are seven known graphs that are uniquely pancyclic. One of order 3, one of order 5, and the five graphs shown below (click on any of the thumbnails for a larger picture). Finding all such graphs is unsolved problem number 10 on the list contained in Graph Theory with Applications by Bondy and Murty.

GraphData

Select[GraphData["Pancyclic"],IntegerQ[(poly=GraphData[#,"CyclePolynomial"][x])/.x->1]&&Union[Drop[CoefficientList[poly,x],3]]=={1}&]

Search

Length/@Table[Graphs[n],{n,9}]

Table[Select[Graphs[n],UniquelyPancyclicGraphQ],{n,9}]

%/.g_Graph:>RecognizeGraph[g]

1: {8,3825}

g1=Graph[Range[8],UndirectedEdge@@@Join[Partition[Range[8],2,1,1],{{1,3},{1,6}}],VertexCoordinates->CirclePoints[{1,0},8],VertexLabels->"Name"]

RecognizeGraph[g1]

CyclePolynomial[g1,x]

PancyclicGraphQ[g1]

2: {8,6029}

g2=Graph[Range[8],UndirectedEdge@@@Join[Partition[Range[8],2,1,1],{{5,8},{1,3}}],VertexCoordinates->CirclePoints[{1,0},8],VertexLabels->"Name"]

RecognizeGraph[g2]

CyclePolynomial[g2,x]

PancyclicGraphQ[g2]

3: 14 nodes

g3=Graph[Range[14],UndirectedEdge@@@Join[Partition[Range[14],2,1,1],{{1,13},{6,14},{1,4}}],VertexCoordinates->CirclePoints[{1,π/2},14],VertexLabels->"Name"]

RecognizeGraph[g3]

CyclePolynomial[g3,x]

PancyclicGraphQ[g3]

4: 14 nodes

g4=Graph[Range[14],UndirectedEdge@@@Join[Partition[Range[14],2,1,1],{{1,13},{8,14},{9,12}}],VertexCoordinates->CirclePoints[{1,π/2},14],VertexLabels->"Name"]

RecognizeGraph[g4]

CyclePolynomial[g4,x]

PancyclicGraphQ[g4]

5: 14 nodes

g5=Graph[Range[14],UndirectedEdge@@@Join[Partition[Range[14],2,1,1],{{1,13},{8,11},{8,14}}],VertexCoordinates->CirclePoints[{1,π/2},14],VertexLabels->"Name"]

RecognizeGraph[g5]

CyclePolynomial[g5,x]

PancyclicGraphQ[g5]

GraphData

GraphDataString

Length[Graphs[8]]

file=OpenAppend["~/up.m"]

RecognizeGraph@LineGraph[Graphs[8][[3825]]]

WriteString[file,GraphDataString[g5,
"StandardName"->{"UniquelyPancyclic",{14,3}},
"Name"->"(14,3)\[Hyphen]uniquely pancyclic graph",
"Classes"->{"UniquelyPancyclic"},
"NotationRules"->{"UniquelyPancyclic"->{14,3}},
"Information"->"UniquelyPancyclicGraph",
"Embeddings"->{},
"Skip"->{"ComplementOddChordlessCycles"},
Debug->True,
TimeConstraint->60]]

Close[file]