Zone creatures

src/Dodge/Block.hs

@@ -32,7 +32,7 @@ unshadowBlock wlid w = case w ^? walls . ix wlid of
         & walls . ix wlid . wlDraw .~ True
         & wallsZone . znObjects . ix x . ix y . ix wlid . wlDraw .~ True
       where
-        V2 x y = wallZoneOfPoint $ uncurry midPoint (_wlLine wl)
+        V2 x y = wlZoneOfPoint $ uncurry midPoint (_wlLine wl)
     Nothing -> w
 
 checkBlockHP :: Block -> World -> World

src/Dodge/Item/Weapon/UseEffect.hs

@@ -123,8 +123,8 @@ itemBlips p r = IM.elems . IM.filter f . fmap _flItPos . _floorItems
 
 wallBlips :: Point2 -> Float -> World -> [Point2]
 wallBlips p r w = runIdentity . S.toList_ $ S.mapMaybe (uncurry (intersectCircSegFirst p r) . _wlLine)
-        $ S.map (over wlLine swp) (wallsAlongCirc' p r w)
+        $ S.map (over wlLine swp) (wallsInsideCirc p r w)
-                      <> wallsAlongCirc' p r w
+                      <> wallsInsideCirc p r w
   where
     swp (a,b) = (b,a)
 

src/Dodge/Path.hs

@@ -92,5 +92,5 @@ removePathsCrossing a b w = w
     & pathPoints .~ foldr insertPoint IM.empty (labNodes newGraph)
   where 
     pg' = S.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
-    insertPoint pp@(_,p) = uncurryV insertInZoneWith (wallZoneOfPoint p) (++) [pp]
+    insertPoint pp@(_,p) = uncurryV insertInZoneWith (wlZoneOfPoint p) (++) [pp]
     newGraph = pairsToGraph dist pg'

src/Dodge/Placement/PlaceSpot/Block.hs

@@ -47,9 +47,9 @@ addBlock (p:ps) wl bl w = w
             = insertIMInZone x y wlid wl'
         | otherwise = flip (foldl' $ flip (\(a,b) -> insertIMInZone a b wlid wl')) ips
       where 
-        V2 x y = wallZoneOfPoint $ uncurry midPoint (_wlLine wl)
+        V2 x y = wlZoneOfPoint $ uncurry midPoint (_wlLine wl)
         wlid  = _wlID wl
-        ips = map (unv2 . wallZoneOfPoint) $ uncurry (divideLine (2*wlZoneSize)) (_wlLine wl)
+        ips = map (unv2 . wlZoneOfPoint) $ uncurry (divideLine (2*wlZoneSize)) (_wlLine wl)
         unv2 (V2 x' y') = (x',y')
 addBlock _ _ _ _ = error "Trying to add a block with incomplete polygon"
         

src/Dodge/Update.hs

@@ -100,7 +100,7 @@ functionalUpdate cfig w = checkEndGame
     zoneClouds = set (cloudsZone . znObjects) (foldl' (flip cloudInZone) IM.empty (_clouds w))
     cloudInZone cl = insertInZoneWith x y (++) [cl]
       where 
-        (x,y) = cloudZoneOfPoint $ stripZ $ _clPos cl
+        V2 x y = clZoneOfPoint $ stripZ $ _clPos cl
 
 updateWorldSelect :: World -> World
 updateWorldSelect w = case w ^? mouseButtons . ix ButtonLeft of
@@ -149,12 +149,21 @@ doRewind w = case _maybeWorld w of
 zoneCreatures :: World -> World
 zoneCreatures w = w 
     & creaturesZone . znObjects .~
-        IM.foldl' (flip creatureInZone) IM.empty (_creatures w)
+        runIdentity (S.fold_ zoneCreature IM.empty id (S.each $ _creatures w))
+
+zoneCreature :: IM.IntMap (IM.IntMap (IM.IntMap Creature)) 
+    -> Creature
+    -> IM.IntMap (IM.IntMap (IM.IntMap Creature)) 
+zoneCreature m cr = runIdentity $ S.fold_ doinsert m id (zoneOfCreature cr)
   where
-    creatureInZone cr = insertIMInZone x y cid cr
+    doinsert m' (V2 x y) = insertIMInZone x y (_crID cr) cr m'
-      where 
+
-        (x,y) = crZoneOfPoint $ _crPos cr
+--        IM.foldl' (flip creatureInZone) IM.empty (_creatures w)
-        cid = _crID cr
+--  where
+--    creatureInZone cr = insertIMInZone x y cid cr
+--      where 
+--        V2 x y = crZoneOfPoint $ _crPos cr
+--        cid = _crID cr
 
 updateCreatureSoundPositions :: World -> World
 updateCreatureSoundPositions w = M.foldlWithKey' insertSound w 

src/Dodge/WorldEvent/Shockwave.hs

@@ -70,7 +70,7 @@ mvShockwave is w pt
             w'
             id
             hitBlocks
-    hitBlocks = S.map snd . overlapCircWalls p rad $ wallsAlongCirc' p rad w 
+    hitBlocks = S.map snd . overlapCircWalls p rad $ wallsInsideCirc p rad w 
         -- this is not expansive enough
     damCr cr 
         | _crID cr `elem` is || dist (_crPos cr) p >= rad + _crRad cr  = cr

src/Dodge/WorldEvent/ThingsHit.hs

@@ -35,8 +35,8 @@ crsHit sp ep
     | otherwise = sortStreamOn (dist sp . fst)
         . S.mapMaybe 
             (\cr -> (, cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep))
-        . S.each 
+--        . S.each . _creatures
-        . _creatures
+        . crsNearSeg sp ep
 
 thingHit :: Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall)
 thingHit sp ep = runIdentity . S.head_ . thingsHit sp ep

