908 lines
41 KiB
Haskell
908 lines
41 KiB
Haskell
module Dodge.WorldActions where
|
|
|
|
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
|
|
$ over tempLightSources ((:) $ tLightFade 20 150 intensityF p)
|
|
$ fs
|
|
$ over particles (IM.insert n exp)
|
|
w
|
|
where n = newParticleKey w
|
|
exp = Particle
|
|
{ _ptPos = p
|
|
, _ptStartPos = p
|
|
, _ptVel = (0,0)
|
|
, _ptPict = blank
|
|
, _ptID = n
|
|
, _ptUpdate = explosionWaveDamage 6 p n
|
|
}
|
|
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 = map (pushAgainstWalls . (+.+) p . (*.*) 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
|
|
fs w = foldr ($) w newFs
|
|
pushAgainstWalls q = fromMaybe q $ fmap (\(x,y)-> x +.+ y)
|
|
$ collidePointWalls p q $ wallsNearPoint q w
|
|
fadeFac x | x > 10 = 0
|
|
| otherwise = 1 - fromIntegral x / 10
|
|
intensityF x | x < 10 = 1 / (10 - fromIntegral x)
|
|
| otherwise = 1
|
|
|
|
explosionWaveDamage :: Int -> Point2 -> Int -> World -> World
|
|
explosionWaveDamage 0 p ptid = over particles (IM.delete ptid)
|
|
explosionWaveDamage time p ptid
|
|
= set (particles . ix ptid . ptUpdate) (explosionWaveDamage (time-1) p ptid)
|
|
. shockWaveDamage p rad 20
|
|
. set (particles . ix ptid . ptPict) shockwavePic
|
|
. lowLightRadAt white 0.3 75 150 p
|
|
where shockwavePic = onLayer PtLayer $ uncurry translate p $ color (withAlpha 0.9 white)
|
|
$ thickCircle rad (thickness*2)
|
|
thickness = max 0 $ sqrt $ (fromIntegral time - 2) * 8
|
|
rad = 40 - thickness
|
|
|
|
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
|
|
|
|
|
|
-- makeTremorAt :: Int -> Point -> Float -> Particle
|
|
-- makeTremorAt i pos d = Particle
|
|
-- { _ptPos = (0,0)
|
|
-- , _ptStartPos = (0,0)
|
|
-- , _ptVel = (0,0)
|
|
-- , _ptPict = Line [(0,0),(0,0)]
|
|
-- , _ptID = i
|
|
-- , _ptUpdate = moveTremor [pos] 200 pos d i
|
|
-- }
|
|
--
|
|
-- moveTremor :: [Point] -> Int -> Point -> Float -> Int -> World -> World
|
|
-- moveTremor ps t p1 d i w
|
|
-- | t <= -30 = over particles (IM.delete i) . over partUnder (IM.delete i) $ w
|
|
-- | t <= 0 = set (particles . ix i . ptUpdate) (moveTremor ps (t-1) p1 d i)
|
|
-- . over partUnder
|
|
-- (IM.insert i (lineOfThickness (0.1*(fromIntegral t + 30)) ps)) $ w
|
|
-- | otherwise = case hitWall of
|
|
-- Nothing -> upUndPict . set randGen g . shakeCrs .
|
|
-- shatterAt p1 pl $ shatterAt p1 pr
|
|
-- $ set (particles . ix i . ptUpdate) (moveTremor (p3:ps) (t-1) p3 d i)
|
|
-- $ damCrsOnLine 10 p1 p3 w
|
|
-- Just (pw,pRef) -> set (particles . ix i . ptUpdate) (moveTremor ps (t-1) p1 (argV pRef) i) w
|
|
-- where p2 = p1 +.+ 5 *.* unitVectorAtAngle d
|
|
-- pl = p1 +.+ rotateV (d + pi/4) (75,0)
|
|
-- pr = p1 +.+ rotateV (d - pi/4) (75,0)
|
|
-- hitWall = collidePointWalls p1 p3 $ wallsAlongLine p1 p3 w
|
|
-- (d1,g) = randomR (0,2*pi) $ _randGen w
|
|
-- v = unitVectorAtAngle d1
|
|
-- p3 = p2 +.+ 5 *.* v
|
|
-- shakeCrs = over creatures (IM.map shCr)
|
|
-- shCr cr | dist p1 (_crPos cr) < 75 = over crPos (+.+ v) cr
|
|
-- | otherwise = cr
|
|
-- upUndPict = over partUnder (IM.insert i pic)
|
|
-- pic = pictures [color white $ lineOfThickness 3 [p3,head ps]
|
|
-- ,lineOfThickness 3 ps]
|
|
--
|
|
-- makeTremorAt' :: Int -> Point -> Particle
|
|
-- makeTremorAt' i pos = Particle
|
|
-- { _ptPos = (0,0)
|
|
-- , _ptStartPos = (0,0)
|
|
-- , _ptVel = (0,0)
|
|
-- , _ptPict = Line [(0,0),(0,0)]
|
|
-- , _ptID = i
|
|
-- , _ptUpdate = rotateTremorAround 10 pos i
|
|
-- }
|
|
--
|
|
-- rotateTremorAround :: Int -> Point -> Int -> World -> World
|
|
-- rotateTremorAround 0 p i w = over particles (IM.delete i) w
|
|
-- rotateTremorAround t p i w = set (particles . ix i . ptUpdate) (rotateTremorAround (t-1) p i)
|
|
-- $ foldr ($) w shatters
|
|
-- where rot d = rotateV $ d + fromIntegral t * pi / 7
|
|
-- ds = fmap (\x -> fromIntegral x * pi / 2.5) [0..4]
|
|
-- shatters = map (\d -> shatterAt p (p +.+ rot d (300,0))) ds
|
|
--
|
|
-- shatterAt :: Point -> Point -> World -> World
|
|
-- shatterAt p1 p2 w = case wlHit of
|
|
-- Just (p,v,col) -> makeFallingBlock col (f1 p) (f2 v)
|
|
-- $ set randGen g w
|
|
-- _ -> w
|
|
-- where wlHit = collidePointWallsNormCol p1 p2 $ wallsNearPoint p2 w
|
|
-- f1 q = q +.+ 5 *.* errorNormalizeV 10 (p2 -.- p1)
|
|
-- (d,g) = randomR (-0.5,0.5) $ _randGen w
|
|
-- f2 v' = rotateV d $ 3 *.* errorNormalizeV 11 v'
|
|
--
|
|
-- fallingWall :: Int -> Color -> Point -> Float -> Particle
|
|
-- fallingWall pid col p d
|
|
-- = Particle
|
|
-- { _ptPos = p
|
|
-- , _ptStartPos = p
|
|
-- , _ptVel = rotateV d (3,0)
|
|
-- , _ptPict = Line [(0,0),(0,0)]
|
|
-- , _ptID = pid
|
|
-- , _ptUpdate = moveFallingWall 10 p d col pid
|
|
-- }
|
|
--
|
|
-- moveFallingWall :: Int -> Point -> Float -> Color -> Int -> World -> World
|
|
-- moveFallingWall 0 p d col i w = over particles (IM.delete i) $ b1 $ b2 w
|
|
-- where b1 = makeFallingBlock col (p +.+ ( 3, 3)) (rotateV d (0,5))
|
|
-- b2 = makeFallingBlock col (p +.+ (-3,-3)) (rotateV d (0,1))
|
|
-- moveFallingWall t p d col i w
|
|
-- = set (particles . ix i . ptUpdate) (moveFallingWall (t-1) np d col i)
|
|
-- $ set (particles . ix i . ptPict) pic
|
|
-- w
|
|
-- where np = p +.+ 1 *.* unitVectorAtAngle d
|
|
-- pic = uncurry translate p $ rotate (-radToDeg d)
|
|
-- $ color col $ polygon [(-6,-6)
|
|
-- ,(-6, 6)
|
|
-- ,( 6, 6)
|
|
-- ,( 6,-6)
|
|
-- ]
|
|
--
|
|
-- makeFallingBlock :: Color -> Point -> Point -> World -> World
|
|
-- makeFallingBlock col p v w
|
|
-- = over particles (IM.insert i $ fallingBlock i col p v) w
|
|
-- where i = newParticleKey w
|
|
--
|
|
-- fallingBlock :: Int -> Color -> Point -> Point -> Particle
|
|
-- fallingBlock pid col p v
|
|
-- = Particle
|
|
-- { _ptPos = p
|
|
-- , _ptStartPos = p
|
|
-- , _ptVel = v
|
|
-- , _ptPict = Line [(0,0),(0,0)]
|
|
-- , _ptID = pid
|
|
-- , _ptUpdate = moveFallingBlock 10 p v col pid
|
|
-- }
|
|
--
|
|
-- moveFallingBlock :: Int -> Point -> Point -> Color -> Int -> World -> World
|
|
-- moveFallingBlock 0 p v col i w = over particles (IM.delete i) w
|
|
-- moveFallingBlock t p v col i w
|
|
-- = case hitCr of
|
|
-- Nothing -> set (particles . ix i . ptUpdate) (moveFallingBlock (t-1) np v col i)
|
|
-- $ set (particles . ix i . ptPict) pic
|
|
-- w
|
|
-- Just (p1,v1,crID) -> over particles (IM.delete i)
|
|
-- $ over (creatures . ix crID . crHP) (\hp -> hp - 1) w
|
|
-- where np = p +.+ v
|
|
-- pic = uncurry translate p $ rotate (-radToDeg (argV v))
|
|
-- $ color col $ polygon [(-3,-3)
|
|
-- ,(-3, 3)
|
|
-- ,( 3, 3)
|
|
-- ,( 3,-3)
|
|
-- ]
|
|
-- hitCr = reflectCircCreatures 4 p np $ _creatures w
|
|
|
|
|
|
-- 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')
|
|
-- . lowLightAt' 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' = threeEff' 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)
|
|
. flareAt' white 0.005 0.03 pos')
|
|
-- . lowLightAt' 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' = threeEff' 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
|
|
|
|
flareAt :: Color -> Point2 -> World -> World
|
|
flareAt c p = flareAt' c 0.02 0.5 p
|
|
|
|
flareAt' :: Color -> Float -> Float -> Point2 -> World -> World
|
|
flareAt' col alphax alphay p
|
|
= over particles' ((:) (flashColAt col alphax p))
|
|
. lowLightColAt col alphay p
|
|
|
|
|
|
tLightFade :: Int -> Float -> (Int -> Float) -> Point2 -> TempLightSource
|
|
tLightFade 0 rmax intensityF p =
|
|
TLS { _tlsPos = p
|
|
, _tlsRad = rmax
|
|
, _tlsIntensity = intensityF 0
|
|
, _tlsUpdate = \w _ -> (w, Nothing)
|
|
}
|
|
tLightFade i rmax intensityF p =
|
|
TLS { _tlsPos = p
|
|
, _tlsRad = rmax
|
|
, _tlsIntensity = intensityF i
|
|
, _tlsUpdate = \w _ -> (w, Just $ tLightFade (i-1) rmax intensityF p)
|
|
}
|
|
|
|
tLightRad :: Int -> Float -> Float -> Point2 -> TempLightSource
|
|
tLightRad 0 rmax rmin p =
|
|
TLS { _tlsPos = p
|
|
, _tlsRad = rmax
|
|
, _tlsIntensity = 0.5
|
|
, _tlsUpdate = \w _ -> (w, Nothing)
|
|
}
|
|
tLightRad i rmax rmin p =
|
|
TLS { _tlsPos = p
|
|
, _tlsRad = rmax
|
|
, _tlsIntensity = 0.5
|
|
, _tlsUpdate = \w _ -> (w, Just $ tLightRad (i-1) rmax rmin p)
|
|
}
|
|
|
|
tLightAt i p = tLightRad i 100 0 p
|
|
|
|
flareWidth :: Float -> Float -> Float -> Int -> Color -> Float -> Float -> Point2 -> World -> World
|
|
flareWidth len wdth rad rays col ax ay p
|
|
= over particles' ((:) (flashRadAt rad col ax p))
|
|
. lowLightWidthAt len wdth col ay rays rad p
|
|
|
|
flareRad :: Float -> Int -> Color -> Float -> Float -> Point2 -> World -> World
|
|
flareRad rad rays col ax ay p
|
|
= over particles' ((:) (flashRadAt rad col ax p))
|
|
. lowLightRadAt col ay rays rad p
|
|
|
|
flashRadAt :: Float -> Color -> Float -> Point2 -> Particle'
|
|
flashRadAt rad col alphax (x,y) =
|
|
Particle'
|
|
{ _ptPict' = pictures $
|
|
map (\i -> onLayerL [levLayer PtLayer]
|
|
$ color (withAlpha alphax col) $ translate x y $ circleSolid i
|
|
)
|
|
[rad/5,2*rad/5,3*rad/5,4*rad/5,rad]
|
|
, _ptUpdate' = ptTimer' 1
|
|
}
|
|
|
|
flashColAt :: Color -> Float -> Point2 -> Particle'
|
|
flashColAt col alphax (x,y) =
|
|
Particle'
|
|
{ _ptPict' = pictures $
|
|
map (\i -> onLayerL [levLayer PtLayer]
|
|
$ color (withAlpha alphax col) $ translate x y $ circleSolid i
|
|
)
|
|
[20,25,30,35,40,45,50]
|
|
, _ptUpdate' = ptTimer' 1
|
|
}
|
|
lowLightWidthAt :: Float -> Float -> Color -> Float -> Int -> Float -> Point2 -> World -> World
|
|
lowLightWidthAt len wdth col alphay rays rad p w = foldr (lowLightWidthHit len wdth col alphay p) w ps
|
|
where ps = map ((+.+) p) $ nRaysRad rays rad
|
|
|
|
lowLightRadAt :: Color -> Float -> Int -> Float -> Point2 -> World -> World
|
|
lowLightRadAt col alphay rays rad p w = foldr (lowLightColHit col alphay p) w ps
|
|
where ps = map ((+.+) p) $ nRaysRad rays rad
|
|
|
|
lowLightColAt :: Color -> Float -> Point2 -> World -> World
|
|
lowLightColAt col alphay p w = foldr (lowLightColHit col alphay p) w ps
|
|
where ps = map ((+.+) p) $ nRaysRad 20 30
|
|
|
|
lowLightDirected :: Color -> Float -> Point2 -> Point2 -> [Float] -> World -> World
|
|
lowLightDirected col alpha a b angles w
|
|
= foldr (\angle w' -> lowLightColHit col alpha a (a +.+ rotateV angle b) w') w angles
|
|
|
|
lowLightColHit :: Color -> Float -> Point2 -> Point2 -> World -> World
|
|
lowLightColHit col alphay a b w
|
|
= case thingsHitLongLine a b w of
|
|
((p, E3x2 wall):_)
|
|
-> over particles' ((:) (wallGlareCol col alphay p wall)) w
|
|
((p, E3x1 cr):_)
|
|
-> over afterParticles' ((:) (crGlareCol col alphay p cr)) w
|
|
_ -> w
|
|
|
|
wallGlareCol :: Color -> Float -> Point2 -> Wall -> Particle'
|
|
wallGlareCol col alphay p wl = wallGlareWidth 10 5 col alphay p wl
|
|
|
|
crGlareCol :: Color -> Float -> Point2 -> Creature -> Particle'
|
|
crGlareCol col alphay p cr = crGlareWidth 5 col alphay p cr
|
|
|
|
lowLightWidthHit :: Float -> Float -> Color -> Float -> Point2 -> Point2 -> World -> World
|
|
lowLightWidthHit len wdth col alphay a b w
|
|
= case thingsHitLongLine a b w of
|
|
((p, E3x2 wall):_)
|
|
-> over particles' ((:) (wallGlareWidth len wdth col alphay p wall)) w
|
|
((p, E3x1 cr):_)
|
|
-> over afterParticles' ((:) (crGlareWidth wdth col alphay p cr)) w
|
|
_ -> w
|
|
|
|
wallGlareWidth :: Float -> Float -> Color -> Float -> Point2 -> Wall -> Particle'
|
|
wallGlareWidth len wdth col alphay p wl =
|
|
Particle'
|
|
{ _ptPict' = onLayerL [levLayer GloomLayer + 2] $ l
|
|
, _ptUpdate' = ptTimer' 1
|
|
}
|
|
where l = color (withAlpha alphay col) $ lineOfThickness wdth $ [p +.+ x, p -.- x]
|
|
x = len *.* ( normalizeV $ a -.- b)
|
|
(a:b:_) = _wlLine wl
|
|
|
|
crGlareWidth :: Float -> Color -> Float -> Point2 -> Creature -> Particle'
|
|
crGlareWidth wdth col alphay p cr =
|
|
Particle'
|
|
{ _ptPict' = onLayerL [levLayer GloomLayer + 2] $ l cp
|
|
--{ _ptPict' = [(blank, [levLayer WlLayer + 2])]
|
|
, _ptUpdate' = \w pt -> (w, Just $ pt {_ptPict' = onLayerL [levLayer GloomLayer + 2] $ upp cid w
|
|
,_ptUpdate' = ptTimer' 0
|
|
}
|
|
)
|
|
}
|
|
where l x = uncurry translate x
|
|
$ rotate (pi*0.5 + argV (p -.- x))
|
|
$ color (withAlpha alphay col)
|
|
$ thickArc 0 (pi/2) (_crRad cr) wdth
|
|
cp = _crPos cr
|
|
cid = _crID cr
|
|
upp cid' w' = case w' ^? creatures . ix cid . crPos of
|
|
Just y -> l y
|
|
--Just p -> uncurry translate p $ circleSolid 5
|
|
_ -> blank
|
|
|
|
muzFlareAt :: Point2 -> World -> World
|
|
muzFlareAt p = over particles' ((:) (muzzleFlareAt p))
|
|
. lowLightAt p
|
|
|
|
muzzleFlareAt :: Point2 -> Particle'
|
|
muzzleFlareAt (x,y) =
|
|
Particle'
|
|
{ _ptPict' = pictures
|
|
$ map (\i -> onLayer PtLayer $ color (withAlpha 0.02 white) $ translate x y $ circleSolid i
|
|
)
|
|
[20,25,30,35,40,45,50]
|
|
, _ptUpdate' = ptTimer' 1
|
|
}
|
|
|
|
ptTimer' :: Int -> World -> Particle' -> (World, Maybe Particle')
|
|
ptTimer' 0 w pt = (w, Nothing)
|
|
ptTimer' n w pt = (w, Just $ pt {_ptUpdate' = ptTimer' (n-1)})
|
|
|
|
lowLightAt :: Point2 -> World -> World
|
|
lowLightAt p w = lowLightWidthAt 10 5 white 0.5 20 30 p w
|
|
|
|
lowLightHit :: Point2 -> Point2 -> World -> World
|
|
lowLightHit a b w
|
|
= case thingsHitLongLine a b w of
|
|
((p, E3x2 wall):_)
|
|
-> over particles' ((:) (wallGlare p wall)) w
|
|
((p, E3x1 cr):_)
|
|
-> over afterParticles' ((:) (crGlare p cr)) w
|
|
_ -> w
|
|
|
|
wallGlare :: Point2 -> Wall -> Particle'
|
|
wallGlare p wl = wallGlareWidth 10 5 white 0.5 p wl
|
|
|
|
crGlare :: Point2 -> Creature -> Particle'
|
|
crGlare = crGlareCol white 0.5
|
|
-- crGlare p cr =
|
|
-- Particle'
|
|
-- { _ptPict' = [(l, [levLayer WlLayer + 2])]
|
|
-- , _ptUpdate' = ptTimer' 1
|
|
-- }
|
|
-- where l = uncurry translate cp
|
|
-- $ rotate (90 - (radToDeg $ argV (p -.- cp)))
|
|
-- $ color (withAlpha 0.5 white)
|
|
-- $ thickArc 0 180 (_crRad cr) 5
|
|
-- -- where l = rotate (radToDeg $ argV (cp -.- p)) $ uncurry translate cp $ color (withAlpha 0.5 white) $ thickArc 0 25 (_crRad cr) 5
|
|
-- cp = _crPos cr
|
|
|
|
|
|
lowLightAt' :: Point2 -> World -> World
|
|
lowLightAt' p w = foldr (lowLightHit' p) w ps
|
|
where ps = map ((+.+) p) $ nRaysRad 20 30
|
|
|
|
lowLightHit' :: Point2 -> Point2 -> World -> World
|
|
lowLightHit' a b w
|
|
= case thingsHitLongLine a b w of
|
|
((p, E3x2 wall):_)
|
|
-> over particles' ((:) (wallGlare' p wall)) w
|
|
_ -> w
|
|
|
|
wallGlare' :: Point2 -> Wall -> Particle'
|
|
wallGlare' p wl = wallGlareWidth 5 5 white 0.1 p wl
|
|
|
|
noEff _ _ _ = id
|
|
|
|
threeEff' ::
|
|
( Particle' -> Point2 -> Creature -> World -> World ) ->
|
|
( Particle' -> Point2 -> Wall -> World -> World ) ->
|
|
( Particle' -> Point2 -> ForceField -> World -> World ) ->
|
|
Particle' -> (Point2, Either3 Creature Wall ForceField) -> World -> World
|
|
threeEff' crEff wlEff ffEff pt thing w = case thing of
|
|
(p,E3x1 cr) -> crEff pt p cr w
|
|
(p,E3x2 wl) -> wlEff pt p wl w
|
|
(p,E3x3 ff) -> ffEff pt p ff w
|
|
|
|
mvGenBullet' :: World -> Particle' -> (World, Maybe Particle')
|
|
mvGenBullet' w bt
|
|
| t <= 0 = (w, Nothing)
|
|
| t < 4 = (w, Just $ set btPassThrough' Nothing
|
|
$ set btTrail' (p:p:ps)
|
|
$ set ptPict' (bulLine col wth (p:p:ps))
|
|
$ set btTimer' (t-1) bt
|
|
)
|
|
| otherwise = case thingsHitExceptCr mcr p (p +.+ vel) w of
|
|
[] -> (w, Just $ set btPassThrough' Nothing
|
|
$ set btTrail' (p +.+ vel :p:ps)
|
|
$ set ptPict' (bulLine col wth (p +.+ vel:p:ps))
|
|
$ set btTimer' (t-1) bt
|
|
)
|
|
((hitp,thing):_)
|
|
-> ( hiteff bt (hitp,thing) w
|
|
, Just $ set btPassThrough' Nothing
|
|
$ set btTrail' (hitp:p:ps)
|
|
$ set ptPict' (bulLine col wth (hitp:p:ps))
|
|
$ set btTimer' 3 bt
|
|
)
|
|
where mcr = _btPassThrough' bt
|
|
col = _btColor' bt
|
|
(p:ps) = _btTrail' bt
|
|
vel = _btVel' bt
|
|
hiteff = _btHitEffect' bt
|
|
wth = _btWidth' bt
|
|
t = _btTimer' bt
|
|
|
|
bulLine c w = setLayer 1 . bulLinea c w
|
|
|
|
bulLinea :: Color -> Float -> [Point2] -> Picture
|
|
bulLinea _ _ [] = blank
|
|
bulLinea _ _ (x:[]) = blank
|
|
bulLinea col width (a:b:[]) -- (a:b:[])
|
|
= onLayer HPtLayer $ pictures $ reverse
|
|
[polygonCol $ zip (wedgeGeom width b a) $ [white,withAlpha 0 white,withAlpha 0 white]
|
|
,polygonCol $ zip (lineGeom (width+1.5) a b) $ [col,col,withAlpha 0 col,withAlpha 0 col]
|
|
]
|
|
bulLinea col width (a:b:c:[]) -- (a:b:[])
|
|
= onLayer HPtLayer $ pictures $ reverse
|
|
[polygonCol $ zip (wedgeGeom width b a) $ repeat white
|
|
,polygonCol $ zip (wedgeGeom width b c) $ [white,white,withAlpha 0 white]
|
|
,polygonCol $ zip (lineGeom (width+1.5) a c) $ [col,col,withAlpha 0 col,withAlpha 0 col]
|
|
]
|
|
bulLinea col width (a:b:_:c:[]) -- (a:b:[])
|
|
= onLayer HPtLayer $ pictures $ reverse
|
|
[polygonCol $ zip (wedgeGeom width b a) $ repeat white
|
|
,polygonCol $ zip (wedgeGeom width b c) $ [white,white,withAlpha 0 white]
|
|
,polygonCol $ zip (lineGeom (width+1.5) a c) $ [col,col,withAlpha 0 col,withAlpha 0 col]
|
|
]
|
|
bulLinea col width (a:b:_:_:c:_) -- (a:b:[])
|
|
= onLayer HPtLayer $ pictures $ reverse
|
|
[polygonCol $ zip (wedgeGeom width b a) $ repeat white
|
|
,polygonCol $ zip (wedgeGeom width b c) $ [white,white,withAlpha 0 white]
|
|
,polygonCol $ zip (lineGeom (width+1.5) a c) $ [col,col,withAlpha 0 col,withAlpha 0 col]
|
|
]
|
|
-- [color (withAlpha 0.5 col) $ lineOfThickness (width+1.5) [a,b]
|
|
-- ,color white $ wedgeOfThickness width a b
|
|
--bulLine col width (a:b:c:_)
|
|
-- = onLayer HPtLayer $ pictures
|
|
-- [color (withAlpha 0.5 col) $ lineOfThickness (width+1.5) [a,c]
|
|
-- ,color white $ wedgeOfThickness width a c
|
|
|
|
thingsHitExceptCr :: Maybe Int -> Point2 -> Point2 -> World
|
|
-> [(Point2, (Either3 Creature Wall ForceField))]
|
|
thingsHitExceptCr Nothing sp ep = thingsHit sp ep
|
|
thingsHitExceptCr (Just cid) sp ep = filter crNotCid . thingsHit sp ep
|
|
where crNotCid (_,(E3x1 cr)) = _crID cr /= cid
|
|
crNotCid _ = True
|
|
|
|
thingsHit :: Point2 -> Point2 -> World -> [(Point2, (Either3 Creature Wall ForceField))]
|
|
thingsHit sp ep w = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs)
|
|
where hitCrs = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr))
|
|
$ creaturesAlongLine sp ep w
|
|
crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
|
|
crs = zip crPs (map E3x1 hitCrs)
|
|
-- hitWls = wallsOnLine sp ep (f y $ f x $ _wallsZone w)
|
|
hitWls = wallsOnLine sp ep (IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1]
|
|
, b<-[y-1,y,y+1]])
|
|
(x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep))
|
|
f i m = case IM.lookup i m of Just val -> val
|
|
_ -> IM.empty
|
|
walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls)
|
|
hitPoint w = intersectSegSeg' sp ep (_wlLine w !! 0) (_wlLine w !! 1)
|
|
hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
|
|
ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs
|
|
|
|
thingsHitExceptCrLongLine :: Maybe Int -> Point2 -> Point2 -> World
|
|
-> [(Point2, (Either3 Creature Wall ForceField))]
|
|
thingsHitExceptCrLongLine Nothing sp ep = thingsHitLongLine sp ep
|
|
thingsHitExceptCrLongLine (Just cid) sp ep = filter crNotCid . thingsHitLongLine sp ep
|
|
where crNotCid (_,(E3x1 cr)) = _crID cr /= cid
|
|
crNotCid _ = True
|
|
|
|
thingsHitLongLine :: Point2 -> Point2 -> World -> [(Point2, (Either3 Creature Wall ForceField))]
|
|
--thingsHitLongLine sp ep w = crs ++ walls
|
|
thingsHitLongLine sp ep w = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs)
|
|
where hitCrs = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr))
|
|
-- $ _creatures w
|
|
$ creaturesAlongLine sp ep w
|
|
crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
|
|
--crPs = map _crPos hitCrs
|
|
crs = zip crPs (map E3x1 hitCrs)
|
|
-- hitWls = wallsOnLine sp ep (f y $ f x $ _wallsZone w)
|
|
hitWls = wallsOnLine sp ep $ wallsAlongLine sp ep w
|
|
--hitWls = wallsOnLine sp ep $ _walls w
|
|
f i m = case IM.lookup i m of Just val -> val
|
|
_ -> IM.empty
|
|
--walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls)
|
|
walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls)
|
|
hitPoint w = intersectSegSeg' sp ep (_wlLine w !! 0) (_wlLine w !! 1)
|
|
-- hitPoint w = intersectSegSeg' sp ep (_wlLine w !! 0) (_wlLine w !! 1)
|
|
hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
|
|
ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs
|
|
cr = _creatures w IM.! 0
|
|
|
|
makeFlameletTimed :: Point2 -> Point2 -> Int -> Maybe Int -> Float -> Int -> World -> World
|
|
makeFlameletTimed pos vel levelInt maycid size time w
|
|
= set randGen g $ over particles' ((:) theFlamelet)
|
|
$ 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' = threeEff' (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' = threeEff' (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 -> World -> World
|
|
makeSmokeAt p w = over particles (IM.insert n smP) w
|
|
where n = newParticleKey w
|
|
smP = Particle
|
|
{ _ptPos = p
|
|
, _ptStartPos = p
|
|
, _ptVel = (0,0)
|
|
, _ptPict = onLayer PtLayer $ uncurry translate p $ color black $ circleSolid 1
|
|
--, _ptPict = uncurry translate p $ color white $ circleSolid 30
|
|
, _ptID = n
|
|
, _ptUpdate = moveSmoke p 20 n
|
|
}
|
|
|
|
moveSmoke :: Point2 -> Int -> Int -> World -> World
|
|
moveSmoke p time i | time > 0 =
|
|
set (particles . ix i . ptPict) pic . set (particles . ix i . ptUpdate) (moveSmoke p (time-1) i)
|
|
| time > -50 =
|
|
set (particles . ix i . ptPict) pi1 . set (particles . ix i . ptUpdate) (moveSmoke p (time-1) i)
|
|
| otherwise =
|
|
over particles (IM.delete i)
|
|
|
|
where pic = onLayer PtLayer $ uncurry translate p $ color (greyN 0.5) $ circleSolid $ 21 - fromIntegral time
|
|
pi1 = onLayer PtLayer $ uncurry translate p
|
|
$ color (withAlpha (1 + fromIntegral time /50) (greyN 0.5))
|
|
$ circleSolid $ 21
|
|
|
|
makeSmokeAt' :: Float -> Int -> Point2 -> World -> World
|
|
makeSmokeAt' scal time p w = over particles (IM.insert n smP) w
|
|
where n = newParticleKey w
|
|
smP = Particle
|
|
{ _ptPos = p
|
|
, _ptStartPos = p
|
|
, _ptVel = (0,0)
|
|
, _ptPict = onLayer PtLayer $ uncurry translate p $ color black $ circleSolid 1
|
|
, _ptID = n
|
|
, _ptUpdate = moveSmoke' scal p time n
|
|
}
|
|
|
|
moveSmoke' :: Float -> Point2 -> Int -> Int -> World -> World
|
|
moveSmoke' scal p time i
|
|
| time > 0
|
|
= set (particles . ix i . ptPict) pic
|
|
. set (particles . ix i . ptUpdate) (moveSmoke' scal p (time-1) i)
|
|
| time > -50
|
|
= set (particles . ix i . ptPict) pi1
|
|
. set (particles . ix i . ptUpdate) (moveSmoke' scal p (time-1) i)
|
|
| otherwise
|
|
= over particles (IM.delete i)
|
|
where pic = onLayer PtLayer $ uncurry translate p $ color (greyN 0.5) $ circleSolid $ (21 - fromIntegral time) * scal
|
|
pi1 = onLayer PtLayer $ uncurry translate p
|
|
$ color (withAlpha (1 + fromIntegral time /50) (greyN 0.5))
|
|
$ circleSolid $ 21 * scal
|
|
|
|
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 particles (IM.insert n smP) w
|
|
where n = newParticleKey w
|
|
smP = Particle
|
|
{ _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 (particles . ix i . ptPict) pic
|
|
. set (particles . ix i . ptUpdate) (moveColorSmoke col scal (time-1) i)
|
|
. set (particles . ix i . ptPos) newPos
|
|
. setVel
|
|
$ w
|
|
| time > -50
|
|
= set (particles . ix i . ptPict) pi1
|
|
. set (particles . ix i . ptUpdate) (moveColorSmoke col scal (time-1) i)
|
|
. set (particles . ix i . ptPos) newPos
|
|
. setVel
|
|
$ w
|
|
| otherwise
|
|
= over particles (IM.delete i) w
|
|
where oldPos = _ptPos $ _particles w IM.! i
|
|
newPos = oldPos +.+ (_ptVel $ _particles w IM.! i)
|
|
setVel = over (particles . 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
|
|
|
|
|
|
thingHit :: Point2 -> Maybe (Point2,a,b) -> Maybe (Point2,c) -> Maybe (Either (Point2,a,b) (Point2,c))
|
|
thingHit p Nothing Nothing = Nothing
|
|
thingHit p (Just x) Nothing = Just (Left x)
|
|
thingHit p Nothing (Just x) = Just (Right x)
|
|
thingHit p (Just x@(p1,_,_)) (Just y@(p2,_))
|
|
| magV (p -.- p1) > magV (p -.- p2) = Just (Right y)
|
|
| otherwise = Just (Left x)
|
|
|
|
|
|
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
|