AnitomataSpec.hs

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
module Test.AnitomataSpec
  ( spec
  ) where

import Anitomata
import Control.Exception (ErrorCall(..), evaluate, try)
import Data.Function ((&), on)
import Data.Functor ((<&>))
import Data.Kind (Type)
import Data.Maybe (isJust, isNothing)
import Data.Proxy (Proxy(Proxy))
import Data.Semigroup (Semigroup(sconcat))
import GHC.TypeLits (KnownNat, Nat, natVal)
import Prelude
import Test.Hspec (Spec, describe, parallel)
import Test.Hspec.QuickCheck (prop)
import Test.QuickCheck
  ( Arbitrary(arbitrary), NonNegative(getNonNegative), Positive(Positive, getPositive), (.&&.)
  , (===), (==>), Gen, chooseInt, frequency, ioProperty, listOf1, mapSize, oneof, vectorOf
  )

import Data.List qualified as L
import Data.List.NonEmpty qualified as NonEmpty
import Data.Vector qualified as V
import Data.Vector.Generic qualified as G

spec :: Spec
spec = parallel do
  describe "Foo.Data.Anim" do
    prop "Initial source rect is correct" \case
      FiniteTestAnim (TestAnim a) ->
        animFrame a === case animSlice a of
          AnimSlice { animSliceDir = dir, animSliceFrames = frames }
            | dir == AnimDirForward -> V.head frames
            | otherwise -> V.last frames

    prop "Finite animations can be stepped to completion" \case
      FiniteTestAnim (TestAnim a) ->
        -- Use the computed total duration as the delta time so that we can
        -- get through the animation quickly.
        iterateAnim dur a
          & fmap fromSteppedAnim
          & L.lookup AnimStatusFinished
          & isJust
        where
        Just AnimMeta { animMetaTotalDur = dur } = animMeta a

    prop "No frames are skipped if delta time is small enough" $ mapSize (`div` 2) \case
      FiniteTestAnimBuilder (TestAnimBuilder ab) ->
        expectedFrames `L.isSubsequenceOf` realFrames
          .&&. length expectedFrames === totalFrameCount
          .&&. iterDur - totalDur >= 0
          .&&. iterDur - totalDur < dt
        where
        expectedFrames = getExpectedFrames a0
        realFrames = getRealFrames $ iterateAnim dt a0
        iterDur = dt * fromIntegral (length realFrames)
        a0 = buildAnim AnimDurationDefault ab
        dt = minFrameDur / 2
        Just AnimMeta
          { animMetaTotalFrameCount = totalFrameCount
          , animMetaTotalDur = totalDur
          , animMetaMinFrameDur = minFrameDur
          } = animMeta a0

    prop "Some frames are skipped if delta time is large enough" \case
      FiniteTestAnimBuilder (TestAnimBuilder ab) ->
        length expectedFrames >= length realFrames
          .&&. iterDur - totalDur >= 0
          .&&. iterDur - totalDur < dt
        where
        expectedFrames = getExpectedFrames a0
        realFrames = getRealFrames $ iterateAnim dt a0
        iterDur = dt * fromIntegral (length realFrames)
        a0 = buildAnim AnimDurationDefault ab
        dt = maxFrameDur * 2
        Just AnimMeta
          { animMetaTotalDur = totalDur
          , animMetaMaxFrameDur = maxFrameDur
          } = animMeta a0

    prop "Duration of finite animations can be scaled" \case
      (FiniteTestAnimBuilder (TestAnimBuilder ab), Positive scaleFactor) ->
        scaleFactor * iterDurDefault === iterDurScaled
          .&&. scaleFactor * totalDurDefault === totalDurScaled
          .&&. scaleFactor * minFrameDurDefault === minFrameDurScaled
          .&&. scaleFactor * maxFrameDurDefault === maxFrameDurScaled
          .&&. totalFrameCountDefault === totalFrameCountScaled
        where
        stepCountScaled = length $ iterateAnim dtScaled aScaled
        iterDurScaled = dtScaled * fromIntegral stepCountScaled
        aScaled = buildAnim (AnimDurationScaled scaleFactor) ab
        dtScaled = maxFrameDurScaled
        Just AnimMeta
          { animMetaTotalFrameCount = totalFrameCountScaled
          , animMetaTotalDur = totalDurScaled
          , animMetaMinFrameDur = minFrameDurScaled
          , animMetaMaxFrameDur = maxFrameDurScaled
          } = animMeta aScaled

        stepCountDefault = length $ iterateAnim dtDefault aDefault
        iterDurDefault = dtDefault * fromIntegral stepCountDefault
        aDefault = buildAnim AnimDurationDefault ab
        dtDefault = maxFrameDurDefault
        Just AnimMeta
          { animMetaTotalFrameCount = totalFrameCountDefault
          , animMetaTotalDur = totalDurDefault
          , animMetaMinFrameDur = minFrameDurDefault
          , animMetaMaxFrameDur = maxFrameDurDefault
          } = animMeta aDefault

    prop "Total duration of finite animations can be set while respecting relative frame timings" \case
      (FiniteTestAnimBuilder (TestAnimBuilder ab), Positive newTotalDur) ->
        totalDur === newTotalDur
          .&&. iterDur - newTotalDur >= 0
          .&&. iterDur - newTotalDur < dt
          .&&. scaleFactor * minFrameDurDefault === minFrameDur
          .&&. scaleFactor * maxFrameDurDefault === maxFrameDur
          .&&. totalFrameCountDefault === totalFrameCount
        where
        stepCount = length $ iterateAnim dt a'
        iterDur = dt * fromIntegral stepCount
        a' = buildAnim (AnimDurationTotal newTotalDur) ab
        dt = maxFrameDur
        Just AnimMeta
          { animMetaTotalFrameCount = totalFrameCount
          , animMetaTotalDur = totalDur
          , animMetaMinFrameDur = minFrameDur
          , animMetaMaxFrameDur = maxFrameDur
          } = animMeta a'

        scaleFactor = newTotalDur / totalDurDefault

        a = buildAnim AnimDurationDefault ab
        Just AnimMeta
          { animMetaTotalFrameCount = totalFrameCountDefault
          , animMetaTotalDur = totalDurDefault
          , animMetaMinFrameDur = minFrameDurDefault
          , animMetaMaxFrameDur = maxFrameDurDefault
          } = animMeta a

    prop "Constant frame duration of finite animations can be set" \case
      (FiniteTestAnimBuilder (TestAnimBuilder ab), Positive frameDur) ->
        iterDur - frameDur * fromIntegral totalFrameCount >= 0
          .&&. iterDur - frameDur * fromIntegral totalFrameCount < dt
          .&&. minFrameDur === frameDur
          .&&. maxFrameDur === frameDur
          .&&. totalFrameCountDefault === totalFrameCount
        where
        stepCount = length $ iterateAnim dt a'
        iterDur = dt * fromIntegral stepCount
        a' = buildAnim (AnimDurationEachFrame frameDur) ab
        dt = maxFrameDur
        Just AnimMeta
          { animMetaTotalFrameCount = totalFrameCount
          , animMetaMinFrameDur = minFrameDur
          , animMetaMaxFrameDur = maxFrameDur
          } = animMeta a'

        a = buildAnim AnimDurationDefault ab
        Just AnimMeta
          { animMetaTotalFrameCount = totalFrameCountDefault
          } = animMeta a

    prop "Total duration of finite animations can be set via constant frame timing" \case
      (FiniteTestAnimBuilder (TestAnimBuilder ab), Positive newTotalDur) ->
        totalDur === newTotalDur
          .&&. iterDur - newTotalDur >= 0
          .&&. iterDur - newTotalDur < dt
          .&&. minFrameDur === frameDur
          .&&. maxFrameDur === frameDur
          .&&. totalFrameCountDefault === totalFrameCount
        where
        stepCount = length $ iterateAnim dt a'
        iterDur = dt * fromIntegral stepCount
        a' = buildAnim (AnimDurationEachFrameFromTotal newTotalDur) ab
        dt = maxFrameDur
        Just AnimMeta
          { animMetaTotalFrameCount = totalFrameCount
          , animMetaTotalDur = totalDur
          , animMetaMinFrameDur = minFrameDur
          , animMetaMaxFrameDur = maxFrameDur
          } = animMeta a'

        frameDur = newTotalDur / fromIntegral totalFrameCount

        a = buildAnim AnimDurationDefault ab
        Just AnimMeta
          { animMetaTotalFrameCount = totalFrameCountDefault
          } = animMeta a

    prop "Stepping a completed animation is idempotent" \case
      (FiniteTestAnim (TestAnim a), Positive dt) ->
        ((==) `on` animFrame . steppedAnimValue) sa $ stepAnim dt $ steppedAnimValue sa
        where
        sa = last $ iterateAnim dt a

    prop "Infinite animations do not have countable metadata" \case
      (InfiniteTestAnimBuilder (TestAnimBuilder ab), TestAnimDuration ad) ->
        validDur ad ==> isNothing $ animMeta $ buildAnim ad ab

    prop "Infinite animations cannot override total duration" \case
      (InfiniteTestAnimBuilder (TestAnimBuilder ab), TestAnimDuration ad) ->
        invalidInfiniteDur ad ==> ioProperty do
          try (evaluate $ buildAnim ad ab) >>= \case
            Left (ErrorCall msg) -> pure $ "buildAnim: " `L.isPrefixOf` msg
            Right {} -> pure False

    prop "Repeating a finite animation some finite number of times" \case
      (TestAnimSlice as, (TestAnimRepeat ar) :: TestAnimRepeat 1 0, TestAnimDuration ad) ->
        getExpectedFrames a === take (succ n * sliceLen) (cycle $ getSliceFrames as)
        where
        a = buildAnim ad ab
        ab = repeatAnim ar $ fromAnimSlice as
        sliceLen = V.length $ animSliceFrames as
        n = case ar of
          AnimRepeatCount x -> x
          AnimRepeatForever -> error "impossible"

    prop "An infinite animation is \"infinite\"" \case
      (TestAnimSlice as, TestAnimDuration ad, Positive n) ->
        validDur ad && n > sliceLen ==>
        take (n * sliceLen) (getExpectedFrames a) ===
          take (n * sliceLen) (cycle $ getSliceFrames as)
        where
        a = buildAnim ad ab
        ab = repeatAnim AnimRepeatForever $ fromAnimSlice as
        sliceLen = V.length $ animSliceFrames as

    prop "An infinite pingponging animation is \"infinite\"" \case
      (TestAnimSlice as, TestAnimDuration ad, Positive n) ->
        validDur ad ==>
        take (n * sliceLen) (getExpectedFrames a) ===
          take (n * sliceLen) (cycle $ sliceFrames <> reverse sliceFrames)
        where
        sliceFrames = getSliceFrames as
        a = buildAnim ad ab
        ab = repeatAnim AnimRepeatForever $ pingpongAnimSlice as
        sliceLen = V.length $ animSliceFrames as

