From 5a40eac4e25de5bef032e410b8494e6ffce9db64 Mon Sep 17 00:00:00 2001 From: justin Date: Sun, 9 Nov 2025 14:37:45 +0000 Subject: [PATCH] Move wall destruction --- src/Dodge/Debug/Picture.hs | 7 ++--- src/Dodge/Door.hs | 38 ------------------------- src/Dodge/Wall/Damage.hs | 58 ++++++++++++++++++++++++++++++++++---- src/Dodge/Wall/Draw.hs | 13 +++++---- src/Dodge/Zoning/Base.hs | 29 ++----------------- 5 files changed, 65 insertions(+), 80 deletions(-) diff --git a/src/Dodge/Debug/Picture.hs b/src/Dodge/Debug/Picture.hs index 9889b76d6..8b5379c0f 100644 --- a/src/Dodge/Debug/Picture.hs +++ b/src/Dodge/Debug/Picture.hs @@ -323,10 +323,9 @@ drawDDATest w = g [_,b,_,d] = color blue $ thickLine 2 [b,d] g _ = undefined ps = zoneOfSeg 50 x y - qs = map (zoneOfPoint 50) $ xIntercepts' 50 x y - rs = map (zoneOfPoint 50) $ yIntercepts' 50 x y - xs = xIntercepts' 50 x y --- xs' = xIntercepts' 50 x y + qs = map (zoneOfPoint 50) $ xIntercepts 50 x y + rs = map (zoneOfPoint 50) $ yIntercepts 50 x y + xs = xIntercepts 50 x y drawWallSearchRays :: World -> Picture drawWallSearchRays w = foldMap (f . fst) $ allVisibleWalls w diff --git a/src/Dodge/Door.hs b/src/Dodge/Door.hs index 0d3de47d9..2acfcb6e6 100644 --- a/src/Dodge/Door.hs +++ b/src/Dodge/Door.hs @@ -3,16 +3,12 @@ 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 @@ -25,7 +21,6 @@ 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 @@ -73,36 +68,3 @@ doorLerp speed dr w = fromMaybe (mempty, domounts (dr ^. drLerp) w) $ do 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/Wall/Damage.hs b/src/Dodge/Wall/Damage.hs index d7da0ee24..727b9a03a 100644 --- a/src/Dodge/Wall/Damage.hs +++ b/src/Dodge/Wall/Damage.hs @@ -1,8 +1,20 @@ +{-# LANGUAGE LambdaCase #-} {- | Controls a walls response to external damage. - Indestructible walls may still produce sparks, dust etc -} module Dodge.Wall.Damage (damageWall) where +import Linear +import Data.Maybe +import Dodge.LightSource +import Data.Foldable +import Dodge.ShiftPoint +import Dodge.Zoning.Pathing +import Dodge.Zoning.Base +import Dodge.Door.DoorLerp +import Dodge.Wall.Delete +import Dodge.Block.Debris +import qualified Data.IntMap.Strict as IM import Geometry.Data import Dodge.Material.Damage import Dodge.Block @@ -18,8 +30,8 @@ damageWall dt wl (is,w) = case _wlStructure wl of w' & cWorld . lWorld . blocks . ix blid . blHP -~ dmam & maybeDestroyBlock is blid DoorPart drid _ -> - f $ w' & cWorld . lWorld . doors . ix drid . drHP -~ dmam --- & maybeDestroyDoor drid + w' & cWorld . lWorld . doors . ix drid . drHP -~ dmam + & maybeDestroyDoor is drid _ -> f w' where f = (,) is @@ -34,7 +46,41 @@ maybeDestroyBlock is blid w = case w ^? cWorld . lWorld . blocks . ix blid of Just bl | _blHP bl < 1 -> destroyBlock is bl w _ -> (is,w) ---maybeDestroyDoor :: Int -> World -> World ---maybeDestroyDoor drid w = case w ^? cWorld . lWorld . doors . ix drid of --- Just dr | _drHP dr < 1 -> destroyDoor dr w --- _ -> w +maybeDestroyDoor :: S.Set Int2 -> Int -> World -> (S.Set Int2, World) +maybeDestroyDoor is drid w = case w ^? cWorld . lWorld . doors . ix drid of + Just dr | _drHP dr < 1 -> destroyDoor dr w + _ -> (is,w) + +destroyDoor :: Door -> World -> (S.Set Int2, World) +destroyDoor dr w = + ( is + , w + & makeDoorDebris dr + & deleteWallIDs wlids + & cWorld . lWorld . doors . at (dr ^. drID) .~ Nothing -- %~ 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/Wall/Draw.hs b/src/Dodge/Wall/Draw.hs index be45ae71e..4bb7ba52b 100644 --- a/src/Dodge/Wall/Draw.hs +++ b/src/Dodge/Wall/Draw.hs @@ -1,20 +1,23 @@ +{-# LANGUAGE LambdaCase #-} + module Dodge.Wall.Draw (drawWall) where -import Dodge.Material.Color +import Control.Lens import Dodge.Data.Wall +import Dodge.Material.Color import Picture.Base import ShapePicture -import Control.Lens drawWall :: WallDraw -> Wall -> SPic -drawWall wd = case wd of +drawWall = \case DrawForceField -> drawForceField drawForceField :: Wall -> SPic -drawForceField wl = noShape . setLayer BloomLayer +drawForceField wl = + noShape + . setLayer BloomLayer . setDepth 20 . color (materialColor (wl ^. wlMaterial)) --- . color (_wlColor wl) $ thickLine 5 [a, b] where (a, b) = _wlLine wl diff --git a/src/Dodge/Zoning/Base.hs b/src/Dodge/Zoning/Base.hs index 54b7a0352..8ff2769f0 100644 --- a/src/Dodge/Zoning/Base.hs +++ b/src/Dodge/Zoning/Base.hs @@ -11,8 +11,6 @@ module Dodge.Zoning.Base , zoneOfCirc , zonesAroundPoint , xIntercepts - , xIntercepts' - , yIntercepts' , yIntercepts , updateInt2Map ) where @@ -50,8 +48,7 @@ zoneOfPoint = fmap . divTo zoneOfSeg :: Float -> Point2 -> Point2 -> [Int2] {-# INLINE zoneOfSeg #-} ---zoneOfSeg s sp ep = map (zoneOfPoint s) (sp : xIntercepts s sp ep ++ yIntercepts s sp ep) -zoneOfSeg s sp ep = map (zoneOfPoint s) (sp : xIntercepts' s sp ep ++ yIntercepts' s sp ep) +zoneOfSeg s sp ep = map (zoneOfPoint s) (sp : xIntercepts s sp ep ++ yIntercepts s sp ep) zoneOfSegSet :: Float -> Point2 -> Point2 -> S.Set Int2 {-# INLINE zoneOfSegSet #-} @@ -68,23 +65,7 @@ zonesExtract = foldMap . flip zoneExtract xIntercepts :: Float -> Point2 -> Point2 -> [Point2] {-# INLINE xIntercepts #-} -xIntercepts s (V2 sx sy) (V2 ex ey) - | divTo s sx == divTo s ex = [] - | otherwise = zipWith V2 [halfstep + sx', halfstep + sx' + xdx * s .. ex] ([sy', sy' + ydx * s .. ey] ++ repeat ey) - where - halfstep - | xdx > 0 = -s/2 - | otherwise = s/2 - xdx = signum (ex - sx) - ydx = (ey - sy) / abs (ex - sx) -- carefull: if this is zero - sy' = sy + ydx * abs (sx - sx') - sx' - | xdx < 0 = sx - modTo s sx - | otherwise = s + sx - modTo s sx - -xIntercepts' :: Float -> Point2 -> Point2 -> [Point2] -{-# INLINE xIntercepts' #-} -xIntercepts' s (V2 sx sy) (V2 ex ey) +xIntercepts s (V2 sx sy) (V2 ex ey) | divTo s sx == divTo s ex = [] | otherwise = g <$> [a, a + s .. b] where @@ -100,12 +81,6 @@ yIntercepts s sp ep = map f $ xIntercepts s (f sp) (f ep) where f (V2 x y) = V2 y x -yIntercepts' :: Float -> Point2 -> Point2 -> [Point2] -{-# INLINE yIntercepts' #-} -yIntercepts' s sp ep = map f $ xIntercepts' s (f sp) (f ep) - where - f (V2 x y) = V2 y x - -- consider using: at x . non mempty . at y . non mempty <>~ a zoneMonoid :: Semigroup m => Int2 -> m -> IM.IntMap (IM.IntMap m) -> IM.IntMap (IM.IntMap m) {-# INLINE zoneMonoid #-}