{-# LANGUAGE ScopedTypeVariables #-}

module Graphs.GetAncestors(
   getAncestors,
      -- :: Graph graph => Bool
      -- -> graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -- -> (nodeLabel -> IO Bool) -> Node -> IO [Node]
      --
      -- Given an acyclic graph, a function (f :: nodeLabel -> IO Bool),
      -- and a node v, we return the set of nodes W such that for w in W,
      -- (1) (f w) returns True
      -- (2) there is a path from w to v, such that
      --     (f x) returns False for all nodes of the path except for v and w
      -- If the Bool is False, the path may be of length 0, and if it is not
      --    then f v must be False.
      -- If the Bool is True, the path must be of length at least 1.

   getDescendants,
      -- :: Graph graph => Bool
      -- -> graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
      -- -> (nodeLabel -> IO Bool) -> node -> IO [node]
      --  Same specification as getAncestors, with arc directions reversed.

   getAncestorsGeneric,
      -- :: Ord node => Bool -> (node -> IO [node]) -> (node -> IO Bool)
      -- -> node
      -- -> IO [node]
      -- general function for doing the above.

   isAncestorPure, -- :: Ord node => (node -> [node]) -> node -> node -> Bool
      -- Returns True if first node is ancestor or equal to the second.
   isAncestor, -- :: (Monad m,Ord node) => (node -> m [node]) -> node -> node
      -- -> m Bool
   getAncestorsPure,
      -- :: Ord node => (node -> [node]) -> node -> [node]
      -- This is a pure cut-down function for extracting a node's ancestors.
   ) where

import Control.Monad
import Data.Maybe

import qualified Data.Set as Set
import Data.Set (Set)

import Graphs.Graph


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

getAncestors
   :: Graph graph
   => Bool -> graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
   -> (nodeLabel -> IO Bool) -> Node -> IO [Node]
getAncestors :: Bool
-> graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> (nodeLabel -> IO Bool)
-> Node
-> IO [Node]
getAncestors Bool
nonTrivial graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graph nodeLabel -> IO Bool
f1 Node
node0 =
   let
      getParents :: Node -> IO [Node]
      getParents :: Node -> IO [Node]
getParents 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]
getArcsIn 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 (graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Arc -> IO Node
forall (graph :: * -> * -> * -> * -> *) nodeLabel nodeTypeLabel
       arcLabel arcTypeLabel.
Graph graph =>
graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Arc -> IO Node
getSource graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graph) [Arc]
arcs

      f :: Node -> IO Bool
      f :: Node -> IO Bool
f Node
node =
         do
            nodeLabel
label <- graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Node -> IO nodeLabel
forall (graph :: * -> * -> * -> * -> *) nodeLabel nodeTypeLabel
       arcLabel arcTypeLabel.
Graph graph =>
graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Node -> IO nodeLabel
getNodeLabel graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graph Node
node
            nodeLabel -> IO Bool
f1 nodeLabel
label
   in
      Bool
-> (Node -> IO [Node]) -> (Node -> IO Bool) -> Node -> IO [Node]
forall node.
Ord node =>
Bool
-> (node -> IO [node]) -> (node -> IO Bool) -> node -> IO [node]
getAncestorsGeneric Bool
nonTrivial Node -> IO [Node]
getParents Node -> IO Bool
f Node
node0



getDescendants
   :: Graph graph
   => Bool -> graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
   -> (nodeLabel -> IO Bool) -> Node -> IO [Node]
getDescendants :: Bool
-> graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> (nodeLabel -> IO Bool)
-> Node
-> IO [Node]
getDescendants Bool
nonTrivial graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graph nodeLabel -> IO Bool
f1 Node
node0 =
   let
      getParents :: Node -> IO [Node]
      getParents :: Node -> IO [Node]
getParents 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 (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]
arcs

      f :: Node -> IO Bool
      f :: Node -> IO Bool
