{-# 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