{-# language BangPatterns #-}
{-# language NamedFieldPuns #-}
{-# language RecordWildCards #-}
{-# language ScopedTypeVariables #-}
module Reactive.Banana.Prim.Low.Graph
( Graph
, empty
, getOutgoing
, getIncoming
, size
, edgeCount
, listConnectedVertices
, deleteVertex
, insertEdge
, deleteEdge
, clearPredecessors
, collectGarbage
, topologicalSort
, Step (..)
, walkSuccessors
, walkSuccessors_
, Level
, getLevel
, showDot
) where
import Data.Functor.Identity
( Identity (..) )
import Data.Hashable
( Hashable )
import Data.Maybe
( fromMaybe )
import Reactive.Banana.Prim.Low.GraphTraversal
( reversePostOrder )
import qualified Data.List as L
import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet as Set
import qualified Data.PQueue.Prio.Min as Q
type Queue = Q.MinPQueue
type Map = Map.HashMap
type Set = Set.HashSet
type Level = Int
ground :: Level
ground :: Level
ground = Level
0
data Graph v e = Graph
{
forall v e. Graph v e -> Map v (Map v e)
outgoing :: !(Map v (Map v e))
, forall v e. Graph v e -> Map v (Map v e)
incoming :: !(Map v (Map v e))
, forall v e. Graph v e -> Map v Level
levels :: !(Map v Level)
} deriving (Graph v e -> Graph v e -> Bool
(Graph v e -> Graph v e -> Bool)
-> (Graph v e -> Graph v e -> Bool) -> Eq (Graph v e)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall v e. (Eq v, Eq e) => Graph v e -> Graph v e -> Bool
$c== :: forall v e. (Eq v, Eq e) => Graph v e -> Graph v e -> Bool
== :: Graph v e -> Graph v e -> Bool
$c/= :: forall v e. (Eq v, Eq e) => Graph v e -> Graph v e -> Bool
/= :: Graph v e -> Graph v e -> Bool
Eq, Level -> Graph v e -> ShowS
[Graph v e] -> ShowS
Graph v e -> String
(Level -> Graph v e -> ShowS)
-> (Graph v e -> String)
-> ([Graph v e] -> ShowS)
-> Show (Graph v e)
forall a.
(Level -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall v e. (Show v, Show e) => Level -> Graph v e -> ShowS
forall v e. (Show v, Show e) => [Graph v e] -> ShowS
forall v e. (Show v, Show e) => Graph v e -> String
$cshowsPrec :: forall v e. (Show v, Show e) => Level -> Graph v e -> ShowS
showsPrec :: Level -> Graph v e -> ShowS
$cshow :: forall v e. (Show v, Show e) => Graph v e -> String
show :: Graph v e -> String
$cshowList :: forall v e. (Show v, Show e) => [Graph v e] -> ShowS
showList :: [Graph v e] -> ShowS
Show)
empty :: Graph v e
empty :: forall v e. Graph v e
empty = Graph
{ outgoing :: Map v (Map v e)
outgoing = Map v (Map v e)
forall k v. HashMap k v
Map.empty
, incoming :: Map v (Map v e)
incoming = Map v (Map v e)
forall k v. HashMap k v
Map.empty
, levels :: Map v Level
levels = Map v Level
forall k v. HashMap k v
Map.empty
}
getOutgoing :: (Eq v, Hashable v) => Graph v e -> v -> [(e,v)]
getOutgoing :: forall v e. (Eq v, Hashable v) => Graph v e -> v -> [(e, v)]
getOutgoing Graph{Map v (Map v e)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
outgoing :: Map v (Map v e)
outgoing} v
x =
((v, e) -> (e, v)) -> [(v, e)] -> [(e, v)]
forall a b. (a -> b) -> [a] -> [b]
map (v, e) -> (e, v)
forall {b} {a}. (b, a) -> (a, b)
shuffle ([(v, e)] -> [(e, v)]) -> [(v, e)] -> [(e, v)]
forall a b. (a -> b) -> a -> b
$ Map v e -> [(v, e)]
forall k v. HashMap k v -> [(k, v)]
Map.toList (Map v e -> [(v, e)]) -> Map v e -> [(v, e)]
forall a b. (a -> b) -> a -> b
$ Map v e -> Maybe (Map v e) -> Map v e
forall a. a -> Maybe a -> a
fromMaybe Map v e
forall k v. HashMap k v
Map.empty (Maybe (Map v e) -> Map v e) -> Maybe (Map v e) -> Map v e
forall a b. (a -> b) -> a -> b
$ v -> Map v (Map v e) -> Maybe (Map v e)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup v
x Map v (Map v e)
outgoing
where
shuffle :: (b, a) -> (a, b)
shuffle (b
x,a
y) = (a
y,b
x)
getIncoming :: (Eq v, Hashable v) => Graph v e -> v -> [(v,e)]
getIncoming :: forall v e. (Eq v, Hashable v) => Graph v e -> v -> [(v, e)]
getIncoming Graph{Map v (Map v e)
incoming :: forall v e. Graph v e -> Map v (Map v e)
incoming :: Map v (Map v e)
incoming} v
x =
Map v e -> [(v, e)]
forall k v. HashMap k v -> [(k, v)]
Map.toList (Map v e -> [(v, e)]) -> Map v e -> [(v, e)]
forall a b. (a -> b) -> a -> b
$ Map v e -> Maybe (Map v e) -> Map v e
forall a. a -> Maybe a -> a
fromMaybe Map v e
forall k v. HashMap k v
Map.empty (Maybe (Map v e) -> Map v e) -> Maybe (Map v e) -> Map v e
forall a b. (a -> b) -> a -> b
$ v -> Map v (Map v e) -> Maybe (Map v e)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup v
x Map v (Map v e)
incoming
getLevel :: (Eq v, Hashable v) => Graph v e -> v -> Level
getLevel :: forall v e. (Eq v, Hashable v) => Graph v e -> v -> Level
getLevel Graph{Map v Level
levels :: forall v e. Graph v e -> Map v Level
levels :: Map v Level
levels} v
x = Level -> Maybe Level -> Level
forall a. a -> Maybe a -> a
fromMaybe Level
ground (Maybe Level -> Level) -> Maybe Level -> Level
forall a b. (a -> b) -> a -> b
$ v -> Map v Level -> Maybe Level
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup v
x Map v Level
levels
listConnectedVertices :: (Eq v, Hashable v) => Graph v e -> [v]
listConnectedVertices :: forall v e. (Eq v, Hashable v) => Graph v e -> [v]
listConnectedVertices Graph{Map v (Map v e)
incoming :: forall v e. Graph v e -> Map v (Map v e)
incoming :: Map v (Map v e)
incoming,Map v (Map v e)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
outgoing :: Map v (Map v e)
outgoing} =
HashMap v () -> [v]
forall k v. HashMap k v -> [k]
Map.keys (HashMap v () -> [v]) -> HashMap v () -> [v]
forall a b. (a -> b) -> a -> b
$ (() () -> Map v (Map v e) -> HashMap v ()
forall a b. a -> HashMap v b -> HashMap v a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Map v (Map v e)
outgoing) HashMap v () -> HashMap v () -> HashMap v ()
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`Map.union` (() () -> Map v (Map v e) -> HashMap v ()
forall a b. a -> HashMap v b -> HashMap v a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Map v (Map v e)
incoming)
size :: (Eq v, Hashable v) => Graph v e -> Int
size :: forall v e. (Eq v, Hashable v) => Graph v e -> Level
size Graph{Map v (Map v e)
incoming :: forall v e. Graph v e -> Map v (Map v e)
incoming :: Map v (Map v e)
incoming,Map v (Map v e)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
outgoing :: Map v (Map v e)
outgoing} =
HashMap v () -> Level
forall k v. HashMap k v -> Level
Map.size (HashMap v () -> Level) -> HashMap v () -> Level
forall a b. (a -> b) -> a -> b
$ (() () -> Map v (Map v e) -> HashMap v ()
forall a b. a -> HashMap v b -> HashMap v a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Map v (Map v e)
outgoing) HashMap v () -> HashMap v () -> HashMap v ()
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`Map.union` (() () -> Map v (Map v e) -> HashMap v ()
forall a b. a -> HashMap v b -> HashMap v a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Map v (Map v e)
incoming)
edgeCount :: (Eq v, Hashable v) => Graph v e -> Int
edgeCount :: forall v e. (Eq v, Hashable v) => Graph v e -> Level
edgeCount Graph{Map v (Map v e)
incoming :: forall v e. Graph v e -> Map v (Map v e)
incoming :: Map v (Map v e)
incoming,Map v (Map v e)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
outgoing :: Map v (Map v e)
outgoing} =
(Map v (Map v e) -> Level
forall {k} {k} {v}. HashMap k (HashMap k v) -> Level
count Map v (Map v e)
incoming Level -> Level -> Level
forall a. Num a => a -> a -> a
+ Map v (Map v e) -> Level
forall {k} {k} {v}. HashMap k (HashMap k v) -> Level
count Map v (Map v e)
outgoing) Level -> Level -> Level
forall a. Integral a => a -> a -> a
`div` Level
2
where
count :: HashMap k (HashMap k v) -> Level
count = (Level -> HashMap k v -> Level)
-> Level -> HashMap k (HashMap k v) -> Level
forall a v k. (a -> v -> a) -> a -> HashMap k v -> a
Map.foldl' (\Level
a HashMap k v
v -> HashMap k v -> Level
forall k v. HashMap k v -> Level
Map.size HashMap k v
v Level -> Level -> Level
forall a. Num a => a -> a -> a
+ Level
a) Level
0
insertEdge :: (Eq v, Hashable v) => (v,v) -> e -> Graph v e -> Graph v e
insertEdge :: forall v e.
(Eq v, Hashable v) =>
(v, v) -> e -> Graph v e -> Graph v e
insertEdge (v
x,v
y) e
exy g0 :: Graph v e
g0@Graph{Map v Level
Map v (Map v e)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
incoming :: forall v e. Graph v e -> Map v (Map v e)
levels :: forall v e. Graph v e -> Map v Level
outgoing :: Map v (Map v e)
incoming :: Map v (Map v e)
levels :: Map v Level
..} = Graph
{ outgoing :: Map v (Map v e)
outgoing
= (Map v e -> Map v e -> Map v e)
-> v -> Map v e -> Map v (Map v e) -> Map v (Map v e)
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
Map.insertWith (\Map v e
new Map v e
old -> Map v e
new Map v e -> Map v e -> Map v e
forall a. Semigroup a => a -> a -> a
<> Map v e
old) v
x (v -> e -> Map v e
forall k v. Hashable k => k -> v -> HashMap k v
Map.singleton v
y e
exy)
(Map v (Map v e) -> Map v (Map v e))
-> Map v (Map v e) -> Map v (Map v e)
forall a b. (a -> b) -> a -> b
$ v -> Map v e -> Map v (Map v e) -> Map v (Map v e)
forall k a. (Eq k, Hashable k) => k -> a -> Map k a -> Map k a
insertDefaultIfNotMember v
y Map v e
forall k v. HashMap k v
Map.empty
(Map v (Map v e) -> Map v (Map v e))
-> Map v (Map v e) -> Map v (Map v e)
forall a b. (a -> b) -> a -> b
$ Map v (Map v e)
outgoing
, incoming :: Map v (Map v e)
incoming
= (Map v e -> Map v e -> Map v e)
-> v -> Map v e -> Map v (Map v e) -> Map v (Map v e)
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
Map.insertWith (\Map v e
new Map v e
old -> Map v e
new Map v e -> Map v e -> Map v e
forall a. Semigroup a => a -> a -> a
<> Map v e
old) v
y (v -> e -> Map v e
forall k v. Hashable k => k -> v -> HashMap k v
Map.singleton v
x e
exy)
(Map v (Map v e) -> Map v (Map v e))
-> (Map v (Map v e) -> Map v (Map v e))
-> Map v (Map v e)
-> Map v (Map v e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Map v e -> Map v (Map v e) -> Map v (Map v e)
forall k a. (Eq k, Hashable k) => k -> a -> Map k a -> Map k a
insertDefaultIfNotMember v
x Map v e
forall k v. HashMap k v
Map.empty
(Map v (Map v e) -> Map v (Map v e))
-> Map v (Map v e) -> Map v (Map v e)
forall a b. (a -> b) -> a -> b
$ Map v (Map v e)
incoming
, levels :: Map v Level
levels
= Map v Level -> Map v Level
adjustLevels
(Map v Level -> Map v Level) -> Map v Level -> Map v Level
forall a b. (a -> b) -> a -> b
$ Map v Level
levels0
}
where
getLevel :: k -> HashMap k Level -> Level
getLevel k
z = Level -> Maybe Level -> Level
forall a. a -> Maybe a -> a
fromMaybe Level
ground (Maybe Level -> Level)
-> (HashMap k Level -> Maybe Level) -> HashMap k Level -> Level
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> HashMap k Level -> Maybe Level
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup k
z
levels0 :: Map v Level
levels0
= v -> Level -> Map v Level -> Map v Level
forall k a. (Eq k, Hashable k) => k -> a -> Map k a -> Map k a
insertDefaultIfNotMember v
x (Level
groundLevel -> Level -> Level
forall a. Num a => a -> a -> a
-Level
1)
(Map v Level -> Map v Level)
-> (Map v Level -> Map v Level) -> Map v Level -> Map v Level
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Level -> Map v Level -> Map v Level
forall k a. (Eq k, Hashable k) => k -> a -> Map k a -> Map k a
insertDefaultIfNotMember v
y Level
ground
(Map v Level -> Map v Level) -> Map v Level -> Map v Level
forall a b. (a -> b) -> a -> b
$ Map v Level
levels
levelDifference :: Level
levelDifference = v -> Map v Level -> Level
forall {k}. Hashable k => k -> HashMap k Level -> Level
getLevel v
y Map v Level
levels0 Level -> Level -> Level
forall a. Num a => a -> a -> a
- Level
1 Level -> Level -> Level
forall a. Num a => a -> a -> a
- v -> Map v Level -> Level
forall {k}. Hashable k => k -> HashMap k Level -> Level
getLevel v
x Map v Level
levels0
adjustLevel :: HashMap k Level -> k -> HashMap k Level
adjustLevel HashMap k Level
g k
x = (Level -> Level) -> k -> HashMap k Level -> HashMap k Level
forall k v.
(Eq k, Hashable k) =>
(v -> v) -> k -> HashMap k v -> HashMap k v
Map.adjust (Level -> Level -> Level
forall a. Num a => a -> a -> a
+ Level
levelDifference) k
x HashMap k Level
g
adjustLevels :: Map v Level -> Map v Level
adjustLevels Map v Level
ls
| Level
levelDifference Level -> Level -> Bool
forall a. Ord a => a -> a -> Bool
>= Level
0 = Map v Level
ls
| Bool
otherwise = (Map v Level -> v -> Map v Level)
-> Map v Level -> [v] -> Map v Level
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' Map v Level -> v -> Map v Level
forall {k}. Hashable k => HashMap k Level -> k -> HashMap k Level
adjustLevel Map v Level
ls [v]
predecessors
where
Identity [v]
predecessors =
[v] -> GraphM Identity v -> Identity [v]
forall a (m :: * -> *).
(Eq a, Hashable a, Monad m) =>
[a] -> GraphM m a -> m [a]
reversePostOrder [v
x] ([v] -> Identity [v]
forall a. a -> Identity a
Identity ([v] -> Identity [v]) -> (v -> [v]) -> GraphM Identity v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((v, e) -> v) -> [(v, e)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (v, e) -> v
forall a b. (a, b) -> a
fst ([(v, e)] -> [v]) -> (v -> [(v, e)]) -> v -> [v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph v e -> v -> [(v, e)]
forall v e. (Eq v, Hashable v) => Graph v e -> v -> [(v, e)]
getIncoming Graph v e
g0)
insertDefaultIfNotMember
:: (Eq k, Hashable k)
=> k -> a -> Map k a -> Map k a
insertDefaultIfNotMember :: forall k a. (Eq k, Hashable k) => k -> a -> Map k a -> Map k a
insertDefaultIfNotMember k
x a
def = (a -> a -> a) -> k -> a -> HashMap k a -> HashMap k a
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
Map.insertWith (\a
_ a
old -> a
old) k
x a
def
deleteEdge :: (Eq v, Hashable v) => (v,v) -> Graph v e -> Graph v e
deleteEdge :: forall v e. (Eq v, Hashable v) => (v, v) -> Graph v e -> Graph v e
deleteEdge (v
x,v
y) Graph v e
g = Graph
{ outgoing :: Map v (Map v e)
outgoing = v -> Graph v e -> Map v (Map v e)
forall a. HasCallStack => a
undefined v
x Graph v e
g
, incoming :: Map v (Map v e)
incoming = v -> Graph v e -> Map v (Map v e)
forall a. HasCallStack => a
undefined v
y Graph v e
g
, levels :: Map v Level
levels = Map v Level
forall a. HasCallStack => a
undefined
}
deleteVertex :: (Eq v, Hashable v) => v -> Graph v e -> Graph v e
deleteVertex :: forall v e. (Eq v, Hashable v) => v -> Graph v e -> Graph v e
deleteVertex v
x = Graph v e -> Graph v e
forall {e}. Graph v e -> Graph v e
clearLevels (Graph v e -> Graph v e)
-> (Graph v e -> Graph v e) -> Graph v e -> Graph v e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Graph v e -> Graph v e
forall v e. (Eq v, Hashable v) => v -> Graph v e -> Graph v e
clearPredecessors v
x (Graph v e -> Graph v e)
-> (Graph v e -> Graph v e) -> Graph v e -> Graph v e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Graph v e -> Graph v e
forall v e. (Eq v, Hashable v) => v -> Graph v e -> Graph v e
clearSuccessors v
x
where
clearLevels :: Graph v e -> Graph v e
clearLevels g :: Graph v e
g@Graph{Map v Level
levels :: forall v e. Graph v e -> Map v Level
levels :: Map v Level
levels} = Graph v e
g{levels :: Map v Level
levels = v -> Map v Level -> Map v Level
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete v
x Map v Level
levels}
clearPredecessors :: (Eq v, Hashable v) => v -> Graph v e -> Graph v e
clearPredecessors :: forall v e. (Eq v, Hashable v) => v -> Graph v e -> Graph v e
clearPredecessors v
x g :: Graph v e
g@Graph{Map v Level
Map v (Map v e)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
incoming :: forall v e. Graph v e -> Map v (Map v e)
levels :: forall v e. Graph v e -> Map v Level
outgoing :: Map v (Map v e)
incoming :: Map v (Map v e)
levels :: Map v Level
..} = Graph v e
g
{ outgoing :: Map v (Map v e)
outgoing = ((Map v (Map v e) -> Map v (Map v e))
-> Map v (Map v e) -> Map v (Map v e))
-> Map v (Map v e)
-> [Map v (Map v e) -> Map v (Map v e)]
-> Map v (Map v e)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Map v (Map v e) -> Map v (Map v e))
-> Map v (Map v e) -> Map v (Map v e)
forall a b. (a -> b) -> a -> b
($) Map v (Map v e)
outgoing
[ (Map v e -> Map v e) -> v -> Map v (Map v e) -> Map v (Map v e)
forall k v.
(Eq k, Hashable k) =>
(v -> v) -> k -> HashMap k v -> HashMap k v
Map.adjust (v -> Map v e -> Map v e
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete v
x) v
z | (v
z,e
_) <- Graph v e -> v -> [(v, e)]
forall v e. (Eq v, Hashable v) => Graph v e -> v -> [(v, e)]
getIncoming Graph v e
g v
x ]
, incoming :: Map v (Map v e)
incoming = v -> Map v (Map v e) -> Map v (Map v e)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete v
x Map v (Map v e)
incoming
}
clearSuccessors :: (Eq v, Hashable v) => v -> Graph v e -> Graph v e
clearSuccessors :: forall v e. (Eq v, Hashable v) => v -> Graph v e -> Graph v e
clearSuccessors v
x g :: Graph v e
g@Graph{Map v Level
Map v (Map v e)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
incoming :: forall v e. Graph v e -> Map v (Map v e)
levels :: forall v e. Graph v e -> Map v Level
outgoing :: Map v (Map v e)
incoming :: Map v (Map v e)
levels :: Map v Level
..} = Graph v e
g
{ outgoing :: Map v (Map v e)
outgoing = v -> Map v (Map v e) -> Map v (Map v e)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete v
x Map v (Map v e)
outgoing
, incoming :: Map v (Map v e)
incoming = ((Map v (Map v e) -> Map v (Map v e))
-> Map v (Map v e) -> Map v (Map v e))
-> Map v (Map v e)
-> [Map v (Map v e) -> Map v (Map v e)]
-> Map v (Map v e)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Map v (Map v e) -> Map v (Map v e))
-> Map v (Map v e) -> Map v (Map v e)
forall a b. (a -> b) -> a -> b
($) Map v (Map v e)
incoming
[ (Map v e -> Map v e) -> v -> Map v (Map v e) -> Map v (Map v e)
forall k v.
(Eq k, Hashable k) =>
(v -> v) -> k -> HashMap k v -> HashMap k v
Map.adjust (v -> Map v e -> Map v e
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete v
x) v
z | (e
_,v
z) <- Graph v e -> v -> [(e, v)]
forall v e. (Eq v, Hashable v) => Graph v e -> v -> [(e, v)]
getOutgoing Graph v e
g v
x ]
}
collectGarbage :: (Eq v, Hashable v) => [v] -> Graph v e -> Graph v e
collectGarbage :: forall v e. (Eq v, Hashable v) => [v] -> Graph v e -> Graph v e
collectGarbage [v]
roots g :: Graph v e
g@Graph{Map v (Map v e)
incoming :: forall v e. Graph v e -> Map v (Map v e)
incoming :: Map v (Map v e)
incoming,Map v (Map v e)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
outgoing :: Map v (Map v e)
outgoing} = Graph v e
g
{ incoming :: Map v (Map v e)
incoming = (v -> Map v e -> Bool) -> Map v (Map v e) -> Map v (Map v e)
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
Map.filterWithKey (\v
v Map v e
_ -> v -> Bool
isReachable v
v) Map v (Map v e)
incoming
, outgoing :: Map v (Map v e)
outgoing
= (Map v e -> Map v e) -> Map v (Map v e) -> Map v (Map v e)
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map ((v -> e -> Bool) -> Map v e -> Map v e
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
Map.filterWithKey (\v
v e
_ -> v -> Bool
isReachable v
v))
(Map v (Map v e) -> Map v (Map v e))
-> Map v (Map v e) -> Map v (Map v e)
forall a b. (a -> b) -> a -> b
$ (v -> Map v e -> Bool) -> Map v (Map v e) -> Map v (Map v e)
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
Map.filterWithKey (\v
v Map v e
_ -> v -> Bool
isReachable v
v) Map v (Map v e)
outgoing
}
where
isReachable :: v -> Bool
isReachable v
x = v
x v -> HashSet v -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`Set.member` HashSet v
reachables
reachables :: HashSet v
reachables
= [v] -> HashSet v
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList ([v] -> HashSet v)
-> (Identity [v] -> [v]) -> Identity [v] -> HashSet v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity [v] -> [v]
forall a. Identity a -> a
runIdentity
(Identity [v] -> HashSet v) -> Identity [v] -> HashSet v
forall a b. (a -> b) -> a -> b
$ [v] -> GraphM Identity v -> Identity [v]
forall a (m :: * -> *).
(Eq a, Hashable a, Monad m) =>
[a] -> GraphM m a -> m [a]
reversePostOrder [v]
roots
(GraphM Identity v -> Identity [v])
-> GraphM Identity v -> Identity [v]
forall a b. (a -> b) -> a -> b
$ [v] -> Identity [v]
forall a. a -> Identity a
Identity ([v] -> Identity [v]) -> (v -> [v]) -> GraphM Identity v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((v, e) -> v) -> [(v, e)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (v, e) -> v
forall a b. (a, b) -> a
fst ([(v, e)] -> [v]) -> (v -> [(v, e)]) -> v -> [v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph v e -> v -> [(v, e)]
forall v e. (Eq v, Hashable v) => Graph v e -> v -> [(v, e)]
getIncoming Graph v e
g
topologicalSort :: (Eq v, Hashable v) => Graph v e -> [v]
topologicalSort :: forall v e. (Eq v, Hashable v) => Graph v e -> [v]
topologicalSort g :: Graph v e
g@Graph{Map v (Map v e)
incoming :: forall v e. Graph v e -> Map v (Map v e)
incoming :: Map v (Map v e)
incoming} =
Identity [v] -> [v]
forall a. Identity a -> a
runIdentity (Identity [v] -> [v]) -> Identity [v] -> [v]
forall a b. (a -> b) -> a -> b
$ [v] -> GraphM Identity v -> Identity [v]
forall a (m :: * -> *).
(Eq a, Hashable a, Monad m) =>
[a] -> GraphM m a -> m [a]
reversePostOrder [v]
roots ([v] -> Identity [v]
forall a. a -> Identity a
Identity ([v] -> Identity [v]) -> (v -> [v]) -> GraphM Identity v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((e, v) -> v) -> [(e, v)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (e, v) -> v
forall a b. (a, b) -> b
snd ([(e, v)] -> [v]) -> (v -> [(e, v)]) -> v -> [v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph v e -> v -> [(e, v)]
forall v e. (Eq v, Hashable v) => Graph v e -> v -> [(e, v)]
getOutgoing Graph v e
g)
where
roots :: [v]
roots = [ v
x | (v
x,Map v e
preds) <- Map v (Map v e) -> [(v, Map v e)]
forall k v. HashMap k v -> [(k, v)]
Map.toList Map v (Map v e)
incoming, Map v e -> Bool
forall a. HashMap v a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map v e
preds ]
data Step = Next | Stop
walkSuccessors
:: forall v e m. (Monad m, Eq v, Hashable v)
=> [v] -> (v -> m Step) -> Graph v e -> m [v]
walkSuccessors :: forall v e (m :: * -> *).
(Monad m, Eq v, Hashable v) =>
[v] -> (v -> m Step) -> Graph v e -> m [v]
walkSuccessors [v]
xs v -> m Step
step Graph v e
g = Queue Level v -> Set v -> [v] -> m [v]
go ([(Level, v)] -> Queue Level v
forall k a. Ord k => [(k, a)] -> MinPQueue k a
Q.fromList ([(Level, v)] -> Queue Level v) -> [(Level, v)] -> Queue Level v
forall a b. (a -> b) -> a -> b
$ [v] -> [(Level, v)]
zipLevels [v]
xs) Set v
forall a. HashSet a
Set.empty []
where
zipLevels :: [v] -> [(Level, v)]
zipLevels [v]
vs = [(Graph v e -> v -> Level
forall v e. (Eq v, Hashable v) => Graph v e -> v -> Level
getLevel Graph v e
g v
v, v
v) | v
v <- [v]
vs]
go :: Queue Level v -> Set v -> [v] -> m [v]
go :: Queue Level v -> Set v -> [v] -> m [v]
go Queue Level v
q0 Set v
seen [v]
visits = case Queue Level v -> Maybe (v, Queue Level v)
forall k a. Ord k => MinPQueue k a -> Maybe (a, MinPQueue k a)
Q.minView Queue Level v
q0 of
Maybe (v, Queue Level v)
Nothing -> [v] -> m [v]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([v] -> m [v]) -> [v] -> m [v]
forall a b. (a -> b) -> a -> b
$ [v] -> [v]
forall a. [a] -> [a]
reverse [v]
visits
Just (v
v,Queue Level v
q1)
| v
v v -> Set v -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`Set.member` Set v
seen -> Queue Level v -> Set v -> [v] -> m [v]
go Queue Level v
q1 Set v
seen [v]
visits
| Bool
otherwise -> do
Step
next <- v -> m Step
step v
v
let q2 :: Queue Level v
q2 = case Step
next of
Step
Stop -> Queue Level v
q1
Step
Next ->
let successors :: [(Level, v)]
successors = [v] -> [(Level, v)]
zipLevels ([v] -> [(Level, v)]) -> [v] -> [(Level, v)]
forall a b. (a -> b) -> a -> b
$ ((e, v) -> v) -> [(e, v)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (e, v) -> v
forall a b. (a, b) -> b
snd ([(e, v)] -> [v]) -> [(e, v)] -> [v]
forall a b. (a -> b) -> a -> b
$ Graph v e -> v -> [(e, v)]
forall v e. (Eq v, Hashable v) => Graph v e -> v -> [(e, v)]
getOutgoing Graph v e
g v
v
in Queue Level v -> [(Level, v)] -> Queue Level v
forall k v. Ord k => Queue k v -> [(k, v)] -> Queue k v
insertList Queue Level v
q1 [(Level, v)]
successors
Queue Level v -> Set v -> [v] -> m [v]
go Queue Level v
q2 (v -> Set v -> Set v
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.insert v
v Set v
seen) (v
vv -> [v] -> [v]
forall a. a -> [a] -> [a]
:[v]
visits)
insertList :: Ord k => Queue k v -> [(k,v)] -> Queue k v
insertList :: forall k v. Ord k => Queue k v -> [(k, v)] -> Queue k v
insertList = (Queue k v -> (k, v) -> Queue k v)
-> Queue k v -> [(k, v)] -> Queue k v
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (\Queue k v
q (k
k,v
v) -> k -> v -> Queue k v -> Queue k v
forall k a. Ord k => k -> a -> MinPQueue k a -> MinPQueue k a
Q.insert k
k v
v Queue k v
q)
walkSuccessors_
:: (Monad m, Eq v, Hashable v)
=> [v] -> (v -> m Step) -> Graph v e -> m ()
walkSuccessors_ :: forall (m :: * -> *) v e.
(Monad m, Eq v, Hashable v) =>
[v] -> (v -> m Step) -> Graph v e -> m ()
walkSuccessors_ [v]
xs v -> m Step
step Graph v e
g = [v] -> (v -> m Step) -> Graph v e -> m [v]
forall v e (m :: * -> *).
(Monad m, Eq v, Hashable v) =>
[v] -> (v -> m Step) -> Graph v e -> m [v]
walkSuccessors [v]
xs v -> m Step
step Graph v e
g m [v] -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
showDot
:: (Eq v, Hashable v)
=> (v -> String) -> Graph v e -> String
showDot :: forall v e.
(Eq v, Hashable v) =>
(v -> String) -> Graph v e -> String
showDot v -> String
fv Graph v e
g = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
[ String
"digraph mygraph {"
, String
" node [shape=box];"
] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> (v -> String) -> [v] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map v -> String
showVertex (Graph v e -> [v]
forall v e. (Eq v, Hashable v) => Graph v e -> [v]
listConnectedVertices Graph v e
g)
[String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
"}"]
where
showVertex :: v -> String
showVertex v
x =
[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> v -> v -> String
showEdge v
x v
y String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"; " | (e
_,v
y) <- Graph v e -> v -> [(e, v)]
forall v e. (Eq v, Hashable v) => Graph v e -> v -> [(e, v)]
getOutgoing Graph v e
g v
x ]
showEdge :: v -> v -> String
showEdge v
x v
y = v -> String
escape v
x String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" -> " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> v -> String
escape v
y
escape :: v -> String
escape = ShowS
forall a. Show a => a -> String
show ShowS -> (v -> String) -> v -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> String
fv