Add picture shader container datatype

src/Data/Preload/Render.hs

@@ -21,7 +21,7 @@ data RenderData = RenderData
     , _colorBlurShader          :: FullShader
     , _barrelShader             :: FullShader
     , _grayscaleShader          :: FullShader
-    , _pictureShaders           :: [VShader]
+    , _pictureShaders           :: PicShads VShader
     , _fbo2                     :: (FramebufferObject, TextureObject)
     , _fbo3                     :: (FramebufferObject, TextureObject)
     , _fboFourth1 :: (FramebufferObject, TextureObject)

src/Dodge/Render.hs

@@ -77,32 +77,30 @@ doDrawing pdata w = do
     if w ^. config . wall_textured
         then renderTextureWalls pdata nWalls
         else renderBlankWalls pdata nWalls
-    --_ <- renderFoldable pdata $ (picToAlt (Just 0) (polysToPic $ foregroundPics w) :: [RenderType])
-    --_ <- renderFoldable pdata $ (picToAlt (Just 0) pic :: [RenderType])
---FIXME    _ <- renderFoldable pdata $ polysToPic $ foregroundPics w
-    vfore <- pokeBindFoldableLayer pdata $  polysToPic $ foregroundPics w
-    mapM_ (uncurry $ drawShaderLay 0) (vfore IM.! 0)
 
-    --_ <- renderFoldable pdata $ map snd $ filter ((==0).fst) pic
+    _ <- renderFoldable pdata $ polysToPic $ foregroundPics w
+
     vnums <- pokeBindFoldableLayer pdata $ pic
-    mapM_ (uncurry $ drawShaderLay 0) (vnums IM.! 0)
+    let shads = _pictureShaders pdata
+    --mapM_ (uncurry $ drawShaderLay 0) ((,) <$> shads <*> count)
+    renderLayer 0 shads vnums
 
     _ <- renderShader (_textureArrayShader pdata) (_floorTiles w)
 
     bindFramebuffer Framebuffer $= fst (_fboBloom pdata)
     clear [ColorBuffer]
     blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-    --_ <- renderFoldable pdata $ map snd $ filter ((==1).fst) pic
+    --mapM_ (uncurry $ drawShaderLay 1) (vnums IM.! 1)
-    mapM_ (uncurry $ drawShaderLay 1) (vnums IM.! 1)
+    renderLayer 1 shads vnums
     bindFramebuffer Framebuffer $= fst (_fboColor pdata)
     clear [ColorBuffer]
     depthMask $= Disabled
-    mapM_ (uncurry $ drawShaderLay 3) (vnums IM.! 3)
+    --mapM_ (uncurry $ drawShaderLay 3) (vnums IM.! 3)
-    mapM_ (uncurry $ drawShaderLay 4) (vnums IM.! 4)
+    --mapM_ (uncurry $ drawShaderLay 4) (vnums IM.! 4)
-    mapM_ (uncurry $ drawShaderLay 5) (vnums IM.! 5)
+    --mapM_ (uncurry $ drawShaderLay 5) (vnums IM.! 5)
-    --_ <- renderFoldable pdata $ map snd $ filter ((==3).fst) pic
+    renderLayer 3 shads vnums
-    --_ <- renderFoldable pdata $ map snd $ filter ((==4).fst) pic
+    renderLayer 4 shads vnums
-    --_ <- renderFoldable pdata $ map snd $ filter ((==5).fst) pic
+    renderLayer 5 shads vnums
 
     depthMask $= Enabled
     bindFramebuffer Framebuffer $= fst (_fboFourth1 pdata)
@@ -145,8 +143,8 @@ doDrawing pdata w = do
     drawShader (_fullscreenShader pdata) 4
 
     depthFunc $= Just Lequal
-    --_ <- renderFoldable pdata $ map snd $ filter ((==2).fst) pic
+    --mapM_ (uncurry $ drawShaderLay 2) (vnums IM.! 2)
-    mapM_ (uncurry $ drawShaderLay 2) (vnums IM.! 2)
+    renderLayer 2 shads vnums
     renderWindows pdata windowPoints
 
     depthFunc $= Just Always
@@ -178,9 +176,7 @@ doDrawing pdata w = do
     blend $= Enabled
     blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
 
