{-# LANGUAGE TypeFamilies, BangPatterns, DeriveFunctor #-}
-- | This graph is based on the implementation in fgl (using
-- big-endian patricia-tries -- IntMap).
--
-- This formulation does not support parallel edges.
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` ()

-- | The 'PatriciaTree' is a graph implementing the 'I.InductiveGraph'
-- interface (as well as the other immutable graph interfaces).  It is
-- based on the graph type provided by fgl.
--
-- Inductive graphs support more interesting decompositions than the
-- other graph interfaces in this library, at the cost of less compact
-- representations and some additional overhead on some operations, as
-- most must go through the 'I.match' operator.
--
-- This graph type is most useful for incremental construction in pure
-- code.  It also supports node removal from pure code.
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

{- Note [Representation]

Since this graph does not support parallel edges, the edge ID does not
actually matter.  This implementation will let it always be zero.  Edge
identity can be recovered with just (src, dst).

-}