{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module GHC.Data.Graph.Color (
        module GHC.Data.Graph.Base,
        module GHC.Data.Graph.Ops,
        module GHC.Data.Graph.Ppr,
        colorGraph
)
where
import GHC.Prelude
import GHC.Data.Graph.Base
import GHC.Data.Graph.Ops
import GHC.Data.Graph.Ppr
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Utils.Outputable
import GHC.Utils.Panic
import Data.Maybe
import Data.List (mapAccumL)
colorGraph
        :: forall k cls color.
           ( Uniquable  k, Uniquable cls,  Uniquable  color
           , Eq cls, Ord k
           , Outputable k, Outputable cls, Outputable color)
        => Bool                         
        -> Int                          
        -> UniqFM cls (UniqSet color)       
        -> Triv   k cls color           
        -> (Graph k cls color -> k)     
        -> Graph  k cls color           
        -> ( Graph k cls color          
           , UniqSet k                  
           , UniqFM k k )                
                                        
colorGraph :: forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Eq cls, Ord k,
 Outputable k, Outputable cls, Outputable color) =>
Bool
-> Int
-> UniqFM cls (UniqSet color)
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> (Graph k cls color, UniqSet k, UniqFM k k)
colorGraph Bool
iterative Int
spinCount UniqFM cls (UniqSet color)
colors Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph0
 = let
        
        
        
        
        
        
        
        
        (Graph k cls color
graph_coalesced, [(k, k)]
kksCoalesce1)
         = if Bool
iterative
                then (Graph k cls color
graph0, [])
                else if Int
spinCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                        then Bool
-> Triv k cls color
-> Graph k cls color
-> (Graph k cls color, [(k, k)])
forall k cls color.
(Uniquable k, Ord k, Eq cls, Outputable k) =>
Bool
-> Triv k cls color
-> Graph k cls color
-> (Graph k cls color, [(k, k)])
coalesceGraph Bool
True  Triv k cls color
triv Graph k cls color
graph0
                        else Bool
-> Triv k cls color
-> Graph k cls color
-> (Graph k cls color, [(k, k)])
forall k cls color.
(Uniquable k, Ord k, Eq cls, Outputable k) =>
Bool
-> Triv k cls color
-> Graph k cls color
-> (Graph k cls color, [(k, k)])
coalesceGraph Bool
False Triv k cls color
triv Graph k cls color
graph0
        
        
        ([k]
ksTriv, [k]
ksProblems, [(k, k)]
kksCoalesce2 :: [(k,k)])
                = Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> ([k], [k], [(k, k)])
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Ord k, Eq cls,
 Outputable k, Outputable cls) =>
Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> ([k], [k], [(k, k)])
colorScan Bool
iterative Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph_coalesced
        
        
        
        
        
        
        
        (Graph k cls color
graph_scan_coalesced, [Maybe (k, k)]
_)
                = (Graph k cls color -> (k, k) -> (Graph k cls color, Maybe (k, k)))
-> Graph k cls color
-> [(k, k)]
-> (Graph k cls color, [Maybe (k, k)])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (Bool
-> Triv k cls color
-> Graph k cls color
-> (k, k)
-> (Graph k cls color, Maybe (k, k))
forall k cls color.
(Uniquable k, Ord k, Eq cls) =>
Bool
-> Triv k cls color
-> Graph k cls color
-> (k, k)
-> (Graph k cls color, Maybe (k, k))
coalesceNodes Bool
True Triv k cls color
triv) Graph k cls color
graph_coalesced [(k, k)]
kksCoalesce2
        
        
        
        (Graph k cls color
graph_triv, [k]
ksNoTriv)
                = UniqFM cls (UniqSet color)
-> Graph k cls color -> [k] -> (Graph k cls color, [k])
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Outputable cls) =>
UniqFM cls (UniqSet color)
-> Graph k cls color -> [k] -> (Graph k cls color, [k])
assignColors UniqFM cls (UniqSet color)
colors Graph k cls color
graph_scan_coalesced [k]
ksTriv
        
        
        
        (Graph k cls color
graph_prob, [k]
ksNoColor)
                = UniqFM cls (UniqSet color)
