Refactor creature zoning

src/Dodge/Base/Collide.hs

@@ -40,6 +40,7 @@ module Dodge.Base.Collide
     ) where
 import Dodge.Data
 import Dodge.Zone
+import Dodge.Zoning
 import Dodge.Base.Wall
 import Geometry
 
@@ -49,6 +50,7 @@ import Control.Lens
 import Control.Monad
 import StreamingHelp
 import qualified Streaming.Prelude as S
+import qualified Data.IntSet as IS
 
 collidePoint :: Point2 -> Point2 
     -> StreamOf Wall
@@ -59,10 +61,10 @@ collidePoint sp ep = runIdentity . S.fold_ findPoint (ep, Nothing) id
     findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl
 
 overlap1SegCrs :: Point2 -> Point2 
-    -> StreamOf Creature
+    -> [Creature]
-    -> StreamOf (Point2, Creature)
+    -> [(Point2, Creature)]
 {-# INLINE overlap1SegCrs #-}
-overlap1SegCrs sp ep = S.mapMaybe 
+overlap1SegCrs sp ep = mapMaybe 
     (\cr -> (,cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep ))
 
 overlapSegCrs :: Point2 -> Point2 
@@ -172,8 +174,9 @@ circOnSomeWall p rad = runIdentity . S.any_ (uncurry (circOnSeg p rad) . _wlLine
 
 circOnAnyCr :: Point2 -> Float -> World -> Bool
 {-# INLINE circOnAnyCr #-}
-circOnAnyCr p r = runIdentity . S.any_ (\cr -> dist p (_crPos cr) < r + _crRad cr)
+circOnAnyCr p r w = IS.foldr f False $ crIXsNearPoint p w
-    . crsNearPoint p
+  where
+    f cid bl = maybe False (\cr -> dist p (_crPos cr) < r + _crRad cr) (w ^? creatures . ix cid) || bl
 
 {- | More general collision tests follow -}
 
@@ -218,6 +221,10 @@ canSeeIndirect i j w = hasLOSIndirect ipos jpos w
 anythingHitCirc :: Float -> Point2 -> Point2 -> World -> Bool
 anythingHitCirc rad sp ep w = hitCr || isJust (sequence hitWl)
   where
-    hitCr    = runIdentity $ S.any_ (const True) $ overlap1SegCrs sp ep $ crsNearSeg sp ep w
+    hitCr    = IS.foldr f False $ crsNearSeg sp ep w
+    f cid bl = maybe False (\cr -> null $ intersectCircSeg (_crPos cr) (rad + _crRad cr) sp ep)
+            (w ^? creatures . ix cid)
+        || bl
+
     hitWl    = collideCircWallsStream sp ep rad $ wlsNearPoint ep w
                                                     -- this should probably be wallsOnLine or something

src/Dodge/Creature/ReaderUpdate.hs

@@ -14,12 +14,15 @@ module Dodge.Creature.ReaderUpdate
     , setMvPos
     , setViewPos
     ) where
+import Dodge.Zoning.Creature
+import FoldableHelp
 import Dodge.Data
 import Dodge.Creature.Volition
 import Dodge.Base
 import Dodge.Zone
 import Geometry
 
+import qualified Data.IntSet as IS
 import qualified IntMapHelp as IM
 import Control.Lens
 import Control.Applicative
@@ -76,7 +79,9 @@ flockACC w cr = case cr ^? crIntention . targetCr . _Just of
             isFarACC cr' = _crGroup cr' == _crGroup cr 
                 && _crID cr' /= _crID cr
                 && dist (_crPos cr') tpos > dist cpos tpos
-            macr = minStreamOn (dist cpos . _crPos) . S.filter isFarACC $ crsInsideCirc cpos 50 w
+            macr = safeMinimumOn (dist cpos . _crPos) 
+                . filter isFarACC 
+                $ crsNearCirc cpos 50 w
             in case macr of
                 Nothing  -> cr
                 Just acr ->

src/Dodge/DamageCircle.hs

@@ -6,6 +6,7 @@ import Dodge.WorldEvent.ThingsHit
 import Geometry
 import LensHelp
 
+import Data.Foldable
 import qualified Streaming.Prelude as S
 import qualified IntMapHelp as IM
 damageCircle :: Float -> Point2 -> DamageType -> Int -> World -> World
@@ -16,7 +17,7 @@ damageCircle r sp dt da w = w
     addwalldamages wlds = runIdentity $ S.fold_ (damageWlCircle wldam) wlds id wlstodam
     wlstodam = wlsHitRadial sp r w
     wldam p = Damage dt da sp p (sp +.+ r *.* normalizeV (p -.- sp)) NoDamageEffect
-    addcreaturedamages crs = runIdentity $ S.fold_ (damageCrCircle crdam) crs id crstodam
+    addcreaturedamages crs = foldl' (damageCrCircle crdam) crs crstodam
     crdam p cr = Damage dt da sp p (_crPos cr) NoDamageEffect
     crstodam = crsHitRadial sp r w
 

src/Dodge/Data.hs

@@ -186,7 +186,7 @@ data World = World
     , _boundBox         :: [Point2]
     , _boundDist        :: (Float,Float,Float,Float) -- NSEW, S and W negative
     , _creatures        :: IM.IntMap Creature
-    , _crZoning         :: Zoning IM.IntMap Creature
+    , _crZoning         :: CrZoning --Zoning IM.IntMap Creature
     , _creatureGroups   :: IM.IntMap CrGroupParams
     , _itemPositions    :: IM.IntMap ItemPos
     , _clouds           :: [Cloud]

src/Dodge/Data/Zoning.hs

@@ -4,6 +4,7 @@ module Dodge.Data.Zoning where
 import Geometry.Data
 import Control.Lens
 import qualified IntMapHelp as IM
+import qualified Data.IntSet as IS
 import StreamingHelp
 
 data Zoning t a = Zoning
@@ -12,5 +13,7 @@ data Zoning t a = Zoning
     , _znFunc       :: Float -> a -> StreamOf Int2
 --    , _znInsert     :: a -> t a -> t a
     }
+newtype CrZoning = CrZoning {_getCrZoning :: IM.IntMap (IM.IntMap IS.IntSet)}
 
 makeLenses ''Zoning
+makeLenses ''CrZoning

src/Dodge/Default/World.hs

@@ -27,7 +27,7 @@ defaultWorld = World
     , _viewDistance = 1000
     , _modifications    = IM.empty
     , _creatures        = IM.empty
-    , _crZoning         = Zoning IM.empty crZoneSize zoneOfCreature
+    , _crZoning         = CrZoning mempty --Zoning IM.empty crZoneSize zoneOfCreature
     , _creatureGroups   = IM.empty
     , _clouds           = mempty
     , _clZoning         = Zoning IM.empty clZoneSize (zonePos (stripZ . _clPos))

src/Dodge/Item/Weapon/ExtraEffect.hs

@@ -18,6 +18,8 @@ module Dodge.Item.Weapon.ExtraEffect
     , targetCursorUpdate
 --    , rbSetTarget
     ) where
+import Dodge.Zoning.Creature
+import FoldableHelp
 import Dodge.Data
 import Dodge.Base
 import Dodge.Zone
@@ -93,9 +95,9 @@ targetRBCreatureUp it cr w t
         & tgActive .~ False 
         )
   where
