Add lookupTouchesRangeWithKey and lookupTouchesRange.

Data/RTree/Base.hs

@@ -41,6 +41,8 @@ module Data.RTree.Base
     , lookupRangeWithKey
     , lookupContainsRangeWithKey
     , lookupContainsRange
+    , lookupTouchesRangeWithKey
+    , lookupTouchesRange
     , length
     , null
     , keys
@@ -317,7 +319,7 @@ intersectWithKey mbb t@Leaf{}
 intersectWithKey mbb t = founds
     where matches = filter intersectRTree $ getChildren t
           founds = concatMap (intersectWithKey mbb) matches
-          intersectRTree x = isJust $ mbb `intersectMBB` (getMBB x)
+          intersectRTree x = mbb `touchesMBB` (getMBB x)
 
 -- | returns all values, which intersects with the given bounding box.
 intersect :: MBB -> RTree a -> [a]
@@ -333,7 +335,7 @@ lookupRangeWithKey mbb t = founds
     where
     matches = filter intersectRTree $ getChildren t
     founds = concatMap (lookupRangeWithKey mbb) matches
-    intersectRTree x = isJust $ mbb `intersectMBB` (getMBB x)
+    intersectRTree x = mbb `touchesMBB` (getMBB x)
 
 -- | returns all values, which are located in the given bounding box.
 lookupRange :: MBB -> RTree a -> [a]
@@ -355,6 +357,24 @@ lookupContainsRangeWithKey mbb t = founds
 lookupContainsRange :: MBB -> RTree a -> [a]
 lookupContainsRange mbb t = snd <$> (lookupContainsRangeWithKey mbb t)
 
+
+-- | returns all keys and values touching the given bounding box
+lookupTouchesRangeWithKey :: MBB -> RTree a -> [(MBB, a)]
+lookupTouchesRangeWithKey _ Empty = []
+lookupTouchesRangeWithKey mbb t@Leaf{}
+    | (getMBB t) `touchesMBB` mbb = [(getMBB t, getElem t)]
+    | otherwise = []
+lookupTouchesRangeWithKey mbb t = founds
+    where
+    matches = filter intersectRTree $ getChildren t
+    founds = concatMap (lookupTouchesRangeWithKey mbb) matches
+    intersectRTree x = mbb `touchesMBB` (getMBB x)
+
+-- | returns all values touching the given bounding box
+lookupTouchesRange :: MBB -> RTree a -> [a]
+lookupTouchesRange mbb t = snd <$> (lookupTouchesRangeWithKey mbb t)
+
+
 -- -----------
 -- delete
 

Data/RTree/MBB.hs

@@ -21,6 +21,7 @@ module Data.RTree.MBB
     mbb,
     area,
     containsMBB,
+    touchesMBB,
     unionMBB,
     unionsMBB,
     intersectMBB,
@@ -31,22 +32,23 @@ where
 
 import Data.Binary
 
+import           Data.Maybe (isJust)
 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, Ord)
 
--- | 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
+-- | create a minimal bounding box (or a rectangle)
+-- The first point must be smaller, than the second one. This is unchecked. To make sense of the following components, visualize x-axis pointing to the right and y-axis pointing downwards; u=upper, b=bottom, l=left,r=right.
+mbb :: Double -- ^ x - coordinate of first  point (ulx)
+    -> Double -- ^ y - coordinate of first  point (uly)
+    -> Double -- ^ x - coordinate of second point (brx)
+    -> Double -- ^ y - coordinate of second point (bry)
     -> MBB
 mbb = MBB
 
--- | the property, that a 'MBB' must hold
+-- | the property that a 'MBB' must hold, namely that the first point must be smaller than the second one.
 isValidMBB :: MBB -> Bool
 isValidMBB (MBB ulx uly brx bry) = (ulx <= brx) && (uly <= bry)
 
@@ -70,6 +72,12 @@ area (MBB ulx uly brx bry) = (brx - ulx) * (bry - uly)
 containsMBB :: MBB -> MBB -> Bool
 containsMBB (MBB x11 y11 x12 y12) (MBB x21 y21 x22 y22) =  x11 <= x21 && y11 <= y21 && x12 >= x22 && y12 >= y22
 
+
+-- | returns True, when the two mbbs touch each other
+touchesMBB :: MBB -> MBB -> Bool
+touchesMBB mbb1 mbb2 = isJust $ mbb1 `intersectMBB` mbb2
+
+
 -- | 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')

changelog.md

@@ -16,4 +16,9 @@
 * Add `intersectWithKey` and `intersect`.
 * Now supports GHC 8.4, 8.5 and 8.6.
 * Removed `test-strict` flag.
-* Minimal Bounding Box is now also an instance of `Ord`
+* Minimal Bounding Box is now also an instance of `Ord`
+
+
+## 0.6.1
+
+* Add `lookupTouchesRangeWithKey` and `lookupTouchesRange`.

data-r-tree.cabal

@@ -1,7 +1,7 @@
 cabal-version: 2.2
 
 name:                   data-r-tree
