Refactor creature zoning

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]
---zoneOfCirc zsize p r = zoneOfRect' x (p +.+ V2 r r) (p -.- V2 r r)
+import Control.Lens
+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]
---zoneOfRect' s sp ep = [V2 x y | x <- makeInterval sx ex, y <- makeInterval sy ey]
---  where
---    V2 sx sy = zoneOfPoint s sp
---    V2 ex ey = zoneOfPoint s ep
---
---zoneOfPoint :: Float -> Point2 -> Int2
---{-# INLINE zoneOfPoint #-}
---zoneOfPoint s = fmap (divTo s)
---
---zoneExtract :: Monoid m => Int2 -> IM.IntMap (IM.IntMap m) -> m
---zoneExtract (x,y) = ix x . ix y
---
---zonesExtract :: Monoid m => [Int2] -> IM.IntMap (IM.IntMap m) -> m
---zonesExtract xs = fold (flip zoneExtract xs)
+zonesExtract :: Monoid m => IM.IntMap (IM.IntMap m) -> [Int2] -> m
+zonesExtract im = foldMap (flip zoneExtract im)
+
+xIntercepts' :: Float -> Point2 -> Point2 -> [Point2]
+{-# INLINE xIntercepts' #-}
+xIntercepts' s (V2 sx sy) (V2 ex ey) 
+    | xdx == 0  = []
+    | xdx > 0   = zipWith V2 [sx',sx'+xdx*50..ex] ([sy',sy'+ydx*50..ey] ++ repeat ey)
+    | otherwise = zipWith V2 [sx'-50,sx'+xdx*50-50..ex-50] ([sy',sy'+ydx*50..ey] ++ repeat ey)
+  where
+    xdx = signum (ex - sx)
+    ydx = (ey - sy) / abs (ex - sx) -- carefull: if this is zero
+
+    sy' = sy + ydx * abs (sx - sx')
+    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]
---zoneOfCr cr = zoneOfCirc crZoneSize (_crPos cr) (_crRad cr)
+import Data.Maybe
+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