McGregor Map

Author

Eric W. Weisstein
January 27, 2023

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

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

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

Graphics

GraphData["McGregorMap","Graph","Labeled"]

Table[HighlightMesh[GraphData["McGregorMap","MeshRegion"],Labeled[n,"Index"]],{n,0,2}]

GraphData["McGregorGraph"]

GraphData["McGregorGraph","ChromaticNumber"]

Not minimal via Brelaz:

Max@FindVertexColoring[GraphData@"McGregorGraph",Method->"Brelaz"]

Minimal via incremental ILP:

(col=FindVertexColoring[GraphData@"McGregorGraph",Method->"ILP",Debug->True])//Timing

col={3,2,2,4,4,1,2,2,4,1,1,3,4,4,2,4,4,1,1,3,3,4,2,2,2,2,4,1,1,1,1,3,3,3,4,4,4,1,2,2,3,3,2,2,4,4,1,4,1,1,1,4,3,3,3,2,2,4,2,2,2,3,3,4,1,4,4,3,3,1,4,2,1,1,3,1,3,2,1,3,4,2,3,1,2,3,4,2,3,1,4,2,2,4,3,1,1,2,4,2,3,3,1,4,2,3,1,4,1,3};

Max[col]

VertexColoringQ[GraphData@"McGregorGraph",col]

The ordering of faces in "McGregorMap" corresponds to the vertices in "McGregorGraph" (except that "McGregorMap" contains the additional bounding face, which must therefore be removed in the coloring graphic):

boundary=Union[Round[ConvexHullMesh[v=GraphData["McGregorMap","VertexCoordinates"]]["VertexCoordinates"]]]/.Thread[GraphData["McGregorMap","VertexCoordinates"]->Range[GraphData["McGregorMap","V"]]]

