RosettaCodeData/Task/Graph-colouring/Mathematica/graph-colouring.math

36 lines
1.7 KiB
Plaintext

ClearAll[ColorGroups]
ColorGroups[g_Graph] := Module[{h, cols, indset, diffcols},
h = g;
cols = {};
While[! EmptyGraphQ[h], maxd = RandomChoice[VertexList[h]];
indset = Flatten[FindIndependentVertexSet[{h, maxd}]];
AppendTo[cols, indset];
h = VertexDelete[h, indset];
];
AppendTo[cols, VertexList[h]];
diffcols = Length[cols];
cols = Catenate[Map[Thread][Rule @@@ Transpose[{cols, Range[Length[cols]]}]]];
Print[Column[Row[{"Edge ", #1, " to ", #2, " has colors ", #1 /. cols, " and ", #2 /. cols }] & @@@ EdgeList[g]]];
Print[Grid[{{"Vertices: ", VertexCount[g]}, {"Edges: ", EdgeCount[g]}, {"Colors used: ", diffcols}}]]
]
ColorGroups[Graph[Range[0, 3], {0 \[UndirectedEdge] 1, 1 \[UndirectedEdge] 2,
2 \[UndirectedEdge] 0}]]
ColorGroups[Graph[Range[8], {1 \[UndirectedEdge] 6, 1 \[UndirectedEdge] 7,
1 \[UndirectedEdge] 8, 2 \[UndirectedEdge] 5,
2 \[UndirectedEdge] 7, 2 \[UndirectedEdge] 8,
3 \[UndirectedEdge] 5, 3 \[UndirectedEdge] 6,
3 \[UndirectedEdge] 8, 4 \[UndirectedEdge] 5,
4 \[UndirectedEdge] 6, 4 \[UndirectedEdge] 7}]]
ColorGroups[Graph[Range[8], {1 \[UndirectedEdge] 4, 1 \[UndirectedEdge] 6,
1 \[UndirectedEdge] 8, 3 \[UndirectedEdge] 2,
3 \[UndirectedEdge] 6, 3 \[UndirectedEdge] 8,
5 \[UndirectedEdge] 2, 5 \[UndirectedEdge] 4,
5 \[UndirectedEdge] 8, 7 \[UndirectedEdge] 2,
7 \[UndirectedEdge] 4, 7 \[UndirectedEdge] 6}]]
ColorGroups[Graph[Range[8], {1 \[UndirectedEdge] 6, 7 \[UndirectedEdge] 1,
8 \[UndirectedEdge] 1, 5 \[UndirectedEdge] 2,
2 \[UndirectedEdge] 7, 2 \[UndirectedEdge] 8,
3 \[UndirectedEdge] 5, 6 \[UndirectedEdge] 3,
3 \[UndirectedEdge] 8, 4 \[UndirectedEdge] 5,
4 \[UndirectedEdge] 6, 4 \[UndirectedEdge] 7}]]