Vulkan.hs

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

module Spec.Vulkan (tests) where

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

import Linear (M44, V3(..), V4(..))

import Geomancy.DMat4 qualified
import Geomancy.DTransform qualified as DTransform
import Geomancy.Mat4 qualified
import Geomancy.Mat4 ((!*))
import Geomancy.Transform qualified as Transform
import Geomancy.Vulkan.DProjection qualified as DProjection
import Geomancy.Vulkan.DView qualified as DView
import Geomancy.Vulkan.Projection qualified as Projection
import Geomancy.Vulkan.View qualified as View

import Support.Ball (Ball, enclosed, exactly)
import Support.Fixtures (quarterTurn, toNDC)
import Support.Gen (genDVec3, genVec3)
import Support.Linear (entries, toM44, toM44D)
import Support.Reference.Mat4 qualified as Ref.Mat4
import Support.Reference.Vulkan qualified as Ref.Vulkan

tests :: TestTree
tests = testGroup "Vulkan"
  [ testGroup "Projection"
      [ testPropertyNamed "reverseDepthRH" "prop_projection_reverseDepthRH" prop_projection_reverseDepthRH
      , testPropertyNamed "orthoRH_identity" "prop_projection_orthoRH_identity" prop_projection_orthoRH_identity
      , testPropertyNamed "reverseDepthOrthoRH" "prop_projection_reverseDepthOrthoRH" prop_projection_reverseDepthOrthoRH
      ]
  , testGroup "View"
      [ testPropertyNamed "lookAtRH_identity" "prop_view_lookAtRH_identity" prop_view_lookAtRH_identity
      ]
  , testGroup "DProjection"
      [ testPropertyNamed "dprojection" "prop_dprojection" prop_dprojection
      ]
  , testGroup "DView"
      [ testPropertyNamed "lookAtRH_identity" "prop_dview_lookAtRH_identity" prop_dview_lookAtRH_identity
      ]
  ]

prop_projection_reverseDepthRH :: Property
prop_projection_reverseDepthRH = withTests 1 $ property do
  let
    zNear = 0.1
    Transform p = Projection.reverseDepthRH quarterTurn zNear 800 600
    pBall = Ref.Vulkan.reverseDepthRH quarterTurn (exactly zNear) 800 600
  annotateShow p
  let
    -- stating the expected in transposed order for testing
    Transform expected = Geomancy.Mat4.rowMajor
      0.7500 0.0000 0.0000 0.0000
      0.0000 1.0000 0.0000 0.0000
      0.0000 0.0000 0.0000 1.0000
      0.0000 0.0000  zNear 0.0000
  annotateShow expected
  replicate 16 Nothing === enclosed (entries pBall) (entries (toM44 p))
  replicate 16 Nothing === enclosed (entries pBall) (entries (toM44 expected))

  let
    centerNearIn = vec4 0 0 zNear 1
    centerNearOut = p !* centerNearIn
    centerNearNDC = toNDC centerNearOut
  annotateShow (centerNearIn, centerNearOut)
  vec3 0 0 1 === centerNearNDC

prop_projection_orthoRH_identity :: Property
prop_projection_orthoRH_identity = withTests 1 $ property do
  let Transform pNative = Projection.orthoRH 0 1 2 2
  annotateShow pNative
  let pBall = Ref.Vulkan.orthoRH 0 1 2 2 :: M44 (Ball Float)
  replicate 16 Nothing === enclosed (entries pBall) (entries (toM44 pNative))
  replicate 16 Nothing === enclosed (entries pBall) (entries (toM44 mempty))

prop_projection_reverseDepthOrthoRH :: Property
prop_projection_reverseDepthOrthoRH = withTests 1 $ property do
  let t = Projection.reverseDepthOrthoRH 1 10 800 600
  annotateShow t

  vec4 0 0 1 1 === t !* vec4 0 0 1 1 -- center/near
  vec4 0 0 0 1 === t !* vec4 0 0 10 1 -- center/far
  vec4 1 1 0 1 === t !* vec4 400 300 10 1 -- edge/far
  vec4 (-1/400) (-1/300) 1 1 === t !* vec4 (-1) (-1) 1 1 -- step/near
  vec4 (1/400) (1/300) 0 1 === t !* vec4 1 1 10 1 -- step/far

prop_view_lookAtRH_identity :: Property
prop_view_lookAtRH_identity = property do
  let alreadyThere = View.lookAtRH_ (vec3 0 0 0) (vec3 0 0 1)
  annotateShow alreadyThere

  p <- forAll genVec3

  p === Transform.apply p alreadyThere

prop_dprojection :: Property
prop_dprojection = withTests 1 $ property do
  let
    zNear = 0.1
    DTransform p = DProjection.reverseDepthRH quarterTurn zNear 800 600
    centerNear = p Geomancy.DMat4.!* dvec4 0 0 zNear 1
    pBall = Ref.Vulkan.reverseDepthRH quarterTurn (exactly zNear) 800 600
    V4 xBall yBall zBall wBall = Ref.Mat4.apply pBall (V4 0 0 (exactly zNear) 1)
    centerNearNDCBall = V3 (xBall / wBall) (yBall / wBall) (zBall / wBall)
  withDVec4 centerNear \x y z w -> do
    replicate 3 Nothing === enclosed centerNearNDCBall (V3 (x/w) (y/w) (z/w))
    replicate 3 Nothing === enclosed centerNearNDCBall (V3 0 0 1 :: V3 Double)

  let
    DTransform o = DProjection.orthoRH 0 1 2 2
    oBall = Ref.Vulkan.orthoRH 0 1 2 2 :: M44 (Ball Double)
  replicate 16 Nothing === enclosed (entries oBall) (entries (toM44D o))
  replicate 16 Nothing === enclosed (entries oBall) (entries (toM44D mempty))

  let t = DProjection.reverseDepthOrthoRH 1 10 800 600
  dvec4 0 0 1 1 === t Geomancy.DMat4.!* dvec4 0 0 1 1
  dvec4 0 0 0 1 === t Geomancy.DMat4.!* dvec4 0 0 10 1
  dvec4 1 1 0 1 === t Geomancy.DMat4.!* dvec4 400 300 10 1

prop_dview_lookAtRH_identity :: Property
prop_dview_lookAtRH_identity = property do
  let alreadyThere = DView.lookAtRH_ (dvec3 0 0 0) (dvec3 0 0 1)
  p <- forAll genDVec3
  p === DTransform.apply p alreadyThere