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

import Prelude ()

import Game.LambdaHack.Core.Prelude

import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import qualified Data.IntMap.Strict as IM
import           Data.Ratio

import           Game.LambdaHack.Atomic
import           Game.LambdaHack.Common.Actor
import           Game.LambdaHack.Common.ActorState
import           Game.LambdaHack.Common.Analytics
import           Game.LambdaHack.Common.Area
import           Game.LambdaHack.Common.ClientOptions
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.Point
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 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.Core.Random
import qualified Game.LambdaHack.Definition.Ability as Ability
import           Game.LambdaHack.Definition.Defs
import qualified Game.LambdaHack.Definition.DefsInternal as DefsInternal
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 :: forall (m :: * -> *). MonadServerAtomic m => FactionId -> m ()
revealItems FactionId
fid = do
  COps{coitem} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  ServerOptions{sclientOptions} <- getsServer soptions
  discoAspect <- getsState sdiscoAspect
  let keptSecret ItemKind
kind AspectRecord
ar = ItemKind -> Bool
IA.isHumanTrinket ItemKind
kind
                           Bool -> Bool -> Bool
|| Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.MetaGame AspectRecord
ar
      discover ActorId
aid CStore
store ItemId
iid ItemQuant
_ = do
        itemKindId <- (State -> ContentId ItemKind) -> m (ContentId ItemKind)
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ContentId ItemKind) -> m (ContentId ItemKind))
-> (State -> ContentId ItemKind) -> m (ContentId ItemKind)
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> ContentId ItemKind
getIidKindIdServer ItemId
iid
        let arItem = DiscoveryAspect
discoAspect DiscoveryAspect -> ItemId -> AspectRecord
forall k a. Enum k => EnumMap k a -> k -> a
EM.! ItemId
iid
            c = ActorId -> CStore -> Container
CActor ActorId
aid CStore
store
            itemKind = ContentData ItemKind -> ContentId ItemKind -> ItemKind
forall a. ContentData a -> ContentId a -> a
okind ContentData ItemKind
coitem ContentId ItemKind
itemKindId
        unless (keptSecret itemKind arItem) $  -- a hack
          execUpdAtomic $ UpdDiscover c iid itemKindId arItem
      f (ActorId
aid, Actor
b) =
        -- CStash is IDed for each actor of each faction, which is fine,
        -- even though it may introduce a slight lag at gameover.
        m (m ()) -> m ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m ()) -> m ()) -> m (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ (State -> m ()) -> m (m ())
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> m ()) -> m (m ())) -> (State -> m ()) -> m (m ())
forall a b. (a -> b) -> a -> b
$ (CStore -> ItemId -> ItemQuant -> m ()) -> Actor -> State -> m ()
forall (m :: * -> *).
Monad m =>
(CStore -> ItemId -> ItemQuant -> m ()) -> Actor -> State -> m ()
mapActorItems_ (ActorId -> CStore -> ItemId -> ItemQuant -> m ()
discover ActorId
aid) Actor
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 = (LevelId, Level) -> LevelId
forall a b. (a, b) -> a
fst ((LevelId, Level) -> LevelId) -> (LevelId, Level) -> LevelId
forall a b. (a -> b) -> a -> b
$ ((LevelId, Level) -> (LevelId, Level) -> Ordering)
-> [(LevelId, Level)] -> (LevelId, Level)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (((LevelId, Level) -> AbsDepth)
-> (LevelId, Level) -> (LevelId, Level) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Level -> AbsDepth
ldepth (Level -> AbsDepth)
-> ((LevelId, Level) -> Level) -> (LevelId, Level) -> AbsDepth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LevelId, Level) -> Level
forall a b. (a, b) -> b
snd))
                   ([(LevelId, Level)] -> (LevelId, Level))
-> [(LevelId, Level)] -> (LevelId, Level)
forall a b. (a -> b) -> a -> b
$ Dungeon -> [(LevelId, Level)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs Dungeon
dungeon
      discoverSample ItemId
iid = do
        itemKindId <- (State -> ContentId ItemKind) -> m (ContentId ItemKind)
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ContentId ItemKind) -> m (ContentId ItemKind))
-> (State -> ContentId ItemKind) -> m (ContentId ItemKind)
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> ContentId ItemKind
getIidKindIdServer ItemId
iid
        let arItem = DiscoveryAspect
discoAspect DiscoveryAspect -> ItemId -> AspectRecord
forall k a. Enum k => EnumMap k a -> k -> a
EM.! ItemId
iid
            cdummy = FactionId -> LevelId -> Point -> Container
CTrunk FactionId
fid LevelId
minLid Point
originPoint
            itemKind = ContentData ItemKind -> ContentId ItemKind -> ItemKind
forall a. ContentData a -> ContentId a -> a
okind ContentData ItemKind
coitem ContentId ItemKind
itemKindId
        -- Due to @cdummy@, the met and unmet secret things will appear
        -- at gameover among actors in the debug mode. Tough luck.
        execUpdAtomic $ if keptSecret itemKind arItem
                        then UpdSpotItem False iid quantSingle cdummy
                        else UpdDiscover cdummy iid itemKindId arItem
  generationAn <- getsServer sgenerationAn
  getKindId <- getsState $ flip getIidKindIdServer
  let kindsEqual ItemId
iid ItemId
iid2 = ItemId -> ContentId ItemKind
getKindId ItemId
iid ContentId ItemKind -> ContentId ItemKind -> Bool
forall a. Eq a => a -> a -> Bool
== ItemId -> ContentId ItemKind
getKindId ItemId
iid2 Bool -> Bool -> Bool
&& ItemId
iid ItemId -> ItemId -> Bool
forall a. Eq a => a -> a -> Bool
/= ItemId
iid2
      nonDupSample EnumMap ItemId Int
em ItemId
iid Int
0 = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (ItemId -> Bool) -> [ItemId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ItemId -> ItemId -> Bool
kindsEqual ItemId
iid) ([ItemId] -> Bool) -> [ItemId] -> Bool
forall a b. (a -> b) -> a -> b
$ EnumMap ItemId Int -> [ItemId]
forall k a. Enum k => EnumMap k a -> [k]
EM.keys EnumMap ItemId Int
em
      nonDupSample EnumMap ItemId Int
_ ItemId
_ Int
_ = Bool
True
      nonDupGen = (EnumMap ItemId Int -> EnumMap ItemId Int)
-> GenerationAnalytics -> GenerationAnalytics
forall a b k. (a -> b) -> EnumMap k a -> EnumMap k b
EM.map (\EnumMap ItemId Int
em -> (ItemId -> Int -> Bool) -> EnumMap ItemId Int -> EnumMap ItemId Int
forall k a.
Enum k =>
(k -> a -> Bool) -> EnumMap k a -> EnumMap k a
EM.filterWithKey (EnumMap ItemId Int -> ItemId -> Int -> Bool
nonDupSample EnumMap ItemId Int
em) EnumMap ItemId Int
em)
                         GenerationAnalytics
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 $ \StateServer
ser -> StateServer
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) $ do
    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

revealAll :: MonadServerAtomic m => FactionId -> m ()
revealAll :: forall (m :: * -> *). MonadServerAtomic m => FactionId -> m ()
revealAll FactionId
fid = do
  FactionId -> m ()
forall (m :: * -> *). MonadServerAtomic m => FactionId -> m ()
revealItems FactionId
fid
  UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> Bool -> UpdAtomic
UpdMuteMessages FactionId
fid Bool
True
  dungeon <- (State -> Dungeon) -> m Dungeon
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> Dungeon
sdungeon
  -- Perception needs to be sent explicitly, because normal management
  -- assumes an action must happen on a level to invalidate and regenerate
  -- perception on the level (and actors must survive!).
  -- Also, we'd rather hack here and in `verifyCaches` that complicate
  -- the already complex perception creation and caching code.
  mapM_ (revealPerceptionLid fid) $ EM.assocs dungeon
  execUpdAtomic $ UpdMuteMessages fid False

revealPerceptionLid :: MonadServerAtomic m
                    => FactionId -> (LevelId, Level) -> m ()
revealPerceptionLid :: forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> (LevelId, Level) -> m ()
revealPerceptionLid FactionId
fid (LevelId
lid, Level
lvl) = do
  let (Int
x0, Int
y0, Int
x1, Int
y1) = Area -> (Int, Int, Int, Int)
fromArea (Area -> (Int, Int, Int, Int)) -> Area -> (Int, Int, Int, Int)
forall a b. (a -> b) -> a -> b
$ Level -> Area
larea Level
lvl
      fullSet :: EnumSet Point
fullSet = [Point] -> EnumSet Point
forall k. Enum k => [k] -> EnumSet k
ES.fromDistinctAscList [ Int -> Int -> Point
Point Int
x Int
y
                                       | Int
y <- [Int
y0 .. Int
y1]
                                       , Int
x <- [Int
x0 .. Int
x1] ]
      perNew :: Perception
perNew = Perception
        { psight :: PerVisible
psight = EnumSet Point -> PerVisible
PerVisible EnumSet Point
fullSet
        , psmell :: PerSmelled
psmell = EnumSet Point -> PerSmelled
PerSmelled EnumSet Point
forall k. EnumSet k
ES.empty  -- don't obscure
        }
  FactionId -> LevelId -> Perception -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> LevelId -> Perception -> m ()
updatePerFromNew FactionId
fid LevelId
lid Perception
perNew

-- | Generate the atomic updates that jointly perform a given item move.
generalMoveItem :: MonadStateRead m
                => Bool -> ItemId -> Int -> Container -> Container
                -> m [UpdAtomic]
generalMoveItem :: forall (m :: * -> *).
MonadStateRead m =>
Bool -> ItemId -> Int -> Container -> Container -> m [UpdAtomic]
generalMoveItem Bool
_ ItemId
iid Int
k (CActor ActorId
aid1 CStore
cstore1) c2 :: Container
c2@(CActor ActorId
aid2 CStore
cstore2)
  | ActorId
aid1 ActorId -> ActorId -> Bool
forall a. Eq a => a -> a -> Bool
== ActorId
aid2 = do
    moveStash <- Container -> m [UpdAtomic]
forall (m :: * -> *).
MonadStateRead m =>
Container -> m [UpdAtomic]
moveStashIfNeeded Container
c2
    return $! moveStash ++ [UpdMoveItem iid k aid1 cstore1 cstore2]
generalMoveItem Bool
verbose ItemId
iid Int
k Container
c1 Container
c2 = Bool -> ItemId -> Int -> Container -> Container -> m [UpdAtomic]
forall (m :: * -> *).
MonadStateRead m =>
Bool -> ItemId -> Int -> Container -> Container -> m [UpdAtomic]
containerMoveItem Bool
verbose ItemId
iid Int
k Container
c1 Container
c2

containerMoveItem :: MonadStateRead m
                  => Bool -> ItemId -> Int -> Container -> Container
                  -> m [UpdAtomic]
containerMoveItem :: forall (m :: * -> *).
MonadStateRead m =>
Bool -> ItemId -> Int -> Container -> Container -> m [UpdAtomic]
containerMoveItem Bool
verbose ItemId
iid Int
k Container
c1 Container
c2 = do
  bag <- (State -> ItemBag) -> m ItemBag
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ItemBag) -> m ItemBag)
-> (State -> ItemBag) -> m ItemBag
forall a b. (a -> b) -> a -> b
$ Container -> State -> ItemBag
getContainerBag Container
c1
  case iid `EM.lookup` bag of
    Maybe ItemQuant
Nothing -> [Char] -> m [UpdAtomic]
forall a. HasCallStack => [Char] -> a
error ([Char] -> m [UpdAtomic]) -> [Char] -> m [UpdAtomic]
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char] -> (ItemId, Int, Container, Container) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (ItemId
iid, Int
k, Container
c1, Container
c2)
    Just (Int
_, ItemTimers
it) -> do
      moveStash <- Container -> m [UpdAtomic]
