Move sparks into dedicated datatype

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

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))
+      = zipWith3 (\p a -> createBarrelSpark (_crPos cr +.+ p) (a + argV p))
-                            poss as times colids
+                            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 %~ 

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]

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

src/Dodge/Default/World.hs

@@ -43,6 +43,7 @@ defaultWorld = World
     , _bullets = []
     , _instantParticles = []
     , _particles = []
+    , _sparks = []
     , _radarBlips = []
     , _flares = []
     , _newBeams = WorldBeams [] [] [] []

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)
+    LASERING    -> a 0 $ colSparkRandDir 0.2 lSparkCol outTo (argV $ reflectIn (p -.- sp) v)
-    PIERCING    -> a d $ colSparkRandDir 0.2 8 pSparkCol 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

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

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

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)

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 lp
-    makeaspark = randColDirTimeSpark rcol rdir rtime lp
     makesparks = makeaspark . makeaspark . makeaspark
     (lp,ld) = case last thearc of
         ArcStep lp' ld' Nothing -> (lp',ld')

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 :: Particle -> Maybe Particle
-destroyAt hitp pt = Just $ pt 
+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)
         )

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)

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
+moveSpark :: World -> Spark -> (World, Maybe Spark)
-
+moveSpark w sk
-mvSpark :: World -> Particle -> (World, Maybe Particle)
+    | magV (_skVel sk) < 1 = (w,Nothing)
-mvSpark w bt' 
+    | otherwise = case thingHit sp ep w of
-    | t <= 0 || magV (_ptVel bt) < 1 = (w,Nothing)
+        Nothing -> (w, Just $ sk & skPos .~ ep & skVel .*.*~ 0.9 & skOldPos .~ sp)
-    | otherwise = second (fmap dodrag) $ 
+        Just (hp,hthing) -> (sparkDam sp ep (hp,hthing) w, Just $ sk & skPos .~ hp & skOldPos .~ sp & skVel .~ 0)
-        hiteff bt (thingsHit p (p +.+ vel) w) w
   where
-    bt = bt'
+    sp = _skPos sk
-    dodrag = ptVel .*.*~ drag
+    ep = sp +.+ _skVel sk
-    drag = _ptDrag bt
+
-    (p:_)   = _ptTrail bt
+sparkDam 
-    vel     = _ptVel bt
+    :: Point2
-    hiteff  = _ptHitEff bt
+    -> Point2
-    t       = _ptTimer bt
+    -> (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 :: Point2 -> Float -> Int -> World -> World
-createBarrelSpark pos dir time colid = instantParticles .:~ PtSpark  
+createBarrelSpark pos dir colid = sparks .:~ Spark  
-    { _ptUpdate = mvSpark
+    { _skVel = rotateV dir (V2 5 0)
-    , _ptVel = rotateV dir (V2 5 0)
+    , _skColor = numColor colid
-    , _ptDrag = 0.9
+    , _skPos = pos
-    , _ptColor = numColor colid
+    , _skOldPos = pos
-    , _ptTrail = [pos]
+    , _skWidth = 1
-    , _ptWidth = 1
-    , _ptTimer = time
-    , _ptHitEff = expireAndDamage basicSparkDams
     }
-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
+randColDirTimeSpark randcol randdir pos w = w
-    & instantParticles .:~ spark
+    & 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)
-        return (c,d,t)
+    spark = Spark
-    spark = PtSpark
+        { _skVel    = rotateV dir (V2 5 0)
-        { _ptUpdate = mvSpark
+        , _skColor  = col
-        , _ptDrag   = 0.9
+        , _skPos  = pos
-        , _ptVel    = rotateV dir (V2 5 0)
+        , _skOldPos  = pos
-        , _ptColor  = col
+        , _skWidth = 1
-        , _ptTrail  = [pos]
-        , _ptWidth = 1
-        , _ptTimer = time
-        , _ptHitEff = expireAndDamage basicSparkDams
         }
 
-colSparkRandDir :: Float -> Int -> Color -> Point2 -> Float -> World -> World
+colSparkRandDir :: Float -> Color -> Point2 -> Float -> World -> World
-colSparkRandDir randDir time col pos baseDir w = w 
+colSparkRandDir randDir col pos baseDir w = w 
-    & instantParticles .:~ spark
+    & sparks .:~ spark
     & randGen .~ g
   where
     (a,g)  = randomR (-randDir,randDir) $ _randGen w
     dir = a + baseDir
-    spark = PtSpark
+    spark = Spark
-        { _ptUpdate = mvSpark
+        { _skVel = rotateV dir (V2 5 0)
-        , _ptDrag   = 0.9
+        , _skColor = col
-        , _ptVel = rotateV dir (V2 5 0)
+        , _skPos = pos
-        , _ptColor = col
+        , _skOldPos = pos
-        , _ptTrail = [pos]
+        , _skWidth = 1
-        , _ptWidth = 1
-        , _ptTimer = time
-        , _ptHitEff = expireAndDamage basicSparkDams
         }

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]

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'

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)
+    LASERING    -> a 0 $ colSparkRandDir 0.2 lSparkCol outTo (reflDirWall sp p wl)
-    PIERCING    -> a d $ colSparkRandDir 0.2 8 pSparkCol outTo (reflDirWall sp p wl) . wlDustAt wl outTo
+    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)
+    LASERING    -> a 0 $ colSparkRandDir 0.2 lSparkCol outTo (reflDirWall sp p wl)
-    PIERCING    -> a d $ dosplint . colSparkRandDir 0.2 8 pSparkCol outTo (reflDirWall sp p wl) . wlDustAt wl outTo
+    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)
+    LASERING    -> a 0 $ colSparkRandDir 0.2 lSparkCol outTo (reflDirWall sp p wl)
-    PIERCING    -> a 0 $ colSparkRandDir 0.2 8 pSparkCol outTo (reflDirWall sp p wl) . wlDustAt wl outTo
+    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