getExpectedFrames :: G.Vector v f => Anim_ v t f -> [f]
getExpectedFrames a0 = foldMap getSliceFrames $ animSequence a0

getSliceFrames :: G.Vector v f => AnimSlice_ v t f -> [f]
getSliceFrames AnimSlice { animSliceDir = dir, animSliceFrames = frames }
  | AnimDirForward <- dir = G.toList frames
  | otherwise = G.toList $ G.reverse frames

getRealFrames :: G.Vector v f => [SteppedAnim_ v t f] -> [f]
getRealFrames = fmap \case
  SteppedAnim { steppedAnimValue = a } -> animFrame a

validDur :: AnimDuration_ t -> Bool
validDur = \case
  AnimDurationDefault -> True
  AnimDurationScaled {} -> True
  AnimDurationTotal {} -> False
  AnimDurationEachFrame {} -> True
  AnimDurationEachFrameFromTotal {} -> False

invalidInfiniteDur :: AnimDuration_ t -> Bool
invalidInfiniteDur = \case
  AnimDurationDefault -> False
  AnimDurationScaled {} -> False
  AnimDurationTotal {} -> True
  AnimDurationEachFrame {} -> False
  AnimDurationEachFrameFromTotal {} -> True

type FiniteTestAnim :: Type
newtype FiniteTestAnim = FiniteTestAnim (TestAnim 1 0)
  deriving newtype (Arbitrary, Show)

