module Game.LambdaHack.Server.HandleRequestServer
( handleRequestAI, handleRequestUI, reqMove
) where
import Control.Exception.Assert.Sugar
import Control.Monad
import qualified Data.EnumMap.Strict as EM
import Data.Maybe
import Data.Text (Text)
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.ClientOptions
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.CommonServer
import Game.LambdaHack.Server.HandleEffectServer
import Game.LambdaHack.Server.ItemServer
import Game.LambdaHack.Server.MonadServer
import Game.LambdaHack.Server.State
handleRequestAI :: (MonadAtomic m, MonadServer m)
=> FactionId -> ActorId -> RequestAI -> m (ActorId, m ())
handleRequestAI fid aid cmd = case cmd of
ReqAITimed cmdT -> return (aid, handleRequestTimed aid cmdT)
ReqAILeader aidNew mtgtNew cmd2 -> do
switchLeader fid aidNew mtgtNew
handleRequestAI fid aidNew cmd2
ReqAIPong -> return (aid, skip)
handleRequestUI :: (MonadAtomic m, MonadServer m)
=> FactionId -> RequestUI -> m (Maybe ActorId, m ())
handleRequestUI fid cmd = case cmd of
ReqUITimed cmdT -> do
fact <- getsState $ (EM.! fid) . sfactionD
let (aid, _) = fromMaybe (assert `failure` fact) $ gleader fact
return (Just aid, handleRequestTimed aid cmdT)
ReqUILeader aidNew mtgtNew cmd2 -> do
switchLeader fid aidNew mtgtNew
handleRequestUI fid cmd2
ReqUIGameRestart aid t d names ->
return (Nothing, reqGameRestart aid t d names)
ReqUIGameExit aid d -> return (Nothing, reqGameExit aid d)
ReqUIGameSave -> return (Nothing, reqGameSave)
ReqUITactic toT -> return (Nothing, reqTactic fid toT)
ReqUIAutomate -> return (Nothing, reqAutomate fid)
ReqUIPong _ -> return (Nothing, skip)
handleRequestTimed :: (MonadAtomic m, MonadServer m)
=> ActorId -> RequestTimed a -> m ()
handleRequestTimed 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 mfeat -> reqAlter aid tpos mfeat
ReqWait -> reqWait aid
ReqMoveItem iid k fromCStore toCStore ->
reqMoveItem aid iid k fromCStore toCStore
ReqProject p eps iid cstore -> reqProject aid p eps iid cstore
ReqApply iid cstore -> reqApply aid iid cstore
ReqTrigger mfeat -> reqTrigger aid mfeat
switchLeader :: (MonadAtomic m, MonadServer m)
=> FactionId -> ActorId -> Maybe Target -> m ()
switchLeader fid aidNew mtgtNew = do
fact <- getsState $ (EM.! fid) . sfactionD
bPre <- getsState $ getActorBody aidNew
let mleader = gleader fact
actorChanged = fmap fst mleader /= Just aidNew
assert (Just (aidNew, mtgtNew) /= mleader
&& not (bproj bPre)
`blame` (aidNew, mtgtNew, bPre, fid, fact)) skip
assert (bfid bPre == fid
`blame` "client tries to move other faction actors"
`twith` (aidNew, mtgtNew, bPre, fid, fact)) skip
let (autoDun, autoLvl) = autoDungeonLevel fact
arena <- case mleader of
Nothing -> return $! blid bPre
Just (leader, _) -> do
b <- getsState $ getActorBody leader
return $! blid b
if actorChanged && blid bPre /= arena && autoDun
then execFailure aidNew ReqWait NoChangeDunLeader
else if actorChanged && autoLvl
then execFailure aidNew ReqWait NoChangeLvlLeader
else execUpdAtomic $ UpdLeadFaction fid mleader (Just (aidNew, mtgtNew))
addSmell :: (MonadAtomic m, MonadServer m) => ActorId -> m ()
addSmell aid = do
b <- getsState $ getActorBody aid
fact <- getsState $ (EM.! bfid b) . sfactionD
smellRadius <- sumOrganEqpServer IK.EqpSlotAddSmell aid
unless (bproj b || not (fhasGender $ gplayer fact) || smellRadius > 0) $ do
time <- getsState $ getLocalTime $ blid b
lvl <- getLevel $ blid b
let oldS = EM.lookup (bpos b) . lsmell $ lvl
newTime = timeShift time smellTimeout
execUpdAtomic $ UpdAlterSmell (blid b) (bpos b) oldS (Just newTime)
reqMove :: (MonadAtomic m, MonadServer m) => ActorId -> Vector -> m ()
reqMove source dir = do
cops <- getsState scops
sb <- getsState $ getActorBody source
let lid = blid sb
lvl <- getLevel lid
let spos = bpos sb
tpos = spos `shift` dir
tgt <- getsState $ posToActor tpos lid
case tgt of
Just ((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
_
| accessible cops lvl spos tpos -> do
execUpdAtomic $ UpdMoveActor source spos tpos
addSmell 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
hurtBonus <- armorHurtBonus source target
let isFightImpaired = hurtBonus <= 10
block = braced tb
hitA = if block && isFightImpaired
then HitBlock 2
else if block || isFightImpaired
then HitBlock 1
else HitClear
execSfxAtomic $ SfxStrike source target iid hitA
case btrajectory sb of
Nothing -> return ()
Just (tra, speed) -> do
execUpdAtomic $ UpdRefillHP source minusM
unless (bproj sb || null tra) $
execUpdAtomic
$ UpdTrajectory source (btrajectory sb) (Just ([], speed))
let c = CActor source cstore
itemEffectAndDestroy source target iid c
let friendlyFire = bproj sb || 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
cops <- getsState scops
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
tfact <- getsState $ (EM.! bfid tb) . sfactionD
let spos = bpos sb
tpos = bpos tb
adj = checkAdjacent sb tb
atWar = isAtWar tfact (bfid sb)
req = ReqDisplace target
activeItems <- activeItemsServer target
dEnemy <- getsState $ dispEnemy source target activeItems
if not adj then execFailure source req DisplaceDistant
else if atWar && not dEnemy
then do
mweapon <- pickWeaponServer source
case mweapon of
Nothing -> reqWait source
Just (wp, cstore) -> reqMelee source target wp cstore
else do
let lid = blid sb
lvl <- getLevel lid
if accessible cops lvl spos tpos then do
tgts <- getsState $ posToActors tpos lid
case tgts of
[] -> assert `failure` (source, sb, target, tb)
[_] -> do
execUpdAtomic $ UpdDisplaceActor source target
addSmell source
addSmell target
_ -> execFailure source req DisplaceProjectiles
else do
execFailure source req DisplaceAccess
reqAlter :: (MonadAtomic m, MonadServer m)
=> ActorId -> Point -> Maybe TK.Feature -> m ()
reqAlter source tpos mfeat = do
cops@Kind.COps{cotile=cotile@Kind.Ops{okind, opick}} <- getsState scops
sb <- getsState $ getActorBody source
let lid = blid sb
spos = bpos sb
req = ReqAlter tpos mfeat
if not $ adjacent spos tpos then execFailure source req AlterDistant
else do
lvl <- getLevel lid
let serverTile = lvl `at` tpos
freshClientTile = hideTile cops lvl tpos
changeTo tgroup = do
toTile <- rndToAction $ fmap (fromMaybe $ assert `failure` tgroup)
$ opick tgroup (const True)
unless (toTile == serverTile) $ do
execUpdAtomic $ UpdAlterTile lid tpos serverTile toTile
case (Tile.isExplorable cotile serverTile,
Tile.isExplorable cotile toTile) of
(False, True) -> execUpdAtomic $ UpdAlterClear lid 1
(True, False) -> execUpdAtomic $ UpdAlterClear lid (1)
_ -> return ()
feats = case mfeat of
Nothing -> TK.tfeature $ okind serverTile
Just feat2 | Tile.hasFeature cotile feat2 serverTile -> [feat2]
Just _ -> []
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
as <- getsState $ actorList (const True) lid
if null groupsToAlterTo && serverTile == freshClientTile then
execFailure source req AlterNothing
else do
if EM.notMember tpos $ lfloor lvl then
if unoccupied as tpos then do
when (serverTile /= freshClientTile) $ do
execUpdAtomic $ UpdSearchTile source tpos freshClientTile serverTile
maybe skip changeTo $ listToMaybe groupsToAlterTo
void $ triggerEffect source tpos feats
else execFailure source req AlterBlockActor
else execFailure source req AlterBlockItem
reqWait :: MonadAtomic m => ActorId -> m ()
reqWait _ = return ()
reqMoveItem :: (MonadAtomic m, MonadServer m)
=> ActorId -> ItemId -> Int -> CStore -> CStore -> m ()
reqMoveItem aid iid k fromCStore toCStore = do
b <- getsState $ getActorBody aid
activeItems <- activeItemsServer aid
let fromC = CActor aid fromCStore
toC = CActor aid toCStore
bagBefore <- getsState $ getCBag toC
let moveItem = do
when (fromCStore == CGround) $ do
seed <- getsServer $ (EM.! iid) . sitemSeedD
execUpdAtomic $ UpdDiscoverSeed (blid b) (bpos b) iid seed
upds <- generalMoveItem iid k fromC toC
mapM_ execUpdAtomic upds
req = ReqMoveItem iid k fromCStore toCStore
if k < 1 || fromCStore == toCStore then execFailure aid req ItemNothing
else if toCStore == CEqp
&& eqpOverfull b k then execFailure aid req EqpOverfull
else if fromCStore /= CSha && toCStore /= CSha then moveItem
else do
if calmEnough b activeItems then moveItem
else execFailure aid req ItemNotCalm
when (toCStore `elem` [CEqp, COrgan]
&& fromCStore `notElem` [CEqp, COrgan]) $ do
localTime <- getsState $ getLocalTime (blid b)
discoEffect <- getsServer sdiscoEffect
mrndTimeout <- rndToAction $ computeRndTimeout localTime discoEffect iid
let beforeIt = case iid `EM.lookup` bagBefore of
Nothing -> []
Just (_, it2) -> it2
case mrndTimeout of
Just rndT -> do
bagAfter <- getsState $ getCBag toC
let afterIt = case iid `EM.lookup` bagAfter of
Nothing -> assert `failure` (iid, bagAfter, toC)
Just (_, it2) -> it2
resetIt = beforeIt ++ replicate k rndT
when (afterIt /= resetIt) $
execUpdAtomic $ UpdTimeItem iid toC afterIt resetIt
Nothing -> return ()
computeRndTimeout :: Time -> DiscoveryEffect -> ItemId -> Rnd (Maybe Time)
computeRndTimeout localTime discoEffect iid = do
let timeoutAspect :: IK.Aspect Int -> Maybe Int
timeoutAspect (IK.Timeout t) = Just t
timeoutAspect _ = Nothing
case EM.lookup iid discoEffect of
Just ItemAspectEffect{jaspects} -> do
case mapMaybe timeoutAspect jaspects of
[t] | IK.Periodic `elem` jaspects -> do
rndT <- randomR (0, t)
let rndTurns = timeDeltaScale (Delta timeTurn) rndT
return $ Just $ timeShift localTime rndTurns
_ -> return Nothing
_ -> assert `failure` (iid, discoEffect)
reqProject :: (MonadAtomic m, MonadServer m)
=> ActorId
-> Point
-> Int
-> ItemId
-> CStore
-> m ()
reqProject source tpxy eps iid cstore = assert (cstore /= CSha) $ do
mfail <- projectFail source tpxy eps iid cstore False
let req = ReqProject tpxy eps iid cstore
maybe skip (execFailure source req) mfail
reqApply :: (MonadAtomic m, MonadServer m)
=> ActorId
-> ItemId
-> CStore
-> m ()
reqApply aid iid cstore = assert (cstore /= CSha) $ do
let req = ReqApply iid cstore
bag <- getsState $ getActorBag aid cstore
case EM.lookup iid bag of
Nothing -> execFailure aid req ApplyOutOfReach
Just kit -> do
itemToF <- itemToFullServer
b <- getsState $ getActorBody aid
activeItems <- activeItemsServer aid
actorSk <- actorSkillsServer aid
let skill = EM.findWithDefault 0 Ability.AbProject actorSk
itemFull = itemToF iid kit
legal = permittedApply " " skill itemFull b activeItems
case legal of
Left reqFail -> execFailure aid req reqFail
Right _ -> applyItem aid iid cstore
reqTrigger :: (MonadAtomic m, MonadServer m)
=> ActorId -> Maybe TK.Feature -> m ()
reqTrigger aid mfeat = do
Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops
sb <- getsState $ getActorBody aid
let lid = blid sb
lvl <- getLevel lid
let tpos = bpos sb
serverTile = lvl `at` tpos
feats = case mfeat of
Nothing -> TK.tfeature $ okind serverTile
Just feat2 | Tile.hasFeature cotile feat2 serverTile -> [feat2]
Just _ -> []
req = ReqTrigger mfeat
go <- triggerEffect aid tpos feats
unless go $ execFailure aid req TriggerNothing
triggerEffect :: (MonadAtomic m, MonadServer m)
=> ActorId -> Point -> [TK.Feature] -> m Bool
triggerEffect aid tpos feats = do
let triggerFeat feat =
case feat of
TK.Cause ef -> itemEffectCause aid tpos ef
_ -> return False
goes <- mapM triggerFeat feats
return $! or goes
reqGameRestart :: (MonadAtomic m, MonadServer m)
=> ActorId -> GroupName ModeKind -> Int -> [(Int, (Text, Text))] -> m ()
reqGameRestart aid groupName d configHeroNames = do
modifyServer $ \ser ->
ser {sdebugNxt = (sdebugNxt ser) { sdifficultySer = d
, sdebugCli = (sdebugCli (sdebugNxt ser))
{sdifficultyCli = d}
}}
b <- getsState $ getActorBody aid
let fid = bfid b
oldSt <- getsState $ gquit . (EM.! fid) . sfactionD
modifyServer $ \ser ->
ser { squit = True
, sheroNames = EM.insert fid configHeroNames $ sheroNames ser }
revealItems Nothing Nothing
execUpdAtomic $ UpdQuitFaction fid (Just b) oldSt
$ Just $ Status Restart (fromEnum $ blid b) (Just groupName)
reqGameExit :: (MonadAtomic m, MonadServer m) => ActorId -> Int -> m ()
reqGameExit aid d = do
modifyServer $ \ser ->
ser {sdebugNxt = (sdebugNxt ser) { sdifficultySer = d
, sdebugCli = (sdebugCli (sdebugNxt ser))
{sdifficultyCli = d}
}}
b <- getsState $ getActorBody aid
let fid = bfid b
oldSt <- getsState $ gquit . (EM.! fid) . sfactionD
modifyServer $ \ser -> ser {swriteSave = True}
modifyServer $ \ser -> ser {squit = True}
execUpdAtomic $ UpdQuitFaction fid (Just b) oldSt
$ Just $ Status Camping (fromEnum $ blid b) Nothing
reqGameSave :: MonadServer m => m ()
reqGameSave = do
modifyServer $ \ser -> ser {swriteSave = True}
modifyServer $ \ser -> ser {squit = True}
reqTactic :: (MonadAtomic m, MonadServer m) => FactionId -> Tactic -> m ()
reqTactic fid toT = do
fromT <- getsState $ ftactic . gplayer . (EM.! fid) . sfactionD
execUpdAtomic $ UpdTacticFaction fid toT fromT
reqAutomate :: (MonadAtomic m, MonadServer m) => FactionId -> m ()
reqAutomate fid = execUpdAtomic $ UpdAutoFaction fid True