data-r-tree 0.0.5.0 → 0.6.0

raw patch · 9 files changed

+390/−218 lines, 9 filesdep ~HUnitdep ~QuickCheckdep ~binaryPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: HUnit, QuickCheck, binary, containers, deepseq, ghc-heap-view, test-framework, test-framework-hunit, test-framework-quickcheck2

API changes (from Hackage documentation)

Files

• Data/RTree.hs +5/−1
• Data/RTree/Base.hs +94/−64
• Data/RTree/MBB.hs +13/−6
• Data/RTree/Strict.hs +25/−6
• LICENSE +10/−10
• changelog.md +8/−0
• data-r-tree.cabal +71/−82
• test/RTreeProperties.hs +122/−14
• test/RTreeStrict.hs +42/−35

@@ -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

@@ -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 = (<>)

@@ -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 

@@ -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

@@ -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.

@@ -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`

@@ -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

@@ -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  -- ------------------------- 

@@ -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