Lambda2 experiment.

1 files changed, 150 insertions, 0 deletions

diff --git a/Lambda2.hs b/Lambda2.hs
new file mode 100644
index 0000000..bedf18c
--- /dev/null
+++ b/Lambda2.hs
@@ -0,0 +1,150 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Lambda2 where
+
+import GI.Gtk.Objects (GLArea,gLAreaGetContext,widgetGetWindow)
+import GI.Gdk.Objects.GLContext (GLContext, gLContextGetDebugEnabled,
+                                 gLContextGetForwardCompatible,
+                                 gLContextSetDebugEnabled,
+                                 gLContextSetForwardCompatible,
+                                 gLContextGetRequiredVersion,
+                                 gLContextSetRequiredVersion,
+                                 gLContextGetUseEs,
+                                 getGLContextWindow)
+import GI.Gdk.Objects.Window (windowCreateGlContext,windowGetWidth,windowGetHeight)
+
+import qualified Data.Map as Map
+import qualified Data.Vector as V
+
+import LambdaCube.GL as LambdaCubeGL -- renderer
+import LambdaCube.GL.Mesh as LambdaCubeGL
+import Codec.Picture as Juicy
+import Data.Aeson
+import qualified Data.ByteString as SB
+
+data State = State
+
+initState :: IO State
+initState = do
+    return State
+
+render :: State -> GLArea -> GLContext -> IO Bool
+render st glarea gl = do
+    Just pipelineDesc <- decodeStrict <$> SB.readFile "hello.json"
+
+    -- win <- initWindow "LambdaCube 3D DSL Hello World" 640 640
+
+    -- setup render data
+    let inputSchema = makeSchema $ do
+          defObjectArray "objects" Triangles $ do
+            "position"  @: Attribute_V2F
+            "uv"        @: Attribute_V2F
+          defUniforms $ do
+            "time"           @: Float
+            "diffuseTexture" @: FTexture2D
+
+    storage <- LambdaCubeGL.allocStorage inputSchema
+
+    -- upload geometry to GPU and add to pipeline input
+    LambdaCubeGL.uploadMeshToGPU triangleA >>= LambdaCubeGL.addMeshToObjectArray storage "objects" []
+    LambdaCubeGL.uploadMeshToGPU triangleB >>= LambdaCubeGL.addMeshToObjectArray storage "objects" []
+
+    -- load image and upload texture
+    Right img <- Juicy.readImage "logo.png"
+    textureData <- LambdaCubeGL.uploadTexture2DToGPU img
+
+    -- allocate GL pipeline
+    renderer <- LambdaCubeGL.allocRenderer pipelineDesc
+    LambdaCubeGL.setStorage renderer storage >>= \case -- check schema compatibility
+      Just err -> putStrLn err
+      Nothing  -> loop
+        where loop = do
+                -- update graphics input
+                -- GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h)
+                (wd,ht) <- do
+                        Just win <- getGLContextWindow gl
+                        wd <- windowGetWidth win
+                        ht <- windowGetHeight win
+                        print (wd,ht)
+                        return (wd,ht)
+                return (wd,ht) >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h)
+                LambdaCubeGL.updateUniforms storage $ do
+                  "diffuseTexture" @= return textureData
+                  "time" @= do
+                              Just t <- return $ Just (1.0::Double) -- GLFW.getTime
+                              return (realToFrac t :: Float)
+                -- render
+                putStrLn "LambdaCubeGL.renderFrame enter"
+                LambdaCubeGL.renderFrame renderer
+                putStrLn "LambdaCubeGL.renderFrame exit"
+                -- GLFW.swapBuffers win
+                -- GLFW.pollEvents
+
+                let keyIsPressed k = return True -- fmap (==KeyState'Pressed) $ GLFW.getKey win k
+                escape <- keyIsPressed () -- Key'Escape
+                if escape then return () else loop
+
+    LambdaCubeGL.disposeRenderer renderer
+    -- LambdaCubeGL.disposeStorage storage -- XXX: not implemented
+    -- GLFW.destroyWindow win
+    -- GLFW.terminate
+    return True
+
+-- geometry data: triangles
+triangleA :: LambdaCubeGL.Mesh
+triangleA = Mesh
+    { mAttributes   = Map.fromList
+        [ ("position",  A_V2F $ V.fromList [V2 1 1, V2 1 (-1), V2 (-1) (-1)])
+        , ("uv",        A_V2F $ V.fromList [V2 1 1, V2 0 1, V2 0 0])
+        ]
+    , mPrimitive    = P_Triangles
+    }
+
+triangleB :: LambdaCubeGL.Mesh
+triangleB = Mesh
+    { mAttributes   = Map.fromList
+        [ ("position",  A_V2F $ V.fromList [V2 1 1, V2 (-1) (-1), V2 (-1) 1])
+        , ("uv",        A_V2F $ V.fromList [V2 1 1, V2 0 0, V2 1 0])
+        ]
+    , mPrimitive    = P_Triangles
+    }
+
+realize :: State -> GLArea -> IO ()
+realize st glarea = do
+    putStrLn "realize!"
+    return ()
+
+unrealize :: State -> GLArea -> IO ()
+unrealize st glarea = do
+    return ()
+
+createContext :: State -> GLArea -> IO GLContext
+createContext st glarea = do
+    putStrLn "createContext!"
+    -- gl <- gLAreaGetContext glarea -- Remember to bind signal with 'after' so that this is not nullPtr.
+    Just win <- widgetGetWindow glarea
+    gl <- windowCreateGlContext win
+    (maj,min) <- gLContextGetRequiredVersion gl
+    -- (vmaj,vmin) <- gLContextGetVersion gl -- must be realized
+    -- islegacy <- gLContextIsLegacy gl -- must be realized
+    -- v_es <-gLContextGetUseEs gl
+
+    v_db <- gLContextGetDebugEnabled gl
+    v_fw <- gLContextGetForwardCompatible gl
+    v_es <- gLContextGetUseEs gl
+    putStrLn $ unwords [ "debug:",show v_db
+                       , "fw:",show v_fw
+                       , "es:", show v_es
+                       , "ver:", show (maj,min)
+                       ]
+    gLContextSetDebugEnabled gl True
+    gLContextSetForwardCompatible gl False -- True
+    gLContextSetRequiredVersion gl 3 3
+    v_db <- gLContextGetDebugEnabled gl
+    v_fw <- gLContextGetForwardCompatible gl
+    (maj,min) <- gLContextGetRequiredVersion gl
+    putStrLn $ unwords [ "debug:",show v_db
+                       , "fw:",show v_fw
+                       , "ver:", show (maj,min)
+                       ]
+    return gl