# LANGUAGE CPP #
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE RecordWildCards     #-}
# LANGUAGE ScopedTypeVariables #
  | Copyright : ( c ) 2018 ,  
  SPDX - License - Identifier : BSD-3 - Clause
--
  Tools to work with Directed Acyclic Graphs ,
-- by taking advantage of topological sorting.
--
module Topograph (
    -- * Graph
    -- $setup

    G (..),
    runG,
    runG',
    -- * Transpose
    transpose,
    -- * Transitive reduction
    reduction,
    -- * Transitive closure
    closure,
    -- * DFS
    dfs,
    dfsTree,
    -- * All paths
    allPaths,
    allPaths',
    allPathsTree,
    -- * Path lengths
    shortestPathLengths,
    longestPathLengths,
    -- * Query
    edgesSet,
    adjacencyMap,
    adjacencyList,
    -- * Utilities
    pairs,
    treePairs,
    ) where

import Data.Orphans ()
import Prelude ()
import Prelude.Compat

import Control.Monad.ST (ST, runST)
import Data.Foldable    (for_)
import Data.List        (sort)
import Data.Map         (Map)
import Data.Maybe       (catMaybes, mapMaybe)
import Data.Monoid      (First (..))
import Data.Ord         (Down (..))
import Data.Set         (Set)

import qualified Data.Graph                  as G
import qualified Data.Map                    as Map
import qualified Data.Set                    as Set
import qualified Data.Tree                   as T
import qualified Data.Vector                 as V
import qualified Data.Vector.Unboxed         as U
import qualified Data.Vector.Unboxed.Mutable as MU

-------------------------------------------------------------------------------
-- Setup
-------------------------------------------------------------------------------

-- $setup
--
-- Initial setup and imports:
--
-- >>> :set -XRecordWildCards
  > > > import Data . Monoid ( All ( .. ) )
-- >>> import Data.Foldable (traverse_)
-- >>> import Data.List (elemIndex, sort)
-- >>> import Data.Tree (Tree (..))
-- >>> import Data.Map (Map)
-- >>> import Data.Set (Set)
-- >>> import qualified Data.Tree as T
-- >>> import qualified Data.Map as Map
-- >>> import qualified Data.Set as Set
--
-- Some compatibility imports
--
  > > > import Control . Applicative
-- >>> import Data.Foldable (traverse_, foldMap)
--
-- Graph used in examples:
--
-- <<dag-original.png>>
--
  > > > let example : : Map  ( Set  ) ; example = Map.map Set.fromList $ Map.fromList [ ( ' a ' , " bxde " ) , ( ' b ' , " d " ) , ( ' x ' , " de " ) , ( 'd ' , " e " ) , ( ' e ' , " " ) ]
--
-- == Few functions to be used in examples
--
-- To make examples slightly shorter:
--
  > > > let fmap2 f = fmap ( fmap f )
-- >>> let fmap3 f = fmap (fmap2 f)
  > > > let  _ f = traverse _ ( traverse _ f )
  > > > let traverse3 _ f = traverse _ (  _ f )
--
-- To display trees:
--
  > > > let dispTree : : Show a = > Tree a - > IO ( ) ; dispTree = go 0 where go i ( T.Node x xs ) = putStrLn ( replicate ( i * 2 ) ' ' + + show x ) > > traverse _ ( go ( succ i ) ) xs
--
-- And fold them (this function is available in recent @containers@):
--
-- >>> let foldTree f = go where go (T.Node x ts) = f x (map go ts)
--

-------------------------------------------------------------------------------
-- Graph
-------------------------------------------------------------------------------

-- | Graph representation.
--
  The ' runG ' creates a @'G ' v i@ structure . Note , that @i@ is kept free ,
-- so you cannot construct `i` which isn't in the `gVertices`.
  Therefore operations , like ` gFromVertex ` are total ( and fast ) .
--
-- === __Properties__
--
  @'gVerticeCount ' g = ' length ' ( ' gVertices ' g)@
--
-- >>> runG example $ \G {..} -> (length gVertices, gVerticeCount)
  Right ( 5,5 )
--
-- @'Just' ('gVertexIndex' g x) = 'elemIndex' x ('gVertices' g)@
--
-- >>> runG example $ \G {..} -> map (`elemIndex` gVertices) gVertices
-- Right [Just 0,Just 1,Just 2,Just 3,Just 4]
--
-- >>> runG example $ \G {..} -> map gVertexIndex gVertices
-- Right [0,1,2,3,4]
--
data G v i = G
    { gVertices     :: [i]             -- ^ all vertices, in topological order.
    , gFromVertex   :: i -> v          -- ^ /O(1)/. retrieve original vertex data
  ^ /O(log n)/.
    , gEdges        :: i -> [i]        -- ^ /O(1)/. Outgoing edges. Note: target indices are larger than source index.
    , gDiff         :: i -> i -> Int   -- ^ /O(1)/. Upper bound of the path length. Negative means there aren't path.
  ^ /O(1)/. @'gVerticeCount ' g = ' length ' ( ' gVertices ' g)@
    , gVertexIndex  :: i -> Int        -- ^ /O(1)/. @'Just' ('verticeIndex' g x) = 'elemIndex' x ('gVertices' g)@. Note, there are no efficient way to convert 'Int' into 'i', conversion back and forth is discouraged on purpose.
    }

-- | Run action on topologically sorted representation of the graph.
--
-- === __Examples__
--
-- ==== Topological sorting
--
-- >>> runG example $ \G {..} -> map gFromVertex gVertices
-- Right "axbde"
--
-- Vertices are sorted
--
  > > > runG example $ \G { .. } - > map gFromVertex $ sort gVertices
