{-# LANGUAGE FlexibleContexts #-}
-- | Semantics of atomic commands shared by client and server.
--
-- See
-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.
module Game.LambdaHack.Atomic.HandleAtomicWrite
  ( handleUpdAtomic
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , updRegisterItems, updCreateActor, updDestroyActor
  , updCreateItem, updDestroyItem, updSpotItemBag, updLoseItemBag
  , updMoveActor, updWaitActor, updDisplaceActor, updMoveItem
  , updRefillHP, updRefillCalm
  , updTrajectory, updQuitFaction, updSpotStashFaction, updLoseStashFaction
  , updLeadFaction, updDiplFaction, updDoctrineFaction, updAutoFaction
  , updRecordKill, updAlterTile, updAlterExplorable, updSearchTile
  , updSpotTile, updLoseTile, updAlterSmell, updSpotSmell, updLoseSmell
  , updTimeItem, updAgeGame, updUnAgeGame, ageLevel, updDiscover, updCover
  , updDiscoverKind, discoverKind, updCoverKind
  , updDiscoverAspect, discoverAspect, updCoverAspect
  , updDiscoverServer, updCoverServer
  , updRestart, updRestartServer, updResumeServer
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import           Data.Int (Int64)

import           Game.LambdaHack.Atomic.CmdAtomic
import           Game.LambdaHack.Atomic.MonadStateWrite
import           Game.LambdaHack.Common.Actor
import           Game.LambdaHack.Common.ActorState
import           Game.LambdaHack.Common.Faction
import           Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.ItemAspect as IA
import           Game.LambdaHack.Common.Kind
import           Game.LambdaHack.Common.Level
import           Game.LambdaHack.Common.MonadStateRead
import           Game.LambdaHack.Common.Perception
import           Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray
import           Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import           Game.LambdaHack.Common.Time
import           Game.LambdaHack.Common.Types
import           Game.LambdaHack.Common.Vector
import           Game.LambdaHack.Content.FactionKind
import           Game.LambdaHack.Content.ItemKind (ItemKind)
import qualified Game.LambdaHack.Content.PlaceKind as PK
import           Game.LambdaHack.Content.TileKind (TileKind, unknownId)
import qualified Game.LambdaHack.Definition.Ability as Ability
import           Game.LambdaHack.Definition.Defs

-- | The game-state semantics of atomic game commands.
-- There is no corresponding definition for special effects (@SfxAtomic@),
-- because they don't modify 'State'.
--
-- For each of the commands, we are guaranteed that the client,
-- the command is addressed to, perceives all the positions the command
-- affects (as computed by 'Game.LambdaHack.Atomic.PosAtomicRead.posUpdAtomic').
-- In the code for each semantic function we additonally verify
-- the client is aware of any relevant items and/or actors and we throw
-- the @AtomicFail@ exception if it's not.
-- The server keeps copies of all clients' states and, before sending a command
-- to a client, applies it to the client's state copy.
-- If @AtomicFail@ is signalled, the command is ignored for that client.
-- This enables simpler server code that addresses commands to all clients
-- that can see it, even though not all are able to process it.
handleUpdAtomic :: MonadStateWrite m => UpdAtomic -> m ()
handleUpdAtomic :: UpdAtomic -> m ()
handleUpdAtomic UpdAtomic
cmd = case UpdAtomic
cmd of
  UpdRegisterItems [(ItemId, Item)]
ais -> [(ItemId, Item)] -> m ()
forall (m :: * -> *). MonadStateWrite m => [(ItemId, Item)] -> m ()
updRegisterItems [(ItemId, Item)]
ais
  UpdCreateActor ActorId
aid Actor
body [(ItemId, Item)]
ais -> ActorId -> Actor -> [(ItemId, Item)] -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> Actor -> [(ItemId, Item)] -> m ()
updCreateActor ActorId
aid Actor
body [(ItemId, Item)]
ais
  UpdDestroyActor ActorId
aid Actor
body [(ItemId, Item)]
ais -> ActorId -> Actor -> [(ItemId, Item)] -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> Actor -> [(ItemId, Item)] -> m ()
updDestroyActor ActorId
aid Actor
body [(ItemId, Item)]
ais
  UpdCreateItem Bool
_ ItemId
iid Item
item ItemQuant
kit Container
c -> ItemId -> Item -> ItemQuant -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> Item -> ItemQuant -> Container -> m ()
updCreateItem ItemId
iid Item
item ItemQuant
kit Container
c
  UpdDestroyItem Bool
_ ItemId
iid Item
item ItemQuant
kit Container
c -> ItemId -> Item -> ItemQuant -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> Item -> ItemQuant -> Container -> m ()
updDestroyItem ItemId
iid Item
item ItemQuant
kit Container
c
  UpdSpotActor ActorId
aid Actor
body -> ActorId -> Actor -> m ()
forall (m :: * -> *). MonadStateWrite m => ActorId -> Actor -> m ()
updSpotActor ActorId
aid Actor
body
  UpdLoseActor ActorId
aid Actor
body -> ActorId -> Actor -> m ()
forall (m :: * -> *). MonadStateWrite m => ActorId -> Actor -> m ()
updLoseActor ActorId
aid Actor
body
  UpdSpotItem Bool
_ ItemId
iid ItemQuant
kit Container
c -> ItemId -> ItemQuant -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> Container -> m ()
updSpotItem ItemId
iid ItemQuant
kit Container
c
  UpdLoseItem Bool
_ ItemId
iid ItemQuant
kit Container
c -> ItemId -> ItemQuant -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> Container -> m ()
updLoseItem ItemId
iid ItemQuant
kit Container
c
  UpdSpotItemBag Bool
_ Container
c ItemBag
bag -> Container -> ItemBag -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
Container -> ItemBag -> m ()
updSpotItemBag Container
c ItemBag
bag
  UpdLoseItemBag Bool
_ Container
c ItemBag
bag -> Container -> ItemBag -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
Container -> ItemBag -> m ()
updLoseItemBag Container
c ItemBag
bag
  UpdMoveActor ActorId
aid Point
fromP Point
toP -> ActorId -> Point -> Point -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> Point -> Point -> m ()
updMoveActor ActorId
aid Point
fromP Point
toP
  UpdWaitActor ActorId
aid Watchfulness
fromWS Watchfulness
toWS -> ActorId -> Watchfulness -> Watchfulness -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> Watchfulness -> Watchfulness -> m ()
updWaitActor ActorId
aid Watchfulness
fromWS Watchfulness
toWS
  UpdDisplaceActor ActorId
source ActorId
target -> ActorId -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> ActorId -> m ()
updDisplaceActor ActorId
source ActorId
target
  UpdMoveItem ItemId
iid Int
k ActorId
aid CStore
c1 CStore
c2 -> ItemId -> Int -> ActorId -> CStore -> CStore -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> Int -> ActorId -> CStore -> CStore -> m ()
updMoveItem ItemId
iid Int
k ActorId
aid CStore
c1 CStore
c2
  UpdRefillHP ActorId
aid Int64
n -> ActorId -> Int64 -> m ()
forall (m :: * -> *). MonadStateWrite m => ActorId -> Int64 -> m ()
updRefillHP ActorId
aid Int64
n
  UpdRefillCalm ActorId
aid Int64
n -> ActorId -> Int64 -> m ()
forall (m :: * -> *). MonadStateWrite m => ActorId -> Int64 -> m ()
updRefillCalm ActorId
aid Int64
n
  UpdTrajectory ActorId
aid Maybe ([Vector], Speed)
fromT Maybe ([Vector], Speed)
toT -> ActorId
-> Maybe ([Vector], Speed) -> Maybe ([Vector], Speed) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId
-> Maybe ([Vector], Speed) -> Maybe ([Vector], Speed) -> m ()
updTrajectory ActorId
aid Maybe ([Vector], Speed)
fromT Maybe ([Vector], Speed)
toT
  UpdQuitFaction FactionId
fid Maybe Status
fromSt Maybe Status
toSt Maybe (FactionAnalytics, GenerationAnalytics)
_ -> FactionId -> Maybe Status -> Maybe Status -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> Maybe Status -> Maybe Status -> m ()
updQuitFaction FactionId
fid Maybe Status
fromSt Maybe Status
toSt
  UpdSpotStashFaction Bool
_ FactionId
fid LevelId
lid Point
pos -> FactionId -> LevelId -> Point -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> LevelId -> Point -> m ()
updSpotStashFaction FactionId
fid LevelId
lid Point
pos
  UpdLoseStashFaction Bool
_ FactionId
fid LevelId
lid Point
pos -> FactionId -> LevelId -> Point -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> LevelId -> Point -> m ()
updLoseStashFaction FactionId
fid LevelId
lid Point
pos
  UpdLeadFaction FactionId
fid Maybe ActorId
source Maybe ActorId
target -> FactionId -> Maybe ActorId -> Maybe ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> Maybe ActorId -> Maybe ActorId -> m ()
updLeadFaction FactionId
fid Maybe ActorId
source Maybe ActorId
target
  UpdDiplFaction FactionId
fid1 FactionId
fid2 Diplomacy
fromDipl Diplomacy
toDipl ->
    FactionId -> FactionId -> Diplomacy -> Diplomacy -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> FactionId -> Diplomacy -> Diplomacy -> m ()
updDiplFaction FactionId
fid1 FactionId
fid2 Diplomacy
fromDipl Diplomacy
toDipl
  UpdDoctrineFaction FactionId
fid Doctrine
toT Doctrine
fromT -> FactionId -> Doctrine -> Doctrine -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> Doctrine -> Doctrine -> m ()
updDoctrineFaction FactionId
fid Doctrine
toT Doctrine
fromT
  UpdAutoFaction FactionId
fid Bool
st -> FactionId -> Bool -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> Bool -> m ()
updAutoFaction FactionId
fid Bool
st
  UpdRecordKill ActorId
aid ContentId ItemKind
ikind Int
k -> ActorId -> ContentId ItemKind -> Int -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> ContentId ItemKind -> Int -> m ()
updRecordKill ActorId
aid ContentId ItemKind
ikind Int
k
  UpdAlterTile LevelId
lid Point
p ContentId TileKind
fromTile ContentId TileKind
toTile -> LevelId
-> Point -> ContentId TileKind -> ContentId TileKind -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId
-> Point -> ContentId TileKind -> ContentId TileKind -> m ()
updAlterTile LevelId
lid Point
p ContentId TileKind
fromTile ContentId TileKind
toTile
  UpdAlterExplorable LevelId
lid Int
delta -> LevelId -> Int -> m ()
forall (m :: * -> *). MonadStateWrite m => LevelId -> Int -> m ()
updAlterExplorable LevelId
lid Int
delta
  UpdAlterGold Int
delta -> Int -> m ()
forall (m :: * -> *). MonadStateWrite m => Int -> m ()
updAlterGold Int
delta
  UpdSearchTile ActorId
aid Point
p ContentId TileKind
toTile -> ActorId -> Point -> ContentId TileKind -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> Point -> ContentId TileKind -> m ()
updSearchTile ActorId
aid Point
p ContentId TileKind
toTile
  UpdHideTile{} -> m ()
forall a. HasCallStack => a
undefined
  UpdSpotTile LevelId
lid [(Point, ContentId TileKind)]
ts -> LevelId -> [(Point, ContentId TileKind)] -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> [(Point, ContentId TileKind)] -> m ()
updSpotTile LevelId
lid [(Point, ContentId TileKind)]
ts
  UpdLoseTile LevelId
lid [(Point, ContentId TileKind)]
ts -> LevelId -> [(Point, ContentId TileKind)] -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> [(Point, ContentId TileKind)] -> m ()
updLoseTile LevelId
lid [(Point, ContentId TileKind)]
ts
  UpdSpotEntry LevelId
lid [(Point, PlaceEntry)]
ts -> LevelId -> [(Point, PlaceEntry)] -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> [(Point, PlaceEntry)] -> m ()
updSpotEntry LevelId
lid [(Point, PlaceEntry)]
ts
  UpdLoseEntry LevelId
lid [(Point, PlaceEntry)]
ts -> LevelId -> [(Point, PlaceEntry)] -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> [(Point, PlaceEntry)] -> m ()
updLoseEntry LevelId
lid [(Point, PlaceEntry)]
ts
  UpdAlterSmell LevelId
lid Point
p Time
fromSm Time
toSm -> LevelId -> Point -> Time -> Time -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> Point -> Time -> Time -> m ()
updAlterSmell LevelId
lid Point
p Time
fromSm Time
toSm
  UpdSpotSmell LevelId
lid [(Point, Time)]
sms -> LevelId -> [(Point, Time)] -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> [(Point, Time)] -> m ()
updSpotSmell LevelId
lid [(Point, Time)]
sms
  UpdLoseSmell LevelId
lid [(Point, Time)]
sms -> LevelId -> [(Point, Time)] -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> [(Point, Time)] -> m ()
updLoseSmell LevelId
lid [(Point, Time)]
sms
  UpdTimeItem ItemId
iid Container
c ItemTimers
fromIt ItemTimers
toIt -> ItemId -> Container -> ItemTimers -> ItemTimers -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> Container -> ItemTimers -> ItemTimers -> m ()
updTimeItem ItemId
iid Container
c ItemTimers
fromIt ItemTimers
toIt
  UpdAgeGame EnumSet LevelId
lids -> EnumSet LevelId -> m ()
forall (m :: * -> *). MonadStateWrite m => EnumSet LevelId -> m ()
updAgeGame EnumSet LevelId
lids
  UpdUnAgeGame EnumSet LevelId
lids -> EnumSet LevelId -> m ()
forall (m :: * -> *). MonadStateWrite m => EnumSet LevelId -> m ()
updUnAgeGame EnumSet LevelId
lids
  UpdDiscover Container
c ItemId
iid ContentId ItemKind
ik AspectRecord
arItem -> Container -> ItemId -> ContentId ItemKind -> AspectRecord -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
Container -> ItemId -> ContentId ItemKind -> AspectRecord -> m ()
updDiscover Container
c ItemId
iid ContentId ItemKind
ik AspectRecord
arItem
  UpdCover Container
c ItemId
iid ContentId ItemKind
ik AspectRecord
arItem -> Container -> ItemId -> ContentId ItemKind -> AspectRecord -> m ()
forall (m :: * -> *).
Container -> ItemId -> ContentId ItemKind -> AspectRecord -> m ()
updCover Container
c ItemId
iid ContentId ItemKind
ik AspectRecord
arItem
  UpdDiscoverKind Container
c ItemKindIx
ix ContentId ItemKind
ik -> Container -> ItemKindIx -> ContentId ItemKind -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
Container -> ItemKindIx -> ContentId ItemKind -> m ()
updDiscoverKind Container
c ItemKindIx
ix ContentId ItemKind
ik
  UpdCoverKind Container
c ItemKindIx
ix ContentId ItemKind
ik -> Container -> ItemKindIx -> ContentId ItemKind -> m ()
forall (m :: * -> *).
Container -> ItemKindIx -> ContentId ItemKind -> m ()
updCoverKind Container
c ItemKindIx
ix ContentId ItemKind
ik
  UpdDiscoverAspect Container
c ItemId
iid AspectRecord
arItem -> Container -> ItemId -> AspectRecord -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
Container -> ItemId -> AspectRecord -> m ()
updDiscoverAspect Container
c ItemId
iid AspectRecord
arItem
  UpdCoverAspect Container
c ItemId
iid AspectRecord
arItem -> Container -> ItemId -> AspectRecord -> m ()
forall (m :: * -> *). Container -> ItemId -> AspectRecord -> m ()
updCoverAspect Container
c ItemId
iid AspectRecord
arItem
  UpdDiscoverServer ItemId
iid AspectRecord
arItem -> ItemId -> AspectRecord -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> AspectRecord -> m ()
updDiscoverServer ItemId
iid AspectRecord
arItem
  UpdCoverServer ItemId
iid AspectRecord
arItem -> ItemId -> AspectRecord -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> AspectRecord -> m ()
updCoverServer ItemId
iid AspectRecord
arItem
  UpdPerception LevelId
_ Perception
outPer Perception
inPer ->
    Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Perception -> Bool
nullPer Perception
outPer Bool -> Bool -> Bool
&& Perception -> Bool
nullPer Perception
inPer)) (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
  UpdRestart FactionId
_ PerLid
_ State
s Challenge
_ ClientOptions
_ SMGen
_ -> State -> m ()
forall (m :: * -> *). MonadStateWrite m => State -> m ()
updRestart State
s
  UpdRestartServer State
s -> State -> m ()
forall (m :: * -> *). MonadStateWrite m => State -> m ()
updRestartServer State
s
  UpdResume{} -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  UpdResumeServer State
s -> State -> m ()
forall (m :: * -> *). MonadStateWrite m => State -> m ()
updResumeServer State
s
  UpdKillExit{} -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  UpdAtomic
UpdWriteSave -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  UpdHearFid{} -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  UpdMuteMessages{} -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Actor's items may or may not be already present in @sitemD@,
-- regardless if they are already present otherwise in the dungeon.
-- We re-add them all to save time determining which really need it.
-- If collision occurs, pick the item found on easier level.
updRegisterItems :: MonadStateWrite m => [(ItemId, Item)] -> m ()
updRegisterItems :: [(ItemId, Item)] -> m ()
updRegisterItems [(ItemId, Item)]
ais = do
  let h :: Item -> Item -> Item
h Item
item1 Item
item2 =
        Bool -> Item -> Item
forall a. HasCallStack => Bool -> a -> a
assert (Item -> Item -> Bool
itemsMatch Item
item1 Item
item2
                Bool -> (String, (Item, Item, [(ItemId, Item)])) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"inconsistent added items"
                String
-> (Item, Item, [(ItemId, Item)])
-> (String, (Item, Item, [(ItemId, Item)]))
forall v. String -> v -> (String, v)
`swith` (Item
item1, Item
item2, [(ItemId, Item)]
ais))
               Item
item2 -- keep the first found level
  [(ItemId, Item)] -> ((ItemId, Item) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t a -> (a -> m ()) -> m ()
forM_ [(ItemId, Item)]
ais (((ItemId, Item) -> m ()) -> m ())
-> ((ItemId, Item) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(ItemId
iid, Item
item) -> do
    let f :: State -> State
f = case Item -> ItemIdentity
jkind Item
item of
          IdentityObvious ContentId ItemKind
_ -> State -> State
forall a. a -> a
id
          IdentityCovered ItemKindIx
ix ContentId ItemKind
_ ->
            (ItemIxMap -> ItemIxMap) -> State -> State
updateItemIxMap ((ItemIxMap -> ItemIxMap) -> State -> State)
-> (ItemIxMap -> ItemIxMap) -> State -> State
forall a b. (a -> b) -> a -> b
$ (EnumSet ItemId -> EnumSet ItemId -> EnumSet ItemId)
-> ItemKindIx -> EnumSet ItemId -> ItemIxMap -> ItemIxMap
forall k a.
Enum k =>
(a -> a -> a) -> k -> a -> EnumMap k a -> EnumMap k a
EM.insertWith EnumSet ItemId -> EnumSet ItemId -> EnumSet ItemId
forall k. EnumSet k -> EnumSet k -> EnumSet k
ES.union ItemKindIx
ix (ItemId -> EnumSet ItemId
forall k. Enum k => k -> EnumSet k
ES.singleton ItemId
iid)
    (State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ State -> State
f (State -> State) -> (State -> State) -> State -> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ItemDict -> ItemDict) -> State -> State
updateItemD ((Item -> Item -> Item) -> ItemId -> Item -> ItemDict -> ItemDict
forall k a.
Enum k =>
(a -> a -> a) -> k -> a -> EnumMap k a -> EnumMap k a
EM.insertWith Item -> Item -> Item
h ItemId
iid Item
item)

-- Note: after this command, usually a new leader
-- for the party should be elected (in case this actor is the only one alive).
updCreateActor :: MonadStateWrite m
               => ActorId -> Actor -> [(ItemId, Item)] -> m ()
updCreateActor :: ActorId -> Actor -> [(ItemId, Item)] -> m ()
updCreateActor ActorId
aid Actor
body [(ItemId, Item)]
ais = do
  [(ItemId, Item)] -> m ()
forall (m :: * -> *). MonadStateWrite m => [(ItemId, Item)] -> m ()
updRegisterItems [(ItemId, Item)]
ais
  ActorId -> Actor -> m ()
forall (m :: * -> *). MonadStateWrite m => ActorId -> Actor -> m ()
updSpotActor ActorId
aid Actor
body

-- If a leader dies, a new leader should be elected on the server
-- before this command is executed (not checked).
updDestroyActor :: MonadStateWrite m
                => ActorId -> Actor -> [(ItemId, Item)] -> m ()
updDestroyActor :: ActorId -> Actor -> [(ItemId, Item)] -> m ()
updDestroyActor ActorId
aid Actor
body [(ItemId, Item)]
ais = do
  -- Assert that actor's items belong to @sitemD@. Do not remove those
  -- that do not appear anywhere else, for simplicity and speed.
  ItemDict
itemD <- (State -> ItemDict) -> m ItemDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> ItemDict
sitemD
  let match :: (ItemId, Item) -> Bool
match (ItemId
iid, Item
item) = Item -> Item -> Bool
itemsMatch (ItemDict
itemD ItemDict -> ItemId -> Item
forall k a. Enum k => EnumMap k a -> k -> a
EM.! ItemId
iid) Item
item
  let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (((ItemId, Item) -> Bool) -> [(ItemId, Item)] -> Bool
forall a. Show a => (a -> Bool) -> [a] -> Bool
allB (ItemId, Item) -> Bool
match [(ItemId, Item)]
ais Bool
-> (String, (ActorId, Actor, [(ItemId, Item)], ItemDict)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"destroyed actor items not found"
                    String
-> (ActorId, Actor, [(ItemId, Item)], ItemDict)
-> (String, (ActorId, Actor, [(ItemId, Item)], ItemDict))
forall v. String -> v -> (String, v)
`swith` (ActorId
aid, Actor
body, [(ItemId, Item)]
ais, ItemDict
itemD)) ()
  ActorId -> Actor -> m ()
forall (m :: * -> *). MonadStateWrite m => ActorId -> Actor -> m ()
updLoseActor ActorId
aid Actor
body

-- Create a few copies of an item that is already registered for the dungeon
-- (in @sitemRev@ field of @StateServer@).
--
-- Number of copies may be zero, when the item is only created as a sample
-- to let the player know what can potentially be genereated in the dungeon.
updCreateItem :: MonadStateWrite m
              => ItemId -> Item -> ItemQuant -> Container -> m ()
updCreateItem :: ItemId -> Item -> ItemQuant -> Container -> m ()
updCreateItem ItemId
iid Item
item ItemQuant
kit Container
c = do
  [(ItemId, Item)] -> m ()
forall (m :: * -> *). MonadStateWrite m => [(ItemId, Item)] -> m ()
updRegisterItems [(ItemId
iid, Item
item)]
  ItemId -> ItemQuant -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> Container -> m ()
updSpotItem ItemId
iid ItemQuant
kit Container
c

-- Destroy some copies (possibly not all) of an item.
updDestroyItem :: MonadStateWrite m
               => ItemId -> Item -> ItemQuant -> Container -> m ()
updDestroyItem :: ItemId -> Item -> ItemQuant -> Container -> m ()
updDestroyItem ItemId
iid Item
item kit :: ItemQuant
kit@(Int
k, ItemTimers
_) Container
c = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  -- Do not remove the item from @sitemD@ nor from @sitemRev@
  -- nor from @DiscoveryAspect@, @ItemIxMap@, etc.
  -- It's incredibly costly and not particularly noticeable for the player.
  -- Moreover, copies of the item may reappear in the future
  -- and then we save computation and the player remembers past discovery.
  -- However, assert the item is registered in @sitemD@.
  ItemDict
itemD <- (State -> ItemDict) -> m ItemDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> ItemDict
sitemD
  let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert ((case ItemId
iid ItemId -> ItemDict -> Maybe Item
forall k a. Enum k => k -> EnumMap k a -> Maybe a
`EM.lookup` ItemDict
itemD of
                        Maybe Item
Nothing -> Bool
False
                        Just Item
item0 -> Item -> Item -> Bool
itemsMatch Item
item0 Item
item)
                    Bool -> (String, (ItemId, Item, ItemDict)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"item already removed"
                    String
-> (ItemId, Item, ItemDict) -> (String, (ItemId, Item, ItemDict))
forall v. String -> v -> (String, v)
`swith` (ItemId
iid, Item
item, ItemDict
itemD)) ()
  ItemId -> ItemQuant -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> Container -> m ()
updLoseItem ItemId
iid ItemQuant
kit Container
c

updSpotActor :: MonadStateWrite m => ActorId -> Actor -> m ()
updSpotActor :: ActorId -> Actor -> m ()
updSpotActor ActorId
aid Actor
body = do
  -- The exception is possible, e.g., when we teleport and so see our actor
  -- at the new location, but also the location is part of new perception,
  -- so @UpdSpotActor@ is sent.
  let f :: Maybe Actor -> Maybe Actor
f Maybe Actor
Nothing = Actor -> Maybe Actor
forall a. a -> Maybe a
Just Actor
body
      f (Just Actor
b) = Bool -> Maybe Actor -> Maybe Actor
forall a. HasCallStack => Bool -> a -> a
assert (Actor
body Actor -> Actor -> Bool
forall a. Eq a => a -> a -> Bool
== Actor
b Bool -> (ActorId, Actor, Actor) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (ActorId
aid, Actor
body, Actor
b)) (Maybe Actor -> Maybe Actor) -> Maybe Actor -> Maybe Actor
forall a b. (a -> b) -> a -> b
$
        String -> Maybe Actor
forall a. String -> a
atomicFail (String -> Maybe Actor) -> String -> Maybe Actor
forall a b. (a -> b) -> a -> b
$ String
"actor already added" String -> (ActorId, Actor, Actor) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
body, Actor
b)
  (State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (ActorDict -> ActorDict) -> State -> State
updateActorD ((ActorDict -> ActorDict) -> State -> State)
-> (ActorDict -> ActorDict) -> State -> State
forall a b. (a -> b) -> a -> b
$ (Maybe Actor -> Maybe Actor) -> ActorId -> ActorDict -> ActorDict
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe Actor -> Maybe Actor
f ActorId
aid
  let g :: Maybe [ActorId] -> Maybe [ActorId]
g Maybe [ActorId]
Nothing = [ActorId] -> Maybe [ActorId]
forall a. a -> Maybe a
Just [ActorId
aid]
      g (Just [ActorId]
l) =
#ifdef WITH_EXPENSIVE_ASSERTIONS
        -- Not so much expensive, as doubly impossible.
        Bool -> Maybe [ActorId] -> Maybe [ActorId]
forall a. HasCallStack => Bool -> a -> a
assert (ActorId
aid ActorId -> [ActorId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ActorId]
l Bool -> (String, (ActorId, Actor, [ActorId])) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"actor already added"
                                String
-> (ActorId, Actor, [ActorId])
-> (String, (ActorId, Actor, [ActorId]))
forall v. String -> v -> (String, v)
`swith` (ActorId
aid, Actor
body, [ActorId]
l))
#endif
        ([ActorId] -> Maybe [ActorId]
forall a. a -> Maybe a
Just ([ActorId] -> Maybe [ActorId]) -> [ActorId] -> Maybe [ActorId]
forall a b. (a -> b) -> a -> b
$ ActorId
aid ActorId -> [ActorId] -> [ActorId]
forall a. a -> [a] -> [a]
: [ActorId]
l)
  let h :: Maybe ActorId -> Maybe ActorId
h Maybe ActorId
Nothing = ActorId -> Maybe ActorId
forall a. a -> Maybe a
Just ActorId
aid
      h (Just ActorId
aid2) = String -> Maybe ActorId
forall a. HasCallStack => String -> a
error (String -> Maybe ActorId) -> String -> Maybe ActorId
forall a b. (a -> b) -> a -> b
$ String
"an actor already present there"
                              String -> (ActorId, Actor, ActorId) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
body, ActorId
aid2)
  LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel (Actor -> LevelId
blid Actor
body) ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ if Actor -> Bool
bproj Actor
body
                            then (ProjectileMap -> ProjectileMap) -> Level -> Level
updateProjMap ((Maybe [ActorId] -> Maybe [ActorId])
-> Point -> ProjectileMap -> ProjectileMap
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe [ActorId] -> Maybe [ActorId]
g (Actor -> Point
bpos Actor
body))
                            else (BigActorMap -> BigActorMap) -> Level -> Level
updateBigMap ((Maybe ActorId -> Maybe ActorId)
-> Point -> BigActorMap -> BigActorMap
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe ActorId -> Maybe ActorId
h (Actor -> Point
bpos Actor
body))
  Skills
actorMaxSk <- (State -> Skills) -> m Skills
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Skills) -> m Skills) -> (State -> Skills) -> m Skills
forall a b. (a -> b) -> a -> b
$ Actor -> State -> Skills
maxSkillsFromActor Actor
body
  (State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (ActorMaxSkills -> ActorMaxSkills) -> State -> State
updateActorMaxSkills ((ActorMaxSkills -> ActorMaxSkills) -> State -> State)
-> (ActorMaxSkills -> ActorMaxSkills) -> State -> State
forall a b. (a -> b) -> a -> b
$ ActorId -> Skills -> ActorMaxSkills -> ActorMaxSkills
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert ActorId
aid Skills
actorMaxSk

updLoseActor :: MonadStateWrite m => ActorId -> Actor ->  m ()
updLoseActor :: ActorId -> Actor -> m ()
updLoseActor ActorId
aid Actor
body = do
  -- Remove actor from @sactorD@.
  let f :: Maybe Actor -> Maybe Actor
f Maybe Actor
Nothing = String -> Maybe Actor
forall a. HasCallStack => String -> a
error (String -> Maybe Actor) -> String -> Maybe Actor
forall a b. (a -> b) -> a -> b
$ String
"actor already removed" String -> (ActorId, Actor) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
body)
      f (Just Actor
b) = Bool -> Maybe Actor -> Maybe Actor
forall a. HasCallStack => Bool -> a -> a
assert (Actor
b Actor -> Actor -> Bool
forall a. Eq a => a -> a -> Bool
== Actor
body Bool -> (String, (ActorId, Actor, Actor)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"inconsistent destroyed actor body"
                                     String
-> (ActorId, Actor, Actor) -> (String, (ActorId, Actor, Actor))
forall v. String -> v -> (String, v)
`swith` (ActorId
aid, Actor
body, Actor
b)) Maybe Actor
forall a. Maybe a
Nothing
  (State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (ActorDict -> ActorDict) -> State -> State
updateActorD ((ActorDict -> ActorDict) -> State -> State)
-> (ActorDict -> ActorDict) -> State -> State
forall a b. (a -> b) -> a -> b
$ (Maybe Actor -> Maybe Actor) -> ActorId -> ActorDict -> ActorDict
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe Actor -> Maybe Actor
f ActorId
aid
  let g :: Maybe [ActorId] -> Maybe [ActorId]
g Maybe [ActorId]
Nothing = String -> Maybe [ActorId]
forall a. HasCallStack => String -> a
error (String -> Maybe [ActorId]) -> String -> Maybe [ActorId]
forall a b. (a -> b) -> a -> b
$ String
"actor already removed" String -> (ActorId, Actor) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
body)
      g (Just [ActorId]
l) =
#ifdef WITH_EXPENSIVE_ASSERTIONS
        -- Not so much expensive, as doubly impossible.
        Bool -> Maybe [ActorId] -> Maybe [ActorId]
forall a. HasCallStack => Bool -> a -> a
assert (ActorId
aid ActorId -> [ActorId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ActorId]
l Bool -> (String, (ActorId, Actor, [ActorId])) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"actor already removed"
                             String
-> (ActorId, Actor, [ActorId])
-> (String, (ActorId, Actor, [ActorId]))
forall v. String -> v -> (String, v)
`swith` (ActorId
aid, Actor
body, [ActorId]
l))
#endif
        (let l2 :: [ActorId]
l2 = ActorId -> [ActorId] -> [ActorId]
forall a. Eq a => a -> [a] -> [a]
delete ActorId
aid [ActorId]
l
         in if [ActorId] -> Bool
forall a. [a] -> Bool
null [ActorId]
l2 then Maybe [ActorId]
forall a. Maybe a
Nothing else [ActorId] -> Maybe [ActorId]
forall a. a -> Maybe a
Just [ActorId]
l2)
  let h :: Maybe ActorId -> Maybe ActorId
h Maybe ActorId
Nothing = String -> Maybe ActorId
forall a. HasCallStack => String -> a
error (String -> Maybe ActorId) -> String -> Maybe ActorId
forall a b. (a -> b) -> a -> b
$ String
"actor already removed" String -> (ActorId, Actor) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
body)
      h (Just ActorId
_aid2) =
#ifdef WITH_EXPENSIVE_ASSERTIONS
        -- Not so much expensive, as doubly impossible.
        Bool -> Maybe ActorId -> Maybe ActorId
forall a. HasCallStack => Bool -> a -> a
assert (ActorId
aid ActorId -> ActorId -> Bool
forall a. Eq a => a -> a -> Bool
== ActorId
_aid2 Bool -> (String, (ActorId, Actor, ActorId)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"actor already removed"
                             String
-> (ActorId, Actor, ActorId) -> (String, (ActorId, Actor, ActorId))
forall v. String -> v -> (String, v)
`swith` (ActorId
aid, Actor
body, ActorId
_aid2))
#endif
        Maybe ActorId
forall a. Maybe a
Nothing
  LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel (Actor -> LevelId
blid Actor
body) ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ if Actor -> Bool
bproj Actor
body
                            then (ProjectileMap -> ProjectileMap) -> Level -> Level
updateProjMap ((Maybe [ActorId] -> Maybe [ActorId])
-> Point -> ProjectileMap -> ProjectileMap
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe [ActorId] -> Maybe [ActorId]
g (Actor -> Point
bpos Actor
body))
                            else (BigActorMap -> BigActorMap) -> Level -> Level
updateBigMap ((Maybe ActorId -> Maybe ActorId)
-> Point -> BigActorMap -> BigActorMap
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe ActorId -> Maybe ActorId
h (Actor -> Point
bpos Actor
body))
  (State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (ActorMaxSkills -> ActorMaxSkills) -> State -> State
updateActorMaxSkills ((ActorMaxSkills -> ActorMaxSkills) -> State -> State)
-> (ActorMaxSkills -> ActorMaxSkills) -> State -> State
forall a b. (a -> b) -> a -> b
$ ActorId -> ActorMaxSkills -> ActorMaxSkills
forall k a. Enum k => k -> EnumMap k a -> EnumMap k a
EM.delete ActorId
aid

updSpotItem :: MonadStateWrite m => ItemId -> ItemQuant -> Container -> m ()
updSpotItem :: ItemId -> ItemQuant -> Container -> m ()
updSpotItem ItemId
iid kit :: ItemQuant
kit@(Int
k, ItemTimers
_) Container
c = do
  Item
item <- (State -> Item) -> m Item
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Item) -> m Item) -> (State -> Item) -> m Item
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> Item
getItemBody ItemId
iid
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    ItemId -> ItemQuant -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> Container -> m ()
insertItemContainer ItemId
iid ItemQuant
kit Container
c
    case Container
c of
      CActor ActorId
aid CStore
store -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CStore
store CStore -> [CStore] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CStore
CEqp, CStore
COrgan])
                          (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ ItemId -> Item -> Int -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> Item -> Int -> ActorId -> m ()
addItemToActorMaxSkills ItemId
iid Item
item Int
k ActorId
aid
      Container
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

updLoseItem :: MonadStateWrite m => ItemId -> ItemQuant -> Container -> m ()
updLoseItem :: ItemId -> ItemQuant -> Container -> m ()
updLoseItem ItemId
iid kit :: ItemQuant
kit@(Int
k, ItemTimers
_) Container
c = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Item
item <- (State -> Item) -> m Item
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Item) -> m Item) -> (State -> Item) -> m Item
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> Item
getItemBody ItemId
iid
  ItemId -> ItemQuant -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> Container -> m ()
