From 8d79e96798713ec7b5a0e269eb62d09a38d2efe8 Mon Sep 17 00:00:00 2001 From: justin Date: Sun, 2 Nov 2025 22:07:15 +0000 Subject: [PATCH] Add files --- src/Dodge/Door.hs | 108 +++++++++++++++++++++++++++++++++ src/Dodge/Door/DoorLerp.hs | 9 +++ src/Dodge/Door/PutSlideDoor.hs | 20 ++++++ src/Dodge/Wall/Pathing.hs | 19 ++++++ 4 files changed, 156 insertions(+) create mode 100644 src/Dodge/Door.hs create mode 100644 src/Dodge/Door/DoorLerp.hs create mode 100644 src/Dodge/Door/PutSlideDoor.hs create mode 100644 src/Dodge/Wall/Pathing.hs diff --git a/src/Dodge/Door.hs b/src/Dodge/Door.hs new file mode 100644 index 000000000..0d3de47d9 --- /dev/null +++ b/src/Dodge/Door.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE LambdaCase #-} + +module Dodge.Door (updateDoor) where + +import Data.Foldable +import qualified Data.IntMap.Strict as IM +import Data.Maybe +import qualified Data.Set as S +import Dodge.Block.Debris +import Dodge.Data.World +import Dodge.Door.DoorLerp +import Dodge.LightSource +import Dodge.ShiftPoint +import Dodge.SoundLogic +import Dodge.Wall.Delete +import Dodge.Wall.Move +import Dodge.WorldBool +import Dodge.Zoning.Base +import Dodge.Zoning.Pathing +import Geometry.Data +import LensHelp +import Linear +import Picture.Data +import Shape.Data + +updateDoor :: Door -> World -> (S.Set Int2, World) +updateDoor dr w + | dr ^. drHP < 1 = destroyDoor dr w + | DoorLerp x <- dr ^. drUpdate = doorLerp x dr w + | otherwise = + ( mempty + , foldl' (doDoorMount (doDoorLerp dr (dr ^. drLerp))) w (dr ^. drMounts) + ) + +doDoorMount :: Point2A -> World -> MountedObject -> World +doDoorMount pa w = \case + MountedLight p r c -> + w & cWorld . lWorld . lights .:~ LSParam (p & _xy %~ shiftPointBy pa) r c + MountedSPic x -> + w & cWorld . lWorld . tempSPic + <>~ ( x & _1 . each . sfVs . each . _xy %~ shiftPointBy pa + & _2 . each . vxPos . _xy %~ shiftPointBy pa + ) + +doorLerp :: Float -> Door -> World -> (S.Set Int2, World) +doorLerp speed dr w = fromMaybe (mempty, domounts (dr ^. drLerp) w) $ do + x <- newlerp + let ps = wlposs x + ps' = wlposs (dr ^. drLerp) + is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) (ps <> ps') + -- it seems possible that this will miss some paths: we don't add zones for the + -- old footprint. Seems unlikely, but a possible cause of pathfinding bugs + return + ( is + , domounts x $ + f x + & playSound x + & cWorld . lWorld . doors . ix drid . drLerp .~ x + ) + where + domounts x w' = foldl' (doDoorMount (doDoorLerp dr x)) w' (dr ^. drMounts) + f = ifoldl' (flip . moveWallID) w . wlposs + wlposs x = (dr ^. drFootPrint) & each . each %~ shiftPointBy (doDoorLerp dr x) + clerp = dr ^. drLerp + newlerp + | toOpen && clerp < 1 = Just . min 1 $ clerp + speed + | clerp > 0 && not toOpen = Just . max 0 $ clerp - speed + | otherwise = Nothing + toOpen = doWdBl (_drTrigger dr) w + drid = _drID dr + playSound x + | _drPushedBy dr == PushesItself = + soundContinue (WallSound drid) (fst $ doDoorLerp dr x) slideDoorS (Just 1) + | otherwise = id + +destroyDoor :: Door -> World -> (S.Set Int2, World) +destroyDoor dr w = + ( is + , w + & makeDoorDebris dr + & deleteWallIDs wlids + & cWorld . lWorld . doors %~ IM.delete (_drID dr) + -- & muchWlDustAt awl (0.5 * uncurry (+) (_drPos dr)) + -- & flip (foldl' (flip $ muchWlDustAt awl)) (map (pos +.+) ps) + & stopPushing (dr ^. drPushes) + & destroyMounts pa (dr ^. drMounts) + ) + where + pa = doDoorLerp dr (dr ^. drLerp) + is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) ps + ps = (dr ^. drFootPrint) & each . each %~ shiftPointBy pa + wlids = IM.keysSet $ _drFootPrint dr + +destroyMounts :: Point2A -> [MountedObject] -> World -> World +destroyMounts pa mos w = foldl' (flip $ destroyMount pa) w mos + +destroyMount :: Point2A -> MountedObject -> World -> World +destroyMount pa = \case + MountedLight x _ _ -> destroyLSFlashAt $ x & _xy %~ shiftPointBy pa + MountedSPic{} -> id -- make debris? + +stopPushing :: Maybe Int -> World -> World +stopPushing mdrid w = fromMaybe w $ do + drid <- mdrid + dr <- w ^? cWorld . lWorld . doors . ix drid + return $ + w & cWorld . lWorld . doors . ix drid . drUpdate .~ DoorDoNothing + & stopPushing (_drPushes dr) diff --git a/src/Dodge/Door/DoorLerp.hs b/src/Dodge/Door/DoorLerp.hs new file mode 100644 index 000000000..9e65380f3 --- /dev/null +++ b/src/Dodge/Door/DoorLerp.hs @@ -0,0 +1,9 @@ +module Dodge.Door.DoorLerp (doDoorLerp) where + +import Dodge.ShiftPoint +import Dodge.Data.Door +import Geometry.Data +import Control.Lens + +doDoorLerp :: Door -> Float -> Point2A +doDoorLerp dr = lerpP2A (dr ^. drZeroPos) (dr ^. drOnePos) diff --git a/src/Dodge/Door/PutSlideDoor.hs b/src/Dodge/Door/PutSlideDoor.hs new file mode 100644 index 000000000..4cbe5e42c --- /dev/null +++ b/src/Dodge/Door/PutSlideDoor.hs @@ -0,0 +1,20 @@ +module Dodge.Door.PutSlideDoor (putSlideDr) where + +import ListHelp +import Dodge.LevelGen.DoorPane +import Control.Lens +import Geometry.Vector +import qualified Data.IntMap.Strict as IM +import Dodge.Data.GenWorld +import Geometry.Data +import Linear + +putSlideDr :: Door -> Wall -> Float -> Point2 -> Point2 -> PSType +putSlideDr dr wl x a b = PutDoor thedr wl + where + c = a + (a - b) + x *^ normalizeV (b - a) + thedr = + dr & drUpdate . drLerpSpeed %~ (/ distance a c) + & drZeroPos .~ (a, 0) + & drOnePos .~ (c, 0) + & drFootPrint .~ IM.fromList (zip [0..] $ loopPairs (mkRectangle 9 (b - a))) diff --git a/src/Dodge/Wall/Pathing.hs b/src/Dodge/Wall/Pathing.hs new file mode 100644 index 000000000..3b06e9c35 --- /dev/null +++ b/src/Dodge/Wall/Pathing.hs @@ -0,0 +1,19 @@ +module Dodge.Wall.Pathing (getWallPathing) where + +import qualified Data.Set as S +import Dodge.Data.Wall +import Control.Lens + +getWallPathing :: Wall -> S.Set WallFlag +getWallPathing wl = f . g . h $ mempty + where + h = case wl ^. wlStructure of + StandaloneWall -> S.insert WallNotDestrucable + _ | wl ^. wlMaterial == Crystal -> S.insert WallNotDestrucable + _ -> id + g = case wl ^? wlStructure . wsIsAutoDoor of + Just True -> id + _ -> S.insert WallNotAutoOpen + f = case wl ^. wlOpacity of + Opaque {} -> S.insert WallBlockVisibility + _ -> id