diff --git a/Data/RTree.hs b/Data/RTree.hs new file mode 100644 --- /dev/null +++ b/Data/RTree.hs @@ -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 diff --git a/Data/RTree/Base.hs b/Data/RTree/Base.hs new file mode 100644 --- /dev/null +++ b/Data/RTree/Base.hs @@ -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) diff --git a/Data/RTree/MBB.hs b/Data/RTree/MBB.hs new file mode 100644 --- /dev/null +++ b/Data/RTree/MBB.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/data-r-tree.cabal b/data-r-tree.cabal new file mode 100644 --- /dev/null +++ b/data-r-tree.cabal @@ -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 diff --git a/test/RTreeProperties.hs b/test/RTreeProperties.hs new file mode 100644 --- /dev/null +++ b/test/RTreeProperties.hs @@ -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