deleteItemContainer ItemId
iid ItemQuant
kit Container
c
  case Container
c of
    CActor ActorId
aid CStore
store -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CStore
store CStore -> [CStore] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CStore
CEqp, CStore
COrgan])
                        (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ ItemId -> Item -> Int -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> Item -> Int -> ActorId -> m ()
addItemToActorMaxSkills ItemId
iid Item
item (-Int
k) ActorId
aid
    Container
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

updSpotItemBag :: MonadStateWrite m => Container -> ItemBag -> m ()
updSpotItemBag :: Container -> ItemBag -> m ()
updSpotItemBag Container
c ItemBag
bag =
  -- The case of empty bag is for a hack to help identifying sample items.
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ItemBag -> Bool
forall k a. EnumMap k a -> Bool
EM.null ItemBag
bag) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    ItemBag -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemBag -> Container -> m ()
insertBagContainer ItemBag
bag Container
c
    case Container
c of
      CActor ActorId
aid CStore
store ->
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CStore
store CStore -> [CStore] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CStore
CEqp, CStore
COrgan]) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          ItemDict
itemD <- (State -> ItemDict) -> m ItemDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> ItemDict
sitemD
          let ais :: [(ItemId, Item)]
ais = (ItemId -> (ItemId, Item)) -> [ItemId] -> [(ItemId, Item)]
forall a b. (a -> b) -> [a] -> [b]
map (\ItemId
iid -> (ItemId
iid, ItemDict
itemD ItemDict -> ItemId -> Item
forall k a. Enum k => EnumMap k a -> k -> a
EM.! ItemId
iid)) ([ItemId] -> [(ItemId, Item)]) -> [ItemId] -> [(ItemId, Item)]
forall a b. (a -> b) -> a -> b
$ ItemBag -> [ItemId]
forall k a. Enum k => EnumMap k a -> [k]
EM.keys ItemBag
bag
          [(ItemId, Item)] -> ((ItemId, Item) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t a -> (a -> m ()) -> m ()
forM_ [(ItemId, Item)]
ais (((ItemId, Item) -> m ()) -> m ())
-> ((ItemId, Item) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(ItemId
iid, Item
item) ->
            ItemId -> Item -> Int -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> Item -> Int -> ActorId -> m ()
addItemToActorMaxSkills ItemId
iid Item
item (ItemQuant -> Int
forall a b. (a, b) -> a
fst (ItemQuant -> Int) -> ItemQuant -> Int
forall a b. (a -> b) -> a -> b
$ ItemBag
bag ItemBag -> ItemId -> ItemQuant
forall k a. Enum k => EnumMap k a -> k -> a
EM.! ItemId
iid) ActorId
aid
      Container
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

updLoseItemBag :: MonadStateWrite m => Container -> ItemBag -> m ()
updLoseItemBag :: Container -> ItemBag -> m ()
updLoseItemBag Container
c ItemBag
bag = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (ItemBag -> Int
forall k a. EnumMap k a -> Int
EM.size ItemBag
bag Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  ItemBag -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemBag -> Container -> m ()
deleteBagContainer ItemBag
bag Container
c
  -- Do not remove the items from @sitemD@ nor from @sitemRev@,
  -- It's incredibly costly and not noticeable for the player.
  -- However, assert the items are registered in @sitemD@.
  case Container
c of
    CActor ActorId
aid CStore
store ->
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CStore
store CStore -> [CStore] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CStore
CEqp, CStore
COrgan]) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        ItemDict
itemD <- (State -> ItemDict) -> m ItemDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> ItemDict
sitemD
        let ais :: [(ItemId, Item)]
ais = (ItemId -> (ItemId, Item)) -> [ItemId] -> [(ItemId, Item)]
forall a b. (a -> b) -> [a] -> [b]
map (\ItemId
iid -> (ItemId
iid, ItemDict
itemD ItemDict -> ItemId -> Item
forall k a. Enum k => EnumMap k a -> k -> a
EM.! ItemId
iid)) ([ItemId] -> [(ItemId, Item)]) -> [ItemId] -> [(ItemId, Item)]
forall a b. (a -> b) -> a -> b
$ ItemBag -> [ItemId]
forall k a. Enum k => EnumMap k a -> [k]
EM.keys ItemBag
bag
        [(ItemId, Item)] -> ((ItemId, Item) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t a -> (a -> m ()) -> m ()
forM_ [(ItemId, Item)]
ais (((ItemId, Item) -> m ()) -> m ())
-> ((ItemId, Item) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(ItemId
iid, Item
item) ->
          ItemId -> Item -> Int -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> Item -> Int -> ActorId -> m ()
addItemToActorMaxSkills ItemId
iid Item
item (- (ItemQuant -> Int
forall a b. (a, b) -> a
fst (ItemQuant -> Int) -> ItemQuant -> Int
forall a b. (a -> b) -> a -> b
$ ItemBag
bag ItemBag -> ItemId -> ItemQuant
forall k a. Enum k => EnumMap k a -> k -> a
EM.! ItemId
iid)) ActorId
aid
    Container
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

updMoveActor :: MonadStateWrite m => ActorId -> Point -> Point -> m ()
updMoveActor :: ActorId -> Point -> Point -> m ()
updMoveActor ActorId
aid Point
fromP Point
toP = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Point
fromP Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
/= Point
toP) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Actor
body <- (State -> Actor) -> m Actor
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
  let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Point
fromP Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
== Actor -> Point
bpos Actor
body
                    Bool -> (String, (ActorId, Point, Point, Point, Actor)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"unexpected moved actor position"
                    String
-> (ActorId, Point, Point, Point, Actor)
-> (String, (ActorId, Point, Point, Point, Actor))
forall v. String -> v -> (String, v)
`swith` (ActorId
aid, Point
fromP, Point
toP, Actor -> Point
bpos Actor
body, Actor
body)) ()
      newBody :: Actor
newBody = Actor
body {bpos :: Point
bpos = Point
toP, boldpos :: Maybe Point
boldpos = Point -> Maybe Point
forall a. a -> Maybe a
Just Point
fromP}
  ActorId -> (Actor -> Actor) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> (Actor -> Actor) -> m ()
updateActor ActorId
aid ((Actor -> Actor) -> m ()) -> (Actor -> Actor) -> m ()
forall a b. (a -> b) -> a -> b
$ Actor -> Actor -> Actor
forall a b. a -> b -> a
const Actor
newBody
  ActorId -> Actor -> Actor -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> Actor -> Actor -> m ()
moveActorMap ActorId
aid Actor
body Actor
newBody

updWaitActor :: MonadStateWrite m
             => ActorId -> Watchfulness -> Watchfulness -> m ()
updWaitActor :: ActorId -> Watchfulness -> Watchfulness -> m ()
updWaitActor ActorId
aid Watchfulness
fromWS Watchfulness
toWS = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Watchfulness
fromWS Watchfulness -> Watchfulness -> Bool
forall a. Eq a => a -> a -> Bool
/= Watchfulness
toWS) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Actor
body <- (State -> Actor) -> m Actor
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
  let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Watchfulness
fromWS Watchfulness -> Watchfulness -> Bool
forall a. Eq a => a -> a -> Bool
== Actor -> Watchfulness
bwatch Actor
body
                    Bool
-> (String, (ActorId, Watchfulness, Watchfulness, Actor)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"unexpected actor wait state"
                    String
-> (ActorId, Watchfulness, Watchfulness, Actor)
-> (String, (ActorId, Watchfulness, Watchfulness, Actor))
forall v. String -> v -> (String, v)
`swith` (ActorId
aid, Watchfulness
fromWS, Actor -> Watchfulness
bwatch Actor
body, Actor
body)) ()
  ActorId -> (Actor -> Actor) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> (Actor -> Actor) -> m ()
updateActor ActorId
aid ((Actor -> Actor) -> m ()) -> (Actor -> Actor) -> m ()
forall a b. (a -> b) -> a -> b
$ \Actor
b -> Actor
b {bwatch :: Watchfulness
bwatch = Watchfulness
toWS}

updDisplaceActor :: MonadStateWrite m => ActorId -> ActorId -> m ()
updDisplaceActor :: ActorId -> ActorId -> m ()
updDisplaceActor ActorId
source ActorId
target = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (ActorId
source ActorId -> ActorId -> Bool
forall a. Eq a => a -> a -> Bool
/= ActorId
target) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Actor
sbody <- (State -> Actor) -> m Actor
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
  Actor
tbody <- (State -> Actor) -> m Actor
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
target
  let spos :: Point
spos = Actor -> Point
bpos Actor
sbody
      tpos :: Point
tpos = Actor -> Point
bpos Actor
tbody
      snewBody :: Actor
snewBody = Actor
sbody {bpos :: Point
bpos = Point
tpos, boldpos :: Maybe Point
boldpos = Point -> Maybe Point
forall a. a -> Maybe a
Just Point
spos}
      tnewBody :: Actor
tnewBody = Actor
tbody {bpos :: Point
bpos = Point
spos, boldpos :: Maybe Point
boldpos = Point -> Maybe Point
forall a. a -> Maybe a
Just Point
tpos}
  ActorId -> (Actor -> Actor) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> (Actor -> Actor) -> m ()
updateActor ActorId
source ((Actor -> Actor) -> m ()) -> (Actor -> Actor) -> m ()
forall a b. (a -> b) -> a -> b
$ Actor -> Actor -> Actor
forall a b. a -> b -> a
const Actor
snewBody
  ActorId -> (Actor -> Actor) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> (Actor -> Actor) -> m ()
updateActor ActorId
target ((Actor -> Actor) -> m ()) -> (Actor -> Actor) -> m ()
forall a b. (a -> b) -> a -> b
$ Actor -> Actor -> Actor
forall a b. a -> b -> a
const Actor
tnewBody
  ActorId -> Actor -> ActorId -> Actor -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> Actor -> ActorId -> Actor -> m ()
swapActorMap ActorId
source Actor
sbody ActorId
target Actor
tbody

updMoveItem :: MonadStateWrite m
            => ItemId -> Int -> ActorId -> CStore -> CStore
            -> m ()
updMoveItem :: ItemId -> Int -> ActorId -> CStore -> CStore -> m ()
updMoveItem ItemId
iid Int
k ActorId
aid CStore
s1 CStore
s2 = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& CStore
s1 CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
/= CStore
s2) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Actor
b <- (State -> Actor) -> m Actor
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
  ItemBag
