Play around with tesla arcs

2025-01-16 12:18:25 +00:00
parent 5fb71cec39
commit 881b866ed2
11 changed files with 227 additions and 230 deletions
@@ -18,11 +18,10 @@ data ArcStep = ArcStep
    }
    deriving (Eq, Ord, Show, Read) --Generic, Flat)

-data NextArcStep
-    = EndArc
-    | DefaultArcStep
-    deriving (Eq, Ord, Show, Read) --Generic, Flat)
+--data NextArcStep
+--    = DefaultArcStep
+--    deriving (Eq, Ord, Show, Read) --Generic, Flat)

 makeLenses ''ArcStep
 deriveJSON defaultOptions ''ArcStep
-deriveJSON defaultOptions ''NextArcStep
+--deriveJSON defaultOptions ''NextArcStep
@@ -12,37 +12,17 @@ import Dodge.Data.ArcStep

 data ItemParams
    = NoParams
--    | MagShieldParams
--        {_magShieldMgMIX :: Maybe Int}
    | FlatShieldParams
        {_flatShieldWlMIX :: Maybe Int}
    | Arcing
        { _currentArc :: [ArcStep]
-        , _arcSize :: Float
-        , _arcNumber :: Int
-        , _newArcStep :: NextArcStep --ItemParams -> World -> ArcStep -> State StdGen (Maybe ArcStep)
-        , _previousArcEffect :: PreviousArcEffect
+--        , _arcSize :: Float
+--        , _arcNumber :: Int
        }

 data ShrinkGunStatus = FullSize | Shrunk
    --deriving (Eq, Ord, Show, Read) --Generic, Flat)

-data PreviousArcEffect = NoPreviousArcEffect | PerturbTillBreakPreviousArc
-    --deriving (Eq, Ord, Show, Read) --Generic, Flat)
-
--data GunBarrels
----    = MultiBarrel
----        { _brlSpread :: BarrelSpread
----        , _brlNum :: Int
----        , _brlInaccuracy :: Float
----        }
--    = BarrelList 
--        { _brlList :: [GunBarrel]
--        }
-    --deriving (Eq, Ord, Show, Read) --Generic, Flat)
-
-
 makeLenses ''ItemParams
 deriveJSON defaultOptions ''ShrinkGunStatus
-deriveJSON defaultOptions ''PreviousArcEffect
 deriveJSON defaultOptions ''ItemParams
@@ -1,19 +1,20 @@
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}

-module Dodge.Data.TeslaArc where
+module Dodge.Data.TeslaArc (
+    module Dodge.Data.TeslaArc,
+    module Dodge.Data.ArcStep,
+) where

 import Color
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
 import Dodge.Data.ArcStep
--import Geometry.Data

 data TeslaArc = TeslaArc
