data-r-tree 0.0.3.0 → 0.0.4.0

raw patch · 8 files changed

+462/−24 lines, 8 filesdep +ghc-heap-viewdep −gnuplotdep ~binarydep ~deepseqPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: ghc-heap-view

Dependencies removed: gnuplot

Dependency ranges changed: binary, deepseq

API changes (from Hackage documentation)

Files

• Data/RTree/Base.hs +39/−14
• Data/RTree/MBB.hs +11/−6
• Data/RTree/Strict.hs +170/−0
• README.md +15/−0
• changelog.md +6/−0
• data-r-tree.cabal +38/−3
• test/RTreeProperties.hs +10/−1
• test/RTreeStrict.hs +173/−0

@@ -1,4 +1,4 @@-{-# LANGUAGE NoMonomorphismRestriction, DeriveFunctor, OverlappingInstances, DeriveDataTypeable #-}+{-# LANGUAGE NoMonomorphismRestriction, DeriveFunctor, OverlappingInstances, DeriveDataTypeable, BangPatterns #-} {-# LANGUAGE DeriveGeneric #-}  {- |@@ -10,14 +10,14 @@     Stability  : experimental     Portability: not portable -    Internal implementations. Use Data.RTree instead+    Internal implementations. Use 'Data.RTree' instead or use at you own risc. -}   module Data.RTree.Base (     -- * Data Type-    RTree+    RTree (..)     -- * Constructors     , empty     , singleton@@ -43,22 +43,28 @@      -- * Internal and Testing     , foldWithMBB-    , getMBB     , pp     , isValid     , unionDistinct     , unionDistinctWith-    , getC1-    , getC2-    , getC3-    , getC4+    , fromList'+    , unionDistinctSplit+    , depth+    , areaIncreasesWith+    , partition+    , getChildren+    , unionMBB'+    , createNodeWithChildren+    , n+    , splitNode+    , node ) where  import           Prelude hiding (lookup, length, null)  import           Data.Binary-import           Data.Function+import           Data.Function (on) import           Data.List (maximumBy, minimumBy, partition) import qualified Data.List as L (length) import           Data.Maybe (catMaybes, isJust)@@ -98,7 +104,7 @@ empty :: RTree a empty = Empty --- | returns True, if empty+-- | returns 'True', if empty -- -- prop> null empty = True null :: RTree a -> Bool@@ -137,11 +143,12 @@ fromList :: [(MBB, a)] -> RTree a fromList l = fromList' $ (uncurry singleton) <$> l +-- | merges all singletons into a single tree. fromList' :: [RTree a] -> RTree a fromList' [] = empty fromList' ts = foldr1 unionDistinct ts --- | creates a list of pairs out of a  tree+-- | creates a list of pairs out of a tree -- -- prop> toList t = zip (keys t) (values t) toList :: RTree a -> [(MBB, a)]@@ -185,7 +192,7 @@ simpleMergeEqNode f l@Leaf{} r = Leaf (getMBB l) (on f getElem l r) simpleMergeEqNode _ l _ = l --- | Únifies left and right RTeee. Will create invalid trees, if the tree is not a leaf and contains "MBB"s which+-- | 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.  unionDistinctWith :: (a -> a -> a) -> RTree a -> RTree a -> RTree a unionDistinctWith _ Empty{} t           = t@@ -201,7 +208,7 @@     where     newNode = addLeaf f left right --- | Únifies left and right RTeee. Will create invalid trees, if the tree is not a leaf and contains "MBB"s which+-- | Únifies 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.  unionDistinct :: RTree a -> RTree a -> RTree a unionDistinct = unionDistinctWith const@@ -446,7 +453,25 @@     rnf (Node4 _ c1 c2 c3 c4) = {-rnf m `seq`-} rnf c1 `seq` rnf c2 `seq` rnf c3 `seq` rnf c4  -instance  (Binary a) => Binary (RTree a)+instance  (Binary a) => Binary (RTree a) where+    put (Empty)         = put (0::Word8)+    put (Leaf mbb e)    = put (1::Word8)  >> put mbb >> put e+    put t               = put (2::Word8)  >> put (getMBB t) >> put (getChildren t)++    get = do+          !tag <- getWord8+          case tag of+                   0 -> return Empty+                   1 -> do+                        !mbb <- get+                        !e <- get+                        return $! Leaf mbb e+                   2 -> do+                        !mbb <- get+                        !c <- get+                        return $! node mbb c+                   _ -> fail "RTree.get: error while decoding RTree"+  instance (Monoid a) => Monoid (RTree a) where     mempty = empty

@@ -29,6 +29,8 @@  import Data.Binary +import Control.Applicative ((<$>), (<*>))+ import GHC.Generics (Generic)    -- | Minimal bounding box@@ -38,10 +40,10 @@ -- | created a minimal bounding box (or a rectangle) -- The first point must be smaller, than the second one. This is unchecked. mbb :: Double -- ^ x - coordinate of first point-  -> Double   -- ^ y - coordinate of first point-  -> Double   -- ^ x - coordinate of second point-  -> Double   -- ^ x - coordinate of second point-  -> MBB+    -> Double   -- ^ y - coordinate of first point+    -> Double   -- ^ x - coordinate of second point+    -> Double   -- ^ x - coordinate of second point+    -> MBB mbb = MBB  -- | internal only.@@ -74,6 +76,9 @@    instance Show MBB where-  show (MBB ulx uly brx bry) = concat ["mbb ", show ulx, " ", show uly, " ", show brx, " ", show bry]+    show (MBB ulx uly brx bry) = concat ["mbb ", show ulx, " ", show uly, " ", show brx, " ", show bry] -instance Binary MBB++instance Binary MBB where+    put (MBB ulx uly brx bry) = put ulx >> put uly >> put brx >> put bry+    get = MBB <$> get <*> get <*> get <*> get

@@ -0,0 +1,170 @@+{-# LANGUAGE BangPatterns               #-}+{- |+    Module     : Data.RTree.Strict+    Copyright  : Copyright (c) 2014, Birte Wagner, Sebastian Philipp+    License    : MIT++    Maintainer : Birte Wagner, Sebastian Philipp (sebastian@spawnhost.de)+    Stability  : experimental+    Portability: not portable++    This is the Strict version of 'Data.RTree'++    the following property should be true (by using 'GHC.AssertNF.isNF' ) :++    >>> propNF :: RTree a -> IO Bool+    >>> propNF e = isNF $! e++-}+++module Data.RTree.Strict+(+    -- * 'MBB'+    MBB+    , MBB.mbb+    -- * Data Type+    , RTree+    -- * Constructors+    , empty+    , singleton+    -- * Modification+    , insert+    , insertWith+    , delete+    , mapMaybe+    -- ** Merging+    , union+    , unionWith+    -- * Searching and Properties+    , lookup+    , lookupRange+    , lookupRangeWithKey+    , length+    , null+    , keys+    , values+    -- * Lists+    , fromList+    , toList+) where++import           Prelude hiding (lookup, length, null)+import           Data.Function (on)+import qualified Data.List as L (length)+import qualified Data.Maybe as Maybe (mapMaybe)++import           Control.Applicative ((<$>))+import           Data.RTree.Base hiding (singleton, fromList, insertWith, unionDistinctWith, unionWith, insert, mapMaybe, union, fromList', unionDistinct, unionDistinctSplit)+import           Data.RTree.MBB hiding (mbb)+import qualified  Data.RTree.MBB as MBB++-- ---------------+-- smart constuctors++-- | creates a single element tree+singleton :: MBB -> a -> RTree a+singleton mbb !x = Leaf mbb x++-- ----------------------------------+-- Lists++-- | creates a tree out of pairs+fromList :: [(MBB, a)] -> RTree a+fromList l = fromList' $ (uncurry singleton) <$> l++-- | merges all singletons into a single tree.+fromList' :: [RTree a] -> RTree a+fromList' [] = empty+fromList' ts = foldr1 unionDistinct ts+-- ----------------------------------+-- insert ++-- | 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++-- | Inserts an element whith the given 'MBB' and a value in a tree. An existing value will be overwritten with the given one.+--+-- prop> insert = insertWith const+insert :: MBB -> a -> RTree a -> RTree a+insert = insertWith const++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++-- | 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. +unionDistinctWith :: (a -> a -> a) -> RTree a -> RTree a -> RTree a+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+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+    where+    newNode = addLeaf f left right++-- | Únifies 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. +unionDistinct :: RTree a -> RTree a -> RTree a+unionDistinct = unionDistinctWith const++addLeaf :: (a -> a -> a) -> RTree a -> RTree a -> RTree a+addLeaf f left right +    | depth left + 1 == depth right = node (newNode `unionMBB'` right) (newNode : nonEq)+    | otherwise                     = node (left `unionMBB'` right) newChildren+    where+    newChildren = findNodeWithMinimalAreaIncrease f left (getChildren right)+    (eq, nonEq) = partition (on (==) getMBB left) $ getChildren right+    newNode = case eq of+        [] -> left+        [x] -> simpleMergeEqNode f left x+        _ -> 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)+    minimalIncrease = minimum $ snd <$> xsAndIncrease+--  xsAndIncrease' :: [(RTree a, Double)]   +    splitMinimal [] = []+    splitMinimal ((t,mbb):xs)+        | mbb == minimalIncrease = unionDistinctSplit f leaf t ++ (fst <$> xs)+        | otherwise            = t : splitMinimal xs++unionDistinctSplit :: (a -> a -> a) -> RTree a -> RTree a -> [RTree a]+unionDistinctSplit f leaf e+    | (L.length $ getChildren newLeaf) > n = splitNode newLeaf+    | otherwise = [newLeaf]+    where+    newLeaf = addLeaf f leaf e++-- | Unifies the first and the second tree into one. The combining function is used for elemets which exists in both trees.+unionWith :: (a -> a -> a) -> RTree a -> RTree a -> RTree a+unionWith _ l     Empty    = l+unionWith _ Empty r        = r+unionWith f t1 t2+    | depth t1 <= depth t2 = foldr (uncurry (insertWith f)) t2 (toList t1)+    | otherwise            = unionWith f t2 t1++-- | Unifies the first and the second tree into one.+-- If an 'MBB' is a key in both trees, the value from the left tree is chosen. +--+-- prop> union = unionWith const+union :: RTree a -> RTree a -> RTree a+union = unionWith const++-- | map, which also filters Nothing values+mapMaybe :: (a -> Maybe b) -> RTree a -> RTree b+mapMaybe f t = fromList $ Maybe.mapMaybe func $ toList t+    where+    func (mbb,x) = case f x of+            Nothing -> Nothing+            Just x' -> Just (mbb, x')

@@ -0,0 +1,15 @@+R-Trees (and in the future also R*-Trees)+====================++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.++Some function names clash with "Prelude" names, therefore this module is usually+imported ```qualified```, e.g.:++    > import           Data.RTree (RTree)+    > import qualified Data.RTree as RT++this implemetation is incomplete at the moment. Feel free to send comments, patches or merge requests.

@@ -0,0 +1,6 @@+## 0.0.4.0++* Added Data.RTree.Strict++* Added Data.Binary interface for GHC 7.6+

@@ -1,5 +1,5 @@ name:                data-r-tree-version:             0.0.3.0+version:             0.0.4.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.   @@ -14,12 +14,18 @@ category:            Data Structures build-type:          Simple --- extra-source-files:  +Extra-source-files:  changelog.md+                     README.md+ cabal-version:       >=1.10  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    source-repository head   type:         git@@ -29,6 +35,7 @@   exposed-modules:     Data.RTree,                        Data.RTree.MBB                        Data.RTree.Base+                       Data.RTree.Strict   -- other-modules:    other-extensions:    NoMonomorphismRestriction   build-depends:       base        == 4.*,@@ -47,13 +54,14 @@   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-          , gnuplot >= 0.5           , containers+--          , gnuplot >= 0.5    default-language:    Haskell2010   other-extensions:    NoMonomorphismRestriction@@ -61,3 +69,30 @@    hs-source-dirs:                 test++test-suite strict+  type:         exitcode-stdio-1.0+  main-is:      RTreeStrict.hs++  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+++  default-language:+                Haskell2010++  ghc-options:  -Wall -fwarn-tabs++  hs-source-dirs:+                test            

@@ -10,6 +10,7 @@ -- 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)@@ -22,7 +23,7 @@ import           Text.Show.Functions                  ()  -import Graphics.Gnuplot.Simple+--import Graphics.Gnuplot.Simple  -- todo: write tests @@ -43,6 +44,7 @@            , testCase "test_values" test_values            , testCase "test_delete" test_delete            , testCase "test_fromList" test_fromList+           , testCase "test_binary" test_binary --       , testProperty "map a StringMap" prop_map         ]@@ -190,6 +192,10 @@ test_fromList = do     fromList [] `eqRt` (empty :: RTree ()) +test_binary :: Assertion+test_binary = do+    (decode $ encode $ tu_2) @?= tu_2+ {-  test_toList :: Assertion@@ -209,6 +215,8 @@ t_ppp = union t_pp t_p -} +{-+ mbbToPath :: MBB -> [(Double, Double)] mbbToPath (MBB ulx uly brx bry) = [(ulx, uly),(brx, uly),(brx, bry),(ulx, bry),(ulx, uly)] @@ -238,3 +246,4 @@         listToMBB :: [Double] -> MBB         listToMBB [ulx, uly, brx, bry] = MBB ulx uly brx bry         listToMBB xs = error $ "invalid data " ++ show xs+-}

