From 98d08f9b94840c442d3352be6f1cd3f4c76c33c6 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Fri, 26 Apr 2019 12:27:56 -0400 Subject: Renamed MeshMaker to MeshSketch. --- MeshMaker.hs | 115 ---------------------------------------------------------- MeshSketch.hs | 115 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ mainObj2.hs | 6 +-- 3 files changed, 118 insertions(+), 118 deletions(-) delete mode 100644 MeshMaker.hs create mode 100644 MeshSketch.hs diff --git a/MeshMaker.hs b/MeshMaker.hs deleted file mode 100644 index 6b7477a..0000000 --- a/MeshMaker.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedLabels #-} -module MeshMaker 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 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 diff --git a/mainObj2.hs b/mainObj2.hs index 7695120..909af2c 100644 --- a/mainObj2.hs +++ b/mainObj2.hs @@ -10,18 +10,18 @@ import Data.GI.Base.GType import Foreign.Ptr -import qualified MeshMaker +import qualified MeshSketch main = do _ <- Gtk.init Nothing - let mkChild = MeshMaker.new + let mkChild = MeshSketch.new window <- do w <- windowNew WindowTypeToplevel windowSetDefaultSize w 360 360 - windowSetTitle w "Mesh Maker" + windowSetTitle w "MeshSketch" _ <- on w #deleteEvent $ \_ -> mainQuit >> return True child <- mkChild containerAdd w child -- cgit v1.2.3