bag <- (State -> ItemBag) -> m ItemBag
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ItemBag) -> m ItemBag)
-> (State -> ItemBag) -> m ItemBag
forall a b. (a -> b) -> a -> b
$ Actor -> CStore -> State -> ItemBag
getBodyStoreBag Actor
b CStore
s1
  case ItemId
iid ItemId -> ItemBag -> Maybe ItemQuant
forall k a. Enum k => k -> EnumMap k a -> Maybe a
`EM.lookup` ItemBag
bag of
    Maybe ItemQuant
Nothing -> String -> m ()
forall a. HasCallStack => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"" String -> (ItemId, Int, ActorId, CStore, CStore) -> String
forall v. Show v => String -> v -> String
`showFailure` (ItemId
iid, Int
k, ActorId
aid, CStore
s1, CStore
s2)
    Just (Int
_, ItemTimers
it) -> do
      ItemId -> ItemQuant -> ActorId -> CStore -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> ActorId -> CStore -> m ()
deleteItemActor ItemId
iid (Int
k, Int -> ItemTimers -> ItemTimers
forall a. Int -> [a] -> [a]
take Int
k ItemTimers
it) ActorId
aid CStore
s1
      ItemId -> ItemQuant -> ActorId -> CStore -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> ActorId -> CStore -> m ()
