Refactoring

2021-05-03 23:59:20 +02:00
parent b826299cbd
commit e21178b688
20 changed files with 830 additions and 731 deletions
@@ -0,0 +1,172 @@
+{- | 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 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
+zoneOfPoint :: Point2 -> (Int,Int)
+zoneOfPoint (x,y) = (floorHun x, floorHun y)
+
+zoneNearPoint :: Point2 -> [(Int,Int)]
+zoneNearPoint (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 (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 (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 (aa,ab) (ba,bb) 
+    = nub 
+    . concatMap f 
+    $ digitalLine (zoneOfPoint (aa,ab)) (zoneOfPoint (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 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 = [(a,b) | a <- [x - n .. x + n]
+                        , b <- [y - n .. y + n]
+                 ]
+  where 
+    (x,y) = zoneOfPoint $ _cameraCenter w
+    n = ceiling (wh / (_cameraZoom w * zoneSize)) * 2
+    wh = max (getWindowX w) (getWindowY w)
+
+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]
+
+wallsNearZones :: [(Int,Int)] -> World -> IM.IntMap Wall
+wallsNearZones is w = IM.unions [f b $ f a $ _wallsZone w | (a,b) <- 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 (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.foldrWithKey' g IM.empty kps
+  where 
+    g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
+    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