{-# LANGUAGE ScopedTypeVariables #-}

-- | This module contains various functions for operating on graphs
module Graphs.GraphOps(
   isAncestor, -- :: graph ... -> Node -> Node -> IO Bool
      -- returns True if the first Node is an ancestor, or identical, to
      -- the second one.

   isAncestorBy, -- :: Ord key => (key -> IO [key]) -> key -> key -> IO Bool
      -- generic version
   ) where

import qualified Data.Set as Set

import Util.Queue

import Graphs.Graph

-- ---------------------------------------------------------------------------
-- The functions
-- ---------------------------------------------------------------------------

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
         -- The first argument is the visited set; the second the nodes
         -- to be done.  We use a queue so that the search is breadth-first
         -- not depth-first.
         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)