Separate and reify laser beams

src/Dodge/Beam.hs

@@ -3,19 +3,10 @@ import Dodge.Data
 import Dodge.Flame
 import Dodge.Tesla.Arc
 import Dodge.Item.Location
-import Dodge.WorldEvent.Damage
-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 Data.List (sortOn)
---import MonadHelp
 import Data.Maybe
 import qualified IntMapHelp as IM
 
@@ -36,13 +27,13 @@ flameBeamCombine (p,(a,b,_),(x,y,_))
 lasBeamCombine :: (Point2,(Point2,Point2,Beam),(Point2,Point2,Beam))
     -> World -> World
 lasBeamCombine (p,(a,b,_),(x,y,_)) 
-    = instantParticles .:~ lasRayAt yellow 11 1 p (argV (normalizeV (b-.-a)+.+normalizeV (y-.-x)))
+    = lasers .:~ lasRayAt yellow 11 1 p (argV (normalizeV (b-.-a)+.+normalizeV (y-.-x)))
 
 splitBeamCombine :: (Point2,(Point2,Point2,Beam),(Point2,Point2,Beam))
     -> World -> World
 splitBeamCombine (p,(a,b,_),(x,y,_)) 
-    = (instantParticles .:~ lasRayAt yellow 11 1 p (dir+0.5*pi))
+    = (lasers .:~ lasRayAt yellow 11 1 p (dir+0.5*pi))
-    . (instantParticles .:~ lasRayAt yellow 11 1 p (dir-0.5*pi))
+    . (lasers .:~ lasRayAt yellow 11 1 p (dir-0.5*pi))
   where
     dir = argV (normalizeV (b-.-a)+.+normalizeV (y-.-x))
 
@@ -58,35 +49,11 @@ teslaBeamCombine (p,(a,b,bm),(x,y,_)) w
         Nothing -> error "tried to get item use teslaBeamCombine that doesn't exist"
         Just itm -> itm
 
-lasRayAt :: Color -> Int -> Float -> Point2 -> Float -> Particle
+lasRayAt :: Color -> Int -> Float -> Point2 -> Float -> LaserStart
-lasRayAt col dam phasev pos dir = LaserParticle
+lasRayAt col dam phasev pos dir = LaserStart
-    { _ptUpdate = mvLaser phasev pos dir
+    { _lpDamage = dam
-    , _ptRange = 800
+    , _lpPhaseV = phasev
-    , _ptDamage = dam
+    , _lpPos = pos
-    , _ptPhaseV = phasev
+    , _lpDir = dir
-    , _ptColor = col
+    , _lpColor = col
-    , _ptPoints = []
     }
-mvLaser :: Float    -- ^ Phase velocity, controls deflection through windows
-    -> Point2 
-    -> Float 
-    -> World 
-    -> Particle 
-    -> (World, Maybe Particle)
-mvLaser phasev sp dir w pt =
-    ( damThingHitWith (\p1 p2 p3 -> Damage LASERING dam p1 p2 p3 NoDamageEffect) sp xp thHit w
-    , Just pt {_ptPoints = sp:ps ,_ptUpdate = ptSimpleTime 0 }
-    )
-  where
-    dam = _ptDamage pt
-    xp = sp +.+ 800 *.* unitVectorAtAngle dir
-    (thHit, ps) = reflectLaserAlong phasev sp xp w
-
-drawLaser :: Particle -> Picture
-drawLaser pt =
-    setLayer BloomNoZWrite $ pictures
-    [ setDepth 19.5 . color (brightX 10 1 col)  $ thickLine 3  ps
-    ]
-  where
-    col = _ptColor pt
-    ps = _ptPoints pt

src/Dodge/Data.hs

@@ -77,7 +77,9 @@ module Dodge.Data
     , module Dodge.Data.Projectile
     , module Dodge.Data.Modification
     , module Dodge.Data.PressPlate
+    , module Dodge.Data.Laser
     ) where
+import Dodge.Data.Laser
 import Dodge.Data.PressPlate
 import Dodge.Data.Modification
 import Dodge.Data.Projectile
@@ -220,6 +222,8 @@ data World = World
     , _flares           :: [Flare]
     , _newBeams         :: WorldBeams
     , _beams            :: WorldBeams
+    , _lasers           :: [LaserStart]
+    , _lasersToDraw     :: [Laser]
     , _walls            :: IM.IntMap Wall
     , _wallDamages      :: IM.IntMap [Damage]
     , _doors            :: IM.IntMap Door
