From 97174535d8d48971bfc46b202bd0e0a65ffbf18e Mon Sep 17 00:00:00 2001 From: justin Date: Sat, 23 Jul 2022 23:46:03 +0100 Subject: [PATCH] Reify tesla arcs --- src/Dodge/Data.hs | 11 ++++------- src/Dodge/Data/TeslaArc.hs | 3 +++ src/Dodge/Default/World.hs | 1 + src/Dodge/Particle/Draw.hs | 15 +++++++-------- src/Dodge/Render/ShapePicture.hs | 2 ++ src/Dodge/Tesla/Arc.hs | 30 +++++++++++++++--------------- src/Dodge/Update.hs | 8 ++++++++ 7 files changed, 40 insertions(+), 30 deletions(-) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 03af21e5d..a204f4592 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -78,7 +78,9 @@ module Dodge.Data , module Dodge.Data.Modification , module Dodge.Data.PressPlate , module Dodge.Data.Laser + , module Dodge.Data.TeslaArc ) where +import Dodge.Data.TeslaArc import Dodge.Data.Laser import Dodge.Data.PressPlate import Dodge.Data.Modification @@ -222,6 +224,7 @@ data World = World , _flares :: [Flare] , _newBeams :: WorldBeams , _beams :: WorldBeams + , _teslaArcs :: [TeslaArc] , _lasers :: [LaserStart] , _lasersToDraw :: [Laser] , _walls :: IM.IntMap Wall @@ -374,13 +377,7 @@ data WorldBeams = WorldBeams {- Objects without ids. Update themselves, perhaps with side effects. -} data Particle - = PtTeslaArc - { _ptUpdate :: World -> Particle -> (World, Maybe Particle) - , _ptPoints :: [Point2] - , _ptTimer :: Int - , _ptColor :: Color - } - | PtTargetLaser + = PtTargetLaser { _ptUpdate :: World -> Particle -> (World, Maybe Particle) , _ptPoints :: [Point2] , _ptColor :: Color diff --git a/src/Dodge/Data/TeslaArc.hs b/src/Dodge/Data/TeslaArc.hs index 7c40f8a52..ccb7a3553 100644 --- a/src/Dodge/Data/TeslaArc.hs +++ b/src/Dodge/Data/TeslaArc.hs @@ -4,9 +4,12 @@ module Dodge.Data.TeslaArc where import Geometry.Data import Color import Control.Lens +import Dodge.Data.ArcStep data TeslaArc = TeslaArc { _taPoints :: [Point2] , _taTimer :: Int + , _taArcSteps :: [ArcStep] , _taColor :: Color } + deriving (Eq,Ord,Show,Read) makeLenses ''TeslaArc diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index 31deb7d04..26d655a48 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -45,6 +45,7 @@ defaultWorld = World , _flares = [] , _newBeams = WorldBeams [] [] [] [] , _beams = WorldBeams [] [] [] [] + , _teslaArcs = [] , _lasers = [] , _lasersToDraw = [] , _walls = IM.empty diff --git a/src/Dodge/Particle/Draw.hs b/src/Dodge/Particle/Draw.hs index 35d0983ac..bef439240 100644 --- a/src/Dodge/Particle/Draw.hs +++ b/src/Dodge/Particle/Draw.hs @@ -7,7 +7,6 @@ drawParticle :: Particle -> Picture drawParticle pt = case pt of Shockwave {} -> drawShockwave pt PtInvShockwave {} -> drawInverseShockwave pt - PtTeslaArc {} -> drawTeslaArc pt PtTargetLaser {} -> drawTargetLaser pt ShockLine {} -> drawSonicWave pt @@ -34,13 +33,13 @@ drawInverseShockwave pt rad = r - 0.1 * r * fromIntegral (10 - t) thickness = fromIntegral (10 - t) **2 * rad / 40 -drawTeslaArc :: Particle -> Picture -drawTeslaArc pt = setLayer BloomNoZWrite $ pictures - [ setDepth 20.5 $ color (brightX 2 1 $ _ptColor pt) $ thickLine 3 ps - , setDepth 20 $ color (V4 0 0 0 0.5) $ thickLine 10 ps - ] - where - ps = _ptPoints pt +--drawTeslaArc :: Particle -> Picture +--drawTeslaArc pt = setLayer BloomNoZWrite $ pictures +-- [ setDepth 20.5 $ color (brightX 2 1 $ _ptColor pt) $ thickLine 3 ps +-- , setDepth 20 $ color (V4 0 0 0 0.5) $ thickLine 10 ps +-- ] +-- where +-- ps = _ptPoints pt drawTargetLaser :: Particle -> Picture drawTargetLaser pt = setLayer BloomNoZWrite $ pictures diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 1c30200f2..d86d84eb4 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -1,6 +1,7 @@ module Dodge.Render.ShapePicture ( worldSPic ) where +import Dodge.Tesla.Arc.Draw import Dodge.Laser.Draw import Dodge.Cloud.Draw import Dodge.Zoning @@ -128,6 +129,7 @@ cullPoint cfig w p extraPics :: Configuration -> World -> Picture extraPics cfig w = pictures (_decorations w) <> concatMapPic drawLaser (_lasersToDraw w) + <> concatMapPic drawTeslaArc (_teslaArcs w) <> concatMapPic drawParticle (_particles w) <> concatMapPic drawRadarSweep (_radarSweeps w) <> concatMapPic drawFlame (_flames w) diff --git a/src/Dodge/Tesla/Arc.hs b/src/Dodge/Tesla/Arc.hs index 4de475cba..64225b494 100644 --- a/src/Dodge/Tesla/Arc.hs +++ b/src/Dodge/Tesla/Arc.hs @@ -32,23 +32,23 @@ import MonadHelp import Data.Maybe --import qualified IntMapHelp 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 +aTeslaArcAt :: Color -> [ArcStep] -> TeslaArc +aTeslaArcAt col thearc = TeslaArc + { _taPoints = map (^. asPos) thearc + , _taArcSteps = thearc + , _taTimer = 2 + , _taColor = 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) +moveTeslaArc :: World + -> TeslaArc + -> (World,Maybe TeslaArc) +moveTeslaArc w pt + | _taTimer pt == 2 = (makesparks $ foldr damthings w thearc, Just $ pt & taTimer -~ 1) + | _taTimer pt < 1 = (w, Nothing) + | otherwise = (w, Just $ pt & taTimer -~ 1) where + thearc = _taArcSteps pt rcol = brightX 100 1.5 <$> takeOne [white,azure,blue,cyan] rdir = state (randomR (-0.7,0.7)) <&> (+ ld) rspeed = state (randomR (3,6)) @@ -71,7 +71,7 @@ moveTeslaArc thearc w pt shootTeslaArc' :: ItemParams -> Point2 -> Float -> World -> (World,ItemParams) shootTeslaArc' ip pos dir w = (w & randGen .~ g - & instantParticles .:~ aTeslaArcAt col newarc + & teslaArcs .:~ aTeslaArcAt col newarc , ip & currentArc ?~ newarc ) where diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 80e3c6145..93a55decf 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -4,6 +4,7 @@ Module : Dodge.Update Description : Simulation update -} module Dodge.Update ( updateUniverse ) where +import Dodge.Tesla.Arc import Dodge.Laser.Update import Dodge.PressPlate import Dodge.ModificationEffect @@ -96,6 +97,7 @@ functionalUpdate w = checkEndGame . over uvWorld updateFlares . over uvWorld updateBeams . over uvWorld updateLasers + . over uvWorld updateTeslaArcs . over uvWorld (updateIMl _props _pjUpdate ) . over uvWorld (updateIMl' _projectiles updateProjectile) . over uvWorld updateLightSources @@ -229,6 +231,12 @@ updateRadarBlips = radarBlips %~ mapMaybe updateRadarBlip updateFlares :: World -> World updateFlares = flares %~ mapMaybe updateFlare +updateTeslaArcs :: World -> World +updateTeslaArcs w = w' & teslaArcs .~ catMaybes newtas + where + (w',newtas) = mapAccumR moveTeslaArc w $ _teslaArcs w + + {- Apply internal particle updates, delete 'Nothing's. -} updateBullets :: World -> World updateBullets w = updateInstantBullets $ set bullets (catMaybes ps) w'