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

module Graphics.Implicit.ObjectUtil.GetImplicit3 (getImplicit3) where

import Prelude (id, (||), (/=), either, round, fromInteger, Either(Left, Right), abs, (-), (/), (*), sqrt, (+), atan2, max, cos, minimum, ($), sin, pi, (.), Bool(True, False), ceiling, floor, pure, (==), otherwise)

import Graphics.Implicit.Definitions
    ( objectRounding, ObjectContext, ℕ, SymbolicObj3(Cube, Sphere, Cylinder, Rotate3, Transform3, Extrude, ExtrudeM, ExtrudeOnEdgeOf, RotateExtrude, Shared3), Obj3, ℝ2, ℝ, fromℕtoℝ, toScaleFn )

import Graphics.Implicit.MathUtil ( rmax, rmaximum )

import qualified Data.Either as Either (either)

-- Use getImplicit for handling extrusion of 2D shapes to 3D.
import Graphics.Implicit.ObjectUtil.GetImplicitShared (getImplicitShared)
import Linear (V2(V2), V3(V3))
import qualified Linear

import {-# SOURCE #-} Graphics.Implicit.Primitives (getImplicit)

default (ℝ)

-- Get a function that describes the surface of the object.
getImplicit3 :: ObjectContext -> SymbolicObj3 -> Obj3
-- Primitives
getImplicit3 :: ObjectContext -> SymbolicObj3 -> Obj3
getImplicit3 ObjectContext
ctx (Cube (V3 ℝ
dx ℝ
dy ℝ
dz)) =
    \(V3 ℝ
x ℝ
y ℝ
z) -> ℝ -> [ℝ] -> ℝ
rmaximum (ObjectContext -> ℝ
objectRounding ObjectContext
ctx) [forall a. Num a => a -> a
abs (ℝ
xforall a. Num a => a -> a -> a
-ℝ
dxforall a. Fractional a => a -> a -> a
/ℝ
2) forall a. Num a => a -> a -> a
- ℝ
dxforall a. Fractional a => a -> a -> a
/ℝ
2, forall a. Num a => a -> a
abs (ℝ
yforall a. Num a => a -> a -> a
-ℝ
dyforall a. Fractional a => a -> a -> a
/ℝ
2) forall a. Num a => a -> a -> a
- ℝ
dyforall a. Fractional a => a -> a -> a
/ℝ
2, forall a. Num a => a -> a
abs (ℝ
zforall a. Num a => a -> a -> a
-ℝ
dzforall a. Fractional a => a -> a -> a
/ℝ
2) forall a. Num a => a -> a -> a
- ℝ
dzforall a. Fractional a => a -> a -> a
/ℝ
2]
getImplicit3 ObjectContext
_ (Sphere ℝ
r) =
    \(V3 ℝ
x ℝ
y ℝ
z) -> forall a. Floating a => a -> a
sqrt (ℝ
xforall a. Num a => a -> a -> a
*ℝ
x forall a. Num a => a -> a -> a
+ ℝ
yforall a. Num a => a -> a -> a
*ℝ
y forall a. Num a => a -> a -> a
+ ℝ
zforall a. Num a => a -> a -> a
*ℝ
z) forall a. Num a => a -> a -> a
- ℝ
r
getImplicit3 ObjectContext
_ (Cylinder ℝ
h ℝ
r1 ℝ
r2) = \(V3 ℝ
x ℝ
y ℝ
z) ->
    let
        d :: ℝ
d = forall a. Floating a => a -> a
sqrt (ℝ
xforall a. Num a => a -> a -> a
*ℝ
x forall a. Num a => a -> a -> a
+ ℝ
yforall a. Num a => a -> a -> a
*ℝ
y) forall a. Num a => a -> a -> a
- ((ℝ
r2forall a. Num a => a -> a -> a
-ℝ
r1)forall a. Fractional a => a -> a -> a
/ℝ
hforall a. Num a => a -> a -> a
*ℝ
zforall a. Num a => a -> a -> a
+ℝ
r1)
        θ :: ℝ
θ = forall a. RealFloat a => a -> a -> a
atan2 (ℝ
r2forall a. Num a => a -> a -> a
-ℝ
r1) ℝ
h
    in
        forall a. Ord a => a -> a -> a
max (ℝ
d forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
cos ℝ
θ) (forall a. Num a => a -> a
abs (ℝ
zforall a. Num a => a -> a -> a
-ℝ
hforall a. Fractional a => a -> a -> a
/ℝ
2) forall a. Num a => a -> a -> a
- (ℝ
hforall a. Fractional a => a -> a -> a
/ℝ
2))
-- Simple transforms
getImplicit3 ObjectContext
ctx (Rotate3 Quaternion ℝ
q SymbolicObj3
symbObj) =
    ObjectContext -> SymbolicObj3 -> Obj3
getImplicit3 ObjectContext
ctx SymbolicObj3
symbObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(Conjugate a, RealFloat a) =>
Quaternion a -> V3 a -> V3 a
Linear.rotate (forall a. Conjugate a => a -> a
Linear.conjugate Quaternion ℝ
q)
getImplicit3 ObjectContext
ctx (Transform3 M44 ℝ
m SymbolicObj3
symbObj) =
    ObjectContext -> SymbolicObj3 -> Obj3
getImplicit3 ObjectContext
ctx SymbolicObj3
symbObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Fractional a => V4 a -> V3 a
Linear.normalizePoint forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Fractional a => M44 a -> M44 a
Linear.inv44 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
-- 2D Based
getImplicit3 ObjectContext
ctx (Extrude SymbolicObj2
symbObj ℝ
h) =
    let
        obj :: V2 ℝ -> ℝ
obj = forall obj (f :: * -> *) a. Object obj f a => obj -> f a -> a
getImplicit SymbolicObj2
symbObj
    in
        \(V3 ℝ
x ℝ
y ℝ
z) -> ℝ -> ℝ -> ℝ -> ℝ
rmax (ObjectContext -> ℝ
objectRounding ObjectContext
ctx) (V2 ℝ -> ℝ
obj (forall a. a -> a -> V2 a
V2 ℝ
x ℝ
y)) (forall a. Num a => a -> a
abs (ℝ
z forall a. Num a => a -> a -> a
- ℝ
hforall a. Fractional a => a -> a -> a
/ℝ
2) forall a. Num a => a -> a -> a
- ℝ
hforall a. Fractional a => a -> a -> a
/ℝ
2)
getImplicit3 ObjectContext
ctx (ExtrudeM Either ℝ (ℝ -> ℝ)
twist ExtrudeMScale
scale Either (V2 ℝ) (ℝ -> V2 ℝ)
translate SymbolicObj2
symbObj Either ℝ (V2 ℝ -> ℝ)
height) =
    let
        r :: ℝ
r = ObjectContext -> ℝ
objectRounding ObjectContext
ctx
        obj :: V2 ℝ -> ℝ
obj = forall obj (f :: * -> *) a. Object obj f a => obj -> f a -> a
getImplicit SymbolicObj2
symbObj
        height' :: V2 ℝ -> ℝ
height' (V2 ℝ
x ℝ
y) = case Either ℝ (V2 ℝ -> ℝ)
height of
            Left ℝ
