{-# 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
(Graph v e -> Graph v e -> Bool)
-> (Graph v e -> Graph v e -> Bool) -> Eq (Graph v e)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall v e. (Eq v, Eq e) => 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
/= :: Graph v e -> Graph v e -> Bool
Eq, Level -> Graph v e -> ShowS
[Graph v e] -> ShowS
Graph v e -> String
(Level -> Graph v e -> ShowS)
-> (Graph v e -> String)
-> ([Graph v e] -> ShowS)
-> Show (Graph v e)
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
$cshowsPrec :: forall v e. (Show v, Show e) => Level -> Graph v e -> ShowS
showsPrec :: Level -> Graph v e -> ShowS
$cshow :: forall v e. (Show v, Show e) => Graph v e -> String
show :: Graph v e -> String
$cshowList :: forall v e. (Show v, Show e) => [Graph v e] -> ShowS
showList :: [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 = Map v (Map v e)
forall k v. HashMap k v
Map.empty
    , incoming :: Map v (Map v e)
incoming = Map v (Map v e)
forall k v. HashMap k v
Map.empty
    , levels :: Map v Level
levels = Map v Level
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 :: forall v e. Graph v e -> Map v (Map v e)
outgoing :: Map v (Map v e)
outgoing} v
x =
    ((v, e) -> (e, v)) -> [(v, e)] -> [(e, v)]
forall a b. (a -> b) -> [a] -> [b]
map (v, e) -> (e, v)
forall {b} {a}. (b, a) -> (a, b)
shuffle ([(v, e)] -> [(e, v)]) -> [(v, e)] -> [(e, v)]
forall a b. (a -> b) -> a -> b
$ Map v e -> [(v, e)]
forall k v. HashMap k v -> [(k, v)]
Map.toList (Map v e -> [(v, e)]) -> Map v e -> [(v, e)]
forall a b. (a -> b) -> a -> b
$ Map v e -> Maybe (Map v e) -> Map v e
forall a. a -> Maybe a -> a
fromMaybe Map v e
forall k v. HashMap k v
Map.empty (Maybe (Map v e) -> Map v e) -> Maybe (Map v e) -> Map v e
forall a b. (a -> b) -> a -> b
$ v -> Map v (Map v e) -> Maybe (Map v e)
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 :: forall v e. Graph v e -> Map v (Map v e)
incoming :: Map v (Map v e)
incoming} v
x =
    Map v e -> [(v, e)]
forall k v. HashMap k v -> [(k, v)]
Map.toList (Map v e -> [(v, e)]) -> Map v e -> [(v, e)]
forall a b. (a -> b) -> a -> b
$ Map v e -> Maybe (Map v e) -> Map v e
forall a. a -> Maybe a -> a
fromMaybe Map v e
forall k v. HashMap k v
Map.empty (Maybe (Map v e) -> Map v e) -> Maybe (Map v e) -> Map v e
forall a b. (a -> b) -> a -> b
$ v -> Map v (Map v e) -> Maybe (Map v e)
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 :: forall v e. Graph v e -> Map v Level
levels :: Map v Level
levels} v
x = Level -> Maybe Level -> Level
forall a. a -> Maybe a -> a
fromMaybe Level
ground (Maybe Level -> Level) -> Maybe Level -> Level
forall a b. (a -> b) -> a -> b
$ v -> Map v Level -> Maybe Level
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 :: forall v e. Graph v e -> Map v (Map v e)
incoming :: Map v (Map v e)
incoming,Map v (Map v e)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
outgoing :: Map v (Map v e)
outgoing} = 
    HashMap v () -> [v]
forall k v. HashMap k v -> [k]
Map.keys (HashMap v () -> [v]) -> HashMap v () -> [v]
forall a b. (a -> b) -> a -> b
$ (() () -> Map v (Map v e) -> HashMap v ()
forall a b. a -> HashMap v b -> HashMap v a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Map v (Map v e)
outgoing) HashMap v () -> HashMap v () -> HashMap v ()
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`Map.union` (() () -> Map v (Map v e) -> HashMap v ()
forall a b. a -> HashMap v b -> HashMap v a
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 :: forall v e. Graph v e -> Map v (Map v e)
incoming :: Map v (Map v e)
incoming,Map v (Map v e)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
outgoing :: Map v (Map v e)
outgoing} =
    HashMap v () -> Level