-    newtarg = minStreamOn (dist mwp . _crPos)
+    newtarg = safeMinimumOn (dist mwp . _crPos)
-        . S.filter (canseepos . _crPos)
+        . filter (canseepos . _crPos)
-        $ crsInsideCirc mwp 40 w
+        $ crsNearCirc mwp 40 w
     canseepos p = hasLOS (_crPos cr) p w
     mwp = mouseWorldPos w
     updatePos t' = t' & tgPos .~ posFromMaybeID (_tgID t')

src/Dodge/Update.hs

@@ -4,6 +4,7 @@ Module      : Dodge.Update
 Description : Simulation update
 -}
 module Dodge.Update ( updateUniverse ) where
+import Dodge.Zoning.Creature
 import Dodge.WorldEffect
 import Dodge.Data
 import Dodge.Beam
@@ -73,28 +74,28 @@ functionalUpdate w = over uvWorld checkEndGame
     . over uvWorld ppEvents
     . updateCamera
     . colCrsWalls
-    . over uvWorld (simpleCrSprings                         )        
+    . over uvWorld simpleCrSprings 
-    . over uvWorld (zoneCreatures                           )
+    . over uvWorld zoneCreatures
     . over uvWorld (updateIMl _doors _drMech                )
     . over uvWorld doWorldEvents
