Cleanup tesla arcs

2024-12-22 14:50:08 +00:00
parent acba8de359
commit 632deb7486
4 changed files with 69 additions and 87 deletions
@@ -1,12 +0,0 @@
-module Dodge.ArcStep where
-
-import Control.Monad.State
-import Dodge.Data.ArcStep
-import Dodge.Data.World
-import Dodge.Tesla.Arc.Default
-import System.Random
-
-doStep :: NextArcStep -> ItemParams -> World -> ArcStep -> State StdGen (Maybe ArcStep)
-doStep nas = case nas of
-    DefaultArcStep -> defaultArcStep
-    EndArc -> const $ const $ const $ return Nothing
@@ -4,45 +4,40 @@ module Dodge.Tesla.Arc (
 ) where

 import Data.Foldable
+import Data.List (sortOn)
 import Data.Maybe
-import Dodge.ArcStep
+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
-
-aTeslaArcAt :: Color -> [ArcStep] -> TeslaArc
-aTeslaArcAt col thearc =
-    TeslaArc
-        { _taPoints = map (^. asPos) thearc
-        , _taArcSteps = thearc
-        , _taTimer = 2
-        , _taColor = brightX 100 1.5 col
-        }
+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 == 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]
--    rdir = state (randomR (-0.7, 0.7)) <&> (+ ld)
    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)
+    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
@@ -50,10 +45,10 @@ updateTeslaArc w pt
            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 _ -> (lp' -.- 2 *.* unitVectorAtAngle ld', ld' + pi)
-            Just wl -> (lp' -.- 2 *.* unitVectorAtAngle ld'
--                , uncurry (reflectAngle ld') (_wlLine wl))
-                , randWallReflect ld' wl)
+            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
@@ -61,16 +56,22 @@ updateTeslaArc w pt

 randWallReflect :: RandomGen g => Float -> Wall -> State g Float
 randWallReflect a wl = do
-    let (x,y) = _wlLine wl
+    let (x, y) = _wlLine wl
        outa = reflectAngle a x y
-        a1 = nearestAngleRep outa $ argV (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 .:~ aTeslaArcAt col newarc
+        & cWorld . lWorld . teslaArcs
+            .:~ TeslaArc
+                { _taPoints = map (^. asPos) newarc
+                , _taArcSteps = newarc
+                , _taTimer = 2
+                , _taColor = brightX 100 1.5 col
+                }
    , ip & currentArc ?~ newarc
    )
  where
@@ -94,7 +95,7 @@ createNewArc ::
    State StdGen [ArcStep]
 createNewArc arcparams w p dir =
    take (_arcNumber arcparams)
-        <$> unfoldrMID (doStep (_newArcStep arcparams) arcparams w) (ArcStep p dir NothingID)
+        <$> unfoldrMID (doArcStep (_newArcStep arcparams) arcparams w) (ArcStep p dir NothingID)

 updateArc ::
    ItemParams ->
@@ -114,7 +115,7 @@ zipArcs ::
    State StdGen [ArcStep]
 zipArcs ip w x (y : ys) =
    (x :) <$> do
-        defaultnext <- doStep (_newArcStep ip) ip w x
+        defaultnext <- doArcStep (_newArcStep ip) ip w x
        case defaultnext of
            Nothing -> return []
            Just z@(ArcStep _ _ (CrID _)) -> return [z]
@@ -130,3 +131,39 @@ zipArcs ip w x (y : ys) =
                    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]
@@ -1,44 +0,0 @@
-module Dodge.Tesla.Arc.Default where
-
-import Dodge.Data.CrWlID
-import Data.List (sortOn)
-import Data.Maybe
-import Dodge.Base.Collide
-import Dodge.Data.ArcStep
-import Dodge.Data.World
-import Geometry
-import qualified IntMapHelp as IM
-import LensHelp
-import RandomHelp
-import Shape
-
-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]