forall (m :: * -> *).
MonadStateRead m =>
Container -> m [UpdAtomic]
moveStashIfNeeded Container
c2
      return $ [UpdLoseItem verbose iid (k, take k it) c1]
               ++ moveStash
               ++ [UpdSpotItem verbose iid (k, take k it) c2]

quitF :: MonadServerAtomic m => Status -> FactionId -> m ()
quitF :: forall (m :: * -> *).
MonadServerAtomic m =>
Status -> FactionId -> m ()
quitF Status
status FactionId
fid = do
  fact <- (State -> Faction) -> m Faction
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Faction) -> m Faction)
-> (State -> Faction) -> m Faction
forall a b. (a -> b) -> a -> b
$ (EnumMap FactionId Faction -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid) (EnumMap FactionId Faction -> Faction)
-> (State -> EnumMap FactionId Faction) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EnumMap FactionId Faction
sfactionD
  let oldSt = Faction -> Maybe Status
gquit Faction
fact
  -- Note that it's the _old_ status that we check here.
  case stOutcome <$> oldSt of
    Just Outcome
Killed -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()    -- Do not overwrite in case
    Just Outcome
Defeated -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- many things happen in 1 turn.
    Just Outcome
Conquer -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just Outcome
Escape -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Maybe Outcome
_ -> do
      let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Status -> Outcome
stOutcome Status
status Outcome -> [Outcome] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Outcome
Camping, Outcome
Restart]
                        Bool -> ([Char], (Maybe Outcome, Status, FactionId)) -> Bool
forall v. Show v => Bool -> v -> Bool
`blame` [Char]
"Camping and Restart are handled separately"
                        [Char]
-> (Maybe Outcome, Status, FactionId)
-> ([Char], (Maybe Outcome, Status, FactionId))
forall v. [Char] -> v -> ([Char], v)
`swith` (Status -> Outcome
stOutcome (Status -> Outcome) -> Maybe Status -> Maybe Outcome
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Status
oldSt, Status
status, FactionId
fid)) ()
      -- This runs regardless of the _new_ status.
      manalytics <-
        if FactionKind -> Bool
fhasUI (FactionKind -> Bool) -> FactionKind -> Bool
forall a b. (a -> b) -> a -> b
$ Faction -> FactionKind
gkind Faction
fact then do
          keepAutomated <- (StateServer -> Bool) -> m Bool
forall a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> Bool) -> m Bool)
-> (StateServer -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ ServerOptions -> Bool
skeepAutomated (ServerOptions -> Bool)
-> (StateServer -> ServerOptions) -> StateServer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ServerOptions
soptions
          -- Try to remove AI control of the UI faction, to show gameover info.
          when (gunderAI fact && not keepAutomated) $
            execUpdAtomic $ UpdAutoFaction fid False
          revealAll 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 Maybe (FactionAnalytics, GenerationAnalytics)
-> m (Maybe (FactionAnalytics, GenerationAnalytics))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (FactionAnalytics, GenerationAnalytics)
forall a. Maybe a
Nothing
      execUpdAtomic $ UpdQuitFaction fid oldSt (Just status) manalytics
      modifyServer $ \StateServer
ser -> StateServer
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 :: forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> Status -> m ()
deduceQuits FactionId
fid0 status :: Status
status@Status{Outcome
stOutcome :: Status -> Outcome
stOutcome :: Outcome
stOutcome}
  | Outcome
stOutcome Outcome -> [Outcome] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Outcome
Defeated, Outcome
Camping, Outcome
Restart, Outcome
Conquer] =
    [Char] -> m ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"no quitting to deduce" [Char] -> (FactionId, Status) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (FactionId
fid0, Status
status)
deduceQuits FactionId
fid0 Status
status = do
  fact0 <- (State -> Faction) -> m Faction
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Faction) -> m Faction)
-> (State -> Faction) -> m Faction
forall a b. (a -> b) -> a -> b
$ (EnumMap FactionId Faction -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid0) (EnumMap FactionId Faction -> Faction)
-> (State -> EnumMap FactionId Faction) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EnumMap FactionId Faction
sfactionD
  let factHasUI = FactionKind -> Bool
fhasUI (FactionKind -> Bool)
-> (Faction -> FactionKind) -> Faction -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Faction -> FactionKind
gkind
      quitFaction (Outcome
stOutcome, (FactionId
fid, Faction
_)) = Status -> FactionId -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
Status -> FactionId -> m ()
quitF Status
status{stOutcome} FactionId
fid
      mapQuitF [(Outcome, (FactionId, Faction))]
outfids = do
        let ([(Outcome, (FactionId, Faction))]
withUI, [(Outcome, (FactionId, Faction))]
withoutUI) =
              ((Outcome, (FactionId, Faction)) -> Bool)
-> [(Outcome, (FactionId, Faction))]
-> ([(Outcome, (FactionId, Faction))],
    [(Outcome, (FactionId, Faction))])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Faction -> Bool
factHasUI (Faction -> Bool)
-> ((Outcome, (FactionId, Faction)) -> Faction)
-> (Outcome, (FactionId, Faction))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FactionId, Faction) -> Faction
forall a b. (a, b) -> b
snd ((FactionId, Faction) -> Faction)
-> ((Outcome, (FactionId, Faction)) -> (FactionId, Faction))
-> (Outcome, (FactionId, Faction))
-> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Outcome, (FactionId, Faction)) -> (FactionId, Faction)
forall a b. (a, b) -> b
snd)
                        ((Status -> Outcome
stOutcome Status
status, (FactionId
fid0, Faction
fact0)) (Outcome, (FactionId, Faction))
-> [(Outcome, (FactionId, Faction))]
-> [(Outcome, (FactionId, Faction))]
forall a. a -> [a] -> [a]
: [(Outcome, (FactionId, Faction))]
outfids)
        ((Outcome, (FactionId, Faction)) -> m ())
-> [(Outcome, (FactionId, Faction))] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (Outcome, (FactionId, Faction)) -> m ()
quitFaction ([(Outcome, (FactionId, Faction))]
withoutUI [(Outcome, (FactionId, Faction))]
-> [(Outcome, (FactionId, Faction))]
-> [(Outcome, (FactionId, Faction))]
forall a. [a] -> [a] -> [a]
++ [(Outcome, (FactionId, Faction))]
withUI)
      inGameOutcome (FactionId
fid, Faction
fact) = do
        let mout :: Maybe Outcome
mout | FactionId
fid FactionId -> FactionId -> Bool
forall a. Eq a => a -> a -> Bool
== FactionId
fid0 = Outcome -> Maybe Outcome
forall a. a -> Maybe a
Just (Outcome -> Maybe Outcome) -> Outcome -> Maybe Outcome
forall a b. (a -> b) -> a -> b
$ Status -> Outcome
stOutcome Status
status
                 | Bool
otherwise = Status -> Outcome
stOutcome (Status -> Outcome) -> Maybe Status -> Maybe Outcome
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Faction -> Maybe Status
gquit Faction
fact
        case Maybe Outcome
mout of
          Just Outcome
Killed -> Bool
False
          Just Outcome
Defeated -> Bool
False
          Just Outcome
Restart -> Bool
False  -- effectively, commits suicide
          Maybe Outcome
_ -> Bool
True
  factionD <- getsState sfactionD
  let assocsInGame = ((FactionId, Faction) -> Bool)
-> [(FactionId, Faction)] -> [(FactionId, Faction)]
forall a. (a -> Bool) -> [a] -> [a]
filter (FactionId, Faction) -> Bool
inGameOutcome ([(FactionId, Faction)] -> [(FactionId, Faction)])
-> [(FactionId, Faction)] -> [(FactionId, Faction)]
forall a b. (a -> b) -> a -> b
$ EnumMap FactionId Faction -> [(FactionId, Faction)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs EnumMap FactionId Faction
factionD
      assocsKeepArena = ((FactionId, Faction) -> Bool)
-> [(FactionId, Faction)] -> [(FactionId, Faction)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Faction -> Bool
keepArenaFact (Faction -> Bool)
-> ((FactionId, Faction) -> Faction)
-> (FactionId, Faction)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FactionId, Faction) -> Faction
forall a b. (a, b) -> b
snd) [(FactionId, Faction)]
assocsInGame
      assocsUI = ((FactionId, Faction) -> Bool)
-> [(FactionId, Faction)] -> [(FactionId, Faction)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Faction -> Bool
factHasUI (Faction -> Bool)
-> ((FactionId, Faction) -> Faction)
-> (FactionId, Faction)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FactionId, Faction) -> Faction
forall a b. (a, b) -> b
snd) [(FactionId, Faction)]
assocsInGame
      nonHorrorAIG = ((FactionId, Faction) -> Bool)
-> [(FactionId, Faction)] -> [(FactionId, Faction)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((FactionId, Faction) -> Bool) -> (FactionId, Faction) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Faction -> Bool
isHorrorFact (Faction -> Bool)
-> ((FactionId, Faction) -> Faction)
-> (FactionId, Faction)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FactionId, Faction) -> Faction
forall a b. (a, b) -> b
snd) [(FactionId, Faction)]
assocsInGame
      worldPeace =
        ((FactionId, Faction) -> Bool) -> [(FactionId, Faction)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(FactionId
fid1, Faction
_) -> ((FactionId, Faction) -> Bool) -> [(FactionId, Faction)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(FactionId
fid2, Faction
fact2) -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FactionId -> Faction -> FactionId -> Bool
isFoe FactionId
fid2 Faction
fact2 FactionId
fid1)
                           [(FactionId, Faction)]
nonHorrorAIG)
        [(FactionId, Faction)]
nonHorrorAIG
      othersInGame = ((FactionId, Faction) -> Bool)
-> [(FactionId, Faction)] -> [(FactionId, Faction)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((FactionId -> FactionId -> Bool
forall a. Eq a => a -> a -> Bool
/= FactionId
fid0) (FactionId -> Bool)
-> ((FactionId, Faction) -> FactionId)
-> (FactionId, Faction)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FactionId, Faction) -> FactionId
forall a b. (a, b) -> a
fst) [(FactionId, Faction)]
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 (\(FactionId
fi, Faction
_) -> FactionId -> Faction -> FactionId -> Bool
isFriend FactionId
fid0 Faction
fact0 FactionId
fi) othersInGame
       mapQuitF $ zip (repeat Escape) victors ++ zip (repeat Defeated) losers
     | otherwise -> quitF status fid0

-- | Save game on server and all clients.
writeSaveAll :: MonadServerAtomic m => Bool -> Bool -> m ()
writeSaveAll :: forall (m :: * -> *). MonadServerAtomic m => Bool -> Bool -> m ()
writeSaveAll Bool
uiRequested Bool
evenForNoConfirmGames = do
  bench <- (StateServer -> Bool) -> m Bool
forall a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> Bool) -> m Bool)
-> (StateServer -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ ClientOptions -> Bool
sbenchmark (ClientOptions -> Bool)
-> (StateServer -> ClientOptions) -> StateServer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerOptions -> ClientOptions
sclientOptions (ServerOptions -> ClientOptions)
-> (StateServer -> ServerOptions) -> StateServer -> ClientOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ServerOptions
soptions
  noConfirmsGame <- isNoConfirmsGame
  when (uiRequested
        || not bench && (not noConfirmsGame || evenForNoConfirmGames)) $ do
    execUpdAtomic UpdWriteSave
    saveServer
#ifdef WITH_EXPENSIVE_ASSERTIONS
    -- This check is sometimes repeated in @gameExit@, but we don't care about
    -- speed of shutdown and even more so in WITH_EXPENSIVE_ASSERTIONS mode.
    verifyCaches
#endif

verifyCaches :: MonadServer m => m ()
verifyCaches :: forall (m :: * -> *). MonadServer m => m ()
verifyCaches = do
  sperCacheFid <- (StateServer -> PerCacheFid) -> m PerCacheFid
forall a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> PerCacheFid
sperCacheFid
  sperValidFid <- getsServer sperValidFid
  sactorMaxSkills2 <- getsState sactorMaxSkills
  sfovLucidLid <- getsServer sfovLucidLid
  sfovClearLid <- getsServer sfovClearLid
  sfovLitLid <- getsServer sfovLitLid
  sperFid <- getsServer sperFid
  actorMaxSkills <- getsState maxSkillsInDungeon
  ( fovLitLid, fovClearLid, fovLucidLid
   ,perValidFid, perCacheFid, perFid ) <- getsState perFidInDungeon
  rngs <- getsServer srngs  -- initial display may scroll off terminal memory
  factionD <- getsState sfactionD
  -- Perception off UI faction at game over is illegal (revealed to the player
  -- in 'revealAll'), which is fine, because it's never used.
  -- Don't verify perception in such cases. All the caches from which
  -- legal perception would be created at that point are legal and verified,
  -- which is almost as tight.
  let gameOverUI Faction
fact = FactionKind -> Bool
fhasUI (Faction -> FactionKind
gkind Faction
fact)
                        Bool -> Bool -> Bool
&& Bool -> (Status -> Bool) -> Maybe Status -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((Outcome -> Outcome -> Bool
forall a. Eq a => a -> a -> Bool
/= Outcome
Camping) (Outcome -> Bool) -> (Status -> Outcome) -> Status -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> Outcome
stOutcome) (Faction -> Maybe Status
gquit Faction
fact)
      isGameOverUI = (Faction -> Bool) -> [Faction] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Faction -> Bool
gameOverUI ([Faction] -> Bool) -> [Faction] -> Bool
forall a b. (a -> b) -> a -> b
$ EnumMap FactionId Faction -> [Faction]
forall k a. EnumMap k a -> [a]
EM.elems EnumMap FactionId Faction
factionD
      !_A7 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (FovLitLid
sfovLitLid FovLitLid -> FovLitLid -> Bool
forall a. Eq a => a -> a -> Bool
== FovLitLid
fovLitLid
                     Bool -> ([Char], (FovLitLid, FovLitLid, RNGs)) -> Bool
forall v. Show v => Bool -> v -> Bool
`blame` [Char]
"wrong accumulated sfovLitLid"
                     [Char]
-> (FovLitLid, FovLitLid, RNGs)
-> ([Char], (FovLitLid, FovLitLid, RNGs))
forall v. [Char] -> v -> ([Char], v)
`swith` (FovLitLid
sfovLitLid, FovLitLid
fovLitLid, RNGs
rngs)) ()
      !_A6 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (FovClearLid
sfovClearLid FovClearLid -> FovClearLid -> Bool
forall a. Eq a => a -> a -> Bool
== FovClearLid
fovClearLid
                     Bool -> ([Char], (FovClearLid, FovClearLid, RNGs)) -> Bool
forall v. Show v => Bool -> v -> Bool
`blame` [Char]
"wrong accumulated sfovClearLid"
                     [Char]
-> (FovClearLid, FovClearLid, RNGs)
-> ([Char], (FovClearLid, FovClearLid, RNGs))
forall v. [Char] -> v -> ([Char], v)
`swith` (FovClearLid
sfovClearLid, FovClearLid
fovClearLid, RNGs
rngs)) ()
      !_A5 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (ActorMaxSkills
sactorMaxSkills2 ActorMaxSkills -> ActorMaxSkills -> Bool
forall a. Eq a => a -> a -> Bool
== ActorMaxSkills
actorMaxSkills
                     Bool -> ([Char], (ActorMaxSkills, ActorMaxSkills, RNGs)) -> Bool
forall v. Show v => Bool -> v -> Bool
`blame` [Char]
"wrong accumulated sactorMaxSkills"
                     [Char]
-> (ActorMaxSkills, ActorMaxSkills, RNGs)
-> ([Char], (ActorMaxSkills, ActorMaxSkills, RNGs))
forall v. [Char] -> v -> ([Char], v)
`swith` (ActorMaxSkills
sactorMaxSkills2, ActorMaxSkills
actorMaxSkills, RNGs
rngs)) ()
      !_A4 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (FovLucidLid
sfovLucidLid FovLucidLid -> FovLucidLid -> Bool
forall a. Eq a => a -> a -> Bool
== FovLucidLid
fovLucidLid
                     Bool -> ([Char], (FovLucidLid, FovLucidLid, RNGs)) -> Bool
forall v. Show v => Bool -> v -> Bool
`blame` [Char]
"wrong accumulated sfovLucidLid"
                     [Char]
-> (FovLucidLid, FovLucidLid, RNGs)
-> ([Char], (FovLucidLid, FovLucidLid, RNGs))
forall v. [Char] -> v -> ([Char], v)
`swith` (FovLucidLid
sfovLucidLid, FovLucidLid
fovLucidLid, RNGs
rngs)) ()
      !_A3 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (PerValidFid
sperValidFid PerValidFid -> PerValidFid -> Bool
forall a. Eq a => a -> a -> Bool
== PerValidFid
perValidFid
                     Bool -> ([Char], (PerValidFid, PerValidFid, RNGs)) -> Bool
forall v. Show v => Bool -> v -> Bool
`blame` [Char]
"wrong accumulated sperValidFid"
                     [Char]
-> (PerValidFid, PerValidFid, RNGs)
-> ([Char], (PerValidFid, PerValidFid, RNGs))
forall v. [Char] -> v -> ([Char], v)
`swith` (PerValidFid
sperValidFid, PerValidFid
perValidFid, RNGs
rngs)) ()
      !_A2 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (PerCacheFid
sperCacheFid PerCacheFid -> PerCacheFid -> Bool
forall a. Eq a => a -> a -> Bool
== PerCacheFid
perCacheFid
                     Bool -> ([Char], (PerCacheFid, PerCacheFid, RNGs)) -> Bool
forall v. Show v => Bool -> v -> Bool
`blame` [Char]
"wrong accumulated sperCacheFid"
                     [Char]
-> (PerCacheFid, PerCacheFid, RNGs)
-> ([Char], (PerCacheFid, PerCacheFid, RNGs))
forall v. [Char] -> v -> ([Char], v)
`swith` (PerCacheFid
sperCacheFid, PerCacheFid
perCacheFid, RNGs
rngs)) ()
      !_A1 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool
isGameOverUI Bool -> Bool -> Bool
|| PerFid
sperFid PerFid -> PerFid -> Bool
forall a. Eq a => a -> a -> Bool
== PerFid
perFid
                     Bool -> ([Char], (PerFid, PerFid, RNGs)) -> Bool
forall v. Show v => Bool -> v -> Bool
`blame` [Char]
"wrong accumulated perception"
                     [Char]
-> (PerFid, PerFid, RNGs) -> ([Char], (PerFid, PerFid, RNGs))
forall v. [Char] -> v -> ([Char], v)
`swith` (PerFid
sperFid, PerFid
perFid, RNGs
rngs)) ()
  return ()

-- | 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 :: Faction -> Bool
keepArenaFact Faction
fact = FactionKind -> Bool
fhasPointman (Faction -> FactionKind
gkind Faction
fact) Bool -> Bool -> Bool
&& FactionKind -> Bool
fneverEmpty (Faction -> FactionKind
gkind Faction
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 :: forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
deduceKilled ActorId
aid = do
  body <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
  fact <- getsState $ (EM.! bfid body) . sfactionD
  when (fneverEmpty $ gkind fact) $ do
    actorsAlive <- anyActorsAlive (bfid body) aid
    unless actorsAlive $
      deduceQuits (bfid body) $ Status Killed (fromEnum $ blid body) Nothing

anyActorsAlive :: MonadServer m => FactionId -> ActorId -> m Bool
anyActorsAlive :: forall (m :: * -> *).
MonadServer m =>
FactionId -> ActorId -> m Bool
anyActorsAlive FactionId
fid ActorId
aid = do
  as <- (State -> [(ActorId, Actor)]) -> m [(ActorId, Actor)]
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> [(ActorId, Actor)]) -> m [(ActorId, Actor)])
-> (State -> [(ActorId, Actor)]) -> m [(ActorId, Actor)]
forall a b. (a -> b) -> a -> b
$ FactionId -> State -> [(ActorId, Actor)]
fidActorNotProjGlobalAssocs FactionId
fid
  -- We test HP here, in case more than one actor goes to 0 HP in the same turn.
  return $! any (\(ActorId
aid2, Actor
b2) -> ActorId
aid2 ActorId -> ActorId -> Bool
forall a. Eq a => a -> a -> Bool
/= ActorId
aid Bool -> Bool -> Bool
&& Actor -> Int64
bhp Actor
b2 Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0) as

electLeader :: MonadServerAtomic m => FactionId -> LevelId -> ActorId -> m ()
electLeader :: forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> LevelId -> ActorId -> m ()
electLeader FactionId
fid LevelId
lid ActorId
aidToReplace = do
  mleader <- (State -> Maybe ActorId) -> m (Maybe ActorId)
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Maybe ActorId) -> m (Maybe ActorId))
-> (State -> Maybe ActorId) -> m (Maybe ActorId)
forall a b. (a -> b) -> a -> b
$ Faction -> Maybe ActorId
gleader (Faction -> Maybe ActorId)
-> (State -> Faction) -> State -> Maybe ActorId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnumMap FactionId Faction -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid) (EnumMap FactionId Faction -> Faction)
-> (State -> EnumMap FactionId Faction) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EnumMap FactionId Faction
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 (\(ActorId
_, Actor
b) -> Actor -> Int64
bhp Actor
b Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0) allOurs
        (awake, sleeping) = partition (\(ActorId
_, Actor
b) -> Actor -> Watchfulness
bwatch Actor
b Watchfulness -> Watchfulness -> Bool
forall a. Eq a => a -> a -> Bool
/= Watchfulness
WSleep) positive
    onThisLevel <- getsState $ fidActorRegularAssocs fid lid
    let candidates = ((ActorId, Actor) -> Bool)
-> [(ActorId, Actor)] -> [(ActorId, Actor)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ActorId
_, Actor
b) -> Actor -> Watchfulness
bwatch Actor
b Watchfulness -> Watchfulness -> Bool
forall a. Eq a => a -> a -> Bool
/= Watchfulness
WSleep) [(ActorId, Actor)]
onThisLevel
                     [(ActorId, Actor)] -> [(ActorId, Actor)] -> [(ActorId, Actor)]
forall a. [a] -> [a] -> [a]
++ [(ActorId, Actor)]
awake [(ActorId, Actor)] -> [(ActorId, Actor)] -> [(ActorId, Actor)]
forall a. [a] -> [a] -> [a]
++ [(ActorId, Actor)]
sleeping [(ActorId, Actor)] -> [(ActorId, Actor)] -> [(ActorId, Actor)]
forall a. [a] -> [a] -> [a]
++ [(ActorId, Actor)]
negative
        mleaderNew = (ActorId -> Bool) -> [ActorId] -> Maybe ActorId
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (ActorId -> ActorId -> Bool
forall a. Eq a => a -> a -> Bool
/= ActorId
aidToReplace) ([ActorId] -> Maybe ActorId) -> [ActorId] -> Maybe ActorId
forall a b. (a -> b) -> a -> b
$ ((ActorId, Actor) -> ActorId) -> [(ActorId, Actor)] -> [ActorId]
forall a b. (a -> b) -> [a] -> [b]
map (ActorId, Actor) -> ActorId
forall a b. (a, b) -> a
fst [(ActorId, Actor)]
candidates
    execUpdAtomic $ UpdLeadFaction fid mleader mleaderNew

