{- ORMOLU_DISABLE -}
-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
-- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com)
-- Copyright 2015 2016, Mike MacHenry (mike.machenry@gmail.com)
-- Released under the GNU AGPLV3+, see LICENSE

module Graphics.Implicit.ObjectUtil.GetBox3 (getBox3) where

import Prelude(uncurry, pure, Bool(False), Either (Left, Right), (==), max, (/), (-), (+), fmap, unzip, ($), (<$>), (.), minimum, maximum, min, (>), (*), (<), abs, either, const, otherwise, take, fst, snd)

import Graphics.Implicit.Definitions
    ( Fastℕ,
      fromFastℕ,
      ExtrudeMScale(C2, C1),
      SymbolicObj3(Shared3, Cube, Sphere, Cylinder, Rotate3, Transform3, Extrude, ExtrudeOnEdgeOf, ExtrudeM, RotateExtrude),
      Box3,
      ℝ,
      fromFastℕtoℝ,
      toScaleFn )

import Graphics.Implicit.ObjectUtil.GetBox2 (getBox2, getBox2R)

import Graphics.Implicit.ObjectUtil.GetBoxShared (corners, pointsBox, getBoxShared)

import Linear (V2(V2), V3(V3))
import qualified Linear

-- FIXME: many variables are being ignored here. no rounding for intersect, or difference.. etc.

-- Get a Box3 around the given object.
getBox3 :: SymbolicObj3 -> Box3
-- Primitives
getBox3 :: SymbolicObj3 -> Box3
getBox3 (Shared3 SharedObj SymbolicObj3 V3 ℝ
obj) = forall obj (f :: * -> *) a.
(Object obj f a, VectorStuff (f a), ComponentWiseMultable (f a),
 Fractional a, Metric f) =>
SharedObj obj f a -> (f a, f a)
getBoxShared SharedObj SymbolicObj3 V3 ℝ
obj
getBox3 (Cube V3 ℝ
size) = (forall (f :: * -> *) a. Applicative f => a -> f a
pure ℝ
0, V3 ℝ
size)
getBox3 (Sphere ℝ
r) = (forall (f :: * -> *) a. Applicative f => a -> f a
pure (-ℝ
r), forall (f :: * -> *) a. Applicative f => a -> f a
pure ℝ
r)
getBox3 (Cylinder ℝ
h ℝ
r1 ℝ
r2) = (forall a. a -> a -> a -> V3 a
V3 (-ℝ
r) (-ℝ
r) ℝ
0, forall a. a -> a -> a -> V3 a
V3 ℝ
r ℝ
r ℝ
h ) where r :: ℝ
r = forall a. Ord a => a -> a -> a
max ℝ
r1 ℝ
r2
-- (Rounded) CSG
-- Simple transforms
getBox3 (Rotate3 Quaternion ℝ
q SymbolicObj3
symbObj) =
    let box :: Box3
box = SymbolicObj3 -> Box3
getBox3 SymbolicObj3
symbObj
     in forall (f :: * -> *) a.
(Applicative f, Num a, VectorStuff (f a)) =>
[f a] -> (f a, f a)
pointsBox forall a b. (a -> b) -> a -> b
$ forall a.
(Conjugate a, RealFloat a) =>
Quaternion a -> V3 a -> V3 a
Linear.rotate Quaternion ℝ
q forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall vec. VectorStuff vec => (vec, vec) -> [vec]
corners Box3
box
getBox3 (Transform3 M44 ℝ
m SymbolicObj3
symbObj) =
    let box :: Box3
box = SymbolicObj3 -> Box3
getBox3 SymbolicObj3
symbObj
     in forall (f :: * -> *) a.
