module Game.LambdaHack.Animation
( Attr(..), defaultAttr, AttrChar(..)
, SingleFrame(..), Animation, rederAnim
, twirlSplash, blockHit, blockMiss, deathBody, swapPlaces
) where
import qualified Data.IntMap as IM
import Data.Maybe
import qualified Data.List as L
import Data.Monoid
import Game.LambdaHack.PointXY
import Game.LambdaHack.Point
import Game.LambdaHack.Color
data SingleFrame = SingleFrame
{ sfLevel :: ![[AttrChar]]
, sfTop :: String
, sfBottom :: String
}
deriving Eq
newtype Animation = Animation [IM.IntMap AttrChar]
instance Monoid Animation where
mempty = Animation []
mappend (Animation a1) (Animation a2) = Animation (a1 ++ a2)
rederAnim :: X -> Y -> SingleFrame -> Animation
-> [Maybe SingleFrame]
rederAnim lxsize lysize basicFrame (Animation anim) =
let modifyFrame SingleFrame{sfLevel = levelOld, ..} am =
let fLine y lineOld =
let f l (x, acOld) =
let loc = toPoint lxsize (PointXY (x, y))
!ac = fromMaybe acOld $ IM.lookup loc am
in ac : l
in L.foldl' f [] (zip [lxsize1,lxsize2..0] (reverse lineOld))
sfLevel =
let f l (y, lineOld) = let !line = fLine y lineOld in line : l
in L.foldl' f [] (zip [lysize1,lysize2..0] (reverse levelOld))
in Just SingleFrame{..}
in map (modifyFrame basicFrame) anim
blank :: Maybe AttrChar
blank = Nothing
coloredSymbol :: Color -> Char -> Maybe AttrChar
coloredSymbol color symbol = Just $ AttrChar (Attr color defBG) symbol
mzipPairs :: (Maybe Point, Maybe Point) -> (Maybe AttrChar, Maybe AttrChar)
-> [(Point, AttrChar)]
mzipPairs (mloc1, mloc2) (mattr1, mattr2) =
let mzip (Just loc, Just attr) = Just (loc, attr)
mzip _ = Nothing
in if mloc1 /= mloc2
then catMaybes [mzip (mloc1, mattr1), mzip (mloc2, mattr2)]
else
catMaybes [mzip (mloc1, mattr1)]
twirlSplash :: (Maybe Point, Maybe Point) -> Color -> Color -> Animation
twirlSplash locs c1 c2 = Animation $ map (IM.fromList . mzipPairs locs)
[ (coloredSymbol BrWhite '*', blank)
, (coloredSymbol c1 '/', coloredSymbol BrCyan '^')
, (coloredSymbol c1 '-', blank)
, (coloredSymbol c1 '\\',blank)
, (coloredSymbol c1 '|', blank)
, (coloredSymbol c2 '/', blank)
, (coloredSymbol c2 '%', coloredSymbol BrCyan '^')
, (coloredSymbol c2 '%', blank)
, (blank , blank)
]
blockHit :: (Maybe Point, Maybe Point) -> Color -> Color -> Animation
blockHit locs c1 c2 = Animation $ map (IM.fromList . mzipPairs locs)
[ (coloredSymbol BrWhite '*', blank)
, (coloredSymbol BrBlue '{', coloredSymbol BrCyan '^')
, (coloredSymbol BrBlue '{', blank)
, (coloredSymbol c1 '}', blank)
, (coloredSymbol c1 '}', coloredSymbol BrCyan '^')
, (coloredSymbol c2 '/', blank)
, (coloredSymbol c2 '%', blank)
, (coloredSymbol c2 '%', blank)
, (blank , blank)
]
blockMiss :: (Maybe Point, Maybe Point) -> Animation
blockMiss locs = Animation $ map (IM.fromList . mzipPairs locs)
[ (coloredSymbol BrWhite '*', blank)
, (coloredSymbol BrBlue '{', coloredSymbol BrCyan '^')
, (coloredSymbol BrBlue '}', blank)
, (coloredSymbol BrBlue '}', blank)
, (blank , blank)
]
deathBody :: Point -> Animation
deathBody loc = Animation $ map (maybe IM.empty (IM.singleton loc))
[ coloredSymbol BrRed '\\'
, coloredSymbol BrRed '\\'
, coloredSymbol BrRed '|'
, coloredSymbol BrRed '|'
, coloredSymbol BrRed '%'
, coloredSymbol BrRed '%'
, coloredSymbol Red '%'
, coloredSymbol Red '%'
, coloredSymbol Red ';'
, coloredSymbol Red ';'
, coloredSymbol Red ','
]
swapPlaces :: (Maybe Point, Maybe Point) -> Animation
swapPlaces locs = Animation $ map (IM.fromList . mzipPairs locs)
[ (coloredSymbol BrMagenta '.', coloredSymbol Magenta 'o')
, (coloredSymbol BrMagenta 'd', coloredSymbol Magenta 'p')
, (coloredSymbol Magenta 'p', coloredSymbol BrMagenta 'd')
, (coloredSymbol Magenta 'o', blank)
]