Reogranise drawing in main

app/Main.hs

@@ -85,15 +85,58 @@ doTheRender :: PreloadData a -> World -> IO (Word32)
 doTheRender preData w = do
     sTicks <- SDL.ticks
     clear [ColorBuffer,DepthBuffer]
-    renderPicture' (_renderData preData) 
+    let pdata   = _renderData preData
-        (_cameraRot w) (_cameraZoom w) 
+        rot     = _cameraRot w
-        (_cameraCenter w)
+        zoom    = _cameraZoom w
-        (_windowX w,_windowY w) 
+        trans@(tranx,trany) = _cameraCenter w
-        (wallsPointsAndCols w)
+        wins@(winx,winy)    = (_windowX w,_windowY w)
-        (wallsWindows w)
+        wallPointsCol   = wallsPointsAndCols w
-        (lightsForGloom' w)
+        windowPoints    = wallsWindows w
-        (_cameraViewFrom w)
+        lightPoints     = lightsForGloom' w
-        (worldPictures 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

src/Dodge/Creature/Inanimate.hs

@@ -5,6 +5,7 @@ import Dodge.Base
 import Dodge.Default
 import Dodge.CreatureState
 import Dodge.LightSources
+import Dodge.WorldEvent.Flash
 
 import Dodge.WorldEvent.Sound
 
@@ -34,7 +35,7 @@ updateLamp :: Int -> CRUpdate
 updateLamp i = unrandUpdate handleLS internalUpdate
   where
     handleLS cr w 
-        | _crHP cr < 0 = mkSoundBreakGlass w & lightSources %~ IM.delete i
+        | _crHP cr < 0 = explosionFlashAt (_crPos cr) $ mkSoundBreakGlass w & lightSources %~ IM.delete i
         | otherwise    = w & lightSources . ix i . lsPos .~ _crPos cr
     internalUpdate cr 
         | _crHP cr < 0 = Nothing

src/Dodge/WallCreatureCollisions.hs

@@ -40,18 +40,17 @@ wallBuffer = 3
 
 -- the following tests whether or not a point is on a wall, and if so pushes it
 -- out from the wall
--- If the resultant push out is itself on another wall, the original point is
+-- this is then repeated if the point ends up on a new wall
--- returned
 collideWalls :: Float -> Point2 -> [[Point2]] -> Point2 -> Point2
 collideWalls rad cp1 walls cp2
     = case (listToMaybe.mapMaybe (pushOutFromWall rad cp2)) walls of
             Nothing -> cp2
             Just cp3 -> case (listToMaybe.reverse.mapMaybe (pushOutFromWall rad cp3)) walls of
                                          Nothing -> cp3
-                                         Just cp4 -> cp1
+                                         Just cp4 -> cp4
 
 -- pushes a point out from a list of walls
--- if multiple new points occur, chooses the one closest to the orignal pointjk
+-- if multiple new points occur, chooses the one closest to the orignal point
 pushOutFromWalls :: Float -> [[Point2]] -> Point2 -> Point2
 pushOutFromWalls rad walls p = 
     fromMaybe p

src/Dodge/WorldEvent/Flash.hs

@@ -59,7 +59,7 @@ glareBetween t len wdth col a b w
 
 lowLightPic :: Float -> Float -> Color -> (Point2, Point2) -> World -> Picture
 lowLightPic len wdth col (a,b) w
-    = case thingsHitLongLine a b w of
+    = case thingsHit a b w of
         ((p, E3x2 wall):_) 
             -> setCol . lineOfThickness wdth $ [alongLineBy len p wa, alongLineBy len p wb]
                 where x = len *.* (normalizeV $ wa -.- wb)

src/Dodge/WorldEvent/ThingsHit.hs

@@ -17,6 +17,7 @@ thingsHit sp ep w
     where 
           hitCrs   = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr))
                                             $ _creatures w
