{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE FlexibleInstances #-}
module Waterfall.Transforms
( Transformable
, scale
, uScale
, rotate
, translate
, mirror
) where
import Waterfall.Internal.Solid (Solid (..), acquireSolid, solidFromAcquire)
import Waterfall.Internal.Finalizers (toAcquire, unsafeFromAcquire) 
import Linear.V3 (V3 (..))
import Linear ((*^), normalize, dot )
import qualified Linear.Quaternion as Quaternion
import qualified OpenCascade.GP.Trsf as GP.Trsf
import qualified OpenCascade.GP as GP
import qualified OpenCascade.GP.GTrsf as GP.GTrsf
import qualified OpenCascade.GP.Ax1 as GP.Ax1
import qualified OpenCascade.GP.Ax2 as GP.Ax2
import qualified OpenCascade.GP.Dir as GP.Dir
import qualified OpenCascade.GP.Vec as GP.Vec
import qualified OpenCascade.BRepBuilderAPI.Transform  as BRepBuilderAPI.Transform
import qualified OpenCascade.BRepBuilderAPI.GTransform  as BRepBuilderAPI.GTransform
import Control.Monad.IO.Class (liftIO)
import Data.Acquire
import Foreign.Ptr
import Waterfall.Internal.Path (Path(..))
import OpenCascade.Inheritance (upcast, unsafeDowncast)

-- | Typeclass for objects that can be manipulated in 3D space
class Transformable a where
    -- | Scale by different amounts along the x, y and z axes
    scale :: V3 Double -> a -> a
    -- Uniform Scale
    -- | Scale uniformally along all axes
    uScale :: Double -> a -> a
    -- | Rotate by Axis and Angle (in radians)
    rotate :: V3 Double -> Double -> a -> a
    -- | Translate by a vector in 3D space
    translate :: V3 Double -> a -> a
    -- | Mirror in the plane, which passes through the origin, tangent to the specified vector
    mirror :: V3 Double -> a -> a


fromTrsfSolid :: Acquire (Ptr GP.Trsf) -> Solid -> Solid
fromTrsfSolid :: Acquire (Ptr Trsf) -> Solid -> Solid
fromTrsfSolid Acquire (Ptr Trsf)
mkTrsf Solid
s = Acquire (Ptr Shape) -> Solid
solidFromAcquire (Acquire (Ptr Shape) -> Solid) -> Acquire (Ptr Shape) -> Solid
forall a b. (a -> b) -> a -> b
$ do 
    Ptr Shape
solid <- Solid -> Acquire (Ptr Shape)
acquireSolid Solid
s
    Ptr Trsf
trsf <- Acquire (Ptr Trsf)
mkTrsf 
    Ptr Shape -> Ptr Trsf -> Bool -> Acquire (Ptr Shape)
BRepBuilderAPI.Transform.transform Ptr Shape
solid Ptr Trsf
trsf Bool
True 


fromGTrsfSolid :: Acquire (Ptr GP.GTrsf) -> Solid -> Solid
fromGTrsfSolid :: Acquire (Ptr GTrsf) -> Solid -> Solid
fromGTrsfSolid Acquire (Ptr GTrsf)
mkTrsf Solid
s = Acquire (Ptr Shape) -> Solid
solidFromAcquire (Acquire (Ptr Shape) -> Solid) -> Acquire (Ptr Shape) -> Solid
forall a b. (a -> b) -> a -> b
$ do 
    Ptr Shape
solid <- Solid -> Acquire (Ptr Shape)
acquireSolid Solid
s
    Ptr GTrsf
trsf <- Acquire (Ptr GTrsf)
mkTrsf 
    Ptr Shape -> Ptr GTrsf -> Bool -> Acquire (Ptr Shape)
BRepBuilderAPI.GTransform.gtransform Ptr Shape
solid Ptr GTrsf
trsf Bool
True 


fromTrsfPath :: Acquire (Ptr GP.Trsf) -> Path -> Path
fromTrsfPath :: Acquire (Ptr Trsf) -> Path -> Path
fromTrsfPath Acquire (Ptr Trsf)
mkTrsf (Path Ptr Wire
p) = Ptr Wire -> Path
Path (Ptr Wire -> Path)
-> (Acquire (Ptr Wire) -> Ptr Wire) -> Acquire (Ptr Wire) -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Acquire (Ptr Wire) -> Ptr Wire
forall a. Acquire a -> a
unsafeFromAcquire (Acquire (Ptr Wire) -> Path) -> Acquire (Ptr Wire) -> Path
forall a b. (a -> b) -> a -> b
$ do 
    Ptr Wire
path <- Ptr Wire -> Acquire (Ptr Wire)
forall a. a -> Acquire a
toAcquire Ptr Wire
p
    Ptr Trsf
trsf <- Acquire (Ptr Trsf)
mkTrsf 
    (IO (Ptr Wire) -> Acquire (Ptr Wire)
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Wire) -> Acquire (Ptr Wire))
-> (Ptr Shape -> IO (Ptr Wire)) -> Ptr Shape -> Acquire (Ptr Wire)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Shape -> IO (Ptr Wire)
forall a b. DiscriminatedSubTypeOf a b => Ptr a -> IO (Ptr b)
unsafeDowncast) (Ptr Shape -> Acquire (Ptr Wire))
-> Acquire (Ptr Shape) -> Acquire (Ptr Wire)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr Shape -> Ptr Trsf -> Bool -> Acquire (Ptr Shape)
BRepBuilderAPI.Transform.transform (Ptr Wire -> Ptr Shape
forall a b. SubTypeOf a b => Ptr b -> Ptr a
upcast Ptr Wire
path) Ptr Trsf
trsf Bool
True 

