LambdaHello

1 files changed, 139 insertions, 0 deletions

diff --git a/LambdaHello.hs b/LambdaHello.hs
new file mode 100644
index 0000000..ed04598
--- /dev/null
+++ b/LambdaHello.hs
@@ -0,0 +1,139 @@
+{-# LANGUAGE OverloadedStrings #-}
+module LambdaHello where
+
+import GI.Gtk as Gtk
+import GI.Gdk.Objects
+
+-- import qualified Graphics.Rendering.OpenGL as GL
+import Data.Function
+import Control.Concurrent
+import LambdaCube.GL as LambdaCubeGL
+import LambdaCube.GL.Mesh as LambdaCubeGL
+import LambdaCube.IR
+import Codec.Picture as Juicy
+import Data.Aeson as JSON
+import qualified Data.ByteString as SB
+import System.IO.Error
+import qualified Data.Map as Map
+import qualified Data.Vector as V
+
+import qualified Backend as RF
+
+data State = State
+    { stConfig   :: Config
+    , stRealized :: MVar Realized
+    }
+
+initState :: IO State
+initState = do
+    cfg <- either fail return =<< loadConfig
+    r <- newEmptyMVar
+    return State
+        { stConfig   = cfg
+        , stRealized = r
+        }
+
+
+render :: State -> GLArea -> GLContext -> IO Bool
+render st w _ = do -- gLAreaMakeCurrent w >> gLAreaGetError w >>= \me -> maybe id (\e _ -> print e >> return False) me $ do
+    mr <- tryTakeMVar (stRealized st)
+    maybe (\_ -> putStrLn "Not realized!") (&) mr $ \r -> do
+        -- Load input to pipeline.
+        -- GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h)
+        return (500,500) >>= \(w,h) -> LambdaCubeGL.setScreenSize (rStorage r) (fromIntegral w) (fromIntegral h)
+        LambdaCubeGL.updateUniforms (rStorage r) $ do
+          "diffuseTexture" @= return (rTexture r)
+          "time" @= do
+                      -- Just t <- GLFW.getTime
+                      let t = 1.0 :: Double
+                      return (realToFrac t :: Float)
+
+        putStrLn "render!"
+        -- GL.clearColor GL.$= GL.Color4 0 255 0 1
+        -- GL.clear [GL.ColorBuffer]
+        RF.renderFrame (rRenderer r)
+        -- GL.flush
+        putMVar (stRealized st) r
+    return True
+
+data Realized = Realized
+    { rStorage  :: GLStorage
+    , rTexture  :: TextureData
+    , rRenderer :: GLRenderer
+    }
+
+realize :: State -> GLArea -> IO ()
+realize st w = gLAreaMakeCurrent w >> gLAreaGetError w >>= \me -> maybe id (\e _ -> print e) me $ do
+    let cfg = stConfig st
+
+    _ <- tryTakeMVar (stRealized st)
+
+    storage <- LambdaCubeGL.allocStorage (cfgSchema cfg)
+
+    -- 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
+    texture <- LambdaCubeGL.uploadTexture2DToGPU (cfgLogo cfg)
+
+    renderer <- LambdaCubeGL.allocRenderer (cfgPipeline cfg)
+
+    compat <- LambdaCubeGL.setStorage renderer storage -- check schema compatibility
+
+    putMVar (stRealized st) $ Realized storage texture renderer
+    -- GL.flush
+    putStrLn "realize!"
+    maybe id (\e _ -> putStrLn e) compat $ return ()
+
+unrealize :: State -> GLArea -> IO ()
+unrealize _ _ = return ()
+
+data Config = Config
+    { cfgSchema   :: PipelineSchema
+    , cfgPipeline :: Pipeline
+    , cfgLogo     :: DynamicImage
+    }
+
+loadConfig :: IO (Either String Config)
+loadConfig = do
+    pipelineDesc <- do
+            maybe (Left "Unable to parse hello.json") Right . JSON.decodeStrict <$> SB.readFile "hello.json"
+        `catchIOError` \e -> return $ Left (show e)
+    -- setup render data
+    let inputSchema = makeSchema $ do
+          defObjectArray "objects" Triangles $ do
+            "position"  @: Attribute_V2F
+            "uv"        @: Attribute_V2F
+          defUniforms $ do
+            "time"           @: Float
+            "diffuseTexture" @: FTexture2D
+    -- load image and upload texture
+    img <- Juicy.readImage "logo.png"
+        `catchIOError` \e -> return $ Left (show e)
+    return $ Config inputSchema <$> pipelineDesc <*> img
+
+-- 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
+    }
+
+createContext :: State -> GLArea -> IO GLContext
+createContext st glarea = do
+    Just win <- widgetGetWindow glarea
+    gl <- windowCreateGlContext win
+    return gl