1 files changed, 115 insertions, 0 deletions

diff --git a/MeshSketch.hs b/MeshSketch.hs
new file mode 100644
index 0000000..e23820c
--- /dev/null
+++ b/MeshSketch.hs
@@ -0,0 +1,115 @@
+{-# LANGUAGE LambdaCase       #-}
+{-# LANGUAGE OverloadedLabels #-}
+module MeshSketch where
+
+import Control.Monad
+import Data.Coerce
+import Data.IORef
+import Foreign.C.Types
+import GI.Gdk
+import GI.GObject.Functions
+import GI.Gtk
+import Numeric.LinearAlgebra
+
+data MeshMaker = MeshMaker
+    { mmWidget   :: GLArea
+    , mmRealized :: IORef (Maybe State)
+    }
+
+data Camera = Camera
+    { camHeightAngle   :: Float
+    , camTarget        :: Vector Float
+    , camDirection     :: Vector Float
+    , camDistance      :: Float
+    , camWidth         :: Float
+    , camHeight        :: Float
+    , camWorldToScreen :: Maybe (Matrix Float)
+    , camScreenToWorld :: Maybe (Matrix Float)
+    }
+
+data State = State
+    { stCamera :: IORef Camera
+    }
+
+initCamera = Camera
+    { camHeightAngle = pi/6
+    , camTarget      = fromList [0,0,0]
+    , camDirection   = fromList [0,0,-1]
+    , camDistance    = 10
+    , camWidth       = 0
+    , camHeight      = 0
+    , camWorldToScreen = Nothing
+    , camScreenToWorld = Nothing
+    }
+
+new :: IO GLArea
+new = do
+    w <- gLAreaNew
+    ref <- newIORef Nothing
+    let mm = MeshMaker w ref
+    -- _ <- on w #createContext $ onCreateContext mm
+    _ <- on w #realize   $ onRealize mm
+    _ <- on w #unrealize $ onUnrealize mm
+    -- _ <- on w #destroy $ onDestroy mm
+    return w
+
+onRealize :: MeshMaker -> IO ()
+onRealize mm@(MeshMaker w ref) = do
+    putStrLn "realize!"
+    readIORef ref >>= \case
+        Just st -> onUnrealize mm -- Shouldn't happen.
+        Nothing -> return ()
+    widgetAddEvents w
+        [ EventMaskPointerMotionMask
+        , EventMaskButtonPressMask
+        , EventMaskButtonReleaseMask
+        , EventMaskTouchMask
+        , EventMaskScrollMask
+        ]
+    _ <- on w #event $ onEvent mm
+    cam <- newIORef initCamera
+    writeIORef ref $ Just State
+        { stCamera = cam
+        }
+
+onUnrealize :: MeshMaker -> IO ()
+onUnrealize (MeshMaker w ref) = do
+    putStrLn "unrealize!"
+    readIORef ref >>= \case
+        Just st -> do
+            return ()
+        Nothing -> return () -- Shouldn't happen.
+    writeIORef ref Nothing
+
+
+onRender :: MeshMaker -> GLContext -> IO Bool
+onRender (MeshMaker w ref) gl = do
+    return True
+
+
+onEvent mm@(MeshMaker w ref) ev = do
+    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 ()
+
+        _ -> return ()
+
+    return False