dom-lt 0.2.0 → 0.2.1
raw patch · 5 files changed
+257/−166 lines, 5 filesdep +HUnitdep ~basesetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: HUnit
Dependency ranges changed: base
API changes (from Hackage documentation)
Files
- Changelog.md +18/−14
- Data/Graph/Dom.hs +34/−29
- Setup.lhs +2/−2
- dom-lt.cabal +68/−60
- tests/Main.hs +135/−61
Changelog.md view
@@ -1,15 +1,19 @@-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. +## Changes in version 0.2.1++* Fixed a bug that resulted in incorrect results.++## 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.
Data/Graph/Dom.hs view
@@ -459,14 +459,23 @@ predG :: Graph -> Graph predG g = IM.unionWith IS.union (go g) g0 where g0 = fmap (const mempty) g- f :: IntMap IntSet -> Int -> IntSet -> IntMap IntSet- f m i a = foldl' (\m p -> IM.insertWith mappend p+ go = flip IM.foldrWithKey mempty (\i a m ->+ foldl' (\m p -> IM.insertWith mappend p (IS.singleton i) m) m- (IS.toList a)- go :: IntMap IntSet -> IntMap IntSet- go = flip IM.foldlWithKey' mempty f+ (IS.toList a)) +-- predG :: Graph -> Graph+-- predG g = IM.unionWith IS.union (go g) g0+-- where g0 = fmap (const mempty) g+-- 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)+-- go :: IntMap IntSet -> IntMap IntSet+-- go = flip IM.foldlWithKey' mempty f+ pruneReach :: Rooted -> Rooted pruneReach (r,g) = (r,g2) where is = reachable@@ -525,28 +534,24 @@ -- (renamed, old -> new) renum :: Int -> Graph -> (Graph, NodeMap Node) renum from = (\(_,m,g)->(g,m))- . 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)+ . IM.foldrWithKey+ (\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) ----------------------------------------------------------------------------- @@ -554,10 +559,10 @@ instance Functor (S z s) where fmap f (S g) = S (\k -> g (k . f)) instance Monad (S z s) where- return a = S (\k -> k a)+ return = pure S g >>= f = S (\k -> g (\a -> unS (f a) k)) instance Applicative (S z s) where- pure = return+ pure a = S (\k -> k a) (<*>) = ap -- get :: S z s s -- get = S (\k s -> k s s)
Setup.lhs view
@@ -1,3 +1,3 @@-> import Distribution.Simple -> main :: IO () +> import Distribution.Simple+> main :: IO () > main = defaultMain
dom-lt.cabal view
@@ -1,60 +1,68 @@-name: dom-lt -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: 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: - 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 - 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 - +name: dom-lt+version: 0.2.1+cabal-version: >= 1.10+build-type: Simple+tested-with: GHC == 8.10.1 || == 8.8.4 || == 8.0.1+license: BSD3+license-file: LICENSE+category: Algorithms, Graphs+author: Matt Morrow+copyright: (c) Matt Morrow, 2009+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:+ 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+ default-extensions: RankNTypes+ build-depends:+ base >= 4.9 && < 5+ , array+ , containers >= 0.5 && < 0.7+ 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 >=4.6 && <5+ , dom-lt+ , containers+ , HUnit >=1.3 && <1.7++ 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+
tests/Main.hs view
@@ -1,61 +1,135 @@-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 - - - +{-# OPTIONS_GHC -Wno-missing-signatures #-}++module Main (main) where++import Data.Graph.Dom as G+import Data.Tree+import System.Exit++import Test.HUnit hiding (Node,Path)+-- import Test.Framework.Providers.QuickCheck2+-- import Test.QuickCheck (Property, (===))+-- import Test.QuickCheck.Function (Fun, apply)+-- import Test.QuickCheck.Poly (A, OrdA, B, OrdB, C)++-- main = defaultMain+-- [ test_dom+-- , testtest_pdom+-- , test_idom+-- , test_ipdom+-- , test_domTree+-- , test_pdomTree+-- ]++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,[])]++main = do+ counts <- runTestTT tests+ putStrLn $ showCounts counts+ if (errors counts + failures counts) > 0+ then exitWith $ ExitFailure 1+ else exitWith ExitSuccess++tests = TestList $ map TestCase [dom0, dom1, pdom0, pdom1, ipdom0, ipdom1, dom_t_g0, dom_t_g1, dom_pt_g0, dom_pt_g1]++g0_rooted, g1_rooted :: Rooted+g0_rooted = (1,g0)+g1_rooted = (0,g1)++dom0 = assertEqual "dom g0"+ [(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])]+ (dom g0_rooted)++dom1 = assertEqual "dom g1"+ [(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])]+ (dom g1_rooted)++pdom0 = assertEqual "pdom g0"+ [(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])]+ (pdom g0_rooted)++pdom1 = assertEqual "pdom g1"+ []+ (pdom g1_rooted)++ipdom0 = assertEqual "ipdom g0"+ [(10,7),(8,9),(9,1),(7,8),(6,7),(5,7),(4,7),(3,4),(2,3),(1,1)]+ (ipdom g0_rooted)++ipdom1 = assertEqual "ipdom g1"+ [(0,0)]+ (ipdom g1_rooted)++dom_t_g0 = assertEqual "domTree g0"+ ( 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 = []}]}]}]}]}]} )+ (domTree g0_rooted)++dom_t_g1 = assertEqual "domTree g1"+ ( 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 = []}]}]} )+ (domTree g1_rooted)++dom_pt_g0 = assertEqual "pdomTree g0"+ ( 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 = []}]}]}]}]} )+ (pdomTree g0_rooted)++dom_pt_g1 = assertEqual "pdomTree g1"+ ( Node {rootLabel = 0, subForest = []} )+ (pdomTree g1_rooted)+++++-- 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+++