Make block damages slightly more logical

src/Dodge/Block.hs

@@ -44,6 +44,11 @@ matSplintSound mat = case mat of
     Wood  -> originIDsAt (BlockDegradeSound 1) [impact1S,impact2S,impact3S]
     Metal -> originIDsAt (BlockDegradeSound 1) [impact2S,impact3S]
 
+checkBlockHP :: Block -> World -> World
+checkBlockHP bl
+    | _blHP bl < 1 = destroyBlock bl
+    | otherwise = id
+
 destroyBlock :: Block -> World -> World
 destroyBlock bl w = w
     & flip (foldr unshadowBlock) (_blShadows bl)

src/Dodge/Data.hs

@@ -9,6 +9,7 @@ circular imports are probably not a good idea.
 {-# LANGUAGE DeriveGeneric #-}
 module Dodge.Data 
     ( module Dodge.Data
+    , module Dodge.Data.Wall
     , module Dodge.Combine.Data
     , module Dodge.Distortion.Data
     , module Dodge.Data.DamageType
@@ -27,6 +28,7 @@ module Dodge.Data
     , module Dodge.Data.Room
     ) where
 import Dodge.Data.Room
+import Dodge.Data.Wall
 import Dodge.RoomCluster.Data
 import Dodge.Data.ItemAmount
 import Dodge.ShortShow
@@ -927,8 +929,6 @@ data Block = Block
     , _blDraw       :: Block -> SPic
     , _blDeath      :: Block -> World -> World
     }
-data Material = Wood | Dirt | Stone | Glass | Metal | Crystal
-  deriving (Eq,Ord,Show,Bounded,Enum)
 data TerminalStatus = TerminalOff | TerminalBusy | TerminalReady
   deriving (Eq,Ord,Show)
 data TerminalInput = TerminalInput
@@ -1015,38 +1015,6 @@ data Door = Door
     }
 data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int
   deriving (Eq, Ord, Show)
-data Wall = Wall 
-    { _wlLine           :: (Point2,Point2) 
-    , _wlID             :: Int
-    , _wlColor          :: Color
-    , _wlSeen           :: Bool
-    , _wlOpacity        :: Opacity
-    , _wlPathable       :: Bool
-    , _wlWalkable       :: Bool
-    , _wlTouchThrough   :: Bool
-    , _wlFireThrough    :: Bool
-    , _wlReflect        :: Bool
-    , _wlDraw           :: Bool
-    , _wlRotateTo       :: Bool
-    , _wlStructure      :: WallStructure
-    , _wlHeight         :: Float
---    , _wlDamageEff      :: Damage -> Wall -> World -> World
-    , _wlMaterial       :: Material
-    }
-data Opacity
-    = SeeThrough
-    | SeeAbove
-    | DrawnWall {_opDraw :: Wall -> SPic}
-    | Opaque
-data WallStructure 
-    = StandaloneWall
-    | DoorPart    { _wsDoor    :: Int }
-    | MachinePart { _wsMachine :: Int }
-    | BlockPart   { _wsBlock   :: Int }
-    | CreaturePart 
-        { _wlStCreature :: Int 
---        , _wlStDamCreature :: Damage -> Wall -> Int -> World -> World
-        }
 
 data ActionPlan
     = Inanimate
@@ -1509,9 +1477,6 @@ makeLenses ''TweakParam
 makeLenses ''Prop
 makeLenses ''Modification
 makeLenses ''Particle
-makeLenses ''Wall
-makeLenses ''WallStructure
-makeLenses ''Opacity
 makeLenses ''PressPlate
 makeLenses ''Button
 makeLenses ''ActionPlan

src/Dodge/Data/Wall.hs

@@ -3,3 +3,44 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE DeriveGeneric #-}
 module Dodge.Data.Wall where
+import Geometry
+import Color
+import ShapePicture
+import Control.Lens
+data Wall = Wall 
+    { _wlLine           :: (Point2,Point2) 
+    , _wlID             :: Int
+    , _wlColor          :: Color
+    , _wlSeen           :: Bool
+    , _wlOpacity        :: Opacity
+    , _wlPathable       :: Bool
+    , _wlWalkable       :: Bool
+    , _wlTouchThrough   :: Bool
+    , _wlFireThrough    :: Bool
+    , _wlReflect        :: Bool
+    , _wlDraw           :: Bool
+    , _wlRotateTo       :: Bool
+    , _wlStructure      :: WallStructure
+    , _wlHeight         :: Float
+--    , _wlDamageEff      :: Damage -> Wall -> World -> World
+    , _wlMaterial       :: Material
+    }
+data Opacity
+    = SeeThrough
+    | SeeAbove
+    | DrawnWall {_opDraw :: Wall -> SPic}
+    | Opaque
+data WallStructure 
+    = StandaloneWall
+    | DoorPart    { _wsDoor    :: Int }
+    | MachinePart { _wsMachine :: Int }
+    | BlockPart   { _wsBlock   :: Int }
+    | CreaturePart 
+        { _wlStCreature :: Int 
+--        , _wlStDamCreature :: Damage -> Wall -> Int -> World -> World
+        }
+data Material = Wood | Dirt | Stone | Glass | Metal | Crystal
+  deriving (Eq,Ord,Show,Bounded,Enum)
+makeLenses ''Wall
+makeLenses ''WallStructure
+makeLenses ''Opacity

