{-# LANGUAGE TypeFamilies, BangPatterns #-}
-- | 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)

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 IntMap el -> IntMap el -> IntMap el
forall a b. NFData a => a -> b -> b
`deepseq` IntMap el
s IntMap el -> nl -> nl
forall a b. NFData a => a -> b -> b
`deepseq` nl
nl nl -> Vertex -> Vertex
forall a b. NFData a => a -> b -> b
`deepseq` Vertex
v Vertex -> () -> ()
`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 { PatriciaTree nl el -> IntMap (Ctx nl el)
graphRepr :: IntMap (Ctx nl el) }

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 IntMap (Ctx nl el) -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` ()

instance Bifunctor PatriciaTree where
  first :: (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) = IntMap c -> Vertex -> b -> IntMap c -> Ctx b c
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 IntMap (Ctx b c) -> PatriciaTree b c
forall nl el. IntMap (Ctx nl el) -> PatriciaTree nl el
Gr (IntMap (Ctx b c) -> PatriciaTree b c)
-> IntMap (Ctx b c) -> PatriciaTree b c
forall a b. (a -> b) -> a -> b
$ (Ctx a c -> Ctx b c) -> IntMap (Ctx a c) -> IntMap (Ctx b c)
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 :: (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) = IntMap c -> Vertex -> a -> IntMap c -> Ctx a c
forall nl el. IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
Ctx (b -> c
f (b -> c) -> IntMap b -> IntMap c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntMap b
inM) Vertex
v a
n (b -> c
f (b -> c) -> IntMap b -> IntMap c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntMap b
outM)
    in IntMap (Ctx a c) -> PatriciaTree a c
forall nl el. IntMap (Ctx nl el) -> PatriciaTree nl el
Gr (IntMap (Ctx a c) -> PatriciaTree a c)
-> IntMap (Ctx a c) -> PatriciaTree a c
forall a b. (a -> b) -> a -> b
$ (Ctx a b -> Ctx a c) -> IntMap (Ctx a b) -> IntMap (Ctx a c)
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 = (Int -> Vertex) -> [Int] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Vertex
I.V ([Int] -> [Vertex])
-> (PatriciaTree nl el -> [Int]) -> PatriciaTree nl el -> [Vertex]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap (Ctx nl el) -> [Int]
forall a. IntMap a -> [Int]
IM.keys (IntMap (Ctx nl el) -> [Int])
-> (PatriciaTree nl el -> IntMap (Ctx nl el))
-> PatriciaTree nl el
-> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatriciaTree nl el -> IntMap (Ctx nl el)
forall nl el. PatriciaTree nl el -> IntMap (Ctx nl el)
graphRepr
  isEmpty :: PatriciaTree nl el -> Bool
isEmpty = IntMap (Ctx nl el) -> Bool
forall a. IntMap a -> Bool
IM.null (IntMap (Ctx nl el) -> Bool)
-> (PatriciaTree nl el -> IntMap (Ctx nl el))
-> PatriciaTree nl el
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatriciaTree nl el -> IntMap (Ctx nl el)
forall nl el. PatriciaTree nl el -> IntMap (Ctx nl el)
graphRepr
  maxVertexId :: PatriciaTree nl el -> Int
maxVertexId (Gr IntMap (Ctx nl el)
g)
    | IntMap (Ctx nl el) -> Bool
forall a. IntMap a -> Bool
IM.null IntMap (Ctx nl el)
g = Int
0
    | Bool
otherwise = (Int, Ctx nl el) -> Int
forall a b. (a, b) -> a
fst ((Int, Ctx nl el) -> Int) -> (Int, Ctx nl el) -> Int
forall a b. (a -> b) -> a -> b
$ IntMap (Ctx nl el) -> (Int, Ctx nl el)
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) = Maybe Edge -> [Edge]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe Edge -> [Edge]) -> Maybe Edge -> [Edge]
forall a b. (a -> b) -> a -> b
$ do
    Ctx IntMap el
_ Vertex
_ nl
_ IntMap el
ss <- Int -> IntMap (Ctx nl el) -> Maybe (Ctx nl el)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
src IntMap (Ctx nl el)
g
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int -> IntMap el -> Bool
forall a. Int -> IntMap a -> Bool
IM.member Int
dst IntMap el
ss)
    Edge -> Maybe Edge
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 = (Vertex -> [Edge]) -> [Vertex] -> [Edge]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (PatriciaTree nl el -> Vertex -> [Edge]
forall g. Graph g => g -> Vertex -> [Edge]
I.outEdges PatriciaTree nl el
g) (PatriciaTree nl el -> [Vertex]
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) = [Vertex] -> Maybe [Vertex] -> [Vertex]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Vertex] -> [Vertex]) -> Maybe [Vertex] -> [Vertex]
forall a b. (a -> b) -> a -> b
$ do
    Ctx IntMap el
