Vec4.hs

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

module Spec.Vec4 (tests) where

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

import Geomancy.DVec4 qualified
import Geomancy.Vec4 qualified

import Support.Gen (genEdgeScalar, genMostlySame)
import Support.Property (pattern PROP_TESTS)

tests :: TestTree
tests = testGroup "Vec4"
  [ testPropertyNamed "eq_ord" "prop_vec4_eq_ord" prop_vec4_eq_ord
  , testPropertyNamed "dvec4_eq_ord" "prop_dvec4_eq_ord" prop_dvec4_eq_ord
  ]

prop_vec4_eq_ord :: Property
prop_vec4_eq_ord = withTests PROP_TESTS $ property do
  (xsA, xsB) <- forAll nearbyTuples
  matchesTuple (Geomancy.Vec4.fromTuple xsA, xsA) (Geomancy.Vec4.fromTuple xsB, xsB)

prop_dvec4_eq_ord :: Property
prop_dvec4_eq_ord = withTests PROP_TESTS $ property do
  (xsA, xsB) <- forAll nearbyTuples
  matchesTuple (Geomancy.DVec4.fromTuple xsA, xsA) (Geomancy.DVec4.fromTuple xsB, xsB)

type Tuple4 a = (a, a, a, a)

nearbyTuples :: Fractional a => Gen (Tuple4 a, Tuple4 a)
nearbyTuples = do
  a <- (,,,) <$> genEdgeScalar <*> genEdgeScalar <*> genEdgeScalar <*> genEdgeScalar
  b <- traverse4 (genMostlySame 4) a
  pure (a, b)
  where
    traverse4 f (x, y, z, w) = (,,,) <$> f x <*> f y <*> f z <*> f w

matchesTuple
  :: (Ord v, Show v, Ord a)
  => (v, Tuple4 a)
  -> (v, Tuple4 a)
  -> PropertyT IO ()
matchesTuple (a, xsA) (b, xsB) = do
  label $ if xsA == xsB then "equal" else "different"
  (a == b) === (xsA == xsB)
  (a /= b) === (xsA /= xsB)
  compare a b === compare xsA xsB
  (a < b) === (xsA < xsB)
  (a <= b) === (xsA <= xsB)
  (a > b) === (xsA > xsB)
  (a >= b) === (xsA >= xsB)