r-tree (empty) → 1.0.0.0
raw patch · 20 files changed
+6350/−0 lines, 20 filesdep +basedep +deepseqdep +hspecsetup-changed
Dependencies added: base, deepseq, hspec, r-tree, random, tasty-bench, weigh
Files
- CHANGELOG.md +4/−0
- LICENSE +22/−0
- README.md +18/−0
- Setup.hs +2/−0
- benchmark/space/Main.hs +33/−0
- benchmark/time/Main.hs +175/−0
- no/No/Tree/D2.hs +133/−0
- r-tree.cabal +106/−0
- src/Data/R2Tree/Double.hs +183/−0
- src/Data/R2Tree/Double/Debug.hs +192/−0
- src/Data/R2Tree/Double/Internal.hs +2204/−0
- src/Data/R2Tree/Double/Unsafe.hs +43/−0
- src/Data/R2Tree/Float.hs +123/−0
- src/Data/R2Tree/Float/Debug.hs +192/−0
- src/Data/R2Tree/Float/Internal.hs +2204/−0
- src/Data/R2Tree/Float/Unsafe.hs +43/−0
- test/properties/Main.hs +10/−0
- test/properties/Test/Kit.hs +60/−0
- test/properties/Test/R2Tree/Double.hs +493/−0
- test/properties/Test/R2Tree/Double/Sample.hs +110/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+## 1.0.0.0 -- September 2024++- Initial rewrite.+- Library renamed from `data-r-tree`.
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,18 @@+# r-tree [](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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmark/space/Main.hs view
@@ -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
+ benchmark/time/Main.hs view
@@ -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+ ]
+ no/No/Tree/D2.hs view
@@ -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
+ r-tree.cabal view
@@ -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 <https://github.com/sebastian-philipp/r-tree/blob/master/README.md README>+ 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 <frozenwitness@gmail.com>+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
+ src/Data/R2Tree/Double.hs view
@@ -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/\",+ <http://www-db.deis.unibo.it/courses/SI-LS/papers/Gut84.pdf>++ * N. Beckmann, H.P. Kriegel, R. Schneider, B. Seeger (1990),+ \"/The R*-tree: an efficient and robust access method for points and rectangles/\",+ <https://infolab.usc.edu/csci599/Fall2001/paper/rstar-tree.pdf>++ * S.T. Leutenegger, J.M. Edgington, M.A. Lopez (1997),+ \"/STR: A Simple and Efficient Algorithm for R-Tree Packing/\",+ <https://ia800900.us.archive.org/27/items/nasa_techdoc_19970016975/19970016975.pdf>+-}++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
+ src/Data/R2Tree/Double/Debug.hs view
@@ -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
+ src/Data/R2Tree/Double/Internal.hs view
@@ -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"
+ src/Data/R2Tree/Double/Unsafe.hs view
@@ -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
+ src/Data/R2Tree/Float.hs view
@@ -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
+ src/Data/R2Tree/Float/Debug.hs view
@@ -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
+ src/Data/R2Tree/Float/Internal.hs view
@@ -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"
+ src/Data/R2Tree/Float/Unsafe.hs view
@@ -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
+ test/properties/Main.hs view
@@ -0,0 +1,10 @@+module Main where++import qualified Test.R2Tree.Double as R2++import Test.Hspec++++main :: IO ()+main = hspec R2.test
+ test/properties/Test/Kit.hs view
@@ -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)
+ test/properties/Test/R2Tree/Double.hs view
@@ -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
+ test/properties/Test/R2Tree/Double/Sample.hs view
@@ -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