PosAtomicRead.hs

-- | Semantics of atomic commands shared by client and server.
-- See
-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.
module Game.LambdaHack.Atomic.PosAtomicRead
  ( PosAtomic(..), posUpdAtomic, posSfxAtomic
  , resetsFovCmdAtomic, breakUpdAtomic, breakSfxAtomic, loudUpdAtomic
  , seenAtomicCli, seenAtomicSer, generalMoveItem
  ) where

import Control.Applicative
import Control.Exception.Assert.Sugar
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import qualified NLP.Miniutter.English as MU

import Game.LambdaHack.Atomic.CmdAtomic
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import qualified Game.LambdaHack.Common.Effect as Effect
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Msg
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Content.ModeKind as ModeKind

-- All functions here that take an atomic action are executed
-- in the state just before the action is executed.

-- | The type representing visibility of actions to factions,
-- based on the position of the action, etc.
data PosAtomic =
    PosSight !LevelId ![Point]  -- ^ whomever sees all the positions, notices
  | PosFidAndSight ![FactionId] !LevelId ![Point]
                                -- ^ observers and the faction notice
  | PosSmell !LevelId ![Point]  -- ^ whomever smells all the positions, notices
  | PosFid !FactionId           -- ^ only the faction notices
  | PosFidAndSer !(Maybe LevelId) !FactionId  -- ^ faction and server notices
  | PosSer                      -- ^ only the server notices
  | PosAll                      -- ^ everybody notices
  | PosNone                     -- ^ never broadcasted, but sent manually
  deriving (Show, Eq)

