justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Move shader compilation over to raw opengl, errors display incorrect

Browse Source
This commit is contained in:
justin
2023-03-07 15:40:29 +00:00
parent e6ec46edce
commit 3e3fd049a9
12 changed files with 338 additions and 121 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Shader/AuxAddition.hs
+76 -1
View File
@@ -1,13 +1,20 @@
module Shader.AuxAddition
( addTexture
, addTexture'
, addTextureNoFilter
, vaddTextureNoFilter
, vaddTextureNoFilter'
, addTextureArray
, addTextureArray'
, addUniforms
, addUniforms'
, tilesToLine -- ^ kept in case it is needed in the future
) where
import Shader.Data
import Foreign.Marshal
import Control.Monad
import qualified Data.ByteString as BS
import Data.ByteString.Char8 (pack)
import qualified Data.Vector as V
import Data.List.Extra
import Codec.Picture
@@ -37,6 +44,25 @@ addTexture texturePath shad = do
,_textureTarget = GL_TEXTURE_2D
}
addTexture' :: String -> FullShader' -> IO FullShader'
addTexture' texturePath shad = do
Right cmap <- readImage texturePath
let tex = convertRGBA8 cmap
textureOb <- genObjectName
textureBinding Texture2D $= Just textureOb
let wtex = fromIntegral $ imageWidth tex
htex = fromIntegral $ imageHeight tex
glTexStorage2D GL_TEXTURE_2D 3 GL_RGBA8 wtex htex
VS.unsafeWith (imageData tex) $ \ptr -> do
glTexSubImage2D GL_TEXTURE_2D 0 0 0 wtex htex GL_RGBA GL_UNSIGNED_BYTE ptr
--textureFilter Texture2DArray $= ((Linear',Just Linear') , Linear')
textureFilter Texture2D $= ((Linear',Just Linear') , Linear')
generateMipmap' Texture2D
return $ shad & shadTex' ?~ ShaderTexture
{_textureObject = textureOb
,_textureTarget = GL_TEXTURE_2D
}
vaddTextureNoFilter :: String -> FullShader -> IO FullShader
vaddTextureNoFilter texturePath shad = do
Right cmap <- readImage texturePath
@@ -54,6 +80,23 @@ vaddTextureNoFilter texturePath shad = do
, _textureTarget = GL_TEXTURE_2D
}
vaddTextureNoFilter' :: String -> FullShader' -> IO FullShader'
vaddTextureNoFilter' texturePath shad = do
Right cmap <- readImage texturePath
let tex = convertRGBA8 cmap
textureOb <- genObjectName
textureBinding Texture2D $= Just textureOb
textureFilter Texture2D $= ((Nearest,Nothing) , Nearest)
let wtex = fromIntegral $ imageWidth tex
htex = fromIntegral $ imageHeight tex
glTexStorage2D GL_TEXTURE_2D 1 GL_RGBA8 wtex htex
VS.unsafeWith (imageData tex) $ \ptr -> do
glTexSubImage2D GL_TEXTURE_2D 0 0 0 wtex htex GL_RGBA GL_UNSIGNED_BYTE ptr
return $ shad & shadTex' ?~ ShaderTexture
{ _textureObject = textureOb
, _textureTarget = GL_TEXTURE_2D
}
addTextureNoFilter :: String -> FullShader -> IO FullShader
addTextureNoFilter texturePath shad = do
Right cmap <- readImage texturePath
@@ -95,6 +138,27 @@ addTextureArray texturePath shad = do
{ _textureObject = textureOb
, _textureTarget = GL_TEXTURE_2D_ARRAY
}
addTextureArray' :: String -> FullShader' -> IO FullShader'
addTextureArray' texturePath shad = do
textureOb <- genObjectName
textureBinding Texture2DArray $= Just textureOb
Right cmap <- readImage texturePath
let tex = convertRGBA8 cmap
--let texData = tilesToLine 8 128 .
--let texData = tilesToLine 8 128 .
-- V.toList $ imageData tex
glTexStorage3D GL_TEXTURE_2D_ARRAY 3 GL_RGBA8 32 32 64
--writePng "atest.png" ((Image 256 256 (V.fromList texData)) :: Image PixelRGBA8)
--withArray texData $ \ptr -> do
VS.unsafeWith (imageData tex) $ \ptr -> do
--glTexSubImage3D GL_TEXTURE_2D_ARRAY 0 0 0 0 32 32 64 GL_RGBA GL_UNSIGNED_BYTE ptr
glTexSubImage3D GL_TEXTURE_2D_ARRAY 0 0 0 0 32 32 64 GL_RGBA GL_UNSIGNED_BYTE ptr
textureFilter Texture2DArray $= ((Linear',Just Linear') , Linear')
generateMipmap' Texture2DArray
return $ shad & shadTex' ?~ ShaderTexture
{ _textureObject = textureOb
, _textureTarget = GL_TEXTURE_2D_ARRAY
}
-- I am completely unclear on why this works with its current parameters
tilesToLine
@@ -108,3 +172,14 @@ addUniforms :: [String] -> FullShader -> IO FullShader
addUniforms uniStrings shad = do
uniLocs <- mapM (uniformLocation $ _shadProg shad) uniStrings
return $ shad & shadUnis %~ (V.++ V.fromList uniLocs)
addUniforms' :: [String] -> FullShader' -> IO FullShader'
addUniforms' uniStrings shad = do foldM addUniform' shad uniStrings
-- uniLocs <- mapM (uniformLocation $ _shadProg shad) uniStrings
-- return $ shad & shadUnis' %~ (V.++ V.fromList uniLocs)
addUniform' :: FullShader' -> String -> IO FullShader'
addUniform' shad unistr = BS.useAsCString (pack unistr) $ \cstr -> do
loc <- glGetUniformLocation (_shadProg' shad) cstr
return $ shad & shadUnis' %~ (V.++ V.fromList [loc])
src/Shader/Bind.hs
+12 -6
View File
@@ -1,6 +1,7 @@
module Shader.Bind
( bindShaderLayers
, bindShaderBuffers
, bindShaderBuffers'
, bindShader
) where
import Shader.Data
@@ -25,11 +26,11 @@ bindArrayBuffers numVs theVBO = do
(fromIntegral $ floatSize * numVs * sum (_vboAttribSizes theVBO))
(_vboPtr theVBO)
bindShaderLayers :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> IO ()
bindShaderLayers :: MV.MVector (PrimState IO) FullShader' -> UMV.MVector (PrimState IO) Int -> IO ()
bindShaderLayers shads counts = MV.imapM_ f shads
where
f i shad = do
let theVBO = _vaoVBO $ _shadVAO shad
let theVBO = _vaoVBO $ _shadVAO' shad
stride = sum $ _vboAttribSizes theVBO
bindBuffer ArrayBuffer $= (Just . _vbo $ theVBO)
VFSM.mapM_ (g stride theVBO) $ VFSM.enumFromStepN 0 1 6 -- [0..5]
@@ -45,12 +46,17 @@ bindShaderLayers shads counts = MV.imapM_ f shads
(fromIntegral $ floatSize * numVs * stride)
(_vboPtr theVBO `plusPtr` (floatSize * stride * numSubElements * lay))
bindShader :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> IO ()
bindShader :: MV.MVector (PrimState IO) FullShader' -> UMV.MVector (PrimState IO) Int -> IO ()
bindShader shads counts = MV.imapM_ f shads
where
f i shad = UMV.read counts i >>= flip bindArrayBuffers (_vaoVBO . _shadVAO $ shad)
f i shad = UMV.read counts i >>= flip bindArrayBuffers (_vaoVBO . _shadVAO' $ shad)
bindShaderBuffers :: [FullShader] -> [Int] -> IO ()
bindShaderBuffers :: [FullShader'] -> [Int] -> IO ()
bindShaderBuffers = zipWithM_ f
where
f fs i = bindArrayBuffers i $ _vaoVBO $ _shadVAO fs
f fs i = bindArrayBuffers i $ _vaoVBO $ _shadVAO' fs
bindShaderBuffers' :: [FullShader'] -> [Int] -> IO ()
bindShaderBuffers' = zipWithM_ f
where
f fs i = bindArrayBuffers i $ _vaoVBO $ _shadVAO' fs
src/Shader/Compile.hs
+108 -5
View File
@@ -1,10 +1,16 @@
module Shader.Compile
( makeShader
, makeShader'
, makeByteStringShader
, makeByteStringShader'
, makeByteStringShaderUsingVAO
, makeByteStringShaderUsingVAO'
, makeShaderSized
, makeShaderSized'
, makeShaderUsingShaderVAO
, makeShaderUsingShaderVAO'
, makeShaderUsingVAO
, makeShaderUsingVAO'
, makeSourcedShader
, setupVAO
, setupVertexAttribPointer
@@ -39,6 +45,22 @@ makeShader s shaderlist sizes pm = do
, _shadTex = Nothing
, _shadUnis = mempty
}
makeShader'
:: String -- ^ First part of the name of the shader
-> [GLenum] -- ^ shader types
-> [Int] -- ^ The input vertex sizes
-> EPrimitiveMode
-> IO FullShader'
makeShader' s shaderlist sizes pm = do
prog <- makeSourcedShader' s shaderlist
vaob <- setupVAO sizes
return $ FullShader'
{ _shadProg' = prog
, _shadVAO' = vaob
, _shadPrim' = pm
, _shadTex' = Nothing
, _shadUnis' = mempty
}
makeByteStringShader'
:: String -- ^ (Arbitrary) name of the shader
@@ -88,6 +110,21 @@ makeByteStringShaderUsingVAO s shaderlist pm fs = do
, _shadUnis = mempty
}
makeByteStringShaderUsingVAO'
:: String -- ^ (Arbitrary) name of the shader
-> [(GLenum,BS.ByteString)] -- ^ Filetype extensions and shader data
-> EPrimitiveMode
-> FullShader'
-> IO FullShader'
makeByteStringShaderUsingVAO' s shaderlist pm fs = do
prog <- makeShaderProgram' s shaderlist
return $ fs
{ _shadProg' = prog
, _shadPrim' = pm
, _shadTex' = Nothing
, _shadUnis' = mempty
}
-- | Takes the VAO from elsewhere
makeShaderUsingVAO
:: String -- ^ First part of the name of the shader
@@ -104,6 +141,21 @@ makeShaderUsingVAO s shaderlist pm theVAO = do
, _shadTex = Nothing
, _shadUnis = mempty
}
makeShaderUsingVAO'
:: String -- ^ First part of the name of the shader
-> [GLenum] -- ^ shader types
-> EPrimitiveMode
-> VAO
-> IO FullShader'
makeShaderUsingVAO' s shaderlist pm theVAO = do
prog <- makeSourcedShader' s shaderlist
return $ FullShader'
{ _shadProg' = prog
, _shadVAO' = theVAO
, _shadPrim' = pm
, _shadTex' = Nothing
, _shadUnis' = mempty
}
-- | Takes the VAO from another shader
makeShaderUsingShaderVAO
@@ -120,6 +172,20 @@ makeShaderUsingShaderVAO s shaderlist pm fs = do
, _shadTex = Nothing
, _shadUnis = mempty
}
makeShaderUsingShaderVAO'
:: String -- ^ First part of the name of the shader
-> [GLenum] -- ^ shader types
-> EPrimitiveMode
-> FullShader'
-> IO FullShader'
makeShaderUsingShaderVAO' s shaderlist pm fs = do
prog <- makeSourcedShader' s shaderlist
return $ fs
{ _shadProg' = prog
, _shadPrim' = pm
, _shadTex' = Nothing
, _shadUnis' = mempty
}
{- |
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.
@@ -141,6 +207,23 @@ makeShaderSized s shaderlist sizes ndraw pm = do
, _shadTex = Nothing
, _shadUnis = mempty
}
makeShaderSized'
:: String -- ^ First part of the name of the shader
-> [GLenum] -- ^ shader types
-> [Int] -- ^ The input vertex sizes
-> Int -- ^ Number of vertexes that can be poked
-> EPrimitiveMode
-> IO FullShader'
makeShaderSized' s shaderlist sizes ndraw pm = do
prog <- makeSourcedShader' s shaderlist
vaob <- setupVAOSized sizes ndraw
return $ FullShader'
{ _shadProg' = prog
, _shadVAO' = vaob
, _shadPrim' = pm
, _shadTex' = Nothing
, _shadUnis' = mempty
}
-- | Compile shader and get its uniform locations.
-- supposes the shader code is in the shader folder, with the string names
@@ -150,13 +233,24 @@ makeSourcedShader s sts = do
sources <- forM sts $ \st -> BS.readFile ("shader/" ++ s ++ shaderTypeExt st)
makeShaderProgram s $ zip sts sources
makeSourcedShader' :: String -> [GLenum] -> IO GLuint
makeSourcedShader' s sts = do
sources <- forM sts $ \st -> BS.readFile ("shader/" ++ s ++ shaderTypeExt' st)
makeShaderProgram' s $ zip sts sources
shaderTypeExt :: ShaderType -> String
shaderTypeExt VertexShader = ".vert"
shaderTypeExt GeometryShader = ".geom"
shaderTypeExt FragmentShader = ".frag"
shaderTypeExt _ = undefined
-- I think that this requires that the correct shader program is bound...
shaderTypeExt' :: GLenum -> String
shaderTypeExt' GL_VERTEX_SHADER = ".vert"
shaderTypeExt' GL_GEOMETRY_SHADER = ".geom"
shaderTypeExt' GL_FRAGMENT_SHADER = ".frag"
shaderTypeExt' _ = undefined
-- I think that this requires that the correct shader program is bound?
setupVAO :: [Int] -> IO VAO
setupVAO sizes = do
theVAO <- genObjectName
@@ -244,12 +338,20 @@ makeShaderProgram' :: String
makeShaderProgram' str srcs = do
theprog <- glCreateProgram
shaders <- mapM (compileAndCheckShader' str) srcs
mapM_ (glAttachShader theprog) shaders
glLinkProgram theprog
glCheckError str glGetProgramiv glGetProgramInfoLog theprog GL_LINK_STATUS
mapM (glDetachShader theprog) shaders
mapM glDeleteShader shaders
glCheckError (str ++ " linking ") glGetProgramiv glGetProgramInfoLog theprog GL_LINK_STATUS
mapM_ (glDetachShader theprog) shaders
mapM_ glDeleteShader shaders
return theprog
glCheckError :: (Storable t1, Storable a1, Show a1) =>
[Char]
-> (t2 -> GLenum -> Ptr t1 -> IO ())
-> (t2 -> t1 -> Ptr a3 -> Ptr a1 -> IO ())
-> t2
-> GLenum
-> IO ()
glCheckError str f g x statustype =
alloca $ \statusPtr -> do
f x statustype statusPtr
@@ -294,7 +396,7 @@ compileAndCheckShader' str (theShaderType,sourceCode) = do
theShader <- glCreateShader theShaderType
setShaderSource theShader sourceCode
glCompileShader theShader
glCheckError str glGetShaderiv glGetShaderInfoLog theShader GL_COMPILE_STATUS
glCheckError (str ++ shaderTypeExt' theShaderType) glGetShaderiv glGetShaderInfoLog theShader GL_COMPILE_STATUS
return theShader
setShaderSource :: GLuint -> BS.ByteString -> IO ()
@@ -305,6 +407,7 @@ setShaderSource si src =
glShaderSource si 1 srcPtrBuf srcLengthBuf
-- https://hackage.haskell.org/package/OpenGL-3.0.3.0/docs/src/Graphics.Rendering.OpenGL.GL.ByteString.html#withByteStringP
withByteString :: Num t => BS.ByteString -> (Ptr b -> t -> IO a) -> IO a
withByteString bs act =
BU.unsafeUseAsCStringLen bs $ \(ptr, size) ->
act (castPtr ptr) (fromIntegral size)
src/Shader/Data.hs
+10 -2
View File
@@ -33,9 +33,13 @@ module Shader.Data
, vert
, geom
, frag
, vert'
, geom'
, frag'
) where
import Data.Vector (Vector)
import Graphics.Rendering.OpenGL
import Graphics.GL.Core43
import Foreign
import Control.Lens
{- | Datatype containing the necessary information for a single shader. -}
@@ -47,11 +51,11 @@ data FullShader = FullShader
, _shadUnis :: Vector UniformLocation
}
data FullShader' = FullShader'
{ _shadProg' :: GLuint
{ _shadProg' :: GLuint -- should be shaderID
, _shadVAO' :: VAO
, _shadPrim' :: EPrimitiveMode
, _shadTex' :: Maybe ShaderTexture
, _shadUnis' :: Vector UniformLocation
, _shadUnis' :: Vector GLint
}
{- | Vertex array object: contains the reference to the object,
and its buffer targets. -}
@@ -96,6 +100,10 @@ vert, geom, frag :: ShaderType
vert = VertexShader
geom = GeometryShader
frag = FragmentShader
vert', geom', frag' :: GLenum
vert' = GL_VERTEX_SHADER
geom' = GL_GEOMETRY_SHADER
frag' = GL_FRAGMENT_SHADER
makeLenses ''VAO
makeLenses ''VBO
makeLenses ''FullShader
src/Shader/Poke.hs
+6 -6
View File
@@ -25,17 +25,17 @@ import Control.Monad.Primitive
--import qualified Control.Monad.Parallel as MP
pokeVerxs
:: MV.MVector (PrimState IO) FullShader
:: MV.MVector (PrimState IO) FullShader'
-> UMV.MVector (PrimState IO) Int
-> Picture
-> IO ()
--pokeVerxs vbos count = S.mapM_ (pokeVerx vbos count) . S.each
pokeVerxs vbos count = VFSM.mapM_ (pokeVerx vbos count) . VFSM.fromList
pokeVerx :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> Verx -> IO ()
pokeVerx :: MV.MVector (PrimState IO) FullShader' -> UMV.MVector (PrimState IO) Int -> Verx -> IO ()
pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=theShadNum} = do
typeOff <- UMV.unsafeRead offsets sn
basePtr <- _vboPtr . _vaoVBO . _shadVAO <$> MV.unsafeRead vbos sn
basePtr <- _vboPtr . _vaoVBO . _shadVAO' <$> MV.unsafeRead vbos sn
let thePtr = plusPtr basePtr (typeOff * pokeStride sn * floatSize)
poke34 thePtr thePos theCol
pokeArrayOff thePtr 7 ext
@@ -183,18 +183,18 @@ pokeJustV ptr nv sh = do
V4 d e f g = _svCol sh
pokeLayVerxs
:: MV.MVector (PrimState IO) FullShader
:: MV.MVector (PrimState IO) FullShader'
-> UMV.MVector (PrimState IO) Int
-> Picture
-> IO ()
--pokeLayVerxs vbos counts = S.mapM_ (pokeLayVerx vbos counts) . S.each
pokeLayVerxs vbos counts = VFSM.mapM_ (pokeLayVerx vbos counts) . VFSM.fromList
pokeLayVerx :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> Verx -> IO ()
pokeLayVerx :: MV.MVector (PrimState IO) FullShader' -> UMV.MVector (PrimState IO) Int -> Verx -> IO ()
--{-# INLINE pokeLayVerx #-}
pokeLayVerx vbos counts vx = do
theOff <- UMV.unsafeRead counts vecPos
basePtr <- _vboPtr . _vaoVBO . _shadVAO <$> MV.unsafeRead vbos sn
basePtr <- _vboPtr . _vaoVBO . _shadVAO' <$> MV.unsafeRead vbos sn
let thePtr = plusPtr basePtr ((theOff + layOff) * theStride * floatSize)
poke34 thePtr thePos theCol
pokeArrayOff thePtr 7 (_vxExt vx)