From 301946ff8fc22f0ced0bf2dfc52b5b21abc66137 Mon Sep 17 00:00:00 2001 From: justin Date: Sat, 16 Jul 2022 21:15:25 +0100 Subject: [PATCH] Move bullets into own data type --- src/Dodge/Combine/Module.hs | 8 ++-- src/Dodge/Creature/Damage.hs | 14 ++++-- src/Dodge/Data.hs | 47 ++++++++++++++----- src/Dodge/Default/World.hs | 2 + src/Dodge/Item/Weapon/AmmoParams.hs | 8 ++-- src/Dodge/Item/Weapon/Bullet.hs | 4 +- src/Dodge/Item/Weapon/BulletGun/Rod.hs | 2 +- src/Dodge/Magnet.hs | 14 +++--- src/Dodge/Particle/Bullet/Draw.hs | 6 +-- src/Dodge/Particle/Bullet/Spawn.hs | 27 +++++------ src/Dodge/Particle/Bullet/Update.hs | 21 +++++++-- src/Dodge/Particle/Damage.hs | 42 ++++++++++------- src/Dodge/Particle/Draw.hs | 11 ++++- src/Dodge/Particle/HitEffect.hs | 17 +++---- .../Particle/HitEffect/ExpireAndDamage.hs | 22 ++++++++- src/Dodge/Particle/HitEffect/Penetrate.hs | 14 +++--- src/Dodge/Particle/Spark.hs | 18 +++---- src/Dodge/Particle/Update.hs | 26 ++++++++-- src/Dodge/Render/ShapePicture.hs | 1 + src/Dodge/Update.hs | 12 +++++ src/Dodge/Wall/DamageEffect.hs | 8 ++-- 21 files changed, 216 insertions(+), 108 deletions(-) diff --git a/src/Dodge/Combine/Module.hs b/src/Dodge/Combine/Module.hs index fa33378ac..ff13d8ebe 100644 --- a/src/Dodge/Combine/Module.hs +++ b/src/Dodge/Combine/Module.hs @@ -20,10 +20,10 @@ moduleModification imt = case imt of DRUMMAG -> itConsumption . laMax .~ 45 BELTMAG -> itConsumption . laMax .~ 150 MAGNETMAG -> itUse . useDelay . rateMax .~ 4 - INCENDBUL -> f $ expireAndDamage $ spawnAtBulDams incBall - BOUNCEBUL -> f $ expireAndDamage bounceBulDams - STATICBUL -> f $ expireAndDamage $ spawnAtBulDams aStaticBall - CONCUSBUL -> f $ expireAndDamage $ spawnAtBulDams concBall + INCENDBUL -> f $ expireAndDamage' $ spawnAtBulDams incBall + BOUNCEBUL -> f $ expireAndDamage' bounceBulDams + STATICBUL -> f $ expireAndDamage' $ spawnAtBulDams aStaticBall + CONCUSBUL -> f $ expireAndDamage' $ spawnAtBulDams concBall TARGCR -> itTargeting .~ targetRBCreature TARGLAS -> itTargeting .~ targetLaser TARGPOS -> itTargeting .~ targetRBPress diff --git a/src/Dodge/Creature/Damage.hs b/src/Dodge/Creature/Damage.hs index 3b27e6d68..77b82d1d7 100644 --- a/src/Dodge/Creature/Damage.hs +++ b/src/Dodge/Creature/Damage.hs @@ -42,20 +42,24 @@ applyDamageEffect dm de cr w = case de of & creatures . ix (_crID cr) . crPos .+.+~ (1/_crMass cr) *.* pback TorqueDamage rot -> w & creatures . ix (_crID cr) . crDir +~ rot - BounceBullet bt | crIsArmouredFrom p cr -> w & instantParticles .:~ bouncer + BounceBullet bt | crIsArmouredFrom p cr -> w & instantBullets .:~ bouncer where - bouncer = (aBulAt Nothing id (Just (_ptColor bt)) pOut reflectVel (_btDrag bt) - (_ptHitEff bt) (_ptWidth bt) - ) {_ptTimer = _ptTimer bt - 1} + bouncer = (aBulAt Nothing id (Just (_buColor bt)) pOut reflectVel (_buDrag bt) + (_buHitEff bt) (_buWidth bt) + ) {_buTimer = _buTimer bt - 1} pOut = p +.+ 2 *.* newDir reflectVel = magV bulVel *.* newDir newDir = squashNormalizeV (p -.- _crPos cr) - bulVel = _ptVel bt + bulVel = _buVel bt BounceBullet _ -> w DamageSpawn f -> w & instantParticles .:~ thepart & randGen .~ g where (thepart,g) = runState (f (Left cr) dm) $ _randGen w + DamageSpawn' f -> w & instantBullets .:~ thepart + & randGen .~ g + where + (thepart,g) = runState (f (Left cr) dm) $ _randGen w NoDamageEffect -> w where fromDir = _dmFrom dm diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 92b963296..53205587f 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -141,6 +141,8 @@ data World = World , _gusts :: IM.IntMap Gust , _gsZoning :: Zoning IM.IntMap Gust , _props :: IM.IntMap Prop + , _instantBullets :: [Bullet] + , _bullets :: [Bullet] , _instantParticles :: [Particle] , _particles :: [Particle] , _radarBlips :: [RadarBlip] @@ -229,7 +231,7 @@ data Magnet = Magnet { _mgID :: Int , _mgUpdate :: Magnet -> Maybe Magnet , _mgPos :: Point2 - , _mgField :: Magnet -> Particle -> Particle + , _mgField :: Magnet -> Bullet -> Bullet } data OptionScreenFlag = NormalOptions | GameOverOptions @@ -522,6 +524,17 @@ data BeamType {_beamCombine :: (Point2 , (Point2,Point2,Beam) , (Point2,Point2,Beam)) -> World -> World} | BeamSimple +data Bullet = Bullet + { _buUpdate :: World -> Bullet -> (World, Maybe Bullet) + , _buVel :: Point2 + , _buDrag :: Float + , _buColor :: Color + , _buTrail :: [Point2] + , _buWidth :: Float + , _buTimer :: Int + , _buHitEff :: HitEffect' + } + {- Objects without ids. Update themselves, perhaps with side effects. -} data Particle @@ -540,6 +553,16 @@ data Particle , _ptPhaseV :: Float , _ptPoints :: [Point2] } + | PtSpark + { _ptUpdate :: World -> Particle -> (World, Maybe Particle) + , _ptVel :: Point2 + , _ptDrag :: Float + , _ptColor :: Color + , _ptTrail :: [Point2] + , _ptWidth :: Float + , _ptTimer :: Int + , _ptHitEff :: HitEffect + } | PtTeslaArc { _ptUpdate :: World -> Particle -> (World, Maybe Particle) , _ptPoints :: [Point2] @@ -551,16 +574,6 @@ data Particle , _ptPoints :: [Point2] , _ptColor :: Color } - | BulletPt - { _ptUpdate :: World -> Particle -> (World, Maybe Particle) - , _ptVel :: Point2 - , _btDrag :: Float - , _ptColor :: Color - , _ptTrail :: [Point2] - , _ptWidth :: Float - , _ptTimer :: Int - , _ptHitEff :: HitEffect - } | PtFlame { _ptUpdate :: World -> Particle -> (World, Maybe Particle) , _ptVel :: Point2 @@ -625,6 +638,11 @@ type HitEffect = Particle -> World -> (World,Maybe Particle) +type HitEffect' = Bullet + -> Stream (Of (Point2, Either Creature Wall)) Identity () + -> World + -> (World,Maybe Bullet) + data BulletTrajectory = BasicBulletTrajectory | BezierTrajectory @@ -641,7 +659,7 @@ data AmmoType } | BulletAmmo { _amString :: String - , _amBulEff :: HitEffect + , _amBulEff :: HitEffect' , _amBulWth :: Float , _amBulVel :: Point2 , _amBulTraj :: BulletTrajectory @@ -1230,9 +1248,11 @@ data DamageEffect } | TorqueDamage { _deTorque :: Float } | PushBackDamage {_dePushBack :: Point2 } - | BounceBullet {_bulToBounce :: Particle} + | BounceBullet {_bulToBounce :: Bullet} | DamageSpawn {_spawnFunc :: Either Creature Wall -> Damage -> State StdGen Particle} + | DamageSpawn' {_spawnFunc' + :: Either Creature Wall -> Damage -> State StdGen Bullet} | NoDamageEffect -- deriving (Eq,Ord,Show) @@ -1388,6 +1408,7 @@ makeLenses ''TweakParam makeLenses ''Prop makeLenses ''Modification makeLenses ''Particle +makeLenses ''Bullet makeLenses ''PressPlate makeLenses ''Button makeLenses ''ActionPlan diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index 78eea1fae..3bc2a9204 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -39,6 +39,8 @@ defaultWorld = World , _gsZoning = Zoning IM.empty clZoneSize (zonePos _guPos) , _itemPositions = IM.empty , _props = IM.empty + , _instantBullets = [] + , _bullets = [] , _instantParticles = [] , _particles = [] , _radarBlips = [] diff --git a/src/Dodge/Item/Weapon/AmmoParams.hs b/src/Dodge/Item/Weapon/AmmoParams.hs index 986e67f0c..d4f26da8c 100644 --- a/src/Dodge/Item/Weapon/AmmoParams.hs +++ b/src/Dodge/Item/Weapon/AmmoParams.hs @@ -15,7 +15,7 @@ import Data.Maybe --import Control.Lens useAmmoParams :: Maybe Float -> Item -> Creature -> World -> World -useAmmoParams vfact it cr w = w & instantParticles .:~ aBulAt +useAmmoParams vfact it cr w = w & instantBullets .:~ aBulAt vfact thetraj -- extra update Nothing -- color (default) @@ -34,15 +34,15 @@ useAmmoParams vfact it cr w = w & instantParticles .:~ aBulAt BasicBulletTrajectory -> id MagnetTrajectory -> fromMaybe id $ do tpos <- it ^? itTargeting . tgPos . _Just - return $ \pt -> pt & ptVel .+.+~ 5 *.* normalizeV (tpos -.- head (_ptTrail pt)) + return $ \pt -> pt & buVel .+.+~ 5 *.* normalizeV (tpos -.- head (_buTrail pt)) FlechetteTrajectory -> fromMaybe id $ do tpos <- it ^? itTargeting . tgPos . _Just - return $ \pt -> pt & ptVel %~ vecTurnTo 0.2 (head $ _ptTrail pt) tpos + return $ \pt -> pt & buVel %~ vecTurnTo 0.2 (head $ _buTrail pt) tpos BezierTrajectory -> fromMaybe id $ do tpos <- it ^? itTargeting . tgPos . _Just let bf t = bQuadToF (sp,mouseWorldPos w,tpos) $ (100 - t) * 0.05 return $ \pt -> pt - & ptVel .~ bf (fromIntegral $ _ptTimer pt - 1) -.- bf (fromIntegral $ _ptTimer pt) + & buVel .~ bf (fromIntegral $ _buTimer pt - 1) -.- bf (fromIntegral $ _buTimer pt) ---- this shouldn't really be used loadedAmmo :: Item -> Int diff --git a/src/Dodge/Item/Weapon/Bullet.hs b/src/Dodge/Item/Weapon/Bullet.hs index 3f85b6291..146d0283c 100644 --- a/src/Dodge/Item/Weapon/Bullet.hs +++ b/src/Dodge/Item/Weapon/Bullet.hs @@ -10,7 +10,7 @@ import Geometry.Data basicBullet :: AmmoType basicBullet = BulletAmmo { _amString = "BASIC" - , _amBulEff = expireAndDamage basicBulDams + , _amBulEff = expireAndDamage' basicBulDams , _amBulWth = 2 , _amBulVel = V2 50 0 , _amBulTraj = BasicBulletTrajectory @@ -18,7 +18,7 @@ basicBullet = BulletAmmo hvBullet :: AmmoType hvBullet = BulletAmmo { _amString = "HVBULLET" - , _amBulEff = expireAndDamage hvBulDams + , _amBulEff = expireAndDamage' hvBulDams , _amBulWth = 6 , _amBulVel = V2 80 0 , _amBulTraj = BasicBulletTrajectory diff --git a/src/Dodge/Item/Weapon/BulletGun/Rod.hs b/src/Dodge/Item/Weapon/BulletGun/Rod.hs index a29fc2bfa..6bd5f0561 100644 --- a/src/Dodge/Item/Weapon/BulletGun/Rod.hs +++ b/src/Dodge/Item/Weapon/BulletGun/Rod.hs @@ -63,7 +63,7 @@ bangRod = defaultBulletWeapon & itUse . useAim . aimZoom .~ defaultItZoom {_itZoomFac = 1.5} & itUse . useAim . aimHandlePos .~ 5 & itUse . useAim . aimMuzPos .~ 30 - & itConsumption . laAmmoType . amBulEff .~ expireAndDamage heavyBulDams + & itConsumption . laAmmoType . amBulEff .~ expireAndDamage' heavyBulDams elephantGun :: Item elephantGun = bangRod & itType . iyBase .~ HELD ELEPHANTGUN diff --git a/src/Dodge/Magnet.hs b/src/Dodge/Magnet.hs index bc317e384..95c695737 100644 --- a/src/Dodge/Magnet.hs +++ b/src/Dodge/Magnet.hs @@ -4,23 +4,23 @@ import Geometry import Control.Lens -dampField :: Magnet -> Particle -> Particle +dampField :: Magnet -> Bullet -> Bullet dampField mg pt = case pt of - BulletPt{} | dist (head $ _ptTrail pt) (_mgPos mg) < 100 -> pt & ptVel *~ 0.5 + Bullet{} | dist (head $ _buTrail pt) (_mgPos mg) < 100 -> pt & buVel *~ 0.5 _ -> pt -curveLeftField :: Magnet -> Particle -> Particle +curveLeftField :: Magnet -> Bullet -> Bullet curveLeftField mg pt = case pt of - BulletPt{} | dist (head $ _ptTrail pt) (_mgPos mg) < 500 -> pt & ptVel %~ rotateV 0.2 + Bullet{} | dist (head $ _buTrail pt) (_mgPos mg) < 500 -> pt & buVel %~ rotateV 0.2 _ -> pt -curveAroundField :: Float -> Float -> Magnet -> Particle -> Particle +curveAroundField :: Float -> Float -> Magnet -> Bullet -> Bullet curveAroundField minrad maxrad mg pt = case pt of - BulletPt{} | thedist < maxrad -> pt & ptVel %~ rotateToCircle + Bullet{} | thedist < maxrad -> pt & buVel %~ rotateToCircle where thedist = dist btpos mgpos mgpos = _mgPos mg - btpos = head $ _ptTrail pt + btpos = head $ _buTrail pt rotateToCircle vel | (isLHS mgpos btpos (btpos +.+ vel) && isRHS mgpos btpos (mgpos +.+ vNormal vel) ) || (isRHS mgpos btpos (btpos +.+ vel) && isLHS mgpos btpos (mgpos +.+ vNormal vel) ) diff --git a/src/Dodge/Particle/Bullet/Draw.hs b/src/Dodge/Particle/Bullet/Draw.hs index 107a09610..48c1b7360 100644 --- a/src/Dodge/Particle/Bullet/Draw.hs +++ b/src/Dodge/Particle/Bullet/Draw.hs @@ -4,9 +4,9 @@ module Dodge.Particle.Bullet.Draw import Dodge.Data import Picture -drawBul :: Particle -> Picture +drawBul :: Bullet -> Picture drawBul pt = setLayer BloomNoZWrite . setDepth 20 - . color (_ptColor pt) + . color (_buColor pt) -- $ thickLine (_ptWidth pt) (take 3 $ _ptTrail pt) - $ thickLine (_ptWidth pt) (take 2 $ _ptTrail pt) + $ thickLine (_buWidth pt) (take 2 $ _buTrail pt) diff --git a/src/Dodge/Particle/Bullet/Spawn.hs b/src/Dodge/Particle/Bullet/Spawn.hs index 7ba369f82..cb9d478a4 100644 --- a/src/Dodge/Particle/Bullet/Spawn.hs +++ b/src/Dodge/Particle/Bullet/Spawn.hs @@ -12,27 +12,26 @@ import Data.Bifunctor aBulAt :: Maybe Float -- ^ Start velocity step factor - -> (Particle -> Particle) + -> (Bullet -> Bullet) -> Maybe Color -> Point2 -- ^ Start position -> Point2 -- ^ Velocity -> Float -- ^ Drag - -> HitEffect + -> HitEffect' -> Float -- ^ Bullet width - -> Particle -aBulAt vfact updatemod mcol pos vel drag hiteff width = BulletPt - { _ptUpdate = theupdate - , _ptVel = fromMaybe 1 vfact *.* vel - , _btDrag = drag - , _ptColor = fromMaybe (V4 200 200 200 2) mcol --- , _ptColor = V4 2 2 2 2 - , _ptTrail = [pos] - , _ptWidth = width - , _ptTimer = 100 - , _ptHitEff = hiteff + -> Bullet +aBulAt vfact updatemod mcol pos vel drag hiteff width = Bullet + { _buUpdate = theupdate + , _buVel = fromMaybe 1 vfact *.* vel + , _buDrag = drag + , _buColor = fromMaybe (V4 200 200 200 2) mcol + , _buTrail = [pos] + , _buWidth = width + , _buTimer = 100 + , _buHitEff = hiteff } where theupdate = case vfact of Just _ -> \w -> resetVel . mvBullet w . updatemod Nothing -> \w -> mvBullet w . updatemod - resetVel = second $ fmap $ (ptUpdate .~ (\w -> mvBullet w . updatemod)) . (ptVel .~ vel) + resetVel = second $ fmap $ (buUpdate .~ (\w -> mvBullet w . updatemod)) . (buVel .~ vel) diff --git a/src/Dodge/Particle/Bullet/Update.hs b/src/Dodge/Particle/Bullet/Update.hs index e00f6ba87..a816576d4 100644 --- a/src/Dodge/Particle/Bullet/Update.hs +++ b/src/Dodge/Particle/Bullet/Update.hs @@ -2,6 +2,7 @@ {- Bullet update. -} module Dodge.Particle.Bullet.Update ( mvBullet + , mvSpark ) where import Dodge.Data --import Dodge.Base @@ -12,15 +13,29 @@ import LensHelp import Data.Bifunctor {- Update for a generic bullet. -} -mvBullet :: World -> Particle -> (World, Maybe Particle) +mvBullet :: World -> Bullet -> (World, Maybe Bullet) mvBullet w bt' - | t <= 0 || magV (_ptVel bt) < 1 = (w,Nothing) + | t <= 0 || magV (_buVel bt) < 1 = (w,Nothing) | otherwise = second (fmap dodrag) $ hiteff bt (thingsHit p (p +.+ vel) w) w where bt = foldr (\mg b -> _mgField mg mg b) bt' $ _magnets w + dodrag = buVel .*.*~ drag + drag = _buDrag bt + (p:_) = _buTrail bt + vel = _buVel bt + hiteff = _buHitEff bt + t = _buTimer bt + +mvSpark :: World -> Particle -> (World, Maybe Particle) +mvSpark w bt' + | t <= 0 || magV (_ptVel bt) < 1 = (w,Nothing) + | otherwise = second (fmap dodrag) $ + hiteff bt (thingsHit p (p +.+ vel) w) w + where + bt = bt' dodrag = ptVel .*.*~ drag - drag = _btDrag bt + drag = _ptDrag bt (p:_) = _ptTrail bt vel = _ptVel bt hiteff = _ptHitEff bt diff --git a/src/Dodge/Particle/Damage.hs b/src/Dodge/Particle/Damage.hs index 615743fcb..33ff5d849 100644 --- a/src/Dodge/Particle/Damage.hs +++ b/src/Dodge/Particle/Damage.hs @@ -8,43 +8,49 @@ import Control.Monad.State -- TODO unify particle position in a sensible manner spawnAtBulDams :: (Point2 -> State StdGen Particle) - -> Particle -> Point2 -> [Damage] + -> Bullet -> Point2 -> [Damage] spawnAtBulDams thespawn bt p = [ Damage PIERCING 50 sp p ep (DamageSpawn $ \_ dm -> thespawn (_dmAt dm)) , Damage PUSHDAM 1 sp p ep . PushBackDamage $ 2 *.* bulVel ] where - sp = head $ _ptTrail bt - bulVel = _ptVel bt + sp = head $ _buTrail bt + bulVel = _buVel bt ep = sp +.+ bulVel simpleDam :: DamageType -> Int -> Particle -> Point2 -> [Damage] simpleDam dt amount bt p = [ Damage dt amount sp p ep NoDamageEffect ] where - sp = case bt ^? ptTrail of - Nothing -> _ptPos bt - Just xs -> head xs + sp = _ptPos bt bulVel = _ptVel bt ep = sp +.+ bulVel +simpleDam' :: DamageType -> Int -> Bullet -> Point2 -> [Damage] +simpleDam' dt amount bt p = [ Damage dt amount sp p ep NoDamageEffect ] + where + sp = case bt ^? buTrail of + Nothing -> 0 + Just xs -> head xs + bulVel = _buVel bt + ep = sp +.+ bulVel -heavyBulDams :: Particle -> Point2 -> [Damage] +heavyBulDams :: Bullet -> 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 + sp = head $ _buTrail bt + bulVel = _buVel bt ep = sp +.+ bulVel -basicBulDams :: Particle -> Point2 -> [Damage] +basicBulDams :: Bullet -> Point2 -> [Damage] basicBulDams bt p = [ Damage PIERCING 100 sp p ep NoDamageEffect , Damage PUSHDAM 1 sp p ep . PushBackDamage $ 2 *.* bulVel ] where - sp = head $ _ptTrail bt - bulVel = _ptVel bt + sp = head $ _buTrail bt + bulVel = _buVel bt ep = sp +.+ bulVel basicSparkDams :: Particle -> Point2 -> [Damage] @@ -54,7 +60,7 @@ basicSparkDams bt p = [ Damage SPARKING 1 sp p ep NoDamageEffect ] bulVel = _ptVel bt ep = sp +.+ bulVel -hvBulDams :: Particle -> Point2 -> [Damage] +hvBulDams :: Bullet -> Point2 -> [Damage] hvBulDams bt p = [ Damage PIERCING 25 sp p ep NoDamageEffect , Damage PIERCING 25 sp p ep NoDamageEffect @@ -66,16 +72,16 @@ hvBulDams bt p = , Damage PUSHDAM 1 sp p ep . PushBackDamage $ 3 *.* (ep -.- sp) ] where - sp = head $ _ptTrail bt - bulVel = _ptVel bt + sp = head $ _buTrail bt + bulVel = _buVel bt ep = sp +.+ bulVel -bounceBulDams :: Particle -> Point2 -> [Damage] +bounceBulDams :: Bullet -> Point2 -> [Damage] bounceBulDams bt p = [ Damage PIERCING 80 sp p ep (BounceBullet bt) , Damage PUSHDAM 1 sp p ep . PushBackDamage $ 2 *.* bulVel ] where - sp = head $ _ptTrail bt - bulVel = _ptVel bt + sp = head $ _buTrail bt + bulVel = _buVel bt ep = sp +.+ bulVel diff --git a/src/Dodge/Particle/Draw.hs b/src/Dodge/Particle/Draw.hs index db3ccd150..9d59215a9 100644 --- a/src/Dodge/Particle/Draw.hs +++ b/src/Dodge/Particle/Draw.hs @@ -10,7 +10,7 @@ drawParticle pt = case pt of PtStaticBall {} -> drawStaticBall pt PtIncBall {} -> drawFlameletZ pt PtInvShockwave {} -> drawInverseShockwave pt - BulletPt {} -> drawBul pt + PtSpark {} -> drawSpark pt PtTeslaArc {} -> drawTeslaArc pt PtTargetLaser {} -> drawTargetLaser pt LaserParticle {} -> drawLaser pt @@ -124,8 +124,15 @@ drawInverseShockwave pt rad = r - 0.1 * r * fromIntegral (10 - t) thickness = fromIntegral (10 - t) **2 * rad / 40 -drawBul :: Particle -> Picture +drawBul :: Bullet -> Picture drawBul pt = setLayer BloomNoZWrite + . setDepth 20 + . color (_buColor pt) + -- $ thickLine (_ptWidth pt) (take 3 $ _ptTrail pt) + $ thickLine (_buWidth pt) (take 2 $ _buTrail pt) + +drawSpark :: Particle -> Picture +drawSpark pt = setLayer BloomNoZWrite . setDepth 20 . color (_ptColor pt) -- $ thickLine (_ptWidth pt) (take 3 $ _ptTrail pt) diff --git a/src/Dodge/Particle/HitEffect.hs b/src/Dodge/Particle/HitEffect.hs index a120ca98d..7ca1d185f 100644 --- a/src/Dodge/Particle/HitEffect.hs +++ b/src/Dodge/Particle/HitEffect.hs @@ -8,19 +8,20 @@ import Dodge.Particle.HitEffect.ExpireAndDamage import Geometry import Data.Bifunctor -type HitCreatureEffect = Particle -> Point2 -> Creature -> World -> World -type HitWallEffect = Particle -> Point2 -> Wall -> World -> World + +type HitCreatureEffect' = Bullet -> Point2 -> Creature -> World -> World +type HitWallEffect' = Bullet -> Point2 -> Wall -> World -> World penWalls - :: HitCreatureEffect - -> HitWallEffect - -> Particle + :: HitCreatureEffect' + -> HitWallEffect' + -> Bullet -> [(Point2, Either Creature Wall)] -> World - -> (World, Maybe Particle) + -> (World, Maybe Bullet) penWalls crEff wlEff pt hitThings w = case hitThings of [] -> ( w, mvPt pt) - ((p,Left cr):_) -> (crEff pt p cr w, destroyAt p pt) + ((p,Left cr):_) -> (crEff pt p cr w, destroyAt' p pt) ((p,Right wl):hs) | _wlFireThrough wl -> first (wlEff pt p wl) $ penWalls crEff wlEff pt hs w - ((p,Right wl):_) -> (wlEff pt p wl w, destroyAt p pt) + ((p,Right wl):_) -> (wlEff pt p wl w, destroyAt' p pt) diff --git a/src/Dodge/Particle/HitEffect/ExpireAndDamage.hs b/src/Dodge/Particle/HitEffect/ExpireAndDamage.hs index 841bb4505..0ef82f389 100644 --- a/src/Dodge/Particle/HitEffect/ExpireAndDamage.hs +++ b/src/Dodge/Particle/HitEffect/ExpireAndDamage.hs @@ -14,9 +14,18 @@ expireAndDamage :: (Particle -> Point2 -> [Damage]) -> World -> (World, Maybe Particle) expireAndDamage fdm bt things w = case runIdentity $ S.head_ things of - Nothing -> (w, mvPt bt) + Nothing -> (w, mvPt' bt) Just x -> (doDamages fdm x bt w, destroyAt (fst x) bt) +expireAndDamage' :: (Bullet -> Point2 -> [Damage]) + -> Bullet + -> Stream (Of (Point2, Either Creature Wall)) Identity () + -> World + -> (World, Maybe Bullet) +expireAndDamage' fdm bt things w = case runIdentity $ S.head_ things of + Nothing -> (w, mvPt bt) + Just x -> (doDamages' fdm x bt w, destroyAt' (fst x) bt) + doDamages :: (Particle -> Point2 -> [Damage]) -> (Point2, Either Creature Wall) -> Particle @@ -27,3 +36,14 @@ doDamages fdm (p,thhit) bt = case thhit of Right wl -> wallDamages %~ IM.insertWith (++) (_wlID wl) dams where dams = fdm bt p + +doDamages' :: (Bullet -> Point2 -> [Damage]) + -> (Point2, Either Creature Wall) + -> Bullet + -> World + -> World +doDamages' fdm (p,thhit) bt = case thhit of + Left cr -> creatures . ix (_crID cr) . crState . csDamage .++~ dams + Right wl -> wallDamages %~ IM.insertWith (++) (_wlID wl) dams + where + dams = fdm bt p diff --git a/src/Dodge/Particle/HitEffect/Penetrate.hs b/src/Dodge/Particle/HitEffect/Penetrate.hs index 2810d8c0f..04afbdc94 100644 --- a/src/Dodge/Particle/HitEffect/Penetrate.hs +++ b/src/Dodge/Particle/HitEffect/Penetrate.hs @@ -10,16 +10,16 @@ import Streaming import qualified Streaming.Prelude as S penetrate - :: ((Point2,Either Creature Wall) -> Particle -> Maybe Particle) + :: ((Point2,Either Creature Wall) -> Bullet -> Maybe Bullet) -- | penetration test, can update particle if it penetrates - -> (Particle -> Point2 -> [Damage]) -- | damages when penetrating - -> (Particle -> Point2 -> [Damage]) -- | damages when not penetrating - -> Particle + -> (Bullet -> Point2 -> [Damage]) -- | damages when penetrating + -> (Bullet -> Point2 -> [Damage]) -- | damages when not penetrating + -> Bullet -> Stream (Of (Point2, Either Creature Wall)) Identity () -> World - -> (World, Maybe Particle) + -> (World, Maybe Bullet) penetrate t pendam stopdam pt hitThings w = case runIdentity $ S.uncons hitThings of Nothing -> (w, mvPt pt) Just (x,xs) -> case t x pt of - Nothing -> expireAndDamage stopdam pt hitThings w - Just pt' -> first (doDamages pendam x pt) $ penetrate t pendam stopdam pt' xs w + Nothing -> expireAndDamage' stopdam pt hitThings w + Just pt' -> first (doDamages' pendam x pt) $ penetrate t pendam stopdam pt' xs w diff --git a/src/Dodge/Particle/Spark.hs b/src/Dodge/Particle/Spark.hs index 40b4b4340..0690f2572 100644 --- a/src/Dodge/Particle/Spark.hs +++ b/src/Dodge/Particle/Spark.hs @@ -19,10 +19,10 @@ import System.Random --import Control.Lens -- TODO remove/simplify this function createBarrelSpark :: Point2 -> Float -> Int -> Int -> World -> World -createBarrelSpark pos dir time colid = instantParticles .:~ BulletPt - { _ptUpdate = mvBullet +createBarrelSpark pos dir time colid = instantParticles .:~ PtSpark + { _ptUpdate = mvSpark , _ptVel = rotateV dir (V2 5 0) - , _btDrag = 0.9 + , _ptDrag = 0.9 , _ptColor = numColor colid , _ptTrail = [pos] , _ptWidth = 1 @@ -48,9 +48,9 @@ randColDirTimeSpark randcol randdir randtime pos w = w d <- randdir t <- randtime return (c,d,t) - spark = BulletPt - { _ptUpdate = mvBullet - , _btDrag = 0.9 + spark = PtSpark + { _ptUpdate = mvSpark + , _ptDrag = 0.9 , _ptVel = rotateV dir (V2 5 0) , _ptColor = col , _ptTrail = [pos] @@ -66,9 +66,9 @@ colSparkRandDir randDir time col pos baseDir w = w where (a,g) = randomR (-randDir,randDir) $ _randGen w dir = a + baseDir - spark = BulletPt - { _ptUpdate = mvBullet - , _btDrag = 0.9 + spark = PtSpark + { _ptUpdate = mvSpark + , _ptDrag = 0.9 , _ptVel = rotateV dir (V2 5 0) , _ptColor = col , _ptTrail = [pos] diff --git a/src/Dodge/Particle/Update.hs b/src/Dodge/Particle/Update.hs index 47af2a369..e529dbdd4 100644 --- a/src/Dodge/Particle/Update.hs +++ b/src/Dodge/Particle/Update.hs @@ -3,8 +3,15 @@ import Dodge.Data import LensHelp import Geometry -mvPt :: Particle -> Maybe Particle +mvPt :: Bullet -> Maybe Bullet mvPt pt = Just $ pt + & buTrail %~ f + & buTimer -~ 1 + where + f trl = head trl +.+ _buVel pt : trl + +mvPt' :: Particle -> Maybe Particle +mvPt' pt = Just $ pt & ptTrail %~ f & ptTimer -~ 1 where @@ -12,12 +19,25 @@ mvPt pt = Just $ pt destroyAt :: Point2 -> Particle -> Maybe Particle destroyAt hitp pt = Just $ pt - & ptUpdate .~ killBulletUpdate + & ptUpdate .~ killParticleUpdate & ptTrail .:~ hitp & ptTimer %~ (min 3 . subtract 1) +destroyAt' :: Point2 -> Bullet -> Maybe Bullet +destroyAt' hitp pt = Just $ pt + & buUpdate .~ killBulletUpdate + & buTrail .:~ hitp + & buTimer %~ (min 3 . subtract 1) -killBulletUpdate :: World -> Particle -> (World,Maybe Particle) +killBulletUpdate :: World -> Bullet -> (World,Maybe Bullet) killBulletUpdate w pt + | _buTimer pt <= 0 = (w,Nothing) + | otherwise = (w + , Just $ pt & buTimer -~ 1 + & buTrail %~ (\(x:xs) -> x:x:xs) + ) + +killParticleUpdate :: World -> Particle -> (World,Maybe Particle) +killParticleUpdate w pt | _ptTimer pt <= 0 = (w,Nothing) | otherwise = (w , Just $ pt & ptTimer -~ 1 diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index c15930094..292371bb9 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -84,6 +84,7 @@ cullPoint cfig w p extraPics :: Configuration -> World -> Picture extraPics cfig w = pictures (_decorations w) <> concatMapPic drawParticle (_particles w) + <> concatMapPic drawBul (_bullets w) <> concatMapPic drawBlip (_radarBlips w) <> concatMapPic drawFlare (_flares w) <> concatMapPic (dbArg _bmDraw) (_positronBeams $ _beams w) diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index a23aac20a..53fa92252 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -81,6 +81,7 @@ functionalUpdate cfig w = checkEndGame . dbArg _worldEvents . updateIMl _modifications _mdUpdate . updateParticles + . updateBullets . updateRadarBlips . updateFlares . updateBeams @@ -212,6 +213,12 @@ updateRadarBlips = radarBlips %~ mapMaybe updateRadarBlip updateFlares :: World -> World updateFlares = flares %~ mapMaybe updateFlare +{- Apply internal particle updates, delete 'Nothing's. -} +updateBullets :: World -> World +updateBullets w = updateInstantBullets $ set bullets (catMaybes ps) w' + where + (w',ps) = mapAccumR (\a b -> _buUpdate b a b) w $ _bullets w + {- Apply internal particle updates, delete 'Nothing's. -} updateParticles :: World -> World updateParticles w = updateInstantParticles $ set particles (catMaybes ps) w' @@ -287,6 +294,11 @@ intersectSegSegs' _ _ _ = Nothing -- Just -- (intersectSegSegss x y ass) --intersectSegsSegss _ _ = Nothing +updateInstantBullets :: World -> World +updateInstantBullets w = case _instantBullets w of + [] -> w + ps -> let (w',ps') = mapAccumR (\a b -> _buUpdate b a b) (w {_instantBullets=[]}) ps + in updateInstantBullets $ w' & bullets .++~ catMaybes ps' updateInstantParticles :: World -> World updateInstantParticles w = case _instantParticles w of diff --git a/src/Dodge/Wall/DamageEffect.hs b/src/Dodge/Wall/DamageEffect.hs index 6522910fb..cd5ecdfe1 100644 --- a/src/Dodge/Wall/DamageEffect.hs +++ b/src/Dodge/Wall/DamageEffect.hs @@ -133,11 +133,11 @@ dirtWallDamage dm wl = case _dmType dm of wallDamageEffect :: Damage -> Wall -> World -> World wallDamageEffect dm wl w = case _dmEffect dm of - BounceBullet bt -> w & instantParticles .:~ thebouncer + BounceBullet bt -> w & instantBullets .:~ thebouncer where - reflectVel = reflVelWall wl (_ptVel bt) - thebouncer = aBulAt Nothing id (Just (_ptColor bt)) pOut reflectVel (_btDrag bt) (_ptHitEff bt) (_ptWidth bt) - & ptTimer .~ _ptTimer bt - 1 + reflectVel = reflVelWall wl (_buVel bt) + thebouncer = aBulAt Nothing id (Just (_buColor bt)) pOut reflectVel (_buDrag bt) (_buHitEff bt) (_buWidth bt) + & buTimer .~ _buTimer bt - 1 pOut = p +.+ squashNormalizeV (sp -.- p) p = _dmAt dm sp = _dmFrom dm