Broken binding of central picture in one pass

package.yaml

@@ -51,6 +51,8 @@ dependencies:
 
 library:
   source-dirs: src
+  #  ghc-options: -fwrite-ide-info
+  #    -hiedir=.hie
 
 executables:
     #  loop-exe:
@@ -69,6 +71,8 @@ executables:
     - -funfolding-keeness-factor1000 
     - -fllvm 
     - -optlo-O3
+#    - -fwrite-ide-info
+#    - -hiedir=.hie
     dependencies:
     - loop
 

src/Dodge/Render.hs

@@ -34,7 +34,7 @@ import qualified Control.Foldl as F
 --import Data.List
 --import Data.Bifunctor
 --import Data.Function
---import qualified Data.IntMap.Strict as IM
+import qualified Data.IntMap.Strict as IM
 --import qualified Data.Map as M
 --import qualified Data.Set as S
 import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate)
@@ -60,7 +60,7 @@ doDrawing pdata w = do
     -- poke foreground geometry and floor
     let addC (xx,yy) = (xx,yy,0)
     nsurfVs <- F.foldM (pokeShader (_lightingSurfaceShader pdata)) 
-        $ (Render3 $ polyToTris $ map addC $ screenPolygon w)
+        $ Render3 (polyToTris $ map addC $ screenPolygon w)
         : concatMap polyToGeoRender (foregroundPics w)
     -- bind wall points, silhouette data, surface geometry
     uncurry bindShaderBuffers $ unzip
@@ -80,19 +80,27 @@ doDrawing pdata w = do
     --_ <- renderFoldable pdata $ (picToAlt (Just 0) (polysToPic $ foregroundPics w) :: [RenderType])
     --_ <- renderFoldable pdata $ (picToAlt (Just 0) pic :: [RenderType])
     _ <- renderFoldable pdata $ map snd (polysToPic $ foregroundPics w)
-    _ <- renderFoldable pdata $ map snd $ filter ((==0).fst) pic
+
+    --_ <- renderFoldable pdata $ map snd $ filter ((==0).fst) pic
+    vnums <- pokeBindFoldableLayer pdata $ pic
+    mapM_ (uncurry $ drawShaderLay 0) (vnums IM.! 0)
+
     _ <- renderShader (_textureArrayShader pdata) (_floorTiles w)
 
     bindFramebuffer Framebuffer $= fst (_fboBloom pdata)
     clear [ColorBuffer]
     blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-    _ <- renderFoldable pdata $ map snd $ filter ((==1).fst) pic
+    --_ <- renderFoldable pdata $ map snd $ filter ((==1).fst) pic
+    mapM_ (uncurry $ drawShaderLay 1) (vnums IM.! 1)
     bindFramebuffer Framebuffer $= fst (_fboColor pdata)
     clear [ColorBuffer]
     depthMask $= Disabled
-    _ <- renderFoldable pdata $ map snd $ filter ((==3).fst) pic
+    mapM_ (uncurry $ drawShaderLay 3) (vnums IM.! 3)
-    _ <- renderFoldable pdata $ map snd $ filter ((==4).fst) pic
+    mapM_ (uncurry $ drawShaderLay 4) (vnums IM.! 4)
-    _ <- renderFoldable pdata $ map snd $ filter ((==5).fst) pic
+    mapM_ (uncurry $ drawShaderLay 5) (vnums IM.! 5)
+    --_ <- renderFoldable pdata $ map snd $ filter ((==3).fst) pic
+    --_ <- renderFoldable pdata $ map snd $ filter ((==4).fst) pic
+    --_ <- renderFoldable pdata $ map snd $ filter ((==5).fst) pic
 
     depthMask $= Enabled
     bindFramebuffer Framebuffer $= fst (_fboFourth1 pdata)
@@ -135,7 +143,8 @@ doDrawing pdata w = do
     drawShader (_fullscreenShader pdata) 4
 
     depthFunc $= Just Lequal
-    _ <- renderFoldable pdata $ map snd $ filter ((==2).fst) pic
+    --_ <- renderFoldable pdata $ map snd $ filter ((==2).fst) pic
+    mapM_ (uncurry $ drawShaderLay 2) (vnums IM.! 2)
     renderWindows pdata windowPoints
 
     depthFunc $= Just Always

