DMat4.hs

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

module Spec.DMat4 (tests) where

import Hedgehog
import Hedgehog.Gen qualified as Gen
import Hedgehog.Range qualified as Range
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.Hedgehog (testPropertyNamed)

import Linear qualified
import Linear ((!*!))

import Geomancy.DMat4 qualified
import Geomancy.DVec4 qualified
import Geomancy.Mat4 ((!*))
import Geomancy.Transform qualified as Transform

import Support.Ball (balls, balls44, consistent, enclosed, narrow, widen)
import Support.Gen (forAllDTransform, forAllTransform, genDVec4, genEdgeScalar, genMostlySame, genVec4)
import Support.Linear (entries, toM44, toM44D, toV4, toV4D)
import Support.Property (pattern PROP_TESTS)
import Support.Reference.Mat4 qualified as Ref.Mat4

tests :: TestTree
tests = testGroup "DMat4"
  [ testPropertyNamed "assoc" "prop_dmat4_assoc" prop_dmat4_assoc
  , testPropertyNamed "order" "prop_dmat4_order" prop_dmat4_order
  , testPropertyNamed "eq" "prop_dmat4_eq" prop_dmat4_eq
  , testPropertyNamed "det" "prop_dmat4_det" prop_dmat4_det
  , testPropertyNamed "inverse" "prop_dmat4_inverse" prop_dmat4_inverse
  , testPropertyNamed "apply" "prop_dmat4_apply" prop_dmat4_apply
  , testPropertyNamed "float_parity" "prop_dmat4_float_parity" prop_dmat4_float_parity
  ]

prop_dmat4_assoc :: Property
prop_dmat4_assoc = withDiscards 1000 . withTests PROP_TESTS $ property do
  (p, p_) <- forAllDTransform
  (v, v_) <- forAllDTransform
  (m, m_) <- forAllDTransform

  let
    pv'm = (p <> v) <> m
    p'vm = p <> (v <> m)
    pv'mBall = Ref.Mat4.compose (Ref.Mat4.compose (balls44 p_) (balls44 v_)) (balls44 m_)
    p'vmBall = Ref.Mat4.compose (balls44 p_) (Ref.Mat4.compose (balls44 v_) (balls44 m_))
  replicate 16 Nothing === enclosed (entries pv'mBall) (entries (toM44D pv'm))
  replicate 16 Nothing === enclosed (entries p'vmBall) (entries (toM44D p'vm))

  let
    mv_p = (m_ !*! v_) !*! p_
    m_vp = m_ !*! (v_ !*! p_)
    mv_pBall = (balls44 m_ !*! balls44 v_) !*! balls44 p_
    m_vpBall = balls44 m_ !*! (balls44 v_ !*! balls44 p_)
  replicate 16 Nothing === enclosed (entries mv_pBall) (entries mv_p)
  replicate 16 Nothing === enclosed (entries m_vpBall) (entries m_vp)

  replicate 16 Nothing === consistent (entries pv'mBall) (entries p'vmBall)
  replicate 16 Nothing === consistent (entries mv_pBall) (entries m_vpBall)
  replicate 16 Nothing === consistent (entries pv'mBall) (entries mv_pBall)

prop_dmat4_order :: Property
prop_dmat4_order = withTests 1 $ property do
  let
    cm = Geomancy.DMat4.colMajor @Geomancy.DMat4.DMat4
      0 1 2 3
      4 5 6 7
      8 9 0 1
      2 3 4 5
    rm = Geomancy.DMat4.rowMajor @Geomancy.DMat4.DMat4
      0 4 8 2
      1 5 9 3
      2 6 0 4
      3 7 1 5
  Geomancy.DMat4.toListColMajor2d cm === Geomancy.DMat4.toListColMajor2d rm

  let
    cmT = Geomancy.DMat4.transpose cm
    rmT = Geomancy.DMat4.transpose rm
  Geomancy.DMat4.toListColMajor2d cmT === Geomancy.DMat4.toListColMajor2d rmT

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

prop_dmat4_inverse :: Property
prop_dmat4_inverse = withDiscards 1000 . withTests PROP_TESTS $ property do
  (m, m_) <- forAllDTransform
  let
    mm' = m <> Geomancy.DMat4.inverse m
    mBall = balls44 m_
    mm'Ball = Ref.Mat4.compose mBall (Ref.Mat4.inverse mBall)
  annotateShow mm'
  replicate 16 Nothing === enclosed (entries mm'Ball) (entries (toM44D mm'))
  replicate 16 Nothing === enclosed (entries mm'Ball) (entries (Linear.identity :: Linear.M44 Double))

prop_dmat4_apply :: Property
prop_dmat4_apply = withDiscards 1000 . withTests PROP_TESTS $ property do
  (m, m_) <- forAllDTransform
  v <- forAll genDVec4
  let
    out = m Geomancy.DMat4.!* v
    out_ = toV4D v Linear.*! m_
    outBall = Ref.Mat4.apply (balls44 m_) (balls (toV4D v))
    out_Ball = balls (toV4D v) Linear.*! balls44 m_
  annotateShow out
  annotateShow out_
  replicate 4 Nothing === enclosed outBall (toV4D out)
  replicate 4 Nothing === enclosed out_Ball out_
  replicate 4 Nothing === consistent outBall out_Ball

prop_dmat4_float_parity :: Property
prop_dmat4_float_parity = withDiscards 1000 . withTests PROP_TESTS $ property do
  (a, a_) <- forAllTransform
  (b, b_) <- forAllTransform
  let
    viaDouble =
      Geomancy.DMat4.toMat4 $
        Geomancy.DMat4.fromMat4 a <> Geomancy.DMat4.fromMat4 b
    widened = fmap (fmap widen) . balls44
    viaDoubleBall = fmap (fmap narrow) $ Ref.Mat4.compose (widened a_) (widened b_)
    viaFloatBall = Ref.Mat4.compose (balls44 a_) (balls44 b_)
  replicate 16 Nothing === enclosed (entries viaDoubleBall) (entries (toM44 viaDouble))
  replicate 16 Nothing === enclosed (entries viaFloatBall) (entries (toM44 (a <> b)))
  replicate 16 Nothing === consistent (entries viaDoubleBall) (entries viaFloatBall)

  v <- forAll genVec4
  let
    viaDoubleV =
      Geomancy.DVec4.toVec4 $
        Geomancy.DMat4.fromMat4 a Geomancy.DMat4.!* Geomancy.DVec4.fromVec4 v
    viaDoubleVBall =
      fmap narrow $ Ref.Mat4.apply (widened a_) (fmap widen (balls (toV4 v)))
    viaFloatVBall = Ref.Mat4.apply (balls44 a_) (balls (toV4 v))
  replicate 4 Nothing === enclosed viaDoubleVBall (toV4 viaDoubleV)
  replicate 4 Nothing === enclosed viaFloatVBall (toV4 (a !* v))
  replicate 4 Nothing === consistent viaDoubleVBall viaFloatVBall

prop_dmat4_eq :: Property
prop_dmat4_eq = withTests PROP_TESTS $ property do
  let
    four = Gen.list (Range.singleton 4)
    fromRows = evalMaybe . Geomancy.DMat4.fromRowMajor2d @[] @Geomancy.DMat4.DMat4
  rowsA <- forAll $ four (four genEdgeScalar)
  rowsB <- forAll $ traverse (traverse (genMostlySame 8)) rowsA
  a <- fromRows rowsA
  b <- fromRows rowsB
  label $ if rowsA == rowsB then "equal" else "different"
  (a == b) === (rowsA == rowsB)
  (a /= b) === (rowsA /= rowsB)