data-r-tree (empty) → 0.0.1.0
raw patch · 7 files changed
+832/−0 lines, 7 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, binary, containers, data-r-tree, deepseq, gnuplot, test-framework, test-framework-hunit, test-framework-quickcheck2
Files
- Data/RTree.hs +50/−0
- Data/RTree/Base.hs +405/−0
- Data/RTree/MBB.hs +75/−0
- LICENSE +21/−0
- Setup.hs +2/−0
- data-r-tree.cabal +63/−0
- test/RTreeProperties.hs +216/−0
+ Data/RTree.hs view
@@ -0,0 +1,50 @@+{- |+ 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++ 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.++ 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.++-}+++module Data.RTree +(+ MBB.MBB,+ MBB.mbb,+ RTree,+ empty,+ singleton,+ insert,+ union,+ lookup,+ lookupRange,+ fromList,+ toList,+ delete,+ length,+ null,+ keys,+ values,++) where++import Prelude ()+import Data.RTree.Base++import qualified Data.RTree.MBB as MBB
+ Data/RTree/Base.hs view
@@ -0,0 +1,405 @@+{-# LANGUAGE NoMonomorphismRestriction, DeriveFunctor, OverlappingInstances, DeriveDataTypeable #-}+{-# 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++ 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++ pp,+ isValid,+ unionDistinct,+ getC1,+ getC2,+ getC3,+ getC4+)+where++import Prelude hiding (lookup, length, null)++import Data.Binary+import Data.Function+import Data.List (maximumBy, minimumBy, partition)+import qualified Data.List as L (length)+import Data.Maybe (catMaybes, isJust)+import qualified Data.Maybe as Maybe (mapMaybe)+import Data.Typeable (Typeable)++import Control.Applicative ((<$>))+import Control.DeepSeq (NFData, rnf)++import GHC.Generics (Generic)++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) }+ | Node3 {getMBB :: {-# UNPACK #-} ! MBB, getC1 :: ! (RTree a), getC2 :: ! (RTree a), getC3 :: ! (RTree a) }+ | Node2 {getMBB :: {-# UNPACK #-} ! MBB, getC1 :: ! (RTree a), getC2 :: ! (RTree a) }+ | Node {getMBB :: MBB, getChildren' :: [RTree a] }+ | Leaf {getMBB :: {-# UNPACK #-} ! MBB, getElem :: a}+ | Empty+ deriving (Show, Eq, Functor, Typeable, Generic)++m, n :: Int+m = 2+n = 4+++unionMBB' :: RTree a -> RTree a -> MBB+unionMBB' x y = unionMBB [getMBB x, getMBB y]++-- ---------------+-- smart constuctors++-- | creates an empty tree+empty :: RTree a+empty = Empty++-- | returns True, if empty+--+-- prop> null empty = True+null :: RTree a -> Bool+null Empty = True+null _ = False++-- | creates a single element tree+singleton :: MBB -> a -> RTree a+singleton mbb x = Leaf mbb x++node :: MBB -> [RTree a] -> RTree a+node mbb [x,y] = Node2 mbb x y+node mbb [x,y,z] = Node3 mbb x y z+node mbb [x,y,z,w] = Node4 mbb x y z w+node _ [] = error "node: empty"+node mbb xs = Node mbb xs++createNodeWithChildren :: [RTree a] -> RTree a+createNodeWithChildren c = node (unionMBB $ getMBB <$> c) c++norm :: RTree a -> RTree a+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++getChildren :: RTree a -> [RTree a]+getChildren Empty = error "getChildren: Empty"+getChildren Leaf{} = error "getChildren: Leaf"+getChildren t = getChildren' $ norm t++-- ----------------------------------+-- Lists++-- | creates a tree out of pairs+fromList :: [(MBB, a)] -> RTree a+fromList l = fromList' $ (uncurry singleton) <$> l++fromList' :: [RTree a] -> RTree a+fromList' [] = error "fromList' empty"+fromList' ts = foldr1 unionDistinct ts++-- | creates a list of pairs out of a tree+--+-- prop> toList t = zip (keys t) (values t)+toList :: RTree a -> [(MBB, a)]+toList Empty = []+toList (Leaf mbb x) = [(mbb, x)]+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++-- | 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+++-- ----------------------------------+-- insert ++-- | inserts an element whith the given 'MBB' and a value in a tree+insert :: MBB -> a -> RTree a -> RTree a+insert mbb e oldRoot = unionDistinct (singleton mbb e) oldRoot++-- | 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+ | depth left == depth right = fromList' $ (getChildren left) ++ [right]+ | (L.length $ getChildren newNode) > n = createNodeWithChildren $ splitNode newNode+ | otherwise = newNode+ where+ newNode = addLeaf left right++addLeaf :: RTree a -> RTree a -> RTree a+addLeaf left right + | depth left + 1 == depth right = node (left `unionMBB'` right) (left : nonEq)+ | otherwise = node (left `unionMBB'` right) newChildren+ where+ newChildren = findNodeWithMinimalAreaIncrease left (getChildren right)+ (eq, nonEq) = partition (on (==) getMBB left) $ getChildren right++findNodeWithMinimalAreaIncrease :: RTree a -> [RTree a] -> [RTree a]+findNodeWithMinimalAreaIncrease 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 leaf t ++ (fst <$> xs)+ | otherwise = t : splitMinimal xs++unionDistinctSplit :: RTree a -> RTree a -> [RTree a]+unionDistinctSplit leaf e+ | (L.length $ getChildren newLeaf) > n = splitNode newLeaf+ | otherwise = [newLeaf]+ where+ newLeaf = addLeaf leaf e++-- | /O(n²)/ solution+splitNode :: RTree a -> [RTree a]+splitNode Leaf{} = error "splitNode: Leaf"+splitNode e = [createNodeWithChildren x1, createNodeWithChildren x2]+ where+ (l, r) = findGreatestArea $ getChildren e+ (x1, x2) = quadSplit [l] [r] unfinished+ unfinished = filter (on (/=) getMBB l) $ filter (on (/=) getMBB r) $ getChildren e++findGreatestArea :: [RTree a] -> (RTree a, RTree a)+findGreatestArea xs = (x', y')+ where+ xs' = zip xs [(1::Int)..]+ listOfTripels = [(fst x, fst y, on unionMBB' fst x y) | x <- xs', y <- xs', ((<) `on` snd) x y]+ (x', y', _) = maximumBy (compare `on` (\(_,_,x) -> area x)) listOfTripels+++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)+ | 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))+ (minimumElem, isLeft'', _) = minimumBy (compare `on` (\(_,_,g) -> g)) $ makeTripel <$> 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)+--mergeNodes _ _ = error "no merge for Leafs"++-- ------------+-- helpers+++areaIncreasesWith :: RTree a -> (RTree a) -> Double+areaIncreasesWith newElem current = newArea - currentArea+ where+ currentArea = area $ getMBB current+ newArea = area $ unionMBB' newElem current++-- -----------------+-- lookup++-- | returns the value if it exists in the tree+lookup :: MBB -> RTree a -> Maybe a+lookup _ Empty = Nothing+lookup mbb t@Leaf{}+ | mbb == getMBB t = Just $ getElem t+ | otherwise = Nothing+lookup mbb t = case founds of + [] -> Nothing+ x:_ -> Just x+ where+ 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]+ | otherwise = []+lookupRange mbb t = founds+ where+ matches = filter intersectRTree $ getChildren t+ founds = concatMap (lookupRange mbb) matches+ intersectRTree x = isJust $ mbb `intersectMBB` (getMBB x)++-- -----------+-- delete++-- | Delete a key and its value from the RTree. When the key is not a member of the tree, the original tree is returned.+delete :: MBB -> RTree a -> RTree a+delete _ Empty = Empty+delete mbb t@Leaf{} + | mbb == getMBB t = Empty+ | otherwise = t+delete mbb root+ | L.length (getChildren newRoot) == 1 = head $ getChildren newRoot+ | otherwise = newRoot+ where+ newRoot = delete' mbb root+++delete' :: MBB -> RTree a -> RTree a+delete' mbb t@Leaf{} + | mbb == getMBB t = Empty+ | otherwise = t+delete' mbb t = fromList' $ orphans ++ [newValidNode]+ where+ (matches, noMatches) = partition (\x -> (getMBB x) `containsMBB` mbb) $ getChildren t+ matches' = filter (not . null) $ map (delete' mbb) matches+ (orphans, validMatches) = foldr handleInvalid ([], []) matches'+-- handleInvalid :: RTree a -> ([RTree a], [RTree a]) -> ([RTree a], [RTree a])+ handleInvalid l@Leaf{} (orphans', validMatches') = (orphans', l:validMatches')+ handleInvalid invalidNode (orphans', validMatches')+ | L.length children < m = (children ++ orphans', validMatches')+ | otherwise = (orphans', invalidNode:validMatches')+ where+ children = getChildren invalidNode+ newValidNode = createNodeWithChildren $ validMatches ++ noMatches++-- ---------------+foldWithMBB :: (MBB -> a -> b) -> (MBB -> [b] -> b) -> b -> RTree a -> b+foldWithMBB _ _ n' Empty = n'+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.+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++-- | 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')++-- ---------------++isValid :: Show b => b -> RTree a -> Bool+isValid _ Leaf{} = True+isValid context x = case L.length c >= m && L.length c <= n && (and $ (isValid context) <$> c) && (isBalanced x) of+ True -> True+ False -> error ( "invalid " ++ show (L.length c) ++ " " ++ show context )+ where+ isBalanced :: RTree a -> Bool + isBalanced (Leaf _ _ ) = True+ isBalanced x' = (and $ isBalanced <$> c') && (and $ (== depth (head c')) <$> (depth <$> c'))+ where+ c' = getChildren x'+ c = getChildren x++-- ----------------------+i_ :: String+i_ = " "++pp :: (Show a) => RTree a -> IO ()+pp = pp' ""++pp' :: (Show a) => String -> RTree a -> IO ()+pp' i Empty = putStrLn $ i ++ "Empty"+pp' i (Leaf mbb x) = putStrLn $ i ++ "Leaf " ++ (show mbb) ++ " " ++ (show x)+pp' i (Node mbb cs) = do+ putStrLn $ i ++ "Node " ++ (show mbb)+ mapM_ (pp' (i ++ i_)) cs+pp' i (Node2 mbb c1 c2) = do+ putStrLn $ i ++ "Node2 " ++ (show mbb)+ mapM_ (pp' (i ++ i_)) [c1, c2]+pp' i (Node3 mbb c1 c2 c3) = do+ putStrLn $ i ++ "Node3 " ++ (show mbb)+ mapM_ (pp' (i ++ i_)) [c1, c2, c3]+pp' i (Node4 mbb c1 c2 c3 c4) = do+ putStrLn $ i ++ "Node4 " ++ (show mbb)+ mapM_ (pp' (i ++ i_)) [c1, c2, c3, c4]++-- ----------------------++depth :: RTree a -> Int+depth (Leaf _ _ ) = 0+depth t = 1 + (depth $ head $ getChildren t)++-- | returns the number of elements in a tree+length :: RTree a -> Int +length Empty = 0+length (Leaf {}) = 1+length t = sum $ length <$> (getChildren t)++--delete' :: MBB -> RTree a -> Either (RTree a) [(MBB, a)]++instance NFData a => NFData (RTree a) where+ rnf (Empty) = ()+ rnf (Leaf _ e) = {-rnf m `seq`-} rnf e+ rnf (Node _ cs) = {-rnf m `seq`-} rnf cs+ rnf (Node2 _ c1 c2) = {-rnf m `seq`-} rnf c1 `seq` rnf c2+ rnf (Node3 _ c1 c2 c3) = {-rnf m `seq`-} rnf c1 `seq` rnf c2 `seq` rnf c3+ 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)
+ Data/RTree/MBB.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++{- |+ Module : Data.RTree.MBB+ Copyright : Copyright (c) 2014, Birte Wagner, Sebastian Philipp+ License : MIT++ Maintainer : Birte Wagner, Sebastian Philipp (sebastian@spawnhost.de)+ Stability : experimental+ Portability: not portable++ This module provides a minimal bounding box. + +-}+++module Data.RTree.MBB+(+ MBB (..),+ mbb,+ area,+ containsMBB,+ unionMBB,+ intersectMBB+)+where++import Data.Binary+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)++-- | 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+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')++-- | calculates the area of the rect+area :: MBB -> Double+area (MBB ulx uly brx bry) = (brx - ulx) * (bry - uly)++-- | returns True, when the first mbb contains the secons+containsMBB :: MBB -> MBB -> Bool+containsMBB (MBB x11 y11 x12 y12) (MBB x21 y21 x22 y22) = x11 <= x21 && y11 <= y21 && x12 >= x22 && y12 >= y22++-- | returns the intersection of both mbbs. Returns Nothing, if they don't intersect. +intersectMBB :: MBB -> MBB -> Maybe MBB+intersectMBB (MBB ulx uly brx bry) (MBB ulx' uly' brx' bry')+ | ulx'' <= brx'' && uly'' <= bry'' = Just $ MBB ulx'' uly'' brx'' bry''+ | otherwise = Nothing+ where+ ulx'' = max ulx ulx'+ uly'' = max uly uly'+ brx'' = min brx brx'+ bry'' = min bry bry'+ ++instance Show MBB where+ show (MBB ulx uly brx bry) = concat ["mbb ", show ulx, " ", show uly, " ", show brx, " ", show bry]++instance Binary MBB
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License++Copyright (c) 2014 Sebastian Philipp, Birte Wagner++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 +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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ data-r-tree.cabal view
@@ -0,0 +1,63 @@+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.+ + 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+build-type: Simple++-- extra-source-files: +cabal-version: >=1.10++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+ -- 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++ build-depends:+ data-r-tree+ , base == 4.*+ , HUnit >= 1.2+ , QuickCheck >= 2.4+ , test-framework >= 0.6+ , test-framework-quickcheck2 >= 0.2+ , test-framework-hunit >= 0.2+ , gnuplot >= 0.5+ , containers++ default-language: Haskell2010+ other-extensions: NoMonomorphismRestriction+ ghc-options: -Wall -fwarn-tabs++ hs-source-dirs:+ test
+ test/RTreeProperties.hs view
@@ -0,0 +1,216 @@+module Main+(+ main+)+where+import Data.RTree.Base+import Data.RTree.MBB hiding (mbb)+++-- import qualified Data.Set as S++import Prelude hiding (lookup, map, null, length)+import Data.Function (on)+import Data.List ((\\))+import qualified Data.List as L (map, length)+import Control.Applicative ((<$>))++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.HUnit hiding (Test, Testable)+import Text.Show.Functions ()+++import Graphics.Gnuplot.Simple++-- todo: write tests++main :: IO ()+main = do+ defaultMain+ [+ testCase "test_null" test_null+ , testCase "test_singleton" test_singleton+ , testCase "test_insert" test_insert+ , testCase "test_lookup" test_lookup+ , testCase "test_lookupRange" test_lookupRange+ , testCase "test_union" test_union+ , testCase "test_length" test_length+ , testCase "test_keys" test_keys+ , testCase "test_values" test_values+ , testCase "test_delete" test_delete+-- , testProperty "map a StringMap" prop_map++ ]+-- ------------------------+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)++t_1, t_2, t_3, t_4, t_5, t_6 :: 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 = [(t_mbb1, "a"), (t_mbb2, "b"),(t_mbb3, "c"),(t_mbb4, "d")]+u_2 = [(t_mbb5, "e"), (t_mbb6, "f")] ++ u_1++tu_1, tu_2 :: RTree String+tu_1 = fromList u_1+tu_2 = fromList u_2++-- ------------------------+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)+-- ------------------------++test_null :: Assertion+test_null = do+ null empty @?= True+ null t_1 @?= False++test_singleton :: Assertion+test_singleton = do+ t_1 `eqRt` t_1+ length t_1 @?= 1+ keys t_1 @?= [t_mbb1]+ values t_1 @?= ["a"]++test_insert :: Assertion+test_insert = do+ insert t_mbb2 "b" t_1 `eqRt` fromList [(t_mbb1, "a"), (t_mbb2, "b")]+ insert t_mbb1 "a" t_2 `eqRt` fromList [(t_mbb1, "a"), (t_mbb2, "b")]+ insert t_mbb1 "a+" t_1 `eqRt` fromList [(t_mbb1, "a+")]+ insert t_mbb1 "a" empty `eqRt` t_1+ insert t_mbb5 "e" (fromList u_1) `eqRt` fromList (u_1 ++ [(t_mbb5, "e")])+ insert t_mbb6 "f" (fromList u_1) `eqRt` fromList (u_1 ++ [(t_mbb6, "f")])++test_lookup :: Assertion+test_lookup = do+ lookup t_mbb3 t_3 @?= Just "c"+ lookup t_mbb1 tu_1 @?= Just "a"+ lookup t_mbb2 tu_2 @?= Just "b"+ lookup t_mbb3 tu_2 @?= Just "c"+ lookup t_mbb4 tu_2 @?= Just "d"+ lookup t_mbb5 tu_2 @?= Just "e"+ lookup t_mbb6 tu_2 @?= Just "f"++ lookup t_mbb1 empty @?= (Nothing :: Maybe ())+ lookup t_mbb6 (fromList u_1) @?= Nothing+++test_lookupRange :: Assertion+test_lookupRange = do+ lookupRange t_mbb3 t_3 @?= ["c"]+ lookupRange t_mbb1 tu_1 @?= ["a"]+ lookupRange t_mbb2 tu_2 @?= ["b"]+ lookupRange t_mbb3 tu_2 @?= ["c"]+ lookupRange t_mbb4 tu_2 @?= ["d"]+ lookupRange t_mbb5 tu_2 @?= ["e"]+ lookupRange t_mbb6 tu_2 @?= ["f"]++ lookupRange (MBB 1.0 1.0 7.0 3.0) tu_2 @?= ["c", "d"]+ 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_union :: Assertion+test_union = do+ union empty empty `eqRt` (empty :: RTree ())+ union tu_2 tu_1 `eqRt` tu_2+++test_length :: Assertion+test_length = do+ length empty @?= 0+ length t_1 @?= 1+ length tu_2 @?= L.length u_2++test_keys :: Assertion+test_keys = do+ keys empty @?= []+ keys t_1 @?= [t_mbb1]+ keys tu_2 `eqList` (fst <$> u_2)++test_values :: Assertion+test_values = do+ values empty @?= ([] :: [()])+ values t_1 @?= ["a"]+ values tu_2 `eqList` (snd <$> u_2)++test_delete :: Assertion+test_delete = do+ let d1 = delete (MBB 3.0 3.0 4.0 4.0) tu_2+ values d1 @?= ["c","f","a","b","d"]+ let d2 = delete (MBB 1.0 2.0 2.0 3.0) d1+ values d2 @?= ["f","a","b","d"]+ let d3 = delete (MBB 0.0 0.0 0.0 0.0) d2+ values d3 @?= ["a","b","d"]+ let d4 = delete (MBB 5.0 0.0 6.0 1.0) d3+ values d4 @?= ["a","d"]+ let d5 = delete (MBB 0.0 0.0 1.0 1.0) d4+ values d5 @?= ["d"]+ let d6 = delete (MBB 6.0 2.0 7.0 3.0) d5+ values d6 @?= []+++{-+test_fromList :: Assertion+test_toList :: Assertion+test_delete :: Assertion+-}+++++-- -------------------------++{- t_p = node (mbb 6469.0 9103.0 6656.0 9721.0) [+ Leaf {getmbb = (mbb 6469.0 9103.0 6469.0 9721.0), getElem = ()},+ Leaf {getmbb = (mbb 6786.0 9678.0 6656.0 9651.0), getElem = ()},+ Leaf {getmbb = (mbb 6593.0 9103.0 6593.0 9721.0), getElem = ()}]+t_pp = Leaf {getmbb = (mbb 6531.0 9103.0 6531.0 9721.0), getElem = ()}+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)]++rtreeToPaths :: RTree a -> [[(Double, Double)]]+rtreeToPaths = foldWithMBB handleLeaf handleNode []+ where+ handleLeaf mbb _ = [mbbToPath mbb]+ handleNode mbb xs = [mbbToPath mbb] ++ (concat xs)+ ++plotRtree :: RTree a -> IO ()+plotRtree tree = do+ print [p20 ulx brx, p20 uly bry]+ print [ulx, brx, uly, bry]+ plotPaths [Key Nothing, XRange $ p20 ulx brx, YRange $ p20 uly bry] $ rtreeToPaths tree+ where+ (MBB ulx uly brx bry) = getMBB tree+ p20 l r = (l - ((r-l) / 5), r + ((r-l) / 5))+++testData :: FilePath -> IO (RTree ())+testData p = do+ d <- lines <$> readFile p+ let pairs = zip (listToMBB <$> (L.map read d)) (replicate 100000000 ())+ return $ fromList pairs+ where+ listToMBB :: [Double] -> MBB+ listToMBB [ulx, uly, brx, bry] = MBB ulx uly brx bry+ listToMBB xs = error $ "invalid data " ++ show xs