Broken implementation of window colours, move towards stencil ceilings

2025-10-29 21:48:09 +00:00
parent 40c1907689
commit c2e5aaa7a0
17 changed files with 76 additions and 85 deletions
@@ -32,6 +32,7 @@ data RenderData = RenderData
    , _fboHalf2 :: (FBO, TO)
    , _fboBase :: (FBO, (TO, TO, TO))
    , _fboCloud :: (FBO, (TO, TO, TO))
+--    , _fboWindow :: (FBO, (TO, TO, TO))
    , _fboBloom :: (FBO, TO)
    , _fboPos :: (FBO, TO)
    , _fboLighting :: (FBO, TO)
@@ -1,5 +1,3 @@
-{-# LANGUAGE LambdaCase #-}
-
 module Dodge.Prop.Draw (
    propSPic,
    debrisSPic,
@@ -15,17 +13,14 @@ import qualified Quaternion as Q
 import Shape
 import ShapePicture

-propSPic :: Prop -> SPic
-propSPic pr = drawProp pr
-
 debrisSPic :: Debris -> SPic
 debrisSPic db = translateSP (_dbPos db) . overPosSP (Q.rotate (_dbRot db)) $
    case db ^. dbType of
        Gib x col -> noPic $ drawGib x col
        BlockDebris m -> noPic . colorSH m $ cubeShape 4

-drawProp :: Prop -> SPic
-drawProp pr =
+propSPic :: Prop -> SPic
+propSPic pr =
        uncurryV translateSPxy (_prPos pr) $ rotateSP (_prRot pr) $ pr ^. prDraw

 drawGib :: Float -> Color -> Shape
@@ -66,8 +66,8 @@ doDrawing' win pdata u = do
        ws = wswp ^. _1
        wp = wswp ^. _2
    ((nWins, trueNWalls), (nShapeVs, nIndices, nSilIndices)) <-
-        MP.bindM3
-            (\_ a b -> return (a, b))
+        MP.liftM3
+            (\_ a b -> (a, b))
            ( pokeLayVerxs
                shadV
                pokeCounts
@@ -115,19 +115,18 @@ doDrawing' win pdata u = do
        , (_silhouetteEBO pdata, nSilIndices)
        ]
    -- set the coordinate uniform ready for drawing elements using world coordinates
-    withArray (perspectiveMatrixb rot camzoom trans wins viewFroms) $ \ptr ->
-        glNamedBufferSubData (pdata ^. matUBO) 0 64 ptr
+    withArray (perspectiveMatrixb rot camzoom trans wins viewFroms) $
+        glNamedBufferSubData (pdata ^. matUBO) 0 64
    setViewport _graphics_world_resolution cfig
    glBindFramebuffer GL_FRAMEBUFFER (pdata ^. fboBase . _1 . unFBO)
    glDepthMask GL_TRUE
    glDisable GL_BLEND
    glDepthFunc GL_LESS
-    with 1 $ \ptr ->
+    with 1 $
        glClearNamedFramebufferfv
            (pdata ^. fboBase . _1 . unFBO)
            GL_DEPTH
            0
-            ptr
    -- draw wall occlusions from the camera's point of view
    unless (debugOn Remove_LOS cfig) $ do
        glUseProgram (pdata ^. lightingWallShadShader . shaderUINT)
@@ -153,7 +152,6 @@ doDrawing' win pdata u = do
        glClearNamedFramebufferfv (pdata ^. fboBase . _1 . unFBO) GL_COLOR 2
    withArray [GL_COLOR_ATTACHMENT0, GL_COLOR_ATTACHMENT1, GL_COLOR_ATTACHMENT2] $
        glNamedFramebufferDrawBuffers (pdata ^. fboBase . _1 . unFBO) 3
-    --        \ptr -> glDrawBuffers 3 ptr
    --draw walls onto base buffer
    -- maybe cull faces? maybe do this before?
    glEnable GL_CULL_FACE
@@ -195,7 +193,6 @@ doDrawing' win pdata u = do
        (fromIntegral nchs)
    withArray [GL_COLOR_ATTACHMENT0, GL_COLOR_ATTACHMENT1, GL_COLOR_ATTACHMENT2] $
        glNamedFramebufferDrawBuffers (pdata ^. fboBase . _1 . unFBO) 3
-    --        \ptr -> glDrawBuffers 3 ptr
    glDepthMask GL_TRUE
    --draw floor onto base buffer
    glUseProgram (pdata ^. floorShader . shaderUINT)
@@ -228,19 +225,17 @@ doDrawing' win pdata u = do
    glEnable GL_BLEND
    glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR
    drawShader (_fullscreenShader pdata) 4
-    with GL_COLOR_ATTACHMENT0 $ \ptr ->
+    with GL_COLOR_ATTACHMENT0 $
        glInvalidateNamedFramebufferData
            (pdata ^. fboLighting . _1 . unFBO)
            1
-            ptr
    --draw bloom onto bloom buffer
    glBindFramebuffer GL_FRAMEBUFFER (pdata ^. fboBloom . _1 . unFBO)
-    withArray [0, 0, 0, 0] $ \ptr ->
+    withArray [0, 0, 0, 0] $
        glClearNamedFramebufferfv
            (pdata ^. fboBloom . _1 . unFBO)
            GL_COLOR
            0
-            ptr
    glDepthFunc GL_LESS
    glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
    glDepthMask GL_FALSE
@@ -274,12 +269,12 @@ doDrawing' win pdata u = do
        glEnable GL_BLEND
    setViewport _graphics_world_resolution cfig
    --draw clouds onto cloud buffer
-    glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboCloud pdata)))
+    glBindFramebuffer GL_FRAMEBUFFER (pdata ^. fboCloud . _1 . unFBO)
    glDepthFunc GL_LEQUAL
    glDepthMask GL_FALSE
