justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Cleanup, move towards unifying zones

Browse Source
This commit is contained in:
justin
2021-09-11 15:52:43 +01:00
parent 27e4f16dd9
commit aa7413a29f
57 changed files with 157 additions and 331 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base/Collide.hs
+1 -1
View File
@@ -3,7 +3,7 @@
module Dodge.Base.Collide
where
import Dodge.Data
import Dodge.Base.Zone
import Dodge.Zone
import Geometry
import FoldableHelp
src/Dodge/Base/Zone.hs
-247
View File
@@ -1,247 +0,0 @@
{- | 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 Dodge.Bounds
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
import qualified Data.Vector as V
zoneSize :: Float
zoneSize = 50
--zoneSize = 100
data Zoning a = Zoning
{ _znObjects :: V.Vector (V.Vector a)
, _znSize :: Int
, _znBounds :: Bounds
}
setupZoning :: Int -> Bounds -> a -> Zoning a
setupZoning size bounds x = Zoning
{ _znObjects = V.replicate xsize (V.replicate ysize x)
, _znSize = size
, _znBounds = bounds
}
where
toInt y = (ceiling y `div` size) + 1
xFloatSize = _bdMaxX bounds - _bdMinX bounds
yFloatSize = _bdMaxX bounds - _bdMinX bounds
xsize = toInt xFloatSize
ysize = toInt yFloatSize
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]
-- TODO sort out zoning of walls properly
wallsDoubleScreen :: World -> IM.IntMap Wall
wallsDoubleScreen w = _walls 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)) * 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
flattenIMIMIM :: IM.IntMap (IM.IntMap (IM.IntMap a)) -> IM.IntMap a
flattenIMIMIM = IM.unions . IM.map IM.unions