87 lines
2.2 KiB
Haskell
87 lines
2.2 KiB
Haskell
module Dodge.RadarSweep
|
|
( aRadarPulse
|
|
, updateRadarSweep
|
|
) where
|
|
|
|
import NewInt
|
|
import Color
|
|
import Data.Maybe
|
|
import Dodge.Data.World
|
|
import Dodge.Zoning.Wall
|
|
import Geometry
|
|
import qualified IntMapHelp as IM
|
|
import LensHelp
|
|
|
|
aRadarPulse :: ObjectType -> Creature -> World -> World
|
|
aRadarPulse ob cr =
|
|
cWorld . lWorld . radarSweeps
|
|
.:~ RadarSweep
|
|
{ _rsTimer = 100
|
|
, _rsRad = 0
|
|
, _rsPos = _crPos cr
|
|
, _rsObject = ob
|
|
}
|
|
|
|
updateRadarSweep ::
|
|
World -> RadarSweep -> (World, Maybe RadarSweep)
|
|
updateRadarSweep w pt
|
|
| x < 1 = (w, Nothing)
|
|
| otherwise =
|
|
( putBlips w
|
|
, Just $ pt & rsRad .~ r & rsTimer .~ (x -1)
|
|
)
|
|
where
|
|
p = _rsPos pt
|
|
ob = _rsObject pt
|
|
blipsF = findBlips ob
|
|
bf = makeBlip ob
|
|
x = _rsTimer pt
|
|
putBlips = cWorld . lWorld . radarBlips .++~ blips
|
|
blips = map bf circPoints
|
|
circPoints = blipsF p r w
|
|
r = fromIntegral (400 - x * 4)
|
|
|
|
findBlips :: ObjectType -> Point2 -> Float -> World -> [Point2]
|
|
findBlips ob = case ob of
|
|
ObCreature -> crBlips
|
|
ObItem -> itemBlips
|
|
ObWall -> wallBlips
|
|
_ -> undefined
|
|
|
|
makeBlip :: ObjectType -> Point2 -> RadarBlip
|
|
makeBlip ob = case ob of
|
|
ObCreature -> blipAt 8 (withAlpha 0.2 green) 50
|
|
ObWall -> blipAt 2 red 50
|
|
ObItem -> blipAt 6 blue 50
|
|
_ -> undefined
|
|
|
|
-- | Radar blip at a point.
|
|
blipAt :: Float -> Color -> Int -> Point2 -> RadarBlip
|
|
blipAt r col i p =
|
|
RadarBlip
|
|
{ _rbColor = col
|
|
, _rbTime = i
|
|
, _rbMaxTime = i
|
|
, _rbRad = r
|
|
, _rbPos = p
|
|
}
|
|
|
|
crBlips :: Point2 -> Float -> World -> [Point2]
|
|
crBlips p r = IM.elems . IM.filter f . fmap _crPos . IM.filter g . _creatures . _lWorld . _cWorld
|
|
where
|
|
f q = dist p q <= r && dist p q > r - 100
|
|
g cr = _crID cr /= 0
|
|
|
|
itemBlips :: Point2 -> Float -> World -> [Point2]
|
|
itemBlips p r = IM.elems . IM.filter f . fmap _flItPos . _unNIntMap . _floorItems . _lWorld . _cWorld
|
|
where
|
|
f q = dist p q <= r && dist p q > r - 4
|
|
|
|
wallBlips :: Point2 -> Float -> World -> [Point2]
|
|
wallBlips p r w =
|
|
mapMaybe (uncurry (intersectCircSegFirst p r) . _wlLine) $
|
|
map (over wlLine swp) (wlsNearCirc p r w)
|
|
<> wlsNearCirc p r w
|
|
where
|
|
swp (a, b) = (b, a)
|