setFreshLeader :: MonadServerAtomic m => FactionId -> ActorId -> m ()
setFreshLeader :: forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> ActorId -> m ()
setFreshLeader FactionId
fid ActorId
aid = do
  fact <- (State -> Faction) -> m Faction
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Faction) -> m Faction)
-> (State -> Faction) -> m Faction
forall a b. (a -> b) -> a -> b
$ (EnumMap FactionId Faction -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid) (EnumMap FactionId Faction -> Faction)
-> (State -> EnumMap FactionId Faction) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EnumMap FactionId Faction
sfactionD
  when (fhasPointman (gkind fact)) $ do
    -- First update and send Perception so that the new leader
    -- may report his environment.
    b <- getsState $ getActorBody aid
    let !_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Actor -> Bool
bproj Actor
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 ()
updatePer :: forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> LevelId -> m ()
updatePer FactionId
fid LevelId
lid = do
  -- Performed in the State after action, e.g., with a new actor.
  perNew <- FactionId -> LevelId -> m Perception
forall (m :: * -> *).
MonadServer m =>
FactionId -> LevelId -> m Perception
recomputeCachePer FactionId
fid LevelId
lid
  updatePerFromNew fid lid perNew

updatePerFromNew :: MonadServerAtomic m
                 => FactionId -> LevelId -> Perception -> m ()
updatePerFromNew :: forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> LevelId -> Perception -> m ()
updatePerFromNew FactionId
fid LevelId
lid Perception
perNew = do
  -- Even if nothing needed to be done, perception is now validated.
  (StateServer -> StateServer) -> m ()
forall (m :: * -> *).
MonadServer m =>
(StateServer -> StateServer) -> m ()
modifyServer ((StateServer -> StateServer) -> m ())
-> (StateServer -> StateServer) -> m ()
forall a b. (a -> b) -> a -> b
$ \StateServer
ser ->
    StateServer
ser {sperValidFid = EM.adjust (EM.insert lid True) fid $ sperValidFid ser}
  sperFidOld <- (StateServer -> PerFid) -> m PerFid
forall a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> PerFid
sperFid
  let perOld = PerFid
sperFidOld PerFid -> FactionId -> EnumMap LevelId Perception
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid EnumMap LevelId Perception -> LevelId -> Perception
forall k a. Enum k => EnumMap k a -> k -> a
EM.! LevelId
lid
      inPer = Perception -> Perception -> Perception
diffPer Perception
perNew Perception
perOld
      outPer = Perception -> Perception -> Perception
diffPer Perception
perOld Perception
perNew
  unless (nullPer outPer && nullPer inPer) $ do
    -- Perception is modified on the server and sent to the client
    -- together with all the revealed info.
    let fper = (EnumMap LevelId Perception -> EnumMap LevelId Perception)
-> FactionId -> PerFid -> PerFid
forall k a. Enum k => (a -> a) -> k -> EnumMap k a -> EnumMap k a
EM.adjust (LevelId
-> Perception
-> EnumMap LevelId Perception
-> EnumMap LevelId Perception
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert LevelId
lid Perception
perNew) FactionId
fid
    modifyServer $ \StateServer
ser -> StateServer
ser {sperFid = fper $ sperFid ser}
    execSendPer fid lid outPer inPer perNew

recomputeCachePer :: MonadServer m => FactionId -> LevelId -> m Perception
recomputeCachePer :: forall (m :: * -> *).
MonadServer m =>
FactionId -> LevelId -> m Perception
recomputeCachePer FactionId
fid LevelId
lid = do
  total <- FactionId -> LevelId -> m CacheBeforeLucid
forall (m :: * -> *).
MonadServer m =>
FactionId -> LevelId -> m CacheBeforeLucid
getCacheTotal FactionId
fid LevelId
lid
  fovLucid <- getCacheLucid lid
  getsState $ perceptionFromPTotal fid lid fovLucid total

-- 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 level)
            -> Point      -- ^ starting position of the projectile;
                          --   usually, but not always, position of @origin@
            -> Point      -- ^ target position of the projectile
            -> Int        -- ^ digital line parameter
            -> Bool       -- ^ whether to start at the origin's position
            -> ItemId     -- ^ the item to be projected
            -> CStore     -- ^ which store the items comes from
            -> Bool       -- ^ whether the item is a blast
            -> m (Maybe ReqFailure)
projectFail :: forall (m :: * -> *).
MonadServerAtomic m =>
ActorId
-> ActorId
-> Point
-> Point
-> Int
-> Bool
-> ItemId
-> CStore
-> Bool
-> m (Maybe ReqFailure)
projectFail ActorId
propeller ActorId
origin Point
oxy Point
tpxy Int
eps Bool
center ItemId
iid CStore
cstore Bool
blast = do
  COps{coTileSpeedup} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  body <- getsState $ getActorBody origin
  let lid = Actor -> LevelId
blid Actor
body
  lvl <- getLevel lid
  case bresenhamsLineAlgorithm eps oxy tpxy of
    Maybe [Point]
Nothing -> Maybe ReqFailure -> m (Maybe ReqFailure)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ReqFailure -> m (Maybe ReqFailure))
-> Maybe ReqFailure -> m (Maybe ReqFailure)
forall a b. (a -> b) -> a -> b
$ ReqFailure -> Maybe ReqFailure
forall a. a -> Maybe a
Just ReqFailure
ProjectAimOnself
    Just [] -> [Char] -> m (Maybe ReqFailure)
forall a. HasCallStack => [Char] -> a
error ([Char] -> m (Maybe ReqFailure)) -> [Char] -> m (Maybe ReqFailure)
forall a b. (a -> b) -> a -> b
$ [Char]
"projecting from the edge of level"
                       [Char] -> (Point, Point) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (Point
oxy, Point
tpxy)
    Just (Point
pos : [Point]
restUnlimited) -> do
      bag <- (State -> ItemBag) -> m ItemBag
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ItemBag) -> m ItemBag)
-> (State -> ItemBag) -> m ItemBag
forall a b. (a -> b) -> a -> b
$ Actor -> CStore -> State -> ItemBag
getBodyStoreBag Actor
body CStore
cstore
      case EM.lookup iid bag of
        Maybe ItemQuant
Nothing -> Maybe ReqFailure -> m (Maybe ReqFailure)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ReqFailure -> m (Maybe ReqFailure))
-> Maybe ReqFailure -> m (Maybe ReqFailure)
forall a b. (a -> b) -> a -> b
$ ReqFailure -> Maybe ReqFailure
forall a. a -> Maybe a
Just ReqFailure
ProjectOutOfReach
        Just ItemQuant
_kit -> do
          itemFull <- (State -> ItemFull) -> m ItemFull
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ItemFull) -> m ItemFull)
-> (State -> ItemFull) -> m ItemFull
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> ItemFull
itemToFull ItemId
iid
          actorSk <- currentSkillsServer origin
          actorMaxSk <- getsState $ getActorMaxSkills origin
          let skill = Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkProject Skills
actorSk
              forced = Bool
blast Bool -> Bool -> Bool
|| Actor -> Bool
bproj Actor
body
              calmE = Actor -> Skills -> Bool
calmEnough Actor
body Skills
actorMaxSk
              legal = Bool -> Int -> Bool -> ItemFull -> Either ReqFailure Bool
permittedProject Bool
forced Int
skill Bool
calmE ItemFull
itemFull
              arItem = ItemFull -> AspectRecord
aspectRecordFull ItemFull
itemFull
          case legal of
            Left ReqFailure
reqFail -> Maybe ReqFailure -> m (Maybe ReqFailure)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ReqFailure -> m (Maybe ReqFailure))
-> Maybe ReqFailure -> m (Maybe ReqFailure)
forall a b. (a -> b) -> a -> b
$ ReqFailure -> Maybe ReqFailure
forall a. a -> Maybe a
Just ReqFailure
reqFail
            Right Bool
_ -> do
              let lobable :: Bool
lobable = Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Lobable AspectRecord
arItem
                  rest :: [Point]
rest = if Bool
lobable
                         then Int -> [Point] -> [Point]
forall a. Int -> [a] -> [a]
take (Point -> Point -> Int
chessDist Point
oxy Point
tpxy Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Point]
restUnlimited
                         else [Point]
restUnlimited
                  t :: ContentId TileKind
t = Level
lvl Level -> Point -> ContentId TileKind
`at` Point
pos
              if | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ TileSpeedup -> ContentId TileKind -> Bool
Tile.isWalkable TileSpeedup
coTileSpeedup ContentId TileKind
t ->
                   Maybe ReqFailure -> m (Maybe ReqFailure)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ReqFailure -> m (Maybe ReqFailure))
-> Maybe ReqFailure -> m (Maybe ReqFailure)
forall a b. (a -> b) -> a -> b
$ ReqFailure -> Maybe ReqFailure
forall a. a -> Maybe a
Just ReqFailure
ProjectBlockTerrain
                 | Point -> Level -> Bool
occupiedBigLvl Point
pos Level
lvl ->
                   if Bool
blast then do
                     -- Hit the blocking actor by starting the explosion
                     -- particle where the projectile landed, not a step away.
                     -- The same when the spot has the explosive embed,
                     -- regardless if it's walkable (@pos@ is, that's enough).
                     -- No problem even if there's a big actor where
                     -- the projectile starts, though it's wierd it may get
                     -- away unharmed sometimes.
                     ActorId
-> ActorId -> Point -> [Point] -> ItemId -> CStore -> Bool -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId
-> ActorId -> Point -> [Point] -> ItemId -> CStore -> Bool -> m ()
projectBla ActorId
propeller ActorId
origin Point
oxy (Point
posPoint -> [Point] -> [Point]
forall a. a -> [a] -> [a]
:[Point]
rest)
                                ItemId
iid CStore
cstore Bool
blast
                     Maybe ReqFailure -> m (Maybe ReqFailure)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ReqFailure
forall a. Maybe a
Nothing
                   else Maybe ReqFailure -> m (Maybe ReqFailure)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ReqFailure -> m (Maybe ReqFailure))
-> Maybe ReqFailure -> m (Maybe ReqFailure)
forall a b. (a -> b) -> a -> b
$ ReqFailure -> Maybe ReqFailure
forall a. a -> Maybe a
Just ReqFailure
ProjectBlockActor
                 | Bool
otherwise -> do
                   -- Make the explosion less regular and weaker at the edges.
                   if Bool
blast Bool -> Bool -> Bool
&& Bool
center then
                     -- Start in the center, not around, even if the center
                     -- is a non-walkable tile with the exploding embed
                     -- or if a big actor is there.
                     ActorId
-> ActorId -> Point -> [Point] -> ItemId -> CStore -> Bool -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId
-> ActorId -> Point -> [Point] -> ItemId -> CStore -> Bool -> m ()
projectBla ActorId
propeller ActorId
origin Point
oxy (Point
posPoint -> [Point] -> [Point]
forall a. a -> [a] -> [a]
:[Point]
rest)
                                ItemId
iid CStore
cstore Bool
blast
                   else
                     ActorId
-> ActorId -> Point -> [Point] -> ItemId -> CStore -> Bool -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId
-> ActorId -> Point -> [Point] -> ItemId -> CStore -> Bool -> m ()
projectBla ActorId
propeller ActorId
origin Point
pos [Point]
rest
                                ItemId
iid CStore
cstore Bool
blast
                   Maybe ReqFailure -> m (Maybe ReqFailure)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ReqFailure
forall a. Maybe a
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     -- ^ which store the items comes from
           -> Bool       -- ^ whether the item is a blast
           -> m ()
