diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +## 1.0.0.0 -- September 2024 + +- Initial rewrite. +- Library renamed from `data-r-tree`. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +The MIT License + +Copyright (c) 2015 Sebastian Philipp, Birte Wagner +Copyright (c) 2022 Oleksii Divak + +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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,18 @@ +# r-tree [![Hackage](http://img.shields.io/hackage/v/r-tree.svg)](https://hackage.haskell.org/package/r-tree) + +A Haskell library for [R-trees](https://en.wikipedia.org/wiki/R-tree) and [R\*-trees](https://en.wikipedia.org/wiki/R\*-tree). + +> [!NOTE] +> +> R-trees are self-balancing and as such can only be spine-strict. + +Featuring: + +- `Data.R2Tree.*`: two-dimensional R-tree with the R\*-tree insertion algorithm. + + `Double`-based implementation is considered the default one; + a `Float`-based variant is provided for cases where reduced precision is preferred, + for example rendering. + +Higher-dimensional R-trees are not currently provided, +but should be trivial to add if needed. 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/benchmark/space/Main.hs b/benchmark/space/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/space/Main.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE TypeApplications #-} + +module Main where + +import qualified Data.R2Tree.Float as R + +import Control.Monad +import Data.Foldable +import Data.List hiding (lookup, map) +import Prelude hiding (lookup, map) +import System.Random.Stateful +import Weigh + + + +randMBR :: StatefulGen g m => g -> m R.MBR +randMBR g = do + a <- uniformRM (0, 2 ^ (20 :: Int)) g + b <- uniformRM (0, 2 ^ (20 :: Int)) g + return $ R.MBR a b (a + 1) (b + 1) + + + +main :: IO () +main = do + g <- newIOGenM $ mkStdGen 0 + raw <- flip zip [0 :: Int ..] <$> replicateM 16384 (randMBR g) + + mainWith $ do + setColumns [Case, Allocated, Max, Live, GCs] + wgroup "insert" $ do + io "BKSS" (pure . foldr (uncurry R.insert) R.empty) raw + io "Gut" (pure . foldr (uncurry R.insertGut) R.empty) raw diff --git a/benchmark/time/Main.hs b/benchmark/time/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/time/Main.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Main where + +import Data.R2Tree.Double (R2Tree, MBR, Predicate) +import qualified Data.R2Tree.Double as R + +import Control.DeepSeq +import Control.Monad +import Data.Foldable +import Data.List hiding (lookup, map) +import Data.Monoid +import Prelude hiding (lookup, map) +import System.Random.Stateful +import Test.Tasty.Bench + + + +instance NFData MBR where + rnf ba = ba `seq` () + + + +randPoint :: StatefulGen g m => g -> m MBR +randPoint g = do + a <- uniformRM (0, 2 ^ (20 :: Int)) g + b <- uniformRM (0, 2 ^ (20 :: Int)) g + return $ R.MBR a b (a + 1) (b + 1) + +randArea :: StatefulGen g m => g -> m MBR +randArea g = do + a <- uniformRM (0, 2 ^ (20 :: Int)) g + b <- uniformRM (0, 2 ^ (20 :: Int)) g + c <- uniformRM (0, 2 ^ (20 :: Int)) g + d <- uniformRM (0, 2 ^ (20 :: Int)) g + return $ R.MBR a b c d + + + +newStdGenM :: IO (IOGenM StdGen) +newStdGenM = newIOGenM $ mkStdGen 0 + +genPoints :: StatefulGen g m => Int -> g -> m [(MBR, Int)] +genPoints n g = flip zip [0..] <$> replicateM n (randPoint g) + +genAreas :: StatefulGen g m => Int -> g -> m [MBR] +genAreas n = replicateM n . randPoint + + + +lookup + :: String -> ([(MBR, Int)] -> R2Tree Int) + -> String -> (MBR -> Predicate) -> Benchmark +lookup cat from name pre = + env ( do g <- newIOGenM $ mkStdGen 0 + no <- genPoints 4096 g + return (from no, take 1024 $ fst <$> no) + ) $ \ ~(r, brs) -> + bgroup (cat <> "/lookup/" <> name) $ + [ bench "First" $ + flip nf brs $ + foldMap $ \x -> [R.foldMapRangeWithKey (pre x) (\_ -> First . Just) r] + + , bench "List" $ + flip nf brs $ + foldMap $ \x -> [R.foldMapRangeWithKey (pre x) (\_ -> (:[])) r] + ] + + +map + :: String -> ([(MBR, Int)] -> R2Tree Int) + -> String -> (MBR -> Predicate) -> Benchmark +map cat from name pre = + env ( do g <- newIOGenM $ mkStdGen 0 + no <- genPoints 4096 g + as <- genAreas 1024 g + return (from no, as) + ) $ \ ~(r, brs) -> + bench (cat <> "/map/" <> name) $ + flip nf brs $ + fmap $ \x -> [R.adjustRangeWithKey (pre x) (\_ -> (+) 1) r] + +traversal + :: String -> ([(MBR, Int)] -> R2Tree Int) + -> String -> (MBR -> Predicate) -> Benchmark +traversal cat from name pre = + env ( do g <- newIOGenM $ mkStdGen 0 + no <- genPoints 4096 g + as <- genAreas 1024 g + return (from no, as) + ) $ \ ~(r, brs) -> + bench (cat <> "/traverse/" <> name) $ + flip nfAppIO brs $ + traverse $ \x -> fmap (:[]) $ R.traverseRangeWithKey (pre x) (\_ -> pure @IO . (+) 1) r + + +fromList :: Foldable t => t (MBR, b) -> R2Tree b +fromList = foldl' (\z (a, b) -> R.insert a b z) R.empty + +fromListGut :: Foldable t => t (MBR, b) -> R2Tree b +fromListGut = foldl' (\z (a, b) -> R.insertGut a b z) R.empty + + +main :: IO () +main = do + defaultMain + [ env ( do g <- newIOGenM $ mkStdGen 0 + no <- genPoints 4096 g + return no + ) $ \ ~raw -> + bgroup "insert" + [ bench "BKSS" $ + nf fromList raw + + , bench "Gut" $ + nf fromListGut raw + + , bench "STR" $ + nf R.bulkSTR raw + ] + + , env ( do g <- newIOGenM $ mkStdGen 0 + no <- genPoints 4096 g + return (fromList no, fst <$> no) + ) $ \ ~(r, brs) -> + bench "delete" $ + nf (foldr R.delete r) brs + + , lookup "BKSS" fromList "equals" R.equals + , lookup "BKSS" fromList "intersects" R.intersects + , lookup "BKSS" fromList "contains" R.contains + , lookup "BKSS" fromList "containedBy" R.containedBy + + , map "BKSS" fromList "equals" R.equals + , map "BKSS" fromList "intersects" R.intersects + , map "BKSS" fromList "contains" R.contains + , map "BKSS" fromList "containedBy" R.containedBy + + , traversal "BKSS" fromList "equals" R.equals + , traversal "BKSS" fromList "intersects" R.intersects + , traversal "BKSS" fromList "contains" R.contains + , traversal "BKSS" fromList "containedBy" R.containedBy + + , lookup "Gut" fromListGut "equals" R.equals + , lookup "Gut" fromListGut "intersects" R.intersects + , lookup "Gut" fromListGut "contains" R.contains + , lookup "Gut" fromListGut "containedBy" R.containedBy + + , map "Gut" fromListGut "equals" R.equals + , map "Gut" fromListGut "intersects" R.intersects + , map "Gut" fromListGut "contains" R.contains + , map "Gut" fromListGut "containedBy" R.containedBy + + , traversal "Gut" fromListGut "equals" R.equals + , traversal "Gut" fromListGut "intersects" R.intersects + , traversal "Gut" fromListGut "contains" R.contains + , traversal "Gut" fromListGut "containedBy" R.containedBy + + , lookup "STR" R.bulkSTR "equals" R.equals + , lookup "STR" R.bulkSTR "intersects" R.intersects + , lookup "STR" R.bulkSTR "contains" R.contains + , lookup "STR" R.bulkSTR "containedBy" R.containedBy + + , map "STR" R.bulkSTR "equals" R.equals + , map "STR" R.bulkSTR "intersects" R.intersects + , map "STR" R.bulkSTR "contains" R.contains + , map "STR" R.bulkSTR "containedBy" R.containedBy + + , traversal "STR" R.bulkSTR "equals" R.equals + , traversal "STR" R.bulkSTR "intersects" R.intersects + , traversal "STR" R.bulkSTR "contains" R.contains + , traversal "STR" R.bulkSTR "containedBy" R.containedBy + ] diff --git a/no/No/Tree/D2.hs b/no/No/Tree/D2.hs new file mode 100644 --- /dev/null +++ b/no/No/Tree/D2.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- | + Reference spatial tree implemented using a naive list of elements. + + Every fold/map is \(O (n)\). +-} + +module No.Tree.D2 where + +import Data.R2Tree.Double.Unsafe (MBR (..), Predicate (..)) + +import Control.DeepSeq +import qualified Data.Foldable as Fold +import qualified Data.List as List +import Prelude hiding (Foldable (..)) + + + +newtype NoTree a = NoTree { toList :: [(MBR, a)] } + +instance Show a => Show (NoTree a) where + show = showString "fromList " . flip showList "" . toList + +instance NFData a => NFData (NoTree a) where + rnf = liftRnf (\(ba, a) -> ba `seq` rnf a) . toList + +instance Functor NoTree where + fmap f = NoTree . fmap (fmap f) . toList + +instance Fold.Foldable NoTree where + foldMap f = Fold.foldMap (f . snd) . toList + + foldr f z = Fold.foldr (f . snd) z . toList + foldr' f z = Fold.foldr' (f . snd) z . toList + + foldl f z = Fold.foldl (\acc -> f acc . snd) z . toList + foldl' f z = Fold.foldl' (\acc -> f acc . snd) z . toList + +instance Traversable NoTree where + traverse f = fmap NoTree . Prelude.traverse (Prelude.traverse f) . toList + + + +empty :: NoTree a +empty = NoTree [] + +singleton :: MBR -> a -> NoTree a +singleton bx x = NoTree [(bx, x)] + + + +null :: NoTree a -> Bool +null = List.null . toList + +length :: NoTree a -> Int +length = List.length . toList + + + +insert :: MBR -> a -> NoTree a -> NoTree a +insert ba a = NoTree . (:) (ba, a) . toList + +delete :: MBR -> NoTree a -> NoTree a +delete ba no = let (xs, ys) = break ((== ba) . fst) $ toList no + in NoTree $ xs <> drop 1 ys + + + +mapWithKey :: (MBR -> a -> b) -> NoTree a -> NoTree b +mapWithKey f = NoTree . fmap (\ ~(ba, a) -> (ba, f ba a) ) . toList + +adjustRangeWithKey :: Predicate -> (MBR -> a -> a) -> NoTree a -> NoTree a +adjustRangeWithKey (Predicate _ checkLeaf) f = + NoTree . fmap (\(ba, a) -> (ba, opt ba a)) . toList + where + opt ba a | checkLeaf ba = f ba a + | otherwise = a + + + +foldMapRangeWithKey :: Monoid m => Predicate -> (MBR -> a -> m) -> NoTree a -> m +foldMapRangeWithKey (Predicate _ checkLeaf) f = Fold.foldMap opt . toList + where + opt (ba, a) | checkLeaf ba = f ba a + | otherwise = mempty + + +foldrRangeWithKey :: Predicate -> (MBR -> a -> b -> b) -> b -> NoTree a -> b +foldrRangeWithKey (Predicate _ checkLeaf) f z = Fold.foldr opt z . toList + where + opt (ba, a) acc | checkLeaf ba = f ba a acc + | otherwise = acc + +foldrRangeWithKey' :: Predicate -> (MBR -> a -> b -> b) -> b -> NoTree a -> b +foldrRangeWithKey' (Predicate _ checkLeaf) f z = Fold.foldr' opt z . toList + where + opt (ba, a) acc | checkLeaf ba = f ba a acc + | otherwise = acc + + +foldlRangeWithKey :: Predicate -> (b -> MBR -> a -> b) -> b -> NoTree a -> b +foldlRangeWithKey (Predicate _ checkLeaf) f z = Fold.foldl opt z . toList + where + opt acc (ba, a) | checkLeaf ba = f acc ba a + | otherwise = acc + +foldlRangeWithKey' :: Predicate -> (b -> MBR -> a -> b) -> b -> NoTree a -> b +foldlRangeWithKey' (Predicate _ checkLeaf) f z = Fold.foldl' opt z . toList + where + opt acc (ba, a) | checkLeaf ba = f acc ba a + | otherwise = acc + + + +traverseWithKey + :: Applicative f => (MBR -> a -> f b) -> NoTree a -> f (NoTree b) +traverseWithKey f = + fmap NoTree . Prelude.traverse ( \(ba, a) -> (,) ba <$> f ba a) . toList + +traverseRangeWithKey + :: Applicative f + => Predicate -> (MBR -> a -> f a) -> NoTree a -> f (NoTree a) +traverseRangeWithKey (Predicate _ checkLeaf) f = + fmap NoTree . Prelude.traverse ( \(ba, a) -> (,) ba <$> opt ba a) . toList + where + opt ba a | checkLeaf ba = f ba a + | otherwise = pure a + + + +fromList :: [(MBR, a)] -> NoTree a +fromList = NoTree diff --git a/r-tree.cabal b/r-tree.cabal new file mode 100644 --- /dev/null +++ b/r-tree.cabal @@ -0,0 +1,106 @@ +cabal-version: 2.2 + +name: r-tree +version: 1.0.0.0 +synopsis: R-/R*-trees. +description: R-trees and R*-trees. + + See the + for a brief overview of the data structures included in this package. + +license: MIT +license-file: LICENSE +author: Sebastian Wagner, Birte Wagner, Oleksii Divak +maintainer: Oleksii Divak +copyright: Sebastian Wagner, Birte Wagner, Oleksii Divak +category: Data Structures +build-type: Simple + +extra-doc-files: CHANGELOG.md + README.md + +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 + build-depends: base >= 4.12 && < 5 + , deepseq >= 1.4.3 && < 1.6 + + hs-source-dirs: src + + exposed-modules: Data.R2Tree.Double + Data.R2Tree.Double.Debug + Data.R2Tree.Double.Unsafe + Data.R2Tree.Float + Data.R2Tree.Float.Debug + Data.R2Tree.Float.Unsafe + + other-modules: Data.R2Tree.Double.Internal + Data.R2Tree.Float.Internal + + ghc-options: -Wall + + default-language: Haskell2010 + +benchmark time + build-depends: base + , r-tree + , deepseq + , tasty-bench >= 0.3 && < 0.5 + , random >= 1.2 && < 1.3 + + type: exitcode-stdio-1.0 + + main-is: Main.hs + + ghc-options: -Wall + + hs-source-dirs: benchmark/time + + default-language: Haskell2010 + +benchmark space + build-depends: base + , r-tree + , random + , weigh >= 0.0.16 && < 0.1 + + type: exitcode-stdio-1.0 + + main-is: Main.hs + + ghc-options: -Wall + + hs-source-dirs: benchmark/space + + default-language: Haskell2010 + +test-suite properties + build-depends: base + , r-tree + , deepseq + , hspec >= 2 && < 2.12 + , random + + type: exitcode-stdio-1.0 + + main-is: Main.hs + + other-modules: No.Tree.D2 + + Test.Kit + Test.R2Tree.Double + Test.R2Tree.Double.Sample + + ghc-options: -Wall + + hs-source-dirs: no + , test/properties + + default-language: Haskell2010 diff --git a/src/Data/R2Tree/Double.hs b/src/Data/R2Tree/Double.hs new file mode 100644 --- /dev/null +++ b/src/Data/R2Tree/Double.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE PatternSynonyms #-} + +{- | + Module : Data.R2Tree.Double + Copyright : Copyright (c) 2015, Birte Wagner, Sebastian Philipp + Copyright (c) 2022, Oleksii Divak + License : MIT + + Maintainer : Oleksii Divak + Stability : experimental + Portability: not portable + + @'R2Tree' a@ is a spine-strict two-dimensional spatial tree using 'Double's as keys. + + R-trees have no notion of element order, as such: + + - Duplicate t'MBR's are permitted. Inserting a duplicate may put it anywhere on the + tree, there is no guarantee a successive 'delete' will pick the newer entry + over the older one. + + - Updating an t'MBR' of an entry requires a reinsertion of said entry. + + - Merge operations are not supported. + + == Laziness + + Evaluating the root of the tree (i.e. @(_ :: 'R2Tree' a)@) to WHNF + evaluates the entire spine of the tree to normal form. + + Functions do not perform any additional evaluations unless + their documentation directly specifies so. + + == Performance + + Each function's time complexity is provided in the documentation. + + \(n\) refers to the total number of entries in the tree. + Parts of the tree are denoted using subscripts: \(n_L\) refers to the left side, + \(n_R\) to the right side, \(n_I\) to a range (interval), and + \(n_M\) to entries collected with the use of a 'Monoid'. + + == Inlining + + Functions that produce and consume 'Predicate's inline heavily. + To avoid unnecessary code duplication during compilation consider creating + helper functions that apply these functions one to another, e.g. + +@ +listIntersections :: 'MBR' -> 'R2Tree' a -> [('MBR', a)] +listIntersections mbr = foldrRangeWithKey (intersects mbr) (\a b -> (:) (a, b)) [] +@ + + N.B. To inline properly functions that consume 'Predicate's + must mention all of the arguments except for the tree. + + == Implementation + + The implementation is heavily specialized for constants + \(m = 2, M = 4, p = 1, k = 1\). + + Descriptions of the R-/R*-tree and of the algorithms implemented can be found within + the following papers: + + * Antonin Guttman (1984), + \"/R-Trees: A Dynamic Index Structure for Spatial Searching/\", + + + * N. Beckmann, H.P. Kriegel, R. Schneider, B. Seeger (1990), + \"/The R*-tree: an efficient and robust access method for points and rectangles/\", + + + * S.T. Leutenegger, J.M. Edgington, M.A. Lopez (1997), + \"/STR: A Simple and Efficient Algorithm for R-Tree Packing/\", + +-} + +module Data.R2Tree.Double + ( MBR (MBR) + , R2Tree + + -- * Construct + , empty + , singleton + , doubleton + , tripleton + , quadrupleton + + -- ** Bulk-loading + , bulkSTR + + -- * Single-key + -- ** Insert + , insert + , insertGut + + -- ** Delete + , delete + + -- * Range + , Predicate + , equals + , intersects + , intersects' + , contains + , contains' + , containedBy + , containedBy' + + -- ** Map + , adjustRangeWithKey + , adjustRangeWithKey' + + -- ** Fold + , foldlRangeWithKey + , foldrRangeWithKey + , foldMapRangeWithKey + , foldlRangeWithKey' + , foldrRangeWithKey' + + -- ** Traverse + , traverseRangeWithKey + + -- * Full tree + -- ** Size + , Data.R2Tree.Double.Internal.null + , size + + -- ** Map + , Data.R2Tree.Double.Internal.map + , map' + , mapWithKey + , mapWithKey' + + -- ** Fold + -- | === Left-to-right + , Data.R2Tree.Double.Internal.foldl + , Data.R2Tree.Double.Internal.foldl' + , foldlWithKey + , foldlWithKey' + + -- | === Right-to-left + , Data.R2Tree.Double.Internal.foldr + , Data.R2Tree.Double.Internal.foldr' + , foldrWithKey + , foldrWithKey' + + -- | === Monoid + , Data.R2Tree.Double.Internal.foldMap + , foldMapWithKey + + -- ** Traverse + , Data.R2Tree.Double.Internal.traverse + , traverseWithKey + ) where + +import Data.R2Tree.Double.Internal + + + +-- | \(\mathcal{O}(1)\). +-- Empty tree. +empty :: R2Tree a +empty = Empty + +-- | \(\mathcal{O}(1)\). +-- Tree with a single entry. +singleton :: MBR -> a -> R2Tree a +singleton = Leaf1 + +-- | \(\mathcal{O}(1)\). +-- Tree with two entries. +doubleton :: MBR -> a -> MBR -> a -> R2Tree a +doubleton = Leaf2 + +-- | \(\mathcal{O}(1)\). +-- Tree with three entries. +tripleton :: MBR -> a -> MBR -> a -> MBR -> a -> R2Tree a +tripleton = Leaf3 + +-- | \(\mathcal{O}(1)\). +-- Tree with four entries. +quadrupleton :: MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a -> R2Tree a +quadrupleton = Leaf4 diff --git a/src/Data/R2Tree/Double/Debug.hs b/src/Data/R2Tree/Double/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Data/R2Tree/Double/Debug.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +{- | + Module : Data.R2Tree.Double.Debug + Copyright : Copyright (c) 2015, Birte Wagner, Sebastian Philipp + Copyright (c) 2022, Oleksii Divak + License : MIT + + Maintainer : Oleksii Divak + Stability : experimental + Portability: not portable + + Functions that expose the innerworkings of an 'R2Tree', but are completely safe + to use otherwise. +-} + +module Data.R2Tree.Double.Debug + ( showsTree + + , Validity (..) + , Reason (..) + , validate + ) where + +import Data.R2Tree.Double.Internal + + + +-- | \(\mathcal{O}(n)\). +-- Shows the internal structure of the R-tree. +showsTree :: (a -> ShowS) -> R2Tree a -> ShowS +showsTree f = go id 0 + where + {-# INLINE mbr #-} + mbr (UnsafeMBR xmin ymin xmax ymax) = shows (xmin, ymin, xmax, ymax) + + {-# INLINE offset #-} + offset i + | i <= 0 = id + | otherwise = showChar ' ' . offset (i - 1) + + go s (i :: Int) n = + offset i . + case n of + Node2 ba a bb b -> + showString "Node 2" . s + . showChar '\n' . go (showChar ' ' . mbr ba) (i + 2) a + . showChar '\n' . go (showChar ' ' . mbr bb) (i + 2) b + + Node3 ba a bb b bc c -> + showString "Node 3" . s + . showChar '\n' . go (showChar ' ' . mbr ba) (i + 2) a + . showChar '\n' . go (showChar ' ' . mbr bb) (i + 2) b + . showChar '\n' . go (showChar ' ' . mbr bc) (i + 2) c + + Node4 ba a bb b bc c bd d -> + showString "Node 4" . s + . showChar '\n' . go (showChar ' ' . mbr ba) (i + 2) a + . showChar '\n' . go (showChar ' ' . mbr bb) (i + 2) b + . showChar '\n' . go (showChar ' ' . mbr bc) (i + 2) c + . showChar '\n' . go (showChar ' ' . mbr bd) (i + 2) d + + Leaf2 ba a bb b -> + showString "Leaf 2" . s + . showChar '\n' . offset (i + 2) . mbr ba . showChar ' ' . f a + . showChar '\n' . offset (i + 2) . mbr bb . showChar ' ' . f b + + Leaf3 ba a bb b bc c -> + showString "Leaf 3" . s + . showChar '\n' . offset (i + 2) . mbr ba . showChar ' ' . f a + . showChar '\n' . offset (i + 2) . mbr bb . showChar ' ' . f b + . showChar '\n' . offset (i + 2) . mbr bc . showChar ' ' . f c + + Leaf4 ba a bb b bc c bd d -> + showString "Leaf 4" . s + . showChar '\n' . offset (i + 2) . mbr ba . showChar ' ' . f a + . showChar '\n' . offset (i + 2) . mbr bb . showChar ' ' . f b + . showChar '\n' . offset (i + 2) . mbr bc . showChar ' ' . f c + . showChar '\n' . offset (i + 2) . mbr bd . showChar ' ' . f d + + Leaf1 bx x -> + showString "Leaf 1" . s + . showChar '\n' . offset (i + 2) . mbr bx . showChar ' ' . f x + + Empty -> + showString "Empty" . s + + + +-- | Whether the tree is well-formed. +data Validity = Valid + | Invalid Reason + deriving Show + +-- | Reason for why the tree is considered malformed. +data Reason = -- | Not all nodes are at the same depth. + UnbalancedTree + -- | Node does not enclose all inner t'MBR's properly. + | MalformedNode MBR + -- | Found a 'Leaf1' node not at root level. + | FoundLeaf1 + -- | Found an 'Empty' node not at root level. + | FoundEmpty + deriving Show + + + +data Carry = Carry Int + | Broken Reason + +carry2 :: Carry -> Carry -> Carry +carry2 (Carry i) (Carry j) + | i == j = Carry (i + 1) + | otherwise = Broken UnbalancedTree + +carry2 (Carry _) b = b +carry2 a _ = a + +carry3 :: Carry -> Carry -> Carry -> Carry +carry3 (Carry i) (Carry j) (Carry k) + | i == j, i == k = Carry (i + 1) + | otherwise = Broken UnbalancedTree + +carry3 (Carry _) (Carry _) c = c +carry3 (Carry _) b _ = b +carry3 a _ _ = a + +carry4 :: Carry -> Carry -> Carry -> Carry -> Carry +carry4 (Carry i) (Carry j) (Carry k) (Carry l) + | i == j, i == k, i == l = Carry (i + 1) + | otherwise = Broken UnbalancedTree + +carry4 (Carry _) (Carry _) (Carry _) d = d +carry4 (Carry _) (Carry _) c _ = c +carry4 (Carry _) b _ _ = b +carry4 a _ _ _ = a + + + +-- | \(\mathcal{O}(n)\). +-- Checks whether the tree is well-formed. +validate :: R2Tree a -> Validity +validate t = + case t of + Leaf1 _ _ -> Valid + Empty -> Valid + _ -> + case go Nothing t of + Carry _ -> Valid + Broken r -> Invalid r + where + go mbx x = + case x of + Node2 ba a bb b + | Just bx <- mbx, bx /= unionMBR ba bb -> Broken $ MalformedNode bx + | otherwise -> + carry2 (go (Just ba) a) + (go (Just bb) b) + + Node3 ba a bb b bc c + | Just bx <- mbx, bx /= unionMBR (unionMBR ba bb) bc -> Broken $ MalformedNode bx + | otherwise -> + carry3 (go (Just ba) a) + (go (Just bb) b) + (go (Just bc) c) + + Node4 ba a bb b bc c bd d + | Just bx <- mbx + , bx /= unionMBR (unionMBR (unionMBR ba bb) bc) bd -> Broken $ MalformedNode bx + + | otherwise -> + carry4 (go (Just ba) a) + (go (Just bb) b) + (go (Just bc) c) + (go (Just bd) d) + + Leaf2 ba _ bb _ + | Just bx <- mbx, bx /= unionMBR ba bb -> Broken $ MalformedNode bx + | otherwise -> Carry 0 + + Leaf3 ba _ bb _ bc _ + | Just bx <- mbx, bx /= unionMBR (unionMBR ba bb) bc -> Broken $ MalformedNode bx + | otherwise -> Carry 0 + + Leaf4 ba _ bb _ bc _ bd _ + | Just bx <- mbx + , bx /= unionMBR (unionMBR (unionMBR ba bb) bc) bd -> Broken $ MalformedNode bx + + | otherwise -> Carry 0 + + Leaf1 _ _ -> Broken FoundLeaf1 + Empty -> Broken FoundEmpty diff --git a/src/Data/R2Tree/Double/Internal.hs b/src/Data/R2Tree/Double/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/R2Tree/Double/Internal.hs @@ -0,0 +1,2204 @@ +{-# LANGUAGE BangPatterns + , PatternSynonyms + , RankNTypes + , ViewPatterns + , UnboxedTuples #-} + +module Data.R2Tree.Double.Internal + ( MBR (UnsafeMBR, MBR) + , validMBR + , eqMBR + , unionMBR + , areaMBR + , marginMBR + , distanceMBR + , containsMBR + , containsMBR' + , intersectionMBR + , intersectionMBR' + + , Predicate (..) + , equals + , intersects + , intersects' + , contains + , contains' + , containedBy + , containedBy' + + , R2Tree (..) + + , Data.R2Tree.Double.Internal.null + , Data.R2Tree.Double.Internal.size + + , Data.R2Tree.Double.Internal.map + , map' + , mapWithKey + , mapWithKey' + , adjustRangeWithKey + , adjustRangeWithKey' + + , Data.R2Tree.Double.Internal.foldl + , Data.R2Tree.Double.Internal.foldl' + , foldlWithKey + , foldlWithKey' + , foldlRangeWithKey + , foldlRangeWithKey' + + , Data.R2Tree.Double.Internal.foldr + , Data.R2Tree.Double.Internal.foldr' + , foldrWithKey + , foldrWithKey' + , foldrRangeWithKey + , foldrRangeWithKey' + + , Data.R2Tree.Double.Internal.foldMap + , foldMapWithKey + , foldMapRangeWithKey + + , Data.R2Tree.Double.Internal.traverse + , traverseWithKey + , traverseRangeWithKey + + , insertGut + , insert + , delete + + , bulkSTR + ) where + +import Control.Applicative +import Control.DeepSeq +import Data.Bits +import Data.Foldable +import Data.Functor.Classes +import Data.Function +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty (..), (<|)) +import Text.Show + + + +-- | Two-dimensional minimum bounding rectangle is defined as two intervals, +-- each along a separate axis, where every endpoint is either +-- bounded and closed (i.e. \( [a, b] \)), or infinity (i.e. \((\pm \infty, b]\)). +-- +-- Degenerate intervals (i.e. \([a,a]\)) are permitted. +data MBR = -- | Invariants: \( x_{min} \le x_{max}, y_{min} \le y_{max} \). + UnsafeMBR + {-# UNPACK #-} !Double -- ^ \( x_{min} \) + {-# UNPACK #-} !Double -- ^ \( y_{min} \) + {-# UNPACK #-} !Double -- ^ \( x_{max} \) + {-# UNPACK #-} !Double -- ^ \( y_{max} \) + +{-# COMPLETE MBR #-} +-- | Reorders coordinates to fit internal invariants. +-- +-- Pattern matching guarantees \( x_{0} \le x_{1}, y_{0} \le y_{1} \). +pattern MBR + :: Double -- ^ \( x_0 \) + -> Double -- ^ \( y_0 \) + -> Double -- ^ \( x_1 \) + -> Double -- ^ \( y_1 \) + -> MBR +pattern MBR xmin ymin xmax ymax <- UnsafeMBR xmin ymin xmax ymax + where + MBR x0 y0 x1 y1 = + let !(# xmin, xmax #) | x0 <= x1 = (# x0, x1 #) + | otherwise = (# x1, x0 #) + + !(# ymin, ymax #) | y0 <= y1 = (# y0, y1 #) + | otherwise = (# y1, y0 #) + + in UnsafeMBR xmin ymin xmax ymax + +instance Show MBR where + showsPrec d (UnsafeMBR xmin ymin xmax ymax) = + showParen (d > 10) $ showString "MBR " . showsPrec 11 xmin + . showChar ' ' . showsPrec 11 ymin + . showChar ' ' . showsPrec 11 xmax + . showChar ' ' . showsPrec 11 ymax + +instance Eq MBR where + (==) = eqMBR + + + +-- | Check whether lower endpoints are smaller or equal to the respective upper ones. +validMBR :: MBR -> Bool +validMBR (MBR xmin ymin xmax ymax) = xmin <= xmax && ymin <= ymax + +{-# INLINE eqMBR #-} +-- | Check whether two rectangles are equal. +eqMBR :: MBR -> MBR -> Bool +eqMBR (MBR xmin ymin xmax ymax) (MBR xmin' ymin' xmax' ymax') = + xmin == xmin' && ymin == ymin' && xmax == xmax' && ymax == ymax' + + +{-# INLINE unionMBR #-} +-- | Resulting rectangle contains both input rectangles. +unionMBR :: MBR -> MBR -> MBR +unionMBR (MBR xmin ymin xmax ymax) (MBR xmin' ymin' xmax' ymax') = + MBR (min xmin xmin') (min ymin ymin') (max xmax xmax') (max ymax ymax') + + +{-# INLINE areaMBR #-} +-- | Proper area. +areaMBR :: MBR -> Double +areaMBR (MBR xmin ymin xmax ymax) = (xmax - xmin) * (ymax - ymin) + +{-# INLINE marginMBR #-} +-- | Half a perimeter. +marginMBR :: MBR -> Double +marginMBR (MBR xmin ymin xmax ymax) = (xmax - xmin) + (ymax - ymin) + +{-# INLINE overlapMBR #-} +overlapMBR :: MBR -> MBR -> Double +overlapMBR = + intersectionMBR_ $ \x y x' y' -> + if x < x' && y < y' + then areaMBR (MBR x y x' y') + else 0 + + +{-# INLINE distanceMBR #-} +-- | Square distance between double the centers of two rectangles. +distanceMBR :: MBR -> MBR -> Double +distanceMBR (MBR xmin ymin xmax ymax) (MBR xmin' ymin' xmax' ymax') = + let x = (xmax' + xmin') - (xmax + xmin) + y = (ymax' + ymin') - (ymax + ymin) + in x * x + y * y + + +{-# INLINE containsMBR #-} +-- | Whether left rectangle contains right one. +containsMBR :: MBR -> MBR -> Bool +containsMBR (MBR xmin ymin xmax ymax) (MBR xmin' ymin' xmax' ymax') = + xmin <= xmin' && ymin <= ymin' && xmax >= xmax' && ymax >= ymax' + +{-# INLINE containsMBR' #-} +-- | Whether left rectangle contains right one without touching any of the sides. +containsMBR' :: MBR -> MBR -> Bool +containsMBR' (MBR xmin ymin xmax ymax) (MBR xmin' ymin' xmax' ymax') = + xmin < xmin' && ymin < ymin' && xmax > xmax' && ymax > ymax' + + + +{-# INLINE intersectionMBR #-} +-- | Intersection of two rectangles, if any exists. +intersectionMBR :: MBR -> MBR -> Maybe MBR +intersectionMBR = + intersectionMBR_ $ \x y x' y' -> + if x <= x' && y <= y' + then Just (MBR x y x' y') + else Nothing + +{-# INLINE intersectionMBR' #-} +-- | Intersection of two rectangles, if any exists, excluding the side cases where +-- the result would be a point or a line. +intersectionMBR' :: MBR -> MBR -> Maybe MBR +intersectionMBR' = + intersectionMBR_ $ \x y x' y' -> + if x < x' && y < y' + then Just (MBR x y x' y') + else Nothing + +{-# INLINE intersectionMBR_ #-} +intersectionMBR_ :: (Double -> Double -> Double -> Double -> a) -> MBR -> MBR -> a +intersectionMBR_ f (MBR xmin ymin xmax ymax) (MBR xmin' ymin' xmax' ymax') = + let x = max xmin xmin' + y = max ymin ymin' + x' = min xmax xmax' + y' = min ymax ymax' + + in f x y x' y' + +{-# INLINE intersectsMBR #-} +intersectsMBR :: MBR -> MBR -> Bool +intersectsMBR = intersectionMBR_ $ \x y x' y' -> x <= x' && y <= y' + +{-# INLINE intersectsMBR' #-} +intersectsMBR' :: MBR -> MBR -> Bool +intersectsMBR' = intersectionMBR_ $ \x y x' y' -> x < x' && y < y' + + + +-- | Comparison function. +data Predicate = Predicate + (MBR -> Bool) -- ^ Matches nodes + (MBR -> Bool) -- ^ Matches leaves + +{-# INLINE equals #-} +-- | Matches exactly the provided t'MBR'. +equals :: MBR -> Predicate +equals bx = Predicate (\ba -> containsMBR ba bx) (eqMBR bx) + +{-# INLINE intersects #-} +-- | Matches any t'MBR' that intersects the provided one. +intersects:: MBR -> Predicate +intersects bx = Predicate (intersectsMBR bx) (intersectsMBR bx) + +{-# INLINE intersects' #-} +-- | Matches any t'MBR' that intersects the provided one, if the +-- intersection is not a line or a point. +intersects' :: MBR -> Predicate +intersects' bx = Predicate (intersectsMBR' bx) (intersectsMBR' bx) + +{-# INLINE contains #-} +-- | Matches any t'MBR' that contains the provided one. +contains :: MBR -> Predicate +contains bx = Predicate (\ba -> containsMBR ba bx) (\ba -> containsMBR ba bx) + +{-# INLINE contains' #-} +-- | Matches any t'MBR' that contains the provided one, +-- excluding ones that touch it on one or more sides. +contains' :: MBR -> Predicate +contains' bx = Predicate (\ba -> containsMBR ba bx) (\ba -> containsMBR' ba bx) + +{-# INLINE containedBy #-} +-- | Matches any t'MBR' that is contained within the provided one. +containedBy :: MBR -> Predicate +containedBy bx = Predicate (intersectsMBR bx) (containsMBR bx) + +{-# INLINE containedBy' #-} +-- | Matches any t'MBR' that is contained within the provided one, +-- excluding ones that touch it on one or more sides. +containedBy' :: MBR -> Predicate +containedBy' bx = Predicate (intersectsMBR bx) (containsMBR' bx) + + + +instance Show a => Show (R2Tree a) where + showsPrec = liftShowsPrec showsPrec showList + +instance Show1 R2Tree where + liftShowsPrec showsPrec_ showList_ t r = + showParen (t > 10) $ + showListWith (liftShowsPrec showsPrec_ showList_ 0) $ + foldrWithKey (\k a -> (:) (k, a)) [] r + +instance Eq a => Eq (R2Tree a) where + (==) = liftEq (==) + +instance Eq1 R2Tree where + liftEq f = go + where + {-# INLINE node #-} + node ba a bb b = eqMBR ba bb && go a b + + {-# INLINE leaf #-} + leaf ba a bb b = eqMBR ba bb && f a b + + go m n = + case m of + Node2 ba a bb b -> + case n of + Node2 be e bg g -> node ba a be e && node bb b bg g + _ -> False + + Node3 ba a bb b bc c -> + case n of + Node3 be e bg g bh h -> node ba a be e && node bb b bg g && node bc c bh h + _ -> False + + Node4 ba a bb b bc c bd d -> + case n of + Node4 be e bg g bh h bi i -> + node ba a be e && node bb b bg g && node bc c bh h && node bd d bi i + + _ -> False + + Leaf2 ba a bb b -> + case n of + Leaf2 be e bg g -> leaf ba a be e && leaf bb b bg g + _ -> False + + Leaf3 ba a bb b bc c -> + case n of + Leaf3 be e bg g bh h -> leaf ba a be e && leaf bb b bg g && leaf bc c bh h + _ -> False + + Leaf4 ba a bb b bc c bd d -> + case n of + Leaf4 be e bg g bh h bi i -> + leaf ba a be e && leaf bb b bg g && leaf bc c bh h && leaf bd d bi i + + _ -> False + + Leaf1 ba a -> + case n of + Leaf1 bb b -> eqMBR ba bb && f a b + _ -> False + + Empty -> + case n of + Empty -> True + _ -> False + + + +instance NFData a => NFData (R2Tree a) where + rnf = liftRnf rnf + +instance NFData1 R2Tree where + liftRnf f = go + where + go n = + case n of + Node2 _ a _ b -> go a `seq` go b + Node3 _ a _ b _ c -> go a `seq` go b `seq` go c + Node4 _ a _ b _ c _ d -> go a `seq` go b `seq` go c `seq` go d + + Leaf2 _ a _ b -> f a `seq` f b + Leaf3 _ a _ b _ c -> f a `seq` f b `seq` f c + Leaf4 _ a _ b _ c _ d -> f a `seq` f b `seq` f c `seq` f d + + Leaf1 _ a -> f a + Empty -> () + + + +-- | Uses 'Data.R2Tree.Double.map'. +instance Functor R2Tree where + fmap = Data.R2Tree.Double.Internal.map + +instance Foldable R2Tree where + foldl = Data.R2Tree.Double.Internal.foldl + + foldr = Data.R2Tree.Double.Internal.foldr + + foldMap = Data.R2Tree.Double.Internal.foldMap + + foldl' = Data.R2Tree.Double.Internal.foldl' + + foldr' = Data.R2Tree.Double.Internal.foldr' + + null = Data.R2Tree.Double.Internal.null + + length = size + + +instance Traversable R2Tree where + traverse = Data.R2Tree.Double.Internal.traverse + + + +-- | Spine-strict two-dimensional R-tree. +data R2Tree a = Node2 {-# UNPACK #-} !MBR !(R2Tree a) {-# UNPACK #-} !MBR !(R2Tree a) + | Node3 {-# UNPACK #-} !MBR !(R2Tree a) {-# UNPACK #-} !MBR !(R2Tree a) {-# UNPACK #-} !MBR !(R2Tree a) + | Node4 {-# UNPACK #-} !MBR !(R2Tree a) {-# UNPACK #-} !MBR !(R2Tree a) {-# UNPACK #-} !MBR !(R2Tree a) {-# UNPACK #-} !MBR !(R2Tree a) + + | Leaf2 {-# UNPACK #-} !MBR a {-# UNPACK #-} !MBR a + | Leaf3 {-# UNPACK #-} !MBR a {-# UNPACK #-} !MBR a {-# UNPACK #-} !MBR a + | Leaf4 {-# UNPACK #-} !MBR a {-# UNPACK #-} !MBR a {-# UNPACK #-} !MBR a {-# UNPACK #-} !MBR a + + -- | Invariant: only allowed as the root node. + | Leaf1 {-# UNPACK #-} !MBR a + + -- | Invariant: only allowed as the root node. + | Empty + + + +-- | \(\mathcal{O}(1)\). +-- Check if the tree is empty. +null :: R2Tree a -> Bool +null Empty = True +null _ = False + +-- | \(\mathcal{O}(n)\). +-- Calculate the number of elements stored in the tree. +-- The returned number is guaranteed to be non-negative. +size :: R2Tree a -> Int +size = go + where + go n = + case n of + Node2 _ a _ b -> let !w = go a + !x = go b + + in w + x + + Node3 _ a _ b _ c -> let !w = go a + !x = go b + !y = go c + + in w + x + y + + Node4 _ a _ b _ c _ d -> let !w = go a + !x = go b + !y = go c + !z = go d + + in w + x + y + z + + Leaf2 _ _ _ _ -> 2 + Leaf3 _ _ _ _ _ _ -> 3 + Leaf4 _ _ _ _ _ _ _ _ -> 4 + + Leaf1 _ _ -> 1 + Empty -> 0 + + + +-- | \(\mathcal{O}(n)\). +-- Map a function over all values. +map :: (a -> b) -> R2Tree a -> R2Tree b +map f = go + where + go n = + case n of + Node2 ba a bb b -> + Node2 ba (go a) bb (go b) + + Node3 ba a bb b bc c -> + Node3 ba (go a) bb (go b) bc (go c) + + Node4 ba a bb b bc c bd d -> + Node4 ba (go a) bb (go b) bc (go c) bd (go d) + + Leaf2 ba a bb b -> + Leaf2 ba (f a) bb (f b) + + Leaf3 ba a bb b bc c -> + Leaf3 ba (f a) bb (f b) bc (f c) + + Leaf4 ba a bb b bc c bd d -> + Leaf4 ba (f a) bb (f b) bc (f c) bd (f d) + + Leaf1 ba a -> + Leaf1 ba (f a) + + Empty -> Empty + +-- | \(\mathcal{O}(n)\). +-- Map a function over all values and evaluate the results to WHNF. +map' :: (a -> b) -> R2Tree a -> R2Tree b +map' f = go + where + go n = + case n of + Node2 ba a bb b -> + Node2 ba (go a) bb (go b) + + Node3 ba a bb b bc c -> + Node3 ba (go a) bb (go b) bc (go c) + + Node4 ba a bb b bc c bd d -> + Node4 ba (go a) bb (go b) bc (go c) bd (go d) + + Leaf2 ba a bb b -> + let !a' = f a + !b' = f b + + in Leaf2 ba a' bb b' + + Leaf3 ba a bb b bc c -> + let !a' = f a + !b' = f b + !c' = f c + + in Leaf3 ba a' bb b' bc c' + + Leaf4 ba a bb b bc c bd d -> + let !a' = f a + !b' = f b + !c' = f c + !d' = f d + + in Leaf4 ba a' bb b' bc c' bd d' + + Leaf1 ba a -> + Leaf1 ba $! f a + + Empty -> Empty + + +-- | \(\mathcal{O}(n)\). +-- Map a function over all t'MBR's and their respective values. +mapWithKey :: (MBR -> a -> b) -> R2Tree a -> R2Tree b +mapWithKey f = go + where + go n = + case n of + Node2 ba a bb b -> + Node2 ba (go a) bb (go b) + + Node3 ba a bb b bc c -> + Node3 ba (go a) bb (go b) bc (go c) + + Node4 ba a bb b bc c bd d -> + Node4 ba (go a) bb (go b) bc (go c) bd (go d) + + Leaf2 ba a bb b -> + Leaf2 ba (f ba a) bb (f bb b) + + Leaf3 ba a bb b bc c -> + Leaf3 ba (f ba a) bb (f bb b) bc (f bc c) + + Leaf4 ba a bb b bc c bd d -> + Leaf4 ba (f ba a) bb (f bb b) bc (f bc c) bd (f bd d) + + Leaf1 ba a -> + Leaf1 ba (f ba a) + + Empty -> Empty + +-- | \(\mathcal{O}(n)\). +-- Map a function over all t'MBR's and their respective values +-- and evaluate the results to WHNF. +mapWithKey' :: (MBR -> a -> b) -> R2Tree a -> R2Tree b +mapWithKey' f = go + where + go n = + case n of + Node2 ba a bb b -> + Node2 ba (go a) bb (go b) + + Node3 ba a bb b bc c -> + Node3 ba (go a) bb (go b) bc (go c) + + Node4 ba a bb b bc c bd d -> + Node4 ba (go a) bb (go b) bc (go c) bd (go d) + + Leaf2 ba a bb b -> + let !a' = f ba a + !b' = f bb b + + in Leaf2 ba a' bb b' + + Leaf3 ba a bb b bc c -> + let !a' = f ba a + !b' = f bb b + !c' = f bc c + + in Leaf3 ba a' bb b' bc c' + + Leaf4 ba a bb b bc c bd d -> + let !a' = f ba a + !b' = f bb b + !c' = f bc c + !d' = f bd d + + in Leaf4 ba a' bb b' bc c' bd d' + + Leaf1 ba a -> + Leaf1 ba $! f ba a + + Empty -> Empty + + + +{-# INLINE adjustRangeWithKey #-} +-- | \(\mathcal{O}(\log n + n_I)\). +-- Map a function over t'MBR's that match the 'Predicate' and their respective values. +adjustRangeWithKey :: Predicate -> (MBR -> a -> a) -> R2Tree a -> R2Tree a +adjustRangeWithKey (Predicate nodePred leafPred) f = go + where + {-# INLINE node #-} + node bx x + | nodePred bx = go x + | otherwise = x + + {-# INLINE leaf #-} + leaf bx x + | leafPred bx = f bx x + | otherwise = x + + go n = + case n of + Node2 ba a bb b -> + Node2 ba (node ba a) bb (node bb b) + + Node3 ba a bb b bc c -> + Node3 ba (node ba a) bb (node bb b) bc (node bc c) + + Node4 ba a bb b bc c bd d -> + Node4 ba (node ba a) bb (node bb b) bc (node bc c) bd (node bd d) + + Leaf2 ba a bb b -> + Leaf2 ba (leaf ba a) bb (leaf bb b) + + Leaf3 ba a bb b bc c -> + Leaf3 ba (leaf ba a) bb (leaf bb b) bc (leaf bc c) + + Leaf4 ba a bb b bc c bd d -> + Leaf4 ba (leaf ba a) bb (leaf bb b) bc (leaf bc c) bd (leaf bd d) + + Leaf1 ba a -> + Leaf1 ba (leaf ba a) + + Empty -> Empty + +{-# INLINE adjustRangeWithKey' #-} +-- | \(\mathcal{O}(\log n + n_I)\). +-- Map a function over t'MBR's that match the 'Predicate' and their respective values +-- and evaluate the results to WHNF. +adjustRangeWithKey' :: Predicate -> (MBR -> a -> a) -> R2Tree a -> R2Tree a +adjustRangeWithKey' (Predicate nodePred leafPred) f = go + where + {-# INLINE node #-} + node bx x + | nodePred bx = go x + | otherwise = x + + {-# INLINE leaf #-} + leaf bx x + | leafPred bx = f bx x + | otherwise = x + + go n = + case n of + Node2 ba a bb b -> + Node2 ba (node ba a) bb (node bb b) + + Node3 ba a bb b bc c -> + Node3 ba (node ba a) bb (node bb b) bc (node bc c) + + Node4 ba a bb b bc c bd d -> + Node4 ba (node ba a) bb (node bb b) bc (node bc c) bd (node bd d) + + Leaf2 ba a bb b -> + let !a' = leaf ba a + !b' = leaf bb b + + in Leaf2 ba a' bb b' + + Leaf3 ba a bb b bc c -> + let !a' = leaf ba a + !b' = leaf bb b + !c' = leaf bc c + + in Leaf3 ba a' bb b' bc c' + + Leaf4 ba a bb b bc c bd d -> + let !a' = leaf ba a + !b' = leaf bb b + !c' = leaf bc c + !d' = leaf bd d + + in Leaf4 ba a' bb b' bc c' bd d' + + Leaf1 ba a -> + Leaf1 ba $! leaf ba a + + Empty -> Empty + + + +-- | \(\mathcal{O}(n_R)\). +-- Fold left-to-right over all values. +foldl :: (b -> a -> b) -> b -> R2Tree a -> b +foldl f = go + where + go z n = + case n of + Node2 _ a _ b -> go (go z a) b + Node3 _ a _ b _ c -> go (go (go z a) b) c + Node4 _ a _ b _ c _ d -> go (go (go (go z a) b) c) d + + Leaf2 _ a _ b -> f (f z a) b + Leaf3 _ a _ b _ c -> f (f (f z a) b) c + Leaf4 _ a _ b _ c _ d -> f (f (f (f z a) b) c) d + + Leaf1 _ a -> f z a + Empty -> z + +-- | \(\mathcal{O}(n)\). +-- Fold left-to-right over all values, applying the operator function strictly. +foldl' :: (b -> a -> b) -> b -> R2Tree a -> b +foldl' f = go + where + {-# INLINE leaf #-} + leaf !z x = f z x + + go !z n = + case n of + Node2 _ a _ b -> go (go z a) b + Node3 _ a _ b _ c -> go (go (go z a) b) c + Node4 _ a _ b _ c _ d -> go (go (go (go z a) b) c) d + + Leaf2 _ a _ b -> leaf (leaf z a) b + Leaf3 _ a _ b _ c -> leaf (leaf (leaf z a) b) c + Leaf4 _ a _ b _ c _ d -> leaf (leaf (leaf (leaf z a) b) c) d + + Leaf1 _ a -> leaf z a + Empty -> z + + +-- | \(\mathcal{O}(n_R)\). +-- Fold left-to-right over all t'MBR's and their respective values. +foldlWithKey :: (b -> MBR -> a -> b) -> b -> R2Tree a -> b +foldlWithKey f = go + where + go z n = + case n of + Node2 _ a _ b -> go (go z a) b + Node3 _ a _ b _ c -> go (go (go z a) b) c + Node4 _ a _ b _ c _ d -> go (go (go (go z a) b) c) d + + Leaf2 ba a bb b -> f (f z ba a) bb b + Leaf3 ba a bb b bc c -> f (f (f z ba a) bb b) bc c + Leaf4 ba a bb b bc c bd d -> f (f (f (f z ba a) bb b) bc c) bd d + + Leaf1 ba a -> f z ba a + Empty -> z + +-- | \(\mathcal{O}(n)\). +-- Fold left-to-right over all t'MBR's and their respective values, +-- applying the operator function strictly. +foldlWithKey' :: (b -> MBR -> a -> b) -> b -> R2Tree a -> b +foldlWithKey' f = go + where + {-# INLINE leaf #-} + leaf !z bx x = f z bx x + + go z n = + case n of + Node2 _ a _ b -> go (go z a) b + Node3 _ a _ b _ c -> go (go (go z a) b) c + Node4 _ a _ b _ c _ d -> go (go (go (go z a) b) c) d + + Leaf2 ba a bb b -> leaf (leaf z ba a) bb b + Leaf3 ba a bb b bc c -> leaf (leaf (leaf z ba a) bb b) bc c + Leaf4 ba a bb b bc c bd d -> leaf (leaf (leaf (leaf z ba a) bb b) bc c) bd d + + Leaf1 ba a -> leaf z ba a + Empty -> z + + +{-# INLINE foldlRangeWithKey #-} +-- | \(\mathcal{O}(\log n + n_{I_R})\). +-- Fold left-to-right over t'MBR's that match the 'Predicate' +-- and their respective values. +foldlRangeWithKey :: Predicate -> (b -> MBR -> a -> b) -> b -> R2Tree a -> b +foldlRangeWithKey (Predicate nodePred leafPred) f = go + where + {-# INLINE node #-} + node z bx x + | nodePred bx = go z x + | otherwise = z + + {-# INLINE leaf #-} + leaf z bx x + | leafPred bx = f z bx x + | otherwise = z + + go z n = + case n of + Node2 ba a bb b -> node (node z ba a) bb b + Node3 ba a bb b bc c -> node (node (node z ba a) bb b) bc c + Node4 ba a bb b bc c bd d -> node (node (node (node z ba a) bb b) bc c) bd d + + Leaf2 ba a bb b -> leaf (leaf z ba a) bb b + Leaf3 ba a bb b bc c -> leaf (leaf (leaf z ba a) bb b) bc c + Leaf4 ba a bb b bc c bd d -> leaf (leaf (leaf (leaf z ba a) bb b) bc c) bd d + + Leaf1 ba a -> leaf z ba a + Empty -> z + +{-# INLINE foldlRangeWithKey' #-} +-- | \(\mathcal{O}(\log n + n_I)\). +-- Fold left-to-right over t'MBR's that match the 'Predicate' +-- and their respective values, applying the operator function strictly. +foldlRangeWithKey' :: Predicate -> (b -> MBR -> a -> b) -> b -> R2Tree a -> b +foldlRangeWithKey' (Predicate nodePred leafPred) f = go + where + {-# INLINE node #-} + node z bx x + | nodePred bx = go z x + | otherwise = z + + {-# INLINE leaf #-} + leaf !z bx x + | leafPred bx = f z bx x + | otherwise = z + + go z n = + case n of + Node2 ba a bb b -> node (node z ba a) bb b + Node3 ba a bb b bc c -> node (node (node z ba a) bb b) bc c + Node4 ba a bb b bc c bd d -> node (node (node (node z ba a) bb b) bc c) bd d + + Leaf2 ba a bb b -> leaf (leaf z ba a) bb b + Leaf3 ba a bb b bc c -> leaf (leaf (leaf z ba a) bb b) bc c + Leaf4 ba a bb b bc c bd d -> leaf (leaf (leaf (leaf z ba a) bb b) bc c) bd d + + Leaf1 ba a -> leaf z ba a + Empty -> z + + + +-- | \(\mathcal{O}(n_L)\). +-- Fold right-to-left over all values. +foldr :: (a -> b -> b) -> b -> R2Tree a -> b +foldr f = go + where + go z n = + case n of + Node2 _ a _ b -> go (go z b) a + Node3 _ a _ b _ c -> go (go (go z c) b) a + Node4 _ a _ b _ c _ d -> go (go (go (go z d) c) b) a + + Leaf2 _ a _ b -> f a (f b z) + Leaf3 _ a _ b _ c -> f a (f b (f c z)) + Leaf4 _ a _ b _ c _ d -> f a (f b (f c (f d z))) + + Leaf1 _ a -> f a z + Empty -> z + +-- | \(\mathcal{O}(n)\). +-- Fold right-to-left over all values, applying the operator function strictly. +foldr' :: (a -> b -> b) -> b -> R2Tree a -> b +foldr' f = go + where + {-# INLINE leaf #-} + leaf x !z = f x z + + go z n = + case n of + Node2 _ a _ b -> go (go z b) a + Node3 _ a _ b _ c -> go (go (go z c) b) a + Node4 _ a _ b _ c _ d -> go (go (go (go z d) c) b) a + + Leaf2 _ a _ b -> leaf a (leaf b z) + Leaf3 _ a _ b _ c -> leaf a (leaf b (leaf c z)) + Leaf4 _ a _ b _ c _ d -> leaf a (leaf b (leaf c (leaf d z))) + + Leaf1 _ a -> leaf a z + Empty -> z + + +-- | \(\mathcal{O}(n_L)\). +-- Fold right-to-left over all t'MBR's and their respective values. +foldrWithKey :: (MBR -> a -> b -> b) -> b -> R2Tree a -> b +foldrWithKey f = go + where + go z n = + case n of + Node2 _ a _ b -> go (go z b) a + Node3 _ a _ b _ c -> go (go (go z c) b) a + Node4 _ a _ b _ c _ d -> go (go (go (go z d) c) b) a + + Leaf2 ba a bb b -> f ba a (f bb b z) + Leaf3 ba a bb b bc c -> f ba a (f bb b (f bc c z)) + Leaf4 ba a bb b bc c bd d -> f ba a (f bb b (f bc c (f bd d z))) + + Leaf1 ba a -> f ba a z + Empty -> z + +-- | \(\mathcal{O}(n)\). +-- Fold right-to-left over all t'MBR's and their respective values, +-- applying the operator function strictly. +foldrWithKey' :: (MBR -> a -> b -> b) -> b -> R2Tree a -> b +foldrWithKey' f = go + where + {-# INLINE leaf #-} + leaf bx x !z = f bx x z + + go z n = + case n of + Node2 _ a _ b -> go (go z b) a + Node3 _ a _ b _ c -> go (go (go z c) b) a + Node4 _ a _ b _ c _ d -> go (go (go (go z d) c) b) a + + Leaf2 ba a bb b -> leaf ba a (leaf bb b z) + Leaf3 ba a bb b bc c -> leaf ba a (leaf bb b (leaf bc c z)) + Leaf4 ba a bb b bc c bd d -> leaf ba a (leaf bb b (leaf bc c (leaf bd d z))) + + Leaf1 ba a -> leaf ba a z + Empty -> z + + +{-# INLINE foldrRangeWithKey #-} +-- | \(\mathcal{O}(\log n + n_{I_L})\). +-- Fold right-to-left over t'MBR's that match the 'Predicate' +-- and their respective values. +foldrRangeWithKey :: Predicate -> (MBR -> a -> b -> b) -> b -> R2Tree a -> b +foldrRangeWithKey (Predicate nodePred leafPred) f = go + where + {-# INLINE node #-} + node z bx x + | nodePred bx = go z x + | otherwise = z + + {-# INLINE leaf #-} + leaf bx x z + | leafPred bx = f bx x z + | otherwise = z + + go z n = + case n of + Node2 ba a bb b -> node (node z bb b) ba a + Node3 ba a bb b bc c -> node (node (node z bc c) bb b) ba a + Node4 ba a bb b bc c bd d -> node (node (node (node z bd d) bc c) bb b) ba a + + Leaf2 ba a bb b -> leaf ba a (leaf bb b z) + Leaf3 ba a bb b bc c -> leaf ba a (leaf bb b (leaf bc c z)) + Leaf4 ba a bb b bc c bd d -> leaf ba a (leaf bb b (leaf bc c (leaf bd d z))) + + Leaf1 ba a -> leaf ba a z + Empty -> z + +{-# INLINE foldrRangeWithKey' #-} +-- | \(\mathcal{O}(\log n + n_I)\). +-- Fold right-to-left over t'MBR's that match the 'Predicate' +-- and their respective values, applying the operator function strictly. +foldrRangeWithKey' :: Predicate -> (MBR -> a -> b -> b) -> b -> R2Tree a -> b +foldrRangeWithKey' (Predicate nodePred leafPred) f = go + where + {-# INLINE node #-} + node z bx x + | nodePred bx = go z x + | otherwise = z + + {-# INLINE leaf #-} + leaf bx x !z + | leafPred bx = f bx x z + | otherwise = z + + go z n = + case n of + Node2 ba a bb b -> node (node z bb b) ba a + Node3 ba a bb b bc c -> node (node (node z bc c) bb b) ba a + Node4 ba a bb b bc c bd d -> node (node (node (node z bd d) bc c) bb b) ba a + + Leaf2 ba a bb b -> leaf ba a (leaf bb b z) + Leaf3 ba a bb b bc c -> leaf ba a (leaf bb b (leaf bc c z)) + Leaf4 ba a bb b bc c bd d -> leaf ba a (leaf bb b (leaf bc c (leaf bd d z))) + + Leaf1 ba a -> leaf ba a z + Empty -> z + + + +-- | \(\mathcal{O}(n_M)\). +-- Map each value to a monoid and combine the results. +foldMap :: Monoid m => (a -> m) -> R2Tree a -> m +foldMap f = go + where + go n = + case n of + Node2 _ a _ b -> go a <> go b + Node3 _ a _ b _ c -> go a <> go b <> go c + Node4 _ a _ b _ c _ d -> go a <> go b <> go c <> go d + + Leaf2 _ a _ b -> f a <> f b + Leaf3 _ a _ b _ c -> f a <> f b <> f c + Leaf4 _ a _ b _ c _ d -> f a <> f b <> f c <> f d + + Leaf1 _ a -> f a + Empty -> mempty + + +-- | \(\mathcal{O}(n_M)\). +-- Map each t'MBR' and its respective value to a monoid and combine the results. +foldMapWithKey :: Monoid m => (MBR -> a -> m) -> R2Tree a -> m +foldMapWithKey f = go + where + go n = + case n of + Node2 _ a _ b -> go a <> go b + Node3 _ a _ b _ c -> go a <> go b <> go c + Node4 _ a _ b _ c _ d -> go a <> go b <> go c <> go d + + Leaf2 ba a bb b -> f ba a <> f bb b + Leaf3 ba a bb b bc c -> f ba a <> f bb b <> f bc c + Leaf4 ba a bb b bc c bd d -> f ba a <> f bb b <> f bc c <> f bd d + + Leaf1 ba a -> f ba a + Empty -> mempty + + +{-# INLINE foldMapRangeWithKey #-} +-- | \(\mathcal{O}(\log n + n_{I_M})\). +-- Map each t'MBR' that matches the 'Predicate' and its respective value to a monoid +-- and combine the results. +foldMapRangeWithKey :: Monoid m => Predicate -> (MBR -> a -> m) -> R2Tree a -> m +foldMapRangeWithKey (Predicate nodePred leafPred) f = go + where + {-# INLINE node #-} + node bx x + | nodePred bx = go x + | otherwise = mempty + + {-# INLINE leaf #-} + leaf bx x + | leafPred bx = f bx x + | otherwise = mempty + + go n = + case n of + Node2 ba a bb b -> node ba a <> node bb b + Node3 ba a bb b bc c -> node ba a <> node bb b <> node bc c + Node4 ba a bb b bc c bd d -> node ba a <> node bb b <> node bc c <> node bd d + + Leaf2 ba a bb b -> leaf ba a <> leaf bb b + Leaf3 ba a bb b bc c -> leaf ba a <> leaf bb b <> leaf bc c + Leaf4 ba a bb b bc c bd d -> leaf ba a <> leaf bb b <> leaf bc c <> leaf bd d + + Leaf1 ba a -> leaf ba a + Empty -> mempty + + + +-- | \(\mathcal{O}(n)\). +-- Map each value to an action, evaluate the actions left-to-right and +-- collect the results. +traverse :: Applicative f => (a -> f b) -> R2Tree a -> f (R2Tree b) +traverse f = go + where + go n = + case n of + Node2 ba a bb b -> + liftA2 (\a' b' -> Node2 ba a' bb b') + (go a) (go b) + + Node3 ba a bb b bc c -> + liftA2 (\a' b' c' -> Node3 ba a' bb b' bc c') + (go a) (go b) <*> go c + + Node4 ba a bb b bc c bd d -> + liftA2 (\a' b' c' d' -> Node4 ba a' bb b' bc c' bd d') + (go a) (go b) <*> go c <*> go d + + Leaf2 ba a bb b -> + liftA2 (\a' b' -> Leaf2 ba a' bb b') + (f a) (f b) + + Leaf3 ba a bb b bc c -> + liftA2 (\a' b' c' -> Leaf3 ba a' bb b' bc c') + (f a) (f b) <*> f c + + Leaf4 ba a bb b bc c bd d -> + liftA2 (\a' b' c' d' -> Leaf4 ba a' bb b' bc c' bd d') + (f a) (f b) <*> f c <*> f d + + Leaf1 ba a -> + Leaf1 ba <$> f a + + Empty -> pure Empty + + +-- | \(\mathcal{O}(n)\). +-- Map each t'MBR' and its respective value to an action, +-- evaluate the actions left-to-right and collect the results. +traverseWithKey :: Applicative f => (MBR -> a -> f b) -> R2Tree a -> f (R2Tree b) +traverseWithKey f = go + where + go n = + case n of + Node2 ba a bb b -> + liftA2 (\a' b' -> Node2 ba a' bb b') + (go a) (go b) + + Node3 ba a bb b bc c -> + liftA2 (\a' b' c' -> Node3 ba a' bb b' bc c') + (go a) (go b) <*> go c + + Node4 ba a bb b bc c bd d -> + liftA2 (\a' b' c' d' -> Node4 ba a' bb b' bc c' bd d') + (go a) (go b) <*> go c <*> go d + + Leaf2 ba a bb b -> + liftA2 (\a' b' -> Leaf2 ba a' bb b') + (f ba a) (f bb b) + + Leaf3 ba a bb b bc c -> + liftA2 (\a' b' c' -> Leaf3 ba a' bb b' bc c') + (f ba a) (f bb b) <*> f bc c + + Leaf4 ba a bb b bc c bd d -> + liftA2 (\a' b' c' d' -> Leaf4 ba a' bb b' bc c' bd d') + (f ba a) (f bb b) <*> f bc c <*> f bd d + + Leaf1 ba a -> + Leaf1 ba <$> f ba a + + Empty -> pure Empty + + +{-# INLINE traverseRangeWithKey #-} +-- | \(\mathcal{O}(\log n + n_I)\). +-- Map each t'MBR' that matches the 'Predicate' and its respective value to an action, +-- evaluate the actions left-to-right and collect the results. +traverseRangeWithKey + :: Applicative f => Predicate -> (MBR -> a -> f a) -> R2Tree a -> f (R2Tree a) +traverseRangeWithKey (Predicate nodePred leafPred) f = go + where + {-# INLINE node #-} + node bx x + | nodePred bx = go x + | otherwise = pure x + + {-# INLINE leaf #-} + leaf bx x + | leafPred bx = f bx x + | otherwise = pure x + + go n = + case n of + Node2 ba a bb b -> + liftA2 (\a' b' -> Node2 ba a' bb b') + (node ba a) (node bb b) + + Node3 ba a bb b bc c -> + liftA2 (\a' b' c' -> Node3 ba a' bb b' bc c') + (node ba a) (node bb b) <*> node bc c + + Node4 ba a bb b bc c bd d -> + liftA2 (\a' b' c' d' -> Node4 ba a' bb b' bc c' bd d') + (node ba a) (node bb b) <*> node bc c <*> node bd d + + Leaf2 ba a bb b -> + liftA2 (\a' b' -> Leaf2 ba a' bb b') + (leaf ba a) (leaf bb b) + + Leaf3 ba a bb b bc c -> + liftA2 (\a' b' c' -> Leaf3 ba a' bb b' bc c') + (leaf ba a) (leaf bb b) <*> leaf bc c + + Leaf4 ba a bb b bc c bd d -> + liftA2 (\a' b' c' d' -> Leaf4 ba a' bb b' bc c' bd d') + (leaf ba a) (leaf bb b) <*> leaf bc c <*> leaf bd d + + Leaf1 ba a -> + Leaf1 ba <$> leaf ba a + + Empty -> pure Empty + + + +{-# INLINE union3MBR #-} +union3MBR :: MBR -> MBR -> MBR -> MBR +union3MBR ba bb bc = unionMBR (unionMBR ba bb) bc + +{-# INLINE union4MBR #-} +union4MBR :: MBR -> MBR -> MBR -> MBR -> MBR +union4MBR ba bb bc bd = unionMBR (unionMBR ba bb) (unionMBR bc bd) + + + +data Gut a = GutOne MBR (R2Tree a) + | GutTwo MBR (R2Tree a) MBR (R2Tree a) + +-- | \(\mathcal{O}(\log n)\). Insert a value into the tree. +-- +-- 'insertGut' uses the R-tree insertion algorithm with quadratic-cost splits. +-- Compared to 'insert' the resulting trees are of lower quality (see the +-- [Wikipedia article](https://en.wikipedia.org/w/index.php?title=R*-tree&oldid=1171720351#Performance) +-- for a graphic example). +insertGut :: MBR -> a -> R2Tree a -> R2Tree a +insertGut bx x t = + case insertGutRoot bx x t of + GutOne _ o -> o + GutTwo bl l br r -> Node2 bl l br r + + +insertGutRoot :: MBR -> a -> R2Tree a -> Gut a +insertGutRoot bx x n = + case n of + Node2 ba a bb b -> + let !(# be, e, !bz, !z #) = leastEnlargement2 bx ba a bb b + in case insertGut_ bx x be e of + GutOne bo o -> + GutOne (unionMBR bo bz) (Node2 bo o bz z) + + GutTwo bl l br r -> + GutOne (union3MBR bl br bz) (Node3 bl l br r bz z) + + Node3 ba a bb b bc c -> + let !(# be, e, !by, !y, !bz, !z #) = leastEnlargement3 bx ba a bb b bc c + in case insertGut_ bx x be e of + GutOne bo o -> + GutOne (union3MBR bo by bz) (Node3 bo o by y bz z) + + GutTwo bl l br r -> + GutOne (union4MBR bl br by bz) (Node4 bl l br r by y bz z) + + Node4 ba a bb b bc c bd d -> + let !(# be, e, !bw, !w, !by, !y, !bz, !z #) = leastEnlargement4 bx ba a bb b bc c bd d + in case insertGut_ bx x be e of + GutOne bo o -> + GutOne (union4MBR bo bw by bz) (Node4 bo o bw w by y bz z) + + GutTwo bl l br r -> + case quadSplit bl l br r bw w by y bz z of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bq q bs s) -> + GutTwo bl' (Node3 bm m bo o bp p) br' (Node2 bq q bs s) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bq q bs s) -> + GutTwo bl' (Node2 bm m bo o) br' (Node3 bp p bq q bs s) + + Leaf2 ba a bb b -> + GutOne (union3MBR ba bb bx) (Leaf3 ba a bb b bx x) + + Leaf3 ba a bb b bc c -> + GutOne (union4MBR ba bb bc bx) (Leaf4 ba a bb b bc c bx x) + + Leaf4 ba a bb b bc c bd d -> + case quadSplit ba a bb b bc c bd d bx x of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bq q bs s) -> + GutTwo bl' (Leaf3 bm m bo o bp p) br' (Leaf2 bq q bs s) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bq q bs s) -> + GutTwo bl' (Leaf2 bm m bo o) br' (Leaf3 bp p bq q bs s) + + Leaf1 ba a -> + GutOne (unionMBR ba bx) (Leaf2 ba a bx x) + + Empty -> + GutOne bx (Leaf1 bx x) + + +insertGut_ :: MBR -> a -> MBR -> R2Tree a -> Gut a +insertGut_ bx x = go + where + go bn n = + case n of + Node2 ba a bb b -> + let !(# be, e, !bz, !z #) = leastEnlargement2 bx ba a bb b + in case go be e of + GutOne bo o -> + GutOne (unionMBR bo bz) (Node2 bo o bz z) + + GutTwo bl l br r -> + GutOne (union3MBR bl br bz) (Node3 bl l br r bz z) + + Node3 ba a bb b bc c -> + let !(# be, e, !by, !y, !bz, !z #) = leastEnlargement3 bx ba a bb b bc c + in case go be e of + GutOne bo o -> + GutOne (union3MBR bo by bz) (Node3 bo o by y bz z) + + GutTwo bl l br r -> + GutOne (union4MBR bl br by bz) (Node4 bl l br r by y bz z) + + Node4 ba a bb b bc c bd d -> + let !(# be, e, !bw, !w, !by, !y, !bz, !z #) = leastEnlargement4 bx ba a bb b bc c bd d + in case go be e of + GutOne bo o -> + GutOne (union4MBR bo bw by bz) (Node4 bo o bw w by y bz z) + + GutTwo bl l br r -> + case quadSplit bl l br r bw w by y bz z of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bq q bs s) -> + GutTwo bl' (Node3 bm m bo o bp p) br' (Node2 bq q bs s) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bq q bs s) -> + GutTwo bl' (Node2 bm m bo o) br' (Node3 bp p bq q bs s) + + Leaf2 ba a bb b -> + GutOne (unionMBR bn bx) (Leaf3 ba a bb b bx x) + + Leaf3 ba a bb b bc c -> + GutOne (unionMBR bn bx) (Leaf4 ba a bb b bc c bx x) + + Leaf4 ba a bb b bc c bd d -> + case quadSplit ba a bb b bc c bd d bx x of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bq q bs s) -> + GutTwo bl' (Leaf3 bm m bo o bp p) br' (Leaf2 bq q bs s) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bq q bs s) -> + GutTwo bl' (Leaf2 bm m bo o) br' (Leaf3 bp p bq q bs s) + + Leaf1 ba a -> + GutOne (unionMBR ba bn) (Leaf2 ba a bx x) + + Empty -> + GutOne bn (Leaf1 bx x) + + + +insertGutRootNode :: MBR -> R2Tree a -> Int -> R2Tree a -> Gut a +insertGutRootNode bx x depth n = + case n of + Node2 ba a bb b + | depth <= 0 -> + GutOne (union3MBR ba bb bx) (Node3 ba a bb b bx x) + + | otherwise -> + let !(# be, e, !bz, !z #) = leastEnlargement2 bx ba a bb b + in case insertGutNode bx x (depth - 1) be e of + GutOne bo o -> + GutOne (unionMBR bo bz) (Node2 bo o bz z) + + GutTwo bl l br r -> + GutOne (union3MBR bl br bz) (Node3 bl l br r bz z) + + Node3 ba a bb b bc c + | depth <= 0 -> + GutOne (union4MBR ba bb bc bx) (Node4 ba a bb b bc c bx x) + + | otherwise -> + let !(# be, e, !by, !y, !bz, !z #) = leastEnlargement3 bx ba a bb b bc c + in case insertGutNode bx x (depth - 1) be e of + GutOne bo o -> + GutOne (union3MBR bo by bz) (Node3 bo o by y bz z) + + GutTwo bl l br r -> + GutOne (union4MBR bl br by bz) (Node4 bl l br r by y bz z) + + Node4 ba a bb b bc c bd d + | depth <= 0 -> + case quadSplit ba a bb b bc c bd d bx x of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bq q bs s) -> + GutTwo bl' (Node3 bm m bo o bp p) br' (Node2 bq q bs s) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bq q bs s) -> + GutTwo bl' (Node2 bm m bo o) br' (Node3 bp p bq q bs s) + + | otherwise -> + let !(# be, e, !bw, !w, !by, !y, !bz, !z #) = leastEnlargement4 bx ba a bb b bc c bd d + in case insertGutNode bx x (depth - 1) be e of + GutOne bo o -> + GutOne (union4MBR bo bw by bz) (Node4 bo o bw w by y bz z) + + GutTwo bl l br r -> + case quadSplit bl l br r bw w by y bz z of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bq q bs s) -> + GutTwo bl' (Node3 bm m bo o bp p) br' (Node2 bq q bs s) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bq q bs s) -> + GutTwo bl' (Node2 bm m bo o) br' (Node3 bp p bq q bs s) + + _ -> errorWithoutStackTrace "Data.R2Tree.Double.Internal.insertGutRootNode: reached a leaf" + +insertGutNode :: MBR -> R2Tree a -> Int -> MBR -> R2Tree a -> Gut a +insertGutNode bx x = go + where + go depth bn n = + case n of + Node2 ba a bb b + | depth <= 0 -> + GutOne (unionMBR bn bx) (Node3 ba a bb b bx x) + + | otherwise -> + let !(# be, e, !bz, !z #) = leastEnlargement2 bx ba a bb b + in case go (depth - 1) be e of + GutOne bo o -> + GutOne (unionMBR bo bz) (Node2 bo o bz z) + + GutTwo bl l br r -> + GutOne (union3MBR bl br bz) (Node3 bl l br r bz z) + + Node3 ba a bb b bc c + | depth <= 0 -> + GutOne (unionMBR bn bx) (Node4 ba a bb b bc c bx x) + + | otherwise -> + let !(# be, e, !by, !y, !bz, !z #) = leastEnlargement3 bx ba a bb b bc c + in case go (depth - 1) be e of + GutOne bo o -> + GutOne (union3MBR bo by bz) (Node3 bo o by y bz z) + + GutTwo bl l br r -> + GutOne (union4MBR bl br by bz) (Node4 bl l br r by y bz z) + + Node4 ba a bb b bc c bd d + | depth <= 0 -> + case quadSplit ba a bb b bc c bd d bx x of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bq q bs s) -> + GutTwo bl' (Node3 bm m bo o bp p) br' (Node2 bq q bs s) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bq q bs s) -> + GutTwo bl' (Node2 bm m bo o) br' (Node3 bp p bq q bs s) + + | otherwise -> + let !(# be, e, !bw, !w, !by, !y, !bz, !z #) = leastEnlargement4 bx ba a bb b bc c bd d + in case go (depth - 1) be e of + GutOne bo o -> + GutOne (union4MBR bo bw by bz) (Node4 bo o bw w by y bz z) + + GutTwo bl l br r -> + case quadSplit bl l br r bw w by y bz z of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bq q bs s) -> + GutTwo bl' (Node3 bm m bo o bp p) br' (Node2 bq q bs s) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bq q bs s) -> + GutTwo bl' (Node2 bm m bo o) br' (Node3 bp p bq q bs s) + + _ -> errorWithoutStackTrace "Data.R2Tree.Double.Internal.insertGutNode: reached a leaf" + + + +{-# INLINE enlargement #-} +-- as in (adding A to B) +enlargement :: MBR -> MBR -> Double +enlargement bx ba = areaMBR (unionMBR ba bx) - areaMBR ba + +leastEnlargement2 :: MBR -> MBR -> a -> MBR -> a -> (# MBR, a, MBR, a #) +leastEnlargement2 bx ba a bb b = + let aw = (# ba, a, bb, b #) + bw = (# bb, b, ba, a #) + + in case enlargement bx ba `compare` enlargement bx bb of + GT -> bw + LT -> aw + EQ | areaMBR ba <= areaMBR bb -> aw + | otherwise -> bw + +leastEnlargement3 + :: MBR -> MBR -> a -> MBR -> a -> MBR -> a -> (# MBR, a, MBR, a, MBR, a #) +leastEnlargement3 bx ba a bb b bc c = + let aw = let !(# be, e, by, y #) = leastEnlargement2 bx ba a bc c + in (# be, e, by, y, bb, b #) + + bw = let !(# be, e, by, y #) = leastEnlargement2 bx bb b bc c + in (# be, e, by, y, ba, a #) + + in case enlargement bx ba `compare` enlargement bx bb of + GT -> bw + LT -> aw + EQ | areaMBR ba <= areaMBR bb -> aw + | otherwise -> bw + +leastEnlargement4 + :: MBR -> MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a + -> (# MBR, a, MBR, a, MBR, a, MBR, a #) +leastEnlargement4 bx ba a bb b bc c bd d = + let !(# be, e, bn, n #) = leastEnlargement2 bx ba a bb b + !(# bf, f, bo, o #) = leastEnlargement2 bx bc c bd d + !(# bg, g, bp, p #) = leastEnlargement2 bx be e bf f + + in (# bg, g, bn, n, bo, o, bp, p #) + + + +data L2 a = L2 !MBR !MBR a !MBR a + +data L3 a = L3 !MBR !MBR a !MBR a !MBR a + +data Q1 a = Q1L !(L2 a) !MBR a + | Q1R !MBR a !(L2 a) + +data Q2 a = Q2L !(L3 a) !MBR a + | Q2M !(L2 a) !(L2 a) + | Q2R !MBR a !(L3 a) + +data Q3 a = Q3L !(L3 a) !(L2 a) + | Q3R !(L2 a) !(L3 a) + + + +quadSplit :: MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a -> Q3 a +quadSplit ba a bb b bc c bd d be e = + let !(# bl, l, br, r, bx, x, by, y, bz, z #) = pickSeeds ba a bb b bc c bd d be e + !(# q1, bv, v, bw, w #) = distribute3 bl l br r bx x by y bz z + !(# q2, bu, u #) = distribute2 q1 bv v bw w + + in distribute1 q2 bu u + + + +pickSeeds + :: MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a + -> (# MBR, a, MBR, a, MBR, a, MBR, a, MBR, a #) +pickSeeds ba a bb b bc c bd d be e = + let waste bx by = areaMBR (unionMBR bx by) - areaMBR bx - areaMBR by + + align x@(# bw, _, bx, _, _, _, _, _, _, _ #) + y@(# by, _, bz, _, _, _, _, _, _, _ #) + | waste bw bx > waste by bz = x + | otherwise = y + + in align (# ba, a, bb, b, bc, c, bd, d, be, e #) + ( align (# ba, a, bc, c, bb, b, bd, d, be, e #) + ( align (# ba, a, bd, d, bb, b, bc, c, be, e #) + ( align (# ba, a, be, e, bb, b, bc, c, bd, d #) + ( align (# bb, b, bc, c, ba, a, bd, d, be, e #) + ( align (# bb, b, bd, d, ba, a, bc, c, be, e #) + ( align (# bb, b, be, e, ba, a, bc, c, bd, d #) + ( align (# bc, c, bd, d, ba, a, bb, b, be, e #) + ( align (# bc, c, be, e, ba, a, bb, b, bd, d #) + (# bd, d, be, e, ba, a, bb, b, bc, c #) )))))))) + + + +distribute3 + :: MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a -> (# Q1 a, MBR, a, MBR, a #) +distribute3 bl l br r bx x by y bz z = + let delta ba = abs (enlargement ba bl - enlargement ba br) + + !(# be, !e, !bu, !u, !bv, !v #) = if delta bx >= delta by + then if delta bx >= delta bz + then (# bx, x, by, y, bz, z #) + else (# bz, z, bx, x, by, y #) + + else if delta by >= delta bz + then (# by, y, bx, x, bz, z #) + else (# bz, z, bx, x, by, y #) + + lw = Q1L (L2 (unionMBR bl be) bl l be e) br r + + rw = Q1R bl l (L2 (unionMBR br be) br r be e) + + !q1 = case enlargement be bl `compare` enlargement be br of + GT -> rw + LT -> lw + EQ | areaMBR bl < areaMBR br -> lw + | otherwise -> rw + + in (# q1, bu, u, bv, v #) + + + +distribute2 :: Q1 a -> MBR -> a -> MBR -> a -> (# Q2 a, MBR, a #) +distribute2 q bx x by y = + let delta bl br bd = abs (enlargement bd bl - enlargement bd br) + in case q of + Q1L l@(L2 bl ba a bb b) br r -> + let !(# be, !e, !bz, !z #) | delta bl br bx >= delta bl br by = (# bx, x, by, y #) + | otherwise = (# by, y, bx, x #) + + lw = Q2L (L3 (unionMBR bl be) ba a bb b be e) br r + + rw = Q2M l (L2 (unionMBR br be) br r be e) + + !q2 = case enlargement be bl `compare` enlargement be br of + GT -> rw + LT -> lw + EQ | areaMBR bl <= areaMBR br -> lw + | otherwise -> rw + + in (# q2, bz, z #) + + Q1R bl l r@(L2 br ba a bb b) -> + let !(# be, !e, !bz, !z #) | delta bl br bx >= delta bl br by = (# bx, x, by, y #) + | otherwise = (# by, y, bx, x #) + + lw = Q2M (L2 (unionMBR bl be) bl l be e) r + + rw = Q2R bl l (L3 (unionMBR br be) ba a bb b be e) + + !q2 = case enlargement be bl `compare` enlargement be br of + GT -> rw + LT -> lw + EQ | areaMBR bl <= areaMBR br -> lw + | otherwise -> rw + + in (# q2, bz, z #) + + +distribute1 :: Q2 a -> MBR -> a -> Q3 a +distribute1 q bx x = + case q of + Q2M l@(L2 bl ba a bb b) r@(L2 br bc c bd d) -> + let lw = Q3L (L3 (unionMBR bl bx) ba a bb b bx x) r + + rw = Q3R l (L3 (unionMBR br bx) bc c bd d bx x) + + in case enlargement bx bl `compare` enlargement bx br of + GT -> rw + LT -> lw + EQ | areaMBR bl <= areaMBR br -> lw + | otherwise -> rw + + Q2L l br r -> Q3L l (L2 (unionMBR br bx) br r bx x) + + Q2R bl l r -> Q3R (L2 (unionMBR bl bx) bl l bx x) r + + + +data Carry a = CarryLeaf MBR a + | CarryNode Int MBR (R2Tree a) + +data Ins a = InsOne MBR (R2Tree a) + | InsCarry Word (Carry a) MBR (R2Tree a) + | InsTwo Word MBR (R2Tree a) MBR (R2Tree a) + +-- | \(\mathcal{O}(\log n)\). Insert a value into the tree. +-- +-- 'insert' uses the R*-tree insertion algorithm. +insert :: MBR -> a -> R2Tree a -> R2Tree a +insert bx x n = + case n of + Node2 ba a bb b -> + let add f bg g bh h = + let !(# be, e, !bz, !z #) = leastEnlargement2 bx bg g bh h + in case f be e of + InsOne bo o -> Node2 bo o bz z + InsCarry mask carry bo o -> + case carry of + CarryLeaf bu u -> + add (insert_ mask bu u 0) bo o bz z + + CarryNode depth bu u -> + add (insertNode mask depth bu u 0) bo o bz z + + InsTwo _ bl l br r -> Node3 bl l br r bz z + + in add (insert_ 0 bx x 0) ba a bb b + + Node3 ba a bb b bc c -> + let add f bg g bh h bi i = + let !(# be, e, !by, !y, !bz, !z #) = leastEnlargement3 bx bg g bh h bi i + in case f be e of + InsOne bo o -> Node3 bo o by y bz z + InsCarry mask carry bo o -> + case carry of + CarryLeaf bu u -> + add (insert_ mask bu u 0) bo o by y bz z + + CarryNode depth bu u -> + add (insertNode mask depth bu u 0) bo o by y bz z + + InsTwo _ bl l br r -> Node4 bl l br r by y bz z + + in add (insert_ 0 bx x 0) ba a bb b bc c + + Node4 ba a bb b bc c bd d -> + let add f bg g bh h bi i bj j = + let !(# be, e, !bw, !w, !by, !y, !bz, !z #) = leastEnlargement4 bx bg g bh h bi i bj j + in case f be e of + InsOne bo o -> Node4 bo o bw w by y bz z + InsCarry mask carry bo o -> + case carry of + CarryLeaf bu u -> + add (insert_ mask bu u 0) bo o bw w by y bz z + + CarryNode depth bu u -> + add (insertNode mask depth bu u 0) bo o bw w by y bz z + + InsTwo _ bl l br r -> + case sortSplit bl l br r bw w by y bz z of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bs s bt t) -> + Node2 bl' (Node3 bm m bo o bp p) br' (Node2 bs s bt t) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bs s bt t) -> + Node2 bl' (Node2 bm m bo o) br' (Node3 bp p bs s bt t) + + in add (insert_ 0 bx x 0) ba a bb b bc c bd d + + Leaf2 ba a bb b -> Leaf3 ba a bb b bx x + Leaf3 ba a bb b bc c -> Leaf4 ba a bb b bc c bx x + Leaf4 ba a bb b bc c bd d -> + case sortSplit ba a bb b bc c bd d bx x of + Q3L (L3 bl bu u bv v bw w) (L2 br by y bz z) -> + Node2 bl (Leaf3 bu u bv v bw w) br (Leaf2 by y bz z) + + Q3R (L2 bl bu u bv v) (L3 br bw w by y bz z) -> + Node2 bl (Leaf2 bu u bv v) br (Leaf3 bw w by y bz z) + + Leaf1 ba a -> Leaf2 ba a bx x + Empty -> Leaf1 bx x + + + +insert_ :: Word -> MBR -> a -> Int -> MBR -> R2Tree a -> Ins a +insert_ mask bx x = go + where + go height bn n = + case n of + Node2 ba a bb b -> + let !(# be, e, !bz, !z #) = leastEnlargement2 bx ba a bb b + in case go (height + 1) be e of + InsOne bo o -> InsOne (unionMBR bo bz) (Node2 bo o bz z) + InsCarry mask' carry bo o -> + InsCarry mask' carry (unionMBR bo bz) (Node2 bo o bz z) + + InsTwo _ bl l br r -> + InsOne (union3MBR bl br bz) (Node3 bl l br r bz z) + + Node3 ba a bb b bc c -> + let !(# be, e, !by, !y, !bz, !z #) = leastEnlargement3 bx ba a bb b bc c + in case go (height + 1) be e of + InsOne bo o -> + InsOne (union3MBR bo by bz) (Node3 bo o by y bz z) + + InsCarry mask' carry bo o -> + InsCarry mask' carry (union3MBR bo by bz) (Node3 bo o by y bz z) + + InsTwo _ bl l br r -> + InsOne (union4MBR bl br by bz) (Node4 bl l br r by y bz z) + + Node4 ba a bb b bc c bd d -> + let !(# be, e, !bw, !w, !by, !y, !bz, !z #) = leastEnlargement4 bx ba a bb b bc c bd d + in case go (height + 1) be e of + InsOne bo o -> + InsOne (union4MBR bo bw by bz) (Node4 bo o bw w by y bz z) + + InsCarry mask' carry bo o -> + InsCarry mask' carry (union4MBR bo bw by bz) (Node4 bo o bw w by y bz z) + + InsTwo _ bl l br r -> + let bit_ = 1 `unsafeShiftL` height + in case mask .&. bit_ of + 0 -> + case sortSplit bl l br r bw w by y bz z of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bs s bt t) -> + InsTwo mask bl' (Node3 bm m bo o bp p) br' (Node2 bs s bt t) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bs s bt t) -> + InsTwo mask bl' (Node2 bm m bo o) br' (Node3 bp p bs s bt t) + + _ -> + let !(# bm, m, bo, o, bp, p, bs, s, bt, t #) = + sort5Distance (unionMBR bn bx) bl l br r bw w by y bz z + + in InsCarry (mask .|. bit_) (CarryNode height bt t) + (union4MBR bm bo bp bs) (Node4 bm m bo o bp p bs s) + + Leaf2 ba a bb b -> + InsOne (union3MBR ba bb bx) (Leaf3 ba a bb b bx x) + + Leaf3 ba a bb b bc c -> + InsOne (union4MBR ba bb bc bx) (Leaf4 ba a bb b bc c bx x) + + Leaf4 ba a bb b bc c bd d -> + let bit_ = 1 `unsafeShiftL` height + in case mask .&. bit_ of + 0 -> + case sortSplit ba a bb b bc c bd d bx x of + Q3L (L3 bl bu u bv v bw w) (L2 br by y bz z) -> + InsTwo mask bl (Leaf3 bu u bv v bw w) br (Leaf2 by y bz z) + + Q3R (L2 bl bu u bv v) (L3 br bw w by y bz z) -> + InsTwo mask bl (Leaf2 bu u bv v) br (Leaf3 bw w by y bz z) + + _ -> + let !(# bu, u, bv, v, bw, w, by, y, bz, z #) = + sort5Distance (unionMBR bn bx) ba a bb b bc c bd d bx x + + in InsCarry (mask .|. bit_) (CarryLeaf bz z) + (union4MBR bu bv bw by) (Leaf4 bu u bv v bw w by y) + + Leaf1 ba a -> + InsOne (unionMBR ba bx) (Leaf2 ba a bx x) + + Empty -> + InsOne bx (Leaf1 bx x) + + +insertNode :: Word -> Int -> MBR -> R2Tree a -> Int -> MBR -> R2Tree a -> Ins a +insertNode mask depth bx x = go + where + go height bn n = + case n of + Node2 ba a bb b + | height >= depth -> + let !(# be, e, !bz, !z #) = leastEnlargement2 bx ba a bb b + in case go (height + 1) be e of + InsOne bo o -> InsOne (unionMBR bo bz) (Node2 bo o bz z) + InsCarry mask' carry bo o -> + InsCarry mask' carry (unionMBR bo bz) (Node2 bo o bz z) + + InsTwo _ bl l br r -> + InsOne (union3MBR bl br bz) (Node3 bl l br r bz z) + + | otherwise -> + InsOne (unionMBR bn bx) (Node3 ba a bb b bx x) + + Node3 ba a bb b bc c + | height >= depth -> + let !(# be, e, !by, !y, !bz, !z #) = leastEnlargement3 bx ba a bb b bc c + in case go (height + 1) be e of + InsOne bo o -> + InsOne (union3MBR bo by bz) (Node3 bo o by y bz z) + + InsCarry mask' carry bo o -> + InsCarry mask' carry (union3MBR bo by bz) (Node3 bo o by y bz z) + + InsTwo _ bl l br r -> + InsOne (union4MBR bl br by bz) (Node4 bl l br r by y bz z) + + | otherwise -> + InsOne (unionMBR bn bx) (Node4 ba a bb b bc c bx x) + + Node4 ba a bb b bc c bd d + | height >= depth -> + let !(# be, e, !bw, !w, !by, !y, !bz, !z #) = leastEnlargement4 bx ba a bb b bc c bd d + in case go (height + 1) be e of + InsOne bo o -> + InsOne (union4MBR bo bw by bz) (Node4 bo o bw w by y bz z) + + InsCarry mask' carry bo o -> + InsCarry mask' carry (union4MBR bo bw by bz) (Node4 bo o bw w by y bz z) + + InsTwo _ bl l br r -> + let bit_ = 1 `unsafeShiftL` height + in case mask .&. bit_ of + 0 -> + case sortSplit bl l br r bw w by y bz z of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bs s bt t) -> + InsTwo mask bl' (Node3 bm m bo o bp p) br' (Node2 bs s bt t) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bs s bt t) -> + InsTwo mask bl' (Node2 bm m bo o) br' (Node3 bp p bs s bt t) + + _ -> + let !(# bm, m, bo, o, bp, p, bs, s, bt, t #) = + sort5Distance (unionMBR bn bx) bl l br r bw w by y bz z + + in InsCarry (mask .|. bit_) (CarryNode height bt t) + (union4MBR bm bo bp bs) (Node4 bm m bo o bp p bs s) + + | otherwise -> + let bit_ = 1 `unsafeShiftL` height + in case mask .&. bit_ of + 0 -> + case sortSplit ba a bb b bc c bd d bx x of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bs s bt t) -> + InsTwo mask bl' (Node3 bm m bo o bp p) br' (Node2 bs s bt t) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bs s bt t) -> + InsTwo mask bl' (Node2 bm m bo o) br' (Node3 bp p bs s bt t) + + _ -> + let !(# bm, m, bo, o, bp, p, bs, s, bt, t #) = + sort5Distance (unionMBR bn bx) ba a bb b bc c bd d bx x + + in InsCarry (mask .|. bit_) (CarryNode height bt t) + (union4MBR bm bo bp bs) (Node4 bm m bo o bp p bs s) + + + + _ -> errorWithoutStackTrace "Data.R2Tree.Double.Internal.insertNode: reached a leaf" + + + +sortSplit :: MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a -> Q3 a +sortSplit ba a bb b bc c bd d be e = + let v = sort5_ vertical ba a bb b bc c bd d be e + h = sort5_ horizontal ba a bb b bc c bd d be e + + vg = group v + hg = group h + + !(# al@(L3 bu _ _ _ _ _ _), ar@(L2 bv _ _ _ _) + , bl@(L2 bx _ _ _ _), br@(L3 by _ _ _ _ _ _) #) + | margins vg <= margins hg = vg + | otherwise = hg + + aw = Q3L al ar + bw = Q3R bl br + + in case overlapMBR bu bv `compare` overlapMBR bx by of + GT -> bw + LT -> aw + EQ | areaMBR bu + areaMBR bv <= areaMBR bx + areaMBR by -> aw + | otherwise -> bw + + + +sort5Distance + :: MBR + -> MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a + -> (# MBR, a, MBR, a, MBR, a, MBR, a, MBR, a #) +sort5Distance bx ka a kb b kc c kd d ke e = + sort5_ (distance bx) ka a kb b kc c kd d ke e + + + + +{-# INLINE horizontal #-} +horizontal :: MBR -> MBR -> Bool +horizontal (UnsafeMBR xmin _ xmax _) (UnsafeMBR xmin' _ xmax' _) = + case xmin `compare` xmin' of + GT -> False + LT -> True + EQ -> xmax <= xmax' + +{-# INLINE vertical #-} +vertical :: MBR -> MBR -> Bool +vertical (UnsafeMBR _ ymin _ ymax) (UnsafeMBR _ ymin' _ ymax') = + case ymin `compare` ymin' of + GT -> False + LT -> True + EQ -> ymax <= ymax' + +{-# INLINE distance #-} +distance :: MBR -> MBR -> MBR -> Bool +distance bx ba bb = distanceMBR bx ba <= distanceMBR bx bb + +{-# INLINE sort5_ #-} +sort5_ + :: (k -> k -> Bool) -- as in (A is smaller than B) + -> k -> a -> k -> a -> k -> a -> k -> a -> k -> a + -> (# k, a, k, a, k, a, k, a, k, a #) +sort5_ f ka a kb b kc c kd d ke e = + let swap kx x ky y + | f kx ky = (# kx, x, ky, y #) + | otherwise = (# ky, y, kx, x #) + + sort3 kw w kx x ky y kz z + | f kw ky = + if f kw kx + then (# kw, w, kx, x, ky, y, kz, z #) + else (# kx, x, kw, w, ky, y, kz, z #) + + | otherwise = + if f kw kz + then (# kx, x, ky, y, kw, w, kz, z #) + else (# kx, x, ky, y, kz, z, kw, w #) + + (# ka1, a1, kb1, b1 #) = swap ka a kb b + (# kc1, c1, kd1, d1 #) = swap kc c kd d + + (# ka2, (a2, kb2, b2), kc2, (c2, kd2, d2) #) = + swap ka1 (a1, kb1, b1) kc1 (c1, kd1, d1) + + (# ka3, a3, kc3, c3, kd3, d3, ke3, e3 #) = sort3 ke e ka2 a2 kc2 c2 kd2 d2 + + (# kb4, b4, kc4, c4, kd4, d4, ke4, e4 #) = sort3 kb2 b2 kc3 c3 kd3 d3 ke3 e3 + + in (# ka3, a3, kb4, b4, kc4, c4, kd4, d4, ke4, e4 #) + +{-# INLINE group #-} +group + :: (# MBR, a, MBR, a, MBR, a, MBR, a, MBR, a #) -> (# L3 a, L2 a, L2 a, L3 a #) +group (# ba, a, bb, b, bc, c, bd, d, be, e #) = + (# L3 (union3MBR ba bb bc) ba a bb b bc c, L2 (unionMBR bd be) bd d be e + , L2 (unionMBR ba bb) ba a bb b, L3 (union3MBR bd be bc) bd d be e bc c #) + +{-# INLINE margins #-} +margins :: (# L3 a, L2 a, L2 a, L3 a #) -> Double +margins (# L3 bw _ _ _ _ _ _, L2 bx _ _ _ _, L2 by _ _ _ _, L3 bz _ _ _ _ _ _ #) = + marginMBR bw + marginMBR bx + marginMBR by + marginMBR bz + + + +-- | \(\mathcal{O}(\log n)\). +-- Remove an entry stored under a given t'MBR', if one exists. +-- If multiple entries qualify, the leftmost one is removed. +-- +-- 'delete' uses the R-tree deletion algorithm with quadratic-cost splits. +delete :: MBR -> R2Tree a -> R2Tree a +delete bx s = + case delete_ bx 0 s of + DelOne _ o -> o + DelNone -> s + DelSome re _ o -> reintegrate 0 o re + DelRe re -> + case re of + ReCons _ _ n re' -> reintegrate (-1) n re' + ReLeaf ba a -> Leaf1 ba a + where + reintegrate height n re = + case re of + ReCons depth ba a re' -> + case insertGutRootNode ba a (depth + height) n of + GutOne _ o -> reintegrate height o re' + GutTwo bl l br r -> reintegrate (height + 1) (Node2 bl l br r) re' + + ReLeaf ba a -> + case insertGutRoot ba a n of + GutOne _ o -> o + GutTwo bl l br r -> Node2 bl l br r + + + +data Re a = ReCons Int MBR (R2Tree a) (Re a) + | ReLeaf MBR a + +data Del a = DelNone + | DelOne MBR (R2Tree a) + | DelSome (Re a) MBR (R2Tree a) + | DelRe (Re a) + +delete_ :: MBR -> Int -> R2Tree a -> Del a +delete_ bx = go + where + {-# INLINE cut2 #-} + cut2 depth next ba a bb b + | containsMBR ba bx = + case go (depth + 1) a of + DelNone -> next + DelOne bo o -> DelOne (unionMBR bo bb) (Node2 bo o bb b) + DelSome re bo o -> DelSome re (unionMBR bo bb) (Node2 bo o bb b) + DelRe re -> DelRe (ReCons depth bb b re) + + | otherwise = next + + {-# INLINE cut3 #-} + cut3 depth next ba a bb b bc c + | containsMBR ba bx = + case go (depth + 1) a of + DelNone -> next + DelOne bo o -> DelOne (union3MBR bo bb bc) (Node3 bo o bb b bc c) + DelSome re bo o -> DelSome re (union3MBR bo bb bc) (Node3 bo o bb b bc c) + DelRe re -> DelSome re (unionMBR bb bc) (Node2 bb b bc c) + + | otherwise = next + + {-# INLINE cut4 #-} + cut4 depth next ba a bb b bc c bd d + | containsMBR ba bx = + case go (depth + 1) a of + DelNone -> next + DelOne bo o -> DelOne (union4MBR bo bb bc bd) (Node4 bo o bb b bc c bd d) + DelSome re bo o -> DelSome re (union4MBR bo bb bc bd) (Node4 bo o bb b bc c bd d) + DelRe re -> DelSome re (union3MBR bb bc bd) (Node3 bb b bc c bd d) + + | otherwise = next + + {-# INLINE edge2 #-} + edge2 next ba bb b + | eqMBR ba bx = DelRe (ReLeaf bb b) + | otherwise = next + + {-# INLINE edge3 #-} + edge3 next ba bb b bc c + | eqMBR ba bx = DelOne (unionMBR bb bc) (Leaf2 bb b bc c) + | otherwise = next + + {-# INLINE edge4 #-} + edge4 next ba bb b bc c bd d + | eqMBR ba bx = DelOne (union3MBR bb bc bd) (Leaf3 bb b bc c bd d) + | otherwise = next + + go depth n = + case n of + Node2 ba a bb b -> + let dela = cut2 depth delb ba a bb b + delb = cut2 depth DelNone bb b ba a + + in dela + + Node3 ba a bb b bc c -> + let dela = cut3 depth delb ba a bb b bc c + delb = cut3 depth delc bb b ba a bc c + delc = cut3 depth DelNone bc c ba a bb b + + in dela + + Node4 ba a bb b bc c bd d -> + let dela = cut4 depth delb ba a bb b bc c bd d + delb = cut4 depth delc bb b ba a bc c bd d + delc = cut4 depth deld bc c ba a bb b bd d + deld = cut4 depth DelNone bd d ba a bb b bc c + + in dela + + Leaf2 ba a bb b -> + let dela = edge2 delb ba bb b + delb = edge2 DelNone bb ba a + + in dela + + Leaf3 ba a bb b bc c -> + let dela = edge3 delb ba bb b bc c + delb = edge3 delc bb ba a bc c + delc = edge3 DelNone bc ba a bb b + + in dela + + Leaf4 ba a bb b bc c bd d -> + let dela = edge4 delb ba bb b bc c bd d + delb = edge4 delc bb ba a bc c bd d + delc = edge4 deld bc ba a bb b bd d + deld = edge4 DelNone bd ba a bb b bc c + + in dela + + Leaf1 ba _ | eqMBR bx ba -> DelOne ba Empty + | otherwise -> DelNone + + Empty -> DelNone + + + + +quotCeil :: Int -> Int -> Int +quotCeil i d = let ~(p, q) = quotRem i d + in p + case q of + 0 -> 0 + _ -> 1 + +slices :: Int -> Int +slices r = ceiling (sqrt (fromIntegral (quotCeil r 4)) :: Double) + +partition1 :: Int -> [a] -> [(Int, [a])] +partition1 n_ = go + where + go xs = + let ~(n, before, after) = splitAt1 0 xs + in (n, before) : case after of + _:_ -> go after + [] -> [] + + splitAt1 n xs = + case xs of + [] -> (n, [], []) + x:ys + | n < n_ -> let ~(m, as, bs) = splitAt1 (n + 1) ys + in (m, x:as, bs) + + | [] <- ys -> (n + 1, xs, []) + | otherwise -> (n , [], xs) + + + +-- | \(\mathcal{O}(n \log n)\). Bulk-load a tree. +-- +-- 'bulkSTR' uses the Sort-Tile-Recursive algorithm. +bulkSTR :: [(MBR, a)] -> R2Tree a +bulkSTR xs = + case xs of + _:_:_ -> snd $ vertically (length xs) xs + [(ba, a)] -> Leaf1 ba a + [] -> Empty + where + horiCenter (UnsafeMBR xmin _ xmax _, _) = xmin + xmax + + vertCenter (UnsafeMBR _ ymin _ ymax, _) = ymin + ymax + + horizontally r as = + let s = slices r + in if s <= 1 + then base as + else compress . + fmap (uncurry vertically) $ + partition1 (r `quotCeil` s) (List.sortBy (compare `on` vertCenter) as) + + + vertically r as = + let s = slices r + in if s <= 1 + then base as + else compress . + fmap (uncurry horizontally) $ + partition1 (r `quotCeil` s) (List.sortBy (compare `on` horiCenter) as) + + compress (x : ys) = go (x :| ys) + where + go (a :| bs) = + case bs of + [] -> a + b:cs -> go (mend a b cs) + + compress [] = + errorWithoutStackTrace + "Data.R2Tree.Double.Internal.bulkSTR: zero-sized partition" + + mend (ba, a) (bb, b) cs = + case cs of + (bc, c) : (bd, d) : e : f : gs -> + (union4MBR ba bb bc bd, Node4 ba a bb b bc c bd d) <| mend e f gs + + (bc, c) : (bd, d) : (be, e) : [] -> + (union3MBR ba bb bc, Node3 ba a bb b bc c) :| + (unionMBR bd be, Node2 bd d be e) : [] + + (bc, c) : (bd, d) : [] -> + (union4MBR ba bb bc bd, Node4 ba a bb b bc c bd d) :| [] + + (bc, c) : [] -> + (union3MBR ba bb bc, Node3 ba a bb b bc c) :| [] + + [] -> + (unionMBR ba bb, Node2 ba a bb b) :| [] + + base as = + case as of + (ba, a) : (bb, b) : (bc, c) : (bd, d) : [] -> + (union4MBR ba bb bc bd, Leaf4 ba a bb b bc c bd d) + + (ba, a) : (bb, b) : (bc, c) : [] -> + (union3MBR ba bb bc, Leaf3 ba a bb b bc c) + + (ba, a) : (bb, b) : [] -> + (unionMBR ba bb, Leaf2 ba a bb b) + + _ -> errorWithoutStackTrace + "Data.R2Tree.Double.Internal.bulkSTR: malformed leaf" diff --git a/src/Data/R2Tree/Double/Unsafe.hs b/src/Data/R2Tree/Double/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Data/R2Tree/Double/Unsafe.hs @@ -0,0 +1,43 @@ +{-# OPTIONS_HADDOCK not-home #-} + +{- | + Module : Data.R2Tree.Double.Unsafe + Copyright : Copyright (c) 2015, Birte Wagner, Sebastian Philipp + Copyright (c) 2022, Oleksii Divak + License : MIT + + Maintainer : Oleksii Divak + Stability : experimental + Portability: not portable + + Underlying implementation of the 'R2Tree'. +-} + +module Data.R2Tree.Double.Unsafe + ( MBR (MBR, UnsafeMBR) + + -- | === R-tree + -- + -- Each t'MBR' is tied to the value directly after it. + -- + -- Invariant: the t'MBR' of each non-leaf node encloses + -- all the t'MBR's inside the node. + , R2Tree (..) + + -- * Common operations + , validMBR + , eqMBR + , unionMBR + , areaMBR + , marginMBR + , distanceMBR + , containsMBR + , containsMBR' + , intersectionMBR + , intersectionMBR' + + -- * Range + , Predicate (..) + ) where + +import Data.R2Tree.Double.Internal diff --git a/src/Data/R2Tree/Float.hs b/src/Data/R2Tree/Float.hs new file mode 100644 --- /dev/null +++ b/src/Data/R2Tree/Float.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE PatternSynonyms #-} + +{- | + Module : Data.R2Tree.Float + Copyright : Copyright (c) 2015, Birte Wagner, Sebastian Philipp + Copyright (c) 2022, Oleksii Divak + License : MIT + + Maintainer : Oleksii Divak + Stability : experimental + Portability: not portable + + This module (and every module below it) is a duplicate of "Data.R2Tree.Double", + defined for 'Float's instead of 'Double's. +-} + +module Data.R2Tree.Float + ( MBR (MBR) + , R2Tree + + -- * Construct + , empty + , singleton + , doubleton + , tripleton + , quadrupleton + + -- ** Bulk-loading + , bulkSTR + + -- * Single-key + -- ** Insert + , insert + , insertGut + + -- ** Delete + , delete + + -- * Range + , Predicate + , equals + , intersects + , intersects' + , contains + , contains' + , containedBy + , containedBy' + + -- ** Map + , adjustRangeWithKey + , adjustRangeWithKey' + + -- ** Fold + , foldlRangeWithKey + , foldrRangeWithKey + , foldMapRangeWithKey + , foldlRangeWithKey' + , foldrRangeWithKey' + + -- ** Traverse + , traverseRangeWithKey + + -- * Full tree + -- ** Size + , Data.R2Tree.Float.Internal.null + , size + + -- ** Map + , Data.R2Tree.Float.Internal.map + , map' + , mapWithKey + , mapWithKey' + + -- ** Fold + -- | === Left-to-right + , Data.R2Tree.Float.Internal.foldl + , Data.R2Tree.Float.Internal.foldl' + , foldlWithKey + , foldlWithKey' + + -- | === Right-to-left + , Data.R2Tree.Float.Internal.foldr + , Data.R2Tree.Float.Internal.foldr' + , foldrWithKey + , foldrWithKey' + + -- | === Monoid + , Data.R2Tree.Float.Internal.foldMap + , foldMapWithKey + + -- ** Traverse + , Data.R2Tree.Float.Internal.traverse + , traverseWithKey + ) where + +import Data.R2Tree.Float.Internal + + + +-- | \(\mathcal{O}(1)\). +-- Empty tree. +empty :: R2Tree a +empty = Empty + +-- | \(\mathcal{O}(1)\). +-- Tree with a single entry. +singleton :: MBR -> a -> R2Tree a +singleton = Leaf1 + +-- | \(\mathcal{O}(1)\). +-- Tree with two entries. +doubleton :: MBR -> a -> MBR -> a -> R2Tree a +doubleton = Leaf2 + +-- | \(\mathcal{O}(1)\). +-- Tree with three entries. +tripleton :: MBR -> a -> MBR -> a -> MBR -> a -> R2Tree a +tripleton = Leaf3 + +-- | \(\mathcal{O}(1)\). +-- Tree with four entries. +quadrupleton :: MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a -> R2Tree a +quadrupleton = Leaf4 diff --git a/src/Data/R2Tree/Float/Debug.hs b/src/Data/R2Tree/Float/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Data/R2Tree/Float/Debug.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +{- | + Module : Data.R2Tree.Float.Debug + Copyright : Copyright (c) 2015, Birte Wagner, Sebastian Philipp + Copyright (c) 2022, Oleksii Divak + License : MIT + + Maintainer : Oleksii Divak + Stability : experimental + Portability: not portable + + Functions that expose the innerworkings of an 'R2Tree', but are completely safe + to use otherwise. +-} + +module Data.R2Tree.Float.Debug + ( showsTree + + , Validity (..) + , Reason (..) + , validate + ) where + +import Data.R2Tree.Float.Internal + + + +-- | \(\mathcal{O}(n)\). +-- Shows the internal structure of the R-tree. +showsTree :: (a -> ShowS) -> R2Tree a -> ShowS +showsTree f = go id 0 + where + {-# INLINE mbr #-} + mbr (UnsafeMBR xmin ymin xmax ymax) = shows (xmin, ymin, xmax, ymax) + + {-# INLINE offset #-} + offset i + | i <= 0 = id + | otherwise = showChar ' ' . offset (i - 1) + + go s (i :: Int) n = + offset i . + case n of + Node2 ba a bb b -> + showString "Node 2" . s + . showChar '\n' . go (showChar ' ' . mbr ba) (i + 2) a + . showChar '\n' . go (showChar ' ' . mbr bb) (i + 2) b + + Node3 ba a bb b bc c -> + showString "Node 3" . s + . showChar '\n' . go (showChar ' ' . mbr ba) (i + 2) a + . showChar '\n' . go (showChar ' ' . mbr bb) (i + 2) b + . showChar '\n' . go (showChar ' ' . mbr bc) (i + 2) c + + Node4 ba a bb b bc c bd d -> + showString "Node 4" . s + . showChar '\n' . go (showChar ' ' . mbr ba) (i + 2) a + . showChar '\n' . go (showChar ' ' . mbr bb) (i + 2) b + . showChar '\n' . go (showChar ' ' . mbr bc) (i + 2) c + . showChar '\n' . go (showChar ' ' . mbr bd) (i + 2) d + + Leaf2 ba a bb b -> + showString "Leaf 2" . s + . showChar '\n' . offset (i + 2) . mbr ba . showChar ' ' . f a + . showChar '\n' . offset (i + 2) . mbr bb . showChar ' ' . f b + + Leaf3 ba a bb b bc c -> + showString "Leaf 3" . s + . showChar '\n' . offset (i + 2) . mbr ba . showChar ' ' . f a + . showChar '\n' . offset (i + 2) . mbr bb . showChar ' ' . f b + . showChar '\n' . offset (i + 2) . mbr bc . showChar ' ' . f c + + Leaf4 ba a bb b bc c bd d -> + showString "Leaf 4" . s + . showChar '\n' . offset (i + 2) . mbr ba . showChar ' ' . f a + . showChar '\n' . offset (i + 2) . mbr bb . showChar ' ' . f b + . showChar '\n' . offset (i + 2) . mbr bc . showChar ' ' . f c + . showChar '\n' . offset (i + 2) . mbr bd . showChar ' ' . f d + + Leaf1 bx x -> + showString "Leaf 1" . s + . showChar '\n' . offset (i + 2) . mbr bx . showChar ' ' . f x + + Empty -> + showString "Empty" . s + + + +-- | Whether the tree is well-formed. +data Validity = Valid + | Invalid Reason + deriving Show + +-- | Reason for why the tree is considered malformed. +data Reason = -- | Not all nodes are at the same depth. + UnbalancedTree + -- | Node does not enclose all inner t'MBR's properly. + | MalformedNode MBR + -- | Found a 'Leaf1' node not at root level. + | FoundLeaf1 + -- | Found an 'Empty' node not at root level. + | FoundEmpty + deriving Show + + + +data Carry = Carry Int + | Broken Reason + +carry2 :: Carry -> Carry -> Carry +carry2 (Carry i) (Carry j) + | i == j = Carry (i + 1) + | otherwise = Broken UnbalancedTree + +carry2 (Carry _) b = b +carry2 a _ = a + +carry3 :: Carry -> Carry -> Carry -> Carry +carry3 (Carry i) (Carry j) (Carry k) + | i == j, i == k = Carry (i + 1) + | otherwise = Broken UnbalancedTree + +carry3 (Carry _) (Carry _) c = c +carry3 (Carry _) b _ = b +carry3 a _ _ = a + +carry4 :: Carry -> Carry -> Carry -> Carry -> Carry +carry4 (Carry i) (Carry j) (Carry k) (Carry l) + | i == j, i == k, i == l = Carry (i + 1) + | otherwise = Broken UnbalancedTree + +carry4 (Carry _) (Carry _) (Carry _) d = d +carry4 (Carry _) (Carry _) c _ = c +carry4 (Carry _) b _ _ = b +carry4 a _ _ _ = a + + + +-- | \(\mathcal{O}(n)\). +-- Checks whether the tree is well-formed. +validate :: R2Tree a -> Validity +validate t = + case t of + Leaf1 _ _ -> Valid + Empty -> Valid + _ -> + case go Nothing t of + Carry _ -> Valid + Broken r -> Invalid r + where + go mbx x = + case x of + Node2 ba a bb b + | Just bx <- mbx, bx /= unionMBR ba bb -> Broken $ MalformedNode bx + | otherwise -> + carry2 (go (Just ba) a) + (go (Just bb) b) + + Node3 ba a bb b bc c + | Just bx <- mbx, bx /= unionMBR (unionMBR ba bb) bc -> Broken $ MalformedNode bx + | otherwise -> + carry3 (go (Just ba) a) + (go (Just bb) b) + (go (Just bc) c) + + Node4 ba a bb b bc c bd d + | Just bx <- mbx + , bx /= unionMBR (unionMBR (unionMBR ba bb) bc) bd -> Broken $ MalformedNode bx + + | otherwise -> + carry4 (go (Just ba) a) + (go (Just bb) b) + (go (Just bc) c) + (go (Just bd) d) + + Leaf2 ba _ bb _ + | Just bx <- mbx, bx /= unionMBR ba bb -> Broken $ MalformedNode bx + | otherwise -> Carry 0 + + Leaf3 ba _ bb _ bc _ + | Just bx <- mbx, bx /= unionMBR (unionMBR ba bb) bc -> Broken $ MalformedNode bx + | otherwise -> Carry 0 + + Leaf4 ba _ bb _ bc _ bd _ + | Just bx <- mbx + , bx /= unionMBR (unionMBR (unionMBR ba bb) bc) bd -> Broken $ MalformedNode bx + + | otherwise -> Carry 0 + + Leaf1 _ _ -> Broken FoundLeaf1 + Empty -> Broken FoundEmpty diff --git a/src/Data/R2Tree/Float/Internal.hs b/src/Data/R2Tree/Float/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/R2Tree/Float/Internal.hs @@ -0,0 +1,2204 @@ +{-# LANGUAGE BangPatterns + , PatternSynonyms + , RankNTypes + , ViewPatterns + , UnboxedTuples #-} + +module Data.R2Tree.Float.Internal + ( MBR (UnsafeMBR, MBR) + , validMBR + , eqMBR + , unionMBR + , areaMBR + , marginMBR + , distanceMBR + , containsMBR + , containsMBR' + , intersectionMBR + , intersectionMBR' + + , Predicate (..) + , equals + , intersects + , intersects' + , contains + , contains' + , containedBy + , containedBy' + + , R2Tree (..) + + , Data.R2Tree.Float.Internal.null + , Data.R2Tree.Float.Internal.size + + , Data.R2Tree.Float.Internal.map + , map' + , mapWithKey + , mapWithKey' + , adjustRangeWithKey + , adjustRangeWithKey' + + , Data.R2Tree.Float.Internal.foldl + , Data.R2Tree.Float.Internal.foldl' + , foldlWithKey + , foldlWithKey' + , foldlRangeWithKey + , foldlRangeWithKey' + + , Data.R2Tree.Float.Internal.foldr + , Data.R2Tree.Float.Internal.foldr' + , foldrWithKey + , foldrWithKey' + , foldrRangeWithKey + , foldrRangeWithKey' + + , Data.R2Tree.Float.Internal.foldMap + , foldMapWithKey + , foldMapRangeWithKey + + , Data.R2Tree.Float.Internal.traverse + , traverseWithKey + , traverseRangeWithKey + + , insertGut + , insert + , delete + + , bulkSTR + ) where + +import Control.Applicative +import Control.DeepSeq +import Data.Bits +import Data.Foldable +import Data.Functor.Classes +import Data.Function +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty (..), (<|)) +import Text.Show + + + +-- | Two-dimensional minimum bounding rectangle is defined as two intervals, +-- each along a separate axis, where every endpoint is either +-- bounded and closed (i.e. \( [a, b] \)), or infinity (i.e. \((\pm \infty, b]\)). +-- +-- Degenerate intervals (i.e. \([a,a]\)) are permitted. +data MBR = -- | Invariants: \( x_{min} \le x_{max}, y_{min} \le y_{max} \). + UnsafeMBR + {-# UNPACK #-} !Float -- ^ \( x_{min} \) + {-# UNPACK #-} !Float -- ^ \( y_{min} \) + {-# UNPACK #-} !Float -- ^ \( x_{max} \) + {-# UNPACK #-} !Float -- ^ \( y_{max} \) + +{-# COMPLETE MBR #-} +-- | Reorders coordinates to fit internal invariants. +-- +-- Pattern matching guarantees \( x_{0} \le x_{1}, y_{0} \le y_{1} \). +pattern MBR + :: Float -- ^ \( x_0 \) + -> Float -- ^ \( y_0 \) + -> Float -- ^ \( x_1 \) + -> Float -- ^ \( y_1 \) + -> MBR +pattern MBR xmin ymin xmax ymax <- UnsafeMBR xmin ymin xmax ymax + where + MBR x0 y0 x1 y1 = + let !(# xmin, xmax #) | x0 <= x1 = (# x0, x1 #) + | otherwise = (# x1, x0 #) + + !(# ymin, ymax #) | y0 <= y1 = (# y0, y1 #) + | otherwise = (# y1, y0 #) + + in UnsafeMBR xmin ymin xmax ymax + +instance Show MBR where + showsPrec d (UnsafeMBR xmin ymin xmax ymax) = + showParen (d > 10) $ showString "MBR " . showsPrec 11 xmin + . showChar ' ' . showsPrec 11 ymin + . showChar ' ' . showsPrec 11 xmax + . showChar ' ' . showsPrec 11 ymax + +instance Eq MBR where + (==) = eqMBR + + + +-- | Check whether lower endpoints are smaller or equal to the respective upper ones. +validMBR :: MBR -> Bool +validMBR (MBR xmin ymin xmax ymax) = xmin <= xmax && ymin <= ymax + +{-# INLINE eqMBR #-} +-- | Check whether two rectangles are equal. +eqMBR :: MBR -> MBR -> Bool +eqMBR (MBR xmin ymin xmax ymax) (MBR xmin' ymin' xmax' ymax') = + xmin == xmin' && ymin == ymin' && xmax == xmax' && ymax == ymax' + + +{-# INLINE unionMBR #-} +-- | Resulting rectangle contains both input rectangles. +unionMBR :: MBR -> MBR -> MBR +unionMBR (MBR xmin ymin xmax ymax) (MBR xmin' ymin' xmax' ymax') = + MBR (min xmin xmin') (min ymin ymin') (max xmax xmax') (max ymax ymax') + + +{-# INLINE areaMBR #-} +-- | Proper area. +areaMBR :: MBR -> Float +areaMBR (MBR xmin ymin xmax ymax) = (xmax - xmin) * (ymax - ymin) + +{-# INLINE marginMBR #-} +-- | Half a perimeter. +marginMBR :: MBR -> Float +marginMBR (MBR xmin ymin xmax ymax) = (xmax - xmin) + (ymax - ymin) + +{-# INLINE overlapMBR #-} +overlapMBR :: MBR -> MBR -> Float +overlapMBR = + intersectionMBR_ $ \x y x' y' -> + if x < x' && y < y' + then areaMBR (MBR x y x' y') + else 0 + + +{-# INLINE distanceMBR #-} +-- | Square distance between double the centers of two rectangles. +distanceMBR :: MBR -> MBR -> Float +distanceMBR (MBR xmin ymin xmax ymax) (MBR xmin' ymin' xmax' ymax') = + let x = (xmax' + xmin') - (xmax + xmin) + y = (ymax' + ymin') - (ymax + ymin) + in x * x + y * y + + +{-# INLINE containsMBR #-} +-- | Whether left rectangle contains right one. +containsMBR :: MBR -> MBR -> Bool +containsMBR (MBR xmin ymin xmax ymax) (MBR xmin' ymin' xmax' ymax') = + xmin <= xmin' && ymin <= ymin' && xmax >= xmax' && ymax >= ymax' + +{-# INLINE containsMBR' #-} +-- | Whether left rectangle contains right one without touching any of the sides. +containsMBR' :: MBR -> MBR -> Bool +containsMBR' (MBR xmin ymin xmax ymax) (MBR xmin' ymin' xmax' ymax') = + xmin < xmin' && ymin < ymin' && xmax > xmax' && ymax > ymax' + + + +{-# INLINE intersectionMBR #-} +-- | Intersection of two rectangles, if any exists. +intersectionMBR :: MBR -> MBR -> Maybe MBR +intersectionMBR = + intersectionMBR_ $ \x y x' y' -> + if x <= x' && y <= y' + then Just (MBR x y x' y') + else Nothing + +{-# INLINE intersectionMBR' #-} +-- | Intersection of two rectangles, if any exists, excluding the side cases where +-- the result would be a point or a line. +intersectionMBR' :: MBR -> MBR -> Maybe MBR +intersectionMBR' = + intersectionMBR_ $ \x y x' y' -> + if x < x' && y < y' + then Just (MBR x y x' y') + else Nothing + +{-# INLINE intersectionMBR_ #-} +intersectionMBR_ :: (Float -> Float -> Float -> Float -> a) -> MBR -> MBR -> a +intersectionMBR_ f (MBR xmin ymin xmax ymax) (MBR xmin' ymin' xmax' ymax') = + let x = max xmin xmin' + y = max ymin ymin' + x' = min xmax xmax' + y' = min ymax ymax' + + in f x y x' y' + +{-# INLINE intersectsMBR #-} +intersectsMBR :: MBR -> MBR -> Bool +intersectsMBR = intersectionMBR_ $ \x y x' y' -> x <= x' && y <= y' + +{-# INLINE intersectsMBR' #-} +intersectsMBR' :: MBR -> MBR -> Bool +intersectsMBR' = intersectionMBR_ $ \x y x' y' -> x < x' && y < y' + + + +-- | Comparison function. +data Predicate = Predicate + (MBR -> Bool) -- ^ Matches nodes + (MBR -> Bool) -- ^ Matches leaves + +{-# INLINE equals #-} +-- | Matches exactly the provided t'MBR'. +equals :: MBR -> Predicate +equals bx = Predicate (\ba -> containsMBR ba bx) (eqMBR bx) + +{-# INLINE intersects #-} +-- | Matches any t'MBR' that intersects the provided one. +intersects:: MBR -> Predicate +intersects bx = Predicate (intersectsMBR bx) (intersectsMBR bx) + +{-# INLINE intersects' #-} +-- | Matches any t'MBR' that intersects the provided one, if the +-- intersection is not a line or a point. +intersects' :: MBR -> Predicate +intersects' bx = Predicate (intersectsMBR' bx) (intersectsMBR' bx) + +{-# INLINE contains #-} +-- | Matches any t'MBR' that contains the provided one. +contains :: MBR -> Predicate +contains bx = Predicate (\ba -> containsMBR ba bx) (\ba -> containsMBR ba bx) + +{-# INLINE contains' #-} +-- | Matches any t'MBR' that contains the provided one, +-- excluding ones that touch it on one or more sides. +contains' :: MBR -> Predicate +contains' bx = Predicate (\ba -> containsMBR ba bx) (\ba -> containsMBR' ba bx) + +{-# INLINE containedBy #-} +-- | Matches any t'MBR' that is contained within the provided one. +containedBy :: MBR -> Predicate +containedBy bx = Predicate (intersectsMBR bx) (containsMBR bx) + +{-# INLINE containedBy' #-} +-- | Matches any t'MBR' that is contained within the provided one, +-- excluding ones that touch it on one or more sides. +containedBy' :: MBR -> Predicate +containedBy' bx = Predicate (intersectsMBR bx) (containsMBR' bx) + + + +instance Show a => Show (R2Tree a) where + showsPrec = liftShowsPrec showsPrec showList + +instance Show1 R2Tree where + liftShowsPrec showsPrec_ showList_ t r = + showParen (t > 10) $ + showListWith (liftShowsPrec showsPrec_ showList_ 0) $ + foldrWithKey (\k a -> (:) (k, a)) [] r + +instance Eq a => Eq (R2Tree a) where + (==) = liftEq (==) + +instance Eq1 R2Tree where + liftEq f = go + where + {-# INLINE node #-} + node ba a bb b = eqMBR ba bb && go a b + + {-# INLINE leaf #-} + leaf ba a bb b = eqMBR ba bb && f a b + + go m n = + case m of + Node2 ba a bb b -> + case n of + Node2 be e bg g -> node ba a be e && node bb b bg g + _ -> False + + Node3 ba a bb b bc c -> + case n of + Node3 be e bg g bh h -> node ba a be e && node bb b bg g && node bc c bh h + _ -> False + + Node4 ba a bb b bc c bd d -> + case n of + Node4 be e bg g bh h bi i -> + node ba a be e && node bb b bg g && node bc c bh h && node bd d bi i + + _ -> False + + Leaf2 ba a bb b -> + case n of + Leaf2 be e bg g -> leaf ba a be e && leaf bb b bg g + _ -> False + + Leaf3 ba a bb b bc c -> + case n of + Leaf3 be e bg g bh h -> leaf ba a be e && leaf bb b bg g && leaf bc c bh h + _ -> False + + Leaf4 ba a bb b bc c bd d -> + case n of + Leaf4 be e bg g bh h bi i -> + leaf ba a be e && leaf bb b bg g && leaf bc c bh h && leaf bd d bi i + + _ -> False + + Leaf1 ba a -> + case n of + Leaf1 bb b -> eqMBR ba bb && f a b + _ -> False + + Empty -> + case n of + Empty -> True + _ -> False + + + +instance NFData a => NFData (R2Tree a) where + rnf = liftRnf rnf + +instance NFData1 R2Tree where + liftRnf f = go + where + go n = + case n of + Node2 _ a _ b -> go a `seq` go b + Node3 _ a _ b _ c -> go a `seq` go b `seq` go c + Node4 _ a _ b _ c _ d -> go a `seq` go b `seq` go c `seq` go d + + Leaf2 _ a _ b -> f a `seq` f b + Leaf3 _ a _ b _ c -> f a `seq` f b `seq` f c + Leaf4 _ a _ b _ c _ d -> f a `seq` f b `seq` f c `seq` f d + + Leaf1 _ a -> f a + Empty -> () + + + +-- | Uses 'Data.R2Tree.Float.map'. +instance Functor R2Tree where + fmap = Data.R2Tree.Float.Internal.map + +instance Foldable R2Tree where + foldl = Data.R2Tree.Float.Internal.foldl + + foldr = Data.R2Tree.Float.Internal.foldr + + foldMap = Data.R2Tree.Float.Internal.foldMap + + foldl' = Data.R2Tree.Float.Internal.foldl' + + foldr' = Data.R2Tree.Float.Internal.foldr' + + null = Data.R2Tree.Float.Internal.null + + length = size + + +instance Traversable R2Tree where + traverse = Data.R2Tree.Float.Internal.traverse + + + +-- | Spine-strict two-dimensional R-tree. +data R2Tree a = Node2 {-# UNPACK #-} !MBR !(R2Tree a) {-# UNPACK #-} !MBR !(R2Tree a) + | Node3 {-# UNPACK #-} !MBR !(R2Tree a) {-# UNPACK #-} !MBR !(R2Tree a) {-# UNPACK #-} !MBR !(R2Tree a) + | Node4 {-# UNPACK #-} !MBR !(R2Tree a) {-# UNPACK #-} !MBR !(R2Tree a) {-# UNPACK #-} !MBR !(R2Tree a) {-# UNPACK #-} !MBR !(R2Tree a) + + | Leaf2 {-# UNPACK #-} !MBR a {-# UNPACK #-} !MBR a + | Leaf3 {-# UNPACK #-} !MBR a {-# UNPACK #-} !MBR a {-# UNPACK #-} !MBR a + | Leaf4 {-# UNPACK #-} !MBR a {-# UNPACK #-} !MBR a {-# UNPACK #-} !MBR a {-# UNPACK #-} !MBR a + + -- | Invariant: only allowed as the root node. + | Leaf1 {-# UNPACK #-} !MBR a + + -- | Invariant: only allowed as the root node. + | Empty + + + +-- | \(\mathcal{O}(1)\). +-- Check if the tree is empty. +null :: R2Tree a -> Bool +null Empty = True +null _ = False + +-- | \(\mathcal{O}(n)\). +-- Calculate the number of elements stored in the tree. +-- The returned number is guaranteed to be non-negative. +size :: R2Tree a -> Int +size = go + where + go n = + case n of + Node2 _ a _ b -> let !w = go a + !x = go b + + in w + x + + Node3 _ a _ b _ c -> let !w = go a + !x = go b + !y = go c + + in w + x + y + + Node4 _ a _ b _ c _ d -> let !w = go a + !x = go b + !y = go c + !z = go d + + in w + x + y + z + + Leaf2 _ _ _ _ -> 2 + Leaf3 _ _ _ _ _ _ -> 3 + Leaf4 _ _ _ _ _ _ _ _ -> 4 + + Leaf1 _ _ -> 1 + Empty -> 0 + + + +-- | \(\mathcal{O}(n)\). +-- Map a function over all values. +map :: (a -> b) -> R2Tree a -> R2Tree b +map f = go + where + go n = + case n of + Node2 ba a bb b -> + Node2 ba (go a) bb (go b) + + Node3 ba a bb b bc c -> + Node3 ba (go a) bb (go b) bc (go c) + + Node4 ba a bb b bc c bd d -> + Node4 ba (go a) bb (go b) bc (go c) bd (go d) + + Leaf2 ba a bb b -> + Leaf2 ba (f a) bb (f b) + + Leaf3 ba a bb b bc c -> + Leaf3 ba (f a) bb (f b) bc (f c) + + Leaf4 ba a bb b bc c bd d -> + Leaf4 ba (f a) bb (f b) bc (f c) bd (f d) + + Leaf1 ba a -> + Leaf1 ba (f a) + + Empty -> Empty + +-- | \(\mathcal{O}(n)\). +-- Map a function over all values and evaluate the results to WHNF. +map' :: (a -> b) -> R2Tree a -> R2Tree b +map' f = go + where + go n = + case n of + Node2 ba a bb b -> + Node2 ba (go a) bb (go b) + + Node3 ba a bb b bc c -> + Node3 ba (go a) bb (go b) bc (go c) + + Node4 ba a bb b bc c bd d -> + Node4 ba (go a) bb (go b) bc (go c) bd (go d) + + Leaf2 ba a bb b -> + let !a' = f a + !b' = f b + + in Leaf2 ba a' bb b' + + Leaf3 ba a bb b bc c -> + let !a' = f a + !b' = f b + !c' = f c + + in Leaf3 ba a' bb b' bc c' + + Leaf4 ba a bb b bc c bd d -> + let !a' = f a + !b' = f b + !c' = f c + !d' = f d + + in Leaf4 ba a' bb b' bc c' bd d' + + Leaf1 ba a -> + Leaf1 ba $! f a + + Empty -> Empty + + +-- | \(\mathcal{O}(n)\). +-- Map a function over all t'MBR's and their respective values. +mapWithKey :: (MBR -> a -> b) -> R2Tree a -> R2Tree b +mapWithKey f = go + where + go n = + case n of + Node2 ba a bb b -> + Node2 ba (go a) bb (go b) + + Node3 ba a bb b bc c -> + Node3 ba (go a) bb (go b) bc (go c) + + Node4 ba a bb b bc c bd d -> + Node4 ba (go a) bb (go b) bc (go c) bd (go d) + + Leaf2 ba a bb b -> + Leaf2 ba (f ba a) bb (f bb b) + + Leaf3 ba a bb b bc c -> + Leaf3 ba (f ba a) bb (f bb b) bc (f bc c) + + Leaf4 ba a bb b bc c bd d -> + Leaf4 ba (f ba a) bb (f bb b) bc (f bc c) bd (f bd d) + + Leaf1 ba a -> + Leaf1 ba (f ba a) + + Empty -> Empty + +-- | \(\mathcal{O}(n)\). +-- Map a function over all t'MBR's and their respective values +-- and evaluate the results to WHNF. +mapWithKey' :: (MBR -> a -> b) -> R2Tree a -> R2Tree b +mapWithKey' f = go + where + go n = + case n of + Node2 ba a bb b -> + Node2 ba (go a) bb (go b) + + Node3 ba a bb b bc c -> + Node3 ba (go a) bb (go b) bc (go c) + + Node4 ba a bb b bc c bd d -> + Node4 ba (go a) bb (go b) bc (go c) bd (go d) + + Leaf2 ba a bb b -> + let !a' = f ba a + !b' = f bb b + + in Leaf2 ba a' bb b' + + Leaf3 ba a bb b bc c -> + let !a' = f ba a + !b' = f bb b + !c' = f bc c + + in Leaf3 ba a' bb b' bc c' + + Leaf4 ba a bb b bc c bd d -> + let !a' = f ba a + !b' = f bb b + !c' = f bc c + !d' = f bd d + + in Leaf4 ba a' bb b' bc c' bd d' + + Leaf1 ba a -> + Leaf1 ba $! f ba a + + Empty -> Empty + + + +{-# INLINE adjustRangeWithKey #-} +-- | \(\mathcal{O}(\log n + n_I)\). +-- Map a function over t'MBR's that match the 'Predicate' and their respective values. +adjustRangeWithKey :: Predicate -> (MBR -> a -> a) -> R2Tree a -> R2Tree a +adjustRangeWithKey (Predicate nodePred leafPred) f = go + where + {-# INLINE node #-} + node bx x + | nodePred bx = go x + | otherwise = x + + {-# INLINE leaf #-} + leaf bx x + | leafPred bx = f bx x + | otherwise = x + + go n = + case n of + Node2 ba a bb b -> + Node2 ba (node ba a) bb (node bb b) + + Node3 ba a bb b bc c -> + Node3 ba (node ba a) bb (node bb b) bc (node bc c) + + Node4 ba a bb b bc c bd d -> + Node4 ba (node ba a) bb (node bb b) bc (node bc c) bd (node bd d) + + Leaf2 ba a bb b -> + Leaf2 ba (leaf ba a) bb (leaf bb b) + + Leaf3 ba a bb b bc c -> + Leaf3 ba (leaf ba a) bb (leaf bb b) bc (leaf bc c) + + Leaf4 ba a bb b bc c bd d -> + Leaf4 ba (leaf ba a) bb (leaf bb b) bc (leaf bc c) bd (leaf bd d) + + Leaf1 ba a -> + Leaf1 ba (leaf ba a) + + Empty -> Empty + +{-# INLINE adjustRangeWithKey' #-} +-- | \(\mathcal{O}(\log n + n_I)\). +-- Map a function over t'MBR's that match the 'Predicate' and their respective values +-- and evaluate the results to WHNF. +adjustRangeWithKey' :: Predicate -> (MBR -> a -> a) -> R2Tree a -> R2Tree a +adjustRangeWithKey' (Predicate nodePred leafPred) f = go + where + {-# INLINE node #-} + node bx x + | nodePred bx = go x + | otherwise = x + + {-# INLINE leaf #-} + leaf bx x + | leafPred bx = f bx x + | otherwise = x + + go n = + case n of + Node2 ba a bb b -> + Node2 ba (node ba a) bb (node bb b) + + Node3 ba a bb b bc c -> + Node3 ba (node ba a) bb (node bb b) bc (node bc c) + + Node4 ba a bb b bc c bd d -> + Node4 ba (node ba a) bb (node bb b) bc (node bc c) bd (node bd d) + + Leaf2 ba a bb b -> + let !a' = leaf ba a + !b' = leaf bb b + + in Leaf2 ba a' bb b' + + Leaf3 ba a bb b bc c -> + let !a' = leaf ba a + !b' = leaf bb b + !c' = leaf bc c + + in Leaf3 ba a' bb b' bc c' + + Leaf4 ba a bb b bc c bd d -> + let !a' = leaf ba a + !b' = leaf bb b + !c' = leaf bc c + !d' = leaf bd d + + in Leaf4 ba a' bb b' bc c' bd d' + + Leaf1 ba a -> + Leaf1 ba $! leaf ba a + + Empty -> Empty + + + +-- | \(\mathcal{O}(n_R)\). +-- Fold left-to-right over all values. +foldl :: (b -> a -> b) -> b -> R2Tree a -> b +foldl f = go + where + go z n = + case n of + Node2 _ a _ b -> go (go z a) b + Node3 _ a _ b _ c -> go (go (go z a) b) c + Node4 _ a _ b _ c _ d -> go (go (go (go z a) b) c) d + + Leaf2 _ a _ b -> f (f z a) b + Leaf3 _ a _ b _ c -> f (f (f z a) b) c + Leaf4 _ a _ b _ c _ d -> f (f (f (f z a) b) c) d + + Leaf1 _ a -> f z a + Empty -> z + +-- | \(\mathcal{O}(n)\). +-- Fold left-to-right over all values, applying the operator function strictly. +foldl' :: (b -> a -> b) -> b -> R2Tree a -> b +foldl' f = go + where + {-# INLINE leaf #-} + leaf !z x = f z x + + go !z n = + case n of + Node2 _ a _ b -> go (go z a) b + Node3 _ a _ b _ c -> go (go (go z a) b) c + Node4 _ a _ b _ c _ d -> go (go (go (go z a) b) c) d + + Leaf2 _ a _ b -> leaf (leaf z a) b + Leaf3 _ a _ b _ c -> leaf (leaf (leaf z a) b) c + Leaf4 _ a _ b _ c _ d -> leaf (leaf (leaf (leaf z a) b) c) d + + Leaf1 _ a -> leaf z a + Empty -> z + + +-- | \(\mathcal{O}(n_R)\). +-- Fold left-to-right over all t'MBR's and their respective values. +foldlWithKey :: (b -> MBR -> a -> b) -> b -> R2Tree a -> b +foldlWithKey f = go + where + go z n = + case n of + Node2 _ a _ b -> go (go z a) b + Node3 _ a _ b _ c -> go (go (go z a) b) c + Node4 _ a _ b _ c _ d -> go (go (go (go z a) b) c) d + + Leaf2 ba a bb b -> f (f z ba a) bb b + Leaf3 ba a bb b bc c -> f (f (f z ba a) bb b) bc c + Leaf4 ba a bb b bc c bd d -> f (f (f (f z ba a) bb b) bc c) bd d + + Leaf1 ba a -> f z ba a + Empty -> z + +-- | \(\mathcal{O}(n)\). +-- Fold left-to-right over all t'MBR's and their respective values, +-- applying the operator function strictly. +foldlWithKey' :: (b -> MBR -> a -> b) -> b -> R2Tree a -> b +foldlWithKey' f = go + where + {-# INLINE leaf #-} + leaf !z bx x = f z bx x + + go z n = + case n of + Node2 _ a _ b -> go (go z a) b + Node3 _ a _ b _ c -> go (go (go z a) b) c + Node4 _ a _ b _ c _ d -> go (go (go (go z a) b) c) d + + Leaf2 ba a bb b -> leaf (leaf z ba a) bb b + Leaf3 ba a bb b bc c -> leaf (leaf (leaf z ba a) bb b) bc c + Leaf4 ba a bb b bc c bd d -> leaf (leaf (leaf (leaf z ba a) bb b) bc c) bd d + + Leaf1 ba a -> leaf z ba a + Empty -> z + + +{-# INLINE foldlRangeWithKey #-} +-- | \(\mathcal{O}(\log n + n_{I_R})\). +-- Fold left-to-right over t'MBR's that match the 'Predicate' +-- and their respective values. +foldlRangeWithKey :: Predicate -> (b -> MBR -> a -> b) -> b -> R2Tree a -> b +foldlRangeWithKey (Predicate nodePred leafPred) f = go + where + {-# INLINE node #-} + node z bx x + | nodePred bx = go z x + | otherwise = z + + {-# INLINE leaf #-} + leaf z bx x + | leafPred bx = f z bx x + | otherwise = z + + go z n = + case n of + Node2 ba a bb b -> node (node z ba a) bb b + Node3 ba a bb b bc c -> node (node (node z ba a) bb b) bc c + Node4 ba a bb b bc c bd d -> node (node (node (node z ba a) bb b) bc c) bd d + + Leaf2 ba a bb b -> leaf (leaf z ba a) bb b + Leaf3 ba a bb b bc c -> leaf (leaf (leaf z ba a) bb b) bc c + Leaf4 ba a bb b bc c bd d -> leaf (leaf (leaf (leaf z ba a) bb b) bc c) bd d + + Leaf1 ba a -> leaf z ba a + Empty -> z + +{-# INLINE foldlRangeWithKey' #-} +-- | \(\mathcal{O}(\log n + n_I)\). +-- Fold left-to-right over t'MBR's that match the 'Predicate' +-- and their respective values, applying the operator function strictly. +foldlRangeWithKey' :: Predicate -> (b -> MBR -> a -> b) -> b -> R2Tree a -> b +foldlRangeWithKey' (Predicate nodePred leafPred) f = go + where + {-# INLINE node #-} + node z bx x + | nodePred bx = go z x + | otherwise = z + + {-# INLINE leaf #-} + leaf !z bx x + | leafPred bx = f z bx x + | otherwise = z + + go z n = + case n of + Node2 ba a bb b -> node (node z ba a) bb b + Node3 ba a bb b bc c -> node (node (node z ba a) bb b) bc c + Node4 ba a bb b bc c bd d -> node (node (node (node z ba a) bb b) bc c) bd d + + Leaf2 ba a bb b -> leaf (leaf z ba a) bb b + Leaf3 ba a bb b bc c -> leaf (leaf (leaf z ba a) bb b) bc c + Leaf4 ba a bb b bc c bd d -> leaf (leaf (leaf (leaf z ba a) bb b) bc c) bd d + + Leaf1 ba a -> leaf z ba a + Empty -> z + + + +-- | \(\mathcal{O}(n_L)\). +-- Fold right-to-left over all values. +foldr :: (a -> b -> b) -> b -> R2Tree a -> b +foldr f = go + where + go z n = + case n of + Node2 _ a _ b -> go (go z b) a + Node3 _ a _ b _ c -> go (go (go z c) b) a + Node4 _ a _ b _ c _ d -> go (go (go (go z d) c) b) a + + Leaf2 _ a _ b -> f a (f b z) + Leaf3 _ a _ b _ c -> f a (f b (f c z)) + Leaf4 _ a _ b _ c _ d -> f a (f b (f c (f d z))) + + Leaf1 _ a -> f a z + Empty -> z + +-- | \(\mathcal{O}(n)\). +-- Fold right-to-left over all values, applying the operator function strictly. +foldr' :: (a -> b -> b) -> b -> R2Tree a -> b +foldr' f = go + where + {-# INLINE leaf #-} + leaf x !z = f x z + + go z n = + case n of + Node2 _ a _ b -> go (go z b) a + Node3 _ a _ b _ c -> go (go (go z c) b) a + Node4 _ a _ b _ c _ d -> go (go (go (go z d) c) b) a + + Leaf2 _ a _ b -> leaf a (leaf b z) + Leaf3 _ a _ b _ c -> leaf a (leaf b (leaf c z)) + Leaf4 _ a _ b _ c _ d -> leaf a (leaf b (leaf c (leaf d z))) + + Leaf1 _ a -> leaf a z + Empty -> z + + +-- | \(\mathcal{O}(n_L)\). +-- Fold right-to-left over all t'MBR's and their respective values. +foldrWithKey :: (MBR -> a -> b -> b) -> b -> R2Tree a -> b +foldrWithKey f = go + where + go z n = + case n of + Node2 _ a _ b -> go (go z b) a + Node3 _ a _ b _ c -> go (go (go z c) b) a + Node4 _ a _ b _ c _ d -> go (go (go (go z d) c) b) a + + Leaf2 ba a bb b -> f ba a (f bb b z) + Leaf3 ba a bb b bc c -> f ba a (f bb b (f bc c z)) + Leaf4 ba a bb b bc c bd d -> f ba a (f bb b (f bc c (f bd d z))) + + Leaf1 ba a -> f ba a z + Empty -> z + +-- | \(\mathcal{O}(n)\). +-- Fold right-to-left over all t'MBR's and their respective values, +-- applying the operator function strictly. +foldrWithKey' :: (MBR -> a -> b -> b) -> b -> R2Tree a -> b +foldrWithKey' f = go + where + {-# INLINE leaf #-} + leaf bx x !z = f bx x z + + go z n = + case n of + Node2 _ a _ b -> go (go z b) a + Node3 _ a _ b _ c -> go (go (go z c) b) a + Node4 _ a _ b _ c _ d -> go (go (go (go z d) c) b) a + + Leaf2 ba a bb b -> leaf ba a (leaf bb b z) + Leaf3 ba a bb b bc c -> leaf ba a (leaf bb b (leaf bc c z)) + Leaf4 ba a bb b bc c bd d -> leaf ba a (leaf bb b (leaf bc c (leaf bd d z))) + + Leaf1 ba a -> leaf ba a z + Empty -> z + + +{-# INLINE foldrRangeWithKey #-} +-- | \(\mathcal{O}(\log n + n_{I_L})\). +-- Fold right-to-left over t'MBR's that match the 'Predicate' +-- and their respective values. +foldrRangeWithKey :: Predicate -> (MBR -> a -> b -> b) -> b -> R2Tree a -> b +foldrRangeWithKey (Predicate nodePred leafPred) f = go + where + {-# INLINE node #-} + node z bx x + | nodePred bx = go z x + | otherwise = z + + {-# INLINE leaf #-} + leaf bx x z + | leafPred bx = f bx x z + | otherwise = z + + go z n = + case n of + Node2 ba a bb b -> node (node z bb b) ba a + Node3 ba a bb b bc c -> node (node (node z bc c) bb b) ba a + Node4 ba a bb b bc c bd d -> node (node (node (node z bd d) bc c) bb b) ba a + + Leaf2 ba a bb b -> leaf ba a (leaf bb b z) + Leaf3 ba a bb b bc c -> leaf ba a (leaf bb b (leaf bc c z)) + Leaf4 ba a bb b bc c bd d -> leaf ba a (leaf bb b (leaf bc c (leaf bd d z))) + + Leaf1 ba a -> leaf ba a z + Empty -> z + +{-# INLINE foldrRangeWithKey' #-} +-- | \(\mathcal{O}(\log n + n_I)\). +-- Fold right-to-left over t'MBR's that match the 'Predicate' +-- and their respective values, applying the operator function strictly. +foldrRangeWithKey' :: Predicate -> (MBR -> a -> b -> b) -> b -> R2Tree a -> b +foldrRangeWithKey' (Predicate nodePred leafPred) f = go + where + {-# INLINE node #-} + node z bx x + | nodePred bx = go z x + | otherwise = z + + {-# INLINE leaf #-} + leaf bx x !z + | leafPred bx = f bx x z + | otherwise = z + + go z n = + case n of + Node2 ba a bb b -> node (node z bb b) ba a + Node3 ba a bb b bc c -> node (node (node z bc c) bb b) ba a + Node4 ba a bb b bc c bd d -> node (node (node (node z bd d) bc c) bb b) ba a + + Leaf2 ba a bb b -> leaf ba a (leaf bb b z) + Leaf3 ba a bb b bc c -> leaf ba a (leaf bb b (leaf bc c z)) + Leaf4 ba a bb b bc c bd d -> leaf ba a (leaf bb b (leaf bc c (leaf bd d z))) + + Leaf1 ba a -> leaf ba a z + Empty -> z + + + +-- | \(\mathcal{O}(n_M)\). +-- Map each value to a monoid and combine the results. +foldMap :: Monoid m => (a -> m) -> R2Tree a -> m +foldMap f = go + where + go n = + case n of + Node2 _ a _ b -> go a <> go b + Node3 _ a _ b _ c -> go a <> go b <> go c + Node4 _ a _ b _ c _ d -> go a <> go b <> go c <> go d + + Leaf2 _ a _ b -> f a <> f b + Leaf3 _ a _ b _ c -> f a <> f b <> f c + Leaf4 _ a _ b _ c _ d -> f a <> f b <> f c <> f d + + Leaf1 _ a -> f a + Empty -> mempty + + +-- | \(\mathcal{O}(n_M)\). +-- Map each t'MBR' and its respective value to a monoid and combine the results. +foldMapWithKey :: Monoid m => (MBR -> a -> m) -> R2Tree a -> m +foldMapWithKey f = go + where + go n = + case n of + Node2 _ a _ b -> go a <> go b + Node3 _ a _ b _ c -> go a <> go b <> go c + Node4 _ a _ b _ c _ d -> go a <> go b <> go c <> go d + + Leaf2 ba a bb b -> f ba a <> f bb b + Leaf3 ba a bb b bc c -> f ba a <> f bb b <> f bc c + Leaf4 ba a bb b bc c bd d -> f ba a <> f bb b <> f bc c <> f bd d + + Leaf1 ba a -> f ba a + Empty -> mempty + + +{-# INLINE foldMapRangeWithKey #-} +-- | \(\mathcal{O}(\log n + n_{I_M})\). +-- Map each t'MBR' that matches the 'Predicate' and its respective value to a monoid +-- and combine the results. +foldMapRangeWithKey :: Monoid m => Predicate -> (MBR -> a -> m) -> R2Tree a -> m +foldMapRangeWithKey (Predicate nodePred leafPred) f = go + where + {-# INLINE node #-} + node bx x + | nodePred bx = go x + | otherwise = mempty + + {-# INLINE leaf #-} + leaf bx x + | leafPred bx = f bx x + | otherwise = mempty + + go n = + case n of + Node2 ba a bb b -> node ba a <> node bb b + Node3 ba a bb b bc c -> node ba a <> node bb b <> node bc c + Node4 ba a bb b bc c bd d -> node ba a <> node bb b <> node bc c <> node bd d + + Leaf2 ba a bb b -> leaf ba a <> leaf bb b + Leaf3 ba a bb b bc c -> leaf ba a <> leaf bb b <> leaf bc c + Leaf4 ba a bb b bc c bd d -> leaf ba a <> leaf bb b <> leaf bc c <> leaf bd d + + Leaf1 ba a -> leaf ba a + Empty -> mempty + + + +-- | \(\mathcal{O}(n)\). +-- Map each value to an action, evaluate the actions left-to-right and +-- collect the results. +traverse :: Applicative f => (a -> f b) -> R2Tree a -> f (R2Tree b) +traverse f = go + where + go n = + case n of + Node2 ba a bb b -> + liftA2 (\a' b' -> Node2 ba a' bb b') + (go a) (go b) + + Node3 ba a bb b bc c -> + liftA2 (\a' b' c' -> Node3 ba a' bb b' bc c') + (go a) (go b) <*> go c + + Node4 ba a bb b bc c bd d -> + liftA2 (\a' b' c' d' -> Node4 ba a' bb b' bc c' bd d') + (go a) (go b) <*> go c <*> go d + + Leaf2 ba a bb b -> + liftA2 (\a' b' -> Leaf2 ba a' bb b') + (f a) (f b) + + Leaf3 ba a bb b bc c -> + liftA2 (\a' b' c' -> Leaf3 ba a' bb b' bc c') + (f a) (f b) <*> f c + + Leaf4 ba a bb b bc c bd d -> + liftA2 (\a' b' c' d' -> Leaf4 ba a' bb b' bc c' bd d') + (f a) (f b) <*> f c <*> f d + + Leaf1 ba a -> + Leaf1 ba <$> f a + + Empty -> pure Empty + + +-- | \(\mathcal{O}(n)\). +-- Map each t'MBR' and its respective value to an action, +-- evaluate the actions left-to-right and collect the results. +traverseWithKey :: Applicative f => (MBR -> a -> f b) -> R2Tree a -> f (R2Tree b) +traverseWithKey f = go + where + go n = + case n of + Node2 ba a bb b -> + liftA2 (\a' b' -> Node2 ba a' bb b') + (go a) (go b) + + Node3 ba a bb b bc c -> + liftA2 (\a' b' c' -> Node3 ba a' bb b' bc c') + (go a) (go b) <*> go c + + Node4 ba a bb b bc c bd d -> + liftA2 (\a' b' c' d' -> Node4 ba a' bb b' bc c' bd d') + (go a) (go b) <*> go c <*> go d + + Leaf2 ba a bb b -> + liftA2 (\a' b' -> Leaf2 ba a' bb b') + (f ba a) (f bb b) + + Leaf3 ba a bb b bc c -> + liftA2 (\a' b' c' -> Leaf3 ba a' bb b' bc c') + (f ba a) (f bb b) <*> f bc c + + Leaf4 ba a bb b bc c bd d -> + liftA2 (\a' b' c' d' -> Leaf4 ba a' bb b' bc c' bd d') + (f ba a) (f bb b) <*> f bc c <*> f bd d + + Leaf1 ba a -> + Leaf1 ba <$> f ba a + + Empty -> pure Empty + + +{-# INLINE traverseRangeWithKey #-} +-- | \(\mathcal{O}(\log n + n_I)\). +-- Map each t'MBR' that matches the 'Predicate' and its respective value to an action, +-- evaluate the actions left-to-right and collect the results. +traverseRangeWithKey + :: Applicative f => Predicate -> (MBR -> a -> f a) -> R2Tree a -> f (R2Tree a) +traverseRangeWithKey (Predicate nodePred leafPred) f = go + where + {-# INLINE node #-} + node bx x + | nodePred bx = go x + | otherwise = pure x + + {-# INLINE leaf #-} + leaf bx x + | leafPred bx = f bx x + | otherwise = pure x + + go n = + case n of + Node2 ba a bb b -> + liftA2 (\a' b' -> Node2 ba a' bb b') + (node ba a) (node bb b) + + Node3 ba a bb b bc c -> + liftA2 (\a' b' c' -> Node3 ba a' bb b' bc c') + (node ba a) (node bb b) <*> node bc c + + Node4 ba a bb b bc c bd d -> + liftA2 (\a' b' c' d' -> Node4 ba a' bb b' bc c' bd d') + (node ba a) (node bb b) <*> node bc c <*> node bd d + + Leaf2 ba a bb b -> + liftA2 (\a' b' -> Leaf2 ba a' bb b') + (leaf ba a) (leaf bb b) + + Leaf3 ba a bb b bc c -> + liftA2 (\a' b' c' -> Leaf3 ba a' bb b' bc c') + (leaf ba a) (leaf bb b) <*> leaf bc c + + Leaf4 ba a bb b bc c bd d -> + liftA2 (\a' b' c' d' -> Leaf4 ba a' bb b' bc c' bd d') + (leaf ba a) (leaf bb b) <*> leaf bc c <*> leaf bd d + + Leaf1 ba a -> + Leaf1 ba <$> leaf ba a + + Empty -> pure Empty + + + +{-# INLINE union3MBR #-} +union3MBR :: MBR -> MBR -> MBR -> MBR +union3MBR ba bb bc = unionMBR (unionMBR ba bb) bc + +{-# INLINE union4MBR #-} +union4MBR :: MBR -> MBR -> MBR -> MBR -> MBR +union4MBR ba bb bc bd = unionMBR (unionMBR ba bb) (unionMBR bc bd) + + + +data Gut a = GutOne MBR (R2Tree a) + | GutTwo MBR (R2Tree a) MBR (R2Tree a) + +-- | \(\mathcal{O}(\log n)\). Insert a value into the tree. +-- +-- 'insertGut' uses the R-tree insertion algorithm with quadratic-cost splits. +-- Compared to 'insert' the resulting trees are of lower quality (see the +-- [Wikipedia article](https://en.wikipedia.org/w/index.php?title=R*-tree&oldid=1171720351#Performance) +-- for a graphic example). +insertGut :: MBR -> a -> R2Tree a -> R2Tree a +insertGut bx x t = + case insertGutRoot bx x t of + GutOne _ o -> o + GutTwo bl l br r -> Node2 bl l br r + + +insertGutRoot :: MBR -> a -> R2Tree a -> Gut a +insertGutRoot bx x n = + case n of + Node2 ba a bb b -> + let !(# be, e, !bz, !z #) = leastEnlargement2 bx ba a bb b + in case insertGut_ bx x be e of + GutOne bo o -> + GutOne (unionMBR bo bz) (Node2 bo o bz z) + + GutTwo bl l br r -> + GutOne (union3MBR bl br bz) (Node3 bl l br r bz z) + + Node3 ba a bb b bc c -> + let !(# be, e, !by, !y, !bz, !z #) = leastEnlargement3 bx ba a bb b bc c + in case insertGut_ bx x be e of + GutOne bo o -> + GutOne (union3MBR bo by bz) (Node3 bo o by y bz z) + + GutTwo bl l br r -> + GutOne (union4MBR bl br by bz) (Node4 bl l br r by y bz z) + + Node4 ba a bb b bc c bd d -> + let !(# be, e, !bw, !w, !by, !y, !bz, !z #) = leastEnlargement4 bx ba a bb b bc c bd d + in case insertGut_ bx x be e of + GutOne bo o -> + GutOne (union4MBR bo bw by bz) (Node4 bo o bw w by y bz z) + + GutTwo bl l br r -> + case quadSplit bl l br r bw w by y bz z of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bq q bs s) -> + GutTwo bl' (Node3 bm m bo o bp p) br' (Node2 bq q bs s) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bq q bs s) -> + GutTwo bl' (Node2 bm m bo o) br' (Node3 bp p bq q bs s) + + Leaf2 ba a bb b -> + GutOne (union3MBR ba bb bx) (Leaf3 ba a bb b bx x) + + Leaf3 ba a bb b bc c -> + GutOne (union4MBR ba bb bc bx) (Leaf4 ba a bb b bc c bx x) + + Leaf4 ba a bb b bc c bd d -> + case quadSplit ba a bb b bc c bd d bx x of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bq q bs s) -> + GutTwo bl' (Leaf3 bm m bo o bp p) br' (Leaf2 bq q bs s) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bq q bs s) -> + GutTwo bl' (Leaf2 bm m bo o) br' (Leaf3 bp p bq q bs s) + + Leaf1 ba a -> + GutOne (unionMBR ba bx) (Leaf2 ba a bx x) + + Empty -> + GutOne bx (Leaf1 bx x) + + +insertGut_ :: MBR -> a -> MBR -> R2Tree a -> Gut a +insertGut_ bx x = go + where + go bn n = + case n of + Node2 ba a bb b -> + let !(# be, e, !bz, !z #) = leastEnlargement2 bx ba a bb b + in case go be e of + GutOne bo o -> + GutOne (unionMBR bo bz) (Node2 bo o bz z) + + GutTwo bl l br r -> + GutOne (union3MBR bl br bz) (Node3 bl l br r bz z) + + Node3 ba a bb b bc c -> + let !(# be, e, !by, !y, !bz, !z #) = leastEnlargement3 bx ba a bb b bc c + in case go be e of + GutOne bo o -> + GutOne (union3MBR bo by bz) (Node3 bo o by y bz z) + + GutTwo bl l br r -> + GutOne (union4MBR bl br by bz) (Node4 bl l br r by y bz z) + + Node4 ba a bb b bc c bd d -> + let !(# be, e, !bw, !w, !by, !y, !bz, !z #) = leastEnlargement4 bx ba a bb b bc c bd d + in case go be e of + GutOne bo o -> + GutOne (union4MBR bo bw by bz) (Node4 bo o bw w by y bz z) + + GutTwo bl l br r -> + case quadSplit bl l br r bw w by y bz z of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bq q bs s) -> + GutTwo bl' (Node3 bm m bo o bp p) br' (Node2 bq q bs s) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bq q bs s) -> + GutTwo bl' (Node2 bm m bo o) br' (Node3 bp p bq q bs s) + + Leaf2 ba a bb b -> + GutOne (unionMBR bn bx) (Leaf3 ba a bb b bx x) + + Leaf3 ba a bb b bc c -> + GutOne (unionMBR bn bx) (Leaf4 ba a bb b bc c bx x) + + Leaf4 ba a bb b bc c bd d -> + case quadSplit ba a bb b bc c bd d bx x of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bq q bs s) -> + GutTwo bl' (Leaf3 bm m bo o bp p) br' (Leaf2 bq q bs s) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bq q bs s) -> + GutTwo bl' (Leaf2 bm m bo o) br' (Leaf3 bp p bq q bs s) + + Leaf1 ba a -> + GutOne (unionMBR ba bn) (Leaf2 ba a bx x) + + Empty -> + GutOne bn (Leaf1 bx x) + + + +insertGutRootNode :: MBR -> R2Tree a -> Int -> R2Tree a -> Gut a +insertGutRootNode bx x depth n = + case n of + Node2 ba a bb b + | depth <= 0 -> + GutOne (union3MBR ba bb bx) (Node3 ba a bb b bx x) + + | otherwise -> + let !(# be, e, !bz, !z #) = leastEnlargement2 bx ba a bb b + in case insertGutNode bx x (depth - 1) be e of + GutOne bo o -> + GutOne (unionMBR bo bz) (Node2 bo o bz z) + + GutTwo bl l br r -> + GutOne (union3MBR bl br bz) (Node3 bl l br r bz z) + + Node3 ba a bb b bc c + | depth <= 0 -> + GutOne (union4MBR ba bb bc bx) (Node4 ba a bb b bc c bx x) + + | otherwise -> + let !(# be, e, !by, !y, !bz, !z #) = leastEnlargement3 bx ba a bb b bc c + in case insertGutNode bx x (depth - 1) be e of + GutOne bo o -> + GutOne (union3MBR bo by bz) (Node3 bo o by y bz z) + + GutTwo bl l br r -> + GutOne (union4MBR bl br by bz) (Node4 bl l br r by y bz z) + + Node4 ba a bb b bc c bd d + | depth <= 0 -> + case quadSplit ba a bb b bc c bd d bx x of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bq q bs s) -> + GutTwo bl' (Node3 bm m bo o bp p) br' (Node2 bq q bs s) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bq q bs s) -> + GutTwo bl' (Node2 bm m bo o) br' (Node3 bp p bq q bs s) + + | otherwise -> + let !(# be, e, !bw, !w, !by, !y, !bz, !z #) = leastEnlargement4 bx ba a bb b bc c bd d + in case insertGutNode bx x (depth - 1) be e of + GutOne bo o -> + GutOne (union4MBR bo bw by bz) (Node4 bo o bw w by y bz z) + + GutTwo bl l br r -> + case quadSplit bl l br r bw w by y bz z of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bq q bs s) -> + GutTwo bl' (Node3 bm m bo o bp p) br' (Node2 bq q bs s) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bq q bs s) -> + GutTwo bl' (Node2 bm m bo o) br' (Node3 bp p bq q bs s) + + _ -> errorWithoutStackTrace "Data.R2Tree.Float.Internal.insertGutRootNode: reached a leaf" + +insertGutNode :: MBR -> R2Tree a -> Int -> MBR -> R2Tree a -> Gut a +insertGutNode bx x = go + where + go depth bn n = + case n of + Node2 ba a bb b + | depth <= 0 -> + GutOne (unionMBR bn bx) (Node3 ba a bb b bx x) + + | otherwise -> + let !(# be, e, !bz, !z #) = leastEnlargement2 bx ba a bb b + in case go (depth - 1) be e of + GutOne bo o -> + GutOne (unionMBR bo bz) (Node2 bo o bz z) + + GutTwo bl l br r -> + GutOne (union3MBR bl br bz) (Node3 bl l br r bz z) + + Node3 ba a bb b bc c + | depth <= 0 -> + GutOne (unionMBR bn bx) (Node4 ba a bb b bc c bx x) + + | otherwise -> + let !(# be, e, !by, !y, !bz, !z #) = leastEnlargement3 bx ba a bb b bc c + in case go (depth - 1) be e of + GutOne bo o -> + GutOne (union3MBR bo by bz) (Node3 bo o by y bz z) + + GutTwo bl l br r -> + GutOne (union4MBR bl br by bz) (Node4 bl l br r by y bz z) + + Node4 ba a bb b bc c bd d + | depth <= 0 -> + case quadSplit ba a bb b bc c bd d bx x of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bq q bs s) -> + GutTwo bl' (Node3 bm m bo o bp p) br' (Node2 bq q bs s) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bq q bs s) -> + GutTwo bl' (Node2 bm m bo o) br' (Node3 bp p bq q bs s) + + | otherwise -> + let !(# be, e, !bw, !w, !by, !y, !bz, !z #) = leastEnlargement4 bx ba a bb b bc c bd d + in case go (depth - 1) be e of + GutOne bo o -> + GutOne (union4MBR bo bw by bz) (Node4 bo o bw w by y bz z) + + GutTwo bl l br r -> + case quadSplit bl l br r bw w by y bz z of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bq q bs s) -> + GutTwo bl' (Node3 bm m bo o bp p) br' (Node2 bq q bs s) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bq q bs s) -> + GutTwo bl' (Node2 bm m bo o) br' (Node3 bp p bq q bs s) + + _ -> errorWithoutStackTrace "Data.R2Tree.Float.Internal.insertGutNode: reached a leaf" + + + +{-# INLINE enlargement #-} +-- as in (adding A to B) +enlargement :: MBR -> MBR -> Float +enlargement bx ba = areaMBR (unionMBR ba bx) - areaMBR ba + +leastEnlargement2 :: MBR -> MBR -> a -> MBR -> a -> (# MBR, a, MBR, a #) +leastEnlargement2 bx ba a bb b = + let aw = (# ba, a, bb, b #) + bw = (# bb, b, ba, a #) + + in case enlargement bx ba `compare` enlargement bx bb of + GT -> bw + LT -> aw + EQ | areaMBR ba <= areaMBR bb -> aw + | otherwise -> bw + +leastEnlargement3 + :: MBR -> MBR -> a -> MBR -> a -> MBR -> a -> (# MBR, a, MBR, a, MBR, a #) +leastEnlargement3 bx ba a bb b bc c = + let aw = let !(# be, e, by, y #) = leastEnlargement2 bx ba a bc c + in (# be, e, by, y, bb, b #) + + bw = let !(# be, e, by, y #) = leastEnlargement2 bx bb b bc c + in (# be, e, by, y, ba, a #) + + in case enlargement bx ba `compare` enlargement bx bb of + GT -> bw + LT -> aw + EQ | areaMBR ba <= areaMBR bb -> aw + | otherwise -> bw + +leastEnlargement4 + :: MBR -> MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a + -> (# MBR, a, MBR, a, MBR, a, MBR, a #) +leastEnlargement4 bx ba a bb b bc c bd d = + let !(# be, e, bn, n #) = leastEnlargement2 bx ba a bb b + !(# bf, f, bo, o #) = leastEnlargement2 bx bc c bd d + !(# bg, g, bp, p #) = leastEnlargement2 bx be e bf f + + in (# bg, g, bn, n, bo, o, bp, p #) + + + +data L2 a = L2 !MBR !MBR a !MBR a + +data L3 a = L3 !MBR !MBR a !MBR a !MBR a + +data Q1 a = Q1L !(L2 a) !MBR a + | Q1R !MBR a !(L2 a) + +data Q2 a = Q2L !(L3 a) !MBR a + | Q2M !(L2 a) !(L2 a) + | Q2R !MBR a !(L3 a) + +data Q3 a = Q3L !(L3 a) !(L2 a) + | Q3R !(L2 a) !(L3 a) + + + +quadSplit :: MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a -> Q3 a +quadSplit ba a bb b bc c bd d be e = + let !(# bl, l, br, r, bx, x, by, y, bz, z #) = pickSeeds ba a bb b bc c bd d be e + !(# q1, bv, v, bw, w #) = distribute3 bl l br r bx x by y bz z + !(# q2, bu, u #) = distribute2 q1 bv v bw w + + in distribute1 q2 bu u + + + +pickSeeds + :: MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a + -> (# MBR, a, MBR, a, MBR, a, MBR, a, MBR, a #) +pickSeeds ba a bb b bc c bd d be e = + let waste bx by = areaMBR (unionMBR bx by) - areaMBR bx - areaMBR by + + align x@(# bw, _, bx, _, _, _, _, _, _, _ #) + y@(# by, _, bz, _, _, _, _, _, _, _ #) + | waste bw bx > waste by bz = x + | otherwise = y + + in align (# ba, a, bb, b, bc, c, bd, d, be, e #) + ( align (# ba, a, bc, c, bb, b, bd, d, be, e #) + ( align (# ba, a, bd, d, bb, b, bc, c, be, e #) + ( align (# ba, a, be, e, bb, b, bc, c, bd, d #) + ( align (# bb, b, bc, c, ba, a, bd, d, be, e #) + ( align (# bb, b, bd, d, ba, a, bc, c, be, e #) + ( align (# bb, b, be, e, ba, a, bc, c, bd, d #) + ( align (# bc, c, bd, d, ba, a, bb, b, be, e #) + ( align (# bc, c, be, e, ba, a, bb, b, bd, d #) + (# bd, d, be, e, ba, a, bb, b, bc, c #) )))))))) + + + +distribute3 + :: MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a -> (# Q1 a, MBR, a, MBR, a #) +distribute3 bl l br r bx x by y bz z = + let delta ba = abs (enlargement ba bl - enlargement ba br) + + !(# be, !e, !bu, !u, !bv, !v #) = if delta bx >= delta by + then if delta bx >= delta bz + then (# bx, x, by, y, bz, z #) + else (# bz, z, bx, x, by, y #) + + else if delta by >= delta bz + then (# by, y, bx, x, bz, z #) + else (# bz, z, bx, x, by, y #) + + lw = Q1L (L2 (unionMBR bl be) bl l be e) br r + + rw = Q1R bl l (L2 (unionMBR br be) br r be e) + + !q1 = case enlargement be bl `compare` enlargement be br of + GT -> rw + LT -> lw + EQ | areaMBR bl < areaMBR br -> lw + | otherwise -> rw + + in (# q1, bu, u, bv, v #) + + + +distribute2 :: Q1 a -> MBR -> a -> MBR -> a -> (# Q2 a, MBR, a #) +distribute2 q bx x by y = + let delta bl br bd = abs (enlargement bd bl - enlargement bd br) + in case q of + Q1L l@(L2 bl ba a bb b) br r -> + let !(# be, !e, !bz, !z #) | delta bl br bx >= delta bl br by = (# bx, x, by, y #) + | otherwise = (# by, y, bx, x #) + + lw = Q2L (L3 (unionMBR bl be) ba a bb b be e) br r + + rw = Q2M l (L2 (unionMBR br be) br r be e) + + !q2 = case enlargement be bl `compare` enlargement be br of + GT -> rw + LT -> lw + EQ | areaMBR bl <= areaMBR br -> lw + | otherwise -> rw + + in (# q2, bz, z #) + + Q1R bl l r@(L2 br ba a bb b) -> + let !(# be, !e, !bz, !z #) | delta bl br bx >= delta bl br by = (# bx, x, by, y #) + | otherwise = (# by, y, bx, x #) + + lw = Q2M (L2 (unionMBR bl be) bl l be e) r + + rw = Q2R bl l (L3 (unionMBR br be) ba a bb b be e) + + !q2 = case enlargement be bl `compare` enlargement be br of + GT -> rw + LT -> lw + EQ | areaMBR bl <= areaMBR br -> lw + | otherwise -> rw + + in (# q2, bz, z #) + + +distribute1 :: Q2 a -> MBR -> a -> Q3 a +distribute1 q bx x = + case q of + Q2M l@(L2 bl ba a bb b) r@(L2 br bc c bd d) -> + let lw = Q3L (L3 (unionMBR bl bx) ba a bb b bx x) r + + rw = Q3R l (L3 (unionMBR br bx) bc c bd d bx x) + + in case enlargement bx bl `compare` enlargement bx br of + GT -> rw + LT -> lw + EQ | areaMBR bl <= areaMBR br -> lw + | otherwise -> rw + + Q2L l br r -> Q3L l (L2 (unionMBR br bx) br r bx x) + + Q2R bl l r -> Q3R (L2 (unionMBR bl bx) bl l bx x) r + + + +data Carry a = CarryLeaf MBR a + | CarryNode Int MBR (R2Tree a) + +data Ins a = InsOne MBR (R2Tree a) + | InsCarry Word (Carry a) MBR (R2Tree a) + | InsTwo Word MBR (R2Tree a) MBR (R2Tree a) + +-- | \(\mathcal{O}(\log n)\). Insert a value into the tree. +-- +-- 'insert' uses the R*-tree insertion algorithm. +insert :: MBR -> a -> R2Tree a -> R2Tree a +insert bx x n = + case n of + Node2 ba a bb b -> + let add f bg g bh h = + let !(# be, e, !bz, !z #) = leastEnlargement2 bx bg g bh h + in case f be e of + InsOne bo o -> Node2 bo o bz z + InsCarry mask carry bo o -> + case carry of + CarryLeaf bu u -> + add (insert_ mask bu u 0) bo o bz z + + CarryNode depth bu u -> + add (insertNode mask depth bu u 0) bo o bz z + + InsTwo _ bl l br r -> Node3 bl l br r bz z + + in add (insert_ 0 bx x 0) ba a bb b + + Node3 ba a bb b bc c -> + let add f bg g bh h bi i = + let !(# be, e, !by, !y, !bz, !z #) = leastEnlargement3 bx bg g bh h bi i + in case f be e of + InsOne bo o -> Node3 bo o by y bz z + InsCarry mask carry bo o -> + case carry of + CarryLeaf bu u -> + add (insert_ mask bu u 0) bo o by y bz z + + CarryNode depth bu u -> + add (insertNode mask depth bu u 0) bo o by y bz z + + InsTwo _ bl l br r -> Node4 bl l br r by y bz z + + in add (insert_ 0 bx x 0) ba a bb b bc c + + Node4 ba a bb b bc c bd d -> + let add f bg g bh h bi i bj j = + let !(# be, e, !bw, !w, !by, !y, !bz, !z #) = leastEnlargement4 bx bg g bh h bi i bj j + in case f be e of + InsOne bo o -> Node4 bo o bw w by y bz z + InsCarry mask carry bo o -> + case carry of + CarryLeaf bu u -> + add (insert_ mask bu u 0) bo o bw w by y bz z + + CarryNode depth bu u -> + add (insertNode mask depth bu u 0) bo o bw w by y bz z + + InsTwo _ bl l br r -> + case sortSplit bl l br r bw w by y bz z of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bs s bt t) -> + Node2 bl' (Node3 bm m bo o bp p) br' (Node2 bs s bt t) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bs s bt t) -> + Node2 bl' (Node2 bm m bo o) br' (Node3 bp p bs s bt t) + + in add (insert_ 0 bx x 0) ba a bb b bc c bd d + + Leaf2 ba a bb b -> Leaf3 ba a bb b bx x + Leaf3 ba a bb b bc c -> Leaf4 ba a bb b bc c bx x + Leaf4 ba a bb b bc c bd d -> + case sortSplit ba a bb b bc c bd d bx x of + Q3L (L3 bl bu u bv v bw w) (L2 br by y bz z) -> + Node2 bl (Leaf3 bu u bv v bw w) br (Leaf2 by y bz z) + + Q3R (L2 bl bu u bv v) (L3 br bw w by y bz z) -> + Node2 bl (Leaf2 bu u bv v) br (Leaf3 bw w by y bz z) + + Leaf1 ba a -> Leaf2 ba a bx x + Empty -> Leaf1 bx x + + + +insert_ :: Word -> MBR -> a -> Int -> MBR -> R2Tree a -> Ins a +insert_ mask bx x = go + where + go height bn n = + case n of + Node2 ba a bb b -> + let !(# be, e, !bz, !z #) = leastEnlargement2 bx ba a bb b + in case go (height + 1) be e of + InsOne bo o -> InsOne (unionMBR bo bz) (Node2 bo o bz z) + InsCarry mask' carry bo o -> + InsCarry mask' carry (unionMBR bo bz) (Node2 bo o bz z) + + InsTwo _ bl l br r -> + InsOne (union3MBR bl br bz) (Node3 bl l br r bz z) + + Node3 ba a bb b bc c -> + let !(# be, e, !by, !y, !bz, !z #) = leastEnlargement3 bx ba a bb b bc c + in case go (height + 1) be e of + InsOne bo o -> + InsOne (union3MBR bo by bz) (Node3 bo o by y bz z) + + InsCarry mask' carry bo o -> + InsCarry mask' carry (union3MBR bo by bz) (Node3 bo o by y bz z) + + InsTwo _ bl l br r -> + InsOne (union4MBR bl br by bz) (Node4 bl l br r by y bz z) + + Node4 ba a bb b bc c bd d -> + let !(# be, e, !bw, !w, !by, !y, !bz, !z #) = leastEnlargement4 bx ba a bb b bc c bd d + in case go (height + 1) be e of + InsOne bo o -> + InsOne (union4MBR bo bw by bz) (Node4 bo o bw w by y bz z) + + InsCarry mask' carry bo o -> + InsCarry mask' carry (union4MBR bo bw by bz) (Node4 bo o bw w by y bz z) + + InsTwo _ bl l br r -> + let bit_ = 1 `unsafeShiftL` height + in case mask .&. bit_ of + 0 -> + case sortSplit bl l br r bw w by y bz z of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bs s bt t) -> + InsTwo mask bl' (Node3 bm m bo o bp p) br' (Node2 bs s bt t) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bs s bt t) -> + InsTwo mask bl' (Node2 bm m bo o) br' (Node3 bp p bs s bt t) + + _ -> + let !(# bm, m, bo, o, bp, p, bs, s, bt, t #) = + sort5Distance (unionMBR bn bx) bl l br r bw w by y bz z + + in InsCarry (mask .|. bit_) (CarryNode height bt t) + (union4MBR bm bo bp bs) (Node4 bm m bo o bp p bs s) + + Leaf2 ba a bb b -> + InsOne (union3MBR ba bb bx) (Leaf3 ba a bb b bx x) + + Leaf3 ba a bb b bc c -> + InsOne (union4MBR ba bb bc bx) (Leaf4 ba a bb b bc c bx x) + + Leaf4 ba a bb b bc c bd d -> + let bit_ = 1 `unsafeShiftL` height + in case mask .&. bit_ of + 0 -> + case sortSplit ba a bb b bc c bd d bx x of + Q3L (L3 bl bu u bv v bw w) (L2 br by y bz z) -> + InsTwo mask bl (Leaf3 bu u bv v bw w) br (Leaf2 by y bz z) + + Q3R (L2 bl bu u bv v) (L3 br bw w by y bz z) -> + InsTwo mask bl (Leaf2 bu u bv v) br (Leaf3 bw w by y bz z) + + _ -> + let !(# bu, u, bv, v, bw, w, by, y, bz, z #) = + sort5Distance (unionMBR bn bx) ba a bb b bc c bd d bx x + + in InsCarry (mask .|. bit_) (CarryLeaf bz z) + (union4MBR bu bv bw by) (Leaf4 bu u bv v bw w by y) + + Leaf1 ba a -> + InsOne (unionMBR ba bx) (Leaf2 ba a bx x) + + Empty -> + InsOne bx (Leaf1 bx x) + + +insertNode :: Word -> Int -> MBR -> R2Tree a -> Int -> MBR -> R2Tree a -> Ins a +insertNode mask depth bx x = go + where + go height bn n = + case n of + Node2 ba a bb b + | height >= depth -> + let !(# be, e, !bz, !z #) = leastEnlargement2 bx ba a bb b + in case go (height + 1) be e of + InsOne bo o -> InsOne (unionMBR bo bz) (Node2 bo o bz z) + InsCarry mask' carry bo o -> + InsCarry mask' carry (unionMBR bo bz) (Node2 bo o bz z) + + InsTwo _ bl l br r -> + InsOne (union3MBR bl br bz) (Node3 bl l br r bz z) + + | otherwise -> + InsOne (unionMBR bn bx) (Node3 ba a bb b bx x) + + Node3 ba a bb b bc c + | height >= depth -> + let !(# be, e, !by, !y, !bz, !z #) = leastEnlargement3 bx ba a bb b bc c + in case go (height + 1) be e of + InsOne bo o -> + InsOne (union3MBR bo by bz) (Node3 bo o by y bz z) + + InsCarry mask' carry bo o -> + InsCarry mask' carry (union3MBR bo by bz) (Node3 bo o by y bz z) + + InsTwo _ bl l br r -> + InsOne (union4MBR bl br by bz) (Node4 bl l br r by y bz z) + + | otherwise -> + InsOne (unionMBR bn bx) (Node4 ba a bb b bc c bx x) + + Node4 ba a bb b bc c bd d + | height >= depth -> + let !(# be, e, !bw, !w, !by, !y, !bz, !z #) = leastEnlargement4 bx ba a bb b bc c bd d + in case go (height + 1) be e of + InsOne bo o -> + InsOne (union4MBR bo bw by bz) (Node4 bo o bw w by y bz z) + + InsCarry mask' carry bo o -> + InsCarry mask' carry (union4MBR bo bw by bz) (Node4 bo o bw w by y bz z) + + InsTwo _ bl l br r -> + let bit_ = 1 `unsafeShiftL` height + in case mask .&. bit_ of + 0 -> + case sortSplit bl l br r bw w by y bz z of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bs s bt t) -> + InsTwo mask bl' (Node3 bm m bo o bp p) br' (Node2 bs s bt t) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bs s bt t) -> + InsTwo mask bl' (Node2 bm m bo o) br' (Node3 bp p bs s bt t) + + _ -> + let !(# bm, m, bo, o, bp, p, bs, s, bt, t #) = + sort5Distance (unionMBR bn bx) bl l br r bw w by y bz z + + in InsCarry (mask .|. bit_) (CarryNode height bt t) + (union4MBR bm bo bp bs) (Node4 bm m bo o bp p bs s) + + | otherwise -> + let bit_ = 1 `unsafeShiftL` height + in case mask .&. bit_ of + 0 -> + case sortSplit ba a bb b bc c bd d bx x of + Q3L (L3 bl' bm m bo o bp p) (L2 br' bs s bt t) -> + InsTwo mask bl' (Node3 bm m bo o bp p) br' (Node2 bs s bt t) + + Q3R (L2 bl' bm m bo o) (L3 br' bp p bs s bt t) -> + InsTwo mask bl' (Node2 bm m bo o) br' (Node3 bp p bs s bt t) + + _ -> + let !(# bm, m, bo, o, bp, p, bs, s, bt, t #) = + sort5Distance (unionMBR bn bx) ba a bb b bc c bd d bx x + + in InsCarry (mask .|. bit_) (CarryNode height bt t) + (union4MBR bm bo bp bs) (Node4 bm m bo o bp p bs s) + + + + _ -> errorWithoutStackTrace "Data.R2Tree.Float.Internal.insertNode: reached a leaf" + + + +sortSplit :: MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a -> Q3 a +sortSplit ba a bb b bc c bd d be e = + let v = sort5_ vertical ba a bb b bc c bd d be e + h = sort5_ horizontal ba a bb b bc c bd d be e + + vg = group v + hg = group h + + !(# al@(L3 bu _ _ _ _ _ _), ar@(L2 bv _ _ _ _) + , bl@(L2 bx _ _ _ _), br@(L3 by _ _ _ _ _ _) #) + | margins vg <= margins hg = vg + | otherwise = hg + + aw = Q3L al ar + bw = Q3R bl br + + in case overlapMBR bu bv `compare` overlapMBR bx by of + GT -> bw + LT -> aw + EQ | areaMBR bu + areaMBR bv <= areaMBR bx + areaMBR by -> aw + | otherwise -> bw + + + +sort5Distance + :: MBR + -> MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a -> MBR -> a + -> (# MBR, a, MBR, a, MBR, a, MBR, a, MBR, a #) +sort5Distance bx ka a kb b kc c kd d ke e = + sort5_ (distance bx) ka a kb b kc c kd d ke e + + + + +{-# INLINE horizontal #-} +horizontal :: MBR -> MBR -> Bool +horizontal (UnsafeMBR xmin _ xmax _) (UnsafeMBR xmin' _ xmax' _) = + case xmin `compare` xmin' of + GT -> False + LT -> True + EQ -> xmax <= xmax' + +{-# INLINE vertical #-} +vertical :: MBR -> MBR -> Bool +vertical (UnsafeMBR _ ymin _ ymax) (UnsafeMBR _ ymin' _ ymax') = + case ymin `compare` ymin' of + GT -> False + LT -> True + EQ -> ymax <= ymax' + +{-# INLINE distance #-} +distance :: MBR -> MBR -> MBR -> Bool +distance bx ba bb = distanceMBR bx ba <= distanceMBR bx bb + +{-# INLINE sort5_ #-} +sort5_ + :: (k -> k -> Bool) -- as in (A is smaller than B) + -> k -> a -> k -> a -> k -> a -> k -> a -> k -> a + -> (# k, a, k, a, k, a, k, a, k, a #) +sort5_ f ka a kb b kc c kd d ke e = + let swap kx x ky y + | f kx ky = (# kx, x, ky, y #) + | otherwise = (# ky, y, kx, x #) + + sort3 kw w kx x ky y kz z + | f kw ky = + if f kw kx + then (# kw, w, kx, x, ky, y, kz, z #) + else (# kx, x, kw, w, ky, y, kz, z #) + + | otherwise = + if f kw kz + then (# kx, x, ky, y, kw, w, kz, z #) + else (# kx, x, ky, y, kz, z, kw, w #) + + (# ka1, a1, kb1, b1 #) = swap ka a kb b + (# kc1, c1, kd1, d1 #) = swap kc c kd d + + (# ka2, (a2, kb2, b2), kc2, (c2, kd2, d2) #) = + swap ka1 (a1, kb1, b1) kc1 (c1, kd1, d1) + + (# ka3, a3, kc3, c3, kd3, d3, ke3, e3 #) = sort3 ke e ka2 a2 kc2 c2 kd2 d2 + + (# kb4, b4, kc4, c4, kd4, d4, ke4, e4 #) = sort3 kb2 b2 kc3 c3 kd3 d3 ke3 e3 + + in (# ka3, a3, kb4, b4, kc4, c4, kd4, d4, ke4, e4 #) + +{-# INLINE group #-} +group + :: (# MBR, a, MBR, a, MBR, a, MBR, a, MBR, a #) -> (# L3 a, L2 a, L2 a, L3 a #) +group (# ba, a, bb, b, bc, c, bd, d, be, e #) = + (# L3 (union3MBR ba bb bc) ba a bb b bc c, L2 (unionMBR bd be) bd d be e + , L2 (unionMBR ba bb) ba a bb b, L3 (union3MBR bd be bc) bd d be e bc c #) + +{-# INLINE margins #-} +margins :: (# L3 a, L2 a, L2 a, L3 a #) -> Float +margins (# L3 bw _ _ _ _ _ _, L2 bx _ _ _ _, L2 by _ _ _ _, L3 bz _ _ _ _ _ _ #) = + marginMBR bw + marginMBR bx + marginMBR by + marginMBR bz + + + +-- | \(\mathcal{O}(\log n)\). +-- Remove an entry stored under a given t'MBR', if one exists. +-- If multiple entries qualify, the leftmost one is removed. +-- +-- 'delete' uses the R-tree deletion algorithm with quadratic-cost splits. +delete :: MBR -> R2Tree a -> R2Tree a +delete bx s = + case delete_ bx 0 s of + DelOne _ o -> o + DelNone -> s + DelSome re _ o -> reintegrate 0 o re + DelRe re -> + case re of + ReCons _ _ n re' -> reintegrate (-1) n re' + ReLeaf ba a -> Leaf1 ba a + where + reintegrate height n re = + case re of + ReCons depth ba a re' -> + case insertGutRootNode ba a (depth + height) n of + GutOne _ o -> reintegrate height o re' + GutTwo bl l br r -> reintegrate (height + 1) (Node2 bl l br r) re' + + ReLeaf ba a -> + case insertGutRoot ba a n of + GutOne _ o -> o + GutTwo bl l br r -> Node2 bl l br r + + + +data Re a = ReCons Int MBR (R2Tree a) (Re a) + | ReLeaf MBR a + +data Del a = DelNone + | DelOne MBR (R2Tree a) + | DelSome (Re a) MBR (R2Tree a) + | DelRe (Re a) + +delete_ :: MBR -> Int -> R2Tree a -> Del a +delete_ bx = go + where + {-# INLINE cut2 #-} + cut2 depth next ba a bb b + | containsMBR ba bx = + case go (depth + 1) a of + DelNone -> next + DelOne bo o -> DelOne (unionMBR bo bb) (Node2 bo o bb b) + DelSome re bo o -> DelSome re (unionMBR bo bb) (Node2 bo o bb b) + DelRe re -> DelRe (ReCons depth bb b re) + + | otherwise = next + + {-# INLINE cut3 #-} + cut3 depth next ba a bb b bc c + | containsMBR ba bx = + case go (depth + 1) a of + DelNone -> next + DelOne bo o -> DelOne (union3MBR bo bb bc) (Node3 bo o bb b bc c) + DelSome re bo o -> DelSome re (union3MBR bo bb bc) (Node3 bo o bb b bc c) + DelRe re -> DelSome re (unionMBR bb bc) (Node2 bb b bc c) + + | otherwise = next + + {-# INLINE cut4 #-} + cut4 depth next ba a bb b bc c bd d + | containsMBR ba bx = + case go (depth + 1) a of + DelNone -> next + DelOne bo o -> DelOne (union4MBR bo bb bc bd) (Node4 bo o bb b bc c bd d) + DelSome re bo o -> DelSome re (union4MBR bo bb bc bd) (Node4 bo o bb b bc c bd d) + DelRe re -> DelSome re (union3MBR bb bc bd) (Node3 bb b bc c bd d) + + | otherwise = next + + {-# INLINE edge2 #-} + edge2 next ba bb b + | eqMBR ba bx = DelRe (ReLeaf bb b) + | otherwise = next + + {-# INLINE edge3 #-} + edge3 next ba bb b bc c + | eqMBR ba bx = DelOne (unionMBR bb bc) (Leaf2 bb b bc c) + | otherwise = next + + {-# INLINE edge4 #-} + edge4 next ba bb b bc c bd d + | eqMBR ba bx = DelOne (union3MBR bb bc bd) (Leaf3 bb b bc c bd d) + | otherwise = next + + go depth n = + case n of + Node2 ba a bb b -> + let dela = cut2 depth delb ba a bb b + delb = cut2 depth DelNone bb b ba a + + in dela + + Node3 ba a bb b bc c -> + let dela = cut3 depth delb ba a bb b bc c + delb = cut3 depth delc bb b ba a bc c + delc = cut3 depth DelNone bc c ba a bb b + + in dela + + Node4 ba a bb b bc c bd d -> + let dela = cut4 depth delb ba a bb b bc c bd d + delb = cut4 depth delc bb b ba a bc c bd d + delc = cut4 depth deld bc c ba a bb b bd d + deld = cut4 depth DelNone bd d ba a bb b bc c + + in dela + + Leaf2 ba a bb b -> + let dela = edge2 delb ba bb b + delb = edge2 DelNone bb ba a + + in dela + + Leaf3 ba a bb b bc c -> + let dela = edge3 delb ba bb b bc c + delb = edge3 delc bb ba a bc c + delc = edge3 DelNone bc ba a bb b + + in dela + + Leaf4 ba a bb b bc c bd d -> + let dela = edge4 delb ba bb b bc c bd d + delb = edge4 delc bb ba a bc c bd d + delc = edge4 deld bc ba a bb b bd d + deld = edge4 DelNone bd ba a bb b bc c + + in dela + + Leaf1 ba _ | eqMBR bx ba -> DelOne ba Empty + | otherwise -> DelNone + + Empty -> DelNone + + + + +quotCeil :: Int -> Int -> Int +quotCeil i d = let ~(p, q) = quotRem i d + in p + case q of + 0 -> 0 + _ -> 1 + +slices :: Int -> Int +slices r = ceiling (sqrt (fromIntegral (quotCeil r 4)) :: Float) + +partition1 :: Int -> [a] -> [(Int, [a])] +partition1 n_ = go + where + go xs = + let ~(n, before, after) = splitAt1 0 xs + in (n, before) : case after of + _:_ -> go after + [] -> [] + + splitAt1 n xs = + case xs of + [] -> (n, [], []) + x:ys + | n < n_ -> let ~(m, as, bs) = splitAt1 (n + 1) ys + in (m, x:as, bs) + + | [] <- ys -> (n + 1, xs, []) + | otherwise -> (n , [], xs) + + + +-- | \(\mathcal{O}(n \log n)\). Bulk-load a tree. +-- +-- 'bulkSTR' uses the Sort-Tile-Recursive algorithm. +bulkSTR :: [(MBR, a)] -> R2Tree a +bulkSTR xs = + case xs of + _:_:_ -> snd $ vertically (length xs) xs + [(ba, a)] -> Leaf1 ba a + [] -> Empty + where + horiCenter (UnsafeMBR xmin _ xmax _, _) = xmin + xmax + + vertCenter (UnsafeMBR _ ymin _ ymax, _) = ymin + ymax + + horizontally r as = + let s = slices r + in if s <= 1 + then base as + else compress . + fmap (uncurry vertically) $ + partition1 (r `quotCeil` s) (List.sortBy (compare `on` vertCenter) as) + + + vertically r as = + let s = slices r + in if s <= 1 + then base as + else compress . + fmap (uncurry horizontally) $ + partition1 (r `quotCeil` s) (List.sortBy (compare `on` horiCenter) as) + + compress (x : ys) = go (x :| ys) + where + go (a :| bs) = + case bs of + [] -> a + b:cs -> go (mend a b cs) + + compress [] = + errorWithoutStackTrace + "Data.R2Tree.Float.Internal.bulkSTR: zero-sized partition" + + mend (ba, a) (bb, b) cs = + case cs of + (bc, c) : (bd, d) : e : f : gs -> + (union4MBR ba bb bc bd, Node4 ba a bb b bc c bd d) <| mend e f gs + + (bc, c) : (bd, d) : (be, e) : [] -> + (union3MBR ba bb bc, Node3 ba a bb b bc c) :| + (unionMBR bd be, Node2 bd d be e) : [] + + (bc, c) : (bd, d) : [] -> + (union4MBR ba bb bc bd, Node4 ba a bb b bc c bd d) :| [] + + (bc, c) : [] -> + (union3MBR ba bb bc, Node3 ba a bb b bc c) :| [] + + [] -> + (unionMBR ba bb, Node2 ba a bb b) :| [] + + base as = + case as of + (ba, a) : (bb, b) : (bc, c) : (bd, d) : [] -> + (union4MBR ba bb bc bd, Leaf4 ba a bb b bc c bd d) + + (ba, a) : (bb, b) : (bc, c) : [] -> + (union3MBR ba bb bc, Leaf3 ba a bb b bc c) + + (ba, a) : (bb, b) : [] -> + (unionMBR ba bb, Leaf2 ba a bb b) + + _ -> errorWithoutStackTrace + "Data.R2Tree.Float.Internal.bulkSTR: malformed leaf" diff --git a/src/Data/R2Tree/Float/Unsafe.hs b/src/Data/R2Tree/Float/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Data/R2Tree/Float/Unsafe.hs @@ -0,0 +1,43 @@ +{-# OPTIONS_HADDOCK not-home #-} + +{- | + Module : Data.R2Tree.Float.Unsafe + Copyright : Copyright (c) 2015, Birte Wagner, Sebastian Philipp + Copyright (c) 2022, Oleksii Divak + License : MIT + + Maintainer : Oleksii Divak + Stability : experimental + Portability: not portable + + Underlying implementation of the 'R2Tree'. +-} + +module Data.R2Tree.Float.Unsafe + ( MBR (MBR, UnsafeMBR) + + -- | === R-tree + -- + -- Each t'MBR' is tied to the value directly after it. + -- + -- Invariant: the t'MBR' of each non-leaf node encloses + -- all the t'MBR's inside the node. + , R2Tree (..) + + -- * Common operations + , validMBR + , eqMBR + , unionMBR + , areaMBR + , marginMBR + , distanceMBR + , containsMBR + , containsMBR' + , intersectionMBR + , intersectionMBR' + + -- * Range + , Predicate (..) + ) where + +import Data.R2Tree.Float.Internal diff --git a/test/properties/Main.hs b/test/properties/Main.hs new file mode 100644 --- /dev/null +++ b/test/properties/Main.hs @@ -0,0 +1,10 @@ +module Main where + +import qualified Test.R2Tree.Double as R2 + +import Test.Hspec + + + +main :: IO () +main = hspec R2.test diff --git a/test/properties/Test/Kit.hs b/test/properties/Test/Kit.hs new file mode 100644 --- /dev/null +++ b/test/properties/Test/Kit.hs @@ -0,0 +1,60 @@ +module Test.Kit + ( Case (..) + , augment + + , Test (..) + + , run + , dump + ) where + +import Control.Exception +import Data.Foldable + + + +data Case s a b = Case s a b + +augment :: (s -> t) -> [Case s a b] -> [Case t a b] +augment f xs = fmap (\(Case s a b) -> Case (f s) a b) xs + + + +data Test s a b x y = Test (x -> y -> Bool) (s -> a -> x) (s -> b -> y) + + + +newtype Failure = Failure Int + +instance Show Failure where + showsPrec _ (Failure n) = showString "Test failed on case " . shows n + +instance Exception Failure + + + +newtype UnknownIndex = UnknownIndex Int + +instance Show UnknownIndex where + showsPrec _ (UnknownIndex n) = showString "No case under index " . shows n + +instance Exception UnknownIndex + + + +enumerate :: [Case s a b] -> [(Int, Case s a b)] +enumerate = zip [0..] + +run :: [Case s a b] -> Test s a b x y -> IO () +run cs (Test cmp f g) = traverse_ go $ enumerate cs + where + go (n, Case s a b) = + if cmp (f s a) (g s b) + then pure () + else throwIO (Failure n) + +dump :: [Case s a b] -> Test s a b x y -> Int -> IO (s, a, b, x, y) +dump xs (Test _ f g) n = + case lookup n (enumerate xs) of + Just (Case s a b) -> pure (s, a, b, f s a, g s b) + Nothing -> throwIO (UnknownIndex n) diff --git a/test/properties/Test/R2Tree/Double.hs b/test/properties/Test/R2Tree/Double.hs new file mode 100644 --- /dev/null +++ b/test/properties/Test/R2Tree/Double.hs @@ -0,0 +1,493 @@ +{-# LANGUAGE RankNTypes #-} + +module Test.R2Tree.Double + ( test + ) where + +import qualified Data.R2Tree.Double as R +import Data.R2Tree.Double.Debug +import Data.R2Tree.Double.Unsafe +import No.Tree.D2 (NoTree) +import qualified No.Tree.D2 as No +import Test.Kit +import Test.R2Tree.Double.Sample + +import Data.Functor.Identity +import Data.List +import Test.Hspec + + + +mbrT :: Spec +mbrT = do + describe "valid" $ do + it "0 0 1 1" $ + validMBR (UnsafeMBR 0 0 1 1) `shouldBe` True + + it "1 0 0 1" $ + validMBR (UnsafeMBR 1 0 0 1) `shouldBe` False + + it "1 1 0 0" $ + validMBR (UnsafeMBR 1 1 0 0) `shouldBe` False + + describe "union" $ do + it "2 1 3 4 / 6 5 8 9" $ + unionMBR (UnsafeMBR 2 1 3 4) (UnsafeMBR 6 5 8 9) `shouldBe` UnsafeMBR 2 1 8 9 + + it "2 4 5 8 / 1 3 6 9" $ + unionMBR (UnsafeMBR 2 4 5 8) (UnsafeMBR 1 3 6 9) `shouldBe` UnsafeMBR 1 3 6 9 + + it "1 3 6 9 / 2 4 7 8" $ + unionMBR (UnsafeMBR 1 3 6 9) (UnsafeMBR 2 4 7 8) `shouldBe` UnsafeMBR 1 3 7 9 + + describe "area" $ do + it "2 1 8 9" $ + areaMBR (UnsafeMBR 2 1 8 9) `shouldBe` 48 + + it "3 4 6 5" $ + areaMBR (UnsafeMBR 3 4 6 5) `shouldBe` 3 + + describe "margin" $ do + it "2 1 8 9" $ + marginMBR (UnsafeMBR 2 1 8 9) `shouldBe` 14 + + it "3 4 6 5" $ + marginMBR (UnsafeMBR 3 4 6 5) `shouldBe` 4 + + describe "distance" $ do + it "2 1 3 4 / 6 5 8 9" $ + distanceMBR (UnsafeMBR 2 1 3 4) (UnsafeMBR 6 5 8 9) `shouldBe` 162 + + it "2 4 5 8 / 1 3 6 9" $ + distanceMBR (UnsafeMBR 2 4 5 8) (UnsafeMBR 1 3 6 9) `shouldBe` 0 + + it "1 3 6 9 / 2 4 7 8" $ + distanceMBR (UnsafeMBR 1 3 6 9) (UnsafeMBR 2 4 7 8) `shouldBe` 4 + + describe "contains" $ do + it "2 1 3 4 / 6 5 8 9" $ + containsMBR (UnsafeMBR 2 1 3 4) (UnsafeMBR 6 5 8 9) `shouldBe` False + + it "2 1 8 9 / 3 4 5 6" $ + containsMBR (UnsafeMBR 2 1 8 9) (UnsafeMBR 3 4 5 6) `shouldBe` True + + it "2 1 8 9 / 2 1 2 8" $ + containsMBR (UnsafeMBR 2 1 8 9) (UnsafeMBR 2 1 2 8) `shouldBe` True + + it "2 1 8 9 / 8 9 8 9" $ + containsMBR (UnsafeMBR 2 1 8 9) (UnsafeMBR 8 9 8 9) `shouldBe` True + + describe "contains'" $ do + it "2 1 3 4 / 6 5 8 9" $ + containsMBR' (UnsafeMBR 2 1 3 4) (UnsafeMBR 6 5 8 9) `shouldBe` False + + it "2 1 8 9 / 3 4 5 6" $ + containsMBR' (UnsafeMBR 2 1 8 9) (UnsafeMBR 3 4 5 6) `shouldBe` True + + it "2 1 8 9 / 2 1 2 8" $ + containsMBR' (UnsafeMBR 2 1 8 9) (UnsafeMBR 2 1 2 8) `shouldBe` False + + it "2 1 8 9 / 8 9 8 9" $ + containsMBR' (UnsafeMBR 2 1 8 9) (UnsafeMBR 8 9 8 9) `shouldBe` False + + describe "intersection" $ do + it "2 1 3 4 / 6 5 8 9" $ + intersectionMBR (UnsafeMBR 2 1 3 4) (UnsafeMBR 6 5 8 9) `shouldBe` Nothing + + it "1 3 6 9 / 2 4 5 8" $ + intersectionMBR (UnsafeMBR 1 3 6 9) (UnsafeMBR 2 4 5 8) `shouldBe` Just (UnsafeMBR 2 4 5 8) + + it "2 4 7 8 / 1 3 6 9" $ + intersectionMBR (UnsafeMBR 2 4 7 8) (UnsafeMBR 1 3 6 9) `shouldBe` Just (UnsafeMBR 2 4 6 8) + + it "1 2 5 4 / 3 4 6 5" $ + intersectionMBR (UnsafeMBR 1 2 5 4) (UnsafeMBR 3 4 6 5) `shouldBe` Just (UnsafeMBR 3 4 5 4) + + it "3 4 5 6 / 5 6 7 8" $ + intersectionMBR (UnsafeMBR 3 4 5 6) (UnsafeMBR 5 6 7 8) `shouldBe` Just (UnsafeMBR 5 6 5 6) + + describe "intersection'" $ do + it "2 1 3 4 / 6 5 8 9" $ + intersectionMBR' (UnsafeMBR 2 1 3 4) (UnsafeMBR 6 5 8 9) `shouldBe` Nothing + + it "1 3 6 9 / 2 4 5 8" $ + intersectionMBR' (UnsafeMBR 1 3 6 9) (UnsafeMBR 2 4 5 8) `shouldBe` Just (UnsafeMBR 2 4 5 8) + + it "2 4 7 8 / 1 3 6 9" $ + intersectionMBR' (UnsafeMBR 2 4 7 8) (UnsafeMBR 1 3 6 9) `shouldBe` Just (UnsafeMBR 2 4 6 8) + + it "1 2 5 4 / 3 4 6 5" $ + intersectionMBR' (UnsafeMBR 1 2 5 4) (UnsafeMBR 3 4 6 5) `shouldBe` Nothing + + it "3 4 5 6 / 5 6 7 8" $ + intersectionMBR' (UnsafeMBR 3 4 5 6) (UnsafeMBR 5 6 7 8) `shouldBe` Nothing + + + +predicateT :: Spec +predicateT = do + describe "equals 2 3 7 6" $ do + let Predicate nodePred leafPred = R.equals (UnsafeMBR 2 3 7 6) + it "node 1 2 9 8" $ + nodePred (UnsafeMBR 1 2 9 8) `shouldBe` True + + it "leaf 1 2 9 8" $ + leafPred (UnsafeMBR 1 2 9 8) `shouldBe` False + + it "node 2 3 7 6" $ + nodePred (UnsafeMBR 2 3 7 6) `shouldBe` True + + it "leaf 2 3 7 6" $ + leafPred (UnsafeMBR 2 3 7 6) `shouldBe` True + + it "node 3 4 6 5" $ + nodePred (UnsafeMBR 3 4 6 5) `shouldBe` False + + it "leaf 3 4 6 5" $ + leafPred (UnsafeMBR 3 4 6 5) `shouldBe` False + + it "node 3 4 9 8" $ + nodePred (UnsafeMBR 3 4 9 8) `shouldBe` False + + it "leaf 3 4 9 8" $ + leafPred (UnsafeMBR 3 4 9 8) `shouldBe` False + + describe "intersects 2 3 7 6" $ do + let Predicate nodePred leafPred = R.intersects (UnsafeMBR 2 3 7 6) + it "node 1 2 9 8" $ + nodePred (UnsafeMBR 1 2 9 8) `shouldBe` True + + it "leaf 1 2 9 8" $ + leafPred (UnsafeMBR 1 2 9 8) `shouldBe` True + + it "node 2 3 7 6" $ + nodePred (UnsafeMBR 2 3 7 6) `shouldBe` True + + it "leaf 2 3 7 6" $ + leafPred (UnsafeMBR 2 3 7 6) `shouldBe` True + + it "node 3 4 6 5" $ + nodePred (UnsafeMBR 3 4 6 5) `shouldBe` True + + it "leaf 3 4 6 5" $ + leafPred (UnsafeMBR 3 4 6 5) `shouldBe` True + + it "node 3 4 9 8" $ + nodePred (UnsafeMBR 3 4 9 8) `shouldBe` True + + it "leaf 3 4 9 8" $ + leafPred (UnsafeMBR 3 4 9 8) `shouldBe` True + + it "node 2 3 7 6" $ + nodePred (UnsafeMBR 7 3 8 6) `shouldBe` True + + it "leaf 2 3 7 6" $ + leafPred (UnsafeMBR 7 3 8 6) `shouldBe` True + + describe "intersects' 2 3 7 6" $ do + let Predicate nodePred leafPred = R.intersects' (UnsafeMBR 2 3 7 6) + it "node 2 3 7 6" $ + nodePred (UnsafeMBR 7 3 8 6) `shouldBe` False + + it "leaf 2 3 7 6" $ + leafPred (UnsafeMBR 7 3 8 6) `shouldBe` False + + describe "contains 2 3 7 6" $ do + let Predicate nodePred leafPred = R.contains (UnsafeMBR 2 3 7 6) + it "node 1 2 9 8" $ + nodePred (UnsafeMBR 1 2 9 8) `shouldBe` True + + it "leaf 1 2 9 8" $ + leafPred (UnsafeMBR 1 2 9 8) `shouldBe` True + + it "node 2 3 7 6" $ + nodePred (UnsafeMBR 2 3 7 6) `shouldBe` True + + it "leaf 2 3 7 6" $ + leafPred (UnsafeMBR 2 3 7 6) `shouldBe` True + + it "node 3 4 6 5" $ + nodePred (UnsafeMBR 3 4 6 5) `shouldBe` False + + it "leaf 3 4 6 5" $ + leafPred (UnsafeMBR 3 4 6 5) `shouldBe` False + + it "node 3 4 9 8" $ + nodePred (UnsafeMBR 3 4 9 8) `shouldBe` False + + it "leaf 3 4 9 8" $ + leafPred (UnsafeMBR 3 4 9 8) `shouldBe` False + + describe "contains' 2 3 7 6" $ do + let Predicate nodePred leafPred = R.contains' (UnsafeMBR 2 3 7 6) + it "node 2 3 7 6" $ + nodePred (UnsafeMBR 2 3 7 6) `shouldBe` True + + it "leaf 2 3 7 6" $ + leafPred (UnsafeMBR 2 3 7 6) `shouldBe` False + + describe "containedBy 2 3 7 6" $ do + let Predicate nodePred leafPred = R.containedBy (UnsafeMBR 2 3 7 6) + it "node 1 2 9 8" $ + nodePred (UnsafeMBR 1 2 9 8) `shouldBe` True + + it "leaf 1 2 9 8" $ + leafPred (UnsafeMBR 1 2 9 8) `shouldBe` False + + it "node 2 3 7 6" $ + nodePred (UnsafeMBR 2 3 7 6) `shouldBe` True + + it "leaf 2 3 7 6" $ + leafPred (UnsafeMBR 2 3 7 6) `shouldBe` True + + it "node 3 4 6 5" $ + nodePred (UnsafeMBR 3 4 6 5) `shouldBe` True + + it "leaf 3 4 6 5" $ + leafPred (UnsafeMBR 3 4 6 5) `shouldBe` True + + it "node 3 4 9 8" $ + nodePred (UnsafeMBR 3 4 9 8) `shouldBe` True + + it "leaf 3 4 9 8" $ + leafPred (UnsafeMBR 3 4 9 8) `shouldBe` False + + describe "containedBy' 2 3 7 6" $ do + let Predicate nodePred leafPred = R.containedBy' (UnsafeMBR 2 3 7 6) + it "node 2 3 7 6" $ + nodePred (UnsafeMBR 2 3 7 6) `shouldBe` True + + it "leaf 2 3 7 6" $ + leafPred (UnsafeMBR 2 3 7 6) `shouldBe` False + + + +rFromList :: [(MBR, a)] -> R2Tree a +rFromList = foldr (uncurry R.insert) R.empty + +rToList :: R2Tree a -> [(MBR, a)] +rToList = R.foldrWithKey (\ba a -> (:) (ba, a)) [] + + + +unary0 :: [Case () (R2Tree Int) (NoTree Int)] +unary0 = foldMap (mkUnary0 rFromList) [zero, one, four, five, tiny, small, medium] + +unary1 :: [Case (MBR, Int) (R2Tree Int) (NoTree Int)] +unary1 = foldMap (mkUnary1 rFromList) [zero, one, four, five, tiny, small, medium] + +unary1_ :: [Case MBR (R2Tree Int) (NoTree Int)] +unary1_ = augment fst unary1 + + + +compareMBR :: Ord a => (MBR, a) -> (MBR, a) -> Ordering +compareMBR (MBR x0 y0 x1 y1, a) (MBR x2 y2 x3 y3, b) = + case compare a b of + EQ -> case compare x0 x2 of + EQ -> case compare y0 y2 of + EQ -> case compare x1 x3 of + EQ -> compare y1 y3 + cmp -> cmp + cmp -> cmp + cmp -> cmp + cmp -> cmp + +type TreeT s a = Test s (R2Tree a) (NoTree a) (R2Tree a) (NoTree a) + +treeEq :: Ord a => R2Tree a -> NoTree a -> Bool +treeEq tree no = + case validate tree of + Valid -> sortBy compareMBR (No.toList no) == sortBy compareMBR (rToList tree) + _ -> False + +type TreeIdT s a = Test s (R2Tree a) (NoTree a) (Identity (R2Tree a)) (Identity (NoTree a)) + +treeIdEq :: Ord a => Identity (R2Tree a) -> Identity (NoTree a) -> Bool +treeIdEq (Identity tree) (Identity no) = treeEq tree no + + + +type ListT s a = Test s (R2Tree a) (NoTree a) [a] [a] + +listEq :: Ord a => [a] -> [a] -> Bool +listEq as bs = sort as == sort bs + +type ListWithKeyT s a = Test s (R2Tree a) (NoTree a) [(MBR, a)] [(MBR, a)] + +listWithKeyEq :: Ord a => [(MBR, a)] -> [(MBR, a)] -> Bool +listWithKeyEq as bs = sortBy compareMBR as == sortBy compareMBR bs + + + +insertT :: (Num a, Ord a) => TreeT (MBR, a) a +insertT = Test treeEq (\(bx, x) r -> R.insert bx (negate x) r) + (\(bx, x) no -> No.insert bx (negate x) no) + +insertGutT :: (Num a, Ord a) => TreeT (MBR, a) a +insertGutT = Test treeEq (\(bx, x) r -> R.insertGut bx (negate x) r) + (\(bx, x) no -> No.insert bx (negate x) no) + +deleteT :: Ord a => TreeT MBR a +deleteT = Test treeEq R.delete No.delete + + + +mapT, mapT' :: TreeT () Int +mapT = mapT_ R.map +mapT' = mapT_ R.map' + +mapT_ :: (forall a. (a -> a) -> R2Tree a -> R2Tree a) -> TreeT () Int +mapT_ f = Test treeEq (\_ -> f negate) (\_ -> No.mapWithKey (\_ -> negate)) + + + +mapWithKeyT, mapWithKeyT' :: TreeT () Int +mapWithKeyT = mapWithKeyT_ R.mapWithKey +mapWithKeyT' = mapWithKeyT_ R.mapWithKey' + +compressMBR :: MBR -> Int +compressMBR (UnsafeMBR xmin ymin xmax ymax) = + truncate xmin + truncate ymin + truncate xmax + truncate ymax + +mapWithKeyT_ :: (forall a. (MBR -> a -> a) -> R2Tree a -> R2Tree a) -> TreeT () Int +mapWithKeyT_ f = + let g k i = compressMBR k + i + in Test treeEq (\_ -> f g) (\_ -> No.mapWithKey g) + + + +adjustRangeWithKeyT, adjustRangeWithKeyT' :: (MBR -> Predicate) -> TreeT MBR Int +adjustRangeWithKeyT = adjustRangeWithKeyT_ R.adjustRangeWithKey +adjustRangeWithKeyT' = adjustRangeWithKeyT_ R.adjustRangeWithKey' + +adjustRangeWithKeyT_ + :: (forall a. Predicate -> (MBR -> a -> a) -> R2Tree a -> R2Tree a) + -> (MBR -> Predicate) + -> TreeT MBR Int +adjustRangeWithKeyT_ f p = + let g k i = compressMBR k + i + in Test treeEq (\bx -> f (p bx) g) (\bx -> No.adjustRangeWithKey (p bx) g) + + + +foldlT, foldrT, foldMapT, foldlT', foldrT' :: ListT () Int +foldlT = foldT $ R.foldl (flip (:)) [] +foldrT = foldT $ R.foldr (:) [] +foldMapT = foldT $ R.foldMap (:[]) +foldlT' = foldT $ R.foldl' (flip (:)) [] +foldrT' = foldT $ R.foldr' (:) [] + +foldT :: (forall a. R2Tree a -> [a]) -> ListT () Int +foldT f = Test listEq (\_ -> f) (\_ -> fmap snd . No.toList) + + + +foldlWithKeyT, foldrWithKeyT, foldMapWithKeyT, foldlWithKeyT', foldrWithKeyT' + :: ListWithKeyT () Int +foldlWithKeyT = foldWithKeyT $ R.foldlWithKey (\z bx x -> (bx, x) : z) [] +foldrWithKeyT = foldWithKeyT $ R.foldrWithKey (\bx x -> (:) (bx, x)) [] +foldMapWithKeyT = foldWithKeyT $ R.foldMapWithKey (\bx x -> [(bx, x)]) +foldlWithKeyT' = foldWithKeyT $ R.foldlWithKey' (\z bx x -> (bx, x) : z) [] +foldrWithKeyT' = foldWithKeyT $ R.foldrWithKey' (\bx x -> (:) (bx, x)) [] + +foldWithKeyT :: (forall a. R2Tree a -> [(MBR, a)]) -> ListWithKeyT () Int +foldWithKeyT f = Test listWithKeyEq (\_ -> f) (\_ -> No.toList) + + + +foldlRangeWithKeyT + , foldrRangeWithKeyT + , foldMapRangeWithKeyT + , foldlRangeWithKeyT' + , foldrRangeWithKeyT' + :: (MBR -> Predicate) -> ListWithKeyT MBR Int +foldlRangeWithKeyT = foldRangeWithKeyT $ \p -> R.foldlRangeWithKey p (\z bx x -> (bx, x) : z) [] +foldrRangeWithKeyT = foldRangeWithKeyT $ \p -> R.foldrRangeWithKey p (\bx x -> (:) (bx, x)) [] +foldMapRangeWithKeyT = foldRangeWithKeyT $ \p -> R.foldMapRangeWithKey p (\bx x -> [(bx, x)]) +foldlRangeWithKeyT' = foldRangeWithKeyT $ \p -> R.foldlRangeWithKey' p (\z bx x -> (bx, x) : z) [] +foldrRangeWithKeyT' = foldRangeWithKeyT $ \p -> R.foldrRangeWithKey' p (\bx x -> (:) (bx, x)) [] + +foldRangeWithKeyT + :: (forall a. Predicate -> R2Tree a -> [(MBR, a)]) + -> (MBR -> Predicate) -> ListWithKeyT MBR Int +foldRangeWithKeyT f p = + Test listWithKeyEq (\bx -> f (p bx)) + (\bx -> No.foldrRangeWithKey (p bx) (\ba a -> (:) (ba, a)) []) + + + +traverseT :: TreeIdT () Int +traverseT = + let f = Identity . negate + in Test treeIdEq (\_ -> R.traverse f) (\_ -> No.traverseWithKey (\_ -> f)) + +traverseWithKeyT :: TreeIdT () Int +traverseWithKeyT = + let f k i = Identity $ compressMBR k + i + in Test treeIdEq (\_ -> R.traverseWithKey f) (\_ -> No.traverseWithKey f) + +traverseRangeWithKeyT :: (MBR -> Predicate) -> TreeIdT MBR Int +traverseRangeWithKeyT p = + let f k i = Identity $ compressMBR k + i + in Test treeIdEq (\bx -> R.traverseRangeWithKey (p bx) f) (\bx -> No.traverseRangeWithKey (p bx) f) + + + +test :: Spec +test = do + describe "MBR" + mbrT + + describe "Predicate" + predicateT + + describe "R2Tree" $ do + describe "Single-key" $ do + it "insert" $ run unary1 insertT + it "insertGut" $ run unary1 insertGutT + it "delete" $ run unary1_ deleteT + + describe "Range" $ do + it "adjustRangeWithKey/equals" $ run unary1_ (adjustRangeWithKeyT R.equals) + it "adjustRangeWithKey/intersects" $ run unary1_ (adjustRangeWithKeyT R.intersects) + it "adjustRangeWithKey'/equals" $ run unary1_ (adjustRangeWithKeyT' R.equals) + it "adjustRangeWithKey'/intersects" $ run unary1_ (adjustRangeWithKeyT' R.intersects) + + it "foldlRangeWithKey/equals" $ run unary1_ (foldlRangeWithKeyT R.equals) + it "foldlRangeWithKey/intersects" $ run unary1_ (foldlRangeWithKeyT R.intersects) + it "foldlRangeWithKey'/equals" $ run unary1_ (foldlRangeWithKeyT' R.equals) + it "foldlRangeWithKey'/intersects" $ run unary1_ (foldlRangeWithKeyT' R.intersects) + + it "foldrRangeWithKey/equals" $ run unary1_ (foldrRangeWithKeyT R.equals) + it "foldrRangeWithKey/intersects" $ run unary1_ (foldrRangeWithKeyT R.intersects) + it "foldrRangeWithKey'/equals" $ run unary1_ (foldrRangeWithKeyT' R.equals) + it "foldrRangeWithKey'/intersects" $ run unary1_ (foldrRangeWithKeyT' R.intersects) + + it "foldMapRangeWithKey/equals" $ run unary1_ (foldMapRangeWithKeyT R.equals) + it "foldMapRangeWithKey/intersects" $ run unary1_ (foldMapRangeWithKeyT R.intersects) + + it "traverseRangeWithKey/equals" $ run unary1_ (traverseRangeWithKeyT R.equals) + it "traverseRangeWithKey/intersects" $ run unary1_ (traverseRangeWithKeyT R.intersects) + + describe "Full tree" $ do + it "map" $ run unary0 mapT + it "map'" $ run unary0 mapT' + it "mapWithKey" $ run unary0 mapWithKeyT + it "mapWithKey'" $ run unary0 mapWithKeyT' + + it "foldl" $ run unary0 foldlT + it "foldl'" $ run unary0 foldlT' + it "foldlWithKey" $ run unary0 foldlWithKeyT + it "foldlWithKey'" $ run unary0 foldlWithKeyT' + + it "foldr" $ run unary0 foldrT + it "foldr'" $ run unary0 foldrT' + it "foldrWithKey" $ run unary0 foldrWithKeyT + it "foldrWithKey'" $ run unary0 foldrWithKeyT' + + it "foldMap" $ run unary0 foldMapT + it "foldMapWithKey" $ run unary0 foldMapWithKeyT + + it "traverse" $ run unary0 traverseT + it "traverseWithKey" $ run unary0 traverseWithKeyT diff --git a/test/properties/Test/R2Tree/Double/Sample.hs b/test/properties/Test/R2Tree/Double/Sample.hs new file mode 100644 --- /dev/null +++ b/test/properties/Test/R2Tree/Double/Sample.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE RankNTypes #-} + +module Test.R2Tree.Double.Sample + ( Sample + , zero + , one + , four + , five + , tiny + , small + , medium + , large + + , mkUnary0 + , mkUnary1 + ) where + +import Data.R2Tree.Double +import No.Tree.D2 (NoTree) +import qualified No.Tree.D2 as No +import Test.Kit + +import System.Random + + + +data Sample = + Sample + [(MBR, Int)] -- ^ Keys in the tree + [(MBR, Int)] -- ^ Keys not in the tree + deriving Show + +zero, one, four, five :: Sample +zero = + Sample + [] + [(MBR 6 3 9 6, 6), (MBR 2 7 7 8, 7), (MBR 1 2 3 4, 8), (MBR 5 1 9 4, 9)] + +one = + Sample + [(MBR 4 5 6 7, 1)] + [(MBR 6 3 9 6, 6), (MBR 2 7 7 8, 7), (MBR 1 2 3 4, 8), (MBR 5 1 9 4, 9)] + +four = + Sample + [(MBR 3 4 5 6, 1), (MBR 1 2 6 2, 2), (MBR 4 1 8 7, 3), (MBR 3 2 9 3, 4)] + [(MBR 6 3 9 6, 6), (MBR 2 7 7 8, 7), (MBR 1 2 3 4, 8), (MBR 5 1 9 4, 9)] + +five = + Sample + [(MBR 3 4 5 6, 1), (MBR 1 2 6 2, 2), (MBR 4 1 8 7, 3), (MBR 3 2 9 3, 4), (MBR 2 1 7 7, 5)] + [(MBR 6 3 9 6, 6), (MBR 2 7 7 8, 7), (MBR 1 2 3 4, 8), (MBR 5 1 9 4, 9)] + + + +randMBR :: RandomGen g => (Int, Int) -> g -> (MBR, g) +randMBR r g0 = + let ~(x0, g1) = uniformR r g0 + ~(y0, g2) = uniformR r g1 + ~(x1, g3) = uniformR r g2 + ~(y1, g4) = uniformR r g3 + + in (MBR (fromIntegral x0) (fromIntegral y0) (fromIntegral x1) (fromIntegral y1), g4) + +list :: (g -> (a, g)) -> Int -> g -> ([a], g) +list gen = go + where + go n g + | n <= 0 = ([], g) + | otherwise = let ~(a, g') = gen g + ~(as, g'') = go (n - 1) g' + in (a:as, g'') + + + +halve :: [a] -> ([a], [a]) +halve (a:b:cs) = let ~(as, bs) = halve cs + in (a:as, b:bs) +halve as = (as, []) + +sample :: (Int, Int) -> Int -> StdGen -> Sample +sample r n g0 = + let ~(xs, _) = list (randMBR r) n g0 + + ~(as, bs) = halve $ zip xs [1..] + + in Sample as bs + + + +tiny, small, medium, large :: Sample +tiny = sample (0x1000, 0x80000) 16 (mkStdGen 0) +small = sample (0x1000, 0x80000) 64 (mkStdGen 1) +medium = sample (0x1000, 0x80000) 512 (mkStdGen 2) +large = sample (0x1000, 0x80000) 4096 (mkStdGen 3) + + + +type FromList tree = forall a. [(MBR, a)] -> tree a + +mkUnary0 :: FromList tree -> Sample -> [Case () (tree Int) (NoTree Int)] +mkUnary0 fromList (Sample xs _) = + [Case () (fromList xs) (No.fromList xs)] + +mkUnary1 :: FromList tree -> Sample -> [Case (MBR, Int) (tree Int) (NoTree Int)] +mkUnary1 fromList (Sample xs ys) = + let tree = fromList xs + no = No.fromList xs + + in fmap (\(bx, x) -> Case (bx, x) tree no) $ xs <> ys