DTransform.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}

module Spec.DTransform (tests) where

import Geomancy
import Hedgehog
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.Hedgehog (testPropertyNamed)

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

import Geomancy.DMat4 qualified
import Geomancy.DQuaternion qualified
import Geomancy.DTransform qualified as DTransform
import Geomancy.Mat4 qualified
import Geomancy.Transform ((!.))
import Geomancy.Transform qualified as Transform
import Geomancy.Vulkan.DView qualified as DView

import Support.Ball (Ball, balls, consistent, enclosed, exactly, narrow)
import Support.Fixtures
  (fourteenthTurn, intrinsicComposedD, intrinsicComposedRef, quarterTurn, rotationsMatch, trsRef, twelfthTurn)
import Support.Gen (genAngle, genTransform)
import Support.Linear (entries, toM44, toV3, toV3D)
import Support.Property (pattern PROP_TESTS)
import Support.Reference.Mat4 qualified as Ref.Mat4
import Support.Reference.Quaternion qualified as Ref.Quaternion
import Support.Reference.Transform qualified as Ref.Transform
import Support.Reference.Vulkan qualified as Ref.Vulkan

tests :: TestTree
tests = testGroup "DTransform"
  [ testPropertyNamed "det" "prop_dtransform_det" prop_dtransform_det
  , testPropertyNamed "rotate" "prop_dtransform_rotate" prop_dtransform_rotate
  , testPropertyNamed "node_order" "prop_dtransform_node_order" prop_dtransform_node_order
  , testPropertyNamed "float_parity" "prop_dtransform_float_parity" prop_dtransform_float_parity
  , testPropertyNamed "big_world" "prop_dtransform_big_world" prop_dtransform_big_world
  ]

prop_dtransform_det :: Property
prop_dtransform_det = withTests 1 $ property do
  1     === Geomancy.DMat4.det (DTransform.translate 1 2 3)
  0     === Geomancy.DMat4.det (DTransform.scaleX 0)
  -1    === Geomancy.DMat4.det (DTransform.scaleZ (-1))
  8     === Geomancy.DMat4.det (DTransform.scale 2)
  (1/8) === Geomancy.DMat4.det (DTransform.scale (1/2))

  let
    rotatedBall = Ref.Mat4.det (Ref.Transform.rotateY twelfthTurn) :: Ball Double
  [Nothing] === enclosed [rotatedBall] [Geomancy.DMat4.det (DTransform.rotateY twelfthTurn)]
  [Nothing] === enclosed [rotatedBall] [1 :: Double]

prop_dtransform_rotate :: Property
prop_dtransform_rotate = withTests 1 $ property do
  let
    axisQ axis = DTransform.rotateQ (Geomancy.DQuaternion.axisAngle axis quarterTurn)
    axisQBall axis = Ref.Transform.rotateQ (Ref.Quaternion.axisAngle axis quarterTurn)
    cases =
      [ (DTransform.rotateX quarterTurn, Ref.Transform.rotateX quarterTurn, dvec3 0 0 1, dvec3 0 (-1) 0)
      , (axisQ (dvec3 1 0 0), axisQBall (V3 1 0 0), dvec3 0 0 1, dvec3 0 (-1) 0)
      , (DTransform.rotateY quarterTurn, Ref.Transform.rotateY quarterTurn, dvec3 0 0 1, dvec3 1 0 0)
      , (axisQ (dvec3 0 1 0), axisQBall (V3 0 1 0), dvec3 0 0 1, dvec3 1 0 0)
      , (DTransform.rotateZ quarterTurn, Ref.Transform.rotateZ quarterTurn, dvec3 1 0 0, dvec3 0 1 0)
      , (axisQ (dvec3 0 0 1), axisQBall (V3 0 0 1), dvec3 1 0 0, dvec3 0 1 0)
      ]
  for_ cases \(t, tBall, input, expected) ->
    rotationsMatch toV3D (t DTransform.!.) (tBall Ref.Transform.!.) [(input, expected)]