colorlist={Yellow,Blue,Red,Green};Graphics[{EdgeForm[Black],GraphicsComplex[v,MapIndexed[{FaceForm[colorlist[[col[[#2[[1]]]]]]],Polygon[#]}&,Select[GraphData["McGregorMap","Faces"],Sort[#]=!=boundary&]]]}]

Embeddings

"McGregorGraph"

GraphData["McGregorGraph","StandardName"]

All

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

Halin

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

Planar

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

Planar construction

GraphPlot[PlanarGraph[GraphData["McGregorGraph"],VertexSize->10]]

g=Graph[GraphData["McGregorGraph","EdgeList"],GraphLayout->"PlanarEmbedding"]

e=GraphEmbedding[g]//Round

g=Graph[GraphData["McGregorGraph","EdgeList"],VertexCoordinates->e]

PlanarGraphEmbeddingQ[g]

LCF

GraphData["McGregorGraph","LCFSignature"]

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

UnitDistance

GraphData["McGregorGraph","UnitDistance"]

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

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

Matchstick

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

MinimalCrossing

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

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

Default embedding

g=Graph@GraphData["McGregorGraph","Edges"]

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

RecognizeGraph[g]

MinimalCrossing Construction

GraphPlot@RotateGraph[MinimalCrossingGraph[GraphData["McGregorGraph"]]]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Maximum independent vertex sets

Annotate[HighlightGraph[GraphData["McGregorGraph"],#],VertexSize->{"Scaled",.02}]&/@GraphData["McGregorGraph","MaximumIndependentVertexSets"]

3D default

Graph3D[GraphData["McGregorGraph","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["McGregorGraph","Polyhedral"]

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

Graphics3D[{FaceForm[Green,Red],GraphData["McGregorGraph","Polyhedron"]}]

3D Canonical

GraphData["McGregorGraph","Graph",{"3D","Canonical"}]

Graphics3D[{Opacity[.5],Red,GraphData["McGregorGraph","Polyhedron"],Yellow,Sphere[]}]

3D Polyhedron construction

Graphics3D[{FaceForm[Green,Red],poly=GraphPolyhedron[GraphData["McGregorGraph"],-1],MapIndexed[Text[#2[[1]],#,Background->White]&,poly[[1]]]}]

v=poly[[1]];
v=ReplacePart[v,Rule[#,1.1v[[#]]]&/@{109,110,74,15}];
Graphics3D[{FaceForm[Green,Red],poly2=Polyhedron[v,poly[[2]]],MapIndexed[Text[#2[[1]],#,Background->White]&,poly2[[1]]]}]

(can=FindCanonicalPolyhedron[poly2,WorkingPrecision->100,MaxIterations->1000,PrecisionGoal->20,"ProgressInterval"->100,"TangentFactor"->1/20,"PlanarFactor"->1/20,Debug->True])//Timing

Graphics3D[can]

SimplePolyhedronQ[can]

(can=FindCanonicalPolyhedron[poly,WorkingPrecision->1000,MaxIterations->20000,PrecisionGoal->20])//Timing

Graphics3D[{Opacity[.5],Red,can,Yellow,Sphere[]}]

(lens=Mean/@Split[Sort[PolyhedronEdgeLengths[can]],Abs[#1-#2]<1.*^-10&])//N

v=PolyhedronCoordinates[can];

colors=With[{n=Length[lens]},Table[Hue[i/n],{i,0,n-1}]]

Graphics3D[{Thick,Sequence@@Nearest[Thread[lens->colors],EuclideanDistance@@v[[#]]],Line[v[[#]]]}&/@PolyhedronEdges[can],Boxed->False]

g=PolyhedronGraph[can]

3D Canonical construction from PolyhedralEmbedding

g=PlanarGraph[GraphData["McGregorGraph","Edges"]]

<<IGraphM`

Tally[Length/@GraphData["McGregorGraph","FaceIndices"]]

IGLayoutTutte[GraphData["McGregorGraph"]]

g=Graph[GraphData["McGregorGraph","Edges"],GraphLayout->"TutteEmbedding"]

Show[g2=PolyhedralEmbedding[g,"Circular"->True,"Scale"->2],Boxed->True]//Quiet

With[
{faces=PlanarFaceList[Graph[EdgeList[g2]]],v=GraphEmbedding@g2},
Graphics3D[{Point[{0,0,0}],Opacity[.5],Sphere[],FaceForm[Green,Red],
poly=Polyhedron[1.2v,faces]}]]

(can=FindCanonicalPolyhedron[poly,WorkingPrecision->100,MaxIterations->20000,PrecisionGoal->20,"ProgressInterval"->100,"TangentFactor"->1/5,"PlanarFactor"->1/5,Debug->True])//Timing

SimplePolyhedronQ[can]

If[%===False,Quit[]]

Graphics3D[{Opacity[.5],Red,can,Yellow,Sphere[]}]

(lens=Mean/@Split[Sort[PolyhedronEdgeLengths[can]],Abs[#1-#2]<1.*^-10&])//N

v=PolyhedronCoordinates[can];

colors=With[{n=Length[lens]},Table[Hue[i/n],{i,0,n-1}]]

Graphics3D[{Thick,Sequence@@Nearest[Thread[lens->colors],EuclideanDistance@@v[[#]]],Line[v[[#]]]}&/@PolyhedronEdges[can],Boxed->False]

g=PolyhedronGraph[can]

"McGregorMap"

GraphData["McGregorMap","StandardName"]

All

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

Halin

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

LCF

GraphData["McGregorMap","LCFSignature"]

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

UnitDistance

GraphData["McGregorMap","UnitDistance"]

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

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

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

Select[UnitDistanceEmbeddingRefine/@Complement@@(GraphData["McGregorMap","Graph",#]&/@{"All","UnitDistance"}),UnitDistanceGraphEmbeddingQ]

UnitDistanceGraphEmbeddingQ[]

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

UnitDistance FindSubgraphUnitDistanceEmbedding

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

gs=UniqueEmbeddings[l]

Matchstick

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

MinimalCrossing

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

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

Default embedding

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

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

RecognizeGraph[g]

MinimalCrossing construction

GraphPlot@RotateGraph[MinimalCrossingGraph[GraphData["McGregorMap"],"CrossingNumber"->-1]]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

3D default

Graph3D[GraphData["McGregorMap","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["McGregorMap","Polyhedral"]

History

Chartrand and Ping

MaxNexus

https://mathnexus.wwu.edu/archive/news/detail.asp?ID=19

In his April (1975) column in Scientific American, Martin Gardner claimed that this 110-region map required five colors and was thereby a counterexample to the four-color "theorem" (at most four colors are needed to color any planar map whose regions share a common boundary but do not share the same color).

I remember being caught up in the attempts to color in the regions...I even gave it to my middle school students to play with as extra credit. Then, in a subsequent issue, Martin Gardner confessed that his entire April (1975) column was an April Fool's joke on his readers. In fact, Stan Wagon, mathematics professor at Macalester College, produced a coloring that shows only four colors are needed to color Gardner's map.

It is now interesting (around this year's April Fool's Day) to look back at this hoax and how Martin Gardner introduced it:

"As a public service, I shall comment briefly on six major discoveries of 1974 that for one reason or another were inadequately reported to both the scientific community and the public at large. The most sensational of last year's discoveries in pure mathematics was surely the finding of a counterexample to the notorious four-color-map conjecture. That theorem, as all readers of this department must know, is that four colors are both necessary and sufficient for coloring all planar maps so that no two regions with a common boundary are the same color. It is easy to construct maps that require only four colors, and topologists long ago proved that five colors are enough to color any map. Closing the gap, however, had eluded the greatest minds in mathematics. Most mathematicians have believed that the four-color theorem is true and that eventually it would be established. A few suggested it might be Godel-undecidable. ] H.S.M. Coxeter, a geometer at the University of Toronto, stood almost alone in believing that the conjecture is false."

"Coxeter's insight has now been vindicated. In November 1974 William McGregor, a graph theorist of Wappingers Falls, N.Y., constructed a map of 110 regions that cannot be colored with fewer than five colors. McGregor's technical report will appear in 1978 in the Journal of Combinatorial Theory, Series B."

William McGregor is an actual person, who created the map and gave Gardner permission to use it as an April Fool's prank. In the follow-up column, Martin Gardner seemed almost apologetic:

I never dreamed anyone would take it seriously, yet it produced more than a thousand letters from readers who did not recognize the column as a hoax.

Scrape

FileNames["Polya*"]

g1=Show[Import["/Users/eww/Documents/Troves/MathOzTeX/graphics/pdf/AprilFourColoring.pdf"],ImageSize->Automatic]

polys=Select[Cases[g1,JoinedCurve[z_,p_,___]:>p[[1]],∞],Max[#[[All,1]]]<200&];

Graphics[Line[polys]]

roundedpolys=Round[10polys];

v=Union[Flatten[roundedpolys,1]]

faces=Sort[roundedpolys/.Thread[v->Range[Length[v]]]]

MeshRegion from scrape

origmesh=MeshRegion[v,Polygon/@faces]

HighlightMesh[origmesh,Labeled[2,"Index"]]

HighlightMesh[origmesh,Labeled[0,"Index"]]

Note that the faces scraped from the graphic do not include some intermediate vertices that lie upon edges, e.g.,
{9,25,26,10}, should be {9,25,26,17,10},

v[[{26,10}]]

v[[17]]

Mesh Region with intermediate points added (and duplicated trailing points removed)

newfaces=Sort@{
{9,25,26,17,10},
{13,22,33,34,14},
{17,26,37,38,27,18},
{21,32,45,46,33,22},
{25,49,50,37,26},
{27,38,51,52,39,28},
{31,44,59,60,45,32},
{33,46,61,62,34},
{37,50,65,66,51,38},
{39,52,67,68,53,40},
{43,58,75,76,59,44},
{45,60,77,78,61,46},
{49,81,82,65,50},
{51,66,83,84,67,52},
{53,68,85,86,69,54},
{57,74,93,94,75,58},
{59,76,95,96,77,60},
{61,78,97,98,62},
{65,82,101,102,83,66},
{67,84,103,104,85,68},
{69,86,105,106,87,70},
{73,92,114,115,93,74},
{75,94,116,117,95,76},
{77,96,118,119,97,78},
{81,120,121,101,82},
{83,102,122,123,103,84},
{85,104,124,125,105,86},
{87,106,126,127,107,88},
{91,113,132,133,114,92},
{93,115,134,135,116,94},
{95,117,136,137,118,96},
{97,119,138,139,98},
{101,121,142,143,122,102},
{103,123,144,145,124,104},
{105,125,146,147,126,106},
{107,127,148,149,128,108},
{109,129,150,151,152,130,111,110},
{114,133,155,156,134,115},
{116,135,157,158,136,117},
{118,137,159,160,138,119},
{120,141,163,164,142,121},
{122,143,165,166,144,123},
{124,145,167,168,146,125},
{126,147,169,170,148,127},
{132,154,173,174,155,133},
{134,156,175,176,157,135},
{136,158,177,178,159,137},
{138,160,179,180,139},
{140,259,260,247,227,199,163,141},
{142,164,183,184,165,143},
{144,166,185,186,167,145},
{146,168,187,188,169,147},
{155,174,191,192,175,156},
{157,176,193,194,177,158},
{159,178,195,196,179,160},
{163,199,200,183,164},
{165,184,201,202,185,166},
{167,186,203,204,187,168},
{175,192,207,208,193,176},
{177,194,209,210,195,178},
{179,196,211,212,180},
{183,200,215,216,201,184},
{185,202,217,218,203,186},
{193,208,221,222,209,194},
{195,210,223,224,211,196},
{199,227,228,215,200},
{201,216,229,230,217,202},
{209,222,233,234,223,210},
{211,224,235,236,212},
{215,228,239,240,229,216},
{223,234,243,244,235,224},
{227,247,248,239,228},
{235,244,251,252,236},
{131,153,154,132,113,112},
{4,9,10,7,8,5},
{5,8,11,12,21,22,13,6},
{11,16,19,20,31,32,21,12},
{18,15,16,11,8,7,10,17},
{19,24,29,30,43,44,31,20},
{23,28,39,40,35,36,29,24},
{29,36,41,42,57,58,43,30},
{35,40,53,54,47,48,41,36},
{41,48,55,56,73,74,57,42},
{47,54,69,70,63,64,55,48},
{55,64,71,72,91,92,73,56},
{63,70,87,88,79,80,71,64},
{71,80,89,90,112,113,91,72},
{79,88,107,108,99,100,89,80},
{128,129,109,110,100,99,108},
{129,128,149,161,162,151,150},
{130,131,112,90,89,100,110,111},
{148,170,181,182,171,162,161,149},
{151,162,171,172,153,131,130,152},
{171,182,189,190,173,154,153,172},
{187,204,213,214,205,198,197,188},
{189,198,205,206,191,174,173,190},
{203,218,225,226,219,214,213,204},
{205,214,219,220,207,192,191,206},
{217,230,237,238,231,226,225,218},
{219,226,231,232,221,208,207,220},
{229,240,245,246,241,238,237,230},
{231,238,241,242,233,222,221,232},
{241,246,249,250,243,234,233,242},
{249,254,255,256,251,244,243,250},
{255,257,258,252,251,256},
{18,27,28,23,24,19,16,15},
{188,197,198,189,182,181,170,169},
{248,253,254,249,246,245,240,239},
{14,2,1,140,141,120,81,49,25,9,4,5,6,13},
{260,261,3,2,14,34,62,98,139,180,212,236,252,258,257,255,254,253,248,247}
};

Select[newfaces,DeleteDuplicates[#]=!=#&]

Counts[Length/@newfaces]

Select[newfaces,Length[#]==7&]

Length[newfaces]

e=DeleteCases[Union[Flatten[(Sort/@Partition[#,2,1,1])&/@newfaces,1]],{x_,x_}];

Check that no edge passes over a point without being incident

Position[
Monitor[Table[If[MemberQ[v[[e[[ei]]]],#],False,RegionMember[Line[v[[e[[ei]]]]],#]]&/@v,{ei,Length[e]}],ei],True]

Manipulate[Column[{newfaces[[i]],Graphics[{
EdgeForm[Black],FaceForm[None],PointSize[.007],GraphicsComplex[v,Join[
Polygon/@newfaces,
{FaceForm[Yellow],EdgeForm[Red],Polygon[newfaces[[i]]]},
{{PointSize[.02],Red,Point[newfaces[[i]]]}},
{Point[Range[Length[v]]]}]],MapIndexed[Text[#2[[1]],#+{1,1}15]&,v]}]}],{i,1,Length[v],1}]

randomcolored=Graphics[{EdgeForm[Black],PointSize[.02],GraphicsComplex[v,Join[
{FaceForm[Hue[RandomReal[]]],Polygon[#]}&/@newfaces,
{Point[Range[Length[v]]]}]]}
]

mesh=MeshRegion[v,Polygon/@newfaces]

HighlightMesh[mesh,Labeled[0,"Index"]]

HighlightMesh[mesh,Labeled[2,"Index"]]

Map as a graph

e=DeleteCases[Union[Flatten[(Sort/@Partition[#,2,1,1])&/@newfaces,1]],{x_,x_}];

map=System`Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v,VertexLabels->"Name"]

RecognizeGraph[map]

Through[{VertexCount,EdgeCount}[map]]

EdgeList[g]

Graph of Adjacent Faces

adjfaces=Select[Subsets[Range[Length[newfaces]],{2}],Length[Intersection@@newfaces[[#]]]>1&]

centroids=RegionCentroid[Polygon[v[[#]]]]&/@newfaces;//Quiet

graph=System`Graph[Union[Flatten[adjfaces]],UndirectedEdge@@@adjfaces,VertexCoordinates->centroids,VertexLabels->"Name",VertexSize->Large]

Show[{Graphics[{EdgeForm[Black],FaceForm[LightYellow],GraphicsComplex[v,Polygon/@newfaces]}],graph}]

pos=If[RegionMember@@#===True,#[[2]],RandomPoint[#[[1]]]]&/@Transpose[{Polygon[v[[#]]]&/@newfaces,centroids}]

graph2=System`Graph[Union[Flatten[adjfaces]],UndirectedEdge@@@adjfaces,VertexCoordinates->pos,VertexLabels->"Name",VertexSize->Large]

Show[{Graphics[{EdgeForm[Black],FaceForm[LightYellow],GraphicsComplex[v,Polygon/@newfaces]}],graph2}]

Through[{VertexCount,EdgeCount}[graph]]

GraphData["GardnerGraph",{"V","E","F"}]

adj=mesh["ConnectivityMatrix"[2,1]];(*face-edge connectivity*)

adj

m=adj.Transpose[adj]

m["NonzeroPositions"]

adjm=Unitize[adj.Transpose[adj]] (*face-face connectivity*)

Union[Sort/@Position[Normal[adjm]-IdentityMatrix[110],1]]===adjfaces

newg2=SimpleGraph[AdjacencyGraph[adjm]]

IsomorphicGraphQ[newg,newg2]

GraphData

Graph

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

WriteString[file,GraphDataString[graph2,
"StandardName"->"McGregorGraph",
"Name"->"McGregor graph",
"Information"->"McGregorMap",
TimeConstraint->10]]

Map

WriteString[file,GraphDataString[map,
"StandardName"->"McGregorMap",
"Name"->"McGregor map",
"Information"->"McGregorMap",
TimeConstraint->10]]

Close[file]