{-# LANGUAGE DeriveGeneric #-}
module Animate
( Color
, FrameIndex
, Frame(..)
, Animations(..)
, Loop(..)
, Position(..)
, FrameStep(..)
, KeyName(..)
, SpriteClip(..)
, SpriteSheet(..)
, SpriteSheetInfo(..)
, animations
, framesByAnimation
, initPosition
, initPositionLoops
, initPositionWithLoop
, stepFrame
, stepPosition
, isAnimationComplete
, positionHasLooped
, currentFrame
, currentLocation
, nextKey
, prevKey
, readSpriteSheetInfoJSON
, readSpriteSheetInfoYAML
, readSpriteSheetJSON
, readSpriteSheetYAML
) where
import qualified Data.Vector as V (Vector, (!), length, fromList)
import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as BL
import qualified Data.Yaml as Y
import Control.Applicative ((<|>))
import Control.Monad (mzero)
import Data.Aeson (FromJSON(..), ToJSON(..), (.:), eitherDecode, object, (.=), Value(..))
import Data.Map (Map)
import Data.Word (Word8)
import Data.Text (Text)
import GHC.Generics (Generic)
type Color = (Word8, Word8, Word8)
type FrameIndex = Int
data Frame loc delay = Frame
{ fLocation :: loc
, fDelay :: delay
} deriving (Show, Eq, Generic)
newtype Animations key loc delay = Animations { unAnimations :: V.Vector (V.Vector (Frame loc delay)) }
deriving (Show, Eq)
class KeyName key where
keyName :: key -> Text
data SpriteClip key = SpriteClip
{ scX :: Int
, scY :: Int
, scW :: Int
, scH :: Int
, scOffset :: Maybe (Int, Int)
} deriving (Show, Eq, Generic)
instance ToJSON (SpriteClip key) where
toJSON SpriteClip{scX,scY,scW,scH,scOffset} = case scOffset of
Nothing -> toJSON (scX, scY, scW, scH)
Just (ofsX, ofsY) -> toJSON (scX, scY, scW, scH, ofsX, ofsY)
instance FromJSON (SpriteClip key) where
parseJSON v =
(do
(x,y,w,h) <- parseJSON v
return SpriteClip { scX = x, scY = y, scW = w, scH = h, scOffset = Nothing })
<|>
(do
(x,y,w,h,ofsX,ofsY) <- parseJSON v
return SpriteClip { scX = x, scY = y, scW = w, scH = h, scOffset = Just (ofsX, ofsY) })
data SpriteSheet key img delay = SpriteSheet
{ ssAnimations :: Animations key (SpriteClip key) delay
, ssImage :: img
} deriving (Generic)
data SpriteSheetInfo key delay = SpriteSheetInfo
{ ssiImage :: FilePath
, ssiAlpha :: Maybe Color
, ssiClips :: [SpriteClip key]
, ssiAnimations :: Map Text [(FrameIndex, delay)]
} deriving (Show, Eq, Generic)
instance ToJSON delay => ToJSON (SpriteSheetInfo key delay) where
toJSON SpriteSheetInfo{ssiImage,ssiAlpha,ssiClips,ssiAnimations} = object
[ "image" .= ssiImage
, "alpha" .= ssiAlpha
, "clips" .= ssiClips
, "animations" .= ssiAnimations
]
instance FromJSON delay => FromJSON (SpriteSheetInfo key delay) where
parseJSON (Object o) = do
image <- o .: "image"
alpha <- o .: "alpha"
clips <- o .: "clips"
anis <- o .: "animations"
return SpriteSheetInfo { ssiImage = image, ssiAlpha = alpha, ssiClips = clips, ssiAnimations = anis }
parseJSON _ = mzero
animations :: (Enum key, Bounded key) => (key -> [Frame loc delay]) -> Animations key loc delay
animations getFrames = Animations $ V.fromList $ map (V.fromList . getFrames) [minBound..maxBound]
framesByAnimation :: Enum key => Animations key loc delay -> key -> V.Vector (Frame loc delay)
framesByAnimation (Animations as) k = as V.! fromEnum k
data Loop
= Loop'Always
| Loop'Count Int
deriving (Show, Eq, Generic)
data Position key delay = Position
{ pKey :: key
, pFrameIndex :: FrameIndex
, pCounter :: delay
, pLoop :: Loop
} deriving (Show, Eq, Generic)
initPosition :: (Num delay) => key -> Position key delay
initPosition key = initPositionWithLoop key Loop'Always
initPositionLoops :: (Num delay) => key -> Int -> Position key delay
initPositionLoops key count = initPositionWithLoop key (Loop'Count count)
initPositionWithLoop :: (Num delay) => key -> Loop -> Position key delay
initPositionWithLoop key loop = Position
{ pKey = key
, pFrameIndex = 0
, pCounter = 0
, pLoop = loop
}
data FrameStep delay
= FrameStep'Counter delay
| FrameStep'Delta delay
deriving (Show, Eq, Generic)
stepFrame :: (Num delay, Ord delay) => Frame loc delay -> Position key delay -> delay -> FrameStep delay
stepFrame Frame{fDelay} Position{pCounter} delta =
if pCounter + delta >= fDelay
then FrameStep'Delta $ pCounter + delta - fDelay
else FrameStep'Counter $ pCounter + delta
stepPosition :: (Enum key, Num delay, Ord delay) => Animations key loc delay -> Position key delay -> delay -> Position key delay
stepPosition as p d =
case frameStep of
FrameStep'Counter counter -> p{pCounter = counter }
FrameStep'Delta delta -> stepPosition as p' delta
where
frameStep = stepFrame f p d
fs = unAnimations as V.! fromEnum (pKey p)
f = fs V.! pFrameIndex p
p'= case pLoop p of
Loop'Always -> p{pFrameIndex = (pFrameIndex p + 1) `mod` V.length fs, pCounter = 0}
Loop'Count n -> let
index = (pFrameIndex p + 1) `mod` V.length fs
n' = if index == 0 then n - 1 else n
in p
{ pFrameIndex = if n' < 0 then pFrameIndex p else index
, pCounter = 0
, pLoop = Loop'Count n' }
currentFrame :: (Enum key, Num delay) => Animations key loc delay -> Position key delay -> Frame loc delay
currentFrame anis Position{pKey,pFrameIndex} = (framesByAnimation anis pKey) V.! pFrameIndex
currentLocation :: (Enum key, Num delay) => Animations key loc delay -> Position key delay -> loc
currentLocation anis p = fLocation (currentFrame anis p)
isAnimationComplete :: (Enum key, Num delay, Ord delay) => Animations key loc delay -> Position key delay -> Bool
isAnimationComplete as p = case pLoop p of
Loop'Always -> False
Loop'Count n -> n < 0 && pFrameIndex p == lastIndex && pCounter p >= fDelay lastFrame
where
frames = framesByAnimation as (pKey p)
lastIndex = V.length frames - 1
lastFrame = frames V.! lastIndex
nextKey :: (Bounded key, Enum key, Eq key) => key -> key
nextKey key = if key == maxBound then minBound else succ key
prevKey :: (Bounded key, Enum key, Eq key) => key -> key
prevKey key = if key == minBound then maxBound else pred key
positionHasLooped
:: Position key delay
-> Position key delay
-> Bool
positionHasLooped Position{ pLoop = Loop'Count c } Position{ pLoop = Loop'Count c' } = c > c'
positionHasLooped Position{ pLoop = Loop'Always } _ = False
positionHasLooped _ Position{ pLoop = Loop'Always } = False
readSpriteSheetInfoJSON
:: FromJSON delay
=> FilePath
-> IO (SpriteSheetInfo key delay)
readSpriteSheetInfoJSON = readSpriteSheetInfo eitherDecode
readSpriteSheetInfoYAML
:: FromJSON delay
=> FilePath
-> IO (SpriteSheetInfo key delay)
readSpriteSheetInfoYAML = readSpriteSheetInfo eitherDecodeYAML
eitherDecodeYAML :: FromJSON a => BL.ByteString -> Either String a
eitherDecodeYAML = Y.decodeEither . BL.toStrict
readSpriteSheetInfo
:: FromJSON delay
=> (BL.ByteString -> Either String (SpriteSheetInfo key delay))
-> FilePath
-> IO (SpriteSheetInfo key delay)
readSpriteSheetInfo decoder path = do
metaBytes <- BL.readFile path
case decoder metaBytes of
Left _err -> error $ "Cannot parse Sprite Sheet Info \"" ++ path ++ "\""
Right ssi -> return ssi
readSpriteSheetJSON
:: (KeyName key, Ord key, Bounded key, Enum key, FromJSON delay)
=> (FilePath -> Maybe Color -> IO img)
-> FilePath
-> IO (SpriteSheet key img delay)
readSpriteSheetJSON = readSpriteSheet eitherDecode
readSpriteSheetYAML
:: (KeyName key, Ord key, Bounded key, Enum key, FromJSON delay)
=> (FilePath -> Maybe Color -> IO img)
-> FilePath
-> IO (SpriteSheet key img delay)
readSpriteSheetYAML = readSpriteSheet eitherDecodeYAML
readSpriteSheet
:: (KeyName key, Ord key, Bounded key, Enum key, FromJSON delay)
=> (BL.ByteString -> Either String (SpriteSheetInfo key delay))
-> (FilePath -> Maybe Color -> IO img)
-> FilePath
-> IO (SpriteSheet key img delay)
readSpriteSheet decoder loadImage infoPath = do
SpriteSheetInfo{ssiImage, ssiClips, ssiAnimations, ssiAlpha} <- readSpriteSheetInfo decoder infoPath
i <- loadImage ssiImage ssiAlpha
let frame key = (key, map (\a -> Frame (ssiClips !! fst a) (snd a)) (ssiAnimations Map.! keyName key))
let animationMap = Map.fromList $ map frame [minBound..maxBound]
return $ SpriteSheet (animations $ (Map.!) animationMap) i