{-# LANGUAGE ScopedTypeVariables #-}

-- | The removeAncestors function in this module (actually an IO action) takes
-- a graph G and a list of nodes N and computes N' = { n in N |
--    there does not exist an m in N and a non-trivial path n -> m }.
-- This is required for graph merging.
module Graphs.RemoveAncestors(
   removeAncestors,
   removeAncestorsBy,
   removeAncestorsByPure,
   ) where

import Control.Monad.Identity
import qualified Data.Map as Map

import Graphs.Graph


-- | Takes a graph G and a list of nodes N and computes N' = { n in N |
-- there does not exist an m in N and a non-trivial path n -> m }.
removeAncestors :: Graph graph =>
   graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
   -> [Node]
   -> IO [Node]
removeAncestors :: graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> [Node] -> IO [Node]
removeAncestors graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
graph [Node]
nodes =
   do
      let
         getChildren :: Node -> IO [Node]
getChildren Node
node =
            do
               [Arc]
arcsOut <- 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]
arcsOut

      (Node -> IO [Node]) -> [Node] -> IO [Node]
forall node (m :: * -> *).
(Ord node, Monad m) =>
(node -> m [node]) -> [node] -> m [node]
removeAncestorsBy Node -> IO [Node]
getChildren [Node]
nodes


-- | General removeAncestors function, which takes as argument the action
-- computing a Node\'s successors.
removeAncestorsBy :: (Ord node,Monad m)
   => (node -> m [node]) -> [node] -> m [node]
removeAncestorsBy :: (node -> m [node]) -> [node] -> m [node]
removeAncestorsBy (node -> m [node]
getChildren :: node -> m [node]) ([node]
nodes :: [node]) =
   do
      -- We maintain a state of type (Map.Map node NodeState) to express
      -- what is currently known about each node.  We also maintain
      -- a set containing the target nodes.

      -- compute initial map
      let
         state0 :: Map node NodeState
state0 = [(node, NodeState)] -> Map node NodeState
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((node -> (node, NodeState)) -> [node] -> [(node, NodeState)]
forall a b. (a -> b) -> [a] -> [b]
map (\ node
node -> (node
node,NodeState
Yes)) [node]
nodes)

         uniqueNodes :: [node]
uniqueNodes = ((node, NodeState) -> node) -> [(node, NodeState)] -> [node]
forall a b. (a -> b) -> [a] -> [b]
map (node, NodeState) -> node
forall a b. (a, b) -> a
fst (Map node NodeState -> [(node, NodeState)]
forall k a. Map k a -> [(k, a)]
Map.toList Map node NodeState
state0)

         -- Return True if there is a, possibly trivial, path from this node
         -- to one of the target set, also transforming the state.
         -- EXCEPTION - we don't search down nodes which have Cycle set,
         -- and in that case return False.
         nodeIsAncestor :: node -> Map.Map node NodeState
            -> m (Bool,Map.Map node NodeState)
         nodeIsAncestor :: node -> Map node NodeState -> m (Bool, Map node NodeState)
nodeIsAncestor node
node Map node NodeState
state0 =
            case node -> Map node NodeState -> Maybe NodeState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup node
node Map node NodeState
state0 of
               Just NodeState
Yes -> (Bool, Map node NodeState) -> m (Bool, Map node NodeState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True,Map node NodeState
state0)
               Just NodeState
No -> (Bool, Map node NodeState) -> m (Bool, Map node NodeState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False,Map node NodeState
state0)
               Just NodeState
Cycle -> (Bool, Map node NodeState) -> m (Bool, Map node NodeState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False,Map node NodeState
state0)
               Maybe NodeState
Nothing ->
                  do
                     let
                        state1 :: Map node NodeState
state1 = node -> NodeState -> Map node NodeState -> Map node NodeState
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert node
node NodeState
Cycle Map node NodeState
state0

                     [node]
children <- node -> m [node]
getChildren node
node
                     (Bool
isAncestor,Map node NodeState
state2) <- [node] -> Map node NodeState -> m (Bool, Map node NodeState)
anyNodeIsAncestor [node]
children Map node NodeState
state1
                     let
                        state3 :: Map node NodeState
