1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
module Animator where
import Control.Monad
import Data.Int
import qualified Data.IntMap as IntMap
;import Data.IntMap (IntMap)
import Data.IORef
import Data.Word
import GI.Gtk as Gtk
import GI.Gdk.Objects
import GI.GLib.Constants (pattern SOURCE_CONTINUE,pattern SOURCE_REMOVE)
-- | Type alias to mark a value returned by 'widgetAddTickCallback'.
type TickCallbackHandle = Word32
data Animator = Animator
{ tmSeconds :: IORef Double
, tmFirstFrame :: IORef Int64
, tmCallback :: IORef (Maybe TickCallbackHandle)
, tmAnimations :: IORef (IntMap Animation)
, tmAnimationCounter :: IORef Int
, tmWidget :: Widget
}
-- | An animation is an action that updates some state based on elapsing time.
-- The first argument is the elapsed seconds since the prior call (or zero the
-- first time) and the second argument is the current seconds elapsed since the
-- first tick.
--
-- When the animation is done, Nothing is returned. Otherwise itself or a
-- replacement action is returned to be invoked at the next frame.
newtype Animation = Animation (Double -> Double -> IO (Maybe Animation))
newAnimator :: Widget -> IO Animator
newAnimator w = do
s <- newIORef 0.0
ff <- newIORef 0
cb <- newIORef Nothing
as <- newIORef IntMap.empty
cnt <- newIORef 0
return $ Animator s ff cb as cnt w
getSeconds :: Animator -> IO Double
getSeconds tk = readIORef (tmSeconds tk)
addAnimation :: Animator -> Animation -> IO Int
addAnimation tm action = do
k <- atomicModifyIORef' (tmAnimationCounter tm) $ \x -> (succ x, x)
m <- atomicModifyIORef' (tmAnimations tm) $ \m -> (IntMap.insert k action m,m)
when (IntMap.null m) $ do
cb <- widgetAddTickCallback (tmWidget tm) (tick tm)
writeIORef (tmCallback tm) (Just cb)
return k
removeAnimation :: Animator -> Int -> IO ()
removeAnimation tm k = do
m <- atomicModifyIORef' (tmAnimations tm) $ \m -> (IntMap.delete k m, m)
when (IntMap.null $ IntMap.delete k m) $ do
mcb <- readIORef (tmCallback tm)
mapM_ (widgetRemoveTickCallback $ tmWidget tm) mcb
writeIORef (tmCallback tm) Nothing
tick :: Animator -> Widget -> FrameClock -> IO Bool
tick tm widget clock = widgetGetWindow widget >>= \case
Nothing -> do writeIORef (tmCallback tm) Nothing
return SOURCE_REMOVE
Just win -> do
windowInvalidateRect win Nothing False
micros <- frameClockGetFrameTime clock
ff <- atomicModifyIORef' (tmFirstFrame tm) $ \prev ->
if prev == 0 then (micros, micros)
else (prev, prev)
(prior,secs) <- atomicModifyIORef' (tmSeconds tm) $ \prior -> do
let secs = fromIntegral (micros - ff) / 1000000.0
in (secs,(prior,secs))
let delta | prior==0 = 0
| otherwise = secs - prior
as <- readIORef (tmAnimations tm)
as' <- mapM (\(Animation f) -> f delta secs) as
let as'' = IntMap.mapMaybe id as'
writeIORef (tmAnimations tm) as''
if IntMap.null as''
then do writeIORef (tmCallback tm) Nothing
return SOURCE_REMOVE
else return SOURCE_CONTINUE
|
