-- | Representation and computation of visiblity of atomic commands
-- by clients.
--
-- See
-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.
module Game.LambdaHack.Atomic.PosAtomicRead
  ( PosAtomic(..), posUpdAtomic, posSfxAtomic, iidUpdAtomic, iidSfxAtomic
  , breakUpdAtomic, lidOfPos, seenAtomicCli, seenAtomicSer
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , pointsProjBody, posProjBody, singleAid, doubleAid
  , singleContainerStash, singleContainerActor
#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.CmdAtomic
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.State
import Game.LambdaHack.Common.Types
import Game.LambdaHack.Definition.Defs

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

-- | The type representing visibility of atomic commands to factions,
-- based on the position of the command, etc. Note that the server
-- sees and smells all positions. Also note that hearing is not covered
-- because it gives very restricted information, so hearing doesn't equal
-- seeing (and we assume smelling actors get lots of data from smells).
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
  | PosSightLevels [(LevelId, Point)]
                                -- ^ whomever sees all the positions, notices
  | PosFid FactionId            -- ^ only the faction notices, server doesn't
  | PosFidAndSer FactionId      -- ^ faction and server notices
  | PosSer                      -- ^ only the server notices
  | PosAll                      -- ^ everybody notices
  | PosNone                     -- ^ never broadcasted, but sent manually
  deriving (Int -> PosAtomic -> ShowS
[PosAtomic] -> ShowS
PosAtomic -> String
(Int -> PosAtomic -> ShowS)
-> (PosAtomic -> String)
-> ([PosAtomic] -> ShowS)
-> Show PosAtomic
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PosAtomic -> ShowS
showsPrec :: Int -> PosAtomic -> ShowS
$cshow :: PosAtomic -> String
show :: PosAtomic -> String
$cshowList :: [PosAtomic] -> ShowS
showList :: [PosAtomic] -> ShowS
Show, PosAtomic -> PosAtomic -> Bool
(PosAtomic -> PosAtomic -> Bool)
-> (PosAtomic -> PosAtomic -> Bool) -> Eq PosAtomic
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PosAtomic -> PosAtomic -> Bool
== :: PosAtomic -> PosAtomic -> Bool
$c/= :: PosAtomic -> PosAtomic -> Bool
/= :: PosAtomic -> PosAtomic -> Bool
Eq)

-- | Produce the positions where the atomic update takes place or, more
-- generally, the conditions under which the update can be noticed by
-- a client.
--
-- The goal of this mechanics is to ensure that atomic commands involving
-- some positions visible by a client convey similar information as the client
-- would get by directly observing the changes
-- of the portion of server state limited to the visible positions.
-- Consequently, when the visible commands are later applied
-- to the client's state, the state stays consistent
-- --- in sync with the server state and correctly limited by visiblity.
-- There is some wiggle room both in what "in sync" and
-- "visible" means and how they propagate through time.
--
-- E.g., @UpdDisplaceActor@ in a black room between two enemy actors,
-- with only 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@ in similar cotext would be
-- (or the former should be perceived as the latter).
-- However, to simplify, we assign 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 :: forall (m :: * -> *). MonadStateRead m => UpdAtomic -> m PosAtomic
posUpdAtomic UpdAtomic
cmd = case UpdAtomic
cmd of
  UpdRegisterItems{} -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PosAtomic
PosNone
  UpdCreateActor ActorId
_ Actor
body [(ItemId, Item)]
_ -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! Actor -> PosAtomic
posProjBody Actor
body
  UpdDestroyActor ActorId
_ Actor
body [(ItemId, Item)]
_ -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! Actor -> PosAtomic
posProjBody Actor
body
  UpdCreateItem Bool
_ ItemId
_ Item
_ ItemQuant
_ Container
c -> Container -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => Container -> m PosAtomic
singleContainerStash Container
c
  UpdDestroyItem Bool
_ ItemId
_ Item
_ ItemQuant
_ Container
c -> Container -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => Container -> m PosAtomic
singleContainerStash Container
c
  UpdSpotActor ActorId
_ Actor
body -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! Actor -> PosAtomic
posProjBody Actor
body
  UpdLoseActor ActorId
_ Actor
body -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! Actor -> PosAtomic
posProjBody Actor
body
  UpdSpotItem Bool
_ ItemId
_ ItemQuant
_ Container
c -> Container -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => Container -> m PosAtomic
singleContainerStash Container
c
  UpdLoseItem Bool
_ ItemId
_ ItemQuant
_ Container
c -> Container -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => Container -> m PosAtomic
singleContainerStash Container
c
  UpdSpotItemBag Bool
_ Container
c ItemBag
_ -> Container -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => Container -> m PosAtomic
singleContainerStash Container
c
  UpdLoseItemBag Bool
_ Container
c ItemBag
_ -> Container -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => Container -> m PosAtomic
singleContainerStash Container
c
  UpdMoveActor ActorId
aid Point
fromP Point
toP -> do
    b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
    -- Non-projectile actors are never totally isolated from environment;
    -- they hear, feel air movement, etc.
    return $! pointsProjBody b [fromP, toP]
  UpdWaitActor ActorId
aid Watchfulness
_ Watchfulness
_ -> ActorId -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => ActorId -> m PosAtomic
singleAid ActorId
aid
  UpdDisplaceActor ActorId
source ActorId
target -> ActorId -> ActorId -> m PosAtomic
forall (m :: * -> *).
MonadStateRead m =>
ActorId -> ActorId -> m PosAtomic
doubleAid ActorId
source ActorId
target
  UpdMoveItem ItemId
_ Int
_ ActorId
aid CStore
cstore1 CStore
cstore2 -> do
    b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
    mlidPos1 <- lidPosOfStash b cstore1
    mlidPos2 <- lidPosOfStash b cstore2
    let mlidPos = Maybe (LevelId, Point)
mlidPos1 Maybe (LevelId, Point)
-> Maybe (LevelId, Point) -> Maybe (LevelId, Point)
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe (LevelId, Point)
mlidPos2
    return $! maybe (posProjBody b)
                    (\(LevelId, Point)
lidPos -> [(LevelId, Point)] -> PosAtomic
PosSightLevels [(LevelId, Point)
lidPos, (Actor -> LevelId
blid Actor
b, Actor -> Point
bpos Actor
b)])
                    mlidPos
  UpdRefillHP ActorId
aid Int64
_ -> ActorId -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => ActorId -> m PosAtomic
singleAid ActorId
aid
  UpdRefillCalm ActorId
aid Int64
_ -> ActorId -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => ActorId -> m PosAtomic
singleAid ActorId
aid
  UpdTrajectory ActorId
aid Maybe ([Vector], Speed)
_ Maybe ([Vector], Speed)
_ -> ActorId -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => ActorId -> m PosAtomic
singleAid ActorId
aid
  UpdQuitFaction{} -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PosAtomic
PosAll
  UpdSpotStashFaction Bool
_ FactionId
fid LevelId
lid Point
pos -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! FactionId -> LevelId -> [Point] -> PosAtomic
PosFidAndSight FactionId
fid LevelId
lid [Point
pos]
  UpdLoseStashFaction Bool
_ FactionId
fid LevelId
lid Point
pos -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! FactionId -> LevelId -> [Point] -> PosAtomic
PosFidAndSight FactionId
fid LevelId
lid [Point
pos]
  UpdLeadFaction FactionId
fid Maybe ActorId
_ Maybe ActorId
_ -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! FactionId -> PosAtomic
PosFidAndSer FactionId
fid
  UpdDiplFaction{} -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PosAtomic
PosAll
  UpdDoctrineFaction{} -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PosAtomic
PosAll  -- make faction lore fun
  UpdAutoFaction{} -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PosAtomic
PosAll
  UpdRecordKill ActorId
aid ContentId ItemKind
_ Int
_ -> ActorId -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => ActorId -> m PosAtomic
singleAid ActorId
aid
  UpdAlterTile LevelId
lid Point
p ContentId TileKind
_ ContentId TileKind
_ -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! LevelId -> [Point] -> PosAtomic
PosSight LevelId
lid [Point
p]
  UpdAlterExplorable{} -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PosAtomic
PosAll
    -- Can't have @PosSight@, because we'd end up with many accessible
    -- unknown tiles, but the game reporting 'all seen'.
  UpdAlterGold{} -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PosAtomic
PosAll
  UpdSearchTile ActorId
aid Point
p ContentId TileKind
_ -> do
    b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
    return $! pointsProjBody b [bpos b, p]
  UpdHideTile ActorId
aid Point
p ContentId TileKind
_ -> do
    b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
    return $! pointsProjBody b [bpos b, p]
  UpdSpotTile LevelId
lid [(Point, ContentId TileKind)]
ts -> do
    let ps :: [Point]
ps = ((Point, ContentId TileKind) -> Point)
-> [(Point, ContentId TileKind)] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map (Point, ContentId TileKind) -> Point
forall a b. (a, b) -> a
fst [(Point, ContentId TileKind)]
ts
    PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! LevelId -> [Point] -> PosAtomic
PosSight LevelId
lid [Point]
ps
  UpdLoseTile LevelId
lid [(Point, ContentId TileKind)]
ts -> do
    let ps :: [Point]
ps = ((Point, ContentId TileKind) -> Point)
-> [(Point, ContentId TileKind)] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map (Point, ContentId TileKind) -> Point
forall a b. (a, b) -> a
fst [(Point, ContentId TileKind)]
ts
    PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! LevelId -> [Point] -> PosAtomic
PosSight LevelId
lid [Point]
ps
  UpdSpotEntry LevelId
lid [(Point, PlaceEntry)]
ts -> do
    let ps :: [Point]
ps = ((Point, PlaceEntry) -> Point) -> [(Point, PlaceEntry)] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map (Point, PlaceEntry) -> Point
forall a b. (a, b) -> a
fst [(Point, PlaceEntry)]
ts
    PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! LevelId -> [Point] -> PosAtomic
PosSight LevelId
lid [Point]
ps
  UpdLoseEntry LevelId
lid [(Point, PlaceEntry)]
ts -> do
    let ps :: [Point]
ps = ((Point, PlaceEntry) -> Point) -> [(Point, PlaceEntry)] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map (Point, PlaceEntry) -> Point
forall a b. (a, b) -> a
fst [(Point, PlaceEntry)]
ts
    PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! LevelId -> [Point] -> PosAtomic
PosSight LevelId
lid [Point]
ps
  UpdAlterSmell LevelId
lid Point
p Time
_ Time
_ -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! LevelId -> [Point] -> PosAtomic
PosSmell LevelId
lid [Point
p]
  UpdSpotSmell LevelId
lid [(Point, Time)]
sms -> do
    let ps :: [Point]
ps = ((Point, Time) -> Point) -> [(Point, Time)] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map (Point, Time) -> Point
forall a b. (a, b) -> a
fst [(Point, Time)]
sms
    PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! LevelId -> [Point] -> PosAtomic
PosSmell LevelId
lid [Point]
ps
  UpdLoseSmell LevelId
lid [(Point, Time)]
sms -> do
    let ps :: [Point]
ps = ((Point, Time) -> Point) -> [(Point, Time)] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map (Point, Time) -> Point
forall a b. (a, b) -> a
fst [(Point, Time)]
sms
    PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! LevelId -> [Point] -> PosAtomic
PosSmell LevelId
lid [Point]
ps
  UpdTimeItem ItemId
_ Container
c ItemTimers
_ ItemTimers
_ -> Container -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => Container -> m PosAtomic
singleContainerStash Container
c
  UpdAgeGame EnumSet LevelId
_ -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PosAtomic
PosAll
  UpdUnAgeGame EnumSet LevelId
_ -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PosAtomic
PosAll
  UpdDiscover Container
c ItemId
_ ContentId ItemKind
_ AspectRecord
_ -> Container -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => Container -> m PosAtomic
singleContainerActor Container
c
    -- This implies other factions applying items from their inventory,
    -- when we can't see the position of the stash, won't Id the item
    -- for us, even when notice item usage. Thrown items will Id, though,
    -- just as triggering items from the floor or embedded items.
  UpdCover Container
c ItemId
_ ContentId ItemKind
_ AspectRecord
_ -> Container -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => Container -> m PosAtomic
singleContainerActor Container
c
  UpdDiscoverKind Container
c ItemKindIx
_ ContentId ItemKind
_ -> Container -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => Container -> m PosAtomic
singleContainerActor Container
c
  UpdCoverKind Container
c ItemKindIx
_ ContentId ItemKind
_ -> Container -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => Container -> m PosAtomic
singleContainerActor Container
c
  UpdDiscoverAspect Container
c ItemId
_ AspectRecord
_ -> Container -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => Container -> m PosAtomic
singleContainerActor Container
c
  UpdCoverAspect Container
c ItemId
_ AspectRecord
_ -> Container -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => Container -> m PosAtomic
singleContainerActor Container
c
  UpdDiscoverServer{} -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PosAtomic
PosSer
  UpdCoverServer{} -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PosAtomic
PosSer
  UpdPerception{} -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PosAtomic
PosNone
  UpdRestart FactionId
fid PerLid
_ State
_ Challenge
_ ClientOptions
_ SMGen
_ -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! FactionId -> PosAtomic
PosFid FactionId
fid
  UpdRestartServer State
_ -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PosAtomic
PosSer
  UpdResume FactionId
_ PerLid
_ -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PosAtomic
PosNone
  UpdResumeServer State
_ -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PosAtomic
PosSer
  UpdKillExit FactionId
fid -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! FactionId -> PosAtomic
PosFid FactionId
fid
  UpdAtomic
UpdWriteSave -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PosAtomic
PosAll
  UpdHearFid FactionId
fid Maybe Int
_ HearMsg
_ -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! FactionId -> PosAtomic
PosFid FactionId
fid
  UpdMuteMessages FactionId
fid Bool
_ -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! FactionId -> PosAtomic
PosFid FactionId
fid

-- | Produce the positions where the atomic special effect takes place.
posSfxAtomic :: MonadStateRead m => SfxAtomic -> m PosAtomic
posSfxAtomic :: forall (m :: * -> *). MonadStateRead m => SfxAtomic -> m PosAtomic
posSfxAtomic SfxAtomic
cmd = case SfxAtomic
cmd of
  SfxStrike ActorId
_ ActorId
target ItemId
_ -> ActorId -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => ActorId -> m PosAtomic
singleAid ActorId
target
  SfxRecoil ActorId
_ ActorId
target ItemId
_ -> ActorId -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => ActorId -> m PosAtomic
singleAid ActorId
target
  SfxSteal ActorId
_ ActorId
target ItemId
_ -> ActorId -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => ActorId -> m PosAtomic
singleAid ActorId
target
  SfxRelease ActorId
_ ActorId
target ItemId
_ -> ActorId -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => ActorId -> m PosAtomic
singleAid ActorId
target
  SfxProject ActorId
aid ItemId
_ -> ActorId -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => ActorId -> m PosAtomic
singleAid ActorId
aid
  SfxReceive ActorId
aid ItemId
_ -> ActorId -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => ActorId -> m PosAtomic
singleAid ActorId
aid
  SfxApply ActorId
aid ItemId
_ -> ActorId -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => ActorId -> m PosAtomic
singleAid ActorId
aid
  SfxCheck ActorId
aid ItemId
_ -> ActorId -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => ActorId -> m PosAtomic
singleAid ActorId
aid
  SfxTrigger ActorId
aid LevelId
lid Point
p ContentId TileKind
_ -> do
    body <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
    return $! PosSightLevels [(lid, p), (blid body, bpos body)]
      -- @PosFidAndSightLevels@ would be better, but no big deal
  SfxShun ActorId
aid LevelId
lid Point
p ContentId TileKind
_ -> do
    body <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
    return $! PosSightLevels [(lid, p), (blid body, bpos body)]
  SfxEffect FactionId
_ ActorId
aid ItemId
_ Effect
_ Int64
_ -> ActorId -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => ActorId -> m PosAtomic
singleAid ActorId
aid  -- sometimes we don't see source, OK
  SfxItemApplied Bool
_ ItemId
_ Container
c -> Container -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => Container -> m PosAtomic
singleContainerActor Container
c
  SfxMsgFid FactionId
fid SfxMsg
_ -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! FactionId -> PosAtomic
PosFid FactionId
fid
  SfxAtomic
SfxRestart -> PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PosAtomic
PosAll
  SfxCollideTile ActorId
aid Point
_ -> ActorId -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => ActorId -> m PosAtomic
singleAid ActorId
aid
  SfxTaunt Bool
_ ActorId
aid -> ActorId -> m PosAtomic
forall (m :: * -> *). MonadStateRead m => ActorId -> m PosAtomic
singleAid ActorId
aid

-- | All items introduced by the atomic command, to be used in it.
iidUpdAtomic :: UpdAtomic -> [ItemId]
iidUpdAtomic :: UpdAtomic -> [ItemId]
iidUpdAtomic UpdAtomic
cmd = case UpdAtomic
cmd of
  UpdRegisterItems{} -> []
  UpdCreateActor{} -> []  -- iids and items needed even on server
  UpdDestroyActor{} -> []
  UpdCreateItem{} -> []
  UpdDestroyItem{} -> []
  UpdSpotActor ActorId
_ Actor
body -> Actor -> [ItemId]
getCarriedIidsAndTrunk Actor
body
  UpdLoseActor{} -> []  -- already seen, so items known
  UpdSpotItem Bool
_ ItemId
iid ItemQuant
_ Container
_ -> [ItemId
iid]
  UpdLoseItem{} -> []
  UpdSpotItemBag Bool
_ Container
_ ItemBag
bag -> ItemBag -> [ItemId]
forall k a. Enum k => EnumMap k a -> [k]
EM.keys ItemBag
bag
  UpdLoseItemBag{} -> []
  UpdMoveActor{} -> []
  UpdWaitActor{} -> []
  UpdDisplaceActor{} -> []
  UpdMoveItem{} -> []
  UpdRefillHP{} -> []
  UpdRefillCalm{} -> []
  UpdTrajectory{} -> []
  UpdQuitFaction{} -> []
  UpdSpotStashFaction{} -> []
  UpdLoseStashFaction{} -> []
  UpdLeadFaction{} -> []
  UpdDiplFaction{} -> []
  UpdDoctrineFaction{} -> []
  UpdAutoFaction{} -> []
  UpdRecordKill{} -> []
  UpdAlterTile{} -> []
  UpdAlterExplorable{} -> []
  UpdAlterGold{} -> []
  UpdSearchTile{} -> []
  UpdHideTile{} -> []
  UpdSpotTile{} -> []
  UpdLoseTile{} -> []
  UpdSpotEntry{} -> []
  UpdLoseEntry{} -> []
  UpdAlterSmell{} -> []
  UpdSpotSmell{} -> []
  UpdLoseSmell{} -> []
  UpdTimeItem ItemId
iid Container
_ ItemTimers
_ ItemTimers
_ -> [ItemId
iid]
  UpdAgeGame{} -> []
  UpdUnAgeGame{} -> []
  UpdDiscover Container
_ ItemId
iid ContentId ItemKind
_ AspectRecord
_ -> [ItemId
iid]
  UpdCover Container
_ ItemId
iid ContentId ItemKind
_ AspectRecord
_ -> [ItemId
iid]
  UpdDiscoverKind{} -> []
  UpdCoverKind{} -> []
  UpdDiscoverAspect Container
_ ItemId
iid AspectRecord
_ -> [ItemId
iid]
  UpdCoverAspect Container
_ ItemId
iid AspectRecord
_ -> [ItemId
iid]
  UpdDiscoverServer{} -> []  -- never sent to clients
  UpdCoverServer{} -> []
  UpdPerception{} -> []
  UpdRestart{} -> []
  UpdRestartServer{} -> []
  UpdResume{} -> []
  UpdResumeServer{} -> []
  UpdKillExit{} -> []
  UpdAtomic
UpdWriteSave -> []
  UpdHearFid{} -> []
  UpdMuteMessages{} -> []

-- | All items introduced by the atomic special effect, to be used in it.
iidSfxAtomic :: SfxAtomic -> [ItemId]
iidSfxAtomic :: SfxAtomic -> [ItemId]
iidSfxAtomic SfxAtomic
cmd = case SfxAtomic
cmd of
  SfxStrike ActorId
_ ActorId
_ ItemId
iid -> [ItemId
iid]
  SfxRecoil ActorId
_ ActorId
_ ItemId
iid -> [ItemId
iid]
  SfxSteal ActorId
_ ActorId
_ ItemId
iid -> [ItemId
iid]
  SfxRelease ActorId
_ ActorId
_ ItemId
iid -> [ItemId
iid]
  SfxProject ActorId
_ ItemId
iid -> [ItemId
iid]
  SfxReceive ActorId
_ ItemId
iid -> [ItemId
iid]
  SfxApply ActorId
_ ItemId
iid -> [ItemId
iid]
  SfxCheck ActorId
_ ItemId
iid -> [ItemId
iid]
  SfxTrigger{} -> []
  SfxShun{} -> []
  SfxEffect{} -> []
  SfxItemApplied Bool
_ ItemId
iid Container
_ -> [ItemId
iid]
  SfxMsgFid{} -> []
  SfxRestart{} -> []
  SfxCollideTile{} -> []
  SfxTaunt{} -> []

pointsProjBody :: Actor -> [Point] -> PosAtomic
pointsProjBody :: Actor -> [Point] -> PosAtomic
pointsProjBody Actor
body [Point]
ps =
  if Actor -> Bool
bproj Actor
body
  then LevelId -> [Point] -> PosAtomic
PosSight (Actor -> LevelId
blid Actor
body) [Point]
ps
  else FactionId -> LevelId -> [Point] -> PosAtomic
PosFidAndSight (Actor -> FactionId
bfid Actor
body) (Actor -> LevelId
blid Actor
body) [Point]
ps

posProjBody :: Actor -> PosAtomic
posProjBody :: Actor -> PosAtomic
posProjBody Actor
body = Actor -> [Point] -> PosAtomic
pointsProjBody Actor
body [Actor -> Point
bpos Actor
body]

singleAid :: MonadStateRead m => ActorId -> m PosAtomic
singleAid :: forall (m :: * -> *). MonadStateRead m => ActorId -> m PosAtomic
singleAid ActorId
aid = do
  body <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
  return $! posProjBody body

doubleAid :: MonadStateRead m => ActorId -> ActorId -> m PosAtomic
doubleAid :: forall (m :: * -> *).
MonadStateRead m =>
ActorId -> ActorId -> m PosAtomic
doubleAid ActorId
source ActorId
target = do
  sb <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
source
  tb <- getsState $ getActorBody target
  -- No @PosFidAndSight@ instead of @PosSight@, because both positions
  -- need to be seen to have the enemy actor in client's state.
  return $! assert (blid sb == blid tb) $ PosSight (blid sb) [bpos sb, bpos tb]

singleContainerStash :: MonadStateRead m => Container -> m PosAtomic
singleContainerStash :: forall (m :: * -> *). MonadStateRead m => Container -> m PosAtomic
singleContainerStash (CFloor LevelId
lid Point
p) = PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! LevelId -> [Point] -> PosAtomic
PosSight LevelId
lid [Point
p]
singleContainerStash (CEmbed LevelId
lid Point
p) = PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! LevelId -> [Point] -> PosAtomic
PosSight LevelId
lid [Point
p]
singleContainerStash (CActor ActorId
aid CStore
cstore) = do
  b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
  mlidPos <- lidPosOfStash b cstore
  return $! maybe (posProjBody b)
                  (\(LevelId, Point)
lidPos -> [(LevelId, Point)] -> PosAtomic
PosSightLevels [(LevelId, Point)
lidPos, (Actor -> LevelId
blid Actor
b, Actor -> Point
bpos Actor
b)])
                    -- the actor's position is needed so that a message
                    -- about the actor is not sent to a client that doesn't
                    -- know the actor; actor's faction is ignored, because
                    -- for these operations actor doesn't vanish
                  mlidPos
singleContainerStash (CTrunk FactionId
fid LevelId
lid Point
p) = PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! FactionId -> LevelId -> [Point] -> PosAtomic
PosFidAndSight FactionId
fid LevelId
lid [Point
p]

singleContainerActor :: MonadStateRead m => Container -> m PosAtomic
singleContainerActor :: forall (m :: * -> *). MonadStateRead m => Container -> m PosAtomic
singleContainerActor (CFloor LevelId
lid Point
p) = PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! LevelId -> [Point] -> PosAtomic
PosSight LevelId
lid [Point
p]
singleContainerActor (CEmbed LevelId
lid Point
p) = PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! LevelId -> [Point] -> PosAtomic
PosSight LevelId
lid [Point
p]
singleContainerActor (CActor ActorId
aid CStore
_) = do
  b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
  return $! posProjBody b
    -- stash position is ignored, because for these operations, nothing
    -- is added to that position; the store name is only used for flavour text
singleContainerActor (CTrunk FactionId
fid LevelId
lid Point
p) = PosAtomic -> m PosAtomic
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PosAtomic -> m PosAtomic) -> PosAtomic -> m PosAtomic
forall a b. (a -> b) -> a -> b
$! FactionId -> LevelId -> [Point] -> PosAtomic
PosFidAndSight FactionId
fid LevelId
lid [Point
p]

