{- |
Module      : Dodge.Update
Description : Simulation update
-}
module Dodge.Update 
    ( update
    ) where
import Dodge.Data
import Dodge.Data.Menu
import Dodge.World.Trigger.Data
--import Dodge.Config.Data
import Dodge.Base
import Dodge.Base.Zone
import Dodge.WallCreatureCollisions
import Dodge.LevelGen.Block
import Dodge.Update.Camera
--import Dodge.Update.UsingInput
import Dodge.SoundLogic
import Dodge.Inventory
import Dodge.Initialisation
import Dodge.Layout
import Dodge.Floor
import Geometry
import Geometry.Vector3D

import Data.List
import Data.Maybe
import Data.Function
import qualified Data.Set as S
import qualified Data.IntMap.Lazy as IM
import qualified Data.Map as M
import Control.Lens
import Data.Monoid
--import System.Random

update :: World -> World
update = functionalUpdate . pushSideEffects

pushSideEffects :: World -> World
pushSideEffects w = w 
    & sideEffects .~ []
    & doneSideEffects .~ _sideEffects w
{- | 
 The update step.
For most menus the only way to change the world is using event handling.  -}
functionalUpdate :: World -> World
functionalUpdate w = case _menuLayers w of
    (TerminalMessage t xs:mls) -> w & menuLayers .~ (TerminalMessage (max (t-1) 0) xs:mls)
    (WaitMessage s i: _) 
        | i < 1     -> w & dbArg _worldEvents
        | otherwise -> w & menuLayers %~ ( (WaitMessage s (i-1) :) . tail )
    (GameOverMenu : _) -> updateParticles 
        . updateProjectiles 
        . updateLightSources
        . updateClouds
        $ updateSoundQueue
        w
    (_ : _) -> w
    []  -> checkEndGame 
        . updateRadialDistortions
        . updateTriggers
        . ppEvents 
        . updateCamera
        . colCrsWalls
        . simpleCrSprings 
        . zoneCreatures 
        . updateWalls
        . resetWorldEvents
        . dbArg _worldEvents
        . updateParticles 
        . updateProjectiles 
        . updateLightSources
        . updateClouds
        . zoneClouds
        . updateCreatures 
        . updateCreatureGroups
        . updateBlocks
        . updateSeenWalls 
        . updateSoundQueue
        $ updateCloseObjects w
  where 
    zoneCreatures = set creaturesZone (IM.foldl' (flip creatureInZone) IM.empty (_creatures w))
    creatureInZone cr = insertIMInZone x y cid cr
      where 
        (x,y) = crZoneOfPoint $ _crPos cr
        cid = _crID cr
    zoneClouds = set cloudsZone (foldl' (flip cloudInZone) IM.empty (_clouds w))
    cloudInZone cl = insertInZoneWith x y (++) [cl]
      where 
        (x,y) = cloudZoneOfPoint $ stripZ $ _clPos cl

-- | Note the explict use of record syntax. Using lens creates 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)

updateRadialDistortions :: World -> World
updateRadialDistortions = radDistortion %~ mapMaybe decreaseBulge

decreaseBulge 
    :: (Point2,Point2,Point2,Float) 
    -> Maybe (Point2,Point2,Point2,Float)
decreaseBulge (a,b,c,v)
    | v > 1 = Just (a,b,c,max 1 (v - 0.05) )
    | v < 1 = Just (a,b,c,min 1 (v + 0.05) )
    | otherwise = Nothing

updateTriggers :: World -> World
updateTriggers w 
    | ResetLevel 1 `S.member` _worldTriggers w = generateLevelFromRoomList levx $ initialWorld 
        & randGen       .~ _randGen w
        & config        .~ _config w
        & menuLayers    .~ []
        & creatures . ix 0 .~ cr
    | otherwise = w
  where
    cr = _creatures w IM.! 0 & crPos .~ V2 0 0

updateSoundQueue :: World -> World
updateSoundQueue = set soundQueue [] . set sounds M.empty

updateLightSources :: World -> World
updateLightSources w = set tempLightSources (catMaybes tlss) w'
  where 
    (w',tlss) = mapAccumR (\a b -> _tlsUpdate b a b) w $ _tempLightSources w

updateProjectiles :: World -> World
updateProjectiles w = IM.foldl' (flip $ dbArg _pjUpdate) w $ _projectiles w
{-
Apply internal particle updates, delete 'Nothing's.  -}
updateParticles :: World -> World
updateParticles w = set particles (catMaybes ps) w'
  where 
    (w',ps) = mapAccumR (\a b -> _ptUpdate' b a b) w $ _particles w

updateCreatures :: World -> World
updateCreatures w = appEndo f $ w & creatures .~ IM.mapMaybe id m
  where
    (f,m) = traverse (\cr -> _crUpdate cr cr w) (_creatures w)

{- |
Apply door mechanisms.  -}
updateWalls :: World -> World
updateWalls w = IM.foldl' (flip $ fromMaybe id . (^? doorMech)) w (_walls w)

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

updateSeenWalls :: World -> World
updateSeenWalls w = foldl' (flip markSeen) w wallsToUpdate
  where 
    vPos = _cameraViewFrom w
    wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w)
                             $ nRays 20
    markSeen i = set (walls . ix i . wlSeen) True

--setTestStringIO :: IO World -> IO World
--setTestStringIO = fmap (\ w -> set testString (show $ s w) w)
--  where 
--    s w = (-.-) <$> (w ^? creatures . ix 0 . crPos) <*> (w ^? creatures . ix 0 . crOldPos)

checkEndGame :: World -> World
checkEndGame w 
    | _crHP (you w) < 1 = haltSound $ w {_menuLayers = [GameOverMenu]}
    | otherwise         = w

--updateClouds :: World -> World
--updateClouds w = w' & clouds %~ mapMaybe (updateCloud w)
updateClouds :: World -> World
updateClouds w = w' & clouds .~ catMaybes mclouds
  where
    (w',mclouds) = mapAccumR updateCloud w (_clouds w)
-- did i write a mapMaybeAccumR ?

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
    hitWl = collideCircWalls' oldPos2 newPos2 5 $ 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 . ix id1 . crPos) (+.+ overlap1)
                        $ over (creatures . 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 IDs of visible walls from a point to another point.  -}
visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Int]
visibleWalls p1 p2 ws 
    = map fst 
    . takeUntil (_wlIsSeeThrough . snd) 
    . map snd 
    . sortOn (dist p1 . fromJust . fst) 
    . filter ((/=) Nothing . fst) 
    . map f 
    $ IM.toList ws
  where 
    f (i,wl) = (uncurry intersectSegSeg (_wlLine wl) p1 p2, (i,wl))