{-# LANGUAGE ScopedTypeVariables #-}
module Graphs.GetAncestors(
getAncestors,
getDescendants,
getAncestorsGeneric,
isAncestorPure,
isAncestor,
getAncestorsPure,
) where
import Control.Monad
import Data.Maybe
import qualified Data.Set as Set
import Data.Set (Set)
import Graphs.Graph
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
:: 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
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 #-}
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)