{-# LANGUAGE TupleSections #-}
module Game.LambdaHack.Server.BroadcastAtomic
( handleAndBroadcast, sendPer, handleCmdAtomicServer
#ifdef EXPOSE_INTERNAL
, hearUpdAtomic, hearSfxAtomic, filterHear, atomicForget, atomicRemember
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Game.LambdaHack.Atomic
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import qualified Game.LambdaHack.Common.ItemAspect as IA
import Game.LambdaHack.Common.Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Types
import qualified Game.LambdaHack.Content.ItemKind as IK
import Game.LambdaHack.Content.TileKind (isUknownSpace)
import qualified Game.LambdaHack.Core.Dice as Dice
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Definition.Ability as Ability
import Game.LambdaHack.Definition.Defs
import Game.LambdaHack.Server.MonadServer
import Game.LambdaHack.Server.ProtocolM
import Game.LambdaHack.Server.ServerOptions
import Game.LambdaHack.Server.State
handleCmdAtomicServer :: MonadServerAtomic m
=> UpdAtomic -> m (PosAtomic, [UpdAtomic], Bool)
handleCmdAtomicServer cmd = do
ps <- posUpdAtomic cmd
atomicBroken <- breakUpdAtomic cmd
executedOnServer <- if seenAtomicSer ps
then execUpdAtomicSer cmd
else return False
return (ps, atomicBroken, executedOnServer)
handleAndBroadcast :: (MonadServerAtomic m, MonadServerComm m)
=> PosAtomic -> [UpdAtomic] -> CmdAtomic -> m ()
handleAndBroadcast ps atomicBroken atomic = do
knowEvents <- getsServer $ sknowEvents . soptions
sperFidOld <- getsServer sperFid
let sendAtomic fid (UpdAtomic cmd) = sendUpdate fid cmd
sendAtomic fid (SfxAtomic sfx) = sendSfx fid sfx
breakSend lid fid perFidLid = do
let send2 (cmd2, ps2) =
when (seenAtomicCli knowEvents fid perFidLid ps2) $
sendUpdate fid cmd2
psBroken <- mapM posUpdAtomic atomicBroken
case psBroken of
_ : _ -> mapM_ send2 $ zip atomicBroken psBroken
[] -> do
let drainCalmOnce aid = do
b <- getsState $ getActorBody aid
when (deltaBenign $ bcalmDelta b) $
execUpdAtomic $ UpdRefillCalm aid minusM
as <- getsState $ fidActorRegularAssocs fid lid
case atomic of
UpdAtomic cmd -> do
maids <- hearUpdAtomic as cmd
case maids of
Nothing -> return ()
Just aids -> do
sendUpdate fid $ UpdHearFid fid
$ HearUpd (not $ null aids) cmd
mapM_ drainCalmOnce aids
SfxAtomic cmd -> do
mhear <- hearSfxAtomic as cmd
case mhear of
Nothing -> return ()
Just (hearMsg, aids) -> do
sendUpdate fid $ UpdHearFid fid hearMsg
mapM_ drainCalmOnce aids
anySend lid fid perFidLid =
if seenAtomicCli knowEvents fid perFidLid ps
then sendAtomic fid atomic
else breakSend lid fid perFidLid
posLevel lid fid =
anySend lid fid $ sperFidOld EM.! fid EM.! lid
send fid = case ps of
PosSight lid _ -> posLevel lid fid
PosFidAndSight _ lid _ -> posLevel lid fid
PosFidAndSer (Just lid) _ -> posLevel lid fid
PosSmell lid _ -> posLevel lid fid
PosFid fid2 -> when (fid == fid2) $ sendAtomic fid atomic
PosFidAndSer Nothing fid2 ->
when (fid == fid2) $ sendAtomic fid atomic
PosSer -> return ()
PosAll -> sendAtomic fid atomic
PosNone -> error $ "" `showFailure` (fid, atomic)
factionD <- getsState sfactionD
mapM_ send $ EM.keys factionD
hearUpdAtomic :: MonadStateRead m
=> [(ActorId, Actor)] -> UpdAtomic
-> m (Maybe [ActorId])
hearUpdAtomic as cmd = do
COps{coTileSpeedup} <- getsState scops
case cmd of
UpdDestroyActor _ body _ | not $ bproj body -> do
aids <- filterHear (bpos body) as
return $ Just aids
UpdCreateItem iid item _ (CActor aid cstore) -> do
itemKind <- getsState $ getItemKindServer item
discoAspect <- getsState sdiscoAspect
let arItem = discoAspect EM.! iid
if cstore /= COrgan
|| IA.checkFlag Ability.Blast arItem
&& Dice.supDice (IK.idamage itemKind) > 0 then do
body <- getsState $ getActorBody aid
aids <- filterHear (bpos body) as
return $ Just aids
else return Nothing
UpdTrajectory aid (Just (l, _)) Nothing | not (null l) -> do
b <- getsState $ getActorBody aid
discoAspect <- getsState sdiscoAspect
let arTrunk = discoAspect EM.! btrunk b
aids <- filterHear (bpos b) as
return $! if bproj b && IA.checkFlag Ability.Blast arTrunk || null aids
then Nothing
else Just aids
UpdAlterTile _ p _ toTile -> do
aids <- filterHear p as
return $! if Tile.isDoor coTileSpeedup toTile && null aids
then Nothing
else Just aids
UpdAlterExplorable{} -> return $ Just []
_ -> return Nothing
hearSfxAtomic :: MonadServer m
=> [(ActorId, Actor)] -> SfxAtomic
-> m (Maybe (HearMsg, [ActorId]))
hearSfxAtomic as cmd =
case cmd of
SfxStrike aid _ iid _ -> do
b <- getsState $ getActorBody aid
discoAspect <- getsState sdiscoAspect
let arItem = discoAspect EM.! iid
aids <- filterHear (bpos b) as
itemKindId <- getsState $ getIidKindIdServer iid
return $! if IA.checkFlag Ability.Blast arItem || null aids
then Nothing
else Just (HearStrike itemKindId, aids)
SfxEffect _ aid (IK.Summon grp p) _ -> do
b <- getsState $ getActorBody aid
aids <- filterHear (bpos b) as
return $! if null aids
then Nothing
else Just (HearSummon (bproj b) grp p, aids)
SfxTaunt voluntary aid -> do
b <- getsState $ getActorBody aid
aids <- filterHear (bpos b) as
(subject, verb) <- displayTaunt voluntary rndToAction aid
return $ Just (HearTaunt $ subject <+> verb, aids)
_ -> return Nothing
filterHear :: MonadStateRead m => Point -> [(ActorId, Actor)] -> m [ActorId]
filterHear pos as = do
let actorHear (aid, body) = do
actorMaxSk <- getsState $ getActorMaxSkills aid
return $! Ability.getSk Ability.SkHearing actorMaxSk
>= chessDist pos (bpos body)
map fst <$> filterM actorHear as
sendPer :: (MonadServerAtomic m, MonadServerComm m)
=> FactionId -> LevelId -> Perception -> Perception -> Perception
-> m ()
{-# INLINE sendPer #-}
sendPer fid lid outPer inPer perNew = do
knowEvents <- getsServer $ sknowEvents . soptions
unless knowEvents $ do
sendUpdNoState fid $ UpdPerception lid outPer inPer
sClient <- getsServer $ (EM.! fid) . sclientStates
let forget = atomicForget fid lid outPer sClient
remember <- getsState $ atomicRemember lid inPer sClient
let seenNew = seenAtomicCli False fid perNew
psRem <- mapM posUpdAtomic remember
let !_A = assert (allB seenNew psRem) ()
mapM_ (sendUpdateCheck fid) forget
mapM_ (sendUpdate fid) remember
atomicForget :: FactionId -> LevelId -> Perception -> State
-> [UpdAtomic]
atomicForget side lid outPer sClient =
let outFov = totalVisible outPer
fActor (aid, b) =
UpdLoseActor aid b $ getCarriedAssocsAndTrunk b sClient
outPrioBig = mapMaybe (\p -> posToBigAssoc p lid sClient)
$ ES.elems outFov
outPrioProj = concatMap (\p -> posToProjAssocs p lid sClient)
$ ES.elems outFov
in map fActor $ filter ((/= side) . bfid . snd) outPrioBig ++ outPrioProj
atomicRemember :: LevelId -> Perception -> State -> State -> [UpdAtomic]
{-# INLINE atomicRemember #-}
atomicRemember lid inPer sClient s =
let COps{cotile, coTileSpeedup} = scops s
inFov = ES.elems $ totalVisible inPer
lvl = sdungeon s EM.! lid
lvlClient = sdungeon sClient EM.! lid
inContainer allow fc bagEM bagEMClient =
let f p = case (EM.lookup p bagEM, EM.lookup p bagEMClient) of
(Nothing, Nothing) -> []
(Just bag, Nothing) ->
let ais = map (\iid -> (iid, getItemBody iid s))
(EM.keys bag)
in [UpdSpotItemBag (fc lid p) bag ais | allow p]
(Nothing, Just bagClient) ->
let aisClient = map (\iid -> (iid, getItemBody iid sClient))
(EM.keys bagClient)
in [UpdLoseItemBag (fc lid p) bagClient aisClient]
(Just bag, Just bagClient) ->
if bag == bagClient
then []
else
let aisClient = map (\iid -> (iid, getItemBody iid sClient))
(EM.keys bagClient)
ais = map (\iid -> (iid, getItemBody iid s))
(EM.keys bag)
in [ UpdLoseItemBag (fc lid p) bagClient aisClient
, UpdSpotItemBag (fc lid p) bag ais ]
in concatMap f inFov
inFloor = inContainer (const True) CFloor (lfloor lvl) (lfloor lvlClient)
allowEmbed p = not (Tile.isHideAs coTileSpeedup $ lvl `at` p)
|| lvl `at` p == lvlClient `at` p
inEmbed = inContainer allowEmbed CEmbed (lembed lvl) (lembed lvlClient)
atomicTile =
let f p (loses1, spots1, entries1) =
let t = lvl `at` p
tHidden = fromMaybe t $ Tile.hideAs cotile t
tClient = lvlClient `at` p
entries2 = case EM.lookup p $ lentry lvl of
Nothing -> entries1
Just entry2 -> case EM.lookup p $ lentry lvlClient of
Nothing -> (p, entry2) : entries1
Just entry3 -> assert (entry3 == entry2) entries1
in if tClient `elem` [t, tHidden]
then (loses1, spots1, entries1)
else ( if isUknownSpace tClient
then loses1
else (p, tClient) : loses1
, (p, tHidden) : spots1
, if tHidden == t then entries2 else entries1)
(loses, spots, entries) = foldr f ([], [], []) inFov
in [UpdLoseTile lid loses | not $ null loses]
++ [UpdSpotTile lid spots | not $ null spots]
++ [UpdSpotEntry lid entries | not $ null entries]
inSmellFov = ES.elems $ totalSmelled inPer
inSm = mapMaybe (\p -> (p,) <$> EM.lookup p (lsmell lvlClient)) inSmellFov
inSmell = if null inSm then [] else [UpdLoseSmell lid inSm]
inSm2 = mapMaybe (\p -> (p,) <$> EM.lookup p (lsmell lvl)) inSmellFov
atomicSmell = if null inSm2 then [] else [UpdSpotSmell lid inSm2]
inAssocs = concatMap (\p -> posToAidAssocs p lid s) inFov
fActor (aid, b) = let ais = getCarriedAssocsAndTrunk b s
in UpdSpotActor aid b ais
inActor = map fActor inAssocs
in atomicTile ++ inFloor ++ inEmbed ++ inSmell ++ atomicSmell ++ inActor