From d04c6fb9334493b9afa23bc7df2cddbae7fd4903 Mon Sep 17 00:00:00 2001
From: Joe Crayne <joe@jerkface.net>
Date: Mon, 29 Apr 2019 17:33:10 -0400
Subject: Continued rework toward MeshSketch design.

---
 MeshSketch.hs | 80 ++++++++++++++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 65 insertions(+), 15 deletions(-)

diff --git a/MeshSketch.hs b/MeshSketch.hs
index 9b75d9b..c56d34f 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -9,6 +9,7 @@ import Control.Concurrent
 import Control.Monad
 import Data.Word
 import Data.Function ((&))
+import Data.Int
 import Data.IORef
 import Data.Text (Text)
 import Data.Map.Strict (Map)
@@ -25,10 +26,13 @@ import System.Environment
 import System.IO
 import System.IO.Error
 import Control.Exception
+import LambdaCube.GL as LC
+import LambdaCube.IR as LC
+import LambdaCube.Gtk
 
-import GLWidget
+import GLWidget (nullableContext, withCurrentGL)
 import LambdaCube.GL.HMatrix
-import LambdaCubeWidget
+import LambdaCubeWidget (loadPipeline,DynamicPipeline(..))
 import TimeKeeper
 import LoadMesh
 import InfinitePlane
@@ -102,6 +106,10 @@ data MeshSketch = MeshSketch
     }
 
 data Realized = Realized
+    { stStorage  :: GLStorage
+    , stRenderer :: GLRenderer
+    , stState    :: State
+    }
 
 new :: IO MeshSketch
 new = do
@@ -122,19 +130,61 @@ new = do
             "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
+        -- glarea <- newGLWidget return (lambdaRender app glmethods)
+        do
+            g <- gLAreaNew
+            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)
+            return mm
+
+onUnrealize :: MeshSketch -> IO ()
+onUnrealize mm = do
+    m <- readIORef (mmRealized mm)
+    forM_ m $ \st -> do
+        LC.disposeStorage (stStorage st)
+        LC.disposeRenderer (stRenderer st)
+        -- lcDestroyState lc x
+
+onRealize :: MeshData -> Pipeline -> PipelineSchema -> MeshSketch -> IO ()
+onRealize mesh pipeline schema mm = do
+    onUnrealize mm
+    storage <- LC.allocStorage schema
+    renderer <- LC.allocRenderer pipeline
+    compat <- LC.setStorage renderer storage -- check schema compatibility
+    x <- uploadState mesh (mmWidget mm) storage
+    let r = Realized
+            { stStorage  = storage
+            , stRenderer = renderer
+            , stState    = x
             }
+    _ <- on (mmWidget mm) #render $ onRender (mmWidget mm) r
+    _ <- on (mmWidget mm) #resize $ onResize (mmWidget mm) r
+    writeIORef (mmRealized mm) $ Just r
+
+onRender :: w -> Realized -> GLContext -> IO Bool
+onRender w realized gl = do
+    r <- fixupRenderTarget (stRenderer realized)
+    setUniforms gl (stStorage realized) (stState realized)
+    LC.renderFrame r
+    return True
+
+onResize :: GLArea -> Realized -> Int32 -> Int32 -> IO ()
+onResize glarea realized w h = do
+    let storage = stStorage realized
+    -- Plenty of options here.  I went with the last one.
+    -- 1. gLContextGetWindow :: HasCallStack => GLContext -> IO (Maybe Window)
+    -- 2. getGLContextWindow ::                 GLContext -> IO (Maybe Window)
+    -- 3. widgetGetWindow    :: HasCallStack => GLArea    -> IO (Maybe Window)
+    widgetGetWindow glarea >>= mapM_ (\win -> do
+        (wd,ht) <- do wd <- windowGetWidth win
+                      ht <- windowGetHeight win
+                      return (fromIntegral wd,fromIntegral ht)
+        LC.setScreenSize (stStorage realized) wd ht)
-- 
cgit v1.2.3