module Graphs.RemoveAncestors(
removeAncestors,
removeAncestorsBy,
removeAncestorsByPure,
) where
import Control.Monad.Identity
import qualified Data.Map as Map
import Graphs.Graph
removeAncestors :: Graph graph =>
graph nodeLabel nodeTypeLabel arcLabel arcTypeLabel
-> [Node]
-> IO [Node]
removeAncestors graph nodes =
do
let
getChildren node =
do
arcsOut <- getArcsOut graph node
mapM
(\ arc -> getTarget graph arc)
arcsOut
removeAncestorsBy getChildren nodes
removeAncestorsBy :: (Ord node,Monad m)
=> (node -> m [node]) -> [node] -> m [node]
removeAncestorsBy (getChildren :: node -> m [node]) (nodes :: [node]) =
do
let
state0 = Map.fromList (map (\ node -> (node,Yes)) nodes)
uniqueNodes = map fst (Map.toList state0)
nodeIsAncestor :: node -> Map.Map node NodeState
-> m (Bool,Map.Map node NodeState)
nodeIsAncestor node state0 =
case Map.lookup node state0 of
Just Yes -> return (True,state0)
Just No -> return (False,state0)
Just Cycle -> return (False,state0)
Nothing ->
do
let
state1 = Map.insert node Cycle state0
children <- getChildren node
(isAncestor,state2) <- anyNodeIsAncestor children state1
let
state3 = Map.insert node
(if isAncestor then Yes else No) state2
return (isAncestor,state3)
anyNodeIsAncestor :: [node] -> Map.Map node NodeState
-> m (Bool,Map.Map node NodeState)
anyNodeIsAncestor [] state0 = return (False,state0)
anyNodeIsAncestor (node : nodes) state0 =
do
(thisIsAncestor,state1) <- nodeIsAncestor node state0
if thisIsAncestor
then
return (True,state1)
else
anyNodeIsAncestor nodes state1
nodeIsNonTrivialAncestor :: node -> Map.Map node NodeState
-> m (Bool,Map.Map node NodeState)
nodeIsNonTrivialAncestor node state0 =
do
children <- getChildren node
anyNodeIsAncestor children state0
(list :: [node],finalState :: Map.Map node NodeState) <- foldM
(\ (listSoFar,state0) node ->
do
(isAncestor,state1) <- nodeIsNonTrivialAncestor node state0
return (if isAncestor then (listSoFar,state1)
else (node:listSoFar,state1))
)
([],state0)
uniqueNodes
return list
removeAncestorsByPure :: Ord node => (node -> [node]) -> [node] -> [node]
removeAncestorsByPure (toParents0 :: node -> [node]) nodes =
let
toParents1 :: node -> Identity [node]
toParents1 = Identity . toParents0
in
runIdentity (removeAncestorsBy toParents1 nodes)
data NodeState =
Yes
| No
| Cycle