-> Graph k cls color -> [k] -> (Graph k cls color, [k])
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Outputable cls) =>
UniqFM cls (UniqSet color)
-> Graph k cls color -> [k] -> (Graph k cls color, [k])
assignColors UniqFM cls (UniqSet color)
colors Graph k cls color
graph_triv [k]
ksProblems
        
        
        
   in   if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [k] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [k]
ksNoTriv
         then   String -> SDoc -> (Graph k cls color, UniqSet k, UniqFM k k)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"colorGraph: trivially colorable nodes didn't color!" 
                        (  SDoc
empty
                        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"ksTriv    = " SDoc -> SDoc -> SDoc
<> [k] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [k]
ksTriv
                        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"ksNoTriv  = " SDoc -> SDoc -> SDoc
<> [k] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [k]
ksNoTriv
                        SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"colors    = " SDoc -> SDoc -> SDoc
<> UniqFM cls (UniqSet color) -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqFM cls (UniqSet color)
colors
                        SDoc -> SDoc -> SDoc
$$ SDoc
empty
                        SDoc -> SDoc -> SDoc
$$ (color -> SDoc) -> Triv k cls color -> Graph k cls color -> SDoc
forall k cls color.
(Uniquable k, Outputable k, Outputable cls, Outputable color) =>
(color -> SDoc) -> Triv k cls color -> Graph k cls color -> SDoc
dotGraph (\color
_ -> String -> SDoc
text String
"white") Triv k cls color
triv Graph k cls color
graph_triv)
         else   ( Graph k cls color
graph_prob
                , [k] -> UniqSet k
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [k]
ksNoColor   
                , if Bool
iterative
                        then ([(k, k)] -> UniqFM k k
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM [(k, k)]
kksCoalesce2)
                        else ([(k, k)] -> UniqFM k k
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM [(k, k)]
kksCoalesce1))
colorScan
        :: ( Uniquable k, Uniquable cls, Uniquable color
           , Ord k,       Eq cls
           , Outputable k, Outputable cls)
        => Bool                         
        -> Triv k cls color             
        -> (Graph k cls color -> k)     
        -> Graph k cls color            
        -> ([k], [k], [(k, k)])         
colorScan :: forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Ord k, Eq cls,
 Outputable k, Outputable cls) =>
Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> ([k], [k], [(k, k)])
colorScan Bool
iterative Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph
        = Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Ord k, Eq cls,
 Outputable k, Outputable cls) =>
Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
colorScan_spin Bool
iterative Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph [] [] []
colorScan_spin
        :: ( Uniquable k, Uniquable cls, Uniquable color
           , Ord k,       Eq cls
           , Outputable k, Outputable cls)
        => Bool
        -> Triv k cls color
        -> (Graph k cls color -> k)
        -> Graph k cls color
        -> [k]
        -> [k]
        -> [(k, k)]
        -> ([k], [k], [(k, k)])
colorScan_spin :: forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Ord k, Eq cls,
 Outputable k, Outputable cls) =>
Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
colorScan_spin Bool
iterative Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph
        [k]
ksTriv [k]
ksSpill [(k, k)]
kksCoalesce
        
        | UniqFM k (Node k cls color) -> Bool
forall key elt. UniqFM key elt -> Bool
isNullUFM (UniqFM k (Node k cls color) -> Bool)
-> UniqFM k (Node k cls color) -> Bool
forall a b. (a -> b) -> a -> b
$ Graph k cls color -> UniqFM k (Node k cls color)
forall k cls color.
Graph k cls color -> UniqFM k (Node k cls color)
graphMap Graph k cls color
graph
        = ([k]
ksTriv, [k]
ksSpill, [(k, k)] -> [(k, k)]
forall a. [a] -> [a]
reverse [(k, k)]
kksCoalesce)
        
        
        
        
        | nsTrivFound :: [Node k cls color]
nsTrivFound@(Node k cls color
_:[Node k cls color]
_)
                <-  (Node k cls color -> Bool)
