{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE StrictData      #-}

module Data.QuadTree
  ( QuadTree (..)

    -- * Constructing 'QuadTree's
  , fill
  , combineAla

    -- * Spatially Querying 'QuadTree's
  , lookup
  , query

    -- * Eliminating 'QuadTree's
  , fuse
  , elements
  , toRects
  , boundingRect
  , defaultValue

    -- * Constructing 'Rect's
  , Rect (..)
  , mkRectByPow

    -- * Eliminating 'Rect's
  , midpoint
  , subdivide
  , Raw.rectCorners

    -- * Indexing Types
  , V2 (..)
  , V4 (..)
  ) where

import           Data.Coerce
import           Data.Foldable
import           Data.Maybe (fromMaybe)
import           Data.Monoid (Ap(..))
import           Data.QuadTree.Internal (Free(..), Rect(..), unwrap, intersects, rectContainsRect, getIntersect, rectContainsPoint, normalize, rectSize)
import qualified Data.QuadTree.Internal as Raw
import           Data.Semilattice
import           Data.Set (Set)
import qualified Data.Set as S
import           GHC.Base (liftA2)
import           Linear.V2
import           Linear.V4
import           Prelude hiding (lookup)


------------------------------------------------------------------------------
-- | Compute the center of a 'Rect'.
midpoint :: (Fractional a) => Rect a -> V2 a
midpoint :: forall a. Fractional a => Rect a -> V2 a
midpoint (Rect V2 a
pos V2 a
sz) = V2 a
pos forall a. Num a => a -> a -> a
+ V2 a
sz forall a. Fractional a => a -> a -> a
/ V2 a
2


------------------------------------------------------------------------------
-- | Subdivide a 'Rect' into four 'Rect's which fill up the same volume.
subdivide :: Fractional a => Rect a -> V4 (Rect a)
subdivide :: forall a. Fractional a => Rect a -> V4 (Rect a)
subdivide (Rect (V2 a
x a
y) (V2 a
w a
h)) =
  let halfw :: a
halfw = a
w forall a. Fractional a => a -> a -> a
/ a
2
      halfh :: a
halfh = a
h forall a. Fractional a => a -> a -> a
/ a
2
   in forall a. a -> a -> a -> a -> V4 a
V4
        (forall a. V2 a -> V2 a -> Rect a
Rect (forall a. a -> a -> V2 a
V2 a
x a
y) (forall a. a -> a -> V2 a
V2 a
halfw a
halfh))
        (forall a. V2 a -> V2 a -> Rect a
Rect (forall a. a -> a -> V2 a
V2 (a
x forall a. Num a => a -> a -> a
+ a
halfw) a
y) forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> V2 a
V2 (a
w forall a. Num a => a -> a -> a
- a
halfw) a
halfh)
        (forall a. V2 a -> V2 a -> Rect a
Rect (forall a. a -> a -> V2 a
V2 a
x (a
y forall a. Num a => a -> a -> a
+ a
halfh)) forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> V2 a
V2 a
halfw (a
h forall a. Num a => a -> a -> a
- a
halfh))
        (forall a. V2 a -> V2 a -> Rect a
Rect (forall a. a -> a -> V2 a
V2 (a
x forall a. Num a => a -> a -> a
+ a
halfw) (a
y forall a. Num a => a -> a -> a
+ a
halfh)) forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> V2 a
V2 (a
w forall a. Num a => a -> a -> a
- a
halfw) (a
h forall a. Num a => a -> a -> a
- a
halfh))


------------------------------------------------------------------------------
-- | A type mapping values at (infinitely precise) locations in 2D
-- space. That is, you can consider an 'QuadTree' to be a function @'V2'
-- 'Rational' -> a@, equipped with efficient means of querying the space.
--
-- 'QuadTree's should usually be constructed using their 'Monoid'al or
-- 'Applicative' interfaces, as well as by way of the 'fill'
-- function.
data QuadTree a = QuadTree
  { forall a. QuadTree a -> a
ot_default  :: a
  , forall a. QuadTree a -> Integer
ot_root_pow :: Integer
  , forall a. QuadTree a -> Free a
ot_tree     :: Free a
  }
  deriving stock (Int -> QuadTree a -> ShowS
forall a. Show a => Int -> QuadTree a -> ShowS
forall a. Show a => [QuadTree a] -> ShowS
forall a. Show a => QuadTree a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [QuadTree a] -> ShowS
$cshowList :: forall a. Show a => [QuadTree a] -> ShowS
show :: QuadTree a -> String
$cshow :: forall a. Show a => QuadTree a -> String
showsPrec :: Int -> QuadTree a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> QuadTree a -> ShowS
Show, forall a b. a -> QuadTree b -> QuadTree a
forall a b. (a -> b) -> QuadTree a -> QuadTree b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> QuadTree b -> QuadTree a
$c<$ :: forall a b. a -> QuadTree b -> QuadTree a
fmap :: forall a b. (a -> b) -> QuadTree a -> QuadTree b
$cfmap :: forall a b. (a -> b) -> QuadTree a -> QuadTree b
Functor)
  deriving (Integer -> QuadTree a
QuadTree a -> QuadTree a
QuadTree a -> QuadTree a -> QuadTree a
forall a. Num a => Integer -> QuadTree a
forall a. Num a => QuadTree a -> QuadTree a
forall a. Num a => QuadTree a -> QuadTree a -> QuadTree a
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> QuadTree a
$cfromInteger :: forall a. Num a => Integer -> QuadTree a
signum :: QuadTree a -> QuadTree a
$csignum :: forall a. Num a => QuadTree a -> QuadTree a
abs :: QuadTree a -> QuadTree a
$cabs :: forall a. Num a => QuadTree a -> QuadTree a
negate :: QuadTree a -> QuadTree a
$cnegate :: forall a. Num a => QuadTree a -> QuadTree a
* :: QuadTree a -> QuadTree a -> QuadTree a
$c* :: forall a. Num a => QuadTree a -> QuadTree a -> QuadTree a
- :: QuadTree a -> QuadTree a -> QuadTree a
$c- :: forall a. Num a => QuadTree a -> QuadTree a -> QuadTree a
+ :: QuadTree a -> QuadTree a -> QuadTree a
$c+ :: forall a. Num a => QuadTree a -> QuadTree a -> QuadTree a
Num, NonEmpty (QuadTree a) -> QuadTree a
QuadTree a -> QuadTree a -> QuadTree a
forall b. Integral b => b -> QuadTree a -> QuadTree a
forall a. Semigroup a => NonEmpty (QuadTree a) -> QuadTree a
forall a. Semigroup a => QuadTree a -> QuadTree a -> QuadTree a
forall a b.
(Semigroup a, Integral b) =>
b -> QuadTree a -> QuadTree a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> QuadTree a -> QuadTree a
$cstimes :: forall a b.
(Semigroup a, Integral b) =>
b -> QuadTree a -> QuadTree a
sconcat :: NonEmpty (QuadTree a) -> QuadTree a
$csconcat :: forall a. Semigroup a => NonEmpty (QuadTree a) -> QuadTree a
<> :: QuadTree a -> QuadTree a -> QuadTree a
$c<> :: forall a. Semigroup a => QuadTree a -> QuadTree a -> QuadTree a
Semigroup, QuadTree a
[QuadTree a] -> QuadTree a
QuadTree a -> QuadTree a -> QuadTree a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall {a}. Monoid a => Semigroup (QuadTree a)
forall a. Monoid a => QuadTree a
forall a. Monoid a => [QuadTree a] -> QuadTree a
forall a. Monoid a => QuadTree a -> QuadTree a -> QuadTree a
mconcat :: [QuadTree a] -> QuadTree a
$cmconcat :: forall a. Monoid a => [QuadTree a] -> QuadTree a
mappend :: QuadTree a -> QuadTree a -> QuadTree a
$cmappend :: forall a. Monoid a => QuadTree a -> QuadTree a -> QuadTree a
mempty :: QuadTree a
$cmempty :: forall a. Monoid a => QuadTree a
Monoid) via (Ap QuadTree a)

instance Semilattice a => Semilattice (QuadTree a)


------------------------------------------------------------------------------
-- | Get the value used to fill the infinity of space in an 'QuadTree'.
defaultValue :: QuadTree a -> a
defaultValue :: forall a. QuadTree a -> a
defaultValue = forall a. QuadTree a -> a
ot_default

instance Eq a => Eq (QuadTree a) where
  q1 :: QuadTree a
q1@(QuadTree a
a Integer
m Free a
tr) == :: QuadTree a -> QuadTree a -> Bool
== q2 :: QuadTree a
q2@(QuadTree a
a' Integer
n Free a
tr') =
    case forall a. Ord a => a -> a -> Ordering
compare Integer
m Integer
n of
      Ordering
LT -> forall a. QuadTree a -> QuadTree a
realloc QuadTree a
q1 forall a. Eq a => a -> a -> Bool
== QuadTree a
q2
      Ordering
EQ -> a
a forall a. Eq a => a -> a -> Bool
== a
a' Bool -> Bool -> Bool
&& Free a
tr forall a. Eq a => a -> a -> Bool
== Free a
tr'
      Ordering
GT -> QuadTree a
q1 forall a. Eq a => a -> a -> Bool
== forall a. QuadTree a -> QuadTree a
realloc QuadTree a
q2


instance Applicative QuadTree where
  pure :: forall a. a -> QuadTree a
pure a
a = forall a. a -> Integer -> Free a -> QuadTree a
QuadTree a
a Integer
0 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  liftA2 :: forall a b c.
(a -> b -> c) -> QuadTree a -> QuadTree b -> QuadTree c
liftA2 a -> b -> c
fabc q1 :: QuadTree a
q1@(QuadTree a
a Integer
m Free a
ota) q2 :: QuadTree b
q2@(QuadTree b
b Integer
n Free b
otb) =
    case forall a. Ord a => a -> a -> Ordering
compare Integer
m Integer
n of
      Ordering
LT -> forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
fabc (forall a. QuadTree a -> QuadTree a
realloc QuadTree a
q1) QuadTree b
q2
      Ordering
EQ -> forall a. a -> Integer -> Free a -> QuadTree a
QuadTree (a -> b -> c
fabc a
a b
b) Integer
m forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
fabc Free a
ota Free b
otb
      Ordering
GT -> forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
fabc QuadTree a
q1 (forall a. QuadTree a -> QuadTree a
realloc QuadTree b
q2)


------------------------------------------------------------------------------
-- | Get a 'Rect' guaranteed to bound all of the non-defaulted values in the
-- 'QuadTree'.
boundingRect :: QuadTree a -> Rect Rational
boundingRect :: forall a. QuadTree a -> Rect Rational
boundingRect = Integer -> Rect Rational
mkRectByPow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. QuadTree a -> Integer
ot_root_pow


------------------------------------------------------------------------------
-- | Construct a 'Rect' centered around $(0, 0, 0)$, with side length $2n$.
mkRectByPow :: Integer -> Rect Rational
mkRectByPow :: Integer -> Rect Rational
mkRectByPow Integer
n =
  let side :: Rational
side = Rational
2 forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
n
   in forall a. V2 a -> V2 a -> Rect a
Rect (forall (f :: * -> *) a. Applicative f => a -> f a
pure (-Rational
side)) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Rational
side forall a. Num a => a -> a -> a
* Rational
2


------------------------------------------------------------------------------
-- | Build a larger 'Free' 'Quad' by doubling each side length, keeping the
-- contents in the center.
doubleGo :: a -> V4 (Free a) -> Free a
doubleGo :: forall a. a -> V4 (Free a) -> Free a
doubleGo a
def (V4 Free a
tl Free a
tr Free a
bl Free a
br) = forall a. V4 (Free a) -> Free a
Split forall a b. (a -> b) -> a -> b
$
  forall a. a -> a -> a -> a -> V4 a
V4
    (forall a. V4 (Free a) -> Free a
Split (forall a. a -> a -> a -> a -> V4 a
V4 Free a
a Free a
a
               Free a
a Free a
tl)) (forall a. V4 (Free a) -> Free a
Split (forall a. a -> a -> a -> a -> V4 a
V4 Free a
a  Free a
a
                                Free a
tr Free a
a))
    (forall a. V4 (Free a) -> Free a
Split (forall a. a -> a -> a -> a -> V4 a
V4 Free a
a Free a
bl
               Free a
a Free a
a)) (forall a. V4 (Free a) -> Free a
Split (forall a. a -> a -> a -> a -> V4 a
V4 Free a
br Free a
a
                                Free a
a  Free a
a))
  where
    a :: Free a
a = forall a. a -> Free a
Fill a
def


------------------------------------------------------------------------------
-- | Reallocate the bounds of the 'QuadTree' so each side length is twice the
-- size.
realloc :: QuadTree a -> QuadTree a
realloc :: forall a. QuadTree a -> QuadTree a
realloc (QuadTree a
a Integer
n Free a
q) = forall a. a -> Integer -> Free a -> QuadTree a
QuadTree a
a (Integer
n forall a. Num a => a -> a -> a
+ Integer
1) forall a b. (a -> b) -> a -> b
$ forall a. a -> V4 (Free a) -> Free a
doubleGo a
a forall a b. (a -> b) -> a -> b
$ forall a. Free a -> V4 (Free a)
unwrap Free a
q


------------------------------------------------------------------------------
-- | Get the smallest integer which will contain the 'Rect' when given as an
-- argument to 'mkRectByPow'.
--
-- @
-- 'rectContainsRect' ('mkRectByPow' ('rectBoundingLog' c)) c == True
-- @
rectBoundingLog :: Rect Rational -> Integer
rectBoundingLog :: Rect Rational -> Integer
rectBoundingLog (Rect (V2 Rational
x Rational
y) (V2 Rational
w Rational
h)) =
  forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ (Integer
0 forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (RealFrac a, Integral b) => a -> b
ceiling @Double forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Floating a => a -> a -> a
logBase Double
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Fractional a => Rational -> a
fromRational)
    [ forall a. Num a => a -> a
abs Rational
x
    , forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ Rational
x forall a. Num a => a -> a -> a
+ Rational
w
    , forall a. Num a => a -> a
abs Rational
y
    , forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ Rational
y forall a. Num a => a -> a -> a
+ Rational
h
    ]


fillSel :: (Fractional r, Ord r) => a -> a -> Maybe (Rect r) -> Rect r -> Free a
fillSel :: forall r a.
(Fractional r, Ord r) =>
a -> a -> Maybe (Rect r) -> Rect r -> Free a
fillSel a
def a
_ Maybe (Rect r)
Nothing Rect r
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
def
fillSel a
def a
v (Just Rect r
r) Rect r
qu = forall r a.
(Fractional r, Ord r) =>
a -> a -> Rect r -> Rect r -> Free a
fillImpl a
def a
v Rect r
r Rect r
qu


fillImpl :: (Fractional r, Ord r) => a -> a -> Rect r -> Rect r -> Free a
fillImpl :: forall r a.
(Fractional r, Ord r) =>
a -> a -> Rect r -> Rect r -> Free a
fillImpl a
def a
v Rect r
area Rect r
r
  | forall a. (Num a, Ord a) => Rect a -> Rect a -> Bool
rectContainsRect Rect r
area Rect r
r = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
  | forall a. (Ord a, Num a) => Rect a -> Rect a -> Bool
intersects Rect r
area Rect r
r = do
      let subr :: V4 (Rect r)
subr = forall a. Fractional a => Rect a -> V4 (Rect a)
subdivide Rect r
r
          subarea :: V4 (Maybe (Rect r))
subarea = forall a. (Ord a, Num a) => Rect a -> Rect a -> Maybe (Rect a)
getIntersect Rect r
area forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> V4 (Rect r)
subr
      forall a. V4 (Free a) -> Free a
Split forall a b. (a -> b) -> a -> b
$ forall r a.
(Fractional r, Ord r) =>
a -> a -> Maybe (Rect r) -> Rect r -> Free a
fillSel a
def a
v forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> V4 (Maybe (Rect r))
subarea forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> V4 (Rect r)
subr
  | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
def


------------------------------------------------------------------------------
-- | @'rect' def val c@ constructs a new 'QuadTree', which has value @val@
-- everywhere in the rect @c@, and @def@ everywhere else.
rect :: a -> a -> Rect Rational -> QuadTree a
rect :: forall a. a -> a -> Rect Rational -> QuadTree a
rect a
def a
v (forall a. (Num a, Ord a) => Rect a -> Rect a
normalize -> Rect Rational
r)
  | forall a. Num a => Rect a -> a
rectSize Rect Rational
r forall a. Eq a => a -> a -> Bool
== Rational
0  = forall a. a -> Integer -> Free a -> QuadTree a
QuadTree a
def (Rect Rational -> Integer
rectBoundingLog Rect Rational
r) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure a
def
  | Bool
otherwise = forall a. a -> Integer -> Free a -> QuadTree a
QuadTree a
def (Rect Rational -> Integer
rectBoundingLog Rect Rational
r) forall a b. (a -> b) -> a -> b
$ forall r a.
(Fractional r, Ord r) =>
a -> a -> Rect r -> Rect r -> Free a
fillImpl a
def a
v Rect Rational
r forall a b. (a -> b) -> a -> b
$ Integer -> Rect Rational
mkRectByPow (Rect Rational -> Integer
rectBoundingLog Rect Rational
r)


------------------------------------------------------------------------------
-- | Fill a 'Rect' with the given value in an 'QuadTree'
fill :: forall a. Rect Rational -> a -> QuadTree a -> QuadTree a
fill :: forall a. Rect Rational -> a -> QuadTree a -> QuadTree a
fill (forall a. (Num a, Ord a) => Rect a -> Rect a
normalize -> Rect Rational
r) a
a QuadTree a
q = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. a -> Maybe a -> a
fromMaybe QuadTree a
q (forall a. a -> a -> Rect Rational -> QuadTree a
rect forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just a
a) Rect Rational
r)


lookupImpl :: V2 Rational -> Rect Rational -> Free a -> Maybe a
lookupImpl :: forall a. V2 Rational -> Rect Rational -> Free a -> Maybe a
lookupImpl V2 Rational
p Rect Rational
r Free a
ot
  | forall a. (Ord a, Num a) => Rect a -> V2 a -> Bool
rectContainsPoint Rect Rational
r V2 Rational
p = case Free a
ot of
      Fill a
a -> forall a. a -> Maybe a
Just a
a
      Split V4 (Free a)
qu -> forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum forall a b. (a -> b) -> a -> b
$ forall a. V2 Rational -> Rect Rational -> Free a -> Maybe a
lookupImpl V2 Rational
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Fractional a => Rect a -> V4 (Rect a)
subdivide Rect Rational
r forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> V4 (Free a)
qu
  | Bool
otherwise = forall a. Maybe a
Nothing


------------------------------------------------------------------------------
-- | Get the value at the given position in the 'QuadTree'.
lookup :: V2 Rational -> QuadTree a -> a
lookup :: forall a. V2 Rational -> QuadTree a -> a
lookup V2 Rational
v2 (QuadTree a
a Integer
n Free a
q) = forall a. a -> Maybe a -> a
fromMaybe a
a forall a b. (a -> b) -> a -> b
$ forall a. V2 Rational -> Rect Rational -> Free a -> Maybe a
lookupImpl V2 Rational
v2 (Integer -> Rect Rational
mkRectByPow Integer
n) Free a
q


------------------------------------------------------------------------------
-- | Query a region of space in an 'QuadTree'. This method is a special case of
-- 'foldMap', specialized to finite regions.
--
-- For example, if you'd like to check if everything in the 'Rect' has
-- a specific value, use 'Data.Monoid.All' as your choice of 'Semilattice'. If
-- you'd like to check whether anything in the space has a value, instead use
-- 'Data.Monoid.Any'.
query :: Semilattice s => (a -> s) -> Rect Rational -> QuadTree a -> s
query :: forall s a.
Semilattice s =>
(a -> s) -> Rect Rational -> QuadTree a -> s
query a -> s
f (forall a. (Num a, Ord a) => Rect a -> Rect a
normalize -> Rect Rational
area) (QuadTree a
a Integer
n Free a
q)
  | forall a. (Num a, Ord a) => Rect a -> Rect a -> Bool
rectContainsRect Rect Rational
r Rect Rational
area = forall s a.
Semilattice s =>
(a -> s) -> Rect Rational -> Rect Rational -> Free a -> s
queryImpl a -> s
f Rect Rational
area Rect Rational
r Free a
q
  | forall a. (Ord a, Num a) => Rect a -> Rect a -> Bool
intersects Rect Rational
r Rect Rational
area = forall s a.
Semilattice s =>
(a -> s) -> Rect Rational -> Rect Rational -> Free a -> s
queryImpl a -> s
f Rect Rational
area Rect Rational
r Free a
q forall a. Semilattice a => a -> a -> a
/\ a -> s
f a
a
  | Bool
otherwise = a -> s
f a
a
  where
    r :: Rect Rational
r = Integer -> Rect Rational
mkRectByPow Integer
n


queryImpl :: Semilattice s => (a -> s) -> Rect Rational -> Rect Rational -> Free a -> s
queryImpl :: forall s a.
Semilattice s =>
(a -> s) -> Rect Rational -> Rect Rational -> Free a -> s
queryImpl a -> s
f Rect Rational
area Rect Rational
r (Fill a
a)
  | forall a. (Ord a, Num a) => Rect a -> Rect a -> Bool
intersects Rect Rational
area Rect Rational
r = a -> s
f a
a
  | Bool
otherwise = forall a. Monoid a => a
mempty
queryImpl a -> s
f Rect Rational
area Rect Rational
r (Split V4 (Free a)
qu)
  | forall a. (Ord a, Num a) => Rect a -> Rect a -> Bool
intersects Rect Rational
area Rect Rational
r = do
      let subr :: V4 (Rect Rational)
subr = forall a. Fractional a => Rect a -> V4 (Rect a)
subdivide Rect Rational
r
          subarea :: V4 (Maybe (Rect Rational))
subarea = forall a. (Ord a, Num a) => Rect a -> Rect a -> Maybe (Rect a)
getIntersect Rect Rational
area forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> V4 (Rect Rational)
subr
      forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$ forall s a.
Semilattice s =>
(a -> s) -> Maybe (Rect Rational) -> Rect Rational -> Free a -> s
querySel a -> s
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> V4 (Maybe (Rect Rational))
subarea forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> V4 (Rect Rational)
subr forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> V4 (Free a)
qu
  | Bool
otherwise = forall a. Monoid a => a
mempty


querySel :: Semilattice s => (a -> s) -> Maybe (Rect Rational) -> Rect Rational -> Free a -> s
querySel :: forall s a.
Semilattice s =>
(a -> s) -> Maybe (Rect Rational) -> Rect Rational -> Free a -> s
querySel a -> s
_ Maybe (Rect Rational)
Nothing Rect Rational
_ Free a
_ = forall a. Monoid a => a
mempty
querySel a -> s
f (Just Rect Rational
area) Rect Rational
r Free a
q = forall s a.
Semilattice s =>
(a -> s) -> Rect Rational -> Rect Rational -> Free a -> s
queryImpl a -> s
f Rect Rational
area Rect Rational
r Free a
q


------------------------------------------------------------------------------
-- | Partition the 'QuadTree' into contiguous, singular-valued 'Rect's.
-- Satsifies the law
--
-- @
-- foldr (uncurry 'fill') (pure $ 'defaultValue' ot) ('toRects' ot) == ot
-- @
toRects :: QuadTree a -> [(Rect Rational, a)]
toRects :: forall a. QuadTree a -> [(Rect Rational, a)]
toRects (QuadTree a
_ Integer
n Free a
q) = forall a. Rect Rational -> Free a -> [(Rect Rational, a)]
toRectsImpl (Integer -> Rect Rational
mkRectByPow Integer
n) Free a
q

toRectsImpl :: Rect Rational -> Free a -> [(Rect Rational, a)]
toRectsImpl :: forall a. Rect Rational -> Free a -> [(Rect Rational, a)]
toRectsImpl Rect Rational
r (Fill a
a) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rect Rational
r, a
a)
toRectsImpl Rect Rational
r (Split V4 (Free a)
qu) = do
  let subr :: V4 (Rect Rational)
