646 lines
23 KiB
Haskell
646 lines
23 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
|
|
{- |
|
|
Module : Dodge.Update
|
|
Description : Simulation update
|
|
-}
|
|
module Dodge.Update (updateUniverse) where
|
|
|
|
import Color
|
|
--import Dodge.Zone
|
|
|
|
import Dodge.Update.Scroll
|
|
import Control.Applicative
|
|
import Data.List
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe
|
|
import Dodge.Base
|
|
import Dodge.Beam
|
|
import Dodge.Bullet
|
|
import Dodge.CrGroupUpdate
|
|
import Dodge.Creature.Update
|
|
import Dodge.CullBox
|
|
import Dodge.Data.Universe
|
|
import Dodge.Distortion
|
|
import Dodge.DrWdWd
|
|
import Dodge.EnergyBall
|
|
import Dodge.Flame
|
|
import Dodge.Flare
|
|
import Dodge.Hammer
|
|
import Dodge.Inventory
|
|
import Dodge.Item.Location
|
|
import Dodge.Laser.Update
|
|
import Dodge.LightSource.Update
|
|
import Dodge.LinearShockwave.Update
|
|
import Dodge.Machine.Update
|
|
import Dodge.Magnet.Update
|
|
import Dodge.Menu
|
|
import Dodge.ModificationEffect
|
|
import Dodge.PosEvent
|
|
import Dodge.PressPlate
|
|
import Dodge.Projectile.Update
|
|
import Dodge.Prop.Update
|
|
import Dodge.RadarBlip
|
|
import Dodge.RadarSweep
|
|
import Dodge.Shockwave.Update
|
|
import Dodge.SoundLogic
|
|
import Dodge.Spark
|
|
import Dodge.Tesla.Arc
|
|
import Dodge.TmTm
|
|
import Dodge.TractorBeam.Update
|
|
import Dodge.Update.Camera
|
|
import Dodge.Update.Cloud
|
|
import Dodge.Update.WallDamage
|
|
import Dodge.WallCreatureCollisions
|
|
import Dodge.WorldEffect
|
|
import Dodge.Zoning.Cloud
|
|
import Dodge.Zoning.Creature
|
|
import Geometry
|
|
import qualified IntMapHelp as IM
|
|
import LensHelp
|
|
--import MaybeHelp
|
|
import SDL
|
|
import Sound.Data
|
|
import StrictHelp
|
|
|
|
updateUniverse :: Universe -> Universe
|
|
updateUniverse u = updateUniverseLast . updateUniverseMid
|
|
. over uvWorld (updateCamera cfig)
|
|
. over (uvWorld . cWorld . cClock) ( + 1)
|
|
$ updateBounds u -- where should this go? next to update camera?
|
|
where
|
|
cfig = u ^. uvConfig
|
|
|
|
updateUniverseLast :: Universe -> Universe
|
|
updateUniverseLast = over uvWorld (input . mouseButtons . each .~ True) -- to determine if the mouse button is held
|
|
|
|
{- For most menus the only way to change the world is using event handling. -}
|
|
updateUniverseMid :: Universe -> Universe
|
|
updateUniverseMid u
|
|
| concurrentblocking = u
|
|
| otherwise = case _uvScreenLayers u of
|
|
(OptionScreen{_scOptionFlag = GameOverOptions} : _) ->
|
|
u & uvWorld
|
|
%~ (
|
|
--updateParticles
|
|
(cWorld . lWorld . radarBlips .~ [])
|
|
-- . updateIMl _props _pjUpdate
|
|
. updateLightSources
|
|
. updateClouds
|
|
)
|
|
(_ : _) -> u
|
|
[] -> functionalUpdate'' u
|
|
where
|
|
concurrentblocking = case u ^. uvConcEffects of
|
|
BlockingConcEffect{} -> True
|
|
_ -> False
|
|
|
|
functionalUpdate'' :: Universe -> Universe
|
|
functionalUpdate'' = advanceScrollAmount . functionalUpdate'
|
|
|
|
functionalUpdate' :: Universe -> Universe
|
|
functionalUpdate' u = case u ^. uvWorld . cWorld . timeFlow of
|
|
NormalTimeFlow -> functionalUpdate u
|
|
ScrollTimeFlow smoothing _ _ _ -> over uvWorld (doTimeScroll smoothing) u
|
|
_ -> u
|
|
|
|
doTimeScroll :: Int -> World -> World
|
|
doTimeScroll smoothing w = case w ^? input . mouseButtons . ix ButtonLeft of
|
|
Just False -> w & cWorld . timeFlow .~ NormalTimeFlow
|
|
_ -> doTimeScroll' smoothing w
|
|
|
|
doTimeScroll' :: Int -> World -> World
|
|
doTimeScroll' smoothing w = case w ^. input . scrollAmount of
|
|
x | x > 1 -> w & scrollTimeBack & cWorld . timeFlow . scrollSmoothing .~ 20
|
|
x | x > 0 -> w & scrollTimeBack & cWorld . timeFlow . scrollSmoothing %~ max 0
|
|
x | x < (-1) -> w & scrollTimeForward & cWorld .timeFlow . scrollSmoothing .~ negate 20
|
|
x | x < 0 -> w & scrollTimeForward & cWorld .timeFlow . scrollSmoothing %~ min 0
|
|
_ | smoothing > 0 -> scrollTimeBack w & cWorld .timeFlow . scrollSmoothing -~ 1
|
|
_ | smoothing < 0 -> scrollTimeForward w & cWorld .timeFlow . scrollSmoothing +~ 1
|
|
_ -> w
|
|
|
|
scrollTimeBack :: World -> World
|
|
scrollTimeBack w = case w ^? cWorld . pastWorlds . _head of
|
|
Nothing -> w
|
|
Just lw -> case w ^?! cWorld .timeFlow . reverseAmount of
|
|
x | x > 0 ->
|
|
w & cWorld . pastWorlds %~ tail
|
|
& cWorld .timeFlow . futureWorlds .:~ (w ^. cWorld . lWorld)
|
|
& cWorld .timeFlow . reverseAmount -~ 1
|
|
& cWorld . lWorld .~ lw
|
|
& pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix i) . itUse . leftConsumption . wpCharge .~ (x -1)
|
|
_ -> w
|
|
where
|
|
i = w ^?! cWorld . timeFlow . scrollItemLocation
|
|
|
|
scrollTimeForward :: World -> World
|
|
scrollTimeForward w = case w ^? cWorld . timeFlow . futureWorlds . _head of
|
|
Nothing -> w
|
|
Just lw ->
|
|
w & cWorld . timeFlow . futureWorlds %~ tail
|
|
& cWorld . pastWorlds .:~ (w ^. cWorld . lWorld)
|
|
& cWorld . lWorld .~ lw
|
|
& cWorld . timeFlow . reverseAmount .~ ramount
|
|
& pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix i) . itUse . leftConsumption . wpCharge .~ ramount
|
|
where
|
|
i = w ^?! cWorld . timeFlow . scrollItemLocation
|
|
ramount = (w ^?! cWorld . timeFlow . reverseAmount) + 1
|
|
|
|
-- | The update step.
|
|
functionalUpdate :: Universe -> Universe
|
|
functionalUpdate w =
|
|
checkEndGame
|
|
-- . updateRandGen
|
|
. over uvWorld (cWorld . lWorld . lClock +~ 1)
|
|
. over uvWorld updateWorldSelect'
|
|
-- . over uvWorld doRewind
|
|
-- . over uvWorld (hammers . each %~ moveHammerUp)
|
|
-- . over (uvWorld . hammers . each) moveHammerUp
|
|
-- . over uvWorld (hammers %~ fmap moveHammerUp)
|
|
. moveHammersUp
|
|
. over uvWorld updateDistortions
|
|
. over uvWorld updateCreatureSoundPositions
|
|
. over uvWorld ppEvents
|
|
. colCrsWalls
|
|
. over uvWorld simpleCrSprings
|
|
. over uvWorld zoneCreatures
|
|
. over uvWorld (updateIMl (_doors . _lWorld . _cWorld) (doDrWdWd . _drMech))
|
|
. over uvWorld doWorldEvents
|
|
. over uvWorld updateDelayedEvents
|
|
. over uvWorld (updateIMl (_modifications . _lWorld . _cWorld) (doModificationEffect . _mdUpdate))
|
|
. over uvWorld updateSparks
|
|
. over uvWorld updateRadarSweeps
|
|
. over uvWorld updatePosEvents
|
|
. over uvWorld updateFlames
|
|
. over uvWorld updateShockwaves
|
|
. over uvWorld updateEnergyBalls
|
|
-- . over uvWorld updateParticles
|
|
. over uvWorld updateBullets
|
|
. over uvWorld updateRadarBlips
|
|
. over uvWorld updateFlares
|
|
. over uvWorld updateBeams
|
|
. over uvWorld updateLasers
|
|
. over uvWorld updateTeslaArcs
|
|
. over uvWorld updateTractorBeams
|
|
. 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 . lWorld . magnets) (doMagnetUpdate . _mgUpdate))
|
|
. over uvWorld (updateIMl' (_terminals . _lWorld . _cWorld) tmUpdate)
|
|
-- . updateIMl _machines mcChooseUpdate
|
|
. 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 . lWorld . creatures) (fmap setOldPos)
|
|
. over uvWorld updateCreatureGroups
|
|
. over uvWorld updateWallDamages
|
|
. over uvWorld updateSeenWalls
|
|
. over uvWorld updateTerminal
|
|
. over uvWorld updateRBList
|
|
. over uvWorld updateCloseObjects
|
|
. over uvWorld updateWheelEvents
|
|
$ over uvWorld updatePastWorlds w
|
|
|
|
updateWheelEvents :: World -> World
|
|
updateWheelEvents w = foldr ($) w (replicate (abs y) (updateWheelEvent (signum y)))
|
|
where
|
|
y = w ^. input . scrollAmount
|
|
|
|
|
|
advanceScrollAmount :: Universe -> Universe
|
|
advanceScrollAmount u =
|
|
u
|
|
& uvWorld . input . previousScrollAmount .~ _scrollAmount (_input $ _uvWorld u)
|
|
& uvWorld . input . scrollAmount .~ 0
|
|
|
|
updatePastWorlds :: World -> World
|
|
updatePastWorlds w = w & cWorld . pastWorlds %~ (forceFoldable . take 100 . ((w ^. cWorld . lWorld) :))
|
|
|
|
moveHammersUp :: Universe -> Universe
|
|
--moveHammersUp = uvWorld . hammers .~ M.empty
|
|
moveHammersUp = uvWorld . input . hammers %~ M.map moveHammerUp
|
|
|
|
--moveHammersUp = uvWorld . hammers . each %~ (moveHammerUp $!)
|
|
--moveHammersUp = uvWorld %~ ( (hammers . each %~ (moveHammerUp $!)) $!)
|
|
--moveHammersUp uv = uv { _uvWorld = w' }
|
|
-- where
|
|
-- w = _uvWorld uv
|
|
-- w' = w {_hammers = fmap moveHammerUp (_hammers w)}
|
|
|
|
doWorldEvents :: World -> World
|
|
doWorldEvents w = foldl' (flip doWdWd) (w & cWorld . lWorld . worldEvents .~ []) (w ^. cWorld . lWorld . worldEvents)
|
|
|
|
updateLasers :: World -> World
|
|
updateLasers w =
|
|
w'
|
|
& cWorld . lWorld . lasers .~ []
|
|
& cWorld . lWorld . lasersToDraw .~ ls
|
|
where
|
|
(w', ls) = mapAccumR updateLaser w (w ^. cWorld . lWorld . lasers)
|
|
|
|
zoneClouds :: World -> World
|
|
zoneClouds w =
|
|
w
|
|
& cWorld . lWorld . clZoning .~ mempty
|
|
& cWorld . lWorld . clZoning %~ \zn ->
|
|
foldl' (flip zoneCloud) zn (w ^. cWorld . lWorld . clouds)
|
|
|
|
updateWorldSelect' :: World -> World
|
|
updateWorldSelect' w = over input (updateWorldSelect (w ^. cWorld . camPos)) w
|
|
|
|
updateWorldSelect :: CamPos -> Input -> Input
|
|
updateWorldSelect cam inp = f . g $ case (inp ^? mouseButtons . ix ButtonLeft, inp ^? mouseButtons . ix ButtonRight) of
|
|
(Just False, Nothing) ->
|
|
inp & lLine . _1 .~ mwp
|
|
& lrLine . _1 .~ mwp
|
|
(Just True, Nothing) ->
|
|
inp & lLine . _2 .~ mwp
|
|
& lrLine . _1 .~ mwp
|
|
(Nothing, Just False) ->
|
|
inp & rLine . _1 .~ mwp
|
|
& lrLine . _2 .~ mwp
|
|
(Nothing, Just True) ->
|
|
inp & rLine . _2 .~ mwp
|
|
& lrLine . _2 .~ mwp
|
|
_ -> inp
|
|
where
|
|
mwp = mouseWorldPos inp cam
|
|
f
|
|
| ButtonLeft `M.member` _mouseButtons inp = lSelect .~ mwp
|
|
| otherwise = id
|
|
g
|
|
| ButtonRight `M.member` _mouseButtons inp = rSelect .~ mwp
|
|
| otherwise = id
|
|
|
|
--mcChooseUpdate :: Machine -> Machine -> World -> World
|
|
--mcChooseUpdate mc mc'
|
|
-- | _mcHP mc > 0 = _mcUpdate mc mc'
|
|
-- | otherwise = destroyMachine mc
|
|
|
|
displayTerminalLineString :: TerminalLineString -> World -> (String, Color)
|
|
displayTerminalLineString tls = case tls of
|
|
TerminalLineConst str col -> const (str, col)
|
|
|
|
tmUpdate :: Terminal -> World -> World
|
|
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) ->
|
|
w & pointTermParams
|
|
%~ ( (tmFutureLines %~ tail)
|
|
. (tmDisplayedLines .:~ displayTerminalLineString f w)
|
|
)
|
|
Just (TerminalLineEffect _ eff) ->
|
|
w
|
|
& pointTermParams . tmFutureLines %~ tail
|
|
& doTmWdWd eff tm
|
|
Just (TerminalLineTerminalEffect _ eff) ->
|
|
w
|
|
& pointTermParams . tmFutureLines %~ tail
|
|
& pointTermParams %~ doTmTm eff
|
|
where
|
|
pointTermParams = cWorld . lWorld . 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 w ^. cwTime . maybeWorld of
|
|
-- Just' cw ->
|
|
-- w & cWorld .~ cw
|
|
-- & timeFlow .~ RewindingLastFrame
|
|
-- Nothing' -> w & timeFlow .~ NormalTimeFlow
|
|
|
|
zoneCreatures :: World -> World
|
|
zoneCreatures w =
|
|
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)
|
|
|
|
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 ^? 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
|
|
|
|
--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)
|
|
|
|
|
|
updateCreatureGroups :: World -> World
|
|
updateCreatureGroups w =
|
|
w & cWorld . lWorld . creatureGroups
|
|
%~ IM.mapMaybe (\cgp -> doCrGroupUpdate (_crGroupUpdate cgp) w cgp)
|
|
|
|
updateObjMapMaybe
|
|
:: (([a] -> Identity [a]) -> LWorld -> Identity LWorld)
|
|
-> (a -> Maybe a)
|
|
-> World
|
|
-> World
|
|
updateObjMapMaybe p f = cWorld . lWorld . p %~ mapMaybe f
|
|
|
|
updateObjCatMaybes
|
|
:: ALens' LWorld [a]
|
|
-> (World -> a -> (World, Maybe a))
|
|
-> World
|
|
-> World
|
|
updateObjCatMaybes p f w = w' & cWorld . lWorld . p #~ catMaybes newxs
|
|
where
|
|
(w', newxs) = mapAccumR f w $ w ^# cWorld . lWorld . p
|
|
|
|
updateDistortions :: World -> World
|
|
updateDistortions = updateObjMapMaybe distortions updateDistortion
|
|
--updateDistortions = cWorld . lWorld . distortions %~ mapMaybe updateDistortion
|
|
|
|
updateLightSources :: World -> World
|
|
updateLightSources = updateObjMapMaybe tempLightSources (\b -> updateTempLightSource (_tlsUpdate b) b)
|
|
|
|
updateTeslaArcs :: World -> World
|
|
updateTeslaArcs = updateObjCatMaybes teslaArcs moveTeslaArc
|
|
|
|
updateRadarBlips :: World -> World
|
|
updateRadarBlips = updateObjMapMaybe radarBlips updateRadarBlip
|
|
|
|
updateFlares :: World -> World
|
|
updateFlares = updateObjMapMaybe flares updateFlare
|
|
|
|
updateTractorBeams :: World -> World
|
|
updateTractorBeams = updateObjCatMaybes tractorBeams updateTractorBeam
|
|
|
|
{- Apply internal particle updates, delete 'Nothing's. -}
|
|
updateBullets :: World -> World
|
|
updateBullets w = updateInstantBullets $ set (cWorld . lWorld . bullets) (catMaybes ps) w'
|
|
where
|
|
(w', ps) = mapAccumR updateBullet w $ w ^. cWorld . lWorld . bullets
|
|
|
|
updateShockwaves :: World -> World
|
|
updateShockwaves = updateObjCatMaybes shockwaves updateShockwave
|
|
|
|
updateFlames :: World -> World
|
|
updateFlames = updateObjCatMaybes flames moveFlame
|
|
|
|
updateEnergyBalls :: World -> World
|
|
updateEnergyBalls = updateObjCatMaybes energyBalls moveEnergyBall
|
|
|
|
updateRadarSweeps :: World -> World
|
|
updateRadarSweeps = updateObjCatMaybes radarSweeps updateRadarSweep
|
|
|
|
updateSparks :: World -> World
|
|
updateSparks = updateObjCatMaybes sparks moveSpark
|
|
|
|
updatePosEvents :: World -> World
|
|
updatePosEvents = updateObjCatMaybes posEvents updatePosEvent
|
|
|
|
{- 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
|
|
& cWorld . lWorld . newBeams .~ WorldBeams [] [] [] []
|
|
& cWorld . lWorld . beams .~ thebeams
|
|
& combineBeams thebeams
|
|
where
|
|
thebeams = w ^. cWorld . lWorld . newBeams
|
|
|
|
combineBeams :: WorldBeams -> World -> World
|
|
combineBeams wbeams w =
|
|
w''
|
|
& 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
|
|
|
|
combineBeamBeams :: [Beam] -> World -> Beam -> (World, Beam)
|
|
combineBeamBeams bms w bm = case intersectBeamBeams bm bms of
|
|
(ps, Nothing) -> (w, bm & bmFirstPoints .~ ps)
|
|
(ps, Just a) -> (doBeamCombine (_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
|
|
updateInstantBullets :: World -> World
|
|
updateInstantBullets w = case w ^. cWorld . lWorld . instantBullets of
|
|
[] -> w
|
|
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
|
|
-- [] -> 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 -> doPressPlateEvent (_ppEvent pp) pp) w $ w ^. cWorld . lWorld . pressPlates
|
|
|
|
updateSeenWalls :: World -> World
|
|
updateSeenWalls w = foldl' markWallSeen w (map (_wlID . snd) $ allVisibleWalls w)
|
|
|
|
-- where
|
|
-- f w' !i -- = w' & walls . ix i . wlSeen .~ True
|
|
-- = w' { _walls = IM.adjust mw i $ _walls w' }
|
|
-- mw wl = wl {_wlSeen = True}
|
|
|
|
markWallSeen :: World -> Int -> World
|
|
markWallSeen !w !i = w & cWorld . lWorld . walls .~ IM.adjust markSeen i (w ^. cWorld . lWorld . walls)
|
|
|
|
markSeen :: Wall -> Wall
|
|
{-# INLINE markSeen #-}
|
|
markSeen wl = wl{_wlSeen = True}
|
|
|
|
checkEndGame :: Universe -> Universe
|
|
checkEndGame uv = case w ^? cWorld . timeFlow . deathDelay of
|
|
Just x
|
|
| x < 0 ->
|
|
uv & uvScreenLayers .~ [gameOverMenu]
|
|
Just _ -> uv & uvWorld . cWorld . timeFlow . deathDelay -~ 1
|
|
_ | _crHP (you w) < 1 -> uv & uvWorld . cWorld . timeFlow .~ DeathTime 50
|
|
_ -> uv
|
|
where
|
|
w = _uvWorld uv
|
|
|
|
updateGusts :: World -> World
|
|
updateGusts w = w & cWorld . lWorld . 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 = updateObjCatMaybes clouds updateCloud
|
|
|
|
cloudEffect :: Cloud -> World -> World
|
|
cloudEffect cl = case _clType cl of
|
|
GasCloud -> cloudPoisonDamage cl
|
|
SmokeCloud -> id
|
|
|
|
updateCloud :: World -> Cloud -> (World, Maybe Cloud)
|
|
updateCloud w c
|
|
| _clTimer c < 1 = (w, Nothing)
|
|
| otherwise =
|
|
( cloudEffect 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) (clsNearPoint oldPos2 w)
|
|
oldPos@(V3 _ _ opz) = _clPos c
|
|
oldPos2 = stripZ oldPos
|
|
newPos@(V3 _ _ npz) = oldPos +.+.+ newVel
|
|
newPos2 = stripZ newPos
|
|
hitWl = bouncePoint (const True) 1 oldPos2 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
|
|
|
|
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 $ w ^. cWorld . lWorld . creatures
|
|
|
|
-- note that this may in rare cases not push creatures away from each other
|
|
crSpring :: Creature -> World -> World
|
|
crSpring c w = foldl' (flip $ crCrSpring c) w cs
|
|
where
|
|
cs = crsNearPoint (_crPos c) w
|
|
|
|
crCrSpring :: Creature -> Creature -> World -> World
|
|
crCrSpring c1 c2
|
|
| id1 == id2 = id
|
|
| vec == V2 0 0 = id
|
|
| diff >= comRad = id
|
|
| otherwise =
|
|
cWorld . lWorld . creatures
|
|
%~ ( over (ix id1 . crPos) (+.+ overlap1)
|
|
. over (ix id2 . crPos) (-.- overlap2)
|
|
)
|
|
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
|
|
|
|
updateDelayedEvents :: World -> World
|
|
updateDelayedEvents w =
|
|
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 . lWorld . worldEvents .:~ g, Nothing)
|
|
| otherwise = (w', Just (i -1, g))
|