data-r-tree 0.0.1.0 → 0.0.2.0

raw patch · 5 files changed

+200/−113 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Data/RTree.hs +42/−32
• Data/RTree/Base.hs +116/−72
• Data/RTree/MBB.hs +16/−5
• data-r-tree.cabal +3/−3
• test/RTreeProperties.hs +23/−1

@@ -1,47 +1,57 @@ {- |-  Module     : Data.RTree-  Copyright  : Copyright (c) 2014, Birte Wagner, Sebastian Philipp-  License    : MIT+    Module     : Data.RTree+    Copyright  : Copyright (c) 2014, Birte Wagner, Sebastian Philipp+    License    : MIT -  Maintainer : Birte Wagner, Sebastian Philipp (sebastian@spawnhost.de)-  Stability  : experimental-  Portability: not portable+    Maintainer : Birte Wagner, Sebastian Philipp (sebastian@spawnhost.de)+    Stability  : experimental+    Portability: not portable -  R-Tree is a spartial 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.+    R-Tree is a spatial data structure similar to Quadtrees or B-Trees. -  Some function names clash with "Prelude" names, therefore this module is usually-  imported @qualified@, e.g.+    An R-Tree is a balanced tree and optimized for lookups. This implemetation useses an R-Tree to privide+    a map to arbitrary values. -  > import           Data.RTree (RTree)-  > import qualified Data.RTree as RT+    Some function names clash with "Prelude" names, therefore this module is usually+    imported @qualified@, e.g. -  this implemetation is incomplete at the moment. Feel free to send comments, patches or merge requests.+    > 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.+ -}   module Data.RTree  (-    MBB.MBB,-    MBB.mbb,-    RTree,-    empty,-    singleton,-    insert,-    union,-    lookup,-    lookupRange,-    fromList,-    toList,-    delete,-    length,-    null,-    keys,-    values,-+    -- * 'MBB'+    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 ()

@@ -2,48 +2,56 @@ {-# LANGUAGE DeriveGeneric #-}  {- |-  Module     : Data.RTree.Base-  Copyright  : Copyright (c) 2014, Birte Wagner, Sebastian Philipp-  License    : MIT--  Maintainer : Birte Wagner, Sebastian Philipp (sebastian@spawnhost.de)-  Stability  : experimental-  Portability: not portable+    Module     : Data.RTree.Base+    Copyright  : Copyright (c) 2014, Birte Wagner, Sebastian Philipp+    License    : MIT -  Internal implementations. Use Data.RTree instead+    Maintainer : Birte Wagner, Sebastian Philipp (sebastian@spawnhost.de)+    Stability  : experimental+    Portability: not portable +    Internal implementations. Use Data.RTree instead -}   module Data.RTree.Base (-    RTree,-    empty,-    singleton,-    insert,-    union,-    lookup,-    lookupRange,-    fromList,-    toList,-    delete,-    length,-    null,-    keys,-    values,-    mapMaybe,-    foldWithMBB,-    getMBB,--    -- | testing+    -- * 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 -    pp,-    isValid,-    unionDistinct,-    getC1,-    getC2,-    getC3,-    getC4+    -- * Internal and Testing+    , foldWithMBB+    , getMBB+    , pp+    , isValid+    , unionDistinct+    , unionDistinctWith+    , getC1+    , getC2+    , getC3+    , getC4 ) where @@ -55,6 +63,7 @@ import qualified Data.List as L (length) 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 ((<$>))@@ -79,7 +88,7 @@   unionMBB' :: RTree a -> RTree a -> MBB-unionMBB' x y = unionMBB [getMBB x, getMBB y]+unionMBB' = unionMBB `on` getMBB  -- --------------- -- smart constuctors@@ -107,7 +116,7 @@ node mbb xs        = Node mbb xs  createNodeWithChildren :: [RTree a] -> RTree a-createNodeWithChildren c = node (unionMBB $ getMBB <$> c) c+createNodeWithChildren c = node (unionsMBB $ getMBB <$> c) c  norm :: RTree a -> RTree a norm (Node4 mbb x y z w) = Node mbb [x,y,z,w]@@ -128,7 +137,7 @@ fromList l = fromList' $ (uncurry singleton) <$> l  fromList' :: [RTree a] -> RTree a-fromList' [] = error "fromList' empty"+fromList' [] = empty fromList' ts = foldr1 unionDistinct ts  -- | creates a list of pairs out of a  tree@@ -161,35 +170,55 @@ -- ---------------------------------- -- insert  --- | inserts an element whith the given 'MBB' and a value in a tree+-- | 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 mbb e oldRoot = unionDistinct (singleton mbb e) oldRoot+insert = insertWith const --- | unifies left and right RTeee. Works only, if they don't contain common keys. Much faster than union, though. -unionDistinct :: RTree a -> RTree a -> RTree a-unionDistinct Empty{} t           = t-unionDistinct t       Empty{}     = t-unionDistinct t1@Leaf{} t2@Leaf{}-    | on (==) getMBB t1 t2 = t1-    | otherwise = createNodeWithChildren [t1, t2] -- root case-unionDistinct left right-    | depth left > depth right              = unionDistinct right left+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++-- | Únifies left and right RTeee. 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+    | (L.length $ getChildren newNode) > n  = createNodeWithChildren $ splitNode newNode     | otherwise                             = newNode     where-    newNode = addLeaf left right+    newNode = addLeaf f left right -addLeaf :: RTree a -> RTree a -> RTree a-addLeaf left right -    | depth left + 1 == depth right = node (left `unionMBB'` right) (left : nonEq)+-- | Únifies left and right RTeee. 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 left (getChildren right)+    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 :: RTree a -> [RTree a] -> [RTree a]-findNodeWithMinimalAreaIncrease leaf children = splitMinimal xsAndIncrease+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)@@ -197,15 +226,15 @@ --  xsAndIncrease' :: [(RTree a, Double)]        splitMinimal [] = []     splitMinimal ((t,mbb):xs)-        | mbb == minimalIncrease = unionDistinctSplit leaf t ++ (fst <$> xs)+        | mbb == minimalIncrease = unionDistinctSplit f leaf t ++ (fst <$> xs)         | otherwise            = t : splitMinimal xs -unionDistinctSplit :: RTree a -> RTree a -> [RTree a]-unionDistinctSplit leaf e+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 leaf e+    newLeaf = addLeaf f leaf e  -- | /O(n²)/ solution splitNode :: RTree a -> [RTree a]@@ -274,18 +303,22 @@     matches = filter (\x -> (getMBB x) `containsMBB` mbb) $ getChildren t     founds = catMaybes $ map (lookup mbb) matches --- | returns all values, which are located in the given bounding box. -lookupRange :: MBB -> RTree a -> [a]-lookupRange _ Empty = []-lookupRange mbb t@Leaf{}-    | mbb `containsMBB` (getMBB t) = [getElem t]+-- | returns all keys and values, which are located in the given bounding box. +lookupRangeWithKey :: MBB -> RTree a -> [(MBB, a)]+lookupRangeWithKey _ Empty = []+lookupRangeWithKey mbb t@Leaf{}+    | mbb `containsMBB` (getMBB t) = [(getMBB t, getElem t)]     | otherwise = []-lookupRange mbb t = founds+lookupRangeWithKey mbb t = founds     where     matches = filter intersectRTree $ getChildren t-    founds = concatMap (lookupRange mbb) matches+    founds = concatMap (lookupRangeWithKey mbb) matches     intersectRTree x = isJust $ mbb `intersectMBB` (getMBB x) +-- | returns all values, which are located in the given bounding box. +lookupRange :: MBB -> RTree a -> [a]+lookupRange mbb t = snd <$> (lookupRangeWithKey mbb t)+ -- ----------- -- delete @@ -326,12 +359,19 @@ foldWithMBB f _ _ t@Leaf{} = f (getMBB t) (getElem t) foldWithMBB f g n' t        = g (getMBB t) $ foldWithMBB f g n' <$> (getChildren t) --- | unifies the first and the second tree into one.+-- | 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 _ Empty Empty = Empty+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 Empty Empty = Empty-union t1 t2-    | depth t1 <= depth t2 = foldr (uncurry insert) t2 (toList t1)-    | otherwise            = union t2 t1+union = unionWith const  -- | map, which also filters Nothing values mapMaybe :: (a -> Maybe b) -> RTree a -> RTree b@@ -403,3 +443,7 @@   instance  (Binary a) => Binary (RTree a)++instance (Monoid a) => Monoid (RTree a) where+    mempty = empty+    mappend = unionWith mappend

@@ -22,11 +22,14 @@     area,     containsMBB,     unionMBB,+    unionsMBB,     intersectMBB ) where  import Data.Binary+import Data.Monoid+ import GHC.Generics (Generic)    -- | Minimal bounding box@@ -43,12 +46,14 @@ mbb = MBB  -- | internal only.-unionMBB :: [MBB] -> MBB-unionMBB [] = error "unionMBB': []"-unionMBB xs = foldr1 f xs-    where-    f (MBB ulx uly brx bry) (MBB ulx' uly' brx' bry') = MBB (min ulx ulx') (min uly uly') (max brx brx') (max bry bry')+unionsMBB :: [MBB] -> MBB+unionsMBB [] = error "unionsMBB': []"+unionsMBB xs = foldr1 unionMBB xs +-- | unifies two MBBs into one+unionMBB :: MBB -> MBB -> MBB+unionMBB (MBB ulx uly brx bry) (MBB ulx' uly' brx' bry') = MBB (min ulx ulx') (min uly uly') (max brx brx') (max bry bry')+ -- | calculates the area of the rect area :: MBB -> Double area (MBB ulx uly brx bry) = (brx - ulx) * (bry - uly)@@ -73,3 +78,9 @@   show (MBB ulx uly brx bry) = concat ["mbb ", show ulx, " ", show uly, " ", show brx, " ", show bry]  instance Binary MBB++-- | mconcat will fail for empty lists. +instance Monoid MBB where+  mempty = MBB 0.0 0.0 0.0 0.0+  mappend = unionMBB+  mconcat = unionsMBB

@@ -1,7 +1,7 @@ name:                data-r-tree-version:             0.0.1.0-synopsis:            R-Tree is a spartial data structure similar to Quadtrees or B-Trees.-description:         R-Tree is a spartial data structure similar to Quadtrees or B-Trees.+version:             0.0.2.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. 

@@ -35,11 +35,14 @@            , testCase "test_insert" test_insert            , testCase "test_lookup" test_lookup            , testCase "test_lookupRange" test_lookupRange+           , testCase "test_lookupRangeWithKey" test_lookupRangeWithKey            , testCase "test_union" test_union+           , testCase "test_unionWith" test_unionWith            , testCase "test_length" test_length            , testCase "test_keys" test_keys            , testCase "test_values" test_values            , testCase "test_delete" test_delete+           , testCase "test_fromList" test_fromList --       , testProperty "map a StringMap" prop_map         ]@@ -125,13 +128,29 @@     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 +test_lookupRangeWithKey :: Assertion+test_lookupRangeWithKey = do+    lookupRangeWithKey t_mbb3 t_3 @?= [(t_mbb3, "c")]+    lookupRangeWithKey t_mbb1 tu_1 @?= [(t_mbb1, "a")]+    lookupRangeWithKey t_mbb2 tu_2 @?= [(t_mbb2, "b")]+    lookupRangeWithKey t_mbb3 tu_2 @?= [(t_mbb3, "c")]+    lookupRangeWithKey t_mbb4 tu_2 @?= [(t_mbb4, "d")] +    lookupRangeWithKey (MBB 1.0 1.0 7.0 3.0) tu_2 @?= [(t_mbb3, "c"), (t_mbb4, "d")]+    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+ test_union :: Assertion test_union = do     union empty empty `eqRt` (empty :: RTree ())     union tu_2 tu_1 `eqRt` tu_2 +test_unionWith :: Assertion+test_unionWith = do+    unionWith undefined empty empty `eqRt` (empty :: RTree ())+    unionWith (++) tu_2 tu_1 `eqRt` (fromList [(t_mbb1,"aa"),(t_mbb2,"bb"),(t_mbb3,"cc"),(t_mbb4,"dd"),(t_mbb5,"e"),(t_mbb6,"f")]) -- tu_2 + test_length :: Assertion test_length = do     length empty @?= 0@@ -165,9 +184,12 @@     let d6 = delete (MBB 6.0 2.0 7.0 3.0) d5     values d6 @?= [] +test_fromList :: Assertion+test_fromList = do+    fromList [] `eqRt` (empty :: RTree ())  {--test_fromList :: Assertion+ test_toList :: Assertion test_delete :: Assertion -}