155 lines
5.7 KiB
Haskell
155 lines
5.7 KiB
Haskell
module Dodge.WorldActions.Flash
|
|
where
|
|
import Dodge.Data
|
|
import Dodge.Base
|
|
|
|
import Dodge.WorldActions.ThingsHit
|
|
import Dodge.WorldActions.HelperParticle
|
|
|
|
import Picture
|
|
import Geometry
|
|
|
|
import Control.Lens
|
|
|
|
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
|
|
|
|
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
|
|
|
|
|
|
lowLightColHit :: Color -> Float -> Point2 -> Point2 -> World -> World
|
|
lowLightColHit col alphay a b w
|
|
= case thingsHitLongLine a b w of
|
|
((p, E3x2 wall):_)
|
|
-> over particles' ((:) (wallGlareWidth 10 5 col alphay p wall)) w
|
|
((p, E3x1 cr):_)
|
|
-> over particles' ((:) (crGlareCol col alphay p cr)) w
|
|
_ -> w
|
|
|
|
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
|
|
}
|
|
|
|
crGlareCol :: Color -> Float -> Point2 -> Creature -> Particle'
|
|
crGlareCol col alphay p cr = crGlareWidth 5 col alphay p cr
|
|
|
|
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
|
|
, _ptUpdate' = \w pt -> (w, Just $ pt {_ptPict' = onLayerL [levLayer GloomLayer + 2] $ upp cid w
|
|
,_ptUpdate' = ptTimer' 0
|
|
}
|
|
)
|
|
}
|
|
where l x = uncurry translate x
|
|
$ rotate (-0.25*pi + 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
|
|
_ -> blank
|
|
|
|
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
|
|
}
|
|
|
|
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
|
|
|
|
|
|
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
|
|
|
|
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
|
|
|
|
|
|
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
|
|
}
|
|
|
|
|
|
lowLightAt :: Point2 -> World -> World
|
|
lowLightAt p w = lowLightWidthAt 10 5 white 0.5 20 30 p w
|
|
|
|
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
|