Bigdrum Graph

Author

Eric W. Weisstein
July 27, 2026

This notebook downloaded from https://mathworld.wolfram.com/notebooks/GraphTheory/BigdrumGraph.nb.

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

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

Figure

GraphicsGrid[
Partition[
StyleGraphs[
GraphData["BigdrumGraph","Graph","All"]
],
UpTo[5]
],
Dividers->All
]

Embeddings

<<MathWorld`Graphs`

Names

GraphData["BigdrumGraph","StandardName"]

GraphData["BigdrumGraph","StandardNames"]

HouseOfGraphs

hogid=GraphData["BigdrumGraph","NotationRules","HouseOfGraphs"]

HouseOfGraphsLookup[hogid]

HouseOfGraphsGraph[hogid]//StyleGraphs[#,ImageSize->Small]&

Wikidata

GraphData["BigdrumGraph","WikidataID"]

GraphData["BigdrumGraph","WikidataID","URL"]

Primary

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

All

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

CurvedEdge

GraphData["BigdrumGraph","Graph","CurvedEdge"]//StyleGraphs

Inexact

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

Degenerate

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

DegenerateGraphEmbeddingTypes/@GraphData["BigdrumGraph","Graph","Degenerate"]//Column

Embeddings

GraphDataEmbeddings[GraphData["BigdrumGraph"]]

Default embedding

g0=GraphPlot[Graph[GraphData["BigdrumGraph","VertexList"],GraphData["BigdrumGraph","Edges"]]]

Configuration

GraphData["BigdrumGraph","Configuration"]

configurations=GraphData["BigdrumGraph","Graph","Configuration"]//StyleGraphs

GeneralizedPetersen

GraphData["BigdrumGraph","Graph","GeneralizedPetersen"]//StyleGraphs

IGraph

GraphData["BigdrumGraph","Graph","IGraph"]//StyleGraphs

CompleteKPartite

GraphData["BigdrumGraph","Graph","CompleteKPartite"]//StyleGraphs

Bipartite

GraphData["BigdrumGraph","Bipartite"]

GraphData["BigdrumGraph","Graph","Bipartite"]//StyleGraphs

Bilateral

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

