{-# LANGUAGE TypeFamilies, BangPatterns, DeriveFunctor #-}
module Data.Graph.Haggle.PatriciaTree ( PatriciaTree ) where
import Control.DeepSeq
import Control.Monad ( guard )
import Data.Bifunctor
import Data.Foldable ( toList )
import Data.IntMap ( IntMap )
import qualified Data.IntMap as IM
import Data.Maybe ( fromMaybe )
import Data.Monoid
import Prelude
import qualified Data.Graph.Haggle.Classes as I
import qualified Data.Graph.Haggle.Internal.Basic as I
data Ctx nl el = Ctx !(IntMap el) I.Vertex nl !(IntMap el)
deriving forall a b. a -> Ctx nl b -> Ctx nl a
forall a b. (a -> b) -> Ctx nl a -> Ctx nl b
forall nl a b. a -> Ctx nl b -> Ctx nl a
forall nl a b. (a -> b) -> Ctx nl a -> Ctx nl b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Ctx nl b -> Ctx nl a
$c<$ :: forall nl a b. a -> Ctx nl b -> Ctx nl a
fmap :: forall a b. (a -> b) -> Ctx nl a -> Ctx nl b
$cfmap :: forall nl a b. (a -> b) -> Ctx nl a -> Ctx nl b
Functor
instance (NFData nl, NFData el) => NFData (Ctx nl el) where
rnf :: Ctx nl el -> ()
rnf (Ctx IntMap el
p Vertex
v nl
nl IntMap el
s) =
IntMap el
p forall a b. NFData a => a -> b -> b
`deepseq` IntMap el
s forall a b. NFData a => a -> b -> b
`deepseq` nl
nl forall a b. NFData a => a -> b -> b
`deepseq` Vertex
v seq :: forall a b. a -> b -> b
`seq` ()
data PatriciaTree nl el = Gr { forall nl el. PatriciaTree nl el -> IntMap (Ctx nl el)
graphRepr :: IntMap (Ctx nl el) }
deriving forall a b. a -> PatriciaTree nl b -> PatriciaTree nl a
forall a b. (a -> b) -> PatriciaTree nl a -> PatriciaTree nl b
forall nl a b. a -> PatriciaTree nl b -> PatriciaTree nl a
forall nl a b. (a -> b) -> PatriciaTree nl a -> PatriciaTree nl b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> PatriciaTree nl b -> PatriciaTree nl a
$c<$ :: forall nl a b. a -> PatriciaTree nl b -> PatriciaTree nl a
fmap :: forall a b. (a -> b) -> PatriciaTree nl a -> PatriciaTree nl b
$cfmap :: forall nl a b. (a -> b) -> PatriciaTree nl a -> PatriciaTree nl b
Functor
instance (NFData nl, NFData el) => NFData (PatriciaTree nl el) where
rnf :: PatriciaTree nl el -> ()
rnf (Gr IntMap (Ctx nl el)
im) = IntMap (Ctx nl el)
im forall a b. NFData a => a -> b -> b
`deepseq` ()
instance Bifunctor PatriciaTree where
first :: forall a b c. (a -> b) -> PatriciaTree a c -> PatriciaTree b c
first a -> b
f (Gr IntMap (Ctx a c)
im) =
let onNode :: Ctx a c -> Ctx b c
onNode (Ctx IntMap c
inM Vertex
v a
n IntMap c
outM) = forall nl el. IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
Ctx IntMap c
inM Vertex
v (a -> b
f a
n) IntMap c
outM
in forall nl el. IntMap (Ctx nl el) -> PatriciaTree nl el
Gr forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ctx a c -> Ctx b c
onNode IntMap (Ctx a c)
im
second :: forall b c a. (b -> c) -> PatriciaTree a b -> PatriciaTree a c
second b -> c
f (Gr IntMap (Ctx a b)
im) =
let onEdge :: Ctx a b -> Ctx a c
onEdge (Ctx IntMap b
inM Vertex
v a
n IntMap b
outM) = forall nl el. IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
Ctx (b -> c
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntMap b
inM) Vertex
v a
n (b -> c
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntMap b
outM)
in forall nl el. IntMap (Ctx nl el) -> PatriciaTree nl el
Gr forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ctx a b -> Ctx a c
onEdge IntMap (Ctx a b)
im
instance I.Graph (PatriciaTree nl el) where
vertices :: PatriciaTree nl el -> [Vertex]
vertices = forall a b. (a -> b) -> [a] -> [b]
map Int -> Vertex
I.V forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IntMap a -> [Int]
IM.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall nl el. PatriciaTree nl el -> IntMap (Ctx nl el)
graphRepr
isEmpty :: PatriciaTree nl el -> Bool
isEmpty = forall a. IntMap a -> Bool
IM.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall nl el. PatriciaTree nl el -> IntMap (Ctx nl el)
graphRepr
maxVertexId :: PatriciaTree nl el -> Int
maxVertexId (Gr IntMap (Ctx nl el)
g)
| forall a. IntMap a -> Bool
IM.null IntMap (Ctx nl el)
g = Int
0
| Bool
otherwise = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. IntMap a -> (Int, a)
IM.findMax IntMap (Ctx nl el)
g
edgesBetween :: PatriciaTree nl el -> Vertex -> Vertex -> [Edge]
edgesBetween (Gr IntMap (Ctx nl el)
g) (I.V Int
src) (I.V Int
dst) = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ do
Ctx IntMap el
_ Vertex
_ nl
_ IntMap el
ss <- forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
src IntMap (Ctx nl el)
g
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall a. Int -> IntMap a -> Bool
IM.member Int
dst IntMap el
ss)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> Int -> Edge
I.E (-Int
1) Int
src Int
dst)
edges :: PatriciaTree nl el -> [Edge]
edges PatriciaTree nl el
g = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall g. Graph g => g -> Vertex -> [Edge]
I.outEdges PatriciaTree nl el
g) (forall g. Graph g => g -> [Vertex]
I.vertices PatriciaTree nl el
g)
successors :: PatriciaTree nl el -> Vertex -> [Vertex]
successors (Gr IntMap (Ctx nl el)
g) (I.V Int
v) = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ do
Ctx IntMap el
_ Vertex
_ nl
_ IntMap el
ss <- forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
v IntMap (Ctx nl el)
g
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Int -> Vertex
I.V forall a b. (a -> b) -> a -> b
$ forall a. IntMap a -> [Int]
IM.keys IntMap el
ss
outEdges :: PatriciaTree nl el -> Vertex -> [Edge]
outEdges (Gr IntMap (Ctx nl el)
g) (I.V Int
v) = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ do
Ctx IntMap el
_ Vertex
_ nl
_ IntMap el
ss <- forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
v IntMap (Ctx nl el)
g
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Int -> Edge
toEdge (forall a. IntMap a -> [Int]
IM.keys IntMap el
ss)
where
toEdge :: Int -> Edge
toEdge Int
d = Int -> Int -> Int -> Edge
I.E (-Int
1) Int
v Int
d
instance I.HasEdgeLabel (PatriciaTree nl el) where
type EdgeLabel (PatriciaTree nl el) = el
edgeLabel :: PatriciaTree nl el
-> Edge -> Maybe (EdgeLabel (PatriciaTree nl el))
edgeLabel (Gr IntMap (Ctx nl el)
g) (I.E Int
_ Int
src Int
dst) = do
Ctx IntMap el
_ Vertex
_ nl
_ IntMap el
ss <- forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
src IntMap (Ctx nl el)
g
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
dst IntMap el
ss
labeledEdges :: PatriciaTree nl el -> [(Edge, EdgeLabel (PatriciaTree nl el))]
labeledEdges PatriciaTree nl el
gr = forall a b. (a -> b) -> [a] -> [b]
map Edge -> (Edge, el)
toLabEdge (forall g. Graph g => g -> [Edge]
I.edges PatriciaTree nl el
gr)
where
toLabEdge :: Edge -> (Edge, el)
toLabEdge Edge
e =
let Just EdgeLabel (PatriciaTree nl el)
lab = forall g. HasEdgeLabel g => g -> Edge -> Maybe (EdgeLabel g)
I.edgeLabel PatriciaTree nl el
gr Edge
e
in (Edge
e, EdgeLabel (PatriciaTree nl el)
lab)
labeledOutEdges :: PatriciaTree nl el
-> Vertex -> [(Edge, EdgeLabel (PatriciaTree nl el))]
labeledOutEdges (Gr IntMap (Ctx nl el)
g) (I.V Int
s) = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ do
Ctx IntMap el
_ Vertex
_ nl
_ IntMap el
ss <- forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
s IntMap (Ctx nl el)
g
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (Int -> a -> b -> b) -> b -> IntMap a -> b
IM.foldrWithKey Int -> el -> [(Edge, el)] -> [(Edge, el)]
toOut [] IntMap el
ss
where
toOut :: Int -> el -> [(Edge, el)] -> [(Edge, el)]
toOut Int
d el
lbl [(Edge, el)]
acc = (Int -> Int -> Int -> Edge
I.E (-Int
1) Int
s Int
d, el
lbl) forall a. a -> [a] -> [a]
: [(Edge, el)]
acc
instance I.HasVertexLabel (PatriciaTree nl el) where
type VertexLabel (PatriciaTree nl el) = nl
vertexLabel :: PatriciaTree nl el
-> Vertex -> Maybe (VertexLabel (PatriciaTree nl el))
vertexLabel (Gr IntMap (Ctx nl el)
g) (I.V Int
v) = do
Ctx IntMap el
_ Vertex
_ nl
lbl IntMap el
_ <- forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
v IntMap (Ctx nl el)
g
forall (m :: * -> *) a. Monad m => a -> m a
return nl
lbl
labeledVertices :: PatriciaTree nl el -> [(Vertex, VertexLabel (PatriciaTree nl el))]
labeledVertices PatriciaTree nl el
gr = forall a b. (a -> b) -> [a] -> [b]
map Vertex -> (Vertex, nl)
toLabVert (forall g. Graph g => g -> [Vertex]
I.vertices PatriciaTree nl el
gr)
where
toLabVert :: Vertex -> (Vertex, nl)
toLabVert Vertex
v =
let Just VertexLabel (PatriciaTree nl el)
l = forall g. HasVertexLabel g => g -> Vertex -> Maybe (VertexLabel g)
I.vertexLabel PatriciaTree nl el
gr Vertex
v
in (Vertex
v, VertexLabel (PatriciaTree nl el)
l)
instance I.Bidirectional (PatriciaTree nl el) where
predecessors :: PatriciaTree nl el -> Vertex -> [Vertex]
predecessors (Gr IntMap (Ctx nl el)
g) (I.V Int
v) = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ do
Ctx IntMap el
pp Vertex
_ nl
_ IntMap el
_ <- forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
v IntMap (Ctx nl el)
g
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Int -> Vertex
I.V (forall a. IntMap a -> [Int]
IM.keys IntMap el
pp)
inEdges :: PatriciaTree nl el -> Vertex -> [Edge]
inEdges (Gr IntMap (Ctx nl el)
g) (I.V Int
v) = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ do
Ctx IntMap el
pp Vertex
_ nl
_ IntMap el
_ <- forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
v IntMap (Ctx nl el)
g
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Int -> Edge
toEdge (forall a. IntMap a -> [Int]
IM.keys IntMap el
pp)
where
toEdge :: Int -> Edge
toEdge Int
s = Int -> Int -> Int -> Edge
I.E (-Int
1) Int
s Int
v
instance I.BidirectionalEdgeLabel (PatriciaTree nl el) where
labeledInEdges :: PatriciaTree nl el
-> Vertex -> [(Edge, EdgeLabel (PatriciaTree nl el))]
labeledInEdges (Gr IntMap (Ctx nl el)
g) (I.V Int
d) = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ do
Ctx IntMap el
pp Vertex
_ nl
_ IntMap el
_ <- forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
d IntMap (Ctx nl el)
g
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (Int -> a -> b -> b) -> b -> IntMap a -> b
IM.foldrWithKey Int -> el -> [(Edge, el)] -> [(Edge, el)]
toIn [] IntMap el
pp
where
toIn :: Int -> el -> [(Edge, el)] -> [(Edge, el)]
toIn Int
s el
lbl [(Edge, el)]
acc = (Int -> Int -> Int -> Edge
I.E (-Int
1) Int
s Int
d, el
lbl) forall a. a -> [a] -> [a]
: [(Edge, el)]
acc
instance I.InductiveGraph (PatriciaTree nl el) where
emptyGraph :: PatriciaTree nl el
emptyGraph = forall nl el. IntMap (Ctx nl el) -> PatriciaTree nl el
Gr forall a. IntMap a
IM.empty
insertLabeledVertex :: PatriciaTree nl el
-> VertexLabel (PatriciaTree nl el) -> (Vertex, PatriciaTree nl el)
insertLabeledVertex gr :: PatriciaTree nl el
gr@(Gr IntMap (Ctx nl el)
g) VertexLabel (PatriciaTree nl el)
lab =
let vid :: Int
vid = forall g. Graph g => g -> Int
I.maxVertexId PatriciaTree nl el
gr forall a. Num a => a -> a -> a
+ Int
1
v :: Vertex
v = Int -> Vertex
I.V Int
vid
g' :: IntMap (Ctx nl el)
g' = forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
vid (forall nl el. IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
Ctx forall a. Monoid a => a
mempty Vertex
v VertexLabel (PatriciaTree nl el)
lab forall a. Monoid a => a
mempty) IntMap (Ctx nl el)
g
in (Vertex
v, forall nl el. IntMap (Ctx nl el) -> PatriciaTree nl el
Gr IntMap (Ctx nl el)
g')
replaceLabeledVertex :: PatriciaTree nl el
-> Vertex -> VertexLabel (PatriciaTree nl el) -> PatriciaTree nl el
replaceLabeledVertex (Gr IntMap (Ctx nl el)
g) (I.V Int
v) VertexLabel (PatriciaTree nl el)
vl =
let updLabel :: Ctx nl el -> Ctx nl el
updLabel (Ctx IntMap el
ie Vertex
nv nl
_nl IntMap el
oe) = forall nl el. IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
Ctx IntMap el
ie Vertex
nv VertexLabel (PatriciaTree nl el)
vl IntMap el
oe
in forall nl el. IntMap (Ctx nl el) -> PatriciaTree nl el
Gr forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IM.adjust Ctx nl el -> Ctx nl el
updLabel Int
v IntMap (Ctx nl el)
g
insertLabeledEdge :: PatriciaTree nl el
-> Vertex
-> Vertex
-> EdgeLabel (PatriciaTree nl el)
-> Maybe (Edge, PatriciaTree nl el)
insertLabeledEdge gr :: PatriciaTree nl el
gr@(Gr IntMap (Ctx nl el)
g) v1 :: Vertex
v1@(I.V Int
src) (I.V Int
dst) EdgeLabel (PatriciaTree nl el)
lab | Int
src forall a. Eq a => a -> a -> Bool
== Int
dst = do
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall a. Int -> IntMap a -> Bool
IM.member Int
src IntMap (Ctx nl el)
g)
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (forall g. Graph g => g -> Vertex -> Vertex -> Bool
I.edgeExists PatriciaTree nl el
gr Vertex
v1 Vertex
v1))
let e :: Edge
e = Int -> Int -> Int -> Edge
I.E (-Int
1) Int
src Int
src
Ctx IntMap el
spp Vertex
sv nl
sl IntMap el
sss <- forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
src IntMap (Ctx nl el)
g
let ctx' :: Ctx nl el
ctx' = forall nl el. IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
Ctx (forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
src EdgeLabel (PatriciaTree nl el)
lab IntMap el
spp) Vertex
sv nl
sl (forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
dst EdgeLabel (PatriciaTree nl el)
lab IntMap el
sss)
!g' :: IntMap (Ctx nl el)
g' = forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
src Ctx nl el
ctx' IntMap (Ctx nl el)
g
forall (m :: * -> *) a. Monad m => a -> m a
return (Edge
e, forall nl el. IntMap (Ctx nl el) -> PatriciaTree nl el
Gr IntMap (Ctx nl el)
g')
insertLabeledEdge gr :: PatriciaTree nl el
gr@(Gr IntMap (Ctx nl el)
g) v1 :: Vertex
v1@(I.V Int
src) v2 :: Vertex
v2@(I.V Int
dst) EdgeLabel (PatriciaTree nl el)
lab = do
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall a. Int -> IntMap a -> Bool
IM.member Int
src IntMap (Ctx nl el)
g Bool -> Bool -> Bool
&& forall a. Int -> IntMap a -> Bool
IM.member Int
dst IntMap (Ctx nl el)
g)
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (forall g. Graph g => g -> Vertex -> Vertex -> Bool
I.edgeExists PatriciaTree nl el
gr Vertex
v1 Vertex
v2))
let e :: Edge
e = Int -> Int -> Int -> Edge
I.E (-Int
1) Int
src Int
dst
Ctx IntMap el
spp Vertex
sv nl
sl IntMap el
sss <- forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
src IntMap (Ctx nl el)
g
Ctx IntMap el
dpp Vertex
dv nl
dl IntMap el
dss <- forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
dst IntMap (Ctx nl el)
g
let sctx' :: Ctx nl el
sctx' = forall nl el. IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
Ctx IntMap el
spp Vertex
sv nl
sl (forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
dst EdgeLabel (PatriciaTree nl el)
lab IntMap el
sss)
dctx' :: Ctx nl el
dctx' = forall nl el. IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
Ctx (forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
src EdgeLabel (PatriciaTree nl el)
lab IntMap el
dpp) Vertex
dv nl
dl IntMap el
dss
!g' :: IntMap (Ctx nl el)
g' = forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
src Ctx nl el
sctx' IntMap (Ctx nl el)
g
!g'' :: IntMap (Ctx nl el)
g'' = forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
dst Ctx nl el
dctx' IntMap (Ctx nl el)
g'
forall (m :: * -> *) a. Monad m => a -> m a
return (Edge
e, forall nl el. IntMap (Ctx nl el) -> PatriciaTree nl el
Gr IntMap (Ctx nl el)
g'')
deleteEdge :: PatriciaTree nl el -> Edge -> PatriciaTree nl el
deleteEdge PatriciaTree nl el
g (I.E Int
_ Int
s Int
d) = forall g. InductiveGraph g => g -> Vertex -> Vertex -> g
I.deleteEdgesBetween PatriciaTree nl el
g (Int -> Vertex
I.V Int
s) (Int -> Vertex
I.V Int
d)
deleteEdgesBetween :: PatriciaTree nl el -> Vertex -> Vertex -> PatriciaTree nl el
deleteEdgesBetween gr :: PatriciaTree nl el
gr@(Gr IntMap (Ctx nl el)
g) (I.V Int
src) (I.V Int
dst) | Int
src forall a. Eq a => a -> a -> Bool
== Int
dst = forall a. a -> Maybe a -> a
fromMaybe PatriciaTree nl el
gr forall a b. (a -> b) -> a -> b
$ do
Ctx IntMap el
spp Vertex
sv nl
sl IntMap el
sss <- forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
src IntMap (Ctx nl el)
g
let ctx' :: Ctx nl el
ctx' = forall nl el. IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
Ctx (forall a. Int -> IntMap a -> IntMap a
IM.delete Int
src IntMap el
spp) Vertex
sv nl
sl (forall a. Int -> IntMap a -> IntMap a
IM.delete Int
src IntMap el
sss)
!g' :: IntMap (Ctx nl el)
g' = forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
src Ctx nl el
ctx' IntMap (Ctx nl el)
g
forall (m :: * -> *) a. Monad m => a -> m a
return (forall nl el. IntMap (Ctx nl el) -> PatriciaTree nl el
Gr IntMap (Ctx nl el)
g')
deleteEdgesBetween gr :: PatriciaTree nl el
gr@(Gr IntMap (Ctx nl el)
g) (I.V Int
src) (I.V Int
dst) = forall a. a -> Maybe a -> a
fromMaybe PatriciaTree nl el
gr forall a b. (a -> b) -> a -> b
$ do
Ctx IntMap el
spp Vertex
sv nl
sl IntMap el
sss <- forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
src IntMap (Ctx nl el)
g
Ctx IntMap el
dpp Vertex
dv nl
dl IntMap el
dss <- forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
dst IntMap (Ctx nl el)
g
let sctx' :: Ctx nl el
sctx' = forall nl el. IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
Ctx IntMap el
spp Vertex
sv nl
sl (forall a. Int -> IntMap a -> IntMap a
IM.delete Int
dst IntMap el
sss)
dctx' :: Ctx nl el
dctx' = forall nl el. IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
Ctx (forall a. Int -> IntMap a -> IntMap a
IM.delete Int
src IntMap el
dpp) Vertex
dv nl
dl IntMap el
dss
!g' :: IntMap (Ctx nl el)
g' = forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
src Ctx nl el
sctx' IntMap (Ctx nl el)
g
!g'' :: IntMap (Ctx nl el)
g'' = forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
dst Ctx nl el
dctx' IntMap (Ctx nl el)
g'
forall (m :: * -> *) a. Monad m => a -> m a
return (forall nl el. IntMap (Ctx nl el) -> PatriciaTree nl el
Gr IntMap (Ctx nl el)
g'')
context :: PatriciaTree nl el
-> Vertex -> Maybe (Context (PatriciaTree nl el))
context (Gr IntMap (Ctx nl el)
g) (I.V Int
v) = do
Ctx IntMap el
pp Vertex
_ nl
l IntMap el
ss <- forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
v IntMap (Ctx nl el)
g
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall g.
[(EdgeLabel g, Vertex)]
-> VertexLabel g -> [(EdgeLabel g, Vertex)] -> Context g
I.Context (forall a. IntMap a -> [(a, Vertex)]
toAdj IntMap el
pp) nl
l (forall a. IntMap a -> [(a, Vertex)]
toAdj IntMap el
ss)
match :: PatriciaTree nl el
-> Vertex
-> Maybe (Context (PatriciaTree nl el), PatriciaTree nl el)
match (Gr IntMap (Ctx nl el)
g) (I.V Int
v) = do
Ctx IntMap el
pp Vertex
_ nl
l IntMap el
ss <- forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
v IntMap (Ctx nl el)
g
let g' :: IntMap (Ctx nl el)
g' = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IM.adjust (forall nl el. Int -> Ctx nl el -> Ctx nl el
removeSucc Int
v)) IntMap (Ctx nl el)
g (forall a. IntMap a -> [Int]
IM.keys IntMap el
pp)
g'' :: IntMap (Ctx nl el)
g'' = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IM.adjust (forall nl el. Int -> Ctx nl el -> Ctx nl el
removePred Int
v)) IntMap (Ctx nl el)
g' (forall a. IntMap a -> [Int]
IM.keys IntMap el
ss)
g''' :: IntMap (Ctx nl el)
g''' = forall a. Int -> IntMap a -> IntMap a
IM.delete Int
v IntMap (Ctx nl el)
g''
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall g.
[(EdgeLabel g, Vertex)]
-> VertexLabel g -> [(EdgeLabel g, Vertex)] -> Context g
I.Context (forall a. IntMap a -> [(a, Vertex)]
toAdj IntMap el
pp) nl
l (forall a. IntMap a -> [(a, Vertex)]
toAdj IntMap el
ss), forall nl el. IntMap (Ctx nl el) -> PatriciaTree nl el
Gr IntMap (Ctx nl el)
g''')
toAdj :: IntMap a -> [(a, I.Vertex)]
toAdj :: forall a. IntMap a -> [(a, Vertex)]
toAdj = forall a b. (Int -> a -> b -> b) -> b -> IntMap a -> b
IM.foldrWithKey forall {a}. Int -> a -> [(a, Vertex)] -> [(a, Vertex)]
f []
where
f :: Int -> a -> [(a, Vertex)] -> [(a, Vertex)]
f Int
dst a
lbl [(a, Vertex)]
acc = (a
lbl, Int -> Vertex
I.V Int
dst) forall a. a -> [a] -> [a]
: [(a, Vertex)]
acc
removeSucc :: Int -> Ctx nl el -> Ctx nl el
removeSucc :: forall nl el. Int -> Ctx nl el -> Ctx nl el
removeSucc Int
v (Ctx IntMap el
pp Vertex
vert nl
lbl IntMap el
ss) =
forall nl el. IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
Ctx IntMap el
pp Vertex
vert nl
lbl (forall a. Int -> IntMap a -> IntMap a
IM.delete Int
v IntMap el
ss)
removePred :: Int -> Ctx nl el -> Ctx nl el
removePred :: forall nl el. Int -> Ctx nl el -> Ctx nl el
removePred Int
v (Ctx IntMap el
pp Vertex
vert nl
lbl IntMap el
ss) =
forall nl el. IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
Ctx (forall a. Int -> IntMap a -> IntMap a
IM.delete Int
v IntMap el
pp) Vertex
vert nl
lbl IntMap el
ss