Continue to tweak death effects

src/Dodge/Base/NewID.hs

@@ -2,6 +2,16 @@ module Dodge.Base.NewID where
 import qualified IntMapHelp as IM
 import LensHelp
 
+-- | generalised way of putting a new item into a lensed intmap, returning the
+-- new index as well
+plNewID :: ALens' b (IM.IntMap a)
+    -> a
+    -> b
+    -> (Int,b)
+plNewID l x w = (i,w & l #%~ IM.insert i x)
+  where
+    i = IM.newKey $ w ^# l
+
 -- | place an new object into an intmap and update its id
 plNewUpID :: ALens' b (IM.IntMap a)
     -> ALens' a Int

src/Dodge/Creature.hs

@@ -208,6 +208,7 @@ inventoryX c = case c of
 testInventory :: IM.IntMap Item
 testInventory = IM.fromList $ zip [0..] 
     [ makeTypeCraftNum 9 PIPE
+    , autoAmr
     , brainHat
     , headLamp
     , autoDetector WALLDETECTOR
@@ -215,6 +216,7 @@ testInventory = IM.fromList $ zip [0..]
     , frontArmour
     , wristArmour
     , flatShield
+    , sniperRifle
     , makeTypeCraftNum 1 MOTOR
     , makeModule INCENDIARYMODULE
     , makeModule STATICMODULE

src/Dodge/Creature/Picture.hs

@@ -20,6 +20,7 @@ import Dodge.Data
 import Dodge.Clock
 import Dodge.Creature.HandPos (translateToRightHand,translateToLeftHand)
 import Dodge.Creature.Test
+import Dodge.Damage
 --import Dodge.Debug.Picture
 import Picture
 import Geometry
@@ -210,7 +211,13 @@ arms cr = fst $ translateToRightHand cr aHand
 --    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
+deadScalp cr = deadRot cr . translateSHz 10 . scalp $ cr
+
+deadRot :: Creature -> Shape -> Shape
+deadRot cr = overPosSH (Q.rotateToZ d)
+  where
+    d = maybe (V3 1 0 0) (addZ 0 . unitVectorAtAngle . subtract (_crDir cr+pi))
+        (damageDirection . _crDamage $ _crState cr)
 
 scalp :: Creature -> Shape
 {-# INLINE scalp #-}
@@ -246,7 +253,7 @@ torso cr
     aShoulder = scaleSH (V3 10 10 1) baseShoulder
 
 deadUpperBody :: Creature -> Shape
-deadUpperBody = overPosSH (Q.rotateToZ (V3 1 0 0)) . translateSHz (negate 10) . upperBody
+deadUpperBody cr = deadRot cr . translateSHz (negate 10) . upperBody $ cr
 
 baseShoulder :: Shape
 {-# INLINE baseShoulder #-}

src/Dodge/Creature/State.hs

@@ -18,9 +18,11 @@ import Dodge.WorldEvent
 import Dodge.Creature.Action
 --import Dodge.Hammer
 import Geometry
---import Picture
+import Picture
 import qualified IntMapHelp as IM
 --import StrictHelp
+import FoldableHelp
+
 
 --import qualified Data.IntSet as IS
 --import Data.Maybe
@@ -54,7 +56,7 @@ foldCr xs cr w = foldr f w xs
 -- may affect whether the shield moves correctly
 stateUpdate :: (Creature -> World -> World) -> Creature -> World -> World
 stateUpdate f = foldCr
-    [ doDamage
+    [ clearDamage
     , equipmentEffects
     , invSideEff
     , upInv      -- upInv must be called before invSideEff 22.05.23
@@ -62,6 +64,7 @@ stateUpdate f = foldCr
     , f
     , internalUpdate 
     , checkDeath
+    , doDamage
     ]
 
 checkDeath :: Creature -> World -> World
@@ -72,13 +75,24 @@ checkDeath cr w
         & dropByState cr
         & removecr
         & stopSoundFrom (CrWeaponSound (_crID cr) 0) 
-        & plNew corpses cpID thecorpse
+        & corpseOrGib cr
   where
     removecr
         | _crID cr == 0 = (creatures . ix (_crID cr) . crUpdate .~ const id)
             . (creatures . ix (_crID cr) . crPict .~ const mempty)
-            . addCrGibs cr
         | otherwise  = creatures . at (_crID cr) .~ Nothing
+corpseOrGib :: Creature -> World -> World
+corpseOrGib cr w 
+    | _crPastDamage cr > 200 = w & addCrGibs cr
+        & bloodPuddleAt cpos
+        & bloodPuddleAt cpos
+        & bloodPuddleAt cpos
+    | otherwise = w
+        & bloodPuddleAt cpos
+        & bloodPuddleAt cpos
+        & plNew corpses cpID thecorpse
+  where
+    cpos = _crPos cr
     thecorpse = Corpse
         { _cpID = 0
         , _cpPos = _crPos cr
@@ -87,6 +101,15 @@ checkDeath cr w
         , _cpRes = Nothing
         }
 
+
+bloodPuddleAt :: Point2 -> World -> World
+bloodPuddleAt p w = w
+    & snd . plNewID decorations 
+        (color (dark $ dark red) . setDepth 01 . uncurryV translate (p +.+ q) $ circleSolid 10)
+    & randGen .~ g
+  where
+    (q,g) = randInCirc 10 & runState $ _randGen w
+
 internalUpdate :: Creature -> World -> World
 internalUpdate cr = creatures . ix (_crID cr) %~ 
     ( (crHammerPosition %~ moveHammerUp)
@@ -102,9 +125,12 @@ dropByState cr w = foldr (dropItem cr) w $ case cr ^. crState . crDropsOnDeath o
     DropSpecific xs -> xs
     DropAmount n -> take n $ evalState (shuffle $ IM.keys $ _crInv cr) (_randGen w)
 
+clearDamage :: Creature -> World -> World
+clearDamage cr w = w
+    & creatures . ix (_crID cr) . crState . crDamage .~ [] 
+
 doDamage :: Creature -> World -> World
 doDamage cr w = w
-    & creatures . ix (_crID cr) . crState . crDamage .~ [] 
     & applyPastDamages cr
     & _crApplyDamage cr dams cr
   where 

src/Dodge/Damage.hs

@@ -1,8 +1,15 @@
 module Dodge.Damage where
 import Dodge.Data
 import Dodge.Wall.Damage
+import FoldableHelp
+import Geometry.Vector
 import LensHelp
 
 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
+
+damageDirection :: [Damage] -> Maybe Float
+damageDirection ds = do
+    dm <- safeMinimumOn (negate . _dmAmount) ds
+    safeArgV (_dmTo dm -.- _dmFrom dm)

src/Dodge/Item/Weapon/BulletGun/Rod.hs

@@ -8,6 +8,8 @@ module Dodge.Item.Weapon.BulletGun.Rod
     ) where
 import Dodge.Data
 import Dodge.Item.Weapon.BulletGun.Clip
+import Dodge.Particle.HitEffect
+import Dodge.Particle.Damage
 --import Dodge.ChainEffect
 --import Dodge.TweakBullet
 import Dodge.Default.Weapon
@@ -81,6 +83,7 @@ bangRod = defaultGun
     & itUse . useAim . aimRange .~ 1
     & itUse . useAim . aimStance .~ OneHand
     & itUse . useAim . aimZoom .~ defaultItZoom {_itZoomFac = 1.5}
+    & itConsumption . aoType . amBulEff .~ expireAndDamage heavyBulDams
 baseRodShape :: Shape
 baseRodShape = colorSH orange $ upperPrismPoly 3 $ rectXH 20 2
 baseAMRShape :: Shape

src/Dodge/Particle/Damage.hs

@@ -27,6 +27,16 @@ simpleDam dt amount bt p = [ Damage dt amount sp p ep NoDamageEffect ]
     bulVel = _ptVel bt
     ep = sp +.+ bulVel
 
+heavyBulDams :: Particle -> Point2 -> [Damage]
+heavyBulDams bt p =
+    [ Damage PIERCING 300 sp p ep NoDamageEffect
+    , Damage PUSHDAM    1 sp p ep . PushBackDamage $ 2 *.* bulVel
+    ]
+  where
+    sp = head $ _ptTrail bt
+    bulVel = _ptVel bt
+    ep = sp +.+ bulVel
+
 basicBulDams :: Particle -> Point2 -> [Damage]
 basicBulDams bt p =
     [ Damage PIERCING 100 sp p ep NoDamageEffect

src/Dodge/Particle/HitEffect.hs

@@ -1,8 +1,10 @@
 module Dodge.Particle.HitEffect
     ( penWalls
+    , module Dodge.Particle.HitEffect.ExpireAndDamage
     ) where
 import Dodge.Data
 import Dodge.Particle.Update
+import Dodge.Particle.HitEffect.ExpireAndDamage
 import Geometry
 
 import Data.Bifunctor

src/Dodge/Placement/PlaceSpot.hs

@@ -143,16 +143,6 @@ addPane wl l wls = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls
   where
     wlid = IM.newKey wls
 
--- | generalised way of putting a new item into a lensed intmap, returning the
--- new index as well
-plNewID :: ALens' World (IM.IntMap a)
-    -> a
-    -> World
-    -> (Int,World)
-plNewID l x w = (i,w & l #%~ IM.insert i x)
-  where
-    i = IM.newKey $ w ^# l
-
 ---- | place an new object into an intmap and update its id
 --plNewUpID :: ALens' World (IM.IntMap a)
 --    -> ALens' a Int

src/Dodge/Prop/Gib.hs

@@ -2,6 +2,7 @@ module Dodge.Prop.Gib where
 import Dodge.Zone
 import Dodge.Base
 import Dodge.Data
+import Dodge.Damage
 import ShapePicture
 import Shape
 import Geometry
@@ -20,7 +21,7 @@ aGib = PropZ
     {_pjPos = 0
     ,_pjStartPos = 0
     ,_pjVel = 0
-    ,_prDraw = drawGib 4
+    ,_prDraw = drawGib 3
     ,_pjID = 0
     ,_pjUpdate = updateGib
     ,_pjPosZ = 10
@@ -73,10 +74,14 @@ updateGib' w pr
         Just (p,v') -> (pjPos .~ p) . (pjVel .~ v')
 
 addCrGibs :: Creature -> World -> World
-addCrGibs cr w = w
-    & addGibAt 25 (_skinHead skin) cpos
-    & addGibsAt 3 7 (_skinLower skin) cpos
-    & addGibsAt 13 20 (_skinUpper skin) cpos
+addCrGibs cr w = case damageDirection $ _crDamage $ _crState cr of
+    Nothing -> w
+        & addGibAt 25 (_skinHead skin) cpos
+        & addGibsAt 3 7 (_skinLower skin) cpos
+        & addGibsAt 13 20 (_skinUpper skin) cpos
+    Just d -> w
+        & addGibsAtDir d 3 7 (_skinLower skin) cpos
+        & addGibsAtDir d 13 20 (_skinUpper skin) cpos
   where
     skin = _crSkin cr
     cpos = _crPos cr
@@ -100,6 +105,27 @@ addGibsAt minh maxh col p w = foldr addg w (zip4 vels zspeeds quats hs)
         & pjVelZ .~ zs
         & pjPosZ .~ h
         )
+
+-- this is ugly because it is mostly copy-paste from addGibsAt
+addGibsAtDir :: Float -> Float -> Float -> Color -> Point2 -> World -> World
+addGibsAtDir dir minh maxh col p w = foldr addg w (zip4 vels zspeeds quats hs)
+    & randGen .~ newg
+  where
+    (speeds,newg) = replicateM 4 (state (randomR (1,4))) & runState $ _randGen w
+    hs = replicateM 4 (state (randomR (minh,maxh))) & evalState $ _randGen w
+    dirs = unitVectorAtAngle <$> (randsSpread (dir-pi/4,dir+pi/4) 4 & evalState $ _randGen w)
+    vels = zipWith (*.*) speeds dirs
+    zspeeds = replicateM 4 (state (randomR (-8,8))) & evalState $ _randGen w
+    quats :: [Q.Quaternion Float]
+    quats = replicateM 4 (Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere) & evalState $ _randGen w
+    addg (v,zs,q,h) = plNew props pjID (aGib & pjPos .~ p +.+ (5 *.* normalizeV v)
+        & pjColor .~ col
+        & pjVel .~ v
+        & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
+        & pjQuat .~ q
+        & pjVelZ .~ zs
+        & pjPosZ .~ h
+        )
   
 addGibAt :: Float -> Color -> Point2 -> World -> World
 addGibAt h col p w = w

src/Dodge/RandomHelp.hs

@@ -97,9 +97,17 @@ maybeTakeOne :: RandomGen g => [a] -> State g (Maybe a)
 maybeTakeOne [] = return Nothing
 maybeTakeOne xs = state (randomR (0,length xs - 1)) >>= (\i -> return (Just (xs !! i)))
 
-randsOnCirc :: RandomGen g => Int -> State g [Float]
-randsOnCirc i
-    | i <= 0    = error "tried to take <= 0 randsOnCirc"
-    | otherwise = zipWith (+) [x,2*x..] <$> replicateM i (state $ randomR (0,x))
+randsSpread :: RandomGen g => (Float,Float) -> Int -> State g [Float]
+randsSpread (a,b) i
+    | i <= 0    = error "tried to take <= 0 randsSpread"
+    | otherwise = zipWith (+) [a+x,a+2*x..] <$> replicateM i (state $ randomR (0,x))
   where
-    x = 2*pi/fromIntegral i
+    x = (b-a)/fromIntegral i
+
+randsOnCirc :: RandomGen g => Int -> State g [Float]
+randsOnCirc = randsSpread (0,2*pi)
+--randsOnCirc i
+--    | i <= 0    = error "tried to take <= 0 randsOnCirc"
+--    | otherwise = zipWith (+) [x,2*x..] <$> replicateM i (state $ randomR (0,x))
+--  where
+--    x = 2*pi/fromIntegral i

src/Geometry/Vector.hs

@@ -68,6 +68,13 @@ dotV (V2 x y) (V2 z w) = x*z + y*w
 argV :: Point2 -> Float
 {-# INLINE argV #-}
 argV (V2 x y) = normalizeAngle $ atan2 y x
+
+{- | Given vector, returns the angle, anticlockwise from +ve x-axis, in radians.  
+ Returns Nothing for a 0 0 vector. -}
+safeArgV :: Point2 -> Maybe Float
+{-# INLINE safeArgV #-}
+safeArgV (V2 0 0) = Nothing
+safeArgV v = Just $ argV v
 {- | Determinant of the matrix formed by two vectors.  -}
 detV :: Point2 -> Point2 -> Float
 {-# INLINE detV #-}

src/Quaternion.hs

@@ -9,6 +9,7 @@ import qualified Linear.Quaternion as Q
 import Linear.Quaternion
 
 -- apply a rotation as if the z axis moves to the new point.
+-- i think this may instead do as if the new point moves to be on z axis
 rotateToZ :: Point3 -> Point3 -> Point3
 rotateToZ z1
     | cprod == V3 0 0 0 = id