From 1990558985b8dc3d33bd3ba70bb043e5fea2daef Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 28 Sep 2021 01:48:03 +0100 Subject: [PATCH] Refactor doors --- src/Dodge/Data.hs | 14 ++++- src/Dodge/Default/Wall.hs | 2 + src/Dodge/Default/World.hs | 1 + src/Dodge/LevelGen.hs | 7 +-- src/Dodge/LevelGen/AutoDoor.hs | 12 ++++- src/Dodge/LevelGen/Data.hs | 1 - src/Dodge/LevelGen/DoorPane.hs | 1 + src/Dodge/LevelGen/MoveDoor.hs | 6 +-- src/Dodge/LevelGen/TriggerDoor.hs | 89 +++++++++++++++++++++---------- src/Dodge/Room/LongDoor.hs | 13 +++-- src/Dodge/Room/NoNeedWeapon.hs | 4 +- src/Dodge/Update.hs | 4 ++ src/Shader/Poke.hs | 2 +- 13 files changed, 105 insertions(+), 51 deletions(-) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index cc24b3b8f..e04c87211 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -59,6 +59,7 @@ data World = World , _props :: IM.IntMap Prop , _particles :: ![Particle] , _walls :: !(IM.IntMap Wall) + , _doors :: IM.IntMap Door' , _wallsZone :: Zone (IM.IntMap Wall) , _forceFields :: IM.IntMap ForceField , _floorItems :: IM.IntMap FloorItem @@ -237,6 +238,7 @@ data CrMvType } data WorldState = DoorNumOpen Int + | DoorNumOpening Int | CrNumAlive Int deriving (Eq,Ord) data Button = Button @@ -529,7 +531,15 @@ data Prop , _pjTimer :: Int } data Either3 a b c = E3x1 a | E3x2 b | E3x3 c - +data Door' = Door' + { _drID :: Int + , _drWallIDs :: [Int] + , _drStatus :: DoorStatus + , _drTrigger :: World -> Bool + , _drMech :: Door' -> World -> World + } +data DoorStatus = DoorOpen | DoorClosed | DoorHalfway + deriving (Eq, Ord, Show) data Wall = Wall { _wlLine :: (Point2,Point2) @@ -537,6 +547,7 @@ data Wall , _wlColor :: Color , _wlSeen :: Bool , _wlIsSeeThrough :: Bool + , _wlPathable :: Bool } | BlockAutoDoor { _wlLine :: (Point2,Point2) @@ -761,6 +772,7 @@ makeLenses ''Action makeLenses ''CrGroupParams makeLenses ''CrMvType makeLenses ''Intention +makeLenses ''Door' numColor :: Int -> Color numColor 0 = toV4 (1,0,0,1) numColor 1 = toV4 (0,1,0,1) diff --git a/src/Dodge/Default/Wall.hs b/src/Dodge/Default/Wall.hs index d5e23a1b9..953a4fa60 100644 --- a/src/Dodge/Default/Wall.hs +++ b/src/Dodge/Default/Wall.hs @@ -12,6 +12,7 @@ defaultWall = Wall , _wlColor = greyN 0.6 , _wlSeen = False , _wlIsSeeThrough = False + , _wlPathable = False } {- Indestructible see-through wall. -} defaultCrystalWall :: Wall @@ -21,6 +22,7 @@ defaultCrystalWall = Wall , _wlColor = withAlpha 0.5 aquamarine , _wlSeen = False , _wlIsSeeThrough = True + , _wlPathable = False } {- Door that opens on approach. Pathable. -} diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index 672e1cefa..f88c63539 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -36,6 +36,7 @@ defaultWorld = World , _props = IM.empty , _particles = [] , _walls = IM.empty + , _doors = IM.empty , _wallsZone = Zone IM.empty , _forceFields = IM.empty , _floorItems = IM.empty diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 2b27fe208..fbcbeb1da 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -83,18 +83,15 @@ placeSpot ps w = case _psType ps of where mapBoth fn (x,y) = (fn x, fn y) PutDoubleDoor col f a b speed - -> putDoubleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w + -> putDoubleDoor False col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w PutSingleDoor col f a b speed - -> putSingleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w + -> putSingleDoor False col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w PutAutoDoor a b -> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w PutBlock (hp:hps) col ps' -> putBlock (map (shiftPointBy (p,rot)) ps') hp col False hps w PutBlock{} -> error "messed up block placement somehow" PutBtDoor c bp f a b speed -> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot) (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w - PutSwitchDoor c bp f a b speed - -> addSwitchDoor c (shiftPointBy (p,rot) bp) (f + rot) - (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w PutLineBlock wl width depth a b -> putLineBlock wl width depth (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w PutWall { _pwPoly = ps', _pwWall = wl } -> rmCrossPaths $ over walls (addWalls (q:qs) wl) w diff --git a/src/Dodge/LevelGen/AutoDoor.hs b/src/Dodge/LevelGen/AutoDoor.hs index fe2454bac..513a6fef6 100644 --- a/src/Dodge/LevelGen/AutoDoor.hs +++ b/src/Dodge/LevelGen/AutoDoor.hs @@ -10,6 +10,7 @@ import Dodge.Base import Dodge.Creature.Property --import Dodge.LevelGen.MoveDoor import Dodge.LevelGen.DoorPane +import Dodge.LevelGen.TriggerDoor --import Geometry import Picture import Geometry.Data @@ -26,7 +27,16 @@ addAutoDoor -> Point2 -- ^ Right point (though the two points should be symmetric) -> World -> World -addAutoDoor a b = over walls (autoDoorAt a b) +addAutoDoor a b = putDoubleDoor True (dim yellow) cond a b 3 + where + cond = any (crNearSeg 40 a b) . IM.filter isAnimate . _creatures + +addAutoDoor' + :: Point2 -- ^ Left point + -> Point2 -- ^ Right point (though the two points should be symmetric) + -> World + -> World +addAutoDoor' a b = over walls (autoDoorAt a b) autoDoorAt :: Point2 -- ^ Left point diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index 717972db2..fee9a47ba 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -39,7 +39,6 @@ data PSType = PutCrit {_unPutCrit :: Creature} | PutSingleDoor Color (World -> Bool) Point2 Point2 Float | PutDoor Color (World -> Bool) [(Point2,Point2)] | PutBtDoor Color Point2 Float Point2 Point2 Float - | PutSwitchDoor Color Point2 Float Point2 Point2 Float | RandPS (State StdGen PSType) | PutForeground Shape | PutNothing diff --git a/src/Dodge/LevelGen/DoorPane.hs b/src/Dodge/LevelGen/DoorPane.hs index be730f9c9..a17bce744 100644 --- a/src/Dodge/LevelGen/DoorPane.hs +++ b/src/Dodge/LevelGen/DoorPane.hs @@ -2,6 +2,7 @@ module Dodge.LevelGen.DoorPane ( linearPane , mkDoubleDoor , mkSingleDoor + , rectanglePairs ) where import Dodge.Data import Dodge.LevelGen.MoveDoor diff --git a/src/Dodge/LevelGen/MoveDoor.hs b/src/Dodge/LevelGen/MoveDoor.hs index e5b14e949..b2d52b498 100644 --- a/src/Dodge/LevelGen/MoveDoor.hs +++ b/src/Dodge/LevelGen/MoveDoor.hs @@ -4,6 +4,7 @@ module Dodge.LevelGen.MoveDoor , zoneps , moveDoorToward , addSoundToDoor + , changeZonedWall ) where import Dodge.Data import Dodge.Data.SoundOrigin @@ -28,10 +29,7 @@ mvPs !speed (!ex,!ey) (!sx,!sy) = (mvP speed ex sx,mvP speed ey sy) moveDoorToward :: Float -> (Point2,Point2) -> Wall -> Wall {-# INLINE moveDoorToward #-} -moveDoorToward speed (ex,ey) wls = wls & wlLine %~ mvPs speed (ex,ey) ---moveDoorToward !speed !(!ex,!ey) wls = wls & wlLine %~ bimap (f ex) (f ey) --- where --- f !p = mvPointTowardAtSpeed speed p +moveDoorToward speed (ex,ey) = wlLine %~ mvPs speed (ex,ey) zoneps :: (Point2, Point2) -> [(Int,Int)] {-# INLINE zoneps #-} diff --git a/src/Dodge/LevelGen/TriggerDoor.hs b/src/Dodge/LevelGen/TriggerDoor.hs index f998cfd6f..075e58e0b 100644 --- a/src/Dodge/LevelGen/TriggerDoor.hs +++ b/src/Dodge/LevelGen/TriggerDoor.hs @@ -4,7 +4,6 @@ module Dodge.LevelGen.TriggerDoor , putDoubleDoor , putSingleDoor , addButtonDoor - , addSwitchDoor ) where import Dodge.Data import Dodge.Base @@ -17,6 +16,9 @@ import Picture import Geometry import qualified DoubleStack as DS import qualified IntMapHelp as IM +import Dodge.SoundLogic +import Dodge.SoundLogic.LoadSound +import Dodge.Data.SoundOrigin import Data.List import Data.Maybe @@ -30,7 +32,7 @@ addButtonDoor c btp btr a b speed w $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph)) $ set pathGraph newGraph $ set pathGraphP newGraphPairs - $ putDoubleDoor c cond a b speed w + $ putDoubleDoor False c cond a b speed w where bid = IM.newKey $ _buttons w cond w' = BtNoLabel == _btState (_buttons w' IM.! bid) @@ -42,26 +44,6 @@ addButtonDoor c btp btr a b speed w eff w' = over pathGraphP (removedPairs ++) . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w' f (x,y) = (x,y,dist x y) --- this has been repeated at least three times: TO BE UNIFIED, REFACTORED -addSwitchDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> Float -> World -> World -addSwitchDoor c btp btr a b speed w = over buttons (IM.insert bid bt) - $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph)) - $ set pathGraph newGraph - $ set pathGraphP newGraphPairs - $ putDoubleDoor c cond a b speed w - where - bid = IM.newKey $ _buttons w - cond w' = BtOn == _btState (_buttons w' IM.! bid) - bt = (makeSwitch c red openDoor closeDoor) {_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] - openDoor w' = over pathGraphP (removedPairs ++) - . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w' - f (x,y) = (x,y,dist x y) - closeDoor w' = over pathGraphP (\\ removedPairs) - . over pathGraph (flip run_ $ delMapEdgesM removedPairs) $ w' putDoor :: Color @@ -76,19 +58,68 @@ putDoor c cond pss = over walls triggerDoor where is = [IM.newKey wls..] -putDoubleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World -putDoubleDoor c cond a b speed = over walls triggerDoubleDoor +putDoubleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World +putDoubleDoor isPathable col cond a b speed + = putSingleDoor isPathable col cond a c speed + . putSingleDoor isPathable col cond b c speed + where + c = 0.5 *.* (a +.+ b) + +putDoubleDoor' :: Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World +putDoubleDoor' c cond a b speed = over walls triggerDoubleDoor where triggerDoubleDoor wls = IM.union wls $ IM.fromList $ zip is $ mkDoubleDoor c False cond a b speed is where is = [IM.newKey wls..] -putSingleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World -putSingleDoor c cond a b speed = over walls putTheDoor +doorMechanism :: Int -> Float -> [(Int,(Point2,Point2),(Point2,Point2))] -> Door' -> World -> World +doorMechanism drid speed wlidOpCps dr w + | toOpen && not (dstatus == DoorOpen) = playSound . setStatus $ foldl' doOpen w wlidOpCps + | not toOpen && not (dstatus == DoorClosed) = playSound . setStatus $ foldl' doClose w wlidOpCps + | otherwise = w where - putTheDoor wls = IM.union wls $ IM.fromList $ zip is $ mkSingleDoor c False cond a b speed is - where - is = [IM.newKey wls..] + playSound = soundContinue (WallSound drid) (fst cpos) slideDoorS (Just 1) + setStatus + | isOpen = doors . ix drid . drStatus .~ DoorOpen + | isClosed = doors . ix drid . drStatus .~ DoorClosed + | otherwise = doors . ix drid . drStatus .~ DoorHalfway + (wlid',opos,cpos) = head wlidOpCps + wlpos = _wlLine $ _walls w IM.! wlid' + isOpen = dist (fst wlpos) (fst opos) < 1 + isClosed = dist (fst wlpos) (fst cpos) < 1 + toOpen = _drTrigger dr w + dstatus = _drStatus dr + doOpen w' (wlid,openpos,cp) = w' + & walls . ix wlid %~ moveDoorToward speed openpos + & (\w'' -> foldr (changeZonedWall (moveDoorToward speed openpos) wlid) w'' (zoneps cp)) + doClose w' (wlid,_,cp) = w' & walls . ix wlid %~ moveDoorToward speed cp + & (\w'' -> foldr (changeZonedWall (moveDoorToward speed cp) wlid) w'' (zoneps cp)) + +putSingleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World +putSingleDoor isPathable col cond a b speed w = addWalls w + & doors %~ addDoor + where + drid = IM.newKey $ _doors w + addDoor = IM.insert drid $ Door' + { _drID = drid + , _drWallIDs = wlids + , _drStatus = DoorClosed + , _drTrigger = cond + , _drMech = doorMechanism drid speed (zip3 wlids shiftedPairs pairs) + } + addWalls w' = foldl' addWall w' $ zip wlids pairs + addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid Wall + { _wlLine = wlps + , _wlID = wlid + , _wlColor = col + , _wlSeen = False + , _wlIsSeeThrough = False + , _wlPathable = isPathable + } + pairs = rectanglePairs 9 a b + shiftedPairs = map (bimap shiftLeft shiftLeft) pairs + shiftLeft = (+.+ (a -.- b)) + wlids = take 4 [IM.newKey $ _walls w ..] mkTriggerDoor :: Color diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index 5a1a18a56..b845a09c8 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -31,7 +31,7 @@ twinSlowDoorRoom -> Float -- ^ Half height -> Float -- ^ Inner width -> Room -twinSlowDoorRoom drID w h x = defaultRoom +twinSlowDoorRoom drid w h x = defaultRoom { _rmPolys = ps , _rmLinks = [ (V2 w (h/2) , negate $ pi/2) @@ -46,10 +46,10 @@ twinSlowDoorRoom drID w h x = defaultRoom , sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2 x 1) (V2 x h) 1 , sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2 (-x) 1) (V2 (-x) h) 1 , sPS (V2 0 (h-5)) pi $ PutButton $ makeSwitch col red - (over worldState (M.insert (DoorNumOpen drID) True)) - (over worldState (M.insert (DoorNumOpen drID) False)) --- , sPS (V2 0 (h-1)) 0 $ PutLS (colorLightAt (V3 0.75 0 0) (V3 0 0 lampHeight) 0) (lampPic lampHeight) --- , sPS (V2 0 (h-1)) 0 $ PutProp $ lampCover lampHeight + (worldState %~ M.insert (DoorNumOpen drid) True ) + (worldState %~ M.insert (DoorNumOpen drid) False) + , sPS (V2 0 (h-1)) 0 $ PutLS (colorLightAt (V3 0.75 0 0) (V3 0 0 lampHeight) 0) (lampPic lampHeight) + , sPS (V2 0 (h-1)) 0 $ PutProp $ lampCover lampHeight ] , _rmBound = ps , _rmName = "twinSlowDoorRoom" @@ -60,7 +60,7 @@ twinSlowDoorRoom drID w h x = defaultRoom [rectNSWE h 0 (-w) w ,rectNSWE 20 (-h) (negate x) x ] - cond w' = or $ M.lookup (DoorNumOpen drID) (_worldState w') + cond w' = or $ M.lookup (DoorNumOpen drid) (_worldState w') col = dim $ dim $ bright red twinSlowDoorChasers @@ -104,7 +104,6 @@ slowDoorRoom = do 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 - -- ,PutSwitchDoor (dim $ light red) butPos butRot (0,h) (x,h) ] fmap connectRoom (filterLinks cond =<< diff --git a/src/Dodge/Room/NoNeedWeapon.hs b/src/Dodge/Room/NoNeedWeapon.hs index c7870952a..c3cf47843 100644 --- a/src/Dodge/Room/NoNeedWeapon.hs +++ b/src/Dodge/Room/NoNeedWeapon.hs @@ -27,7 +27,7 @@ centerVaultExplosiveExit :: RandomGen g => Int -- ^ Door id -> State g Room -centerVaultExplosiveExit drID = do +centerVaultExplosiveExit drid = do cr <- takeOne [miniGunCrit, autoCrit] let extraPS = [sPS (V2 0 175) 0 $ PutCrit explosiveBarrel @@ -36,5 +36,5 @@ centerVaultExplosiveExit drID = do ,sPS (V2 (-4) 195) 0 $ PutCrit explosiveBarrel ,sPS (V2 0 0) 0 $ PutCrit (cr & crState . crDropsOnDeath .~ DropAll) ] - r <- centerVaultRoom drID 200 200 50 <&> rmPS %~ (extraPS ++) + r <- centerVaultRoom drid 200 200 50 <&> rmPS %~ (extraPS ++) randomiseLinksBy shuffleTail r <&> rmLinks %~ take 2 diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index f7f982d24..d2061f65c 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -61,6 +61,7 @@ functionalUpdate w = case _menuLayers w of . ifConfigWallRotate . simpleCrSprings . zoneCreatures + . updateDoors . updateWalls . resetWorldEvents . dbArg _worldEvents @@ -147,6 +148,9 @@ Apply door mechanisms. -} updateWalls :: World -> World updateWalls w = IM.foldl' (flip $ fromMaybe id . (^? doorMech)) w (_walls w) +updateDoors :: World -> World +updateDoors w = IM.foldl' (\w' dr -> _drMech dr dr w') w (_doors w) + ppEvents :: World -> World ppEvents w = IM.foldl' (flip $ \pp w' -> _ppEvent pp pp w') w $ _pressPlates w diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index 95d138147..26dc469cd 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -166,7 +166,7 @@ topPrismIndices n = concatMap f [1..n-2] -- triangles on top face ++ concatMap g [0..n-2] -- other triangles on sides where f x = [0,2*x,2*x+2] - f' x = [1,2*x+1,2*x+3] + f' x = [1,2*x+3,2*x+1] g x = [2*x,2*x+1,2*x+3 ,2*x,2*x+3,2*x+2]