490 lines
17 KiB
Haskell
490 lines
17 KiB
Haskell
{- |
|
|
Creation of particles in the world.
|
|
-}
|
|
module Dodge.WorldEvent.SpawnParticle
|
|
where
|
|
import Dodge.Data
|
|
import Dodge.Creature.State.Data
|
|
import Dodge.Base
|
|
import Dodge.Base.Zone
|
|
import Dodge.Base.Collide
|
|
import Dodge.Picture
|
|
import Dodge.Picture.Layer
|
|
import Dodge.WorldEvent.HitEffect
|
|
import Dodge.WorldEvent.ThingsHit
|
|
import Dodge.WorldEvent.Cloud
|
|
import Dodge.WorldEvent.Flash
|
|
import Dodge.Particle.Bullet.Draw
|
|
import Dodge.Particle.Bullet.Update
|
|
import Dodge.SoundLogic
|
|
import Dodge.SoundLogic.Synonyms
|
|
import Dodge.RandomHelp
|
|
--import Dodge.Debug
|
|
import Picture
|
|
import Geometry
|
|
--import Geometry.Data
|
|
import qualified IntMapHelp as IM
|
|
|
|
import Control.Lens
|
|
import System.Random
|
|
import Control.Monad.State
|
|
import Data.Function (on)
|
|
import Data.List
|
|
import Data.Maybe
|
|
import Data.Tuple
|
|
|
|
aFlameParticle
|
|
:: Int -- ^ Timer
|
|
-> Point2 -- ^ Position
|
|
-> Point2 -- ^ Velocity
|
|
-> Maybe Int -- ^ Creature id
|
|
-> Particle
|
|
aFlameParticle t pos vel maycid = Pt'
|
|
{ _ptDraw = drawFlame vel
|
|
, _ptUpdate' = moveFlame vel
|
|
, _btVel' = vel
|
|
, _btColor' = red
|
|
, _btPos' = pos
|
|
, _btPassThrough' = maycid
|
|
, _btWidth' = 4
|
|
, _btTimer' = t
|
|
, _btHitEffect' = destroyOnImpact (doFlameDam 1) noEff noEff
|
|
}
|
|
|
|
drawFlame
|
|
:: Point2 -- ^ Rotate direction
|
|
-> Particle -> Picture
|
|
drawFlame rotd pt = thePic
|
|
where
|
|
ep = _btPos' pt
|
|
thePic = pictures
|
|
[ glow
|
|
, aPic 3 prot2 18 (V2 (scaleChange + 1) 2 ) red
|
|
, aPic 4 prot 19 (V2 (scaleChange + 0.5) 1.5) orange
|
|
, aPic 5 prot3 20 (V2 scaleChange 1 ) white
|
|
]
|
|
aPic :: Int -> (Point2 -> Point2) -> Float -> Point2 -> Color -> Picture
|
|
aPic lay offset depth (V2 scalex scaley) col
|
|
= setLayer lay
|
|
. setDepth depth
|
|
. uncurryV translate (offset ep)
|
|
. rotate (pi * 0.5 + argV rotd)
|
|
. scale scalex scaley
|
|
. color col
|
|
$ circleSolid 5
|
|
glow = setLayer 1 $ setDepth 0.3 $ uncurryV translate ep
|
|
$ circleSolidCol (withAlpha 0 orange) (withAlpha 0.02 orange) 50
|
|
time = _btTimer' pt
|
|
scaleChange
|
|
| time < 80 = 3
|
|
| otherwise = 3 - (fromIntegral time - 80) * 0.2
|
|
prot p' = p' +.+ rotateV (fromIntegral time) (V2 0 1)
|
|
prot2 p' = p' +.+ rotateV (negate $ fromIntegral time) (V2 0 1)
|
|
prot3 p' = p' +.+ rotateV (2 + fromIntegral time * 0.1) (V2 0 2)
|
|
|
|
{- TODO: add generalised area damage particles/hiteffects. -}
|
|
moveFlame
|
|
:: Point2 -- ^ Rotation direction
|
|
-> World
|
|
-> Particle
|
|
-> (World, Maybe Particle)
|
|
moveFlame rotd w pt
|
|
| time <= 0 = (smokeGen w, Nothing)
|
|
| otherwise = case thingsHitExceptCr (_btPassThrough' pt) sp ep w of
|
|
((_,E3x1 _):_) -> (soundAndGlare damcrs , mvPt')
|
|
(thing@(p,E3x2 wl):_) -> (fst $ hiteff [thing] damcrs , rfl wl p)
|
|
_ -> (soundAndGlare damcrs , mvPt)
|
|
where
|
|
time = _btTimer' pt
|
|
soundAndGlare = soundFrom Flame fireSound 2 500 . over worldEvents ((.) $ flameGlareAt ep)
|
|
sp = _btPos' pt
|
|
vel = _btVel' pt
|
|
ep = sp +.+ vel
|
|
mvPt = Just $ pt {_btTimer' = time - 1, _btPos' = ep
|
|
, _btPassThrough' = Nothing
|
|
,_btVel' = 0.98 *.* vel}
|
|
mvPt' = Just $ pt {_btTimer' = time - 1, _btPos' = ep
|
|
, _btPassThrough' = Nothing
|
|
,_btVel' = 0.7 *.* vel}
|
|
damcrs = foldr (\cr -> fst . hiteff [(ep,E3x1 cr)]) w
|
|
$ filter closeCrs
|
|
$ IM.elems $ _creatures w
|
|
closeCrs cr = dist ep (_crPos cr)
|
|
< _crRad cr + 10 - min 9 (max 0 (fromIntegral time - 80))
|
|
+ 5 * angleCoeff (angleVV (ep -.- _crPos cr) rotd)
|
|
angleCoeff x = abs $ 1 - abs ( (x * 2 - pi) / pi )
|
|
hiteff = _btHitEffect' pt pt
|
|
rfl wl p = Just $ pt
|
|
{ _btTimer' = time -1
|
|
, _btPos' = pOut p
|
|
, _btVel' = reflV wl
|
|
}
|
|
pOut p = p +.+ safeNormalizeV (sp -.- p)
|
|
reflV wall = (0.3 *.* reflectIn (uncurry (-.-) . swap $ _wlLine wall) vel )
|
|
+.+ (0.2 *.* vel)
|
|
smokeCol = fst $ randomR (0.2,0.5) (_randGen w)
|
|
smokeGen = makeFlamerSmokeAt smokeCol ep
|
|
|
|
makeFlameletTimed
|
|
:: Point2 -- ^ Position
|
|
-> Float -- ^ z position
|
|
-> Point2 -- ^ Velocity
|
|
-> Maybe Int -- ^ Creature id
|
|
-> Float -- ^ Size
|
|
-> Int -- ^ Timer
|
|
-> World
|
|
-> World
|
|
makeFlameletTimed (V2 x y) z vel maycid size time w = w
|
|
& randGen .~ g
|
|
& particles %~ (theFlamelet :)
|
|
where
|
|
theFlamelet = PtZ
|
|
{ _ptDraw = drawFlameletZ rot
|
|
, _ptUpdate' = moveFlamelet
|
|
, _btVel' = vel
|
|
, _btColor' = red
|
|
, _btPos' = V2 x y
|
|
, _btPassThrough' = maycid
|
|
, _btWidth' = size
|
|
, _btTimer' = time
|
|
, _btHitEffect' = destroyOnImpact (doFlameDam 1) noEff noEff
|
|
, _ptZ = z
|
|
}
|
|
(rot ,g) = randomR (0,3) $ _randGen w
|
|
|
|
drawFlameletZ
|
|
:: Float -- ^ Rotation
|
|
-> Particle
|
|
-> Picture
|
|
drawFlameletZ rot pt = pictures
|
|
[ setLayer 5 pic
|
|
, setLayer 4 pi2
|
|
, setLayer 3 piu
|
|
, setLayer 1 glow
|
|
]
|
|
where
|
|
z = _ptZ pt
|
|
sp = _btPos' pt
|
|
vel = _btVel' pt
|
|
ep = sp +.+ vel
|
|
size = _btWidth' pt
|
|
siz2 = size + 0.2
|
|
time = _btTimer' pt
|
|
glow = setDepth 19 $ uncurryV translate ep
|
|
$ circleSolidCol (withAlpha 0 red) (withAlpha 0.05 red) 30
|
|
piu = setDepth (z + 20)
|
|
. uncurryV translate ep
|
|
. color (dark red)
|
|
. rotate (negate (rot - 0.1 * fromIntegral time))
|
|
. scale s1 s1
|
|
$ polygon (rectNSWE siz2 (-siz2) (-siz2) siz2)
|
|
pi2 = setDepth (z + 20)
|
|
. uncurryV translate ep
|
|
. color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
|
|
orange (dark red)
|
|
)
|
|
. rotate (negate (rot + 0.2 * fromIntegral time))
|
|
. scale s2 s2
|
|
$ polygon (rectNSWE siz2 (-siz2) (-siz2) siz2)
|
|
pic = setDepth (z + 20)
|
|
. uncurryV translate ep
|
|
. color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
|
|
white (dark red)
|
|
)
|
|
. rotate (negate ( 0.1 * fromIntegral time + rot))
|
|
. scale sc sc
|
|
$ polygon $ map toV2 [(-size,-size),(size,-size),(size,size),(-size,size)]
|
|
sc = (*) 2 $ log $ 1 + fromIntegral time / 20
|
|
s1 = (*) 2 $ log $ 2 + fromIntegral time / 40
|
|
s2 = 0.5 * (sc + s1)
|
|
|
|
drawFlamelet
|
|
:: Float -- ^ Rotation
|
|
-> Particle
|
|
-> Picture
|
|
drawFlamelet rot pt = setLayer 1 $ pictures [pic , piu , pi2 , glow]
|
|
where
|
|
sp = _btPos' pt
|
|
vel = _btVel' pt
|
|
ep = sp +.+ vel
|
|
size = _btWidth' pt
|
|
siz2 = size + 0.2
|
|
time = _btTimer' pt
|
|
glow = setDepth 19 $ uncurryV translate ep
|
|
$ circleSolidCol (withAlpha 0 red) (withAlpha 0.05 red) 30
|
|
piu = setDepth 20
|
|
. uncurryV translate ep
|
|
. color (dark red)
|
|
. rotate (negate (rot - 0.1 * fromIntegral time))
|
|
. scale s1 s1
|
|
. polygon
|
|
$ rectNSWE siz2 (-siz2) (-siz2) siz2
|
|
pi2 = setDepth 20.2
|
|
. uncurryV translate ep
|
|
. color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
|
|
orange (dark red)
|
|
)
|
|
. rotate (negate (rot + 0.2 * fromIntegral time))
|
|
. scale s2 s2
|
|
. polygon
|
|
$ rectNSWE siz2 (-siz2) (-siz2) siz2
|
|
pic = setDepth 20.4
|
|
. uncurryV translate ep
|
|
. color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
|
|
white (dark red)
|
|
)
|
|
. rotate (negate ( 0.1 * fromIntegral time + rot))
|
|
. scale sc sc
|
|
$ polygon $ map toV2 [(-size,-size),(size,-size),(size,size),(-size,size)]
|
|
sc = (*) 2 $ log $ 1 + fromIntegral time / 20
|
|
s1 = (*) 2 $ log $ 2 + fromIntegral time / 40
|
|
s2 = 0.5 * (sc + s1)
|
|
{- Update of a flamelet.
|
|
Applies movement and attaches damage to nearby creatures. -}
|
|
moveFlamelet :: World -> Particle -> (World, Maybe Particle)
|
|
moveFlamelet w pt
|
|
| _btTimer' pt <= 0 = ( w, Nothing)
|
|
| otherwise = (damcrs, mvPt)
|
|
where
|
|
sp = _btPos' pt
|
|
vel = _btVel' pt
|
|
ep = sp +.+ vel
|
|
size = _btWidth' pt
|
|
mvPt = Just $ pt & btTimer' -~ 1
|
|
& btPos' .~ ep
|
|
& btPassThrough' .~ Nothing
|
|
& btVel' .~ 0.8 *.* vel
|
|
damcrs = w & creatures %~ IM.map damifclose
|
|
isClose cr = dist ep (_crPos cr) < _crRad cr + size
|
|
damifclose cr
|
|
| isClose cr = cr & crState . crDamage %~ ( Flaming 3 sp ep ep : )
|
|
| otherwise = cr
|
|
-- | At writing the radius is half the size of the effect area
|
|
makeGasCloud
|
|
:: Point2 -- ^ Position
|
|
-> Point2 -- ^ Velocity
|
|
-> World
|
|
-> World
|
|
makeGasCloud pos vel w = w
|
|
& clouds %~ (theCloud :)
|
|
& randGen .~ g
|
|
where
|
|
theCloud = Cloud
|
|
{ _clPos = pos
|
|
, _clVel = vel
|
|
, _clPict = \_ -> onLayer CrLayer $ color (withAlpha 0.1 col)
|
|
$ circleSolid 20
|
|
, _clRad = 10
|
|
, _clTimer = 400
|
|
, _clType = GasCloud
|
|
-- , _clEffect = cloudPoisonDamage
|
|
}
|
|
(col, g) = runState (takeOne [green,yellow]) $ _randGen w
|
|
|
|
{-
|
|
Attach poison cloud damage to creatures near cloud.
|
|
-}
|
|
cloudPoisonDamage :: Cloud -> World -> World
|
|
cloudPoisonDamage c w = w & creatures %~ flip (foldr (IM.adjust doDam)) damagedCrs
|
|
where
|
|
damagedCrs = IM.keys $ IM.filter f $ creaturesNearPoint (_clPos c) w
|
|
f cr = dist (_crPos cr) (_clPos c) < _crRad cr + _clRad c + 10
|
|
doDam cr = cr & crState . crDamage %~ (:) (PoisonDam 1)
|
|
makeTeslaArcAt :: Point2 -> Float -> Particle
|
|
makeTeslaArcAt pos dir = LinearParticle
|
|
{ _ptPoints = [pos]
|
|
, _ptDraw = drawTeslaArc
|
|
, _ptUpdate' = moveTeslaArc pos dir
|
|
, _ptTimer = 2
|
|
, _ptColor = white
|
|
}
|
|
drawTeslaArc :: Particle -> Picture
|
|
drawTeslaArc pt = pic
|
|
where
|
|
ps' = _ptPoints pt
|
|
pic = setLayer 1 $ pictures
|
|
[ setDepth 20.5 $ color (_ptColor pt) $ line ps'
|
|
, setDepth 20 $ color (withAlpha 0.02 cyan) $ lineOfThickness 20 ps'
|
|
, setDepth 20 $ color (withAlpha 0.02 cyan) $ lineOfThickness 25 ps'
|
|
, setDepth 20 $ color (withAlpha 0.02 cyan) $ lineOfThickness 30 ps'
|
|
]
|
|
-- todo: fix electrical damage location
|
|
moveTeslaArc
|
|
:: Point2 -- ^ Emmission position
|
|
-> Float -- ^ Emmission direction
|
|
-> World
|
|
-> Particle
|
|
-> (World, Maybe Particle)
|
|
moveTeslaArc p d w pt
|
|
| t == 2 =
|
|
(foldr damCrs w hitCrs & randGen .~ g
|
|
& createSpark 8 nc q2 (argV sv + d1) Nothing
|
|
, Just $ pt & ptTimer -~ 1
|
|
& ptPoints .~ ps'
|
|
& ptColor .~ theColor)
|
|
| t < 1 = (w , Nothing)
|
|
| otherwise = (w , Just $ pt & ptTimer -~ 1)
|
|
where
|
|
t = _ptTimer pt
|
|
ps = take 15 $ p : map f (crsLightChain p d 0 w)
|
|
f (E3x1 cr) = _crPos cr
|
|
f (E3x2 p1) = p1
|
|
f (E3x3 p1) = p1
|
|
ps' = lightningMids d pers ps
|
|
pers = evalState (sequence $ repeat $ randInCirc 5) $ _randGen w
|
|
(nc,g) = randomR (0::Int,11) $ _randGen w
|
|
theColor = f2 nc
|
|
f2 0 = cyan
|
|
f2 1 = azure
|
|
f2 _ = white
|
|
f1 (E3x1 cr) = Just $ _crID cr
|
|
f1 _ = Nothing
|
|
hitCrs = mapMaybe f1 $ take 14 $ crsLightChain p d 0 w
|
|
damCrs cid = over (creatures . ix cid . crState . crDamage) (Electrical 5 cpos cpos cpos :)
|
|
where
|
|
cpos = _crPos (_creatures w IM.! cid)
|
|
q1 = last $ init ps'
|
|
q2 = last ps'
|
|
hitWall = reflectPointWalls q1 ((2 *.* q2) -.- q1) $ wallsNearPoint q1 w
|
|
(d1,_) = randomR (-0.7,0.7) $ _randGen w
|
|
sv = maybe (q2 -.- q1) snd hitWall
|
|
|
|
{-
|
|
Finds a point somewhere roughly inbetween two points.
|
|
-}
|
|
lightningMid :: Float -> Point2 -> Point2 -> Point2
|
|
lightningMid d p1 p2 = (0.25 *.* (p1 +.+ p2)) +.+ 0.5 *.* p3
|
|
where p3 = errorClosestPointOnLine 1 p1 (p1 +.+ unitVectorAtAngle d) p2
|
|
|
|
{-
|
|
Finds extra middle points between successive points in a list of points.
|
|
-}
|
|
lightningMids :: Float -> [Point2] -> [Point2] -> [Point2]
|
|
lightningMids d1 (p:pers) (p1:p3:ps)
|
|
= let p2 = p +.+ lightningMid d1 p1 p3
|
|
d2 = argV $ p3 -.- p2
|
|
in p1 : p2 : lightningMids d2 pers (p3:ps)
|
|
lightningMids _ _ ps = ps
|
|
|
|
{-
|
|
Finds a list of hit things from a given point.
|
|
'E3x1' objects are creatures, 'E3x2' objects are points on walls, 'E3x3' objects are points in space.
|
|
-}
|
|
crsLightChain :: Point2 -> Float -> Float -> World -> [Either3 Creature Point2 Point2]
|
|
crsLightChain p d wlAttract w
|
|
= case crOrWallSensitive p d wlAttract w of
|
|
E3x1 cr -> E3x1 cr : crsLightChain (_crPos cr) (argV (_crPos cr -.- p))
|
|
(min 1 (wlAttract + 0.3)) w
|
|
E3x2 p1 -> [E3x2 p1]
|
|
E3x3 p1 -> E3x3 p1 : crsLightChain p1 (dChange + argV (p1 -.- p)) (min 1 (wlAttract + 0.3)) (set randGen g w)
|
|
-- where (dChange, g) = (0, _randGen w)
|
|
where (dChange, g) = randomR (-0.05,0.05) $ _randGen w
|
|
|
|
{-
|
|
Finds whether a creature or wall is in front of a given point and direction.
|
|
Evaluates to a creature as an 'E3x1' or a wall as an 'E3x2'.
|
|
Has a parameter to tweak how attracted the test is to walls.
|
|
-}
|
|
crOrWallSensitive
|
|
:: Point2 -- ^ Start point
|
|
-> Float -- ^ Direction (radians)
|
|
-> Float -- ^ Wall attraction parameter
|
|
-> World
|
|
-> Either3 Creature Point2 Point2
|
|
crOrWallSensitive p dir wlAttract w =
|
|
fromMaybe (E3x3 $ p +.+ rotateV dir (V2 arcLen 0))
|
|
. listToMaybe
|
|
. sortBy (compare `on` g)
|
|
$ catMaybes [cr,wlp]
|
|
where
|
|
cr = E3x1 <$> nearestCrInFront p dir 100 w
|
|
wlp = fmap E3x2
|
|
. listToMaybe
|
|
. sortBy (compare `on` dist p)
|
|
$ mapMaybe
|
|
( fmap fst
|
|
. (\p1 -> reflectPointWalls p p1 $ wallsNearPoint p w)
|
|
. (+.+) p
|
|
. (\d -> rotateV d (V2 100 0))
|
|
. (+ dir)
|
|
. (* wlAttract)
|
|
)
|
|
[-(3*pi/8),-pi/4,-pi/8,0,pi/8,pi/4,3*pi/8]
|
|
g (E3x2 p1) = 100 + dist p p1 -- tweak makes it more likely to hit crs first
|
|
--g (E3x2 p1) = dist p p1 - 100 -- tweak makes it more likely to hit walls first
|
|
g (E3x1 cr1) = dist p $ _crPos cr1
|
|
g _ = 0
|
|
(arcLen,_) = randomR (25,50) $ _randGen w
|
|
-- BUG: can hit crs through walls
|
|
{- Finds whether a creature or wall is in front of a given point and direction.
|
|
Evaluates to a creature as an 'E3x1' or a wall as an 'E3x2'. -}
|
|
crOrWall :: Point2 -> Float -> World -> Either3 Creature Point2 Point2
|
|
crOrWall p dir w = fromMaybe (E3x3 $ p +.+ rotateV dir (V2 arcLen 0))
|
|
$ listToMaybe $ sortBy (compare `on` g)
|
|
$ catMaybes [cr,wlp]
|
|
where
|
|
cr = E3x1 <$> nearestCrInFront p dir 100 w
|
|
wlp = fmap E3x2
|
|
$ listToMaybe
|
|
$ sortBy (compare `on` dist p)
|
|
$ mapMaybe
|
|
( fmap fst
|
|
. (\p1 -> reflectPointWalls p p1 $ wallsNearPoint p w)
|
|
. (+.+) p
|
|
. (\d -> rotateV d (V2 100 0))
|
|
. (+) dir
|
|
)
|
|
[-(3*pi/8),-pi/4,-pi/8,0,pi/8,pi/4,3*pi/8]
|
|
--[-pi/4,-pi/8,0,pi/8,pi/4]
|
|
g (E3x2 p1) = 100 + dist p p1 -- tweak makes it more likely to hit crs first
|
|
--g (E3x2 p1) = dist p p1 - 100 -- tweak makes it more likely to hit walls first
|
|
g (E3x1 cr1) = dist p $ _crPos cr1
|
|
g _ = 0
|
|
(arcLen,_) = randomR (25,50) $ _randGen w
|
|
-- | Create a spark.
|
|
-- 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
|
|
= w & worldEvents %~ ( (over particles (spark :) . sparkFlashAt pos') . )
|
|
where
|
|
spark = Bul'
|
|
{ _ptDraw = drawBul
|
|
, _ptUpdate' = mvGenBullet
|
|
, _btVel' = rotateV dir (V2 5 0)
|
|
, _btColor' = numColor colid
|
|
, _btTrail' = [pos]
|
|
, _btPassThrough' = maycid
|
|
, _btWidth' = 1
|
|
, _btTimer' = time
|
|
, _btHitEffect' = destroyOnImpact sparkEff noEff noEff
|
|
}
|
|
pos' = pos +.+ rotateV dir (V2 5 0)
|
|
sparkEff bt p cr
|
|
= creatures . ix (_crID cr) . crState . crDamage %~ ( SparkDam 1 sp p ep : )
|
|
where
|
|
sp = head (_btTrail' bt)
|
|
ep = sp +.+ _btVel' bt
|
|
createSparkCol :: Int -> Color -> Point2 -> Float -> Maybe Int -> World -> World
|
|
createSparkCol time col pos dir maycid w
|
|
= w & worldEvents %~ ( (over particles (spark :) . sparkFlashAt pos') . )
|
|
where
|
|
spark = Bul'
|
|
{ _ptDraw = drawBul
|
|
, _ptUpdate' = mvGenBullet
|
|
, _btVel' = rotateV dir (V2 5 0)
|
|
, _btColor' = col
|
|
, _btTrail' = [pos]
|
|
, _btPassThrough' = maycid
|
|
, _btWidth' = 1
|
|
, _btTimer' = time
|
|
, _btHitEffect' = destroyOnImpact sparkEff noEff noEff
|
|
}
|
|
pos' = pos +.+ rotateV dir (V2 5 0)
|
|
sparkEff bt p cr
|
|
= creatures . ix (_crID cr) . crState . crDamage %~ ( SparkDam 1 sp p ep : )
|
|
where
|
|
sp = head (_btTrail' bt)
|
|
ep = sp +.+ _btVel' bt
|
|
|