_ Vertex
_ nl
_ IntMap el
ss <- Int -> IntMap (Ctx nl el) -> Maybe (Ctx nl el)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
v IntMap (Ctx nl el)
g
    [Vertex] -> Maybe [Vertex]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Vertex] -> Maybe [Vertex]) -> [Vertex] -> Maybe [Vertex]
forall a b. (a -> b) -> a -> b
$ (Int -> Vertex) -> [Int] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Vertex
I.V ([Int] -> [Vertex]) -> [Int] -> [Vertex]
forall a b. (a -> b) -> a -> b
$ IntMap el -> [Int]
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) = [Edge] -> Maybe [Edge] -> [Edge]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Edge] -> [Edge]) -> Maybe [Edge] -> [Edge]
forall a b. (a -> b) -> a -> b
$ do
    Ctx IntMap el
_ Vertex
_ nl
_ IntMap el
ss <- Int -> IntMap (Ctx nl el) -> Maybe (Ctx nl el)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
v IntMap (Ctx nl el)
g
    [Edge] -> Maybe [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Edge] -> Maybe [Edge]) -> [Edge] -> Maybe [Edge]
forall a b. (a -> b) -> a -> b
$ (Int -> Edge) -> [Int] -> [Edge]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Edge
toEdge (IntMap el -> [Int]
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 <- Int -> IntMap (Ctx nl el) -> Maybe (Ctx nl el)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
src IntMap (Ctx nl el)
g
    Int -> IntMap el -> Maybe el
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 = (Edge -> (Edge, el)) -> [Edge] -> [(Edge, el)]
forall a b. (a -> b) -> [a] -> [b]
map Edge -> (Edge, el)
toLabEdge (PatriciaTree nl el -> [Edge]
forall g. Graph g => g -> [Edge]
I.edges PatriciaTree nl el
gr)
    where
      toLabEdge :: Edge -> (Edge, el)
toLabEdge Edge
e =
        let Just el
lab = PatriciaTree nl el
-> Edge -> Maybe (EdgeLabel (PatriciaTree nl el))
forall g. HasEdgeLabel g => g -> Edge -> Maybe (EdgeLabel g)
I.edgeLabel PatriciaTree nl el
gr Edge
e
        in (Edge
e, el
lab)
  labeledOutEdges :: PatriciaTree nl el
-> Vertex -> [(Edge, EdgeLabel (PatriciaTree nl el))]
labeledOutEdges (Gr IntMap (Ctx nl el)
g) (I.V Int
s) = [(Edge, el)] -> Maybe [(Edge, el)] -> [(Edge, el)]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [(Edge, el)] -> [(Edge, el)])
-> Maybe [(Edge, el)] -> [(Edge, el)]
forall a b. (a -> b) -> a -> b
$ do
    Ctx IntMap el
_ Vertex
_ nl
_ IntMap el
ss <- Int -> IntMap (Ctx nl el) -> Maybe (Ctx nl el)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
s IntMap (Ctx nl el)
g
    [(Edge, el)] -> Maybe [(Edge, el)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Edge, el)] -> Maybe [(Edge, el)])
-> [(Edge, el)] -> Maybe [(Edge, el)]
forall a b. (a -> b) -> a -> b
$ (Int -> el -> [(Edge, el)] -> [(Edge, el)])
-> [(Edge, el)] -> IntMap el -> [(Edge, el)]
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) (Edge, el) -> [(Edge, el)] -> [(Edge, el)]
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
_ <- Int -> IntMap (Ctx nl el) -> Maybe (Ctx nl el)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
v IntMap (Ctx nl el)
g
    nl -> Maybe nl
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 = (Vertex -> (Vertex, nl)) -> [Vertex] -> [(Vertex, nl)]
forall a b. (a -> b) -> [a] -> [b]
map Vertex -> (Vertex, nl)
toLabVert (PatriciaTree nl el -> [Vertex]
forall g. Graph g => g -> [Vertex]
I.vertices PatriciaTree nl el
gr)
    where
      toLabVert :: Vertex -> (Vertex, nl)
toLabVert Vertex
v =
        let Just nl