-    glBlendFuncSeparate GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA GL_ONE_MINUS_DST_ALPHA GL_ONE
-    --withArray [GL_COLOR_ATTACHMENT0, GL_NONE] $ \ptr -> glDrawBuffers 2 ptr
-    withArray [GL_COLOR_ATTACHMENT0, GL_NONE] $
+    glBlendFuncSeparatei 0 GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA GL_ONE_MINUS_DST_ALPHA GL_ONE
+    --withArray [GL_COLOR_ATTACHMENT0, GL_NONE] $
+    withArray [GL_COLOR_ATTACHMENT0, GL_COLOR_ATTACHMENT1] $
        glNamedFramebufferDrawBuffers (pdata ^. fboCloud . _1 . unFBO) 2
    withArray [0.5, 0.5, 0.5, 0] $ \ptr ->
        glClearNamedFramebufferfv
@@ -287,7 +282,6 @@ doDrawing' win pdata u = do
            GL_COLOR
            0
            ptr
-    --    renderLayer MidLayer shadV pokeCounts
    glUseProgram (pdata ^. cloudShader . shaderUINT)
    glBindVertexArray $ pdata ^. cloudShader . shaderVAO . vaoName
    glDrawElements
@@ -325,6 +319,7 @@ doDrawing' win pdata u = do
        -- we sum the positions weighted by alpha, and sum the alpha
        glBlendFuncSeparatei 1 GL_SRC_ALPHA GL_ONE GL_ONE GL_ONE
        -- and sum the normals weighted by alpha
+        --glBlendFunci 2 GL_SRC_ALPHA GL_ONE
        glBlendFunci 2 GL_SRC_ALPHA GL_ONE
        glUseProgram (pdata ^. cloudShader . shaderUINT)
        glBindVertexArray $ pdata ^. cloudShader . shaderVAO . vaoName
@@ -334,6 +329,13 @@ doDrawing' win pdata u = do
            (fromIntegral nCloudIs)
            GL_UNSIGNED_SHORT
            nullPtr
