6 files changed, 65 insertions, 46 deletions

diff --git a/examples/Hello.hs b/examples/Hello.hs
index cfe1053..5918d88 100644
--- a/examples/Hello.hs
+++ b/examples/Hello.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE PackageImports, LambdaCase #-}
+{-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts #-}
 import "GLFW-b" Graphics.UI.GLFW as GLFW
 import qualified Data.Map as Map
@@ -11,39 +11,6 @@ import Codec.Picture as Juicy
 
 import LambdaCube.Compiler.Driver as LambdaCube -- compiler
 
-----
-import Control.Monad.Writer
-
-{-
-data ObjectArraySchema
-    = ObjectArraySchema
-    { primitive     :: FetchPrimitive
-    , attributes    :: Map String StreamType
-    }
-    deriving Show
-
-data PipelineSchema
-    = PipelineSchema
-    { objectArrays  :: Map String ObjectArraySchema
-    , uniforms      :: Map String InputType
-    }
--}
-
-
-a @: b = tell [(a,b)]
-defObjectArray n p m = tell [PipelineSchema (Map.singleton n $ ObjectArraySchema p $ Map.fromList $ execWriter m) mempty]
-defUniforms m = tell [PipelineSchema mempty $ Map.fromList $ execWriter m]
-makeSchema a = head $ execWriter a :: PipelineSchema
-
-sch = makeSchema $ do
-  defObjectArray "objects" Triangles $ do
-    "position"  @: Attribute_V4F
-    "uv"        @: Attribute_V2F
-  defUniforms $ do
-    "time"           @: Float
-    "diffuseTexture" @: FTexture2D
-
------
 main :: IO ()
 main = do
     -- compile hello.lc to graphics pipeline description
@@ -56,7 +23,7 @@ main = do
     -- setup render data
     let inputSchema = makeSchema $ do
           defObjectArray "objects" Triangles $ do
-            "position"  @: Attribute_V4F
+            "position"  @: Attribute_V2F
             "uv"        @: Attribute_V2F
           defUniforms $ do
             "time"           @: Float
@@ -80,11 +47,11 @@ main = do
         where loop = do
                 -- update graphics input
                 GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h)
-                {-
                 LambdaCubeGL.updateUniforms storage $ do
-                  "time" @= fromJust <$> GLFW.getTime
                   "diffuseTexture" @= return textureData
-                -}
+                  "time" @= do
+                              Just t <- GLFW.getTime
+                              return (realToFrac t :: Float)
                 -- render
                 LambdaCubeGL.renderFrame renderer
                 GLFW.swapBuffers win
diff --git a/examples/Panels_Diffuse.png b/examples/Panels_Diffuse.png
new file mode 100644
index 0000000..15b242c
--- /dev/null
+++ b/examples/Panels_Diffuse.png
diff --git a/examples/hello.lc b/examples/hello.lc
new file mode 100644
index 0000000..1087fbe
--- /dev/null
+++ b/examples/hello.lc
@@ -0,0 +1,12 @@
+sampler = Sampler PointFilter MirroredRepeat (Texture2DSlot "diffuseTexture")
+main = let
+  emptyFB           = FrameBuffer (colorImage1 (V4 0.0 0.0 0.4 1.0))
+  rasterCtx         = TriangleCtx CullNone PolygonFill NoOffset LastVertex
+  fragmentCtx       = AccumulationContext (ColorOp NoBlending (V4 True True True True))
+  vertexShader (p,uv) = VertexOut (V4 p%x p%y (-1) 1) 1.0 () (Smooth uv)
+  vertexStream      = Fetch "objects" Triangles (Attribute "position" :: Vec 2 Float, Attribute "uv" :: Vec 2 Float)
+  primitiveStream   = Transform vertexShader vertexStream
+  fragmentStream    = Rasterize rasterCtx primitiveStream
+  fragmentShader uv = FragmentOut $ texture2D sampler uv
+  frame             = Accumulate fragmentCtx PassAll fragmentShader fragmentStream emptyFB
+ in ScreenOut frame
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