geomancy-0.4.0.0: src/Geomancy/DTransform.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE TypeFamilies #-}

#ifdef TH_LIFT
{-# LANGUAGE DeriveLift #-}
#endif

module Geomancy.DTransform
  ( DTransform(..)
  , DMat4.inverse

  , apply
  , (!.)

  , translate
  , translateV

  , rotateX
  , rotateY
  , rotateZ
  , rotateQ

  , scale
  , scaleX
  , scaleY
  , scaleZ
  , scaleXY
  , scale3
  , scaleV

  , dirPos
  , node

  , fromTransform
  , toTransform
  ) where

import Foreign (Storable(..))
import Foreign.Ptr.Diff (peekDiffOff, pokeDiffOff)

#ifdef TH_LIFT
import Language.Haskell.TH.Syntax (Lift)
#endif

#ifdef SERIALISE
import Codec.Serialise (Serialise)
#endif

import Geomancy.DMat4 (DMat4, colMajor)
import Geomancy.DQuaternion (DQuaternion, withDQuaternion)
import Geomancy.DVec3 (DVec3, dvec3, withDVec3)
import Geomancy.DVec4 (fromDVec3, withDVec4)
import Geomancy.DMat4 qualified as DMat4
import Geomancy.Transform (Transform(..))

import Graphics.Gl.Block (Block(..))

newtype DTransform = DTransform { unDTransform :: DMat4 }
  deriving newtype (Eq, Show, Semigroup, Monoid, Storable)
#ifdef TH_LIFT
  deriving Lift
#endif
#ifdef SERIALISE
  deriving Serialise
#endif

instance Block DTransform where
  type PackedSize DTransform = 128
  alignment140 _  = 32
  sizeOf140       = sizeOfPacked
  alignment430    = alignment140
  sizeOf430       = sizeOf140
  isStruct _      = False
  read140     = peekDiffOff
  write140    = pokeDiffOff
  read430     = read140
  write430    = write140
  readPacked  = read140
  writePacked = write140
  {-# INLINE alignment140 #-}
  {-# INLINE sizeOf140 #-}
  {-# INLINE alignment430 #-}
  {-# INLINE sizeOf430 #-}
  {-# INLINE isStruct #-}
  {-# INLINE read140 #-}
  {-# INLINE write140 #-}
  {-# INLINE read430 #-}
  {-# INLINE write430 #-}
  {-# INLINE readPacked #-}
  {-# INLINE writePacked #-}

{-# INLINE fromTransform #-}
fromTransform :: Transform -> DTransform
fromTransform = DTransform . DMat4.fromMat4

{-# INLINE toTransform #-}
toTransform :: DTransform -> Transform
toTransform = Transform . DMat4.toMat4 . unDTransform

apply :: DVec3 -> DTransform -> DVec3
apply = flip (!.)

(!.) :: DTransform -> DVec3 -> DVec3
(!.) mat vec =
  withDVec4 res \x y z w ->
    dvec3 (x / w) (y / w) (z / w)
  where
    res = mat DMat4.!* fromDVec3 vec 1.0

infixr 5 !.

{-# INLINE translate #-}
translate :: Double -> Double -> Double -> DTransform
translate x y z = colMajor
  1 0 0 x
  0 1 0 y
  0 0 1 z
  0 0 0 1

{-# INLINE translateV #-}
translateV :: DVec3 -> DTransform
translateV vec = withDVec3 vec translate

{-# INLINE scale3 #-}
scale3 :: Double -> Double -> Double -> DTransform
scale3 x y z = colMajor
  x 0 0 0
  0 y 0 0
  0 0 z 0
  0 0 0 1

{-# INLINE scale #-}
scale :: Double -> DTransform
scale s = scale3 s s s

{-# INLINE scaleX #-}
scaleX :: Double -> DTransform
scaleX x = scale3 x 1 1

{-# INLINE scaleY #-}
scaleY :: Double -> DTransform
scaleY y = scale3 1 y 1

{-# INLINE scaleZ #-}
scaleZ :: Double -> DTransform
scaleZ z = scale3 1 1 z

{-# INLINE scaleXY #-}
scaleXY :: Double -> Double -> DTransform
scaleXY x y = scale3 x y 1

{-# INLINE scaleV #-}
scaleV :: DVec3 -> DTransform
scaleV s = withDVec3 s scale3

{-# INLINE rotateX #-}
rotateX :: Double -> DTransform
rotateX rads =
  colMajor
    1 0   0  0
    0 c (-s) 0
    0 s   c  0
    0 0   0  1
  where
    c = cos rads
    s = sin rads

{-# INLINE rotateY #-}
rotateY :: Double -> DTransform
rotateY rads =
  colMajor
    c  0 s 0
    0  1 0 0
  (-s) 0 c 0
    0  0 0 1
  where
    c = cos rads
    s = sin rads

{-# INLINE rotateZ #-}
rotateZ :: Double -> DTransform
rotateZ rads =
  colMajor
    c (-s) 0 0
    s   c  0 0
    0   0  1 0
    0   0  0 1
  where
   c = cos rads
   s = sin rads

{-# INLINE rotateQ #-}
rotateQ :: DQuaternion -> DTransform
rotateQ dir = dirPos dir 0

{-# INLINE dirPos #-}
dirPos :: DQuaternion -> DVec3 -> DTransform
dirPos rs t =
  withDQuaternion rs \w x y z ->
  withDVec3 t \tx ty tz ->
    let
      x2 = x * x
      y2 = y * y
      z2 = z * z
      xy = x * y
      xz = x * z
      xw = x * w
      yz = y * z
      yw = y * w
      zw = z * w
    in
      colMajor
        (1 - 2 * (y2 + z2)) (    2 * (xy - zw)) (    2 * (xz + yw)) tx
        (    2 * (xy + zw)) (1 - 2 * (x2 + z2)) (    2 * (yz - xw)) ty
        (    2 * (xz - yw)) (    2 * (yz + xw)) (1 - 2 * (x2 + y2)) tz
        0                   0                   0                    1

node :: DVec3 -> DQuaternion -> DVec3 -> DTransform
node t r s
 | s == 1.0 = dirPos r t
 | otherwise = dirPos r t <> scaleV s