--{-# LANGUAGE BangPatterns #-}

{- |
Module      : Dodge.Update
Description : Simulation update
-}
module Dodge.Update (updateUniverse) where

import Data.Monoid
import NewInt
import Control.Monad
import Dodge.Update.Input.InGame
import Dodge.Update.Input.ScreenLayer
import Dodge.Debug
import Dodge.SmoothScroll
import Color
--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.Data.SelectionList
import Dodge.Data.Universe
import Dodge.DisplayInventory
import Dodge.Distortion
import Dodge.DrWdWd
import Dodge.EnergyBall
import Dodge.Flame
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.Menu.Option
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.ScrollValue
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.Scroll
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 SDL
import Sound.Data
import StrictHelp

updateUniverse :: Universe -> Universe
updateUniverse u =
    updateUniverseLast
        . updateUniverseMid
        . debugEvents
        . over uvWorld (updateCamera cfig)
        . updateUniverseFirst
        $ u
  where
    cfig = u ^. uvConfig

updateUniverseFirst :: Universe -> Universe
updateUniverseFirst u =
    u
        & uvWorld . input . clickWorldPos %~ M.union (setClickWorldPos u)
        & uvWorld . input . smoothScrollAmount %~ calcSmoothScroll (u ^. uvWorld . input . scrollAmount)
        & over (uvWorld . input) updateScrollTestValue
        & updateDebugMessageOffset
        & over (uvWorld . cWorld . cClock) (+ 1)

updateDebugMessageOffset :: Universe -> Universe
updateDebugMessageOffset u
    | SDL.ScancodeRShift `M.member` (u ^. uvWorld . input . pressedKeys)
        = u & uvDebugMessageOffset %~ (max 0 . subtract (u ^. uvWorld . input . scrollAmount))
    | otherwise = u

setClickWorldPos :: Universe -> M.Map MouseButton Point2
setClickWorldPos u = fmap 
    (const (screenToWorldPos (u ^. uvWorld . wCam) (u ^. uvWorld . input . mousePos)))
    (M.filter (== 0) $ u ^. uvWorld . input . mouseButtons)

updateWorldEventFlags :: Universe -> Universe
updateWorldEventFlags u =
    (uvWorld . worldEventFlags .~ mempty)
        . updateInventoryPositioning
        $ foldr updateWorldEventFlag u (u ^. uvWorld . worldEventFlags)

updateWorldEventFlag :: WorldEventFlag -> Universe -> Universe
updateWorldEventFlag wef = case wef of
    InventoryChange -> id -- TODO determine more precisely when the inventory does change
    CombineInventoryChange -> updateCombinePositioning

maybeOpenTerminal :: Universe -> Universe
maybeOpenTerminal u = case u ^. uvWorld . input . pressedKeys . at ScancodeSemicolon of
    Just InitialPress -> gotoTerminal u
    _ -> u

gotoTerminal :: Universe -> Universe
gotoTerminal w = case _uvScreenLayers w of
    (InputScreen{} : _) -> w
    _ -> w & uvScreenLayers .:~ InputScreen mempty "Enter command"

updateUniverseLast :: Universe -> Universe
updateUniverseLast u =
    u
        & over (uvWorld . input . textInput) (const mempty)
        & maybeOpenTerminal
        & advanceScrollAmount
        & updateWorldEventFlags
        & uvWorld . input . pressedKeys . each %~ f
        & uvWorld . input . mouseMoving .~ False
        & uvWorld . input . mouseButtons . each +~ 1
        & uvWorld . input . heldPos %~ M.union (fmap (const mp) (u ^. uvWorld . input . mouseButtons))
        & uvWorld . input . heldWorldPos %~ M.union (fmap (const mwp) (u ^. uvWorld . input . mouseButtons))
  where
    mp = u ^. uvWorld . input . mousePos
    mwp = screenToWorldPos (u ^. uvWorld . wCam) mp
    f LongPress = LongPress
    f _ = ShortPress

{- For most menus the only way to change the world is using event handling.  -}
updateUniverseMid :: Universe -> Universe
updateUniverseMid u = case _uvScreenLayers u of
    (OptionScreen{_scOptionFlag = LoadingScreen} : _) -> u
    (sl@OptionScreen{_scOptionFlag = GameOverOptions} : _) ->
        u & updateUseInputOnScreen sl
            & uvWorld
            %~ (
                 --updateParticles
                 (cWorld . lWorld . radarBlips .~ [])
                    --        . updateIMl _props _pjUpdate
                    . updateLightSources
                    . updateClouds
               )
    (sl : _) -> u & updateUseInputOnScreen sl
    [] -> timeFlowUpdate $ updateUseInputInGame u

timeFlowUpdate :: Universe -> Universe
timeFlowUpdate u = case u ^. uvWorld . timeFlow of
    NormalTimeFlow -> functionalUpdate u
    ItemScrollTimeFlow smoothing _ _ _ -> over uvWorld (doItemTimeScroll smoothing) u
    CameraScrollTimeFlow smoothing _ _ 
        | SDL.ScancodeLShift `M.member` (u ^. uvWorld . input . pressedKeys) 
            -> over uvWorld (doTimeScroll smoothing) u
    CameraScrollTimeFlow {} -> u
    RewindLeftClick 0 _ -> u & uvWorld . timeFlow .~ NormalTimeFlow
    RewindLeftClick _ _ -> over uvWorld scrollTimeBack u -- & uvWorld . cWorld . timeFlow .~ NormalTimeFlow
    DeathTime{} -> u
    PausedTimeFlow _ itmloc -> over uvWorld (pauseTime itmloc) u

pauseTime :: NewInt ItmInt -> World -> World
pauseTime itmloc w
    | justPressedButtonLeft || outofcharge = w & timeFlow .~ NormalTimeFlow
    | otherwise = w & pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix (_unNInt itmloc)) . itUse . leftConsumption . wpCharge -~ 1
  where
    justPressedButtonLeft = w ^? input . mouseButtons . ix ButtonLeft == Just 0
    outofcharge = maybe True (== 0) charge
    charge = w ^? pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix (_unNInt itmloc)) . itUse . leftConsumption . wpCharge

