Add basic corpse shapes

src/Dodge/Creature/Picture.hs

@@ -25,6 +25,7 @@ import Picture
 import Geometry
 import Shape
 import ShapePicture
+import qualified Quaternion as Q
 --import Geometry.Vector3D
 
 import Control.Lens
@@ -64,14 +65,13 @@ basicCrShape cr
     | _crCamouflage cr == Invisible = mempty
     | otherwise = tr . scaleSH (V3 crsize crsize crsize) $ mconcat
         [ --rotdir . _spShape $ drawEquipment cr
-         rotdir . dm . colorSH (_skinHead cskin) . translateSHz 20 $ scalp cr
+         rotdir . colorSH (_skinHead cskin) . translateSHz 20 $ scalp cr
-        , rotdir . dm $ colorSH (_skinUpper cskin) $ upperBody cr
+        , rotdir $ colorSH (_skinUpper cskin) $ upperBody cr
-        , dm . rotmdir $ colorSH (_skinLower cskin) $ feet cr
+        , rotmdir $ colorSH (_skinLower cskin) $ feet cr
         ]
   where 
     cskin = _crSkin cr
     crsize = 0.1 * _crRad cr
-    dm = damageModSH cr
     tr = uncurryV translateSHf (_crPos cr)
     rotdir = rotateSH (_crDir cr)
     rotmdir = rotateSH (_crMvDir cr)
@@ -141,8 +141,6 @@ crDisplayAwake = show . _crAwakeLevel . _crPerception
 --    piercingMod = case fmap argV piercingDam of
 --        Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a)
 --        _   -> id
