Refactored object-loading demo.

1 files changed, 102 insertions, 0 deletions

diff --git a/mainObj.hs b/mainObj.hs
new file mode 100644
index 0000000..1513075
--- /dev/null
+++ b/mainObj.hs
@@ -0,0 +1,102 @@
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+module Main where
+
+import Codec.Picture             as Juicy
+import Control.Concurrent
+import Control.Monad
+import Data.Word
+import Data.Function
+import Data.Text (Text)
+import Data.Map.Strict (Map)
+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.Environment
+import System.IO
+import System.IO.Error
+
+import GLWidget
+import LambdaCubeWidget
+import TimeKeeper
+import LoadMesh
+import InfinitePlane
+import MtlParser (ObjMaterial(..))
+
+type State = (TimeKeeper, TickCallbackHandle)
+
+addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text (ObjMaterial,TextureData) -> IO [LC.Object]
+addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat) -> do
+  obj <- LC.addMeshToObjectArray storage slotName ["diffuseTexture","diffuseColor"] mesh
+         -- diffuseTexture and diffuseColor values can change on each model
+  case mat >>= flip Map.lookup mtlLib of
+    Nothing -> return ()
+    Just (ObjMaterial{..},t) -> LC.updateObjectUniforms obj $ do
+      "diffuseTexture" @= return t -- set model's diffuse texture
+      "diffuseColor" @= let (r,g,b) = mtl_Kd in return (V4 r g b mtl_Tr)
+  return obj
+
+
+uploadState :: IsWidget glarea => MeshData -> glarea -> GLStorage -> IO State
+uploadState obj glarea storage = do
+    -- load OBJ geometry and material descriptions
+    (objMesh,mtlLib) <- uploadOBJToGPU obj
+    -- load materials textures
+    gpuMtlLib <- uploadMtlLib mtlLib
+    -- add OBJ to pipeline input
+    addOBJToObjectArray storage "objects" objMesh gpuMtlLib
+    -- grid plane
+    uploadMeshToGPU xyplane >>= addMeshToObjectArray storage "plane" []
+
+    -- setup FrameClock
+    tm <- newTimeKeeper
+    tickcb <- widgetAddTickCallback glarea (tick tm)
+    return (tm,tickcb)
+
+destroyState :: GLArea -> State -> IO ()
+destroyState glarea (tm,tickcb) = do
+    widgetRemoveTickCallback glarea tickcb
+
+setUniforms :: glctx -> GLStorage -> State -> IO ()
+setUniforms gl storage (tm,_) = do
+    t <- withMVar (tmSeconds tm) return
+    LC.updateUniforms storage $ do
+      "time" @= return (realToFrac t :: Float)
+
+main :: IO ()
+main = do
+    m <- do
+        objName <- head . (++ ["cube.obj"]) <$> getArgs
+        mobj <- loadOBJ objName
+        mpipeline <- loadPipeline "hello_obj2.json" $ do
+          defObjectArray "objects" Triangles $ do
+            "position"  @: Attribute_V4F
+            "normal"    @: Attribute_V3F
+            "uvw"       @: Attribute_V3F
+          defObjectArray "plane" Triangles $ do
+            "position"  @: Attribute_V4F
+          defUniforms $ do
+            "time"            @: Float
+            "diffuseTexture"  @: FTexture2D
+            "diffuseColor"    @: V4F
+        return $ (,) <$> mobj <*> mpipeline
+    either (\e _ -> hPutStrLn stderr e) (&) m $ \(obj,pipeline) -> do
+        app <- do
+            mvar <- newEmptyMVar
+            return $ \glarea -> LCMethods
+                { lcRealized     = mvar
+                , lcUploadState  = uploadState obj glarea
+                , lcDestroyState = destroyState glarea
+                , lcSetUniforms  = setUniforms
+                , lcPipeline     = pipeline
+                }
+
+        runGLApp return (lambdaRender app glmethods)
+            { glTitle = "LambdaCube 3D DSL OBJ viewer"
+            }