Hack wall depth, objects don't appear on top of walls (nor beneath windows)

src/Dodge/Floor.hs

@@ -32,6 +32,7 @@ lev1 = do
             (
             [return $ return $ Right deadEndRoom
             ]
+              ++[roomMiniIntro]
             ++ [longRoom >>= randomiseLinks]
             ++ [return $ connectRoom corridor
                ,return $ connectRoom door]

src/Dodge/LevelGen/AutoDoor.hs

@@ -28,13 +28,6 @@ mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane [pl,pr])
                                xs
                                (lDoorClosed ++ rDoorClosed)
                                (map shiftL lDoorClosed ++ map shiftR rDoorClosed)
-                     --          [ [plld,pld]
-                     --          , [pld,plu]
-                     --          , [plu,pllu]
-                     --          , [prru,pru]
-                     --          , [pru,prd]
-                     --          , [prd,prrd]
-                     --          ]
     where lDoorClosed = [ [pld,hwd]
                         , [hwd,hwu]
                         , [hwu,plu]
@@ -45,7 +38,6 @@ mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane [pl,pr])
                         ]
           norm = 10 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
           hw = 0.5 *.* (pl +.+ pr)
-          --parallel = 15 *.* normalizeV (pl -.- pr)
           parallel = 0.5 *.* (pl -.- pr)
           plu = pl +.+ norm
           pld = pl -.- norm
@@ -56,14 +48,10 @@ mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane [pl,pr])
           shiftL = map $ (+.+ parallel) . (-.- normalizeV parallel)
           shiftR = map $ (-.- parallel) . (+.+ normalizeV parallel)
 
-          pllu = plu +.+ parallel
-          plld = pld +.+ parallel
-          prru = pru -.- parallel
-          prrd = prd -.- parallel
           addSound (x:xs) = f x : xs
           f wl = over doorMech g wl
-          g dm w | dist wp pld > 1 && dist wp hwd > 1 = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 
+          g dm w | dist wp pld > 1 && dist wp hwd > 1 
-                                                                    $ dm w
+                    = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 $ dm w
                  | otherwise = dm w
             where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
 

src/Dodge/Rendering.hs

@@ -66,12 +66,12 @@ worldPictures w
                         , ptPicts 
                         , ptPicts'
                         , afterPtPicts'
---                        , wlPicts'
                         , wlPicts
                         , smokeShadows
                         , ppLabels
                         , btLabels
                         , testPic w
+                        , wallsToSetDepth
                         ]
     where
           decPicts      = IM.elems $ _decorations w
@@ -84,7 +84,7 @@ worldPictures w
           clPicts       = map clDraw $ IM.elems $ _clouds w
           smokeShadows  = map (drawSmokeShadow w) $ _smoke w
           wlPicts       = map drawWallFloor (wallFloorsToDraw w)
-          wlPicts'      = map (drawWallFace w) (wallShadowsToDraw w)
+          wallsToSetDepth = map (drawWallFace w) (wallShadowsToDraw w)
           itFloorPicts  = map drawItem (IM.elems (_floorItems w))
           yourPos = _crPos $ you w
           yourRot = _crDir $ you w
@@ -271,8 +271,8 @@ outsideScreenPolygon w = [tr,tl,bl,br]
           x = halfWidth w + halfHeight w
 
 wallShadowsToDraw :: World -> [Wall]
-wallShadowsToDraw w = --IM.elems $ _walls w
+wallShadowsToDraw w = filter isVisible 
-        filter isVisible $ IM.elems -- $ _walls w
+                        . IM.elems
                         $ wallsNearZones (zoneOfSight w) w
 -- should really sort this out
     where onScreen wall = True -- lineOnScreenCone w (_wlLine wall)
@@ -299,21 +299,12 @@ lineOnScreen w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9
 
 drawWallFace :: World -> Wall -> Picture
 drawWallFace w wall
-    | isRHS sightFrom x y = blank
+    | isRHS sightFrom x y || _wlIsSeeThrough wall = blank
-    | otherwise = colorAndLayer $ polygon $ points
+    | otherwise = setLayer 3 . setDepth 1 . polygon $ points
     where 
