From 5495d33389cb7afba4b096005e42dcb232ba0c02 Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 18 Jul 2022 12:15:05 +0100 Subject: [PATCH] Move sparks into dedicated datatype --- src/Dodge/Creature/Damage.hs | 2 +- src/Dodge/Creature/Inanimate.hs | 5 +- src/Dodge/Data.hs | 13 +-- src/Dodge/Data/Spark.hs | 14 +++ src/Dodge/Default/World.hs | 1 + src/Dodge/Material/Damage.hs | 4 +- src/Dodge/Particle/Damage.hs | 8 -- src/Dodge/Particle/Draw.hs | 7 -- .../Particle/HitEffect/ExpireAndDamage.hs | 3 +- src/Dodge/Particle/TeslaArc.hs | 3 +- src/Dodge/Particle/Update.hs | 10 +- src/Dodge/Render/ShapePicture.hs | 2 + src/Dodge/Spark.hs | 103 ++++++++---------- src/Dodge/Spark/Draw.hs | 9 ++ src/Dodge/Update.hs | 7 ++ src/Dodge/Wall/DamageEffect.hs | 12 +- 16 files changed, 99 insertions(+), 104 deletions(-) create mode 100644 src/Dodge/Data/Spark.hs create mode 100644 src/Dodge/Spark/Draw.hs diff --git a/src/Dodge/Creature/Damage.hs b/src/Dodge/Creature/Damage.hs index c2810568c..c0ff82700 100644 --- a/src/Dodge/Creature/Damage.hs +++ b/src/Dodge/Creature/Damage.hs @@ -59,7 +59,7 @@ applyIndividualDamage' cr w dm = case _dmType dm of applyPiercingDamage :: Creature -> Damage -> World -> World applyPiercingDamage cr dm - | crIsArmouredFrom p cr = colSpark 8 (brightX 10 1.5 orange) p1 (argV (p1 -.- p)) + | crIsArmouredFrom p cr = colSpark (brightX 10 1.5 orange) p1 (argV (p1 -.- p)) | otherwise = damageHP cr $ _dmAmount dm where p = _dmAt dm diff --git a/src/Dodge/Creature/Inanimate.hs b/src/Dodge/Creature/Inanimate.hs index 18eeb4cb3..415d3420b 100644 --- a/src/Dodge/Creature/Inanimate.hs +++ b/src/Dodge/Creature/Inanimate.hs @@ -70,11 +70,10 @@ updateExpBarrel cr w damages = _csDamage $ _crState cr pierceSparks :: [World -> World] pierceSparks - = zipWith4 (\p a -> createBarrelSpark (_crPos cr +.+ p) (a + argV p)) - poss as times colids + = zipWith3 (\p a -> createBarrelSpark (_crPos cr +.+ p) (a + argV p)) + poss as colids as = randomRs (-0.7,0.7) g colids = randomRs (0,11) g - times = randomRs (2,5) g poss = _piercedPoints $ _csSpState $ _crState cr newCr = Just $ applyFuseDamage $ set (crState . csDamage) [] $ damToExpBarrel damages cr applyFuseDamage cr' = cr' & crHP %~ diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 751823ebf..d136b3239 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -10,6 +10,7 @@ circular imports are probably not a good idea. {-# LANGUAGE DerivingStrategies #-} module Dodge.Data ( module Dodge.Data + , module Dodge.Data.Spark , module Dodge.Data.Bullet , module Dodge.Data.Door , module Dodge.Data.Item @@ -47,6 +48,7 @@ module Dodge.Data , module Dodge.Data.RadarBlip , module Dodge.Data.PathGraph ) where +import Dodge.Data.Spark import Dodge.Data.Bullet import Dodge.Data.Door import Dodge.Data.Item @@ -147,6 +149,7 @@ data World = World , _bullets :: [Bullet] , _instantParticles :: [Particle] , _particles :: [Particle] + , _sparks :: [Spark] , _radarBlips :: [RadarBlip] , _flares :: [Flare] , _newBeams :: WorldBeams @@ -544,16 +547,6 @@ 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] diff --git a/src/Dodge/Data/Spark.hs b/src/Dodge/Data/Spark.hs new file mode 100644 index 000000000..851aa8816 --- /dev/null +++ b/src/Dodge/Data/Spark.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StrictData #-} +module Dodge.Data.Spark where +import Geometry.Data +import Color +import Control.Lens +data Spark = Spark + { _skVel :: Point2 + , _skColor :: Color + , _skPos :: Point2 + , _skOldPos :: Point2 + , _skWidth :: Float + } +makeLenses ''Spark diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index 3bc2a9204..5587a779f 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -43,6 +43,7 @@ defaultWorld = World , _bullets = [] , _instantParticles = [] , _particles = [] + , _sparks = [] , _radarBlips = [] , _flares = [] , _newBeams = WorldBeams [] [] [] [] diff --git a/src/Dodge/Material/Damage.hs b/src/Dodge/Material/Damage.hs index 96b33482e..efb9800a1 100644 --- a/src/Dodge/Material/Damage.hs +++ b/src/Dodge/Material/Damage.hs @@ -16,8 +16,8 @@ defDamageMaterial dm _ w = (_dmAmount dm, w) damageStone :: Damage -> Float -> World -> (Int,World) damageStone dm dir = case _dmType dm of - LASERING -> a 0 $ colSparkRandDir 0.2 4 lSparkCol outTo (argV $ reflectIn (p -.- sp) v) - PIERCING -> a d $ colSparkRandDir 0.2 8 pSparkCol outTo (argV $ reflectIn (p -.- sp) v) + LASERING -> a 0 $ colSparkRandDir 0.2 lSparkCol outTo (argV $ reflectIn (p -.- sp) v) + PIERCING -> a d $ colSparkRandDir 0.2 pSparkCol outTo (argV $ reflectIn (p -.- sp) v) BLUNT -> a d id SHATTERING -> a d id CRUSHING -> a d id diff --git a/src/Dodge/Particle/Damage.hs b/src/Dodge/Particle/Damage.hs index 5fb49cac7..534fd1297 100644 --- a/src/Dodge/Particle/Damage.hs +++ b/src/Dodge/Particle/Damage.hs @@ -15,14 +15,6 @@ simpleDam' dt amount bt p = [ Damage dt amount sp p ep NoDamageEffect ] bulVel = _buVel bt ep = sp +.+ bulVel - -basicSparkDams :: Particle -> Point2 -> [Damage] -basicSparkDams bt p = [ Damage SPARKING 1 sp p ep NoDamageEffect ] - where - sp = head $ _ptTrail bt - bulVel = _ptVel bt - ep = sp +.+ bulVel - hvBulDams :: [Damage] hvBulDams = [ Damage PIERCING 25 0 0 0 NoDamageEffect diff --git a/src/Dodge/Particle/Draw.hs b/src/Dodge/Particle/Draw.hs index d0bcf1daa..4b661af29 100644 --- a/src/Dodge/Particle/Draw.hs +++ b/src/Dodge/Particle/Draw.hs @@ -10,7 +10,6 @@ drawParticle pt = case pt of PtStaticBall {} -> drawStaticBall pt PtIncBall {} -> drawFlameletZ pt PtInvShockwave {} -> drawInverseShockwave pt - PtSpark {} -> drawSpark pt PtTeslaArc {} -> drawTeslaArc pt PtTargetLaser {} -> drawTargetLaser pt LaserParticle {} -> drawLaser pt @@ -124,12 +123,6 @@ drawInverseShockwave pt rad = r - 0.1 * r * fromIntegral (10 - t) thickness = fromIntegral (10 - t) **2 * rad / 40 -drawSpark :: Particle -> Picture -drawSpark pt = setLayer BloomNoZWrite - . setDepth 20 - . color (_ptColor pt) - $ thickLine (_ptWidth pt) (take 2 $ _ptTrail pt) - drawTeslaArc :: Particle -> Picture drawTeslaArc pt = setLayer BloomNoZWrite $ pictures [ setDepth 20.5 $ color (brightX 2 1 $ _ptColor pt) $ thickLine 3 ps diff --git a/src/Dodge/Particle/HitEffect/ExpireAndDamage.hs b/src/Dodge/Particle/HitEffect/ExpireAndDamage.hs index d4b908053..b7db21dd9 100644 --- a/src/Dodge/Particle/HitEffect/ExpireAndDamage.hs +++ b/src/Dodge/Particle/HitEffect/ExpireAndDamage.hs @@ -15,8 +15,7 @@ expireAndDamage :: (Particle -> Point2 -> [Damage]) -> (World, Maybe Particle) 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) - + Just x -> (doDamages fdm x bt w, destroyAt bt) doDamages :: (Particle -> Point2 -> [Damage]) -> (Point2, Either Creature Wall) diff --git a/src/Dodge/Particle/TeslaArc.hs b/src/Dodge/Particle/TeslaArc.hs index 035ca98d5..4a661b74b 100644 --- a/src/Dodge/Particle/TeslaArc.hs +++ b/src/Dodge/Particle/TeslaArc.hs @@ -28,8 +28,7 @@ moveTeslaArc thearc w pt where rcol = brightX 100 1.5 <$> takeOne [white,azure,blue,cyan] rdir = state (randomR (-0.7,0.7)) <&> (+ ld) - rtime = state $ randomR (5,8) - makeaspark = randColDirTimeSpark rcol rdir rtime lp + makeaspark = randColDirTimeSpark rcol rdir lp makesparks = makeaspark . makeaspark . makeaspark (lp,ld) = case last thearc of ArcStep lp' ld' Nothing -> (lp',ld') diff --git a/src/Dodge/Particle/Update.hs b/src/Dodge/Particle/Update.hs index 82cfed97a..6ef388c80 100644 --- a/src/Dodge/Particle/Update.hs +++ b/src/Dodge/Particle/Update.hs @@ -1,19 +1,14 @@ module Dodge.Particle.Update where import Dodge.Data import LensHelp -import Geometry mvPt' :: Particle -> Maybe Particle mvPt' pt = Just $ pt - & ptTrail %~ f & ptTimer -~ 1 - where - f trl = head trl +.+ _ptVel pt : trl -destroyAt :: Point2 -> Particle -> Maybe Particle -destroyAt hitp pt = Just $ pt +destroyAt :: Particle -> Maybe Particle +destroyAt pt = Just $ pt & ptUpdate .~ killParticleUpdate - & ptTrail .:~ hitp & ptTimer %~ (min 3 . subtract 1) killParticleUpdate :: World -> Particle -> (World,Maybe Particle) @@ -21,5 +16,4 @@ killParticleUpdate w pt | _ptTimer pt <= 0 = (w,Nothing) | otherwise = (w , Just $ pt & ptTimer -~ 1 - & ptTrail %~ (\(x:xs) -> x:x:xs) ) diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 833e30195..50a4f7352 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -6,6 +6,7 @@ import Dodge.Creature.Picture.Awareness import Dodge.Creature.Picture import Dodge.Particle.Draw import Dodge.Bullet.Draw +import Dodge.Spark.Draw import Dodge.RadarBlip import Dodge.Flare import Dodge.ShortShow @@ -85,6 +86,7 @@ cullPoint cfig w p extraPics :: Configuration -> World -> Picture extraPics cfig w = pictures (_decorations w) <> concatMapPic drawParticle (_particles w) + <> concatMapPic drawSpark (_sparks w) <> concatMapPic drawBul (_bullets w) <> concatMapPic drawBlip (_radarBlips w) <> concatMapPic drawFlare (_flares w) diff --git a/src/Dodge/Spark.hs b/src/Dodge/Spark.hs index 7d740fac2..add131bcf 100644 --- a/src/Dodge/Spark.hs +++ b/src/Dodge/Spark.hs @@ -1,5 +1,5 @@ module Dodge.Spark - ( mvSpark + ( moveSpark , colSpark , colSparkRandDir , createBarrelSpark @@ -9,86 +9,79 @@ import Dodge.Data import Dodge.WorldEvent.ThingsHit import Geometry import LensHelp -import Dodge.Particle.HitEffect.ExpireAndDamage -import Dodge.Particle.Damage import Color import Control.Monad.State import System.Random -import Data.Bifunctor - -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 +moveSpark :: World -> Spark -> (World, Maybe Spark) +moveSpark w sk + | magV (_skVel sk) < 1 = (w,Nothing) + | otherwise = case thingHit sp ep w of + Nothing -> (w, Just $ sk & skPos .~ ep & skVel .*.*~ 0.9 & skOldPos .~ sp) + Just (hp,hthing) -> (sparkDam sp ep (hp,hthing) w, Just $ sk & skPos .~ hp & skOldPos .~ sp & skVel .~ 0) where - bt = bt' - dodrag = ptVel .*.*~ drag - drag = _ptDrag bt - (p:_) = _ptTrail bt - vel = _ptVel bt - hiteff = _ptHitEff bt - t = _ptTimer bt + sp = _skPos sk + ep = sp +.+ _skVel sk + +sparkDam + :: Point2 + -> Point2 + -> (Point2, Either Creature Wall) + -> World + -> World +sparkDam sp ep mayEiCrWl = case mayEiCrWl of + (hitp,Left cr) -> creatures . ix (_crID cr) . crState . csDamage .:~ thedam hitp + (hitp,Right wl) -> wallDamages . ix (_wlID wl) .:~ thedam hitp + where + thedam hitp = Damage SPARKING 1 sp hitp ep NoDamageEffect --import Control.Lens -- TODO remove/simplify this function -createBarrelSpark :: Point2 -> Float -> Int -> Int -> World -> World -createBarrelSpark pos dir time colid = instantParticles .:~ PtSpark - { _ptUpdate = mvSpark - , _ptVel = rotateV dir (V2 5 0) - , _ptDrag = 0.9 - , _ptColor = numColor colid - , _ptTrail = [pos] - , _ptWidth = 1 - , _ptTimer = time - , _ptHitEff = expireAndDamage basicSparkDams +createBarrelSpark :: Point2 -> Float -> Int -> World -> World +createBarrelSpark pos dir colid = sparks .:~ Spark + { _skVel = rotateV dir (V2 5 0) + , _skColor = numColor colid + , _skPos = pos + , _skOldPos = pos + , _skWidth = 1 } -colSpark :: Int -> Color -> Point2 -> Float -> World -> World +colSpark :: Color -> Point2 -> Float -> World -> World colSpark = colSparkRandDir 0.7 randColDirTimeSpark :: State StdGen Color -> State StdGen Float - -> State StdGen Int -> Point2 -> World -> World -randColDirTimeSpark randcol randdir randtime pos w = w - & instantParticles .:~ spark +randColDirTimeSpark randcol randdir pos w = w + & sparks .:~ spark & randGen .~ g where - ((col,dir,time),g) = (`runState` _randGen w) $ do + ((col,dir),g) = (`runState` _randGen w) $ do c <- randcol d <- randdir - t <- randtime - return (c,d,t) - spark = PtSpark - { _ptUpdate = mvSpark - , _ptDrag = 0.9 - , _ptVel = rotateV dir (V2 5 0) - , _ptColor = col - , _ptTrail = [pos] - , _ptWidth = 1 - , _ptTimer = time - , _ptHitEff = expireAndDamage basicSparkDams + return (c,d) + spark = Spark + { _skVel = rotateV dir (V2 5 0) + , _skColor = col + , _skPos = pos + , _skOldPos = pos + , _skWidth = 1 } -colSparkRandDir :: Float -> Int -> Color -> Point2 -> Float -> World -> World -colSparkRandDir randDir time col pos baseDir w = w - & instantParticles .:~ spark +colSparkRandDir :: Float -> Color -> Point2 -> Float -> World -> World +colSparkRandDir randDir col pos baseDir w = w + & sparks .:~ spark & randGen .~ g where (a,g) = randomR (-randDir,randDir) $ _randGen w dir = a + baseDir - spark = PtSpark - { _ptUpdate = mvSpark - , _ptDrag = 0.9 - , _ptVel = rotateV dir (V2 5 0) - , _ptColor = col - , _ptTrail = [pos] - , _ptWidth = 1 - , _ptTimer = time - , _ptHitEff = expireAndDamage basicSparkDams + spark = Spark + { _skVel = rotateV dir (V2 5 0) + , _skColor = col + , _skPos = pos + , _skOldPos = pos + , _skWidth = 1 } diff --git a/src/Dodge/Spark/Draw.hs b/src/Dodge/Spark/Draw.hs new file mode 100644 index 000000000..f34b43aaf --- /dev/null +++ b/src/Dodge/Spark/Draw.hs @@ -0,0 +1,9 @@ +module Dodge.Spark.Draw where +import Dodge.Data +import Picture + +drawSpark :: Spark -> Picture +drawSpark pt = setLayer BloomNoZWrite + . setDepth 20 + . color (_skColor pt) + $ thickLine (_skWidth pt) [_skOldPos pt, _skPos pt] diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 6a4996245..355634765 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -5,6 +5,7 @@ Description : Simulation update -} module Dodge.Update ( updateUniverse ) where import Dodge.Data +import Dodge.Spark import Dodge.Bullet import Dodge.Update.Cloud import Dodge.Machine.Update @@ -81,6 +82,7 @@ functionalUpdate cfig w = checkEndGame . resetWorldEvents . dbArg _worldEvents . updateIMl _modifications _mdUpdate + . updateSparks . updateParticles . updateBullets . updateRadarBlips @@ -220,6 +222,11 @@ updateBullets w = updateInstantBullets $ set bullets (catMaybes ps) w' where (w',ps) = mapAccumR updateBullet w $ _bullets w +updateSparks :: World -> World +updateSparks w = w' & sparks .~ catMaybes newsparks + where + (w',newsparks) = mapAccumR (\a b -> moveSpark a b) w $ _sparks w + {- Apply internal particle updates, delete 'Nothing's. -} updateParticles :: World -> World updateParticles w = updateInstantParticles $ set particles (catMaybes ps) w' diff --git a/src/Dodge/Wall/DamageEffect.hs b/src/Dodge/Wall/DamageEffect.hs index 46f8369f9..a5c85cbc2 100644 --- a/src/Dodge/Wall/DamageEffect.hs +++ b/src/Dodge/Wall/DamageEffect.hs @@ -20,8 +20,8 @@ defaultWallDamage dm wl = case _wlMaterial wl of stoneWallDamage :: Damage -> Wall -> World -> (World,Int) stoneWallDamage dm wl = case _dmType dm of - LASERING -> a 0 $ colSparkRandDir 0.2 4 lSparkCol outTo (reflDirWall sp p wl) - PIERCING -> a d $ colSparkRandDir 0.2 8 pSparkCol outTo (reflDirWall sp p wl) . wlDustAt wl outTo + LASERING -> a 0 $ colSparkRandDir 0.2 lSparkCol outTo (reflDirWall sp p wl) + PIERCING -> a d $ colSparkRandDir 0.2 pSparkCol outTo (reflDirWall sp p wl) . wlDustAt wl outTo BLUNT -> a d $ wlDustAt wl outTo SHATTERING -> a d $ muchWlDustAt wl outTo CRUSHING -> a d id @@ -46,8 +46,8 @@ stoneWallDamage dm wl = case _dmType dm of windowWallDamage :: Damage -> Wall -> World -> (World,Int) windowWallDamage dm wl w = w & case _dmType dm of - LASERING -> a 0 $ colSparkRandDir 0.2 4 lSparkCol outTo (reflDirWall sp p wl) - PIERCING -> a d $ dosplint . colSparkRandDir 0.2 8 pSparkCol outTo (reflDirWall sp p wl) . wlDustAt wl outTo + LASERING -> a 0 $ colSparkRandDir 0.2 lSparkCol outTo (reflDirWall sp p wl) + PIERCING -> a d $ dosplint . colSparkRandDir 0.2 pSparkCol outTo (reflDirWall sp p wl) . wlDustAt wl outTo BLUNT -> a d $ dosplint . wlDustAt wl outTo SHATTERING -> a d $ dosplint . muchWlDustAt wl outTo CRUSHING -> a d dosplint @@ -78,8 +78,8 @@ windowWallDamage dm wl w = w & case _dmType dm of crystalWallDamage :: Damage -> Wall -> World -> (World,Int) crystalWallDamage dm wl = case _dmType dm of - LASERING -> a 0 $ colSparkRandDir 0.2 4 lSparkCol outTo (reflDirWall sp p wl) - PIERCING -> a 0 $ colSparkRandDir 0.2 8 pSparkCol outTo (reflDirWall sp p wl) . wlDustAt wl outTo + LASERING -> a 0 $ colSparkRandDir 0.2 lSparkCol outTo (reflDirWall sp p wl) + PIERCING -> a 0 $ colSparkRandDir 0.2 pSparkCol outTo (reflDirWall sp p wl) . wlDustAt wl outTo BLUNT -> a 0 $ wlDustAt wl outTo SHATTERING -> a d $ muchWlDustAt wl outTo CRUSHING -> a 0 id