Heule Graphs

Author

Eric W. Weisstein
January 1, 2022

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

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

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

Additional Authors

Graph discovered by and embeddings from:
Marijn Heule
PolyMath website

Graphic

DateString[]

heule=GraphData["Heule*"]

ColorGraph[g_Graph]:=Module[{col=FindVertexColoring[g],cols={Red,Green,Yellow,Green,Blue}},
Annotate[g,{EdgeStyle->Directive[LightGray],VertexStyle->MapIndexed[#2[[1]]->cols[[#]]&,col]}]
]

GraphicsGrid[Partition[Show[ColorGraph[GraphData[#]],PlotLabel->Style[GraphData[#,"Name"],Directive[Black,FontSlant->Italic,FontFamily->"Times"]]]&/@Reverse[heule],UpTo[4]],ImageSize->700,Dividers->All]

Table

Print[{#,VertexChromaticNumber[GraphData[#]]//Timing,UnitDistanceGraphEmbeddingQ[GraphData[#],WorkingPrecision->∞]//Quiet//Timing}]&/@heule;

TextGrid[GraphData[#,{"V","M","Name"}]&/@heule,Dividers->All]

Graphs

https://github.com/marijnheule/CNP-SAT

510-vertex

<<MathWorld`Graphs`

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Collections/UnitDistance/Heule/510"];

Length[v=ToExpression/@Import["510.vtx.txt","Lines"]]

Length[e=Rest[Import["510.edge.txt","Table"]][[All,2;;]]]

(HeuleGraph510=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v])

UnitDistanceGraphEmbeddingQ[HeuleGraph510,WorkingPrecision->∞]//Timing//Quiet

VertexChromaticNumber[HeuleGraph510]//Timing

GraphDataString

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

WriteString[file,GraphDataString[HeuleGraph510,
"StandardName"->"HeuleGraph510",
"Name"->"Heule graph 510",
"Information"->"HeuleGraphs",
"ChromaticNumber"->5,
"Skip"->{"CliqueCoveringNumber","ConnectedInducedSubgraphPolynomial","CrossingNumber","DominatingSet","GracefulLabeling","GracefulLabelings","IndependencePolynomial","MatchingGeneratingPolynomial","MatchingPolynomial","RadioNumber","TotalDominatingSet","VertexCover"},
TimeConstraint->5,
Debug->True]]

Close[file]

517-vertex

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Collections/UnitDistance/Heule/517"];

Length[v=ToExpression/@Import["517.vtx.txt","Lines"]]

Length[e=Rest[Import["517.edge.txt","Table"]][[All,2;;]]]

(HeuleGraph517=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v])

UnitDistanceGraphEmbeddingQ[HeuleGraph517,WorkingPrecision->∞]//FullSimplify//Timing//Quiet

VertexChromaticNumber[HeuleGraph517]//Timing

GraphDataString

file=OpenAppend["~/heule.m"]

WriteString[file,GraphDataString[HeuleGraph517,
"StandardName"->"HeuleGraph517",
"Name"->"Heule graph 517",
"Information"->"HeuleGraphs",
"ChromaticNumber"->5,
"Skip"->{"CliqueCoveringNumber","ConnectedInducedSubgraphPolynomial","CrossingNumber","DominatingSet","GracefulLabeling","GracefulLabelings","IndependencePolynomial","MatchingGeneratingPolynomial","MatchingPolynomial","RadioNumber","TotalDominatingSet","VertexCover"},
TimeConstraint->5,
Debug->True]]

Close[file]

529-vertex (https://arxiv.org/pdf/1907.00929.pdf)

Length[v=]

Length[e=]

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

RecognizeGraph[HeuleGraph529]

UnitDistanceGraphEmbeddingQ[HeuleGraph529,WorkingPrecision->∞]//FullSimplify//Timing

(col=FindVertexColoring[HeuleGraph529,Method->{"ILP",5}])//Timing

GraphDataString

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

WriteString[file,GraphDataString[HeuleGraph529,
"StandardName"->"HeuleGraph529",
"Name"->"Heule graph 293",
"Information"->"HeuleGraphs",
"ChromaticNumber"->5,
"Skip"->{"IndependencePolynomial","MatchingGeneratingPolynomial","MatchingPolynomial"},
TimeConstraint->10,
Debug->True]]

Close[file]

553-vertex (Marijn Heule, May 30, 2018)

https://arxiv.org/abs/1805.12181

Construction

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Collections/UnitDistance/553"]

FileNames[]

Length[v=ToExpression/@Import["553.vtx.txt","Lines"]]

Length[e=Rest[Import["553.edge.txt","Table"]][[All,2;;]]]

(HeuleGraph553=System`Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v])

UnitDistanceGraphEmbeddingQ[HeuleGraph553,WorkingPrecision->∞]//FullSimplify//Timing

GraphDataString

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

WriteString[file,GraphDataString[HeuleGraph553,
"StandardName"->"HeuleGraph553",
"Name"->"Heule graph 553",
"Information"->"HeuleGraphs",
"ChromaticNumber"->5,
"Skip"->{"IndependencePolynomial","MatchingGeneratingPolynomial","MatchingPolynomial"},
TimeConstraint->5,
Debug->True]]

Close[file]

610-vertex (Marijn Heule, May 14, 2018)

https://dustingmixon.wordpress.com/2018/05/10/polymath16-fifth-thread-human-verifiable-proofs/#comment-4465

There is still some slow, but steady progress in finding a smaller unit-distance graph with chromatic number 5. I have it now down to 610 vertices and 3000 edges. The image below shows this graph.

From image

img=;

Construction

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Collections/UnitDistance/610"]

FileNames[]

Length[v=ToExpression/@Import["610.vtx","Lines"]]

Length[e=Rest[Import["610.edge","Table"]][[All,2;;]]]

(HeuleGraph610=System`Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v])

UnitDistanceGraphEmbeddingQ[HeuleGraph610,WorkingPrecision->∞]//FullSimplify//Timing

GraphDataString

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

WriteString[file,GraphDataString[HeuleGraph610,
"StandardName"->"HeuleGraph610",
"Name"->"Heule graph 610",
"Information"->"HeuleGraphs",
"ChromaticNumber"->5,
"Skip"->{"IndependencePolynomial","MatchingGeneratingPolynomial","MatchingPolynomial"},
TimeConstraint->5,
Debug->True]]

Close[file]

633-vertex (Marijn Heule, May 6, 2018)

https://dustingmixon.wordpress.com/2018/05/05/polymath16-fourth-thread-applying-the-probabilistic-method/#comment-4316

I found a new record that is substantially smaller compared to the prior ones and it consists of only 633 vertices and 3166 edges. It is a subgraph of two copies of the Minkowski sum of  with  referring to the one from de Grey’s paper. The copies share the center vertex and are rotated in such a way that the points at distance 2 from the center become connected. The resulting graph is quite interesting and I am writing it up in a paper. I plan to get out by next weekend.

From image

img=;

{white,gray,black,yellow,red,green,blue}=DominantColors[img]

Length[redpts=ImageValuePositions[img,red,.1]]

Length[yellowpts=ImageValuePositions[img,yellow,.1]]

Length[greenpts=ImageValuePositions[img,green,.1]]

Length[bluepts=ImageValuePositions[img,blue,.1]]

Graphics[{
{Red,Point[redpts]},
{Yellow,Point[yellowpts]},
{Green,Point[greenpts]},
{Blue,Point[bluepts]}
}]

Length[yellowv=Mean/@FindClusters[yellowpts, Method->{"NeighborhoodContraction", "NeighborhoodRadius"->.01}]]//Timing

Length[redv=Mean/@FindClusters[redpts, Method->{"NeighborhoodContraction", "NeighborhoodRadius"->.01}]]//Timing

Length[greenv=Mean/@FindClusters[greenpts, Method->{"NeighborhoodContraction", "NeighborhoodRadius"->.01}]]//Timing

Length[greenv=Mean/@FindClusters[greenpts, Method->{"NeighborhoodContraction", "NeighborhoodRadius"->.01}]]//Timing

Length[bluev=Mean/@FindClusters[bluepts, Method->{"NeighborhoodContraction", "NeighborhoodRadius"->.01}]]//Timing

Length[v=Join[yellowv,redv,greenv,bluev]]

633-%

Show[{img,With[{r=8},Graphics[{EdgeForm[Black],
{Disk[#,r]&/@redv},
{Disk[#,r]&/@yellowv},
{Disk[#,r]&/@greenv},
{Disk[#,r]&/@bluev}
}]]},ImageSize->1000]

Construction

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Collections/UnitDistance/633"]

FileNames[]

Length[v=ToExpression/@Import["633.vtx","Lines"]]

Length[e=Rest[Import["633.edge","Table"]][[All,2;;]]]

(HeuleGraph633=System`Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v])

UnitDistanceGraphEmbeddingQ[HeuleGraph633,WorkingPrecision->∞]//FullSimplify//Timing

GraphDataString

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

WriteString[file,GraphDataString[HeuleGraph633,
"StandardName"->"HeuleGraph633",
"Name"->"Heule graph 633",
"Information"->"HeuleGraphs",
"ChromaticNumber"->5,
"Skip"->{"IndependencePolynomial","MatchingGeneratingPolynomial","MatchingPolynomial"},
TimeConstraint->5,
Debug->True]]

Close[file]

803-vertex (Marijn Heule, Apr. 30, 2018)

https://dustingmixon.wordpress.com/2018/04/22/polymath16-second-thread-what-does-it-take-to-be-5-chromatic/#comment-4105

By improving the heuristics, the random probing approach found an even smaller unit-distance graph with chromatic number 5. This one has 803 vertices and 4144 edges.

Construction

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Collections/Hadwiger-Nelson/803"]

FileNames[]

Length[v=ToExpression/@Import["803.vtx.txt","Lines"]]

Length[e=Rest[Import["803.edge.txt","Table"]][[All,2;;]]]

(HeuleGraph803=System`Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v])

Properties

TriangleFreeGraphQ[HeuleGraph803]

UnitDistanceGraphEmbeddingQ[HeuleGraph803,WorkingPrecision->∞]//FullSimplify//Timing

GraphDataString

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

WriteString[file,GraphDataString[HeuleGraph803,
"StandardName"->"HeuleGraph803",
"Name"->"Heule graph 803",
"Information"->"HeuleGraphs",
"ChromaticNumber"->5,
"Skip"->{"IndependencePolynomial","MatchingGeneratingPolynomial","MatchingPolynomial"},
TimeConstraint->5,
Debug->True]]

Close[file]

826-vertex (Marijn Heule, Apr. 16, 2018)

https://dustingmixon.wordpress.com/2018/04/14/polymath16-first-thread-simplifying-de-greys-graph/#comment-3867

Marijn Heule says:
April 16, 2018 at 7:40 pm
The random probing approach found a smaller unit-distance graph with chromatic number 5. This one has “only” 826 vertices and 4273 edges.

GraphData

g=GraphData[gname="HeuleGraph826"]

GraphData[gname,"Graph","All"]

GraphData[gname,"Graph","UnitDistance"]

GraphData[gname,{"V","M"}]

GraphData[gname,"VertexCoordinates"]//Union//Length

GraphData[gname,"UnitDistance"]

UnitDistanceGraphEmbeddingQ[g,WorkingPrecision->∞]//FullSimplify//Quiet//Timing

GraphData[gname,"ChromaticNumber"]

Construction

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Collections/Hadwiger-Nelson/826"]

FileNames[]

Length[v=ToExpression/@Import["826.vtx.txt","Lines"]]

Length[e=Rest[Import["826.edge.txt","Table"]][[All,2;;]]]

(HeuleGraph826=System`Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v])

Properties

TriangleFreeGraphQ[HeuleGraph826]

UnitDistanceGraphEmbeddingQ[HeuleGraph826]

UnitDistanceGraphEmbeddingQ[HeuleGraph826,WorkingPrecision->∞]//FullSimplify//Timing//Quiet

FindVertexColoring[HeuleGraph826,Method->"Brelaz"]//Max//Timing

FindVertexColoring[HeuleGraph826,Method->"Combinatorica"]//Max//Timing

FindVertexColoring[HeuleGraph826,Method->{"ILP",3}]//Max//Timing

GraphDataString

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

WriteString[file,GraphDataString[HeuleGraph826,
"StandardName"->"HeuleGraph826",
"Name"->"Heule graph 826",
"Information"->"HeuleGraphs",
"ChromaticNumber"->5,
"Skip"->{"IndependencePolynomial","MatchingGeneratingPolynomial","MatchingPolynomial"},
TimeConstraint->5,
Debug->True]]

874-vertex (Marijn Heule, Apr. 14, 2018)

http://michaelnielsen.org/polymath1/index.php?title=Hadwiger-Nelson_problem

https://polymathprojects.org/2018/04/10/polymath-proposal-finding-simpler-unit-distance-graphs-of-chromatic-number-5/#comment-120318

Construction

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Collections/Hadwiger-Nelson/874"]

FileNames[]

Length[v=ToExpression/@Import["874.vtx.txt","Lines"]]

Length[e=Rest[Import["874.edge.txt","Table"]][[All,2;;]]]

e[[1]]//InputForm

(HeuleGraph874=System`Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v])

GraphData

g=GraphData[gname="HeuleGraph874"]

GraphData[gname,"Graph","All"]

GraphData[gname,"Graph","UnitDistance"]

GraphData[gname,{"V","M"}]

GraphData[gname,"VertexCoordinates"]//Union//Length

GraphData[gname,"UnitDistance"]

UnitDistanceGraphEmbeddingQ[g,WorkingPrecision->∞]//FullSimplify//Quiet//Timing

GraphData[gname,"ChromaticNumber"]

Construction

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Collections/Hadwiger-Nelson/826"]

FileNames[]

Length[v=ToExpression/@Import["826.vtx.txt","Lines"]]

Length[e=Rest[Import["826.edge.txt","Table"]][[All,2;;]]]

e[[1]]//InputForm

(HeuleGraph826=System`Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v])

Compute Properties

TriangleFreeGraphQ[HeuleGraph826]

UnitDistanceGraphEmbeddingQ[HeuleGraph826]

UnitDistanceGraphEmbeddingQ[HeuleGraph826,WorkingPrecision->∞]//FullSimplify//Timing//Quiet

FindVertexColoring[HeuleGraph826,Method->"Brelaz"]//Max//Timing

FindVertexColoring[HeuleGraph826,Method->"Combinatorica"]//Max//Timing

FindVertexColoring[HeuleGraph826,Method->{"ILP",3}]//Max//Timing

GraphDataString

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

WriteString[file,GraphDataString[HeuleGraph826,
"StandardName"->"HeuleGraph826",
"Name"->"Heule graph 826",
"Information"->"HeuleGraphs",
"ChromaticNumber"->5,
"Skip"->{"IndependencePolynomial","MatchingGeneratingPolynomial","MatchingPolynomial"},
TimeConstraint->5,
Debug->True]]

Compute properties

TriangleFreeGraphQ[g]

UnitDistanceGraphEmbeddingQ[g]

UnitDistanceGraphEmbeddingQ[g,WorkingPrecision->∞]//FullSimplify//Timing

FindVertexColoring[g,Method->"Brelaz"]//Max//Timing

FindVertexColoring[g,Method->"Combinatorica"]//Max//Timing

FindVertexColoring[g,Method->{"ILP",3}]//Max//Timing

GraphDataString

WriteString[file,GraphDataString[HeuleGraph874,
"StandardName"->"HeuleGraph874",
"Name"->"Heule graph 874",
"Information"->"HeuleGraphs",
"ChromaticNumber"->5,
"Skip"->{"IndependencePolynomial","MatchingGeneratingPolynomial","MatchingPolynomial"},
TimeConstraint->5,
Debug->True]]

Close[file]

deGreyGraph (1581-vertex)

https://gilkalai.wordpress.com/2018/04/10/aubrey-de-grey-the-chromatic-number-of-the-plane-is-at-least-5/#comment-40108

April 10, 2018 at 11:10 pm
Update: the smallest case may need to be revised up to 1585 vertices. Many thanks to Brendan McKay and Gordon Royle for letting me know overnight that they had successfully 4-coloured my 1567er; as a result I found a bug in the part of my code that implements the relaxation described in section 5.4 and now it agrees. Mercifully this only means, in the worst case, that fewer than nine vertices can be removed from S to make Sa; the worst case is that we could remove none, which leaves the full graph with 1585 vertices, and I’m pleased to say that Dustin Mixon and Boris Alexeev have confirmed the non-4-colorability of that graph using a completely different algorithm than mine (a SAT solver):

ag24ag24 says:
April 11, 2018 at 6:51 pm
Update: after fixing my bug and re-running the code that seeks deletions from Sa, I now find that just two vertices can be deleted wtthout introducing a problematic (as defined in section 5.4) 4-coloring. This therefore leads to a size of 1581 for the full 5-chromatic graph (which contains two copies of Sa).

1585-vertex

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Collections/Hadwiger-Nelson/1585"]

FileNames[]

bug(350483): Import[graph.dimacs"] emits "Import::unsup: Unsupported type of DIMACS file." and returns $Failed (in contradiction to documentation, which states "Import and Export fully support the DIMACS format.")

Length[v]

Length[v=Get["1585v.txt"]]

Length[e=Select[Subsets[Range[Length[v]],{2}],EuclideanDistance@@v[[#]]==1.&]]//Quiet//Timing

Put[e,"1585e.txt"]

e

g1585=System`Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v]

UnitDistanceGraphEmbeddingQ[g]

TriangleFreeGraphQ[g]