src/Dodge/Zone.hs

@@ -3,17 +3,18 @@ module Dodge.Zone
     , wallsNearPoint
     , wallsNearPoint'
     , wallsAlongLine
-    , wallsAlongCirc'
+    , crsNearSeg
+    , wallsInsideCirc
     , lookLookups
     , zoneOfSeg
     , zoneNearPointIP
     , zoneNearPoint
-    , cloudZoneOfPoint
+    , zoneOfCreature
+    , clZoneOfPoint
     , cloudsNearPoint
-    , wallsNearZones
     , zoneOfSight
     , flattenIMIMIM
-    , wallZoneOfPoint
+    , wlZoneOfPoint
     , creaturesNearPointI
     , creaturesNearPoint
     , creatureNearPoint
@@ -29,107 +30,57 @@ import Geometry
 import Geometry.Zone
 import qualified FoldlHelp as L
 
-import qualified Data.Set as Set
 import qualified Streaming.Prelude as S
 import Streaming
 import Data.Maybe
-import Data.List
---import Data.IntMap.Merge.Strict
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
 
---flattenZones ::  Zone (IM.IntMap a) -> IM.IntMap a
+wlZoneOfPoint :: Point2 -> Int2
---flattenZones = flattenIMIMIM . _znObjects
+wlZoneOfPoint = zoneOfPoint wlZoneSize
 
-sizeZoneOfPoint :: Float -> Point2 -> (Int,Int)
+clZoneOfPoint :: Point2 -> Int2
-sizeZoneOfPoint s (V2 x y) = (f x, f y)
+clZoneOfPoint = zoneOfPoint clZoneSize
-  where
-    f = floor . (/ s)
 
-wallZoneOfPoint :: Point2 -> V2 Int 
+crZoneOfPoint :: Point2 -> Int2
-wallZoneOfPoint (V2 x y) = V2 (divTo wlZoneSize x) (divTo wlZoneSize y)
+crZoneOfPoint = zoneOfPoint crZoneSize
 
-cloudZoneOfPoint :: Point2 -> (Int,Int)
+zoneOfSeg :: Float -> Point2 -> Point2 -> StreamOf Int2
-cloudZoneOfPoint = sizeZoneOfPoint 20
-
-crZoneOfPoint :: Point2 -> (Int,Int)
-crZoneOfPoint = sizeZoneOfPoint crZoneSize
-
-zoneOfSeg :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
 --zoneOfLineStream = ddaSqStream zoneSize
 zoneOfSeg = ddaStream
 
-zoneOfCirc :: Monad m => Point2 -> Float -> Stream (Of (V2 Int)) m ()
+zoneOfCreature :: Creature -> StreamOf Int2
-zoneOfCirc p = S.each . zoneOfCircle p
+zoneOfCreature cr = zoneInsideCirc crZoneSize (_crPos cr) (_crRad cr)
 
-zoneOfCircle :: Point2 -> Float -> Set.Set (V2 Int)
+zoneInsideCirc :: Float -> Point2 -> Float -> StreamOf Int2
-zoneOfCircle p r = foldMap zoneNearPointS $ divideCircle (1.5 * wlZoneSize) p r
+zoneInsideCirc x p r = ddaSqStream x (p +.+ V2 r r) (p -.- V2 r r)
-
-zoneNearPointS :: Point2 -> Set.Set (V2 Int)
-zoneNearPointS p = Set.fromList [V2 a b | a <- [x-1..x+1] , b <- [y-1..y+1] ]
-  where
-    V2 x y = wallZoneOfPoint p
 
 zoneNearPointIP :: Point2 -> [(Int,Int)]
 zoneNearPointIP p = [(a,b) | a <- [x-1..x+1] , b <- [y-1..y+1] ]
   where
