{-# LANGUAGE RankNTypes #-}
module Reanimate.Scene where
import Control.Monad.ST
import Control.Monad.ST.Unsafe
import Data.IORef
import Data.Map (Map)
import qualified Data.Map as Map
import Data.STRef
import Debug.Trace
import Data.Ord
import Data.List
import System.IO.Unsafe
import System.Mem.StableName
import Reanimate.Monad
data World
type ZIndex = Int
type Timeline = [(Time, Animation, ZIndex)]
newtype Scene s a = M { unM :: Time -> ST s (a, Duration, Duration, Timeline) }
unionTimeline :: Timeline -> Timeline -> Timeline
unionTimeline = (++)
emptyTimeline :: Timeline
emptyTimeline = []
instance Functor (Scene s) where
fmap f action = M $ \t -> do
(a, d1, d2, tl) <- unM action t
return (f a, d1, d2, tl)
instance Applicative (Scene s) where
pure a = M $ \_ -> return (a, 0, 0, emptyTimeline)
f <*> g = M $ \t -> do
(f', s1, p1, tl1) <- unM f t
(g', s2, p2, tl2) <- unM g (t+s1)
return (f' g', s1+s2, max p1 (s1+p2), unionTimeline tl1 tl2)
instance Monad (Scene s) where
return = pure
f >>= g = M $ \t -> do
(a, s1, p1, tl1) <- unM f t
(b, s2, p2, tl2) <- unM (g a) (t+s1)
return (b, s1+s2, max p1 (s1+p2), unionTimeline tl1 tl2)
sceneAnimation :: (forall s. Scene s a) -> Animation
sceneAnimation action = Animation (max s p) $ Frame $ \d t ->
sequence_ $ map snd $ sortBy (comparing fst)
[ (z, unFrame frameGen dur (t-startT))
| (startT, Animation dur frameGen, z) <- tl
, startT < t
, startT+dur > t
]
where
(_, s, p, tl) = runST (unM action 0)
debug :: String -> Scene s ()
debug msg = M $ \t -> trace msg (return ((), 0, 0, emptyTimeline))
someaction :: Scene s ()
someaction = debug "someaction"
fork :: Scene s a -> Scene s a
fork (M action) = M $ \t -> do
(a, s, p, tl) <- action t
return (a, 0, max s p, tl)
play :: Animation -> Scene s ()
play = playZ 0
playZ :: ZIndex -> Animation -> Scene s ()
playZ z ani = M $ \t -> do
let d = duration ani
return ((), d, 0, [(t, ani, z)])
queryNow :: Scene s Time
queryNow = M $ \t -> return (t, 0, 0, emptyTimeline)
waitAll :: Scene s a -> Scene s a
waitAll (M action) = M $ \t -> do
(a, s, p, tl) <- action t
return (a, max s p, 0, tl)
waitUntil :: Time -> Scene s ()
waitUntil tNew = do
now <- queryNow
wait (max 0 (tNew - now))
wait :: Duration -> Scene s ()
wait d = M $ \t ->
return ((), d, 0, emptyTimeline)
adjustZ :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a
adjustZ fn (M action) = M $ \t -> do
(a, s, p, tl) <- action t
return (a, s, p, [ (startT, ani, fn z) | (startT, ani, z) <- tl ])
withSceneDuration :: Scene s a -> Scene s Duration
withSceneDuration s = do
t1 <- queryNow
s
t2 <- queryNow
return (t2-t1)