204 lines
7.7 KiB
Haskell
204 lines
7.7 KiB
Haskell
{- |
|
|
Module : Dodge.Update
|
|
Description : Simulation update
|
|
-}
|
|
module Dodge.Update
|
|
( update
|
|
) where
|
|
import Dodge.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.
|
|
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.
|
|
-}
|
|
update' :: World -> World
|
|
update' w = case _menuLayers w of
|
|
(ConfigSaveScreen : ls) -> w & menuLayers .~ ls
|
|
(_ : _) -> w
|
|
[] -> let w1 = updateParticles'
|
|
. updateProjectiles
|
|
. updateLightSources
|
|
. zoneClouds
|
|
. updateClouds
|
|
. updateCreatures
|
|
. updateBlocks -- . zoning
|
|
. updateSeenWalls
|
|
. updateSoundQueue
|
|
$ updateCloseObjects w
|
|
in checkEndGame
|
|
. triggerUpdate
|
|
. ppEvents
|
|
. updateCamera
|
|
. colCrsWalls
|
|
. simpleCrSprings
|
|
. zoneCreatures
|
|
. wallEvents
|
|
. set worldEvents id
|
|
$ _worldEvents w1 w1
|
|
where
|
|
zoneCreatures = set creaturesZone (IM.foldr creatureInZone IM.empty (_creatures w))
|
|
creatureInZone cr = insertIMInZone x y cid cr
|
|
where (x,y) = zoneOfPoint $ _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) = zoneOfPoint $ _clPos cr
|
|
cid = _clID cr
|
|
|
|
triggerUpdate :: World -> World
|
|
triggerUpdate w
|
|
| ResetLevel 1 `S.member` _worldTriggers w
|
|
= generateFromList levx
|
|
$ initialWorld
|
|
& randGen .~ _randGen w
|
|
& windowX .~ _windowX w
|
|
& windowY .~ _windowY w
|
|
& menuLayers .~ []
|
|
& creatures . ix 0 .~ (_creatures w IM.! 0 & crPos .~ (0,0))
|
|
| otherwise = w
|
|
|
|
updateSoundQueue = set soundQueue []
|
|
. set sounds M.empty
|
|
|
|
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
|
|
|
|
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' (setOldPos cr)) (id,_randGen w)
|
|
$ _creatures w
|
|
setOldPos cr = cr & crOldPos .~ _crPos cr
|
|
|
|
|
|
wallEvents :: World -> World
|
|
wallEvents w = IM.foldr (_doorMech) w ( IM.filter (\d -> case d of
|
|
Door {} -> True
|
|
BlockAutoDoor {} -> True
|
|
_ -> False) ( _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 yPos = _crPos $ _creatures w IM.! 0
|
|
-- wallsToUpdate = map _wlID $ IM.elems $ wallsNearPoint yPos w
|
|
wallsToUpdate = concatMap (\p -> collidePointFindWalls yPos (yPos +.+p) $ wallsAlongLine yPos (yPos +.+ p) w)
|
|
$ nRays 60
|
|
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 = 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
|
|
|
|
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 = 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
|
|
|
|
collidePointFindWall :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Int
|
|
collidePointFindWall p1 p2 ws = fmap fst $ listToMaybe $ sortBy f
|
|
$ IM.toList
|
|
$ IM.mapMaybe ((\(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine) ws
|
|
where f (_,a) (_,b) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
|
|
|
|
collidePointFindWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Int]
|
|
collidePointFindWalls p1 p2 ws
|
|
-- = map fst . takeWhileAnd g . map snd . sortBy (compare `on` (dist p1 . fst . fromJust)) . filter ((/=) Nothing . fst) . map f $ IM.toList ws
|
|
= map fst . takeWhileAnd g . map snd . sortBy (compare `on` (dist p1 . fromJust . fst)) . filter ((/=) Nothing . fst) . map f $ IM.toList ws
|
|
where f (i,wl) = (intersectSegSeg' (_wlLine wl !! 0) (_wlLine wl !! 1) p1 p2, (i,wl))
|
|
g (_,wl) = _wlIsSeeThrough wl
|
|
takeWhileAnd h xs = let (ys,zs) = span h xs
|
|
in ys ++ tf zs
|
|
where tf (x:_) = [x]
|
|
tf _ = []
|
|
|