Franklin Graph

Author

Eric W. Weisstein
March 1, 2024

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

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

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

Embeddings

<<MathWorld`Graphs`

Names

GraphData["FranklinGraph","StandardName"]

GraphData["FranklinGraph","StandardNames"]

Primary

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

Read and Wilson

All

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

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData["FranklinGraph","EdgeList"]]

Default embedding

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

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

RecognizeGraph[g]

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

RecognizeGraph[g]

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

RecognizeGraph[g]

GraphPlot@

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

RecognizeGraph@g

CVT construction

g=CubicVertexTransitiveGraph[12]

RecognizeGraph@g

Degenerate

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

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

GeneralizedHoneycombGraph construction

With[{n=12},Cases[Table[{k,g=GeneralizedHoneycombGraph[n,k],RecognizeGraph@g},{k,n-1}],{__,"FranklinGraph"}]]//Timing

g=GeneralizedHoneycombGraph[12,5]

RecognizeGraph@g

Bilateral

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

Circular

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

Planar

GraphData["FranklinGraph","Planar"]

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

MinimalCrossing

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

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

MinimalCrossing construction

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

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

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

faces=ReverseSort@SymmetricallyDistinctFaces[g]

Tally[ReverseSort[Length/@faces]]

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

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

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

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

Table[MinimalCrossingGraph[GraphData["FranklinGraph"],"CrossingNumber"->3,RandomSeed->i],{i,500}]//Union

GraphPlot@RotateGraph[,-Pi/2]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

GraphPlot@

Circulant

GraphData["FranklinGraph","Circulant"]

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

Line graph

GraphData["FranklinGraph","Line"]

LineGraphQ[GraphData["FranklinGraph"]]//Timing

RootGraph

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

RootGraph[GraphData["FranklinGraph"]]

Halin

GraphData["FranklinGraph","Halin"]

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

Rigid

GraphData["FranklinGraph","Rigid"]

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

Flexible

GraphData["FranklinGraph","Flexible"]

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

LCF

GraphData["FranklinGraph","LCF"]

GraphData["FranklinGraph","HamiltonianCycleCount"]

GraphData["FranklinGraph","LCFSignature"]

GraphData["FranklinGraph","LCFNotations"]

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

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

LCF compute all

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

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

lcf

LCFGraph@@@lcf//StyleGraphs