l = PatriciaTree nl el
-> Vertex -> Maybe (VertexLabel (PatriciaTree nl el))
forall g. HasVertexLabel g => g -> Vertex -> Maybe (VertexLabel g)
I.vertexLabel PatriciaTree nl el
gr Vertex
v
        in (Vertex
v, nl
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) = [Vertex] -> Maybe [Vertex] -> [Vertex]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Vertex] -> [Vertex]) -> Maybe [Vertex] -> [Vertex]
forall a b. (a -> b) -> a -> b
$ do
    Ctx IntMap el
pp Vertex
_ nl
_ IntMap el
_ <- Int -> IntMap (Ctx nl el) -> Maybe (Ctx nl el)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
v IntMap (Ctx nl el)
g
    [Vertex] -> Maybe [Vertex]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Vertex] -> Maybe [Vertex]) -> [Vertex] -> Maybe [Vertex]
forall a b. (a -> b) -> a -> b
$ (Int -> Vertex) -> [Int] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Vertex
I.V (IntMap el -> [Int]
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) = [Edge] -> Maybe [Edge] -> [Edge]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Edge] -> [Edge]) -> Maybe [Edge] -> [Edge]
forall a b. (a -> b) -> a -> b
$ do
    Ctx IntMap el
pp Vertex
_ nl
_ IntMap el
_ <- Int -> IntMap (Ctx nl el) -> Maybe (Ctx nl el)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
v IntMap (Ctx nl el)
g
    [Edge] -> Maybe [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Edge] -> Maybe [Edge]) -> [Edge] -> Maybe [Edge]
forall a b. (a -> b) -> a -> b
$ (Int -> Edge) -> [Int] -> [Edge]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Edge
toEdge (IntMap el -> [Int]
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) = [(Edge, el)] -> Maybe [(Edge, el)] -> [(Edge, el)]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [(Edge, el)] -> [(Edge, el)])
-> Maybe [(Edge, el)] -> [(Edge, el)]
forall a b. (a -> b) -> a -> b
$ do
    Ctx IntMap el
pp Vertex
_ nl
_ IntMap el
_ <- Int -> IntMap (Ctx nl el) -> Maybe (Ctx nl el)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
d IntMap (Ctx nl el)
g
    [(Edge, el)] -> Maybe [(Edge, el)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Edge, el)] -> Maybe [(Edge, el)])
-> [(Edge, el)] -> Maybe [(Edge, el)]
forall a b. (a -> b) -> a -> b
$ (Int -> el -> [(Edge, el)] -> [(Edge, el)])
-> [(Edge, el)] -> IntMap el -> [(Edge, el)]
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) (Edge, el) -> [(Edge, el)] -> [(Edge, el)]
forall a. a -> [a] -> [a]
: [(Edge, el)]
acc

instance I.InductiveGraph (PatriciaTree nl el) where
  emptyGraph :: PatriciaTree nl el
emptyGraph = IntMap (Ctx nl el) -> PatriciaTree nl el
forall nl el. IntMap (Ctx nl el) -> PatriciaTree nl el
Gr IntMap (Ctx nl el)
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 = PatriciaTree nl el -> Int
forall g. Graph g => g -> Int
I.maxVertexId PatriciaTree nl el
gr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        v :: Vertex
v = Int -> Vertex
I.V Int
vid
        g' :: IntMap (Ctx nl el)
