{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
-- |
-- Module     : Algebra.Graph.AdjacencyMap.Algorithm
-- Copyright  : (c) Andrey Mokhov 2016-2022
-- 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

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

-- | 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 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)
                      when new $ modify' (Set.insert v)
                      return 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 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)
                      when new $ modify' (Set.insert v)
                      return 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 p_u <- a -> StateT (StateSCC a) Identity Int
forall {m :: * -> *} {b}.
(Monad m, Ord b) =>
b -> StateT (StateSCC b) m Int
enter a
u
                    for_ (postSet u g) $ \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 -> StateT (StateSCC a) Identity ())
-> StateT (StateSCC a) Identity ()
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
                          updated <- a -> StateT (StateSCC a) Identity Bool
dfs a
v
                          if updated then outedge (u,v) else inedge (p_u,(u,v))
                        Just Int
p_v -> do
                          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 scc_v
                            then outedge (u,v)
                            else popBoundary p_v >> inedge (p_u,(u,v))
                    exit u
     [a]
-> (a -> StateT (StateSCC a) Identity ())
-> StateT (StateSCC a) Identity ()
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 -> StateT (StateSCC a) Identity ())
 -> StateT (StateSCC a) Identity ())
-> (a -> StateT (StateSCC a) Identity ())
-> StateT (StateSCC a) Identity ()
forall a b. (a -> b) -> a -> b
$ \a
v -> do
       assigned <- a -> StateT (StateSCC a) Identity Bool
forall {m :: * -> *} {k}.
(Monad m, Ord k) =>
k -> StateT (StateSCC k) m Bool
hasPreorderId a
v
       unless assigned $ void $ dfs 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 pre scc bnd pth pres sccs gs es_i es_o <- StateT (StateSCC b) m (StateSCC b)
forall (m :: * -> *) s. Monad m => StateT s m s
get
                 let pre' = Int
preInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1
                     bnd' = (Int
pre,b
v)(Int, b) -> [(Int, b)] -> [(Int, b)]
forall a. a -> [a] -> [a]
:[(Int, b)]
bnd
                     pth' = b
vb -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
pth
                     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
                 put $! SCC pre' scc bnd' pth' pres' sccs gs es_i es_o
                 return 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 :: b -> StateT (StateSCC b) m Bool
exit b
v = do newComponent <- (b
vb -> b -> Bool
forall a. Eq a => a -> a -> Bool
==)(b -> Bool) -> ([(Int, b)] -> b) -> [(Int, b)] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int, b) -> b
forall a b. (a, b) -> b
snd((Int, b) -> b) -> ([(Int, b)] -> (Int, b)) -> [(Int, b)] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[(Int, b)] -> (Int, b)
forall a. HasCallStack => [a] -> a
head ([(Int, b)] -> Bool)
-> StateT (StateSCC b) m [(Int, b)] -> StateT (StateSCC b) m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StateSCC b -> [(Int, b)]) -> StateT (StateSCC b) m [(Int, b)]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets StateSCC b -> [(Int, b)]
forall a. StateSCC a -> [(Int, a)]
boundaryStack
                when newComponent $ insertComponent v
                return newComponent

    insertComponent :: k -> StateT (StateSCC k) m ()
insertComponent k
v = (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)]
bnd [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' = [k] -> [k]
forall a. HasCallStack => [a] -> [a]
tail [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)
             p_v :: Int
p_v = (Int, k) -> Int
forall a b. (a, b) -> a
fst ((Int, k) -> Int) -> (Int, k) -> Int
forall a b. (a -> b) -> a -> b
$ [(Int, k)] -> (Int, k)
forall a. HasCallStack => [a] -> a
head [(Int, k)]
bnd
             scc' :: Int
scc' = Int
scc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
             bnd' :: [(Int, k)]
bnd' = [(Int, k)] -> [(Int, k)]
forall a. HasCallStack => [a] -> [a]
tail [(Int, k)]
bnd
             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)]
bnd' [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 ]
        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)
        guard $ postSet root am `Set.isSubsetOf` newSeen
        go newSeen 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