{-# LANGUAGE GADTs #-}
module Game.LambdaHack.Server.HandleRequestM
( handleRequestAI, handleRequestUI, handleRequestTimed, switchLeader
, reqMove, reqDisplace, reqAlterFail, reqGameDropAndExit, reqGameSaveAndExit
#ifdef EXPOSE_INTERNAL
, setBWait, managePerRequest, handleRequestTimedCases
, affectSmell, reqMelee, reqAlter, reqWait
, reqMoveItems, reqMoveItem, computeRndTimeout, reqProject, reqApply
, reqGameRestart, reqGameSave, reqTactic, reqAutomate
#endif
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import qualified Data.EnumMap.Strict as EM
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.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.Common.Vector
import qualified Game.LambdaHack.Content.ItemKind as IK
import Game.LambdaHack.Content.ModeKind
import qualified Game.LambdaHack.Content.TileKind as TK
import Game.LambdaHack.Server.CommonM
import Game.LambdaHack.Server.HandleEffectM
import Game.LambdaHack.Server.ItemM
import Game.LambdaHack.Server.MonadServer
import Game.LambdaHack.Server.PeriodicM
import Game.LambdaHack.Server.ServerOptions
import Game.LambdaHack.Server.State
handleRequestAI :: MonadServerAtomic m
=> ReqAI
-> m (Maybe RequestAnyAbility)
handleRequestAI cmd = case cmd of
ReqAITimed cmdT -> return $ Just cmdT
ReqAINop -> return Nothing
handleRequestUI :: MonadServerAtomic m
=> FactionId -> ActorId -> ReqUI
-> m (Maybe RequestAnyAbility)
handleRequestUI fid aid cmd = case cmd of
ReqUITimed cmdT -> return $ Just cmdT
ReqUIGameRestart t d -> reqGameRestart aid t d >> return Nothing
ReqUIGameDropAndExit -> reqGameDropAndExit aid >> return Nothing
ReqUIGameSaveAndExit -> reqGameSaveAndExit aid >> return Nothing
ReqUIGameSave -> reqGameSave >> return Nothing
ReqUITactic toT -> reqTactic fid toT >> return Nothing
ReqUIAutomate -> reqAutomate fid >> return Nothing
ReqUINop -> return Nothing
setBWait :: MonadServerAtomic m
=> RequestTimed a -> ActorId -> Actor -> m (Maybe Bool)
{-# INLINE setBWait #-}
setBWait cmd aid b = do
let mwait = case cmd of
ReqWait -> Just True
ReqWait10 -> Just False
_ -> Nothing
when ((mwait == Just True) /= bwait b) $
execUpdAtomic $ UpdWaitActor aid (mwait == Just True)
return mwait
handleRequestTimed :: MonadServerAtomic m
=> FactionId -> ActorId -> RequestTimed a -> m Bool
handleRequestTimed fid aid cmd = do
b <- getsState $ getActorBody aid
mwait <- setBWait cmd aid b
unless (mwait == Just True) $ overheadActorTime fid (blid b)
advanceTime aid (if mwait == Just False then 10 else 100) True
handleRequestTimedCases aid cmd
managePerRequest aid
return $! isNothing mwait
managePerRequest :: MonadServerAtomic m => ActorId -> m ()
managePerRequest aid = do
b <- getsState $ getActorBody aid
let clearMark = 0
unless (bcalmDelta b == ResDelta (0, 0) (0, 0)) $
execUpdAtomic $ UpdRefillCalm aid clearMark
unless (bhpDelta b == ResDelta (0, 0) (0, 0)) $
execUpdAtomic $ UpdRefillHP aid clearMark
handleRequestTimedCases :: MonadServerAtomic m
=> ActorId -> RequestTimed a -> m ()
handleRequestTimedCases aid cmd = case cmd of
ReqMove target -> reqMove aid target
ReqMelee target iid cstore -> reqMelee aid target iid cstore
ReqDisplace target -> reqDisplace aid target
ReqAlter tpos -> reqAlter aid tpos
ReqWait -> reqWait aid
ReqWait10 -> reqWait aid
ReqMoveItems l -> reqMoveItems aid l
ReqProject p eps iid cstore -> reqProject aid p eps iid cstore
ReqApply iid cstore -> reqApply aid iid cstore
switchLeader :: MonadServerAtomic m => FactionId -> ActorId -> m ()
{-# INLINE switchLeader #-}
switchLeader fid aidNew = do
fact <- getsState $ (EM.! fid) . sfactionD
bPre <- getsState $ getActorBody aidNew
let mleader = gleader fact
!_A1 = assert (Just aidNew /= mleader
&& not (bproj bPre)
`blame` (aidNew, bPre, fid, fact)) ()
!_A2 = assert (bfid bPre == fid
`blame` "client tries to move other faction actors"
`swith` (aidNew, bPre, fid, fact)) ()
let (autoDun, _) = autoDungeonLevel fact
arena <- case mleader of
Nothing -> return $! blid bPre
Just leader -> do
b <- getsState $ getActorBody leader
return $! blid b
if | blid bPre /= arena && autoDun ->
execFailure aidNew ReqWait NoChangeDunLeader
| otherwise -> do
execUpdAtomic $ UpdLeadFaction fid mleader (Just aidNew)
case mleader of
Just aidOld | aidOld /= aidNew -> swapTime aidOld aidNew
_ -> return ()
affectSmell :: MonadServerAtomic m => ActorId -> m ()
affectSmell aid = do
b <- getsState $ getActorBody aid
unless (bproj b) $ do
fact <- getsState $ (EM.! bfid b) . sfactionD
ar <- getsState $ getActorAspect aid
let smellRadius = IA.aSmell ar
when (fhasGender (gplayer fact) || smellRadius > 0) $ do
localTime <- getsState $ getLocalTime $ blid b
lvl <- getLevel $ blid b
let oldS = fromMaybe timeZero $ EM.lookup (bpos b) . lsmell $ lvl
newTime = timeShift localTime smellTimeout
newS = if smellRadius > 0
then timeZero
else newTime
when (oldS /= newS) $
execUpdAtomic $ UpdAlterSmell (blid b) (bpos b) oldS newS
reqMove :: MonadServerAtomic m => ActorId -> Vector -> m ()
reqMove source dir = do
COps{coTileSpeedup} <- getsState scops
sb <- getsState $ getActorBody source
let lid = blid sb
lvl <- getLevel lid
let spos = bpos sb
tpos = spos `shift` dir
collides <- getsState $ \s tb ->
let sitemKind = getIidKindServer (btrunk sb) s
titemKind = getIidKindServer (btrunk tb) s
bursting itemKind = IK.Fragile `elem` IK.ifeature itemKind
&& IK.Lobable `elem` IK.ifeature itemKind
sbursting = bursting sitemKind
tbursting = bursting titemKind
damaging itemKind = IK.idamage itemKind /= 0
sdamaging = damaging sitemKind
tdamaging = damaging titemKind
sameBlast = IK.isBlast sitemKind
&& getIidKindIdServer (btrunk sb) s
== getIidKindIdServer (btrunk tb) s
in not sameBlast
&& (sbursting && (tdamaging || tbursting)
|| (tbursting && (sdamaging || sbursting)))
tgt <- getsState $ posToAssocs tpos lid
case tgt of
(target, tb) : _ | not (bproj sb) || not (bproj tb) || collides tb -> do
mweapon <- pickWeaponServer source
case mweapon of
Nothing -> reqWait source
Just (wp, cstore) -> reqMelee source target wp cstore
_ | Tile.isWalkable coTileSpeedup $ lvl `at` tpos -> do
execUpdAtomic $ UpdMoveActor source spos tpos
affectSmell source
| otherwise ->
execFailure source (ReqMove dir) MoveNothing
reqMelee :: MonadServerAtomic m
=> ActorId -> ActorId -> ItemId -> CStore -> m ()
reqMelee source target iid cstore = do
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
let req = ReqMelee target iid cstore
if source == target then execFailure source req MeleeSelf
else if not (checkAdjacent sb tb) then execFailure source req MeleeDistant
else do
let sfid = bfid sb
tfid = bfid tb
haltProjectile aid b = case btrajectory b of
btra@(Just (l, speed)) | not $ null l ->
execUpdAtomic $ UpdTrajectory aid btra $ Just ([], speed)
_ -> return ()
sfact <- getsState $ (EM.! sfid) . sfactionD
itemKind <- getsState $ getIidKindServer $ btrunk tb
if bproj tb && EM.size (beqp tb) == 1 && not (IK.isBlast itemKind)
&& cstore == COrgan then do
execSfxAtomic $ SfxSteal source target iid cstore
case EM.assocs $ beqp tb of
[(iid2, (k, _))] -> do
upds <- generalMoveItem True iid2 k (CActor target CEqp)
(CActor source CInv)
mapM_ execUpdAtomic upds
itemFull <- getsState $ itemToFull iid2
discoverIfMinorEffects (CActor source CInv) iid2 (itemKindId itemFull)
err -> error $ "" `showFailure` err
haltProjectile target tb
else do
if bproj sb && bproj tb then do
when (bhp tb > oneM) $
execUpdAtomic $ UpdRefillHP target minusM
when (bhp tb <= oneM) $
haltProjectile target tb
else do
execSfxAtomic $ SfxStrike source target iid cstore
let c = CActor source cstore
meleeEffectAndDestroy source target iid c
sb2 <- getsState $ getActorBody source
case btrajectory sb2 of
Just (tra, _speed) | not (null tra) -> do
when (bhp sb2 > oneM) $ do
execUpdAtomic $ UpdRefillHP source minusM
unless (bproj sb2) $ do
execSfxAtomic $
SfxMsgFid (bfid sb2) $ SfxCollideActor (blid tb) source target
unless (bproj tb) $
execSfxAtomic $
SfxMsgFid (bfid tb) $ SfxCollideActor (blid tb) source target
when (not (bproj sb2) || bhp sb2 <= oneM) $
haltProjectile source sb2
_ -> return ()
let friendlyFire = bproj sb2 || bproj tb
fromDipl = EM.findWithDefault Unknown tfid (gdipl sfact)
unless (friendlyFire
|| isFoe sfid sfact tfid
|| isFriend sfid sfact tfid) $
execUpdAtomic $ UpdDiplFaction sfid tfid fromDipl War
reqDisplace :: MonadServerAtomic m => ActorId -> ActorId -> m ()
reqDisplace source target = do
COps{coTileSpeedup} <- getsState scops
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
tfact <- getsState $ (EM.! bfid tb) . sfactionD
let tpos = bpos tb
atWar = isFoe (bfid tb) tfact (bfid sb)
req = ReqDisplace target
ar <- getsState $ getActorAspect target
dEnemy <- getsState $ dispEnemy source target $ IA.aSkills ar
if | not (checkAdjacent sb tb) -> execFailure source req DisplaceDistant
| atWar && not dEnemy -> do
mweapon <- pickWeaponServer source
case mweapon of
Nothing -> reqWait source
Just (wp, cstore) -> reqMelee source target wp cstore
| otherwise -> do
let lid = blid sb
lvl <- getLevel lid
if Tile.isWalkable coTileSpeedup $ lvl `at` tpos then
case posToAidsLvl tpos lvl of
[] -> error $ "" `showFailure` (source, sb, target, tb)
[_] -> do
execUpdAtomic $ UpdDisplaceActor source target
affectSmell source
affectSmell target
_ -> execFailure source req DisplaceProjectiles
else
execFailure source req DisplaceAccess
reqAlter :: MonadServerAtomic m => ActorId -> Point -> m ()
reqAlter source tpos = do
mfail <- reqAlterFail source tpos
let req = ReqAlter tpos
maybe (return ()) (execFailure source req) mfail
reqAlterFail :: MonadServerAtomic m => ActorId -> Point -> m (Maybe ReqFailure)
reqAlterFail source tpos = do
COps{cotile, coTileSpeedup} <- getsState scops
sb <- getsState $ getActorBody source
ar <- getsState $ getActorAspect source
let calmE = calmEnough sb ar
lid = blid sb
sClient <- getsServer $ (EM.! bfid sb) . sclientStates
itemToF <- getsState $ flip itemToFull
actorSk <- currentSkillsServer source
localTime <- getsState $ getLocalTime lid
let alterSkill = EM.findWithDefault 0 Ability.AbAlter actorSk
applySkill = EM.findWithDefault 0 Ability.AbApply actorSk
embeds <- getsState $ getEmbedBag lid tpos
lvl <- getLevel lid
let serverTile = lvl `at` tpos
lvlClient = (EM.! lid) . sdungeon $ sClient
clientTile = lvlClient `at` tpos
hiddenTile = Tile.hideAs cotile serverTile
revealEmbeds = unless (EM.null embeds) $ do
s <- getState
let ais = map (\iid -> (iid, getItemBody iid s)) (EM.keys embeds)
execUpdAtomic $ UpdSpotItemBag (CEmbed lid tpos) embeds ais
tryApplyEmbeds = do
execSfxAtomic $ SfxTrigger source tpos
mapM_ tryApplyEmbed $ EM.assocs embeds
tryApplyEmbed (iid, kit) = do
let itemFull@ItemFull{itemKind} = itemToF iid
legal = permittedApply localTime applySkill calmE itemFull kit
case legal of
Left ApplyNoEffects -> return ()
Left reqFail | reqFail `notElem` [ApplyUnskilled, NotCalmPrecious] ->
execSfxAtomic $ SfxMsgFid (bfid sb)
$ SfxExpected ("embedded" <+> IK.iname itemKind) reqFail
_ -> itemEffectEmbedded source lid tpos iid
if chessDist tpos (bpos sb) > 1
then return $ Just AlterDistant
else if Just clientTile == hiddenTile then
if alterSkill <= 1
then return $ Just AlterUnskilled
else do
execUpdAtomic $ UpdSearchTile source tpos serverTile
revealEmbeds
unless (Tile.isDoor coTileSpeedup serverTile
|| Tile.isChangable coTileSpeedup serverTile)
tryApplyEmbeds
return Nothing
else if clientTile == serverTile then
if alterSkill < Tile.alterMinSkill coTileSpeedup serverTile
then return $ Just AlterUnskilled
else do
let changeTo tgroup = do
lvl2 <- getLevel lid
let nightCond kt = not (Tile.kindHasFeature TK.Walkable kt
&& Tile.kindHasFeature TK.Clear kt)
|| (if lnight lvl2 then id else not)
(Tile.kindHasFeature TK.Dark kt)
mtoTile <- rndToAction $ opick cotile tgroup nightCond
toTile <- maybe (rndToAction
$ fromMaybe (error $ "" `showFailure` tgroup)
<$> opick cotile tgroup (const True))
return
mtoTile
unless (toTile == serverTile) $ do
execUpdAtomic $ UpdAlterTile lid tpos serverTile toTile
case hiddenTile of
Just tHidden ->
execUpdAtomic $ UpdAlterTile lid tpos tHidden toTile
Nothing -> return ()
case (Tile.isExplorable coTileSpeedup serverTile,
Tile.isExplorable coTileSpeedup toTile) of
(False, True) -> execUpdAtomic $ UpdAlterExplorable lid 1
(True, False) -> execUpdAtomic $ UpdAlterExplorable lid (-1)
_ -> return ()
case EM.lookup tpos (lembed lvl2) of
Just bag -> do
s <- getState
let ais = map (\iid -> (iid, getItemBody iid s)) (EM.keys bag)
execUpdAtomic $ UpdLoseItemBag (CEmbed lid tpos) bag ais
Nothing -> return ()
embedItem lid tpos toTile
feats = TK.tfeature $ okind cotile serverTile
toAlter feat =
case feat of
TK.OpenTo tgroup -> Just tgroup
TK.CloseTo tgroup -> Just tgroup
TK.ChangeTo tgroup -> Just tgroup
_ -> Nothing
groupsToAlterTo = mapMaybe toAlter feats
if null groupsToAlterTo && EM.null embeds then
return $ Just AlterNothing
else
if EM.notMember tpos $ lfloor lvl then
if null (posToAidsLvl tpos lvl) then do
revealEmbeds
tryApplyEmbeds
case groupsToAlterTo of
[] -> return ()
[groupToAlterTo] -> changeTo groupToAlterTo
l -> error $ "tile changeable in many ways" `showFailure` l
return Nothing
else return $ Just AlterBlockActor
else return $ Just AlterBlockItem
else
return $ Just AlterNothing
reqWait :: MonadServerAtomic m => ActorId -> m ()
{-# INLINE reqWait #-}
reqWait _ = return ()
reqMoveItems :: MonadServerAtomic m
=> ActorId -> [(ItemId, Int, CStore, CStore)] -> m ()
reqMoveItems aid l = do
b <- getsState $ getActorBody aid
ar <- getsState $ getActorAspect aid
let calmE = calmEnough b ar
mapM_ (reqMoveItem aid calmE) l
reqMoveItem :: MonadServerAtomic m
=> ActorId -> Bool -> (ItemId, Int, CStore, CStore) -> m ()
reqMoveItem aid calmE (iid, k, fromCStore, toCStore) = do
b <- getsState $ getActorBody aid
let fromC = CActor aid fromCStore
req = ReqMoveItems [(iid, k, fromCStore, toCStore)]
toC <- case toCStore of
CGround -> pickDroppable aid b
_ -> return $! CActor aid toCStore
bagBefore <- getsState $ getContainerBag toC
if
| k < 1 || fromCStore == toCStore -> execFailure aid req ItemNothing
| toCStore == CEqp && eqpOverfull b k ->
execFailure aid req EqpOverfull
| (fromCStore == CSha || toCStore == CSha) && not calmE ->
execFailure aid req ItemNotCalm
| otherwise -> do
upds <- generalMoveItem True iid k fromC toC
mapM_ execUpdAtomic upds
itemFull <- getsState $ itemToFull iid
when (fromCStore == CGround) $
discoverIfMinorEffects toC iid (itemKindId itemFull)
when (toCStore `elem` [CEqp, COrgan]
&& fromCStore `notElem` [CEqp, COrgan]
|| fromCStore == CSha) $ do
localTime <- getsState $ getLocalTime (blid b)
mrndTimeout <- rndToAction $ computeRndTimeout localTime itemFull
let beforeIt = case iid `EM.lookup` bagBefore of
Nothing -> []
Just (_, it2) -> it2
case mrndTimeout of
Just rndT -> do
bagAfter <- getsState $ getContainerBag toC
let afterIt = case iid `EM.lookup` bagAfter of
Nothing -> error $ "" `showFailure` (iid, bagAfter, toC)
Just (_, it2) -> it2
resetIt = beforeIt ++ replicate k rndT
when (afterIt /= resetIt) $
execUpdAtomic $ UpdTimeItem iid toC afterIt resetIt
Nothing -> return ()
computeRndTimeout :: Time -> ItemFull -> Rnd (Maybe Time)
computeRndTimeout localTime ItemFull{itemKind, itemDisco} =
case IA.aTimeout $ itemAspect itemDisco of
t | t /= 0 && IK.Periodic `elem` IK.ifeature itemKind -> do
rndT <- randomR (0, t)
let rndTurns = timeDeltaScale (Delta timeTurn) (t + rndT)
return $ Just $ timeShift localTime rndTurns
_ -> return Nothing
reqProject :: MonadServerAtomic m
=> ActorId
-> Point
-> Int
-> ItemId
-> CStore
-> m ()
reqProject source tpxy eps iid cstore = do
let req = ReqProject tpxy eps iid cstore
b <- getsState $ getActorBody source
ar <- getsState $ getActorAspect source
let calmE = calmEnough b ar
if cstore == CSha && not calmE then execFailure source req ItemNotCalm
else do
mfail <- projectFail source tpxy eps False iid cstore False
maybe (return ()) (execFailure source req) mfail
reqApply :: MonadServerAtomic m
=> ActorId
-> ItemId
-> CStore
-> m ()
reqApply aid iid cstore = do
let req = ReqApply iid cstore
b <- getsState $ getActorBody aid
ar <- getsState $ getActorAspect aid
let calmE = calmEnough b ar
if cstore == CSha && not calmE then execFailure aid req ItemNotCalm
else do
bag <- getsState $ getBodyStoreBag b cstore
case EM.lookup iid bag of
Nothing -> execFailure aid req ApplyOutOfReach
Just kit -> do
itemFull <- getsState $ itemToFull iid
actorSk <- currentSkillsServer aid
localTime <- getsState $ getLocalTime (blid b)
let skill = EM.findWithDefault 0 Ability.AbApply actorSk
legal = permittedApply localTime skill calmE itemFull kit
case legal of
Left reqFail -> execFailure aid req reqFail
Right _ -> applyItem aid iid cstore
reqGameRestart :: MonadServerAtomic m
=> ActorId -> GroupName ModeKind -> Challenge
-> m ()
reqGameRestart aid groupName scurChalSer = do
modifyServer $ \ser -> ser {soptionsNxt = (soptionsNxt ser) {scurChalSer}}
b <- getsState $ getActorBody aid
oldSt <- getsState $ gquit . (EM.! bfid b) . sfactionD
modifyServer $ \ser -> ser {sbreakASAP = True}
isNoConfirms <- isNoConfirmsGame
unless isNoConfirms $ revealItems Nothing
execUpdAtomic $ UpdQuitFaction (bfid b) oldSt
$ Just $ Status Restart (fromEnum $ blid b) (Just groupName)
reqGameDropAndExit :: MonadServerAtomic m => ActorId -> m ()
reqGameDropAndExit aid = do
b <- getsState $ getActorBody aid
oldSt <- getsState $ gquit . (EM.! bfid b) . sfactionD
modifyServer $ \ser -> ser {sbreakLoop = True}
execUpdAtomic $ UpdQuitFaction (bfid b) oldSt
$ Just $ Status Camping (fromEnum $ blid b) Nothing
reqGameSaveAndExit :: MonadServerAtomic m => ActorId -> m ()
reqGameSaveAndExit aid = do
b <- getsState $ getActorBody aid
oldSt <- getsState $ gquit . (EM.! bfid b) . sfactionD
modifyServer $ \ser -> ser { sbreakASAP = True
, swriteSave = True }
execUpdAtomic $ UpdQuitFaction (bfid b) oldSt
$ Just $ Status Camping (fromEnum $ blid b) Nothing
reqGameSave :: MonadServer m => m ()
reqGameSave =
modifyServer $ \ser -> ser { sbreakASAP = True
, swriteSave = True }
reqTactic :: MonadServerAtomic m => FactionId -> Tactic -> m ()
reqTactic fid toT = do
fromT <- getsState $ ftactic . gplayer . (EM.! fid) . sfactionD
execUpdAtomic $ UpdTacticFaction fid toT fromT
reqAutomate :: MonadServerAtomic m => FactionId -> m ()
reqAutomate fid = execUpdAtomic $ UpdAutoFaction fid True