f Node
node =
         do
            nodeLabel
label <- graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Node -> IO nodeLabel
forall (graph :: * -> * -> * -> * -> *) nodeLabel nodeTypeLabel
       arcLabel arcTypeLabel.
Graph graph =>
graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> Node -> IO nodeLabel
getNodeLabel graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graph Node
node
            nodeLabel -> IO Bool
f1 nodeLabel
label
   in
      Bool
-> (Node -> IO [Node]) -> (Node -> IO Bool) -> Node -> IO [Node]
forall node.
Ord node =>
Bool
-> (node -> IO [node]) -> (node -> IO Bool) -> node -> IO [node]
getAncestorsGeneric Bool
nonTrivial Node -> IO [Node]
getParents Node -> IO Bool
f Node
node0

-- ------------------------------------------------------------------------
-- getAncestorsGeneric
-- ------------------------------------------------------------------------

getAncestorsGeneric
   :: Ord node
   => Bool -> (node -> IO [node]) -> (node -> IO Bool) -> node
   -> IO [node]
getAncestorsGeneric :: Bool
-> (node -> IO [node]) -> (node -> IO Bool) -> node -> IO [node]
getAncestorsGeneric Bool
nonTrivial node -> IO [node]
getParents node -> IO Bool
f node
node =
   do
      (Set node
visited,[node]
ancestors) <-
         (if Bool
nonTrivial then (node -> IO [node])
-> (node -> IO Bool)
-> (Set node, [node])
-> node
-> IO (Set node, [node])
forall node.
Ord node =>
(node -> IO [node])
-> (node -> IO Bool)
-> (Set node, [node])
-> node
-> IO (Set node, [node])
getAncestorsGenericInnerStrict
            else (node -> IO [node])
-> (node -> IO Bool)
-> (Set node, [node])
-> node
-> IO (Set node, [node])
forall node.
Ord node =>
(node -> IO [node])
-> (node -> IO Bool)
-> (Set node, [node])
-> node
-> IO (Set node, [node])
getAncestorsGenericInner)
         node -> IO [node]
getParents node -> IO Bool
f (Set node
forall a. Set a
Set.empty,[]) node
node
      [node] -> IO [node]
forall (m :: * -> *) a. Monad m => a -> m a
return [node]
ancestors

getAncestorsGenericInner
   :: Ord node => (node -> IO [node]) -> (node -> IO Bool)
   -> (Set node,[node]) -> node -> IO (Set node,[node])
getAncestorsGenericInner :: (node -> IO [node])
-> (node -> IO Bool)
-> (Set node, [node])
-> node
-> IO (Set node, [node])
getAncestorsGenericInner node -> IO [node]
getParents node -> IO Bool
f (state :: (Set node, [node])
state @ (Set node
visitedSet0,[node]
ancestors0)) node
node =
   if node -> Set node -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member node
node Set node
visitedSet0
      then
         (Set node, [node]) -> IO (Set node, [node])
forall (m :: * -> *) a. Monad m => a -> m a
return (Set node, [node])
state
      else
         do
            let
               visitedSet1 :: Set node
visitedSet1 = node -> Set node -> Set node
forall a. Ord a => a -> Set a -> Set a
Set.insert node
node Set node
visitedSet0
            Bool
isAncestor <- node -> IO Bool
f node
node
            if Bool
isAncestor
               then
                  (Set node, [node]) -> IO (Set node, [node])
forall (m :: * -> *) a. Monad m => a -> m a
return (Set node
visitedSet1,(node
node node -> [node] -> [node]
forall a. a -> [a] -> [a]
: [node]
ancestors0))
               else
                  (node -> IO [node])
-> (node -> IO Bool)
-> (Set node, [node])
-> node
-> IO (Set node, [node])
forall node.
Ord node =>
(node -> IO [node])
-> (node -> IO Bool)
-> (Set node, [node])
-> node
-> IO (Set node, [node])
getAncestorsGenericInnerStrict node -> IO [node]
getParents node -> IO Bool
f
                     (Set node
visitedSet1,[node]
ancestors0) node
node

