Start to make wall flags/pathing interaction more sensible

2025-10-23 11:35:24 +01:00
parent 9e6534b8f4
commit fc7c4d6468
18 changed files with 167 additions and 145 deletions
@@ -1,22 +1,25 @@
+{-# LANGUAGE LambdaCase #-}
+
 module Dodge.Block (
    splinterBlock,
    destroyBlock,
 ) where

-import Dodge.Zoning.Wall
-import Dodge.Base.Collide
-import Control.Monad
-import Dodge.Path
+import qualified Data.Set as S
 import Control.Lens
+import Control.Monad
 import Data.Foldable
 import qualified Data.IntSet as IS
 import Data.Maybe
+import Dodge.Base.Collide
 import Dodge.Block.Debris
 import Dodge.Data.World
 import Dodge.Material.Sound
+import Dodge.Path
 import Dodge.Wall.Delete
 import Dodge.Wall.Zone
 import Dodge.WorldEvent.Sound
+import Dodge.Zoning.Wall
 import qualified IntMapHelp as IM

 splinterBlock :: Block -> World -> World
@@ -53,29 +56,29 @@ destroyBlock bl w =
        & deleteWallIDs wlids
        & maybeClearPaths (_blObstructs bl) -- must happen after the walls are deleted
        & cWorld . lWorld . blocks %~ IM.delete (_blID bl)
--        & muchWlDustAt awl (_blPos bl)
--        & flip (foldl' $ flip (muchWlDustAt awl)) (map (pos +.+) ps)
  where
+    --        & muchWlDustAt awl (_blPos bl)
+    --        & flip (foldl' $ flip (muchWlDustAt awl)) (map (pos +.+) ps)
+
    wlids = _blWallIDs bl
+
 --    awl = w ^?! cWorld . lWorld . walls . ix (IS.findMin wlids)
 --    pos = fst . _wlLine $ awl
 --    ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w

 -- this does not handle eg doors blocking the path as well
-maybeClearPaths :: [(Int,Int)] -> World -> World
+maybeClearPaths :: [(Int, Int)] -> World -> World
 maybeClearPaths ps w = foldl' maybeClearPath w ps

-maybeClearPath :: World -> (Int,Int) -> World
-maybeClearPath w (i,j) = fromMaybe w $ do
+maybeClearPath :: World -> (Int, Int) -> World
+maybeClearPath w (i, j) = fromMaybe w $ do
    x <- getNodePos i w
    y <- getNodePos j w
    guard $ null $ overlapSegWalls x y $ wlsNearSeg x y w
-    return $ w & cWorld . incGraph %~ updateEdge f (i,j) 
-  where
-    f = at BlockObstacle .~ Nothing
+    return $ w & cWorld . incGraph %~ updateEdge (S.intersection (S.singleton ChasmObstacle)) (i, j)
+
 ----    | not . null $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w =
 ----        w
 ----    | otherwise =
 ----        w
 ----            & cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles .~ mempty) . FGL.delEdge (x, y)
-
@@ -53,9 +53,9 @@ data PSType
        , _putEndPoint :: Point2
        }
    | PutWall {_pwPoly :: [Point2], _pwWall :: Wall}
-    | PutSlideDr Door Wall EdgeObstacle Float Point2 Point2
+    | PutSlideDr Door Wall (S.Set EdgeObstacle) Float Point2 Point2
 --    | PutDoor Color EdgeObstacle WdBl [(Point2, Point2)]
-    | PutDoor Color EdgeObstacle WdBl Float Point2A Point2A -- [(Point2, Point2)]
+    | PutDoor Color (S.Set EdgeObstacle) WdBl Float Point2A Point2A -- [(Point2, Point2)]
    | RandPS (State StdGen PSType)
    | PutForeground ForegroundShape
    | PutWorldUpdate (Int -> PlacementSpot -> GenWorld -> GenWorld)
@@ -8,12 +8,13 @@ The warnings have been disabled.
 -}
 module Dodge.Data.PathGraph where

