-- | This module contains the type definitions and basic operations
-- for the graph that
-- "Futhark.Optimise.ReduceDeviceSyncs.MigrationTable" internally uses
-- to construct a migration table.  It is however completely
-- Futhark-agnostic and implements a generic graph abstraction.
--
-- = Overview
--
-- The 'Graph' type is a data flow dependency graph of program variables, each
-- variable represented by a 'Vertex'. A vertex may have edges to other vertices
-- or to a sink, which is a special vertex with no graph representation. Each
-- edge to a vertex is either from another vertex or from a source, which also
-- is a special vertex with no graph representation.
--
-- The primary graph operation provided by this module is 'route'. Given the
-- vertex that some unspecified source has an edge to, a path is attempted
-- found to a sink. If a sink can be reached from the source, all edges along
-- the path are reversed. The path in the opposite direction of reversed edges
-- from a source to some sink is a route.
--
-- Routes can be used to find a minimum vertex cut in the graph through what
-- amounts to a specialized depth-first search implementation of the
-- Ford-Fulkerson method. When viewed in this way each graph edge has a capacity
-- of 1 and the reversing of edges to create routes amounts to sending reverse
-- flow through a residual network (the current state of the graph).
-- The max-flow min-cut theorem allows one to determine a minimum edge cut that
-- separates the sources and sinks.
--
-- If each vertex @v@ in the graph is viewed as two vertices, @v_in@ and
-- @v_out@, with all ingoing edges to @v@ going to @v_in@, all outgoing edges
-- from @v@ going from @v_out@, and @v_in@ connected to @v_out@ with a single
-- edge, then the minimum edge cut of the view amounts to a minimum vertex cut
-- in the actual graph. The view need not be manifested as whether @v_in@ or
-- @v_out@ is reached by an edge to @v@ can be determined from whether that edge
-- is reversed or not. The presence of an outgoing, reversed edge also gives the
-- state of the virtual edge that connects @v_in@ to @v_out@.
--
-- When routing fails to find a sink in some subgraph reached via an edge then
-- that edge is marked exhausted. No sink can be reached via an exhausted edge,
-- and any subsequent routing attempt will skip pathfinding along such edge.
module Futhark.Optimise.ReduceDeviceSyncs.MigrationTable.Graph
  ( -- * Types
    Graph,
    Id,
    IdSet,
    Vertex (..),
    Routing (..),
    Exhaustion (..),
    Edges (..),
    EdgeType (..),
    Visited,
    Result (..),

    -- * Construction
    empty,
    vertex,
    declareEdges,
    oneEdge,
    none,

    -- * Insertion
    insert,

    -- * Update
    adjust,
    connectToSink,
    addEdges,

    -- * Query
    member,
    lookup,
    isSinkConnected,

    -- * Routing
    route,
    routeMany,

    -- * Traversal
    fold,
    reduce,
  )
where