+                                           -- $ creaturesAlongLine sp ep w
           crPs     = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
           crs   = zip crPs (map E3x1 hitCrs)
 

src/Geometry.hs

@@ -152,6 +152,7 @@ circOnLine' !p1 !p2 !c !rad = isJustTrue (fmap (\p -> magV (p -.- c) < rad) y)
 
 -- this should probably be circOnSeg
 circOnLine :: Point2 -> Point2 -> Point2 -> Float -> Bool
+{-# INLINE circOnLine #-}
 circOnLine !p1 !p2 !c !rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad
                              || isJustTrue (fmap (\p -> magV (p -.- c) < rad) y)
   where 

src/Picture/Render.hs

@@ -1,9 +1,9 @@
 --{-# LANGUAGE Strict #-}
 {-# LANGUAGE DeriveFoldable, StandaloneDeriving #-}
 module Picture.Render
-    ( renderPicture'
+    ( module Picture.Render
-    , renderFoldable
     , picToLTree
+    , perspectiveMatrix 
     )
     where
 
@@ -114,19 +114,27 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
                     (viewFromx,viewFromy) pmat = do
 
     bindFramebuffer Framebuffer $= (_spareFBO pdata)
-    clearColor $= Color4 0 0.5 0 1
+
-    depthFunc $= Just Less
+-- 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
 
-    nWalls <- F.foldM (pokeShader $ _wallShadowShader pdata) wallPoints
+-- draw walls from your point of view in order to set z buffer
-    bindShaderBuffers [_wallShadowShader pdata] [nWalls]
+    colorMask $= (Color4 Disabled Disabled Disabled Disabled)
 
     let (tx,ty) = (tranx,trany) -.- (viewFromx,viewFromy)
 
@@ -140,41 +148,44 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
     cullFace $= Just Back
     drawShader (_wallShadowShader pdata) nWalls
 
+-- for each of the lights: 
+-- stencil out the walls from this lights point of view
+-- draw fading lightmap circles on the floor
+-- draw fading lightmaps on the walls
     depthMask $= Disabled
     blendFunc $= (Zero, OneMinusSrcAlpha)
---    blendFuncSeparate    $= ((Zero,Zero),(Zero, OneMinusSrcAlpha))
     stencilTest $= Enabled
     forM_ lightPoints $ \(x,y,r,lum) -> do
---        depthFunc $= Just Less
-        colorMask $= (Color4 Disabled Disabled Disabled Disabled)
-        clear [StencilBuffer]
-        cullFace $= Just Back
---        stencilOp $= (OpKeep,OpKeep,OpReplace)
-        stencilOp $= (OpKeep,OpKeep,OpIncr)
-        stencilFunc $= (Always, 0, 255)
--- currentProgram does get called twice: here and inside drawShader below
-        currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata)
-        uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata)
-            $= Vector2 x y
---        blendFunc $= (Zero,One)
-        drawShader (_wallShadowShader pdata) nWalls
 
-        cullFace $= Just Front
+-- bind buffer for floor light circle
-        stencilOp $= (OpKeep,OpKeep,OpDecr)
-        drawShader (_wallShadowShader pdata) nWalls
-
-        cullFace $= Nothing
-        
-        colorMask $= (Color4 Enabled Enabled Enabled Enabled)
         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]
+        cullFace $= Just Back
+        stencilOp $= (OpKeep,OpKeep,OpIncr)
+        stencilFunc $= (Always, 0, 255)
+        currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata)
+        uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata)
+            $= Vector2 x y
+        drawShader (_wallShadowShader pdata) nWalls
+        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)
                 $= Vector2 x y  
@@ -204,8 +215,7 @@ renderBackground pdata rot zoom (tranx,trany) (winx,winy) = do
     depthFunc $= Just Less
 
 -- set drawing for on top
-    blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
+    --blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
-    clear [DepthBuffer]
 
 -- draw background
     bindArrayBuffers 1 $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata