Separate out concrete part of world
This commit is contained in:
+81
-82
@@ -67,7 +67,7 @@ updateUniverse u = case _menuLayers u of
|
||||
| otherwise -> u & menuLayers %~ ( (WaitScreen s (i-1) :) . tail )
|
||||
(OptionScreen {_scOptionFlag = GameOverOptions} : _) -> u & uvWorld %~
|
||||
( --updateParticles
|
||||
(radarBlips .~ [])
|
||||
(cWorld . radarBlips .~ [])
|
||||
-- . updateIMl _props _pjUpdate
|
||||
. updateLightSources
|
||||
. updateClouds )
|
||||
@@ -78,11 +78,11 @@ updateUniverse u = case _menuLayers u of
|
||||
functionalUpdate :: Universe -> Universe
|
||||
functionalUpdate w = checkEndGame
|
||||
-- . updateRandGen
|
||||
. over uvWorld (mouseButtons . each .~ True) -- to determine if the mouse button is held
|
||||
. over uvWorld (worldClock +~ 1)
|
||||
. over uvWorld (cWorld . mouseButtons . each .~ True) -- to determine if the mouse button is held
|
||||
. over uvWorld (cWorld . worldClock +~ 1)
|
||||
. over uvWorld updateWorldSelect
|
||||
. over uvWorld doRewind
|
||||
. over uvWorld (hammers . each %~ moveHammerUp)
|
||||
. over uvWorld (cWorld . hammers . each %~ moveHammerUp)
|
||||
. over uvWorld updateDistortions
|
||||
. over uvWorld updateCreatureSoundPositions
|
||||
. over uvWorld ppEvents
|
||||
@@ -90,10 +90,10 @@ functionalUpdate w = checkEndGame
|
||||
. colCrsWalls
|
||||
. over uvWorld simpleCrSprings
|
||||
. over uvWorld zoneCreatures
|
||||
. over uvWorld (updateIMl _doors (doDrWdWd . _drMech) )
|
||||
. over uvWorld (updateIMl (_doors . _cWorld) (doDrWdWd . _drMech) )
|
||||
. over uvWorld doWorldEvents
|
||||
. over uvWorld updateDelayedEvents
|
||||
. over uvWorld (updateIMl _modifications (doModificationEffect . _mdUpdate) )
|
||||
. over uvWorld (updateIMl (_modifications. _cWorld) (doModificationEffect . _mdUpdate) )
|
||||
. over uvWorld updateSparks
|
||||
. over uvWorld updateRadarSweeps
|
||||
. over uvWorld updatePosEvents
|
||||
@@ -108,20 +108,20 @@ functionalUpdate w = checkEndGame
|
||||
. over uvWorld updateLasers
|
||||
. over uvWorld updateTeslaArcs
|
||||
. over uvWorld updateTractorBeams
|
||||
. over uvWorld (updateIMl' _linearShockwaves updateLinearShockwave)
|
||||
. over uvWorld (updateIMl' _props updateProp )
|
||||
. over uvWorld (updateIMl' _projectiles updateProjectile)
|
||||
. over uvWorld (updateIMl' (_linearShockwaves . _cWorld) updateLinearShockwave)
|
||||
. over uvWorld (updateIMl' (_props . _cWorld) updateProp )
|
||||
. over uvWorld (updateIMl' (_projectiles . _cWorld) updateProjectile)
|
||||
. over uvWorld updateLightSources
|
||||
. over uvWorld updateClouds
|
||||
. over uvWorld updateGusts
|
||||
. over uvWorld zoneClouds
|
||||
. over uvWorld (updateMIM magnets (doMagnetUpdate . _mgUpdate) )
|
||||
. over uvWorld (updateIMl' _terminals tmUpdate )
|
||||
. over uvWorld (updateMIM (cWorld . magnets) (doMagnetUpdate . _mgUpdate) )
|
||||
. over uvWorld (updateIMl' (_terminals . _cWorld) tmUpdate )
|
||||
-- . updateIMl _machines mcChooseUpdate
|
||||
. over uvWorld (updateIMl' _machines updateMachine )
|
||||
. over uvWorld (updateIMl' _creatures updateCreature )
|
||||
. over uvWorld (updateIMl' (_machines . _cWorld) updateMachine )
|
||||
. over uvWorld (updateIMl' (_creatures . _cWorld) updateCreature )
|
||||
-- creatures should be updated early so that crOldPos is set before any position change
|
||||
. over (uvWorld . creatures) (fmap setOldPos)
|
||||
. over (uvWorld . cWorld . creatures) (fmap setOldPos)
|
||||
. over uvWorld updateCreatureGroups
|
||||
. over uvWorld updateWallDamages
|
||||
. over uvWorld updateSeenWalls
|
||||
@@ -131,35 +131,35 @@ functionalUpdate w = checkEndGame
|
||||
$ over uvWorld updateCloseObjects w
|
||||
|
||||
doWorldEvents :: World -> World
|
||||
doWorldEvents w = foldr doWorldEffect (w & worldEvents .~ []) (_worldEvents w)
|
||||
doWorldEvents w = foldr doWorldEffect (w & cWorld . worldEvents .~ []) (_worldEvents (_cWorld w))
|
||||
|
||||
updateLasers :: World -> World
|
||||
updateLasers w = w'
|
||||
& lasers .~ []
|
||||
& lasersToDraw .~ ls
|
||||
& cWorld . lasers .~ []
|
||||
& cWorld . lasersToDraw .~ ls
|
||||
where
|
||||
(w',ls) = mapAccumR updateLaser w (_lasers w)
|
||||
(w',ls) = mapAccumR updateLaser w (_lasers (_cWorld w))
|
||||
|
||||
zoneClouds :: World -> World
|
||||
zoneClouds w = w
|
||||
& clZoning .~ mempty
|
||||
& clZoning %~ \zn ->
|
||||
foldl' (flip zoneCloud) zn (_clouds w)
|
||||
& cWorld . clZoning .~ mempty
|
||||
& cWorld . clZoning %~ \zn ->
|
||||
foldl' (flip zoneCloud) zn (_clouds (_cWorld w))
|
||||
--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
|
||||
updateWorldSelect w = f . g $ case (w ^? cWorld . mouseButtons . ix ButtonLeft, w ^? cWorld . mouseButtons . ix ButtonRight) of
|
||||
(Nothing ,Nothing) -> w
|
||||
(Just False,Nothing) -> w & lLine . _1 .~ mwp
|
||||
(Just True ,Nothing) -> w & lLine . _2 .~ mwp
|
||||
(Just False,Nothing) -> w & cWorld . lLine . _1 .~ mwp
|
||||
(Just True ,Nothing) -> w & cWorld . lLine . _2 .~ mwp
|
||||
(Nothing ,_) -> w
|
||||
(Just False,_) -> w & rLine . _1 .~ mwp
|
||||
(Just True ,_) -> w & rLine . _2 .~ mwp
|
||||
(Just False,_) -> w & cWorld . rLine . _1 .~ mwp
|
||||
(Just True ,_) -> w & cWorld . rLine . _2 .~ mwp
|
||||
where
|
||||
mwp = mouseWorldPos w
|
||||
f | ButtonLeft `M.member` _mouseButtons w = lSelect .~ mwp
|
||||
f | ButtonLeft `M.member` _mouseButtons (_cWorld w) = cWorld . lSelect .~ mwp
|
||||
| otherwise = id
|
||||
g | ButtonRight `M.member` _mouseButtons w = rSelect .~ mwp
|
||||
g | ButtonRight `M.member` _mouseButtons (_cWorld w) = cWorld . rSelect .~ mwp
|
||||
| otherwise = id
|
||||
|
||||
--mcChooseUpdate :: Machine -> Machine -> World -> World
|
||||
@@ -172,7 +172,7 @@ displayTerminalLineString tls = case tls of
|
||||
TerminalLineConst str col -> const (str,col)
|
||||
|
||||
tmUpdate :: Terminal -> World -> World
|
||||
tmUpdate tm w = case w ^? terminals . ix (_tmID tm) . tmFutureLines . ix 0 of
|
||||
tmUpdate tm w = case w ^? cWorld . 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 %~
|
||||
@@ -186,7 +186,7 @@ tmUpdate tm w = case w ^? terminals . ix (_tmID tm) . tmFutureLines . ix 0 of
|
||||
& pointTermParams . tmFutureLines %~ tail
|
||||
& pointTermParams %~ doTmTm eff
|
||||
where
|
||||
pointTermParams = terminals . ix (_tmID tm)
|
||||
pointTermParams = cWorld . terminals . ix (_tmID tm)
|
||||
|
||||
setOldPos :: Creature -> Creature
|
||||
setOldPos cr = cr
|
||||
@@ -198,14 +198,14 @@ setOldPos cr = cr
|
||||
--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
|
||||
doRewind w = case _maybeWorld (_cWorld w) of
|
||||
Just' w' -> w' & cWorld . timeFlow .~ RewindingLastFrame
|
||||
Nothing' -> w & cWorld . timeFlow .~ NormalTimeFlow
|
||||
|
||||
zoneCreatures :: World -> World
|
||||
zoneCreatures w = w
|
||||
& crZoning .~ mempty
|
||||
& crZoning %~ \zn -> foldl' (flip zoneCreature) zn (_creatures w)
|
||||
& cWorld . crZoning .~ mempty
|
||||
& cWorld . crZoning %~ \zn -> foldl' (flip zoneCreature) zn (_creatures (_cWorld w))
|
||||
-- foldl' (flip $ updateZoning (\cr -> IM.insert (_crID cr) cr))
|
||||
-- zn (_creatures w)
|
||||
|
||||
@@ -215,7 +215,7 @@ updateCreatureSoundPositions w = M.foldlWithKey' insertSound w
|
||||
$ _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
|
||||
updateSound (CrMouth cid) s = case w ^? cWorld . 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
|
||||
@@ -229,67 +229,67 @@ updateIMl' :: (World -> IM.IntMap a) -> (a -> World -> World) -> World -> World
|
||||
updateIMl' fim fup w = foldl' (flip fup) w (fim w)
|
||||
|
||||
updateCreatureGroups :: World -> World
|
||||
updateCreatureGroups w = w & creatureGroups %~
|
||||
updateCreatureGroups w = w & cWorld . creatureGroups %~
|
||||
IM.mapMaybe (\cgp -> doCrGroupUpdate (_crGroupUpdate cgp) w cgp)
|
||||
|
||||
updateDistortions :: World -> World
|
||||
updateDistortions = distortions %~ mapMaybe updateDistortion
|
||||
updateDistortions = cWorld . distortions %~ mapMaybe updateDistortion
|
||||
|
||||
updateLightSources :: World -> World
|
||||
updateLightSources = tempLightSources %~ f
|
||||
updateLightSources = cWorld . tempLightSources %~ f
|
||||
where
|
||||
f = mapMaybe (\b -> updateTempLightSource (_tlsUpdate b) b)
|
||||
|
||||
updateRadarBlips :: World -> World
|
||||
updateRadarBlips = radarBlips %~ mapMaybe updateRadarBlip
|
||||
updateRadarBlips = cWorld . radarBlips %~ mapMaybe updateRadarBlip
|
||||
|
||||
updateFlares :: World -> World
|
||||
updateFlares = flares %~ mapMaybe updateFlare
|
||||
updateFlares = cWorld . flares %~ mapMaybe updateFlare
|
||||
|
||||
updateTeslaArcs :: World -> World
|
||||
updateTeslaArcs w = w' & teslaArcs .~ catMaybes newtas
|
||||
updateTeslaArcs w = w' & cWorld . teslaArcs .~ catMaybes newtas
|
||||
where
|
||||
(w',newtas) = mapAccumR moveTeslaArc w $ _teslaArcs w
|
||||
(w',newtas) = mapAccumR moveTeslaArc w $ _teslaArcs (_cWorld w)
|
||||
|
||||
updateTractorBeams :: World -> World
|
||||
updateTractorBeams w = w' & tractorBeams .~ catMaybes newtas
|
||||
updateTractorBeams w = w' & cWorld . tractorBeams .~ catMaybes newtas
|
||||
where
|
||||
(w',newtas) = mapAccumR updateTractorBeam w $ _tractorBeams w
|
||||
(w',newtas) = mapAccumR updateTractorBeam w $ _tractorBeams (_cWorld w)
|
||||
|
||||
|
||||
{- Apply internal particle updates, delete 'Nothing's. -}
|
||||
updateBullets :: World -> World
|
||||
updateBullets w = updateInstantBullets $ set bullets (catMaybes ps) w'
|
||||
updateBullets w = updateInstantBullets $ set (cWorld . bullets) (catMaybes ps) w'
|
||||
where
|
||||
(w',ps) = mapAccumR updateBullet w $ _bullets w
|
||||
(w',ps) = mapAccumR updateBullet w $ _bullets (_cWorld w)
|
||||
|
||||
updateShockwaves :: World -> World
|
||||
updateShockwaves w = w' & shockwaves .~ catMaybes newflames
|
||||
updateShockwaves w = w' & cWorld . shockwaves .~ catMaybes newflames
|
||||
where
|
||||
(w',newflames) = mapAccumR updateShockwave w $ _shockwaves w
|
||||
(w',newflames) = mapAccumR updateShockwave w $ _shockwaves (_cWorld w)
|
||||
|
||||
updateFlames :: World -> World
|
||||
updateFlames w = w' & flames .~ catMaybes newflames
|
||||
updateFlames w = w' & cWorld . flames .~ catMaybes newflames
|
||||
where
|
||||
(w',newflames) = mapAccumR moveFlame w $ _flames w
|
||||
(w',newflames) = mapAccumR moveFlame w $ _flames (_cWorld w)
|
||||
|
||||
updateEnergyBalls :: World -> World
|
||||
updateEnergyBalls w = w' & energyBalls .~ catMaybes newebs
|
||||
updateEnergyBalls w = w' & cWorld . energyBalls .~ catMaybes newebs
|
||||
where
|
||||
(w',newebs) = mapAccumR moveEnergyBall w $ _energyBalls w
|
||||
(w',newebs) = mapAccumR moveEnergyBall w $ _energyBalls (_cWorld w)
|
||||
updateRadarSweeps :: World -> World
|
||||
updateRadarSweeps w = w' & radarSweeps .~ catMaybes newradarSweeps
|
||||
updateRadarSweeps w = w' & cWorld . radarSweeps .~ catMaybes newradarSweeps
|
||||
where
|
||||
(w',newradarSweeps) = mapAccumR updateRadarSweep w $ _radarSweeps w
|
||||
(w',newradarSweeps) = mapAccumR updateRadarSweep w $ _radarSweeps (_cWorld w)
|
||||
|
||||
updateSparks :: World -> World
|
||||
updateSparks w = w' & sparks .~ catMaybes newsparks
|
||||
updateSparks w = w' & cWorld . sparks .~ catMaybes newsparks
|
||||
where
|
||||
(w',newsparks) = mapAccumR moveSpark w $ _sparks w
|
||||
(w',newsparks) = mapAccumR moveSpark w $ _sparks (_cWorld w)
|
||||
updatePosEvents :: World -> World
|
||||
updatePosEvents w = w' & posEvents .~ catMaybes newposEvents
|
||||
updatePosEvents w = w' & cWorld . posEvents .~ catMaybes newposEvents
|
||||
where
|
||||
(w',newposEvents) = mapAccumR updatePosEvent w $ _posEvents w
|
||||
(w',newposEvents) = mapAccumR updatePosEvent w $ _posEvents (_cWorld w)
|
||||
|
||||
|
||||
{- Apply internal particle updates, delete 'Nothing's. -}
|
||||
@@ -299,16 +299,16 @@ updatePosEvents w = w' & posEvents .~ catMaybes newposEvents
|
||||
-- (w',ps) = mapAccumR (\a b -> _ptUpdate b a b) w $ _particles w
|
||||
updateBeams :: World -> World
|
||||
updateBeams w = w
|
||||
& newBeams .~ WorldBeams [] [] [] []
|
||||
& beams .~ thebeams
|
||||
& cWorld . newBeams .~ WorldBeams [] [] [] []
|
||||
& cWorld . beams .~ thebeams
|
||||
& combineBeams thebeams
|
||||
where
|
||||
thebeams = _newBeams w
|
||||
thebeams = _newBeams (_cWorld w)
|
||||
|
||||
combineBeams :: WorldBeams -> World -> World
|
||||
combineBeams wbeams w = w''
|
||||
& beams . positronBeams .~ pbeams
|
||||
& beams . electronBeams .~ ebeams
|
||||
& cWorld . beams . positronBeams .~ pbeams
|
||||
& cWorld . beams . electronBeams .~ ebeams
|
||||
where
|
||||
(w',pbeams) = mapAccumR (combineBeamBeams (_electronBeams wbeams)) w $ _positronBeams wbeams
|
||||
(w'',ebeams) = mapAccumR (combineBeamBeams (_positronBeams wbeams)) w' $ _electronBeams wbeams
|
||||
@@ -368,10 +368,10 @@ intersectSegSegs' _ _ _ = Nothing
|
||||
-- (intersectSegSegss x y ass)
|
||||
--intersectSegsSegss _ _ = Nothing
|
||||
updateInstantBullets :: World -> World
|
||||
updateInstantBullets w = case _instantBullets w of
|
||||
updateInstantBullets w = case _instantBullets (_cWorld w) of
|
||||
[] -> w
|
||||
ps -> let (w',ps') = mapAccumR updateBullet (w {_instantBullets=[]}) ps
|
||||
in updateInstantBullets $ w' & bullets .++~ catMaybes ps'
|
||||
ps -> let (w',ps') = mapAccumR updateBullet (w & cWorld . instantBullets.~[]) ps
|
||||
in updateInstantBullets $ w' & cWorld . bullets .++~ catMaybes ps'
|
||||
|
||||
--updateInstantParticles :: World -> World
|
||||
--updateInstantParticles w = case _instantParticles w of
|
||||
@@ -395,7 +395,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 w
|
||||
ppEvents w = IM.foldl' (flip $ \pp -> doPressPlateEvent (_ppEvent pp) pp) w $ _pressPlates (_cWorld w)
|
||||
|
||||
updateSeenWalls :: World -> World
|
||||
updateSeenWalls w = foldl' markWallSeen w (map (_wlID . snd) $ allVisibleWalls w)
|
||||
@@ -405,24 +405,23 @@ updateSeenWalls w = foldl' markWallSeen w (map (_wlID . snd) $ allVisibleWalls w
|
||||
-- mw wl = wl {_wlSeen = True}
|
||||
|
||||
markWallSeen :: World -> Int -> World
|
||||
markWallSeen !w !i = w { _walls = IM.adjust markSeen i $ _walls w }
|
||||
markWallSeen !w !i = w & cWorld . walls .~ IM.adjust markSeen i (_walls (_cWorld w))
|
||||
|
||||
markSeen :: Wall -> Wall
|
||||
markSeen wl = wl {_wlSeen = True}
|
||||
|
||||
checkEndGame :: Universe -> Universe
|
||||
checkEndGame uv = case _deathDelay w of
|
||||
checkEndGame uv = case _deathDelay (_cWorld w) of
|
||||
Just x | x < 0 -> uv & menuLayers .~ [gameOverMenu]
|
||||
& uvWorld . deathDelay .~ Nothing
|
||||
Just _ -> uv & uvWorld . deathDelay . _Just -~ 1
|
||||
_ | _crHP (you w) < 1 -> uv & uvWorld . deathDelay ?~ 50
|
||||
& uvWorld . cWorld . deathDelay .~ Nothing
|
||||
Just _ -> uv & uvWorld . cWorld . deathDelay . _Just -~ 1
|
||||
_ | _crHP (you w) < 1 -> uv & uvWorld . cWorld . deathDelay ?~ 50
|
||||
_ -> uv
|
||||
where
|
||||
w = _uvWorld uv
|
||||
|
||||
updateGusts :: World -> World
|
||||
updateGusts w = w
|
||||
& gusts %~ IM.mapMaybe (mvGust w)
|
||||
updateGusts w = w & cWorld . gusts %~ IM.mapMaybe (mvGust w)
|
||||
|
||||
mvGust :: World -> Gust -> Maybe Gust
|
||||
mvGust _ gu
|
||||
@@ -431,10 +430,10 @@ mvGust _ gu
|
||||
& guPos .+.+~ _guVel gu
|
||||
& guTime -~ 1
|
||||
updateClouds :: World -> World
|
||||
updateClouds w = w' & clouds .~ catMaybes mclouds
|
||||
updateClouds w = w' & cWorld . clouds .~ catMaybes mclouds
|
||||
where
|
||||
-- cls = _clouds w
|
||||
(w',mclouds) = mapAccumR updateCloud w (_clouds w)
|
||||
(w',mclouds) = mapAccumR updateCloud w (_clouds (_cWorld w))
|
||||
|
||||
cloudEffect :: Cloud -> World -> World
|
||||
cloudEffect cl = case _clType cl of
|
||||
@@ -473,7 +472,7 @@ clClSpringVel a v b
|
||||
radDist = (_clRad a + _clRad b) / 2
|
||||
|
||||
simpleCrSprings :: World -> World
|
||||
simpleCrSprings w = IM.foldl' (flip crSpring) w $ _creatures w
|
||||
simpleCrSprings w = IM.foldl' (flip crSpring) w $ _creatures (_cWorld w)
|
||||
|
||||
-- note that this may in rare cases not push creatures away from each other
|
||||
crSpring :: Creature -> World -> World
|
||||
@@ -486,7 +485,7 @@ crCrSpring c1 c2
|
||||
| id1 == id2 = id
|
||||
| vec == V2 0 0 = id
|
||||
| diff >= comRad = id
|
||||
| otherwise = creatures %~
|
||||
| otherwise = cWorld . creatures %~
|
||||
( over (ix id1 . crPos) (+.+ overlap1)
|
||||
. over (ix id2 . crPos) (-.- overlap2)
|
||||
)
|
||||
@@ -501,9 +500,9 @@ crCrSpring c1 c2
|
||||
massT = _crMass c1 + _crMass c2
|
||||
|
||||
updateDelayedEvents :: World -> World
|
||||
updateDelayedEvents w = let (neww,newde) = mapAccumR f w (_delayedEvents w)
|
||||
in neww & delayedEvents .~ catMaybes newde
|
||||
updateDelayedEvents w = let (neww,newde) = mapAccumR f w (_delayedEvents (_cWorld w))
|
||||
in neww & cWorld . delayedEvents .~ catMaybes newde
|
||||
where
|
||||
f w' (i,g)
|
||||
| i <= 0 = (w' & worldEvents .:~ g, Nothing)
|
||||
| i <= 0 = (w' & cWorld . worldEvents .:~ g, Nothing)
|
||||
| otherwise = (w', Just (i-1,g))
|
||||
|
||||
Reference in New Issue
Block a user