(Applicative f, Num a, VectorStuff (f a)) =>
[f a] -> (f a, f a)
pointsBox forall a b. (a -> b) -> a -> b
$ forall a. Fractional a => V4 a -> V3 a
Linear.normalizePoint forall b c a. (b -> c) -> (a -> b) -> a -> c
. (M44 ℝ
m forall (m :: * -> *) (r :: * -> *) a.
(Functor m, Foldable r, Additive r, Num a) =>
m (r a) -> r a -> m a
Linear.!*) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => V3 a -> V4 a
Linear.point forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall vec. VectorStuff vec => (vec, vec) -> [vec]
corners Box3
box
-- Misc
-- 2D Based
getBox3 (Extrude SymbolicObj2
symbObj ℝ
h) = (forall a. a -> a -> a -> V3 a
V3 ℝ
x1 ℝ
y1 ℝ
0, forall a. a -> a -> a -> V3 a
V3 ℝ
x2 ℝ
y2 ℝ
h)
    where
        (V2 ℝ
x1 ℝ
y1, V2 ℝ
x2 ℝ
y2) = SymbolicObj2 -> (ℝ2, ℝ2)
getBox2 SymbolicObj2
symbObj
getBox3 (ExtrudeOnEdgeOf SymbolicObj2
symbObj1 SymbolicObj2
symbObj2) =
    let
        (V2 ℝ
ax1 ℝ
ay1, V2 ℝ
ax2 ℝ
ay2) = SymbolicObj2 -> (ℝ2, ℝ2)
getBox2 SymbolicObj2
symbObj1
        (V2 ℝ
bx1 ℝ
by1, V2 ℝ
bx2 ℝ
by2) = SymbolicObj2 -> (ℝ2, ℝ2)
getBox2 SymbolicObj2
symbObj2
    in
        (forall a. a -> a -> a -> V3 a
V3 (ℝ
bx1forall a. Num a => a -> a -> a
+ℝ
ax1) (ℝ
by1forall a. Num a => a -> a -> a
+ℝ
ax1) ℝ
ay1, forall a. a -> a -> a -> V3 a
V3 (ℝ
bx2forall a. Num a => a -> a -> a
+ℝ
ax2) (ℝ
by2forall a. Num a => a -> a -> a
+ℝ
ax2) ℝ
ay2)
-- FIXME: magic numbers: 0.2 and 11.
-- FIXME: this may use an approximation, based on sampling functions. generate a warning if the approximation part of this function is used.
-- FIXME: re-implement the expression system, so this can recieve a function, and determine class (constant, linear)... and implement better forms of this function.
getBox3 (ExtrudeM Either ℝ (ℝ -> ℝ)
twist ExtrudeMScale
scale Either ℝ2 (ℝ -> ℝ2)
translate SymbolicObj2
symbObj Either ℝ (ℝ2 -> ℝ)
height) =
    let
        (V2 ℝ
x1 ℝ
y1, V2 ℝ
x2 ℝ
y2) = SymbolicObj2 -> (ℝ2, ℝ2)
getBox2 SymbolicObj2
symbObj
        (ℝ
dx, ℝ
dy) = (ℝ
x2 forall a. Num a => a -> a -> a
- ℝ
x1, ℝ
y2 forall a. Num a => a -> a -> a
- ℝ
y1)

        samples :: Fastℕ
        samples :: Fastℕ
samples = Fastℕ
11
        range :: [Fastℕ]
        range :: [Fastℕ]