-    V2 x y = wallZoneOfPoint p
+    V2 x y = wlZoneOfPoint p
 
 zoneNearPoint :: Point2 -> Stream (Of (V2 Int)) Identity ()
 zoneNearPoint p = S.each [V2 a b | a <- [x-1..x+1] , b <- [y-1..y+1] ]
   where
-    V2 x y = wallZoneOfPoint p
+    V2 x y = wlZoneOfPoint p
 
+--zoneOfBounds :: Float -> (Float,Float,Float,Float) -> Stream (Of Int2) Identity ()
+--zoneOfBounds x (n,s,e,w) = ddaSqStream x (V2 n e) (V2 s w)
+
+-- this is ugly, might be better with zoneOfBounds or somesuch
 zoneOfSight :: Float -> World -> Stream (Of (V2 Int)) Identity () --(Int,Int)]
-zoneOfSight x w = S.each
+zoneOfSight x' w = S.each
     [V2 a b 
         | a <- [minimum xs .. maximum xs]
         , b <- [minimum ys .. maximum ys]
     ]
   where 
     --(xs,ys) = unzip $ map zoneOfPoint $ screenPolygon cfig w -- ++ [_cameraViewFrom w]
-    (xs,ys) = unzip $ map (sizeZoneOfPoint x) $ _boundBox w -- ++ [_cameraViewFrom w]
+    (xs,ys) = unzip $ map (sizeZoneOfPoint x') $ _boundBox w -- ++ [_cameraViewFrom w]
-
+    sizeZoneOfPoint s (V2 x y) = (f x, f y)
---wallsDoubleScreen :: Configuration -> World -> IM.IntMap Wall
+      where
---wallsDoubleScreen cfig w
+        f = floor . (/ s)
---    -- = foldl' (flip $ IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
---    -- for some reason (TODO diagnose) the foldl' version causes errors
---    = foldr (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 (_windowX cfig) (_windowY cfig)
---    xs = [x - n .. x + n]
---    ys = [y - n .. y + n]
-
---wallsOnScreen :: Configuration -> World -> IM.IntMap Wall
---{-# INLINABLE wallsOnScreen #-}
---wallsOnScreen cfig w
---   -- = foldl' (flip $ IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
---    = foldr (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
---    innerFold m = foldr (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 (_windowX cfig) (_windowY cfig)
---    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
@@ -142,7 +93,7 @@ lookLookups xs z = mapMaybe (flip (uncurry lookLookup) z) xs
 cloudsNearPoint :: Point2 -> World -> Stream (Of Cloud) Identity ()
 cloudsNearPoint p w = S.each . f $ w ^? cloudsZone . znObjects . ix x . ix y
   where 
-    (x,y) = cloudZoneOfPoint p
+    V2 x y = clZoneOfPoint p
     f Nothing = []
     f (Just l) = l
 
@@ -152,8 +103,13 @@ wallsAlongLine sp ep w = S.concat $ S.mapMaybe f $ zoneOfSeg wlZoneSize sp ep
   where
     f (V2 i j) = w ^? wallsZone . znObjects . ix i . ix j
 
-wallsAlongCirc' :: Point2 -> Float -> World -> Stream (Of Wall) Identity ()
+crsNearSeg :: Point2 -> Point2 -> World -> StreamOf Creature
-wallsAlongCirc' p r w = S.concat $ S.mapMaybe f $ zoneOfCirc p r
+crsNearSeg sp ep w = S.concat $ S.mapMaybe f $ zoneOfSeg crZoneSize sp ep
+  where
+    f (V2 i j) = w ^? creaturesZone . znObjects . ix i . ix j
+
+wallsInsideCirc :: Point2 -> Float -> World -> Stream (Of Wall) Identity ()
+wallsInsideCirc p r w = S.concat $ S.mapMaybe f $ zoneInsideCirc wlZoneSize p r
   where
     f (V2 i j) = w ^? wallsZone . znObjects . ix i . ix j
 
@@ -163,7 +119,7 @@ wallsNearPoint' p = runIdentity . S.toList_ . wallsNearPoint p
 wallsNearPoint :: Point2 -> World -> Stream (Of Wall) Identity ()
 wallsNearPoint p w = S.concat $ S.mapMaybe f $ S.each [V2 a b | a <- [x-1,x,x+1], b <- [y-1,y,y+1]]
   where
-    V2 x y = wallZoneOfPoint p
+    V2 x y = wlZoneOfPoint p
     f (V2 i j) = w ^? wallsZone . znObjects . ix i . ix j
 --    IM.unions [f b $ f a $ _znObjects $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
 --  where 
@@ -188,7 +144,7 @@ creaturesNearPointI :: Int -> Point2 -> World -> IM.IntMap Creature
 creaturesNearPointI n p w =  IM.unions 
     [f b $ f a $ _znObjects $ _creaturesZone w | a<-[x-n..x+n] , b<-[y-n..y+n]]
   where 
-    (x,y) = crZoneOfPoint p
+    V2 x y = crZoneOfPoint p
     f i m = fromMaybe IM.empty $ IM.lookup i m
 
 creaturesAlongLine :: Point2 -> Point2 -> World -> Stream (Of Creature) Identity ()

src/Geometry/Data.hs

@@ -8,6 +8,9 @@ module Geometry.Data
 import Linear.V2
 import Linear.V3
 import Linear.V4
+import Streaming
+type StreamOf a = Stream (Of a) Identity ()
+type Int2   = V2 Int
 type Point2 = V2 Float
 type Point3 = V3 Float
 type Point4 = V4 Float

src/Geometry/Zone.hs

@@ -10,6 +10,7 @@ module Geometry.Zone
     , xIntercepts
     , yIntercepts
     , divTo
+    , zoneOfPoint
     ) where
 import Geometry.Data
 
@@ -90,9 +91,9 @@ modTo s x = x - s * fromIntegral (divTo s x)
 --    | abs (sx-ex) > abs (sy-ey) = f sp ep
 --    | otherwise = map flipV $ f (flipV sp) (flipV ep)
 
-sizeZoneOfPoint' :: Float -> Point2 -> V2 Int
+zoneOfPoint :: Float -> Point2 -> V2 Int
-{-# INLINE sizeZoneOfPoint' #-}
+{-# INLINE zoneOfPoint #-}
-sizeZoneOfPoint' s = fmap (divTo s)
+zoneOfPoint s = fmap (divTo s)
 
 --increasingInterval :: Int -> Int -> [Int]
 --increasingInterval x y
@@ -128,7 +129,7 @@ ddaExt' s sp@(V2 sx sy) ep@(V2 ex ey)
                     $ map (IS.singleton . divTo s) [x1y,x1y+ydx..]
     | otherwise = ddaExt' s ep sp
   where
-    addsp im = let V2 x y = sizeZoneOfPoint' s sp
+    addsp im = let V2 x y = zoneOfPoint s sp
         in insertXY im (x,y)
     x1 = divTo s sx
     x2 = divTo s ex
@@ -148,8 +149,8 @@ ddaExt' s sp@(V2 sx sy) ep@(V2 ex ey)
 ddaSqStream :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
 ddaSqStream s sp ep = S.each [V2 x y | x <- makeInterval sx ex, y <- makeInterval sy ey]
   where
-    V2 sx sy = sizeZoneOfPoint' s sp
+    V2 sx sy = zoneOfPoint s sp
-    V2 ex ey = sizeZoneOfPoint' s ep
+    V2 ex ey = zoneOfPoint s ep
 
 makeInterval :: Int -> Int -> [Int]
 makeInterval x y
@@ -157,16 +158,16 @@ makeInterval x y
     | otherwise = [y-1..x+1]
 
 ddaStream :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
-ddaStream s sp ep = S.map (sizeZoneOfPoint' s)
+ddaStream s sp ep = S.map (zoneOfPoint s)
     $  S.yield sp
     <> xIntercepts s sp ep
     <> yIntercepts s sp ep
 
 ddaStreamX :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
-ddaStreamX s sp ep = S.map (sizeZoneOfPoint' s) $ xIntercepts s sp ep
+ddaStreamX s sp ep = S.map (zoneOfPoint s) $ xIntercepts s sp ep
 
 ddaStreamY :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
-ddaStreamY s sp ep = S.map (sizeZoneOfPoint' s) $ yIntercepts s sp ep
+ddaStreamY s sp ep = S.map (zoneOfPoint s) $ yIntercepts s sp ep
 
 xIntercepts :: Float -> Point2 -> Point2 -> Stream (Of Point2) Identity ()
 {-# INLINE xIntercepts #-}
@@ -200,7 +201,7 @@ ddaExt s sp@(V2 sx sy) ep@(V2 ex ey)
     | otherwise = addsp . addys . IM.fromDistinctAscList $ zip [x2-1 .. x1-1]
                     $ map (IS.singleton . divTo s) [x2y,x2y+ydx..]
   where
-    addsp im = let V2 x y = sizeZoneOfPoint' s sp
+    addsp im = let V2 x y = zoneOfPoint s sp
         in insertXY im (x,y)
     x1 = divTo s sx
     x2 = divTo s ex