r-tree-1.0.0.0: src/Data/R2Tree/Float/Internal.hs
{-# 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"