range = [Fastℕ
0, Fastℕ
1 .. (Fastℕ
samplesforall a. Num a => a -> a -> a
-Fastℕ
1)]
        ([ℝ]
xrange, [ℝ]
yrange) = ( forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((\ℝ
s -> ℝ
x1forall a. Num a => a -> a -> a
+ℝ
sforall a. Num a => a -> a -> a
*ℝ
dxforall a. Fractional a => a -> a -> a
/Fastℕ -> ℝ
fromFastℕtoℝ (Fastℕ
samplesforall a. Num a => a -> a -> a
-Fastℕ
1)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fastℕ -> ℝ
fromFastℕtoℝ) [Fastℕ]
range, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((\ℝ
s -> ℝ
y1forall a. Num a => a -> a -> a
+ℝ
sforall a. Num a => a -> a -> a
*ℝ
dyforall a. Fractional a => a -> a -> a
/Fastℕ -> ℝ
fromFastℕtoℝ (Fastℕ
samplesforall a. Num a => a -> a -> a
-Fastℕ
1)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fastℕ -> ℝ
fromFastℕtoℝ) [Fastℕ]
range)

        hfuzz :: ℝ
        hfuzz :: ℝ
hfuzz = ℝ
0.2
        h :: ℝ
h = case Either ℝ (ℝ2 -> ℝ)
height of
              Left ℝ
hval -> ℝ
hval
              Right ℝ2 -> ℝ
hfun -> ℝ
hmax forall a. Num a => a -> a -> a
+ ℝ
hfuzzforall a. Num a => a -> a -> a
*(ℝ
hmaxforall a. Num a => a -> a -> a
-ℝ
hmin)
                where
                    hs :: [ℝ]
hs = [ℝ2 -> ℝ
hfun forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> V2 a
V2 ℝ
x ℝ
y | ℝ
x <- [ℝ]
xrange, ℝ
y <- [ℝ]
yrange]
                    (ℝ
hmin, ℝ
hmax) = (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [ℝ]
hs, forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [ℝ]
hs)
        hrange :: [ℝ]
hrange = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall a. Fractional a => a -> a -> a
/ Fastℕ -> ℝ
fromFastℕtoℝ (Fastℕ
samplesforall a. Num a => a -> a -> a
-Fastℕ
1)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ℝ
hforall a. Num a => a -> a -> a
*) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fastℕ -> ℝ
fromFastℕtoℝ) [Fastℕ]
range

        (ℝ
twistXmin, ℝ
twistYmin, ℝ
twistXmax, ℝ
twistYmax) =
          let
            both :: (t -> b) -> (t, t) -> (b, b)
both t -> b
f (t
a, t
b) = (t -> b
f t
a, t -> b
f t
b)
            (V2 ℝ
scalex' ℝ
scaley') = case ExtrudeMScale
scale of
              C1 ℝ
s -> forall a. a -> a -> V2 a
V2 ℝ
s ℝ
s
              C2 ℝ2
s -> ℝ2
s
              ExtrudeMScale
s -> forall a. (a, a) -> V2 a
pack forall a b. (a -> b) -> a -> b
$ forall {t} {b}. (t -> b) -> (t, t) -> (b, b)
both forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. V2 a -> (a, a)
unpack forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Num a => a -> a
abs forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtrudeMScale -> ℝ -> ℝ2
toScaleFn ExtrudeMScale
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ℝ]
hrange
            smin :: a -> a -> a
smin a
s a
v = forall a. Ord a => a -> a -> a
min a
v (a
s forall a. Num a => a -> a -> a
* a
v)
            smax :: a -> a -> a
smax a
s a
v = forall a. Ord a => a -> a -> a
max a
v (a
s forall a. Num a => a -> a -> a
* a
v)
            -- FIXME: assumes minimums are negative, and maximums are positive.
            scaleEach :: (ℝ2, ℝ2) -> (ℝ, ℝ, ℝ, ℝ)
scaleEach (V2 ℝ
d1 ℝ
d2, V2 ℝ
d3 ℝ
d4) = (ℝ
scalex' forall a. Num a => a -> a -> a
* ℝ
d1, ℝ
scaley' forall a. Num a => a -> a -> a
* ℝ
d2, ℝ
scalex' forall a. Num a => a -> a -> a
* ℝ
d3, ℝ
scaley' forall a. Num a => a -> a -> a
* ℝ
d4)
          in case Either ℝ (ℝ -> ℝ)
twist of
            Left ℝ
twval -> if ℝ
twval forall a. Eq a => a -> a -> Bool
== ℝ
0
                          then (forall {a}. (Ord a, Num a) => a -> a -> a
smin ℝ
scalex' ℝ
x1, forall {a}. (Ord a, Num a) => a -> a -> a
smin ℝ
scaley' ℝ
y1, forall {a}. (Ord a, Num a) => a -> a -> a
smax ℝ
scalex' ℝ
x2, forall {a}. (Ord a, Num a) => a -> a -> a
smax ℝ
scaley' ℝ
y2)
                          else (ℝ2, ℝ2) -> (ℝ, ℝ, ℝ, ℝ)
scaleEach forall a b. (a -> b) -> a -> b
$ SymbolicObj2 -> ℝ -> (ℝ2, ℝ2)
getBox2R SymbolicObj2
symbObj ℝ
twval
            Right ℝ -> ℝ