-> Graph k cls color -> [Node k cls color]
forall k cls color.
(Node k cls color -> Bool)
-> Graph k cls color -> [Node k cls color]
scanGraph   (\Node k cls color
node -> Triv k cls color
triv  (Node k cls color -> cls
forall k cls color. Node k cls color -> cls
nodeClass Node k cls color
node) (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node k cls color
node) (Node k cls color -> UniqSet color
forall k cls color. Node k cls color -> UniqSet color
nodeExclusions Node k cls color
node)
                                  
                                  
                                  Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
iterative Bool -> Bool -> Bool
|| UniqSet k -> Bool
forall a. UniqSet a -> Bool
isEmptyUniqSet (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeCoalesce Node k cls color
node)))
                        (Graph k cls color -> [Node k cls color])
-> Graph k cls color -> [Node k cls color]
forall a b. (a -> b) -> a -> b
$ Graph k cls color
graph
        , [k]
ksTrivFound   <- (Node k cls color -> k) -> [Node k cls color] -> [k]
forall a b. (a -> b) -> [a] -> [b]
map Node k cls color -> k
forall k cls color. Node k cls color -> k
nodeId [Node k cls color]
nsTrivFound
        , Graph k cls color
graph2        <- (k -> Graph k cls color -> Graph k cls color)
-> Graph k cls color -> [k] -> Graph k cls color
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\k
k Graph k cls color
g -> let Just Graph k cls color
g' = k -> Graph k cls color -> Maybe (Graph k cls color)
forall k cls color.
Uniquable k =>
k -> Graph k cls color -> Maybe (Graph k cls color)
delNode k
k Graph k cls color
g
                                          in  Graph k cls color
g')
                                Graph k cls color
graph [k]
ksTrivFound
        = Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Ord k, Eq cls,
 Outputable k, Outputable cls) =>
Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
colorScan_spin Bool
iterative Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph2
                ([k]
ksTrivFound [k] -> [k] -> [k]
forall a. [a] -> [a] -> [a]
++ [k]
ksTriv)
                [k]
ksSpill
                [(k, k)]
kksCoalesce
        
        
        
        | Bool
iterative
        = case Bool
-> Triv k cls color
-> Graph k cls color
-> (Graph k cls color, [(k, k)])
forall k cls color.
(Uniquable k, Ord k, Eq cls, Outputable k) =>
Bool
-> Triv k cls color
-> Graph k cls color
-> (Graph k cls color, [(k, k)])
coalesceGraph Bool
False Triv k cls color
triv Graph k cls color
graph of
                
                
                (Graph k cls color
graph2, kksCoalesceFound :: [(k, k)]
kksCoalesceFound@((k, k)
_:[(k, k)]
_))
                 -> Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Ord k, Eq cls,
 Outputable k, Outputable cls) =>
Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
colorScan_spin Bool
iterative Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph2
                        [k]
ksTriv [k]
ksSpill ([(k, k)] -> [(k, k)]
forall a. [a] -> [a]
reverse [(k, k)]
kksCoalesceFound [(k, k)] -> [(k, k)] -> [(k, k)]
forall a. [a] -> [a] -> [a]
++ [(k, k)]
kksCoalesce)
                
                
                
                (Graph k cls color
graph2, [])
                 -> case Graph k cls color -> (Graph k cls color, Bool)
forall k cls color.
Uniquable k =>
Graph k cls color -> (Graph k cls color, Bool)
freezeOneInGraph Graph k cls color
graph2 of
                        
                        
                        (Graph k cls color
graph3, Bool
True)
                         -> Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Ord k, Eq cls,
 Outputable k, Outputable cls) =>
Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
colorScan_spin Bool
iterative Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph3
                                [k]
ksTriv [k]
ksSpill [(k, k)]
kksCoalesce
                        
                        
                        (Graph k cls color
graph3, Bool
False)
                         -> Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Ord k, Eq cls,
 Outputable k, Outputable cls) =>
Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
colorScan_spill Bool
iterative Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph3
                                [k]
ksTriv [k]
ksSpill [(k, k)]
kksCoalesce
        
        | Bool
otherwise
        = Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Ord k, Eq cls,
 Outputable k, Outputable cls) =>
Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
colorScan_spill Bool
iterative Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph
                [k]