projectBla :: forall (m :: * -> *).
MonadServerAtomic m =>
ActorId
-> ActorId -> Point -> [Point] -> ItemId -> CStore -> Bool -> m ()
projectBla ActorId
propeller ActorId
origin Point
pos [Point]
rest ItemId
iid CStore
cstore Bool
blast = do
  body <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
origin
  let lid = Actor -> LevelId
blid Actor
body
  localTime <- getsState $ getLocalTime lid
  unless blast $ execSfxAtomic $ SfxProject origin iid
  bag <- getsState $ getBodyStoreBag body cstore
  ItemFull{itemKind} <- getsState $ itemToFull iid
  case iid `EM.lookup` bag of
    Maybe ItemQuant
Nothing -> [Char] -> m ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char] -> (ActorId, Point, [Point], ItemId, CStore) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (ActorId
origin, Point
pos, [Point]
rest, ItemId
iid, CStore
cstore)
    Just kit :: ItemQuant
kit@(Int
_, ItemTimers
it) -> do
      let delay :: Time
delay =
            if ItemKind -> Int
IK.iweight ItemKind
itemKind Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
            then Time
timeTurn  -- big delay at start, e.g., to easily read hologram
            else Time
timeZero  -- avoid running into own projectiles
          btime :: Time
btime = Time -> Time -> Time
absoluteTimeAdd Time
delay Time
localTime
      ActorId
-> Point
-> [Point]
-> ItemId
-> ItemQuant
-> LevelId
-> FactionId
-> Time
-> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId
-> Point
-> [Point]
-> ItemId
-> ItemQuant
-> LevelId
-> FactionId
-> Time
-> m ()
addProjectile ActorId
propeller Point
pos [Point]
rest ItemId
iid ItemQuant
kit LevelId
lid (Actor -> FactionId
bfid Actor
body) Time
btime
      let c :: Container
c = ActorId -> CStore -> Container
CActor ActorId
origin CStore
cstore
      UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> ItemId -> ItemQuant -> Container -> UpdAtomic
UpdLoseItem Bool
False ItemId
iid (Int
1, Int -> ItemTimers -> ItemTimers
forall a. Int -> [a] -> [a]
take Int
1 ItemTimers
it) Container
c

addActorFromGroup :: MonadServerAtomic m
                  => GroupName ItemKind -> FactionId -> Point -> LevelId -> Time
                  -> m (Maybe ActorId)
addActorFromGroup :: forall (m :: * -> *).
MonadServerAtomic m =>
GroupName ItemKind
-> FactionId -> Point -> LevelId -> Time -> m (Maybe ActorId)
addActorFromGroup GroupName ItemKind
actorGroup FactionId
fid Point
pos LevelId
lid Time
time = do
  Level{ldepth} <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel LevelId
lid
  -- 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 ldepth [(actorGroup, 1)]
  m2 <- rollItemAspect freq ldepth
  case m2 of
    NewItem
NoNewItem -> Maybe ActorId -> m (Maybe ActorId)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ActorId
forall a. Maybe a
Nothing
    NewItem GroupName ItemKind
_ ItemKnown
itemKnown ItemFull
itemFull ItemQuant
itemQuant -> do
      let itemFullKit :: (ItemFull, ItemQuant)
itemFullKit = (ItemFull
itemFull, ItemQuant
itemQuant)
      ActorId -> Maybe ActorId
forall a. a -> Maybe a
Just (ActorId -> Maybe ActorId) -> m ActorId -> m (Maybe ActorId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> ItemKnown
-> (ItemFull, ItemQuant)
-> FactionId
-> Point
-> LevelId
-> Time
-> m ActorId
forall (m :: * -> *).
MonadServerAtomic m =>
Bool
-> ItemKnown
-> (ItemFull, ItemQuant)
-> FactionId
-> Point
-> LevelId
-> Time
-> m ActorId
registerActor Bool
False ItemKnown
itemKnown (ItemFull, ItemQuant)
itemFullKit FactionId
fid Point
pos LevelId
lid Time
time

registerActor :: MonadServerAtomic m
              => Bool -> ItemKnown -> ItemFullKit
              -> FactionId -> Point -> LevelId -> Time
              -> m ActorId
registerActor :: forall (m :: * -> *).
MonadServerAtomic m =>
Bool
-> ItemKnown
-> (ItemFull, ItemQuant)
-> FactionId
-> Point
-> LevelId
-> Time
-> m ActorId
registerActor Bool
summoned (ItemKnown ItemIdentity
kindIx AspectRecord
ar Maybe FactionId
_) (ItemFull
itemFullRaw, ItemQuant
kit)
              FactionId
bfid Point
pos LevelId
lid Time
time = do
  COps{cocave} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  let container = FactionId -> LevelId -> Point -> Container
CTrunk FactionId
bfid LevelId
lid Point
pos
      jfid = FactionId -> Maybe FactionId
forall a. a -> Maybe a
Just FactionId
bfid
      itemKnown = ItemIdentity -> AspectRecord -> Maybe FactionId -> ItemKnown
ItemKnown ItemIdentity
kindIx AspectRecord
ar Maybe FactionId
jfid
      itemFull = ItemFull
itemFullRaw {itemBase = (itemBase itemFullRaw) {jfid}}
  trunkId <- registerItem False (itemFull, kit) itemKnown container
  aid <- addNonProjectile summoned trunkId (itemFull, kit) bfid pos lid time
  fact <- getsState $ (EM.! bfid) . sfactionD
  actorMaxSk <- getsState $ getActorMaxSkills aid
  condAnyFoeAdj <- getsState $ anyFoeAdj aid
  Level{lkind} <- getLevel lid
  let cinitSleep = CaveKind -> InitSleep
CK.cinitSleep (CaveKind -> InitSleep) -> CaveKind -> InitSleep
forall a b. (a -> b) -> a -> b
$ ContentData CaveKind -> ContentId CaveKind -> CaveKind
forall a. ContentData a -> ContentId a -> a
okind ContentData CaveKind
cocave ContentId CaveKind
lkind
  when (cinitSleep /= CK.InitSleepBanned
        && canSleep actorMaxSk
        && not condAnyFoeAdj
        && not summoned
        && not (fhasGender (gkind fact))) $ do  -- heroes never start asleep
    -- A lot of actors will wake up at once anyway, so let most start sleeping.
    let sleepOdds = if Skills -> Bool
prefersSleep Skills
actorMaxSk then Integer
19Integer -> Integer -> Ratio Integer
forall a. Integral a => a -> a -> Ratio a
%Integer
20 else Integer
2Integer -> Integer -> Ratio Integer
forall a. Integral a => a -> a -> Ratio a
%Integer
3
    sleeps <- rndToAction $ chance sleepOdds
    when (cinitSleep == CK.InitSleepAlways || sleeps) $ addSleep aid
  return aid

addProjectile :: MonadServerAtomic m
              => ActorId -> Point -> [Point] -> ItemId -> ItemQuant -> LevelId
              -> FactionId -> Time
              -> m ()
addProjectile :: forall (m :: * -> *).
MonadServerAtomic m =>
ActorId
-> Point
-> [Point]
-> ItemId
-> ItemQuant
-> LevelId
-> FactionId
-> Time
-> m ()
addProjectile ActorId
propeller Point
pos [Point]
rest ItemId
iid (Int
_, ItemTimers
it) LevelId
lid FactionId
fid Time
time = do
  itemFull <- (State -> ItemFull) -> m ItemFull
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ItemFull) -> m ItemFull)
-> (State -> ItemFull) -> m ItemFull
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> ItemFull
itemToFull ItemId
iid
  let arItem = ItemFull -> AspectRecord
aspectRecordFull ItemFull
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 Actor
b = Actor
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 $ \StateServer
ser ->
    StateServer
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 :: forall (m :: * -> *).
MonadServerAtomic m =>
Bool
-> ItemId
-> (ItemFull, ItemQuant)
-> FactionId
-> Point
-> LevelId
-> Time
-> m ActorId
addNonProjectile Bool
summoned ItemId
trunkId (ItemFull
itemFull, ItemQuant
kit) FactionId
fid Point
pos LevelId
lid Time
time = do
  let tweakBody :: Actor -> Actor
tweakBody Actor
b = Actor
b { borgan = EM.singleton trunkId kit
                      , bcalm = if summoned
                                then xM 5  -- a tiny buffer before domination
                                else bcalm b }
  aid <- ItemId
-> ItemFull
-> Bool
-> FactionId
-> Point
-> LevelId
-> (Actor -> Actor)
-> m ActorId
forall (m :: * -> *).
MonadServerAtomic m =>
ItemId
-> ItemFull
-> Bool
-> FactionId
-> Point
-> LevelId
-> (Actor -> Actor)
-> m ActorId
addActorIid ItemId
trunkId ItemFull
itemFull Bool
False FactionId
fid Point
pos LevelId
lid Actor -> Actor
tweakBody
  -- We assume actor is never born pushed.
  modifyServer $ \StateServer
ser ->
    StateServer
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 :: forall (m :: * -> *).
MonadServerAtomic m =>
ItemId
-> ItemFull
-> Bool
-> FactionId
-> Point
-> LevelId
-> (Actor -> Actor)
-> m ActorId
addActorIid ItemId
trunkId ItemFull{Item
itemBase :: ItemFull -> Item
itemBase :: Item
itemBase, ItemKind
itemKind :: ItemFull -> ItemKind
itemKind :: ItemKind
itemKind, itemDisco :: ItemFull -> ItemDisco
itemDisco=ItemDiscoFull AspectRecord
arItem}
            Bool
bproj FactionId
fid Point
pos LevelId
lid Actor -> Actor
tweakBody = do
  COps{coitem} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  -- Initial HP and Calm is based only on trunk and ignores organs.
  let trunkMaxHP = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
2 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Skill -> AspectRecord -> Int
IA.getSkill Skill
Ability.SkMaxHP AspectRecord
arItem
      hp = Int -> Int64
xM Int
trunkMaxHP Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
2
      -- Slightly reduced starting Calm to auto-id items that refill Calm
      -- and to let animals do some initial exploration before going to sleep.
      -- Higher reduction would cause confusingly low sight range at game
      -- start and even inability to handle equipment.
      calm = Int -> Int64
xM (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Skill -> AspectRecord -> Int
IA.getSkill Skill
Ability.SkMaxCalm AspectRecord
arItem Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
10)
  -- Create actor.
  factionD <- getsState sfactionD
  curChalSer <- getsServer $ scurChalSer . soptions
  let fact = EnumMap FactionId Faction
factionD EnumMap FactionId Faction -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid
      teamContinuityOurs = FactionKind -> TeamContinuity
fteam (Faction -> FactionKind
gkind Faction
fact)
  bnumberTeam <-
    if bproj then return Nothing else do
      stcounter <- getsServer stcounter
      let number = Int -> TeamContinuity -> EnumMap TeamContinuity Int -> Int
forall k a. Enum k => a -> k -> EnumMap k a -> a
EM.findWithDefault Int
0 TeamContinuity
teamContinuityOurs EnumMap TeamContinuity Int
stcounter
      modifyServer $ \StateServer
ser -> StateServer
ser {stcounter =
        EM.insert teamContinuityOurs (succ number) stcounter}
      return $ Just (number, teamContinuityOurs)
  let bnumber = (Int, TeamContinuity) -> Int
forall a b. (a, b) -> a
fst ((Int, TeamContinuity) -> Int)
-> Maybe (Int, TeamContinuity) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Int, TeamContinuity)
bnumberTeam
  -- 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 = Int -> Int
