{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE DeriveGeneric #-}
#endif

-- |An efficient implementation of 'Data.Graph.Inductive.Graph.Graph'
-- using big-endian patricia tree (i.e. "Data.IntMap").
--
-- This module provides the following specialised functions to gain
-- more performance, using GHC's RULES pragma:
--
-- * 'Data.Graph.Inductive.Graph.insNode'
--
-- * 'Data.Graph.Inductive.Graph.insEdge'
--
-- * 'Data.Graph.Inductive.Graph.gmap'
--
-- * 'Data.Graph.Inductive.Graph.nmap'
--
-- * 'Data.Graph.Inductive.Graph.emap'

module Data.Graph.Inductive.PatriciaTree
    ( Gr
    , UGr
    )
    where

import Data.Graph.Inductive.Graph

import           Control.Applicative (liftA2)
import           Data.IntMap         (IntMap)
import qualified Data.IntMap         as IM
import           Data.List           (foldl', sort)
import           Data.Maybe          (fromMaybe)
import           Data.Tuple          (swap)

#if MIN_VERSION_containers (0,4,2)
import Control.DeepSeq (NFData(..))
#endif

#if MIN_VERSION_containers(0,5,0)
import qualified Data.IntMap.Strict as IMS
#else
import qualified Data.IntMap as IMS
#endif

#if __GLASGOW_HASKELL__ >= 702
import GHC.Generics (Generic)
#endif

#if MIN_VERSION_base (4,8,0)
import Data.Bifunctor
#else
import Control.Arrow (second)
#endif

----------------------------------------------------------------------
-- GRAPH REPRESENTATION
----------------------------------------------------------------------

newtype Gr a b = Gr (GraphRep a b)
#if __GLASGOW_HASKELL__ >= 702
  deriving ((forall x. Gr a b -> Rep (Gr a b) x)
-> (forall x. Rep (Gr a b) x -> Gr a b) -> Generic (Gr a b)
forall x. Rep (Gr a b) x -> Gr a b
forall x. Gr a b -> Rep (Gr a b) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a b x. Rep (Gr a b) x -> Gr a b
forall a b x. Gr a b -> Rep (Gr a b) x
$cto :: forall a b x. Rep (Gr a b) x -> Gr a b
$cfrom :: forall a b x. Gr a b -> Rep (Gr a b) x
Generic)
#endif

type GraphRep a b = IntMap (Context' a b)
type Context' a b = (IntMap [b], a, IntMap [b])

type UGr = Gr () ()

----------------------------------------------------------------------
-- CLASS INSTANCES
----------------------------------------------------------------------

instance (Eq a, Ord b) => Eq (Gr a b) where
  (Gr GraphRep a b
g1) == :: Gr a b -> Gr a b -> Bool
== (Gr GraphRep a b
g2) = ((IntMap [b], a, IntMap [b]) -> (IntMap [b], a, IntMap [b]))
-> GraphRep a b -> GraphRep a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IntMap [b], a, IntMap [b]) -> (IntMap [b], a, IntMap [b])
forall (f :: * -> *) (f :: * -> *) a a b.
(Functor f, Functor f, Ord a, Ord a) =>
(f [a], b, f [a]) -> (f [a], b, f [a])
sortAdj GraphRep a b
g1 GraphRep a b -> GraphRep a b -> Bool
forall a. Eq a => a -> a -> Bool
== ((IntMap [b], a, IntMap [b]) -> (IntMap [b], a, IntMap [b]))
-> GraphRep a b -> GraphRep a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IntMap [b], a, IntMap [b]) -> (IntMap [b], a, IntMap [b])
forall (f :: * -> *) (f :: * -> *) a a b.
(Functor f, Functor f, Ord a, Ord a) =>
(f [a], b, f [a]) -> (f [a], b, f [a])
sortAdj GraphRep a b
g2
    where
      sortAdj :: (f [a], b, f [a]) -> (f [a], b, f [a])
sortAdj (f [a]
p,b
n,f [a]
s) = (([a] -> [a]) -> f [a] -> f [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> [a]
forall a. Ord a => [a] -> [a]
sort f [a]
p,b
n,([a] -> [a]) -> f [a] -> f [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> [a]
forall a. Ord a => [a] -> [a]
sort f [a]
s)

instance (Show a, Show b) => Show (Gr a b) where
  showsPrec :: Int -> Gr a b -> ShowS
showsPrec Int
d Gr a b
g = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
                    String -> ShowS
showString String
"mkGraph "
                    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LNode a] -> ShowS
forall a. Show a => a -> ShowS
shows (Gr a b -> [LNode a]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes Gr a b
g)
                    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
                    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LEdge b] -> ShowS
forall a. Show a => a -> ShowS
shows (Gr a b -> [LEdge b]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges Gr a b
g)

instance (Read a, Read b) => Read (Gr a b) where
  readsPrec :: Int -> ReadS (Gr a b)
readsPrec Int
p = Bool -> ReadS (Gr a b) -> ReadS (Gr a b)
forall a. Bool -> ReadS a -> ReadS a
readParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ReadS (Gr a b) -> ReadS (Gr a b))
-> ReadS (Gr a b) -> ReadS (Gr a b)
forall a b. (a -> b) -> a -> b
$ \ String
r -> do
    (String
"mkGraph", String
s) <- ReadS String
lex String
r
    ([LNode a]
ns,String
t) <- ReadS [LNode a]
forall a. Read a => ReadS a
reads String
s
    ([LEdge b]
es,String
u) <- ReadS [LEdge b]
forall a. Read a => ReadS a
reads String
t
    (Gr a b, String) -> [(Gr a b, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([LNode a] -> [LEdge b] -> Gr a b
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [LNode a]
ns [LEdge b]
es, String
u)

instance Graph Gr where
    empty :: Gr a b
empty           = GraphRep a b -> Gr a b
forall a b. GraphRep a b -> Gr a b
Gr GraphRep a b
forall a. IntMap a
IM.empty

    isEmpty :: Gr a b -> Bool
isEmpty (Gr GraphRep a b
g)  = GraphRep a b -> Bool
forall a. IntMap a -> Bool
IM.null GraphRep a b
g

    match :: Int -> Gr a b -> Decomp Gr a b
match           = Int -> Gr a b -> Decomp Gr a b
forall a b. Int -> Gr a b -> Decomp Gr a b
matchGr

    mkGraph :: [LNode a] -> [LEdge b] -> Gr a b
mkGraph [LNode a]
vs [LEdge b]
es   = [LEdge b] -> Gr a b -> Gr a b
forall (gr :: * -> * -> *) b a.
DynGraph gr =>
[LEdge b] -> gr a b -> gr a b
insEdges [LEdge b]
es
                      (Gr a b -> Gr a b) -> ([LNode a] -> Gr a b) -> [LNode a] -> Gr a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GraphRep a b -> Gr a b
forall a b. GraphRep a b -> Gr a b
Gr
                      (GraphRep a b -> Gr a b)
-> ([LNode a] -> GraphRep a b) -> [LNode a] -> Gr a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, (IntMap [b], a, IntMap [b]))] -> GraphRep a b
forall a. [(Int, a)] -> IntMap a
IM.fromList
                      ([(Int, (IntMap [b], a, IntMap [b]))] -> GraphRep a b)