fromGTrsfPath :: Acquire (Ptr GP.GTrsf) -> Path -> Path
fromGTrsfPath :: Acquire (Ptr GTrsf) -> Path -> Path
fromGTrsfPath Acquire (Ptr GTrsf)
mkTrsf (Path Ptr Wire
p) = Ptr Wire -> Path
Path (Ptr Wire -> Path)
-> (Acquire (Ptr Wire) -> Ptr Wire) -> Acquire (Ptr Wire) -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Acquire (Ptr Wire) -> Ptr Wire
forall a. Acquire a -> a
unsafeFromAcquire (Acquire (Ptr Wire) -> Path) -> Acquire (Ptr Wire) -> Path
forall a b. (a -> b) -> a -> b
$ do 
    Ptr Wire
path <- Ptr Wire -> Acquire (Ptr Wire)
forall a. a -> Acquire a
toAcquire Ptr Wire
p
    Ptr GTrsf
trsf <- Acquire (Ptr GTrsf)
mkTrsf 
    (IO (Ptr Wire) -> Acquire (Ptr Wire)
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Wire) -> Acquire (Ptr Wire))
-> (Ptr Shape -> IO (Ptr Wire)) -> Ptr Shape -> Acquire (Ptr Wire)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Shape -> IO (Ptr Wire)
forall a b. DiscriminatedSubTypeOf a b => Ptr a -> IO (Ptr b)
unsafeDowncast) (Ptr Shape -> Acquire (Ptr Wire))
-> Acquire (Ptr Shape) -> Acquire (Ptr Wire)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr Shape -> Ptr GTrsf -> Bool -> Acquire (Ptr Shape)
BRepBuilderAPI.GTransform.gtransform (Ptr Wire -> Ptr Shape
forall a b. SubTypeOf a b => Ptr b -> Ptr a
upcast Ptr Wire
path) Ptr GTrsf
trsf Bool
True 

scaleTrsf :: V3 Double -> Acquire (Ptr GP.GTrsf)
scaleTrsf :: V3 Double -> Acquire (Ptr GTrsf)
scaleTrsf (V3 Double
x Double
y Double
z ) = do
    Ptr GTrsf
