{-----------------------------------------------------------------------------
reactive-banana
Implementation of graph-related functionality
------------------------------------------------------------------------------}
{-# language ScopedTypeVariables#-}
module Reactive.Banana.Prim.Graph where
import Control.Monad
import Data.Functor.Identity
import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet as Set
import Data.Hashable
import Data.Maybe
{-----------------------------------------------------------------------------
Graphs and topological sorting
------------------------------------------------------------------------------}
data Graph a = Graph
{ children :: Map.HashMap a [a]
, parents :: Map.HashMap a [a]
, nodes :: Set.HashSet a
}
-- | The graph with no edges and no nodes.
emptyGraph :: Graph a
emptyGraph = Graph Map.empty Map.empty Set.empty
-- | Insert an edge from the first node to the second node into the graph.
insertEdge :: (Eq a, Hashable a) => (a,a) -> Graph a -> Graph a
insertEdge (x,y) gr = gr
{ children = Map.insertWith (flip (++)) x [y] (children gr)
, parents = Map.insertWith (flip (++)) y [x] (parents gr)
, nodes = Set.insert x $ Set.insert y $ nodes gr
}
-- | Get all immediate children of a node in a graph.
getChildren :: (Eq a, Hashable a) => Graph a -> a -> [a]
getChildren gr x = maybe [] id . Map.lookup x . children $ gr
-- | Get all immediate parents of a node in a graph.
getParents :: (Eq a, Hashable a) => Graph a -> a -> [a]
getParents gr x = maybe [] id . Map.lookup x . parents $ gr
-- | List all nodes such that each parent is listed before all of its children.
listParents :: forall a. (Eq a, Hashable a) => Graph a -> [a]
listParents gr = list
where
-- all nodes without children
ancestors :: [a]
ancestors = [x | x <- Set.toList $ nodes gr, null (getParents gr x)]
-- all nodes in topological order "parents before children"
list :: [a]
list = runIdentity $ dfs' ancestors (Identity . getChildren gr)
{-----------------------------------------------------------------------------
Graph traversal
------------------------------------------------------------------------------}
-- | Graph represented as map of successors.
type GraphM m a = a -> m [a]
-- | Depth-first search. List all transitive successors of a node.
-- A node is listed *before* all its successors have been listed.
dfs :: (Eq a, Hashable a, Monad m) => a -> GraphM m a -> m [a]
dfs x = dfs' [x]
-- | Depth-first serach, refined version.
-- INVARIANT: None of the nodes in the initial list have a predecessor.
dfs' :: forall a m. (Eq a, Hashable a, Monad m) => [a] -> GraphM m a -> m [a]
dfs' xs succs = liftM fst $ go xs [] Set.empty
where
go :: [a] -> [a] -> Set.HashSet a -> m ([a], Set.HashSet a)
go [] ys seen = return (ys, seen) -- all nodes seen
go (x:xs) ys seen
| x `Set.member` seen = go xs ys seen
| otherwise = do
xs' <- succs x
-- visit all children
(ys', seen') <- go xs' ys (Set.insert x seen)
-- list this node as all successors have been seen
go xs (x:ys') seen'