Create datatypes for radar sweeps

src/Dodge/Bullet.hs

@@ -116,7 +116,6 @@ damageThingHit bu (p,crwl) = case crwl of
   where
     dams = setFromToDams bu p
     
-
 expireAndDamage :: Float
     -> Bullet
     -> Stream (Of (Point2, Either Creature Wall)) Identity ()

src/Dodge/Data.hs

@@ -10,6 +10,7 @@ circular imports are probably not a good idea.
 {-# LANGUAGE DerivingStrategies #-}
 module Dodge.Data 
     ( module Dodge.Data
+    , module Dodge.Data.RadarSweep
     , module Dodge.Data.PosEvent
     , module Dodge.Data.EnergyBall
     , module Dodge.Data.Flame
@@ -52,6 +53,7 @@ module Dodge.Data
     , module Dodge.Data.RadarBlip
     , module Dodge.Data.PathGraph
     ) where
+import Dodge.Data.RadarSweep
 import Dodge.Data.PosEvent
 import Dodge.Data.EnergyBall
 import Dodge.Data.Flame
@@ -157,6 +159,7 @@ data World = World
     , _bullets              :: [Bullet]
     , _instantParticles     :: [Particle]
     , _particles            :: [Particle]
+    , _radarSweeps          :: [RadarSweep]
     , _energyBalls          :: [EnergyBall]
     , _posEvents            :: [PosEvent]
     , _flames               :: [Flame]
@@ -536,14 +539,7 @@ data BeamType
 {- Objects without ids.
 Update themselves, perhaps with side effects.  -}
 data Particle
-    = RadarCircleParticle
+    = LaserParticle
-        { _ptUpdate :: World -> Particle -> (World, Maybe Particle)
-        , _ptTimer  :: Int
-        , _ptRad    :: Float
-        , _ptPos    :: Point2
-        , _ptColor  :: Color
-        }
-    | LaserParticle
         { _ptUpdate :: World -> Particle -> (World, Maybe Particle)
         , _ptRange  :: Float
         , _ptDamage :: Int

src/Dodge/Data/Object.hs

@@ -11,4 +11,5 @@ data Object
     | ObLightSource
     | ObProp
     | ObTrigger
+    | ObItem
   deriving (Eq,Show,Ord,Read,Enum,Bounded)

src/Dodge/Data/RadarSweep.hs

@@ -0,0 +1,14 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
+module Dodge.Data.RadarSweep where
+import Dodge.Data.Object
+import Geometry.Data
+import Control.Lens
+
+data RadarSweep = RadarSweep
+    { _rsPos    :: Point2
+    , _rsRad    :: Float
+    , _rsObject :: Object
+    , _rsTimer  :: Int
+    }
+makeLenses ''RadarSweep

src/Dodge/Default/World.hs

@@ -44,6 +44,7 @@ defaultWorld = World
     , _instantParticles = []
     , _particles = []
     , _flames = []
+    , _radarSweeps = []
     , _sparks = []
     , _posEvents = []
     , _energyBalls = []

src/Dodge/Item/Weapon.hs

@@ -5,7 +5,6 @@ module Dodge.Item.Weapon
     , module Dodge.Item.Weapon.Shatter
     , module Dodge.Item.Weapon.TriggerType
     , module Dodge.Item.Weapon.ExtraEffect
-    , module Dodge.Item.Weapon.UseEffect
     , module Dodge.Item.Weapon.Remote
     , module Dodge.Item.Weapon.Grenade
     , module Dodge.Item.Weapon.Spawn
@@ -23,7 +22,6 @@ import Dodge.Item.Weapon.TriggerType
 import Dodge.Item.Weapon.SonicGuns
 import Dodge.Item.Weapon.Shatter
 import Dodge.Item.Weapon.ExtraEffect
-import Dodge.Item.Weapon.UseEffect
 import Dodge.Item.Weapon.Remote
 import Dodge.Item.Weapon.Grenade
 import Dodge.Item.Weapon.Spawn

src/Dodge/Item/Weapon/ExtraEffect.hs

@@ -17,9 +17,8 @@ module Dodge.Item.Weapon.ExtraEffect
 import Dodge.Data
 import Dodge.Base
 import Dodge.Zone
+import Dodge.RadarSweep
 import Dodge.SoundLogic
---import Dodge.Item.Weapon.Decoration
-import Dodge.Item.Weapon.UseEffect
 import Dodge.Item.Weapon.LaserPath
 --import Dodge.Item.Attachment.Data
 import Dodge.Creature.Test
@@ -49,10 +48,10 @@ autoEffect eff t sid itm cr w
 
 {- | Automatically send out radar pulses that detect walls.  -}
 autoRadarEffect :: Item -> Creature -> World -> World
-autoRadarEffect = autoEffect (const aWallPulse) 100 click1S
+autoRadarEffect = autoEffect (const (aRadarPulse ObWall)) 100 click1S
 {- | Automatically send out sonar pulses that detect creatures.  -}
 autoSonarEffect :: Item -> Creature -> World -> World
-autoSonarEffect = autoEffect (const aSonarPulse) 50 click1S
+autoSonarEffect = autoEffect (const (aRadarPulse ObCreature)) 50 click1S
 defaultTargeting :: Targeting
 defaultTargeting = Targeting
     { _tgPos = Nothing

src/Dodge/Item/Weapon/Radar.hs

@@ -1,11 +1,9 @@
 module Dodge.Item.Weapon.Radar where
 import Dodge.Data
---import Dodge.Picture.Layer
+import Dodge.RadarSweep
 import Dodge.Default
 import Dodge.Item.Weapon.TriggerType
 import Dodge.Item.Weapon.ExtraEffect
-import Dodge.Item.Weapon.UseEffect
---import Dodge.Item.Weapon.Remote
 import Dodge.SoundLogic
 
 import Control.Lens
@@ -34,6 +32,6 @@ autoDetector dt = defaultEquipment
 
 detectorEffect :: Detector -> Item -> Creature -> World -> World
 detectorEffect dt = case dt of
-    ITEMDETECTOR        -> const anItemFindPulse
+    ITEMDETECTOR        -> const (aRadarPulse ObItem)
-    CREATUREDETECTOR    -> const aSonarPulse
+    CREATUREDETECTOR    -> const (aRadarPulse ObCreature)
-    WALLDETECTOR        -> const aWallPulse
+    WALLDETECTOR        -> const (aRadarPulse ObWall)

src/Dodge/Item/Weapon/UseEffect.hs

@@ -1,86 +0,0 @@
-{- |
-Effects centered on creatures.
-These are typically item effects, and typical occur when an item is explictly used.  -}
-module Dodge.Item.Weapon.UseEffect 
-    ( anItemFindPulse
-    , aWallPulse
-    , aSonarPulse
-    ) where
-import Dodge.Data
-import Dodge.Zone
-import Picture
-import Geometry
-import LensHelp
-
-import qualified Data.IntMap.Strict as IM
-import qualified Streaming.Prelude as S
-{- | Creates an outwardly increasing circle that draws creatures, even those behind walls.  -}
-aSonarPulse :: Creature -> World -> World
-aSonarPulse = aRadarPulse crBlips (blipAt 8) (withAlpha 0.2 green)
-
-aWallPulse :: Creature -> World -> World
-aWallPulse = aRadarPulse wallBlips (blipAt 2) red
-
-{- | Creates an outwardly increasing circle that displays items.  -}
-anItemFindPulse :: Creature -> World -> World
-anItemFindPulse = aRadarPulse itemBlips (blipAt 6) blue
-
-aRadarPulse :: (Point2 -> Float -> World -> [Point2]) 
-    -> (Point2 -> Color -> Int -> RadarBlip)
-    -> Color
-    -> Creature 
-    -> World -> World
-aRadarPulse blipsF bf col cr = instantParticles .:~ RadarCircleParticle
-    { _ptUpdate = mvRadar blipsF bf col (_crPos cr)
-    , _ptTimer  = 100
-    , _ptRad    = 0
-    , _ptPos    = _crPos cr
-    , _ptColor  = col
-    }
-{- | Radar blip at a point.  -}
-blipAt :: Float -> Point2 -> Color -> Int -> RadarBlip
-blipAt r p col i = RadarBlip
-    {_rbColor = col
-    ,_rbTime = i
-    ,_rbMaxTime = i
-    ,_rbRad = r
-    ,_rbPos = p
-    }
-mvRadar 
-    :: (Point2 -> Float -> World -> [Point2])
-    -> (Point2 -> Color -> Int -> RadarBlip)
-    -> Color
-    -> Point2   -- ^ Center of expanding circle
-    -> World -> Particle -> (World, Maybe Particle)
-mvRadar blipsF bf col p w pt
-    | x < 1 = (w, Nothing)
-    | otherwise =
-        ( putBlips w
-        , Just $ pt & ptRad .~ r & ptTimer .~ (x-1)
-        )
-  where
-    x = _ptTimer pt
-    putBlips = radarBlips .++~ blips
-    blips = map (\bp -> bf bp (withAlpha (0.5*globalAlpha) col) 50) circPoints
-    circPoints = blipsF p r w
-    r = fromIntegral (400 - x*4)
-    globalAlpha | x > 10 = 1
-                | otherwise = fromIntegral x / 10
-
-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)
-
-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

src/Dodge/Particle/Draw.hs

@@ -11,8 +11,6 @@ drawParticle pt = case pt of
     PtTargetLaser {} -> drawTargetLaser pt
     LaserParticle {} -> drawLaser pt
     ShockLine {} -> drawSonicWave pt
-    RadarCircleParticle {} -> drawPulse pt
-
 
 drawShockwave :: Particle -> Picture
 drawShockwave pt = setDepth 20 
@@ -72,17 +70,3 @@ drawSonicWave pt = foldMap (color (_ptColor pt) . setLayer BloomNoZWrite . setDe
     . map fst)
     $ _ptPointDirs pt
 
-drawPulse :: Particle -> Picture
-drawPulse pt = setLayer DebugLayer $ pictures sweepPics
-  where
-    col = _ptColor pt
-    p = _ptPos pt
-    r = _ptRad pt
-    sweepPics = [colHelper 0.1 $ uncurryV translate p $ thickCircle r 15
-                ,colHelper 0.06 $ uncurryV translate p $ thickCircle (r-5) 5
-                ,colHelper 0.03 $ uncurryV translate p $ thickCircle (r-10) 5
-                ]
-    colHelper y = color (withAlpha (y * globalAlpha) col)
-    globalAlpha | x > 10 = 1
-                | otherwise = fromIntegral x / 10
-    x = _ptTimer pt

src/Dodge/RadarSweep.hs

@@ -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)
+

src/Dodge/RadarSweep/Draw.hs

@@ -0,0 +1,27 @@
+module Dodge.RadarSweep.Draw where
+import Dodge.Data.Object
+import Dodge.Data.RadarSweep
+import Geometry
+import Picture
+
+drawRadarSweep :: RadarSweep -> Picture
+drawRadarSweep pt = setLayer DebugLayer $ pictures sweepPics
+  where
+    col = rsObjectColor $ _rsObject pt
+    p = _rsPos pt
+    r = _rsRad pt
+    sweepPics = [colHelper 0.1 $ uncurryV translate p $ thickCircle r 15
+                ,colHelper 0.06 $ uncurryV translate p $ thickCircle (r-5) 5
+                ,colHelper 0.03 $ uncurryV translate p $ thickCircle (r-10) 5
+                ]
+    colHelper y = color (withAlpha (y * globalAlpha) col)
+    globalAlpha | x > 10 = 1
+                | otherwise = fromIntegral x / 10
+    x = _rsTimer pt
+
+rsObjectColor :: Object -> Color
+rsObjectColor ob = case ob of
+    ObWall -> red
+    ObCreature -> green
+    ObItem  -> blue
+    _ -> yellow

src/Dodge/Render/ShapePicture.hs

@@ -1,6 +1,7 @@
 module Dodge.Render.ShapePicture
     ( worldSPic
     ) where
+import Dodge.RadarSweep.Draw
 import Dodge.Item.Draw.SPic
 import Dodge.EnergyBall.Draw
 import Dodge.Creature.Picture.Awareness
@@ -88,6 +89,7 @@ cullPoint cfig w p
 extraPics :: Configuration -> World -> Picture
 extraPics cfig w = pictures (_decorations w)
     <> concatMapPic drawParticle (_particles    w)
+    <> concatMapPic drawRadarSweep (_radarSweeps    w)
     <> concatMapPic drawFlame (_flames    w)
     <> concatMapPic drawEnergyBall (_energyBalls    w)
     <> concatMapPic drawSpark (_sparks    w)

src/Dodge/Update.hs

@@ -5,6 +5,7 @@ Description : Simulation update
 -}
 module Dodge.Update ( updateUniverse ) where
 import Dodge.Data
+import Dodge.RadarSweep
 import Dodge.PosEvent
 import Dodge.Spark
 import Dodge.EnergyBall
@@ -86,6 +87,7 @@ functionalUpdate cfig w = checkEndGame
     . dbArg _worldEvents
     . updateIMl _modifications _mdUpdate
     . updateSparks 
+    . updateRadarSweeps
     . updatePosEvents 
     . updateFlames
     . updateEnergyBalls
@@ -237,6 +239,10 @@ updateEnergyBalls :: World -> World
 updateEnergyBalls w = w' & energyBalls .~ catMaybes newebs
   where
     (w',newebs) = mapAccumR moveEnergyBall w $ _energyBalls w
+updateRadarSweeps :: World -> World
+updateRadarSweeps w = w' & radarSweeps .~ catMaybes newradarSweeps
+  where
+    (w',newradarSweeps) = mapAccumR updateRadarSweep w $ _radarSweeps w
 
 updateSparks :: World -> World
 updateSparks w = w' & sparks .~ catMaybes newsparks