From 0cb0c752e25556ce8fbed390678e8367b490ef1a Mon Sep 17 00:00:00 2001 From: jgk Date: Sat, 12 Jun 2021 01:41:46 +0200 Subject: [PATCH] Start modularising shader code --- src/Picture/Preload.hs | 2 + src/Shader.hs | 199 +------------------------------------- src/Shader/AuxAddition.hs | 36 +++++++ src/Shader/Compile.hs | 123 +++++++++++++++++++++++ src/Shader/Parameters.hs | 15 +++ 5 files changed, 180 insertions(+), 195 deletions(-) create mode 100644 src/Shader/AuxAddition.hs create mode 100644 src/Shader/Compile.hs create mode 100644 src/Shader/Parameters.hs diff --git a/src/Picture/Preload.hs b/src/Picture/Preload.hs index d26926bba..98c3d2d93 100644 --- a/src/Picture/Preload.hs +++ b/src/Picture/Preload.hs @@ -8,6 +8,8 @@ module Picture.Preload where import Picture.Data import Shader +import Shader.Compile +import Shader.AuxAddition import Geometry.Data import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight) diff --git a/src/Shader.hs b/src/Shader.hs index 3bd531fb1..6261c5de3 100644 --- a/src/Shader.hs +++ b/src/Shader.hs @@ -1,18 +1,9 @@ module Shader - ( makeShader - , addTexture - , addUniforms - , pokeShaders + ( pokeShaders , pokeArrayOff - --, pokeShader , pokeShader' - --, bindArrayBuffers , bindArrayBuffers' , bindShaderBuffers - , makeSourcedShader - , setupVAO - , floatSize - , numDrawableElements , drawShader , drawShaders , setShaderUniforms @@ -25,15 +16,12 @@ module Shader where import Geometry import Shader.Data +import Shader.Parameters import MatrixHelper import Picture.Data import Foreign -import Codec.Picture -import qualified Data.ByteString as BS -import qualified Data.Vector.Storable as V -import Control.Monad (unless, forM, zipWithM_, forM_, foldM) -import Control.Lens +import Control.Monad import qualified Control.Foldl as F import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight) --import Text.RawString.QQ @@ -55,13 +43,8 @@ pokeShader' fs = F.FoldM (pokeRender' fls ptr stride) (return 0) return stride = sum $ _vboAttribSizes theVBO fls = _shaderPokeStrategy fs -pokeRender :: (RenderType -> [[[Float]]]) - -> [(Ptr Float,Int)] -> Int -> RenderType -> IO Int -pokeRender toFs ptrs n rt = pokeList ptrs n (toFs rt) - pokeRender' - :: (RenderType - -> [[[Float]]]) + :: (RenderType -> [[[Float]]]) -> Ptr Float -> Int -- ^ stride -> Int @@ -69,9 +52,6 @@ pokeRender' -> IO Int pokeRender' toFs ptr stride n rt = pokeList' ptr stride n (toFs rt) -pokeList :: [(Ptr Float,Int)] -> Int -> [[[Float]]] -> IO Int -pokeList ptrs = foldM (pokePtrs ptrs) - pokeList' :: Ptr Float -> Int -> Int -> [[[Float]]] -> IO Int pokeList' ptr stride = foldM (pokePtrs' ptr stride) @@ -80,23 +60,9 @@ pokePtrs' ptr stride n fss = do pokeArrayOff ptr (stride * n) (concat fss) return $ n + 1 -pokePtrs :: [(Ptr Float,Int)] -> Int -> [[Float]] -> IO Int -pokePtrs ptrIs n fss = do - zipWithM_ f ptrIs fss - return $ n + 1 - where - f (ptr,i) fs = pokeArrayOff ptr (i*n) fs - pokeArrayOff :: Storable a => Ptr a -> Int -> [a] -> IO () pokeArrayOff ptr i = zipWithM_ (pokeElemOff ptr) [i..] -bindArrayBuffers :: Int -> [(BufferObject,Ptr Float,Int)] -> IO () -{-# INLINE bindArrayBuffers #-} -bindArrayBuffers numVs ps = do - forM_ ps $ \(bo,ptr,i) -> do - bindBuffer ArrayBuffer $= Just bo - bufferData ArrayBuffer $= (fromIntegral $ floatSize * numVs * i, ptr, DynamicDraw) - bindArrayBuffers' :: Int -> VBO -> IO () bindArrayBuffers' numVs theVBO = do bindBuffer ArrayBuffer $= Just (_vbo theVBO) @@ -123,164 +89,7 @@ drawShader fs i = do _ -> return () drawArrays (_shaderDrawPrimitive fs) 0 (fromIntegral i) --- I am not sure if this assumes that the shader is constructed directly before --- the texture is added... -addTexture :: String -> FullShader -> IO (FullShader) -addTexture texturePath shad = do - Right cmap <- readImage texturePath - let tex = convertRGBA8 cmap - textureOb <- genObjectName - textureBinding Texture2D $= Just textureOb - let texData = V.toList $ imageData tex - wtex = fromIntegral $ imageWidth tex - htex = fromIntegral $ imageHeight tex - withArray texData $ \ptr -> do - texImage2D Texture2D NoProxy 0 RGBA8 (TextureSize2D wtex htex) 0 - (PixelData RGBA UnsignedByte ptr) - generateMipmap' Texture2D - textureFilter Texture2D $= ((Linear',Just Linear') , Nearest) - return $ shad & shaderTexture ?~ ShaderTexture {_textureObject = textureOb} -{- | -Compiles a full shader found within the shader directory. -The shader is made up of files begining with the inputted string with extensions .vert, .geom etc. --} -makeShader - :: String -- ^ First part of the name of the shader - -> [ShaderType] -- ^ Filetype extensions - -> [Int] -- ^ The input vertex sizes - -> PrimitiveMode - -> (RenderType -> [[[Float]]]) -- ^ Poke strategy: method for creating a list of vertex data to be bound - -> IO (FullShader) -makeShader s shaderlist sizes pm renStrat = do - (prog,unis) <- makeSourcedShader s shaderlist - vaob <- setupVAO sizes - return $ FullShader { _shaderProgram = prog - , _shaderMatrixUniform = unis - , _shaderVAO = vaob - , _shaderPokeStrategy = renStrat - , _shaderDrawPrimitive = pm - , _shaderTexture = Nothing - , _shaderCustomUnis = [] - } -floatSize :: Int -floatSize = sizeOf (0.5 :: GLfloat) -{-# INLINE floatSize #-} - -bufferOffset :: Integral a => a -> Ptr b -bufferOffset = plusPtr nullPtr . (* floatSize) . fromIntegral - -numDrawableElements :: Int -{-# INLINE numDrawableElements #-} -numDrawableElements = 50000 - -setupVAO :: [Int] -> IO VAO -setupVAO sizes = do - theVAO <- genObjectName - bindVertexArrayObject $= Just theVAO - vbos <- forM (zip (map fromIntegral [(0::Int)..]) sizes) setupArrayBuffer - ptrs <- forM (zip vbos sizes) setupVBOPointers - theVBO <- setupVBO $ sizes - return $ VAO - { _vao = theVAO - , _vaoVBO = theVBO - } - -setupVBO :: [Int] -> IO VBO -setupVBO sizes = do - vboName <- genObjectName - bindBuffer ArrayBuffer $= Just vboName - forM_ (zip3 [0..] sizes offs) $ \(loc,siz,off) -> do - setupVertexAttribPointer loc siz strd off - thePtr <- mallocArray (strd * numDrawableElements) - return $ VBO - { _vbo = vboName - , _vboPointer = thePtr - , _vboAttribSizes = sizes - } - where - strd = sum sizes - offs = scanl (+) 0 sizes - -{- | Assumes the correct VBO is bound -} -setupVertexAttribPointer - :: Int -- ^ Atrib location - -> Int -- ^ Size - -> Int -- ^ Stride - -> Int -- ^ Offset - -> IO () -setupVertexAttribPointer loc siz strd off = do - vertexAttribPointer (AttribLocation (fi loc)) $= - (ToFloat, VertexArrayDescriptor (fi' siz) Float (fi'' $ floatSize * strd) (bufferOffset off)) - vertexAttribArray (AttribLocation (fi loc)) $= Enabled - where - fi = fromIntegral - fi' = fromIntegral - fi'' = fromIntegral - -setupVBOPointers :: (BufferObject,Int) -> IO (BufferObject,Ptr Float,Int) -setupVBOPointers (vbo,vsize) = do - thePtr <- mallocArray (vsize * numDrawableElements) - return (vbo,thePtr,vsize) - -setupArrayBuffer :: (GLuint,Int) -> IO BufferObject -setupArrayBuffer (aloc,i) = do - vbo <- genObjectName - bindBuffer ArrayBuffer $= Just vbo - vertexAttribPointer (AttribLocation aloc) $= - ( ToFloat - , VertexArrayDescriptor (fromIntegral i) - Float - (fromIntegral $ floatSize * i) - (bufferOffset (0::Int)) - ) - vertexAttribArray (AttribLocation aloc) $= Enabled - return vbo - --- | Compile shader and get its uniform locations. --- supposes the shader code is in the shader folder, with the string names --- followed by .vert/.geom/.frag. -makeSourcedShader :: String -> [ShaderType] -> IO (Program, UniformLocation) -makeSourcedShader s sts = do - sources <- forM sts $ \st -> BS.readFile ("shader/" ++ s ++ shaderTypeExt st) - prog <- makeShaderProgram s $ zip sts sources - uniformLocations <- uniformLocation prog "worldMat" - return (prog,uniformLocations) - -addUniforms :: [String] -> FullShader -> IO (FullShader) -addUniforms uniStrings shad = do - uniLocs <- mapM (uniformLocation $ _shaderProgram shad) uniStrings - return $ shad & shaderCustomUnis %~ (++ uniLocs) - -shaderTypeExt :: ShaderType -> String -shaderTypeExt VertexShader = ".vert" -shaderTypeExt GeometryShader = ".geom" -shaderTypeExt FragmentShader = ".frag" -shaderTypeExt _ = undefined - -makeShaderProgram :: String -> [(ShaderType,BS.ByteString)] -> IO Program -makeShaderProgram str sources = do - theShaderProgram <- createProgram - shaders <- mapM (compileAndCheckShader str) sources - mapM_ (attachShader theShaderProgram) shaders - - linkProgram theShaderProgram - linkingSuccess <- linkStatus theShaderProgram - unless linkingSuccess $ do - infoLog <- get (programInfoLog theShaderProgram) - putStrLn $ str ++ ": Program Linking" ++ infoLog - return theShaderProgram - -compileAndCheckShader :: String -> (ShaderType,BS.ByteString) -> IO Shader -compileAndCheckShader str (theShaderType,sourceCode) = do - theShader <- createShader theShaderType - shaderSourceBS theShader $= sourceCode - compileShader theShader - success <- compileStatus theShader - unless success $ do - infoLog <- get (shaderInfoLog theShader) - putStrLn $ str ++ ": Shader compile: " ++ show theShaderType ++ " : " ++ show infoLog - return theShader resetShaderUniforms :: [(Program, UniformLocation)] -> IO () {-# INLINE resetShaderUniforms #-} diff --git a/src/Shader/AuxAddition.hs b/src/Shader/AuxAddition.hs new file mode 100644 index 000000000..ecf3a777b --- /dev/null +++ b/src/Shader/AuxAddition.hs @@ -0,0 +1,36 @@ +module Shader.AuxAddition + ( addTexture + , addUniforms + ) where +import Shader.Data + +import Foreign +import Codec.Picture +import qualified Data.Vector.Storable as V +import Control.Lens +import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight) +--import Text.RawString.QQ + +-- I am not sure if this assumes that the shader is constructed directly before +-- the texture is added... +addTexture :: String -> FullShader -> IO (FullShader) +addTexture texturePath shad = do + Right cmap <- readImage texturePath + let tex = convertRGBA8 cmap + textureOb <- genObjectName + textureBinding Texture2D $= Just textureOb + let texData = V.toList $ imageData tex + wtex = fromIntegral $ imageWidth tex + htex = fromIntegral $ imageHeight tex + withArray texData $ \ptr -> do + texImage2D Texture2D NoProxy 0 RGBA8 (TextureSize2D wtex htex) 0 + (PixelData RGBA UnsignedByte ptr) + generateMipmap' Texture2D + textureFilter Texture2D $= ((Linear',Just Linear') , Nearest) + return $ shad & shaderTexture ?~ ShaderTexture {_textureObject = textureOb} + + +addUniforms :: [String] -> FullShader -> IO (FullShader) +addUniforms uniStrings shad = do + uniLocs <- mapM (uniformLocation $ _shaderProgram shad) uniStrings + return $ shad & shaderCustomUnis %~ (++ uniLocs) diff --git a/src/Shader/Compile.hs b/src/Shader/Compile.hs new file mode 100644 index 000000000..4b96131eb --- /dev/null +++ b/src/Shader/Compile.hs @@ -0,0 +1,123 @@ +module Shader.Compile + ( makeShader + , makeSourcedShader + , setupVAO + ) where +import Shader.Data +import Shader.Parameters +import Picture.Data + +import Foreign +import qualified Data.ByteString as BS +import Control.Monad +--import Control.Lens +import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight) + +{- | +Compiles a full shader found within the shader directory. +The shader is made up of files begining with the inputted string with extensions .vert, .geom etc. +-} +makeShader + :: String -- ^ First part of the name of the shader + -> [ShaderType] -- ^ Filetype extensions + -> [Int] -- ^ The input vertex sizes + -> PrimitiveMode + -> (RenderType -> [[[Float]]]) -- ^ Poke strategy: method for creating a list of vertex data to be bound + -> IO (FullShader) +makeShader s shaderlist sizes pm renStrat = do + (prog,unis) <- makeSourcedShader s shaderlist + vaob <- setupVAO sizes + return $ FullShader { _shaderProgram = prog + , _shaderMatrixUniform = unis + , _shaderVAO = vaob + , _shaderPokeStrategy = renStrat + , _shaderDrawPrimitive = pm + , _shaderTexture = Nothing + , _shaderCustomUnis = [] + } + +-- | Compile shader and get its uniform locations. +-- supposes the shader code is in the shader folder, with the string names +-- followed by .vert/.geom/.frag. +makeSourcedShader :: String -> [ShaderType] -> IO (Program, UniformLocation) +makeSourcedShader s sts = do + sources <- forM sts $ \st -> BS.readFile ("shader/" ++ s ++ shaderTypeExt st) + prog <- makeShaderProgram s $ zip sts sources + uniformLocations <- uniformLocation prog "worldMat" + return (prog,uniformLocations) + +shaderTypeExt :: ShaderType -> String +shaderTypeExt VertexShader = ".vert" +shaderTypeExt GeometryShader = ".geom" +shaderTypeExt FragmentShader = ".frag" +shaderTypeExt _ = undefined + +setupVAO :: [Int] -> IO VAO +setupVAO sizes = do + theVAO <- genObjectName + bindVertexArrayObject $= Just theVAO + theVBO <- setupVBO $ sizes + return $ VAO + { _vao = theVAO + , _vaoVBO = theVBO + } + +setupVBO :: [Int] -> IO VBO +setupVBO sizes = do + vboName <- genObjectName + bindBuffer ArrayBuffer $= Just vboName + forM_ (zip3 [0..] sizes offs) $ \(loc,siz,off) -> do + setupVertexAttribPointer loc siz strd off + thePtr <- mallocArray (strd * numDrawableElements) + return $ VBO + { _vbo = vboName + , _vboPointer = thePtr + , _vboAttribSizes = sizes + } + where + strd = sum sizes + offs = scanl (+) 0 sizes + +{- | Assumes the correct VBO is bound -} +setupVertexAttribPointer + :: Int -- ^ Atrib location + -> Int -- ^ Size + -> Int -- ^ Stride + -> Int -- ^ Offset + -> IO () +setupVertexAttribPointer loc siz strd off = do + vertexAttribPointer (AttribLocation (fi loc)) $= + (ToFloat, VertexArrayDescriptor (fi' siz) Float (fi'' $ floatSize * strd) (bufferOffset off)) + vertexAttribArray (AttribLocation (fi loc)) $= Enabled + where + fi = fromIntegral + fi' = fromIntegral + fi'' = fromIntegral + +makeShaderProgram :: String -> [(ShaderType,BS.ByteString)] -> IO Program +makeShaderProgram str sources = do + theShaderProgram <- createProgram + shaders <- mapM (compileAndCheckShader str) sources + mapM_ (attachShader theShaderProgram) shaders + + linkProgram theShaderProgram + linkingSuccess <- linkStatus theShaderProgram + unless linkingSuccess $ do + infoLog <- get (programInfoLog theShaderProgram) + putStrLn $ str ++ ": Program Linking" ++ infoLog + return theShaderProgram + +compileAndCheckShader :: String -> (ShaderType,BS.ByteString) -> IO Shader +compileAndCheckShader str (theShaderType,sourceCode) = do + theShader <- createShader theShaderType + shaderSourceBS theShader $= sourceCode + compileShader theShader + success <- compileStatus theShader + unless success $ do + infoLog <- get (shaderInfoLog theShader) + putStrLn $ str ++ ": Shader compile: " ++ show theShaderType ++ " : " ++ show infoLog + return theShader + +bufferOffset :: Integral a => a -> Ptr b +bufferOffset = plusPtr nullPtr . (* floatSize) . fromIntegral + diff --git a/src/Shader/Parameters.hs b/src/Shader/Parameters.hs new file mode 100644 index 000000000..d608a08e0 --- /dev/null +++ b/src/Shader/Parameters.hs @@ -0,0 +1,15 @@ +module Shader.Parameters + ( floatSize + , numDrawableElements + ) where +import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight) +import Foreign + +floatSize :: Int +floatSize = sizeOf (0.5 :: GLfloat) +{-# INLINE floatSize #-} + +numDrawableElements :: Int +{-# INLINE numDrawableElements #-} +numDrawableElements = 50000 +