Use differenceWith to implement (&) and match

Based upon work by David Feuer, manually re-integrated into current
codebase.

Closes #48; closes #39.

Author: ivan-m

Data/Graph/Inductive/PatriciaTree.hs

@@ -30,11 +30,17 @@ import Data.Graph.Inductive.Graph
 import           Control.Applicative (liftA2)
 import           Data.IntMap         (IntMap)
 import qualified Data.IntMap         as IM
-import           Data.List           (sort)
+import           Data.List           (foldl', sort)
 import           Data.Maybe          (fromMaybe)
 
 #if MIN_VERSION_containers (0,4,2)
-import Control.DeepSeq (NFData (..))
+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
@@ -115,9 +121,11 @@ instance Graph Gr where
 
 instance DynGraph Gr where
     (p, v, l, s) & (Gr g)
-        = let !g1 = IM.insert v (fromAdj p, l, fromAdj s) g
-              !g2 = addSucc g1 v p
-              !g3 = addPred g2 v s
+        = let !g1 = IM.insert v (preds, l, succs) g
+              !(np, preds) = fromAdjCounting p
+              !(ns, succs) = fromAdjCounting s
+              !g2 = addSucc g1 v np preds
+              !g3 = addPred g2 v ns succs
           in Gr g3
 
 #if MIN_VERSION_containers (0,4,2)
@@ -144,8 +152,8 @@ matchGr node (Gr g)
             -> let !g1 = IM.delete node g
                    !p' = IM.delete node p
                    !s' = IM.delete node s
-                   !g2 = clearPred g1 node (IM.keys s')
-                   !g3 = clearSucc g2 node (IM.keys p')
+                   !g2 = clearPred g1 node s'
+                   !g3 = clearSucc g2 node p'
                in (Just (toAdj p', node, label, toAdj s), Gr g3)
 
 ----------------------------------------------------------------------
@@ -166,11 +174,11 @@ fastInsNode (v, l) (Gr g) = g' `seq` Gr g'
 fastInsEdge :: LEdge b -> Gr a b -> Gr a b
 fastInsEdge (v, w, l) (Gr g) = g2 `seq` Gr g2
   where
-    g1 = IM.adjust addSucc' v g
-    g2 = IM.adjust addPred' w g1
+    g1 = IM.adjust addS' v g
+    g2 = IM.adjust addP' w g1
 
-    addSucc' (ps, l', ss) = (ps, l', IM.insertWith addLists w [l] ss)
-    addPred' (ps, l', ss) = (IM.insertWith addLists v [l] ps, l', ss)
+    addS' (ps, l', ss) = (ps, l', IM.insertWith addLists w [l] ss)
+    addP' (ps, l', ss) = (IM.insertWith addLists v [l] ps, l', ss)
 
 {-# RULES
       "gmap/Data.Graph.Inductive.PatriciaTree"  gmap = fastGMap
@@ -220,6 +228,31 @@ toAdj = concatMap expand . IM.toList
 fromAdj :: Adj b -> IntMap [b]
 fromAdj = IM.fromListWith addLists . map (second (:[]) . swap)
 
+data FromListCounting a = FromListCounting !Int !(IntMap a)
+  deriving (Eq, Show, Read)
+
+getFromListCounting :: FromListCounting a -> (Int, IntMap a)
+getFromListCounting (FromListCounting i m) = (i, m)
+{-# INLINE getFromListCounting #-}
+
+fromListWithKeyCounting :: (Int -> a -> a -> a) -> [(Int, a)] -> (Int, IntMap a)
+fromListWithKeyCounting f = getFromListCounting . foldl' ins (FromListCounting 0 IM.empty)
+  where
+    ins (FromListCounting i t) (k,x) = FromListCounting (i + 1) (IM.insertWithKey f k x t)
+{-# INLINE fromListWithKeyCounting #-}
+
+fromListWithCounting :: (a -> a -> a) -> [(Int, a)] -> (Int, IntMap a)
+fromListWithCounting f = fromListWithKeyCounting (\_ x y -> f x y)
+{-# INLINE fromListWithCounting #-}
+
+fromAdjCounting :: Adj b -> (Int, IntMap [b])
+fromAdjCounting = fromListWithCounting addLists . map (second (:[]) . swap)
+
+-- We use differenceWith to modify a graph more than bulkThreshold times,
+-- and repeated insertWith otherwise.
+bulkThreshold :: Int
+bulkThreshold = 5
+
 toContext :: Node -> Context' a b -> Context a b
 toContext v (ps, a, ss) = (toAdj ps, v, a, toAdj ss)
 
@@ -238,33 +271,44 @@ addLists [a] as  = a : as
 addLists as  [a] = a : as
 addLists xs  ys  = xs ++ ys
 
-addSucc :: GraphRep a b -> Node -> [(b, Node)] -> GraphRep a b
-addSucc g _ []              = g
-addSucc g v ((l, p) : rest) = addSucc g' v rest
-    where
-      g' = IM.adjust f p g
-      f (ps, l', ss) = (ps, l', IM.insertWith addLists v [l] ss)
-
-
-addPred :: GraphRep a b -> Node -> [(b, Node)] -> GraphRep a b
-addPred g _ []              = g
-addPred g v ((l, s) : rest) = addPred g' v rest
+addSucc :: forall a b . GraphRep a b -> Node -> Int -> IM.IntMap [b] -> GraphRep a b
+addSucc g0 v numAdd xs
+  | numAdd < bulkThreshold = IM.foldlWithKey' go g0 xs
   where
-    g' = IM.adjust f s g
-    f (ps, l', ss) = (IM.insertWith addLists v [l] ps, l', ss)
-
+    go :: GraphRep a b -> Node -> [b] -> GraphRep a b
+    go g p l = IMS.adjust f p g
+      where f (ps, l', ss) = let !ss' = IM.insertWith (++) v l ss
+                             in (ps, l', ss')
+addSucc g v _ xs = IMS.differenceWith go g xs
+  where
+    go :: Context' a b -> [b] -> Maybe (Context' a b)
+    go (ps, l', ss) l = let !ss' = IM.insertWith (++) v l ss
+                        in Just (ps, l', ss')
 
-clearSucc :: GraphRep a b -> Node -> [Node] -> GraphRep a b
-clearSucc g _ []       = g
-clearSucc g v (p:rest) = clearSucc g' v rest
+addPred :: forall a b . GraphRep a b -> Node -> Int -> IM.IntMap [b] -> GraphRep a b
+addPred g0 v numAdd xs
+  | numAdd < bulkThreshold = IM.foldlWithKey' go g0 xs
   where
-    g' = IM.adjust f p g
-    f (ps, l, ss) = (ps, l, IM.delete v ss)
+    go :: GraphRep a b -> Node -> [b] -> GraphRep a b
+    go g p l = IMS.adjust f p g
+      where f (ps, l', ss) = let !ps' = IM.insertWith (++) v l ps
+                             in (ps', l', ss)
+addPred g v _ xs = IMS.differenceWith go g xs
+  where
+    go :: Context' a b -> [b] -> Maybe (Context' a b)
+    go (ps, l', ss) l = let !ps' = IM.insertWith (++) v l ps
+                        in Just (ps', l', ss)
 
+clearSucc :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b
+clearSucc g v = IMS.differenceWith go g
+  where
+    go :: Context' a b -> x -> Maybe (Context' a b)
+    go (ps, l, ss) _ = let !ss' = IM.delete v ss
+                       in Just (ps, l, ss')
 
-clearPred :: GraphRep a b -> Node -> [Node] -> GraphRep a b
-clearPred g _ []       = g
-clearPred g v (s:rest) = clearPred g' v rest
+clearPred :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b
+clearPred g v = IMS.differenceWith go g
   where
-    g' = IM.adjust f s g
-    f (ps, l, ss) = (IM.delete v ps, l, ss)
+    go :: Context' a b -> x -> Maybe (Context' a b)
+    go (ps, l, ss) _ = let !ps' = IM.delete v ps
+                       in Just (ps', l, ss)