From 3e3fd049a9f0c93a1767a547d44186ddae84d5e8 Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 7 Mar 2023 15:40:29 +0000 Subject: [PATCH] Move shader compilation over to raw opengl, errors display incorrect --- src/Data/Preload/Render.hs | 34 +++++------ src/Dodge/Render.hs | 19 ++++--- src/Dodge/Render/Shadow.hs | 13 +++-- src/Preload/Render.hs | 66 +++++++++++----------- src/Preload/Update.hs | 2 +- src/Render.hs | 54 ++++++++++-------- src/Shader.hs | 39 ++++++++----- src/Shader/AuxAddition.hs | 77 ++++++++++++++++++++++++- src/Shader/Bind.hs | 18 ++++-- src/Shader/Compile.hs | 113 +++++++++++++++++++++++++++++++++++-- src/Shader/Data.hs | 12 +++- src/Shader/Poke.hs | 12 ++-- 12 files changed, 338 insertions(+), 121 deletions(-) diff --git a/src/Data/Preload/Render.hs b/src/Data/Preload/Render.hs index e7f33a505..9fd332425 100644 --- a/src/Data/Preload/Render.hs +++ b/src/Data/Preload/Render.hs @@ -12,25 +12,25 @@ import qualified Data.Vector.Mutable as MV import Control.Monad.Primitive data RenderData = RenderData - { _lightingWallShadShader :: FullShader - , _lightingLineShadowShader :: FullShader - , _positionalBlankShader :: FullShader - , _lightingCapShader :: FullShader - , _wallBlankShader :: FullShader - , _windowShader :: FullShader - , _wallTextureShader :: FullShader - , _textureArrayShader :: FullShader - , _fullscreenShader :: FullShader - , _lightingTextureShader :: FullShader - --, _fullscreenAlphaHalveShader :: FullShader - , _bloomBlurShader :: FullShader - , _colorBlurShader :: FullShader - , _barrelShader :: FullShader - , _grayscaleShader :: FullShader - , _shapeShader :: FullShader + { _lightingWallShadShader :: FullShader' + , _lightingLineShadowShader :: FullShader' + , _positionalBlankShader :: FullShader' + , _lightingCapShader :: FullShader' + , _wallBlankShader :: FullShader' + , _windowShader :: FullShader' + , _wallTextureShader :: FullShader' + , _textureArrayShader :: FullShader' + , _fullscreenShader :: FullShader' + , _lightingTextureShader :: FullShader' + --, _fullscreenAlphaHalveShader :: FullShader' + , _bloomBlurShader :: FullShader' + , _colorBlurShader :: FullShader' + , _barrelShader :: FullShader' + , _grayscaleShader :: FullShader' + , _shapeShader :: FullShader' , _shapeEBO :: EBO , _silhouetteEBO :: EBO - , _pictureShaders :: MV.MVector (PrimState IO) FullShader + , _pictureShaders :: MV.MVector (PrimState IO) FullShader' , _fbo2 :: (FramebufferObject, TextureObject) , _fbo3 :: (FramebufferObject, TextureObject) , _fboHalf1 :: (FramebufferObject, TextureObject) diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index 89727eb9b..b2d6c0f0b 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -70,7 +70,7 @@ doDrawing win pdata u = do (w ^. cWorld . floorTiles) ) ( pokeShape - (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata) + (_vboPtr $ _vaoVBO $ _shadVAO' $ _shapeShader pdata) (_eboPtr $ _shapeEBO pdata) (_eboPtr $ _silhouetteEBO pdata) (0, 0, 0) @@ -107,12 +107,14 @@ doDrawing win pdata u = do clear [ColorBuffer, DepthBuffer] depthFunc $= Just Less -- draw wall occlusions from the camera's point of view - currentProgram $= lwShad ^? shadProg -- Just (_shadProg lwShad) - uniform (_shadUnis lwShad V.! 0) $= viewFrom3d - bindVertexArrayObject $= lwShad ^? shadVAO . vao -- Just (_vao $ _shadVAO lwShad) +-- currentProgram $= lwShad ^? shadProg -- Just (_shadProg lwShad) +-- uniform (_shadUnis lwShad V.! 0) $= viewFrom3d + glUseProgram (lwShad ^. shadProg') + glUniform3f (_shadUnis' lwShad V.! 0) vfx vfy 20 + bindVertexArrayObject $= lwShad ^? shadVAO' . vao -- Just (_vao $ _shadVAO lwShad) unless (debugOn Remove_LOS cfig) $ glDrawArrays - (marshalEPrimitiveMode $ _shadPrim lwShad) + (marshalEPrimitiveMode $ _shadPrim' lwShad) 0 (fromIntegral nWalls) --draw walls onto base buffer @@ -123,10 +125,11 @@ doDrawing win pdata u = do renderLayer BottomLayer shadV layerCounts --draw object shapes onto base buffer let fs = _shapeShader pdata - currentProgram $= Just (_shadProg fs) - bindVertexArrayObject $= fs ^? shadVAO . vao -- Just (_vao $ _shadVAO fs) + --currentProgram $= Just (_shadProg fs) + glUseProgram (_shadProg' fs) + bindVertexArrayObject $= fs ^? shadVAO' . vao -- Just (_vao $ _shadVAO fs) glDrawElements - (marshalEPrimitiveMode $ _shadPrim fs) + (marshalEPrimitiveMode $ _shadPrim' fs) (fromIntegral nIndices) GL_UNSIGNED_SHORT nullPtr diff --git a/src/Dodge/Render/Shadow.hs b/src/Dodge/Render/Shadow.hs index 70aa1a16e..36b3011a4 100644 --- a/src/Dodge/Render/Shadow.hs +++ b/src/Dodge/Render/Shadow.hs @@ -21,19 +21,20 @@ import qualified Data.Vector.Fusion.Stream.Monadic as VFSM drawCPUShadows :: RenderData -> Shape -> Point3 -> Float -> IO () drawCPUShadows pdata s pos rad = do let theshad = pdata ^. positionalBlankShader - theptr = _vboPtr $ _vaoVBO $ _shadVAO theshad + theptr = _vboPtr $ _vaoVBO $ _shadVAO' theshad i <- VFSM.foldlM' (pokeShapeShad pos rad theptr) 0 $ VFSM.fromList s - bindBuffer ArrayBuffer $= (theshad ^? shadVAO . vaoVBO . vbo) + bindBuffer ArrayBuffer $= (theshad ^? shadVAO' . vaoVBO . vbo) bufferSubData ArrayBuffer WriteToBuffer 0 (fromIntegral $ floatSize * i) - (theshad ^. shadVAO . vaoVBO . vboPtr) - currentProgram $= theshad ^? shadProg - bindVertexArrayObject $= Just (_vao $ _shadVAO theshad) + (theshad ^. shadVAO' . vaoVBO . vboPtr) + --currentProgram $= theshad ^? shadProg + glUseProgram (theshad ^. shadProg') + bindVertexArrayObject $= Just (_vao $ _shadVAO' theshad) glDrawArrays - (marshalEPrimitiveMode $ _shadPrim theshad) + (marshalEPrimitiveMode $ _shadPrim' theshad) 0 (fromIntegral i) return () diff --git a/src/Preload/Render.hs b/src/Preload/Render.hs index 69cc53882..9479e471d 100644 --- a/src/Preload/Render.hs +++ b/src/Preload/Render.hs @@ -114,56 +114,56 @@ preloadRender = do shEdgeVAO = VAO{_vao = shEdgeVAOname, _vaoVBO = shVBO} -- lighting shaders lightingWallShadShad <- - makeShaderUsingVAO "lighting/wallShadow" [vert, geom, frag] EPoints wpVAO - >>= addUniforms ["lightPos"] + makeShaderUsingVAO' "lighting/wallShadow" [vert', geom', frag'] EPoints wpVAO + >>= addUniforms' ["lightPos"] lightingCapShad <- - makeShaderUsingVAO "lighting/cap" [vert, geom, frag] ETriangles shPosVAO - >>= addUniforms ["lightPos"] + makeShaderUsingVAO' "lighting/cap" [vert', geom', frag'] ETriangles shPosVAO + >>= addUniforms' ["lightPos"] lightingLineShadowShad <- - makeShaderUsingVAO "lighting/lineShadow" [vert, geom, frag] ELinesAdjacency shEdgeVAO - >>= addUniforms ["lightPos", "radiusUniform"] + makeShaderUsingVAO' "lighting/lineShadow" [vert', geom', frag'] ELinesAdjacency shEdgeVAO + >>= addUniforms' ["lightPos", "radiusUniform"] -- positional shader - positionalBlankShad <- makeShader "positional/blank" [vert, frag] [3] ETriangles + positionalBlankShad <- makeShader' "positional/blank" [vert', frag'] [3] ETriangles -- 2D draw shaders - bslist <- makeShader "dualTwoD/basic" [vert, frag] [3, 4] ETriangles - bslista <- makeShader "dualTwoD/basic" [vert, frag] [3, 4] ETriangles - aslist <- makeShader "dualTwoD/arc" [vert, frag] [3, 4, 3] ETriangles - eslist <- makeShader "dualTwoD/ellipse" [vert, geom, frag] [3, 4] ETriangles - bezierQuadShader <- makeShader "dualTwoD/bezierQuad" [vert, frag] [3, 4, 4] ETriangleStrip + bslist <- makeShader' "dualTwoD/basic" [vert', frag'] [3, 4] ETriangles + bslista <- makeShader' "dualTwoD/basic" [vert', frag'] [3, 4] ETriangles + aslist <- makeShader' "dualTwoD/arc" [vert', frag'] [3, 4, 3] ETriangles + eslist <- makeShader' "dualTwoD/ellipse" [vert', geom', frag'] [3, 4] ETriangles + bezierQuadShader <- makeShader' "dualTwoD/bezierQuad" [vert', frag'] [3, 4, 4] ETriangleStrip cslist <- - makeShader "dualTwoD/character" [vert, frag] [3, 4, 2] ETriangles - >>= vaddTextureNoFilter "data/texture/charMap.png" + makeShader' "dualTwoD/character" [vert', frag'] [3, 4, 2] ETriangles + >>= vaddTextureNoFilter' "data/texture/charMap.png" -- this should really be a 2d texture array - basicTweakZShad <- makeShader "dualTwoD/basicTweakZ" [vert, frag] [4, 4] ETriangles + basicTweakZShad <- makeShader' "dualTwoD/basicTweakZ" [vert', frag'] [4, 4] ETriangles -- fullscreen shaders --fullscreenAlphaHalveShad <- makeShaderSized "fullscreen/alphaHalve" [vert,frag] [2] 4 ETriangleStrip --pokeArray (shadVBOptr fullscreenAlphaHalveShad) $ concat cornerListNoCoord -- texture shaders, no textures attached - fsShad <- makeShaderSized "texture/simple" [vert, frag] [2, 2] 4 ETriangleStrip + fsShad <- makeShaderSized' "texture/simple" [vert', frag'] [2, 2] 4 ETriangleStrip -- note we directly poke the shader vertex data here -- could possibly use an indirect draw call - pokeArray (shadVBOptr fsShad) $ concat cornerList + pokeArray (shadVBOptr' fsShad) $ concat cornerList - bloomBlurShad <- makeShaderUsingShaderVAO "texture/bloomBlur" [vert, frag] ETriangleStrip fsShad - colorBlurShad <- makeShaderUsingShaderVAO "texture/colorBlur" [vert, frag] ETriangleStrip fsShad - grayscaleShad <- makeShaderUsingShaderVAO "texture/grayscale" [vert, frag] ETriangleStrip fsShad + bloomBlurShad <- makeShaderUsingShaderVAO' "texture/bloomBlur" [vert', frag'] ETriangleStrip fsShad + colorBlurShad <- makeShaderUsingShaderVAO' "texture/colorBlur" [vert', frag'] ETriangleStrip fsShad + grayscaleShad <- makeShaderUsingShaderVAO' "texture/grayscale" [vert', frag'] ETriangleStrip fsShad lightingTextureShad <- - makeShaderUsingShaderVAO "lighting/texture" [vert, frag] ETriangleStrip fsShad - >>= addUniforms ["lightPos", "lumRad"] - barrelShad <- makeShader "texture/barrel" [vert, geom, frag] [2, 2, 2, 1] EPoints + makeShaderUsingShaderVAO' "lighting/texture" [vert', frag'] ETriangleStrip fsShad + >>= addUniforms' ["lightPos", "lumRad"] + barrelShad <- makeShader' "texture/barrel" [vert', geom', frag'] [2, 2, 2, 1] EPoints -- blank wallShader - wallBlankShad <- makeShaderUsingVAO "wall/blank" [vert, geom, frag] EPoints wpColVAO + wallBlankShad <- makeShaderUsingVAO' "wall/blank" [vert', geom', frag'] EPoints wpColVAO -- textured wallShader wallTextureShad <- - makeShaderUsingVAO "wall/texture" [vert, geom, frag] EPoints wpColVAO - >>= addTexture "data/texture/grayscaleDirt.png" + makeShaderUsingVAO' "wall/texture" [vert', geom', frag'] EPoints wpColVAO + >>= addTexture' "data/texture/grayscaleDirt.png" ---- texture array shader textArrayShad <- - makeShader "texture/arrayPos" [vert, frag] [3, 3] ETriangles - >>= addTextureArray "data/texture/ayene_wooden_floor_transformed.png" + makeShader' "texture/arrayPos" [vert', frag'] [3, 3] ETriangles + >>= addTextureArray' "data/texture/ayene_wooden_floor_transformed.png" -- >>= addTextureArray "data/texture/ayene_wooden_floor.png" -- bind fixed vertex data - bindShaderBuffers [fsShad] [4, 4] + bindShaderBuffers' [fsShad] [4, 4] framebuf2 <- setupTextureFramebuffer 800 600 framebuf3 <- setupTextureFramebuffer 800 600 @@ -206,7 +206,7 @@ preloadRender = do return $ RenderData { _pictureShaders = shadV - , _shapeShader = bslista{_shadVAO = shPosColVAO} + , _shapeShader = bslista{_shadVAO' = shPosColVAO} , _shapeEBO = shEBO , _silhouetteEBO = silEBO , _lightingCapShader = lightingCapShad @@ -215,7 +215,7 @@ preloadRender = do , _lightingWallShadShader = lightingWallShadShad , _wallBlankShader = wallBlankShad , _wallTextureShader = wallTextureShad - , _windowShader = wallBlankShad{_shadVAO = winColVAO} + , _windowShader = wallBlankShad{_shadVAO' = winColVAO} , _textureArrayShader = textArrayShad , _fullscreenShader = fsShad , _lightingTextureShader = lightingTextureShad @@ -253,5 +253,5 @@ cleanUpRenderPreload :: RenderData -> IO () cleanUpRenderPreload pd = do -- TODO fix this --mapM_ freeShaderPointers $ _pictureShaders pd - freeShaderPointers $ _lightingWallShadShader pd - freeShaderPointers $ _fullscreenShader pd + freeShaderPointers' $ _lightingWallShadShader pd + freeShaderPointers' $ _fullscreenShader pd diff --git a/src/Preload/Update.hs b/src/Preload/Update.hs index 2389e9602..b27ef12f2 100644 --- a/src/Preload/Update.hs +++ b/src/Preload/Update.hs @@ -36,6 +36,6 @@ renderDataResizeUpdate xsize ysize xfull yfull rdata = do (_,btt) = BS.breakSubstring ")" bmid bbFrag' = BS.append bh $ BS.append (BSC.pack $ '(' : show xsize ++ "," ++ show ysize) btt --BSC.putStrLn bbFrag' - bbShad <- makeByteStringShaderUsingVAO "bloomBlur" [(vert,bbVert),(frag,bbFrag')] ETriangleStrip + bbShad <- makeByteStringShaderUsingVAO' "bloomBlur" [(vert',bbVert),(frag',bbFrag')] ETriangleStrip (_fullscreenShader rdata) return (rdata' {_bloomBlurShader = bbShad}) diff --git a/src/Render.hs b/src/Render.hs index c5ac532e3..a9ff8a8c1 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -76,33 +76,40 @@ createLightMap pdata lightPoints nWalls nSils nCaps drawObjShads toPos drawCPUSh cullFace $= Nothing stencilFunc $= (Always, 0, 255) --draw wall shadows - currentProgram $= Just (_shadProg lwallShad) - uniform (_shadUnis lwallShad V.! 0) - $= Vector3 x y z - bindVertexArrayObject $= lwallShad ^? shadVAO . vao -- Just (_vao $ _shadVAO lwallShad) + --currentProgram $= Just (_shadProg lwallShad) + glUseProgram (_shadProg' lwallShad) + --uniform (_shadUnis lwallShad V.! 0) + -- $= Vector3 x y z + glUniform3f (_shadUnis' lwallShad V.! 0) x y z + bindVertexArrayObject $= lwallShad ^? shadVAO' . vao -- Just (_vao $ _shadVAO lwallShad) glDrawArrays - (marshalEPrimitiveMode $ _shadPrim lwallShad) + (marshalEPrimitiveMode $ _shadPrim' lwallShad) 0 (fromIntegral nWalls) case drawObjShads of GeoObjShads -> do --draw silhouette shadows - currentProgram $= Just (_shadProg llinesShad) - uniform (_shadUnis llinesShad V.! 0) $= Vector3 x y z - uniform (_shadUnis llinesShad V.! 1) $= rad - bindVertexArrayObject $= Just (_vao $ _shadVAO llinesShad) + --currentProgram $= Just (_shadProg llinesShad) + --uniform (_shadUnis llinesShad V.! 0) $= Vector3 x y z + --uniform (_shadUnis llinesShad V.! 1) $= rad + glUseProgram (_shadProg' llinesShad) + glUniform3f (_shadUnis' llinesShad V.! 0) x y z + glUniform1f (_shadUnis' llinesShad V.! 1) rad + bindVertexArrayObject $= Just (_vao $ _shadVAO' llinesShad) glDrawElements - (marshalEPrimitiveMode $ _shadPrim llinesShad) + (marshalEPrimitiveMode $ _shadPrim' llinesShad) (fromIntegral nSils) GL_UNSIGNED_SHORT nullPtr --draw caps on the near plane as required cullFace $= Just Back - currentProgram $= Just (_shadProg lcapShad) - uniform (_shadUnis lcapShad V.! 0) $= Vector3 x y z - bindVertexArrayObject $= lcapShad ^? shadVAO . vao --Just (_vao $ _shadVAO lcapShad) + --currentProgram $= Just (_shadProg lcapShad) + --uniform (_shadUnis lcapShad V.! 0) $= Vector3 x y z + glUseProgram (_shadProg' lcapShad) + glUniform3f (_shadUnis' lcapShad V.! 0) x y z + bindVertexArrayObject $= lcapShad ^? shadVAO' . vao --Just (_vao $ _shadVAO lcapShad) glDrawElements - (marshalEPrimitiveMode $ _shadPrim lcapShad) + (marshalEPrimitiveMode $ _shadPrim' lcapShad) (fromIntegral nCaps) GL_UNSIGNED_SHORT nullPtr @@ -115,12 +122,15 @@ createLightMap pdata lightPoints nWalls nSils nCaps drawObjShads toPos drawCPUSh colorMask $= Color4 Enabled Enabled Enabled Enabled --stencilOp $= (OpKeep, OpKeep, OpKeep) stencilFunc $= (Equal, 0, 255) - currentProgram $= ltextShad ^? shadProg --Just (_shadProg ltextShad) - uniform (_shadUnis ltextShad V.! 0) $= Vector3 x y z - uniform (_shadUnis ltextShad V.! 1) $= Vector4 r g b rad - bindVertexArrayObject $= ltextShad ^? shadVAO . vao -- Just (_vao $ _shadVAO ltextShad) + --currentProgram $= ltextShad ^? shadProg --Just (_shadProg ltextShad) + --uniform (_shadUnis ltextShad V.! 0) $= Vector3 x y z + --uniform (_shadUnis ltextShad V.! 1) $= Vector4 r g b rad + glUseProgram (ltextShad ^. shadProg') --Just (_shadProg ltextShad) + glUniform3f (_shadUnis' ltextShad V.! 0) x y z + glUniform4f (_shadUnis' ltextShad V.! 1) r g b rad + bindVertexArrayObject $= ltextShad ^? shadVAO' . vao -- Just (_vao $ _shadVAO ltextShad) glDrawArrays - (marshalEPrimitiveMode (_shadPrim ltextShad)) + (marshalEPrimitiveMode (_shadPrim' ltextShad)) 0 (fromIntegral (4 :: Int)) --cleanup: may not be necessary, depending on what comes after... @@ -131,7 +141,7 @@ createLightMap pdata lightPoints nWalls nSils nCaps drawObjShads toPos drawCPUSh pingPongBetween :: (FramebufferObject, TextureObject) -> (FramebufferObject, TextureObject) -> - FullShader -> + FullShader' -> IO () pingPongBetween (fb1, to1) (fb2, to2) fs = do bindFramebuffer Framebuffer $= fb2 @@ -142,7 +152,7 @@ pingPongBetween (fb1, to1) (fb2, to2) fs = do drawShader fs 4 renderFoldable :: - MV.MVector (PrimState IO) FullShader -> + MV.MVector (PrimState IO) FullShader' -> Picture -> IO () renderFoldable shadV struct = do @@ -153,7 +163,7 @@ renderFoldable shadV struct = do ------------------------------end renderFoldable renderLayer :: Layer -> - MV.MVector (PrimState IO) FullShader -> + MV.MVector (PrimState IO) FullShader' -> UMV.MVector (PrimState IO) Int -> IO () renderLayer layer shads counts = do diff --git a/src/Shader.hs b/src/Shader.hs index d926819d0..c156ea3c1 100644 --- a/src/Shader.hs +++ b/src/Shader.hs @@ -1,7 +1,9 @@ module Shader ( freeShaderPointers + , freeShaderPointers' , drawShaderLay , shadVBOptr + , shadVBOptr' , drawShader , pokeBindFoldable , pokeBindFoldableLayer @@ -20,41 +22,46 @@ import Foreign import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight) import Graphics.GL.Core43 -drawShaderLay :: Int -> UMV.MVector (PrimState IO) Int -> Int -> FullShader -> IO () +drawShaderLay :: Int -> UMV.MVector (PrimState IO) Int -> Int -> FullShader' -> IO () {-# INLINE drawShaderLay #-} drawShaderLay l countsVector shadIn fs = do i <- UMV.read countsVector shadIn - currentProgram $= Just (_shadProg fs) - bindVertexArrayObject $= Just (_vao $ _shadVAO fs) - case _shadTex fs of + --currentProgram $= Just (_shadProg' fs) + glUseProgram (_shadProg' fs) + bindVertexArrayObject $= Just (_vao $ _shadVAO' fs) + case _shadTex' fs of Just ShaderTexture{_textureObject = txo} -> textureBinding Texture2D $= Just txo _ -> return () glDrawArrays - (marshalEPrimitiveMode $ _shadPrim fs) + (marshalEPrimitiveMode $ _shadPrim' fs) (fromIntegral $ l*numSubElements) (fromIntegral i) -drawShader :: FullShader -> Int -> IO () +drawShader :: FullShader' -> Int -> IO () {-# INLINE drawShader #-} drawShader fs i = do - currentProgram $= Just (_shadProg fs) - bindVertexArrayObject $= Just (_vao $ _shadVAO fs) - case _shadTex fs of + --currentProgram $= Just (_shadProg fs) + glUseProgram (_shadProg' fs) + bindVertexArrayObject $= Just (_vao $ _shadVAO' fs) + case _shadTex' fs of Just ShaderTexture{_textureObject = TextureObject txo , _textureTarget = tt } -> glBindTexture tt txo _ -> return () glDrawArrays - (marshalEPrimitiveMode $ _shadPrim fs) + (marshalEPrimitiveMode $ _shadPrim' fs) 0 (fromIntegral i) freeShaderPointers :: FullShader -> IO () freeShaderPointers = free . _vboPtr . _vaoVBO . _shadVAO +freeShaderPointers' :: FullShader' -> IO () +freeShaderPointers' = free . _vboPtr . _vaoVBO . _shadVAO' + pokeBindFoldable - :: MV.MVector (PrimState IO) FullShader + :: MV.MVector (PrimState IO) FullShader' -> UMV.MVector (PrimState IO) Int -> Picture -> IO () @@ -63,7 +70,7 @@ pokeBindFoldable shadV counts m = do bindShader shadV counts pokeBindFoldableLayer - :: MV.MVector (PrimState IO) FullShader + :: MV.MVector (PrimState IO) FullShader' -> UMV.MVector (PrimState IO) Int -> Picture -> IO () @@ -71,6 +78,10 @@ pokeBindFoldableLayer shadV counts m = do pokeLayVerxs shadV counts m bindShaderLayers shadV counts -shadVBOptr :: FullShader -> Ptr Float +shadVBOptr :: FullShader' -> Ptr Float {-# INLINE shadVBOptr #-} -shadVBOptr = _vboPtr . _vaoVBO . _shadVAO +shadVBOptr = _vboPtr . _vaoVBO . _shadVAO' + +shadVBOptr' :: FullShader' -> Ptr Float +{-# INLINE shadVBOptr' #-} +shadVBOptr' = _vboPtr . _vaoVBO . _shadVAO' diff --git a/src/Shader/AuxAddition.hs b/src/Shader/AuxAddition.hs index 27ecff200..961e58493 100644 --- a/src/Shader/AuxAddition.hs +++ b/src/Shader/AuxAddition.hs @@ -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]) + + diff --git a/src/Shader/Bind.hs b/src/Shader/Bind.hs index bcabaab85..846c7ba17 100644 --- a/src/Shader/Bind.hs +++ b/src/Shader/Bind.hs @@ -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 diff --git a/src/Shader/Compile.hs b/src/Shader/Compile.hs index e42dd105a..593ff3b8e 100644 --- a/src/Shader/Compile.hs +++ b/src/Shader/Compile.hs @@ -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) diff --git a/src/Shader/Data.hs b/src/Shader/Data.hs index 6201b73c9..9cb334cd5 100644 --- a/src/Shader/Data.hs +++ b/src/Shader/Data.hs @@ -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 diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index fe3f9b7f3..7c67a1b9f 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -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)