Quick hack to make window rendering passable

Before windows drew even on black backgrounds
2025-11-23 00:24:14 +00:00
parent 229350120a
commit 74c02291c1
7 changed files with 93 additions and 106 deletions
@@ -10,7 +10,7 @@ materialColor = \case
        Wood -> dark yellow
        Dirt -> dark $ dark orange
        Stone -> greyN 0.5
-        Glass -> white
+        Glass -> aquamarine
        Metal -> orange
        Crystal -> green
        Flesh -> red
@@ -14,13 +14,7 @@ import Dodge.LevelGen.PlacementHelper
 import Geometry
 import Linear

-putDoubleDoor ::
-    Wall ->
-    WdBl ->
-    Point2 ->
-    Point2 ->
-    Float ->
-    Placement
+putDoubleDoor :: Wall -> WdBl -> Point2 -> Point2 -> Float -> Placement
 putDoubleDoor wl cond a b speed =
    putDoubleDoorThen wl cond 1 a b speed (const $ const Nothing)

@@ -6,7 +6,6 @@
 -}
 module Dodge.Placement.PlaceSpot (placeSpot) where

-import Dodge.Placement.PlaceSpot.Block
 import Control.Monad.State
 import Data.Bifunctor
 import Data.Foldable
@@ -17,6 +16,7 @@ import Dodge.Base.NewID
 import Dodge.Data.GenWorld
 import Dodge.Default.Wall
 import Dodge.Path
+import Dodge.Placement.PlaceSpot.Block
 import Dodge.Placement.PlaceSpot.TriggerDoor
 import Dodge.Placement.Shift
 import Dodge.ShiftPoint
@@ -32,11 +32,10 @@ import NewInt
 -- to the placement. This id should be associated with the type of placement and
 -- match up with the created id for the object (creature id, flitid id, etc)
 placeSpot :: Int -> GenWorld -> Placement -> GenWorld
-placeSpot rid w plmnt = case plmnt of
-    Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rid i f plmnt w
-    Placement{_plSpot = PSPos extract eff fallback} ->
-        placeSpotUsingLink w rid plmnt extract eff fallback
-    Placement{} -> placePlainPSSpot w rid plmnt shift
+placeSpot rid w plmnt = case plmnt ^. plSpot of
+    PSRoomRand i f -> placeSpotRoomRand rid i f plmnt w
+    PSPos extract eff fallback -> placeSpotUsingLink w rid plmnt extract eff fallback
+    _ -> placePlainPSSpot w rid plmnt shift
  where
    shift = _rmShift $ w ^?! genRooms . ix rid

@@ -126,7 +125,7 @@ placeSpotID rid ps pt w = case pt of
            )
    PutCrit cr -> plNewUpID (gwWorld . cWorld . lWorld . creatures) crID (mvCr p rot cr) w
    PutForeground fs ->
-            (0, w & gwWorld . cWorld . lWorld . foreShapes .:~ mvFS p rot fs)
+        (0, w & gwWorld . cWorld . lWorld . foreShapes .:~ mvFS p rot fs)
    PutMachine pps mc mitm -> plMachine (map doShift pps) mc mitm p rot w
    PutLS ls -> plNewUpID (gwWorld . cWorld . lWorld . lightSources) lsID (mvLS p' rot ls) w
    RandPS _ -> error "RandPS should not be reachable here" --evaluateRandPS rid rgn ps w
@@ -161,15 +160,8 @@ placeChasm gw rid ps shiftps =
    f w = foldl' g w (loopPairs shiftps)
    g w (x, y) = obstructPathsCrossing (S.singleton ChasmObstacle) x y w

--evaluateRandPS
--    :: Int -> State StdGen PSType -> PlacementSpot -> GenWorld -> (Int, GenWorld)
--evaluateRandPS rid rgen ps w = placeSpotID rid ps evaluatedType
--    $ set (gwWorld . randGen) g w
--  where
--    (evaluatedType, g) = runState rgen (_randGen $ _gwWorld w)
-
 placeWallPoly :: [Point2] -> Wall -> World -> World
-placeWallPoly qs wl w 
+placeWallPoly qs wl w
    | (p : ps) <- orderPolygon qs = foldl' (addPane wl) w $ zip (ps ++ [p]) (p : ps)
    | otherwise = error "tried to place wall poly with too few points"

@@ -185,11 +177,10 @@ mvButton :: Point2 -> Float -> Button -> Button
 mvButton p a = (btRot +~ a) . (btPos %~ ((p +.+) . rotateV a))

 mvCr :: Point2 -> Float -> Creature -> Creature
-mvCr p rot cr =
-    cr
-        & crPos . _xy .~ p
-        & crOldPos . _xy .~ p
-        & crDir .~ rot
+mvCr p rot =
+    (crPos . _xy .~ p)
+        . (crOldPos . _xy .~ p)
+        . (crDir .~ rot)

 mvFS :: Point2 -> Float -> ForegroundShape -> ForegroundShape
 mvFS p a = (fsDir +~ a) . (fsPos %~ ((p +.+) . rotateV a))
@@ -227,6 +218,6 @@ placeMachineWalls poly mcid = insertStructureWalls MachinePart baseWall poly mci
    baseWall = defaultMachineWall & wlStructure . wsMachine .~ mcid

 mvLS :: Point3 -> Float -> LightSource -> LightSource
-mvLS (V3 x y z) rot ls = ls & lsParam . lsPos .~ V3 x y z +.+.+ startPos
+mvLS (V3 x y z) rot ls = ls & lsParam . lsPos .~ V3 x y z + startPos
  where
    startPos = onXY (rotateV rot) $ _lsPos (_lsParam ls)
@@ -301,7 +301,7 @@ doDrawing' win pdata u = do
        glClearNamedFramebufferfv (pdata ^. fboWindow . _1 . unFBO) GL_COLOR 0
    withArray [0, 0, 0, 0] $
        glClearNamedFramebufferfv (pdata ^. fboWindow . _1 . unFBO) GL_COLOR 1
-    glEnable GL_CULL_FACE
+--    glEnable GL_CULL_FACE
    glEnable GL_DEPTH_CLAMP
    glDepthFunc GL_LEQUAL
    glDepthMask GL_FALSE
@@ -311,10 +311,11 @@ doDrawing' win pdata u = do
    -- with all source alphas 0.25, alpha -> 0.5
    glBlendFunc GL_ONE_MINUS_DST_ALPHA GL_ONE_MINUS_SRC_ALPHA
    glUseProgram $ pdata ^. windowPullShader
+    glDrawArrays GL_TRIANGLES 0 (fromIntegral nWins * 12)
    -- don't need cloud postions any more
    withArray [GL_COLOR_ATTACHMENT0] $
        glInvalidateNamedFramebufferData (pdata ^. fboPos . _1 . unFBO) 1
-    glDrawArrays GL_TRIANGLES 0 (fromIntegral nWins * 12)
+    glEnable GL_CULL_FACE
    glDisable GL_DEPTH_CLAMP
    --apply lightmap to cloud buffer
    glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboCloud pdata)))