ksTriv [k]
ksSpill [(k, k)]
kksCoalesce
colorScan_spill
        :: ( Uniquable k, Uniquable cls, Uniquable color
           , Ord k,       Eq cls
           , Outputable k, Outputable cls)
        => Bool
        -> Triv k cls color
        -> (Graph k cls color -> k)
        -> Graph k cls color
        -> [k]
        -> [k]
        -> [(k, k)]
        -> ([k], [k], [(k, k)])
colorScan_spill :: forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Ord k, Eq cls,
 Outputable k, Outputable cls) =>
Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
colorScan_spill Bool
iterative Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph
        [k]
ksTriv [k]
ksSpill [(k, k)]
kksCoalesce
 = let  kSpill :: k
kSpill          = Graph k cls color -> k
spill Graph k cls color
graph
        Just Graph k cls color
graph'     = k -> Graph k cls color -> Maybe (Graph k cls color)
forall k cls color.
Uniquable k =>
k -> Graph k cls color -> Maybe (Graph k cls color)
delNode k
kSpill Graph k cls color
graph
   in   Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Ord k, Eq cls,
 Outputable k, Outputable cls) =>
Bool
-> Triv k cls color
-> (Graph k cls color -> k)
-> Graph k cls color
-> [k]
-> [k]
-> [(k, k)]
-> ([k], [k], [(k, k)])
colorScan_spin Bool
iterative Triv k cls color
triv Graph k cls color -> k
spill Graph k cls color
graph'
                [k]
ksTriv (k
kSpill k -> [k] -> [k]
forall a. a -> [a] -> [a]
: [k]
ksSpill) [(k, k)]
kksCoalesce
assignColors
        :: forall k cls color.
           ( Uniquable k, Uniquable cls, Uniquable color
           , Outputable cls)
        => UniqFM cls (UniqSet color)       
        -> Graph k cls color            
        -> [k]                          
        -> ( Graph k cls color          
           , [k])                       
assignColors :: forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Outputable cls) =>
UniqFM cls (UniqSet color)
-> Graph k cls color -> [k] -> (Graph k cls color, [k])
assignColors UniqFM cls (UniqSet color)
colors Graph k cls color
graph [k]
ks
        = UniqFM cls (UniqSet color)
-> Graph k cls color -> [k] -> [k] -> (Graph k cls color, [k])
assignColors' UniqFM cls (UniqSet color)
colors Graph k cls color
graph [] [k]
ks
 where  assignColors' :: UniqFM cls (UniqSet color)     
                        -> Graph k cls color            
                        -> [k]                          
                        -> [k]
                        -> ( Graph k cls color          
                        , [k])
        assignColors' :: UniqFM cls (UniqSet color)
-> Graph k cls color -> [k] -> [k] -> (Graph k cls color, [k])
assignColors' UniqFM cls (UniqSet color)
_ Graph k cls color
graph [k]
prob []
                = (Graph k cls color
graph, [k]
prob)
        assignColors' UniqFM cls (UniqSet color)
colors Graph k cls color
graph [k]
prob (k
k:[k]
ks)
         = case UniqFM cls (UniqSet color)
-> k -> Graph k cls color -> Maybe (Graph k cls color)
forall {k} {cls} {color}.
(Uniquable k, Uniquable cls, Uniquable color, Outputable cls) =>
UniqFM cls (UniqSet color)
-> k -> Graph k cls color -> Maybe (Graph k cls color)
assignColor UniqFM cls (UniqSet color)
colors k
k Graph k cls color
graph of
                
                Maybe (Graph k cls color)
Nothing         -> UniqFM cls (UniqSet color)
-> Graph k cls color -> [k] -> [k] -> (Graph k cls color, [k])
assignColors' UniqFM cls (UniqSet color)
colors Graph k cls color
graph (k
k k -> [k] -> [k]
forall a. a -> [a] -> [a]
: [k]
prob) [k]
ks
                
                Just Graph k cls color
graph'     -> UniqFM cls (UniqSet color)
-> Graph k cls color -> [k] -> [k] -> (Graph k cls color, [k])
assignColors' UniqFM cls (UniqSet color)
colors Graph k cls color
graph' [k]
prob [k]
ks
        assignColor :: UniqFM cls (UniqSet color)
