Lambdacube code for MeshSketch.

2 files changed, 67 insertions, 2 deletions

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
diff --git a/meshsketch.lc b/meshsketch.lc
new file mode 100644
index 0000000..9ca422d
--- /dev/null
+++ b/meshsketch.lc
@@ -0,0 +1,22 @@
+makeFrame (cam :: Mat 4 4 Float)
+          (skybox :: Texture)
+          (skypoints :: PrimitiveStream Point ((Vec 3 Float)))
+
+    = imageFrame (emptyDepthImage 1, emptyColorImage (V4 0 0 0.4 1))
+      `overlay`
+          skypoints
+        & mapPrimitives (\((p)) -> ( cam *. V4 p%x p%y p%z 1, V3 p%x (-p%y) (-p%z) ) )
+        & rasterizePrimitives (PointCtx (PointSize 1.0)
+                                        1.0        -- GL_POINT_FADE_THRESHOLD
+                                        UpperLeft) -- texture y increases downward
+                              ((Smooth))
+        & mapFragments (\((d)) -> ((texture2D (Sampler PointFilter MirroredRepeat skybox) d%xy )))
+        & accumulateWith (DepthOp Always True, ColorOp NoBlending (V4 True True True True))
+
+
+textureCubeSlot s = Texture2DSlot s
+
+main = renderFrame $
+   makeFrame (Uniform "Cam")
+             (textureCubeSlot "Skybox")
+             (fetch "skypoints" ((Attribute "position")))