Bouwer Graph

Author

Eric W. Weisstein
October 21, 2022

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

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

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

Author

Embeddings

<<MathWorld`Graphs`

GraphData["Bouwer*"]

{"Bouwer", {2, 4, 15}}

GraphData[{"Bouwer",{2,4,15}},"StandardName"]

Primary

GraphData[{"Bouwer",{2,4,15}}]//StyleGraphs[#,ImageSize->Small]&

All

GraphData[{"Bouwer",{2,4,15}},"Graph","All"]//StyleGraphs

Default embedding

GraphPlot@GraphData[{"Bouwer",{2,4,15}},"Edges"]

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

RecognizeGraph[g]

Embedding types

GraphDataEmbeddings[GraphData[{"Bouwer",{2,4,15}},"EdgeList"]]

Degenerate

GraphData[{"Bouwer",{2,4,15}},"Graph","Degenerate"]//StyleGraphs

Circular

GraphData[{"Bouwer",{2,4,15}},"Graph","Circular"]//StyleGraphs

Planar

GraphData[{"Bouwer",{2,4,15}},"Planar"]

GraphData[{"Bouwer",{2,4,15}},"Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData[{"Bouwer",{2,4,15}},{"RCN","CN"}]

GraphData[{"Bouwer",{2,4,15}},"Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

(cn=CrossingNumber[GraphData[{"Bouwer",{2,4,15}}],TimeConstraint->10])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"Bouwer",{2,4,15}}],TimeConstraint->60])//AbsoluteTiming

g=RotateGraph[MinimalCrossingGraph[GraphData[{"Bouwer",{2,4,15}}],"CrossingNumber"->cn]]

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

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData[{"Bouwer",{2,4,15}},"Circulant"]

GraphData[{"Bouwer",{2,4,15}},"Graph","Circulant"]//StyleGraphs

Halin

GraphData[{"Bouwer",{2,4,15}},"Halin"]

GraphData[{"Bouwer",{2,4,15}},"Graph","Halin"]//StyleGraphs

LCF

GraphData[{"Bouwer",{2,4,15}},"LCF"]

GraphData[{"Bouwer",{2,4,15}},"LCFSignature"]

GraphData[{"Bouwer",{2,4,15}},"Graph","LCF"]//StyleGraphs

LCF compute

Length[FindHamiltonianCycle[GraphData[{"Bouwer",{2,4,15}}],All][[All,All,1]]]//Timing

Tally[(lcf=LCF[GraphData[{"Bouwer",{2,4,15}}],All])[[All,2]]]

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

UnitDistance

GraphData[{"Bouwer",{2,4,15}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"Bouwer",{2,4,15}}],Debug->True]//Timing

GraphData[{"Bouwer",{2,4,15}},"Graph","UnitDistance"]//StyleGraphs

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

UnitDistance by refinement