lidPosOfStash :: MonadStateRead m
              => Actor -> CStore -> m (Maybe (LevelId, Point))
lidPosOfStash :: forall (m :: * -> *).
MonadStateRead m =>
Actor -> CStore -> m (Maybe (LevelId, Point))
lidPosOfStash Actor
b CStore
cstore =
  case CStore
cstore of
    CStore
CStash -> do
      mstash <- (State -> Maybe (LevelId, Point)) -> m (Maybe (LevelId, Point))
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Maybe (LevelId, Point)) -> m (Maybe (LevelId, Point)))
-> (State -> Maybe (LevelId, Point)) -> m (Maybe (LevelId, Point))
forall a b. (a -> b) -> a -> b
$ \State
s -> Faction -> Maybe (LevelId, Point)
gstash (Faction -> Maybe (LevelId, Point))
-> Faction -> Maybe (LevelId, Point)
forall a b. (a -> b) -> a -> b
$ State -> FactionDict
sfactionD State
s FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> FactionId
bfid Actor
b
      case mstash of
        Just{} -> Maybe (LevelId, Point) -> m (Maybe (LevelId, Point))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LevelId, Point)
mstash
        Maybe (LevelId, Point)
Nothing -> String -> m (Maybe (LevelId, Point))
forall a. HasCallStack => String -> a
error (String -> m (Maybe (LevelId, Point)))
-> String -> m (Maybe (LevelId, Point))
forall a b. (a -> b) -> a -> b
$ String
"manipulating void stash" String -> Actor -> String
forall v. Show v => String -> v -> String
`showFailure` Actor
b
    CStore