_  -> (ℝ2, ℝ2) -> (ℝ, ℝ, ℝ, ℝ)
scaleEach forall a b. (a -> b) -> a -> b
$ SymbolicObj2 -> ℝ -> (ℝ2, ℝ2)
getBox2R SymbolicObj2
symbObj ℝ
360 -- we can't range functions yet, so assume a full circle.

        (ℝ
tminx, ℝ
tmaxx, ℝ
tminy, ℝ
tmaxy) =
          let
            tvalsx :: (ℝ -> V2 ℝ) -> [ℝ]
            tvalsx :: (ℝ -> ℝ2) -> [ℝ]
tvalsx ℝ -> ℝ2
tfun = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. V2 a -> (a, a)
unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ℝ -> ℝ2
tfun) [ℝ]
hrange
            tvalsy :: (ℝ -> V2 ℝ) -> [ℝ]
            tvalsy :: (ℝ -> ℝ2) -> [ℝ]
tvalsy ℝ -> ℝ2
tfun = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. V2 a -> (a, a)
unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ℝ -> ℝ2
tfun) [ℝ]
hrange
          in case Either ℝ2 (ℝ -> ℝ2)
translate of
            Left  (V2 ℝ
tvalx ℝ
tvaly) -> (ℝ
tvalx, ℝ
tvalx, ℝ
tvaly, ℝ
tvaly)
            Right ℝ -> ℝ2
tfun -> ( forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum forall a b. (a -> b) -> a -> b
$ (ℝ -> ℝ2) -> [ℝ]
tvalsx ℝ -> ℝ2
tfun
                          , forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ (ℝ -> ℝ2) -> [ℝ]
tvalsx ℝ -> ℝ2
tfun
                          , forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum forall a b. (a -> b) -> a -> b
$ (ℝ -> ℝ2) -> [ℝ]
tvalsy ℝ -> ℝ2
tfun
                          , forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ (ℝ -> ℝ2) -> [ℝ]
tvalsy ℝ -> ℝ2
tfun
                          )
    in
        (forall a. a -> a -> a -> V3 a
V3 (ℝ
twistXmin forall a. Num a => a -> a -> a
+ ℝ
tminx) (ℝ
twistYmin forall a. Num a => a -> a -> a
+ ℝ
tminy) ℝ
0, forall a. a -> a -> a -> V3 a
V3 (ℝ
twistXmax forall a. Num a => a -> a -> a
+ ℝ
tmaxx) (ℝ
twistYmax forall a. Num a => a -> a -> a
+ ℝ
tmaxy) ℝ
h)
-- Note: Assumes x2 is always greater than x1.
-- FIXME: Insert the above assumption as an assertion in the type system?
getBox3 (RotateExtrude ℝ
_ (Left (V2 ℝ
xshift ℝ
yshift)) Either ℝ (ℝ -> ℝ)
_ SymbolicObj2
symbObj) =
    let
        (V2 ℝ
_ ℝ
y1, V2 ℝ
x2 ℝ
y2) = SymbolicObj2 -> (ℝ2, ℝ2)
getBox2 SymbolicObj2
symbObj
        r :: ℝ
r = forall a. Ord a => a -> a -> a
max ℝ
x2 (ℝ
x2 forall a. Num a => a -> a -> a
+ ℝ
xshift)
    in
        (forall a. a -> a -> a -> V3 a
V3 (-ℝ
r) (-ℝ
r) forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
min ℝ
y1 (ℝ
y1 forall a. Num a => a -> a -> a
+ ℝ
yshift), forall a. a -> a -> a -> V3 a
V3 ℝ
r ℝ
r forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max ℝ
y2 (ℝ
y2 forall a. Num a => a -> a -> a
+ ℝ
yshift))
-- FIXME: magic numbers: 0.1, 1.1, and 11.
-- FIXME: this may use an approximation, based on sampling functions. generate a warning if the approximation part of this function is used.
-- FIXME: re-implement the expression system, so this can recieve a function, and determine class (constant, linear)... and implement better forms of this function.
getBox3 (RotateExtrude ℝ
rot (Right ℝ -> ℝ2
f) Either ℝ (ℝ -> ℝ)
rotate SymbolicObj2
symbObj) =
    let
        samples :: Fastℕ
        samples :: Fastℕ
