diff --git a/src/Dodge/Base/NewID.hs b/src/Dodge/Base/NewID.hs index 96edac72d..ae31c338a 100644 --- a/src/Dodge/Base/NewID.hs +++ b/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 diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index 1256fc1af..2ed5a8208 100644 --- a/src/Dodge/Creature.hs +++ b/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 diff --git a/src/Dodge/Creature/Picture.hs b/src/Dodge/Creature/Picture.hs index db10f2112..da346d69c 100644 --- a/src/Dodge/Creature/Picture.hs +++ b/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 #-} diff --git a/src/Dodge/Creature/State.hs b/src/Dodge/Creature/State.hs index 407233cf6..5dabc5b89 100644 --- a/src/Dodge/Creature/State.hs +++ b/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 diff --git a/src/Dodge/Damage.hs b/src/Dodge/Damage.hs index 08a494345..4e639c1bc 100644 --- a/src/Dodge/Damage.hs +++ b/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) diff --git a/src/Dodge/Item/Weapon/BulletGun/Rod.hs b/src/Dodge/Item/Weapon/BulletGun/Rod.hs index a94cbe77c..d09ab838a 100644 --- a/src/Dodge/Item/Weapon/BulletGun/Rod.hs +++ b/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 diff --git a/src/Dodge/Particle/Damage.hs b/src/Dodge/Particle/Damage.hs index 85ca66bd7..615743fcb 100644 --- a/src/Dodge/Particle/Damage.hs +++ b/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 diff --git a/src/Dodge/Particle/HitEffect.hs b/src/Dodge/Particle/HitEffect.hs index 8c600e02d..a120ca98d 100644 --- a/src/Dodge/Particle/HitEffect.hs +++ b/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 diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index aa7f3cfb1..f8c3d0598 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/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 diff --git a/src/Dodge/Prop/Gib.hs b/src/Dodge/Prop/Gib.hs index c9e27a117..b1b56ae67 100644 --- a/src/Dodge/Prop/Gib.hs +++ b/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 diff --git a/src/Dodge/RandomHelp.hs b/src/Dodge/RandomHelp.hs index 83256a49f..59fb89dc1 100644 --- a/src/Dodge/RandomHelp.hs +++ b/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 diff --git a/src/Geometry/Vector.hs b/src/Geometry/Vector.hs index 5ee0b24f4..b394a76f3 100644 --- a/src/Geometry/Vector.hs +++ b/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 #-} diff --git a/src/Quaternion.hs b/src/Quaternion.hs index c6ef61c85..2c7f42ddc 100644 --- a/src/Quaternion.hs +++ b/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