{-# LANGUAGE TupleSections #-}
module Game.LambdaHack.Server.CommonM
( execFailure, revealItems, moveStores, generalMoveItem
, deduceQuits, deduceKilled, electLeader, supplantLeader
, updatePer, recomputeCachePer, projectFail
, addActorFromGroup, registerActor, discoverIfMinorEffects
, pickWeaponServer, currentSkillsServer
#ifdef EXPOSE_INTERNAL
, containerMoveItem, quitF, keepArenaFact, anyActorsAlive, projectBla
, addProjectile, addActorIid, getCacheLucid, getCacheTotal
#endif
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import qualified Data.EnumMap.Strict as EM
import qualified Data.Text as T
import qualified Text.Show.Pretty as Show.Pretty
import Game.LambdaHack.Atomic
import Game.LambdaHack.Client
import qualified Game.LambdaHack.Common.Ability as Ability
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
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.Random
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.Content.ItemKind (ItemKind)
import qualified Game.LambdaHack.Content.ItemKind as IK
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.RuleKind
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
execFailure :: MonadServerAtomic m
=> ActorId -> RequestTimed a -> ReqFailure -> m ()
execFailure aid req failureSer = do
body <- getsState $ getActorBody aid
let fid = bfid body
msg = showReqFailure failureSer
impossible = impossibleReqFailure failureSer
debugShow :: Show a => a -> Text
debugShow = T.pack . Show.Pretty.ppShow
possiblyAlarm = if impossible
then debugPossiblyPrintAndExit
else debugPossiblyPrint
possiblyAlarm $
"execFailure:" <+> msg <> "\n"
<> debugShow body <> "\n" <> debugShow req <> "\n" <> debugShow failureSer
execSfxAtomic $ SfxMsgFid fid $ SfxUnexpected failureSer
revealItems :: MonadServerAtomic m => Maybe FactionId -> m ()
revealItems mfid = do
COps{coitem} <- getsState scops
let discover aid store iid _ = do
itemKindId <- getsState $ getIidKindIdServer iid
let itemKind = okind coitem itemKindId
c = CActor aid store
unless (IK.isHumanTrinket itemKind) $ do
seed <- getsServer $ (EM.! iid) . sitemSeedD
execUpdAtomic $ UpdDiscover c iid itemKindId seed
f aid = do
b <- getsState $ getActorBody aid
let ourSide = maybe True (== bfid b) mfid
when (not (bproj b) && ourSide) $
join $ getsState $ mapActorItems_ (discover aid) b
as <- getsState $ EM.keys . sactorD
mapM_ f as
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 verbose iid k c1 c2 =
case (c1, c2) of
(CActor aid1 cstore1, CActor aid2 cstore2) | aid1 == aid2
&& cstore1 /= CSha
&& cstore2 /= CSha ->
return [UpdMoveItem iid k aid1 cstore1 cstore2]
_ -> 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
when (fhasUI $ gplayer fact) $ do
keepAutomated <- getsServer $ skeepAutomated . soptions
when (isAIFact fact
&& fleaderMode (gplayer fact) /= LeaderNull
&& not keepAutomated) $
execUpdAtomic $ UpdAutoFaction fid False
revealItems (Just fid)
registerScore status fid
execUpdAtomic $ UpdQuitFaction fid oldSt $ Just status
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
cops <- getsState scops
body <- getsState $ getActorBody aid
let firstDeathEnds = rfirstDeathEnds $ getStdRuleset cops
fact <- getsState $ (EM.! bfid body) . sfactionD
when (fneverEmpty $ gplayer fact) $ do
actorsAlive <- anyActorsAlive (bfid body) aid
when (not actorsAlive || firstDeathEnds) $
deduceQuits (bfid body) $ Status Killed (fromEnum $ blid body) Nothing
anyActorsAlive :: MonadServer m => FactionId -> ActorId -> m Bool
anyActorsAlive fid aid = do
as <- getsState $ fidActorNotProjAssocs fid
return $! any (\(aid2, b2) -> aid2 /= aid && bhp b2 > 0) as
electLeader :: MonadServerAtomic m => FactionId -> LevelId -> ActorId -> m ()
electLeader fid lid aidDead = do
mleader <- getsState $ gleader . (EM.! fid) . sfactionD
when (mleader == Just aidDead) $ do
actorD <- getsState sactorD
let ours (_, b) = bfid b == fid && not (bproj b)
party = filter ours $ EM.assocs actorD
(positive, negative) = partition (\(_, b) -> bhp b > 0) party
onLevel <- getsState $ fidActorRegularIds fid lid
let mleaderNew = case filter (/= aidDead)
$ onLevel ++ map fst (positive ++ negative) of
[] -> Nothing
aid : _ -> Just aid
execUpdAtomic $ UpdLeadFaction fid mleader mleaderNew
supplantLeader :: MonadServerAtomic m => FactionId -> ActorId -> m ()
supplantLeader 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
-> Point
-> Int
-> Bool
-> ItemId
-> CStore
-> Bool
-> m (Maybe ReqFailure)
projectFail source tpxy eps center iid cstore blast = do
COps{coTileSpeedup} <- getsState scops
sb <- getsState $ getActorBody source
let lid = blid sb
spos = bpos sb
lvl@Level{lxsize, lysize} <- getLevel lid
case bla lxsize lysize 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@ItemFull{itemKind} <- getsState $ itemToFull iid
actorSk <- currentSkillsServer source
ar <- getsState $ getActorAspect source
let skill = EM.findWithDefault 0 Ability.AbProject actorSk
forced = blast || bproj sb
calmE = calmEnough sb ar
legal = permittedProject forced skill calmE itemFull
case legal of
Left reqFail -> return $ Just reqFail
Right _ -> do
let lobable = IK.Lobable `elem` IK.ifeature itemKind
rest = if lobable
then take (chessDist spos tpxy - 1) restUnlimited
else restUnlimited
t = lvl `at` pos
if not $ Tile.isWalkable coTileSpeedup t
then return $ Just ProjectBlockTerrain
else do
lab <- getsState $ posToAssocs pos lid
if not $ all (bproj . snd) lab
then if blast && bproj sb then do
projectBla source spos (pos:rest) iid cstore blast
return Nothing
else return $ Just ProjectBlockActor
else do
if blast && bproj sb && center then
projectBla source spos (pos:rest) iid cstore blast
else
projectBla source pos rest iid cstore blast
return Nothing
projectBla :: MonadServerAtomic m
=> ActorId
-> Point
-> [Point]
-> ItemId
-> CStore
-> Bool
-> m ()
projectBla 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 timeClip
btime = absoluteTimeAdd delay localTime
addProjectile 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
let trunkFreq = [(actorGroup, 1)]
m4 <- rollItem 0 lid trunkFreq
case m4 of
Nothing -> return Nothing
Just (itemKnown, itemFullKit, seed, _) ->
Just <$> registerActor False itemKnown itemFullKit seed bfid pos lid time
registerActor :: MonadServerAtomic m
=> Bool -> ItemKnown -> ItemFullKit -> IA.ItemSeed
-> FactionId -> Point -> LevelId -> Time
-> m ActorId
registerActor summoned (kindIx, ar, _) (itemFullRaw, kit)
seed bfid pos lid time = do
let container = CTrunk bfid lid pos
jfid = Just bfid
itemKnown = (kindIx, ar, jfid)
itemFull = itemFullRaw {itemBase = (itemBase itemFullRaw) {jfid}}
trunkId <- registerItem (itemFull, kit) itemKnown seed container False
addNonProjectile summoned trunkId (itemFull, kit) bfid pos lid time
addProjectile :: MonadServerAtomic m
=> Point -> [Point] -> ItemId -> ItemQuant -> LevelId -> FactionId
-> Time
-> m ()
addProjectile bpos rest iid (_, it) blid bfid btime = do
itemFull <- getsState $ itemToFull iid
let (trajectory, (speed, _)) =
IK.itemTrajectory (itemKind itemFull) (bpos : rest)
tweakBody b = b { bhp = oneM
, btrajectory = Just (trajectory, speed)
, beqp = EM.singleton iid (1, take 1 it) }
void $ addActorIid iid itemFull True bfid bpos blid tweakBody btime
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 bcalm b * 2 `div` 3 - xM 3
else bcalm b }
addActorIid trunkId itemFull False fid pos lid tweakBody time
addActorIid :: MonadServerAtomic m
=> ItemId -> ItemFull -> Bool -> FactionId -> Point -> LevelId
-> (Actor -> Actor) -> Time
-> m ActorId
addActorIid trunkId ItemFull{itemBase, itemKind, itemDisco}
bproj bfid pos lid tweakBody time = do
let hp = xM (max 2 $ IA.aMaxHP $ itemAspect itemDisco) `div` 2
calm = xM (max 0 $ IA.aMaxCalm $ itemAspect itemDisco)
factionD <- getsState sfactionD
curChalSer <- getsServer $ scurChalSer . soptions
nU <- nUI
let diffBonusCoeff = difficultyCoeff $ cdiff curChalSer
hasUIorEscapes Faction{gplayer} =
fhasUI gplayer || nU == 0 && fcanEscape gplayer
boostFact = not bproj
&& if diffBonusCoeff > 0
then any (hasUIorEscapes . snd)
(filter (\(fi, fa) -> isFriend fi fa bfid)
(EM.assocs factionD))
else any (hasUIorEscapes . snd)
(filter (\(fi, fa) -> isFoe fi fa bfid)
(EM.assocs factionD))
diffHP | boostFact = if cdiff curChalSer `elem` [1, difficultyBound]
then xM 999 - hp
else hp * 2 ^ abs diffBonusCoeff
| otherwise = hp
bonusHP = fromEnum $ (diffHP - hp) `divUp` oneM
healthOrgans = [(Just bonusHP, ("bonus HP", COrgan)) | bonusHP /= 0]
b = actorTemplate trunkId diffHP calm pos lid bfid bproj
withTrunk = b {bweapon = if IK.isMelee itemKind then 1 else 0}
aid <- getsServer sacounter
modifyServer $ \ser -> ser {sacounter = succ aid}
modifyServer $ \ser ->
ser {sactorTime = updateActorTime bfid lid aid time $ sactorTime ser}
execUpdAtomic $ UpdCreateActor aid (tweakBody withTrunk) [(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, _), _)) ->
discoverIfMinorEffects container iid (itemKindId itemFull2)
return aid
discoverIfMinorEffects :: MonadServerAtomic m
=> Container -> ItemId -> ContentId ItemKind -> m ()
discoverIfMinorEffects c iid itemKindId = do
COps{coitem} <- getsState scops
let itemKind = okind coitem itemKindId
if IK.onlyMinorEffects itemKind
then do
seed <- getsServer $ (EM.! iid) . sitemSeedD
execUpdAtomic $ UpdDiscover c iid itemKindId seed
else return ()
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 (IK.isMelee . itemKind . fst . snd) kitAssRaw
strongest <- pickWeaponM 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 $ actorSkills 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
actorAspect <- getsState sactorAspect
fovClearLid <- getsServer sfovClearLid
getActorB <- getsState $ flip getActorBody
let perActorNew =
perActorFromLevel (perActor perCacheOld) getActorB
actorAspect (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