trsf <- Acquire (Ptr GTrsf)
GP.GTrsf.new 
    IO (Ptr GTrsf) -> Acquire (Ptr GTrsf)
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr GTrsf) -> Acquire (Ptr GTrsf))
-> IO (Ptr GTrsf) -> Acquire (Ptr GTrsf)
forall a b. (a -> b) -> a -> b
$ do
        Ptr GTrsf -> Int -> Int -> Double -> IO ()
GP.GTrsf.setValue Ptr GTrsf
trsf Int
1 Int
1 Double
x
        Ptr GTrsf -> Int -> Int -> Double -> IO ()
GP.GTrsf.setValue Ptr GTrsf
trsf Int
2 Int
2 Double
y
        Ptr GTrsf -> Int -> Int -> Double -> IO ()
GP.GTrsf.setValue Ptr GTrsf
trsf Int
3 Int
3 Double
z
        Ptr GTrsf -> IO ()
GP.GTrsf.setForm Ptr GTrsf
trsf
        Ptr GTrsf -> IO (Ptr GTrsf)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr GTrsf
trsf

uScaleTrsf :: Double -> Acquire (Ptr GP.Trsf)
uScaleTrsf :: Double -> Acquire (Ptr Trsf)
uScaleTrsf Double
factor = do
    Ptr Trsf
trsf <- Acquire (Ptr Trsf)
GP.Trsf.new
    Ptr Pnt
o <- Acquire (Ptr Pnt)
GP.origin
    IO () -> Acquire ()
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Acquire ()) -> IO () -> Acquire ()
forall a b. (a -> b) -> a -> b
$ Ptr Trsf -> Ptr Pnt -> Double -> IO ()
GP.Trsf.setScale Ptr Trsf
trsf Ptr Pnt
o Double
factor 
    Ptr Trsf -> Acquire (Ptr Trsf)
forall a. a -> Acquire a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr Trsf
trsf

rotateTrsf :: V3 Double -> Double -> Acquire (Ptr GP.Trsf)
rotateTrsf :: V3 Double -> Double -> Acquire (Ptr Trsf)
rotateTrsf (V3 Double
ax Double
ay Double
az) Double
angle = do
    Ptr Trsf
trsf <- Acquire (Ptr Trsf)
GP.Trsf.new
    Ptr Pnt
o <- Acquire (Ptr Pnt)
GP.origin
    Ptr Dir
dir <- Double -> Double -> Double -> Acquire (Ptr Dir)
GP.Dir.new Double
ax Double
ay Double
az
    Ptr Ax1
axis <- Ptr Pnt -> Ptr Dir -> Acquire (Ptr Ax1)
GP.Ax1.new Ptr Pnt
o Ptr Dir
dir
    IO () -> Acquire ()
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Acquire ()) -> IO () -> Acquire ()
forall a b. (a -> b) -> a -> b
$ Ptr Trsf -> Ptr Ax1 -> Double -> IO ()
GP.Trsf.setRotationAboutAxisAngle Ptr Trsf
trsf Ptr Ax1
axis Double
angle
    Ptr Trsf -> Acquire (Ptr Trsf)
forall a. a -> Acquire a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr Trsf
trsf

translateTrsf :: V3 Double -> Acquire (Ptr GP.Trsf)
translateTrsf :: V3 Double -> Acquire (Ptr Trsf)
translateTrsf (V3 Double
x Double
y Double
z) = do
    Ptr Trsf
trsf <- Acquire (Ptr Trsf)
GP.Trsf.new
    Ptr Vec
vec <- Double -> Double -> Double -> Acquire (Ptr Vec)
GP.Vec.new Double
x Double
y Double
z
    IO () -> Acquire ()
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Acquire ()) -> IO () -> Acquire ()
forall a b. (a -> b) -> a -> b
$ Ptr Trsf -> Ptr Vec -> IO ()
GP.Trsf.setTranslation Ptr Trsf
trsf Ptr Vec
vec
    Ptr Trsf -> Acquire (Ptr Trsf)