@@ -332,10 +333,13 @@ doDrawing' win pdata u = do
    glBindFramebuffer GL_FRAMEBUFFER (pdata ^. fboBase . _1 . unFBO)
    glUseProgram (pdata ^. fullscreenShader)
    glBindTextureUnit 0 (pdata ^. fboWindow . _2 . _2 . unTO)
+    glBlendFunc GL_DST_COLOR GL_ONE_MINUS_SRC_ALPHA
    glDrawArrays GL_TRIANGLES 0 6
    glBindTextureUnit 0 (pdata ^. fboCloud . _2 . _1 . unTO)
+    glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
    glDrawArrays GL_TRIANGLES 0 6
    glBindTextureUnit 0 (pdata ^. fboWindow . _2 . _1 . unTO)
+    glBlendFunc GL_DST_COLOR GL_ONE_MINUS_SRC_ALPHA
    glDrawArrays GL_TRIANGLES 0 6

    --Draw blurred bloom onto base buffer
@@ -387,12 +387,9 @@ getMenuMouseContext :: ScreenLayer -> Universe -> MouseContext
 getMenuMouseContext screen u = case screen ^. scOptions of
    [] -> NoMouseContext
    _ -> fromMaybe MouseMenuCursor $ do
-        ymax <- length <$> screen ^? scSelectionList
        yi <- ldpSelection (u ^. uvConfig) menuLDP (u ^. uvWorld . input . mousePos)
-        guard (yi >= 0 && yi < ymax)
-        return $ case screen ^? scSelectionList . ix yi . siIsSelectable of
-            Just True -> MouseMenuClick yi
-            _ -> NoMouseContext
+        t <- screen ^? scSelectionList . ix yi . siIsSelectable
+        return $ if t then MouseMenuClick yi else NoMouseContext

 isOverTerminalScreen :: Config -> Point2 -> Bool
 isOverTerminalScreen cfig (V2 x y) =
@@ -410,9 +407,9 @@ isOverTerminalScreen cfig (V2 x y) =
    xmax = xmin + 555 -- HACK drawSelectionListBackground

 updateWheelEvents :: World -> World
-updateWheelEvents w
-    | 0 <- w ^. input . scrollAmount = w
-    | yi <- w ^. input . scrollAmount = updateWheelEvent yi w
+updateWheelEvents w = case w ^. input . scrollAmount of
+    0 -> w
+    yi -> updateWheelEvent yi w

 advanceScrollAmount :: Universe -> Universe
 advanceScrollAmount =
@@ -19,6 +19,7 @@ updateWallDamages w = set (cWorld . lWorld . wallDamages) mempty
  where
    f (k,dams) w' = foldrM (damageWall k) w' dams

+-- the hack is to force the pathing incidence graph
 updateEdgesWall :: S.Set Int2 -> World -> World
 updateEdgesWall is w =
    hack $