-damageModSH :: Creature -> Shape -> Shape
-damageModSH _ = id
 
 feet :: Creature -> Shape
 {-# INLINE feet #-}
@@ -166,6 +164,28 @@ feet cr = case cr ^? crStance . carriage of
     sLen = _strideLength $ _crStance cr
     f i = 6 * fromIntegral (sLen - i) / fromIntegral sLen
 
+deadFeet :: Creature -> Shape
+{-# INLINE deadFeet #-}
+deadFeet cr = case cr ^? crStance . carriage of
+    Just (Walking sa LeftForward)  -> mconcat
+        [ translateSHf ( f sa)   off  aFoot
+        , translateSHf (-f sa) (-off) aFoot
+        ]
+    Just (Walking sa RightForward) -> mconcat
+        [ translateSHf (-f sa)   off  aFoot
+        , translateSHf ( f sa) (-off) aFoot
+        ]
+    _ -> mconcat
+        [ translateSHf 0   off  aFoot
+        , translateSHf 0 (-off) aFoot
+        ]
+  where
+    aFoot :: Shape
+    aFoot = upperPrismPoly 3 $ polyCirc 3 4
+    off = 5
+    sLen = _strideLength $ _crStance cr
+    f i = 6 * fromIntegral (sLen - i) / fromIntegral sLen
+
 arms :: Creature -> Shape
 {-# INLINE arms #-}
 arms cr = fst $ translateToRightHand cr aHand
@@ -189,6 +209,9 @@ arms cr = fst $ translateToRightHand cr aHand
 --    sLen = _strideLength $ _crStance cr
 --    f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen
 
+deadScalp :: Creature -> Shape
+deadScalp = overPosSH (Q.rotateToZ (V3 1 0 0)) . translateSHz 10 . scalp
+
 scalp :: Creature -> Shape
 {-# INLINE scalp #-}
 scalp cr
@@ -222,6 +245,9 @@ torso cr
     --aShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPoly 10 $ polyCirc 3 crad
     aShoulder = scaleSH (V3 10 10 1) baseShoulder
 
+deadUpperBody :: Creature -> Shape
+deadUpperBody = overPosSH (Q.rotateToZ (V3 1 0 0)) . translateSHz (negate 10) . upperBody
+
 baseShoulder :: Shape
 {-# INLINE baseShoulder #-}
 baseShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPolyHalf 10 $ polyCirc 3 1
@@ -266,17 +292,15 @@ picAtCrPosNoRot :: Picture -> Creature -> Configuration -> World -> SPic
 --{-# INLINE picAtCrPos #-}
 picAtCrPosNoRot thePic cr _ _ = (,) emptySH $ uncurryV translate (_crPos cr) thePic
 
-basicCrCorpse :: Creature -> SPic
+basicCrCorpse :: Creature -> Corpse -> SPic
-basicCrCorpse cr = noPic . tr . scaleSH (V3 crsize crsize crsize) $ mconcat
+basicCrCorpse cr cp = noPic . tr . scaleSH (V3 crsize crsize crsize) $ mconcat
-        [ --rotdir . _spShape $ drawEquipment cr
+        [ rotdir . colorSH (_skinHead cskin) $ deadScalp cr
-         rotdir . dm . colorSH (_skinHead cskin) . translateSHz 20 $ scalp cr
+        , rotdir $ colorSH (_skinUpper cskin) $ deadUpperBody cr
-        , rotdir . dm $ colorSH (_skinUpper cskin) $ upperBody cr
+        , rotdir . rotmdir $ colorSH (_skinLower cskin) $ deadFeet cr
-        , dm . rotmdir $ colorSH (_skinLower cskin) $ feet cr
         ]
   where 
     cskin = _crSkin cr
     crsize = 0.1 * _crRad cr
-    dm = damageModSH cr
+    tr = uncurryV translateSHf (_cpPos cp)
-    tr = uncurryV translateSHf (_crPos cr)
+    rotdir = rotateSH (_cpDir cp)
-    rotdir = rotateSH (_crDir cr)
+    rotmdir = rotateSH (_crMvDir cr - _crDir cr)
-    rotmdir = rotateSH (_crMvDir cr)

src/Dodge/Creature/State.hs

@@ -69,10 +69,10 @@ checkDeath cr w
     | _crHP cr > 0 = w
     | otherwise = w 
 --        & creatures . at (_crID cr) .~ Nothing
+        & dropByState cr
         & removecr
         & stopSoundFrom (CrWeaponSound (_crID cr) 0) 
         & plNew corpses cpID thecorpse
-        & dropByState cr
   where
     removecr
         | _crID cr == 0 = (creatures . ix (_crID cr) . crUpdate .~ const id)

src/Dodge/Data.hs

@@ -277,7 +277,7 @@ data Corpse = Corpse
     { _cpID  :: Int
     , _cpPos :: Point2
     , _cpDir :: Float
-    , _cpPict :: SPic
+    , _cpPict :: Corpse -> SPic
     , _cpRes :: Maybe Creature
     }
 data Gust = Gust
@@ -339,7 +339,7 @@ data Creature = Creature
     , _crEquipment      :: M.Map EquipPosition Int
     , _crLeftInvSel     :: Maybe Int
     , _crState          :: CreatureState
-    , _crCorpse         :: Creature -> SPic
+    , _crCorpse         :: Creature -> Corpse -> SPic
     , _crApplyDamage    :: [Damage] -> Creature -> World -> World
     , _crPastDamage     :: Int
     , _crStance         :: Stance

src/Dodge/Render/ShapePicture.hs

@@ -32,6 +32,7 @@ worldSPic :: Configuration -> World -> SPic
 worldSPic cfig w = 
     (extraShapes w, extraPics cfig w)
     <> foldMap (dbArg _prDraw) (filtOn _pjPos _props)
+    <> foldMap (dbArg _cpPict) (filtOn _cpPos _corpses)
     <> foldMap ((($ w) . ($ cfig)) . dbArg _crPict) (filtOn _crPos _creatures)
     <> foldMap floorItemSPic (filtOn _flItPos _floorItems)
     <> foldMap btSPic (filtOn _btPos _buttons)