_ -> Maybe (LevelId, Point) -> m (Maybe (LevelId, Point))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LevelId, Point)
forall a. Maybe a
Nothing

-- | Decompose an atomic action that is outside a client's visiblity.
-- The decomposed actions give less information that the original command,
-- but some of them may fall within the visibility range of the client.
-- The original action may give more information than even the total sum
-- of all actions it's broken into. E.g., @UpdMoveActor@
-- informs about the continued existence of the actor between
-- moves vs popping out of existence and then back in.
--
-- This is computed in server's @State@ from before performing the command.
breakUpdAtomic :: MonadStateRead m => UpdAtomic -> m [UpdAtomic]
breakUpdAtomic :: forall (m :: * -> *).
MonadStateRead m =>
UpdAtomic -> m [UpdAtomic]
breakUpdAtomic UpdAtomic
cmd = case UpdAtomic
cmd of
  UpdCreateItem Bool
verbose ItemId
iid Item
item ItemQuant
kit (CActor ActorId
aid CStore
CStash) -> do
    b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
    mstash <- getsState $ \State
s -> Faction -> Maybe (LevelId, Point)
gstash (Faction -> Maybe (LevelId, Point))
-> Faction -> Maybe (LevelId, Point)
forall a b. (a -> b) -> a -> b
$ State -> FactionDict
sfactionD State
s FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> FactionId
bfid Actor
b
    case mstash of
      Just (LevelId
lid, Point
pos) ->
        [UpdAtomic] -> m [UpdAtomic]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Bool -> ItemId -> Item -> ItemQuant -> Container -> UpdAtomic
