{-# LANGUAGE TupleSections #-}
module Game.LambdaHack.Server.CommonM
( execFailure, revealItems, moveStores, generalMoveItem
, deduceQuits, deduceKilled, electLeader, supplantLeader
, updatePer, recomputeCachePer, projectFail
, addActor, registerActor, addActorIid, discoverIfNoEffects
, pickWeaponServer, currentSkillsServer
#ifdef EXPOSE_INTERNAL
, containerMoveItem, quitF, keepArenaFact, anyActorsAlive, projectBla
, addProjectile, 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 Game.LambdaHack.Common.ItemStrongest
import qualified Game.LambdaHack.Common.Kind as 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
itemToF <- getsState itemToFull
let discover aid store iid k =
let itemFull = itemToF iid k
c = CActor aid store
in case itemDisco itemFull of
Just ItemDisco{itemKindId, itemKind} -> do
let isGem = maybe False (> 0) (lookup "gem" $ IK.ifreq itemKind)
unless isGem $ do
seed <- getsServer $ (EM.! iid) . sitemSeedD
execUpdAtomic $ UpdDiscover c iid itemKindId seed
_ -> error $ "" `showFailure` (mfid, c, iid, itemFull)
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 {squit = 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 (\(_, fact2) -> not $ isAtWar 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 (flip isAllied fid0 . snd) 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
Kind.COps{corule} <- getsState scops
body <- getsState $ getActorBody aid
let firstDeathEnds = rfirstDeathEnds $ Kind.stdRuleset corule
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 $! map fst as /= [aid]
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
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
knowEvents <- getsServer $ sknowEvents . soptions
perNew <- recomputeCachePer fid lid
let inPer = diffPer perNew perOld
outPer = diffPer perOld perNew
unless (nullPer outPer && nullPer inPer) $
unless knowEvents $
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
-> ItemId
-> CStore
-> Bool
-> m (Maybe ReqFailure)
projectFail source tpxy eps iid cstore isBlast = do
Kind.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
itemToF <- getsState itemToFull
actorSk <- currentSkillsServer source
ar <- getsState $ getActorAspect source
let skill = EM.findWithDefault 0 Ability.AbProject actorSk
itemFull@ItemFull{itemBase} = itemToF iid kit
forced = isBlast || 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` jfeature itemBase
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 isBlast && bproj sb then do
projectBla source spos (pos:rest) iid cstore isBlast
return Nothing
else return $ Just ProjectBlockActor
else do
if isBlast && bproj sb && eps `mod` 2 == 0 then
projectBla source spos (pos:rest) iid cstore isBlast
else
projectBla source pos rest iid cstore isBlast
return Nothing
projectBla :: MonadServerAtomic m
=> ActorId
-> Point
-> [Point]
-> ItemId
-> CStore
-> Bool
-> m ()
projectBla source pos rest iid cstore isBlast = do
sb <- getsState $ getActorBody source
item <- getsState $ getItemBody iid
let lid = blid sb
localTime <- getsState $ getLocalTime lid
unless isBlast $ execSfxAtomic $ SfxProject source iid cstore
bag <- getsState $ getBodyStoreBag sb cstore
case iid `EM.lookup` bag of
Nothing -> error $ "" `showFailure` (source, pos, rest, iid, cstore)
Just kit@(_, it) -> do
let btime = absoluteTimeAdd timeEpsilon localTime
addProjectile pos rest iid kit lid (bfid sb) btime isBlast
let c = CActor source cstore
execUpdAtomic $ UpdLoseItem False iid item (1, take 1 it) c
addProjectile :: MonadServerAtomic m
=> Point -> [Point] -> ItemId -> ItemQuant -> LevelId
-> FactionId -> Time -> Bool
-> m ()
addProjectile bpos rest iid (_, it) blid bfid btime _isBlast = do
itemToF <- getsState itemToFull
let itemFull@ItemFull{itemBase} = itemToF iid (1, take 1 it)
(trajectory, (speed, _)) = itemTrajectory itemBase (bpos : rest)
tweakBody b = b { bhp = oneM
, bproj = True
, btrajectory = Just (trajectory, speed)
, beqp = EM.singleton iid (1, take 1 it)
, borgan = EM.empty }
void $ addActorIid iid itemFull True bfid bpos blid tweakBody btime
addActor :: MonadServerAtomic m
=> GroupName ItemKind -> FactionId -> Point -> LevelId
-> (Actor -> Actor) -> Time
-> m (Maybe ActorId)
addActor actorGroup bfid pos lid tweakBody time = do
let trunkFreq = [(actorGroup, 1)]
m5 <- rollItem 0 lid trunkFreq
case m5 of
Nothing -> return Nothing
Just (itemKnownRaw, itemFullRaw, _, seed, _) ->
registerActor itemKnownRaw itemFullRaw seed bfid pos lid tweakBody time
registerActor :: MonadServerAtomic m
=> ItemKnown -> ItemFull -> ItemSeed
-> FactionId -> Point -> LevelId -> (Actor -> Actor) -> Time
-> m (Maybe ActorId)
registerActor (kindIx, ar, damage, _) itemFullRaw seed
bfid pos lid tweakBody time = do
let container = CTrunk bfid lid pos
jfid = Just bfid
itemKnown = (kindIx, ar, damage, jfid)
itemFull = itemFullRaw {itemBase = (itemBase itemFullRaw) {jfid}}
trunkId <- registerItem itemFull itemKnown seed container False
addActorIid trunkId itemFull False bfid pos lid tweakBody time
addActorIid :: MonadServerAtomic m
=> ItemId -> ItemFull -> Bool -> FactionId -> Point -> LevelId
-> (Actor -> Actor) -> Time
-> m (Maybe ActorId)
addActorIid trunkId trunkFull@ItemFull{..} bproj
bfid pos lid tweakBody time = do
let trunkKind = case itemDisco of
Just ItemDisco{itemKind} -> itemKind
Nothing -> error $ "" `showFailure` trunkFull
aspects = fromJust $ itemAspect $ fromJust itemDisco
hp = xM (max 2 $ aMaxHP aspects) `div` 2
calm = xM (max 0 $ aMaxCalm aspects)
factionD <- getsState sfactionD
let fact = factionD EM.! bfid
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 hasUIorEscapes fact
|| any hasUIorEscapes
(filter (`isAllied` bfid) $ EM.elems factionD)
else any hasUIorEscapes
(filter (`isAtWar` bfid) $ EM.elems 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
withTrunk = b { borgan = EM.singleton trunkId (itemK, itemTimer)
, bweapon = if isMelee itemBase then 1 else 0 }
aid <- getsServer sacounter
modifyServer $ \ser -> ser {sacounter = succ aid}
execUpdAtomic $ UpdCreateActor aid (tweakBody withTrunk) [(trunkId, itemBase)]
modifyServer $ \ser ->
ser {sactorTime = updateActorTime bfid lid aid time $ sactorTime ser}
forM_ (healthOrgans ++ map (Nothing,) (IK.ikit trunkKind))
$ \(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, (itemFull, _)) -> discoverIfNoEffects container iid itemFull
return $ Just aid
discoverIfNoEffects :: MonadServerAtomic m
=> Container -> ItemId -> ItemFull -> m ()
discoverIfNoEffects c iid itemFull = case itemFull of
ItemFull{itemDisco=Just ItemDisco{itemKind}}
| any IK.forIdEffect (IK.ieffects itemKind)
|| maybe False (> 0) (lookup "gem" $ IK.ifreq itemKind) ->
return ()
ItemFull{itemDisco=Just ItemDisco{itemKindId}} -> do
seed <- getsServer $ (EM.! iid) . sitemSeedD
execUpdAtomic $ UpdDiscover c iid itemKindId seed
_ -> error "server doesn't fully know item"
pickWeaponServer :: MonadServer m => ActorId -> m (Maybe (ItemId, CStore))
pickWeaponServer source = do
eqpAssocs <- getsState $ fullAssocs source [CEqp]
bodyAssocs <- getsState $ fullAssocs source [COrgan]
actorSk <- currentSkillsServer source
sb <- getsState $ getActorBody source
let allAssocsRaw = eqpAssocs ++ bodyAssocs
forced = bproj sb
allAssocs | forced = allAssocsRaw
| otherwise = filter (isMelee . itemBase . snd) allAssocsRaw
strongest <- pickWeaponM Nothing allAssocs 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