Start modularising shader code
This commit is contained in:
@@ -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)
|
||||
|
||||
+4
-195
@@ -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 #-}
|
||||
|
||||
@@ -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)
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user