getAncestorsGenericInnerStrict
   :: Ord node => (node -> IO [node]) -> (node -> IO Bool)
   -> (Set node,[node]) -> node -> IO (Set node,[node])
getAncestorsGenericInnerStrict :: (node -> IO [node])
-> (node -> IO Bool)
-> (Set node, [node])
-> node
-> IO (Set node, [node])
getAncestorsGenericInnerStrict node -> IO [node]
getParents node -> IO Bool
f (state :: (Set node, [node])
state @ (Set node
visitedSet0,[node]
ancestors0))
      node
node =
   do
      [node]
parents <- node -> IO [node]
getParents node
node
      ((Set node, [node]) -> node -> IO (Set node, [node]))
-> (Set node, [node]) -> [node] -> IO (Set node, [node])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
         ((node -> IO [node])
-> (node -> IO Bool)
-> (Set node, [node])
-> node
-> IO (Set node, [node])
forall node.
Ord node =>
(node -> IO [node])
-> (node -> IO Bool)
-> (Set node, [node])
-> node
-> IO (Set node, [node])
getAncestorsGenericInner node -> IO [node]
getParents node -> IO Bool
f)
         (Set node
visitedSet0,[node]
ancestors0)
         [node]
parents

-- | Returns True if first node is ancestor or equal to the second.
isAncestor :: (Monad m,Ord node) => (node -> m [node]) -> node -> node
   -> m Bool
isAncestor :: (node -> m [node]) -> node -> node -> m Bool
isAncestor (node -> m [node]
getParents :: node -> m [node]) (node
node1 :: node) (node
node2 :: node) =
   let
      isAncestorInner :: Set node -> node -> m (Maybe (Set node))
      isAncestorInner :: Set node -> node -> m (Maybe (Set node))
isAncestorInner Set node
visitedSet0 node
node =
         if node -> Set node -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member node
node Set node
visitedSet0
            then
               Maybe (Set node) -> m (Maybe (Set node))
forall (m :: * -> *) a. Monad m => a -> m a
return (
                  if node
node node -> node -> Bool
forall a. Eq a => a -> a -> Bool
== node
node1
                     then
                        Maybe (Set node)
forall a. Maybe a
Nothing
                     else
                        Set node -> Maybe (Set node)
forall a. a -> Maybe a
Just Set node
visitedSet0
                  )
            else
               let
                  visitedSet1 :: Set node
                  visitedSet1 :: Set node
visitedSet1 = node -> Set node -> Set node
forall a. Ord a => a -> Set a -> Set a
Set.insert node
node Set node
visitedSet0
               in
                  do
                     [node]
parents <- node -> m [node]
getParents node
node
                     Set node -> [node] -> m (Maybe (Set node))
scanParents Set node
visitedSet1 [node]
parents

      scanParents :: Set node -> [node] -> m (Maybe (Set node))
      scanParents :: Set node -> [node] -> m (Maybe (Set node))
scanParents Set node
visitedSet0 [] = Maybe (Set node) -> m (Maybe (Set node))
forall (m :: * -> *) a. Monad m => a -> m a
return (Set node -> Maybe (Set node)
forall a. a -> Maybe a
Just Set node
visitedSet0)
      scanParents Set node
visitedSet0 (node
node:[node]
nodes) =
         do
            Maybe (Set node)
search1Result <- Set node -> node -> m (Maybe (Set node))
isAncestorInner Set node
visitedSet0 node
node
            case Maybe (Set node)
search1Result of
               Maybe (Set node)
Nothing -> Maybe (Set node) -> m (Maybe (Set node))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Set node)
forall a. Maybe a
Nothing
               Just Set node
visitedSet1 -> Set node -> [node] -> m (Maybe (Set node))
scanParents Set node
visitedSet1 [node]
nodes
   in
      do
         Maybe (Set node)
