{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
-- |
-- Module     : Algebra.Graph.AdjacencyMap.Algorithm
-- Copyright  : (c) Andrey Mokhov 2016-2025
-- License    : MIT (see the file LICENSE)
-- Maintainer : andrey.mokhov@gmail.com
-- Stability  : unstable
--
-- __Alga__ is a library for algebraic construction and manipulation of graphs
-- in Haskell. See <https://github.com/snowleopard/alga-paper this paper> for the
-- motivation behind the library, the underlying theory, and implementation details.
--
-- This module provides basic graph algorithms, such as /depth-first search/,
-- implemented for the "Algebra.Graph.AdjacencyMap" data type.
-----------------------------------------------------------------------------
module Algebra.Graph.AdjacencyMap.Algorithm (
    -- * Algorithms
    bfsForest, bfs, dfsForest, dfsForestFrom, dfs, reachable,
    topSort, isAcyclic, scc,

    -- * Correctness properties
    isDfsForestOf, isTopSortOf,

    -- * Type synonyms
    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 (Forest, Tree (..), flatten, levels, unfoldForestM_BF)

import Algebra.Graph.AdjacencyMap

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

-- | Compute the /breadth-first search/ forest of a graph, such that adjacent
-- vertices are explored in increasing order according to their 'Ord' instance.
-- The search is seeded by a list of vertices that will become the roots of the
-- resulting forest. Duplicates in the list will have their first occurrence
-- explored and subsequent ones ignored. The seed vertices that do not belong to
-- the graph are also ignored.
--
-- Complexity: /O((L + m) * log n)/ time and /O(n)/ space, where /L/ is the
-- number of seed vertices.
--
-- @
-- 'forest' $ bfsForest ('edge' 1 2) [0]        == 'empty'
-- 'forest' $ bfsForest ('edge' 1 2) [1]        == 'edge' 1 2
-- 'forest' $ bfsForest ('edge' 1 2) [2]        == 'vertex' 2
-- 'forest' $ bfsForest ('edge' 1 2) [0,1,2]    == 'vertices' [1,2]
-- 'forest' $ bfsForest ('edge' 1 2) [2,1,0]    == 'vertices' [1,2]
-- 'forest' $ bfsForest ('edge' 1 1) [1]        == 'vertex' 1
-- 'isSubgraphOf' ('forest' $ bfsForest x vs) x == True
-- bfsForest x ('vertexList' x)               == 'map' (\\v -> Node v []) ('Data.List.nub' $ 'vertexList' x)
-- bfsForest x []                           == []
-- bfsForest 'empty' vs                       == []
-- bfsForest (3 * (1 + 4) * (1 + 5)) [1,4]  == [ Node { rootLabel = 1
--                                                    , subForest = [ Node { rootLabel = 5
--                                                                         , subForest = [] }]}
--                                             , Node { rootLabel = 4
--                                                    , subForest = [] }]
-- 'forest' $ bfsForest ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == 'path' [3,2,1] + 'path' [3,4,5]
--
-- @
bfsForest :: Ord a => AdjacencyMap a -> [a] -> Forest a
bfsForest :: forall a. Ord a => AdjacencyMap a -> [a] -> Forest a
bfsForest AdjacencyMap a
x [a]
vs = 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
x ]) Set a
forall a. Set a
Set.empty
  where
    explore :: [a] -> State (Set a) (Forest a)
