Move flame into its own datatype

src/Dodge/Beam.hs

@@ -1,22 +1,21 @@
 module Dodge.Beam where
 import Dodge.Data
-import Dodge.Particle.Flame
+import Dodge.Flame
-import Dodge.Particle.TeslaArc
+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 Dodge.Base.Collide
-import Shape
+--import Shape
 
-import Data.List (sortOn)
+--import Data.List (sortOn)
-import MonadHelp
+--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)

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

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

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

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 

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)

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

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

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

src/Dodge/Data/SoundOrigin.hs

@@ -14,7 +14,7 @@ data SoundOrigin = InventorySound
     | CrReloadSound Int
     | Flamer
     | ShellSound Int
-    | Flame
+    | FlameSound
     | LasSound
     | FootstepSound Int
     | BlockDegradeSound Int

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

src/Dodge/Default/World.hs

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

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)

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)

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

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.Flame
---import Dodge.Data.SoundOrigin
---import Dodge.Base
---import Dodge.Zone
---import Dodge.Picture.Layer
---import Dodge.SoundLogic
 import Dodge.SoundLogic.LoadSound
 --import Dodge.Creature.Action
 import Dodge.WorldEvent

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 

src/Dodge/Particle/Flame.hs

@@ -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)

src/Dodge/Particle/TeslaArc.hs

@@ -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

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)

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
---        }

src/Dodge/Tesla.hs

@@ -1,12 +1,9 @@
-module Dodge.Tesla where
+module Dodge.Tesla 
-import Dodge.Data
+    ( module Dodge.Tesla.Ball
-import Dodge.Beam
+    , 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
-    }

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)

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]

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

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
+    }

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

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.Flame
---import Dodge.Zone
 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

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