state3 = node -> NodeState -> Map node NodeState -> Map node NodeState
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert node
node
                           (if Bool
isAncestor then NodeState
Yes else NodeState
No) Map node NodeState
state2
                     (Bool, Map node NodeState) -> m (Bool, Map node NodeState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
isAncestor,Map node NodeState
state3)

         -- Returns True if there is a, possibly trivial, path from any
         -- of the given nodes to one of the target nodes.
         anyNodeIsAncestor :: [node] -> Map.Map node NodeState
            -> m (Bool,Map.Map node NodeState)
         anyNodeIsAncestor :: [node] -> Map node NodeState -> m (Bool, Map node NodeState)
anyNodeIsAncestor [] Map node NodeState
state0 = (Bool, Map node NodeState) -> m (Bool, Map node NodeState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False,Map node NodeState
state0)
         anyNodeIsAncestor (node
node : [node]
nodes) Map node NodeState
state0 =
            do
               (Bool
thisIsAncestor,Map node NodeState
state1) <-  node -> Map node NodeState -> m (Bool, Map node NodeState)
nodeIsAncestor node
node Map node NodeState
state0
               if Bool
thisIsAncestor
                  then
                     (Bool, Map node NodeState) -> m (Bool, Map node NodeState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True,Map node NodeState
state1)
                  else
                     [node] -> Map node NodeState -> m (Bool, Map node NodeState)
anyNodeIsAncestor [node]
nodes Map node NodeState
state1

         -- Returns True if there is a non-trivial path from the given node
         -- to one of the target nodes.
         nodeIsNonTrivialAncestor :: node -> Map.Map node NodeState
            -> m (Bool,Map.Map node NodeState)
         nodeIsNonTrivialAncestor :: node -> Map node NodeState -> m (Bool, Map node NodeState)
nodeIsNonTrivialAncestor node
node Map node NodeState
state0 =
            do
               [node]
children <- node -> m [node]
getChildren node
node
               [node] -> Map node NodeState -> m (Bool, Map node NodeState)
anyNodeIsAncestor [node]
children Map node NodeState
state0

      ([node]
list :: [node],Map node NodeState
finalState :: Map.Map node NodeState) <- (([node], Map node NodeState)
 -> node -> m ([node], Map node NodeState))
-> ([node], Map node NodeState)
-> [node]
-> m ([node], Map node NodeState)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
         (\ ([node]
listSoFar,Map node NodeState
state0) node
node ->
            do
               (Bool
isAncestor,Map node NodeState
state1) <- node -> Map node NodeState -> m (Bool, Map node NodeState)
nodeIsNonTrivialAncestor node
node Map node NodeState
state0
               ([node], Map node NodeState) -> m ([node], Map node NodeState)
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
isAncestor then ([node]
listSoFar,Map node NodeState
state1)
                  else (node
nodenode -> [node] -> [node]
forall a. a -> [a] -> [a]
:[node]
listSoFar,Map node NodeState
state1))
            )
         ([],Map node NodeState
state0)
         [node]
uniqueNodes

      [node] -> m [node]
forall (m :: * -> *) a. Monad m => a -> m a
return [node]
list

-- | Pure version of 'removeAncestorsBy'.
removeAncestorsByPure :: Ord node => (node -> [node]) -> [node] -> [node]
removeAncestorsByPure :: (node -> [node]) -> [node] -> [node]
removeAncestorsByPure (node -> [node]
toParents0 :: node -> [node]) [node]
nodes =
   let
      toParents1 :: node -> Identity [node]
      toParents1 :: node -> Identity [node]
toParents1 = [node] -> Identity [node]
forall a. a -> Identity a
Identity ([node] -> Identity [node])
-> (node -> [node]) -> node -> Identity [node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. node -> [node]
toParents0
   in
      Identity [node] -> [node]
forall a. Identity a -> a
runIdentity ((node -> Identity [node]) -> [node] -> Identity [node]
forall node (m :: * -> *).
(Ord node, Monad m) =>
(node -> m [node]) -> [node] -> m [node]
removeAncestorsBy node -> Identity [node]
toParents1 [node]
nodes)

-- | This describes the information kept about a node during the course of
-- removeAncestorsBy
data NodeState =
      Yes -- ^ there is a, possibly trivial, path from here to an element
          -- of the target set.
   |  No  -- ^ the opposite of Yes.
   |  Cycle -- ^ we are already searching from this element.

{- SPECIALIZE removeAncestorsBy
   ::  (Node -> IO [Node]) -> [Node] -> IO [Node] -}