Attempt to reimplement cloud springs

This commit is contained in:
jgk
2021-07-21 00:53:51 +02:00
parent 7b45a4a295
commit 7367fc8f09
2 changed files with 23 additions and 14 deletions
+22 -13
View File
@@ -80,7 +80,7 @@ update' w = case _menuLayers w of
where
(x,y) = crZoneOfPoint $ _crPos cr
cid = _crID cr
zoneClouds = set cloudsZone (foldr cloudInZone IM.empty (_clouds w))
zoneClouds = set cloudsZone (foldl' (flip cloudInZone) IM.empty (_clouds w))
cloudInZone cl = insertInZoneWith x y (++) [cl]
where
(x,y) = cloudZoneOfPoint $ _clPos cl
@@ -161,9 +161,21 @@ checkEndGame w
| otherwise = w
updateClouds :: World -> World
updateClouds w = w
updateClouds w = w & clouds %~ mapMaybe (updateCloud w)
--updateClouds w = IM.foldl' updateCloud w $ _clouds w
updateCloud :: World -> Cloud -> Maybe Cloud
updateCloud w c
| _clTimer c < 1 = Nothing
| otherwise = Just $ c
& clPos %~ (+.+ newVel)
& clVel .~ newVel
& clTimer -~ 1
where
newVel = 0.90 *.* springVels
springVels = foldl' (clClSpringVel c) (_clVel c) (cloudsNearPoint oldPos w)
oldPos = _clPos c
--updateCloud :: World -> Cloud -> World
--updateCloud w c
-- | _clTimer c < 1 = w & clouds %~ IM.delete (_clID c)
@@ -184,17 +196,14 @@ updateClouds w = w
-- & 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
clClSpringVel :: Cloud -> Point2 -> Cloud -> Point2
clClSpringVel a v b
| dist pa pb < radDist = v +.+ 0.1 *.* safeNormalizeV (pa -.- pb)
| otherwise = v
where
pa = _clPos a
pb = _clPos b
radDist = (_clRad a + _clRad b) / 2
simpleCrSprings :: World -> World
simpleCrSprings w = IM.foldr' crSpring w $ _creatures w
+1 -1
View File
@@ -5,7 +5,7 @@ import Dodge.Data
import Dodge.Base
--import Geometry
import Picture
import qualified IntMapHelp as IM
--import qualified IntMapHelp as IM
import Control.Lens