-- Right "axbde"
--
-- ==== Outgoing edges
--
-- >>> runG example $ \G {..} -> map (map gFromVertex . gEdges) gVertices
-- Right ["xbde","de","d","e",""]
--
-- Note: target indices are always larger than source vertex' index:
--
  > > > runG example $ \G { .. } - > getAll $ foldMap ( \a - > foldMap ( \b - > All ( a < b ) ) ( gEdges a ) ) gVertices
-- Right True
--
  = = = = Not DAG
--
  > > > let loop = Map.map Set.fromList $ Map.fromList [ ( ' a ' , " bx " ) , ( ' b ' , " cx " ) , ( ' c ' , " ax " ) , ( ' x ' , " " ) ]
-- >>> runG loop $ \G {..} -> map gFromVertex gVertices
  Left " abc "
--
  > > > runG ( Map.singleton ' a ' ( Set.singleton ' a ' ) ) $ \G { .. } - > map gFromVertex gVertices
-- Left "aa"
--
runG
    :: forall v r. Ord v
    => Map v (Set v)                    -- ^ Adjacency Map
    -> (forall i. Ord i => G v i -> r)  -- ^ function on linear indices
    -> Either [v] r                     -- ^ Return the result or a cycle in the graph.
runG m f
    | Just l <- loop = Left (map (indices V.!) l)
    | otherwise      = Right (f g)
  where
    gr :: G.Graph
    r  :: G.Vertex -> ((), v, [v])
    _t  :: v -> Maybe G.Vertex

    (gr, r, _t) = G.graphFromEdges [ ((), v, Set.toAscList us) | (v, us) <- Map.toAscList m ]

    r' :: G.Vertex -> v
    r' i = case r i of (_, v, _) -> v

    topo :: [G.Vertex]
    topo = G.topSort gr

    indices :: V.Vector v
    indices = V.fromList (map r' topo)

    revIndices :: Map v Int
    revIndices = Map.fromList $ zip (map r' topo) [0..]

    edges :: V.Vector [Int]
    edges = V.map
        (\v -> maybe
            []
            (\sv -> sort $ mapMaybe (\v' -> Map.lookup v' revIndices) $ Set.toList sv)
            (Map.lookup v m))
        indices

    -- TODO: let's see if this check is too expensive
    loop :: Maybe [Int]
    loop = getFirst $ foldMap (\a -> foldMap (check a) (gEdges g a)) (gVertices g)
      where
        check a b
            | a < b     = First Nothing
            -- TODO: here we could use shortest path
            | otherwise = First $ case allPaths g b a of
                []      -> Nothing
                (p : _) -> Just p

    g :: G v Int
    g = G
        { gVertices     = [0 .. V.length indices - 1]
        , gFromVertex   = (indices V.!)
        , gToVertex     = (`Map.lookup` revIndices)
        , gDiff         = \a b -> b - a
        , gEdges        = (edges V.!)
        , gVerticeCount = V.length indices
        , gVertexIndex  = id
        }

-- | Like 'runG' but returns 'Maybe'
runG'
    :: forall v r. Ord v
    => Map v (Set v)                    -- ^ Adjacency Map
    -> (forall i. Ord i => G v i -> r)  -- ^ function on linear indices
    -> Maybe r                          -- ^ Return the result or 'Nothing' if there is a cycle.
runG' m f = either (const Nothing) Just (runG m f)

-------------------------------------------------------------------------------
-- All paths
-------------------------------------------------------------------------------

  | All paths from @a@ to @b@. Note that every path has at least 2 elements , start and end .
  Use ' allPaths '' for the intermediate steps only .
--
-- See 'dfs', which returns all paths starting at some vertice.
-- This function returns paths with specified start and end vertices.
--
-- >>> runG example $ \g@G{..} -> fmap3 gFromVertex $ allPaths g <$> gToVertex 'a' <*> gToVertex 'e'
-- Right (Just ["axde","axe","abde","ade","ae"])
--
-- There are no paths from element to itself:
--
-- >>> runG example $ \g@G{..} -> fmap3 gFromVertex $ allPaths g <$> gToVertex 'a' <*> gToVertex 'a'
-- Right (Just [])
--
allPaths :: forall v i. Ord i => G v i -> i -> i -> [[i]]
allPaths g a b = map (\p -> a : p) (allPaths' g a b [b])

  | ' allPaths ' without begin and end elements .
--
  > > > runG example $ \g@G { .. } - > fmap3 gFromVertex $ allPaths ' g < $ > gToVertex ' a ' < * > gToVertex ' e ' < * > pure [ ]
-- Right (Just ["xd","x","bd","d",""])
--
allPaths' :: forall v i. Ord i => G v i -> i -> i -> [i] -> [[i]]
allPaths' G {..} a b end = concatMap go (gEdges a) where
    go :: i -> [[i]]
    go i
        | i == b    = [end]
        | otherwise =
            let js :: [i]
                js = filter (<= b) $ gEdges i

                js2b :: [[i]]
                js2b = concatMap go js

            in map (i:) js2b

  | Like ' allPaths ' but return a ' T.Tree ' .
  All paths from @a@ to @b@. Note that every path has at least 2 elements , start and end ,
--
  Unfortunately , this is the same as @'dfs ' g \<$ > ' gToVertex ' \'a\'@ ,
-- as in our example graph, all paths from @\'a\'@ end up in @\'e\'@.
--
-- <<dag-tree.png>>
--
-- >>> let t = runG example $ \g@G{..} -> fmap3 gFromVertex $ allPathsTree g <$> gToVertex 'a' <*> gToVertex 'e'
-- >>> fmap3 (foldTree $ \a bs -> if null bs then [[a]] else concatMap (map (a:)) bs) t
-- Right (Just (Just ["axde","axe","abde","ade","ae"]))
--
  > > > fmap3 ( Set.fromList . treePairs ) t
-- Right (Just (Just (fromList [('a','b'),('a','d'),('a','e'),('a','x'),('b','d'),('d','e'),('x','d'),('x','e')])))
--
-- >>> let ls = runG example $ \g@G{..} -> fmap3 gFromVertex $ allPaths g <$> gToVertex 'a' <*> gToVertex 'e'
  > > > fmap2 ( Set.fromList . concatMap pairs ) ls
-- Right (Just (fromList [('a','b'),('a','d'),('a','e'),('a','x'),('b','d'),('d','e'),('x','d'),('x','e')]))
--
-- 'Tree' paths show how one can explore the paths.
--
-- >>> traverse3_ dispTree t
-- 'a'
--   'x'
--     'd'
--       'e'
--     'e'
--   'b'
--     'd'
--       'e'
--   'd'
--     'e'
--   'e'
--
-- >>> traverse3_ (putStrLn . T.drawTree . fmap show) t
-- 'a'
-- |
-- +- 'x'
-- |  |
-- |  +- 'd'
-- |  |  |
-- |  |  `- 'e'
-- |  |
-- |  `- 'e'
-- ...
--
-- There are no paths from element to itself, but we'll return a
-- single root node, as 'Tree' cannot be empty.
--
-- >>> runG example $ \g@G{..} -> fmap3 gFromVertex $ allPathsTree g <$> gToVertex 'a' <*> gToVertex 'a'
  Right ( Just ( Just ( Node { rootLabel = ' a ' ,  = [ ] } ) ) )
--
allPathsTree :: forall v i. Ord i => G v i -> i -> i -> Maybe (T.Tree i)
allPathsTree G {..} a b = go a where
    go :: i -> Maybe (T.Tree i)
    go i
        | i == b    = Just (T.Node b [])
        | otherwise = case mapMaybe go $ filter (<= b) $ gEdges i of
            [] -> Nothing
            js -> Just (T.Node i js)

-------------------------------------------------------------------------------
-- DFS
-------------------------------------------------------------------------------

-- | Depth-first paths starting at a vertex.
--
  > > > runG example $ \g@G { .. } - > fmap3 gFromVertex $ dfs g < $ > gToVertex ' x '
-- Right (Just ["xde","xe"])
--
dfs :: forall v i. Ord i => G v i -> i -> [[i]]
dfs G {..} = go where
    go :: i -> [[i]]
    go a = case gEdges a of
        [] -> [[a]]
        bs -> concatMap (\b -> map (a :) (go b)) bs

-- | like 'dfs' but returns a 'T.Tree'.
--
  > > >  _ dispTree $ runG example $ \g@G { .. } - > fmap2 gFromVertex $ dfsTree g < $ > gToVertex ' x '
-- 'x'
--   'd'
--     'e'
--   'e'
--
dfsTree :: forall v i. Ord i => G v i -> i -> T.Tree i
dfsTree G {..} = go where
    go :: i -> T.Tree i
    go a = case gEdges a of
        [] -> T.Node a []
        bs -> T.Node a $ map go bs

-------------------------------------------------------------------------------
  Longest / shortest path
-------------------------------------------------------------------------------

-- | Shortest paths lengths starting from a vertex.
-- The resulting list is of the same length as 'gVertices'.
-- It's quite efficient to compute all shortest (or longest) paths' lengths
  at once . Zero means that there are no path .
--
-- >>> runG example $ \g@G{..} -> shortestPathLengths g <$> gToVertex 'a'
  Right ( Just [ 0,1,1,1,1 ] )
--
-- >>> runG example $ \g@G{..} -> shortestPathLengths g <$> gToVertex 'b'
-- Right (Just [0,0,0,1,2])
--
shortestPathLengths :: Ord i => G v i -> i -> [Int]
shortestPathLengths = pathLenghtsImpl min' where
    min' 0 y = y
    min' x y = min x y

-- | Longest paths lengths starting from a vertex.
-- The resulting list is of the same length as 'gVertices'.
--
-- >>> runG example $ \g@G{..} -> longestPathLengths g <$> gToVertex 'a'
-- Right (Just [0,1,1,2,3])
--
-- >>> runG example $ \G {..} -> map gFromVertex gVertices
-- Right "axbde"
--
-- >>> runG example $ \g@G{..} -> longestPathLengths g <$> gToVertex 'b'
-- Right (Just [0,0,0,1,2])
--
longestPathLengths :: Ord i => G v i -> i -> [Int]
longestPathLengths = pathLenghtsImpl max

pathLenghtsImpl :: forall v i. Ord i => (Int -> Int -> Int) -> G v i -> i -> [Int]
pathLenghtsImpl merge G {..} a = runST $ do
    v <- MU.replicate (length gVertices) (0 :: Int)
    go v (Set.singleton a)
    v' <- U.freeze v
    pure (U.toList v')
  where
    go :: MU.MVector s Int -> Set i -> ST s ()
    go v xs = do
        case Set.minView xs of
            Nothing       -> pure ()
            Just (x, xs') -> do
                c <- MU.unsafeRead v (gVertexIndex x)
                let ys = Set.fromList $ gEdges x
                for_ ys $ \y ->
                    flip (MU.unsafeModify v) (gVertexIndex y) $ \d -> merge d (c + 1)
                go v (xs' `Set.union` ys)

-------------------------------------------------------------------------------
  Transpose
-------------------------------------------------------------------------------

-- | Graph with all edges reversed.
--
-- <<dag-transpose.png>>
--
-- >>> runG example $ adjacencyList . transpose
-- Right [('a',""),('b',"a"),('d',"abx"),('e',"adx"),('x',"a")]
--
-- === __Properties__
--
  Commutes with ' closure '
--
-- >>> runG example $ adjacencyList . closure . transpose
-- Right [('a',""),('b',"a"),('d',"abx"),('e',"abdx"),('x',"a")]
--
-- >>> runG example $ adjacencyList . transpose . closure
-- Right [('a',""),('b',"a"),('d',"abx"),('e',"abdx"),('x',"a")]
--
  Commutes with ' reduction '
--
-- >>> runG example $ adjacencyList . reduction . transpose
-- Right [('a',""),('b',"a"),('d',"bx"),('e',"d"),('x',"a")]
--
-- >>> runG example $ adjacencyList . transpose . reduction
-- Right [('a',""),('b',"a"),('d',"bx"),('e',"d"),('x',"a")]
--
transpose :: forall v i. Ord i => G v i -> G v (Down i)
transpose G {..} = G
    { gVertices     = map Down $ reverse gVertices
    , gFromVertex   = gFromVertex . getDown
    , gToVertex     = fmap Down . gToVertex
    , gEdges        = gEdges'
    , gDiff         = \(Down a) (Down b) -> gDiff b a
    , gVerticeCount = gVerticeCount
    , gVertexIndex  = \(Down a) -> gVerticeCount - gVertexIndex a - 1
    }
  where
    gEdges' :: Down i -> [Down i]
    gEdges' (Down a) = es V.! gVertexIndex a

    -- Note: in original order!
    es :: V.Vector [Down i]
    es = V.fromList $ map (map Down . revEdges) gVertices

    revEdges :: i -> [i]
    revEdges x = concatMap (\y -> [y | x `elem` gEdges y ]) gVertices


-------------------------------------------------------------------------------
-- Reduction
-------------------------------------------------------------------------------

-- | Transitive reduction.
--
-- Smallest graph,
-- such that if there is a path from /u/ to /v/ in the original graph,
-- then there is also such a path in the reduction.
--
-- The green edges are not in the transitive reduction:
--
-- <<dag-reduction.png>>
--
  > > > runG example $ \g - > adjacencyList $ reduction g
-- Right [('a',"bx"),('b',"d"),('d',"e"),('e',""),('x',"d")]
--
  Taking closure first does n't matter :
--
  > > > runG example $ \g - > adjacencyList $ reduction $ closure g
-- Right [('a',"bx"),('b',"d"),('d',"e"),('e',""),('x',"d")]
--
reduction :: Ord i => G v i -> G v i
reduction = transitiveImpl (== 1)

-------------------------------------------------------------------------------
-- Closure
-------------------------------------------------------------------------------

-- | Transitive closure.
--
-- A graph,
-- such that if there is a path from /u/ to /v/ in the original graph,
-- then there is an edge from /u/ to /v/ in the closure.
--
-- The purple edge is added in a closure:
--
-- <<dag-closure.png>>
--
  > > > runG example $ \g - > adjacencyList $ closure g
-- Right [('a',"bdex"),('b',"de"),('d',"e"),('e',""),('x',"de")]
--
  Taking reduction first , does n't matter :
--
  > > > runG example $ \g - > adjacencyList $ closure $ reduction g
-- Right [('a',"bdex"),('b',"de"),('d',"e"),('e',""),('x',"de")]
--
closure :: Ord i => G v i -> G v i
closure = transitiveImpl (/= 0)

transitiveImpl :: forall v i. Ord i => (Int -> Bool) -> G v i -> G v i
transitiveImpl pre g@G {..} = g { gEdges = gEdges' } where
    gEdges' :: i -> [i]
    gEdges' a = es V.! gVertexIndex a

    es :: V.Vector [i]
    es = V.fromList $ map f gVertices where
        f :: i -> [i]
        f x = catMaybes $ zipWith edge gVertices (longestPathLengths g x)

        edge y i
            | pre i     = Just y
            | otherwise = Nothing

-------------------------------------------------------------------------------
-- Display
-------------------------------------------------------------------------------

-- | Recover adjacency map representation from the 'G'.
--
-- >>> runG example adjacencyMap
-- Right (fromList [('a',fromList "bdex"),('b',fromList "d"),('d',fromList "e"),('e',fromList ""),('x',fromList "de")])
--
adjacencyMap :: Ord v => G v i -> Map v (Set v)
adjacencyMap G {..} = Map.fromList $ map f gVertices where
    f x = (gFromVertex x, Set.fromList $ map gFromVertex $ gEdges x)

-- | Adjacency list representation of 'G'.
--
-- >>> runG example adjacencyList
-- Right [('a',"bdex"),('b',"d"),('d',"e"),('e',""),('x',"de")]
--
adjacencyList :: Ord v => G v i -> [(v, [v])]
adjacencyList = flattenAM . adjacencyMap

flattenAM :: Map a (Set a) -> [(a, [a])]
flattenAM = map (fmap Set.toList) . Map.toList

-- | Edges set.
--
  > > > runG example $ \g@G { .. } - > map ( \(a , b ) - > [ gFromVertex a , gFromVertex b ] ) $   Set.toList $ edgesSet g
-- Right ["ax","ab","ad","ae","xd","xe","bd","de"]
--
edgesSet :: Ord i => G v i -> Set (i, i)
edgesSet G {..} = Set.fromList
    [ (x, y)
    | x <- gVertices
    , y <- gEdges x
    ]

-------------------------------------------------------------------------------
  Utilities
-------------------------------------------------------------------------------

#if !(MIN_VERSION_base(4,14,0))
-- | Unwrap 'Down'.
getDown :: Down a -> a
getDown (Down a) = a
#endif

-- | Like 'pairs' but for 'T.Tree'.
treePairs :: T.Tree a -> [(a,a)]
treePairs (T.Node i js) =
    [ (i, j) | T.Node j _ <- js ] ++ concatMap treePairs js

-- | Consecutive pairs.
--
  > > > pairs [ 1 .. 10 ]
  [ ( 1,2),(2,3),(3,4),(4,5),(5,6),(6,7),(7,8),(8,9),(9,10 ) ]
--
-- >>> pairs []
-- []
--
pairs :: [a] -> [(a, a)]
pairs [] = []
pairs xs = zip xs (tail xs)

# LANGUAGE RankNTypes          #
# LANGUAGE RecordWildCards     #

 by taking advantage of topological sorting.

 * Graph
 $setup
 * Transpose
 * Transitive reduction
 * Transitive closure
 * DFS
 * All paths
 * Path lengths
 * Query
 * Utilities
-----------------------------------------------------------------------------
 Setup
-----------------------------------------------------------------------------
 $setup

 Initial setup and imports:

 >>> :set -XRecordWildCards
 >>> import Data.Foldable (traverse_)
 >>> import Data.List (elemIndex, sort)
 >>> import Data.Tree (Tree (..))
 >>> import Data.Map (Map)
 >>> import Data.Set (Set)
 >>> import qualified Data.Tree as T
 >>> import qualified Data.Map as Map
 >>> import qualified Data.Set as Set

 Some compatibility imports

 >>> import Data.Foldable (traverse_, foldMap)

 Graph used in examples:

 <<dag-original.png>>


 == Few functions to be used in examples

 To make examples slightly shorter:

 >>> let fmap3 f = fmap (fmap2 f)

 To display trees:


 And fold them (this function is available in recent @containers@):

 >>> let foldTree f = go where go (T.Node x ts) = f x (map go ts)

-----------------------------------------------------------------------------
 Graph
-----------------------------------------------------------------------------
 | Graph representation.

 so you cannot construct `i` which isn't in the `gVertices`.

 === __Properties__


 >>> runG example $ \G {..} -> (length gVertices, gVerticeCount)

 @'Just' ('gVertexIndex' g x) = 'elemIndex' x ('gVertices' g)@

 >>> runG example $ \G {..} -> map (`elemIndex` gVertices) gVertices
 Right [Just 0,Just 1,Just 2,Just 3,Just 4]

 >>> runG example $ \G {..} -> map gVertexIndex gVertices
 Right [0,1,2,3,4]

 ^ all vertices, in topological order.
 ^ /O(1)/. retrieve original vertex data
 ^ /O(1)/. Outgoing edges. Note: target indices are larger than source index.
 ^ /O(1)/. Upper bound of the path length. Negative means there aren't path.
 ^ /O(1)/. @'Just' ('verticeIndex' g x) = 'elemIndex' x ('gVertices' g)@. Note, there are no efficient way to convert 'Int' into 'i', conversion back and forth is discouraged on purpose.
 | Run action on topologically sorted representation of the graph.

 === __Examples__

 ==== Topological sorting

 >>> runG example $ \G {..} -> map gFromVertex gVertices
 Right "axbde"

 Vertices are sorted

 Right "axbde"

 ==== Outgoing edges

 >>> runG example $ \G {..} -> map (map gFromVertex . gEdges) gVertices
 Right ["xbde","de","d","e",""]

 Note: target indices are always larger than source vertex' index:

 Right True


 >>> runG loop $ \G {..} -> map gFromVertex gVertices

 Left "aa"

 ^ Adjacency Map
 ^ function on linear indices
 ^ Return the result or a cycle in the graph.
 TODO: let's see if this check is too expensive
 TODO: here we could use shortest path
 | Like 'runG' but returns 'Maybe'
 ^ Adjacency Map
 ^ function on linear indices
 ^ Return the result or 'Nothing' if there is a cycle.
-----------------------------------------------------------------------------
 All paths
-----------------------------------------------------------------------------

 See 'dfs', which returns all paths starting at some vertice.
 This function returns paths with specified start and end vertices.

 >>> runG example $ \g@G{..} -> fmap3 gFromVertex $ allPaths g <$> gToVertex 'a' <*> gToVertex 'e'
 Right (Just ["axde","axe","abde","ade","ae"])

 There are no paths from element to itself:

 >>> runG example $ \g@G{..} -> fmap3 gFromVertex $ allPaths g <$> gToVertex 'a' <*> gToVertex 'a'
 Right (Just [])


 Right (Just ["xd","x","bd","d",""])


 as in our example graph, all paths from @\'a\'@ end up in @\'e\'@.

 <<dag-tree.png>>

 >>> let t = runG example $ \g@G{..} -> fmap3 gFromVertex $ allPathsTree g <$> gToVertex 'a' <*> gToVertex 'e'
 >>> fmap3 (foldTree $ \a bs -> if null bs then [[a]] else concatMap (map (a:)) bs) t
 Right (Just (Just ["axde","axe","abde","ade","ae"]))

 Right (Just (Just (fromList [('a','b'),('a','d'),('a','e'),('a','x'),('b','d'),('d','e'),('x','d'),('x','e')])))

 >>> let ls = runG example $ \g@G{..} -> fmap3 gFromVertex $ allPaths g <$> gToVertex 'a' <*> gToVertex 'e'
 Right (Just (fromList [('a','b'),('a','d'),('a','e'),('a','x'),('b','d'),('d','e'),('x','d'),('x','e')]))

 'Tree' paths show how one can explore the paths.

 >>> traverse3_ dispTree t
 'a'
   'x'
     'd'
       'e'
     'e'
   'b'
     'd'
       'e'
   'd'
     'e'
   'e'

 >>> traverse3_ (putStrLn . T.drawTree . fmap show) t
 'a'
 |
 +- 'x'
 |  |
 |  +- 'd'
 |  |  |
 |  |  `- 'e'
 |  |
 |  `- 'e'
 ...

 There are no paths from element to itself, but we'll return a
 single root node, as 'Tree' cannot be empty.

 >>> runG example $ \g@G{..} -> fmap3 gFromVertex $ allPathsTree g <$> gToVertex 'a' <*> gToVertex 'a'

-----------------------------------------------------------------------------
 DFS
-----------------------------------------------------------------------------
 | Depth-first paths starting at a vertex.

 Right (Just ["xde","xe"])

 | like 'dfs' but returns a 'T.Tree'.

 'x'
   'd'
     'e'
   'e'

-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
 | Shortest paths lengths starting from a vertex.
 The resulting list is of the same length as 'gVertices'.
 It's quite efficient to compute all shortest (or longest) paths' lengths

 >>> runG example $ \g@G{..} -> shortestPathLengths g <$> gToVertex 'a'

 >>> runG example $ \g@G{..} -> shortestPathLengths g <$> gToVertex 'b'
 Right (Just [0,0,0,1,2])

 | Longest paths lengths starting from a vertex.
 The resulting list is of the same length as 'gVertices'.

 >>> runG example $ \g@G{..} -> longestPathLengths g <$> gToVertex 'a'
 Right (Just [0,1,1,2,3])

 >>> runG example $ \G {..} -> map gFromVertex gVertices
 Right "axbde"

 >>> runG example $ \g@G{..} -> longestPathLengths g <$> gToVertex 'b'
 Right (Just [0,0,0,1,2])

-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
 | Graph with all edges reversed.

 <<dag-transpose.png>>

 >>> runG example $ adjacencyList . transpose
 Right [('a',""),('b',"a"),('d',"abx"),('e',"adx"),('x',"a")]

 === __Properties__


 >>> runG example $ adjacencyList . closure . transpose
 Right [('a',""),('b',"a"),('d',"abx"),('e',"abdx"),('x',"a")]

 >>> runG example $ adjacencyList . transpose . closure
 Right [('a',""),('b',"a"),('d',"abx"),('e',"abdx"),('x',"a")]


 >>> runG example $ adjacencyList . reduction . transpose
 Right [('a',""),('b',"a"),('d',"bx"),('e',"d"),('x',"a")]

 >>> runG example $ adjacencyList . transpose . reduction
 Right [('a',""),('b',"a"),('d',"bx"),('e',"d"),('x',"a")]

 Note: in original order!
-----------------------------------------------------------------------------
 Reduction
-----------------------------------------------------------------------------
 | Transitive reduction.

 Smallest graph,
 such that if there is a path from /u/ to /v/ in the original graph,
 then there is also such a path in the reduction.

 The green edges are not in the transitive reduction:

 <<dag-reduction.png>>

 Right [('a',"bx"),('b',"d"),('d',"e"),('e',""),('x',"d")]


 Right [('a',"bx"),('b',"d"),('d',"e"),('e',""),('x',"d")]

-----------------------------------------------------------------------------
 Closure
-----------------------------------------------------------------------------
 | Transitive closure.

 A graph,
 such that if there is a path from /u/ to /v/ in the original graph,
 then there is an edge from /u/ to /v/ in the closure.

 The purple edge is added in a closure:

 <<dag-closure.png>>

 Right [('a',"bdex"),('b',"de"),('d',"e"),('e',""),('x',"de")]


 Right [('a',"bdex"),('b',"de"),('d',"e"),('e',""),('x',"de")]

-----------------------------------------------------------------------------
 Display
-----------------------------------------------------------------------------
 | Recover adjacency map representation from the 'G'.

 >>> runG example adjacencyMap
 Right (fromList [('a',fromList "bdex"),('b',fromList "d"),('d',fromList "e"),('e',fromList ""),('x',fromList "de")])

 | Adjacency list representation of 'G'.

 >>> runG example adjacencyList
 Right [('a',"bdex"),('b',"d"),('d',"e"),('e',""),('x',"de")]

 | Edges set.

 Right ["ax","ab","ad","ae","xd","xe","bd","de"]

-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
 | Unwrap 'Down'.
 | Like 'pairs' but for 'T.Tree'.
 | Consecutive pairs.


 >>> pairs []
 []

# LANGUAGE CPP #
# LANGUAGE ScopedTypeVariables #
  | Copyright : ( c ) 2018 ,  
  SPDX - License - Identifier : BSD-3 - Clause
  Tools to work with Directed Acyclic Graphs ,
module Topograph (

    G (..),
    runG,
    runG',
    transpose,
    reduction,
    closure,
    dfs,
    dfsTree,
    allPaths,
    allPaths',
    allPathsTree,
    shortestPathLengths,
    longestPathLengths,
    edgesSet,
    adjacencyMap,
    adjacencyList,
    pairs,
    treePairs,
    ) where

import Data.Orphans ()
import Prelude ()
import Prelude.Compat

import Control.Monad.ST (ST, runST)
import Data.Foldable    (for_)
import Data.List        (sort)
import Data.Map         (Map)
import Data.Maybe       (catMaybes, mapMaybe)
import Data.Monoid      (First (..))
import Data.Ord         (Down (..))
import Data.Set         (Set)

import qualified Data.Graph                  as G
import qualified Data.Map                    as Map
import qualified Data.Set                    as Set
import qualified Data.Tree                   as T
import qualified Data.Vector                 as V
import qualified Data.Vector.Unboxed         as U
import qualified Data.Vector.Unboxed.Mutable as MU


  > > > import Data . Monoid ( All ( .. ) )
  > > > import Control . Applicative
  > > > let example : : Map  ( Set  ) ; example = Map.map Set.fromList $ Map.fromList [ ( ' a ' , " bxde " ) , ( ' b ' , " d " ) , ( ' x ' , " de " ) , ( 'd ' , " e " ) , ( ' e ' , " " ) ]
  > > > let fmap2 f = fmap ( fmap f )
  > > > let  _ f = traverse _ ( traverse _ f )
  > > > let traverse3 _ f = traverse _ (  _ f )
  > > > let dispTree : : Show a = > Tree a - > IO ( ) ; dispTree = go 0 where go i ( T.Node x xs ) = putStrLn ( replicate ( i * 2 ) ' ' + + show x ) > > traverse _ ( go ( succ i ) ) xs


  The ' runG ' creates a @'G ' v i@ structure . Note , that @i@ is kept free ,
  Therefore operations , like ` gFromVertex ` are total ( and fast ) .
  @'gVerticeCount ' g = ' length ' ( ' gVertices ' g)@
  Right ( 5,5 )
data G v i = G
  ^ /O(log n)/.
  ^ /O(1)/. @'gVerticeCount ' g = ' length ' ( ' gVertices ' g)@
    }

  > > > runG example $ \G { .. } - > map gFromVertex $ sort gVertices
  > > > runG example $ \G { .. } - > getAll $ foldMap ( \a - > foldMap ( \b - > All ( a < b ) ) ( gEdges a ) ) gVertices
  = = = = Not DAG
  > > > let loop = Map.map Set.fromList $ Map.fromList [ ( ' a ' , " bx " ) , ( ' b ' , " cx " ) , ( ' c ' , " ax " ) , ( ' x ' , " " ) ]
  Left " abc "
  > > > runG ( Map.singleton ' a ' ( Set.singleton ' a ' ) ) $ \G { .. } - > map gFromVertex gVertices
runG
    :: forall v r. Ord v
runG m f
    | Just l <- loop = Left (map (indices V.!) l)
    | otherwise      = Right (f g)
  where
    gr :: G.Graph
    r  :: G.Vertex -> ((), v, [v])
    _t  :: v -> Maybe G.Vertex

    (gr, r, _t) = G.graphFromEdges [ ((), v, Set.toAscList us) | (v, us) <- Map.toAscList m ]

    r' :: G.Vertex -> v
    r' i = case r i of (_, v, _) -> v

    topo :: [G.Vertex]
    topo = G.topSort gr

    indices :: V.Vector v
    indices = V.fromList (map r' topo)

    revIndices :: Map v Int
    revIndices = Map.fromList $ zip (map r' topo) [0..]

    edges :: V.Vector [Int]
    edges = V.map
        (\v -> maybe
            []
            (\sv -> sort $ mapMaybe (\v' -> Map.lookup v' revIndices) $ Set.toList sv)
            (Map.lookup v m))
        indices

    loop :: Maybe [Int]
    loop = getFirst $ foldMap (\a -> foldMap (check a) (gEdges g a)) (gVertices g)
      where
        check a b
            | a < b     = First Nothing
            | otherwise = First $ case allPaths g b a of
                []      -> Nothing
                (p : _) -> Just p

    g :: G v Int
    g = G
        { gVertices     = [0 .. V.length indices - 1]
        , gFromVertex   = (indices V.!)
        , gToVertex     = (`Map.lookup` revIndices)
        , gDiff         = \a b -> b - a
        , gEdges        = (edges V.!)
        , gVerticeCount = V.length indices
        , gVertexIndex  = id
        }

runG'
    :: forall v r. Ord v
runG' m f = either (const Nothing) Just (runG m f)


  | All paths from @a@ to @b@. Note that every path has at least 2 elements , start and end .
  Use ' allPaths '' for the intermediate steps only .
allPaths :: forall v i. Ord i => G v i -> i -> i -> [[i]]
allPaths g a b = map (\p -> a : p) (allPaths' g a b [b])

  | ' allPaths ' without begin and end elements .
  > > > runG example $ \g@G { .. } - > fmap3 gFromVertex $ allPaths ' g < $ > gToVertex ' a ' < * > gToVertex ' e ' < * > pure [ ]
allPaths' :: forall v i. Ord i => G v i -> i -> i -> [i] -> [[i]]
allPaths' G {..} a b end = concatMap go (gEdges a) where
    go :: i -> [[i]]
    go i
        | i == b    = [end]
        | otherwise =
            let js :: [i]
                js = filter (<= b) $ gEdges i

                js2b :: [[i]]
                js2b = concatMap go js

            in map (i:) js2b

  | Like ' allPaths ' but return a ' T.Tree ' .
  All paths from @a@ to @b@. Note that every path has at least 2 elements , start and end ,
  Unfortunately , this is the same as @'dfs ' g \<$ > ' gToVertex ' \'a\'@ ,
  > > > fmap3 ( Set.fromList . treePairs ) t
  > > > fmap2 ( Set.fromList . concatMap pairs ) ls
  Right ( Just ( Just ( Node { rootLabel = ' a ' ,  = [ ] } ) ) )
allPathsTree :: forall v i. Ord i => G v i -> i -> i -> Maybe (T.Tree i)
allPathsTree G {..} a b = go a where
    go :: i -> Maybe (T.Tree i)
    go i
        | i == b    = Just (T.Node b [])
        | otherwise = case mapMaybe go $ filter (<= b) $ gEdges i of
            [] -> Nothing
            js -> Just (T.Node i js)


  > > > runG example $ \g@G { .. } - > fmap3 gFromVertex $ dfs g < $ > gToVertex ' x '
dfs :: forall v i. Ord i => G v i -> i -> [[i]]
dfs G {..} = go where
    go :: i -> [[i]]
    go a = case gEdges a of
        [] -> [[a]]
        bs -> concatMap (\b -> map (a :) (go b)) bs

  > > >  _ dispTree $ runG example $ \g@G { .. } - > fmap2 gFromVertex $ dfsTree g < $ > gToVertex ' x '
dfsTree :: forall v i. Ord i => G v i -> i -> T.Tree i
dfsTree G {..} = go where
    go :: i -> T.Tree i
    go a = case gEdges a of
        [] -> T.Node a []
        bs -> T.Node a $ map go bs

  Longest / shortest path

  at once . Zero means that there are no path .
  Right ( Just [ 0,1,1,1,1 ] )
shortestPathLengths :: Ord i => G v i -> i -> [Int]
shortestPathLengths = pathLenghtsImpl min' where
    min' 0 y = y
    min' x y = min x y

longestPathLengths :: Ord i => G v i -> i -> [Int]
longestPathLengths = pathLenghtsImpl max

pathLenghtsImpl :: forall v i. Ord i => (Int -> Int -> Int) -> G v i -> i -> [Int]
pathLenghtsImpl merge G {..} a = runST $ do
    v <- MU.replicate (length gVertices) (0 :: Int)
    go v (Set.singleton a)
    v' <- U.freeze v
    pure (U.toList v')
  where
    go :: MU.MVector s Int -> Set i -> ST s ()
    go v xs = do
        case Set.minView xs of
            Nothing       -> pure ()
            Just (x, xs') -> do
                c <- MU.unsafeRead v (gVertexIndex x)
                let ys = Set.fromList $ gEdges x
                for_ ys $ \y ->
                    flip (MU.unsafeModify v) (gVertexIndex y) $ \d -> merge d (c + 1)
                go v (xs' `Set.union` ys)

  Transpose

  Commutes with ' closure '
  Commutes with ' reduction '
transpose :: forall v i. Ord i => G v i -> G v (Down i)
transpose G {..} = G
    { gVertices     = map Down $ reverse gVertices
    , gFromVertex   = gFromVertex . getDown
    , gToVertex     = fmap Down . gToVertex
    , gEdges        = gEdges'
    , gDiff         = \(Down a) (Down b) -> gDiff b a
    , gVerticeCount = gVerticeCount
    , gVertexIndex  = \(Down a) -> gVerticeCount - gVertexIndex a - 1
    }
  where
    gEdges' :: Down i -> [Down i]
    gEdges' (Down a) = es V.! gVertexIndex a

    es :: V.Vector [Down i]
    es = V.fromList $ map (map Down . revEdges) gVertices

    revEdges :: i -> [i]
    revEdges x = concatMap (\y -> [y | x `elem` gEdges y ]) gVertices



  > > > runG example $ \g - > adjacencyList $ reduction g
  Taking closure first does n't matter :
  > > > runG example $ \g - > adjacencyList $ reduction $ closure g
reduction :: Ord i => G v i -> G v i
reduction = transitiveImpl (== 1)


  > > > runG example $ \g - > adjacencyList $ closure g
  Taking reduction first , does n't matter :
  > > > runG example $ \g - > adjacencyList $ closure $ reduction g
closure :: Ord i => G v i -> G v i
closure = transitiveImpl (/= 0)

transitiveImpl :: forall v i. Ord i => (Int -> Bool) -> G v i -> G v i
transitiveImpl pre g@G {..} = g { gEdges = gEdges' } where
    gEdges' :: i -> [i]
    gEdges' a = es V.! gVertexIndex a

    es :: V.Vector [i]
    es = V.fromList $ map f gVertices where
        f :: i -> [i]
        f x = catMaybes $ zipWith edge gVertices (longestPathLengths g x)

        edge y i
            | pre i     = Just y
            | otherwise = Nothing


adjacencyMap :: Ord v => G v i -> Map v (Set v)
adjacencyMap G {..} = Map.fromList $ map f gVertices where
    f x = (gFromVertex x, Set.fromList $ map gFromVertex $ gEdges x)

adjacencyList :: Ord v => G v i -> [(v, [v])]
adjacencyList = flattenAM . adjacencyMap

flattenAM :: Map a (Set a) -> [(a, [a])]
flattenAM = map (fmap Set.toList) . Map.toList

  > > > runG example $ \g@G { .. } - > map ( \(a , b ) - > [ gFromVertex a , gFromVertex b ] ) $   Set.toList $ edgesSet g
edgesSet :: Ord i => G v i -> Set (i, i)
edgesSet G {..} = Set.fromList
    [ (x, y)
    | x <- gVertices
    , y <- gEdges x
    ]

  Utilities

#if !(MIN_VERSION_base(4,14,0))
getDown :: Down a -> a
getDown (Down a) = a
#endif

treePairs :: T.Tree a -> [(a,a)]
treePairs (T.Node i js) =
    [ (i, j) | T.Node j _ <- js ] ++ concatMap treePairs js

  > > > pairs [ 1 .. 10 ]
  [ ( 1,2),(2,3),(3,4),(4,5),(5,6),(6,7),(7,8),(8,9),(9,10 ) ]
pairs :: [a] -> [(a, a)]
pairs [] = []
pairs xs = zip xs (tail xs)
