{-# 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 forall a. Eq a => a -> a -> Bool
== Int
0
then 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 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)])
= 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)]
_)
= forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (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)
= 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)
= 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 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [k]
ksNoTriv
then 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
<> forall a. Outputable a => a -> SDoc
ppr [k]
ksTriv
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"ksNoTriv = " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr [k]
ksNoTriv
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"colors = " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr UniqFM cls (UniqSet color)
colors
SDoc -> SDoc -> SDoc
$$ SDoc
empty
SDoc -> SDoc -> 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
, forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [k]
ksNoColor
, if Bool
iterative
then (forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM [(k, k)]
kksCoalesce2)
else (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
= 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
| forall key elt. UniqFM key elt -> Bool
isNullUFM forall a b. (a -> b) -> a -> b
$ forall k cls color.
Graph k cls color -> UniqFM k (Node k cls color)
graphMap Graph k cls color
graph
= ([k]
ksTriv, [k]
ksSpill, forall a. [a] -> [a]
reverse [(k, k)]
kksCoalesce)
| nsTrivFound :: [Node k cls color]
nsTrivFound@(Node 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 (forall k cls color. Node k cls color -> cls
nodeClass Node k cls color
node) (forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node k cls color
node) (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
|| forall a. UniqSet a -> Bool
isEmptyUniqSet (forall k cls color. Node k cls color -> UniqSet k
nodeCoalesce Node k cls color
node)))
forall a b. (a -> b) -> a -> b
$ Graph k cls color
graph
, [k]
ksTrivFound <- forall a b. (a -> b) -> [a] -> [b]
map forall k cls color. Node k cls color -> k
nodeId [Node k cls color]
nsTrivFound
, Graph k cls color
graph2 <- 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' = 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
= 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 forall a. [a] -> [a] -> [a]
++ [k]
ksTriv)
[k]
ksSpill
[(k, k)]
kksCoalesce
| Bool
iterative
= case 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)]
_))
-> 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 (forall a. [a] -> [a]
reverse [(k, k)]
kksCoalesceFound forall a. [a] -> [a] -> [a]
++ [(k, k)]
kksCoalesce)
(Graph k cls color
graph2, [])
-> case 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)
-> 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)
-> 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
= 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' = 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 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 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 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 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 <- 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
= forall a. a -> Maybe a
Just (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
= 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 = 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 forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM cls (UniqSet color)
colors (forall k cls color. Node k cls color -> cls
nodeClass Node k cls color
node) of
Maybe (UniqSet color)
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"selectColor: no colors available for class " (forall a. Outputable a => a -> SDoc
ppr (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
= forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall k cls color.
Uniquable k =>
Graph k cls color -> k -> Maybe (Node k cls color)
lookupNode Graph k cls color
graph)
forall a b. (a -> b) -> a -> b
$ forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet
forall a b. (a -> b) -> a -> b
$ forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node k cls color
node
colors_conflict :: UniqSet color
colors_conflict = forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet
forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall k cls color. Node k cls color -> Maybe color
nodeColor [Node k cls color]
nsConflicts
colors_neighbor_prefs :: UniqSet color
colors_neighbor_prefs
= forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet
forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall k cls color. Node k cls color -> [color]
nodePreference [Node k cls color]
nsConflicts
colors_ok_ex :: UniqSet color
colors_ok_ex = forall a. UniqSet a -> UniqSet a -> UniqSet a
minusUniqSet UniqSet color
colors_avail (forall k cls color. Node k cls color -> UniqSet color
nodeExclusions Node k cls color
node)
colors_ok :: UniqSet color
colors_ok = 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 = forall a. UniqSet a -> UniqSet a -> UniqSet a
intersectUniqSets
(forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet forall a b. (a -> b) -> a -> b
$ 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 = 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
= 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 forall a b. (a -> b) -> a -> b
$ forall a. UniqSet a -> Bool
isEmptyUniqSet UniqSet color
colors_ok_pref_nice
, color
c : [color]
_ <- forall a. (a -> Bool) -> [a] -> [a]
filter (\color
x -> forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet color
x UniqSet color
colors_ok_pref_nice)
(forall k cls color. Node k cls color -> [color]
nodePreference Node k cls color
node)
= forall a. a -> Maybe a
Just color
c
| Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. UniqSet a -> Bool
isEmptyUniqSet UniqSet color
colors_ok_pref
, color
c : [color]
_ <- forall a. (a -> Bool) -> [a] -> [a]
filter (\color
x -> forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet color
x UniqSet color
colors_ok_pref)
(forall k cls color. Node k cls color -> [color]
nodePreference Node k cls color
node)
= forall a. a -> Maybe a
Just color
c
| Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. UniqSet a -> Bool
isEmptyUniqSet UniqSet color
colors_ok
, color
c : [color]
_ <- forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet color
colors_ok
= forall a. a -> Maybe a
Just color
c
| Bool
otherwise
= forall a. Maybe a
Nothing
in Maybe color
chooseColor