{-# 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 cmd = case cmd of
  UpdRegisterItems ais -> updRegisterItems ais
  UpdCreateActor aid body ais -> updCreateActor aid body ais
  UpdDestroyActor aid body ais -> updDestroyActor aid body ais
  UpdCreateItem _ iid item kit c -> updCreateItem iid item kit c
  UpdDestroyItem _ iid item kit c -> updDestroyItem iid item kit c
  UpdSpotActor aid body -> updSpotActor aid body
  UpdLoseActor aid body -> updLoseActor aid body
  UpdSpotItem _ iid kit c -> updSpotItem iid kit c
  UpdLoseItem _ iid kit c -> updLoseItem iid kit c
  UpdSpotItemBag _ c bag -> updSpotItemBag c bag
  UpdLoseItemBag _ c bag -> updLoseItemBag c bag
  UpdMoveActor aid fromP toP -> updMoveActor aid fromP toP
  UpdWaitActor aid fromWS toWS -> updWaitActor aid fromWS toWS
  UpdDisplaceActor source target -> updDisplaceActor source target
  UpdMoveItem iid k aid c1 c2 -> updMoveItem iid k aid c1 c2
  UpdRefillHP aid n -> updRefillHP aid n
  UpdRefillCalm aid n -> updRefillCalm aid n
  UpdTrajectory aid fromT toT -> updTrajectory aid fromT toT
  UpdQuitFaction fid fromSt toSt _ -> updQuitFaction fid fromSt toSt
  UpdSpotStashFaction _ fid lid pos -> updSpotStashFaction fid lid pos
  UpdLoseStashFaction _ fid lid pos -> updLoseStashFaction fid lid pos
  UpdLeadFaction fid source target -> updLeadFaction fid source target
  UpdDiplFaction fid1 fid2 fromDipl toDipl ->
    updDiplFaction fid1 fid2 fromDipl toDipl
  UpdDoctrineFaction fid toT fromT -> updDoctrineFaction fid toT fromT
  UpdAutoFaction fid st -> updAutoFaction fid st
  UpdRecordKill aid ikind k -> updRecordKill aid ikind k
  UpdAlterTile lid p fromTile toTile -> updAlterTile lid p fromTile toTile
  UpdAlterExplorable lid delta -> updAlterExplorable lid delta
  UpdAlterGold delta -> updAlterGold delta
  UpdSearchTile aid p toTile -> updSearchTile aid p toTile
  UpdHideTile{} -> undefined
  UpdSpotTile lid ts -> updSpotTile lid ts
  UpdLoseTile lid ts -> updLoseTile lid ts
  UpdSpotEntry lid ts -> updSpotEntry lid ts
  UpdLoseEntry lid ts -> updLoseEntry lid ts
  UpdAlterSmell lid p fromSm toSm -> updAlterSmell lid p fromSm toSm
  UpdSpotSmell lid sms -> updSpotSmell lid sms
  UpdLoseSmell lid sms -> updLoseSmell lid sms
  UpdTimeItem iid c fromIt toIt -> updTimeItem iid c fromIt toIt
  UpdAgeGame lids -> updAgeGame lids
  UpdUnAgeGame lids -> updUnAgeGame lids
  UpdDiscover c iid ik arItem -> updDiscover c iid ik arItem
  UpdCover c iid ik arItem -> updCover c iid ik arItem
  UpdDiscoverKind c ix ik -> updDiscoverKind c ix ik
  UpdCoverKind c ix ik -> updCoverKind c ix ik
  UpdDiscoverAspect c iid arItem -> updDiscoverAspect c iid arItem
  UpdCoverAspect c iid arItem -> updCoverAspect c iid arItem
  UpdDiscoverServer iid arItem -> updDiscoverServer iid arItem
  UpdCoverServer iid arItem -> updCoverServer iid arItem
  UpdPerception _ outPer inPer ->
    assert (not (nullPer outPer && nullPer inPer)) (return ())
  UpdRestart _ _ s _ _ _ -> updRestart s
  UpdRestartServer s -> updRestartServer s
  UpdResume{} -> return ()
  UpdResumeServer s -> updResumeServer s
  UpdKillExit{} -> return ()
  UpdWriteSave -> return ()
  UpdHearFid{} -> return ()
  UpdMuteMessages{} -> 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 ais = do
  let h item1 item2 =
        assert (itemsMatch item1 item2
                `blame` "inconsistent added items"
                `swith` (item1, item2, ais))
               item2 -- keep the first found level
  forM_ ais $ \(iid, item) -> do
    let f = case jkind item of
          IdentityObvious _ -> id
          IdentityCovered ix _ ->
            updateItemIxMap $ EM.insertWith ES.union ix (ES.singleton iid)
    modifyState $ f . updateItemD (EM.insertWith h iid 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 aid body ais = do
  updRegisterItems ais
  updSpotActor aid 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 aid body ais = do
  -- Assert that actor's items belong to @sitemD@. Do not remove those
  -- that do not appear anywhere else, for simplicity and speed.
  itemD <- getsState sitemD
  let match (iid, item) = itemsMatch (itemD EM.! iid) item
  let !_A = assert (allB match ais `blame` "destroyed actor items not found"
                    `swith` (aid, body, ais, itemD)) ()
  updLoseActor aid 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 iid item kit c = do
  updRegisterItems [(iid, item)]
  updSpotItem iid kit c

-- Destroy some copies (possibly not all) of an item.
updDestroyItem :: MonadStateWrite m
               => ItemId -> Item -> ItemQuant -> Container -> m ()
updDestroyItem iid item kit@(k, _) c = assert (k > 0) $ 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@.
  itemD <- getsState sitemD
  let !_A = assert ((case iid `EM.lookup` itemD of
                        Nothing -> False
                        Just item0 -> itemsMatch item0 item)
                    `blame` "item already removed"
                    `swith` (iid, item, itemD)) ()
  updLoseItem iid kit c

updSpotActor :: MonadStateWrite m => ActorId -> Actor -> m ()
updSpotActor aid 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 Nothing = Just body
      f (Just b) = assert (body == b `blame` (aid, body, b)) $
        atomicFail $ "actor already added" `showFailure` (aid, body, b)
  modifyState $ updateActorD $ EM.alter f aid
  let g Nothing = Just [aid]
      g (Just l) =
#ifdef WITH_EXPENSIVE_ASSERTIONS
        -- Not so much expensive, as doubly impossible.
        assert (aid `notElem` l `blame` "actor already added"
                                `swith` (aid, body, l))
#endif
        (Just $ aid : l)
  let h Nothing = Just aid
      h (Just aid2) = error $ "an actor already present there"
                              `showFailure` (aid, body, aid2)
  updateLevel (blid body) $ if bproj body
                            then updateProjMap (EM.alter g (bpos body))
                            else updateBigMap (EM.alter h (bpos body))
  actorMaxSk <- getsState $ maxSkillsFromActor body
  modifyState $ updateActorMaxSkills $ EM.insert aid actorMaxSk

updLoseActor :: MonadStateWrite m => ActorId -> Actor ->  m ()
updLoseActor aid body = do
  -- Remove actor from @sactorD@.
  let f Nothing = error $ "actor already removed" `showFailure` (aid, body)
      f (Just b) = assert (b == body `blame` "inconsistent destroyed actor body"
                                     `swith` (aid, body, b)) Nothing
  modifyState $ updateActorD $ EM.alter f aid
  let g Nothing = error $ "actor already removed" `showFailure` (aid, body)
      g (Just l) =
#ifdef WITH_EXPENSIVE_ASSERTIONS
        -- Not so much expensive, as doubly impossible.
        assert (aid `elem` l `blame` "actor already removed"
                             `swith` (aid, body, l))
#endif
        (let l2 = delete aid l
         in if null l2 then Nothing else Just l2)
  let h Nothing = error $ "actor already removed" `showFailure` (aid, body)
      h (Just _aid2) =
#ifdef WITH_EXPENSIVE_ASSERTIONS
        -- Not so much expensive, as doubly impossible.
        assert (aid == _aid2 `blame` "actor already removed"
                             `swith` (aid, body, _aid2))
#endif
        Nothing
  updateLevel (blid body) $ if bproj body
                            then updateProjMap (EM.alter g (bpos body))
                            else updateBigMap (EM.alter h (bpos body))
  modifyState $ updateActorMaxSkills $ EM.delete aid

updSpotItem :: MonadStateWrite m => ItemId -> ItemQuant -> Container -> m ()
updSpotItem iid kit@(k, _) c = do
  item <- getsState $ getItemBody iid
  when (k > 0) $ do
    insertItemContainer iid kit c
    case c of
      CActor aid store -> when (store `elem` [CEqp, COrgan])
                          $ addItemToActorMaxSkills iid item k aid
      _ -> return ()

updLoseItem :: MonadStateWrite m => ItemId -> ItemQuant -> Container -> m ()
updLoseItem iid kit@(k, _) c = assert (k > 0) $ do
  item <- getsState $ getItemBody iid
  deleteItemContainer iid kit c
  case c of
    CActor aid store -> when (store `elem` [CEqp, COrgan])
                        $ addItemToActorMaxSkills iid item (-k) aid
    _ -> return ()

updSpotItemBag :: MonadStateWrite m => Container -> ItemBag -> m ()
updSpotItemBag c bag =
  -- The case of empty bag is for a hack to help identifying sample items.
  unless (EM.null bag) $ do
    insertBagContainer bag c
    case c of
      CActor aid store ->
        when (store `elem` [CEqp, COrgan]) $ do
          itemD <- getsState sitemD
          let ais = map (\iid -> (iid, itemD EM.! iid)) $ EM.keys bag
          forM_ ais $ \(iid, item) ->
            addItemToActorMaxSkills iid item (fst $ bag EM.! iid) aid
      _ -> return ()

updLoseItemBag :: MonadStateWrite m => Container -> ItemBag -> m ()
updLoseItemBag c bag = assert (EM.size bag > 0) $ do
  deleteBagContainer bag 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 c of
    CActor aid store ->
      when (store `elem` [CEqp, COrgan]) $ do
        itemD <- getsState sitemD
        let ais = map (\iid -> (iid, itemD EM.! iid)) $ EM.keys bag
        forM_ ais $ \(iid, item) ->
          addItemToActorMaxSkills iid item (- (fst $ bag EM.! iid)) aid
    _ -> return ()

updMoveActor :: MonadStateWrite m => ActorId -> Point -> Point -> m ()
updMoveActor aid fromP toP = assert (fromP /= toP) $ do
  body <- getsState $ getActorBody aid
  let !_A = assert (fromP == bpos body
                    `blame` "unexpected moved actor position"
                    `swith` (aid, fromP, toP, bpos body, body)) ()
      newBody = body {bpos = toP, boldpos = Just fromP}
  updateActor aid $ const newBody
  moveActorMap aid body newBody

updWaitActor :: MonadStateWrite m
             => ActorId -> Watchfulness -> Watchfulness -> m ()
updWaitActor aid fromWS toWS = assert (fromWS /= toWS) $ do
  body <- getsState $ getActorBody aid
  let !_A = assert (fromWS == bwatch body
                    `blame` "unexpected actor wait state"
                    `swith` (aid, fromWS, bwatch body, body)) ()
  updateActor aid $ \b -> b {bwatch = toWS}

updDisplaceActor :: MonadStateWrite m => ActorId -> ActorId -> m ()
updDisplaceActor source target = assert (source /= target) $ do
  sbody <- getsState $ getActorBody source
  tbody <- getsState $ getActorBody target
  let spos = bpos sbody
      tpos = bpos tbody
      snewBody = sbody {bpos = tpos, boldpos = Just spos}
      tnewBody = tbody {bpos = spos, boldpos = Just tpos}
  updateActor source $ const snewBody
  updateActor target $ const tnewBody
  swapActorMap source sbody target tbody

updMoveItem :: MonadStateWrite m
            => ItemId -> Int -> ActorId -> CStore -> CStore
            -> m ()
updMoveItem iid k aid s1 s2 = assert (k > 0 && s1 /= s2) $ do
  b <- getsState $ getActorBody aid
  bag <- getsState $ getBodyStoreBag b s1
  case iid `EM.lookup` bag of
    Nothing -> error $ "" `showFailure` (iid, k, aid, s1, s2)
    Just (_, it) -> do
      deleteItemActor iid (k, take k it) aid s1
      insertItemActor iid (k, take k it) aid s2
  case s1 of
    CEqp -> case s2 of
      COrgan -> return ()
      _ -> do
        itemBase <- getsState $ getItemBody iid
        addItemToActorMaxSkills iid itemBase (-k) aid
    COrgan -> case s2 of
      CEqp -> return ()
      _ -> do
        itemBase <- getsState $ getItemBody iid
        addItemToActorMaxSkills iid itemBase (-k) aid
    _ ->
      when (s2 `elem` [CEqp, COrgan]) $ do
        itemBase <- getsState $ getItemBody iid
        addItemToActorMaxSkills iid itemBase k aid

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

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

updTrajectory :: MonadStateWrite m
              => ActorId
              -> Maybe ([Vector], Speed)
              -> Maybe ([Vector], Speed)
              -> m ()
updTrajectory aid fromT toT = assert (fromT /= toT) $ do
  body <- getsState $ getActorBody aid
  let !_A = assert (fromT == btrajectory body
                    `blame` "unexpected actor trajectory"
                    `swith` (aid, fromT, toT, body)) ()
  updateActor aid $ \b -> b {btrajectory = toT}

updQuitFaction :: MonadStateWrite m
               => FactionId -> Maybe Status -> Maybe Status
               -> m ()
updQuitFaction fid fromSt toSt = do
  let !_A = assert (fromSt /= toSt `blame` (fid, fromSt, toSt)) ()
  fact <- getsState $ (EM.! fid) . sfactionD
  let !_A = assert (fromSt == gquit fact
                    `blame` "unexpected actor quit status"
                    `swith` (fid, fromSt, toSt, fact)) ()
  let adj fa = fa {gquit = toSt}
  updateFaction fid adj

updSpotStashFaction :: MonadStateWrite m
                    => FactionId -> LevelId -> Point -> m ()
updSpotStashFaction fid lid pos = do
  let adj fa = fa {gstash = Just (lid, 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
  updateFaction fid adj

updLoseStashFaction :: MonadStateWrite m
                    => FactionId -> LevelId -> Point -> m ()
updLoseStashFaction fid lid pos = do
  let adj fa = assert (gstash fa == Just (lid, pos)
                       `blame` "unexpected lack of gstash"
                       `swith` (fid, lid, pos, fa))
               $ fa {gstash = Nothing}
  updateFaction fid adj

-- The previous leader is assumed to be alive.
updLeadFaction :: MonadStateWrite m
               => FactionId
               -> Maybe ActorId
               -> Maybe ActorId
               -> m ()
updLeadFaction fid source target = assert (source /= target) $ do
  fact <- getsState $ (EM.! fid) . sfactionD
  let !_A = assert (fhasPointman (gkind fact)) ()
    -- @PosNone@ ensures this
  mtb <- getsState $ \s -> flip getActorBody s <$> target
  let !_A = assert (maybe True (not . bproj) mtb
                    `blame` (fid, source, target, mtb, fact)) ()
  let !_A = assert (source == gleader fact
                    `blame` "unexpected actor leader"
                    `swith` (fid, source, target, mtb, fact)) ()
  let adj fa = fa {_gleader = target}
  updateFaction fid adj

updDiplFaction :: MonadStateWrite m
               => FactionId -> FactionId -> Diplomacy -> Diplomacy -> m ()
updDiplFaction fid1 fid2 fromDipl toDipl =
  assert (fid1 /= fid2 && fromDipl /= toDipl) $ do
    fact1 <- getsState $ (EM.! fid1) . sfactionD
    fact2 <- getsState $ (EM.! fid2) . sfactionD
    let !_A =
          assert (fromDipl == EM.findWithDefault Unknown fid2 (gdipl fact1)
                  && fromDipl == EM.findWithDefault Unknown fid1 (gdipl fact2)
                  `blame` "unexpected actor diplomacy status"
                  `swith` (fid1, fid2, fromDipl, toDipl, fact1, fact2)) ()
    let adj fid fact = fact {gdipl = EM.insert fid toDipl (gdipl fact)}
    updateFaction fid1 (adj fid2)
    updateFaction fid2 (adj fid1)

updDoctrineFaction :: MonadStateWrite m
                   => FactionId -> Ability.Doctrine -> Ability.Doctrine -> m ()
updDoctrineFaction fid toT fromT = do
  let adj fact = assert (gdoctrine fact == fromT) $ fact {gdoctrine = toT}
  updateFaction fid adj

updAutoFaction :: MonadStateWrite m => FactionId -> Bool -> m ()
updAutoFaction fid st =
  updateFaction fid (\fact ->
    assert (gunderAI fact == not st) $ fact {gunderAI = 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 aid ikind k = do
  b <- getsState $ getActorBody aid
  let !_A = assert (not (bproj b) `blame` (aid, b))
  let alterKind mn = let n = fromMaybe 0 mn + k
                     in if n == 0 then Nothing else Just n
      adjFact fact = fact {gvictims = EM.alter alterKind ikind
                                      $ gvictims fact}
  updateFaction (bfid b) 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 lid p fromTile toTile = assert (fromTile /= toTile) $ do
  COps{coTileSpeedup} <- getsState scops
  lvl <- getLevel lid
  let t = lvl `at` p
  if t /= fromTile
  then atomicFail "terrain to modify is different than assumed"
  else do
    let adj ts = ts PointArray.// [(p, toTile)]
    updateLevel lid $ updateTile adj
    case ( Tile.isExplorable coTileSpeedup fromTile
         , Tile.isExplorable coTileSpeedup toTile ) of
      (False, True) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl2 + 1}
      (True, False) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl2 - 1}
      _ -> return ()

updAlterExplorable :: MonadStateWrite m => LevelId -> Int -> m ()
updAlterExplorable lid delta = assert (delta /= 0) $
  updateLevel lid $ \lvl -> lvl {lexpl = lexpl lvl + delta}

updAlterGold :: MonadStateWrite m => Int -> m ()
updAlterGold delta = assert (delta /= 0) $
  modifyState $ updateGold (+ delta)

-- Showing to the client the embedded items, if any, is done elsewhere.
updSearchTile :: MonadStateWrite m
              => ActorId -> Point -> ContentId TileKind -> m ()
updSearchTile aid p toTile = do
  COps{cotile} <- getsState scops
  b <- getsState $ getActorBody aid
  lvl <- getLevel $ blid b
  let t = lvl `at` p
  if t == toTile
  then atomicFail "tile already searched"
  else assert (Just t == Tile.hideAs cotile toTile) $ do
    updLoseTile (blid b) [(p, t)]
    updSpotTile (blid b) [(p, 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 lid ts = assert (not $ null ts) $ do
  COps{coTileSpeedup} <- getsState scops
  let unk tileMap (p, _) = tileMap PointArray.! p == unknownId
      adj tileMap = assert (allB (unk tileMap) ts)
                    $ tileMap PointArray.// ts
  updateLevel lid $ updateTile adj
  let f (_, t1) = when (Tile.isExplorable coTileSpeedup t1) $
        updateLevel lid $ \lvl -> lvl {lseen = lseen lvl + 1}
  mapM_ f 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 lid ts = assert (not $ null ts) $ do
  COps{coTileSpeedup} <- getsState scops
  let matches tileMap (p, ov) = tileMap PointArray.! p == ov
      tu = map (second (const unknownId)) ts
      adj tileMap = assert (allB (matches tileMap) ts)
                    $ tileMap PointArray.// tu
  updateLevel lid $ updateTile adj
  let f (_, t1) = when (Tile.isExplorable coTileSpeedup t1) $
        updateLevel lid $ \lvl -> lvl {lseen = lseen lvl - 1}
  mapM_ f ts

updSpotEntry :: MonadStateWrite m => LevelId -> [(Point, PK.PlaceEntry)] -> m ()
updSpotEntry lid ts = assert (not $ null ts) $ do
  let alt en Nothing = Just en
      alt en (Just oldEn) = atomicFail $ "entry already added"
                                         `showFailure` (lid, ts, en, oldEn)
      f (p, en) = EM.alter (alt en) p
      upd m = foldr f m ts
  updateLevel lid $ updateEntry upd

updLoseEntry :: MonadStateWrite m => LevelId -> [(Point, PK.PlaceEntry)] -> m ()
updLoseEntry lid ts = assert (not $ null ts) $ do
  let alt en Nothing = error $ "entry already removed"
                               `showFailure` (lid, ts, en)
      alt en (Just oldEn) =
        assert (en == oldEn `blame` "unexpected lost entry"
                            `swith` (lid, ts, en, oldEn)) Nothing
      f (p, en) = EM.alter (alt en) p
      upd m = foldr f m ts
  updateLevel lid $ updateEntry upd

updAlterSmell :: MonadStateWrite m => LevelId -> Point -> Time -> Time -> m ()
updAlterSmell lid p fromSm' toSm' = do
  let fromSm = if fromSm' == timeZero then Nothing else Just fromSm'
      toSm = if toSm' == timeZero then Nothing else Just toSm'
      alt sm = assert (sm == fromSm `blame` "unexpected tile smell"
                                    `swith` (lid, p, fromSm, toSm, sm)) toSm
  updateLevel lid $ updateSmell $ EM.alter alt p

updSpotSmell :: MonadStateWrite m => LevelId -> [(Point, Time)] -> m ()
updSpotSmell lid sms = assert (not $ null sms) $ do
  let alt sm Nothing = Just sm
      alt sm (Just oldSm) = error $ "smell already added"
                                    `showFailure` (lid, sms, sm, oldSm)
      f (p, sm) = EM.alter (alt sm) p
      upd m = foldr f m sms
  updateLevel lid $ updateSmell upd

updLoseSmell :: MonadStateWrite m => LevelId -> [(Point, Time)] -> m ()
updLoseSmell lid sms = assert (not $ null sms) $ do
  let alt sm Nothing = error $ "smell already removed"
                               `showFailure` (lid, sms, sm)
      alt sm (Just oldSm) =
        assert (sm == oldSm `blame` "unexpected lost smell"
                            `swith` (lid, sms, sm, oldSm)) Nothing
      f (p, sm) = EM.alter (alt sm) p
      upd m = foldr f m sms
  updateLevel lid $ updateSmell upd

updTimeItem :: MonadStateWrite m
            => ItemId -> Container -> ItemTimers -> ItemTimers
            -> m ()
updTimeItem iid c fromIt toIt = assert (fromIt /= toIt) $ do
  bag <- getsState $ getContainerBag c
  case iid `EM.lookup` bag of
    Just (k, it) -> do
      let !_A1 = assert (fromIt == it `blame` (k, it, iid, c, fromIt, toIt)) ()
          !_A2 = assert (length toIt <= k `blame` (k, toIt, iid, c, fromIt)) ()
      deleteItemContainer iid (k, fromIt) c
      insertItemContainer iid (k, toIt) c
    Nothing -> error $ "" `showFailure` (bag, iid, c, fromIt, toIt)

updAgeGame :: MonadStateWrite m => ES.EnumSet LevelId -> m ()
updAgeGame lids = do
  modifyState $ updateTime $ flip timeShift (Delta timeClip)
  mapM_ (ageLevel (Delta timeClip)) $ ES.elems lids

updUnAgeGame :: MonadStateWrite m => ES.EnumSet LevelId -> m ()
updUnAgeGame lids = do
  modifyState $ updateTime $ flip timeShift (timeDeltaReverse $ Delta timeClip)
  mapM_ (ageLevel (timeDeltaReverse $ Delta timeClip)) $ ES.elems lids

ageLevel :: MonadStateWrite m => Delta Time -> LevelId -> m ()
ageLevel delta lid =
  updateLevel lid $ \lvl -> lvl {ltime = timeShift (ltime lvl) delta}

updDiscover :: MonadStateWrite m
            => Container -> ItemId -> ContentId ItemKind -> IA.AspectRecord
            -> m ()
updDiscover _c iid ik arItem = do
  itemD <- getsState sitemD
  COps{coItemSpeedup} <- getsState scops
  let kmIsConst = IA.kmConst $ getKindMean ik coItemSpeedup
  discoKind <- getsState sdiscoKind
  let discoverAtMostAspect = do
        discoAspect <- getsState sdiscoAspect
        if kmIsConst || iid `EM.member` discoAspect
        then atomicFail "item already fully discovered"
        else discoverAspect iid arItem
  case EM.lookup iid itemD of
    Nothing -> atomicFail "discovered item unheard of"
    Just item -> case jkind item of
      IdentityObvious _ -> discoverAtMostAspect
      IdentityCovered ix _ik -> case EM.lookup ix discoKind of
        Just{} -> discoverAtMostAspect
        Nothing -> do
          discoverKind ix ik
          unless kmIsConst $ discoverAspect iid arItem
  resetActorMaxSkills

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

updDiscoverKind :: MonadStateWrite m
                => Container -> ItemKindIx -> ContentId ItemKind -> m ()
updDiscoverKind _c ix kmKind = do
  discoKind <- getsState sdiscoKind
  if ix `EM.member` discoKind
  then atomicFail "item kind already discovered"
  else do
    discoverKind ix kmKind
    resetActorMaxSkills

discoverKind :: MonadStateWrite m => ItemKindIx -> ContentId ItemKind -> m ()
discoverKind ix kindId = do
  let f Nothing = Just kindId
      f Just{} = error $ "already discovered" `showFailure` (ix, kindId)
  modifyState $ updateDiscoKind $ \discoKind1 ->
    EM.alter f ix discoKind1

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

updDiscoverAspect :: MonadStateWrite m
                  => Container -> ItemId -> IA.AspectRecord -> m ()
updDiscoverAspect _c iid arItem = do
  COps{coItemSpeedup} <- getsState scops
  itemD <- getsState sitemD
  case EM.lookup iid itemD of
    Nothing -> atomicFail "discovered item unheard of"
    Just item -> do
      -- Here the kind information is exact, hence @getItemKindIdServer@.
      kindId <- getsState $ getItemKindIdServer item
      discoAspect <- getsState sdiscoAspect
      let kmIsConst = IA.kmConst $ getKindMean kindId coItemSpeedup
      if kmIsConst || iid `EM.member` discoAspect
      then atomicFail "item arItem already discovered"
      else do
        discoverAspect iid arItem
        resetActorMaxSkills

discoverAspect :: MonadStateWrite m => ItemId -> IA.AspectRecord -> m ()
discoverAspect iid arItem = do
  let f Nothing = Just arItem
      f Just{} = error $ "already discovered" `showFailure` (iid, arItem)
  -- At this point we know the item is not @kmConst@.
  modifyState $ updateDiscoAspect $ \discoAspect1 ->
    EM.alter f iid discoAspect1

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

updDiscoverServer :: MonadStateWrite m => ItemId -> IA.AspectRecord -> m ()
updDiscoverServer iid arItem =
  modifyState $ updateDiscoAspect $ \discoAspect1 ->
    EM.insert iid arItem discoAspect1

updCoverServer :: MonadStateWrite m => ItemId -> IA.AspectRecord -> m ()
updCoverServer iid arItem =
  modifyState $ updateDiscoAspect $ \discoAspect1 ->
    assert (discoAspect1 EM.! iid == arItem)
    $ EM.delete iid discoAspect1

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

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

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