From 6f41f548fc9774a69138e3c92ea606f7b021ac93 Mon Sep 17 00:00:00 2001 From: Eric Wong Date: Fri, 29 Apr 2016 10:02:12 +0800 Subject: [PATCH 1/7] Add stack to .gititnore Signed-off-by: Eric Wong --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index afa96d5..e68c5fe 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ /dist/ /.cabal-sandbox/ /cabal.sandbox.config +/.stack-work/ \ No newline at end of file From 0a8edc18466e28df3077277ba3047b5c0f26d684 Mon Sep 17 00:00:00 2001 From: Eric Wong Date: Fri, 6 Jul 2018 09:10:07 +0800 Subject: [PATCH 2/7] Fix typo --- Data/RTree/MBB.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Data/RTree/MBB.hs b/Data/RTree/MBB.hs index 5225861..e18be87 100644 --- a/Data/RTree/MBB.hs +++ b/Data/RTree/MBB.hs @@ -68,7 +68,7 @@ unionMBB (MBB ulx uly brx bry) (MBB ulx' uly' brx' bry') = MBB (min ulx ulx') (m area :: MBB -> Double area (MBB ulx uly brx bry) = (brx - ulx) * (bry - uly) --- | returns True, when the first mbb contains the secons +-- | returns True, when the first mbb contains the second containsMBB :: MBB -> MBB -> Bool containsMBB (MBB x11 y11 x12 y12) (MBB x21 y21 x22 y22) = x11 <= x21 && y11 <= y21 && x12 >= x22 && y12 >= y22 From f5b23460d0b0ff3108609c2e7c0c3d0e58ae9c39 Mon Sep 17 00:00:00 2001 From: Eric Wong Date: Fri, 6 Jul 2018 09:41:56 +0800 Subject: [PATCH 3/7] Add intersect and intersectWithKey API to lookup with intersections --- Data/RTree/Base.hs | 17 +++++++++++++++++ Data/RTree/Strict.hs | 10 ++++++++++ 2 files changed, 27 insertions(+) diff --git a/Data/RTree/Base.hs b/Data/RTree/Base.hs index 9fd21cb..66e4bf4 100644 --- a/Data/RTree/Base.hs +++ b/Data/RTree/Base.hs @@ -31,6 +31,8 @@ module Data.RTree.Base , unionWith -- * Searching and Properties , lookup + , intersectWithKey + , intersect , lookupRange , lookupRangeWithKey , lookupContainsRangeWithKey @@ -313,6 +315,21 @@ lookup mbb t = case founds of matches = filter (\x -> (getMBB x) `containsMBB` mbb) $ getChildren t founds = catMaybes $ L.map (lookup mbb) matches +-- | returns all keys and values, which intersects with the given bounding box. +intersectWithKey :: MBB -> RTree a -> [(MBB, a)] +intersectWithKey _ Empty = [] +intersectWithKey mbb t@Leaf{} + | isJust $ intersectMBB mbb (getMBB t) = [(getMBB t, getElem t)] + | otherwise = [] +intersectWithKey mbb t = founds + where matches = filter intersectRTree $ getChildren t + founds = concatMap (intersectWithKey mbb) matches + intersectRTree x = isJust $ mbb `intersectMBB` (getMBB x) + +-- | returns all values, which intersects with the given bounding box. +intersect :: MBB -> RTree a -> [a] +intersect mbb t = snd <$> intersectWithKey mbb t + -- | returns all keys and values, which are located in the given bounding box. lookupRangeWithKey :: MBB -> RTree a -> [(MBB, a)] lookupRangeWithKey _ Empty = [] diff --git a/Data/RTree/Strict.hs b/Data/RTree/Strict.hs index a0f251d..e2c02a4 100644 --- a/Data/RTree/Strict.hs +++ b/Data/RTree/Strict.hs @@ -44,6 +44,8 @@ module Data.RTree.Strict , unionWith -- * Searching and Properties , lookup + , intersectWithKey + , intersect , lookupRange , lookupRangeWithKey , lookupContainsRange @@ -211,6 +213,14 @@ unionDistinctSplit f leaf e lookup :: MBB -> RTree a -> Maybe a lookup mbb = Lazy.lookup mbb . toLazy +-- | returns all keys and values, which intersect with the given bounding box. +intersectWithKey :: MBB -> RTree a -> [(MBB, a)] +intersectWithKey mbb = Lazy.intersectWithKey mbb . toLazy + +-- | returns all values, which intersect with the given bounding box +intersect :: MBB -> RTree a -> [a] +intersect mbb = Lazy.intersect mbb . toLazy + -- | returns all keys and values, which are located in the given bounding box. lookupRangeWithKey :: MBB -> RTree a -> [(MBB, a)] lookupRangeWithKey mbb = Lazy.lookupRangeWithKey mbb . toLazy From 3a3ebd85497050438e983aa4eaad47eee19645ed Mon Sep 17 00:00:00 2001 From: Eric Wong Date: Fri, 6 Jul 2018 09:54:00 +0800 Subject: [PATCH 4/7] Expose the new intersect API in top module --- Data/RTree.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Data/RTree.hs b/Data/RTree.hs index eb7abcd..cf61de1 100644 --- a/Data/RTree.hs +++ b/Data/RTree.hs @@ -43,6 +43,8 @@ module Data.RTree , unionWith -- * Searching and Properties , lookup + , intersectWithKey + , intersect , lookupRange , lookupRangeWithKey , lookupContainsRange From f44ee5d0adbf38d2a97cde39e62cbe66a56f246e Mon Sep 17 00:00:00 2001 From: Eric Wong Date: Fri, 6 Jul 2018 09:44:59 +0800 Subject: [PATCH 5/7] Delete uesless code --- Data/RTree/Base.hs | 2 -- Data/RTree/MBB.hs | 2 -- Data/RTree/Strict.hs | 1 - 3 files changed, 5 deletions(-) diff --git a/Data/RTree/Base.hs b/Data/RTree/Base.hs index 66e4bf4..b7e12de 100644 --- a/Data/RTree/Base.hs +++ b/Data/RTree/Base.hs @@ -72,10 +72,8 @@ import Data.List (maximumBy, minimumBy, partition) import qualified Data.List as L (length,map) 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 ((<$>)) import Control.DeepSeq (NFData, rnf) import GHC.Generics (Generic) diff --git a/Data/RTree/MBB.hs b/Data/RTree/MBB.hs index e18be87..805b41f 100644 --- a/Data/RTree/MBB.hs +++ b/Data/RTree/MBB.hs @@ -31,8 +31,6 @@ where import Data.Binary -import Control.Applicative ((<$>), (<*>)) - import GHC.Generics (Generic) -- | Minimal bounding box diff --git a/Data/RTree/Strict.hs b/Data/RTree/Strict.hs index e2c02a4..1952eb5 100644 --- a/Data/RTree/Strict.hs +++ b/Data/RTree/Strict.hs @@ -65,7 +65,6 @@ import Data.Binary import Data.Function (on) import qualified Data.List as L (length) import qualified Data.Maybe as Maybe (mapMaybe) -import Data.Monoid (Monoid) import Data.Semigroup import Data.Typeable (Typeable) From 01a9f6f75b7044c994ab0f0df89ffbb05837c003 Mon Sep 17 00:00:00 2001 From: Schell Scivally Date: Sat, 15 Sep 2018 22:07:25 -0700 Subject: [PATCH 6/7] compiling now --- Data/RTree/Base.hs | 115 +++++++++++++++++++++---------------------- Data/RTree/Strict.hs | 1 + 2 files changed, 56 insertions(+), 60 deletions(-) diff --git a/Data/RTree/Base.hs b/Data/RTree/Base.hs index b7e12de..36c041b 100644 --- a/Data/RTree/Base.hs +++ b/Data/RTree/Base.hs @@ -1,5 +1,9 @@ -{-# LANGUAGE NoMonomorphismRestriction, DeriveFunctor, DeriveDataTypeable, BangPatterns #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} {- | Module : Data.RTree.Base @@ -64,22 +68,19 @@ module Data.RTree.Base ) where -import Prelude hiding (lookup, length, null, map) - -import Data.Binary -import Data.Function (on) -import Data.List (maximumBy, minimumBy, partition) -import qualified Data.List as L (length,map) -import Data.Maybe (catMaybes, isJust) -import qualified Data.Maybe as Maybe (mapMaybe) -import Data.Typeable (Typeable) - import Control.DeepSeq (NFData, rnf) - -import GHC.Generics (Generic) - -import Data.RTree.MBB hiding (mbb) +import Data.Binary +import Data.Function (on) +import Data.List (maximumBy, minimumBy, partition) +import qualified Data.List as L (length, map) +import Data.Maybe (catMaybes, isJust) +import qualified Data.Maybe as Maybe (mapMaybe) +import Data.Typeable (Typeable) import Data.Semigroup +import GHC.Generics (Generic) +import Prelude hiding (length, lookup, map, null) + +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) } @@ -115,7 +116,7 @@ null _ = False -- | creates a single element tree singleton :: MBB -> a -> RTree a -singleton mbb x = Leaf mbb x +singleton = Leaf node :: MBB -> [RTree a] -> RTree a node mbb [x,y] = Node2 mbb x y @@ -131,19 +132,19 @@ 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 +norm x = x getChildren :: RTree a -> [RTree a] -getChildren Empty = error "getChildren: Empty" +getChildren Empty = error "getChildren: Empty" getChildren Leaf{} = error "getChildren: Leaf" -getChildren t = getChildren' $ norm t +getChildren t = getChildren' $ norm t -- ---------------------------------- -- Lists -- | creates a tree out of pairs fromList :: [(MBB, a)] -> RTree a -fromList l = fromList' $ (uncurry singleton) <$> l +fromList l = fromList' $ uncurry singleton <$> l -- | merges all singletons into a single tree. fromList' :: [RTree a] -> RTree a @@ -154,27 +155,21 @@ fromList' ts = foldr1 unionDistinct ts -- -- prop> toList t = zip (keys t) (values t) toList :: RTree a -> [(MBB, a)] -toList Empty = [] +toList Empty = [] toList (Leaf mbb x) = [(mbb, x)] -toList t = concatMap toList $ getChildren t +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 +keys = foldWithMBB (\mbb _ -> [mbb]) (const concat) [] -- | 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 +values = foldWithMBB (const pure) (const concat) [] -- ---------------------------------- @@ -182,7 +177,7 @@ values = foldWithMBB handleLeaf handleNode [] -- | 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 +insertWith f mbb e = unionDistinctWith f (singleton mbb e) -- | Inserts an element whith the given 'MBB' and a value in a tree. An existing value will be overwritten with the given one. -- @@ -192,7 +187,7 @@ 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 +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. @@ -200,13 +195,13 @@ 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 + | 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 + | 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 @@ -223,15 +218,15 @@ addLeaf f left right newChildren = findNodeWithMinimalAreaIncrease f left (getChildren right) (eq, nonEq) = partition (on (==) getMBB left) $ getChildren right newNode = case eq of - [] -> left + [] -> left [x] -> simpleMergeEqNode f left x - _ -> error "addLeaf: invalid RTree" + _ -> 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) + xsAndIncrease = zip children $ areaIncreasesWith leaf <$> children minimalIncrease = minimum $ snd <$> xsAndIncrease -- xsAndIncrease' :: [(RTree a, Double)] splitMinimal [] = [] @@ -241,7 +236,7 @@ findNodeWithMinimalAreaIncrease f leaf children = splitMinimal xsAndIncrease unionDistinctSplit :: (a -> a -> a) -> RTree a -> RTree a -> [RTree a] unionDistinctSplit f leaf e - | (L.length $ getChildren newLeaf) > n = splitNode newLeaf + | L.length (getChildren newLeaf) > n = splitNode newLeaf | otherwise = [newLeaf] where newLeaf = addLeaf f leaf e @@ -266,22 +261,22 @@ findGreatestArea xs = (x', y') 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) + | 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)) + isLeft = areaIncreasesWithLeft < areaIncreasesWithRight + growth = if isLeft + then areaIncreasesWithLeft + else 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) + 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) @@ -307,7 +302,7 @@ lookup mbb t@Leaf{} | mbb == getMBB t = Just $ getElem t | otherwise = Nothing lookup mbb t = case founds of - [] -> Nothing + [] -> Nothing x:_ -> Just x where matches = filter (\x -> (getMBB x) `containsMBB` mbb) $ getChildren t @@ -429,7 +424,7 @@ isValid :: Show b => b -> RTree a -> Bool isValid _ Empty = True isValid _ Leaf{} = True isValid context x = case L.length c >= m && L.length c <= n && (and $ (isValid context) <$> c) && (isBalanced x) of - True -> True + True -> True False -> error ( "invalid " ++ show (L.length c) ++ " " ++ show context ) where isBalanced :: RTree a -> Bool @@ -465,15 +460,15 @@ pp' i (Node4 mbb c1 c2 c3 c4) = do -- ---------------------- depth :: RTree a -> Int -depth Empty = 0 +depth Empty = 0 depth (Leaf _ _ ) = 1 -depth t = 1 + (depth $ head $ getChildren t) +depth t = 1 + (depth $ head $ getChildren t) -- | returns the number of elements in a tree length :: RTree a -> Int -length Empty = 0 +length Empty = 0 length (Leaf {}) = 1 -length t = sum $ length <$> (getChildren t) +length t = sum $ length <$> (getChildren t) --delete' :: MBB -> RTree a -> Either (RTree a) [(MBB, a)] @@ -509,6 +504,6 @@ instance (Binary a) => Binary (RTree a) where instance (Semigroup a) => Semigroup (RTree a) where (<>) = unionWith (<>) -instance (Monoid a) => Monoid (RTree a) where +instance Monoid a => Monoid (RTree a) where mempty = empty - mappend = unionWith mappend + mappend = (<>) diff --git a/Data/RTree/Strict.hs b/Data/RTree/Strict.hs index 1952eb5..d67a4ff 100644 --- a/Data/RTree/Strict.hs +++ b/Data/RTree/Strict.hs @@ -75,6 +75,7 @@ import qualified Data.RTree.Base as Lazy import Data.RTree.MBB hiding (mbb) import qualified Data.RTree.MBB as MBB + newtype RTree a = RTree {toLazy' :: Lazy.RTree a} deriving (Show, Eq, Typeable, Generic, NFData, Binary, Monoid, Semigroup) From d454aba156c95a6f4ff3b4ff1650c6c25a0d4e03 Mon Sep 17 00:00:00 2001 From: Schell Scivally Date: Sat, 15 Sep 2018 23:02:16 -0700 Subject: [PATCH 7/7] MBB is ord --- Data/RTree/MBB.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Data/RTree/MBB.hs b/Data/RTree/MBB.hs index 805b41f..03548dd 100644 --- a/Data/RTree/MBB.hs +++ b/Data/RTree/MBB.hs @@ -35,7 +35,7 @@ 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) + deriving (Eq, Generic, Ord) -- | created a minimal bounding box (or a rectangle) -- The first point must be smaller, than the second one. This is unchecked.