102 lines
3.1 KiB
Haskell
102 lines
3.1 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
module Dodge.Zoning.Base
|
|
( zoneExtract
|
|
, zoneOfPoint
|
|
, zonesExtract
|
|
, zoneOfSeg
|
|
, zoneOfSegSet
|
|
, zoneOfRect
|
|
, zoneMonoid
|
|
, deZoneIX
|
|
, zoneOfCirc
|
|
, zonesAroundPoint
|
|
, xIntercepts
|
|
, yIntercepts
|
|
, updateInt2Map
|
|
) where
|
|
|
|
import Control.Lens
|
|
import qualified Data.IntSet as IS
|
|
import qualified Data.Set as S
|
|
--import Data.Maybe
|
|
import Geometry
|
|
import Geometry.Zone
|
|
import qualified IntMapHelp as IM
|
|
|
|
zoneOfCirc :: Float -> Point2 -> Float -> [Int2]
|
|
{-# INLINE zoneOfCirc #-}
|
|
zoneOfCirc zsize p r = zoneOfRect zsize (p + V2 r r) (p - V2 r r)
|
|
|
|
zoneOfRect :: Float -> Point2 -> Point2 -> [Int2]
|
|
{-# INLINE zoneOfRect #-}
|
|
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 = fmap . divTo
|
|
|
|
zoneOfSeg :: Float -> Point2 -> Point2 -> [Int2]
|
|
{-# INLINE zoneOfSeg #-}
|
|
zoneOfSeg s sp ep = map (zoneOfPoint s) (sp : xIntercepts s sp ep ++ yIntercepts s sp ep)
|
|
|
|
zoneOfSegSet :: Float -> Point2 -> Point2 -> S.Set Int2
|
|
{-# INLINE zoneOfSegSet #-}
|
|
zoneOfSegSet s sp = S.fromList . zoneOfSeg s sp
|
|
|
|
-- | zoneExtract (V2 x y) == fromMaybe mempty . (^? ix x . ix y)
|
|
zoneExtract :: Monoid m => Int2 -> IM.IntMap (IM.IntMap m) -> m
|
|
{-# INLINE zoneExtract #-}
|
|
zoneExtract (V2 x y) = foldOf (ix x . ix y)
|
|
|
|
zonesExtract :: (Foldable f,Monoid m) => IM.IntMap (IM.IntMap m) -> f Int2 -> m
|
|
{-# INLINE zonesExtract #-}
|
|
zonesExtract = foldMap . flip zoneExtract
|
|
|
|
xIntercepts :: Float -> Point2 -> Point2 -> [Point2]
|
|
{-# INLINE xIntercepts #-}
|
|
xIntercepts s (V2 sx sy) (V2 ex ey)
|
|
| divTo s sx == divTo s ex = []
|
|
| otherwise = g <$> [a, a + s .. b]
|
|
where
|
|
(a,b) | sx < ex = (ceilingTo s sx,floorTo s ex)
|
|
| otherwise = (ceilingTo s ex,floorTo s sx)
|
|
g x = V2 (h + x) (f x)
|
|
h = 0.5 * s * signum (ex - sx)
|
|
f x = sy + (x - sx) * (ey - sy) / (ex - 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
|
|
|
|
-- consider using: at x . non mempty . at y . non mempty <>~ a
|
|
zoneMonoid :: Semigroup m => Int2 -> m -> IM.IntMap (IM.IntMap m) -> IM.IntMap (IM.IntMap m)
|
|
{-# INLINE zoneMonoid #-}
|
|
zoneMonoid (V2 !x !y) a = IM.insertWith f x $! IM.singleton y a
|
|
where
|
|
f _ = IM.insertWith (<>) y a
|
|
|
|
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
|
|
|
|
updateInt2Map :: (Eq a,Monoid a) =>
|
|
(a -> a) -> Int2 -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntMap a)
|
|
updateInt2Map f (V2 x y) = at x . non mempty . at y . non mempty %~ f
|
|
|
|
zonesAroundPoint :: Float -> Point2 -> [Int2]
|
|
zonesAroundPoint s p = [V2 a b | a <- [x -1 .. x + 1], b <- [y -1 .. y + 1]]
|
|
where
|
|
V2 x y = zoneOfPoint s p
|