Start to move damage effects of bullets into a more sensible place

src/Dodge/Creature/Damage.hs

@@ -1,12 +1,12 @@
 module Dodge.Creature.Damage where
 import Dodge.Data
-import Dodge.SoundLogic
 import Dodge.Creature.Property
 import Dodge.Particle.Spark
+import Dodge.Particle.Bullet.Spawn
 import Color
 import Geometry
+import LensHelp
 
-import Control.Lens
 import Data.List
 
 defaultApplyDamage :: [Damage] -> Creature -> (World -> World, Creature)
@@ -18,34 +18,52 @@ defaultApplyDamage ds cr = over _2 doPoisonDam $ foldl' applyIndividualDamage (i
     poisonDam = quot (max 0 (sum (map _dmAmount ps))) 10
     doPoisonDam = crHP -~ poisonDam
 
-applyDamageEffect :: Damage -> DamageEffect -> Creature -> Creature
+applyDamageEffect :: Damage -> DamageEffect -> (World->World,Creature) -> (World -> World, Creature)
-applyDamageEffect dm de cr = case de of
+applyDamageEffect dm de (f,cr) = case de of
-    NoDamageEffect -> cr
+    PushDamage push pushexp pushRad -> (f, cr 
-    PushDamage push pushexp pushRad -> cr 
+        & crPos %~ (+.+ (pushAmount *.* squashNormalizeV (_crPos cr -.- fromDir))) )
-        & crPos %~ (+.+ (pushAmount *.* squashNormalizeV (_crPos cr -.- fromDir))) 
       where
         pushAmount
             | dist (_crPos cr) fromDir == 0 = 0
             | otherwise = min 5 $ (push*5*pushRad / (dist (_crPos cr) fromDir * _crMass cr))**pushexp
-    PushBackDamage pback -> cr
+    PushBackDamage pback -> (f, cr
         & crPos %~ (+.+ ((1/_crMass cr) *.* pback ))
-    TorqueDamage rot -> cr & crDir +~ rot
+        )
+    TorqueDamage rot -> (f, cr & crDir +~ rot)
+    BounceBullet bt | crIsArmouredFrom p cr -> (f . (instantParticles .:~ bouncer), cr) -- TODO
+      where
+        bouncer = (aBulAt Nothing id (Just (_ptColor bt)) Nothing pOut reflectVel (_btDrag bt)
+                                          (_ptHitEff bt) (_ptWidth bt)
+                  ) {_ptTimer = _ptTimer bt - 1}
+        pOut = p +.+ 2 *.* newDir
+        reflectVel = magV bulVel *.* newDir
+        newDir = squashNormalizeV (p -.- _crPos cr)
+        bulVel = _ptVel bt
+    SparkBullet _ -> (f, cr) -- TODO
+    _ -> (f,cr)
   where
     fromDir = _dmFrom dm
+    p = _dmAt dm
 
 applyIndividualDamage :: (World -> World, Creature) -> Damage -> (World -> World, Creature)
-applyIndividualDamage (f,cr) dm = case _dmType dm of
+applyIndividualDamage (f,cr) dm = applyDamageEffect dm (_dmEffect dm) (f . f', cr')
+  where
+    (f',cr') = applyIndividualDamage' (f,cr) dm
+
+--      & applyDamageEffect dm (_dmEffect dm)
+
+applyIndividualDamage' :: (World -> World, Creature) -> Damage -> (World -> World, Creature)
+applyIndividualDamage' (f,cr) dm = case _dmType dm of
     Piercing -> applyPiercingDamage cr dm & _1 %~ (. f)
     _ -> (f , newcr )
   where
     newcr = cr
       & crHP -~ _dmAmount dm
-      & applyDamageEffect dm (_dmEffect dm)
 
 applyPiercingDamage :: Creature -> Damage -> (World -> World, Creature)
 applyPiercingDamage cr dm
     | crIsArmouredFrom p cr = (colSpark 8 (brightX 10 1.5 orange) p1 (argV (p1 -.- p)) , cr) 
-    | otherwise = (id,cr & crHP -~ _dmAmount dm & applyDamageEffect dm (_dmEffect dm))
+    | otherwise = (id, cr & crHP -~ _dmAmount dm)
   where
     p = _dmAt dm
     p1 = p +.+ 2 *.* squashNormalizeV (p -.- _crPos cr)

src/Dodge/Creature/State/Data.hs

@@ -4,18 +4,10 @@ module Dodge.Creature.State.Data
   where
 --import Geometry
 import Geometry.Data
-import Dodge.Data.DamageType
 import Color
 
 import Control.Lens
 import qualified Data.IntSet as IS
-import qualified Data.Vector as V
-data CreatureState = CrSt 
-    { _crDamage  :: [Damage]
-    , _crPastDamage :: V.Vector [Damage]
-    , _crSpState :: CrSpState
-    , _crDropsOnDeath :: CreatureDropType
-    }
 data CreatureDropType
     = DropAll
     | DropAmount Int