--    { _taPoints :: [Point2]
    { _taTimer :: Int
    , _taArcSteps :: [ArcStep]
    , _taColor :: Color
@@ -1,27 +1,26 @@
-module Dodge.Item.Held.BatteryGuns 
-    ( sparkGun
-    , teslaGun
-    , laser
-    , tractorGun
-    ) where
+module Dodge.Item.Held.BatteryGuns (
+    sparkGun,
+    teslaGun,
+    laser,
+    tractorGun,
+) where

-import Dodge.Data.ArcStep
-import Dodge.SoundLogic.ExternallyGeneratedSounds
-import Dodge.Default.Item
 import Control.Lens
 import Dodge.Data.Item
+import Dodge.Default.Item
+import Dodge.SoundLogic.ExternallyGeneratedSounds
 import Geometry.Data

 sparkGun :: Item
 sparkGun =
    teslaGun
        & itType .~ HELD SPARKGUN
-        & itParams . arcSize .~ 10
+--        & itParams . arcSize .~ 10

 teslaGun :: Item
 teslaGun =
    defaultHeldItem
-        & itUse . heldParams .~ BeamShooterParams (Just (elecCrackleS,2))
+        & itUse . heldParams .~ BeamShooterParams (Just (elecCrackleS, 2))
        & itParams .~ teslaParams
        & itUse . heldDelay .~ NoDelay
        & itUse . heldAim . aimWeight .~ 6
@@ -38,17 +37,15 @@ teslaParams :: ItemParams
 teslaParams =
    Arcing
        { _currentArc = []
-        , _arcSize = 20
-        , _arcNumber = 10
-        , _newArcStep = DefaultArcStep --defaultArcStep
-        , _previousArcEffect = NoPreviousArcEffect
+--        , _arcSize = 20
+--        , _arcNumber = 10
        }

 -- previous phaseV parameters: 0.2, 1, 5
 laser :: Item
 laser =
    defaultHeldItem
-        & itUse . heldParams .~ BeamShooterParams (Just (tone440sawtoothquietS,2))
+        & itUse . heldParams .~ BeamShooterParams (Just (tone440sawtoothquietS, 2))
        & itAmmoSlots .~ singleAmmo ElectricalAmmo
        & itUse . heldDelay .~ NoDelay
        & itUse . heldTriggerType .~ AutoTrigger
@@ -56,11 +53,12 @@ laser =
        & itUse . heldAim . aimMuzzles . ix 0 . mzInaccuracy .~ 0
        & itUse . heldAim . aimMuzzles . ix 0 . mzFlareType .~ LasGunFlare
        & itUse . heldAim . aimMuzzles . ix 0 . mzEffect .~ MuzzleLaser
-        & itTargeting .~ ItTargeting
-            { _itTgPos = Nothing 
-            , _itTgID = Nothing 
-            , _itTgActive = False
-            }
+        & itTargeting
+            .~ ItTargeting
+                { _itTgPos = Nothing
+                , _itTgID = Nothing
+                , _itTgActive = False
+                }
        & itUse . heldAim . aimWeight .~ 6
        & itUse . heldAim . aimRange .~ 1
        & itUse . heldAim . aimStance .~ TwoHandFlat
@@ -70,7 +68,7 @@ laser =
 tractorGun :: Item
 tractorGun =
    defaultHeldItem
-        & itUse . heldParams .~ BeamShooterParams (Just (tone440sawtoothquietS,2))
+        & itUse . heldParams .~ BeamShooterParams (Just (tone440sawtoothquietS, 2))
        & itAmmoSlots .~ singleAmmo ElectricalAmmo
        & itUse . heldTriggerType .~ AutoTrigger
        & itUse . heldAim . aimMuzzles . ix 0 . mzPos .~ V2 30 0
@@ -1,4 +1,7 @@
-module Dodge.Randify where
+module Dodge.Randify (
+    gRandify,
+    runStateWorld,
+) where

 import Control.Lens
 import Control.Monad.State
@@ -9,3 +12,9 @@ gRandify :: GenWorld -> State StdGen GenWorld -> GenWorld
 gRandify gw mw =
    let (gw', g) = runState mw (_randGen $ _gwWorld gw)
     in gw' & gwWorld . randGen .~ g
+
+-- this can possibly be done using zoom in a clever way
+runStateWorld :: World -> State StdGen World -> World
+runStateWorld gw mw =
+    let (gw', g) = runState mw (_randGen gw)
+     in gw' & randGen .~ g
@@ -1,73 +1,34 @@
 module Dodge.Tesla (
    makeTeslaArc,
-    updateTeslaArc,
+--    updateTeslaArc,
 ) where

-import Data.Foldable
-import Data.List (sortOn)
+import Dodge.Movement.Turn
+import Control.Monad
+import Dodge.WorldEvent.ThingsHit
+--import Control.Applicative
+--import Data.Foldable
+--import Data.List (uncons) --(sortOn)
 import Data.Maybe
-import Dodge.Base.Collide
-import Dodge.Damage
+--import Dodge.Base.Collide
+--import Dodge.Damage
 import Dodge.Data.ArcStep
 import Dodge.Data.CrWlID
 import Dodge.Data.World
-import Dodge.Spark
+--import Dodge.Spark
 import Geometry
-import qualified IntMapHelp as IM
+--import qualified IntMapHelp as IM
 import LensHelp
-import MonadHelp
+--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, Just $ pt & taTimer -~ 1)
-    | otherwise = (w, Nothing)
-  where
-    thearc = _taArcSteps pt
-    makeaspark =
-        randSpark
-            ELECTRICAL
-            (state (randomR (3, 6)))
-            (brightX 100 1.5 <$> takeOne [white, azure, blue, cyan])
-            rdir
-            lp
-    makesparks = makeaspark . makeaspark . makeaspark
-    rp x = randPeakedParam 2 (x - 0.7) x (x + 0.7)
-    (lp, rdir)
-        | ArcStep lp' ld' (CrID crid) <- last thearc
-          , Just cr <- w ^? cWorld . lWorld . creatures . ix crid =
-            (lp' -.- (_crRad cr + 1) *.* unitVectorAtAngle ld', rp $ ld' + pi)
-        | ArcStep lp' ld' (WlID wlid) <- last thearc
-          , Just wl <- w ^? cWorld . lWorld . walls . ix wlid =
-            ( lp' -.- 2 *.* unitVectorAtAngle ld'
-            , randWallReflect ld' wl
-            )
-        | ArcStep lp' ld' _ <- last thearc = (lp', rp ld')
-    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
+--import Shape

 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
@@ -78,85 +39,95 @@ makeTeslaArc ip pos dir w =
    (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
+updateArc :: ItemParams -> World -> Point2 -> Float -> State StdGen [ArcStep]
+updateArc ip w p dir = take 10 <$> zipArcs dir 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)
+zipArcs :: Float -> World -> ArcStep -> [ArcStep] -> State StdGen [ArcStep]
+zipArcs d w x ys = (x:) <$> do
+    let mys = uncons ys
+    na <- nextArc d w x (fmap fst mys)
+    case na of
+        Just a -> zipArcs d w a (join $ maybeToList (fmap snd mys))
+        Nothing -> return []

-doArcStep :: NextArcStep -> ItemParams -> World -> ArcStep -> State StdGen (Maybe ArcStep)
-doArcStep nas = case nas of
-    DefaultArcStep -> defaultArcStep
-    EndArc -> const $ const $ const $ return Nothing
+nextArc :: Float -> World -> ArcStep -> Maybe ArcStep -> State StdGen (Maybe ArcStep)
+nextArc _ w lastarc mx
+    | ArcStep p d NothingID <- lastarc = do
+        offset <- randInCirc 5
+        let pdir = 20 * unitVectorAtAngle d
+            (dout,pout) = fromMaybe (d,pdir) $ do
+                p' <- mx ^? _Just . asPos
+                let d' = turnTo 0.5 p p' d
+                return $ (d', vecTurnTo 0.5 p p' pdir)
+            newp = p + pout + offset
+        return $ case thingHit p newp w of
+            Nothing -> Just $ ArcStep newp dout NothingID
+            Just (p', Left cr) -> Just $ ArcStep p' dout (CrID (_crID cr))
+            Just (p', Right wl) -> Just $ ArcStep p' dout (WlID (_wlID wl))
+    | otherwise = 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]
+--nextArc :: Float -> World -> ArcStep -> Maybe ArcStep -> State StdGen (Maybe ArcStep)
+--nextArc d w lastarc mx
+--    | ArcStep p d NothingID <- lastarc = do
+--        newp' <- ((p + (20 *.* unitVectorAtAngle d)) +) <$> randInCirc 10
+--        x <- state $ randomR (0,1::Float)
+--        let newp = fromMaybe newp' $ do
+--                p' <- mx ^? _Just . asPos
+--                thit <- mx ^? _Just . asObject
+--                return $ if x > 0.3 || thit /= NothingID then alongSegBy 20 p p' else newp'
+--        return $ case thingHit p newp w of
+--            Nothing -> Just $ ArcStep newp d NothingID
+--            Just (p', Left cr) -> Just $ ArcStep p' d (CrID (_crID cr))
+--            Just (p', Right wl) -> Just $ ArcStep p' d (WlID (_wlID wl))
+--    | otherwise = return Nothing
+
+--zipArcs' :: World -> ArcStep -> [ArcStep] -> State StdGen [ArcStep]
+--zipArcs' w x (y : ys) =
+--    (x :) <$> do
+--        defaultnext <- defaultArcStep 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 = 20
+--                    center = _asPos x +.+ csize *.* unitVectorAtAngle (_asDir x)
+--                    newp = _asPos y +.+ p
+--                    newdir = _asDir x
+--                if dist newp center < csize
+--                    then zipArcs w (y & asPos .~ newp & asDir .~ newdir) ys
+--                    else zipArcs w z ys
+--zipArcs' w y _ = createNewArc w (_asPos y) (_asDir y)
+
+--createNewArc :: World -> Point2 -> Float -> State StdGen [ArcStep]
+--createNewArc w p dir = take 10 <$> unfoldrMID (defaultArcStep w) (ArcStep p dir NothingID)
+--
+--defaultArcStep :: RandomGen g => World -> ArcStep -> State g (Maybe ArcStep)
+--defaultArcStep w (ArcStep p dir NothingID) = do
+--    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)
+--                $ 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]
+--    return $ fmap g mcr <|> (listToMaybe . sortOn (dist p . (^. asPos)) $
+--        ArcStep newp dir NothingID : catMaybes [fmap f mwl])
+--  where
+--    csize = 20
+--    center = (20 *.* unitVectorAtAngle dir) +.+ p
+--defaultArcStep _ _ = return Nothing
@@ -4,7 +4,6 @@ module Dodge.Tesla.Draw (

 import Picture.Base
 import Dodge.Data.TeslaArc
-import Dodge.Data.ArcStep
 import Control.Lens

 drawTeslaArc :: TeslaArc -> Picture
@@ -26,7 +26,8 @@ import qualified IntMapHelp as IM
 import qualified Data.Map.Strict as M

 testStringInit :: Universe -> [String]
-testStringInit u = prettyShort $ M.elems $ u ^. uvWorld . input . pressedKeys
+testStringInit u = prettyShort 
+    $ u ^.. uvWorld . cWorld . lWorld . teslaArcs . ix 0 . taArcSteps . each . asObject
 --testStringInit u = foldMap prettyShort $ u ^. uvWorld . cWorld . lWorld . projectiles
 --    (map (show . _ebPos) $ u ^. uvWorld . cWorld . lWorld . energyBalls)
 --    <>
@@ -7,6 +7,9 @@ Description : Simulation update
 -}
 module Dodge.Update (updateUniverse) where

+import Dodge.Damage
+import RandomHelp
+import Dodge.Data.CrWlID
 import Dodge.ListDisplayParams
 import Color
 import Control.Applicative
@@ -46,7 +49,6 @@ import Dodge.SmoothScroll
 import Dodge.SoundLogic
 import Dodge.Spark
 import Dodge.Terminal.Type
-import Dodge.Tesla
 import Dodge.TmTm
 import Dodge.TractorBeam.Update
 import Dodge.Update.Camera
@@ -530,6 +532,49 @@ updateBullets w = w' & cWorld . lWorld . bullets <>~ catMaybes ps
 updateTeslaArcs :: World -> World
 updateTeslaArcs = updateObjCatMaybes teslaArcs updateTeslaArc

+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, Just $ pt & taTimer -~ 1)
+    | otherwise = (w, Nothing)
+  where
+    thearc = _taArcSteps pt
+    makeaspark =
+        randSpark
+            ELECTRICAL
+            (state (randomR (3, 6)))
+            (brightX 100 1.5 <$> takeOne [white, azure, blue, cyan])
+            rdir
+            lp
+    makesparks = makeaspark . makeaspark . makeaspark
+    rp x = randPeakedParam 2 (x - 0.7) x (x + 0.7)
+    (lp, rdir)
+        | ArcStep lp' ld' (CrID crid) <- last thearc
+          , Just cr <- w ^? cWorld . lWorld . creatures . ix crid =
+            (lp' -.- (_crRad cr + 1) *.* unitVectorAtAngle ld', rp $ ld' + pi)
+        | ArcStep lp' ld' (WlID wlid) <- last thearc
+          , Just wl <- w ^? cWorld . lWorld . walls . ix wlid =
+            ( lp' -.- 2 *.* unitVectorAtAngle ld'
+            , randWallReflect ld' wl
+            )
+        | ArcStep lp' ld' _ <- last thearc = (lp', rp ld')
+    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 = randPeaked a1 outa a2
+  where
+    (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
+
+
 updateTractorBeams :: World -> World
 updateTractorBeams = updateObjCatMaybes tractorBeams updateTractorBeam

@@ -137,3 +137,8 @@ randPeakedParam i a b c = do

 randPeaked :: RandomGen g => Float -> Float -> Float -> State g Float
 randPeaked = randPeakedParam 3
+
+randFromPair :: RandomGen g => Float -> (a,a) -> State g a
+randFromPair x (l,r) = do
+    y <- state $ randomR (0,1)
+    if x < y then return l else return r