Fixing uniforms to work with multiple uses of same B value

Naming uniform blocks
First try at implementing default uniforms (might delete it completely)

GPipe-Core/src/Graphics/GPipe/Shader.hs

@@ -34,7 +34,18 @@ type ShaderT m = ShaderSetupT (ShaderGenT m)
 
 type ShaderSetupT = StateT NextGlobal  
 
-type UniformBufferMap = Map.IntMap (String, Int) -- Offset to type+name + size
+data SType = STypeFloat | STypeInt | STypeBool | STypeUInt
+
+stypeName :: SType -> String
+stypeName STypeFloat = "float"
+stypeName STypeInt = "int"
+stypeName STypeBool = "bool"
+stypeName STypeUInt = "uint"
+
+stypeSize :: SType -> Int
+stypeSize _ = 4
+
+type UniformBufferMap = (Int, Map.IntMap SType)
 
 type ShaderGenT m = ReaderT (SNMap RValue Int) (WriterT Builder (WriterT Builder (StateT (NextTempVar, [UniformBufferMap]) m)))
 
@@ -85,22 +96,23 @@ getNextVar = do
 getTempVar :: Monad m => ShaderT m Int
 getTempVar = lift $ lift $ lift $ lift $ getNextVar
 
-pushUMap :: Monad m => ShaderT m ()
-pushUMap = lift $ lift $ lift $ lift $ do
+pushUMap :: Monad m => Int -> ShaderT m ()
+pushUMap i = lift $ lift $ lift $ lift $ do
     (s, x) <- get
-    put (s, Map.empty : x)
+    put (s, (i, Map.empty) : x)
 
-popUMap :: Monad m => ShaderT m UniformBufferMap
+popUMap :: Monad m => ShaderT m (Map.IntMap SType)
 popUMap = lift $ lift $ lift $ lift $ do
     (s, x:xs) <- get
     put (s, xs)
-    return x
-
-addToUMap :: Monad m => Int -> String -> Int -> ShaderT m ()
-addToUMap a b c = lift $ lift $ lift $ lift $ do
-    (s, x:xs) <- get
-    let y = Map.insert a (b,c) x
-    put (s, y : xs)
+    return $ snd x
+
+addToUMap :: Monad m => Int -> SType -> ShaderT m Int
+addToUMap a b = lift $ lift $ lift $ lift $ do
+    (s, (i,x):xs) <- get
+    let y = Map.insert a b x
+    put (s, (i, y) : xs)
+    return i
 
 
 type VarType = String

GPipe-Core/src/Graphics/GPipe/Uniform.hs

@@ -6,8 +6,7 @@ import Graphics.GPipe.Buffer
 import Graphics.GPipe.Shader
 import Control.Arrow
 import Control.Monad.IO.Class (liftIO)
-import Control.Monad (void, replicateM_)
-import Foreign.Storable (sizeOf)
+import Control.Monad (void, when)
 import Data.IntMap (toAscList)
 
 class BufferFormat (UniformBufferFormat a) => Uniform a where
@@ -18,13 +17,13 @@ class BufferFormat (UniformBufferFormat a) => Uniform a where
 uniformBuffer :: forall os a. Uniform a => Shader os (Buffer os (UniformBufferFormat a)) a
 uniformBuffer = Shader (Kleisli shader) (Kleisli setup)
         where
-            shader _ = do   pushUMap
+            shader _ = do   blockId <- getNextGlobal
+                            pushUMap blockId
                             u <- runKleisli shaderLoad (bElement sampleBuffer)
                             blockMap <- popUMap 
-                            blockId <- getNextGlobal           
                             tellGlobal $ "uniform uBlock" ++ show blockId ++ " {\n"
                             tellUMap 0 (toAscList blockMap) 
-                            tellGlobal "};\n"
+                            tellGlobal $ "} u" ++ show blockId ++ ";\n"
                             return u                             
             setup buffer = do
                                blockId <- getNextGlobal
@@ -34,41 +33,48 @@ uniformBuffer = Shader (Kleisli shader) (Kleisli setup)
             sampleBuffer = makeBuffer undefined undefined :: Buffer os (UniformBufferFormat a)
             Shader shaderLoad setupLoad = loadUniform :: Shader os (UniformBufferFormat a) a
             tellUMap _ [] = return ()
-            tellUMap pos ((off,(decl, size)):xs) = do replicateM_ (off - pos `div` 4) $ do v <- getTempVar
-                                                                                           tellGlobalDecl ("float pad" ++ show v)
-                                                      tellGlobalDecl decl
-                                                      tellUMap (pos + size) xs
+            tellUMap pos ((off,t):xs) = do let pad = off - pos `div` 4
+                                           when (pad > 0) $ do
+                                                v <- getTempVar
+                                                tellGlobalDecl $ "float pad" ++ show v ++ "[" ++ show pad ++ "]"
+                                           tellGlobalDecl $ stypeName t ++ " u" ++ show off
+                                           tellUMap (pos + stypeSize t) xs
 
 type UniformHostFormat a = HostFormat (UniformBufferFormat a)
 
-uniform :: Uniform a => Shader os (UniformHostFormat  a) a
-uniform = undefined
+uniform :: forall os a. Uniform a => Shader os (UniformHostFormat a) a
+uniform = Shader (Kleisli shader) (Kleisli setup)
+    where
+        shader _ = runKleisli shaderLoad (f (error "Hmm, does this work?")) -- TODO: Investigate if this really works
+        setup a = runKleisli setupLoad (f a)
+        Shader shaderLoad setupLoad = loadUniform :: Shader os (UniformBufferFormat a) a
+        ToBuffer _ _ f = toBuffer :: ToBuffer (UniformHostFormat a) (UniformBufferFormat a)
 
+blockUniformName :: Int -> Int -> String
+blockUniformName blockId off = 'u' : show blockId ++ ".u" ++ show off 
 
 instance Uniform VFloat where
     type UniformBufferFormat VFloat = BFloat
     loadUniform = Shader (Kleisli shader) (Kleisli setup)
         where
             shader (B _ off) = do
-                          uniId <- getNextGlobal
-                          let uni = 'u' : show uniId
-                          addToUMap off ("float " ++ uni) (sizeOf (undefined :: Float))
-                          tellGlobalDecl $ "uniform float " ++ uni                           
-                          return (S $ return uni)
+                          blockId <- addToUMap off STypeFloat                          
+                          return (S $ return $ blockUniformName blockId off)
             shader (BConst _) = do
                           uniId <- getNextGlobal
-                          let uni = 'u' : show uniId
+                          let uni = "uu" ++ show uniId
                           tellGlobalDecl $ "uniform float " ++ uni                           
-                          return (S $ return uni)
-
+                          return (S $ return uni)                          
             setup (BConst a) =  do uniId <- getNextGlobal
-                                   liftIO $ glLoadUniformFloat uniId a
+                                   let uni = "uu" ++ show uniId
+                                   liftIO $ glLoadUniformFloat uni a
                                    return undefined
+            setup (B _ _) = error "Shouldnt be able to run setup on uniform value shader on non const B value"                                   
 
 
 glBindBufferToBlock :: Int -> Int -> IO ()
 glBindBufferToBlock = undefined    
 
 
-glLoadUniformFloat :: Int -> Float -> IO () 
+glLoadUniformFloat :: String -> Float -> IO () 
 glLoadUniformFloat = undefined