justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Move wall destruction

Browse Source
This commit is contained in:
justin
2025-11-09 14:37:45 +00:00
parent 09f7cc309b
commit 5a40eac4e2
5 changed files with 65 additions and 80 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Debug/Picture.hs
+3 -4
View File
@@ -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
src/Dodge/Door.hs
-38
View File
@@ -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)
src/Dodge/Wall/Damage.hs
+52 -6
View File
@@ -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)
src/Dodge/Wall/Draw.hs
+8 -5
View File
@@ -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
src/Dodge/Zoning/Base.hs
+2 -27
View File
@@ -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 #-}