prop_dtransform_node_order :: Property
prop_dtransform_node_order = withTests 1 $ property do
  let
    t = dvec3 2 3 5
    r = intrinsicComposedD 0 0 fourteenthTurn
    s = 11
    trsD = mconcat [DTransform.translateV t, DTransform.rotateQ r, DTransform.scaleV s]
    v = dvec3 0 0 1

    rBall = intrinsicComposedRef 0 0 fourteenthTurn
    nodeBall = Ref.Transform.node (V3 2 3 5) rBall 11 :: M44 (Ball Double)
    trsBall = trsRef (V3 2 3 5) rBall 11
    viaNodeBall = nodeBall Ref.Transform.!. V3 0 0 1
    viaTrsBall = trsBall Ref.Transform.!. V3 0 0 1
  replicate 3 Nothing === enclosed viaNodeBall (toV3D (DTransform.node t r s DTransform.!. v))
  replicate 3 Nothing === enclosed viaTrsBall (toV3D (trsD DTransform.!. v))
  replicate 3 Nothing === consistent viaNodeBall viaTrsBall

  let
    parent = DTransform.node (dvec3 4 5 6) (intrinsicComposedD 0 0 twelfthTurn) 2
    local = DTransform.node (dvec3 7 8 9) (intrinsicComposedD 0 twelfthTurn 0) (1/3)
    parentBall = Ref.Transform.node (V3 4 5 6) (intrinsicComposedRef 0 0 twelfthTurn) 2 :: M44 (Ball Double)
    localBall = Ref.Transform.node (V3 7 8 9) (intrinsicComposedRef 0 twelfthTurn 0) (1/3)
    precompBall = Ref.Mat4.compose parentBall localBall Ref.Transform.!. V3 0 0 1
    nocompBall = parentBall Ref.Transform.!. localBall Ref.Transform.!. V3 0 0 1
  replicate 3 Nothing === enclosed precompBall (toV3D (parent <> local DTransform.!. v))
  replicate 3 Nothing === enclosed nocompBall (toV3D (parent DTransform.!. local DTransform.!. v))
  replicate 3 Nothing === consistent precompBall nocompBall

prop_dtransform_float_parity :: Property
prop_dtransform_float_parity = withDiscards 1000 . withTests PROP_TESTS $ property do
  (_name, t) <- forAllWith fst genTransform
  Geomancy.Mat4.toListRowMajor t ===
    Geomancy.Mat4.toListRowMajor (DTransform.toTransform (DTransform.fromTransform t))

  angle <- forAll genAngle
  let
    a = realToFrac angle
    viaDouble = unTransform $ DTransform.toTransform (DTransform.rotateY a)
    viaFloat = unTransform $ Transform.rotateY angle
    viaDoubleBall = fmap (fmap narrow) $ Ref.Transform.rotateY (exactly a)
    viaFloatBall = Ref.Transform.rotateY (exactly angle)
  replicate 16 Nothing === enclosed (entries viaDoubleBall) (entries (toM44 viaDouble))
  replicate 16 Nothing === enclosed (entries viaFloatBall) (entries (toM44 viaFloat))
  replicate 16 Nothing === consistent (entries viaDoubleBall) (entries viaFloatBall)

prop_dtransform_big_world :: Property
prop_dtransform_big_world = withTests 1 $ property do
  let
    far = 1e9
    eye = dvec3 far 0 far
    view = DView.lookAtRH_ eye (eye + dvec3 0 0 1)
    model = DTransform.translate (far + 0.25) 0 (far + 5)
    composedInDouble = DTransform.toTransform (view <> model)
    composedInFloat = DTransform.toTransform view <> DTransform.toTransform model

    farBall = exactly far
    eyeBall = balls (toV3D eye)
    viewBall = Ref.Vulkan.lookAtRH_ eyeBall (eyeBall + V3 0 0 1)
    modelBall = Ref.Transform.translate (farBall + 0.25) 0 (farBall + 5)
    composedInDoubleBall = fmap (fmap narrow) $ Ref.Mat4.compose viewBall modelBall
    originBall = composedInDoubleBall Ref.Transform.!. V3 0 0 0
  replicate 3 Nothing === enclosed originBall (toV3 (composedInDouble !. vec3 0 0 0))
  replicate 3 Nothing === enclosed originBall (toV3 (vec3 0.25 0 5))
  withVec3 (composedInFloat !. vec3 0 0 0) \x _y _z ->
    diff x (/=) 0.25