-- | Produce the positions where the action takes place.
-- The goal of the mechanics: client should not get significantly
-- more information by looking at the atomic commands he is able to see
-- than by looking at the state changes they enact. E.g., @UpdDisplaceActor@
-- in a black room, with one actor carrying a 0-radius light would not be
-- distinguishable by looking at the state (or the screen) from @UpdMoveActor@
-- of the illuminated actor, hence such @UpdDisplaceActor@ should not be
-- observable, but @UpdMoveActor@ should be (or the former should be perceived
-- as the latter). However, to simplify, we assing as strict visibility
-- requirements to @UpdMoveActor@ as to @UpdDisplaceActor@ and fall back
-- to @UpdSpotActor@ (which provides minimal information that does not
-- contradict state) if the visibility is lower.
posUpdAtomic :: MonadStateRead m => UpdAtomic -> m PosAtomic
posUpdAtomic cmd = case cmd of
  UpdCreateActor _ body _ -> posProjBody body
  UpdDestroyActor _ body _ -> posProjBody body
  UpdCreateItem _ _ _ c -> singleContainer c
  UpdDestroyItem _ _ _ c -> singleContainer c
  UpdSpotActor _ body _ -> posProjBody body
  UpdLoseActor _ body _ -> posProjBody body
  UpdSpotItem _ _ _ c -> singleContainer c
  UpdLoseItem _ _ _ c -> singleContainer c
  UpdMoveActor aid fromP toP -> do
    b <- getsState $ getActorBody aid
    -- Non-projectile actors are never totally isolated from envirnoment;
    -- they hear, feel air movement, etc.
    return $! if bproj b
              then PosSight (blid b) [fromP, toP]
              else PosFidAndSight [bfid b] (blid b) [fromP, toP]
  UpdWaitActor aid _ -> singleAid aid
  UpdDisplaceActor source target -> do
    sb <- getsState $ getActorBody source
    tb <- getsState $ getActorBody target
    let ps = [bpos sb, bpos tb]
        lid = assert (blid sb == blid tb) $ blid sb
    return $! if bproj sb && bproj tb
              then PosSight lid ps
              else if bproj sb
              then PosFidAndSight [bfid tb] lid ps
              else if bproj tb
              then PosFidAndSight [bfid sb] lid ps
              else PosFidAndSight [bfid sb, bfid tb] lid ps
  UpdMoveItem _ _ aid _ CSha -> do  -- shared stash is private
    b <- getsState $ getActorBody aid
    return $! PosFidAndSer (Just $ blid b) (bfid b)
  UpdMoveItem _ _ aid CSha _ -> do  -- shared stash is private
    b <- getsState $ getActorBody aid
    return $! PosFidAndSer (Just $ blid b) (bfid b)
  UpdMoveItem _ _ aid _ _ -> singleAid aid
  UpdAgeActor aid _ -> singleAid aid
  UpdRefillHP aid _ -> singleAid aid
  UpdRefillCalm aid _ -> singleAid aid
  UpdOldFidActor aid _ _ -> singleAid aid
  UpdTrajectory aid _ _ -> singleAid aid
  UpdColorActor aid _ _ -> singleAid aid
  UpdQuitFaction{} -> return PosAll
  UpdLeadFaction fid _ _ -> do
    fact <- getsState $ (EM.! fid) . sfactionD
    return $! if fleaderMode (gplayer fact) /= LeaderNull
              then PosFidAndSer Nothing fid
              else PosNone
  UpdDiplFaction{} -> return PosAll
  UpdTacticFaction fid _ _ -> return $! PosFidAndSer Nothing fid
  UpdAutoFaction{} -> return PosAll
  UpdRecordKill aid _ _ -> singleFidAndAid aid
  UpdAlterTile lid p _ _ -> return $! PosSight lid [p]
  UpdAlterClear{} -> return PosAll
  UpdSearchTile aid p _ _ -> do
    (lid, pos) <- posOfAid aid
    return $! PosSight lid [pos, p]
  UpdLearnSecrets aid _ _ -> singleAid aid
  UpdSpotTile lid ts -> do
    let ps = map fst ts
    return $! PosSight lid ps
  UpdLoseTile lid ts -> do
    let ps = map fst ts
    return $! PosSight lid ps
  UpdAlterSmell lid p _ _ -> return $! PosSmell lid [p]
  UpdSpotSmell lid sms -> do
    let ps = map fst sms
    return $! PosSmell lid ps
  UpdLoseSmell lid sms -> do
    let ps = map fst sms
    return $! PosSmell lid ps
  UpdAgeGame _ _ -> return PosAll
  UpdDiscover lid p _ _ _ -> return $! PosSight lid [p]
  UpdCover lid p _ _ _ -> return $! PosSight lid [p]
  UpdDiscoverKind lid p _ _ -> return $! PosSight lid [p]
  UpdCoverKind lid p _ _ -> return $! PosSight lid [p]
  UpdDiscoverSeed lid p _ _ -> return $! PosSight lid [p]
  UpdCoverSeed lid p _ _ -> return $! PosSight lid [p]
  UpdPerception{} -> return PosNone
  UpdRestart fid _ _ _ _ _ -> return $! PosFid fid
  UpdRestartServer _ -> return PosSer
  UpdResume fid _ -> return $! PosFid fid
  UpdResumeServer _ -> return PosSer
  UpdKillExit fid -> return $! PosFid fid
  UpdWriteSave -> return PosAll
  UpdMsgAll{} -> return PosAll
  UpdRecordHistory fid -> return $! PosFid fid

-- | Produce the positions where the atomic special effect takes place.
posSfxAtomic :: MonadStateRead m => SfxAtomic -> m PosAtomic
posSfxAtomic cmd = case cmd of
  SfxStrike source target _ _ -> do
    (slid, sp) <- posOfAid source
    (tlid, tp) <- posOfAid target
    return $! assert (slid == tlid) $ PosSight slid [sp, tp]
  SfxRecoil source target _ _ -> do
    (slid, sp) <- posOfAid source
    (tlid, tp) <- posOfAid target
    return $! assert (slid == tlid) $ PosSight slid [sp, tp]
  SfxProject aid _ -> singleAid aid
  SfxCatch aid _ -> singleAid aid
  SfxActivate aid _ _ -> singleAid aid
  SfxCheck aid _ _ -> singleAid aid
  SfxTrigger aid p _ -> do
    (lid, pa) <- posOfAid aid
    return $! PosSight lid [pa, p]
  SfxShun aid p _ -> do
    (lid, pa) <- posOfAid aid
    return $! PosSight lid [pa, p]
  SfxEffect _ aid _ -> singleAid aid  -- sometimes we don't see source, OK
  SfxMsgFid fid _ -> return $! PosFid fid
  SfxMsgAll _ -> return PosAll
  SfxActorStart aid -> singleAid aid

