-- | Server operations performed periodically in the game loop
-- and related operations.
module Game.LambdaHack.Server.PeriodicM
  ( spawnMonster, addManyActors
  , advanceTime, advanceTimeTraj, overheadActorTime, swapTime
  , updateCalm, leadLevelSwitch
  , endOrLoop
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , addAnyActor, rollSpawnPos, gameExit
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import           Data.Int (Int64)
import qualified Data.IntMap.Strict as IM
import qualified Data.Text as T

import           Game.LambdaHack.Atomic
import           Game.LambdaHack.Common.Actor
import           Game.LambdaHack.Common.ActorState
import           Game.LambdaHack.Common.Area
import           Game.LambdaHack.Common.Faction
import           Game.LambdaHack.Common.Item
import           Game.LambdaHack.Common.Kind
import           Game.LambdaHack.Common.Level
import           Game.LambdaHack.Common.Misc
import           Game.LambdaHack.Common.MonadStateRead
import           Game.LambdaHack.Common.Perception
import           Game.LambdaHack.Common.Point
import           Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import           Game.LambdaHack.Common.Time
import           Game.LambdaHack.Common.Types
import qualified Game.LambdaHack.Content.CaveKind as CK
import           Game.LambdaHack.Content.FactionKind
import           Game.LambdaHack.Content.ItemKind (ItemKind)
import qualified Game.LambdaHack.Content.ItemKind as IK
import           Game.LambdaHack.Content.ModeKind
import           Game.LambdaHack.Core.Frequency
import           Game.LambdaHack.Core.Random
import qualified Game.LambdaHack.Definition.Ability as Ability
import           Game.LambdaHack.Definition.Defs
import           Game.LambdaHack.Server.CommonM
import           Game.LambdaHack.Server.ItemM
import           Game.LambdaHack.Server.ItemRev
import           Game.LambdaHack.Server.MonadServer
import           Game.LambdaHack.Server.ProtocolM
import           Game.LambdaHack.Server.ServerOptions
import           Game.LambdaHack.Server.State

-- | Spawn, possibly, a monster according to the level's actor groups.
-- We assume heroes are never spawned.
spawnMonster :: MonadServerAtomic m => m ()
spawnMonster = do
 COps{cocave} <- getsState scops
 arenas <- getsServer sarenas
 unless (ES.null arenas) $ do
  -- Do this on only one of the arenas to prevent micromanagement,
  -- e.g., spreading leaders across levels to bump monster generation.
  arena <- rndToAction $ oneOf $ ES.elems arenas
  Level{lkind, ldepth, lbig, ltime=localTime} <- getLevel arena
  let ck = okind cocave lkind
  if | CK.cactorCoeff ck == 0 || null (CK.cactorFreq ck) -> return ()
     | EM.size lbig >= 300 ->  -- probably not so rare, but debug anyway
       -- Gameplay consideration: not fun to slog through so many actors.
       -- Caves rarely start with more than 100.
       debugPossiblyPrint "Server: spawnMonster: too many big actors on level"
     | otherwise -> do
       totalDepth <- getsState stotalDepth
       lvlSpawned <- getsServer $ fromMaybe 0 . EM.lookup arena . snumSpawned
       let perMillion =
             monsterGenChance ldepth totalDepth lvlSpawned (CK.cactorCoeff ck)
           million = 1000000
       k <- rndToAction $ randomR (1, million)
       when (k <= perMillion && localTime > timeTurn) $ do
         let numToSpawn | 25 * k <= perMillion = 3
                        | 10 * k <= perMillion = 2
                        | otherwise = 1
             alt Nothing = Just 1
             alt (Just n) = Just $ n + 1
         modifyServer $ \ser ->
           ser { snumSpawned = EM.insert arena (lvlSpawned + numToSpawn)
                               $ snumSpawned ser
               , sbandSpawned = IM.alter alt numToSpawn
                                $ sbandSpawned ser }
         void $ addManyActors False lvlSpawned (CK.cactorFreq ck) arena
                              localTime Nothing numToSpawn

addAnyActor :: MonadServerAtomic m
            => Bool -> Int -> Freqs ItemKind -> LevelId -> Time -> Maybe Point
            -> m (Maybe (ActorId, Point))
addAnyActor summoned lvlSpawned actorFreq lid time mpos = do
  -- We bootstrap the actor by first creating the trunk of the actor's body
  -- that contains the fixed properties of all actors of that kind.
  cops <- getsState scops
  lvl@Level{ldepth} <- getLevel lid
  factionD <- getsState sfactionD
  freq <- prepareItemKind lvlSpawned ldepth actorFreq
  m2 <- rollItemAspect freq ldepth
  case m2 of
    NoNewItem -> do
      debugPossiblyPrint $ T.pack $
        "Server: addAnyActor: trunk failed to roll"
        `showFailure` (summoned, lvlSpawned, actorFreq, freq, lid, time, mpos)
      return Nothing
    NewItem itemGroup itemKnownRaw itemFullRaw itemQuant -> do
      (fid, _) <- rndToAction $ frequency $
                    possibleActorFactions [itemGroup] (itemKind itemFullRaw)
                                          factionD
      let fact = factionD EM.! fid
      if isJust $ gquit fact
      then return Nothing  -- the faction that spawns the monster is dead
      else do
        pers <- getsServer sperFid
        let allPers = ES.unions $ map (totalVisible . (EM.! lid))
                      $ EM.elems $ EM.delete fid pers  -- expensive :(
            -- Checking skill would be more accurate, but skills can be
            -- inside organs, equipment, condition organs, created organs, etc.
            freqNames = map fst $ IK.ifreq $ itemKind itemFullRaw
            mobile = IK.MOBILE `elem` freqNames
            aquatic = IK.AQUATIC `elem` freqNames
        mrolledPos <- case mpos of
          Just{} -> return mpos
          Nothing -> do
            rollPos <-
              getsState $ rollSpawnPos cops allPers mobile aquatic lid lvl fid
            rndToAction rollPos
        case mrolledPos of
          Just pos ->
            Just . (\aid -> (aid, pos))
            <$> registerActor summoned itemKnownRaw (itemFullRaw, itemQuant)
                              fid pos lid time
          Nothing -> do
            debugPossiblyPrint
              "Server: addAnyActor: failed to find any free position"
            return Nothing

addManyActors :: MonadServerAtomic m
              => Bool -> Int -> Freqs ItemKind -> LevelId -> Time -> Maybe Point
              -> Int
              -> m Bool
addManyActors summoned lvlSpawned actorFreq lid time mpos
              howMany = assert (howMany >= 1) $ do
  mInitialLAidPos <- case mpos of
    Just pos -> return $ Just ([], pos)
    Nothing ->
      (\(aid, pos) -> ([aid], pos))
      <$$> addAnyActor summoned lvlSpawned actorFreq lid time Nothing
  case mInitialLAidPos of
    Nothing -> return False  -- suspect content; server debug elsewhere
    Just (laid, pos) -> do
      cops@COps{coTileSpeedup} <- getsState scops
      lvl <- getLevel lid
      let validTile t = not $ Tile.isNoActor coTileSpeedup t
          ps = nearbyFreePoints cops lvl validTile pos
          psNeeded = take (howMany - length laid) ps
      when (length psNeeded < howMany - length laid) $
        debugPossiblyPrint $
          "Server: addManyActors: failed to find enough free positions at"
          <+> tshow (lid, pos)
      maidposs <- forM psNeeded $
        addAnyActor summoned lvlSpawned actorFreq lid time . Just
      case laid ++ map fst (catMaybes maidposs) of
        [] -> return False
        aid : _ -> do
          b <- getsState $ getActorBody aid
          mleader <- getsState $ gleader . (EM.! bfid b) . sfactionD
          when (isNothing mleader) $ setFreshLeader (bfid b) aid
          return True

rollSpawnPos :: COps -> ES.EnumSet Point
             -> Bool -> Bool -> LevelId -> Level -> FactionId -> State
             -> Rnd (Maybe Point)
rollSpawnPos COps{coTileSpeedup} visible
             mobile aquatic lid lvl@Level{larea} fid s = do
  let inhabitants = foeRegularList fid lid s
      nearInh !d !p = any (\ !b -> chessDist (bpos b) p < d) inhabitants
      farInh !d !p = all (\ !b -> chessDist (bpos b) p > d) inhabitants
      (_, xspan, yspan) = spanArea larea
      averageSpan = (xspan + yspan) `div` 2
      distantMiddle !d !p = chessDist p (middlePoint larea) < d
      -- Don't spawn very far from foes, to keep the player entertained,
      -- but not too close, so that standing on positions with better
      -- visibility does not influence the spawn places too often,
      -- to avoid unnatural position micromanagement using AI predictability.
      condList | mobile =
        [ \p -> nearInh (max 15 $ averageSpan `div` 2) p
                && farInh 10 p
        , \p -> nearInh (max 15 $ 2 * averageSpan `div` 3) p
                && farInh 5 p
        ]
               | otherwise =
        [ distantMiddle 8
        , distantMiddle 16
        , distantMiddle 24
        , distantMiddle 26
        , distantMiddle 28
        , distantMiddle 30
        ]
  -- Not considering TK.OftenActor, because monsters emerge from hidden ducts,
  -- which are easier to hide in crampy corridors that lit halls.
  findPosTry2 (if mobile then 500 else 50) lvl
    ( \p !t -> Tile.isWalkable coTileSpeedup t
               && not (Tile.isNoActor coTileSpeedup t)
               && not (occupiedBigLvl p lvl)
               && not (occupiedProjLvl p lvl) )
    (map (\f p _ -> f p) condList)
    (\ !p t -> farInh 3 p  -- otherwise actors in dark rooms swarmed
               && not (p `ES.member` visible)  -- visibility and plausibility
               && (not aquatic || Tile.isAquatic coTileSpeedup t))
    [ \ !p _ -> farInh 3 p
                && not (p `ES.member` visible)
    , \ !p _ -> farInh 2 p  -- otherwise actors hit on entering level
                && not (p `ES.member` visible)
    , \ !p _ -> not (p `ES.member` visible)
    ]

-- | Advance the move time for the given actor.
advanceTime :: MonadServerAtomic m => ActorId -> Int -> Bool -> m ()
advanceTime aid percent breakStasis = do
  b <- getsState $ getActorBody aid
  actorMaxSk <- getsState $ getActorMaxSkills aid
  let t = timeDeltaPercent (ticksPerMeter $ gearSpeed actorMaxSk) percent
  -- @t@ may be negative; that's OK.
  modifyServer $ \ser ->
    ser {sactorTime = ageActor (bfid b) (blid b) aid t $ sactorTime ser}
  when breakStasis $
    modifyServer $ \ser ->
      ser {sactorStasis = ES.delete aid (sactorStasis ser)}
             -- actor moved, so he broke the time stasis, he can be
             -- paralyzed as well as propelled again

-- | Advance the trajectory following time for the given actor.
advanceTimeTraj :: MonadServerAtomic m => ActorId -> m ()
advanceTimeTraj aid = do
  b <- getsState $ getActorBody aid
  let speedTraj = case btrajectory b of
        Nothing -> error $ "" `showFailure` b
        Just (_, speed) -> speed
      t = ticksPerMeter speedTraj
  -- @t@ may be negative; that's OK.
  modifyServer $ \ser ->
    ser {strajTime = ageActor (bfid b) (blid b) aid t $ strajTime ser}

-- | Add communication overhead time delta to all non-projectile, non-dying
-- faction's actors, except the leader. Effectively, this limits moves
-- of a faction on a level to 10, regardless of the number of actors
-- and their speeds. To avoid animals suddenly acting extremely sluggish
-- whenever monster's leader visits a distant arena that has a crowd
-- of animals, overhead applies only to actors on the same level.
-- Since the number of active levels is limited, this bounds the total moves
-- per turn of each faction as well.
--
-- Leader is immune from overhead and so he is faster than other faction
-- members and of equal speed to leaders of other factions (of equal
-- base speed) regardless how numerous the faction is.
-- Thanks to this, there is no problem with leader of a numerous faction
-- having very long UI turns, introducing UI lag.
overheadActorTime :: MonadServerAtomic m => FactionId -> LevelId -> m ()
overheadActorTime fid lid = do
  -- Only non-projectiles processed, because @strajTime@ ignored.
  actorTimeFid <- getsServer $ (EM.! fid) . sactorTime
  let actorTimeLid = actorTimeFid EM.! lid
  getActorB <- getsState $ flip getActorBody
  mleader <- getsState $ gleader . (EM.! fid) . sfactionD
  let f !aid !time =
        let body = getActorB aid
        in if bhp body > 0  -- speed up all-move-at-once carcass removal
              && Just aid /= mleader  -- leader fast, for UI to be fast
           then timeShift time (Delta timeClip)
           else time
      actorTimeLid2 = EM.mapWithKey f actorTimeLid
      actorTimeFid2 = EM.insert lid actorTimeLid2 actorTimeFid
  modifyServer $ \ser ->
    ser {sactorTime = EM.insert fid actorTimeFid2 $ sactorTime ser}

-- | Swap the relative move times of two actors (e.g., when switching
-- a UI leader). Notice that their trajectory move times are not swapped.
swapTime :: MonadServerAtomic m => ActorId -> ActorId -> m ()
swapTime source target = do
  sb <- getsState $ getActorBody source
  tb <- getsState $ getActorBody target
  slvl <- getsState $ getLocalTime (blid sb)
  tlvl <- getsState $ getLocalTime (blid tb)
  btime_sb <-
    getsServer
    $ fromJust . lookupActorTime (bfid sb) (blid sb) source . sactorTime
  btime_tb <-
    getsServer
    $ fromJust . lookupActorTime (bfid tb) (blid tb) target . sactorTime
  let lvlDelta = slvl `timeDeltaToFrom` tlvl
      bDelta = btime_sb `timeDeltaToFrom` btime_tb
      sdelta = timeDeltaSubtract lvlDelta bDelta
      tdelta = timeDeltaReverse sdelta
  -- Equivalent, for the assert:
  let !_A = let sbodyDelta = btime_sb `timeDeltaToFrom` slvl
                tbodyDelta = btime_tb `timeDeltaToFrom` tlvl
                sgoal = slvl `timeShift` tbodyDelta
                tgoal = tlvl `timeShift` sbodyDelta
                sdelta' = sgoal `timeDeltaToFrom` btime_sb
                tdelta' = tgoal `timeDeltaToFrom` btime_tb
            in assert (sdelta == sdelta' && tdelta == tdelta'
                       `blame` ( slvl, tlvl, btime_sb, btime_tb
                               , sdelta, sdelta', tdelta, tdelta' )) ()
  when (sdelta /= Delta timeZero) $ modifyServer $ \ser ->
    ser {sactorTime = ageActor (bfid sb) (blid sb) source sdelta
                      $ sactorTime ser}
  when (tdelta /= Delta timeZero) $ modifyServer $ \ser ->
    ser {sactorTime = ageActor (bfid tb) (blid tb) target tdelta
                      $ sactorTime ser}

updateCalm :: MonadServerAtomic m => ActorId -> Int64 -> m ()
updateCalm target deltaCalm = do
  tb <- getsState $ getActorBody target
  actorMaxSk <- getsState $ getActorMaxSkills target
  let calmMax64 = xM $ Ability.getSk Ability.SkMaxCalm actorMaxSk
  execUpdAtomic $ UpdRefillCalm target deltaCalm
  when (bcalm tb < calmMax64
        && bcalm tb + deltaCalm >= calmMax64) $
    return ()
    -- We don't dominate the actor here, because if so, players would
    -- disengage after one of their actors is dominated and wait for him
    -- to regenerate Calm. This is unnatural and boring. Better fight
    -- and hope he gets his Calm again to 0 and then defects back.
    -- We could instead tell here that Calm is fully regenerated,
    -- but that would be too verbose.

leadLevelSwitch :: MonadServerAtomic m => m ()
leadLevelSwitch = do
  COps{cocave} <- getsState scops
  factionD <- getsState sfactionD
  -- Leader switching between levels can be done by the client
  -- (e.g,. UI client of the human) or by the server
  -- (the frequency of leader level switching done by the server
  -- is controlled by @RuleKind.rleadLevelClips@). Regardless, the server
  -- alwayw does a subset of the switching, e.g., when the old leader dies
  -- and no other actor of the faction resides on his level.
  -- Here we check if the server is permitted to handle the mundane cases.
  let serverMaySwitch fact =
        bannedPointmanSwitchBetweenLevels fact
          -- client banned from switching, so the sever has to step in
        || gunderAI fact
             -- a hack to help AI, until AI client can switch levels
      flipFaction (_, fact) | not $ serverMaySwitch fact = return ()
      flipFaction (fid, fact) =
        case gleader fact of
          Nothing -> return ()
          Just leader -> do
            body <- getsState $ getActorBody leader
            let !_A = assert (fid == bfid body) ()
            s <- getsServer $ (EM.! fid) . sclientStates
            let leaderStuck = actorWaits body
                lvlsRaw =
                  [ ((lid, lvl), (allSeen, as))
                  | (lid, lvl) <- EM.assocs $ sdungeon s
                  , lid /= blid body || not leaderStuck
                  , let asRaw = -- Drama levels ignored, hence @Regular@.
                                fidActorRegularAssocs fid lid s
                        isAlert (_, b) = case bwatch b of
                          WWatch -> True
                          WWait n -> n == 0
                          WSleep -> False
                          WWake -> True  -- probably in danger
                        (alert, relaxed) = partition isAlert asRaw
                        as = alert ++ relaxed  -- best switch leader to alert
                  , not (null as)
                  , let allSeen =
                          lexpl lvl <= lseen lvl
                          || CK.cactorCoeff (okind cocave $ lkind lvl) > 150
                             && not (fhasGender $ gkind fact)
                  ]
                (lvlsSeen, lvlsNotSeen) = partition (fst . snd) lvlsRaw
                -- Monster AI changes leadership mostly to move from level
                -- to level and, in particular, to quickly bring troops
                -- to the frontline level and so prevent human from killing
                -- monsters at numerical advantage.
                -- However, an AI boss that can't move between levels
                -- disrupts this by hogging leadership. To prevent that,
                -- assuming the boss resides below the frontline level,
                -- only the two shallowest levels that are not yet fully
                -- explored are considered to choose the new leader from.
                -- This frontier moves as the levels are explored or emptied
                -- and sometimes the level with the boss is counted among
                -- them, but it never happens in the crucial periods when
                -- AI armies are transferred from level to level.
                f ((_, lvl), _) = ldepth lvl
                lvls = lvlsSeen ++ take 2 (sortBy (comparing f) lvlsNotSeen)
            -- Actors on desolate levels (not many own or enemy non-projectiles)
            -- tend to become (or stay) leaders so that they can join the main
            -- force where it matters ASAP. Unfortunately, this keeps hero
            -- scouts as leader, but foes spawn very fast early on ,
            -- so they give back leadership rather quickly to let others follow.
            -- We count non-mobile and sleeping actors, because they may
            -- be dangerous, especially if adjacent to stairs.
            let overOwnStash b = Just (blid b, bpos b) == gstash fact
                freqList = [ (k, (lid, aid))
                           | ((lid, lvl), (_, (aid, b) : rest)) <- lvls
                           , let len = min 20 (EM.size $ lbig lvl)
                                 n = 1000000 `div` (1 + len)
                                 -- Visit the stash guard rarely, but not too
                                 -- rarely, to regen Calm and fling at foes.
                                 k = max 1 $ if null rest && overOwnStash b
                                             then n `div` 30
                                             else n
                           ]
                closeToFactStash (fid2, fact2) = case gstash fact2 of
                  Just (lid, pos) ->
                    (fid == fid2 || isFoe fid (factionD EM.! fid) fid2)
                    && lid == blid body
                    && chessDist pos (bpos body) == 1  -- visible
                  Nothing -> False
                closeToEnemyStash = any closeToFactStash $ EM.assocs factionD
            foes <- getsState $ foeRegularList fid (blid body)
            ours <- getsState $ map snd
                                <$> fidActorRegularAssocs fid (blid body)
            let foesClose = filter (\b -> chessDist (bpos body) (bpos b) <= 2)
                                   foes
                oursCloseMelee =
                  filter (\b -> chessDist (bpos body) (bpos b) <= 2
                                && bweapon b - bweapBenign b > 0)
                         ours
                canHelpMelee =
                  not leaderStuck
                  && length oursCloseMelee >= 2
                  && not (null foesClose)
                  && not (all (\b -> any (adjacent (bpos b) . bpos) foes)
                              oursCloseMelee)
            unless (closeToEnemyStash || canHelpMelee || null freqList) $ do
              (lid, a) <- rndToAction $ frequency
                                      $ toFreq "leadLevel" freqList
              unless (lid == blid body) $  -- flip levels rather than actors
                setFreshLeader fid a
  mapM_ flipFaction $ EM.assocs factionD

-- | Continue or exit or restart the game.
endOrLoop :: (MonadServerAtomic m, MonadServerComm m)
          => m () -> (Maybe (GroupName ModeKind) -> m ())
          -> m ()
{-# INLINE endOrLoop #-}
endOrLoop loop restart = do
  factionD <- getsState sfactionD
  let inGame fact = case gquit fact of
        Nothing -> True
        Just Status{stOutcome=Camping} -> True
        _ -> False
      gameOver = not $ any inGame $ EM.elems factionD
  let getQuitter fact = case gquit fact of
        Just Status{stOutcome=Restart, stNewGame} -> stNewGame
        _ -> Nothing
      quitters = mapMaybe getQuitter $ EM.elems factionD
      restartNeeded = gameOver || not (null quitters)
  let isCamper fact = case gquit fact of
        Just Status{stOutcome=Camping} -> True
        _ -> False
      campers = filter (isCamper . snd) $ EM.assocs factionD
  -- Wipe out the quit flag for the savegame files.
  mapM_ (\(fid, fact) ->
    execUpdAtomic $ UpdQuitFaction fid (gquit fact) Nothing Nothing) campers
  swriteSave <- getsServer swriteSave
  sstopAfterGameOver <-
    getsServer $ sstopAfterGameOver . soptions
  when swriteSave $ do
    modifyServer $ \ser -> ser {swriteSave = False}
    writeSaveAll True False
  if | gameOver && sstopAfterGameOver -> gameExit
     | restartNeeded -> restart (listToMaybe quitters)
     | not $ null campers -> gameExit  -- and @loop@ is not called
     | otherwise -> loop  -- continue current game

gameExit :: (MonadServerAtomic m, MonadServerComm m) => m ()
gameExit = do
--  debugPossiblyPrint "Server: Verifying all perceptions."
  -- Verify that the possibly not saved caches are equal to future
  -- reconstructed. Otherwise, save/restore would change game state.
  -- This is done even in released binaries, because it only prolongs
  -- game shutdown a bit. The same checks at each periodic game save
  -- would icrease the game saving lag, so they are normally avoided.
  verifyCaches
  -- Kill all clients, including those that did not take part
  -- in the current game.
  -- Clients exit not now, but after they print all ending screens.
--  debugPossiblyPrint "Server: Killing all clients."
  killAllClients
--  debugPossiblyPrint "Server: All clients killed."
  return ()