3 -- This is a generic graph coloring library, abstracted over the type of
4 -- the node keys, nodes and colors.
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 -- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
36 -- | Try to color a graph with this set of colors.
37 -- Uses Chaitin's algorithm to color the graph.
38 -- The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes
39 -- are pushed onto a stack and removed from the graph.
40 -- Once this process is complete the graph can be colored by removing nodes from
41 -- the stack (ie in reverse order) and assigning them colors different to their neighbors.
44 :: ( Uniquable k, Uniquable cls, Uniquable color
45 , Eq color, Eq cls, Ord k
46 , Outputable k, Outputable cls, Outputable color)
47 => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class).
48 -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable.
49 -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
50 -> Graph k cls color -- ^ the graph to color.
52 -> ( Graph k cls color -- the colored graph.
53 , UniqSet k -- the set of nodes that we couldn't find a color for.
54 , UniqFM k ) -- map of regs (r1 -> r2) that were coaleced
55 -- r1 should be replaced by r2 in the source
57 colorGraph colors triv spill graph0
59 -- do aggressive coalesing on the graph
60 (graph_coalesced, rsCoalesce)
61 = coalesceGraph graph0
63 -- run the scanner to slurp out all the trivially colorable nodes
65 = colorScan colors triv spill [] emptyUniqSet graph_coalesced
67 -- color the trivially colorable nodes
68 (graph_triv, ksNoTriv)
69 = assignColors colors graph_coalesced ksTriv
71 -- try and color the problem nodes
72 (graph_prob, ksNoColor) = assignColors colors graph_triv (uniqSetToList ksProblems)
74 -- if the trivially colorable nodes didn't color then something is wrong
75 -- with the provided triv function.
76 in if not $ null ksNoTriv
77 then pprPanic "colorGraph: trivially colorable nodes didn't color!" empty
79 $$ text "ksTriv = " <> ppr ksTriv
80 $$ text "ksNoTriv = " <> ppr ksNoTriv
82 $$ dotGraph (\x -> text "white") triv graph1) -}
86 , listToUFM rsCoalesce)
88 colorScan colors triv spill safe prob graph
90 -- empty graphs are easy to color.
91 | isNullUFM $ graphMap graph
94 -- Try and find a trivially colorable node.
95 | Just node <- find (\node -> triv (nodeClass node)
97 (nodeExclusions node))
98 $ eltsUFM $ graphMap graph
100 = colorScan colors triv spill
101 (k : safe) prob (delNode k graph)
103 -- There was no trivially colorable node,
104 -- Choose one to potentially leave uncolored. We /might/ be able to find
105 -- a color for this later on, but no guarantees.
107 = colorScan colors triv spill
108 safe (addOneToUniqSet prob k) (delNode k graph)
111 -- | Try to assign a color to all these nodes.
114 :: ( Uniquable k, Uniquable cls, Uniquable color, Eq color )
115 => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class).
116 -> Graph k cls color -- ^ the graph
117 -> [k] -- ^ nodes to assign a color to.
118 -> ( Graph k cls color -- the colored graph
119 , [k]) -- the nodes that didn't color.
121 assignColors colors graph ks
122 = assignColors' colors graph [] ks
124 where assignColors' colors graph prob []
127 assignColors' colors graph prob (k:ks)
128 = case assignColor colors k graph of
130 -- couldn't color this node
131 Nothing -> assignColors' colors graph (k : prob) ks
133 -- this node colored ok, so do the rest
134 Just graph' -> assignColors' colors graph' prob ks
137 assignColor colors u graph
138 | Just c <- selectColor colors graph u
139 = Just (setColor u c graph)
146 -- | Select a color for a certain node
147 -- taking into account preferences, neighbors and exclusions.
148 -- returns Nothing if no color can be assigned to this node.
150 -- TODO: avoid using the prefs of the neighbors, if at all possible.
153 :: ( Uniquable k, Uniquable cls, Uniquable color, Eq color)
154 => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class).
155 -> Graph k cls color -- ^ the graph
156 -> k -- ^ key of the node to select a color for.
159 selectColor colors graph u
160 = let -- lookup the node
161 Just node = lookupNode graph u
163 -- lookup the available colors for the class of this node.
165 = lookupUFM colors (nodeClass node)
167 -- find colors we can't use because they're already being used
168 -- by a node that conflicts with this one.
171 $ map (lookupNode graph)
175 colors_conflict = mkUniqSet
177 $ map nodeColor nsConflicts
179 -- colors that are still ok
180 colors_ok_ex = minusUniqSet colors_avail (nodeExclusions node)
181 colors_ok = minusUniqSet colors_ok_ex colors_conflict
183 -- the colors that we prefer, and are still ok
184 colors_ok_pref = intersectUniqSets
185 (mkUniqSet $ nodePreference node) colors_ok
190 -- we got one of our preferences, score!
191 | not $ isEmptyUniqSet colors_ok_pref
192 , c : rest <- uniqSetToList colors_ok_pref
195 -- it wasn't a preference, but it was still ok
196 | not $ isEmptyUniqSet colors_ok
197 , c : rest <- uniqSetToList colors_ok
200 -- leave this node uncolored