+        ---
+        glEnable GL_CULL_FACE
+        glEnable GL_DEPTH_CLAMP
+        glCullFace GL_BACK
+        drawShader (_windowShader pdata) nWins
+        glDisable GL_DEPTH_CLAMP
+        glDisable GL_CULL_FACE
        --        drawShader (_windowShader pdata) nWins
        glBindFramebuffer GL_FRAMEBUFFER (pdata ^. fboPos . _1 . unFBO)
        withArray [0, 0, 0, 0] $ \ptr ->
@@ -212,7 +212,7 @@ airlock90 =
                ]
            ]
        , _rmLinks = lnks
-        , _rmPath = linksDAGToPath lnks $ [(40,80)]
+        , _rmPath = linksDAGToPath lnks [(40,80)]
        , _rmPmnts =
            [ pContID
                (PS (V2 120 120) (3 * pi / 4))
@@ -55,7 +55,7 @@ twinSlowDoorRoom w h x =
                \btid -> jsps0J (putSlideDr (thedoor btid) thewall 1 (V2 x 1) (V2 x h)) $
                    ps0 (putSlideDr (thedoor btid) thewall 1 (V2 (- x) 1) (V2 (- x) h)) $
                        \_ -> jps0' (PutLS (lsColPos (V3 0.75 0 0) (V3 0 (h -1) lampheight))) $
-                            \_ -> Nothing -- jsps0 $ PutProp $ addColorChange (fromJust $ _plMID lspl) did $ lampCoverWhen (WdBlDoorMoving did) (V2 0 (h -1)) lampheight
+                            const Nothing -- jsps0 $ PutProp $ addColorChange (fromJust $ _plMID lspl) did $ lampCoverWhen (WdBlDoorMoving did) (V2 0 (h -1)) lampheight
            ]
        , _rmBound = ps
        , _rmName = "twinSlowDoorRoom"
@@ -24,7 +24,7 @@ import Dodge.Zoning.Wall
 import Geometry
 import LensHelp
 import SDL (MouseButton (..))