UpdCreateItem Bool
verbose ItemId
iid Item
item ItemQuant
kit (LevelId -> Point -> Container
CFloor LevelId
lid Point
pos)]
      Maybe (LevelId, Point)
Nothing -> String -> m [UpdAtomic]
forall a. HasCallStack => String -> a
error (String -> m [UpdAtomic]) -> String -> m [UpdAtomic]
forall a b. (a -> b) -> a -> b
$ String
"manipulating void stash" String -> (ActorId, Actor, Item) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
b, Item
item)
  UpdDestroyItem Bool
verbose ItemId
iid Item
item ItemQuant
kit (CActor ActorId
aid CStore
CStash) -> do
    b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
    mstash <- getsState $ \State
s -> Faction -> Maybe (LevelId, Point)
gstash (Faction -> Maybe (LevelId, Point))
-> Faction -> Maybe (LevelId, Point)
forall a b. (a -> b) -> a -> b
$ State -> FactionDict
sfactionD State
s FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> FactionId
bfid Actor
b
    case mstash of
      Just (LevelId
lid, Point
pos) ->
        [UpdAtomic] -> m [UpdAtomic]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Bool -> ItemId -> Item -> ItemQuant -> Container -> UpdAtomic
UpdDestroyItem Bool
verbose ItemId
iid Item
item ItemQuant
kit (LevelId -> Point -> Container
CFloor LevelId
lid Point
pos)]
      Maybe (LevelId, Point)
