Continue tweaking rendering

app/Main.hs

@@ -54,12 +54,12 @@ doSideEffects preData w = do
     
     endTicks <- SDL.ticks
     let lastFrameTicks = _frameTimer preData
--- FIXME    when (_displaySecondsPerFrame $ _debugFlags w) $ void $ renderFoldable
+    when (_displaySecondsPerFrame $ _debugFlags w) $ void $ renderFoldable
--- FIXME                (_renderData preData)
+                (_renderData preData)
--- FIXME                (map snd $ setDepth (-1)
+                (setDepth (-1)
--- FIXME                    . translate (-0.5) (-0.8) . scale 0.0005 0.0005
+                    . translate (-0.5) (-0.8) . scale 0.0005 0.0005
--- FIXME                    . text $ "ms/frame " ++ show (endTicks - lastFrameTicks)
+                    . text $ "ms/frame " ++ show (endTicks - lastFrameTicks)
--- FIXME                )
+                )
     foldr (=<<) (return (preData & soundData . playingSounds .~ newPlayingSounds
                     & frameTimer .~ endTicks)) (_doneSideEffects w)
 

src/Dodge/Render.hs

@@ -79,7 +79,7 @@ doDrawing pdata w = do
         else renderBlankWalls pdata nWalls
     --_ <- renderFoldable pdata $ (picToAlt (Just 0) (polysToPic $ foregroundPics w) :: [RenderType])
     --_ <- renderFoldable pdata $ (picToAlt (Just 0) pic :: [RenderType])
--- FIXME    _ <- renderFoldable pdata $ map snd (polysToPic $ foregroundPics w)
+    _ <- renderFoldable pdata $ polysToPic $ foregroundPics w
 
     --_ <- renderFoldable pdata $ map snd $ filter ((==0).fst) pic
     vnums <- pokeBindFoldableLayer pdata $ pic
@@ -175,7 +175,7 @@ doDrawing pdata w = do
     depthMask $= Disabled
     blend $= Enabled
     blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
--- FIXME    _ <- renderFoldable pdata $ map snd (fixedCoordPictures w)
+    _ <- renderFoldable pdata $ fixedCoordPictures w
     depthMask $= Enabled
 
     eTicks <- SDL.ticks

src/Render.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 module Render
     where
 import Shader
@@ -159,33 +160,37 @@ pokeBindFoldableLayer
     -> IO (IM.IntMap [(VShader,Int)])
 pokeBindFoldableLayer pdata m = do
     let slist = (,) <$> [0..6] <*> _pictureShaders pdata
+        slist' = IM.fromListWith (++) ((,) <$> [0..6] <*> map ((:[]) . (, 0)) (_pictureShaders pdata))
 
