+{-# OPTIONS -fno-warn-missing-signatures #-}
-- | Basic operations on graphs.
--
--- TODO: refine coalescing crieteria
-
-{-# OPTIONS -fno-warn-missing-signatures #-}
module GraphOps (
addNode, delNode, getNode, lookupNode, modNode,
-- less colorable (aggressive coalescing)
-> Triv k cls color
-> Graph k cls color
- -> (Graph k cls color, [(k, k)])
+ -> ( Graph k cls color
+ , [(k, k)]) -- pairs of nodes that were coalesced, in the order that the
+ -- coalescing was applied.
coalesceGraph aggressive triv graph
= coalesceGraph' aggressive triv graph []
-- keep running until there are no more coalesces can be found
in case catMaybes mPairs of
- [] -> (graph', kkPairsAcc)
- pairs -> coalesceGraph' aggressive triv graph' (pairs ++ kkPairsAcc)
+ [] -> (graph', reverse kkPairsAcc)
+ pairs -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc)
-- | Coalesce this pair of nodes unconditionally / agressively.
-- | validate the internal structure of a graph
-- all its edges should point to valid nodes
--- if they don't then throw an error
+-- If they don't then throw an error
--
validateGraph
- :: (Uniquable k, Outputable k)
- => SDoc
- -> Graph k cls color
- -> Graph k cls color
+ :: (Uniquable k, Outputable k, Eq color)
+ => SDoc -- ^ extra debugging info to display on error
+ -> Bool -- ^ whether this graph is supposed to be colored.
+ -> Graph k cls color -- ^ graph to validate
+ -> Graph k cls color -- ^ validated graph
+
+validateGraph doc isColored graph
+
+ -- Check that all edges point to valid nodes.
+ | edges <- unionManyUniqSets
+ ( (map nodeConflicts $ eltsUFM $ graphMap graph)
+ ++ (map nodeCoalesce $ eltsUFM $ graphMap graph))
+
+ , nodes <- mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph
+ , badEdges <- minusUniqSet edges nodes
+ , not $ isEmptyUniqSet badEdges
+ = pprPanic "GraphOps.validateGraph"
+ ( text "Graph has edges that point to non-existant nodes"
+ $$ text " bad edges: " <> vcat (map ppr $ uniqSetToList badEdges)
+ $$ doc )
+
+ -- Check that no conflicting nodes have the same color
+ | badNodes <- filter (not . (checkNode graph))
+ $ eltsUFM $ graphMap graph
+ , not $ null badNodes
+ = pprPanic "GraphOps.validateGraph"
+ ( text "Node has same color as one of it's conflicts"
+ $$ text " bad nodes: " <> hcat (map (ppr . nodeId) badNodes)
+ $$ doc)
+
+ -- If this is supposed to be a colored graph,
+ -- check that all nodes have a color.
+ | isColored
+ , badNodes <- filter (\n -> isNothing $ nodeColor n)
+ $ eltsUFM $ graphMap graph
+ , not $ null badNodes
+ = pprPanic "GraphOps.validateGraph"
+ ( text "Supposably colored graph has uncolored nodes."
+ $$ text " uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes)
+ $$ doc )
-validateGraph doc graph
- = let edges = unionManyUniqSets
- ( (map nodeConflicts $ eltsUFM $ graphMap graph)
- ++ (map nodeCoalesce $ eltsUFM $ graphMap graph))
- nodes = mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph
+ -- graph looks ok
+ | otherwise
+ = graph
+
+
+-- | If this node is colored, check that all the nodes which
+-- conflict with it have different colors.
+checkNode
+ :: (Uniquable k, Eq color)
+ => Graph k cls color
+ -> Node k cls color
+ -> Bool -- ^ True if this node is ok
- badEdges = minusUniqSet edges nodes
+checkNode graph node
+ | Just color <- nodeColor node
+ , Just neighbors <- sequence $ map (lookupNode graph)
+ $ uniqSetToList $ nodeConflicts node
+
+ , neighbourColors <- catMaybes $ map nodeColor neighbors
+ , elem color neighbourColors
+ = False
- in if isEmptyUniqSet badEdges
- then graph
- else pprPanic "GraphOps.validateGraph"
- ( text "-- bad edges"
- $$ vcat (map ppr $ uniqSetToList badEdges)
- $$ text "----------------------------"
- $$ doc)
+ | otherwise
+ = True
+
-- | Slurp out a map of how many nodes had a certain number of conflict neighbours