Nothing -> String -> m [UpdAtomic]
forall a. HasCallStack => String -> a
error (String -> m [UpdAtomic]) -> String -> m [UpdAtomic]
forall a b. (a -> b) -> a -> b
$ String
"manipulating void stash" String -> (ActorId, Actor, Item) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
b, Item
item)
  UpdSpotItem Bool
verbose ItemId
iid ItemQuant
kit (CActor ActorId
aid CStore
CStash) -> do
    b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
    mstash <- getsState $ \State
s -> Faction -> Maybe (LevelId, Point)
gstash (Faction -> Maybe (LevelId, Point))
-> Faction -> Maybe (LevelId, Point)
forall a b. (a -> b) -> a -> b
$ State -> FactionDict
sfactionD State
s FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> FactionId
bfid Actor
b
    case mstash of
      Just (LevelId
lid, Point
pos) -> [UpdAtomic] -> m [UpdAtomic]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Bool -> ItemId -> ItemQuant -> Container -> UpdAtomic
UpdSpotItem Bool
verbose ItemId
iid ItemQuant
kit (LevelId -> Point -> Container
CFloor LevelId
lid Point
pos)]
      Maybe (LevelId, Point)
Nothing -> String -> m [UpdAtomic]
forall a. HasCallStack => String -> a
error (String -> m [UpdAtomic]) -> String -> m [UpdAtomic]
forall a b. (a -> b) -> a -> b
$ String
"manipulating void stash" String -> (ActorId, Actor, ItemId) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
b, ItemId
iid)
  UpdLoseItem Bool