+import Dodge.Data.Wall.Structure
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
 import Data.Graph.Inductive
 --import Data.Map.Strict (Map)
-import qualified Data.Set as Set
+import qualified Data.Set as S
 --import Geometry.Data

 --data PathGraph = PathGraph
@@ -41,17 +42,17 @@ import qualified Data.Set as Set

 data SimpleEdge = SimpleEdge
    { _seDist :: Float
-    , _seObstacles :: Set.Set EdgeObstacle
+    , _seObstacles :: S.Set EdgeObstacle
    }
    deriving (Eq, Ord, Show, Read) --Generic, Flat)

 data EdgeObstacle
-    = BlockObstacle
-    | DoorObstacle
-    | AutoDoorObstacle
-    | WallObstacle
+    = WallObstacle WallFlag
    | ChasmObstacle
-    deriving (Eq, Ord, Show, Bounded, Enum, Read) --Generic, Flat)
+    deriving (Eq, Ord, Show, Read) --Generic, Flat)
+
+switchWallObs :: S.Set EdgeObstacle
+switchWallObs = S.fromList $ WallObstacle <$> [WallBlockVisibility,WallNotAutoOpen]

 --instance (ToJSON a, ToJSON b) => ToJSON (Gr a b) where
 --    toEncoding = genericToEncoding defaultOptions
@@ -14,12 +14,14 @@ import Data.Aeson.TH
 import Dodge.Data.Material
 import Dodge.Data.Wall.Structure
 import Geometry
+import qualified Data.Set as S

 data Wall = Wall
    { _wlLine :: (Point2, Point2)
    , _wlID :: Int
    , _wlColor :: Color
    , _wlOpacity :: Opacity
+    , _wlPathFlag :: S.Set WallFlag
    , _wlPathable :: Bool
    , _wlPenetrable :: Bool
    , _wlBouncy :: Bool
@@ -1,8 +1,8 @@
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}

-module Dodge.Data.Wall.Structure
- where
+module Dodge.Data.Wall.Structure where
+
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
@@ -12,8 +12,15 @@ data WallStructure
    | DoorPart {_wsDoor :: Int}
    | MachinePart {_wsMachine :: Int}
    | BlockPart {_wsBlock :: Int}
-    | CreaturePart { _wlStCreature :: Int }
+    | CreaturePart {_wlStCreature :: Int}
    deriving (Eq, Ord, Show, Read) --Generic, Flat)

+data WallFlag
+    = WallBlockVisibility
+    | WallNotAutoOpen
+    | WallNotDestrucable
+    deriving (Eq, Ord, Show, Read, Enum, Bounded) --Generic, Flat)
+
 makeLenses ''WallStructure
 deriveJSON defaultOptions ''WallStructure
