{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Copyright: (c) 2018, Oleg Grenrus
-- 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 Char (Set Char); 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 traverse2_ f = traverse_ (traverse_ f)
-- >>> let traverse3_ f = traverse_ (traverse2_ 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
    { G v i -> [i]
gVertices     :: [i]             -- ^ all vertices, in topological order.
    , G v i -> i -> v
gFromVertex   :: i -> v          -- ^ /O(1)/. retrieve original vertex data
    , G v i -> v -> Maybe i
gToVertex     :: v -> Maybe i    -- ^ /O(log n)/.
    , G v i -> i -> [i]
gEdges        :: i -> [i]        -- ^ /O(1)/. Outgoing edges. Note: target indices are larger than source index.
    , G v i -> i -> i -> Int
gDiff         :: i -> i -> Int   -- ^ /O(1)/. Upper bound of the path length. Negative means there aren't path.
    , G v i -> Int
gVerticeCount :: Int             -- ^ /O(1)/. @'gVerticeCount' g = 'length' ('gVertices' g)@
    , G v i -> i -> Int
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 :: Map v (Set v) -> (forall i. Ord i => G v i -> r) -> Either [v] r
runG Map v (Set v)
m forall i. Ord i => G v i -> r
f
    | Just [Int]
l <- Maybe [Int]
loop = [v] -> Either [v] r
forall a b. a -> Either a b
Left ((Int -> v) -> [Int] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (Vector v
indices Vector v -> Int -> v
forall a. Vector a -> Int -> a
V.!) [Int]
l)
    | Bool
otherwise      = r -> Either [v] r
forall a b. b -> Either a b
Right (G v Int -> r
forall i. Ord i => G v i -> r
f G v Int
g)
  where
    gr :: G.Graph
    r  :: G.Vertex -> ((), v, [v])
    _t  :: v -> Maybe G.Vertex

    (Graph
gr, Int -> ((), v, [v])
r, v -> Maybe Int
_t) = [((), v, [v])] -> (Graph, Int -> ((), v, [v]), v -> Maybe Int)
forall key node.
Ord key =>
[(node, key, [key])]
-> (Graph, Int -> (node, key, [key]), key -> Maybe Int)
G.graphFromEdges [ ((), v
v, Set v -> [v]
forall a. Set a -> [a]
Set.toAscList Set v
us) | (v
v, Set v
us) <- Map v (Set v) -> [(v, Set v)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map v (Set v)
m ]

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

    topo :: [G.Vertex]
    topo :: [Int]
topo = Graph -> [Int]
G.topSort Graph
gr

    indices :: V.Vector v
    indices :: Vector v
indices = [v] -> Vector v
forall a. [a] -> Vector a
V.fromList ((Int -> v) -> [Int] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map Int -> v
r' [Int]
topo)

    revIndices :: Map v Int
    revIndices :: Map v Int
revIndices = [(v, Int)] -> Map v Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(v, Int)] -> Map v Int) -> [(v, Int)] -> Map v Int
forall a b. (a -> b) -> a -> b
$ [v] -> [Int] -> [(v, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Int -> v) -> [Int] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map Int -> v
r' [Int]
topo) [Int
0..]

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

    -- TODO: let's see if this check is too expensive
    loop :: Maybe [Int]
    loop :: Maybe [Int]
loop = First [Int] -> Maybe [Int]
forall a. First a -> Maybe a
getFirst (First [Int] -> Maybe [Int]) -> First [Int] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ (Int -> First [Int]) -> [Int] -> First [Int]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Int
a -> (Int -> First [Int]) -> [Int] -> First [Int]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int -> Int -> First [Int]
check Int
a) (G v Int -> Int -> [Int]
forall v i. G v i -> i -> [i]
gEdges G v Int
g Int
a)) (G v Int -> [Int]
forall v i. G v i -> [i]
gVertices G v Int
g)
      where
        check :: Int -> Int -> First [Int]
