Vertex Coloring

Author

Eric W. Weisstein
February 28, 2024

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

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

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

Figure

Combinatorica

vertexColors[g_Graph]:=Module[
{
l=VertexColoring[g],
n,
colors={Red,Green,Blue,Orange}
},
n=Max[l];
RGBColor@@@Take[colors,n][[l]]
]

gr[g_Graph]:=Graphics[showGraph[g,
VertexColors->vertexColors[g],
PlotStyles->AbsolutePointSize[8]],
PlotRange->All]

Show[GraphicsArray[{gr/@{Wheel[8],UtilityGraph,PetersenGraph,FruchtGraph}}]]

GraphPlot (can’t be done?)

{
GraphPlot[GraphData[{"Wheel",8}],"VertexColor"->Red],
GraphPlot[GraphData[{"Wheel",8}],"VertexColor"->{Red}],
GraphPlot[GraphData[{"Wheel",8}],"VertexColor"->{1->Red,2->Green}],
GraphPlot[GraphData[{"Wheel",8}],VertexRenderingFunction->(Red&)]
}

System`Graph

Table[Show[Graphics[{Hue[i /10],Disk[{0,0},1]}],ImageSize->Tiny],{i,0,9}]

ColoredVertices[g_,inds_]:=Module[{colfn,vl=VertexList[g],cn=Max[inds],defcols={Red,Green,Blue,Yellow}},If[Length[inds]=!=Length[vl],Return[$Failed]];
If[cn≤Length[defcols],colfn[c_]:=defcols[[c]],(*Else*)colfn[c_]:=Hue[(c-1.)/cn]];
SetProperty[g,{System`VertexStyle->(MapIndexed[vl[[#2[[1]]]]->Directive[colfn[#]]&,inds]),VertexSize->Medium}]]

fig=With[{g={"Wheel",8}},ColoredVertices[GraphData[g],GraphData[g,"MinimumVertexColoring"]]]

With[{g="K6"},ColoredVertices[GraphData[g],GraphData[g,"MinimumVertexColoring"]]]

Missing

DateString[]

GraphData["ChromaticNumber","Missing"]===GraphData["MinimumVertexColoring","Missing"]

TextGrid[missing=Cases[
Sort[GraphData[#,{"MaximalIndependentVertexSetCount","V","ChromaticNumber","#"}]&/@GraphData[All]],{v__,_Missing,g_}:>{v,g}
],Alignment->{{{Decimal},Left},Automatic},Dividers->All]

Intersection[missing[[All,1]],GraphData["Bipartite"]]

Length[missing]

Export["/Users/eww/Documents/Mathematica/Paclets/GraphData/Data/ForPratt/MinimumVertexColoring.tsv",{GraphNameToPrattName[#3],#1,#2/._Missing->0}&@@@missing]

Special cases

data=ToExpression@Import["/home/usr2/eww/mma/Graphs/Batch/Properties/MinimumVertexColoring-UpperLimits.m","Lines"]

TextGrid[data2=SortBy[{#1,GraphData[#,"V"],Max[#2[[2]]]}&@@@data,Last],Dividers->All]

"ZaraGraph"

Upper bound:

GraphData[All];

$Version

(col1=FindVertexColoring[GraphData["ZaraGraph"]])//Timing

Union[col1]

Max[col1]

Gurobi 11-vertex:

*12500088   852              53       0.0000000    0.00000  0.00%   298 28799s

Cutting planes:
  Gomory: 1
  Clique: 124
  Flow cover: 50
  Zero half: 20

Explored 12501990 nodes (3720808982 simplex iterations) in 28799.25 seconds
Thread count was 16 (of 32 available processors)

Solution count 1: 0

Optimal solution found (tolerance 1.00e-04)
Best objective 0.000000000000e+00, best bound 0.000000000000e+00, gap 0.0000%

Max[col={1,5,8,2,10,4,9,11,8,3,10,4,3,6,2,4,11,1,5,9,2,2,7,9,3,3,5,1,3,6,5,2,9,10,11,10,11,5,8,3,3,6,2,5,6,1,5,9,10,8,2,9,4,8,9,9,1,1,2,10,8,11,4,9,11,3,7,5,10,11,7,2,6,6,3,7,6,7,11,11,4,3,10,10,9,11,4,7,1,7,7,2,3,9,4,3,2,7,10,11,11,5,10,1,6,8,9,10,9,11,10,10,4,9,2,10,5,5,4,9,4,2,8,1,6,11}]

VertexColoringQ[GraphData["ZaraGraph"],col]

Gurobi 10-vertex:

{"Grassmann", {2, {5, 2}}}

GraphData[{"Grassmann",{2,{5,2}}},"V"]

Upper bound:

VertexChromaticNumber[GraphData[{"Grassmann",{2,{5,2}}}]]//Timing

"HoffmanSingletonLineDistance2Graph"

GraphData["HoffmanSingletonLineDistance2Graph","V"]

Upper bound:

VertexChromaticNumber[GraphData["HoffmanSingletonLineDistance2Graph"]]//Timing

{"StronglyRegular", {{176, 70, 18, 34}, 1}}

GraphData[{"StronglyRegular",{{176,70,18,34},1}},"V"]

Upper bound:

VertexChromaticNumber[GraphData[{"StronglyRegular",{{176,70,18,34},1}}]]//Timing

BipartiteColoring

FindBipartiteIndependentVertexSet[g_System`Graph?BipartiteGraphQ]:=Module[{d=GraphDistanceMatrix[g],v=1,set,n=VertexCount[g]},
set=Sort[Reap[DepthFirstScan[g,v,{"PrevisitVertex"->(If[Mod[d[[v,#]],2]==0,Sow[#]]&)}];][[2,1]]];
If[Length[set]>=n/2,set,Complement[Range[n],set]]
]

Grid 5×5

System`GridGraph[{5,5},VertexLabels->"Name"]

(set=FindBipartiteIndependentVertexSet[g=System`GridGraph[{5,5}]])//Timing

HighlightGraph[g,set,VertexSize->Medium]

IndependentVertexSetQ[g,set]

1-Menger sponge

BipartiteGraphQ[g=GraphData[{"MengerSponge",1}]]

SetProperty[g,VertexLabels->"Name"]

(set=FindBipartiteIndependentVertexSet[g])//Timing

HighlightGraph[g,set,VertexSize->Large]

setbar=Complement[Range[VertexCount[g]],set]

Length/@{set,setbar}

IndependentVertexSetQ[g,#]&/@{set,setbar}

FindIndependentVertexSet[g][[1]]//Timing

2-Menger sponge

BipartiteGraphQ[g=GraphData[{"MengerSponge",2}]]

set=FindBipartiteIndependentVertexSet[g];//Timing

setbar=Complement[Range[VertexCount[g]],set];

Length/@{set,setbar}

IndependentVertexSetQ[g,#]&/@{set,setbar}

Length[set2=FindIndependentVertexSet[g][[1]]]//Timing

IndependentVertexSetQ[g,set2]

3-Menger sponge

BipartiteGraphQ[g=GraphData[{"MengerSponge",3}]]

GraphData[{"MengerSponge",3},"α"]

Length[set=FindBipartiteIndependentVertexSet[g]]//Timing

Length[setbar=Complement[Range[VertexCount[g]],set]]

IndependentVertexSetQ[g,#]&/@{set,setbar}

TimeConstrained[FindIndependentVertexSet[g],10]//Timing

Algorithms for a single coloring

Built-in

ZaraGraph

Unknown what the best coloring is, but Eric Weisstein used Gurobi in Oct 2021 to find an 11-coloring and prove there is no 8-coloring.  So only 9- and 10-colorings remain open.

(col=FindVertexColoring[GraphData["ZaraGraph"]])//Timing

Max[col]

VertexChromaticNumber[GraphData["ZaraGraph"]]

{"Queen", {8, 8}}

(col=FindVertexColoring[GraphData[{"Queen",{8,8}}]])//Timing

Max[col]

VertexChromaticNumber[GraphData[{"Queen",{8,8}}]]

{"Rook",{6,7}}]

$Version

(col=FindVertexColoring[GraphData[{"Rook",{6,7}}]])//Timing

(col=FindVertexColoring[GraphData[{"Rook",{6,7}}],PerformanceGoal->"Quality"])//Timing

Max[col]

col2=GraphData[{"Rook",{6,7}},"MinimumVertexColoring"]

Max[col2]

VertexColoringQ[GraphData[{"Rook",{6,7}}],#]&/@{col,col2}

Check

data=Monitor[{g=#,GraphData[#,"ChromaticNumber"],FindVertexColoring[GraphData[#],PerformanceGoal->"Quality"]}&/@GraphData[;;100],g];//Timing

bug(415898): FindVertexColoring[GraphData[{"Rook", {6, 7}}], PerformanceGoal -> "Quality"] incorrectly returns an 8-coloring (the graph has chromatic number 7)

Disagreement:

(bad=Select[DeleteCases[data,{_,_,_FindVertexColoring}],Max[#[[3]]]=!=#[[2]]&])[[All,1]]

Unevaluated (or bad messages):

Cases[data,{g_,_,_FindVertexColoring}:>g]

Backtracking

Cases[EdgeList[gr] /. Thread[Range[Length[color]] -> color], UndirectedEdge[x_, x_], Infinity, 1] === {}

Monitor[DeleteCases[{gr=#,VertexColoringQ[GraphData[#],GraphData[#,"MinimumVertexColoring"]]}&/@GraphData[;;20],{_,True}],gr]//Timing

VertexColoringQ[g, col]

<<MathWorld`Graphs`

Monitor[DeleteCases[{gr=#,VertexColoringQ[GraphData[#],GraphData[#,"MinimumVertexColoring"]]}&/@GraphData[;;20],{_,True}],gr]//Timing

VertexColoringQ compiled

<<MathWorld`Graphs`

Monitor[DeleteCases[{gr=#,VertexColoringQ[GraphData[#],GraphData[#,"MinimumVertexColoring"]]}&/@GraphData[;;20],{_,True}],gr]//Timing

Boolean SAT

http://shodhganga.inflibnet.ac.in/bitstream/10603/119979/7/chapter%206.pdf

Solving Graph Problems with Boolean Methods
https://www.cs.cmu.edu/~bryant/presentations/boolean-methods.pdf

https://www.wolfram.com/mathematica/new-in-10/entity-based-geocomputation/find-a-four-coloring-of-a-map-of-europe.html

From Adam 2018-12-03:

I think this [FindInstance with Integers as a constraint] is less efficient than Boolean encoding.  If you have m vertices and n colors, you need m*n integer variables.  In the Boolean encoding you need m*Ceiling[Log2[n]] Boolean variables.  Plus I would expect Boolean SAT code to work faster than FindInstance over the integers. I am not sure how COIN would compare, it would be an interesting experiment...

The following routine doesn't yet work, presumably because handling of the "extra" 2^n-Ceiling[Log2[n]] colors is not done correctly

4 vertices

g=GraphData["DiamondGraph"];

GraphData["DiamondGraph","MinimumVertexColoring"]

n=VertexCount[g]

adjlist=MapIndexed[{#2[[1]],#}&,AdjacencyList[g]]

nbool=Ceiling[Log2[n]]

colorcode=Thread[Tuples[{True,False},nbool]->Join[Range[n],ConstantArray[n,2^nbool-n]]]

booleans=#->{x[#],y[#]}&/@Range[n]

eqs=And@@(Flatten[Function[{v,neighbors},BooleanConvert[Xor[x[v],x[#]]||Xor[y[v],y[#]],"CNF"]&/@neighbors]@@@adjlist]);

soln=First[FindInstance[eqs,Flatten[booleans[[All,-1]]],Booleans]]

coloring=((booleans/.soln)/.colorcode)[[All,-1]]

DeleteDuplicates[coloring]

reducedcoloring=With[{u=DeleteDuplicates[coloring]},coloring/.Thread[u->Range[Length[Union[coloring]]]]]

GraphData["DiamondGraph","χ"]

<<MathWorld`Graphs`

FindVertexColoring[GraphData["DiamondGraph"],Method->"BooleanSAT"]

ClawGraph (4 vertices) using 4 colors

g=GraphData["ClawGraph"];

GraphData["ClawGraph","MinimumVertexColoring"]

n=VertexCount[g]

adjlist=MapIndexed[{#2[[1]],#}&,AdjacencyList[g]]

nbool=Ceiling[Log2[n]]

colorcode=Thread[Tuples[{True,False},nbool]->Join[Range[n],ConstantArray[n,2^nbool-n]]]

booleans=Rule@@@Transpose[{Range[n],Array[x,{n,nbool}]}]

eqs=And@@(Flatten[Function[{v,neighbors},BooleanConvert[Or@@Table[Xor[x[v,i],x[#,i]],{i,nbool}],"CNF"]&/@neighbors]@@@adjlist]);

soln=First[FindInstance[eqs,Flatten[booleans[[All,-1]]],Booleans]]

coloring=(booleans/.soln/.colorcode)[[All,-1]]

DeleteDuplicates[coloring]

reducedcoloring=With[{u=DeleteDuplicates[coloring]},coloring/.Thread[u->Range[Length[Union[coloring]]]]]

FindVertexColoring[g,Method->"BooleanSAT"]

ClawGraph (4 vertices) using 3 colors

g=GraphData["ClawGraph"];

GraphData["ClawGraph","MinimumVertexColoring"]

n=VertexCount[g]

nmax=2

adjlist=MapIndexed[{#2[[1]],#}&,AdjacencyList[g]]

nbool=Ceiling[Log2[nmax]]

colorcode=Thread[Tuples[{True,False},nbool]->Join[Range[nmax],ConstantArray[nmax,2^nbool-nmax]]]

booleans=Rule@@@Transpose[{Range[nmax],Array[x,{nmax,nbool}]}]

eqs=And@@(Flatten[Function[{v,neighbors},BooleanConvert[or=Or@@Table[Xor[x[v,i],x[#,i]],{i,nbool}],"CNF"]&/@neighbors]@@@adjlist]);

or

soln=First[FindInstance[eqs,Flatten[booleans[[All,-1]]],Booleans]]

coloring=(booleans/.soln/.colorcode)[[All,-1]]

DeleteDuplicates[coloring]

reducedcoloring=With[{u=DeleteDuplicates[coloring]},coloring/.Thread[u->Range[Length[Union[coloring]]]]]

FindVertexColoring[g,Method->"BooleanSAT"]

AGraph (6 vertices)

g=GraphData["AGraph"];

GraphData["AGraph","MinimumVertexColoring"]

n=VertexCount[g]

adjlist=MapIndexed[{#2[[1]],#}&,AdjacencyList[g]]

nbool=Ceiling[Log2[n]]

colorcode=Thread[Tuples[{True,False},nbool]->Join[Range[n],ConstantArray[n,2^nbool-n]]]

Rule@@@Transpose[{Range[n],Array[x,{n,nbool}]}]

booleans=#->{x[#],y[#],z[#]}&/@Range[n]

booleans=Rule@@@Transpose[{Range[n],Array[x,{n,nbool}]}]

eqs0=And@@(Flatten[Function[{v,neighbors},BooleanConvert[Xor[x[v],x[#]]||Xor[y[v],y[#]||Xor[z[v],z[#]]],"CNF"]&/@neighbors]@@@adjlist]);

Or@@Table[Xor[x[i,1],x[i,#]],{i,nbool}]

eqs=And@@(Flatten[Function[{v,neighbors},BooleanConvert[Or@@Table[Xor[x[v,i],x[#,i]],{i,nbool}],"CNF"]&/@neighbors]@@@adjlist]);

soln=First[FindInstance[eqs,Flatten[booleans[[All,-1]]],Booleans]]

coloring=((booleans/.soln)/.colorcode)[[All,-1]]

(booleans/.soln/.colorcode)[[All,-1]]

DeleteDuplicates[coloring]

reducedcoloring=With[{u=DeleteDuplicates[coloring]},coloring/.Thread[u->Range[Length[Union[coloring]]]]]

<<MathWorld`Graphs`

FindVertexColoring[GraphData["AGraph"],Method->"BooleanSAT"]

{5,31} (5 vertices)

g=GraphData[{5,31}];

GraphData[{5,31},"MinimumVertexColoring"]

n=VertexCount[g]

adjlist=MapIndexed[{#2[[1]],#}&,AdjacencyList[g]]

nbool=Ceiling[Log2[n]]

colorcode=Thread[Tuples[{True,False},nbool]->Join[Range[n],ConstantArray[n,2^nbool-n]]]

Rule@@@Transpose[{Range[n],Array[x,{n,nbool}]}]

booleans=Rule@@@Transpose[{Range[n],Array[x,{n,nbool}]}]

eqs=And@@(Flatten[Function[{v,neighbors},BooleanConvert[Or@@Table[Xor[x[v,i],x[#,i]],{i,nbool}],"CNF"]&/@neighbors]@@@adjlist]);

soln=First[FindInstance[eqs,Flatten[booleans[[All,-1]]],Booleans]]

(booleans/.soln/.colorcode)[[All,-1]]

DeleteDuplicates[coloring]

reducedcoloring=With[{u=DeleteDuplicates[coloring]},coloring/.Thread[u->Range[Length[Union[coloring]]]]]

FindVertexColoring[GraphData["AGraph"],Method->"BooleanSAT"]

Test

DeleteCases[Monitor[{g=#,GraphData[#,"ChromaticNumber"],Max@FindVertexColoring[GraphData[#],Method->"BooleanSAT"]}&/@GraphData["Connected",;;6],g],{_,x_,x_}]//Timing

<<MathWorld`Graphs`

DeleteCases[Monitor[{g=#,GraphData[#,"ChromaticNumber"],Max@FindVertexColoring[GraphData[#],Method->"BooleanSAT"]}&/@GraphData["Connected",4],g],{_,x_,x_}]//Timing

MaximalIndependentVertexSets vs IndependentVertexSets

10

Length[gs=GraphData["Connected",;;10]]

cns=GraphData[#,"ChromaticNumber"]&/@gs;

colorings1=Monitor[FindVertexColoring[GraphData[g=#],Method->"Static","IndependentSets"->FindAllMaximalIndependentVertexSets]&/@gs,g];//Timing

And@@(VertexColoringQ[GraphData[#],#2]&@@@Transpose[{gs,colorings1}])

colorings2=Monitor[FindVertexColoring[GraphData[g=#],Method->"Static","IndependentSets"->FindAllIndependentVertexSets]&/@gs,g];//Timing

And@@(VertexColoringQ[GraphData[#],#2]&@@@Transpose[{gs,colorings2}])

DeleteCases[Transpose[{gs,cns,Max/@colorings1,Max/@colorings2}],{_,x_,x_,x_}]

15

Length[gs=GraphData["Connected",;;15]]

cns=GraphData[#,"ChromaticNumber"]&/@gs;

colorings1=Monitor[FindVertexColoring[GraphData[g=#],Method->"Static","IndependentSets"->FindAllMaximalIndependentVertexSets]&/@gs,g];//Timing

And@@(VertexColoringQ[GraphData[#],#2]&@@@Transpose[{gs,colorings1}])

colorings2=Monitor[FindVertexColoring[GraphData[g=#],Method->"Static","IndependentSets"->FindAllIndependentVertexSets]&/@gs,g];//Timing

And@@(VertexColoringQ[GraphData[#],#2]&@@@Transpose[{gs,colorings2}])

DeleteCases[Transpose[{gs,cns,Max/@colorings1,Max/@colorings2}],{_,x_,x_,x_}]

Trick ILP

GraphData["Q3","Graph","Labeled"]

col=FindVertexColoring[GraphData["Q3"],Debug->True]

VertexColoringQ[GraphData["Q3"],col]

SetProperty[GraphData["Q3","Graph","Labeled"],VertexStyle->MapIndexed[#2[[1]]->{Red,Green,Blue,Yellow}[[#]]&,col]]

Cases[Monitor[{#,VertexColoringQ[GraphData[g=#],FindVertexColoring[GraphData[#]]]}&/@GraphData[;;20],g],{g_,False}:>g]//Timing

Cases[Monitor[{#,VertexColoringQ[GraphData[g=#],FindVertexColoring[GraphData[#]]]}&/@GraphData[;;25],g],{g_,False}:>g]//Timing

Algorithms for all colorings

Select[GraphData["Properties"],StringMatchQ["*Color*"]]

"BowtieGraph"

g=GraphData["BowtieGraph"]

Length/@Table[ResourceFunction["FindProperColorings"][g,k],{k,7}]

chi=VertexChromaticNumber[g]

colorings=ResourceFunction["FindProperColorings"][g,chi]

Length[colorings]

Select[GraphData["Properties"],GraphData["BowtieGraph",#]===12&]

VertexColoredGraph[g,#,VertexSize->Medium]&/@colorings

GraphData["BowtieGraph","MinimumVertexColoring"]

MemberQ[colorings,%]