Commit before apply different damage amounts to different materials

src/Dodge/Block.hs

@@ -1,39 +1,36 @@
 {-# LANGUAGE LambdaCase #-}
 
-module Dodge.Block (
-    splinterBlock,
-    destroyBlock,
-) where
+module Dodge.Block (destroyBlock) where
 
 import qualified Data.Set as S
 import Control.Lens
 import Control.Monad
 import Data.Foldable
-import qualified Data.IntSet as IS
+--import qualified Data.IntSet as IS
 import Data.Maybe
 import Dodge.Base.Collide
 import Dodge.Block.Debris
 import Dodge.Data.World
-import Dodge.Material.Sound
+--import Dodge.Material.Sound
 import Dodge.Path
 import Dodge.Wall.Delete
 import Dodge.Wall.Zone
-import Dodge.WorldEvent.Sound
+--import Dodge.WorldEvent.Sound
 import Dodge.Zoning.Wall
 import qualified IntMapHelp as IM
 
-splinterBlock :: Block -> World -> World
-splinterBlock bl w =
-    foldl' unshadowBlock w (_blShadows bl) -- foldr shiftTowardCen w (_blWallIDs bl)
-        & soundOriginsIDsAt
-            [MaterialSound bm 0, MaterialSound bm 1, MaterialSound bm 2]
-            (weakenMatS bm)
-            (_blPos bl)
-  where
-    bm = fromMaybe Stone $ do
-        wlids <- w ^? cWorld . lWorld . blocks . ix (_blID bl) . blWallIDs
-        (wlid, _) <- IS.minView wlids
-        w ^? cWorld . lWorld . walls . ix wlid . wlMaterial
+--splinterBlock :: Block -> World -> World
+--splinterBlock bl w =
+--    foldl' unshadowBlock w (_blShadows bl) -- foldr shiftTowardCen w (_blWallIDs bl)
+--        & soundOriginsIDsAt
+--            [MaterialSound bm 0, MaterialSound bm 1, MaterialSound bm 2]
+--            (weakenMatS bm)
+--            (_blPos bl)
+--  where
+--    bm = fromMaybe Stone $ do
+--        wlids <- w ^? cWorld . lWorld . blocks . ix (_blID bl) . blWallIDs
+--        (wlid, _) <- IS.minView wlids
+--        w ^? cWorld . lWorld . walls . ix wlid . wlMaterial
 
 unshadowBlock :: World -> Int -> World
 unshadowBlock w wlid = case w ^? cWorld . lWorld . walls . ix wlid of

src/Dodge/Data/Block.hs

@@ -21,13 +21,13 @@ data Block = Block
     { _blID :: Int
     , _blWallIDs :: IS.IntSet
     , _blHP :: Int
-    , _blShadows :: [Int] -- a list of blocks/walls? that are not shown when this block exists
+    , _blShadows :: [Int] -- a list of walls that are not shown when this block exists
     , _blFootprint :: [Point2]  -- TODO check whether this should be clockwise/anticlockwise
     , _blPos :: Point2
     , _blDir :: Float
     , _blHeight :: Float
     , _blMaterial :: Material
-    , _blDraw :: BlockDraw --Block -> SPic
+    , _blDraw :: BlockDraw
     , _blObstructs :: [(Int,Int)]
     }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)

src/Dodge/Item/Weapon/Shatter.hs

@@ -1,38 +1,40 @@
 module Dodge.Item.Weapon.Shatter (shootShatter) where
 
-import Linear
-import Dodge.Base.Collide
-import Dodge.Block.Debris
+--import Linear
+--import Dodge.Base.Collide
+--import Dodge.Block.Debris
 import Dodge.Data.World
-import Dodge.Wall.Damage
-import Geometry
-import LensHelp
+--import Dodge.Wall.Damage
+--import Geometry
+--import LensHelp
 
 
 shootShatter :: Item -> Creature -> World -> World