import Data.IntMap.Strict qualified as IM
import Data.IntSet qualified as IS
import Data.List (foldl')
import Data.Map.Strict qualified as M
import Data.Maybe (fromJust)
import Prelude hiding (lookup)

--------------------------------------------------------------------------------
--                                   TYPES                                    --
--------------------------------------------------------------------------------

-- | A data flow dependency graph of program variables, each variable
-- represented by a 'Vertex'.
newtype Graph m = Graph (IM.IntMap (Vertex m))

-- | A handle that identifies a specific 'Vertex'.
type Id = Int

-- | A set of 'Id's.
type IdSet = IS.IntSet

-- | A graph representation of some program variable.
data Vertex m = Vertex
  { -- | The handle for this vertex in the graph.
    forall m. Vertex m -> Id
vertexId :: Id,
    -- | Custom data associated with the variable.
    forall m. Vertex m -> m
vertexMeta :: m,
    -- | Whether a route passes through this vertex, and from where.
    forall m. Vertex m -> Routing
vertexRouting :: Routing,
    -- | Handles of vertices that this vertex has an edge to.
    forall m. Vertex m -> Edges
vertexEdges :: Edges
  }

-- | Route tracking for some vertex.
-- If a route passes through the vertex then both an ingoing and an outgoing
-- edge to/from that vertex will have been reversed, and the vertex will in
-- effect have lost one edge and gained another. The gained edge will be to
-- the prior vertex along the route that passes through.
data Routing
  = -- | No route passes through the vertex, and no edges have been reversed,
    -- added, nor deleted compared to what was declared.
    NoRoute
  | -- | A route passes through the vertex, and the prior vertex is the source
    -- of that route. The edge gained by reversal is by definition exhausted.
    FromSource
  | -- | A route passes through the vertex, and this is the handle of the prior
    -- vertex. The edge gained by reversal may be exhausted. Routing assumes
    -- that at most one 'FromNode' routing exists to each vertex in a graph.
    FromNode Id Exhaustion
  deriving (Id -> Routing -> ShowS
[Routing] -> ShowS
Routing -> String
forall a.
(Id -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Routing] -> ShowS
$cshowList :: [Routing] -> ShowS
show :: Routing -> String
$cshow :: Routing -> String
showsPrec :: Id -> Routing -> ShowS
$cshowsPrec :: Id -> Routing -> ShowS
Show, Routing -> Routing -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Routing -> Routing -> Bool
$c/= :: Routing -> Routing -> Bool
== :: Routing -> Routing -> Bool
$c== :: Routing -> Routing -> Bool
Eq, Eq Routing
Routing -> Routing -> Bool
Routing -> Routing -> Ordering
Routing -> Routing -> Routing
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Routing -> Routing -> Routing
$cmin :: Routing -> Routing -> Routing
max :: Routing -> Routing -> Routing
$cmax :: Routing -> Routing -> Routing
>= :: Routing -> Routing -> Bool
$c>= :: Routing -> Routing -> Bool
> :: Routing -> Routing -> Bool
$c> :: Routing -> Routing -> Bool
<= :: Routing -> Routing -> Bool
$c<= :: Routing -> Routing -> Bool
< :: Routing -> Routing -> Bool
$c< :: Routing -> Routing -> Bool
compare :: Routing -> Routing -> Ordering
$ccompare :: Routing -> Routing -> Ordering
Ord)

-- | Whether some edge is exhausted or not. No sink can be reached via an
-- exhausted edge.
data Exhaustion = Exhausted | NotExhausted
  deriving (Id -> Exhaustion -> ShowS
[Exhaustion] -> ShowS
Exhaustion -> String
forall a.
(Id -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Exhaustion] -> ShowS
$cshowList :: [Exhaustion] -> ShowS
show :: Exhaustion -> String
$cshow :: Exhaustion -> String
showsPrec :: Id -> Exhaustion -> ShowS
$cshowsPrec :: Id -> Exhaustion -> ShowS
Show, Exhaustion -> Exhaustion -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Exhaustion -> Exhaustion -> Bool
$c/= :: Exhaustion -> Exhaustion -> Bool
== :: Exhaustion -> Exhaustion -> Bool
$c== :: Exhaustion -> Exhaustion -> Bool
Eq, Eq Exhaustion
Exhaustion -> Exhaustion -> Bool
Exhaustion -> Exhaustion -> Ordering
Exhaustion -> Exhaustion -> Exhaustion
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Exhaustion -> Exhaustion -> Exhaustion
$cmin :: Exhaustion -> Exhaustion -> Exhaustion
max :: Exhaustion -> Exhaustion -> Exhaustion
$cmax :: Exhaustion -> Exhaustion -> Exhaustion
>= :: Exhaustion -> Exhaustion -> Bool
$c>= :: Exhaustion -> Exhaustion -> Bool
> :: Exhaustion -> Exhaustion -> Bool
$c> :: Exhaustion -> Exhaustion -> Bool
<= :: Exhaustion -> Exhaustion -> Bool
$c<= :: Exhaustion -> Exhaustion -> Bool
< :: Exhaustion -> Exhaustion -> Bool
$c< :: Exhaustion -> Exhaustion -> Bool
compare :: Exhaustion -> Exhaustion -> Ordering
$ccompare :: Exhaustion -> Exhaustion -> Ordering
Ord)

-- | All relevant edges that have been declared from some vertex, plus
-- bookkeeping to track their exhaustion and reversal.
data Edges
  = -- | The vertex has an edge to a sink; all other declared edges are
    -- irrelevant. The edge cannot become exhausted, and it is reversed if a
    -- route passes through the vertex (@vertexRouting v /= NoRoute@).
    ToSink
  | -- | All vertices that the vertex has a declared edge to, and which of
    -- those edges that are not exhausted nor reversed, if not all.
    ToNodes IdSet (Maybe IdSet)
  deriving (Id -> Edges -> ShowS
[Edges] -> ShowS
Edges -> String
forall a.
(Id -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Edges] -> ShowS
$cshowList :: [Edges] -> ShowS
show :: Edges -> String
$cshow :: Edges -> String
showsPrec :: Id -> Edges -> ShowS
$cshowsPrec :: Id -> Edges -> ShowS
Show, Edges -> Edges -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Edges -> Edges -> Bool
$c/= :: Edges -> Edges -> Bool
== :: Edges -> Edges -> Bool
$c== :: Edges -> Edges -> Bool
Eq, Eq Edges
Edges -> Edges -> Bool
Edges -> Edges -> Ordering
Edges -> Edges -> Edges
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Edges -> Edges -> Edges
$cmin :: Edges -> Edges -> Edges
max :: Edges -> Edges -> Edges
$cmax :: Edges -> Edges -> Edges
>= :: Edges -> Edges -> Bool
$c>= :: Edges -> Edges -> Bool
> :: Edges -> Edges -> Bool
$c> :: Edges -> Edges -> Bool
<= :: Edges -> Edges -> Bool
$c<= :: Edges -> Edges -> Bool
< :: Edges -> Edges -> Bool
$c< :: Edges -> Edges -> Bool
compare :: Edges -> Edges -> Ordering
$ccompare :: Edges -> Edges -> Ordering
Ord)

instance Semigroup Edges where
  Edges
ToSink <> :: Edges -> Edges -> Edges
<> Edges
_ = Edges
ToSink
  Edges
_ <> Edges
ToSink = Edges
ToSink
  (ToNodes IdSet
a1 Maybe IdSet
Nothing) <> (ToNodes IdSet
a2 Maybe IdSet
Nothing) =
    IdSet -> Maybe IdSet -> Edges
ToNodes (IdSet
a1 forall a. Semigroup a => a -> a -> a
<> IdSet
a2) forall a. Maybe a
Nothing
  (ToNodes IdSet
a1 (Just IdSet
e1)) <> (ToNodes IdSet
a2 Maybe IdSet
Nothing) =
    IdSet -> Maybe IdSet -> Edges
ToNodes (IdSet
a1 forall a. Semigroup a => a -> a -> a
<> IdSet
a2) forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (IdSet
e1 forall a. Semigroup a => a -> a -> a
<> IdSet -> IdSet -> IdSet
IS.difference IdSet
a2 IdSet
a1)
  (ToNodes IdSet
a1 Maybe IdSet
Nothing) <> (ToNodes IdSet
a2 (Just IdSet
e2)) =
    IdSet -> Maybe IdSet -> Edges
ToNodes (IdSet
a1 forall a. Semigroup a => a -> a -> a
<> IdSet
a2) forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (IdSet
e2 forall a. Semigroup a => a -> a -> a
<> IdSet -> IdSet -> IdSet
IS.difference IdSet
a1 IdSet
a2)
  (ToNodes IdSet
a1 (Just IdSet
e1)) <> (ToNodes IdSet
a2 (Just IdSet
e2)) =
    let a :: IdSet
a = IdSet -> IdSet -> IdSet
IS.difference IdSet
e2 (IdSet -> IdSet -> IdSet
IS.difference IdSet
a1 IdSet
e1)
        b :: IdSet
b = IdSet -> IdSet -> IdSet
IS.difference IdSet
e1 (IdSet -> IdSet -> IdSet
IS.difference IdSet
a2 IdSet
e2)
     in IdSet -> Maybe IdSet -> Edges
ToNodes (IdSet
a1 forall a. Semigroup a => a -> a -> a
<> IdSet
a2) forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (IdSet
a forall a. Semigroup a => a -> a -> a
<> IdSet
b)

instance Monoid Edges where
  -- The empty set of edges.
  mempty :: Edges
mempty = IdSet -> Maybe IdSet -> Edges
ToNodes IdSet
IS.empty forall a. Maybe a
Nothing

-- | Whether a vertex is reached via a normal or reversed edge.
data EdgeType = Normal | Reversed
  deriving (EdgeType -> EdgeType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EdgeType -> EdgeType -> Bool
$c/= :: EdgeType -> EdgeType -> Bool
== :: EdgeType -> EdgeType -> Bool
$c== :: EdgeType -> EdgeType -> Bool
Eq, Eq EdgeType
EdgeType -> EdgeType -> Bool
EdgeType -> EdgeType -> Ordering
EdgeType -> EdgeType -> EdgeType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: EdgeType -> EdgeType -> EdgeType
$cmin :: EdgeType -> EdgeType -> EdgeType
max :: EdgeType -> EdgeType -> EdgeType
$cmax :: EdgeType -> EdgeType -> EdgeType
>= :: EdgeType -> EdgeType -> Bool
$c>= :: EdgeType -> EdgeType -> Bool
> :: EdgeType -> EdgeType -> Bool
$c> :: EdgeType -> EdgeType -> Bool
<= :: EdgeType -> EdgeType -> Bool
$c<= :: EdgeType -> EdgeType -> Bool
< :: EdgeType -> EdgeType -> Bool
$c< :: EdgeType -> EdgeType -> Bool
compare :: EdgeType -> EdgeType -> Ordering
$ccompare :: EdgeType -> EdgeType -> Ordering
Ord)

-- | State that tracks which vertices a traversal has visited, caching immediate
-- computations.
newtype Visited a = Visited {forall a. Visited a -> Map (EdgeType, Id) a
visited :: M.Map (EdgeType, Id) a}

-- | The result of a graph traversal that may abort early in case a sink is
-- reached.
data Result a
  = -- | The traversal finished without encountering a sink, producing this
    -- value.
    Produced a
  | -- | The traversal was aborted because a sink was reached.
    FoundSink
  deriving (Result a -> Result a -> Bool
forall a. Eq a => Result a -> Result a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result a -> Result a -> Bool
$c/= :: forall a. Eq a => Result a -> Result a -> Bool
== :: Result a -> Result a -> Bool
$c== :: forall a. Eq a => Result a -> Result a -> Bool
Eq)

instance Semigroup a => Semigroup (Result a) where
  Result a
FoundSink <> :: Result a -> Result a -> Result a
<> Result a
_ = forall a. Result a
FoundSink
  Result a
_ <> Result a
FoundSink = forall a. Result a
FoundSink
  Produced a
x <> Produced a
y = forall a. a -> Result a
Produced (a
x forall a. Semigroup a => a -> a -> a
<> a
y)

--------------------------------------------------------------------------------
--                                CONSTRUCTION                                --
--------------------------------------------------------------------------------

-- | The empty graph.
empty :: Graph m
empty :: forall m. Graph m
empty = forall m. IntMap (Vertex m) -> Graph m
Graph forall a. IntMap a
IM.empty

-- | Constructs a 'Vertex' without any edges.
vertex :: Id -> m -> Vertex m
vertex :: forall m. Id -> m -> Vertex m
vertex Id
i m
m =
  Vertex
    { vertexId :: Id
vertexId = Id
i,
      vertexMeta :: m
vertexMeta = m
m,
      vertexRouting :: Routing
vertexRouting = Routing
NoRoute,
      vertexEdges :: Edges
vertexEdges = forall a. Monoid a => a
mempty
    }

-- | Creates a set of edges where no edge is reversed or exhausted.
declareEdges :: [Id] -> Edges
declareEdges :: [Id] -> Edges
declareEdges [Id]
is = IdSet -> Maybe IdSet -> Edges
ToNodes ([Id] -> IdSet
IS.fromList [Id]
is) forall a. Maybe a
Nothing

-- | Like 'declareEdges' but for a single vertex.
oneEdge :: Id -> Edges
oneEdge :: Id -> Edges
oneEdge Id
i = IdSet -> Maybe IdSet -> Edges
ToNodes (Id -> IdSet
IS.singleton Id
i) forall a. Maybe a
Nothing

-- | Initial 'Visited' state before any vertex has been visited.
none :: Visited a
none :: forall a. Visited a
none = forall a. Map (EdgeType, Id) a -> Visited a
Visited forall k a. Map k a
M.empty

--------------------------------------------------------------------------------
--                                 INSERTION                                  --
--------------------------------------------------------------------------------

-- | Insert a new vertex into the graph. If its variable already is represented
-- in the graph, the original graph is returned.
insert :: Vertex m -> Graph m -> Graph m
insert :: forall m. Vertex m -> Graph m -> Graph m
insert Vertex m
v (Graph IntMap (Vertex m)
m) = forall m. IntMap (Vertex m) -> Graph m
Graph forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> a) -> Id -> a -> IntMap a -> IntMap a
IM.insertWith forall a b. a -> b -> a
const (forall m. Vertex m -> Id
vertexId Vertex m
v) Vertex m
v IntMap (Vertex m)
m

