{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
-- |
-- Module     : Algebra.Graph.AdjacencyIntMap.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.AdjacencyIntMap" data type.
--
-- Some of the worst-case complexities include the term /min(n,W)/.
-- Following 'IntSet.IntSet' and 'IntMap.IntMap', the /W/ stands for
-- word size (usually 32 or 64 bits).
-----------------------------------------------------------------------------
module Algebra.Graph.AdjacencyIntMap.Algorithm (
    -- * Algorithms
    bfsForest, bfs, dfsForest, dfsForestFrom, dfs, reachable,
    topSort, isAcyclic,

    -- * Correctness properties
    isDfsForestOf, isTopSortOf,

    -- * Type synonyms
    Cycle
    ) where

import Control.Monad
import Control.Monad.Trans.Cont
import Control.Monad.Trans.State.Strict
import Data.Either
import Data.List.NonEmpty (NonEmpty(..), (<|))
import Data.Tree

import Algebra.Graph.AdjacencyIntMap

import qualified Data.List          as List
import qualified Data.IntMap.Strict as IntMap
import qualified Data.IntSet        as IntSet

-- | 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
-- expanded 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 [1,2] $ 'edge' 1 2)      == 'vertices' [1,2]
-- 'forest' (bfsForest [2]   $ 'edge' 1 2)      == 'vertex' 2
-- 'forest' (bfsForest [3]   $ 'edge' 1 2)      == 'empty'
-- 'forest' (bfsForest [2,1] $ 'edge' 1 2)      == 'vertices' [1,2]
-- 'isSubgraphOf' ('forest' $ bfsForest vs x) x == True
-- bfsForest ('vertexList' g) g               == 'map' (\v -> Node v []) ('nub' $ 'vertexList' g)
-- bfsForest [] x                           == []
-- bfsForest [1,4] (3 * (1 + 4) * (1 + 5))  == [ Node { rootLabel = 1
--                                                    , subForest = [ Node { rootLabel = 5
--                                                                         , subForest = [] }]}
--                                             , Node { rootLabel = 4
--                                                    , subForest = [] }]
-- 'forest' (bfsForest [3] ('circuit' [1..5] + 'circuit' [5,4..1])) == 'path' [3,2,1] + 'path' [3,4,5]
--
-- @
bfsForest :: [Int] -> AdjacencyIntMap -> Forest Int
bfsForest :: [Int] -> AdjacencyIntMap -> Forest Int
bfsForest [Int]
vs AdjacencyIntMap
g = State IntSet (Forest Int) -> IntSet -> Forest Int
forall s a. State s a -> s -> a
evalState ([Int] -> State IntSet (Forest Int)
explore [ Int
v | Int
v <- [Int]
vs, Int -> AdjacencyIntMap -> Bool
hasVertex Int
v AdjacencyIntMap
g ]) IntSet
IntSet.empty where
  explore :: [Int] -> State IntSet (Forest Int)
explore = (Int -> StateT IntSet Identity (Int, [Int]))
-> [Int] -> State IntSet (Forest Int)
forall (m :: * -> *) b a.
Monad m =>
(b -> m (a, [b])) -> [b] -> m [Tree a]
unfoldForestM_BF Int -> StateT IntSet Identity (Int, [Int])
walk ([Int] -> State IntSet (Forest Int))
-> ([Int] -> StateT IntSet Identity [Int])
-> [Int]
-> State IntSet (Forest Int)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (Int -> StateT IntSet Identity Bool)
-> [Int] -> StateT IntSet Identity [Int]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Int -> StateT IntSet Identity Bool
forall (m :: * -> *). Monad m => Int -> StateT IntSet m Bool
discovered
  walk :: Int -> StateT IntSet Identity (Int, [Int])
walk Int
v = (Int
v,) ([Int] -> (Int, [Int]))
-> StateT IntSet Identity [Int]
-> StateT IntSet Identity (Int, [Int])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> StateT IntSet Identity [Int]
adjacentM Int
v
  adjacentM :: Int -> StateT IntSet Identity [Int]