insertItemActor ItemId
iid (Int
k, Int -> ItemTimers -> ItemTimers
forall a. Int -> [a] -> [a]
take Int
k ItemTimers
it) ActorId
aid CStore
s2
  case CStore
s1 of
    CStore
CEqp -> case CStore
s2 of
      CStore
COrgan -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      CStore
_ -> do
        Item
itemBase <- (State -> Item) -> m Item
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Item) -> m Item) -> (State -> Item) -> m Item
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> Item
getItemBody ItemId
iid
        ItemId -> Item -> Int -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> Item -> Int -> ActorId -> m ()
addItemToActorMaxSkills ItemId
iid Item
itemBase (-Int
k) ActorId
aid
    CStore
COrgan -> case CStore
s2 of
      CStore
CEqp -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      CStore
_ -> do
        Item
itemBase <- (State -> Item) -> m Item
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Item) -> m Item) -> (State -> Item) -> m Item
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> Item
getItemBody ItemId
iid
        ItemId -> Item -> Int -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> Item -> Int -> ActorId -> m ()
addItemToActorMaxSkills ItemId
iid Item
itemBase (-Int
k) ActorId
aid
    CStore
_ ->
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CStore
s2 CStore -> [CStore] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CStore
CEqp, CStore
COrgan]) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        Item
itemBase <- (State -> Item) -> m Item
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Item) -> m Item) -> (State -> Item) -> m Item
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> Item
getItemBody ItemId
iid
        ItemId -> Item -> Int -> ActorId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> Item -> Int -> ActorId -> m ()
addItemToActorMaxSkills ItemId
iid Item
itemBase Int
k ActorId
aid

updRefillHP :: MonadStateWrite m => ActorId -> Int64 -> m ()
updRefillHP :: ActorId -> Int64 -> m ()
updRefillHP ActorId
aid Int64
nRaw =
  ActorId -> (Actor -> Actor) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> (Actor -> Actor) -> m ()
updateActor ActorId
aid ((Actor -> Actor) -> m ()) -> (Actor -> Actor) -> m ()
forall a b. (a -> b) -> a -> b
$ \Actor
b ->
    -- Make rescue easier by not going into negative HP the first time.
    let newRawHP :: Int64
newRawHP = Actor -> Int64
bhp Actor
b Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
nRaw
        newHP :: Int64
newHP = if Actor -> Int64
bhp Actor
b Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
0 then Int64
newRawHP else Int64 -> Int64 -> Int64
forall a. Ord a => a -> a -> a
max Int64
0 Int64
newRawHP
        n :: Int64
n = Int64
newHP Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Actor -> Int64
bhp Actor
b
    in Actor
b { bhp :: Int64
bhp = Int64
newHP
         , bhpDelta :: ResDelta
bhpDelta = let oldD :: ResDelta
oldD = Actor -> ResDelta
bhpDelta Actor
b
                      in case Int64 -> Int64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int64
n Int64
0 of
                        Ordering
EQ -> ResDelta :: (Int64, Int64) -> (Int64, Int64) -> ResDelta
ResDelta { resCurrentTurn :: (Int64, Int64)
resCurrentTurn = (Int64
0, Int64
0)
                                       , resPreviousTurn :: (Int64, Int64)
resPreviousTurn = ResDelta -> (Int64, Int64)
resCurrentTurn ResDelta
oldD }
                        Ordering
LT -> ResDelta
oldD {resCurrentTurn :: (Int64, Int64)
resCurrentTurn =
                                      ( (Int64, Int64) -> Int64
forall a b. (a, b) -> a
fst (ResDelta -> (Int64, Int64)
resCurrentTurn ResDelta
oldD) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
n
                                      , (Int64, Int64) -> Int64
forall a b. (a, b) -> b
snd (ResDelta -> (Int64, Int64)
resCurrentTurn ResDelta
oldD) )}
                        Ordering
GT -> ResDelta
oldD {resCurrentTurn :: (Int64, Int64)
resCurrentTurn =
                                      ( (Int64, Int64) -> Int64
forall a b. (a, b) -> a
fst (ResDelta -> (Int64, Int64)
resCurrentTurn ResDelta
oldD)
                                      , (Int64, Int64) -> Int64
forall a b. (a, b) -> b
snd (ResDelta -> (Int64, Int64)
resCurrentTurn ResDelta
oldD) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
n )}
         }

updRefillCalm :: MonadStateWrite m => ActorId -> Int64 -> m ()
updRefillCalm :: ActorId -> Int64 -> m ()
updRefillCalm ActorId
aid Int64
n =
  ActorId -> (Actor -> Actor) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> (Actor -> Actor) -> m ()
updateActor ActorId
aid ((Actor -> Actor) -> m ()) -> (Actor -> Actor) -> m ()
forall a b. (a -> b) -> a -> b
$ \Actor
b ->
    Actor
b { bcalm :: Int64
bcalm = Int64 -> Int64 -> Int64
forall a. Ord a => a -> a -> a
max Int64
0 (Int64 -> Int64) -> Int64 -> Int64
forall a b. (a -> b) -> a -> b
$ Actor -> Int64
bcalm Actor
b Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
n
      , bcalmDelta :: ResDelta
bcalmDelta = let oldD :: ResDelta
oldD = Actor -> ResDelta
bcalmDelta Actor
b
                     in case Int64 -> Int64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int64
n Int64
0 of
                       Ordering
EQ -> ResDelta :: (Int64, Int64) -> (Int64, Int64) -> ResDelta
ResDelta { resCurrentTurn :: (Int64, Int64)
resCurrentTurn = (Int64
0, Int64
0)
                                      , resPreviousTurn :: (Int64, Int64)
resPreviousTurn = ResDelta -> (Int64, Int64)
resCurrentTurn ResDelta
oldD }
                       Ordering
LT -> ResDelta
oldD {resCurrentTurn :: (Int64, Int64)
resCurrentTurn =
                                     ( (Int64, Int64) -> Int64
forall a b. (a, b) -> a
fst (ResDelta -> (Int64, Int64)
resCurrentTurn ResDelta
oldD) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
n
                                     , (Int64, Int64) -> Int64
forall a b. (a, b) -> b
snd (ResDelta -> (Int64, Int64)
resCurrentTurn ResDelta
oldD) )}
                       Ordering
GT -> ResDelta
oldD {resCurrentTurn :: (Int64, Int64)
resCurrentTurn =
                                     ( (Int64, Int64) -> Int64
forall a b. (a, b) -> a
fst (ResDelta -> (Int64, Int64)
resCurrentTurn ResDelta
oldD)
                                     , (Int64, Int64) -> Int64
forall a b. (a, b) -> b
snd (ResDelta -> (Int64, Int64)
resCurrentTurn ResDelta
oldD) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
n )}
      }

updTrajectory :: MonadStateWrite m
              => ActorId
              -> Maybe ([Vector], Speed)
              -> Maybe ([Vector], Speed)
              -> m ()
updTrajectory :: ActorId
-> Maybe ([Vector], Speed) -> Maybe ([Vector], Speed) -> m ()
updTrajectory ActorId
aid Maybe ([Vector], Speed)
fromT Maybe ([Vector], Speed)
toT = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Maybe ([Vector], Speed)
fromT Maybe ([Vector], Speed) -> Maybe ([Vector], Speed) -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe ([Vector], Speed)
toT) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Actor
body <- (State -> Actor) -> m Actor
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
  let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Maybe ([Vector], Speed)
fromT Maybe ([Vector], Speed) -> Maybe ([Vector], Speed) -> Bool
forall a. Eq a => a -> a -> Bool
== Actor -> Maybe ([Vector], Speed)
btrajectory Actor
body
                    Bool
-> (String,
    (ActorId, Maybe ([Vector], Speed), Maybe ([Vector], Speed), Actor))
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"unexpected actor trajectory"
                    String
-> (ActorId, Maybe ([Vector], Speed), Maybe ([Vector], Speed),
    Actor)
-> (String,
    (ActorId, Maybe ([Vector], Speed), Maybe ([Vector], Speed), Actor))
forall v. String -> v -> (String, v)
`swith` (ActorId
aid, Maybe ([Vector], Speed)
fromT, Maybe ([Vector], Speed)
toT, Actor
body)) ()
  ActorId -> (Actor -> Actor) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ActorId -> (Actor -> Actor) -> m ()
updateActor ActorId
aid ((Actor -> Actor) -> m ()) -> (Actor -> Actor) -> m ()
forall a b. (a -> b) -> a -> b
$ \Actor
b -> Actor
b {btrajectory :: Maybe ([Vector], Speed)
btrajectory = Maybe ([Vector], Speed)
toT}

