{-# LANGUAGE TupleSections #-}
-- | Server operations common to many modules.
module Game.LambdaHack.Server.CommonM
  ( revealItems, moveStores, generalMoveItem
  , deduceQuits, deduceKilled, electLeader, setFreshLeader
  , updatePer, recomputeCachePer, projectFail
  , addActorFromGroup, registerActor, discoverIfMinorEffects
  , pickWeaponServer, currentSkillsServer, allGroupItems
  , addCondition, removeConditionSingle, addSleep, removeSleepSingle
  , addKillToAnalytics
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , containerMoveItem, quitF, keepArenaFact, anyActorsAlive, projectBla
  , addProjectile, addActorIid, getCacheLucid, getCacheTotal
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import qualified Data.EnumMap.Strict as EM
import qualified Data.Ord as Ord
import           Data.Ratio

import           Game.LambdaHack.Atomic
import           Game.LambdaHack.Client (ClientOptions (..))
import           Game.LambdaHack.Common.Actor
import           Game.LambdaHack.Common.ActorState
import           Game.LambdaHack.Common.Analytics
import           Game.LambdaHack.Common.Faction
import           Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.ItemAspect as IA
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.ReqFailure
import           Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import           Game.LambdaHack.Common.Time
import           Game.LambdaHack.Common.Types
import           Game.LambdaHack.Content.ItemKind (ItemKind)
import qualified Game.LambdaHack.Content.ItemKind as IK
import           Game.LambdaHack.Content.ModeKind
import           Game.LambdaHack.Content.RuleKind
import           Game.LambdaHack.Common.Point
import           Game.LambdaHack.Core.Random
import qualified Game.LambdaHack.Definition.Ability as Ability
import           Game.LambdaHack.Definition.Defs
import           Game.LambdaHack.Server.Fov
import           Game.LambdaHack.Server.ItemM
import           Game.LambdaHack.Server.ItemRev
import           Game.LambdaHack.Server.MonadServer
import           Game.LambdaHack.Server.ServerOptions
import           Game.LambdaHack.Server.State

revealItems :: MonadServerAtomic m => FactionId -> m ()
revealItems fid = do
  COps{coitem} <- getsState scops
  ServerOptions{sclientOptions} <- getsServer soptions
  discoAspect <- getsState sdiscoAspect
  let discover aid store iid _ = do
        itemKindId <- getsState $ getIidKindIdServer iid
        let arItem = discoAspect EM.! iid
            c = CActor aid store
            itemKind = okind coitem itemKindId
        unless (IA.isHumanTrinket itemKind) $  -- a hack
          execUpdAtomic $ UpdDiscover c iid itemKindId arItem
      f (aid, b) =
        -- CSha is IDed for each actor of each faction, which is fine,
        -- even though it may introduce a slight lag at gameover.
        join $ getsState $ mapActorItems_ (discover aid) b
  -- Don't ID projectiles, their items are not really owned by the party.
  aids <- getsState $ fidActorNotProjGlobalAssocs fid
  mapM_ f aids
  dungeon <- getsState sdungeon
  let minLid = fst $ minimumBy (Ord.comparing (ldepth . snd))
                   $ EM.assocs dungeon
      discoverSample iid = do
        itemKindId <- getsState $ getIidKindIdServer iid
        let arItem = discoAspect EM.! iid
            cdummy = CTrunk fid minLid originPoint  -- only @fid@ matters here
            itemKind = okind coitem itemKindId
        unless (IA.isHumanTrinket itemKind) $  -- a hack
          execUpdAtomic $ UpdDiscover cdummy iid itemKindId arItem
  generationAn <- getsServer sgenerationAn
  getKindId <- getsState $ flip getIidKindIdServer
  let kindsEqual iid iid2 = getKindId iid == getKindId iid2 && iid /= iid2
      nonDupSample em iid 0 = not $ any (kindsEqual iid) $ EM.keys em
      nonDupSample _ _ _ = True
      nonDupGen = EM.map (\em -> EM.filterWithKey (nonDupSample em) em)
                         generationAn
  -- Remove samples that are supplanted by real items.
  -- If there are mutliple UI factions, the second run will be vacuus,
  -- but it's important to do that before the first try to identify things
  -- to prevent spam from identifying samples that are not needed.
  modifyServer $ \ser -> ser {sgenerationAn = nonDupGen}
  when (sexposeActors sclientOptions) $
    -- Few, if any, need ID, but we can't rule out unusual content.
    mapM_ discoverSample $ EM.keys $ nonDupGen EM.! STrunk
  when (sexposeItems sclientOptions) $
    mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SItem
  mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SEmbed
  mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SOrgan
  mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SCondition
  mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SBlast

moveStores :: MonadServerAtomic m
           => Bool -> ActorId -> CStore -> CStore -> m ()
moveStores verbose aid fromStore toStore = do
  b <- getsState $ getActorBody aid
  let g iid (k, _) = do
        move <- generalMoveItem verbose iid k (CActor aid fromStore)
                                              (CActor aid toStore)
        mapM_ execUpdAtomic move
  mapActorCStore_ fromStore g b

-- | Generate the atomic updates that jointly perform a given item move.
generalMoveItem :: MonadStateRead m
                => Bool -> ItemId -> Int -> Container -> Container
                -> m [UpdAtomic]
generalMoveItem _ iid k (CActor aid1 cstore1) (CActor aid2 cstore2)
  | aid1 == aid2 && cstore1 /= CSha && cstore2 /= CSha
  = return [UpdMoveItem iid k aid1 cstore1 cstore2]
generalMoveItem verbose iid k c1 c2 = containerMoveItem verbose iid k c1 c2

containerMoveItem :: MonadStateRead m
                  => Bool -> ItemId -> Int -> Container -> Container
                  -> m [UpdAtomic]
containerMoveItem verbose iid k c1 c2 = do
  bag <- getsState $ getContainerBag c1
  case iid `EM.lookup` bag of
    Nothing -> error $ "" `showFailure` (iid, k, c1, c2)
    Just (_, it) -> do
      item <- getsState $ getItemBody iid
      return [ UpdLoseItem verbose iid item (k, take k it) c1
             , UpdSpotItem verbose iid item (k, take k it) c2 ]

quitF :: MonadServerAtomic m => Status -> FactionId -> m ()
quitF status fid = do
  fact <- getsState $ (EM.! fid) . sfactionD
  let oldSt = gquit fact
  -- Note that it's the _old_ status that we check here.
  case stOutcome <$> oldSt of
    Just Killed -> return ()    -- Do not overwrite in case
    Just Defeated -> return ()  -- many things happen in 1 turn.
    Just Conquer -> return ()
    Just Escape -> return ()
    _ -> do
      -- This runs regardless of the _new_ status.
      manalytics <-
        if fhasUI $ gplayer fact then do
          keepAutomated <- getsServer $ skeepAutomated . soptions
          -- Try to remove AI control of the UI faction, to show endgame info.
          when (isAIFact fact
                && fleaderMode (gplayer fact) /= LeaderNull
                && not keepAutomated) $
            execUpdAtomic $ UpdAutoFaction fid False
          itemD <- getsState sitemD
          dungeon <- getsState sdungeon
          let ais = EM.assocs itemD
              minLid = fst $ minimumBy (Ord.comparing (ldepth . snd))
                           $ EM.assocs dungeon
          execUpdAtomic $ UpdSpotItemBag (CTrunk fid minLid originPoint)
                                         EM.empty ais
          revealItems fid
          -- Likely, by this time UI faction is no longer AI-controlled,
          -- so the score will get registered.
          registerScore status fid
          factionAn <- getsServer sfactionAn
          generationAn <- getsServer sgenerationAn
          return $ Just (factionAn, generationAn)
        else return Nothing
      execUpdAtomic $ UpdQuitFaction fid oldSt (Just status) manalytics
      modifyServer $ \ser -> ser {sbreakLoop = True}  -- check game over

-- Send any UpdQuitFaction actions that can be deduced from factions'
-- current state.
deduceQuits :: MonadServerAtomic m => FactionId -> Status -> m ()
deduceQuits fid0 status@Status{stOutcome}
  | stOutcome `elem` [Defeated, Camping, Restart, Conquer] =
    error $ "no quitting to deduce" `showFailure` (fid0, status)
deduceQuits fid0 status = do
  fact0 <- getsState $ (EM.! fid0) . sfactionD
  let factHasUI = fhasUI . gplayer
      quitFaction (stOutcome, (fid, _)) = quitF status{stOutcome} fid
      mapQuitF outfids = do
        let (withUI, withoutUI) =
              partition (factHasUI . snd . snd)
                        ((stOutcome status, (fid0, fact0)) : outfids)
        mapM_ quitFaction (withoutUI ++ withUI)
      inGameOutcome (fid, fact) = do
        let mout | fid == fid0 = Just $ stOutcome status
                 | otherwise = stOutcome <$> gquit fact
        case mout of
          Just Killed -> False
          Just Defeated -> False
          Just Restart -> False  -- effectively, commits suicide
          _ -> True
  factionD <- getsState sfactionD
  let assocsInGame = filter inGameOutcome $ EM.assocs factionD
      assocsKeepArena = filter (keepArenaFact . snd) assocsInGame
      assocsUI = filter (factHasUI . snd) assocsInGame
      nonHorrorAIG = filter (not . isHorrorFact . snd) assocsInGame
      worldPeace =
        all (\(fid1, _) -> all (\(fid2, fact2) -> not $ isFoe fid2 fact2 fid1)
                           nonHorrorAIG)
        nonHorrorAIG
      othersInGame = filter ((/= fid0) . fst) assocsInGame
  if | null assocsUI ->
       -- Only non-UI players left in the game and they all win.
       mapQuitF $ zip (repeat Conquer) othersInGame
     | null assocsKeepArena ->
       -- Only leaderless and spawners remain (the latter may sometimes
       -- have no leader, just as the former), so they win,
       -- or we could get stuck in a state with no active arena
       -- and so no spawns.
       mapQuitF $ zip (repeat Conquer) othersInGame
     | worldPeace ->
       -- Nobody is at war any more, so all win (e.g., horrors, but never mind).
       mapQuitF $ zip (repeat Conquer) othersInGame
     | stOutcome status == Escape -> do
       -- Otherwise, in a game with many warring teams alive,
       -- only complete Victory matters, until enough of them die.
       let (victors, losers) =
             partition (\(fi, _) -> isFriend fid0 fact0 fi) othersInGame
       mapQuitF $ zip (repeat Escape) victors ++ zip (repeat Defeated) losers
     | otherwise -> quitF status fid0

-- | Tell whether a faction that we know is still in game, keeps arena.
-- Keeping arena means, if the faction is still in game,
-- it always has a leader in the dungeon somewhere.
-- So, leaderless factions and spawner factions do not keep an arena,
-- even though the latter usually has a leader for most of the game.
keepArenaFact :: Faction -> Bool
keepArenaFact fact = fleaderMode (gplayer fact) /= LeaderNull
                     && fneverEmpty (gplayer fact)

-- We assume the actor in the second argument has HP <= 0 or is going to be
-- dominated right now. Even if the actor is to be dominated,
-- @bfid@ of the actor body is still the old faction.
deduceKilled :: MonadServerAtomic m => ActorId -> m ()
deduceKilled aid = do
  body <- getsState $ getActorBody aid
  fact <- getsState $ (EM.! bfid body) . sfactionD
  when (fneverEmpty $ gplayer fact) $ do
    actorsAlive <- anyActorsAlive (bfid body) aid
    when (not actorsAlive) $
      deduceQuits (bfid body) $ Status Killed (fromEnum $ blid body) Nothing

anyActorsAlive :: MonadServer m => FactionId -> ActorId -> m Bool
anyActorsAlive fid aid = do
  as <- getsState $ fidActorNotProjGlobalAssocs fid
  -- We test HP here, in case more than one actor goes to 0 HP in the same turn.
  return $! any (\(aid2, b2) -> aid2 /= aid && bhp b2 > 0) as

electLeader :: MonadServerAtomic m => FactionId -> LevelId -> ActorId -> m ()
electLeader fid lid aidToReplace = do
  mleader <- getsState $ gleader . (EM.! fid) . sfactionD
  when (mleader == Just aidToReplace) $ do
    allOurs <- getsState $ fidActorNotProjGlobalAssocs fid  -- not only on level
    let -- Prefer actors on this level and with positive HP and not sleeping.
        -- Exclude @aidToReplace@, even if not dead (e.g., if being dominated).
        (positive, negative) = partition (\(_, b) -> bhp b > 0) allOurs
        (awake, sleeping) = partition (\(_, b) -> bwatch b /= WSleep) positive
    onThisLevel <- getsState $ fidActorRegularAssocs fid lid
    let candidates = filter (\(_, b) -> bwatch b /= WSleep) onThisLevel
                     ++ awake ++ sleeping ++ negative
        mleaderNew =
          listToMaybe $ filter (/= aidToReplace) $ map fst $ candidates
    execUpdAtomic $ UpdLeadFaction fid mleader mleaderNew

setFreshLeader :: MonadServerAtomic m => FactionId -> ActorId -> m ()
setFreshLeader fid aid = do
  fact <- getsState $ (EM.! fid) . sfactionD
  unless (fleaderMode (gplayer fact) == LeaderNull) $ do
    -- First update and send Perception so that the new leader
    -- may report his environment.
    b <- getsState $ getActorBody aid
    let !_A = assert (not $ bproj b) ()
    valid <- getsServer $ (EM.! blid b) . (EM.! fid) . sperValidFid
    unless valid $ updatePer fid (blid b)
    execUpdAtomic $ UpdLeadFaction fid (gleader fact) (Just aid)

updatePer :: MonadServerAtomic m => FactionId -> LevelId -> m ()
{-# INLINE updatePer #-}
updatePer fid lid = do
  modifyServer $ \ser ->
    ser {sperValidFid = EM.adjust (EM.insert lid True) fid $ sperValidFid ser}
  sperFidOld <- getsServer sperFid
  let perOld = sperFidOld EM.! fid EM.! lid
  -- Performed in the State after action, e.g., with a new actor.
  perNew <- recomputeCachePer fid lid
  let inPer = diffPer perNew perOld
      outPer = diffPer perOld perNew
  unless (nullPer outPer && nullPer inPer) $
    execSendPer fid lid outPer inPer perNew

recomputeCachePer :: MonadServer m => FactionId -> LevelId -> m Perception
recomputeCachePer fid lid = do
  total <- getCacheTotal fid lid
  fovLucid <- getCacheLucid lid
  let perNew = perceptionFromPTotal fovLucid total
      fper = EM.adjust (EM.insert lid perNew) fid
  modifyServer $ \ser -> ser {sperFid = fper $ sperFid ser}
  return perNew

-- The missile item is removed from the store only if the projection
-- went into effect (no failure occured).
projectFail :: MonadServerAtomic m
            => ActorId    -- ^ actor causing the projection
            -> ActorId    -- ^ actor projecting the item (is on current lvl)
            -> Point      -- ^ target position of the projectile
            -> Int        -- ^ digital line parameter
            -> Bool       -- ^ whether to start at the source position
            -> ItemId     -- ^ the item to be projected
            -> CStore     -- ^ whether the items comes from floor or inventory
            -> Bool       -- ^ whether the item is a blast
            -> m (Maybe ReqFailure)
projectFail propeller source tpxy eps center iid cstore blast = do
  COps{corule=RuleContent{rXmax, rYmax}, coTileSpeedup} <- getsState scops
  sb <- getsState $ getActorBody source
  let lid = blid sb
      spos = bpos sb
  lvl <- getLevel lid
  case bla rXmax rYmax eps spos tpxy of
    Nothing -> return $ Just ProjectAimOnself
    Just [] -> error $ "projecting from the edge of level"
                       `showFailure` (spos, tpxy)
    Just (pos : restUnlimited) -> do
      bag <- getsState $ getBodyStoreBag sb cstore
      case EM.lookup iid bag of
        Nothing -> return $ Just ProjectOutOfReach
        Just _kit -> do
          itemFull <- getsState $ itemToFull iid
          actorSk <- currentSkillsServer source
          actorMaxSk <- getsState $ getActorMaxSkills source
          let skill = Ability.getSk Ability.SkProject actorSk
              forced = blast || bproj sb
              calmE = calmEnough sb actorMaxSk
              legal = permittedProject forced skill calmE itemFull
              arItem = aspectRecordFull itemFull
          case legal of
            Left reqFail -> return $ Just reqFail
            Right _ -> do
              let lobable = IA.checkFlag Ability.Lobable arItem
                  rest = if lobable
                         then take (chessDist spos tpxy - 1) restUnlimited
                         else restUnlimited
                  t = lvl `at` pos
              if | not $ Tile.isWalkable coTileSpeedup t ->
                   return $ Just ProjectBlockTerrain
                 | occupiedBigLvl pos lvl ->
                   if blast && bproj sb then do
                      -- Hit the blocking actor.
                      projectBla propeller source spos (pos:rest)
                                 iid cstore blast
                      return Nothing
                   else return $ Just ProjectBlockActor
                 | otherwise -> do
                   -- Make the explosion less regular and weaker at edges.
                   if blast && bproj sb && center then
                     -- Start in the center, not around.
                     projectBla propeller source spos (pos:rest)
                                iid cstore blast
                   else
                     projectBla propeller source pos rest iid cstore blast
                   return Nothing

projectBla :: MonadServerAtomic m
           => ActorId    -- ^ actor causing the projection
           -> ActorId    -- ^ actor projecting the item (is on current lvl)
           -> Point      -- ^ starting point of the projectile
           -> [Point]    -- ^ rest of the trajectory of the projectile
           -> ItemId     -- ^ the item to be projected
           -> CStore     -- ^ whether the items comes from floor or inventory
           -> Bool       -- ^ whether the item is a blast
           -> m ()
projectBla propeller source pos rest iid cstore blast = do
  sb <- getsState $ getActorBody source
  let lid = blid sb
  localTime <- getsState $ getLocalTime lid
  unless blast $ execSfxAtomic $ SfxProject source iid cstore
  bag <- getsState $ getBodyStoreBag sb cstore
  ItemFull{itemBase, itemKind} <- getsState $ itemToFull iid
  case iid `EM.lookup` bag of
    Nothing -> error $ "" `showFailure` (source, pos, rest, iid, cstore)
    Just kit@(_, it) -> do
      let delay =
            if IK.iweight itemKind == 0
            then timeTurn  -- big delay at start, e.g., to easily read hologram
            else timeZero  -- avoid running into own projectiles
          btime = absoluteTimeAdd delay localTime
      addProjectile propeller pos rest iid kit lid (bfid sb) btime
      let c = CActor source cstore
      execUpdAtomic $ UpdLoseItem False iid itemBase (1, take 1 it) c

addActorFromGroup :: MonadServerAtomic m
                  => GroupName ItemKind -> FactionId -> Point -> LevelId -> Time
                  -> m (Maybe ActorId)
addActorFromGroup actorGroup bfid pos lid time = 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.
  freq <- prepareItemKind 0 lid [(actorGroup, 1)]
  m2 <- rollItemAspect freq lid
  case m2 of
    Nothing -> return Nothing
    Just (itemKnown, itemFullKit) ->
      Just <$> registerActor False itemKnown itemFullKit bfid pos lid time

registerActor :: MonadServerAtomic m
              => Bool -> ItemKnown -> ItemFullKit
              -> FactionId -> Point -> LevelId -> Time
              -> m ActorId
registerActor summoned (ItemKnown kindIx ar _) (itemFullRaw, kit)
              bfid pos lid time = do
  let container = CTrunk bfid lid pos
      jfid = Just bfid
      itemKnown = ItemKnown kindIx ar jfid
      itemFull = itemFullRaw {itemBase = (itemBase itemFullRaw) {jfid}}
  trunkId <- registerItem (itemFull, kit) itemKnown container False
  aid <- addNonProjectile summoned trunkId (itemFull, kit) bfid pos lid time
  fact <- getsState $ (EM.! bfid) . sfactionD
  actorMaxSk <- getsState $ getActorMaxSkills aid
  condAnyFoeAdj <- getsState $ anyFoeAdj aid
  when (canSleep actorMaxSk &&
        not condAnyFoeAdj
        && not summoned
        && not (fhasGender (gplayer fact))) $ do  -- heroes never start asleep
    let sleepOdds = if prefersSleep actorMaxSk then 9%10 else 1%2
    sleeps <- rndToAction $ chance sleepOdds
    when sleeps $ addSleep aid
  return aid

addProjectile :: MonadServerAtomic m
              => ActorId -> Point -> [Point] -> ItemId -> ItemQuant -> LevelId
              -> FactionId -> Time
              -> m ()
addProjectile propeller pos rest iid (_, it) lid fid time = do
  itemFull <- getsState $ itemToFull iid
  let arItem = aspectRecordFull itemFull
      IK.ThrowMod{IK.throwHP} = IA.aToThrow arItem
      (trajectory, (speed, _)) =
        IA.itemTrajectory arItem (itemKind itemFull) (pos : rest)
      -- Trunk is added to equipment, not to organs, because it's the
      -- projected item, so it's carried, not grown.
      tweakBody b = b { bhp = xM throwHP
                      , btrajectory = Just (trajectory, speed)
                      , beqp = EM.singleton iid (1, take 1 it) }
  aid <- addActorIid iid itemFull True fid pos lid tweakBody
  bp <- getsState $ getActorBody propeller
  -- If propeller is a projectile, it may produce other projectiles, e.g.,
  -- by exploding, so it's not voluntary, so others are to blame.
  -- However, we can't easily see whether a pushed non-projectile actor
  -- produced a projectile due to colliding or voluntarily, so we assign
  -- blame to him.
  originator <- if bproj bp
                then getsServer $ EM.findWithDefault propeller propeller
                                  . strajPushedBy
                else return propeller
  modifyServer $ \ser ->
    ser { strajTime = updateActorTime fid lid aid time $ strajTime ser
        , strajPushedBy = EM.insert aid originator $ strajPushedBy ser }

addNonProjectile :: MonadServerAtomic m
                 => Bool -> ItemId -> ItemFullKit -> FactionId -> Point
                 -> LevelId -> Time
                 -> m ActorId
addNonProjectile summoned trunkId (itemFull, kit) fid pos lid time = do
  let tweakBody b = b { borgan = EM.singleton trunkId kit
                      , bcalm = if summoned
                                then xM 5  -- a tiny buffer before domination
                                else bcalm b }
  aid <- addActorIid trunkId itemFull False fid pos lid tweakBody
  -- We assume actor is never born pushed.
  modifyServer $ \ser ->
    ser {sactorTime = updateActorTime fid lid aid time $ sactorTime ser}
  return aid

addActorIid :: MonadServerAtomic m
            => ItemId -> ItemFull -> Bool -> FactionId -> Point -> LevelId
            -> (Actor -> Actor)
            -> m ActorId
addActorIid trunkId ItemFull{itemBase, itemKind, itemDisco=ItemDiscoFull arItem}
            bproj fid pos lid tweakBody = do
  -- Initial HP and Calm is based only on trunk and ignores organs.
  let trunkMaxHP = max 2 $ IA.getSkill Ability.SkMaxHP arItem
      hp = xM trunkMaxHP `div` 2
      -- Hard to auto-id items that refill Calm, but reduced sight at game
      -- start is more confusing and frustrating:
      calm = xM (max 0 $ IA.getSkill Ability.SkMaxCalm arItem)
  -- Create actor.
  factionD <- getsState sfactionD
  curChalSer <- getsServer $ scurChalSer . soptions
  -- If difficulty is below standard, HP is added to the UI factions,
  -- otherwise HP is added to their enemies.
  -- If no UI factions, their role is taken by the escapees (for testing).
  let diffBonusCoeff = difficultyCoeff $ cdiff curChalSer
      boostFact = not bproj
                  && if diffBonusCoeff > 0
                     then any (fhasUI . gplayer . snd)
                              (filter (\(fi, fa) -> isFriend fi fa fid)
                                      (EM.assocs factionD))
                     else any (fhasUI . gplayer  . snd)
                              (filter (\(fi, fa) -> isFoe fi fa fid)
                                      (EM.assocs factionD))
      finalHP | boostFact = min (xM 899)  -- no more than UI can stand
                                (hp * 2 ^ abs diffBonusCoeff)
              | otherwise = hp
      maxHP = min (finalHP + xM 100) (2 * finalHP)
        -- prevent too high max HP resulting in panic when low HP/max HP ratio
      bonusHP = fromEnum (maxHP `div` oneM) - trunkMaxHP
      healthOrgans = [ (Just bonusHP, ("bonus HP", COrgan))
                     | bonusHP /= 0 && not bproj ]
      b = actorTemplate trunkId finalHP calm pos lid fid bproj
      withTrunk =
        b {bweapon = if IA.checkFlag Ability.Meleeable arItem then 1 else 0}
      bodyTweaked = tweakBody withTrunk
  aid <- getsServer sacounter
  modifyServer $ \ser -> ser {sacounter = succ aid}
  execUpdAtomic $ UpdCreateActor aid bodyTweaked [(trunkId, itemBase)]
  -- Create, register and insert all initial actor items, including
  -- the bonus health organs from difficulty setting.
  forM_ (healthOrgans ++ map (Nothing,) (IK.ikit itemKind))
        $ \(mk, (ikText, cstore)) -> do
    let container = CActor aid cstore
        itemFreq = [(ikText, 1)]
    mIidEtc <- rollAndRegisterItem lid itemFreq container False mk
    case mIidEtc of
      Nothing -> error $ "" `showFailure` (lid, itemFreq, container, mk)
      Just (iid, (itemFull2, _)) ->
        when (cstore /= CGround) $
          -- The items are created in inventory, so won't be picked up,
          -- so we have to discover them now, if eligible.
          discoverIfMinorEffects container iid (itemKindId itemFull2)
  return aid
addActorIid _ _ _ _ _ _ _ = error "addActorIid: server ignorant about an item"

discoverIfMinorEffects :: MonadServerAtomic m
                       => Container -> ItemId -> ContentId ItemKind -> m ()
discoverIfMinorEffects c iid itemKindId = do
  COps{coitem} <- getsState scops
  discoAspect <- getsState sdiscoAspect
  let arItem = discoAspect EM.! iid
      itemKind = okind coitem itemKindId
   -- Otherwise, discover by use when item's effects get activated later on.
  when (IA.onlyMinorEffects arItem itemKind
        && not (IA.isHumanTrinket itemKind)) $
    execUpdAtomic $ UpdDiscover c iid itemKindId arItem

pickWeaponServer :: MonadServer m => ActorId -> m (Maybe (ItemId, CStore))
pickWeaponServer source = do
  eqpAssocs <- getsState $ kitAssocs source [CEqp]
  bodyAssocs <- getsState $ kitAssocs source [COrgan]
  actorSk <- currentSkillsServer source
  sb <- getsState $ getActorBody source
  let kitAssRaw = eqpAssocs ++ bodyAssocs
      forced = bproj sb
      kitAss | forced = kitAssRaw  -- for projectiles, anything is weapon
             | otherwise =
                 filter (IA.checkFlag Ability.Meleeable
                         . aspectRecordFull . fst . snd) kitAssRaw
  -- Server ignores item effects or it would leak item discovery info.
  -- In particular, it even uses weapons that would heal opponent,
  -- and not only in case of projectiles.
  strongest <- pickWeaponM False Nothing kitAss actorSk source
  case strongest of
    [] -> return Nothing
    iis@((maxS, _) : _) -> do
      let maxIis = map snd $ takeWhile ((== maxS) . fst) iis
      (_, (iid, _)) <- rndToAction $ oneOf maxIis
      let cstore = if isJust (lookup iid bodyAssocs) then COrgan else CEqp
      return $ Just (iid, cstore)

-- @MonadStateRead@ would be enough, but the logic is sound only on server.
currentSkillsServer :: MonadServer m => ActorId -> m Ability.Skills
currentSkillsServer aid  = do
  body <- getsState $ getActorBody aid
  fact <- getsState $ (EM.! bfid body) . sfactionD
  let mleader = gleader fact
  getsState $ actorCurrentSkills mleader aid

getCacheLucid :: MonadServer m => LevelId -> m FovLucid
getCacheLucid lid = do
  fovClearLid <- getsServer sfovClearLid
  fovLitLid <- getsServer sfovLitLid
  fovLucidLid <- getsServer sfovLucidLid
  let getNewLucid = getsState $ \s ->
        lucidFromLevel fovClearLid fovLitLid s lid (sdungeon s EM.! lid)
  case EM.lookup lid fovLucidLid of
    Just (FovValid fovLucid) -> return fovLucid
    _ -> do
      newLucid <- getNewLucid
      modifyServer $ \ser ->
        ser {sfovLucidLid = EM.insert lid (FovValid newLucid)
                            $ sfovLucidLid ser}
      return newLucid

getCacheTotal :: MonadServer m => FactionId -> LevelId -> m CacheBeforeLucid
getCacheTotal fid lid = do
  sperCacheFidOld <- getsServer sperCacheFid
  let perCacheOld = sperCacheFidOld EM.! fid EM.! lid
  case ptotal perCacheOld of
    FovValid total -> return total
    FovInvalid -> do
      actorMaxSkills <- getsState sactorMaxSkills
      fovClearLid <- getsServer sfovClearLid
      getActorB <- getsState $ flip getActorBody
      let perActorNew =
            perActorFromLevel (perActor perCacheOld) getActorB
                              actorMaxSkills (fovClearLid EM.! lid)
          -- We don't check if any actor changed, because almost surely one is.
          -- Exception: when an actor is destroyed, but then union differs, too.
          total = totalFromPerActor perActorNew
          perCache = PerceptionCache { ptotal = FovValid total
                                     , perActor = perActorNew }
          fperCache = EM.adjust (EM.insert lid perCache) fid
      modifyServer $ \ser -> ser {sperCacheFid = fperCache $ sperCacheFid ser}
      return total

allGroupItems :: MonadServerAtomic m
              => CStore -> GroupName ItemKind -> ActorId
              -> m [(ItemId, ItemQuant)]
allGroupItems store grp target = do
  b <- getsState $ getActorBody target
  getKind <- getsState $ flip getIidKindServer
  let hasGroup (iid, _) =
        maybe False (> 0) $ lookup grp $ IK.ifreq $ getKind iid
  assocsCStore <- getsState $ EM.assocs . getBodyStoreBag b store
  return $! filter hasGroup assocsCStore

addCondition :: MonadServerAtomic m => GroupName ItemKind -> ActorId -> m ()
addCondition name aid = do
  b <- getsState $ getActorBody aid
  let c = CActor aid COrgan
  mresult <- rollAndRegisterItem (blid b) [(name, 1)] c False Nothing
  assert (isJust mresult) $ return ()

removeConditionSingle :: MonadServerAtomic m
                      => GroupName ItemKind -> ActorId -> m Int
removeConditionSingle name aid = do
  let c = CActor aid COrgan
  is <- allGroupItems COrgan name aid
  case is of
    [(iid, (nAll, itemTimer))] -> do
      itemBase <- getsState $ getItemBody iid
      execUpdAtomic $ UpdLoseItem False iid itemBase (1, itemTimer) c
      return $ nAll - 1
    _ -> error $ "missing or multiple item" `showFailure` (name, is)

addSleep :: MonadServerAtomic m => ActorId -> m ()
addSleep aid = do
  b <- getsState $ getActorBody aid
  addCondition "asleep" aid
  execUpdAtomic $ UpdWaitActor aid (bwatch b) WSleep

removeSleepSingle :: MonadServerAtomic m => ActorId -> m ()
removeSleepSingle aid = do
  nAll <- removeConditionSingle "asleep" aid
  when (nAll == 0) $
    execUpdAtomic $ UpdWaitActor aid WWake WWatch

addKillToAnalytics :: MonadServerAtomic m
                   => ActorId -> KillHow -> FactionId -> ItemId -> m ()
addKillToAnalytics aid killHow fid iid = do
  actorD <- getsState sactorD
  case EM.lookup aid actorD of
    Just b ->
      modifyServer $ \ser ->
        ser { sfactionAn = addFactionKill (bfid b) killHow fid iid
                           $ sfactionAn ser
            , sactorAn = addActorKill aid killHow fid iid
                         $ sactorAn ser }
    Nothing -> return ()  -- killer dead, too late to assign blame