src/Dodge/Default/Wall.hs

@@ -2,7 +2,6 @@ module Dodge.Default.Wall
     where
 import Dodge.Data
 import Dodge.Block.Debris -- this dependency is (directly) for dirtColor
-import Dodge.Wall.DamageEffect
 import Picture
 import Geometry.Data
 {- Indestructible wall.  -}

src/Dodge/Item/Equipment.hs

@@ -161,11 +161,11 @@ shieldWall crid = defaultWall
     }
 
 -- TODO the reflection should be controled by the particle
-shieldWallDamage :: Damage -> Wall -> Int -> World -> World
+--shieldWallDamage :: Damage -> Wall -> Int -> World -> World
-shieldWallDamage dm _ crid w = case _dmType dm of
+--shieldWallDamage dm _ crid w = case _dmType dm of
---    Lasering -> w 
+----    Lasering -> w 
-    _ | isMovementDam dm -> w & creatures . ix crid . crState . crDamage .:~ dm
+--    _ | isMovementDam dm -> w & creatures . ix crid . crState . crDamage .:~ dm
-    _ -> w
+--    _ -> w
 
 createShieldWall :: Creature -> Int -> World -> World
 createShieldWall cr invid w = case _ieMID $ _itEffect it of

src/Dodge/Update.hs

@@ -6,7 +6,7 @@ module Dodge.Update ( updateUniverse ) where
 import Dodge.Data
 import Dodge.Menu
 import Dodge.CullBox
-import Dodge.Block
+--import Dodge.Block
 import Dodge.Distortion
 import Dodge.SoundLogic
 import Dodge.Wall.Delete
@@ -82,7 +82,7 @@ functionalUpdate cfig w = checkEndGame
         -- creatures should be updated early so that crOldPos is set before any position change
     . over creatures (fmap setOldPos)
     . updateCreatureGroups
-    . updateBlocks
+--    . updateBlocks
     . updateWallDamages
     . updateSeenWalls 
 --    . (youHammerPosition %~ moveHammerUp)
@@ -168,14 +168,6 @@ updateIMl fim fup w = foldl' (flip $ dbArg fup) w (fim w)
 updateIMl' :: (World -> IM.IntMap a) -> (a -> World -> World) -> World -> World
 updateIMl' fim fup w = foldl' (flip fup) w (fim w)
 
-updateBlocks :: World -> World
-updateBlocks w = foldr f w $ _blocks w
-  where
-    f bl w' = case _blHP bl of
---        x | x < 1 -> splinterBlock bl w'
-        x     | x < 1 -> destroyBlock bl w'
-        _ -> w'
-
 -- | Note the explict use of record syntax. Using lens created a space leak.
 resetWorldEvents :: World -> World
 resetWorldEvents w = w {_worldEvents = id}

src/Dodge/Update/WallDamage.hs

@@ -13,4 +13,4 @@ updateWallDamages w = w
   where
     f k dams w' = fromMaybe w' $ do
         wl <- w' ^? walls . ix k
-        return $ foldr (flip damageWall wl) w' dams
+        return $ foldr (`damageWall` wl) w' dams

src/Dodge/Wall/Damage.hs

@@ -6,35 +6,23 @@ module Dodge.Wall.Damage
     , damageWall
     ) where
 import Dodge.Data
+import Dodge.Block
 import LensHelp
 import Dodge.Wall.DamageEffect
 
 damageWall :: Damage -> Wall -> World -> World
