diff --git a/Data/RTree.hs b/Data/RTree.hs --- a/Data/RTree.hs +++ b/Data/RTree.hs @@ -1,6 +1,6 @@ {- | Module : Data.RTree - Copyright : Copyright (c) 2014, Birte Wagner, Sebastian Philipp + Copyright : Copyright (c) 2015, Birte Wagner, Sebastian Philipp License : MIT Maintainer : Birte Wagner, Sebastian Philipp (sebastian@spawnhost.de) @@ -43,8 +43,12 @@ , unionWith -- * Searching and Properties , lookup + , intersectWithKey + , intersect , lookupRange , lookupRangeWithKey + , lookupContainsRange + , lookupContainsRangeWithKey , length , null , keys diff --git a/Data/RTree/Base.hs b/Data/RTree/Base.hs --- a/Data/RTree/Base.hs +++ b/Data/RTree/Base.hs @@ -1,9 +1,13 @@ -{-# LANGUAGE NoMonomorphismRestriction, DeriveFunctor, OverlappingInstances, DeriveDataTypeable, BangPatterns #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} {- | Module : Data.RTree.Base - Copyright : Copyright (c) 2014, Birte Wagner, Sebastian Philipp + Copyright : Copyright (c) 2015, Birte Wagner, Sebastian Philipp License : MIT Maintainer : Birte Wagner, Sebastian Philipp (sebastian@spawnhost.de) @@ -31,8 +35,12 @@ , unionWith -- * Searching and Properties , lookup + , intersectWithKey + , intersect , lookupRange , lookupRangeWithKey + , lookupContainsRangeWithKey + , lookupContainsRange , length , null , keys @@ -40,7 +48,6 @@ -- * Lists , fromList , toList - -- * Internal and Testing , foldWithMBB , pp @@ -61,23 +68,19 @@ ) where -import Prelude hiding (lookup, length, null, map) - -import Data.Binary -import Data.Function (on) -import Data.List (maximumBy, minimumBy, partition) -import qualified Data.List as L (length,map) -import Data.Maybe (catMaybes, isJust) -import qualified Data.Maybe as Maybe (mapMaybe) -import Data.Monoid (Monoid, mempty, mappend) -import Data.Typeable (Typeable) - -import Control.Applicative ((<$>)) import Control.DeepSeq (NFData, rnf) - -import GHC.Generics (Generic) +import Data.Binary +import Data.Function (on) +import Data.List (maximumBy, minimumBy, partition) +import qualified Data.List as L (length, map) +import Data.Maybe (catMaybes, isJust) +import qualified Data.Maybe as Maybe (mapMaybe) +import Data.Typeable (Typeable) +import Data.Semigroup +import GHC.Generics (Generic) +import Prelude hiding (length, lookup, map, null) -import Data.RTree.MBB hiding (mbb) +import Data.RTree.MBB hiding (mbb) data RTree a = Node4 {getMBB :: {-# UNPACK #-} ! MBB, getC1 :: ! (RTree a), getC2 :: ! (RTree a), getC3 :: ! (RTree a), getC4 :: ! (RTree a) } @@ -113,7 +116,7 @@ -- | creates a single element tree singleton :: MBB -> a -> RTree a -singleton mbb x = Leaf mbb x +singleton = Leaf node :: MBB -> [RTree a] -> RTree a node mbb [x,y] = Node2 mbb x y @@ -129,19 +132,19 @@ norm (Node4 mbb x y z w) = Node mbb [x,y,z,w] norm (Node3 mbb x y z) = Node mbb [x,y,z] norm (Node2 mbb x y) = Node mbb [x,y] -norm x = x +norm x = x getChildren :: RTree a -> [RTree a] -getChildren Empty = error "getChildren: Empty" +getChildren Empty = error "getChildren: Empty" getChildren Leaf{} = error "getChildren: Leaf" -getChildren t = getChildren' $ norm t +getChildren t = getChildren' $ norm t -- ---------------------------------- -- Lists -- | creates a tree out of pairs fromList :: [(MBB, a)] -> RTree a -fromList l = fromList' $ (uncurry singleton) <$> l +fromList l = fromList' $ uncurry singleton <$> l -- | merges all singletons into a single tree. fromList' :: [RTree a] -> RTree a @@ -152,27 +155,21 @@ -- -- prop> toList t = zip (keys t) (values t) toList :: RTree a -> [(MBB, a)] -toList Empty = [] +toList Empty = [] toList (Leaf mbb x) = [(mbb, x)] -toList t = concatMap toList $ getChildren t +toList t = concatMap toList $ getChildren t -- | returns all keys in this tree -- -- prop> toList t = zip (keys t) (values t) keys :: RTree a -> [MBB] -keys = foldWithMBB handleLeaf handleNode [] - where - handleLeaf mbb _ = [mbb] - handleNode _ xs = concat xs +keys = foldWithMBB (\mbb _ -> [mbb]) (const concat) [] -- | returns all values in this tree -- -- prop> toList t = zip (keys t) (values t) values :: RTree a -> [a] -values = foldWithMBB handleLeaf handleNode [] - where - handleLeaf _ x = [x] - handleNode _ xs = concat xs +values = foldWithMBB (const pure) (const concat) [] -- ---------------------------------- @@ -180,7 +177,7 @@ -- | Inserts an element whith the given 'MBB' and a value in a tree. The combining function will be used if the value already exists. insertWith :: (a -> a -> a) -> MBB -> a -> RTree a -> RTree a -insertWith f mbb e oldRoot = unionDistinctWith f (singleton mbb e) oldRoot +insertWith f mbb e = unionDistinctWith f (singleton mbb e) -- | Inserts an element whith the given 'MBB' and a value in a tree. An existing value will be overwritten with the given one. -- @@ -190,7 +187,7 @@ simpleMergeEqNode :: (a -> a -> a) -> RTree a -> RTree a -> RTree a simpleMergeEqNode f l@Leaf{} r = Leaf (getMBB l) (on f getElem l r) -simpleMergeEqNode _ l _ = l +simpleMergeEqNode _ l _ = l -- | Unifies left and right 'RTree'. Will create invalid trees, if the tree is not a leaf and contains 'MBB's which -- also exists in the left tree. Much faster than union, though. @@ -198,13 +195,13 @@ unionDistinctWith _ Empty{} t = t unionDistinctWith _ t Empty{} = t unionDistinctWith f t1@Leaf{} t2@Leaf{} - | on (==) getMBB t1 t2 = simpleMergeEqNode f t1 t2 - | otherwise = createNodeWithChildren [t1, t2] -- root case + | on (==) getMBB t1 t2 = simpleMergeEqNode f t1 t2 + | otherwise = createNodeWithChildren [t1, t2] -- root case unionDistinctWith f left right - | depth left > depth right = unionDistinctWith f right left - | depth left == depth right = fromList' $ (getChildren left) ++ [right] - | (L.length $ getChildren newNode) > n = createNodeWithChildren $ splitNode newNode - | otherwise = newNode + | depth left > depth right = unionDistinctWith f right left + | depth left == depth right = fromList' $ getChildren left ++ [right] + | L.length (getChildren newNode) > n = createNodeWithChildren $ splitNode newNode + | otherwise = newNode where newNode = addLeaf f left right @@ -221,15 +218,15 @@ newChildren = findNodeWithMinimalAreaIncrease f left (getChildren right) (eq, nonEq) = partition (on (==) getMBB left) $ getChildren right newNode = case eq of - [] -> left + [] -> left [x] -> simpleMergeEqNode f left x - _ -> error "addLeaf: invalid RTree" + _ -> error "addLeaf: invalid RTree" findNodeWithMinimalAreaIncrease :: (a -> a -> a) -> RTree a -> [RTree a] -> [RTree a] findNodeWithMinimalAreaIncrease f leaf children = splitMinimal xsAndIncrease where -- xsAndIncrease :: [(RTree a, Double)] - xsAndIncrease = zip children ((areaIncreasesWith leaf) <$> children) + xsAndIncrease = zip children $ areaIncreasesWith leaf <$> children minimalIncrease = minimum $ snd <$> xsAndIncrease -- xsAndIncrease' :: [(RTree a, Double)] splitMinimal [] = [] @@ -239,7 +236,7 @@ unionDistinctSplit :: (a -> a -> a) -> RTree a -> RTree a -> [RTree a] unionDistinctSplit f leaf e - | (L.length $ getChildren newLeaf) > n = splitNode newLeaf + | L.length (getChildren newLeaf) > n = splitNode newLeaf | otherwise = [newLeaf] where newLeaf = addLeaf f leaf e @@ -264,22 +261,22 @@ quadSplit :: [RTree a] -> [RTree a] -> [RTree a] -> ([RTree a], [RTree a]) quadSplit left right [] = (left, right) quadSplit left right unfinished - | (L.length left) + (L.length unfinished) <= m = (left ++ unfinished, right) - | (L.length right) + (L.length unfinished) <= m = (left, right ++ unfinished) + | L.length left + L.length unfinished <= m = (left ++ unfinished, right) + | L.length right + L.length unfinished <= m = (left, right ++ unfinished) | isLeft'' = quadSplit (minimumElem : left) right newRest | otherwise = quadSplit left (minimumElem : right) newRest where -- makeTripel :: RTree a -> (RTree a, Bool, Double) makeTripel x = (x, isLeft, growth) where - isLeft = (areaIncreasesWithLeft) < (areaIncreasesWithRight) - growth = case isLeft of - True -> areaIncreasesWithLeft - False -> areaIncreasesWithRight - areaIncreasesWithLeft = (areaIncreasesWith x (createNodeWithChildren left)) - areaIncreasesWithRight = (areaIncreasesWith x (createNodeWithChildren right)) + isLeft = areaIncreasesWithLeft < areaIncreasesWithRight + growth = if isLeft + then areaIncreasesWithLeft + else areaIncreasesWithRight + areaIncreasesWithLeft = areaIncreasesWith x $ createNodeWithChildren left + areaIncreasesWithRight = areaIncreasesWith x $ createNodeWithChildren right (minimumElem, isLeft'', _) = minimumBy (compare `on` (\(_,_,g) -> g)) $ makeTripel <$> unfinished - newRest = (filter (on (/=) getMBB minimumElem) unfinished) + newRest = filter (on (/=) getMBB minimumElem) unfinished --mergeNodes :: RTree a -> RTree a -> RTree a --mergeNodes x@Node{} y@Node{} = node (unionMBB' x y) (on (++) getChildren x y) @@ -305,12 +302,27 @@ | mbb == getMBB t = Just $ getElem t | otherwise = Nothing lookup mbb t = case founds of - [] -> Nothing + [] -> Nothing x:_ -> Just x where matches = filter (\x -> (getMBB x) `containsMBB` mbb) $ getChildren t founds = catMaybes $ L.map (lookup mbb) matches +-- | returns all keys and values, which intersects with the given bounding box. +intersectWithKey :: MBB -> RTree a -> [(MBB, a)] +intersectWithKey _ Empty = [] +intersectWithKey mbb t@Leaf{} + | isJust $ intersectMBB mbb (getMBB t) = [(getMBB t, getElem t)] + | otherwise = [] +intersectWithKey mbb t = founds + where matches = filter intersectRTree $ getChildren t + founds = concatMap (intersectWithKey mbb) matches + intersectRTree x = isJust $ mbb `intersectMBB` (getMBB x) + +-- | returns all values, which intersects with the given bounding box. +intersect :: MBB -> RTree a -> [a] +intersect mbb t = snd <$> intersectWithKey mbb t + -- | returns all keys and values, which are located in the given bounding box. lookupRangeWithKey :: MBB -> RTree a -> [(MBB, a)] lookupRangeWithKey _ Empty = [] @@ -327,6 +339,22 @@ lookupRange :: MBB -> RTree a -> [a] lookupRange mbb t = snd <$> (lookupRangeWithKey mbb t) +-- | returns all keys and values containing the given bounding box +lookupContainsRangeWithKey :: MBB -> RTree a -> [(MBB, a)] +lookupContainsRangeWithKey _ Empty = [] +lookupContainsRangeWithKey mbb t@Leaf{} + | (getMBB t) `containsMBB` mbb = [(getMBB t, getElem t)] + | otherwise = [] +lookupContainsRangeWithKey mbb t = founds + where + matches = filter intersectRTree $ getChildren t + founds = concatMap (lookupContainsRangeWithKey mbb) matches + intersectRTree x = (getMBB x) `containsMBB` mbb + +-- | returns all values containing the given bounding box +lookupContainsRange :: MBB -> RTree a -> [a] +lookupContainsRange mbb t = snd <$> (lookupContainsRangeWithKey mbb t) + -- ----------- -- delete @@ -396,7 +424,7 @@ isValid _ Empty = True isValid _ Leaf{} = True isValid context x = case L.length c >= m && L.length c <= n && (and $ (isValid context) <$> c) && (isBalanced x) of - True -> True + True -> True False -> error ( "invalid " ++ show (L.length c) ++ " " ++ show context ) where isBalanced :: RTree a -> Bool @@ -432,15 +460,15 @@ -- ---------------------- depth :: RTree a -> Int -depth Empty = 0 +depth Empty = 0 depth (Leaf _ _ ) = 1 -depth t = 1 + (depth $ head $ getChildren t) +depth t = 1 + (depth $ head $ getChildren t) -- | returns the number of elements in a tree length :: RTree a -> Int -length Empty = 0 +length Empty = 0 length (Leaf {}) = 1 -length t = sum $ length <$> (getChildren t) +length t = sum $ length <$> (getChildren t) --delete' :: MBB -> RTree a -> Either (RTree a) [(MBB, a)] @@ -473,7 +501,9 @@ _ -> fail "RTree.get: error while decoding RTree" -instance (Monoid a) => Monoid (RTree a) where - mempty = empty - mappend = unionWith mappend +instance (Semigroup a) => Semigroup (RTree a) where + (<>) = unionWith (<>) +instance Monoid a => Monoid (RTree a) where + mempty = empty + mappend = (<>) diff --git a/Data/RTree/MBB.hs b/Data/RTree/MBB.hs --- a/Data/RTree/MBB.hs +++ b/Data/RTree/MBB.hs @@ -3,7 +3,7 @@ {- | Module : Data.RTree.MBB - Copyright : Copyright (c) 2014, Birte Wagner, Sebastian Philipp + Copyright : Copyright (c) 2015, Birte Wagner, Sebastian Philipp License : MIT Maintainer : Birte Wagner, Sebastian Philipp (sebastian@spawnhost.de) @@ -23,19 +23,19 @@ containsMBB, unionMBB, unionsMBB, - intersectMBB + intersectMBB, + isValidMBB, + isPointMBB ) where import Data.Binary -import Control.Applicative ((<$>), (<*>)) - import GHC.Generics (Generic) -- | Minimal bounding box data MBB = MBB {getUlx :: {-# UNPACK #-} ! Double, getUly :: {-# UNPACK #-} ! Double, getBrx :: {-# UNPACK #-} ! Double, getBry :: {-# UNPACK #-} ! Double} - deriving (Eq, Generic) + deriving (Eq, Generic, Ord) -- | created a minimal bounding box (or a rectangle) -- The first point must be smaller, than the second one. This is unchecked. @@ -46,6 +46,13 @@ -> MBB mbb = MBB +-- | the property, that a 'MBB' must hold +isValidMBB :: MBB -> Bool +isValidMBB (MBB ulx uly brx bry) = (ulx <= brx) && (uly <= bry) + +isPointMBB :: MBB -> Bool +isPointMBB (MBB ulx uly brx bry) = (ulx == brx) && (uly == bry) + -- | internal only. unionsMBB :: [MBB] -> MBB unionsMBB [] = error "unionsMBB': []" @@ -59,7 +66,7 @@ area :: MBB -> Double area (MBB ulx uly brx bry) = (brx - ulx) * (bry - uly) --- | returns True, when the first mbb contains the secons +-- | returns True, when the first mbb contains the second containsMBB :: MBB -> MBB -> Bool containsMBB (MBB x11 y11 x12 y12) (MBB x21 y21 x22 y22) = x11 <= x21 && y11 <= y21 && x12 >= x22 && y12 >= y22 diff --git a/Data/RTree/Strict.hs b/Data/RTree/Strict.hs --- a/Data/RTree/Strict.hs +++ b/Data/RTree/Strict.hs @@ -5,7 +5,7 @@ {- | Module : Data.RTree.Strict - Copyright : Copyright (c) 2014, Birte Wagner, Sebastian Philipp + Copyright : Copyright (c) 2015, Birte Wagner, Sebastian Philipp License : MIT Maintainer : Birte Wagner, Sebastian Philipp (sebastian@spawnhost.de) @@ -44,8 +44,12 @@ , unionWith -- * Searching and Properties , lookup + , intersectWithKey + , intersect , lookupRange , lookupRangeWithKey + , lookupContainsRange + , lookupContainsRangeWithKey , length , null , keys @@ -61,11 +65,10 @@ import Data.Function (on) import qualified Data.List as L (length) import qualified Data.Maybe as Maybe (mapMaybe) -import Data.Monoid (Monoid) +import Data.Semigroup import Data.Typeable (Typeable) import Control.DeepSeq (NFData) -import Data.Functor import GHC.Generics (Generic) --import Data.RTree.Base hiding (RTree, singleton, fromList, insertWith, unionDistinctWith, unionWith, insert, mapMaybe, union, fromList', unionDistinct, unionDistinctSplit) import qualified Data.RTree.Base as Lazy @@ -74,9 +77,9 @@ newtype RTree a = RTree {toLazy' :: Lazy.RTree a} - deriving (Show, Eq, Typeable, Generic, NFData, Binary, Monoid) + deriving (Show, Eq, Typeable, Generic, NFData, Binary, Monoid, Semigroup) --- | converts a lazy RTree into a strict RTree +-- | converts a lazy RTree into a strict RTree -- /O(n)/ toStrict :: Lazy.RTree a -> RTree a toStrict t = map id (RTree t) @@ -210,6 +213,14 @@ lookup :: MBB -> RTree a -> Maybe a lookup mbb = Lazy.lookup mbb . toLazy +-- | returns all keys and values, which intersect with the given bounding box. +intersectWithKey :: MBB -> RTree a -> [(MBB, a)] +intersectWithKey mbb = Lazy.intersectWithKey mbb . toLazy + +-- | returns all values, which intersect with the given bounding box +intersect :: MBB -> RTree a -> [a] +intersect mbb = Lazy.intersect mbb . toLazy + -- | returns all keys and values, which are located in the given bounding box. lookupRangeWithKey :: MBB -> RTree a -> [(MBB, a)] lookupRangeWithKey mbb = Lazy.lookupRangeWithKey mbb . toLazy @@ -218,6 +229,14 @@ lookupRange :: MBB -> RTree a -> [a] lookupRange mbb = Lazy.lookupRange mbb . toLazy +-- | returns all keys and values containing the given bounding box +lookupContainsRangeWithKey :: MBB -> RTree a -> [(MBB, a)] +lookupContainsRangeWithKey mbb = Lazy.lookupContainsRangeWithKey mbb . toLazy + +-- | returns all values containing the given bounding box +lookupContainsRange :: MBB -> RTree a -> [a] +lookupContainsRange mbb = Lazy.lookupContainsRange mbb .toLazy + -- ----------- -- delete @@ -272,7 +291,7 @@ length = Lazy.length . toLazy -- | 'RTree' is not really a Functor. --- Because thsi law dowsn't hold: +-- Because this law doesn't hold: -- -- prop> fmap id = id instance Functor RTree where diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,21 +1,21 @@ The MIT License -Copyright (c) 2014 Sebastian Philipp, Birte Wagner +Copyright (c) 2015 Sebastian Philipp, Birte Wagner -Permission is hereby granted, free of charge, to any person obtaining +Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the -rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -sell copies of the Software, and to permit persons to whom the Software is +rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -9,3 +9,11 @@ * changed the Functor instance of Data.RTree.Strict to be strict * Data.RTree.Strict.RTree is now a newtype of Data.RTree.RTree + +## 0.6.0 + +* Add `lookupContainsRange` and `lookupContainsRangeWithKey`. +* Add `intersectWithKey` and `intersect`. +* Now supports GHC 8.4, 8.5 and 8.6. +* Removed `test-strict` flag. +* Minimal Bounding Box is now also an instance of `Ord` diff --git a/data-r-tree.cabal b/data-r-tree.cabal --- a/data-r-tree.cabal +++ b/data-r-tree.cabal @@ -1,98 +1,87 @@ -name: data-r-tree -version: 0.0.5.0 -synopsis: R-Tree is a spatial data structure similar to Quadtrees or B-Trees. -description: R-Tree is a spatial data structure similar to Quadtrees or B-Trees. +cabal-version: 2.2 + +name: data-r-tree +version: 0.6.0 +synopsis: R-Tree is a spatial data structure similar to Quadtrees or B-Trees. +description: R-Tree is a spatial data structure similar to Quadtrees or B-Trees. An R-Tree is a balanced tree and optimized for lookups. This implemetation useses an R-Tree to privide a map to arbitrary values. -license: MIT -license-file: LICENSE -author: Sebastian Philipp, Birte Wagner -maintainer: sebastian@spawnhost.de -copyright: Sebastian Philipp, Birte Wagner -category: Data Structures -build-type: Simple - -Extra-source-files: changelog.md - README.md +license: MIT +license-file: LICENSE +author: Sebastian Wagner, Birte Wagner +maintainer: sebastian@spawnhost.de +copyright: Sebastian Wagner, Birte Wagner +category: Data Structures +build-type: Simple -cabal-version: >=1.10 +Extra-source-files: changelog.md + README.md -bug-reports: https://github.com/sebastian-philipp/r-tree/issues -homepage: https://github.com/sebastian-philipp/r-tree - --- enable with cabal test -ftest-strict -flag test-strict - default: False - manual: True +bug-reports: https://github.com/sebastian-philipp/r-tree/issues +homepage: https://github.com/sebastian-philipp/r-tree source-repository head - type: git - location: https://github.com/sebastian-philipp/r-tree.git - -library - exposed-modules: Data.RTree, - Data.RTree.MBB - Data.RTree.Base - Data.RTree.Strict - -- other-modules: - other-extensions: NoMonomorphismRestriction - build-depends: base == 4.*, - deepseq == 1.*, - binary == 0.* - - -- hs-source-dirs: - default-language: Haskell2010 - ghc-options: -Wall -fwarn-tabs - - -test-suite properties - type: exitcode-stdio-1.0 - main-is: RTreeProperties.hs + type: git + location: https://github.com/sebastian-philipp/r-tree.git - build-depends: - data-r-tree - , base == 4.* - , binary - , HUnit >= 1.2 - , QuickCheck >= 2.4 - , test-framework >= 0.6 - , test-framework-quickcheck2 >= 0.2 - , test-framework-hunit >= 0.2 - , containers --- , gnuplot >= 0.5 +common base { build-depends: base >= 4 && < 5 } - default-language: Haskell2010 - other-extensions: NoMonomorphismRestriction - ghc-options: -Wall -fwarn-tabs +common binary { build-depends: binary >= 0.8 && < 0.11 } +common containers { build-depends: containers >= 0.5 && < 0.7 } +common deepseq { build-depends: deepseq >= 1.4 && < 1.5 } +common ghc-heap-view { build-depends: ghc-heap-view >= 0.5 && < 0.7 } +common HUnit { build-depends: HUnit >= 1.6 && < 1.7 } +common QuickCheck { build-depends: QuickCheck >= 2.13 && < 2.14 } +common test-framework { build-depends: test-framework >= 0.8 && < 0.9 } +common test-framework-hunit { build-depends: test-framework-hunit >= 0.3 && < 0.4 } +common test-framework-quickcheck2 { build-depends: test-framework-quickcheck2 >= 0.3 && < 0.4 } - hs-source-dirs: - test +common config + default-language: Haskell2010 + ghc-options: -Wall -fwarn-tabs -test-suite strict - type: exitcode-stdio-1.0 - main-is: RTreeStrict.hs +common data-r-tree + build-depends: data-r-tree - if !flag(test-strict) - buildable: False - else - build-depends: - data-r-tree - , base == 4.* - , deepseq - , ghc-heap-view >= 0.5 - , HUnit >= 1.2 - , QuickCheck >= 2.4 - , test-framework >= 0.6 - , test-framework-quickcheck2 >= 0.2 - , test-framework-hunit >= 0.2 +library + import: base, config + , binary + , deepseq + exposed-modules: Data.RTree + Data.RTree.MBB + Data.RTree.Base + Data.RTree.Strict - default-language: - Haskell2010 - - ghc-options: -Wall -fwarn-tabs +test-suite properties + import: base, config + , binary + , containers + , data-r-tree + , HUnit + , QuickCheck + , test-framework + , test-framework-hunit + , test-framework-quickcheck2 + type: exitcode-stdio-1.0 + main-is: RTreeProperties.hs + other-extensions: NoMonomorphismRestriction + ghc-options: -Wall -fwarn-tabs -Wno-orphans + hs-source-dirs: test - hs-source-dirs: - test +test-suite strict + import: base, config + , data-r-tree + , deepseq + , ghc-heap-view + , HUnit + , QuickCheck + , test-framework + , test-framework-hunit + , test-framework-quickcheck2 + type: exitcode-stdio-1.0 + main-is: RTreeStrict.hs + ghc-options: -Wall -fwarn-tabs -Wno-orphans + hs-source-dirs: test diff --git a/test/RTreeProperties.hs b/test/RTreeProperties.hs --- a/test/RTreeProperties.hs +++ b/test/RTreeProperties.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE FlexibleInstances #-} + + module Main ( main @@ -8,17 +11,18 @@ -- import qualified Data.Set as S - import Prelude hiding (lookup, map, null, length) import Data.Binary (encode, decode) import Data.Function (on) import Data.List ((\\)) -import qualified Data.List as L (map, length) +import qualified Data.List as L (length) import Control.Applicative ((<$>)) import Test.Framework import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary, shrink) +import Test.QuickCheck.Gen (suchThat) import Test.HUnit hiding (Test, Testable) import Text.Show.Functions () @@ -37,6 +41,8 @@ , testCase "test_lookup" test_lookup , testCase "test_lookupRange" test_lookupRange , testCase "test_lookupRangeWithKey" test_lookupRangeWithKey + , testCase "test_lookupContainsRange" test_lookupContainsRange + , testCase "test_lookupContainsRangeWithKey" test_lookupContainsRangeWithKey , testCase "test_union" test_union , testCase "test_unionWith" test_unionWith , testCase "test_length" test_length @@ -45,40 +51,47 @@ , testCase "test_delete" test_delete , testCase "test_fromList" test_fromList , testCase "test_binary" test_binary + , testProperty "prop_mbb" prop_mbb + , testProperty "prop_rtree" prop_rtree + -- , testProperty "map a StringMap" prop_map ] -- ------------------------ -t_mbb1, t_mbb2 , t_mbb3, t_mbb4, t_mbb5, t_mbb6 :: MBB +t_mbb1, t_mbb2 , t_mbb3, t_mbb4, t_mbb5, t_mbb6, t_mbb7, t_mbb8 :: MBB t_mbb1 = (MBB 0.0 0.0 1.0 1.0) t_mbb2 = (MBB 5.0 0.0 6.0 1.0) t_mbb3 = (MBB 1.0 2.0 2.0 3.0) t_mbb4 = (MBB 6.0 2.0 7.0 3.0) t_mbb5 = (MBB 3.0 3.0 4.0 4.0) t_mbb6 = (MBB 0.0 0.0 0.0 0.0) +t_mbb7 = (MBB 1.0 2.0 5.0 4.0) +t_mbb8 = (MBB 4.0 0.0 6.0 3.0) -t_1, t_2, t_3, t_4, t_5, t_6 :: RTree String +t_1, t_2, t_3 :: RTree String t_1 = singleton t_mbb1 "a" t_2 = singleton t_mbb2 "b" t_3 = singleton t_mbb3 "c" -t_4 = singleton t_mbb4 "d" -t_5 = singleton t_mbb5 "e" -t_6 = singleton t_mbb6 "f" -u_1, u_2 :: [(MBB, String)] + +u_1, u_2, u_3 :: [(MBB, String)] u_1 = [(t_mbb1, "a"), (t_mbb2, "b"),(t_mbb3, "c"),(t_mbb4, "d")] u_2 = [(t_mbb5, "e"), (t_mbb6, "f")] ++ u_1 +u_3 = [(t_mbb7, "g"), (t_mbb8, "h")] ++ u_2 -tu_1, tu_2 :: RTree String +tu_1, tu_2, tu_3 :: RTree String tu_1 = fromList u_1 tu_2 = fromList u_2 +tu_3 = fromList u_3 -- ------------------------ eqRt :: (Show a, Eq a) => RTree a -> RTree a -> Assertion eqRt = eqList `on` toList eqList :: (Show a, Eq a) => [a] -> [a] -> Assertion -eqList l1 l2 = [] @=? (l1 \\ l2) +eqList l1 l2 = do + [] @=? (l1 \\ l2) + (L.length l1) @=? (L.length l2) -- ------------------------ test_null :: Assertion @@ -112,6 +125,14 @@ lookup t_mbb5 tu_2 @?= Just "e" lookup t_mbb6 tu_2 @?= Just "f" + lookup t_mbb2 tu_3 @?= Just "b" + lookup t_mbb3 tu_3 @?= Just "c" + lookup t_mbb4 tu_3 @?= Just "d" + lookup t_mbb5 tu_3 @?= Just "e" + lookup t_mbb6 tu_3 @?= Just "f" + lookup t_mbb7 tu_3 @?= Just "g" + lookup t_mbb8 tu_3 @?= Just "h" + lookup t_mbb1 empty @?= (Nothing :: Maybe ()) lookup t_mbb6 (fromList u_1) @?= Nothing @@ -130,6 +151,18 @@ lookupRange (MBB 0.0 0.0 1.0 1.0) tu_2 @?= ["f", "a"] lookupRange (MBB 0.0 0.0 7.0 4.0) tu_2 @?= ["e","c","f","a","b","d"] -- todo order irrelevant + lookupRange t_mbb2 tu_3 @?= ["b"] + lookupRange t_mbb3 tu_3 @?= ["c"] + lookupRange t_mbb4 tu_3 @?= ["d"] + lookupRange t_mbb5 tu_3 @?= ["e"] + lookupRange t_mbb6 tu_3 @?= ["f"] + lookupRange t_mbb7 tu_3 `eqList` ["g","e","c"] + lookupRange t_mbb8 tu_3 `eqList` ["h", "b"] + + lookupRange (MBB 3.0 2.0 7.0 4.0) tu_3 `eqList` ["e","d"] + lookupRange (MBB 0.0 0.0 5.0 3.0) tu_3 `eqList` ["f","a","c"] + + test_lookupRangeWithKey :: Assertion test_lookupRangeWithKey = do lookupRangeWithKey t_mbb3 t_3 @?= [(t_mbb3, "c")] @@ -142,6 +175,53 @@ lookupRangeWithKey (MBB 0.0 0.0 1.0 1.0) tu_2 @?= [(t_mbb6, "f"), (t_mbb1, "a")] lookupRangeWithKey (MBB 0.0 0.0 7.0 4.0) tu_2 `eqList` u_2 -- todo order irrelevant + lookupRangeWithKey t_mbb2 tu_3 @?= [(t_mbb2, "b")] + lookupRangeWithKey t_mbb3 tu_3 @?= [(t_mbb3, "c")] + lookupRangeWithKey t_mbb4 tu_3 @?= [(t_mbb4, "d")] + lookupRangeWithKey t_mbb5 tu_3 @?= [(t_mbb5, "e")] + lookupRangeWithKey t_mbb6 tu_3 @?= [(t_mbb6, "f")] + lookupRangeWithKey t_mbb7 tu_3 `eqList` [(t_mbb7, "g"), (t_mbb5, "e"), (t_mbb3, "c")] + lookupRangeWithKey t_mbb8 tu_3 `eqList` [(t_mbb8, "h"), (t_mbb2, "b")] + +test_lookupContainsRange :: Assertion +test_lookupContainsRange = do + lookupContainsRange t_mbb3 t_3 @?= ["c"] + lookupContainsRange t_mbb1 tu_1 @?= ["a"] + lookupContainsRange t_mbb2 tu_2 @?= ["b"] + lookupContainsRange t_mbb3 tu_2 @?= ["c"] + lookupContainsRange t_mbb4 tu_2 @?= ["d"] + lookupContainsRange t_mbb5 tu_2 @?= ["e"] + lookupContainsRange t_mbb6 tu_2 `eqList` ["f","a"] + + lookupContainsRange (MBB 1.0 1.0 7.0 3.0) tu_2 @?= [] + lookupContainsRange (MBB 0.0 0.0 1.0 1.0) tu_2 @?= ["a"] + lookupContainsRange (MBB 0.0 0.0 7.0 4.0) tu_2 @?= [] + lookupContainsRange (MBB 0.5 0.5 0.5 0.5) tu_2 @?= ["a"] + lookupContainsRange (MBB 0.0 1.0 0.0 1.0) tu_2 @?= ["a"] + lookupContainsRange (MBB 1.0 0.0 1.0 0.0) tu_2 @?= ["a"] + lookupContainsRange (MBB 1.0 1.0 1.0 1.0) tu_2 @?= ["a"] + + lookupContainsRange t_mbb2 tu_3 `eqList` ["b","h"] + lookupContainsRange t_mbb3 tu_3 `eqList` ["c","g"] + lookupContainsRange t_mbb4 tu_3 `eqList` ["d"] + lookupContainsRange t_mbb5 tu_3 `eqList` ["e","g"] + lookupContainsRange t_mbb6 tu_3 `eqList` ["f","a"] + lookupContainsRange t_mbb7 tu_3 `eqList` ["g"] + lookupContainsRange t_mbb8 tu_3 `eqList` ["h"] + + lookupContainsRange (MBB 4.5 2.5 4.5 2.5) tu_3 `eqList` ["g","h"] + +test_lookupContainsRangeWithKey :: Assertion +test_lookupContainsRangeWithKey = do + lookupContainsRangeWithKey t_mbb3 t_3 @?= [(t_mbb3, "c")] + lookupContainsRangeWithKey t_mbb1 tu_1 @?= [(t_mbb1, "a")] + lookupContainsRangeWithKey t_mbb2 tu_2 @?= [(t_mbb2, "b")] + lookupContainsRangeWithKey t_mbb3 tu_2 @?= [(t_mbb3, "c")] + lookupContainsRangeWithKey t_mbb4 tu_2 @?= [(t_mbb4, "d")] + lookupContainsRangeWithKey t_mbb5 tu_2 @?= [(t_mbb5, "e")] + lookupContainsRangeWithKey t_mbb6 tu_2 `eqList` [(t_mbb6, "f"), (t_mbb1, "a")] + + test_union :: Assertion test_union = do union empty empty `eqRt` (empty :: RTree ()) @@ -196,14 +276,42 @@ test_binary = do (decode $ encode $ tu_2) @?= tu_2 -{- -test_toList :: Assertion -test_delete :: Assertion --} +instance Arbitrary MBB where + arbitrary = do + cx <- arbitrary + cy <- arbitrary + h <- arbitrary `suchThat` (>=0) + w <- arbitrary `suchThat` (>=0) + return $ MBB (cx - w) (cy - h) (cx + w) (cy + h) + shrink mbb@(MBB ulx uly brx bry) + | isPointMBB mbb = [] + | otherwise = [MBB (mid ulx brx) (mid uly bry) (mid ulx brx) (mid uly bry)] + where + mid x y = (y - x) / 2 +instance Arbitrary (RTree Int) where + arbitrary = do + ks <- arbitrary + return $ fromList (ks `zip` [1..]) + + shrink Empty = [] + shrink Leaf{} = [Empty] + shrink t = + [Empty] ++ + -- shrink to subterms + (getChildren t) ++ + -- recursively shrink subterms + [createNodeWithChildren newChildred | newChildred <- shrink (getChildren t)] + +prop_mbb :: MBB -> Bool +prop_mbb mbb = isValidMBB mbb + + +prop_rtree :: RTree Int -> Bool +prop_rtree t = isValid "prop_rtree" t -- ------------------------- diff --git a/test/RTreeStrict.hs b/test/RTreeStrict.hs --- a/test/RTreeStrict.hs +++ b/test/RTreeStrict.hs @@ -13,21 +13,27 @@ import Control.Applicative ((<$>)) import Control.DeepSeq (($!!)) -import Data.Monoid import Data.RTree.Strict import qualified Data.RTree as L import Data.RTree.MBB -import GHC.AssertNF +import qualified GHC.AssertNF as NF -- import System.IO import Test.Framework import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck.Arbitrary as QA (Arbitrary, arbitrary, shrink) +import Test.QuickCheck.Monadic as QM (PropertyM, monadicIO, pick, run, assert) +import Test.QuickCheck as Q (Property) + +import Test.QuickCheck.Gen (suchThat) + import Test.HUnit hiding (Test, Testable) newtype Attr = A [Int] - deriving (Show) + deriving (Show, Semigroup) instance Monoid Attr where mempty = mkA [] @@ -97,18 +103,15 @@ --, testCase "m2 union m3" (checkIsNF $ m2 `union` m3) --, testCase "m2 unionWith m2" (checkIsNF $ unionWith mappend m2 m2) - -- -- these test do not run properly with ghc-7.7-pre and ghc-heap-view-0.5.2 - -- -- no idea, whether patched ghc-heap-view or QuickCheck is the reason - --, testProperty "prop_simple" prop_simple - --, testProperty "prop_union" prop_union - --, testProperty "prop_diff" prop_diff + , testProperty "prop_fromList" prop_fromList + , testProperty "prop_union" prop_union ] test_isNF :: Assertion -test_isNF = fmap not (isNF [(1::Int)..10]) @? "isNF" +test_isNF = fmap not (NF.isNF [(1::Int)..10]) @? "isNF" checkIsNF :: (Show a) => RTree a -> Assertion -checkIsNF !m = isNF m @? ("isNF " ++ show m) +checkIsNF !m = NF.isNF m @? ("isNF " ++ show m) -- some simple test data -- ------------------------ @@ -147,33 +150,37 @@ test_toStrict :: RTree Attr test_toStrict = toStrict $ L.fromList u_2 - +-- ######## ---prop_simple :: Q.Property ---prop_simple = Q.monadicIO $ do --- l <- Q.pick Q.arbitrary --- passed <- Q.run $ do -- hPutStrLn stderr $ "\n" ++ show l --- -- hPutStrLn stderr $ "\n" ++ show (fromList''' l) --- isNF $! fromList''' l --- Q.assert passed +instance QA.Arbitrary MBB where + arbitrary = do + cx <- QA.arbitrary + cy <- QA.arbitrary + h <- QA.arbitrary `suchThat` (>=0) + w <- QA.arbitrary `suchThat` (>=0) + return $ MBB (cx - w) (cy - h) (cx + w) (cy + h) ---prop_union :: Q.Property ---prop_union = Q.monadicIO $ do --- l1 <- Q.pick Q.arbitrary --- l2 <- Q.pick Q.arbitrary --- let sm = fromList''' l1 `union` fromList''' l2 --- checkIsNFProp sm + shrink this_mbb@(MBB ulx uly brx bry) + | isPointMBB this_mbb = [] + | otherwise = [MBB (mid ulx brx) (mid uly bry) (mid ulx brx) (mid uly bry)] + where + mid x y = (y - x) / 2 ---prop_diff :: Q.Property ---prop_diff = Q.monadicIO $ do --- l1 <- Q.pick Q.arbitrary --- l2 <- Q.pick Q.arbitrary --- let sm = fromList''' l1 `difference` fromList''' l2 --- checkIsNFProp sm +prop_fromList :: Q.Property +prop_fromList = QM.monadicIO $ do + l <- (QM.pick QA.arbitrary) :: QM.PropertyM IO [(MBB, Int)] + passed <- QM.run $ do + -- hPutStrLn stderr $ "\n" ++ show l + -- hPutStrLn stderr $ "\n" ++ show (fromList''' l) + NF.isNF $! fromList l + QM.assert passed ---checkIsNFProp :: a -> Q.PropertyM IO () ---checkIsNFProp sm = do --- passed <- Q.run $ isNF $! sm --- Q.run $ assertNF $! sm --- Q.assert passed +prop_union :: Q.Property +prop_union = QM.monadicIO $ do + l1 <- (QM.pick QA.arbitrary) :: QM.PropertyM IO [(MBB, Int)] + l2 <- (QM.pick QA.arbitrary) :: QM.PropertyM IO [(MBB, Int)] + passed <- QM.run $ do + let sm = fromList l1 `union` fromList l2 + NF.isNF $! sm + QM.assert passed