{-# LANGUAGE GADTs #-}
module Game.LambdaHack.Server.HandleRequestM
( handleRequestAI, handleRequestUI, switchLeader, handleRequestTimed
, reqMove, reqDisplace, reqGameExit
#ifdef EXPOSE_INTERNAL
, setBWait, 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 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.Kind as 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.Request
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.State
handleRequestAI :: (MonadAtomic m)
=> ReqAI
-> m (Maybe RequestAnyAbility)
handleRequestAI cmd = case cmd of
ReqAITimed cmdT -> return $ Just cmdT
ReqAINop -> return Nothing
handleRequestUI :: (MonadAtomic m, MonadServer 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
ReqUIGameExit -> reqGameExit aid >> return Nothing
ReqUIGameSave -> reqGameSave >> return Nothing
ReqUITactic toT -> reqTactic fid toT >> return Nothing
ReqUIAutomate -> reqAutomate fid >> return Nothing
ReqUINop -> return Nothing
setBWait :: (MonadAtomic m) => RequestTimed a -> ActorId -> m (Maybe Bool)
{-# INLINE setBWait #-}
setBWait cmd aid = do
let mwait = case cmd of
ReqWait -> Just True
ReqWait10 -> Just False
_ -> Nothing
bPre <- getsState $ getActorBody aid
when ((mwait == Just True) /= bwait bPre) $
execUpdAtomic $ UpdWaitActor aid (mwait == Just True)
return mwait
handleRequestTimed :: (MonadAtomic m, MonadServer m)
=> FactionId -> ActorId -> RequestTimed a -> m Bool
handleRequestTimed fid aid cmd = do
mwait <- setBWait cmd aid
unless (mwait == Just True) $ overheadActorTime fid
advanceTime aid (if mwait == Just False then 10 else 100)
handleRequestTimedCases aid cmd
managePerRequest aid
return $! isNothing mwait
managePerRequest :: MonadAtomic 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 :: (MonadAtomic m, MonadServer 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 :: (MonadAtomic m, MonadServer 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 :: (MonadAtomic m, MonadServer m) => ActorId -> m ()
affectSmell aid = do
b <- getsState $ getActorBody aid
unless (bproj b) $ do
fact <- getsState $ (EM.! bfid b) . sfactionD
actorAspect <- getsServer sactorAspect
let ar = actorAspect EM.! aid
smellRadius = 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 :: (MonadAtomic m, MonadServer m) => ActorId -> Vector -> m ()
reqMove source dir = do
Kind.COps{coTileSpeedup} <- getsState scops
sb <- getsState $ getActorBody source
let lid = blid sb
lvl <- getLevel lid
let spos = bpos sb
tpos = spos `shift` dir
tgt <- getsState $ posToAssocs tpos lid
case tgt of
(target, tb) : _ | not (bproj sb && bproj 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 :: (MonadAtomic m, MonadServer m)
=> ActorId -> ActorId -> ItemId -> CStore -> m ()
reqMelee source target iid cstore = do
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
let adj = checkAdjacent sb tb
req = ReqMelee target iid cstore
if source == target then execFailure source req MeleeSelf
else if not adj then execFailure source req MeleeDistant
else do
let sfid = bfid sb
tfid = bfid tb
sfact <- getsState $ (EM.! sfid) . sfactionD
ttrunk <- getsState $ getItemBody $ btrunk tb
if bproj tb && length (beqp tb) == 1 && jweight ttrunk > 1
&& 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
err -> error $ "" `showFailure` err
execUpdAtomic $ UpdTrajectory target (btrajectory tb)
(Just ([], toSpeed 0))
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 (not (bproj sb2) || bhp sb2 > oneM) $
execUpdAtomic $ UpdRefillHP source minusM
when (not (bproj sb2) || bhp sb2 <= oneM) $
execUpdAtomic
$ UpdTrajectory source (btrajectory sb2) (Just ([], speed))
_ -> return ()
let friendlyFire = bproj sb2 || bproj tb
fromDipl = EM.findWithDefault Unknown tfid (gdipl sfact)
unless (friendlyFire
|| isAtWar sfact tfid
|| isAllied sfact tfid
|| sfid == tfid) $
execUpdAtomic $ UpdDiplFaction sfid tfid fromDipl War
reqDisplace :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m ()
reqDisplace source target = do
Kind.COps{coTileSpeedup} <- getsState scops
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
tfact <- getsState $ (EM.! bfid tb) . sfactionD
let tpos = bpos tb
adj = checkAdjacent sb tb
atWar = isAtWar tfact (bfid sb)
req = ReqDisplace target
actorAspect <- getsServer sactorAspect
let ar = actorAspect EM.! target
dEnemy <- getsState $ dispEnemy source target $ aSkills ar
if | not adj -> 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 :: (MonadAtomic m, MonadServer m) => ActorId -> Point -> m ()
reqAlter source tpos = do
Kind.COps{cotile=Kind.Ops{okind, opick}, coTileSpeedup} <- getsState scops
sb <- getsState $ getActorBody source
actorSk <- currentSkillsServer source
let alterSkill = EM.findWithDefault 0 Ability.AbAlter actorSk
lid = blid sb
spos = bpos sb
req = ReqAlter tpos
lvl <- getLevel lid
let serverTile = lvl `at` tpos
hidden = Tile.isHideAs coTileSpeedup serverTile
if alterSkill <= 1
|| not hidden
&& alterSkill < Tile.alterMinSkill coTileSpeedup serverTile
then execFailure source req AlterUnskilled
else if not $ adjacent spos tpos then execFailure source req AlterDistant
else do
let changeTo tgroup = do
let nightCond kt = not (Tile.kindHasFeature TK.Walkable kt
&& Tile.kindHasFeature TK.Clear kt)
|| (if lnight lvl then id else not)
(Tile.kindHasFeature TK.Dark kt)
mtoTile <- rndToAction $ opick tgroup nightCond
toTile <- maybe (rndToAction
$ fromMaybe (error $ "" `showFailure` tgroup)
<$> opick tgroup (const True))
return
mtoTile
unless (toTile == serverTile) $ do
execUpdAtomic $ UpdAlterTile lid tpos serverTile toTile
case (Tile.isExplorable coTileSpeedup serverTile,
Tile.isExplorable coTileSpeedup toTile) of
(False, True) -> execUpdAtomic $ UpdAlterExplorable lid 1
(True, False) -> execUpdAtomic $ UpdAlterExplorable lid (-1)
_ -> return ()
feats = TK.tfeature $ okind 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
embeds <- getsState $ getEmbedBag lid tpos
if null groupsToAlterTo && null embeds && not hidden then
execFailure source req AlterNothing
else
if EM.notMember tpos $ lfloor lvl then
if null (posToAidsLvl tpos lvl) then do
when hidden $
execUpdAtomic $ UpdSearchTile source tpos serverTile
when (alterSkill >= Tile.alterMinSkill coTileSpeedup serverTile) $ do
case groupsToAlterTo of
[] -> return ()
[groupToAlterTo] -> changeTo groupToAlterTo
l -> error $ "tile changeable in many ways" `showFailure` l
itemEffectEmbedded source tpos embeds
else execFailure source req AlterBlockActor
else execFailure source req AlterBlockItem
reqWait :: MonadAtomic m => ActorId -> m ()
{-# INLINE reqWait #-}
reqWait _ = return ()
reqMoveItems :: (MonadAtomic m, MonadServer m)
=> ActorId -> [(ItemId, Int, CStore, CStore)] -> m ()
reqMoveItems aid l = do
b <- getsState $ getActorBody aid
actorAspect <- getsServer sactorAspect
let ar = actorAspect EM.! aid
calmE = calmEnough b ar
mapM_ (reqMoveItem aid calmE) l
reqMoveItem :: (MonadAtomic m, MonadServer 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
itemToF <- itemToFullServer
let itemFull = itemToF iid (k, [])
when (fromCStore == CGround) $ discoverIfNoEffects fromC iid itemFull
upds <- generalMoveItem True iid k fromC toC
mapM_ execUpdAtomic upds
when (toCStore `elem` [CEqp, COrgan]
&& fromCStore `notElem` [CEqp, COrgan]
|| fromCStore == CSha) $ do
localTime <- getsState $ getLocalTime (blid b)
mrndTimeout <- rndToAction $ computeRndTimeout localTime iid 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 -> ItemId -> ItemFull -> Rnd (Maybe Time)
computeRndTimeout localTime iid ItemFull{..}=
case itemDisco of
Just ItemDisco{itemKind, itemAspect=Just ar} ->
case aTimeout ar of
t | t /= 0 && IK.Periodic `elem` IK.ieffects itemKind -> do
rndT <- randomR (0, t)
let rndTurns = timeDeltaScale (Delta timeTurn) rndT
return $ Just $ timeShift localTime rndTurns
_ -> return Nothing
_ -> error $ "" `showFailure` iid
reqProject :: (MonadAtomic m, MonadServer 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
actorAspect <- getsServer sactorAspect
let ar = actorAspect EM.! source
calmE = calmEnough b ar
if cstore == CSha && not calmE then execFailure source req ItemNotCalm
else do
mfail <- projectFail source tpxy eps iid cstore False
maybe (return ()) (execFailure source req) mfail
reqApply :: (MonadAtomic m, MonadServer m)
=> ActorId
-> ItemId
-> CStore
-> m ()
reqApply aid iid cstore = do
let req = ReqApply iid cstore
b <- getsState $ getActorBody aid
actorAspect <- getsServer sactorAspect
let ar = actorAspect EM.! aid
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
itemToF <- itemToFullServer
actorSk <- currentSkillsServer aid
localTime <- getsState $ getLocalTime (blid b)
let skill = EM.findWithDefault 0 Ability.AbApply actorSk
itemFull = itemToF iid kit
legal = permittedApply localTime skill calmE " " itemFull
case legal of
Left reqFail -> execFailure aid req reqFail
Right _ -> applyItem aid iid cstore
reqGameRestart :: (MonadAtomic m, MonadServer m)
=> ActorId -> GroupName ModeKind -> Challenge
-> m ()
reqGameRestart aid groupName scurChalSer = do
modifyServer $ \ser -> ser {sdebugNxt = (sdebugNxt ser) {scurChalSer}}
b <- getsState $ getActorBody aid
oldSt <- getsState $ gquit . (EM.! bfid b) . sfactionD
modifyServer $ \ser ->
ser { swriteSave = True
, squit = True }
isNoConfirms <- isNoConfirmsGame
unless isNoConfirms $ revealItems Nothing
execUpdAtomic $ UpdQuitFaction (bfid b) oldSt
$ Just $ Status Restart (fromEnum $ blid b) (Just groupName)
reqGameExit :: (MonadAtomic m, MonadServer m) => ActorId -> m ()
reqGameExit aid = do
b <- getsState $ getActorBody aid
oldSt <- getsState $ gquit . (EM.! bfid b) . sfactionD
modifyServer $ \ser -> ser { swriteSave = True
, squit = True }
execUpdAtomic $ UpdQuitFaction (bfid b) oldSt
$ Just $ Status Camping (fromEnum $ blid b) Nothing
reqGameSave :: MonadServer m => m ()
reqGameSave =
modifyServer $ \ser -> ser { swriteSave = True
, squit = True }
reqTactic :: MonadAtomic m => FactionId -> Tactic -> m ()
reqTactic fid toT = do
fromT <- getsState $ ftactic . gplayer . (EM.! fid) . sfactionD
execUpdAtomic $ UpdTacticFaction fid toT fromT
reqAutomate :: MonadAtomic m => FactionId -> m ()
reqAutomate fid = execUpdAtomic $ UpdAutoFaction fid True