module Game.LambdaHack.Server.ServerSem where
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 Control.Exception.Assert.Sugar
import Game.LambdaHack.Common.Action
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.AtomicCmd
import qualified Game.LambdaHack.Common.Color as Color
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)
=> Actor -> FailureSer -> m ()
execFailure body failureSer = do
let fid = bfid body
msg = showFailureSer failureSer
debugPrint $ "execFailure:" <+> showT fid <+> ":" <+> msg
execSfxAtomic $ MsgFidD fid 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
checkAdjacent :: MonadActionRO m => Actor -> Actor -> m Bool
checkAdjacent sb tb = do
Level{lxsize} <- getLevel $ blid sb
return $ blid sb == blid tb && adjacent lxsize (bpos sb) (bpos tb)
addSmell :: MonadAtomic m => ActorId -> m ()
addSmell aid = do
Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops
b <- getsState $ getActorBody aid
spawn <- getsState $ isSpawnFaction (bfid b)
let canSmell = asmell $ okind $ bkind b
unless (bproj b || spawn || 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 ->
meleeSer source target
Nothing
| accessible cops lvl spos tpos -> do
execCmdAtomic $ MoveActorA source spos tpos
addSmell source
| otherwise ->
execFailure sb MoveNothing
meleeSer :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m ()
meleeSer source target = do
cops@Kind.COps{coitem=Kind.Ops{opick, okind}} <- getsState scops
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
adj <- checkAdjacent sb tb
if not adj then execFailure sb MeleeDistant
else do
let sfid = bfid sb
tfid = bfid tb
time <- getsState $ getLocalTime (blid tb)
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
isSp <- getsState $ isSpawnFaction sfid
let h2hGroup | isSp = "monstrous"
| otherwise = "unarmed"
h2hKind <- rndToAction $ fmap (fromMaybe $ assert `failure` h2hGroup)
$ opick h2hGroup (const True)
flavour <- getsServer sflavour
discoRev <- getsServer sdiscoRev
let kind = okind h2hKind
effect = fmap maxDeep (ieffect kind)
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 time && 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
sfact <- getsState $ (EM.! sfid) . sfactionD
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
adj <- checkAdjacent sb tb
if not adj then execFailure sb 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
execCmdAtomic $ DisplaceActorA source target
addSmell source
else do
execFailure sb 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
Level{lxsize} <- getLevel lid
if not $ adjacent lxsize spos tpos then execFailure sb 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 sb 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 sb AlterBlockActor
else execFailure sb AlterBlockItem
waitSer :: MonadAtomic m => ActorId -> m ()
waitSer aid = do
body <- getsState $ getActorBody aid
time <- getsState $ getLocalTime $ blid body
let fromWait = bwait body
toWait = timeAddFromSpeed body time
execCmdAtomic $ WaitActorA aid fromWait toWait
pickupSer :: MonadAtomic m
=> ActorId -> ItemId -> Int -> InvChar -> m ()
pickupSer aid iid k l = assert (k > 0 `blame` "pick up no items"
`twith` (aid, iid, k, l)) $ do
b <- getsState $ getActorBody aid
execCmdAtomic $ MoveItemA iid k (CFloor (blid b) (bpos b)) (CActor aid l)
dropSer :: MonadAtomic m => ActorId -> ItemId -> m ()
dropSer aid iid = do
b <- getsState $ getActorBody aid
let k = 1
execCmdAtomic $ MoveItemA iid k (actorContainer aid (binv b) iid)
(CFloor (blid b) (bpos b))
projectSer :: (MonadAtomic m, MonadServer m)
=> ActorId
-> Point
-> Int
-> ItemId
-> Container
-> m ()
projectSer source tpos eps iid container = do
Kind.COps{cotile} <- getsState scops
sb <- getsState $ getActorBody source
let lid = blid sb
spos = bpos sb
fact <- getsState $ (EM.! bfid sb) . sfactionD
Level{lxsize, lysize} <- getLevel lid
foes <- getsState $ actorNotProjList (isAtWar fact) lid
if foesAdjacent lxsize lysize spos foes
then execFailure sb ProjectBlockFoes
else do
case bla lxsize lysize eps spos tpos of
Nothing -> execFailure sb ProjectAimOnself
Just [] -> assert `failure` "projecting from the edge of level"
`twith` (spos, tpos)
Just (pos : rest) -> do
as <- getsState $ actorList (const True) lid
lvl <- getLevel lid
let t = lvl `at` pos
if not $ Tile.hasFeature cotile F.Clear t
then execFailure sb ProjectBlockTerrain
else if unoccupied as pos
then projectBla source pos rest iid container
else execFailure sb ProjectBlockActor
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 `timeAdd` timeEpsilon
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 ik = iokind (fromJust $ jkind disco item)
speed = speedFromWeight (iweight ik) (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]
dirPath = take range $ displacePath (bpos : rest)
kind = okind $ projectileKindId coactor
m = actorTemplate (projectileKindId coactor) (asymbol kind) name
(acolor kind) speed 0 (Just dirPath)
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 sb 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
setPathSer :: (MonadAtomic m, MonadServer m)
=> ActorId -> [Vector] -> m ()
setPathSer aid path = do
when (length path <= 2) $ do
fromColor <- getsState $ bcolor . getActorBody aid
let toColor = Color.BrBlack
when (fromColor /= toColor) $
execCmdAtomic $ ColorActorA aid fromColor toColor
fromPath <- getsState $ bpath . getActorBody aid
case path of
[] -> execCmdAtomic $ PathActorA aid fromPath (Just [])
d : lv -> do
void $ moveSer aid d
execCmdAtomic $ PathActorA aid fromPath (Just lv)
gameRestartSer :: (MonadAtomic m, MonadServer m) => ActorId -> Text -> m ()
gameRestartSer aid stInfo = do
b <- getsState $ getActorBody aid
let fid = bfid b
oldSt <- getsState $ gquit . (EM.! fid) . sfactionD
modifyServer $ \ser -> ser {squit = True}
revealItems Nothing Nothing
execCmdAtomic $ QuitFactionA fid (Just b) oldSt
$ Just $ Status Restart (fromEnum $ blid b) stInfo
gameExitSer :: (MonadAtomic m, MonadServer m) => ActorId -> m ()
gameExitSer aid = do
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}