explore = (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] -> State (Set a) (Forest a))
-> [a]
-> State (Set a) (Forest a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (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 [Tree a]
unfoldForestM_BF a -> StateT (Set a) Identity (a, [a])
walk
    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
x)
    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 a. a -> StateT (Set a) m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
new

-- | A version of 'bfsForest' where the resulting forest is converted to a level
-- structure. Adjacent vertices are explored in the increasing order according
-- to their 'Ord' instance. Flattening the result via @'concat'@ @.@ @'bfs'@ @x@
-- gives an enumeration of reachable vertices in the breadth-first search order.
--
-- Complexity: /O((L + m) * min(n,W))/ time and /O(n)/ space, where /L/ is the
-- number of seed vertices.
--
-- @
-- bfs ('edge' 1 2) [0]                == []
-- bfs ('edge' 1 2) [1]                == [[1], [2]]
-- bfs ('edge' 1 2) [2]                == [[2]]
-- bfs ('edge' 1 2) [1,2]              == [[1,2]]
-- bfs ('edge' 1 2) [2,1]              == [[2,1]]
-- bfs ('edge' 1 1) [1]                == [[1]]
-- bfs 'empty' vs                      == []
-- bfs x []                          == []
-- bfs (1 * 2 + 3 * 4 + 5 * 6) [1,2] == [[1,2]]
-- bfs (1 * 2 + 3 * 4 + 5 * 6) [1,3] == [[1,3], [2,4]]
-- bfs (3 * (1 + 4) * (1 + 5)) [3]   == [[3], [1,4,5]]
--
-- bfs ('circuit' [1..5] + 'circuit' [5,4..1]) [3]          == [[2], [1,3], [5,4]]
-- 'concat' $ bfs ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == [3,2,4,1,5]
-- 'map' 'concat' . 'List.transpose' . 'map' 'levels' . 'bfsForest' x    == bfs x
-- @
bfs :: Ord a => AdjacencyMap a -> [a] -> [[a]]
bfs :: forall a. Ord a => AdjacencyMap a -> [a] -> [[a]]
bfs AdjacencyMap a
x = ([[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]]) -> ([a] -> [[[a]]]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[[a]]] -> [[[a]]]
forall a. [[a]] -> [[a]]
List.transpose ([[[a]]] -> [[[a]]]) -> ([a] -> [[[a]]]) -> [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]]]) -> ([a] -> [Tree a]) -> [a] -> [[[a]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyMap a -> [a] -> [Tree a]
forall a. Ord a => AdjacencyMap a -> [a] -> Forest a
bfsForest AdjacencyMap a
x

dfsForestFromImpl :: Ord a => AdjacencyMap a -> [a] -> Forest a
dfsForestFromImpl :: forall a. Ord a => AdjacencyMap a -> [a] -> Forest a
dfsForestFromImpl AdjacencyMap a
g [a]
vs = 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 a b.
StateT (Set a) Identity a
-> (a -> StateT (Set a) Identity b) -> StateT (Set a) Identity b
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 a b.
StateT (Set a) Identity (a -> b)
-> StateT (Set a) Identity a -> StateT (Set a) Identity b
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 a. a -> StateT (Set a) Identity 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 -> [Tree 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 a. a -> StateT (Set a) m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
new

-- | Compute the /depth-first search/ forest of a graph, where adjacent vertices
-- are explored in the increasing order according to their 'Ord' instance.
--
-- Complexity: /O((n + m) * min(n,W))/ time and /O(n)/ space.
--
-- @
-- 'forest' $ dfsForest 'empty'              == 'empty'
-- 'forest' $ dfsForest ('edge' 1 1)         == 'vertex' 1
-- 'forest' $ dfsForest ('edge' 1 2)         == 'edge' 1 2
-- 'forest' $ dfsForest ('edge' 2 1)         == 'vertices' [1,2]
-- 'isSubgraphOf' ('forest' $ dfsForest x) x == True
-- 'isDfsForestOf' (dfsForest x) x         == True
-- dfsForest . 'forest' . dfsForest        == dfsForest
-- dfsForest ('vertices' vs)               == 'map' (\\v -> Node v []) ('Data.List.nub' $ 'Data.List.sort' vs)
-- dfsForest $ 3 * (1 + 4) * (1 + 5)     == [ Node { rootLabel = 1
--                                                 , subForest = [ Node { rootLabel = 5
--                                                                      , subForest = [] }]}
--                                          , Node { rootLabel = 3
--                                                 , subForest = [ Node { rootLabel = 4
--                                                                      , subForest = [] }]}]
-- 'forest' (dfsForest $ 'circuit' [1..5] + 'circuit' [5,4..1]) == 'path' [1,2,3,4,5]
-- @
dfsForest :: Ord a => AdjacencyMap a -> Forest a
dfsForest :: forall a. Ord a => AdjacencyMap a -> Forest a
dfsForest AdjacencyMap a
g = AdjacencyMap a -> [a] -> Forest a
forall a. Ord a => AdjacencyMap a -> [a] -> Forest a
dfsForestFromImpl AdjacencyMap a
g (AdjacencyMap a -> [a]
forall a. AdjacencyMap a -> [a]
vertexList AdjacencyMap a
g)

-- | Compute the /depth-first search/ forest of a graph starting from the given
-- seed vertices, where adjacent vertices are explored in the increasing order
-- according to their 'Ord' instance. Note that the resulting forest does not
-- necessarily span the whole graph, as some vertices may be unreachable. The
-- seed vertices which do not belong to the graph are ignored.
--
-- Complexity: /O((L + m) * log n)/ time and /O(n)/ space, where /L/ is the
-- number of seed vertices.
--
-- @
-- 'forest' $ dfsForestFrom 'empty'      vs             == 'empty'
-- 'forest' $ dfsForestFrom ('edge' 1 1) [1]            == 'vertex' 1
-- 'forest' $ dfsForestFrom ('edge' 1 2) [0]            == 'empty'
-- 'forest' $ dfsForestFrom ('edge' 1 2) [1]            == 'edge' 1 2
-- 'forest' $ dfsForestFrom ('edge' 1 2) [2]            == 'vertex' 2
-- 'forest' $ dfsForestFrom ('edge' 1 2) [1,2]          == 'edge' 1 2
-- 'forest' $ dfsForestFrom ('edge' 1 2) [2,1]          == 'vertices' [1,2]
-- 'isSubgraphOf' ('forest' $ dfsForestFrom x vs) x     == True
-- 'isDfsForestOf' (dfsForestFrom x ('vertexList' x)) x == True
-- dfsForestFrom x ('vertexList' x)                   == 'dfsForest' x
-- dfsForestFrom x []                               == []
-- dfsForestFrom (3 * (1 + 4) * (1 + 5)) [1,4]      == [ Node { rootLabel = 1
--                                                            , subForest = [ Node { rootLabel = 5
--                                                                                 , subForest = [] }
--                                                     , Node { rootLabel = 4
--                                                            , subForest = [] }]
-- 'forest' $ dfsForestFrom ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == 'path' [3,2,1,5,4]
-- @
dfsForestFrom :: Ord a => AdjacencyMap a -> [a] -> Forest a
dfsForestFrom :: forall a. Ord a => AdjacencyMap a -> [a] -> Forest a
dfsForestFrom AdjacencyMap a
g [a]
vs = AdjacencyMap a -> [a] -> Forest a
forall a. Ord a => AdjacencyMap a -> [a] -> Forest a
dfsForestFromImpl AdjacencyMap a
g [ a
v | a
v <- [a]
vs, a -> AdjacencyMap a -> Bool
forall a. Ord a => a -> AdjacencyMap a -> Bool
hasVertex a
v AdjacencyMap a
g ]

-- | Return the list vertices visited by the /depth-first search/ in a graph,
-- starting from the given seed vertices. Adjacent vertices are explored in the
-- increasing order according to their 'Ord' instance.
--
-- Complexity: /O((L + m) * log n)/ time and /O(n)/ space, where /L/ is the
-- number of seed vertices.
--
-- @
-- dfs 'empty'      vs    == []
-- dfs ('edge' 1 1) [1]   == [1]
-- dfs ('edge' 1 2) [0]   == []
-- dfs ('edge' 1 2) [1]   == [1,2]
-- dfs ('edge' 1 2) [2]   == [2]
-- dfs ('edge' 1 2) [1,2] == [1,2]
-- dfs ('edge' 1 2) [2,1] == [2,1]
-- dfs x          []    == []
--
-- 'Data.List.and' [ 'hasVertex' v x | v <- dfs x vs ]       == True
-- dfs (3 * (1 + 4) * (1 + 5)) [1,4]           == [1,5,4]
-- dfs ('circuit' [1..5] + 'circuit' [5,4..1]) [3] == [3,2,1,5,4]
-- @
dfs :: Ord a => AdjacencyMap a -> [a] -> [a]
dfs :: forall a. Ord a => AdjacencyMap a -> [a] -> [a]
dfs AdjacencyMap a
x = (Tree a -> [a]) -> [Tree a] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree a -> [a]
forall a. Tree a -> [a]
flatten ([Tree a] -> [a]) -> ([a] -> [Tree a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyMap a -> [a] -> [Tree a]
forall a. Ord a => AdjacencyMap a -> [a] -> Forest a
dfsForestFrom AdjacencyMap a
x

-- | Return the list of vertices /reachable/ from a source vertex in a graph.
-- The vertices in the resulting list appear in the /depth-first search order/.
--
-- Complexity: /O(m * log n)/ time and /O(n)/ space.
--
-- @
-- reachable 'empty'              x == []
-- reachable ('vertex' 1)         1 == [1]
-- reachable ('edge' 1 1)         1 == [1]
-- reachable ('edge' 1 2)         0 == []
-- reachable ('edge' 1 2)         1 == [1,2]
-- reachable ('edge' 1 2)         2 == [2]
-- reachable ('path'    [1..8]  ) 4 == [4..8]
-- reachable ('circuit' [1..8]  ) 4 == [4..8] ++ [1..3]
-- reachable ('clique'  [8,7..1]) 8 == [8] ++ [1..7]
--
-- 'Data.List.and' [ 'hasVertex' v x | v <- reachable x y ] == True
-- @
reachable :: Ord a => AdjacencyMap a -> a -> [a]
reachable :: forall a. Ord a => AdjacencyMap a -> a -> [a]
reachable AdjacencyMap a
x a
y = AdjacencyMap a -> [a] -> [a]
forall a. Ord a => AdjacencyMap a -> [a] -> [a]
dfs AdjacencyMap a
x [a
y]

type Cycle = NonEmpty
type Result a = Either (Cycle a) [a]
data NodeState = Entered | Exited
data S a = S { forall a. S a -> Map a a
parent :: Map.Map a a
             , forall a. S a -> Map a NodeState
entry  :: Map.Map a NodeState
             , forall a. S a -> [a]
order  :: [a] }

topSortImpl :: Ord a => AdjacencyMap a -> StateT (S a) (Cont (Result a)) (Result a)
topSortImpl :: forall a.
Ord a =>
AdjacencyMap a -> StateT (S a) (Cont (Result a)) (Result a)
topSortImpl 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 a b.
StateT (S a) (Cont (Result a)) a
-> (a -> StateT (S a) (Cont (Result a)) b)
-> StateT (S a) (Cont (Result a)) b
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 :: * -> *} {a}.
(Monad m, Ord a) =>
a -> StateT (S a) m ()
enterRoot a
x StateT (S a) (Cont (Result a)) ()
-> StateT (S a) (Cont (Result a)) ()
-> StateT (S a) (Cont (Result a)) ()
forall a b.
StateT (S a) (Cont (Result a)) a
-> StateT (S a) (Cont (Result a)) b
-> StateT (S a) (Cont (Result a)) b
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 a b.
StateT (S a) (Cont (Result a)) a
-> StateT (S a) (Cont (Result a)) b
-> StateT (S a) (Cont (Result a)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> StateT (S a) (Cont (Result a)) ()
forall {m :: * -> *} {a}.
(Monad m, Ord a) =>
a -> StateT (S a) m ()
exit a
x
           Maybe NodeState
_       -> () -> StateT (S a) (Cont (Result a)) ()
forall a. a -> StateT (S a) (Cont (Result a)) 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 a b.
StateT (S a) (Cont (Result a)) a
-> (a -> StateT (S a) (Cont (Result a)) b)
-> StateT (S a) (Cont (Result a)) b
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 :: * -> *} {a}.
(Monad m, Ord a) =>
a -> a -> StateT (S a) 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 a b.
StateT (S a) (Cont (Result a)) a
-> StateT (S a) (Cont (Result a)) b
-> StateT (S a) (Cont (Result a)) b
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 a b.
StateT (S a) (Cont (Result a)) a
-> StateT (S a) (Cont (Result a)) b
-> StateT (S a) (Cont (Result a)) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> StateT (S a) (Cont (Result a)) ()
forall {m :: * -> *} {a}.
(Monad m, Ord a) =>
a -> StateT (S a) m ()
exit a
y
                     Just NodeState
Exited  -> () -> StateT (S a) (Cont (Result a)) ()
forall a. a -> StateT (S a) (Cont (Result a)) 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
. Cycle a -> Result a
forall a b. a -> Either a b
Left (Cycle a -> Result a)
-> (Map a a -> Cycle a) -> Map a a -> Result a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> Map a a -> Cycle 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 :: a -> a -> StateT (S a) m ()
enter a
u 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 (a -> a -> Map a a -> Map a a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
v a
u Map a a
m)
                                          (a -> NodeState -> Map a NodeState -> Map a NodeState
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
v NodeState
Entered Map a NodeState
n)
                                          [a]
vs)
    enterRoot :: a -> StateT (S a) m ()
enterRoot 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 (a -> NodeState -> Map a NodeState -> Map a NodeState
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
v NodeState
Entered Map a NodeState
n) [a]
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 a b. (a -> b) -> Maybe a -> Maybe b
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)

-- | Compute a topological sort of a graph or discover a cycle.
--
-- Vertices are explored in the decreasing order according to their 'Ord'
-- instance. This gives the lexicographically smallest topological ordering in
-- the case of success. In the case of failure, the cycle is characterized by
-- being the lexicographically smallest up to rotation with respect to
-- @Ord@ @(Dual@ @Int)@ in the first connected component of the graph containing
-- a cycle, where the connected components are ordered by their largest vertex
-- with respect to @Ord a@.
--
-- Complexity: /O((n + m) * min(n,W))/ time and /O(n)/ space.
--
-- @
-- topSort (1 * 2 + 3 * 1)                    == Right [3,1,2]
-- topSort ('path' [1..5])                      == Right [1..5]
-- topSort (3 * (1 * 4 + 2 * 5))              == Right [3,1,2,4,5]
-- topSort (1 * 2 + 2 * 1)                    == Left (2 ':|' [1])
-- topSort ('path' [5,4..1] + 'edge' 2 4)         == Left (4 ':|' [3,2])
-- topSort ('circuit' [1..3])                   == Left (3 ':|' [1,2])
-- topSort ('circuit' [1..3] + 'circuit' [3,2,1]) == Left (3 ':|' [2])
-- topSort (1 * 2 + (5 + 2) * 1 + 3 * 4 * 3)  == Left (1 ':|' [2])
-- fmap ('flip' 'isTopSortOf' x) (topSort x)      /= Right False
-- 'isRight' . topSort                          == 'isAcyclic'
-- topSort . 'vertices'                         == Right . 'nub' . 'sort'
-- @
topSort :: Ord a => AdjacencyMap a -> Either (Cycle a) [a]
topSort :: forall a. Ord a => 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)
  (ContT (Either (Cycle a) [a]) Identity)
  (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)
     (ContT (Either (Cycle a) [a]) Identity)
     (Either (Cycle a) [a])
forall a.
Ord a =>
AdjacencyMap a -> StateT (S a) (Cont (Result a)) (Result a)
topSortImpl 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 []

-- | Check if a given graph is /acyclic/.
--
--   Complexity: /O((n+m)*log n)/ time and /O(n)/ space.
--
-- @
-- isAcyclic (1 * 2 + 3 * 1) == True
-- isAcyclic (1 * 2 + 2 * 1) == False
-- isAcyclic . 'circuit'       == 'null'
-- isAcyclic                 == 'isRight' . 'topSort'
-- @
isAcyclic :: Ord a => AdjacencyMap a -> Bool
isAcyclic :: forall a. Ord a => 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

-- | Compute the /condensation/ of a graph, where each vertex corresponds to a
-- /strongly-connected component/ of the original graph. Note that component
-- graphs are non-empty, and are therefore of type
-- "Algebra.Graph.NonEmpty.AdjacencyMap".
--
-- Details about the implementation can be found at
-- <https://github.com/jitwit/alga-notes/blob/master/gabow.org gabow-notes>.
--
-- Complexity: /O((n+m)*log n)/ time and /O(n+m)/ space.
--
-- @
-- scc 'empty'               == 'empty'
-- scc ('vertex' x)          == 'vertex' (NonEmpty.'NonEmpty.vertex' x)
-- scc ('vertices' xs)       == 'vertices' ('map' 'NonEmpty.vertex' xs)
-- scc ('edge' 1 1)          == 'vertex' (NonEmpty.'NonEmpty.edge' 1 1)
-- scc ('edge' 1 2)          == 'edge'   (NonEmpty.'NonEmpty.vertex' 1) (NonEmpty.'NonEmpty.vertex' 2)
-- scc ('circuit' (1:xs))    == 'vertex' (NonEmpty.'NonEmpty.circuit1' (1 'Data.List.NonEmpty.:|' xs))
-- scc (3 * 1 * 4 * 1 * 5) == 'edges'  [ (NonEmpty.'NonEmpty.vertex'  3      , NonEmpty.'NonEmpty.vertex'  5      )
--                                   , (NonEmpty.'NonEmpty.vertex'  3      , NonEmpty.'NonEmpty.clique1' [1,4,1])
--                                   , (NonEmpty.'NonEmpty.clique1' [1,4,1], NonEmpty.'NonEmpty.vertex'  5      ) ]
-- 'isAcyclic' . scc == 'const' True
-- 'isAcyclic' x     == (scc x == 'gmap' NonEmpty.'NonEmpty.vertex' x)
-- @
scc :: Ord a => AdjacencyMap a -> AdjacencyMap (NonEmpty.AdjacencyMap a)
scc :: forall a. Ord a => 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 { forall a. StateSCC a -> Int
_preorder     :: {-# unpack #-} !Int
        , forall a. StateSCC a -> Int
_component    :: {-# unpack #-} !Int
        , forall a. StateSCC a -> [(Int, a)]
boundaryStack :: [(Int,a)]
        , forall a. StateSCC a -> [a]
_pathStack    :: [a]
        , forall a. StateSCC a -> Map a Int
preorders     :: Map.Map a Int
        , forall a. StateSCC a -> Map a Int
components    :: Map.Map a Int
        , forall a. StateSCC a -> [AdjacencyMap a]
_innerGraphs  :: [AdjacencyMap a]
        , forall a. StateSCC a -> [(Int, (a, a))]
_innerEdges   :: [(Int,(a,a))]
        , forall 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
$cshowsPrec :: forall a. (Show a, Ord a) => Int -> StateSCC a -> ShowS
showsPrec :: Int -> StateSCC a -> ShowS
$cshow :: forall a. (Show a, Ord a) => StateSCC a -> [Char]
show :: StateSCC a -> [Char]
$cshowList :: forall a. (Show a, Ord a) => [StateSCC a] -> ShowS
showList :: [StateSCC a] -> ShowS
Show)

gabowSCC :: Ord a => AdjacencyMap a -> State (StateSCC a) ()
gabowSCC :: forall a. Ord a => 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 :: * -> *} {b}.
(Monad m, Ord b) =>
b -> StateT (StateSCC b) 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 a b.
StateT (StateSCC a) Identity a
-> (a -> StateT (StateSCC a) Identity b)
-> StateT (StateSCC a) Identity b
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 a b.
StateT (StateSCC a) Identity a
-> StateT (StateSCC a) Identity b -> StateT (StateSCC a) Identity b
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
    -- called when visiting vertex v. assigns preorder number to v,
    -- adds the (id, v) pair to the boundary stack b, and adds v to
    -- the path stack s.
    enter :: b -> StateT (StateSCC b) m Int
enter b
v = do SCC Int
pre Int
scc [(Int, b)]
bnd [b]
pth Map b Int
pres Map b Int
sccs [AdjacencyMap b]
gs [(Int, (b, b))]
es_i [(b, b)]
es_o <- StateT (StateSCC b) m (StateSCC b)
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, b)]
bnd' = (Int
pre,b
v)(Int, b) -> [(Int, b)] -> [(Int, b)]
forall a. a -> [a] -> [a]
:[(Int, b)]
bnd
                     pth' :: [b]
pth' = b
vb -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
pth
                     pres' :: Map b Int
pres' = b -> Int -> Map b Int -> Map b Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert b
v Int
pre Map b Int
pres
                 StateSCC b -> StateT (StateSCC b) m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (StateSCC b -> StateT (StateSCC b) m ())
-> StateSCC b -> StateT (StateSCC b) m ()
forall a b. (a -> b) -> a -> b
$! Int
-> Int
-> [(Int, b)]
-> [b]
-> Map b Int
-> Map b Int
-> [AdjacencyMap b]
-> [(Int, (b, b))]
-> [(b, b)]
-> StateSCC b
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, b)]
bnd' [b]
pth' Map b Int
pres' Map b Int
sccs [AdjacencyMap b]
gs [(Int, (b, b))]
es_i [(b, b)]
es_o
                 Int -> StateT (StateSCC b) m Int
