fgl 5.5.3.0 → 5.5.3.1

raw patch · 7 files changed

+300/−45 lines, 7 filesdep +microbenchdep ~basedep ~deepseqdep ~hspecPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: microbench

Dependency ranges changed: base, deepseq, hspec

API changes (from Hackage documentation)

Files

• ChangeLog +12/−0
• Data/Graph/Inductive/Graph.hs +11/−5
• Data/Graph/Inductive/PatriciaTree.hs +79/−35
• Data/Graph/Inductive/Query/DFS.hs +1/−1
• fgl.cabal +22/−2
• test/Data/Graph/Inductive/Graph/Properties.hs +2/−2
• test/benchmark.hs +173/−0

@@ -1,3 +1,15 @@+5.5.3.1+-------++* Hopefully clearer documentation for `&`, `Context` and the+  `ufold`-based functions.++* Thanks to David Feuer, the existing benchmark suite is now runnable+  with `cabal bench`.++* Some performance improvements for `PatriciaTree`, thanks to David+  Feuer.+ 5.5.3.0 ------- 

@@ -111,6 +111,9 @@ -- | Labeled links to or from a 'Node'. type Adj b        = [(b,Node)] -- | Links to the 'Node', the 'Node' itself, a label, links from the 'Node'.+--+--   In other words, this captures all information regarding the+--   specified 'Node' within a graph. type Context a b  = (Adj b,Node,a,Adj b) -- Context a b "=" Context' a b "+" Node type MContext a b = Maybe (Context a b) -- | 'Graph' decomposition - the context removed from a 'Graph', and the rest@@ -176,8 +179,11 @@ class (Graph gr) => DynGraph gr where   -- | Merge the 'Context' into the 'DynGraph'.   ---  --   Contexts should only refer to either a Node already in a graph-  --   or the node in the Context itself (for loops).+  --   Context adjacencies should only refer to either a Node already+  --   in a graph or the node in the Context itself (for loops).+  --+  --   Behaviour is undefined if the specified 'Node' already exists+  --   in the graph.   (&) :: Context a b -> gr a b -> gr a b  @@ -198,7 +204,7 @@ size :: (Graph gr) => gr a b -> Int size = length . labEdges --- | Fold a function over the graph.+-- | Fold a function over the graph by recursively calling 'match'. ufold :: (Graph gr) => (Context a b -> c -> c) -> c -> gr a b -> c ufold f u g   | isEmpty g = u@@ -206,7 +212,7 @@   where     (c,g') = matchAny g --- | Map a function over the graph.+-- | Map a function over the graph by recursively calling 'match'. gmap :: (DynGraph gr) => (Context a b -> Context c d) -> gr a b -> gr c d gmap f = ufold (\c->(f c&)) empty {-# NOINLINE [0] gmap #-}@@ -343,7 +349,7 @@      labUNodes = map (flip (,) ())  -- | Build a graph out of the contexts for which the predicate is--- true.+-- satisfied by recursively calling 'match'. gfiltermap :: DynGraph gr => (Context a b -> MContext c d) -> gr a b -> gr c d gfiltermap f = ufold (maybe id (&) . f) empty 

@@ -30,13 +30,19 @@ 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 import GHC.Generics (Generic) #endif@@ -115,9 +121,11 @@  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 @@             -> 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 @@ 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 @@ 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 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)

@@ -6,7 +6,7 @@ -- --   1. An optional direction parameter, specifying which nodes to visit next. -----      [@x@] undirectional: ignore edge direction+--      [@u@] undirectional: ignore edge direction --      [@r@] reversed: walk edges in reverse --      [@x@] user defined: speciy which paths to follow --

@@ -1,5 +1,5 @@ name:          fgl-version:       5.5.3.0+version:       5.5.3.1 license:       BSD3 license-file:  LICENSE author:        Martin Erwig, Ivan Lazar Miljenovic@@ -91,7 +91,7 @@     build-depends:    fgl                     , base                     , QuickCheck >= 2.8 && < 2.10-                    , hspec >= 2.1 && < 2.3+                    , hspec >= 2.1 && < 2.5                     , containers      hs-source-dirs:   test@@ -103,6 +103,26 @@                     , Data.Graph.Inductive.Graph.Properties                     , Data.Graph.Inductive.Proxy                     , Data.Graph.Inductive.Query.Properties++    ghc-options:      -Wall++}++benchmark fgl-benchmark {+    default-language: Haskell98++    type:             exitcode-stdio-1.0++    hs-source-dirs:   test++    main-is:          benchmark.hs++    other-modules:    Data.Graph.Inductive.Proxy++    build-depends:    fgl+                    , base+                    , microbench+                    , deepseq      ghc-options:      -Wall 

@@ -93,14 +93,14 @@ valid_match :: (Graph gr) => gr a b -> Property valid_match g = not (isEmpty g) ==> check_match <$> elements (nodes g)   where-    order = noNodes g+    ordr = noNodes g      check_match n = maybe False check_context mc       where         (mc, g') = match n g          check_context c = (node' c `notElem` nodes g')-                          && (noNodes g' == order - 1)+                          && (noNodes g' == ordr - 1)                           -- Edges were previously in the graph                           && all (elem (node' c) . pre g) (sucC c)                           && all (elem (node' c) . suc g) (preC c)

@@ -0,0 +1,173 @@+{-+  This program should generally be run using `cabal bench` or+  `stack bench`. To use `stack bench`, edit stack.yaml to include++  extra-deps:+  - microbench-0.1++  To run benchmarks manually, install microbench from+  http://hackage.haskell.org/cgi-bin/hackage-scripts/package/microbench++  then run++  % ghc -O --make benchmark+  % ./benchmark+  [1 of 1] Compiling Main             ( benchmark.hs, benchmark.o )+  Linking benchmark ...+  * insNode into AVL tree: ..................+    8.877ns per iteration / 112655.53 per second.+  * insNode into PATRICIA tree: .....................+    1.788ns per iteration / 559342.86 per second.+  * insEdge into AVL tree: ...........+    2833.029ns per iteration / 352.98 per second.+  * insEdge into PATRICIA tree: ...................+    4.625ns per iteration / 216224.60 per second.+  * gmap on AVL tree: ................+    32.754ns per iteration / 30530.57 per second.+  * gmap on PATRICIA tree: .....................+    1.623ns per iteration / 616056.37 per second.+  * nmap on AVL tree: ................+    35.455ns per iteration / 28204.95 per second.+  * nmap on PATRICIA tree: .....................+    1.713ns per iteration / 583758.06 per second.+  * emap on AVL tree: ...........+    4416.303ns per iteration / 226.43 per second.+  * emap on PATRICIA tree: ...................+    4.532ns per iteration / 220663.09 per second.+-}++{-# LANGUAGE ScopedTypeVariables #-}++module Main (main) where++import           Control.DeepSeq+import           Data.Graph.Inductive.Graph+import qualified Data.Graph.Inductive.PatriciaTree as Patricia+import           Data.Graph.Inductive.Proxy+import qualified Data.Graph.Inductive.Tree         as AVL+import           Microbench++main :: IO ()+main = do microbench "insNode into AVL tree" insNodeAVL+          microbench "insNode into PATRICIA tree" insNodePatricia++          microbench "buildFull into AVL tree 100" (buildFullAVL 100)+          microbench "buildFull into AVL tree 500" (buildFullAVL 500)+          microbench "buildFull into AVL tree 1000" (buildFullAVL 1000)++          microbench "buildFull into PATRICIA tree 100" (buildFullPatricia 100)+          microbench "buildFull into PATRICIA tree 500" (buildFullPatricia 500)+          microbench "buildFull into PATRICIA tree 1000" (buildFullPatricia 1000)++          microbench "insEdge into AVL tree" insEdgeAVL+          microbench "insEdge into PATRICIA tree" insEdgePatricia++          microbench "gmap on AVL tree" gmapAVL+          microbench "gmap on PATRICIA tree" gmapPatricia++          microbench "nmap on AVL tree" nmapAVL+          microbench "nmap on PATRICIA tree" nmapPatricia++          microbench "emap on AVL tree" emapAVL+          microbench "emap on PATRICIA tree" emapPatricia++buildFullAVL :: Int -> Int -> ()+buildFullAVL = buildFull (Proxy :: TreeP)++insNodeAVL :: Int -> AVL.UGr+insNodeAVL = insNodes' empty++buildFullPatricia :: Int -> Int -> ()+buildFullPatricia = buildFull (Proxy :: PatriciaTreeP)++insNodePatricia :: Int -> Patricia.UGr+insNodePatricia = insNodes' empty++buildFull :: forall gr . (DynGraph gr, NFData (gr Int ()))+             => GraphProxy gr -> Int -> Int -> ()+buildFull _ sz ntimes = rnf [buildFull' i (empty :: gr Int ()) 0 sz | i <- [0..ntimes-1]]++buildFull' :: DynGraph gr => a -> gr a () -> Int -> Int -> gr a ()+buildFull' a g n limit+  | n == limit = empty+  | otherwise = ([((), k) | k <- [0..n-1]],n,a,[((),k) | k <- [0..n-1]]) & buildFull' a g (n + 1) limit+++{-# INLINE insNodes' #-}+insNodes' :: DynGraph gr => gr () b -> Int -> gr () b+insNodes' g 0 = g+insNodes' g n = let [v] = newNodes 1 g+                    g'  = insNode (v, ()) g+                in+                  insNodes' g' (n - 1)+++insEdgeAVL :: Int -> AVL.UGr+insEdgeAVL n = insEdges' (insNodeAVL n) n+++insEdgePatricia :: Int -> Patricia.UGr+insEdgePatricia n = insEdges' (insNodePatricia n) n+++{-# INLINE insEdges' #-}+insEdges' :: DynGraph gr => gr a () -> Int -> gr a ()+insEdges' g 0 = g+insEdges' g n = let n' = n - 1+                    g' = insEdge (0, n', ()) g+                in+                  insEdges' g' n'+++gmapAVL :: Int -> AVL.Gr Int ()+gmapAVL n+    = let g  = insNodeAVL n+          g' = gmap f g+          f (ps, v, _, ss) = (ps, v, v, ss)+      in+        g'+++gmapPatricia :: Int -> Patricia.Gr Int ()+gmapPatricia n+    = let g  = insNodePatricia n+          g' = gmap f g+          f (ps, v, _, ss) = (ps, v, v, ss)+      in+        g'+++nmapAVL :: Int -> AVL.Gr Int ()+nmapAVL n+    = let g   = insNodeAVL n+          g'  = nmap f g+          f _ = n+      in+        g'+++nmapPatricia :: Int -> Patricia.Gr Int ()+nmapPatricia n+    = let g   = insNodePatricia n+          g'  = nmap f g+          f _ = n+      in+        g'+++emapAVL :: Int -> AVL.Gr () Int+emapAVL n+    = let g   = insEdgeAVL n+          g'  = emap f g+          f _ = n+      in+        g'+++emapPatricia :: Int -> Patricia.Gr () Int+emapPatricia n+    = let g   = insEdgePatricia n+          g'  = emap f g+          f _ = n+      in+        g'