updQuitFaction :: MonadStateWrite m
               => FactionId -> Maybe Status -> Maybe Status
               -> m ()
updQuitFaction :: FactionId -> Maybe Status -> Maybe Status -> m ()
updQuitFaction FactionId
fid Maybe Status
fromSt Maybe Status
toSt = do
  let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Maybe Status
fromSt Maybe Status -> Maybe Status -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Status
toSt Bool -> (FactionId, Maybe Status, Maybe Status) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (FactionId
fid, Maybe Status
fromSt, Maybe Status
toSt)) ()
  Faction
fact <- (State -> Faction) -> m Faction
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Faction) -> m Faction)
-> (State -> Faction) -> m Faction
forall a b. (a -> b) -> a -> b
$ (EnumMap FactionId Faction -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid) (EnumMap FactionId Faction -> Faction)
-> (State -> EnumMap FactionId Faction) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EnumMap FactionId Faction
sfactionD
  let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Maybe Status
fromSt Maybe Status -> Maybe Status -> Bool
forall a. Eq a => a -> a -> Bool
== Faction -> Maybe Status
gquit Faction
fact
                    Bool
-> (String, (FactionId, Maybe Status, Maybe Status, Faction))
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"unexpected actor quit status"
                    String
-> (FactionId, Maybe Status, Maybe Status, Faction)
-> (String, (FactionId, Maybe Status, Maybe Status, Faction))
forall v. String -> v -> (String, v)
`swith` (FactionId
fid, Maybe Status
fromSt, Maybe Status
toSt, Faction
fact)) ()
  let adj :: Faction -> Faction
adj Faction
fa = Faction
fa {gquit :: Maybe Status
gquit = Maybe Status
toSt}
  FactionId -> (Faction -> Faction) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> (Faction -> Faction) -> m ()
updateFaction FactionId
fid Faction -> Faction
adj

updSpotStashFaction :: MonadStateWrite m
                    => FactionId -> LevelId -> Point -> m ()
updSpotStashFaction :: FactionId -> LevelId -> Point -> m ()
updSpotStashFaction FactionId
fid LevelId
lid Point
pos = do
  let adj :: Faction -> Faction
adj Faction
fa = Faction
fa {gstash :: Maybe (LevelId, Point)
gstash = (LevelId, Point) -> Maybe (LevelId, Point)
forall a. a -> Maybe a
Just (LevelId
lid, Point
pos)}
    -- the stash may be outdated, but not empty and it's correct,
    -- because we know stash may be only one, so here it's added,
    -- the old one is removed, despite us not seeing its location;
    -- warning: in this form, this is not reversible, no undo,
    -- so we'd need to add the required @UpdLoseStashFaction@
    -- elsehwere, similarly as @LoseTile@ is added when FOV
    -- reveals that tile is different than expected
  FactionId -> (Faction -> Faction) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> (Faction -> Faction) -> m ()
updateFaction FactionId
fid Faction -> Faction
adj

updLoseStashFaction :: MonadStateWrite m
                    => FactionId -> LevelId -> Point -> m ()
updLoseStashFaction :: FactionId -> LevelId -> Point -> m ()
updLoseStashFaction FactionId
fid LevelId
lid Point
pos = do
  let adj :: Faction -> Faction
adj Faction
fa = Bool -> Faction -> Faction
forall a. HasCallStack => Bool -> a -> a
assert (Faction -> Maybe (LevelId, Point)
gstash Faction
fa Maybe (LevelId, Point) -> Maybe (LevelId, Point) -> Bool
forall a. Eq a => a -> a -> Bool
== (LevelId, Point) -> Maybe (LevelId, Point)
forall a. a -> Maybe a
Just (LevelId
lid, Point
pos)
                       Bool -> (String, (FactionId, LevelId, Point, Faction)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"unexpected lack of gstash"
                       String
-> (FactionId, LevelId, Point, Faction)
-> (String, (FactionId, LevelId, Point, Faction))
forall v. String -> v -> (String, v)
`swith` (FactionId
fid, LevelId
lid, Point
pos, Faction
fa))
               (Faction -> Faction) -> Faction -> Faction
forall a b. (a -> b) -> a -> b
$ Faction
fa {gstash :: Maybe (LevelId, Point)
gstash = Maybe (LevelId, Point)
forall a. Maybe a
Nothing}
  FactionId -> (Faction -> Faction) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> (Faction -> Faction) -> m ()
updateFaction FactionId
fid Faction -> Faction
adj

-- The previous leader is assumed to be alive.
updLeadFaction :: MonadStateWrite m
               => FactionId
               -> Maybe ActorId
               -> Maybe ActorId
               -> m ()
updLeadFaction :: FactionId -> Maybe ActorId -> Maybe ActorId -> m ()
updLeadFaction FactionId
fid Maybe ActorId
source Maybe ActorId
target = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Maybe ActorId
source Maybe ActorId -> Maybe ActorId -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe ActorId
target) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Faction
fact <- (State -> Faction) -> m Faction
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Faction) -> m Faction)
-> (State -> Faction) -> m Faction
forall a b. (a -> b) -> a -> b
$ (EnumMap FactionId Faction -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid) (EnumMap FactionId Faction -> Faction)
-> (State -> EnumMap FactionId Faction) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EnumMap FactionId Faction
sfactionD
  let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (FactionKind -> Bool
fhasPointman (Faction -> FactionKind
gkind Faction
fact)) ()
    -- @PosNone@ ensures this
  Maybe Actor
mtb <- (State -> Maybe Actor) -> m (Maybe Actor)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Maybe Actor) -> m (Maybe Actor))
-> (State -> Maybe Actor) -> m (Maybe Actor)
forall a b. (a -> b) -> a -> b
$ \State
s -> (ActorId -> State -> Actor) -> State -> ActorId -> Actor
forall a b c. (a -> b -> c) -> b -> a -> c
flip ActorId -> State -> Actor
getActorBody State
s (ActorId -> Actor) -> Maybe ActorId -> Maybe Actor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ActorId
target
  let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> (Actor -> Bool) -> Maybe Actor -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool -> Bool
not (Bool -> Bool) -> (Actor -> Bool) -> Actor -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Actor -> Bool
bproj) Maybe Actor
mtb
                    Bool
-> (FactionId, Maybe ActorId, Maybe ActorId, Maybe Actor, Faction)
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (FactionId
fid, Maybe ActorId
source, Maybe ActorId
target, Maybe Actor
mtb, Faction
fact)) ()
  let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Maybe ActorId
source Maybe ActorId -> Maybe ActorId -> Bool
forall a. Eq a => a -> a -> Bool
== Faction -> Maybe ActorId
gleader Faction
fact
                    Bool
-> (String,
    (FactionId, Maybe ActorId, Maybe ActorId, Maybe Actor, Faction))
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"unexpected actor leader"
                    String
-> (FactionId, Maybe ActorId, Maybe ActorId, Maybe Actor, Faction)
-> (String,
    (FactionId, Maybe ActorId, Maybe ActorId, Maybe Actor, Faction))
forall v. String -> v -> (String, v)
`swith` (FactionId
fid, Maybe ActorId
source, Maybe ActorId
target, Maybe Actor
mtb, Faction
fact)) ()
  let adj :: Faction -> Faction
adj Faction
fa = Faction
fa {_gleader :: Maybe ActorId
_gleader = Maybe ActorId
target}
  FactionId -> (Faction -> Faction) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> (Faction -> Faction) -> m ()
updateFaction FactionId
fid Faction -> Faction
adj

updDiplFaction :: MonadStateWrite m
               => FactionId -> FactionId -> Diplomacy -> Diplomacy -> m ()
updDiplFaction :: FactionId -> FactionId -> Diplomacy -> Diplomacy -> m ()
updDiplFaction FactionId
fid1 FactionId
fid2 Diplomacy
fromDipl Diplomacy
toDipl =
  Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (FactionId
fid1 FactionId -> FactionId -> Bool
forall a. Eq a => a -> a -> Bool
/= FactionId
fid2 Bool -> Bool -> Bool
&& Diplomacy
fromDipl Diplomacy -> Diplomacy -> Bool
forall a. Eq a => a -> a -> Bool
/= Diplomacy
toDipl) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Faction
fact1 <- (State -> Faction) -> m Faction
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Faction) -> m Faction)
-> (State -> Faction) -> m Faction
forall a b. (a -> b) -> a -> b
$ (EnumMap FactionId Faction -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid1) (EnumMap FactionId Faction -> Faction)
-> (State -> EnumMap FactionId Faction) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EnumMap FactionId Faction
sfactionD
    Faction
fact2 <- (State -> Faction) -> m Faction
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Faction) -> m Faction)
-> (State -> Faction) -> m Faction
forall a b. (a -> b) -> a -> b
$ (EnumMap FactionId Faction -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid2) (EnumMap FactionId Faction -> Faction)
-> (State -> EnumMap FactionId Faction) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EnumMap FactionId Faction
sfactionD
    let !_A :: ()
_A =
          Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Diplomacy
fromDipl Diplomacy -> Diplomacy -> Bool
forall a. Eq a => a -> a -> Bool
== Diplomacy -> FactionId -> EnumMap FactionId Diplomacy -> Diplomacy
forall k a. Enum k => a -> k -> EnumMap k a -> a
EM.findWithDefault Diplomacy
Unknown FactionId
fid2 (Faction -> EnumMap FactionId Diplomacy
gdipl Faction
fact1)
                  Bool -> Bool -> Bool
&& Diplomacy
fromDipl Diplomacy -> Diplomacy -> Bool
forall a. Eq a => a -> a -> Bool
== Diplomacy -> FactionId -> EnumMap FactionId Diplomacy -> Diplomacy
forall k a. Enum k => a -> k -> EnumMap k a -> a
EM.findWithDefault Diplomacy
Unknown FactionId
fid1 (Faction -> EnumMap FactionId Diplomacy
gdipl Faction
fact2)
                  Bool
-> (String,
    (FactionId, FactionId, Diplomacy, Diplomacy, Faction, Faction))
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"unexpected actor diplomacy status"
                  String
-> (FactionId, FactionId, Diplomacy, Diplomacy, Faction, Faction)
-> (String,
    (FactionId, FactionId, Diplomacy, Diplomacy, Faction, Faction))
forall v. String -> v -> (String, v)
`swith` (FactionId
fid1, FactionId
fid2, Diplomacy
fromDipl, Diplomacy
toDipl, Faction
fact1, Faction
fact2)) ()
    let adj :: FactionId -> Faction -> Faction
adj FactionId
fid Faction
fact = Faction
fact {gdipl :: EnumMap FactionId Diplomacy
gdipl = FactionId
-> Diplomacy
-> EnumMap FactionId Diplomacy
-> EnumMap FactionId Diplomacy
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert FactionId
fid Diplomacy
toDipl (Faction -> EnumMap FactionId Diplomacy
gdipl Faction
fact)}
    FactionId -> (Faction -> Faction) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> (Faction -> Faction) -> m ()
updateFaction FactionId
fid1 (FactionId -> Faction -> Faction
adj FactionId
fid2)
    FactionId -> (Faction -> Faction) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> (Faction -> Faction) -> m ()
updateFaction FactionId
fid2 (FactionId -> Faction -> Faction
adj FactionId
fid1)

updDoctrineFaction :: MonadStateWrite m
                   => FactionId -> Ability.Doctrine -> Ability.Doctrine -> m ()
updDoctrineFaction :: FactionId -> Doctrine -> Doctrine -> m ()
updDoctrineFaction FactionId
fid Doctrine
toT Doctrine
fromT = do
  let adj :: Faction -> Faction
adj Faction
fact = Bool -> Faction -> Faction
forall a. HasCallStack => Bool -> a -> a
assert (Faction -> Doctrine
gdoctrine Faction
fact Doctrine -> Doctrine -> Bool
forall a. Eq a => a -> a -> Bool
== Doctrine
fromT) (Faction -> Faction) -> Faction -> Faction
forall a b. (a -> b) -> a -> b
$ Faction
fact {gdoctrine :: Doctrine
gdoctrine = Doctrine
toT}
  FactionId -> (Faction -> Faction) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> (Faction -> Faction) -> m ()
updateFaction FactionId
fid Faction -> Faction
adj

updAutoFaction :: MonadStateWrite m => FactionId -> Bool -> m ()
updAutoFaction :: FactionId -> Bool -> m ()
updAutoFaction FactionId
fid Bool
st =
  FactionId -> (Faction -> Faction) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> (Faction -> Faction) -> m ()
updateFaction FactionId
fid (\Faction
fact ->
    Bool -> Faction -> Faction
forall a. HasCallStack => Bool -> a -> a
assert (Faction -> Bool
gunderAI Faction
fact Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Bool
not Bool
st) (Faction -> Faction) -> Faction -> Faction
forall a b. (a -> b) -> a -> b
$ Faction
fact {gunderAI :: Bool
gunderAI = Bool
st})

-- Record a given number (usually just 1, or -1 for undo) of actor kills
-- for score calculation.
updRecordKill :: MonadStateWrite m
              => ActorId -> ContentId ItemKind -> Int -> m ()
updRecordKill :: ActorId -> ContentId ItemKind -> Int -> m ()
updRecordKill ActorId
aid ContentId ItemKind
ikind Int
k = do
  Actor
b <- (State -> Actor) -> m Actor
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
  let !_A :: Any -> Any
_A = Bool -> Any -> Any
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Actor -> Bool
bproj Actor
b) Bool -> (ActorId, Actor) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (ActorId
aid, Actor
b))
  let alterKind :: Maybe Int -> Maybe Int
alterKind Maybe Int
mn = let n :: Int
n = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
mn Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k
                     in if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Maybe Int
forall a. Maybe a
Nothing else Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
      adjFact :: Faction -> Faction