check Int
a Int
b
            | Int
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
b     = Maybe [Int] -> First [Int]
forall a. Maybe a -> First a
First Maybe [Int]
forall a. Maybe a
Nothing
            -- TODO: here we could use shortest path
            | Bool
otherwise = Maybe [Int] -> First [Int]
forall a. Maybe a -> First a
First (Maybe [Int] -> First [Int]) -> Maybe [Int] -> First [Int]
forall a b. (a -> b) -> a -> b
$ case G v Int -> Int -> Int -> [[Int]]
forall v i. Ord i => G v i -> i -> i -> [[i]]
allPaths G v Int
g Int
b Int
a of
                []      -> Maybe [Int]
forall a. Maybe a
Nothing
                ([Int]
p : [[Int]]
_) -> [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just [Int]
p

    g :: G v Int
    g :: G v Int
g = G :: forall v i.
[i]
-> (i -> v)
-> (v -> Maybe i)
-> (i -> [i])
-> (i -> i -> Int)
-> Int
-> (i -> Int)
-> G v i
G
        { gVertices :: [Int]
gVertices     = [Int
0 .. Vector v -> Int
forall a. Vector a -> Int
V.length Vector v
indices Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
        , gFromVertex :: Int -> v
gFromVertex   = (Vector v
indices Vector v -> Int -> v
forall a. Vector a -> Int -> a
V.!)
        , gToVertex :: v -> Maybe Int
gToVertex     = (v -> Map v Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map v Int
revIndices)
        , gDiff :: Int -> Int -> Int
gDiff         = \Int
a Int
b -> Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
a
        , gEdges :: Int -> [Int]
gEdges        = (Vector [Int]
edges Vector [Int] -> Int -> [Int]
forall a. Vector a -> Int -> a
V.!)
        , gVerticeCount :: Int
gVerticeCount = Vector v -> Int
forall a. Vector a -> Int
V.length Vector v
indices
        , gVertexIndex :: Int -> Int
gVertexIndex  = Int -> Int
forall a. a -> a
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' :: Map v (Set v) -> (forall i. Ord i => G v i -> r) -> Maybe r
runG' Map v (Set v)
m forall i. Ord i => G v i -> r
f = ([v] -> Maybe r) -> (r -> Maybe r) -> Either [v] r -> Maybe r
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe r -> [v] -> Maybe r
forall a b. a -> b -> a
const Maybe r
forall a. Maybe a
Nothing) r -> Maybe r
forall a. a -> Maybe a
Just (Map v (Set v) -> (forall i. Ord i => G v i -> r) -> Either [v] r
forall v r.
Ord v =>
Map v (Set v) -> (forall i. Ord i => G v i -> r) -> Either [v] r
runG Map v (Set v)
m forall i. Ord i => G v i -> r
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 v i -> i -> i -> [[i]]
allPaths G v i
g i
a i
b = ([i] -> [i]) -> [[i]] -> [[i]]
forall a b. (a -> b) -> [a] -> [b]
map (\[i]
p -> i
a i -> [i] -> [i]
forall a. a -> [a] -> [a]
: [i]
p) (G v i -> i -> i -> [i] -> [[i]]
forall v i. Ord i => G v i -> i -> i -> [i] -> [[i]]
allPaths' G v i
g i
a i
b [i
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 v i -> i -> i -> [i] -> [[i]]
allPaths' G {Int
[i]
v -> Maybe i
i -> v
i -> Int
i -> [i]
i -> i -> Int
gVertexIndex :: i -> Int
gVerticeCount :: Int
gDiff :: i -> i -> Int
gEdges :: i -> [i]
gToVertex :: v -> Maybe i
gFromVertex :: i -> v
gVertices :: [i]
gVertexIndex :: forall v i. G v i -> i -> Int
gVerticeCount :: forall v i. G v i -> Int
gDiff :: forall v i. G v i -> i -> i -> Int
gEdges :: forall v i. G v i -> i -> [i]
gToVertex :: forall v i. G v i -> v -> Maybe i
gFromVertex :: forall v i. G v i -> i -> v
gVertices :: forall v i. G v i -> [i]
..} i
a i
b [i]
end = (i -> [[i]]) -> [i] -> [[i]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap i -> [[i]]
go (i -> [i]
gEdges i
a) where
    go :: i -> [[i]]
    go :: i -> [[i]]
go i
i
        | i
i i -> i -> Bool
forall a. Eq a => a -> a -> Bool
== i
b    = [[i]
end]
        | Bool
otherwise =
            let js :: [i]
                js :: [i]
js = (i -> Bool) -> [i] -> [i]
forall a. (a -> Bool) -> [a] -> [a]
filter (i -> i -> Bool
forall a. Ord a => a -> a -> Bool
<= i
b) ([i] -> [i]) -> [i] -> [i]
forall a b. (a -> b) -> a -> b
$ i -> [i]
gEdges i
i

                js2b :: [[i]]
                js2b :: [[i]]
js2b = (i -> [[i]]) -> [i] -> [[i]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap i -> [[i]]
go [i]
js

            in ([i] -> [i]) -> [[i]] -> [[i]]
forall a b. (a -> b) -> [a] -> [b]
map (i
ii -> [i] -> [i]
forall a. a -> [a] -> [a]
:) [[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', subForest = []})))
--
allPathsTree :: forall v i. Ord i => G v i -> i -> i -> Maybe (T.Tree i)
allPathsTree :: G v i -> i -> i -> Maybe (Tree i)
allPathsTree G {Int
[i]
v -> Maybe i
i -> v
i -> Int
i -> [i]
i -> i -> Int
gVertexIndex :: i -> Int
gVerticeCount :: Int
gDiff :: i -> i -> Int
gEdges :: i -> [i]
gToVertex :: v -> Maybe i
gFromVertex :: i -> v
gVertices :: [i]
gVertexIndex :: forall v i. G v i -> i -> Int
gVerticeCount :: forall v i. G v i -> Int
gDiff :: forall v i. G v i -> i -> i -> Int
gEdges :: forall v i. G v i -> i -> [i]
gToVertex :: forall v i. G v i -> v -> Maybe i
gFromVertex :: forall v i. G v i -> i -> v
gVertices :: forall v i. G v i -> [i]
..} i
a i
b = i -> Maybe (Tree i)
go i
a where
    go :: i -> Maybe (T.Tree i)
    go :: i -> Maybe (Tree i)
go i
i
        | i
i i -> i -> Bool
forall a. Eq a => a -> a -> Bool
== i
b    = Tree i -> Maybe (Tree i)
forall a. a -> Maybe a
Just (i -> Forest i -> Tree i
forall a. a -> Forest a -> Tree a
T.Node i
b [])
        | Bool
otherwise = case (i -> Maybe (Tree i)) -> [i] -> Forest i
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe i -> Maybe (Tree i)
go ([i] -> Forest i) -> [i] -> Forest i
forall a b. (a -> b) -> a -> b
$ (i -> Bool) -> [i] -> [i]
forall a. (a -> Bool) -> [a] -> [a]
filter (i -> i -> Bool
forall a. Ord a => a -> a -> Bool
<= i
b) ([i] -> [i]) -> [i] -> [i]
forall a b. (a -> b) -> a -> b
$ i -> [i]
gEdges i
i of
            [] -> Maybe (Tree i)
forall a. Maybe a
Nothing
            Forest i
js -> Tree i -> Maybe (Tree i)
forall a. a -> Maybe a
Just (i -> Forest i -> Tree i
forall a. a -> Forest a -> Tree a
T.Node i
i Forest 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 v i -> i -> [[i]]
dfs G {Int
[i]
v -> Maybe i
i -> v
i -> Int
i -> [i]
i -> i -> Int
gVertexIndex :: i -> Int
gVerticeCount :: Int
gDiff :: i -> i -> Int
gEdges :: i -> [i]
gToVertex :: v -> Maybe i
gFromVertex :: i -> v
gVertices :: [i]
gVertexIndex :: forall v i. G v i -> i -> Int
gVerticeCount :: forall v i. G v i -> Int
gDiff :: forall v i. G v i -> i -> i -> Int
gEdges :: forall v i. G v i -> i -> [i]
gToVertex :: forall v i. G v i -> v -> Maybe i
gFromVertex :: forall v i. G v i -> i -> v
gVertices :: forall v i. G v i -> [i]
..} = i -> [[i]]
go where
    go :: i -> [[i]]
    go :: i -> [[i]]
go i
a = case i -> [i]
gEdges i
a of
        [] -> [[i
a]]
        [i]
bs -> (i -> [[i]]) -> [i] -> [[i]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\i
b -> ([i] -> [i]) -> [[i]] -> [[i]]
forall a b. (a -> b) -> [a] -> [b]
map (i
a i -> [i] -> [i]
forall a. a -> [a] -> [a]
:) (i -> [[i]]
go i
b)) [i]
bs

-- | like 'dfs' but returns a 'T.Tree'.
--
-- >>> traverse2_ 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 v i -> i -> Tree i
dfsTree G {Int
[i]
v -> Maybe i
i -> v
i -> Int
i -> [i]
i -> i -> Int
gVertexIndex :: i -> Int
gVerticeCount :: Int
gDiff :: i -> i -> Int
gEdges :: i -> [i]
gToVertex :: v -> Maybe i
gFromVertex :: i -> v
gVertices :: [i]
gVertexIndex :: forall v i. G v i -> i -> Int
gVerticeCount :: forall v i. G v i -> Int
gDiff :: forall v i. G v i -> i -> i -> Int
gEdges :: forall v i. G v i -> i -> [i]
gToVertex :: forall v i. G v i -> v -> Maybe i
gFromVertex :: forall v i. G v i -> i -> v
gVertices :: forall v i. G v i -> [i]
..} = i -> Tree i
go where
    go :: i -> T.Tree i
    go :: i -> Tree i
go i
a = case i -> [i]
gEdges i
a of
        [] -> i -> Forest i -> Tree i
forall a. a -> Forest a -> Tree a
T.Node i
a []
        [i]
bs -> i -> Forest i -> Tree i
forall a. a -> Forest a -> Tree a
T.Node i
a (Forest i -> Tree i) -> Forest i -> Tree i
forall a b. (a -> b) -> a -> b
$ (i -> Tree i) -> [i] -> Forest i
forall a b. (a -> b) -> [a] -> [b]
map i -> Tree i
go [i]
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 :: G v i -> i -> [Int]
shortestPathLengths = (Int -> Int -> Int) -> G v i -> i -> [Int]
forall v i. Ord i => (Int -> Int -> Int) -> G v i -> i -> [Int]
pathLenghtsImpl Int -> Int -> Int
forall a. (Num a, Ord a) => a -> a -> a
min' where
    min' :: a -> a -> a
min' a
0 a
y = a
y
    min' a
x a
y = a -> a -> a
forall a. Ord a => a -> a -> a
min a
x a
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 :: G v i -> i -> [Int]
longestPathLengths = (Int -> Int -> Int) -> G v i -> i -> [Int]
forall v i. Ord i => (Int -> Int -> Int) -> G v i -> i -> [Int]
pathLenghtsImpl Int -> Int -> Int
forall a. Ord a => a -> a -> a
max

pathLenghtsImpl :: forall v i. Ord i => (Int -> Int -> Int) -> G v i -> i -> [Int]
pathLenghtsImpl :: (Int -> Int -> Int) -> G v i -> i -> [Int]
pathLenghtsImpl Int -> Int -> Int
merge G {Int
[i]
v -> Maybe i
i -> v
i -> Int
i -> [i]
i -> i -> Int
gVertexIndex :: i -> Int
gVerticeCount :: Int
gDiff :: i -> i -> Int
gEdges :: i -> [i]
gToVertex :: v -> Maybe i
gFromVertex :: i -> v
gVertices :: [i]
gVertexIndex :: forall v i. G v i -> i -> Int
gVerticeCount :: forall v i. G v i -> Int
gDiff :: forall v i. G v i -> i -> i -> Int
gEdges :: forall v i. G v i -> i -> [i]
gToVertex :: forall v i. G v i -> v -> Maybe i
gFromVertex :: forall v i. G v i -> i -> v
gVertices :: forall v i. G v i -> [i]
..} i
a = (forall s. ST s [Int]) -> [Int]
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s [Int]) -> [Int])
-> (forall s. ST s [Int]) -> [Int]
forall a b. (a -> b) -> a -> b
$ do
    MVector s Int
v <- Int -> Int -> ST s (MVector (PrimState (ST s)) Int)
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
Int -> a -> m (MVector (PrimState m) a)
MU.replicate ([i] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [i]
gVertices) (Int
0 :: Int)
    MVector s Int -> Set i -> ST s ()
forall s. MVector s Int -> Set i -> ST s ()
go MVector s Int
v (i -> Set i
forall a. a -> Set a
Set.singleton i
a)
    Vector Int
v' <- MVector (PrimState (ST s)) Int -> ST s (Vector Int)
forall a (m :: * -> *).
(Unbox a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
U.freeze MVector s Int
MVector (PrimState (ST s)) Int
v
    [Int] -> ST s [Int]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vector Int -> [Int]
forall a. Unbox a => Vector a -> [a]
U.toList Vector Int
v')
  where
    go :: MU.MVector s Int -> Set i -> ST s ()
    go :: MVector s Int -> Set i -> ST s ()
go MVector s Int
v Set i
xs = do
        case Set i -> Maybe (i, Set i)
forall a. Set a -> Maybe (a, Set a)
Set.minView Set i
xs of
            Maybe (i, Set i)
Nothing       -> () -> ST s ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just (i
x, Set i
xs') -> do
                Int
c <- MVector (PrimState (ST s)) Int -> Int -> ST s Int
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
MU.unsafeRead MVector s Int
MVector (PrimState (ST s)) Int
v (i -> Int
gVertexIndex i
x)
                let ys :: Set i
ys = [i] -> Set i
forall a. Ord a => [a] -> Set a
Set.fromList ([i] -> Set i) -> [i] -> Set i
forall a b. (a -> b) -> a -> b
$ i -> [i]
gEdges i
x
                Set i -> (i -> ST s ()) -> ST s ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Set i
ys ((i -> ST s ()) -> ST s ()) -> (i -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \i
y ->
                    ((Int -> Int) -> Int -> ST s ()) -> Int -> (Int -> Int) -> ST s ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (MVector (PrimState (ST s)) Int -> (Int -> Int) -> Int -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> (a -> a) -> Int -> m ()
MU.unsafeModify MVector s Int
MVector (PrimState (ST s)) Int
v) (i -> Int
gVertexIndex i
y) ((Int -> Int) -> ST s ()) -> (Int -> Int) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
d -> Int -> Int -> Int
merge Int
d (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                MVector s Int -> Set i -> ST s ()
forall s. MVector s Int -> Set i -> ST s ()
go MVector s Int
v (Set i
xs' Set i -> Set i -> Set i
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set i
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 v i -> G v (Down i)
transpose G {Int
[i]
v -> Maybe i
i -> v
i -> Int
i -> [i]
i -> i -> Int
gVertexIndex :: i -> Int
gVerticeCount :: Int
gDiff :: i -> i -> Int
gEdges :: i -> [i]
gToVertex :: v -> Maybe i
gFromVertex :: i -> v
gVertices :: [i]
gVertexIndex :: forall v i. G v i -> i -> Int
gVerticeCount :: forall v i. G v i -> Int
gDiff :: forall v i. G v i -> i -> i -> Int
gEdges :: forall v i. G v i -> i -> [i]
gToVertex :: forall v i. G v i -> v -> Maybe i
gFromVertex :: forall v i. G v i -> i -> v
gVertices :: forall v i. G v i -> [i]
..} = G :: forall v i.
[i]
-> (i -> v)
-> (v -> Maybe i)
-> (i -> [i])
-> (i -> i -> Int)
-> Int
-> (i -> Int)
-> G v i
G
    { gVertices :: [Down i]
gVertices     = (i -> Down i) -> [i] -> [Down i]
forall a b. (a -> b) -> [a] -> [b]
map i -> Down i
forall a. a -> Down a
Down ([i] -> [Down i]) -> [i] -> [Down i]
forall a b. (a -> b) -> a -> b
$ [i] -> [i]
forall a. [a] -> [a]
reverse [i]
gVertices
    , gFromVertex :: Down i -> v
gFromVertex   = i -> v
gFromVertex (i -> v) -> (Down i -> i) -> Down i -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Down i -> i
forall a. Down a -> a
getDown
    , gToVertex :: v -> Maybe (Down i)
gToVertex     = (i -> Down i) -> Maybe i -> Maybe (Down i)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap i -> Down i
forall a. a -> Down a
Down (Maybe i -> Maybe (Down i))
-> (v -> Maybe i) -> v -> Maybe (Down i)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Maybe i
gToVertex
    , gEdges :: Down i -> [Down i]
gEdges        = Down i -> [Down i]
gEdges'
    , gDiff :: Down i -> Down i -> Int
gDiff         = \(Down i
a) (Down i
b) -> i -> i -> Int
gDiff i
b i
a
    , gVerticeCount :: Int
gVerticeCount = Int
gVerticeCount
    , gVertexIndex :: Down i -> Int
gVertexIndex  = \(Down i
a) -> Int
gVerticeCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- i -> Int
gVertexIndex i
a Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    }
  where
    gEdges' :: Down i -> [Down i]
    gEdges' :: Down i -> [Down i]
gEdges' (Down i
a) = Vector [Down i]
es Vector [Down i] -> Int -> [Down i]
forall a. Vector a -> Int -> a
V.! i -> Int
gVertexIndex i
a

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

    revEdges :: i -> [i]
    revEdges :: i -> [i]
revEdges i
x = (i -> [i]) -> [i] -> [i]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\i
y -> [i
y | i
x i -> [i] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` i -> [i]
gEdges i
y ]) [i]
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 doesn'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 :: G v i -> G v i
reduction = (Int -> Bool) -> G v i -> G v i
forall v i. Ord i => (Int -> Bool) -> G v i -> G v i
transitiveImpl (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
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, doesn'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 :: G v i -> G v i
closure = (Int -> Bool) -> G v i -> G v i
forall v i. Ord i => (Int -> Bool) -> G v i -> G v i
transitiveImpl (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0)

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

    es :: V.Vector [i]
    es :: Vector [i]
es = [[i]] -> Vector [i]
forall a. [a] -> Vector a
V.fromList ([[i]] -> Vector [i]) -> [[i]] -> Vector [i]
forall a b. (a -> b) -> a -> b
$ (i -> [i]) -> [i] -> [[i]]
forall a b. (a -> b) -> [a] -> [b]
map i -> [i]
f [i]
gVertices where
        f :: i -> [i]
        f :: i -> [i]
f i
x = [Maybe i] -> [i]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe i] -> [i]) -> [Maybe i] -> [i]
forall a b. (a -> b) -> a -> b
$ (i -> Int -> Maybe i) -> [i] -> [Int] -> [Maybe i]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith i -> Int -> Maybe i
forall a. a -> Int -> Maybe a
edge [i]
gVertices (G v i -> i -> [Int]
forall i v. Ord i => G v i -> i -> [Int]
longestPathLengths G v i
g i
x)

        edge :: a -> Int -> Maybe a
edge a
y Int
i
            | Int -> Bool
pre Int
i     = a -> Maybe a
forall a. a -> Maybe a
Just a
y
            | Bool
otherwise = Maybe a
forall a. Maybe a
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 v i -> Map v (Set v)
adjacencyMap G {Int
[i]
v -> Maybe i
i -> v
i -> Int
i -> [i]
i -> i -> Int
gVertexIndex :: i -> Int
gVerticeCount :: Int
gDiff :: i -> i -> Int
gEdges :: i -> [i]
gToVertex :: v -> Maybe i
gFromVertex :: i -> v
gVertices :: [i]
gVertexIndex :: forall v i. G v i -> i -> Int
gVerticeCount :: forall v i. G v i -> Int
gDiff :: forall v i. G v i -> i -> i -> Int
gEdges :: forall v i. G v i -> i -> [i]
gToVertex :: forall v i. G v i -> v -> Maybe i
gFromVertex :: forall v i. G v i -> i -> v
gVertices :: forall v i. G v i -> [i]
..} = [(v, Set v)] -> Map v (Set v)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(v, Set v)] -> Map v (Set v)) -> [(v, Set v)] -> Map v (Set v)
forall a b. (a -> b) -> a -> b
$ (i -> (v, Set v)) -> [i] -> [(v, Set v)]
forall a b. (a -> b) -> [a] -> [b]
map i -> (v, Set v)
f [i]
gVertices where
    f :: i -> (v, Set v)
f i
x = (i -> v
gFromVertex i
x, [v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList ([v] -> Set v) -> [v] -> Set v
forall a b. (a -> b) -> a -> b
$ (i -> v) -> [i] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map i -> v
gFromVertex ([i] -> [v]) -> [i] -> [v]
forall a b. (a -> b) -> a -> b
$ i -> [i]
gEdges i
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 :: G v i -> [(v, [v])]
adjacencyList = Map v (Set v) -> [(v, [v])]
forall a. Map a (Set a) -> [(a, [a])]
flattenAM (Map v (Set v) -> [(v, [v])])
-> (G v i -> Map v (Set v)) -> G v i -> [(v, [v])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. G v i -> Map v (Set v)
forall v i. Ord v => G v i -> Map v (Set v)
adjacencyMap

flattenAM :: Map a (Set a) -> [(a, [a])]
flattenAM :: Map a (Set a) -> [(a, [a])]
flattenAM = ((a, Set a) -> (a, [a])) -> [(a, Set a)] -> [(a, [a])]
forall a b. (a -> b) -> [a] -> [b]
map ((Set a -> [a]) -> (a, Set a) -> (a, [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Set a -> [a]
forall a. Set a -> [a]
Set.toList) ([(a, Set a)] -> [(a, [a])])
-> (Map a (Set a) -> [(a, Set a)]) -> Map a (Set a) -> [(a, [a])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a (Set a) -> [(a, Set a)]
forall k a. Map k a -> [(k, a)]
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 v i -> Set (i, i)
edgesSet G {Int
[i]
i -> v
i -> Int
i -> [i]
i -> i -> Int
v -> Maybe i
gVertexIndex :: i -> Int
gVerticeCount :: Int
gDiff :: i -> i -> Int
gEdges :: i -> [i]
gToVertex :: v -> Maybe i
gFromVertex :: i -> v
gVertices :: [i]
gVertexIndex :: forall v i. G v i -> i -> Int
gVerticeCount :: forall v i. G v i -> Int
gDiff :: forall v i. G v i -> i -> i -> Int
gEdges :: forall v i. G v i -> i -> [i]
gToVertex :: forall v i. G v i -> v -> Maybe i
gFromVertex :: forall v i. G v i -> i -> v
gVertices :: forall v i. G v i -> [i]
..} = [(i, i)] -> Set (i, i)
forall a. Ord a => [a] -> Set a
Set.fromList
    [ (i
x, i
y)
    | i
x <- [i]
gVertices
    , i
y <- i -> [i]
gEdges i
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 :: Tree a -> [(a, a)]
treePairs (T.Node a
i Forest a
js) =
    [ (a
i, a
j) | T.Node a
j Forest a
_ <- Forest a
js ] [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ (Tree a -> [(a, a)]) -> Forest a -> [(a, a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree a -> [(a, a)]
forall a. Tree a -> [(a, a)]
treePairs Forest a
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 :: [a] -> [(a, a)]
pairs [] = []
pairs [a]
xs = [a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
xs ([a] -> [a]
forall a. [a] -> [a]
tail [a]
xs)