diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,8 @@ +# Changelog + +This project adheres to [Haskell PVP](https://pvp.haskell.org/). + + +## 0.1.0.2 [2018-01-01] + +- Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Olivier Sohn (c) 2017 - 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Olivier Sohn nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,21 @@ +# What is it? + +A framework to create event-based, physics-based, composed, generative animations. + +Also contains ready-to-use animations. + +## Demos + +The following game uses this library to create its animations: + +[![asciicast](https://asciinema.org/a/151434.png)](https://asciinema.org/a/151434) + +# Build + +You can build using [stack](https://docs.haskellstack.org): + +`stack build --pedantic` + +# Contributions + +Contributions are welcome! diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/imj-animation.cabal b/imj-animation.cabal new file mode 100644 --- /dev/null +++ b/imj-animation.cabal @@ -0,0 +1,57 @@ +name: imj-animation +version: 0.1.0.2 +Category: Animation, Game Engine, Graphics, Algorithms +Synopsis: Animation Framework +Description: Framework to create event-based, physics-based, composed, generative animations. +homepage: https://github.com/OlivierSohn/hamazed/blob/master/imj-animation/README.md +bug-reports: https://github.com/OlivierSohn/hamazed/issues/ +license: BSD3 +license-file: LICENSE +author: Olivier Sohn +maintainer: olivier.sohn@gmail.com +copyright: 2017 - 2018 Olivier Sohn +build-type: Simple +extra-source-files: README.md CHANGELOG.md +cabal-version: >=1.10 + +Tested-With: GHC == 8.0.2, GHC == 8.2.2 + +library + hs-source-dirs: src + other-modules: + exposed-modules: + -- initially in a separate module for implementations + Imj.Graphics.Animation + , Imj.Graphics.Animation.Chars + , Imj.Graphics.Animation.Geo + , Imj.Graphics.Animation.Internal + -- initially in a separate module for core + , Imj.Graphics.Animation.Design.Color + , Imj.Graphics.Animation.Design.Create + , Imj.Graphics.Animation.Design.Render + , Imj.Graphics.Animation.Design.Timing + , Imj.Graphics.Animation.Design.Types + , Imj.Graphics.Animation.Design.Update + , Imj.Graphics.Animation.Design.UpdateAnimatedPoints + build-depends: base >= 4.8 && < 4.11 + , mtl >= 2.2.1 && < 2.3 + , imj-base ==0.1.* + , imj-prelude ==0.1.* + ghc-options: -Wall -fpedantic-bottoms -Wredundant-constraints + -fexcess-precision -optc-ffast-math + default-language: Haskell2010 + +test-suite imj-animation-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + other-modules: + main-is: Spec.hs + build-depends: base >= 4.8 && < 4.11 + ghc-options: -Wall -fpedantic-bottoms -Wredundant-constraints + -fexcess-precision -optc-ffast-math + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/OlivierSohn/hamazed/ + subdir: imj-animation diff --git a/src/Imj/Graphics/Animation.hs b/src/Imj/Graphics/Animation.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Animation.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Animation + ( + -- * Animation functions + -- | Animation functions are used by 'Animation's to update 'AnimatedPoint's. + gravityFallGeo + , simpleExplosionGeo + , quantitativeExplosionGeo + , animatePolygonGeo + , laserAnimationGeo + -- * Animation + , Animation + {- | An 'Animation' generates 'AnimatedPoint's: -} + , AnimatedPoint(..) + -- | 'AnimatedPoint's can interact with their environment: + , CanInteract(..) + -- | The result of an interaction between an 'AnimatedPoint' and its environment + -- can trigger a /mutation/: + , InteractionResult(..) + {- | 'AnimatedPoint's live in a + : + -} + , AnimatedPoints(..) + -- ** Create + , mkAnimation + -- ** Predefined animations + -- *** Explosive + , simpleExplosion + , quantitativeExplosionThenSimpleExplosion + -- *** Free fall + {- | 'freeFall' simulates the effect of gravity on an object that has an initial speed. + + 'freeFallThenExplode' adds an explosion when the falling object hits the environment + (ie when the 'InteractionResult' of an interaction between the object and + the environment is 'Mutation'). + -} + , freeFall + , freeFallThenExplode + -- *** Fragments + {- | 'fragmentsFreeFall' gives the impression that the object disintegrated in multiple + pieces before falling. + + 'fragmentsFreeFallThenExplode' adds an explosion when the falling object hits the environment + (ie when the 'InteractionResult' of an interaction between the object and + the environment is 'Mutation'). + -} + , fragmentsFreeFall + , fragmentsFreeFallThenExplode + -- *** Geometric + , animatedPolygon + , laserAnimation + -- *** Nice chars + {-| 'niceChar' presents a list of 'Char's that /look good/ + when used in explosive and free fall animations. -} + , niceChar + -- ** Update + , getDeadline + , shouldUpdate + , updateAnimation + -- ** Render + , renderAnim + -- * Internal + , module Imj.Graphics.Animation.Internal + -- * Reexports + , module Imj.Timing + , module Imj.Iteration + , Coords + ) where + +import Imj.Prelude + +import Imj.GameItem.Weapon.Laser.Types +import Imj.Geo.Continuous +import Imj.Geo.Discrete +import Imj.Graphics.Animation.Chars +import Imj.Graphics.Animation.Design.Create +import Imj.Graphics.Animation.Design.Color +import Imj.Graphics.Animation.Design.Render +import Imj.Graphics.Animation.Design.Timing +import Imj.Graphics.Animation.Design.Types +import Imj.Graphics.Animation.Design.Update +import Imj.Graphics.Animation.Geo +import Imj.Graphics.Animation.Internal +import Imj.Iteration +import Imj.Timing + +-- | A laser ray animation, with a fade-out effect. +laserAnimation :: LaserRay Actual + -- ^ The laser ray + -> (Coords Pos -> InteractionResult) + -- ^ Environment interaction function + -> Either SystemTime KeyTime + -- ^ 'Right' 'KeyTime' of the event's deadline + -- that triggered this animation, or 'Left' 'SystemTime' + -- of the current time if a player action triggered this animation + -> Maybe Animation +laserAnimation ray@(LaserRay _ (Ray seg)) interaction keyTime = + let pos = fst $ extremities seg -- this needs to be collision-free + in mkAnimation pos [laserAnimationGeo ray] (Speed 1) interaction keyTime Nothing + +-- | An animation chaining two circular explosions, the first explosion +-- can be configured in number of points, the second has 4*8=32 points. +quantitativeExplosionThenSimpleExplosion :: Int + -- ^ Number of points in the first explosion + -> Coords Pos + -- ^ Center of the first explosion + -> (Coords Pos -> InteractionResult) + -- ^ Environment interaction function + -> Speed + -- ^ Animation speed + -> Either SystemTime KeyTime + -- ^ 'Right' 'KeyTime' of the event's deadline + -- that triggered this animation, or 'Left' 'SystemTime' + -- of the current time if a player action triggered this animation + -> Char + -- ^ Character used when drawing the animation. + -> Maybe Animation +quantitativeExplosionThenSimpleExplosion num pos interaction animSpeed keyTime char = + let funcs = [ quantitativeExplosionGeo num Interact + , simpleExplosionGeo 8 Interact ] + in mkAnimation pos funcs animSpeed interaction keyTime (Just char) + +-- | An animation where a geometric figure (polygon or circle) expands then shrinks, +-- and doesn't interact with the environment. +animatedPolygon :: Int + -- ^ If n==1, the geometric figure is a circle, else if n>1, a n-sided polygon + -> Coords Pos + -- ^ Center of the polygon (or circle) + -> (Coords Pos -> InteractionResult) + -- ^ Environment interaction function + -> Speed + -- ^ Animation speed + -> Either SystemTime KeyTime + -- ^ 'Right' 'KeyTime' of the event's deadline + -- that triggered this animation, or 'Left' 'SystemTime' + -- of the current time if a player action triggered this animation + -> Char + -- ^ Character used when drawing the animation. + -> Maybe Animation +animatedPolygon n pos interaction animSpeed keyTime char = + mkAnimation pos [animatePolygonGeo n] animSpeed interaction keyTime (Just char) + +-- | A circular explosion configurable in number of points +simpleExplosion :: Int + -- ^ Number of points in the explosion + -> Coords Pos + -- ^ Center of the explosion + -> (Coords Pos -> InteractionResult) + -- ^ Environment interaction function + -> Speed + -- ^ Animation speed + -> Either SystemTime KeyTime + -- ^ 'Right' 'KeyTime' of the event's deadline + -- that triggered this animation, or 'Left' 'SystemTime' + -- of the current time if a player action triggered this animation + -> Char + -- ^ Character used when drawing the animation. + -> Maybe Animation +simpleExplosion resolution pos interaction animSpeed keyTime char = + mkAnimation pos [simpleExplosionGeo resolution Interact] animSpeed interaction keyTime (Just char) + +-- | Animation representing an object with an initial velocity disintegrating in +-- 4 different parts. +fragmentsFreeFall :: Vec2 Vel + -- ^ Initial speed + -> Coords Pos + -- ^ Initial position + -> (Coords Pos -> InteractionResult) + -- ^ Environment interaction function + -> Speed + -- ^ Animation speed + -> Either SystemTime KeyTime + -- ^ 'Right' 'KeyTime' of the event's deadline + -- that triggered this animation, or 'Left' 'SystemTime' + -- of the current time if a player action triggered this animation + -> Char + -- ^ Character used when drawing the animation. + -> [Animation] +fragmentsFreeFall speed pos interaction animSpeed keyTime char = + mapMaybe (\sp -> freeFall sp pos interaction animSpeed keyTime char) $ variations speed + +-- | A gravity-based free-falling animation. +freeFall :: Vec2 Vel + -- ^ Initial speed + -> Coords Pos + -- ^ Initial position + -> (Coords Pos -> InteractionResult) + -- ^ Environment interaction function + -> Speed + -- ^ Animation speed + -> Either SystemTime KeyTime + -- ^ 'Right' 'KeyTime' of the event's deadline + -- that triggered this animation, or 'Left' 'SystemTime' + -- of the current time if a player action triggered this animation + -> Char + -- ^ Character used when drawing the animation. + -> Maybe Animation +freeFall speed pos interaction animSpeed keyTime char = + mkAnimation pos [gravityFallGeo speed Interact] animSpeed interaction keyTime (Just char) + +-- | Animation representing an object with an initial velocity disintegrating in +-- 4 different parts free-falling and then exploding. +fragmentsFreeFallThenExplode :: Vec2 Vel + -- ^ Initial speed + -> Coords Pos + -- ^ Initial position + -> (Coords Pos -> InteractionResult) + -- ^ Environment interaction function + -> Speed + -- ^ Animation speed + -> Either SystemTime KeyTime + -- ^ 'Right' 'KeyTime' of the event's deadline + -- that triggered this animation, or 'Left' 'SystemTime' + -- of the current time if a player action triggered this animation + -> Char + -- ^ Character used when drawing the animation. + -> [Animation] +fragmentsFreeFallThenExplode speed pos interaction k s c = + mapMaybe (\sp -> freeFallThenExplode sp pos interaction k s c) $ variations speed + +-- | Given an input speed, computes four slightly different input speeds +variations :: Vec2 Vel -> [Vec2 Vel] +variations sp = + map (sumVec2d sp) [ Vec2 0.12 (-0.16) + , Vec2 (-0.22) (-0.116) + , Vec2 (-0.04) 0.36 + , Vec2 0.48 0.08] + +-- | An animation chaining a gravity-based free-fall and a circular explosion of 4*8 points. +freeFallThenExplode :: Vec2 Vel + -- ^ Initial speed + -> Coords Pos + -- ^ Initial position + -> (Coords Pos -> InteractionResult) + -- ^ Environment interaction function + -> Speed + -- ^ Animation speed + -> Either SystemTime KeyTime + -- ^ 'Right' 'KeyTime' of the event's deadline + -- that triggered this animation, or 'Left' 'SystemTime' + -- of the current time if a player action triggered this animation + -> Char + -- ^ Character used when drawing the animation. + -> Maybe Animation +freeFallThenExplode speed pos interaction animSpeed keyTime char = + let funcs = [ gravityFallGeo speed Interact + , simpleExplosionGeo 8 Interact] + in mkAnimation pos funcs animSpeed interaction keyTime (Just char) diff --git a/src/Imj/Graphics/Animation/Chars.hs b/src/Imj/Graphics/Animation/Chars.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Animation/Chars.hs @@ -0,0 +1,61 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Animation.Chars + ( niceChar + -- * Reexports + , Word8 + ) where + +import Imj.Prelude + +import Data.Word(Word8) + +-- | Returns one of the characters that /look good/ for explosive animations. +niceChar :: Word8 + -- ^ We take the modulo of that value + -> Char +niceChar i' + | i == 0 = '$' + | i == 1 = '?' + | i == 2 = 'd' + | i == 3 = 'R' + | i == 4 = 'O' + | i == 5 = 'o' + | i == 6 = '^' + | i == 7 = 'à' + | i == 8 = '{' + | i == 9 = '[' + | i == 10 = '|' + | i == 11 = '!' + | i == 12 = ':' + | i == 13 = '¨' + | i == 14 = '`' + | i == 15 = '&' + | i == 16 = '#' + | i == 17 = '@' + | i == 18 = '=' + | i == 19 = '\\' + | i == 20 = '/' + | i == 21 = '*' + | otherwise = error $ "logic error in niceChar " ++ show i' + where + end = 22 + i = abs $ i' `mod` end + + -- characters by type: + -- funny : $ + -- surprising : ? + -- beautiful : d + -- visible : R + -- bubbly : O o + -- birds : ^ { [ + -- interesting: à + -- subtle : | ! + -- nice : : & = + -- very light : ¨ ` + -- heavy : # + -- round : @ + -- sharp : \ / + -- rich : * diff --git a/src/Imj/Graphics/Animation/Design/Color.hs b/src/Imj/Graphics/Animation/Design/Color.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Animation/Design/Color.hs @@ -0,0 +1,21 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Animation.Design.Color + ( colorFromFrame + ) where + +import Imj.Prelude + +import Imj.Graphics.Color +import Imj.Iteration + +-- | Returns the color used to draw an animation, based on the frame number +-- (relative to the parent animation, if any). +colorFromFrame :: Frame -> LayeredColor +colorFromFrame (Frame f) = onBlack $ rgb r g b + where + r = assert (f >= 0) 4 + g = fromIntegral $ (0 + quot f 6) `mod` 2 -- [0..1] , slow changes + b = fromIntegral $ (0 + quot f 3) `mod` 3 -- [0..2] , 2x faster changes diff --git a/src/Imj/Graphics/Animation/Design/Create.hs b/src/Imj/Graphics/Animation/Design/Create.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Animation/Design/Create.hs @@ -0,0 +1,69 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Animation.Design.Create + ( mkAnimation + ) where + + +import Imj.Prelude + +import Imj.Geo.Discrete +import Imj.Graphics.Animation.Design.Types +import Imj.Graphics.Animation.Design.Update +import Imj.Graphics.Animation.Design.UpdateAnimatedPoints +import Imj.Iteration +import Imj.Timing + +-- | Creates an animation and initializes it by updating it once. +mkAnimation :: Coords Pos + -- ^ Center of the root 'AnimatedPoints'. + -> [Coords Pos -> Frame -> [AnimatedPoint]] + {- ^ List of /animation functions/. Every /animation function/ generates + 'AnimatedPoint's for a given level of the root 'AnimatedPoints': + + The k-th /animation function/ generates 'AnimatedPoints' + living in the (k+2)-th level, and takes the center of a (k+1)-th + level 'AnimatedPoints' in its 'Coords' argument. + + /Animation functions/ are expected to return the same number of 'AnimatedPoint's + at each iteration, or none after a given iteration to indicate that + their animation is over. -} + -> Speed + -- ^ Animation discrete speed. Tells by how much the 'Frame', passed + -- to animation functions, is incremented during an update. + -> (Coords Pos -> InteractionResult) + {- ^ The environmental interaction function. + + During update, 'AnimatedPoint's for which this function returns + 'Mutation' can mutate if they are allowed to. + + During render, 'AnimatedPoint's for which this + function returns 'Stable' are drawn. Others are + not drawn because they would overlap with the environment. -} + -> Either SystemTime KeyTime + -- ^ 'Right' 'KeyTime' of the event's deadline + -- that triggered this animation, or 'Left' 'SystemTime' + -- of the current time if a player action triggered this animation + -> Maybe Char + {- ^ The default 'Char' to draw an 'AnimatedPoint' with, if an 'AnimatedPoint' + of that 'Animation' doesn't specify one (i.e if one of the /animation functions/ + passed as argument don't set the 'Char' of the 'AnimatedPoint' they generate). -} + -> Maybe Animation + -- ^ Depending on /animation functions/, the created 'Animation' may be over + -- after the first update, hence 'Nothing' would be returned. +mkAnimation center updates speed interaction t' mayChar = + let update = updateAnimatedPoints updates + t = either KeyTime id t' + u = UpdateSpec t (zeroIteration speed) + points = mkAnimatedPoints center + in updateAnimation $ Animation points update interaction u mayChar + + +-- | Constructs an 'AnimatedPoints'. +mkAnimatedPoints :: Coords Pos + -- ^ Where the first animation should start. + -> AnimatedPoints +mkAnimatedPoints center = + AnimatedPoints Nothing center 0 diff --git a/src/Imj/Graphics/Animation/Design/Render.hs b/src/Imj/Graphics/Animation/Design/Render.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Animation/Design/Render.hs @@ -0,0 +1,65 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Animation.Design.Render + ( renderAnim + ) where + + +import Imj.Prelude + +import Control.Monad.IO.Class(MonadIO) +import Control.Monad.Reader.Class(MonadReader) + +import Data.Either(partitionEithers) + +import Imj.Geo.Discrete +import Imj.Graphics.Animation.Design.Types +import Imj.Graphics.Animation.Design.Color +import Imj.Graphics.Render +import Imj.Iteration + +{- | If an 'AnimatedPoint' has no specific 'Char' to be rendered with, +it will be rendered with the 'Char' of the 'Animation'. + +Hence, if neither 'AnimatedPoint' nor 'Animation' contain a 'Char', this function +errors.-} +{-# INLINABLE renderAnim #-} +renderAnim :: (Draw e, MonadReader e m, MonadIO m) + => Animation + -> Coords Pos + -- ^ Reference coordinates. + -> m () +renderAnim (Animation points _ interaction (UpdateSpec _ (Iteration _ frameForNextUpdate)) mayChar) = + render' frameForNextUpdate mayChar points interaction + +{-# INLINABLE render' #-} +render' :: (Draw e, MonadReader e m, MonadIO m) + => Frame + -> Maybe Char + -- ^ Default char to use when there is no char specified in the state + -> AnimatedPoints + -> (Coords Pos -> InteractionResult) + -> Coords Pos + -> m () +render' _ _ (AnimatedPoints Nothing _ _) _ _ = return () +render' _ _ (AnimatedPoints (Just []) _ _) _ _ = return () +render' + parentFrame mayCharAnim (AnimatedPoints (Just branches) _ childFrame) interaction r = do + let (children, aliveCoordinates) = partitionEithers branches + selectRenderedCoordinates = + filter (\(AnimatedPoint canInteract coords _) -> + case canInteract of + -- An alive animated point may collide: + DontInteract -> interaction coords == Stable + -- We make the assumption that every alive point is guaranteed to be collision-free. + -- Note that when the environment will be dynamic, it will be wrong: + Interact -> True) + relFrame = parentFrame - childFrame + color = colorFromFrame relFrame + mapM_ (\(AnimatedPoint _ c mayChar) -> do + let char = fromMaybe (error "no char was specified") $ mayChar <|> mayCharAnim + drawChar char (sumCoords c r) color) + $ selectRenderedCoordinates aliveCoordinates + mapM_ (\child -> render' relFrame mayCharAnim child interaction r) children diff --git a/src/Imj/Graphics/Animation/Design/Timing.hs b/src/Imj/Graphics/Animation/Design/Timing.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Animation/Design/Timing.hs @@ -0,0 +1,24 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Animation.Design.Timing + ( animationPeriod + , animationUpdateMargin + ) where + +import Imj.Timing + +-- | The console can refresh at approx. 21 fps, hence this value seems +-- appropriate (1/25 second) +animationPeriod :: DiffTime +animationPeriod = 0.04 + +{- | When there are multiple unsynchronized animations running, +there could be a lot of scene renderings in the same 1/100th second. + +To prevent performance degradation we allow some margin +to group update deadlines. +-} +animationUpdateMargin :: DiffTime +animationUpdateMargin = 0.01 diff --git a/src/Imj/Graphics/Animation/Design/Types.hs b/src/Imj/Graphics/Animation/Design/Types.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Animation/Design/Types.hs @@ -0,0 +1,99 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Animation.Design.Types + ( Animation(..) + , UpdateSpec(..) + , AnimatedPoints(..) + , AnimatedPoint(..) + , CanInteract(..) + , InteractionResult(..) + ) where + +import Imj.Prelude + +import GHC.Show(showString) + +import Imj.Geo.Discrete +import Imj.Iteration +import Imj.Timing + + +data Animation = Animation { + _animationPoints :: !AnimatedPoints + -- ^ The current points. + , _animationUpdate :: !((Coords Pos -> InteractionResult) + -> Frame + -> AnimatedPoints + -> AnimatedPoints) + -- ^ The function updating 'AnimatedPoints'. + , _animationInteraction :: !(Coords Pos -> InteractionResult) + -- ^ The environment interaction function. + , _animationNextUpdateSpec :: !UpdateSpec + -- ^ The time and iteration of the next update + , _animationChar :: !(Maybe Char) + -- ^ The char used to draw animated points when the 'AnimatedPoints' + -- don't specify one. If 'Nothing', the animation function /must/ specify one + -- when creating new 'AnimatedPoint's. +} + +instance Show Animation where + showsPrec _ (Animation a _ _ b c) = + showString $ "Animation{" ++ show (a,b,c) ++ "}" + + +data UpdateSpec = UpdateSpec { + _updateSpecTime :: !KeyTime + -- ^ The time at which the update should happen. + , _updateSpecIteration :: !Iteration + -- ^ The iteration that will be used in the update. +} deriving(Show) + + +data AnimatedPoints = AnimatedPoints { + _animatedPointsBranches :: !(Maybe [Either AnimatedPoints AnimatedPoint]) + -- ^ The children. A child can be 'Right' 'AnimatedPoint' or 'Left' 'AnimatedPoints'. + -- + -- When a 'Right' 'AnimatedPoint' mutates, it is converted to an empty 'Left' 'AnimatedPoints' + , _animatedPointsCenter :: !(Coords Pos) + -- ^ The center, aka the coordinates of the 'AnimatedPoint', w.r.t the animation reference frame, + -- that gave birth to this 'AnimatedPoints'. + , _animatedPointsFrame :: !Frame + -- ^ The frame at which this 'AnimatedPoints' was created, relatively to the parent, if any. +} deriving (Show) + +data AnimatedPoint = AnimatedPoint { + _animatedPointCanInteract :: !CanInteract + -- ^ Can the point interact with the environment? + , _animatedPointCoords :: {-# UNPACK #-} !(Coords Pos) + -- ^ Its location, w.r.t the animation reference frame. + , _animatedPointRenderedWith :: !(Maybe Char) + -- ^ The char used to render it. If 'Nothing', 'Animation' /must/ specify a 'Char'. +} deriving (Show) + +data CanInteract = DontInteract + -- ^ The 'AnimatedPoint' can't interact with the environment. + -- + -- To ensure that the 'Animation' is finite in time, + -- animation functions returning 'AnimatedPoint's that + -- 'DontInteract' should return an empty list of 'AnimatedPoint's + -- for each 'Frame' after a given 'Frame'. + | Interact + -- ^ The 'AnimatedPoint' can be mutated after an interaction + -- with the environment. + -- + -- For the animation to be finite in time, 'AnimatedPoint's that + -- 'Interact' /must/ eventually be mutated by the environment. + -- + -- Hence, assuming the environment has a finite size, + -- animation functions returning 'AnimatedPoint's that + -- 'Interact' can guarantee animation finitude by computing their + -- coordinates using functions diverging in the 'Frame' argument. + deriving (Show, Eq) + +data InteractionResult = Mutation + -- ^ The 'AnimatedPoint' can mutate. + | Stable + -- ^ The 'AnimatedPoint' doesn't mutate. + deriving(Eq,Show) diff --git a/src/Imj/Graphics/Animation/Design/Update.hs b/src/Imj/Graphics/Animation/Design/Update.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Animation/Design/Update.hs @@ -0,0 +1,63 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} + +module Imj.Graphics.Animation.Design.Update + ( shouldUpdate + , updateAnimation + , getDeadline + ) where + + +import Imj.Prelude + +import Data.Either(partitionEithers) + +import Imj.Graphics.Animation.Design.Types +import Imj.Graphics.Animation.Design.Timing +import Imj.Iteration +import Imj.Timing + + +{- | Returns 'True' if the 'KeyTime' is beyond the 'Animation' deadline or if the +time difference is within 'animationUpdateMargin'. -} +shouldUpdate :: Animation + -> KeyTime + -- ^ The current 'KeyTime' + -> Bool +shouldUpdate a (KeyTime k) = + let (KeyTime k') = getDeadline a + in diffSystemTime k' k < animationUpdateMargin + +updateAnimation :: Animation + -- ^ The current animation + -> Maybe Animation + -- ^ The updated animation, or Nothing if the 'Animation' + -- is over. +updateAnimation + (Animation points update interaction (UpdateSpec k it@(Iteration _ frame)) c) = + let newPoints = update interaction frame points + newUpdateSpec = UpdateSpec (addDuration animationPeriod k) (nextIteration it) + newAnim = Animation newPoints update interaction newUpdateSpec c + in case isActive newAnim of + True -> Just newAnim + False -> Nothing + +isActive :: Animation + -> Bool +isActive (Animation points _ _ _ _) = + hasActivePoints points + +hasActivePoints :: AnimatedPoints + -> Bool +hasActivePoints (AnimatedPoints Nothing _ _) = False +hasActivePoints (AnimatedPoints (Just []) _ _) = False +hasActivePoints (AnimatedPoints (Just branches) _ _) = + let (children, activeCoordinates) = partitionEithers branches + childrenActive = map hasActivePoints children + in (not . null) activeCoordinates || or childrenActive + +-- | Returns the time at which an 'Animation' should be updated. +getDeadline :: Animation -> KeyTime +getDeadline (Animation _ _ _ (UpdateSpec k _) _) = k diff --git a/src/Imj/Graphics/Animation/Design/UpdateAnimatedPoints.hs b/src/Imj/Graphics/Animation/Design/UpdateAnimatedPoints.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Animation/Design/UpdateAnimatedPoints.hs @@ -0,0 +1,130 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} + +module Imj.Graphics.Animation.Design.UpdateAnimatedPoints + ( updateAnimatedPoints + ) where + + +import Imj.Prelude + +import Data.List( length ) +import Data.Maybe( fromMaybe ) + +import Imj.Geo.Discrete +import Imj.Graphics.Animation.Design.Types +import Imj.Iteration + + +{- | Given a length \( n \) list of animation functions, updates the \( n \) +first levels of an 'AnimatedPoints' using one animation function per level. + +An 'AnimatedPoint' at level \( k <= n \) can mutate to an 'AnimatedPoints' by +interacting with its environment: + +* if \( k = n \) , the new 'AnimatedPoints' will remain empty. +* if \( k < n \), the new 'AnimatedPoints' will be populated by 'AnimatedPoints' +using the \( k+1 \)th animation function. +-} +updateAnimatedPoints :: [Coords Pos -> Frame -> [AnimatedPoint]] + -- ^ The animation function at index @i@ updates + -- 'AnimatedPoints' at level @i@. + -> (Coords Pos -> InteractionResult) + -- ^ Interaction function + -> Frame + -- ^ Current iteration + -> AnimatedPoints + -> AnimatedPoints +updateAnimatedPoints [] _ _ aps = aps +updateAnimatedPoints (f:fs) interaction globalFrame (AnimatedPoints branches center startFrame) = + let relativeFrame = globalFrame - startFrame + branchesLevel1Mutated = updatePointsAndMutateIfNeeded f center relativeFrame interaction branches + newBranches = map (\case + -- recurse for the 'AnimatedPoints's + Left aps -> Left $ updateAnimatedPoints fs interaction relativeFrame aps + -- the 'AnimatedPoint's are already up-to-date due to updatePointsAndMutateIfNeeded: + Right ap -> Right ap + ) branchesLevel1Mutated + in AnimatedPoints (Just newBranches) center startFrame + + +-- | Doesn't change the existing /level 1/ 'AnimatedPoints's, but can convert some +-- 'AnimatedPoint's to 'AnimatedPoints's. +updatePointsAndMutateIfNeeded :: (Coords Pos -> Frame -> [AnimatedPoint]) + -- ^ Geometric animation function + -> Coords Pos + -- ^ Center of the animation + -> Frame + -- ^ Relative frame + -> (Coords Pos -> InteractionResult) + -- ^ Interaction function + -> Maybe [Either AnimatedPoints AnimatedPoint] + -- ^ Current branches + -> [Either AnimatedPoints AnimatedPoint] + -- ^ Updated branches +updatePointsAndMutateIfNeeded animation root frame interaction branches = + let points = animation (assert (interaction root == Stable) root) frame + defaultState = map (\(AnimatedPoint canInteract _ _) -> Right $ AnimatedPoint canInteract root Nothing) points + previousState = fromMaybe defaultState branches + -- if previousState contains only Left(s), the animation does not need to be computed. + -- I wonder if lazyness takes care of that or not? + in combine points previousState frame interaction + +combine :: [AnimatedPoint] + -> [Either AnimatedPoints AnimatedPoint] + -> Frame + -> (Coords Pos -> InteractionResult) + -> [Either AnimatedPoints AnimatedPoint] +combine points previousState frame interaction = + let check = allowedPointCountVariation (length previousState) (length points) + in assert check $ + zipWith + (combinePoints interaction frame) + points previousState + +combinePoints :: (Coords Pos -> InteractionResult) + -> Frame + -> AnimatedPoint + -> Either AnimatedPoints AnimatedPoint + -> Either AnimatedPoints AnimatedPoint +combinePoints interaction frame point@(AnimatedPoint onWall coords _) = + either + Left + (\(AnimatedPoint prevOnWall prevCoords' _) -> + case assert (prevOnWall == onWall) onWall of + DontInteract -> Right point + Interact -> + -- The assert verifies that we can drop the first point of the trajectory. + -- This is because the environment is static. + let prevCoords = assert (interaction prevCoords' == Stable) prevCoords' + trajectory = bresenham $ mkSegment prevCoords coords + in maybe + (Right $ assert (interaction coords == Stable) point) + (\preCollision -> + Left $ AnimatedPoints Nothing preCollision frame) + $ getCoordsBeforeMutation trajectory interaction + ) + +-- The first point of the trajectory is expected to be stable +getCoordsBeforeMutation :: [Coords Pos] -> (Coords Pos -> InteractionResult) -> Maybe (Coords Pos) +getCoordsBeforeMutation [] _ = error "not supposed to happen" +getCoordsBeforeMutation [_] _ = Nothing +getCoordsBeforeMutation (a:as@(b:_)) interaction = + case interaction b of + Stable -> getCoordsBeforeMutation as interaction + Mutation -> Just a + +{- | Verifies that the variation in number of points is allowed: + +Number of points generated by /animation functions/ should be always the same, +or change from non-zero to 0 (to indicate the end of the animation). +-} +allowedPointCountVariation :: Int + -- ^ From + -> Int + -- ^ To + -> Bool +allowedPointCountVariation from to = + to == from || to == 0 diff --git a/src/Imj/Graphics/Animation/Geo.hs b/src/Imj/Graphics/Animation/Geo.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Animation/Geo.hs @@ -0,0 +1,156 @@ +{-# OPTIONS_HADDOCK hide #-} + +{-# LANGUAGE NoImplicitPrelude #-} + +module Imj.Graphics.Animation.Geo + ( gravityFallGeo + , simpleExplosionGeo + , quantitativeExplosionGeo + , animatePolygonGeo + , laserAnimationGeo + ) where + +import Imj.Prelude + +import Data.Char( intToDigit ) +import Data.List( length ) + +import Imj.GameItem.Weapon.Laser.Types +import Imj.Geo.Continuous +import Imj.Geo.Discrete +import Imj.Graphics.Animation.Design.Types +import Imj.Iteration + + +-- | Note that the Coords parameter is unused. +laserAnimationGeo :: LaserRay Actual + -> Coords Pos + -- ^ Unused, because the 'LaserRay' encodes the origin already + -> Frame + -> [AnimatedPoint] +laserAnimationGeo (LaserRay dir (Ray seg)) _ (Frame i) = + -- frame 0 : original char + -- frame 1 and 2 : replacement char + -- frame 3 : the end + let (originalChar, replacementChar) = + if dir == LEFT || dir == RIGHT + then + ('=','-') + else + ('|','.') + char = if i >= 2 + then + replacementChar + else + originalChar + points = if i >= 4 + then + [] + else + bresenham seg + in map (\p -> AnimatedPoint DontInteract p (Just char)) points + +-- | Gravity free-fall +gravityFallGeo :: Vec2 Vel + -- ^ Initial speed + -> CanInteract + -> Coords Pos + -- ^ Initial position + -> Frame + -> [AnimatedPoint] +gravityFallGeo initialSpeed canInteract origin frame = + let o = pos2vec origin + points = [vec2pos $ parabola o initialSpeed frame] + in map (\p -> AnimatedPoint canInteract p Nothing) points + +-- | Circular explosion by copying quarter arcs. +simpleExplosionGeo :: Int + -- ^ Number of points per quarter arc. + -> CanInteract + -> Coords Pos + -- ^ Center + -> Frame + -> [AnimatedPoint] +simpleExplosionGeo resolution canInteract center (Frame iteration) = + let radius = fromIntegral iteration :: Float + c = pos2vec center + points = map vec2pos $ translatedFullCircleFromQuarterArc c radius 0 resolution + in map (\p -> AnimatedPoint canInteract p Nothing) points + +-- | Circular explosion +quantitativeExplosionGeo :: Int + -- ^ The number of points of the circle + -> CanInteract + -> Coords Pos + -- ^ Center + -> Frame + -> [AnimatedPoint] +quantitativeExplosionGeo number canInteract center (Frame iteration) = + let numRand = 10 :: Int + rnd = 2 :: Int -- TODO store the random number in the state of the animation + -- rnd <- getStdRandom $ randomR (0,numRand-1) + radius = fromIntegral iteration :: Float + firstAngle = (fromIntegral rnd :: Float) * 2*pi / (fromIntegral numRand :: Float) + c = pos2vec center + points = map vec2pos $ translatedFullCircle c radius firstAngle number + in map (\p -> AnimatedPoint canInteract p Nothing) points + +-- | Expanding then shrinking geometric figure. +animatePolygonGeo :: Int + -- ^ number of extremities of the polygon (if 1, draw a circle instead) + -> Coords Pos + -- ^ Center + -> Frame + -- ^ Used to compute the radius. + -> [AnimatedPoint] +animatePolygonGeo n center (Frame i) = + let r = animateRadius (quot i 2) n + points = if r < 0 + then + [] + else + case n of + 1 -> let p = simpleExplosionGeo 8 DontInteract center $ Frame r + in map (\(AnimatedPoint _ p' _) -> p') p + _ -> polygon n r center + in map (\p -> AnimatedPoint DontInteract p (Just $ intToDigit n)) points + +-- | A polygon using resampled bresenham to augment the number of points : +-- the number of points needs to be constant across the entire animation +-- so we need to resampleWithExtremities according to the biggest possible figure. +polygon :: Int -> Int -> Coords Pos -> [Coords Pos] +polygon nSides radius center = + let startAngle = if odd nSides then pi else pi/4.0 + extrs = polyExtremities (pos2vec center) (fromIntegral radius) startAngle nSides + in connect $ map vec2pos extrs + +-- | Animates the radius by first expanding then shrinking. +animateRadius :: Int -> Int -> Int +animateRadius i nSides = + let limit + | nSides <= 4 = 5 + | nSides <= 6 = 7 + | otherwise = 10 + in if i < limit + then + i + else + 2 * limit - i + +connect :: [Coords Pos] -> [Coords Pos] +connect [] = [] +connect l@[_] = l +connect (a:rest@(b:_)) = connect2 a b ++ connect rest + +connect2 :: Coords Pos -> Coords Pos -> [Coords Pos] +connect2 start end = + let numpoints = 80 -- more than 2 * (max height width of world) to avoid spaces + in sampledBresenham numpoints start end + +-- | Applies bresenham transformation and resamples it +sampledBresenham :: Int -> Coords Pos -> Coords Pos -> [Coords Pos] +sampledBresenham nSamples start end = + let l = bresenhamLength start end + seg = mkSegment start end + bres = bresenham seg + in resampleWithExtremities bres (assert (l == length bres) l) nSamples diff --git a/src/Imj/Graphics/Animation/Internal.hs b/src/Imj/Graphics/Animation/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Imj/Graphics/Animation/Internal.hs @@ -0,0 +1,10 @@ +module Imj.Graphics.Animation.Internal + ( -- * Animation timing + animationPeriod + , animationUpdateMargin + -- * Animation colors + , colorFromFrame + ) where + +import Imj.Graphics.Animation.Design.Color +import Imj.Graphics.Animation.Design.Timing diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,4 @@ + +main :: IO () +main = do + putStrLn "" -- for readablilty