adjFact Faction
fact = Faction
fact {gvictims :: EnumMap (ContentId ItemKind) Int
gvictims = (Maybe Int -> Maybe Int)
-> ContentId ItemKind
-> EnumMap (ContentId ItemKind) Int
-> EnumMap (ContentId ItemKind) Int
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe Int -> Maybe Int
alterKind ContentId ItemKind
ikind
                                      (EnumMap (ContentId ItemKind) Int
 -> EnumMap (ContentId ItemKind) Int)
-> EnumMap (ContentId ItemKind) Int
-> EnumMap (ContentId ItemKind) Int
forall a b. (a -> b) -> a -> b
$ Faction -> EnumMap (ContentId ItemKind) Int
gvictims Faction
fact}
  FactionId -> (Faction -> Faction) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
FactionId -> (Faction -> Faction) -> m ()
updateFaction (Actor -> FactionId
bfid Actor
b) Faction -> Faction
adjFact
    -- The death of a dominated actor counts as the dominating faction's loss
    -- for score purposes, so human nor AI can't treat such actor as disposable,
    -- which means domination will not be as cruel, as frustrating,
    -- as it could be and there is a higher chance of getting back alive
    -- the actor, the human player has grown attached to.

-- Alter an attribute (actually, the only, the defining attribute)
-- of a visible tile. This is similar to e.g., @UpdTrajectory@.
--
-- Removing and creating embedded items when altering a tile
-- is done separately via @UpdCreateItem@ and @UpdDestroyItem@.
updAlterTile :: MonadStateWrite m
             => LevelId -> Point -> ContentId TileKind -> ContentId TileKind
             -> m ()
updAlterTile :: LevelId
-> Point -> ContentId TileKind -> ContentId TileKind -> m ()
updAlterTile LevelId
lid Point
p ContentId TileKind
fromTile ContentId TileKind
toTile = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (ContentId TileKind
fromTile ContentId TileKind -> ContentId TileKind -> Bool
forall a. Eq a => a -> a -> Bool
/= ContentId TileKind
toTile) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  COps{TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  Level
lvl <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel LevelId
lid
  let t :: ContentId TileKind
t = Level
lvl Level -> Point -> ContentId TileKind
`at` Point
p
  if ContentId TileKind
t ContentId TileKind -> ContentId TileKind -> Bool
forall a. Eq a => a -> a -> Bool
/= ContentId TileKind
fromTile
  then String -> m ()
forall a. String -> a
atomicFail String
"terrain to modify is different than assumed"
  else do
    let adj :: Array (ContentId TileKind) -> Array (ContentId TileKind)
adj Array (ContentId TileKind)
ts = Array (ContentId TileKind)
ts Array (ContentId TileKind)
-> [(Point, ContentId TileKind)] -> Array (ContentId TileKind)
forall c. UnboxRepClass c => Array c -> [(Point, c)] -> Array c
PointArray.// [(Point
p, ContentId TileKind
toTile)]
    LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ (Array (ContentId TileKind) -> Array (ContentId TileKind))
-> Level -> Level
updateTile Array (ContentId TileKind) -> Array (ContentId TileKind)
adj
    case ( TileSpeedup -> ContentId TileKind -> Bool
Tile.isExplorable TileSpeedup
coTileSpeedup ContentId TileKind
fromTile
         , TileSpeedup -> ContentId TileKind -> Bool
Tile.isExplorable TileSpeedup
coTileSpeedup ContentId TileKind
toTile ) of
      (Bool
False, Bool
True) -> LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ \Level
lvl2 -> Level
lvl2 {lseen :: Int
lseen = Level -> Int
lseen Level
lvl2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1}
      (Bool
True, Bool
False) -> LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ \Level
lvl2 -> Level
lvl2 {lseen :: Int
lseen = Level -> Int
lseen Level
lvl2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1}
      (Bool, Bool)
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

updAlterExplorable :: MonadStateWrite m => LevelId -> Int -> m ()
updAlterExplorable :: LevelId -> Int -> m ()
updAlterExplorable LevelId
lid Int
delta = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
delta Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
  LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ \Level
lvl -> Level
lvl {lexpl :: Int
lexpl = Level -> Int
lexpl Level
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
delta}

updAlterGold :: MonadStateWrite m => Int -> m ()
updAlterGold :: Int -> m ()
updAlterGold Int
delta = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
delta Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
  (State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> State -> State
updateGold (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
delta)

-- Showing to the client the embedded items, if any, is done elsewhere.
updSearchTile :: MonadStateWrite m
              => ActorId -> Point -> ContentId TileKind -> m ()
updSearchTile :: ActorId -> Point -> ContentId TileKind -> m ()
updSearchTile ActorId
aid Point
p ContentId TileKind
toTile = do
  COps{ContentData TileKind
cotile :: COps -> ContentData TileKind
cotile :: ContentData TileKind
cotile} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  Actor
b <- (State -> Actor) -> m Actor
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
  Level
lvl <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel (LevelId -> m Level) -> LevelId -> m Level
forall a b. (a -> b) -> a -> b
$ Actor -> LevelId
blid Actor
b
  let t :: ContentId TileKind
t = Level
lvl Level -> Point -> ContentId TileKind
`at` Point
p
  if ContentId TileKind
t ContentId TileKind -> ContentId TileKind -> Bool
forall a. Eq a => a -> a -> Bool
== ContentId TileKind
toTile
  then String -> m ()
forall a. String -> a
atomicFail String
"tile already searched"
  else Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (ContentId TileKind -> Maybe (ContentId TileKind)
forall a. a -> Maybe a
Just ContentId TileKind
t Maybe (ContentId TileKind) -> Maybe (ContentId TileKind) -> Bool
forall a. Eq a => a -> a -> Bool
== ContentData TileKind
-> ContentId TileKind -> Maybe (ContentId TileKind)
Tile.hideAs ContentData TileKind
cotile ContentId TileKind
toTile) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    LevelId -> [(Point, ContentId TileKind)] -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> [(Point, ContentId TileKind)] -> m ()
updLoseTile (Actor -> LevelId
blid Actor
b) [(Point
p, ContentId TileKind
t)]
    LevelId -> [(Point, ContentId TileKind)] -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> [(Point, ContentId TileKind)] -> m ()
updSpotTile (Actor -> LevelId
blid Actor
b) [(Point
p, ContentId TileKind
toTile)]  -- not the hidden version this one time

-- Notice previously invisible tiles. This is done in bulk,
-- because it often involves dozens of tiles per move.
-- We verify that the old tiles at the positions in question
-- are indeed unknown.
updSpotTile :: MonadStateWrite m
            => LevelId -> [(Point, ContentId TileKind)] -> m ()
updSpotTile :: LevelId -> [(Point, ContentId TileKind)] -> m ()
updSpotTile LevelId
lid [(Point, ContentId TileKind)]
ts = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Point, ContentId TileKind)] -> Bool
forall a. [a] -> Bool
null [(Point, ContentId TileKind)]
ts) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  COps{TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  let unk :: Array (ContentId TileKind) -> (Point, b) -> Bool
unk Array (ContentId TileKind)
tileMap (Point
p, b
_) = Array (ContentId TileKind)
tileMap Array (ContentId TileKind) -> Point -> ContentId TileKind
forall c. UnboxRepClass c => Array c -> Point -> c
PointArray.! Point
p ContentId TileKind -> ContentId TileKind -> Bool
forall a. Eq a => a -> a -> Bool
== ContentId TileKind
unknownId
      adj :: Array (ContentId TileKind) -> Array (ContentId TileKind)
adj Array (ContentId TileKind)
tileMap = Bool -> Array (ContentId TileKind) -> Array (ContentId TileKind)
forall a. HasCallStack => Bool -> a -> a
assert (((Point, ContentId TileKind) -> Bool)
-> [(Point, ContentId TileKind)] -> Bool
forall a. Show a => (a -> Bool) -> [a] -> Bool
allB (Array (ContentId TileKind) -> (Point, ContentId TileKind) -> Bool
forall b. Array (ContentId TileKind) -> (Point, b) -> Bool
unk Array (ContentId TileKind)
tileMap) [(Point, ContentId TileKind)]
ts)
                    (Array (ContentId TileKind) -> Array (ContentId TileKind))
-> Array (ContentId TileKind) -> Array (ContentId TileKind)
forall a b. (a -> b) -> a -> b
$ Array (ContentId TileKind)
tileMap Array (ContentId TileKind)
-> [(Point, ContentId TileKind)] -> Array (ContentId TileKind)
forall c. UnboxRepClass c => Array c -> [(Point, c)] -> Array c
PointArray.// [(Point, ContentId TileKind)]
ts
  LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ (Array (ContentId TileKind) -> Array (ContentId TileKind))
-> Level -> Level
updateTile Array (ContentId TileKind) -> Array (ContentId TileKind)
adj
  let f :: (Point, ContentId TileKind) -> m ()
f (Point
_, ContentId TileKind
t1) = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TileSpeedup -> ContentId TileKind -> Bool
Tile.isExplorable TileSpeedup
coTileSpeedup ContentId TileKind
t1) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ \Level
lvl -> Level
lvl {lseen :: Int
lseen = Level -> Int
lseen Level
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1}
  ((Point, ContentId TileKind) -> m ())
-> [(Point, ContentId TileKind)] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (Point, ContentId TileKind) -> m ()
f [(Point, ContentId TileKind)]
ts

-- Stop noticing previously visible tiles. It verifies
-- the state of the tiles before wiping them out.
updLoseTile :: MonadStateWrite m
            => LevelId -> [(Point, ContentId TileKind)] -> m ()
updLoseTile :: LevelId -> [(Point, ContentId TileKind)] -> m ()
updLoseTile LevelId
lid [(Point, ContentId TileKind)]
ts = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Point, ContentId TileKind)] -> Bool
forall a. [a] -> Bool
null [(Point, ContentId TileKind)]
ts) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  COps{TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  let matches :: Array a -> (Point, a) -> Bool
matches Array a
tileMap (Point
p, a
ov) = Array a
tileMap Array a -> Point -> a
forall c. UnboxRepClass c => Array c -> Point -> c
PointArray.! Point
p a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
ov
      tu :: [(Point, ContentId TileKind)]
tu = ((Point, ContentId TileKind) -> (Point, ContentId TileKind))
-> [(Point, ContentId TileKind)] -> [(Point, ContentId TileKind)]
forall a b. (a -> b) -> [a] -> [b]
map ((ContentId TileKind -> ContentId TileKind)
-> (Point, ContentId TileKind) -> (Point, ContentId TileKind)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (ContentId TileKind -> ContentId TileKind -> ContentId TileKind
forall a b. a -> b -> a
const ContentId TileKind
unknownId)) [(Point, ContentId TileKind)]
ts
      adj :: Array (ContentId TileKind) -> Array (ContentId TileKind)
adj Array (ContentId TileKind)
tileMap = Bool -> Array (ContentId TileKind) -> Array (ContentId TileKind)
forall a. HasCallStack => Bool -> a -> a
assert (((Point, ContentId TileKind) -> Bool)
-> [(Point, ContentId TileKind)] -> Bool
forall a. Show a => (a -> Bool) -> [a] -> Bool
allB (Array (ContentId TileKind) -> (Point, ContentId TileKind) -> Bool
forall a. UnboxRepClass a => Array a -> (Point, a) -> Bool
matches Array (ContentId TileKind)
tileMap) [(Point, ContentId TileKind)]
ts)
                    (Array (ContentId TileKind) -> Array (ContentId TileKind))
-> Array (ContentId TileKind) -> Array (ContentId TileKind)
forall a b. (a -> b) -> a -> b
$ Array (ContentId TileKind)
tileMap Array (ContentId TileKind)
-> [(Point, ContentId TileKind)] -> Array (ContentId TileKind)
forall c. UnboxRepClass c => Array c -> [(Point, c)] -> Array c
PointArray.// [(Point, ContentId TileKind)]
tu
  LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ (Array (ContentId TileKind) -> Array (ContentId TileKind))
-> Level -> Level
updateTile Array (ContentId TileKind) -> Array (ContentId TileKind)
adj
  let f :: (Point, ContentId TileKind) -> m ()
f (Point
_, ContentId TileKind
t1) = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TileSpeedup -> ContentId TileKind -> Bool
Tile.isExplorable TileSpeedup
coTileSpeedup ContentId TileKind
t1) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ \Level
lvl -> Level
lvl {lseen :: Int
lseen = Level -> Int
lseen Level
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1}
  ((Point, ContentId TileKind) -> m ())
-> [(Point, ContentId TileKind)] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (Point, ContentId TileKind) -> m ()
f [(Point, ContentId TileKind)]
ts

updSpotEntry :: MonadStateWrite m => LevelId -> [(Point, PK.PlaceEntry)] -> m ()
updSpotEntry :: LevelId -> [(Point, PlaceEntry)] -> m ()
updSpotEntry LevelId
lid [(Point, PlaceEntry)]
ts = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Point, PlaceEntry)] -> Bool
forall a. [a] -> Bool
null [(Point, PlaceEntry)]
ts) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  let alt :: PlaceEntry -> Maybe PlaceEntry -> Maybe PlaceEntry
alt PlaceEntry
en Maybe PlaceEntry
Nothing = PlaceEntry -> Maybe PlaceEntry
forall a. a -> Maybe a
Just PlaceEntry
en
      alt PlaceEntry
en (Just PlaceEntry
oldEn) = String -> Maybe PlaceEntry
forall a. String -> a
atomicFail (String -> Maybe PlaceEntry) -> String -> Maybe PlaceEntry
forall a b. (a -> b) -> a -> b
$ String
"entry already added"
                                         String
-> (LevelId, [(Point, PlaceEntry)], PlaceEntry, PlaceEntry)
-> String
forall v. Show v => String -> v -> String
`showFailure` (LevelId
lid, [(Point, PlaceEntry)]
ts, PlaceEntry
en, PlaceEntry
oldEn)
      f :: (Point, PlaceEntry)
-> EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry
f (Point
p, PlaceEntry
en) = (Maybe PlaceEntry -> Maybe PlaceEntry)
-> Point -> EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter (PlaceEntry -> Maybe PlaceEntry -> Maybe PlaceEntry
alt PlaceEntry
en) Point
p
      upd :: EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry
upd EnumMap Point PlaceEntry
m = ((Point, PlaceEntry)
 -> EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry)
