Permalink
Browse files

Fixing uniforms to work with multiple uses of same B value

Naming uniform blocks
First try at implementing default uniforms (might delete it completely)
  • Loading branch information...
1 parent b5d35f1 commit 1ea87f2bf9db72c8c8a9141eeb6b3271f69193bc @tobbebex committed Apr 24, 2012
Showing with 51 additions and 33 deletions.
  1. +24 −12 GPipe-Core/src/Graphics/GPipe/Shader.hs
  2. +27 −21 GPipe-Core/src/Graphics/GPipe/Uniform.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
@@ -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

0 comments on commit 1ea87f2

Please sign in to comment.