Create datatypes for radar sweeps

2022-07-19 20:38:56 +01:00
parent b4c0074d43
commit 29e25f61d3
14 changed files with 139 additions and 123 deletions
@@ -0,0 +1,77 @@
+module Dodge.RadarSweep where
+import Dodge.Data
+import Dodge.Zone
+import Color
+import Geometry
+import LensHelp
+
+import qualified Data.IntMap.Strict as IM
+import qualified Streaming.Prelude as S
+
+aRadarPulse :: Object -> Creature -> World -> World
+aRadarPulse ob cr = 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 = radarBlips .++~ blips
+    blips = map bf circPoints
+    circPoints = blipsF p r w
+    r = fromIntegral (400 - x*4)
+
+findBlips :: Object -> Point2 -> Float -> World -> [Point2]
+findBlips ob = case ob of
+    ObCreature -> crBlips
+    ObItem      -> itemBlips
+    ObWall      -> wallBlips
+    _ -> undefined
+makeBlip :: Object -> 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
+  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
+  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)
+