--------------------------------------------------------------------------------
--                                   UPDATE                                   --
--------------------------------------------------------------------------------

-- | Adjust the vertex with this specific id. When no vertex with that id is a
-- member of the graph, the original graph is returned.
adjust :: (Vertex m -> Vertex m) -> Id -> Graph m -> Graph m
adjust :: forall m. (Vertex m -> Vertex m) -> Id -> Graph m -> Graph m
adjust Vertex m -> Vertex m
f Id
i (Graph IntMap (Vertex m)
m) = forall m. IntMap (Vertex m) -> Graph m
Graph forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> Id -> IntMap a -> IntMap a
IM.adjust Vertex m -> Vertex m
f Id
i IntMap (Vertex m)
m

-- | Connect the vertex with this id to a sink. When no vertex with that id is a
-- member of the graph, the original graph is returned.
connectToSink :: Id -> Graph m -> Graph m
connectToSink :: forall m. Id -> Graph m -> Graph m
connectToSink = forall m. (Vertex m -> Vertex m) -> Id -> Graph m -> Graph m
adjust forall a b. (a -> b) -> a -> b
$ \Vertex m
v -> Vertex m
v {vertexEdges :: Edges
vertexEdges = Edges
ToSink}

-- | Add these edges to the vertex with this id. When no vertex with that id is
-- a member of the graph, the original graph is returned.
addEdges :: Edges -> Id -> Graph m -> Graph m
addEdges :: forall m. Edges -> Id -> Graph m -> Graph m
addEdges Edges
es = forall m. (Vertex m -> Vertex m) -> Id -> Graph m -> Graph m
adjust forall a b. (a -> b) -> a -> b
$ \Vertex m
v -> Vertex m
v {vertexEdges :: Edges
vertexEdges = Edges
es forall a. Semigroup a => a -> a -> a
<> forall m. Vertex m -> Edges
vertexEdges Vertex m
v}

--------------------------------------------------------------------------------
--                                   QUERY                                    --
--------------------------------------------------------------------------------

-- | Does a vertex for the given id exist in the graph?
member :: Id -> Graph m -> Bool
member :: forall m. Id -> Graph m -> Bool
member Id
i (Graph IntMap (Vertex m)
m) = forall a. Id -> IntMap a -> Bool
IM.member Id
i IntMap (Vertex m)
m

