content: -- | 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 ()
  