-    . over uvWorld (updateDelayedEvents                     )
+    . over uvWorld updateDelayedEvents
     . over uvWorld (updateIMl _modifications _mdUpdate      )
-    . over uvWorld (updateSparks                            )
+    . over uvWorld updateSparks
-    . over uvWorld (updateRadarSweeps                       )
+    . over uvWorld updateRadarSweeps
-    . over uvWorld (updatePosEvents                         )
+    . over uvWorld updatePosEvents
-    . over uvWorld (updateFlames                            )
+    . over uvWorld updateFlames
-    . over uvWorld (updateEnergyBalls                       )
+    . over uvWorld updateEnergyBalls
-    . over uvWorld (updateParticles                         )
+    . over uvWorld updateParticles
-    . over uvWorld (updateBullets                           )
+    . over uvWorld updateBullets
-    . over uvWorld (updateRadarBlips                        )
+    . over uvWorld updateRadarBlips
-    . over uvWorld (updateFlares                            )
+    . over uvWorld updateFlares
-    . over uvWorld (updateBeams                             )
+    . over uvWorld updateBeams
     . over uvWorld (updateIMl _props _pjUpdate              )
     . over uvWorld (updateIMl' _projectiles updateProjectile)
-    . over uvWorld (updateLightSources                      )
+    . over uvWorld updateLightSources
-    . over uvWorld (updateClouds                            )
+    . over uvWorld updateClouds
-    . over uvWorld (updateGusts                             )
+    . over uvWorld updateGusts
-    . over uvWorld (zoneClouds                              )
+    . over uvWorld zoneClouds
     . over uvWorld (updateMIM magnets _mgUpdate             )
     . over uvWorld (updateIMl' _terminals tmUpdate          )
 --    . updateIMl _machines mcChooseUpdate
@@ -173,10 +174,10 @@ doRewind w = case _maybeWorld w of
 
 zoneCreatures :: World -> World
 zoneCreatures w = w 
-    & crZoning . znObjects .~ mempty
+    & crZoning . getCrZoning .~ mempty
-    & crZoning %~ \zn ->
+    & crZoning %~ \zn -> foldl' (flip zoneCreature) zn (_creatures w)
-        foldl' (flip $ updateZoning (\cr -> IM.insert (_crID cr) cr)) 
+--        foldl' (flip $ updateZoning (\cr -> IM.insert (_crID cr) cr)) 
-            zn (_creatures w)
+--            zn (_creatures w)
 
 updateCreatureSoundPositions :: World -> World
 updateCreatureSoundPositions w = M.foldlWithKey' insertSound w 
@@ -428,7 +429,7 @@ simpleCrSprings w = IM.foldl' (flip crSpring) w $ _creatures w
 
 -- note that this may in rare cases not push creatures away from each other
 crSpring :: Creature -> World -> World
-crSpring c w = runIdentity $ S.fold_ (flip $ crCrSpring c) w id cs
+crSpring c w = foldl' (flip $ crCrSpring c) w cs
   where 
     cs = crsNearPoint (_crPos c) w
 

src/Dodge/Update/Cloud.hs

@@ -1,15 +1,17 @@
 module Dodge.Update.Cloud where
+import Dodge.Zoning.Creature
 import Dodge.Data
 import Dodge.Zone
 import Geometry.Vector3D
 import LensHelp
 import StreamingHelp
 import qualified Streaming.Prelude as S
+import Data.Foldable
 cloudPoisonDamage :: Cloud -> World -> World
-cloudPoisonDamage c w = w & dodamagesto (S.filter f $ crsNearPoint clpos w)
+cloudPoisonDamage c w = w & dodamagesto (filter f $ crsNearPoint clpos w)
   where 
-    dodamagesto :: StreamOf Creature -> World -> World
+    dodamagesto :: [Creature] -> World -> World
-    dodamagesto scrs mcrs = runIdentity $ S.fold_ (flip doDam) mcrs id scrs
+    dodamagesto scrs mcrs = foldl' (flip doDam) mcrs scrs
     doDam cr = creatures . ix (_crID cr) . crState . csDamage 
         .:~ Damage POISONDAM 1 clpos clpos clpos NoDamageEffect
     f cr = dist3 (addZ 20 $ _crPos cr) (_clPos c) < _crRad cr + _clRad c + 10

src/Dodge/WorldEvent/ThingsHit.hs

@@ -11,15 +11,19 @@ module Dodge.WorldEvent.ThingsHit
     , wlsHitRadial
     )
     where
+import Dodge.Zoning.Creature
 import Dodge.Data
 import Dodge.Base
 import Dodge.Zone
 import Geometry
 
---import Data.Maybe
+import Control.Lens
+import Data.Maybe
+import Data.List (sortOn)
 import Data.Functor
 import Data.Bifunctor
 import StreamingHelp
+import qualified Data.IntSet as IS
 import qualified Streaming.Prelude as S
 
 {- List those objects that appear on a line.  -}
@@ -29,15 +33,18 @@ thingsHit
     -> World 
     -> StreamOf (Point2, Either Creature Wall)
 thingsHit sp ep w = void $ S.mergeOn (dist sp . fst)  
-    (S.map (second Left)  (crsHit sp ep w))
+    (S.map (second Left)  (S.each $ crsHit sp ep w))
     (S.map (second Right) (wlsHit sp ep w))
 
-crsHit :: Point2 -> Point2 -> World -> StreamOf (Point2, Creature)
+crsHit :: Point2 -> Point2 -> World -> [(Point2, Creature)]
-crsHit sp ep
+crsHit sp ep w
-    | sp == ep  = const mempty
+    | sp == ep  = mempty
-    | otherwise = sortStreamOn (dist sp . fst)
+    | otherwise = sortOn (dist sp . fst)
         . overlap1SegCrs sp ep
+        . mapMaybe (\cid -> w ^? creatures . ix cid)
+        . IS.toList
         . crsNearSeg sp ep
+        $ w
 
 thingHitFilt :: (Creature -> Bool) -> (Wall -> Bool) 
     -> Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall)