-- | Returns the vertex with the given id.
lookup :: Id -> Graph m -> Maybe (Vertex m)
lookup :: forall m. Id -> Graph m -> Maybe (Vertex m)
lookup Id
i (Graph IntMap (Vertex m)
m) = forall a. Id -> IntMap a -> Maybe a
IM.lookup Id
i IntMap (Vertex m)
m

-- | Returns whether a vertex with the given id exists in the
-- graph and is connected directly to a sink.
isSinkConnected :: Id -> Graph m -> Bool
isSinkConnected :: forall m. Id -> Graph m -> Bool
isSinkConnected Id
i Graph m
g =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((Edges
ToSink ==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Vertex m -> Edges
vertexEdges) (forall m. Id -> Graph m -> Maybe (Vertex m)
lookup Id
i Graph m
g)

--                                  ROUTING                                   --
--------------------------------------------------------------------------------

-- | @route src g@ attempts to find a path in @g@ from the source connected
-- vertex with id @src@. If a sink is found, all edges along the path will be
-- reversed to create a route, and the id of the vertex that connects to the
-- sink is returned.
route :: Id -> Graph m -> (Maybe Id, Graph m)
route :: forall m. Id -> Graph m -> (Maybe Id, Graph m)
route Id
src Graph m
g =
  case forall m.
Pending
-> Id
-> Maybe Id
-> EdgeType
-> Id
-> Graph m
-> (RoutingResult m, Graph m)
route' forall a. IntMap a
IM.empty Id
0 forall a. Maybe a
Nothing EdgeType
Normal Id
src Graph m
g of
    (RoutingResult m
DeadEnd, Graph m
g') -> (forall a. Maybe a
Nothing, Graph m
g')
    (SinkFound Id
snk, Graph m
g') -> (forall a. a -> Maybe a
Just Id
snk, Graph m
g')
    (CycleDetected {}, Graph m
_) ->
      forall a. HasCallStack => String -> a
error
        String
"Routing did not escape cycle in Futhark.Analysis.MigrationTable.Graph."

-- | @routeMany srcs g@ attempts to create a 'route' in @g@ from every vertex
-- in @srcs@. Returns the ids for the vertices connected to each found sink.
routeMany :: [Id] -> Graph m -> ([Id], Graph m)
routeMany :: forall m. [Id] -> Graph m -> ([Id], Graph m)
routeMany [Id]
srcs Graph m
graph =
  forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {m}. ([Id], Graph m) -> Id -> ([Id], Graph m)
f ([], Graph m
graph) [Id]
srcs
  where
    f :: ([Id], Graph m) -> Id -> ([Id], Graph m)
f ([Id]
snks, Graph m
g) Id
src =
      case forall m. Id -> Graph m -> (Maybe Id, Graph m)
route Id
src Graph m
g of
        (Maybe Id
Nothing, Graph m
g') -> ([Id]
snks, Graph m
g')
        (Just Id
snk, Graph m
g') -> (Id
snk forall a. a -> [a] -> [a]
: [Id]
snks, Graph m
g')

--------------------------------------------------------------------------------
--                                 TRAVERSAL                                  --
--------------------------------------------------------------------------------

-- | @fold g f (a, vs) et i@ folds @f@ over the vertices in @g@ that can be
-- reached from the vertex with handle @i@ accessed via an edge of type @et@.
-- Each vertex @v@ may be visited up to two times, once for each type of edge
-- @e@ pointing to it, and each time @f a e v@ is evaluated to produce an
-- updated @a@ value to be used in future @f@ evaluations or to be returned.
-- The @vs@ set records which @f a e v@ evaluations already have taken place.
-- The function returns an updated 'Visited' set recording the evaluations it
-- has performed.
fold ::
  Graph m ->
  (a -> EdgeType -> Vertex m -> a) ->
  (a, Visited ()) ->
  EdgeType ->
  Id ->
  (a, Visited ())
fold :: forall m a.
Graph m
-> (a -> EdgeType -> Vertex m -> a)
-> (a, Visited ())
-> EdgeType
-> Id
-> (a, Visited ())
fold Graph m
g a -> EdgeType -> Vertex m -> a
f (a
res, Visited ()
vs) EdgeType
et Id
i
  | forall k a. Ord k => k -> Map k a -> Bool
M.notMember (EdgeType
et, Id
i) (forall a. Visited a -> Map (EdgeType, Id) a
visited Visited ()
vs),
    Just Vertex m
v <- forall m. Id -> Graph m -> Maybe (Vertex m)
lookup Id
i Graph m
g =
      let res' :: a
res' = a -> EdgeType -> Vertex m -> a
f a
res EdgeType
et Vertex m
v
          vs' :: Visited ()
vs' = forall a. Map (EdgeType, Id) a -> Visited a
Visited forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (EdgeType
et, Id
i) () (forall a. Visited a -> Map (EdgeType, Id) a
visited Visited ()
vs)
          st :: (a, Visited ())
st = (a
res', Visited ()
vs')
       in case (EdgeType
et, forall m. Vertex m -> Routing
vertexRouting Vertex m
v) of
            (EdgeType
Normal, Routing
FromSource) -> (a, Visited ())
st
            (EdgeType
Normal, FromNode Id
rev Exhaustion
_) -> (a, Visited ()) -> Id -> (a, Visited ())
foldReversed (a, Visited ())
st Id
rev
            (EdgeType
Reversed, FromNode Id
rev Exhaustion
_) -> (a, Visited ()) -> Id -> Edges -> (a, Visited ())
foldAll (a, Visited ())
st Id
rev (forall m. Vertex m -> Edges
vertexEdges Vertex m
v)
            (EdgeType, Routing)
_ -> (a, Visited ()) -> Edges -> (a, Visited ())
foldNormals (a, Visited ())
st (forall m. Vertex m -> Edges
vertexEdges Vertex m
v)
  | Bool
otherwise =
      (a
res, Visited ()
vs)
  where
    foldReversed :: (a, Visited ()) -> Id -> (a, Visited ())
foldReversed (a, Visited ())
st = forall m a.
Graph m
-> (a -> EdgeType -> Vertex m -> a)
-> (a, Visited ())
-> EdgeType
-> Id
-> (a, Visited ())
fold Graph m
g a -> EdgeType -> Vertex m -> a
f (a, Visited ())
st EdgeType
Reversed

    foldAll :: (a, Visited ()) -> Id -> Edges -> (a, Visited ())
foldAll (a, Visited ())
st Id
rev Edges
es = (a, Visited ()) -> Id -> (a, Visited ())
foldReversed ((a, Visited ()) -> Edges -> (a, Visited ())
foldNormals (a, Visited ())
st Edges
es) Id
rev

    foldNormals :: (a, Visited ()) -> Edges -> (a, Visited ())
foldNormals (a, Visited ())
st Edges
ToSink = (a, Visited ())
st
    foldNormals (a, Visited ())
st (ToNodes IdSet
es Maybe IdSet
_) =
      forall a. (a -> Id -> a) -> a -> IdSet -> a
IS.foldl' (\(a, Visited ())
s -> forall m a.
Graph m
-> (a -> EdgeType -> Vertex m -> a)
-> (a, Visited ())
-> EdgeType
-> Id
-> (a, Visited ())
fold Graph m
g a -> EdgeType -> Vertex m -> a
f (a, Visited ())
s EdgeType
Normal) (a, Visited ())
st IdSet
es

-- | @reduce g r vs et i@ returns 'FoundSink' if a sink can be reached via the
-- vertex @v@ with id @i@ in @g@. Otherwise it returns 'Produced' @(r x et v)@
-- where @x@ is the '<>' aggregate of all values produced by reducing the
-- vertices that are available via the edges of @v@.
-- @et@ identifies the type of edge that @v@ is accessed by and thereby which
-- edges of @v@ that are available. @vs@ caches reductions of vertices that
-- previously have been visited in the graph.
--
-- The reduction of a cyclic reference resolves to 'mempty'.
reduce ::
  Monoid a =>
  Graph m ->
  (a -> EdgeType -> Vertex m -> a) ->
  Visited (Result a) ->
  EdgeType ->
  Id ->
  (Result a, Visited (Result a))
reduce :: forall a m.
Monoid a =>
Graph m
-> (a -> EdgeType -> Vertex m -> a)
-> Visited (Result a)
-> EdgeType
-> Id
-> (Result a, Visited (Result a))
reduce Graph m
g a -> EdgeType -> Vertex m -> a
r Visited (Result a)
vs EdgeType
et Id
i
  | Just Result a
res <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (EdgeType
et, Id
i) (forall a. Visited a -> Map (EdgeType, Id) a
visited Visited (Result a)
vs) =
      (Result a
res, Visited (Result a)
vs)
  | Just Vertex m
v <- forall m. Id -> Graph m -> Maybe (Vertex m)
lookup Id
i Graph m
g =
      Vertex m -> (Result a, Visited (Result a))
reduceVertex Vertex m
v
  | Bool
otherwise =
      (forall a. a -> Result a
Produced forall a. Monoid a => a
mempty, Visited (Result a)
vs) -- shouldn't happen
  where
    reduceVertex :: Vertex m -> (Result a, Visited (Result a))
reduceVertex Vertex m
v =
      let (Result a
res, Visited (Result a)
vs') = forall {m}. Vertex m -> (Result a, Visited (Result a))
reduceEdges Vertex m
v
       in case Result a
res of
            Produced a
x -> forall {a}. a -> Visited a -> (a, Visited a)
cached (forall a. a -> Result a
Produced forall a b. (a -> b) -> a -> b
$ a -> EdgeType -> Vertex m -> a
r a
x EdgeType
et Vertex m
v) Visited (Result a)
vs'
            Result a
FoundSink -> forall {a}. a -> Visited a -> (a, Visited a)
cached Result a
res Visited (Result a)
vs'

    cached :: a -> Visited a -> (a, Visited a)
cached a
res Visited a
vs0 =
      let vs1 :: Visited a
vs1 = forall a. Map (EdgeType, Id) a -> Visited a
Visited (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (EdgeType
et, Id
i) a
res forall a b. (a -> b) -> a -> b
$ forall a. Visited a -> Map (EdgeType, Id) a
visited Visited a
vs0)
       in (a
res, Visited a
vs1)

    reduceEdges :: Vertex m -> (Result a, Visited (Result a))
reduceEdges Vertex m
v =
      case (EdgeType
et, forall m. Vertex m -> Routing
vertexRouting Vertex m
v) of
        (EdgeType
Normal, Routing
FromSource) -> (forall a. a -> Result a
Produced forall a. Monoid a => a
mempty, Visited (Result a)
vs)
        (EdgeType
Normal, FromNode Id
rev Exhaustion
_) -> forall {b}. (Visited (Result a) -> b) -> b
entry (Id -> Visited (Result a) -> (Result a, Visited (Result a))
reduceReversed Id
rev)
        (EdgeType
Reversed, FromNode Id
rev Exhaustion
_) -> forall {b}. (Visited (Result a) -> b) -> b
entry (Id -> Edges -> Visited (Result a) -> (Result a, Visited (Result a))
reduceAll Id
rev forall a b. (a -> b) -> a -> b
$ forall m. Vertex m -> Edges
vertexEdges Vertex m
v)
        (EdgeType, Routing)
_ -> forall {b}. (Visited (Result a) -> b) -> b
entry (Edges -> Visited (Result a) -> (Result a, Visited (Result a))
reduceNormals forall a b. (a -> b) -> a -> b
$ forall m. Vertex m -> Edges
vertexEdges Vertex m
v)

    -- Handle cycles
    entry :: (Visited (Result a) -> b) -> b
entry Visited (Result a) -> b
f = Visited (Result a) -> b
f forall a b. (a -> b) -> a -> b
$ forall a. Map (EdgeType, Id) a -> Visited a
Visited forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (EdgeType
et, Id
i) (forall a. a -> Result a
Produced forall a. Monoid a => a
mempty) (forall a. Visited a -> Map (EdgeType, Id) a
visited Visited (Result a)
vs)

    reduceReversed :: Id -> Visited (Result a) -> (Result a, Visited (Result a))
reduceReversed Id
rev Visited (Result a)
vs' = forall a m.
Monoid a =>
Graph m
-> (a -> EdgeType -> Vertex m -> a)
-> Visited (Result a)
-> EdgeType
-> Id
-> (Result a, Visited (Result a))
reduce Graph m
g a -> EdgeType -> Vertex m -> a
r Visited (Result a)
vs' EdgeType
Reversed Id
rev

    reduceAll :: Id -> Edges -> Visited (Result a) -> (Result a, Visited (Result a))
reduceAll Id
rev Edges
es Visited (Result a)
vs0 =
      let (Result a
res, Visited (Result a)
vs1) = Edges -> Visited (Result a) -> (Result a, Visited (Result a))
reduceNormals Edges
es Visited (Result a)
vs0
       in case Result a
res of
            Produced a
_ ->
              let (Result a
res', Visited (Result a)
vs2) = Id -> Visited (Result a) -> (Result a, Visited (Result a))
reduceReversed Id
rev Visited (Result a)
vs1
               in (Result a
res forall a. Semigroup a => a -> a -> a
<> Result a
res', Visited (Result a)
vs2)
            Result a
FoundSink -> (Result a
res, Visited (Result a)
vs1)

    reduceNormals :: Edges -> Visited (Result a) -> (Result a, Visited (Result a))
reduceNormals Edges
ToSink Visited (Result a)
vs' = (forall a. Result a
FoundSink, Visited (Result a)
vs')
    reduceNormals (ToNodes IdSet
es Maybe IdSet
_) Visited (Result a)
vs' = a -> [Id] -> Visited (Result a) -> (Result a, Visited (Result a))
reduceNorms forall a. Monoid a => a
mempty (IdSet -> [Id]
IS.elems IdSet
es) Visited (Result a)
vs'

    reduceNorms :: a -> [Id] -> Visited (Result a) -> (Result a, Visited (Result a))
reduceNorms a
x [] Visited (Result a)
vs0 = (forall a. a -> Result a
Produced a
x, Visited (Result a)
vs0)
    reduceNorms a
x (Id
e : [Id]
es) Visited (Result a)
vs0 =
      let (Result a
res, Visited (Result a)
vs1) = forall a m.
Monoid a =>
Graph m
-> (a -> EdgeType -> Vertex m -> a)
-> Visited (Result a)
-> EdgeType
-> Id
-> (Result a, Visited (Result a))
reduce Graph m
g a -> EdgeType -> Vertex m -> a
r Visited (Result a)
vs0 EdgeType
Normal Id
e
       in case Result a
res of
            Produced a
y -> a -> [Id] -> Visited (Result a) -> (Result a, Visited (Result a))
reduceNorms (a
x forall a. Semigroup a => a -> a -> a
<> a
y) [Id]
es Visited (Result a)
vs1
            Result a
FoundSink -> (Result a
res, Visited (Result a)
vs1)

--------------------------------------------------------------------------------
--                             ROUTING INTERNALS                              --
--------------------------------------------------------------------------------

-- | A set of vertices visited by a graph traversal, and at what depth they were
-- encountered. Used to detect cycles.
type Pending = IM.IntMap Depth

-- | Search depth. Distance to some vertex from some search root.
type Depth = Int

-- | The outcome of attempted to find a route through a vertex.
data RoutingResult a
  = -- | No sink could be reached through this vertex.
    DeadEnd
  | -- | A cycle was detected. A sink can be reached through this vertex if a
    -- sink can be reached from the vertex at this depth. If no sink can be
    -- reached from the vertex at this depth, then the graph should be updated
    -- by these actions. Until the vertex is reached, the status of these
    -- vertices are pending.
    CycleDetected Depth [Graph a -> Graph a] Pending
  | -- | A sink was found. This is the id of the vertex connected to it.
    SinkFound Id

instance Semigroup (RoutingResult a) where
  SinkFound Id
i <> :: RoutingResult a -> RoutingResult a -> RoutingResult a
<> RoutingResult a
_ = forall a. Id -> RoutingResult a
SinkFound Id
i
  RoutingResult a
_ <> SinkFound Id
i = forall a. Id -> RoutingResult a
SinkFound Id
i
  CycleDetected Id
d1 [Graph a -> Graph a]
as1 Pending
_ <> CycleDetected Id
d2 [Graph a -> Graph a]
as2 Pending
p2 =
    forall a. Id -> [Graph a -> Graph a] -> Pending -> RoutingResult a
CycleDetected (forall a. Ord a => a -> a -> a
min Id
d1 Id
d2) ([Graph a -> Graph a]
as1 forall a. [a] -> [a] -> [a]
++ [Graph a -> Graph a]
as2) Pending
p2
  RoutingResult a
_ <> CycleDetected Id
d [Graph a -> Graph a]
as Pending
p = forall a. Id -> [Graph a -> Graph a] -> Pending -> RoutingResult a
CycleDetected Id
d [Graph a -> Graph a]
as Pending
p
  CycleDetected Id
d [Graph a -> Graph a]
as Pending
p <> RoutingResult a
_ = forall a. Id -> [Graph a -> Graph a] -> Pending -> RoutingResult a
CycleDetected Id
d [Graph a -> Graph a]
as Pending
p
  RoutingResult a
DeadEnd <> RoutingResult a
DeadEnd = forall a. RoutingResult a
DeadEnd

instance Monoid (RoutingResult a) where
  mempty :: RoutingResult a
mempty = forall a. RoutingResult a
DeadEnd

route' ::
  Pending ->
  Depth ->
  Maybe Id ->
  EdgeType ->
  Id ->
  Graph m ->
  (RoutingResult m, Graph m)
route' :: forall m.
Pending
-> Id
-> Maybe Id
-> EdgeType
-> Id
-> Graph m
-> (RoutingResult m, Graph m)
route' Pending
p Id
d Maybe Id
prev EdgeType
et Id
i Graph m
g
  | Just Id
d' <- forall a. Id -> IntMap a -> Maybe a
IM.lookup Id
i Pending
p =
      let found_cycle :: (RoutingResult a, Graph m)
found_cycle = (forall a. Id -> [Graph a -> Graph a] -> Pending -> RoutingResult a
CycleDetected Id
d' [] Pending
p, Graph m
g)
       in case EdgeType
et of
            -- Accessing some vertex v via a normal edge corresponds to accessing
            -- v_in via a normal edge. If v_in has a reversed edge then that is
            -- the only outgoing edge that is available.
            -- All outgoing edges available via this ingoing edge were already
            -- available via the edge that first reached the vertex.
            EdgeType
Normal -> forall {a}. (RoutingResult a, Graph m)
found_cycle
            -- Accessing some vertex v via a reversed edge corresponds to
            -- accessing v_out via a reversed edge. All other edges of v_out are
            -- available, and the edge from v_in to v_out has been reversed,
            -- implying that v_in has a single reversed edge that also is
            -- available.
            -- There exists at most one reversed edge to each vertex. Since this
            -- vertex was reached via one, and the vertex already have been
            -- reached, then the first reach must have been via a normal edge
            -- that only could traverse a reversed edge. The reversed edge from
            -- v_out to v_in thus completes a cycle, but a sink might be
            -- reachable via any of the other edges from v_out.
            -- The depth for the vertex need not be updated as this is the only
            -- edge to v_out and 'prev' is already in the 'Pending' map.
            -- It follows that no (new) cycle can start here.
            EdgeType
Reversed ->
              let (RoutingResult m
res, Graph m
g') = forall {a}.
Vertex a -> Graph a -> Pending -> (RoutingResult a, Graph a)
routeNormals (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall m. Id -> Graph m -> Maybe (Vertex m)
lookup Id
i Graph m
g) Graph m
g Pending
p
               in (forall a b. (a, b) -> a
fst forall {a}. (RoutingResult a, Graph m)
found_cycle forall a. Semigroup a => a -> a -> a
<> RoutingResult m
res, Graph m
g')
  | Just Vertex m
v <- forall m. Id -> Graph m -> Maybe (Vertex m)
lookup Id
i Graph m
g =
      Vertex m -> (RoutingResult m, Graph m)
routeVertex Vertex m
v
  | Bool
otherwise =
      forall {a}. (RoutingResult a, Graph m)
backtrack
  where
    backtrack :: (RoutingResult a, Graph m)
backtrack = (forall a. RoutingResult a
DeadEnd, Graph m
g)

    routeVertex :: Vertex m -> (RoutingResult m, Graph m)
routeVertex Vertex m
v =
      case (EdgeType
et, forall m. Vertex m -> Routing
vertexRouting Vertex m
v) of
        (EdgeType
Normal, Routing
FromSource) -> forall {a}. (RoutingResult a, Graph m)
backtrack
        (EdgeType
Normal, FromNode Id
_ Exhaustion
Exhausted) -> forall {a}. (RoutingResult a, Graph m)
backtrack
        (EdgeType
Normal, FromNode Id
rev Exhaustion
_) -> forall {a}.
(Graph m -> Pending -> (RoutingResult a, Graph a))
-> (RoutingResult a, Graph a)
entry (forall {m}. Id -> Graph m -> Pending -> (RoutingResult m, Graph m)
routeReversed Id
rev)
        (EdgeType
Reversed, FromNode Id
rev Exhaustion
_) -> forall {a}.
(Graph m -> Pending -> (RoutingResult a, Graph a))
-> (RoutingResult a, Graph a)
entry (forall {m}.
Id -> Vertex m -> Graph m -> Pending -> (RoutingResult m, Graph m)
routeAll Id
rev Vertex m
v)
        (EdgeType, Routing)
_ -> forall {a}.
(Graph m -> Pending -> (RoutingResult a, Graph a))
-> (RoutingResult a, Graph a)
entry (forall {a}.
Vertex a -> Graph a -> Pending -> (RoutingResult a, Graph a)
routeNormals Vertex m
v)

    entry :: (Graph m -> Pending -> (RoutingResult a, Graph a))
-> (RoutingResult a, Graph a)
entry Graph m -> Pending -> (RoutingResult a, Graph a)
f =
      let (RoutingResult a
res, Graph a
g0) = Graph m -> Pending -> (RoutingResult a, Graph a)
f Graph m
g (forall a. Id -> a -> IntMap a -> IntMap a
IM.insert Id
i Id
d Pending
p)
       in case RoutingResult a
res of
            CycleDetected Id
d' [Graph a -> Graph a]
as Pending
_
              | Id
d forall a. Eq a => a -> a -> Bool
== Id
d' -> (forall a. RoutingResult a
DeadEnd, forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Graph a
g1 Graph a -> Graph a
a -> Graph a -> Graph a
a Graph a
g1) Graph a
g0 [Graph a -> Graph a]
as)
            RoutingResult a
_ | Bool
otherwise -> (RoutingResult a
res, Graph a
g0)

    routeAll :: Id -> Vertex m -> Graph m -> Pending -> (RoutingResult m, Graph m)
routeAll Id
rev Vertex m
v Graph m
g0 Pending
p0 =
      let (RoutingResult m
res, Graph m
g1) = forall {a}.
Vertex a -> Graph a -> Pending -> (RoutingResult a, Graph a)
routeNormals Vertex m
v Graph m
g0 Pending
p0
       in case RoutingResult m
res of
            RoutingResult m
DeadEnd -> forall {m}. Id -> Graph m -> Pending -> (RoutingResult m, Graph m)
routeReversed Id
rev Graph m
g1 Pending
p0
            CycleDetected Id
_ [Graph m -> Graph m]
_ Pending
p1 ->
              let (RoutingResult m
res', Graph m
g2) = forall {m}. Id -> Graph m -> Pending -> (RoutingResult m, Graph m)
routeReversed Id
rev Graph m
g1 Pending
p1
               in (RoutingResult m
res forall a. Semigroup a => a -> a -> a
<> RoutingResult m
res', Graph m
g2)
            SinkFound Id
_ -> (RoutingResult m
res, Graph m
g1)

    routeReversed :: Id -> Graph m -> Pending -> (RoutingResult m, Graph m)
routeReversed Id
rev Graph m
g0 Pending
p0 =
      let (RoutingResult m
res, Graph m
g') = forall m.
Pending
-> Id
-> Maybe Id
-> EdgeType
-> Id
-> Graph m
-> (RoutingResult m, Graph m)
route' Pending
p0 (Id
d forall a. Num a => a -> a -> a
+ Id
1) (forall a. a -> Maybe a
Just Id
i) EdgeType
Reversed Id
rev Graph m
g0
          exhaust :: Graph m -> Graph m
exhaust = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall m. (Vertex m -> Vertex m) -> Id -> Graph m -> Graph m
adjust Id
i forall a b. (a -> b) -> a -> b
$
            \Vertex m
v -> Vertex m
v {vertexRouting :: Routing
vertexRouting = Id -> Exhaustion -> Routing
FromNode Id
rev Exhaustion
Exhausted}
       in case (RoutingResult m
res, EdgeType
et) of
            (RoutingResult m
DeadEnd, EdgeType
_) ->
              (RoutingResult m
res, forall {m}. Graph m -> Graph m
exhaust Graph m
g')
            (CycleDetected Id
d' [Graph m -> Graph m]
as Pending
p', EdgeType
_) ->
              (forall a. Id -> [Graph a -> Graph a] -> Pending -> RoutingResult a
CycleDetected Id
d' (forall {m}. Graph m -> Graph m
exhaust forall a. a -> [a] -> [a]
: [Graph m -> Graph m]
as) Pending
p', Graph m
g')
            (SinkFound Id
_, EdgeType
Normal) ->
              (RoutingResult m
res, forall {m}. Graph m -> Graph m
setRoute Graph m
g')
            (SinkFound Id
_, EdgeType
Reversed) ->
              let f :: Vertex m -> Vertex m
f Vertex m
v =
                    Vertex m
v
                      { vertexEdges :: Edges
vertexEdges = Edges -> Edges
withPrev (forall m. Vertex m -> Edges
vertexEdges Vertex m
v),
                        vertexRouting :: Routing
vertexRouting = Routing
NoRoute
                      }
               in (RoutingResult m
res, forall m. (Vertex m -> Vertex m) -> Id -> Graph m -> Graph m
adjust forall {m}. Vertex m -> Vertex m
f Id
i Graph m
g')

    setRoute :: Graph m -> Graph m
setRoute = forall m. (Vertex m -> Vertex m) -> Id -> Graph m -> Graph m
adjust (\Vertex m
v -> Vertex m
v {vertexRouting :: Routing
vertexRouting = Routing
routing}) Id
i

    routing :: Routing
routing =
      case Maybe Id
prev of
        Maybe Id
Nothing -> Routing
FromSource
        Just Id
i' -> Id -> Exhaustion -> Routing
FromNode Id
i' Exhaustion
NotExhausted

    withPrev :: Edges -> Edges
withPrev Edges
edges
      | Just Id
i' <- Maybe Id
prev,
        ToNodes IdSet
es (Just IdSet
es') <- Edges
edges =
          IdSet -> Maybe IdSet -> Edges
ToNodes IdSet
es (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Id -> IdSet -> IdSet
IS.insert Id
i' IdSet
es')
      | Bool
otherwise =
          Edges
edges -- shouldn't happen
    routeNormals :: Vertex a -> Graph a -> Pending -> (RoutingResult a, Graph a)
routeNormals Vertex a
v Graph a
g0 Pending
p0
      | Edges
ToSink <- forall m. Vertex m -> Edges
vertexEdges Vertex a
v =
          -- There cannot be a reversed edge to a vertex with an edge to a sink.
          (forall a. Id -> RoutingResult a
SinkFound Id
i, forall {m}. Graph m -> Graph m
setRoute Graph a
g0)
      | ToNodes IdSet
es Maybe IdSet
nx <- forall m. Vertex m -> Edges
vertexEdges Vertex a
v =
          let (RoutingResult a
res, Graph a
g', [Id]
nx') =
                case Maybe IdSet
nx of
                  Just IdSet
es' -> forall {a}.
[Id] -> Graph a -> Pending -> (RoutingResult a, Graph a, [Id])
routeNorms (IdSet -> [Id]
IS.toAscList IdSet
es') Graph a
g0 Pending
p0
                  Maybe IdSet
Nothing -> forall {a}.
[Id] -> Graph a -> Pending -> (RoutingResult a, Graph a, [Id])
routeNorms (IdSet -> [Id]
IS.toAscList IdSet
es) Graph a
g0 Pending
p0
              edges :: Edges
edges = IdSet -> Maybe IdSet -> Edges
ToNodes IdSet
es (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Id] -> IdSet
IS.fromDistinctAscList [Id]
nx')
              exhaust :: Graph m -> Graph m
exhaust = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall m. (Vertex m -> Vertex m) -> Id -> Graph m -> Graph m
adjust Id
i forall a b. (a -> b) -> a -> b
$ \Vertex m
v' ->
                Vertex m
v' {vertexEdges :: Edges
vertexEdges = IdSet -> Maybe IdSet -> Edges
ToNodes IdSet
es (forall a. a -> Maybe a
Just IdSet
IS.empty)}
           in case (RoutingResult a
res, EdgeType
et) of
                (RoutingResult a
DeadEnd, EdgeType
_) -> (RoutingResult a
res, forall {m}. Graph m -> Graph m
exhaust Graph a
g')
                (CycleDetected Id
d' [Graph a -> Graph a]
as Pending
p', EdgeType
_) ->
                  let res' :: RoutingResult a
res' = forall a. Id -> [Graph a -> Graph a] -> Pending -> RoutingResult a
CycleDetected Id
d' (forall {m}. Graph m -> Graph m
exhaust forall a. a -> [a] -> [a]
: [Graph a -> Graph a]
as) Pending
p'
                      v' :: Vertex a
v' = Vertex a
v {vertexEdges :: Edges
vertexEdges = Edges
edges}
                   in (RoutingResult a
res', forall m. Vertex m -> Graph m -> Graph m
insert Vertex a
v' Graph a
g')
                (SinkFound Id
_, EdgeType
Normal) ->
                  let v' :: Vertex a
v' = Vertex a
v {vertexEdges :: Edges
vertexEdges = Edges
edges, vertexRouting :: Routing
vertexRouting = Routing
routing}
                   in (RoutingResult a
res, forall m. Vertex m -> Graph m -> Graph m
insert Vertex a
v' Graph a
g')
                (SinkFound Id
_, EdgeType
Reversed) ->
                  let v' :: Vertex a
v' = Vertex a
v {vertexEdges :: Edges
vertexEdges = Edges -> Edges
withPrev Edges
edges}
                   in (RoutingResult a
res, forall m. Vertex m -> Graph m -> Graph m
insert Vertex a
v' Graph a
g')

    routeNorms :: [Id] -> Graph a -> Pending -> (RoutingResult a, Graph a, [Id])
routeNorms [] Graph a
g0 Pending
_ = (forall a. RoutingResult a
DeadEnd, Graph a
g0, [])
    routeNorms (Id
e : [Id]
es) Graph a
g0 Pending
p0 =
      let (RoutingResult a
res, Graph a
g1) = forall m.
Pending
-> Id
-> Maybe Id
-> EdgeType
-> Id
-> Graph m
-> (RoutingResult m, Graph m)
route' Pending
p0 (Id
d forall a. Num a => a -> a -> a
+ Id
1) (forall a. a -> Maybe a
Just Id
i) EdgeType
Normal Id
e Graph a
g0
       in case RoutingResult a
res of
            RoutingResult a
DeadEnd -> [Id] -> Graph a -> Pending -> (RoutingResult a, Graph a, [Id])
routeNorms [Id]
es Graph a
g1 Pending
p0
            SinkFound Id
_ -> (RoutingResult a
res, Graph a
g1, [Id]
es)
            CycleDetected Id
_ [Graph a -> Graph a]
_ Pending
p1 ->
              let (RoutingResult a
res', Graph a
g2, [Id]
es') = [Id] -> Graph a -> Pending -> (RoutingResult a, Graph a, [Id])
routeNorms [Id]
es Graph a
g1 Pending
p1
               in (RoutingResult a
res forall a. Semigroup a => a -> a -> a
<> RoutingResult a
res', Graph a
g2, Id
e forall a. a -> [a] -> [a]
: [Id]
es')