Control wall damage effects using the wall

src/Dodge/Default.hs

@@ -218,15 +218,15 @@ defaultMachine = Machine
     , _mcDraw = const mempty
     , _mcPos = V2 0 0
     , _mcDir = 0
-    , _mcHP = 100
+    , _mcHP = 1000
     , _mcSensor = 0
     , _mcDamage = []
     }
 defaultMachineUpdate :: Machine -> World -> World
-defaultMachineUpdate mc w 
-    | _mcHP mc < 1 = w & machines %~ IM.delete mcid
-        & deleteWallIDs (_mcWallIDs mc)
-    | otherwise = w & machines . ix mcid %~ ( (mcDamage .~ []) . (mcHP -~ dams) )
+defaultMachineUpdate mc
+    | _mcHP mc < 1 = (machines %~ IM.delete mcid)
+        . deleteWallIDs (_mcWallIDs mc)
+    | otherwise = machines . ix mcid %~ ( (mcDamage .~ []) . (mcHP -~ dams) )
   where
     dams = sum $ map _dmAmount $ _mcDamage mc 
     mcid = _mcID mc

src/Dodge/Item/Weapon/BatteryGuns.hs

@@ -9,7 +9,7 @@ import Dodge.SoundLogic.LoadSound
 import Dodge.Creature.State.Data
 import Dodge.Data.DamageType
 import Dodge.WorldEvent
-import Dodge.WorldEvent.DamageBlock
+import Dodge.Wall.Damage
 import Dodge.Default
 import Dodge.Item.Draw
 import Dodge.Item.Data
@@ -186,7 +186,6 @@ moveLaser phaseV pos dir w pt
       )
   where 
     xp = pos +.+ 800 *.* unitVectorAtAngle dir