-        colorAndLayer | _wlIsSeeThrough wall = setLayer 2
-                                                . onLayerL [levLayer ShadowLayer,3] 
-                                                . color (withAlpha 0.5 $ _wlColor wall)
-                      | otherwise = setLayer 0 
-                                        . onLayerL [levLayer ShadowLayer,l]
-                                        . color (_wlColor wall)
         (x:y:_) = _wlLine wall 
         points = extendConeToScreenEdge w sightFrom (x,y)
         sightFrom = _cameraCenter w
-        l = case wall of
-                Door {} -> 1
-                _ -> 2
 
 -- the following assumes that the point a is inside the screen
 -- it still works otherwise, but it might intersect two points:
@@ -445,7 +436,8 @@ wallsPointsAndCols w = map f . filter (not . _wlIsSeeThrough) . IM.elems $ walls
           f wl = (linePairs $ _wlLine wl, _wlColor wl)
 
 wallsWindows :: World -> [((Point2,Point2),Point4)]
-wallsWindows w = map f . filter _wlIsSeeThrough . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
+wallsWindows w = map f . filter (fromMaybe True . (^? blVisible)) .
+                     filter _wlIsSeeThrough . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
     where linePairs (x:y:_) = (x,y)
           f wl = (linePairs $ _wlLine wl, _wlColor wl)
 
@@ -455,12 +447,6 @@ wallsForShadows w = map (linePairs . _wlLine)
                         . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
     where linePairs (x:y:_) = (x,y)
 
-wallsForGloom :: World -> [((Point2,Point2),Point4)]
-wallsForGloom w = map f $ filter (not . _wlIsSeeThrough)
-                        $ IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
-    where linePairs (x:y:_) = (x,y)
-          f wl = (linePairs $ _wlLine wl, _wlColor wl)
-
 lightsForGloom' :: World -> [(Point4)]
 lightsForGloom' w = map getLS (IM.elems $ _lightSources w) ++ map getTLS (_tempLightSources w)
     where getLS ls  = ( fst $ _lsPos ls, snd $ _lsPos ls,  _lsRad ls , _lsIntensity ls)

src/Picture/Render.hs

@@ -31,16 +31,6 @@ import qualified Data.IntMap.Strict as IM
 
 import qualified SDL as SDL
 
-setCommonUniforms :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> IO ()
-setCommonUniforms pdata rot zoom (tranx,trany) (winx,winy) = do
-    setShaderUniforms rot zoom (tranx,trany) (winx,winy) 
-        ( (extractProgAndUnis $ _lightSourceShader pdata) 
-        : (extractProgAndUnis $ _wallShadowShader pdata) 
-        : (extractProgAndUnis $ _wallLightShader pdata) 
-        : (extractProgAndUnis $ _backgroundShader pdata) 
-        : (map extractProgAndUnis $ _listShaders pdata)
-        )
-
 renderPicture' :: RenderData -> Float -> Float -> Point2 -> Point2 ->
                     [((Point2,Point2),Point4)] -> [((Point2,Point2),Point4)] -> [Point4] ->
                     (Float,Float) -> Picture -> IO (Word32,Word32)
@@ -61,13 +51,21 @@ renderPicture' pdata rot zoom trans@(tranx,trany) wins@(winx,winy) wallPointsCol
     ticksAfterLighting <- SDL.ticks
     renderBackground pdata rot zoom trans wins
 
+    renderWalls pdata wallPointsCol pmat
+
+    renderWalls pdata windowPoints pmat
+
+-- hack: the walls are drawn with a continuous depth from 0 to -1
+-- the following call is aimed at setting the depth buffer over all the walls to
+-- at most -0.9
+    colorMask $= (Color4 Disabled Disabled Disabled Disabled)
+    renderFoldable pdata $ picToLTree (Just 3) pic
+    colorMask $= (Color4 Enabled Enabled Enabled Enabled)
+
     depthFunc $= Just Lequal
 
     renderFoldable pdata $ picToLTree (Just 0) pic
 
-    renderWalls pdata wallPointsCol pmat
-
-    renderWalls pdata windowPoints pmat
 
 -- reset blend so that light map doesn't apply
     blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
