{- |
Module      : Dodge.Update
Description : Simulation update
-}
module Dodge.Update 
    ( update
    ) where
import Dodge.Data
import Dodge.Menu
import Dodge.Config.Data
import Dodge.Base
import Dodge.Zone
import Dodge.WallCreatureCollisions
import Dodge.Update.Camera
import Dodge.SoundLogic
import Dodge.Inventory
import Dodge.WorldEvent.Sound
import Dodge.Wall.Delete
import Geometry
import Geometry.ConvexPoly
import Geometry.Vector3D

import SDL (MouseButton (..))
import Data.List
import Data.Maybe
import Data.Function
import qualified Data.Set as S
import qualified Data.IntSet as IS
import qualified Data.IntMap.Strict as IM
import Control.Lens
import Data.Monoid
import System.Random

update :: World -> World
update = (frameClock +~ 1) . functionalUpdate

{- | 
 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
    (TerminalScreen t xs:mls) -> w & menuLayers .~ (TerminalScreen (max (t-1) 0) xs:mls)
    (WaitScreen s i : _) 
        | i < 1     -> w & dbArg _worldEvents
        | otherwise -> w & menuLayers %~ ( (WaitScreen s (i-1) :) . tail )
    (OptionScreen {_scOptionFlag = GameOverOptions} : _) -> updateParticles 
        . updateProjectiles 
        . updateLightSources
        $ updateClouds
        w
    (_ : _) -> w
    []  -> checkEndGame 
        . updateRadialDistortions
        . ppEvents 
        . updateCamera
        . colCrsWalls
        . ifConfigWallRotate
        . simpleCrSprings 
        . zoneCreatures 
        . updateDoors
        . resetWorldEvents
        . dbArg _worldEvents
        . updateParticles 
        . updateProjectiles 
        . updateLightSources
        . updateClouds
        . zoneClouds
        . updateMachines
        . updateCreatures 
        . updateCreatureGroups
        . updateBlocks
        . updateSeenWalls 
        $ updateCloseObjects w
  where 
    --updatedLightSources = mapMaybe (\b -> _tlsUpdate b w b) $ _tempLightSources w
    zoneCreatures = set (creaturesZone . znObjects) 
        (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 . znObjects) (foldl' (flip cloudInZone) IM.empty (_clouds w))
    cloudInZone cl = insertInZoneWith x y (++) [cl]
      where 
        (x,y) = cloudZoneOfPoint $ stripZ $ _clPos cl

splinterBlock :: Block -> World -> World
splinterBlock bl w = foldr unshadowBlock w (_blShadows bl) -- foldr shiftTowardCen w (_blWallIDs bl)
    & blocks . ix (_blID bl) . blHPs %~ tail
    & theSoundEffect cen
  where
    wls = map (_walls w IM.!) (IS.toList $ _blWallIDs bl)
    ps = map (fst . _wlLine) wls
    cen = centroid ps
    theSoundEffect 
        | _wlOpacity (head wls) == SeeThrough = mkSoundSplinterGlass
        | otherwise                           = mkSoundSplinterBlock

unshadowBlock :: Int -> World -> World
unshadowBlock wlid w = case w ^? walls . ix wlid of
    Just wl -> w
        & walls . ix wlid . wlDraw .~ True
        & wallsZone . znObjects . ix x . ix y . ix wlid . wlDraw .~ True
      where
        (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
    Nothing -> 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'

destroyBlock :: Block -> World -> World
destroyBlock bl w = w
    & deleteWallIDs wlids
    & blocks %~ IM.delete (_blID bl)
    & mkSoundBreakGlass pos
  where
    wlids = _blWallIDs bl
    pos = fst . _wlLine $ _walls w IM.! IS.findMin wlids

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

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

updateLightSources :: World -> World
updateLightSources w = over tempLightSources f w
  where 
    f = mapMaybe (\b -> _tlsUpdate b w b)

updateProjectiles :: World -> World
updateProjectiles w = IM.foldl' (flip $ dbArg _pjUpdate) w $ _props 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

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 = haltSound $ w {_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

ifConfigWallRotate :: World -> World
ifConfigWallRotate w
    | _rotate_to_wall (_config w) && not (ButtonRight `S.member` _mouseButtons w)
        = rotateToOverlappingWall w
    | otherwise = w

rotateToOverlappingWall :: World -> World
rotateToOverlappingWall w = case theWall of
    Nothing -> w
    Just wl -> rotateUsing ( (argV . uncurry (-.-) $ _wlLine wl) - camrot)
  where
    camrot = _cameraRot w
    rotateUsing a
        | b - b' > 0.01 = w & cameraRot +~ 0.01
        | b - b' < negate 0.01 = w & cameraRot -~ 0.01
        | otherwise    = w
      where
        b = a * (2 / pi)
        b' = fromIntegral (round b :: Int)
    cr = you w
    p = _crPos cr
    theWall = overlapCircWallsReturnWall p (_crRad cr + 5) (IM.filter _wlRotateTo $ wallsNearPoint p w)

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