Add intersecting beams

src/Dodge/Combine/Combinations.hs

@@ -69,7 +69,9 @@ itemCombinations =
     , p [o PRISM,o TRANSFORMER,o PIPE] lasGun
     , p [o LASGUN,o PRISM] lasGunSway
     , p [o LASGUN,o HARDWARE] lasGunSwing
-    , p [o LASGUN,o PIPE] lasGunPulse
+--    , p [o LASGUN,o PIPE] lasGunPulse
+    , p [o LASGUN,p 2 PIPE] lasGunDual
+    , p [o LASGUN,o PIPE, o PRISM] lasGunWidePulse
     , p [o LASGUN,o TRANSFORMER,o PRISM] (lasGunWide 2)
 
     , p [o TRANSFORMER,p 2 CAN] sparkGun

src/Dodge/Combine/Data.hs

@@ -51,8 +51,10 @@ data CombineType
     | TESLAGUN
     | LASGUN
     | LASPULSE
+    | LASGUNDUAL
     | LASGUNSWING
     | LASGUNSWAY
+    | LASGUNWIDEPULSE
     | LASGUNWIDE Int
     | LASGUNFOCUS Int
     | SONICGUN

src/Dodge/Data.hs

@@ -86,6 +86,8 @@ data World = World
     , _props                :: IM.IntMap Prop
     , _instantParticles     :: [Particle]
     , _particles            :: [Particle]
+    , _newBeams             :: WorldBeams
+    , _beams                :: WorldBeams
     , _walls                :: IM.IntMap Wall
     , _doors                :: IM.IntMap Door
     , _machines             :: IM.IntMap Machine
@@ -496,6 +498,33 @@ data ItEffect
         ,_itEffectID   :: Maybe Int
         }
 data IntID a = IntID Int a
+
+data WorldBeams = WorldBeams
+    {_blockingBeams :: [Beam]
+    ,_lightBeams    :: [Beam]
+    ,_positronBeams :: [Beam]
+    ,_electronBeams :: [Beam]
+    }
+{- | Linear beams. Last only one frame.
+ - Can interact with one another in a limited manner
+ -}
+data Beam = Beam
+    { _bmDraw   :: Beam -> Picture
+    , _bmPos    :: Point2
+    , _bmDir    :: Float
+    , _bmDamage :: Int
+    , _bmColor  :: Color
+    , _bmPoints :: [Point2]
+    , _bmFirstPoints :: [Point2]
+    , _bmRange  :: Float
+    , _bmPhaseV :: Float
+    , _bmType   :: BeamType
+    }
+data BeamType 
+    = BeamCombine 
+        {_beamCombine :: (Point2 , (Point2,Point2,Beam) , (Point2,Point2,Beam)) -> World -> World}
+    | BeamSimple
+
 {- Objects without ids.
 Update themselves, perhaps with side effects.  -}
 data Particle
@@ -1136,3 +1165,6 @@ makeLenses ''TerminalLine
 makeLenses ''ItemValue
 makeLenses ''ScreenLayer
 makeLenses ''Sensor
+makeLenses ''Beam
+makeLenses ''BeamType
+makeLenses ''WorldBeams

src/Dodge/Default/World.hs

@@ -38,6 +38,8 @@ defaultWorld = World
     , _props = IM.empty
     , _instantParticles = []
     , _particles = []
+    , _newBeams = WorldBeams [] [] [] []
+    , _beams = WorldBeams [] [] [] []
     , _walls = IM.empty
     , _blocks = IM.empty
     , _machines = IM.empty

src/Dodge/Item/Weapon/BatteryGuns.hs

