Steps towards making clouds list based

src/Dodge/Base.hs

@@ -109,14 +109,13 @@ creaturesNearPointI n p w =  IM.unions [f b $ f a $ _creaturesZone w | a<-[x-n..
         Just val -> val
         _        -> IM.empty
 
-cloudsNearPoint :: Point2 -> World -> IM.IntMap Cloud
+cloudsNearPoint :: Point2 -> World -> [Cloud]
 --cloudsNearPoint p w =  IM.unions [f b $ f a $ _cloudsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
-cloudsNearPoint p w =  f y $ f x $ _cloudsZone w
+cloudsNearPoint p w = f ((IM.lookup x $ _cloudsZone w) >>= IM.lookup y)
   where 
     (x,y) = cloudZoneOfPoint p
-    f i m = case IM.lookup i m of 
+    f Nothing = []
-        Just val -> val
+    f (Just l) = l
-        _        -> IM.empty
 -- possible BUG, occurs when used in thingsHitLongLine
 creaturesAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
 --creaturesAlongLine a b w = IM.unions [f y $ f x $ _creaturesZone w | (x,y) <- zoneOfLine a b]

src/Dodge/Data.hs

@@ -55,8 +55,8 @@ data World = World
     , _creaturesZone        :: IM.IntMap (IM.IntMap (IM.IntMap Creature))
     , _creatureGroups       :: IM.IntMap CrGroupParams
     , _itemPositions        :: IM.IntMap ItemPos
-    , _clouds               :: IM.IntMap Cloud
+    , _clouds               :: [Cloud]
-    , _cloudsZone           :: IM.IntMap (IM.IntMap (IM.IntMap Cloud))
+    , _cloudsZone           :: IM.IntMap (IM.IntMap [Cloud])
     , _projectiles          :: IM.IntMap Projectile
     , _particles            :: ![Particle]
     , _staticWalls          :: IM.IntMap (IM.IntMap [Wall'])
@@ -123,14 +123,17 @@ data Corpse = Corpse
     , _cpRes :: Creature
     }
 data Cloud = Cloud
-    { _clID :: Int
+    { _clPos :: Point2
-    , _clPos :: Point2
     , _clVel :: Point2
     , _clPict :: Cloud -> Picture
     , _clRad :: Float
     , _clTimer :: Int
-    , _clEffect :: Cloud -> World -> World
+    , _clType :: CloudType
+--    , _clEffect :: Cloud -> World -> World
     }
+data CloudType
+    = SmokeCloud
+    | GasCloud
 data LightSource = LS  
     { _lsID         :: !Int
     , _lsPos        :: !Point3

src/Dodge/Default/World.hs

@@ -27,7 +27,7 @@ defaultWorld = World
     , _creatures = IM.empty
     , _creaturesZone = IM.empty
     , _creatureGroups = IM.empty
-    , _clouds = IM.empty
+    , _clouds = []
     , _cloudsZone = IM.empty
     , _itemPositions = IM.empty
     , _projectiles = IM.empty

src/Dodge/Render/Picture.hs

@@ -23,7 +23,7 @@ worldPictures w = pictures $ concat
     , map (dbArg _pjDraw)  . IM.elems $ _projectiles w
     , map drawItem . IM.elems $ _floorItems w
     , map (crDraw w) . IM.elems $ _creatures w
-    , map clDraw   . reverse . IM.elems $ _clouds w
+    , map clDraw   . reverse $ _clouds w
     , map ppDraw   . IM.elems $ _pressPlates w
     , map btDraw (IM.elems (_buttons w))
     , map (dbArg _ptDraw) $ _particles w

src/Dodge/Update.hs

@@ -80,11 +80,10 @@ update' w = case _menuLayers w of
       where 
         (x,y) = crZoneOfPoint $ _crPos cr
         cid = _crID cr
-    zoneClouds = set cloudsZone (IM.foldr cloudInZone IM.empty (_clouds w))
+    zoneClouds = set cloudsZone (foldr cloudInZone IM.empty (_clouds w))
-    cloudInZone cr = insertIMInZone x y cid cr
+    cloudInZone cl = insertInZoneWith x y (++) [cl]
       where 
-        (x,y) = cloudZoneOfPoint $ _clPos cr
+        (x,y) = cloudZoneOfPoint $ _clPos cl
-        cid = _clID cr
 
 updateCreatureGroups :: World -> World
 updateCreatureGroups w = w & creatureGroups %~ 
@@ -161,43 +160,41 @@ checkEndGame w
     | _crHP (you w) < 1 = haltSound $ w {_menuLayers = [GameOverMenu]}
     | otherwise         = w
 
---updateClouds :: World -> World
---updateClouds = (clouds .~ IM.empty) . (cloudsZone .~ IM.empty)
-
 updateClouds :: World -> World
-updateClouds w = IM.foldl' updateCloud w $ _clouds w 
+updateClouds w = w
+--updateClouds w = IM.foldl' updateCloud w $ _clouds w 
 
-updateCloud :: World -> Cloud -> World
+--updateCloud :: World -> Cloud -> World
-updateCloud w c
+--updateCloud w c
-    | _clTimer c < 1 = w & clouds %~ IM.delete (_clID c)
+--    | _clTimer c < 1 = w & clouds %~ IM.delete (_clID c)
-    | otherwise = moveCloud c w
+--    | otherwise = moveCloud c w
-
+--
-moveCloud :: Cloud -> World -> World
+--moveCloud :: Cloud -> World -> World
-moveCloud c w = _clEffect c c . theUpdate $ w
+--moveCloud c w = _clEffect c c . theUpdate $ w
-  where 
+--  where 
-    newVel = 0.95 *.* springVels
+--    newVel = 0.95 *.* springVels
-    springVels = IM.foldl' (clClSpringVel c) (_clVel c) (cloudsNearPoint oldPos w)
+--    springVels = IM.foldl' (clClSpringVel c) (_clVel c) (cloudsNearPoint oldPos w)
-    oldPos = _clPos c
+--    oldPos = _clPos c
-    newPos = oldPos +.+ newVel
+--    newPos = oldPos +.+ newVel
-    hitWl = collideCircWalls' oldPos newPos 5 $ wallsNearPoint newPos w
+--    hitWl = collideCircWalls' oldPos newPos 5 $ wallsNearPoint newPos w
-    finalPos = maybe newPos fst hitWl
+--    finalPos = maybe newPos fst hitWl
-    finalVel = maybe newVel snd hitWl
+--    finalVel = maybe newVel snd hitWl
-    theUpdate w' = w' 
+--    theUpdate w' = w' 
-        & clouds . ix (_clID c) . clTimer %~ (\t -> t - 1)
+--        & clouds . ix (_clID c) . clTimer %~ (\t -> t - 1)
-        & clouds . ix (_clID c) . clVel .~ finalVel
+--        & clouds . ix (_clID c) . clVel .~ finalVel
-        & clouds . ix (_clID c) . clPos .~ finalPos
+--        & clouds . ix (_clID c) . clPos .~ finalPos
-
+--
-clClSpringVel :: Cloud -> Point2 -> Cloud -> Point2
+--clClSpringVel :: Cloud -> Point2 -> Cloud -> Point2
-clClSpringVel a v b
+--clClSpringVel a v b
-    | ida == idb = v
+--    | ida == idb = v
-    | dist pa pb < radDist = v +.+ 0.1 *.* safeNormalizeV (pa -.- pb)
+--    | dist pa pb < radDist = v +.+ 0.1 *.* safeNormalizeV (pa -.- pb)
-    | otherwise = v
+--    | otherwise = v
-  where 
+--  where 
-    ida = _clID a
+--    ida = _clID a
-    idb = _clID b
+--    idb = _clID b
-    pa = _clPos a
+--    pa = _clPos a
-    pb = _clPos b
+--    pb = _clPos b
-    radDist = (_clRad a + _clRad b) / 2
+--    radDist = (_clRad a + _clRad b) / 2
 
 simpleCrSprings :: World -> World
 simpleCrSprings w = IM.foldr' crSpring w $ _creatures w

src/Dodge/WorldEvent/Cloud.hs

@@ -10,17 +10,16 @@ import qualified IntMapHelp as IM
 import Control.Lens
 
 makeCloudAt :: Float -> Int -> (Cloud -> Picture) -> Point2 -> World -> World
-makeCloudAt rad t drawFunc p w = w & clouds %~ IM.insert i theCloud
+makeCloudAt rad t drawFunc p w = w & clouds %~ (theCloud :)
   where 
-    i = IM.newKey $ _clouds w
     theCloud = Cloud 
-        { _clID = i
+        { _clPos = p
-        , _clPos = p
         , _clVel = (0,0)
         , _clPict = drawFunc
         , _clRad = rad
         , _clTimer = t
-        , _clEffect = const id
+        , _clType = SmokeCloud
+        --, _clEffect = const id
         }
 
 drawCloudWith :: Float -> Float -> Color -> Cloud -> Picture

src/Dodge/WorldEvent/SpawnParticle.hs

@@ -264,18 +264,18 @@ makeGasCloud
     -> World 
     -> World
 makeGasCloud pos vel w = w
-    & clouds    %~ IM.insert i theCloud
+    & clouds    %~ (theCloud :)
     & randGen   .~ g
   where 
-    i = IM.newKey $ _clouds w
+    theCloud = Cloud 
-    theCloud = Cloud { _clID = i
+        {  _clPos = pos
-                     , _clPos = pos
         , _clVel = vel
         , _clPict = \_ -> onLayer CrLayer $ color (withAlpha 0.1 col) 
                                           $ circleSolid 20
         , _clRad = 10
         , _clTimer = 400
-                     , _clEffect = cloudPoisonDamage
+        , _clType = GasCloud
+        -- , _clEffect = cloudPoisonDamage
         }
     (col, g) = runState (takeOne [green,yellow]) $ _randGen w