Allow debris to do damage

src/Dodge/Block/Debris.hs

@@ -36,9 +36,9 @@ someDebris = PropZ
     {_prPos = 0
     ,_pjStartPos = 0
     ,_pjVel = 0
-    ,_prDraw = \pr -> drawMovingShape pr (debrisShape pr)
+    ,_prDraw = \pr -> drawMovingShape pr (debrisShape 4 pr)
     ,_pjID = 0
-    ,_pjUpdate = fallSmallBounce
+    ,_pjUpdate = fallSmallBounceDamage
     ,_pjPosZ = 10
     ,_pjVelZ = 5
     ,_pjTimer = 20
@@ -46,5 +46,5 @@ someDebris = PropZ
     ,_pjQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
     ,_pjColor = white
     }
-debrisShape :: Prop -> Shape
+debrisShape :: Float -> Prop -> Shape
-debrisShape pr = colorSH (_pjColor pr) . translateSHz (-5) $ upperPrismPoly 10 $ square 5
+debrisShape size pr = colorSH (_pjColor pr) . translateSHz (-size) $ upperPrismPoly 8 $ square size

src/Dodge/Data/DamageType.hs

@@ -9,6 +9,7 @@ data DamageType
     | BLUNT    
     | CUTTING  
     | SPARKING
+    | CRUSHING
     | FLAMING  
     | LASERING 
     | ELECTRICAL

src/Dodge/Placement/PlaceSpot/Block.hs

@@ -92,7 +92,7 @@ placeLineBlock basePane bm blockWidth depth a b gw = ( 0
         { _blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i
         , _blHPs = [5,5], _blShadows = shadowsAt i, _blMaterial = bm
         , _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise)
-        , _blPos = p, _blDraw = const mempty , _blDeath = const id}
+        , _blPos = p, _blDraw = const mempty , _blDeath = makeBlockDebris bm}
     insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs
     ksAtI i = map ( + (wlid + i*4) ) [0,1,2,3]
     visibilityAt i 

src/Dodge/Prop/Moving.hs

@@ -1,4 +1,8 @@
-module Dodge.Prop.Moving where
+module Dodge.Prop.Moving 
+    ( drawMovingShape
+    , fallSmallBounceDamage
+    , fallSmallBounce
+    ) where
 import Dodge.Zone
 import Dodge.Base
 import Dodge.Data
@@ -13,9 +17,25 @@ import LensHelp
 
 import qualified Quaternion as Q
 --import Data.List (zip4)
+--
+fallSmallBounceDamage :: Prop -> World -> World
+fallSmallBounceDamage pr w = w 
+    & dodamage
+    & props . ix (_pjID pr) %~ fallSmallBounce' w
+  where
+    p = _prPos pr
+    v = _pjVel pr
+    dodamage
+        | _pjPosZ pr < 25 = creatures %~ fmap dodamage'
+        | otherwise = id
+    dodamage' cr
+        | dist (_crPos cr) p < _crRad cr = cr & crState . crDamage 
+            .:~ Damage CRUSHING (floor . (*10) . max 0 . subtract 5 . abs $ _pjVelZ pr) (p -.- v) p (p +.+ v) NoDamageEffect
+        | otherwise = cr
 
 fallSmallBounce :: Prop -> World -> World
-fallSmallBounce pr w = w & props . ix (_pjID pr) %~ fallSmallBounce' w
+fallSmallBounce pr w = w 
+    & props . ix (_pjID pr) %~ fallSmallBounce' w
 
 fallSmallBounce' :: World -> Prop -> Prop
 fallSmallBounce' w pr

src/Dodge/Wall/Damage.hs

@@ -22,6 +22,7 @@ damageBlockWith dm = case _dmType dm of
     CUTTING     -> blHPs %~ reduceHead dam
     EXPLOSIVE   -> blHPs %~ reduceHead dam
     CONCUSSIVE  -> blHPs %~ reduceHead dam
+    CRUSHING    -> blHPs %~ reduceHead (dam `div` 4)
     LASERING    -> id
     SPARKING    -> id
     FLAMING     -> id

src/Dodge/Wall/DamageEffect.hs

@@ -14,6 +14,7 @@ defaultWallDamage dm wl = wallDamageEffect dm wl . case _dmType dm of
     LASERING    -> colSparkRandDir 0.2 8 lSparkCol outTo (reflDirWall sp p wl)
     PIERCING    -> colSparkRandDir 0.2 8 pSparkCol outTo (reflDirWall sp p wl) . wlDustAt wl outTo
     BLUNT       -> wlDustAt wl outTo
+    CRUSHING    -> id
     EXPLOSIVE   -> id
     CUTTING     -> id
     SPARKING    -> id