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

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 ()
-renderPicture pdata pic = do
-
-    depthFunc $= Just Lequal
-
--- draw layer 0
-    ticks2 <- renderFoldable pdata $ picToLTree (Just 0) pic
-                                                        --((picToAlt 0 pic) :: [RenderType])
--- 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)
-
+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)
+        )
 
 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))