Move flame into its own datatype

2022-07-18 22:41:40 +01:00
parent c14b3ff787
commit 54ba0fbedc
29 changed files with 444 additions and 318 deletions
@@ -0,0 +1,118 @@
+module Dodge.Tesla.Arc
+    where
+import Dodge.Data
+import Dodge.Damage
+import Dodge.Spark
+import RandomHelp
+import Picture
+import Geometry
+import LensHelp
+--import Dodge.Data
+--import Geometry
+--import LensHelp
+--import RandomHelp
+--import Color
+--import Dodge.Item.Location
+--import Dodge.WorldEvent.Damage
+--import Dodge.WorldEvent.ThingsHit
+--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 qualified Data.IntMap.Strict as IM
+--import Data.List (sortOn)
+import MonadHelp
+import Data.Maybe
+--import qualified Data.IntMap.Strict as IM
+
+aTeslaArcAt :: Color -> [ArcStep] -> Particle
+aTeslaArcAt col thearc = PtTeslaArc
+    { _ptPoints = map (^. asPos) thearc
+    , _ptUpdate = moveTeslaArc thearc
+    , _ptTimer = 2
+    , _ptColor = brightX 100 1.5 col
+    }
+
+moveTeslaArc :: [ArcStep]
+    -> World
+    -> Particle
+    -> (World,Maybe Particle)
+moveTeslaArc thearc w pt
+    | _ptTimer pt == 2  = (makesparks $ foldr damthings w thearc, Just $ pt & ptTimer -~ 1)
+    | _ptTimer pt < 1   = (w, Nothing)
+    | otherwise         = (w, Just $ pt & ptTimer -~ 1)
+  where
+    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
+    (lp,ld) = case last thearc of
+        ArcStep lp' ld' Nothing -> (lp',ld')
+        ArcStep lp' ld' (Just (Left cr)) -> (lp' -.- (_crRad cr + 1) *.* unitVectorAtAngle ld',ld'+pi)
+        ArcStep lp' ld' (Just (Right _)) -> (lp' -.- 2 *.* unitVectorAtAngle ld',ld'+pi)
+    damthings (ArcStep _ _ Nothing) = id
+    damthings (ArcStep p dir (Just crwl)) = damageCrWall (thedamage p dir) crwl
+    thedamage p dir = Damage ELECTRICAL 50 (p -.- q) p (p +.+ q) NoDamageEffect
+      where
+        q = 5 *.* unitVectorAtAngle dir
+
+shootTeslaArc' :: ItemParams -> Point2 -> Float -> World -> (World,ItemParams)
+shootTeslaArc' ip pos dir w = 
+    (w & randGen .~ g
+       & instantParticles .:~ aTeslaArcAt col newarc
+    , 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 (_newArcStep arcparams arcparams w) (ArcStep p dir Nothing)
+
+updateArc :: ItemParams
+    -> World
+    -> Point2
+    -> Float
+    -> State StdGen [ArcStep]
+updateArc ip w p dir = take (_arcNumber ip) <$> zipArcs ip w (ArcStep p dir Nothing) carc
+  where
+    carc = tail $ fromJust $ _currentArc ip
+
+zipArcs :: ItemParams
+    -> World
+    -> ArcStep
+    -> [ArcStep]
+    -> State StdGen [ArcStep]
+zipArcs ip w x (y:ys) = (x :) <$> do  
+    defaultnext <- _newArcStep ip ip w x
+    case defaultnext of
+        Nothing -> return []
+        Just z@(ArcStep _ _ (Just _)) -> 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)