+deriveJSON defaultOptions ''WallFlag
@@ -268,10 +268,9 @@ drawPathEdge x y pe = setLayer DebugLayer $ multiArrow x y green (S.map obstacle

 obstacleColor :: EdgeObstacle -> Color
 obstacleColor eo = case eo of
-    WallObstacle -> red
-    DoorObstacle -> orange
-    AutoDoorObstacle -> yellow
-    BlockObstacle -> blue
+    WallObstacle WallNotAutoOpen -> red
+    WallObstacle WallBlockVisibility -> orange
+    WallObstacle WallNotDestrucable -> yellow
    ChasmObstacle -> cyan

 drawFarWallDetect :: World -> Picture
@@ -402,8 +401,7 @@ drawWlIDs w = setLayer FixedCoordLayer $ foldMap f (w ^. cWorld . lWorld . walls
        p = worldPosToScreen (w ^. wCam) $ 0.5 *.* uncurry (+.+) (_wlLine wl)

 drawPathing :: Config -> World -> Picture
-drawPathing cfig w =
-    setLayer DebugLayer $ ifoldMap f $ w ^. cWorld . incGraph
+drawPathing cfig w = setLayer DebugLayer $ ifoldMap f $ w ^. cWorld . incGraph
  where
    inodes = w ^. cWorld . incNode
    f i = foldMap (g i)
@@ -8,6 +8,7 @@ module Dodge.Default.Wall (
    defaultDirtWall,
 ) where

+import qualified Data.Set as S
 import Control.Lens
 import Dodge.Data.Wall
 import Geometry.Data
@@ -20,6 +21,8 @@ defaultWall =
        { _wlLine = (V2 0 0, V2 50 0)
        , _wlID = 0
        , _wlColor = greyN 0.6
+        , _wlPathFlag = S.fromList [WallBlockVisibility
+                , WallNotAutoOpen, WallNotDestrucable]
        , --, _wlOpacity = Opaque 11
          _wlOpacity = Opaque 11
        , _wlPathable = False
@@ -38,6 +41,7 @@ defaultWall =

 defaultDoorWall :: Wall
 defaultDoorWall = defaultWall { _wlMaterial = Metal }
+    & wlPathFlag . at WallNotDestrucable .~ Nothing

 {- Indestructible see-through wall.  -}
 defaultCrystalWall :: Wall
@@ -15,6 +15,7 @@ module Dodge.Path (
    getEdgesCrossing,
 ) where

+import qualified Data.Set as S
 import qualified Algorithm.Search as AS
 import Control.Lens
 --import Data.Bifunctor
@@ -82,7 +83,7 @@ makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
 makePathBetween = makePathUsing $ not . pathEdgeObstructed

 pathEdgeObstructed :: Set.Set EdgeObstacle -> Bool
-pathEdgeObstructed pe = any (`Set.member` pe) [DoorObstacle, BlockObstacle, ChasmObstacle]
+pathEdgeObstructed pe = any (`Set.member` pe) [WallObstacle WallNotAutoOpen, ChasmObstacle]

 walkableNodeNear :: World -> Point2 -> Maybe Int
 {-# INLINE walkableNodeNear #-}
@@ -129,17 +130,17 @@ pairsToIncGraph pairs =
    ps = Set.toList $ Set.map fst pairs <> Set.map snd pairs

 obstructPathsCrossing ::
-    EdgeObstacle ->
+    S.Set EdgeObstacle ->
    Point2 ->
    Point2 ->
    World ->
    (World, [(Int,Int)])
-obstructPathsCrossing obstacletype s e w =
+obstructPathsCrossing obs s e w =
    ( w & cWorld . incGraph %~ updateincedges
    , inces
    )
  where
-    updateincedge = flip $ updateEdge (at obstacletype ?~ ()) 
+    updateincedge = flip $ updateEdge (S.union obs) 
    updateincedges gr = foldl' updateincedge gr inces
    inces = filter inedgecrosses $ nearSeg peZoneSize _incEdgeZoning s e w
    inedgecrosses (i, j) = isJust $ intersectSegSeg s e (f i) (f j)
@@ -5,6 +5,7 @@ module Dodge.Placement.Instance.Door (
    switchDoor, -- not used 9/3/22
 ) where

+import qualified Data.Set as S
 import Color
 import Control.Lens
 import Dodge.Data.CreatureEffect
@@ -14,12 +15,13 @@ import Dodge.LevelGen.PlacementHelper
 import Dodge.LevelGen.Switch
 import Geometry

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

 putDoubleDoorThen ::
-    EdgeObstacle ->
+    S.Set EdgeObstacle ->
    Wall ->
    WdBl ->
    Float ->
@@ -37,7 +39,7 @@ putDoubleDoorThen eo wl cond soff a b speed cont =
    half = 0.5 *.* (a +.+ b)

 doorBetween ::
-    EdgeObstacle ->
+    S.Set EdgeObstacle ->
    Wall ->
    WdBl ->
    Float ->
@@ -70,7 +72,7 @@ divideDoorPane mid wl cond soff speed ppairs g = case ppairs of
    (p : ps) -> ptCont (adoor p) $ \pl -> Just $ divideDoorPane (_plMID pl) wl cond soff speed ps g
    _ -> undefined
  where
-    adoor (x, y) = PutSlideDr thedoor wl DoorObstacle soff x y
+    adoor (x, y) = PutSlideDr thedoor wl mempty soff x y
    thedoor =
        defaultDoor & drSpeed .~ speed & drTrigger .~ cond
            & drPushedBy .~ maybe PushesItself PushedBy mid
@@ -81,7 +83,7 @@ putAutoDoor a b = Placement (PS 0 0) (PutCoord a) Nothing Nothing $ \_ apl ->
        let x = w ^?! gwWorld . coordinates . ix (apl ^?! plMID . _Just)
            y = w ^?! gwWorld . coordinates . ix (bpl ^?! plMID . _Just)
        in Just $ putDoubleDoor
-                AutoDoorObstacle
+                (S.fromList [WallObstacle WallBlockVisibility])
                defaultAutoWall
                (WdBlCrFilterNearPoint 40 (0.5 *.* (x + y)) CrIsAnimate)
                a
@@ -109,7 +111,8 @@ switchDoor btpos btrot dra drb col = pContID
        jsps0J (doorbetween btid dra drc) $
            sps0 (doorbetween btid drb drc)
  where
-    doorbetween btid a b = PutSlideDr thedoor (switchWallCol col) DoorObstacle 1 a b
+    doorbetween btid a b = PutSlideDr thedoor (switchWallCol col) 
+        (S.fromList (WallObstacle <$> [WallNotAutoOpen,WallBlockVisibility])) 1 a b
      where
        thedoor =
            defaultDoor
@@ -6,6 +6,7 @@
 -}
 module Dodge.Placement.PlaceSpot (placeSpot) where

+import qualified Data.Set as S
 import Color
 import Control.Monad.State
 import Data.Bifunctor
@@ -165,7 +166,7 @@ placeChasm gw rid ps shiftps =
        & gwWorld %~ f
  where
    f w = foldl' g w (loopPairs shiftps)
-    g w (x,y) = fst $ obstructPathsCrossing ChasmObstacle x y w
+    g w (x,y) = fst $ obstructPathsCrossing (S.singleton ChasmObstacle) x y w

 --evaluateRandPS
 --    :: Int -> State StdGen PSType -> PlacementSpot -> GenWorld -> (Int, GenWorld)
@@ -185,7 +186,7 @@ placeWallPoly qs wl w = foldl' (addPane wl) w pairs
 addPane :: Wall -> World -> (Point2, Point2) -> World
 addPane wl w l =
    w & plNew (cWorld . lWorld . walls) wlID (wl & wlLine .~ l)
-        & fst . uncurry (obstructPathsCrossing WallObstacle) l
+        & fst . uncurry (obstructPathsCrossing (S.fromList [WallObstacle WallNotAutoOpen])) l

 mvProp :: Point2 -> Float -> Prop -> Prop
 mvProp p a = (prRot +~ a) . (prPos %~ ((p +.+) . rotateV a))
@@ -4,6 +4,7 @@ module Dodge.Placement.PlaceSpot.Block (
    plLineBlock,
 ) where

+import qualified Data.Set as S
 import Control.Lens
 import qualified Data.IntSet as IS
 import Data.List
@@ -119,5 +120,6 @@ insertWalls blid wls w = w' & cWorld . lWorld . blocks . ix blid . blObstructs .

 insertWall :: Wall -> World -> (World, [(Int,Int)])
 insertWall wl =
-    uncurry (obstructPathsCrossing BlockObstacle) (_wlLine wl)
+    uncurry (obstructPathsCrossing (S.fromList [WallObstacle WallNotAutoOpen, WallObstacle WallBlockVisibility])) 
+        (_wlLine wl)
        . (cWorld . lWorld . walls . at (_wlID wl) ?~ wl)
@@ -4,6 +4,7 @@ module Dodge.Placement.PlaceSpot.TriggerDoor (
    updateDoorEdges,
 ) where

+import qualified Data.Set as S
 import Dodge.ShiftPoint
 import Linear
 import Dodge.Data.GenWorld
@@ -18,7 +19,7 @@ import Picture

 plDoor ::
    Color ->
-    EdgeObstacle ->
+    S.Set EdgeObstacle ->
    -- | Opening condition
    WdBl ->
    -- | Door positions, closed to open.
@@ -51,7 +52,8 @@ plDoor col eo cond l p1 p2 gw = (drid, over gwWorld addWalls $ gw & gwWorld . cW
    addWalls w' = foldl' (addDoorWall eo drid $ switchWallCol col) w' $ zip wlids
        $ wlps' & each . each %~ shiftPointBy p1

-addDoorWall :: EdgeObstacle -> Int -> Wall -> World -> (Int, (Point2, Point2)) -> World
+addDoorWall :: S.Set EdgeObstacle 
+    -> Int -> Wall -> World -> (Int, (Point2, Point2)) -> World
 addDoorWall eo drid wl w (wlid, wlps) =
    w'
        & cWorld . lWorld . walls
@@ -80,7 +82,7 @@ updateDoorEdge _ w _ = w
 plSlideDoor ::
    Door ->
    Wall ->
-    EdgeObstacle ->
+    S.Set EdgeObstacle ->
    Float ->
    Point2 ->
    Point2 ->
@@ -35,8 +35,8 @@ decontamRoom i =
        & rmPmnts
            .~ [ pContID (PS (V2 (-35) 50) (negate $ pi / 2)) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) $
                    \btid -> Just $
-                        putDoubleDoorThen DoorObstacle thewall (WdBlNegate $ WdBlBtOn btid) 1 (V2 0 20) (V2 40 20) 2 $
-                            \_ _ -> Just $ putDoubleDoor DoorObstacle thewall (WdBlBtOn btid) (V2 0 80) (V2 40 80) 2
+                        putDoubleDoorThen switchWallObs thewall (WdBlNegate $ WdBlBtOn btid) 1 (V2 0 20) (V2 40 20) 2 $
+                            \_ _ -> Just $ putDoubleDoor switchWallObs thewall (WdBlBtOn btid) (V2 0 80) (V2 40 80) 2
               , invisibleWall $ rectNSWE 60 40 (-40) (-30)
               , spanLightI (V2 (-20) 30) (V2 (-20) 70)
               , analyser (NoItemZone ps) (PS 50 0) (PS mcpos 0) & plExternalID ?~ i
@@ -50,7 +50,7 @@ decontamRoom i =
        pmnt <- gw ^? genPmnt . ix i
        return $
            putDoubleDoor
-                DoorObstacle
+                switchWallObs
                (switchWallCol red)
                (cond pmnt)
                (V2 (-10) 35)
@@ -78,8 +78,8 @@ airlock0 =
        , _rmPmnts =
            [ pContID (PS (V2 (-35) 50) (negate $ pi / 2)) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) $
                \btid -> Just $
-                    putDoubleDoorThen DoorObstacle thewall (WdBlNegate $ WdBlBtOn btid) 1 (V2 0 20) (V2 40 20) 2 $
-                        \_ _ -> Just $ putDoubleDoor DoorObstacle thewall (WdBlBtOn btid) (V2 0 80) (V2 40 80) 2
+                    putDoubleDoorThen switchWallObs thewall (WdBlNegate $ WdBlBtOn btid) 1 (V2 0 20) (V2 40 20) 2 $
+                        \_ _ -> Just $ putDoubleDoor switchWallObs thewall (WdBlBtOn btid) (V2 0 80) (V2 40 80) 2
            , invisibleWall $ rectNSWE 60 40 (-40) (-30)
            , spanLightI (V2 (-2) 30) (V2 (-2) 70)
            , sps0 $ putShape $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
@@ -97,7 +97,7 @@ airlock0 =

 --airlockDoor :: Color -> WdBl -> [(Point2, Point2)] -> PSType
 airlockDoor :: Color -> WdBl -> Float -> Point2A -> Point2A -> PSType
-airlockDoor col = PutDoor col DoorObstacle
+airlockDoor col = PutDoor col switchWallObs

 airlockDoubleDoor ::
    Point2 ->
@@ -43,5 +43,5 @@ triggerDoorRoom i =
    f gw = fromMaybe (error "tried to put a door using an empty placement list") $ do
        pmnt <- gw ^? genPmnt . ix i
        return $ putDoubleDoor 
-            DoorObstacle (switchWallCol red) (cond pmnt) (V2 0 20) (V2 40 20) 2
+            switchWallObs (switchWallCol red) (cond pmnt) (V2 0 20) (V2 40 20) 2
    cond pmnt = WdTrig $ fromJust (_plMID pmnt)
@@ -47,8 +47,8 @@ twinSlowDoorRoom w h x =
        , _rmPath = mempty
        , _rmPmnts =
            [ pContID (PS (V2 0 (h -5)) pi) (PutButton $ makeButton col NoWorldEffect) $
-                \btid -> jsps0J (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 x 1) (V2 x h)) $
-                    ps0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 (- x) 1) (V2 (- x) h)) $
+                \btid -> jsps0J (PutSlideDr (thedoor btid) thewall switchWallObs 1 (V2 x 1) (V2 x h)) $
+                    ps0 (PutSlideDr (thedoor btid) thewall switchWallObs 1 (V2 (- x) 1) (V2 (- x) h)) $
                        \did -> jps0' (PutLS (lsColPos (V3 0.75 0 0) (V3 0 (h -1) lampheight))) $
                            \lspl -> jsps0 $ PutProp $ addColorChange (fromJust $ _plMID lspl) did $ lampCoverWhen (WdBlDoorMoving did) (V2 0 (h -1)) lampheight
            ]
@@ -135,7 +135,7 @@ addButtonSlowDoor x h rm = do
        (rprBool (isUnusedLnkType InLink))
        $ \btplmnt -> Just $
            putDoubleDoorThen
-                DoorObstacle
+                switchWallObs
                thewall
                (WdBlBtOn $ fromJust $ _plMID btplmnt)
                30
@@ -327,8 +327,8 @@ centerVaultRoom w h d =
    theDoor =
        [ pContID (PS (V2 35 (d + 4)) 0) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) $
            \btid ->
-                jspsJ (V2 0 (d -10)) 0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 (-21) 0) (V2 0 0)) $
-                    sPS (V2 0 (d -10)) 0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 21 0) (V2 0 0))
+                jspsJ (V2 0 (d -10)) 0 (PutSlideDr (thedoor btid) thewall switchWallObs 1 (V2 (-21) 0) (V2 0 0)) $
+                    sPS (V2 0 (d -10)) 0 (PutSlideDr (thedoor btid) thewall switchWallObs 1 (V2 21 0) (V2 0 0))
        ]
    thewall = switchWallCol col
    thedoor btid =
@@ -318,12 +318,10 @@ updateEdgeWallObs :: World -> (Int,Int) -> World
 updateEdgeWallObs w (i,j) = fromMaybe w $ do
    s <- getNodePos i w
    e <- getNodePos j w
-    let wls = snd <$> wlsHitUnsorted s e w
-    return $ w & cWorld . incGraph %~ updateEdge (f wls) (i,j)
+    let wlflags = foldMap (^. _2 . wlPathFlag) $ wlsHitUnsorted s e w
+    return $ w & cWorld . incGraph %~ updateEdge (f wlflags) (i,j)
  where
-    f wls 
-        | all _wlPathable wls = (at BlockObstacle .~ Nothing) . (at DoorObstacle .~ Nothing)
-        | otherwise = at DoorObstacle ?~ ()
+    f x _ = S.map WallObstacle x

 updateDoors :: World -> World
 updateDoors w = let (is,w') = foldrM updateDoor w (w ^. cWorld . lWorld . doors)