@@ -1,6 +1,8 @@
 module Dodge.Item.Weapon.BatteryGuns
     ( lasGun
+    , lasGunDual
     , lasGunWide
+    , lasGunWidePulse
     , lasGunSway
     , lasGunSwing
     , lasGunFocus
@@ -14,6 +16,7 @@ import Dodge.Data
 import Dodge.Item.Weapon.LaserPath
 import Dodge.Creature.HandPos
 import Dodge.Particle.TeslaArc
+import Dodge.Particle.Flame
 import Dodge.SoundLogic.LoadSound
 import Dodge.WorldEvent.Flash
 import Dodge.WorldEvent.Damage
@@ -137,27 +140,34 @@ lasGunWide n = lasGun
   where
     n' = 9 * n
     xs = [ 0.25 * (fromIntegral x - fromIntegral (n'-1) /2)  | x <- [0..n'-1] ]
-lasGunWidePulse :: Int -> Item
+lasGunWidePulse :: Item
-lasGunWidePulse n = lasGun
+lasGunWidePulse = lasGun
-    & itName .~ "PARALELLASPULSE"++show n
+    & itName .~ "LASWIDEPULSE"
-    & itType .~ LASGUNWIDE n
+    & itType .~ LASGUNWIDEPULSE
     & itParams . lasColor .~ orange
     & itParams . lasDamage .~ 2
     & itUse .~ ( ruseInstant shootLaser NoHammer
         [ ammoCheckI
-        , withItem $ \it -> withTempLight 1 100 (xyzV4 (_lasColor $ _itParams it))
+        , withItem $ \it -> withTempLight 1 (100 * frac it) (xyzV4 (_lasColor $ _itParams it))
-        , withItem $ \it -> withMuzPos $ flareCircleAt (_lasColor $ _itParams it) 0.8
+        , withItem $ \it -> withSoundForVol (frac it) tone440sawtoothquietS 2
-        , withSoundForI tone440sawtoothquietS 2
+        , withItemUpdate itup 
+            $ \it -> withMuzPos $ flareCircleAt (_lasColor $ _itParams it) (frac it * 0.8)
         , useAmmoAmount 1
-        , duplicateOffsets xs
+        , withItemUpdate itup $ \it -> duplicateOffsets (xs it)
         ]
         & useAim . aimSpeed .~ 0.4
         & useAim . aimRange .~ 1
         & useAim . aimStance .~ TwoHandTwist
         )
   where
-    n' = 9 * n
+    itup it = it
-    xs = [ 0.25 * (fromIntegral x - fromIntegral (n'-1) /2)  | x <- [0..n'-1] ]
+        & itParams . lasCycle %~ (\i -> (i+1) `mod` 40)
+        & itParams . lasDamage .~ ceiling ((22 :: Float) * frac it)
+        & itParams . lasColor .~ frac it * orange
+    frac it = 0.5 * (1 + sin (pi * fromIntegral (_lasCycle $ _itParams it) * 0.05))
+    xs it = [ 0.25 * (fromIntegral x - fromIntegral (n'-1) /2)  | x <- [0..n'-1] ]
+      where
+        n' = (ceiling $ (150 :: Float) * frac it) :: Int
 lasGunSway :: Item
 lasGunSway = lasGun
     & itName .~ "SWAYLAS"
@@ -197,6 +207,24 @@ lasGunFocus n = lasGunWide n
   where
     n' = 9 * n
     xs = [ 0.25 * (fromIntegral x - fromIntegral (n'-1) /2)  | x <- [0..n'-1] ]
+
+lasGunDual :: Item
+lasGunDual = lasGun
+    & itName .~ "DUALAS"
+    & itType .~ LASGUNDUAL
+    & itParams . lasColor .~ red
+    & itUse .~ (ruseInstant shootDualLaser NoHammer
+        [ ammoCheckI
+        , withItem $ \it -> withTempLight 1 100 (xyzV4 (_lasColor $ _itParams it))
+        , withItem $ \it -> withMuzPos $ flareCircleAt (_lasColor $ _itParams it) 0.8
+        , withSoundForI tone440sawtoothquietS 2
+        , useAmmoAmount 1
+        ]
+        & useAim . aimSpeed .~ 0.4
+        & useAim . aimRange .~ 1
+        & useAim . aimStance .~ TwoHandTwist
+        )
+
 lasGunSwing :: Item
 lasGunSwing = lasGun
     & itName .~ "SWINGLAS"
@@ -404,6 +432,73 @@ shootLaser it cr = instantParticles .:~ lasRayAt (_lasColor $ _itParams it) dam
     phasev = _phaseV . _itParams $ _crInv cr IM.! _crInvSel cr
     dam = _lasDamage $ _itParams it
 
+shootDualLaser :: Item -> Creature -> World -> World
+shootDualLaser it cr w = w
+    & newBeams . positronBeams .:~ dualRayAt w orange dam phasev posl dirl
+    & newBeams . electronBeams .:~ dualRayAtNoFlame w blue dam phasev posr dirr
+  where 
+    dir = _crDir cr
+    pos = _crPos cr +.+ aimlength *.* unitVectorAtAngle dir
+    aimlength = aimingMuzzlePos cr it
+    posl = pos +.+ (-10) * vNormal (unitVectorAtAngle dir)
+    posr = pos +.+ 10 * vNormal (unitVectorAtAngle dir)
+    mwp = mouseWorldPos w
+    mwp' | dist mwp (_crPos cr) < aimlength + 5 = _crPos cr +.+ (aimlength + 5) *.* unitVectorAtAngle dir
+        | otherwise = mwp
+    dirl = argV $ mwp' -.- posl
+    dirr = argV $ mwp' -.- posr
+    phasev = _phaseV . _itParams $ _crInv cr IM.! _crInvSel cr
+    dam = _lasDamage $ _itParams it
+
+drawBeam :: Beam -> Picture
+drawBeam bm = setLayer 1 $ pictures
+    [ setDepth 19   . color (brightX 0 0.5 col) $ thickLine 20 ps
+    , setDepth 19.5 . color (brightX 10 1 col)  $ thickLine 3  ps
+    ]
+  where
+    col = _bmColor bm
+    ps = _bmFirstPoints bm
+    
+dualRayAt :: World -> Color -> Int -> Float -> Point2 -> Float -> Beam
+dualRayAt w col dam phasev pos dir = Beam
+    { _bmDraw = drawBeam
+    , _bmPos = pos
+    , _bmDir = dir
+    , _bmDamage = dam
+--    , _ptUpdate = mvLaser phasev pos dir
+    , _bmRange = 800
+--    , _ptDamage = dam
+    , _bmPhaseV = phasev
+    , _bmColor = col
+    , _bmPoints = pos:ps
+    , _bmFirstPoints = []
+    , _bmType = BeamCombine 
+        $ \(p,(a,b,_),(x,y,_)) -> makeFlame p (2 *.* normalizeV (normalizeV (b-.-a)+.+normalizeV (y-.-x)))
+--        $ \(p,(a,b,_),(x,y,_)) -> makeFlame p (V2 5 0)
+    }
+  where
+    (_,ps) = reflectLaserAlong phasev [] pos (pos +.+ 800 *.* unitVectorAtAngle dir) w
+--    ps = [pos,pos +.+ 800 *.* unitVectorAtAngle dir]
+dualRayAtNoFlame :: World -> Color -> Int -> Float -> Point2 -> Float -> Beam
+dualRayAtNoFlame w col dam phasev pos dir = Beam
+    { _bmDraw = drawBeam
+    , _bmPos = pos
+    , _bmDir = dir
+    , _bmDamage = dam
+--    , _ptUpdate = mvLaser phasev pos dir
+    , _bmRange = 800
+--    , _ptDamage = dam
+    , _bmPhaseV = phasev
+    , _bmColor = col
+    , _bmPoints = pos:ps
+    , _bmFirstPoints = []
+    , _bmType = BeamCombine 
+        $ \_ -> id
+--        $ \(p,(a,b,_),(x,y,_)) -> makeFlame p (V2 5 0)
+    }
+  where
+    (_,ps) = reflectLaserAlong phasev [] pos (pos +.+ 800 *.* unitVectorAtAngle dir) w
+
 lasRayAt :: Color -> Int -> Float -> Point2 -> Float -> Particle
 lasRayAt col dam phasev pos dir = LaserParticle
     { _ptDraw = const blank

src/Dodge/Item/Weapon/SprayGuns.hs

@@ -7,6 +7,7 @@ module Dodge.Item.Weapon.SprayGuns
     , flameWall
     ) where
 import Dodge.Data
+import Dodge.Particle.Flame
 --import Dodge.Data.SoundOrigin
 --import Dodge.Base
 --import Dodge.Zone
@@ -204,7 +205,8 @@ useGasParams nz it cr = _amCreateGas (_aoType (_itConsumption it)) (_nzPressure
     pos = _crPos cr +.+ (_nzLength nz *.* unitVectorAtAngle (_crDir cr))
 
 aFlame :: Float -> Point2 -> Float -> Creature -> World -> World
-aFlame pressure pos dir cr w = w & instantParticles .:~ aFlameParticle t pos vel (Just $ _crID cr)
+aFlame pressure pos dir cr = makeFlame pos vel
+    --w & instantParticles .:~ aFlameParticle t pos vel Nothing -- (Just $ _crID cr)
   where 
-    (t,_) = randomR (99,101) (_randGen w)
+--    (t,_) = randomR (99,101) (_randGen w)
     vel = (_crPos cr -.- _crOldPos cr) +.+ pressure *.* unitVectorAtAngle dir

src/Dodge/Particle/Damage.hs

@@ -1,10 +1,12 @@
 module Dodge.Particle.Damage where
 import Dodge.Data
 import Geometry
+import LensHelp
 
 import System.Random
 import Control.Monad.State
 
+-- TODO unify particle position in a sensible manner
 spawnAtBulDams :: (Point2 -> State StdGen Particle)
     -> Particle -> Point2 -> [Damage]
 spawnAtBulDams thespawn bt p =
@@ -21,7 +23,9 @@ simpleDam dt amount bt p =
     [ Damage dt amount sp p ep NoDamageEffect
     ]
   where
-    sp = head $ _ptTrail bt
+    sp = case bt ^? ptTrail of
+        Nothing -> _ptPos bt
+        Just xs -> head xs
     bulVel = _ptVel bt
     ep = sp +.+ bulVel
 

src/Dodge/Render/ShapePicture.hs

@@ -46,6 +46,8 @@ extraShapes = _foregroundShape
 extraPics :: Configuration -> World -> Picture
 extraPics cfig w = pictures (_decorations w)
     <> concatMapPic (dbArg _ptDraw) (_particles    w)
+    <> concatMapPic (dbArg _bmDraw) (_positronBeams $ _beams w)
+    <> concatMapPic (dbArg _bmDraw) (_electronBeams $ _beams w)
     <> concatMapPic (dbArg _lsPict) (_lightSources w)
     <> testPic w
     <> concatMapPic clDraw (_clouds w      )

src/Dodge/Update.hs

@@ -59,6 +59,7 @@ functionalUpdate cfig w = checkEndGame
     . dbArg _worldEvents
     . updateIMl _modifications _mdUpdate
     . updateParticles 
+    . updateBeams
     . updateIMl _props _pjUpdate  
     . updateLightSources
     . updateClouds
@@ -141,6 +142,74 @@ updateParticles :: World -> World
 updateParticles w = updateInstantParticles $ set particles (catMaybes ps) w'
   where 
     (w',ps) = mapAccumR (\a b -> _ptUpdate b a b) w $ _particles w
+updateBeams :: World -> World
+updateBeams w = w
+    & newBeams .~ WorldBeams [] [] [] []
+    & beams    .~ thebeams
+    & combineBeams thebeams
+  where
+    thebeams = _newBeams w
+
+combineBeams :: WorldBeams -> World -> World
+combineBeams wbeams w = w'' 
+    & beams . positronBeams .~ pbeams
+    & beams . electronBeams .~ ebeams
+  where
+    (w',pbeams) = mapAccumR (combineBeamBeams (_electronBeams wbeams)) w $ _positronBeams wbeams
+    (w'',ebeams) = mapAccumR (combineBeamBeams (_positronBeams wbeams)) w' $ _electronBeams wbeams
+
+combineBeamBeams :: [Beam] -> World -> Beam -> (World,Beam)
+combineBeamBeams bms w bm = case intersectBeamBeams bm bms of
+    (ps,Nothing) -> (w, bm & bmFirstPoints .~ ps)
+    (ps,Just a)  -> (_beamCombine (_bmType bm) a w, bm & bmFirstPoints .~ ps)
+
+-- intersect a beam with a list of beams.
+-- returns the (reversed) travel of the beam up to maybe an intersection point
+intersectBeamBeams :: Beam -> [Beam] 
+    -> ([Point2], Maybe (Point2,(Point2,Point2,Beam),(Point2,Point2,Beam)))
+intersectBeamBeams bm bms = f [] $ _bmPoints bm
+  where
+    f ps (x:y:ys) = case intersectSegBeams x y bms of
+        Just (z,a) -> ((z:x:ps), Just (z,(x,y,bm),a))
+        Nothing -> f (x:ps) (y:ys)
+    f ps (x:[]) = (x:ps, Nothing)
+    f _ _ = error "made an empty beam"
+
+intersectSegBeams :: Point2 -> Point2 -> [Beam] -> Maybe (Point2,(Point2,Point2,Beam))
+intersectSegBeams sp ep (bm:bms) = case intersectSegBeam sp ep bm of
+    Nothing -> intersectSegBeams sp ep bms
+    Just a@(z,_) -> maybe (Just a) Just $ intersectSegBeams sp z bms
+intersectSegBeams _ _ _ = Nothing
+
+intersectSegBeam :: Point2 -> Point2 -> Beam -> Maybe (Point2,(Point2,Point2,Beam))
+intersectSegBeam sp ep bm = case intersectSegSegs' sp ep (_bmPoints bm) of
+    Nothing -> Nothing
+    Just (z,x,y) -> Just (z,(x,y,bm))
+
+intersectSegSegs' :: Point2 -> Point2 -> [Point2] -> Maybe (Point2,Point2,Point2)
+intersectSegSegs' sp ep (x:y:ys) = case intersectSegSeg sp ep x y of
+    Just z  -> maybe (Just (z,x,y)) Just $ intersectSegSegs' sp z (y:ys)
+    Nothing -> intersectSegSegs' sp ep (y:ys)
+intersectSegSegs' _ _ _ = Nothing
+
+--intersectSegSegs :: Point2 -> Point2 -> [Point2] -> Maybe Point2
+--intersectSegSegs sp ep (x:y:ys) = case intersectSegSeg sp ep x y of
+--    Just z  -> maybe (Just z) Just $ intersectSegSegs sp z (y:ys)
+--    Nothing -> intersectSegSegs sp ep (y:ys)
+--intersectSegSegs _ _ _ = Nothing
+--
+--intersectSegSegss :: Point2 -> Point2 -> [[Point2]] -> Maybe Point2
+--intersectSegSegss sp ep (as:ass) = case intersectSegSegs sp ep as of
+--    Just z  -> maybe (Just z) Just $ intersectSegSegss sp z ass
+--    Nothing -> intersectSegSegss sp ep ass
+--intersectSegSegss _ _ _ = Nothing
+--
+--intersectSegsSegss :: [Point2] -> [[Point2]] -> Maybe Point2
+--intersectSegsSegss (x:y:ys) ass = maybe 
+--    (intersectSegsSegss (y:ys) ass)
+--    Just
+--    (intersectSegSegss x y ass)
+--intersectSegsSegss _ _ = Nothing
 
 updateInstantParticles :: World -> World
 updateInstantParticles w = case _instantParticles w of