Reify shockwaves

src/Dodge/Beam.hs

@@ -51,7 +51,7 @@ teslaBeamCombine (p,(a,b,bm),(x,y,_)) w
 
 lasRayAt :: Color -> Int -> Float -> Point2 -> Float -> LaserStart
 lasRayAt col dam phasev pos dir = LaserStart
-    { _lpDamage = dam
+    { _lpType = DamageLaser dam
     , _lpPhaseV = phasev
     , _lpPos = pos
     , _lpDir = dir

src/Dodge/Bullet.hs

@@ -83,7 +83,7 @@ bulletSpawn :: Bullet -> Maybe (Point2 -> World -> World)
 bulletSpawn bu = case _buSpawn bu of
     BulSpark -> Nothing
     BulBall IncBall -> Just incBallAt
-    BulBall ConcBall -> Just $ randParticleAt concBall
+    BulBall ConcBall -> Just $ \p -> shockwaves .:~ concBall p
     BulBall TeslaBall -> Just makeStaticBall
 
 hitEffFromBul :: Float -> Bullet

src/Dodge/Data.hs

@@ -79,7 +79,9 @@ module Dodge.Data
     , module Dodge.Data.PressPlate
     , module Dodge.Data.Laser
     , module Dodge.Data.TeslaArc
+    , module Dodge.Data.Shockwave
     ) where
+import Dodge.Data.Shockwave
 import Dodge.Data.TeslaArc
 import Dodge.Data.Laser
 import Dodge.Data.PressPlate
@@ -225,6 +227,7 @@ data World = World
     , _newBeams         :: WorldBeams
     , _beams            :: WorldBeams
     , _teslaArcs        :: [TeslaArc]
+    , _shockwaves       :: [Shockwave]
     , _lasers           :: [LaserStart]
     , _lasersToDraw     :: [Laser]
     , _walls            :: IM.IntMap Wall
@@ -377,22 +380,7 @@ data WorldBeams = WorldBeams
 {- Objects without ids.
 Update themselves, perhaps with side effects.  -}
 data Particle
-    = PtTargetLaser
+    = PtInvShockwave
-        { _ptUpdate :: World -> Particle -> (World, Maybe Particle)
-        , _ptPoints :: [Point2]
-        , _ptColor  :: Color
-        }
-    | Shockwave
-        { _ptUpdate     :: World -> Particle -> (World, Maybe Particle)
-        , _ptColor      :: Color
-        , _ptPos        :: Point2
-        , _ptRad        :: Float
-        , _ptDam        :: Int
-        , _ptPush       :: Float
-        , _ptMaxTime    :: Int
-        , _ptTimer      :: Int
-        }
-    | PtInvShockwave
         { _ptUpdate     :: World -> Particle -> (World, Maybe Particle)
         , _ptColor      :: Color
         , _ptPos        :: Point2

src/Dodge/Data/Laser.hs

@@ -5,17 +5,26 @@ module Dodge.Data.Laser
 import Color
 import Geometry.Data
 import Control.Lens
+
+data LaserType = DamageLaser {_laserTypeDamage :: Int}
+    | TargetLaser
+  deriving (Eq,Ord,Show,Read)
+
 data LaserStart = LaserStart
-    { _lpDamage :: Int
+    { _lpPhaseV :: Float
-    , _lpPhaseV :: Float
     , _lpPos :: Point2
     , _lpDir :: Float
     , _lpColor :: Color
+    , _lpType   :: LaserType
     }
+  deriving (Eq,Ord,Show,Read)
 
 data Laser = Laser
     { _laColor  :: Color
     , _laPoints :: [Point2]
+    , _laType   :: LaserType
     }
+  deriving (Eq,Ord,Show,Read)
 makeLenses ''Laser
 makeLenses ''LaserStart
+makeLenses ''LaserType

src/Dodge/Data/Shockwave.hs

@@ -0,0 +1,22 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
+module Dodge.Data.Shockwave
+    where
+import Color
+import Geometry.Data
+import Control.Lens
+data ShockwaveDirection = OutwardShockwave | InwardShockwave
+  deriving (Eq,Ord,Show,Read)
+data Shockwave = Shockwave
+    { _swColor      :: Color
+    , _swDirection  :: ShockwaveDirection
+    , _swInvulnerableCrs :: [Int]
+    , _swPos        :: Point2
+    , _swRad        :: Float
+    , _swDam        :: Int
+    , _swPush       :: Float
+    , _swMaxTime    :: Int
+    , _swTimer      :: Int
+    }
+  deriving (Eq,Ord,Show,Read)
+makeLenses ''Shockwave

src/Dodge/Default/World.hs

@@ -46,6 +46,7 @@ defaultWorld = World
     , _newBeams         = WorldBeams [] [] [] []
     , _beams            = WorldBeams [] [] [] []
     , _teslaArcs        = []
+    , _shockwaves       = []
     , _lasers           = []
     , _lasersToDraw     = []
     , _walls            = IM.empty

src/Dodge/Flame.hs

@@ -59,9 +59,7 @@ doDamagesFL fdm (p,thhit) bt = case thhit of
     dams = fdm bt p
 
 {- TODO: add generalised area damage particles/hiteffects.  -}
-moveFlame :: World 
+moveFlame :: World -> Flame -> (World, Maybe Flame)
-    -> Flame
-    -> (World, Maybe Flame)
 moveFlame w pt 
     | time <= 0 = (makeFlamerSmokeAt (addZ 20 ep) w, Nothing)
     | otherwise = case List.safeHead $ thingsHit sp ep w of

src/Dodge/Item/Weapon/Decoration.hs

@@ -1,23 +0,0 @@
-{- |
-Particles and pictures that decorate weapons, such as laser scopes etc.
--}
-module Dodge.Item.Weapon.Decoration
-    ( makeLaserScope
-    ) where
-import Dodge.Data
-import Geometry.Data
-import Picture
-
-import Control.Lens
-makeLaserScope 
-    :: Point2   -- ^ Start point
-    -> Point2   -- ^ End point
-    -> Float    -- ^ Fraction of red/green
-    -> Particle
-makeLaserScope p ep relFrac = PtTargetLaser
-    {_ptUpdate = \w pt -> (w, Just $ pt & ptUpdate .~ \w' _ -> (w',Nothing))
-        , _ptPoints = [p,ep]
-        , _ptColor = col
-    }
-  where
-    col = mixColors relFrac (1-relFrac) red green

src/Dodge/Item/Weapon/ExtraEffect.hs

@@ -141,10 +141,12 @@ targetLaserUpdate _ cr w t
     (mp, ps) = reflectLaserAlong 0.2 sp ep w
     sp = _crPos cr +.+ 15 *.* unitVectorAtAngle (_crDir cr)
     ep = sp +.+ 5000 *.* normalizeV (mouseWorldPos w -.- sp)
-    addLaserPic = instantParticles .:~ PtTargetLaser
+    addLaserPic = lasers .:~ LaserStart
-        { _ptUpdate = ptSimpleTime 1
+        { _lpPhaseV = 1
-        , _ptPoints = sp:ps
+        , _lpDir    = _crDir cr
-        , _ptColor = col
+        , _lpPos    = sp
+        , _lpColor  = col
+        , _lpType   = TargetLaser
         }
     --wpammo = _itConsumption it
 --    reloadFrac 

src/Dodge/Laser/Update.hs

@@ -5,16 +5,21 @@ import Dodge.WorldEvent.Damage
 import Dodge.Data
 import Geometry
 
+import Control.Lens
+import Data.Maybe
+
 updateLaser :: World -> LaserStart -> (World, Laser)
 updateLaser w pt =
-    ( damThingHitWith (\p1 p2 p3 -> Damage LASERING dam p1 p2 p3 NoDamageEffect) sp xp thHit w
+    ( w'
-    , Laser {_laPoints = sp:ps , _laColor = _lpColor pt}
+    , Laser {_laPoints = sp:ps , _laColor = _lpColor pt, _laType = _lpType pt}
     )
   where
+    w' = fromMaybe w $ do
+        dam <- pt ^? lpType . laserTypeDamage
+        return $ damThingHitWith (\p1 p2 p3 -> Damage LASERING dam p1 p2 p3 NoDamageEffect) sp xp thHit w
     phasev = _lpPhaseV pt
     sp  = _lpPos pt
     dir = _lpDir pt
-    dam = _lpDamage pt
     xp = sp +.+ 800 *.* unitVectorAtAngle dir
     (thHit, ps) = reflectLaserAlong phasev sp xp w
 

src/Dodge/Particle/Draw.hs

@@ -5,22 +5,19 @@ import Picture
 
 drawParticle :: Particle -> Picture
 drawParticle pt = case pt of
-    Shockwave {} -> drawShockwave pt
-    PtInvShockwave {} -> drawInverseShockwave pt
-    PtTargetLaser {} -> drawTargetLaser pt
     ShockLine {} -> drawSonicWave pt
-
+--
-drawShockwave :: Particle -> Picture
+--drawShockwave :: Particle -> Picture
-drawShockwave pt = setDepth 20 
+--drawShockwave pt = setDepth 20 
-    . setLayer BloomLayer
+--    . setLayer BloomLayer
-    . uncurryV translate (_ptPos pt) 
+--    . uncurryV translate (_ptPos pt) 
-    . color (_ptColor pt) 
+--    . color (_ptColor pt) 
-    $ thickCircle rad thickness
+--    $ thickCircle rad thickness
-  where
+--  where
-    r    = _ptRad pt
+--    r    = _ptRad pt
-    thickness = tFraction**2 * r 
+--    thickness = tFraction**2 * r 
-    rad = r - (3/4) * r * tFraction
+--    rad = r - (3/4) * r * tFraction
-    tFraction = fromIntegral (_ptTimer pt) / fromIntegral (_ptMaxTime pt)
+--    tFraction = fromIntegral (_ptTimer pt) / fromIntegral (_ptMaxTime pt)
 
 drawInverseShockwave :: Particle -> Picture
 drawInverseShockwave  pt 
@@ -41,14 +38,14 @@ drawInverseShockwave  pt
 --  where
 --    ps = _ptPoints pt
 
-drawTargetLaser :: Particle -> Picture
+drawTargetLaser :: Laser -> Picture
 drawTargetLaser pt = setLayer BloomNoZWrite $ pictures
-            [ setDepth 19   . color (brightX 0 0.5 col) $ thickLine 5 (sp:ps)
+    [ setDepth 19   . color (brightX 0 0.5 col) $ thickLine 5 (sp:ps)
-            , setDepth 19.5 . color (brightX 5 1 col)  $ thickLine 1  (sp:ps)
+    , setDepth 19.5 . color (brightX 5 1 col)  $ thickLine 1  (sp:ps)
-            ]
+    ]
   where
-    col = _ptColor pt
+    col = _laColor pt
-    (sp:ps) = _ptPoints pt
+    (sp:ps) = _laPoints pt
 
 drawSonicWave :: Particle -> Picture
 drawSonicWave pt = foldMap (color (_ptColor pt) . setLayer BloomNoZWrite . setDepth 20 

src/Dodge/Render/ShapePicture.hs

@@ -1,6 +1,7 @@
 module Dodge.Render.ShapePicture
     ( worldSPic
     ) where
+import Dodge.Shockwave.Draw
 import Dodge.Tesla.Arc.Draw
 import Dodge.Laser.Draw
 import Dodge.Cloud.Draw
@@ -128,6 +129,7 @@ cullPoint cfig w p
 
 extraPics :: Configuration -> World -> Picture
 extraPics cfig w = pictures (_decorations w)
+    <> concatMapPic drawShockwave (_shockwaves w)
     <> concatMapPic drawLaser (_lasersToDraw w)
     <> concatMapPic drawTeslaArc (_teslaArcs w)
     <> concatMapPic drawParticle (_particles    w)

src/Dodge/Shockwave/Draw.hs

@@ -0,0 +1,17 @@
+module Dodge.Shockwave.Draw
+    where
+import Dodge.Data.Shockwave
+import Picture
+import Geometry
+
+drawShockwave :: Shockwave -> Picture
+drawShockwave sw = setDepth 20 
+    . setLayer BloomLayer
+    . uncurryV translate (_swPos sw) 
+    . color (_swColor sw) 
+    $ thickCircle rad thickness
+  where
+    r    = _swRad sw
+    thickness = tFraction**2 * r 
+    rad = r - (3/4) * r * tFraction
+    tFraction = fromIntegral (_swTimer sw) / fromIntegral (_swMaxTime sw)

src/Dodge/Shockwave/Update.hs

@@ -0,0 +1,67 @@
+module Dodge.Shockwave.Update
+    where
+import Geometry.Vector
+import Dodge.Zoning.Wall
+import Dodge.Base.Collide
+import Dodge.Wall.Damage
+import Dodge.Data
+import qualified IntMapHelp as IM
+import LensHelp
+
+import Data.Foldable
+
+updateShockwave :: World -> Shockwave -> (World,Maybe Shockwave)
+updateShockwave w sw = case _swDirection sw of
+    OutwardShockwave -> moveShockwave w sw
+    InwardShockwave -> moveInverseShockwave w sw
+
+moveShockwave :: World -> Shockwave -> (World,Maybe Shockwave)
+moveShockwave w sw 
+    | _swTimer sw <= 0 = (        w , Nothing)
+    | otherwise         = (doDams w , Just $ sw & swTimer -~ 1)
+  where 
+    is  = _swInvulnerableCrs sw
+    r    = _swRad sw
+    p    = _swPos sw
+    push = _swPush sw
+    dam  = _swDam sw
+    t    = _swTimer sw
+    tFraction = fromIntegral t / fromIntegral (_swMaxTime sw)
+    rad = r - (3/4) * r * tFraction
+    doDams w' = over creatures (IM.map damCr) 
+        $ foldl'
+            (flip $ damageWall (Damage EXPLOSIVE 10000 p p p NoDamageEffect))
+            w'
+            hitBlocks
+    hitBlocks = map snd . overlapCircWalls p rad $ wlsNearCirc p rad w 
+        -- this is not expansive enough
+    damCr cr 
+        | _crID cr `elem` is || dist (_crPos cr) p >= rad + _crRad cr  = cr
+        | otherwise = cr & crState . csDamage .:~
+            Damage PUSHDAM dam (cpos -.- v) cpos (cpos +.+ v)
+                (PushBackDamage (25 * push))
+          where
+            cpos = _crPos cr
+            v = normalizeV (cpos -.- p)
+
+moveInverseShockwave 
+    :: World
+    -> Shockwave 
+    -> (World, Maybe Shockwave)
+moveInverseShockwave w sw 
+    | t <= 0    = (     w, Nothing)
+    | otherwise = (dams w, Just $ swTimer -~ 1 $ sw )
+  where 
+    p = _swPos sw
+    r = _swRad sw
+    t = _swTimer sw
+    rad = r - 0.1 * r * fromIntegral (10 - t)
+    dams = over creatures (IM.map damCr) -- . flip (foldr (damageBlocksBy 1)) hitBlocks
+--    hitBlocks = wallsOnCirc' p rad $ wallsNearPoint' p w 
+    damCr cr 
+        | dist (_crPos cr) p >= rad + _crRad cr = cr
+        | otherwise = cr & crState . csDamage .:~
+            Damage PUSHDAM 1 (cpos +.+ v) cpos (cpos -.- v) (PushBackDamage 25)
+          where
+            cpos = _crPos cr
+            v = normalizeV (cpos -.- p)

src/Dodge/Update.hs

@@ -4,6 +4,7 @@ Module      : Dodge.Update
 Description : Simulation update
 -}
 module Dodge.Update ( updateUniverse ) where
+import Dodge.Shockwave.Update
 import Dodge.Tesla.Arc
 import Dodge.Laser.Update
 import Dodge.PressPlate
@@ -90,6 +91,7 @@ functionalUpdate w = checkEndGame
     . over uvWorld updateRadarSweeps
     . over uvWorld updatePosEvents
     . over uvWorld updateFlames
+    . over uvWorld updateShockwaves
     . over uvWorld updateEnergyBalls
     . over uvWorld updateParticles
     . over uvWorld updateBullets
@@ -243,6 +245,11 @@ updateBullets w = updateInstantBullets $ set bullets (catMaybes ps) w'
   where 
     (w',ps) = mapAccumR updateBullet w $ _bullets w
 
+updateShockwaves :: World -> World
+updateShockwaves w = w' & shockwaves .~ catMaybes newflames
+  where
+    (w',newflames) = mapAccumR updateShockwave w $ _shockwaves w
+
 updateFlames :: World -> World
 updateFlames w = w' & flames .~ catMaybes newflames
   where

src/Dodge/WorldEvent/Shockwave.hs

@@ -1,8 +1,6 @@
 module Dodge.WorldEvent.Shockwave
     ( makeShockwaveAt
     , inverseShockwaveAt
-    , drawShockwave
-    , mvShockwave
     ) where
 import Dodge.Zoning.Wall
 import Dodge.Data
@@ -24,58 +22,18 @@ makeShockwaveAt
     -> Color    -- ^ Color of shockwave.
     -> World    -- ^ Start world.
     -> World
-makeShockwaveAt is p rad dam push col = instantParticles .:~ Shockwave
+makeShockwaveAt is p rad dam push col = shockwaves .:~ Shockwave
-    { _ptUpdate    = mvShockwave is
+    { _swInvulnerableCrs = is
-    , _ptColor     = col
+    , _swDirection = OutwardShockwave
-    , _ptPos       = p
+    , _swColor     = col
-    , _ptRad       = rad
+    , _swPos       = p
-    , _ptDam       = dam
+    , _swRad       = rad
-    , _ptPush      = push
+    , _swDam       = dam
-    , _ptMaxTime   = 10
+    , _swPush      = push
-    , _ptTimer     = 10
+    , _swMaxTime   = 10
+    , _swTimer     = 10
     }
-{- Shockwave picture.  -}
-drawShockwave :: Particle -> Picture
-drawShockwave pt = setDepth 20 
-    . setLayer BloomLayer
-    . uncurryV translate (_ptPos pt) 
-    . color (_ptColor pt) 
-    $ thickCircle rad thickness
-  where
-    r    = _ptRad pt
-    thickness = tFraction**2 * r 
-    rad = r - (3/4) * r * tFraction
-    tFraction = fromIntegral (_ptTimer pt) / fromIntegral (_ptMaxTime pt)
 
-mvShockwave
-    :: [Int]    -- ^ IDs of invulnerable creatures.
-    -> World -> Particle -> (World, Maybe Particle)
-mvShockwave is w pt 
-    | _ptTimer pt <= 0 = (        w , Nothing)
-    | otherwise         = (doDams w , Just $ pt & ptTimer -~ 1)
-  where 
-    r    = _ptRad pt
-    p    = _ptPos pt
-    push = _ptPush pt
-    dam  = _ptDam pt
-    t    = _ptTimer pt
-    tFraction = fromIntegral t / fromIntegral (_ptMaxTime pt)
-    rad = r - (3/4) * r * tFraction
-    doDams w' = over creatures (IM.map damCr) 
-        $ foldl'
-            (flip $ damageWall (Damage EXPLOSIVE 10000 p p p NoDamageEffect))
-            w'
-            hitBlocks
-    hitBlocks = map snd . overlapCircWalls p rad $ wlsNearCirc p rad w 
-        -- this is not expansive enough
-    damCr cr 
-        | _crID cr `elem` is || dist (_crPos cr) p >= rad + _crRad cr  = cr
-        | otherwise = cr & crState . csDamage .:~
-            Damage PUSHDAM dam (cpos -.- v) cpos (cpos +.+ v)
-                (PushBackDamage (25 * push))
-          where
-            cpos = _crPos cr
-            v = normalizeV (cpos -.- p)
 {- Create a shockwave going from an outside circle into a center point.  -}
 inverseShockwaveAt 
     :: Point2   -- Center position
@@ -84,34 +42,14 @@ inverseShockwaveAt
     -> Float    -- Push amount
     -> World 
     -> World
-inverseShockwaveAt p rad dam push = instantParticles .:~ Shockwave
+inverseShockwaveAt p rad dam push = shockwaves .:~ Shockwave
-    { _ptUpdate = moveInverseShockwave
+    { _swDirection = InwardShockwave
-    , _ptColor      = cyan
+    , _swInvulnerableCrs = []
-    , _ptPos       = p
+    , _swColor      = cyan
-    , _ptRad       = rad
+    , _swPos       = p
-    , _ptDam       = dam
+    , _swRad       = rad
-    , _ptPush      = push
+    , _swDam       = dam
-    , _ptMaxTime   = 10
+    , _swPush      = push
-    , _ptTimer     = 10
+    , _swMaxTime   = 10
+    , _swTimer     = 10
     }
-moveInverseShockwave 
-    :: World
-    -> Particle 
-    -> (World, Maybe Particle)
-moveInverseShockwave w pt 
-    | t <= 0    = (     w, Nothing)
-    | otherwise = (dams w, Just $ ptTimer -~ 1 $ pt )
-  where 
-    p = _ptPos pt
-    r = _ptRad pt
-    t = _ptTimer pt
-    rad = r - 0.1 * r * fromIntegral (10 - t)
-    dams = over creatures (IM.map damCr) -- . flip (foldr (damageBlocksBy 1)) hitBlocks
---    hitBlocks = wallsOnCirc' p rad $ wallsNearPoint' p w 
-    damCr cr 
-        | dist (_crPos cr) p >= rad + _crRad cr = cr
-        | otherwise = cr & crState . csDamage .:~
-            Damage PUSHDAM 1 (cpos +.+ v) cpos (cpos -.- v) (PushBackDamage 25)
-          where
-            cpos = _crPos cr
-            v = normalizeV (cpos -.- p)

src/Dodge/WorldEvent/SpawnParticle.hs

@@ -30,16 +30,17 @@ makeStaticBall p = randEnergyBallAt aStaticBall p . (posEvents .:~ thesparker)
   where
     thesparker = PosEvent SparkSpawner 10 p
 
-concBall :: Point2 -> State g Particle
+concBall :: Point2 -> Shockwave
-concBall p = return Shockwave
+concBall p = Shockwave
-    { _ptUpdate    = mvShockwave []
+    { _swDirection = OutwardShockwave
-    , _ptColor     = white
+    , _swInvulnerableCrs = []
-    , _ptPos       = p
+    , _swColor     = white
-    , _ptRad       = 15
+    , _swPos       = p
-    , _ptDam       = 4
+    , _swRad       = 15
-    , _ptPush      = 1
+    , _swDam       = 4
-    , _ptMaxTime   = 10
+    , _swPush      = 1
-    , _ptTimer     = 10
+    , _swMaxTime   = 10
+    , _swTimer     = 10
     }
 
 aStaticBall :: Point2 -> State g EnergyBall