n -> ℝ
n
            Right V2 ℝ -> ℝ
f -> V2 ℝ -> ℝ
f (forall a. a -> a -> V2 a
V2 ℝ
x ℝ
y)
        -- FIXME: twist functions should have access to height, if height is allowed to vary.
        twistVal :: Either ℝ (ℝ -> ℝ) -> ℝ -> ℝ -> ℝ
        twistVal :: Either ℝ (ℝ -> ℝ) -> ℝ -> ℝ -> ℝ
twistVal Either ℝ (ℝ -> ℝ)
twist' ℝ
z ℝ
h =
          case Either ℝ (ℝ -> ℝ)
twist' of
                   Left ℝ
twval  -> if ℝ
twval forall a. Eq a => a -> a -> Bool
== ℝ
0
                                  then ℝ
0
                                  else ℝ
twval forall a. Num a => a -> a -> a
* (ℝ
z forall a. Fractional a => a -> a -> a
/ ℝ
h)
                   Right ℝ -> ℝ
twfun -> ℝ -> ℝ
twfun ℝ
z
        translatePos :: Either ℝ2 (ℝ -> ℝ2) -> ℝ -> ℝ2 -> ℝ2
        translatePos :: Either (V2 ℝ) (ℝ -> V2 ℝ) -> ℝ -> V2 ℝ -> V2 ℝ
