```{-# language LambdaCase #-}

-----------------------------------------------------------------------------
-- |
-- Copyright  : (c) Andrey Mokhov 2016-2018
-- 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).
-----------------------------------------------------------------------------
-- * Algorithms
bfsForest, bfs, dfsForest, dfsForestFrom, dfs, reachable,
topSort, isAcyclic,

-- * Correctness properties
isDfsForestOf, isTopSortOf,

-- * Type synonyms
Cycle
) where

import Data.Either
import Data.List.NonEmpty (NonEmpty(..),(<|))
import Data.Tree

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 with respect
--   to their 'Ord' instance. The search is seeded by a list of
--   argument vertices that will be the roots of the resulting
--   forest. Duplicates in the list will have their first occurrence
--   expanded and subsequent ones ignored. Argument vertices not in
--   the graph are also ignored.
--
--   Let /L/ be the number of seed vertices. Complexity:
--   /O((L+m)*min(n,W))/ time and /O(n)/ space.
--
-- @
-- '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 vs g = evalState (explore [ v | v <- vs, hasVertex v g ]) IntSet.empty where
explore = unfoldForestM_BF walk <=< filterM discovered
walk v = (v,) <\$> adjacentM v
adjacentM v = filterM discovered \$ IntSet.toList (postIntSet v g)
discovered v = do new <- gets (not . IntSet.member v)
when new \$ modify' (IntSet.insert v)
return new

-- | This is 'bfsForest' with the resulting forest converted to a
--   level structure. Adjacent vertices are explored in increasing
--   order with respect to their 'Ord' instance. Flattening the result
--   via @'concat' . 'bfs' vs@ gives an enumeration of vertices
--   reachable from @vs@ in breadth first order.
--
--   Let /L/ be the number of seed vertices. Complexity:
--   /O((L+m)*min(n,W))/ time and /O(n)/ space.
--
-- @
-- 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 vs = map concat . List.transpose . map levels . bfsForest vs

-- | Compute the /depth-first search/ forest of a graph, where
--   adjacent vertices are expanded in increasing order with respect
--   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 g = dfsForestFrom' (vertexList g) g

-- | Compute the /depth-first search/ forest of a graph from the given
--   vertices, where adjacent vertices are expanded in increasing
--   order with respect to to their 'Ord' instance. Note that the
--   resulting forest does not necessarily span the whole graph, as
--   some vertices may be unreachable. Any of the given vertices which
--   are not in the graph are ignored.
--
--   Let /L/ be the number of seed vertices. Complexity:
--   /O((L+m)*min(n,W))/ time and /O(n)/ space.
--
-- @
-- 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 vs g = dfsForestFrom' [ v | v <- vs, hasVertex v g ] g

dfsForestFrom' :: [Int] -> AdjacencyIntMap -> Forest Int
dfsForestFrom' vs g = evalState (explore vs) IntSet.empty where
explore (v:vs) = discovered v >>= \case
True -> (:) <\$> walk v <*> explore vs
False -> explore vs
explore [] = return []
walk v = Node v <\$> explore (adjacent v)
adjacent v = IntSet.toList (postIntSet v g)
discovered v = do new <- gets (not . IntSet.member v)
when new \$ modify' (IntSet.insert v)
return new

-- | Compute the vertices visited by /depth-first search/ in a graph
--   from the given vertices. Adjacent vertices are explored in
--   increasing order with respect to their 'Ord' instance.
--
--   Let /L/ be the number of seed vertices. Complexity:
--   /O((L+m)*min(n,W))/ time and /O(n)/ space.
--
-- @
-- 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 vs = dfsForestFrom vs >=> flatten

-- | Compute the list of vertices that are /reachable/ from a given
--   source vertex in a graph. The vertices in the resulting list
--   appear in /depth-first order/.
--
--   Complexity: /O(m*min(n,W))/ 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 x = dfs [x]

type Cycle = NonEmpty
data NodeState = Entered | Exited
data S = S { parent :: IntMap.IntMap Int
, entry  :: IntMap.IntMap NodeState
, order  :: [Int] }

=> AdjacencyIntMap -> m (Either (Cycle Int) [Int])
topSort' g = callCC \$ \cyclic ->
do let vertices = map fst \$ IntMap.toDescList \$ adjacencyIntMap g
adjacent = IntSet.toDescList . flip postIntSet g
dfsRoot x = nodeState x >>= \case
Nothing -> enterRoot x >> dfs x >> exit x
_       -> return ()
dfs x = forM_ (adjacent x) \$ \y ->
nodeState y >>= \case
Nothing      -> enter x y >> dfs y >> exit y
Just Exited  -> return ()
Just Entered -> cyclic . Left . retrace x y =<< gets parent
forM_ vertices dfsRoot
Right <\$> gets order
where
nodeState v = gets (IntMap.lookup v . entry)
enter u v = modify' (\(S m n vs) -> S (IntMap.insert v u m)
(IntMap.insert v Entered n)
vs)
enterRoot v = modify' (\(S m n vs) -> S m (IntMap.insert v Entered n) vs)
exit v = modify' (\(S m n vs) -> S m (IntMap.alter (fmap leave) v n) (v:vs))
where leave = \case
Entered -> Exited
Exited  -> error "Internal error: dfs search order violated"
retrace curr head parent = aux (curr :| []) where
aux xs@(curr :| _)
| head == curr = xs
| otherwise = aux (parent IntMap.! curr <| xs)

-- | Compute a topological sort of a DAG or discover a cycle.
--
--   Vertices are expanded in decreasing order with respect 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 g = runContT (evalStateT (topSort' g) initialState) id where
initialState = S IntMap.empty 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 = isRight . 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 f am = case go IntSet.empty f of
Just seen -> seen == vertexIntSet am
Nothing   -> False
where
go seen []     = Just seen
go seen (t:ts) = do
let root = rootLabel t
guard \$ root `IntSet.notMember` seen
guard \$ and [ hasEdge root (rootLabel subTree) am | subTree <- subForest t ]
newSeen <- go (IntSet.insert root seen) (subForest t)
guard \$ postIntSet root am `IntSet.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 :: [Int] -> AdjacencyIntMap -> Bool
isTopSortOf xs m = go IntSet.empty xs
where
go seen []     = seen == IntMap.keysSet (adjacencyIntMap m)
go seen (v:vs) = postIntSet v m `IntSet.intersection` newSeen == IntSet.empty
&& go newSeen vs
where
newSeen = IntSet.insert v seen
```