Add in "linear" lWorld to separate time reversable worlds
This commit is contained in:
+66
-69
@@ -13,7 +13,6 @@ import Dodge.Update.Scroll
|
||||
import Control.Applicative
|
||||
import Data.List
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Set as S
|
||||
import Data.Maybe
|
||||
import Dodge.Base
|
||||
import Dodge.Beam
|
||||
@@ -63,7 +62,6 @@ import LensHelp
|
||||
import SDL
|
||||
import Sound.Data
|
||||
import StrictHelp
|
||||
import qualified Data.Text as T
|
||||
|
||||
updateUniverse :: Universe -> Universe
|
||||
updateUniverse = updateUniverseLast . updateUniverseFirst
|
||||
@@ -80,7 +78,7 @@ updateUniverseFirst u
|
||||
u & uvWorld
|
||||
%~ (
|
||||
--updateParticles
|
||||
(cWorld . radarBlips .~ [])
|
||||
(cWorld . lWorld . radarBlips .~ [])
|
||||
-- . updateIMl _props _pjUpdate
|
||||
. updateLightSources
|
||||
. updateClouds
|
||||
@@ -125,7 +123,7 @@ scrollTimeBack w = case w ^? cwTime . pastWorlds . _head of
|
||||
& timeFlow . futureWorlds .:~ _cWorld w
|
||||
& timeFlow . reverseAmount -~ 1
|
||||
& cWorld .~ cw
|
||||
& pointerToItemLocation (w ^?! cWorld . itemLocations . ix i) . itUse . leftConsumption . wpCharge .~ (x -1)
|
||||
& pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix i) . itUse . leftConsumption . wpCharge .~ (x -1)
|
||||
_ -> w
|
||||
where
|
||||
i = w ^?! timeFlow . scrollItemLocation
|
||||
@@ -138,7 +136,7 @@ scrollTimeForward w = case w ^? timeFlow . futureWorlds . _head of
|
||||
& cwTime . pastWorlds .:~ _cWorld w
|
||||
& cWorld .~ cw
|
||||
& timeFlow . reverseAmount .~ ramount
|
||||
& pointerToItemLocation (w ^?! cWorld . itemLocations . ix i) . itUse . leftConsumption . wpCharge .~ ramount
|
||||
& pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix i) . itUse . leftConsumption . wpCharge .~ ramount
|
||||
where
|
||||
i = w ^?! timeFlow . scrollItemLocation
|
||||
ramount = (w ^?! timeFlow . reverseAmount) + 1
|
||||
@@ -162,10 +160,10 @@ functionalUpdate w =
|
||||
. colCrsWalls
|
||||
. over uvWorld simpleCrSprings
|
||||
. over uvWorld zoneCreatures
|
||||
. over uvWorld (updateIMl (_doors . _cWorld) (doDrWdWd . _drMech))
|
||||
. over uvWorld (updateIMl (_doors . _lWorld . _cWorld) (doDrWdWd . _drMech))
|
||||
. over uvWorld doWorldEvents
|
||||
. over uvWorld updateDelayedEvents
|
||||
. over uvWorld (updateIMl (_modifications . _cWorld) (doModificationEffect . _mdUpdate))
|
||||
. over uvWorld (updateIMl (_modifications . _lWorld . _cWorld) (doModificationEffect . _mdUpdate))
|
||||
. over uvWorld updateSparks
|
||||
. over uvWorld updateRadarSweeps
|
||||
. over uvWorld updatePosEvents
|
||||
@@ -180,20 +178,20 @@ functionalUpdate w =
|
||||
. over uvWorld updateLasers
|
||||
. over uvWorld updateTeslaArcs
|
||||
. over uvWorld updateTractorBeams
|
||||
. over uvWorld (updateIMl' (_linearShockwaves . _cWorld) updateLinearShockwave)
|
||||
. over uvWorld (updateIMl' (_props . _cWorld) updateProp)
|
||||
. over uvWorld (updateIMl' (_projectiles . _cWorld) updateProjectile)
|
||||
. over uvWorld (updateIMl' (_linearShockwaves . _lWorld . _cWorld) updateLinearShockwave)
|
||||
. over uvWorld (updateIMl' (_props . _lWorld . _cWorld) updateProp)
|
||||
. over uvWorld (updateIMl' (_projectiles . _lWorld . _cWorld) updateProjectile)
|
||||
. over uvWorld updateLightSources
|
||||
. over uvWorld updateClouds
|
||||
. over uvWorld updateGusts
|
||||
. over uvWorld zoneClouds
|
||||
. over uvWorld (updateMIM (cWorld . magnets) (doMagnetUpdate . _mgUpdate))
|
||||
. over uvWorld (updateIMl' (_terminals . _cWorld) tmUpdate)
|
||||
. over uvWorld (updateMIM (cWorld . lWorld . magnets) (doMagnetUpdate . _mgUpdate))
|
||||
. over uvWorld (updateIMl' (_terminals . _lWorld . _cWorld) tmUpdate)
|
||||
-- . updateIMl _machines mcChooseUpdate
|
||||
. over uvWorld (updateIMl' (_machines . _cWorld) updateMachine)
|
||||
. over uvWorld (updateIMl' (_creatures . _cWorld) updateCreature)
|
||||
. over uvWorld (updateIMl' (_machines . _lWorld . _cWorld) updateMachine)
|
||||
. over uvWorld (updateIMl' (_creatures . _lWorld . _cWorld) updateCreature)
|
||||
-- creatures should be updated early so that crOldPos is set before any position change
|
||||
. over (uvWorld . cWorld . creatures) (fmap setOldPos)
|
||||
. over (uvWorld . cWorld . lWorld . creatures) (fmap setOldPos)
|
||||
. over uvWorld updateCreatureGroups
|
||||
. over uvWorld updateWallDamages
|
||||
. over uvWorld updateSeenWalls
|
||||
@@ -231,24 +229,23 @@ moveHammersUp = uvWorld . hammers %~ M.map moveHammerUp
|
||||
-- w' = w {_hammers = fmap moveHammerUp (_hammers w)}
|
||||
|
||||
doWorldEvents :: World -> World
|
||||
doWorldEvents w = foldl' (flip doWdWd) (w & cWorld . worldEvents .~ []) (_worldEvents (_cWorld w))
|
||||
doWorldEvents w = foldl' (flip doWdWd) (w & cWorld . lWorld . worldEvents .~ []) (w ^. cWorld . lWorld . worldEvents)
|
||||
|
||||
updateLasers :: World -> World
|
||||
updateLasers w =
|
||||
w'
|
||||
& cWorld . lasers .~ []
|
||||
& cWorld . lasersToDraw .~ ls
|
||||
& cWorld . lWorld . lasers .~ []
|
||||
& cWorld . lWorld . lasersToDraw .~ ls
|
||||
where
|
||||
(w', ls) = mapAccumR updateLaser w (_lasers (_cWorld w))
|
||||
(w', ls) = mapAccumR updateLaser w (w ^. cWorld . lWorld . lasers)
|
||||
|
||||
zoneClouds :: World -> World
|
||||
zoneClouds w =
|
||||
w
|
||||
& cWorld . clZoning .~ mempty
|
||||
& cWorld . clZoning %~ \zn ->
|
||||
foldl' (flip zoneCloud) zn (_clouds (_cWorld w))
|
||||
& cWorld . lWorld . clZoning .~ mempty
|
||||
& cWorld . lWorld . clZoning %~ \zn ->
|
||||
foldl' (flip zoneCloud) zn (w ^. cWorld . lWorld . clouds)
|
||||
|
||||
--runIdentity (S.fold_ (flip $ updateZoning (:)) (zn & znObjects .~ mempty) id (_clouds w))
|
||||
|
||||
updateWorldSelect :: World -> World
|
||||
updateWorldSelect w = f . g $ case (w ^? mouseButtons . ix ButtonLeft, w ^? mouseButtons . ix ButtonRight) of
|
||||
@@ -284,7 +281,7 @@ displayTerminalLineString tls = case tls of
|
||||
TerminalLineConst str col -> const (str, col)
|
||||
|
||||
tmUpdate :: Terminal -> World -> World
|
||||
tmUpdate tm w = case w ^? cWorld . terminals . ix (_tmID tm) . tmFutureLines . ix 0 of
|
||||
tmUpdate tm w = case w ^? cWorld . lWorld . 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) ->
|
||||
@@ -301,7 +298,7 @@ tmUpdate tm w = case w ^? cWorld . terminals . ix (_tmID tm) . tmFutureLines . i
|
||||
& pointTermParams . tmFutureLines %~ tail
|
||||
& pointTermParams %~ doTmTm eff
|
||||
where
|
||||
pointTermParams = cWorld . terminals . ix (_tmID tm)
|
||||
pointTermParams = cWorld . lWorld . terminals . ix (_tmID tm)
|
||||
|
||||
setOldPos :: Creature -> Creature
|
||||
setOldPos cr =
|
||||
@@ -323,8 +320,8 @@ setOldPos cr =
|
||||
zoneCreatures :: World -> World
|
||||
zoneCreatures w =
|
||||
w
|
||||
& cWorld . crZoning .~ mempty
|
||||
& cWorld . crZoning %~ \zn -> foldl' (flip zoneCreature) zn (_creatures (_cWorld w))
|
||||
& cWorld . lWorld . crZoning .~ mempty
|
||||
& cWorld . lWorld . crZoning %~ \zn -> foldl' (flip zoneCreature) zn (w ^. cWorld . lWorld . creatures)
|
||||
|
||||
-- foldl' (flip $ updateZoning (\cr -> IM.insert (_crID cr) cr))
|
||||
-- zn (_creatures w)
|
||||
@@ -336,7 +333,7 @@ updateCreatureSoundPositions w =
|
||||
$ _playingSounds w
|
||||
where
|
||||
insertSound w' k s = w' & toPlaySounds %~ M.insertWith (const id) k s
|
||||
updateSound (CrMouth cid) s = case w ^? cWorld . creatures . ix cid . crPos of
|
||||
updateSound (CrMouth cid) s = case w ^? cWorld . lWorld . 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
|
||||
@@ -351,68 +348,68 @@ updateIMl' fim fup w = foldl' (flip fup) w (fim w)
|
||||
|
||||
updateCreatureGroups :: World -> World
|
||||
updateCreatureGroups w =
|
||||
w & cWorld . creatureGroups
|
||||
w & cWorld . lWorld . creatureGroups
|
||||
%~ IM.mapMaybe (\cgp -> doCrGroupUpdate (_crGroupUpdate cgp) w cgp)
|
||||
|
||||
updateDistortions :: World -> World
|
||||
updateDistortions = cWorld . distortions %~ mapMaybe updateDistortion
|
||||
updateDistortions = cWorld . lWorld . distortions %~ mapMaybe updateDistortion
|
||||
|
||||
updateLightSources :: World -> World
|
||||
updateLightSources = cWorld . tempLightSources %~ f
|
||||
updateLightSources = cWorld . lWorld . tempLightSources %~ f
|
||||
where
|
||||
f = mapMaybe (\b -> updateTempLightSource (_tlsUpdate b) b)
|
||||
|
||||
updateRadarBlips :: World -> World
|
||||
updateRadarBlips = cWorld . radarBlips %~ mapMaybe updateRadarBlip
|
||||
updateRadarBlips = cWorld . lWorld . radarBlips %~ mapMaybe updateRadarBlip
|
||||
|
||||
updateFlares :: World -> World
|
||||
updateFlares = cWorld . flares %~ mapMaybe updateFlare
|
||||
updateFlares = cWorld . lWorld . flares %~ mapMaybe updateFlare
|
||||
|
||||
updateTeslaArcs :: World -> World
|
||||
updateTeslaArcs w = w' & cWorld . teslaArcs .~ catMaybes newtas
|
||||
updateTeslaArcs w = w' & cWorld . lWorld . teslaArcs .~ catMaybes newtas
|
||||
where
|
||||
(w', newtas) = mapAccumR moveTeslaArc w $ _teslaArcs (_cWorld w)
|
||||
(w', newtas) = mapAccumR moveTeslaArc w $ w ^. cWorld . lWorld . teslaArcs
|
||||
|
||||
updateTractorBeams :: World -> World
|
||||
updateTractorBeams w = w' & cWorld . tractorBeams .~ catMaybes newtas
|
||||
updateTractorBeams w = w' & cWorld . lWorld . tractorBeams .~ catMaybes newtas
|
||||
where
|
||||
(w', newtas) = mapAccumR updateTractorBeam w $ _tractorBeams (_cWorld w)
|
||||
(w', newtas) = mapAccumR updateTractorBeam w $ w ^. cWorld . lWorld . tractorBeams
|
||||
|
||||
{- Apply internal particle updates, delete 'Nothing's. -}
|
||||
updateBullets :: World -> World
|
||||
updateBullets w = updateInstantBullets $ set (cWorld . bullets) (catMaybes ps) w'
|
||||
updateBullets w = updateInstantBullets $ set (cWorld . lWorld . bullets) (catMaybes ps) w'
|
||||
where
|
||||
(w', ps) = mapAccumR updateBullet w $ _bullets (_cWorld w)
|
||||
(w', ps) = mapAccumR updateBullet w $ w ^. cWorld . lWorld . bullets
|
||||
|
||||
updateShockwaves :: World -> World
|
||||
updateShockwaves w = w' & cWorld . shockwaves .~ catMaybes newflames
|
||||
updateShockwaves w = w' & cWorld . lWorld . shockwaves .~ catMaybes newflames
|
||||
where
|
||||
(w', newflames) = mapAccumR updateShockwave w $ _shockwaves (_cWorld w)
|
||||
(w', newflames) = mapAccumR updateShockwave w $ w ^. cWorld . lWorld . shockwaves
|
||||
|
||||
updateFlames :: World -> World
|
||||
updateFlames w = w' & cWorld . flames .~ catMaybes newflames
|
||||
updateFlames w = w' & cWorld . lWorld . flames .~ catMaybes newflames
|
||||
where
|
||||
(w', newflames) = mapAccumR moveFlame w $ _flames (_cWorld w)
|
||||
(w', newflames) = mapAccumR moveFlame w $ w ^. cWorld . lWorld . flames
|
||||
|
||||
updateEnergyBalls :: World -> World
|
||||
updateEnergyBalls w = w' & cWorld . energyBalls .~ catMaybes newebs
|
||||
updateEnergyBalls w = w' & cWorld . lWorld . energyBalls .~ catMaybes newebs
|
||||
where
|
||||
(w', newebs) = mapAccumR moveEnergyBall w $ _energyBalls (_cWorld w)
|
||||
(w', newebs) = mapAccumR moveEnergyBall w $ w ^. cWorld . lWorld . energyBalls
|
||||
|
||||
updateRadarSweeps :: World -> World
|
||||
updateRadarSweeps w = w' & cWorld . radarSweeps .~ catMaybes newradarSweeps
|
||||
updateRadarSweeps w = w' & cWorld . lWorld . radarSweeps .~ catMaybes newradarSweeps
|
||||
where
|
||||
(w', newradarSweeps) = mapAccumR updateRadarSweep w $ _radarSweeps (_cWorld w)
|
||||
(w', newradarSweeps) = mapAccumR updateRadarSweep w $ w ^. cWorld . lWorld . radarSweeps
|
||||
|
||||
updateSparks :: World -> World
|
||||
updateSparks w = w' & cWorld . sparks .~ catMaybes newsparks
|
||||
updateSparks w = w' & cWorld . lWorld . sparks .~ catMaybes newsparks
|
||||
where
|
||||
(w', newsparks) = mapAccumR moveSpark w $ _sparks (_cWorld w)
|
||||
(w', newsparks) = mapAccumR moveSpark w $ w ^. cWorld . lWorld . sparks
|
||||
|
||||
updatePosEvents :: World -> World
|
||||
updatePosEvents w = w' & cWorld . posEvents .~ catMaybes newposEvents
|
||||
updatePosEvents w = w' & cWorld . lWorld . posEvents .~ catMaybes newposEvents
|
||||
where
|
||||
(w', newposEvents) = mapAccumR updatePosEvent w $ _posEvents (_cWorld w)
|
||||
(w', newposEvents) = mapAccumR updatePosEvent w $ w ^. cWorld . lWorld . posEvents
|
||||
|
||||
{- Apply internal particle updates, delete 'Nothing's. -}
|
||||
--updateParticles :: World -> World
|
||||
@@ -422,17 +419,17 @@ updatePosEvents w = w' & cWorld . posEvents .~ catMaybes newposEvents
|
||||
updateBeams :: World -> World
|
||||
updateBeams w =
|
||||
w
|
||||
& cWorld . newBeams .~ WorldBeams [] [] [] []
|
||||
& cWorld . beams .~ thebeams
|
||||
& cWorld . lWorld . newBeams .~ WorldBeams [] [] [] []
|
||||
& cWorld . lWorld . beams .~ thebeams
|
||||
& combineBeams thebeams
|
||||
where
|
||||
thebeams = _newBeams (_cWorld w)
|
||||
thebeams = w ^. cWorld . lWorld . newBeams
|
||||
|
||||
combineBeams :: WorldBeams -> World -> World
|
||||
combineBeams wbeams w =
|
||||
w''
|
||||
& cWorld . beams . positronBeams .~ pbeams
|
||||
& cWorld . beams . electronBeams .~ ebeams
|
||||
& cWorld . lWorld . beams . positronBeams .~ pbeams
|
||||
& cWorld . lWorld . beams . electronBeams .~ ebeams
|
||||
where
|
||||
(w', pbeams) = mapAccumR (combineBeamBeams (_electronBeams wbeams)) w $ _positronBeams wbeams
|
||||
(w'', ebeams) = mapAccumR (combineBeamBeams (_positronBeams wbeams)) w' $ _electronBeams wbeams
|
||||
@@ -494,11 +491,11 @@ intersectSegSegs' _ _ _ = Nothing
|
||||
-- (intersectSegSegss x y ass)
|
||||
--intersectSegsSegss _ _ = Nothing
|
||||
updateInstantBullets :: World -> World
|
||||
updateInstantBullets w = case _instantBullets (_cWorld w) of
|
||||
updateInstantBullets w = case w ^. cWorld . lWorld . instantBullets of
|
||||
[] -> w
|
||||
ps ->
|
||||
let (w', ps') = mapAccumR updateBullet (w & cWorld . instantBullets .~ []) ps
|
||||
in updateInstantBullets $ w' & cWorld . bullets .++~ catMaybes ps'
|
||||
let (w', ps') = mapAccumR updateBullet (w & cWorld . lWorld . instantBullets .~ []) ps
|
||||
in updateInstantBullets $ w' & cWorld . lWorld . bullets .++~ catMaybes ps'
|
||||
|
||||
--updateInstantParticles :: World -> World
|
||||
--updateInstantParticles w = case _instantParticles w of
|
||||
@@ -522,7 +519,7 @@ updateMIM f up = f %~ IM.mapMaybe (dbArg up)
|
||||
-- (_,g') = genWord8 g
|
||||
|
||||
ppEvents :: World -> World
|
||||
ppEvents w = IM.foldl' (flip $ \pp -> doPressPlateEvent (_ppEvent pp) pp) w $ _pressPlates (_cWorld w)
|
||||
ppEvents w = IM.foldl' (flip $ \pp -> doPressPlateEvent (_ppEvent pp) pp) w $ w ^. cWorld . lWorld . pressPlates
|
||||
|
||||
updateSeenWalls :: World -> World
|
||||
updateSeenWalls w = foldl' markWallSeen w (map (_wlID . snd) $ allVisibleWalls w)
|
||||
@@ -533,7 +530,7 @@ updateSeenWalls w = foldl' markWallSeen w (map (_wlID . snd) $ allVisibleWalls w
|
||||
-- mw wl = wl {_wlSeen = True}
|
||||
|
||||
markWallSeen :: World -> Int -> World
|
||||
markWallSeen !w !i = w & cWorld . walls .~ IM.adjust markSeen i (_walls (_cWorld w))
|
||||
markWallSeen !w !i = w & cWorld . lWorld . walls .~ IM.adjust markSeen i (w ^. cWorld . lWorld . walls)
|
||||
|
||||
markSeen :: Wall -> Wall
|
||||
{-# INLINE markSeen #-}
|
||||
@@ -552,7 +549,7 @@ checkEndGame uv = case w ^. cwTime . deathDelay of
|
||||
w = _uvWorld uv
|
||||
|
||||
updateGusts :: World -> World
|
||||
updateGusts w = w & cWorld . gusts %~ IM.mapMaybe (mvGust w)
|
||||
updateGusts w = w & cWorld . lWorld . gusts %~ IM.mapMaybe (mvGust w)
|
||||
|
||||
mvGust :: World -> Gust -> Maybe Gust
|
||||
mvGust _ gu
|
||||
@@ -564,10 +561,10 @@ mvGust _ gu
|
||||
& guTime -~ 1
|
||||
|
||||
updateClouds :: World -> World
|
||||
updateClouds w = w' & cWorld . clouds .~ catMaybes mclouds
|
||||
updateClouds w = w' & cWorld . lWorld . clouds .~ catMaybes mclouds
|
||||
where
|
||||
-- cls = _clouds w
|
||||
(w', mclouds) = mapAccumR updateCloud w (_clouds (_cWorld w))
|
||||
(w', mclouds) = mapAccumR updateCloud w (w ^. cWorld . lWorld . clouds)
|
||||
|
||||
cloudEffect :: Cloud -> World -> World
|
||||
cloudEffect cl = case _clType cl of
|
||||
@@ -609,7 +606,7 @@ clClSpringVel a v b
|
||||
radDist = (_clRad a + _clRad b) / 2
|
||||
|
||||
simpleCrSprings :: World -> World
|
||||
simpleCrSprings w = IM.foldl' (flip crSpring) w $ _creatures (_cWorld w)
|
||||
simpleCrSprings w = IM.foldl' (flip crSpring) w $ w ^. cWorld . lWorld . creatures
|
||||
|
||||
-- note that this may in rare cases not push creatures away from each other
|
||||
crSpring :: Creature -> World -> World
|
||||
@@ -623,7 +620,7 @@ crCrSpring c1 c2
|
||||
| vec == V2 0 0 = id
|
||||
| diff >= comRad = id
|
||||
| otherwise =
|
||||
cWorld . creatures
|
||||
cWorld . lWorld . creatures
|
||||
%~ ( over (ix id1 . crPos) (+.+ overlap1)
|
||||
. over (ix id2 . crPos) (-.- overlap2)
|
||||
)
|
||||
@@ -639,9 +636,9 @@ crCrSpring c1 c2
|
||||
|
||||
updateDelayedEvents :: World -> World
|
||||
updateDelayedEvents w =
|
||||
let (neww, newde) = mapAccumR f w (_delayedEvents (_cWorld w))
|
||||
in neww & cWorld . delayedEvents .~ catMaybes newde
|
||||
let (neww, newde) = mapAccumR f w (w ^. cWorld . lWorld . delayedEvents)
|
||||
in neww & cWorld . lWorld . delayedEvents .~ catMaybes newde
|
||||
where
|
||||
f w' (i, g)
|
||||
| i <= 0 = (w' & cWorld . worldEvents .:~ g, Nothing)
|
||||
| i <= 0 = (w' & cWorld . lWorld . worldEvents .:~ g, Nothing)
|
||||
| otherwise = (w', Just (i -1, g))
|
||||
|
||||
Reference in New Issue
Block a user