(gs=Flatten[{
(* all LCF's with order >1, sorted by order and with bilateral graphs first *)
Join[DeleteCases[#,{_Missing,_}][[All,1]],Cases[#,{_Missing,_}][[All,2]]]&/@Map[{BilateralLCFGraph@#,#}&,Map[LCFGraph@@#&,SplitBy[DeleteCases[lcf,{_,1}],Last],{2}],{2}],
(* order-1 bilateral only *)
DeleteMissing[BilateralLCFGraph@@@Cases[lcf,{_,1}]]}])//Timing

Length[gs]

UnitDistance

GraphData["FranklinGraph","UnitDistance"]

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

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

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

UnitDistance construction (Eric Weisstein, June–July 2021'ish)

FindUnitDistanceEmbedding[GraphData["FranklinGraph"],5000]//Timing

DeleteCases[FindUnitDistanceEmbedding[GraphData["FranklinGraph"],100],$Failed]//Quiet//Timing

g=RotateGraph[SetProperty[,VertexLabels->Automatic],{10,1}]

UnitDistanceEmbeddingRefine/@%

Select[%,UnitDistanceGraphEmbeddingQ]

GraphPlot[GraphData[{"CrossedPrism",6}]]

GraphPlot[GraphData[{"CrossedPrism",6},"EdgeList"]]

UnitDistanceEmbeddingRefine@GraphicsToGraph@%

UnitDistanceGraphEmbeddingQ@%

(ud=FindUnitDistanceEmbedding[GraphData[{"CrossedPrism",6}],MaxIterations->10000])//Timing

UnitDistanceGraphEmbeddingQ[ud]

Select[FindUnitDistanceEmbedding[GraphData[{"CrossedPrism",6}],50],UnitDistanceGraphEmbeddingQ]

v0=GraphEmbedding[g0];

None with straight-line triangular edges:

s=Sqrt[3]/2;
R[i_]:=RotationMatrix[2Pi i/3];
v={{0,0},{-1,0},{-1/2,s},{0,2s},R[1].{c,d},{a,b},{c,d},{1,0},{1/2,s},R[2].{a,b},R[2].{c,d},R[1].{a,b}};
ee=EdgeList[GraphData["FranklinGraph"]];
eqn=UnitEdgeEquations[v,ee]

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

Clear[c,e];
s=Sqrt[3]/2;
R[i_]:=RotationMatrix[2Pi i/3];
v={{a,b},R[1].{0,h},R[2].{a,b},{0,h},R[2].{e,f},{c,d},R[1].{e,f},R[2].{0,h},R[1].{a,b},R[2].{c,d},{e,f},R[1].{c,d}};
ee=EdgeList[GraphData["FranklinGraph"]];
eqn=UnitEdgeEquations[v,ee]//FullSimplify

Mean[v0[[{5,7,11}]]]-v0[[1]]

(nsoln=NSolve[Append[eqn,b==-62/100],{h,a,b,c,d,e,f},Reals])//Timing

gs=Select[Graph[Range[12],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@nsoln,UnitDistanceGraphEmbeddingQ]

Do[
(nsoln=NSolve[Append[eqn,b==b0],{h,a,b,c,d,e,f},Reals];
Print[{b0,Select[Graph[Range[12],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@nsoln,UnitDistanceGraphEmbeddingQ]}]
),{b0,-1,2,.1}];

Hangs:

(soln=Solve[Append[eqn,b==-1/2],{h,a,b,c,d,e,f},Reals])//Timing

(nsoln=NSolve[Append[eqn,b==-1/2],{h,a,b,c,d,e,f},Reals])//Timing

Select[Graph[Range[12],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@nsoln,UnitDistanceGraphEmbeddingQ]

gs={RotateGraph[,{4,5}],}

Square embedding:

squares=RightAngleEquation[v,#]&/@{{3,4,5},{12,11,2},{10,7,8}}//FullSimplify

(soln=Solve[Join[eqn,squares],{h,a,b,c,d,e,f},Reals])//Timing

Select[Graph[Range[12],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@nsoln,UnitDistanceGraphEmbeddingQ]

g=RotateGraph[,{6,3}]

Triangle embedding:

RegionDistance[Line[v[[{2,4}]]],v[[3]]]^2//FullSimplify

RegionDistance[Line[v[[{4,8}]]],v[[9]]]^2//FullSimplify

RegionDistance[Line[v[[{2,8}]]],v[[1]]]^2//FullSimplify

(#.#&/@v[[{5,7,11}]])//FullSimplify

(#.#&/@v[[{1,3,9}]])//FullSimplify

(#.#&/@v[[{10,6,12}]])//FullSimplify

horizontal=Equal@@v[[{11,12}]][[All,2]]//FullSimplify

(nsoln=NSolve[Join[eqn,{horizontal,2b+h==0}],{h,a,b,c,d,e,f},Reals,WorkingPrecision->20])//Timing

(nsoln=NSolve[Append[eqn,2b+h==0],{h,a,b,c,d,e,f},Reals])//Timing

Select[Graph[Range[12],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@nsoln,UnitDistanceGraphEmbeddingQ]

v1=GraphEmbedding[];

v1[[{11,12}]]

RegionDistance[Line[v1[[#]]],v1[[#2]]]&@@@{{{2,4},3},{{4,8},9},{{2,8},1}}

(soln=Solve[Join[eqn,{horizontal,2b+h==0}],{h,a,b,c,d,e,f},Reals]//FullSimplify)//Timing

gs=Select[Graph[Range[12],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@soln,UnitDistanceGraphEmbeddingQ]

g=

GraphEmbedding[g][[{2,8}]][[All,2]]

RotateGraph[LabelGraph@,{2,12}]

g0=CenterGraph[]

v0=GraphEmbedding[g0];

v0[[1,2]]-v0[[2,2]]

Clear[e];

v={{0,y},{-x,0},{a,b},{-g,h},{-a,-b},{g,-h},{-e,-f},{c,-d},{e,f},{-c,d},{0,-y},{x,0}};
ee=EdgeList[GraphData["FranklinGraph"]];
eqn=UnitEdgeEquations[v,ee]

soln=Solve[Join[eqn,{a==c,b==d,e==g,f==h}],{a,b,c,d,e,f,g,h,x,y},Reals]//RootReduce

Select[Graph[Range[12],ee,VertexCoordinates->(v/.#),VertexLabels->Automatic]&/@soln,UnitDistanceGraphEmbeddingQ]

gs={,}

UnitDistanceGraphEmbeddingQ/@gs

RecognizeGraph/@gs

UnitDistance construction (Jeremy Tan, Oct 20, 2021) [same as Eric's]

2nd UD embedding Independently found by Jeremy Tan Oct 20, 2012ish

(*Both cu functions below construct their point to the left of the vector from x to y. cu[x,y] is a terser form of cu[x,y,1,1]*)
cu[x_,y_]:=(x+y)/2+Sqrt[Norm[y-x]^2/4-1]Normalize[y-x]

cu[x_,y_,rx_,ry_]:=Module[{d,ϕ,θ},
{d,ϕ}=ToPolarCoordinates[ReIm[y-x]];θ=ArcCos[(rx^2-ry^2+d^2)/(2d rx)];x+rx Exp[I(ϕ+θ)]]

vertices=ReIm/@Module[{s1,s2,s3,third},
s2=Root[9#^4-15#^3+16#^2-15#+9&,4];s3=Sqrt[-3];s1=RootReduce[cu[s2,s3]];third={s3,s1,s2,0}-s3/3;
RootReduce[Flatten[Table[third Exp[2I k Pi/3],{k,0,2}]]]]//RootReduce

Exactly the same vertices!:

Sort[GraphEmbedding[GraphData["FranklinGraph","Graph","UnitDistance"][[2]]]]===Sort[vertices]

edges=UnitEdges[franklinvertices]

g=Graph[Range[Length[vertices]],edges,VertexCoordinates->vertices]

UnitDistance by refinement

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

UnitDistanceGraphEmbeddingQ[%]

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

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

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

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

UnitDistance by FindSubgraphUnitDistanceEmbedding

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

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

Matchstick

GraphData["FranklinGraph","Matchstick"]

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

3D default

Graph3D[GraphData["FranklinGraph","Edges"]]

g=CubicVertexTransitiveGraph[12,GraphLayout->"3DEmbedding"]

RecognizeGraph@g

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["FranklinGraph","Polyhedral"]