GPipe 1.0.2 → 1.0.3
raw patch · 3 files changed
+77/−51 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- GPipe.cabal +1/−1
- src/Resources.hs +28/−6
- src/Shader.hs +48/−44
GPipe.cabal view
@@ -1,5 +1,5 @@ name: GPipe-version: 1.0.2+version: 1.0.3 cabal-version: >= 1.2.3 build-type: Simple license: BSD3
src/Resources.hs view
@@ -23,6 +23,7 @@ VertexBuffer(..), IndexBuffer(..), UniformLocationSet, + UniformState(..), ContextCacheIO, ContextCache(contextWindow,contextViewPort), newContextCache, @@ -36,7 +37,6 @@ Filter(..), EdgeMode(..), SamplerType(..), - UniformSet, cubeMapTargets, getContextCache, saveContextCache, @@ -68,15 +68,26 @@ import Control.Exception (evaluate) import Foreign.ForeignPtr import System.Mem.Weak (addFinalizer)+import Data.Unique data VertexBuffer = VertexBuffer BufferObject Int data IndexBuffer = IndexBuffer BufferObject Int DataType type UniformLocationSet = (UniformLocation,UniformLocation,UniformLocation, Map SamplerType UniformLocation) -type UniformSet = ([Float],[Int],[Bool], [(SamplerType, [(Sampler,WinMappedTexture)])]) data SamplerType = Sampler3D | Sampler2D | Sampler1D | SamplerCube deriving (Eq, Ord, Enum, Bounded) +data UniformState = UniformState + { + floatUniforms :: Map Unique Float, + intUniforms :: Map Unique Int, + boolUniforms :: Map Unique Bool, + sampler3DUniforms :: Map Unique (Sampler, WinMappedTexture), + sampler2DUniforms :: Map Unique (Sampler, WinMappedTexture), + sampler1DUniforms :: Map Unique (Sampler, WinMappedTexture), + samplerCubeUniforms :: Map Unique (Sampler, WinMappedTexture) + } deriving Eq + -- | A structure describing how a texture is sampled data Sampler = Sampler Filter EdgeMode deriving (Eq, Ord) -- | Filter mode used in sampler state @@ -221,16 +232,27 @@ useProgramResource :: Program -> ContextCacheIO () useProgramResource p = liftIO $ currentProgram $= Just p -useUniforms :: UniformLocationSet -> UniformSet -> ContextCacheIO () -useUniforms (fu,iu,bu,su) (f,i,b,s) = do +useUniforms :: UniformLocationSet -> UniformState -> ContextCacheIO () +useUniforms (fu,iu,bu,su) uns = do w <- asks contextWindow liftIO $ do unless (null f) $ withArray (map (TexCoord1 . realToFrac) f :: [TexCoord1 GLfloat]) $ uniformv fu (fromIntegral $ length f) unless (null i) $ withArray (map (TexCoord1 . fromIntegral) i :: [TexCoord1 GLint]) $ uniformv iu (fromIntegral $ length i) unless (null b) $ withArray (map (TexCoord1 . fromBool) b :: [TexCoord1 GLint]) $ uniformv bu (fromIntegral $ length b) - mapM_ (useSampler w) s + unless (null s3) $ useSampler w Sampler3D s3 + unless (null s2) $ useSampler w Sampler2D s2 + unless (null s1) $ useSampler w Sampler1D s1 + unless (null sc) $ useSampler w SamplerCube sc where - useSampler w (t, xs) = do + f = Map.elems $ floatUniforms uns + i = Map.elems $ intUniforms uns + b = Map.elems $ boolUniforms uns + s3 = Map.elems $ sampler3DUniforms uns + s2 = Map.elems $ sampler2DUniforms uns + s1 = Map.elems $ sampler1DUniforms uns + sc = Map.elems $ samplerCubeUniforms uns + + useSampler w t xs = do let texs = nub xs samplers <- mapM (createSampler w t) $ zip texs [0..] let texToSamp = zip texs samplers
src/Shader.hs view
@@ -15,9 +15,7 @@ module Shader ( GPU(..), Shader, - Uniform(..), addInput, - addUniform, runShader, vertexProgram, fragmentProgram, @@ -61,8 +59,18 @@ -- | Converts a value from the CPU to the GPU. toGPU :: CPU a -> a -type Shader = State (Map Unique Uniform, IntSet) +type Shader = State (UniformState, IntSet) + +setFloatUniforms a = modify $ first $ \ u -> u{floatUniforms=a} +setIntUniforms a = modify $ first $ \ u -> u{intUniforms=a} +setBoolUniforms a = modify $ first $ \ u -> u{boolUniforms=a} +setSampler3DUniforms a = modify $ first $ \ u -> u{sampler3DUniforms=a} +setSampler2DUniforms a = modify $ first $ \ u -> u{sampler2DUniforms=a} +setSampler1DUniforms a = modify $ first $ \ u -> u{sampler1DUniforms=a} +setSamplerCubeUniforms a = modify $ first $ \ u -> u{samplerCubeUniforms=a} + + vertexProgram vPos rast fins = let ((pos, outs), uns, ins) = runShader $ do vPos' <- vPos rast' <- selectM fins rast return (vPos', rast') @@ -113,12 +121,17 @@ ++ "gl_FragDepth=" ++ d' ++ ";\n" ++ "gl_FragColor=vec4(" ++ r' ++ "," ++ g' ++ "," ++ b' ++ "," ++ a' ++ ");\n" -uniformDecls :: String -> UniformSet -> String -uniformDecls p (f,i,b,s) = let makeU tn xs = if not $ null xs - then "uniform " ++ tn ++ p ++ "[" ++ show (length xs) ++ "];\n" - else "" - in makeU "float f" f ++ makeU "int i" i ++ makeU "bool b" b ++ - concatMap (\(t,xs) -> makeU (samplerTypeString t ++ " s" ++ show (fromEnum t)) xs) s +uniformDecls :: String -> UniformState -> String +uniformDecls p uns = makeU "float f" floatUniforms ++ + makeU "int i" intUniforms ++ + makeU "bool b" boolUniforms ++ + makeU "sampler3D s3" sampler3DUniforms ++ + makeU "sampler2D s2" sampler2DUniforms ++ + makeU "sampler1D s1" sampler1DUniforms ++ + makeU "samplerCube sc" samplerCubeUniforms + where makeU tn f = if Map.null (f uns) + then "" + else "uniform " ++ tn ++ p ++ "[" ++ show (Map.size (f uns)) ++ "];\n" -- Generates e.g. [(0,4), (1,4), (2,3)] from [x,x,x,x,x,x,x,x,x,x,x] (length 11) inputVecs ins = [(i,min (length ins - i*4) 4) | i <- [0..(length ins - 1) `div` 4]] @@ -137,71 +150,62 @@ tName :: Int -> String tName 1 = "float" tName x = "vec" ++ show x - -data Uniform = FloatUniform Float - | IntUniform Int - | BoolUniform Bool - | SamplerUniform SamplerType Sampler WinMappedTexture -samplerTypeString Sampler3D = "sampler3D" -samplerTypeString Sampler2D = "sampler2D" -samplerTypeString Sampler1D = "sampler1D" -samplerTypeString SamplerCube = "samplerCube" + vSampleFunc f t s tex c xs = toColor $ fromVVec 4 (vListFunc f $ [addVertexSamplerUniform t s tex, vVec c] ++ xs) fSampleFunc f t s tex c xs = toColor $ fromFVec 4 (fListFunc f $ [addFragmentSamplerUniform t s tex, fVec c] ++ xs) -addVertexSamplerUniform t s = Vertex . addUniform ("s" ++ show (fromEnum t) ++ "vu") . SamplerUniform t s -addFragmentSamplerUniform t s = Fragment . addUniform ("s" ++ show (fromEnum t) ++ "fu") . SamplerUniform t s +addVertexSamplerUniform Sampler3D s t = Vertex $ addUniform "s3vu" sampler3DUniforms setSampler3DUniforms (s,t) +addVertexSamplerUniform Sampler2D s t = Vertex $ addUniform "s2vu" sampler2DUniforms setSampler2DUniforms (s,t) +addVertexSamplerUniform Sampler1D s t = Vertex $ addUniform "s1vu" sampler1DUniforms setSampler1DUniforms (s,t) +addVertexSamplerUniform SamplerCube s t = Vertex $ addUniform "scvu" samplerCubeUniforms setSamplerCubeUniforms (s,t) +addFragmentSamplerUniform Sampler3D s t = Fragment $ addUniform "s3fu" sampler3DUniforms setSampler3DUniforms (s,t) +addFragmentSamplerUniform Sampler2D s t = Fragment $ addUniform "s2fu" sampler2DUniforms setSampler2DUniforms (s,t) +addFragmentSamplerUniform Sampler1D s t = Fragment $ addUniform "s1fu" sampler1DUniforms setSampler1DUniforms (s,t) +addFragmentSamplerUniform SamplerCube s t = Fragment $ addUniform "scfu" samplerCubeUniforms setSamplerCubeUniforms (s,t) -- | An opaque type constructor for atomic values in a vertex on the GPU, e.g. 'Vertex' 'Float'. newtype Vertex a = Vertex { fromVertex :: Shader String } -- | An opaque type constructor for atomic values in a fragment on the GPU, e.g. 'Fragment' 'Float'. newtype Fragment a = Fragment { fromFragment :: Shader String } -runShader :: Shader a -> (a, UniformSet, [Int]) -runShader m = (a, getSamplerList $ splitSet ([],[],[], Map.empty) $ reverse $ Map.elems $ fst s, IntSet.toAscList $ snd s) - where (a,s) = runState m (Map.empty, IntSet.empty) - splitSet (f,i,b,s) (FloatUniform u:xs) = splitSet (u:f,i,b,s) xs - splitSet (f,i,b,s) (IntUniform u:xs) = splitSet (f,u:i,b,s) xs - splitSet (f,i,b,s) (BoolUniform u:xs) = splitSet (f,i,u:b,s) xs - splitSet (f,i,b,s) (SamplerUniform t samp tex:xs) = splitSet (f,i,b, Map.insertWith (++) t [(samp,tex)] s) xs - splitSet s [] = s - getSamplerList (f,i,b,s) = (f,i,b, Map.toList s) - +runShader :: Shader a -> (a, UniformState, [Int]) +runShader m = (a, fst s, IntSet.toAscList $ snd s) + where (a,s) = runState m (UniformState Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty, IntSet.empty) addInput :: Int -> Shader () addInput = modify . second . IntSet.insert-addUniform :: String -> Uniform -> Shader String -addUniform p u = do x <- gets fst - case Map.lookupIndex n x of - Nothing -> do let x' = Map.insert n u' x - s = Map.findIndex n x' - modify $ first $ const x' - return $ p ++ "[" ++ show s ++ "]" - Just i -> return $ p ++ "[" ++ show i ++ "]" + +addUniform p getter setter u = do x <- gets (getter . fst) + case Map.lookupIndex n x of + Nothing -> do let x' = Map.insert n u' x + s = Map.findIndex n x' + setter x' + return $ p ++ "[" ++ show s ++ "]" + Just i -> return $ p ++ "[" ++ show i ++ "]" where (n,u') = unsafePerformIO $ do n <- newUnique return (n,u) --wire u to make it happen as often as we want... instance GPU (Vertex Float) where type CPU (Vertex Float) = Float - toGPU = Vertex . addUniform "fvu" . FloatUniform + toGPU = Vertex . addUniform "fvu" floatUniforms setFloatUniforms instance GPU (Vertex Int) where type CPU (Vertex Int) = Int - toGPU = Vertex . addUniform "ivu" . IntUniform + toGPU = Vertex . addUniform "ivu" intUniforms setIntUniforms instance GPU (Vertex Bool) where type CPU (Vertex Bool) = Bool - toGPU = Vertex . addUniform "bvu" . BoolUniform + toGPU = Vertex . addUniform "bvu" boolUniforms setBoolUniforms instance GPU (Fragment Float) where type CPU (Fragment Float) = Float - toGPU = Fragment . addUniform "ffu" . FloatUniform + toGPU = Fragment . addUniform "ffu" floatUniforms setFloatUniforms instance GPU (Fragment Int) where type CPU (Fragment Int) = Int - toGPU = Fragment . addUniform "ifu" . IntUniform + toGPU = Fragment . addUniform "ifu" intUniforms setIntUniforms instance GPU (Fragment Bool) where type CPU (Fragment Bool) = Bool - toGPU = Fragment . addUniform "bfu" . BoolUniform + toGPU = Fragment . addUniform "bfu" boolUniforms setBoolUniforms instance GPU () where