@@ -370,15 +374,7 @@ data WorldBeams = WorldBeams
 {- Objects without ids.
 Update themselves, perhaps with side effects.  -}
 data Particle
-    = LaserParticle
+    = PtTeslaArc 
-        { _ptUpdate :: World -> Particle -> (World, Maybe Particle)
-        , _ptRange  :: Float
-        , _ptDamage :: Int
-        , _ptColor  :: Color
-        , _ptPhaseV :: Float
-        , _ptPoints :: [Point2]
-        }
-    | PtTeslaArc 
         { _ptUpdate :: World -> Particle -> (World, Maybe Particle)
         , _ptPoints :: [Point2]
         , _ptTimer :: Int

src/Dodge/Data/Laser.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
+module Dodge.Data.Laser
+    where
+import Color
+import Geometry.Data
+import Control.Lens
+data LaserStart = LaserStart
+    { _lpDamage :: Int
+    , _lpPhaseV :: Float
+    , _lpPos :: Point2
+    , _lpDir :: Float
+    , _lpColor :: Color
+    }
+
+data Laser = Laser
+    { _laColor  :: Color
+    , _laPoints :: [Point2]
+    }
+makeLenses ''Laser
+makeLenses ''LaserStart

src/Dodge/Data/PressPlate.hs

@@ -16,4 +16,5 @@ data PressPlate = PressPlate
     , _ppID :: Int
     , _ppText :: String
     }
+  deriving (Eq,Ord,Show,Read)
 makeLenses ''PressPlate

src/Dodge/Default/World.hs

@@ -45,6 +45,8 @@ defaultWorld = World
     , _flares           = []
     , _newBeams         = WorldBeams [] [] [] []
     , _beams            = WorldBeams [] [] [] []
+    , _lasers           = []
+    , _lasersToDraw     = []
     , _walls            = IM.empty
     , _wallDamages = IM.empty
     , _blocks = IM.empty

src/Dodge/Item/Weapon/BatteryGuns.hs

@@ -290,7 +290,7 @@ shootTeslaArc it cr w = w'
     dir = _crDir cr
 
 shootLaser :: Item -> Creature -> World -> World
-shootLaser it cr = instantParticles .:~ lasRayAt (_lasColor $ _itParams it) dam phasev pos dir
+shootLaser it cr = lasers .:~ lasRayAt (_lasColor $ _itParams it) dam phasev pos dir
   where 
     pos = _crPos cr
     dir = _crDir cr
@@ -301,7 +301,7 @@ shootLaser it cr = instantParticles .:~ lasRayAt (_lasColor $ _itParams it) dam
 circleLaser :: Item -> Creature -> World -> World
 circleLaser it cr w
     | hasLOSIndirect cpos pos w = w
-        & instantParticles .:~ lasRayAt (_lasColor $ _itParams it) dam phasev pos dir
+        & lasers .:~ lasRayAt (_lasColor $ _itParams it) dam phasev pos dir
     | otherwise = w
   where 
     cpos = _crPos cr

src/Dodge/Laser/Draw.hs

