From f94b914cebd3fb541cb956aebdd3a49f57982d03 Mon Sep 17 00:00:00 2001 From: justin Date: Fri, 24 Oct 2025 20:51:38 +0100 Subject: [PATCH] Cleanup door placement/auto path generation --- src/Dodge/Data/GenWorld.hs | 3 +- src/Dodge/Data/PathGraph.hs | 2 - src/Dodge/Placement/Instance/Door.hs | 64 +------- src/Dodge/Placement/PlaceSpot.hs | 4 +- src/Dodge/Placement/PlaceSpot/TriggerDoor.hs | 145 ++++++++----------- src/Dodge/Room/Airlock.hs | 9 +- src/Dodge/Room/Door.hs | 2 +- src/Dodge/Room/LongDoor.hs | 5 +- src/Dodge/Room/Procedural.hs | 4 +- 9 files changed, 83 insertions(+), 155 deletions(-) diff --git a/src/Dodge/Data/GenWorld.hs b/src/Dodge/Data/GenWorld.hs index cc51699d5..d8349a7ae 100644 --- a/src/Dodge/Data/GenWorld.hs +++ b/src/Dodge/Data/GenWorld.hs @@ -52,8 +52,7 @@ data PSType , _putEndPoint :: Point2 } | PutWall {_pwPoly :: [Point2], _pwWall :: Wall} - | PutSlideDr Bool Door Wall (S.Set EdgeObstacle) Float Point2 Point2 --- | PutDoor Color EdgeObstacle WdBl [(Point2, Point2)] + | PutSlideDr Bool Door Wall Float Point2 Point2 | PutDoor Bool WdBl Float Point2A Point2A | RandPS (State StdGen PSType) | PutForeground ForegroundShape diff --git a/src/Dodge/Data/PathGraph.hs b/src/Dodge/Data/PathGraph.hs index 55938770d..cff1c81e8 100644 --- a/src/Dodge/Data/PathGraph.hs +++ b/src/Dodge/Data/PathGraph.hs @@ -51,8 +51,6 @@ data EdgeObstacle | ChasmObstacle 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 diff --git a/src/Dodge/Placement/Instance/Door.hs b/src/Dodge/Placement/Instance/Door.hs index def54af79..3c071ce94 100644 --- a/src/Dodge/Placement/Instance/Door.hs +++ b/src/Dodge/Placement/Instance/Door.hs @@ -2,35 +2,29 @@ module Dodge.Placement.Instance.Door ( putDoubleDoor, putAutoDoor, putDoubleDoorThen, - switchDoor, -- not used 9/3/22 ) where -import Color import Control.Lens -import qualified Data.Set as S import Dodge.Data.CreatureEffect import Dodge.Data.GenWorld import Dodge.Default.Door import Dodge.Default.Wall import Dodge.LevelGen.PlacementHelper -import Dodge.LevelGen.Switch import Geometry putDoubleDoor :: Bool -> - S.Set EdgeObstacle -> Wall -> WdBl -> Point2 -> Point2 -> Float -> Placement -putDoubleDoor isauto eo wl cond a b speed = - putDoubleDoorThen isauto eo wl cond 1 a b speed (const $ const Nothing) +putDoubleDoor isauto wl cond a b speed = + putDoubleDoorThen isauto wl cond 1 a b speed (const $ const Nothing) putDoubleDoorThen :: Bool -> - S.Set EdgeObstacle -> Wall -> WdBl -> Float -> @@ -39,17 +33,16 @@ putDoubleDoorThen :: Float -> (Placement -> Placement -> Maybe Placement) -> Placement -putDoubleDoorThen isauto eo wl cond soff a b speed cont = - doorBetween isauto eo wl cond soff a half speed $ +putDoubleDoorThen isauto wl cond soff a b speed cont = + doorBetween isauto wl cond soff a half speed $ \pl1 -> Just $ - doorBetween isauto eo wl cond soff b half speed $ + doorBetween isauto wl cond soff b half speed $ \pl2 -> cont pl1 pl2 where half = 0.5 *.* (a +.+ b) doorBetween :: Bool -> - S.Set EdgeObstacle -> Wall -> WdBl -> Float -> @@ -58,8 +51,8 @@ doorBetween :: Float -> (Placement -> Maybe Placement) -> Placement -doorBetween isauto eo wl cond soff pa pb speed g = case divideLine 40 pa pb of - [x, y] -> ptCont (PutSlideDr isauto adoor wl eo soff x y) g +doorBetween isauto wl cond soff pa pb speed g = case divideLine 40 pa pb of + [x, y] -> ptCont (PutSlideDr isauto adoor wl soff x y) g (x : y : zs) -> divideDoorPane isauto Nothing wl cond (soff - dist y pb) speed (zip (x : y : zs) (y : zs)) g _ -> undefined where @@ -83,7 +76,7 @@ divideDoorPane isauto mid wl cond soff speed ppairs g = case ppairs of (p : ps) -> ptCont (adoor p) $ \pl -> Just $ divideDoorPane isauto (_plMID pl) wl cond soff speed ps g _ -> undefined where - adoor (x, y) = PutSlideDr isauto thedoor wl mempty soff x y + adoor (x, y) = PutSlideDr isauto thedoor wl soff x y thedoor = defaultDoor & drUpdate . drLerpSpeed .~ speed & drTrigger .~ cond & drPushedBy .~ maybe PushesItself PushedBy mid @@ -96,49 +89,8 @@ putAutoDoor a b = Placement (PS 0 0) (PutCoord a) Nothing Nothing $ \_ apl -> y = w ^?! gwWorld . coordinates . ix (bpl ^?! plMID . _Just) in Just $ putDoubleDoor True - (S.fromList [WallObstacle WallBlockVisibility]) defaultAutoWall (WdBlCrFilterNearPoint 40 (0.5 *.* (x + y)) CrIsAnimate) a b 3 - ---putAutoDoor :: Point2 -> Point2 -> Placement ---putAutoDoor a b = PlacementUsingPos (addZ 0 a) $ --- \az -> PlacementUsingPos (addZ 0 b) $ --- \bz -> --- putDoubleDoor --- AutoDoorObstacle --- defaultAutoWall --- (cond az bz) --- a --- b --- 3 --- where --- cond az bz = WdBlCrFilterNearPoint 40 (0.5 *.* (stripZ az +.+ stripZ bz)) CrIsAnimate - -switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement -switchDoor btpos btrot dra drb col = pContID - (PS btpos btrot) - (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) - $ \btid -> - jsps0J (doorbetween btid dra drc) $ - sps0 (doorbetween btid drb drc) - where - --doorbetween btid a b = PutSlideDr thedoor (switchWallCol col) - doorbetween btid a b = - PutSlideDr False - thedoor - defaultDoorWall - (S.fromList (WallObstacle <$> [WallNotAutoOpen, WallBlockVisibility])) - 1 - a - b - where - thedoor = - defaultDoor - & drTrigger .~ WdBlBtOn btid - & drUpdate . drLerpSpeed .~ 2 - drc = 0.5 *.* (dra +.+ drb) - ---cond btid w' = _btState (_buttons w' IM.! btid) == BtOn diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index 27fa5d363..9f6c283b8 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -136,8 +136,8 @@ placeSpotID rid ps pt w = case pt of RandPS _ -> error "RandPS should not be reachable here" --evaluateRandPS rid rgn ps w PutDoor isauto f l p1 p2 -> plDoor isauto f l (pashift p1) (pashift p2) w PutCoord cp -> plNewID (gwWorld . coordinates) (doShift cp) w - PutSlideDr isauto wl dr eo off a b -> - plSlideDoor isauto wl dr eo off (doShift a) (doShift b) w + PutSlideDr isauto wl dr off a b -> + plSlideDoor isauto wl dr off (doShift a) (doShift b) w PutBlock bl wl ps' -> plBlock (map doShift ps') diff --git a/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs b/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs index 43b32bfa0..6cf241d71 100644 --- a/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs +++ b/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs @@ -1,17 +1,15 @@ module Dodge.Placement.PlaceSpot.TriggerDoor ( plDoor, plSlideDoor, - updateDoorEdges, ) where -import Dodge.Placement.PlaceSpot.Block -import Data.List -import qualified Data.Set as S +--import Data.List import Dodge.Data.GenWorld import Dodge.Default.Door import Dodge.Default.Wall import Dodge.LevelGen.DoorPane -import Dodge.Path +--import Dodge.Path +import Dodge.Placement.PlaceSpot.Block import Dodge.ShiftPoint import Geometry import qualified IntMapHelp as IM @@ -19,6 +17,7 @@ import LensHelp import Linear plDoor :: + -- | Is door automatic? Bool -> -- | Opening condition WdBl -> @@ -29,75 +28,72 @@ plDoor :: Point2A -> GenWorld -> (Int, GenWorld) -plDoor isauto cond l p1 p2 gw = (drid, over gwWorld addWalls $ gw & gwWorld . cWorld . lWorld . doors %~ addDoor) -- carefull with the ordering of addWalls +plDoor isauto cond l p1 p2 gw = + ( drid + , over gwWorld addWalls $ gw & gwWorld . cWorld . lWorld . doors . at drid ?~ addDoor + -- carefull with the ordering of addWalls + ) where drid = IM.newKey $ _doors (_lWorld (_cWorld $ _gwWorld gw)) addDoor = - IM.insert drid $ - defaultDoor - { _drID = drid - , _drTrigger = cond - , _drUpdate = DoorLerp 0.01 - , _drZeroPos = p1 - , _drOnePos = p2 - , _drLerp = 0 - , _drFootPrint = IM.fromList . zip wlids $ wlps' - } - wlids = take 4 [wlid..] + defaultDoor + { _drID = drid + , _drTrigger = cond + , _drUpdate = DoorLerp 0.01 + , _drZeroPos = p1 + , _drOnePos = p2 + , _drLerp = 0 + , _drFootPrint = IM.fromList . zip wlids $ wlps' + } + wlids = take 4 [wlid ..] wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls wlps' = rectanglePairs 9 0 (V2 l 0) - addWalls = insertStructureWalls (`DoorPart` isauto) defaultDoorWall - (map fst wlps' & each %~ shiftPointBy p1) drid wlid - --addWalls w' = foldl' (addDoorWall eo drid $ switchWallCol col) w' $ zip wlids - -- foldl' (addDoorWall isauto eo drid defaultDoorWall) w' $ - -- zip wlids $ - -- wlps' & each . each %~ shiftPointBy p1 + addWalls = + insertStructureWalls + (`DoorPart` isauto) + defaultDoorWall + (map fst wlps' & each %~ shiftPointBy p1) + drid + wlid -addDoorWall :: - Bool -> - S.Set EdgeObstacle -> - Int -> - Wall -> - World -> - (Int, (Point2, Point2)) -> - World -addDoorWall isauto eo drid wl w (wlid, wlps) = - w' - & cWorld . lWorld . walls - %~ IM.insert - wlid - wl - { _wlLine = wlps - , _wlID = wlid - , _wlStructure = DoorPart drid isauto - } - where - w' = uncurry (obstructPathsCrossing eo) wlps w +--addWalls w' = foldl' (addDoorWall eo drid $ switchWallCol col) w' $ zip wlids +-- foldl' (addDoorWall isauto eo drid defaultDoorWall) w' $ +-- zip wlids $ +-- wlps' & each . each %~ shiftPointBy p1 -updateDoorEdges :: EdgeObstacle -> [(Int, Int)] -> World -> World -updateDoorEdges eo es w = foldl' (updateDoorEdge eo) w es - -updateDoorEdge :: EdgeObstacle -> World -> (Int, Int) -> World ---updateDoorEdge eo w (i,j) = w -updateDoorEdge _ w _ = w - --- | not . null $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w = --- w & cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles . at eo ?~ ()) . FGL.delEdge (x, y) --- | otherwise = --- w & cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles . at eo .~ Nothing) . FGL.delEdge (x, y) +--addDoorWall :: +-- Bool -> +-- S.Set EdgeObstacle -> +-- Int -> +-- Wall -> +-- World -> +-- (Int, (Point2, Point2)) -> +-- World +--addDoorWall isauto eo drid wl w (wlid, wlps) = +-- w' +-- & cWorld . lWorld . walls +-- %~ IM.insert +-- wlid +-- wl +-- { _wlLine = wlps +-- , _wlID = wlid +-- , _wlStructure = DoorPart drid isauto +-- } +-- where +-- w' = uncurry (obstructPathsCrossing eo) wlps w plSlideDoor :: Bool -> Door -> Wall -> - S.Set EdgeObstacle -> Float -> Point2 -> Point2 -> GenWorld -> (Int, GenWorld) -plSlideDoor isauto dr wl eo shiftOffset a b gw = - (drid, over gwWorld addDoorWalls $ gw & gwWorld . cWorld . lWorld . doors %~ addDoor) +plSlideDoor isauto dr wl shiftOffset a b gw = + --(drid, over gwWorld addDoorWalls $ gw & gwWorld . cWorld . lWorld . doors %~ addDoor) + (drid, over gwWorld addWalls $ gw & gwWorld . cWorld . lWorld . doors %~ addDoor) where drid = IM.newKey $ _doors (_lWorld (_cWorld $ _gwWorld gw)) addDoor = @@ -110,30 +106,15 @@ plSlideDoor isauto dr wl eo shiftOffset a b gw = , _drLerp = 0 , _drFootPrint = IM.fromList $ zip wlids $ rectanglePairs 9 0 (b - a) } - addDoorWalls w' = foldl' (addDoorWall isauto eo drid wl) w' $ zip wlids pairs pairs = rectanglePairs 9 a b shiftLeft = (+.+ (a -.- b +.+ shiftOffset *.* normalizeV (b -.- a))) - wlids = take 4 [IM.newKey $ _walls (_lWorld (_cWorld $ _gwWorld gw)) ..] - --- old code that may help with pathing ---import Dodge.LevelGen.Pathing ---import Data.Graph.Inductive hiding ((&)) ---addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> Float -> World -> (Int, World) ---addButtonDoor c btp btr a b speed w --- = (,) 0 --- . over buttons (IM.insert bid bt) --- $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph)) --- $ set pathGraph newGraph --- $ set pathGraphP newGraphPairs --- $ snd (placeSlideDoor False c cond a b speed w) --- where --- bid = IM.newKey $ _buttons w --- cond w' = BtNoLabel == _btState (_buttons w' IM.! bid) --- bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid} --- (newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg a b)) --- $ _pathGraphP w --- newGraph = pairsToGraph dist newGraphPairs --- insertPoint pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp] --- eff w' = over pathGraphP (removedPairs ++) --- . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w' --- f (x,y) = (x,y,dist x y) + wlids = take 4 [wlid ..] + wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls + addWalls = + insertStructureWalls + (`DoorPart` isauto) + wl + (map fst pairs) + drid + wlid +-- addDoorWalls w' = foldl' (addDoorWall isauto eo drid wl) w' $ zip wlids pairs diff --git a/src/Dodge/Room/Airlock.hs b/src/Dodge/Room/Airlock.hs index 13ad22626..5b83726b6 100644 --- a/src/Dodge/Room/Airlock.hs +++ b/src/Dodge/Room/Airlock.hs @@ -35,8 +35,8 @@ decontamRoom i = & rmPmnts .~ [ pContID (PS (V2 (-35) 50) (negate $ pi / 2)) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) $ \btid -> Just $ - putDoubleDoorThen False switchWallObs thewall (WdBlNegate $ WdBlBtOn btid) 1 (V2 0 20) (V2 40 20) 2 $ - \_ _ -> Just $ putDoubleDoor False switchWallObs thewall (WdBlBtOn btid) (V2 0 80) (V2 40 80) 2 + putDoubleDoorThen False thewall (WdBlNegate $ WdBlBtOn btid) 1 (V2 0 20) (V2 40 20) 2 $ + \_ _ -> Just $ putDoubleDoor False 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,6 @@ decontamRoom i = pmnt <- gw ^? genPmnt . ix i return $ putDoubleDoor False - switchWallObs defaultDoorWall (cond pmnt) (V2 (-10) 35) @@ -79,8 +78,8 @@ airlock0 = , _rmPmnts = [ pContID (PS (V2 (-35) 50) (negate $ pi / 2)) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) $ \btid -> Just $ - putDoubleDoorThen False switchWallObs thewall (WdBlNegate $ WdBlBtOn btid) 1 (V2 0 20) (V2 40 20) 2 $ - \_ _ -> Just $ putDoubleDoor False switchWallObs thewall (WdBlBtOn btid) (V2 0 80) (V2 40 80) 2 + putDoubleDoorThen False thewall (WdBlNegate $ WdBlBtOn btid) 1 (V2 0 20) (V2 40 20) 2 $ + \_ _ -> Just $ putDoubleDoor False 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) diff --git a/src/Dodge/Room/Door.hs b/src/Dodge/Room/Door.hs index a221924ca..74116cd5e 100644 --- a/src/Dodge/Room/Door.hs +++ b/src/Dodge/Room/Door.hs @@ -42,5 +42,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 False - switchWallObs defaultDoorWall (cond pmnt) (V2 0 20) (V2 40 20) 2 + defaultDoorWall (cond pmnt) (V2 0 20) (V2 40 20) 2 cond pmnt = WdTrig $ fromJust (_plMID pmnt) diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index c9a7ef123..0706a594c 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -48,8 +48,8 @@ twinSlowDoorRoom w h x = , _rmPath = mempty , _rmPmnts = [ pContID (PS (V2 0 (h -5)) pi) (PutButton $ makeButton col NoWorldEffect) $ - \btid -> jsps0J (PutSlideDr False (thedoor btid) thewall switchWallObs 1 (V2 x 1) (V2 x h)) $ - ps0 (PutSlideDr False (thedoor btid) thewall switchWallObs 1 (V2 (- x) 1) (V2 (- x) h)) $ + \btid -> jsps0J (PutSlideDr False (thedoor btid) thewall 1 (V2 x 1) (V2 x h)) $ + ps0 (PutSlideDr False (thedoor btid) thewall 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 ] @@ -138,7 +138,6 @@ addButtonSlowDoor x h rm = do (rprBool (isUnusedLnkType InLink)) $ \btplmnt -> Just $ putDoubleDoorThen False - switchWallObs thewall (WdBlBtOn $ fromJust $ _plMID btplmnt) 30 diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index f44bb5df5..6e7d74492 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -328,8 +328,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 False (thedoor btid) thewall switchWallObs 1 (V2 (-21) 0) (V2 0 0)) $ - sPS (V2 0 (d -10)) 0 (PutSlideDr False (thedoor btid) thewall switchWallObs 1 (V2 21 0) (V2 0 0)) + jspsJ (V2 0 (d -10)) 0 (PutSlideDr False (thedoor btid) thewall 1 (V2 (-21) 0) (V2 0 0)) $ + sPS (V2 0 (d -10)) 0 (PutSlideDr False (thedoor btid) thewall 1 (V2 21 0) (V2 0 0)) ] --thewall = switchWallCol col thewall = defaultDoorWall