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

2021-03-21 23:51:56 +01:00
parent 863f2d3d7a
commit 5a5ca6f208
4 changed files with 32 additions and 101 deletions
@@ -32,6 +32,7 @@ lev1 = do
            (
            [return $ return $ Right deadEndRoom
            ]
+              ++[roomMiniIntro]
            ++ [longRoom >>= randomiseLinks]
            ++ [return $ connectRoom corridor
               ,return $ connectRoom door]
@@ -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 
-                                                                    $ dm w
+          g dm w | dist wp pld > 1 && dist wp hwd > 1 
+                    = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 $ dm w
                 | otherwise = dm w
            where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1

@@ -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,9 +271,9 @@ outsideScreenPolygon w = [tr,tl,bl,br]
          x = halfWidth w + halfHeight w

 wallShadowsToDraw :: World -> [Wall]
-wallShadowsToDraw w = --IM.elems $ _walls w
-        filter isVisible $ IM.elems -- $ _walls w
-                                     $ wallsNearZones (zoneOfSight w) w
+wallShadowsToDraw w = filter isVisible 
+                        . IM.elems
+                        $ wallsNearZones (zoneOfSight w) w
 -- should really sort this out
    where onScreen wall = True -- lineOnScreenCone w (_wlLine wall)
          isVisible wl | wl ^? blVisible == Just False = False
@@ -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
-    | otherwise = colorAndLayer $ polygon $ points
+    | isRHS sightFrom x y || _wlIsSeeThrough wall = blank
+    | 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)
@@ -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))