Refactor wall zoning, remove streaming

2022-07-23 12:29:29 +01:00
parent 39f4555697
commit 39778f46fb
30 changed files with 396 additions and 163 deletions
@@ -0,0 +1,61 @@
+module Dodge.Zoning.Wall where
+import FoldableHelp
+import Dodge.Data
+import Geometry
+import Dodge.Zoning.Base
+import qualified IntMapHelp as IM
+
+import Data.Maybe
+import qualified Data.IntSet as IS
+import Control.Lens
+
+wlIXsNearPoint :: Point2 -> World -> IS.IntSet
+wlIXsNearPoint p w = zoneExtract (zoneOfPoint' wlZoneSize p) (w ^. wlZoning)
+
+wlIXsNearSeg :: Point2 -> Point2 -> World -> IS.IntSet
+wlIXsNearSeg sp ep w = zonesExtract (w ^. wlZoning) (zoneOfSeg' wlZoneSize sp ep)
+
+wlIXsNearRect :: Point2 -> Point2 -> World -> IS.IntSet
+wlIXsNearRect sp ep w = zonesExtract (w ^. wlZoning) $ zoneOfRect' wlZoneSize sp ep
+
+wlIXsNearCirc :: Point2 -> Float -> World -> IS.IntSet
+wlIXsNearCirc p r = wlIXsNearRect (p +.+ V2 r r) (p -.- V2 r r)
+
+wlsFromIXs :: World -> IS.IntSet -> [Wall]
+wlsFromIXs w = mapMaybe (\wlid -> w ^? walls . ix wlid) . IS.toList
+
+wlsNearPoint :: Point2 -> World -> [Wall]
+wlsNearPoint p w = wlsFromIXs w $ wlIXsNearPoint p w
+
+wlsNearSeg :: Point2 -> Point2 -> World -> [Wall]
+wlsNearSeg sp ep w = wlsFromIXs w $ wlIXsNearSeg sp ep w
+
+wlsNearRect :: Point2 -> Point2 -> World -> [Wall]
+wlsNearRect sp ep w = wlsFromIXs w $ wlIXsNearRect sp ep w
+
+wlsNearCirc :: Point2 -> Float -> World -> [Wall]
+wlsNearCirc p r w = wlsFromIXs w $ wlIXsNearCirc p r w
+
+wlZoneSize :: Float
+wlZoneSize = 50
+
+zoneOfWl :: Wall -> [Int2]
+zoneOfWl = uncurry (zoneOfSeg' wlZoneSize) . _wlLine
+
+--minCrIXOn :: Ord a => (Creature -> a) -> IS.IntSet -> World -> Maybe Creature
+--minCrIXOn f is w = fmap fst $ IS.foldl' g Nothing is
+--  where
+--    g mcrx cid = minOn snd <$> getpair cid <*> mcrx
+--    getpair cid = fmap h $ w ^? creatures . ix cid
+--    h cr = (cr, f cr)
+
+zoneWall :: Wall -> IM.IntMap (IM.IntMap IS.IntSet) -> IM.IntMap (IM.IntMap IS.IntSet)
+zoneWall wl im = foldl' f im (zoneOfWl wl)
+  where
+    f im' i2 = zoneMonoid i2 (IS.singleton $ _wlID wl) im'
+
+deZoneWall :: Wall -> IM.IntMap (IM.IntMap IS.IntSet) -> IM.IntMap (IM.IntMap IS.IntSet)
+deZoneWall wl im = foldl' (deZoneIX (_wlID wl)) im (zoneOfWl wl)
+
+deZoneIX :: Int -> IM.IntMap (IM.IntMap IS.IntSet) -> Int2 ->  IM.IntMap (IM.IntMap IS.IntSet)
+deZoneIX i im (V2 x y) = im & ix x . ix y %~ IS.delete i