-> EnumMap Point PlaceEntry
-> [(Point, PlaceEntry)]
-> EnumMap Point PlaceEntry
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Point, PlaceEntry)
-> EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry
f EnumMap Point PlaceEntry
m [(Point, PlaceEntry)]
ts
  LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ (EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry)
-> Level -> Level
updateEntry EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry
upd

updLoseEntry :: MonadStateWrite m => LevelId -> [(Point, PK.PlaceEntry)] -> m ()
updLoseEntry :: LevelId -> [(Point, PlaceEntry)] -> m ()
updLoseEntry LevelId
lid [(Point, PlaceEntry)]
ts = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Point, PlaceEntry)] -> Bool
forall a. [a] -> Bool
null [(Point, PlaceEntry)]
ts) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  let alt :: PlaceEntry -> Maybe PlaceEntry -> Maybe PlaceEntry
alt PlaceEntry
en Maybe PlaceEntry
Nothing = String -> Maybe PlaceEntry
forall a. HasCallStack => String -> a
error (String -> Maybe PlaceEntry) -> String -> Maybe PlaceEntry
forall a b. (a -> b) -> a -> b
$ String
"entry already removed"
                               String -> (LevelId, [(Point, PlaceEntry)], PlaceEntry) -> String
forall v. Show v => String -> v -> String
`showFailure` (LevelId
lid, [(Point, PlaceEntry)]
ts, PlaceEntry
en)
      alt PlaceEntry
en (Just PlaceEntry
oldEn) =
        Bool -> Maybe PlaceEntry -> Maybe PlaceEntry
forall a. HasCallStack => Bool -> a -> a
assert (PlaceEntry
en PlaceEntry -> PlaceEntry -> Bool
forall a. Eq a => a -> a -> Bool
== PlaceEntry
oldEn Bool
-> (String,
    (LevelId, [(Point, PlaceEntry)], PlaceEntry, PlaceEntry))
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"unexpected lost entry"
                            String
-> (LevelId, [(Point, PlaceEntry)], PlaceEntry, PlaceEntry)
-> (String,
    (LevelId, [(Point, PlaceEntry)], PlaceEntry, PlaceEntry))
forall v. String -> v -> (String, v)
`swith` (LevelId
lid, [(Point, PlaceEntry)]
ts, PlaceEntry
en, PlaceEntry
oldEn)) Maybe PlaceEntry
forall a. Maybe a
Nothing
      f :: (Point, PlaceEntry)
-> EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry
f (Point
p, PlaceEntry
en) = (Maybe PlaceEntry -> Maybe PlaceEntry)
-> Point -> EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter (PlaceEntry -> Maybe PlaceEntry -> Maybe PlaceEntry
alt PlaceEntry
en) Point
p
      upd :: EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry
upd EnumMap Point PlaceEntry
m = ((Point, PlaceEntry)
 -> EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry)
-> EnumMap Point PlaceEntry
-> [(Point, PlaceEntry)]
-> EnumMap Point PlaceEntry
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Point, PlaceEntry)
-> EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry
f EnumMap Point PlaceEntry
m [(Point, PlaceEntry)]
ts
  LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ (EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry)
-> Level -> Level
updateEntry EnumMap Point PlaceEntry -> EnumMap Point PlaceEntry
upd

updAlterSmell :: MonadStateWrite m => LevelId -> Point -> Time -> Time -> m ()
updAlterSmell :: LevelId -> Point -> Time -> Time -> m ()
updAlterSmell LevelId
lid Point
p Time
fromSm' Time
toSm' = do
  let fromSm :: Maybe Time
fromSm = if Time
fromSm' Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
timeZero then Maybe Time
forall a. Maybe a
Nothing else Time -> Maybe Time
forall a. a -> Maybe a
Just Time
fromSm'
      toSm :: Maybe Time
toSm = if Time
toSm' Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
timeZero then Maybe Time
forall a. Maybe a
Nothing else Time -> Maybe Time
forall a. a -> Maybe a
Just Time
toSm'
      alt :: Maybe Time -> Maybe Time
alt Maybe Time
sm = Bool -> Maybe Time -> Maybe Time
forall a. HasCallStack => Bool -> a -> a
assert (Maybe Time
sm Maybe Time -> Maybe Time -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Time
fromSm Bool
-> (String, (LevelId, Point, Maybe Time, Maybe Time, Maybe Time))
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"unexpected tile smell"
                                    String
-> (LevelId, Point, Maybe Time, Maybe Time, Maybe Time)
-> (String, (LevelId, Point, Maybe Time, Maybe Time, Maybe Time))
forall v. String -> v -> (String, v)
`swith` (LevelId
lid, Point
p, Maybe Time
fromSm, Maybe Time
toSm, Maybe Time
sm)) Maybe Time
toSm
  LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ (SmellMap -> SmellMap) -> Level -> Level
updateSmell ((SmellMap -> SmellMap) -> Level -> Level)
-> (SmellMap -> SmellMap) -> Level -> Level
forall a b. (a -> b) -> a -> b
$ (Maybe Time -> Maybe Time) -> Point -> SmellMap -> SmellMap
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe Time -> Maybe Time
alt Point
p

updSpotSmell :: MonadStateWrite m => LevelId -> [(Point, Time)] -> m ()
updSpotSmell :: LevelId -> [(Point, Time)] -> m ()
updSpotSmell LevelId
lid [(Point, Time)]
sms = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Point, Time)] -> Bool
forall a. [a] -> Bool
null [(Point, Time)]
sms) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  let alt :: Time -> Maybe Time -> Maybe Time
alt Time
sm Maybe Time
Nothing = Time -> Maybe Time
forall a. a -> Maybe a
Just Time
sm
      alt Time
sm (Just Time
oldSm) = String -> Maybe Time
forall a. HasCallStack => String -> a
error (String -> Maybe Time) -> String -> Maybe Time
forall a b. (a -> b) -> a -> b
$ String
"smell already added"
                                    String -> (LevelId, [(Point, Time)], Time, Time) -> String
forall v. Show v => String -> v -> String
`showFailure` (LevelId
lid, [(Point, Time)]
sms, Time
sm, Time
oldSm)
      f :: (Point, Time) -> SmellMap -> SmellMap
f (Point
p, Time
sm) = (Maybe Time -> Maybe Time) -> Point -> SmellMap -> SmellMap
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter (Time -> Maybe Time -> Maybe Time
alt Time
sm) Point
p
      upd :: SmellMap -> SmellMap
upd SmellMap
m = ((Point, Time) -> SmellMap -> SmellMap)
-> SmellMap -> [(Point, Time)] -> SmellMap
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Point, Time) -> SmellMap -> SmellMap
f SmellMap
m [(Point, Time)]
sms
  LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ (SmellMap -> SmellMap) -> Level -> Level
updateSmell SmellMap -> SmellMap
upd

updLoseSmell :: MonadStateWrite m => LevelId -> [(Point, Time)] -> m ()
updLoseSmell :: LevelId -> [(Point, Time)] -> m ()
updLoseSmell LevelId
lid [(Point, Time)]
sms = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(Point, Time)] -> Bool
forall a. [a] -> Bool
null [(Point, Time)]
sms) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  let alt :: Time -> Maybe Time -> Maybe Time
alt Time
sm Maybe Time
Nothing = String -> Maybe Time
forall a. HasCallStack => String -> a
error (String -> Maybe Time) -> String -> Maybe Time
forall a b. (a -> b) -> a -> b
$ String
"smell already removed"
                               String -> (LevelId, [(Point, Time)], Time) -> String
forall v. Show v => String -> v -> String
`showFailure` (LevelId
lid, [(Point, Time)]
sms, Time
sm)
      alt Time
sm (Just Time
oldSm) =
        Bool -> Maybe Time -> Maybe Time
forall a. HasCallStack => Bool -> a -> a
assert (Time
sm Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
oldSm Bool -> (String, (LevelId, [(Point, Time)], Time, Time)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"unexpected lost smell"
                            String
-> (LevelId, [(Point, Time)], Time, Time)
-> (String, (LevelId, [(Point, Time)], Time, Time))
forall v. String -> v -> (String, v)
`swith` (LevelId
lid, [(Point, Time)]
sms, Time
sm, Time
oldSm)) Maybe Time
forall a. Maybe a
Nothing
      f :: (Point, Time) -> SmellMap -> SmellMap
f (Point
p, Time
sm) = (Maybe Time -> Maybe Time) -> Point -> SmellMap -> SmellMap
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter (Time -> Maybe Time -> Maybe Time
alt Time
sm) Point
p
      upd :: SmellMap -> SmellMap
upd SmellMap
m = ((Point, Time) -> SmellMap -> SmellMap)
-> SmellMap -> [(Point, Time)] -> SmellMap
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Point, Time) -> SmellMap -> SmellMap
f SmellMap
m [(Point, Time)]
sms
  LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ (SmellMap -> SmellMap) -> Level -> Level
updateSmell SmellMap -> SmellMap
upd

updTimeItem :: MonadStateWrite m
            => ItemId -> Container -> ItemTimers -> ItemTimers
            -> m ()
updTimeItem :: ItemId -> Container -> ItemTimers -> ItemTimers -> m ()
updTimeItem ItemId
iid Container
c ItemTimers
fromIt ItemTimers
toIt = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (ItemTimers
fromIt ItemTimers -> ItemTimers -> Bool
forall a. Eq a => a -> a -> Bool
/= ItemTimers
toIt) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  ItemBag
bag <- (State -> ItemBag) -> m ItemBag
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ItemBag) -> m ItemBag)
-> (State -> ItemBag) -> m ItemBag
forall a b. (a -> b) -> a -> b
$ Container -> State -> ItemBag
getContainerBag Container
c
  case ItemId
iid ItemId -> ItemBag -> Maybe ItemQuant
forall k a. Enum k => k -> EnumMap k a -> Maybe a
`EM.lookup` ItemBag
bag of
    Just (Int
k, ItemTimers
it) -> do
      let !_A1 :: ()
_A1 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (ItemTimers
fromIt ItemTimers -> ItemTimers -> Bool
forall a. Eq a => a -> a -> Bool
== ItemTimers
it Bool
-> (Int, ItemTimers, ItemId, Container, ItemTimers, ItemTimers)
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (Int
k, ItemTimers
it, ItemId
iid, Container
c, ItemTimers
fromIt, ItemTimers
toIt)) ()
          !_A2 :: ()
_A2 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (ItemTimers -> Int
forall a. [a] -> Int
length ItemTimers
toIt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
k Bool -> (Int, ItemTimers, ItemId, Container, ItemTimers) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (Int
k, ItemTimers
toIt, ItemId
iid, Container
c, ItemTimers
fromIt)) ()
      ItemId -> ItemQuant -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> Container -> m ()
deleteItemContainer ItemId
iid (Int
k, ItemTimers
fromIt) Container
c
      ItemId -> ItemQuant -> Container -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> ItemQuant -> Container -> m ()
insertItemContainer ItemId
iid (Int
k, ItemTimers
toIt) Container
c
    Maybe ItemQuant
Nothing -> String -> m ()
forall a. HasCallStack => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"" String
-> (ItemBag, ItemId, Container, ItemTimers, ItemTimers) -> String
forall v. Show v => String -> v -> String
`showFailure` (ItemBag
bag, ItemId
iid, Container
c, ItemTimers
fromIt, ItemTimers
toIt)

