module Futhark.Optimise.ReduceDeviceSyncs.MigrationTable.Graph
(
Graph,
Id,
IdSet,
Vertex (..),
Routing (..),
Exhaustion (..),
Edges (..),
EdgeType (..),
Visited,
Result (..),
empty,
vertex,
declareEdges,
oneEdge,
none,
insert,
adjust,
connectToSink,
addEdges,
member,
lookup,
isSinkConnected,
route,
routeMany,
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)
newtype Graph m = Graph (IM.IntMap (Vertex m))
type Id = Int
type IdSet = IS.IntSet
data Vertex m = Vertex
{
forall m. Vertex m -> Id
vertexId :: Id,
forall m. Vertex m -> m
vertexMeta :: m,
forall m. Vertex m -> Routing
vertexRouting :: Routing,
forall m. Vertex m -> Edges
vertexEdges :: Edges
}
data Routing
=
NoRoute
|
FromSource
|
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)
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)
data Edges
=
ToSink
|
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
mempty :: Edges
mempty = IdSet -> Maybe IdSet -> Edges
ToNodes IdSet
IS.empty forall a. Maybe a
Nothing
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)
newtype Visited a = Visited {forall a. Visited a -> Map (EdgeType, Id) a
visited :: M.Map (EdgeType, Id) a}
data Result a
=
Produced a
|
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)
empty :: Graph m
empty :: forall m. Graph m
empty = forall m. IntMap (Vertex m) -> Graph m
Graph forall a. IntMap a
IM.empty
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
}
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
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
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
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
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
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}
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}
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
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
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)
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 :: [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')
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 ::
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)
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)
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)
type Pending = IM.IntMap Depth
type Depth = Int
data RoutingResult a
=
DeadEnd
|
CycleDetected Depth [Graph a -> Graph a] Pending
|
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
EdgeType
Normal -> forall {a}. (RoutingResult a, Graph m)
found_cycle
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
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 =
(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')