{-# LANGUAGE TupleSections #-}
module Game.LambdaHack.Server.CommonM
( revealItems, moveStores, generalMoveItem
, deduceQuits, deduceKilled, electLeader, setFreshLeader
, updatePer, recomputeCachePer, projectFail
, addActorFromGroup, registerActor, discoverIfMinorEffects
, pickWeaponServer, currentSkillsServer, allGroupItems
, addCondition, removeConditionSingle, addSleep, removeSleepSingle
, addKillToAnalytics
#ifdef EXPOSE_INTERNAL
, containerMoveItem, quitF, keepArenaFact, anyActorsAlive, projectBla
, addProjectile, addActorIid, getCacheLucid, getCacheTotal
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import qualified Data.EnumMap.Strict as EM
import qualified Data.Ord as Ord
import Data.Ratio
import Game.LambdaHack.Atomic
import Game.LambdaHack.Client (ClientOptions (..))
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Analytics
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.ItemAspect as IA
import Game.LambdaHack.Common.Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.ReqFailure
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Common.Types
import Game.LambdaHack.Content.ItemKind (ItemKind)
import qualified Game.LambdaHack.Content.ItemKind as IK
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.RuleKind
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Core.Random
import qualified Game.LambdaHack.Definition.Ability as Ability
import Game.LambdaHack.Definition.Defs
import Game.LambdaHack.Server.Fov
import Game.LambdaHack.Server.ItemM
import Game.LambdaHack.Server.ItemRev
import Game.LambdaHack.Server.MonadServer
import Game.LambdaHack.Server.ServerOptions
import Game.LambdaHack.Server.State
revealItems :: MonadServerAtomic m => FactionId -> m ()
revealItems fid = do
COps{coitem} <- getsState scops
ServerOptions{sclientOptions} <- getsServer soptions
discoAspect <- getsState sdiscoAspect
let discover aid store iid _ = do
itemKindId <- getsState $ getIidKindIdServer iid
let arItem = discoAspect EM.! iid
c = CActor aid store
itemKind = okind coitem itemKindId
unless (IA.isHumanTrinket itemKind) $
execUpdAtomic $ UpdDiscover c iid itemKindId arItem
f (aid, b) =
join $ getsState $ mapActorItems_ (discover aid) b
aids <- getsState $ fidActorNotProjGlobalAssocs fid
mapM_ f aids
dungeon <- getsState sdungeon
let minLid = fst $ minimumBy (Ord.comparing (ldepth . snd))
$ EM.assocs dungeon
discoverSample iid = do
itemKindId <- getsState $ getIidKindIdServer iid
let arItem = discoAspect EM.! iid
cdummy = CTrunk fid minLid originPoint
itemKind = okind coitem itemKindId
unless (IA.isHumanTrinket itemKind) $
execUpdAtomic $ UpdDiscover cdummy iid itemKindId arItem
generationAn <- getsServer sgenerationAn
getKindId <- getsState $ flip getIidKindIdServer
let kindsEqual iid iid2 = getKindId iid == getKindId iid2 && iid /= iid2
nonDupSample em iid 0 = not $ any (kindsEqual iid) $ EM.keys em
nonDupSample _ _ _ = True
nonDupGen = EM.map (\em -> EM.filterWithKey (nonDupSample em) em)
generationAn
modifyServer $ \ser -> ser {sgenerationAn = nonDupGen}
when (sexposeActors sclientOptions) $
mapM_ discoverSample $ EM.keys $ nonDupGen EM.! STrunk
when (sexposeItems sclientOptions) $
mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SItem
mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SEmbed
mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SOrgan
mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SCondition
mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SBlast
moveStores :: MonadServerAtomic m
=> Bool -> ActorId -> CStore -> CStore -> m ()
moveStores verbose aid fromStore toStore = do
b <- getsState $ getActorBody aid
let g iid (k, _) = do
move <- generalMoveItem verbose iid k (CActor aid fromStore)
(CActor aid toStore)
mapM_ execUpdAtomic move
mapActorCStore_ fromStore g b
generalMoveItem :: MonadStateRead m
=> Bool -> ItemId -> Int -> Container -> Container
-> m [UpdAtomic]
generalMoveItem _ iid k (CActor aid1 cstore1) (CActor aid2 cstore2)
| aid1 == aid2 && cstore1 /= CSha && cstore2 /= CSha
= return [UpdMoveItem iid k aid1 cstore1 cstore2]
generalMoveItem verbose iid k c1 c2 = containerMoveItem verbose iid k c1 c2
containerMoveItem :: MonadStateRead m
=> Bool -> ItemId -> Int -> Container -> Container
-> m [UpdAtomic]
containerMoveItem verbose iid k c1 c2 = do
bag <- getsState $ getContainerBag c1
case iid `EM.lookup` bag of
Nothing -> error $ "" `showFailure` (iid, k, c1, c2)
Just (_, it) -> do
item <- getsState $ getItemBody iid
return [ UpdLoseItem verbose iid item (k, take k it) c1
, UpdSpotItem verbose iid item (k, take k it) c2 ]
quitF :: MonadServerAtomic m => Status -> FactionId -> m ()
quitF status fid = do
fact <- getsState $ (EM.! fid) . sfactionD
let oldSt = gquit fact
case stOutcome <$> oldSt of
Just Killed -> return ()
Just Defeated -> return ()
Just Conquer -> return ()
Just Escape -> return ()
_ -> do
manalytics <-
if fhasUI $ gplayer fact then do
keepAutomated <- getsServer $ skeepAutomated . soptions
when (isAIFact fact
&& fleaderMode (gplayer fact) /= LeaderNull
&& not keepAutomated) $
execUpdAtomic $ UpdAutoFaction fid False
itemD <- getsState sitemD
dungeon <- getsState sdungeon
let ais = EM.assocs itemD
minLid = fst $ minimumBy (Ord.comparing (ldepth . snd))
$ EM.assocs dungeon
execUpdAtomic $ UpdSpotItemBag (CTrunk fid minLid originPoint)
EM.empty ais
revealItems fid
registerScore status fid
factionAn <- getsServer sfactionAn
generationAn <- getsServer sgenerationAn
return $ Just (factionAn, generationAn)
else return Nothing
execUpdAtomic $ UpdQuitFaction fid oldSt (Just status) manalytics
modifyServer $ \ser -> ser {sbreakLoop = True}
deduceQuits :: MonadServerAtomic m => FactionId -> Status -> m ()
deduceQuits fid0 status@Status{stOutcome}
| stOutcome `elem` [Defeated, Camping, Restart, Conquer] =
error $ "no quitting to deduce" `showFailure` (fid0, status)
deduceQuits fid0 status = do
fact0 <- getsState $ (EM.! fid0) . sfactionD
let factHasUI = fhasUI . gplayer
quitFaction (stOutcome, (fid, _)) = quitF status{stOutcome} fid
mapQuitF outfids = do
let (withUI, withoutUI) =
partition (factHasUI . snd . snd)
((stOutcome status, (fid0, fact0)) : outfids)
mapM_ quitFaction (withoutUI ++ withUI)
inGameOutcome (fid, fact) = do
let mout | fid == fid0 = Just $ stOutcome status
| otherwise = stOutcome <$> gquit fact
case mout of
Just Killed -> False
Just Defeated -> False
Just Restart -> False
_ -> True
factionD <- getsState sfactionD
let assocsInGame = filter inGameOutcome $ EM.assocs factionD
assocsKeepArena = filter (keepArenaFact . snd) assocsInGame
assocsUI = filter (factHasUI . snd) assocsInGame
nonHorrorAIG = filter (not . isHorrorFact . snd) assocsInGame
worldPeace =
all (\(fid1, _) -> all (\(fid2, fact2) -> not $ isFoe fid2 fact2 fid1)
nonHorrorAIG)
nonHorrorAIG
othersInGame = filter ((/= fid0) . fst) assocsInGame
if | null assocsUI ->
mapQuitF $ zip (repeat Conquer) othersInGame
| null assocsKeepArena ->
mapQuitF $ zip (repeat Conquer) othersInGame
| worldPeace ->
mapQuitF $ zip (repeat Conquer) othersInGame
| stOutcome status == Escape -> do
let (victors, losers) =
partition (\(fi, _) -> isFriend fid0 fact0 fi) othersInGame
mapQuitF $ zip (repeat Escape) victors ++ zip (repeat Defeated) losers
| otherwise -> quitF status fid0
keepArenaFact :: Faction -> Bool
keepArenaFact fact = fleaderMode (gplayer fact) /= LeaderNull
&& fneverEmpty (gplayer fact)
deduceKilled :: MonadServerAtomic m => ActorId -> m ()
deduceKilled aid = do
body <- getsState $ getActorBody aid
fact <- getsState $ (EM.! bfid body) . sfactionD
when (fneverEmpty $ gplayer fact) $ do
actorsAlive <- anyActorsAlive (bfid body) aid
when (not actorsAlive) $
deduceQuits (bfid body) $ Status Killed (fromEnum $ blid body) Nothing
anyActorsAlive :: MonadServer m => FactionId -> ActorId -> m Bool
anyActorsAlive fid aid = do
as <- getsState $ fidActorNotProjGlobalAssocs fid
return $! any (\(aid2, b2) -> aid2 /= aid && bhp b2 > 0) as
electLeader :: MonadServerAtomic m => FactionId -> LevelId -> ActorId -> m ()
electLeader fid lid aidToReplace = do
mleader <- getsState $ gleader . (EM.! fid) . sfactionD
when (mleader == Just aidToReplace) $ do
allOurs <- getsState $ fidActorNotProjGlobalAssocs fid
let
(positive, negative) = partition (\(_, b) -> bhp b > 0) allOurs
(awake, sleeping) = partition (\(_, b) -> bwatch b /= WSleep) positive
onThisLevel <- getsState $ fidActorRegularAssocs fid lid
let candidates = filter (\(_, b) -> bwatch b /= WSleep) onThisLevel
++ awake ++ sleeping ++ negative
mleaderNew =
listToMaybe $ filter (/= aidToReplace) $ map fst $ candidates
execUpdAtomic $ UpdLeadFaction fid mleader mleaderNew
setFreshLeader :: MonadServerAtomic m => FactionId -> ActorId -> m ()
setFreshLeader fid aid = do
fact <- getsState $ (EM.! fid) . sfactionD
unless (fleaderMode (gplayer fact) == LeaderNull) $ do
b <- getsState $ getActorBody aid
let !_A = assert (not $ bproj b) ()
valid <- getsServer $ (EM.! blid b) . (EM.! fid) . sperValidFid
unless valid $ updatePer fid (blid b)
execUpdAtomic $ UpdLeadFaction fid (gleader fact) (Just aid)
updatePer :: MonadServerAtomic m => FactionId -> LevelId -> m ()
{-# INLINE updatePer #-}
updatePer fid lid = do
modifyServer $ \ser ->
ser {sperValidFid = EM.adjust (EM.insert lid True) fid $ sperValidFid ser}
sperFidOld <- getsServer sperFid
let perOld = sperFidOld EM.! fid EM.! lid
perNew <- recomputeCachePer fid lid
let inPer = diffPer perNew perOld
outPer = diffPer perOld perNew
unless (nullPer outPer && nullPer inPer) $
execSendPer fid lid outPer inPer perNew
recomputeCachePer :: MonadServer m => FactionId -> LevelId -> m Perception
recomputeCachePer fid lid = do
total <- getCacheTotal fid lid
fovLucid <- getCacheLucid lid
let perNew = perceptionFromPTotal fovLucid total
fper = EM.adjust (EM.insert lid perNew) fid
modifyServer $ \ser -> ser {sperFid = fper $ sperFid ser}
return perNew
projectFail :: MonadServerAtomic m
=> ActorId
-> ActorId
-> Point
-> Int
-> Bool
-> ItemId
-> CStore
-> Bool
-> m (Maybe ReqFailure)
projectFail propeller source tpxy eps center iid cstore blast = do
COps{corule=RuleContent{rXmax, rYmax}, coTileSpeedup} <- getsState scops
sb <- getsState $ getActorBody source
let lid = blid sb
spos = bpos sb
lvl <- getLevel lid
case bla rXmax rYmax eps spos tpxy of
Nothing -> return $ Just ProjectAimOnself
Just [] -> error $ "projecting from the edge of level"
`showFailure` (spos, tpxy)
Just (pos : restUnlimited) -> do
bag <- getsState $ getBodyStoreBag sb cstore
case EM.lookup iid bag of
Nothing -> return $ Just ProjectOutOfReach
Just _kit -> do
itemFull <- getsState $ itemToFull iid
actorSk <- currentSkillsServer source
actorMaxSk <- getsState $ getActorMaxSkills source
let skill = Ability.getSk Ability.SkProject actorSk
forced = blast || bproj sb
calmE = calmEnough sb actorMaxSk
legal = permittedProject forced skill calmE itemFull
arItem = aspectRecordFull itemFull
case legal of
Left reqFail -> return $ Just reqFail
Right _ -> do
let lobable = IA.checkFlag Ability.Lobable arItem
rest = if lobable
then take (chessDist spos tpxy - 1) restUnlimited
else restUnlimited
t = lvl `at` pos
if | not $ Tile.isWalkable coTileSpeedup t ->
return $ Just ProjectBlockTerrain
| occupiedBigLvl pos lvl ->
if blast && bproj sb then do
projectBla propeller source spos (pos:rest)
iid cstore blast
return Nothing
else return $ Just ProjectBlockActor
| otherwise -> do
if blast && bproj sb && center then
projectBla propeller source spos (pos:rest)
iid cstore blast
else
projectBla propeller source pos rest iid cstore blast
return Nothing
projectBla :: MonadServerAtomic m
=> ActorId
-> ActorId
-> Point
-> [Point]
-> ItemId
-> CStore
-> Bool
-> m ()
projectBla propeller source pos rest iid cstore blast = do
sb <- getsState $ getActorBody source
let lid = blid sb
localTime <- getsState $ getLocalTime lid
unless blast $ execSfxAtomic $ SfxProject source iid cstore
bag <- getsState $ getBodyStoreBag sb cstore
ItemFull{itemBase, itemKind} <- getsState $ itemToFull iid
case iid `EM.lookup` bag of
Nothing -> error $ "" `showFailure` (source, pos, rest, iid, cstore)
Just kit@(_, it) -> do
let delay =
if IK.iweight itemKind == 0
then timeTurn
else timeZero
btime = absoluteTimeAdd delay localTime
addProjectile propeller pos rest iid kit lid (bfid sb) btime
let c = CActor source cstore
execUpdAtomic $ UpdLoseItem False iid itemBase (1, take 1 it) c
addActorFromGroup :: MonadServerAtomic m
=> GroupName ItemKind -> FactionId -> Point -> LevelId -> Time
-> m (Maybe ActorId)
addActorFromGroup actorGroup bfid pos lid time = do
freq <- prepareItemKind 0 lid [(actorGroup, 1)]
m2 <- rollItemAspect freq lid
case m2 of
Nothing -> return Nothing
Just (itemKnown, itemFullKit) ->
Just <$> registerActor False itemKnown itemFullKit bfid pos lid time
registerActor :: MonadServerAtomic m
=> Bool -> ItemKnown -> ItemFullKit
-> FactionId -> Point -> LevelId -> Time
-> m ActorId
registerActor summoned (ItemKnown kindIx ar _) (itemFullRaw, kit)
bfid pos lid time = do
let container = CTrunk bfid lid pos
jfid = Just bfid
itemKnown = ItemKnown kindIx ar jfid
itemFull = itemFullRaw {itemBase = (itemBase itemFullRaw) {jfid}}
trunkId <- registerItem (itemFull, kit) itemKnown container False
aid <- addNonProjectile summoned trunkId (itemFull, kit) bfid pos lid time
fact <- getsState $ (EM.! bfid) . sfactionD
actorMaxSk <- getsState $ getActorMaxSkills aid
condAnyFoeAdj <- getsState $ anyFoeAdj aid
when (canSleep actorMaxSk &&
not condAnyFoeAdj
&& not summoned
&& not (fhasGender (gplayer fact))) $ do
let sleepOdds = if prefersSleep actorMaxSk then 9%10 else 1%2
sleeps <- rndToAction $ chance sleepOdds
when sleeps $ addSleep aid
return aid
addProjectile :: MonadServerAtomic m
=> ActorId -> Point -> [Point] -> ItemId -> ItemQuant -> LevelId
-> FactionId -> Time
-> m ()
addProjectile propeller pos rest iid (_, it) lid fid time = do
itemFull <- getsState $ itemToFull iid
let arItem = aspectRecordFull itemFull
IK.ThrowMod{IK.throwHP} = IA.aToThrow arItem
(trajectory, (speed, _)) =
IA.itemTrajectory arItem (itemKind itemFull) (pos : rest)
tweakBody b = b { bhp = xM throwHP
, btrajectory = Just (trajectory, speed)
, beqp = EM.singleton iid (1, take 1 it) }
aid <- addActorIid iid itemFull True fid pos lid tweakBody
bp <- getsState $ getActorBody propeller
originator <- if bproj bp
then getsServer $ EM.findWithDefault propeller propeller
. strajPushedBy
else return propeller
modifyServer $ \ser ->
ser { strajTime = updateActorTime fid lid aid time $ strajTime ser
, strajPushedBy = EM.insert aid originator $ strajPushedBy ser }
addNonProjectile :: MonadServerAtomic m
=> Bool -> ItemId -> ItemFullKit -> FactionId -> Point
-> LevelId -> Time
-> m ActorId
addNonProjectile summoned trunkId (itemFull, kit) fid pos lid time = do
let tweakBody b = b { borgan = EM.singleton trunkId kit
, bcalm = if summoned
then xM 5
else bcalm b }
aid <- addActorIid trunkId itemFull False fid pos lid tweakBody
modifyServer $ \ser ->
ser {sactorTime = updateActorTime fid lid aid time $ sactorTime ser}
return aid
addActorIid :: MonadServerAtomic m
=> ItemId -> ItemFull -> Bool -> FactionId -> Point -> LevelId
-> (Actor -> Actor)
-> m ActorId
addActorIid trunkId ItemFull{itemBase, itemKind, itemDisco=ItemDiscoFull arItem}
bproj fid pos lid tweakBody = do
let trunkMaxHP = max 2 $ IA.getSkill Ability.SkMaxHP arItem
hp = xM trunkMaxHP `div` 2
calm = xM (max 0 $ IA.getSkill Ability.SkMaxCalm arItem)
factionD <- getsState sfactionD
curChalSer <- getsServer $ scurChalSer . soptions
let diffBonusCoeff = difficultyCoeff $ cdiff curChalSer
boostFact = not bproj
&& if diffBonusCoeff > 0
then any (fhasUI . gplayer . snd)
(filter (\(fi, fa) -> isFriend fi fa fid)
(EM.assocs factionD))
else any (fhasUI . gplayer . snd)
(filter (\(fi, fa) -> isFoe fi fa fid)
(EM.assocs factionD))
finalHP | boostFact = min (xM 899)
(hp * 2 ^ abs diffBonusCoeff)
| otherwise = hp
maxHP = min (finalHP + xM 100) (2 * finalHP)
bonusHP = fromEnum (maxHP `div` oneM) - trunkMaxHP
healthOrgans = [ (Just bonusHP, ("bonus HP", COrgan))
| bonusHP /= 0 && not bproj ]
b = actorTemplate trunkId finalHP calm pos lid fid bproj
withTrunk =
b {bweapon = if IA.checkFlag Ability.Meleeable arItem then 1 else 0}
bodyTweaked = tweakBody withTrunk
aid <- getsServer sacounter
modifyServer $ \ser -> ser {sacounter = succ aid}
execUpdAtomic $ UpdCreateActor aid bodyTweaked [(trunkId, itemBase)]
forM_ (healthOrgans ++ map (Nothing,) (IK.ikit itemKind))
$ \(mk, (ikText, cstore)) -> do
let container = CActor aid cstore
itemFreq = [(ikText, 1)]
mIidEtc <- rollAndRegisterItem lid itemFreq container False mk
case mIidEtc of
Nothing -> error $ "" `showFailure` (lid, itemFreq, container, mk)
Just (iid, (itemFull2, _)) ->
when (cstore /= CGround) $
discoverIfMinorEffects container iid (itemKindId itemFull2)
return aid
addActorIid _ _ _ _ _ _ _ = error "addActorIid: server ignorant about an item"
discoverIfMinorEffects :: MonadServerAtomic m
=> Container -> ItemId -> ContentId ItemKind -> m ()
discoverIfMinorEffects c iid itemKindId = do
COps{coitem} <- getsState scops
discoAspect <- getsState sdiscoAspect
let arItem = discoAspect EM.! iid
itemKind = okind coitem itemKindId
when (IA.onlyMinorEffects arItem itemKind
&& not (IA.isHumanTrinket itemKind)) $
execUpdAtomic $ UpdDiscover c iid itemKindId arItem
pickWeaponServer :: MonadServer m => ActorId -> m (Maybe (ItemId, CStore))
pickWeaponServer source = do
eqpAssocs <- getsState $ kitAssocs source [CEqp]
bodyAssocs <- getsState $ kitAssocs source [COrgan]
actorSk <- currentSkillsServer source
sb <- getsState $ getActorBody source
let kitAssRaw = eqpAssocs ++ bodyAssocs
forced = bproj sb
kitAss | forced = kitAssRaw
| otherwise =
filter (IA.checkFlag Ability.Meleeable
. aspectRecordFull . fst . snd) kitAssRaw
strongest <- pickWeaponM False Nothing kitAss actorSk source
case strongest of
[] -> return Nothing
iis@((maxS, _) : _) -> do
let maxIis = map snd $ takeWhile ((== maxS) . fst) iis
(_, (iid, _)) <- rndToAction $ oneOf maxIis
let cstore = if isJust (lookup iid bodyAssocs) then COrgan else CEqp
return $ Just (iid, cstore)
currentSkillsServer :: MonadServer m => ActorId -> m Ability.Skills
currentSkillsServer aid = do
body <- getsState $ getActorBody aid
fact <- getsState $ (EM.! bfid body) . sfactionD
let mleader = gleader fact
getsState $ actorCurrentSkills mleader aid
getCacheLucid :: MonadServer m => LevelId -> m FovLucid
getCacheLucid lid = do
fovClearLid <- getsServer sfovClearLid
fovLitLid <- getsServer sfovLitLid
fovLucidLid <- getsServer sfovLucidLid
let getNewLucid = getsState $ \s ->
lucidFromLevel fovClearLid fovLitLid s lid (sdungeon s EM.! lid)
case EM.lookup lid fovLucidLid of
Just (FovValid fovLucid) -> return fovLucid
_ -> do
newLucid <- getNewLucid
modifyServer $ \ser ->
ser {sfovLucidLid = EM.insert lid (FovValid newLucid)
$ sfovLucidLid ser}
return newLucid
getCacheTotal :: MonadServer m => FactionId -> LevelId -> m CacheBeforeLucid
getCacheTotal fid lid = do
sperCacheFidOld <- getsServer sperCacheFid
let perCacheOld = sperCacheFidOld EM.! fid EM.! lid
case ptotal perCacheOld of
FovValid total -> return total
FovInvalid -> do
actorMaxSkills <- getsState sactorMaxSkills
fovClearLid <- getsServer sfovClearLid
getActorB <- getsState $ flip getActorBody
let perActorNew =
perActorFromLevel (perActor perCacheOld) getActorB
actorMaxSkills (fovClearLid EM.! lid)
total = totalFromPerActor perActorNew
perCache = PerceptionCache { ptotal = FovValid total
, perActor = perActorNew }
fperCache = EM.adjust (EM.insert lid perCache) fid
modifyServer $ \ser -> ser {sperCacheFid = fperCache $ sperCacheFid ser}
return total
allGroupItems :: MonadServerAtomic m
=> CStore -> GroupName ItemKind -> ActorId
-> m [(ItemId, ItemQuant)]
allGroupItems store grp target = do
b <- getsState $ getActorBody target
getKind <- getsState $ flip getIidKindServer
let hasGroup (iid, _) =
maybe False (> 0) $ lookup grp $ IK.ifreq $ getKind iid
assocsCStore <- getsState $ EM.assocs . getBodyStoreBag b store
return $! filter hasGroup assocsCStore
addCondition :: MonadServerAtomic m => GroupName ItemKind -> ActorId -> m ()
addCondition name aid = do
b <- getsState $ getActorBody aid
let c = CActor aid COrgan
mresult <- rollAndRegisterItem (blid b) [(name, 1)] c False Nothing
assert (isJust mresult) $ return ()
removeConditionSingle :: MonadServerAtomic m
=> GroupName ItemKind -> ActorId -> m Int
removeConditionSingle name aid = do
let c = CActor aid COrgan
is <- allGroupItems COrgan name aid
case is of
[(iid, (nAll, itemTimer))] -> do
itemBase <- getsState $ getItemBody iid
execUpdAtomic $ UpdLoseItem False iid itemBase (1, itemTimer) c
return $ nAll - 1
_ -> error $ "missing or multiple item" `showFailure` (name, is)
addSleep :: MonadServerAtomic m => ActorId -> m ()
addSleep aid = do
b <- getsState $ getActorBody aid
addCondition "asleep" aid
execUpdAtomic $ UpdWaitActor aid (bwatch b) WSleep
removeSleepSingle :: MonadServerAtomic m => ActorId -> m ()
removeSleepSingle aid = do
nAll <- removeConditionSingle "asleep" aid
when (nAll == 0) $
execUpdAtomic $ UpdWaitActor aid WWake WWatch
addKillToAnalytics :: MonadServerAtomic m
=> ActorId -> KillHow -> FactionId -> ItemId -> m ()
addKillToAnalytics aid killHow fid iid = do
actorD <- getsState sactorD
case EM.lookup aid actorD of
Just b ->
modifyServer $ \ser ->
ser { sfactionAn = addFactionKill (bfid b) killHow fid iid
$ sfactionAn ser
, sactorAn = addActorKill aid killHow fid iid
$ sactorAn ser }
Nothing -> return ()