(* :Title: GraphColoring *) (* :Author: John J. Lattanzio *) (* :Comments: This package is a supplement to the package "Combinatorica" by Pemmaraju and Skiena. Any problems or suggestions should be forwarded to: John Lattanzio Department of Mathematics Indiana University of Pennsylvania Indiana, PA 15705 Email: John.Lattanzio@iup.edu Phone: (724) 357-4760 *) (* :Context: ProgrammingInMathematica`GraphColoring` *) BeginPackage["ProgrammingInMathematica`GraphColoring`", "DiscreteMath`Combinatorica`", "Graphics`Colors`"] Unprotect[ColorGraph, TestColorGraph, SetAppend, IndependentSets, IndependenceTrees] ColorGraph::usage = "ColorGraph[G] returns an upper bound, k, for \[Chi](G) together with a vertex partition of G having k members. Successive vertices in a color class are determined by a maximum intersection property. The option ExhibitGraph can be used to display the colored graph." TestColorGraph::usage = "TestColorGraph[n, a, b, p] compares the algorithms of Brelaz and Lattanzio by returning the average of the differences between upper bounds, determined by the algorithms respectively, on the chromatic numbers of n randomly generated graphs, having between a and b vertices and an approximate edge probability of p. The option ExhibitTest can be used to display the test data." ExhibitGraph::usage = "ExhibitGraph is an option for ColorGraph that will display the colored graph determined by the algorithm. The default value of ExhibitGraph is 0 so that the graph is not displayed. To display the graph, the value of ExhibitGraph should be set to 1." ExhibitTest::usage = "ExhibitTest is an option for TestColorGraph that will display the data determined by the algorithm. The default value of ExhibitTest is 0 so that the data is not displayed. To display the data, the value of ExhibitTest should be set to 1." IndependentSets::usage = "IndependentSets[G, L] returns a labeled graph G together with a list in which element i of list L is the set of all independent subsets of V(G) containing vertex i. L is required to be a nonempty subset of the vertex set of G. The default for L is V(G)." IndependenceTrees::usage = "IndependenceTrees[G, L] returns a labeled graph G together with a sequence of rooted trees, a root for each vertex in L. The vertices contained in the paths of the rooted trees correspond to independent subsets of V(G). L is required to be a nonempty subset of the vertex set of G. The default for L is V(G)." Options[ColorGraph] = {ExhibitGraph -> 0} Options[TestColorGraph] = {ExhibitTest -> 0} Begin["`Private`"] ColorGraph[G_Graph, options___Rule] := Module[{opt1, g, adlist, class, verpart, maxlength, v, nbhds, delnbhd, inter, s, maxinter, w, color}, g = G; adlist = ToAdjacencyLists[g]; class = {}; delnbhd = adlist; verpart = {}; opt1 = ExhibitGraph /. {options} /. Options[ColorGraph]; Do[If[Flatten[adlist] == {}, verpart = Append[verpart, Complement[Table[t, {t, Length[adlist]}], Flatten[verpart]]]; Break[], If[Length[Flatten[verpart]] == Length[adlist], Break[]]; Do[maxlength = Max[Table[Length[adlist[[a]]], {a, Length[adlist]}]]; If[maxlength != 0, Do[If[Length[adlist[[b]]] == maxlength && Not[MemberQ[Flatten[verpart],b]], v = b; class = Union[class, {v}]; Break[]], {b, Length[adlist]}]; nbhds = Union[{{v}}, Table[{adlist[[v, c]]}, {c, Length[adlist[[v]]]}]]; delnbhd = ReplacePart[adlist, {}, nbhds]; inter = Table[Intersection[adlist[[v]], delnbhd[[d]]], {d, Length[delnbhd]}]; Do[If[Flatten[delnbhd] == {} && r == 1, s = r; color = {v}; Break[], If[Flatten[delnbhd] == {}, Break[]]; s = r; If[Flatten[delnbhd] != {} && Flatten[inter] == {}, inter = delnbhd]; maxinter = Max[Table[Length[inter[[m]]], {m, Length[inter]}]]; Do[If[Length[inter[[n]]] == maxinter && Intersection[{n}, Flatten[verpart]] == {}, w = n; class = Union[class, {w}]; Break[]], {n, Length[inter]}]; nbhds = Union[nbhds, {{w}}, Table[{adlist[[w, p]]}, {p, Length[adlist[[w]]]}]]; delnbhd = ReplacePart[adlist, {}, nbhds]; inter = Table[Intersection[adlist[[w]], delnbhd[[q]]], {q, Length[delnbhd]}]; If[Length[nbhds] == Length[adlist], Break[]]], {r, Length[delnbhd]}], s = 0; class = Complement[Table[e, {e, Length[adlist]}], Flatten[verpart]]]; s = -1; If[s == 0 || s != 1, colorclass[y] = class, colorclass[y] = color]; If[s != 0, color = {}; class = {}]; adlist = ReplacePart[adlist, {}, Table[{colorclass[y][[o]]}, {o, Length[colorclass[y]]}]]; adlist = Table[Complement[adlist[[az]], colorclass[y]], {az, Length[adlist]}]; verpart = Append[verpart, colorclass[y]]]; If[Length[Flatten[verpart]] == Length[adlist],Break[]],{z, Length[adlist]}],{y, Length[adlist]}]; Print["\[Chi](G) \[PrecedesSlantEqual] ", Length[verpart],"."]; Print["A vertex set partition is ",Sort[verpart]//MatrixForm,"."]; If[MemberQ[{0,1}, opt1] && opt1 == 1, ShowGraph[SetGraphOptions[Highlight[g,verpart],VertexLabel->Table[i, {i, V[g]}],VertexLabelPosition->Center]]]; {Length[verpart], Sort[verpart]}] ColorGraphTest[G_Graph] := Module[{g, adlist, class, verpart, maxlength, v, nbhds, delnbhd, inter, s, maxinter, w, color}, g = G; adlist = ToAdjacencyLists[g]; class = {}; delnbhd = adlist; verpart = {}; Do[If[Flatten[adlist] == {}, verpart = Append[verpart, Complement[Table[t, {t, Length[adlist]}], Flatten[verpart]]]; Break[], If[Length[Flatten[verpart]] == Length[adlist], Break[]]; Do[maxlength = Max[Table[Length[adlist[[a]]], {a, Length[adlist]}]]; If[maxlength != 0, Do[If[Length[adlist[[b]]] == maxlength && Not[MemberQ[Flatten[verpart],b]], v = b; class = Union[class, {v}]; Break[]], {b, Length[adlist]}]; nbhds = Union[{{v}}, Table[{adlist[[v, c]]}, {c, Length[adlist[[v]]]}]]; delnbhd = ReplacePart[adlist, {}, nbhds]; inter = Table[Intersection[adlist[[v]], delnbhd[[d]]], {d, Length[delnbhd]}]; Do[If[Flatten[delnbhd] == {} && r == 1, s = r; color = {v}; Break[], If[Flatten[delnbhd] == {}, Break[]]; s = r; If[Flatten[delnbhd] != {} && Flatten[inter] == {}, inter = delnbhd]; maxinter = Max[Table[Length[inter[[m]]], {m, Length[inter]}]]; Do[If[Length[inter[[n]]] == maxinter && Intersection[{n}, Flatten[verpart]] == {}, w = n; class = Union[class, {w}]; Break[]], {n, Length[inter]}]; nbhds = Union[nbhds, {{w}}, Table[{adlist[[w, p]]}, {p, Length[adlist[[w]]]}]]; delnbhd = ReplacePart[adlist, {}, nbhds]; inter = Table[Intersection[adlist[[w]], delnbhd[[q]]], {q, Length[delnbhd]}]; If[Length[nbhds] == Length[adlist], Break[]]], {r, Length[delnbhd]}], s = 0; class = Complement[Table[e, {e, Length[adlist]}], Flatten[verpart]]]; s = -1; If[s == 0 || s != 1, colorclass[y] = class, colorclass[y] = color]; If[s != 0, color = {}; class = {}]; adlist = ReplacePart[adlist, {}, Table[{colorclass[y][[o]]}, {o, Length[colorclass[y]]}]]; adlist = Table[Complement[adlist[[az]], colorclass[y]], {az, Length[adlist]}]; verpart = Append[verpart, colorclass[y]]]; If[Length[Flatten[verpart]] == Length[adlist],Break[]],{z, Length[adlist]}],{y, Length[adlist]}]; bre=Max[BrelazColoring[g]]; lat=Length[verpart]; {bre,lat,bre-lat}] TestColorGraph[n_, a_, b_, p_, options___Rule] := Module[{i, s, t, opt1}, s = Table[RandomGraph[Random[Integer, {a, b}], p], {i, n}]; opt1 = ExhibitTest /. {options} /. Options[TestColorGraph]; t = Table[ColorGraphTest[s[[i]]], {i, n}]; Print["On average for this test, ColorGraph uses ", N[Sum[t[[i, 3]]/n, {i, n}], 3]," fewer colors than BrelazColoring."]; If[MemberQ[{0,1}, opt1] && opt1 == 1, Print[Prepend[t,{"Brelaz","ColorGraph","Difference"}]//TableForm]]; {N[Sum[t[[i, 3]]/n, {i, n}], 3]}] /; IntegerQ[n] && IntegerQ[a] && IntegerQ[b] && NumberQ[p] && 0 < a < b && 0 < p < 1 IndependentSets[x_Graph,M_List]:= Module[{G,A,NonNeighbors,IndPaths,z},G=x;A=ToAdjacencyMatrix[G]; SetAppend[X_List,Y_List]:= If[Y\[NotEqual]{},MapThread[Append,{Table[X,{Length[Y]}],Y}],X]; NonNeighbors= Table[Complement[Table[p,{p,V[G]}],Neighborhood[G,v,1]],{v,V[G]}]; NextInd[Z_List]:= Select[NonNeighbors[[Z[[1]]]],#>Z[[-1]] && MemberQ[Apply[Intersection, Table[NonNeighbors[[Z[[-i]]]],{i,Length[Z]}]],#] &]; Do[IndTemp[v,1]={v},{v,V[G]}]; Ind[1]=Flatten[Table[IndTemp[v,1],{v,V[G]}],0]; Do[If[NonNeighbors[[v]]\[NotEqual]{}, IndTemp[v,2]=SetAppend[IndTemp[v,1],NonNeighbors[[v]]], IndTemp[v,2]={IndTemp[v,1]}],{v,V[G]}]; Ind[2]=Flatten[Table[IndTemp[v,2],{v,V[G]}],1]; z=0; Do[If[Ind[k-1]\[Equal]Ind[k-2],IndPaths=Ind[k-2];z=-1;Break[], Ind[k]=Flatten[ Table[If[NextInd[Ind[k-1][[i]]]\[NotEqual]{}, SetAppend[Ind[k-1][[i]], NextInd[Ind[k-1][[i]]]],{SetAppend[Ind[k-1][[i]], NextInd[Ind[k-1][[i]]]]}],{i,Length[Ind[k-1]]}],1]],{k,3, V[G]}]; If[z!=-1,IndPaths=Ind[V[G]]]; PathToEdges[L_List]:= If[Length[L]>1,Table[{L[[i]],L[[i+1]]},{i,Length[L]-1}],L]; SetToRootedPaths[S_List]:= If[Length[S]>1,Table[Table[S[[i]],{i,j}],{j,Length[S]}],S]; Do[Vertex[i]=Select[IndPaths,# [[1]]==i &],{i,V[G]}]; Do[If[Length[Flatten[Vertex[i]]]>1, IndEdges[i]=Union[Flatten[Map[PathToEdges,Vertex[i]],1]], IndEdges[i]={}],{i,V[G]}]; Do[If[Length[Flatten[Vertex[i]]]>1, IndTreePaths[i]=Union[Flatten[Map[SetToRootedPaths,Vertex[i]],1]], IndTreePaths[i]={}],{i,V[G]}]; ShowGraph[ SetGraphOptions[G,VertexStyle\[Rule]Disk[Large], VertexColor\[Rule]LightGray,VertexLabel\[Rule]Table[i,{i,V[G]}], VertexLabelPosition\[Rule]Center]]; Do[If[IndTreePaths[i]\[NotEqual]{},IndSets[i]=IndTreePaths[i], IndSets[i]={{i}}],{i,V[G]}]; Table[IndSets[M[[i]]],{i,Length[M]}]] IndependenceTrees[x_Graph,L_List]:=Module[{t,G}, G=x; t=IndependentSets[G,Table[z,{z,V[G]}]]; Do[IndTreePaths[i]=t[[i]],{i,Length[t]}]; Do[If[IndTreePaths[j]\[NotEqual]{}, HalfEdges[j]= Flatten[Table[ Position[IndTreePaths[j],Delete[IndTreePaths[j][[i]],-1] ,1, 1],{i,Length[IndTreePaths[j]]}],2],HalfEdges[j]={}],{j,1, V[G]}]; Do[If[HalfEdges[j]\[NotEqual]{}, EdgesTree[j]= Table[{HalfEdges[j][[i]],i+1},{i,Length[IndTreePaths[j]]-1}], EdgesTree[j]={}],{j,1,V[G]}]; Do[If[EdgesTree[i]\[NotEqual]{},g[i]=FromUnorderedPairs[EdgesTree[i]], g[i]=CompleteGraph[1]],{i,V[G]}]; Do[If[IndTreePaths[j]\[NotEqual]{}, TreeLabels[j]= Table[IndTreePaths[j][[i,-1]],{i,Length[IndTreePaths[j]]}], TreeLabels[j]={j}],{j,V[G]}]; indtrees= Table[SetGraphOptions[ Highlight[RootedEmbedding[g[i]],{Table[j,{j,V[g[i]]}]}], VertexStyle\[Rule]Disk[Normal],VertexLabel\[Rule]TreeLabels[i], VertexLabelPosition\[Rule]Center],{i,V[G]}]; Do[ShowGraph[indtrees[[L[[i]]]]],{i,Length[L]}]] IndependentSets[G_Graph] := IndependentSets[G, Table[i, {i, V[G]}]] IndependenceTrees[G_Graph] := IndependenceTrees[G, Table[i, {i, V[G]}]] End[] Protect[ColorGraph, ShowColorGraph, TestColorGraph, IndependentSets, IndependenceTrees] EndPackage[]