Refactor poking slightly

2021-06-12 02:40:45 +02:00
parent 02a2d3920d
commit 8723be7f26
5 changed files with 71 additions and 75 deletions
@@ -18,6 +18,8 @@ import Picture.Render
 import Picture.Preload
 import Picture.Data
 import Shader
+import Shader.Data
+import Shader.Poke
 import MatrixHelper

 import Foreign (Word32)
@@ -136,7 +138,7 @@ renderBlankWalls
    -> GLmatrix GLfloat 
    -> IO ()
 renderBlankWalls pdata wps pmat = do
-    n <- F.foldM (pokeShader' $ _wallBlankShader pdata) (map Render22x4 wps)
+    n <- F.foldM (pokeShader $ _wallBlankShader pdata) (map Render22x4 wps)
    bindShaderBuffers [_wallBlankShader pdata] [n]
    currentProgram $= Just (_shaderProgram $ _wallBlankShader pdata)
    uniform (_shaderMatrixUniform $ _wallBlankShader pdata) $= pmat
@@ -150,7 +152,7 @@ renderTextureWalls
    -> GLmatrix GLfloat 
    -> IO ()
 renderTextureWalls pdata wps pmat = do
-    n <- F.foldM (pokeShader' $ _wallTextureShader pdata) (map Render22x4 wps)
+    n <- F.foldM (pokeShader $ _wallTextureShader pdata) (map Render22x4 wps)
    bindShaderBuffers [_wallTextureShader pdata] [n]
    currentProgram $= Just (_shaderProgram $ _wallTextureShader pdata)
    uniform (_shaderMatrixUniform $ _wallTextureShader pdata) $= pmat
@@ -8,6 +8,7 @@ module Picture.Preload
    where
 import Picture.Data
 import Shader
+import Shader.Data
 import Shader.Compile
 import Shader.AuxAddition
 import Geometry.Data
@@ -15,7 +16,6 @@ import Geometry.Data
 import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
 import Control.Lens
 import Foreign
-import qualified Control.Foldl as F

 data RenderData = RenderData
    { _lightingFloorShader      :: FullShader
@@ -52,33 +52,17 @@ preloadRender = do
    lslist <- makeShader "twoD/basic"   [vert,frag]      [3,4]   Lines     pokeLineStrat
    aslist <- makeShader "twoD/arc"     [vert,geom,frag] [3,4,4] Points    pokeArcStrat
    eslist <- makeShader "twoD/ellipse" [vert,geom,frag] [3,4]   Triangles pokeEllStrat
-    bezierQuadShader <- makeShader 
-                      "twoD/bezierQuad" [vert,frag] [3,4,4]    TriangleStrip pokeBezQStrat
-    cslist <- makeShader "twoD/character" [vert,geom,frag] 
-                                [3,4,3] Points pokeCharStrat
+    bezierQuadShader <- makeShader "twoD/bezierQuad" [vert,frag] [3,4,4]  TriangleStrip pokeBezQStrat
+    cslist <- makeShader "twoD/character" [vert,geom,frag] [3,4,3] Points pokeCharStrat
                  >>= addTexture "data/texture/charMap.png"
 -- texture shaders, no textures attached
-    fsShad <- makeShader "texture/simple" [vert,frag] [2,2] TriangleStrip $ const
-        [[-1, 1,0,1]
-        ,[ 1, 1,1,1]
-        ,[-1,-1,0,0]
-        ,[ 1,-1,1,0]
-        ]
-    _ <- F.foldM (pokeShader' fsShad) [RenderConst] -- fix fullscreen vertex positions now
-    boxBlurShad <- makeShader "texture/boxBlur" [vert,frag] [2,2] TriangleStrip $ const
-        [[-1, 1,0,1]
-        ,[ 1, 1,1,1]
-        ,[-1,-1,0,0]
-        ,[ 1,-1,1,0]
-        ]
-    _ <- F.foldM (pokeShader' boxBlurShad) [RenderConst] -- fix fullscreen vertex positions now
-    grayscaleShad <- makeShader "texture/grayscale" [vert,frag] [2,2] TriangleStrip $ const
-        [[-1, 1,0,1]
-        ,[ 1, 1,1,1]
-        ,[-1,-1,0,0]
-        ,[ 1,-1,1,0]
-        ]
-    _ <- F.foldM (pokeShader' grayscaleShad) [RenderConst] -- fix fullscreen vertex positions now
+    fsShad <- makeShader "texture/simple" [vert,frag] [2,2] TriangleStrip $ const cornerList
+    -- note we directly poke the shader vertex data here
+    pokeArray (_vboPointer $ _vaoVBO $ _shaderVAO fsShad) $ concat cornerList
+    boxBlurShad <- makeShader "texture/boxBlur" [vert,frag] [2,2] TriangleStrip $ const cornerList
+    pokeArray (_vboPointer $ _vaoVBO $ _shaderVAO boxBlurShad) $ concat cornerList
+    grayscaleShad <- makeShader "texture/grayscale" [vert,frag] [2,2] TriangleStrip $ const cornerList
+    pokeArray (_vboPointer $ _vaoVBO $ _shaderVAO grayscaleShad) $ concat cornerList
 -- background shader
    bgShad <- makeShader "background" [vert,geom,frag] [4,2] Points pokeBGStrat
                >>= addTexture "data/texture/marbleSlabs.png"
@@ -118,6 +102,13 @@ preloadRender = do
        , _fbo3                     = framebuf3
        }

+cornerList :: [[Float]]
+cornerList =
+        [[-1, 1,0,1]
+        ,[ 1, 1,1,1]
+        ,[-1,-1,0,0]
+        ,[ 1,-1,1,0]
+        ]
 -- potential drawing setup
 ----                            swapInterval $= ImmediateUpdates
 --                            GL.blend $= GL.Enabled
@@ -9,6 +9,8 @@ module Picture.Render
    where

 import Shader
+import Shader.Data
+import Shader.Poke
 --import MatrixHelper
 import Picture.Preload
 import Picture.Data
@@ -34,7 +36,7 @@ setWallDepth
 setWallDepth pdata wallPoints (viewFromx,viewFromy) _ = do
    startTicks <- SDL.ticks
    colorMask $= Color4 Disabled Disabled Disabled Disabled
-    nWalls <- F.foldM (pokeShader' $ _lightingOccludeShader pdata) (map Render22 wallPoints)
+    nWalls <- F.foldM (pokeShader $ _lightingOccludeShader pdata) (map Render22 wallPoints)
    bindShaderBuffers [_lightingOccludeShader pdata] [nWalls]

    currentProgram $= Just (_shaderProgram $ _lightingOccludeShader pdata)
@@ -76,9 +78,9 @@ createLightMap pdata resDiv wallPoints lightPoints (viewFromx,viewFromy) pmat _
    bindFramebuffer Framebuffer $= _spareFBO pdata

 -- store wall and light positions into buffer
-    nWallLights <- F.foldM (pokeShader' $ _lightingWallShader pdata) (map Render22 wallPoints)
+    nWallLights <- F.foldM (pokeShader $ _lightingWallShader pdata) (map Render22 wallPoints)
    bindShaderBuffers [_lightingWallShader pdata] [nWallLights]
-    nWalls <- F.foldM (pokeShader' $ _lightingOccludeShader pdata) (map Render22 wallPoints)
+    nWalls <- F.foldM (pokeShader $ _lightingOccludeShader pdata) (map Render22 wallPoints)
    bindShaderBuffers [_lightingOccludeShader pdata] [nWalls]
 -- set uniforms for shader that draws lights
    currentProgram $= Just (_shaderProgram $ _lightingWallShader pdata)
@@ -246,7 +248,7 @@ renderShader
    -> IO Word32
 renderShader shad dat = do
    sticks <- SDL.ticks
-    i <- F.foldM  (pokeShader' shad) dat
+    i <- F.foldM  (pokeShader shad) dat
    bindShaderBuffers [shad] [i]
    drawShader shad i
    eticks <- SDL.ticks
@@ -257,13 +259,13 @@ renderFoldable
    => RenderData
    -> f RenderType
    -> IO Word32
-renderFoldable pdata tree = do
+renderFoldable pdata struct = do
    pokeStartTicks <- SDL.ticks

    let slist = _pictureShaders pdata

 -- poke data, returns list of number of vertices for each shader
-    is <- F.foldM (pokeShaders slist) tree
+    is <- F.foldM (pokeShaders slist) struct

 -- the idea of binding many buffers at once, rather than interweaving with draw
 -- calls, is to prevent opengl from waiting for a draw call to finish
@@ -1,8 +1,5 @@
 module Shader
-    ( pokeShaders
-    , pokeArrayOff
-    , pokeShader'
-    , bindArrayBuffers'
+    ( bindArrayBuffers'
    , bindShaderBuffers
    , drawShader
    , drawShaders
@@ -11,18 +8,14 @@ module Shader
    , extractProgAndUnis 
    , freeShaderPointers
    , setPerpMatUniform
-    , module Shader.Data
-    )
-  where
-import Geometry
+    ) where
+import Geometry.Data
 import Shader.Data
 import Shader.Parameters
 import MatrixHelper
-import Picture.Data

 import Foreign
 import Control.Monad
-import qualified Control.Foldl as F
 import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
 --import Text.RawString.QQ
 import Linear.Matrix
@@ -31,37 +24,6 @@ import Linear.V4
 extractProgAndUnis :: FullShader -> (Program,UniformLocation)
 extractProgAndUnis s = (_shaderProgram s, _shaderMatrixUniform s)

-pokeShaders :: [FullShader] -> F.FoldM IO RenderType [Int]
-pokeShaders = traverse pokeShader'
-
-pokeShader' :: FullShader -> F.FoldM IO RenderType Int
-pokeShader' fs = F.FoldM (pokeRender' fls ptr stride)  (return 0) return
-  where 
-    theVBO = _vaoVBO $ _shaderVAO fs
-    ptr = _vboPointer theVBO
-    stride = sum $ _vboAttribSizes theVBO
-    fls = _shaderPokeStrategy fs
-
-pokeRender' 
-    :: (RenderType -> [[Float]])
-    -> Ptr Float
-    -> Int  -- ^ stride
-    -> Int 
-    -> RenderType 
-    -> IO Int
-pokeRender' toFs ptr stride n rt = pokeList' ptr stride n (toFs rt)
-
-pokeList' :: Ptr Float -> Int -> Int -> [[Float]] -> IO Int
-pokeList' ptr stride = foldM (pokePtrs' ptr stride)
-
-pokePtrs' :: Ptr Float -> Int -> Int -> [Float] -> IO Int
-pokePtrs' ptr stride n fs = do
-    pokeArrayOff ptr (stride * n) fs
-    return $ n + 1
-
-pokeArrayOff :: Storable a => Ptr a -> Int -> [a] -> IO ()
-pokeArrayOff ptr i = zipWithM_ (pokeElemOff ptr) [i..]
-
 bindArrayBuffers' :: Int -> VBO -> IO ()
 bindArrayBuffers' numVs theVBO = do
    bindBuffer ArrayBuffer $= Just (_vbo theVBO)
@@ -0,0 +1,39 @@
+module Shader.Poke
+    ( pokeShaders
+    , pokeArrayOff
+    , pokeShader
+    ) where
+import Shader.Data
+import Picture.Data
+
+import Foreign
+import Control.Monad
+import qualified Control.Foldl as F
+
+pokeShaders :: [FullShader] -> F.FoldM IO RenderType [Int]
+pokeShaders = traverse pokeShader
+
+pokeShader :: FullShader -> F.FoldM IO RenderType Int
+pokeShader fs = F.FoldM (pokeRender fls ptr stride)  (return 0) return
+  where 
+    theVBO = _vaoVBO $ _shaderVAO fs
+    ptr = _vboPointer theVBO
+    stride = sum $ _vboAttribSizes theVBO
+    fls = _shaderPokeStrategy fs
+
+pokeRender 
+    :: (RenderType -> [[Float]])
+    -> Ptr Float
+    -> Int  -- ^ stride
+    -> Int 
+    -> RenderType 
+    -> IO Int
+pokeRender toFs ptr stride n rt = foldM (pokePtrs ptr stride) n (toFs rt)
+
+pokePtrs :: Ptr Float -> Int -> Int -> [Float] -> IO Int
+pokePtrs ptr stride n fs = do
+    pokeArrayOff ptr (stride * n) fs
+    return $ n + 1
+
+pokeArrayOff :: Storable a => Ptr a -> Int -> [a] -> IO ()
+pokeArrayOff ptr i = zipWithM_ (pokeElemOff ptr) [i..]