Grid[DeleteCases[Monitor[{g=#,BilateralGraphEmbeddingTypes[#],GraphSymmetryGroup[#]}&/@GraphData["BigdrumGraph","Graph","All"],g],{_,_,TransformationGroup[{}]}],Dividers->All,Alignment->{{Center,{Left}}}]//Quiet

Circular

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

Circular construction All

GraphData["BigdrumGraph","Hamiltonian"]

GraphData["BigdrumGraph","HamiltonianCycles"]

GraphData["BigdrumGraph","HamiltonianCycleCount"]

GraphData["BigdrumGraph","LCF"]

GraphData["BigdrumGraph","LCFSignature"]

BilateralHamiltonianCycleQ[GraphData["BigdrumGraph"]]

FindBilateralHamiltonianCycle[GraphData["BigdrumGraph"]]

Planar

GraphData["BigdrumGraph","Planar"]

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

MinimalCrossingNumber crossings.uos.de [verified 3]

CrossingNumber[GraphData["BigdrumGraph"],Method->"WebCompute"]//AbsoluteTiming

DateString[]

MinimalCrossingNumber: "EmbeddingScheme" -> 1

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

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

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

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

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

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

MinimalCrossingNumber: "EmbeddingScheme" -> 2

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

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

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

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

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

(cn=CrossingNumber[GraphData["BigdrumGraph"],"EmbeddingScheme"->2,TimeConstraint->86400])//AbsoluteTiming

MinimalCrossingNumber: "EmbeddingScheme" -> 3

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

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

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

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

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

(cn=CrossingNumber[GraphData["BigdrumGraph"],"EmbeddingScheme"->3,TimeConstraint->86400])//AbsoluteTiming

MinimalCrossing

GraphData["BigdrumGraph","CN"]

(gs=GraphData["BigdrumGraph","Graph","MinimalCrossing"])//StyleGraphs

GraphCrossingCount/@gs

GraphCrossingDiagram/@gs

MinimalRectilinearCrossing

GraphData["BigdrumGraph","RCN"]

GraphData["BigdrumGraph","Graph","MinimalRectilinearCrossing"]//StyleGraphs

MinimalCrossing construction Tutte

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

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

MinimalCrossing construction Random 1k [102 s]

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

Length[diagrams=DistinctMinimalCrossingDiagramData[
GraphData["BigdrumGraph"],
1000,
"CrossingNumber"->cn,
EdgeShapeFunction->"BezierEdge"
]]//AbsoluteTiming

No crossing points on the boundary:

Length[diagrams0=Lookup[Select[diagrams,MinimalCrossingOuterCrossingCount[#]==0&],"Graph",{}]]//Timing

Take[diagrams0,UpTo[10]]

One crossing point on the boundary:

Length[diagrams1=Lookup[Select[diagrams,MinimalCrossingOuterCrossingCount[#]==1&],"Graph",{}]]//Timing

Take[diagrams1,UpTo[10]]

graphs=#["Graph"]&/@diagrams;

Symmetric embeddings:

RandomGraphsWithSymmetryGroups={
#,
GraphSymmetryGroup[#]
}&/@graphs;//AbsoluteTiming

MaxMemoryUsed[]/10^9.GB

Symmetric embeddings:

Length[SymmetricMinimalEmbeddingData=DeleteCases[
RandomGraphsWithSymmetryGroups,
{_,TransformationGroup[{}]}
]
]//AbsoluteTiming

SymmetricMinimalEmbeddingData

SymmetricMinimalEmbeddingGraphs=SymmetricMinimalEmbeddingData[[All,1]]

RecognizeGraph/@gs

GraphCrossingCount/@SymmetricMinimalEmbeddingGraphs

GraphCrossingDiagram/@SymmetricMinimalEmbeddingGraphs

GraphPlot[RotateGraph[StraightenGraph[#],Pi/2]]&/@{,,}

gs=ToGridEmbedding/@{,,}

RecognizeGraph/@gs

GraphCrossingCount/@gs

GraphCrossingDiagram/@gs

MinimalCrossing construction Random 5k [XXX s]

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

Length[diagrams=DistinctMinimalCrossingDiagramData[
GraphData["BigdrumGraph"],
5000,
"CrossingNumber"->cn,
EdgeShapeFunction->"BezierEdge"
]]//AbsoluteTiming

No crossing points on the boundary:

Length[diagrams0=Lookup[Select[diagrams,MinimalCrossingOuterCrossingCount[#]==0&],"Graph",{}]]//Timing

Take[diagrams0,UpTo[10]]

One crossing point on the boundary:

Length[diagrams1=Lookup[Select[diagrams,MinimalCrossingOuterCrossingCount[#]==1&],"Graph",{}]]//Timing

Take[diagrams1,UpTo[10]]

graphs=#["Graph"]&/@diagrams;

Symmetric embeddings:

RandomGraphsWithSymmetryGroups={
#,
GraphSymmetryGroup[#]
}&/@graphs;//AbsoluteTiming

MaxMemoryUsed[]/10^9.GB

Symmetric embeddings:

Length[SymmetricMinimalEmbeddingData=DeleteCases[
RandomGraphsWithSymmetryGroups,
{_,TransformationGroup[{}]}
]
]//AbsoluteTiming

SymmetricMinimalEmbeddingData

SymmetricMinimalEmbeddingGraphs=SymmetricMinimalEmbeddingData[[All,1]]

GraphCrossingCount/@SymmetricMinimalEmbeddingGraphs

GraphCrossingDiagram/@SymmetricMinimalEmbeddingGraphs

MinimalCrossing construction Random 20k [XXX s]

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

Length[diagrams=DistinctMinimalCrossingDiagramData[
GraphData["BigdrumGraph"],
20*^3,
"CrossingNumber"->cn,
EdgeShapeFunction->"BezierEdge"
]]//AbsoluteTiming

No crossing points on the boundary:

Length[diagrams0=Lookup[Select[diagrams,MinimalCrossingOuterCrossingCount[#]==0&],"Graph",{}]]//Timing

Take[diagrams0,UpTo[10]]

One crossing point on the boundary:

Length[diagrams1=Lookup[Select[diagrams,MinimalCrossingOuterCrossingCount[#]==1&],"Graph",{}]]//Timing

Take[diagrams1,UpTo[10]]

graphs=#["Graph"]&/@diagrams;

Symmetric embeddings:

RandomGraphsWithSymmetryGroups={
#,
GraphSymmetryGroup[#]
}&/@graphs;//AbsoluteTiming

MaxMemoryUsed[]/10^9.GB

Symmetric embeddings:

Length[SymmetricMinimalEmbeddingData=DeleteCases[
RandomGraphsWithSymmetryGroups,
{_,TransformationGroup[{}]}
]
]//AbsoluteTiming

SymmetricMinimalEmbeddingData

SymmetricMinimalEmbeddingGraphs=SymmetricMinimalEmbeddingData[[All,1]]

GraphCrossingCount/@SymmetricMinimalEmbeddingGraphs

GraphCrossingDiagram/@SymmetricMinimalEmbeddingGraphs

MinimalCrossing construction Random 1k [old]

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

(RandomGraphs=Table[MinimalCrossingGraph[GraphData["BigdrumGraph"],"CrossingNumber"->cn,RandomSeed->n],{n,1000}]//Union);//Timing

RandomGraphsWithOuterCrossingPointCounts={
#,
Count[OuterFace[#],_?(GreaterThan[GraphData["BigdrumGraph","V"]])]
}&/@RandomGraphs;

Small numbers of crossing points on the boundary:

Cases[RandomGraphsWithOuterCrossingPointCounts,{g_,0}:>g]

Cases[RandomGraphsWithOuterCrossingPointCounts,{g_,1}:>g]

Symmetric embeddings:

RandomGraphsWithSymmetryGroups={
#,
GraphSymmetryGroup[
#,
AdditionalData->Join[Table[True,GraphData["BigdrumGraph","V"]],Table[False,cn]],
SameTest->Equal
]
}&/@RandomGraphs;

MaxMemoryUsed[]/10^9.GB

DeleteCases[
RandomGraphsWithSymmetryGroups,
{_,TransformationGroup[{}]}
]/.g_Graph:>BilateralGraph[CenterGraph@g,"ReturnNonbilateralGraph"->True]

MinimalCrossing construction Random 20k [old]

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

(RandomGraphs=Table[MinimalCrossingGraph[GraphData["BigdrumGraph"],"CrossingNumber"->cn,RandomSeed->n],{n,20000}]//Union);//Timing

RandomGraphsWithOuterCrossingPointCounts={
#,
Count[OuterFace[#],_?(GreaterThan[GraphData["BigdrumGraph","V"]])]
}&/@RandomGraphs;

Small numbers of crossing points on the boundary:

Cases[RandomGraphsWithOuterCrossingPointCounts,{g_,0}:>g]

Cases[RandomGraphsWithOuterCrossingPointCounts,{g_,1}:>g]

Symmetric embeddings:

RandomGraphsWithSymmetryGroups={
#,
GraphSymmetryGroup[
#,
AdditionalData->Join[Table[True,GraphData["BigdrumGraph","V"]],Table[False,cn]],
SameTest->Equal
]
}&/@RandomGraphs;

MaxMemoryUsed[]/10^9.GB

DeleteCases[
RandomGraphsWithSymmetryGroups,
{_,TransformationGroup[{}]}
]/.g_Graph:>BilateralGraph[CenterGraph@g,"ReturnNonbilateralGraph"->True]

MinimalLocalCrossing

GraphData["BigdrumGraph",{"LocalCrossingNumber","RectilinearLocalCrossingNumber"}]

GraphData["BigdrumGraph","Graph","MinimalLocalCrossing"]//StyleGraphs

MinimalRectilinearLocalCrossing

GraphData["BigdrumGraph",{"LocalCrossingNumber","RectilinearLocalCrossingNumber"}]

GraphData["BigdrumGraph","Graph","MinimalRectilinearLocalCrossing"]//StyleGraphs

MinimaRectilinearlLocalCrossing construction 1000

AdjacentCrossingsQ[g_Graph,cn_Integer]:=Module[{a=AdjacencyList[g],n=VertexCount[g]-cn},Max[Take[a,-cn]]>n]

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

(gs=Select[Table[MinimalCrossingGraph[GraphData["BigdrumGraph"],"CrossingNumber"->cn,RandomSeed->i],{i,1000}],!AdjacentCrossingsQ[#,cn]&]//Union)//Timing

MinimaRectilinearlLocalCrossing construction 20000

AdjacentCrossingsQ[g_Graph,cn_Integer]:=Module[{a=AdjacencyList[g],n=VertexCount[g]-cn},Max[Take[a,-cn]]>n]

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

(gs=Select[Table[MinimalCrossingGraph[GraphData["BigdrumGraph"],"CrossingNumber"->cn,RandomSeed->i],{i,20000}],!AdjacentCrossingsQ[#,cn]&]//Union)//Timing

Circulant

GraphData["BigdrumGraph","Circulant"]

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

Circulant construction

GraphData["BigdrumGraph","NotationRules","Circulant"]

(ci=CirculantIndices[GraphData["BigdrumGraph"]])//AbsoluteTiming

CirculantGraph1@@@ci

Cases[GraphData["BigdrumGraph","StandardNames"],{"Circulant",i_}:>i]

CirculantGraph1@@@%

Complement graph

compl=GraphData["BigdrumGraph","ComplementGraph","Name"]

Line graph

GraphData["BigdrumGraph","Line"]

LineGraphQ[GraphData["BigdrumGraph"]]//Timing

RootGraph

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

RootGraph[GraphData["BigdrumGraph"]]

Halin

GraphData["BigdrumGraph","Halin"]

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

Rigid

GraphData["BigdrumGraph","Rigid"]

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

Flexible

GraphData["BigdrumGraph","Flexible"]

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

Voltage

gs=GraphData["BigdrumGraph","Graph","Voltage"]//StyleGraphs

VoltageGraphNotation/@gs//Column

Voltage construction

VoltageGraph[GraphData["BigdrumGraph"],"MaxResults"->20,Debug->True]

gs=Take[%,XXX]

LCF

GraphData["BigdrumGraph","LCF"]

GraphData["BigdrumGraph","HamiltonianCycleCount"]

GraphData["BigdrumGraph","LCFSignature"]

GraphData["BigdrumGraph","LCFNotations"]

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

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

LCF compute All

Divisors[GraphData["BigdrumGraph","V"]]

{1,2,3,6,9,18}

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

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

MaxMemoryUsed[]/10.^9 "GB"

DeleteCases[lcf,{_,1}]

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

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

Length[gs=nicelcfgs]

gs

NiceLCFEmbeddingsWithSymmetryGroups={#,GraphSymmetryGroup[#]}&/@gs;

DeleteCases[NiceLCFEmbeddingsWithSymmetryGroups,{_,TransformationGroup[{Reflection[InfiniteLine[{0,0},{0,-1}]]}]}]

UnitDistance

GraphData["BigdrumGraph","UnitDistance"]

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

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

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

UnitDistance by refinement of default embeddings

Graph[edge list]

(g=UnitDistanceEmbeddingRefine[Graph[GraphData["BigdrumGraph","EdgeList"]],MaxIterations->500])//Timing

UnitDistanceGraphEmbeddingQ[g]

Graph[vertex list, edge list]

(g=UnitDistanceEmbeddingRefine[Graph[GraphData["BigdrumGraph","VertexList"],GraphData["BigdrumGraph","EdgeList"]],MaxIterations->500])//Timing

UnitDistanceGraphEmbeddingQ[g]

UnitDistance by refinement of existing embeddings

gs=UnitDistanceEmbeddingRefine[Graph[VertexList[#],EdgeList[#],VertexCoordinates->GraphEmbedding[#]],MaxIterations->500]&/@Complement@@(GraphData["BigdrumGraph","Graph",#]&/@{"All","UnitDistance"})

TextGrid[
gdata=SortBy[
{#,DegenerateGraphEmbeddingQ[#],GraphSymmetryGroup[#],Max[Abs[EdgeLengths[#]-1]]}&/@gs,
Last
],
Dividers->All
]

Cases[gdata,{__,0.}]

Symmetric:

gs=Cases[
gdata,
{g_,_,sym:Except[TransformationGroup[{}]],diff_}:>{
HighlightGraph[g1=BilateralGraph[CenterGraph[g],"ReturnNonbilateralGraph"->True],Flatten[FindCoincidentVertices[g1]]],
sym,
diff
}]

UnitDistance by refinement of stored LCF embeddings

FileByteCount[file=FileNameJoin[{$PropertiesDir,"LCFNotations-Nice",GraphNameToFileName["BigdrumGraph",".m.gz"]}]]

Tally[(lcf=Import[file])[[All,-1]]]//Timing//AbsoluteTiming

lcf=LCFNotation/@nicelcfgs;

gs=UnitDistanceEmbeddingRefine[LCFGraph@@#,MaxIterations->500]&/@lcf;//Timing

gdata=SortBy[
{#,Max[Abs[EdgeLengths[#]-1]]}&/@gs,
Last
]

Cases[gdata,{g_?UnitDistanceGraphEmbeddingQ,_}:>g]

NondegenerateSymmetricGraphs=Select[
gdata,
And[
DegenerateGraphEmbeddingQ[#[[1]]]===False,
GraphSymmetryGroup[#[[1]]]=!=TransformationGroup[{}]
]&
]/.g_Graph:>CenterGraph[g]

UnitDistance by FindUnitDistanceEmbedding  (random embeddings returning on messages)

gs=FindUnitDistanceEmbedding[GraphData["BigdrumGraph"],50,"ReturnWithMessage"->True];//Quiet//Timing

gdata=SortBy[
{#,Max[Abs[EdgeLengths[#]-1]]}&/@gs,
Last
]

Cases[gdata,{g_?UnitDistanceGraphEmbeddingQ,_}:>g]

SymmetricEmebddings=Select[gdata,GraphSymmetryGroup[#[[1]]]=!=TransformationGroup[{}]&]

UnitDistance by FindUnitDistanceEmbedding  (random embedding waiting until UD is found)

FindUnitDistanceEmbedding[GraphData["BigdrumGraph"],"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance by FindSubgraphUnitDistanceEmbedding

{$Version,DateString[]}

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

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

Select[IndexGraph/@gs,!DegenerateGraphEmbeddingQ[#]&&GraphSymmetryGroup[#]=!=TransformationGroup[{}]&]//Timing

Matchstick

GraphData["BigdrumGraph","Matchstick"]

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

3D default

Graph3D[GraphData["BigdrumGraph","Edges"]]

3D construction

3D All

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

3D UnitDistance construction Random

GraphData["BigdrumGraph","Dimension"]

(g=UnitDistanceEmbeddingRefine[
Graph3D[
GraphData["BigdrumGraph","VertexList"],
GraphData["BigdrumGraph","EdgeList"]
],
WorkingPrecision->25])//Timing

EdgeLengths[g]

UnitDistanceGraphEmbeddingQ[g]

3D UnitDistance

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

3D Polyhedron

GraphData["BigdrumGraph","Polyhedral"]

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

Construction

Robertson et al. 2019

v=Join[Sequence@@Table[{i,j},{i,0,3},{j,0,3}],{{-1,3/2},{4,3/2}}];
g=Graph[Range[Length[v]],UndirectedEdge@@@Sort[{{1,5},{5,9},{9,13},{2,7},{7,10},{10,15},{11,14},{6,11},{3,6},{13,14},{14,15},{15,16},{4,8},{8,12},{12,16},{1,2},{2,3},{3,4},{4,17},{1,17},{13,18},{16,18},{17,18},{5,6},{9,10},{7,8},{11,12}}],VertexCoordinates->v,VertexLabels->"Name"]

CubicGraphQ[g]

RecognizeGraph[g]

MinimalRectilinearCrossing by hand

GraphPlot[Graph[GraphData["BigdrumGraph","Edges"]]]

v={{0,0},{2/6,0},{4/6,0},{1,0},{1,1},{0,1},{1/6,1/4},{2/6,1/4},{3/6,1/4},{5/6,1/4},{1/6,1/2},{2/6,1/2},{4/6,1/2},{5/6,1/2},{1/6,3/4},{2/6,3/4},{3/6,3/4},{4/6,3/4}};
g=Graph[Range[Length[v]],UndirectedEdge@@@Sort[Sort/@{Sequence@@Partition[Range[6],2,1,1],{1,7},{7,12},{2,8},{8,11},{14,18},{5,18},{3,13},{8,9},{9,10},{10,14},{13,14},{12,13},{9,17},{7,11},{11,15},{6,15},{4,10},{15,16},{16,17},{17,18},{12,16}}],VertexLabels->"Name",VertexCoordinates->v]

r=RecognizeGraph[g]

rcn=RectilinearCrossingCount@g

vs=ToCommonEdges[g,GraphData[r]]

MinimalRectilinearCrossing by Planarization

mc=MinimalCrossingGraph[GraphData["BigdrumGraph"],"CrossingNumber"->3]

mc2=VertexDelete[mc,Range[19,21]]

d=VertexDegree[mc2]

add=Flatten[MapIndexed[Table[#2[[1]],#]&,3-d]]

Length[sub=Select[Subsets[Subsets[add,{2}],{Length[add]/2}],Intersection[EdgeList[mc2],#]==={}&]]

gs=SetProperty[EdgeAdd[mc2,UndirectedEdge@@@#],{VertexLabels->None,VertexCoordinates->Take[GraphEmbedding[mc],18]}]&/@sub;

SelectFirst[gs,IsomorphicGraphQ[#,GraphData["ConcertinaGraph"]]&]

r=RecognizeGraph[g]

Circular

GraphData["BigdrumGraph","Graphics","All"][[1]]

c=CirclePoints[12];

v=Join[c,{Mean[c[[{7,12}]]],Mean[c[[{1,6}]]]},Flatten[Table[{i c[[7,1]],j c[[9,2]]},{i,{-1,1}},{j,{-1,1}}],1]]

g=Graph[Range[Length[v]],UndirectedEdge@@@Join[Partition[Range[12],2,1,1],{{11,13},{8,13},{13,14},{2,14},{5,14},{10,18},{9,17},{3,16},{4,15},{7,18},{12,17},{6,16},{1,15},{15,18},{16,17}}],VertexCoordinates->v,VertexLabels->"Name"]

RecognizeGraph@g

UnitDistance

soln=Solve[{
(2x)^2+(2y)^2==1,
(x-1/2)^2+(y-h)^2==1,
(a-1/2)^2+b^2==1,
(x-c)^2+(1/2+y)^2==1,
(a-1/2)^2+(b-h)^2==1,
(a-c)^2+(b-1/2)^2==1},{x,y,a,b,c,h},Reals]//RootReduce

gs=Select[Graph[Range[18],UndirectedEdge@@@{{1,2},{1,3},{1,5},{2,4},{2,6},{3,7},{3,11},{4,8},{4,12},{5,10},{5,13},{6,9},{6,14},{7,8},{7,15},{8,16},{9,11},{9,17},{10,12},{10,18},{11,13},{12,14},{13,15},{14,16},{15,17},{16,18},{17,18}},VertexCoordinates->({{-1/2,h},{1/2,h},{-a,b},{a,b},{-x,y},{x,y},{-1/2,0},{1/2,0},{-x,-y},{x,-y},{-c,1/2},{c,1/2},{-c,-1/2},{c,-1/2},{-a,-b},{a,-b},{-1/2,-h},{1/2,-h}}/.#),VertexLabels->"Name"]&/@soln,!DegenerateEmbeddingQ[#]&]

RecognizeGraph/@gs

UnitDistanceGraphEmbeddingQ/@gs

DegenerateEmbeddingQ/@gs

gs=Reverse[gs]

GraphData

GraphDataClassString

GraphDataClassString["BigdrumGraph"]

GraphDataString

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

WriteString[file,GraphDataString[g,
"StandardName"->"BigdrumGraph",
"Name"->"bigdrum graph",
TimeConstraint->10,
Debug->True,
"Skip"->{"Arboricity"}
]]

Close[file]