-shootShatter _ cr w =
-    maybe w (uncurry $ shatterWall w sp ep) $
-        sequence $
-            collidePointWallsFilter canshatter sp ep w
-  where
-    canshatter wl = case _wlOpacity wl of
-        Opaque {} -> True
-        SeeThrough -> True
-        _ -> False
-    sp = cr ^. crPos ._xy +.+ 10 *.* unitVectorAtAngle dir
-    -- the 10 is arbtrary and should be changed to a muzzle position
-    dir = _crDir cr
-    ep = sp +.+ 200 *.* unitVectorAtAngle dir
-
-shatterWall :: World -> Point2 -> Point2 -> Point2 -> Wall -> World
-shatterWall w sp ep p wl =
-    w
---        & makeDebris (_wlMaterial wl) (_wlColor wl) p
-        & makeDebris (_wlMaterial wl)  p
-        & makeDebrisDirected
-            (pi / 2)
-            (argV $ vNormal $ uncurry (-) $ _wlLine wl)
-            (_wlMaterial wl)
---            (_wlColor wl)
-            p
-        & damageWall (Shattering 1000 p (ep - sp)) wl
+shootShatter _ _ w = w
+--shootShatter _ cr w =
+--    maybe w (uncurry $ shatterWall w sp ep) $
+--        sequence $
+--            collidePointWallsFilter canshatter sp ep w
+--  where
+--    canshatter wl = case _wlOpacity wl of
+--        Opaque {} -> True
+--        SeeThrough -> True
+--        _ -> False
+--    sp = cr ^. crPos ._xy +.+ 10 *.* unitVectorAtAngle dir
+--    -- the 10 is arbtrary and should be changed to a muzzle position
+--    dir = _crDir cr
+--    ep = sp +.+ 200 *.* unitVectorAtAngle dir
+--
+--shatterWall :: World -> Point2 -> Point2 -> Point2 -> Wall -> World
+----shatterWall w sp ep p wl =
+--shatterWall w sp ep p wl =
+--    w
+----        & makeDebris (_wlMaterial wl) (_wlColor wl) p
+--        & makeDebris (_wlMaterial wl)  p
+--        & makeDebrisDirected
+--            (pi / 2)
+--            (argV $ vNormal $ uncurry (-) $ _wlLine wl)
+--            (_wlMaterial wl)
+----            (_wlColor wl)
+--            p
+----        & damageWall (Shattering 1000 p (ep - sp)) wl

src/Dodge/Placement/PlaceSpot.hs

@@ -6,15 +6,15 @@
 -}
 module Dodge.Placement.PlaceSpot (placeSpot) where
 
-import Dodge.Default.Wall
-import qualified Data.Set as S
 import Control.Monad.State
 import Data.Bifunctor
 import Data.Foldable
 import qualified Data.IntSet as IS
 import Data.Maybe
+import qualified Data.Set as S
 import Dodge.Base.NewID
 import Dodge.Data.GenWorld
+import Dodge.Default.Wall
 import Dodge.Path
 import Dodge.Placement.PlaceSpot.Block
 import Dodge.Placement.PlaceSpot.TriggerDoor