g' = Int -> Ctx nl el -> IntMap (Ctx nl el) -> IntMap (Ctx nl el)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
vid (IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
forall nl el. IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
Ctx IntMap el
forall a. Monoid a => a
mempty Vertex
v nl
VertexLabel (PatriciaTree nl el)
lab IntMap el
forall a. Monoid a => a
mempty) IntMap (Ctx nl el)
g
    in (Vertex
v, IntMap (Ctx nl el) -> PatriciaTree nl el
forall nl el. IntMap (Ctx nl el) -> PatriciaTree nl el
Gr 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) v2 :: Vertex
v2@(I.V Int
dst) EdgeLabel (PatriciaTree nl el)
lab = do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int -> IntMap (Ctx nl el) -> Bool
forall a. Int -> IntMap a -> Bool
IM.member Int
src IntMap (Ctx nl el)
g Bool -> Bool -> Bool
&& Int -> IntMap (Ctx nl el) -> Bool
forall a. Int -> IntMap a -> Bool
IM.member Int
dst IntMap (Ctx nl el)
g)
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (PatriciaTree nl el -> Vertex -> Vertex -> Bool
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 <- Int -> IntMap (Ctx nl el) -> Maybe (Ctx nl el)
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 <- Int -> IntMap (Ctx nl el) -> Maybe (Ctx nl el)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
dst IntMap (Ctx nl el)
g
    let sctx' :: Ctx nl el
sctx' = IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
forall nl el. IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
Ctx IntMap el
spp Vertex
sv nl
sl (Int -> el -> IntMap el -> IntMap el
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
dst el
EdgeLabel (PatriciaTree nl el)
lab IntMap el
sss)
        dctx' :: Ctx nl el
dctx' = IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
forall nl el. IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
Ctx (Int -> el -> IntMap el -> IntMap el
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
src el
EdgeLabel (PatriciaTree nl el)
lab IntMap el
dpp) Vertex
dv nl
dl IntMap el
dss
        !g' :: IntMap (Ctx nl el)
g' = Int -> Ctx nl el -> IntMap (Ctx nl el) -> IntMap (Ctx nl el)
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'' = Int -> Ctx nl el -> IntMap (Ctx nl el) -> IntMap (Ctx nl el)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
dst Ctx nl el
dctx' IntMap (Ctx nl el)
g'
    (Edge, PatriciaTree nl el) -> Maybe (Edge, PatriciaTree nl el)
forall (m :: * -> *) a. Monad m => a -> m a
return (Edge
e, IntMap (Ctx nl el) -> PatriciaTree nl el
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) = PatriciaTree nl el -> Vertex -> Vertex -> PatriciaTree nl el
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) = PatriciaTree nl el
-> Maybe (PatriciaTree nl el) -> PatriciaTree nl el
forall a. a -> Maybe a -> a
fromMaybe PatriciaTree nl el
gr (Maybe (PatriciaTree nl el) -> PatriciaTree nl el)
-> Maybe (PatriciaTree nl el) -> PatriciaTree nl el
forall a b. (a -> b) -> a -> b
$ do
    Ctx IntMap el
spp Vertex
sv nl
sl IntMap el
sss <- Int -> IntMap (Ctx nl el) -> Maybe (Ctx nl el)
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 <- Int -> IntMap (Ctx nl el) -> Maybe (Ctx nl el)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
dst IntMap (Ctx nl el)
g
    let sctx' :: Ctx nl el
sctx' = IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
forall nl el. IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
Ctx IntMap el
spp Vertex
sv nl
sl (Int -> IntMap el -> IntMap el
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
dst IntMap el
sss)
        dctx' :: Ctx nl el
dctx' = IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
forall nl el. IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
Ctx (Int -> IntMap el -> IntMap el
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' = Int -> Ctx nl el -> IntMap (Ctx nl el) -> IntMap (Ctx nl el)
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'' = Int -> Ctx nl el -> IntMap (Ctx nl el) -> IntMap (Ctx nl el)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
dst Ctx nl el
dctx' IntMap (Ctx nl el)
g'
    PatriciaTree nl el -> Maybe (PatriciaTree nl el)
forall (m :: * -> *) a. Monad m => a -> m a
return (IntMap (Ctx nl el) -> PatriciaTree nl el
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 <- Int -> IntMap (Ctx nl el) -> Maybe (Ctx nl el)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
v IntMap (Ctx nl el)
g
    Context (PatriciaTree nl el)
-> Maybe (Context (PatriciaTree nl el))
forall (m :: * -> *) a. Monad m => a -> m a
return (Context (PatriciaTree nl el)
 -> Maybe (Context (PatriciaTree nl el)))
-> Context (PatriciaTree nl el)
-> Maybe (Context (PatriciaTree nl el))
forall a b. (a -> b) -> a -> b
$ [(EdgeLabel (PatriciaTree nl el), Vertex)]
-> VertexLabel (PatriciaTree nl el)
-> [(EdgeLabel (PatriciaTree nl el), Vertex)]
-> Context (PatriciaTree nl el)
forall g.
[(EdgeLabel g, Vertex)]
-> VertexLabel g -> [(EdgeLabel g, Vertex)] -> Context g
I.Context (IntMap el -> [(el, Vertex)]
forall a. IntMap a -> [(a, Vertex)]
toAdj IntMap el
pp) nl
VertexLabel (PatriciaTree nl el)
l (IntMap el -> [(el, Vertex)]
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 <- Int -> IntMap (Ctx nl el) -> Maybe (Ctx nl el)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
v IntMap (Ctx nl el)
g
    let g' :: IntMap (Ctx nl el)
g' = (Int -> IntMap (Ctx nl el) -> IntMap (Ctx nl el))
-> IntMap (Ctx nl el) -> [Int] -> IntMap (Ctx nl el)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Ctx nl el -> Ctx nl el)
-> Int -> IntMap (Ctx nl el) -> IntMap (Ctx nl el)
forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IM.adjust (Int -> Ctx nl el -> Ctx nl el
forall nl el. Int -> Ctx nl el -> Ctx nl el
removeSucc Int
v)) IntMap (Ctx nl el)
g (IntMap el -> [Int]
forall a. IntMap a -> [Int]
IM.keys IntMap el
pp)
        g'' :: IntMap (Ctx nl el)
g'' = (Int -> IntMap (Ctx nl el) -> IntMap (Ctx nl el))
-> IntMap (Ctx nl el) -> [Int] -> IntMap (Ctx nl el)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Ctx nl el -> Ctx nl el)
-> Int -> IntMap (Ctx nl el) -> IntMap (Ctx nl el)
forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IM.adjust (Int -> Ctx nl el -> Ctx nl el
forall nl el. Int -> Ctx nl el -> Ctx nl el
removePred Int
v)) IntMap (Ctx nl el)
g' (IntMap el -> [Int]
forall a. IntMap a -> [Int]
IM.keys IntMap el
ss)
        g''' :: IntMap (Ctx nl el)
g''' = Int -> IntMap (Ctx nl el) -> IntMap (Ctx nl el)
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
v IntMap (Ctx nl el)
g''
    (Context (PatriciaTree nl el), PatriciaTree nl el)
