diff --git a/Data/RTree/Base.hs b/Data/RTree/Base.hs --- a/Data/RTree/Base.hs +++ b/Data/RTree/Base.hs @@ -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 diff --git a/Data/RTree/MBB.hs b/Data/RTree/MBB.hs --- a/Data/RTree/MBB.hs +++ b/Data/RTree/MBB.hs @@ -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 diff --git a/Data/RTree/Strict.hs b/Data/RTree/Strict.hs new file mode 100644 --- /dev/null +++ b/Data/RTree/Strict.hs @@ -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') diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,6 @@ +## 0.0.4.0 + +* Added Data.RTree.Strict + +* Added Data.Binary interface for GHC 7.6 + diff --git a/data-r-tree.cabal b/data-r-tree.cabal --- a/data-r-tree.cabal +++ b/data-r-tree.cabal @@ -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 diff --git a/test/RTreeProperties.hs b/test/RTreeProperties.hs --- a/test/RTreeProperties.hs +++ b/test/RTreeProperties.hs @@ -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 +-} diff --git a/test/RTreeStrict.hs b/test/RTreeStrict.hs new file mode 100644 --- /dev/null +++ b/test/RTreeStrict.hs @@ -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