From 751000636efe85244767a3e92d1ff80b6dd07c1a Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 28 Sep 2021 12:32:44 +0100 Subject: [PATCH] Continue major door/wall refactor --- src/Dodge/Data.hs | 2 +- src/Dodge/LevelGen/AutoDoor.hs | 30 -------------- src/Dodge/LevelGen/TriggerDoor.hs | 66 ++++++++++++++++++++++++++----- 3 files changed, 57 insertions(+), 41 deletions(-) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index e04c87211..65cf86e74 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -538,7 +538,7 @@ data Door' = Door' , _drTrigger :: World -> Bool , _drMech :: Door' -> World -> World } -data DoorStatus = DoorOpen | DoorClosed | DoorHalfway +data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int deriving (Eq, Ord, Show) data Wall = Wall diff --git a/src/Dodge/LevelGen/AutoDoor.hs b/src/Dodge/LevelGen/AutoDoor.hs index 513a6fef6..8e55e6617 100644 --- a/src/Dodge/LevelGen/AutoDoor.hs +++ b/src/Dodge/LevelGen/AutoDoor.hs @@ -9,7 +9,6 @@ import Dodge.Data import Dodge.Base import Dodge.Creature.Property --import Dodge.LevelGen.MoveDoor -import Dodge.LevelGen.DoorPane import Dodge.LevelGen.TriggerDoor --import Geometry import Picture @@ -17,10 +16,6 @@ import Geometry.Data --import qualified DoubleStack as DS import qualified IntMapHelp as IM ---import Data.List ---import Data.Maybe -import Control.Lens ---import Control.DeepSeq (deepseq) addAutoDoor :: Point2 -- ^ Left point @@ -30,28 +25,3 @@ addAutoDoor 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 - -> Point2 -- ^ Right point (though the two points should be symmetric) - -> IM.IntMap Wall - -> IM.IntMap Wall -autoDoorAt a b wls = IM.union wls $ IM.fromList $ zip is $ mkAutoDoor a b is - where - is = [IM.newKey wls..] - -mkAutoDoor - :: Point2 -- ^ Left point - -> Point2 -- ^ Right point (though the two points should be symmetric) - -> [Int] -- ^ Wall ids - -> [Wall] -mkAutoDoor pl pr = mkDoubleDoor (dim yellow) True cond pl pr 3 - where - cond = any (crNearSeg 40 pl pr) . IM.filter isAnimate . _creatures diff --git a/src/Dodge/LevelGen/TriggerDoor.hs b/src/Dodge/LevelGen/TriggerDoor.hs index 075e58e0b..153f52d3d 100644 --- a/src/Dodge/LevelGen/TriggerDoor.hs +++ b/src/Dodge/LevelGen/TriggerDoor.hs @@ -45,6 +45,19 @@ addButtonDoor c btp btr a b speed w . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w' f (x,y) = (x,y,dist x y) +putDoor' + :: Color + -> (World -> Bool) -- ^ Opening condition + -> [(Point2,Point2)] -- ^ Door positions, closed to open. + -- Bumped out up and down by 9, not widened + -> World + -> World +putDoor' c cond pss = over walls triggerDoor + where + triggerDoor wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond pss is + where + is = [IM.newKey wls..] + putDoor :: Color -> (World -> Bool) -- ^ Opening condition @@ -52,11 +65,50 @@ putDoor -- Bumped out up and down by 9, not widened -> World -> World -putDoor c cond pss = over walls triggerDoor +putDoor col cond pss w = addWalls w + & doors %~ addDoor where - triggerDoor wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond pss is + drid = IM.newKey $ _doors w + addDoor = IM.insert drid $ Door' + { _drID = drid + , _drWallIDs = wlids + , _drStatus = DoorInt 0 + , _drTrigger = cond + , _drMech = doorMechanismStepwise nsteps drid wlids pss + } + nsteps = length pss - 1 + wlids = take 4 [IM.newKey $ _walls w ..] + wlps = uncurry (rectanglePairs 9) $ head pss + addWalls w' = foldl' addWall w' $ zip wlids wlps + addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid Wall + { _wlLine = wlps + , _wlID = wlid + , _wlColor = col + , _wlSeen = False + , _wlIsSeeThrough = False + , _wlPathable = False + } +-- TODO use vector instead of list, perhaps also memoisation of rectanglePairs +-- perhaps also remove use of DoorInt in favour of DoorOpen/DoorClosed +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) + | otherwise = case _drStatus dr of + DoorInt 0 -> w + DoorInt x -> setWalls (x-1) + where + playSound = soundContinue (WallSound drid) (fst $ head pss) slideDoorS (Just 1) + toOpen = _drTrigger dr w + setWalls n = (playSound $ foldl' setWall w (zip wlids newps)) + & doors . ix drid . drStatus .~ DoorInt n where - is = [IM.newKey wls..] + newps = uncurry (rectanglePairs 9) (pss !! n) + setWall w' (wlid,ps) = w & walls . ix wlid . wlLine .~ ps + & (\w'' -> foldr (changeZonedWall (wlLine .~ ps) wlid) w'' (zoneps ps)) +-- it is not at all clear that the zoning selects the correct walls + putDoubleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World putDoubleDoor isPathable col cond a b speed @@ -65,13 +117,7 @@ putDoubleDoor isPathable col cond a b 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..] - +-- TODO think about wall zoning, simplify! 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