104 lines
2.8 KiB
Haskell
104 lines
2.8 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
|
|
module Dodge.RadarSweep (
|
|
aRadarPulse,
|
|
updateRadarSweep,
|
|
) where
|
|
|
|
import Color
|
|
import Data.Maybe
|
|
import qualified Data.Set as S
|
|
import Dodge.Data.World
|
|
import Dodge.Item.Location
|
|
import Dodge.Zoning.Wall
|
|
import Geometry
|
|
import qualified IntMapHelp as IM
|
|
import LensHelp
|
|
import NewInt
|
|
|
|
aRadarPulse ::
|
|
NewInt ItmInt ->
|
|
Maybe (NewInt ItmInt) ->
|
|
Maybe (NewInt ItmInt) ->
|
|
ObjectType ->
|
|
Creature ->
|
|
World ->
|
|
World
|
|
aRadarPulse itid mitid armitid ob cr =
|
|
cWorld . lWorld . radarSweeps
|
|
.:~ RadarSweep
|
|
{ _rsTimer = 50
|
|
, _rsRad = 0
|
|
, _rsPos = _crPos cr
|
|
, _rsObject = ob
|
|
, _rsMapper = mitid
|
|
, _rsAR = armitid
|
|
, _rsSource = itid
|
|
}
|
|
|
|
updateRadarSweep :: World -> RadarSweep -> (World, Maybe RadarSweep)
|
|
updateRadarSweep w pt
|
|
| x < 1 = (w, Nothing)
|
|
| otherwise =
|
|
( putBlips w & updatemapper
|
|
, Just $ pt & rsRad .~ r & rsTimer .~ (x -1)
|
|
)
|
|
where
|
|
updatemapper = fromMaybe id $ do
|
|
itid <- pt ^. rsMapper
|
|
return $ pointerToItemID itid . itUse . useMapperLines <>~ wps
|
|
p = _rsPos pt
|
|
ob = _rsObject pt
|
|
x = _rsTimer pt
|
|
putBlips
|
|
| isJust (pt ^. rsAR) = cWorld . lWorld . radarBlips
|
|
.++~ map
|
|
(makeBlip ob)
|
|
blips
|
|
| otherwise = id
|
|
(blips, wps) = findBlips ob p r w
|
|
r = fromIntegral (400 - x * 8)
|
|
|
|
findBlips :: ObjectType -> Point2 -> Float -> World -> ([Point2], S.Set (Point2, Point2))
|
|
findBlips ob = case ob of
|
|
OTCreature -> crBlips
|
|
OTItem -> itemBlips
|
|
OTWall -> wallBlips
|
|
_ -> undefined
|
|
|
|
makeBlip :: ObjectType -> Point2 -> RadarBlip
|
|
makeBlip ob = case ob of
|
|
OTCreature -> blipAt 8 (withAlpha 0.2 green) 50
|
|
OTWall -> blipAt 2 red 50
|
|
OTItem -> 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], S.Set (Point2, Point2))
|
|
crBlips p r = (,mempty) . 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], S.Set (Point2, Point2))
|
|
itemBlips p r = (,mempty) . IM.elems . IM.filter f . fmap _flItPos . _floorItems . _lWorld . _cWorld
|
|
where
|
|
f q = dist p q <= r && dist p q > r - 4
|
|
|
|
wallBlips :: Point2 -> Float -> World -> ([Point2], S.Set (Point2, Point2))
|
|
wallBlips p r = foldMap f . wlsNearCirc p r
|
|
where
|
|
f wl = case uncurry (intersectCircSeg p r) $ _wlLine wl of
|
|
[] -> mempty
|
|
xs -> (xs, S.singleton (wl ^. wlLine))
|