module Game.LambdaHack.Server.AtomicSemSer
( atomicSendSem
) where
import Control.Exception.Assert.Sugar
import Control.Monad
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.Key (mapWithKeyM_)
import Data.Maybe
import Game.LambdaHack.Common.Action
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.AtomicCmd
import Game.LambdaHack.Common.AtomicPos
import Game.LambdaHack.Common.AtomicSem
import Game.LambdaHack.Common.ClientCmd
import Game.LambdaHack.Common.Faction
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.State
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Server.Action
import Game.LambdaHack.Server.State
storeUndo :: MonadServer m => Atomic -> m ()
storeUndo _atomic =
maybe skip (\a -> modifyServer $ \ser -> ser {sundo = a : sundo ser})
$ Nothing
atomicServerSem :: (MonadAction m, MonadServer m)
=> PosAtomic -> Atomic -> m ()
atomicServerSem posAtomic atomic =
when (seenAtomicSer posAtomic) $ do
storeUndo atomic
case atomic of
CmdAtomic cmd -> cmdAtomicSem cmd
SfxAtomic _ -> return ()
atomicSendSem :: (MonadAction m, MonadConnServer m) => Atomic -> m ()
atomicSendSem atomic = do
sOld <- getState
factionD <- getsState sfactionD
persOld <- getsServer sper
(ps, resets, atomicBroken, psBroken) <-
case atomic of
CmdAtomic cmd -> do
ps <- posCmdAtomic cmd
resets <- resetsFovAtomic cmd
atomicBroken <- breakCmdAtomic cmd
psBroken <- mapM posCmdAtomic atomicBroken
return (ps, resets, atomicBroken, psBroken)
SfxAtomic sfx -> do
ps <- posSfxAtomic sfx
return (ps, Just [], [], [])
let atomicPsBroken = zip atomicBroken psBroken
assert (case ps of
PosSight{} -> True
PosFidAndSight{} -> True
_ -> resets == Just []
&& (null atomicBroken
|| fmap CmdAtomic atomicBroken == [atomic])) skip
atomicServerSem ps atomic
knowEvents <- getsServer $ sknowEvents . sdebugSer
let sendUI fid cmdUI =
when (playerUI $ gplayer $ factionD EM.! fid) $ sendUpdateUI fid cmdUI
sendAI fid cmdAI = sendUpdateAI fid cmdAI
sendA fid cmd = do
sendUI fid $ CmdAtomicUI cmd
sendAI fid $ CmdAtomicAI cmd
sendUpdate fid (CmdAtomic cmd) = sendA fid cmd
sendUpdate fid (SfxAtomic sfx) = sendUI fid $ SfxAtomicUI sfx
breakSend fid perNew = do
let send2 (atomic2, ps2) =
if seenAtomicCli knowEvents fid perNew ps2
then sendUpdate fid $ CmdAtomic atomic2
else when (loudCmdAtomic fid atomic2) $
sendUpdate fid
$ SfxAtomic $ MsgAllD "You hear some noises."
mapM_ send2 atomicPsBroken
anySend fid perOld perNew = do
let startSeen = seenAtomicCli knowEvents fid perOld ps
endSeen = seenAtomicCli knowEvents fid perNew ps
if startSeen && endSeen
then sendUpdate fid atomic
else breakSend fid perNew
posLevel fid lid = do
let perOld = persOld EM.! fid EM.! lid
resetsFid = maybe True (fid `elem`) resets
if resetsFid then do
resetFidPerception fid lid
perNew <- getPerFid fid lid
let inPer = diffPer perNew perOld
outPer = diffPer perOld perNew
if nullPer outPer && nullPer inPer
then anySend fid perOld perOld
else do
unless knowEvents $ do
sendA fid $ PerceptionA lid outPer inPer
let remember = atomicRemember lid inPer sOld
seenNew = seenAtomicCli False fid perNew
seenOld = seenAtomicCli False fid perOld
psRem <- mapM posCmdAtomic remember
assert (allB seenNew psRem) skip
assert (allB (not . seenOld) psRem) skip
mapM_ (sendA fid) remember
anySend fid perOld perNew
else anySend fid perOld perOld
send fid = case ps of
PosSight lid _ -> posLevel fid lid
PosFidAndSight _ lid _ -> posLevel fid lid
PosSmell lid _ -> do
let perOld = persOld EM.! fid EM.! lid
anySend fid perOld perOld
PosFid fid2 -> when (fid == fid2) $ sendUpdate fid atomic
PosFidAndSer fid2 -> when (fid == fid2) $ sendUpdate fid atomic
PosSer -> return ()
PosAll -> sendUpdate fid atomic
PosNone -> assert `failure` "illegal sending" `twith` (atomic, fid)
mapWithKeyM_ (\fid _ -> send fid) factionD
atomicRemember :: LevelId -> Perception -> State -> [CmdAtomic]
atomicRemember lid inPer s =
let inFov = ES.elems $ totalVisible inPer
lvl = sdungeon s EM.! lid
inPrio = concatMap (\p -> posToActors p lid s) inFov
fActor ((aid, b), ais) = SpotActorA aid b ais
inActor = map fActor inPrio
pMaybe p = maybe Nothing (\x -> Just (p, x))
inFloor = mapMaybe (\p -> pMaybe p $ EM.lookup p (lfloor lvl)) inFov
fItem p (iid, k) = SpotItemA iid (getItemBody iid s) k (CFloor lid p)
fBag (p, bag) = map (fItem p) $ EM.assocs bag
inItem = concatMap fBag inFloor
cotile = Kind.cotile (scops s)
inTileMap = map (\p -> (p, hideTile cotile lvl p)) inFov
atomicTile = if null inTileMap then [] else [SpotTileA lid inTileMap]
inSmellFov = ES.elems $ smellVisible inPer
inSm = mapMaybe (\p -> pMaybe p $ EM.lookup p (lsmell lvl)) inSmellFov
atomicSmell = if null inSm then [] else [SpotSmellA lid inSm]
in inItem ++ inActor ++ atomicTile ++ atomicSmell