posProjBody :: Monad m => Actor -> m PosAtomic
posProjBody body = return $!
  if bproj body
  then PosSight (blid body) [bpos body]
  else PosFidAndSight [bfid body] (blid body) [bpos body]

singleFidAndAid :: MonadStateRead m => ActorId -> m PosAtomic
singleFidAndAid aid = do
  body <- getsState $ getActorBody aid
  return $! PosFidAndSight [bfid body] (blid body) [bpos body]

singleAid :: MonadStateRead m => ActorId -> m PosAtomic
singleAid aid = do
  (lid, p) <- posOfAid aid
  return $! PosSight lid [p]

singleContainer :: MonadStateRead m => Container -> m PosAtomic
singleContainer (CFloor lid p) = return $! PosSight lid [p]
singleContainer (CActor aid CSha) = do  -- shared stash is private
  b <- getsState $ getActorBody aid
  return $! PosFidAndSer (Just $ blid b) (bfid b)
singleContainer (CActor aid _) = do
  (lid, p) <- posOfAid aid
  return $! PosSight lid [p]
singleContainer (CTrunk fid lid p) = return $! PosFidAndSight [fid] lid [p]

-- | Determines if a command resets FOV.
--
-- Invariant: if @resetsFovCmdAtomic@ determines we do not need
-- to reset Fov, perception (@ptotal@ to be precise, @psmell@ is irrelevant)
-- of any faction does not change upon recomputation. Otherwise,
-- save/restore would change game state.
resetsFovCmdAtomic :: UpdAtomic -> Bool
resetsFovCmdAtomic cmd = case cmd of
  -- Create/destroy actors and items.
  UpdCreateActor{} -> True  -- may have a light source
  UpdDestroyActor{} -> True
  UpdCreateItem{} -> True  -- may be a light source
  UpdDestroyItem{} -> True
  UpdSpotActor{} -> True
  UpdLoseActor{} -> True
  UpdSpotItem{} -> True
  UpdLoseItem{} -> True
  -- Move actors and items.
  UpdMoveActor{} -> True
  UpdDisplaceActor{} -> True
  UpdMoveItem{} -> True  -- light sources, sight radius bonuses
  UpdRefillCalm{} -> True  -- Calm caps sight radius
  -- Alter map.
  UpdAlterTile{} -> True  -- even if pos not visible initially
  UpdSpotTile{} -> True
  UpdLoseTile{} -> True
  _ -> False

-- | Decompose an atomic action. The original action is visible
-- if it's positions are visible both before and after the action
-- (in between the FOV might have changed). The decomposed actions
-- are only tested vs the FOV after the action and they give reduced
-- information that still modifies client's state to match the server state
-- wrt the current FOV and the subset of @posUpdAtomic@ that is visible.
-- The original actions give more information not only due to spanning
-- potentially more positions than those visible. E.g., @UpdMoveActor@
-- informs about the continued existence of the actor between
-- moves, v.s., popping out of existence and then back in.
breakUpdAtomic :: MonadStateRead m => UpdAtomic -> m [UpdAtomic]
breakUpdAtomic cmd = case cmd of
  UpdMoveActor aid _ toP -> do
    -- We assume other factions don't see leaders and we know the actor's
    -- faction always sees the atomic command, so the leader doesn't
    -- need to be updated (or the actor is a projectile, hence not a leader).
    b <- getsState $ getActorBody aid
    ais <- getsState $ getCarriedAssocs b
    return [ UpdLoseActor aid b ais
           , UpdSpotActor aid b {bpos = toP, boldpos = bpos b} ais ]
  UpdDisplaceActor source target -> do
    sb <- getsState $ getActorBody source
    sais <- getsState $ getCarriedAssocs sb
    tb <- getsState $ getActorBody target
    tais <- getsState $ getCarriedAssocs tb
    return [ UpdLoseActor source sb sais
           , UpdSpotActor source sb {bpos = bpos tb, boldpos = bpos sb} sais
           , UpdLoseActor target tb tais
           , UpdSpotActor target tb {bpos = bpos sb, boldpos = bpos tb} tais
           ]
  UpdMoveItem iid k aid cstore1 cstore2 | cstore1 == CSha  -- CSha is private
                                          || cstore2 == CSha -> do
    item <- getsState $ getItemBody iid
    return [ UpdLoseItem iid item k (CActor aid cstore1)
           , UpdSpotItem iid item k (CActor aid cstore2) ]
  -- No need to cover @UpdSearchTile@, because if an actor sees only
  -- one of the positions and so doesn't notice the search results,
  -- he's left with a hidden tile, which doesn't cause any trouble
  -- (because the commands doesn't change @State@ and the client-side
  -- processing of the command is lenient).
  _ -> return [cmd]