adjacentM Int
v = (Int -> StateT IntSet Identity Bool)
-> [Int] -> StateT IntSet Identity [Int]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Int -> StateT IntSet Identity Bool
forall (m :: * -> *). Monad m => Int -> StateT IntSet m Bool
discovered ([Int] -> StateT IntSet Identity [Int])
-> [Int] -> StateT IntSet Identity [Int]
forall a b. (a -> b) -> a -> b
$ IntSet -> [Int]
IntSet.toList (Int -> AdjacencyIntMap -> IntSet
postIntSet Int
v AdjacencyIntMap
g)
  discovered :: Int -> StateT IntSet m Bool
discovered Int
v = do Bool
new <- (IntSet -> Bool) -> StateT IntSet m Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (Bool -> Bool
not (Bool -> Bool) -> (IntSet -> Bool) -> IntSet -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IntSet -> Bool
IntSet.member Int
v)
                    Bool -> StateT IntSet m () -> StateT IntSet m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
new (StateT IntSet m () -> StateT IntSet m ())
-> StateT IntSet m () -> StateT IntSet m ()
forall a b. (a -> b) -> a -> b
$ (IntSet -> IntSet) -> StateT IntSet m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' (Int -> IntSet -> IntSet
IntSet.insert Int
v)
                    Bool -> StateT IntSet m Bool
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'@ @vs@
-- gives an enumeration of vertices reachable from @vs@ in the BFS order.
--
-- Complexity: /O((L+m)*min(n,W))/ time and /O(n)/ space, where /L/ is the
-- number of seed vertices.
--
-- @
-- bfs vs 'empty'                                         == []
-- bfs [] g                                             == []
-- bfs [1]   ('edge' 1 1)                                 == [[1]]
-- bfs [1]   ('edge' 1 2)                                 == [[1],[2]]
-- bfs [2]   ('edge' 1 2)                                 == [[2]]
-- bfs [1,2] ('edge' 1 2)                                 == [[1,2]]
-- bfs [2,1] ('edge' 1 2)                                 == [[2,1]]
-- bfs [3]   ('edge' 1 2)                                 == []
-- bfs [1,2] ( (1*2) + (3*4) + (5*6) )                  == [[1,2]]
-- bfs [1,3] ( (1*2) + (3*4) + (5*6) )                  == [[1,3],[2,4]]
-- bfs [3] (3 * (1 + 4) * (1 + 5))                      == [[3],[1,4,5]]
-- bfs [2] ('circuit' [1..5] + 'circuit' [5,4..1])          == [[2],[1,3],[5,4]]
-- 'concat' (bfs [3] $ 'circuit' [1..5] + 'circuit' [5,4..1]) == [3,2,4,1,5]
-- bfs vs == 'map' 'concat' . 'List.transpose' . 'map' 'levels' . 'bfsForest' vs
-- @
bfs :: [Int] -> AdjacencyIntMap -> [[Int]]
bfs :: [Int] -> AdjacencyIntMap -> [[Int]]
bfs [Int]
vs = ([[Int]] -> [Int]) -> [[[Int]]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map [[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[Int]]] -> [[Int]])
-> (AdjacencyIntMap -> [[[Int]]]) -> AdjacencyIntMap -> [[Int]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[[Int]]] -> [[[Int]]]
forall a. [[a]] -> [[a]]
List.transpose ([[[Int]]] -> [[[Int]]])
-> (AdjacencyIntMap -> [[[Int]]]) -> AdjacencyIntMap -> [[[Int]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree Int -> [[Int]]) -> Forest Int -> [[[Int]]]
forall a b. (a -> b) -> [a] -> [b]
map Tree Int -> [[Int]]
forall a. Tree a -> [[a]]
levels (Forest Int -> [[[Int]]])
-> (AdjacencyIntMap -> Forest Int) -> AdjacencyIntMap -> [[[Int]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> AdjacencyIntMap -> Forest Int
bfsForest [Int]
vs

-- | 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.
--
-- @
-- dfsForest '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)
-- 'dfsForestFrom' ('vertexList' x) x        == dfsForest x
-- 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 :: AdjacencyIntMap -> Forest Int
dfsForest :: AdjacencyIntMap -> Forest Int
dfsForest AdjacencyIntMap
g = [Int] -> AdjacencyIntMap -> Forest Int
dfsForestFrom' (AdjacencyIntMap -> [Int]
vertexList AdjacencyIntMap
g) AdjacencyIntMap
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/ be the number
-- of seed vertices.
--
-- @
-- dfsForestFrom vs 'empty'                           == []
-- 'forest' (dfsForestFrom [1]   $ 'edge' 1 1)          == 'vertex' 1
-- 'forest' (dfsForestFrom [1]   $ 'edge' 1 2)          == 'edge' 1 2
-- 'forest' (dfsForestFrom [2]   $ 'edge' 1 2)          == 'vertex' 2
-- 'forest' (dfsForestFrom [3]   $ 'edge' 1 2)          == 'empty'
-- 'forest' (dfsForestFrom [2,1] $ 'edge' 1 2)          == 'vertices' [1,2]
-- 'isSubgraphOf' ('forest' $ dfsForestFrom vs x) x     == True
-- 'isDfsForestOf' (dfsForestFrom ('vertexList' x) x) x == True
-- dfsForestFrom ('vertexList' x) x                   == 'dfsForest' x
-- dfsForestFrom vs             ('vertices' vs)       == 'map' (\\v -> Node v []) ('Data.List.nub' vs)
-- dfsForestFrom []             x                   == []
-- dfsForestFrom [1,4] $ 3 * (1 + 4) * (1 + 5)      == [ Node { rootLabel = 1
--                                                            , subForest = [ Node { rootLabel = 5
--                                                                                 , subForest = [] }
--                                                     , Node { rootLabel = 4
--                                                            , subForest = [] }]
-- 'forest' (dfsForestFrom [3] $ 'circuit' [1..5] + 'circuit' [5,4..1]) == 'path' [3,2,1,5,4]
-- @
dfsForestFrom :: [Int] -> AdjacencyIntMap -> Forest Int
dfsForestFrom :: [Int] -> AdjacencyIntMap -> Forest Int
dfsForestFrom [Int]
vs AdjacencyIntMap
g = [Int] -> AdjacencyIntMap -> Forest Int
dfsForestFrom' [ Int
v | Int
v <- [Int]
vs, Int -> AdjacencyIntMap -> Bool
hasVertex Int
v AdjacencyIntMap
g ] AdjacencyIntMap
g

dfsForestFrom' :: [Int] -> AdjacencyIntMap -> Forest Int
dfsForestFrom' :: [Int] -> AdjacencyIntMap -> Forest Int
dfsForestFrom' [Int]
vs AdjacencyIntMap
g = State IntSet (Forest Int) -> IntSet -> Forest Int
forall s a. State s a -> s -> a
evalState ([Int] -> State IntSet (Forest Int)
explore [Int]
vs) IntSet
IntSet.empty where
  explore :: [Int] -> State IntSet (Forest Int)
explore (Int
v:[Int]
vs) = Int -> StateT IntSet Identity Bool
forall (m :: * -> *). Monad m => Int -> StateT IntSet m Bool
discovered Int
v StateT IntSet Identity Bool
-> (Bool -> State IntSet (Forest Int)) -> State IntSet (Forest Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> (:) (Tree Int -> Forest Int -> Forest Int)
-> StateT IntSet Identity (Tree Int)
-> StateT IntSet Identity (Forest Int -> Forest Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> StateT IntSet Identity (Tree Int)
walk Int
v StateT IntSet Identity (Forest Int -> Forest Int)
-> State IntSet (Forest Int) -> State IntSet (Forest Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Int] -> State IntSet (Forest Int)
explore [Int]
vs
    Bool
False -> [Int] -> State IntSet (Forest Int)
explore [Int]
vs
  explore [] = Forest Int -> State IntSet (Forest Int)
forall (m :: * -> *) a. Monad m => a -> m a
return []
  walk :: Int -> StateT IntSet Identity (Tree Int)
walk Int
v = Int -> Forest Int -> Tree Int
forall a. a -> [Tree a] -> Tree a
Node Int
v (Forest Int -> Tree Int)
-> State IntSet (Forest Int) -> StateT IntSet Identity (Tree Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> State IntSet (Forest Int)
explore (Int -> [Int]
adjacent Int
v)
  adjacent :: Int -> [Int]
adjacent Int
v = IntSet -> [Int]
IntSet.toList (Int -> AdjacencyIntMap -> IntSet
postIntSet Int
v AdjacencyIntMap
g)
  discovered :: Int -> StateT IntSet m Bool
discovered Int
v = do Bool
new <- (IntSet -> Bool) -> StateT IntSet m Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (Bool -> Bool
not (Bool -> Bool) -> (IntSet -> Bool) -> IntSet -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IntSet -> Bool
IntSet.member Int
v)
                    Bool -> StateT IntSet m () -> StateT IntSet m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
new (StateT IntSet m () -> StateT IntSet m ())
-> StateT IntSet m () -> StateT IntSet m ()
forall a b. (a -> b) -> a -> b
$ (IntSet -> IntSet) -> StateT IntSet m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' (Int -> IntSet -> IntSet
IntSet.insert Int
v)
                    Bool -> StateT IntSet m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
new

-- | 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 vs    $ 'empty'                    == []
-- dfs [1]   $ 'edge' 1 1                 == [1]
-- dfs [1]   $ 'edge' 1 2                 == [1,2]
-- dfs [2]   $ 'edge' 1 2                 == [2]
-- dfs [3]   $ 'edge' 1 2                 == []
-- dfs [1,2] $ 'edge' 1 2                 == [1,2]
-- dfs [2,1] $ 'edge' 1 2                 == [2,1]
-- dfs []    $ x                        == []
-- dfs [1,4] $ 3 * (1 + 4) * (1 + 5)    == [1,5,4]
-- 'isSubgraphOf' ('vertices' $ dfs vs x) x == True
-- dfs [3] $ 'circuit' [1..5] + 'circuit' [5,4..1] == [3,2,1,5,4]
-- @
dfs :: [Int] -> AdjacencyIntMap -> [Int]
dfs :: [Int] -> AdjacencyIntMap -> [Int]
dfs [Int]
vs = [Int] -> AdjacencyIntMap -> Forest Int
dfsForestFrom [Int]
vs (AdjacencyIntMap -> Forest Int)
-> (Tree Int -> [Int]) -> AdjacencyIntMap -> [Int]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tree Int -> [Int]
forall a. Tree a -> [a]
flatten

-- | Return the list of vertices that are /reachable/ from a given source vertex
-- in a graph. The vertices in the resulting list appear in the /depth-first order/.
--
-- Complexity: /O(m*log n)/ time and /O(n)/ space.
--
-- @
-- reachable x $ 'empty'                       == []
-- reachable 1 $ 'vertex' 1                    == [1]
-- reachable 1 $ 'vertex' 2                    == []
-- reachable 1 $ 'edge' 1 1                    == [1]
-- reachable 1 $ 'edge' 1 2                    == [1,2]
-- reachable 4 $ 'path'    [1..8]              == [4..8]
-- reachable 4 $ 'circuit' [1..8]              == [4..8] ++ [1..3]
-- reachable 8 $ 'clique'  [8,7..1]            == [8] ++ [1..7]
-- 'isSubgraphOf' ('vertices' $ reachable x y) y == True
-- @
reachable :: Int -> AdjacencyIntMap -> [Int]
reachable :: Int -> AdjacencyIntMap -> [Int]
reachable Int
x = [Int] -> AdjacencyIntMap -> [Int]
dfs [Int
x]

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

topSort' :: AdjacencyIntMap -> StateT S (Cont Result) Result
topSort' :: AdjacencyIntMap -> StateT S (Cont Result) Result
topSort' AdjacencyIntMap
g = CallCC (Cont Result) (Result, S) ((), S)
-> CallCC (StateT S (Cont Result)) Result ()
forall (m :: * -> *) a s b.
CallCC m (a, s) (b, s) -> CallCC (StateT s m) a b
liftCallCC' CallCC (Cont Result) (Result, S) ((), S)
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 (Cont Result)) Result ()
-> CallCC (StateT S (Cont Result)) Result ()
forall a b. (a -> b) -> a -> b
$ \Result -> StateT S (Cont Result) ()
cyclic ->
  do let vertices :: [Int]
vertices = ((Int, IntSet) -> Int) -> [(Int, IntSet)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, IntSet) -> Int
forall a b. (a, b) -> a
fst ([(Int, IntSet)] -> [Int]) -> [(Int, IntSet)] -> [Int]
forall a b. (a -> b) -> a -> b
$ IntMap IntSet -> [(Int, IntSet)]
forall a. IntMap a -> [(Int, a)]
IntMap.toDescList (IntMap IntSet -> [(Int, IntSet)])
-> IntMap IntSet -> [(Int, IntSet)]
forall a b. (a -> b) -> a -> b
$ AdjacencyIntMap -> IntMap IntSet
adjacencyIntMap AdjacencyIntMap
g
         adjacent :: Int -> [Int]
adjacent = IntSet -> [Int]
IntSet.toDescList (IntSet -> [Int]) -> (Int -> IntSet) -> Int -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> AdjacencyIntMap -> IntSet)
-> AdjacencyIntMap -> Int -> IntSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> AdjacencyIntMap -> IntSet
postIntSet AdjacencyIntMap
g
         dfsRoot :: Int -> StateT S (Cont Result) ()
dfsRoot Int
x = Int -> StateT S (Cont Result) (Maybe NodeState)
forall (m :: * -> *).
Monad m =>
Int -> StateT S m (Maybe NodeState)
nodeState Int
x StateT S (Cont Result) (Maybe NodeState)
-> (Maybe NodeState -> StateT S (Cont Result) ())
-> StateT S (Cont Result) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
           Maybe NodeState
Nothing -> Int -> StateT S (Cont Result) ()
forall (m :: * -> *). Monad m => Int -> StateT S m ()
enterRoot Int
x StateT S (Cont Result) ()
-> StateT S (Cont Result) () -> StateT S (Cont Result) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> StateT S (Cont Result) ()
dfs Int
x StateT S (Cont Result) ()
-> StateT S (Cont Result) () -> StateT S (Cont Result) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> StateT S (Cont Result) ()
forall (m :: * -> *). Monad m => Int -> StateT S m ()
exit Int
x
           Maybe NodeState
_       -> () -> StateT S (Cont Result) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         dfs :: Int -> StateT S (Cont Result) ()
dfs Int
x = [Int]
-> (Int -> StateT S (Cont Result) ()) -> StateT S (Cont Result) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Int -> [Int]
adjacent Int
x) ((Int -> StateT S (Cont Result) ()) -> StateT S (Cont Result) ())
-> (Int -> StateT S (Cont Result) ()) -> StateT S (Cont Result) ()
forall a b. (a -> b) -> a -> b
$ \Int
y ->
                   Int -> StateT S (Cont Result) (Maybe NodeState)
forall (m :: * -> *).
Monad m =>
Int -> StateT S m (Maybe NodeState)
nodeState Int
y StateT S (Cont Result) (Maybe NodeState)
-> (Maybe NodeState -> StateT S (Cont Result) ())
-> StateT S (Cont Result) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                     Maybe NodeState
Nothing      -> Int -> Int -> StateT S (Cont Result) ()
forall (m :: * -> *). Monad m => Int -> Int -> StateT S m ()
enter Int
x Int
y StateT S (Cont Result) ()
-> StateT S (Cont Result) () -> StateT S (Cont Result) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> StateT S (Cont Result) ()
dfs Int
y StateT S (Cont Result) ()
-> StateT S (Cont Result) () -> StateT S (Cont Result) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> StateT S (Cont Result) ()
forall (m :: * -> *). Monad m => Int -> StateT S m ()
exit Int
y
                     Just NodeState
Exited  -> () -> StateT S (Cont Result) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                     Just NodeState
Entered -> Result -> StateT S (Cont Result) ()
cyclic (Result -> StateT S (Cont Result) ())
-> (IntMap Int -> Result)
-> IntMap Int
-> StateT S (Cont Result) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Int -> Result
forall a b. a -> Either a b
Left (NonEmpty Int -> Result)
-> (IntMap Int -> NonEmpty Int) -> IntMap Int -> Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> IntMap Int -> NonEmpty Int
retrace Int
x Int
y (IntMap Int -> StateT S (Cont Result) ())
-> StateT S (Cont Result) (IntMap Int) -> StateT S (Cont Result) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (S -> IntMap Int) -> StateT S (Cont Result) (IntMap Int)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets S -> IntMap Int
parent
     [Int]
-> (Int -> StateT S (Cont Result) ()) -> StateT S (Cont Result) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
vertices Int -> StateT S (Cont Result) ()
dfsRoot
     [Int] -> Result
forall a b. b -> Either a b
Right ([Int] -> Result)
-> StateT S (Cont Result) [Int] -> StateT S (Cont Result) Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (S -> [Int]) -> StateT S (Cont Result) [Int]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets S -> [Int]
order
  where
    nodeState :: Int -> StateT S m (Maybe NodeState)
nodeState Int
v = (S -> Maybe NodeState) -> StateT S m (Maybe NodeState)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (Int -> IntMap NodeState -> Maybe NodeState
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
v (IntMap NodeState -> Maybe NodeState)
-> (S -> IntMap NodeState) -> S -> Maybe NodeState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. S -> IntMap NodeState
entry)
    enter :: Int -> Int -> StateT S m ()
enter Int
u Int
v = (S -> S) -> StateT S m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' (\(S IntMap Int
m IntMap NodeState
n [Int]
vs) -> IntMap Int -> IntMap NodeState -> [Int] -> S
S (Int -> Int -> IntMap Int -> IntMap Int
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
v Int
u IntMap Int
m)
                                          (Int -> NodeState -> IntMap NodeState -> IntMap NodeState
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
v NodeState
Entered IntMap NodeState
n)
                                          [Int]
vs)
    enterRoot :: Int -> StateT S m ()
