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

Door destruction happens during door update, updates pathing

Browse Source
This commit is contained in:
justin
2025-10-22 22:47:10 +01:00
parent 151c037763
commit 0fd7ba46b5
9 changed files with 145 additions and 198 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Block.hs
-36
View File
@@ -1,7 +1,6 @@
module Dodge.Block (
splinterBlock,
destroyBlock,
destroyDoor,
) where
import Dodge.Zoning.Wall
@@ -13,10 +12,7 @@ import Data.Foldable
import qualified Data.IntSet as IS
import Data.Maybe
import Dodge.Block.Debris
import Dodge.Data.MountedObject
import Dodge.Data.World
import Dodge.DrWdWd
import Dodge.LightSource
import Dodge.Material.Sound
import Dodge.Wall.Delete
import Dodge.Wall.Zone
@@ -83,35 +79,3 @@ maybeClearPath w (i,j) = fromMaybe w $ do
---- w
---- & cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles .~ mempty) . FGL.delEdge (x, y)
destroyDoor :: Door -> World -> World
destroyDoor dr w =
w
& doDrWdWd (_drDeath dr) 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 (_drPushes dr)
& destroyMounts (_drMounts dr)
where
wlids = _drWallIDs dr
--awl = _walls (_cWorld w) IM.! IS.findMin wlids
-- awl = w ^?! cWorld . lWorld . walls . ix (IS.findMin wlids)
-- pos = fst . _wlLine $ awl
-- ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w
destroyMounts :: [MountedObject] -> World -> World
destroyMounts mos w = foldl' (flip destroyMount) w mos
destroyMount :: MountedObject -> World -> World
destroyMount mo = case mo of
MountedLS lsid -> destroyLS lsid
MountedProp prid -> cWorld . lWorld . props . at prid .~ Nothing
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 . drMech .~ DrWdId
& stopPushing (_drPushes dr)
src/Dodge/Data/Door.hs
-1
View File
@@ -37,7 +37,6 @@ data Door = Door
, _drLerp :: Float
, _drFootPrint :: IM.IntMap (Point2,Point2)
, _drHP :: Int
, _drDeath :: DrWdWd
, _drSpeed :: Float
, _drPushedBy :: PushSource
, _drPushes :: Maybe Int
src/Dodge/Data/WorldEffect.hs
+1 -4
View File
@@ -60,10 +60,7 @@ data WdP2f
= WdP2f0
| WdP2fDoorPosition Int
data DrWdWd
= DrWdId
| DrWdMakeDoorDebris
| DoorLerp
data DrWdWd = DrWdId | DoorLerp
deriveJSON defaultOptions ''ItCrWdWd
deriveJSON defaultOptions ''WdWd
src/Dodge/Default/Door.hs
-1
View File
@@ -42,7 +42,6 @@ defaultDoor =
, _drLerp = 0
, _drFootPrint = mempty
, _drHP = 10000
, _drDeath = DrWdMakeDoorDebris
, _drSpeed = 1
, _drPushedBy = PushesItself
, _drPushes = Nothing
src/Dodge/DrWdWd.hs
+51 -40
View File
@@ -1,12 +1,15 @@
module Dodge.DrWdWd (doDrWdWd,doDrWdWd') where
module Dodge.DrWdWd (updateDoor) where
import ListHelp
import Dodge.LightSource
import Data.Foldable
import Dodge.Wall.Delete
import Dodge.Block.Debris
import qualified Data.IntMap.Strict as IM
import Dodge.Zoning.Pathing
import Dodge.Zoning.Base
import Geometry.Data
import Control.Lens
import Data.Maybe
import Dodge.Block.Debris
import Dodge.Data.World
import Dodge.ShiftPoint
import Dodge.SoundLogic
@@ -14,47 +17,19 @@ import Dodge.Wall.Move
import Dodge.WorldBool
import qualified Data.Set as S
doDrWdWd :: DrWdWd -> Door -> World -> World
doDrWdWd dww = case dww of
DrWdId -> const id
DrWdMakeDoorDebris -> makeDoorDebris
DoorLerp -> doorLerp
updateDoor :: Door -> World -> (S.Set Int2, World)
updateDoor dr w
| dr ^. drHP < 1 = destroyDoor dr w
| DoorLerp <- dr ^. drMech = doorLerp dr w
| otherwise = (mempty,w)
doDrWdWd' :: Door -> World -> (S.Set Int2, World)
doDrWdWd' dr w = case dr ^. drMech of
DrWdId -> (mempty,w)
DrWdMakeDoorDebris -> (mempty, makeDoorDebris dr w)
DoorLerp -> doorLerp' dr w
doorLerp :: Door -> World -> World
doorLerp dr w = fromMaybe w $ do
x <- newlerp
return $
f x
& playSound x
& cWorld . lWorld . doors . ix drid . drLerp .~ x
where
f = ifoldl' (flip . moveWallID) w . wlposs
p2a = lerpP2A (dr ^. drZeroPos) (dr ^. drOnePos)
wlposs x = (dr ^. drFootPrint) & each . each %~ shiftPointBy (p2a 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
speed = _drSpeed dr
drid = _drID dr
playSound x
| _drPushedBy dr == PushesItself =
soundContinue (WallSound drid) (fst $ p2a x) slideDoorS (Just 1)
| otherwise = id
doorLerp' :: Door -> World -> (S.Set Int2,World)
doorLerp' dr w = fromMaybe (mempty,w) $ do
doorLerp :: Door -> World -> (S.Set Int2,World)
doorLerp dr w = fromMaybe (mempty,w) $ do
x <- newlerp
let ps = (dr ^. drFootPrint) & each . each %~ shiftPointBy (p2a x)
is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) ps
-- it seems possible that this will miss some paths: we add zones for the
-- old footprint. Seems unlikely, but a possible cause of pathfinding bugs
return $ (is,
f x
& playSound x
@@ -75,3 +50,39 @@ doorLerp' dr w = fromMaybe (mempty,w) $ do
| _drPushedBy dr == PushesItself =
soundContinue (WallSound drid) (fst $ p2a 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 (_drPushes dr)
& destroyMounts (_drMounts dr))
where
p2a = lerpP2A (dr ^. drZeroPos) (dr ^. drOnePos) (dr ^. drLerp)
ps = (dr ^. drFootPrint) & each . each %~ shiftPointBy p2a
is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) ps
wlids = _drWallIDs dr
--awl = _walls (_cWorld w) IM.! IS.findMin wlids
-- awl = w ^?! cWorld . lWorld . walls . ix (IS.findMin wlids)
-- pos = fst . _wlLine $ awl
-- ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w
destroyMounts :: [MountedObject] -> World -> World
destroyMounts mos w = foldl' (flip destroyMount) w mos
destroyMount :: MountedObject -> World -> World
destroyMount mo = case mo of
MountedLS lsid -> destroyLS lsid
MountedProp prid -> cWorld . lWorld . props . at prid .~ Nothing
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 . drMech .~ DrWdId
& stopPushing (_drPushes dr)
src/Dodge/Path.hs
+7 -7
View File
@@ -40,13 +40,13 @@ import Linear
getNodePos :: Int -> World -> Maybe Point2
getNodePos i w = w ^? cWorld . incNode . ix i
getEdgesCrossingPoly :: [Point2] -> World -> [(Int,Int)]
getEdgesCrossingPoly ps w = filter tcross $ zonesExtract (w ^. incEdgeZoning)
$ Set.toList $ foldMap (uncurry $ zoneOfSegSet peZoneSize) $ pairs
where
pairs = loopPairs ps
tcross (i,j) = any (isJust . uncurry (intersectSegSeg (f i) (f j))) pairs
f i = w ^?! cWorld . incNode . ix i
--getEdgesCrossingPoly :: [Point2] -> World -> [(Int,Int)]
--getEdgesCrossingPoly ps w = filter tcross $ zonesExtract (w ^. incEdgeZoning)
-- $ Set.toList $ foldMap (uncurry $ zoneOfSegSet peZoneSize) $ pairs
-- where
-- pairs = loopPairs ps
-- tcross (i,j) = any (isJust . uncurry (intersectSegSeg (f i) (f j))) pairs
-- f i = w ^?! cWorld . incNode . ix i
getEdgesCrossing :: Point2 -> Point2 -> World -> [(Int,Int)]
getEdgesCrossing s e w = filter inedgecrosses $ nearSeg peZoneSize _incEdgeZoning s e w
src/Dodge/Update.hs
+1 -17
View File
@@ -3,8 +3,6 @@
module Dodge.Update (updateUniverse) where
import Dodge.Zoning.Pathing
import Dodge.Debug.Picture
import Dodge.Zoning.Base
import Dodge.Path
import Data.Foldable
@@ -328,14 +326,8 @@ updateEdgeWallObs w (i,j) = fromMaybe w $ do
| otherwise = at DoorObstacle ?~ ()
updateDoors :: World -> World
updateDoors w = let (is,w') = foldrM doDrWdWd' w (w ^. cWorld . lWorld . doors)
updateDoors w = let (is,w') = foldrM updateDoor w (w ^. cWorld . lWorld . doors)
in updateEdgesWall (zonesExtract (w ^. incEdgeZoning & each . each %~ S.fromList) is) w'
& cWorld . lWorld . flares <>~ foldMap (drawZoneCol green peZoneSize) is
--updateDoors w = uncurry updateEdgesWall .
-- over _1 (zonesExtract (w ^. incEdgeZoning & each . each %~ S.fromList)) $ foldrM doDrWdWd' w (w ^. cWorld . lWorld . doors)
updateDoor :: Door -> World -> World
updateDoor dr = doDrWdWd (_drMech dr) dr
updateMagnets :: LWorld -> LWorld
updateMagnets lw =
@@ -561,14 +553,6 @@ updateIMl fim fup w = alaf Endo foldMap (dbArg fup) (fim w) w
updateIMl' :: (World -> IM.IntMap a) -> (a -> World -> World) -> World -> World
updateIMl' fim fup w = alaf Endo foldMap fup (fim w) w
updateAccum :: (Foldable f, Monoid m)
=> (World -> f a)
-> (a -> World -> (m, World))
-> World
-> (m, World)
updateAccum fim fup w = foldrM fup w (fim w)
--alaf Endo foldMap fup (fim w) w
updateCreatureGroups :: World -> World
updateCreatureGroups w =
w & cWorld . lWorld . creatureGroups
src/Dodge/Wall/Damage.hs
+5 -5
View File
@@ -20,7 +20,7 @@ damageWall dt wl w = case _wlStructure wl of
& maybeDestroyBlock blid
DoorPart drid ->
w' & cWorld . lWorld . doors . ix drid . drHP -~ x
& maybeDestroyDoor drid
-- & maybeDestroyDoor drid
_ -> w'
where
x = case dt of
@@ -34,7 +34,7 @@ maybeDestroyBlock blid w = case w ^? cWorld . lWorld . blocks . ix blid of
Just bl | _blHP bl < 1 -> destroyBlock bl w
_ -> 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 :: Int -> World -> World
--maybeDestroyDoor drid w = case w ^? cWorld . lWorld . doors . ix drid of
-- Just dr | _drHP dr < 1 -> destroyDoor dr w
-- _ -> w