Reorganise rendering in Dodge

app/Main.hs

@@ -10,7 +10,7 @@ import Dodge.Layout
 import Dodge.LoadSound
 import Dodge.Update
 import Dodge.Event
-import Dodge.Rendering
+import Dodge.Render
 import Dodge.Menu
 import Dodge.Floor
 import Dodge.LoadConfig
@@ -53,7 +53,7 @@ main = do
         (fmap (setWindowSize sizex sizey keyConfig) firstWorld)
         ( \preData w -> do
             startTicks <- SDL.ticks
-            doTheRender preData w
+            doDrawing (_renderData preData) w
             playSoundQueue (_soundData preData) (_soundQueue w)
             newSoundData <- playAndUpdate (_sounds w) (_soundData preData)
 
@@ -81,63 +81,3 @@ setWindowSize :: Int -> Int -> KeyConfigSDL-> World -> World
 setWindowSize x y z w = w & windowX .~ fromIntegral x
                         & windowY .~ fromIntegral y
                         & keyConfig .~ z
-doTheRender :: PreloadData a -> World -> IO (Word32)
-doTheRender preData w = do
-    sTicks <- SDL.ticks
-    clear [ColorBuffer,DepthBuffer]
-    let pdata   = _renderData preData
-        rot     = _cameraRot w
-        zoom    = _cameraZoom w
-        trans@(tranx,trany) = _cameraCenter w
-        wins@(winx,winy)    = (_windowX w,_windowY w)
-        wallPointsCol   = wallsPointsAndCols w
-        windowPoints    = wallsWindows w
-        lightPoints     = lightsForGloom' w
-        viewFroms@(viewFromx,viewFromy) = _cameraViewFrom w
-        pic = worldPictures w
-    let wallPoints = map fst wallPointsCol
-
-    setCommonUniforms pdata rot zoom trans wins
-
-    depthFunc $= Just Less
-
-    pmat <- (newMatrix RowMajor 
-                $ perspectiveMatrix rot zoom (tranx,trany) (winx,winy) (viewFromx,viewFromy)
-            ) :: IO (GLmatrix GLfloat)
-
-    createLightMap pdata rot zoom trans wins wallPoints lightPoints viewFroms pmat
-
-    blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
-    clear [DepthBuffer]
-
-    renderBackground pdata rot zoom trans wins
-
-    renderWalls pdata wallPointsCol pmat
-
-    setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat
-
-    depthFunc $= Just Lequal
-
-    renderFoldable pdata $ picToLTree (Just 0) pic
-
--- reset blend so that light map doesn't apply
---    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-    blendFuncSeparate $= ((SrcAlpha,OneMinusSrcAlpha) , (Zero,One))
---    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-    renderFoldable pdata $ picToLTree (Just 1) pic
-
--- set drawing for on top
-    blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
-
-    renderFoldable pdata $ picToLTree (Just 2) pic
-
-    depthMask $= Disabled
-    renderWalls pdata windowPoints pmat
-    depthMask $= Enabled
-
-    resetShaderUniforms (map extractProgAndUnis $ _listShaders pdata)
-----------------------
-    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-    renderFoldable (_renderData preData) (picToLTree Nothing $ fixedCoordPictures w)
-    eTicks <- SDL.ticks
-    return (eTicks - sTicks)

package.yaml

@@ -79,3 +79,23 @@ tests:
     - -with-rtsopts=-N
     dependencies:
     - loop
+
+benchmarks:
+  loop-benchmarks:
+      dependencies:
+          - criterion
+      ghc-options:
+        - -threaded
+        - -O2
+        - -rtsopts
+        - -with-rtsopts=-N
+        - -flate-dmd-anal
+        - -fno-liberate-case 
+        - -fno-state-hack
+        - -funfolding-use-threshold1000 
+        - -funfolding-keeness-factor1000 
+        - -fllvm 
+        - -optlo-O3
+      main:         Bench.hs
+      source-dirs:  bench
+

src/Dodge/Base.hs

@@ -280,6 +280,12 @@ zoneOfLine :: Point2 -> Point2 -> [(Int,Int)]
 zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f 
                                  $ digitalLine (zoneOfPoint (aa,ab)) (zoneOfPoint (ba,bb))
     where f (x,y) = [(p,r) | p <-[x-1,x,x+1] , r<-[y-1,y,y+1]]
+
+zoneOfLine' :: Point2 -> Point2 -> IM.IntMap IS.IntSet
+{-# INLINE zoneOfLine' #-}
+zoneOfLine' a b = expandLine $ digitalLine (x-1,y-1) (x'-1,y'-1)
+    where (x,y) = zoneOfPoint a
+          (x',y') = zoneOfPoint b
 --zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f 
 --                                 $ digitalLine (zoneOfPoint (aa-n,ab-n)) (zoneOfPoint (ba-n,bb-n))
 --    where f (x,y) = [(p,r) | p <-[x,x+1] , r<-[y,y+1]]
@@ -294,11 +300,6 @@ expandLine xs = IM.map expandSet
           --expandSet s = s
                 where mk = IS.findMax s
 
-zoneOfLine' :: Point2 -> Point2 -> IM.IntMap IS.IntSet
-{-# INLINE zoneOfLine' #-}
-zoneOfLine' a b = expandLine $ digitalLine (x-1,y-1) (x'-1,y'-1)
-    where (x,y) = zoneOfPoint a
-          (x',y') = zoneOfPoint b
                         
 --zoneOfLine a b = concatMap zoneNearPoint $ divideLine (2 * zoneSize) a b
 --zoneOfLine a b = concatMap zoneNearPoint $ divideLine zoneSize a b

src/Dodge/Render.hs

@@ -0,0 +1,122 @@
+module Dodge.Render 
+    ( module Dodge.Render.Picture
+    , doDrawing
+    , doDrawing'
+    )
+  where
+import Dodge.Data
+import Dodge.Base
+
+import Dodge.Render.HUD
+import Dodge.Render.MenuScreen
+import Dodge.Render.Picture
+import Dodge.Render.PerspectiveMatrix
+
+import Geometry
+import Picture
+import Shader
+
+import Picture.Render
+import Picture.Preload
+
+import Data.Graph.Inductive.Query.DFS
+import Data.Graph.Inductive.Graph
+
+import Control.Monad.State
+import Data.List
+import Data.Bifunctor
+
+import Foreign (Word32)
+import Data.Function
+import Control.Applicative
+import Control.Lens
+import Data.Maybe
+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)
+
+import qualified SDL
+
+doDrawing :: RenderData -> World -> IO (Word32)
+doDrawing pdata w = do
+    sTicks <- SDL.ticks
+    clear [ColorBuffer,DepthBuffer]
+    let rot     = _cameraRot w
+        zoom    = _cameraZoom w
+        trans@(tranx,trany) = _cameraCenter w
+        wins@(winx,winy)    = (_windowX w,_windowY w)
+        wallPointsCol   = wallsPointsAndCols w
+        windowPoints    = wallsWindows w
+        lightPoints     = lightsForGloom' w
+        viewFroms@(viewFromx,viewFromy) = _cameraViewFrom w
+        pic = worldPictures w
+        wallPoints = map fst wallPointsCol
+    setCommonUniforms pdata rot zoom trans wins
+    depthFunc $= Just Less
+    pmat <- (newMatrix RowMajor $ perspectiveMatrix w) :: IO (GLmatrix GLfloat)
+    createLightMap pdata rot zoom trans wins wallPoints lightPoints viewFroms pmat
+    blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
+--    clear [DepthBuffer]
+    depthFunc $= Just Always
+    renderBackground pdata rot zoom trans wins
+    depthFunc $= Just Lequal
+    renderWalls pdata wallPointsCol pmat
+    setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat
+--    depthFunc $= Just Lequal
+    renderFoldable pdata $ picToLTree (Just 0) pic
+-- reset blend so that light map doesn't apply
+--    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
+    blendFuncSeparate $= ((SrcAlpha,OneMinusSrcAlpha) , (Zero,One))
+--    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
+    renderFoldable pdata $ picToLTree (Just 1) pic
+
+-- set drawing for on top
+    blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
+
+    renderFoldable pdata $ picToLTree (Just 2) pic
+
+    depthMask $= Disabled
+    renderWalls pdata windowPoints pmat
+    depthMask $= Enabled
+
+    resetShaderUniforms (map extractProgAndUnis $ _listShaders pdata)
+----------------------
+    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
+    renderFoldable pdata (picToLTree Nothing $ fixedCoordPictures w)
+    eTicks <- SDL.ticks
+    return (eTicks - sTicks)
+doDrawing' :: RenderData -> World -> IO (Word32)
+doDrawing' pdata w = do
+    bindFramebuffer Framebuffer $= defaultFramebufferObject
+    sTicks <- SDL.ticks
+    clear [ColorBuffer,DepthBuffer]
+    let rot     = _cameraRot w
+        zoom    = _cameraZoom w
+        trans@(tranx,trany) = _cameraCenter w
+        wins@(winx,winy)    = (_windowX w,_windowY w)
+        wallPointsCol   = wallsPointsAndCols w
+        windowPoints    = wallsWindows w
+        lightPoints     = lightsForGloom' w
+        viewFroms@(viewFromx,viewFromy) = _cameraViewFrom w
+        pic = worldPictures w
+        wallPoints = map fst wallPointsCol
+    pmat <- (newMatrix RowMajor 
+                $ perspectiveMatrix w) :: IO (GLmatrix GLfloat)
+    setCommonUniforms pdata rot zoom trans wins
+
+    depthMask $= Disabled
+    renderBackground pdata rot zoom trans wins
+    depthMask $= Enabled
+    blend $= Enabled
+    blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
+    -- not sure why renderWalls and setWallDepth aren't combined
+    renderWalls pdata wallPointsCol pmat
+    setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat
+    depthFunc $= Just Lequal
+    renderFoldable pdata $ picToLTree (Just 0) pic
+    renderFoldable pdata $ picToLTree (Just 1) pic
+    renderFoldable pdata $ picToLTree (Just 2) pic
+    eTicks <- SDL.ticks
+    return (eTicks - sTicks)
+

src/Dodge/Render/HUD.hs

@@ -1,4 +1,4 @@
-module Dodge.Rendering.HUD
+module Dodge.Render.HUD
     where
 
 import Dodge.Data

src/Dodge/Render/MenuScreen.hs

@@ -1,4 +1,4 @@
-module Dodge.Rendering.MenuScreen
+module Dodge.Render.MenuScreen
     ( menuScreen
     )
     where

src/Dodge/Render/PerspectiveMatrix.hs

@@ -0,0 +1,50 @@
+module Dodge.Render.PerspectiveMatrix
+    where
+import Dodge.Data
+
+import Geometry
+
+import Linear.Matrix
+import Linear.V4
+import Graphics.Rendering.OpenGL (GLfloat)
+
+perspectiveMatrix :: World -> [GLfloat]
+perspectiveMatrix w =
+    let rot     = _cameraRot w
+        zoom    = _cameraZoom w
+        (tranx,trany)   = _cameraCenter w
+        (winx,winy)     = (_windowX w,_windowY w)
+        (viewFromx,viewFromy)   = _cameraViewFrom w
+        scalMat = Linear.Matrix.transpose $ V4 
+            (V4 (2*zoom/winx) 0             0   (0::GLfloat))
+            (V4 0             (2*zoom/winy) 0   0)
+            (V4 0             0             0.5 0) --scaled to make walls shorter
+            (V4 0             0             0   1)
+        rotMat = Linear.Matrix.transpose $
+            V4 (V4 (cos rot) (sin (-rot)) 0 0)
+                (V4 (sin rot) (cos rot)    0 0)
+                (V4 0             0        1 0)
+                (V4 0             0        0 1)
+        tranMat3 = Linear.Matrix.transpose $
+            V4 (V4 1        0        0 0)
+                (V4 0        1        0 0)
+                (V4 0        0        1 0)
+                (V4 (-tranx) (-trany) 0 1)
+        tranMat2 = Linear.Matrix.transpose $
+            V4 (V4 1        0        0 0)
+                (V4 0        1        0 0)
+                (V4 0        0        1 0)
+                (V4 (viewFromx-tranx) (viewFromy-trany) 0 1)
+        perMat = Linear.Matrix.transpose $
+             V4 (V4 1 0 0 0)
+                (V4 0 1 0 0)
+                (V4 0 0 1 1)
+                (V4 0 0 0 1)
+        tranMat1 = Linear.Matrix.transpose $
+             V4 (V4 1        0        0 0)
+                (V4 0        1        0 0)
+                (V4 0        0        1 0)
+                (V4 (-viewFromx) (-viewFromy) 0 1)
+        wmat = scalMat !*! rotMat !*! tranMat2 !*! perMat !*! tranMat1
+        vToL (V4 a b c d) = [a,b,c,d]
+    in concatMap vToL $ vToL wmat

src/Dodge/Render/Picture.hs

@@ -1,29 +1,17 @@
-module Dodge.Rendering where
+module Dodge.Render.Picture
--- imports {{{
+  where
 import Dodge.Data
 import Dodge.Base
---import Dodge.Inventory
 
-import Dodge.Rendering.HUD
+import Dodge.Render.HUD
-import Dodge.Rendering.MenuScreen
+import Dodge.Render.MenuScreen
 
 import Geometry
 import Picture
 
-import Data.Graph.Inductive.Query.DFS
-import Data.Graph.Inductive.Graph
-
-import Control.Monad.State
-import Data.List
-import Data.Bifunctor
-
-import Data.Function
-import Control.Applicative
 import Control.Lens
 import Data.Maybe
 import qualified Data.IntMap.Strict as IM
-import qualified Data.Map as M
-import qualified Data.Set as S
 
 worldPictures :: World -> Picture
 worldPictures w = pictures $ concat 

src/Dodge/Update.hs

@@ -71,8 +71,11 @@ updateLightSources w = set tempLightSources (catMaybes tlss) w'
 updateProjectiles w = IM.foldr' _pjUpdate w $ _projectiles w
 
 updateParticles' :: World -> World
-updateParticles' w = set particles' (catMaybes ps) w'
+updateParticles' w = 
-    where (w',ps) = mapAccumR (\a b -> _ptUpdate' b a b) w $ _particles' w
+    --set particles' [] w
+    set particles' (catMaybes ps) w'
+  where 
+    (w',ps) = mapAccumR (\a b -> _ptUpdate' b a b) w $ _particles' w
 
 updateCreatures :: World -> World
 updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w

src/Dodge/WorldEvent/SpawnParticle.hs

@@ -167,6 +167,7 @@ moveFlamelet w pt
                      & btPassThrough' .~ Nothing
                      & btVel'         .~ 0.8 *.* vel
     damcrs = foldr ($) w $ map dodam $ filter closeCrs $ IM.elems $ _creatures w
+--    damcrs = w
     closeCrs cr = dist ep (_crPos cr) < _crRad cr + size
     dodam cr = over (creatures . ix (_crID cr) . crState . crDamage)
                     ((:) $ Flaming 3 sp ep ep)

src/MatrixHelper.hs

@@ -11,7 +11,7 @@ perspectiveMatrix rot zoom (tranx,trany) (winx,winy) (viewFromx,viewFromy) =
     let scalMat = Linear.Matrix.transpose $ V4 
             (V4 (2*zoom/winx) 0             0   (0::GLfloat))
             (V4 0             (2*zoom/winy) 0   0)
-            (V4 0             0             0.5 0) --scale to make walls shorter
+            (V4 0             0             0.5 0) --scaled to make walls shorter
             (V4 0             0             0   1)
         rotMat = Linear.Matrix.transpose $
             V4 (V4 (cos rot) (sin (-rot)) 0 0)

src/Picture/Render.hs

@@ -3,7 +3,7 @@
 module Picture.Render
     ( module Picture.Render
     , picToLTree
-    , perspectiveMatrix 
+--    , perspectiveMatrix 
     )
     where
 
@@ -114,30 +114,23 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
                     (viewFromx,viewFromy) pmat = do
 
     bindFramebuffer Framebuffer $= (_spareFBO pdata)
-
 -- clear buffer to full alpha and furthest depth
     clearColor $= Color4 0 0 0 1
     clearDepth $= 1
     clear [ColorBuffer,DepthBuffer]
-
     depthFunc $= Just Less
-
 -- store wall and light positions into buffer
     nWallLights <- F.foldM (pokeShader $ _wallLightShader pdata) wallPoints
     bindShaderBuffers [_wallLightShader pdata] [nWallLights]
     nWalls <- F.foldM (pokeShader $ _wallShadowShader pdata) wallPoints
     bindShaderBuffers [_wallShadowShader pdata] [nWalls]
-
 -- set uniforms for shader that draws lights
     currentProgram $= Just (_shaderProgram $ _wallLightShader pdata)
     uniform ( (fromJust $ _shaderCustomUnis $ _wallLightShader pdata) !! 1)
             $= pmat
-
 -- draw walls from your point of view in order to set z buffer
     colorMask $= (Color4 Disabled Disabled Disabled Disabled)
-
     let (tx,ty) = (tranx,trany) -.- (viewFromx,viewFromy)
-
     currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata)
     uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata)
             $= Vector2 viewFromx viewFromy  
@@ -147,23 +140,20 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
             $= (0 :: Float)
     cullFace $= Just Back
     drawShader (_wallShadowShader pdata) nWalls
-
 -- for each of the lights: 
--- stencil out the walls from this lights point of view
+-- stencil out the walls from this light's point of view
 -- draw fading lightmap circles on the floor
 -- draw fading lightmaps on the walls
     depthMask $= Disabled
     blendFunc $= (Zero, OneMinusSrcAlpha)
     stencilTest $= Enabled
     forM_ lightPoints $ \(x,y,r,lum) -> do
-
 -- bind buffer for floor light circle
         let lightPtr = (\(_,ptr,_) -> ptr) $ head 
                             $ _vaoBufferTargets $ _shaderVAO $ _lightSourceShader pdata
             (x',y') = zTran $ rotateV (0 - rot) $ (x,y) -.- (tranx,trany)
             zTran (a,b) = (a*2*zoom / winx, b*2*zoom / winy)
         pokeFourOff lightPtr 0 (x',y',r,lum)
-
 -- stencil out walls
         colorMask $= (Color4 Disabled Disabled Disabled Disabled)
         clear [StencilBuffer]
@@ -177,14 +167,12 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
         cullFace $= Just Front
         stencilOp $= (OpKeep,OpKeep,OpDecr)
         drawShader (_wallShadowShader pdata) nWalls
-
 -- draw floor light circles
         cullFace $= Nothing
         colorMask $= (Color4 Disabled Disabled Disabled Enabled)
         bindShaderBuffers [_lightSourceShader pdata] [1]
         stencilFunc $= (Equal, 0, 255)
         drawShader (_lightSourceShader pdata) 1
-
 -- draw wall light "circles"
         currentProgram $= Just (_shaderProgram $ _wallLightShader pdata)
         uniform (head $ fromJust $ _shaderCustomUnis $ _wallLightShader pdata)
@@ -192,34 +180,25 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
         uniform ( (fromJust $ _shaderCustomUnis $ _wallLightShader pdata) !! 2)
                 $= Vector2 r lum
         drawShader (_wallLightShader pdata) nWallLights
-        
     depthMask $= Enabled
     cullFace $= Nothing
     stencilTest $= Disabled
-
     blend $= Disabled
-
     bindFramebuffer Framebuffer $= defaultFramebufferObject
-
     colorMask $= (Color4 Disabled Disabled Disabled Enabled)
     bindShaderBuffers [_fullscreenShader pdata] [4]
     textureBinding Texture2D $= Just (_fboTexture pdata)
     drawShader (_fullscreenShader pdata) 4
-
     colorMask $= (Color4 Enabled Enabled Enabled Enabled)
-
     blend $= Enabled
 
 renderBackground :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> IO ()
 renderBackground pdata rot zoom (tranx,trany) (winx,winy) = do
-    depthFunc $= Just Less
+--    depthFunc $= Just Less
-
 -- set drawing for on top
     --blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
-
 -- draw background
     bindArrayBuffers 1 $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata
-
     currentProgram $= Just (_shaderProgram $ _backgroundShader pdata)
     bindVertexArrayObject $= Just (_vao $ _shaderVAO $ _backgroundShader pdata)
     let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata