From cffec1ebd78808154e98b6f3ec46578372a1331f Mon Sep 17 00:00:00 2001
From: Joe Crayne <joe@jerkface.net>
Date: Fri, 26 Apr 2019 20:24:50 -0400
Subject: Lambdacube code for MeshSketch.

---
 MeshSketch.hs | 47 +++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 45 insertions(+), 2 deletions(-)

(limited to 'MeshSketch.hs')

diff --git a/MeshSketch.hs b/MeshSketch.hs
index 331d435..30d14b7 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -4,6 +4,8 @@
 module MeshSketch where
 
 import Control.Monad
+import qualified Data.Aeson as JSON
+import qualified Data.ByteString as SB
 import Data.Coerce
 import Data.Functor
 import Data.IORef
@@ -12,7 +14,11 @@ import GI.Gdk
 import GI.GObject.Functions
 import GI.Gtk hiding (IsWindow,windowFullscreen,windowUnfullscreen)
 import Numeric.LinearAlgebra
+import LambdaCube.GL as LC
+import LambdaCube.IR
+import System.IO.Error
 
+import LambdaCube.Gtk
 import CubeMap
 
 data MeshMaker = MeshMaker
@@ -36,6 +42,10 @@ data State = State
     , stSkyboxes   :: Skyboxes
     , stSkybox     :: IORef Int
     , stFullscreen :: IO ()
+    , stPipeline   :: Pipeline
+    , stSchema     :: PipelineSchema
+    , stStorage    :: GLStorage
+    , stRenderer   :: GLRenderer
     }
 
 initCamera :: Camera
@@ -61,6 +71,18 @@ new = do
     -- _ <- 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
+    return $ (,) inputSchema <$> pipelineDesc
+
+
 onRealize :: MeshMaker -> IO ()
 onRealize mm@(MeshMaker w ref) = do
     putStrLn "realize!"
@@ -76,6 +98,16 @@ onRealize mm@(MeshMaker w ref) = do
         , 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
@@ -87,9 +119,14 @@ onRealize mm@(MeshMaker w ref) = do
             , stSkyboxes   = skyboxes
             , stSkybox     = skybox
             , stFullscreen = toggle
+            , stPipeline   = pipeline
+            , stSchema     = schema
+            , stStorage    = storage
+            , stRenderer   = renderer
             }
 
     _ <- on w #event $ onEvent w st
+    _ <- on w #render $ onRender w st
     writeIORef ref $ Just st
 
 onUnrealize :: MeshMaker -> IO ()
@@ -97,13 +134,19 @@ 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 :: MeshMaker -> GLContext -> IO Bool
-onRender (MeshMaker w ref) gl = do
+onRender :: w -> State -> GLContext -> IO Bool
+onRender w st gl = do
+    putStrLn "render"
+    r <- fixupRenderTarget (stRenderer st)
+    --  lcSetUniforms lc gl s x
+    LC.renderFrame r
     return True
 
 onEvent :: w -> State -> Event -> IO Bool
-- 
cgit v1.2.3