Make many death events just leave corpses (no gore)

src/Dodge/Creature/State.hs

@@ -3,6 +3,7 @@ module Dodge.Creature.State
     , doDamage
     ) where
 import Dodge.Data
+import Dodge.Damage
 import Dodge.Hammer
 import Dodge.Reloading
 import Dodge.Prop.Gib
@@ -19,9 +20,11 @@ import Dodge.Creature.Action
 --import Dodge.Hammer
 import Geometry
 import Picture
+import Shape
+import ShapePicture
 import qualified IntMapHelp as IM
 --import StrictHelp
-import FoldableHelp
+--import FoldableHelp
 
 
 --import qualified Data.IntSet as IS
@@ -82,12 +85,15 @@ checkDeath cr w
             . (creatures . ix (_crID cr) . crPict .~ const mempty)
         | otherwise  = creatures . at (_crID cr) .~ Nothing
 corpseOrGib :: Creature -> World -> World
-corpseOrGib cr w 
-    | _crPastDamage cr > 200 = w & addCrGibs cr
+corpseOrGib cr w = case maxDamageType (_crDamage (_crState cr)) of
+    Just (FLAMING,_) -> w & plNew corpses cpID (thecorpse & cpPict %~ fmap scorchSPic)
+    Just (ELECTRICAL,_) -> w & plNew corpses cpID thecorpse
+    Just (POISONDAM,_) -> w & plNew corpses cpID (thecorpse & cpPict %~ fmap poisonSPic)
+    _ | _crPastDamage cr > 200 -> w & addCrGibs cr
         & bloodPuddleAt cpos
         & bloodPuddleAt cpos
         & bloodPuddleAt cpos
-    | otherwise = w
+    _ -> w
         & bloodPuddleAt cpos
         & bloodPuddleAt cpos
         & plNew corpses cpID thecorpse
@@ -101,6 +107,20 @@ corpseOrGib cr w
         , _cpRes = Nothing
         }
 
+scorchSPic :: SPic -> SPic
+scorchSPic = over _1 $
+    overColSH (mixColors 0.9 0.1 black . normalizeColor) 
+
+poisonSPic :: SPic -> SPic
+poisonSPic = over _1 $
+    overColSH (mixColors 0.5 0.5 green . normalizeColor) 
+
+--scorchSPic :: World -> SPic -> SPic
+--scorchSPic w sp = evalState (scorchSPic' sp) (_randGen w)
+--
+--scorchSPic' :: SPic -> State StdGen SPic
+--scorchSPic' = _1 $ overColSHM $ \col -> takeOne [col,black]
+----    (return . mixColorsLinear 0.9 0.1 black) 
 
 bloodPuddleAt :: Point2 -> World -> World
 bloodPuddleAt p w = w

src/Dodge/Damage.hs

@@ -5,6 +5,8 @@ import FoldableHelp
 import Geometry.Vector
 import LensHelp
 
+import qualified Data.Map.Strict as M
+
 damageCrWall :: Damage -> Either Creature Wall -> World -> World
 damageCrWall dt (Left cr) = creatures . ix (_crID cr) . crState . crDamage .:~ dt
 damageCrWall dt (Right wl) = damageWall dt wl
@@ -13,3 +15,11 @@ damageDirection :: [Damage] -> Maybe Float
 damageDirection ds = do
     dm <- safeMinimumOn (negate . _dmAmount) ds
     safeArgV (_dmTo dm -.- _dmFrom dm)
+
+collectDamageTypes :: [Damage] -> M.Map DamageType Int
+collectDamageTypes = foldr f M.empty
+  where
+    f dm = M.insertWith (+) (_dmType dm) (_dmAmount dm)
+
+maxDamageType :: [Damage] -> Maybe (DamageType,Int)
+maxDamageType = safeMinimumOn (negate . snd) . M.assocs . collectDamageTypes

src/Dodge/Prop/Gib.hs

@@ -82,6 +82,7 @@ addCrGibs cr w = case damageDirection $ _crDamage $ _crState cr of
     Just d -> w
         & addGibsAtDir d 3 7 (_skinLower skin) cpos
         & addGibsAtDir d 13 20 (_skinUpper skin) cpos
+        & addGibAtDir d 25 (_skinHead skin) cpos
   where
     skin = _crSkin cr
     cpos = _crPos cr
@@ -147,3 +148,23 @@ addGibAt h col p w = w
             & pjQuat .~ q
             & pjVelZ .~ zs
             & pjPosZ .~ h
+
+addGibAtDir :: Float -> Float -> Color -> Point2 -> World -> World
+addGibAtDir dir h col p w = w
+    & plNew props pjID gib
+    & randGen .~ newg
+  where
+    (gib,newg) = runState f $ _randGen w
+    f = do
+        s   <- state $ randomR (1,4)
+        zs  <- state $ randomR (-8,8)
+        q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
+        let v = s *.* unitVectorAtAngle dir
+        return $ aGib
+            & pjPos .~ p
+            & pjColor .~ col
+            & pjVel .~ v
+            & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
+            & pjQuat .~ q
+            & pjVelZ .~ zs
+            & pjPosZ .~ h