223 lines
7.2 KiB
Haskell
223 lines
7.2 KiB
Haskell
{- | Deals with the specific implementations of zoning for Dodge.
|
|
- These are not yet fixed down. -}
|
|
module Dodge.Base.Zone
|
|
where
|
|
import Dodge.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
|
|
--zoneSize = 100
|
|
|
|
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]
|
|
|
|
-- the laser seemed to be occasionally missing creatures,
|
|
-- if this reoccurs, maybe change
|
|
-- divide line factor from 2 to 1.5
|
|
bres :: Point2 -> Point2 -> [(Int,Int)]
|
|
bres a b = digitalLine (zoneOfPoint a) (zoneOfPoint b)
|
|
|
|
bresx :: Point2 -> Point2 -> [(Int,Int)]
|
|
bresx a b = digitalLine (x-1,y-1) (x'-1,y'-1)
|
|
where
|
|
(x,y) = zoneOfPoint a
|
|
(x',y') = zoneOfPoint b
|
|
|
|
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
|
|
--zoneOfLineIntMap a b = expandLine $ digitalLine (x-1,y-1) (x'-1,y'-1)
|
|
-- where
|
|
-- (x,y) = zoneOfPoint a
|
|
-- (x',y') = zoneOfPoint b
|
|
|
|
|
|
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
|
|
|
|
|
|
--zoneOfLine a b = concatMap zoneNearPoint $ divideLine (2 * zoneSize) a b
|
|
--zoneOfLine a b = concatMap zoneNearPoint $ divideLine zoneSize a b
|
|
|
|
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
|
|
-- [(a,b) | a <- xs
|
|
-- , b <- 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 -- = IM.unions [f b $ f a $ _wallsZone w | (a,b) <- is]
|
|
= foldl' (flip $ IM.union . \i -> innerFold (f i (_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 -- = wallsNearZones (zoneOfScreen w) w
|
|
= foldl' (flip $ IM.union . \i -> innerFold (f i (_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 (_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
|
|
|
|
-- 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 $ _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 $ _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 $ _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 $ _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
|