-> ([LNode a] -> [(Int, (IntMap [b], a, IntMap [b]))])
-> [LNode a]
-> GraphRep a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LNode a -> (Int, (IntMap [b], a, IntMap [b])))
-> [LNode a] -> [(Int, (IntMap [b], a, IntMap [b]))]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> (IntMap [b], a, IntMap [b]))
-> LNode a -> (Int, (IntMap [b], a, IntMap [b]))
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (\a
l -> (IntMap [b]
forall a. IntMap a
IM.empty,a
l,IntMap [b]
forall a. IntMap a
IM.empty)))
                      ([LNode a] -> Gr a b) -> [LNode a] -> Gr a b
forall a b. (a -> b) -> a -> b
$ [LNode a]
vs

    labNodes :: Gr a b -> [LNode a]
labNodes (Gr GraphRep a b
g) = [ (Int
node, a
label)
                            | (Int
node, (IntMap [b]
_, a
label, IntMap [b]
_)) <- GraphRep a b -> [(Int, Context' a b)]
forall a. IntMap a -> [(Int, a)]
IM.toList GraphRep a b
g ]

    noNodes :: Gr a b -> Int
noNodes   (Gr GraphRep a b
g) = GraphRep a b -> Int
forall a. IntMap a -> Int
IM.size GraphRep a b
g

    nodeRange :: Gr a b -> (Int, Int)
nodeRange (Gr GraphRep a b
g) = (Int, Int) -> Maybe (Int, Int) -> (Int, Int)
forall a. a -> Maybe a -> a
fromMaybe (String -> (Int, Int)
forall a. HasCallStack => String -> a
error String
"nodeRange of empty graph")
                       (Maybe (Int, Int) -> (Int, Int)) -> Maybe (Int, Int) -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> (Int, Int))
-> Maybe Int -> Maybe Int -> Maybe (Int, Int)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (Maybe ((Int, Context' a b), GraphRep a b) -> Maybe Int
forall b b b. Maybe ((b, b), b) -> Maybe b
ix (GraphRep a b -> Maybe ((Int, Context' a b), GraphRep a b)
forall a. IntMap a -> Maybe ((Int, a), IntMap a)
IM.minViewWithKey GraphRep a b
g))
                                    (Maybe ((Int, Context' a b), GraphRep a b) -> Maybe Int
forall b b b. Maybe ((b, b), b) -> Maybe b
ix (GraphRep a b -> Maybe ((Int, Context' a b), GraphRep a b)
forall a. IntMap a -> Maybe ((Int, a), IntMap a)
IM.maxViewWithKey GraphRep a b
g))
      where
        ix :: Maybe ((b, b), b) -> Maybe b
ix = (((b, b), b) -> b) -> Maybe ((b, b), b) -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b, b) -> b
forall a b. (a, b) -> a
fst ((b, b) -> b) -> (((b, b), b) -> (b, b)) -> ((b, b), b) -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((b, b), b) -> (b, b)
forall a b. (a, b) -> a
fst)

    labEdges :: Gr a b -> [LEdge b]
labEdges (Gr GraphRep a b
g) = do (Int
node, (IntMap [b]
_, a
_, IntMap [b]
s)) <- GraphRep a b -> [(Int, Context' a b)]
forall a. IntMap a -> [(Int, a)]
IM.toList GraphRep a b
g
                         (Int
next, [b]
labels)    <- IntMap [b] -> [(Int, [b])]
forall a. IntMap a -> [(Int, a)]
IM.toList IntMap [b]
s
                         b
label             <- [b]
labels
                         LEdge b -> [LEdge b]
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
node, Int
next, b
label)

instance DynGraph Gr where
    (Adj b
p, Int
v, a
l, Adj b
s) & :: Context a b -> Gr a b -> Gr a b
& (Gr GraphRep a b
g)
        = let !g1 :: GraphRep a b
g1 = Int -> (IntMap [b], a, IntMap [b]) -> GraphRep a b -> GraphRep a b
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
v (IntMap [b]
preds, a
l, IntMap [b]
succs) GraphRep a b
g
              !(Int
np, IntMap [b]
preds) = Adj b -> (Int, IntMap [b])
forall b. Adj b -> (Int, IntMap [b])
fromAdjCounting Adj b
p
              !(Int
ns, IntMap [b]
succs) = Adj b -> (Int, IntMap [b])
forall b. Adj b -> (Int, IntMap [b])
fromAdjCounting Adj b
s
              !g2 :: GraphRep a b
g2 = GraphRep a b -> Int -> Int -> IntMap [b] -> GraphRep a b
forall a b.
GraphRep a b -> Int -> Int -> IntMap [b] -> GraphRep a b
addSucc GraphRep a b
g1 Int
v Int
np IntMap [b]
preds
              !g3 :: GraphRep a b
g3 = GraphRep a b -> Int -> Int -> IntMap [b] -> GraphRep a b
forall a b.
GraphRep a b -> Int -> Int -> IntMap [b] -> GraphRep a b
addPred GraphRep a b
g2 Int
v Int
ns IntMap [b]
succs
          in GraphRep a b -> Gr a b
forall a b. GraphRep a b -> Gr a b
Gr GraphRep a b
g3

#if MIN_VERSION_containers (0,4,2)
instance (NFData a, NFData b) => NFData (Gr a b) where
  rnf :: Gr a b -> ()
rnf (Gr GraphRep a b
g) = GraphRep a b -> ()
forall a. NFData a => a -> ()
rnf GraphRep a b
g
#endif

#if MIN_VERSION_base (4,8,0)
instance Bifunctor Gr where
  bimap :: (a -> b) -> (c -> d) -> Gr a c -> Gr b d
bimap = (a -> b) -> (c -> d) -> Gr a c -> Gr b d
forall a b c d. (a -> c) -> (b -> d) -> Gr a b -> Gr c d
fastNEMap

  first :: (a -> b) -> Gr a c -> Gr b c
first = (a -> b) -> Gr a c -> Gr b c
forall a b c. (a -> c) -> Gr a b -> Gr c b
fastNMap

  second :: (b -> c) -> Gr a b -> Gr a c
second = (b -> c) -> Gr a b -> Gr a c
forall a b c. (b -> c) -> Gr a b -> Gr a c
fastEMap
#endif

matchGr :: Node -> Gr a b -> Decomp Gr a b
matchGr :: Int -> Gr a b -> Decomp Gr a b
matchGr Int
node (Gr GraphRep a b
g)
    = case Int -> GraphRep a b -> Maybe (Context' a b)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
node GraphRep a b
g of
        Maybe (Context' a b)
Nothing
            -> (Maybe (Context a b)
forall a. Maybe a
Nothing, GraphRep a b -> Gr a b
forall a b. GraphRep a b -> Gr a b
Gr GraphRep a b
g)

        Just (IntMap [b]
p, a
label, IntMap [b]
s)
            -> let !g1 :: GraphRep a b
g1 = Int -> GraphRep a b -> GraphRep a b
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
node GraphRep a b
g
                   !p' :: IntMap [b]
p' = Int -> IntMap [b] -> IntMap [b]
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
node IntMap [b]
p
                   !s' :: IntMap [b]
s' = Int -> IntMap [b] -> IntMap [b]
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
node IntMap [b]
s
                   !g2 :: GraphRep a b
g2 = GraphRep a b -> Int -> IntMap [b] -> GraphRep a b
forall a b x. GraphRep a b -> Int -> IntMap x -> GraphRep a b
clearPred GraphRep a b
g1 Int
node IntMap [b]
s'
                   !g3 :: GraphRep a b
g3 = GraphRep a b -> Int -> IntMap [b] -> GraphRep a b
forall a b x. GraphRep a b -> Int -> IntMap x -> GraphRep a b
clearSucc GraphRep a b
g2 Int
node IntMap [b]
p'
               in (Context a b -> Maybe (Context a b)
forall a. a -> Maybe a
Just (IntMap [b] -> Adj b
forall b. IntMap [b] -> Adj b
toAdj IntMap [b]
p', Int
node, a
label, IntMap [b] -> Adj b
forall b. IntMap [b] -> Adj b
toAdj IntMap [b]
s), GraphRep a b -> Gr a b
forall a b. GraphRep a b -> Gr a b
Gr GraphRep a b
g3)

----------------------------------------------------------------------
-- OVERRIDING FUNCTIONS
----------------------------------------------------------------------

{-# RULES
      "insNode/Data.Graph.Inductive.PatriciaTree"  insNode = fastInsNode
  #-}
fastInsNode :: LNode a -> Gr a b -> Gr a b
fastInsNode :: LNode a -> Gr a b -> Gr a b
fastInsNode (Int
v, a
l) (Gr GraphRep a b
g) = GraphRep a b
g' GraphRep a b -> Gr a b -> Gr a b
`seq` GraphRep a b -> Gr a b
forall a b. GraphRep a b -> Gr a b
Gr GraphRep a b
g'
  where
    g' :: GraphRep a b
g' = Int -> (IntMap [b], a, IntMap [b]) -> GraphRep a b -> GraphRep a b
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
v (IntMap [b]
forall a. IntMap a
IM.empty, a
l, IntMap [b]
forall a. IntMap a
IM.empty) GraphRep a b
g

{-# RULES
      "insEdge/Data.Graph.Inductive.PatriciaTree"  insEdge = fastInsEdge
  #-}
fastInsEdge :: LEdge b -> Gr a b -> Gr a b
fastInsEdge :: LEdge b -> Gr a b -> Gr a b
fastInsEdge (Int
v, Int
w, b
l) (Gr GraphRep a b
g) = GraphRep a b
g2 GraphRep a b -> Gr a b -> Gr a b
`seq` GraphRep a b -> Gr a b
forall a b. GraphRep a b -> Gr a b
Gr GraphRep a b
g2
  where
    g1 :: GraphRep a b
g1 = ((IntMap [b], a, IntMap [b]) -> (IntMap [b], a, IntMap [b]))
-> Int -> GraphRep a b -> GraphRep a b
forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IM.adjust (IntMap [b], a, IntMap [b]) -> (IntMap [b], a, IntMap [b])
forall a b. (a, b, IntMap [b]) -> (a, b, IntMap [b])
addS' Int
v GraphRep a b
g
    g2 :: GraphRep a b
g2 = ((IntMap [b], a, IntMap [b]) -> (IntMap [b], a, IntMap [b]))
-> Int -> GraphRep a b -> GraphRep a b
forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IM.adjust (IntMap [b], a, IntMap [b]) -> (IntMap [b], a, IntMap [b])
forall b c. (IntMap [b], b, c) -> (IntMap [b], b, c)
addP' Int
w GraphRep a b
g1

    addS' :: (a, b, IntMap [b]) -> (a, b, IntMap [b])
addS' (a
ps, b
l', IntMap [b]
ss) = (a
ps, b
l', ([b] -> [b] -> [b]) -> Int -> [b] -> IntMap [b] -> IntMap [b]
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
addLists Int
w [b
l] IntMap [b]
ss)
    addP' :: (IntMap [b], b, c) -> (IntMap [b], b, c)
addP' (IntMap [b]
ps, b
l', c
ss) = (([b] -> [b] -> [b]) -> Int -> [b] -> IntMap [b] -> IntMap [b]
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
addLists Int
v [b
l] IntMap [b]
ps, b
l', c
ss)

{-# RULES
      "gmap/Data.Graph.Inductive.PatriciaTree"  gmap = fastGMap
  #-}
fastGMap :: forall a b c d. (Context a b -> Context c d) -> Gr a b -> Gr c d
fastGMap :: (Context a b -> Context c d) -> Gr a b -> Gr c d
fastGMap Context a b -> Context c d
f (Gr GraphRep a b
g) = GraphRep c d -> Gr c d
forall a b. GraphRep a b -> Gr a b
Gr ((Int -> Context' a b -> Context' c d)
-> GraphRep a b -> GraphRep c d
forall a b. (Int -> a -> b) -> IntMap a -> IntMap b
IM.mapWithKey Int -> Context' a b -> Context' c d
f' GraphRep a b
g)
  where
    f' :: Node -> Context' a b -> Context' c d
    f' :: Int -> Context' a b -> Context' c d
f' = ((Context c d -> Context' c d
forall a b. Context a b -> Context' a b
fromContext (Context c d -> Context' c d)
-> (Context a b -> Context c d) -> Context a b -> Context' c d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context a b -> Context c d
f) (Context a b -> Context' c d)
-> (Context' a b -> Context a b) -> Context' a b -> Context' c d
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Context' a b -> Context a b) -> Context' a b -> Context' c d)
-> (Int -> Context' a b -> Context a b)
-> Int
-> Context' a b
-> Context' c d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Context' a b -> Context a b
forall a b. Int -> Context' a b -> Context a b
toContext

{-# RULES
      "nmap/Data.Graph.Inductive.PatriciaTree"  nmap = fastNMap
  #-}
fastNMap :: forall a b c. (a -> c) -> Gr a b -> Gr c b
fastNMap :: (a -> c) -> Gr a b -> Gr c b
fastNMap a -> c
f (Gr GraphRep a b
g) = GraphRep c b -> Gr c b
forall a b. GraphRep a b -> Gr a b
Gr ((Context' a b -> Context' c b) -> GraphRep a b -> GraphRep c b
forall a b. (a -> b) -> IntMap a -> IntMap b
IM.map Context' a b -> Context' c b
f' GraphRep a b
g)
  where
    f' :: Context' a b -> Context' c b
    f' :: Context' a b -> Context' c b
f' (IntMap [b]
ps, a
a, IntMap [b]
ss) = (IntMap [b]
ps, a -> c
f a
a, IntMap [b]
ss)

{-# RULES
      "emap/Data.Graph.Inductive.PatriciaTree"  emap = fastEMap
  #-}
fastEMap :: forall a b c. (b -> c) -> Gr a b -> Gr a c
fastEMap :: (b -> c) -> Gr a b -> Gr a c
fastEMap b -> c
f (Gr GraphRep a b
g) = GraphRep a c -> Gr a c
forall a b. GraphRep a b -> Gr a b
Gr ((Context' a b -> Context' a c) -> GraphRep a b -> GraphRep a c
forall a b. (a -> b) -> IntMap a -> IntMap b
IM.map Context' a b -> Context' a c
f' GraphRep a b
g)
  where
    f' :: Context' a b -> Context' a c
    f' :: Context' a b -> Context' a c
f' (IntMap [b]
ps, a
a, IntMap [b]
ss) = (([b] -> [c]) -> IntMap [b] -> IntMap [c]
forall a b. (a -> b) -> IntMap a -> IntMap b
IM.map ((b -> c) -> [b] -> [c]
forall a b. (a -> b) -> [a] -> [b]
map b -> c
f) IntMap [b]
ps, a
a, ([b] -> [c]) -> IntMap [b] -> IntMap [c]
forall a b. (a -> b) -> IntMap a -> IntMap b
IM.map ((b -> c) -> [b] -> [c]
forall a b. (a -> b) -> [a] -> [b]
map b -> c
f) IntMap [b]
ss)

{-# RULES
      "nemap/Data.Graph.Inductive.PatriciaTree"  nemap = fastNEMap
  #-}
fastNEMap :: forall a b c d. (a -> c) -> (b -> d) -> Gr a b -> Gr c d
fastNEMap :: (a -> c) -> (b -> d) -> Gr a b -> Gr c d
fastNEMap a -> c
fn b -> d
fe (Gr GraphRep a b
g) = GraphRep c d -> Gr c d
forall a b. GraphRep a b -> Gr a b
Gr ((Context' a b -> Context' c d) -> GraphRep a b -> GraphRep c d
forall a b. (a -> b) -> IntMap a -> IntMap b
IM.map Context' a b -> Context' c d
f GraphRep a b
g)
  where
    f :: Context' a b -> Context' c d
    f :: Context' a b -> Context' c d
f (IntMap [b]
ps, a
a, IntMap [b]
ss) = (([b] -> [d]) -> IntMap [b] -> IntMap [d]
forall a b. (a -> b) -> IntMap a -> IntMap b
IM.map ((b -> d) -> [b] -> [d]
forall a b. (a -> b) -> [a] -> [b]
map b -> d
fe) IntMap [b]
ps, a -> c
fn a
a, ([b] -> [d]) -> IntMap [b] -> IntMap [d]
forall a b. (a -> b) -> IntMap a -> IntMap b
IM.map ((b -> d) -> [b] -> [d]
forall a b. (a -> b) -> [a] -> [b]
map b -> d
fe) IntMap [b]
ss)

----------------------------------------------------------------------
-- UTILITIES
----------------------------------------------------------------------

toAdj :: IntMap [b] -> Adj b
toAdj :: IntMap [b] -> Adj b
toAdj = ((Int, [b]) -> Adj b) -> [(Int, [b])] -> Adj b
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int, [b]) -> Adj b
forall b a. (b, [a]) -> [(a, b)]
expand ([(Int, [b])] -> Adj b)
-> (IntMap [b] -> [(Int, [b])]) -> IntMap [b] -> Adj b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap [b] -> [(Int, [b])]
forall a. IntMap a -> [(Int, a)]
IM.toList
  where
    expand :: (b, [a]) -> [(a, b)]
expand (b
n,[a]
ls) = (a -> (a, b)) -> [a] -> [(a, b)]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b -> (a, b)) -> b -> a -> (a, b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) b
n) [a]
ls

fromAdj :: Adj b -> IntMap [b]
fromAdj :: Adj b -> IntMap [b]
fromAdj = ([b] -> [b] -> [b]) -> [(Int, [b])] -> IntMap [b]
forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IM.fromListWith [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
addLists ([(Int, [b])] -> IntMap [b])
-> (Adj b -> [(Int, [b])]) -> Adj b -> IntMap [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((b, Int) -> (Int, [b])) -> Adj b -> [(Int, [b])]
forall a b. (a -> b) -> [a] -> [b]
map ((b -> [b]) -> (Int, b) -> (Int, [b])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (b -> [b] -> [b]
forall a. a -> [a] -> [a]
:[]) ((Int, b) -> (Int, [b]))
-> ((b, Int) -> (Int, b)) -> (b, Int) -> (Int, [b])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b, Int) -> (Int, b)
forall a b. (a, b) -> (b, a)
swap)

data FromListCounting a = FromListCounting !Int !(IntMap a)
  deriving (FromListCounting a -> FromListCounting a -> Bool
(FromListCounting a -> FromListCounting a -> Bool)
-> (FromListCounting a -> FromListCounting a -> Bool)
-> Eq (FromListCounting a)
forall a. Eq a => FromListCounting a -> FromListCounting a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FromListCounting a -> FromListCounting a -> Bool
$c/= :: forall a. Eq a => FromListCounting a -> FromListCounting a -> Bool
== :: FromListCounting a -> FromListCounting a -> Bool
$c== :: forall a. Eq a => FromListCounting a -> FromListCounting a -> Bool
Eq, Int -> FromListCounting a -> ShowS
[FromListCounting a] -> ShowS
FromListCounting a -> String
(Int -> FromListCounting a -> ShowS)
-> (FromListCounting a -> String)
-> ([FromListCounting a] -> ShowS)
-> Show (FromListCounting a)
forall a. Show a => Int -> FromListCounting a -> ShowS
forall a. Show a => [FromListCounting a] -> ShowS
forall a. Show a => FromListCounting a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FromListCounting a] -> ShowS
$cshowList :: forall a. Show a => [FromListCounting a] -> ShowS
show :: FromListCounting a -> String
$cshow :: forall a. Show a => FromListCounting a -> String
showsPrec :: Int -> FromListCounting a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> FromListCounting a -> ShowS
Show, ReadPrec [FromListCounting a]
ReadPrec (FromListCounting a)
Int -> ReadS (FromListCounting a)
ReadS [FromListCounting a]
(Int -> ReadS (FromListCounting a))
-> ReadS [FromListCounting a]
-> ReadPrec (FromListCounting a)
-> ReadPrec [FromListCounting a]
-> Read (FromListCounting a)
forall a. Read a => ReadPrec [FromListCounting a]
forall a. Read a => ReadPrec (FromListCounting a)
forall a. Read a => Int -> ReadS (FromListCounting a)
forall a. Read a => ReadS [FromListCounting a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FromListCounting a]
$creadListPrec :: forall a. Read a => ReadPrec [FromListCounting a]
readPrec :: ReadPrec (FromListCounting a)
$creadPrec :: forall a. Read a => ReadPrec (FromListCounting a)
readList :: ReadS [FromListCounting a]
$creadList :: forall a. Read a => ReadS [FromListCounting a]
readsPrec :: Int -> ReadS (FromListCounting a)
$creadsPrec :: forall a. Read a => Int -> ReadS (FromListCounting a)
Read)

getFromListCounting :: FromListCounting a -> (Int, IntMap a)
getFromListCounting :: FromListCounting a -> (Int, IntMap a)
getFromListCounting (FromListCounting Int
i IntMap a
m) = (Int
i, IntMap a
m)
{-# INLINE getFromListCounting #-}

fromListWithKeyCounting :: (Int -> a -> a -> a) -> [(Int, a)] -> (Int, IntMap a)
fromListWithKeyCounting :: (Int -> a -> a -> a) -> [(Int, a)] -> (Int, IntMap a)
fromListWithKeyCounting Int -> a -> a -> a
f = FromListCounting a -> (Int, IntMap a)
forall a. FromListCounting a -> (Int, IntMap a)
getFromListCounting (FromListCounting a -> (Int, IntMap a))
-> ([(Int, a)] -> FromListCounting a)
-> [(Int, a)]
-> (Int, IntMap a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FromListCounting a -> (Int, a) -> FromListCounting a)
-> FromListCounting a -> [(Int, a)] -> FromListCounting a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' FromListCounting a -> (Int, a) -> FromListCounting a
ins (Int -> IntMap a -> FromListCounting a
forall a. Int -> IntMap a -> FromListCounting a
FromListCounting Int
0 IntMap a
forall a. IntMap a
IM.empty)
  where
    ins :: FromListCounting a -> (Int, a) -> FromListCounting a
ins (FromListCounting Int
i IntMap a
t) (Int
k,a
x) = Int -> IntMap a -> FromListCounting a
forall a. Int -> IntMap a -> FromListCounting a
FromListCounting (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ((Int -> a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
forall a. (Int -> a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWithKey Int -> a -> a -> a
f Int
k a
x IntMap a
t)
{-# INLINE fromListWithKeyCounting #-}

fromListWithCounting :: (a -> a -> a) -> [(Int, a)] -> (Int, IntMap a)
fromListWithCounting :: (a -> a -> a) -> [(Int, a)] -> (Int, IntMap a)
fromListWithCounting a -> a -> a
f = (Int -> a -> a -> a) -> [(Int, a)] -> (Int, IntMap a)
forall a. (Int -> a -> a -> a) -> [(Int, a)] -> (Int, IntMap a)
fromListWithKeyCounting (\Int
_ a
x a
y -> a -> a -> a
f a
x a
y)
{-# INLINE fromListWithCounting #-}

fromAdjCounting :: Adj b -> (Int, IntMap [b])
fromAdjCounting :: Adj b -> (Int, IntMap [b])
fromAdjCounting = ([b] -> [b] -> [b]) -> [(Int, [b])] -> (Int, IntMap [b])
forall a. (a -> a -> a) -> [(Int, a)] -> (Int, IntMap a)
fromListWithCounting [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
addLists ([(Int, [b])] -> (Int, IntMap [b]))
-> (Adj b -> [(Int, [b])]) -> Adj b -> (Int, IntMap [b])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((b, Int) -> (Int, [b])) -> Adj b -> [(Int, [b])]
forall a b. (a -> b) -> [a] -> [b]
map ((b -> [b]) -> (Int, b) -> (Int, [b])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (b -> [b] -> [b]
forall a. a -> [a] -> [a]
:[]) ((Int, b) -> (Int, [b]))
-> ((b, Int) -> (Int, b)) -> (b, Int) -> (Int, [b])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b, Int) -> (Int, b)
forall a b. (a, b) -> (b, a)
swap)

-- We use differenceWith to modify a graph more than bulkThreshold times,
-- and repeated insertWith otherwise.
bulkThreshold :: Int
bulkThreshold :: Int
bulkThreshold = Int
5

toContext :: Node -> Context' a b -> Context a b
toContext :: Int -> Context' a b -> Context a b
toContext Int
v (IntMap [b]
ps, a
a, IntMap [b]
ss) = (IntMap [b] -> Adj b
forall b. IntMap [b] -> Adj b
toAdj IntMap [b]
ps, Int
v, a
a, IntMap [b] -> Adj b
forall b. IntMap [b] -> Adj b
toAdj IntMap [b]
ss)

fromContext :: Context a b -> Context' a b
fromContext :: Context a b -> Context' a b
fromContext (Adj b
ps, Int
_, a
a, Adj b
ss) = (Adj b -> IntMap [b]
forall b. Adj b -> IntMap [b]
fromAdj Adj b
ps, a
a, Adj b -> IntMap [b]
forall b. Adj b -> IntMap [b]
fromAdj Adj b
ss)

-- A version of @++@ where order isn't important, so @xs ++ [x]@
-- becomes @x:xs@.  Used when we have to have a function of type @[a]
-- -> [a] -> [a]@ but one of the lists is just going to be a single
-- element (and it isn't possible to tell which).
addLists :: [a] -> [a] -> [a]
addLists :: [a] -> [a] -> [a]
addLists [a
a] [a]
as  = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as
addLists [a]
as  [a
a] = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as
addLists [a]
xs  [a]
ys  = [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
ys

addSucc :: forall a b . GraphRep a b -> Node -> Int -> IM.IntMap [b] -> GraphRep a b
addSucc :: GraphRep a b -> Int -> Int -> IntMap [b] -> GraphRep a b
addSucc GraphRep a b
g0 Int
v Int
numAdd IntMap [b]
xs
  | Int
numAdd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
bulkThreshold = (GraphRep a b -> Int -> [b] -> GraphRep a b)
-> GraphRep a b -> IntMap [b] -> GraphRep a b
forall a b. (a -> Int -> b -> a) -> a -> IntMap b -> a
foldlWithKey' GraphRep a b -> Int -> [b] -> GraphRep a b
go GraphRep a b
g0 IntMap [b]
xs
  where
    go :: GraphRep a b -> Node -> [b] -> GraphRep a b
    go :: GraphRep a b -> Int -> [b] -> GraphRep a b
go GraphRep a b
g Int
p [b]
l = ((IntMap [b], a, IntMap [b]) -> (IntMap [b], a, IntMap [b]))
-> Int -> GraphRep a b -> GraphRep a b
forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IMS.adjust (IntMap [b], a, IntMap [b]) -> (IntMap [b], a, IntMap [b])
forall a b. (a, b, IntMap [b]) -> (a, b, IntMap [b])
f Int
p GraphRep a b
g
      where f :: (a, b, IntMap [b]) -> (a, b, IntMap [b])
f (a
ps, b
l', IntMap [b]
ss) = let !ss' :: IntMap [b]
ss' = ([b] -> [b] -> [b]) -> Int -> [b] -> IntMap [b] -> IntMap [b]
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
addLists Int
v [b]
l IntMap [b]
ss
                             in (a
ps, b
l', IntMap [b]
ss')
addSucc GraphRep a b
g Int
v Int
_ IntMap [b]
xs = ((IntMap [b], a, IntMap [b])
 -> [b] -> Maybe (IntMap [b], a, IntMap [b]))
-> GraphRep a b -> IntMap [b] -> GraphRep a b
forall a b. (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
IMS.differenceWith (IntMap [b], a, IntMap [b])
-> [b] -> Maybe (IntMap [b], a, IntMap [b])
go GraphRep a b
g IntMap [b]
xs
  where
    go :: Context' a b -> [b] -> Maybe (Context' a b)
    go :: (IntMap [b], a, IntMap [b])
-> [b] -> Maybe (IntMap [b], a, IntMap [b])
go (IntMap [b]
ps, a
l', IntMap [b]
ss) [b]
l = let !ss' :: IntMap [b]
ss' = ([b] -> [b] -> [b]) -> Int -> [b] -> IntMap [b] -> IntMap [b]
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
addLists Int
v [b]
l IntMap [b]
ss
                        in (IntMap [b], a, IntMap [b]) -> Maybe (IntMap [b], a, IntMap [b])
forall a. a -> Maybe a
Just (IntMap [b]
ps, a
l', IntMap [b]
ss')

foldlWithKey' :: (a -> IM.Key -> b -> a) -> a -> IntMap b -> a
foldlWithKey' :: (a -> Int -> b -> a) -> a -> IntMap b -> a
foldlWithKey' =
#if MIN_VERSION_containers (0,4,2)
  (a -> Int -> b -> a) -> a -> IntMap b -> a
forall a b. (a -> Int -> b -> a) -> a -> IntMap b -> a
IM.foldlWithKey'
#else
  IM.foldWithKey . adjustFunc
  where
    adjustFunc f k b a = f a k b
#endif

addPred :: forall a b . GraphRep a b -> Node -> Int -> IM.IntMap [b] -> GraphRep a b
addPred :: GraphRep a b -> Int -> Int -> IntMap [b] -> GraphRep a b
addPred GraphRep a b
g0 Int
v Int
numAdd IntMap [b]
xs
  | Int
numAdd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
bulkThreshold = (GraphRep a b -> Int -> [b] -> GraphRep a b)
-> GraphRep a b -> IntMap [b] -> GraphRep a b
forall a b. (a -> Int -> b -> a) -> a -> IntMap b -> a
foldlWithKey' GraphRep a b -> Int -> [b] -> GraphRep a b
go GraphRep a b
g0 IntMap [b]
xs
  where
    go :: GraphRep a b -> Node -> [b] -> GraphRep a b
    go :: GraphRep a b -> Int -> [b] -> GraphRep a b
go GraphRep a b
g Int
p [b]
l = ((IntMap [b], a, IntMap [b]) -> (IntMap [b], a, IntMap [b]))
-> Int -> GraphRep a b -> GraphRep a b
forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IMS.adjust (IntMap [b], a, IntMap [b]) -> (IntMap [b], a, IntMap [b])
forall b c. (IntMap [b], b, c) -> (IntMap [b], b, c)
f Int
p GraphRep a b
g
      where f :: (IntMap [b], b, c) -> (IntMap [b], b, c)
f (IntMap [b]
ps, b
l', c
ss) = let !ps' :: IntMap [b]
ps' = ([b] -> [b] -> [b]) -> Int -> [b] -> IntMap [b] -> IntMap [b]
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
addLists Int
v [b]
l IntMap [b]
ps
                             in (IntMap [b]
ps', b
l', c
ss)
addPred GraphRep a b
g Int
v Int
_ IntMap [b]
xs = ((IntMap [b], a, IntMap [b])
 -> [b] -> Maybe (IntMap [b], a, IntMap [b]))
-> GraphRep a b -> IntMap [b] -> GraphRep a b
forall a b. (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
IMS.differenceWith (IntMap [b], a, IntMap [b])
-> [b] -> Maybe (IntMap [b], a, IntMap [b])
go GraphRep a b
g IntMap [b]
xs
  where
    go :: Context' a b -> [b] -> Maybe (Context' a b)
    go :: (IntMap [b], a, IntMap [b])
-> [b] -> Maybe (IntMap [b], a, IntMap [b])
go (IntMap [b]
ps, a
l', IntMap [b]
ss) [b]
l = let !ps' :: IntMap [b]
ps' = ([b] -> [b] -> [b]) -> Int -> [b] -> IntMap [b] -> IntMap [b]
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
addLists Int
v [b]
l IntMap [b]
ps
                        in (IntMap [b], a, IntMap [b]) -> Maybe (IntMap [b], a, IntMap [b])
forall a. a -> Maybe a
Just (IntMap [b]
ps', a
l', IntMap [b]
ss)

clearSucc :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b
clearSucc :: GraphRep a b -> Int -> IntMap x -> GraphRep a b
clearSucc GraphRep a b
g Int
v = (Context' a b -> x -> Maybe (Context' a b))
-> GraphRep a b -> IntMap x -> GraphRep a b
forall a b. (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
IMS.differenceWith Context' a b -> x -> Maybe (Context' a b)
go GraphRep a b
g
  where
    go :: Context' a b -> x -> Maybe (Context' a b)
    go :: Context' a b -> x -> Maybe (Context' a b)
go (IntMap [b]
ps, a
l, IntMap [b]
ss) x
_ = let !ss' :: IntMap [b]
ss' = Int -> IntMap [b] -> IntMap [b]
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
v IntMap [b]
ss
                       in Context' a b -> Maybe (Context' a b)
forall a. a -> Maybe a
Just (IntMap [b]
ps, a
l, IntMap [b]
ss')

clearPred :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b
clearPred :: GraphRep a b -> Int -> IntMap x -> GraphRep a b
clearPred GraphRep a b
g Int
v = (Context' a b -> x -> Maybe (Context' a b))
-> GraphRep a b -> IntMap x -> GraphRep a b
forall a b. (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
IMS.differenceWith Context' a b -> x -> Maybe (Context' a b)
go GraphRep a b
g
  where
    go :: Context' a b -> x -> Maybe (Context' a b)
    go :: Context' a b -> x -> Maybe (Context' a b)
go (IntMap [b]
ps, a
l, IntMap [b]
ss) x
_ = let !ps' :: IntMap [b]
ps' = Int -> IntMap [b] -> IntMap [b]
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
v IntMap [b]
ps
                       in Context' a b -> Maybe (Context' a b)
forall a. a -> Maybe a
Just (IntMap [b]
ps', a
l, IntMap [b]
ss)