From 7b45a4a295144d9319f76afdf48cd07da9944e45 Mon Sep 17 00:00:00 2001 From: jgk Date: Wed, 21 Jul 2021 00:05:13 +0200 Subject: [PATCH] Steps towards making clouds list based --- src/Dodge/Base.hs | 9 ++-- src/Dodge/Data.hs | 13 +++-- src/Dodge/Default/World.hs | 2 +- src/Dodge/Render/Picture.hs | 2 +- src/Dodge/Update.hs | 75 +++++++++++++-------------- src/Dodge/WorldEvent/Cloud.hs | 9 ++-- src/Dodge/WorldEvent/SpawnParticle.hs | 22 ++++---- 7 files changed, 65 insertions(+), 67 deletions(-) diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 02913f49a..a6bd86113 100644 --- a/src/Dodge/Base.hs +++ b/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 - Just val -> val - _ -> IM.empty + f Nothing = [] + f (Just l) = l -- 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] diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 4cfe19121..a9139a7ea 100644 --- a/src/Dodge/Data.hs +++ 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 - , _cloudsZone :: IM.IntMap (IM.IntMap (IM.IntMap Cloud)) + , _clouds :: [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 diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index ecedc4f95..65ac47a34 100644 --- a/src/Dodge/Default/World.hs +++ b/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 diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index e37eab7a3..65a7c80f5 100644 --- a/src/Dodge/Render/Picture.hs +++ b/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 diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 338f43f80..30c1c9e09 100644 --- a/src/Dodge/Update.hs +++ b/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)) - cloudInZone cr = insertIMInZone x y cid cr + zoneClouds = set cloudsZone (foldr cloudInZone IM.empty (_clouds w)) + cloudInZone cl = insertInZoneWith x y (++) [cl] where - (x,y) = cloudZoneOfPoint $ _clPos cr - cid = _clID cr + (x,y) = cloudZoneOfPoint $ _clPos cl 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 w c - | _clTimer c < 1 = w & clouds %~ IM.delete (_clID c) - | otherwise = moveCloud c w - -moveCloud :: Cloud -> World -> World -moveCloud c w = _clEffect c c . theUpdate $ w - where - newVel = 0.95 *.* springVels - springVels = IM.foldl' (clClSpringVel c) (_clVel c) (cloudsNearPoint oldPos w) - oldPos = _clPos c - newPos = oldPos +.+ newVel - hitWl = collideCircWalls' oldPos newPos 5 $ wallsNearPoint newPos w - finalPos = maybe newPos fst hitWl - finalVel = maybe newVel snd hitWl - theUpdate w' = w' - & clouds . ix (_clID c) . clTimer %~ (\t -> t - 1) - & clouds . ix (_clID c) . clVel .~ finalVel - & clouds . ix (_clID c) . clPos .~ finalPos - -clClSpringVel :: Cloud -> Point2 -> Cloud -> Point2 -clClSpringVel a v b - | ida == idb = v - | dist pa pb < radDist = v +.+ 0.1 *.* safeNormalizeV (pa -.- pb) - | otherwise = v - where - ida = _clID a - idb = _clID b - pa = _clPos a - pb = _clPos b - radDist = (_clRad a + _clRad b) / 2 +--updateCloud :: World -> Cloud -> World +--updateCloud w c +-- | _clTimer c < 1 = w & clouds %~ IM.delete (_clID c) +-- | otherwise = moveCloud c w +-- +--moveCloud :: Cloud -> World -> World +--moveCloud c w = _clEffect c c . theUpdate $ w +-- where +-- newVel = 0.95 *.* springVels +-- springVels = IM.foldl' (clClSpringVel c) (_clVel c) (cloudsNearPoint oldPos w) +-- oldPos = _clPos c +-- newPos = oldPos +.+ newVel +-- hitWl = collideCircWalls' oldPos newPos 5 $ wallsNearPoint newPos w +-- finalPos = maybe newPos fst hitWl +-- finalVel = maybe newVel snd hitWl +-- theUpdate w' = w' +-- & clouds . ix (_clID c) . clTimer %~ (\t -> t - 1) +-- & clouds . ix (_clID c) . clVel .~ finalVel +-- & clouds . ix (_clID c) . clPos .~ finalPos +-- +--clClSpringVel :: Cloud -> Point2 -> Cloud -> Point2 +--clClSpringVel a v b +-- | ida == idb = v +-- | dist pa pb < radDist = v +.+ 0.1 *.* safeNormalizeV (pa -.- pb) +-- | otherwise = v +-- where +-- ida = _clID a +-- idb = _clID b +-- pa = _clPos a +-- pb = _clPos b +-- radDist = (_clRad a + _clRad b) / 2 simpleCrSprings :: World -> World simpleCrSprings w = IM.foldr' crSpring w $ _creatures w diff --git a/src/Dodge/WorldEvent/Cloud.hs b/src/Dodge/WorldEvent/Cloud.hs index 46e60b367..0fed2477b 100644 --- a/src/Dodge/WorldEvent/Cloud.hs +++ b/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 diff --git a/src/Dodge/WorldEvent/SpawnParticle.hs b/src/Dodge/WorldEvent/SpawnParticle.hs index ad61fc6bc..8094f74b4 100644 --- a/src/Dodge/WorldEvent/SpawnParticle.hs +++ b/src/Dodge/WorldEvent/SpawnParticle.hs @@ -264,19 +264,19 @@ 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 { _clID = i - , _clPos = pos - , _clVel = vel - , _clPict = \_ -> onLayer CrLayer $ color (withAlpha 0.1 col) - $ circleSolid 20 - , _clRad = 10 - , _clTimer = 400 - , _clEffect = cloudPoisonDamage - } + theCloud = Cloud + { _clPos = pos + , _clVel = vel + , _clPict = \_ -> onLayer CrLayer $ color (withAlpha 0.1 col) + $ circleSolid 20 + , _clRad = 10 + , _clTimer = 400 + , _clType = GasCloud + -- , _clEffect = cloudPoisonDamage + } (col, g) = runState (takeOne [green,yellow]) $ _randGen w {-