Transform.hs

{-# LANGUAGE ImportQualifiedPost #-}

module Support.Reference.Transform
  ( (!.)
  , translate
  , translateV
  , scale3
  , scaleV
  , rotateX
  , rotateY
  , rotateZ
  , rotateQ
  , dirPos
  , node
  ) where

import Linear (M44, Quaternion(..), V3(..), V4(..))

import Support.Ball (Ball, isExactly)
import Support.Reference.Mat4 (colMajor)
import Support.Reference.Mat4 qualified as Mat4

(!.) :: RealFloat p => M44 (Ball p) -> V3 (Ball p) -> V3 (Ball p)
(!.) mat (V3 vx vy vz) = V3 (x / w) (y / w) (z / w)
  where
    V4 x y z w = Mat4.apply mat (V4 vx vy vz 1)

infixr 5 !.

translate :: Num a => a -> a -> a -> M44 a
translate x y z = colMajor
  1 0 0 x
  0 1 0 y
  0 0 1 z
  0 0 0 1

translateV :: Num a => V3 a -> M44 a
translateV (V3 x y z) = translate x y z

scale3 :: Num a => a -> a -> a -> M44 a
scale3 x y z = colMajor
  x 0 0 0
  0 y 0 0
  0 0 z 0
  0 0 0 1

scaleV :: Num a => V3 a -> M44 a
scaleV (V3 x y z) = scale3 x y z

rotateX :: Floating a => a -> M44 a
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

rotateY :: Floating a => a -> M44 a
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

rotateZ :: Floating a => a -> M44 a
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

rotateQ :: Num a => Quaternion a -> M44 a
rotateQ dir = dirPos dir 0

dirPos :: Num a => Quaternion a -> V3 a -> M44 a
dirPos (Quaternion w (V3 x y z)) (V3 tx ty tz) =
  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
  where
    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

node :: RealFloat p => V3 (Ball p) -> Quaternion (Ball p) -> V3 (Ball p) -> M44 (Ball p)
node t r s
  | all (isExactly 1) s = dirPos r t
  | otherwise = dirPos r t `Mat4.compose` scaleV s