diff options
Diffstat (limited to 'MeshSketch.hs')
-rw-r--r-- | MeshSketch.hs | 98 |
1 files changed, 79 insertions, 19 deletions
diff --git a/MeshSketch.hs b/MeshSketch.hs index 7d0392f..1408710 100644 --- a/MeshSketch.hs +++ b/MeshSketch.hs | |||
@@ -9,16 +9,17 @@ import Control.Concurrent | |||
9 | import Control.Monad | 9 | import Control.Monad |
10 | import Data.Word | 10 | import Data.Word |
11 | import Data.Function ((&)) | 11 | import Data.Function ((&)) |
12 | import Data.Functor ((<&>)) | ||
12 | import Data.Int | 13 | import Data.Int |
13 | import Data.IORef | 14 | import Data.IORef |
14 | import Data.Text (Text) | 15 | import Data.Text (Text) |
15 | import Data.Map.Strict (Map) | 16 | import Data.Map.Strict (Map) |
16 | import qualified Data.Map.Strict as Map | 17 | import qualified Data.Map.Strict as Map |
17 | import qualified Data.Vector as V | 18 | import qualified Data.Vector as V |
19 | import GI.Gdk | ||
18 | import GI.Gdk.Objects | 20 | import GI.Gdk.Objects |
19 | import GI.GLib.Constants | 21 | import GI.GLib.Constants |
20 | import qualified GI.Gtk as Gtk (main) | 22 | import GI.Gtk hiding (IsWindow,windowFullscreen,windowUnfullscreen) |
21 | import GI.Gtk as Gtk hiding (main) | ||
22 | import LambdaCube.GL as LC | 23 | import LambdaCube.GL as LC |
23 | import LambdaCube.GL.Mesh as LC | 24 | import LambdaCube.GL.Mesh as LC |
24 | import Numeric.LinearAlgebra hiding ((<>)) | 25 | import Numeric.LinearAlgebra hiding ((<>)) |
@@ -41,8 +42,9 @@ import Matrix | |||
41 | 42 | ||
42 | -- State created by uploadState. | 43 | -- State created by uploadState. |
43 | data State = State | 44 | data State = State |
44 | { stAnimator :: Animator | 45 | { stAnimator :: Animator |
45 | , stCamera :: IORef Camera | 46 | , stCamera :: IORef Camera |
47 | , stFullscreen :: IO () | ||
46 | } | 48 | } |
47 | 49 | ||
48 | data Camera = Camera | 50 | data Camera = Camera |
@@ -93,6 +95,13 @@ addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat) | |||
93 | "diffuseColor" @= let (r,g,b) = mtl_Kd in return (V4 r g b mtl_Tr) | 95 | "diffuseColor" @= let (r,g,b) = mtl_Kd in return (V4 r g b mtl_Tr) |
94 | return obj | 96 | return obj |
95 | 97 | ||
98 | mkFullscreenToggle :: IsWindow a => a -> IO (IO ()) | ||
99 | mkFullscreenToggle w = do | ||
100 | full <- newIORef False | ||
101 | return $ do | ||
102 | b <- atomicModifyIORef' full $ \b -> (not b, not b) | ||
103 | if b then windowFullscreen w | ||
104 | else windowUnfullscreen w | ||
96 | 105 | ||
97 | uploadState :: IsWidget glarea => MeshData -> glarea -> GLStorage -> IO State | 106 | uploadState :: IsWidget glarea => MeshData -> glarea -> GLStorage -> IO State |
98 | uploadState obj glarea storage = do | 107 | uploadState obj glarea storage = do |
@@ -106,11 +115,18 @@ uploadState obj glarea storage = do | |||
106 | uploadMeshToGPU xzplane >>= addMeshToObjectArray storage "plane" [] | 115 | uploadMeshToGPU xzplane >>= addMeshToObjectArray storage "plane" [] |
107 | 116 | ||
108 | -- setup FrameClock | 117 | -- setup FrameClock |
109 | tm <- newAnimator =<< toWidget glarea | 118 | w <- toWidget glarea |
119 | tm <- newAnimator w | ||
110 | cam <- newIORef initCamera | 120 | cam <- newIORef initCamera |
121 | |||
122 | Just pwidget <- get w #parent | ||
123 | Just parent <- get pwidget #window | ||
124 | toggle <- mkFullscreenToggle parent | ||
125 | |||
111 | let st = State | 126 | let st = State |
112 | { stAnimator = tm | 127 | { stAnimator = tm |
113 | , stCamera = cam | 128 | , stCamera = cam |
129 | , stFullscreen = toggle | ||
114 | } | 130 | } |
115 | _ <- addAnimation tm (whirlingCamera st) | 131 | _ <- addAnimation tm (whirlingCamera st) |
116 | 132 | ||
@@ -140,16 +156,6 @@ whirlingCamera st = Animation $ \_ t -> do | |||
140 | setUniforms :: glctx -> GLStorage -> State -> IO () | 156 | setUniforms :: glctx -> GLStorage -> State -> IO () |
141 | setUniforms gl storage st = do | 157 | setUniforms gl storage st = do |
142 | (mvp,pos) <- atomicModifyIORef' (stCamera st) viewProjection | 158 | (mvp,pos) <- atomicModifyIORef' (stCamera st) viewProjection |
143 | |||
144 | {- | ||
145 | let pos = rot #> fromList [2,2,10] | ||
146 | up = rot #> fromList [0,1,0] | ||
147 | view = lookat pos 0 up | ||
148 | aspect = 1 | ||
149 | proj = perspective 0.1 100 deg30 aspect | ||
150 | mvp = proj <> view | ||
151 | -} | ||
152 | |||
153 | LC.updateUniforms storage $ do | 159 | LC.updateUniforms storage $ do |
154 | "CameraPosition" @= return (pos :: Vector Float) | 160 | "CameraPosition" @= return (pos :: Vector Float) |
155 | "ViewProjection" @= return (mvp :: Matrix Float) | 161 | "ViewProjection" @= return (mvp :: Matrix Float) |
@@ -192,8 +198,6 @@ new = do | |||
192 | let mm = MeshSketch g ref | 198 | let mm = MeshSketch g ref |
193 | gLAreaSetHasDepthBuffer g True | 199 | gLAreaSetHasDepthBuffer g True |
194 | st <- return g | 200 | st <- return g |
195 | -- _ <- on g #render $ glRender w st | ||
196 | -- _ <- on g #resize $ glResize w st | ||
197 | _ <- on g #realize $ withCurrentGL g (onRealize obj (dynamicPipeline pipeline) (dynamicSchema pipeline) mm) | 201 | _ <- on g #realize $ withCurrentGL g (onRealize obj (dynamicPipeline pipeline) (dynamicSchema pipeline) mm) |
198 | _ <- on g #unrealize $ onUnrealize mm | 202 | _ <- on g #unrealize $ onUnrealize mm |
199 | -- _ <- on g #createContext $ nullableContext (glCreateContext w st) | 203 | -- _ <- on g #createContext $ nullableContext (glCreateContext w st) |
@@ -219,8 +223,19 @@ onRealize mesh pipeline schema mm = do | |||
219 | , stRenderer = renderer | 223 | , stRenderer = renderer |
220 | , stState = x | 224 | , stState = x |
221 | } | 225 | } |
222 | _ <- on (mmWidget mm) #render $ onRender (mmWidget mm) r | 226 | w = mmWidget mm |
223 | _ <- on (mmWidget mm) #resize $ onResize (mmWidget mm) r | 227 | set w [ #canFocus := True ] -- For keyboard events. |
228 | widgetAddEvents w | ||
229 | [ EventMaskPointerMotionMask | ||
230 | , EventMaskButtonPressMask | ||
231 | , EventMaskButtonReleaseMask | ||
232 | , EventMaskTouchMask | ||
233 | , EventMaskScrollMask | ||
234 | , EventMaskKeyPressMask -- , EventMaskKeyReleaseMask | ||
235 | ] | ||
236 | _ <- on w #event $ onEvent w r | ||
237 | _ <- on w #render $ onRender w r | ||
238 | _ <- on w #resize $ onResize w r | ||
224 | writeIORef (mmRealized mm) $ Just r | 239 | writeIORef (mmRealized mm) $ Just r |
225 | 240 | ||
226 | onRender :: w -> Realized -> GLContext -> IO Bool | 241 | onRender :: w -> Realized -> GLContext -> IO Bool |
@@ -246,3 +261,48 @@ onResize glarea realized w h = do | |||
246 | , camHeight = fromIntegral ht | 261 | , camHeight = fromIntegral ht |
247 | } | 262 | } |
248 | LC.setScreenSize (stStorage realized) wd ht) | 263 | LC.setScreenSize (stStorage realized) wd ht) |
264 | |||
265 | onEvent :: w -> Realized -> Event -> IO Bool | ||
266 | onEvent w realized ev = do | ||
267 | let st = stState realized | ||
268 | msrc <- eventGetSourceDevice ev | ||
269 | inputSource <- forM msrc $ \src -> do | ||
270 | src <- get src #inputSource | ||
271 | return src | ||
272 | etype <- get ev #type | ||
273 | -- putStrLn $ "onEvent! " ++ show (etype,inputSource) | ||
274 | let put x = putStrLn (show inputSource ++ " " ++ show x) | ||
275 | case etype of | ||
276 | |||
277 | EventTypeMotionNotify -> do | ||
278 | mev <- get ev #motion | ||
279 | x <- get mev #x | ||
280 | y <- get mev #y | ||
281 | put (x,y) | ||
282 | return () | ||
283 | |||
284 | EventTypeScroll -> do | ||
285 | sev <- get ev #scroll | ||
286 | d <- get sev #direction | ||
287 | put d | ||
288 | return () | ||
289 | |||
290 | EventTypeKeyPress -> do | ||
291 | kev <- get ev #key | ||
292 | val <- get kev #keyval <&> \k -> if k > 0x5A then k - 0x20 else k | ||
293 | case val of | ||
294 | {- | ||
295 | KEY_N -> do | ||
296 | modifyIORef' (stSkybox st) $ \n -> (n + 1) `mod` (skyboxCount $ stSkyboxes st) | ||
297 | idx <- readIORef (stSkybox st) | ||
298 | put (skyboxNames (stSkyboxes st) !! idx) | ||
299 | return () | ||
300 | -} | ||
301 | KEY_F -> do | ||
302 | put 'F' | ||
303 | stFullscreen st | ||
304 | _ -> return () | ||
305 | |||
306 | e -> return () | ||
307 | |||
308 | return False | ||