translatePos Either (V2 ℝ) (ℝ -> V2 ℝ)
trans ℝ
z (V2 ℝ
x ℝ
y) = forall a. a -> a -> V2 a
V2 (ℝ
x forall a. Num a => a -> a -> a
- ℝ
xTrans) (ℝ
y forall a. Num a => a -> a -> a
- ℝ
yTrans)
          where
            (V2 ℝ
xTrans ℝ
yTrans) = case Either (V2 ℝ) (ℝ -> V2 ℝ)
trans of
                                 Left  V2 ℝ
tval -> V2 ℝ
tval
                                 Right ℝ -> V2 ℝ
tfun -> ℝ -> V2 ℝ
tfun ℝ
z
        scaleVec :: ℝ -> ℝ2 -> ℝ2
        scaleVec :: ℝ -> V2 ℝ -> V2 ℝ
scaleVec ℝ
z (V2 ℝ
x ℝ
y) = let (V2 ℝ
sx ℝ
sy) = ExtrudeMScale -> ℝ -> V2 ℝ
toScaleFn ExtrudeMScale
scale ℝ
z
                               in forall a. a -> a -> V2 a
V2 (ℝ
x forall a. Fractional a => a -> a -> a
/ ℝ
sx) (ℝ
y forall a. Fractional a => a -> a -> a
/ ℝ
sy)
        rotateVec :: ℝ -> ℝ2 -> ℝ2
        rotateVec :: ℝ -> V2 ℝ -> V2 ℝ
rotateVec ℝ
θ (V2 ℝ
x ℝ
y)
          | ℝ
θ forall a. Eq a => a -> a -> Bool
== ℝ
0    = forall a. a -> a -> V2 a
V2 ℝ
x ℝ
y
          | Bool
otherwise = forall a. a -> a -> V2 a
V2 (ℝ
xforall a. Num a => a -> a -> a
*forall a. Floating a => a -> a
cos ℝ
θ forall a. Num a => a -> a -> a
+ ℝ
yforall a. Num a => a -> a -> a
*forall a. Floating a => a -> a
sin ℝ
θ) (ℝ
yforall a. Num a => a -> a -> a
*forall a. Floating a => a -> a
cos ℝ
θ forall a. Num a => a -> a -> a
- ℝ
xforall a. Num a => a -> a -> a
*forall a. Floating a => a -> a
sin ℝ
θ)
        k :: ℝ
        k :: ℝ
k = forall a. Floating a => a
piforall a. Fractional a => a -> a -> a
/ℝ
180
    in
        \(V3 ℝ
x ℝ
y ℝ
z) ->
          let
            h :: ℝ
h = V2 ℝ -> ℝ
height' forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> V2 a
V2 ℝ
x ℝ
y
            res :: ℝ
res = ℝ -> ℝ -> ℝ -> ℝ
rmax ℝ
r
                (V2 ℝ -> ℝ
obj
                 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ℝ -> V2 ℝ -> V2 ℝ
rotateVec (-ℝ
kforall a. Num a => a -> a -> a
*Either ℝ (ℝ -> ℝ) -> ℝ -> ℝ -> ℝ
twistVal Either ℝ (ℝ -> ℝ)
twist ℝ
z ℝ
h)
                 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ℝ -> V2 ℝ -> V2 ℝ
scaleVec ℝ
z
                 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (V2 ℝ) (ℝ -> V2 ℝ) -> ℝ -> V2 ℝ -> V2 ℝ
translatePos Either (V2 ℝ) (ℝ -> V2 ℝ)
translate ℝ
z
                 forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> V2 a
V2 ℝ
x ℝ
y )
                (forall a. Num a => a -> a
abs (ℝ
z forall a. Num a => a -> a -> a
- ℝ
hforall a. Fractional a => a -> a -> a
/ℝ
2) forall a. Num a => a -> a -> a
- ℝ
hforall a. Fractional a => a -> a -> a
/ℝ
2)
          in
            ℝ
