Nechushtan Graph

Author

Eric W. Weisstein
July 26, 2023

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

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

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

Sources

Nechushtan 2002

Fig. 5 in 
Discrete Mathematics 256 (2002) 499–507
On the space chromatic number
Oren Nechushtan

De Grey and Haugstrup

de Grey, A. and Haugstrup, A.  "Two small 6-chromatic unit-distance graphs in R."  Geocombinatorics 30, 5–13, 2020.

GraphData["NechushtanGraph","Graph","3D"]

v=GraphData["NechushtanGraph","Embeddings","3D"]

Select[Subsets[Range[10],{6}],UnitDistanceGraphEmbeddingQ[IndexGraph@Subgraph[GraphData["NechushtanGraph","Graph","3D"],#]]&]

Properties

GraphData["NechushtanGraph","V"]

GraphData["NechushtanGraph","ChromaticNumber"]

Embeddings

<<MathWorld`Graphs`

2D

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

GraphicsRow[%]

GraphData["NechushtanGraph","EmbeddingClasses"]

3D

GraphData["NechushtanGraph","Graph","3D"]

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

GraphData["NechushtanGraph","EmbeddingClasses3D"]

Embeddings

<<MathWorld`Graphs`

Names

GraphData["NechushtanGraph","StandardName"]

GraphData["NechushtanGraph","StandardNames"]

Primary

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

All

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

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

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData["NechushtanGraph","EdgeList"]]

Default embedding

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

v=Join[UnitCirclePoints[8],{0,#/2}&/@{-1,1}];
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[{1,8},1,9,8,5,10,4,1,3,10,6,9,3],e[5,7,9,2,4],e[7,10,2],{6,8}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

Degenerate

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

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

Bilateral

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

Circular

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

Circular construction

Length[hc=FindHamiltonianCycle[GraphData["NechushtanGraph"],All][[All,All,1]]]

Length[bilat=DeleteDuplicatesBy[
DeleteMissing[BilaterallyRotatedGraph@CircularEmbeddingFromHamiltonianCycle[GraphData["NechushtanGraph"],#]&/@hc],
CircularCanonicalGraphEmbedding]]//Timing

gs=bilat

Length[quad=DeleteDuplicatesBy[Union@Select[bilat,BilateralGraphEmbeddingQ[#,Axis->"X"]&],CircularCanonicalGraphEmbedding[#,4]&]]

quad

gs=Join[{,,},{,,,,,,,,,}]

Planar

GraphData["NechushtanGraph","Planar"]

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

MinimalCrossing

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

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

Minimalistic construction

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

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

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

GraphData["NechushtanGraph","Polyhedral"]

faces=ReverseSort@SymmetricallyDistinctFaces[g]

Tally[ReverseSort[Length/@faces]]

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

GraphPlot@

v={{0,0},{1,0},{1,1},{0,1},{1/4,1/4},{1/2,1/4},{1/2,1/2},{3/4,1/2},{1/4,3/4},{1/2,3/4}};
g=Graph[Range@Length@v,UndirectedEdge@@@{e[1,2,3,4,1,9,5,4,9,10,7,6,5,1,6,8,10,4],e[6,2,8,3,10],e[2,7,3],{7,8},{5,10},{6,9}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@g

RectilinearCrossingCount@g

GraphPlot@

v={{-1,0},{1,0},{0,Sqrt[3]},{-1/4,1/4},{1/4,1/4},{-1/8,1/2},{1/8,1/2},{-1/4,3/4},{1/4,3/4},{0,5/4}};
g=Graph[Range@Length@v,UndirectedEdge@@@{e[1,2,3,1,4,5,2,9,10,8,1],e[4,8,3,9,5,7,6,4,7,8,6,9,7],{5,6},{3,10},e[1,10,2]},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@g

RectilinearCrossingCount@g

GraphPlot@RotateGraph[,3Pi/4]

v={{-1,0},{1,0},{0,Sqrt[3]},{-1/4,1/4},{1/4,1/4},{-1/4,1/2},{1/4,1/2},{-1/4,3/4},{1/4,3/4},{0,5/4}};
g=Graph[Range@Length@v,UndirectedEdge@@@{e[1,5,4,2,3,1,4,6,8,10,9,7,5,2,9,8,1,10,2],e[8,3,9],e[4,7,6,5],{3,10},{1,6},{2,7}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@g

RectilinearCrossingCount@g

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

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

GraphPlot@RotateGraph[,-Pi/4]

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

RecognizeGraph@g

RectilinearCrossingCount@g

GraphPlot@RotateGraph[,-Pi/4]

v={{0,0},{1,0},{1,1},{0,1},{1/2,1/4},{1/2,3/4},{1/6,1/2},{1/3,1/2},{2/3,1/2},{5/6,1/2}};
g=Graph[Range@Length@v,UndirectedEdge@@@{e[1,2,3,4,1,7,4,6,9,2,10,3,9,5,7,6,3],e[7,8,1,5,2],e[4,8,6],{5,8},{9,10},e[5,10,6]},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@g

RectilinearCrossingCount@g

RotateGraph[,-Pi/4]

GraphPlot@

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

RecognizeGraph@g

RectilinearCrossingCount@g

gs=UnlabelGraph/@{,,,}

Circulant

GraphData["NechushtanGraph","Circulant"]

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

Line graph

GraphData["NechushtanGraph","Line"]

LineGraphQ[GraphData["NechushtanGraph"]]//Timing

RootGraph

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

RootGraph[GraphData["NechushtanGraph"]]

Halin

GraphData["NechushtanGraph","Halin"]

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

Rigid

GraphData["NechushtanGraph","Rigid"]

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

Flexible

GraphData["NechushtanGraph","Flexible"]

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

LCF

GraphData["NechushtanGraph","LCF"]

GraphData["NechushtanGraph","HamiltonianCycleCount"]

GraphData["NechushtanGraph","LCFSignature"]

GraphData["NechushtanGraph","LCFNotations"]

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

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

UnitDistance

GraphData["NechushtanGraph","UnitDistance"]

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

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

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

UnitDistance by refinement

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

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

GraphPlot@RotateGraph[,{10,5}]

v=Join[UnitCirclePoints[8],{0,#/2}&/@{-1,1}];
g=Graph[Range@Length@v,UndirectedEdge@@@{e[{1,8},1,4,2,9,7,5,8,10,2],e[6,10,3,1,10,7],e[5,9,4],e[6,9,3],{6,8}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@g

RectilinearCrossingCount@g

GraphPlot@RotateGraph[,{3,2}]

v=Join[CirclePoints[6],Subdivide[{0,1/2},{0,-1/2},3]];
g=Graph[Range@Length@v,UndirectedEdge@@@{e[1,2,3,4,5,6,1,3,10,2,9,5,8,2,7,5,10,4,9,3],e[4,6,8,1,7,6],{7,8},{9,10}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@g

RectilinearCrossingCount@g

gs=UnlabelGraph/@{,}

UnitDistance by FindUnitDistanceEmbedding

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

Matchstick

GraphData["NechushtanGraph","Matchstick"]

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

3D default

Graph3D[GraphData["NechushtanGraph","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["NechushtanGraph","Polyhedral"]

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

Construction

https://demonstrations.wolfram.com/ChromaticSpindles/

Three 3D spindles forcing a 5-coloring are given. Two were found by Raiskii and Nechushtan. In [3] a method for combining these two spindles into a graph of around 400 vertices is given, which proves that space needs six colors.

v=  {{-(1/2),-(1/2),0},{-(1/2),(1/2),0},{(1/2),-(1/2),0},{(1/2),(1/2),0},{-(5/6),0,-((Sqrt[23])/6)},{(5/6),0,-((Sqrt[23])/6)},{0,(1/16) (2-(Sqrt[46])),Root[1369-14080 ((#1)^2)+16384 ((#1)^4)&,2]},{0,(1/16) (-2+(Sqrt[46])),Root[1369-14080 ((#1)^2)+16384 ((#1)^4)&,2]},{0,(1/16) (-2-(Sqrt[46])),Root[1369-14080 ((#1)^2)+16384 ((#1)^4)&,1]},{0,(1/16) (2+(Sqrt[46])),Root[1369-14080 ((#1)^2)+16384 ((#1)^4)&,1]}};

e=Select[Subsets[Range[Length[v]],{2}],Abs[EuclideanDistance@@v[[#]]-1]<=.01&]//Quiet;

g0=Graph[Range@Length[v],UndirectedEdge@@@e,VertexCoordinates->v]

RecognizeGraph[g0,"Cache"->"InternalOnly"]

UnitDistanceGraphEmbeddingQ[g0,WorkingPrecision->∞]

ChromaticPolynomial[g0][x]

ChromaticNumber[g0]

CrossingNumber[g0,TimeConstraint->60]

GraphPlot[EdgeList[g]]

g=Graph[Range[10],UndirectedEdge@@@{{1,2},{2,3},{3,4},{1,4},{5,6},{6,7},{7,10},{10,9},{9,8},{5,8},{1,8},{4,5},{2,10},{3,7},{4,9},{3,9},{1,6},{2,6},{5,9},{9,7},{10,6},{8,6},{4,8},{3,10},{1,5},{2,7}},VertexLabels->"Name",VertexCoordinates->{{0,0},{1,0},{1,1},{0,1},{1/4,1/3},{1/2,1/3},{3/4,1/3},{1/4,2/3},{1/2,2/3},{3/4,2/3}}]

IsomorphicGraphQ[g,g0]

RectilinearCrossingCount[g]

v=CirclePoints[Csc[Pi/8]/2,8];

RegionIntersection[InfiniteLine[v[[{4,7}]]],InfiniteLine[v[[{2,5}]]]]//FullSimplify

g1=Graph[Range[10],UndirectedEdge@@@Join[Partition[Range[8],2,1,1],{9,#}&/@Range[2,7],{10,#}&/@{6,7,8,1,2,3},{{5,8},{1,4},{6,8},{5,7},{2,4},{1,3}}],VertexLabels->"Name",VertexCoordinates->Join[v,{{0,(1/2) (-1+Cot[(π/8)])},{0,-(1/2) (-1+Cot[(π/8)])}}]]

LamanGraphQ[g1]

IsomorphicGraphQ[g,g1]

ToCommonEdges[g1,g]//FullSimplify

ToCommonEdges[g0,g]

GraphData

GraphDataString

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

WriteString[file,GraphDataString[g,
"StandardName"->"NechushtanGraph",
"Name"->"Nechushtan graph",
Debug->True,
TimeConstraint->60
]]

Close[file]