Make many death events just leave corpses (no gore)

src/Color.hs

@@ -61,6 +61,12 @@ paletteToColor pc = case pc of
     WHITE       -> white     
     BLACK       -> black     
 
+normalizeColor :: Color -> Color
+{-# INLINE normalizeColor #-}
+normalizeColor (V4 r g b a) = V4 (f r) (f g) (f b) (f a)
+  where
+    f = min 1 . max 0
+
 mixColors :: Float -> Float -> Color -> Color -> Color
 {-# INLINE mixColors #-}
 mixColors rata ratb (V4 r0 g0 b0 a0) (V4 r2 g2 b2 a2) = 
@@ -70,6 +76,15 @@ mixColors rata ratb (V4 r0 g0 b0 a0) (V4 r2 g2 b2 a2) =
         f x y = sqrt $ normrata * x^(2::Int) + normratb * y^(2::Int)
     in  V4 (f r0 r2 ) ( f g0 g2 ) ( f b0 b2 ) ( normrata * a0 + normratb * a2)
 
+mixColorsLinear :: Float -> Float -> Color -> Color -> Color
+{-# INLINE mixColorsLinear #-}
+mixColorsLinear rata ratb (V4 r0 g0 b0 a0) (V4 r2 g2 b2 a2) = 
+    let fullrat = rata + ratb
+        normrata = rata / fullrat
+        normratb = ratb / fullrat
+        f x y = normrata * x + normratb * y
+    in  V4 (f r0 r2 ) ( f g0 g2 ) ( f b0 b2 ) ( normrata * a0 + normratb * a2)
+
 light :: Color -> Color
 {-# INLINE light #-}
 light (V4 r g b a) = V4 (r+0.2) (g+0.2) (b+0.2) a

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 
+corpseOrGib cr w = case maxDamageType (_crDamage (_crState cr)) of
-    | _crPastDamage cr > 200 = w & addCrGibs cr
+    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

src/Shape.hs

@@ -14,6 +14,8 @@ module Shape
     , polyCircx
     , scaleSH
     , colorSH
+    , overColSH
+    , overColSHM
     , overPosSH
     ) where
 import Geometry
@@ -79,11 +81,15 @@ upperPrismPolyHalf h ps = [ShapeObj (TopPrism n) (f upps downps)]
 
 colorSH :: Color -> Shape -> Shape
 {-# INLINE colorSH #-}
-colorSH = overCol . const
+colorSH = overColSH . const
 
-overCol :: (Point4 -> Point4) -> Shape -> Shape
+overColSH :: (Point4 -> Point4) -> Shape -> Shape
-{-# INLINE overCol #-}
+{-# INLINE overColSH #-}
-overCol = fmap . overColObj
+overColSH = fmap . overColObj
+
+overColSHM :: Monad m => (Point4 -> m Point4) -> Shape -> m Shape
+{-# INLINE overColSHM #-}
+overColSHM = mapM . overColObjM
 
 overPosSHI :: (Point3 -> Point3) -> Shape -> Shape
 {-# INLINE overPosSHI #-}
@@ -121,6 +127,10 @@ overColObj :: (Point4 -> Point4) -> ShapeObj -> ShapeObj
 {-# INLINE overColObj #-}
 overColObj f (ShapeObj st vs) = ShapeObj st (map (overColVertex f) vs)
 
+overColObjM :: Monad m => (Point4 -> m Point4) -> ShapeObj -> m ShapeObj
+{-# INLINE overColObjM #-}
+overColObjM f (ShapeObj st vs) = ShapeObj st <$> (mapM (svCol f) vs)
+
 overColVertex :: (Point4 -> Point4) -> ShapeV -> ShapeV
 {-# INLINE overColVertex #-}
 overColVertex f (ShapeV a b) = ShapeV a (f b)