UnitDistanceEmbeddingRefine/@GraphData[{"Bouwer",{2,4,15}},"Graph","All"]

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistanceEmbeddingRefine/@Complement@@(GraphData[{"Bouwer",{2,4,15}},"Graph",#]&/@{"All","UnitDistance"})

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

FindUnitDistanceEmbedding[GraphData[{"Bouwer",{2,4,15}}],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

FindUnitDistanceEmbedding[GraphData[{"Bouwer",{2,4,15}}],MaxIterations->5000,"ReturnWithMessage"->False]//Quiet//Timing

FindUnitDistanceEmbedding[GraphData[{"Bouwer",{2,4,15}}],MaxIterations->50000,"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance by FindSubgraphUnitDistanceEmbedding

{{"Bouwer",{2,4,15}},l=FindSubgraphUnitDistanceEmbedding[GraphData[{"Bouwer",{2,4,15}}],TimeConstraint->300,"Results"->All]//Timing}

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

Matchstick

GraphData[{"Bouwer",{2,4,15}},"Matchstick"]

GraphData[{"Bouwer",{2,4,15}},"Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData[{"Bouwer",{2,4,15}},"Edges"]]

3D All

GraphData[{"Bouwer",{2,4,15}},"Graph",{"3D","All"}]

3D UnitDistance

GraphData[{"Bouwer",{2,4,15}},"Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData[{"Bouwer",{2,4,15}},"Polyhedral"]

GraphData[{"Bouwer",{2,4,15}},"Graph",{"3D","Polyhedron"}]

{"Bouwer", {2, 6, 9}}

Names

GraphData[{"Bouwer",{2,6,9}},"StandardName"]

GraphData[{"Bouwer",{2,6,9}},"StandardNames"]

Primary

GraphData[{"Bouwer",{2,6,9}}]//StyleGraphs[#,ImageSize->Small]&

All

GraphData[{"Bouwer",{2,6,9}},"Graph","All"]//StyleGraphs

Inexact

Select[GraphData[{"Bouwer",{2,6,9}},"Graph","All"],(!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&)]//StyleGraphs

Default embedding

GraphPlot@GraphData[{"Bouwer",{2,6,9}},"Edges"]

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

RecognizeGraph[g]

Embedding types

GraphDataEmbeddings[GraphData[{"Bouwer",{2,6,9}},"EdgeList"]]

Degenerate

GraphData[{"Bouwer",{2,6,9}},"Graph","Degenerate"]//StyleGraphs

Bilateral

GraphData[{"Bouwer",{2,6,9}},"Graph","Bilateral"]//StyleGraphs

Circular

GraphData[{"Bouwer",{2,6,9}},"Graph","Circular"]//StyleGraphs

Planar

GraphData[{"Bouwer",{2,6,9}},"Planar"]

GraphData[{"Bouwer",{2,6,9}},"Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData[{"Bouwer",{2,6,9}},{"RCN","CN"}]

GraphData[{"Bouwer",{2,6,9}},"Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

(cn=CrossingNumber[GraphData[{"Bouwer",{2,6,9}}],TimeConstraint->10])//AbsoluteTiming

CrossingNumber[GraphData[{"Bouwer",{2,6,9}}],TimeConstraint->60]//AbsoluteTiming

g=RotateGraph[MinimalCrossingGraph[GraphData[{"Bouwer",{2,6,9}}],"CrossingNumber"->cn]]

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

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData[{"Bouwer",{2,6,9}},"Circulant"]

GraphData[{"Bouwer",{2,6,9}},"Graph","Circulant"]//StyleGraphs

Halin

GraphData[{"Bouwer",{2,6,9}},"Halin"]

GraphData[{"Bouwer",{2,6,9}},"Graph","Halin"]//StyleGraphs

LCF

GraphData[{"Bouwer",{2,6,9}},"LCF"]

GraphData[{"Bouwer",{2,6,9}},"HamiltonianCycleCount"]

GraphData[{"Bouwer",{2,6,9}},"LCFSignature"]

GraphData[{"Bouwer",{2,6,9}},"LCFNotations"]

GraphData[{"Bouwer",{2,6,9}},"Graph","LCF"]//StyleGraphs

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

LCF compute random

FindRandomLCFNotation[GraphData[{"Bouwer",{2,6,9}}],TimeConstraint->120]

LCF compute 10^5

Tally[(lcf=LCF[GraphData[{"Bouwer",{2,6,9}}],10^5])[[All,2]]]//Timing

MaxMemoryUsed[]/10.^9 "GB"

DeleteCases[lcf,{_,1}]

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

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

Length[gs]

gs

BilateralGraphEmbeddingQ/@gs

LCF compute 10^6

Tally[(lcf=LCF[GraphData[{"Bouwer",{2,6,9}}],10^6])[[All,2]]]//Timing

MaxMemoryUsed[]/10.^9 "GB"

DeleteCases[lcf,{_,1}]

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

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

Length[gs]

gs

BilateralGraphEmbeddingQ/@gs

LCF compute 10^7

Tally[(lcf=LCF[GraphData[{"Bouwer",{2,6,9}}],10^7])[[All,2]]]//Timing

MaxMemoryUsed[]/10.^9 "GB"

DeleteCases[lcf,{_,1}]

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

Length[gs]

gs

BilateralGraphEmbeddingQ/@gs

LCF compute 5*^7

Tally[(lcf=LCF[GraphData[{"Bouwer",{2,6,9}}],5*^7])[[All,2]]]//Timing

MaxMemoryUsed[]/10.^9 "GB"

DeleteCases[lcf,{_,1}]

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

Length[gs]

gs

BilateralGraphEmbeddingQ/@gs

LCF compute

Length[FindHamiltonianCycle[GraphData[{"Bouwer",{2,6,9}}],All][[All,All,1]]]//Timing

Tally[(lcf=LCF[GraphData[{"Bouwer",{2,6,9}}],All])[[All,2]]]

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

UnitDistance

GraphData[{"Bouwer",{2,6,9}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"Bouwer",{2,6,9}}],Debug->True]//Timing

GraphData[{"Bouwer",{2,6,9}},"Graph","UnitDistance"]//StyleGraphs

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

UnitDistance by refinement

UnitDistanceEmbeddingRefine/@GraphData[{"Bouwer",{2,6,9}},"Graph","All"]

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistanceEmbeddingRefine/@Complement@@(GraphData[{"Bouwer",{2,6,9}},"Graph",#]&/@{"All","UnitDistance"})

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

FindUnitDistanceEmbedding[GraphData[{"Bouwer",{2,6,9}}],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

FindUnitDistanceEmbedding[GraphData[{"Bouwer",{2,6,9}}],MaxIterations->1000,"ReturnWithMessage"->False]//Quiet//Timing

FindUnitDistanceEmbedding[GraphData[{"Bouwer",{2,6,9}}],MaxIterations->50000,"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance by FindSubgraphUnitDistanceEmbedding

{{"Bouwer",{2,6,9}},l=FindSubgraphUnitDistanceEmbedding[GraphData[{"Bouwer",{2,6,9}}],TimeConstraint->300,"Results"->All]//Timing}

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

Matchstick

GraphData[{"Bouwer",{2,6,9}},"Matchstick"]

GraphData[{"Bouwer",{2,6,9}},"Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData[{"Bouwer",{2,6,9}},"Edges"]]

3D All

GraphData[{"Bouwer",{2,6,9}},"Graph",{"3D","All"}]

3D UnitDistance

GraphData[{"Bouwer",{2,6,9}},"Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData[{"Bouwer",{2,6,9}},"Polyhedral"]

GraphData[{"Bouwer",{2,6,9}},"Graph",{"3D","Polyhedron"}]

{"Bouwer", {2, 9, 7}}

GraphData[{"Bouwer",{2,9,7}},"StandardName"]

Primary

GraphData[{"Bouwer",{2,9,7}}]//StyleGraphs[#,ImageSize->Small]&

All

GraphData[{"Bouwer",{2,9,7}},"Graph","All"]//StyleGraphs

Default embedding

GraphPlot@GraphData[{"Bouwer",{2,9,7}},"Edges"]

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

RecognizeGraph[g]

Embedding types

GraphDataEmbeddings[GraphData[{"Bouwer",{2,9,7}},"EdgeList"]]

Degenerate

GraphData[{"Bouwer",{2,9,7}},"Graph","Degenerate"]//StyleGraphs

Circular

GraphData[{"Bouwer",{2,9,7}},"Graph","Circular"]//StyleGraphs

Planar

GraphData[{"Bouwer",{2,9,7}},"Planar"]

GraphData[{"Bouwer",{2,9,7}},"Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData[{"Bouwer",{2,9,7}},{"RCN","CN"}]

GraphData[{"Bouwer",{2,9,7}},"Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

(cn=CrossingNumber[GraphData[{"Bouwer",{2,9,7}}],TimeConstraint->10])//AbsoluteTiming

CrossingNumber[GraphData[{"Bouwer",{2,9,7}}],TimeConstraint->60]//AbsoluteTiming

g=RotateGraph[MinimalCrossingGraph[GraphData[{"Bouwer",{2,9,7}}],"CrossingNumber"->cn]]

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

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData[{"Bouwer",{2,9,7}},"Circulant"]

GraphData[{"Bouwer",{2,9,7}},"Graph","Circulant"]//StyleGraphs

Halin

GraphData[{"Bouwer",{2,9,7}},"Halin"]

GraphData[{"Bouwer",{2,9,7}},"Graph","Halin"]//StyleGraphs

LCF

GraphData[{"Bouwer",{2,9,7}},"LCF"]

GraphData[{"Bouwer",{2,9,7}},"LCFSignature"]

GraphData[{"Bouwer",{2,9,7}},"Graph","LCF"]//StyleGraphs

LCF compute

Length[FindHamiltonianCycle[GraphData[{"Bouwer",{2,9,7}}],All][[All,All,1]]]//Timing

Tally[(lcf=LCF[GraphData[{"Bouwer",{2,9,7}}],All])[[All,2]]]

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

UnitDistance

GraphData[{"Bouwer",{2,9,7}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"Bouwer",{2,9,7}}],Debug->True]//Timing

GraphData[{"Bouwer",{2,9,7}},"Graph","UnitDistance"]//StyleGraphs

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

UnitDistance by refinement

UnitDistanceEmbeddingRefine/@GraphData[{"Bouwer",{2,9,7}},"Graph","All"]

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistanceEmbeddingRefine/@Complement@@(GraphData[{"Bouwer",{2,9,7}},"Graph",#]&/@{"All","UnitDistance"})

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

FindUnitDistanceEmbedding[GraphData[{"Bouwer",{2,9,7}}],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

FindUnitDistanceEmbedding[GraphData[{"Bouwer",{2,9,7}}],MaxIterations->1000,"ReturnWithMessage"->False]//Quiet//Timing

FindUnitDistanceEmbedding[GraphData[{"Bouwer",{2,9,7}}],MaxIterations->50000,"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance by FindSubgraphUnitDistanceEmbedding

{{"Bouwer",{2,9,7}},l=FindSubgraphUnitDistanceEmbedding[GraphData[{"Bouwer",{2,9,7}}],TimeConstraint->300,"Results"->All]//Timing}

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

Matchstick

GraphData[{"Bouwer",{2,9,7}},"Matchstick"]

GraphData[{"Bouwer",{2,9,7}},"Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData[{"Bouwer",{2,9,7}},"Edges"]]

3D All

GraphData[{"Bouwer",{2,9,7}},"Graph",{"3D","All"}]

3D UnitDistance

GraphData[{"Bouwer",{2,9,7}},"Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData[{"Bouwer",{2,9,7}},"Polyhedral"]

GraphData[{"Bouwer",{2,9,7}},"Graph",{"3D","Polyhedron"}]

{"Bouwer", {2, 12, 7}}

GraphData[{"Bouwer",{2,12,7}},"StandardName"]

Primary

GraphData[{"Bouwer",{2,12,7}}]//StyleGraphs[#,ImageSize->Small]&

All

GraphData[{"Bouwer",{2,12,7}},"Graph","All"]//StyleGraphs

Default embedding

GraphPlot@GraphData[{"Bouwer",{2,12,7}},"Edges"]

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

RecognizeGraph[g]

Embedding types

GraphDataEmbeddings[GraphData[{"Bouwer",{2,12,7}},"EdgeList"]]

Degenerate

GraphData[{"Bouwer",{2,12,7}},"Graph","Degenerate"]//StyleGraphs

Circular

GraphData[{"Bouwer",{2,12,7}},"Graph","Circular"]//StyleGraphs

Planar

GraphData[{"Bouwer",{2,12,7}},"Planar"]

GraphData[{"Bouwer",{2,12,7}},"Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData[{"Bouwer",{2,12,7}},{"RCN","CN"}]

GraphData[{"Bouwer",{2,12,7}},"Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

(cn=CrossingNumber[GraphData[{"Bouwer",{2,12,7}}],TimeConstraint->10])//AbsoluteTiming

CrossingNumber[GraphData[{"Bouwer",{2,12,7}}],TimeConstraint->60]//AbsoluteTiming

g=RotateGraph[MinimalCrossingGraph[GraphData[{"Bouwer",{2,12,7}}],"CrossingNumber"->cn]]

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

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData[{"Bouwer",{2,12,7}},"Circulant"]

GraphData[{"Bouwer",{2,12,7}},"Graph","Circulant"]//StyleGraphs

Halin

GraphData[{"Bouwer",{2,12,7}},"Halin"]

GraphData[{"Bouwer",{2,12,7}},"Graph","Halin"]//StyleGraphs

LCF

GraphData[{"Bouwer",{2,12,7}},"LCF"]

GraphData[{"Bouwer",{2,12,7}},"LCFSignature"]

GraphData[{"Bouwer",{2,12,7}},"Graph","LCF"]//StyleGraphs

LCF compute

Length[FindHamiltonianCycle[GraphData[{"Bouwer",{2,12,7}}],All][[All,All,1]]]//Timing

Tally[(lcf=LCF[GraphData[{"Bouwer",{2,12,7}}],All])[[All,2]]]

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

UnitDistance

GraphData[{"Bouwer",{2,12,7}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"Bouwer",{2,12,7}}],Debug->True]//Timing

GraphData[{"Bouwer",{2,12,7}},"Graph","UnitDistance"]//StyleGraphs

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

UnitDistance by refinement

UnitDistanceEmbeddingRefine/@GraphData[{"Bouwer",{2,12,7}},"Graph","All"]

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistanceEmbeddingRefine/@Complement@@(GraphData[{"Bouwer",{2,12,7}},"Graph",#]&/@{"All","UnitDistance"})

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

FindUnitDistanceEmbedding[GraphData[{"Bouwer",{2,12,7}}],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

FindUnitDistanceEmbedding[GraphData[{"Bouwer",{2,12,7}}],MaxIterations->1000,"ReturnWithMessage"->False]//Quiet//Timing

FindUnitDistanceEmbedding[GraphData[{"Bouwer",{2,12,7}}],MaxIterations->50000,"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance by FindSubgraphUnitDistanceEmbedding

{{"Bouwer",{2,12,7}},l=FindSubgraphUnitDistanceEmbedding[GraphData[{"Bouwer",{2,12,7}}],TimeConstraint->300,"Results"->All]//Timing}

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

Matchstick

GraphData[{"Bouwer",{2,12,7}},"Matchstick"]

GraphData[{"Bouwer",{2,12,7}},"Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData[{"Bouwer",{2,12,7}},"Edges"]]

3D All

GraphData[{"Bouwer",{2,12,7}},"Graph",{"3D","All"}]

3D UnitDistance

GraphData[{"Bouwer",{2,12,7}},"Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData[{"Bouwer",{2,12,7}},"Polyhedral"]

GraphData[{"Bouwer",{2,12,7}},"Graph",{"3D","Polyhedron"}]

{"Bouwer", {3, 4, 5}}

GraphData[{"Bouwer",{3,4,5}},"StandardName"]

Primary

GraphData[{"Bouwer",{3,4,5}}]//StyleGraphs[#,ImageSize->Small]&

All

GraphData[{"Bouwer",{3,4,5}},"Graph","All"]//StyleGraphs

Default embedding

GraphPlot@GraphData[{"Bouwer",{3,4,5}},"Edges"]

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

RecognizeGraph[g]

Embedding types

GraphDataEmbeddings[GraphData[{"Bouwer",{3,4,5}},"EdgeList"]]

Degenerate

GraphData[{"Bouwer",{3,4,5}},"Graph","Degenerate"]//StyleGraphs

Circular

GraphData[{"Bouwer",{3,4,5}},"Graph","Circular"]//StyleGraphs

Planar

GraphData[{"Bouwer",{3,4,5}},"Planar"]

GraphData[{"Bouwer",{3,4,5}},"Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData[{"Bouwer",{3,4,5}},{"RCN","CN"}]

GraphData[{"Bouwer",{3,4,5}},"Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

(cn=CrossingNumber[GraphData[{"Bouwer",{3,4,5}}],TimeConstraint->10])//AbsoluteTiming

CrossingNumber[GraphData[{"Bouwer",{3,4,5}}],TimeConstraint->60]//AbsoluteTiming

g=RotateGraph[MinimalCrossingGraph[GraphData[{"Bouwer",{3,4,5}}],"CrossingNumber"->cn]]

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

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

Cases[GraphData[{"Bouwer",{3,4,5}},"StandardNames"],{"Circulant",_}]

GraphData[{"Bouwer",{3,4,5}},"Graph","Circulant"]//StyleGraphs

Halin

GraphData[{"Bouwer",{3,4,5}},"Halin"]

GraphData[{"Bouwer",{3,4,5}},"Graph","Halin"]//StyleGraphs

LCF

GraphData[{"Bouwer",{3,4,5}},"LCF"]

GraphData[{"Bouwer",{3,4,5}},"LCFSignature"]

GraphData[{"Bouwer",{3,4,5}},"Graph","LCF"]//StyleGraphs

LCF compute

Length[FindHamiltonianCycle[GraphData[{"Bouwer",{3,4,5}}],All][[All,All,1]]]//Timing

Tally[(lcf=LCF[GraphData[{"Bouwer",{3,4,5}}],All])[[All,2]]]

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

UnitDistance

GraphData[{"Bouwer",{3,4,5}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"Bouwer",{3,4,5}}],Debug->True]//Timing

GraphData[{"Bouwer",{3,4,5}},"Graph","UnitDistance"]//StyleGraphs

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

UnitDistance by refinement

UnitDistanceEmbeddingRefine/@GraphData[{"Bouwer",{3,4,5}},"Graph","All"]

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistanceEmbeddingRefine/@Complement@@(GraphData[{"Bouwer",{3,4,5}},"Graph",#]&/@{"All","UnitDistance"})

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

FindUnitDistanceEmbedding[GraphData[{"Bouwer",{3,4,5}}],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

FindUnitDistanceEmbedding[GraphData[{"Bouwer",{3,4,5}}],MaxIterations->1000,"ReturnWithMessage"->False]//Quiet//Timing

FindUnitDistanceEmbedding[GraphData[{"Bouwer",{3,4,5}}],MaxIterations->50000,"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance by FindSubgraphUnitDistanceEmbedding

{{"Bouwer",{3,4,5}},l=FindSubgraphUnitDistanceEmbedding[GraphData[{"Bouwer",{3,4,5}}],TimeConstraint->300,"Results"->All]//Timing}

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

Matchstick

GraphData[{"Bouwer",{3,4,5}},"Matchstick"]

GraphData[{"Bouwer",{3,4,5}},"Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData[{"Bouwer",{3,4,5}},"Edges"]]

3D All

GraphData[{"Bouwer",{3,4,5}},"Graph",{"3D","All"}]

3D UnitDistance

GraphData[{"Bouwer",{3,4,5}},"Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData[{"Bouwer",{3,4,5}},"Polyhedral"]

GraphData[{"Bouwer",{3,4,5}},"Graph",{"3D","Polyhedron"}]

{"Bouwer", {3, 6, 9}}

GraphData[{"Bouwer",{3,6,9}},"StandardName"]

Primary

GraphData[{"Bouwer",{3,6,9}}]//StyleGraphs[#,ImageSize->Small]&

All

GraphData[{"Bouwer",{3,6,9}},"Graph","All"]//StyleGraphs

Default embedding

GraphPlot@GraphData[{"Bouwer",{3,6,9}},"Edges"]

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

RecognizeGraph[g]

Embedding types

GraphDataEmbeddings[GraphData[{"Bouwer",{3,6,9}},"EdgeList"]]

Degenerate

GraphData[{"Bouwer",{3,6,9}},"Graph","Degenerate"]//StyleGraphs

Circular

GraphData[{"Bouwer",{3,6,9}},"Graph","Circular"]//StyleGraphs

Planar

GraphData[{"Bouwer",{3,6,9}},"Planar"]

GraphData[{"Bouwer",{3,6,9}},"Graph","Planar"]//StyleGraphs

MinimalCrossing

GraphData[{"Bouwer",{3,6,9}},{"RCN","CN"}]

GraphData[{"Bouwer",{3,6,9}},"Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossing construction

(cn=CrossingNumber[GraphData[{"Bouwer",{3,6,9}}],TimeConstraint->10])//AbsoluteTiming

CrossingNumber[GraphData[{"Bouwer",{3,6,9}}],TimeConstraint->60]//AbsoluteTiming

CrossingNumber[GraphData[{"Bouwer",{3,6,9}}],TimeConstraint->300]//AbsoluteTiming

g=RotateGraph[MinimalCrossingGraph[GraphData[{"Bouwer",{3,6,9}}],"CrossingNumber"->cn]]

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

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData[{"Bouwer",{3,6,9}},"Circulant"]

GraphData[{"Bouwer",{3,6,9}},"Graph","Circulant"]//StyleGraphs

Halin

GraphData[{"Bouwer",{3,6,9}},"Halin"]

GraphData[{"Bouwer",{3,6,9}},"Graph","Halin"]//StyleGraphs

LCF

GraphData[{"Bouwer",{3,6,9}},"LCF"]

GraphData[{"Bouwer",{3,6,9}},"LCFSignature"]

GraphData[{"Bouwer",{3,6,9}},"Graph","LCF"]//StyleGraphs

LCF compute

Length[FindHamiltonianCycle[GraphData[{"Bouwer",{3,6,9}}],All][[All,All,1]]]//Timing

Tally[(lcf=LCF[GraphData[{"Bouwer",{3,6,9}}],All])[[All,2]]]

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

UnitDistance

GraphData[{"Bouwer",{3,6,9}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"Bouwer",{3,6,9}}],Debug->True]//Timing

GraphData[{"Bouwer",{3,6,9}},"Graph","UnitDistance"]//StyleGraphs

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

UnitDistance by refinement

UnitDistanceEmbeddingRefine/@GraphData[{"Bouwer",{3,6,9}},"Graph","All"]

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistanceEmbeddingRefine/@Complement@@(GraphData[{"Bouwer",{3,6,9}},"Graph",#]&/@{"All","UnitDistance"})

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

FindUnitDistanceEmbedding[GraphData[{"Bouwer",{3,6,9}}],MaxIterations->100,"ReturnWithMessage"->True]//Timing

FindUnitDistanceEmbedding[GraphData[{"Bouwer",{3,6,9}}],MaxIterations->1000,"ReturnWithMessage"->False]//Quiet//Timing

FindUnitDistanceEmbedding[GraphData[{"Bouwer",{3,6,9}}],MaxIterations->50000,"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance by FindSubgraphUnitDistanceEmbedding

{{"Bouwer",{3,6,9}},l=FindSubgraphUnitDistanceEmbedding[GraphData[{"Bouwer",{3,6,9}}],TimeConstraint->300,"Results"->All]//Timing}

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

Matchstick

GraphData[{"Bouwer",{3,6,9}},"Matchstick"]

GraphData[{"Bouwer",{3,6,9}},"Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData[{"Bouwer",{3,6,9}},"Edges"]]

3D All

GraphData[{"Bouwer",{3,6,9}},"Graph",{"3D","All"}]

3D UnitDistance

GraphData[{"Bouwer",{3,6,9}},"Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData[{"Bouwer",{3,6,9}},"Polyhedral"]

GraphData[{"Bouwer",{3,6,9}},"Graph",{"3D","Polyhedron"}]

Embeddings

From Ed Pegg Jr.
Nov 17, 2010

edges={{1,10},{1,11},{1,46},{1,50},{2,11},{2,12},{2,47},{2,51},{3,12},{3,13},{3,48},{3,52},{4,13},{4,14},{4,49},{4,53},{5,14},{5,15},{5,50},{5,54},{6,15},{6,16},{6,46},{6,51},{7,16},{7,17},{7,47},{7,52},{8,17},{8,18},{8,48},{8,53},{9,10},{9,18},{9,49},{9,54},{10,19},{10,21},{11,20},{11,22},{12,21},{12,23},{13,22},{13,24},{14,23},{14,25},{15,24},{15,26},{16,25},{16,27},{17,19},{17,26},{18,20},{18,27},{19,28},{19,32},{20,29},{20,33},{21,30},{21,34},{22,31},{22,35},{23,32},{23,36},{24,28},{24,33},{25,29},{25,34},{26,30},{26,35},{27,31},{27,36},{28,37},{28,45},{29,37},{29,38},{30,38},{30,39},{31,39},{31,40},{32,40},{32,41},{33,41},{33,42},{34,42},{34,43},{35,43},{35,44},{36,44},{36,45},{37,46},{37,53},{38,47},{38,54},{39,46},{39,48},{40,47},{40,49},{41,48},{41,50},{42,49},{42,51},{43,50},{43,52},{44,51},{44,53},{45,52},{45,54}};

1

g=FromUnorderedPairs[edges];

ArrayPlot[MatrixPower[ToAdjacencyMatrix[g],5]]

It has a lot of structure. There are 54 cases of 20 in the above MatrixPower, so put vertex 28 maximally distant from point 1, put vertex 29 maximally distant from point 2, and so on. Next, notice some symmetries in the first and last 27 vertices.Then take advantage of that symmetry.

bouw=edges/.Thread[{1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,36,28,29,30,31,32,33,34,35,44,45,37,38,39,40,41,42,43,51,52,53,54,46,47,48,49,50}->Range[54]];

GraphPlot[Rule@@@Select[bouw,Min[#]>27&]]

GraphPlot[Rule@@@Select[bouw,Max[#]<28&]]

d={1,1.6,2.9};

GraphPlot[Rule@@@bouw,VertexCoordinateRules->Thread[Range[54]->Flatten[Table[(4-d[[a]]) {Sin[(2 x-b) Pi/9],Cos[(2 x-b) Pi/9]},{a,1,3},{b,0,1},{x,0,8}],2]]]

ShowGraph[g1=Graph[List/@bouw,List/@Flatten[Table[(4-d[[a]]) {Sin[(2 x-b) Pi/9],Cos[(2 x-b) Pi/9]},{a,1,3},{b,0,1},{x,0,8}],2]]]

2

bouw=edges/.Thread[{1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,36,28,29,30,31,32,33,34,35,44,45,37,38,39,40,41,42,43,51,52,53,54,46,47,48,49,50}->Range[54]];

GraphPlot[Rule@@@bouw,VertexCoordinateRules->Thread[Range[54]->(v=Flatten[{Table[3 {Sin[(2 x-b) Pi/9],Cos[(2 x-b) Pi/9]},{b,0,1},{x,0,8}],Table[2.0 {Sin[(2 x-b+2 8) Pi/9],Cos[(2 x-b+2 8) Pi/9]},{b,1,1},{x,0,8}],Table[2.5 {Sin[(2 x-b+9) Pi/9],Cos[(2 x-b+9) Pi/9]},{b,0,1},{x,0,8}],Table[2.1 {Sin[(2 x-b+2 3) Pi/9],Cos[(2 x-b+2 3) Pi/9]},{b,0,0},{x,0,8}]},2])]]

ShowGraph[g2=Graph[List/@bouw,List/@v]]

3

bouw=edges/.Thread[{1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,36,28,29,30,31,32,33,34,35,44,45,37,38,39,40,41,42,43,51,52,53,54,46,47,48,49,50}->Range[54]];

GraphPlot[Rule@@@bouw,VertexCoordinateRules->Thread[Range[54]->(v=Flatten[{Table[3 {Sin[(2 x-b) Pi/9],Cos[(2 x-b) Pi/9]},{b,0,0},{x,0,8}],Table[2.8 {Sin[(2 x-b) Pi/9],Cos[(2 x-b) Pi/9]},{b,1,1},{x,0,8}],Table[1.93 {Sin[(2 x-b+2 8) Pi/9],Cos[(2 x-b+2 8) Pi/9]},{b,1,1},{x,0,8}],Table[3 {Sin[(2 x-b+9) Pi/9],Cos[(2 x-b+9) Pi/9]},{b,0,0},{x,0,8}],Table[2.8 {Sin[(2 x-b+9) Pi/9],Cos[(2 x-b+9) Pi/9]},{b,1,1},{x,0,8}],Table[1.93 {Sin[(2 x-b+2 3) Pi/9],Cos[(2 x-b+2 3) Pi/9]},{b,0,0},{x,0,8}]},2])]]

ShowGraph[g3=Graph[List/@bouw,List/@v]]

ToCommonEdges[#,Graph[{"Bouwer",4}]]&/@{g3,g2,g1}//N

Properties

Construction

Bouwer Paper

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]]

Counts

Table[6 (9^n),{n,10}]

(2,6,9)

(b2=BouwerGraph[2,6,9])//Timing

ShowGraph[b2]

Through[{RegularQ,SymmetricQ,ArcTransitiveQ}[b2]]//Timing

RecognizeGraph[b2]

g=BouwerGraph[2,6,9];

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

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

RecognizeGraph[g2]

(2,4,15)

g=BouwerGraph[2,4,10]

Try to contract

Tally[Sort[GraphDistanceMatrix[g][[1]]]]

m=5

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

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

SymmetricGraphQ[g2]

m=1

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

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

SymmetricGraphQ[g2]

(2,12,7)

g=BouwerGraph[2,12,7]

Try to contract

Tally[Sort[GraphDistanceMatrix[g][[1]]]]

m

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

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

RecognizeGraph[g2]

SymmetricGraphQ[g2]

(3,6,9)

6 (9^2)

(b3=BouwerGraph[3,6,9])//Timing

Through[{RegularQ,SymmetricQ,ArcTransitiveQ}[b3]]//Timing

HamiltonianGraphQ[AdjacencyGraph[AdjacencyMatrix[b3]]]

(4,6,9)

6 (9^3)

(b4=BouwerGraph[4,6,9])//Timing

Through[{RegularQ,SymmetricQ,ArcTransitiveQ}[b4]]//Timing

Holt Paper

b=MakeUndirected@MakeGraph[Flatten[Outer[List,Range[6],Range[9]],1],
((Mod[#1[[1]]+1-#2[[1]],6]==0||Mod[#1[[1]]-1-#2[[1]],6]==0)&&Mod[#2[[2]]-(#1[[2]]),9]==0)||
((Mod[#1[[1]]+1-#2[[1]],6]==0&&Mod[#1[[2]]+2^#1[[1]]-#2[[2]],9]==0))||
((Mod[#1[[1]]-1-#2[[1]],6]==0&&Mod[#1[[2]]-2^(#1[[1]]-1)-#2[[2]],9]==0))&,Type->Directed]

ShowGraph[b]

RecognizeGraph[b]

Through[{ArcTransitiveQ,EdgeTransitiveQ,VertexTransitiveQ}[b]]

HamiltonianGraphQ[AdjacencyGraph[AdjacencyMatrix[b]]]

General

ok=Select[Flatten[Table[{m,n},{m,2,20},{n,2,20}],1],Mod[2^#[[1]]-1,#[[2]]]==0&]

i0=Select[Flatten[Table[{n,Sequence@@#}&/@ok,{n,2,4}],1],#[[2]]((#[[3]])^(#[[1]]-1))<1000&]

g=Monitor[{i=#,BouwerGraph@@#}&/@i0,i];//Timing

Symmetric Check

Monitor[Select[g,!SymmetricGraphQ[gr=#[[1]];#[[2]]]&],gr]//Timing

Recognize

old=DeleteCases[{#[[1]],RecognizeGraph[#[[2]]]}&/@g,{_,{}}];

Grid[{#[[1]],GraphData[#[[2]],"Name"]}&/@old,Dividers->True,Alignment->Left]

SortBy[{GetGraphData[#,"File"],#}&/@old[[All,2]],First]

GraphData["Qt66","V"]

Arc-Intransitive

ait=Monitor[Select[g,(gr=#[[1]];!ArcTransitiveQ[#[[2]]])&],gr];//Timing

t=SortBy[{V[#[[2]]],#[[1]]}&/@ait,First]

Append[Take[t,5][[All,2]],{3,6,9}]

Grid[Select[t,First[#]≤100&],Dividers->All,Alignment->{{Right,Left}}]

Table[!ArcTransitiveQ[BouwerGraph[n,4,5]],{n,2,5}]

Table[!ArcTransitiveQ[BouwerGraph[n,3,7]],{n,2,5}]

Table[!ArcTransitiveQ[BouwerGraph[n,6,7]],{n,2,5}]

GraphData

GraphClassString

GraphClassString[{{"Bouwer",4}}]

GraphDataString

file=OpenWrite["~/bouwer.m"];

WriteString[file,GraphDataString[BouwerGraph@@#,
"StandardName"->{"Bouwer",#},
"Name"->"("<>StringTake[StringReplace[ToString[#]," "->""],{2,-2}]<>")\[Hyphen]Bouwer graph",
Debug->True,
TimeConstraint->10,
"Information"->"Bouwer"
]]&/@{{2,6,9},{2,4,15},{2,9,7},{2,12,7},{3,4,5},{3,6,9}};

Close[file]