{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE StrictData #-}
module Data.OctTree
( OctTree (..)
, fill
, combineAla
, lookup
, query
, fuse
, elements
, toCubes
, boundingCube
, defaultValue
, Cube (..)
, mkCubeByPow
, midpoint
, subdivide
, Raw.cubeCorners
, 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)
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 :: 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))
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)
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)
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
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
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
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
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 :: 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 :: 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
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 :: 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
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
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 :: 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
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