@@ -43,5 +35,4 @@ data CrGroup
     | CrGroupID { _crGroupID :: Int }
     | ShieldGroup
   deriving (Eq, Show)
-makeLenses ''CreatureState
 makeLenses ''CrSpState

src/Dodge/Data.hs

@@ -44,6 +44,7 @@ import Dodge.GameRoom
 import Color
 import Shape
 
+import qualified Data.Vector as V
 import GHC.Generics
 import Control.Lens
 import Control.Monad.State
@@ -1002,6 +1003,47 @@ data Goal
 newtype Zone a = Zone
     { _znObjects :: IM.IntMap (IM.IntMap a)
     }
+data DamageEffect
+    = PushDamage 
+        { _dePush :: Float 
+        , _dePushExp :: Float
+        , _dePushRadius :: Float
+        }
+    | TorqueDamage { _deTorque :: Float }
+    | PushBackDamage {_dePushBack :: Point2 }
+    | BounceBullet {_bulToBounce :: Particle}
+    | SparkBullet {_bulToSpark :: Particle}
+    | NoDamageEffect
+--  deriving (Eq,Ord,Show)
+
+data Damage = Damage 
+    { _dmType :: DamageType
+    , _dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 
+    , _dmEffect :: DamageEffect
+    }
+--  deriving (Eq,Ord,Show)
+
+isElectrical :: Damage -> Bool
+isElectrical dm = case _dmType dm of
+    Electrical{} -> True
+    _ -> False
+
+isMovementDam :: Damage -> Bool
+isMovementDam dm = case _dmType dm of
+    TorqueDam{} -> True
+    PushDam{} -> True
+    _ -> False
+
+data CreatureState = CrSt 
+    { _crDamage  :: [Damage]
+    , _crPastDamage :: V.Vector [Damage]
+    , _crSpState :: CrSpState
+    , _crDropsOnDeath :: CreatureDropType
+    }
+
+makeLenses ''CreatureState
+makeLenses ''Damage
+makeLenses ''DamageEffect
 makeLenses ''World
 makeLenses ''Cloud
 makeLenses ''Creature

src/Dodge/Data/DamageType.hs

@@ -1,17 +1,11 @@
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE StrictData #-}
 {- 
 Datatypes describing the type of damage effects that are to be applied to
 creatures.
 -}
-module Dodge.Data.DamageType
+module Dodge.Data.DamageType where
-    where
+data DamageType 
---import Geometry
+    = Piercing 
-import Geometry.Data
-
-import Control.Lens
-
-data DamageType = Piercing 
     | Blunt    
     | Cutting  
     | SparkDam 
@@ -24,36 +18,3 @@ data DamageType = Piercing
     | PushDam   
     | PoisonDam 
   deriving (Eq,Ord,Show)
-
--- this should possibly be pushed into the damage type
-data DamageEffect
-    = PushDamage 
-        { _dePush :: Float 
-        , _dePushExp :: Float
-        , _dePushRadius :: Float
-        }
-    | TorqueDamage { _deTorque :: Float }
-    | PushBackDamage {_dePushBack :: Point2 }
-    | NoDamageEffect
---  deriving (Eq,Ord,Show)
-
-data Damage = Damage 
-    { _dmType :: DamageType
-    , _dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 
-    , _dmEffect :: DamageEffect
-    }
---  deriving (Eq,Ord,Show)
-
-isElectrical :: Damage -> Bool
-isElectrical dm = case _dmType dm of
-    Electrical{} -> True
-    _ -> False
-
-isMovementDam :: Damage -> Bool
-isMovementDam dm = case _dmType dm of
-    TorqueDam{} -> True
-    PushDam{} -> True
-    _ -> False
-
-makeLenses ''Damage
-makeLenses ''DamageEffect

src/Dodge/Particle/Bullet/DestroyDamage.hs

@@ -4,7 +4,6 @@ module Dodge.Particle.Bullet.DestroyDamage
 import Dodge.Data
 import Dodge.WorldEvent.HitEffect
 import Dodge.Wall.Damage
-import Dodge.SoundLogic
 import Geometry
 import LensHelp
 

src/Dodge/Particle/Bullet/HitEffect.hs

@@ -31,28 +31,6 @@ crArmourSplit normalf armourf bt p cr
     | crIsArmouredFrom p cr = armourf bt p cr
     | otherwise             = normalf bt p cr
 
-basicHitCr :: Particle -> Point2 -> Creature -> World -> World
-basicHitCr bt p cr = addDamage 
-  where
-    sp = head $ _ptTrail bt
-    bulVel = _ptVel bt
-    ep = sp +.+ bulVel
-    mvDams = [ Damage PushDam 1 sp p ep . PushBackDamage $ 2 *.* bulVel ]
-    addDamage = creatures . ix cid . crState . crDamage .++~ 
-        (Damage Piercing 100 sp p ep NoDamageEffect : mvDams)
-    cid = _crID cr
-
--- | Basic bullet hit creature effect.
-basicHitArmour :: Particle -> Point2 -> Creature -> World -> World
-basicHitArmour bt p cr w = colSpark 8 (_ptColor bt) p1 (argV (p1 -.- p)) $ addDamageArmoured w
-  where
-    sp = head $ _ptTrail bt
-    bulVel = _ptVel bt
-    ep = sp +.+ bulVel
-    mvDams = [ Damage PushDam 1 sp p ep . PushBackDamage $ 2 *.* bulVel ]
-    addDamageArmoured = creatures . ix cid . crState . crDamage .++~ mvDams
-    cid = _crID cr
-    p1 = p +.+ 2 *.* squashNormalizeV (p -.- _crPos cr)
 
 bounceArmour :: Particle -> Point2 -> Creature -> World -> World
 bounceArmour bt p cr = addBouncer . addDamageArmoured