@@ -0,0 +1,173 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables        #-}++module Main+where++-- import qualified Data.RTree                       as Lazy    -- just for dev.+import           Prelude                              hiding (lookup, map, mapM,+                                                       null, succ)++--import           Control.Arrow                        (second)+import           Control.Applicative ((<$>), (<*>))+import           Control.DeepSeq                      (($!!))++import           Data.Monoid+import           Data.RTree.Strict+import           Data.RTree.MBB++import           GHC.AssertNF++-- import           System.IO++import           Test.Framework+import           Test.Framework.Providers.HUnit+import           Test.Framework.Providers.QuickCheck2+import           Test.HUnit                           hiding (Test, Testable)+import qualified Test.QuickCheck                      as Q (Property, arbitrary)+import qualified Test.QuickCheck.Monadic              as Q (PropertyM, assert,+                                                            monadicIO, pick,+                                                            run)++newtype Attr = A [Int]+    deriving (Show)++instance Monoid Attr where+    mempty = mkA []+    mappend (A xs) (A ys) = mkA (xs ++ ys)++-- evaluation of x `mappend` y to WHNF leads to NF+-- because of the $!! in mkA+--+-- example+--+--    A [1,2] `mappend` A [3,4]+-- =  { subst of mappend }+--    mkA ([1,2] ++ [3,4])+-- =  { subst of mkA }+--    A $!! ([1,2] ++ [3,4])+-- =  { subst of $!! }+--    A [1,2,3,4]+--+-- in a call of Data.RTree.insert k (x `mappend` y) m+-- the attribute is forced to be in WHNF, and this leads to NF++type Map = RTree Attr++-- smart constructor for evaluation into NF+-- before calling the constructor A++mkA :: [Int] -> Attr+mkA xs = A $!! xs++mkA' :: Int -> Attr+mkA' x = mkA [0 .. x]++consA :: Int -> Attr -> Attr+consA n a = mkA [n] `mappend` a++default (Int)++main :: IO ()+main = defaultMain+       [+         testCase "isNF" test_isNF+       , testCase "empty" (checkIsNF (empty :: RTree ()))+       , testCase "t_1" (checkIsNF t_1)+       , testCase "tu_1" (checkIsNF tu_1)+       , testCase "tu_2" (checkIsNF tu_2)+       , testCase "tu_2" (checkIsNF test_union)+       , testCase "test_insertWith1" (checkIsNF test_insertWith1)+       , testCase "test_insertWith" (checkIsNF test_insertWith)+       --, testCase "m1" (checkIsNF m1)+       --, testCase "m2" (checkIsNF m2)+       --, testCase "m3" (checkIsNF m3)+       --, testCase "m5" (checkIsNF m3)+       --, testCase "m6" (checkIsNF m3)+       --, testCase "m7 (map test)" (checkIsNF m7)+       --, testCase "fromList l4" (checkIsNF $ fromList l4)+       --, testCase "m8 (fromList''' ll)" (checkIsNF m8)++       --, testCase "adjust m6" (checkIsNF $ adjust (consA 42) "ab" m6)+       --, testCase "adjust m1" (checkIsNF $ adjust (consA 42) "xx" m1)+       --, testCase "delete m6" (checkIsNF $ delete "ab" m6)+       --, testCase "delete m1" (checkIsNF $ delete "xx" m1)++       --, 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+       ]++test_isNF :: Assertion+test_isNF = fmap not (isNF [(1::Int)..10]) @? "isNF"++checkIsNF :: (Show a) => RTree a -> Assertion+checkIsNF !m = isNF m @? ("isNF " ++ show m)++-- some simple test data+-- ------------------------+t_mbb1, t_mbb2 , t_mbb3, t_mbb4, t_mbb5, t_mbb6 :: 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)++u_1, u_2 :: [(MBB, Attr)]+u_1 = [(t_mbb1, mkA' 1), (t_mbb2, mkA' 2),(t_mbb3, mkA' 3),(t_mbb4, mkA' 4)]+u_2 = [(t_mbb5, mkA' 5), (t_mbb6, mkA' 6)] ++ u_1++t_1, t_2, t_3, t_4, t_5, t_6 :: RTree Attr+[t_5, t_6, t_1, t_2, t_3, t_4] = (uncurry singleton) <$> u_2++tu_1, tu_2 :: RTree Attr+tu_1 = fromList u_1+tu_2 = fromList u_2+++test_union :: RTree Attr+test_union = unionWith mappend tu_1 t_6++test_insertWith1 :: RTree Attr+test_insertWith1 = insertWith mappend t_mbb1 (mkA' 4) t_1++test_insertWith :: RTree Attr+test_insertWith = insertWith mappend t_mbb6 (mkA' 6) tu_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++--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+++--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++--checkIsNFProp :: a -> Q.PropertyM IO ()+--checkIsNFProp sm = do+--                            passed <- Q.run $ isNF $! sm+--                            Q.run $ assertNF $! sm+--                            Q.assert passed