From d6a94ec4bc7c847cfd28638f4cde7fe850798c01 Mon Sep 17 00:00:00 2001 From: justin Date: Sun, 24 Jul 2022 20:36:27 +0100 Subject: [PATCH] Refactor doors --- src/Dodge/Block.hs | 5 +- src/Dodge/CreatureEffect.hs | 3 +- src/Dodge/Data.hs | 29 ++------ src/Dodge/Data/CreatureEffect.hs | 1 + src/Dodge/Data/Door.hs | 32 ++++++++- src/Dodge/Data/EnergyBall.hs | 1 + src/Dodge/Data/Flame.hs | 1 + src/Dodge/Data/Flare.hs | 3 +- src/Dodge/Data/MountedObject.hs | 9 +++ src/Dodge/Data/PathGraph.hs | 5 +- src/Dodge/Data/PosEvent.hs | 3 +- src/Dodge/Data/RadarBlip.hs | 3 +- src/Dodge/Data/RadarSweep.hs | 1 + src/Dodge/Data/Spark.hs | 1 + src/Dodge/Data/WorldEffect.hs | 11 +++ src/Dodge/Default/Door.hs | 7 +- src/Dodge/DrWdWd.hs | 76 ++++++++++++++++++++ src/Dodge/Placement/Instance/Door.hs | 19 +++-- src/Dodge/Placement/PlaceSpot/TriggerDoor.hs | 62 ++-------------- src/Dodge/Room/Airlock.hs | 22 +++--- src/Dodge/Room/Door.hs | 4 +- src/Dodge/Room/LongDoor.hs | 7 +- src/Dodge/Room/Procedural.hs | 3 +- src/Dodge/Update.hs | 3 +- src/Dodge/WorldBool.hs | 10 +++ 25 files changed, 186 insertions(+), 135 deletions(-) create mode 100644 src/Dodge/Data/MountedObject.hs create mode 100644 src/Dodge/DrWdWd.hs diff --git a/src/Dodge/Block.hs b/src/Dodge/Block.hs index abad28895..513e58575 100644 --- a/src/Dodge/Block.hs +++ b/src/Dodge/Block.hs @@ -1,4 +1,5 @@ module Dodge.Block where +import Dodge.DrWdWd import Dodge.Zoning.Wall import Dodge.Data import Dodge.Base.Collide @@ -70,7 +71,7 @@ maybeClearPath w (x,y,pe) destroyDoor :: Door -> World -> World destroyDoor dr w = w - & _drDeath dr dr + & doDrWdWd (_drDeath dr) dr & deleteWallIDs wlids & doors %~ IM.delete (_drID dr) & flip (foldr (wlDustAt awl)) (map (pos +.+) ps) @@ -94,5 +95,5 @@ stopPushing :: Maybe Int -> World -> World stopPushing mdrid w = fromMaybe w $ do drid <- mdrid dr <- w ^? doors . ix drid - return $ w & doors . ix drid . drMech .~ const id + return $ w & doors . ix drid . drMech .~ DrWdId & stopPushing (_drPushes dr) diff --git a/src/Dodge/CreatureEffect.hs b/src/Dodge/CreatureEffect.hs index 3a9842e6f..10e9fbf43 100644 --- a/src/Dodge/CreatureEffect.hs +++ b/src/Dodge/CreatureEffect.hs @@ -1,7 +1,7 @@ module Dodge.CreatureEffect where +import Dodge.Creature.Test import Dodge.Data import Geometry -import Dodge.Creature.Test import Dodge.Base.Collide import Dodge.Path import qualified IntMapHelp as IM @@ -47,6 +47,7 @@ doCrBl cb = case cb of CrCanShoot -> crCanShoot CrIsReloading -> crIsReloading CrIsAiming -> crIsAiming + CrIsAnimate -> isAnimate doMCrAc :: MCrAc -> Maybe Creature -> Action doMCrAc mca = case mca of diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 1808beaf8..4ab8dfcb6 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -83,7 +83,9 @@ module Dodge.Data , module Dodge.Data.Prop , module Dodge.Data.LinearShockwave , module Dodge.Data.TractorBeam + , module Dodge.Data.MountedObject ) where +import Dodge.Data.MountedObject import Dodge.Data.TractorBeam import Dodge.Data.LinearShockwave import Dodge.Data.Prop @@ -292,7 +294,7 @@ data World = World , _lSelect :: Point2 , _rSelect :: Point2 } --- deriving (Eq,Ord,Show,Read) + --deriving (Eq,Ord,Show,Read) data WorldHammer = SubInvHam | DoubleMouseHam @@ -456,28 +458,6 @@ data MachineType , _tuFireTime :: Int , _tuMCrID :: Maybe Int } -data Door = Door - { _drID :: Int - , _drWallIDs :: IS.IntSet - , _drStatus :: DoorStatus - , _drTrigger :: World -> Bool - , _drMech :: Door -> World -> World - , _drPos :: (Point2,Point2) - , _drOpenPos :: (Point2,Point2) - , _drClosePos :: (Point2,Point2) - , _drHP :: Int - , _drDeath :: Door -> World -> World - , _drSpeed :: Float - , _drPushedBy :: PushSource - , _drPushes :: Maybe Int - , _drMounts :: [MountedObject] - , _drObstructs :: [(Int,Int,PathEdge)] - , _drObstacleType :: EdgeObstacle - } -data MountedObject - = MountedLS Int - | MountedProp Int - deriving (Eq,Ord,Show) data EffectArguments = NoArguments {_cmdEffect :: [TerminalLine]} @@ -510,7 +490,7 @@ data PSType = PutCrit {_unPutCrit :: Creature} , _putStartPoint :: Point2, _putEndPoint :: Point2} | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall } | PutSlideDr Door Wall EdgeObstacle Float Point2 Point2 - | PutDoor Color EdgeObstacle (World -> Bool) [(Point2,Point2)] + | PutDoor Color EdgeObstacle WdBl [(Point2,Point2)] | RandPS (State StdGen PSType) | PutForeground ForegroundShape | PutDecoration Picture @@ -594,7 +574,6 @@ data InPlacement = InPlacement makeLenses ''World makeLenses ''FloorItem --makeLenses ''Particle -makeLenses ''Door makeLenses ''Terminal makeLenses ''Machine makeLenses ''MachineType diff --git a/src/Dodge/Data/CreatureEffect.hs b/src/Dodge/Data/CreatureEffect.hs index dd3192c2f..e7c02458a 100644 --- a/src/Dodge/Data/CreatureEffect.hs +++ b/src/Dodge/Data/CreatureEffect.hs @@ -29,6 +29,7 @@ data WdCrBl = WdCrTrue data CrBl = CrCanShoot | CrIsReloading | CrIsAiming + | CrIsAnimate deriving (Eq,Ord,Show,Read) data MCrAc = MCrNoAction diff --git a/src/Dodge/Data/Door.hs b/src/Dodge/Data/Door.hs index edc17646d..0a32566d4 100644 --- a/src/Dodge/Data/Door.hs +++ b/src/Dodge/Data/Door.hs @@ -1,11 +1,37 @@ ---{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} module Dodge.Data.Door where +import Dodge.Data.PathGraph +import Dodge.Data.MountedObject +import Geometry.Data +import Dodge.Data.WorldEffect +import qualified Data.IntSet as IS +import Control.Lens data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show,Read) data PushSource = PushesItself | PushedBy Int | NotPushed - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show,Read) +data Door = Door + { _drID :: Int + , _drWallIDs :: IS.IntSet + , _drStatus :: DoorStatus + , _drTrigger :: WdBl + , _drMech :: DrWdWd + , _drPos :: (Point2,Point2) + , _drOpenPos :: (Point2,Point2) + , _drClosePos :: (Point2,Point2) + , _drHP :: Int + , _drDeath :: DrWdWd + , _drSpeed :: Float + , _drPushedBy :: PushSource + , _drPushes :: Maybe Int + , _drMounts :: [MountedObject] + , _drObstructs :: [(Int,Int,PathEdge)] + , _drObstacleType :: EdgeObstacle + } + deriving (Eq,Ord,Show,Read) +makeLenses ''Door diff --git a/src/Dodge/Data/EnergyBall.hs b/src/Dodge/Data/EnergyBall.hs index 94b09fc4c..8e0ee1b8d 100644 --- a/src/Dodge/Data/EnergyBall.hs +++ b/src/Dodge/Data/EnergyBall.hs @@ -16,4 +16,5 @@ data EnergyBall = EnergyBall , _ebZ :: Float , _ebRot :: Float } + deriving (Eq,Ord,Show,Read) makeLenses ''EnergyBall diff --git a/src/Dodge/Data/Flame.hs b/src/Dodge/Data/Flame.hs index 2eecc842e..a2384164d 100644 --- a/src/Dodge/Data/Flame.hs +++ b/src/Dodge/Data/Flame.hs @@ -13,4 +13,5 @@ data Flame = Flame , _flZ :: Float , _flOriginalVel :: Point2 } + deriving (Eq,Ord,Show,Read) makeLenses ''Flame diff --git a/src/Dodge/Data/Flare.hs b/src/Dodge/Data/Flare.hs index 42bd0308c..5480516ac 100644 --- a/src/Dodge/Data/Flare.hs +++ b/src/Dodge/Data/Flare.hs @@ -4,7 +4,6 @@ module Dodge.Data.Flare where import Color import Geometry import Control.Lens - data Flare = MuzFlare { _flarePoly :: [Point2] @@ -18,5 +17,5 @@ data Flare , _flareTran3 :: Point3 , _flareTime :: Int } - + deriving (Eq,Ord,Show,Read) makeLenses ''Flare diff --git a/src/Dodge/Data/MountedObject.hs b/src/Dodge/Data/MountedObject.hs new file mode 100644 index 000000000..ce0b7d757 --- /dev/null +++ b/src/Dodge/Data/MountedObject.hs @@ -0,0 +1,9 @@ +--{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StrictData #-} +module Dodge.Data.MountedObject + where +data MountedObject + = MountedLS Int + | MountedProp Int + deriving (Eq,Ord,Show,Read) + diff --git a/src/Dodge/Data/PathGraph.hs b/src/Dodge/Data/PathGraph.hs index 7b8d6f4f4..310611a3a 100644 --- a/src/Dodge/Data/PathGraph.hs +++ b/src/Dodge/Data/PathGraph.hs @@ -12,19 +12,20 @@ data PathGraph = PathGraph , _pgNodeCount :: Int , _pgEdgeMap :: Map (V2 Point2) (Int,Int,PathEdge) } + deriving (Eq,Show,Read) data PathEdge = PathEdge {_peStart :: Point2 ,_peEnd :: Point2 ,_peDist :: Float ,_peObstacles :: Set.Set EdgeObstacle } - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show,Read) data EdgeObstacle = BlockObstacle | DoorObstacle | AutoDoorObstacle | WallObstacle - deriving (Eq,Ord,Show,Bounded,Enum) + deriving (Eq,Ord,Show,Read,Bounded,Enum) makeLenses ''PathGraph makeLenses ''PathEdge diff --git a/src/Dodge/Data/PosEvent.hs b/src/Dodge/Data/PosEvent.hs index f1ab4098f..26607be82 100644 --- a/src/Dodge/Data/PosEvent.hs +++ b/src/Dodge/Data/PosEvent.hs @@ -5,10 +5,11 @@ import Geometry.Data import Control.Lens data PosEventType = SparkSpawner - + deriving (Eq,Ord,Show,Read) data PosEvent = PosEvent { _pvType :: PosEventType , _pvTimer :: Int , _pvPos :: Point2 } + deriving (Eq,Ord,Show,Read) makeLenses ''PosEvent diff --git a/src/Dodge/Data/RadarBlip.hs b/src/Dodge/Data/RadarBlip.hs index b4bfaefe2..ef6bf49be 100644 --- a/src/Dodge/Data/RadarBlip.hs +++ b/src/Dodge/Data/RadarBlip.hs @@ -4,7 +4,6 @@ module Dodge.Data.RadarBlip where import Color import Geometry import Control.Lens - data RadarBlip = RadarBlip { _rbColor :: Color , _rbTime :: Int @@ -12,5 +11,5 @@ data RadarBlip = RadarBlip , _rbRad :: Float , _rbPos :: Point2 } - + deriving (Eq,Ord,Show,Read) makeLenses ''RadarBlip diff --git a/src/Dodge/Data/RadarSweep.hs b/src/Dodge/Data/RadarSweep.hs index 44a082972..bf0162ffb 100644 --- a/src/Dodge/Data/RadarSweep.hs +++ b/src/Dodge/Data/RadarSweep.hs @@ -11,4 +11,5 @@ data RadarSweep = RadarSweep , _rsObject :: Object , _rsTimer :: Int } + deriving (Eq,Ord,Show,Read) makeLenses ''RadarSweep diff --git a/src/Dodge/Data/Spark.hs b/src/Dodge/Data/Spark.hs index b910f191c..4f4c599da 100644 --- a/src/Dodge/Data/Spark.hs +++ b/src/Dodge/Data/Spark.hs @@ -13,4 +13,5 @@ data Spark = Spark , _skWidth :: Float , _skDamageType :: DamageType } + deriving (Eq,Ord,Show,Read) makeLenses ''Spark diff --git a/src/Dodge/Data/WorldEffect.hs b/src/Dodge/Data/WorldEffect.hs index f18841552..8256bf633 100644 --- a/src/Dodge/Data/WorldEffect.hs +++ b/src/Dodge/Data/WorldEffect.hs @@ -1,4 +1,5 @@ module Dodge.Data.WorldEffect where +import Dodge.Data.CreatureEffect import Sound.Data import Geometry.Data import Dodge.Data.SoundOrigin @@ -22,7 +23,17 @@ data MdWdWd = MdWdId deriving (Eq,Ord,Show,Read) data WdBl = WdTrig Int | WdBlDoorMoving Int + | WdBlConst Bool + | WdBlNegate WdBl + | WdBlCrFilterNearPoint Float Point2 CrBl + | WdBlBtOn Int + | WdBlBtNotOff Int deriving (Eq,Ord,Show,Read) data WdP2f = WdP2f0 | WdP2fDoorPosition Int deriving (Eq,Ord,Show,Read) +data DrWdWd = DrWdId + | DrWdMakeDoorDebris + | DrWdMechanismStepwise Int [Int] [(Point2,Point2)] + | DoorMechanism + deriving (Eq,Ord,Show,Read) diff --git a/src/Dodge/Default/Door.hs b/src/Dodge/Default/Door.hs index 8933bfdda..614379ae0 100644 --- a/src/Dodge/Default/Door.hs +++ b/src/Dodge/Default/Door.hs @@ -4,7 +4,6 @@ module Dodge.Default.Door ) where import Dodge.Data import Dodge.Default.Wall -import Dodge.Block.Debris import Color import Control.Lens @@ -26,13 +25,13 @@ defaultDoor = Door { _drID = 0 , _drWallIDs = mempty , _drStatus = DoorClosed - , _drTrigger = const False - , _drMech = const id + , _drTrigger = WdBlConst False + , _drMech = DrWdId , _drPos = (0,0) , _drOpenPos = (0,0) , _drClosePos = (0,0) , _drHP = 10000 - , _drDeath = makeDoorDebris + , _drDeath = DrWdMakeDoorDebris , _drSpeed = 1 , _drPushedBy = PushesItself , _drPushes = Nothing diff --git a/src/Dodge/DrWdWd.hs b/src/Dodge/DrWdWd.hs new file mode 100644 index 000000000..59934446a --- /dev/null +++ b/src/Dodge/DrWdWd.hs @@ -0,0 +1,76 @@ +module Dodge.DrWdWd + where +import Dodge.LevelGen.DoorPane +import Dodge.SoundLogic +import Dodge.Base +import Dodge.WorldBool +import Dodge.Placement.PlaceSpot.TriggerDoor +import Dodge.Wall.Move +import Geometry +import Dodge.Block.Debris +import Dodge.Data + +import qualified Data.IntSet as IS +import Data.Foldable +import Control.Lens +doDrWdWd :: DrWdWd -> Door -> World -> World +doDrWdWd dww = case dww of + DrWdId -> const id + DrWdMakeDoorDebris -> makeDoorDebris + DrWdMechanismStepwise nsteps wlids pss -> doorMechanismStepwise nsteps wlids pss + DoorMechanism -> doorMechanism + +-- TODO sort out why DoorClosed status does not update correctly 22/06/23 +doorMechanism :: Door -> World -> World +doorMechanism dr w = case mvDir of + Just d -> w + & flip (IS.foldl' (flip (`translateWallID` d))) (_drWallIDs dr) + & moveUpdate + & doors . ix drid . drPos . each %~ (+.+ d) + & maybeClearDoorPaths (_drObstacleType dr) (_drObstructs dr) + Nothing -> w + where + toOpen = doWdBl (_drTrigger dr) w + mvDir + | toOpen && _drStatus dr == DoorOpen = Nothing -- Not sure why necessary + | toOpen && dist dpos dop > 0.5 = Just $ vecBetweenSpeed speed dpos dop + | dist dpos dcp > 0.5 = Just $ vecBetweenSpeed speed dpos dcp + | otherwise = Nothing + speed = _drSpeed dr + drid = _drID dr + moveUpdate = playSound . setStatus + playSound + | _drPushedBy dr == PushesItself = soundContinue (WallSound drid) dpos slideDoorS (Just 1) + | otherwise = id + dpos = snd $ _drPos dr + dop = snd $ _drOpenPos dr + dcp = snd $ _drClosePos dr + setStatus + | dist dpos dop < 1 = doors . ix drid . drStatus .~ DoorOpen + | dist dpos dcp < 1 = doors . ix drid . drStatus .~ DoorClosed + | otherwise = doors . ix drid . drStatus .~ DoorHalfway + +-- TODO use vector instead of list, perhaps also memoisation of rectanglePairs +-- TODO update _drPos +-- perhaps also remove use of DoorInt in favour of DoorOpen/DoorClosed +-- perhaps only store intermediate door pos pairs, calculate all wall positions +-- on the fly +doorMechanismStepwise :: Int -> [Int] -> [(Point2,Point2)] -> Door -> World -> World +doorMechanismStepwise nsteps wlids pss dr w + | toOpen = case _drStatus dr of + DoorInt x | x == nsteps -> w + DoorInt x -> setWalls (x+1) + _ -> w + | otherwise = case _drStatus dr of + DoorInt 0 -> w + DoorInt x -> setWalls (x-1) + _ -> w + where + drid = _drID dr + playSound = soundContinue (WallSound drid) (fst $ head pss) slideDoorS (Just 1) + toOpen = doWdBl (_drTrigger dr) w + setWalls n = playSound (foldl' (&) w (zipWith moveWallID wlids newps)) + & doors . ix drid . drStatus .~ DoorInt n + where + newps = uncurry (rectanglePairs 9) (pss !! n) +-- it is not at all clear that the zoning selects the correct walls diff --git a/src/Dodge/Placement/Instance/Door.hs b/src/Dodge/Placement/Instance/Door.hs index fe5573d96..4e34d0728 100644 --- a/src/Dodge/Placement/Instance/Door.hs +++ b/src/Dodge/Placement/Instance/Door.hs @@ -9,17 +9,15 @@ import Dodge.Default.Door import Color import Geometry import Dodge.LevelGen.Data -import Dodge.Creature.Test import Dodge.LevelGen.Switch import Control.Lens -import qualified IntMapHelp as IM -putDoubleDoor :: EdgeObstacle -> Wall -> (World -> Bool) -> Point2 -> Point2 -> Float -> Placement +putDoubleDoor :: 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 -> Wall -> (World -> Bool) +putDoubleDoorThen ::EdgeObstacle -> Wall -> WdBl -> Float -> Point2 -> Point2 -> Float -> (Placement -> Placement -> Maybe Placement) -> Placement @@ -30,7 +28,7 @@ putDoubleDoorThen eo wl cond soff a b speed cont where half = 0.5 *.* (a +.+ b) -doorBetween :: EdgeObstacle -> Wall -> (World -> Bool) -> Float -> Point2 -> Point2 -> Float -> +doorBetween :: EdgeObstacle -> Wall -> WdBl -> Float -> Point2 -> Point2 -> Float -> (Placement -> Maybe Placement) -> Placement doorBetween eo wl cond soff pa pb speed g = case divideLine 40 pa pb of [x,y] -> ptCont (PutSlideDr adoor wl eo soff x y) g @@ -41,7 +39,7 @@ doorBetween eo wl cond soff pa pb speed g = case divideLine 40 pa pb of & drTrigger .~ cond & drSpeed .~ speed -divideDoorPane :: Maybe Int -> Wall -> (World -> Bool) -> Float -> Float +divideDoorPane :: Maybe Int -> Wall -> WdBl -> Float -> Float -> [(Point2,Point2)] -> (Placement -> Maybe Placement) -> Placement divideDoorPane mid wl cond soff speed ppairs g = case ppairs of [p] -> ptCont (adoor p) g @@ -59,8 +57,9 @@ putAutoDoor a b = PlacementUsingPos (addZ 0 a) (cond az bz) a b 3 where --cond az bz = any (crNearSeg 40 (stripZ az) (stripZ bz)) . IM.filter isAnimate . _creatures - cond az bz = any (crNearPoint 40 (0.5 *.* (stripZ az +.+ stripZ bz))) - . IM.filter isAnimate . _creatures + cond az bz = WdBlCrFilterNearPoint 40 (0.5 *.* (stripZ az +.+ stripZ bz)) CrIsAnimate + -- any (crNearPoint 40 (0.5 *.* (stripZ az +.+ stripZ bz))) + -- . IM.filter isAnimate . _creatures switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement switchDoor btpos btrot dra drb col = pContID (PS btpos btrot) @@ -71,7 +70,7 @@ switchDoor btpos btrot dra drb col = pContID (PS btpos btrot) doorbetween btid a b = PutSlideDr thedoor (switchWallCol col) DoorObstacle 1 a b where thedoor = defaultDoor - & drTrigger .~ cond btid + & drTrigger .~ WdBlBtOn btid & drSpeed .~ 2 drc = 0.5 *.* (dra +.+ drb) - cond btid w' = _btState (_buttons w' IM.! btid) == BtOn + --cond btid w' = _btState (_buttons w' IM.! btid) == BtOn diff --git a/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs b/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs index 516107fa3..23c93689a 100644 --- a/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs +++ b/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs @@ -2,18 +2,17 @@ module Dodge.Placement.PlaceSpot.TriggerDoor ( plDoor , plSlideDoor + , maybeClearDoorPaths ) where import Dodge.Zoning.Wall import Dodge.Data import Dodge.Base import Dodge.Path import Dodge.Default.Door -import Dodge.Wall.Move import Dodge.LevelGen.DoorPane import Picture import Geometry import qualified IntMapHelp as IM -import Dodge.SoundLogic import LensHelp --import Dodge.LevelGen.LevelStructure @@ -23,7 +22,7 @@ import qualified Data.IntSet as IS import qualified Data.Graph.Inductive as FGL plDoor :: Color -> EdgeObstacle - -> (World -> Bool) -- ^ Opening condition + -> WdBl -- ^ Opening condition -> [(Point2,Point2)] -- ^ Door positions, closed to open. -- Bumped out up and down by 9, not widened -> World @@ -36,7 +35,7 @@ plDoor col eo cond pss gw = (drid, addWalls $ gw & doors %~ addDoor) -- carefull , _drWallIDs = IS.fromList wlids , _drStatus = DoorInt 0 , _drTrigger = cond - , _drMech = doorMechanismStepwise nsteps drid wlids pss + , _drMech = DrWdMechanismStepwise nsteps wlids pss , _drPos = head pss , _drOpenPos = head pss , _drClosePos = last pss @@ -57,59 +56,6 @@ addDoorWall eo drid wl w (wlid,wlps) = w' & doors . ix drid . drObstructs .++~ es where (w',es) = uncurry (obstructPathsCrossing eo) wlps w --- TODO use vector instead of list, perhaps also memoisation of rectanglePairs --- TODO update _drPos --- perhaps also remove use of DoorInt in favour of DoorOpen/DoorClosed --- perhaps only store intermediate door pos pairs, calculate all wall positions --- on the fly -doorMechanismStepwise :: Int -> Int -> [Int] -> [(Point2,Point2)] -> Door -> World -> World -doorMechanismStepwise nsteps drid wlids pss dr w - | toOpen = case _drStatus dr of - DoorInt x | x == nsteps -> w - DoorInt x -> setWalls (x+1) - _ -> w - | otherwise = case _drStatus dr of - DoorInt 0 -> w - DoorInt x -> setWalls (x-1) - _ -> w - where - playSound = soundContinue (WallSound drid) (fst $ head pss) slideDoorS (Just 1) - toOpen = _drTrigger dr w - setWalls n = playSound (foldl' (&) w (zipWith moveWallID wlids newps)) - & doors . ix drid . drStatus .~ DoorInt n - where - newps = uncurry (rectanglePairs 9) (pss !! n) --- it is not at all clear that the zoning selects the correct walls - --- TODO sort out why DoorClosed status does not update correctly 22/06/23 -doorMechanism :: Door -> World -> World -doorMechanism dr w = case mvDir of - Just d -> w - & flip (IS.foldl' (flip (`translateWallID` d))) (_drWallIDs dr) - & moveUpdate - & doors . ix drid . drPos . each %~ (+.+ d) - & maybeClearDoorPaths (_drObstacleType dr) (_drObstructs dr) - Nothing -> w - where - toOpen = _drTrigger dr w - mvDir - | toOpen && _drStatus dr == DoorOpen = Nothing -- Not sure why necessary - | toOpen && dist dpos dop > 0.5 = Just $ vecBetweenSpeed speed dpos dop - | dist dpos dcp > 0.5 = Just $ vecBetweenSpeed speed dpos dcp - | otherwise = Nothing - speed = _drSpeed dr - drid = _drID dr - moveUpdate = playSound . setStatus - playSound - | _drPushedBy dr == PushesItself = soundContinue (WallSound drid) dpos slideDoorS (Just 1) - | otherwise = id - dpos = snd $ _drPos dr - dop = snd $ _drOpenPos dr - dcp = snd $ _drClosePos dr - setStatus - | dist dpos dop < 1 = doors . ix drid . drStatus .~ DoorOpen - | dist dpos dcp < 1 = doors . ix drid . drStatus .~ DoorClosed - | otherwise = doors . ix drid . drStatus .~ DoorHalfway maybeClearDoorPaths :: EdgeObstacle -> [(Int,Int,PathEdge)] -> World -> World maybeClearDoorPaths eo es w = foldl' (maybeClearDoorPath eo) w es @@ -138,7 +84,7 @@ plSlideDoor dr wl eo shiftOffset a b gw { _drID = drid , _drWallIDs = IS.fromList wlids , _drStatus = DoorClosed - , _drMech = doorMechanism + , _drMech = DoorMechanism , _drPos = (a,b) , _drOpenPos = (shiftLeft a,shiftLeft b) , _drClosePos = (a,b) diff --git a/src/Dodge/Room/Airlock.hs b/src/Dodge/Room/Airlock.hs index 1bfba70e0..895a13bd2 100644 --- a/src/Dodge/Room/Airlock.hs +++ b/src/Dodge/Room/Airlock.hs @@ -14,7 +14,6 @@ import Geometry import Picture --import Control.Lens -import qualified IntMapHelp as IM {- | A passage with a switch that opens forward access while closing backwards access. -} airlock :: RandomGen g => State g Room airlock = takeOne [airlock0,airlock90,airlockCrystal,airlockZ] @@ -27,8 +26,8 @@ airlock0 = defaultRoom , _rmPath = foldMap doublePairSet [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20 5) ] , _rmPmnts = [pContID (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) - $ \btid -> Just $ putDoubleDoorThen DoorObstacle thewall (not . cond' btid) 1 (V2 0 20) (V2 40 20) 2 - $ \_ _ -> Just $ putDoubleDoor DoorObstacle thewall (cond' btid) (V2 0 80) (V2 40 80) 2 + $ \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 , invisibleWall $ rectNSWE 60 40 (-40) (-30) ,spanLightI (V2 (-2) 30) (V2 (-2) 70) ,sps0 $ putShape $ thinHighBar 75 (V2 40 50) (V2 (-1) 50) @@ -41,13 +40,12 @@ airlock0 = defaultRoom lnks = [(V2 20 95,0) ,(V2 20 5,pi) ] - cond' btid w' = _btState (_buttons w' IM.! btid) == BtOn col = dim $ dim $ bright red -airlockDoor :: Color -> (World -> Bool) -> [(Point2,Point2)] -> PSType +airlockDoor :: Color -> WdBl -> [(Point2,Point2)] -> PSType airlockDoor col = PutDoor col DoorObstacle -airlockDoubleDoor :: Point2 -> Point2 -> Color -> (World -> Bool) -> [(Point2,Point2)] +airlockDoubleDoor :: Point2 -> Point2 -> Color -> WdBl -> [(Point2,Point2)] -> [(Point2,Point2)] -> Maybe Placement airlockDoubleDoor p1 p2 col cond outDoorps inDoorps = jspsJ p1 0 (airlockDoor col cond outDoorps) $ sPS p2 0 (airlockDoor col cond inDoorps) @@ -60,7 +58,7 @@ airlockSimple = defaultRoom , _rmPath = foldMap (doublePairSet . (V2 90 30,) . fst) lnks , _rmPmnts = [pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) - $ \btid -> airlockDoubleDoor 0 (V2 180 0) col (cond btid) outDoorps inDoorps + $ \btid -> airlockDoubleDoor 0 (V2 180 0) col (WdBlBtOn btid) outDoorps inDoorps -- jspsJ (V2 0 0) 0 (airlockDoor col (cond btid) outDoorps) -- $ sPS (V2 180 0) 0 (airlockDoor col (cond btid) inDoorps) ] @@ -72,7 +70,6 @@ airlockSimple = defaultRoom [(V2 0 30,pi/2) ,(V2 180 30,1.5*pi) ] - cond btid w' = _btState (_buttons w' IM.! btid) == BtOn col = dim $ dim $ bright red outDoorps = (V2 0 0 ,) <$> arcStepwise 3 (negate $ pi/2) (V2 0 0) (V2 0 55) inDoorps = (V2 0 0 ,) <$> arcStepwise 3 (negate $ pi/2) (V2 0 0) (V2 (-55) 0) @@ -87,7 +84,7 @@ airlockZ = defaultRoom -- ] , _rmPmnts = [pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) - $ \btid -> airlockDoubleDoor (V2 0 60) (V2 180 60) col (cond btid) outDoorps inDoorps + $ \btid -> airlockDoubleDoor (V2 0 60) (V2 180 60) col (WdBlBtOn btid) outDoorps inDoorps -- jspsJ (V2 0 60) 0 (airlockDoor col (cond btid) outDoorps) -- $ sPS (V2 180 60) 0 (airlockDoor col (cond btid) inDoorps) , sps0 $ PutWall (reverse $ rectNSWE 70 50 60 120) defaultWall @@ -97,7 +94,6 @@ airlockZ = defaultRoom [ rectNSWE 120 0 0 180 ] } where - cond btid w' = _btState (_buttons w' IM.! btid) == BtOn col = dim $ dim $ bright red outDoorps = (V2 0 0 ,) <$> arcStepwise 3 (pi/2) (V2 0 0) (V2 0 (-61)) inDoorps = (V2 0 0 ,) <$> arcStepwise 3 (pi/2) (V2 0 0) (V2 (-61) 0) @@ -122,7 +118,7 @@ airlock90 = defaultRoom , _rmPath = doublePairSet (V2 0 40,V2 40 0) , _rmPmnts = [ pContID (PS (V2 120 120) (3 * pi/4)) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) - $ \btid -> jsps (V2 5 5) 0 $ airlockDoor col (cond btid) pss + $ \btid -> jsps (V2 5 5) 0 $ airlockDoor col (WdBlBtOn btid) pss , mntLS vShape (V2 35 35) (V3 70 70 50) ] , _rmBound = @@ -136,7 +132,6 @@ airlock90 = defaultRoom } where --cond w = or $ M.lookup (DoorNumOpen n) (_worldState w) - cond btid w' = _btState (_buttons w' IM.! btid) == BtOn col = dim $ dim $ bright red pss = (V2 0 0 ,) <$> arcStepwise 3 (negate $ pi/2) (V2 0 0) (V2 0 55) @@ -147,7 +142,7 @@ airlockCrystal = defaultRoom , _rmPath = mempty , _rmPmnts = [pContID (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) - $ \btid -> jsps0 $ airlockDoor col (cond btid) pss + $ \btid -> jsps0 $ airlockDoor col (WdBlBtOn btid) pss , crystalLine (V2 0 70) (V2 40 70) , mntLS vShape (V2 150 70) (V3 110 70 70) ] @@ -155,7 +150,6 @@ airlockCrystal = defaultRoom } where switchcutout = orderPolygon $ map toV2 [ (39,20) , (150,60) , (150,80) , (39,120) ] - cond btid w' = _btState (_buttons w' IM.! btid) == BtOn col = dim $ dim $ bright red pss :: [(Point2,Point2)] pss = reverse $ fmap ( (\x -> (V2 50 (x - 10),V2 50 (x+60)) ) . fromIntegral) diff --git a/src/Dodge/Room/Door.hs b/src/Dodge/Room/Door.hs index 257884b24..10e39062a 100644 --- a/src/Dodge/Room/Door.hs +++ b/src/Dodge/Room/Door.hs @@ -10,8 +10,6 @@ import Dodge.Placement.Instance import Color import Data.Maybe -import qualified IntMapHelp as IM ---import Control.Lens door :: Room door = defaultRoom @@ -41,4 +39,4 @@ triggerDoorRoom inplid = defaultRoom where f (pmnt:_) = putDoubleDoor DoorObstacle (switchWallCol red) (cond pmnt) (V2 0 20) (V2 40 20) 2 f _ = error "tried to put a door using an empty placement list" - cond pmnt w = _triggers w IM.! fromJust (_plMID pmnt) + cond pmnt = WdTrig $ fromJust (_plMID pmnt) diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index a5a2e3e64..c202a4e5f 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -28,8 +28,6 @@ import LensHelp import qualified Data.Set as S import Data.Maybe ---import Data.Tree -import qualified IntMapHelp as IM twinSlowDoorRoom :: Float -- ^ Half width @@ -67,7 +65,7 @@ twinSlowDoorRoom w h x = defaultRoom ] thedoor btid = defaultDoor & drSpeed .~ wlSpeed - & drTrigger .~ (\w' -> _btState (_buttons w' IM.! btid) /= BtOff) + & drTrigger .~ WdBlBtNotOff btid col = dim $ dim $ bright red twinSlowDoorChasers :: RandomGen g => State g Room @@ -113,7 +111,7 @@ addButtonSlowDoor x h rm = do thewall = switchWallCol red butDoor = putLitButOnPos col (rprBool (isUnusedLnkType InLink)) - $ \btplmnt -> Just $ putDoubleDoorThen DoorObstacle thewall (cond' $ fromJust $ _plMID btplmnt) + $ \btplmnt -> Just $ putDoubleDoorThen DoorObstacle thewall (WdBlBtNotOff $ fromJust $ _plMID btplmnt) 30 (V2 0 h) (V2 x h) 2 $ \dr1 dr2 -> amountedlight dr1 50 @@ -122,7 +120,6 @@ addButtonSlowDoor x h rm = do $ amountedlight dr2 (-50) Nothing col = dim $ light red - cond' btid w = w ^? buttons . ix btid . btState /= Just BtOff slowDoorRoom :: RandomGen g => State g Room slowDoorRoom = do diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index f92d8c5ba..461cc6db5 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -34,7 +34,6 @@ import Data.Tile import LensHelp import qualified Data.Set as S -import qualified IntMapHelp as IM --import Control.Lens -- This will need a cleanup, but it might change a bit first {- A simple rectangular room with a light in the center. @@ -272,5 +271,5 @@ centerVaultRoom w h d = return $ defaultRoom ] thewall = switchWallCol col thedoor btid = defaultDoor - & drTrigger .~ (\w' -> _btState (_buttons w' IM.! btid) == BtOn) + & drTrigger .~ WdBlBtOn btid & drSpeed .~ 2 diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 4b4becfaf..b55881c71 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -4,6 +4,7 @@ Module : Dodge.Update Description : Simulation update -} module Dodge.Update ( updateUniverse ) where +import Dodge.DrWdWd import Dodge.TractorBeam.Update import Dodge.Prop.Update import Dodge.LinearShockwave.Update @@ -86,7 +87,7 @@ functionalUpdate w = checkEndGame . colCrsWalls . over uvWorld simpleCrSprings . over uvWorld zoneCreatures - . over uvWorld (updateIMl _doors _drMech ) + . over uvWorld (updateIMl _doors (doDrWdWd . _drMech) ) . over uvWorld doWorldEvents . over uvWorld updateDelayedEvents . over uvWorld (updateIMl _modifications (doModificationEffect . _mdUpdate) ) diff --git a/src/Dodge/WorldBool.hs b/src/Dodge/WorldBool.hs index c095d5cf5..de818ad72 100644 --- a/src/Dodge/WorldBool.hs +++ b/src/Dodge/WorldBool.hs @@ -1,12 +1,22 @@ module Dodge.WorldBool where +import Dodge.CreatureEffect +import Dodge.Creature.Test import Dodge.Data import Data.Maybe import Control.Lens +import qualified IntMapHelp as IM + doWdBl :: WdBl -> World -> Bool doWdBl wb w = case wb of + WdBlConst bl -> bl WdTrig i -> fromMaybe False $ w ^? triggers . ix i WdBlDoorMoving i -> fromMaybe False $ do dr <- w ^? doors . ix i return (DoorHalfway == _drStatus dr) + WdBlCrFilterNearPoint r p t -> any (crNearPoint r p) (IM.filter (doCrBl t) (_creatures w)) + WdBlBtOn btid -> _btState (_buttons w IM.! btid) == BtOn -- unsafe + WdBlBtNotOff btid -> _btState (_buttons w IM.! btid) /= BtOff -- unsafe + WdBlNegate x -> not $ doWdBl x w +