Use stencil to black out floor shadows

src/Picture/Preload.hs

@@ -23,6 +23,7 @@ import qualified Control.Foldl as F
 data RenderData = RenderData
     { _lightSourceShader :: FullShader (Float,Float,Float,Float)
     , _wallShadowShader  :: FullShader (Point2,Point2,Point2,Point2)
+    , _wallLightShader  :: FullShader (Point3)
     , _backgroundShader  :: FullShader (Point2,Point2,Point2,Point2)
     , _fullscreenShader  :: FullShader ()
     , _wallShader :: FullShader (Point3,Point4)
@@ -47,6 +48,9 @@ preloadRender = do
     wsShad <- makeShaderCustomUnis "wallShadow" [vert,geom,frag] [(0,4),(1,4)] Points pokeWPStrat
                 ["lightPos"]
 
+    wlLightShad <- makeShaderCustomUnis "wallLight" [vert,frag] [(0,3)] TriangleStrip pokeLightWallStrat
+                    ["lightPosRadLum"]
+
     wlShad <- makeShader "wall" [vert,frag] [(0,3),(1,4)] TriangleStrip pokeWlStrat
 
     bslist <- makeShader "basic"   [vert,frag]      [(0,3),(1,4)]       Triangles pokeTriStrat
@@ -91,6 +95,7 @@ preloadRender = do
         , _dummyPtr = dummyptr
         , _lightSourceShader = lsShad
         , _wallShadowShader  = wsShad
+        , _wallLightShader   = wlLightShad
         , _wallShader        = wlShad
         , _backgroundShader  = bgShad
         , _fullscreenShader  = fsShad
@@ -116,7 +121,6 @@ setupFramebuffer = do
     fboRBO <- genObjectName
     bindRenderbuffer Renderbuffer $= fboRBO
     renderbufferStorage Renderbuffer Depth24Stencil8 (RenderbufferSize 800 600)
-                                    -- not sure if the stencil is needed
     framebufferRenderbuffer Framebuffer DepthStencilAttachment Renderbuffer fboRBO
 
     fboStatus <- framebufferStatus Framebuffer
@@ -170,6 +174,9 @@ frag = FragmentShader
 pokeWPStrat :: (Point2,Point2,Point2,Point2) -> [[[Float]]]
 pokeWPStrat ((x,y),(z,w),(a,b),(c,d)) = [[[x,y,z,w],[a,b,c,d]]]
 
+pokeLightWallStrat :: Point3 -> [[[Float]]]
+pokeLightWallStrat (x,y,z) = [[[x,y,z]]]
+
 pokeBGStrat :: a -> [[[Float]]]
 pokeBGStrat = const []
 

src/Picture/Render.hs

@@ -44,6 +44,7 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
     setShaderUniforms rot zoom (tranx,trany) (winx,winy) 
         ( (extractProgAndUnis $ _lightSourceShader pdata) 
         : (extractProgAndUnis $ _wallShadowShader pdata) 
+        : (extractProgAndUnis $ _wallLightShader pdata) 
         : (extractProgAndUnis $ _wallShader pdata) 
         : (extractProgAndUnis $ _backgroundShader pdata) 
         : (map extractProgAndUnis $ _listShaders pdata)
@@ -52,7 +53,7 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
 -- draw lightmap
 
     bindFramebuffer Framebuffer $= (_spareFBO pdata)
-    depthFunc $= Just Less
+    depthFunc $= Just Always
     clearColor $= Color4 0 0.5 0 1
     clearDepth $= (200)
     clear [ColorBuffer]
@@ -61,10 +62,21 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
     nWalls <- F.foldM (pokeShader (_wallShadowShader pdata)) wallPoints
     bindShaderBuffers [_wallShadowShader pdata] [nWalls]
 
+--    let f (x,y) = (x,y,0)
+--        h (x,y) = (x,y,-1)
+--        g (a,b,_,_) = [f a,f a,h a,f b,h b,h b]
+--        wp = concatMap g wallPoints
+--    nLightWalls <- F.foldM (pokeShader (_wallLightShader pdata)) wp
+--    bindShaderBuffers [_wallLightShader pdata] [nLightWalls]
+
+    stencilTest $= Enabled
     forM_ lightPoints $ \(x,y,r,lum) -> do
         cullFace $= Just Front
-        clear [DepthBuffer]
+        clear [DepthBuffer,StencilBuffer]
 
+        stencilOp $= (OpKeep,OpKeep,OpReplace)
+
+        stencilFunc $= (Always, 1, 255)
 -- currentProgram does get called twice: here and inside drawShader below
         currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata)
         uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata)