samples = Fastℕ
11
        xfuzz :: ℝ
        xfuzz :: ℝ
xfuzz = ℝ
1.1
        yfuzz :: ℝ
        yfuzz :: ℝ
yfuzz=ℝ
0.1
        range :: [Fastℕ]
        range :: [Fastℕ]
range = [Fastℕ
0, Fastℕ
1 .. (Fastℕ
samplesforall a. Num a => a -> a -> a
-Fastℕ
1)]
        step :: ℝ
step = ℝ
rotforall a. Fractional a => a -> a -> a
/Fastℕ -> ℝ
fromFastℕtoℝ (Fastℕ
samplesforall a. Num a => a -> a -> a
-Fastℕ
1)
        (V2 ℝ
x1 ℝ
y1, V2 ℝ
x2 ℝ
y2) = SymbolicObj2 -> (ℝ2, ℝ2)
getBox2 SymbolicObj2
symbObj
        ([ℝ]
xrange, [ℝ]
yrange) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. V2 a -> (a, a)
unpack forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take (forall n. FastN n => Fastℕ -> n
fromFastℕ Fastℕ
samples) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ℝ -> ℝ2
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ℝ
stepforall a. Num a => a -> a -> a
*) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fastℕ -> ℝ
fromFastℕtoℝ) [Fastℕ]
range
        xmax :: ℝ
xmax = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [ℝ]
xrange
        ymax :: ℝ
ymax = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [ℝ]
yrange
        ymin :: ℝ
ymin = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [ℝ]
yrange
        xmax' :: ℝ
xmax' | ℝ
xmax forall a. Ord a => a -> a -> Bool
> ℝ
0 = ℝ
xmax forall a. Num a => a -> a -> a
* ℝ
xfuzz
              | ℝ
xmax forall a. Ord a => a -> a -> Bool
< - ℝ
x1 = ℝ
0
              | Bool
otherwise = ℝ
xmax
        ymax' :: ℝ
ymax' = ℝ
ymax forall a. Num a => a -> a -> a
+ ℝ
yfuzz forall a. Num a => a -> a -> a
* (ℝ
ymax forall a. Num a => a -> a -> a
- ℝ
ymin)
        ymin' :: ℝ
ymin' = ℝ
ymin forall a. Num a => a -> a -> a
- ℝ
yfuzz forall a. Num a => a -> a -> a
* (ℝ
ymax forall a. Num a => a -> a -> a
- ℝ
ymin)
        (ℝ
r, ℝ
_, ℝ
_) = if forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Eq a => a -> a -> Bool
==ℝ
0) (forall a b. a -> b -> a
const Bool
False) Either ℝ (ℝ -> ℝ)
rotate
            then let
                s :: ℝ
s = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Num a => a -> a
abs [ℝ
x2, ℝ
y1, ℝ
y2]
            in (ℝ
s forall a. Num a => a -> a -> a
+ ℝ
xmax', ℝ
s forall a. Num a => a -> a -> a
+ ℝ
ymin', ℝ
y2 forall a. Num a => a -> a -> a
+ ℝ
ymax')
            else (ℝ
x2 forall a. Num a => a -> a -> a
+ ℝ
xmax', ℝ
y1 forall a. Num a => a -> a -> a
+ ℝ
ymin', ℝ
y2 forall a. Num a => a -> a -> a
+ ℝ
ymax')
    in
        (forall a. a -> a -> a -> V3 a
V3 (-ℝ
r) (-ℝ
r) forall a b. (a -> b) -> a -> b
$ ℝ
y1 forall a. Num a => a -> a -> a
+ ℝ
ymin', forall a. a -> a -> a -> V3 a
V3 ℝ
r  ℝ
r  forall a b. (a -> b) -> a -> b
$ ℝ
y2 forall a. Num a => a -> a -> a
+ ℝ
ymax')

unpack :: V2 a -> (a, a)
unpack :: forall a. V2 a -> (a, a)
unpack (V2 a
a a
b) = (a
a, a
b)

pack :: (a, a) -> V2 a
pack :: forall a. (a, a) -> V2 a
pack = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. a -> a -> V2 a
V2