From 4b7562521ceefc53571c68165c1dfd4f7ff926c1 Mon Sep 17 00:00:00 2001 From: jgk Date: Tue, 17 Aug 2021 20:59:10 +0200 Subject: [PATCH] Fix long door bug. --- src/Dodge/Creature/State.hs | 2 +- src/Dodge/LevelGen.hs | 1 + src/Dodge/LevelGen/Data.hs | 1 + src/Dodge/LevelGen/DoorPane.hs | 23 +++++++++++++++++++++++ src/Dodge/LevelGen/TriggerDoor.hs | 10 ++++++++++ src/Dodge/Room/LongDoor.hs | 6 ++++-- src/DoubleStack.hs | 1 - 7 files changed, 40 insertions(+), 4 deletions(-) diff --git a/src/Dodge/Creature/State.hs b/src/Dodge/Creature/State.hs index c2533bf93..7f40a7823 100644 --- a/src/Dodge/Creature/State.hs +++ b/src/Dodge/Creature/State.hs @@ -82,7 +82,7 @@ crFriction _ _ = V2 0 0 doDamage :: Creature -> Creature doDamage cr = set (crState . crDamage) [] - $ over (crState . crPastDamage) (forceFoldable . take 20 . (dams :) ) damagedCr + $ over (crState . crPastDamage) (forceFoldable . take 10 . (dams :) ) damagedCr where dams = _crDamage $ _crState cr damagedCr = snd $ _crApplyDamage cr dams cr diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 677808ae9..b51eda76e 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -81,6 +81,7 @@ placeSpot ps w = case _psType ps of where mapBoth fn (x,y) = (fn x, fn y) PutDoubleDoor col f a b -> putDoubleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w + PutSingleDoor col f a b -> putSingleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) 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" diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index 37d0ce3ef..7a60f3904 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -19,6 +19,7 @@ data PSType = PutCrit {_unPutCrit :: Creature} | PutLineBlock Wall Float Float Point2 Point2 | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall } | PutDoubleDoor Color (World -> Bool) Point2 Point2 + | PutSingleDoor Color (World -> Bool) Point2 Point2 | PutDoor Color (World -> Bool) [(Point2,Point2)] | PutBtDoor Color Point2 Float Point2 Point2 | PutSwitchDoor Color Point2 Float Point2 Point2 diff --git a/src/Dodge/LevelGen/DoorPane.hs b/src/Dodge/LevelGen/DoorPane.hs index 4f28db45a..c19c518f7 100644 --- a/src/Dodge/LevelGen/DoorPane.hs +++ b/src/Dodge/LevelGen/DoorPane.hs @@ -1,6 +1,7 @@ module Dodge.LevelGen.DoorPane ( linearPane , mkDoubleDoor + , mkSingleDoor ) where import Dodge.Data import Dodge.LevelGen.MoveDoor @@ -33,6 +34,28 @@ linearPane c isPathable cond n closedPos openPos = Door openDoor = moveDoorToward openPos closeDoor = moveDoorToward closedPos +mkSingleDoor :: Color -> Bool -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall] +mkSingleDoor c isPathable cond pl hw is + = addSoundToDoor (head is) pld hwd $ zipWith3 (linearPane c isPathable cond) + is + leftDoor + (map shiftLeft leftDoor) + where + leftDoor = + [ (pld +.+ perp,hwd) + , (hwd, hwu) + , (hwu, plu +.+ perp) + , (plu +.+ perp,pld +.+ perp) + ] + shiftLeft = h (+.+ (pl -.- hw)) + h func (x,y) = (func x,func y) + norm = 9 *.* normalizeV ( vNormal (hw -.- pl)) + perp = 5 *.* normalizeV (pl -.- hw) + plu = pl +.+ norm + pld = pl -.- norm + hwu = hw +.+ norm + hwd = hw -.- norm + mkDoubleDoor :: Color -> Bool -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall] mkDoubleDoor c isPathable cond pl pr is = addSoundToDoor (head is) pld hwd $ zipWith3 (linearPane c isPathable cond) diff --git a/src/Dodge/LevelGen/TriggerDoor.hs b/src/Dodge/LevelGen/TriggerDoor.hs index a5a29b755..61954e927 100644 --- a/src/Dodge/LevelGen/TriggerDoor.hs +++ b/src/Dodge/LevelGen/TriggerDoor.hs @@ -2,6 +2,7 @@ module Dodge.LevelGen.TriggerDoor ( putDoor , putDoubleDoor + , putSingleDoor , addButtonDoor , addSwitchDoor ) where @@ -81,16 +82,25 @@ putDoubleDoor c cond a b = over walls triggerDoubleDoor where is = [IM.newKey wls..] +putSingleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World +putSingleDoor c cond a b = over walls putTheDoor + where + putTheDoor wls = IM.union wls $ IM.fromList $ zip is $ mkSingleDoor c False cond a b is + where + is = [IM.newKey wls..] + mkTriggerDoor :: Color -> (World -> Bool) -- ^ Opening condition -> [(Point2,Point2)] -- ^ List of wall position pairs, closed to open -> [Int] -- ^ Wall ids -> [Wall] +{-# INLINE mkTriggerDoor #-} mkTriggerDoor c cond ppairs is = zipWith (triggerDoorPane c cond) is $ transpose $ map toPanePoints ppairs toPanePoints :: (Point2,Point2) -> [(Point2,Point2)] +{-# INLINE toPanePoints #-} toPanePoints (x,y) = [ (y +.+ perp, y -.- perp) , (y -.- perp, x -.- perp) diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index 15aa75910..cb6db1aa3 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -42,8 +42,10 @@ twinSlowDoorRoom drID w h x = defaultRoom [ sPS (V2 0 (h/2)) 0 putLamp , sPS (V2 25 5) 0 putLamp , sPS (V2 (negate 25) 5) 0 putLamp - , sPS (V2 0 0) 0 $ PutDoor col (not . cond) drL - , sPS (V2 0 0) 0 $ PutDoor col (not . cond) drR + --, sPS (V2 0 0) 0 $ PutDoor col (not . cond) drL + --, sPS (V2 0 0) 0 $ PutDoor col (not . cond) drR + , sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2 x 0) (V2 x h) + , sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2 (-x) 0) (V2 (-x) h) , sPS (V2 0 (h-5)) pi $ PutButton $ makeButton col (over worldState (M.insert (DoorNumOpen drID) True)) ] diff --git a/src/DoubleStack.hs b/src/DoubleStack.hs index cf754b653..76f24240b 100644 --- a/src/DoubleStack.hs +++ b/src/DoubleStack.hs @@ -3,7 +3,6 @@ module DoubleStack newtype DS a = DS (a,[a],[a]) deriving (Eq, Ord, Read, Show) - {- | Unsafe. -} fromListL :: [a] -> DS a