Add airlocks
This commit is contained in:
+91
-81
@@ -7,6 +7,7 @@ module Dodge.Update
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.Data.Menu
|
||||
import Dodge.World.Trigger.Data
|
||||
import Dodge.Config.Data
|
||||
import Dodge.Data.Menu
|
||||
import Dodge.Base
|
||||
@@ -35,35 +36,38 @@ pushSideEffects :: World -> World
|
||||
pushSideEffects w = w
|
||||
& sideEffects .~ []
|
||||
& doneSideEffects .~ _sideEffects w
|
||||
|
||||
{- | The update step.
|
||||
If '_menuLayers' is not empty, or the saving screen, this is the identity.
|
||||
In such menus, the only way to change the world is using event handling.
|
||||
-}
|
||||
{- |
|
||||
The update step.
|
||||
For most menus the only way to change the world is using event handling. -}
|
||||
update' :: World -> World
|
||||
update' w = case _menuLayers w of
|
||||
(WaitMessage _ : ls) -> w & menuLayers .~ ls
|
||||
(_ : _) -> w
|
||||
[] -> let w1 = updateParticles
|
||||
. updateProjectiles
|
||||
. updateLightSources
|
||||
. zoneClouds
|
||||
. updateClouds
|
||||
. updateCreatures
|
||||
. updateBlocks -- . zoning
|
||||
. updateSeenWalls
|
||||
. updateSoundQueue
|
||||
$ updateCloseObjects w
|
||||
in checkEndGame
|
||||
. updateTriggers
|
||||
. ppEvents
|
||||
. updateCamera
|
||||
. colCrsWalls
|
||||
. simpleCrSprings
|
||||
. zoneCreatures
|
||||
. updateWalls
|
||||
. set worldEvents id
|
||||
$ _worldEvents w1 w1
|
||||
(GameOverMenu : _) -> updateParticles
|
||||
. updateProjectiles
|
||||
. updateLightSources
|
||||
$ updateClouds
|
||||
w
|
||||
(_ : _) -> w
|
||||
[] -> checkEndGame
|
||||
. updateTriggers
|
||||
. ppEvents
|
||||
. updateCamera
|
||||
. colCrsWalls
|
||||
. simpleCrSprings
|
||||
. zoneCreatures
|
||||
. updateWalls
|
||||
. set worldEvents id
|
||||
. doubleArgumentFor _worldEvents
|
||||
. updateParticles
|
||||
. updateProjectiles
|
||||
. updateLightSources
|
||||
. zoneClouds
|
||||
. updateClouds
|
||||
. updateCreatures
|
||||
. updateBlocks
|
||||
. updateSeenWalls
|
||||
. updateSoundQueue
|
||||
$ updateCloseObjects w
|
||||
where
|
||||
zoneCreatures = set creaturesZone (IM.foldr creatureInZone IM.empty (_creatures w))
|
||||
creatureInZone cr = insertIMInZone x y cid cr
|
||||
@@ -73,17 +77,18 @@ update' w = case _menuLayers w of
|
||||
cloudInZone cr = insertIMInZone x y cid cr
|
||||
where (x,y) = zoneOfPoint $ _clPos cr
|
||||
cid = _clID cr
|
||||
doubleArgumentFor f x = f x x
|
||||
|
||||
updateTriggers :: World -> World
|
||||
updateTriggers w
|
||||
| ResetLevel 1 `S.member` _worldTriggers w
|
||||
= generateFromList levx
|
||||
$ initialWorld
|
||||
& randGen .~ _randGen w
|
||||
& config .~ _config w
|
||||
& menuLayers .~ []
|
||||
& creatures . ix 0 . crPos .~ (0,0)
|
||||
| ResetLevel 1 `S.member` _worldTriggers w = generateFromList levx $ initialWorld
|
||||
& randGen .~ _randGen w
|
||||
& config .~ _config w
|
||||
& menuLayers .~ []
|
||||
& creatures . ix 0 .~ cr
|
||||
| otherwise = w
|
||||
where
|
||||
cr = _creatures w IM.! 0 & crPos .~ (0,0)
|
||||
|
||||
updateSoundQueue = set soundQueue [] . set sounds M.empty
|
||||
|
||||
@@ -93,10 +98,8 @@ updateLightSources w = set tempLightSources (catMaybes tlss) w'
|
||||
(w',tlss) = mapAccumR (\a b -> _tlsUpdate b a b) w $ _tempLightSources w
|
||||
|
||||
updateProjectiles w = IM.foldr' _pjUpdate w $ _projectiles w
|
||||
|
||||
{-
|
||||
Apply internal particle updates, delete 'Nothing's.
|
||||
-}
|
||||
Apply internal particle updates, delete 'Nothing's. -}
|
||||
updateParticles :: World -> World
|
||||
updateParticles w = set particles (catMaybes ps) w'
|
||||
where
|
||||
@@ -105,12 +108,11 @@ updateParticles w = set particles (catMaybes ps) w'
|
||||
updateCreatures :: World -> World
|
||||
updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w
|
||||
where
|
||||
((f,newG),crs) = IM.mapAccum (\g' cr -> _crUpdate cr w g' cr) (id,_randGen w)
|
||||
$ _creatures w
|
||||
((f,newG),crs) =
|
||||
IM.mapAccum (\g' cr -> _crUpdate cr w g' cr) (id,_randGen w) $ _creatures w
|
||||
|
||||
{- |
|
||||
Apply door mechanisms.
|
||||
-}
|
||||
Apply door mechanisms. -}
|
||||
updateWalls :: World -> World
|
||||
updateWalls w = IM.foldr (maybe id id . (^? doorMech)) w (_walls w)
|
||||
|
||||
@@ -127,69 +129,75 @@ updateSeenWalls w = foldr markSeen w wallsToUpdate
|
||||
|
||||
setTestStringIO :: IO World -> IO World
|
||||
setTestStringIO = fmap (\ w -> set testString (show $ s w) w)
|
||||
where s w = (-.-) <$> (w ^? creatures . ix 0 . crPos) <*> (w ^? creatures . ix 0 . crOldPos)
|
||||
where
|
||||
s w = (-.-) <$> (w ^? creatures . ix 0 . crPos) <*> (w ^? creatures . ix 0 . crOldPos)
|
||||
|
||||
checkEndGame :: World -> World
|
||||
checkEndGame w | _crHP (you w) < 1 = haltSound $ w {_menuLayers = [GameOverMenu]}
|
||||
| otherwise = w
|
||||
checkEndGame w
|
||||
| _crHP (you w) < 1 = haltSound $ w {_menuLayers = [GameOverMenu]}
|
||||
| otherwise = w
|
||||
|
||||
updateClouds :: World -> World
|
||||
updateClouds w = IM.foldr' updateCloud w $ _clouds w
|
||||
|
||||
updateCloud :: Cloud -> World -> World
|
||||
updateCloud c w | _clTimer c < 1 = w & clouds %~ IM.delete (_clID c)
|
||||
| otherwise = moveCloud c w
|
||||
updateCloud c w
|
||||
| _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.foldr' (clClSpringVel c w) (_clVel c) (cloudsNearPoint oldPos w)
|
||||
oldPos = _clPos c
|
||||
newPos = oldPos +.+ newVel
|
||||
hitWl = collideCircWalls' oldPos newPos 5 $ wallsNearPoint newPos w
|
||||
finalPos = fromMaybe newPos (fmap fst hitWl)
|
||||
finalVel = fromMaybe newVel (fmap 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
|
||||
where
|
||||
newVel = 0.95 *.* springVels
|
||||
springVels = IM.foldr' (clClSpringVel c w) (_clVel c) (cloudsNearPoint oldPos w)
|
||||
oldPos = _clPos c
|
||||
newPos = oldPos +.+ newVel
|
||||
hitWl = collideCircWalls' oldPos newPos 5 $ wallsNearPoint newPos w
|
||||
finalPos = fromMaybe newPos (fmap fst hitWl)
|
||||
finalVel = fromMaybe newVel (fmap 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 -> World -> Cloud -> Point2 -> Point2
|
||||
clClSpringVel a w b v
|
||||
| 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
|
||||
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
|
||||
|
||||
crSpring :: Creature -> World -> World
|
||||
crSpring c w = IM.foldr' (crCrSpring c) w $ cs
|
||||
where cs = creaturesNearPoint (_crPos c) w
|
||||
where
|
||||
cs = creaturesNearPoint (_crPos c) w
|
||||
|
||||
crCrSpring :: Creature -> Creature -> World -> World
|
||||
crCrSpring c1 c2 w
|
||||
| id1 == id2 = w
|
||||
| vec == (0,0) = w
|
||||
| diff < comRad = over (creatures . ix id1 . crPos) (+.+ overlap1)
|
||||
$ over (creatures . ix id2 . crPos) (-.- overlap2) w
|
||||
| otherwise = w
|
||||
where id1 = _crID c1
|
||||
id2 = _crID c2
|
||||
vec = _crPos c1 -.- _crPos c2
|
||||
diff = magV $ vec
|
||||
comRad = _crRad c1 + _crRad c2
|
||||
overlap1 = ((comRad - diff) * _crMass c2 * 0.5 / massT) *.* errorNormalizeV 55 vec
|
||||
overlap2 = ((comRad - diff) * _crMass c1 * 0.5 / massT) *.* errorNormalizeV 56 vec
|
||||
massT = _crMass c1 + _crMass c2
|
||||
|
||||
| id1 == id2 = w
|
||||
| vec == (0,0) = w
|
||||
| diff < comRad = over (creatures . ix id1 . crPos) (+.+ overlap1)
|
||||
$ over (creatures . ix id2 . crPos) (-.- overlap2) w
|
||||
| otherwise = w
|
||||
where
|
||||
id1 = _crID c1
|
||||
id2 = _crID c2
|
||||
vec = _crPos c1 -.- _crPos c2
|
||||
diff = magV $ vec
|
||||
comRad = _crRad c1 + _crRad c2
|
||||
overlap1 = ((comRad - diff) * _crMass c2 * 0.5 / massT) *.* errorNormalizeV 55 vec
|
||||
overlap2 = ((comRad - diff) * _crMass c1 * 0.5 / massT) *.* errorNormalizeV 56 vec
|
||||
massT = _crMass c1 + _crMass c2
|
||||
{-
|
||||
Finds the IDs of visible walls from a point to another point.
|
||||
-}
|
||||
Finds the IDs of visible walls from a point to another point. -}
|
||||
visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Int]
|
||||
visibleWalls p1 p2 ws
|
||||
= map fst
|
||||
@@ -201,8 +209,10 @@ visibleWalls p1 p2 ws
|
||||
$ IM.toList ws
|
||||
where
|
||||
f (i,wl) = (intersectSegSeg' (_wlLine wl !! 0) (_wlLine wl !! 1) p1 p2, (i,wl))
|
||||
takeUntil h xs = let (ys,zs) = span h xs
|
||||
in ys ++ tf zs
|
||||
where tf (x:_) = [x]
|
||||
tf _ = []
|
||||
takeUntil h xs =
|
||||
let (ys,zs) = span h xs
|
||||
in ys ++ tf zs
|
||||
where
|
||||
tf (x:_) = [x]
|
||||
tf _ = []
|
||||
|
||||
|
||||
Reference in New Issue
Block a user