193 lines
7.1 KiB
Haskell
193 lines
7.1 KiB
Haskell
{- |
|
|
Effects centered on creatures.
|
|
These are typically item effects, and typical occur when an item is explictly used. -}
|
|
module Dodge.Item.Weapon.UseEffect
|
|
where
|
|
import Dodge.Data
|
|
import Dodge.Base
|
|
import Dodge.Picture.Layer
|
|
--import Dodge.Item.Weapon.Decoration
|
|
import Dodge.Item.Weapon.TriggerType
|
|
--import Dodge.WorldEvent.Flash
|
|
--import Dodge.WorldEvent.ThingsHit
|
|
import Picture
|
|
import Geometry
|
|
|
|
import Data.Maybe
|
|
import Control.Lens
|
|
import qualified Data.IntMap.Strict as IM
|
|
{- | Creates an outwardly increasing circle that draws creatures, even those behind walls. -}
|
|
aSonarPulse :: Creature -> World -> World
|
|
aSonarPulse cr = over particles (sonarPulseAt (_crPos cr) :)
|
|
{- | Creates an outwardly increasing circle that displays walls, even those behind other walls. -}
|
|
aRadarPulse :: Creature -> World -> World
|
|
aRadarPulse cr = over particles (radarPulseAt (_crPos cr) :)
|
|
{- | Radar blip at a point. -}
|
|
blipAt :: Point2 -> Color -> Int -> Particle
|
|
blipAt p col i = Particle
|
|
{_ptDraw = const blank
|
|
,_ptUpdate' = mvBlip p col i i
|
|
}
|
|
|
|
mvBlip :: Point2 -> Color
|
|
-> Int -- ^ Max possible timer value
|
|
-> Int -- ^ Current timer value
|
|
-> World -> Particle -> (World, Maybe Particle)
|
|
mvBlip _ _ _ 0 w _ = (w, Nothing)
|
|
mvBlip p col maxt t w pt =
|
|
(w
|
|
, Just $ pt & ptUpdate' .~ mvBlip p col maxt (t-1)
|
|
& ptDraw .~ ( const
|
|
. setDepth (-0.5)
|
|
. setLayer 1
|
|
. uncurry translate p
|
|
. color (withAlpha (fromIntegral t / fromIntegral maxt) col)
|
|
$ circleSolid 2 )
|
|
)
|
|
{- | An outwardly increasing circle that draws creatures, even those behind walls. -}
|
|
sonarPulseAt :: Point2 -> Particle
|
|
sonarPulseAt p = Particle { _ptDraw = const blank , _ptUpdate' = mvSonar 100 p }
|
|
|
|
mvSonar
|
|
:: Int -- ^ Timer
|
|
-> Point2 -- ^ Center of expanding circle
|
|
-> World -> Particle -> (World, Maybe Particle)
|
|
mvSonar 0 _ w _ = (w, Nothing)
|
|
mvSonar x p w pt = (w, Just $ pt {_ptDraw = const pic
|
|
,_ptUpdate' = mvSonar (x-1) p
|
|
}
|
|
)
|
|
where
|
|
pic = setDepth (-0.5) . setLayer 1 $ pictures crBlips
|
|
crBlips = mapMaybe crBlip $ IM.elems $ _creatures w
|
|
crBlip cr | dist cpos p < r + crad && dist cpos p > r - (crad + 100)
|
|
= Just $ colHelper (0.5 * (1 - (r - dist cpos p) /100))
|
|
$ uncurry translate cpos $ circleSolid crad
|
|
| otherwise = Nothing
|
|
where crad = _crRad cr
|
|
cpos = _crPos cr
|
|
r = fromIntegral (500 - x*5)
|
|
--sweepPics = [colHelper 0.05 $ uncurry translate p $ thickCircle r 5 ]
|
|
globalAlpha | x > 10 = 1
|
|
| otherwise = fromIntegral x / 10
|
|
colHelper y = color (withAlpha (y * globalAlpha) green)
|
|
{- |
|
|
An outwardly increasing circle that displays walls, even those behind other walls. -}
|
|
radarPulseAt :: Point2 -> Particle
|
|
radarPulseAt p = Particle
|
|
{ _ptDraw = const blank
|
|
, _ptUpdate' = mvRadar 50 p
|
|
}
|
|
|
|
mvRadar
|
|
:: Int -- ^ Timer
|
|
-> Point2 -- ^ Center of expanding circle
|
|
-> World -> Particle -> (World, Maybe Particle)
|
|
mvRadar 0 _ w _ = (w, Nothing)
|
|
mvRadar x p w pt =
|
|
( putBlips w
|
|
, Just $ pt {_ptDraw = const pic ,_ptUpdate' = mvRadar (x-1) p }
|
|
)
|
|
where
|
|
pic = onLayerL [levLayer ShadowLayer, 1] $ pictures sweepPics
|
|
putBlips = over worldEvents ( over particles (blips ++) . )
|
|
blips = map (\bp -> blipAt bp (withAlpha (0.5*globalAlpha) red) 50) circPoints
|
|
circPoints = mapMaybe (\wl -> uncurry collidePointCircCorrect (_wlLine wl) r p)
|
|
$ map (over wlLine swp) (IM.elems $ wallsAlongCirc p r w)
|
|
++ IM.elems (wallsAlongCirc p r w)
|
|
swp (a,b) = (b,a)
|
|
r = fromIntegral (800 - x*16)
|
|
sweepPics = [--colHelper 0.1 $ uncurry translate p $ thickCircle r 15
|
|
--,colHelper 0.06 $ uncurry translate p $ thickCircle (r-5) 5
|
|
--,colHelper 0.03 $ uncurry translate p $ thickCircle (r-10) 5
|
|
]
|
|
globalAlpha | x > 10 = 1
|
|
| otherwise = fromIntegral x / 10
|
|
--colHelper y = color (withAlpha (y * globalAlpha) red)
|
|
|
|
aTractorBeam
|
|
:: Int -- ^ Color id
|
|
-> Creature -- ^ Creature id
|
|
-> World
|
|
-> World
|
|
aTractorBeam col cr w
|
|
= set (creatures . ix cid . crInv . ix itRef . itUse)
|
|
(shoot $ aTractorBeam ((col + 1) `mod` 10))
|
|
$ over projectiles (IM.insert i (tractorBeamAt col i pos dir)) w
|
|
where
|
|
i = newProjectileKey w
|
|
cid = _crID cr
|
|
pos = _crPos cr +.+ ((_crRad cr + 10) *.* unitVectorAtAngle dir)
|
|
dir = _crDir cr
|
|
itRef = _crInvSel cr
|
|
|
|
tractorBeamAt :: Int -> Int -> Point2 -> Float -> Projectile
|
|
tractorBeamAt colID i pos dir = Projectile
|
|
{ _pjPos = pos
|
|
, _pjStartPos = p'
|
|
, _pjVel = d
|
|
, _pjPict = blank
|
|
, _pjID = i
|
|
, _pjUpdate = updateTractor colID 10 i
|
|
}
|
|
where
|
|
d = unitVectorAtAngle dir
|
|
p' = pos +.+ 400 *.* d
|
|
|
|
{- |
|
|
The interaction of this with objects, walls etc needs more thought. -}
|
|
updateTractor :: Int -> Int -> Int -> World -> World
|
|
updateTractor colID time i w
|
|
| time > 0 = set (projectiles . ix i . pjUpdate) (updateTractor colID (time-1) i)
|
|
$ set (projectiles . ix i . pjPict) pic
|
|
$ over creatures (IM.map tractCr)
|
|
$ over floorItems (IM.map tractFlIt)
|
|
w
|
|
| otherwise = over projectiles (IM.delete i) w
|
|
where
|
|
tractCr cr
|
|
| circOnSeg p1 p2 cP 10
|
|
= over crPos (\p ->
|
|
p -.- m *.* ((0.3/ x) *.* q +.+ (f y *.* p4))
|
|
) cr
|
|
| otherwise = cr
|
|
where
|
|
x = abs y + 1
|
|
y = errorClosestPointOnLineParam 1 p1 p3 cP
|
|
cP = _crPos cr
|
|
m | dist cP p1 < 350 = 1
|
|
| otherwise = (400 - dist cP p1) / 50
|
|
tractFlIt it | circOnSeg p1 p2 iP 10
|
|
= over flItPos (\p -> p -.- m *.*
|
|
( (0.3/ x) *.* q +.+ (f y *.* p4))
|
|
) it
|
|
| otherwise = it
|
|
where x = abs y + 1
|
|
y = errorClosestPointOnLineParam 2 p1 p3 iP
|
|
iP = _flItPos it
|
|
m | dist iP p1 < 350 = 1
|
|
| otherwise = (410 - dist iP p1) / 60
|
|
pj = _projectiles w IM.! i
|
|
q = _pjVel pj
|
|
p1 = _pjPos pj
|
|
p' = _pjStartPos pj
|
|
p2 = maybe p' fst $ reflectPointWalls p1 p' $ wallsNearPoint p' w
|
|
p4 = vNormal p5
|
|
p5 = errorNormalizeV 12 $ p2 -.- p1
|
|
p3 = p1 +.+ p4
|
|
g x | x > 5 = (10 - x) / 5
|
|
| x > 1 = 1
|
|
| x > -1 = x
|
|
| x > -5 = -1
|
|
| otherwise = (x - 10) / 5
|
|
f x = g x / 50
|
|
col = mixColors 0.5 0.5 white blue
|
|
px z = (fromIntegral time + 5) *.* z
|
|
pz z = fromIntegral time * 10 *.* z
|
|
pic = setLayer 1 $ onLayer PtLayer $ color (withAlpha 0.05 col)
|
|
$ polygon [ p1 +.+ px p4
|
|
, p1 -.- 10 *.* p5
|
|
, p1 -.- px p4
|
|
, (p' -.- pz p5) -.- px p4
|
|
, (p' -.- pz p5) +.+ px p4]
|