Added colors to pen points + various updates.

4 files changed, 75 insertions, 22 deletions

diff --git a/GLWidget.hs b/GLWidget.hs
index 8620c1a..ebd6694 100644
--- a/GLWidget.hs
+++ b/GLWidget.hs
@@ -63,8 +63,11 @@ newGLWidget mk w = do
 withCurrentGL :: GLArea -> IO () -> IO ()
 withCurrentGL glarea action = do
     gLAreaMakeCurrent glarea
-    e <- gLAreaGetError glarea
-    maybe action oopsG e
+    gLAreaGetError glarea >>= maybe action oopsG
+    -- -- The following causes realize and resize to each be triggered
+    -- -- twice before the first render signal.
+    -- gLAreaAttachBuffers glarea
+    -- gLAreaGetError glarea >>= maybe action oopsG
 
 nullableContext :: IO (Maybe GLContext) -> IO GLContext
 nullableContext mk = mk >>= maybe mknull return
diff --git a/MaskableStream.hs b/MaskableStream.hs
index d836f37..6c03769 100644
--- a/MaskableStream.hs
+++ b/MaskableStream.hs
@@ -331,7 +331,6 @@ updateAttributes i writer = forM_ (execWriter writer) $ \case
 
             Just (MarshalGLVector with) -> with $ \sz ptr -> do
                 let sz' = fromIntegral $ attribSize * (fromIntegral sz)
-                putStrLn $ "vector sz = " ++ show sz
                 glBufferSubData GL_ARRAY_BUFFER (base + fromIntegral i * sz') sz' ptr
 
             Just (MarshalGLMatrix with) -> with $ \sz isrowcol ptr -> case isrowcol of
diff --git a/MeshSketch.hs b/MeshSketch.hs
index 2b29f0a..8df74b3 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -17,6 +17,7 @@ import Data.Function ((&))
 import Data.Functor ((<&>))
 import Data.Int
 import Data.IORef
+import Data.Maybe
 import Data.Text (Text)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
@@ -25,6 +26,7 @@ import qualified Data.Vector.Generic as G
 import Foreign.Marshal.Array
 import Foreign.Storable
 import GI.Gdk
+import GI.GObject.Functions (signalHandlerDisconnect)
 import GI.Gdk.Objects
 import GI.GLib.Constants
 import GI.Gtk hiding (IsWindow,windowFullscreen,windowUnfullscreen)
@@ -40,10 +42,11 @@ import LambdaCube.IR as LC
 import LambdaCube.Gtk
 import LambdaCube.GL.Data (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer)
 import LambdaCube.GL.Type (TextureCubeData(..),Object(..))
--- import Text.Show.Pretty (ppShow)
+import Text.Show.Pretty (ppShow)
 import qualified Graphics.Rendering.OpenGL as GL
 import Data.Char
 import Text.Printf
+import qualified Foreign.C.Types
 
 import CubeMap
 import GLWidget (nullableContext, withCurrentGL)
@@ -82,6 +85,7 @@ type Plane = Vector Float
 
 data RingPoint = RingPoint
     { rpPosition :: AttributeKey (GLVector 3 Float)
+    , rpColor :: AttributeKey (GLVector 3 Float)
     }
     deriving Data
 
@@ -293,14 +297,18 @@ data MeshSketch = MeshSketch
     , mmRealized :: IORef (Maybe Realized)
     }
 
+type SignalHandlerId = Foreign.C.Types.CULong
+
 data Realized = Realized
     { stStorage  :: GLStorage
     , stRenderer :: GLRenderer
     , stState    :: State
+    , stSigs     :: [SignalHandlerId] -- Signals attached by onRealize.
     }
 
 new :: IO GLArea
 new = do
+    putStrLn "new!"
     m <- do
         objName <- head . (++ ["cube.obj"]) <$> getArgs
         mobj <- loadOBJ objName
@@ -316,6 +324,7 @@ new = do
             "position"  @: Attribute_V4F
           defObjectArray "Points" Points $ do
             "position"  @: Attribute_V3F
+            "color"     @: Attribute_V3F
           defUniforms $ do
             "PointBuffer"     @: FTextureBuffer
             "CubeMap"         @: FTextureCube
@@ -329,7 +338,23 @@ new = do
         return $ (,) <$> mobj <*> mpipeline
     either (\e _ -> hPutStrLn stderr e >> throwIO (userError e)) (&) m $ \(obj,pipeline) -> do
 
