85 lines
2.3 KiB
Haskell
85 lines
2.3 KiB
Haskell
module Dodge.RadarSweep where
|
|
import Dodge.Zoning.Wall
|
|
import Dodge.Data
|
|
import Color
|
|
import Geometry
|
|
import LensHelp
|
|
|
|
import Data.Maybe
|
|
import qualified IntMapHelp as IM
|
|
|
|
aRadarPulse :: ObjectType -> Creature -> World -> World
|
|
aRadarPulse ob cr = cWorld . 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 . 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 . _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 . _floorItems . _cWorld
|
|
where
|
|
f q = dist p q <= r && dist p q > r - 4
|
|
|
|
--wallBlips :: Point2 -> Float -> World -> [Point2]
|
|
--wallBlips p r w = runIdentity . S.toList_ $ S.mapMaybe (uncurry (intersectCircSegFirst p r) . _wlLine)
|
|
-- $ S.map (over wlLine swp) (wlsInsideCirc p r w)
|
|
-- <> wlsInsideCirc p r w
|
|
-- where
|
|
-- swp (a,b) = (b,a)
|
|
|
|
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)
|
|
|