difficultyCoeff (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Challenge -> Int
cdiff Challenge
curChalSer
      -- For most projectiles (exceptions are, e.g.,  maxHP boosting rings),
      -- SkMaxHP is zero, which means they drop after one hit regardless
      -- of extra bhp they have due to piercing. That is fine.
      -- If we want armoured missiles, that should not be done via piercing,
      -- but via SkMaxHP of the thrown items. Rings that are piercing
      -- by coincidence are harmless, too. However, piercing should not be
      -- added to missiles via SkMaxHP or equipping them would be beneficial
      -- in a hard to balance way (e.g., one bullet adds 10 SkMaxHP).
      boostFact = Bool -> Bool
not Bool
bproj
                  Bool -> Bool -> Bool
&& if Int
diffBonusCoeff Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                     then ((FactionId, Faction) -> Bool) -> [(FactionId, Faction)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FactionKind -> Bool
fhasUI (FactionKind -> Bool)
-> ((FactionId, Faction) -> FactionKind)
-> (FactionId, Faction)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Faction -> FactionKind
gkind (Faction -> FactionKind)
-> ((FactionId, Faction) -> Faction)
-> (FactionId, Faction)
-> FactionKind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FactionId, Faction) -> Faction
forall a b. (a, b) -> b
snd)
                              (((FactionId, Faction) -> Bool)
-> [(FactionId, Faction)] -> [(FactionId, Faction)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(FactionId
fi, Faction
fa) -> FactionId -> Faction -> FactionId -> Bool
isFriend FactionId
fi Faction
fa FactionId
fid)
                                      (EnumMap FactionId Faction -> [(FactionId, Faction)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs EnumMap FactionId Faction
factionD))
                     else ((FactionId, Faction) -> Bool) -> [(FactionId, Faction)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FactionKind -> Bool
fhasUI (FactionKind -> Bool)
-> ((FactionId, Faction) -> FactionKind)
-> (FactionId, Faction)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Faction -> FactionKind
gkind  (Faction -> FactionKind)
-> ((FactionId, Faction) -> Faction)
-> (FactionId, Faction)
-> FactionKind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FactionId, Faction) -> Faction
forall a b. (a, b) -> b
snd)
                              (((FactionId, Faction) -> Bool)
-> [(FactionId, Faction)] -> [(FactionId, Faction)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(FactionId
fi, Faction
fa) -> FactionId -> Faction -> FactionId -> Bool
isFoe FactionId
fi Faction
fa FactionId
fid)
                                      (EnumMap FactionId Faction -> [(FactionId, Faction)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs EnumMap FactionId Faction
factionD))
      finalHP | Bool
boostFact = Int64 -> Int64 -> Int64
forall a. Ord a => a -> a -> a
min (Int -> Int64
xM Int
899)  -- no more than UI can stand
                                (Int64
hp Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
2 Int64 -> Int -> Int64
forall a b. (Num a, Integral b) => a -> b -> a
^ Int -> Int
forall a. Num a => a -> a
abs Int
diffBonusCoeff)
              | Bool
otherwise = Int64
hp
      -- Prevent too high max HP resulting in panic when low HP/max HP ratio.
      maxHP = Int64 -> Int64 -> Int64
forall a. Ord a => a -> a -> a
min (Int64
finalHP Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int -> Int64
xM Int
100) (Int64
2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
finalHP)
      bonusHP = Int64 -> Int
forall a. Enum a => a -> Int
fromEnum (Int64
maxHP Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
oneM) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
trunkMaxHP
      healthOrgans = [(Int -> Maybe Int
forall a. a -> Maybe a
Just Int
bonusHP, (GroupName ItemKind
IK.S_BONUS_HP, CStore
COrgan)) | Int
bonusHP Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0]
      b = ItemId
-> Maybe Int
-> Int64
-> Int64
-> Point
-> LevelId
-> FactionId
-> Bool
-> Actor
actorTemplate ItemId
trunkId Maybe Int
bnumber Int64
finalHP Int64
calm Point
pos LevelId
lid FactionId
fid Bool
bproj
      withTrunk =
        Actor
b { bweapon = if IA.checkFlag Ability.Meleeable arItem then 1 else 0
          , bweapBenign =
              if IA.checkFlag Ability.Meleeable arItem
                 && IA.checkFlag Ability.Benign arItem then 1 else 0 }
      bodyTweaked = Actor -> Actor
tweakBody Actor
withTrunk
  aid <- getsServer sacounter
  modifyServer $ \StateServer
ser -> StateServer
ser {sacounter = succ aid}
  execUpdAtomic $ UpdCreateActor aid bodyTweaked [(trunkId, itemBase)]
  unless bproj $ do
    steamGearCur <- getsServer steamGearCur
    let gearList = case Maybe (Int, TeamContinuity)
bnumberTeam of
          Maybe (Int, TeamContinuity)
Nothing -> []
          Just (Int
number, TeamContinuity
teamContinuity) ->
            case TeamContinuity
teamContinuity TeamContinuity
-> GearOfTeams
-> Maybe (IntMap [(GroupName ItemKind, ContentId ItemKind)])
forall k a. Enum k => k -> EnumMap k a -> Maybe a
`EM.lookup` GearOfTeams
steamGearCur of
              Maybe (IntMap [(GroupName ItemKind, ContentId ItemKind)])
Nothing -> []
              Just IntMap [(GroupName ItemKind, ContentId ItemKind)]
im -> [(GroupName ItemKind, ContentId ItemKind)]
-> Int
-> IntMap [(GroupName ItemKind, ContentId ItemKind)]
-> [(GroupName ItemKind, ContentId ItemKind)]
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault [] Int
number IntMap [(GroupName ItemKind, ContentId ItemKind)]
im
    -- Create, register and insert all initial actor items, including
    -- the bonus health organs from difficulty setting.
    forM_ (healthOrgans ++ map (Nothing,) (IK.ikit itemKind))
          $ \(Maybe Int
mk, (GroupName ItemKind
ikGrp, CStore
cstore)) -> do
     -- TODO: remove ASAP. This is a hack that prevents AI from stealing
     -- backstories until there is enough of them in Allure.
     -- Instead, pre-generate 20 player heroes to make sure all unique
     -- backstories are available to the player and so that the order
     -- of games played doesn't affect their availability.
     if GroupName ItemKind
ikGrp GroupName ItemKind -> GroupName ItemKind -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> GroupName ItemKind
forall c. Text -> GroupName c
DefsInternal.GroupName Text
"backstory"
        Bool -> Bool -> Bool
&& Maybe (Int, TeamContinuity) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Int, TeamContinuity)
bnumberTeam
        Bool -> Bool -> Bool
&& ((Int, TeamContinuity) -> TeamContinuity
forall a b. (a, b) -> b
snd ((Int, TeamContinuity) -> TeamContinuity)
-> Maybe (Int, TeamContinuity) -> Maybe TeamContinuity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Int, TeamContinuity)
bnumberTeam) Maybe TeamContinuity -> Maybe TeamContinuity -> Bool
forall a. Eq a => a -> a -> Bool
/= TeamContinuity -> Maybe TeamContinuity
forall a. a -> Maybe a
Just TeamContinuity
teamExplorer
     then () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     else do
      let container :: Container
container = ActorId -> CStore -> Container
CActor ActorId
aid CStore
cstore
      Level{ldepth} <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel LevelId
lid
      mIidEtc <- case lookup ikGrp gearList of
        Maybe (ContentId ItemKind)
Nothing -> do
          let itemFreq :: Freqs ItemKind
itemFreq = [(GroupName ItemKind
ikGrp, Int
1)]
          -- Power depth of new items unaffected by number of spawned actors.
          freq <- Int
-> AbsDepth
-> Freqs ItemKind
-> m (Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind))
forall (m :: * -> *).
MonadServerAtomic m =>
Int
-> AbsDepth
-> Freqs ItemKind
-> m (Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind))
prepareItemKind Int
0 AbsDepth
ldepth Freqs ItemKind
itemFreq
          mIidEtc <- rollAndRegisterItem False ldepth freq container mk
          case (bnumberTeam, mIidEtc) of
            (Just (Int
number, TeamContinuity
teamContinuity), Just (ItemId
_, (ItemFull
itemFull2, ItemQuant
_))) -> do
              let arItem2 :: AspectRecord
arItem2 = ItemFull -> AspectRecord
aspectRecordFull ItemFull
itemFull2
                  inMetaGame :: Bool
inMetaGame = Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.MetaGame AspectRecord
arItem2
                  itemKindId2 :: ContentId ItemKind
itemKindId2 = ItemFull -> ContentId ItemKind
itemKindId ItemFull
itemFull2
              Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
inMetaGame (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                let altInner :: Maybe [(GroupName ItemKind, ContentId ItemKind)]
-> Maybe [(GroupName ItemKind, ContentId ItemKind)]
altInner Maybe [(GroupName ItemKind, ContentId ItemKind)]
ml = [(GroupName ItemKind, ContentId ItemKind)]
-> Maybe [(GroupName ItemKind, ContentId ItemKind)]
forall a. a -> Maybe a
Just ([(GroupName ItemKind, ContentId ItemKind)]
 -> Maybe [(GroupName ItemKind, ContentId ItemKind)])
-> [(GroupName ItemKind, ContentId ItemKind)]
-> Maybe [(GroupName ItemKind, ContentId ItemKind)]
forall a b. (a -> b) -> a -> b
$ (GroupName ItemKind
ikGrp, ContentId ItemKind
itemKindId2) (GroupName ItemKind, ContentId ItemKind)
-> [(GroupName ItemKind, ContentId ItemKind)]
-> [(GroupName ItemKind, ContentId ItemKind)]
forall a. a -> [a] -> [a]
: [(GroupName ItemKind, ContentId ItemKind)]
-> Maybe [(GroupName ItemKind, ContentId ItemKind)]
-> [(GroupName ItemKind, ContentId ItemKind)]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [(GroupName ItemKind, ContentId ItemKind)]
ml
                    alt :: Maybe (IntMap [(GroupName ItemKind, ContentId ItemKind)])
-> Maybe (IntMap [(GroupName ItemKind, ContentId ItemKind)])
alt Maybe (IntMap [(GroupName ItemKind, ContentId ItemKind)])
mim =
                      IntMap [(GroupName ItemKind, ContentId ItemKind)]
-> Maybe (IntMap [(GroupName ItemKind, ContentId ItemKind)])
forall a. a -> Maybe a
Just (IntMap [(GroupName ItemKind, ContentId ItemKind)]
 -> Maybe (IntMap [(GroupName ItemKind, ContentId ItemKind)]))
-> IntMap [(GroupName ItemKind, ContentId ItemKind)]
-> Maybe (IntMap [(GroupName ItemKind, ContentId ItemKind)])
forall a b. (a -> b) -> a -> b
$ (Maybe [(GroupName ItemKind, ContentId ItemKind)]
 -> Maybe [(GroupName ItemKind, ContentId ItemKind)])
-> Int
-> IntMap [(GroupName ItemKind, ContentId ItemKind)]
-> IntMap [(GroupName ItemKind, ContentId ItemKind)]
forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter Maybe [(GroupName ItemKind, ContentId ItemKind)]
-> Maybe [(GroupName ItemKind, ContentId ItemKind)]
altInner Int
number (IntMap [(GroupName ItemKind, ContentId ItemKind)]
 -> IntMap [(GroupName ItemKind, ContentId ItemKind)])
-> IntMap [(GroupName ItemKind, ContentId ItemKind)]
-> IntMap [(GroupName ItemKind, ContentId ItemKind)]
forall a b. (a -> b) -> a -> b
$ IntMap [(GroupName ItemKind, ContentId ItemKind)]
-> Maybe (IntMap [(GroupName ItemKind, ContentId ItemKind)])
-> IntMap [(GroupName ItemKind, ContentId ItemKind)]
forall a. a -> Maybe a -> a
fromMaybe IntMap [(GroupName ItemKind, ContentId ItemKind)]
forall a. IntMap a
IM.empty Maybe (IntMap [(GroupName ItemKind, ContentId ItemKind)])
mim
                (StateServer -> StateServer) -> m ()
forall (m :: * -> *).
MonadServer m =>
(StateServer -> StateServer) -> m ()
modifyServer ((StateServer -> StateServer) -> m ())
-> (StateServer -> StateServer) -> m ()
forall a b. (a -> b) -> a -> b
$ \StateServer
ser ->
                  StateServer
ser {steamGear = EM.alter alt teamContinuity $ steamGear ser}
            (Maybe (Int, TeamContinuity),
 Maybe (ItemId, (ItemFull, ItemQuant)))
_ -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          return mIidEtc
        Just ContentId ItemKind
itemKindId2 -> do
          let gearListNew :: [(GroupName ItemKind, ContentId ItemKind)]
gearListNew = (GroupName ItemKind, ContentId ItemKind)
-> [(GroupName ItemKind, ContentId ItemKind)]
-> [(GroupName ItemKind, ContentId ItemKind)]
forall a. Eq a => a -> [a] -> [a]
delete (GroupName ItemKind
ikGrp, ContentId ItemKind
itemKindId2) [(GroupName ItemKind, ContentId ItemKind)]
gearList
              (Int
number, TeamContinuity
teamContinuity) = Maybe (Int, TeamContinuity) -> (Int, TeamContinuity)
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Int, TeamContinuity)
bnumberTeam
              alt :: Maybe (IntMap [(GroupName ItemKind, ContentId ItemKind)])