enterRoot Int
v = (S -> S) -> StateT S m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' (\(S IntMap Int
m IntMap NodeState
n [Int]
vs) -> IntMap Int -> IntMap NodeState -> [Int] -> S
S IntMap Int
m (Int -> NodeState -> IntMap NodeState -> IntMap NodeState
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
v NodeState
Entered IntMap NodeState
n) [Int]
vs)
    exit :: Int -> StateT S m ()
exit Int
v = (S -> S) -> StateT S m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' (\(S IntMap Int
m IntMap NodeState
n [Int]
vs) -> IntMap Int -> IntMap NodeState -> [Int] -> S
S IntMap Int
m ((Maybe NodeState -> Maybe NodeState)
-> Int -> IntMap NodeState -> IntMap NodeState
forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IntMap.alter ((NodeState -> NodeState) -> Maybe NodeState -> Maybe NodeState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NodeState -> NodeState
leave) Int
v IntMap NodeState
n) (Int
vInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
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 :: Int -> Int -> IntMap Int -> NonEmpty Int
retrace Int
curr Int
head IntMap Int
parent = NonEmpty Int -> NonEmpty Int
aux (Int
curr Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty a
:| []) where
      aux :: NonEmpty Int -> NonEmpty Int
aux xs :: NonEmpty Int
xs@(Int
curr :| [Int]
_)
        | Int
head Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
curr = NonEmpty Int
xs
        | Bool
otherwise = NonEmpty Int -> NonEmpty Int
aux (IntMap Int
parent IntMap Int -> Int -> Int
forall a. IntMap a -> Int -> a
IntMap.! Int
curr Int -> NonEmpty Int -> NonEmpty Int
forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty Int
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 + 2*1 + 3*4 + 4*3 + 5*1)      == Left (1 ':|' [2])
-- fmap ('flip' 'isTopSortOf' x) (topSort x)      /= Right False
-- topSort . 'vertices'                         == Right . 'nub' . 'sort'
-- @
topSort :: AdjacencyIntMap -> Either (Cycle Int) [Int]
topSort :: AdjacencyIntMap -> Result
topSort AdjacencyIntMap
g = Cont Result Result -> (Result -> Result) -> Result
forall r a. Cont r a -> (a -> r) -> r
runCont (StateT S (Cont Result) Result -> S -> Cont Result Result
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (AdjacencyIntMap -> StateT S (Cont Result) Result
topSort' AdjacencyIntMap
g) S
initialState) Result -> Result
forall a. a -> a
id
  where
    initialState :: S
initialState = IntMap Int -> IntMap NodeState -> [Int] -> S
S IntMap Int
forall a. IntMap a
IntMap.empty IntMap NodeState
forall a. IntMap a
IntMap.empty []

-- | Check if a given graph is /acyclic/.
--
-- Complexity: /O((n+m)*min(n,W))/ time and /O(n)/ space.
--
-- @
-- isAcyclic (1 * 2 + 3 * 1) == True
-- isAcyclic (1 * 2 + 2 * 1) == False
-- isAcyclic . 'circuit'       == 'null'
-- isAcyclic                 == 'isRight' . 'topSort'
-- @
isAcyclic :: AdjacencyIntMap -> Bool
isAcyclic :: AdjacencyIntMap -> Bool
isAcyclic = Result -> Bool
forall a b. Either a b -> Bool
isRight (Result -> Bool)
-> (AdjacencyIntMap -> Result) -> AdjacencyIntMap -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyIntMap -> Result
topSort

-- | 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 :: Forest Int -> AdjacencyIntMap -> Bool
isDfsForestOf :: Forest Int -> AdjacencyIntMap -> Bool
isDfsForestOf Forest Int
f AdjacencyIntMap
am = case IntSet -> Forest Int -> Maybe IntSet
go IntSet
IntSet.empty Forest Int
f of
    Just IntSet
seen -> IntSet
seen IntSet -> IntSet -> Bool
forall a. Eq a => a -> a -> Bool
== AdjacencyIntMap -> IntSet
vertexIntSet AdjacencyIntMap
am
    Maybe IntSet
Nothing   -> Bool
False
  where
    go :: IntSet -> Forest Int -> Maybe IntSet
go IntSet
seen []     = IntSet -> Maybe IntSet
forall a. a -> Maybe a
Just IntSet
seen
    go IntSet
seen (Tree Int
t:Forest Int
ts) = do
        let root :: Int
root = Tree Int -> Int
forall a. Tree a -> a
rootLabel Tree Int
t
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Int
root Int -> IntSet -> Bool
`IntSet.notMember` IntSet
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 [ Int -> Int -> AdjacencyIntMap -> Bool
hasEdge Int
root (Tree Int -> Int
forall a. Tree a -> a
rootLabel Tree Int
subTree) AdjacencyIntMap
am | Tree Int
subTree <- Tree Int -> Forest Int
forall a. Tree a -> [Tree a]
subForest Tree Int
t ]
        IntSet
newSeen <- IntSet -> Forest Int -> Maybe IntSet
go (Int -> IntSet -> IntSet
IntSet.insert Int
root IntSet
seen) (Tree Int -> Forest Int
forall a. Tree a -> [Tree a]
subForest Tree Int
t)
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Int -> AdjacencyIntMap -> IntSet
postIntSet Int
root AdjacencyIntMap
am IntSet -> IntSet -> Bool
`IntSet.isSubsetOf` IntSet
newSeen
        IntSet -> Forest Int -> Maybe IntSet
go IntSet
newSeen Forest Int
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 :: [Int] -> AdjacencyIntMap -> Bool
isTopSortOf :: [Int] -> AdjacencyIntMap -> Bool
isTopSortOf [Int]
xs AdjacencyIntMap
m = IntSet -> [Int] -> Bool
go IntSet
IntSet.empty [Int]
xs
  where
    go :: IntSet -> [Int] -> Bool
go IntSet
seen []     = IntSet
seen IntSet -> IntSet -> Bool
forall a. Eq a => a -> a -> Bool
== IntMap IntSet -> IntSet
forall a. IntMap a -> IntSet
IntMap.keysSet (AdjacencyIntMap -> IntMap IntSet
adjacencyIntMap AdjacencyIntMap
m)
    go IntSet
seen (Int
v:[Int]
vs) = Int -> AdjacencyIntMap -> IntSet
postIntSet Int
v AdjacencyIntMap
m IntSet -> IntSet -> IntSet
`IntSet.intersection` IntSet
newSeen IntSet -> IntSet -> Bool
forall a. Eq a => a -> a -> Bool
== IntSet
IntSet.empty
                  Bool -> Bool -> Bool
&& IntSet -> [Int] -> Bool
go IntSet
newSeen [Int]
vs
      where
        newSeen :: IntSet
newSeen = Int -> IntSet -> IntSet
IntSet.insert Int
v IntSet
seen