doItemTimeScroll :: Int -> World -> World
doItemTimeScroll smoothing w = case w ^? input . mouseButtons . ix ButtonLeft of
    Just 0 -> w & timeFlow .~ NormalTimeFlow
    _ -> doTimeScroll smoothing w

doTimeScroll :: Int -> World -> World
doTimeScroll smoothing w = case w ^. input . scrollAmount of
    x | x > 1 -> w & scrollTimeBack & timeFlow . scrollSmoothing .~ 20
    x | x > 0 -> w & scrollTimeBack & timeFlow . scrollSmoothing %~ max 0
    x | x < (-1) -> w & scrollTimeForward & timeFlow . scrollSmoothing .~ negate 20
    x | x < 0 -> w & scrollTimeForward & timeFlow . scrollSmoothing %~ min 0
    _ | smoothing > 0 -> scrollTimeBack w & timeFlow . scrollSmoothing -~ 1
    _ | smoothing < 0 -> scrollTimeForward w & timeFlow . scrollSmoothing +~ 1
    _ -> w

scrollTimeBack :: World -> World
scrollTimeBack w = case w ^? pastWorlds . _head of
    Nothing -> w
    Just lw -> case w ^?! timeFlow . reverseAmount of
        x
            | x > 0 ->
                w & pastWorlds %~ tail
                    & timeFlow . futureWorlds .:~ (w ^. cWorld . lWorld)
                    & timeFlow . reverseAmount -~ 1
                    & cWorld . lWorld .~ lw
                    & mupdateitem x
        _ -> w
  where
    mupdateitem x = fromMaybe id $ do
        i <- w ^? timeFlow . scrollItemID . unNInt
        let pointituse = pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix i) . itUse
        return $ (pointituse . leftConsumption . wpCharge .~ (x -1))
                    . ( pointituse . leftHammer .~ HammerDown)

scrollTimeForward :: World -> World
scrollTimeForward w = case w ^? timeFlow . futureWorlds . _head of
    Nothing -> w
    Just lw ->
        w & timeFlow . futureWorlds %~ tail
            & pastWorlds .:~ (w ^. cWorld . lWorld)
            & cWorld . lWorld .~ lw
            & timeFlow . reverseAmount .~ ramount
            & mupdateitem   
  where
    ramount = (w ^?! timeFlow . reverseAmount) + 1
    mupdateitem = fromMaybe id $ do
        i <- w ^? timeFlow . scrollItemID . unNInt
        return $ pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix i) . itUse . leftConsumption . wpCharge .~ ramount

