220 lines
8.2 KiB
Haskell
220 lines
8.2 KiB
Haskell
module Dodge.Bullet
|
|
( updateBullet
|
|
, useAmmoParams
|
|
) where
|
|
import Dodge.WorldEvent.SpawnParticle
|
|
import Dodge.Creature.Test
|
|
import Dodge.Data
|
|
import Dodge.Creature.HandPos
|
|
import Dodge.Base.Coordinate
|
|
import Geometry
|
|
import LensHelp
|
|
import StreamingHelp
|
|
|
|
import qualified Data.IntMap.Strict as IM
|
|
import qualified Streaming.Prelude as S
|
|
import Data.Maybe
|
|
import Dodge.Movement.Turn
|
|
import Dodge.WorldEvent.ThingsHit
|
|
import Control.Monad.State
|
|
import System.Random
|
|
--import Data.Bifunctor
|
|
|
|
updateBullet :: World -> Bullet -> (World,Maybe Bullet)
|
|
updateBullet w bu = case _buState bu of
|
|
DyingBulletState -> (w,Nothing)
|
|
DelayedBullet x -> mvBulletSlow x w bu
|
|
_ -> mvBullet w bu
|
|
|
|
useAmmoParams :: Maybe Float -> Item -> Creature -> World -> World
|
|
useAmmoParams vfact it cr w = w & instantBullets .:~ (_amBullet bultype
|
|
& buPos .~ sp
|
|
& buTrajectory %~ settrajectory
|
|
& buVel %~ (rotateV dir . (muzvel *.*))
|
|
& buDrag *~ _rifling (_itParams it)
|
|
& buState %~ setstate
|
|
)
|
|
where
|
|
setstate = case vfact of
|
|
Nothing -> id
|
|
Just x -> const $ DelayedBullet x
|
|
sp = _crPos cr +.+ (muzlength + 10) *.* unitVectorAtAngle dir
|
|
dir = _crDir cr
|
|
bultype = _laAmmoType $ _itConsumption it
|
|
muzvel = _muzVel $ _itParams it
|
|
muzlength = aimingMuzzlePos cr it
|
|
settrajectory traj = case traj of
|
|
BasicBulletTrajectory -> BasicBulletTrajectory
|
|
MagnetTrajectory{} -> fromMaybe BasicBulletTrajectory $ do
|
|
tpos <- it ^? itTargeting . tgPos . _Just
|
|
return $ MagnetTrajectory tpos
|
|
FlechetteTrajectory{} -> fromMaybe BasicBulletTrajectory $ do
|
|
tpos <- it ^? itTargeting . tgPos . _Just
|
|
return $ FlechetteTrajectory tpos
|
|
BezierTrajectory{} -> fromMaybe BasicBulletTrajectory $ do
|
|
tpos <- it ^? itTargeting . tgPos . _Just
|
|
return $ BezierTrajectory sp tpos (mouseWorldPos w)
|
|
|
|
{- Update for a generic bullet. -}
|
|
mvBullet :: World -> Bullet -> (World, Maybe Bullet)
|
|
mvBullet w bt'
|
|
| t <= 0 || magV (_buVel bt) < 1 = (w,Nothing)
|
|
| otherwise = bimap (maybespawn . maybebounce) (fmap dodrag) $
|
|
hiteff bt hitstream w
|
|
where
|
|
maybespawn w' = fromMaybe w' $ do
|
|
(hp,_) <- runIdentity (S.head_ hitstream)
|
|
partspawn <- bulletSpawn bt'
|
|
let (thepart,g) = runState (partspawn hp) $ _randGen w'
|
|
return $ w' & instantParticles .:~ thepart
|
|
& randGen .~ g
|
|
maybebounce = fromMaybe id $ do
|
|
guard (_buEffect bt' == BounceBullet)
|
|
(hp,crwl) <- runIdentity (S.head_ hitstream)
|
|
dir <- bounceDir (hp,crwl)
|
|
return $ instantBullets .:~ (bt
|
|
& buPos .~ hp +.+ (normalizeV (_buPos bt' -.- hp))
|
|
& buVel %~ reflectIn dir
|
|
& buTrajectory .~ BasicBulletTrajectory
|
|
& buTimer -~ 1
|
|
)
|
|
--maybebounce = case _buEffect bt' of
|
|
-- BounceBullet -> case runIdentity (S.head_ hitstream) of
|
|
-- Just (hp, Left cr) | crIsArmouredFrom hp cr -> instantBullets .:~ bouncer
|
|
-- where
|
|
-- bouncer = bt
|
|
-- & buPos .~ pOut
|
|
-- & buVel .~ reflectVel
|
|
-- & buTrajectory .~ BasicBulletTrajectory
|
|
-- & buTimer -~ 1
|
|
-- pOut = hp +.+ 2 *.* newDir
|
|
-- reflectVel = reflectIn newDir bulVel --magV bulVel *.* newDir
|
|
-- newDir = squashNormalizeV (hp -.- _crPos cr)
|
|
-- bulVel = _buVel bt
|
|
-- Just (hp, Right wl) -> instantBullets .:~ bouncer
|
|
-- where
|
|
-- reflectVel = reflVelWall wl (_buVel bt)
|
|
-- bouncer = bt
|
|
-- & buPos .~ pOut
|
|
-- & buVel .~ reflectVel
|
|
-- & buTrajectory .~ BasicBulletTrajectory
|
|
-- & buTimer -~ 1
|
|
-- pOut = hp +.+ squashNormalizeV (p -.- hp)
|
|
-- _ -> id
|
|
-- _ -> id
|
|
hitstream = thingsHit p (p +.+ vel) w
|
|
bt = foldr (\mg b -> _mgField mg mg b) bt' $ _magnets w
|
|
dodrag = case _buTrajectory bt of
|
|
BasicBulletTrajectory -> buVel .*.*~ drag
|
|
MagnetTrajectory tpos -> buVel .+.+~ 5 *.* normalizeV (tpos -.- _buPos bt)
|
|
FlechetteTrajectory tpos -> buVel %~ vecTurnTo 0.2 (_buPos bt) tpos
|
|
BezierTrajectory spos tpos xpos ->
|
|
let bf tm = bQuadToF (spos,xpos,tpos) $ (100 - tm) * 0.05
|
|
in buVel .~ bf (fromIntegral $ _buTimer bt - 1) -.- bf (fromIntegral $ _buTimer bt)
|
|
drag = _buDrag bt
|
|
p = _buPos bt
|
|
vel = _buVel bt
|
|
hiteff = hitEffFromBul
|
|
t = _buTimer bt
|
|
|
|
bounceDir :: (Point2, Either Creature Wall) -> Maybe Point2
|
|
bounceDir (_,Right wl) = Just $ uncurry (-.-) (_wlLine wl)
|
|
bounceDir (p,Left cr) | crIsArmouredFrom p cr = Just $ vNormal $ p -.- _crPos cr
|
|
bounceDir _ = Nothing
|
|
|
|
bulletSpawn :: Bullet -> Maybe (Point2 -> State StdGen Particle)
|
|
bulletSpawn bu = case _buSpawn bu of
|
|
BulSpark -> Nothing
|
|
BulBall IncBall -> Just incBall
|
|
BulBall ConcBall -> Just concBall
|
|
BulBall TeslaBall -> Just aStaticBall
|
|
|
|
hitEffFromBul :: Bullet
|
|
-> Stream (Of (Point2, Either Creature Wall)) Identity ()
|
|
-> World
|
|
-> (World,Maybe Bullet)
|
|
hitEffFromBul = expireAndDamage' setfromtodams
|
|
where
|
|
setfromtodams bu p = map f (_buDamages bu)
|
|
where
|
|
f = (dmFrom .~ _buPos bu) . (dmAt .~ p) . (dmTo .~ _buPos bu +.+ _buVel bu)
|
|
|
|
mvBulletSlow :: Float -> World -> Bullet -> (World, Maybe Bullet)
|
|
mvBulletSlow x w bt'
|
|
| t <= 0 || magV (_buVel bt) < 1 = (w,Nothing)
|
|
| otherwise = second (fmap dodrag) $
|
|
hiteff bt (thingsHit p (p +.+ vel) w) w
|
|
where
|
|
bt = foldr (\mg b -> _mgField mg mg b) bt' $ _magnets w
|
|
dodrag = (buVel .*.*~ drag)
|
|
. (buState .~ NormalBulletState)
|
|
drag = _buDrag bt
|
|
p = _buPos bt
|
|
vel = x *.* _buVel bt
|
|
hiteff = hitEffFromBul
|
|
t = _buTimer bt
|
|
expireAndDamage' :: (Bullet -> Point2 -> [Damage])
|
|
-> Bullet
|
|
-> Stream (Of (Point2, Either Creature Wall)) Identity ()
|
|
-> World
|
|
-> (World, Maybe Bullet)
|
|
expireAndDamage' fdm bt things w = case runIdentity $ S.head_ things of
|
|
Nothing -> (w, moveBullet bt)
|
|
Just x -> (doDamages' fdm x bt w, destroyAt' (fst x) bt)
|
|
|
|
moveBullet :: Bullet -> Maybe Bullet
|
|
moveBullet pt = Just $ pt
|
|
& buPos %~ (+.+ _buVel pt)
|
|
& buOldPos .~ _buPos pt
|
|
& buTimer -~ 1
|
|
|
|
destroyAt' :: Point2 -> Bullet -> Maybe Bullet
|
|
destroyAt' hitp pt = Just $ pt
|
|
& buState .~ DyingBulletState
|
|
& buPos .~ hitp
|
|
& buOldPos .~ _buPos pt
|
|
& buTimer %~ (min 3 . subtract 1)
|
|
|
|
--penWalls
|
|
-- :: HitCreatureEffect'
|
|
-- -> HitWallEffect'
|
|
-- -> Bullet
|
|
-- -> [(Point2, Either Creature Wall)]
|
|
-- -> World
|
|
-- -> (World, Maybe Bullet)
|
|
--penWalls crEff wlEff pt hitThings w = case hitThings of
|
|
-- [] -> ( w, moveBullet pt)
|
|
-- ((p,Left cr):_) -> (crEff pt p cr w, destroyAt' p pt)
|
|
-- ((p,Right wl):hs) | _wlFireThrough wl
|
|
-- -> first (wlEff pt p wl) $ penWalls crEff wlEff pt hs w
|
|
-- ((p,Right wl):_) -> (wlEff pt p wl w, destroyAt' p pt)
|
|
|
|
--type HitCreatureEffect' = Bullet -> Point2 -> Creature -> World -> World
|
|
--type HitWallEffect' = Bullet -> Point2 -> Wall -> World -> World
|
|
|
|
doDamages' :: (Bullet -> Point2 -> [Damage])
|
|
-> (Point2, Either Creature Wall)
|
|
-> Bullet
|
|
-> World
|
|
-> World
|
|
doDamages' fdm (p,thhit) bt = case thhit of
|
|
Left cr -> creatures . ix (_crID cr) . crState . csDamage .++~ dams
|
|
Right wl -> wallDamages %~ IM.insertWith (++) (_wlID wl) dams
|
|
where
|
|
dams = fdm bt p
|
|
|
|
--penetrate
|
|
-- :: ((Point2,Either Creature Wall) -> Bullet -> Maybe Bullet)
|
|
-- -- | penetration test, can update particle if it penetrates
|
|
-- -> (Bullet -> Point2 -> [Damage]) -- | damages when penetrating
|
|
-- -> (Bullet -> Point2 -> [Damage]) -- | damages when not penetrating
|
|
-- -> Bullet
|
|
-- -> Stream (Of (Point2, Either Creature Wall)) Identity ()
|
|
-- -> World
|
|
-- -> (World, Maybe Bullet)
|
|
--penetrate t pendam stopdam pt hitThings w = case runIdentity $ S.uncons hitThings of
|
|
-- Nothing -> (w, moveBullet pt)
|
|
-- Just (x,xs) -> case t x pt of
|
|
-- Nothing -> expireAndDamage' stopdam pt hitThings w
|
|
-- Just pt' -> first (doDamages' pendam x pt) $ penetrate t pendam stopdam pt' xs w
|