module Game.LambdaHack.Server.ServerSem where
import Control.Exception.Assert.Sugar
import Control.Monad
import qualified Data.EnumMap.Strict as EM
import Data.Key (mapWithKeyM_)
import Data.Maybe
import Data.Ratio
import Data.Text (Text)
import qualified NLP.Miniutter.English as MU
import Game.LambdaHack.Common.Action
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Animation
import Game.LambdaHack.Common.AtomicCmd
import qualified Game.LambdaHack.Common.Color as Color
import Game.LambdaHack.Common.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.Msg
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.Random
import Game.LambdaHack.Common.ServerCmd
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.ActorKind
import Game.LambdaHack.Content.ItemKind
import Game.LambdaHack.Content.TileKind as TileKind
import Game.LambdaHack.Server.Action hiding (sendQueryAI, sendQueryUI,
sendUpdateAI, sendUpdateUI)
import Game.LambdaHack.Server.EffectSem
import Game.LambdaHack.Server.State
execFailure :: (MonadAtomic m, MonadServer m)
=> ActorId -> FailureSer -> m ()
execFailure aid failureSer = do
body <- getsState $ getActorBody aid
let fid = bfid body
msg = showFailureSer failureSer
debugPrint
$ "execFailure:" <+> tshow fid <+> ":" <+> msg <> "\n" <> tshow body
execSfxAtomic $ MsgFidD fid $ "Unexpected problem:" <+> msg <> "."
broadcastCmdAtomic :: MonadAtomic m
=> (FactionId -> CmdAtomic) -> m ()
broadcastCmdAtomic fcmd = do
factionD <- getsState sfactionD
mapWithKeyM_ (\fid _ -> execCmdAtomic $ fcmd fid) factionD
broadcastSfxAtomic :: MonadAtomic m
=> (FactionId -> SfxAtomic) -> m ()
broadcastSfxAtomic fcmd = do
factionD <- getsState sfactionD
mapWithKeyM_ (\fid _ -> execSfxAtomic $ fcmd fid) factionD
addSmell :: MonadAtomic m => ActorId -> m ()
addSmell aid = do
cops@Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops
b <- getsState $ getActorBody aid
fact <- getsState $ (EM.! bfid b) . sfactionD
let canSmell = asmell $ okind $ bkind b
unless (bproj b || not (isHeroFact cops fact) || canSmell) $ do
time <- getsState $ getLocalTime $ blid b
lvl <- getLevel $ blid b
let oldS = EM.lookup (bpos b) . lsmell $ lvl
newTime = timeAdd time smellTimeout
execCmdAtomic $ AlterSmellA (blid b) (bpos b) oldS (Just newTime)
moveSer :: (MonadAtomic m, MonadServer m) => ActorId -> Vector -> m ()
moveSer 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) ->
meleeSer source target
_
| accessible cops lvl spos tpos -> do
execCmdAtomic $ MoveActorA source spos tpos
addSmell source
| otherwise ->
execFailure source MoveNothing
meleeSer :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m ()
meleeSer source target = do
cops@Kind.COps{coitem=coitem@Kind.Ops{opick, okind}} <- getsState scops
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
let adj = checkAdjacent sb tb
if source == target then execFailure source MeleeSelf
else if not adj then execFailure source MeleeDistant
else do
let sfid = bfid sb
tfid = bfid tb
sfact <- getsState $ (EM.! sfid) . sfactionD
itemAssocs <- getsState $ getActorItem source
(miid, item) <-
if bproj sb
then case itemAssocs of
[(iid, item)] -> return (Just iid, item)
_ -> assert `failure` "projectile with wrong items" `twith` itemAssocs
else case strongestSword cops itemAssocs of
Just (_, (iid, w)) -> return (Just iid, w)
Nothing -> do
let isHero = isHeroFact cops sfact
h2hGroup | isHero = "unarmed"
| otherwise = "monstrous"
h2hKind <- rndToAction $ fmap (fromMaybe $ assert `failure` h2hGroup)
$ opick h2hGroup (const True)
flavour <- getsServer sflavour
discoRev <- getsServer sdiscoRev
let kind = okind h2hKind
let kindEffect = case causeIEffects coitem h2hKind of
[] -> NoEffect
eff : _TODO -> eff
effect = fmap maxDeep kindEffect
return ( Nothing
, buildItem flavour discoRev h2hKind kind effect )
let performHit block = do
let hitA = if block then HitBlockD else HitD
execSfxAtomic $ StrikeD source target item hitA
when (bproj sb) $ execCmdAtomic $ HealActorA source (1)
itemEffect source target miid item
if braced tb && not (bproj sb) && bhp tb > 0
then do
blocked <- rndToAction $ chance $ 1%2
if blocked
then execSfxAtomic $ StrikeD source target item MissBlockD
else performHit True
else performHit False
let friendlyFire = bproj sb || bproj tb
fromDipl = EM.findWithDefault Unknown tfid (gdipl sfact)
unless (friendlyFire || isAtWar sfact tfid || sfid == tfid) $
execCmdAtomic $ DiplFactionA sfid tfid fromDipl War
displaceSer :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m ()
displaceSer source target = do
cops <- getsState scops
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
let adj = checkAdjacent sb tb
if not adj then execFailure source DisplaceDistant
else do
let lid = blid sb
lvl <- getLevel lid
let spos = bpos sb
tpos = bpos tb
if accessible cops lvl spos tpos then do
tgts <- getsState $ posToActors tpos lid
case tgts of
[] -> assert `failure` (source, sb, target, tb)
[_] -> do
execCmdAtomic $ DisplaceActorA source target
addSmell source
addSmell target
_ -> execFailure source DisplaceProjectiles
else do
execFailure source DisplaceAccess
alterSer :: (MonadAtomic m, MonadServer m)
=> ActorId -> Point -> Maybe F.Feature -> m ()
alterSer source tpos mfeat = do
Kind.COps{cotile=cotile@Kind.Ops{okind, opick}} <- getsState scops
sb <- getsState $ getActorBody source
let lid = blid sb
spos = bpos sb
if not $ adjacent spos tpos then execFailure source AlterDistant
else do
lvl <- getLevel lid
let serverTile = lvl `at` tpos
freshClientTile = hideTile cotile lvl tpos
changeTo tgroup = do
toTile <- rndToAction $ fmap (fromMaybe $ assert `failure` tgroup)
$ opick tgroup (const True)
unless (toTile == serverTile) $
execCmdAtomic $ AlterTileA lid tpos serverTile toTile
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
groupsToAlter = mapMaybe toAlter feats
as <- getsState $ actorList (const True) lid
if null groupsToAlter && serverTile == freshClientTile then
execFailure source AlterNothing
else do
if EM.null $ lvl `atI` tpos then
if unoccupied as tpos then do
when (serverTile /= freshClientTile) $ do
execCmdAtomic $ SearchTileA source tpos freshClientTile serverTile
mapM_ changeTo groupsToAlter
void $ triggerEffect source feats
else execFailure source AlterBlockActor
else execFailure source AlterBlockItem
waitSer :: MonadAtomic m => ActorId -> m ()
waitSer _ = return ()
pickupSer :: (MonadAtomic m, MonadServer m)
=> ActorId -> ItemId -> Int -> m ()
pickupSer aid iid k = assert (k > 0) $ do
b <- getsState $ getActorBody aid
item <- getsState $ getItemBody iid
case actorContainerB aid b iid item of
Just c -> execCmdAtomic $ MoveItemA iid k (CFloor (blid b) (bpos b)) c
Nothing -> execFailure aid PickupOverfull
dropSer :: MonadAtomic m => ActorId -> ItemId -> Int -> m ()
dropSer aid iid k = assert (k > 0) $ do
b <- getsState $ getActorBody aid
let c = actorContainer aid (binv b) iid
execCmdAtomic $ MoveItemA iid k c (CFloor (blid b) (bpos b))
projectSer :: (MonadAtomic m, MonadServer m)
=> ActorId
-> Point
-> Int
-> ItemId
-> Container
-> m ()
projectSer source tpxy eps iid container = do
mfail <- projectFail source tpxy eps iid container False
maybe skip (execFailure source) mfail
projectFail :: (MonadAtomic m, MonadServer m)
=> ActorId
-> Point
-> Int
-> ItemId
-> Container
-> Bool
-> m (Maybe FailureSer)
projectFail source tpxy eps iid container isShrapnel = do
Kind.COps{coactor=Kind.Ops{okind}, cotile} <- getsState scops
sb <- getsState $ getActorBody source
let lid = blid sb
spos = bpos sb
lvl@Level{lxsize, lysize} <- getLevel lid
case bla lxsize lysize eps spos tpxy of
Nothing -> return $ Just ProjectAimOnself
Just [] -> assert `failure` "projecting from the edge of level"
`twith` (spos, tpxy)
Just (pos : rest) -> do
let t = lvl `at` pos
if not $ Tile.isClear cotile t
then return $ Just ProjectBlockTerrain
else do
mab <- getsState $ posToActor pos lid
if not $ maybe True (bproj . snd . fst) mab
then
if isShrapnel then do
projectBla source spos (pos : rest) iid container
return Nothing
else return $ Just ProjectBlockActor
else do
blockedByFoes <-
if isShrapnel then return False
else do
fact <- getsState $ (EM.! bfid sb) . sfactionD
foes <- getsState $ actorNotProjList (isAtWar fact) lid
return $! foesAdjacent lxsize lysize spos foes
if blockedByFoes then
return $ Just ProjectBlockFoes
else if not (asight (okind $ bkind sb) || bproj sb)
then return $ Just ProjectBlind
else do
if isShrapnel && eps `mod` 2 == 0 then
projectBla source spos (pos:rest) iid container
else
projectBla source pos rest iid container
return Nothing
projectBla :: (MonadAtomic m, MonadServer m)
=> ActorId
-> Point
-> [Point]
-> ItemId
-> Container
-> m ()
projectBla source pos rest iid container = do
sb <- getsState $ getActorBody source
let lid = blid sb
time = btime sb
unless (bproj sb) $ execSfxAtomic $ ProjectD source iid
projId <- addProjectile pos rest iid lid (bfid sb) time
execCmdAtomic $ MoveItemA iid 1 container (CActor projId (InvChar 'a'))
addProjectile :: (MonadAtomic m, MonadServer m)
=> Point -> [Point] -> ItemId -> LevelId -> FactionId -> Time
-> m ActorId
addProjectile bpos rest iid blid bfid btime = do
Kind.COps{ coactor=coactor@Kind.Ops{okind}
, coitem=coitem@Kind.Ops{okind=iokind} } <- getsState scops
disco <- getsServer sdisco
item <- getsState $ getItemBody iid
let lingerPercent = isLingering coitem disco item
ik = iokind (fromJust $ jkind disco item)
speed = speedFromWeight (jweight item) (itoThrow ik)
range = rangeFromSpeed speed
adj | range < 5 = "falling"
| otherwise = "flying"
(object1, object2) = partItem coitem EM.empty item
name = makePhrase [MU.AW $ MU.Text adj, object1, object2]
trajectoryLength = lingerPercent * range `div` 100
dirTrajectory = take trajectoryLength $ pathToTrajectory (bpos : rest)
kind = okind $ projectileKindId coactor
m = actorTemplate (projectileKindId coactor) (asymbol kind) name
(acolor kind) speed 0 (Just dirTrajectory)
bpos blid btime bfid True
acounter <- getsServer sacounter
modifyServer $ \ser -> ser {sacounter = succ acounter}
execCmdAtomic $ CreateActorA acounter m [(iid, item)]
return $! acounter
applySer :: (MonadAtomic m, MonadServer m)
=> ActorId
-> ItemId
-> Container
-> m ()
applySer actor iid container = do
item <- getsState $ getItemBody iid
execSfxAtomic $ ActivateD actor iid
itemEffect actor actor (Just iid) item
execCmdAtomic $ DestroyItemA iid item 1 container
triggerSer :: (MonadAtomic m, MonadServer m)
=> ActorId -> Maybe F.Feature -> m ()
triggerSer 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 _ -> []
go <- triggerEffect aid feats
unless go $ execFailure aid 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 $ TriggerD aid tpos feat
void $ effectSem ef aid aid
return True
_ -> return False
goes <- mapM triggerFeat feats
return $! or goes
setTrajectorySer :: (MonadAtomic m, MonadServer m) => ActorId -> m ()
setTrajectorySer aid = do
cops <- getsState scops
b@Actor{bpos, btrajectory, blid, bcolor} <- getsState $ getActorBody aid
lvl <- getLevel blid
let clearTrajectory =
execCmdAtomic $ TrajectoryActorA aid btrajectory (Just [])
case btrajectory of
Just (d : lv) ->
if not $ accessibleDir cops lvl bpos d
then clearTrajectory
else do
when (length lv <= 1) $ do
let toColor = Color.BrBlack
when (bcolor /= toColor) $
execCmdAtomic $ ColorActorA aid bcolor toColor
moveSer aid d
execCmdAtomic $ TrajectoryActorA aid btrajectory (Just lv)
_ -> assert `failure` "null trajectory" `twith` (aid, b)
gameRestartSer :: (MonadAtomic m, MonadServer m)
=> ActorId -> Text -> Int -> [(Int, Text)] -> m ()
gameRestartSer aid stInfo 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
execCmdAtomic $ QuitFactionA fid (Just b) oldSt
$ Just $ Status Restart (fromEnum $ blid b) stInfo
gameExitSer :: (MonadAtomic m, MonadServer m) => ActorId -> Int -> m ()
gameExitSer 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 {squit = True}
execCmdAtomic $ QuitFactionA fid (Just b) oldSt
$ Just $ Status Camping (fromEnum $ blid b) ""
gameSaveSer :: MonadServer m => m ()
gameSaveSer = do
modifyServer $ \ser -> ser {sbkpSave = True}
modifyServer $ \ser -> ser {squit = True}