type InfiniteTestAnim :: Type
newtype InfiniteTestAnim = InfiniteTestAnim (TestAnim 0 1)
  deriving newtype (Arbitrary, Show)

type TestAnim :: Nat -> Nat -> Type
newtype TestAnim nf ni = TestAnim (Anim_ V.Vector Rational AnimFrame)
  deriving newtype (Show)

instance (KnownNat nf, KnownNat ni) => Arbitrary (TestAnim nf ni) where
  arbitrary :: Gen (TestAnim nf ni)
  arbitrary = do
    TestAnimDuration dur <- arbitrary
    TestAnimBuilder builder <- arbitrary @(TestAnimBuilder nf ni)
    pure $ TestAnim $ buildAnim dur builder

type FiniteTestAnimBuilder :: Type
newtype FiniteTestAnimBuilder = FiniteTestAnimBuilder (TestAnimBuilder 1 0)
  deriving newtype (Arbitrary, Show)

type InfiniteTestAnimBuilder :: Type
newtype InfiniteTestAnimBuilder = InfiniteTestAnimBuilder (TestAnimBuilder 0 1)
  deriving newtype (Arbitrary, Show)

type TestAnimBuilder :: Nat -> Nat -> Type
newtype TestAnimBuilder nf ni = TestAnimBuilder (AnimBuilder_ V.Vector Rational AnimFrame)
  deriving newtype (Semigroup, Show)

