module Game.LambdaHack.Server.HandleRequestServer
( handleRequestAI, handleRequestUI, reqMove, reqDisplace
) 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 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.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, return ())
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 -> return (Nothing, reqGameExit aid)
ReqUIGameSave -> return (Nothing, reqGameSave)
ReqUITactic toT -> return (Nothing, reqTactic fid toT)
ReqUIAutomate -> return (Nothing, reqAutomate fid)
ReqUIPong _ -> return (Nothing, return ())
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
ReqMoveItems l -> reqMoveItems aid l
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
let !_A = assert (Just (aidNew, mtgtNew) /= mleader
&& not (bproj bPre)
`blame` (aidNew, mtgtNew, bPre, fid, fact)) ()
let !_A = assert (bfid bPre == fid
`blame` "client tries to move other faction actors"
`twith` (aidNew, mtgtNew, bPre, fid, fact)) ()
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
let dumbMonster = not (fhasGender $ gplayer fact) && smellRadius <= 0
unless (bproj b || dumbMonster) $ do
time <- getsState $ getLocalTime $ blid b
lvl <- getLevel $ blid b
let oldS = EM.lookup (bpos b) . lsmell $ lvl
newTime = timeShift time smellTimeout
newS = if smellRadius > 0
then Nothing
else Just newTime
when (oldS /= newS) $
execUpdAtomic $ UpdAlterSmell (blid b) (bpos b) oldS newS
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 $ posToActors 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
_
| 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 hitA | hurtBonus <= 50
= HitBlock 2
| hurtBonus <= 10
= HitBlock 1
| otherwise = HitClear
execSfxAtomic $ SfxStrike source target iid cstore 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)
[_] -> execUpdAtomic $ UpdDisplaceActor source target
_ -> execFailure source req DisplaceProjectiles
else
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
actorSk <- actorSkillsServer source
let skill = EM.findWithDefault 0 Ability.AbAlter actorSk
lid = blid sb
spos = bpos sb
req = ReqAlter tpos mfeat
if skill < 1 then execFailure source req AlterUnskilled
else 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 $ 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
if EM.notMember tpos $ lfloor lvl then
if unoccupied as tpos then do
when (serverTile /= freshClientTile) $
execUpdAtomic $ UpdSearchTile source tpos freshClientTile serverTile
maybe (return ()) 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 ()
reqMoveItems :: (MonadAtomic m, MonadServer m)
=> ActorId -> [(ItemId, Int, CStore, CStore)] -> m ()
reqMoveItems aid l = do
b <- getsState $ getActorBody aid
activeItems <- activeItemsServer aid
let calmE = calmEnough b activeItems
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
toC = CActor aid toCStore
req = ReqMoveItems [(iid, k, fromCStore, toCStore)]
bagBefore <- getsState $ getCBag toC
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)
&& not calmE then execFailure aid req ItemNotCalm
else do
when (fromCStore == CGround) $ do
seed <- getsServer $ (EM.! iid) . sitemSeedD
item <- getsState $ getItemBody iid
Level{ldepth} <- getLevel $ jlid item
execUpdAtomic $ UpdDiscoverSeed fromC iid seed ldepth
upds <- generalMoveItem iid k fromC toC
mapM_ execUpdAtomic upds
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} ->
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 = do
let req = ReqProject tpxy eps iid cstore
b <- getsState $ getActorBody source
activeItems <- activeItemsServer source
let calmE = calmEnough b activeItems
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
activeItems <- activeItemsServer aid
let calmE = calmEnough b activeItems
if cstore == CSha && not calmE then execFailure aid req ItemNotCalm
else do
bag <- getsState $ getActorBag aid cstore
case EM.lookup iid bag of
Nothing -> execFailure aid req ApplyOutOfReach
Just kit -> do
itemToF <- itemToFullServer
actorSk <- actorSkillsServer aid
localTime <- getsState $ getLocalTime (blid b)
let skill = EM.findWithDefault 0 Ability.AbApply actorSk
itemFull = itemToF iid kit
legal = permittedApply " " localTime 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) {scurDiffSer = 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 -> m ()
reqGameExit aid = do
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