-> k -> Graph k cls color -> Maybe (Graph k cls color)
assignColor UniqFM cls (UniqSet color)
colors k
u Graph k cls color
graph
                | Just color
c        <- UniqFM cls (UniqSet color) -> Graph k cls color -> k -> Maybe color
forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Outputable cls) =>
UniqFM cls (UniqSet color) -> Graph k cls color -> k -> Maybe color
selectColor UniqFM cls (UniqSet color)
colors Graph k cls color
graph k
u
                = Graph k cls color -> Maybe (Graph k cls color)
forall a. a -> Maybe a
Just (k -> color -> Graph k cls color -> Graph k cls color
forall k color cls.
Uniquable k =>
k -> color -> Graph k cls color -> Graph k cls color
setColor k
u color
c Graph k cls color
graph)
                | Bool
otherwise
                = Maybe (Graph k cls color)
forall a. Maybe a
Nothing
selectColor
        :: ( Uniquable k, Uniquable cls, Uniquable color
           , Outputable cls)
        => UniqFM cls (UniqSet color)   
        -> Graph k cls color            
        -> k                            
        -> Maybe color
selectColor :: forall k cls color.
(Uniquable k, Uniquable cls, Uniquable color, Outputable cls) =>
UniqFM cls (UniqSet color) -> Graph k cls color -> k -> Maybe color
selectColor UniqFM cls (UniqSet color)
colors Graph k cls color
graph k
u
 = let  
        Just Node k cls color
node       = Graph k cls color -> k -> Maybe (Node k cls color)
forall k cls color.
Uniquable k =>
Graph k cls color -> k -> Maybe (Node k cls color)
lookupNode Graph k cls color
graph k
u
        
        colors_avail :: UniqSet color
colors_avail
         = case UniqFM cls (UniqSet color) -> cls -> Maybe (UniqSet color)
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM cls (UniqSet color)
colors (Node k cls color -> cls
forall k cls color. Node k cls color -> cls
nodeClass Node k cls color
node) of
                Maybe (UniqSet color)
Nothing -> String -> SDoc -> UniqSet color
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"selectColor: no colors available for class " (cls -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Node k cls color -> cls
forall k cls color. Node k cls color -> cls
nodeClass Node k cls color
node))
                Just UniqSet color
cs -> UniqSet color
cs
        
        
        Just [Node k cls color]
nsConflicts
                        = [Maybe (Node k cls color)] -> Maybe [Node k cls color]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
                        ([Maybe (Node k cls color)] -> Maybe [Node k cls color])
-> [Maybe (Node k cls color)] -> Maybe [Node k cls color]
forall a b. (a -> b) -> a -> b
$ (k -> Maybe (Node k cls color))
-> [k] -> [Maybe (Node k cls color)]
forall a b. (a -> b) -> [a] -> [b]
map (Graph k cls color -> k -> Maybe (Node k cls color)
forall k cls color.
Uniquable k =>
Graph k cls color -> k -> Maybe (Node k cls color)
lookupNode Graph k cls color
graph)
                        ([k] -> [Maybe (Node k cls color)])
-> [k] -> [Maybe (Node k cls color)]
forall a b. (a -> b) -> a -> b
$ UniqSet k -> [k]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet
                        (UniqSet k -> [k]) -> UniqSet k -> [k]
forall a b. (a -> b) -> a -> b
$ Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node k cls color
node
                        
        colors_conflict :: UniqSet color
colors_conflict = [color] -> UniqSet color
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet
                        ([color] -> UniqSet color) -> [color] -> UniqSet color
forall a b. (a -> b) -> a -> b
$ [Maybe color] -> [color]
forall a. [Maybe a] -> [a]
catMaybes
                        ([Maybe color] -> [color]) -> [Maybe color] -> [color]
forall a b. (a -> b) -> a -> b
$ (Node k cls color -> Maybe color)
-> [Node k cls color] -> [Maybe color]
forall a b. (a -> b) -> [a] -> [b]
map Node k cls color -> Maybe color
forall k cls color. Node k cls color -> Maybe color
nodeColor [Node k cls color]
nsConflicts
        
        colors_neighbor_prefs :: UniqSet color