verbose ItemId
iid ItemQuant
kit (CActor ActorId
aid CStore
CStash) -> do
    b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
    mstash <- getsState $ \State
s -> Faction -> Maybe (LevelId, Point)
gstash (Faction -> Maybe (LevelId, Point))
-> Faction -> Maybe (LevelId, Point)
forall a b. (a -> b) -> a -> b
$ State -> FactionDict
sfactionD State
s FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> FactionId
bfid Actor
b
    case mstash of
      Just (LevelId
lid, Point
pos) -> [UpdAtomic] -> m [UpdAtomic]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Bool -> ItemId -> ItemQuant -> Container -> UpdAtomic
UpdLoseItem Bool
verbose ItemId
iid ItemQuant
kit (LevelId -> Point -> Container
CFloor LevelId
lid Point
pos)]
      Maybe (LevelId, Point)
Nothing -> String -> m [UpdAtomic]
forall a. HasCallStack => String -> a
error (String -> m [UpdAtomic]) -> String -> m [UpdAtomic]
forall a b. (a -> b) -> a -> b
$ String
"manipulating void stash" String -> (ActorId, Actor, ItemId) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
b, ItemId
iid)
  UpdSpotItemBag Bool
verbose (CActor ActorId
aid CStore
CStash) ItemBag
bag -> do
    b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
    mstash <- getsState $ \State
s -> Faction -> Maybe (LevelId, Point)
gstash (Faction -> Maybe (LevelId, Point))
-> Faction -> Maybe (LevelId, Point)
forall a b. (a -> b) -> a -> b
$ State -> FactionDict
sfactionD State
s FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> FactionId
bfid Actor
b
    case mstash of
      Just (LevelId
lid, Point
pos) -> [UpdAtomic] -> m [UpdAtomic]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Bool -> Container -> ItemBag -> UpdAtomic
UpdSpotItemBag Bool
verbose (LevelId -> Point -> Container
CFloor LevelId
lid Point
pos) ItemBag
bag]
      Maybe (LevelId, Point)
Nothing -> String -> m [UpdAtomic]
forall a. HasCallStack => String -> a
error (String -> m [UpdAtomic]) -> String -> m [UpdAtomic]
forall a b. (a -> b) -> a -> b
$ String
"manipulating void stash" String -> (ActorId, Actor, ItemBag) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
b, ItemBag
bag)
  UpdLoseItemBag Bool
verbose (CActor ActorId
aid CStore
CStash) ItemBag
bag -> do
    b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
    mstash <- getsState $ \State
s -> Faction -> Maybe (LevelId, Point)
gstash (Faction -> Maybe (LevelId, Point))
-> Faction -> Maybe (LevelId, Point)
forall a b. (a -> b) -> a -> b
$ State -> FactionDict
sfactionD State
s FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> FactionId
bfid Actor
b
    case mstash of
      Just (LevelId
lid, Point
pos) -> [UpdAtomic] -> m [UpdAtomic]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Bool -> Container -> ItemBag -> UpdAtomic
UpdLoseItemBag Bool
verbose (LevelId -> Point -> Container
CFloor LevelId
lid Point
pos) ItemBag
bag]
      Maybe (LevelId, Point)
Nothing -> String -> m [UpdAtomic]
forall a. HasCallStack => String -> a
error (String -> m [UpdAtomic]) -> String -> m [UpdAtomic]
forall a b. (a -> b) -> a -> b
$ String
"manipulating void stash" String -> (ActorId, Actor, ItemBag) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
b, ItemBag
bag)
  UpdMoveItem ItemId