-- | The update step.
functionalUpdate :: Universe -> Universe
functionalUpdate w =
    checkEndGame
        . over uvWorld (cWorld . lWorld . lClock +~ 1)
        . over uvWorld updateDistortions
        . over uvWorld updateCreatureSoundPositions
        . over uvWorld ppEvents
        . colCrsWalls
        . over uvWorld simpleCrSprings
        . 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 updateBullets
        . over uvWorld updateRadarBlips
--        . 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 (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 checkTermDist
        . over uvWorld updateRBList
        . over uvWorld updateCloseObjects
        . over uvWorld updateWheelEvents
        . over uvWorld zoneClouds
        . over uvWorld zoneCreatures
        -- . over uvWorld updateInventorySelectionList
        . set (uvWorld . cWorld . lWorld . flares) []
        $ over uvWorld updatePastWorlds w

checkTermDist :: World -> World
checkTermDist w = fromMaybe w $ do
    tmid <- w ^? hud . hudElement . subInventory . termID
    btid <- w ^? cWorld . lWorld . terminals . ix tmid . tmButtonID
    btpos <- w ^? cWorld . lWorld . buttons . ix btid . btPos
    guard $ dist btpos (_crPos $ you w) > 40
    return (w & hud . hudElement . subInventory .~ NoSubInventory)


updateWheelEvents :: World -> World
updateWheelEvents w
    | yi == 0 = w
    | otherwise = updateWheelEvent yi w
  where
    yi = w ^. input . scrollAmount

advanceScrollAmount :: Universe -> Universe
advanceScrollAmount u =
    u
        & uvWorld . input . scrollAmount .~ 0
        & uvWorld . input . smoothScrollAmount %~ advanceSmoothScroll

updatePastWorlds :: World -> World
updatePastWorlds w = w & pastWorlds %~ (forceFoldable . take 100 . ((w ^. cWorld . lWorld) :))
--updatePastWorlds w = w & pastWorlds %~ (forceFoldable . take 600 . ((w ^. cWorld . lWorld) :))

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 & clZoning .~ foldl' (flip zoneCloud) mempty (w ^. cWorld . lWorld . clouds)

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 & crZoning
        .~ foldl' (flip zoneCreature) mempty (w ^. cWorld . lWorld . creatures)

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 = alaf Endo foldMap (dbArg fup) (fim w) w
--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 = alaf Endo foldMap fup (fim w) w
--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

updateLightSources :: World -> World
updateLightSources = updateObjMapMaybe tempLightSources (\b -> updateTempLightSource (_tlsUpdate b) b)

updateRadarBlips :: World -> World
updateRadarBlips = updateObjMapMaybe radarBlips updateRadarBlip

{- 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

updateTeslaArcs :: World -> World
updateTeslaArcs = updateObjCatMaybes teslaArcs updateTeslaArc

updateTractorBeams :: World -> World
updateTractorBeams = updateObjCatMaybes tractorBeams updateTractorBeam

updateShockwaves :: World -> World
updateShockwaves = updateObjCatMaybes shockwaves updateShockwave

updateFlames :: World -> World
updateFlames = updateObjCatMaybes flames updateFlame

updateEnergyBalls :: World -> World
updateEnergyBalls = updateObjCatMaybes energyBalls updateEnergyBall

updateRadarSweeps :: World -> World
updateRadarSweeps = updateObjCatMaybes radarSweeps updateRadarSweep

updateSparks :: World -> World
updateSparks = updateObjCatMaybes sparks updateSpark

updatePosEvents :: World -> World
updatePosEvents = updateObjCatMaybes posEvents updatePosEvent

updateClouds :: World -> World
updateClouds = updateObjCatMaybes clouds updateCloud

--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 = alaf Endo foldMap (markWallSeen . _wlID . snd) (allVisibleWalls w) w
--updateSeenWalls w = foldl' markWallSeen w (map (_wlID . snd) $ allVisibleWalls w)

markWallSeen :: Int -> World -> World
markWallSeen i = cWorld . seenWalls . at i ?~ ()
--markWallSeen :: World -> Int -> World
--markWallSeen w i = w & cWorld . seenWalls . at i ?~ ()

--markWallSeen !w !i = w & cWorld . lWorld . walls %~ IM.adjust markSeen i
-- in the past there might have been a space leak, which the following was meant
-- to fix
--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 ^? timeFlow . deathDelay of
    Just x
        | x < 0 ->
            uv & uvScreenLayers .~ [gameOverMenu uv]
    Just _ -> uv & uvWorld . timeFlow . deathDelay -~ 1
    _ | _crHP (you w) < 1 -> uv & uvWorld . 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

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))