{-# LANGUAGE BangPatterns #-}
{- |
Module      : Dodge.Update
Description : Simulation update
-}
module Dodge.Update ( updateUniverse ) where
import Dodge.Tesla.Arc
import Dodge.Laser.Update
import Dodge.PressPlate
import Dodge.ModificationEffect
import Dodge.CrGroupUpdate
import Dodge.Zoning.Cloud
import Dodge.Zoning.Creature
import Dodge.WorldEffect
import Dodge.Data
import Dodge.Beam
import Dodge.LightSource.Update
import Dodge.Projectile.Update
import Dodge.Creature.Update
import Dodge.RadarSweep
import Dodge.PosEvent
import Dodge.Spark
import Dodge.EnergyBall
import Dodge.Flame
import Dodge.Bullet
import Dodge.Update.Cloud
import Dodge.Machine.Update
import Dodge.RadarBlip
import Dodge.Flare
import Dodge.Menu
import Dodge.CullBox
import Dodge.Distortion
import Dodge.SoundLogic
import Dodge.Update.WallDamage
import Dodge.Base
--import Dodge.Zone
import Dodge.Hammer
import Dodge.WallCreatureCollisions
import Dodge.Update.Camera
import Dodge.Inventory
import Sound.Data
import Geometry
import LensHelp
import FoldableHelp

import Data.List
import Data.Maybe
import qualified IntMapHelp as IM
import qualified Data.Map.Strict as M
import Control.Applicative
--import qualified Streaming.Prelude as S
import SDL

{- For most menus the only way to change the world is using event handling.  -}
updateUniverse :: Universe -> Universe
updateUniverse u = case _menuLayers u of
    (WaitScreen s i : _) 
        | i < 1     -> u & over uvWorld doWorldEvents
        | otherwise -> u & menuLayers %~ ( (WaitScreen s (i-1) :) . tail )
    (OptionScreen {_scOptionFlag = GameOverOptions} : _) -> u & uvWorld %~
        ( updateParticles 
        . (radarBlips .~ [])
        . updateIMl _props _pjUpdate 
        . updateLightSources
        . updateClouds )
    (_ : _) -> u
    []  -> functionalUpdate u 

{- | The update step. -}
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 updateWorldSelect
    . over uvWorld doRewind
    . over uvWorld (hammers . each %~ moveHammerUp)
    . over uvWorld updateDistortions
    . over uvWorld updateCreatureSoundPositions
    . over uvWorld ppEvents
    . updateCamera
    . colCrsWalls
    . over uvWorld simpleCrSprings 
    . over uvWorld zoneCreatures
    . over uvWorld (updateIMl _doors _drMech                )
    . over uvWorld doWorldEvents
    . over uvWorld updateDelayedEvents
    . over uvWorld (updateIMl _modifications (doModificationEffect . _mdUpdate)      )
    . over uvWorld updateSparks
    . over uvWorld updateRadarSweeps
    . over uvWorld updatePosEvents
    . over uvWorld updateFlames
    . 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 (updateIMl _props _pjUpdate              )
    . over uvWorld (updateIMl' _projectiles updateProjectile)
    . over uvWorld updateLightSources
    . over uvWorld updateClouds
    . over uvWorld updateGusts
    . over uvWorld zoneClouds
    . over uvWorld (updateMIM magnets _mgUpdate             )
    . over uvWorld (updateIMl' _terminals tmUpdate          )
--    . updateIMl _machines mcChooseUpdate
    . over uvWorld (updateIMl' _machines updateMachine   )
    . over uvWorld (updateIMl' _creatures updateCreature )
        -- creatures should be updated early so that crOldPos is set before any position change
    . over (uvWorld . 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 w

doWorldEvents :: World -> World
doWorldEvents w = foldr doWorldEffect (w & worldEvents .~ []) (_worldEvents w)

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

zoneClouds :: World -> World
zoneClouds w = w 
    & clZoning .~ mempty
    & clZoning %~ \zn ->
        foldl' (flip zoneCloud) zn (_clouds 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
    (Nothing   ,Nothing)  -> w
    (Just False,Nothing)  -> w & lLine . _1 .~ mwp
    (Just True ,Nothing)  -> w & lLine . _2 .~ mwp
    (Nothing   ,_)        -> w
    (Just False,_)        -> w & rLine . _1 .~ mwp
    (Just True ,_)        -> w & rLine . _2 .~ mwp
  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

tmUpdate :: Terminal -> World -> World
tmUpdate tm w = case w ^? 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 .:~ f w )
        )
    Just (TerminalLineEffect _ eff) -> w
        & pointTermParams . tmFutureLines %~ tail
        & eff tm
    Just (TerminalLineTerminalEffect _ eff) -> w
        & pointTermParams . tmFutureLines %~ tail
        & pointTermParams %~ eff
  where
    pointTermParams = 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 _maybeWorld w of
    Just' w' -> w' & timeFlow .~ RewindingLastFrame
    Nothing' -> w  & timeFlow .~ NormalTimeFlow

zoneCreatures :: World -> World
zoneCreatures w = w 
    & crZoning .~ mempty
    & crZoning %~ \zn -> foldl' (flip zoneCreature) zn (_creatures 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 ^? 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 & creatureGroups %~ 
    IM.mapMaybe (\cgp -> doCrGroupUpdate (_crGroupUpdate cgp) w cgp)

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

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

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

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

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


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

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

updateEnergyBalls :: World -> World
updateEnergyBalls w = w' & energyBalls .~ catMaybes newebs
  where
    (w',newebs) = mapAccumR moveEnergyBall w $ _energyBalls w
updateRadarSweeps :: World -> World
updateRadarSweeps w = w' & radarSweeps .~ catMaybes newradarSweeps
  where
    (w',newradarSweeps) = mapAccumR updateRadarSweep w $ _radarSweeps w

updateSparks :: World -> World
updateSparks w = w' & sparks .~ catMaybes newsparks
  where
    (w',newsparks) = mapAccumR moveSpark w $ _sparks w
updatePosEvents :: World -> World
updatePosEvents w = w' & posEvents .~ catMaybes newposEvents
  where
    (w',newposEvents) = mapAccumR updatePosEvent w $ _posEvents 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
    & newBeams .~ WorldBeams [] [] [] []
    & beams    .~ thebeams
    & combineBeams thebeams
  where
    thebeams = _newBeams w

combineBeams :: WorldBeams -> World -> World
combineBeams wbeams w = w'' 
    & beams . positronBeams .~ pbeams
    & 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 w of
    [] -> w
    ps -> let (w',ps') = mapAccumR updateBullet (w {_instantBullets=[]}) ps
        in updateInstantBullets $ w' & 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 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 { _walls = IM.adjust markSeen i $ _walls w }

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

checkEndGame :: Universe -> Universe
checkEndGame uv = case _deathDelay 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
    _ -> uv
  where
    w = _uvWorld uv

updateGusts :: World -> World
updateGusts w = w
    & 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' & clouds .~ catMaybes mclouds
  where
--    cls = _clouds w
    (w',mclouds) = mapAccumR updateCloud w (_clouds 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 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 = 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 w)
    in neww & delayedEvents .~ catMaybes newde
  where
    f w' (i,g) 
        | i <= 0    = (w' & worldEvents .:~ g, Nothing)
        | otherwise = (w', Just (i-1,g))