Animator utility.

1 files changed, 82 insertions, 0 deletions

diff --git a/Animator.hs b/Animator.hs
new file mode 100644
index 0000000..e51fc50
--- /dev/null
+++ b/Animator.hs
@@ -0,0 +1,82 @@
+{-# 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
+
+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
+