forall a. a -> Acquire a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr Trsf
trsf

mirrorTrsf :: V3 Double -> Acquire (Ptr GP.Trsf)
mirrorTrsf :: V3 Double -> Acquire (Ptr Trsf)
mirrorTrsf (V3 Double
x Double
y Double
z) = do
    Ptr Trsf
trsf <- Acquire (Ptr Trsf)
GP.Trsf.new
    Ptr Dir
dir <- Double -> Double -> Double -> Acquire (Ptr Dir)
GP.Dir.new Double
x Double
y Double
z
    Ptr Ax2
axis <- Acquire (Ptr Ax2)
GP.xoy
    IO () -> Acquire ()
forall a. IO a -> Acquire a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Acquire ()) -> IO () -> Acquire ()
forall a b. (a -> b) -> a -> b
$ do 
        Ptr Ax2 -> Ptr Dir -> IO ()
GP.Ax2.setDirection Ptr Ax2
axis Ptr Dir
dir
        Ptr Trsf -> Ptr Ax2 -> IO ()
GP.Trsf.setMirrorAboutAx2 Ptr Trsf
trsf Ptr Ax2
axis
    Ptr Trsf -> Acquire (Ptr Trsf)
forall a. a -> Acquire a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr Trsf
trsf
    
instance Transformable Solid where
    scale :: V3 Double -> Solid -> Solid
    scale :: V3 Double -> Solid -> Solid
scale = Acquire (Ptr GTrsf) -> Solid -> Solid
fromGTrsfSolid (Acquire (Ptr GTrsf) -> Solid -> Solid)
-> (V3 Double -> Acquire (Ptr GTrsf))
-> V3 Double
-> Solid
-> Solid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V3 Double -> Acquire (Ptr GTrsf)
scaleTrsf

    uScale :: Double -> Solid -> Solid
    uScale :: Double -> Solid -> Solid
uScale = Acquire (Ptr Trsf) -> Solid -> Solid
fromTrsfSolid (Acquire (Ptr Trsf) -> Solid -> Solid)
-> (Double -> Acquire (Ptr Trsf)) -> Double -> Solid -> Solid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Acquire (Ptr Trsf)
uScaleTrsf

    rotate :: V3 Double -> Double -> Solid -> Solid
    rotate :: V3 Double -> Double -> Solid -> Solid
rotate V3 Double
axis Double
angle = Acquire (Ptr Trsf) -> Solid -> Solid
fromTrsfSolid (V3 Double -> Double -> Acquire (Ptr Trsf)
rotateTrsf V3 Double
axis Double
angle)

    translate :: V3 Double -> Solid -> Solid
    translate :: V3 Double -> Solid -> Solid
translate = Acquire (Ptr Trsf) -> Solid -> Solid
fromTrsfSolid (Acquire (Ptr Trsf) -> Solid -> Solid)
-> (V3 Double -> Acquire (Ptr Trsf)) -> V3 Double -> Solid -> Solid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V3 Double -> Acquire (Ptr Trsf)
translateTrsf

    mirror :: V3 Double -> Solid -> Solid
    mirror :: V3 Double -> Solid -> Solid
mirror = Acquire (Ptr Trsf) -> Solid -> Solid
fromTrsfSolid (Acquire (Ptr Trsf) -> Solid -> Solid)
-> (V3 Double -> Acquire (Ptr Trsf)) -> V3 Double -> Solid -> Solid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V3 Double -> Acquire (Ptr Trsf)
mirrorTrsf

instance Transformable Path where
    scale :: V3 Double -> Path -> Path
    scale :: V3 Double -> Path -> Path
