From 9eda8c81a9db8d3229dd1ba9df5af8648f92db77 Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 2 Nov 2021 11:04:23 +0000 Subject: [PATCH] Unify more doors --- src/Dodge/Floor.hs | 5 +++ src/Dodge/LevelGen.hs | 11 ++---- src/Dodge/LevelGen/Data.hs | 4 +- src/Dodge/LevelGen/TriggerDoor.hs | 66 +++++++++++++++---------------- src/Dodge/Placements.hs | 16 +++++--- src/Dodge/Room/Airlock.hs | 9 ++--- src/Dodge/Room/LongDoor.hs | 16 ++++++-- src/Dodge/Room/Placement.hs | 4 +- src/Dodge/Room/Procedural.hs | 4 +- 9 files changed, 72 insertions(+), 63 deletions(-) diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 386f40667..9d0490b75 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -35,6 +35,11 @@ initialRoomTree = do t = treeFromTrunk [[StartRoom] ,[Corridor] + ,[Corridor] + ,[SpecificRoom slowDoorRoom ] + ,[Corridor] + ,[Corridor] + ,[Corridor] ,[SpecificRoom roomCCrits] ,[Corridor] ,[AirlockAno] diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 95c6ee553..5be5883b6 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -54,16 +54,11 @@ placeSpotID ps w = case _psType ps of RandPS rgen -> placeSpotID (set psType evaluatedType ps) (set randGen g w) where (evaluatedType, g) = runState rgen (_randGen w) - PutDoor col f pss -> putDoor col f (map (mapBoth doShift) pss) w - where - mapBoth fn (x,y) = (fn x, fn y) - PutSingleDoor col f a b speed - -> placeSingleDoor False col f (doShift a) (doShift b) speed w - --PutAutoDoor a b -> (,) 0 $ placeAutoDoor (doShift a) (doShift b) w + PutDoor col f pss -> putDoor col f (map (bimap doShift doShift) pss) w + PutSlideDoor pathing col f a b speed + -> placeSlideDoor pathing col f (doShift a) (doShift b) speed w PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w PutBlock{} -> error "messed up block placement somehow" - PutBtDoor c bp f a b speed -> addButtonDoor c (doShift bp) (f + rot) - (doShift a) (doShift b) speed w PutLineBlock wl width depth a b -> placeLineBlock wl width depth (doShift a) (doShift b) w PutWall { _pwPoly = ps', _pwWall = wl } -> (0,rmCrossPaths $ over walls (addWalls qs wl) w) diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index 2b7858c91..ea8d027d0 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -17,13 +17,11 @@ data PSType = PutCrit {_unPutCrit :: Creature} | PutProp Prop | PutFlIt Item | PutPressPlate PressPlate - -- | PutAutoDoor Point2 Point2 | PutBlock [Int] Color [Point2] | PutLineBlock Wall Float Float Point2 Point2 | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall } - | PutSingleDoor Color (World -> Bool) Point2 Point2 Float + | PutSlideDoor Bool Color (World -> Bool) Point2 Point2 Float | PutDoor Color (World -> Bool) [(Point2,Point2)] - | PutBtDoor Color Point2 Float Point2 Point2 Float | RandPS (State StdGen PSType) | PutForeground Shape | PutNothing diff --git a/src/Dodge/LevelGen/TriggerDoor.hs b/src/Dodge/LevelGen/TriggerDoor.hs index 98693b4c0..b20e15c6d 100644 --- a/src/Dodge/LevelGen/TriggerDoor.hs +++ b/src/Dodge/LevelGen/TriggerDoor.hs @@ -1,15 +1,15 @@ --{-# LANGUAGE BangPatterns #-} module Dodge.LevelGen.TriggerDoor ( putDoor - , placeSingleDoor - , addButtonDoor + , placeSlideDoor + --, addButtonDoor ) where import Dodge.Data -import Dodge.Base -import Dodge.Zone +--import Dodge.Base +--import Dodge.Zone import Dodge.Default.Wall -import Dodge.LevelGen.Switch -import Dodge.LevelGen.Pathing +--import Dodge.LevelGen.Switch +--import Dodge.LevelGen.Pathing import Dodge.LevelGen.MoveDoor import Dodge.LevelGen.DoorPane import Picture @@ -20,32 +20,10 @@ import Dodge.SoundLogic.LoadSound import Dodge.Data.SoundOrigin import Data.List -import Data.Maybe +--import Data.Maybe import Control.Lens -import Data.Graph.Inductive hiding ((&)) +--import Data.Graph.Inductive hiding ((&)) import qualified Data.IntSet as IS - --- probably don't have to rebuild the entire graph, oh well -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 (placeSingleDoor 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) - putDoor :: Color -> (World -> Bool) -- ^ Opening condition @@ -122,10 +100,10 @@ doorMechanism drid speed wlidOpCps dr w & walls . ix wlid %~ moveDoorToward speed p & (\w'' -> foldr (changeZonedWall (moveDoorToward speed p) wlid) w'' (zoneps zp)) -placeSingleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World +-- TODO cut pathing if not pathable, reset when opened +placeSlideDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> (Int, World) -placeSingleDoor isPathable col cond a b speed w = (drid, addWalls w - & doors %~ addDoor) +placeSlideDoor isPathable col cond a b speed w = (drid, addWalls w & doors %~ addDoor) where drid = IM.newKey $ _doors w addDoor = IM.insert drid $ Door @@ -148,3 +126,25 @@ placeSingleDoor isPathable col cond a b speed w = (drid, addWalls w shiftedPairs = map (bimap shiftLeft shiftLeft) pairs shiftLeft = (+.+ (a -.- b)) wlids = take 4 [IM.newKey $ _walls w ..] +-- 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) diff --git a/src/Dodge/Placements.hs b/src/Dodge/Placements.hs index 83b215c38..c5d47ab2a 100644 --- a/src/Dodge/Placements.hs +++ b/src/Dodge/Placements.hs @@ -1,5 +1,6 @@ module Dodge.Placements - ( putDoubleDoorThen + ( putDoubleDoor + , putDoubleDoorThen , putAutoDoor ) where @@ -11,13 +12,18 @@ import Dodge.LevelGen.Data import Dodge.Creature.Property import qualified Data.IntMap.Strict as IM -putDoubleDoorThen :: Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> Maybe Placement -> Placement -putDoubleDoorThen col cond a b speed mayp = ps0j (PutSingleDoor col cond a half speed) - $ Placement (PS (V2 0 0) 0 (PutSingleDoor col cond b half speed)) $ const mayp + +putDoubleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> Placement +putDoubleDoor pathing col cond a b speed = putDoubleDoorThen pathing col cond a b speed Nothing + +putDoubleDoorThen :: Bool -> Color -> (World -> Bool) + -> Point2 -> Point2 -> Float -> Maybe Placement -> Placement +putDoubleDoorThen pathing col cond a b speed mayp = ps0j (PutSlideDoor pathing col cond a half speed) + $ Placement (PS (V2 0 0) 0 (PutSlideDoor pathing col cond b half speed)) $ const mayp where half = 0.5 *.* (a +.+ b) putAutoDoor :: Point2 -> Point2 -> Placement -putAutoDoor a b = putDoubleDoorThen (dim yellow) cond a b 3 Nothing +putAutoDoor a b = putDoubleDoorThen True (dim yellow) cond a b 3 Nothing where cond = any (crNearSeg 40 a b) . IM.filter isAnimate . _creatures diff --git a/src/Dodge/Room/Airlock.hs b/src/Dodge/Room/Airlock.hs index dfc3b125a..78335a346 100644 --- a/src/Dodge/Room/Airlock.hs +++ b/src/Dodge/Room/Airlock.hs @@ -19,8 +19,7 @@ import System.Random import Control.Monad.State {- | A passage with a switch that opens forward access while closing backwards access. -} airlock :: RandomGen g => State g Room ---airlock = takeOne [airlock0,airlock90,airlockCrystal] -airlock = takeOne [airlock0] +airlock = takeOne [airlock0,airlock90,airlockCrystal] {- | Straight airlock -} airlock0 :: Room airlock0 = defaultRoom @@ -29,10 +28,8 @@ airlock0 = defaultRoom , _rmPath = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20 5) ] , _rmPS = [Placement (PS (V2 (-35) 50) (negate $ pi/2) $ PutButton $ makeSwitch col red id id) - $ \btid -> Just $ putDoubleDoorThen col (not . cond' btid) (V2 (-1) 20) (V2 41 20) 2 - $ Just $ putDoubleDoorThen col (cond' btid) (V2 (-1) 80) (V2 41 80) 2 Nothing - -- $ \btid -> jspsJ (V2 0 0) 0 (PutDoubleDoor col (not . cond' btid) (V2 1 20) (V2 39 20) 2) - -- $ sPS (V2 0 0) 0 $ PutDoubleDoor col (cond' btid) (V2 1 80) (V2 39 80) 2 + $ \btid -> Just $ putDoubleDoorThen False col (not . cond' btid) (V2 (-1) 20) (V2 41 20) 2 + $ Just $ putDoubleDoorThen False col (cond' btid) (V2 (-1) 80) (V2 41 80) 2 Nothing ,mountedLightI 70 (V2 (-2) 30) (V2 (-2) 70) ,sps0 $ PutForeground $ thinHighBar 75 (V2 40 50) (V2 (-1) 50) ] diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index 107a5eb1c..e7cfb1035 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -16,6 +16,7 @@ import Dodge.RandomHelp import Dodge.Creature.Inanimate import Dodge.Creature import Dodge.LightSources.Lamp +import Dodge.Placements import Picture import Geometry @@ -40,8 +41,8 @@ twinSlowDoorRoom w h x = defaultRoom , _rmPath = [] , _rmPS = [ Placement (PS (V2 0 (h-5)) pi $ PutButton $ makeButton col id) - $ \btid -> jsps0J (PutSingleDoor col (cond' btid) (V2 x 1) (V2 x h) wlSpeed) - $ ps0 (PutSingleDoor col (cond' btid) (V2 (-x) 1) (V2 (-x) h) wlSpeed) + $ \btid -> jsps0J (PutSlideDoor False col (cond' btid) (V2 x 1) (V2 x h) wlSpeed) + $ ps0 (PutSlideDoor False col (cond' btid) (V2 (-x) 1) (V2 (-x) h) wlSpeed) $ \did -> jps0 (PutLS (colorLightAt (V3 0.75 0 0) (V3 0 (h-1) lampHeight) 0)) $ \lsid -> jsps0 $ PutProp $ addColorChange lsid did $ lampCoverWhen (drmoving did) (V2 0 (h-1)) lampHeight ] @@ -104,15 +105,22 @@ slowDoorRoom = do pillars <- takeOne [pillarsa, pillarsb, pillarsc] let cond x' = (sndV2 . fst) x' > h + 40 cond2 x' = (sndV2 . fst) x' < h - 40 - but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (V2 0 h) (V2 x h) 2 + but <- takeOne [butDoor x h butPos butRot ] fmap connectRoom (filterLinks cond =<< changeLinkTo cond2 - (set rmPS ([sPS (V2 0 0) 0 but] ++ crits ++ pillars ++ barrels ++ lsources) + (set rmPS ([but] ++ crits ++ pillars ++ barrels ++ lsources) $ roomRectAutoLinks x y ) ) + where + butDoor x h bpos brot + = ps0 (PutButton $ (makeButton col id) {_btPos = bpos, _btRot = brot}) + $ \btid -> Just $ putDoubleDoor False col (cond' btid) (V2 0 h) (V2 x h) 2 + col = dim $ light red + cond' btid w = w ^? buttons . ix btid . btState /= Just BtOff + --but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (V2 0 h) (V2 x h) 2 randC1 :: PSType randC1 = RandPS $ takeOne $ map PutCrit $ armourChaseCrit : replicate 50 chaseCrit diff --git a/src/Dodge/Room/Placement.hs b/src/Dodge/Room/Placement.hs index 8eb02f362..65453f97d 100644 --- a/src/Dodge/Room/Placement.hs +++ b/src/Dodge/Room/Placement.hs @@ -177,8 +177,8 @@ putBlockN a x b y = [ blockLine (V2 a b) (V2 a y) switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement switchDoor btpos btrot dra drb col = Placement (PS btpos btrot $ PutButton $ makeSwitch col red id id) - $ \btid -> jsps0J (PutSingleDoor col (cond btid) dra drc 2) - $ sps0 (PutSingleDoor col (cond btid) drb drc 2) + $ \btid -> jsps0J (PutSlideDoor False col (cond btid) dra drc 2) + $ sps0 (PutSlideDoor False col (cond btid) drb drc 2) where drc = 0.5 *.* (dra +.+ drb) cond btid w' = _btState (_buttons w' IM.! btid) == BtOn diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 0b8c9ae45..aa2c5dcd4 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -232,7 +232,7 @@ centerVaultRoom w h d = do col = dim $ dim $ bright red theDoor = [ Placement (PS (V2 35 (d+4)) 0 $ PutButton $ makeSwitch col red id id) - $ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSingleDoor col (cond' btid) (V2 (-21) 0) (V2 0 0) 2) - $ sPS (V2 0 (d-10)) 0 (PutSingleDoor col (cond' btid) (V2 21 0) (V2 0 0) 2) + $ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDoor False col (cond' btid) (V2 (-21) 0) (V2 0 0) 2) + $ sPS (V2 0 (d-10)) 0 (PutSlideDoor False col (cond' btid) (V2 21 0) (V2 0 0) 2) ] cond' btid w' = _btState (_buttons w' IM.! btid) == BtOn