searchResultOpt <- Set node -> node -> m (Maybe (Set node))
isAncestorInner (node -> Set node
forall a. a -> Set a
Set.singleton node
node1) node
node2
         Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not (Maybe (Set node) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Set node)
searchResultOpt))
{-# SPECIALIZE isAncestor
   :: (Integer -> IO [Integer]) -> Integer -> Integer -> IO Bool #-}
-- this will be used for VersionState.versionIsAncestor

-- | Returns True if first node is ancestor or equal to the second.
isAncestorPure :: Ord node => (node -> [node]) -> node -> node -> Bool
isAncestorPure :: (node -> [node]) -> node -> node -> Bool
isAncestorPure node -> [node]
getParents (node
node1 :: node) (node
node2 :: node) =
   let
      isAncestorPureInner :: Set node -> node -> Maybe (Set node)
      isAncestorPureInner :: Set node -> node -> Maybe (Set node)
isAncestorPureInner Set node
visitedSet0 node
node =
         if node -> Set node -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member node
node Set node
visitedSet0
            then
               if node
node node -> node -> Bool
forall a. Eq a => a -> a -> Bool
== node
node1
                  then
                     Maybe (Set node)
forall a. Maybe a
Nothing
                  else
                     Set node -> Maybe (Set node)
forall a. a -> Maybe a
Just Set node
visitedSet0
            else
               let
                  visitedSet1 :: Set node
                  visitedSet1 :: Set node
visitedSet1 = node -> Set node -> Set node
forall a. Ord a => a -> Set a -> Set a
Set.insert node
node Set node
visitedSet0
               in
                  Set node -> [node] -> Maybe (Set node)
scanParents Set node
visitedSet1 (node -> [node]
getParents node
node)

      scanParents :: Set node -> [node] -> Maybe (Set node)
scanParents Set node
visitedSet0 [] = Set node -> Maybe (Set node)
forall a. a -> Maybe a
Just Set node
visitedSet0
      scanParents Set node
visitedSet0 (node
node:[node]
nodes) =
         case Set node -> node -> Maybe (Set node)
isAncestorPureInner Set node
visitedSet0 node
node of
            Maybe (Set node)
Nothing -> Maybe (Set node)
forall a. Maybe a
Nothing
            Just Set node
visitedSet1 -> Set node -> [node] -> Maybe (Set node)
scanParents Set node
visitedSet1 [node]
nodes
   in
      Bool -> Bool
not (Maybe (Set node) -> Bool
forall a. Maybe a -> Bool
isJust (Set node -> node -> Maybe (Set node)
isAncestorPureInner (node -> Set node
forall a. a -> Set a
Set.singleton node
node1) node
node2))

getAncestorsPure :: Ord node => (node -> [node]) -> node -> [node]
getAncestorsPure :: (node -> [node]) -> node -> [node]
getAncestorsPure node -> [node]
getParents (node
node0 :: node) =
   let
      getAncestorsPureInner :: Set node -> node -> Set node
      getAncestorsPureInner :: Set node -> node -> Set node
getAncestorsPureInner Set node
visitedSet0 node
node =
         if node -> Set node -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member node
node Set node
visitedSet0
            then
               Set node
visitedSet0
            else
               let
                  visitedSet1 :: Set node
visitedSet1 = node -> Set node -> Set node
forall a. Ord a => a -> Set a -> Set a
Set.insert node
node Set node
visitedSet0
                  parents :: [node]
parents = node -> [node]
getParents node
node
               in
                  (Set node -> node -> Set node) -> Set node -> [node] -> Set node
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Set node -> node -> Set node
getAncestorsPureInner Set node
visitedSet1 [node]
parents
   in
      Set node -> [node]
forall a. Set a -> [a]
Set.toList (Set node -> node -> Set node
getAncestorsPureInner Set node
forall a. Set a
Set.empty node
node0)