@@ -77,8 +84,8 @@ wlsHitRadial p r = S.mapMaybe f . wlsInsideCirc p r
       where
         v = normalizeV $ vNormal $ uncurry (-.-) $ _wlLine wl
 
-crsHitRadial :: Point2 -> Float -> World -> StreamOf (Point2, Creature)
+crsHitRadial :: Point2 -> Float -> World -> [(Point2, Creature)]
-crsHitRadial p r = S.mapMaybe f . crsInsideCirc p r
+crsHitRadial p r = mapMaybe f . crsNearCirc p r
   where
     f cr 
         | dist cpos p <= r = Just (cpos +.+ r *.* normalizeV (p -.- cpos), cr)

src/Dodge/Zone.hs

@@ -5,14 +5,14 @@ module Dodge.Zone
     , nearPoint
     , nearSeg
     , wlsNearPoint
-    , crsNearPoint
+    --, crsNearPoint
     , clsNearPoint
     , wlsNearSeg
-    , crsNearSeg
+    --, crsNearSeg
     , wlsInsideCirc
-    , crsInsideCirc
+    --, crsInsideCirc
     , clZoneOfPoint
-    , crZoneOfPoint
+    --, crZoneOfPoint
     , wlZoneOfPoint
     , module Dodge.Zone.Size
     , module Dodge.Zone.Object
