{-# LANGUAGE LambdaCase #-}
module Algebra.Graph.AdjacencyMap.Algorithm (
bfsForest, bfs, dfsForest, dfsForestFrom, dfs, reachable,
topSort, isAcyclic, scc,
isDfsForestOf, isTopSortOf,
Cycle
) where
import Control.Monad
import Control.Monad.Trans.Cont
import Control.Monad.Trans.State.Strict
import Data.Foldable (for_)
import Data.Either
import Data.List.NonEmpty (NonEmpty(..), (<|))
import Data.Maybe
import Data.Tree
import Algebra.Graph.AdjacencyMap
import Algebra.Graph.Internal
import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NonEmpty
import qualified Data.Array as Array
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
bfsForest :: Ord a => [a] -> AdjacencyMap a -> Forest a
bfsForest :: [a] -> AdjacencyMap a -> Forest a
bfsForest [a]
vs AdjacencyMap a
g = State (Set a) (Forest a) -> Set a -> Forest a
forall s a. State s a -> s -> a
evalState ([a] -> State (Set a) (Forest a)
explore [ a
v | a
v <- [a]
vs, a -> AdjacencyMap a -> Bool
forall a. Ord a => a -> AdjacencyMap a -> Bool
hasVertex a
v AdjacencyMap a
g ]) Set a
forall a. Set a
Set.empty where
explore :: [a] -> State (Set a) (Forest a)
explore = (a -> StateT (Set a) Identity (a, [a]))
-> [a] -> State (Set a) (Forest a)
forall (m :: * -> *) b a.
Monad m =>
(b -> m (a, [b])) -> [b] -> m (Forest a)
unfoldForestM_BF a -> StateT (Set a) Identity (a, [a])
walk ([a] -> State (Set a) (Forest a))
-> ([a] -> StateT (Set a) Identity [a])
-> [a]
-> State (Set a) (Forest a)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (a -> StateT (Set a) Identity Bool)
-> [a] -> StateT (Set a) Identity [a]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM a -> StateT (Set a) Identity Bool
forall (m :: * -> *) a.
(Monad m, Ord a) =>
a -> StateT (Set a) m Bool
discovered
walk :: a -> StateT (Set a) Identity (a, [a])
walk a
v = (a
v,) ([a] -> (a, [a]))
-> StateT (Set a) Identity [a] -> StateT (Set a) Identity (a, [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Set a) Identity [a]
adjacentM a
v
adjacentM :: a -> StateT (Set a) Identity [a]
adjacentM a
v = (a -> StateT (Set a) Identity Bool)
-> [a] -> StateT (Set a) Identity [a]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM a -> StateT (Set a) Identity Bool
forall (m :: * -> *) a.
(Monad m, Ord a) =>
a -> StateT (Set a) m Bool
discovered ([a] -> StateT (Set a) Identity [a])
-> [a] -> StateT (Set a) Identity [a]
forall a b. (a -> b) -> a -> b
$ Set a -> [a]
forall a. Set a -> [a]
Set.toList (a -> AdjacencyMap a -> Set a
forall a. Ord a => a -> AdjacencyMap a -> Set a
postSet a
v AdjacencyMap a
g)
discovered :: a -> StateT (Set a) m Bool
discovered a
v = do Bool
new <- (Set a -> Bool) -> StateT (Set a) m Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (Bool -> Bool
not (Bool -> Bool) -> (Set a -> Bool) -> Set a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member a
v)
Bool -> StateT (Set a) m () -> StateT (Set a) m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
new (StateT (Set a) m () -> StateT (Set a) m ())
-> StateT (Set a) m () -> StateT (Set a) m ()
forall a b. (a -> b) -> a -> b
$ (Set a -> Set a) -> StateT (Set a) m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
v)
Bool -> StateT (Set a) m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
new
bfs :: Ord a => [a] -> AdjacencyMap a -> [[a]]
bfs :: [a] -> AdjacencyMap a -> [[a]]
bfs [a]
vs = ([[a]] -> [a]) -> [[[a]]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[a]]] -> [[a]])
-> (AdjacencyMap a -> [[[a]]]) -> AdjacencyMap a -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[[a]]] -> [[[a]]]
forall a. [[a]] -> [[a]]
List.transpose ([[[a]]] -> [[[a]]])
-> (AdjacencyMap a -> [[[a]]]) -> AdjacencyMap a -> [[[a]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree a -> [[a]]) -> [Tree a] -> [[[a]]]
forall a b. (a -> b) -> [a] -> [b]
map Tree a -> [[a]]
forall a. Tree a -> [[a]]
levels ([Tree a] -> [[[a]]])
-> (AdjacencyMap a -> [Tree a]) -> AdjacencyMap a -> [[[a]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> AdjacencyMap a -> [Tree a]
forall a. Ord a => [a] -> AdjacencyMap a -> Forest a
bfsForest [a]
vs
dfsForest :: Ord a => AdjacencyMap a -> Forest a
dfsForest :: AdjacencyMap a -> Forest a
dfsForest AdjacencyMap a
g = [a] -> AdjacencyMap a -> Forest a
forall a. Ord a => [a] -> AdjacencyMap a -> Forest a
dfsForestFrom' (AdjacencyMap a -> [a]
forall a. AdjacencyMap a -> [a]
vertexList AdjacencyMap a
g) AdjacencyMap a
g
dfsForestFrom :: Ord a => [a] -> AdjacencyMap a -> Forest a
dfsForestFrom :: [a] -> AdjacencyMap a -> Forest a
dfsForestFrom [a]
vs AdjacencyMap a
g = [a] -> AdjacencyMap a -> Forest a
forall a. Ord a => [a] -> AdjacencyMap a -> Forest a
dfsForestFrom' [ a
v | a
v <- [a]
vs, a -> AdjacencyMap a -> Bool
forall a. Ord a => a -> AdjacencyMap a -> Bool
hasVertex a
v AdjacencyMap a
g ] AdjacencyMap a
g
dfsForestFrom' :: Ord a => [a] -> AdjacencyMap a -> Forest a
dfsForestFrom' :: [a] -> AdjacencyMap a -> Forest a
dfsForestFrom' [a]
vs AdjacencyMap a
g = State (Set a) (Forest a) -> Set a -> Forest a
forall s a. State s a -> s -> a
evalState ([a] -> State (Set a) (Forest a)
explore [a]
vs) Set a
forall a. Set a
Set.empty where
explore :: [a] -> State (Set a) (Forest a)
explore (a
v:[a]
vs) = a -> StateT (Set a) Identity Bool
forall (m :: * -> *) a.
(Monad m, Ord a) =>
a -> StateT (Set a) m Bool
discovered a
v StateT (Set a) Identity Bool
-> (Bool -> State (Set a) (Forest a)) -> State (Set a) (Forest a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> (:) (Tree a -> Forest a -> Forest a)
-> StateT (Set a) Identity (Tree a)
-> StateT (Set a) Identity (Forest a -> Forest a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Set a) Identity (Tree a)
walk a
v StateT (Set a) Identity (Forest a -> Forest a)
-> State (Set a) (Forest a) -> State (Set a) (Forest a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [a] -> State (Set a) (Forest a)
explore [a]
vs
Bool
False -> [a] -> State (Set a) (Forest a)
explore [a]
vs
explore [] = Forest a -> State (Set a) (Forest a)
forall (m :: * -> *) a. Monad m => a -> m a
return []
walk :: a -> StateT (Set a) Identity (Tree a)
walk a
v = a -> Forest a -> Tree a
forall a. a -> Forest a -> Tree a
Node a
v (Forest a -> Tree a)
-> State (Set a) (Forest a) -> StateT (Set a) Identity (Tree a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> State (Set a) (Forest a)
explore (a -> [a]
adjacent a
v)
adjacent :: a -> [a]
adjacent a
v = Set a -> [a]
forall a. Set a -> [a]
Set.toList (a -> AdjacencyMap a -> Set a
forall a. Ord a => a -> AdjacencyMap a -> Set a
postSet a
v AdjacencyMap a
g)
discovered :: a -> StateT (Set a) m Bool
discovered a
v = do Bool
new <- (Set a -> Bool) -> StateT (Set a) m Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (Bool -> Bool
not (Bool -> Bool) -> (Set a -> Bool) -> Set a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member a
v)
Bool -> StateT (Set a) m () -> StateT (Set a) m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
new (StateT (Set a) m () -> StateT (Set a) m ())
-> StateT (Set a) m () -> StateT (Set a) m ()
forall a b. (a -> b) -> a -> b
$ (Set a -> Set a) -> StateT (Set a) m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
v)
Bool -> StateT (Set a) m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
new
dfs :: Ord a => [a] -> AdjacencyMap a -> [a]
dfs :: [a] -> AdjacencyMap a -> [a]
dfs [a]
vs = [a] -> AdjacencyMap a -> Forest a
forall a. Ord a => [a] -> AdjacencyMap a -> Forest a
dfsForestFrom [a]
vs (AdjacencyMap a -> Forest a)
-> (Tree a -> [a]) -> AdjacencyMap a -> [a]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tree a -> [a]
forall a. Tree a -> [a]
flatten
reachable :: Ord a => a -> AdjacencyMap a -> [a]
reachable :: a -> AdjacencyMap a -> [a]
reachable a
x = [a] -> AdjacencyMap a -> [a]
forall a. Ord a => [a] -> AdjacencyMap a -> [a]
dfs [a
x]
type Cycle = NonEmpty
type Result a = Either (Cycle a) [a]
data NodeState = Entered | Exited
data S a = S { S a -> Map a a
parent :: Map.Map a a
, S a -> Map a NodeState
entry :: Map.Map a NodeState
, S a -> [a]
order :: [a] }
topSort' :: Ord a => AdjacencyMap a -> StateT (S a) (Cont (Result a)) (Result a)
topSort' :: AdjacencyMap a -> StateT (S a) (Cont (Result a)) (Result a)
topSort' AdjacencyMap a
g = CallCC (Cont (Result a)) (Result a, S a) ((), S a)
-> CallCC (StateT (S a) (Cont (Result a))) (Result a) ()
forall (m :: * -> *) a s b.
CallCC m (a, s) (b, s) -> CallCC (StateT s m) a b
liftCallCC' CallCC (Cont (Result a)) (Result a, S a) ((), S a)
forall k a (r :: k) (m :: k -> *) b.
((a -> ContT r m b) -> ContT r m a) -> ContT r m a
callCC CallCC (StateT (S a) (Cont (Result a))) (Result a) ()
-> CallCC (StateT (S a) (Cont (Result a))) (Result a) ()
forall a b. (a -> b) -> a -> b
$ \Result a -> StateT (S a) (Cont (Result a)) ()
cyclic ->
do let vertices :: [a]
vertices = ((a, Set a) -> a) -> [(a, Set a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, Set a) -> a
forall a b. (a, b) -> a
fst ([(a, Set a)] -> [a]) -> [(a, Set a)] -> [a]
forall a b. (a -> b) -> a -> b
$ Map a (Set a) -> [(a, Set a)]
forall k a. Map k a -> [(k, a)]
Map.toDescList (Map a (Set a) -> [(a, Set a)]) -> Map a (Set a) -> [(a, Set a)]
forall a b. (a -> b) -> a -> b
$ AdjacencyMap a -> Map a (Set a)
forall a. AdjacencyMap a -> Map a (Set a)
adjacencyMap AdjacencyMap a
g
adjacent :: a -> [a]
adjacent = Set a -> [a]
forall a. Set a -> [a]
Set.toDescList (Set a -> [a]) -> (a -> Set a) -> a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> AdjacencyMap a -> Set a) -> AdjacencyMap a -> a -> Set a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> AdjacencyMap a -> Set a
forall a. Ord a => a -> AdjacencyMap a -> Set a
postSet AdjacencyMap a
g
dfsRoot :: a -> StateT (S a) (Cont (Result a)) ()
dfsRoot a
x = a -> StateT (S a) (Cont (Result a)) (Maybe NodeState)
forall (m :: * -> *) k.
(Monad m, Ord k) =>
k -> StateT (S k) m (Maybe NodeState)
nodeState a
x StateT (S a) (Cont (Result a)) (Maybe NodeState)
-> (Maybe NodeState -> StateT (S a) (Cont (Result a)) ())
-> StateT (S a) (Cont (Result a)) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe NodeState
Nothing -> a -> StateT (S a) (Cont (Result a)) ()
forall (m :: * -> *) k. (Monad m, Ord k) => k -> StateT (S k) m ()
enterRoot a
x StateT (S a) (Cont (Result a)) ()
-> StateT (S a) (Cont (Result a)) ()
-> StateT (S a) (Cont (Result a)) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> StateT (S a) (Cont (Result a)) ()
dfs a
x StateT (S a) (Cont (Result a)) ()
-> StateT (S a) (Cont (Result a)) ()
-> StateT (S a) (Cont (Result a)) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> StateT (S a) (Cont (Result a)) ()
forall (m :: * -> *) k. (Monad m, Ord k) => k -> StateT (S k) m ()
exit a
x
Maybe NodeState
_ -> () -> StateT (S a) (Cont (Result a)) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
dfs :: a -> StateT (S a) (Cont (Result a)) ()
dfs a
x = [a]
-> (a -> StateT (S a) (Cont (Result a)) ())
-> StateT (S a) (Cont (Result a)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (a -> [a]
adjacent a
x) ((a -> StateT (S a) (Cont (Result a)) ())
-> StateT (S a) (Cont (Result a)) ())
-> (a -> StateT (S a) (Cont (Result a)) ())
-> StateT (S a) (Cont (Result a)) ()
forall a b. (a -> b) -> a -> b
$ \a
y ->
a -> StateT (S a) (Cont (Result a)) (Maybe NodeState)
forall (m :: * -> *) k.
(Monad m, Ord k) =>
k -> StateT (S k) m (Maybe NodeState)
nodeState a
y StateT (S a) (Cont (Result a)) (Maybe NodeState)
-> (Maybe NodeState -> StateT (S a) (Cont (Result a)) ())
-> StateT (S a) (Cont (Result a)) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe NodeState
Nothing -> a -> a -> StateT (S a) (Cont (Result a)) ()
forall (m :: * -> *) k.
(Monad m, Ord k) =>
k -> k -> StateT (S k) m ()
enter a
x a
y StateT (S a) (Cont (Result a)) ()
-> StateT (S a) (Cont (Result a)) ()
-> StateT (S a) (Cont (Result a)) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> StateT (S a) (Cont (Result a)) ()
dfs a
y StateT (S a) (Cont (Result a)) ()
-> StateT (S a) (Cont (Result a)) ()
-> StateT (S a) (Cont (Result a)) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> StateT (S a) (Cont (Result a)) ()
forall (m :: * -> *) k. (Monad m, Ord k) => k -> StateT (S k) m ()
exit a
y
Just NodeState
Exited -> () -> StateT (S a) (Cont (Result a)) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just NodeState
Entered -> Result a -> StateT (S a) (Cont (Result a)) ()
cyclic (Result a -> StateT (S a) (Cont (Result a)) ())
-> (Map a a -> Result a)
-> Map a a
-> StateT (S a) (Cont (Result a)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty a -> Result a
forall a b. a -> Either a b
Left (NonEmpty a -> Result a)
-> (Map a a -> NonEmpty a) -> Map a a -> Result a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> Map a a -> NonEmpty a
forall a. Ord a => a -> a -> Map a a -> NonEmpty a
retrace a
x a
y (Map a a -> StateT (S a) (Cont (Result a)) ())
-> StateT (S a) (Cont (Result a)) (Map a a)
-> StateT (S a) (Cont (Result a)) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (S a -> Map a a) -> StateT (S a) (Cont (Result a)) (Map a a)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets S a -> Map a a
forall a. S a -> Map a a
parent
[a]
-> (a -> StateT (S a) (Cont (Result a)) ())
-> StateT (S a) (Cont (Result a)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [a]
vertices a -> StateT (S a) (Cont (Result a)) ()
dfsRoot
[a] -> Result a
forall a b. b -> Either a b
Right ([a] -> Result a)
-> StateT (S a) (Cont (Result a)) [a]
-> StateT (S a) (Cont (Result a)) (Result a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (S a -> [a]) -> StateT (S a) (Cont (Result a)) [a]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets S a -> [a]
forall a. S a -> [a]
order
where
nodeState :: k -> StateT (S k) m (Maybe NodeState)
nodeState k
v = (S k -> Maybe NodeState) -> StateT (S k) m (Maybe NodeState)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (k -> Map k NodeState -> Maybe NodeState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
v (Map k NodeState -> Maybe NodeState)
-> (S k -> Map k NodeState) -> S k -> Maybe NodeState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. S k -> Map k NodeState
forall a. S a -> Map a NodeState
entry)
enter :: k -> k -> StateT (S k) m ()
enter k
u k
v = (S k -> S k) -> StateT (S k) m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' (\(S Map k k
m Map k NodeState
n [k]
vs) -> Map k k -> Map k NodeState -> [k] -> S k
forall a. Map a a -> Map a NodeState -> [a] -> S a
S (k -> k -> Map k k -> Map k k
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
v k
u Map k k
m)
(k -> NodeState -> Map k NodeState -> Map k NodeState
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
v NodeState
Entered Map k NodeState
n)
[k]
vs)
enterRoot :: k -> StateT (S k) m ()
enterRoot k
v = (S k -> S k) -> StateT (S k) m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' (\(S Map k k
m Map k NodeState
n [k]
vs) -> Map k k -> Map k NodeState -> [k] -> S k
forall a. Map a a -> Map a NodeState -> [a] -> S a
S Map k k
m (k -> NodeState -> Map k NodeState -> Map k NodeState
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
v NodeState
Entered Map k NodeState
n) [k]
vs)
exit :: a -> StateT (S a) m ()
exit a
v = (S a -> S a) -> StateT (S a) m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' (\(S Map a a
m Map a NodeState
n [a]
vs) -> Map a a -> Map a NodeState -> [a] -> S a
forall a. Map a a -> Map a NodeState -> [a] -> S a
S Map a a
m ((Maybe NodeState -> Maybe NodeState)
-> a -> Map a NodeState -> Map a NodeState
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter ((NodeState -> NodeState) -> Maybe NodeState -> Maybe NodeState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NodeState -> NodeState
leave) a
v Map a NodeState
n) (a
va -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
vs))
where leave :: NodeState -> NodeState
leave = \case
NodeState
Entered -> NodeState
Exited
NodeState
Exited -> [Char] -> NodeState
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: dfs search order violated"
retrace :: a -> a -> Map a a -> NonEmpty a
retrace a
curr a
head Map a a
parent = NonEmpty a -> NonEmpty a
aux (a
curr a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| []) where
aux :: NonEmpty a -> NonEmpty a
aux xs :: NonEmpty a
xs@(a
curr :| [a]
_)
| a
head a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
curr = NonEmpty a
xs
| Bool
otherwise = NonEmpty a -> NonEmpty a
aux (Map a a
parent Map a a -> a -> a
forall k a. Ord k => Map k a -> k -> a
Map.! a
curr a -> NonEmpty a -> NonEmpty a
forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty a
xs)
topSort :: Ord a => AdjacencyMap a -> Either (Cycle a) [a]
topSort :: AdjacencyMap a -> Either (Cycle a) [a]
topSort AdjacencyMap a
g = Cont (Either (Cycle a) [a]) (Either (Cycle a) [a])
-> (Either (Cycle a) [a] -> Either (Cycle a) [a])
-> Either (Cycle a) [a]
forall r a. Cont r a -> (a -> r) -> r
runCont (StateT (S a) (Cont (Either (Cycle a) [a])) (Either (Cycle a) [a])
-> S a -> Cont (Either (Cycle a) [a]) (Either (Cycle a) [a])
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (AdjacencyMap a
-> StateT
(S a) (Cont (Either (Cycle a) [a])) (Either (Cycle a) [a])
forall a.
Ord a =>
AdjacencyMap a -> StateT (S a) (Cont (Result a)) (Result a)
topSort' AdjacencyMap a
g) S a
forall a. S a
initialState) Either (Cycle a) [a] -> Either (Cycle a) [a]
forall a. a -> a
id
where
initialState :: S a
initialState = Map a a -> Map a NodeState -> [a] -> S a
forall a. Map a a -> Map a NodeState -> [a] -> S a
S Map a a
forall k a. Map k a
Map.empty Map a NodeState
forall k a. Map k a
Map.empty []
isAcyclic :: Ord a => AdjacencyMap a -> Bool
isAcyclic :: AdjacencyMap a -> Bool
isAcyclic = Either (Cycle a) [a] -> Bool
forall a b. Either a b -> Bool
isRight (Either (Cycle a) [a] -> Bool)
-> (AdjacencyMap a -> Either (Cycle a) [a])
-> AdjacencyMap a
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyMap a -> Either (Cycle a) [a]
forall a. Ord a => AdjacencyMap a -> Either (Cycle a) [a]
topSort
scc :: Ord a => AdjacencyMap a -> AdjacencyMap (NonEmpty.AdjacencyMap a)
scc :: AdjacencyMap a -> AdjacencyMap (AdjacencyMap a)
scc AdjacencyMap a
g = AdjacencyMap a -> StateSCC a -> AdjacencyMap (AdjacencyMap a)
forall a.
Ord a =>
AdjacencyMap a -> StateSCC a -> AdjacencyMap (AdjacencyMap a)
condense AdjacencyMap a
g (StateSCC a -> AdjacencyMap (AdjacencyMap a))
-> StateSCC a -> AdjacencyMap (AdjacencyMap a)
forall a b. (a -> b) -> a -> b
$ State (StateSCC a) () -> StateSCC a -> StateSCC a
forall s a. State s a -> s -> s
execState (AdjacencyMap a -> State (StateSCC a) ()
forall a. Ord a => AdjacencyMap a -> State (StateSCC a) ()
gabowSCC AdjacencyMap a
g) StateSCC a
forall a. StateSCC a
initialState where
initialState :: StateSCC a
initialState = Int
-> Int
-> [(Int, a)]
-> [a]
-> Map a Int
-> Map a Int
-> [AdjacencyMap a]
-> [(Int, (a, a))]
-> [(a, a)]
-> StateSCC a
forall a.
Int
-> Int
-> [(Int, a)]
-> [a]
-> Map a Int
-> Map a Int
-> [AdjacencyMap a]
-> [(Int, (a, a))]
-> [(a, a)]
-> StateSCC a
SCC Int
0 Int
0 [] [] Map a Int
forall k a. Map k a
Map.empty Map a Int
forall k a. Map k a
Map.empty [] [] []
data StateSCC a
= SCC { StateSCC a -> Int
_preorder :: {-# unpack #-} !Int
, StateSCC a -> Int
_component :: {-# unpack #-} !Int
, StateSCC a -> [(Int, a)]
boundaryStack :: [(Int,a)]
, StateSCC a -> [a]
_pathStack :: [a]
, StateSCC a -> Map a Int
preorders :: Map.Map a Int
, StateSCC a -> Map a Int
components :: Map.Map a Int
, StateSCC a -> [AdjacencyMap a]
_innerGraphs :: [AdjacencyMap a]
, StateSCC a -> [(Int, (a, a))]
_innerEdges :: [(Int,(a,a))]
, StateSCC a -> [(a, a)]
_outerEdges :: [(a,a)]
} deriving (Int -> StateSCC a -> ShowS
[StateSCC a] -> ShowS
StateSCC a -> [Char]
(Int -> StateSCC a -> ShowS)
-> (StateSCC a -> [Char])
-> ([StateSCC a] -> ShowS)
-> Show (StateSCC a)
forall a. (Show a, Ord a) => Int -> StateSCC a -> ShowS
forall a. (Show a, Ord a) => [StateSCC a] -> ShowS
forall a. (Show a, Ord a) => StateSCC a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [StateSCC a] -> ShowS
$cshowList :: forall a. (Show a, Ord a) => [StateSCC a] -> ShowS
show :: StateSCC a -> [Char]
$cshow :: forall a. (Show a, Ord a) => StateSCC a -> [Char]
showsPrec :: Int -> StateSCC a -> ShowS
$cshowsPrec :: forall a. (Show a, Ord a) => Int -> StateSCC a -> ShowS
Show)
gabowSCC :: Ord a => AdjacencyMap a -> State (StateSCC a) ()
gabowSCC :: AdjacencyMap a -> State (StateSCC a) ()
gabowSCC AdjacencyMap a
g =
do let dfs :: a -> StateT (StateSCC a) Identity Bool
dfs a
u = do Int
p_u <- a -> StateT (StateSCC a) Identity Int
forall (m :: * -> *) a.
(Monad m, Ord a) =>
a -> StateT (StateSCC a) m Int
enter a
u
Set a -> (a -> State (StateSCC a) ()) -> State (StateSCC a) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (a -> AdjacencyMap a -> Set a
forall a. Ord a => a -> AdjacencyMap a -> Set a
postSet a
u AdjacencyMap a
g) ((a -> State (StateSCC a) ()) -> State (StateSCC a) ())
-> (a -> State (StateSCC a) ()) -> State (StateSCC a) ()
forall a b. (a -> b) -> a -> b
$ \a
v -> do
a -> StateT (StateSCC a) Identity (Maybe Int)
forall (m :: * -> *) k.
(Monad m, Ord k) =>
k -> StateT (StateSCC k) m (Maybe Int)
preorderId a
v StateT (StateSCC a) Identity (Maybe Int)
-> (Maybe Int -> State (StateSCC a) ()) -> State (StateSCC a) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Int
Nothing -> do
Bool
updated <- a -> StateT (StateSCC a) Identity Bool
dfs a
v
if Bool
updated then (a, a) -> State (StateSCC a) ()
forall (m :: * -> *) a.
Monad m =>
(a, a) -> StateT (StateSCC a) m ()
outedge (a
u,a
v) else (Int, (a, a)) -> State (StateSCC a) ()
forall (m :: * -> *) a.
Monad m =>
(Int, (a, a)) -> StateT (StateSCC a) m ()
inedge (Int
p_u,(a
u,a
v))
Just Int
p_v -> do
Bool
scc_v <- a -> StateT (StateSCC a) Identity Bool
forall (m :: * -> *) k.
(Monad m, Ord k) =>
k -> StateT (StateSCC k) m Bool
hasComponent a
v
if Bool
scc_v
then (a, a) -> State (StateSCC a) ()
forall (m :: * -> *) a.
Monad m =>
(a, a) -> StateT (StateSCC a) m ()
outedge (a
u,a
v)
else Int -> State (StateSCC a) ()
forall (m :: * -> *) a. Monad m => Int -> StateT (StateSCC a) m ()
popBoundary Int
p_v State (StateSCC a) ()
-> State (StateSCC a) () -> State (StateSCC a) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Int, (a, a)) -> State (StateSCC a) ()
forall (m :: * -> *) a.
Monad m =>
(Int, (a, a)) -> StateT (StateSCC a) m ()
inedge (Int
p_u,(a
u,a
v))
a -> StateT (StateSCC a) Identity Bool
forall (m :: * -> *) k.
(Monad m, Ord k) =>
k -> StateT (StateSCC k) m Bool
exit a
u
[a] -> (a -> State (StateSCC a) ()) -> State (StateSCC a) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (AdjacencyMap a -> [a]
forall a. AdjacencyMap a -> [a]
vertexList AdjacencyMap a
g) ((a -> State (StateSCC a) ()) -> State (StateSCC a) ())
-> (a -> State (StateSCC a) ()) -> State (StateSCC a) ()
forall a b. (a -> b) -> a -> b
$ \a
v -> do
Bool
assigned <- a -> StateT (StateSCC a) Identity Bool
forall (m :: * -> *) k.
(Monad m, Ord k) =>
k -> StateT (StateSCC k) m Bool
hasPreorderId a
v
Bool -> State (StateSCC a) () -> State (StateSCC a) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
assigned (State (StateSCC a) () -> State (StateSCC a) ())
-> State (StateSCC a) () -> State (StateSCC a) ()
forall a b. (a -> b) -> a -> b
$ StateT (StateSCC a) Identity Bool -> State (StateSCC a) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT (StateSCC a) Identity Bool -> State (StateSCC a) ())
-> StateT (StateSCC a) Identity Bool -> State (StateSCC a) ()
forall a b. (a -> b) -> a -> b
$ a -> StateT (StateSCC a) Identity Bool
dfs a
v
where
enter :: a -> StateT (StateSCC a) m Int
enter a
v = do SCC Int
pre Int
scc [(Int, a)]
bnd [a]
pth Map a Int
pres Map a Int
sccs [AdjacencyMap a]
gs [(Int, (a, a))]
es_i [(a, a)]
es_o <- StateT (StateSCC a) m (StateSCC a)
forall (m :: * -> *) s. Monad m => StateT s m s
get
let pre' :: Int
pre' = Int
preInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1
bnd' :: [(Int, a)]
bnd' = (Int
pre,a
v)(Int, a) -> [(Int, a)] -> [(Int, a)]
forall a. a -> [a] -> [a]
:[(Int, a)]
bnd
pth' :: [a]
pth' = a
va -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
pth
pres' :: Map a Int
pres' = a -> Int -> Map a Int -> Map a Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
v Int
pre Map a Int
pres
StateSCC a -> StateT (StateSCC a) m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (StateSCC a -> StateT (StateSCC a) m ())
-> StateSCC a -> StateT (StateSCC a) m ()
forall a b. (a -> b) -> a -> b
$! Int
-> Int
-> [(Int, a)]
-> [a]
-> Map a Int
-> Map a Int
-> [AdjacencyMap a]
-> [(Int, (a, a))]
-> [(a, a)]
-> StateSCC a
forall a.
Int
-> Int
-> [(Int, a)]
-> [a]
-> Map a Int
-> Map a Int
-> [AdjacencyMap a]
-> [(Int, (a, a))]
-> [(a, a)]
-> StateSCC a
SCC Int
pre' Int
scc [(Int, a)]
bnd' [a]
pth' Map a Int
pres' Map a Int
sccs [AdjacencyMap a]
gs [(Int, (a, a))]
es_i [(a, a)]
es_o
Int -> StateT (StateSCC a) m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
pre
popBoundary :: Int -> StateT (StateSCC a) m ()
popBoundary Int
p_v = (StateSCC a -> StateSCC a) -> StateT (StateSCC a) m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify'
(\(SCC Int
pre Int
scc [(Int, a)]
bnd [a]
pth Map a Int
pres Map a Int
sccs [AdjacencyMap a]
gs [(Int, (a, a))]
es_i [(a, a)]
es_o) ->
Int
-> Int
-> [(Int, a)]
-> [a]
-> Map a Int
-> Map a Int
-> [AdjacencyMap a]
-> [(Int, (a, a))]
-> [(a, a)]
-> StateSCC a
forall a.
Int
-> Int
-> [(Int, a)]
-> [a]
-> Map a Int
-> Map a Int
-> [AdjacencyMap a]
-> [(Int, (a, a))]
-> [(a, a)]
-> StateSCC a
SCC Int
pre Int
scc (((Int, a) -> Bool) -> [(Int, a)] -> [(Int, a)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
p_v)(Int -> Bool) -> ((Int, a) -> Int) -> (Int, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int, a) -> Int
forall a b. (a, b) -> a
fst) [(Int, a)]
bnd) [a]
pth Map a Int
pres Map a Int
sccs [AdjacencyMap a]
gs [(Int, (a, a))]
es_i [(a, a)]
es_o)
exit :: a -> StateT (StateSCC a) m Bool
exit a
v = do Bool
newComponent <- (a
va -> a -> Bool
forall a. Eq a => a -> a -> Bool
==)(a -> Bool) -> ([(Int, a)] -> a) -> [(Int, a)] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int, a) -> a
forall a b. (a, b) -> b
snd((Int, a) -> a) -> ([(Int, a)] -> (Int, a)) -> [(Int, a)] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[(Int, a)] -> (Int, a)
forall a. [a] -> a
head ([(Int, a)] -> Bool)
-> StateT (StateSCC a) m [(Int, a)] -> StateT (StateSCC a) m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StateSCC a -> [(Int, a)]) -> StateT (StateSCC a) m [(Int, a)]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets StateSCC a -> [(Int, a)]
forall a. StateSCC a -> [(Int, a)]
boundaryStack
Bool -> StateT (StateSCC a) m () -> StateT (StateSCC a) m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
newComponent (StateT (StateSCC a) m () -> StateT (StateSCC a) m ())
-> StateT (StateSCC a) m () -> StateT (StateSCC a) m ()
forall a b. (a -> b) -> a -> b
$ a -> StateT (StateSCC a) m ()
forall (m :: * -> *) a.
(Monad m, Ord a) =>
a -> StateT (StateSCC a) m ()
insertComponent a
v
Bool -> StateT (StateSCC a) m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
newComponent
insertComponent :: a -> StateT (StateSCC a) m ()
insertComponent a
v = (StateSCC a -> StateSCC a) -> StateT (StateSCC a) m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify'
(\(SCC Int
pre Int
scc [(Int, a)]
bnd [a]
pth Map a Int
pres Map a Int
sccs [AdjacencyMap a]
gs [(Int, (a, a))]
es_i [(a, a)]
es_o) ->
let ([a]
curr,[a]
v_pth') = (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/=a
v) [a]
pth
pth' :: [a]
pth' = [a] -> [a]
forall a. [a] -> [a]
tail [a]
v_pth'
([(Int, (a, a))]
es,[(Int, (a, a))]
es_i') = ((Int, (a, a)) -> Bool)
-> [(Int, (a, a))] -> ([(Int, (a, a))], [(Int, (a, a))])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=Int
p_v)(Int -> Bool) -> ((Int, (a, a)) -> Int) -> (Int, (a, a)) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int, (a, a)) -> Int
forall a b. (a, b) -> a
fst) [(Int, (a, a))]
es_i
g_i :: AdjacencyMap a
g_i | [(Int, (a, a))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, (a, a))]
es = a -> AdjacencyMap a
forall a. a -> AdjacencyMap a
vertex a
v
| Bool
otherwise = [(a, a)] -> AdjacencyMap a
forall a. Ord a => [(a, a)] -> AdjacencyMap a
edges ((Int, (a, a)) -> (a, a)
forall a b. (a, b) -> b
snd ((Int, (a, a)) -> (a, a)) -> [(Int, (a, a))] -> [(a, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, (a, a))]
es)
p_v :: Int
p_v = (Int, a) -> Int
forall a b. (a, b) -> a
fst ((Int, a) -> Int) -> (Int, a) -> Int
forall a b. (a -> b) -> a -> b
$ [(Int, a)] -> (Int, a)
forall a. [a] -> a
head [(Int, a)]
bnd
scc' :: Int
scc' = Int
scc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
bnd' :: [(Int, a)]
bnd' = [(Int, a)] -> [(Int, a)]
forall a. [a] -> [a]
tail [(Int, a)]
bnd
sccs' :: Map a Int
sccs' = (Map a Int -> a -> Map a Int) -> Map a Int -> [a] -> Map a Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\Map a Int
sccs a
x -> a -> Int -> Map a Int -> Map a Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
x Int
scc Map a Int
sccs) Map a Int
sccs (a
va -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
curr)
gs' :: [AdjacencyMap a]
gs' = AdjacencyMap a
g_iAdjacencyMap a -> [AdjacencyMap a] -> [AdjacencyMap a]
forall a. a -> [a] -> [a]
:[AdjacencyMap a]
gs
in Int
-> Int
-> [(Int, a)]
-> [a]
-> Map a Int
-> Map a Int
-> [AdjacencyMap a]
-> [(Int, (a, a))]
-> [(a, a)]
-> StateSCC a
forall a.
Int
-> Int
-> [(Int, a)]
-> [a]
-> Map a Int
-> Map a Int
-> [AdjacencyMap a]
-> [(Int, (a, a))]
-> [(a, a)]
-> StateSCC a
SCC Int
pre Int
scc' [(Int, a)]
bnd' [a]
pth' Map a Int
pres Map a Int
sccs' [AdjacencyMap a]
gs' [(Int, (a, a))]
es_i' [(a, a)]
es_o)
inedge :: (Int, (a, a)) -> StateT (StateSCC a) m ()
inedge (Int, (a, a))
uv = (StateSCC a -> StateSCC a) -> StateT (StateSCC a) m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify'
(\(SCC Int
pre Int
scc [(Int, a)]
bnd [a]
pth Map a Int
pres Map a Int
sccs [AdjacencyMap a]
gs [(Int, (a, a))]
es_i [(a, a)]
es_o) ->
Int
-> Int
-> [(Int, a)]
-> [a]
-> Map a Int
-> Map a Int
-> [AdjacencyMap a]
-> [(Int, (a, a))]
-> [(a, a)]
-> StateSCC a
forall a.
Int
-> Int
-> [(Int, a)]
-> [a]
-> Map a Int
-> Map a Int
-> [AdjacencyMap a]
-> [(Int, (a, a))]
-> [(a, a)]
-> StateSCC a
SCC Int
pre Int
scc [(Int, a)]
bnd [a]
pth Map a Int
pres Map a Int
sccs [AdjacencyMap a]
gs ((Int, (a, a))
uv(Int, (a, a)) -> [(Int, (a, a))] -> [(Int, (a, a))]
forall a. a -> [a] -> [a]
:[(Int, (a, a))]
es_i) [(a, a)]
es_o)
outedge :: (a, a) -> StateT (StateSCC a) m ()
outedge (a, a)
uv = (StateSCC a -> StateSCC a) -> StateT (StateSCC a) m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify'
(\(SCC Int
pre Int
scc [(Int, a)]
bnd [a]
pth Map a Int
pres Map a Int
sccs [AdjacencyMap a]
gs [(Int, (a, a))]
es_i [(a, a)]
es_o) ->
Int
-> Int
-> [(Int, a)]
-> [a]
-> Map a Int
-> Map a Int
-> [AdjacencyMap a]
-> [(Int, (a, a))]
-> [(a, a)]
-> StateSCC a
forall a.
Int
-> Int
-> [(Int, a)]
-> [a]
-> Map a Int
-> Map a Int
-> [AdjacencyMap a]
-> [(Int, (a, a))]
-> [(a, a)]
-> StateSCC a
SCC Int
pre Int
scc [(Int, a)]
bnd [a]
pth Map a Int
pres Map a Int
sccs [AdjacencyMap a]
gs [(Int, (a, a))]
es_i ((a, a)
uv(a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
:[(a, a)]
es_o))
hasPreorderId :: k -> StateT (StateSCC k) m Bool
hasPreorderId k
v = (StateSCC k -> Bool) -> StateT (StateSCC k) m Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (k -> Map k Int -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member k
v (Map k Int -> Bool)
-> (StateSCC k -> Map k Int) -> StateSCC k -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateSCC k -> Map k Int
forall a. StateSCC a -> Map a Int
preorders)
preorderId :: k -> StateT (StateSCC k) m (Maybe Int)
preorderId k
v = (StateSCC k -> Maybe Int) -> StateT (StateSCC k) m (Maybe Int)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (k -> Map k Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
v (Map k Int -> Maybe Int)
-> (StateSCC k -> Map k Int) -> StateSCC k -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateSCC k -> Map k Int
forall a. StateSCC a -> Map a Int
preorders)
hasComponent :: k -> StateT (StateSCC k) m Bool
hasComponent k
v = (StateSCC k -> Bool) -> StateT (StateSCC k) m Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (k -> Map k Int -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member k
v (Map k Int -> Bool)
-> (StateSCC k -> Map k Int) -> StateSCC k -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateSCC k -> Map k Int
forall a. StateSCC a -> Map a Int
components)
condense :: Ord a => AdjacencyMap a -> StateSCC a -> AdjacencyMap (NonEmpty.AdjacencyMap a)
condense :: AdjacencyMap a -> StateSCC a -> AdjacencyMap (AdjacencyMap a)
condense AdjacencyMap a
g (SCC Int
_ Int
n [(Int, a)]
_ [a]
_ Map a Int
_ Map a Int
assignment [AdjacencyMap a]
inner [(Int, (a, a))]
_ [(a, a)]
outer)
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = AdjacencyMap a -> AdjacencyMap (AdjacencyMap a)
forall a. a -> AdjacencyMap a
vertex (AdjacencyMap a -> AdjacencyMap (AdjacencyMap a))
-> AdjacencyMap a -> AdjacencyMap (AdjacencyMap a)
forall a b. (a -> b) -> a -> b
$ AdjacencyMap a -> AdjacencyMap a
forall a. AdjacencyMap a -> AdjacencyMap a
convert AdjacencyMap a
g
| Bool
otherwise = (Int -> AdjacencyMap a)
-> AdjacencyMap Int -> AdjacencyMap (AdjacencyMap a)
forall a b.
(Ord a, Ord b) =>
(a -> b) -> AdjacencyMap a -> AdjacencyMap b
gmap (\Int
c -> Array Int (AdjacencyMap a)
inner' Array Int (AdjacencyMap a) -> Int -> AdjacencyMap a
forall i e. Ix i => Array i e -> i -> e
Array.! (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
c)) AdjacencyMap Int
outer'
where inner' :: Array Int (AdjacencyMap a)
inner' = (Int, Int) -> [AdjacencyMap a] -> Array Int (AdjacencyMap a)
forall i e. Ix i => (i, i) -> [e] -> Array i e
Array.listArray (Int
0,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (AdjacencyMap a -> AdjacencyMap a
forall a. AdjacencyMap a -> AdjacencyMap a
convert (AdjacencyMap a -> AdjacencyMap a)
-> [AdjacencyMap a] -> [AdjacencyMap a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AdjacencyMap a]
inner)
outer' :: AdjacencyMap Int
outer' = AdjacencyMap Int
es AdjacencyMap Int -> AdjacencyMap Int -> AdjacencyMap Int
forall a.
Ord a =>
AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a
`overlay` AdjacencyMap Int
vs
vs :: AdjacencyMap Int
vs = [Int] -> AdjacencyMap Int
forall a. Ord a => [a] -> AdjacencyMap a
vertices [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
es :: AdjacencyMap Int
es = [(Int, Int)] -> AdjacencyMap Int
forall a. Ord a => [(a, a)] -> AdjacencyMap a
edges [ (a -> Int
sccid a
x, a -> Int
sccid a
y) | (a
x,a
y) <- [(a, a)]
outer ]
sccid :: a -> Int
sccid a
v = Map a Int
assignment Map a Int -> a -> Int
forall k a. Ord k => Map k a -> k -> a
Map.! a
v
convert :: AdjacencyMap a -> AdjacencyMap a
convert = Maybe (AdjacencyMap a) -> AdjacencyMap a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (AdjacencyMap a) -> AdjacencyMap a)
-> (AdjacencyMap a -> Maybe (AdjacencyMap a))
-> AdjacencyMap a
-> AdjacencyMap a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyMap a -> Maybe (AdjacencyMap a)
forall a. AdjacencyMap a -> Maybe (AdjacencyMap a)
NonEmpty.toNonEmpty
isDfsForestOf :: Ord a => Forest a -> AdjacencyMap a -> Bool
isDfsForestOf :: Forest a -> AdjacencyMap a -> Bool
isDfsForestOf Forest a
f AdjacencyMap a
am = case Set a -> Forest a -> Maybe (Set a)
go Set a
forall a. Set a
Set.empty Forest a
f of
Just Set a
seen -> Set a
seen Set a -> Set a -> Bool
forall a. Eq a => a -> a -> Bool
== AdjacencyMap a -> Set a
forall a. AdjacencyMap a -> Set a
vertexSet AdjacencyMap a
am
Maybe (Set a)
Nothing -> Bool
False
where
go :: Set a -> Forest a -> Maybe (Set a)
go Set a
seen [] = Set a -> Maybe (Set a)
forall a. a -> Maybe a
Just Set a
seen
go Set a
seen (Tree a
t:Forest a
ts) = do
let root :: a
root = Tree a -> a
forall a. Tree a -> a
rootLabel Tree a
t
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ a
root a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set a
seen
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ a -> a -> AdjacencyMap a -> Bool
forall a. Ord a => a -> a -> AdjacencyMap a -> Bool
hasEdge a
root (Tree a -> a
forall a. Tree a -> a
rootLabel Tree a
subTree) AdjacencyMap a
am | Tree a
subTree <- Tree a -> Forest a
forall a. Tree a -> Forest a
subForest Tree a
t ]
Set a
newSeen <- Set a -> Forest a -> Maybe (Set a)
go (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
root Set a
seen) (Tree a -> Forest a
forall a. Tree a -> Forest a
subForest Tree a
t)
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ a -> AdjacencyMap a -> Set a
forall a. Ord a => a -> AdjacencyMap a -> Set a
postSet a
root AdjacencyMap a
am Set a -> Set a -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set a
newSeen
Set a -> Forest a -> Maybe (Set a)
go Set a
newSeen Forest a
ts
isTopSortOf :: Ord a => [a] -> AdjacencyMap a -> Bool
isTopSortOf :: [a] -> AdjacencyMap a -> Bool
isTopSortOf [a]
xs AdjacencyMap a
m = Set a -> [a] -> Bool
go Set a
forall a. Set a
Set.empty [a]
xs
where
go :: Set a -> [a] -> Bool
go Set a
seen [] = Set a
seen Set a -> Set a -> Bool
forall a. Eq a => a -> a -> Bool
== Map a (Set a) -> Set a
forall k a. Map k a -> Set k
Map.keysSet (AdjacencyMap a -> Map a (Set a)
forall a. AdjacencyMap a -> Map a (Set a)
adjacencyMap AdjacencyMap a
m)
go Set a
seen (a
v:[a]
vs) = a -> AdjacencyMap a -> Set a
forall a. Ord a => a -> AdjacencyMap a -> Set a
postSet a
v AdjacencyMap a
m Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set a
newSeen Set a -> Set a -> Bool
forall a. Eq a => a -> a -> Bool
== Set a
forall a. Set a
Set.empty
Bool -> Bool -> Bool
&& Set a -> [a] -> Bool
go Set a
newSeen [a]
vs
where
newSeen :: Set a
newSeen = a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
v Set a
seen