module Game.LambdaHack.Server.HandleRequestServer
( handleRequestAI, handleRequestUI, reqMove
) where
import Control.Applicative
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 Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.ClientOptions
import qualified Game.LambdaHack.Common.Effect as Effect
import Game.LambdaHack.Common.Faction
import qualified Game.LambdaHack.Common.Feature as F
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.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 Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.TileKind as TileKind
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
handleRequestAI fid aid cmd = case cmd of
ReqAITimed cmdT -> handleRequestTimed aid cmdT >> return aid
ReqAILeader aidNew mtgtNew cmd2 -> do
switchLeader fid aidNew mtgtNew
handleRequestAI fid aidNew cmd2
ReqAIPong -> return aid
handleRequestUI :: (MonadAtomic m, MonadServer m)
=> FactionId -> RequestUI -> m (Maybe ActorId)
handleRequestUI fid cmd = case cmd of
ReqUITimed cmdT -> do
fact <- getsState $ (EM.! fid) . sfactionD
let (aid, _) = fromMaybe (assert `failure` fact) $ gleader fact
handleRequestTimed aid cmdT >> return (Just aid)
ReqUILeader aidNew mtgtNew cmd2 -> do
switchLeader fid aidNew mtgtNew
handleRequestUI fid cmd2
ReqUIGameRestart aid t d names ->
reqGameRestart aid t d names >> return Nothing
ReqUIGameExit aid d -> reqGameExit aid d >> return Nothing
ReqUIGameSave -> reqGameSave >> return Nothing
ReqUITactic toT -> reqTactic fid toT >> return Nothing
ReqUIAutomate -> reqAutomate fid >> return Nothing
ReqUIPong _ -> return Nothing
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 Effect.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
itemToF <- itemToFullServer
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))
itemEffectAndDestroy source target iid (itemToF iid 1) cstore
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
sfact <- getsState $ (EM.! bfid sb) . sfactionD
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 (fst <$> gleader sfact) 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 F.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 -> TileKind.tfeature $ okind serverTile
Just feat2 | Tile.hasFeature cotile feat2 serverTile -> [feat2]
Just _ -> []
toAlter feat =
case feat of
F.OpenTo tgroup -> Just tgroup
F.CloseTo tgroup -> Just tgroup
F.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.null $ lvl `atI` tpos 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 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 moveItem = do
when (fromCStore == CGround) $ do
seed <- getsServer $ (EM.! iid) . sitemSeedD
execUpdAtomic $ UpdDiscoverSeed (blid b) (bpos b) iid seed
upds <- generalMoveItem iid k (CActor aid fromCStore)
(CActor aid toCStore)
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
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
bag <- getsState $ getActorBag aid cstore
let req = ReqApply iid cstore
if EM.notMember iid bag
then execFailure aid req ApplyOutOfReach
else do
actorBlind <- radiusBlind
<$> sumOrganEqpServer Effect.EqpSlotAddSight aid
item <- getsState $ getItemBody iid
let blindScroll = jsymbol item == '?' && actorBlind
if blindScroll
then execFailure aid req ApplyBlind
else applyItem aid iid cstore
reqTrigger :: (MonadAtomic m, MonadServer m)
=> ActorId -> Maybe F.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 -> TileKind.tfeature $ okind serverTile
Just feat2 | Tile.hasFeature cotile feat2 serverTile -> [feat2]
Just _ -> []
req = ReqTrigger mfeat
go <- triggerEffect aid feats
unless go $ execFailure aid req TriggerNothing
triggerEffect :: (MonadAtomic m, MonadServer m)
=> ActorId -> [F.Feature] -> m Bool
triggerEffect aid feats = do
sb <- getsState $ getActorBody aid
let tpos = bpos sb
triggerFeat feat =
case feat of
F.Cause ef -> do
execSfxAtomic $ SfxTrigger aid tpos feat
void $ effectsSem [ef] aid aid False
return True
_ -> return False
goes <- mapM triggerFeat feats
return $! or goes
reqGameRestart :: (MonadAtomic m, MonadServer m)
=> ActorId -> GroupName -> 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