+        {-
+        let pipeline = pipeline0 { dynamicPipeline = (dynamicPipeline pipeline0) 
+                                    { targets = fmap nocolorv (targets $ dynamicPipeline pipeline0) } }
+            nocolorv (RenderTarget v) = RenderTarget (fmap nocolor v)
+            nocolor (TargetItem LC.Color (Just (Framebuffer LC.Color))) = TargetItem LC.Color Nothing
+            nocolor x = x -}
+
         -- putStrLn $ ppShow (dynamicPipeline pipeline)
+        mapM_ (putStrLn . ppShow) (targets $ dynamicPipeline pipeline)
+        {-
+        RenderTarget
+          { renderTargets =
+              [ TargetItem { targetSemantic = Depth , targetRef = Just (Framebuffer Depth) }
+              , TargetItem { targetSemantic = Color , targetRef = Just (Framebuffer Color) }
+              ]
+          }
+        -}
 
         ref <- newIORef Nothing
         -- glarea <- newGLWidget return (lambdaRender app glmethods)
@@ -340,29 +365,38 @@ new = do
             st <- return g
             _ <- on g #realize       $ withCurrentGL g (onRealize obj (dynamicPipeline pipeline) (dynamicSchema pipeline) mm)
             _ <- on g #unrealize     $ onUnrealize mm
-            -- _ <- on g #createContext $ nullableContext (glCreateContext w st)
+            _ <- on g #createContext $ nullableContext (onCreateContext g)
             return g
 
 onUnrealize :: MeshSketch -> IO ()
 onUnrealize mm = do
+    putStrLn "onUnrealize!"
     m <- readIORef (mmRealized mm)
     forM_ m $ \st -> do
-        LC.disposeStorage (stStorage st)
+        forM_ (stSigs st) $ \sig -> do
+            signalHandlerDisconnect (mmWidget mm) sig
         LC.disposeRenderer (stRenderer st)
+        LC.disposeStorage (stStorage st)
         -- lcDestroyState lc x
+        writeIORef (mmRealized mm) Nothing
 
 onRealize :: MeshData -> Pipeline -> PipelineSchema -> MeshSketch -> IO ()
 onRealize mesh pipeline schema mm = do
+    putStrLn "onRealize!"
     onUnrealize mm
     setupGLDebugging
     storage <- LC.allocStorage schema
+    -- do fbo <- GL.get $ GL.bindFramebuffer GL.DrawFramebuffer
+    --    putStrLn $ "allocRenderer fbo = " ++ show fbo
     renderer <- LC.allocRenderer pipeline
     compat <- LC.setStorage renderer storage -- check schema compatibility
+    -- putStrLn $ "setStorage compat = " ++ show compat
     x <- uploadState mesh (mmWidget mm) storage
     let r = Realized
             { stStorage  = storage
             , stRenderer = renderer
             , stState    = x
+            , stSigs     = []
             }
         w = mmWidget mm
     set w [ #canFocus := True ] -- For keyboard events.
@@ -374,21 +408,29 @@ onRealize mesh pipeline schema mm = do
         , EventMaskScrollMask
         , EventMaskKeyPressMask -- , EventMaskKeyReleaseMask
         ]
-    _ <- on w #event  $ \ev -> do gLAreaMakeCurrent w
-                                  onEvent w r ev
-    _ <- on w #render $ onRender w r
-    _ <- on w #resize $ onResize w r
-    writeIORef (mmRealized mm) $ Just r
+    sige <- on w #event  $ \ev -> do gLAreaMakeCurrent w
+                                     gLAreaAttachBuffers w
+                                     onEvent w r ev
+    sigr <- on w #render $ onRender w r
+    sigs <- on w #resize $ onResize w r
+
+    writeIORef (mmRealized mm) $ Just r { stSigs = [sige,sigr,sigs] }
 
 onRender :: w -> Realized -> GLContext -> IO Bool
 onRender w realized gl = do
-    r <- fixupRenderTarget (stRenderer realized)
+    -- putStrLn "onRender!"
+    r <- -- Patched lambdacube-gl: No longer need this hack.
+         -- fixupRenderTarget (stRenderer realized)
+         return (stRenderer realized)
     setUniforms gl (stStorage realized) (stState realized)
+    -- do fbo <- GL.get $ GL.bindFramebuffer GL.DrawFramebuffer
+    --    putStrLn $ "renderFrame fbo = " ++ show fbo
     LC.renderFrame r
     return True
 
 onResize :: GLArea -> Realized -> Int32 -> Int32 -> IO ()
 onResize glarea realized w h = do