forall k v. HashMap k v -> Level
Map.size (HashMap v () -> Level) -> HashMap v () -> Level
forall a b. (a -> b) -> a -> b
$ (() () -> Map v (Map v e) -> HashMap v ()
forall a b. a -> HashMap v b -> HashMap v a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Map v (Map v e)
outgoing) HashMap v () -> HashMap v () -> HashMap v ()
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`Map.union` (() () -> Map v (Map v e) -> HashMap v ()
forall a b. a -> HashMap v b -> HashMap v a
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 :: forall v e. Graph v e -> Map v (Map v e)
incoming :: Map v (Map v e)
incoming,Map v (Map v e)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
outgoing :: Map v (Map v e)
outgoing} =
    (Map v (Map v e) -> Level
forall {k} {k} {v}. HashMap k (HashMap k v) -> Level
count Map v (Map v e)
incoming Level -> Level -> Level
forall a. Num a => a -> a -> a
+ Map v (Map v e) -> Level
forall {k} {k} {v}. HashMap k (HashMap k v) -> Level
count Map v (Map v e)
outgoing) Level -> Level -> Level
forall a. Integral a => a -> a -> a
`div` Level
2
  where
    count :: HashMap k (HashMap k v) -> Level
count = (Level -> HashMap k v -> Level)
-> Level -> HashMap k (HashMap k v) -> Level
forall a v k. (a -> v -> a) -> a -> HashMap k v -> a
Map.foldl' (\Level
a HashMap k v
v -> HashMap k v -> Level
forall k v. HashMap k v -> Level
Map.size HashMap k v
v Level -> Level -> Level
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)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
incoming :: forall v e. Graph v e -> Map v (Map v e)
levels :: forall v e. Graph v e -> Map v Level
outgoing :: Map v (Map v e)
incoming :: Map v (Map v e)
levels :: Map v Level
..} = Graph
    { outgoing :: Map v (Map v e)
outgoing
        = (Map v e -> Map v e -> Map v e)
-> v -> Map v e -> Map v (Map v e) -> Map v (Map v e)
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 Map v e -> Map v e -> Map v e
forall a. Semigroup a => a -> a -> a
<> Map v e
old) v
x (v -> e -> Map v e
forall k v. Hashable k => k -> v -> HashMap k v
Map.singleton v
y e
exy)
        (Map v (Map v e) -> Map v (Map v e))
-> Map v (Map v e) -> Map v (Map v e)
forall a b. (a -> b) -> a -> b
$ v -> Map v e -> Map v (Map v e) -> Map v (Map v e)
forall k a. (Eq k, Hashable k) => k -> a -> Map k a -> Map k a
insertDefaultIfNotMember v
y Map v e
forall k v. HashMap k v
Map.empty
        (Map v (Map v e) -> Map v (Map v e))
-> Map v (Map v e) -> Map v (Map v e)
forall a b. (a -> b) -> a -> b
$ Map v (Map v e)
outgoing
    , incoming :: Map v (Map v e)
incoming
        = (Map v e -> Map v e -> Map v e)
-> v -> Map v e -> Map v (Map v e) -> Map v (Map v e)
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 Map v e -> Map v e -> Map v e
forall a. Semigroup a => a -> a -> a
<> Map v e
old) v
y (v -> e -> Map v e
forall k v. Hashable k => k -> v -> HashMap k v
Map.singleton v
x e
exy)
        (Map v (Map v e) -> Map v (Map v e))
-> (Map v (Map v e) -> Map v (Map v e))
-> Map v (Map v e)
-> Map v (Map v e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Map v e -> Map v (Map v e) -> Map v (Map v e)
forall k a. (Eq k, Hashable k) => k -> a -> Map k a -> Map k a
insertDefaultIfNotMember v
x Map v e
forall k v. HashMap k v
Map.empty
        (Map v (Map v e) -> Map v (Map v e))
-> Map v (Map v e) -> Map v (Map v e)
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
        (Map v Level -> Map v Level) -> Map v Level -> Map v Level
forall a b. (a -> b) -> a -> b
$ Map v Level
levels0
    }
  where
    getLevel :: k -> HashMap k Level -> Level
