Creature zoning refactor

src/Dodge/Base/Collide.hs

@@ -252,8 +252,8 @@ circOnSomeWall p rad = runIdentity . S.any_ (uncurry (circOnSeg p rad) . _wlLine
 --    . wallsNearPoint p
 {- | Adds the distance to the creature radius, tests whether the center is in
 the circle of this size centered at the point -}
-crsNearPoint :: Float -> Point2 -> World -> Bool
-crsNearPoint d p = any (\c -> dist (_crPos c) p < (d + _crRad c)) . _creatures
+anyCrNearPoint :: Float -> Point2 -> World -> Bool
+anyCrNearPoint d p = any (\c -> dist (_crPos c) p < (d + _crRad c)) . _creatures
 {- | Produce an unordered list of creatures on a line. -}
 crsOnLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
 crsOnLine p1 p2

src/Dodge/Update.hs

@@ -149,7 +149,8 @@ doRewind w = case _maybeWorld w of
 zoneCreatures :: World -> World
 zoneCreatures w = w 
     & creaturesZone . znObjects .~
-        runIdentity (S.fold_ zoneCreature IM.empty id (S.each $ _creatures w))
+        IM.foldl' zoneCreature IM.empty (_creatures w)
+--        runIdentity (S.fold_ zoneCreature IM.empty id (S.each $ _creatures w))
 
 zoneCreature :: IM.IntMap (IM.IntMap (IM.IntMap Creature)) 
     -> Creature
@@ -347,7 +348,7 @@ updateCloud w c
     newVel@(V3 _ _ nvz) = (0.95 *.*.* springVels) +.+.+ V3 0 0 (0.001 * vertVel)
     newVel2 = stripZ newVel
     vertVel = _clAlt c - opz
-    springVels = runIdentity $ S.fold_ (clClSpringVel c) (_clVel c) id (cloudsNearPoint oldPos2 w)
+    springVels = runIdentity $ S.fold_ (clClSpringVel c) (_clVel c) id (clsNearPoint oldPos2 w)
     oldPos@(V3 _ _ opz) = _clPos c
     oldPos2 = stripZ oldPos
     newPos@(V3 _ _ npz) = oldPos +.+.+ newVel
@@ -369,10 +370,11 @@ clClSpringVel a v b
 simpleCrSprings :: World -> World
 simpleCrSprings w = IM.foldl' (flip crSpring) w $ _creatures w
 
+-- note that this may in rare cases not push creatures away from each other
 crSpring :: Creature -> World -> World
-crSpring c w = IM.foldl' (flip $ crCrSpring c) w cs
+crSpring c w = runIdentity $ S.fold_ (flip $ crCrSpring c) w id cs
   where 
-    cs = creaturesNearPoint (_crPos c) w
+    cs = crsNearPoint (_crPos c) w
 
 crCrSpring :: Creature -> Creature -> World -> World
 crCrSpring c1 c2

src/Dodge/WorldEvent/SpawnParticle.hs

@@ -240,9 +240,12 @@ makeGasCloud pos vel w = w
     (col, g) = runState (takeOne [green,yellow]) $ _randGen w
 {- Attach poison cloud damage to creatures near cloud.  -}
 cloudPoisonDamage :: Cloud -> World -> World
-cloudPoisonDamage c w = w & creatures %~ flip (foldl' (flip $ IM.adjust doDam)) damagedCrs
+cloudPoisonDamage c w = w & creatures 
+    %~ dodamagesto damagedCrs
   where 
-    damagedCrs = IM.keys $ IM.filter f $ creaturesNearPoint clpos w
+    dodamagesto :: StreamOf Creature -> IM.IntMap Creature -> IM.IntMap Creature
+    dodamagesto = undefined
+    damagedCrs = S.filter f $ crsNearPoint clpos w
     f cr = dist3 (addZ 20 $ _crPos cr) (_clPos c) < _crRad cr + _clRad c + 10
     doDam cr = cr & crState . csDamage .:~ Damage POISONDAM 1 clpos clpos clpos NoDamageEffect
     clpos = stripZ $ _clPos c

src/Dodge/Zone.hs

@@ -1,7 +1,6 @@
 module Dodge.Zone
     ( crZoneOfPoint
     , wallsNearPoint
-    , wallsNearPoint'
     , wallsAlongLine
     , crsNearSeg
     , wallsInsideCirc
@@ -11,12 +10,13 @@ module Dodge.Zone
     , zoneNearPoint
     , zoneOfCreature
     , clZoneOfPoint
-    , cloudsNearPoint
+    , clsNearPoint
     , zoneOfSight
     , flattenIMIMIM
     , wlZoneOfPoint
+    , crsNearPoint
     , creaturesNearPointI
-    , creaturesNearPoint
+--    , creaturesNearPoint
     , creatureNearPoint
     , creatureNearPointI
     , creaturesAlongLine
@@ -90,12 +90,10 @@ lookLookup i j z = case IM.lookup i z of
 lookLookups :: [(Int,Int)] -> IM.IntMap (IM.IntMap a) -> [a]
 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
+clsNearPoint :: Point2 -> World -> Stream (Of Cloud) Identity ()
+clsNearPoint p w = S.each . fromMaybe mempty $ w ^? cloudsZone . znObjects . ix x . ix y
   where 
     V2 x y = clZoneOfPoint p
-    f Nothing = []
-    f (Just l) = l
 
 -- TODO check whether/when nubbing of walls is necessary
 wallsAlongLine :: Point2 -> Point2 -> World -> Stream (Of Wall) Identity ()
@@ -113,20 +111,10 @@ 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
 
-wallsNearPoint' :: Point2 -> World -> [Wall]
-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]]
+wallsNearPoint :: Point2 -> World -> StreamOf Wall
+wallsNearPoint p = S.each . fromMaybe mempty . (^? wallsZone . znObjects . ix x . ix y)
   where
     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 
---    (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 . fmap IM.unions
@@ -137,6 +125,11 @@ creatureNearPoint = creatureNearPointI 1
 creatureNearPointI :: Int -> Point2 -> World -> Maybe Creature
 creatureNearPointI n p = L.fold (L.minimumOn (dist p . _crPos)) . creaturesNearPointI n p
 
+crsNearPoint :: Point2 -> World -> StreamOf Creature
+crsNearPoint p = S.each . fromMaybe mempty . (^? creaturesZone . znObjects . ix x . ix y)
+  where
+    V2 x y = crZoneOfPoint p
+
 creaturesNearPoint :: Point2 -> World -> IM.IntMap Creature
 creaturesNearPoint = creaturesNearPointI 1