-    vovers <- pokeBindFoldableLayer pdata $ fixedCoordPictures w
+    _ <- renderFoldable pdata $ fixedCoordPictures w
-    mapM_ (uncurry $ drawShaderLay 0) (vovers IM.! 0)
---FIXME    _ <- renderFoldable pdata $ fixedCoordPictures w
     depthMask $= Enabled
 
     eTicks <- SDL.ticks

src/Picture.hs

@@ -55,8 +55,8 @@ import Geometry.Vector3D
 import Geometry.Data
 import Picture.Data
 
-import Data.List
+--import Data.List
-import Data.Bifunctor
+--import Data.Bifunctor
 --import qualified Data.DList as DL
 --import Graphics.Rendering.OpenGL (lineWidth, ($=))
 import Control.Lens
@@ -64,8 +64,8 @@ import Control.Lens
 black :: RGBA
 black = (0,0,0,1)
 
-zl :: RenderType -> [(Int,RenderType)]
+--zl :: RenderType -> [(Int,RenderType)]
-zl rt = [(0,rt)]
+--zl rt = [(0,rt)]
 
 polygon :: [Point2] -> Picture
 {-# INLINE polygon #-}
@@ -175,7 +175,7 @@ addDepth d = map $ overPos (\(x,y,z) -> (x,y,z+d))
 
 setLayer :: Int -> Picture -> Picture
 {-# INLINE setLayer #-}
-setLayer i = map $ f
+setLayer i = map f
   where
     f v = v {_vxLayer = i}
 

src/Preload/Render.hs

@@ -38,7 +38,7 @@ preloadRender = do
         , nullPtr
         , DynamicDraw
         )
-    let wpVBO = VBO {_vbo = wpVBOname, _vboPointer = wpVBOptr, _vboAttribSizes = [4,4]}
+    let wpVBO = VBO {_vbo = wpVBOname, _vboPointer = wpVBOptr, _vboAttribSizes = [4,4], _vboStride = 8}
     wpVAOname <- genObjectName
     bindVertexArrayObject $= Just wpVAOname
     bindBuffer ArrayBuffer $= Just wpVBOname
@@ -119,8 +119,14 @@ preloadRender = do
     clearColor $= Color4 0 0 0 1
 
     return $ RenderData
-        { _pictureShaders           = 
+        { _pictureShaders           = PicShads
-            [bslist,cslist,aslist,eslist,bezierQuadShader,basicTweakZShad]
+            { _psPoly = bslist 
+            , _psText = cslist 
+            , _psArc = aslist
+            , _psEll = eslist
+            , _psBez = bezierQuadShader
+            , _psPolyz = basicTweakZShad
+            }
         , _lightingSurfaceShader    = lightingSurfaceShad
         , _lightingLineShadowShader = lightingLineShadowShad
         , _lightingOccludeShader    = wsShad        {_shaderVAO = wpVAO}
@@ -238,6 +244,7 @@ poke33 :: RenderType -> [[Float]]
 poke33 Render3x3{_unRender3x3=((x,y,z),(a,b,c))} = [[x,y,z,a,b,c]]
 poke33 _ = undefined
 
+isPolyV, isArcV, isEllV, isTextV, isBezV, isPolyzV :: VertexType -> Bool
 isPolyV PolyV = True
 isPolyV _ = False
 isArcV (ArcV _) = True

src/Render.hs

@@ -153,20 +153,33 @@ renderShader shad dat = do
     eticks <- SDL.ticks
     return $ eticks - sticks
 
+pokeBindFoldable
+    :: Foldable f
+    => RenderData
+    -> f Verx
+    -> IO (PicShads Int)
+pokeBindFoldable pdata m = do
+    let shads = _pictureShaders pdata
+        counts = zeroCounts
+    elist <- foldM (pokeVX' shads) counts m
+    bindShader shads elist
+    return elist
+
+zeroCounts :: PicShads Int
+zeroCounts = PicShads 0 0 0 0 0 0
+
 pokeBindFoldableLayer
     :: Foldable f
     => RenderData
     -> f Verx
-    -> IO (IM.IntMap [(VShader,Int)])
+    -> IO (IM.IntMap (PicShads Int))
 pokeBindFoldableLayer pdata m = do
-    let slist = (,) <$> [0..6] <*> _pictureShaders pdata
+    let shads = _pictureShaders pdata
-        slist' = IM.fromListWith (++) ((,) <$> [0..6] <*> map ((:[]) . (, 0)) (_pictureShaders pdata))
+        slist' = (IM.fromList ((,) <$> [0..6] <*> [zeroCounts])) :: IM.IntMap (PicShads Int)
+
+    slist'' <- foldM (pokeVX shads) slist' m
+    bindShaderLay shads slist''
 
---    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
@@ -177,22 +190,19 @@ renderFoldable
 renderFoldable pdata struct = do
     pokeStartTicks <- SDL.ticks
 
-    let slist = (,) <$> [0..6] <*> _pictureShaders pdata
+    count <- pokeBindFoldable pdata struct
+    let shads = _pictureShaders pdata
 
--- poke data, returns list buffer sizes for each shader
+    mapM_ (uncurry (drawShaderLay 0)) ((,) <$> shads <*> count)
-    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
-
-    zipWithM_ (uncurry drawShaderLay) slist is
     
     pokeEndTicks <- SDL.ticks
     return $ pokeEndTicks - pokeStartTicks
 ------------------------------end renderFoldable
 
+renderLayer :: Int -> PicShads VShader -> IM.IntMap (PicShads Int) -> IO ()
+renderLayer i shads counts = 
+    mapM_ (uncurry $ drawShaderLay i) ((,) <$> shads <*> counts IM.! i)
+
 pokeTwoOff 
     :: Ptr Float 
     -> Int 

src/Shader.hs

@@ -2,6 +2,7 @@ module Shader
     ( bindShaderLayer
     , bindShaderLay
     , bindShaderBuffers
+    , bindShader
     , bindArrayBuffers
     , drawShader
     , freeShaderPointers
@@ -18,6 +19,7 @@ import Control.Monad
 import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
 import Graphics.GL.Core43
 import qualified Data.IntMap.Strict as IM
+import Data.Bifunctor
 --import Text.RawString.QQ
 --import Linear.Matrix
 --import Linear.V4
@@ -32,6 +34,18 @@ bindArrayBuffers numVs theVBO = do
         (fromIntegral $ floatSize * numVs * sum (_vboAttribSizes theVBO)) 
         (_vboPointer theVBO)
 
+bindArrayBuffersLayer' :: Int -> Int -> VBO -> IO ()
+bindArrayBuffersLayer' lay numVs theVBO = do
+    bindBuffer ArrayBuffer $= Just (_vbo theVBO)
+    bufferSubData 
+        ArrayBuffer 
+        WriteToBuffer 
+        (fromIntegral $ floatSize * stride * numSubElements * lay)
+        (fromIntegral $ floatSize * numVs * stride)
+        (_vboPointer theVBO `plusPtr` (floatSize * stride * numSubElements * lay))
+  where
+    stride = sum $ _vboAttribSizes theVBO
+
 bindArrayBuffersLayer :: Int -> Int -> VBO -> IO ()
 bindArrayBuffersLayer numVs lay theVBO = do
     bindBuffer ArrayBuffer $= Just (_vbo theVBO)
@@ -44,11 +58,14 @@ bindArrayBuffersLayer numVs lay theVBO = do
   where
     stride = sum $ _vboAttribSizes theVBO
 
-bindShaderLay :: IM.IntMap [(VShader,Int)] -> IO ()
+bindShaderLay :: PicShads VShader -> IM.IntMap (PicShads Int) -> IO ()
-bindShaderLay = mapM_ f . IM.toList
+bindShaderLay shads = mapM_ f . IM.toList
   where
-    f (lay,ps) = mapM_ (g lay) ps 
+    f (lay,counts) = sequence_ $ bindArrayBuffersLayer' lay <$> counts <*> (_vaoVBO . _vshaderVAO <$> shads)
-    g l (fs,i) = bindArrayBuffersLayer i l $ _vaoVBO $ _vshaderVAO fs
+
+bindShader :: PicShads VShader -> PicShads Int -> IO ()
+bindShader shads counts = sequence_ $ bindArrayBuffers <$> counts <*> (_vaoVBO . _vshaderVAO <$> shads)
+--bindShader = mapM_ (uncurry (flip bindArrayBuffers) . first (_vaoVBO . _vshaderVAO))
 
 bindShaderLayer :: [(Int,VShader)] -> [Int] -> IO ()
 bindShaderLayer = zipWithM_ f
@@ -60,13 +77,6 @@ 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/Compile.hs

@@ -151,6 +151,7 @@ setupVBO sizes = do
         { _vbo = vboName
         , _vboPointer = thePtr
         , _vboAttribSizes = sizes
+        , _vboStride = sum sizes
         }
   where
     strd = sum sizes
@@ -173,6 +174,7 @@ setupVBOSized sizes ndraw = do
         { _vbo = vboName
         , _vboPointer = thePtr
         , _vboAttribSizes = sizes
+        , _vboStride = sum sizes
         }
   where
     strd = sum sizes

src/Shader/Data.hs

@@ -9,6 +9,7 @@ module Shader.Data
     , VShader (..)
     , ShaderTexture (..)
     , EPrimitiveMode (..)
+    , PicShads (..)
 -- | Lens functions
     , vao
     , vaoVBO
@@ -27,6 +28,14 @@ module Shader.Data
     , vshaderCustomUnis
     , vshaderPokeTest
 
+    , psPoly 
+    , psPolyz
+    , psBez  
+    , psText 
+    , psArc  
+    , psEll  
+
+-- TODO make lenses for VBO object
 --    , textureObject 
     ) where
 import Picture.Data
@@ -49,6 +58,7 @@ data VBO = VBO
     { _vbo      :: BufferObject
     , _vboPointer :: Ptr Float
     , _vboAttribSizes :: [Int]  -- ^ It is not clear to me if this is necessary to store or not
+    , _vboStride :: Int
     }
 data VShader = VShader
     { _vshaderProgram :: Program
@@ -58,6 +68,69 @@ data VShader = VShader
     , _vshaderCustomUnis :: [UniformLocation]
     , _vshaderPokeTest :: VertexType -> Bool
     }
+data PicShads a = PicShads
+    { _psPoly   :: a
+    , _psPolyz  :: a
+    , _psBez    :: a
+    , _psText   :: a
+    , _psArc    :: a
+    , _psEll    :: a
+    }
+-- boilerplate folows
+instance Functor PicShads where
+    fmap f PicShads
+        { _psPoly  = thePoly 
+        , _psPolyz = thePolyz
+        , _psBez   = theBez  
+        , _psText  = theText 
+        , _psArc   = theArc  
+        , _psEll   = theEll  
+        }
+        = PicShads
+        { _psPoly  = f thePoly 
+        , _psPolyz = f thePolyz
+        , _psBez   = f theBez  
+        , _psText  = f theText 
+        , _psArc   = f theArc  
+        , _psEll   = f theEll  
+        }
+instance Applicative PicShads where
+    pure a = PicShads a a a a a a
+    (<*>) PicShads
+        { _psPoly  = fPoly 
+        , _psPolyz = fPolyz
+        , _psBez   = fBez  
+        , _psText  = fText 
+        , _psArc   = fArc  
+        , _psEll   = fEll  
+        }
+        PicShads
+        { _psPoly  = thePoly 
+        , _psPolyz = thePolyz
+        , _psBez   = theBez  
+        , _psText  = theText 
+        , _psArc   = theArc  
+        , _psEll   = theEll  
+        }
+        = PicShads
+        { _psPoly  = fPoly  thePoly 
+        , _psPolyz = fPolyz thePolyz
+        , _psBez   = fBez   theBez  
+        , _psText  = fText  theText 
+        , _psArc   = fArc   theArc  
+        , _psEll   = fEll   theEll  
+        }
+instance Foldable PicShads where
+    foldr f x PicShads
+        { _psPoly  = thePoly 
+        , _psPolyz = thePolyz
+        , _psBez   = theBez  
+        , _psText  = theText 
+        , _psArc   = theArc  
+        , _psEll   = theEll  
+        }
+        = f thePoly . f thePolyz . f theBez . f theText . f theArc $ f theEll x
+
 
 {- | Datatype containing the necessary information for a single shader.  -}
 data FullShader = FullShader
@@ -89,3 +162,4 @@ data EPrimitiveMode
 makeLenses ''VAO
 makeLenses ''FullShader
 makeLenses ''VShader
+makeLenses ''PicShads

src/Shader/Poke.hs

@@ -1,9 +1,10 @@
-{-# LANGUAGE TupleSections #-}
+--{-# LANGUAGE TupleSections #-}
 module Shader.Poke
     ( pokeArrayOff
     , pokeShader
     , pokeShaderLayer
     , pokeVX
+    , pokeVX'
     ) where
 import Shader.Data
 import Shader.Parameters
@@ -22,11 +23,9 @@ pokeShader fs = F.FoldM (pokeVertices fls ptr stride)  (return 0) return
   where 
     theVBO = _vaoVBO $ _shaderVAO fs
     ptr = _vboPointer theVBO
-    stride = sum $ _vboAttribSizes theVBO
+    stride = _vboStride theVBO
     fls = _shaderPokeStrategy fs
 
-
-
 pokeVertices 
     :: (RenderType -> [[Float]])
     -> Ptr Float
@@ -36,23 +35,47 @@ 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)])
+getterPicShad :: VertexType -> Getting a (PicShads a) a
-pokeSL vslist vxs = do
+getterPicShad PolyV    = psPoly
-    foldM pokeVX (f vslist) vxs
+getterPicShad PolyzV{} = psPolyz
-  where
+getterPicShad BezV{}   = psBez
-    f = IM.map (map (, 0)) . IM.fromList
+getterPicShad TextV{}  = psText
+getterPicShad ArcV{}   = psArc
+getterPicShad EllV     = psEll
 
-pokeVX :: IM.IntMap [(VShader,Int)] -> Verx -> IO (IM.IntMap [(VShader,Int)])
+--setterPicShad :: VertexType -> ASetter 
-pokeVX count vx = do
+setterPicShad PolyV    = psPoly
-    let offset = _vxLayer vx
+setterPicShad PolyzV{} = psPolyz
-        lshads = count IM.! offset
+setterPicShad BezV{}   = psBez
-        (vshad,n) = fromJust $ find (\(s,_) -> _vshaderPokeTest s $ _vxType vx) lshads
+setterPicShad TextV{}  = psText
-        i = fromJust $ findIndex (\(s,_) -> _vshaderPokeTest s $ _vxType vx) lshads
+setterPicShad ArcV{}   = psArc
+setterPicShad EllV     = psEll
+
+pokeVX' :: PicShads VShader -> PicShads Int -> Verx -> IO (PicShads Int)
+pokeVX' shads count vx = do
+    let f = setterPicShad (_vxType vx)
+        g = getterPicShad (_vxType vx)
+        vshad = shads ^. g
+        n = count ^. g
         theVBO = _vaoVBO $ _vshaderVAO vshad
         ptr = _vboPointer theVBO
-        stride = sum $ _vboAttribSizes theVBO
+        stride = _vboStride theVBO
+    pokeArrayOff ptr (stride * n) (toFls' vx)
+    return $ count & f +~ 1
+
+pokeVX :: PicShads VShader -> IM.IntMap (PicShads Int) -> Verx -> IO (IM.IntMap (PicShads Int))
+pokeVX shads laycounts vx = do
+    let theType = _vxType vx
+        offset = _vxLayer vx
+        counts = laycounts IM.! offset
+        getF = getterPicShad theType
+        vshad = shads ^. getF
+        n = counts ^. getF
+        theVBO = _vaoVBO $ _vshaderVAO vshad
+        ptr = _vboPointer theVBO
+        stride = _vboStride theVBO
     pokeArrayOff ptr (stride * (n+offset * numSubElements)) (toFls' vx)
-    return $ count & ix offset . ix i . _2 +~ 1
+    return $ laycounts & ix offset . setterPicShad theType +~ 1
 
 
 pokeShaderLayer :: (Int,VShader) -> F.FoldM IO Verx Int
@@ -60,7 +83,7 @@ pokeShaderLayer (l,fs) = F.FoldM (pokeVerticesOff ptr (_vshaderPokeTest fs) stri
   where 
     theVBO = _vaoVBO $ _vshaderVAO fs
     ptr = _vboPointer theVBO
-    stride = sum $ _vboAttribSizes theVBO
+    stride = _vboStride theVBO
 
 pokeVerticesOff
     :: Ptr Float
@@ -108,5 +131,6 @@ pokeVertex ptr stride n fs = do
     return $ n + 1
 
 pokeArrayOff :: Storable a => Ptr a -> Int -> [a] -> IO ()
-{-# INLINE pokeArrayOff #-}
+--{-# INLINE pokeArrayOff #-}
-pokeArrayOff ptr i = zipWithM_ (pokeElemOff ptr) [i..]
+--pokeArrayOff ptr i = zipWithM_ (pokeElemOff ptr) [i..]
+pokeArrayOff ptr i = pokeArray (plusPtr ptr (floatSize * i))