Reorganise modules. Broken layout-- to be diagnosed
This commit is contained in:
@@ -0,0 +1,339 @@
|
||||
module Dodge.WorldEvent.SpawnParticle
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.WorldEvent.HitEffect
|
||||
import Dodge.WorldEvent.ThingsHit
|
||||
import Dodge.WorldEvent.Cloud
|
||||
import Dodge.WorldEvent.Flash
|
||||
import Dodge.WorldEvent.HelperParticle
|
||||
import Dodge.WorldEvent.Bullet
|
||||
import Dodge.SoundLogic
|
||||
import Dodge.RandomHelp
|
||||
import Dodge.Debug
|
||||
|
||||
import Picture
|
||||
import Geometry
|
||||
|
||||
import Control.Lens
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import System.Random
|
||||
import Control.Monad.State
|
||||
import Data.Function (on)
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
|
||||
-- take out the flame particle from makeFlame
|
||||
aFlameParticle :: Int -> Point2 -> Point2 -> Maybe Int -> 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
|
||||
}
|
||||
|
||||
makeFlame :: Point2 -> Point2 -> Maybe Int -> World -> World
|
||||
makeFlame pos vel maycid = over particles' (aFlameParticle 100 pos vel maycid : )
|
||||
|
||||
drawFlame :: Point2 -> Particle' -> Picture
|
||||
drawFlame rotd pt = thePic
|
||||
where ep = _btPos' pt
|
||||
thePic = pictures
|
||||
[ glow
|
||||
, aPic prot2 0.2998 (scaleChange + 1,2) red
|
||||
, aPic prot 0.2996 (scaleChange + 0.5,1.5) orange
|
||||
, aPic prot3 0.2994 (scaleChange,1) white
|
||||
]
|
||||
aPic :: (Point2 -> Point2) -> Float -> Point2 -> Color -> Picture
|
||||
aPic offset depth (scalex,scaley) col
|
||||
= setLayer 1
|
||||
. setDepth depth
|
||||
. uncurry translate (offset ep)
|
||||
. rotate (pi * 0.5 + argV rotd)
|
||||
. scale scalex scaley
|
||||
. color col
|
||||
$ circleSolid 5
|
||||
glow = setLayer 1 $ setDepth 0.3 $ uncurry 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 * 1) (0,1)
|
||||
prot2 p' = p' +.+ rotateV (negate $ fromIntegral time * 1) (0,1)
|
||||
prot3 p' = p' +.+ rotateV (2 + fromIntegral time * 0.1) (0,2)
|
||||
|
||||
moveFlame :: Point2 -> World -> Particle' -> (World, Maybe Particle')
|
||||
moveFlame rotd w pt
|
||||
| time <= 0 = (smokeGen w, Nothing)
|
||||
| otherwise = case thingsHitExceptCr (_btPassThrough' pt) sp ep w of
|
||||
((p,(E3x1 cr)):_) -> (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 ($) w $ map (\cr -> fst . hiteff [(ep,E3x1 cr)]) $ 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--, _ptDraw = const $ thepic $ pOut p
|
||||
}
|
||||
pOut p = p +.+ safeNormalizeV (sp -.- p)
|
||||
reflV wall = (0.3 *.* reflectIn (_wlLine wall !! 1 -.- _wlLine wall !! 0)
|
||||
vel )
|
||||
+.+
|
||||
(0.2 *.* vel)
|
||||
smokeGen = makeFlamerSmokeAt ep
|
||||
|
||||
makeFlameletTimed :: Point2 -> Point2 -> Maybe Int -> Float -> Int -> World -> World
|
||||
makeFlameletTimed pos vel maycid size time w
|
||||
= set randGen g $ over particles' ((:) theFlamelet) w
|
||||
where theFlamelet =
|
||||
Pt' { _ptDraw = drawFlamelet rot
|
||||
, _ptUpdate' = moveFlamelet
|
||||
, _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
|
||||
|
||||
drawFlamelet :: Float -> 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 0.336 $ uncurry translate ep
|
||||
$ circleSolidCol (withAlpha 0 red) (withAlpha 0.05 red) 30
|
||||
piu = setDepth 0.334 $ uncurry translate ep
|
||||
$ color (dark red) $ rotate (0 - (rot - 0.1 * fromIntegral time))
|
||||
$ scale s1 s1
|
||||
$ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2)
|
||||
pi2 = setDepth 0.332 $ 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)
|
||||
pic = setDepth 0.33 $ 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)]
|
||||
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]
|
||||
|
||||
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 = 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)
|
||||
|
||||
makeGasCloud :: Point2 -> Point2 -> World -> World
|
||||
makeGasCloud pos vel w = over clouds (IM.insert i theCloud)
|
||||
$ set randGen g w
|
||||
where i = newKey $ _clouds w
|
||||
theCloud = Cloud { _clID = i
|
||||
, _clPos = pos
|
||||
, _clVel = vel
|
||||
, _clPict = \_ -> onLayer CrLayer $ color (withAlpha 0.1 col)
|
||||
$ circleSolid 20
|
||||
, _clRad = 20
|
||||
, _clTimer = 400
|
||||
, _clEffect = cloudPoisonDamage
|
||||
}
|
||||
(col, g) = runState (takeOne [green,yellow]) $ _randGen w
|
||||
|
||||
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
|
||||
doDam cr = cr & crState . crDamage %~ (:) (PoisonDam 1)
|
||||
|
||||
makeTeslaArcAt :: Int -> Point2 -> Float -> Projectile
|
||||
makeTeslaArcAt i pos dir = Projectile
|
||||
{ _ptPos = pos
|
||||
, _ptStartPos = pos
|
||||
, _ptVel = (0,0)
|
||||
, _ptPict = onLayer PtLayer $ line [(0,0),(0,0)]
|
||||
, _ptID = i
|
||||
, _ptUpdate = moveTeslaArc pos dir i
|
||||
}
|
||||
|
||||
moveTeslaArc :: Point2 -> Float -> Int -> World -> World
|
||||
moveTeslaArc p d i w =
|
||||
set (projectiles . ix i . ptPict) pic
|
||||
$ set (projectiles . ix i . ptUpdate)
|
||||
(ptTimer 2 i)
|
||||
$ set randGen g
|
||||
$ createSpark 8 nc q2 (argV sv + d1) Nothing
|
||||
$ foldr damCrs w hitCrs
|
||||
where pic = setLayer 1 $ pictures
|
||||
[ onLayer PtLayer $ color (f2 nc) $ line ps'
|
||||
, onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 20 ps'
|
||||
, onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 25 ps'
|
||||
, onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 30 ps'
|
||||
]
|
||||
ps' = lightningMids d pers ps
|
||||
ps = take 15 $ p : map f (crsLightChain p d 0 w)
|
||||
f (E3x1 cr) = _crPos cr
|
||||
f (E3x2 p1) = p1
|
||||
f (E3x3 p1) = p1
|
||||
pers = evalState (sequence $ repeat $ randInCirc 5) $ _randGen w
|
||||
(nc,g) = randomR (0::Int,11) $ _randGen w
|
||||
f1 (E3x1 cr) = Just $ _crID cr
|
||||
f1 _ = Nothing
|
||||
hitCrs = mapMaybe f1 $ take 14 $ crsLightChain p d 0 w
|
||||
damCrs i = over (creatures . ix i . crHP) (\hp -> hp - 5)
|
||||
f2 0 = cyan
|
||||
f2 1 = azure
|
||||
f2 _ = white
|
||||
sID = newProjectileKey w
|
||||
q1 = last $ init ps'
|
||||
q2 = last ps'
|
||||
hitWall = collidePointWalls q1 ((2 *.* q2) -.- q1) $ wallsNearPoint q1 w
|
||||
(d1,_) = randomR (-0.7,0.7) $ _randGen w
|
||||
sv = fromMaybe (q2 -.- q1) $ fmap snd hitWall
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
crsLightChain' :: Point2 -> Float -> World -> [Either3 Creature Point2 Point2]
|
||||
crsLightChain' p d w
|
||||
= case crOrWall p d w of
|
||||
E3x1 cr -> E3x1 cr : crsLightChain' (_crPos cr) (argV (_crPos cr -.- p)) w
|
||||
E3x2 p1 -> [E3x2 p1]
|
||||
E3x3 p1 -> E3x3 p1 : crsLightChain' p1 (dChange + argV (p1 -.- p)) (set randGen g w)
|
||||
-- where (dChange, g) = (0, _randGen w)
|
||||
where (dChange, g) = randomR (-0.05,0.05) $ _randGen w
|
||||
|
||||
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
|
||||
|
||||
crOrWallSensitive :: Point2 -> Float -> Float -> World -> Either3 Creature Point2 Point2
|
||||
crOrWallSensitive p dir wlAttract w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0))
|
||||
$ listToMaybe $ sortBy (compare `on` g)
|
||||
$ catMaybes [cr,wlp]
|
||||
where cr = fmap E3x1 $ nearestCrInFront p dir 100 w
|
||||
wlp = fmap E3x2 $ listToMaybe
|
||||
$ sortBy (compare `on` dist p)
|
||||
$ mapMaybe
|
||||
( fmap fst
|
||||
. (\p1 -> collidePointWalls p p1 $ wallsNearPoint p w)
|
||||
. (+.+) p
|
||||
. (\d -> rotateV d (100,0))
|
||||
. (+) dir
|
||||
)
|
||||
(fmap (*wlAttract) [-(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
|
||||
(arcLen,_) = randomR (25,50) $ _randGen w
|
||||
-- BUG: can hit crs through walls
|
||||
|
||||
crOrWall :: Point2 -> Float -> World -> Either3 Creature Point2 Point2
|
||||
crOrWall p dir w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0))
|
||||
$ listToMaybe $ sortBy (compare `on` g)
|
||||
$ catMaybes [cr,wlp]
|
||||
where cr = fmap E3x1 $ nearestCrInFront p dir 100 w
|
||||
wlp = fmap E3x2 $ listToMaybe
|
||||
$ sortBy (compare `on` dist p)
|
||||
$ mapMaybe
|
||||
( fmap fst
|
||||
. (\p1 -> collidePointWalls p p1 $ wallsNearPoint p w)
|
||||
. (+.+) p
|
||||
. (\d -> rotateV d (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
|
||||
(arcLen,_) = randomR (25,50) $ _randGen 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')
|
||||
. sparkFlashAt pos')
|
||||
) w
|
||||
where spark = Bul' { _ptDraw = drawBul
|
||||
, _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
|
||||
|
||||
drawBul :: Particle' -> Picture
|
||||
drawBul pt = setLayer 1 . color white $ thickLine (take 2 $ _btTrail' pt) (_btWidth' pt)
|
||||
Reference in New Issue
Block a user