Grünbaum-Rigby Graph

Author

Eric W. Weisstein
December 12, 2023

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/Gruenbaum-RigbyGraph.nb.

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

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

Properties

GraphData["GruenbaumRigbyGraph",{"V","E"}]

Graphic

GraphicsGrid[Partition[GraphData["GruenbaumRigbyGraph","Graph","All"]//StyleGraphs,UpTo[5]],ImageSize->700]

Configuration

GraphData["GruenbaumRigbyGraph","Incidence"]

lines=GraphData["GruenbaumRigbyGraph","Configurations"]

Subscript@@Reverse@Flatten@Tally[Length/@lines[[1]]]

RecognizeGraph[LeviGraph[#]]&/@lines

GraphData["GruenbaumRigbyConfigurationGraph","#"]

configg=GraphData["GruenbaumRigbyConfigurationGraph","Graph",{"Configuration","Labeled"}][[1]]

lines2=Sort@Select[ConfigurationLinesFromGraph[configg],Length[#]==4&]

LeviGraph[lines2]//RecognizeGraph

points=GraphEmbedding[configg]

all=ResourceFunction["FindExtraordinaryLines"][points]

Graphics3D[{Point[points],Select[all,Length[#]==3&]}]

ConfigurationGraph[points,lines2,VertexLabels->Automatic]

RecognizeGraph@%

ConfigurationDiagram[points,lines2,.5]

Embeddings

<<MathWorld`Graphs`

Names

GraphData["GruenbaumRigbyGraph","StandardName"]

GraphData["GruenbaumRigbyGraph","StandardNames"]

Primary

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

All

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

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData["GruenbaumRigbyGraph","EdgeList"]]

Default embedding

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

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

RecognizeGraph[g]

Degenerate

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

Bilateral

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

Circular

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

Planar

GraphData["GruenbaumRigbyGraph","Planar"]

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

MinimalCrossing

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

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

MinimalCrossing construction

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

(cn=CrossingNumber[GraphData["GruenbaumRigbyGraph"],TimeConstraint->60])//AbsoluteTiming

(cn=CrossingNumber[GraphData["GruenbaumRigbyGraph"],TimeConstraint->300])//AbsoluteTiming

(cn=CrossingNumber[GraphData["GruenbaumRigbyGraph"],TimeConstraint->3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData["GruenbaumRigbyGraph"],TimeConstraint->5 3600])//AbsoluteTiming

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

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

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData["GruenbaumRigbyGraph","Circulant"]

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

Halin

GraphData["GruenbaumRigbyGraph","Halin"]

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

LCF

GraphData["GruenbaumRigbyGraph","LCF"]

GraphData["GruenbaumRigbyGraph","HamiltonianCycleCount"]

GraphData["GruenbaumRigbyGraph","LCFNotations"]

GraphData["GruenbaumRigbyGraph","LCFSignature"]

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

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

LCF compute All

GraphData["GruenbaumRigbyGraph","HamiltonianCycleCount"]

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

DeleteCases[lcf,{_,1}]

LCFGraph@@@DeleteCases[lcf,{_,1|2|3}]

(gs=Flatten[{
(* all LCF's with order >3, 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|2|3}],Last],{2}],{2}],
(* order-3 bilateral only *)
DeleteMissing[BilateralLCFGraph@@@Cases[lcf,{_,3}]]}])//Timing

Length[gs]

(gs=Flatten[{
(* all LCF's with order >3, 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|2|3}],Last],{2}],{2}],
(* order-3 bilateral only *)
DeleteMissing[BilateralLCFGraph@@@Cases[lcf,{_,2|3}]]}])//Timing

Length[gs]

UnitDistance

GraphData["GruenbaumRigbyGraph","UnitDistance"]

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

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

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

UnitDistance by refinement

UnitDistanceEmbeddingRefine[Graph[GraphData["GruenbaumRigbyGraph","VertexList"],GraphData["GruenbaumRigbyGraph","EdgeList"]]]

UnitDistanceGraphEmbeddingQ[%]

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

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

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

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

UnitDistance by FindSubgraphUnitDistanceEmbedding

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

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

Matchstick

GraphData["GruenbaumRigbyGraph","Matchstick"]

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

3D default

Graph3D[GraphData["GruenbaumRigbyGraph","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["GruenbaumRigbyGraph","Polyhedral"]

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

Construction

Configuration from Ed Pegg, Jr.

Points and lines from Ed Pegg, Jr.
Dec 15, 2022

Length[points=RootReduce[Flatten[Transpose[{CirclePoints[7],RotateRight[(NumericalApproximation[Root, (RowDefault["-2.80", FEExpressionsNumericalApproximationElider]), Root[-1+3 #1+4 ((#1)^2)+((#1)^3)&,1], ])CirclePoints[7],4],(NumericalApproximation[Root, (RowDefault["4.05", FEExpressionsNumericalApproximationElider]), Root[-1-4 #1-3 ((#1)^2)+((#1)^3)&,3], ])CirclePoints[7]}],1]]]

Length[lines={{1,2,7,11},{2,3,18,20},{3,4,7,12},{4,5,10,14},{2,5,6,21},
{6,7,10,15},{7,8,13,17},{3,5,8,9},{9,10,13,18},{10,11,16,20},
{6,8,11,12},{12,13,16,21},{2,13,14,19},{9,11,14,15},
{3,15,16,19},{1,5,16,17},{12,14,17,18},{1,6,18,19},{4,8,19,20},{15,17,20,21},{1,4,9,21}}]

Graphics[{
PointSize[.02],Point[points],
Line[points[[#]]]&/@lines,
MapIndexed[Text[#2[[1]],#,{-2,-1},Background->White]&,points]}]

ConfigurationDiagram[points,lines,.5]

ConfigurationGraph[points,lines]

RecognizeGraph@%

Levi graph

lines=Select[ConfigurationLinesFromGraph[GraphData["GruenbaumRigbyConfigurationGraph"]],Length[#]==4&]

g=LeviGraph[lines]

RecognizeGraph@g

LCF embedding from Ed Pegg, Jr.
Dec 15, 2022

vertices=Sort[Thread[Flatten[Transpose[{Range[21],Range[21]+21}]]->RotateLeft[CirclePoints[42],1]]][[All,2]];

edges=Sort[UndirectedEdge@@@Flatten[Table[{#,k+21}&/@lines[[k]],{k,21}],1]];

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

g2=;

LCFNotation@g2

IsomorphicGraphQ[g1,g2]

Construction from "extraordinary lines" but includes "extra" lines through the center

Ed Pegg, Jr.
Dec 11, 2023

points=RootReduce[Flatten[#  CirclePoints[7]&/@{Root[1-4 #+3 #^2+#^3&,2,0],-1,Root[1+3 #-4 #^2+#^3&,2,0]},1]];
lines=ResourceFunction["FindExtraordinaryLines"][points];
Graphics[{Line[points[[#]]]&/@lines,Disk[#,.05]&/@points}]

ConfigurationGraph[points,lines]

RecognizeGraph@%

Length[lines]

Length[points]

LeviGraph[lines]

RecognizeGraph@%

GraphData

GraphDataClassString

GraphDataClassString["GruenbaumRigbyGraph"]

GraphDataString

file=OpenWrite["~/grunbaumrigby.m"]

WriteString[file,GraphDataString[g2,
"StandardName"->"GruenbaumRigbyGraph",
"Name"->"Grünbaum\[Hyphen]Rigby graph",
"Information"->"Gruenbaum-RigbyGraph",
"Skip"->{"TuttePolynomial"},
TimeConstraint->5
]]