Refactor creature zoning

2022-07-22 17:53:08 +01:00
parent 43e7d20b21
commit 39f4555697
17 changed files with 209 additions and 85 deletions
@@ -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