-    reflectDir wall = argV (reflectIn (uncurry (-.-) (_wlLine wall)) (xp -.- pos))
     f :: [Wall] -> Point2 -> Point2 -> (Maybe (Point2,Either Creature Wall),[Point2])
     f seenWs x y = case find (h' seenWs) $ thingsHitExceptCrLongLine Nothing x y w of
         Just (p,Right wl) 
@@ -225,9 +224,7 @@ moveLaser phaseV pos dir w pt
     hitEffect = case thHit of
         Just (p,Left cr) 
             -> creatures . ix (_crID cr) . crState . crDamage %~ (Lasering 19 pos p xp :)
-        Just (p,Right wl) -> colSpark 8 (V4 20 (-5) 0 1) (p +.+ safeNormalizeV (pos -.- p))
-                                                    (reflectDir wl)
-            . damageWall (Lasering 19 pos p xp) wl
+        Just (p,Right wl) -> damageWall (Lasering 19 pos p xp) wl
         _   -> id
     pic = setLayer 1 $ pictures
         [ setDepth 19   . color (brightX 0 0.5 yellow) $ lineOfThickness 20 (pos:ps)

src/Dodge/Particle/Bullet/HitEffect.hs

@@ -6,7 +6,7 @@ module Dodge.Particle.Bullet.HitEffect
 import Dodge.Data
 import Dodge.Data.DamageType
 import Dodge.Data.SoundOrigin
-import Dodge.WorldEvent.DamageBlock
+import Dodge.Wall.Damage
 import Dodge.WorldEvent
 import Dodge.Particle.Bullet.Spawn
 import Dodge.SoundLogic
@@ -16,7 +16,7 @@ import Dodge.WorldEvent.Shockwave
 import Dodge.Creature.State.Data
 import Dodge.Creature.Property
 import Geometry
-import Geometry.Vector3D
+--import Geometry.Vector3D
 import Picture
 
 import System.Random
@@ -132,24 +132,18 @@ bulConCr' bt p cr w
     mkwave = over worldEvents $ (.) (makeShockwaveAt [] p 15 4 1 white)
 {- | Hitting wall effects: create a spark, damage blocks.  -}
 bulHitWall :: Particle -> Point2 -> Wall -> World -> World
-bulHitWall bt p wl w = damageBlocksBy 5 wl
-    . smokeCloudAt dustcol 20 200 1 (addZ 20 pOut)
-    $ colSpark' 0.2 8 theCol pOut (reflectDir wl)
-    w
+bulHitWall bt p = damageWall (Piercing 100 sp p ep)
   where 
-    dustcol = _wlColor wl & _4 .~ 1
-    theCol = brightX 100 1.5 white
+    ep = sp +.+ _btVel' bt
     sp = head $ _btTrail' bt
-    pOut = p +.+ safeNormalizeV (sp -.- p)
-    reflectDir wall = argV (reflectIn (uncurry (-.-) (_wlLine wall)) (p -.- sp) )
 {- | Bounce off walls, do damage to blocks.  -}
-bulBounceWall' :: Particle -> Point2 -> Wall -> World -> World
-bulBounceWall' bt p wl w = damageBlocksBy 5 wl $ over worldEvents addBouncer w
+bulBounceWall :: Particle -> Point2 -> Wall -> World -> World
+bulBounceWall bt p wl = damageWall (Blunt 50 sp p ep) wl . over worldEvents addBouncer
   where 
+    ep = sp +.+ _btVel' bt
     sp = head $ _btTrail' bt
     pOut = p +.+ safeNormalizeV (sp -.- p)
-    bouncer = (aGenBulAt Nothing pOut reflectVel 
-                                      (_btHitEffect' bt) (_btWidth' bt)
+    bouncer = (aGenBulAt Nothing pOut reflectVel (_btHitEffect' bt) (_btWidth' bt)
               ) {_btTimer' = _btTimer' bt - 1}
     wallV = uncurry (-.-) (_wlLine wl)
     reflectVel = reflectIn wallV (_btVel' bt)
@@ -159,14 +153,15 @@ bulBounceWall' bt p wl w = damageBlocksBy 5 wl $ over worldEvents addBouncer w
 -- this list
 
 {- | Create flamelet on wall.  -}
-bulIncWall'
+bulIncWall
     :: Particle 
     -> Point2   -- Impact point
     -> Wall 
     -> World 
     -> World
-bulIncWall' bt p wl w =  damageBlocksBy 5 wl $ incFlamelets w
+bulIncWall bt p wl =  damageWall (Blunt 50 sp p ep) wl . incFlamelets
   where   
+    ep = sp +.+ _btVel' bt
     sp = head $ _btTrail' bt
     pOut = p +.+ safeNormalizeV (sp -.- p)
     wallV = uncurry (-.-) (_wlLine wl)

src/Dodge/Update.hs

@@ -89,11 +89,10 @@ splinterBlock bl w = foldr unshadowBlock w (_blShadows bl) -- foldr shiftTowardC
     & blocks . ix (_blID bl) . blHPs %~ tail
     & theSoundEffect cen
   where
-    wls = map (_walls w IM.!) (IS.toList $ _blWallIDs bl)
-    ps = map (fst . _wlLine) wls
-    cen = centroid ps
+    wls = IM.restrictKeys (_walls w) (_blWallIDs bl)
+    cen = centroid $ fmap (fst . _wlLine) wls
     theSoundEffect 
-        | _wlOpacity (head wls) == SeeThrough = mkSoundSplinterGlass
+        | _wlOpacity (snd $ IM.findMin wls) == SeeThrough = mkSoundSplinterGlass
         | otherwise                           = mkSoundSplinterBlock
 
 unshadowBlock :: Int -> World -> World
@@ -121,7 +120,6 @@ destroyBlock bl w = w
   where
     wlids = _blWallIDs bl
     pos = fst . _wlLine $ _walls w IM.! IS.findMin wlids
-
 -- | Note the explict use of record syntax. Using lens created a space leak.
 resetWorldEvents :: World -> World
 resetWorldEvents w = w {_worldEvents = id}

src/Dodge/Wall/Damage.hs

@@ -0,0 +1,71 @@
+{- | Controls a walls response to external damage.
+ - Indestructible walls may still produce sparks, dust etc
+ -}
+module Dodge.Wall.Damage
+    ( damageBlocksBy
+    , damageWall
+    ) where
+import Dodge.Data
+import Dodge.Data.DamageType
+import Dodge.WorldEvent.SpawnParticle
+import Dodge.WorldEvent.Cloud
+import Geometry
+import Geometry.Vector3D
+import Color
+
+import Control.Lens
+damageWall :: DamageType -> Wall -> World -> World
+damageWall dt wl = case _wlStructure wl of
+    MachinePart mcid -> machines . ix mcid . mcDamage %~ (dt :)
+    BlockPart blid   -> wallEff dt wl . (blocks . ix blid %~ damageBlockWith dt)
+    _   -> wallEff dt wl
+{- | Damage effects on indestructible walls -}
+-- TODO take into account damage amount for amount of dust/sparks?
+wallEff :: DamageType -> Wall -> World -> World
+wallEff dt wl = case dt of
+    Lasering _ sp p _ -> colSpark 8 lSparkCol (outTo sp p) (reflDirWall sp p wl)
+    Piercing _ sp p _ -> colSpark' 0.2 8 pSparkCol (outTo sp p) (reflDirWall sp p wl)
+        . smokeCloudAt dustcol 20 200 1 (addZ 20 (outTo sp p))
+    Blunt    _ sp p _ -> smokeCloudAt dustcol 20 200 1 (addZ 20 (outTo sp p))
+    Cutting {} -> id
+    SparkDam {} -> id
+    Flaming  {} -> id
+    Electrical {} -> id
+    Concussive {} -> id
+    TorqueDam {} -> id
+    PushDam {} -> id
+    PoisonDam {} -> id
+  where
+    outTo sp p = p +.+ safeNormalizeV (sp -.- p)
+    dustcol = _wlColor wl & _4 .~ 1
+    pSparkCol = brightX 100 1.5 white
+    lSparkCol = V4 20 (-5) 0 1
+
+reflDirWall :: Point2 -> Point2 -> Wall -> Float
+reflDirWall sp ep wl = argV (reflectIn (uncurry (-.-) (_wlLine wl)) (ep -.- sp))
+
+damageBlockWith :: DamageType -> Block -> Block
+damageBlockWith dt = case dt of
+    Piercing dam _ _ _ -> blHPs %~ reduceHead dam
+    Blunt    dam _ _ _ -> blHPs %~ reduceHead dam
+    Cutting  dam _ _ _ -> blHPs %~ reduceHead dam
+    Concussive dam _ _ _ _ -> blHPs %~ reduceHead dam
+    Lasering {} -> id
+    SparkDam {} -> id
+    Flaming {} -> id
+    Electrical {} -> id
+    TorqueDam {} -> id
+    PushDam {} -> id
+    PoisonDam {} -> id
+
+reduceHead :: Int -> [Int] -> [Int]
+reduceHead y (x:xs) = x-y:xs
+reduceHead _ _ = []
+
+damageBlocksBy :: Int -> Wall -> World -> World
+damageBlocksBy x wl = case wl ^? wlStructure . wlStBlock of
+    Just blid -> blocks . ix blid . blHPs %~ reduceHeadBy x
+    Nothing   -> id
+  where
+    reduceHeadBy y (z:zs) = z - y : zs
+    reduceHeadBy _ [] = []

src/Dodge/WorldEvent/DamageBlock.hs

@@ -1,25 +0,0 @@
-module Dodge.WorldEvent.DamageBlock
-    ( damageBlocksBy
-    , damageWall
-    ) where
-import Dodge.Data
-import Dodge.Data.DamageType
-
-import Control.Lens
-
-damageWall :: DamageType -> Wall -> World -> World
-damageWall dt wl = case _wlStructure wl of
-    MachinePart mcid -> machines . ix mcid . mcDamage %~ (dt :)
-    BlockPart blid   -> blocks   . ix blid %~ damageBlockWith dt
-    _   -> id
-
-damageBlockWith :: DamageType -> Block -> Block
-damageBlockWith _ = id
-
-damageBlocksBy :: Int -> Wall -> World -> World
-damageBlocksBy x wl = case wl ^? wlStructure . wlStBlock of
-    Just blid -> blocks . ix blid . blHPs %~ reduceHeadBy x
-    Nothing   -> id
-  where
-    reduceHeadBy y (z:zs) = z - y : zs
-    reduceHeadBy _ [] = []

src/Dodge/WorldEvent/Shockwave.hs

@@ -6,7 +6,7 @@ module Dodge.WorldEvent.Shockwave
 import Dodge.Data
 import Dodge.Data.DamageType
 import Dodge.Creature.State.Data
-import Dodge.WorldEvent.DamageBlock
+import Dodge.Wall.Damage
 import Dodge.Base
 import Dodge.Zone
 import Dodge.Picture.Layer