subr = forall a. Fractional a => Rect a -> V4 (Rect a)
subdivide Rect Rational
r
  forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$ forall a. Rect Rational -> Free a -> [(Rect Rational, a)]
toRectsImpl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> V4 (Rect Rational)
subr forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> V4 (Free a)
qu


------------------------------------------------------------------------------
-- | Get the unique elements contained in the 'QuadTree'.
elements :: Ord a => QuadTree a -> Set a
elements :: forall a. Ord a => QuadTree a -> Set a
elements QuadTree a
ot = forall a. Ord a => a -> Set a -> Set a
S.insert (forall a. QuadTree a -> a
ot_default QuadTree a
ot) forall a b. (a -> b) -> a -> b
$ forall s a.
Semilattice s =>
(a -> s) -> Rect Rational -> QuadTree a -> s
query forall a. a -> Set a
S.singleton (forall a. QuadTree a -> Rect Rational
boundingRect QuadTree a
ot) QuadTree a
ot


------------------------------------------------------------------------------
-- | Fuse together all adjacent regions of space which contain the same value.
-- This will speed up subsequent queries, but requires traversing the entire
-- tree.
fuse :: Eq a => QuadTree a -> QuadTree a
fuse :: forall a. Eq a => QuadTree a -> QuadTree a
fuse (QuadTree a
a Integer
n Free a
ot) = forall a. a -> Integer -> Free a -> QuadTree a
QuadTree a
a Integer
n forall a b. (a -> b) -> a -> b
$ forall a. Eq a => Free a -> Free a
Raw.fuse Free a
ot


------------------------------------------------------------------------------
-- | Combine two 'QuadTree's using a different semigroup than usual. For
-- example, in order to replace any values in @qt1@ with those covered by
-- @qt2@, we can use:
--
-- @
-- 'combineAla' 'Data.Semigroup.Last' qt1 qt2
-- @
combineAla :: forall n a. (Coercible a n, Semigroup n)  => (a -> n) -> QuadTree a -> QuadTree a -> QuadTree a
combineAla :: forall n a.
(Coercible a n, Semigroup n) =>
(a -> n) -> QuadTree a -> QuadTree a -> QuadTree a
combineAla a -> n
_ QuadTree a
x QuadTree a
y = coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ (coerce :: forall a b. Coercible a b => a -> b
coerce QuadTree a
x :: QuadTree n) forall a. Semigroup a => a -> a -> a
<> coerce :: forall a b. Coercible a b => a -> b
coerce QuadTree a
y