forall a. a -> StateT (StateSCC b) m a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
pre

    -- called on back edges. pops the boundary stack while the top
    -- vertex has a larger preorder number than p_v.
    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)

    -- called when exiting vertex v. if v is the bottom of a scc
    -- boundary, we add a new SCC, otherwise v is part of a larger scc
    -- being constructed and we continue.
    exit :: a -> StateT (StateSCC a) m Bool
exit a
v = do [(Int, a)]
boundaryStack <- (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
                case [(Int, a)]
boundaryStack of
                    (Int
p_top, a
top) : [(Int, a)]
newBoundaryStack | a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
top -> do
                       Int -> a -> [(Int, a)] -> StateT (StateSCC a) m ()
forall {m :: * -> *} {k}.
(Monad m, Ord k) =>
Int -> k -> [(Int, k)] -> StateT (StateSCC k) m ()
insertComponent Int
p_top a
top [(Int, a)]
newBoundaryStack
                       Bool -> StateT (StateSCC a) m Bool
forall a. a -> StateT (StateSCC a) m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

                    [(Int, a)]
_ -> Bool -> StateT (StateSCC a) m Bool
forall a. a -> StateT (StateSCC a) m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    insertComponent :: Int -> k -> [(Int, k)] -> StateT (StateSCC k) m ()
insertComponent Int
p_v k
v [(Int, k)]
newBoundaryStack = (StateSCC k -> StateSCC k) -> StateT (StateSCC k) m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify'
      (\(SCC Int
pre Int
scc [(Int, k)]
_oldBoundaryStack [k]
pth Map k Int
pres Map k Int
sccs [AdjacencyMap k]
gs [(Int, (k, k))]
es_i [(k, k)]
es_o) ->
         let ([k]
curr,[k]
v_pth') = (k -> Bool) -> [k] -> ([k], [k])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (k -> k -> Bool
forall a. Eq a => a -> a -> Bool
/=k
v) [k]
pth
             pth' :: [k]
pth' = Int -> [k] -> [k]
forall a. Int -> [a] -> [a]
drop Int
1 [k]
v_pth' -- Here we know that v_pth' starts with v
             ([(Int, (k, k))]
es,[(Int, (k, k))]
es_i') = ((Int, (k, k)) -> Bool)
-> [(Int, (k, k))] -> ([(Int, (k, k))], [(Int, (k, k))])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=Int
p_v)(Int -> Bool) -> ((Int, (k, k)) -> Int) -> (Int, (k, k)) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int, (k, k)) -> Int
forall a b. (a, b) -> a
fst) [(Int, (k, k))]
es_i
             g_i :: AdjacencyMap k
