Play around with tesla arcs
This commit is contained in:
+99
-128
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user