{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Imj.Graphics.Text.Animation
(
TextAnimation(..)
, AnchorChars
, AnchorStrings
, mkTextTranslation
, mkSequentialTextTranslationsCharAnchored
, mkSequentialTextTranslationsStringAnchored
, renderAnimatedTextCharAnchored
, renderAnimatedTextStringAnchored
, getAnimatedTextRenderStates
, module Imj.Graphics.Interpolation
) where
import Imj.Prelude
import qualified Prelude(length)
import Control.Monad( zipWithM_ )
import Control.Monad.IO.Class(MonadIO)
import Control.Monad.Reader.Class(MonadReader)
import Data.Text( unpack, length )
import Data.List(foldl', splitAt, unzip)
import Imj.Geo.Discrete
import Imj.Graphics.Math.Ease
import Imj.Graphics.Interpolation
import Imj.Graphics.Render
import Imj.Graphics.Text.ColorString
data AnchorStrings
data AnchorChars
data TextAnimation a = TextAnimation {
_textAnimationFromTos :: ![Evolution ColorString]
, _textAnimationAnchorsFrom :: !(Evolution (SequentiallyInterpolatedList (Coords Pos)))
, _textAnimationClock :: !EaseClock
} deriving(Show)
{-# INLINABLE renderAnimatedTextStringAnchored #-}
renderAnimatedTextStringAnchored :: (Draw e, MonadReader e m, MonadIO m)
=> TextAnimation AnchorStrings
-> Frame
-> m ()
renderAnimatedTextStringAnchored (TextAnimation fromToStrs renderStatesEvolution _) i = do
let rss = getAnimatedTextRenderStates renderStatesEvolution i
renderAnimatedTextStringAnchored' fromToStrs rss i
{-# INLINABLE renderAnimatedTextStringAnchored' #-}
renderAnimatedTextStringAnchored' :: (Draw e, MonadReader e m, MonadIO m)
=> [Evolution ColorString]
-> [Coords Pos]
-> Frame
-> m ()
renderAnimatedTextStringAnchored' [] _ _ = return ()
renderAnimatedTextStringAnchored' l@(_:_) rs i = do
let e = head l
rsNow = head rs
colorStr = getValueAt e i
drawColorStr colorStr rsNow
renderAnimatedTextStringAnchored' (tail l) (tail rs) i
{-# INLINABLE renderAnimatedTextCharAnchored #-}
renderAnimatedTextCharAnchored :: (Draw e, MonadReader e m, MonadIO m)
=> TextAnimation AnchorChars
-> Frame
-> m ()
renderAnimatedTextCharAnchored (TextAnimation fromToStrs renderStatesEvolution _) i = do
let rss = getAnimatedTextRenderStates renderStatesEvolution i
renderAnimatedTextCharAnchored' fromToStrs rss i
{-# INLINABLE renderAnimatedTextCharAnchored' #-}
renderAnimatedTextCharAnchored' :: (Draw e, MonadReader e m, MonadIO m)
=> [Evolution ColorString]
-> [Coords Pos]
-> Frame
-> m ()
renderAnimatedTextCharAnchored' [] _ _ = return ()
renderAnimatedTextCharAnchored' l@(_:_) rs i = do
let e@(Evolution (Successive colorStrings) _ _ _) = head l
nRS = maximum $ map countChars colorStrings
(nowRS, laterRS) = splitAt nRS rs
(ColorString colorStr) = getValueAt e i
renderColorStringAt colorStr nowRS
renderAnimatedTextCharAnchored' (tail l) laterRS i
{-# INLINABLE renderColorStringAt #-}
renderColorStringAt :: (Draw e, MonadReader e m, MonadIO m)
=> [(Text, LayeredColor)]
-> [Coords Pos]
-> m ()
renderColorStringAt [] _ = return ()
renderColorStringAt l@(_:_) rs = do
let (txt, color) = head l
len = length txt
(headRs, tailRs) = splitAt len $ assert (Prelude.length rs >= len) rs
zipWithM_ (\char coord -> drawChar char coord color) (unpack txt) headRs
renderColorStringAt (tail l) tailRs
getAnimatedTextRenderStates :: Evolution (SequentiallyInterpolatedList (Coords Pos))
-> Frame
-> [Coords Pos]
getAnimatedTextRenderStates evolution i =
let (SequentiallyInterpolatedList l) = getValueAt evolution i
in l
build :: Coords Pos -> Int -> [Coords Pos]
build x sz = map (\i -> move i RIGHT x) [0..pred sz]
mkSequentialTextTranslationsCharAnchored :: [([ColorString], Coords Pos, Coords Pos)]
-> Float
-> TextAnimation AnchorChars
mkSequentialTextTranslationsCharAnchored l duration =
let (from_,to_) =
foldl'
(\(froms, tos) (colorStrs, from, to) ->
let sz = maximum $ map countChars colorStrs
in (froms ++ build from sz, tos ++ build to sz))
([], [])
l
strsEv = map (\(txts,_,_) -> mkEvolutionEaseQuart (Successive txts) duration) l
fromTosLF = maximum $ map (\(Evolution _ lf _ _) -> lf) strsEv
evAnchors@(Evolution _ anchorsLF _ _) =
mkEvolutionEaseQuart (Successive [SequentiallyInterpolatedList from_,
SequentiallyInterpolatedList to_]) duration
in TextAnimation strsEv evAnchors $ mkEaseClock duration (max anchorsLF fromTosLF) invQuartEaseInOut
mkSequentialTextTranslationsStringAnchored :: [([ColorString], Coords Pos, Coords Pos)]
-> Float
-> TextAnimation AnchorStrings
mkSequentialTextTranslationsStringAnchored l duration =
let (from_,to_) = unzip $ map (\(_,f,t) -> (f,t)) l
strsEv = map (\(txts,_,_) -> mkEvolutionEaseQuart (Successive txts) duration) l
fromTosLF = maximum $ map (\(Evolution _ lf _ _) -> lf) strsEv
evAnchors@(Evolution _ anchorsLF _ _) =
mkEvolutionEaseQuart (Successive [SequentiallyInterpolatedList from_,
SequentiallyInterpolatedList to_]) duration
in TextAnimation strsEv evAnchors $ mkEaseClock duration (max anchorsLF fromTosLF) invQuartEaseInOut
mkTextTranslation :: ColorString
-> Float
-> Coords Pos
-> Coords Pos
-> TextAnimation AnchorChars
mkTextTranslation text duration from to =
let sz = countChars text
strEv@(Evolution _ fromToLF _ _) = mkEvolutionEaseQuart (Successive [text]) duration
from_ = build from sz
to_ = build to sz
strsEv = [strEv]
fromTosLF = fromToLF
evAnchors@(Evolution _ anchorsLF _ _) =
mkEvolutionEaseQuart (Successive [SequentiallyInterpolatedList from_,
SequentiallyInterpolatedList to_]) duration
in TextAnimation strsEv evAnchors $ mkEaseClock duration (max anchorsLF fromTosLF) invQuartEaseInOut