-- | Decompose an atomic special effect.
breakSfxAtomic :: MonadStateRead m => SfxAtomic -> m [SfxAtomic]
breakSfxAtomic cmd = case cmd of
  SfxStrike source target _ _ -> do
    -- Hack: make a fight detectable even if one of combatants not visible.
    sb <- getsState $ getActorBody source
    return $! [ SfxEffect (bfid sb) source (Effect.RefillCalm (-1))
              | not $ bproj sb ]
              ++ [SfxEffect (bfid sb) target (Effect.RefillHP (-1))]
  _ -> return [cmd]

-- | Messages for some unseen game object creation/destruction/alteration.
loudUpdAtomic :: MonadStateRead m
              => Bool -> FactionId -> UpdAtomic -> m (Maybe Msg)
loudUpdAtomic local fid cmd = do
  msound <- case cmd of
    UpdDestroyActor _ body _
      -- Death of a party member does not need to be heard,
      -- because it's seen.
      | not $ fid == bfid body || bproj body -> return $ Just "shriek"
    UpdCreateItem{} -> return $ Just "clatter"
    UpdAlterTile _ _ fromTile _ -> do
      Kind.COps{cotile} <- getsState scops
      if Tile.isDoor cotile fromTile
        then return $ Just "creaking sound"
        else return $ Just "rumble"
    _ -> return Nothing
  let distant = if local then [] else ["distant"]
      hear sound = makeSentence [ "you hear"
                                , MU.AW $ MU.Phrase $ distant ++ [sound] ]
  return $! hear <$> msound

seenAtomicCli :: Bool -> FactionId -> Perception -> PosAtomic -> Bool
seenAtomicCli knowEvents fid per posAtomic =
  case posAtomic of
    PosSight _ ps -> all (`ES.member` totalVisible per) ps || knowEvents
    PosFidAndSight fids _ ps ->
      fid `elem` fids || all (`ES.member` totalVisible per) ps || knowEvents
    PosSmell _ ps -> all (`ES.member` smellVisible per) ps || knowEvents
    PosFid fid2 -> fid == fid2
    PosFidAndSer _ fid2 -> fid == fid2
    PosSer -> False
    PosAll -> True
    PosNone -> assert `failure` "no position possible" `twith` fid

seenAtomicSer :: PosAtomic -> Bool
seenAtomicSer posAtomic =
  case posAtomic of
    PosFid _ -> False
    PosNone -> False
    _ -> True

generalMoveItem :: MonadStateRead m
                => ItemId -> Int -> Container -> Container
                -> m [UpdAtomic]
generalMoveItem iid k c1 c2 = do
  case (c1, c2) of
    (CActor aid1 cstore1, CActor aid2 cstore2) | aid1 == aid2 -> do
      return [UpdMoveItem iid k aid1 cstore1 cstore2]
    _ -> do
      item <- getsState $ getItemBody iid
      return [ UpdLoseItem iid item k c1
             , UpdSpotItem iid item k c2 ]