updAgeGame :: MonadStateWrite m => ES.EnumSet LevelId -> m ()
updAgeGame :: EnumSet LevelId -> m ()
updAgeGame EnumSet LevelId
lids = do
  (State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (Time -> Time) -> State -> State
updateTime ((Time -> Time) -> State -> State)
-> (Time -> Time) -> State -> State
forall a b. (a -> b) -> a -> b
$ (Time -> Delta Time -> Time) -> Delta Time -> Time -> Time
forall a b c. (a -> b -> c) -> b -> a -> c
flip Time -> Delta Time -> Time
timeShift (Time -> Delta Time
forall a. a -> Delta a
Delta Time
timeClip)
  (LevelId -> m ()) -> [LevelId] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (Delta Time -> LevelId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
Delta Time -> LevelId -> m ()
ageLevel (Time -> Delta Time
forall a. a -> Delta a
Delta Time
timeClip)) ([LevelId] -> m ()) -> [LevelId] -> m ()
forall a b. (a -> b) -> a -> b
$ EnumSet LevelId -> [LevelId]
forall k. Enum k => EnumSet k -> [k]
ES.elems EnumSet LevelId
lids

updUnAgeGame :: MonadStateWrite m => ES.EnumSet LevelId -> m ()
updUnAgeGame :: EnumSet LevelId -> m ()
updUnAgeGame EnumSet LevelId
lids = do
  (State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (Time -> Time) -> State -> State
updateTime ((Time -> Time) -> State -> State)
-> (Time -> Time) -> State -> State
forall a b. (a -> b) -> a -> b
$ (Time -> Delta Time -> Time) -> Delta Time -> Time -> Time
forall a b c. (a -> b -> c) -> b -> a -> c
flip Time -> Delta Time -> Time
timeShift (Delta Time -> Delta Time
timeDeltaReverse (Delta Time -> Delta Time) -> Delta Time -> Delta Time
forall a b. (a -> b) -> a -> b
$ Time -> Delta Time
forall a. a -> Delta a
Delta Time
timeClip)
  (LevelId -> m ()) -> [LevelId] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (Delta Time -> LevelId -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
Delta Time -> LevelId -> m ()
ageLevel (Delta Time -> Delta Time
timeDeltaReverse (Delta Time -> Delta Time) -> Delta Time -> Delta Time
forall a b. (a -> b) -> a -> b
$ Time -> Delta Time
forall a. a -> Delta a
Delta Time
timeClip)) ([LevelId] -> m ()) -> [LevelId] -> m ()
forall a b. (a -> b) -> a -> b
$ EnumSet LevelId -> [LevelId]
forall k. Enum k => EnumSet k -> [k]
ES.elems EnumSet LevelId
lids

ageLevel :: MonadStateWrite m => Delta Time -> LevelId -> m ()
ageLevel :: Delta Time -> LevelId -> m ()
ageLevel Delta Time
delta LevelId
lid =
  LevelId -> (Level -> Level) -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
LevelId -> (Level -> Level) -> m ()
updateLevel LevelId
lid ((Level -> Level) -> m ()) -> (Level -> Level) -> m ()
forall a b. (a -> b) -> a -> b
$ \Level
lvl -> Level
lvl {ltime :: Time
ltime = Time -> Delta Time -> Time
timeShift (Level -> Time
ltime Level
lvl) Delta Time
delta}

updDiscover :: MonadStateWrite m
            => Container -> ItemId -> ContentId ItemKind -> IA.AspectRecord
            -> m ()
updDiscover :: Container -> ItemId -> ContentId ItemKind -> AspectRecord -> m ()
updDiscover Container
_c ItemId
iid ContentId ItemKind
ik AspectRecord
arItem = do
  ItemDict
itemD <- (State -> ItemDict) -> m ItemDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> ItemDict
sitemD
  COps{ItemSpeedup
coItemSpeedup :: COps -> ItemSpeedup
coItemSpeedup :: ItemSpeedup
coItemSpeedup} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  let kmIsConst :: Bool
kmIsConst = KindMean -> Bool
IA.kmConst (KindMean -> Bool) -> KindMean -> Bool
forall a b. (a -> b) -> a -> b
$ ContentId ItemKind -> ItemSpeedup -> KindMean
getKindMean ContentId ItemKind
ik ItemSpeedup
coItemSpeedup
  DiscoveryKind
discoKind <- (State -> DiscoveryKind) -> m DiscoveryKind
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> DiscoveryKind
sdiscoKind
  let discoverAtMostAspect :: m ()
discoverAtMostAspect = do
        DiscoveryAspect
discoAspect <- (State -> DiscoveryAspect) -> m DiscoveryAspect
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> DiscoveryAspect
sdiscoAspect
        if Bool
kmIsConst Bool -> Bool -> Bool
|| ItemId
iid ItemId -> DiscoveryAspect -> Bool
forall k a. Enum k => k -> EnumMap k a -> Bool
`EM.member` DiscoveryAspect
discoAspect
        then String -> m ()
forall a. String -> a
atomicFail String
"item already fully discovered"
        else ItemId -> AspectRecord -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> AspectRecord -> m ()
discoverAspect ItemId
iid AspectRecord
arItem
  case ItemId -> ItemDict -> Maybe Item
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup ItemId
iid ItemDict
itemD of
    Maybe Item
Nothing -> String -> m ()
forall a. String -> a
atomicFail String
"discovered item unheard of"
    Just Item
item -> case Item -> ItemIdentity
jkind Item
item of
      IdentityObvious ContentId ItemKind
_ -> m ()
discoverAtMostAspect
      IdentityCovered ItemKindIx
ix ContentId ItemKind
_ik -> case ItemKindIx -> DiscoveryKind -> Maybe (ContentId ItemKind)
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup ItemKindIx
ix DiscoveryKind
discoKind of
        Just{} -> m ()
discoverAtMostAspect
        Maybe (ContentId ItemKind)
Nothing -> do
          ItemKindIx -> ContentId ItemKind -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemKindIx -> ContentId ItemKind -> m ()
discoverKind ItemKindIx
ix ContentId ItemKind
ik
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
kmIsConst (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ ItemId -> AspectRecord -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> AspectRecord -> m ()
discoverAspect ItemId
iid AspectRecord
arItem
  m ()
forall (m :: * -> *). MonadStateWrite m => m ()
resetActorMaxSkills

updCover :: Container -> ItemId -> ContentId ItemKind -> IA.AspectRecord -> m ()
updCover :: Container -> ItemId -> ContentId ItemKind -> AspectRecord -> m ()
updCover Container
_c ItemId
_iid ContentId ItemKind
_ik AspectRecord
_arItem = m ()
forall a. HasCallStack => a
undefined

updDiscoverKind :: MonadStateWrite m
                => Container -> ItemKindIx -> ContentId ItemKind -> m ()
updDiscoverKind :: Container -> ItemKindIx -> ContentId ItemKind -> m ()
updDiscoverKind Container
_c ItemKindIx
ix ContentId ItemKind
kmKind = do
  DiscoveryKind
discoKind <- (State -> DiscoveryKind) -> m DiscoveryKind
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> DiscoveryKind
sdiscoKind
  if ItemKindIx
ix ItemKindIx -> DiscoveryKind -> Bool
forall k a. Enum k => k -> EnumMap k a -> Bool
`EM.member` DiscoveryKind
discoKind
  then String -> m ()
forall a. String -> a
atomicFail String
"item kind already discovered"
  else do
    ItemKindIx -> ContentId ItemKind -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemKindIx -> ContentId ItemKind -> m ()
discoverKind ItemKindIx
ix ContentId ItemKind
kmKind
    m ()
forall (m :: * -> *). MonadStateWrite m => m ()
resetActorMaxSkills

discoverKind :: MonadStateWrite m => ItemKindIx -> ContentId ItemKind -> m ()
discoverKind :: ItemKindIx -> ContentId ItemKind -> m ()
discoverKind ItemKindIx
ix ContentId ItemKind
kindId = do
  let f :: Maybe (ContentId ItemKind) -> Maybe (ContentId ItemKind)
f Maybe (ContentId ItemKind)
Nothing = ContentId ItemKind -> Maybe (ContentId ItemKind)
forall a. a -> Maybe a
Just ContentId ItemKind
kindId
      f Just{} = String -> Maybe (ContentId ItemKind)
forall a. HasCallStack => String -> a
error (String -> Maybe (ContentId ItemKind))
-> String -> Maybe (ContentId ItemKind)
forall a b. (a -> b) -> a -> b
$ String
"already discovered" String -> (ItemKindIx, ContentId ItemKind) -> String
forall v. Show v => String -> v -> String
`showFailure` (ItemKindIx
ix, ContentId ItemKind
kindId)
  (State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (DiscoveryKind -> DiscoveryKind) -> State -> State
updateDiscoKind ((DiscoveryKind -> DiscoveryKind) -> State -> State)
-> (DiscoveryKind -> DiscoveryKind) -> State -> State
forall a b. (a -> b) -> a -> b
$ \DiscoveryKind
discoKind1 ->
    (Maybe (ContentId ItemKind) -> Maybe (ContentId ItemKind))
-> ItemKindIx -> DiscoveryKind -> DiscoveryKind
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe (ContentId ItemKind) -> Maybe (ContentId ItemKind)
f ItemKindIx
ix DiscoveryKind
discoKind1

updCoverKind :: Container -> ItemKindIx -> ContentId ItemKind -> m ()
updCoverKind :: Container -> ItemKindIx -> ContentId ItemKind -> m ()
updCoverKind Container
_c ItemKindIx
_ix ContentId ItemKind
_ik = m ()
forall a. HasCallStack => a
undefined

updDiscoverAspect :: MonadStateWrite m
                  => Container -> ItemId -> IA.AspectRecord -> m ()
updDiscoverAspect :: Container -> ItemId -> AspectRecord -> m ()
updDiscoverAspect Container
_c ItemId
iid AspectRecord
arItem = do
  COps{ItemSpeedup
coItemSpeedup :: ItemSpeedup
coItemSpeedup :: COps -> ItemSpeedup
coItemSpeedup} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  ItemDict
itemD <- (State -> ItemDict) -> m ItemDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> ItemDict
sitemD
  case ItemId -> ItemDict -> Maybe Item
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup ItemId
iid ItemDict
itemD of
    Maybe Item
Nothing -> String -> m ()
forall a. String -> a
atomicFail String
"discovered item unheard of"
    Just Item
item -> do
      -- Here the kind information is exact, hence @getItemKindIdServer@.
      ContentId ItemKind
kindId <- (State -> ContentId ItemKind) -> m (ContentId ItemKind)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ContentId ItemKind) -> m (ContentId ItemKind))
-> (State -> ContentId ItemKind) -> m (ContentId ItemKind)
forall a b. (a -> b) -> a -> b
$ Item -> State -> ContentId ItemKind
getItemKindIdServer Item
item
      DiscoveryAspect
discoAspect <- (State -> DiscoveryAspect) -> m DiscoveryAspect
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> DiscoveryAspect
sdiscoAspect
      let kmIsConst :: Bool
kmIsConst = KindMean -> Bool
IA.kmConst (KindMean -> Bool) -> KindMean -> Bool
forall a b. (a -> b) -> a -> b
$ ContentId ItemKind -> ItemSpeedup -> KindMean
getKindMean ContentId ItemKind
kindId ItemSpeedup
coItemSpeedup
      if Bool
kmIsConst Bool -> Bool -> Bool
|| ItemId
iid ItemId -> DiscoveryAspect -> Bool
forall k a. Enum k => k -> EnumMap k a -> Bool
`EM.member` DiscoveryAspect
discoAspect
      then String -> m ()
forall a. String -> a
atomicFail String
"item arItem already discovered"
      else do
        ItemId -> AspectRecord -> m ()
forall (m :: * -> *).
MonadStateWrite m =>
ItemId -> AspectRecord -> m ()
discoverAspect ItemId
iid AspectRecord
arItem
        m ()
forall (m :: * -> *). MonadStateWrite m => m ()
resetActorMaxSkills

discoverAspect :: MonadStateWrite m => ItemId -> IA.AspectRecord -> m ()
discoverAspect :: ItemId -> AspectRecord -> m ()
discoverAspect ItemId
iid AspectRecord
arItem = do
  let f :: Maybe AspectRecord -> Maybe AspectRecord
f Maybe AspectRecord
Nothing = AspectRecord -> Maybe AspectRecord
forall a. a -> Maybe a
Just AspectRecord
arItem
      f Just{} = String -> Maybe AspectRecord
forall a. HasCallStack => String -> a
error (String -> Maybe AspectRecord) -> String -> Maybe AspectRecord
forall a b. (a -> b) -> a -> b
$ String
"already discovered" String -> (ItemId, AspectRecord) -> String
forall v. Show v => String -> v -> String
`showFailure` (ItemId
iid, AspectRecord
arItem)
  -- At this point we know the item is not @kmConst@.
  (State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (DiscoveryAspect -> DiscoveryAspect) -> State -> State
updateDiscoAspect ((DiscoveryAspect -> DiscoveryAspect) -> State -> State)
-> (DiscoveryAspect -> DiscoveryAspect) -> State -> State
forall a b. (a -> b) -> a -> b
$ \DiscoveryAspect
discoAspect1 ->
    (Maybe AspectRecord -> Maybe AspectRecord)
-> ItemId -> DiscoveryAspect -> DiscoveryAspect
forall k a.
Enum k =>
(Maybe a -> Maybe a) -> k -> EnumMap k a -> EnumMap k a
EM.alter Maybe AspectRecord -> Maybe AspectRecord
f ItemId
iid DiscoveryAspect
discoAspect1

updCoverAspect :: Container -> ItemId -> IA.AspectRecord -> m ()
updCoverAspect :: Container -> ItemId -> AspectRecord -> m ()
updCoverAspect Container
_c ItemId
_iid AspectRecord
_arItem = m ()
forall a. HasCallStack => a
undefined

updDiscoverServer :: MonadStateWrite m => ItemId -> IA.AspectRecord -> m ()
updDiscoverServer :: ItemId -> AspectRecord -> m ()
updDiscoverServer ItemId
iid AspectRecord
arItem =
  (State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (DiscoveryAspect -> DiscoveryAspect) -> State -> State
updateDiscoAspect ((DiscoveryAspect -> DiscoveryAspect) -> State -> State)
-> (DiscoveryAspect -> DiscoveryAspect) -> State -> State
forall a b. (a -> b) -> a -> b
$ \DiscoveryAspect
discoAspect1 ->
    ItemId -> AspectRecord -> DiscoveryAspect -> DiscoveryAspect
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert ItemId
iid AspectRecord
arItem DiscoveryAspect
discoAspect1

updCoverServer :: MonadStateWrite m => ItemId -> IA.AspectRecord -> m ()
updCoverServer :: ItemId -> AspectRecord -> m ()
updCoverServer ItemId
iid AspectRecord
arItem =
  (State -> State) -> m ()
forall (m :: * -> *). MonadStateWrite m => (State -> State) -> m ()
modifyState ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ (DiscoveryAspect -> DiscoveryAspect) -> State -> State
updateDiscoAspect ((DiscoveryAspect -> DiscoveryAspect) -> State -> State)
-> (DiscoveryAspect -> DiscoveryAspect) -> State -> State
forall a b. (a -> b) -> a -> b
$ \DiscoveryAspect
discoAspect1 ->
    Bool -> DiscoveryAspect -> DiscoveryAspect
forall a. HasCallStack => Bool -> a -> a
assert (DiscoveryAspect
discoAspect1 DiscoveryAspect -> ItemId -> AspectRecord
forall k a. Enum k => EnumMap k a -> k -> a
EM.! ItemId
iid AspectRecord -> AspectRecord -> Bool
forall a. Eq a => a -> a -> Bool
== AspectRecord
arItem)
    (DiscoveryAspect -> DiscoveryAspect)
-> DiscoveryAspect -> DiscoveryAspect
forall a b. (a -> b) -> a -> b
$ ItemId -> DiscoveryAspect -> DiscoveryAspect
forall k a. Enum k => k -> EnumMap k a -> EnumMap k a
EM.delete ItemId
iid DiscoveryAspect
discoAspect1

-- This is ever run only on clients.
updRestart :: MonadStateWrite m => State -> m ()
updRestart :: State -> m ()
updRestart = State -> m ()
forall (m :: * -> *). MonadStateWrite m => State -> m ()
putState

-- This is ever run only on the server.
updRestartServer :: MonadStateWrite m => State -> m ()
updRestartServer :: State -> m ()
updRestartServer = State -> m ()
forall (m :: * -> *). MonadStateWrite m => State -> m ()
putState

-- This is ever run only on the server.
updResumeServer :: MonadStateWrite m => State -> m ()
updResumeServer :: State -> m ()
updResumeServer = State -> m ()
forall (m :: * -> *). MonadStateWrite m => State -> m ()
putState