iid Int
k ActorId
aid CStore
CStash CStore
store2 -> do
    b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
    bag <- getsState $ getBodyStoreBag b CStash
    let (k1, it1) = bag EM.! iid
        kit = Bool -> ItemQuant -> ItemQuant
forall a. HasCallStack => Bool -> a -> a
assert (Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
k1) (Int
k, Int -> ItemTimers -> ItemTimers
forall a. Int -> [a] -> [a]
take Int
k ItemTimers
it1)
    mstash <- getsState $ \State
s -> Faction -> Maybe (LevelId, Point)
gstash (Faction -> Maybe (LevelId, Point))
-> Faction -> Maybe (LevelId, Point)
forall a b. (a -> b) -> a -> b
$ State -> FactionDict
sfactionD State
s FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> FactionId
bfid Actor
b
    case mstash of
      Just (LevelId
lid, Point
pos) -> [UpdAtomic] -> m [UpdAtomic]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Bool -> ItemId -> ItemQuant -> Container -> UpdAtomic
UpdLoseItem Bool
True ItemId
iid ItemQuant
kit (LevelId -> Point -> Container
CFloor LevelId
lid Point
pos)
                                , Bool -> ItemId -> ItemQuant -> Container -> UpdAtomic
UpdSpotItem Bool
True ItemId
iid ItemQuant
kit (ActorId -> CStore -> Container
CActor ActorId
aid CStore
store2) ]
      Maybe (LevelId, Point)
Nothing -> String -> m [UpdAtomic]
forall a. HasCallStack => String -> a
error (String -> m [UpdAtomic]) -> String -> m [UpdAtomic]
forall a b. (a -> b) -> a -> b
$ String
"manipulating void stash" String -> (ActorId, Actor, ItemId) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
b, ItemId
iid)
  UpdMoveItem ItemId
iid Int
k ActorId
aid CStore
store1 CStore
CStash -> do
    b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
    bag <- getsState $ getBodyStoreBag b store1
    let (k1, it1) = bag EM.! iid
        kit = Bool -> ItemQuant -> ItemQuant
forall a. HasCallStack => Bool -> a -> a
assert (Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
k1) (Int
k, Int -> ItemTimers -> ItemTimers
forall a. Int -> [a] -> [a]
take Int
k ItemTimers
it1)
    mstash <- getsState $ \State
s -> Faction -> Maybe (LevelId, Point)
gstash (Faction -> Maybe (LevelId, Point))
-> Faction -> Maybe (LevelId, Point)
forall a b. (a -> b) -> a -> b
$ State -> FactionDict
sfactionD State
s FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> FactionId
bfid Actor
b
    case mstash of
      Just (LevelId
lid, Point
pos) -> [UpdAtomic] -> m [UpdAtomic]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Bool -> ItemId -> ItemQuant -> Container -> UpdAtomic
UpdLoseItem Bool
True ItemId
iid ItemQuant
kit (ActorId -> CStore -> Container
CActor ActorId
aid CStore
store1)
                                , Bool -> ItemId -> ItemQuant -> Container -> UpdAtomic
UpdSpotItem Bool
True ItemId
iid ItemQuant
kit (LevelId -> Point -> Container
CFloor LevelId
lid Point
pos) ]
      Maybe (LevelId, Point)
Nothing -> String -> m [UpdAtomic]
forall a. HasCallStack => String -> a
error (String -> m [UpdAtomic]) -> String -> m [UpdAtomic]
forall a b. (a -> b) -> a -> b
$ String
"manipulating void stash" String -> (ActorId, Actor, ItemId) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
b, ItemId
iid)
  UpdMoveActor ActorId
aid Point
fromP Point
toP -> do
    -- We assume other factions don't see leaders and we know the actor's
    -- faction always sees the atomic command and no other commands
    -- may be inserted between the two below, so the leader doesn't
    -- need to be updated, even when aid is the leader.
    b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
    return [ UpdLoseActor aid b
           , UpdSpotActor aid b {bpos = toP, boldpos = Just fromP} ]
  UpdDisplaceActor ActorId
source ActorId
target -> do
    sb <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
source
    tb <- getsState $ getActorBody target
    -- The order ensures the invariant that no two big actors occupy the same
    -- position is maintained. The actions about leadership are required
    -- to keep faction data (identify of the leader) consistent with actor
    -- data (the actor that is the leader exists). Here, for speed
    -- and simplicity we violate the property that in a faction
    -- that has leaders, if any eligible actor is alive,
    -- the leader is set, because for a moment there may be no leader,
    -- even though other actors of the faction may exist.
    msleader <- getsState $ gleader . (EM.! bfid sb) . sfactionD
    mtleader <- getsState $ gleader . (EM.! bfid tb) . sfactionD
    return $ [ UpdLeadFaction (bfid sb) msleader Nothing
             | Just source == msleader ]
             ++ [ UpdLeadFaction (bfid tb) mtleader Nothing
                | Just target == mtleader ]
             ++ [ UpdLoseActor source sb
                , UpdLoseActor target tb
                , UpdSpotActor source sb { bpos = bpos tb
                                         , boldpos = Just $ bpos sb }
                , UpdSpotActor target tb { bpos = bpos sb
                                         , boldpos = Just $ bpos tb } ]
             ++ [ UpdLeadFaction (bfid sb) Nothing msleader
                | Just source == msleader ]
             ++ [ UpdLeadFaction (bfid tb) Nothing mtleader
                | Just target == mtleader ]
  UpdTimeItem ItemId
iid (CActor ActorId
aid CStore
CStash) ItemTimers
fromIt ItemTimers
toIt -> do
    b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
    mstash <- getsState $ \State