@@ -82,9 +82,9 @@ wlsNearPoint :: Point2 -> World -> StreamOf Wall
 {-# INLINE wlsNearPoint #-}
 wlsNearPoint = nearPoint _wlZoning
 
-crsNearPoint :: Point2 -> World -> StreamOf Creature
+--crsNearPoint :: Point2 -> World -> StreamOf Creature
-{-# INLINE crsNearPoint #-}
+--{-# INLINE crsNearPoint #-}
-crsNearPoint = nearPoint _crZoning
+--crsNearPoint = nearPoint _crZoning
 
 nearSeg :: Foldable t => (World -> Zoning t a) -> Point2 -> Point2 -> World -> StreamOf a
 {-# INLINE nearSeg #-}
@@ -96,9 +96,9 @@ wlsNearSeg :: Point2 -> Point2 -> World -> StreamOf Wall
 {-# INLINE wlsNearSeg #-}
 wlsNearSeg = nearSeg _wlZoning
 
-crsNearSeg :: Point2 -> Point2 -> World -> StreamOf Creature
+--crsNearSeg :: Point2 -> Point2 -> World -> StreamOf Creature
-{-# INLINE crsNearSeg #-}
+--{-# INLINE crsNearSeg #-}
-crsNearSeg = nearSeg _crZoning
+--crsNearSeg = nearSeg _crZoning
 
 insideCirc :: Foldable t => (World -> Zoning t a) -> Point2 -> Float -> World -> StreamOf a
 {-# INLINE insideCirc #-}
@@ -110,9 +110,9 @@ wlsInsideCirc :: Point2 -> Float -> World -> Stream (Of Wall) Identity ()
 {-# INLINE wlsInsideCirc #-}
 wlsInsideCirc = insideCirc _wlZoning
 
-crsInsideCirc :: Point2 -> Float -> World -> StreamOf Creature
+--crsInsideCirc :: Point2 -> Float -> World -> StreamOf Creature
-{-# INLINE crsInsideCirc #-}
+--{-# INLINE crsInsideCirc #-}
-crsInsideCirc = insideCirc _crZoning
+--crsInsideCirc = insideCirc _crZoning
 
 wlZoneOfPoint :: Point2 -> Int2
 {-# INLINE wlZoneOfPoint #-}
@@ -122,6 +122,6 @@ clZoneOfPoint :: Point2 -> Int2
 {-# INLINE clZoneOfPoint #-}
 clZoneOfPoint = zoneOfPoint clZoneSize
 
-crZoneOfPoint :: Point2 -> Int2
+--crZoneOfPoint :: Point2 -> Int2
-{-# INLINE crZoneOfPoint #-}
+--{-# INLINE crZoneOfPoint #-}
-crZoneOfPoint = zoneOfPoint crZoneSize
+--crZoneOfPoint = zoneOfPoint crZoneSize

src/Dodge/Zone/Size.hs

@@ -6,8 +6,5 @@ pnZoneSize = 100
 wlZoneSize :: Float
 wlZoneSize = 50
 
-crZoneSize :: Float
-crZoneSize = 15
-
 clZoneSize :: Float
 clZoneSize = 20

src/Dodge/Zoning.hs

@@ -1,2 +1,5 @@
-module Dodge.Zoning where
+module Dodge.Zoning 
+    ( module Dodge.Zoning.Creature
+    ) where
+import Dodge.Zoning.Creature
 

src/Dodge/Zoning/Base.hs

@@ -1,20 +1,62 @@
 module Dodge.Zoning.Base where
+import Geometry
+import Geometry.Zone
+import qualified IntMapHelp as IM
 
---zoneOfCirc :: Float -> Point2 -> Float -> [Int2]
+import Control.Lens
---zoneOfCirc zsize p r = zoneOfRect' x (p +.+ V2 r r) (p -.- V2 r r)
+import Data.Maybe
+
+zoneOfCirc :: Float -> Point2 -> Float -> [Int2]
+zoneOfCirc zsize p r = zoneOfRect' zsize (p +.+ V2 r r) (p -.- V2 r r)
+
+zoneOfRect' :: Float -> Point2 -> Point2 -> [Int2]
+zoneOfRect' s sp ep = [V2 x y | x <- makeIntInterval sx ex, y <- makeIntInterval sy ey]
+  where
+    V2 sx sy = zoneOfPoint' s sp
+    V2 ex ey = zoneOfPoint' s ep
+
+makeIntInterval :: Int -> Int -> [Int]
+makeIntInterval x y
+    | x < y     = [x..y]
+    | otherwise = [y..x]
+
+makeInt2Interval :: Int2 -> Int2 -> [Int2]
+makeInt2Interval (V2 x1 y1) (V2 x2 y2) 
+    = [(V2 x y) | x <- makeIntInterval x1 x2, y <- makeIntInterval y1 y2]
+
+zoneOfPoint' :: Float -> Point2 -> Int2
+zoneOfPoint' s = fmap (divTo s)
+
+zoneOfSeg' :: Float -> Point2 -> Point2 -> [Int2]
+zoneOfSeg' s sp ep = map (zoneOfPoint' s) (sp : xIntercepts' s sp ep ++ yIntercepts' s sp ep)
+
+zoneExtract :: Monoid m => Int2 -> IM.IntMap (IM.IntMap m) -> m
+zoneExtract (V2 x y) = fromMaybe mempty . (^? ix x . ix y)
 --
---zoneOfRect' :: Float -> Point2 -> Point2 -> [Int2]
+zonesExtract :: Monoid m => IM.IntMap (IM.IntMap m) -> [Int2] -> m
---zoneOfRect' s sp ep = [V2 x y | x <- makeInterval sx ex, y <- makeInterval sy ey]
+zonesExtract im = foldMap (flip zoneExtract im)
---  where
+
---    V2 sx sy = zoneOfPoint s sp
+xIntercepts' :: Float -> Point2 -> Point2 -> [Point2]
---    V2 ex ey = zoneOfPoint s ep
+{-# INLINE xIntercepts' #-}
---
+xIntercepts' s (V2 sx sy) (V2 ex ey) 
---zoneOfPoint :: Float -> Point2 -> Int2
+    | xdx == 0  = []
---{-# INLINE zoneOfPoint #-}
+    | xdx > 0   = zipWith V2 [sx',sx'+xdx*50..ex] ([sy',sy'+ydx*50..ey] ++ repeat ey)
---zoneOfPoint s = fmap (divTo s)
+    | otherwise = zipWith V2 [sx'-50,sx'+xdx*50-50..ex-50] ([sy',sy'+ydx*50..ey] ++ repeat ey)
---
+  where
---zoneExtract :: Monoid m => Int2 -> IM.IntMap (IM.IntMap m) -> m
+    xdx = signum (ex - sx)
---zoneExtract (x,y) = ix x . ix y
+    ydx = (ey - sy) / abs (ex - sx) -- carefull: if this is zero
---
+
---zonesExtract :: Monoid m => [Int2] -> IM.IntMap (IM.IntMap m) -> m
+    sy' = sy + ydx * abs (sx - sx')
---zonesExtract xs = fold (flip zoneExtract xs)
+    sx' | xdx < 0 = sx - modTo s sx
+        | otherwise = s + sx - modTo s sx
+
+yIntercepts' :: Float -> Point2 -> Point2 -> [Point2]
+{-# INLINE yIntercepts' #-}
+yIntercepts' s sp ep = map f $ xIntercepts' s (f sp) (f ep)
+  where
+    f (V2 x y) = V2 y x
+
+zoneMonoid :: Semigroup m => Int2 -> m -> IM.IntMap (IM.IntMap m) -> IM.IntMap (IM.IntMap m)
+zoneMonoid (V2 x y) a = IM.insertWith f x $ IM.singleton y a
+  where
+    f _ = IM.insertWith (<>) y a

src/Dodge/Zoning/Creature.hs

@@ -1,7 +1,54 @@
 module Dodge.Zoning.Creature where
+import FoldableHelp
+import Dodge.Data
+import Geometry
+import Dodge.Zoning.Base
+import qualified FoldlHelp as L
+import qualified IntMapHelp as IM
 
---zoneOfCr :: Creature -> [Int2]
+import Data.Maybe
---zoneOfCr cr = zoneOfCirc crZoneSize (_crPos cr) (_crRad cr)
+import Data.Function
+import qualified Data.IntSet as IS
+import Control.Lens
+
+crIXsNearPoint :: Point2 -> World -> IS.IntSet
+crIXsNearPoint p w = zoneExtract (zoneOfPoint' crZoneSize p) (w ^. crZoning . getCrZoning)
+
+crsNearPoint :: Point2 -> World -> [Creature]
+crsNearPoint p w = mapMaybe (\cid -> w ^? creatures . ix cid) . IS.toList $ crIXsNearPoint p w
+
+crsNearSeg :: Point2 -> Point2 -> World -> IS.IntSet
+crsNearSeg sp ep w = zonesExtract (w ^. crZoning . getCrZoning) (zoneOfSeg' crZoneSize sp ep)
+
+crIXsNearCirc :: Point2 -> Float -> World -> IS.IntSet
+crIXsNearCirc p r = crsNearRect (p +.+ V2 r r) (p -.- V2 r r)
+
+crsNearCirc :: Point2 -> Float -> World -> [Creature]
+crsNearCirc p r w = mapMaybe (\cid -> w ^? creatures . ix cid) . IS.toList $ crIXsNearCirc p r w
+
+crsNearRect :: Point2 -> Point2 -> World -> IS.IntSet
+crsNearRect sp ep w = zonesExtract (w ^. crZoning . getCrZoning) $ zoneOfRect' crZoneSize sp ep
+
+crZoneSize :: Float
+crZoneSize = 15
+
+zoneOfCr :: Creature -> [Int2]
+zoneOfCr cr = zoneOfCirc crZoneSize (_crPos cr) (_crRad cr)
+
+minCrIXOn :: Ord a => (Creature -> a) -> IS.IntSet -> World -> Maybe Creature
+minCrIXOn f is w = fmap fst $ IS.foldl' (g w) Nothing is
+  where
+    g w mcrx cid = minOn snd <$> getpair cid <*> mcrx
+    getpair cid = fmap h $ w ^? creatures . ix cid
+    h cr = (cr, f cr)
+
+zoneCreature :: Creature -> CrZoning -> CrZoning
+zoneCreature cr = over getCrZoning (zoneCr' cr)
+
+zoneCr' :: Creature -> IM.IntMap (IM.IntMap IS.IntSet) -> IM.IntMap (IM.IntMap IS.IntSet)
+zoneCr' cr im = foldl' f im (zoneOfCr cr)
+  where
+    f im i2 = zoneMonoid i2 (IS.singleton $ _crID cr) im
 
 --crsInZones :: [Int2] -> CrZoning -> IS.IntSet
 --crsInZones is 

src/FoldableHelp.hs

@@ -8,6 +8,7 @@ module FoldableHelp
     , filter3
     , takeUntil
     , ssfold
+    , minOn
     , module Data.Foldable
     )
     where
@@ -29,6 +30,11 @@ safeMinimumOn f = foldl' g Nothing
         | f x < f y = Just x
         | otherwise = Just y
     g Nothing y = Just y
+
+minOn :: Ord b => (a -> b) -> a -> a -> a
+minOn f x y
+    | f x < f y = x
+    | otherwise = y
 safeMinimumOnMaybeF :: (Ord b) => (a -> Maybe b) -> [a] -> Maybe a
 safeMinimumOnMaybeF f = L.fold $ L.Fold step initial extract
   where

src/Geometry/Zone.hs

@@ -9,6 +9,7 @@ module Geometry.Zone
     , zoneOfPoint
     , zoneOfSeg
     , zoneInsideCirc
+    , makeInterval
     ) where
 import Geometry.Data
 import Geometry.Vector