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

module Data.OctTree
  ( OctTree (..)

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

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

    -- * Eliminating 'OctTree's
  , fuse
  , elements
  , toCubes
  , boundingCube
  , defaultValue

    -- * Constructing 'Cube's
  , Cube (..)
  , mkCubeByPow

    -- * Eliminating 'Cube's
  , midpoint
  , subdivide
  , Raw.cubeCorners

    -- * Indexing Types
  , V3 (..)
  , Oct (..)
  ) where

import           Data.Coerce
import           Data.Foldable
import           Data.Maybe (fromMaybe)
import           Data.Monoid (Ap(..))
import           Data.OctTree.Internal (Free(..), Oct(..), Cube(..), pattern Oct8, unwrap, intersects, cubeContainsCube, getIntersect, cubeContainsPoint, normalize, cubeSize)
import qualified Data.OctTree.Internal as Raw
import           Data.Semilattice
import           Data.Set (Set)
import qualified Data.Set as S
import           GHC.Base (liftA2)
import           Linear.V3
import           Prelude hiding (lookup)


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


------------------------------------------------------------------------------
-- | Subdivide a 'Cube' into eight 'Cube's which fill up the same volume.
subdivide :: Fractional a => Cube a -> Oct (Cube a)
subdivide :: forall a. Fractional a => Cube a -> Oct (Cube a)
subdivide (Cube (V3 a
x a
y a
z) (V3 a
w a
h a
d)) =
  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
      halfd :: a
halfd = a
d forall a. Fractional a => a -> a -> a
/ a
2
   in forall a. a -> a -> a -> a -> a -> a -> a -> a -> Oct a
Oct8
        (forall a. V3 a -> V3 a -> Cube a
Cube (forall a. a -> a -> a -> V3 a
V3 a
x a
y a
z) (forall a. a -> a -> a -> V3 a
V3 a
halfw a
halfh a
halfd))
        (forall a. V3 a -> V3 a -> Cube a
Cube (forall a. a -> a -> a -> V3 a
V3 (a
x forall a. Num a => a -> a -> a
+ a
halfw) a
y a
z) forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> a -> V3 a
V3 (a
w forall a. Num a => a -> a -> a
- a
halfw) a
halfh a
halfd)
        (forall a. V3 a -> V3 a -> Cube a
Cube (forall a. a -> a -> a -> V3 a
V3 a
x (a
y forall a. Num a => a -> a -> a
+ a
halfh) a
z) forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> a -> V3 a
V3 a
halfw (a
h forall a. Num a => a -> a -> a
- a
halfh) a
halfd)
        (forall a. V3 a -> V3 a -> Cube a
Cube (forall a. a -> a -> a -> V3 a
V3 (a
x forall a. Num a => a -> a -> a
+ a
halfw) (a
y forall a. Num a => a -> a -> a
+ a
halfh) a
z) forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> a -> V3 a
V3 (a
w forall a. Num a => a -> a -> a
- a
halfw) (a
h forall a. Num a => a -> a -> a
- a
halfh) a
halfd)
        (forall a. V3 a -> V3 a -> Cube a
Cube (forall a. a -> a -> a -> V3 a
V3 a
x a
y (a
z forall a. Num a => a -> a -> a
+ a
halfd)) forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> a -> V3 a
V3 a
halfw a
halfh (a
d forall a. Num a => a -> a -> a
- a
halfd))
        (forall a. V3 a -> V3 a -> Cube a
Cube (forall a. a -> a -> a -> V3 a
V3 (a
x forall a. Num a => a -> a -> a
+ a
halfw) a
y (a
z forall a. Num a => a -> a -> a
+ a
halfd)) forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> a -> V3 a
V3 (a
w forall a. Num a => a -> a -> a
- a
halfw) a
halfh (a
d forall a. Num a => a -> a -> a
- a
halfd))
        (forall a. V3 a -> V3 a -> Cube a
Cube (forall a. a -> a -> a -> V3 a
V3 a
x (a
y forall a. Num a => a -> a -> a
+ a
halfh) (a
z forall a. Num a => a -> a -> a
+ a
halfd)) forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> a -> V3 a
V3 a
halfw (a
h forall a. Num a => a -> a -> a
- a
halfh) (a
d forall a. Num a => a -> a -> a
- a
halfd))
        (forall a. V3 a -> V3 a -> Cube a
Cube (forall a. a -> a -> a -> V3 a
V3 (a
x forall a. Num a => a -> a -> a
+ a
halfw) (a
y forall a. Num a => a -> a -> a
+ a
halfh) (a
z forall a. Num a => a -> a -> a
+ a
halfd)) forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> a -> V3 a
V3 (a
w forall a. Num a => a -> a -> a
- a
halfw) (a
h forall a. Num a => a -> a -> a
- a
halfh) (a
d forall a. Num a => a -> a -> a
- a
halfd))


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

