{-# 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 qualified Data.Set as S
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
import qualified Data.Text as T

updateUniverse :: Universe -> Universe
updateUniverse = updateUniverseLast . updateUniverseFirst

updateUniverseLast :: Universe -> Universe
updateUniverseLast = over uvWorld (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.  -}
updateUniverseFirst :: Universe -> Universe
updateUniverseFirst u
    | concurrentblocking = u
    | otherwise = case _uvScreenLayers u of
        (OptionScreen{_scOptionFlag = GameOverOptions} : _) ->
            u & uvWorld
                %~ (
                     --updateParticles
                     (cWorld . 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 . timeFlow of
    NormalTimeFlow -> functionalUpdate u
    ScrollTimeFlow smoothing _ _ _ -> over uvWorld (doTimeScroll smoothing) u
    _ -> u

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

doTimeScroll' :: Int -> World -> World
doTimeScroll' smoothing w = case w ^. 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 ^? cwTime . pastWorlds . _head of
    Nothing -> w
    Just cw -> case w ^?! timeFlow . reverseAmount of
        x | x > 0 ->
                w & cwTime . pastWorlds %~ tail
                    & timeFlow . futureWorlds .:~ _cWorld w
                    & timeFlow . reverseAmount -~ 1
                    & cWorld .~ cw
                    & pointerToItemLocation (w ^?! cWorld . itemLocations . ix i) . itUse . leftConsumption . wpCharge .~ (x -1)
        _ -> w
  where
    i = w ^?! timeFlow . scrollItemLocation

scrollTimeForward :: World -> World
scrollTimeForward w = case w ^? timeFlow . futureWorlds . _head of
    Nothing -> w
    Just cw ->
        w & timeFlow . futureWorlds %~ tail
            & cwTime . pastWorlds .:~ _cWorld w
            & cWorld .~ cw
            & timeFlow . reverseAmount .~ ramount
            & pointerToItemLocation (w ^?! cWorld . itemLocations . ix i) . itUse . leftConsumption . wpCharge .~ ramount
  where
    i = w ^?! timeFlow . scrollItemLocation
    ramount = (w ^?! timeFlow . reverseAmount) + 1

-- | The update step.
functionalUpdate :: Universe -> Universe
functionalUpdate w =
    checkEndGame
        --    . updateRandGen
        . over uvWorld (cwTime . worldClock +~ 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
        . updateCamera
        . colCrsWalls
        . over uvWorld simpleCrSprings
        . over uvWorld zoneCreatures
        . over uvWorld (updateIMl (_doors . _cWorld) (doDrWdWd . _drMech))
        . over uvWorld doWorldEvents
        . over uvWorld updateDelayedEvents
        . over uvWorld (updateIMl (_modifications . _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 . _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 (cWorld . magnets) (doMagnetUpdate . _mgUpdate))
        . over uvWorld (updateIMl' (_terminals . _cWorld) tmUpdate)
        --    . updateIMl _machines mcChooseUpdate
        . 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 . cWorld . creatures) (fmap setOldPos)
        . over uvWorld updateCreatureGroups
        . over uvWorld updateWallDamages
        . over uvWorld updateSeenWalls
        . over uvWorld updateTerminal
        . over uvWorld updateRBList
        . updateBounds -- where should this go? next to update camera?
        . 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 ^. scrollAmount


advanceScrollAmount :: Universe -> Universe
advanceScrollAmount u =
    u
        & uvWorld . previousScrollAmount .~ _scrollAmount (_uvWorld u)
        & uvWorld . scrollAmount .~ 0

updatePastWorlds :: World -> World
updatePastWorlds w = w & cwTime . pastWorlds %~ (forceFoldable . take 100 . (_cWorld w :))

moveHammersUp :: Universe -> Universe
--moveHammersUp = uvWorld . hammers .~ M.empty
moveHammersUp = uvWorld . 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 . worldEvents .~ []) (_worldEvents (_cWorld w))

updateLasers :: World -> World
updateLasers w =
    w'
        & cWorld . lasers .~ []
        & cWorld . lasersToDraw .~ ls
  where
    (w', ls) = mapAccumR updateLaser w (_lasers (_cWorld w))

zoneClouds :: World -> World
zoneClouds w =
    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
    (Just False, Nothing) ->
        w & lLine . _1 .~ mwp
            & lrLine . _1 .~ mwp
    (Just True, Nothing) ->
        w & lLine . _2 .~ mwp
            & lrLine . _1 .~ mwp
    (Nothing, Just False) ->
        w & rLine . _1 .~ mwp
            & lrLine . _2 .~ mwp
    (Nothing, Just True) ->
        w & rLine . _2 .~ mwp
            & lrLine . _2 .~ mwp
    _ -> w
  where
    mwp = mouseWorldPos w
    f
        | ButtonLeft `M.member` _mouseButtons w = lSelect .~ mwp
        | otherwise = id
    g
        | ButtonRight `M.member` _mouseButtons w = 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 . 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 . 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 . crZoning .~ mempty
        & cWorld . crZoning %~ \zn -> foldl' (flip zoneCreature) zn (_creatures (_cWorld w))

--        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 . 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 . creatureGroups
        %~ IM.mapMaybe (\cgp -> doCrGroupUpdate (_crGroupUpdate cgp) w cgp)

updateDistortions :: World -> World
updateDistortions = cWorld . distortions %~ mapMaybe updateDistortion

updateLightSources :: World -> World
updateLightSources = cWorld . tempLightSources %~ f
  where
    f = mapMaybe (\b -> updateTempLightSource (_tlsUpdate b) b)

updateRadarBlips :: World -> World
updateRadarBlips = cWorld . radarBlips %~ mapMaybe updateRadarBlip

updateFlares :: World -> World
updateFlares = cWorld . flares %~ mapMaybe updateFlare

updateTeslaArcs :: World -> World
updateTeslaArcs w = w' & cWorld . teslaArcs .~ catMaybes newtas
  where
    (w', newtas) = mapAccumR moveTeslaArc w $ _teslaArcs (_cWorld w)

updateTractorBeams :: World -> World
updateTractorBeams w = w' & cWorld . tractorBeams .~ catMaybes newtas
  where
    (w', newtas) = mapAccumR updateTractorBeam w $ _tractorBeams (_cWorld w)

{- Apply internal particle updates, delete 'Nothing's.  -}
updateBullets :: World -> World
updateBullets w = updateInstantBullets $ set (cWorld . bullets) (catMaybes ps) w'
  where
    (w', ps) = mapAccumR updateBullet w $ _bullets (_cWorld w)

updateShockwaves :: World -> World
updateShockwaves w = w' & cWorld . shockwaves .~ catMaybes newflames
  where
    (w', newflames) = mapAccumR updateShockwave w $ _shockwaves (_cWorld w)

updateFlames :: World -> World
updateFlames w = w' & cWorld . flames .~ catMaybes newflames
  where
    (w', newflames) = mapAccumR moveFlame w $ _flames (_cWorld w)

updateEnergyBalls :: World -> World
updateEnergyBalls w = w' & cWorld . energyBalls .~ catMaybes newebs
  where
    (w', newebs) = mapAccumR moveEnergyBall w $ _energyBalls (_cWorld w)

updateRadarSweeps :: World -> World
updateRadarSweeps w = w' & cWorld . radarSweeps .~ catMaybes newradarSweeps
  where
    (w', newradarSweeps) = mapAccumR updateRadarSweep w $ _radarSweeps (_cWorld w)

updateSparks :: World -> World
updateSparks w = w' & cWorld . sparks .~ catMaybes newsparks
  where
    (w', newsparks) = mapAccumR moveSpark w $ _sparks (_cWorld w)

updatePosEvents :: World -> World
updatePosEvents w = w' & cWorld . posEvents .~ catMaybes newposEvents
  where
    (w', newposEvents) = mapAccumR updatePosEvent w $ _posEvents (_cWorld w)

{- 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 . newBeams .~ WorldBeams [] [] [] []
        & cWorld . beams .~ thebeams
        & combineBeams thebeams
  where
    thebeams = _newBeams (_cWorld w)

combineBeams :: WorldBeams -> World -> World
combineBeams wbeams w =
    w''
        & 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

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 _instantBullets (_cWorld w) of
    [] -> w
    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
--    [] -> 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 $ _pressPlates (_cWorld w)

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 . walls .~ IM.adjust markSeen i (_walls (_cWorld w))

markSeen :: Wall -> Wall
{-# INLINE markSeen #-}
markSeen wl = wl{_wlSeen = True}

checkEndGame :: Universe -> Universe
checkEndGame uv = case w ^. cwTime . deathDelay of
    Just x
        | x < 0 ->
            uv & uvScreenLayers .~ [gameOverMenu]
                & uvWorld . cwTime . deathDelay .~ Nothing
    Just _ -> uv & uvWorld . cwTime . deathDelay . _Just -~ 1
    _ | _crHP (you w) < 1 -> uv & uvWorld . cwTime . deathDelay ?~ 50
    _ -> uv
  where
    w = _uvWorld uv

updateGusts :: World -> World
updateGusts w = w & cWorld . 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' & cWorld . clouds .~ catMaybes mclouds
  where
    --    cls = _clouds w
    (w', mclouds) = mapAccumR updateCloud w (_clouds (_cWorld w))

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 $ _creatures (_cWorld w)

-- 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 . 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 (_delayedEvents (_cWorld w))
     in neww & cWorld . delayedEvents .~ catMaybes newde
  where
    f w' (i, g)
        | i <= 0 = (w' & cWorld . worldEvents .:~ g, Nothing)
        | otherwise = (w', Just (i -1, g))