dom-lt 0.1.3 → 0.2.0

raw patch · 5 files changed

+276/−105 lines, 5 filesdep +criteriondep +deepseqdep +dom-ltdep ~arraydep ~basedep ~containersnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: criterion, deepseq, dom-lt

Dependency ranges changed: array, base, containers

API changes (from Hackage documentation)

Files

• Changelog.md +15/−0
• Data/Graph/Dom.hs +103/−98
• benchmarks/Main.hs +53/−0
• dom-lt.cabal +44/−7
• tests/Main.hs +61/−0

@@ -0,0 +1,15 @@+Changes in version 0.2.0
+
+* Better performance!
+* Major bump because of strictness changes.
+* Functions are now slightly stricter.
+  In the past the successor list of nodes unreachable from the root wasn't evaluated.
+  This is no longer the case and they will be evaluated.
+  Moving forward users should expect all inputs to be evaluated unless stated otherwise.
+* Requires GHC >= 8.0 to build (base dependency)
+* Requires containers >= 0.5
+* Exchanged the deprecated container functions with their replacements.
+* Replaced a few right folds with strict left folds.
+* Commented out/removed some unused code.
+* Replaced mapsnd and swap with variants from base.
+* Add very simplistic benchmark/test suites.

@@ -1,11 +1,11 @@-{-# LANGUAGE RankNTypes, BangPatterns, FlexibleContexts #-}+{-# LANGUAGE RankNTypes, BangPatterns, FlexibleContexts, Strict #-}  {- |   Module      :  Data.Graph.Dom   Copyright   :  (c) Matt Morrow 2009   License     :  BSD3-  Maintainer  :  <morrow@moonpatio.com>-  Stability   :  experimental+  Maintainer  :  <klebinger.andreas@gmx.at>+  Stability   :  stable   Portability :  portable    The Lengauer-Tarjan graph dominators algorithm.@@ -19,6 +19,12 @@     \[3\] Brisk, Sarrafzadeh,       /Interference Graphs for Procedures in Static Single/       /Information Form are Interval Graphs/, 2007.++ * Strictness++ Unless stated otherwise all exposed functions might fully evaluate their input+ but are not guaranteed to do so.+ -}  module Data.Graph.Dom (@@ -34,22 +40,24 @@   ,parents,ancestors ) where +import Data.Monoid(Monoid(..))+import Data.Bifunctor+import Data.Tuple (swap)+ import Data.Tree import Data.List-import Data.Map(Map) import Data.IntMap(IntMap) import Data.IntSet(IntSet)-import qualified Data.Map as M-import qualified Data.IntMap as IM+import qualified Data.IntMap.Strict as IM import qualified Data.IntSet as IS-import Data.Monoid(Monoid(..))-import Control.Applicative+ import Control.Monad+import Control.Monad.ST.Strict+ import Data.Array.ST import Data.Array.Base   (unsafeNewArray_   ,unsafeWrite,unsafeRead)-import Control.Monad.ST.Strict  ----------------------------------------------------------------------------- @@ -100,7 +108,7 @@ -- | /Immediate post-dominators/. -- Complexity as for @idom@. ipdom :: Rooted -> [(Node,Node)]-ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (mapsnd predG rg)))+ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predG rg)))  ----------------------------------------------------------------------------- @@ -338,7 +346,7 @@ fromEnv = do   dom   <- gets domE   rn    <- gets rnE-  r     <- gets rootE+  -- r     <- gets rootE   (_,n) <- st (getBounds dom)   forM [1..n] (\i-> do     j <- st(rn!:i)@@ -364,8 +372,8 @@ sizeM = fetch sizeE sdnoM :: Node -> Dom s Int sdnoM = fetch sdnoE-dfnM :: Node -> Dom s Int-dfnM = fetch dfnE+-- dfnM :: Node -> Dom s Int+-- dfnM = fetch dfnE ndfsM :: Int -> Dom s Node ndfsM = fetch ndfsE childM :: Node -> Dom s Node@@ -408,28 +416,28 @@ newI :: Int -> ST s (Arr s Int) newI = new -newD :: Int -> ST s (Arr s Double)-newD = new+-- newD :: Int -> ST s (Arr s Double)+-- newD = new -dump :: (MArray (A s) a (ST s)) => Arr s a -> ST s [a]-dump a = do-  (m,n) <- getBounds a-  forM [m..n] (\i -> a!:i)+-- dump :: (MArray (A s) a (ST s)) => Arr s a -> ST s [a]+-- dump a = do+--   (m,n) <- getBounds a+--   forM [m..n] (\i -> a!:i)  writes :: (MArray (A s) a (ST s))      => Arr s a -> [(Int,a)] -> ST s () writes a xs = forM_ xs (\(i,x) -> (a.=x) i) -arr :: (MArray (A s) a (ST s)) => [a] -> ST s (Arr s a)-arr xs = do-  let n = length xs-  a <- new n-  go a n 0 xs-  return a-  where go _ _ _    [] = return ()-        go a n i (x:xs)-          | i <= n = (a.=x) i >> go a n (i+1) xs-          | otherwise = return ()+-- arr :: (MArray (A s) a (ST s)) => [a] -> ST s (Arr s a)+-- arr xs = do+--   let n = length xs+--   a <- new n+--   go a n 0 xs+--   return a+--   where go _ _ _    [] = return ()+--         go a n i (x:xs)+--           | i <= n = (a.=x) i >> go a n (i+1) xs+--           | otherwise = return ()  ----------------------------------------------------------------------------- @@ -437,25 +445,27 @@ (!) g n = maybe mempty id (IM.lookup n g)  fromAdj :: [(Node, [Node])] -> Graph-fromAdj = IM.fromList . fmap (mapsnd IS.fromList)+fromAdj = IM.fromList . fmap (second IS.fromList)  fromEdges :: [Edge] -> Graph fromEdges = collectI IS.union fst (IS.singleton . snd)  toAdj :: Graph -> [(Node, [Node])]-toAdj = fmap (mapsnd IS.toList) . IM.toList+toAdj = fmap (second IS.toList) . IM.toList++toEdges :: Graph -> [Edge] toEdges = concatMap (uncurry (fmap . (,))) . toAdj  predG :: Graph -> Graph--toEdges :: Graph -> [Edge] predG g = IM.unionWith IS.union (go g) g0   where g0 = fmap (const mempty) g-        go = flip IM.foldWithKey mempty (\i a m ->-                foldl' (\m p -> IM.insertWith mappend p+        f :: IntMap IntSet -> Int -> IntSet -> IntMap IntSet+        f m i a = foldl' (\m p -> IM.insertWith mappend p                                       (IS.singleton i) m)                         m-                       (IS.toList a))+                       (IS.toList a)+        go :: IntMap IntSet -> IntMap IntSet+        go = flip IM.foldlWithKey' mempty f  pruneReach :: Rooted -> Rooted pruneReach (r,g) = (r,g2)@@ -463,7 +473,7 @@               (maybe mempty id                 . flip IM.lookup g) $ r         g2 = IM.fromList-            . fmap (mapsnd (IS.filter (`IS.member`is)))+            . fmap (second (IS.filter (`IS.member`is)))             . filter ((`IS.member`is) . fst)             . IM.toList $ g @@ -505,43 +515,38 @@                                   (f a)                                   (g a) m) mempty -collect :: (Ord b) => (c -> c -> c)-        -> (a -> b) -> (a -> c) -> [a] -> Map b c-collect (<>) f g-  = foldl' (\m a -> M.insertWith' (<>)-                                  (f a)-                                  (g a) m) mempty--swap :: (a,b) -> (b,a)-swap = uncurry (flip (,))--mapfst :: (a -> c) -> (a,b) -> (c,b)-mapfst f = \(a,b) -> (f a, b)--mapsnd :: (b -> c) -> (a,b) -> (a,c)-mapsnd f = \(a,b) -> (a, f b)+-- collect :: (Ord b) => (c -> c -> c)+--         -> (a -> b) -> (a -> c) -> [a] -> Map b c+-- collect (<>) f g+--   = foldl' (\m a -> SM.insertWith (<>)+--                                   (f a)+--                                   (g a) m) mempty  -- (renamed, old -> new) renum :: Int -> Graph -> (Graph, NodeMap Node) renum from = (\(_,m,g)->(g,m))-  . IM.foldWithKey-      (\i ss (!n,!env,!new)->-          let (j,n2,env2) = go n env i-              (n3,env3,ss2) = IS.fold-                (\k (!n,!env,!new)->-                    case go n env k of-                      (l,n2,env2)-> (n2,env2,l `IS.insert` new))-                (n2,env2,mempty) ss-              new2 = IM.insertWith IS.union j ss2 new-          in (n3,env3,new2)) (from,mempty,mempty)-  where go :: Int-           -> NodeMap Node-           -> Node-           -> (Node,Int,NodeMap Node)-        go !n !env i =-          case IM.lookup i env of-            Just j -> (j,n,env)-            Nothing -> (n,n+1,IM.insert i n env)+  . IM.foldlWithKey'+      f (from,mempty,mempty)+  where+    f :: (Int, NodeMap Node, IntMap IntSet) -> Node -> IntSet+      -> (Int, NodeMap Node, IntMap IntSet)+    f (!n,!env,!new) i ss =+            let (j,n2,env2) = go n env i+                (n3,env3,ss2) = IS.fold+                  (\k (!n,!env,!new)->+                      case go n env k of+                        (l,n2,env2)-> (n2,env2,l `IS.insert` new))+                  (n2,env2,mempty) ss+                new2 = IM.insertWith IS.union j ss2 new+            in (n3,env3,new2)+    go :: Int+        -> NodeMap Node+        -> Node+        -> (Node,Int,NodeMap Node)+    go !n !env i =+        case IM.lookup i env of+        Just j -> (j,n,env)+        Nothing -> (n,n+1,IM.insert i n env)  ----------------------------------------------------------------------------- @@ -554,20 +559,20 @@ instance Applicative (S z s) where   pure = return   (<*>) = ap-get :: S z s s-get = S (\k s -> k s s)+-- get :: S z s s+-- get = S (\k s -> k s s) gets :: (s -> a) -> S z s a gets f = S (\k s -> k (f s) s)-set :: s -> S z s ()-set s = S (\k _ -> k () s)+-- set :: s -> S z s ()+-- set s = S (\k _ -> k () s) modify :: (s -> s) -> S z s () modify f = S (\k -> k () . f)-runS :: S z s a -> s -> ST z (a, s)-runS (S g) = g (\a s -> return (a,s))+-- runS :: S z s a -> s -> ST z (a, s)+-- runS (S g) = g (\a s -> return (a,s)) evalS :: S z s a -> s -> ST z a evalS (S g) = g ((return .) . const)-execS :: S z s a -> s -> ST z s-execS (S g) = g ((return .) . flip const)+-- execS :: S z s a -> s -> ST z s+-- execS (S g) = g ((return .) . flip const) st :: ST z a -> S z s a st m = S (\k s-> do   a <- m@@ -585,26 +590,26 @@  ----------------------------------------------------------------------------- -g0 = fromAdj-  [(1,[2,3])-  ,(2,[3])-  ,(3,[4])-  ,(4,[3,5,6])-  ,(5,[7])-  ,(6,[7])-  ,(7,[4,8])-  ,(8,[3,9,10])-  ,(9,[1])-  ,(10,[7])]+-- g0 = fromAdj+--   [(1,[2,3])+--   ,(2,[3])+--   ,(3,[4])+--   ,(4,[3,5,6])+--   ,(5,[7])+--   ,(6,[7])+--   ,(7,[4,8])+--   ,(8,[3,9,10])+--   ,(9,[1])+--   ,(10,[7])] -g1 = fromAdj-  [(0,[1])-  ,(1,[2,3])-  ,(2,[7])-  ,(3,[4])-  ,(4,[5,6])-  ,(5,[7])-  ,(6,[4])-  ,(7,[])]+-- g1 = fromAdj+--   [(0,[1])+--   ,(1,[2,3])+--   ,(2,[7])+--   ,(3,[4])+--   ,(4,[5,6])+--   ,(5,[7])+--   ,(6,[4])+--   ,(7,[])]  -----------------------------------------------------------------------------

@@ -0,0 +1,53 @@+module Main(main) where
+
+import Data.Graph.Dom
+import Control.DeepSeq
+import Criterion.Main
+
+g0 :: Rooted
+g0 = (1,
+      fromAdj
+        [(1,[2,3])
+        ,(2,[3])
+        ,(3,[4])
+        ,(4,[3,5,6])
+        ,(5,[7])
+        ,(6,[7])
+        ,(7,[4,8])
+        ,(8,[3,9,10])
+        ,(9,[1])
+        ,(10,[7])]
+    )
+
+g1 :: Rooted
+g1 = (0,
+       fromAdj
+        [(0,[1])
+        ,(1,[2,3])
+        ,(2,[7])
+        ,(3,[4])
+        ,(4,[5,6])
+        ,(5,[7])
+        ,(6,[4])
+        ,(7,[])]
+    )
+
+-- Our benchmark harness.
+main :: IO ()
+main = g0 `deepseq` g1 `deepseq`
+    defaultMain [
+        bgroup "g0" [ bench "dom"       $ nf dom g0
+                    , bench "pdom"      $ nf pdom g0
+                    , bench "idom"      $ nf idom g0
+                    , bench "ipdom"     $ nf ipdom g0
+                    , bench "domTree"   $ nf domTree g0
+                    , bench "pdomTree"  $ nf pdomTree g0
+            ],
+        bgroup "g1" [ bench "dom"       $ nf dom g1
+                    , bench "pdom"      $ nf pdom g1
+                    , bench "idom"      $ nf idom g1
+                    , bench "ipdom"     $ nf ipdom g1
+                    , bench "domTree"   $ nf domTree g1
+                    , bench "pdomTree"  $ nf pdomTree g1
+            ]
+        ]

@@ -1,23 +1,60 @@ name:               dom-lt
-version:            0.1.3
-cabal-version:      >= 1.6
+version:            0.2.0
+cabal-version:      >= 1.10
 build-type:         Simple
 license:            BSD3
 license-file:       LICENSE
 category:           Algorithms, Graphs
 author:             Matt Morrow
 copyright:          (c) Matt Morrow, 2009
-maintainer:         Matt Morrow <morrow@moonpatio.com>
-stability:          experimental
+maintainer:         Andreas Klebinger <klebinger.andreas@gmx.at>
+bug-reports:        https://github.com/AndreasPK/dom-lt/issues
+stability:          stable
 synopsis:           The Lengauer-Tarjan graph dominators algorithm.
-description:        .
+description:
+    The Lengauer-Tarjan graph dominators algorithm.
 
+    Included are ways to compute domination and post-domination relationships.
+
+Extra-Source-Files:
+  Changelog.md
+
+source-repository head
+  type: git
+  location: https://github.com/AndreasPK/dom-lt
+
 library
+  Default-Language: Haskell2010
   includes:
   build-tools:
   extra-libraries:
   hs-source-dirs:   .
   ghc-options:      -O2 -funbox-strict-fields
-  extensions:       RankNTypes
-  build-depends:    base==4.*, array, containers
+  default-extensions: RankNTypes
+  build-depends:    base >= 4.9 && < 5, array, containers >= 0.5
   exposed-modules:  Data.Graph.Dom
+
+test-suite dom-lt-tests
+  Default-Language: Haskell2010
+  type: exitcode-stdio-1.0
+
+  Main-Is:  Main.hs
+  hs-source-dirs: tests
+
+  Build-Depends: base, dom-lt, containers
+
+  default-extensions:
+  Ghc-Options: -Wall
+
+benchmark dom-lt-bench
+  Default-Language: Haskell2010
+  type: exitcode-stdio-1.0
+
+  Main-Is:  Main.hs
+  hs-source-dirs: benchmarks
+
+  Build-Depends: base, dom-lt, containers, criterion >= 1.4, deepseq
+  default-extensions:
+
+  Ghc-Options: -O2 -fno-full-laziness
+

@@ -0,0 +1,61 @@+module Main (main) where
+
+import Data.Graph.Dom as G
+import Data.Tree
+import System.Exit
+
+g0 :: Graph
+g0 = fromAdj
+  [(1,[2,3])
+  ,(2,[3])
+  ,(3,[4])
+  ,(4,[3,5,6])
+  ,(5,[7])
+  ,(6,[7])
+  ,(7,[4,8])
+  ,(8,[3,9,10])
+  ,(9,[1])
+  ,(10,[7])]
+
+g1 :: Graph
+g1 = fromAdj
+  [(0,[1])
+  ,(1,[2,3])
+  ,(2,[7])
+  ,(3,[4])
+  ,(4,[5,6])
+  ,(5,[7])
+  ,(6,[4])
+  ,(7,[])]
+
+applyDomFunctions :: Rooted
+                  -> ([(Node, Path)], [(Node, Path)], [(Node, Node)], [(Node, Node)], Tree Node, Tree Node)
+applyDomFunctions g = (dom g, pdom g, idom g, ipdom g, domTree g, pdomTree g)
+
+g0_expected :: ([(Node, Path)], [(Node, Path)], [(Node, Node)], [(Node, Node)], Tree Node, Tree Node)
+g0_expected = (
+  [(2,[1]),(3,[1]),(4,[3,1]),(5,[4,3,1]),(6,[4,3,1]),(7,[4,3,1]),(8,[7,4,3,1]),(9,[8,7,4,3,1]),(10,[8,7,4,3,1])],
+  [(9,[1]),(8,[9,1]),(7,[8,9,1]),(4,[7,8,9,1]),(5,[7,8,9,1]),(6,[7,8,9,1]),(10,[7,8,9,1]),(3,[4,7,8,9,1]),(2,[3,4,7,8,9,1])],
+  [(10,8),(7,4),(9,8),(1,1),(8,7),(3,1),(4,3),(6,4),(5,4),(2,1)],
+  [(10,7),(8,9),(9,1),(7,8),(6,7),(5,7),(4,7),(3,4),(2,3),(1,1)],
+  Node {rootLabel = 1, subForest = [Node {rootLabel = 2, subForest = []},Node {rootLabel = 3, subForest = [Node {rootLabel = 4, subForest = [Node {rootLabel = 5, subForest = []},Node {rootLabel = 6, subForest = []},Node {rootLabel = 7, subForest = [Node {rootLabel = 8, subForest = [Node {rootLabel = 9, subForest = []},Node {rootLabel = 10, subForest = []}]}]}]}]}]},
+  Node {rootLabel = 1, subForest = [Node {rootLabel = 9, subForest = [Node {rootLabel = 8, subForest = [Node {rootLabel = 7, subForest = [Node {rootLabel = 4, subForest = [Node {rootLabel = 3, subForest = [Node {rootLabel = 2, subForest = []}]}]},Node {rootLabel = 5, subForest = []},Node {rootLabel = 6, subForest = []},Node {rootLabel = 10, subForest = []}]}]}]}]}
+  )
+
+g1_expected :: ([(Node, Path)], [(Node, Path)], [(Node, Node)], [(Node, Node)], Tree Node, Tree Node)
+g1_expected = (
+    [(1,[0]),(2,[1,0]),(3,[1,0]),(7,[1,0]),(4,[3,1,0]),(5,[4,3,1,0]),(6,[4,3,1,0])],
+    [],[(7,1),(6,4),(4,3),(5,4),(3,1),(2,1),(1,0),(0,0)],[(0,0)],
+    Node {rootLabel = 0, subForest = [Node {rootLabel = 1, subForest = [Node {rootLabel = 2, subForest = []},Node {rootLabel = 3, subForest = [Node {rootLabel = 4, subForest = [Node {rootLabel = 5, subForest = []},Node {rootLabel = 6, subForest = []}]}]},
+    Node {rootLabel = 7, subForest = []}]}]},Node {rootLabel = 0, subForest = []})
+
+main :: IO ()
+main = do
+    let g0_result = applyDomFunctions (1,g0)
+    let g1_result = applyDomFunctions (0,g1)
+    if g0_result == g0_expected && g1_result == g1_expected
+        then exitWith ExitSuccess
+        else exitWith $ ExitFailure 1
+
+
+