instance Semilattice a => Semilattice (OctTree a)


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

instance Eq a => Eq (OctTree a) where
  q1 :: OctTree a
q1@(OctTree a
a Integer
m Free a
tr) == :: OctTree a -> OctTree a -> Bool
== q2 :: OctTree a
q2@(OctTree 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. OctTree a -> OctTree a
realloc OctTree a
q1 forall a. Eq a => a -> a -> Bool
== OctTree 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 -> OctTree a
q1 forall a. Eq a => a -> a -> Bool
== forall a. OctTree a -> OctTree a
realloc OctTree a
q2


instance Applicative OctTree where
  pure :: forall a. a -> OctTree a
pure a
a = forall a. a -> Integer -> Free a -> OctTree a
OctTree 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) -> OctTree a -> OctTree b -> OctTree c
liftA2 a -> b -> c
fabc q1 :: OctTree a
q1@(OctTree a
a Integer
m Free a
ota) q2 :: OctTree b
q2@(OctTree 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. OctTree a -> OctTree a
realloc OctTree a
q1) OctTree b
q2
      Ordering
EQ -> forall a. a -> Integer -> Free a -> OctTree a
OctTree (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 OctTree a
q1 (forall a. OctTree a -> OctTree a
realloc OctTree b
q2)


------------------------------------------------------------------------------
-- | Get a 'Cube' guaranteed to bound all of the non-defaulted values in the
-- 'OctTree'.
boundingCube :: OctTree a -> Cube Rational
boundingCube :: forall a. OctTree a -> Cube Rational
boundingCube = Integer -> Cube Rational
mkCubeByPow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. OctTree a -> Integer
ot_root_pow


------------------------------------------------------------------------------
-- | Construct a 'Cube' centered around $(0, 0, 0)$, with side length $2n$.
mkCubeByPow :: Integer -> Cube Rational
mkCubeByPow :: Integer -> Cube Rational
mkCubeByPow Integer
n =
  let side :: Rational
side = Rational
2 forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
n
   in forall a. V3 a -> V3 a -> Cube a
Cube (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' 'Oct' by doubling each side length, keeping the
-- contents in the center.
doubleGo :: a -> Oct (Free a) -> Free a
doubleGo :: forall a. a -> Oct (Free a) -> Free a
doubleGo a
def (Oct8 Free a
tl0 Free a
tr0 Free a
bl0 Free a
br0 Free a
tl1 Free a
tr1 Free a
bl1 Free a
br1) = forall a. Oct (Free a) -> Free a
Split forall a b. (a -> b) -> a -> b
$
  forall a. a -> a -> a -> a -> a -> a -> a -> a -> Oct a
Oct8
    (forall a. Oct (Free a) -> Free a
Split (forall a. a -> a -> a -> a -> a -> a -> a -> a -> Oct a
Oct8 Free a
a Free a
a Free a
a Free a
a Free a
a Free a
a
                 Free a
a Free a
tl0)) (forall a. Oct (Free a) -> Free a
Split (forall a. a -> a -> a -> a -> a -> a -> a -> a -> Oct a
Oct8 Free a
a Free a
a Free a
a Free a
a Free a
a  Free a
a
                                     Free a
tr0 Free a
a))
    (forall a. Oct (Free a) -> Free a
Split (forall a. a -> a -> a -> a -> a -> a -> a -> a -> Oct a
Oct8 Free a
a Free a
a Free a
a Free a
a Free a
a Free a
bl0
                 Free a
a Free a
a)) (forall a. Oct (Free a) -> Free a
Split (forall a. a -> a -> a -> a -> a -> a -> a -> a -> Oct a
Oct8 Free a
a Free a
a Free a
a Free a
a Free a
br0 Free a
a
                                    Free a
a  Free a
a))
    (forall a. Oct (Free a) -> Free a
Split (forall a. a -> a -> a -> a -> a -> a -> a -> a -> Oct a
Oct8 Free a
a Free a
a
                 Free a
a Free a
tl1 Free a
a Free a
a Free a
a Free a
a)) (forall a. Oct (Free a) -> Free a
Split (forall a. a -> a -> a -> a -> a -> a -> a -> a -> Oct a
Oct8 Free a
a  Free a
a
                                     Free a
tr1 Free a
a Free a
a Free a
a Free a
a Free a
a))
    (forall a. Oct (Free a) -> Free a
Split (forall a. a -> a -> a -> a -> a -> a -> a -> a -> Oct a
Oct8 Free a
a Free a
bl1
                 Free a
a Free a
a Free a
a Free a
a Free a
a Free a
a)) (forall a. Oct (Free a) -> Free a
Split (forall a. a -> a -> a -> a -> a -> a -> a -> a -> Oct a
Oct8 Free a
br1 Free a
a
                                    Free a
a  Free a
a Free a
a 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 'OctTree' so each side length is twice the
-- size.
realloc :: OctTree a -> OctTree a
realloc :: forall a. OctTree a -> OctTree a
realloc (OctTree a
a Integer
n Free a
q) = forall a. a -> Integer -> Free a -> OctTree a
OctTree a
a (Integer
n forall a. Num a => a -> a -> a
+ Integer
1) forall a b. (a -> b) -> a -> b
$ forall a. a -> Oct (Free a) -> Free a
doubleGo a
a forall a b. (a -> b) -> a -> b
$ forall a. Free a -> Oct (Free a)
unwrap Free a
q


------------------------------------------------------------------------------
-- | Get the smallest integer which will contain the 'Cube' when given as an
-- argument to 'mkCubeByPow'.
--
-- @
-- 'cubeContainsCube' ('mkCubeByPow' ('cubeBoundingLog' c)) c == True
-- @
cubeBoundingLog :: Cube Rational -> Integer
cubeBoundingLog :: Cube Rational -> Integer
cubeBoundingLog (Cube (V3 Rational
x Rational
y Rational
z) (V3 Rational
w Rational
h Rational
d)) =
  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
    , forall a. Num a => a -> a
abs Rational
z
    , forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ Rational
z forall a. Num a => a -> a -> a
+ Rational
d
    ]


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


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


------------------------------------------------------------------------------
-- | @'cube' def val c@ constructs a new 'OctTree', which has value @val@
-- everywhere in the cube @c@, and @def@ everywhere else.
cube :: a -> a -> Cube Rational -> OctTree a
cube :: forall a. a -> a -> Cube Rational -> OctTree a
cube a
def a
v (forall a. (Num a, Ord a) => Cube a -> Cube a
normalize -> Cube Rational
r)
  | forall a. Num a => Cube a -> a
cubeSize Cube Rational
r forall a. Eq a => a -> a -> Bool
== Rational
0  = forall a. a -> Integer -> Free a -> OctTree a
OctTree a
def (Cube Rational -> Integer
cubeBoundingLog Cube 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 -> OctTree a
OctTree a
def (Cube Rational -> Integer
cubeBoundingLog Cube Rational
r) forall a b. (a -> b) -> a -> b
$ forall r a.
(Fractional r, Ord r) =>
a -> a -> Cube r -> Cube r -> Free a
fillImpl a
def a
v Cube Rational
r forall a b. (a -> b) -> a -> b
$ Integer -> Cube Rational
mkCubeByPow (Cube Rational -> Integer
cubeBoundingLog Cube Rational
r)


------------------------------------------------------------------------------
-- | Fill a 'Cube' with the given value in an 'OctTree'
fill :: forall a. Cube Rational -> a -> OctTree a -> OctTree a
fill :: forall a. Cube Rational -> a -> OctTree a -> OctTree a
fill (forall a. (Num a, Ord a) => Cube a -> Cube a
normalize -> Cube Rational
r) a
a OctTree 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 OctTree a
q (forall a. a -> a -> Cube Rational -> OctTree a
cube forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just a
a) Cube Rational
r)


lookupImpl :: V3 Rational -> Cube Rational -> Free a -> Maybe a
lookupImpl :: forall a. V3 Rational -> Cube Rational -> Free a -> Maybe a
lookupImpl V3 Rational
p Cube Rational
r Free a
ot
  | forall a. (Ord a, Num a) => Cube a -> V3 a -> Bool
cubeContainsPoint Cube Rational
r V3 Rational
p = case Free a
ot of
      Fill a
a -> forall a. a -> Maybe a
Just a
a
      Split Oct (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. V3 Rational -> Cube Rational -> Free a -> Maybe a
lookupImpl V3 Rational
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Fractional a => Cube a -> Oct (Cube a)
subdivide Cube Rational
r forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Oct (Free a)
qu
  | Bool
otherwise = forall a. Maybe a
Nothing


------------------------------------------------------------------------------
-- | Get the value at the given position in the 'OctTree'.
lookup :: V3 Rational -> OctTree a -> a
lookup :: forall a. V3 Rational -> OctTree a -> a
lookup V3 Rational
v2 (OctTree 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. V3 Rational -> Cube Rational -> Free a -> Maybe a
lookupImpl V3 Rational
v2 (Integer -> Cube Rational
mkCubeByPow Integer
n) Free a
q


------------------------------------------------------------------------------
-- | Query a region of space in an 'OctTree'. This method is a special case of
-- 'foldMap', specialized to finite regions.
--
-- For example, if you'd like to check if everything in the 'Cube' 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) -> Cube Rational -> OctTree a -> s
query :: forall s a.
Semilattice s =>
(a -> s) -> Cube Rational -> OctTree a -> s
query a -> s
f (forall a. (Num a, Ord a) => Cube a -> Cube a
normalize -> Cube Rational
area) (OctTree a
a Integer
n Free a
q)
  | forall a. (Num a, Ord a) => Cube a -> Cube a -> Bool
cubeContainsCube Cube Rational
r Cube Rational
area = forall s a.
Semilattice s =>
(a -> s) -> Cube Rational -> Cube Rational -> Free a -> s
queryImpl a -> s
f Cube Rational
area Cube Rational
r Free a
q
  | forall a. (Ord a, Num a) => Cube a -> Cube a -> Bool
intersects Cube Rational
r Cube Rational
area = forall s a.
Semilattice s =>
(a -> s) -> Cube Rational -> Cube Rational -> Free a -> s
queryImpl a -> s
f Cube Rational
area Cube 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 :: Cube Rational
r = Integer -> Cube Rational
mkCubeByPow Integer
n


queryImpl :: Semilattice s => (a -> s) -> Cube Rational -> Cube Rational -> Free a -> s
queryImpl :: forall s a.
Semilattice s =>
(a -> s) -> Cube Rational -> Cube Rational -> Free a -> s
queryImpl a -> s
f Cube Rational
area Cube Rational
r (Fill a
a)
  | forall a. (Ord a, Num a) => Cube a -> Cube a -> Bool
intersects Cube Rational
area Cube Rational
r = a -> s
f a
a
  | Bool
otherwise = forall a. Monoid a => a
mempty
queryImpl a -> s
f Cube Rational
area Cube Rational
r (Split Oct (Free a)
qu)
  | forall a. (Ord a, Num a) => Cube a -> Cube a -> Bool
intersects Cube Rational
area Cube Rational
r = do
      let subr :: Oct (Cube Rational)
subr = forall a. Fractional a => Cube a -> Oct (Cube a)
subdivide Cube Rational
r
          subarea :: Oct (Maybe (Cube Rational))
subarea = forall a. (Ord a, Num a) => Cube a -> Cube a -> Maybe (Cube a)
getIntersect Cube Rational
area forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Oct (Cube 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 (Cube Rational) -> Cube Rational -> Free a -> s
querySel a -> s
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Oct (Maybe (Cube Rational))
subarea forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Oct (Cube Rational)
subr forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Oct (Free a)
qu
  | Bool
otherwise = forall a. Monoid a => a
mempty


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


------------------------------------------------------------------------------
-- | Partition the 'OctTree' into contiguous, singular-valued 'Cube's.
-- Satsifies the law
--
-- @
-- 'foldMap' (uncurry $ 'cube' ('defaultValue' ot)) ('toCubes' ot) == ot
-- @
toCubes :: OctTree a -> [(Cube Rational, a)]
toCubes :: forall a. OctTree a -> [(Cube Rational, a)]
toCubes (OctTree a
_ Integer
n Free a
q) = forall a. Cube Rational -> Free a -> [(Cube Rational, a)]
toCubesImpl (Integer -> Cube Rational
mkCubeByPow Integer
n) Free a
q

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


------------------------------------------------------------------------------
-- | Get the unique elements contained in the 'OctTree'.
elements :: Ord a => OctTree a -> Set a
elements :: forall a. Ord a => OctTree a -> Set a
elements OctTree a
ot = forall a. Ord a => a -> Set a -> Set a
S.insert (forall a. OctTree a -> a
ot_default OctTree a
ot) forall a b. (a -> b) -> a -> b
$ forall s a.
Semilattice s =>
(a -> s) -> Cube Rational -> OctTree a -> s
query forall a. a -> Set a
S.singleton (forall a. OctTree a -> Cube Rational
boundingCube OctTree a
ot) OctTree 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 => OctTree a -> OctTree a
fuse :: forall a. Eq a => OctTree a -> OctTree a
fuse (OctTree a
a Integer
n Free a
ot) = forall a. a -> Integer -> Free a -> OctTree a
OctTree 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 'OctTree's using a different semigroup than usual. For
-- example, in order to replace any values in @ot1@ with those covered by
-- @ot2@, we can use:
--
-- @
-- 'combineAla' 'Data.Semigroup.Last' ot1 ot2
-- @
combineAla :: forall n a. (Coercible a n, Semigroup n)  => (a -> n) -> OctTree a -> OctTree a -> OctTree a
combineAla :: forall n a.
(Coercible a n, Semigroup n) =>
(a -> n) -> OctTree a -> OctTree a -> OctTree a
combineAla a -> n
_ OctTree a
x OctTree 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 OctTree a
x :: OctTree n) forall a. Semigroup a => a -> a -> a
<> coerce :: forall a b. Coercible a b => a -> b
coerce OctTree a
y