Barnette-Bosák-Lederberg Graph

Author

Eric W. Weisstein
June 19, 2023

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/Barnette-Bosak-LederbergGraph.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/Barnette-Bosak-LederbergGraph.html.

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

Embeddings

Primary

Construction from Read and Wilson

g=Graph[Range[38],UndirectedEdge@@@{{1,2},{1,3},{1,11},{2,5},{2,20},{3,4},{3,6},{4,5},{4,8},{5,10},{6,7},{6,12},{7,8},{7,13},{8,9},{9,10},{9,14},{10,15},{11,12},{11,16},{12,13},{13,14},{14,15},{15,18},{16,17},{16,21},{17,18},{17,22},{18,19},{19,20},{19,23},{20,38},{21,22},{21,24},{22,23},{23,28},{24,25},{24,37},{25,26},{25,29},{26,27},{26,30},{27,28},{27,32},{28,33},{29,30},{29,34},{30,31},{31,32},{31,35},{32,33},{33,36},{34,35},{34,37},{35,36},{36,38},{37,38}},VertexCoordinates->(10^(-4)){{6977,-19679},{6977,-2656},{8819,-18615},{8819,-11167},{8819,-3720},{10661,-17551},{10661,-13295},{10661,-11167},{10661,-9039},{10661,-4784},{12503,-19679},{12503,-16487},{12503,-13295},{12503,-9039},{12503,-5848},{14346,-19679},{14346,-11167},{14346,-4784},{16188,-3720},{16188,-2656},{18030,-19679},{18030,-11167},{18030,-4784},{19872,-19679},{19872,-16487},{19872,-13295},{19872,-9039},{19872,-5848},{21714,-17551},{21714,-13295},{21714,-11167},{21714,-9039},{21714,-4784},{23556,-18615},{23556,-11167},{23556,-3796},{25398,-19679},{25398,-2656}},VertexLabels->Automatic]

RecognizeGraph@g

All

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

Default embedding

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

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

RecognizeGraph[g]

MinimalCrossing

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

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

MinimalCrossing construction

GraphPlot@RotateGraph[MinimalCrossingGraph[GraphData["BarnetteBosakLederbergGraph"]]]

LCF

GraphData["BarnetteBosakLederbergGraph","LCF"]

GraphData["BarnetteBosakLederbergGraph","Hamiltonian"]

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

UnitDistance

GraphData["BarnetteBosakLederbergGraph","UnitDistance"]

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

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

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

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

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

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

gs=UniqueEmbeddings[l]

gs={,,,,};

Matchstick

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

3D default

Graph3D[GraphData["BarnetteBosakLederbergGraph","Edges"]]

3D All

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

3D Polyhedron

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

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

3D Polyhedron construction

Graphics3D[{FaceForm[Green,Red],poly=GraphPolyhedron[GraphData["BarnetteBosakLederbergGraph"],1]}]

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

Graphics3D[can]

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

Graphics3D[can]

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

Graphics3D[can=Polyhedron[]]

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

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

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

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={Red,Green,Black,Blue};

Graphics3D[{Thick,Sequence@@Nearest[Thread[lens->colors],EuclideanDistance@@v[[#]]],Line[v[[#]]]}&/@PolyhedronEdges[can],Boxed->False]

g=PolyhedronGraph[can]

3D Canonical construction from PolyhedralEmbedding

GraphData["BarnetteBosakLederbergGraph","Graph","Planar"]

g=GraphData["BarnetteBosakLederbergGraph","Graph","Planar"][[1]]

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

Show[g2=PolyhedralEmbedding[g,"Scale"->2],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.02v,faces]}]]

(can=FindCanonicalPolyhedron[poly,WorkingPrecision->100,MaxIterations->1000,PrecisionGoal->20,"ProgressInterval"->100,"TangentFactor"->1/10,"PlanarFactor"->1/10,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]

Embedding construction

Grünbaum, Long paths in polytopes,

Grünbaum, Long paths in polytopes, Fig. 17.1.5

GraphPlot[Graph[List/@Sort[Sort/@DeleteCases[List@@@{1->1,2->2,3->3,4->4,5->5,6->6,7->7,8->8,9->9,10->10,11->11,12->12,13->13,14->14,13->5,5->6,14->7,7->4,4->2,2->1,12->11,11->10,10->3,3->2,12->13,13->14,6->7,5->8,8->9,8->11,9->10,15->15,16->16,16->15,15->3,15->4,9->16,16->6},{n_,n_}]],List/@{{570,510},{568,549},{525,581},{619,586},{561,674},{610,653},{684,655},{521,662},{533,642},{473,607},{433,660},{383,735},{566,750},{751,749},{565,598},{566,626}}/700.],Method->None]

g=ToCombinatoricaGraph[]

v=(#-{0,.65})&/@Vertices[g]

e=Edges[g]

(g2=AddEdges[AddVertices[AddEdges[AddVertices[ChangeVertices[g,v],{1,-1}#&/@v],e+16],{{.81,0},{1.07,0},{.56,.08},{.56,-.08},{.69,.08},{.69,-.08}}],{{14,34},{34,30},{1,33},{33,17},{33,34},{35,12},{35,36},{36,28},{35,37},{37,1},{37,38},{36,38},{38,17}}])//ShowLabeledGraph

RecognizeGraph[g2]

ShowGraph[g2,ImageSize->150]

Append[GraphData["BarnetteBosakLederbergGraph","Embeddings"],ToCommonEdges[g2,Graph["BarnetteBosakLederbergGraph"]]]//PadVertices

GraphicsArray[{ShowGraph[#]&/@{Graph["BarnetteBosakLederbergGraph"],g2}/.{PointSize[x_]:>AbsolutePointSize[5],
Thickness[x_]:>AbsoluteThickness[1]}}]

GraphData

GraphClassString["BarnetteBosakLederbergGraph"]

GraphDataMatrices

GraphDataMatrices["BarnetteBosakLederbergGraph"]

GraphDataTable

TableForm[GraphDataTable["BarnetteBosakLederbergGraph",x],TableDepth->2]//TraditionalForm