Mat4.hs

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

module Spec.Mat4 (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 Geomancy.Mat4 qualified
import Linear ((!*!))

import Support.Ball (balls44, consistent, enclosed)
import Support.Gen (forAllTransform, genEdgeScalar, genMostlySame)
import Support.Linear (entries, toM44)
import Support.Property (pattern PROP_TESTS)
import Support.Reference.Mat4 qualified as Ref.Mat4

tests :: TestTree
tests = testGroup "Mat4"
  [ testPropertyNamed "assoc" "prop_mat4_assoc" prop_mat4_assoc
  , testPropertyNamed "order" "prop_mat4_order" prop_mat4_order
  , testPropertyNamed "eq" "prop_mat4_eq" prop_mat4_eq
  ]

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

  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 (toM44 pv'm))
  replicate 16 Nothing === enclosed (entries p'vmBall) (entries (toM44 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_mat4_order :: Property
prop_mat4_order = withTests 1 $ property do
  let
    cm = Geomancy.Mat4.colMajor @Geomancy.Mat4.Mat4
      0 1 2 3
      4 5 6 7
      8 9 0 1
      2 3 4 5
    rm = Geomancy.Mat4.rowMajor @Geomancy.Mat4.Mat4
      0 4 8 2
      1 5 9 3
      2 6 0 4
      3 7 1 5
  Geomancy.Mat4.toListColMajor2d cm === Geomancy.Mat4.toListColMajor2d rm

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

prop_mat4_eq :: Property
prop_mat4_eq = withTests PROP_TESTS $ property do
  let
    four = Gen.list (Range.singleton 4)
    fromRows = evalMaybe . Geomancy.Mat4.fromRowMajor2d @[] @Geomancy.Mat4.Mat4
  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)