Cleanup tesla arcs

src/Dodge/Data/Item/Params.hs

@@ -19,7 +19,7 @@ data ItemParams
     | FlatShieldParams
         {_flatShieldWlMIX :: Maybe Int}
     | Arcing
-        { _currentArc :: Maybe [ArcStep]
+        { _currentArc :: [ArcStep]
         , _arcSize :: Float
         , _arcNumber :: Int
         , _newArcStep :: NextArcStep --ItemParams -> World -> ArcStep -> State StdGen (Maybe ArcStep)

src/Dodge/Draw.hs

@@ -18,7 +18,7 @@ module Dodge.Draw (
     module Dodge.RadarSweep.Draw,
     module Dodge.Spark.Draw,
     module Dodge.Targeting.Draw,
-    module Dodge.Tesla.Arc.Draw,
+    module Dodge.Tesla.Draw,
     module Dodge.TractorBeam.Draw,
     module Dodge.Shockwave.Draw,
 ) where
@@ -40,5 +40,5 @@ import Dodge.RadarSweep.Draw
 import Dodge.Shockwave.Draw
 import Dodge.Spark.Draw
 import Dodge.Targeting.Draw
-import Dodge.Tesla.Arc.Draw
+import Dodge.Tesla.Draw
 import Dodge.TractorBeam.Draw

src/Dodge/HeldUse.hs

@@ -24,7 +24,7 @@ import Dodge.Item.Weapon.Shatter
 import Dodge.Projectile.Create
 import Dodge.RadarSweep
 import Dodge.SoundLogic
-import Dodge.Tesla.Arc
+import Dodge.Tesla
 import Geometry
 import LensHelp
 import ListHelp

src/Dodge/Item/Held/BatteryGuns.hs

@@ -5,11 +5,11 @@ module Dodge.Item.Held.BatteryGuns
     , tractorGun
     ) where
 
+import Dodge.Data.ArcStep
 import Dodge.SoundLogic.ExternallyGeneratedSounds
 import Dodge.Default.Item
 import Control.Lens
 import Dodge.Data.Item
-import Dodge.Tesla.ItemParams
 import Geometry.Data
 
 sparkGun :: Item
@@ -34,6 +34,16 @@ teslaGun =
         & itAmmoSlots .~ singleAmmo ElectricalAmmo
         & itUse . heldTriggerType .~ AutoTrigger
 
+teslaParams :: ItemParams
+teslaParams =
+    Arcing
+        { _currentArc = []
+        , _arcSize = 20
+        , _arcNumber = 10
+        , _newArcStep = DefaultArcStep --defaultArcStep
+        , _previousArcEffect = NoPreviousArcEffect
+        }
+
 -- previous phaseV parameters: 0.2, 1, 5
 laser :: Item
 laser =

src/Dodge/Render/ShapePicture.hs

@@ -133,3 +133,4 @@ mcSPic :: LWorld -> Machine -> SPic
 mcSPic lw mc =
     uncurryV translateSPxy (_mcPos mc) $
         rotateSP (_mcDir mc) (drawMachine lw mc)
+

src/Dodge/Tesla.hs

@@ -1,9 +1,162 @@
-module Dodge.Tesla 
-    ( module Dodge.Tesla.Ball
-    , module Dodge.Tesla.Arc
-    , module Dodge.Tesla.ItemParams
-    ) where
-import Dodge.Tesla.Ball
-import Dodge.Tesla.Arc
-import Dodge.Tesla.ItemParams
+module Dodge.Tesla (
+    makeTeslaArc,
+    updateTeslaArc,
+) where
 
+import Data.Foldable
+import Data.List (sortOn)
+import Data.Maybe
+import Dodge.Base.Collide
+import Dodge.Damage
+import Dodge.Data.ArcStep
+import Dodge.Data.CrWlID
+import Dodge.Data.World
+import Dodge.Spark
+import Geometry
+import qualified IntMapHelp as IM
+import LensHelp
+import MonadHelp
+import Picture
+import RandomHelp
+import Shape
+
+updateTeslaArc ::
+    World ->
+    TeslaArc ->
+    (World, Maybe TeslaArc)
+updateTeslaArc w pt
+    | _taTimer pt == 2 =
+        ( makesparks $ foldl' (flip damthings) w thearc
+        , Just $ pt & taTimer -~ 1
+        )
+    | _taTimer pt < 0 = (w, Nothing)
+    | otherwise = (w, Just $ pt & taTimer -~ 1)
+  where
+    thearc = _taArcSteps pt
+    rcol = brightX 100 1.5 <$> takeOne [white, azure, blue, cyan]
+    rspeed = state (randomR (3, 6))
+    makeaspark = randSpark ELECTRICAL rspeed rcol rdir lp
+    makesparks = makeaspark . makeaspark . makeaspark
+    rp x = randPeakedParam 2 (x - 0.7) x (x + 0.7)
+    (lp, rdir) = case last thearc of
+        ArcStep lp' ld' NothingID -> (lp', rp ld')
+        ArcStep lp' ld' (CrID crid) -> case w ^? cWorld . lWorld . creatures . ix crid of
+            Nothing -> (lp', rp ld')
+            Just cr -> (lp' -.- (_crRad cr + 1) *.* unitVectorAtAngle ld', rp $ ld' + pi)
+        ArcStep lp' ld' (WlID wlid) -> case w ^? cWorld . lWorld . walls . ix wlid of
+            Nothing -> (lp', rp ld')
+            Just wl ->
+                ( lp' -.- 2 *.* unitVectorAtAngle ld'
+                , randWallReflect ld' wl
+                )
+    damthings (ArcStep p dir crwl) = damageCrWlID (thedamage p dir) crwl
+    thedamage p dir = Damage ELECTRICAL 50 (p -.- q) p (p +.+ q) NoDamageEffect
+      where
+        q = 5 *.* unitVectorAtAngle dir
+
+randWallReflect :: RandomGen g => Float -> Wall -> State g Float
+randWallReflect a wl = do
+    let (x, y) = _wlLine wl
+        outa = reflectAngle a x y
+        a1 = nearestAngleRep outa $ argV (x - y)
+        a2 = if a1 < outa then a1 + pi else a1 - pi
+    randPeaked a1 outa a2
+
+makeTeslaArc :: ItemParams -> Point2 -> Float -> World -> (World, ItemParams)
+makeTeslaArc ip pos dir w =
+    ( w & randGen .~ g
+        & cWorld . lWorld . teslaArcs
+            .:~ TeslaArc
+                { _taPoints = map (^. asPos) newarc
+                , _taArcSteps = newarc
+                , _taTimer = 2
+                , _taColor = brightX 100 1.5 col
+                }
+    , ip & currentArc .~ newarc
+    )
+  where
+    (col, g) = takeOne [white, azure, blue, cyan] & runState $ _randGen w
+    newarc = updateArc ip w pos dir & evalState $ _randGen w
+
+createNewArc ::
+    ItemParams ->
+    World ->
+    Point2 ->
+    Float ->
+    State StdGen [ArcStep]
+createNewArc arcparams w p dir =
+    take (_arcNumber arcparams)
+        <$> unfoldrMID (doArcStep (_newArcStep arcparams) arcparams w) (ArcStep p dir NothingID)
+
+updateArc ::
+    ItemParams ->
+    World ->
+    Point2 ->
+    Float ->
+    State StdGen [ArcStep]
+updateArc ip w p dir = take (_arcNumber ip) <$> zipArcs ip w (ArcStep p dir NothingID) carc
+  where
+    carc = case _currentArc ip of
+        (_:xs) -> xs
+        [] -> [] -- tail $ _currentArc ip
+
+zipArcs ::
+    ItemParams ->
+    World ->
+    ArcStep ->
+    [ArcStep] ->
+    State StdGen [ArcStep]
+zipArcs ip w x (y : ys) =
+    (x :) <$> do
+        defaultnext <- doArcStep (_newArcStep ip) ip w x
+        case defaultnext of
+            Nothing -> return []
+            Just z@(ArcStep _ _ (CrID _)) -> return [z]
+            Just z@(ArcStep _ _ (WlID _)) -> 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)
+
+doArcStep :: NextArcStep -> ItemParams -> World -> ArcStep -> State StdGen (Maybe ArcStep)
+doArcStep nas = case nas of
+    DefaultArcStep -> defaultArcStep
+    EndArc -> const $ const $ const $ return Nothing
+
+defaultArcStep ::
+    RandomGen g =>
+    ItemParams ->
+    World ->
+    ArcStep ->
+    State g (Maybe ArcStep)
+defaultArcStep _ _ (ArcStep _ _ (CrID _)) = return Nothing
+defaultArcStep _ _ (ArcStep _ _ (WlID _)) = 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
+                $ w ^. cWorld . lWorld . creatures --_creatures (_cWorld w)
+        mwl =
+            listToMaybe
+                . sortOn (dist p . fst)
+                . mapMaybe (\q -> sequence $ collidePointWallsFilter (const True) p (center +.+ q) w)
+                -- collidePointWallsWall and wlsnearpoint
+                $ polyCirc 6 csize
+        f (q, wl) = ArcStep q dir (WlID $ _wlID wl)
+        g cr = ArcStep (_crPos cr +.+ csize *.* unitVectorAtAngle dir) dir (CrID $ _crID cr)
+    return . listToMaybe . sortOn (dist p . (^. asPos)) $
+        ArcStep newp dir NothingID : catMaybes [fmap f mwl, fmap g mcr]

src/Dodge/Tesla/Arc.hs

@@ -1,169 +0,0 @@
-module Dodge.Tesla.Arc (
-    makeTeslaArc,
-    updateTeslaArc,
-) where
-
-import Data.Foldable
-import Data.List (sortOn)
-import Data.Maybe
-import Dodge.Base.Collide
-import Dodge.Damage
-import Dodge.Data.ArcStep
-import Dodge.Data.CrWlID
-import Dodge.Data.World
-import Dodge.Spark
-import Geometry
-import qualified IntMapHelp as IM
-import LensHelp
-import MonadHelp
-import Picture
-import RandomHelp
-import Shape
-
-updateTeslaArc ::
-    World ->
-    TeslaArc ->
-    (World, Maybe TeslaArc)
-updateTeslaArc w pt
-    | _taTimer pt == 2 =
-        ( makesparks $ foldl' (flip damthings) w thearc
-        , Just $ pt & taTimer -~ 1
-        )
-    | _taTimer pt < 1 = (w, Nothing)
-    | otherwise = (w, Just $ pt & taTimer -~ 1)
-  where
-    thearc = _taArcSteps pt
-    rcol = brightX 100 1.5 <$> takeOne [white, azure, blue, cyan]
-    rspeed = state (randomR (3, 6))
-    makeaspark = randSpark ELECTRICAL rspeed rcol rdir lp
-    makesparks = makeaspark . makeaspark . makeaspark
-    rp x = randPeakedParam 2 (x - 0.7) x (x + 0.7)
-    (lp, rdir) = case last thearc of
-        ArcStep lp' ld' NothingID -> (lp', rp ld')
-        ArcStep lp' ld' (CrID crid) -> case w ^? cWorld . lWorld . creatures . ix crid of
-            Nothing -> (lp', rp ld')
-            Just cr -> (lp' -.- (_crRad cr + 1) *.* unitVectorAtAngle ld', rp $ ld' + pi)
-        ArcStep lp' ld' (WlID wlid) -> case w ^? cWorld . lWorld . walls . ix wlid of
-            Nothing -> (lp', rp ld')
-            Just wl ->
-                ( lp' -.- 2 *.* unitVectorAtAngle ld'
-                , randWallReflect ld' wl
-                )
-    damthings (ArcStep p dir crwl) = damageCrWlID (thedamage p dir) crwl
-    thedamage p dir = Damage ELECTRICAL 50 (p -.- q) p (p +.+ q) NoDamageEffect
-      where
-        q = 5 *.* unitVectorAtAngle dir
-
-randWallReflect :: RandomGen g => Float -> Wall -> State g Float
-randWallReflect a wl = do
-    let (x, y) = _wlLine wl
-        outa = reflectAngle a x y
-        a1 = nearestAngleRep outa $ argV (x - y)
-        a2 = if a1 < outa then a1 + pi else a1 - pi
-    randPeaked a1 outa a2
-
-makeTeslaArc :: ItemParams -> Point2 -> Float -> World -> (World, ItemParams)
-makeTeslaArc ip pos dir w =
-    ( w & randGen .~ g
-        & cWorld . lWorld . teslaArcs
-            .:~ TeslaArc
-                { _taPoints = map (^. asPos) newarc
-                , _taArcSteps = newarc
-                , _taTimer = 2
-                , _taColor = brightX 100 1.5 col
-                }
-    , 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 (doArcStep (_newArcStep arcparams) arcparams w) (ArcStep p dir NothingID)
-
-updateArc ::
-    ItemParams ->
-    World ->
-    Point2 ->
-    Float ->
-    State StdGen [ArcStep]
-updateArc ip w p dir = take (_arcNumber ip) <$> zipArcs ip w (ArcStep p dir NothingID) carc
-  where
-    carc = tail $ fromJust $ _currentArc ip
-
-zipArcs ::
-    ItemParams ->
-    World ->
-    ArcStep ->
-    [ArcStep] ->
-    State StdGen [ArcStep]
-zipArcs ip w x (y : ys) =
-    (x :) <$> do
-        defaultnext <- doArcStep (_newArcStep ip) ip w x
-        case defaultnext of
-            Nothing -> return []
-            Just z@(ArcStep _ _ (CrID _)) -> return [z]
-            Just z@(ArcStep _ _ (WlID _)) -> 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)
-
-doArcStep :: NextArcStep -> ItemParams -> World -> ArcStep -> State StdGen (Maybe ArcStep)
-doArcStep nas = case nas of
-    DefaultArcStep -> defaultArcStep
-    EndArc -> const $ const $ const $ return Nothing
-
-defaultArcStep ::
-    RandomGen g =>
-    ItemParams ->
-    World ->
-    ArcStep ->
-    State g (Maybe ArcStep)
-defaultArcStep _ _ (ArcStep _ _ (CrID _)) = return Nothing
-defaultArcStep _ _ (ArcStep _ _ (WlID _)) = 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
-                $ w ^. cWorld . lWorld . creatures --_creatures (_cWorld w)
-        mwl =
-            listToMaybe
-                . sortOn (dist p . fst)
-                . mapMaybe (\q -> sequence $ collidePointWallsFilter (const True) p (center +.+ q) w)
-                -- collidePointWallsWall and wlsnearpoint
-                $ polyCirc 6 csize
-        f (q, wl) = ArcStep q dir (WlID $ _wlID wl)
-        g cr = ArcStep (_crPos cr +.+ csize *.* unitVectorAtAngle dir) dir (CrID $ _crID cr)
-    return . listToMaybe . sortOn (dist p . (^. asPos)) $
-        ArcStep newp dir NothingID : catMaybes [fmap f mwl, fmap g mcr]

src/Dodge/Tesla/Arc/Draw.hs

@@ -1,15 +0,0 @@
-module Dodge.Tesla.Arc.Draw where
-
-import Dodge.Data.TeslaArc
-import Geometry
-import Picture
-
-drawTeslaArc :: TeslaArc -> Picture
-drawTeslaArc pt =
-    setLayer BloomNoZWrite $
-        fold
-            [ setDepth 20.5 $ color (brightX 2 1 $ _taColor pt) $ thickLine 3 ps
-            , setDepth 20 $ color (V4 0 0 0 0.5) $ thickLine 10 ps
-            ]
-  where
-    ps = _taPoints pt

src/Dodge/Tesla/Ball.hs

@@ -1,7 +0,0 @@
-module Dodge.Tesla.Ball where
-
-import Dodge.Data.World
-import Geometry
-
-makeTeslaBallAt :: Point2 -> World -> World
-makeTeslaBallAt _ = id

src/Dodge/Tesla/ItemParams.hs

@@ -1,14 +0,0 @@
-module Dodge.Tesla.ItemParams where
-
-import Dodge.Data.ArcStep
-import Dodge.Data.Item.Params
-
-teslaParams :: ItemParams
-teslaParams =
-    Arcing
-        { _currentArc = Nothing
-        , _arcSize = 20
-        , _arcNumber = 10
-        , _newArcStep = DefaultArcStep --defaultArcStep
-        , _previousArcEffect = NoPreviousArcEffect
-        }

src/Dodge/Update.hs

@@ -47,7 +47,7 @@ import Dodge.SmoothScroll
 import Dodge.SoundLogic
 import Dodge.Spark
 import Dodge.Terminal.Type
-import Dodge.Tesla.Arc
+import Dodge.Tesla
 import Dodge.TmTm
 import Dodge.TractorBeam.Update
 import Dodge.Update.Camera