From a1cf451ede392fae4a7c594f18b699128c6875fe Mon Sep 17 00:00:00 2001
From: Joe Crayne <joe@jerkface.net>
Date: Mon, 29 Apr 2019 22:01:19 -0400
Subject: MeshSketch rework: events.

---
 MeshSketch.hs | 98 +++++++++++++++++++++++++++++++++++++++++++++++------------
 1 file changed, 79 insertions(+), 19 deletions(-)

(limited to 'MeshSketch.hs')

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
 import Control.Monad
 import Data.Word
 import Data.Function ((&))
+import Data.Functor ((<&>))
 import Data.Int
 import Data.IORef
 import Data.Text (Text)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import qualified Data.Vector     as V
+import GI.Gdk
 import GI.Gdk.Objects
 import GI.GLib.Constants
-import qualified GI.Gtk          as Gtk (main)
-import GI.Gtk                    as Gtk hiding (main)
+import GI.Gtk hiding (IsWindow,windowFullscreen,windowUnfullscreen)
 import LambdaCube.GL             as LC
 import LambdaCube.GL.Mesh        as LC
 import Numeric.LinearAlgebra hiding ((<>))
@@ -41,8 +42,9 @@ import Matrix
 
 -- State created by uploadState.
 data State = State
-    { stAnimator :: Animator
-    , stCamera   :: IORef Camera
+    { stAnimator   :: Animator
+    , stCamera     :: IORef Camera
+    , stFullscreen :: IO ()
     }
 
 data Camera = Camera
@@ -93,6 +95,13 @@ addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat)
       "diffuseColor" @= let (r,g,b) = mtl_Kd in return (V4 r g b mtl_Tr)
   return obj
 
+mkFullscreenToggle :: IsWindow a => a -> IO (IO ())
+mkFullscreenToggle w = do
+    full <- newIORef False
+    return $ do
+        b <- atomicModifyIORef' full $ \b -> (not b, not b)
+        if b then windowFullscreen w
+             else windowUnfullscreen w
 
 uploadState :: IsWidget glarea => MeshData -> glarea -> GLStorage -> IO State
 uploadState obj glarea storage = do
@@ -106,11 +115,18 @@ uploadState obj glarea storage = do
     uploadMeshToGPU xzplane >>= addMeshToObjectArray storage "plane" []
 
     -- setup FrameClock
-    tm <- newAnimator =<< toWidget glarea
+    w <- toWidget glarea
+    tm <- newAnimator w
     cam <- newIORef initCamera
+
+    Just pwidget <- get w #parent
+    Just parent <- get pwidget #window
+    toggle <- mkFullscreenToggle parent
+
     let st = State
             { stAnimator     = tm
             , stCamera       = cam
+            , stFullscreen   = toggle
             }
     _ <- addAnimation tm (whirlingCamera st)
 
@@ -140,16 +156,6 @@ whirlingCamera st = Animation $ \_ t -> do
 setUniforms :: glctx -> GLStorage -> State -> IO ()
 setUniforms gl storage st = do
     (mvp,pos) <- atomicModifyIORef' (stCamera st) viewProjection
-
-    {-
-    let pos = rot #> fromList [2,2,10]
-        up = rot #> fromList [0,1,0]
-        view = lookat pos 0 up
-        aspect = 1
-        proj = perspective 0.1 100 deg30 aspect
-        mvp = proj <> view
-    -}
-
     LC.updateUniforms storage $ do
       "CameraPosition" @= return (pos :: Vector Float)
       "ViewProjection" @= return (mvp :: Matrix Float)
@@ -192,8 +198,6 @@ new = do
             let mm = MeshSketch g ref
             gLAreaSetHasDepthBuffer g True
             st <- return g
-            -- _ <- on g #render        $ glRender w st
-            -- _ <- on g #resize        $ glResize w st
             _ <- on g #realize       $ withCurrentGL g (onRealize obj (dynamicPipeline pipeline) (dynamicSchema pipeline) mm)
             _ <- on g #unrealize     $ onUnrealize mm
             -- _ <- on g #createContext $ nullableContext (glCreateContext w st)
@@ -219,8 +223,19 @@ onRealize mesh pipeline schema mm = do
             , stRenderer = renderer
             , stState    = x
             }
-    _ <- on (mmWidget mm) #render $ onRender (mmWidget mm) r
-    _ <- on (mmWidget mm) #resize $ onResize (mmWidget mm) r
+        w = mmWidget mm
+    set w [ #canFocus := True ] -- For keyboard events.
+    widgetAddEvents w
+        [ EventMaskPointerMotionMask
+        , EventMaskButtonPressMask
+        , EventMaskButtonReleaseMask
+        , EventMaskTouchMask
+        , EventMaskScrollMask
+        , EventMaskKeyPressMask -- , EventMaskKeyReleaseMask
+        ]
+    _ <- on w #event  $ onEvent  w r
+    _ <- on w #render $ onRender w r
+    _ <- on w #resize $ onResize w r
     writeIORef (mmRealized mm) $ Just r
 
 onRender :: w -> Realized -> GLContext -> IO Bool
@@ -246,3 +261,48 @@ onResize glarea realized w h = do
                             , camHeight = fromIntegral ht
                             }
         LC.setScreenSize (stStorage realized) wd ht)
+
+onEvent :: w -> Realized -> Event -> IO Bool
+onEvent w realized ev = do
+    let st = stState realized
+    msrc <- eventGetSourceDevice ev
+    inputSource <- forM msrc $ \src -> do
+        src <- get src #inputSource
+        return src
+    etype <- get ev #type
+    -- putStrLn $ "onEvent! " ++ show (etype,inputSource)
+    let put x = putStrLn (show inputSource ++ " " ++ show x)
+    case etype of
+
+        EventTypeMotionNotify -> do
+            mev <- get ev #motion
+            x <- get mev #x
+            y <- get mev #y
+            put (x,y)
+            return ()
+
+        EventTypeScroll -> do
+            sev <- get ev #scroll
+            d <- get sev #direction
+            put d
+            return ()
+
+        EventTypeKeyPress -> do
+            kev <- get ev #key
+            val <- get kev #keyval <&> \k -> if k > 0x5A then k - 0x20 else k
+            case val of
+                {-
+                KEY_N -> do
+                    modifyIORef' (stSkybox st) $ \n -> (n + 1) `mod` (skyboxCount $ stSkyboxes st)
+                    idx <- readIORef (stSkybox st)
+                    put (skyboxNames (stSkyboxes st) !! idx)
+                    return ()
+                -}
+                KEY_F -> do
+                    put 'F'
+                    stFullscreen st
+                _ -> return ()
+
+        e -> return ()
+
+    return False
-- 
cgit v1.2.3