colors_neighbor_prefs
                        = [color] -> UniqSet color
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet
                        ([color] -> UniqSet color) -> [color] -> UniqSet color
forall a b. (a -> b) -> a -> b
$ (Node k cls color -> [color]) -> [Node k cls color] -> [color]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Node k cls color -> [color]
forall k cls color. Node k cls color -> [color]
nodePreference [Node k cls color]
nsConflicts
        
        colors_ok_ex :: UniqSet color
colors_ok_ex    = UniqSet color -> UniqSet color -> UniqSet color
forall a. UniqSet a -> UniqSet a -> UniqSet a
minusUniqSet UniqSet color
colors_avail (Node k cls color -> UniqSet color
forall k cls color. Node k cls color -> UniqSet color
nodeExclusions Node k cls color
node)
        colors_ok :: UniqSet color
colors_ok       = UniqSet color -> UniqSet color -> UniqSet color
forall a. UniqSet a -> UniqSet a -> UniqSet a
minusUniqSet UniqSet color
colors_ok_ex UniqSet color
colors_conflict
        
        colors_ok_pref :: UniqSet color
colors_ok_pref  = UniqSet color -> UniqSet color -> UniqSet color
forall a. UniqSet a -> UniqSet a -> UniqSet a
intersectUniqSets
                                ([color] -> UniqSet color
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet ([color] -> UniqSet color) -> [color] -> UniqSet color
forall a b. (a -> b) -> a -> b
$ Node k cls color -> [color]
forall k cls color. Node k cls color -> [color]
nodePreference Node k cls color
node) UniqSet color
colors_ok
        
        colors_ok_nice :: UniqSet color
colors_ok_nice  = UniqSet color -> UniqSet color -> UniqSet color
forall a. UniqSet a -> UniqSet a -> UniqSet a
minusUniqSet
                                UniqSet color
colors_ok UniqSet color
colors_neighbor_prefs
        
        colors_ok_pref_nice :: UniqSet color
colors_ok_pref_nice
                        = UniqSet color -> UniqSet color -> UniqSet color
forall a. UniqSet a -> UniqSet a -> UniqSet a
intersectUniqSets
                                UniqSet color
colors_ok_nice UniqSet color
colors_ok_pref
        
        chooseColor :: Maybe color
chooseColor
                
                | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ UniqSet color -> Bool
forall a. UniqSet a -> Bool
isEmptyUniqSet UniqSet color
colors_ok_pref_nice
                , color
c : [color]
_         <- (color -> Bool) -> [color] -> [color]
forall a. (a -> Bool) -> [a] -> [a]
filter (\color
x -> color -> UniqSet color -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet color
x UniqSet color
colors_ok_pref_nice)
                                        (Node k cls color -> [color]
forall k cls color. Node k cls color -> [color]
nodePreference Node k cls color
node)
                = color -> Maybe color
forall a. a -> Maybe a
Just color
c
                
                | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ UniqSet color -> Bool
forall a. UniqSet a -> Bool
isEmptyUniqSet UniqSet color
colors_ok_pref
                , color
c : [color]
_         <- (color -> Bool) -> [color] -> [color]
forall a. (a -> Bool) -> [a] -> [a]
filter (\color
x -> color -> UniqSet color -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet color
x UniqSet color
colors_ok_pref)
                                        (Node k cls color -> [color]
forall k cls color. Node k cls color -> [color]
nodePreference Node k cls color
node)
                = color -> Maybe color
forall a. a -> Maybe a
Just color
c
                
                | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ UniqSet color -> Bool
forall a. UniqSet a -> Bool
isEmptyUniqSet UniqSet color
colors_ok
                , color
c : [color]
_         <- UniqSet color -> [color]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet color
colors_ok
                
                = color -> Maybe color
forall a. a -> Maybe a
Just color
c
                
                
                | Bool
otherwise
                = Maybe color
forall a. Maybe a
Nothing
   in   Maybe color
chooseColor