{- |
Module      : Dodge.Update
Description : Simulation update
-}
module Dodge.Update ( updateUniverse ) where
import Dodge.Data
import Dodge.Menu
import Dodge.Hammer
import Dodge.Block
import Dodge.Distortion
import Dodge.SoundLogic
--import Dodge.Menu
import Dodge.Base
import Dodge.Zone
import Dodge.WallCreatureCollisions
import Dodge.Update.Camera
import Dodge.Inventory
import Sound.Data
import Geometry

import Data.List
import Data.Maybe
import Data.Function
import qualified Data.IntMap.Strict as IM
import qualified Data.Map.Strict as M
--import qualified Data.Set as S
import Control.Lens
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 
    . (worldClock +~ 1)
    . updateDistortions
    . updateCreatureSoundPositions
    . ppEvents
    . updateCamera cfig
    . colCrsWalls cfig
    . simpleCrSprings 
    . zoneCreatures 
    . updateIMl _doors _drMech
    . updateDelayedEvents
    . resetWorldEvents
    . dbArg _worldEvents
    . updateIMl _modifications _mdUpdate
    . updateParticles 
    . updateIMl _props _pjUpdate  
    . updateLightSources
    . updateClouds
    . zoneClouds
    . updateIMl _machines _mcUpdate
    . updateCreatures 
    . updateCreatureGroups
    . updateBlocks
    . updateSeenWalls 
    . (lSelHammerPosition %~ moveHammerUp)
    $ 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

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.foldrWithKey insertSound w 
    . M.mapMaybeWithKey updateSound 
    $ _playingSounds w
  where
    insertSound k s = 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)

updateBlocks :: World -> World
updateBlocks w = foldr f w $ _blocks w
  where
    f bl w' = case _blHPs bl of
        (x:_:_) | x < 1 -> splinterBlock bl w'
        [x]     | x < 1 -> destroyBlock bl w'
        _ -> 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

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

updateMachines :: World -> World
updateMachines w = foldr f w (_machines w)
  where
    f mc = _mcUpdate mc mc

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

updateDoors :: World -> World
updateDoors w = IM.foldl' (\w' dr -> _drMech dr dr w') w (_doors w)

ppEvents :: World -> World
ppEvents w = IM.foldl' (flip $ \pp -> _ppEvent pp pp) w $ _pressPlates w

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

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 
    | _crHP (you w) < 1 = w & sideEffects %~ ( . (menuLayers .~ [gameOverMenu]))
    | otherwise         = w

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 npz $ maybe newPos2 fst hitWl
    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 theTest
    . 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)
    theTest wl = _wlOpacity wl /= Opaque

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