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/Data/Preload/Render.hs
+17 -17
View File
@@ -12,25 +12,25 @@ import qualified Data.Vector.Mutable as MV
import Control.Monad.Primitive import Control.Monad.Primitive
data RenderData = RenderData data RenderData = RenderData
{ _lightingWallShadShader :: FullShader { _lightingWallShadShader :: FullShader'
, _lightingLineShadowShader :: FullShader , _lightingLineShadowShader :: FullShader'
, _positionalBlankShader :: FullShader , _positionalBlankShader :: FullShader'
, _lightingCapShader :: FullShader , _lightingCapShader :: FullShader'
, _wallBlankShader :: FullShader , _wallBlankShader :: FullShader'
, _windowShader :: FullShader , _windowShader :: FullShader'
, _wallTextureShader :: FullShader , _wallTextureShader :: FullShader'
, _textureArrayShader :: FullShader , _textureArrayShader :: FullShader'
, _fullscreenShader :: FullShader , _fullscreenShader :: FullShader'
, _lightingTextureShader :: FullShader , _lightingTextureShader :: FullShader'
--, _fullscreenAlphaHalveShader :: FullShader --, _fullscreenAlphaHalveShader :: FullShader'
, _bloomBlurShader :: FullShader , _bloomBlurShader :: FullShader'
, _colorBlurShader :: FullShader , _colorBlurShader :: FullShader'
, _barrelShader :: FullShader , _barrelShader :: FullShader'
, _grayscaleShader :: FullShader , _grayscaleShader :: FullShader'
, _shapeShader :: FullShader , _shapeShader :: FullShader'
, _shapeEBO :: EBO , _shapeEBO :: EBO
, _silhouetteEBO :: EBO , _silhouetteEBO :: EBO
, _pictureShaders :: MV.MVector (PrimState IO) FullShader , _pictureShaders :: MV.MVector (PrimState IO) FullShader'
, _fbo2 :: (FramebufferObject, TextureObject) , _fbo2 :: (FramebufferObject, TextureObject)
, _fbo3 :: (FramebufferObject, TextureObject) , _fbo3 :: (FramebufferObject, TextureObject)
, _fboHalf1 :: (FramebufferObject, TextureObject) , _fboHalf1 :: (FramebufferObject, TextureObject)
src/Dodge/Render.hs
+11 -8
View File
@@ -70,7 +70,7 @@ doDrawing win pdata u = do
(w ^. cWorld . floorTiles) (w ^. cWorld . floorTiles)
) )
( pokeShape ( pokeShape
(_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata) (_vboPtr $ _vaoVBO $ _shadVAO' $ _shapeShader pdata)
(_eboPtr $ _shapeEBO pdata) (_eboPtr $ _shapeEBO pdata)
(_eboPtr $ _silhouetteEBO pdata) (_eboPtr $ _silhouetteEBO pdata)
(0, 0, 0) (0, 0, 0)
@@ -107,12 +107,14 @@ doDrawing win pdata u = do
clear [ColorBuffer, DepthBuffer] clear [ColorBuffer, DepthBuffer]
depthFunc $= Just Less depthFunc $= Just Less
-- draw wall occlusions from the camera's point of view -- draw wall occlusions from the camera's point of view
currentProgram $= lwShad ^? shadProg -- Just (_shadProg lwShad) -- currentProgram $= lwShad ^? shadProg -- Just (_shadProg lwShad)
uniform (_shadUnis lwShad V.! 0) $= viewFrom3d -- uniform (_shadUnis lwShad V.! 0) $= viewFrom3d
bindVertexArrayObject $= lwShad ^? shadVAO . vao -- Just (_vao $ _shadVAO lwShad) glUseProgram (lwShad ^. shadProg')
glUniform3f (_shadUnis' lwShad V.! 0) vfx vfy 20
bindVertexArrayObject $= lwShad ^? shadVAO' . vao -- Just (_vao $ _shadVAO lwShad)
unless (debugOn Remove_LOS cfig) $ unless (debugOn Remove_LOS cfig) $
glDrawArrays glDrawArrays
(marshalEPrimitiveMode $ _shadPrim lwShad) (marshalEPrimitiveMode $ _shadPrim' lwShad)
0 0
(fromIntegral nWalls) (fromIntegral nWalls)
--draw walls onto base buffer --draw walls onto base buffer
@@ -123,10 +125,11 @@ doDrawing win pdata u = do
renderLayer BottomLayer shadV layerCounts renderLayer BottomLayer shadV layerCounts
--draw object shapes onto base buffer --draw object shapes onto base buffer
let fs = _shapeShader pdata let fs = _shapeShader pdata
currentProgram $= Just (_shadProg fs) --currentProgram $= Just (_shadProg fs)
bindVertexArrayObject $= fs ^? shadVAO . vao -- Just (_vao $ _shadVAO fs) glUseProgram (_shadProg' fs)
bindVertexArrayObject $= fs ^? shadVAO' . vao -- Just (_vao $ _shadVAO fs)
glDrawElements glDrawElements
(marshalEPrimitiveMode $ _shadPrim fs) (marshalEPrimitiveMode $ _shadPrim' fs)
(fromIntegral nIndices) (fromIntegral nIndices)
GL_UNSIGNED_SHORT GL_UNSIGNED_SHORT
nullPtr nullPtr
src/Dodge/Render/Shadow.hs
+7 -6
View File
@@ -21,19 +21,20 @@ import qualified Data.Vector.Fusion.Stream.Monadic as VFSM
drawCPUShadows :: RenderData -> Shape -> Point3 -> Float -> IO () drawCPUShadows :: RenderData -> Shape -> Point3 -> Float -> IO ()
drawCPUShadows pdata s pos rad = do drawCPUShadows pdata s pos rad = do
let theshad = pdata ^. positionalBlankShader 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 i <- VFSM.foldlM' (pokeShapeShad pos rad theptr) 0 $ VFSM.fromList s
bindBuffer ArrayBuffer $= (theshad ^? shadVAO . vaoVBO . vbo) bindBuffer ArrayBuffer $= (theshad ^? shadVAO' . vaoVBO . vbo)
bufferSubData bufferSubData
ArrayBuffer ArrayBuffer
WriteToBuffer WriteToBuffer
0 0
(fromIntegral $ floatSize * i) (fromIntegral $ floatSize * i)
(theshad ^. shadVAO . vaoVBO . vboPtr) (theshad ^. shadVAO' . vaoVBO . vboPtr)
currentProgram $= theshad ^? shadProg --currentProgram $= theshad ^? shadProg
bindVertexArrayObject $= Just (_vao $ _shadVAO theshad) glUseProgram (theshad ^. shadProg')
bindVertexArrayObject $= Just (_vao $ _shadVAO' theshad)
glDrawArrays glDrawArrays
(marshalEPrimitiveMode $ _shadPrim theshad) (marshalEPrimitiveMode $ _shadPrim' theshad)
0 0
(fromIntegral i) (fromIntegral i)
return () return ()
src/Preload/Render.hs
+33 -33
View File
@@ -114,56 +114,56 @@ preloadRender = do
shEdgeVAO = VAO{_vao = shEdgeVAOname, _vaoVBO = shVBO} shEdgeVAO = VAO{_vao = shEdgeVAOname, _vaoVBO = shVBO}
-- lighting shaders -- lighting shaders
lightingWallShadShad <- lightingWallShadShad <-
makeShaderUsingVAO "lighting/wallShadow" [vert, geom, frag] EPoints wpVAO makeShaderUsingVAO' "lighting/wallShadow" [vert', geom', frag'] EPoints wpVAO
>>= addUniforms ["lightPos"] >>= addUniforms' ["lightPos"]
lightingCapShad <- lightingCapShad <-
makeShaderUsingVAO "lighting/cap" [vert, geom, frag] ETriangles shPosVAO makeShaderUsingVAO' "lighting/cap" [vert', geom', frag'] ETriangles shPosVAO
>>= addUniforms ["lightPos"] >>= addUniforms' ["lightPos"]
lightingLineShadowShad <- lightingLineShadowShad <-
makeShaderUsingVAO "lighting/lineShadow" [vert, geom, frag] ELinesAdjacency shEdgeVAO makeShaderUsingVAO' "lighting/lineShadow" [vert', geom', frag'] ELinesAdjacency shEdgeVAO
>>= addUniforms ["lightPos", "radiusUniform"] >>= addUniforms' ["lightPos", "radiusUniform"]
-- positional shader -- positional shader
positionalBlankShad <- makeShader "positional/blank" [vert, frag] [3] ETriangles positionalBlankShad <- makeShader' "positional/blank" [vert', frag'] [3] ETriangles
-- 2D draw shaders -- 2D draw shaders
bslist <- makeShader "dualTwoD/basic" [vert, frag] [3, 4] ETriangles bslist <- makeShader' "dualTwoD/basic" [vert', frag'] [3, 4] ETriangles
bslista <- 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 aslist <- makeShader' "dualTwoD/arc" [vert', frag'] [3, 4, 3] ETriangles
eslist <- makeShader "dualTwoD/ellipse" [vert, geom, frag] [3, 4] ETriangles eslist <- makeShader' "dualTwoD/ellipse" [vert', geom', frag'] [3, 4] ETriangles
bezierQuadShader <- makeShader "dualTwoD/bezierQuad" [vert, frag] [3, 4, 4] ETriangleStrip bezierQuadShader <- makeShader' "dualTwoD/bezierQuad" [vert', frag'] [3, 4, 4] ETriangleStrip
cslist <- cslist <-
makeShader "dualTwoD/character" [vert, frag] [3, 4, 2] ETriangles makeShader' "dualTwoD/character" [vert', frag'] [3, 4, 2] ETriangles
>>= vaddTextureNoFilter "data/texture/charMap.png" >>= vaddTextureNoFilter' "data/texture/charMap.png"
-- this should really be a 2d texture array -- 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 -- fullscreen shaders
--fullscreenAlphaHalveShad <- makeShaderSized "fullscreen/alphaHalve" [vert,frag] [2] 4 ETriangleStrip --fullscreenAlphaHalveShad <- makeShaderSized "fullscreen/alphaHalve" [vert,frag] [2] 4 ETriangleStrip
--pokeArray (shadVBOptr fullscreenAlphaHalveShad) $ concat cornerListNoCoord --pokeArray (shadVBOptr fullscreenAlphaHalveShad) $ concat cornerListNoCoord
-- texture shaders, no textures attached -- 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 -- note we directly poke the shader vertex data here
-- could possibly use an indirect draw call -- 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 bloomBlurShad <- makeShaderUsingShaderVAO' "texture/bloomBlur" [vert', frag'] ETriangleStrip fsShad
colorBlurShad <- makeShaderUsingShaderVAO "texture/colorBlur" [vert, frag] ETriangleStrip fsShad colorBlurShad <- makeShaderUsingShaderVAO' "texture/colorBlur" [vert', frag'] ETriangleStrip fsShad
grayscaleShad <- makeShaderUsingShaderVAO "texture/grayscale" [vert, frag] ETriangleStrip fsShad grayscaleShad <- makeShaderUsingShaderVAO' "texture/grayscale" [vert', frag'] ETriangleStrip fsShad
lightingTextureShad <- lightingTextureShad <-
makeShaderUsingShaderVAO "lighting/texture" [vert, frag] ETriangleStrip fsShad makeShaderUsingShaderVAO' "lighting/texture" [vert', frag'] ETriangleStrip fsShad
>>= addUniforms ["lightPos", "lumRad"] >>= addUniforms' ["lightPos", "lumRad"]
barrelShad <- makeShader "texture/barrel" [vert, geom, frag] [2, 2, 2, 1] EPoints barrelShad <- makeShader' "texture/barrel" [vert', geom', frag'] [2, 2, 2, 1] EPoints
-- blank wallShader -- blank wallShader
wallBlankShad <- makeShaderUsingVAO "wall/blank" [vert, geom, frag] EPoints wpColVAO wallBlankShad <- makeShaderUsingVAO' "wall/blank" [vert', geom', frag'] EPoints wpColVAO
-- textured wallShader -- textured wallShader
wallTextureShad <- wallTextureShad <-
makeShaderUsingVAO "wall/texture" [vert, geom, frag] EPoints wpColVAO makeShaderUsingVAO' "wall/texture" [vert', geom', frag'] EPoints wpColVAO
>>= addTexture "data/texture/grayscaleDirt.png" >>= addTexture' "data/texture/grayscaleDirt.png"
---- texture array shader ---- texture array shader
textArrayShad <- textArrayShad <-
makeShader "texture/arrayPos" [vert, frag] [3, 3] ETriangles makeShader' "texture/arrayPos" [vert', frag'] [3, 3] ETriangles
>>= addTextureArray "data/texture/ayene_wooden_floor_transformed.png" >>= addTextureArray' "data/texture/ayene_wooden_floor_transformed.png"
-- >>= addTextureArray "data/texture/ayene_wooden_floor.png" -- >>= addTextureArray "data/texture/ayene_wooden_floor.png"
-- bind fixed vertex data -- bind fixed vertex data
bindShaderBuffers [fsShad] [4, 4] bindShaderBuffers' [fsShad] [4, 4]
framebuf2 <- setupTextureFramebuffer 800 600 framebuf2 <- setupTextureFramebuffer 800 600
framebuf3 <- setupTextureFramebuffer 800 600 framebuf3 <- setupTextureFramebuffer 800 600
@@ -206,7 +206,7 @@ preloadRender = do
return $ return $
RenderData RenderData
{ _pictureShaders = shadV { _pictureShaders = shadV
, _shapeShader = bslista{_shadVAO = shPosColVAO} , _shapeShader = bslista{_shadVAO' = shPosColVAO}
, _shapeEBO = shEBO , _shapeEBO = shEBO
, _silhouetteEBO = silEBO , _silhouetteEBO = silEBO
, _lightingCapShader = lightingCapShad , _lightingCapShader = lightingCapShad
@@ -215,7 +215,7 @@ preloadRender = do
, _lightingWallShadShader = lightingWallShadShad , _lightingWallShadShader = lightingWallShadShad
, _wallBlankShader = wallBlankShad , _wallBlankShader = wallBlankShad
, _wallTextureShader = wallTextureShad , _wallTextureShader = wallTextureShad
, _windowShader = wallBlankShad{_shadVAO = winColVAO} , _windowShader = wallBlankShad{_shadVAO' = winColVAO}
, _textureArrayShader = textArrayShad , _textureArrayShader = textArrayShad
, _fullscreenShader = fsShad , _fullscreenShader = fsShad
, _lightingTextureShader = lightingTextureShad , _lightingTextureShader = lightingTextureShad
@@ -253,5 +253,5 @@ cleanUpRenderPreload :: RenderData -> IO ()
cleanUpRenderPreload pd = do cleanUpRenderPreload pd = do
-- TODO fix this -- TODO fix this
--mapM_ freeShaderPointers $ _pictureShaders pd --mapM_ freeShaderPointers $ _pictureShaders pd
freeShaderPointers $ _lightingWallShadShader pd freeShaderPointers' $ _lightingWallShadShader pd
freeShaderPointers $ _fullscreenShader pd freeShaderPointers' $ _fullscreenShader pd
src/Preload/Update.hs
+1 -1
View File
@@ -36,6 +36,6 @@ renderDataResizeUpdate xsize ysize xfull yfull rdata = do
(_,btt) = BS.breakSubstring ")" bmid (_,btt) = BS.breakSubstring ")" bmid
bbFrag' = BS.append bh $ BS.append (BSC.pack $ '(' : show xsize ++ "," ++ show ysize) btt bbFrag' = BS.append bh $ BS.append (BSC.pack $ '(' : show xsize ++ "," ++ show ysize) btt
--BSC.putStrLn bbFrag' --BSC.putStrLn bbFrag'
bbShad <- makeByteStringShaderUsingVAO "bloomBlur" [(vert,bbVert),(frag,bbFrag')] ETriangleStrip bbShad <- makeByteStringShaderUsingVAO' "bloomBlur" [(vert',bbVert),(frag',bbFrag')] ETriangleStrip
(_fullscreenShader rdata) (_fullscreenShader rdata)
return (rdata' {_bloomBlurShader = bbShad}) return (rdata' {_bloomBlurShader = bbShad})
src/Render.hs
+32 -22
View File
@@ -76,33 +76,40 @@ createLightMap pdata lightPoints nWalls nSils nCaps drawObjShads toPos drawCPUSh
cullFace $= Nothing cullFace $= Nothing
stencilFunc $= (Always, 0, 255) stencilFunc $= (Always, 0, 255)
--draw wall shadows --draw wall shadows
currentProgram $= Just (_shadProg lwallShad) --currentProgram $= Just (_shadProg lwallShad)
uniform (_shadUnis lwallShad V.! 0) glUseProgram (_shadProg' lwallShad)
$= Vector3 x y z --uniform (_shadUnis lwallShad V.! 0)
bindVertexArrayObject $= lwallShad ^? shadVAO . vao -- Just (_vao $ _shadVAO lwallShad) -- $= Vector3 x y z
glUniform3f (_shadUnis' lwallShad V.! 0) x y z
bindVertexArrayObject $= lwallShad ^? shadVAO' . vao -- Just (_vao $ _shadVAO lwallShad)
glDrawArrays glDrawArrays
(marshalEPrimitiveMode $ _shadPrim lwallShad) (marshalEPrimitiveMode $ _shadPrim' lwallShad)
0 0
(fromIntegral nWalls) (fromIntegral nWalls)
case drawObjShads of case drawObjShads of
GeoObjShads -> do GeoObjShads -> do
--draw silhouette shadows --draw silhouette shadows
currentProgram $= Just (_shadProg llinesShad) --currentProgram $= Just (_shadProg llinesShad)
uniform (_shadUnis llinesShad V.! 0) $= Vector3 x y z --uniform (_shadUnis llinesShad V.! 0) $= Vector3 x y z
uniform (_shadUnis llinesShad V.! 1) $= rad --uniform (_shadUnis llinesShad V.! 1) $= rad
bindVertexArrayObject $= Just (_vao $ _shadVAO llinesShad) glUseProgram (_shadProg' llinesShad)
glUniform3f (_shadUnis' llinesShad V.! 0) x y z
glUniform1f (_shadUnis' llinesShad V.! 1) rad
bindVertexArrayObject $= Just (_vao $ _shadVAO' llinesShad)
glDrawElements glDrawElements
(marshalEPrimitiveMode $ _shadPrim llinesShad) (marshalEPrimitiveMode $ _shadPrim' llinesShad)
(fromIntegral nSils) (fromIntegral nSils)
GL_UNSIGNED_SHORT GL_UNSIGNED_SHORT
nullPtr nullPtr
--draw caps on the near plane as required --draw caps on the near plane as required
cullFace $= Just Back cullFace $= Just Back
currentProgram $= Just (_shadProg lcapShad) --currentProgram $= Just (_shadProg lcapShad)
uniform (_shadUnis lcapShad V.! 0) $= Vector3 x y z --uniform (_shadUnis lcapShad V.! 0) $= Vector3 x y z
bindVertexArrayObject $= lcapShad ^? shadVAO . vao --Just (_vao $ _shadVAO lcapShad) glUseProgram (_shadProg' lcapShad)
glUniform3f (_shadUnis' lcapShad V.! 0) x y z
bindVertexArrayObject $= lcapShad ^? shadVAO' . vao --Just (_vao $ _shadVAO lcapShad)
glDrawElements glDrawElements
(marshalEPrimitiveMode $ _shadPrim lcapShad) (marshalEPrimitiveMode $ _shadPrim' lcapShad)
(fromIntegral nCaps) (fromIntegral nCaps)
GL_UNSIGNED_SHORT GL_UNSIGNED_SHORT
nullPtr nullPtr
@@ -115,12 +122,15 @@ createLightMap pdata lightPoints nWalls nSils nCaps drawObjShads toPos drawCPUSh
colorMask $= Color4 Enabled Enabled Enabled Enabled colorMask $= Color4 Enabled Enabled Enabled Enabled
--stencilOp $= (OpKeep, OpKeep, OpKeep) --stencilOp $= (OpKeep, OpKeep, OpKeep)
stencilFunc $= (Equal, 0, 255) stencilFunc $= (Equal, 0, 255)
currentProgram $= ltextShad ^? shadProg --Just (_shadProg ltextShad) --currentProgram $= ltextShad ^? shadProg --Just (_shadProg ltextShad)
uniform (_shadUnis ltextShad V.! 0) $= Vector3 x y z --uniform (_shadUnis ltextShad V.! 0) $= Vector3 x y z
uniform (_shadUnis ltextShad V.! 1) $= Vector4 r g b rad --uniform (_shadUnis ltextShad V.! 1) $= Vector4 r g b rad
bindVertexArrayObject $= ltextShad ^? shadVAO . vao -- Just (_vao $ _shadVAO ltextShad) 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 glDrawArrays
(marshalEPrimitiveMode (_shadPrim ltextShad)) (marshalEPrimitiveMode (_shadPrim' ltextShad))
0 0
(fromIntegral (4 :: Int)) (fromIntegral (4 :: Int))
--cleanup: may not be necessary, depending on what comes after... --cleanup: may not be necessary, depending on what comes after...
@@ -131,7 +141,7 @@ createLightMap pdata lightPoints nWalls nSils nCaps drawObjShads toPos drawCPUSh
pingPongBetween :: pingPongBetween ::
(FramebufferObject, TextureObject) -> (FramebufferObject, TextureObject) ->
(FramebufferObject, TextureObject) -> (FramebufferObject, TextureObject) ->
FullShader -> FullShader' ->
IO () IO ()
pingPongBetween (fb1, to1) (fb2, to2) fs = do pingPongBetween (fb1, to1) (fb2, to2) fs = do
bindFramebuffer Framebuffer $= fb2 bindFramebuffer Framebuffer $= fb2
@@ -142,7 +152,7 @@ pingPongBetween (fb1, to1) (fb2, to2) fs = do
drawShader fs 4 drawShader fs 4
renderFoldable :: renderFoldable ::
MV.MVector (PrimState IO) FullShader -> MV.MVector (PrimState IO) FullShader' ->
Picture -> Picture ->
IO () IO ()
renderFoldable shadV struct = do renderFoldable shadV struct = do
@@ -153,7 +163,7 @@ renderFoldable shadV struct = do
------------------------------end renderFoldable ------------------------------end renderFoldable
renderLayer :: renderLayer ::
Layer -> Layer ->
MV.MVector (PrimState IO) FullShader -> MV.MVector (PrimState IO) FullShader' ->
UMV.MVector (PrimState IO) Int -> UMV.MVector (PrimState IO) Int ->
IO () IO ()
renderLayer layer shads counts = do renderLayer layer shads counts = do
src/Shader.hs
+25 -14
View File
@@ -1,7 +1,9 @@
module Shader module Shader
( freeShaderPointers ( freeShaderPointers
, freeShaderPointers'
, drawShaderLay , drawShaderLay
, shadVBOptr , shadVBOptr
, shadVBOptr'
, drawShader , drawShader
, pokeBindFoldable , pokeBindFoldable
, pokeBindFoldableLayer , pokeBindFoldableLayer
@@ -20,41 +22,46 @@ import Foreign
import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight) import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
import Graphics.GL.Core43 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 #-} {-# INLINE drawShaderLay #-}
drawShaderLay l countsVector shadIn fs = do drawShaderLay l countsVector shadIn fs = do
i <- UMV.read countsVector shadIn i <- UMV.read countsVector shadIn
currentProgram $= Just (_shadProg fs) --currentProgram $= Just (_shadProg' fs)
bindVertexArrayObject $= Just (_vao $ _shadVAO fs) glUseProgram (_shadProg' fs)
case _shadTex fs of bindVertexArrayObject $= Just (_vao $ _shadVAO' fs)
case _shadTex' fs of
Just ShaderTexture{_textureObject = txo} Just ShaderTexture{_textureObject = txo}
-> textureBinding Texture2D $= Just txo -> textureBinding Texture2D $= Just txo
_ -> return () _ -> return ()
glDrawArrays glDrawArrays
(marshalEPrimitiveMode $ _shadPrim fs) (marshalEPrimitiveMode $ _shadPrim' fs)
(fromIntegral $ l*numSubElements) (fromIntegral $ l*numSubElements)
(fromIntegral i) (fromIntegral i)
drawShader :: FullShader -> Int -> IO () drawShader :: FullShader' -> Int -> IO ()
{-# INLINE drawShader #-} {-# INLINE drawShader #-}
drawShader fs i = do drawShader fs i = do
currentProgram $= Just (_shadProg fs) --currentProgram $= Just (_shadProg fs)
bindVertexArrayObject $= Just (_vao $ _shadVAO fs) glUseProgram (_shadProg' fs)
case _shadTex fs of bindVertexArrayObject $= Just (_vao $ _shadVAO' fs)
case _shadTex' fs of
Just ShaderTexture{_textureObject = TextureObject txo Just ShaderTexture{_textureObject = TextureObject txo
, _textureTarget = tt } , _textureTarget = tt }
-> glBindTexture tt txo -> glBindTexture tt txo
_ -> return () _ -> return ()
glDrawArrays glDrawArrays
(marshalEPrimitiveMode $ _shadPrim fs) (marshalEPrimitiveMode $ _shadPrim' fs)
0 0
(fromIntegral i) (fromIntegral i)
freeShaderPointers :: FullShader -> IO () freeShaderPointers :: FullShader -> IO ()
freeShaderPointers = free . _vboPtr . _vaoVBO . _shadVAO freeShaderPointers = free . _vboPtr . _vaoVBO . _shadVAO
freeShaderPointers' :: FullShader' -> IO ()
freeShaderPointers' = free . _vboPtr . _vaoVBO . _shadVAO'
pokeBindFoldable pokeBindFoldable
:: MV.MVector (PrimState IO) FullShader :: MV.MVector (PrimState IO) FullShader'
-> UMV.MVector (PrimState IO) Int -> UMV.MVector (PrimState IO) Int
-> Picture -> Picture
-> IO () -> IO ()
@@ -63,7 +70,7 @@ pokeBindFoldable shadV counts m = do
bindShader shadV counts bindShader shadV counts
pokeBindFoldableLayer pokeBindFoldableLayer
:: MV.MVector (PrimState IO) FullShader :: MV.MVector (PrimState IO) FullShader'
-> UMV.MVector (PrimState IO) Int -> UMV.MVector (PrimState IO) Int
-> Picture -> Picture
-> IO () -> IO ()
@@ -71,6 +78,10 @@ pokeBindFoldableLayer shadV counts m = do
pokeLayVerxs shadV counts m pokeLayVerxs shadV counts m
bindShaderLayers shadV counts bindShaderLayers shadV counts
shadVBOptr :: FullShader -> Ptr Float shadVBOptr :: FullShader' -> Ptr Float
{-# INLINE shadVBOptr #-} {-# INLINE shadVBOptr #-}
shadVBOptr = _vboPtr . _vaoVBO . _shadVAO shadVBOptr = _vboPtr . _vaoVBO . _shadVAO'
shadVBOptr' :: FullShader' -> Ptr Float
{-# INLINE shadVBOptr' #-}
shadVBOptr' = _vboPtr . _vaoVBO . _shadVAO'
src/Shader/AuxAddition.hs
+76 -1
View File
@@ -1,13 +1,20 @@
module Shader.AuxAddition module Shader.AuxAddition
( addTexture ( addTexture
, addTexture'
, addTextureNoFilter , addTextureNoFilter
, vaddTextureNoFilter , vaddTextureNoFilter
, vaddTextureNoFilter'
, addTextureArray , addTextureArray
, addTextureArray'
, addUniforms , addUniforms
, addUniforms'
, tilesToLine -- ^ kept in case it is needed in the future , tilesToLine -- ^ kept in case it is needed in the future
) where ) where
import Shader.Data 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 qualified Data.Vector as V
import Data.List.Extra import Data.List.Extra
import Codec.Picture import Codec.Picture
@@ -37,6 +44,25 @@ addTexture texturePath shad = do
,_textureTarget = GL_TEXTURE_2D ,_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 :: String -> FullShader -> IO FullShader
vaddTextureNoFilter texturePath shad = do vaddTextureNoFilter texturePath shad = do
Right cmap <- readImage texturePath Right cmap <- readImage texturePath
@@ -54,6 +80,23 @@ vaddTextureNoFilter texturePath shad = do
, _textureTarget = GL_TEXTURE_2D , _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 :: String -> FullShader -> IO FullShader
addTextureNoFilter texturePath shad = do addTextureNoFilter texturePath shad = do
Right cmap <- readImage texturePath Right cmap <- readImage texturePath
@@ -95,6 +138,27 @@ addTextureArray texturePath shad = do
{ _textureObject = textureOb { _textureObject = textureOb
, _textureTarget = GL_TEXTURE_2D_ARRAY , _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 -- I am completely unclear on why this works with its current parameters
tilesToLine tilesToLine
@@ -108,3 +172,14 @@ addUniforms :: [String] -> FullShader -> IO FullShader
addUniforms uniStrings shad = do addUniforms uniStrings shad = do
uniLocs <- mapM (uniformLocation $ _shadProg shad) uniStrings uniLocs <- mapM (uniformLocation $ _shadProg shad) uniStrings
return $ shad & shadUnis %~ (V.++ V.fromList uniLocs) 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 module Shader.Bind
( bindShaderLayers ( bindShaderLayers
, bindShaderBuffers , bindShaderBuffers
, bindShaderBuffers'
, bindShader , bindShader
) where ) where
import Shader.Data import Shader.Data
@@ -25,11 +26,11 @@ bindArrayBuffers numVs theVBO = do
(fromIntegral $ floatSize * numVs * sum (_vboAttribSizes theVBO)) (fromIntegral $ floatSize * numVs * sum (_vboAttribSizes theVBO))
(_vboPtr 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 bindShaderLayers shads counts = MV.imapM_ f shads
where where
f i shad = do f i shad = do
let theVBO = _vaoVBO $ _shadVAO shad let theVBO = _vaoVBO $ _shadVAO' shad
stride = sum $ _vboAttribSizes theVBO stride = sum $ _vboAttribSizes theVBO
bindBuffer ArrayBuffer $= (Just . _vbo $ theVBO) bindBuffer ArrayBuffer $= (Just . _vbo $ theVBO)
VFSM.mapM_ (g stride theVBO) $ VFSM.enumFromStepN 0 1 6 -- [0..5] 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) (fromIntegral $ floatSize * numVs * stride)
(_vboPtr theVBO `plusPtr` (floatSize * stride * numSubElements * lay)) (_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 bindShader shads counts = MV.imapM_ f shads
where 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 bindShaderBuffers = zipWithM_ f
where 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 module Shader.Compile
( makeShader ( makeShader
, makeShader'
, makeByteStringShader , makeByteStringShader
, makeByteStringShader'
, makeByteStringShaderUsingVAO , makeByteStringShaderUsingVAO
, makeByteStringShaderUsingVAO'
, makeShaderSized , makeShaderSized
, makeShaderSized'
, makeShaderUsingShaderVAO , makeShaderUsingShaderVAO
, makeShaderUsingShaderVAO'
, makeShaderUsingVAO , makeShaderUsingVAO
, makeShaderUsingVAO'
, makeSourcedShader , makeSourcedShader
, setupVAO , setupVAO
, setupVertexAttribPointer , setupVertexAttribPointer
@@ -39,6 +45,22 @@ makeShader s shaderlist sizes pm = do
, _shadTex = Nothing , _shadTex = Nothing
, _shadUnis = mempty , _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' makeByteStringShader'
:: String -- ^ (Arbitrary) name of the shader :: String -- ^ (Arbitrary) name of the shader
@@ -88,6 +110,21 @@ makeByteStringShaderUsingVAO s shaderlist pm fs = do
, _shadUnis = mempty , _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 -- | Takes the VAO from elsewhere
makeShaderUsingVAO makeShaderUsingVAO
:: String -- ^ First part of the name of the shader :: String -- ^ First part of the name of the shader
@@ -104,6 +141,21 @@ makeShaderUsingVAO s shaderlist pm theVAO = do
, _shadTex = Nothing , _shadTex = Nothing
, _shadUnis = mempty , _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 -- | Takes the VAO from another shader
makeShaderUsingShaderVAO makeShaderUsingShaderVAO
@@ -120,6 +172,20 @@ makeShaderUsingShaderVAO s shaderlist pm fs = do
, _shadTex = Nothing , _shadTex = Nothing
, _shadUnis = mempty , _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. 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. 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 , _shadTex = Nothing
, _shadUnis = mempty , _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. -- | Compile shader and get its uniform locations.
-- supposes the shader code is in the shader folder, with the string names -- 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) sources <- forM sts $ \st -> BS.readFile ("shader/" ++ s ++ shaderTypeExt st)
makeShaderProgram s $ zip sts sources 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 :: ShaderType -> String
shaderTypeExt VertexShader = ".vert" shaderTypeExt VertexShader = ".vert"
shaderTypeExt GeometryShader = ".geom" shaderTypeExt GeometryShader = ".geom"
shaderTypeExt FragmentShader = ".frag" shaderTypeExt FragmentShader = ".frag"
shaderTypeExt _ = undefined 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 :: [Int] -> IO VAO
setupVAO sizes = do setupVAO sizes = do
theVAO <- genObjectName theVAO <- genObjectName
@@ -244,12 +338,20 @@ makeShaderProgram' :: String
makeShaderProgram' str srcs = do makeShaderProgram' str srcs = do
theprog <- glCreateProgram theprog <- glCreateProgram
shaders <- mapM (compileAndCheckShader' str) srcs shaders <- mapM (compileAndCheckShader' str) srcs
mapM_ (glAttachShader theprog) shaders
glLinkProgram theprog glLinkProgram theprog
glCheckError str glGetProgramiv glGetProgramInfoLog theprog GL_LINK_STATUS glCheckError (str ++ " linking ") glGetProgramiv glGetProgramInfoLog theprog GL_LINK_STATUS
mapM (glDetachShader theprog) shaders mapM_ (glDetachShader theprog) shaders
mapM glDeleteShader shaders mapM_ glDeleteShader shaders
return theprog 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 = glCheckError str f g x statustype =
alloca $ \statusPtr -> do alloca $ \statusPtr -> do
f x statustype statusPtr f x statustype statusPtr
@@ -294,7 +396,7 @@ compileAndCheckShader' str (theShaderType,sourceCode) = do
theShader <- glCreateShader theShaderType theShader <- glCreateShader theShaderType
setShaderSource theShader sourceCode setShaderSource theShader sourceCode
glCompileShader theShader glCompileShader theShader
glCheckError str glGetShaderiv glGetShaderInfoLog theShader GL_COMPILE_STATUS glCheckError (str ++ shaderTypeExt' theShaderType) glGetShaderiv glGetShaderInfoLog theShader GL_COMPILE_STATUS
return theShader return theShader
setShaderSource :: GLuint -> BS.ByteString -> IO () setShaderSource :: GLuint -> BS.ByteString -> IO ()
@@ -305,6 +407,7 @@ setShaderSource si src =
glShaderSource si 1 srcPtrBuf srcLengthBuf glShaderSource si 1 srcPtrBuf srcLengthBuf
-- https://hackage.haskell.org/package/OpenGL-3.0.3.0/docs/src/Graphics.Rendering.OpenGL.GL.ByteString.html#withByteStringP -- 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 = withByteString bs act =
BU.unsafeUseAsCStringLen bs $ \(ptr, size) -> BU.unsafeUseAsCStringLen bs $ \(ptr, size) ->
act (castPtr ptr) (fromIntegral size) act (castPtr ptr) (fromIntegral size)
src/Shader/Data.hs
+10 -2
View File
@@ -33,9 +33,13 @@ module Shader.Data
, vert , vert
, geom , geom
, frag , frag
, vert'
, geom'
, frag'
) where ) where
import Data.Vector (Vector) import Data.Vector (Vector)
import Graphics.Rendering.OpenGL import Graphics.Rendering.OpenGL
import Graphics.GL.Core43
import Foreign import Foreign
import Control.Lens import Control.Lens
{- | Datatype containing the necessary information for a single shader. -} {- | Datatype containing the necessary information for a single shader. -}
@@ -47,11 +51,11 @@ data FullShader = FullShader
, _shadUnis :: Vector UniformLocation , _shadUnis :: Vector UniformLocation
} }
data FullShader' = FullShader' data FullShader' = FullShader'
{ _shadProg' :: GLuint { _shadProg' :: GLuint -- should be shaderID
, _shadVAO' :: VAO , _shadVAO' :: VAO
, _shadPrim' :: EPrimitiveMode , _shadPrim' :: EPrimitiveMode
, _shadTex' :: Maybe ShaderTexture , _shadTex' :: Maybe ShaderTexture
, _shadUnis' :: Vector UniformLocation , _shadUnis' :: Vector GLint
} }
{- | Vertex array object: contains the reference to the object, {- | Vertex array object: contains the reference to the object,
and its buffer targets. -} and its buffer targets. -}
@@ -96,6 +100,10 @@ vert, geom, frag :: ShaderType
vert = VertexShader vert = VertexShader
geom = GeometryShader geom = GeometryShader
frag = FragmentShader frag = FragmentShader
vert', geom', frag' :: GLenum
vert' = GL_VERTEX_SHADER
geom' = GL_GEOMETRY_SHADER
frag' = GL_FRAGMENT_SHADER
makeLenses ''VAO makeLenses ''VAO
makeLenses ''VBO makeLenses ''VBO
makeLenses ''FullShader 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 --import qualified Control.Monad.Parallel as MP
pokeVerxs pokeVerxs
:: MV.MVector (PrimState IO) FullShader :: MV.MVector (PrimState IO) FullShader'
-> UMV.MVector (PrimState IO) Int -> UMV.MVector (PrimState IO) Int
-> Picture -> Picture
-> IO () -> IO ()
--pokeVerxs vbos count = S.mapM_ (pokeVerx vbos count) . S.each --pokeVerxs vbos count = S.mapM_ (pokeVerx vbos count) . S.each
pokeVerxs vbos count = VFSM.mapM_ (pokeVerx vbos count) . VFSM.fromList 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 pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=theShadNum} = do
typeOff <- UMV.unsafeRead offsets sn 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) let thePtr = plusPtr basePtr (typeOff * pokeStride sn * floatSize)
poke34 thePtr thePos theCol poke34 thePtr thePos theCol
pokeArrayOff thePtr 7 ext pokeArrayOff thePtr 7 ext
@@ -183,18 +183,18 @@ pokeJustV ptr nv sh = do
V4 d e f g = _svCol sh V4 d e f g = _svCol sh
pokeLayVerxs pokeLayVerxs
:: MV.MVector (PrimState IO) FullShader :: MV.MVector (PrimState IO) FullShader'
-> UMV.MVector (PrimState IO) Int -> UMV.MVector (PrimState IO) Int
-> Picture -> Picture
-> IO () -> IO ()
--pokeLayVerxs vbos counts = S.mapM_ (pokeLayVerx vbos counts) . S.each --pokeLayVerxs vbos counts = S.mapM_ (pokeLayVerx vbos counts) . S.each
pokeLayVerxs vbos counts = VFSM.mapM_ (pokeLayVerx vbos counts) . VFSM.fromList 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 #-} --{-# INLINE pokeLayVerx #-}
pokeLayVerx vbos counts vx = do pokeLayVerx vbos counts vx = do
theOff <- UMV.unsafeRead counts vecPos 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) let thePtr = plusPtr basePtr ((theOff + layOff) * theStride * floatSize)
poke34 thePtr thePos theCol poke34 thePtr thePos theCol
pokeArrayOff thePtr 7 (_vxExt vx) pokeArrayOff thePtr 7 (_vxExt vx)