res
getImplicit3 ObjectContext
_ (ExtrudeOnEdgeOf SymbolicObj2
symbObj1 SymbolicObj2
symbObj2) =
    let
        obj1 :: V2 ℝ -> ℝ
obj1 = forall obj (f :: * -> *) a. Object obj f a => obj -> f a -> a
getImplicit SymbolicObj2
symbObj1
        obj2 :: V2 ℝ -> ℝ
obj2 = forall obj (f :: * -> *) a. Object obj f a => obj -> f a -> a
getImplicit SymbolicObj2
symbObj2
    in
        \(V3 ℝ
x ℝ
y ℝ
z) -> V2 ℝ -> ℝ
obj1 forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> V2 a
V2 (V2 ℝ -> ℝ
obj2 (forall a. a -> a -> V2 a
V2 ℝ
x ℝ
y)) ℝ
z
getImplicit3 ObjectContext
ctx (RotateExtrude ℝ
totalRotation Either (V2 ℝ) (ℝ -> V2 ℝ)
translate Either ℝ (ℝ -> ℝ)
rotate SymbolicObj2
symbObj) =
    let
        tau :: ℝ
        tau :: ℝ
tau = ℝ
2 forall a. Num a => a -> a -> a
* forall a. Floating a => a
pi
        obj :: V2 ℝ -> ℝ
obj = forall obj (f :: * -> *) a. Object obj f a => obj -> f a -> a
getImplicit SymbolicObj2
symbObj

        is360m :: ℝ -> Bool
        is360m :: ℝ -> Bool
is360m ℝ
n = ℝ
tau forall a. Num a => a -> a -> a
* forall a. Num a => Integer -> a
fromInteger (forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ ℝ
n forall a. Fractional a => a -> a -> a
/ ℝ
tau) forall a. Eq a => a -> a -> Bool
/= ℝ
n
        capped :: Bool
capped
             = ℝ -> Bool
is360m ℝ
totalRotation
            Bool -> Bool -> Bool
|| forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ( forall a. Eq a => a -> a -> Bool
/= forall (f :: * -> *) a. Applicative f => a -> f a
pure ℝ
0) (\ℝ -> V2 ℝ
f -> ℝ -> V2 ℝ
f ℝ
0 forall a. Eq a => a -> a -> Bool
/= ℝ -> V2 ℝ
f ℝ
totalRotation) Either (V2 ℝ) (ℝ -> V2 ℝ)
translate
            Bool -> Bool -> Bool
|| forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ℝ -> Bool
is360m (\ℝ -> ℝ
f -> ℝ -> Bool
is360m (ℝ -> ℝ
f ℝ
0 forall a. Num a => a -> a -> a
- ℝ -> ℝ
f ℝ
totalRotation)) Either ℝ (ℝ -> ℝ)
rotate
        round' :: ℝ
round' = ObjectContext -> ℝ
objectRounding ObjectContext
ctx
        translate' :: ℝ -> ℝ2
        translate' :: ℝ -> V2 ℝ
translate' = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
Either.either
                (\(V2 ℝ
a ℝ
b) ℝ
θ -> forall a. a -> a -> V2 a
V2 (ℝ
aforall a. Num a => a -> a -> a
*ℝ
θforall a. Fractional a => a -> a -> a
/ℝ
totalRotation) (ℝ
bforall a. Num a => a -> a -> a
*ℝ
θforall a. Fractional a => a -> a -> a
/ℝ
totalRotation))
                forall a. a -> a
id
                Either (V2 ℝ) (ℝ -> V2 ℝ)
translate
        rotate' :: ℝ -> ℝ
        rotate' :: ℝ -> ℝ
rotate' = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
Either.either
                (\ℝ
t ℝ
θ -> ℝ
tforall a. Num a => a -> a -> a
*ℝ
θforall a. Fractional a => a -> a -> a
/ℝ
totalRotation )
                forall a. a -> a
id
                Either ℝ (ℝ -> ℝ)
rotate
        twists :: Bool
twists = case Either ℝ (ℝ -> ℝ)
rotate of
                   Left ℝ
