update example

3 files changed, 48 insertions, 8 deletions

diff --git a/src/LambdaCube/GL.hs b/src/LambdaCube/GL.hs
index 3e11be1..258d2ba 100644
--- a/src/LambdaCube/GL.hs
+++ b/src/LambdaCube/GL.hs
@@ -28,6 +28,7 @@ module LambdaCube.GL (
     uploadTexture2DToGPU',
 
     -- GL: Renderer, Storage, Object
+    GLUniformName,
     GLRenderer,
     GLStorage,
     Object,
@@ -48,7 +49,6 @@ module LambdaCube.GL (
     setObjectOrder,
     objectUniformSetter,
     setScreenSize,
-    sortSlotObjects,
 
     uniformBool,
     uniformV2B,
@@ -80,7 +80,16 @@ module LambdaCube.GL (
     uniformM43F,
     uniformM44F,
 
-    uniformFTexture2D
+    uniformFTexture2D,
+
+    -- schema builder utility functions
+    (@:),
+    defObjectArray,
+    defUniforms,
+    makeSchema,
+
+    (@=),
+    updateUniforms
 ) where
 
 import LambdaCube.GL.Type
diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs
index 2753ac3..677e925 100644
--- a/src/LambdaCube/GL/Backend.hs
+++ b/src/LambdaCube/GL/Backend.hs
@@ -696,12 +696,12 @@ renderSlot cmds = forM_ cmds $ \cmd -> do
                                                                 texUnit <- readIORef tuRef
                                                                 glActiveTexture $ GL_TEXTURE0 + fromIntegral texUnit
                                                                 glBindTexture txTarget txObj
-                                                                putStrLn $ "to texture unit " ++ show texUnit ++ " texture object " ++ show txObj
+                                                                --putStrLn $ "to texture unit " ++ show texUnit ++ " texture object " ++ show txObj
         GLSetVertexAttrib idx val                       -> do
                                                             glDisableVertexAttribArray idx
                                                             setVertexAttrib idx val
-    isOk <- checkGL
-    putStrLn $ isOk ++ " - " ++ show cmd
+    --isOk <- checkGL
+    --putStrLn $ isOk ++ " - " ++ show cmd
 
 renderFrame :: GLRenderer -> IO ()
 renderFrame glp = do
@@ -750,8 +750,8 @@ renderFrame glp = do
             GLSaveImage
             GLLoadImage
             -}
-        isOk <- checkGL
-        putStrLn $ isOk ++ " - " ++ show cmd
+        --isOk <- checkGL
+        --putStrLn $ isOk ++ " - " ++ show cmd
 
 data CGState
     = CGState
diff --git a/src/LambdaCube/GL/Input.hs b/src/LambdaCube/GL/Input.hs
index 742fc35..7e4ba74 100644
--- a/src/LambdaCube/GL/Input.hs
+++ b/src/LambdaCube/GL/Input.hs
@@ -1,8 +1,10 @@
+{-# LANGUAGE FlexibleContexts #-}
 module LambdaCube.GL.Input where
 
 import Control.Applicative
 import Control.Exception
 import Control.Monad
+import Control.Monad.Writer
 import Data.IORef
 import Data.Map (Map)
 import Data.IntMap (IntMap)
@@ -68,7 +70,7 @@ allocStorage sch = do
         }
 
 disposeStorage :: GLStorage -> IO ()
-disposeStorage = error "not implemented: disposeStorage"
+disposeStorage _ = putStrLn "not implemented: disposeStorage"
 
 -- object
 addObject :: GLStorage -> String -> Primitive -> Maybe (IndexStream Buffer) -> Map String (Stream Buffer) -> [String] -> IO Object
@@ -137,6 +139,7 @@ addObject input slotName prim indices attribs uniformNames = do
                     let emptyV = V.replicate (V.length $ glPrograms p) []
                     return $ emptyV // [(prgIdx,createObjectCommands (glTexUnitMapping p) topUnis obj (glPrograms p ! prgIdx))| prgIdx <- glSlotPrograms p ! pSlotIdx]
     writeIORef cmdsRef cmds
+    sortSlotObjects input
     return obj
 
 removeObject :: GLStorage -> Object -> IO ()
@@ -149,6 +152,7 @@ setObjectOrder :: GLStorage -> Object -> Int -> IO ()
 setObjectOrder p obj i = do
     writeIORef (objOrder obj) i
     modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs sorted _) -> GLSlot objs sorted Reorder
+    sortSlotObjects p
 
 objectUniformSetter :: Object -> Map GLUniformName InputSetter
 objectUniformSetter = objUniSetter
@@ -387,3 +391,30 @@ uniformM44F n is = case Map.lookup n is of
 uniformFTexture2D n is = case Map.lookup n is of
     Just (SFTexture2D fun)    -> fun
     _   -> nullSetter n "FTexture2D"
+
+a @: b = tell [(a,b)]
+defObjectArray n p m = mapM_ tell [PipelineSchema (Map.singleton n $ ObjectArraySchema p $ Map.singleton a t) mempty | (a,t) <- execWriter m]
+defUniforms m = tell $ PipelineSchema mempty $ Map.fromList $ execWriter m
+makeSchema a = execWriter a :: PipelineSchema
+
+unionObjectArraySchema (ObjectArraySchema a1 b1) (ObjectArraySchema a2 b2) =
+  ObjectArraySchema (if a1 == a2 then a1 else error $ "object array schema primitive mismatch " ++ show (a1,a2))
+                    (Map.unionWith (\a b -> if a == b then a else error $ "object array schema attribute type mismatch " ++ show (a,b)) b1 b2)
+
+instance Monoid PipelineSchema where
+  mempty = PipelineSchema mempty mempty
+  mappend (PipelineSchema a1 b1) (PipelineSchema a2 b2) =
+    PipelineSchema (Map.unionWith unionObjectArraySchema a1 a2) (Map.unionWith (\a b -> if a == b then a else error $ "schema type mismatch " ++ show (a,b)) b1 b2)
+
+type UniM = Writer [GLStorage -> IO ()]
+
+class UniformSetter a where
+  (@=) :: GLUniformName -> IO a -> UniM ()
+
+instance UniformSetter Float where
+  n @= act = tell [\s -> let f = uniformFloat n (uniformSetter s) in f =<< act]
+
+instance UniformSetter TextureData where
+  n @= act = tell [\s -> let f = uniformFTexture2D n (uniformSetter s) in f =<< act]
+
+updateUniforms storage m = sequence_ $ let l = map ($ storage) $ execWriter m in l