{-# language BangPatterns #-}
{-# language NamedFieldPuns #-}
{-# language RecordWildCards #-}
{-# language ScopedTypeVariables #-}
{-----------------------------------------------------------------------------
    reactive-banana
------------------------------------------------------------------------------}
module Reactive.Banana.Prim.Low.Graph
    ( Graph
    , empty
    , getOutgoing
    , getIncoming
    , size
    , edgeCount
    , listConnectedVertices

    , deleteVertex
    , insertEdge
    , deleteEdge
    , clearPredecessors
    , collectGarbage

    , topologicalSort
    , Step (..)
    , walkSuccessors
    , walkSuccessors_

    -- * Internal
    , Level
    , getLevel

    -- * Debugging
    , showDot
    ) where

import Data.Functor.Identity
    ( Identity (..) )
import Data.Hashable
    ( Hashable )
import Data.Maybe
    ( fromMaybe )
import Reactive.Banana.Prim.Low.GraphTraversal
    ( reversePostOrder )

import qualified Data.List as L
import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet as Set
import qualified Data.PQueue.Prio.Min as Q

type Queue = Q.MinPQueue
type Map = Map.HashMap
type Set = Set.HashSet

{-----------------------------------------------------------------------------
    Levels
------------------------------------------------------------------------------}
-- | 'Level's are used to keep track of the order of vertices —
-- Lower levels come first.
type Level = Int

ground :: Level
ground :: Level
ground = Level
0

{-----------------------------------------------------------------------------
    Graph
------------------------------------------------------------------------------}
{- | A directed graph
whose set of vertices is the set of all values of the type @v@
and whose edges are associated with data of type @e@.

Note that a 'Graph' does not have a notion of vertex membership
— by design, /all/ values of the type @v@ are vertices of the 'Graph'.
The main purpose of 'Graph' is to keep track of directed edges between
vertices; a vertex with at least one edge incident on it is called
a /connected vertex/.
For efficiency, only the connected vertices are stored.
-}
data Graph v e = Graph
    { -- | Mapping from each vertex to its direct successors
      -- (possibly empty).
      forall v e. Graph v e -> Map v (Map v e)
outgoing :: !(Map v (Map v e))

      -- | Mapping from each vertex to its direct predecessors
      -- (possibly empty).
    , forall v e. Graph v e -> Map v (Map v e)
incoming :: !(Map v (Map v e))

      -- | Mapping from each vertex to its 'Level'.
      -- Invariant: If x precedes y, then x has a lower level than y.
    , forall v e. Graph v e -> Map v Level
levels :: !(Map v Level)
    } deriving (Graph v e -> Graph v e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall v e. (Eq v, Eq e) => Graph v e -> Graph v e -> Bool
/= :: Graph v e -> Graph v e -> Bool
$c/= :: forall v e. (Eq v, Eq e) => Graph v e -> Graph v e -> Bool
== :: Graph v e -> Graph v e -> Bool
$c== :: forall v e. (Eq v, Eq e) => Graph v e -> Graph v e -> Bool
Eq, Level -> Graph v e -> ShowS
forall a.
(Level -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall v e. (Show v, Show e) => Level -> Graph v e -> ShowS
forall v e. (Show v, Show e) => [Graph v e] -> ShowS
forall v e. (Show v, Show e) => Graph v e -> String
showList :: [Graph v e] -> ShowS
$cshowList :: forall v e. (Show v, Show e) => [Graph v e] -> ShowS
show :: Graph v e -> String
$cshow :: forall v e. (Show v, Show e) => Graph v e -> String
showsPrec :: Level -> Graph v e -> ShowS
$cshowsPrec :: forall v e. (Show v, Show e) => Level -> Graph v e -> ShowS
Show)

-- | The graph with no edges.
empty :: Graph v e
empty :: forall v e. Graph v e
empty = Graph
    { outgoing :: Map v (Map v e)
outgoing = forall k v. HashMap k v
Map.empty
    , incoming :: Map v (Map v e)
incoming = forall k v. HashMap k v
Map.empty
    , levels :: Map v Level
levels = forall k v. HashMap k v
Map.empty
    }

-- | Get all direct successors of a vertex in a 'Graph'.
getOutgoing :: (Eq v, Hashable v) => Graph v e -> v -> [(e,v)]
getOutgoing :: forall v e. (Eq v, Hashable v) => Graph v e -> v -> [(e, v)]
getOutgoing Graph{Map v (Map v e)
outgoing :: Map v (Map v e)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
outgoing} v
x =
    forall a b. (a -> b) -> [a] -> [b]
map forall {b} {a}. (b, a) -> (a, b)
shuffle forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [(k, v)]
Map.toList forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall k v. HashMap k v
Map.empty forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup v
x Map v (Map v e)
outgoing
  where
      shuffle :: (b, a) -> (a, b)
shuffle (b
x,a
y) = (a
y,b
x)

-- | Get all direct predecessors of a vertex in a 'Graph'.
getIncoming :: (Eq v, Hashable v) => Graph v e -> v -> [(v,e)]
getIncoming :: forall v e. (Eq v, Hashable v) => Graph v e -> v -> [(v, e)]
getIncoming Graph{Map v (Map v e)
incoming :: Map v (Map v e)
incoming :: forall v e. Graph v e -> Map v (Map v e)
incoming} v
x =
    forall k v. HashMap k v -> [(k, v)]
Map.toList forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall k v. HashMap k v
Map.empty forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup v
x Map v (Map v e)
incoming

-- | Get the 'Level' of a vertex in a 'Graph'.
getLevel :: (Eq v, Hashable v) => Graph v e -> v -> Level
getLevel :: forall v e. (Eq v, Hashable v) => Graph v e -> v -> Level
getLevel Graph{Map v Level
levels :: Map v Level
levels :: forall v e. Graph v e -> Map v Level
levels} v
x = forall a. a -> Maybe a -> a
fromMaybe Level
ground forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup v
x Map v Level
levels

-- | List all connected vertices,
-- i.e. vertices on which at least one edge is incident.
listConnectedVertices :: (Eq v, Hashable v) => Graph v e -> [v]
listConnectedVertices :: forall v e. (Eq v, Hashable v) => Graph v e -> [v]
listConnectedVertices Graph{Map v (Map v e)
incoming :: Map v (Map v e)
incoming :: forall v e. Graph v e -> Map v (Map v e)
incoming,Map v (Map v e)
outgoing :: Map v (Map v e)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
outgoing} = 
    forall k v. HashMap k v -> [k]
Map.keys forall a b. (a -> b) -> a -> b
$ (() forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Map v (Map v e)
outgoing) forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`Map.union` (() forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Map v (Map v e)
incoming)

-- | Number of connected vertices,
-- i.e. vertices on which at least one edge is incident.
size :: (Eq v, Hashable v) => Graph v e -> Int
size :: forall v e. (Eq v, Hashable v) => Graph v e -> Level
size Graph{Map v (Map v e)
incoming :: Map v (Map v e)
incoming :: forall v e. Graph v e -> Map v (Map v e)
incoming,Map v (Map v e)
outgoing :: Map v (Map v e)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
outgoing} =
    forall k v. HashMap k v -> Level
Map.size forall a b. (a -> b) -> a -> b
$ (() forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Map v (Map v e)
outgoing) forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`Map.union` (() forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Map v (Map v e)
incoming)

-- | Number of edges.
edgeCount :: (Eq v, Hashable v) => Graph v e -> Int
edgeCount :: forall v e. (Eq v, Hashable v) => Graph v e -> Level
edgeCount Graph{Map v (Map v e)
incoming :: Map v (Map v e)
incoming :: forall v e. Graph v e -> Map v (Map v e)
incoming,Map v (Map v e)
outgoing :: Map v (Map v e)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
outgoing} =
    (forall {k} {k} {v}. HashMap k (HashMap k v) -> Level
count Map v (Map v e)
incoming forall a. Num a => a -> a -> a
+ forall {k} {k} {v}. HashMap k (HashMap k v) -> Level
count Map v (Map v e)
outgoing) forall a. Integral a => a -> a -> a
`div` Level
2
  where
    count :: HashMap k (HashMap k v) -> Level
count = forall a v k. (a -> v -> a) -> a -> HashMap k v -> a
Map.foldl' (\Level
a HashMap k v
v -> forall k v. HashMap k v -> Level
Map.size HashMap k v
v forall a. Num a => a -> a -> a
+ Level
a) Level
0

{-----------------------------------------------------------------------------
    Insertion
------------------------------------------------------------------------------}
-- | Insert an edge from the first to the second vertex into the 'Graph'.
insertEdge :: (Eq v, Hashable v) => (v,v) -> e -> Graph v e -> Graph v e
insertEdge :: forall v e.
(Eq v, Hashable v) =>
(v, v) -> e -> Graph v e -> Graph v e
insertEdge (v
x,v
y) e
exy g0 :: Graph v e
g0@Graph{Map v Level
Map v (Map v e)
levels :: Map v Level
incoming :: Map v (Map v e)
outgoing :: Map v (Map v e)
levels :: forall v e. Graph v e -> Map v Level
incoming :: forall v e. Graph v e -> Map v (Map v e)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
..} = Graph
    { outgoing :: Map v (Map v e)
outgoing
        = forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
Map.insertWith (\Map v e
new Map v e
old -> Map v e
new forall a. Semigroup a => a -> a -> a
<> Map v e
old) v
x (forall k v. Hashable k => k -> v -> HashMap k v
Map.singleton v
y e
exy)
        forall a b. (a -> b) -> a -> b
$ forall k a. (Eq k, Hashable k) => k -> a -> Map k a -> Map k a
insertDefaultIfNotMember v
y forall k v. HashMap k v
Map.empty
        forall a b. (a -> b) -> a -> b
$ Map v (Map v e)
outgoing
    , incoming :: Map v (Map v e)
incoming
        = forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
Map.insertWith (\Map v e
new Map v e
old -> Map v e
new forall a. Semigroup a => a -> a -> a
<> Map v e
old) v
y (forall k v. Hashable k => k -> v -> HashMap k v
Map.singleton v
x e
exy)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. (Eq k, Hashable k) => k -> a -> Map k a -> Map k a
insertDefaultIfNotMember v
x forall k v. HashMap k v
Map.empty
        forall a b. (a -> b) -> a -> b
$ Map v (Map v e)
incoming
    , levels :: Map v Level
levels
        = Map v Level -> Map v Level
adjustLevels
        forall a b. (a -> b) -> a -> b
$ Map v Level
levels0
    }
  where
    getLevel :: k -> HashMap k Level -> Level
getLevel k
z = forall a. a -> Maybe a -> a
fromMaybe Level
ground forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup k
z
    levels0 :: Map v Level
levels0
        = forall k a. (Eq k, Hashable k) => k -> a -> Map k a -> Map k a
insertDefaultIfNotMember v
x (Level
groundforall a. Num a => a -> a -> a
-Level
1)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. (Eq k, Hashable k) => k -> a -> Map k a -> Map k a
insertDefaultIfNotMember v
y Level
ground
        forall a b. (a -> b) -> a -> b
$ Map v Level
levels

    levelDifference :: Level
levelDifference = forall {k}. Hashable k => k -> HashMap k Level -> Level
getLevel v
y Map v Level
levels0 forall a. Num a => a -> a -> a
- Level
1 forall a. Num a => a -> a -> a
- forall {k}. Hashable k => k -> HashMap k Level -> Level
getLevel v
x Map v Level
levels0
    adjustLevel :: HashMap k Level -> k -> HashMap k Level
adjustLevel HashMap k Level
g k
x = forall k v.
(Eq k, Hashable k) =>
(v -> v) -> k -> HashMap k v -> HashMap k v
Map.adjust (forall a. Num a => a -> a -> a
+ Level
levelDifference) k
x HashMap k Level
g
    adjustLevels :: Map v Level -> Map v Level
adjustLevels Map v Level
ls
        | Level
levelDifference forall a. Ord a => a -> a -> Bool
>= Level
0 = Map v Level
ls
        | Bool
otherwise            = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' forall {k}. Hashable k => HashMap k Level -> k -> HashMap k Level
adjustLevel Map v Level
ls [v]
predecessors
      where
        Identity [v]
predecessors =
            forall a (m :: * -> *).
(Eq a, Hashable a, Monad m) =>
[a] -> GraphM m a -> m [a]
reversePostOrder [v
x] (forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v e. (Eq v, Hashable v) => Graph v e -> v -> [(v, e)]
getIncoming Graph v e
g0)

-- Helper function: Insert a default value if the key is not a member yet
insertDefaultIfNotMember
    :: (Eq k, Hashable k)
    => k -> a -> Map k a -> Map k a
insertDefaultIfNotMember :: forall k a. (Eq k, Hashable k) => k -> a -> Map k a -> Map k a
insertDefaultIfNotMember k
x a
def = forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
Map.insertWith (\a
_ a
old -> a
old) k
x a
def

{-----------------------------------------------------------------------------
    Deletion
------------------------------------------------------------------------------}
-- | TODO: Not implemented.
deleteEdge :: (Eq v, Hashable v) => (v,v) -> Graph v e -> Graph v e
deleteEdge :: forall v e. (Eq v, Hashable v) => (v, v) -> Graph v e -> Graph v e
deleteEdge (v
x,v
y) Graph v e
g = Graph
    { outgoing :: Map v (Map v e)
outgoing = forall a. HasCallStack => a
undefined v
x Graph v e
g
    , incoming :: Map v (Map v e)
incoming = forall a. HasCallStack => a
undefined v
y Graph v e
g
    , levels :: Map v Level
levels = forall a. HasCallStack => a
undefined
    }

-- | Remove all edges incident on this vertex from the 'Graph'.
deleteVertex :: (Eq v, Hashable v) => v -> Graph v e -> Graph v e
deleteVertex :: forall v e. (Eq v, Hashable v) => v -> Graph v e -> Graph v e
deleteVertex v
x = forall {e}. Graph v e -> Graph v e
clearLevels forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v e. (Eq v, Hashable v) => v -> Graph v e -> Graph v e
clearPredecessors v
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v e. (Eq v, Hashable v) => v -> Graph v e -> Graph v e
clearSuccessors v
x
  where
    clearLevels :: Graph v e -> Graph v e
clearLevels g :: Graph v e
g@Graph{Map v Level
levels :: Map v Level
levels :: forall v e. Graph v e -> Map v Level
levels} = Graph v e
g{levels :: Map v Level
levels = forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete v
x Map v Level
levels}

-- | Remove all the edges that connect the given vertex to its predecessors.
clearPredecessors :: (Eq v, Hashable v) => v -> Graph v e -> Graph v e
clearPredecessors :: forall v e. (Eq v, Hashable v) => v -> Graph v e -> Graph v e
clearPredecessors v
x g :: Graph v e
g@Graph{Map v Level
Map v (Map v e)
levels :: Map v Level
incoming :: Map v (Map v e)
outgoing :: Map v (Map v e)
levels :: forall v e. Graph v e -> Map v Level
incoming :: forall v e. Graph v e -> Map v (Map v e)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
..} = Graph v e
g
    { outgoing :: Map v (Map v e)
outgoing = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. (a -> b) -> a -> b
($) Map v (Map v e)
outgoing
        [ forall k v.
(Eq k, Hashable k) =>
(v -> v) -> k -> HashMap k v -> HashMap k v
Map.adjust (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete v
x) v
z | (v
z,e
_) <- forall v e. (Eq v, Hashable v) => Graph v e -> v -> [(v, e)]
getIncoming Graph v e
g v
x ]
    , incoming :: Map v (Map v e)
incoming = forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete v
x Map v (Map v e)
incoming
    }

-- | Remove all the edges that connect the given vertex to its successors.
clearSuccessors :: (Eq v, Hashable v) => v -> Graph v e -> Graph v e
clearSuccessors :: forall v e. (Eq v, Hashable v) => v -> Graph v e -> Graph v e
clearSuccessors v
x g :: Graph v e
g@Graph{Map v Level
Map v (Map v e)
levels :: Map v Level
incoming :: Map v (Map v e)
outgoing :: Map v (Map v e)
levels :: forall v e. Graph v e -> Map v Level
incoming :: forall v e. Graph v e -> Map v (Map v e)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
..} = Graph v e
g
    { outgoing :: Map v (Map v e)
outgoing = forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete v
x Map v (Map v e)
outgoing
    , incoming :: Map v (Map v e)
incoming = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. (a -> b) -> a -> b
($) Map v (Map v e)
incoming
        [ forall k v.
(Eq k, Hashable k) =>
(v -> v) -> k -> HashMap k v -> HashMap k v
Map.adjust (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete v
x) v
z | (e
_,v
z) <- forall v e. (Eq v, Hashable v) => Graph v e -> v -> [(e, v)]
getOutgoing Graph v e
g v
x ]
    }

-- | Apply `deleteVertex` to all vertices which are not predecessors
-- of any of the vertices in the given list.
collectGarbage :: (Eq v, Hashable v) => [v] -> Graph v e -> Graph v e
collectGarbage :: forall v e. (Eq v, Hashable v) => [v] -> Graph v e -> Graph v e
collectGarbage [v]
roots g :: Graph v e
g@Graph{Map v (Map v e)
incoming :: Map v (Map v e)
incoming :: forall v e. Graph v e -> Map v (Map v e)
incoming,Map v (Map v e)
outgoing :: Map v (Map v e)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
outgoing} = Graph v e
g
    { incoming :: Map v (Map v e)
incoming = forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
Map.filterWithKey (\v
v Map v e
_ -> v -> Bool
isReachable v
v) Map v (Map v e)
incoming
        -- incoming edges of reachable members are reachable by definition
    , outgoing :: Map v (Map v e)
outgoing
        = forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map (forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
Map.filterWithKey (\v
v e
_ -> v -> Bool
isReachable v
v))
        forall a b. (a -> b) -> a -> b
$ forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
Map.filterWithKey (\v
v Map v e
_ -> v -> Bool
isReachable v
v) Map v (Map v e)
outgoing
    }
  where
    isReachable :: v -> Bool
isReachable v
x = v
x forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`Set.member` HashSet v
reachables
    reachables :: HashSet v
reachables
        = forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity
        forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(Eq a, Hashable a, Monad m) =>
[a] -> GraphM m a -> m [a]
reversePostOrder [v]
roots
        forall a b. (a -> b) -> a -> b
$ forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v e. (Eq v, Hashable v) => Graph v e -> v -> [(v, e)]
getIncoming Graph v e
g

{-----------------------------------------------------------------------------
    Topological sort
------------------------------------------------------------------------------}
-- | If the 'Graph' is acyclic, return a topological sort,
-- that is a linear ordering of its connected vertices such that
-- each vertex occurs before its successors.
--
-- (Vertices that are not connected are not listed in the topological sort.)
--
-- https://en.wikipedia.org/wiki/Topological_sorting
topologicalSort :: (Eq v, Hashable v) => Graph v e -> [v]
topologicalSort :: forall v e. (Eq v, Hashable v) => Graph v e -> [v]
topologicalSort g :: Graph v e
g@Graph{Map v (Map v e)
incoming :: Map v (Map v e)
incoming :: forall v e. Graph v e -> Map v (Map v e)
incoming} =
    forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(Eq a, Hashable a, Monad m) =>
[a] -> GraphM m a -> m [a]
reversePostOrder [v]
roots (forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v e. (Eq v, Hashable v) => Graph v e -> v -> [(e, v)]
getOutgoing Graph v e
g)
  where
    -- all vertices that have no (direct) predecessors
    roots :: [v]
roots = [ v
x | (v
x,Map v e
preds) <- forall k v. HashMap k v -> [(k, v)]
Map.toList Map v (Map v e)
incoming, forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map v e
preds ]

data Step = Next | Stop

-- | Starting from a list of vertices without predecessors,
-- walk through all successors, but in such a way that every vertex
-- is visited before its predecessors.
-- For every vertex, if the function returns `Next`, then
-- the successors are visited, otherwise the walk at the vertex
-- stops prematurely.
--
-- > topologicalSort g =
-- >     runIdentity $ walkSuccessors (roots g) (pure Next) g
--
walkSuccessors
    :: forall v e m. (Monad m, Eq v, Hashable v)
    => [v] -> (v -> m Step) -> Graph v e -> m [v]
walkSuccessors :: forall v e (m :: * -> *).
(Monad m, Eq v, Hashable v) =>
[v] -> (v -> m Step) -> Graph v e -> m [v]
walkSuccessors [v]
xs v -> m Step
step Graph v e
g = Queue Level v -> Set v -> [v] -> m [v]
go (forall k a. Ord k => [(k, a)] -> MinPQueue k a
Q.fromList forall a b. (a -> b) -> a -> b
$ [v] -> [(Level, v)]
zipLevels [v]
xs) forall a. HashSet a
Set.empty []
  where
    zipLevels :: [v] -> [(Level, v)]
zipLevels [v]
vs = [(forall v e. (Eq v, Hashable v) => Graph v e -> v -> Level
getLevel Graph v e
g v
v, v
v) | v
v <- [v]
vs]

    go :: Queue Level v -> Set v -> [v] -> m [v]
    go :: Queue Level v -> Set v -> [v] -> m [v]
go Queue Level v
q0 Set v
seen [v]
visits = case forall k a. Ord k => MinPQueue k a -> Maybe (a, MinPQueue k a)
Q.minView Queue Level v
q0 of
        Maybe (v, Queue Level v)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [v]
visits
        Just (v
v,Queue Level v
q1)
            | v
v forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`Set.member` Set v
seen -> Queue Level v -> Set v -> [v] -> m [v]
go Queue Level v
q1 Set v
seen [v]
visits
            | Bool
otherwise -> do
                Step
next <- v -> m Step
step v
v
                let q2 :: Queue Level v
q2 = case Step
next of
                      Step
Stop -> Queue Level v
q1
                      Step
Next ->
                          let successors :: [(Level, v)]
successors = [v] -> [(Level, v)]
zipLevels forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall v e. (Eq v, Hashable v) => Graph v e -> v -> [(e, v)]
getOutgoing Graph v e
g v
v
                          in  forall k v. Ord k => Queue k v -> [(k, v)] -> Queue k v
insertList Queue Level v
q1 [(Level, v)]
successors
                Queue Level v -> Set v -> [v] -> m [v]
go Queue Level v
q2 (forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.insert v
v Set v
seen) (v
vforall a. a -> [a] -> [a]
:[v]
visits)


insertList :: Ord k => Queue k v -> [(k,v)] -> Queue k v
insertList :: forall k v. Ord k => Queue k v -> [(k, v)] -> Queue k v
insertList = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (\Queue k v
q (k
k,v
v) -> forall k a. Ord k => k -> a -> MinPQueue k a -> MinPQueue k a
Q.insert k
k v
v Queue k v
q)

walkSuccessors_
    :: (Monad m, Eq v, Hashable v)
    => [v] -> (v -> m Step) -> Graph v e -> m ()
walkSuccessors_ :: forall (m :: * -> *) v e.
(Monad m, Eq v, Hashable v) =>
[v] -> (v -> m Step) -> Graph v e -> m ()
walkSuccessors_ [v]
xs v -> m Step
step Graph v e
g = forall v e (m :: * -> *).
(Monad m, Eq v, Hashable v) =>
[v] -> (v -> m Step) -> Graph v e -> m [v]
walkSuccessors [v]
xs v -> m Step
step Graph v e
g forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

{-----------------------------------------------------------------------------
    Debugging
------------------------------------------------------------------------------}
-- | Map to a string in @graphviz@ dot file format.
showDot
    :: (Eq v, Hashable v)
    => (v -> String) -> Graph v e -> String
showDot :: forall v e.
(Eq v, Hashable v) =>
(v -> String) -> Graph v e -> String
showDot v -> String
fv Graph v e
g = [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
    [ String
"digraph mygraph {"
    , String
"  node [shape=box];"
    ] forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map v -> String
showVertex (forall v e. (Eq v, Hashable v) => Graph v e -> [v]
listConnectedVertices Graph v e
g)
    forall a. Semigroup a => a -> a -> a
<> [String
"}"]
  where
    showVertex :: v -> String
showVertex v
x =
        forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"  " forall a. Semigroup a => a -> a -> a
<> v -> v -> String
showEdge v
x v
y forall a. Semigroup a => a -> a -> a
<> String
"; " | (e
_,v
y) <- forall v e. (Eq v, Hashable v) => Graph v e -> v -> [(e, v)]
getOutgoing Graph v e
g v
x ]
    showEdge :: v -> v -> String
showEdge v
x v
y = v -> String
escape v
x forall a. Semigroup a => a -> a -> a
<> String
" -> " forall a. Semigroup a => a -> a -> a
<> v -> String
escape v
y
    escape :: v -> String
escape = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> String
fv