Broken implementation of window colours, move towards stencil ceilings

shader/cloud/basic.frag

@@ -11,5 +11,5 @@ void main()
     if (d > 1) {discard;}
     fCol = vec4(vCol.xyz,vCol.w*(1-d));
     fPos = vec4(vPosID.xyz, vCol.w*(1-d));
-    fNorm = vec4(vControls.xy, 0.1 ,fPos.w); // note arbirary 0.1, might want to point downwards at the edges?
+    fNorm = vec4(vControls.xy, 0.1 ,fPos.w); // note arbitrary 0.1, might want to point downwards at the edges?
 }

shader/lighting/wallShadow.geom

@@ -4,7 +4,7 @@ layout(triangle_strip, max_vertices = 18) out;
 layout(std140, binding = 0) uniform TheMat { mat4 theMat; };
 layout(location=0) uniform vec3 lightPos;
 layout(location=1) uniform float rad;
-float rad2 = rad;
+//float rad = rad;
 // Preprocessed to include ../functions.glsl
 float closestPointOnLineParam (vec2 a, vec2 b, vec2 p) {
   return dot(p - a,b-a) / dot(b-a,b-a);
@@ -19,7 +19,7 @@ vec2 closestPointOnSeg (vec2 a,vec2 b, vec2 p) {
 }
 // End include 2023-03-13 15:33:44.438312149 UTC
 vec2 shift(vec2 p) {
-  return vec2(lightPos.xy + (rad2 * normalize(p - lightPos.xy)));
+  return vec2(lightPos.xy + (rad * normalize(p - lightPos.xy)));
 }
 float isLHS(vec2 startV, vec2 testV) {
   return sign(-startV.x * testV.y + startV.y * testV.x);
@@ -29,12 +29,12 @@ void main() {
   vec2 p1 = gl_in[0].gl_Position.xy;
   vec2 p2 = gl_in[0].gl_Position.zw;
   vec2 closepoint = closestPointOnSeg(p1,p2,lightPos.xy);
-  if (isLHS(p1 - lightPos.xy, p2 - lightPos.xy) < 0 && distance(closepoint,lightPos.xy) < rad2) {
+  if (isLHS(p1 - lightPos.xy, p2 - lightPos.xy) < 0 && distance(closepoint,lightPos.xy) < rad) {
-    vec2 closeshift = (rad2 * normalize(closepoint - lightPos.xy)) + lightPos.xy - closepoint;
+    vec2 closeshift = (rad * normalize(closepoint - lightPos.xy)) + lightPos.xy - closepoint;
     vec2 p1cs = p1 + closeshift;
-    vec2 p1o = vec2( distance(p1,lightPos.xy) > rad2 ? p1cs : shift(p1) );
+    vec2 p1o = vec2( distance(p1,lightPos.xy) > rad ? p1cs : shift(p1) );
     vec2 p2cs = p2 + closeshift;
-    vec2 p2o = vec2( distance(p2,lightPos.xy) > rad2 ? p2cs : shift(p2) );
+    vec2 p2o = vec2( distance(p2,lightPos.xy) > rad ? p2cs : shift(p2) );
 
     gl_Position = theMat * vec4(p1o,-500,1); EmitVertex();
     gl_Position = theMat * vec4(p1,-500,1); EmitVertex();

src/Data/Preload/Render.hs

@@ -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)

src/Dodge/Prop/Draw.hs

@@ -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
+propSPic :: Prop -> SPic
-drawProp pr =
+propSPic pr =
         uncurryV translateSPxy (_prPos pr) $ rotateSP (_prRot pr) $ pr ^. prDraw
 
 drawGib :: Float -> Color -> Shape

src/Dodge/Render.hs

@@ -66,8 +66,8 @@ doDrawing' win pdata u = do
         ws = wswp ^. _1
         wp = wswp ^. _2
     ((nWins, trueNWalls), (nShapeVs, nIndices, nSilIndices)) <-
-        MP.bindM3
+        MP.liftM3
-            (\_ a b -> return (a, b))
+            (\_ 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 ->
+    withArray (perspectiveMatrixb rot camzoom trans wins viewFroms) $
-        glNamedBufferSubData (pdata ^. matUBO) 0 64 ptr
+        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
+    glBlendFuncSeparatei 0 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] $
-    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 ->

src/Dodge/Room/Airlock.hs

@@ -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))

src/Dodge/Room/LongDoor.hs

@@ -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"

src/Dodge/Update/Camera.hs

@@ -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.  -}

src/Dodge/Update/WallDamage.hs

@@ -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

src/Dodge/Wall.hs

@@ -1,8 +1,9 @@
-module Dodge.Wall
+module Dodge.Wall (
-    ( module Dodge.Wall.Create
+    module Dodge.Wall.Create,
-    , module Dodge.Wall.Move
+    module Dodge.Wall.Move,
-    , module Dodge.Wall.Delete
+    module Dodge.Wall.Delete,
-    ) where
+) where
+
 import Dodge.Wall.Create
-import Dodge.Wall.Move
 import Dodge.Wall.Delete
+import Dodge.Wall.Move

src/Dodge/Wall/Create.hs

@@ -1,4 +1,4 @@
-module Dodge.Wall.Create where
+module Dodge.Wall.Create (createWall) where
 
 import Control.Lens
 import Dodge.Data.World

src/Dodge/Wall/Delete.hs

@@ -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 :: Wall -> World -> World
-deleteWall wl =
+--deleteWall wl =
-    (cWorld . lWorld . walls %~ IM.delete i)
+--    (cWorld . lWorld . walls %~ IM.delete i)
-        . deleteWallFromZones wl
+--        . deleteWallFromZones wl
-  where
+--  where
-    i = _wlID wl
+--    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

src/Framebuffer/Update.hs

@@ -76,23 +76,11 @@ sizeFBOs cfig rdata =
             )
             l
 
-ffoldM ::
+ffoldM :: (Foldable t, Monad m) => (a1 -> a2 -> m a1) -> t a2 -> a1 -> m a1
-    (Foldable t, Monad m) =>
-    (a1 -> a2 -> m a1) ->
-    t a2 ->
-    a1 ->
-    m a1
 ffoldM f = flip $ foldM f
 
-resizeRBO ::
+resizeRBO :: GLuint -> GLsizei -> GLsizei -> IO ()
-    GLuint -> -- RenderbufferObject
+resizeRBO rboName = glNamedRenderbufferStorage rboName GL_DEPTH24_STENCIL8
-    GLsizei ->
-    GLsizei ->
-    IO ()
-resizeRBO rboName =
-    glNamedRenderbufferStorage
-        rboName
-        GL_DEPTH24_STENCIL8
 
 updateFBOTO ::
     Int ->

src/Grid.hs

@@ -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]

src/Preload/Render.hs

@@ -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 <-

src/Render.hs

@@ -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

src/Shader/Poke/Cloud.hs

@@ -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 :: Cloud -> (Point3, Point4)
-mkCloudCloudLike x = (x ^. clPos,V4 r g b a)
+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.imapM_ (pokeCloudLikeVerx vptr x nv) $
-        $ UV.fromList [(1, 1), (-1, 1), (-1, -1), (1, -1)]
+        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