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 Data.Text as T
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.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.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.Config
import Game.LambdaHack.Server.EffectSem
import Game.LambdaHack.Server.State
import Game.LambdaHack.Utils.Assert
execFailure :: MonadAtomic m => FactionId -> Msg -> m Bool
execFailure fid msg = do
execSfxAtomic $ MsgFidD fid msg
return False
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
moveSer :: (MonadAtomic m, MonadServer m)
=> ActorId -> Vector -> Bool -> m Bool
moveSer aid dir exploration = do
cops <- getsState scops
sm <- getsState $ getActorBody aid
lvl <- getsLevel (blid sm) id
let spos = bpos sm
tpos = spos `shift` dir
let lid = blid sm
tgt <- getsState (posToActor tpos lid)
case tgt of
Just target -> do
actorAttackActor aid target
return True
Nothing
| accessible cops lvl spos tpos -> do
execCmdAtomic $ MoveActorA aid spos tpos
addSmell aid
return True
| otherwise ->
actorOpenDoor aid dir exploration
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
oldS <- getsLevel (blid b) $ EM.lookup (bpos b) . lsmell
let newTime = timeAdd time smellTimeout
execCmdAtomic $ AlterSmellA (blid b) (bpos b) oldS (Just newTime)
actorAttackActor :: (MonadAtomic m, MonadServer m)
=> ActorId -> ActorId -> m ()
actorAttackActor source target = do
cops@Kind.COps{coitem=Kind.Ops{opick, okind}} <- getsState scops
sm <- getsState (getActorBody source)
tm <- getsState (getActorBody target)
let sfid = bfid sm
tfid = bfid tm
time <- getsState $ getLocalTime (blid tm)
s <- getState
itemAssocs <- getsState $ getActorItem source
(miid, item) <-
if bproj sm
then case itemAssocs of
[(iid, item)] -> return (Just iid, item)
_ -> assert `failure` itemAssocs
else case strongestSword cops itemAssocs of
Just (_, (iid, w)) -> return (Just iid, w)
Nothing -> do
let h2hGroup | isSpawnFaction sfid s = "monstrous"
| otherwise = "unarmed"
h2hKind <- rndToAction $ opick h2hGroup (const True)
flavour <- getsServer sflavour
discoRev <- getsServer sdiscoRev
let kind = okind h2hKind
effect = fmap (maxDice . fst) (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 sm) $ execCmdAtomic $ HealActorA source (1)
itemEffect source target miid item
if braced tm time && not (bproj sm) && bhp tm > 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 sm || bproj tm
fromDipl = EM.findWithDefault Unknown tfid (gdipl sfact)
unless (friendlyFire || isAtWar sfact tfid || sfid == tfid) $
execCmdAtomic $ DiplFactionA sfid tfid fromDipl War
actorOpenDoor :: (MonadAtomic m, MonadServer m)
=> ActorId -> Vector -> Bool -> m Bool
actorOpenDoor aid dir exploration = do
Kind.COps{cotile} <- getsState scops
body <- getsState $ getActorBody aid
let dpos = shift (bpos body) dir
lid = blid body
lvl <- getsLevel lid id
let serverTile = lvl `at` dpos
freshClientTile = hideTile cotile dpos lvl
t | exploration = serverTile
| otherwise = freshClientTile
if Tile.hasFeature cotile F.Openable t
then triggerSer aid dpos
else do
when (exploration && serverTile /= freshClientTile) $
execCmdAtomic $ SearchTileA aid dpos freshClientTile serverTile
if Tile.hasFeature cotile F.Closable t
then execFailure (bfid body) "already open"
else if exploration && serverTile /= freshClientTile
then return True
else execFailure (bfid body) "never mind"
runSer :: (MonadAtomic m, MonadServer m) => ActorId -> Vector -> m Bool
runSer aid dir = do
cops <- getsState scops
sm <- getsState $ getActorBody aid
lvl <- getsLevel (blid sm) id
let spos = bpos sm
tpos = spos `shift` dir
let lid = blid sm
tgt <- getsState (posToActor tpos lid)
case tgt of
Just target
| accessible cops lvl spos tpos -> do
displaceActor aid target
return True
| otherwise ->
execFailure (bfid sm) "blocked"
Nothing
| accessible cops lvl spos tpos -> do
execCmdAtomic $ MoveActorA aid spos tpos
addSmell aid
return True
| otherwise ->
actorOpenDoor aid dir False
displaceActor :: MonadAtomic m
=> ActorId -> ActorId -> m ()
displaceActor source target = do
execCmdAtomic $ DisplaceActorA source target
addSmell source
waitSer :: MonadAtomic m => ActorId -> m ()
waitSer aid = do
Kind.COps{coactor} <- getsState scops
body <- getsState $ getActorBody aid
time <- getsState $ getLocalTime $ blid body
let fromWait = bwait body
toWait = timeAddFromSpeed coactor body time
execCmdAtomic $ WaitActorA aid fromWait toWait
pickupSer :: MonadAtomic m
=> ActorId -> ItemId -> Int -> InvChar -> m ()
pickupSer aid iid k l = assert (k > 0 `blame` (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 Bool
projectSer source tpos eps iid container = do
cops <- getsState scops
sm <- getsState (getActorBody source)
Actor{btime} <- getsState $ getActorBody source
lvl <- getsLevel (blid sm) id
lxsize <- getsLevel (blid sm) lxsize
lysize <- getsLevel (blid sm) lysize
let spos = bpos sm
lid = blid sm
time = btime `timeAdd` timeEpsilon
bl = bla lxsize lysize eps spos tpos
case bl of
Nothing -> execFailure (bfid sm) "cannot zap oneself"
Just [] -> assert `failure`
(spos, tpos, "project from the edge of level" :: Text)
Just path@(pos:_) -> do
inhabitants <- getsState (posToActor pos lid)
if accessible cops lvl spos pos && isNothing inhabitants
then do
execSfxAtomic $ ProjectD source iid
projId <- addProjectile iid pos (blid sm) (bfid sm) path time
execCmdAtomic
$ MoveItemA iid 1 container (CActor projId (InvChar 'a'))
return True
else
execFailure (bfid sm) "blocked"
addProjectile :: (MonadAtomic m, MonadServer m)
=> ItemId -> Point -> LevelId -> FactionId -> [Point] -> Time
-> m ActorId
addProjectile iid bpos blid bfid path btime = do
Kind.COps{coactor, coitem=coitem@Kind.Ops{okind}} <- getsState scops
disco <- getsServer sdisco
item <- getsState $ getItemBody iid
let ik = okind (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 path
m = actorTemplate (projectileKindId coactor) Nothing (Just name) Nothing
(Just 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 -> Point -> m Bool
triggerSer aid dpos = do
Kind.COps{cotile=cotile@Kind.Ops{okind, opick}} <- getsState scops
b <- getsState $ getActorBody aid
let lid = blid b
lvl <- getsLevel lid id
let serverTile = lvl `at` dpos
freshClientTile = hideTile cotile dpos lvl
when (serverTile /= freshClientTile) $
execCmdAtomic $ SearchTileA aid dpos freshClientTile serverTile
let f feat =
case feat of
F.Cause ef -> do
execSfxAtomic $ TriggerD aid dpos feat True
void $ effectSem ef aid aid
return True
F.ChangeTo tgroup -> do
execSfxAtomic $ TriggerD aid dpos feat True
as <- getsState $ actorList (const True) lid
if EM.null $ lvl `atI` dpos
then if unoccupied as dpos
then do
toTile <- rndToAction $ opick tgroup (const True)
execCmdAtomic $ AlterTileA lid dpos serverTile toTile
return True
else execFailure (bfid b) "blocked"
else execFailure (bfid b) "jammed"
_ -> return False
bs <- mapM f $ TileKind.tfeature $ okind serverTile
return $! or bs
setPathSer :: (MonadAtomic m, MonadServer m)
=> ActorId -> [Vector] -> m ()
setPathSer aid path = do
when (length path <= 2) $ do
fromColor <- getsState $ bcolor . getActorBody aid
let toColor = Just 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 False
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}
cfgDumpSer :: (MonadAtomic m, MonadServer m) => ActorId -> m ()
cfgDumpSer aid = do
b <- getsState $ getActorBody aid
let fid = bfid b
Config{configRulesCfgFile} <- getsServer sconfig
let fn = configRulesCfgFile ++ ".dump"
msg = "Server dumped current game rules configuration to file"
<+> T.pack fn <> "."
dumpCfg fn
execSfxAtomic $ MsgFidD fid msg