s -> Faction -> Maybe (LevelId, Point)
gstash (Faction -> Maybe (LevelId, Point))
-> Faction -> Maybe (LevelId, Point)
forall a b. (a -> b) -> a -> b
$ State -> FactionDict
sfactionD State
s FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> FactionId
bfid Actor
b
    case mstash of
      Just (LevelId
lid, Point
pos) -> [UpdAtomic] -> m [UpdAtomic]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [ItemId -> Container -> ItemTimers -> ItemTimers -> UpdAtomic
UpdTimeItem ItemId
iid (LevelId -> Point -> Container
CFloor LevelId
lid Point
pos) ItemTimers
fromIt ItemTimers
toIt]
      Maybe (LevelId, Point)
Nothing -> String -> m [UpdAtomic]
forall a. HasCallStack => String -> a
error (String -> m [UpdAtomic]) -> String -> m [UpdAtomic]
forall a b. (a -> b) -> a -> b
$ String
"manipulating void stash" String -> (ActorId, Actor, ItemId) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
b, ItemId
iid)
  UpdAtomic
_ -> [UpdAtomic] -> m [UpdAtomic]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | What is the main map level the @PosAtomic@ refers to, if any.
lidOfPos :: PosAtomic -> Maybe LevelId
lidOfPos :: PosAtomic -> Maybe LevelId
lidOfPos PosAtomic
posAtomic =
  case PosAtomic
posAtomic of
    PosSight LevelId
lid [Point]
_ -> LevelId -> Maybe LevelId
forall a. a -> Maybe a
Just LevelId
lid
    PosFidAndSight FactionId
_ LevelId
lid [Point]
_ -> LevelId -> Maybe LevelId
forall a. a -> Maybe a
Just LevelId
lid
    PosSmell LevelId
lid [Point]
_ -> LevelId -> Maybe LevelId
forall a. a -> Maybe a
Just LevelId
lid
    PosSightLevels [] -> Maybe LevelId
forall a. Maybe a
Nothing
    PosSightLevels ((LevelId
lid, Point
_) : [(LevelId, Point)]
_) -> LevelId -> Maybe LevelId
forall a. a -> Maybe a
Just LevelId
lid
    PosFid{} -> Maybe LevelId
forall a. Maybe a
Nothing
    PosFidAndSer{} -> Maybe LevelId
forall a. Maybe a
Nothing
    PosAtomic
PosSer -> Maybe LevelId
forall a. Maybe a
Nothing
    PosAtomic
PosAll -> Maybe LevelId
forall a. Maybe a
Nothing
    PosAtomic
PosNone -> Maybe LevelId
forall a. Maybe a
Nothing

-- | Given the client, its perception and an atomic command, determine
-- if the client notices the command.
seenAtomicCli :: Bool -> FactionId -> PerLid -> PosAtomic -> Bool
seenAtomicCli :: Bool -> FactionId -> PerLid -> PosAtomic -> Bool
seenAtomicCli Bool
knowEvents FactionId
fid PerLid
perLid PosAtomic
posAtomic =
  let per :: LevelId -> Perception
per = (PerLid
perLid PerLid -> LevelId -> Perception
forall k a. Enum k => EnumMap k a -> k -> a
EM.!)
  in case PosAtomic
posAtomic of
    PosSight LevelId
lid [Point]
ps -> (Point -> Bool) -> [Point] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Point -> EnumSet Point -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
`ES.member` Perception -> EnumSet Point
totalVisible (LevelId -> Perception
per LevelId
lid)) [Point]
ps Bool -> Bool -> Bool
|| Bool
knowEvents
    PosFidAndSight FactionId
fid2 LevelId
lid [Point]
ps ->
      FactionId
fid FactionId -> FactionId -> Bool
forall a. Eq a => a -> a -> Bool
== FactionId
fid2 Bool -> Bool -> Bool
|| (Point -> Bool) -> [Point] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Point -> EnumSet Point -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
`ES.member` Perception -> EnumSet Point
totalVisible (LevelId -> Perception
per LevelId
lid)) [Point]
ps Bool -> Bool -> Bool
|| Bool
knowEvents
    PosSmell LevelId
lid [Point]
ps -> (Point -> Bool) -> [Point] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Point -> EnumSet Point -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
`ES.member` Perception -> EnumSet Point
totalSmelled (LevelId -> Perception
per LevelId
lid)) [Point]
ps Bool -> Bool -> Bool
|| Bool
knowEvents
    PosSightLevels [(LevelId, Point)]
l ->
      let visible :: (LevelId, Point) -> Bool
visible (LevelId
lid, Point
pos) = Point
pos Point -> EnumSet Point -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
`ES.member` Perception -> EnumSet Point
totalVisible (LevelId -> Perception
per LevelId
lid)
      in ((LevelId, Point) -> Bool) -> [(LevelId, Point)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (LevelId, Point) -> Bool
visible [(LevelId, Point)]
l Bool -> Bool -> Bool
|| Bool
knowEvents
    PosFid FactionId
fid2 -> FactionId
fid FactionId -> FactionId -> Bool
forall a. Eq a => a -> a -> Bool
== FactionId
fid2
    PosFidAndSer FactionId
fid2 -> FactionId
fid FactionId -> FactionId -> Bool
forall a. Eq a => a -> a -> Bool
== FactionId
fid2
    PosAtomic
PosSer -> Bool
False
    PosAtomic
PosAll -> Bool
True
    PosAtomic
PosNone -> Bool
False

-- | Determine whether the server would see a command that has
-- the given visibilty conditions.
seenAtomicSer :: PosAtomic -> Bool
seenAtomicSer :: PosAtomic -> Bool
seenAtomicSer PosAtomic
posAtomic =
  case PosAtomic
posAtomic of
    PosFid FactionId
_ -> Bool
False
    PosAtomic
PosNone -> String -> Bool
forall a. HasCallStack => String -> a
error (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
"no position possible" String -> PosAtomic -> String
forall v. Show v => String -> v -> String
`showFailure` PosAtomic
posAtomic
    PosAtomic
_ -> Bool
True