{-# LANGUAGE BangPatterns #-}
{- |
Module      : Dodge.Update
Description : Simulation update
-}
module Dodge.Update ( updateUniverse ) where
import Dodge.Data
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.Block
import Dodge.Distortion
import Dodge.SoundLogic
--import Dodge.Wall.Delete
import Dodge.Update.WallDamage
--import Dodge.Machine.Destroy
--import Dodge.Menu
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 qualified Data.Text as T
--import System.Random
import Data.List
import Data.Maybe
--import Data.Function
import qualified Data.IntMap.Strict as IM
import qualified Data.Map.Strict as M
import Control.Applicative
--import qualified Data.Set as S
--import Data.Monoid
--import System.Random
import qualified Streaming.Prelude as S
import SDL
--import Streaming

{- 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 (dbArg _worldEvents)
        | otherwise -> u & menuLayers %~ ( (WaitScreen s (i-1) :) . tail )
    (OptionScreen {_scOptionFlag = GameOverOptions} : _) -> u & uvWorld %~
        ( updateParticles 
        . (radarBlips .~ [])
        . updateIMl _props _pjUpdate 
        . updateLightSources
        . updateClouds )
    (_ : _) -> u
    []  -> over uvWorld (functionalUpdate (_config u)) u 

{- | The update step. -}
functionalUpdate :: Configuration -> World -> World
functionalUpdate cfig w = checkEndGame 
--    . updateRandGen
    . (mouseButtons . each .~ True)  -- to determine if the mouse button is held
    . (worldClock +~ 1)
    . updateWorldSelect
    . doRewind
    . (hammers . each %~ moveHammerUp)
    . updateDistortions
    . updateCreatureSoundPositions
    . ppEvents
    . updateCamera cfig
    . colCrsWalls cfig
    . simpleCrSprings 
    . zoneCreatures 
    . updateIMl _doors _drMech
    . updateDelayedEvents
    . resetWorldEvents
    . dbArg _worldEvents
    . updateIMl _modifications _mdUpdate
    . updateSparks 
    . updateRadarSweeps
    . updatePosEvents 
    . updateFlames
    . updateEnergyBalls
    . updateParticles 
    . updateBullets 
    . updateRadarBlips 
    . updateFlares 
    . updateBeams
    . updateIMl _props _pjUpdate  
    . updateLightSources
    . updateClouds
    . updateGusts
    . zoneClouds
    . updateMIM magnets _mgUpdate
    . updateIMl' _terminals tmUpdate
--    . updateIMl _machines mcChooseUpdate
    . updateIMl' _machines updateMachine
    . updateIMl _creatures _crUpdate 
        -- creatures should be updated early so that crOldPos is set before any position change
    . over creatures (fmap setOldPos)
    . updateCreatureGroups
--    . updateBlocks
    . updateWallDamages
    . updateSeenWalls 
--    . (youHammerPosition %~ moveHammerUp)
    . updateTerminal
    . updateRBList
    . updateBounds cfig  -- where should this go? next to update camera?
    $ updateCloseObjects w

zoneClouds :: World -> World
zoneClouds w = w 
    & clZoning . znObjects .~ mempty
    & clZoning %~ \zn ->
        foldl' (flip $ updateZoning (:)) 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 . znObjects .~ mempty
    & crZoning %~ \zn ->
        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)

-- | Note the explict use of record syntax. Using lens created a space leak.
resetWorldEvents :: World -> World
resetWorldEvents w = w {_worldEvents = id}

updateCreatureGroups :: World -> World
updateCreatureGroups w = w & creatureGroups %~ 
    IM.mapMaybe (\cgp -> _crGroupUpdate cgp w cgp)

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

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

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

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

{- 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)  -> (_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 -> _ppEvent pp pp) w $ _pressPlates w

updateSeenWalls :: World -> World
updateSeenWalls w = runIdentity $ S.fold_ markWallSeen w id (S.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 :: World -> World
checkEndGame w = case _deathDelay w of
    Just x | x < 0 -> w & sideEffects %~ ( . (menuLayers .~ [gameOverMenu]))
        & deathDelay .~ Nothing
    Just _ -> w & deathDelay . _Just -~ 1
    _ | _crHP (you w) < 1 -> w & deathDelay ?~ 50
    _ -> w

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 = runIdentity $ S.fold_ (clClSpringVel c) (_clVel c) id (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 = runIdentity $ S.fold_ (flip $ crCrSpring c) w id 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    = (g w', Nothing)
        | otherwise = (w', Just (i-1,g))