g_i | [(Int, (k, k))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, (k, k))]
es = k -> AdjacencyMap k
forall a. a -> AdjacencyMap a
vertex k
v
                 | Bool
otherwise = [(k, k)] -> AdjacencyMap k
forall a. Ord a => [(a, a)] -> AdjacencyMap a
edges ((Int, (k, k)) -> (k, k)
forall a b. (a, b) -> b
snd ((Int, (k, k)) -> (k, k)) -> [(Int, (k, k))] -> [(k, k)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, (k, k))]
es)
             scc' :: Int
scc' = Int
scc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
             sccs' :: Map k Int
sccs' = (Map k Int -> k -> Map k Int) -> Map k Int -> [k] -> Map k Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\Map k Int
sccs k
x -> k -> Int -> Map k Int -> Map k Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
x Int
scc Map k Int
sccs) Map k Int
sccs (k
vk -> [k] -> [k]
forall a. a -> [a] -> [a]
:[k]
curr)
             gs' :: [AdjacencyMap k]
gs' = AdjacencyMap k
g_iAdjacencyMap k -> [AdjacencyMap k] -> [AdjacencyMap k]
forall a. a -> [a] -> [a]
:[AdjacencyMap k]
gs
          in Int
-> Int
-> [(Int, k)]
-> [k]
-> Map k Int
-> Map k Int
-> [AdjacencyMap k]
-> [(Int, (k, k))]
-> [(k, k)]
-> StateSCC k
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, k)]
newBoundaryStack [k]
pth' Map k Int
pres Map k Int
sccs' [AdjacencyMap k]
gs' [(Int, (k, k))]
es_i' [(k, k)]
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 :: forall a.
Ord a =>
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