-damageWall dt wl = case _wlStructure wl of
+damageWall dt wl w = case _wlStructure wl of
-    MachinePart mcid -> defaultWallDamage dt wl . (machines . ix mcid . mcDamage .:~ dt)
+    MachinePart mcid -> fst . defaultWallDamage dt wl $ w
-    BlockPart blid   -> defaultWallDamage dt wl . (blocks . ix blid %~ damageBlockWith dt)
+        & machines . ix mcid . mcDamage .:~ dt
---    CreaturePart crid f -> f dt wl crid
+    BlockPart blid   -> let (w',x) = defaultWallDamage dt wl w
-    _   -> defaultWallDamage dt wl
+        in w' & blocks . ix blid . blHP -~ x & maybeDestroyBlock blid
+    _   -> fst $ defaultWallDamage dt wl w
 
-damageBlockWith :: Damage -> Block -> Block
+-- block destruction is convoluted...
-damageBlockWith dm = case _dmType dm of
+maybeDestroyBlock :: Int -> World -> World
-    PIERCING    -> blHP -~ dam
+maybeDestroyBlock blid w = case w ^? blocks . ix blid of
-    BLUNT       -> blHP -~ dam
+    Just bl | _blHP bl < 1 -> destroyBlock bl w 
-    CUTTING     -> blHP -~ dam
+    _ -> w
-    EXPLOSIVE   -> blHP -~ dam
-    CONCUSSIVE  -> blHP -~ dam
-    SHATTERING  -> blHP -~ dam
-    CRUSHING    -> blHP -~ (dam `div` 4)
-    LASERING    -> id
-    SPARKING    -> id
-    FLAMING     -> id
-    ELECTRICAL  -> id
-    TORQUEDAM   -> id
-    PUSHDAM     -> id
-    POISONDAM   -> id
-    ENTERREMENT -> id
-  where
-    dam = _dmAmount dm
 
 damageBlocksBy :: Int -> Wall -> World -> World
 damageBlocksBy x wl = case wl ^? wlStructure . wsBlock of

src/Dodge/Wall/DamageEffect.hs

@@ -8,62 +8,103 @@ import Dodge.Block
 import Geometry
 import LensHelp
 
+import Data.Bifunctor
 import Control.Monad.State
-import Data.Maybe
+--import Data.Maybe
 
-defaultWallDamage :: Damage -> Wall -> World -> World
+defaultWallDamage :: Damage -> Wall -> World -> (World,Int)
-defaultWallDamage dm wl = wallDamageEffect dm wl . case _dmType dm of
+defaultWallDamage dm wl = flip (.) (wallDamageEffect dm wl) $ case _wlMaterial wl of
-    LASERING    -> colSparkRandDir 0.2 8 lSparkCol outTo (reflDirWall sp p wl)
+    Stone   -> stoneWallDamage dm wl
-    PIERCING    -> colSparkRandDir 0.2 8 pSparkCol outTo (reflDirWall sp p wl) . wlDustAt wl outTo
+    Glass   -> windowWallDamage dm wl
-    BLUNT       -> wlDustAt wl outTo
+    Dirt    -> dirtWallDamage dm wl
-    SHATTERING  -> muchWlDustAt wl outTo
+    _ -> second (const 0) . stoneWallDamage dm wl
-    CRUSHING    -> id
+
-    EXPLOSIVE   -> id
+stoneWallDamage :: Damage -> Wall -> World -> (World,Int)
-    CUTTING     -> id
+stoneWallDamage dm wl = case _dmType dm of
-    SPARKING    -> id
+    LASERING    -> a 0 $ colSparkRandDir 0.2 8 lSparkCol outTo (reflDirWall sp p wl)
-    FLAMING     -> id
+    PIERCING    -> a d $ colSparkRandDir 0.2 8 pSparkCol outTo (reflDirWall sp p wl) . wlDustAt wl outTo
-    ELECTRICAL  -> id
+    BLUNT       -> a d $ wlDustAt wl outTo
-    CONCUSSIVE  -> id
+    SHATTERING  -> a d $ muchWlDustAt wl outTo
-    TORQUEDAM   -> id
+    CRUSHING    -> a d $ id
-    PUSHDAM     -> id
+    EXPLOSIVE   -> a d $ id
-    POISONDAM   -> id
+    CUTTING     -> a d $ id
-    ENTERREMENT -> id
+    SPARKING    -> a 0 $ id
+    FLAMING     -> a 0 $ id
+    ELECTRICAL  -> a 0 $ id
+    CONCUSSIVE  -> a d $ id
+    TORQUEDAM   -> a 0 $ id
+    PUSHDAM     -> a 0 $ id
+    POISONDAM   -> a 0 $ id
+    ENTERREMENT -> a 0 $ id
   where
+    a x f w = (f w,x)
+    d = _dmAmount dm
     sp = _dmFrom dm
     p = _dmAt dm
     outTo = p +.+ squashNormalizeV (sp -.- p)
     pSparkCol = V4 5 1 0.5 2
     lSparkCol = V4 20 (-5) 0 1
 
-windowWallDamage :: Damage -> Wall -> World -> World
+windowWallDamage :: Damage -> Wall -> World -> (World,Int)
-windowWallDamage dm wl = wallDamageEffect dm wl . case _dmType dm of
+windowWallDamage dm wl w = w & case _dmType dm of
-    LASERING    -> colSparkRandDir 0.2 8 lSparkCol outTo (reflDirWall sp p wl)
+    LASERING    -> a 0 $ colSparkRandDir 0.2 8 lSparkCol outTo (reflDirWall sp p wl)
-    PIERCING    -> dosplint . colSparkRandDir 0.2 8 pSparkCol outTo (reflDirWall sp p wl) . wlDustAt wl outTo
+    PIERCING    -> a d $ dosplint . colSparkRandDir 0.2 8 pSparkCol outTo (reflDirWall sp p wl) . wlDustAt wl outTo
-    BLUNT       -> dosplint . wlDustAt wl outTo
+    BLUNT       -> a d $ dosplint . wlDustAt wl outTo
-    SHATTERING  -> dosplint . muchWlDustAt wl outTo
+    SHATTERING  -> a d $ dosplint . muchWlDustAt wl outTo
-    CRUSHING    -> dosplint
+    CRUSHING    -> a d $ dosplint
-    EXPLOSIVE   -> dosplint
+    EXPLOSIVE   -> a d $ dosplint
-    CUTTING     -> dosplint
+    CUTTING     -> a d $ dosplint
-    SPARKING    -> id
+    SPARKING    -> a 0 $ id
-    FLAMING     -> id
+    FLAMING     -> a 0 $ id
-    ELECTRICAL  -> id
+    ELECTRICAL  -> a 0 $ id
-    CONCUSSIVE  -> dosplint
+    CONCUSSIVE  -> a 0 $ dosplint
-    TORQUEDAM   -> id
+    TORQUEDAM   -> a 0 $ id
-    PUSHDAM     -> id
+    PUSHDAM     -> a 0 $ id
-    POISONDAM   -> id
+    POISONDAM   -> a 0 $ id
-    ENTERREMENT -> id
+    ENTERREMENT -> a 0 $ id
   where
-    dosplint w = fromMaybe w $ do
+    mbl = do 
         blid <- wl ^? wlStructure . wsBlock
-        bl   <- w ^? blocks . ix blid
+        w ^? blocks . ix blid
-        return $ splinterBlock bl w
+    d :: Int
-            & blocks . ix blid . blHP %~ min 1
+    d = max 1 $ maybe 1 (subtract 1 . _blHP) mbl
+    a :: Int -> (World -> World) -> World -> (World,Int)
+    a x f w' = (f w',x)
+    dosplint = maybe id splinterBlock mbl
+       --  fromMaybe w $ do
+       -- blid <- wl ^? wlStructure . wsBlock
+       -- bl   <- w ^? blocks . ix blid
+       -- return $ splinterBlock bl w
+--            & blocks . ix blid . blHP %~ min 1
     sp = _dmFrom dm
     p = _dmAt dm
     outTo = p +.+ squashNormalizeV (sp -.- p)
     pSparkCol = V4 5 1 0.5 2
     lSparkCol = V4 20 (-5) 0 1
 
+dirtWallDamage :: Damage -> Wall -> World -> (World,Int)
+dirtWallDamage dm wl = case _dmType dm of
+    LASERING    -> a d $ wlDustAt wl outTo
+    PIERCING    -> a d $ wlDustAt wl outTo
+    BLUNT       -> a d $ wlDustAt wl outTo
+    SHATTERING  -> a d $ muchWlDustAt wl outTo
+    CRUSHING    -> a d $ id
+    EXPLOSIVE   -> a d $ id
+    CUTTING     -> a d $ id
+    SPARKING    -> a 0 $ id
+    FLAMING     -> a 0 $ id
+    ELECTRICAL  -> a 0 $ id
+    CONCUSSIVE  -> a d $ id
+    TORQUEDAM   -> a 0 $ id
+    PUSHDAM     -> a 0 $ id
+    POISONDAM   -> a 0 $ id
+    ENTERREMENT -> a 0 $ id
+  where
+    a x f w = (f w,x)
+    d = _dmAmount dm
+    sp = _dmFrom dm
+    p = _dmAt dm
+    outTo = p +.+ squashNormalizeV (sp -.- p)
 
 wallDamageEffect :: Damage -> Wall -> World -> World
 wallDamageEffect dm wl w = case _dmEffect dm of