instance (KnownNat nf, KnownNat ni) => Arbitrary (TestAnimBuilder nf ni) where
  arbitrary :: Gen (TestAnimBuilder nf ni)
  arbitrary = do
    sconcat . NonEmpty.fromList <$> listOf1 do
      mkBuilder <- genMkAnimBuilder
      TestAnimSlice slice <- arbitrary
      TestAnimRepeat rep <- arbitrary @(TestAnimRepeat nf ni)
      pure $ TestAnimBuilder $ repeatAnim rep $ mkBuilder slice

type TestAnimSlice :: Type
newtype TestAnimSlice = TestAnimSlice (AnimSlice_ V.Vector Rational AnimFrame)
  deriving newtype (Show)

instance Arbitrary TestAnimSlice where
  arbitrary :: Gen TestAnimSlice
  arbitrary = do
    TestAnimDir dir <- arbitrary
    len <- chooseInt (1, 3)
    frameDurs <- do
      positiveDurs <- fmap getPositive <$> vectorOf len arbitrary
      pure $ V.fromListN len positiveDurs
    frames <- do
      rects <- vectorOf len genAnimFrame
      pure $ V.fromListN len rects
    pure $ TestAnimSlice AnimSlice
      { animSliceDir = dir
      , animSliceFrameDurs = frameDurs
      , animSliceFrames = frames
      }

type TestAnimDuration :: Type
newtype TestAnimDuration = TestAnimDuration (AnimDuration_ Rational)
  deriving stock (Show)

instance Arbitrary TestAnimDuration where
  arbitrary :: Gen TestAnimDuration
  arbitrary =
    TestAnimDuration <$> frequency
      [ (4, pure AnimDurationDefault)
      , (1, AnimDurationScaled . getNonNegative <$> arbitrary)
      , (1, AnimDurationTotal . getPositive <$> arbitrary)
      , (1, AnimDurationEachFrame . getNonNegative <$> arbitrary)
      , (1, AnimDurationEachFrameFromTotal . getPositive <$> arbitrary)
      ]

type TestAnimDir :: Type
newtype TestAnimDir = TestAnimDir AnimDir

instance Arbitrary TestAnimDir where
  arbitrary :: Gen TestAnimDir
  arbitrary = TestAnimDir <$> oneof [pure AnimDirForward, pure AnimDirBackward]

type TestAnimRepeat :: Nat -> Nat -> Type
newtype TestAnimRepeat nf ni = TestAnimRepeat AnimRepeat
  deriving newtype (Show)

instance (KnownNat nf, KnownNat ni) => Arbitrary (TestAnimRepeat nf ni) where
  arbitrary :: Gen (TestAnimRepeat nf ni)
  arbitrary =
    TestAnimRepeat <$> frequency
      [ ( fromInteger $ natVal $ Proxy @nf
        , AnimRepeatCount . getNonNegative <$> arbitrary
        )
      , ( fromInteger $ natVal $ Proxy @ni
        , pure AnimRepeatForever
        )
      ]

genMkAnimBuilder :: Gen (AnimSlice_ V.Vector Rational AnimFrame -> AnimBuilder_ V.Vector Rational AnimFrame)
genMkAnimBuilder = arbitrary <&> \case
  False -> fromAnimSlice
  True -> pingpongAnimSlice

genAnimFrame :: Arbitrary a => Gen (AnimFrame_ a)
genAnimFrame = AnimFrame <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary

fromSteppedAnim :: SteppedAnim_ v t f -> (AnimStatus, Anim_ v t f)
fromSteppedAnim SteppedAnim { steppedAnimStatus = as, steppedAnimValue = a } = (as, a)