{-# LANGUAGE ScopedTypeVariables #-}
module Graphs.GraphOps(
isAncestor,
isAncestorBy,
) where
import qualified Data.Set as Set
import Util.Queue
import Graphs.Graph
isAncestor :: Graph graph
=> graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Node -> Node -> IO Bool
isAncestor :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Node -> Node -> IO Bool
isAncestor graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graph Node
node1 Node
node2 =
let
getChildren :: Node -> IO [Node]
getChildren :: Node -> IO [Node]
getChildren Node
node =
do
[Arc]
arcs <- graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Node -> IO [Arc]
forall (graph :: * -> * -> * -> * -> *) nodeLabel nodeTypeLabel
arcLabel arcTypeLabel.
Graph graph =>
graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Node -> IO [Arc]
getArcsOut graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graph Node
node
(Arc -> IO Node) -> [Arc] -> IO [Node]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ Arc
arc -> graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Arc -> IO Node
forall (graph :: * -> * -> * -> * -> *) nodeLabel nodeTypeLabel
arcLabel arcTypeLabel.
Graph graph =>
graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Arc -> IO Node
getTarget graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graph Arc
arc) [Arc]
arcs
in
(Node -> IO [Node]) -> Node -> Node -> IO Bool
forall key. Ord key => (key -> IO [key]) -> key -> key -> IO Bool
isAncestorBy Node -> IO [Node]
getChildren Node
node1 Node
node2
isAncestorBy :: Ord key => (key -> IO [key]) -> key -> key -> IO Bool
isAncestorBy :: (key -> IO [key]) -> key -> key -> IO Bool
isAncestorBy key -> IO [key]
getChildren (key
node1 :: node) key
node2 =
do
let
search :: Set.Set node -> Queue node -> IO Bool
search :: Set key -> Queue key -> IO Bool
search Set key
visited Queue key
toDo0 = case Queue key -> Maybe (key, Queue key)
forall a. Queue a -> Maybe (a, Queue a)
removeQ Queue key
toDo0 of
Maybe (key, Queue key)
Nothing -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Just (key
node,Queue key
toDo1) ->
if key -> Set key -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member key
node Set key
visited
then
Set key -> Queue key -> IO Bool
search Set key
visited Queue key
toDo1
else
if key
node key -> key -> Bool
forall a. Eq a => a -> a -> Bool
== key
node2
then
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else
do
[key]
children <- key -> IO [key]
getChildren key
node
let
toDo2 :: Queue key
toDo2 = (Queue key -> key -> Queue key) -> Queue key -> [key] -> Queue key
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Queue key -> key -> Queue key
forall a. Queue a -> a -> Queue a
insertQ Queue key
toDo1 [key]
children
visited1 :: Set key
visited1 = key -> Set key -> Set key
forall a. Ord a => a -> Set a -> Set a
Set.insert key
node Set key
visited
Set key -> Queue key -> IO Bool
search Set key
visited1 Queue key
toDo2
Set key -> Queue key -> IO Bool
search Set key
forall a. Set a
Set.empty (key -> Queue key
forall a. a -> Queue a
singletonQ key
node1)