From 54ba0fbedc21f5627751362debf94517b714c31b Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 18 Jul 2022 22:41:40 +0100 Subject: [PATCH] Move flame into its own datatype --- src/Dodge/Beam.hs | 93 ++------------ src/Dodge/Bullet.hs | 2 +- src/Dodge/Data.hs | 33 ++--- src/Dodge/Data/Bullet.hs | 2 +- src/Dodge/Data/{DamageType.hs => Damage.hs} | 23 +--- src/Dodge/Data/Damage/Type.hs | 19 +++ src/Dodge/Data/Flame.hs | 16 +++ src/Dodge/Data/Magnet.hs | 14 +++ src/Dodge/Data/Sensor.hs | 2 +- src/Dodge/Data/SoundOrigin.hs | 2 +- src/Dodge/Data/Spark.hs | 2 + src/Dodge/Default/World.hs | 1 + src/Dodge/Flame.hs | 127 ++++++++++++++++++++ src/Dodge/Flame/Draw.hs | 35 ++++++ src/Dodge/Item/Weapon/BatteryGuns.hs | 5 - src/Dodge/Item/Weapon/SprayGuns.hs | 7 +- src/Dodge/Particle/Draw.hs | 31 ----- src/Dodge/Particle/Flame.hs | 14 --- src/Dodge/Particle/TeslaArc.hs | 42 ------- src/Dodge/Render/ShapePicture.hs | 2 + src/Dodge/Spark.hs | 29 ++--- src/Dodge/Tesla.hs | 19 ++- src/Dodge/Tesla/Arc.hs | 118 ++++++++++++++++++ src/Dodge/Tesla/Arc/Default.hs | 35 ++++++ src/Dodge/Tesla/Ball.hs | 6 + src/Dodge/Tesla/ItemParams.hs | 12 ++ src/Dodge/Update.hs | 9 +- src/Dodge/WorldEvent/Explosion.hs | 5 +- src/Dodge/WorldEvent/SpawnParticle.hs | 57 --------- 29 files changed, 444 insertions(+), 318 deletions(-) rename src/Dodge/Data/{DamageType.hs => Damage.hs} (74%) create mode 100644 src/Dodge/Data/Damage/Type.hs create mode 100644 src/Dodge/Data/Flame.hs create mode 100644 src/Dodge/Data/Magnet.hs create mode 100644 src/Dodge/Flame.hs create mode 100644 src/Dodge/Flame/Draw.hs delete mode 100644 src/Dodge/Particle/Flame.hs delete mode 100644 src/Dodge/Particle/TeslaArc.hs create mode 100644 src/Dodge/Tesla/Arc.hs create mode 100644 src/Dodge/Tesla/Arc/Default.hs create mode 100644 src/Dodge/Tesla/Ball.hs create mode 100644 src/Dodge/Tesla/ItemParams.hs diff --git a/src/Dodge/Beam.hs b/src/Dodge/Beam.hs index c7a1e280b..832794ed5 100644 --- a/src/Dodge/Beam.hs +++ b/src/Dodge/Beam.hs @@ -1,22 +1,21 @@ module Dodge.Beam where import Dodge.Data -import Dodge.Particle.Flame -import Dodge.Particle.TeslaArc +import Dodge.Flame +import Dodge.Tesla.Arc import Dodge.Item.Location import Dodge.WorldEvent.Damage ---import Dodge.WorldEvent.ThingsHit import Dodge.WorldEvent.HelperParticle import Dodge.Item.Weapon.LaserPath import Geometry import LensHelp import Picture -import RandomHelp +--import RandomHelp --import Dodge.Zone -import Dodge.Base.Collide -import Shape +--import Dodge.Base.Collide +--import Shape -import Data.List (sortOn) -import MonadHelp +--import Data.List (sortOn) +--import MonadHelp import Data.Maybe import qualified Data.IntMap.Strict as IM @@ -81,81 +80,3 @@ drawLaser pt = where col = _ptColor pt ps = _ptPoints pt - -shootTeslaArc' :: ItemParams -> Point2 -> Float -> World -> (World,ItemParams) -shootTeslaArc' ip pos dir w = - (w & randGen .~ g - & instantParticles .:~ aTeslaArcAt col newarc - , ip & currentArc ?~ newarc - ) - where - (col,g) = takeOne [white,azure,blue,cyan] & runState $ _randGen w - newarc = createArc ip w pos dir & evalState $ _randGen w - -createArc :: ItemParams - -> World - -> Point2 - -> Float - -> State StdGen [ArcStep] -createArc arcparams@Arcing{_currentArc = Nothing} w p dir = createNewArc arcparams w p dir -createArc arcparams w p dir = updateArc arcparams w p dir - -createNewArc :: ItemParams -> World -> Point2 -> Float - -> State StdGen [ArcStep] -createNewArc arcparams w p dir = take (_arcNumber arcparams) - <$> unfoldrMID (_newArcStep arcparams arcparams w) (ArcStep p dir Nothing) - -defaultArcStep :: RandomGen g => ItemParams -> World -> ArcStep - -> State g (Maybe ArcStep) -defaultArcStep _ _ (ArcStep _ _ (Just _)) = return Nothing -defaultArcStep itparams w (ArcStep p dir _) = do - let csize = _arcSize itparams - --rot <- takeOne [pi/4,negate pi/4] - rot <- takeOne [0] - let center = csize *.* rotateV rot (unitVectorAtAngle dir) +.+ p - newp <- (center +.+) <$> randInCirc csize - let mcr = listToMaybe - . sortOn (dist center . _crPos) - . filter (\cr -> dist center (_crPos cr) < csize) - . IM.elems - $ _creatures w - mwl = listToMaybe - . sortOn (dist p . fst) - . mapMaybe (\ q -> sequence $ collidePointWallsFilterStream (const True) p (center +.+ q) w) - -- collidePointWallsWall and wlsnearpoint - $ polyCirc 6 csize - f (q,wl) = ArcStep q dir (Just $ Right wl) - g cr = ArcStep (_crPos cr +.+ csize *.* unitVectorAtAngle dir) dir (Just $ Left cr) - return . listToMaybe . sortOn (dist p . (^. asPos)) - $ ArcStep newp dir Nothing : catMaybes [fmap f mwl,fmap g mcr] - -updateArc :: ItemParams - -> World - -> Point2 - -> Float - -> State StdGen [ArcStep] -updateArc ip w p dir = take (_arcNumber ip) <$> zipArcs ip w (ArcStep p dir Nothing) carc - where - carc = tail $ fromJust $ _currentArc ip - -zipArcs :: ItemParams - -> World - -> ArcStep - -> [ArcStep] - -> State StdGen [ArcStep] -zipArcs ip w x (y:ys) = (x :) <$> do - defaultnext <- _newArcStep ip ip w x - case defaultnext of - Nothing -> return [] - Just z@(ArcStep _ _ (Just _)) -> return [z] - Just z -> do - p <- randInCirc 5 - let csize = _arcSize ip - center = _asPos x +.+ csize *.* unitVectorAtAngle (_asDir x) - newp = _asPos y +.+ p - --newdir = argV $ newp -.- _asPos x - newdir = _asDir x - if dist newp center < csize - then zipArcs ip w (y & asPos .~ newp & asDir .~ newdir) ys - else zipArcs ip w z ys -zipArcs ip w y _ = createNewArc ip w (_asPos y) (_asDir y) diff --git a/src/Dodge/Bullet.hs b/src/Dodge/Bullet.hs index 7fd162315..e9727802a 100644 --- a/src/Dodge/Bullet.hs +++ b/src/Dodge/Bullet.hs @@ -75,7 +75,7 @@ mvBullet x w bt' & buTimer -~ 1 ) hitstream = thingsHit p (p +.+ vel) w - bt = (foldr (\mg b -> _mgField mg mg b) bt' $ _magnets w) + bt = foldr (\mg b -> _mgField mg mg b) bt' (_magnets w) & buState .~ NormalBulletState dodrag = case _buTrajectory bt of BasicBulletTrajectory -> buVel .*.*~ drag diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index d136b3239..0a7166e76 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -10,6 +10,8 @@ circular imports are probably not a good idea. {-# LANGUAGE DerivingStrategies #-} module Dodge.Data ( module Dodge.Data + , module Dodge.Data.Flame + , module Dodge.Data.Magnet , module Dodge.Data.Spark , module Dodge.Data.Bullet , module Dodge.Data.Door @@ -31,7 +33,7 @@ module Dodge.Data , module Dodge.Data.Sensor , module Dodge.Combine.Data , module Dodge.Distortion.Data - , module Dodge.Data.DamageType + , module Dodge.Data.Damage , module Dodge.Data.SoundOrigin , module Dodge.Creature.State.Data , module Dodge.Creature.Stance.Data @@ -48,6 +50,8 @@ module Dodge.Data , module Dodge.Data.RadarBlip , module Dodge.Data.PathGraph ) where +import Dodge.Data.Flame +import Dodge.Data.Magnet import Dodge.Data.Spark import Dodge.Data.Bullet import Dodge.Data.Door @@ -80,7 +84,7 @@ import Dodge.Creature.Memory.Data import Dodge.Distortion.Data import Dodge.Equipment.Data import Dodge.Data.SoundOrigin -import Dodge.Data.DamageType +import Dodge.Data.Damage import Dodge.Combine.Data import Dodge.Config.Data import Dodge.Config.KeyConfig @@ -149,6 +153,7 @@ data World = World , _bullets :: [Bullet] , _instantParticles :: [Particle] , _particles :: [Particle] + , _flames :: [Flame] , _sparks :: [Spark] , _radarBlips :: [RadarBlip] , _flares :: [Flare] @@ -232,13 +237,6 @@ data TimeFlowStatus data SaveSlot = QuicksaveSlot | LevelStartSlot deriving (Eq,Ord) -data Magnet = Magnet - { _mgID :: Int - , _mgUpdate :: Magnet -> Maybe Magnet - , _mgPos :: Point2 - , _mgField :: Magnet -> Bullet -> Bullet - } - data OptionScreenFlag = NormalOptions | GameOverOptions data ScreenLayer = OptionScreen @@ -558,17 +556,6 @@ data Particle , _ptPoints :: [Point2] , _ptColor :: Color } - | PtFlame - { _ptUpdate :: World -> Particle -> (World, Maybe Particle) - , _ptVel :: Point2 - , _ptColor :: Color - , _ptPos :: Point2 - , _ptWidth :: Float - , _ptTimer :: Int - , _ptHitEff :: HitEffect - , _ptZ :: Float - , _ptOriginalVel :: Point2 - } | PtIncBall { _ptUpdate :: World -> Particle -> (World, Maybe Particle) , _ptVel :: Point2 @@ -621,6 +608,10 @@ type HitEffect = Particle -> Stream (Of (Point2, Either Creature Wall)) Identity () -> World -> (World,Maybe Particle) +type HitEffect' = Flame + -> Stream (Of (Point2, Either Creature Wall)) Identity () + -> World + -> (World,Maybe Flame) data AmmoType = ProjectileAmmo @@ -1355,7 +1346,6 @@ makeLenses ''MachineType makeLenses ''Universe makeLenses ''ItemParams makeLenses ''ItemTweaks -makeLenses ''Magnet makeLenses ''Gust makeLenses ''GunBarrels makeLenses ''Targeting @@ -1381,5 +1371,6 @@ makeLenses ''PSType makeLenses ''PlacementSpot makeLenses ''Placement + crSel :: Creature -> Int crSel = _iselPos . _crInvSel diff --git a/src/Dodge/Data/Bullet.hs b/src/Dodge/Data/Bullet.hs index fa7a4f961..4672e0682 100644 --- a/src/Dodge/Data/Bullet.hs +++ b/src/Dodge/Data/Bullet.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} module Dodge.Data.Bullet where -import Dodge.Data.DamageType +import Dodge.Data.Damage import Geometry.Data import Control.Lens data Bullet = Bullet diff --git a/src/Dodge/Data/DamageType.hs b/src/Dodge/Data/Damage.hs similarity index 74% rename from src/Dodge/Data/DamageType.hs rename to src/Dodge/Data/Damage.hs index 87e44b394..47be2bf54 100644 --- a/src/Dodge/Data/DamageType.hs +++ b/src/Dodge/Data/Damage.hs @@ -4,26 +4,13 @@ Datatypes describing the type of damage effects that are to be applied to creatures. -} -module Dodge.Data.DamageType where +module Dodge.Data.Damage + ( module Dodge.Data.Damage + , module Dodge.Data.Damage.Type + ) where +import Dodge.Data.Damage.Type import Geometry.Data import Control.Lens -data DamageType - = PIERCING - | BLUNT - | CUTTING - | SPARKING - | CRUSHING - | SHATTERING - | FLAMING - | LASERING - | ELECTRICAL - | EXPLOSIVE - | CONCUSSIVE - | TORQUEDAM - | PUSHDAM - | POISONDAM - | ENTERREMENT - deriving (Eq,Ord,Show,Read) data DamageEffect = PushDamage { _dePush :: Float diff --git a/src/Dodge/Data/Damage/Type.hs b/src/Dodge/Data/Damage/Type.hs new file mode 100644 index 000000000..92938f42b --- /dev/null +++ b/src/Dodge/Data/Damage/Type.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE StrictData #-} +module Dodge.Data.Damage.Type where +data DamageType + = PIERCING + | BLUNT + | CUTTING + | SPARKING + | CRUSHING + | SHATTERING + | FLAMING + | LASERING + | ELECTRICAL + | EXPLOSIVE + | CONCUSSIVE + | TORQUEDAM + | PUSHDAM + | POISONDAM + | ENTERREMENT + deriving (Eq,Ord,Show,Read,Enum,Bounded) diff --git a/src/Dodge/Data/Flame.hs b/src/Dodge/Data/Flame.hs new file mode 100644 index 000000000..2eecc842e --- /dev/null +++ b/src/Dodge/Data/Flame.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StrictData #-} +module Dodge.Data.Flame where +import Control.Lens +import Geometry.Data +import Color +data Flame = Flame + { _flVel :: Point2 + , _flColor :: Color + , _flPos :: Point2 + , _flWidth :: Float + , _flTimer :: Int + , _flZ :: Float + , _flOriginalVel :: Point2 + } +makeLenses ''Flame diff --git a/src/Dodge/Data/Magnet.hs b/src/Dodge/Data/Magnet.hs new file mode 100644 index 000000000..79bcc2352 --- /dev/null +++ b/src/Dodge/Data/Magnet.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StrictData #-} +module Dodge.Data.Magnet where +import Dodge.Data.Bullet +import Geometry.Data +import Control.Lens + +data Magnet = Magnet + { _mgID :: Int + , _mgUpdate :: Magnet -> Maybe Magnet + , _mgPos :: Point2 + , _mgField :: Magnet -> Bullet -> Bullet + } +makeLenses ''Magnet diff --git a/src/Dodge/Data/Sensor.hs b/src/Dodge/Data/Sensor.hs index f7d95643b..0449e6413 100644 --- a/src/Dodge/Data/Sensor.hs +++ b/src/Dodge/Data/Sensor.hs @@ -2,7 +2,7 @@ {-# LANGUAGE StrictData #-} module Dodge.Data.Sensor where import Dodge.Combine.Data -import Dodge.Data.DamageType +import Dodge.Data.Damage.Type import Control.Lens data Sensor = NoSensor diff --git a/src/Dodge/Data/SoundOrigin.hs b/src/Dodge/Data/SoundOrigin.hs index 45b363f0b..8612d643c 100644 --- a/src/Dodge/Data/SoundOrigin.hs +++ b/src/Dodge/Data/SoundOrigin.hs @@ -14,7 +14,7 @@ data SoundOrigin = InventorySound | CrReloadSound Int | Flamer | ShellSound Int - | Flame + | FlameSound | LasSound | FootstepSound Int | BlockDegradeSound Int diff --git a/src/Dodge/Data/Spark.hs b/src/Dodge/Data/Spark.hs index 851aa8816..b910f191c 100644 --- a/src/Dodge/Data/Spark.hs +++ b/src/Dodge/Data/Spark.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} module Dodge.Data.Spark where +import Dodge.Data.Damage.Type import Geometry.Data import Color import Control.Lens @@ -10,5 +11,6 @@ data Spark = Spark , _skPos :: Point2 , _skOldPos :: Point2 , _skWidth :: Float + , _skDamageType :: DamageType } makeLenses ''Spark diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index 5587a779f..30b020c71 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -43,6 +43,7 @@ defaultWorld = World , _bullets = [] , _instantParticles = [] , _particles = [] + , _flames = [] , _sparks = [] , _radarBlips = [] , _flares = [] diff --git a/src/Dodge/Flame.hs b/src/Dodge/Flame.hs new file mode 100644 index 000000000..d30559cd3 --- /dev/null +++ b/src/Dodge/Flame.hs @@ -0,0 +1,127 @@ +module Dodge.Flame + ( aFlameParticle + , makeFlame + , moveFlame + ) where +import Dodge.Data +import Dodge.LightSource +import Dodge.Zone +import Dodge.WorldEvent.ThingsHit +import Dodge.WorldEvent.Cloud +import Dodge.SoundLogic +import RandomHelp +import Picture +import Geometry +import qualified IntMapHelp as IM +import LensHelp +import StreamingHelp + +import Data.Foldable +import Data.Tuple +import qualified Streaming.Prelude as S + +aFlameParticle + :: Int -- ^ Timer + -> Point2 -- ^ Position + -> Point2 -- ^ Velocity + -> Flame +aFlameParticle t pos vel = Flame + { _flVel = vel + , _flColor = red + , _flPos = pos + , _flWidth = 4 + , _flTimer = t + , _flZ = 20 + , _flOriginalVel = vel + } +simpleDamFL :: DamageType -> Int -> Flame -> Point2 -> [Damage] +simpleDamFL dt amount bt p = [ Damage dt amount sp p ep NoDamageEffect ] + where + sp = _flPos bt + bulVel = _flVel bt + ep = sp +.+ bulVel +expireAndDamageFL :: (Flame -> Point2 -> [Damage]) + -> Flame + -> Stream (Of (Point2, Either Creature Wall)) Identity () + -> World + -> (World, Maybe Flame) +expireAndDamageFL fdm bt things w = case runIdentity $ S.head_ things of + Nothing -> (w, mvFlame bt) + Just x -> (doDamagesFL fdm x bt w, Nothing) +doDamagesFL :: (Flame -> Point2 -> [Damage]) + -> (Point2, Either Creature Wall) + -> Flame + -> World + -> World +doDamagesFL 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 + +{- TODO: add generalised area damage particles/hiteffects. -} +moveFlame :: World + -> Flame + -> (World, Maybe Flame) +moveFlame w pt + | time <= 0 = (makeFlamerSmokeAt (addZ 20 ep) w, Nothing) + | otherwise = case runIdentity . S.head_ $ thingsHit sp ep w of + Just (_,Left _) -> (doSound $ dodamage w , mvPt' 0.7) + Just (p,Right wl) -> (doSound $ dodamage w , rfl wl p) + _ -> (flFlicker pt $ doSound $ dodamage w , mvPt' 0.98) + where + rotd = _flOriginalVel pt + time = _flTimer pt + doSound = soundContinue FlameSound (V2 x y) fireLoudS (Just 2) + sp@(V2 x y) = _flPos pt + vel = _flVel pt + ep = sp +.+ vel + mvPt' drag = Just $ pt + & flTimer -~ 1 + & flPos .~ ep + & flVel %~ (drag *.*) + dodamage = flDamageInArea closeCrs closeWls pt + closeWls wl = uncurry segOnCirc (_wlLine wl) ep 5 + closeCrs cr = dist ep (_crPos cr) + < _crRad cr + 10 - min 9 (max 0 (fromIntegral time - 80)) + + 5 * angleCoeff (angleVV (ep -.- _crPos cr) rotd) + angleCoeff x' = abs $ 1 - abs ( (x' * 2 - pi) / pi ) + rfl wl p = Just $ pt + { _flTimer = time - 1 + , _flPos = pOut p + , _flVel = reflV wl + } + pOut p = p +.+ squashNormalizeV (sp -.- p) + reflV wall = (0.3 *.* reflectIn (uncurry (-.-) . swap $ _wlLine wall) vel ) + +.+ (0.2 *.* vel) + +flDamageInArea :: (Creature -> Bool) -> (Wall -> Bool) -> Flame -> World -> World +{-# INLINE flDamageInArea #-} +flDamageInArea crt wlt pt w = damwls damcrs + where + p = _flPos pt + damcrs = foldl' (flip $ \cr -> fst . hiteff (S.yield (p,Left cr))) w $ IM.filter crt $ _creatures w + damwls w' = runIdentity + . S.fold_ + (flip $ \wl -> fst . hiteff (S.yield (p,Right wl))) + w' + id + . S.filter wlt + $ wlsNearPoint p w' + hiteff = expireAndDamageFL (simpleDamFL FLAMING 1) pt + +mvFlame :: Flame -> Maybe Flame +mvFlame pt = Just $ pt + & flTimer -~ 1 + +flFlicker :: Flame -> World -> World +flFlicker pt + | _flTimer pt `mod` 7 == 0 = tempLightSources + .:~ tlsTimeRadColPos 1 70 (0.5 *.*.* xyzV4 (_flColor pt)) (addZ 10 $ _flPos pt) + | otherwise = id +makeFlame :: Point2 -> Point2 -> World -> World +makeFlame pos vel w = w + & flames .:~ aFlameParticle t pos vel + & randGen .~ g + where + (t,g) = randomR (99,101) (_randGen w) diff --git a/src/Dodge/Flame/Draw.hs b/src/Dodge/Flame/Draw.hs new file mode 100644 index 000000000..cdb4f533d --- /dev/null +++ b/src/Dodge/Flame/Draw.hs @@ -0,0 +1,35 @@ +module Dodge.Flame.Draw where +import Dodge.Data +import Geometry +import Picture + +drawFlame + :: Flame + -> Picture +drawFlame pt = pictures + [ glow + , aPic BloomNoZWrite prot2 25 (V2 (scaleChange + 1) 2 ) $ V4 2 (-1) (-1) 0.5 + , aPic BloomNoZWrite prot 22 (V2 (scaleChange + 0.5) 1 ) $ V4 1 0.5 0 2 + , aPic BloomLayer prot3 20 (V2 scaleChange 0.5) $ V4 1 1 1 1 + ] + where + rotd = _flOriginalVel pt -- rotate direction + ep = _flPos pt + aPic :: Layer -> (Point2 -> Point2) -> Float -> Point2 -> Color -> Picture + aPic lay offset depth (V2 scalex scaley) col + = setLayer lay + . setDepth depth + . uncurryV translate (offset ep) + . rotate (pi * 0.5 + argV rotd) + . scale scalex scaley + . color col + $ circleSolid 5 + glow = setLayer BloomNoZWrite $ setDepth 0.3 $ uncurryV translate ep + $ circleSolidCol (withAlpha 0 orange) (withAlpha 0.02 orange) 50 + time = _flTimer pt + scaleChange + | time < 80 = 3 + | otherwise = 3 - (fromIntegral time - 80) * 0.2 + prot p' = p' +.+ rotateV (fromIntegral time) (V2 0 1) + prot2 p' = p' +.+ rotateV (negate $ fromIntegral time) (V2 0 1) + prot3 p' = p' +.+ rotateV (2 + fromIntegral time * 0.1) (V2 0 2) diff --git a/src/Dodge/Item/Weapon/BatteryGuns.hs b/src/Dodge/Item/Weapon/BatteryGuns.hs index 2f8b811b4..e34355b01 100644 --- a/src/Dodge/Item/Weapon/BatteryGuns.hs +++ b/src/Dodge/Item/Weapon/BatteryGuns.hs @@ -3,11 +3,6 @@ module Dodge.Item.Weapon.BatteryGuns , lasCircle , dualBeam , lasWide --- , lasWidePulse - --, lasSway --- , lasSwing - --, lasFocus --- , lasPulse , sparkGun , teslaGun , teslaParams diff --git a/src/Dodge/Item/Weapon/SprayGuns.hs b/src/Dodge/Item/Weapon/SprayGuns.hs index 82f40b686..60b1c4593 100644 --- a/src/Dodge/Item/Weapon/SprayGuns.hs +++ b/src/Dodge/Item/Weapon/SprayGuns.hs @@ -8,12 +8,7 @@ module Dodge.Item.Weapon.SprayGuns ) where import Dodge.Data import Dodge.Reloading.Action -import Dodge.Particle.Flame ---import Dodge.Data.SoundOrigin ---import Dodge.Base ---import Dodge.Zone ---import Dodge.Picture.Layer ---import Dodge.SoundLogic +import Dodge.Flame import Dodge.SoundLogic.LoadSound --import Dodge.Creature.Action import Dodge.WorldEvent diff --git a/src/Dodge/Particle/Draw.hs b/src/Dodge/Particle/Draw.hs index 4b661af29..d88d3ff23 100644 --- a/src/Dodge/Particle/Draw.hs +++ b/src/Dodge/Particle/Draw.hs @@ -5,7 +5,6 @@ import Picture drawParticle :: Particle -> Picture drawParticle pt = case pt of - PtFlame {} -> drawFlame pt Shockwave {} -> drawShockwave pt PtStaticBall {} -> drawStaticBall pt PtIncBall {} -> drawFlameletZ pt @@ -16,36 +15,6 @@ drawParticle pt = case pt of ShockLine {} -> drawSonicWave pt RadarCircleParticle {} -> drawPulse pt -drawFlame - :: Particle - -> Picture -drawFlame pt = pictures - [ glow - , aPic BloomNoZWrite prot2 25 (V2 (scaleChange + 1) 2 ) $ V4 2 (-1) (-1) 0.5 - , aPic BloomNoZWrite prot 22 (V2 (scaleChange + 0.5) 1 ) $ V4 1 0.5 0 2 - , aPic BloomLayer prot3 20 (V2 scaleChange 0.5) $ V4 1 1 1 1 - ] - where - rotd = _ptOriginalVel pt -- rotate direction - ep = _ptPos pt - aPic :: Layer -> (Point2 -> Point2) -> Float -> Point2 -> Color -> Picture - aPic lay offset depth (V2 scalex scaley) col - = setLayer lay - . setDepth depth - . uncurryV translate (offset ep) - . rotate (pi * 0.5 + argV rotd) - . scale scalex scaley - . color col - $ circleSolid 5 - glow = setLayer BloomNoZWrite $ setDepth 0.3 $ uncurryV translate ep - $ circleSolidCol (withAlpha 0 orange) (withAlpha 0.02 orange) 50 - time = _ptTimer pt - scaleChange - | time < 80 = 3 - | otherwise = 3 - (fromIntegral time - 80) * 0.2 - prot p' = p' +.+ rotateV (fromIntegral time) (V2 0 1) - prot2 p' = p' +.+ rotateV (negate $ fromIntegral time) (V2 0 1) - prot3 p' = p' +.+ rotateV (2 + fromIntegral time * 0.1) (V2 0 2) drawShockwave :: Particle -> Picture drawShockwave pt = setDepth 20 diff --git a/src/Dodge/Particle/Flame.hs b/src/Dodge/Particle/Flame.hs deleted file mode 100644 index 09fe190dc..000000000 --- a/src/Dodge/Particle/Flame.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Dodge.Particle.Flame where -import Dodge.Data -import Dodge.WorldEvent -import Geometry -import LensHelp - -import System.Random - -makeFlame :: Point2 -> Point2 -> World -> World -makeFlame pos vel w = w - & instantParticles .:~ aFlameParticle t pos vel - & randGen .~ g - where - (t,g) = randomR (99,101) (_randGen w) diff --git a/src/Dodge/Particle/TeslaArc.hs b/src/Dodge/Particle/TeslaArc.hs deleted file mode 100644 index 64d4ee362..000000000 --- a/src/Dodge/Particle/TeslaArc.hs +++ /dev/null @@ -1,42 +0,0 @@ -module Dodge.Particle.TeslaArc - ( aTeslaArcAt - ) where -import Dodge.Data -import Dodge.Damage -import Dodge.Spark -import RandomHelp -import Picture -import Geometry -import LensHelp - -aTeslaArcAt :: Color -> [ArcStep] -> Particle -aTeslaArcAt col thearc = PtTeslaArc - { _ptPoints = map (^. asPos) thearc - , _ptUpdate = moveTeslaArc thearc - , _ptTimer = 2 - , _ptColor = brightX 100 1.5 col - } - -moveTeslaArc :: [ArcStep] - -> World - -> Particle - -> (World,Maybe Particle) -moveTeslaArc thearc w pt - | _ptTimer pt == 2 = (makesparks $ foldr damthings w thearc, Just $ pt & ptTimer -~ 1) - | _ptTimer pt < 1 = (w, Nothing) - | otherwise = (w, Just $ pt & ptTimer -~ 1) - where - rcol = brightX 100 1.5 <$> takeOne [white,azure,blue,cyan] - rdir = state (randomR (-0.7,0.7)) <&> (+ ld) - rspeed = state (randomR (3,6)) - makeaspark = randSpark rspeed rcol rdir lp - makesparks = makeaspark . makeaspark . makeaspark - (lp,ld) = case last thearc of - ArcStep lp' ld' Nothing -> (lp',ld') - ArcStep lp' ld' (Just (Left cr)) -> (lp' -.- (_crRad cr + 1) *.* unitVectorAtAngle ld',ld'+pi) - ArcStep lp' ld' (Just (Right _)) -> (lp' -.- 2 *.* unitVectorAtAngle ld',ld'+pi) - damthings (ArcStep _ _ Nothing) = id - damthings (ArcStep p dir (Just crwl)) = damageCrWall (thedamage p dir) crwl - thedamage p dir = Damage ELECTRICAL 50 (p -.- q) p (p +.+ q) NoDamageEffect - where - q = 5 *.* unitVectorAtAngle dir diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 50a4f7352..b092f9f25 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -5,6 +5,7 @@ import Dodge.Item.Draw.SPic import Dodge.Creature.Picture.Awareness import Dodge.Creature.Picture import Dodge.Particle.Draw +import Dodge.Flame.Draw import Dodge.Bullet.Draw import Dodge.Spark.Draw import Dodge.RadarBlip @@ -86,6 +87,7 @@ cullPoint cfig w p extraPics :: Configuration -> World -> Picture extraPics cfig w = pictures (_decorations w) <> concatMapPic drawParticle (_particles w) + <> concatMapPic drawFlame (_flames w) <> concatMapPic drawSpark (_sparks w) <> concatMapPic drawBul (_bullets w) <> concatMapPic drawBlip (_radarBlips w) diff --git a/src/Dodge/Spark.hs b/src/Dodge/Spark.hs index c64574910..7fe40dfa4 100644 --- a/src/Dodge/Spark.hs +++ b/src/Dodge/Spark.hs @@ -20,23 +20,24 @@ 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 (hp,hthing) -> (sparkDam sk sp ep (hp,hthing) w , Just $ sk & skPos .~ hp & skOldPos .~ sp & skVel .~ 0) where sp = _skPos sk ep = sp +.+ _skVel sk sparkDam - :: Point2 + :: Spark + -> Point2 -> Point2 -> (Point2, Either Creature Wall) -> World -> World -sparkDam sp ep mayEiCrWl = case mayEiCrWl of +sparkDam sk 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 + thedam hitp = Damage (_skDamageType sk) 1 sp hitp ep NoDamageEffect createBarrelSpark :: Point2 -> Float -> Int -> World -> World createBarrelSpark pos dir colid = colSparkRandDir 0.1 (numColor colid) pos dir @@ -64,16 +65,18 @@ randColDirSpark randcol randdir pos w = w , _skPos = pos , _skOldPos = pos , _skWidth = 1 + , _skDamageType = SPARKING } randSpark - :: State StdGen Float + :: DamageType + -> State StdGen Float -> State StdGen Color -> State StdGen Float -> Point2 -> World -> World -randSpark randspeed randcol randdir pos w = w +randSpark dt randspeed randcol randdir pos w = w & randGen .~ g & sparks .:~ Spark { _skVel = rotateV dir (V2 speed 0) @@ -81,6 +84,7 @@ randSpark randspeed randcol randdir pos w = w , _skPos = pos , _skOldPos = pos , _skWidth = 1 + , _skDamageType = dt } where ((col,dir,speed),g) = (`runState` _randGen w) $ do @@ -94,16 +98,3 @@ colSparkRandDir a col pos dir = randColDirSpark (return col) (state $ randomR (dir - a, dir + a)) pos --- w --- & sparks .:~ spark --- & randGen .~ g --- where --- (a,g) = randomR (-randDir,randDir) $ _randGen w --- dir = a + baseDir --- spark = Spark --- { _skVel = rotateV dir (V2 5 0) --- , _skColor = col --- , _skPos = pos --- , _skOldPos = pos --- , _skWidth = 1 --- } diff --git a/src/Dodge/Tesla.hs b/src/Dodge/Tesla.hs index 5387f96d7..c02114b07 100644 --- a/src/Dodge/Tesla.hs +++ b/src/Dodge/Tesla.hs @@ -1,12 +1,9 @@ -module Dodge.Tesla where -import Dodge.Data -import Dodge.Beam +module Dodge.Tesla + ( module Dodge.Tesla.Ball + , module Dodge.Tesla.Arc + , module Dodge.Tesla.ItemParams + ) where +import Dodge.Tesla.Ball +import Dodge.Tesla.Arc +import Dodge.Tesla.ItemParams -teslaParams :: ItemParams -teslaParams = Arcing - { _currentArc = Nothing - , _arcSize = 20 - , _arcNumber = 10 - , _newArcStep = defaultArcStep - , _previousArcEffect = NoPreviousArcEffect - } diff --git a/src/Dodge/Tesla/Arc.hs b/src/Dodge/Tesla/Arc.hs new file mode 100644 index 000000000..74ce11161 --- /dev/null +++ b/src/Dodge/Tesla/Arc.hs @@ -0,0 +1,118 @@ +module Dodge.Tesla.Arc + where +import Dodge.Data +import Dodge.Damage +import Dodge.Spark +import RandomHelp +import Picture +import Geometry +import LensHelp +--import Dodge.Data +--import Geometry +--import LensHelp +--import RandomHelp +--import Color +--import Dodge.Item.Location +--import Dodge.WorldEvent.Damage +--import Dodge.WorldEvent.ThingsHit +--import Dodge.WorldEvent.HelperParticle +--import Dodge.Item.Weapon.LaserPath +--import Geometry +--import LensHelp +--import Picture +--import RandomHelp +--import Dodge.Zone +--import Dodge.Base.Collide +--import Shape + +--import qualified Data.IntMap.Strict as IM +--import Data.List (sortOn) +import MonadHelp +import Data.Maybe +--import qualified Data.IntMap.Strict as IM + +aTeslaArcAt :: Color -> [ArcStep] -> Particle +aTeslaArcAt col thearc = PtTeslaArc + { _ptPoints = map (^. asPos) thearc + , _ptUpdate = moveTeslaArc thearc + , _ptTimer = 2 + , _ptColor = brightX 100 1.5 col + } + +moveTeslaArc :: [ArcStep] + -> World + -> Particle + -> (World,Maybe Particle) +moveTeslaArc thearc w pt + | _ptTimer pt == 2 = (makesparks $ foldr damthings w thearc, Just $ pt & ptTimer -~ 1) + | _ptTimer pt < 1 = (w, Nothing) + | otherwise = (w, Just $ pt & ptTimer -~ 1) + where + rcol = brightX 100 1.5 <$> takeOne [white,azure,blue,cyan] + rdir = state (randomR (-0.7,0.7)) <&> (+ ld) + rspeed = state (randomR (3,6)) + makeaspark = randSpark ELECTRICAL rspeed rcol rdir lp + makesparks = makeaspark . makeaspark . makeaspark + (lp,ld) = case last thearc of + ArcStep lp' ld' Nothing -> (lp',ld') + ArcStep lp' ld' (Just (Left cr)) -> (lp' -.- (_crRad cr + 1) *.* unitVectorAtAngle ld',ld'+pi) + ArcStep lp' ld' (Just (Right _)) -> (lp' -.- 2 *.* unitVectorAtAngle ld',ld'+pi) + damthings (ArcStep _ _ Nothing) = id + damthings (ArcStep p dir (Just crwl)) = damageCrWall (thedamage p dir) crwl + thedamage p dir = Damage ELECTRICAL 50 (p -.- q) p (p +.+ q) NoDamageEffect + where + q = 5 *.* unitVectorAtAngle dir + +shootTeslaArc' :: ItemParams -> Point2 -> Float -> World -> (World,ItemParams) +shootTeslaArc' ip pos dir w = + (w & randGen .~ g + & instantParticles .:~ aTeslaArcAt col newarc + , ip & currentArc ?~ newarc + ) + where + (col,g) = takeOne [white,azure,blue,cyan] & runState $ _randGen w + newarc = createArc ip w pos dir & evalState $ _randGen w + +createArc :: ItemParams + -> World + -> Point2 + -> Float + -> State StdGen [ArcStep] +createArc arcparams@Arcing{_currentArc = Nothing} w p dir = createNewArc arcparams w p dir +createArc arcparams w p dir = updateArc arcparams w p dir + +createNewArc :: ItemParams -> World -> Point2 -> Float + -> State StdGen [ArcStep] +createNewArc arcparams w p dir = take (_arcNumber arcparams) + <$> unfoldrMID (_newArcStep arcparams arcparams w) (ArcStep p dir Nothing) + +updateArc :: ItemParams + -> World + -> Point2 + -> Float + -> State StdGen [ArcStep] +updateArc ip w p dir = take (_arcNumber ip) <$> zipArcs ip w (ArcStep p dir Nothing) carc + where + carc = tail $ fromJust $ _currentArc ip + +zipArcs :: ItemParams + -> World + -> ArcStep + -> [ArcStep] + -> State StdGen [ArcStep] +zipArcs ip w x (y:ys) = (x :) <$> do + defaultnext <- _newArcStep ip ip w x + case defaultnext of + Nothing -> return [] + Just z@(ArcStep _ _ (Just _)) -> return [z] + Just z -> do + p <- randInCirc 5 + let csize = _arcSize ip + center = _asPos x +.+ csize *.* unitVectorAtAngle (_asDir x) + newp = _asPos y +.+ p + --newdir = argV $ newp -.- _asPos x + newdir = _asDir x + if dist newp center < csize + then zipArcs ip w (y & asPos .~ newp & asDir .~ newdir) ys + else zipArcs ip w z ys +zipArcs ip w y _ = createNewArc ip w (_asPos y) (_asDir y) diff --git a/src/Dodge/Tesla/Arc/Default.hs b/src/Dodge/Tesla/Arc/Default.hs new file mode 100644 index 000000000..2d8975fbb --- /dev/null +++ b/src/Dodge/Tesla/Arc/Default.hs @@ -0,0 +1,35 @@ +module Dodge.Tesla.Arc.Default where +import Dodge.Data +import RandomHelp +import Geometry +import Dodge.Base.Collide +import LensHelp +import Shape + +import Data.Maybe +import Data.List (sortOn) +import qualified Data.IntMap.Strict as IM + +defaultArcStep :: RandomGen g => ItemParams -> World -> ArcStep + -> State g (Maybe ArcStep) +defaultArcStep _ _ (ArcStep _ _ (Just _)) = return Nothing +defaultArcStep itparams w (ArcStep p dir _) = do + let csize = _arcSize itparams + --rot <- takeOne [pi/4,negate pi/4] + rot <- takeOne [0] + let center = csize *.* rotateV rot (unitVectorAtAngle dir) +.+ p + newp <- (center +.+) <$> randInCirc csize + let mcr = listToMaybe + . sortOn (dist center . _crPos) + . filter (\cr -> dist center (_crPos cr) < csize) + . IM.elems + $ _creatures w + mwl = listToMaybe + . sortOn (dist p . fst) + . mapMaybe (\ q -> sequence $ collidePointWallsFilterStream (const True) p (center +.+ q) w) + -- collidePointWallsWall and wlsnearpoint + $ polyCirc 6 csize + f (q,wl) = ArcStep q dir (Just $ Right wl) + g cr = ArcStep (_crPos cr +.+ csize *.* unitVectorAtAngle dir) dir (Just $ Left cr) + return . listToMaybe . sortOn (dist p . (^. asPos)) + $ ArcStep newp dir Nothing : catMaybes [fmap f mwl,fmap g mcr] diff --git a/src/Dodge/Tesla/Ball.hs b/src/Dodge/Tesla/Ball.hs new file mode 100644 index 000000000..afa12af3a --- /dev/null +++ b/src/Dodge/Tesla/Ball.hs @@ -0,0 +1,6 @@ +module Dodge.Tesla.Ball where +import Dodge.Data +import Geometry + +makeTeslaBallAt :: Point2 -> World -> World +makeTeslaBallAt _ = id diff --git a/src/Dodge/Tesla/ItemParams.hs b/src/Dodge/Tesla/ItemParams.hs new file mode 100644 index 000000000..6058658e6 --- /dev/null +++ b/src/Dodge/Tesla/ItemParams.hs @@ -0,0 +1,12 @@ +module Dodge.Tesla.ItemParams where +import Dodge.Data +import Dodge.Tesla.Arc.Default + +teslaParams :: ItemParams +teslaParams = Arcing + { _currentArc = Nothing + , _arcSize = 20 + , _arcNumber = 10 + , _newArcStep = defaultArcStep + , _previousArcEffect = NoPreviousArcEffect + } diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 355634765..452751604 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -6,6 +6,7 @@ Description : Simulation update module Dodge.Update ( updateUniverse ) where import Dodge.Data import Dodge.Spark +import Dodge.Flame import Dodge.Bullet import Dodge.Update.Cloud import Dodge.Machine.Update @@ -83,6 +84,7 @@ functionalUpdate cfig w = checkEndGame . dbArg _worldEvents . updateIMl _modifications _mdUpdate . updateSparks + . updateFlames . updateParticles . updateBullets . updateRadarBlips @@ -222,10 +224,15 @@ updateBullets w = updateInstantBullets $ set bullets (catMaybes ps) w' where (w',ps) = mapAccumR updateBullet w $ _bullets w +updateFlames :: World -> World +updateFlames w = w' & flames .~ catMaybes newflames + where + (w',newflames) = mapAccumR moveFlame w $ _flames w + updateSparks :: World -> World updateSparks w = w' & sparks .~ catMaybes newsparks where - (w',newsparks) = mapAccumR (\a b -> moveSpark a b) w $ _sparks w + (w',newsparks) = mapAccumR moveSpark w $ _sparks w {- Apply internal particle updates, delete 'Nothing's. -} updateParticles :: World -> World diff --git a/src/Dodge/WorldEvent/Explosion.hs b/src/Dodge/WorldEvent/Explosion.hs index 184efa442..ccc11dfac 100644 --- a/src/Dodge/WorldEvent/Explosion.hs +++ b/src/Dodge/WorldEvent/Explosion.hs @@ -9,8 +9,7 @@ module Dodge.WorldEvent.Explosion ) where import Dodge.Data import Dodge.LightSource ---import Dodge.Default ---import Dodge.Zone +import Dodge.Flame import Dodge.Base.Collide import Dodge.WorldEvent.SpawnParticle --import Dodge.WorldEvent.Flash @@ -58,7 +57,7 @@ makeFlameExplosionAt -> World makeFlameExplosionAt p w = soundMultiFrom [Explosion 0,Explosion 1] p bangS Nothing w - & instantParticles .++~ newFlames + & flames .++~ newFlames where newFlames = zipWith makeFlameWithVelAndTime velocities timers makeFlameWithVelAndTime vel time = aFlameParticle time p vel diff --git a/src/Dodge/WorldEvent/SpawnParticle.hs b/src/Dodge/WorldEvent/SpawnParticle.hs index 5d75ac471..e438ed574 100644 --- a/src/Dodge/WorldEvent/SpawnParticle.hs +++ b/src/Dodge/WorldEvent/SpawnParticle.hs @@ -1,7 +1,6 @@ {- | Creation of particles in the world. -} module Dodge.WorldEvent.SpawnParticle ( makeGasCloud - , aFlameParticle , makeFlamelet , aStaticBall , incBall @@ -11,12 +10,8 @@ import Dodge.Data import Dodge.Zone import Dodge.Particle.HitEffect.ExpireAndDamage import Dodge.Particle.Damage ---import Dodge.WorldEvent.HitEffect -import Dodge.WorldEvent.ThingsHit -import Dodge.WorldEvent.Cloud import Dodge.WorldEvent.Flash import Dodge.WorldEvent.Shockwave -import Dodge.SoundLogic import RandomHelp import Picture import Geometry @@ -24,59 +19,7 @@ import qualified IntMapHelp as IM import LensHelp import Data.Foldable -import Data.Tuple import qualified Streaming.Prelude as S -aFlameParticle - :: Int -- ^ Timer - -> Point2 -- ^ Position - -> Point2 -- ^ Velocity - -> Particle -aFlameParticle t pos vel = PtFlame - { _ptUpdate = moveFlame - , _ptVel = vel - , _ptColor = red - , _ptPos = pos - , _ptWidth = 4 - , _ptTimer = t - , _ptHitEff = expireAndDamage $ simpleDam FLAMING 1 - , _ptZ = 20 - , _ptOriginalVel = vel - } -{- TODO: add generalised area damage particles/hiteffects. -} -moveFlame :: World - -> Particle - -> (World, Maybe Particle) -moveFlame w pt - | time <= 0 = (makeFlamerSmokeAt (addZ 20 ep) w, Nothing) - | otherwise = case runIdentity . S.head_ $ thingsHit sp ep w of - Just (_,Left _) -> (doSound $ dodamage w , mvPt' 0.7) - Just (p,Right wl) -> (doSound $ dodamage w , rfl wl p) - _ -> (ptFlicker pt $ doSound $ dodamage w , mvPt' 0.98) - where - rotd = _ptOriginalVel pt - time = _ptTimer pt - doSound = soundContinue Flame (V2 x y) fireLoudS (Just 2) - sp@(V2 x y) = _ptPos pt - vel = _ptVel pt - ep = sp +.+ vel - mvPt' drag = Just $ pt - & ptTimer -~ 1 - & ptPos .~ ep - & ptVel %~ (drag *.*) - dodamage = damageInArea closeCrs closeWls pt - closeWls wl = uncurry segOnCirc (_wlLine wl) ep 5 - closeCrs cr = dist ep (_crPos cr) - < _crRad cr + 10 - min 9 (max 0 (fromIntegral time - 80)) - + 5 * angleCoeff (angleVV (ep -.- _crPos cr) rotd) - angleCoeff x' = abs $ 1 - abs ( (x' * 2 - pi) / pi ) - rfl wl p = Just $ pt - { _ptTimer = time - 1 - , _ptPos = pOut p - , _ptVel = reflV wl - } - pOut p = p +.+ squashNormalizeV (sp -.- p) - reflV wall = (0.3 *.* reflectIn (uncurry (-.-) . swap $ _wlLine wall) vel ) - +.+ (0.2 *.* vel) concBall :: Point2 -> State g Particle