420 lines
15 KiB
Haskell
420 lines
15 KiB
Haskell
{- |
|
|
Module : Dodge.Update
|
|
Description : Simulation update
|
|
-}
|
|
module Dodge.Update ( updateUniverse ) where
|
|
import Dodge.Data
|
|
import Dodge.Menu
|
|
import Dodge.CullBox
|
|
--import Dodge.Block
|
|
import Dodge.Distortion
|
|
import Dodge.SoundLogic
|
|
import Dodge.Wall.Delete
|
|
import Dodge.Update.WallDamage
|
|
--import Dodge.Menu
|
|
import Dodge.Base
|
|
import Dodge.Zone
|
|
import Dodge.Hammer
|
|
import Dodge.WallCreatureCollisions
|
|
import Dodge.Update.Camera
|
|
import Dodge.Inventory
|
|
import Sound.Data
|
|
import Geometry
|
|
import LensHelp
|
|
import FoldableHelp
|
|
|
|
--import qualified Data.Text as T
|
|
--import System.Random
|
|
import Data.List
|
|
import Data.Maybe
|
|
--import Data.Function
|
|
import qualified Data.IntMap.Strict as IM
|
|
import qualified Data.Map.Strict as M
|
|
import Control.Applicative
|
|
--import qualified Data.Set as S
|
|
--import Data.Monoid
|
|
--import System.Random
|
|
|
|
{- For most menus the only way to change the world is using event handling. -}
|
|
updateUniverse :: Universe -> Universe
|
|
updateUniverse u = case _menuLayers u of
|
|
(WaitScreen s i : _)
|
|
| i < 1 -> u & over uvWorld (dbArg _worldEvents)
|
|
| otherwise -> u & menuLayers %~ ( (WaitScreen s (i-1) :) . tail )
|
|
(OptionScreen {_scOptionFlag = GameOverOptions} : _) -> u & uvWorld %~
|
|
( updateParticles
|
|
. updateIMl _props _pjUpdate
|
|
. updateLightSources
|
|
. updateClouds )
|
|
(_ : _) -> u
|
|
[] -> over uvWorld (functionalUpdate (_config u)) u
|
|
|
|
{- | The update step. -}
|
|
functionalUpdate :: Configuration -> World -> World
|
|
functionalUpdate cfig w = checkEndGame
|
|
-- . updateRandGen
|
|
. (mouseButtons . each .~ True) -- to determine if the mouse button is held
|
|
. (worldClock +~ 1)
|
|
. doRewind
|
|
. (doubleMouseHammer %~ moveHammerUp)
|
|
. updateDistortions
|
|
. updateCreatureSoundPositions
|
|
. ppEvents
|
|
. updateCamera cfig
|
|
. colCrsWalls cfig
|
|
. simpleCrSprings
|
|
. zoneCreatures
|
|
. updateIMl _doors _drMech
|
|
. updateDelayedEvents
|
|
. resetWorldEvents
|
|
. dbArg _worldEvents
|
|
. updateIMl _modifications _mdUpdate
|
|
. updateParticles
|
|
. updateBeams
|
|
. updateIMl _props _pjUpdate
|
|
. updateLightSources
|
|
. updateClouds
|
|
. updateGusts
|
|
. zoneClouds
|
|
. updateMIM magnets _mgUpdate
|
|
. updateIMl' _terminals tmUpdate
|
|
. updateIMl _machines mcChooseUpdate
|
|
. updateIMl _creatures _crUpdate
|
|
-- creatures should be updated early so that crOldPos is set before any position change
|
|
. over creatures (fmap setOldPos)
|
|
. updateCreatureGroups
|
|
-- . updateBlocks
|
|
. updateWallDamages
|
|
. updateSeenWalls
|
|
-- . (youHammerPosition %~ moveHammerUp)
|
|
. updateTerminal
|
|
. updateRBList
|
|
. updateBoundBox cfig -- where should this go? next to update camera?
|
|
$ updateCloseObjects w
|
|
where
|
|
--updatedLightSources = mapMaybe (\b -> _tlsUpdate b w b) $ _tempLightSources w
|
|
zoneClouds = set (cloudsZone . znObjects) (foldl' (flip cloudInZone) IM.empty (_clouds w))
|
|
cloudInZone cl = insertInZoneWith x y (++) [cl]
|
|
where
|
|
(x,y) = cloudZoneOfPoint $ stripZ $ _clPos cl
|
|
|
|
|
|
updateBoundBox :: Configuration -> World -> World
|
|
updateBoundBox cfig w = w & boundBox .~ cullBox cfig w
|
|
|
|
mcChooseUpdate :: Machine -> Machine -> World -> World
|
|
mcChooseUpdate mc mc'
|
|
| _mcHP mc > 0 = _mcUpdate mc mc'
|
|
| otherwise = (machines %~ IM.delete (_mcID mc))
|
|
. deleteWallIDs (_mcWallIDs mc)
|
|
. _mcDeath mc mc'
|
|
|
|
tmUpdate :: Terminal -> World -> World
|
|
tmUpdate tm w = case w ^? terminals . ix (_tmID tm) . tmFutureLines . ix 0 of
|
|
Nothing -> w
|
|
Just tl | _tlPause tl > 0 -> w & pointTermParams . tmFutureLines . ix 0 . tlPause -~ 1
|
|
Just (TerminalLineDisplay _ f) -> w & pointTermParams %~
|
|
( ( tmFutureLines %~ tail )
|
|
. ( tmDisplayedLines .:~ f w )
|
|
)
|
|
Just (TerminalLineEffect _ eff) -> w
|
|
& pointTermParams . tmFutureLines %~ tail
|
|
& eff tm
|
|
Just (TerminalLineTerminalEffect _ eff) -> w
|
|
& pointTermParams . tmFutureLines %~ tail
|
|
& pointTermParams %~ eff
|
|
where
|
|
pointTermParams = terminals . ix (_tmID tm)
|
|
|
|
setOldPos :: Creature -> Creature
|
|
setOldPos cr = cr
|
|
& crOldPos .~ _crPos cr
|
|
& crOldDir .~ _crDir cr
|
|
|
|
-- hack
|
|
--updateRandGen :: World -> World
|
|
--updateRandGen = randGen %~ (snd . (uniform :: StdGen -> (Int,StdGen)))
|
|
|
|
doRewind :: World -> World
|
|
doRewind w = case _maybeWorld w of
|
|
Just' w' -> w' & timeFlow .~ RewindingLastFrame
|
|
Nothing' -> w & timeFlow .~ NormalTimeFlow
|
|
|
|
zoneCreatures :: World -> World
|
|
zoneCreatures w = w
|
|
& creaturesZone . znObjects .~
|
|
IM.foldl' (flip creatureInZone) IM.empty (_creatures w)
|
|
where
|
|
creatureInZone cr = insertIMInZone x y cid cr
|
|
where
|
|
(x,y) = crZoneOfPoint $ _crPos cr
|
|
cid = _crID cr
|
|
|
|
updateCreatureSoundPositions :: World -> World
|
|
updateCreatureSoundPositions w = M.foldlWithKey' insertSound w
|
|
. M.mapMaybeWithKey updateSound
|
|
$ _playingSounds w
|
|
where
|
|
insertSound w' k s = w' & toPlaySounds %~ M.insertWith (const id) k s
|
|
updateSound (CrMouth cid) s = case w ^? creatures . ix cid . crPos of
|
|
Just p -> Just s {_soundPos = p, _soundAngDist = Just (soundAngle p w,0)}
|
|
Nothing -> Just s {_soundTime = Just 0}
|
|
updateSound _ _ = Nothing
|
|
|
|
--updateIMr :: (World -> IM.IntMap a) -> (a -> a -> World -> World) -> World -> World
|
|
--updateIMr fim fup w = foldr (dbArg fup) w (fim w)
|
|
updateIMl :: (World -> IM.IntMap a) -> (a -> a -> World -> World) -> World -> World
|
|
updateIMl fim fup w = foldl' (flip $ dbArg fup) w (fim w)
|
|
|
|
updateIMl' :: (World -> IM.IntMap a) -> (a -> World -> World) -> World -> World
|
|
updateIMl' fim fup w = foldl' (flip fup) w (fim w)
|
|
|
|
-- | Note the explict use of record syntax. Using lens created a space leak.
|
|
resetWorldEvents :: World -> World
|
|
resetWorldEvents w = w {_worldEvents = id}
|
|
|
|
updateCreatureGroups :: World -> World
|
|
updateCreatureGroups w = w & creatureGroups %~
|
|
IM.mapMaybe (\cgp -> _crGroupUpdate cgp w cgp)
|
|
|
|
updateDistortions :: World -> World
|
|
updateDistortions = distortions %~ mapMaybe updateDistortion
|
|
|
|
updateLightSources :: World -> World
|
|
updateLightSources w = over tempLightSources f w
|
|
where
|
|
f = mapMaybe (\b -> _tlsUpdate b w b)
|
|
|
|
{- Apply internal particle updates, delete 'Nothing's. -}
|
|
updateParticles :: World -> World
|
|
updateParticles w = updateInstantParticles $ set particles (catMaybes ps) w'
|
|
where
|
|
(w',ps) = mapAccumR (\a b -> _ptUpdate b a b) w $ _particles w
|
|
updateBeams :: World -> World
|
|
updateBeams w = w
|
|
& newBeams .~ WorldBeams [] [] [] []
|
|
& beams .~ thebeams
|
|
& combineBeams thebeams
|
|
where
|
|
thebeams = _newBeams w
|
|
|
|
combineBeams :: WorldBeams -> World -> World
|
|
combineBeams wbeams w = w''
|
|
& beams . positronBeams .~ pbeams
|
|
& beams . electronBeams .~ ebeams
|
|
where
|
|
(w',pbeams) = mapAccumR (combineBeamBeams (_electronBeams wbeams)) w $ _positronBeams wbeams
|
|
(w'',ebeams) = mapAccumR (combineBeamBeams (_positronBeams wbeams)) w' $ _electronBeams wbeams
|
|
|
|
combineBeamBeams :: [Beam] -> World -> Beam -> (World,Beam)
|
|
combineBeamBeams bms w bm = case intersectBeamBeams bm bms of
|
|
(ps,Nothing) -> (w, bm & bmFirstPoints .~ ps)
|
|
(ps,Just a) -> (_beamCombine (_bmType bm) a w, bm & bmFirstPoints .~ ps)
|
|
|
|
-- intersect a beam with a list of beams.
|
|
-- returns the (reversed) travel of the beam up to maybe an intersection point
|
|
intersectBeamBeams :: Beam -> [Beam]
|
|
-> ([Point2], Maybe (Point2,(Point2,Point2,Beam),(Point2,Point2,Beam)))
|
|
intersectBeamBeams bm bms = f [] $ _bmPoints bm
|
|
where
|
|
f ps (x:y:ys) = case intersectSegBeams x y bms of
|
|
Just (z,a) -> (z:x:ps, Just (z,(x,y,bm),a))
|
|
Nothing -> f (x:ps) (y:ys)
|
|
f ps [x] = (x:ps, Nothing)
|
|
f _ _ = error "made an empty beam"
|
|
|
|
intersectSegBeams :: Point2 -> Point2 -> [Beam] -> Maybe (Point2,(Point2,Point2,Beam))
|
|
intersectSegBeams sp ep (bm:bms) = case intersectSegBeam sp ep bm of
|
|
Nothing -> intersectSegBeams sp ep bms
|
|
--Just a@(z,_) -> maybe (Just a) Just $ intersectSegBeams sp z bms
|
|
Just a@(z,_) -> intersectSegBeams sp z bms <|> Just a
|
|
intersectSegBeams _ _ _ = Nothing
|
|
|
|
intersectSegBeam :: Point2 -> Point2 -> Beam -> Maybe (Point2,(Point2,Point2,Beam))
|
|
intersectSegBeam sp ep bm = case intersectSegSegs' sp ep (_bmPoints bm) of
|
|
Nothing -> Nothing
|
|
Just (z,x,y) -> Just (z,(x,y,bm))
|
|
|
|
intersectSegSegs' :: Point2 -> Point2 -> [Point2] -> Maybe (Point2,Point2,Point2)
|
|
intersectSegSegs' sp ep (x:y:ys) = case intersectSegSeg sp ep x y of
|
|
--Just z -> maybe (Just (z,x,y)) Just $ intersectSegSegs' sp z (y:ys)
|
|
Just z -> intersectSegSegs' sp z (y:ys) <|> Just (z,x,y)
|
|
Nothing -> intersectSegSegs' sp ep (y:ys)
|
|
intersectSegSegs' _ _ _ = Nothing
|
|
|
|
--intersectSegSegs :: Point2 -> Point2 -> [Point2] -> Maybe Point2
|
|
--intersectSegSegs sp ep (x:y:ys) = case intersectSegSeg sp ep x y of
|
|
-- Just z -> maybe (Just z) Just $ intersectSegSegs sp z (y:ys)
|
|
-- Nothing -> intersectSegSegs sp ep (y:ys)
|
|
--intersectSegSegs _ _ _ = Nothing
|
|
--
|
|
--intersectSegSegss :: Point2 -> Point2 -> [[Point2]] -> Maybe Point2
|
|
--intersectSegSegss sp ep (as:ass) = case intersectSegSegs sp ep as of
|
|
-- Just z -> maybe (Just z) Just $ intersectSegSegss sp z ass
|
|
-- Nothing -> intersectSegSegss sp ep ass
|
|
--intersectSegSegss _ _ _ = Nothing
|
|
--
|
|
--intersectSegsSegss :: [Point2] -> [[Point2]] -> Maybe Point2
|
|
--intersectSegsSegss (x:y:ys) ass = maybe
|
|
-- (intersectSegsSegss (y:ys) ass)
|
|
-- Just
|
|
-- (intersectSegSegss x y ass)
|
|
--intersectSegsSegss _ _ = Nothing
|
|
|
|
updateInstantParticles :: World -> World
|
|
updateInstantParticles w = case _instantParticles w of
|
|
[] -> w
|
|
ps -> let (w',ps') = mapAccumR (\a b -> _ptUpdate b a b) (w {_instantParticles=[]}) ps
|
|
in updateInstantParticles $ w' & particles .++~ catMaybes ps'
|
|
|
|
updateMIM :: ASetter' World (IM.IntMap a) -> (a -> a -> Maybe a) -> World -> World
|
|
updateMIM f up = f %~ IM.mapMaybe (dbArg up)
|
|
|
|
-- Note that this updates the randgen
|
|
--updateCreatures :: World -> World
|
|
--updateCreatures w = appEndo f $ w
|
|
-- & creatures .~ IM.mapMaybe id m
|
|
-- & randGen .~ newg
|
|
-- where
|
|
-- ((f,newg),m) = mapAccumR crUp (Endo id,_randGen w) (_creatures w)
|
|
-- crUp (f',g) cr = ((f' <> f'',g'), cr')
|
|
-- where
|
|
-- (f'',cr') = _crUpdate cr cr (w & randGen .~ g)
|
|
-- (_,g') = genWord8 g
|
|
|
|
ppEvents :: World -> World
|
|
ppEvents w = IM.foldl' (flip $ \pp -> _ppEvent pp pp) w $ _pressPlates w
|
|
|
|
-- this is not working correctly, maybe a problem with wallsAlongLine
|
|
updateSeenWalls :: World -> World
|
|
updateSeenWalls w = foldl' markWallSeen w wallsToUpdate
|
|
where
|
|
vPos = _cameraViewFrom w
|
|
wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w)
|
|
$ nRays 20
|
|
-- wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ _walls w)
|
|
-- $ nRays 20
|
|
|
|
markWallSeen :: World -> Wall -> World
|
|
markWallSeen w wl = w { _walls = IM.adjust mw (_wlID wl) $ _walls w }
|
|
where
|
|
mw wl' = wl' {_wlSeen = True}
|
|
|
|
checkEndGame :: World -> World
|
|
checkEndGame w = case _deathDelay w of
|
|
Just x | x < 0 -> w & sideEffects %~ ( . (menuLayers .~ [gameOverMenu]))
|
|
& deathDelay .~ Nothing
|
|
Just _ -> w & deathDelay . _Just -~ 1
|
|
_ | _crHP (you w) < 1 -> w & deathDelay ?~ 50
|
|
_ -> w
|
|
|
|
updateGusts :: World -> World
|
|
updateGusts w = w
|
|
& gusts %~ IM.mapMaybe (mvGust w)
|
|
|
|
mvGust :: World -> Gust -> Maybe Gust
|
|
mvGust _ gu
|
|
| _guTime gu < 0 = Nothing
|
|
| otherwise = Just $ gu
|
|
& guPos .+.+~ _guVel gu
|
|
& guTime -~ 1
|
|
updateClouds :: World -> World
|
|
updateClouds w = w' & clouds .~ catMaybes mclouds
|
|
where
|
|
(w',mclouds) = mapAccumR updateCloud w (_clouds w)
|
|
|
|
updateCloud :: World -> Cloud -> (World,Maybe Cloud)
|
|
updateCloud w c
|
|
| _clTimer c < 1 = (w, Nothing)
|
|
| otherwise = (_clEffect c c w, Just $ c
|
|
& clPos .~ finalPos
|
|
& clVel .~ finalVel
|
|
& clTimer -~ 1
|
|
)
|
|
where
|
|
newVel@(V3 _ _ nvz) = (0.95 *.*.* springVels) +.+.+ V3 0 0 (0.001 * vertVel)
|
|
newVel2 = stripZ newVel
|
|
vertVel = _clAlt c - opz
|
|
springVels = foldl' (clClSpringVel c) (_clVel c) (cloudsNearPoint oldPos2 w)
|
|
oldPos@(V3 _ _ opz) = _clPos c
|
|
oldPos2 = stripZ oldPos
|
|
newPos@(V3 _ _ npz) = oldPos +.+.+ newVel
|
|
newPos2 = stripZ newPos
|
|
-- the following only tests for the first collision with a wall
|
|
hitWl = collidePointAnyWallsReflect oldPos2 newPos2 $ wallsNearPoint newPos2 w
|
|
finalPos = addZ (min 74 npz) $ maybe newPos2 fst hitWl
|
|
-- allowing clouds at/above height 75 causes graphical glitches 22.05.23
|
|
finalVel = addZ nvz $ maybe newVel2 snd hitWl
|
|
|
|
--updateCloud :: World -> Cloud -> Maybe Cloud
|
|
--updateCloud w c
|
|
-- | _clTimer c < 1 = Nothing
|
|
-- | otherwise = Just $ c
|
|
-- & clPos .~ finalPos
|
|
-- & clVel .~ finalVel
|
|
-- & clTimer -~ 1
|
|
-- where
|
|
-- newVel = 0.95 *.* springVels
|
|
-- springVels = 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
|
|
|
|
clClSpringVel :: Cloud -> Point3 -> Cloud -> Point3
|
|
clClSpringVel a v b
|
|
| dist3 pa pb < radDist = v +.+.+ 0.1 *.*.* normalizeV3 (pa -.-.- pb)
|
|
| otherwise = v
|
|
where
|
|
pa = _clPos a
|
|
pb = _clPos b
|
|
radDist = (_clRad a + _clRad b) / 2
|
|
|
|
simpleCrSprings :: World -> World
|
|
simpleCrSprings w = IM.foldl' (flip crSpring) w $ _creatures w
|
|
|
|
crSpring :: Creature -> World -> World
|
|
crSpring c w = IM.foldl' (flip $ crCrSpring c) w cs
|
|
where
|
|
cs = creaturesNearPoint (_crPos c) w
|
|
|
|
crCrSpring :: Creature -> Creature -> World -> World
|
|
crCrSpring c1 c2 w
|
|
| id1 == id2 = w
|
|
| vec == V2 0 0 = w
|
|
| diff >= comRad = w
|
|
| otherwise = over creatures
|
|
( over (ix id1 . crPos) (+.+ overlap1)
|
|
. over (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 visible walls from a point to another point. -}
|
|
visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall]
|
|
visibleWalls p1 p2 ws
|
|
= takeUntil wlIsOpaque
|
|
. map snd
|
|
. sortOn (dist p1 . fromJust . fst)
|
|
. filter (isJust . fst)
|
|
. map f
|
|
$ IM.elems ws
|
|
where
|
|
f wl = (uncurry intersectSegSeg (_wlLine wl) p1 p2, wl)
|
|
|
|
updateDelayedEvents :: World -> World
|
|
updateDelayedEvents w = let (neww,newde) = mapAccumR f w (_delayedEvents w)
|
|
in neww & delayedEvents .~ catMaybes newde
|
|
where
|
|
f w' (i,g)
|
|
| i <= 0 = (g w', Nothing)
|
|
| otherwise = (w', Just (i-1,g))
|