Rendering optimisations (mainly inlining)

src/Dodge/Render.hs

@@ -49,7 +49,6 @@ doDrawing pdata w = do
         (wallPointsCol,windowPoints) = wallsAndWindows w
         lightPoints     = lightsForGloom w
         viewFroms = _cameraViewFrom w
-        pic = worldPictures w
     -- bind as much data into vbos as feasible at this point
     -- poke wall points and colors
     nWalls <- poke224s (shadVBOptr $ _wallTextureShader pdata) wallPointsCol
@@ -79,7 +78,7 @@ doDrawing pdata w = do
 
     _ <- renderFoldable pdata $ polysToPic $ foregroundPics w
 
-    vnums <- pokeBindFoldableLayer pdata pic
+    vnums <- pokeBindFoldableLayer pdata $ worldPictures w
     let shads = _pictureShaders pdata
     renderLayer 0 shads vnums
 

src/Dodge/Render/Picture.hs

@@ -21,9 +21,12 @@ import Data.List (partition)
 import qualified Data.IntMap.Lazy as IM
 
 worldPictures :: World -> Picture
-worldPictures w = 
+worldPictures w = concat $
-    concat (IM.elems $ _decorations w) ++ testPic w ++ concat
+    (IM.elems $ _decorations w) ++
-    [ concatMap (dbArg _pjDraw)  . IM.elems $ _projectiles w
+    (map (dbArg _pjDraw)  . IM.elems $ _projectiles w) ++
+    (map (crDraw w) . IM.elems $ _creatures w) ++
+    (map (dbArg _ptDraw) $ _particles w) ++
+    [ testPic w
     , concatMap drawItem . IM.elems $ _floorItems w
     , concatMap (crDraw w) . IM.elems $ _creatures w
     , concatMap clDraw   . reverse $ _clouds w

src/Dodge/WorldEvent/Explosion.hs

@@ -72,14 +72,14 @@ makeExplosionAt p w
     . explosionFlashAt p
     $ makeShockwaveAt [] p 50 10 1 white w
   where 
-    fVs  = replicateM 75 (randInCirc 1)  & evalState $ _randGen w
+    fVs  = replicateM 15 (randInCirc 1)  & evalState $ _randGen w
-    fPs'' = replicateM 75 (fmap (15 *.*.*) randInHemisphere) & evalState $ _randGen w
+    fPs'' = replicateM 15 (fmap (15 *.*.*) randInHemisphere) & evalState $ _randGen w
     (fPs',zs) = let (a,b,c) = unzip3 $ map fromV3 fPs''
                 in (zipWith V2 a b, c)
     fPs  = map (pushAgainstWalls . (+.+) p . (*.*) 0.5) fPs'
     inversePushOut v = (15 - magV v) * 0.01 *.* v
     fVs' = zipWith (+.+) fVs $ map inversePushOut fPs'
-    sizes = randomRs (2,6) $ _randGen w
+    sizes = randomRs (2,9) $ _randGen w
     times = randomRs (20,25) $ _randGen w
     mF q z v size time = makeFlameletTimed q z v Nothing size time
     newFs = zipWith5 mF fPs zs (fmap (3 *.*) fVs') sizes times

src/Picture.hs

@@ -63,7 +63,7 @@ import Picture.Data
 --import Data.Bifunctor
 --import qualified Data.DList as DL
 --import Graphics.Rendering.OpenGL (lineWidth, ($=))
-import Control.Lens
+--import Control.Lens
 
 blank :: Picture
 {-# INLINE blank #-}
@@ -160,17 +160,16 @@ translate3 :: Float -> Float -> Point3 -> Point3
 translate3 !a !b !(V3 x y z) = V3 (x+a) (y+b) z
 
 translate :: Float -> Float -> Picture -> Picture
---{-# INLINE translate #-}
+{-# INLINE translate #-}
---translate x y = map $ second $ overPos (translate3 x y)
 translate !x !y = map $! overPos $! translate3 x y
 
 setDepth :: Float -> Picture -> Picture
---{-# INLINE setDepth #-}
+{-# INLINE setDepth #-}
 --setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d))
 setDepth d = map $ overPos (\(V3 x y _) -> V3 x y d)
 
 addDepth :: Float -> Picture -> Picture
---{-# INLINE addDepth #-}
+{-# INLINE addDepth #-}
 --addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d))
 addDepth d = map $ overPos (\(V3 x y z) -> V3 x y (z+d))
 
@@ -185,12 +184,12 @@ scale3 :: Float -> Float -> Point3 -> Point3
 scale3 a b (V3 x y z) = (V3 (x*a) (y*b) (z))
 
 scale :: Float -> Float -> Picture -> Picture
---{-# INLINE scale #-}
+{-# INLINE scale #-}
 --scale x y = map . second . overPos $ scale3 x y
 scale x y = map $ overPos $ scale3 x y
 
 rotate :: Float -> Picture -> Picture
---{-# INLINE rotate #-}
+{-# INLINE rotate #-}
 rotate a = map $ overPos $ rotate3 a
 
 pictures :: [Picture] -> Picture
@@ -230,12 +229,10 @@ text s = map f $ stringToList s
 
 line :: [Point2] -> Picture
 {-# INLINE line #-}
---line = Line
 line = flip thickLine 1
 
 lineCol :: [(Point2,RGBA)] -> Picture
 {-# INLINE lineCol #-}
---lineCol = LineCol
 lineCol = flip thickLineCol 1
 
 thickLine :: [Point2] -> Float -> Picture
@@ -296,6 +293,7 @@ thickArc startA endA rad wdth
     w = 1 - wdth / r
 
 thickArcHelp :: Float -> Float -> Float -> Float -> [Verx]
+{-# INLINE thickArcHelp #-}
 thickArcHelp startA endA rad wdth = map f 
     [(  (V3 0 0 0),black,(V3 0 0 wdth))
     ,((V3 xa ya 0),black,(V3 1 0 wdth))
@@ -330,9 +328,23 @@ chartreuse= V4 0.5   1   0 1
 orange    = V4   1 0.5   0 1  
 white     = V4   1   1   1 1 
 black     = V4   0   0   0 1
-
+{-# INLINE red        #-}
+{-# INLINE green      #-}
+{-# INLINE blue       #-}
+{-# INLINE yellow     #-}
+{-# INLINE cyan       #-}
+{-# INLINE magenta    #-}
+{-# INLINE rose       #-}
+{-# INLINE violet     #-}
+{-# INLINE azure      #-}
+{-# INLINE aquamarine #-}
+{-# INLINE chartreuse #-}
+{-# INLINE orange     #-}
+{-# INLINE white      #-}
+{-# INLINE black      #-}
 
 mixColors :: Float -> Float -> Color -> Color -> Color
+{-# INLINE mixColors #-}
 mixColors rata ratb (V4 r0 g0 b0 a0) (V4 r2 g2 b2 a2) = 
     let fullrat = rata + ratb
         normrata = rata / fullrat
@@ -341,26 +353,33 @@ mixColors rata ratb (V4 r0 g0 b0 a0) (V4 r2 g2 b2 a2) =
     in  (V4 (f r0 r2 ) ( f g0 g2 ) ( f b0 b2 ) ( normrata * a0 + normratb * a2))
 
 light :: Color -> Color
+{-# INLINE light #-}
 light (V4 r g b a) = (V4 (r+0.2) (g+0.2) (b+0.2) (a))
 
 dark :: Color -> Color
+{-# INLINE dark #-}
 dark (V4 r g b a) = (V4 (r-0.2) (g-0.2) (b-0.2) (a))
         
 dim :: Color -> Color
+{-# INLINE dim #-}
 dim (V4 r g b a) = (V4 (r/1.2) (g/1.2) (b/1.2) (a))
 
 bright :: Color -> Color
+{-# INLINE bright #-}
 bright (V4 r g b a) = (V4 (r*1.2) (g*1.2) (b*1.2) (a))
 
 greyN :: Float -> Color
+{-# INLINE greyN #-}
 greyN x = toV4 (x,x,x,1)
 
 overPos :: (Point3 -> Point3) -> Verx -> Verx
 {-# INLINE overPos #-}
-overPos = over vxPos
+--overPos = over vxPos
+overPos f vx = vx {_vxPos = f (_vxPos vx)}
 
 overCol :: (Point4 -> Point4) -> Verx -> Verx
-overCol = over vxCol
+{-# INLINE overCol #-}
+overCol f vx = vx {_vxCol = f (_vxCol vx)}
 
 -- no premature optimisation, consider changing to use texture arrays
 stringToList :: String -> [(Point3,Point4,Point2)]

src/Render.hs

@@ -157,15 +157,21 @@ pokeBindFoldable pdata m = do
 zeroCounts :: PicShads Int
 zeroCounts = PicShads 0 0 0 0 0 0
 
-pokeBindFoldableLayer
+pokeVerxLayers
---    :: Foldable f
+    :: PicShads VBO
-    :: RenderData
     -> [Verx]
+    -> Layers (PicShads Int)
+    -> IO (Layers (PicShads Int))
+pokeVerxLayers = undefined
+
+pokeBindFoldableLayer
+    :: RenderData
+    -> Picture
     -> IO (Layers (PicShads Int))
 pokeBindFoldableLayer pdata m = do
     let shads = _pictureShaders pdata
 
-    slist'' <- pokeLayVerxs (fmap (_vaoVBO . _vshaderVAO) shads) m
+    slist'' <- pokeLayVerxsPart (fmap (_vaoVBO . _vshaderVAO) shads) m (pure $ pure 0)
     bindShaderLay shads slist''
 
     return slist''

src/Shader/Data.hs

@@ -37,6 +37,8 @@ module Shader.Data
 -- TODO make lenses for VBO object
 --    , textureObject 
     ) where
+--import Geometry.Data
+
 import Graphics.Rendering.OpenGL
 import Foreign
 import Control.Lens
@@ -139,6 +141,14 @@ data FullShader = FullShader
 {- | Datatype containing the reference to a texture object.  -}
 newtype ShaderTexture = ShaderTexture
     { _textureObject :: TextureObject }
+--data PicVerxs = PicVerxs
+--    { _pvPoly   :: (Point3,Point4)
+--    , _pvPolyz  :: (Point3,Point4,Float)
+--    , _pvBez    :: (Point3,Point4,Point4)
+--    , _pvText   :: (Point3,Point4,Point2)
+--    , _pvArc    :: (Point3,Point3,Point3)
+--    , _pvEll    :: (Point3,Point4)
+--    }
 
 data EPrimitiveMode
     = EPoints

src/Shader/Poke.hs

@@ -7,6 +7,8 @@ module Shader.Poke
     , pokePoint33s
     , pokeVerxs
     , pokeLayVerxs
+    , pokeLayVerxsPart
+    , pokeLayVerxsPartM
     , pokeLayVerxsM
     , poke224s
     ) where
@@ -22,7 +24,7 @@ import Foreign
 import Control.Monad
 --import qualified Control.Foldl as F
 --import qualified Data.IntMap.Strict as IM
-import Control.Lens
+--import Control.Lens
 
 pokeVerxs :: PicShads VBO -> [Verx] -> IO (PicShads Int)
 pokeVerxs vbos vxs0 = go vxs0 (pure 0)
@@ -32,7 +34,7 @@ pokeVerxs vbos vxs0 = go vxs0 (pure 0)
 
 -- this is very brittle, but want to optimise speed if possible here
 pokeVerx :: PicShads VBO -> PicShads Int -> Verx -> IO ()
---{-# INLINE pokeVerx #-}
+{-# INLINE pokeVerx #-}
 pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType} = case theType of
     PolyV -> poke34 (plusPtr (_vboPtr $ _psPoly vbos) (_psPoly offsets * 7 * floatSize)) thePos theCol
     PolyzV x        -> poke34 thePtr thePos theCol
@@ -124,6 +126,17 @@ pokeLayVerxsM !vbos = foldM f (pure $ pure 0)
   where
     f counts vx = pokeLayVerx vbos counts vx >> return (addLayCountVerx counts vx)
 
+pokeLayVerxsPartM :: PicShads VBO -> [Verx] -> Layers (PicShads Int) -> IO (Layers (PicShads Int))
+pokeLayVerxsPartM !vbos vxs0 count0 = foldM f count0 vxs0
+  where
+    f counts vx = pokeLayVerx vbos counts vx >> return (addLayCountVerx counts vx)
+
+pokeLayVerxsPart :: PicShads VBO -> [Verx] -> Layers (PicShads Int) -> IO (Layers (PicShads Int))
+pokeLayVerxsPart !vbos vxs0 count0 = go vxs0 count0
+  where
+    go [] count = return count
+    go (!vx:vxs) !count = pokeLayVerx vbos count vx >> (go vxs $! addLayCountVerx count vx)
+
 pokeLayVerxs :: PicShads VBO -> [Verx] -> IO (Layers (PicShads Int))
 pokeLayVerxs !vbos vxs0 = go vxs0 (pure (pure 0))
   where
@@ -132,7 +145,7 @@ pokeLayVerxs !vbos vxs0 = go vxs0 (pure (pure 0))
 
 -- this is very brittle, but want to optimise speed if possible here
 pokeLayVerx :: PicShads VBO -> Layers (PicShads Int) -> Verx -> IO ()
---{-# INLINE pokeLayVerx #-}
+{-# INLINE pokeLayVerx #-}
 pokeLayVerx vbos imoffsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType, _vxLayer = theLay} = case theType of
     PolyV -> poke34 (plusPtr (_vboPtr $ _psPoly vbos) ((_psPoly offsets + layOff) * 7 * floatSize)) thePos theCol
     PolyzV x        -> poke34 thePtr thePos theCol
@@ -164,13 +177,21 @@ pokeLayVerx vbos imoffsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType, _vx
 
 addLayCountVerx :: Layers (PicShads Int) -> Verx -> Layers (PicShads Int)
 --{-# INLINE addLayCountVerx #-}
-addLayCountVerx !m !vx = case _vxLayer vx of
+addLayCountVerx !m@Layers
-    0 -> m & lay0 %~ f
+    { _lay0 = a0
-    1 -> m & lay1 %~ f
+    , _lay1 = a1
-    2 -> m & lay2 %~ f
+    , _lay2 = a2
-    3 -> m & lay3 %~ f
+    , _lay3 = a3
-    4 -> m & lay4 %~ f
+    , _lay4 = a4
-    5 -> m & lay5 %~ f
+    , _lay5 = a5
+    }
+    !vx = case _vxLayer vx of
+    0 -> m { _lay0 = f a0 }
+    1 -> m { _lay1 = f a1 }
+    2 -> m { _lay2 = f a2 }
+    3 -> m { _lay3 = f a3 }
+    4 -> m { _lay4 = f a4 }
+    5 -> m { _lay5 = f a5 }
     _ -> undefined
   where
     f = flip addCountVerx vx