335 lines
12 KiB
Haskell
335 lines
12 KiB
Haskell
--{-# LANGUAGE LambdaCase #-}
|
|
--{-# OPTIONS_GHC -Wno-unused-imports #-}
|
|
module Dodge.Projectile.Update (updateProjectile) where
|
|
|
|
import Linear
|
|
import Dodge.Render.List
|
|
import Dodge.Render.Label
|
|
import ShortShow
|
|
import Picture.Base
|
|
import Control.Monad
|
|
import Data.List (delete)
|
|
import Data.Maybe
|
|
import Dodge.Base
|
|
import Dodge.Data.Object
|
|
import Dodge.Data.World
|
|
import Dodge.EnergyBall
|
|
import Dodge.Item.Location
|
|
import Dodge.Movement.Turn
|
|
import Dodge.Payload
|
|
import Dodge.SoundLogic
|
|
import Dodge.WorldEvent.Cloud
|
|
import Dodge.WorldEvent.Sound
|
|
import Geometry
|
|
import qualified IntMapHelp as IM
|
|
import LensHelp
|
|
import NewInt
|
|
import RandomHelp
|
|
|
|
updateProjectile :: Projectile -> World -> World
|
|
updateProjectile pj w =
|
|
(cWorld . lWorld . projectiles . ix (pj ^. pjID) . pjTimer -~ 1)
|
|
. shellExplosionCheck pj
|
|
. moveProjectile pj
|
|
. tryThrust pj
|
|
. trySpin pj
|
|
$ doGravityPU pj w
|
|
|
|
doGravityPU :: Projectile -> World -> World
|
|
doGravityPU pj
|
|
| Grenade GBounce{} <- pj ^. pjType = applyGravityPU pj
|
|
| Grenade GStick <- pj ^. pjType = applyGravityPU pj
|
|
| otherwise = id
|
|
|
|
applyGravityPU :: Projectile -> World -> World
|
|
applyGravityPU pj w
|
|
| (pj ^. pjPos . _z) < 1 && norm (_pjVel pj) < 1 =
|
|
w
|
|
& topj . pjVel .~ 0
|
|
| otherwise =
|
|
w -- & topj . pjZ .~ newz
|
|
& topj . pjVel . _z -~ 0.5
|
|
where
|
|
topj = cWorld . lWorld . projectiles . ix (pj ^. pjID)
|
|
|
|
-- newz = pj ^. pjZ + pj ^. pjZVel
|
|
|
|
-- consider pushing any hit creature back
|
|
shellExplosionCheck :: Projectile -> World -> World
|
|
shellExplosionCheck pj w
|
|
| RetiredProjectile <- pj ^. pjType
|
|
, time <= 0 =
|
|
destroyProjectile (pj ^. pjScreenID) (_pjID pj) w
|
|
| time <= 0 = explodeShell pj w
|
|
| RetiredProjectile <- pj ^. pjType = w
|
|
| otherwise = w
|
|
where
|
|
time = _pjTimer pj
|
|
|
|
shellHitWall :: Point3 -> Point3 -> Wall -> Projectile -> World -> World
|
|
shellHitWall p n wl pj w
|
|
| Just GStick <- pj ^? pjType . gnHitEffect =
|
|
w & topj . pjType .~ Grenade (GStuckWall (wl ^. wlStructure))
|
|
& soundOriginIDsAt (ShellSound (pj ^. pjID)) [slapS, slap1S] (pj ^. pjPos . _xy)
|
|
| Just x <- pj ^? pjType . gnHitEffect . bounceTolerance
|
|
, abs (dot (pj ^. pjVel) (normalize n)) < x =
|
|
w
|
|
& topj . pjVel %~ reflectInNormal n
|
|
& topj . pjPos .~ p + normalize n
|
|
& soundStart (ShellSound (pj ^. pjID)) (pj ^. pjPos . _xy) click1S Nothing
|
|
| otherwise =
|
|
w & topj . pjPos .~ p
|
|
& topj . pjTimer .~ 0
|
|
where
|
|
topj = cWorld . lWorld . projectiles . ix (_pjID pj)
|
|
|
|
shellHitCreature :: Point3 -> Creature -> Projectile -> World -> World
|
|
shellHitCreature p cr pj w
|
|
| Just GStick <- pj ^? pjType . gnHitEffect =
|
|
w
|
|
& cWorld . lWorld . projectiles . ix (_pjID pj) . pjType
|
|
.~ Grenade
|
|
( GStuckCreature
|
|
(cr ^. crID)
|
|
(rotate3z (- cr ^. crDir) (p - ((cr ^. crPos . _xy) `v2z` 0)))
|
|
(pj ^. pjDir - cr ^. crDir)
|
|
)
|
|
& soundOriginIDsAt (ShellSound (pj ^. pjID)) [slapS, slap1S] (pj ^. pjPos . _xy)
|
|
| otherwise =
|
|
w
|
|
& cWorld . lWorld . projectiles . ix (_pjID pj) . pjTimer .~ 0
|
|
|
|
shellHitFloor :: Point3 -> Projectile -> World -> World
|
|
shellHitFloor p pj w
|
|
| z < 1 && norm (_pjVel pj) < 1 = w
|
|
| otherwise =
|
|
w
|
|
& topj . pjPos .~ (p & _z .~ 0.1)
|
|
& topj . pjVel . _z %~ bouncez
|
|
& topj . pjVel . _xy %~ decvel
|
|
& topj . pjSpin %~ decspin
|
|
& soundStart (ShellSound (pj ^. pjID)) (pj ^. pjPos . _xy) click1S Nothing
|
|
where
|
|
bouncez x
|
|
| x < -1 = -0.5 * x
|
|
| otherwise = 0
|
|
topj = cWorld . lWorld . projectiles . ix (pj ^. pjID)
|
|
zvel = pj ^. pjVel . _z
|
|
z = pj ^. pjPos . _z + zvel
|
|
decvel v
|
|
| magV v > 1 = rotateV (5 * pj ^. pjSpin) $ 0.8 * v
|
|
| otherwise = 0
|
|
decspin x
|
|
| abs x < 0.01 = 0
|
|
| otherwise = x * 0.9
|
|
|
|
------ note this doesn't take into account moving walls, which may break the
|
|
------ bouncing in some way
|
|
--tryShellBounce :: Point3 -> (Point3, Object ) -> Projectile -> World -> World
|
|
--tryShellBounce p' (n, OWall wl) pj w
|
|
-- | Just GStick <- pj ^? pjType . gnHitEffect =
|
|
-- w
|
|
-- & cWorld . lWorld . projectiles . ix (_pjID pj) . pjType
|
|
-- .~ Grenade (GStuckWall (wl ^. wlStructure))
|
|
-- & soundOriginIDsAt (ShellSound (pj ^. pjID)) [slapS, slap1S] (pj ^. pjPos . _xy)
|
|
-- | Just x <- pj ^? pjType . gnHitEffect . bounceTolerance
|
|
-- , abs (dotV (pj ^. pjVel . _xy) (vNormal hitline)) < x =
|
|
-- w
|
|
-- & cWorld . lWorld . projectiles . ix (_pjID pj) . pjVel . _xy
|
|
-- %~ reflectIn hitline
|
|
-- & cWorld . lWorld . projectiles . ix (_pjID pj) . pjPos
|
|
-- .~ p - normalizeV (pj ^. pjVel)
|
|
-- & soundStart (ShellSound (pj ^. pjID)) (pj ^. pjPos) click1S Nothing
|
|
-- where
|
|
-- p = xyV3 p'
|
|
-- hitline = normalizeV $ uncurry (-) $ _wlLine wl
|
|
--tryShellBounce p' (n,OCreature cr) pj w
|
|
-- | Just GStick <- pj ^? pjType . gnHitEffect =
|
|
-- w
|
|
-- & cWorld . lWorld . projectiles . ix (_pjID pj) . pjType
|
|
-- .~ Grenade
|
|
-- ( GStuckCreature
|
|
-- (cr ^. crID)
|
|
-- (rotate3z (- cr ^. crDir) (p' - ((cr ^. crPos)`v2z`0)))
|
|
-- (pj ^. pjDir - cr ^. crDir)
|
|
-- )
|
|
-- & soundOriginIDsAt (ShellSound (pj ^. pjID)) [slapS, slap1S] (pj ^. pjPos)
|
|
-- where
|
|
-- p = xyV3 p'
|
|
--tryShellBounce _ _ pj w = w
|
|
--tryShellBounce _ _ pj w = explodeShell pj w
|
|
|
|
destroyProjectile :: Maybe (NewInt ItmInt) -> Int -> World -> World
|
|
destroyProjectile mitid pjid w =
|
|
w & cWorld . lWorld . projectiles %~ IM.delete pjid
|
|
& removelink
|
|
where
|
|
removelink = fromMaybe id $ do
|
|
itid <- mitid
|
|
-- loc <- w ^? cWorld . lWorld . itemLocations . ix itid
|
|
return $ pointerToItemID itid . itUse . uaParams . apProjectiles %~ delete pjid
|
|
|
|
trySpin :: Projectile -> World -> World
|
|
trySpin pj = fromMaybe id $ do
|
|
guard (pj ^. pjTimer == 335)
|
|
(cid, s) <- pj ^? pjBarrelSpin . _Just
|
|
return $ doBarrelSpin cid s pj
|
|
|
|
tryThrust :: Projectile -> World -> World
|
|
tryThrust pj = fromMaybe id $ do
|
|
Rocket y x <- pj ^? pjType
|
|
guard $ pj ^. pjTimer <= 330 && pj ^. pjTimer >= 0
|
|
return $ doThrust pj x . pjRemoteSetDirection (Just y) pj
|
|
|
|
doThrust :: Projectile -> Maybe RocketSmoke -> World -> World
|
|
doThrust pj smoke w =
|
|
w
|
|
& randGen .~ g
|
|
& cWorld . lWorld . projectiles . ix i . pjVel . _xy %~ (\v -> accel +.+ frict *.* v)
|
|
& soundContinue (ShellSound i) newPos missileLaunchS (Just 1)
|
|
& makeFlamelet
|
|
((oldPos -.- vel) `v2z` 20)
|
|
((vel +.+ rotateV (pi + sparkD) accel) `v2z` 0)
|
|
3
|
|
10
|
|
& makeCloudAt
|
|
RocketSmoke
|
|
lifetime
|
|
(addZ 20 (oldPos +.+ r1 +.+ 30 *.* normalizeV (oldPos -.- newPos)))
|
|
where
|
|
lifetime = fst . randomR lt $ _randGen w
|
|
lt
|
|
| smoke == Just ReducedRocketSmoke = (50, 200)
|
|
| otherwise = (300, 500)
|
|
-- trailfadetime = fst . randomR (100, 300) $ _randGen w
|
|
accel = rotateV (pj ^. pjDir) (V2 3 0)
|
|
i = _pjID pj
|
|
oldPos = pj ^. pjPos . _xy
|
|
vel = pj ^. pjVel . _xy
|
|
newPos = oldPos +.+ vel
|
|
(frict, g) = randomR (0.6, 0.9) $ _randGen w
|
|
(sparkD, _) = randomR (-0.2, 0.2) $ _randGen w
|
|
r1 = randInCirc 10 & evalState $ _randGen w
|
|
|
|
doBarrelSpin :: Int -> Float -> Projectile -> World -> World
|
|
doBarrelSpin cid i pj w =
|
|
w & cWorld . lWorld . projectiles . ix pjid . pjSpin .~ newSpin
|
|
& cWorld . lWorld . projectiles . ix pjid . pjBarrelSpin .~ Nothing
|
|
where
|
|
pjid = _pjID pj
|
|
dir = argV $ pj ^. pjVel . _xy
|
|
newSpin = case w ^? cWorld . lWorld . creatures . ix cid of
|
|
Just cr -> negate $ min 0.2 $ max (-0.2) $ normalizeAnglePi (dir - _crDir cr) / spinFactor
|
|
_ -> 0
|
|
spinFactor = 5 * (6 - i)
|
|
|
|
-- note this only allows YOU to remotely track projectiles
|
|
pjRemoteSetDirection :: Maybe RocketHoming -> Projectile -> World -> World
|
|
pjRemoteSetDirection ph pj w = case ph of
|
|
Just (HomeUsingRemoteScreen screenid)
|
|
| lw ^? creatures . ix 0 . crManipulation . manObject . imSelectedItem
|
|
== lw ^? items . ix (_unNInt screenid) . itLocation . ilInvID ->
|
|
w
|
|
& cWorld . lWorld . projectiles . ix (_pjID pj) . pjDir
|
|
.~ (w ^. wCam . camRot) + argV (w ^. input . mousePos)
|
|
& cWorld . lWorld . projectiles . ix (_pjID pj) . pjSpin
|
|
.~ 0.5 * diffAngles ((w ^. wCam . camRot) + argV (w ^. input . mousePos)) (_pjDir pj)
|
|
Just (HomeUsingTargeting itid)
|
|
| Just tp <- w ^? pointerToItemID itid . itTargeting . itTgPos . _Just ->
|
|
w
|
|
& cWorld . lWorld . projectiles . ix (_pjID pj) . pjDir
|
|
%~ turnTo 0.2 (pj ^. pjPos . _xy) tp
|
|
& cWorld . lWorld . projectiles . ix (_pjID pj) . pjSpin
|
|
.~ 0.5 * diffAngles (turnTo 0.2 (pj ^. pjPos . _xy) tp (_pjDir pj)) (_pjDir pj)
|
|
_ -> w
|
|
where
|
|
lw = w ^. cWorld . lWorld
|
|
|
|
moveStuckGrenade :: Int -> Point3 -> Float -> Projectile -> World -> World
|
|
moveStuckGrenade cid poff d pj w
|
|
| Just cr <- w ^? cWorld . lWorld . creatures . ix cid =
|
|
let cpos = cr ^. crPos
|
|
cdir = cr ^. crDir
|
|
vel = cpos - cr ^. crOldPos
|
|
in w
|
|
& cWorld . lWorld . projectiles . ix (pj ^. pjID) . pjPos . _xy
|
|
.~ xyV3 (cpos + rotate3z cdir poff)
|
|
& cWorld . lWorld . projectiles . ix (pj ^. pjID) . pjDir .~ d + cdir
|
|
& cWorld . lWorld . projectiles . ix (pj ^. pjID) . pjVel .~ vel
|
|
| otherwise =
|
|
w & cWorld . lWorld . projectiles . ix (pj ^. pjID) . pjType .~ Grenade GStick
|
|
|
|
moveProjectile :: Projectile -> World -> World
|
|
moveProjectile pj w = moveProjectile' pj w
|
|
& cWorld . lWorld . flares <>~
|
|
(setLayer DebugLayer
|
|
$ color red $ line [p, (p +v)]
|
|
)
|
|
where
|
|
p = pj^. pjPos . _xy
|
|
v = pj^. pjVel . _xy
|
|
|
|
|
|
moveProjectile' :: Projectile -> World -> World
|
|
moveProjectile' pj w
|
|
| Just GStuckWall{} <- pj ^? pjType . gnHitEffect = w
|
|
| Just (GStuckCreature crid poff d) <- pj ^? pjType . gnHitEffect =
|
|
moveStuckGrenade crid poff d pj w
|
|
| (p, Just (n, OWall wl)) <- collide3 sp (sp + 2 *^ _pjVel pj) w =
|
|
shellHitWall p n wl pj w
|
|
| (p, Just (_, OFloor)) <- collide3 sp (sp + 2*^ _pjVel pj) w =
|
|
shellHitFloor p pj w
|
|
| (p, Just (_, OCreature cr)) <- collide3 sp (sp + 2 *^ _pjVel pj) w =
|
|
shellHitCreature p cr pj w
|
|
& cWorld . lWorld . flares <>~ test p cr w sp (_pjVel pj)
|
|
| (_, Just (_, OChasmWall)) <- collide3 sp (sp + 2 *^_pjVel pj) w =
|
|
-- no stick or bounce for now
|
|
w & cWorld . lWorld . projectiles . ix (pj ^. pjID) . pjTimer .~ 0
|
|
| otherwise =
|
|
w
|
|
& cWorld . lWorld . projectiles . ix (pj ^. pjID) . pjSpin *~ 0.99
|
|
& cWorld . lWorld . projectiles . ix (pj ^. pjID) . pjPos +~ _pjVel pj
|
|
& cWorld . lWorld . projectiles . ix (pj ^. pjID) . pjDir +~ _pjSpin pj
|
|
where
|
|
sp = _pjPos pj
|
|
|
|
test :: Point3 -> Creature -> World -> Point3 -> Point3 -> Picture
|
|
test p cr w sp v =
|
|
(setLayer FixedCoordLayer
|
|
$ uncurryV translate (worldPosToScreen (w ^. wCam) (p ^. _xy))
|
|
$ drawList [text (shortShow p),text $ shortShow sp, text $ shortShow $ sp + 2*v, text $ shortShow v]
|
|
<> color white (crossPic 5)
|
|
) <>
|
|
(setLayer DebugLayer
|
|
$ uncurryV translate (p ^. _xy)
|
|
$ ( scale 0.1 0.1
|
|
$ stackPicturesAt
|
|
[ text $ shortShow p
|
|
, text $ shortShow sp
|
|
, text $ shortShow (sp + v)
|
|
]
|
|
) <> color green (crossPic 5)
|
|
) <>
|
|
setLayer DebugLayer
|
|
(uncurryV translate (cr ^. crPos . _xy)
|
|
$ circle 10
|
|
) <>
|
|
(setLayer DebugLayer
|
|
$ color red $ line [sp^. _xy, (sp +v)^._xy]
|
|
)
|
|
|
|
explodeShell :: Projectile -> World -> World
|
|
explodeShell pj w =
|
|
w
|
|
& cWorld . lWorld . projectiles . ix pjid . pjType .~ RetiredProjectile
|
|
& cWorld . lWorld . projectiles . ix pjid . pjVel .~ 0
|
|
& cWorld . lWorld . projectiles . ix pjid . pjTimer .~ 30
|
|
& usePayload (_pjPayload pj) (pj ^. pjPos) (pj ^. pjVel)
|
|
& stopSoundFrom (ShellSound pjid)
|
|
& updatedetonator
|
|
where
|
|
updatedetonator = fromMaybe id $ do
|
|
detid <- pj ^. pjDetonatorID
|
|
return $ pointerToItemID detid . itUse . uaParams . apProjectiles %~ delete pjid
|
|
pjid = pj ^. pjID
|