diff options
Diffstat (limited to 'LambdaHello.hs')
-rw-r--r-- | LambdaHello.hs | 40 |
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 | |||
3 | 3 | ||
4 | import GI.Gtk as Gtk | 4 | import GI.Gtk as Gtk |
5 | import GI.Gdk.Objects | 5 | import GI.Gdk.Objects |
6 | import GI.GLib.Constants | ||
6 | 7 | ||
8 | import Data.Int | ||
7 | import qualified Graphics.Rendering.OpenGL as GL | 9 | import qualified Graphics.Rendering.OpenGL as GL |
8 | import Data.Function | 10 | import Data.Function |
9 | import Control.Concurrent | 11 | import Control.Concurrent |
@@ -25,17 +27,23 @@ import Control.Monad.IO.Class | |||
25 | import qualified Unsafe.Coerce | 27 | import qualified Unsafe.Coerce |
26 | 28 | ||
27 | data State = State | 29 | data State = State |
28 | { stConfig :: Config | 30 | { stConfig :: Config |
29 | , stRealized :: MVar Realized | 31 | , stRealized :: MVar Realized |
32 | , stSeconds :: MVar Double | ||
33 | , stFirstFrame :: MVar Int64 | ||
30 | } | 34 | } |
31 | 35 | ||
32 | initState :: IO State | 36 | initState :: IO State |
33 | initState = do | 37 | initState = do |
34 | cfg <- either fail return =<< loadConfig | 38 | cfg <- either fail return =<< loadConfig |
35 | r <- newEmptyMVar | 39 | r <- newEmptyMVar |
40 | s <- newMVar 0.0 | ||
41 | ff <- newMVar 0 | ||
36 | return State | 42 | return State |
37 | { stConfig = cfg | 43 | { stConfig = cfg |
38 | , stRealized = r | 44 | , stRealized = r |
45 | , stSeconds = s | ||
46 | , stFirstFrame = ff | ||
39 | } | 47 | } |
40 | 48 | ||
41 | 49 | ||
@@ -69,12 +77,10 @@ render st w gl = do | |||
69 | -- print (wd,ht) | 77 | -- print (wd,ht) |
70 | return (fromIntegral wd,fromIntegral ht) | 78 | return (fromIntegral wd,fromIntegral ht) |
71 | LambdaCubeGL.setScreenSize (rStorage r) wd ht | 79 | LambdaCubeGL.setScreenSize (rStorage r) wd ht |
80 | t <- withMVar (stSeconds st) return | ||
72 | LambdaCubeGL.updateUniforms (rStorage r) $ do | 81 | LambdaCubeGL.updateUniforms (rStorage r) $ do |
73 | "diffuseTexture" @= return (rTexture r) | 82 | "diffuseTexture" @= return (rTexture r) |
74 | "time" @= do | 83 | "time" @= return (realToFrac t :: Float) |
75 | -- Just t <- GLFW.getTime | ||
76 | let t = 1.0 :: Double | ||
77 | return (realToFrac t :: Float) | ||
78 | 84 | ||
79 | -- putStrLn "render!" | 85 | -- putStrLn "render!" |
80 | -- GL.clearColor GL.$= GL.Color4 0 255 0 1 | 86 | -- GL.clearColor GL.$= GL.Color4 0 255 0 1 |
@@ -90,6 +96,20 @@ data Realized = Realized | |||
90 | , rRenderer :: GLRenderer | 96 | , rRenderer :: GLRenderer |
91 | } | 97 | } |
92 | 98 | ||
99 | tick :: State -> Widget -> FrameClock -> IO Bool | ||
100 | tick st w clock = do | ||
101 | Just win <- widgetGetWindow w | ||
102 | windowInvalidateRect win Nothing False | ||
103 | micros <- frameClockGetFrameTime clock | ||
104 | ff <- modifyMVar (stFirstFrame st) $ \prev -> | ||
105 | if prev == 0 then return (micros, micros) | ||
106 | else return (prev, prev) | ||
107 | secs <- modifyMVar (stSeconds st) $ \_ -> do | ||
108 | let secs = fromIntegral (micros - ff) / 1000000.0 | ||
109 | return (secs,secs) | ||
110 | -- putStrLn $ "tick! " ++ show (micros,secs) | ||
111 | return SOURCE_CONTINUE | ||
112 | |||
93 | realize :: State -> GLArea -> IO () | 113 | realize :: State -> GLArea -> IO () |
94 | realize st w = gLAreaMakeCurrent w >> gLAreaGetError w >>= \me -> maybe id (\e _ -> print e) me $ do | 114 | realize st w = gLAreaMakeCurrent w >> gLAreaGetError w >>= \me -> maybe id (\e _ -> print e) me $ do |
95 | let cfg = stConfig st | 115 | let cfg = stConfig st |
@@ -112,7 +132,9 @@ realize st w = gLAreaMakeCurrent w >> gLAreaGetError w >>= \me -> maybe id (\e _ | |||
112 | putMVar (stRealized st) $ Realized storage texture renderer | 132 | putMVar (stRealized st) $ Realized storage texture renderer |
113 | -- GL.flush | 133 | -- GL.flush |
114 | putStrLn "realize!" | 134 | putStrLn "realize!" |
115 | maybe id (\e _ -> putStrLn e) compat $ return () | 135 | maybe id (\e _ -> putStrLn e) compat $ do |
136 | tickcb <- widgetAddTickCallback w (tick st) | ||
137 | return () | ||
116 | 138 | ||
117 | 139 | ||
118 | unrealize :: State -> GLArea -> IO () | 140 | unrealize :: State -> GLArea -> IO () |