379 lines
18 KiB
Haskell
379 lines
18 KiB
Haskell
module Dodge.WorldEvent
|
|
( module Dodge.WorldEvent
|
|
, module Dodge.WorldEvent.Bullet
|
|
, module Dodge.WorldEvent.Flash
|
|
, module Dodge.WorldEvent.ThingsHit
|
|
, module Dodge.WorldEvent.HelperParticle
|
|
, module Dodge.WorldEvent.Projectile
|
|
, module Dodge.WorldEvent.Cloud
|
|
)
|
|
where
|
|
|
|
import Dodge.WorldEvent.Projectile
|
|
import Dodge.WorldEvent.Bullet
|
|
import Dodge.WorldEvent.Flash
|
|
import Dodge.WorldEvent.ThingsHit
|
|
import Dodge.WorldEvent.HelperParticle
|
|
import Dodge.WorldEvent.Cloud
|
|
import Dodge.LightSources
|
|
|
|
import Dodge.Data
|
|
import Dodge.Base
|
|
import Dodge.SoundLogic
|
|
import Dodge.RandomHelp
|
|
import Geometry
|
|
import Picture
|
|
|
|
import Control.Lens
|
|
import Control.Monad.State
|
|
|
|
import System.Random
|
|
|
|
import Data.Maybe
|
|
import Data.Function
|
|
import Data.List
|
|
import qualified Data.IntMap.Strict as IM
|
|
|
|
makeExplosionAt :: Point2 -> World -> World
|
|
makeExplosionAt p w = soundOnce grenadeBang
|
|
. addFlames
|
|
. explosionFlashAt p
|
|
$ makeShockwaveAt p 50 10 1 white
|
|
w
|
|
where fVs = fst $ runState ((sequence . take 75 . repeat . randInCirc) 1) $ _randGen w
|
|
fPs' = evalState ((sequence . take 75 . repeat . randInCirc) 15) $ _randGen w
|
|
fPs = map (pushAgainstWalls . (+.+) p . (*.*) 0.5)
|
|
fPs'
|
|
inversePushOut v = (15 - magV v) * 0.01 *.* v
|
|
fVs' = zipWith (+.+) fVs $ map inversePushOut fPs'
|
|
sizes = randomRs (2,6) $ _randGen w
|
|
times = randomRs (20,25) $ _randGen w
|
|
mF q v size time = makeFlameletTimed q v (levLayer GloomLayer - 1) Nothing size time
|
|
newFs = zipWith4 mF fPs (fmap (3 *.*) fVs') sizes times
|
|
addFlames w = foldr ($) w newFs
|
|
pushAgainstWalls q = fromMaybe q $ fmap (\(x,y)-> x +.+ y)
|
|
$ collidePointWalls p q $ wallsNearPoint q w
|
|
|
|
shockWaveDamage :: Point2 -> Float -> Int -> World -> World
|
|
shockWaveDamage p rad amount w = flip (foldr damageBlocks) hitBlocks $ over creatures (IM.map f) w
|
|
where f cr | dist (_crPos cr) p < rad + _crRad cr = over (crState . crDamage)
|
|
((:) $ Concussive amount p 2 0.5 rad) cr
|
|
| otherwise = cr
|
|
hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w
|
|
damageBlocks wall w
|
|
= case wall ^? blHP of
|
|
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - (div amount 2)))
|
|
w
|
|
(_blIDs wall)
|
|
_ -> w
|
|
|
|
makeShockwaveAt :: Point2 -> Float -> Int -> Float -> Color
|
|
-> World -> World
|
|
makeShockwaveAt p rad dam push col = over particles' ((:) theShockwave)
|
|
where theShockwave = shockwaveAt p rad dam push col 10
|
|
|
|
shockwaveAt :: Point2 -> Float -> Int -> Float -> Color -> Int -> Particle'
|
|
shockwaveAt p rad dam push col maxtime
|
|
= Shockwave'
|
|
{ _ptPict' = blank
|
|
, _ptUpdate' = mvShockwave'
|
|
, _btColor' = col
|
|
, _btPos' = p
|
|
, _btRad' = rad
|
|
, _btDam' = dam
|
|
, _btPush' = push
|
|
, _btMaxTime' = maxtime
|
|
, _btTimer' = maxtime
|
|
}
|
|
|
|
mvShockwave' :: World -> Particle' -> (World, Maybe Particle')
|
|
mvShockwave' w pt
|
|
| _btTimer' pt <= 0 = (w, Nothing)
|
|
| otherwise
|
|
= (dams w , Just $ set btTimer' (t - 1) $ set ptPict' pic pt)
|
|
where r = _btRad' pt
|
|
p = _btPos' pt
|
|
push = _btPush' pt
|
|
dam = _btDam' pt
|
|
t = _btTimer' pt
|
|
tFraction = fromIntegral t / fromIntegral (_btMaxTime' pt)
|
|
pic = onLayer PtLayer $ uncurry translate p
|
|
$ color (_btColor' pt) $ thickCircle rad thickness
|
|
rad = r - (3/4) * r * tFraction
|
|
thickness = tFraction**2 * r
|
|
dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks
|
|
hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w
|
|
damageBlocks wall w
|
|
= case wall ^? blHP of
|
|
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1))
|
|
w
|
|
(_blIDs wall)
|
|
_ -> w
|
|
damCr cr | dist (_crPos cr) p < rad + _crRad cr
|
|
= over (crState . crDamage)
|
|
((:) $ PushDam dam (25 * push *.* safeNormalizeV (_crPos cr -.- p)))
|
|
cr
|
|
| otherwise = cr
|
|
moveShockWave :: Int -> Point2 -> Float -> Float -> Float -> World -> Particle' -> (World, Maybe Particle')
|
|
moveShockWave 0 _ _ _ _ w _ = (w, Nothing)
|
|
moveShockWave t p r push pushexp w pt
|
|
= (dams w, Just $ newupdate $ newpic pt )
|
|
where newupdate = set ptUpdate' $ moveShockWave (t-1) p r push pushexp
|
|
newpic = set ptPict' (onLayer PtLayer $ uncurry translate p
|
|
$ color cyan $ thickCircle rad thickness)
|
|
rad = r - (3/40) * r * fromIntegral t
|
|
thickness = (fromIntegral t)**2 * rad / 40
|
|
dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks
|
|
hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w
|
|
damageBlocks wall w
|
|
= case wall ^? blHP of
|
|
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1))
|
|
w
|
|
(_blIDs wall)
|
|
_ -> w
|
|
damCr cr | dist (_crPos cr) p < rad + _crRad cr
|
|
= over (crState . crDamage)
|
|
((:) $ PushDam 1 (25 *.* safeNormalizeV (_crPos cr -.- p)))
|
|
cr
|
|
| otherwise = cr
|
|
|
|
inverseShockwaveAt :: Point2 -> Float -> Int -> Float -> Float -> World -> World
|
|
inverseShockwaveAt p rad dam push pushexp = over particles' ((:) theShockwave)
|
|
where theShockwave
|
|
= Particle'
|
|
{ _ptPict' = blank
|
|
, _ptUpdate' = moveInverseShockWave 10 p rad push pushexp
|
|
}
|
|
moveInverseShockWave :: Int -> Point2 -> Float -> Float -> Float -> World -> Particle' -> (World, Maybe Particle')
|
|
moveInverseShockWave 0 _ _ _ _ w _ = (w, Nothing)
|
|
moveInverseShockWave t p r push pushexp w pt
|
|
= (dams w, Just $ newupdate $ newpic pt )
|
|
where newupdate = set ptUpdate' $ moveInverseShockWave (t-1) p r push pushexp
|
|
newpic = set ptPict' (onLayer PtLayer $ uncurry translate p
|
|
$ color cyan $ thickCircle rad thickness)
|
|
rad = r - (4/40) * r * fromIntegral (10 - t)
|
|
thickness = (fromIntegral (10 - t))**2 * rad / 40
|
|
dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks
|
|
hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w
|
|
damageBlocks wall w
|
|
= case wall ^? blHP of
|
|
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1))
|
|
w
|
|
(_blIDs wall)
|
|
_ -> w
|
|
damCr cr | dist (_crPos cr) p < rad + _crRad cr
|
|
= over (crState . crDamage)
|
|
((:) $ PushDam 1 (25 *.* safeNormalizeV (p -.- _crPos cr)))
|
|
cr
|
|
| otherwise = cr
|
|
|
|
-- if the spark is created by another Particle', it cannot be directly added to
|
|
-- the list, hence the redirect through worldEvents
|
|
createSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World
|
|
createSpark time colid pos dir maycid w = over worldEvents
|
|
((.) $ ( over particles' ((:) spark)
|
|
-- . flareAt' white 0.02 0.05 pos')
|
|
. sparkFlashAt pos')
|
|
) w
|
|
where spark = Bul' { _ptPict' = blank
|
|
, _ptUpdate' = mvGenBullet'
|
|
, _btVel' = rotateV dir (5,0)
|
|
, _btColor' = numColor colid
|
|
, _btTrail' = [pos]
|
|
, _btPassThrough' = maycid
|
|
, _btWidth' = 1
|
|
, _btTimer' = time
|
|
, _btHitEffect' = destroyOnImpact sparkEff noEff noEff
|
|
}
|
|
x = fst $ randomR (0,20) $ _randGen w
|
|
pos' = pos +.+ rotateV dir (x,0)
|
|
sparkEff bt p cr = over (creatures . ix (_crID cr) . crState . crDamage)
|
|
((:) $ SparkDam 1 sp p ep)
|
|
where sp = head (_btTrail' bt)
|
|
ep = sp +.+ _btVel' bt
|
|
|
|
createBarrelSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World
|
|
createBarrelSpark time colid pos dir maycid w = over worldEvents
|
|
((.) $ ( over particles' ((:) spark)
|
|
. sparkFlashAt pos')
|
|
) w
|
|
where spark = Bul' { _ptPict' = blank
|
|
, _ptUpdate' = mvGenBullet'
|
|
, _btVel' = rotateV dir (5,0)
|
|
, _btColor' = numColor colid
|
|
, _btTrail' = [pos]
|
|
, _btPassThrough' = maycid
|
|
, _btWidth' = 1
|
|
, _btTimer' = time
|
|
, _btHitEffect' = destroyOnImpact sparkEff noEff noEff
|
|
}
|
|
x = fst $ randomR (0,20) $ _randGen w
|
|
pos' = pos +.+ rotateV dir (x,0)
|
|
sparkEff bt p cr = over (creatures . ix (_crID cr) . crState . crDamage)
|
|
((:) $ SparkDam 1 sp p ep)
|
|
where sp = head (_btTrail' bt)
|
|
ep = sp +.+ _btVel' bt
|
|
|
|
noEff _ _ _ = id
|
|
|
|
makeFlameletTimed :: Point2 -> Point2 -> Int -> Maybe Int -> Float -> Int -> World -> World
|
|
makeFlameletTimed pos vel levelInt maycid size time w
|
|
= set randGen g $ over particles' ((:) theFlamelet) w
|
|
-- $ flareAt' white 0.01 0.1 pos w
|
|
where theFlamelet =
|
|
Pt' { _ptPict' = blank
|
|
, _ptUpdate' = moveFlamelet levelInt rot
|
|
, _btVel' = vel
|
|
, _btColor' = red
|
|
, _btPos' = pos
|
|
, _btPassThrough' = maycid
|
|
, _btWidth' = size
|
|
, _btTimer' = time
|
|
, _btHitEffect' = destroyOnImpact (doFlameDam 1) noEff noEff
|
|
}
|
|
(rot ,g) = randomR (0,3) $ _randGen w
|
|
|
|
makeFlamelet :: Point2 -> Point2 -> Int -> Maybe Int -> Float -> World -> World
|
|
makeFlamelet pos vel levelInt maycid size w = set randGen g $ over particles' ((:) theFlamelet) w
|
|
where theFlamelet =
|
|
Pt' { _ptPict' = blank
|
|
, _ptUpdate' = moveFlamelet levelInt rot
|
|
, _btVel' = vel
|
|
, _btColor' = red
|
|
, _btPos' = pos
|
|
, _btPassThrough' = maycid
|
|
, _btWidth' = size
|
|
, _btTimer' = 20
|
|
, _btHitEffect' = destroyOnImpact (doFlameDam 1) noEff noEff
|
|
}
|
|
(rot ,g) = randomR (0.5,1.5) $ _randGen w
|
|
moveFlamelet :: Int -> Float -> World -> Particle' -> (World, Maybe Particle')
|
|
moveFlamelet levelInt rot w pt =
|
|
case _btTimer' pt of
|
|
time | time <= 0 -> (w, Nothing)
|
|
| otherwise -> (damcrs, mvPt)
|
|
where sp = _btPos' pt
|
|
vel = _btVel' pt
|
|
ep = sp +.+ vel
|
|
size = _btWidth' pt
|
|
siz2 = size + 0.2
|
|
mvPt = Just $ pt {_btTimer' = time - 1, _btPos' = ep, _ptPict' = thepicture
|
|
, _btPassThrough' = Nothing
|
|
,_btVel' = 0.8 *.* vel}
|
|
damcrs = foldr ($) w $ map dodam $ filter closeCrs $ IM.elems $ _creatures w
|
|
closeCrs cr = dist ep (_crPos cr) < _crRad cr + size
|
|
dodam cr = over (creatures . ix (_crID cr) . crState . crDamage)
|
|
((:) $ Flaming 3 sp ep ep)
|
|
pic = onLayerL [levelInt,3] $ uncurry translate ep
|
|
$ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
|
|
white (dark red)
|
|
)
|
|
$ rotate (0 - ( 0.1 * fromIntegral time + rot))
|
|
$ scale sc sc
|
|
$ polygon [(-size,-size),(size,-size),(size,size),(-size,size)]
|
|
piu = onLayerL [levelInt,1] $ uncurry translate ep
|
|
$ color (dark red) $ rotate (0 - (rot - 0.1 * fromIntegral time))
|
|
$ scale s1 s1
|
|
$ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2)
|
|
glow = onLayerL [levelInt,0] $ uncurry translate ep
|
|
$ color (withAlpha 0.01 red)
|
|
$ circleSolid 30
|
|
sc = (*) 2 $ log $ 1 + fromIntegral time / 20
|
|
s1 = (*) 2 $ log $ 2 + fromIntegral time / 40
|
|
s2 = 0.5 * (sc + s1)
|
|
thepicture = pictures [pic , piu , pi2 , glow]
|
|
pi2 = onLayerL [levelInt,2] $ uncurry translate ep
|
|
$ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
|
|
orange (dark red)
|
|
)
|
|
$ rotate (0 - (rot + 0.2 * fromIntegral time))
|
|
$ scale s2 s2
|
|
$ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2)
|
|
|
|
|
|
doFlameDam :: Int -> Particle' -> Point2 -> Creature -> World -> World
|
|
doFlameDam amount pt p cr = over (creatures . ix (_crID cr) . crState . crDamage)
|
|
((:) $ Flaming amount sp p ep)
|
|
where sp = _btPos' pt
|
|
ep = sp +.+ _btVel' pt
|
|
|
|
makeSmokeAt'' :: Point2 -> Float -> Int -> Point2 -> World -> World
|
|
makeSmokeAt'' vel scal time p w = over particles' ((:) smokeP) w
|
|
where smokeP = Particle'
|
|
--{ _ptPict' = onLayerL [levLayer PtLayer - 1] $ uncurry translate p $ color black $ circleSolid 1
|
|
{ _ptPict' = onLayerL [levLayer PtLayer ] $ uncurry translate p $ color black $ circleSolid 1
|
|
, _ptUpdate' = moveSmoke'' scal time p vel
|
|
}
|
|
|
|
moveSmoke'' :: Float -> Int -> Point2 -> Point2 -> World -> Particle' -> (World, Maybe Particle')
|
|
moveSmoke'' scal time p vel w pt
|
|
| time > 0 = (w, Just $ pt { _ptPict' = pic
|
|
, _ptUpdate' = moveSmoke'' scal (time-1) pNew vel
|
|
})
|
|
| time > -50 = (w, Just $ pt { _ptPict' = pi1
|
|
, _ptUpdate' = moveSmoke'' scal (time-1) pNew vel
|
|
})
|
|
| otherwise = (w, Nothing)
|
|
where pNew = p +.+ vel
|
|
pic = onLayerL [levLayer PtLayer]
|
|
--pic = onLayerL [levLayer PtLayer - 1]
|
|
$ uncurry translate pNew
|
|
$ color (greyN 0.5) $ circleSolid $ (21 - fromIntegral time) * scal
|
|
pi1 = pictures $ reverse
|
|
[(onLayerL [levLayer PtLayer]
|
|
$ uncurry translate pNew
|
|
$ color (withAlpha (0.3 * (1 + fromIntegral time /50)) (greyN 0.5))
|
|
$ circleSolid $ 21 * scal)
|
|
,
|
|
--(onLayerL [levLayer BgLayer+1]
|
|
(onLayerL [levLayer PtLayer]
|
|
$ uncurry translate pNew
|
|
$ color (withAlpha (1 + fromIntegral time /50) (greyN 0.5))
|
|
$ circleSolid $ 21 * scal)
|
|
]
|
|
|
|
makeColorSmokeAt :: Color -> Point2 -> Float -> Int -> Point2 -> World -> World
|
|
makeColorSmokeAt col vel scal time p w = over projectiles (IM.insert n smP) w
|
|
where n = newProjectileKey w
|
|
smP = Projectile
|
|
{ _ptPos = p
|
|
, _ptStartPos = p
|
|
, _ptVel = vel
|
|
, _ptPict = onLayer PtLayer $ uncurry translate p $ color col $ circleSolid 1
|
|
, _ptID = n
|
|
, _ptUpdate = moveColorSmoke col scal time n
|
|
}
|
|
|
|
moveColorSmoke :: Color -> Float -> Int -> Int -> World -> World
|
|
moveColorSmoke col scal time i w
|
|
| time > 0
|
|
= set (projectiles . ix i . ptPict) pic
|
|
. set (projectiles . ix i . ptUpdate) (moveColorSmoke col scal (time-1) i)
|
|
. set (projectiles . ix i . ptPos) newPos
|
|
. setVel
|
|
$ w
|
|
| time > -50
|
|
= set (projectiles . ix i . ptPict) pi1
|
|
. set (projectiles . ix i . ptUpdate) (moveColorSmoke col scal (time-1) i)
|
|
. set (projectiles . ix i . ptPos) newPos
|
|
. setVel
|
|
$ w
|
|
| otherwise
|
|
= over projectiles (IM.delete i) w
|
|
where oldPos = _ptPos $ _projectiles w IM.! i
|
|
newPos = oldPos +.+ (_ptVel $ _projectiles w IM.! i)
|
|
setVel = over (projectiles . ix i . ptVel) $ (*.*) 0.99
|
|
pic = onLayer PtLayer $ uncurry translate newPos $ color col $ circleSolid $ (21 - fromIntegral time) * scal
|
|
pi1 = onLayer PtLayer $ uncurry translate newPos
|
|
$ color (withAlpha (1 + fromIntegral time /50) col)
|
|
$ circleSolid $ 21 * scal
|
|
|
|
damCrsOnLine :: Int -> Point2 -> Point2 -> World -> World
|
|
damCrsOnLine dam p1 p2 = over creatures (IM.map damIfOnLine)
|
|
where damIfOnLine cr | circOnLine p1 p2 (_crPos cr) (_crRad cr)
|
|
= over crHP (\hp -> hp - dam) cr
|
|
| otherwise = cr
|
|
|
|
tempLightForAt :: Int -> Point2 -> World -> World
|
|
tempLightForAt i p w = w & tempLightSources %~ (:) (tLightAt i p)
|