Cleanup, move towards unifying zones
This commit is contained in:
@@ -0,0 +1,207 @@
|
||||
module Dodge.Zone
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Zone.Data
|
||||
import Dodge.Base.Window
|
||||
import Geometry
|
||||
import Geometry.Zone
|
||||
|
||||
import Data.Maybe
|
||||
import Data.List
|
||||
import Data.Bifunctor
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import qualified Data.IntSet as IS
|
||||
|
||||
zoneSize :: Float
|
||||
zoneSize = 50
|
||||
|
||||
floorHun :: Float -> Int
|
||||
floorHun x = floor $ x / zoneSize
|
||||
|
||||
sizeZoneOfPoint :: Float -> Point2 -> (Int,Int)
|
||||
sizeZoneOfPoint s (V2 x y) = (f x, f y)
|
||||
where
|
||||
f = floor . (/ s)
|
||||
|
||||
zoneOfPoint :: Point2 -> (Int,Int)
|
||||
zoneOfPoint (V2 x y) = (floorHun x, floorHun y)
|
||||
|
||||
cloudZoneOfPoint :: Point2 -> (Int,Int)
|
||||
cloudZoneOfPoint = sizeZoneOfPoint 20
|
||||
|
||||
crZoneOfPoint :: Point2 -> (Int,Int)
|
||||
crZoneOfPoint = sizeZoneOfPoint 15
|
||||
|
||||
zoneNearPoint :: Point2 -> [(Int,Int)]
|
||||
zoneNearPoint (V2 x' y') = [(a,b) | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
|
||||
where
|
||||
x = floorHun x'
|
||||
y = floorHun y'
|
||||
|
||||
zoneAroundPoint :: Point2 -> [(Int,Int)]
|
||||
zoneAroundPoint (V2 x' y') = [(a,b) | a<-[x-3..x+3] , b<-[y-3..y+3]]
|
||||
where
|
||||
x = floorHun x'
|
||||
y = floorHun y'
|
||||
|
||||
zoneAroundPoint' :: Int -> Point2 -> IM.IntMap IS.IntSet
|
||||
zoneAroundPoint' i (V2 x' y') = IM.fromSet (const ys) xs
|
||||
where
|
||||
x = floorHun x'
|
||||
y = floorHun y'
|
||||
xs = IS.fromAscList [x-i..x+i]
|
||||
ys = IS.fromAscList [y-i..y+i]
|
||||
|
||||
zoneOfLine :: Point2 -> Point2 -> [(Int,Int)]
|
||||
zoneOfLine (V2 aa ab) (V2 ba bb)
|
||||
= nub
|
||||
. concatMap f
|
||||
$ digitalLine (zoneOfPoint (V2 aa ab)) (zoneOfPoint (V2 ba bb))
|
||||
where
|
||||
f (x,y) = [(p,r) | p <-[x-1,x,x+1] , r<-[y-1,y,y+1]]
|
||||
|
||||
zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet
|
||||
--{-# INLINE zoneOfLineIntMap #-}
|
||||
zoneOfLineIntMap = ddaExt zoneSize
|
||||
|
||||
expandLine :: [(Int,Int)] -> IM.IntMap IS.IntSet
|
||||
--{-# INLINE expandLine #-}
|
||||
expandLine xs = IM.map expandSet
|
||||
$ IM.unionsWith IS.union [im, IM.mapKeysMonotonic (+1) im, IM.mapKeysMonotonic (+2) im]
|
||||
where
|
||||
im = IM.fromListWith IS.union $ map (second IS.singleton) xs
|
||||
-- the second was suggested by hlint, but it increases laziness, so might
|
||||
-- not be ideal
|
||||
expandSet s = IS.insert (mk+2) $ IS.insert (mk+1) s
|
||||
where
|
||||
mk = IS.findMax s
|
||||
|
||||
zoneOfCircle :: Point2 -> Float -> [(Int,Int)]
|
||||
zoneOfCircle p r = concatMap zoneNearPoint $ divideCircle (1.5 * zoneSize) p r
|
||||
|
||||
-- looking at this again, I am not convinced it deals correctly with the
|
||||
-- rotation of the world
|
||||
zoneOfScreen :: World -> [(Int,Int)]
|
||||
zoneOfScreen w =
|
||||
[(a,b)
|
||||
| a <- [x - n .. x + n]
|
||||
, b <- [y - n .. y + n]
|
||||
]
|
||||
where
|
||||
(x,y) = zoneOfPoint $ _cameraCenter w
|
||||
n = ceiling $ wh / (_cameraZoom w * zoneSize)
|
||||
wh = max (getWindowX w) (getWindowY w)
|
||||
|
||||
zoneOfDoubleScreen :: World -> [(Int,Int)]
|
||||
zoneOfDoubleScreen w = (,) <$> xs <*> ys
|
||||
where
|
||||
(x,y) = zoneOfPoint $ _cameraCenter w
|
||||
n = ceiling (wh / (_cameraZoom w * zoneSize)) * 2
|
||||
wh = max (getWindowX w) (getWindowY w)
|
||||
xs = [x - n .. x + n]
|
||||
ys = [y - n .. y + n]
|
||||
|
||||
zoneOfSight :: World -> [(Int,Int)]
|
||||
zoneOfSight w =
|
||||
[(a,b)
|
||||
| a <- [minimum xs .. maximum xs]
|
||||
, b <- [minimum ys .. maximum ys]
|
||||
]
|
||||
where
|
||||
(xs,ys) = unzip $ map zoneOfPoint $ screenPolygon w ++ [_cameraViewFrom w]
|
||||
|
||||
wallsDoubleScreen :: World -> IM.IntMap Wall
|
||||
wallsDoubleScreen w
|
||||
= foldl' (flip $ IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
|
||||
where
|
||||
innerFold m = foldl' (flip $ IM.union . \ j -> f j m) IM.empty ys
|
||||
f i m = case IM.lookup i m of
|
||||
Just val -> val
|
||||
_ -> IM.empty
|
||||
(x,y) = zoneOfPoint $ _cameraCenter w
|
||||
n = ceiling (wh / (_cameraZoom w * zoneSize)) * 2
|
||||
wh = max (getWindowX w) (getWindowY w)
|
||||
xs = [x - n .. x + n]
|
||||
ys = [y - n .. y + n]
|
||||
|
||||
wallsOnScreen :: World -> IM.IntMap Wall
|
||||
wallsOnScreen w
|
||||
= foldl' (flip $ IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
|
||||
where
|
||||
innerFold m = foldl' (flip $ IM.union . \ j -> f j m) IM.empty ys
|
||||
f i m = case IM.lookup i m of
|
||||
Just val -> val
|
||||
_ -> IM.empty
|
||||
(x,y) = zoneOfPoint $ _cameraCenter w
|
||||
n = ceiling (wh / (_cameraZoom w * zoneSize))
|
||||
wh = max (getWindowX w) (getWindowY w)
|
||||
xs = [x - n .. x + n]
|
||||
ys = [y - n .. y + n]
|
||||
|
||||
|
||||
wallsNearZones :: [(Int,Int)] -> World -> IM.IntMap Wall
|
||||
wallsNearZones is w -- = IM.unions [f b $ f a $ _wallsZone w | (a,b) <- is]
|
||||
= foldl' (flip $ IM.union . \(a,b) -> f b (f a (_znObjects $ _wallsZone w))) IM.empty is
|
||||
where
|
||||
f i m = case IM.lookup i m of
|
||||
Just val -> val
|
||||
_ -> IM.empty
|
||||
|
||||
ixZone :: IM.IntMap (IM.IntMap a) -> Point2 -> a
|
||||
ixZone z (V2 x y) = z IM.! floorHun x IM.! floorHun y
|
||||
|
||||
ixNZ :: IM.IntMap (IM.IntMap a) -> Point2 -> [a]
|
||||
ixNZ z p = lookLookups (zoneNearPoint p) z
|
||||
|
||||
lookLookup :: Int -> Int -> IM.IntMap (IM.IntMap a) -> Maybe a
|
||||
lookLookup i j z = case IM.lookup i z of
|
||||
Just z' -> IM.lookup j z'
|
||||
Nothing -> Nothing
|
||||
|
||||
lookLookups :: [(Int,Int)] -> IM.IntMap (IM.IntMap a) -> [a]
|
||||
lookLookups xs z = mapMaybe (flip (uncurry lookLookup) z) xs
|
||||
|
||||
cloudsNearPoint :: Point2 -> World -> [Cloud]
|
||||
--cloudsNearPoint p w = IM.unions [f b $ f a $ _cloudsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
|
||||
cloudsNearPoint p w = f (IM.lookup x (_znObjects $ _cloudsZone w) >>= IM.lookup y)
|
||||
where
|
||||
(x,y) = cloudZoneOfPoint p
|
||||
f Nothing = []
|
||||
f (Just l) = l
|
||||
|
||||
-- possible BUG, was associated with thingsHitLongLine
|
||||
-- assumes _wallsZone is correct level generation
|
||||
-- there is certainly a problem somewhere here: it may be in the zoning, or
|
||||
-- within this function
|
||||
wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall
|
||||
--{-# INLINE wallsAlongLine #-}
|
||||
wallsAlongLine a b w = IM.foldlWithKey' g IM.empty kps
|
||||
where
|
||||
g m x s = IM.union (IM.unions (IM.restrictKeys (f x $ _znObjects $ _wallsZone w) s)) m
|
||||
kps = zoneOfLineIntMap a b
|
||||
f i m = case IM.lookup i m of
|
||||
Just val -> val
|
||||
_ -> IM.empty
|
||||
|
||||
wallsNearZone :: IM.IntMap IS.IntSet -> World -> IM.IntMap Wall
|
||||
{-# INLINE wallsNearZone #-}
|
||||
wallsNearZone im w = IM.foldrWithKey' g IM.empty im
|
||||
where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _znObjects $ _wallsZone w) s))
|
||||
f i m = case IM.lookup i m of Just val -> val
|
||||
_ -> IM.empty
|
||||
|
||||
wallsAlongCirc :: Point2 -> Float -> World -> IM.IntMap Wall
|
||||
wallsAlongCirc p r w = IM.unions [f y $ f x $ _znObjects $ _wallsZone w | (x,y) <- zoneOfCircle p r]
|
||||
where f i m = case IM.lookup i m of Just val -> val
|
||||
_ -> IM.empty
|
||||
|
||||
wallsNearPoint :: Point2 -> World -> IM.IntMap Wall
|
||||
wallsNearPoint p w = IM.unions [f b $ f a $ _znObjects $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
|
||||
where
|
||||
(x,y) = zoneOfPoint p
|
||||
f i m = case IM.lookup i m of
|
||||
Just val -> val
|
||||
_ -> IM.empty
|
||||
|
||||
flattenIMIMIM :: IM.IntMap (IM.IntMap (IM.IntMap a)) -> IM.IntMap a
|
||||
flattenIMIMIM = IM.unions . IM.map IM.unions
|
||||
Reference in New Issue
Block a user