-- | Check if a given forest is a correct /depth-first search/ forest of a graph.
-- The implementation is based on the paper "Depth-First Search and Strong
-- Connectivity in Coq" by François Pottier.
--
-- @
-- isDfsForestOf []                              'empty'            == True
-- isDfsForestOf []                              ('vertex' 1)       == False
-- isDfsForestOf [Node 1 []]                     ('vertex' 1)       == True
-- isDfsForestOf [Node 1 []]                     ('vertex' 2)       == False
-- isDfsForestOf [Node 1 [], Node 1 []]          ('vertex' 1)       == False
-- isDfsForestOf [Node 1 []]                     ('edge' 1 1)       == True
-- isDfsForestOf [Node 1 []]                     ('edge' 1 2)       == False
-- isDfsForestOf [Node 1 [], Node 2 []]          ('edge' 1 2)       == False
-- isDfsForestOf [Node 2 [], Node 1 []]          ('edge' 1 2)       == True
-- isDfsForestOf [Node 1 [Node 2 []]]            ('edge' 1 2)       == True
-- isDfsForestOf [Node 1 [], Node 2 []]          ('vertices' [1,2]) == True
-- isDfsForestOf [Node 2 [], Node 1 []]          ('vertices' [1,2]) == True
-- isDfsForestOf [Node 1 [Node 2 []]]            ('vertices' [1,2]) == False
-- isDfsForestOf [Node 1 [Node 2 [Node 3 []]]]   ('path' [1,2,3])   == True
-- isDfsForestOf [Node 1 [Node 3 [Node 2 []]]]   ('path' [1,2,3])   == False
-- isDfsForestOf [Node 3 [], Node 1 [Node 2 []]] ('path' [1,2,3])   == True
-- isDfsForestOf [Node 2 [Node 3 []], Node 1 []] ('path' [1,2,3])   == True
-- isDfsForestOf [Node 1 [], Node 2 [Node 3 []]] ('path' [1,2,3])   == False
-- @
isDfsForestOf :: Ord a => Forest a -> AdjacencyMap a -> Bool
isDfsForestOf :: forall a. Ord a => 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 -> [Tree 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 -> [Tree 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

-- | Check if a given list of vertices is a correct /topological sort/ of a graph.
--
-- @
-- isTopSortOf [3,1,2] (1 * 2 + 3 * 1) == True
-- isTopSortOf [1,2,3] (1 * 2 + 3 * 1) == False
-- isTopSortOf []      (1 * 2 + 3 * 1) == False
-- isTopSortOf []      'empty'           == True
-- isTopSortOf [x]     ('vertex' x)      == True
-- isTopSortOf [x]     ('edge' x x)      == False
-- @
isTopSortOf :: Ord a => [a] -> AdjacencyMap a -> Bool
isTopSortOf :: forall a. Ord a => [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