256 lines
11 KiB
Haskell
256 lines
11 KiB
Haskell
module Dodge.Item.Weapon.Bullet
|
|
where
|
|
import Dodge.Data
|
|
import Dodge.Base
|
|
import Dodge.WorldActions
|
|
import Dodge.SoundLogic
|
|
import Dodge.RandomHelp
|
|
|
|
import Geometry
|
|
|
|
import System.Random
|
|
|
|
import Control.Lens
|
|
import Control.Monad.State
|
|
|
|
import qualified Data.IntMap.Strict as IM
|
|
|
|
import Picture
|
|
|
|
-- bullet effects
|
|
bulHitCr' :: Particle' -> Point2 -> Creature -> World -> World
|
|
bulHitCr' bt p cr w =
|
|
let sp = head $ _btTrail' bt
|
|
ep = sp +.+ _btVel' bt
|
|
mvDams = [ PushDam 1 $ 2 *.* bulVel ]
|
|
addDamage = over (creatures . ix cid . crState . crDamage)
|
|
(\dams -> (Piercing 100 sp p ep : mvDams) ++ dams)
|
|
addDamageArmoured = over (creatures . ix cid . crState . crDamage)
|
|
(\dams -> mvDams ++ dams)
|
|
hitSound = soundMultiFrom [CrHitSound 0] 15 10 0
|
|
flashEff = over worldEvents ((.) $ flareAt red p)
|
|
bulVel = _btVel' bt
|
|
ck cid = (+.+) (crKnockBack cid *.* bulVel)
|
|
crKnockBack cid = (/) 1 $ (+) 2 $ _crMass $ _creatures w IM.! cid
|
|
hasArmour cr = any (\it -> it ^? itIdentity == Just FrontArmour) $ _crInv cr
|
|
cid = _crID cr
|
|
sID = newParticleKey w
|
|
(d1,g) = randomR (-0.7,0.7) $ _randGen w
|
|
(colID,_) = randomR (0,11) $ _randGen w
|
|
hitEffect = addDamage
|
|
. hitSound
|
|
. flashEff
|
|
$ w
|
|
in case hasArmour cr of --shit this is ugly, to refactor
|
|
True -> if hitBack
|
|
then hitEffect
|
|
else createSpark 8 colID p1
|
|
(argV (p -.- _crPos (_creatures w IM.! cid)) + d1)
|
|
Nothing
|
|
. addDamageArmoured
|
|
$ w
|
|
where cpos = _crPos $ _creatures w IM.! cid
|
|
relHitPos = p -.- cpos
|
|
hitBack = errorAngleVV 19 (unitVectorAtAngle (_crDir $ _creatures w IM.! cid))
|
|
relHitPos
|
|
> pi/2
|
|
p1 = p +.+ 2 *.* safeNormalizeV relHitPos
|
|
_ -> hitEffect
|
|
|
|
bulPenCr' :: Particle' -> Point2 -> Creature -> World -> World
|
|
bulPenCr' bt p cr w
|
|
= over (creatures . ix cid . crState . crDamage)
|
|
(\dams -> [Piercing 50 sp p ep
|
|
,Blunt 50 sp p ep
|
|
,TorqueDam 1 d1
|
|
,PushDam 1 $ 3 *.* (ep -.- sp)
|
|
] ++ dams
|
|
)
|
|
$ soundMultiFrom [CrHitSound 0] 15 10 0
|
|
$ over worldEvents addPiercer
|
|
w
|
|
where (d1,g) = randomR (-0.7,0.7) $ _randGen w
|
|
cid = _crID cr
|
|
sp = head $ _btTrail' bt
|
|
ep = sp +.+ _btVel' bt
|
|
addPiercer = (.) $ over particles' ((:) piercer)
|
|
piercer = (aGenBulAt' (Just cid) (_btColor' bt) p (_btVel' bt)
|
|
(_btHitEffect' bt) (_btWidth' bt)
|
|
) {_btTimer' = _btTimer' bt - 1}
|
|
|
|
hvBulHitCr' :: Particle' -> Point2 -> Creature -> World -> World
|
|
hvBulHitCr' bt p cr w
|
|
= over (creatures . ix cid . crState . crDamage)
|
|
(\dams -> [Piercing 200 sp p ep
|
|
,Blunt 100 sp p ep
|
|
,TorqueDam 1 d1
|
|
,PushDam 1 $ 3 *.* (ep -.- sp)
|
|
] ++ dams
|
|
)
|
|
$ soundMultiFrom [CrHitSound 0] 15 10 0
|
|
w
|
|
where (d1,g) = randomR (-0.7,0.7) $ _randGen w
|
|
cid = _crID cr
|
|
sp = head $ _btTrail' bt
|
|
ep = sp +.+ _btVel' bt
|
|
|
|
bulIncCr' :: Particle' -> Point2 -> Creature -> World -> World
|
|
bulIncCr' bt p cr w
|
|
= over (creatures . ix cid . crState . crDamage)
|
|
(\dams -> [Piercing 60 sp p ep
|
|
] ++ dams
|
|
)
|
|
$ soundMultiFrom [CrHitSound 0] 15 10 0
|
|
$ incFlamelets
|
|
w
|
|
where cid = _crID cr
|
|
sp = head $ _btTrail' bt
|
|
ep = sp +.+ _btVel' bt
|
|
v = evalState (randInCirc 1) $ _randGen w
|
|
incFlamelets = over worldEvents $ (.) (makeFlamelet p v (levLayer UPtLayer) Nothing 3)
|
|
|
|
bulConCr' :: Particle' -> Point2 -> Creature -> World -> World
|
|
bulConCr' bt p cr w
|
|
= over (creatures . ix cid . crState . crDamage)
|
|
(\dams -> [Piercing 60 sp p ep
|
|
] ++ dams
|
|
)
|
|
$ soundMultiFrom [CrHitSound 0] 15 10 0
|
|
$ mkwave
|
|
w
|
|
where cid = _crID cr
|
|
sp = head $ _btTrail' bt
|
|
ep = sp +.+ _btVel' bt
|
|
mkwave = over worldEvents $ (.) (makeShockwaveAt p 15 4 1 white)
|
|
|
|
bulHitWall' :: Particle' -> Point2 -> Wall -> World -> World
|
|
bulHitWall' bt p x w = damageBlocks x
|
|
$ createSpark 8 colID pOut (reflectDir x) Nothing
|
|
$ set randGen g
|
|
w
|
|
where sp = head $ _btTrail' bt
|
|
pOut = p +.+ safeNormalizeV (sp -.- p)
|
|
(colID,g) = randomR (0,11) $ _randGen w
|
|
(a, _) = randomR (-0.1,0.1) $ _randGen w
|
|
spid = newKey $ _particles w
|
|
reflectDir wall = a + (argV $ reflectIn
|
|
(_wlLine wall !! 1 -.- _wlLine wall !! 0)
|
|
(p -.- sp)
|
|
)
|
|
damageBlocks wall w
|
|
= case wall ^? blHP of
|
|
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall)
|
|
_ -> w
|
|
|
|
bulBounceWall' :: Particle' -> Point2 -> Wall -> World -> World
|
|
bulBounceWall' bt p wl w = damageBlocks wl
|
|
$ over worldEvents addBouncer
|
|
-- yay for hack -- should have used this before? or never?
|
|
w
|
|
where sp = head $ _btTrail' bt
|
|
pOut = p +.+ safeNormalizeV (sp -.- p)
|
|
damageBlocks wall w
|
|
= case wall ^? blHP of
|
|
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall)
|
|
_ -> w
|
|
bouncer = (aGenBulAt' Nothing (_btColor' bt) pOut reflectVel
|
|
(_btHitEffect' bt) (_btWidth' bt)
|
|
) {_btTimer' = _btTimer' bt - 1}
|
|
wallV = (_wlLine wl !! 1 -.- _wlLine wl !! 0)
|
|
reflectVel = (reflectIn wallV (_btVel' bt))
|
|
addBouncer = (.) (over particles' ((:) bouncer))
|
|
-- the hack is to get around the fact that the particles' list gets reset after
|
|
-- all particles in it are checked, so we cannot add to it as we accumulate over
|
|
-- this list
|
|
|
|
bulIncWall' :: Particle' -> Point2 -> Wall -> World -> World
|
|
bulIncWall' bt p wl w = damageBlocks wl
|
|
$ incFlamelets
|
|
-- yay for hack -- should have used this before? or never?
|
|
w
|
|
where sp = head $ _btTrail' bt
|
|
pOut = p +.+ safeNormalizeV (sp -.- p)
|
|
damageBlocks wall w
|
|
= case wall ^? blHP of
|
|
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall)
|
|
_ -> w
|
|
wallV = (_wlLine wl !! 1 -.- _wlLine wl !! 0)
|
|
reflectVel = safeNormalizeV $ reflectIn wallV (_btVel' bt)
|
|
incFlamelets = over worldEvents $ (.) (makeFlamelet pOut reflectVel (levLayer UPtLayer) Nothing 3)
|
|
|
|
bulConWall' :: Particle' -> Point2 -> Wall -> World -> World
|
|
bulConWall' bt p wl w = damageBlocks wl
|
|
$ mkwave
|
|
-- yay for hack -- should have used this before? or never?
|
|
w
|
|
where sp = head $ _btTrail' bt
|
|
pOut = p +.+ safeNormalizeV (sp -.- p)
|
|
damageBlocks wall w
|
|
= case wall ^? blHP of
|
|
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall)
|
|
_ -> w
|
|
wallV = (_wlLine wl !! 1 -.- _wlLine wl !! 0)
|
|
mkwave = over worldEvents $ (.) (makeShockwaveAt p 15 4 1 white)
|
|
|
|
hvBulHitWall' :: Particle' -> Point2 -> Wall -> World -> World
|
|
hvBulHitWall' bt p x w = damageBlocks x
|
|
$ set randGen g
|
|
$ foldr ($) w (sparks pOut sv)
|
|
where sp = head $ _btTrail' bt
|
|
pOut = p +.+ safeNormalizeV (sp -.- p)
|
|
(a, g) = randomR (-0.1,0.1) $ _randGen w
|
|
spid = newKey $ _particles w
|
|
reflectDir wall = a + (argV $ reflectIn
|
|
(_wlLine wall !! 1 -.- _wlLine wall !! 0)
|
|
(p -.- sp)
|
|
)
|
|
sv = unitVectorAtAngle $ reflectDir x
|
|
damageBlocks wall w
|
|
= case wall ^? blHP of
|
|
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 20)) w (_blIDs wall)
|
|
_ -> w
|
|
sID = newParticleKey w
|
|
cs = take 10 $ randomRs (0,11) $ _randGen w
|
|
ds = randomRs (-0.7,0.7) $ _randGen w
|
|
ts = randomRs (4,8) $ _randGen w
|
|
sparks pos vel = zipWith3 (\t c d -> createSpark t c pos (argV vel + d) Nothing) ts cs ds
|
|
bulHitFF' :: Particle' -> Point2 -> ForceField -> World -> World
|
|
bulHitFF' _ _ _ = id
|
|
|
|
bulletEffect' :: HitEffect'
|
|
bulletEffect' = threeEff' bulHitCr' bulHitWall' bulHitFF'
|
|
|
|
bulletParticleSideEffect :: Particle' -> HitEffect'
|
|
bulletParticleSideEffect pt = threeEff' mkPt mkPt noEff
|
|
where mkPt _ p _ = over particles' ((:) pt {_btTrail' = [p]})
|
|
|
|
aGenBulAt' :: Maybe Int -> Color -> Point2 -> Point2 -> HitEffect' -> Float -> Particle'
|
|
aGenBulAt' maycid col pos vel hiteff width = Bul'
|
|
{ _ptPict' = blank
|
|
, _ptUpdate' = mvGenBullet'
|
|
, _btVel' = vel
|
|
, _btColor' = col
|
|
, _btTrail' = [pos]
|
|
, _btPassThrough' = maycid
|
|
, _btWidth' = width
|
|
, _btTimer' = 100
|
|
, _btHitEffect' = hiteff
|
|
}
|
|
|
|
aCurveBulAt :: Maybe Int -> Color -> Point2 -> Point2 -> Point2 -> HitEffect' -> Float -> Particle'
|
|
aCurveBulAt maycid col pos control targ hiteff width = Bul'
|
|
{ _ptPict' = blank
|
|
, _ptUpdate' = mvBulletTrajectory f
|
|
, _btVel' = (0,0)
|
|
, _btColor' = col
|
|
, _btTrail' = [pos]
|
|
, _btPassThrough' = maycid
|
|
, _btWidth' = width
|
|
, _btTimer' = 100
|
|
, _btHitEffect' = hiteff
|
|
}
|
|
where f i = g $ (100 - fromIntegral i) / den
|
|
g x = map (bf . (+ x)) [0,1 / (den * 10)..9 / (den * 10)]
|
|
bf = bQuadToF (pos,control,targ)
|
|
den = 20
|