@@ -80,7 +92,18 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
         bindShaderBuffers [_lightSourceShader pdata] [1]
         
         blendFuncSeparate    $= ((Zero,Zero),(Zero, OneMinusSrcAlpha))
+        stencilFunc $= (Notequal, 1, 255)
         drawShader (_lightSourceShader pdata) 1
+        
+--        currentProgram $= Just (_shaderProgram $ _wallLightShader pdata)
+--        uniform (head $ fromJust $ _shaderCustomUnis $ _wallLightShader pdata)
+--            $= Vector4 x y r lum
+--        cullFace $= Just Front
+--        depthFunc $= Just Lequal
+--        drawShader (_wallLightShader pdata) nLightWalls
+
+    cullFace $= Nothing
+    stencilTest $= Disabled
 
     startWallTicks <- SDL.ticks
     wallPokeEnd <- SDL.ticks
@@ -132,22 +155,38 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
     ticks4 <- renderFoldable pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 2) pic
     bticks <- SDL.ticks
 
--- render walls
-    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-    -- poke data
-    let lights = map (\(x,y,r,g) -> ((x,y),(r,g,0,0))) lightPoints
-        wallPairs = map (\(a,b,_,_) -> [(a,(1,1,1,1)),(b,(1,1,1,1))]) wallPoints
-        f (x,y) = [(x,y,0),(x,y,0),(x,y,-1)]
-        g (x,y) = [(x,y,0),(x,y,-1),(x,y,-1)]
-        wp = concatMap (\(a,b,_,_) -> f a ++ g b) wallPoints
-        h p = (p,(1,0,0,1))
-    i <- F.foldM (pokeShader (_wallShader pdata)) $ map h wp
+-- -- render walls
+--     depthFunc $= Nothing
+--     blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
+--     -- poke data
+--     let lights = map (\(x,y,r,g) -> ((x,y),(r,g,0,0))) lightPoints
+--         wallPairs = map (\(a,b,_,_) -> [(a,(1,1,1,1)),(b,(1,1,1,1))]) wallPoints
+--         f (x,y) = [(x,y,0),(x,y,0),(x,y,-1)]
+--         g (x,y) = [(x,y,0),(x,y,-1),(x,y,-1)]
+--         wp = concatMap (\(a,b,_,_) -> f a ++ g b) wallPoints
+--         h p = (p,(1,0,0,1))
+--     i <- F.foldM (pokeShader (_wallShader pdata)) $ map h wp
+-- 
+--     -- bind buffers
+--     bindShaderBuffers [_wallShader pdata] [i]
+-- 
+--     -- draw call
+--     drawShaders [_wallShader pdata] [i]
+--     depthFunc $= Just Lequal
 
-    -- bind buffers
-    bindShaderBuffers [_wallShader pdata] [i]
-
-    -- draw call
-    drawShaders [_wallShader pdata] [i]
+------    blendFunc $= (One,Zero)
+------    let f (x,y) = (x,y,0)
+------        h (x,y) = (x,y,-1)
+------        g (a,b) = [f a,f a,h a,f b,h b,h b]
+------        wp = concatMap g [((200,200),(-200,200))]
+------    nLightWalls <- F.foldM (pokeShader (_wallLightShader pdata)) wp
+------    bindShaderBuffers [_wallLightShader pdata] [nLightWalls]
+------    currentProgram $= Just (_shaderProgram $ _wallLightShader pdata)
+------    uniform (head $ fromJust $ _shaderCustomUnis $ _wallLightShader pdata)
+------        $= Vector4 (0::Float) 0 200 0.5
+------    cullFace $= Just Front
+------    depthFunc $= Just Lequal
+------    drawShader (_wallLightShader pdata) nLightWalls
 
     resetShaderUniforms (map extractProgAndUnis $ _listShaders pdata)