-> Maybe (Context (PatriciaTree nl el), PatriciaTree nl el)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Context (PatriciaTree nl el), PatriciaTree nl el)
 -> Maybe (Context (PatriciaTree nl el), PatriciaTree nl el))
-> (Context (PatriciaTree nl el), PatriciaTree nl el)
-> Maybe (Context (PatriciaTree nl el), PatriciaTree nl el)
forall a b. (a -> b) -> a -> b
$ ([(EdgeLabel (PatriciaTree nl el), Vertex)]
-> VertexLabel (PatriciaTree nl el)
-> [(EdgeLabel (PatriciaTree nl el), Vertex)]
-> Context (PatriciaTree nl el)
forall g.
[(EdgeLabel g, Vertex)]
-> VertexLabel g -> [(EdgeLabel g, Vertex)] -> Context g
I.Context (IntMap el -> [(el, Vertex)]
forall a. IntMap a -> [(a, Vertex)]
toAdj IntMap el
pp) nl
VertexLabel (PatriciaTree nl el)
l (IntMap el -> [(el, Vertex)]
forall a. IntMap a -> [(a, Vertex)]
toAdj IntMap el
ss), IntMap (Ctx nl el) -> PatriciaTree nl el
forall nl el. IntMap (Ctx nl el) -> PatriciaTree nl el
Gr IntMap (Ctx nl el)
g''')

toAdj :: IntMap a -> [(a, I.Vertex)]
toAdj :: IntMap a -> [(a, Vertex)]
toAdj = (Int -> a -> [(a, Vertex)] -> [(a, Vertex)])
-> [(a, Vertex)] -> IntMap a -> [(a, Vertex)]
forall a b. (Int -> a -> b -> b) -> b -> IntMap a -> b
IM.foldrWithKey Int -> a -> [(a, Vertex)] -> [(a, Vertex)]
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) (a, Vertex) -> [(a, Vertex)] -> [(a, Vertex)]
forall a. a -> [a] -> [a]
: [(a, Vertex)]
acc

removeSucc :: Int -> Ctx nl el -> Ctx nl el
removeSucc :: Int -> Ctx nl el -> Ctx nl el
removeSucc Int
v (Ctx IntMap el
pp Vertex
vert nl
lbl IntMap el
ss) =
  IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
forall nl el. IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
Ctx IntMap el
pp Vertex
vert nl
lbl (Int -> IntMap el -> IntMap el
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
v IntMap el
ss)

removePred :: Int -> Ctx nl el -> Ctx nl el
removePred :: Int -> Ctx nl el -> Ctx nl el
removePred Int
v (Ctx IntMap el
pp Vertex
vert nl
lbl IntMap el
ss) =
  IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
forall nl el. IntMap el -> Vertex -> nl -> IntMap el -> Ctx nl el
Ctx (Int -> IntMap el -> IntMap el
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).

-}