Grabarchuk Graph

Author

Eric W. Weisstein
July 12, 2025

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

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

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

Definition

Re: from Knuth re an interesting graph

On 7/11/25 11:17 PM, Maggie McLoughlin wrote:

In 2018, Serhiy Grabarchuk told me about the graph that you get from a 4x4x4 cube by saying that two vertices are adjacent when the Euclidean distance between them is 3.

I filed the idea away, but just came across it again.

This graph is regular of degree 6 (and I think that's surprising!). For example, the neighbors of 000 are 122, 212, 221, 300, 030, and 003.  The neighbors of 001 are 123, 213, 222, 301, 031, and 220.  The neighbors of 111 are 330, 332, 303, 323, 033, amd 233.

Have you seen it before?  Does it have more than 48 automorphisms?

If I base any exercises/examples in TAOCP on this graph, I'm planning to call it the "Grabarchuk graph", unless I learn of another provenance.

Best, Don

PS Holy Grail would be three disjoint Hamiltonian cycles.
(Maybe impossible, but who knows?)

Classes

GraphData["GrabarchukGraph","Classes"]

Select[GraphData["Classes"],MissingQ[GraphData["GrabarchukGraph",#]]&]

Embeddings

<<MathWorld`Graphs`

"GrabarchukGraph"

Names

GraphData["GrabarchukGraph","StandardName"]

GraphData["GrabarchukGraph","StandardNames"]

Primary

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

All

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

Inexact

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

Embeddings

GraphDataEmbeddings[GraphData["GrabarchukGraph"]]

Default embedding

GraphPlot[Graph[GraphData["GrabarchukGraph","VertexList"],GraphData["GrabarchukGraph","Edges"]]]

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

g=FindCorrespondingGraph[,v]

RecognizeGraph@g

Degenerate

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

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

GeneralizedPetersen

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

IGraph

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

Bilateral

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

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

Circular

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

Circular construction

GraphData["GrabarchukGraph","Hamiltonian"]

GraphData["GrabarchukGraph","LCF"]

GraphData["GrabarchukGraph","HamiltonianCycleCount"]

Planar

GraphData["GrabarchukGraph","Planar"]

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

MinimalCrossingNumber: "EmbeddingScheme" -> 1

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

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

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

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

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

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

MinimalCrossingNumber: "EmbeddingScheme" -> 2

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

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

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

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

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

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

MinimalCrossingNumber: "EmbeddingScheme" -> 3

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

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

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

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

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

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

MinimalCrossing

GraphData["GrabarchukGraph","CN"]

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

MinimalRectilinearCrossing

GraphData["GrabarchukGraph","RCN"]

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

MinimalRectilinearCrossing construction order X [minimum RCN == ]

Length[gs=FindMinimalRectilinearCrossingGraph[GraphData["GrabarchukGraph"],Automatic,All,"Size"->Automatic,Method->"SubgraphIsomorphism",Debug->True]]//Timing

MaxMemoryUsed[]/10^9. GB

Tally[RectilinearCrossingCount/@gs]//Timing

Tally[RectilinearLocalCrossingCount/@gs]//Timing

GraphSymmetryGroup/@gs//Tally

Select[gs,GraphSymmetryGroup[#]=!=TransformationGroup[{}]&]

Take[gs,UpTo[100]]

MinimalRectilinearCrossing construction order X [minimum RCN == ]

Length[gs=FindMinimalRectilinearCrossingGraph[GraphData["GrabarchukGraph"],Automatic,All,"Size"->XXX,Method->"SubgraphIsomorphism",Debug->True]]//Timing

MaxMemoryUsed[]/10^9. GB

Tally[RectilinearCrossingCount/@gs]//Timing

Tally[RectilinearLocalCrossingCount/@gs]//Timing

GraphSymmetryGroup/@gs//Tally

Select[gs,GraphSymmetryGroup[#]=!=TransformationGroup[{}]&]

Take[gs,UpTo[100]]

MinimalCrossing construction

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

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

faces=ReverseSort@SymmetricallyDistinctFaces[g]

Tally[ReverseSort[Length/@faces]]

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

Select[tuttegraphs,GraphSymmetryGroup[#,AdditionalData->Join[Table[True,GraphData["GrabarchukGraph","V"]],Table[False,cn]],SameTest->Equal]=!=TransformationGroup[{}]&]

Select[tuttegraphs,Count[OuterFace[#],_?(GreaterThan[GraphData["GrabarchukGraph","V"]])]==0&]

Select[tuttegraphs,Count[OuterFace[#],_?(GreaterThan[GraphData["GrabarchukGraph","V"]])]==1&]

(gs=Table[RotateGraph[MinimalCrossingGraph[GraphData["GrabarchukGraph"],"CrossingNumber"->cn,RandomSeed->n]],{n,1000}]//Union)//Timing

Select[gs,Count[OuterFace[#],_?(GreaterThan[GraphData["GrabarchukGraph","V"]])]==0&]

Select[gs,Count[OuterFace[#],_?(GreaterThan[GraphData["GrabarchukGraph","V"]])]==1&]

Select[gs,GraphSymmetryGroup[#,AdditionalData->Join[Table[True,GraphData["GrabarchukGraph","V"]],Table[False,cn]],SameTest->Equal]=!=TransformationGroup[{}]&]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

RectilinearLocalCrossingCount[g]

MinimalLocalCrossing

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

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

MinimalRectilinearLocalCrossing

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

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

MinimaRectilinearlLocalCrossing construction

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

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

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

Select[gs,GraphSymmetryGroup[#,AdditionalData->Join[Table[True,GraphData["GrabarchukGraph","V"]],Table[False,cn]],SameTest->Equal]=!=TransformationGroup[{}]&]

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

Select[gs,GraphSymmetryGroup[#,AdditionalData->Join[Table[True,GraphData["GrabarchukGraph","V"]],Table[False,cn]],SameTest->Equal]=!=TransformationGroup[{}]&]

Circulant

GraphData["GrabarchukGraph","Circulant"]

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

Circulant construction

GraphData["GrabarchukGraph","NotationRules","Circulant"]

(ci=CirculantIndices[GraphData["GrabarchukGraph"]])//Timing

CirculantGraph1@@@ci

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

CirculantGraph1@@@%

Complement graph

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

Line graph

GraphData["GrabarchukGraph","Line"]

LineGraphQ[GraphData["GrabarchukGraph"]]//Timing

RootGraph

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

RootGraph[GraphData["GrabarchukGraph"]]

Halin

GraphData["GrabarchukGraph","Halin"]

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

Rigid

GraphData["GrabarchukGraph","Rigid"]

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

Flexible

GraphData["GrabarchukGraph","Flexible"]

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

LCF

GraphData["GrabarchukGraph","LCF"]

GraphData["GrabarchukGraph","HamiltonianCycleCount"]

GraphData["GrabarchukGraph","LCFSignature"]

GraphData["GrabarchukGraph","LCFNotations"]

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

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

LCF compute random

FindRandomLCFNotation[GraphData["GrabarchukGraph"],TimeConstraint->120]

FindRandomLCFNotation[GraphData["GrabarchukGraph"],TimeConstraint->3600]

FindRandomLCFNotation[GraphData["GrabarchukGraph"],TimeConstraint->86400]

LCF compute 10^5 [4.5 GB]

Tally[(lcf=LCF[GraphData["GrabarchukGraph"],10^5])[[All,2]]]//Timing

MaxMemoryUsed[]/10.^9 "GB"

DeleteCases[lcf,{_,1}]

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

LCF compute 10^6 [5.0 GB]

Tally[(lcf=LCF[GraphData["GrabarchukGraph"],10^6])[[All,2]]]//Timing

MaxMemoryUsed[]/10.^9 "GB"

DeleteCases[lcf,{_,1}]

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

LCF compute 10^7 [48.1 GB]

Tally[(lcf=LCF[GraphData["GrabarchukGraph"],10^7])[[All,2]]]//Timing

MaxMemoryUsed[]/10.^9 "GB"

DeleteCases[lcf,{_,1}]

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

LCF compute 4*^7 [192.0 GB]

Tally[(lcf=LCF[,4*^7])[[All,2]]]//Timing

MaxMemoryUsed[]/10.^9 "GB"

DeleteCases[lcf,{_,1}]

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

LCF compute all

Divisors[GraphData["GrabarchukGraph","V"]]

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

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

MaxMemoryUsed[]/10.^9 "GB"

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

DeleteCases[lcf,{_,1}]

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

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

Length[gs]

gs

BilateralGraphEmbeddingQ/@gs

UnitDistance

GraphData["GrabarchukGraph","UnitDistance"]

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

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

UnitDistance by refinement

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

UnitDistanceGraphEmbeddingQ[%]

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

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

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

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

Matchstick

GraphData["GrabarchukGraph","Matchstick"]

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

3D default

Graph3D[GraphData["GrabarchukGraph","Edges"]]

3D construction

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

RecognizeGraph[g]

3D All

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

GraphData["GrabarchukGraph","EmbeddingClasses3D"]

DegenerateGraphEmbeddingTypes/@%

3D UnitDistance construction

g0=GraphData["GrabarchukGraph","Graph","3D"]

EdgeLengths@g0

g=Annotate[g0,VertexCoordinates->GraphEmbedding[g0]/3]

UnitDistanceGraphEmbeddingQ[g]

3D UnitDistance

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

3D Polyhedron

GraphData["GrabarchukGraph","Polyhedral"]

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

Properties

CyclePolynomial

GraphData["GrabarchukGraph","CyclePolynomial"]

HamiltonianCycleCount

GraphData["GrabarchukGraph","HamiltonianCycleCount"]

HamiltonianCycles

GraphData["GrabarchukGraph","HamiltonianCycles"]

HamiltonDecomposable

cyc=FindHamiltonDecomposition[GraphData["GrabarchukGraph"],Debug->True]

HamiltonDecompositionQ[GraphData["GrabarchukGraph"],cyc]

HighlightGraph[GraphData["GrabarchukGraph"],UndirectedEdge@@@Partition[#,2,1,1],ImageSize->Medium]&/@cyc

HighlightGraph[GraphData["GrabarchukGraph"],UndirectedEdge@@@Partition[#,2,1,1]&/@cyc]

PathPolynomial

GraphData["GrabarchukGraph","PathPolynomial"]

Construction

EuclideanDistanceGraph[GridGraph1[{4,4,4}],3]

RecognizeGraph[%]

GrabarchukGraph[i_List,d_,opts___?OptionQ]:=Module[{v=Tuples[Range/@i],e,n=Times@@i},e=Select[Subsets[Range[n],{2}],SquaredEuclideanDistance@@v[[#]]==d^2&];
Graph[Range[n],UndirectedEdge@@@e,VertexCoordinates->v,opts]]

RecognizeGraph/@Table[GrabarchukGraph[{2,2,2},n],{n,4}]

RecognizeGraph/@Table[GrabarchukGraph[{3,3,3},n],{n,4}]

RecognizeGraph/@Table[GrabarchukGraph[{4,4,4},n],{n,4(Sqrt[3])}]

RecognizeGraph/@Table[GrabarchukGraph[{5,5,5},n],{n,5(Sqrt[3])}]

g=GrabarchukGraph[{4,4,4},3]

RecognizeGraph@g

HouseOfGraphsLookup[g]

new={{"GrabarchukGraph",Graph[VertexList@g,EdgeList@g]}}

VertexDegree[g]//Tally

GraphAutomorphismGroup[g]//GroupOrder

HamiltonianGraphQ[g]//Timing

Neighbors

v=GraphEmbedding[g];

Annotate[g,VertexLabels->Automatic]

Corner

neighbors=Select[VertexList[g],SquaredEuclideanDistance[v[[4]],v[[#]]]==3^2&]

v[[4]]-#&/@v[[neighbors]]

HighlightGraph[g,{Style[4,Green],neighbors}]

Edge

neighbors=Select[VertexList[g],SquaredEuclideanDistance[v[[8]],v[[#]]]==3^2&]

v[[8]]-#&/@v[[neighbors]]

HighlightGraph[g,{Style[8,Green],neighbors}]

Face

neighbors=Select[VertexList[g],SquaredEuclideanDistance[v[[24]],v[[#]]]==3^2&]

v[[24]]-#&/@v[[neighbors]]

HighlightGraph[g,{Style[24,Green],neighbors}]

Interior

neighbors=Select[VertexList[g],SquaredEuclideanDistance[v[[23]],v[[#]]]==3^2&]

v[[23]]-#&/@v[[neighbors]]

HighlightGraph[g,{Style[23,Green],neighbors}]

GraphData

GraphDataClassString

GraphDataClassString["GrabarchukGraph"]

GraphDataString

<<MathWorld`Graphs`

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

WriteString[file,GraphDataString[
,
"StandardName"->"GrabarchukGraph",
"Name"->"Grabarchuk graph",
Debug->True,
TimeConstraint->10,
"Skip"->{"Arboricity","ConnectedInducedSubgraphPolynomial","ConstructionNumber","Cycles","CyclicEdgeConnectivity","DetourMatrix","DominatingSets","EulerianCycles","HamiltonianPaths","IdiosyncraticPolynomial","IndependencePolynomial","IndependentEdgeSets","IndependentVertexSets","IrredundancePolynomial","LinklesslyEmbeddable","LongestCycles","MatchingGeneratingPolynomial","MaximalIndependentEdgeSet","MaximalIndependentEdgeSets","MaximumIndependentEdgeSetCount","MaximumIndependentEdgeSets","MetricDimension","Meyniel","MinimumConnectedDominatingSet","MinimumCyclicEdgeCuts","MinimumDominatingSets","MinimumTotalDominatingSets","MinimumWeightFractionalEdgeColoring","Minors","ProjectivePlanar","QuadraticEmbeddingConstant","Thickness","TotalDominatingSets","TotalDominationPolynomial","TuttePolynomial","UnitDistance"}
]];

Close[file]