167 lines
5.0 KiB
Haskell
167 lines
5.0 KiB
Haskell
module Dodge.Zone
|
|
( crZoneOfPoint
|
|
, zoneOfLineIntMap
|
|
, wallsNearPoint
|
|
, wallsAlongLine
|
|
, zoneSize
|
|
, zoneOfPoint
|
|
, wallsAlongCirc
|
|
, wallsOnScreen
|
|
, lookLookups
|
|
, zoneAroundPoint
|
|
, floorHun
|
|
, zoneOfLine
|
|
, wallsDoubleScreen
|
|
, cloudZoneOfPoint
|
|
, cloudsNearPoint
|
|
, wallsNearZones
|
|
, zoneOfSight
|
|
)
|
|
where
|
|
import Dodge.Data
|
|
import Dodge.Zone.Data
|
|
import Dodge.Base.Window
|
|
import Geometry
|
|
import Geometry.Zone
|
|
|
|
import Data.Maybe
|
|
import Data.List
|
|
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'
|
|
|
|
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
|
|
|
|
zoneOfCircle :: Point2 -> Float -> [(Int,Int)]
|
|
zoneOfCircle p r = concatMap zoneNearPoint $ divideCircle (1.5 * zoneSize) p r
|
|
|
|
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
|
|
|
|
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
|
|
|
|
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
|