0  -> Bool
True
                   Either ℝ (ℝ -> ℝ)
_       -> Bool
False
    in
        \(V3 ℝ
x ℝ
y ℝ
z) -> forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum forall a b. (a -> b) -> a -> b
$ do
            let
                r :: ℝ
r = forall a. Floating a => a -> a
sqrt forall a b. (a -> b) -> a -> b
$ ℝ
xforall a. Num a => a -> a -> a
*ℝ
x forall a. Num a => a -> a -> a
+ ℝ
yforall a. Num a => a -> a -> a
*ℝ
y
                θ :: ℝ
θ = forall a. RealFloat a => a -> a -> a
atan2 ℝ
y ℝ
x
                ns :: [ℕ]
                ns :: [ℕ]
ns =
                    if Bool
capped
                    then -- we will cap a different way, but want leeway to keep the function cont
                        [-ℕ
1 .. forall a b. (RealFrac a, Integral b) => a -> b
ceiling forall a b. (a -> b) -> a -> b
$ (ℝ
totalRotation forall a. Fractional a => a -> a -> a
/ ℝ
tau) forall a. Num a => a -> a -> a
+ ℝ
1]
                    else
                        [ℕ
0 .. forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ (ℝ
totalRotation forall a. Num a => a -> a -> a
- ℝ
θ) forall a. Fractional a => a -> a -> a
/ ℝ
tau]
            ℕ
n <- [ℕ]
ns
            let
                θvirt :: ℝ
θvirt = ℕ -> ℝ
fromℕtoℝ ℕ
n forall a. Num a => a -> a -> a
* ℝ
tau forall a. Num a => a -> a -> a
+ ℝ
θ
                (V2 ℝ
rshift ℝ
zshift) = ℝ -> V2 ℝ
translate' ℝ
θvirt
                twist :: ℝ
twist = ℝ -> ℝ
rotate' ℝ
θvirt
                rz_pos :: V2 ℝ
rz_pos = if Bool
twists
                        then let
                            (ℝ
c,ℝ
s) = (forall a. Floating a => a -> a
cos ℝ
twist, forall a. Floating a => a -> a
sin ℝ
twist)
                            (ℝ
r',ℝ
z') = (ℝ
rforall a. Num a => a -> a -> a
-ℝ
rshift, ℝ
zforall a. Num a => a -> a -> a
-ℝ
zshift)
                        in
                            forall a. a -> a -> V2 a
V2 (ℝ
cforall a. Num a => a -> a -> a
*ℝ
r' forall a. Num a => a -> a -> a
- ℝ
sforall a. Num a => a -> a -> a
*ℝ
z') (ℝ
cforall a. Num a => a -> a -> a
*ℝ
z' forall a. Num a => a -> a -> a
+ ℝ
sforall a. Num a => a -> a -> a
*ℝ
r')
                        else forall a. a -> a -> V2 a
V2 (ℝ
r forall a. Num a => a -> a -> a
- ℝ
rshift) (ℝ
z forall a. Num a => a -> a -> a
- ℝ
zshift)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
              if Bool
capped
              then ℝ -> ℝ -> ℝ -> ℝ
rmax ℝ
round'
                    (forall a. Num a => a -> a
abs (ℝ
θvirt forall a. Num a => a -> a -> a
- (ℝ
totalRotation forall a. Fractional a => a -> a -> a
/ ℝ
2)) forall a. Num a => a -> a -> a
- (ℝ
totalRotation forall a. Fractional a => a -> a -> a
/ ℝ
2))
                    (V2 ℝ -> ℝ
obj V2 ℝ
rz_pos)
              else V2 ℝ -> ℝ
obj V2 ℝ
rz_pos
getImplicit3 ObjectContext
ctx (Shared3 SharedObj SymbolicObj3 V3 ℝ
obj) = forall obj (f :: * -> *).
(Object obj f ℝ, VectorStuff (f ℝ), ComponentWiseMultable (f ℝ),
 Metric f) =>
ObjectContext -> SharedObj obj f ℝ -> f ℝ -> ℝ
getImplicitShared ObjectContext
ctx SharedObj SymbolicObj3 V3 ℝ
obj