-    is <- F.foldM (traverse pokeShaderLayer slist) m
+--    is <- F.foldM (traverse pokeShaderLayer slist) m
+--    bindShaderLayer slist is
+    slist'' <- foldM pokeVX slist' m
+    bindShaderLay slist''
+    --return $ IM.fromListWith (++) $ zipWith (\(i,fs) n -> (i,[(fs,n)])) slist is
+    return slist''
+
+renderFoldable
+    :: Foldable f
+    => RenderData
+    -> f Verx
+    -> IO Word32
+renderFoldable pdata struct = do
+    pokeStartTicks <- SDL.ticks
+
+    let slist = (,) <$> [0..6] <*> _pictureShaders pdata
+
+-- poke data, returns list buffer sizes for each shader
+    is <- F.foldM (traverse pokeShaderLayer 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
+-- before it performs another state change
     bindShaderLayer slist is
-    return $ IM.fromListWith (++) $ zipWith (\(i,fs) n -> (i,[(fs,n)])) slist is
 
---renderFoldable
+    zipWithM_ (uncurry drawShaderLay) slist is
---    :: Foldable f
+    
---    => RenderData
+    pokeEndTicks <- SDL.ticks
---    -> f RenderType
+    return $ pokeEndTicks - pokeStartTicks
---    -> IO Word32
---renderFoldable pdata struct = do
---    pokeStartTicks <- SDL.ticks
---
---    let slist = _pictureShaders pdata
---
----- poke data, returns list buffer sizes for each shader
---    is <- F.foldM (traverse pokeShader 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
----- before it performs another state change
---    bindShaderBuffers slist is
---
---    zipWithM_ drawShader slist is
---    
---    pokeEndTicks <- SDL.ticks
---    return $ pokeEndTicks - pokeStartTicks
 ------------------------------end renderFoldable
 
 pokeTwoOff 

src/Shader.hs

@@ -1,5 +1,6 @@
 module Shader
     ( bindShaderLayer
+    , bindShaderLay
     , bindShaderBuffers
     , bindArrayBuffers
     , drawShader
@@ -16,6 +17,7 @@ import Foreign
 import Control.Monad
 import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
 import Graphics.GL.Core43
+import qualified Data.IntMap.Strict as IM
 --import Text.RawString.QQ
 --import Linear.Matrix
 --import Linear.V4
@@ -42,6 +44,12 @@ bindArrayBuffersLayer numVs lay theVBO = do
   where
     stride = sum $ _vboAttribSizes theVBO
 
+bindShaderLay :: IM.IntMap [(VShader,Int)] -> IO ()
+bindShaderLay = mapM_ f . IM.toList
+  where
+    f (lay,ps) = mapM_ (g lay) ps 
+    g l (fs,i) = bindArrayBuffersLayer i l $ _vaoVBO $ _vshaderVAO fs
+
 bindShaderLayer :: [(Int,VShader)] -> [Int] -> IO ()
 bindShaderLayer = zipWithM_ f
   where 
@@ -52,6 +60,13 @@ bindShaderBuffers = zipWithM_ f
   where 
     f fs i = bindArrayBuffers i $ _vaoVBO $ _shaderVAO fs
 
+drawShaderLays :: IM.IntMap [(VShader,Int)] -> IO ()
+{-# INLINE drawShaderLays #-}
+drawShaderLays = mapM_ f . IM.toList
+  where
+    f (lay,ps) = mapM_ (g lay) ps
+    g lay (shad,i) = drawShaderLay lay shad i
+
 drawShaderLay :: Int -> VShader -> Int -> IO ()
 {-# INLINE drawShaderLay #-}
 drawShaderLay l fs i = do 

src/Shader/Poke.hs

@@ -1,15 +1,21 @@
+{-# LANGUAGE TupleSections #-}
 module Shader.Poke
     ( pokeArrayOff
     , pokeShader
     , pokeShaderLayer
+    , pokeVX
     ) where
 import Shader.Data
 import Shader.Parameters
 import Picture.Data
 
+import Data.Maybe
+import Data.List
 import Foreign
 import Control.Monad
 import qualified Control.Foldl as F
+import qualified Data.IntMap.Strict as IM
+import Control.Lens
 
 pokeShader :: FullShader -> F.FoldM IO RenderType Int
 pokeShader fs = F.FoldM (pokeVertices fls ptr stride)  (return 0) return
@@ -30,6 +36,25 @@ pokeVertices
     -> IO Int
 pokeVertices toFs ptr stride n rt = foldM (pokeVertex ptr stride) n (toFs rt)
 
+pokeSL :: [(Int,[VShader])] -> [Verx] -> IO (IM.IntMap [(VShader,Int)])
+pokeSL vslist vxs = do
+    foldM pokeVX (f vslist) vxs
+  where
+    f = IM.map (map (, 0)) . IM.fromList
+
+pokeVX :: IM.IntMap [(VShader,Int)] -> Verx -> IO (IM.IntMap [(VShader,Int)])
+pokeVX count vx = do
+    let offset = _vxLayer vx
+        lshads = count IM.! offset
+        (vshad,n) = fromJust $ find (\(s,_) -> _vshaderPokeTest s $ _vxType vx) lshads
+        i = fromJust $ findIndex (\(s,_) -> _vshaderPokeTest s $ _vxType vx) lshads
+        theVBO = _vaoVBO $ _vshaderVAO vshad
+        ptr = _vboPointer theVBO
+        stride = sum $ _vboAttribSizes theVBO
+    pokeArrayOff ptr (stride * (n+offset * numSubElements)) (toFls' vx)
+    return $ count & ix offset . ix i . _2 +~ 1
+
+
 pokeShaderLayer :: (Int,VShader) -> F.FoldM IO Verx Int
 pokeShaderLayer (l,fs) = F.FoldM (pokeVerticesOff ptr (_vshaderPokeTest fs) stride l)  (return 0) return
   where 
@@ -53,6 +78,15 @@ pokeVerticesOff ptr vtest stride offset n vx
     i = _vxLayer vx
     typetest = vtest (_vxType vx)
 
+toFls' :: Verx -> [Float]
+toFls' vx = flat3 (_vxPos vx) ++ flat4 (_vxCol vx) ++ f (_vxType vx)
+  where
+    f (PolyzV x) = [x]
+    f (BezV x) = flat4 x
+    f (TextV x) = flat2 x
+    f (ArcV x) = flat3 x
+    f _ = []
+
 toFls :: Verx -> [[Float]]
 toFls vx = [flat3 (_vxPos vx) ++ flat4 (_vxCol vx) ++ f (_vxType vx)]
   where