Refactored spinning-logo demo.

1 files changed, 92 insertions, 0 deletions

diff --git a/main.hs b/main.hs
new file mode 100644
index 0000000..dff8263
--- /dev/null
+++ b/main.hs
@@ -0,0 +1,92 @@
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+module Main where
+
+import Codec.Picture             as Juicy
+import Control.Concurrent
+import Data.Word
+import Data.Function
+import qualified Data.Map.Strict as Map
+import qualified Data.Vector     as V
+import GI.Gdk.Objects
+import GI.GLib.Constants
+import GI.Gtk                    as Gtk hiding (main)
+import LambdaCube.GL             as LC
+import LambdaCube.GL.Mesh        as LC
+import System.IO
+import System.IO.Error
+
+import GLWidget
+import LambdaCubeWidget
+import TimeKeeper
+
+type State = (TextureData, TimeKeeper, TickCallbackHandle)
+
+uploadState :: IsWidget glarea => DynamicImage -> glarea -> GLStorage -> IO State
+uploadState img glarea storage = do
+    -- upload geometry to GPU and add to pipeline input
+    LC.uploadMeshToGPU triangleA >>= LC.addMeshToObjectArray storage "objects" []
+    LC.uploadMeshToGPU triangleB >>= LC.addMeshToObjectArray storage "objects" []
+    -- load image and upload texture
+    texture <- LC.uploadTexture2DToGPU img
+    -- setup FrameClock
+    tm <- newTimeKeeper
+    tickcb <- widgetAddTickCallback glarea (tick tm)
+    return (texture,tm,tickcb)
+
+destroyState :: GLArea -> State -> IO ()
+destroyState glarea (texture,tm,tickcb) = do
+    widgetRemoveTickCallback glarea tickcb
+
+setUniforms :: glctx -> GLStorage -> State -> IO ()
+setUniforms gl storage (texture,tm,_) = do
+    t <- withMVar (tmSeconds tm) return
+    LC.updateUniforms storage $ do
+      "diffuseTexture" @= return texture
+      "time" @= return (realToFrac t :: Float)
+
+main :: IO ()
+main = do
+    m <- do
+        mimg <- Juicy.readImage "logo.png" `catchIOError` \e -> return $ Left (show e)
+        mpipeline <- loadPipeline "hello.json" $ do
+                        defObjectArray "objects" Triangles $ do
+                            "position"  @: Attribute_V2F
+                            "uv"        @: Attribute_V2F
+                        defUniforms $ do
+                            "time"           @: Float
+                            "diffuseTexture" @: FTexture2D
+        return $ (,) <$> mimg <*> mpipeline
+    either (\e _ -> hPutStrLn stderr e) (&) m $ \(logo,pipeline) -> do
+        app <- do
+            mvar <- newEmptyMVar
+            return $ \glarea -> LCMethods
+                { lcRealized     = mvar
+                , lcUploadState  = uploadState logo glarea
+                , lcDestroyState = destroyState glarea
+                , lcSetUniforms  = setUniforms
+                , lcPipeline     = pipeline
+                }
+
+        runGLApp return (lambdaRender app glmethods)
+
+-- geometry data: triangles
+triangleA :: LC.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 :: LC.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
+    }
+