diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +## 0.1.0.0 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2024 Jason Shipman + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,93 @@ +# [anitomata][] + +[![Version badge][]][version] + +## Synopsis + +`anitomata` is a pure implementation of 2D sprite animation intended for use in +gamedev. + +In this example, `anim` is an animation for an NPC celebrating a victory. The +animation sequence plays the NPC's `idle` animation two times then the `jump` +animation one time, and the entire sequence is looped indefinitely: + +```haskell +import Anitomata +import qualified Data.Vector.Unboxed as U + +anim :: Anim +anim = + buildAnim AnimDurationDefault + $ repeatAnim AnimRepeatForever + $ repeatAnim (AnimRepeatCount 1) idle <> jump + +idle :: AnimBuilder +idle = fromAnimSlice idleSlice + +jump :: AnimBuilder +jump = fromAnimSlice jumpSlice + +idleSlice :: AnimSlice +idleSlice = + AnimSlice + { animSliceDir = AnimDirBackward + , animSliceFrameDurs = U.replicate 4 0.1 -- Each frame is 100ms + , animSliceFrames = U.fromListN 4 [{- ... AnimFrame values ... -}] + } + +jumpSlice :: AnimSlice +jumpSlice = + AnimSlice + { animSliceDir = AnimDirForward + -- Second frame is 500ms, rest are 100ms + , animSliceFrameDurs = U.generate 8 $ \i -> if i == 1 then 0.5 else 0.1 + , animSliceFrames = U.fromListN 8 [{- ... AnimFrame values ... -}] + } +``` + +`AnimSlice` is the smallest building block of an animation. Slices are a minimal +sequence of frames that capture a logical chunk of animation. Slices are +converted to `AnimBuilder` values and then the builders can be combined using +the `Semigroup` interface. Values of the core animation type - `Anim` - are +created from builders. + +A game can play an animation by stepping it using `stepAnim` each simulation +frame, passing the time elapsed since the last step: + +```haskell +stepAnim :: Double -> Anim -> SteppedAnim + +data SteppedAnim = SteppedAnim + { steppedAnimStatus :: AnimStatus + , steppedAnimValue :: Anim + } +``` + +An animation can be rendered using `animFrame` in conjunction with a spritesheet +that is managed separately by the game. `animFrame` provides the current frame +of the animation: + +```haskell +animFrame :: Anim -> AnimFrame +``` + +Note that the types in the library are more general than what is shown above. +For example, there is no requirement of using `Double` as a duration type, +unboxed `Vector` as the vector type, etc. + +The animation building blocks can be defined manually, but this is tedious and +error-prone. Instead, the base slices and builders are typically defined +automatically by feeding a design file - e.g. output from Aseprite - into a code +generator or parsing some translated representation of a design file. Packages +providing this functionality may be found by visiting the project's +[homepage](https://sr.ht/~jship/anitomata/) or by searching Hackage (all +official packages of the `anitomata` project are named `anitomata-*`). + +For additional detail on the library, please see the [Haddocks][] and the +[announcement post][]. + +[anitomata]: +[Version badge]: +[version]: +[Haddocks]: +[announcement post]: diff --git a/anitomata.cabal b/anitomata.cabal new file mode 100644 --- /dev/null +++ b/anitomata.cabal @@ -0,0 +1,58 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.36.0. +-- +-- see: https://github.com/sol/hpack + +name: anitomata +version: 0.1.0.0 +synopsis: Composable sprite animation +description: Composable 2D sprite animation in Haskell. +category: Game +homepage: https://sr.ht/~jship/anitomata/ +author: Jason Shipman +maintainer: Jason Shipman +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + CHANGELOG.md + LICENSE + package.yaml + README.md + +source-repository head + type: git + location: https://git.sr.ht/~jship/anitomata/ + +library + exposed-modules: + Anitomata + other-modules: + Paths_anitomata + hs-source-dirs: + library + ghc-options: -Weverything -Wno-missing-local-signatures -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specializations -Wno-all-missed-specializations -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode + build-depends: + base >=4.17 && <4.20 + , vector >=0.13.1.0 && <0.14 + default-language: GHC2021 + +test-suite anitomata-test-suite + type: exitcode-stdio-1.0 + main-is: Driver.hs + other-modules: + Test.AnitomataSpec + Paths_anitomata + hs-source-dirs: + test-suite + ghc-options: -Weverything -Wno-missing-local-signatures -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specializations -Wno-all-missed-specializations -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode -rtsopts -threaded -with-rtsopts "-N" + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + QuickCheck + , anitomata + , base + , hspec + , vector + default-language: GHC2021 diff --git a/library/Anitomata.hs b/library/Anitomata.hs new file mode 100644 --- /dev/null +++ b/library/Anitomata.hs @@ -0,0 +1,758 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +module Anitomata + ( -- * Synopsis + -- $synopsis + + -- ** Naming conventions + -- $naming + + -- * Animations + Anim, Anim_ + -- ** Playing + , stepAnim + , SteppedAnim, SteppedAnim_(..) + , AnimStatus(..) + -- ** Rendering + , animFrame + , AnimFrame, AnimFrame_(..) + -- ** Building + , buildAnim + , AnimDuration, AnimDuration_(..) + , AnimBuilder, AnimBuilder_ + , fromAnimSlice + , pingpongAnimSlice + , repeatAnim + , AnimRepeat(..) + -- *** Slices + , AnimSlice, AnimSlice_(..) + , AnimDir(..) + -- ** Metadata + , animMeta + , AnimMeta, AnimMeta_(..) + -- ** Testing + -- $testing + , iterateAnim + , animSlice + , animSequence + ) where + +import Control.Monad.ST (ST) +import Data.Int (Int32) +import Data.Kind (Type) +import Data.List.NonEmpty (NonEmpty((:|))) +import Data.Semigroup (Semigroup(stimes)) +import Data.Vector.Fusion.Util (Box) +import Prelude +import Text.Printf (printf) +import Text.Show.Functions () + +import Data.List qualified as L +import Data.Vector.Generic qualified as G +import Data.Vector.Generic.Mutable.Base qualified as GMB +import Data.Vector.Unboxed qualified as U + +-- | The core animation type. +type Anim :: Type +type Anim = Anim_ U.Vector Double AnimFrame + +type Anim_ :: (Type -> Type) -> Type -> Type -> Type +data Anim_ v t f = Anim + { animElapsed :: !t + , animIndex :: !Int + , animUpdateFrameDur :: !(t -> t) + , animBuilder :: !(AnimBuilder_ v t f) + } deriving stock (Show) + +-- | A source rectangle into a spritesheet. +-- +-- The rectangle is defined via the coordinates of its top-left point and its +-- extents. +type AnimFrame :: Type +type AnimFrame = AnimFrame_ Int32 + +type AnimFrame_ :: Type -> Type +data AnimFrame_ i = AnimFrame + { animFrameX :: !i -- ^ X coordinate of top-left point in pixels. + , animFrameY :: !i -- ^ Y coordinate of top-left point in pixels. + , animFrameW :: !i -- ^ Width in pixels. + , animFrameH :: !i -- ^ Height in pixels. + } deriving stock (Eq, Show) + +-- | The animation's current frame. Use the frame in conjunction with your +-- game's spritesheet(s) to render an animation. +-- +-- In the default config, the result type is 'AnimFrame'. You are free to use +-- any frame type you'd like though. +animFrame :: forall v t f. G.Vector v f => Anim_ v t f -> f +animFrame a = frames G.! idx + where + Anim { animIndex = idx, animBuilder = ab } = a + AnimBuilder { animBuilderSlice = as } = ab + AnimSlice { animSliceFrames = frames } = as + +-- | The animation's current slice. +-- +-- The slice returned is the original slice specified at animation build time +-- and its frame durations are /not/ modified to take the animation's specified +-- duration into account. +animSlice :: forall v t f. Anim_ v t f -> AnimSlice_ v t f +animSlice a = animBuilderSlice $ animBuilder a + +-- | The animation's current sequence of slices. +-- +-- The slices returned are the original slices specified at animation build time +-- and their frame durations are /not/ modified to take the animation's +-- specified duration into account. +animSequence :: forall v t f. Anim_ v t f -> NonEmpty (AnimSlice_ v t f) +animSequence a = as :| rest + where + Anim { animBuilder = ab } = a + AnimBuilder { animBuilderSlice = as, animBuilderNext = rest } = ab + +-- | The animation's metadata. +-- +-- This function produces 'Nothing' if the animation is infinitely repeating. +animMeta :: forall v t f. Anim_ v t f -> Maybe (AnimMeta_ t) +animMeta Anim { animBuilder = ab } + | Finite am <- animBuilderMeta ab = Just am + | otherwise = Nothing + +-- | A means for customizing an animation's duration. +-- +-- By default (i.e. when using 'AnimDurationDefault'), an animation's duration +-- is dictated by the durations of each individual frame. This is often what you +-- want, as playing the animation in your game will match the timing of playing +-- the animation in your design tool. Sometimes you may want to tweak an +-- animation's duration without redoing or duplicating work in your design tool +-- though, so in these cases, you may find the other branches in this type +-- useful. +type AnimDuration :: Type +type AnimDuration = AnimDuration_ Double + +type AnimDuration_ :: Type -> Type +data AnimDuration_ t + = AnimDurationDefault + -- ^ Use each frame's default duration. + | AnimDurationScaled !t + -- ^ Scale each frame's default duration by the specified value. + -- + -- For example, you can play an animation twice as fast with + -- 'AnimDurationScaled' @0.5@. + | AnimDurationTotal !t + -- ^ Scale each frame's default duration such that the time required to + -- play the animation matches the specified total duration. + -- + -- 'buildAnim' will generate a runtime error if this is used with an + -- infinitely repeating animation. + | AnimDurationEachFrame !t + -- ^ Ignore each frame's default duration, using the specified constant + -- duration instead. + | AnimDurationEachFrameFromTotal !t + -- ^ Ignore each frame's default duration, using a constant duration for each + -- frame derived from the specified total duration instead. + -- + -- 'buildAnim' will generate a runtime error if this is used with an + -- infinitely repeating animation. + deriving stock (Eq, Show) + +-- | Build an animation with a specified duration. +buildAnim + :: forall v t f + . (G.Vector v f, Fractional t) + => AnimDuration_ t + -> AnimBuilder_ v t f + -> Anim_ v t f +buildAnim ad ab = + Anim + { animElapsed = 0 + , animIndex = startIdx $ animBuilderSlice ab + , animUpdateFrameDur = updateFrameDur + , animBuilder = ab + { animBuilderMeta = + case animBuilderMeta ab of + Infinite -> Infinite + Finite am -> Finite AnimMeta + { animMetaTotalFrameCount = animMetaTotalFrameCount am + , animMetaTotalDur = + case ad of + AnimDurationDefault -> animMetaTotalDur am + AnimDurationScaled scale -> scale * animMetaTotalDur am + AnimDurationTotal dur -> dur + AnimDurationEachFrame dur -> dur * fromIntegral (animMetaTotalFrameCount am) + AnimDurationEachFrameFromTotal dur -> dur + , animMetaMinFrameDur = updateFrameDur $ animMetaMinFrameDur am + , animMetaMaxFrameDur = updateFrameDur $ animMetaMaxFrameDur am + } + } + } + where + updateFrameDur = + case ad of + AnimDurationDefault -> id + AnimDurationScaled scale -> (scale *) + AnimDurationTotal dur + | Finite (AnimMeta _ defaultDur _ _) <- animBuilderMeta ab -> + ((dur / defaultDur) *) + | otherwise -> + error $ unwords + [ "buildAnim: cannot override total duration of infinite" + , "animation" + ] + AnimDurationEachFrame dur -> const dur + AnimDurationEachFrameFromTotal dur + | Finite (AnimMeta frameCount _ _ _) <- animBuilderMeta ab -> + const $ dur / fromIntegral frameCount + | otherwise -> + error $ unwords + [ "buildAnim: cannot override total duration of infinite" + , "animation" + ] + +type AnimStatus :: Type +data AnimStatus + = AnimStatusFinished + -- ^ The animation has finished. Any additional calls to 'stepAnim' will be + -- no-ops. Stepping an infinitely repeating animation will never produce + -- this status. + | AnimStatusPlaying + -- ^ The animation is actively playing. Stepping an infinitely repeating + -- animation always produces this status. + deriving stock (Eq, Show) + +-- | 'SteppedAnim' wraps the animation's status and the updated animation value. +type SteppedAnim :: Type +type SteppedAnim = SteppedAnim_ U.Vector Double AnimFrame + +type SteppedAnim_ :: (Type -> Type) -> Type -> Type -> Type +data SteppedAnim_ v t f = SteppedAnim + { steppedAnimStatus :: !AnimStatus + -- ^ Indicates if the animation has finished or is actively playing. + , steppedAnimValue :: !(Anim_ v t f) + -- ^ The updated animation value. + } deriving stock (Show) + +-- | Advance an animation by the given amount of time. +stepAnim + :: forall v t f + . (G.Vector v t, G.Vector v f, RealFrac t) + => t -- ^ An amount of time. + -> Anim_ v t f + -> SteppedAnim_ v t f +stepAnim dt a + | elapsed' < timer = + if dt == 0 then + SteppedAnim + { steppedAnimStatus = AnimStatusPlaying + , steppedAnimValue = a + } + else + stepAnim 0 a { animElapsed = elapsed' } + | otherwise = + if idx == endIdx then + case s of + [] -> + SteppedAnim + { steppedAnimStatus = AnimStatusFinished + , steppedAnimValue = a + } + next : rest -> + stepAnim (elapsed' - timer) a + { animElapsed = 0 + , animIndex = startIdx next + , animBuilder = + AnimBuilder + { animBuilderMeta = am + , animBuilderSlice = next + , animBuilderNext = rest + } + } + else + stepAnim (elapsed' - timer) a + { animElapsed = 0 + , animIndex = idx + idxStep + } + where + elapsed', timer :: t + elapsed' = elapsed + dt + timer = updateFrameDur $ frameDurs G.! idx + + idxStep, endIdx :: Int + (idxStep, endIdx) = + case dir of + AnimDirForward -> (1, G.length frames - 1) + AnimDirBackward -> (-1, 0) + + Anim + { animElapsed = elapsed + , animIndex = idx + , animUpdateFrameDur = updateFrameDur + , animBuilder = ab + } = a + + AnimBuilder + { animBuilderMeta = am + , animBuilderSlice = as + , animBuilderNext = s + } = ab + + AnimSlice + { animSliceDir = dir + , animSliceFrameDurs = frameDurs + , animSliceFrames = frames + } = as + +-- | Repeatedly step an animation using a fixed timestep, producing a stream of +-- updated animations until the animation is finished. +-- +-- If the input animation is infinitely repeating, this function produces an +-- infinite list. +iterateAnim + :: forall v t f + . (G.Vector v t, G.Vector v f, RealFrac t) + => t + -> Anim_ v t f + -> [SteppedAnim_ v t f] +iterateAnim dt a0 = + takeUntilDone $ L.iterate (stepAnim dt . steppedAnimValue) $ stepAnim dt a0 + +takeUntilDone :: forall v t f. [SteppedAnim_ v t f] -> [SteppedAnim_ v t f] +takeUntilDone = \case + [] -> [] + sa : rest + | AnimStatusPlaying <- steppedAnimStatus sa -> + sa : takeUntilDone rest + | otherwise -> + [sa] + +startIdx :: forall v t f. G.Vector v f => AnimSlice_ v t f -> Int +startIdx as = + case animSliceDir as of + AnimDirForward -> 0 + AnimDirBackward -> G.length (animSliceFrames as) - 1 + +-- | An animation builder. +-- +-- Convert slices to builders via 'fromAnimSlice' and 'pingpongAnimSlice'. +-- Builders may then be combined via the 'Semigroup' interface and their +-- animation sequences may be repeated via 'repeatAnim'. +type AnimBuilder :: Type +type AnimBuilder = AnimBuilder_ U.Vector Double AnimFrame + +type AnimBuilder_ :: (Type -> Type) -> Type -> Type -> Type +data AnimBuilder_ v t f = AnimBuilder + { animBuilderMeta :: !(Countable (AnimMeta_ t)) + , animBuilderSlice :: !(AnimSlice_ v t f) + , animBuilderNext :: ![AnimSlice_ v t f] + } deriving stock (Eq, Show) + +instance RealFrac t => Semigroup (AnimBuilder_ v t f) where + (<>) :: AnimBuilder_ v t f -> AnimBuilder_ v t f -> AnimBuilder_ v t f + x <> y = + AnimBuilder + { animBuilderMeta = + animBuilderMeta x <> animBuilderMeta y + , animBuilderSlice = animBuilderSlice x + , animBuilderNext = + animBuilderNext x ++ (animBuilderSlice y : animBuilderNext y) + } + + stimes :: Integral b => b -> AnimBuilder_ v t f -> AnimBuilder_ v t f + stimes n x + | n <= 0 = error "AnimBuilder_.stimes: positive multiplier expected" + | otherwise = go n + where + go = \case + 1 -> x + i -> x <> go (i - 1) + +-- | Create a builder from a single slice. +fromAnimSlice + :: forall v t f + . (G.Vector v t, G.Vector v f, RealFrac t) + => AnimSlice_ v t f + -> AnimBuilder_ v t f +fromAnimSlice as + | frameDursLen /= framesLen = + let errMsg = unwords + [ "fromAnimSlice: mismatch between frame duration vector size (%d)" + , "and source rectangle vector size (%d)" + ] + in error $ printf errMsg frameDursLen framesLen + | frameDursLen < 1 = + error "fromAnimSlice: empty frame duration and source rectangle vectors" + | otherwise = + AnimBuilder + { animBuilderMeta = + Finite AnimMeta + { animMetaTotalFrameCount = framesLen + , animMetaTotalDur = G.sum frameDurs + , animMetaMinFrameDur = G.minimum frameDurs + , animMetaMaxFrameDur = G.maximum frameDurs + } + , animBuilderSlice = as + , animBuilderNext = [] + } + where + frameDursLen, framesLen :: Int + frameDursLen = G.length frameDurs + framesLen = G.length frames + + AnimSlice + { animSliceFrameDurs = frameDurs + , animSliceFrames = frames + } = as + +-- | Create a builder from a single slice, where the animation sequence is the +-- slice first played in its defined direction and then played in its opposite +-- direction. +-- +-- This is provided for convenience. You may achieve the same result using the +-- 'Semigroup' interface and futzing with the animation directions: +-- +-- @ +-- builder :: 'AnimBuilder' +-- builder = fromAnimSlice slice '<>' fromAnimSlice slice +-- { 'animSliceDir' = +-- case 'animSliceDir' slice of +-- 'AnimDirForward' -> 'AnimDirBackward' +-- 'AnimDirBackward' -> 'AnimDirForward' +-- } +-- +-- slice :: 'AnimSlice' +-- @ +pingpongAnimSlice + :: forall v t f + . (G.Vector v t, G.Vector v f, RealFrac t) + => AnimSlice_ v t f + -> AnimBuilder_ v t f +pingpongAnimSlice as = ab <> ab' + where + ab = fromAnimSlice as + ab' = ab { animBuilderSlice = reverseAnimSlice as } + +-- | Repeat a builder's animation sequence. +repeatAnim + :: forall v t f + . RealFrac t + => AnimRepeat + -> AnimBuilder_ v t f + -> AnimBuilder_ v t f +repeatAnim ar ab = + case ar of + AnimRepeatForever -> + let ab' = ab { animBuilderMeta = Infinite } <> ab' in ab' + AnimRepeatCount n + | n <= 0 -> ab + | otherwise -> stimes (1 + n) ab + +-- | Animation metadata. +type AnimMeta :: Type +type AnimMeta = AnimMeta_ Double + +type AnimMeta_ :: Type -> Type +data AnimMeta_ t = AnimMeta + { animMetaTotalFrameCount :: !Int + , animMetaTotalDur :: !t + , animMetaMinFrameDur :: !t + , animMetaMaxFrameDur :: !t + } deriving stock (Eq, Show) + +instance RealFrac t => Semigroup (AnimMeta_ t) where + (<>) :: AnimMeta_ t -> AnimMeta_ t -> AnimMeta_ t + x <> y = + AnimMeta + { animMetaTotalFrameCount = + animMetaTotalFrameCount x + animMetaTotalFrameCount y + , animMetaTotalDur = animMetaTotalDur x + animMetaTotalDur y + , animMetaMinFrameDur = + min (animMetaMinFrameDur x) (animMetaMinFrameDur y) + , animMetaMaxFrameDur = + max (animMetaMaxFrameDur x) (animMetaMaxFrameDur y) + } + +-- | A single, logical sequence of animation frames. A slice captures a +-- direction, a vector of frames, and a vector of frame durations. The sizes of +-- the two vectors must match. +-- +-- While you are technically free to create an animation out of a bunch of +-- single-frame slices, it is recommended for performance's sake that each slice +-- is defined with as many frames as necessary to capture a logical chunk of +-- animation. +-- +-- If you use a code generator or parser to produce your slices, additional +-- performance gains are available. These utilities typically produce a single +-- vector of frames and a single vector of durations encompassing all the +-- animation slices in your spritesheet. Then the produced animation slices +-- refer to these two "megavectors" via /vector/ slices (mind the overloaded +-- "slice" word) and avoid copying any frame and duration data. This makes the +-- use and reuse of animation slices very cheap. +type AnimSlice :: Type +type AnimSlice = AnimSlice_ U.Vector Double AnimFrame + +type AnimSlice_ :: (Type -> Type) -> Type -> Type -> Type +data AnimSlice_ v t f = AnimSlice + { animSliceDir :: !AnimDir + , animSliceFrameDurs :: !(v t) + , animSliceFrames :: !(v f) + } deriving stock (Eq, Show) + +reverseAnimSlice :: forall v t f. AnimSlice_ v t f -> AnimSlice_ v t f +reverseAnimSlice as = as { animSliceDir = reverseAnimDir $ animSliceDir as } + +type AnimDir :: Type +data AnimDir + = AnimDirForward -- ^ The slice is to be played forward. + | AnimDirBackward -- ^ The slice is to be played in reverse. + deriving stock (Eq, Show) + +reverseAnimDir :: AnimDir -> AnimDir +reverseAnimDir = \case + AnimDirForward -> AnimDirBackward + AnimDirBackward -> AnimDirForward + +type AnimRepeat :: Type +data AnimRepeat + = AnimRepeatForever + -- ^ Repeat the animation sequence infinitely. + | AnimRepeatCount !Int + -- ^ Repeat the animation sequence a finite number of times + deriving stock (Show) + +type Countable :: Type -> Type +data Countable a + = Infinite + | Finite !a + deriving stock (Eq, Show) + +instance (Semigroup a) => Semigroup (Countable a) where + (<>) :: Countable a -> Countable a -> Countable a + Finite x <> Finite y = Finite $ x <> y + _ <> _ = Infinite + +data instance U.MVector s (AnimFrame_ a) = + MV_AnimFrame {-# UNPACK #-} !Int !(U.MVector s a) + +data instance U.Vector (AnimFrame_ a) = + V_AnimFrame {-# UNPACK #-} !Int !(U.Vector a) + +instance U.Unbox a => GMB.MVector U.MVector (AnimFrame_ a) where + {-# INLINE basicLength #-} + basicLength :: U.MVector s (AnimFrame_ a) -> Int + basicLength (MV_AnimFrame n _) = n + + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice + :: Int + -> Int + -> U.MVector s (AnimFrame_ a) + -> U.MVector s (AnimFrame_ a) + basicUnsafeSlice m n (MV_AnimFrame _ rects) = + MV_AnimFrame n (GMB.basicUnsafeSlice (4 * m) (4 * n) rects) + + {-# INLINE basicOverlaps #-} + basicOverlaps + :: U.MVector s (AnimFrame_ a) + -> U.MVector s (AnimFrame_ a) + -> Bool + basicOverlaps (MV_AnimFrame _ rects1) (MV_AnimFrame _ rects2) = + GMB.basicOverlaps rects1 rects2 + + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew :: Int -> ST s (U.MVector s (AnimFrame_ a)) + basicUnsafeNew n = MV_AnimFrame n <$> GMB.basicUnsafeNew (4 * n) + + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead + :: U.MVector s (AnimFrame_ a) + -> Int + -> ST s (AnimFrame_ a) + basicUnsafeRead (MV_AnimFrame _ rects) i = + AnimFrame + <$> GMB.basicUnsafeRead rects offset + <*> GMB.basicUnsafeRead rects (1 + offset) + <*> GMB.basicUnsafeRead rects (2 + offset) + <*> GMB.basicUnsafeRead rects (3 + offset) + where + offset = 4 * i + + {-# INLINE basicUnsafeWrite #-} + basicUnsafeWrite + :: U.MVector s (AnimFrame_ a) + -> Int + -> AnimFrame_ a + -> ST s () + basicUnsafeWrite (MV_AnimFrame _ rects) i x = do + GMB.basicUnsafeWrite rects offset animFrameX + GMB.basicUnsafeWrite rects (1 + offset) animFrameY + GMB.basicUnsafeWrite rects (2 + offset) animFrameW + GMB.basicUnsafeWrite rects (3 + offset) animFrameH + where + offset = 4 * i + AnimFrame + { animFrameX + , animFrameY + , animFrameW + , animFrameH + } = x + + {-# INLINE basicInitialize #-} + basicInitialize :: U.MVector s (AnimFrame_ a) -> ST s () + basicInitialize (MV_AnimFrame _ rects) = GMB.basicInitialize rects + +instance U.Unbox a => G.Vector U.Vector (AnimFrame_ a) where + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze + :: G.Mutable U.Vector s (AnimFrame_ a) + -> ST s (U.Vector (AnimFrame_ a)) + basicUnsafeFreeze (MV_AnimFrame n rects) = + V_AnimFrame n <$> G.basicUnsafeFreeze rects + + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw + :: U.Vector (AnimFrame_ a) + -> ST s (G.Mutable U.Vector s (AnimFrame_ a)) + basicUnsafeThaw (V_AnimFrame n rects) = + MV_AnimFrame n <$> G.basicUnsafeThaw rects + + {-# INLINE basicLength #-} + basicLength :: U.Vector (AnimFrame_ a) -> Int + basicLength (V_AnimFrame n _) = n + + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice + :: Int + -> Int + -> U.Vector (AnimFrame_ a) + -> U.Vector (AnimFrame_ a) + basicUnsafeSlice m n (V_AnimFrame _ rects) = + V_AnimFrame n $ G.basicUnsafeSlice (4 * m) (4 * n) rects + + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeIndexM :: U.Vector (AnimFrame_ a) -> Int -> Box (AnimFrame_ a) + basicUnsafeIndexM (V_AnimFrame _ rects) i = + AnimFrame + <$> G.basicUnsafeIndexM rects offset + <*> G.basicUnsafeIndexM rects (1 + offset) + <*> G.basicUnsafeIndexM rects (2 + offset) + <*> G.basicUnsafeIndexM rects (3 + offset) + where + offset = 4 * i + +instance U.Unbox a => U.Unbox (AnimFrame_ a) + +{- $synopsis + +@anitomata@ is a pure implementation of 2D sprite animation intended for use in +gamedev. + +In this example, @anim@ is an animation for an NPC celebrating a victory. The +animation sequence plays the NPC's @idle@ animation two times then the @jump@ +animation one time, and the entire sequence is looped indefinitely: + +@ +import Anitomata +import qualified Data.Vector.Unboxed as U + +anim :: 'Anim' +anim = + 'buildAnim' 'AnimDurationDefault' + $ 'repeatAnim' 'AnimRepeatForever' + $ 'repeatAnim' ('AnimRepeatCount' 1) idle <> jump + +idle :: 'AnimBuilder' +idle = 'fromAnimSlice' idleSlice + +jump :: 'AnimBuilder' +jump = 'fromAnimSlice' jumpSlice + +idleSlice :: 'AnimSlice' +idleSlice = + 'AnimSlice' + { 'animSliceDir' = 'AnimDirBackward' + , 'animSliceFrameDurs' = 'U.replicate' 4 0.1 -- Each frame is 100ms + , 'animSliceFrames' = 'U.fromListN' 4 [{- ... AnimFrame values ... -}] + } + +jumpSlice :: 'AnimSlice' +jumpSlice = + 'AnimSlice' + { 'animSliceDir' = 'AnimDirForward' + -- Second frame is 500ms, rest are 100ms + , 'animSliceFrameDurs' = 'U.generate' 8 $ \\i -> if i == 1 then 0.5 else 0.1 + , 'animSliceFrames' = 'U.fromListN' 8 [{- ... AnimFrame values ... -}] + } +@ + +'AnimSlice' is the smallest building block of an animation. Slices are a minimal +sequence of frames that capture a logical chunk of animation. Slices are +converted to 'AnimBuilder' values and then the builders can be combined using +the 'Semigroup' interface. Values of the core animation type - 'Anim' - are +created from builders. + +A game can play an animation by stepping it using 'stepAnim' each simulation +frame, passing the time elapsed since the last step: + +@ +stepAnim :: 'Double' -> 'Anim' -> 'SteppedAnim' + +data SteppedAnim = SteppedAnim + { steppedAnimStatus :: 'AnimStatus' + , steppedAnimValue :: 'Anim' + } +@ + +An animation can be rendered using `animFrame` in conjunction with a spritesheet +that is managed separately by the game. `animFrame` provides the current frame +of the animation: + +@ +animFrame :: 'Anim' -> 'AnimFrame' +@ + +Note that the types in the library are more general than what is shown above. +For example, there is no requirement of using 'Double' as a duration type, +unboxed 'U.Vector' as the vector type, etc. + +The animation building blocks can be defined manually, but this is tedious and +error-prone. Instead, the base slices and builders are typically defined +automatically by feeding a design file - e.g. output from Aseprite - into a code +generator or parsing some translated representation of a design file. Packages +providing this functionality may be found by visiting the project's +[homepage](https://sr.ht/~jship/anitomata/) or by searching Hackage (all +official packages of the @anitomata@ project are named @anitomata-*@). +-} + +{- $naming + +This library uses a naming convention on type constructors. Consider 'Anim' +and 'Anim_': 'Anim_' is the type constructor and so is suffixed with an +underscore. 'Anim' is a type alias for 'Anim_' with sensible defaults filled +in for all the type parameters. If you are getting started with the library, +it is recommended to use the type aliases. When looking at type signatures in +the documentation, it may be helpful to mentally substitute the simpler type +aliases in for the more general type constructor applications. If the docs +mention the "default config", this is shorthand for the prescribed defaults +from the aliases. + +The library also aims to be consistent with its naming of type parameters: + ++------+---------------------------+--------------------+ +| Name | Meaning | Default config | ++======+===========================+====================+ +| @v@ | A vector type constructor | Unboxed 'U.Vector' | ++------+---------------------------+--------------------+ +| @t@ | A duration type | 'Double' | ++------+---------------------------+--------------------+ +| @f@ | A frame type | 'AnimFrame' | ++------+---------------------------+--------------------+ +| @i@ | An integral type | 'Int32' | ++------+---------------------------+--------------------+ +-} + +{- $testing + +You __really__ shouldn't need anything from this section! These functions are +only provided to aid in testing and debugging. +-} diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -0,0 +1,55 @@ +name: anitomata +version: 0.1.0.0 +homepage: https://sr.ht/~jship/anitomata/ +git: https://git.sr.ht/~jship/anitomata/ +license: MIT +license-file: LICENSE +author: Jason Shipman +maintainer: Jason Shipman +synopsis: Composable sprite animation +description: | + Composable 2D sprite animation in Haskell. +category: Game + +extra-source-files: +- CHANGELOG.md +- LICENSE +- package.yaml +- README.md + +language: GHC2021 + +ghc-options: +# Draws heavy inspiration from this list: https://medium.com/mercury-bank/enable-all-the-warnings-a0517bc081c3 +- -Weverything +- -Wno-missing-local-signatures # Warns if polymorphic local bindings do not have signatures +- -Wno-missing-exported-signatures # missing-exported-signatures turns off the more strict -Wmissing-signatures. See https://ghc.haskell.org/trac/ghc/ticket/14794#ticket +- -Wno-missing-import-lists # Requires explicit imports of _every_ function (e.g. ‘$’); too strict +- -Wno-missed-specializations # When GHC can’t specialize a polymorphic function +- -Wno-all-missed-specializations # See missed-specializations +- -Wno-unsafe # Don’t use Safe Haskell warnings +- -Wno-safe # Don’t use Safe Haskell warnings +- -Wno-missing-safe-haskell-mode # Don't warn if the Safe Haskell mode is unspecified + +library: + dependencies: + - base >= 4.17 && <4.20 + - vector >= 0.13.1.0 && <0.14 + source-dirs: library + +tests: + anitomata-test-suite: + source-dirs: test-suite + main: Driver.hs + build-tools: + - hspec-discover + dependencies: + - QuickCheck + - anitomata + - base + - hspec + - vector + ghc-options: + - -rtsopts + - -threaded + - -with-rtsopts "-N" diff --git a/test-suite/Driver.hs b/test-suite/Driver.hs new file mode 100644 --- /dev/null +++ b/test-suite/Driver.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test-suite/Test/AnitomataSpec.hs b/test-suite/Test/AnitomataSpec.hs new file mode 100644 --- /dev/null +++ b/test-suite/Test/AnitomataSpec.hs @@ -0,0 +1,382 @@ +{-# 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)