Move shader compilation over to raw opengl, errors display incorrect
This commit is contained in:
+17
-17
@@ -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)
|
||||
|
||||
+11
-8
@@ -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
|
||||
|
||||
@@ -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 ()
|
||||
|
||||
+33
-33
@@ -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
|
||||
|
||||
@@ -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})
|
||||
|
||||
+32
-22
@@ -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
|
||||
|
||||
+25
-14
@@ -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'
|
||||
|
||||
@@ -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])
|
||||
|
||||
|
||||
|
||||
+12
-6
@@ -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
|
||||
|
||||
+108
-5
@@ -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)
|
||||
|
||||
+10
-2
@@ -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
|
||||
|
||||
+6
-6
@@ -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)
|
||||
|
||||
Reference in New Issue
Block a user