+    -- putStrLn "onResize!"
     -- Plenty of options here.  I went with the last one.
     -- 1. gLContextGetWindow :: HasCallStack => GLContext -> IO (Maybe Window)
     -- 2. getGLContextWindow ::                 GLContext -> IO (Maybe Window)
@@ -568,16 +610,19 @@ worldCoordinates st h k mplane = do
         -- Write on the camDistance sphere.
         Nothing    -> p + scale (camDistance cam) d̂
 
-pushRing :: IsWidget w => w -> State -> Double -> Double -> IO (Vector Float)
-pushRing w st h k = do
+pushRing :: IsWidget w => w -> State -> Double -> Double -> Vector Float -> IO (Vector Float)
+pushRing w st h k c = do
     plane <- readIORef (stPlane st)
     d <- worldCoordinates st h k plane
     Just win <- getWidgetWindow w
     pushBack (stRingBuffer st) $ \RingPoint{..} -> do
         rpPosition @<- d
+        rpColor @<- c
     windowInvalidateRect win Nothing False
     return d
 
+yellow = fromList [1,1,0] :: Vector Float
+red    = fromList [1,0,0] :: Vector Float
 
 onEvent :: IsWidget w => w -> Realized -> Event -> IO Bool
 onEvent w realized ev = do
@@ -601,10 +646,10 @@ onEvent w realized ev = do
                 Just InputSourcePen -> do
                     isDown <- readIORef (stPenDown st)
                     when isDown $ do
-                        d <- pushRing w st h k
+                        d <- pushRing w st h k yellow
                         put (etype,(h,k),d)
                 _ -> do
-                    put (h,k)
+                    -- put (h,k)
                     updateCameraRotation w st h k
                     return ()
               Just (from,plane) -> do
@@ -629,7 +674,7 @@ onEvent w realized ev = do
               case inputSource of
                 Just InputSourcePen -> do
                     writeIORef (stPenDown st) True
-                    d <- pushRing w st h k
+                    d <- pushRing w st h k red
                     Just win <- getWidgetWindow w
                     windowInvalidateRect win Nothing False
                     put (etype,(h,k),d)
@@ -656,7 +701,7 @@ onEvent w realized ev = do
               Nothing -> case inputSource of
                 Just InputSourcePen -> do
                     writeIORef (stPenDown st) False
-                    d <- pushRing w st h k
+                    d <- pushRing w st h k red
                     Just win <- getWidgetWindow w
                     windowInvalidateRect win Nothing False
                 _ -> do
@@ -721,3 +766,9 @@ onEvent w realized ev = do
         e -> return ()
 
     return False
+
+onCreateContext :: IsWidget a => a -> IO (Maybe GLContext)
+onCreateContext w = do
+    putStrLn "onCreateContext!"
+    mwin <- widgetGetWindow w
+    forM mwin $ \win -> windowCreateGlContext win
diff --git a/hello_obj2.lc b/hello_obj2.lc
index fdf08d6..72a87ee 100644
--- a/hello_obj2.lc
+++ b/hello_obj2.lc
@@ -19,7 +19,7 @@ makeFrame (cubemap :: TextureCube)
           (texture :: Texture)
           (prims :: PrimitiveStream Triangle (Vec 4 Float, Vec 3 Float, Vec 3 Float))
           (plane :: PrimitiveStream Triangle ((Vec 4 Float)))
-          (points :: PrimitiveStream Point ((Vec 3 Float)))
+          (points :: PrimitiveStream Point (Vec 3 Float, Vec 3 Float))
           (plane_mat :: Mat 4 4 Float)
 
     = imageFrame (emptyDepthImage 1, emptyColorImage (V4 0 0 0.4 1))
@@ -47,8 +47,8 @@ makeFrame (cubemap :: TextureCube)
     & accumulateWith (DepthOp Less True, ColorOp blendplane (V4 True True True True))
   `overlay`
       points
-    & mapPrimitives (\((p)) -> let p' = coordmap cam $ point p
-                                in (p', V4 1 1 0 1 :: Vec 4 Float))
+    & mapPrimitives (\(p,c) -> let p' = coordmap cam $ point p
+                                in (p', point c))
 
     & renderPoints cam
 
@@ -73,5 +73,5 @@ main = renderFrame $
              (Texture2DSlot "diffuseTexture")
              (fetch "objects" (Attribute "position", Attribute "normal", Attribute "uvw"))
              (fetch "plane"   ((Attribute "position")))
-             (fetch "Points" ((Attribute "position")))
+             (fetch "Points" (Attribute "position", Attribute "color"))
              (Uniform "PlaneModel")