-import qualified SDL as SDL
+import qualified SDL

 {- Update the screen camera rotation and position, including any in rold scope/remote camera modifiers;
 update where your avatar's view is from.  -}
@@ -32,7 +32,7 @@ updateEdgesWall is w =
    hack w'
        | null is = w'
        | otherwise =
-            (foldMap Sum $ w' ^.. cWorld . incGraph . each . each . seObstacles . to length)
+            foldMap Sum (w' ^.. cWorld . incGraph . each . each . seObstacles . to length)
                `seq` w'

 updateEdgesWall' :: S.Set (Int, Int) -> World -> World
@@ -1,8 +1,9 @@
-module Dodge.Wall
-    ( module Dodge.Wall.Create
-    , module Dodge.Wall.Move
-    , module Dodge.Wall.Delete
-    ) where
+module Dodge.Wall (
+    module Dodge.Wall.Create,
+    module Dodge.Wall.Move,
+    module Dodge.Wall.Delete,
+) where
+
 import Dodge.Wall.Create
-import Dodge.Wall.Move
 import Dodge.Wall.Delete
+import Dodge.Wall.Move
@@ -1,4 +1,4 @@
-module Dodge.Wall.Create where
+module Dodge.Wall.Create (createWall) where

 import Control.Lens
 import Dodge.Data.World
@@ -3,7 +3,7 @@ module Dodge.Wall.Delete (
    deleteWallID,
 ) where

-import Data.Foldable
+--import Data.Foldable
 import Control.Lens
 import qualified Data.IntSet as IS
 import Dodge.Data.World
@@ -15,15 +15,15 @@ deleteWallID i w =
    w & cWorld . lWorld . walls %~ IM.delete i
        & deleteWallFromZones wl
  where
-    --wl = _walls (_cWorld w) IM.! i
    wl = w ^?! cWorld . lWorld . walls . ix i

-deleteWall :: Wall -> World -> World
-deleteWall wl =
-    (cWorld . lWorld . walls %~ IM.delete i)
-        . deleteWallFromZones wl
-  where
-    i = _wlID wl
+--deleteWall :: Wall -> World -> World
+--deleteWall wl =
+--    (cWorld . lWorld . walls %~ IM.delete i)
+--        . deleteWallFromZones wl
+--  where
+--    i = _wlID wl

 deleteWallIDs :: IS.IntSet -> World -> World
-deleteWallIDs is w = foldl' (flip deleteWall) w $ IM.restrictKeys (w ^. cWorld . lWorld . walls) is
+deleteWallIDs is w = IS.foldl' (flip deleteWallID) w is
+--deleteWallIDs is w = foldl' (flip deleteWall) w $ IM.restrictKeys (w ^. cWorld . lWorld . walls) is
@@ -76,23 +76,11 @@ sizeFBOs cfig rdata =
            )
            l

-ffoldM ::
-    (Foldable t, Monad m) =>
-    (a1 -> a2 -> m a1) ->
-    t a2 ->
-    a1 ->
-    m a1
+ffoldM :: (Foldable t, Monad m) => (a1 -> a2 -> m a1) -> t a2 -> a1 -> m a1
 ffoldM f = flip $ foldM f

-resizeRBO ::
-    GLuint -> -- RenderbufferObject
-    GLsizei ->
-    GLsizei ->
-    IO ()
-resizeRBO rboName =
-    glNamedRenderbufferStorage
-        rboName
-        GL_DEPTH24_STENCIL8
+resizeRBO :: GLuint -> GLsizei -> GLsizei -> IO ()
+resizeRBO rboName = glNamedRenderbufferStorage rboName GL_DEPTH24_STENCIL8

 updateFBOTO ::
    Int ->
@@ -26,7 +26,7 @@ latticeXsYs xs ys =
    foldMap (\y -> mkpairs xs & each . each %~ (`V2` y)) ys
        <> foldMap (\x -> mkpairs ys & each . each %~ V2 x) xs
  where
-    mkpairs (z:zs) = zip (z:zs) $ zs
+    mkpairs (z:zs) = zip (z:zs) zs
    mkpairs [] = []

 gridPointsOff :: Float -> Float -> Float -> Int -> Float -> Int -> [Point2]
@@ -63,7 +63,8 @@ preloadRender = do
    let wallverxstrd = 8
    wallvbo <- setupVBO (floatSize * wallverxstrd)
    winvbo <- setupVBO (floatSize * 8)
-    windowshader <- makeShaderUsingVBO "wall/blank" [vert, geom, frag] (toFloatVAs [4, 4]) pmPoints winvbo
+    windowshader <- makeShaderUsingVBO 
+        "wall/window" [vert, geom, frag] (toFloatVAs [4, 4]) pmPoints winvbo
    wallshader <- makeShaderUsingVBO "wall/basic" [vert, geom, frag] (toFloatVAs [4, 4]) pmPoints wallvbo
    putStrLn "Setup lighting shaders"
    lightingWallShadShad <-
@@ -157,6 +157,7 @@ renderShadows shadrendertype nWalls nSils nCaps positiontexture normaltexture li
        glDepthFunc GL_LESS
        -- setup stencil
        glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE
+        glStencilMask 127 -- so we only affect the last 7 bits
        with 0 $ \ptr ->
            glClearNamedFramebufferiv
                (pdata ^. fboLighting . _1 . unFBO)
@@ -164,7 +165,8 @@ renderShadows shadrendertype nWalls nSils nCaps positiontexture normaltexture li
                0
                ptr
        glDisable GL_CULL_FACE
-        glStencilFunc GL_ALWAYS 0 255
+        -- the first bit has been used to stencil out "ceilings" under which we never draw
+        glStencilFunc GL_NOTEQUAL 128 255 
        --draw wall shadows
        glUseProgram (_shaderUINT lwallShad)
        glUniform3f 0 x y z
@@ -1,45 +1,46 @@
 {-# LANGUAGE LambdaCase #-}

-module Shader.Poke.Cloud (pokeCloud,pokeDust) where
+module Shader.Poke.Cloud (pokeCloud, pokeDust) where

-import Geometry.Data
-import Linear
-import Dodge.Material.Color
 import Color
 import Control.Lens
 import qualified Data.Vector.Unboxed as UV
 import Dodge.Data.Cloud
+import Dodge.Material.Color
 import Foreign
+import Geometry.Data
 import Graphics.GL.Core45
+import Linear

 pokeCloud :: Ptr Float -> Ptr GLushort -> (Int, Int) -> Cloud -> IO (Int, Int)
-pokeCloud vptr iptr (nv, ni) = pokeCloudLike vptr iptr (nv,ni) . mkCloudCloudLike
+pokeCloud vptr iptr (nv, ni) = pokeCloudLike vptr iptr (nv, ni) . mkCloudCloudLike

 pokeDust :: Ptr Float -> Ptr GLushort -> (Int, Int) -> Dust -> IO (Int, Int)
-pokeDust vptr iptr (nv, ni) = pokeCloudLike vptr iptr (nv,ni) . mkDustCloudLike
+pokeDust vptr iptr (nv, ni) = pokeCloudLike vptr iptr (nv, ni) . mkDustCloudLike

-mkCloudCloudLike :: Cloud -> (Point3,Point4)
-mkCloudCloudLike x = (x ^. clPos,V4 r g b a)
+mkCloudCloudLike :: Cloud -> (Point3, Point4)
+mkCloudCloudLike x = (x ^. clPos, V4 r g b a)
  where
-    ( V4 r g b a') = ( clColor $ x ^. clType)
+    (V4 r g b a') = clColor $ x ^. clType
    a = a' * min 1 (fromIntegral (_clTimer x) / 100)

-mkDustCloudLike :: Dust -> (Point3,Point4)
+mkDustCloudLike :: Dust -> (Point3, Point4)
 mkDustCloudLike x = (x ^. dsPos, V4 r g b a)
  where
-    ( V4 r g b a') = ( dustColor x)
+    (V4 r g b a') = dustColor x
    a = a' * min 1 (fromIntegral (_dsTimer x) / 100)

-pokeCloudLike :: Ptr Float -> Ptr GLushort -> (Int, Int) -> (Point3,Point4) -> IO (Int, Int)
+pokeCloudLike ::
+    Ptr Float -> Ptr GLushort -> (Int, Int) -> (Point3, Point4) -> IO (Int, Int)
 pokeCloudLike vptr iptr (nv, ni) x = do
-    UV.imapM_ (pokeCloudLikeVerx vptr x nv) 
-        $ UV.fromList [(1, 1), (-1, 1), (-1, -1), (1, -1)]
+    UV.imapM_ (pokeCloudLikeVerx vptr x nv) $
+        UV.fromList [(1, 1), (-1, 1), (-1, -1), (1, -1)]
    UV.imapM_ (pokeCloudIndex iptr nv ni) $ UV.fromList [0, 1, 2, 2, 0, 3]
    return (nv + 4, ni + 6)

-pokeCloudLikeVerx :: Ptr Float -> (Point3,Point4) -> Int -> Int -> (Float, Float) -> IO ()
+pokeCloudLikeVerx :: Ptr Float -> (Point3, Point4) -> Int -> Int -> (Float, Float) -> IO ()
 {-# INLINE pokeCloudLikeVerx #-}
-pokeCloudLikeVerx ptr (V3 cx cy cz,V4 r g b a) nv i (dx, dy) =
+pokeCloudLikeVerx ptr (V3 cx cy cz, V4 r g b a) nv i (dx, dy) =
    UV.imapM_ (pokeCloudFloat ptr (nv + i)) $
        UV.fromList [x, y, cz, 1, r, g, b, a, dx, dy, 0, 0]
  where