3 -- This is a generic graph coloring library, abstracted over the type of
4 -- the node keys, nodes and colors.
28 -- | Try to color a graph with this set of colors.
29 -- Uses Chaitin's algorithm to color the graph.
30 -- The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes
31 -- are pushed onto a stack and removed from the graph.
32 -- Once this process is complete the graph can be colored by removing nodes from
33 -- the stack (ie in reverse order) and assigning them colors different to their neighbors.
36 :: ( Uniquable k, Uniquable cls, Uniquable color, Eq color
37 , Outputable k, Outputable cls, Outputable color)
38 => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class).
39 -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable.
40 -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
41 -> Graph k cls color -- ^ the graph to color.
42 -> ( Graph k cls color -- ^ the colored graph.
43 , UniqSet k ) -- ^ the set of nodes that we couldn't find a color for.
45 colorGraph colors triv spill graph0
46 = let -- run the scanner to slurp out all the trivially colorable nodes
47 (ksTriv, ksProblems) = colorScan colors triv spill [] emptyUniqSet graph0
49 -- color the trivially colorable nodes
50 (graph1, ksNoTriv) = assignColors colors graph0 ksTriv
52 -- try and color the problem nodes
53 (graph2, ksNoColor) = assignColors colors graph1 (uniqSetToList ksProblems)
55 -- if the trivially colorable nodes didn't color then something is wrong
56 -- with the provided triv function.
57 in if not $ null ksNoTriv
58 then pprPanic "colorGraph: trivially colorable nodes didn't color!" empty
60 $$ text "ksTriv = " <> ppr ksTriv
61 $$ text "ksNoTriv = " <> ppr ksNoTriv
63 $$ dotGraph (\x -> text "white") triv graph1) -}
64 else (graph2, mkUniqSet ksNoColor)
67 colorScan colors triv spill safe prob graph
69 -- empty graphs are easy to color.
70 | isNullUFM $ graphMap graph
73 -- Try and find a trivially colorable node.
74 | Just node <- find (\node -> triv (nodeClass node)
76 (nodeExclusions node))
77 $ eltsUFM $ graphMap graph
79 = colorScan colors triv spill
80 (k : safe) prob (delNode k graph)
82 -- There was no trivially colorable node,
83 -- Choose one to potentially leave uncolored. We /might/ be able to find
84 -- a color for this later on, but no guarantees.
86 = colorScan colors triv spill
87 safe (addOneToUniqSet prob k) (delNode k graph)
91 -- | Try to assign a color to all these nodes.
94 :: ( Uniquable k, Uniquable cls, Uniquable color, Eq color )
95 => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class).
96 -> Graph k cls color -- ^ the graph
97 -> [k] -- ^ nodes to assign a color to.
98 -> ( Graph k cls color -- the colored graph
99 , [k]) -- the nodes that didn't color.
101 assignColors colors graph ks
102 = assignColors' colors graph [] ks
104 where assignColors' colors graph prob []
107 assignColors' colors graph prob (k:ks)
108 = case assignColor colors k graph of
110 -- couldn't color this node
111 Nothing -> assignColors' colors graph (k : prob) ks
113 -- this node colored ok, so do the rest
114 Just graph' -> assignColors' colors graph' prob ks
117 assignColor colors u graph
118 | Just c <- selectColor colors graph u
119 = Just (setColor u c graph)
126 -- | Select a color for a certain node
127 -- taking into account preferences, neighbors and exclusions.
128 -- returns Nothing if no color can be assigned to this node.
130 -- TODO: avoid using the prefs of the neighbors, if at all possible.
133 :: ( Uniquable k, Uniquable cls, Uniquable color, Eq color)
134 => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class).
135 -> Graph k cls color -- ^ the graph
136 -> k -- ^ key of the node to select a color for.
139 selectColor colors graph u
140 = let -- lookup the node
141 Just node = lookupNode graph u
143 -- lookup the available colors for the class of this node.
145 = lookupUFM colors (nodeClass node)
147 -- colors we can't use because they're already being used
148 -- by a node that conflicts with this one.
151 $ map (lookupNode graph)
155 colors_conflict = mkUniqSet
157 $ map nodeColor nsConflicts
159 -- colors that are still ok
160 colors_ok_ex = minusUniqSet colors_avail (nodeExclusions node)
161 colors_ok = minusUniqSet colors_ok_ex colors_conflict
163 -- the colors that we prefer, and are still ok
164 colors_ok_pref = intersectUniqSets
165 (mkUniqSet $ nodePreference node) colors_ok
170 -- we got one of our preferences, score!
171 | not $ isEmptyUniqSet colors_ok_pref
172 , c : rest <- uniqSetToList colors_ok_pref
175 -- it wasn't a preference, but it was still ok
176 | not $ isEmptyUniqSet colors_ok
177 , c : rest <- uniqSetToList colors_ok
180 -- leave this node uncolored