@@ -73,12 +51,20 @@ bounceArmour bt p cr = addBouncer . addDamageArmoured
 
 -- | Basic bullet hit creature effect.
 bulHitCr :: Particle -> Point2 -> Creature -> World -> World
-bulHitCr = basicHitCr
+bulHitCr bt p cr = addDamage 
---bulHitCr = crArmourSplit basicHitCr basicHitArmour
+  where
+    sp = head $ _ptTrail bt
+    bulVel = _ptVel bt
+    ep = sp +.+ bulVel
+    mvDams = [ Damage PushDam 1 sp p ep . PushBackDamage $ 2 *.* bulVel ]
+    addDamage = creatures . ix cid . crState . crDamage .++~ 
+        (Damage Piercing 100 sp p ep NoDamageEffect : mvDams)
+    cid = _crID cr
+
 
 {- | Bounce off armoured creatures, otherwise do damage.  -}
 bulBounceArmCr :: Particle -> Point2 -> Creature -> World -> World
-bulBounceArmCr = crArmourSplit basicHitCr bounceArmour
+bulBounceArmCr = crArmourSplit bulHitCr bounceArmour
 {- | Heavy bullet effects when hitting creature:
 piercing, blunt, twisting and pushback damage all applied.  -}
 hvBulHitCr :: Particle -> Point2 -> Creature -> World -> World
@@ -145,18 +131,10 @@ bulHitWall bt p = damageWall (Damage Piercing 100 sp p ep NoDamageEffect)
     sp = head $ _ptTrail bt
 {- | Bounce off walls, do damage to blocks.  -}
 bulBounceWall :: Particle -> Point2 -> Wall -> World -> World
-bulBounceWall bt p wl = damageWall (Damage Blunt 50 sp p ep NoDamageEffect) wl 
+bulBounceWall bt p = damageWall (Damage Blunt 50 sp p ep (BounceBullet bt))
-    . over instantParticles (bouncer :)
   where 
     ep = sp +.+ _ptVel bt
     sp = head $ _ptTrail bt
-    pOut = p +.+ squashNormalizeV (sp -.- p)
-    bouncer = (aBulAt Nothing id (Just (_ptColor bt)) Nothing pOut reflectVel (_btDrag bt) (_ptHitEff bt) (_ptWidth bt)
-              ) {_ptTimer = _ptTimer bt - 1}
-    reflectVel = reflVelWall wl (_ptVel bt)
--- the hack is to get around the fact that the particles list gets reset after
--- all projectiles in it are checked, so we cannot add to it as we accumulate over
--- this list
 
 hvBulHitWall
     :: Particle 

src/Dodge/Wall/DamageEffect.hs

@@ -1,13 +1,15 @@
 module Dodge.Wall.DamageEffect where
 import Dodge.Data
 import Dodge.Particle.Spark
+import Dodge.Particle.Bullet.Spawn
 import Dodge.Wall.Reflect
 import Dodge.Wall.Dust
 import Geometry
 import Color
+import LensHelp
 
 defaultWallDamage :: Damage -> Wall -> World -> World
-defaultWallDamage dm wl = case _dmType dm of
+defaultWallDamage dm wl = wallDamageEffect dm wl . case _dmType dm of
     Lasering -> colSpark 8 lSparkCol outTo (reflDirWall sp p wl)
     Piercing -> colSparkRandDir 0.2 8 pSparkCol outTo (reflDirWall sp p wl)
         . wlDustAt wl outTo
@@ -27,3 +29,15 @@ defaultWallDamage dm wl = case _dmType dm of
     outTo = p +.+ squashNormalizeV (sp -.- p)
     pSparkCol = brightX 100 1.5 white
     lSparkCol = V4 20 (-5) 0 1
+
+wallDamageEffect :: Damage -> Wall -> World -> World
+wallDamageEffect dm wl = case _dmEffect dm of
+    BounceBullet bt -> instantParticles .:~ thebouncer
+      where
+        reflectVel = reflVelWall wl (_ptVel bt)
+        thebouncer = (aBulAt Nothing id (Just (_ptColor bt)) Nothing pOut reflectVel (_btDrag bt) (_ptHitEff bt) (_ptWidth bt)
+              ) {_ptTimer = _ptTimer bt - 1}
+        pOut = p +.+ squashNormalizeV (sp -.- p)
+        p = _dmAt dm
+        sp = _dmFrom dm
+    _ -> id