228 lines
6.9 KiB
Haskell
228 lines
6.9 KiB
Haskell
{- |
|
|
Module : Dodge.Update
|
|
Description : Simulation update
|
|
-}
|
|
module Dodge.Update
|
|
( update
|
|
) where
|
|
import Dodge.Data
|
|
import Dodge.Data.Menu
|
|
import Dodge.World.Trigger.Data
|
|
import Dodge.Config.Data
|
|
import Dodge.Base
|
|
import Dodge.WallCreatureCollisions
|
|
import Dodge.LevelGen.Block
|
|
import Dodge.Update.Camera
|
|
import Dodge.Update.UsingInput
|
|
import Dodge.SoundLogic
|
|
import Dodge.Inventory
|
|
import Dodge.Initialisation
|
|
import Dodge.Layout
|
|
import Dodge.Floor
|
|
import Geometry
|
|
|
|
import Data.List
|
|
import Data.Maybe
|
|
import Data.Function
|
|
import qualified Data.Set as S
|
|
import qualified Data.IntMap.Strict as IM
|
|
import qualified Data.Map as M
|
|
import Control.Lens
|
|
|
|
update = update' . pushSideEffects
|
|
|
|
pushSideEffects :: World -> World
|
|
pushSideEffects w = w
|
|
& sideEffects .~ []
|
|
& doneSideEffects .~ _sideEffects w
|
|
{- |
|
|
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 s i: ls)
|
|
| i < 1 -> w & doubleArgumentFor _worldEvents
|
|
| otherwise -> w & menuLayers %~ ( (WaitMessage s (i-1) :) . tail )
|
|
(GameOverMenu : _) -> updateParticles
|
|
. updateProjectiles
|
|
. updateLightSources
|
|
. updateClouds
|
|
$ updateSoundQueue
|
|
w
|
|
(_ : _) -> w
|
|
[] -> checkEndGame
|
|
. updateTriggers
|
|
. ppEvents
|
|
. updateCamera
|
|
. colCrsWalls
|
|
. simpleCrSprings
|
|
. zoneCreatures
|
|
. updateWalls
|
|
. set worldEvents id
|
|
. doubleArgumentFor _worldEvents
|
|
. updateParticles
|
|
. updateProjectiles
|
|
. updateLightSources
|
|
. zoneClouds
|
|
. updateClouds
|
|
. updateCreatures
|
|
. updateCreatureGroups
|
|
. updateBlocks
|
|
. updateSeenWalls
|
|
. updateSoundQueue
|
|
$ updateCloseObjects w
|
|
where
|
|
zoneCreatures = set creaturesZone (IM.foldr creatureInZone IM.empty (_creatures w))
|
|
creatureInZone cr = insertIMInZone x y cid cr
|
|
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
|
|
where
|
|
(x,y) = cloudZoneOfPoint $ _clPos cr
|
|
cid = _clID cr
|
|
doubleArgumentFor f x = f x x
|
|
|
|
updateCreatureGroups :: World -> World
|
|
updateCreatureGroups w = w & creatureGroups %~
|
|
IM.mapMaybe (\cgp -> _crGroupUpdate cgp w cgp)
|
|
|
|
updateTriggers :: World -> World
|
|
updateTriggers w
|
|
| 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
|
|
|
|
updateLightSources :: World -> World
|
|
updateLightSources w = set tempLightSources (catMaybes tlss) w'
|
|
where
|
|
(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. -}
|
|
updateParticles :: World -> World
|
|
updateParticles w = set particles (catMaybes ps) w'
|
|
where
|
|
(w',ps) = mapAccumR (\a b -> _ptUpdate' b a b) w $ _particles 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
|
|
|
|
{- |
|
|
Apply door mechanisms. -}
|
|
updateWalls :: World -> World
|
|
updateWalls w = IM.foldr (fromMaybe id . (^? doorMech)) w (_walls w)
|
|
|
|
ppEvents :: World -> World
|
|
ppEvents w = IM.foldr (\pp w -> _ppEvent pp pp w) w $ _pressPlates w
|
|
|
|
updateSeenWalls :: World -> World
|
|
updateSeenWalls w = foldr markSeen w wallsToUpdate
|
|
where
|
|
vPos = _cameraViewFrom w
|
|
wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w)
|
|
$ nRays 20
|
|
markSeen i = set (walls . ix i . wlSeen) True
|
|
|
|
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)
|
|
|
|
checkEndGame :: World -> World
|
|
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
|
|
|
|
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 = 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 -> 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
|
|
|
|
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
|
|
|
|
crCrSpring :: Creature -> Creature -> World -> World
|
|
crCrSpring c1 c2 w
|
|
| id1 == id2 = w
|
|
| vec == (0,0) = w
|
|
| diff >= comRad = w
|
|
| otherwise = over (creatures . ix id1 . crPos) (+.+ overlap1)
|
|
$ over (creatures . ix id2 . crPos) (-.- overlap2) 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. -}
|
|
visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Int]
|
|
visibleWalls p1 p2 ws
|
|
= map fst
|
|
. takeUntil (_wlIsSeeThrough . snd)
|
|
. map snd
|
|
. sortOn (dist p1 . fromJust . fst)
|
|
. filter ((/=) Nothing . fst)
|
|
. map f
|
|
$ IM.toList ws
|
|
where
|
|
f (i,wl) = (uncurry intersectSegSeg' (_wlLine wl) p1 p2, (i,wl))
|
|
takeUntil h xs =
|
|
let (ys,zs) = span h xs
|
|
in ys ++ tf zs
|
|
where
|
|
tf (x:_) = [x]
|
|
tf _ = []
|
|
|