src/Picture.hs

@@ -176,11 +176,11 @@ scale3 a b (x,y,z) = (x*a,y*b,z)
 
 scale :: Float -> Float -> Picture -> Picture
 {-# INLINE scale #-}
-scale x y = map $ second $ overPos $ (scale3 x y)
+scale x y = map . second . overPos $ scale3 x y
 
 rotate :: Float -> Picture -> Picture
 {-# INLINE rotate #-}
-rotate a = map $ second $ overPos $ (rotate3 a)
+rotate a = map . second . overPos $ rotate3 a
 
 pictures :: [Picture] -> Picture
 {-# INLINE pictures #-}

src/Preload/Render.hs

@@ -19,6 +19,9 @@ import Graphics.GL.Core43
 --import Control.Monad
 import Foreign
 
+numDrawableWalls :: Int
+numDrawableWalls = 5000
+
 preloadRender :: IO RenderData
 preloadRender = do
     -- set up uniform buffer object
@@ -28,10 +31,10 @@ preloadRender = do
     bindBufferBase IndexedUniformBuffer 0 $= Just theUBO
     -- setup wall points VBO, VAOs and shaders
     wpVBOname <- genObjectName
-    wpVBOptr <- mallocArray (8 * numDrawableElements)
+    wpVBOptr <- mallocArray (8 * numDrawableWalls)
     bindBuffer ArrayBuffer $= Just wpVBOname
     bufferData ArrayBuffer $=
-        (fromIntegral $ floatSize * numDrawableElements * 8
+        (fromIntegral $ floatSize * numDrawableWalls * 8
         , nullPtr
         , DynamicDraw
         )
@@ -69,11 +72,11 @@ preloadRender = do
                     -- this should really be a 2d texture array
     basicTweakZShad <- makeShader "twoD/basicTweakZ" [vert,frag] [4,4] ETriangles pokeTriTweakZ
 -- fullscreen shaders
-    fullscreenAlphaHalveShad <- makeShader "fullscreen/alphaHalve" [vert,frag] [2] ETriangleStrip $
+    fullscreenAlphaHalveShad <- makeShaderSized "fullscreen/alphaHalve" [vert,frag] [2] 4 ETriangleStrip $
         const cornerListNoCoord
     pokeArray (_vboPointer $ _vaoVBO $ _shaderVAO fullscreenAlphaHalveShad) $ concat cornerListNoCoord
 -- texture shaders, no textures attached
-    fsShad <- makeShader "texture/simple" [vert,frag] [2,2] ETriangleStrip $ const cornerList
+    fsShad <- makeShaderSized "texture/simple" [vert,frag] [2,2] 4 ETriangleStrip $ const cornerList
     -- note we directly poke the shader vertex data here
     pokeArray (_vboPointer $ _vaoVBO $ _shaderVAO fsShad) $ concat cornerList
     bloomBlurShad <- makeShaderUsingShaderVAO "texture/bloomBlur" [vert,frag] ETriangleStrip fsShad

src/Render.hs

@@ -19,7 +19,7 @@ import Foreign hiding (rotate)
 import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,Polygon,Color,T)
 --import Data.Foldable
 --import Data.Tuple.Extra
---import qualified Data.IntMap.Strict as IM
+import qualified Data.IntMap.Strict as IM
 import qualified SDL
 
 divideSize :: Int -> Size -> Size
@@ -152,6 +152,18 @@ renderShader shad dat = do
     eticks <- SDL.ticks
     return $ eticks - sticks
 
+pokeBindFoldableLayer
+    :: Foldable f
+    => RenderData
+    -> f (Int,RenderType)
+    -> IO (IM.IntMap [(FullShader,Int)])
+pokeBindFoldableLayer pdata m = do
+    let slist = (,) <$> [0..6] <*> _pictureShaders pdata
+
+    is <- F.foldM (traverse pokeShaderLayer slist) m
+    bindShaderLayer slist is
+    return $ IM.fromListWith (++) $ zipWith (\(i,fs) n -> (i,[(fs,n)])) slist is
+
 renderFoldable
     :: Foldable f
     => RenderData

src/Shader.hs

@@ -1,8 +1,10 @@
 module Shader
-    ( bindArrayBuffers
+    ( bindShaderLayer
     , bindShaderBuffers
+    , bindArrayBuffers
     , drawShader
     , freeShaderPointers
+    , drawShaderLay
     ) where
 --import Geometry.Data
 import Shader.Data
@@ -28,11 +30,41 @@ bindArrayBuffers numVs theVBO = do
         (fromIntegral $ floatSize * numVs * sum (_vboAttribSizes theVBO)) 
         (_vboPointer theVBO)
 
+bindArrayBuffersLayer :: Int -> Int -> VBO -> IO ()
+bindArrayBuffersLayer numVs lay theVBO = do
+    bindBuffer ArrayBuffer $= Just (_vbo theVBO)
+    bufferSubData 
+        ArrayBuffer 
+        WriteToBuffer 
+        (fromIntegral $ floatSize * stride * numSubElements * lay)
+        (fromIntegral $ floatSize * numVs * stride)
+        (_vboPointer theVBO)
+  where
+    stride = sum $ _vboAttribSizes theVBO
+
+bindShaderLayer :: [(Int,FullShader)] -> [Int] -> IO ()
+bindShaderLayer = zipWithM_ f
+  where 
+    f (l,fs) i = bindArrayBuffersLayer i l $ _vaoVBO $ _shaderVAO fs
+
 bindShaderBuffers :: [FullShader] -> [Int] -> IO ()
 bindShaderBuffers = zipWithM_ f
   where 
     f fs i = bindArrayBuffers i $ _vaoVBO $ _shaderVAO fs
 
+drawShaderLay :: Int -> FullShader -> Int -> IO ()
+{-# INLINE drawShaderLay #-}
+drawShaderLay l fs i = do 
+    currentProgram $= Just (_shaderProgram fs)
+    bindVertexArrayObject $= Just (_vao $ _shaderVAO fs)
+    case _shaderTexture fs of 
+        Just ShaderTexture{_textureObject = txo}
+            -> textureBinding Texture2D $= Just txo
+        _   -> return ()
+    glDrawArrays (marshalEPrimitiveMode $ _shaderDrawPrimitive fs) (fromIntegral $ l*stride*floatSize) (fromIntegral i)
+  where
+    stride = sum $ _vboAttribSizes $ _vaoVBO $ _shaderVAO fs
+
 drawShader :: FullShader -> Int -> IO ()
 {-# INLINE drawShader #-}
 drawShader fs i = do 

src/Shader/Compile.hs

@@ -1,5 +1,6 @@
 module Shader.Compile
     ( makeShader
+    , makeShaderSized
     , makeShaderUsingShaderVAO
     , makeSourcedShader
     , setupVAO
@@ -52,6 +53,29 @@ makeShader s shaderlist sizes pm renStrat = do
         , _shaderTexture = Nothing
         , _shaderCustomUnis = []
         }
+{- | 
+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.
+-}
+makeShaderSized
+    :: String       -- ^ First part of the name of the shader
+    -> [ShaderType] -- ^ Filetype extensions
+    -> [Int]   -- ^ The input vertex sizes
+    -> Int          -- ^ Number of vertexes that can be poked
+    -> EPrimitiveMode
+    -> (RenderType -> [[Float]])   -- ^ Poke strategy: method for creating a list of vertex data to be bound
+    -> IO FullShader
+makeShaderSized s shaderlist sizes ndraw pm renStrat = do
+    prog <- makeSourcedShader s shaderlist
+    vaob <- setupVAOSized sizes ndraw
+    return $ FullShader 
+        { _shaderProgram = prog
+        , _shaderVAO = vaob
+        , _shaderPokeStrategy = renStrat
+        , _shaderDrawPrimitive = pm
+        , _shaderTexture = Nothing
+        , _shaderCustomUnis = []
+        }
 
 -- | Compile shader and get its uniform locations.
 -- supposes the shader code is in the shader folder, with the string names
@@ -76,6 +100,15 @@ setupVAO sizes = do
         { _vao = theVAO
         , _vaoVBO = theVBO
         }
+setupVAOSized :: [Int] -> Int -> IO VAO
+setupVAOSized sizes ndraw = do
+    theVAO <- genObjectName
+    bindVertexArrayObject $= Just theVAO
+    theVBO <- setupVBOSized sizes ndraw
+    return $ VAO 
+        { _vao = theVAO
+        , _vaoVBO = theVBO
+        }
 
 setupVBO :: [Int] -> IO VBO
 setupVBO sizes = do
@@ -98,6 +131,28 @@ setupVBO sizes = do
   where
     strd = sum sizes
     offs = scanl (+) 0 sizes
+
+setupVBOSized :: [Int] -> Int -> IO VBO
+setupVBOSized sizes ndraw = do
+    vboName <- genObjectName
+    bindBuffer ArrayBuffer $= Just vboName
+    forM_ (zip3 [0..] sizes offs) $ \(loc,siz,off) -> do
+        setupVertexAttribPointer loc siz strd off
+    thePtr <- mallocArray (strd * ndraw)
+    -- Allocate space
+    bufferData ArrayBuffer $=
+        (fromIntegral $ floatSize * ndraw * strd
+        , nullPtr
+        , DynamicDraw
+        )
+    return $ VBO
+        { _vbo = vboName
+        , _vboPointer = thePtr
+        , _vboAttribSizes = sizes
+        }
+  where
+    strd = sum sizes
+    offs = scanl (+) 0 sizes
     
 {- | Assumes the correct VBO is bound -}
 setupVertexAttribPointer 

src/Shader/Parameters.hs

@@ -1,6 +1,7 @@
 module Shader.Parameters
     ( floatSize
     , numDrawableElements
+    , numSubElements
     ) where
 import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
 import Foreign
@@ -11,5 +12,8 @@ floatSize = sizeOf (0.5 :: GLfloat)
 
 numDrawableElements :: Int
 {-# INLINE numDrawableElements #-}
-numDrawableElements = 50000
+numDrawableElements = 70000
 
+numSubElements :: Int
+{-# INLINE numSubElements #-}
+numSubElements = 10000

src/Shader/Poke.hs

@@ -1,8 +1,10 @@
 module Shader.Poke
     ( pokeArrayOff
     , pokeShader
+    , pokeShaderLayer
     ) where
 import Shader.Data
+import Shader.Parameters
 import Picture.Data
 
 import Foreign
@@ -17,6 +19,15 @@ pokeShader fs = F.FoldM (pokeVertices fls ptr stride)  (return 0) return
     stride = sum $ _vboAttribSizes theVBO
     fls = _shaderPokeStrategy fs
 
+pokeShaderLayer :: (Int,FullShader) -> F.FoldM IO (Int,RenderType) Int
+pokeShaderLayer (l,fs) = F.FoldM (pokeVerticesOff fls ptr stride l)  (return 0) return
+  where 
+    theVBO = _vaoVBO $ _shaderVAO fs
+    ptr = _vboPointer theVBO
+    stride = sum $ _vboAttribSizes theVBO
+    fls = _shaderPokeStrategy fs
+
+
 pokeVertices 
     :: (RenderType -> [[Float]])
     -> Ptr Float
@@ -26,6 +37,24 @@ pokeVertices
     -> IO Int
 pokeVertices toFs ptr stride n rt = foldM (pokeVertex ptr stride) n (toFs rt)
 
+pokeVerticesOff
+    :: (RenderType -> [[Float]])
+    -> Ptr Float
+    -> Int  -- ^ stride
+    -> Int  -- ^ offset
+    -> Int  -- ^ number of vertices already poked
+    -> (Int,RenderType)
+    -> IO Int
+pokeVerticesOff toFs ptr stride offset n (i,rt) 
+    | offset == i = foldM (pokeVertexOff ptr stride offset) n (toFs rt)
+    | otherwise = return n
+
+pokeVertexOff :: Ptr Float -> Int -> Int -> Int -> [Float] -> IO Int
+pokeVertexOff ptr stride offset n fs = do
+    pokeArrayOff ptr (stride * (n + offset * numSubElements)) fs
+    return $ n + 1
+
+
 pokeVertex :: Ptr Float -> Int -> Int -> [Float] -> IO Int
 pokeVertex ptr stride n fs = do
     pokeArrayOff ptr (stride * n) fs