{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Data.Graph.Ops
( addNode
, delNode
, getNode
, lookupNode
, modNode
, size
, union
, addConflict
, delConflict
, addConflicts
, addCoalesce
, delCoalesce
, addExclusion
, addExclusions
, addPreference
, coalesceNodes
, coalesceGraph
, freezeNode
, freezeOneInGraph
, freezeAllInGraph
, scanGraph
, setColor
, validateGraph
, slurpNodeConflictCount
)
where
import GHC.Prelude
import GHC.Data.Graph.Base
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Types.Unique
import GHC.Types.Unique.Set
import GHC.Types.Unique.FM
import Data.List (mapAccumL, sortBy)
import Data.Maybe
lookupNode
:: Uniquable k
=> Graph k cls color
-> k -> Maybe (Node k cls color)
lookupNode :: forall k cls color.
Uniquable k =>
Graph k cls color -> k -> Maybe (Node k cls color)
lookupNode Graph k cls color
graph k
k
= UniqFM k (Node k cls color) -> k -> Maybe (Node k cls color)
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM (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
k
getNode
:: Uniquable k
=> Graph k cls color
-> k -> Node k cls color
getNode :: forall k cls color.
Uniquable k =>
Graph k cls color -> k -> Node k cls color
getNode Graph k cls color
graph k
k
= case UniqFM k (Node k cls color) -> k -> Maybe (Node k cls color)
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM (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
k of
Just Node k cls color
node -> Node k cls color
node
Maybe (Node k cls color)
Nothing -> String -> Node k cls color
forall a. String -> a
panic String
"ColorOps.getNode: not found"
addNode :: Uniquable k
=> k -> Node k cls color
-> Graph k cls color -> Graph k cls color
addNode :: forall k cls color.
Uniquable k =>
k -> Node k cls color -> Graph k cls color -> Graph k cls color
addNode k
k Node k cls color
node Graph k cls color
graph
= let
map_conflict :: UniqFM k (Node k cls color)
map_conflict =
(k -> UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> UniqFM k (Node k cls color)
-> UniqSet k
-> UniqFM k (Node k cls color)
forall elt a. (elt -> a -> a) -> a -> UniqSet elt -> a
nonDetStrictFoldUniqSet
((Node k cls color -> Node k cls color)
-> k -> UniqFM k (Node k cls color) -> UniqFM k (Node k cls color)
forall k a.
Uniquable k =>
(a -> a) -> k -> UniqFM k a -> UniqFM k a
adjustUFM_C (\Node k cls color
n -> Node k cls color
n { nodeConflicts :: UniqSet k
nodeConflicts =
UniqSet k -> k -> UniqSet k
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node k cls color
n) k
k}))
(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)
(Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node k cls color
node)
map_coalesce :: UniqFM k (Node k cls color)
map_coalesce =
(k -> UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> UniqFM k (Node k cls color)
-> UniqSet k
-> UniqFM k (Node k cls color)
forall elt a. (elt -> a -> a) -> a -> UniqSet elt -> a
nonDetStrictFoldUniqSet
((Node k cls color -> Node k cls color)
-> k -> UniqFM k (Node k cls color) -> UniqFM k (Node k cls color)
forall k a.
Uniquable k =>
(a -> a) -> k -> UniqFM k a -> UniqFM k a
adjustUFM_C (\Node k cls color
n -> Node k cls color
n { nodeCoalesce :: UniqSet k
nodeCoalesce =
UniqSet k -> k -> UniqSet k
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeCoalesce Node k cls color
n) k
k}))
UniqFM k (Node k cls color)
map_conflict
(Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeCoalesce Node k cls color
node)
in Graph k cls color
graph
{ graphMap :: UniqFM k (Node k cls color)
graphMap = UniqFM k (Node k cls color)
-> k -> Node k cls color -> UniqFM k (Node k cls color)
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM k (Node k cls color)
map_coalesce k
k Node k cls color
node}
delNode :: (Uniquable k)
=> k -> Graph k cls color -> Maybe (Graph k cls color)
delNode :: forall k cls color.
Uniquable k =>
k -> Graph k cls color -> Maybe (Graph k cls color)
delNode k
k Graph k cls color
graph
| 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
k
= let
graph1 :: Graph k cls color
graph1 = (Graph k cls color -> k -> Graph k cls color)
-> Graph k cls color -> [k] -> Graph k cls color
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Graph k cls color
g k
k1 -> let Just Graph k cls color
g' = k -> k -> Graph k cls color -> Maybe (Graph k cls color)
forall k cls color.
Uniquable k =>
k -> k -> Graph k cls color -> Maybe (Graph k cls color)
delConflict k
k1 k
k Graph k cls color
g in Graph k cls color
g') Graph k cls color
graph
([k] -> Graph k cls color) -> [k] -> Graph k cls color
forall a b. (a -> b) -> a -> b
$ UniqSet k -> [k]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node k cls color
node)
graph2 :: Graph k cls color
graph2 = (Graph k cls color -> k -> Graph k cls color)
-> Graph k cls color -> [k] -> Graph k cls color
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Graph k cls color
g k
k1 -> let Just Graph k cls color
g' = k -> k -> Graph k cls color -> Maybe (Graph k cls color)
forall k cls color.
Uniquable k =>
k -> k -> Graph k cls color -> Maybe (Graph k cls color)
delCoalesce k
k1 k
k Graph k cls color
g in Graph k cls color
g') Graph k cls color
graph1
([k] -> Graph k cls color) -> [k] -> Graph k cls color
forall a b. (a -> b) -> a -> b
$ UniqSet k -> [k]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeCoalesce Node k cls color
node)
graph3 :: Graph k cls color
graph3 = (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color
forall k cls color.
(UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color
graphMapModify (\UniqFM k (Node k cls color)
fm -> UniqFM k (Node k cls color) -> k -> UniqFM k (Node k cls color)
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> UniqFM key elt
delFromUFM UniqFM k (Node k cls color)
fm k
k) Graph k cls color
graph2
in Graph k cls color -> Maybe (Graph k cls color)
forall a. a -> Maybe a
Just Graph k cls color
graph3
| Bool
otherwise
= Maybe (Graph k cls color)
forall a. Maybe a
Nothing
modNode :: Uniquable k
=> (Node k cls color -> Node k cls color)
-> k -> Graph k cls color -> Maybe (Graph k cls color)
modNode :: forall k cls color.
Uniquable k =>
(Node k cls color -> Node k cls color)
-> k -> Graph k cls color -> Maybe (Graph k cls color)
modNode Node k cls color -> Node k cls color
f k
k Graph k cls color
graph
= case 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
k of
Just Node{}
-> Graph k cls color -> Maybe (Graph k cls color)
forall a. a -> Maybe a
Just
(Graph k cls color -> Maybe (Graph k cls color))
-> Graph k cls color -> Maybe (Graph k cls color)
forall a b. (a -> b) -> a -> b
$ (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color
forall k cls color.
(UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color
graphMapModify
(\UniqFM k (Node k cls color)
fm -> let Just Node k cls color
node = UniqFM k (Node k cls color) -> k -> Maybe (Node k cls color)
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM k (Node k cls color)
fm k
k
node' :: Node k cls color
node' = Node k cls color -> Node k cls color
f Node k cls color
node
in UniqFM k (Node k cls color)
-> k -> Node k cls color -> UniqFM k (Node k cls color)
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM k (Node k cls color)
fm k
k Node k cls color
node')
Graph k cls color
graph
Maybe (Node k cls color)
Nothing -> Maybe (Graph k cls color)
forall a. Maybe a
Nothing
size :: Graph k cls color -> Int
size :: forall k cls color. Graph k cls color -> Int
size Graph k cls color
graph
= UniqFM k (Node k cls color) -> Int
forall key elt. UniqFM key elt -> Int
sizeUFM (UniqFM k (Node k cls color) -> Int)
-> UniqFM k (Node k cls color) -> Int
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
union :: Graph k cls color -> Graph k cls color -> Graph k cls color
union :: forall k cls color.
Graph k cls color -> Graph k cls color -> Graph k cls color
union Graph k cls color
graph1 Graph k cls color
graph2
= Graph
{ graphMap :: UniqFM k (Node k cls color)
graphMap = UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color) -> UniqFM k (Node k cls color)
forall key elt. UniqFM key elt -> UniqFM key elt -> UniqFM key elt
plusUFM (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
graph1) (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
graph2) }
addConflict
:: Uniquable k
=> (k, cls) -> (k, cls)
-> Graph k cls color -> Graph k cls color
addConflict :: forall k cls color.
Uniquable k =>
(k, cls) -> (k, cls) -> Graph k cls color -> Graph k cls color
addConflict (k
u1, cls
c1) (k
u2, cls
c2)
= let addNeighbor :: k
-> cls
-> k
-> UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color)
addNeighbor k
u cls
c k
u'
= (Node k cls color -> Node k cls color)
-> Node k cls color
-> k
-> UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color)
forall k a.
Uniquable k =>
(a -> a) -> a -> k -> UniqFM k a -> UniqFM k a
adjustWithDefaultUFM
(\Node k cls color
node -> Node k cls color
node { nodeConflicts :: UniqSet k
nodeConflicts = UniqSet k -> k -> UniqSet k
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node k cls color
node) k
u' })
(k -> cls -> Node k cls color
forall k cls color. k -> cls -> Node k cls color
newNode k
u cls
c) { nodeConflicts :: UniqSet k
nodeConflicts = k -> UniqSet k
forall a. Uniquable a => a -> UniqSet a
unitUniqSet k
u' }
k
u
in (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color
forall k cls color.
(UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color
graphMapModify
( k
-> cls
-> k
-> UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color)
forall {k} {cls} {color}.
Uniquable k =>
k
-> cls
-> k
-> UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color)
addNeighbor k
u1 cls
c1 k
u2
(UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k
-> cls
-> k
-> UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color)
forall {k} {cls} {color}.
Uniquable k =>
k
-> cls
-> k
-> UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color)
addNeighbor k
u2 cls
c2 k
u1)
delConflict
:: Uniquable k
=> k -> k
-> Graph k cls color -> Maybe (Graph k cls color)
delConflict :: forall k cls color.
Uniquable k =>
k -> k -> Graph k cls color -> Maybe (Graph k cls color)
delConflict k
k1 k
k2
= (Node k cls color -> Node k cls color)
-> k -> Graph k cls color -> Maybe (Graph k cls color)
forall k cls color.
Uniquable k =>
(Node k cls color -> Node k cls color)
-> k -> Graph k cls color -> Maybe (Graph k cls color)
modNode
(\Node k cls color
node -> Node k cls color
node { nodeConflicts :: UniqSet k
nodeConflicts = UniqSet k -> k -> UniqSet k
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
delOneFromUniqSet (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node k cls color
node) k
k2 })
k
k1
addConflicts
:: Uniquable k
=> UniqSet k -> (k -> cls)
-> Graph k cls color -> Graph k cls color
addConflicts :: forall k cls color.
Uniquable k =>
UniqSet k -> (k -> cls) -> Graph k cls color -> Graph k cls color
addConflicts UniqSet k
conflicts k -> cls
getClass
| (k
u : []) <- UniqSet k -> [k]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet k
conflicts
= (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color
forall k cls color.
(UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color
graphMapModify
((UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color)
-> (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color
-> Graph k cls color
forall a b. (a -> b) -> a -> b
$ (Node k cls color -> Node k cls color)
-> Node k cls color
-> k
-> UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color)
forall k a.
Uniquable k =>
(a -> a) -> a -> k -> UniqFM k a -> UniqFM k a
adjustWithDefaultUFM
Node k cls color -> Node k cls color
forall a. a -> a
id
(k -> cls -> Node k cls color
forall k cls color. k -> cls -> Node k cls color
newNode k
u (k -> cls
getClass k
u))
k
u
| Bool
otherwise
= (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color
forall k cls color.
(UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color
graphMapModify
((UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color)
-> (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color
-> Graph k cls color
forall a b. (a -> b) -> a -> b
$ \UniqFM k (Node k cls color)
fm -> (UniqFM k (Node k cls color) -> k -> UniqFM k (Node k cls color))
-> UniqFM k (Node k cls color)
-> [k]
-> UniqFM k (Node k cls color)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\UniqFM k (Node k cls color)
g k
u -> k
-> (k -> cls)
-> UniqSet k
-> UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color)
forall k cls color.
Uniquable k =>
k
-> (k -> cls)
-> UniqSet k
-> UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color)
addConflictSet1 k
u k -> cls
getClass UniqSet k
conflicts UniqFM k (Node k cls color)
g) UniqFM k (Node k cls color)
fm
([k] -> UniqFM k (Node k cls color))
-> [k] -> UniqFM k (Node k cls color)
forall a b. (a -> b) -> a -> b
$ UniqSet k -> [k]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet k
conflicts
addConflictSet1 :: Uniquable k
=> k -> (k -> cls) -> UniqSet k
-> UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color)
addConflictSet1 :: forall k cls color.
Uniquable k =>
k
-> (k -> cls)
-> UniqSet k
-> UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color)
addConflictSet1 k
u k -> cls
getClass UniqSet k
set
= case UniqSet k -> k -> UniqSet k
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
delOneFromUniqSet UniqSet k
set k
u of
UniqSet k
set' -> (Node k cls color -> Node k cls color)
-> Node k cls color
-> k
-> UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color)
forall k a.
Uniquable k =>
(a -> a) -> a -> k -> UniqFM k a -> UniqFM k a
adjustWithDefaultUFM
(\Node k cls color
node -> Node k cls color
node { nodeConflicts :: UniqSet k
nodeConflicts = UniqSet k -> UniqSet k -> UniqSet k
forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets UniqSet k
set' (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node k cls color
node) } )
(k -> cls -> Node k cls color
forall k cls color. k -> cls -> Node k cls color
newNode k
u (k -> cls
getClass k
u)) { nodeConflicts :: UniqSet k
nodeConflicts = UniqSet k
set' }
k
u
addExclusion
:: (Uniquable k, Uniquable color)
=> k -> (k -> cls) -> color
-> Graph k cls color -> Graph k cls color
addExclusion :: forall k color cls.
(Uniquable k, Uniquable color) =>
k -> (k -> cls) -> color -> Graph k cls color -> Graph k cls color
addExclusion k
u k -> cls
getClass color
color
= (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color
forall k cls color.
(UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color
graphMapModify
((UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color)
-> (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color
-> Graph k cls color
forall a b. (a -> b) -> a -> b
$ (Node k cls color -> Node k cls color)
-> Node k cls color
-> k
-> UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color)
forall k a.
Uniquable k =>
(a -> a) -> a -> k -> UniqFM k a -> UniqFM k a
adjustWithDefaultUFM
(\Node k cls color
node -> Node k cls color
node { nodeExclusions :: UniqSet color
nodeExclusions = UniqSet color -> color -> UniqSet color
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet (Node k cls color -> UniqSet color
forall k cls color. Node k cls color -> UniqSet color
nodeExclusions Node k cls color
node) color
color })
(k -> cls -> Node k cls color
forall k cls color. k -> cls -> Node k cls color
newNode k
u (k -> cls
getClass k
u)) { nodeExclusions :: UniqSet color
nodeExclusions = color -> UniqSet color
forall a. Uniquable a => a -> UniqSet a
unitUniqSet color
color }
k
u
addExclusions
:: (Uniquable k, Uniquable color)
=> k -> (k -> cls) -> [color]
-> Graph k cls color -> Graph k cls color
addExclusions :: forall k color cls.
(Uniquable k, Uniquable color) =>
k
-> (k -> cls) -> [color] -> Graph k cls color -> Graph k cls color
addExclusions k
u k -> cls
getClass [color]
colors Graph k cls color
graph
= (color -> Graph k cls color -> Graph k cls color)
-> Graph k cls color -> [color] -> Graph k cls color
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (k -> (k -> cls) -> color -> Graph k cls color -> Graph k cls color
forall k color cls.
(Uniquable k, Uniquable color) =>
k -> (k -> cls) -> color -> Graph k cls color -> Graph k cls color
addExclusion k
u k -> cls
getClass) Graph k cls color
graph [color]
colors
addCoalesce
:: Uniquable k
=> (k, cls) -> (k, cls)
-> Graph k cls color -> Graph k cls color
addCoalesce :: forall k cls color.
Uniquable k =>
(k, cls) -> (k, cls) -> Graph k cls color -> Graph k cls color
addCoalesce (k
u1, cls
c1) (k
u2, cls
c2)
= let addCoalesce :: k
-> cls
-> k
-> UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color)
addCoalesce k
u cls
c k
u'
= (Node k cls color -> Node k cls color)
-> Node k cls color
-> k
-> UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color)
forall k a.
Uniquable k =>
(a -> a) -> a -> k -> UniqFM k a -> UniqFM k a
adjustWithDefaultUFM
(\Node k cls color
node -> Node k cls color
node { nodeCoalesce :: UniqSet k
nodeCoalesce = UniqSet k -> k -> UniqSet k
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeCoalesce Node k cls color
node) k
u' })
(k -> cls -> Node k cls color
forall k cls color. k -> cls -> Node k cls color
newNode k
u cls
c) { nodeCoalesce :: UniqSet k
nodeCoalesce = k -> UniqSet k
forall a. Uniquable a => a -> UniqSet a
unitUniqSet k
u' }
k
u
in (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color
forall k cls color.
(UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color
graphMapModify
( k
-> cls
-> k
-> UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color)
forall {k} {cls} {color}.
Uniquable k =>
k
-> cls
-> k
-> UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color)
addCoalesce k
u1 cls
c1 k
u2
(UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k
-> cls
-> k
-> UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color)
forall {k} {cls} {color}.
Uniquable k =>
k
-> cls
-> k
-> UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color)
addCoalesce k
u2 cls
c2 k
u1)
delCoalesce
:: Uniquable k
=> k -> k
-> Graph k cls color -> Maybe (Graph k cls color)
delCoalesce :: forall k cls color.
Uniquable k =>
k -> k -> Graph k cls color -> Maybe (Graph k cls color)
delCoalesce k
k1 k
k2
= (Node k cls color -> Node k cls color)
-> k -> Graph k cls color -> Maybe (Graph k cls color)
forall k cls color.
Uniquable k =>
(Node k cls color -> Node k cls color)
-> k -> Graph k cls color -> Maybe (Graph k cls color)
modNode (\Node k cls color
node -> Node k cls color
node { nodeCoalesce :: UniqSet k
nodeCoalesce = UniqSet k -> k -> UniqSet k
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
delOneFromUniqSet (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeCoalesce Node k cls color
node) k
k2 })
k
k1
addPreference
:: Uniquable k
=> (k, cls) -> color
-> Graph k cls color -> Graph k cls color
addPreference :: forall k cls color.
Uniquable k =>
(k, cls) -> color -> Graph k cls color -> Graph k cls color
addPreference (k
u, cls
c) color
color
= (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color
forall k cls color.
(UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color
graphMapModify
((UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color)
-> (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color
-> Graph k cls color
forall a b. (a -> b) -> a -> b
$ (Node k cls color -> Node k cls color)
-> Node k cls color
-> k
-> UniqFM k (Node k cls color)
-> UniqFM k (Node k cls color)
forall k a.
Uniquable k =>
(a -> a) -> a -> k -> UniqFM k a -> UniqFM k a
adjustWithDefaultUFM
(\Node k cls color
node -> Node k cls color
node { nodePreference :: [color]
nodePreference = color
color color -> [color] -> [color]
forall a. a -> [a] -> [a]
: (Node k cls color -> [color]
forall k cls color. Node k cls color -> [color]
nodePreference Node k cls color
node) })
(k -> cls -> Node k cls color
forall k cls color. k -> cls -> Node k cls color
newNode k
u cls
c) { nodePreference :: [color]
nodePreference = [color
color] }
k
u
coalesceGraph
:: (Uniquable k, Ord k, Eq cls, Outputable k)
=> Bool
-> Triv k cls color
-> Graph k cls color
-> ( Graph k cls color
, [(k, k)])
coalesceGraph :: 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
aggressive Triv k cls color
triv Graph k cls color
graph
= Bool
-> Triv k cls color
-> Graph k cls color
-> [(k, k)]
-> (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
-> [(k, k)]
-> (Graph k cls color, [(k, k)])
coalesceGraph' Bool
aggressive Triv k cls color
triv Graph k cls color
graph []
coalesceGraph'
:: (Uniquable k, Ord k, Eq cls, Outputable k)
=> Bool
-> Triv k cls color
-> Graph k cls color
-> [(k, k)]
-> ( Graph k cls color
, [(k, k)])
coalesceGraph' :: forall k cls color.
(Uniquable k, Ord k, Eq cls, Outputable k) =>
Bool
-> Triv k cls color
-> Graph k cls color
-> [(k, k)]
-> (Graph k cls color, [(k, k)])
coalesceGraph' Bool
aggressive Triv k cls color
triv Graph k cls color
graph [(k, k)]
kkPairsAcc
= let
cNodes :: [Node k cls color]
cNodes = (Node k cls color -> Bool)
-> [Node k cls color] -> [Node k cls color]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Node k cls color
node -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ 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))
([Node k cls color] -> [Node k cls color])
-> [Node k cls color] -> [Node k cls color]
forall a b. (a -> b) -> a -> b
$ UniqFM k (Node k cls color) -> [Node k cls color]
forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM (UniqFM k (Node k cls color) -> [Node k cls color])
-> UniqFM k (Node k cls color) -> [Node k cls color]
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
cList :: [(k, k)]
cList = [ (Node k cls color -> k
forall k cls color. Node k cls color -> k
nodeId Node k cls color
node1, k
k2)
| Node k cls color
node1 <- [Node k cls color]
cNodes
, k
k2 <- 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
nodeCoalesce Node k cls color
node1 ]
(Graph k cls color
graph', [Maybe (k, k)]
mPairs)
= (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
aggressive Triv k cls color
triv) Graph k cls color
graph [(k, k)]
cList
in case [Maybe (k, k)] -> [(k, k)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (k, k)]
mPairs of
[] -> (Graph k cls color
graph', [(k, k)] -> [(k, k)]
forall a. [a] -> [a]
reverse [(k, k)]
kkPairsAcc)
[(k, k)]
pairs -> Bool
-> Triv k cls color
-> Graph k cls color
-> [(k, k)]
-> (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
-> [(k, k)]
-> (Graph k cls color, [(k, k)])
coalesceGraph' Bool
aggressive Triv k cls color
triv Graph k cls color
graph' ([(k, k)] -> [(k, k)]
forall a. [a] -> [a]
reverse [(k, k)]
pairs [(k, k)] -> [(k, k)] -> [(k, k)]
forall a. [a] -> [a] -> [a]
++ [(k, k)]
kkPairsAcc)
coalesceNodes
:: (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 :: 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
aggressive Triv k cls color
triv Graph k cls color
graph (k
k1, k
k2)
| (k
kMin, k
kMax) <- if k
k1 k -> k -> Bool
forall a. Ord a => a -> a -> Bool
< k
k2
then (k
k1, k
k2)
else (k
k2, k
k1)
, Just Node k cls color
nMin <- 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
kMin
, Just Node k cls color
nMax <- 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
kMax
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ k -> UniqSet k -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet k
kMin (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node k cls color
nMax)
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ k -> UniqSet k -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet k
kMax (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node k cls color
nMin)
, Node k cls color -> k
forall k cls color. Node k cls color -> k
nodeId Node k cls color
nMin k -> k -> Bool
forall a. Eq a => a -> a -> Bool
/= Node k cls color -> k
forall k cls color. Node k cls color -> k
nodeId Node k cls color
nMax
= Bool
-> Triv k cls color
-> Graph k cls color
-> k
-> k
-> Node k cls color
-> Node k cls color
-> (Graph k cls color, Maybe (k, k))
forall k cls color.
(Uniquable k, Eq cls) =>
Bool
-> Triv k cls color
-> Graph k cls color
-> k
-> k
-> Node k cls color
-> Node k cls color
-> (Graph k cls color, Maybe (k, k))
coalesceNodes_merge Bool
aggressive Triv k cls color
triv Graph k cls color
graph k
kMin k
kMax Node k cls color
nMin Node k cls color
nMax
| Bool
otherwise
= (Graph k cls color
graph, Maybe (k, k)
forall a. Maybe a
Nothing)
coalesceNodes_merge
:: (Uniquable k, Eq cls)
=> Bool
-> Triv k cls color
-> Graph k cls color
-> k -> k
-> Node k cls color
-> Node k cls color
-> (Graph k cls color, Maybe (k, k))
coalesceNodes_merge :: forall k cls color.
(Uniquable k, Eq cls) =>
Bool
-> Triv k cls color
-> Graph k cls color
-> k
-> k
-> Node k cls color
-> Node k cls color
-> (Graph k cls color, Maybe (k, k))
coalesceNodes_merge Bool
aggressive Triv k cls color
triv Graph k cls color
graph k
kMin k
kMax Node k cls color
nMin Node k cls color
nMax
| Node k cls color -> cls
forall k cls color. Node k cls color -> cls
nodeClass Node k cls color
nMin cls -> cls -> Bool
forall a. Eq a => a -> a -> Bool
/= Node k cls color -> cls
forall k cls color. Node k cls color -> cls
nodeClass Node k cls color
nMax
= String -> (Graph k cls color, Maybe (k, k))
forall a. HasCallStack => String -> a
error String
"GHC.Data.Graph.Ops.coalesceNodes: can't coalesce nodes of different classes."
| Bool -> Bool
not (Maybe color -> Bool
forall a. Maybe a -> Bool
isNothing (Node k cls color -> Maybe color
forall k cls color. Node k cls color -> Maybe color
nodeColor Node k cls color
nMin) Bool -> Bool -> Bool
&& Maybe color -> Bool
forall a. Maybe a -> Bool
isNothing (Node k cls color -> Maybe color
forall k cls color. Node k cls color -> Maybe color
nodeColor Node k cls color
nMax))
= String -> (Graph k cls color, Maybe (k, k))
forall a. HasCallStack => String -> a
error String
"GHC.Data.Graph.Ops.coalesceNodes: can't coalesce colored nodes."
| Bool
otherwise
= let
node :: Node k cls color
node =
Node { nodeId :: k
nodeId = k
kMin
, nodeClass :: cls
nodeClass = Node k cls color -> cls
forall k cls color. Node k cls color -> cls
nodeClass Node k cls color
nMin
, nodeColor :: Maybe color
nodeColor = Maybe color
forall a. Maybe a
Nothing
, nodeConflicts :: UniqSet k
nodeConflicts
= (UniqSet k -> UniqSet k -> UniqSet k
forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node k cls color
nMin) (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node k cls color
nMax))
UniqSet k -> k -> UniqSet k
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
`delOneFromUniqSet` k
kMin
UniqSet k -> k -> UniqSet k
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
`delOneFromUniqSet` k
kMax
, nodeExclusions :: UniqSet color
nodeExclusions = UniqSet color -> UniqSet color -> UniqSet color
forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets (Node k cls color -> UniqSet color
forall k cls color. Node k cls color -> UniqSet color
nodeExclusions Node k cls color
nMin) (Node k cls color -> UniqSet color
forall k cls color. Node k cls color -> UniqSet color
nodeExclusions Node k cls color
nMax)
, nodePreference :: [color]
nodePreference = Node k cls color -> [color]
forall k cls color. Node k cls color -> [color]
nodePreference Node k cls color
nMin [color] -> [color] -> [color]
forall a. [a] -> [a] -> [a]
++ Node k cls color -> [color]
forall k cls color. Node k cls color -> [color]
nodePreference Node k cls color
nMax
, nodeCoalesce :: UniqSet k
nodeCoalesce
= (UniqSet k -> UniqSet k -> UniqSet k
forall a. UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeCoalesce Node k cls color
nMin) (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeCoalesce Node k cls color
nMax))
UniqSet k -> k -> UniqSet k
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
`delOneFromUniqSet` k
kMin
UniqSet k -> k -> UniqSet k
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
`delOneFromUniqSet` k
kMax
}
in Bool
-> Triv k cls color
-> Graph k cls color
-> k
-> k
-> Node k cls color
-> (Graph k cls color, Maybe (k, k))
forall k cls color.
Uniquable k =>
Bool
-> Triv k cls color
-> Graph k cls color
-> k
-> k
-> Node k cls color
-> (Graph k cls color, Maybe (k, k))
coalesceNodes_check Bool
aggressive Triv k cls color
triv Graph k cls color
graph k
kMin k
kMax Node k cls color
node
coalesceNodes_check
:: Uniquable k
=> Bool
-> Triv k cls color
-> Graph k cls color
-> k -> k
-> Node k cls color
-> (Graph k cls color, Maybe (k, k))
coalesceNodes_check :: forall k cls color.
Uniquable k =>
Bool
-> Triv k cls color
-> Graph k cls color
-> k
-> k
-> Node k cls color
-> (Graph k cls color, Maybe (k, k))
coalesceNodes_check Bool
aggressive Triv k cls color
triv Graph k cls color
graph k
kMin k
kMax Node k cls color
node
| Bool -> Bool
not Bool
aggressive
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ 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)
= (Graph k cls color
graph, Maybe (k, k)
forall a. Maybe a
Nothing)
| Bool
otherwise
= let
Just Graph k cls color
graph1 = 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
kMax Graph k cls color
graph
Just Graph k cls color
graph2 = 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
kMin Graph k cls color
graph1
graph3 :: Graph k cls color
graph3 = k -> Node k cls color -> Graph k cls color -> Graph k cls color
forall k cls color.
Uniquable k =>
k -> Node k cls color -> Graph k cls color -> Graph k cls color
addNode k
kMin Node k cls color
node Graph k cls color
graph2
in (Graph k cls color
graph3, (k, k) -> Maybe (k, k)
forall a. a -> Maybe a
Just (k
kMax, k
kMin))
freezeNode
:: Uniquable k
=> k
-> Graph k cls color
-> Graph k cls color
freezeNode :: forall k cls color.
Uniquable k =>
k -> Graph k cls color -> Graph k cls color
freezeNode k
k
= (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color
forall k cls color.
(UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color
graphMapModify
((UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color)
-> (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color
-> Graph k cls color
forall a b. (a -> b) -> a -> b
$ \UniqFM k (Node k cls color)
fm ->
let
Just Node k cls color
node = UniqFM k (Node k cls color) -> k -> Maybe (Node k cls color)
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM k (Node k cls color)
fm k
k
node' :: Node k cls color
node' = Node k cls color
node
{ nodeCoalesce :: UniqSet k
nodeCoalesce = UniqSet k
forall a. UniqSet a
emptyUniqSet }
fm1 :: UniqFM k (Node k cls color)
fm1 = UniqFM k (Node k cls color)
-> k -> Node k cls color -> UniqFM k (Node k cls color)
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM k (Node k cls color)
fm k
k Node k cls color
node'
freezeEdge :: k -> Node k cls color -> Node k cls color
freezeEdge k
k Node k cls color
node
= if k -> UniqSet k -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet k
k (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeCoalesce Node k cls color
node)
then Node k cls color
node { nodeCoalesce :: UniqSet k
nodeCoalesce = UniqSet k -> k -> UniqSet k
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
delOneFromUniqSet (Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeCoalesce Node k cls color
node) k
k }
else Node k cls color
node
fm2 :: UniqFM k (Node k cls color)
fm2 = (k -> UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> UniqFM k (Node k cls color)
-> UniqSet k
-> UniqFM k (Node k cls color)
forall elt a. (elt -> a -> a) -> a -> UniqSet elt -> a
nonDetStrictFoldUniqSet ((Node k cls color -> Node k cls color)
-> k -> UniqFM k (Node k cls color) -> UniqFM k (Node k cls color)
forall k a.
Uniquable k =>
(a -> a) -> k -> UniqFM k a -> UniqFM k a
adjustUFM_C (k -> Node k cls color -> Node k cls color
forall {k} {cls} {color}.
Uniquable k =>
k -> Node k cls color -> Node k cls color
freezeEdge k
k)) UniqFM k (Node k cls color)
fm1
(UniqSet k -> UniqFM k (Node k cls color))
-> UniqSet k -> UniqFM k (Node k cls color)
forall a b. (a -> b) -> a -> b
$ Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeCoalesce Node k cls color
node
in UniqFM k (Node k cls color)
fm2
freezeOneInGraph
:: (Uniquable k)
=> Graph k cls color
-> ( Graph k cls color
, Bool )
freezeOneInGraph :: forall k cls color.
Uniquable k =>
Graph k cls color -> (Graph k cls color, Bool)
freezeOneInGraph Graph k cls color
graph
= let compareNodeDegree :: Node a cls color -> Node a cls color -> Ordering
compareNodeDegree Node a cls color
n1 Node a cls color
n2
= Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (UniqSet a -> Int
forall a. UniqSet a -> Int
sizeUniqSet (UniqSet a -> Int) -> UniqSet a -> Int
forall a b. (a -> b) -> a -> b
$ Node a cls color -> UniqSet a
forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node a cls color
n1) (UniqSet a -> Int
forall a. UniqSet a -> Int
sizeUniqSet (UniqSet a -> Int) -> UniqSet a -> Int
forall a b. (a -> b) -> a -> b
$ Node a cls color -> UniqSet a
forall k cls color. Node k cls color -> UniqSet k
nodeConflicts Node a cls color
n2)
candidates :: [Node k cls color]
candidates
= (Node k cls color -> Node k cls color -> Ordering)
-> [Node k cls color] -> [Node k cls color]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Node k cls color -> Node k cls color -> Ordering
forall {a} {cls} {color} {a} {cls} {color}.
Node a cls color -> Node a cls color -> Ordering
compareNodeDegree
([Node k cls color] -> [Node k cls color])
-> [Node k cls color] -> [Node k cls color]
forall a b. (a -> b) -> a -> b
$ Int -> [Node k cls color] -> [Node k cls color]
forall a. Int -> [a] -> [a]
take Int
5
([Node k cls color] -> [Node k cls color])
-> [Node k cls color] -> [Node k cls color]
forall a b. (a -> b) -> a -> b
$ (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 -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ 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
graph
in case [Node k cls color]
candidates of
[] -> (Graph k cls color
graph, Bool
False)
(Node k cls color
n : [Node k cls color]
_)
-> ( k -> Graph k cls color -> Graph k cls color
forall k cls color.
Uniquable k =>
k -> Graph k cls color -> Graph k cls color
freezeNode (Node k cls color -> k
forall k cls color. Node k cls color -> k
nodeId Node k cls color
n) Graph k cls color
graph
, Bool
True)
freezeAllInGraph
:: (Uniquable k)
=> Graph k cls color
-> Graph k cls color
freezeAllInGraph :: forall k cls color.
Uniquable k =>
Graph k cls color -> Graph k cls color
freezeAllInGraph Graph k cls color
graph
= (k -> Graph k cls color -> Graph k cls color)
-> Graph k cls color -> [k] -> Graph k cls color
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr k -> Graph k cls color -> Graph k cls color
forall k cls color.
Uniquable k =>
k -> Graph k cls color -> Graph k cls color
freezeNode Graph k cls color
graph
([k] -> Graph k cls color) -> [k] -> Graph k cls color
forall a b. (a -> b) -> a -> b
$ (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] -> [k]) -> [Node k cls color] -> [k]
forall a b. (a -> b) -> a -> b
$ UniqFM k (Node k cls color) -> [Node k cls color]
forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM (UniqFM k (Node k cls color) -> [Node k cls color])
-> UniqFM k (Node k cls color) -> [Node k cls color]
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
scanGraph
:: (Node k cls color -> Bool)
-> Graph k cls color
-> [Node k cls color]
scanGraph :: forall k cls color.
(Node k cls color -> Bool)
-> Graph k cls color -> [Node k cls color]
scanGraph Node k cls color -> Bool
match Graph k cls color
graph
= (Node k cls color -> Bool)
-> [Node k cls color] -> [Node k cls color]
forall a. (a -> Bool) -> [a] -> [a]
filter Node k cls color -> Bool
match ([Node k cls color] -> [Node k cls color])
-> [Node k cls color] -> [Node k cls color]
forall a b. (a -> b) -> a -> b
$ UniqFM k (Node k cls color) -> [Node k cls color]
forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM (UniqFM k (Node k cls color) -> [Node k cls color])
-> UniqFM k (Node k cls color) -> [Node k cls color]
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
validateGraph
:: (Uniquable k, Outputable k, Eq color)
=> SDoc
-> Bool
-> Graph k cls color
-> Graph k cls color
validateGraph :: forall k color cls.
(Uniquable k, Outputable k, Eq color) =>
SDoc -> Bool -> Graph k cls color -> Graph k cls color
validateGraph SDoc
doc Bool
isColored Graph k cls color
graph
| UniqSet k
edges <- [UniqSet k] -> UniqSet k
forall a. [UniqSet a] -> UniqSet a
unionManyUniqSets
( ((Node k cls color -> UniqSet k)
-> [Node k cls color] -> [UniqSet k]
forall a b. (a -> b) -> [a] -> [b]
map Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeConflicts ([Node k cls color] -> [UniqSet k])
-> [Node k cls color] -> [UniqSet k]
forall a b. (a -> b) -> a -> b
$ UniqFM k (Node k cls color) -> [Node k cls color]
forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM (UniqFM k (Node k cls color) -> [Node k cls color])
-> UniqFM k (Node k cls color) -> [Node k cls color]
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)
[UniqSet k] -> [UniqSet k] -> [UniqSet k]
forall a. [a] -> [a] -> [a]
++ ((Node k cls color -> UniqSet k)
-> [Node k cls color] -> [UniqSet k]
forall a b. (a -> b) -> [a] -> [b]
map Node k cls color -> UniqSet k
forall k cls color. Node k cls color -> UniqSet k
nodeCoalesce ([Node k cls color] -> [UniqSet k])
-> [Node k cls color] -> [UniqSet k]
forall a b. (a -> b) -> a -> b
$ UniqFM k (Node k cls color) -> [Node k cls color]
forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM (UniqFM k (Node k cls color) -> [Node k cls color])
-> UniqFM k (Node k cls color) -> [Node k cls color]
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))
, UniqSet k
nodes <- [k] -> UniqSet k
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet ([k] -> UniqSet k) -> [k] -> UniqSet k
forall a b. (a -> b) -> a -> b
$ (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] -> [k]) -> [Node k cls color] -> [k]
forall a b. (a -> b) -> a -> b
$ UniqFM k (Node k cls color) -> [Node k cls color]
forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM (UniqFM k (Node k cls color) -> [Node k cls color])
-> UniqFM k (Node k cls color) -> [Node k cls color]
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
, UniqSet k
badEdges <- UniqSet k -> UniqSet k -> UniqSet k
forall a. UniqSet a -> UniqSet a -> UniqSet a
minusUniqSet UniqSet k
edges UniqSet k
nodes
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ UniqSet k -> Bool
forall a. UniqSet a -> Bool
isEmptyUniqSet UniqSet k
badEdges
= String -> SDoc -> Graph k cls color
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"GHC.Data.Graph.Ops.validateGraph"
( String -> SDoc
text String
"Graph has edges that point to non-existent nodes"
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
" bad edges: " SDoc -> SDoc -> SDoc
<> UniqFM k k -> ([k] -> SDoc) -> SDoc
forall key a. UniqFM key a -> ([a] -> SDoc) -> SDoc
pprUFM (UniqSet k -> UniqFM k k
forall a. UniqSet a -> UniqFM a a
getUniqSet UniqSet k
badEdges) ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> ([k] -> [SDoc]) -> [k] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k -> SDoc) -> [k] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map k -> SDoc
forall a. Outputable a => a -> SDoc
ppr)
SDoc -> SDoc -> SDoc
$$ SDoc
doc )
| [Node k cls color]
badNodes <- (Node k cls color -> Bool)
-> [Node k cls color] -> [Node k cls color]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (Node k cls color -> Bool) -> Node k cls color -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Graph k cls color -> Node k cls color -> Bool
forall k color cls.
(Uniquable k, Eq color) =>
Graph k cls color -> Node k cls color -> Bool
checkNode Graph k cls color
graph))
([Node k cls color] -> [Node k cls color])
-> [Node k cls color] -> [Node k cls color]
forall a b. (a -> b) -> a -> b
$ UniqFM k (Node k cls color) -> [Node k cls color]
forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM (UniqFM k (Node k cls color) -> [Node k cls color])
-> UniqFM k (Node k cls color) -> [Node k cls color]
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
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Node k cls color] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Node k cls color]
badNodes
= String -> SDoc -> Graph k cls color
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"GHC.Data.Graph.Ops.validateGraph"
( String -> SDoc
text String
"Node has same color as one of it's conflicts"
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
" bad nodes: " SDoc -> SDoc -> SDoc
<> [SDoc] -> SDoc
hcat ((Node k cls color -> SDoc) -> [Node k cls color] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (k -> SDoc
forall a. Outputable a => a -> SDoc
ppr (k -> SDoc) -> (Node k cls color -> k) -> Node k cls color -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node k cls color -> k
forall k cls color. Node k cls color -> k
nodeId) [Node k cls color]
badNodes)
SDoc -> SDoc -> SDoc
$$ SDoc
doc)
| Bool
isColored
, [Node k cls color]
badNodes <- (Node k cls color -> Bool)
-> [Node k cls color] -> [Node k cls color]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Node k cls color
n -> Maybe color -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe color -> Bool) -> Maybe color -> Bool
forall a b. (a -> b) -> a -> b
$ Node k cls color -> Maybe color
forall k cls color. Node k cls color -> Maybe color
nodeColor Node k cls color
n)
([Node k cls color] -> [Node k cls color])
-> [Node k cls color] -> [Node k cls color]
forall a b. (a -> b) -> a -> b
$ UniqFM k (Node k cls color) -> [Node k cls color]
forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM (UniqFM k (Node k cls color) -> [Node k cls color])
-> UniqFM k (Node k cls color) -> [Node k cls color]
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
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Node k cls color] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Node k cls color]
badNodes
= String -> SDoc -> Graph k cls color
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"GHC.Data.Graph.Ops.validateGraph"
( String -> SDoc
text String
"Supposably colored graph has uncolored nodes."
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
" uncolored nodes: " SDoc -> SDoc -> SDoc
<> [SDoc] -> SDoc
hcat ((Node k cls color -> SDoc) -> [Node k cls color] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (k -> SDoc
forall a. Outputable a => a -> SDoc
ppr (k -> SDoc) -> (Node k cls color -> k) -> Node k cls color -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node k cls color -> k
forall k cls color. Node k cls color -> k
nodeId) [Node k cls color]
badNodes)
SDoc -> SDoc -> SDoc
$$ SDoc
doc )
| Bool
otherwise
= Graph k cls color
graph
checkNode
:: (Uniquable k, Eq color)
=> Graph k cls color
-> Node k cls color
-> Bool
checkNode :: forall k color cls.
(Uniquable k, Eq color) =>
Graph k cls color -> Node k cls color -> Bool
checkNode Graph k cls color
graph Node k cls color
node
| Just color
color <- Node k cls color -> Maybe color
forall k cls color. Node k cls color -> Maybe color
nodeColor Node k cls color
node
, Just [Node k cls color]
neighbors <- [Maybe (Node k cls color)] -> Maybe [Node k cls color]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t 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
, [color]
neighbourColors <- [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]
neighbors
, color -> [color] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem color
color [color]
neighbourColors
= Bool
False
| Bool
otherwise
= Bool
True
slurpNodeConflictCount
:: Graph k cls color
-> UniqFM Int (Int, Int)
slurpNodeConflictCount :: forall k cls color. Graph k cls color -> UniqFM Int (Int, Int)
slurpNodeConflictCount Graph k cls color
graph
= ((Int, Int) -> (Int, Int) -> (Int, Int))
-> UniqFM Int (Int, Int)
-> [(Int, (Int, Int))]
-> UniqFM Int (Int, Int)
forall key elt.
Uniquable key =>
(elt -> elt -> elt)
-> UniqFM key elt -> [(key, elt)] -> UniqFM key elt
addListToUFM_C
(\(Int
c1, Int
n1) (Int
_, Int
n2) -> (Int
c1, Int
n1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n2))
UniqFM Int (Int, Int)
forall key elt. UniqFM key elt
emptyUFM
([(Int, (Int, Int))] -> UniqFM Int (Int, Int))
-> [(Int, (Int, Int))] -> UniqFM Int (Int, Int)
forall a b. (a -> b) -> a -> b
$ (Node k cls color -> (Int, (Int, Int)))
-> [Node k cls color] -> [(Int, (Int, Int))]
forall a b. (a -> b) -> [a] -> [b]
map (\Node k cls color
node
-> let count :: Int
count = UniqSet k -> Int
forall a. UniqSet a -> Int
sizeUniqSet (UniqSet k -> Int) -> UniqSet k -> Int
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
in (Int
count, (Int
count, Int
1)))
([Node k cls color] -> [(Int, (Int, Int))])
-> [Node k cls color] -> [(Int, (Int, Int))]
forall a b. (a -> b) -> a -> b
$ UniqFM k (Node k cls color) -> [Node k cls color]
forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM
(UniqFM k (Node k cls color) -> [Node k cls color])
-> UniqFM k (Node k cls color) -> [Node k cls color]
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
setColor
:: Uniquable k
=> k -> color
-> Graph k cls color -> Graph k cls color
setColor :: forall k color cls.
Uniquable k =>
k -> color -> Graph k cls color -> Graph k cls color
setColor k
u color
color
= (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color
forall k cls color.
(UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color
graphMapModify
((UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color -> Graph k cls color)
-> (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-> Graph k cls color
-> Graph k cls color
forall a b. (a -> b) -> a -> b
$ (Node k cls color -> Node k cls color)
-> k -> UniqFM k (Node k cls color) -> UniqFM k (Node k cls color)
forall k a.
Uniquable k =>
(a -> a) -> k -> UniqFM k a -> UniqFM k a
adjustUFM_C
(\Node k cls color
n -> Node k cls color
n { nodeColor :: Maybe color
nodeColor = color -> Maybe color
forall a. a -> Maybe a
Just color
color })
k
u
{-# INLINE adjustWithDefaultUFM #-}
adjustWithDefaultUFM
:: Uniquable k
=> (a -> a) -> a -> k
-> UniqFM k a -> UniqFM k a
adjustWithDefaultUFM :: forall k a.
Uniquable k =>
(a -> a) -> a -> k -> UniqFM k a -> UniqFM k a
adjustWithDefaultUFM a -> a
f a
def k
k UniqFM k a
map
= (a -> a -> a) -> UniqFM k a -> k -> a -> UniqFM k a
forall key elt.
Uniquable key =>
(elt -> elt -> elt)
-> UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM_C
(\a
old a
_ -> a -> a
f a
old)
UniqFM k a
map
k
k a
def
{-# INLINE adjustUFM_C #-}
adjustUFM_C
:: Uniquable k
=> (a -> a)
-> k -> UniqFM k a -> UniqFM k a
adjustUFM_C :: forall k a.
Uniquable k =>
(a -> a) -> k -> UniqFM k a -> UniqFM k a
adjustUFM_C a -> a
f k
k UniqFM k a
map
= case UniqFM k a -> k -> Maybe a
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM k a
map k
k of
Maybe a
Nothing -> UniqFM k a
map
Just a
a -> UniqFM k a -> k -> a -> UniqFM k a
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM k a
map k
k (a -> a
f a
a)