@@ -134,7 +134,7 @@ placeSpotID rid ps pt w = case pt of
     PutMachine pps mc mitm -> plMachine (map doShift pps) mc mitm p rot w
     PutLS ls -> plNewUpID (gwWorld . cWorld . lWorld . lightSources) lsID (mvLS p' rot ls) w
     RandPS _ -> error "RandPS should not be reachable here" --evaluateRandPS rid rgn ps w
-    PutDoor eo f l p1 p2 -> plDoor eo f l (pashift p1) (pashift p2)  w
+    PutDoor eo f l p1 p2 -> plDoor eo f l (pashift p1) (pashift p2) w
     PutCoord cp -> plNewID (gwWorld . coordinates) (doShift cp) w
     PutSlideDr wl dr eo off a b ->
         plSlideDoor wl dr eo off (doShift a) (doShift b) w
@@ -165,7 +165,7 @@ placeChasm gw rid ps shiftps =
         & gwWorld %~ f
   where
     f w = foldl' g w (loopPairs shiftps)
-    g w (x,y) = fst $ obstructPathsCrossing (S.singleton ChasmObstacle) x y w
+    g w (x, y) = fst $ obstructPathsCrossing (S.singleton ChasmObstacle) x y w
 
 --evaluateRandPS
 --    :: Int -> State StdGen PSType -> PlacementSpot -> GenWorld -> (Int, GenWorld)
@@ -211,51 +211,24 @@ plMachine ::
     Float ->
     GenWorld ->
     (Int, GenWorld)
-plMachine wallpoly mc = \case
-    Nothing -> plMachine' wallpoly mc 
-    Just itm -> plTurret wallpoly mc  itm
-
-plTurret ::
-    [Point2] ->
-    Machine ->
---    Wall ->
-    Item ->
-    Point2 ->
-    Float ->
-    GenWorld ->
-    (Int, GenWorld)
-plTurret wallpoly mc itm p rot gw =
+plMachine wallpoly mc mitm p rot gw =
     ( mcid
-    , gw & gwWorld . cWorld . lWorld . machines %~ addMc
-        & gwWorld . cWorld . lWorld . walls %~ placeMachineWalls wallpoly mcid wlid
-        & gwWorld . cWorld . lWorld . items . at itid ?~ itm'
+    , gw & tolw . machines . at mcid ?~ themc
+        & tolw . walls %~ placeMachineWalls wallpoly mcid wlid
+        & tolw %~ maybe id placeturretitm mitm
     )
   where
-    itm' =
-        itm & itID .~ NInt itid
-            & itLocation .~ OnTurret mcid
-    itid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . items
+    tolw = gwWorld . cWorld . lWorld
     mcid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . machines
     wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls
-    wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
-    addMc =
-        IM.insert
-            mcid
-            ( mc{_mcPos = p, _mcDir = rot, _mcID = mcid, _mcWallIDs = wlids}
-                & mcType . mctTurret . tuWeapon .~ itid
-            )
-
-plMachine' :: [Point2] -> Machine ->  Point2 -> Float -> GenWorld -> (Int, GenWorld)
-plMachine' wallpoly mc p rot gw =
-    ( mcid
-    , gw & gwWorld . cWorld . lWorld . machines %~ addMc
-        & gwWorld . cWorld . lWorld . walls %~ placeMachineWalls wallpoly mcid wlid
-    )
-  where
-    mcid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . machines
-    wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls
-    wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
-    addMc = IM.insert mcid (mc{_mcPos = p, _mcDir = rot, _mcID = mcid, _mcWallIDs = wlids})
+    wlids = IS.fromList $ take (length wallpoly) [wlid ..]
+    themc = mc{_mcPos = p, _mcDir = rot, _mcID = mcid, _mcWallIDs = wlids}
+    placeturretitm itm =
+        (items . at itid ?~ itm')
+            . (machines . ix mcid . mcType . mctTurret . tuWeapon .~ itid)
+      where
+        itid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . items
+        itm' = itm & itID .~ NInt itid & itLocation .~ OnTurret mcid
 
 -- TODO correctly remove/shift pathfinding lines (removePathsCrossing)
 placeMachineWalls :: [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall

src/Dodge/Update.hs

@@ -250,7 +250,6 @@ functionalUpdate =
         . over uvWorld updateCreatureSoundPositions
         . colCrsWalls
         . over uvWorld simpleCrSprings
---        . over uvWorld (updateIMl' (_doors . _lWorld . _cWorld) updateDoor)
         . over uvWorld updateDoors
         . over uvWorld doWorldEvents
         . over uvWorld updateDelayedEvents
@@ -290,8 +289,7 @@ functionalUpdate =
         -- creatures should be updated early so that crOldPos is set before any position change
         . over (uvWorld . cWorld . lWorld . creatures) (fmap setOldPos)
         . over uvWorld updateCreatureGroups
-        . over uvWorld updateWallDamages
-        --        . over uvWorld updateSeenWalls
+        . over uvWorld updateWallDamages -- can potentially be combined in some way with update doors so that only one pathing update needs to be done...
         . over uvWorld checkTermDist
         . over uvWorld updateRBList
         . over uvWorld updateCloseObjects

src/Dodge/Wall/Damage.hs

@@ -1,10 +1,7 @@
 {- | Controls a walls response to external damage.
  - Indestructible walls may still produce sparks, dust etc
 -}
-module Dodge.Wall.Damage (
---    damageBlocksBy,
-    damageWall,
-) where
+module Dodge.Wall.Damage (damageWall) where
 
 import Dodge.Material.Damage
 import Dodge.Block