Animate GLArea.

1 files changed, 31 insertions, 9 deletions

diff --git a/LambdaHello.hs b/LambdaHello.hs
index 3c15a12..78d4f0d 100644
--- a/LambdaHello.hs
+++ b/LambdaHello.hs
@@ -3,7 +3,9 @@ module LambdaHello where
 
 import GI.Gtk as Gtk
 import GI.Gdk.Objects
+import GI.GLib.Constants
 
+import Data.Int
 import qualified Graphics.Rendering.OpenGL as GL
 import Data.Function
 import Control.Concurrent
@@ -25,17 +27,23 @@ import Control.Monad.IO.Class
 import qualified Unsafe.Coerce
 
 data State = State
-    { stConfig   :: Config
-    , stRealized :: MVar Realized
+    { stConfig     :: Config
+    , stRealized   :: MVar Realized
+    , stSeconds    :: MVar Double
+    , stFirstFrame :: MVar Int64
     }
 
 initState :: IO State
 initState = do
     cfg <- either fail return =<< loadConfig
     r <- newEmptyMVar
+    s <- newMVar 0.0
+    ff <- newMVar 0
     return State
-        { stConfig   = cfg
-        , stRealized = r
+        { stConfig     = cfg
+        , stRealized   = r
+        , stSeconds    = s
+        , stFirstFrame = ff
         }
 
 
@@ -69,12 +77,10 @@ render st w gl = do
                       -- print (wd,ht)
                       return (fromIntegral wd,fromIntegral ht)
         LambdaCubeGL.setScreenSize (rStorage r) wd ht
+        t <- withMVar (stSeconds st) return
         LambdaCubeGL.updateUniforms (rStorage r) $ do
           "diffuseTexture" @= return (rTexture r)
-          "time" @= do
-                      -- Just t <- GLFW.getTime
-                      let t = 1.0 :: Double
-                      return (realToFrac t :: Float)
+          "time" @= return (realToFrac t :: Float)
 
         -- putStrLn "render!"
         -- GL.clearColor GL.$= GL.Color4 0 255 0 1
@@ -90,6 +96,20 @@ data Realized = Realized
     , rRenderer :: GLRenderer
     }
 
+tick :: State -> Widget -> FrameClock -> IO Bool
+tick st w clock = do
+    Just win <- widgetGetWindow w
+    windowInvalidateRect win Nothing False
+    micros <- frameClockGetFrameTime clock
+    ff <- modifyMVar (stFirstFrame st) $ \prev ->
+        if prev == 0 then return (micros, micros)
+                     else return (prev, prev)
+    secs <- modifyMVar (stSeconds st) $ \_ -> do
+        let secs = fromIntegral (micros - ff) / 1000000.0
+        return (secs,secs)
+    -- putStrLn $ "tick! " ++ show (micros,secs)
+    return SOURCE_CONTINUE
+
 realize :: State -> GLArea -> IO ()
 realize st w = gLAreaMakeCurrent w >> gLAreaGetError w >>= \me -> maybe id (\e _ -> print e) me $ do
     let cfg = stConfig st
@@ -112,7 +132,9 @@ realize st w = gLAreaMakeCurrent w >> gLAreaGetError w >>= \me -> maybe id (\e _
     putMVar (stRealized st) $ Realized storage texture renderer
     -- GL.flush
     putStrLn "realize!"
-    maybe id (\e _ -> putStrLn e) compat $ return ()
+    maybe id (\e _ -> putStrLn e) compat $ do
+    tickcb <- widgetAddTickCallback w (tick st)
+    return ()
 
 
 unrealize :: State -> GLArea -> IO ()