scale = Acquire (Ptr GTrsf) -> Path -> Path
fromGTrsfPath (Acquire (Ptr GTrsf) -> Path -> Path)
-> (V3 Double -> Acquire (Ptr GTrsf)) -> V3 Double -> Path -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V3 Double -> Acquire (Ptr GTrsf)
scaleTrsf

    uScale :: Double -> Path -> Path
    uScale :: Double -> Path -> Path
uScale = Acquire (Ptr Trsf) -> Path -> Path
fromTrsfPath (Acquire (Ptr Trsf) -> Path -> Path)
-> (Double -> Acquire (Ptr Trsf)) -> Double -> Path -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Acquire (Ptr Trsf)
uScaleTrsf

    rotate :: V3 Double -> Double -> Path -> Path
    rotate :: V3 Double -> Double -> Path -> Path
rotate V3 Double
axis Double
angle = Acquire (Ptr Trsf) -> Path -> Path
fromTrsfPath (V3 Double -> Double -> Acquire (Ptr Trsf)
rotateTrsf V3 Double
axis Double
angle)

    translate :: V3 Double -> Path -> Path
    translate :: V3 Double -> Path -> Path
translate = Acquire (Ptr Trsf) -> Path -> Path
fromTrsfPath (Acquire (Ptr Trsf) -> Path -> Path)
-> (V3 Double -> Acquire (Ptr Trsf)) -> V3 Double -> Path -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V3 Double -> Acquire (Ptr Trsf)
translateTrsf
    
    mirror :: V3 Double -> Path -> Path
    mirror :: V3 Double -> Path -> Path
mirror = Acquire (Ptr Trsf) -> Path -> Path
fromTrsfPath (Acquire (Ptr Trsf) -> Path -> Path)
-> (V3 Double -> Acquire (Ptr Trsf)) -> V3 Double -> Path -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V3 Double -> Acquire (Ptr Trsf)
mirrorTrsf

        
instance Transformable (V3 Double) where
    scale :: V3 Double -> V3 Double  -> V3 Double
    scale :: V3 Double -> V3 Double -> V3 Double
scale = V3 Double -> V3 Double -> V3 Double
forall a. Num a => a -> a -> a
(*)

    -- Uniform Scale
    uScale :: Double -> V3 Double -> V3 Double
    uScale :: Double -> V3 Double -> V3 Double
uScale = Double -> V3 Double -> V3 Double
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
(*^)

    rotate :: V3 Double -> Double -> V3 Double -> V3 Double 
    rotate :: V3 Double -> Double -> V3 Double -> V3 Double
rotate V3 Double
axis Double
angle = Quaternion Double -> V3 Double -> V3 Double
forall a.
(Conjugate a, RealFloat a) =>
Quaternion a -> V3 a -> V3 a
Quaternion.rotate (V3 Double -> Double -> Quaternion Double
forall a. (Epsilon a, Floating a) => V3 a -> a -> Quaternion a
Quaternion.axisAngle V3 Double
axis Double
angle)

    translate :: V3 Double -> V3 Double -> V3 Double 
    translate :: V3 Double -> V3 Double -> V3 Double
translate = V3 Double -> V3 Double -> V3 Double
forall a. Num a => a -> a -> a
(+)

    mirror :: V3 Double -> V3 Double -> V3 Double 
    mirror :: V3 Double -> V3 Double -> V3 Double
mirror V3 Double
mirrorVec V3 Double
toMirror = 
        let nm :: V3 Double
nm = V3 Double -> V3 Double
forall a (f :: * -> *).
(Floating a, Metric f, Epsilon a) =>
f a -> f a
normalize V3 Double
mirrorVec
        in V3 Double
toMirror V3 Double -> V3 Double -> V3 Double
forall a. Num a => a -> a -> a
- (Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* (V3 Double
nm V3 Double -> V3 Double -> Double
forall a. Num a => V3 a -> V3 a -> a
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` V3 Double
toMirror) Double -> V3 Double -> V3 Double
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ V3 Double
nm)