From 2c277a7d3c25aa792c9d2d324b8e70296d4b453c Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Mon, 29 Apr 2019 16:44:20 -0400 Subject: WIP: Abandon GLWidget in favor of (non-working) MeshSketch design. --- MeshSketch.hs | 349 ++++++++++++++++++++-------------------------------------- mainObj.hs | 142 ++++-------------------- 2 files changed, 143 insertions(+), 348 deletions(-) diff --git a/MeshSketch.hs b/MeshSketch.hs index 9d49f93..9b75d9b 100644 --- a/MeshSketch.hs +++ b/MeshSketch.hs @@ -1,247 +1,140 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} module MeshSketch where +import Codec.Picture as Juicy +import Control.Concurrent import Control.Monad -import qualified Data.Aeson as JSON -import qualified Data.ByteString as SB -import Data.Coerce -import Data.Functor -import qualified Data.Map as Map -import qualified Data.Vector as V +import Data.Word +import Data.Function ((&)) import Data.IORef -import Foreign.C.Types -import GI.Gdk -import GI.GObject.Functions -import GI.Gtk hiding (IsWindow,windowFullscreen,windowUnfullscreen) +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.Objects +import GI.GLib.Constants +import qualified GI.Gtk as Gtk (main) +import GI.Gtk as Gtk hiding (main) +import LambdaCube.GL as LC +import LambdaCube.GL.Mesh as LC import Numeric.LinearAlgebra hiding ((<>)) -import LambdaCube.GL as LC -import LambdaCube.GL.Mesh as LC -import LambdaCube.GL.Data --- import LambdaCube.GL.Type as LC -import LambdaCube.IR +import System.Environment +import System.IO import System.IO.Error - -import CubeMap -import LambdaCube.GL.HMatrix () -import LambdaCube.Gtk +import Control.Exception + +import GLWidget +import LambdaCube.GL.HMatrix +import LambdaCubeWidget +import TimeKeeper +import LoadMesh +import InfinitePlane +import MtlParser (ObjMaterial(..)) import Matrix -data MeshMaker = MeshMaker - { mmWidget :: GLArea - , mmRealized :: IORef (Maybe State) +-- State created by uploadState. +data State = State + { stTimeKeeper :: TimeKeeper + , stTickCallback :: TickCallbackHandle } -data Camera = Camera - { camHeightAngle :: Float - , camTarget :: Vector Float - , camDirection :: Vector Float - , camDistance :: Float - , camWidth :: Float - , camHeight :: Float - , camUp :: Vector Float - , camWorldToScreen :: Maybe (Matrix Float) - , camScreenToWorld :: Maybe (Matrix Float) - } +addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text (ObjMaterial,TextureData) -> IO [LC.Object] +addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat) -> do + obj <- LC.addMeshToObjectArray storage slotName ["diffuseTexture","diffuseColor"] mesh + -- diffuseTexture and diffuseColor values can change on each model + case mat >>= flip Map.lookup mtlLib of + Nothing -> return () + Just (ObjMaterial{..},t) -> LC.updateObjectUniforms obj $ do + "diffuseTexture" @= return t -- set model's diffuse texture + "diffuseColor" @= let (r,g,b) = mtl_Kd in return (V4 r g b mtl_Tr) + return obj + + +uploadState :: IsWidget glarea => MeshData -> glarea -> GLStorage -> IO State +uploadState obj glarea storage = do + -- load OBJ geometry and material descriptions + (objMesh,mtlLib) <- uploadOBJToGPU obj + -- load materials textures + gpuMtlLib <- uploadMtlLib mtlLib + -- add OBJ to pipeline input + addOBJToObjectArray storage "objects" objMesh gpuMtlLib + -- grid plane + uploadMeshToGPU xzplane >>= addMeshToObjectArray storage "plane" [] + + -- setup FrameClock + tm <- newTimeKeeper + tickcb <- widgetAddTickCallback glarea (tick tm) + + return State + { stTimeKeeper = tm + , stTickCallback = tickcb + } -data State = State - { stCamera :: IORef Camera - , stSkyboxes :: Skyboxes - , stSkybox :: IORef Int - , stFullscreen :: IO () - , stPipeline :: Pipeline - , stSchema :: PipelineSchema - , stStorage :: GLStorage - , stRenderer :: GLRenderer - } +destroyState :: GLArea -> State -> IO () +destroyState glarea st = do + widgetRemoveTickCallback glarea (stTickCallback st) + +deg30 :: Float +deg30 = pi/6 + +setUniforms :: glctx -> GLStorage -> State -> IO () +setUniforms gl storage st = do + t <- (/ 10.0) <$> getSeconds (stTimeKeeper st) + let tf = realToFrac t :: Float + rot = rotMatrixZ (-tf) <> rotMatrixX (-tf) + pos = rot #> fromList [2,2,10] + up = rot #> fromList [0,1,0] + cam = lookat pos 0 up + aspect = 1 + proj = perspective 0.1 100 deg30 aspect + mvp = proj <> cam -initCamera :: Camera -initCamera = Camera - { camHeightAngle = pi/6 - , camTarget = fromList [0,0,0] - , camDirection = fromList [0,0,-1] - , camDistance = 10 - , camWidth = 0 - , camHeight = 0 - , camUp = fromList [0,1,0] - , camWorldToScreen = Nothing - , camScreenToWorld = Nothing - } + LC.updateUniforms storage $ do + "CameraPosition" @= return (pos :: Vector Float) + "ViewProjection" @= return (mvp :: Matrix Float) -viewProjection :: Camera -> (Camera,Matrix Float) -viewProjection c - | Just m <- camWorldToScreen c = (c,m) - | otherwise = (c { camWorldToScreen = Just m' }, m') - where - m' = proj <> cam - cam = lookat pos (camTarget c) (camUp c) - pos = camTarget c - scale (camDistance c) (camDirection c) - proj = perspective 0.1 100 (camHeightAngle c) (camWidth c / camHeight c) +data MeshSketch = MeshSketch + { mmWidget :: GLArea + , mmRealized :: IORef (Maybe Realized) + } +data Realized = Realized -new :: IO GLArea +new :: IO MeshSketch 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 - -loadPipeline :: IO (Either String (PipelineSchema,Pipeline)) -loadPipeline = do - pipelineDesc <- do - maybe (Left "Unable to parse meshsketch.json") Right . JSON.decodeStrict <$> SB.readFile "meshsketch.json" - `catchIOError` \e -> return $ Left (show e) - -- setup render data - let inputSchema = makeSchema $ do - defObjectArray "skypoints" Points $ do - "position" @: Attribute_V3F + m <- do + objName <- head . (++ ["cube.obj"]) <$> getArgs + mobj <- loadOBJ objName + mpipeline <- loadPipeline "hello_obj2.json" $ do + defObjectArray "objects" Triangles $ do + "position" @: Attribute_V4F + "normal" @: Attribute_V3F + "uvw" @: Attribute_V3F + defObjectArray "plane" Triangles $ do + "position" @: Attribute_V4F defUniforms $ do - "Cam" @: M44F - "Skybox" @: FTextureCube - return $ (,) inputSchema <$> pipelineDesc - - -onRealize :: MeshMaker -> IO () -onRealize mm@(MeshMaker w ref) = do - putStrLn "realize!" - readIORef ref >>= \case - Just st -> onUnrealize mm -- Shouldn't happen. - Nothing -> return () - set w [ #canFocus := True ] -- For keyboard events. - widgetAddEvents w - [ EventMaskPointerMotionMask - , EventMaskButtonPressMask - , EventMaskButtonReleaseMask - , EventMaskTouchMask - , EventMaskScrollMask - , EventMaskKeyPressMask -- , EventMaskKeyReleaseMask - ] - - Right (schema,pipeline) <- loadPipeline - - gLAreaMakeCurrent w - - storage <- allocStorage schema - -- upload state - renderer <- allocRenderer pipeline - compat <- setStorage renderer storage -- check schema compatibility - - cam <- newIORef initCamera - skyboxes <- loadSkyboxes - skybox <- newIORef 0 - Right ts <- skyboxLoad skyboxes 0 - skybox_id <- uploadCubeMapToGPU ts - mi <- LC.uploadMeshToGPU Mesh - { mAttributes = Map.singleton "position" $ A_V3F $ V.fromList - [ V3 0 0 (-1) - , V3 0 0 1 - , V3 0 (-1) 0 - , V3 0 1 0 - , V3 (-1) 0 0 - , V3 01 0 0 - ] - , mPrimitive = P_Points - } - LC.addMeshToObjectArray storage "skypoints" [] mi - LC.updateUniforms storage $ do - "Skybox" @= return skybox_id - Just pwidget <- get w #parent - Just parent <- get pwidget #window - toggle <- mkFullscreenToggle parent - let st = State - { stCamera = cam - , stSkyboxes = skyboxes - , stSkybox = skybox - , stFullscreen = toggle - , stPipeline = pipeline - , stSchema = schema - , stStorage = storage - , stRenderer = renderer + "CameraPosition" @: V3F + "ViewProjection" @: M44F + "diffuseTexture" @: FTexture2D + "diffuseColor" @: V4F + return $ (,) <$> mobj <*> mpipeline + either (\e _ -> hPutStrLn stderr e >> throwIO (userError e)) (&) m $ \(obj,pipeline) -> do + app <- do + mvar <- newEmptyMVar + return $ \glarea -> LCMethods + { lcRealized = mvar + , lcUploadState = uploadState obj glarea + , lcDestroyState = destroyState glarea + , lcSetUniforms = setUniforms + , lcPipeline = pipeline + } + + ref <- newIORef Nothing + glarea <- newGLWidget return (lambdaRender app glmethods) + return MeshSketch + { mmWidget = glarea + , mmRealized = ref } - - _ <- on w #event $ onEvent w st - _ <- on w #render $ onRender w st - writeIORef ref $ Just st - -onUnrealize :: MeshMaker -> IO () -onUnrealize (MeshMaker w ref) = do - putStrLn "unrealize!" - readIORef ref >>= \case - Just st -> do - -- signalHandlerDisconnect w (sigRender st) - -- signalHandlerDisconnect w (sigEvent st) - return () - Nothing -> return () -- Shouldn't happen. - writeIORef ref Nothing - - -onRender :: w -> State -> GLContext -> IO Bool -onRender w st gl = do - putStrLn "render" - mat_vp <- atomicModifyIORef' (stCamera st) viewProjection - r <- fixupRenderTarget (stRenderer st) - {- - let ks = Map.keys $ uniformSetup (stStorage st) - us = uniforms (stSchema st) - print (us,ks) - -} - LC.updateUniforms (stStorage st) $ do - "Cam" @= return mat_vp - -- todo Skybox texture - LC.renderFrame r - return True - -onEvent :: w -> State -> Event -> IO Bool -onEvent w st 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 () - - 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 - -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 diff --git a/mainObj.hs b/mainObj.hs index 970f94c..caf6501 100644 --- a/mainObj.hs +++ b/mainObj.hs @@ -1,127 +1,29 @@ -{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} module Main where -import Codec.Picture as Juicy -import Control.Concurrent -import Control.Monad -import Data.Word -import Data.Function -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.Objects -import GI.GLib.Constants -import GI.Gtk as Gtk hiding (main) -import LambdaCube.GL as LC -import LambdaCube.GL.Mesh as LC -import Numeric.LinearAlgebra hiding ((<>)) -import System.Environment -import System.IO -import System.IO.Error +import qualified GI.Gtk as Gtk (main) + ;import GI.Gtk as Gtk hiding (main) -import GLWidget -import LambdaCube.GL.HMatrix -import LambdaCubeWidget -import TimeKeeper -import LoadMesh -import InfinitePlane -import MtlParser (ObjMaterial(..)) -import Matrix - --- State created by uploadState. -data State = State - { stTimeKeeper :: TimeKeeper - , stTickCallback :: TickCallbackHandle - } - -addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text (ObjMaterial,TextureData) -> IO [LC.Object] -addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat) -> do - obj <- LC.addMeshToObjectArray storage slotName ["diffuseTexture","diffuseColor"] mesh - -- diffuseTexture and diffuseColor values can change on each model - case mat >>= flip Map.lookup mtlLib of - Nothing -> return () - Just (ObjMaterial{..},t) -> LC.updateObjectUniforms obj $ do - "diffuseTexture" @= return t -- set model's diffuse texture - "diffuseColor" @= let (r,g,b) = mtl_Kd in return (V4 r g b mtl_Tr) - return obj - - -uploadState :: IsWidget glarea => MeshData -> glarea -> GLStorage -> IO State -uploadState obj glarea storage = do - -- load OBJ geometry and material descriptions - (objMesh,mtlLib) <- uploadOBJToGPU obj - -- load materials textures - gpuMtlLib <- uploadMtlLib mtlLib - -- add OBJ to pipeline input - addOBJToObjectArray storage "objects" objMesh gpuMtlLib - -- grid plane - uploadMeshToGPU xzplane >>= addMeshToObjectArray storage "plane" [] - - -- setup FrameClock - tm <- newTimeKeeper - tickcb <- widgetAddTickCallback glarea (tick tm) - - return State - { stTimeKeeper = tm - , stTickCallback = tickcb - } - -destroyState :: GLArea -> State -> IO () -destroyState glarea st = do - widgetRemoveTickCallback glarea (stTickCallback st) - -deg30 :: Float -deg30 = pi/6 - -setUniforms :: glctx -> GLStorage -> State -> IO () -setUniforms gl storage st = do - t <- (/ 10.0) <$> getSeconds (stTimeKeeper st) - let tf = realToFrac t :: Float - rot = rotMatrixZ (-tf) <> rotMatrixX (-tf) - pos = rot #> fromList [2,2,10] - up = rot #> fromList [0,1,0] - cam = lookat pos 0 up - aspect = 1 - proj = perspective 0.1 100 deg30 aspect - mvp = proj <> cam - - LC.updateUniforms storage $ do - "CameraPosition" @= return (pos :: Vector Float) - "ViewProjection" @= return (mvp :: Matrix Float) +import qualified MeshSketch main :: IO () main = do - m <- do - objName <- head . (++ ["cube.obj"]) <$> getArgs - mobj <- loadOBJ objName - mpipeline <- loadPipeline "hello_obj2.json" $ do - defObjectArray "objects" Triangles $ do - "position" @: Attribute_V4F - "normal" @: Attribute_V3F - "uvw" @: Attribute_V3F - defObjectArray "plane" Triangles $ do - "position" @: Attribute_V4F - defUniforms $ do - "CameraPosition" @: V3F - "ViewProjection" @: M44F - "diffuseTexture" @: FTexture2D - "diffuseColor" @: V4F - return $ (,) <$> mobj <*> mpipeline - either (\e _ -> hPutStrLn stderr e) (&) m $ \(obj,pipeline) -> do - app <- do - mvar <- newEmptyMVar - return $ \glarea -> LCMethods - { lcRealized = mvar - , lcUploadState = uploadState obj glarea - , lcDestroyState = destroyState glarea - , lcSetUniforms = setUniforms - , lcPipeline = pipeline - } - - runGLApp return (lambdaRender app glmethods) - { glTitle = "LambdaCube 3D DSL OBJ viewer" - } + _ <- Gtk.init Nothing + + let mkChild = MeshSketch.mmWidget <$> MeshSketch.new + + window <- do + w <- Gtk.windowNew WindowTypeToplevel + windowSetDefaultSize w 720 720 + Gtk.windowSetTitle w "MeshSketch" + containerSetBorderWidth w 0 + _ <- on w #deleteEvent $ \_ -> mainQuit >> return True + child <- mkChild + containerAdd w child + return w + + widgetShowAll window + Gtk.main -- cgit v1.2.3