@@ -209,25 +207,15 @@ renderBackground pdata rot zoom (tranx,trany) (winx,winy) = do
     textureBinding Texture2D $= (fmap _textureObject $ _shaderTexture $ _backgroundShader pdata)
     drawArrays Points (fromIntegral 0) (fromIntegral 1)
 
-renderPicture :: RenderData -> Picture -> IO ()
+setCommonUniforms :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> IO ()
-renderPicture pdata pic = do
+setCommonUniforms pdata rot zoom (tranx,trany) (winx,winy) = do
-
+    setShaderUniforms rot zoom (tranx,trany) (winx,winy) 
-    depthFunc $= Just Lequal
+        ( (extractProgAndUnis $ _lightSourceShader pdata) 
-
+        : (extractProgAndUnis $ _wallShadowShader pdata) 
--- draw layer 0
+        : (extractProgAndUnis $ _wallLightShader pdata) 
-    ticks2 <- renderFoldable pdata $ picToLTree (Just 0) pic
+        : (extractProgAndUnis $ _backgroundShader pdata) 
-                                                        --((picToAlt 0 pic) :: [RenderType])
+        : (map extractProgAndUnis $ _listShaders pdata)
--- reset blend so that light map doesn't apply
+        )
-    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-    ticks3 <- renderFoldable pdata $ picToLTree (Just 1) pic
--- set drawing for on top
-    aticks <- SDL.ticks
-    blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
-    ticks4 <- renderFoldable pdata $ picToLTree (Just 2) pic
-    bticks <- SDL.ticks
-
-    resetShaderUniforms (map extractProgAndUnis $ _listShaders pdata)
-
 
 renderFoldable :: Foldable f => RenderData -> f RenderType -> IO Word32
 renderFoldable pdata tree = do
@@ -247,7 +235,6 @@ renderFoldable pdata tree = do
     
     pokeEndTicks <- SDL.ticks
     return $ pokeEndTicks - pokeStartTicks
-
 ------------------------------end renderFoldable
 
 
@@ -269,34 +256,3 @@ pokeFourOff ptr n (x,y,z,w) = do
     pokeElemOff ptr (4*n+1) y
     pokeElemOff ptr (4*n+2) z
     pokeElemOff ptr (4*n+3) w
-
-mkShadFromWall :: (Point2,Point2,Point2,Point2) -> Point4 -> [(Point3,Point4)]
-{-# INLINE mkShadFromWall #-}
-mkShadFromWall (wla,wlb,_,_) (x,y,r,_) 
-    = makeHexahedron $ prismQuad (f wla
-                                 ,f wlb
-                                 ,f $ wla +.+ r *.* normalizeV (wla -.- ls)
-                                 ,f $ wlb +.+ r *.* normalizeV (wlb -.- ls)
-                                 )
-        where f (x,y) = (x,y,0)
-              ls = (x,y)
-
-prismQuad :: (Point3,Point3,Point3,Point3) -> 
-                (Point3,Point3,Point3,Point3
-                ,Point3,Point3,Point3,Point3)
-{-# INLINE prismQuad #-}
-prismQuad (a,b,c,d) = (a,b,c,d,f a,f b,f d,f c)
-    where f (x,y,z) = (x,y,z-0.5)
-
--- note this doubles the first and last points, assumes these points will be
--- input as part of a triangle strip
-makeHexahedron :: (Point3,Point3,Point3,Point3
-                    ,Point3,Point3,Point3,Point3) -> [(Point3,Point4)]
-{-# INLINE makeHexahedron #-}
-makeHexahedron (a1,a2,a3,a4,a5,a6,a7,a8)
-        = [cr a4 ,cr a4 ,cr a3 ,cr a7 ,cr a8 
-          ,cr a5 ,cr a3 ,cb a1 ,cb a4 ,cr a2 ,cr a7 ,cr a6 ,cr a5 ,cr a2 ,cr a1 ,cr a1 ]
-    where col = (1,0,1,0.1)
-          cr a = (a,(1,0,0,0.1))
-          cg a = (a,(0,1,0,0.1))
-          cb a = (a,(0,0,1,0.1))