-version:                0.6.0
+version:                0.6.1
 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.
 

test/RTreeProperties.hs

@@ -43,6 +43,8 @@ main = do
            , testCase "test_lookupRangeWithKey" test_lookupRangeWithKey
            , testCase "test_lookupContainsRange" test_lookupContainsRange
            , testCase "test_lookupContainsRangeWithKey" test_lookupContainsRangeWithKey
+           , testCase "test_lookupTouchesRange" test_lookupTouchesRange
+           , testCase "test_lookupTouchesRangeWithKey" test_lookupTouchesRangeWithKey
            , testCase "test_union" test_union
            , testCase "test_unionWith" test_unionWith
            , testCase "test_length" test_length
@@ -68,10 +70,15 @@ t_mbb6 = (MBB 0.0 0.0 0.0 0.0)
 t_mbb7 = (MBB 1.0 2.0 5.0 4.0)
 t_mbb8 = (MBB 4.0 0.0 6.0 3.0)
 
-t_1, t_2, t_3 :: RTree String
+t_1, t_2, t_3, t_4, t_5, t_6, t_7, t_8 :: 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"
+t_7 = singleton t_mbb7 "g"
+t_8 = singleton t_mbb8 "h"
 
 
 u_1, u_2, u_3 :: [(MBB, String)]
@@ -222,6 +229,45 @@ test_lookupContainsRangeWithKey = do
     lookupContainsRangeWithKey t_mbb6 tu_2 `eqList` [(t_mbb6, "f"), (t_mbb1, "a")]
 
 
+test_lookupTouchesRange :: Assertion
+test_lookupTouchesRange = do
+    lookupTouchesRange t_mbb3 t_3 @?= ["c"]
+    lookupTouchesRange t_mbb1 tu_1 @?= ["a"]
+    lookupTouchesRange t_mbb2 tu_2 @?= ["b"]
+    lookupTouchesRange t_mbb3 tu_2 @?= ["c"]
+    lookupTouchesRange t_mbb4 tu_2 @?= ["d"]
+    lookupTouchesRange t_mbb5 tu_2 @?= ["e"]
+    lookupTouchesRange t_mbb6 tu_2 `eqList` ["f","a"]
+
+    lookupTouchesRange (MBB 1.0 1.0 7.0 3.0) tu_2 `eqList` ["e","c","a","b","d"]
+    lookupTouchesRange (MBB 0.0 0.0 1.0 1.0) tu_2 `eqList` ["f","a"]
+    lookupTouchesRange (MBB 0.0 0.0 7.0 4.0) tu_2 `eqList` ["e","c","f","a","b","d"]
+    lookupTouchesRange (MBB 0.5 0.5 0.5 0.5) tu_2 `eqList` ["a"]
+    lookupTouchesRange (MBB 0.0 1.0 0.0 1.0) tu_2 `eqList` ["a"]
+    lookupTouchesRange (MBB 1.0 0.0 1.0 0.0) tu_2 `eqList` ["a"]
+    lookupTouchesRange (MBB 1.0 1.0 1.0 1.0) tu_2 `eqList` ["a"]
+
+    lookupTouchesRange t_mbb2 tu_3 `eqList` ["b","h"]
+    lookupTouchesRange t_mbb3 tu_3 `eqList` ["c","g"]
+    lookupTouchesRange t_mbb4 tu_3 `eqList` ["d","h"]
+    lookupTouchesRange t_mbb5 tu_3 `eqList` ["e","g","h"]
+    lookupTouchesRange t_mbb6 tu_3 `eqList` ["f","a"]
+    lookupTouchesRange t_mbb7 tu_3 `eqList` ["c","e","g","h"]
+    lookupTouchesRange t_mbb8 tu_3 `eqList` ["h","b","g","d","e"]
+
+    lookupTouchesRange (MBB 4.5 2.5 4.5 2.5) tu_3 `eqList` ["g","h"]
+
+test_lookupTouchesRangeWithKey :: Assertion
+test_lookupTouchesRangeWithKey = do
+    lookupTouchesRangeWithKey t_mbb3 t_3 `eqList` [(t_mbb3, "c")]
+    lookupTouchesRangeWithKey t_mbb1 tu_1 `eqList` [(t_mbb1, "a")]
+    lookupTouchesRangeWithKey t_mbb2 tu_2 `eqList` [(t_mbb2, "b")]
+    lookupTouchesRangeWithKey t_mbb3 tu_2 `eqList` [(t_mbb3, "c")]
+    lookupTouchesRangeWithKey t_mbb4 tu_2 `eqList` [(t_mbb4, "d")]
+    lookupTouchesRangeWithKey t_mbb5 tu_2 `eqList` [(t_mbb5, "e")]
+    lookupTouchesRangeWithKey t_mbb6 tu_2 `eqList` [(t_mbb6, "f"), (t_mbb1, "a")]
+
+
 test_union :: Assertion
 test_union = do
     union empty empty `eqRt` (empty :: RTree ())