Fixtures.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ImportQualifiedPost #-}

module Support.Fixtures
  ( xPos
  , xNeg
  , yPos
  , yNeg
  , zPos
  , zNeg
  , intrinsicComposed
  , intrinsicComposedD
  , trs
  , toNDC
  , intrinsicComposedRef
  , trsRef
  , quarterTurn
  , twelfthTurn
  , fourteenthTurn
  , rotationsMatch
  ) where

import Geomancy
import Hedgehog

import Data.Foldable (for_)
import Linear (M44, V3(..))
import Linear qualified
import Linear.Epsilon (Epsilon)

import Geomancy.DQuaternion qualified
import Geomancy.Quaternion qualified
import Geomancy.Transform qualified as Transform

import Support.Ball (Ball, balls, enclosed)
import Support.Reference.Mat4 qualified as Ref.Mat4
import Support.Reference.Quaternion qualified as Ref.Quaternion
import Support.Reference.Transform qualified as Ref.Transform

xPos :: Vec3
xPos = vec3 1 0 0

xNeg :: Vec3
xNeg = vec3 (-1) 0 0

yPos :: Vec3
yPos = vec3 0 1 0

yNeg :: Vec3
yNeg = vec3 0 (-1) 0

zPos :: Vec3
zPos = vec3 0 0 1

zNeg :: Vec3
zNeg = vec3 0 0 (-1)

intrinsicComposed :: Float -> Float -> Float -> Quaternion
intrinsicComposed roll pitch yaw =
  Geomancy.Quaternion.axisAngle (vec3 0 1 0) yaw *
  Geomancy.Quaternion.axisAngle (vec3 1 0 0) pitch *
  Geomancy.Quaternion.axisAngle (vec3 0 0 1) roll

intrinsicComposedD :: Double -> Double -> Double -> DQuaternion
intrinsicComposedD roll pitch yaw =
  Geomancy.DQuaternion.axisAngle (dvec3 0 1 0) yaw *
  Geomancy.DQuaternion.axisAngle (dvec3 1 0 0) pitch *
  Geomancy.DQuaternion.axisAngle (dvec3 0 0 1) roll

trs :: Vec3 -> Quaternion -> Vec3 -> Transform
trs t r s = mconcat
  [ Transform.translateV t
  , Transform.rotateQ r
  , Transform.scaleV s
  ]

toNDC :: Vec4 -> Vec3
toNDC v = withVec4 v \x y z w -> vec3 (x/w) (y/w) (z/w)

intrinsicComposedRef :: (Floating a, Epsilon a) => a -> a -> a -> Linear.Quaternion a
intrinsicComposedRef roll pitch yaw =
  Ref.Quaternion.axisAngle (V3 0 1 0) yaw `Ref.Quaternion.multiply`
  Ref.Quaternion.axisAngle (V3 1 0 0) pitch `Ref.Quaternion.multiply`
  Ref.Quaternion.axisAngle (V3 0 0 1) roll

trsRef :: RealFloat p => V3 (Ball p) -> Linear.Quaternion (Ball p) -> V3 (Ball p) -> M44 (Ball p)
trsRef t r s = foldr Ref.Mat4.compose Ref.Mat4.identity
  [ Ref.Transform.translateV t
  , Ref.Transform.rotateQ r
  , Ref.Transform.scaleV s
  ]

quarterTurn :: Floating a => a
quarterTurn = pi / 2

twelfthTurn :: Floating a => a
twelfthTurn = pi / 6

fourteenthTurn :: Floating a => a
fourteenthTurn = pi / 7

rotationsMatch
  :: (Show v, Show p, RealFloat p)
  => (v -> V3 p)
  -> (v -> v)
  -> (V3 (Ball p) -> V3 (Ball p))
  -> [(v, v)]
  -> PropertyT IO ()
rotationsMatch toV rotate rotateBall cases =
  for_ cases \(input, expected) -> do
    let
      rotated = rotate input
      rotatedBall = rotateBall (balls (toV input))
    annotateShow rotated
    replicate 3 Nothing === enclosed rotatedBall (toV rotated)
    replicate 3 Nothing === enclosed rotatedBall (toV expected)