@@ -0,0 +1,26 @@
+module Dodge.Laser.Draw
+    where
+import Dodge.Data.Laser
+import Picture
+
+--drawLaser :: Particle -> Picture
+----drawLaser pt = setLayer BloomNoZWrite $ pictures
+--    --[ setDepth 19   . color (brightX 0 0.5 col) $ thickLine 20 ps
+--drawLaser pt =
+--    setLayer BloomNoZWrite $ pictures
+----    [ setDepth 19   . color (brightX 1 0.5 col) $ thickLine 20 ps
+--    [ setDepth 19.5 . color (brightX 10 1 col)  $ thickLine 3  ps
+--    ]
+--  where
+--    col = _ptColor pt
+--    ps = _ptPoints pt
+
+
+drawLaser :: Laser -> Picture
+drawLaser pt =
+    setLayer BloomNoZWrite $ pictures
+    [ setDepth 19.5 . color (brightX 10 1 col)  $ thickLine 3  ps
+    ]
+  where
+    col = _laColor pt
+    ps  = _laPoints pt

src/Dodge/Laser/Update.hs

@@ -0,0 +1,20 @@
+module Dodge.Laser.Update
+    where
+import Dodge.Item.Weapon.LaserPath
+import Dodge.WorldEvent.Damage
+import Dodge.Data
+import Geometry
+
+updateLaser :: World -> LaserStart -> (World, Laser)
+updateLaser w pt =
+    ( damThingHitWith (\p1 p2 p3 -> Damage LASERING dam p1 p2 p3 NoDamageEffect) sp xp thHit w
+    , Laser {_laPoints = sp:ps , _laColor = _lpColor pt}
+    )
+  where
+    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

@@ -9,7 +9,6 @@ drawParticle pt = case pt of
     PtInvShockwave {} -> drawInverseShockwave pt
     PtTeslaArc {} -> drawTeslaArc pt
     PtTargetLaser {} -> drawTargetLaser pt
-    LaserParticle {} -> drawLaser pt
     ShockLine {} -> drawSonicWave pt
 
 drawShockwave :: Particle -> Picture
@@ -52,18 +51,6 @@ drawTargetLaser pt = setLayer BloomNoZWrite $ pictures
     col = _ptColor pt
     (sp:ps) = _ptPoints pt
 
-drawLaser :: Particle -> Picture
---drawLaser pt = setLayer BloomNoZWrite $ pictures
-    --[ setDepth 19   . color (brightX 0 0.5 col) $ thickLine 20 ps
-drawLaser pt =
-    setLayer BloomNoZWrite $ pictures
---    [ setDepth 19   . color (brightX 1 0.5 col) $ thickLine 20 ps
-    [ setDepth 19.5 . color (brightX 10 1 col)  $ thickLine 3  ps
-    ]
-  where
-    col = _ptColor pt
-    ps = _ptPoints pt
-
 drawSonicWave :: Particle -> Picture
 drawSonicWave pt = foldMap (color (_ptColor pt) . setLayer BloomNoZWrite . setDepth 20 
     . lineThick 20

src/Dodge/PressPlate.hs

@@ -10,6 +10,7 @@ doPressPlateEvent ppe = case ppe of
     PressPlateId -> const id 
     PPLevelReset -> ppLevelReset
 
+ppLevelReset :: PressPlate -> World -> World
 ppLevelReset pp w
     | dist (_crPos $ you w) (_ppPos pp) < 20 = makeExplosionAt (_ppPos pp) w 
     | otherwise = w

src/Dodge/Render/ShapePicture.hs

@@ -1,6 +1,7 @@
 module Dodge.Render.ShapePicture
     ( worldSPic
     ) where
+import Dodge.Laser.Draw
 import Dodge.Cloud.Draw
 import Dodge.Zoning
 import Dodge.Button.Draw
@@ -126,6 +127,7 @@ cullPoint cfig w p
 
 extraPics :: Configuration -> World -> Picture
 extraPics cfig w = pictures (_decorations w)
+    <> concatMapPic drawLaser (_lasersToDraw w)
     <> concatMapPic drawParticle (_particles    w)
     <> concatMapPic drawRadarSweep (_radarSweeps    w)
     <> concatMapPic drawFlame (_flames    w)

src/Dodge/Room/Teleport.hs

@@ -2,14 +2,12 @@
 module Dodge.Room.Teleport
     where
 import Dodge.Data
-import Dodge.Base
 import Dodge.LevelGen.Data
 import Dodge.Room.Procedural
 import Dodge.Placement.Instance
 --import Dodge.LevelGen.Data
 import Geometry
 import Picture
-import Dodge.WorldEvent.Explosion
 
 import Control.Lens
 import Control.Monad.State

src/Dodge/Update.hs

@@ -4,6 +4,7 @@ Module      : Dodge.Update
 Description : Simulation update
 -}
 module Dodge.Update ( updateUniverse ) where
+import Dodge.Laser.Update
 import Dodge.PressPlate
 import Dodge.ModificationEffect
 import Dodge.CrGroupUpdate
@@ -94,6 +95,7 @@ functionalUpdate w = checkEndGame
     . over uvWorld updateRadarBlips
     . over uvWorld updateFlares
     . over uvWorld updateBeams
+    . over uvWorld updateLasers
     . over uvWorld (updateIMl _props _pjUpdate              )
     . over uvWorld (updateIMl' _projectiles updateProjectile)
     . over uvWorld updateLightSources
@@ -118,6 +120,13 @@ functionalUpdate w = checkEndGame
 doWorldEvents :: World -> World
 doWorldEvents w = foldr doWorldEffect (w & worldEvents .~ []) (_worldEvents w)
 
+updateLasers :: World -> World
+updateLasers w = w'
+    & lasers .~ []
+    & lasersToDraw .~ ls
+  where
+    (w',ls) = mapAccumR updateLaser w (_lasers w)
+
 zoneClouds :: World -> World
 zoneClouds w = w 
     & clZoning .~ mempty