{-# LANGUAGE TupleSections #-}
module Game.LambdaHack.Server.BroadcastAtomic
( handleAndBroadcast, sendPer, handleCmdAtomicServer
#ifdef EXPOSE_INTERNAL
, loudUpdAtomic, loudSfxAtomic, atomicForget, atomicRemember
#endif
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.Key (mapWithKeyM_)
import Game.LambdaHack.Atomic
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Faction
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 qualified Game.LambdaHack.Content.ItemKind as IK
import Game.LambdaHack.Content.TileKind (isUknownSpace)
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, MonadServerReadRequest 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 fact perFidLid = do
let hear atomic2 = do
local <- case gleader fact of
Nothing -> return True
Just leader -> do
body <- getsState $ getActorBody leader
return $! (blid body == lid)
loud <- case atomic2 of
UpdAtomic cmd -> loudUpdAtomic local cmd
SfxAtomic cmd -> loudSfxAtomic local cmd
case loud of
Nothing -> return ()
Just msg -> sendSfx fid $ SfxMsgFid fid msg
send2 (cmd2, ps2) =
when (seenAtomicCli knowEvents fid perFidLid ps2) $
sendUpdate fid cmd2
psBroken <- mapM posUpdAtomic atomicBroken
case psBroken of
_ : _ -> mapM_ send2 $ zip atomicBroken psBroken
[] -> hear atomic
anySend lid fid fact perFidLid =
if seenAtomicCli knowEvents fid perFidLid ps
then sendAtomic fid atomic
else breakSend lid fid fact perFidLid
posLevel lid fid fact =
anySend lid fid fact $ sperFidOld EM.! fid EM.! lid
send fid fact = case ps of
PosSight lid _ -> posLevel lid fid fact
PosFidAndSight _ lid _ -> posLevel lid fid fact
PosFidAndSer (Just lid) _ -> posLevel lid fid fact
PosSmell lid _ -> posLevel lid fid fact
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, fact, atomic)
factionD <- getsState sfactionD
mapWithKeyM_ send factionD
loudUpdAtomic :: MonadStateRead m => Bool -> UpdAtomic -> m (Maybe SfxMsg)
loudUpdAtomic local cmd = do
COps{coTileSpeedup} <- getsState scops
mcmd <- case cmd of
UpdDestroyActor _ body _ | not $ bproj body -> return $ Just cmd
UpdCreateItem _ _ _ (CActor _ CGround) -> return $ Just cmd
UpdTrajectory aid (Just (l, _)) Nothing | local && not (null l) -> do
b <- getsState $ getActorBody aid
itemKind <- getsState $ getIidKindServer (btrunk b)
return $! if bproj b && IK.isBlast itemKind then Nothing else Just cmd
UpdAlterTile _ _ fromTile _ -> return $!
if Tile.isDoor coTileSpeedup fromTile
then if local then Just cmd else Nothing
else Just cmd
UpdAlterExplorable{} -> return $ Just cmd
_ -> return Nothing
return $! SfxLoudUpd local <$> mcmd
loudSfxAtomic :: MonadStateRead m => Bool -> SfxAtomic -> m (Maybe SfxMsg)
loudSfxAtomic local cmd =
case cmd of
SfxStrike _ _ iid _ | local -> do
itemKindId <- getsState $ getIidKindIdServer iid
let distance = 20
return $ Just $ SfxLoudStrike local itemKindId distance
SfxEffect _ aid (IK.Summon grp p) _ | local -> do
b <- getsState $ getActorBody aid
return $ Just $ SfxLoudSummon (bproj b) grp p
_ -> return Nothing
sendPer :: (MonadServerAtomic m, MonadServerReadRequest 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
outPrio = concatMap (\p -> posToAssocs p lid sClient) $ ES.elems outFov
fActor (aid, b) =
if not (bproj b) && bfid b == side
then Nothing
else Just $ UpdLoseActor aid b $ getCarriedAssocsAndTrunk b sClient
outActor = mapMaybe fActor outPrio
in outActor
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) =
let t = lvl `at` p
tHidden = fromMaybe t $ Tile.hideAs cotile t
tClient = lvlClient `at` p
in if tClient `elem` [t, tHidden]
then (loses1, spots1)
else ( if isUknownSpace tClient
then loses1
else (p, tClient) : loses1
, (p, tHidden) : spots1 )
(loses, spots) = foldr f ([], []) inFov
in [UpdLoseTile lid loses | not $ null loses]
++ [UpdSpotTile lid spots | not $ null spots]
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 -> posToAssocs 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