Files
loop/src/Dodge/WorldEvent/SpawnParticle.hs
T

498 lines
18 KiB
Haskell

{- |
Creation of particles in the world.
-}
module Dodge.WorldEvent.SpawnParticle
where
import Dodge.Data
import Dodge.Default
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 25 (V2 (scaleChange + 1) 2 ) $ V4 2 (-1) (-1) 0.5
, aPic 3 prot 22 (V2 (scaleChange + 0.5) 1) $ V4 1 0.5 0 2
, aPic 1 prot3 20 (V2 scaleChange 0.5 ) $ V4 1 1 1 1
]
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)
_ -> (glare $ soundAndGlare damcrs , mvPt)
where
time = _btTimer' pt
soundAndGlare = soundFrom Flame fireSound 2 500 -- . over worldEvents ((.) $ flameGlareAt ep)
glare
| time `mod` 5 == 0
= tempLightSources %~ (theTLS :)
| otherwise = id
theTLS = defaultTLS
{ _tlsPos = V3 x y 15
, _tlsRad = 70
, _tlsIntensity = V3 0.5 0 0
}
sp@(V2 x y) = _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 1 pic
, setLayer 3 piu
, setLayer 3 pi2
]
where
z = _ptZ pt
sp = _btPos' pt
vel = _btVel' pt
ep = sp +.+ vel
size = _btWidth' pt
siz2 = size + 0.2
time = _btTimer' pt
piu = setDepth (z + 25)
. uncurryV translate ep
-- . color (V4 2 (-0.5) (-0.5) 1)
. color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
(V4 2 0 0 1) (V4 2 0 0 0)
)
. rotate (negate (rot - 0.1 * fromIntegral time))
. scale s1 s1
$ polygon (rectNSWE siz2 (-siz2) (-siz2) siz2)
pi2 = setDepth (z + 25)
. uncurryV translate ep
. color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
(V4 2 1 0 0.5) (V4 0 0 0 0)
)
. 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)
(V4 1 1 1 3) (V4 1 0 0 1)
)
. rotate (negate ( 0.1 * fromIntegral time + rot))
. scale (0.5* sc) (0.5 *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 = \_ -> setLayer 2 . setDepth 30 $ color (withAlpha 0.05 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 (brightX 2 2 $ _ptColor pt) $ lineOfThickness 3 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 25 $ 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,5) $ _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.5,0.5) $ _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' = brightX 100 1.5 $ 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