{-# 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
forall doc. IsOutput doc => doc
empty
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ksTriv = " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [k] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [k]
ksTriv
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ksNoTriv = " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [k] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [k]
ksNoTriv
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"colors = " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> UniqFM cls (UniqSet color) -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqFM cls (UniqSet color)
colors
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
forall doc. IsOutput doc => doc
empty
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ (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
forall doc. IsLine doc => String -> doc
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 {k} (key :: k) 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
$ (Node k cls color -> Maybe color) -> [Node k cls color] -> [color]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe 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