This commit is contained in:
2025-10-24 11:16:30 +01:00
parent 18ab89d3f2
commit 27569ed8f3
11 changed files with 50 additions and 49 deletions
-2
View File
@@ -1,5 +1,3 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.Block (destroyBlock) where module Dodge.Block (destroyBlock) where
import ListHelp import ListHelp
+1 -1
View File
@@ -25,7 +25,7 @@ doWdCrBl wcb = case wcb of
False False
(\cid -> canSee (_crID cr) cid w) (\cid -> canSee (_crID cr) cid w)
(_targetCr (_crIntention cr)) (_targetCr (_crIntention cr))
WdCrSafeDistFromTarget x -> \w -> crSafeDistFromTarg w x -- currently ignores walls etc WdCrSafeDistFromTarget x -> (`crSafeDistFromTarg` x) -- currently ignores walls etc
doCrBl :: CrBl -> Creature -> Bool doCrBl :: CrBl -> Creature -> Bool
doCrBl cb = case cb of doCrBl cb = case cb of
+2 -2
View File
@@ -28,9 +28,9 @@ doorLerp speed dr w = fromMaybe (mempty,w) $ do
x <- newlerp x <- newlerp
let ps = wlposs x let ps = wlposs x
is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) ps is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) ps
-- it seems possible that this will miss some paths: we add zones for the -- 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 -- old footprint. Seems unlikely, but a possible cause of pathfinding bugs
return $ (is, return (is,
f x f x
& playSound x & playSound x
& cWorld . lWorld . doors . ix drid . drLerp .~ x) & cWorld . lWorld . doors . ix drid . drLerp .~ x)
+17 -17
View File
@@ -38,14 +38,14 @@ damageStone dm ecw w = case dm of
. randsound p [slapS, slap1S] . randsound p [slapS, slap1S]
Blunt _ p t -> f dmam $ makeDustAt Stone 200 (addZ 20 (outTo p t)) Blunt _ p t -> f dmam $ makeDustAt Stone 200 (addZ 20 (outTo p t))
Shattering _ p t -> f dmam $ makeDustAt Stone 200 (addZ 20 (outTo p t)) Shattering _ p t -> f dmam $ makeDustAt Stone 200 (addZ 20 (outTo p t))
Crushing{} -> f dmam $ id Crushing{} -> f dmam id
Explosive{} -> f dmam $ id Explosive{} -> f dmam id
Sparking{} -> f 0 $ id Sparking{} -> f 0 id
Flaming{} -> f 0 $ id Flaming{} -> f 0 id
Electrical{} -> f 0 $ id Electrical{} -> f 0 id
Poison{} -> f 0 $ id Poison{} -> f 0 id
Enterrement{} -> f 0 $ id Enterrement{} -> f 0 id
Flashing{} -> f 0 $ id Flashing{} -> f 0 id
where where
f x g = (x, g w) f x g = (x, g w)
dmam = dm ^. dmAmount dmam = dm ^. dmAmount
@@ -69,15 +69,15 @@ damageMetal dm ecw w = case dm of
Blunt _ p t -> f dmam $ Blunt _ p t -> f dmam $
makeSpark NormalSpark (outTo p t) (rdir p t) makeSpark NormalSpark (outTo p t) (rdir p t)
. randsound p [clangS,clang1S,clang2S] . randsound p [clangS,clang1S,clang2S]
Shattering {} -> f dmam $ id Shattering {} -> f dmam id
Crushing{} -> f dmam $ id Crushing{} -> f dmam id
Explosive{} -> f dmam $ id Explosive{} -> f dmam id
Sparking{} -> f 0 $ id Sparking{} -> f 0 id
Flaming{} -> f 0 $ id Flaming{} -> f 0 id
Electrical{} -> f 0 $ id Electrical{} -> f 0 id
Poison{} -> f 0 $ id Poison{} -> f 0 id
Enterrement{} -> f 0 $ id Enterrement{} -> f 0 id
Flashing{} -> f 0 $ id Flashing{} -> f 0 id
where where
f x g = (x, g w) f x g = (x, g w)
dmam = dm ^. dmAmount dmam = dm ^. dmAmount
+2 -2
View File
@@ -101,11 +101,11 @@ smallSnailInt2 =
[V2 x y | x <- [-2 .. 2], y <- [-2 .. 2]] [V2 x y | x <- [-2 .. 2], y <- [-2 .. 2]]
makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2] makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
makePathBetweenPs a b w = traverse (flip getNodePos w) =<< makePathBetween a b w makePathBetweenPs a b w = traverse (`getNodePos` w) =<< makePathBetween a b w
-- assumes that pathfinding is symmetric -- assumes that pathfinding is symmetric
pointTowardsImpulse :: Point2 -> Point2 -> World -> Maybe Point2 pointTowardsImpulse :: Point2 -> Point2 -> World -> Maybe Point2
pointTowardsImpulse a b w = (find $ flip (isWalkable a) w) =<< makePathBetweenPs b a w pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs b a w
pairsToIncGraph :: pairsToIncGraph ::
Set.Set (Point2, Point2) -> Set.Set (Point2, Point2) ->
+1 -1
View File
@@ -1,4 +1,4 @@
{-# LANGUAGE LambdaCase #-} --{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{- | deals with placement of objects within the world {- | deals with placement of objects within the world
+1 -1
View File
@@ -44,7 +44,7 @@ plDoor eo cond l p1 p2 gw = (drid, over gwWorld addWalls $ gw & gwWorld . cWorld
wlids = take 4 [IM.newKey $ _walls (_lWorld (_cWorld $ _gwWorld gw)) ..] wlids = take 4 [IM.newKey $ _walls (_lWorld (_cWorld $ _gwWorld gw)) ..]
wlps' = rectanglePairs 9 0 (V2 l 0) wlps' = rectanglePairs 9 0 (V2 l 0)
--addWalls w' = foldl' (addDoorWall eo drid $ switchWallCol col) w' $ zip wlids --addWalls w' = foldl' (addDoorWall eo drid $ switchWallCol col) w' $ zip wlids
addWalls w' = foldl' (addDoorWall eo drid $ defaultSwitchWall) w' $ zip wlids addWalls w' = foldl' (addDoorWall eo drid defaultSwitchWall) w' $ zip wlids
$ wlps' & each . each %~ shiftPointBy p1 $ wlps' & each . each %~ shiftPointBy p1
addDoorWall :: S.Set EdgeObstacle addDoorWall :: S.Set EdgeObstacle
+1 -4
View File
@@ -3,8 +3,6 @@
module Dodge.Update (updateUniverse) where module Dodge.Update (updateUniverse) where
import Dodge.Zoning.Base
--import Dodge.Path
import Data.Foldable import Data.Foldable
import qualified Data.Set as S import qualified Data.Set as S
import Color import Color
@@ -322,8 +320,7 @@ updateAimPos u =
-- f x _ = S.map WallObstacle x -- f x _ = S.map WallObstacle x
updateDoors :: World -> World updateDoors :: World -> World
updateDoors w = let (is,w') = foldrM updateDoor w (w ^. cWorld . lWorld . doors) updateDoors w = uncurry updateEdgesWall $ foldrM updateDoor w (w ^. cWorld . lWorld . doors)
in updateEdgesWall (zonesExtract (w ^. incEdgeZoning & each . each %~ S.fromList) is) w'
updateMagnets :: LWorld -> LWorld updateMagnets :: LWorld -> LWorld
updateMagnets lw = updateMagnets lw =
+23 -17
View File
@@ -1,35 +1,41 @@
module Dodge.Update.WallDamage (updateWallDamages,updateEdgesWall) where module Dodge.Update.WallDamage (updateWallDamages, updateEdgesWall) where
import Dodge.WorldEvent.ThingsHit import Geometry.Data
import Dodge.Path
import Dodge.Zoning.Base
import Control.Lens import Control.Lens
import Data.Maybe
import Dodge.Data.World
import Dodge.Wall.Damage
import qualified IntMapHelp as IM
import Data.Foldable import Data.Foldable
import Data.Maybe
import qualified Data.Set as S import qualified Data.Set as S
import Dodge.Data.World
import Dodge.Path
import Dodge.Wall.Damage
import Dodge.WorldEvent.ThingsHit
import Dodge.Zoning.Base
import qualified IntMapHelp as IM
updateWallDamages :: World -> World updateWallDamages :: World -> World
updateWallDamages w = updateWallDamages w =
let (is,w') let (is, w') =
= IM.foldlWithKey' f (mempty,w) (w ^. cWorld . lWorld . wallDamages) IM.foldlWithKey' f (mempty, w) (w ^. cWorld . lWorld . wallDamages)
in updateEdgesWall (zonesExtract (w ^. incEdgeZoning & each . each %~ S.fromList) is) w' in updateEdgesWall is
w'
& cWorld . lWorld . wallDamages .~ IM.empty & cWorld . lWorld . wallDamages .~ IM.empty
where where
f isw k dams = fromMaybe isw $ do f isw k dams = fromMaybe isw $ do
wl <- isw ^? _2 . cWorld . lWorld . walls . ix k wl <- isw ^? _2 . cWorld . lWorld . walls . ix k
return $ foldl' (flip (`damageWall` wl)) isw dams return $ foldl' (flip (`damageWall` wl)) isw dams
updateEdgesWall :: S.Set (Int,Int) -> World -> World updateEdgesWall :: S.Set Int2 -> World -> World
updateEdgesWall = flip $ foldl' updateEdgeWallObs updateEdgesWall is w = updateEdgesWall'
(zonesExtract (w ^. incEdgeZoning & each . each %~ S.fromList) is) w
updateEdgeWallObs :: World -> (Int,Int) -> World updateEdgesWall' :: S.Set (Int, Int) -> World -> World
updateEdgeWallObs w (i,j) = fromMaybe w $ do updateEdgesWall' = flip $ foldl' updateEdgeWallObs
updateEdgeWallObs :: World -> (Int, Int) -> World
updateEdgeWallObs w (i, j) = fromMaybe w $ do
s <- getNodePos i w s <- getNodePos i w
e <- getNodePos j w e <- getNodePos j w
let wlflags = foldMap (^. _2 . wlPathFlag) $ wlsHitUnsorted s e w let wlflags = foldMap (^. _2 . wlPathFlag) $ wlsHitUnsorted s e w
return $ w & cWorld . incGraph %~ updateEdge (f wlflags) (i,j) return $ w & cWorld . incGraph %~ updateEdge (f wlflags) (i, j)
where where
f x _ = S.map WallObstacle x f x _ = S.map WallObstacle x
+1 -1
View File
@@ -20,7 +20,7 @@ damageWall dt wl (is,w) = case _wlStructure wl of
DoorPart drid -> DoorPart drid ->
f $ w' & cWorld . lWorld . doors . ix drid . drHP -~ dmam f $ w' & cWorld . lWorld . doors . ix drid . drHP -~ dmam
-- & maybeDestroyDoor drid -- & maybeDestroyDoor drid
_ -> f $ w' _ -> f w'
where where
f = (,) is f = (,) is
-- x = case dt of -- x = case dt of
+1 -1
View File
@@ -1,4 +1,4 @@
{-# LANGUAGE BangPatterns #-} --{-# LANGUAGE BangPatterns #-}
module Dodge.Wall.Move ( module Dodge.Wall.Move (
moveWallID, moveWallID,