-> Maybe (IntMap [(GroupName ItemKind, ContentId ItemKind)])
alt Maybe (IntMap [(GroupName ItemKind, ContentId ItemKind)])
mim =
                IntMap [(GroupName ItemKind, ContentId ItemKind)]
-> Maybe (IntMap [(GroupName ItemKind, ContentId ItemKind)])
forall a. a -> Maybe a
Just (IntMap [(GroupName ItemKind, ContentId ItemKind)]
 -> Maybe (IntMap [(GroupName ItemKind, ContentId ItemKind)]))
-> IntMap [(GroupName ItemKind, ContentId ItemKind)]
-> Maybe (IntMap [(GroupName ItemKind, ContentId ItemKind)])
forall a b. (a -> b) -> a -> b
$ Int
-> [(GroupName ItemKind, ContentId ItemKind)]
-> IntMap [(GroupName ItemKind, ContentId ItemKind)]
-> IntMap [(GroupName ItemKind, ContentId ItemKind)]
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
number [(GroupName ItemKind, ContentId ItemKind)]
gearListNew (IntMap [(GroupName ItemKind, ContentId ItemKind)]
 -> IntMap [(GroupName ItemKind, ContentId ItemKind)])
-> IntMap [(GroupName ItemKind, ContentId ItemKind)]
-> IntMap [(GroupName ItemKind, ContentId ItemKind)]
forall a b. (a -> b) -> a -> b
$ IntMap [(GroupName ItemKind, ContentId ItemKind)]
-> Maybe (IntMap [(GroupName ItemKind, ContentId ItemKind)])
-> IntMap [(GroupName ItemKind, ContentId ItemKind)]
forall a. a -> Maybe a -> a
fromMaybe IntMap [(GroupName ItemKind, ContentId ItemKind)]
forall a. IntMap a
IM.empty Maybe (IntMap [(GroupName ItemKind, ContentId ItemKind)])
mim
          (StateServer -> StateServer) -> m ()
forall (m :: * -> *).
MonadServer m =>
(StateServer -> StateServer) -> m ()
modifyServer ((StateServer -> StateServer) -> m ())
-> (StateServer -> StateServer) -> m ()
forall a b. (a -> b) -> a -> b
$ \StateServer
ser ->
            StateServer
ser {steamGearCur = EM.alter alt teamContinuity steamGearCur}
          let itemKind2 :: ItemKind
itemKind2 = ContentData ItemKind -> ContentId ItemKind -> ItemKind
forall a. ContentData a -> ContentId a -> a
okind ContentData ItemKind
coitem ContentId ItemKind
itemKindId2
              freq :: Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
freq = (GroupName ItemKind, ContentId ItemKind, ItemKind)
-> Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
forall a. a -> Frequency a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupName ItemKind
ikGrp, ContentId ItemKind
itemKindId2, ItemKind
itemKind2)
          Bool
-> AbsDepth
-> Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
-> Container
-> Maybe Int
-> m (Maybe (ItemId, (ItemFull, ItemQuant)))
forall (m :: * -> *).
MonadServerAtomic m =>
Bool
-> AbsDepth
-> Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
-> Container
-> Maybe Int
-> m (Maybe (ItemId, (ItemFull, ItemQuant)))
rollAndRegisterItem Bool
False AbsDepth
ldepth Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
freq Container
container Maybe Int
mk
      case mIidEtc of
        Maybe (ItemId, (ItemFull, ItemQuant))
Nothing -> [Char] -> m ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char]
-> (LevelId, GroupName ItemKind, Container, Maybe Int) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (LevelId
lid, GroupName ItemKind
ikGrp, Container
container, Maybe Int
mk)
        Just (ItemId
iid, (ItemFull
itemFull2, ItemQuant
_)) ->
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CStore
cstore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
/= CStore
CGround) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            -- The items are created owned by actors, so won't be picked up,
            -- so we have to discover them now, if eligible.
            Container -> ItemId -> ContentId ItemKind -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
Container -> ItemId -> ContentId ItemKind -> m ()
discoverIfMinorEffects Container
container ItemId
iid (ItemFull -> ContentId ItemKind
itemKindId ItemFull
itemFull2)
  return aid
addActorIid ItemId
_ ItemFull
_ Bool
_ FactionId
_ Point
_ LevelId
_ Actor -> Actor
_ = [Char] -> m ActorId
forall a. HasCallStack => [Char] -> a
error [Char]
"addActorIid: server ignorant about an item"

discoverIfMinorEffects :: MonadServerAtomic m
                       => Container -> ItemId -> ContentId ItemKind -> m ()
discoverIfMinorEffects :: forall (m :: * -> *).
MonadServerAtomic m =>
Container -> ItemId -> ContentId ItemKind -> m ()
discoverIfMinorEffects Container
c ItemId
iid ContentId ItemKind
itemKindId = do
  COps{coitem} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  discoAspect <- getsState sdiscoAspect
  let arItem = DiscoveryAspect
discoAspect DiscoveryAspect -> ItemId -> AspectRecord
forall k a. Enum k => EnumMap k a -> k -> a
EM.! ItemId
iid
      itemKind = ContentData ItemKind -> ContentId ItemKind -> ItemKind
forall a. ContentData a -> ContentId a -> a
okind ContentData ItemKind
coitem ContentId ItemKind
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 -> ActorId -> m (Maybe (ItemId, CStore))
pickWeaponServer :: forall (m :: * -> *).
MonadServer m =>
ActorId -> ActorId -> m (Maybe (ItemId, CStore))
pickWeaponServer ActorId
source ActorId
target = do
  eqpAssocs <- (State -> [(ItemId, (ItemFull, ItemQuant))])
-> m [(ItemId, (ItemFull, ItemQuant))]
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> [(ItemId, (ItemFull, ItemQuant))])
 -> m [(ItemId, (ItemFull, ItemQuant))])
-> (State -> [(ItemId, (ItemFull, ItemQuant))])
-> m [(ItemId, (ItemFull, ItemQuant))]
forall a b. (a -> b) -> a -> b
$ ActorId -> [CStore] -> State -> [(ItemId, (ItemFull, ItemQuant))]
kitAssocs ActorId
source [CStore
CEqp]
  bodyAssocs <- getsState $ kitAssocs source [COrgan]
  actorSk <- currentSkillsServer source
  sb <- getsState $ getActorBody source
  tb <- getsState $ getActorBody target
  let kitAssRaw = [(ItemId, (ItemFull, ItemQuant))]
eqpAssocs [(ItemId, (ItemFull, ItemQuant))]
-> [(ItemId, (ItemFull, ItemQuant))]
-> [(ItemId, (ItemFull, ItemQuant))]
forall a. [a] -> [a] -> [a]
++ [(ItemId, (ItemFull, ItemQuant))]
bodyAssocs
      forced = Actor -> Bool
bproj Actor
sb
      kitAss | Bool
forced = [(ItemId, (ItemFull, ItemQuant))]
kitAssRaw  -- for projectiles, anything is weapon
             | Bool
otherwise =
                 ((ItemId, (ItemFull, ItemQuant)) -> Bool)
-> [(ItemId, (ItemFull, ItemQuant))]
-> [(ItemId, (ItemFull, ItemQuant))]
forall a. (a -> Bool) -> [a] -> [a]
filter (Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Meleeable
                         (AspectRecord -> Bool)
-> ((ItemId, (ItemFull, ItemQuant)) -> AspectRecord)
-> (ItemId, (ItemFull, ItemQuant))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ItemFull -> AspectRecord
aspectRecordFull (ItemFull -> AspectRecord)
-> ((ItemId, (ItemFull, ItemQuant)) -> ItemFull)
-> (ItemId, (ItemFull, ItemQuant))
-> AspectRecord
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ItemFull, ItemQuant) -> ItemFull
forall a b. (a, b) -> a
fst ((ItemFull, ItemQuant) -> ItemFull)
-> ((ItemId, (ItemFull, ItemQuant)) -> (ItemFull, ItemQuant))
-> (ItemId, (ItemFull, ItemQuant))
-> ItemFull
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ItemId, (ItemFull, ItemQuant)) -> (ItemFull, ItemQuant)
forall a b. (a, b) -> b
snd) [(ItemId, (ItemFull, ItemQuant))]
kitAssRaw
      benign ItemFull
itemFull = let arItem :: AspectRecord
arItem = ItemFull -> AspectRecord
aspectRecordFull ItemFull
itemFull
                        in Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Benign AspectRecord
arItem
  -- Server ignores item effects or it would leak item discovery info.
  -- Hence, weapons with powerful burning or wouding are undervalued.
  -- In particular, it even uses weapons that would heal an opponent.
  -- But server decides only in exceptiona cases, e.g. projectile collision
  -- or melee in place of an impossible displace. Otherwise, client decides.
  strongest <- pickWeaponM False Nothing kitAss actorSk source
  case strongest of
    [] -> Maybe (ItemId, CStore) -> m (Maybe (ItemId, CStore))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ItemId, CStore)
forall a. Maybe a
Nothing
    (Double
_, Bool
_, Int
_, Int
_, ItemId
_, (ItemFull
itemFull, ItemQuant
_)) : [(Double, Bool, Int, Int, ItemId, (ItemFull, ItemQuant))]
_ | Bool -> Bool
not Bool
forced
                                         Bool -> Bool -> Bool
&& ItemFull -> Bool
benign ItemFull
itemFull Bool -> Bool -> Bool
&& Actor -> Bool
bproj Actor
tb ->
      Maybe (ItemId, CStore) -> m (Maybe (ItemId, CStore))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ItemId, CStore)
forall a. Maybe a
Nothing  -- if strongest is benign, don't waste fun on a projectile
    iis :: [(Double, Bool, Int, Int, ItemId, (ItemFull, ItemQuant))]
iis@((Double
value1, Bool
hasEffect1, Int
timeout1, Int
_, ItemId
_, (ItemFull, ItemQuant)
_) : [(Double, Bool, Int, Int, ItemId, (ItemFull, ItemQuant))]
_) -> do
      let minIis :: [(Double, Bool, Int, Int, ItemId, (ItemFull, ItemQuant))]
minIis = ((Double, Bool, Int, Int, ItemId, (ItemFull, ItemQuant)) -> Bool)
-> [(Double, Bool, Int, Int, ItemId, (ItemFull, ItemQuant))]
-> [(Double, Bool, Int, Int, ItemId, (ItemFull, ItemQuant))]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\(Double
value, Bool
hasEffect, Int
timeout, Int
_, ItemId
_, (ItemFull, ItemQuant)
_) ->
                                 Double
value Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
value1
                                 Bool -> Bool -> Bool
&& Bool
hasEffect Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
hasEffect1
                                 Bool -> Bool -> Bool
&& Int
timeout Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
timeout1)
                             [(Double, Bool, Int, Int, ItemId, (ItemFull, ItemQuant))]
iis
      (_, _, _, _, iid, _) <- Rnd (Double, Bool, Int, Int, ItemId, (ItemFull, ItemQuant))
-> m (Double, Bool, Int, Int, ItemId, (ItemFull, ItemQuant))
forall (m :: * -> *) a. MonadServer m => Rnd a -> m a
rndToAction (Rnd (Double, Bool, Int, Int, ItemId, (ItemFull, ItemQuant))
 -> m (Double, Bool, Int, Int, ItemId, (ItemFull, ItemQuant)))
-> Rnd (Double, Bool, Int, Int, ItemId, (ItemFull, ItemQuant))
-> m (Double, Bool, Int, Int, ItemId, (ItemFull, ItemQuant))
forall a b. (a -> b) -> a -> b
$ [(Double, Bool, Int, Int, ItemId, (ItemFull, ItemQuant))]
-> Rnd (Double, Bool, Int, Int, ItemId, (ItemFull, ItemQuant))
forall a. [a] -> Rnd a
oneOf [(Double, Bool, Int, Int, ItemId, (ItemFull, ItemQuant))]
minIis
      let cstore = if Maybe (ItemFull, ItemQuant) -> Bool
forall a. Maybe a -> Bool
isJust (ItemId
-> [(ItemId, (ItemFull, ItemQuant))] -> Maybe (ItemFull, ItemQuant)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ItemId
iid [(ItemId, (ItemFull, ItemQuant))]
bodyAssocs) then CStore
COrgan else CStore
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 :: forall (m :: * -> *). MonadServer m => ActorId -> m Skills
currentSkillsServer ActorId
aid  = do
  body <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
  mleader <- getsState $ gleader . (EM.! bfid body) . sfactionD
  getsState $ actorCurrentSkills mleader aid

getCacheLucid :: MonadServer m => LevelId -> m FovLucid
getCacheLucid :: forall (m :: * -> *). MonadServer m => LevelId -> m FovLucid
getCacheLucid LevelId
lid = do
  fovClearLid <- (StateServer -> FovClearLid) -> m FovClearLid
forall a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> FovClearLid
sfovClearLid
  fovLitLid <- getsServer sfovLitLid
  fovLucidLid <- getsServer sfovLucidLid
  let getNewLucid = (State -> FovLucid) -> m FovLucid
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> FovLucid) -> m FovLucid)
-> (State -> FovLucid) -> m FovLucid
forall a b. (a -> b) -> a -> b
$ \State
s ->
        FovClearLid -> FovLitLid -> State -> LevelId -> Level -> FovLucid
lucidFromLevel FovClearLid
fovClearLid FovLitLid
fovLitLid State
s LevelId
lid (State -> Dungeon
sdungeon State
s Dungeon -> LevelId -> Level
forall k a. Enum k => EnumMap k a -> k -> a
EM.! LevelId
lid)
  case EM.lookup lid fovLucidLid of
    Just (FovValid FovLucid
fovLucid) -> FovLucid -> m FovLucid
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return FovLucid
fovLucid
    Maybe (FovValid FovLucid)
_ -> do
      newLucid <- m FovLucid
getNewLucid
      modifyServer $ \StateServer
ser ->
        StateServer
ser {sfovLucidLid = EM.insert lid (FovValid newLucid)
                            $ sfovLucidLid ser}
      return newLucid

getCacheTotal :: MonadServer m => FactionId -> LevelId -> m CacheBeforeLucid
getCacheTotal :: forall (m :: * -> *).
MonadServer m =>
FactionId -> LevelId -> m CacheBeforeLucid
getCacheTotal FactionId
fid LevelId
lid = do
  sperCacheFidOld <- (StateServer -> PerCacheFid) -> m PerCacheFid
forall a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> PerCacheFid
sperCacheFid
  let perCacheOld = PerCacheFid
sperCacheFidOld PerCacheFid -> FactionId -> EnumMap LevelId PerceptionCache
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid EnumMap LevelId PerceptionCache -> LevelId -> PerceptionCache
forall k a. Enum k => EnumMap k a -> k -> a
EM.! LevelId
lid
  case ptotal perCacheOld of
    FovValid CacheBeforeLucid
total -> CacheBeforeLucid -> m CacheBeforeLucid
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return CacheBeforeLucid
total
    FovValid CacheBeforeLucid
FovInvalid -> do
      actorMaxSkills <- (State -> ActorMaxSkills) -> m ActorMaxSkills
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> ActorMaxSkills
sactorMaxSkills
      fovClearLid <- getsServer sfovClearLid
      getActorB <- getsState $ flip getActorBody
      let perActorNew =
            PerActor
-> (ActorId -> Actor) -> ActorMaxSkills -> FovClear -> PerActor
perActorFromLevel (PerceptionCache -> PerActor
perActor PerceptionCache
perCacheOld) ActorId -> Actor
getActorB
                              ActorMaxSkills
actorMaxSkills (FovClearLid
fovClearLid FovClearLid -> LevelId -> FovClear
forall k a. Enum k => EnumMap k a -> k -> a
EM.! LevelId
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 = PerActor -> CacheBeforeLucid
totalFromPerActor PerActor
perActorNew
          perCache = PerceptionCache { ptotal :: FovValid CacheBeforeLucid
ptotal = CacheBeforeLucid -> FovValid CacheBeforeLucid
forall a. a -> FovValid a
FovValid CacheBeforeLucid
total
                                     , perActor :: PerActor
perActor = PerActor
perActorNew }
          fperCache = (EnumMap LevelId PerceptionCache
 -> EnumMap LevelId PerceptionCache)
-> FactionId -> PerCacheFid -> PerCacheFid
forall k a. Enum k => (a -> a) -> k -> EnumMap k a -> EnumMap k a
EM.adjust (LevelId
-> PerceptionCache
-> EnumMap LevelId PerceptionCache
-> EnumMap LevelId PerceptionCache
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert LevelId
lid PerceptionCache
perCache) FactionId
fid
      modifyServer $ \StateServer
ser -> StateServer
ser {sperCacheFid = fperCache $ sperCacheFid ser}
      return total

allGroupItems :: MonadServerAtomic m
              => CStore -> GroupName ItemKind -> ActorId
              -> m [(ItemId, ItemQuant)]
allGroupItems :: forall (m :: * -> *).
MonadServerAtomic m =>
CStore -> GroupName ItemKind -> ActorId -> m [(ItemId, ItemQuant)]
allGroupItems CStore
store GroupName ItemKind
grp ActorId
target = do
  COps{coitem} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  b <- getsState $ getActorBody target
  assocsCStore <- getsState $ EM.assocs . getBodyStoreBag b store
  getKindId <- getsState $ flip getIidKindIdServer
  let assocsKindId = ((ItemId, ItemQuant) -> (ContentId ItemKind, (ItemId, ItemQuant)))
-> [(ItemId, ItemQuant)]
-> [(ContentId ItemKind, (ItemId, ItemQuant))]
forall a b. (a -> b) -> [a] -> [b]
map (\as :: (ItemId, ItemQuant)
as@(ItemId
iid, ItemQuant
_) -> (ItemId -> ContentId ItemKind
getKindId ItemId
iid, (ItemId, ItemQuant)
as)) [(ItemId, ItemQuant)]
assocsCStore
      hasGroup (ContentId ItemKind
itemKindId, (ItemId, ItemQuant)
_) =
        Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Maybe Int -> Bool) -> Maybe Int -> Bool
forall a b. (a -> b) -> a -> b
$ GroupName ItemKind -> Freqs ItemKind -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup GroupName ItemKind
grp (Freqs ItemKind -> Maybe Int) -> Freqs ItemKind -> Maybe Int
forall a b. (a -> b) -> a -> b
$ ItemKind -> Freqs ItemKind
IK.ifreq (ItemKind -> Freqs ItemKind) -> ItemKind -> Freqs ItemKind
forall a b. (a -> b) -> a -> b
$ ContentData ItemKind -> ContentId ItemKind -> ItemKind
forall a. ContentData a -> ContentId a -> a
okind ContentData ItemKind
coitem ContentId ItemKind
itemKindId
  return $! map snd $ sortBy (comparing fst) $ filter hasGroup assocsKindId

addCondition :: MonadServerAtomic m
             => Bool -> GroupName ItemKind -> ActorId -> m ()
addCondition :: forall (m :: * -> *).
MonadServerAtomic m =>
Bool -> GroupName ItemKind -> ActorId -> m ()
addCondition Bool
verbose GroupName ItemKind
name ActorId
aid = do
  b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
  Level{ldepth} <- getLevel $ blid b
  let c = ActorId -> CStore -> Container
CActor ActorId
aid CStore
COrgan
  -- Power depth of new items unaffected by number of spawned actors.
  freq <- prepareItemKind 0 ldepth [(name, 1)]
  mresult <- rollAndRegisterItem verbose ldepth freq c Nothing
  assert (isJust mresult) $ return ()

removeConditionSingle :: MonadServerAtomic m
                      => GroupName ItemKind -> ActorId -> m Int
removeConditionSingle :: forall (m :: * -> *).
MonadServerAtomic m =>
GroupName ItemKind -> ActorId -> m Int
removeConditionSingle GroupName ItemKind
name ActorId
aid = do
  let c :: Container
c = ActorId -> CStore -> Container
CActor ActorId
aid CStore
COrgan
  is <- CStore -> GroupName ItemKind -> ActorId -> m [(ItemId, ItemQuant)]
forall (m :: * -> *).
MonadServerAtomic m =>
CStore -> GroupName ItemKind -> ActorId -> m [(ItemId, ItemQuant)]
allGroupItems CStore
COrgan GroupName ItemKind
name ActorId
aid
  case is of
    [(ItemId
iid, (Int
nAll, ItemTimers
itemTimer))] -> do
      UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> ItemId -> ItemQuant -> Container -> UpdAtomic
UpdLoseItem Bool
False ItemId
iid (Int
1, ItemTimers
itemTimer) Container
c
      Int -> m Int
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> m Int) -> Int -> m Int
forall a b. (a -> b) -> a -> b
$ Int
nAll Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    [(ItemId, ItemQuant)]
_ -> [Char] -> m Int
forall a. HasCallStack => [Char] -> a
error ([Char] -> m Int) -> [Char] -> m Int
forall a b. (a -> b) -> a -> b
$ [Char]
"missing or multiple item" [Char] -> (GroupName ItemKind, [(ItemId, ItemQuant)]) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (GroupName ItemKind
name, [(ItemId, ItemQuant)]
is)

addSleep :: MonadServerAtomic m => ActorId -> m ()
addSleep :: forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
addSleep ActorId
aid = do
  b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
  addCondition True IK.S_ASLEEP aid
  execUpdAtomic $ UpdWaitActor aid (bwatch b) WSleep

removeSleepSingle :: MonadServerAtomic m => ActorId -> m ()
removeSleepSingle :: forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
removeSleepSingle ActorId
aid = do
  nAll <- GroupName ItemKind -> ActorId -> m Int
forall (m :: * -> *).
MonadServerAtomic m =>
GroupName ItemKind -> ActorId -> m Int
removeConditionSingle GroupName ItemKind
IK.S_ASLEEP ActorId
aid
  when (nAll == 0) $
    execUpdAtomic $ UpdWaitActor aid WWake WWatch

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