getLevel k
z = Level -> Maybe Level -> Level
forall a. a -> Maybe a -> a
fromMaybe Level
ground (Maybe Level -> Level)
-> (HashMap k Level -> Maybe Level) -> HashMap k Level -> Level
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> HashMap k Level -> Maybe Level
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup k
z
    levels0 :: Map v Level
levels0
        = v -> Level -> Map v Level -> Map v Level
forall k a. (Eq k, Hashable k) => k -> a -> Map k a -> Map k a
insertDefaultIfNotMember v
x (Level
groundLevel -> Level -> Level
forall a. Num a => a -> a -> a
-Level
1)
        (Map v Level -> Map v Level)
-> (Map v Level -> Map v Level) -> Map v Level -> Map v Level
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Level -> Map v Level -> Map v Level
forall k a. (Eq k, Hashable k) => k -> a -> Map k a -> Map k a
insertDefaultIfNotMember v
y Level
ground
        (Map v Level -> Map v Level) -> Map v Level -> Map v Level
forall a b. (a -> b) -> a -> b
$ Map v Level
levels

    levelDifference :: Level
levelDifference = v -> Map v Level -> Level
forall {k}. Hashable k => k -> HashMap k Level -> Level
getLevel v
y Map v Level
levels0 Level -> Level -> Level
forall a. Num a => a -> a -> a
- Level
1 Level -> Level -> Level
forall a. Num a => a -> a -> a
- v -> Map v Level -> Level
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 = (Level -> Level) -> k -> HashMap k Level -> HashMap k Level
forall k v.
(Eq k, Hashable k) =>
(v -> v) -> k -> HashMap k v -> HashMap k v
Map.adjust (Level -> Level -> Level
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 Level -> Level -> Bool
forall a. Ord a => a -> a -> Bool
>= Level
0 = Map v Level
ls
        | Bool
otherwise            = (Map v Level -> v -> Map v Level)
-> Map v Level -> [v] -> Map v Level
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' Map v Level -> v -> Map v Level
forall {k}. Hashable k => HashMap k Level -> k -> HashMap k Level
adjustLevel Map v Level
ls [v]
predecessors
      where
        Identity [v]
predecessors =
            [v] -> GraphM Identity v -> Identity [v]
forall a (m :: * -> *).
(Eq a, Hashable a, Monad m) =>
[a] -> GraphM m a -> m [a]
reversePostOrder [v
x] ([v] -> Identity [v]
forall a. a -> Identity a
Identity ([v] -> Identity [v]) -> (v -> [v]) -> GraphM Identity v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((v, e) -> v) -> [(v, e)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (v, e) -> v
forall a b. (a, b) -> a
fst ([(v, e)] -> [v]) -> (v -> [(v, e)]) -> v -> [v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph v e -> v -> [(v, e)]
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 = (a -> a -> a) -> k -> a -> HashMap k a -> HashMap k a
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 = v -> Graph v e -> Map v (Map v e)
forall a. HasCallStack => a
undefined v
x Graph v e
g
    , incoming :: Map v (Map v e)
incoming = v -> Graph v e -> Map v (Map v e)
forall a. HasCallStack => a
undefined v
y Graph v e
g
    , levels :: Map v Level
levels = Map v Level
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 = Graph v e -> Graph v e
forall {e}. Graph v e -> Graph v e
clearLevels (Graph v e -> Graph v e)
-> (Graph v e -> Graph v e) -> Graph v e -> Graph v e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Graph v e -> Graph v e
forall v e. (Eq v, Hashable v) => v -> Graph v e -> Graph v e
clearPredecessors v
x (Graph v e -> Graph v e)
-> (Graph v e -> Graph v e) -> Graph v e -> Graph v e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Graph v e -> Graph v e
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 :: forall v e. Graph v e -> Map v Level
levels :: Map v Level
levels} = Graph v e
g{levels :: Map v Level
levels = v -> Map v Level -> Map v Level
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)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
incoming :: forall v e. Graph v e -> Map v (Map v e)
levels :: forall v e. Graph v e -> Map v Level
outgoing :: Map v (Map v e)
incoming :: Map v (Map v e)
levels :: Map v Level
..} = Graph v e
g
    { outgoing :: Map v (Map v e)
outgoing = ((Map v (Map v e) -> Map v (Map v e))
 -> Map v (Map v e) -> Map v (Map v e))
-> Map v (Map v e)
-> [Map v (Map v e) -> Map v (Map v e)]
-> Map v (Map v e)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Map v (Map v e) -> Map v (Map v e))
-> Map v (Map v e) -> Map v (Map v e)
forall a b. (a -> b) -> a -> b
($) Map v (Map v e)
outgoing
        [ (Map v e -> Map v e) -> v -> Map v (Map v e) -> Map v (Map v e)
forall k v.
(Eq k, Hashable k) =>
(v -> v) -> k -> HashMap k v -> HashMap k v
Map.adjust (v -> Map v e -> Map v e
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete v
x) v
z | (v
z,e
_) <- Graph v e -> v -> [(v, 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 = v -> Map v (Map v e) -> Map v (Map v e)
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)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
incoming :: forall v e. Graph v e -> Map v (Map v e)
levels :: forall v e. Graph v e -> Map v Level
outgoing :: Map v (Map v e)
incoming :: Map v (Map v e)
levels :: Map v Level
..} = Graph v e
g
    { outgoing :: Map v (Map v e)
outgoing = v -> Map v (Map v e) -> Map v (Map v e)
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 = ((Map v (Map v e) -> Map v (Map v e))
 -> Map v (Map v e) -> Map v (Map v e))
-> Map v (Map v e)
-> [Map v (Map v e) -> Map v (Map v e)]
-> Map v (Map v e)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Map v (Map v e) -> Map v (Map v e))
-> Map v (Map v e) -> Map v (Map v e)
forall a b. (a -> b) -> a -> b
($) Map v (Map v e)
incoming
        [ (Map v e -> Map v e) -> v -> Map v (Map v e) -> Map v (Map v e)
forall k v.
(Eq k, Hashable k) =>
(v -> v) -> k -> HashMap k v -> HashMap k v
Map.adjust (v -> Map v e -> Map v e
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete v
x) v
z | (e
_,v
z) <- Graph v e -> v -> [(e, v)]
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 :: forall v e. Graph v e -> Map v (Map v e)
incoming :: Map v (Map v e)
incoming,Map v (Map v e)
outgoing :: forall v e. Graph v e -> Map v (Map v e)
outgoing :: Map v (Map v e)
outgoing} = Graph v e
g
    { incoming :: Map v (Map v e)
incoming = (v -> Map v e -> Bool) -> Map v (Map v e) -> Map v (Map v e)
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
        = (Map v e -> Map v e) -> Map v (Map v e) -> Map v (Map v e)
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map ((v -> e -> Bool) -> Map v e -> Map v e
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
Map.filterWithKey (\v
v e
_ -> v -> Bool
isReachable v
v))
        (Map v (Map v e) -> Map v (Map v e))
-> Map v (Map v e) -> Map v (Map v e)
forall a b. (a -> b) -> a -> b
$ (v -> Map v e -> Bool) -> Map v (Map v e) -> Map v (Map v e)
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 v -> HashSet v -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`Set.member` HashSet v
reachables
    reachables :: HashSet v
reachables
        = [v] -> HashSet v
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList ([v] -> HashSet v)
-> (Identity [v] -> [v]) -> Identity [v] -> HashSet v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity [v] -> [v]
forall a. Identity a -> a
runIdentity
        (Identity [v] -> HashSet v) -> Identity [v] -> HashSet v
forall a b. (a -> b) -> a -> b
$ [v] -> GraphM Identity v -> Identity [v]
forall a (m :: * -> *).
(Eq a, Hashable a, Monad m) =>
[a] -> GraphM m a -> m [a]
reversePostOrder [v]
roots
        (GraphM Identity v -> Identity [v])
-> GraphM Identity v -> Identity [v]
forall a b. (a -> b) -> a -> b
$ [v] -> Identity [v]
forall a. a -> Identity a
Identity ([v] -> Identity [v]) -> (v -> [v]) -> GraphM Identity v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((v, e) -> v) -> [(v, e)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (v, e) -> v
forall a b. (a, b) -> a
fst ([(v, e)] -> [v]) -> (v -> [(v, e)]) -> v -> [v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph v e -> v -> [(v, e)]
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 :: forall v e. Graph v e -> Map v (Map v e)
incoming :: Map v (Map v e)
incoming} =
    Identity [v] -> [v]
forall a. Identity a -> a
runIdentity (Identity [v] -> [v]) -> Identity [v] -> [v]
forall a b. (a -> b) -> a -> b
$ [v] -> GraphM Identity v -> Identity [v]
forall a (m :: * -> *).
(Eq a, Hashable a, Monad m) =>
[a] -> GraphM m a -> m [a]
reversePostOrder [v]
roots ([v] -> Identity [v]
forall a. a -> Identity a
Identity ([v] -> Identity [v]) -> (v -> [v]) -> GraphM Identity v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((e, v) -> v) -> [(e, v)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (e, v) -> v
forall a b. (a, b) -> b
snd ([(e, v)] -> [v]) -> (v -> [(e, v)]) -> v -> [v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph v e -> v -> [(e, v)]
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) <- Map v (Map v e) -> [(v, Map v e)]
forall k v. HashMap k v -> [(k, v)]
Map.toList Map v (Map v e)
incoming, Map v e -> Bool
forall a. HashMap v a -> Bool
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 ([(Level, v)] -> Queue Level v
forall k a. Ord k => [(k, a)] -> MinPQueue k a
Q.fromList ([(Level, v)] -> Queue Level v) -> [(Level, v)] -> Queue Level v
forall a b. (a -> b) -> a -> b
$ [v] -> [(Level, v)]
zipLevels [v]
xs) Set v
forall a. HashSet a
Set.empty []
  where
    zipLevels :: [v] -> [(Level, v)]
zipLevels [v]
vs = [(Graph v e -> v -> Level
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 Queue Level v -> Maybe (v, Queue Level v)
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 -> [v] -> m [v]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([v] -> m [v]) -> [v] -> m [v]
forall a b. (a -> b) -> a -> b
$ [v] -> [v]
forall a. [a] -> [a]
reverse [v]
visits
        Just (v
v,Queue Level v
q1)
            | v
v v -> Set v -> Bool
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 ([v] -> [(Level, v)]) -> [v] -> [(Level, v)]
forall a b. (a -> b) -> a -> b
$ ((e, v) -> v) -> [(e, v)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
map (e, v) -> v
forall a b. (a, b) -> b
snd ([(e, v)] -> [v]) -> [(e, v)] -> [v]
forall a b. (a -> b) -> a -> b
$ Graph v e -> v -> [(e, v)]
forall v e. (Eq v, Hashable v) => Graph v e -> v -> [(e, v)]
getOutgoing Graph v e
g v
v
                          in  Queue Level v -> [(Level, v)] -> Queue Level v
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 (v -> Set v -> Set v
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.insert v
v Set v
seen) (v
vv -> [v] -> [v]
forall 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 = (Queue k v -> (k, v) -> Queue k v)
-> Queue k v -> [(k, v)] -> Queue k v
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (\Queue k v
q (k
k,v
v) -> k -> v -> Queue k v -> Queue k 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 = [v] -> (v -> m Step) -> Graph v e -> m [v]
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 m [v] -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall a. a -> m a
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 ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    [ String
"digraph mygraph {"
    , String
"  node [shape=box];"
    ] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> (v -> String) -> [v] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map v -> String
showVertex (Graph v e -> [v]
forall v e. (Eq v, Hashable v) => Graph v e -> [v]
listConnectedVertices Graph v e
g)
    [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
"}"]
  where
    showVertex :: v -> String
showVertex v
x =
        [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"  " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> v -> v -> String
showEdge v
x v
y String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"; " | (e
_,v
y) <- Graph v e -> v -> [(e, v)]
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 String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" -> " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> v -> String
escape v
y
    escape :: v -> String
escape = ShowS
forall a. Show a => a -> String
show ShowS -> (v -> String) -> v -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> String
fv