{- |
Module      : Dodge.Update
Description : Simulation update
-}
module Dodge.Update ( updateUniverse ) where
import Dodge.Data
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.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

{- 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 
        . 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)
    . doRewind
    . (doubleMouseHammer %~ moveHammerUp)
    . updateDistortions
    . updateCreatureSoundPositions
    . ppEvents
    . updateCamera cfig
    . colCrsWalls cfig
    . simpleCrSprings 
    . zoneCreatures 
    . updateIMl _doors _drMech
    . updateDelayedEvents
    . resetWorldEvents
    . dbArg _worldEvents
    . updateIMl _modifications _mdUpdate
    . updateParticles 
    . updateBeams
    . updateIMl _props _pjUpdate  
    . updateLightSources
    . updateClouds
    . updateGusts
    . zoneClouds
    . updateMIM magnets _mgUpdate
    . updateIMl' _terminals tmUpdate
    . updateIMl _machines mcChooseUpdate
    . 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
    . updateBoundBox cfig  -- where should this go? next to update camera?
    $ updateCloseObjects w
  where 
    --updatedLightSources = mapMaybe (\b -> _tlsUpdate b w b) $ _tempLightSources w
    zoneClouds = set (cloudsZone . znObjects) (foldl' (flip cloudInZone) IM.empty (_clouds w))
    cloudInZone cl = insertInZoneWith x y (++) [cl]
      where 
        (x,y) = cloudZoneOfPoint $ stripZ $ _clPos cl


updateBoundBox :: Configuration -> World -> World
updateBoundBox cfig w = w & boundBox .~ cullBox cfig w

mcChooseUpdate :: Machine -> Machine -> World -> World
mcChooseUpdate mc mc'
    | _mcHP mc > 0  = _mcUpdate mc mc'
    | otherwise     = (machines %~ IM.delete (_mcID mc))
        . deleteWallIDs (_mcWallIDs mc)
        . _mcDeath mc 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 
    & creaturesZone . znObjects .~
        IM.foldl' (flip creatureInZone) IM.empty (_creatures w)
  where
    creatureInZone cr = insertIMInZone x y cid cr
      where 
        (x,y) = crZoneOfPoint $ _crPos cr
        cid = _crID cr

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 w = over tempLightSources f w
  where 
    f = mapMaybe (\b -> _tlsUpdate b w b)

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

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

-- this is not working correctly, maybe a problem with wallsAlongLine
updateSeenWalls :: World -> World
updateSeenWalls w = foldl' markWallSeen w wallsToUpdate
  where 
    vPos = _cameraViewFrom w
    wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w)
                             $ nRays 20
--    wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ _walls w)
--                             $ nRays 20

markWallSeen :: World -> Wall -> World
markWallSeen w wl = w { _walls = IM.adjust mw (_wlID wl) $ _walls w }
  where
    mw 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
    (w',mclouds) = mapAccumR updateCloud w (_clouds w)

updateCloud :: World -> Cloud -> (World,Maybe Cloud)
updateCloud w c
    | _clTimer c < 1 = (w, Nothing)
    | otherwise = (_clEffect c 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) (cloudsNearPoint oldPos2 w)
    oldPos@(V3 _ _ opz) = _clPos c
    oldPos2 = stripZ oldPos
    newPos@(V3 _ _ npz) = oldPos +.+.+ newVel
    newPos2 = stripZ newPos
    -- the following only tests for the first collision with a wall
    hitWl = collidePointAnyWallsReflect oldPos2 newPos2 $ wallsNearPoint 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

--updateCloud :: World -> Cloud -> Maybe Cloud
--updateCloud w c
--    | _clTimer c < 1 = Nothing
--    | otherwise = Just $ c 
--        & clPos .~ finalPos
--        & clVel .~ finalVel
--        & clTimer -~ 1
--  where
--    newVel = 0.95 *.* springVels
--    springVels = foldl' (clClSpringVel c) (_clVel c) (cloudsNearPoint oldPos w)
--    oldPos = _clPos c
--    newPos = oldPos +.+ newVel
--    hitWl = collideCircWalls' oldPos newPos 5 $ wallsNearPoint newPos w
--    finalPos = maybe newPos fst hitWl
--    finalVel = maybe newVel 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

crSpring :: Creature -> World -> World
crSpring c w = IM.foldl' (flip $ crCrSpring c) w cs
  where 
    cs = creaturesNearPoint (_crPos c) w

crCrSpring :: Creature -> Creature -> World -> World
crCrSpring c1 c2 w 
    | id1 == id2 = w
    | vec == V2 0 0 = w
    | diff >= comRad = w
    | otherwise = over creatures
        ( over (ix id1 . crPos) (+.+ overlap1)
        . over (ix id2 . crPos) (-.- overlap2)
        ) w
  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

{- Finds the visible walls from a point to another point.  -}
visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall]
visibleWalls p1 p2 ws 
    = takeUntil wlIsOpaque
    . map snd 
    . sortOn (dist p1 . fromJust . fst) 
    . filter (isJust . fst) 
    . map f 
    $ IM.elems ws
  where 
    f wl = (uncurry intersectSegSeg (_wlLine wl) p1 p2, wl)

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