content: -- | Handle atomic commands on the server, after they are executed
  -- to change server 'State' and before they are sent to clients.
  module Game.LambdaHack.Server.HandleAtomicM
    ( cmdAtomicSemSer
  #ifdef EXPOSE_INTERNAL
      -- * Internal operations
    , validateFloor, validateFloorBag, levelOfStash
    , invalidateArenas, updateSclear, updateSlit
    , invalidateLucidLid, invalidateLucidAid
    , actorHasShine, itemAffectsShineRadius, itemAffectsPerRadius
    , addPerActor, addPerActorAny, deletePerActor, deletePerActorAny
    , invalidatePerActor, reconsiderPerActor, invalidatePerLid
  #endif
    ) where
  
  import Prelude ()
  
  import Game.LambdaHack.Core.Prelude
  
  import qualified Data.EnumMap.Strict as EM
  import qualified Data.EnumSet as ES
  
  import           Game.LambdaHack.Atomic
  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.MonadStateRead
  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.Types
  import           Game.LambdaHack.Content.TileKind (TileKind)
  import qualified Game.LambdaHack.Definition.Ability as Ability
  import           Game.LambdaHack.Definition.Defs
  import           Game.LambdaHack.Server.Fov
  import           Game.LambdaHack.Server.MonadServer
  import           Game.LambdaHack.Server.State
  
  -- | Effect of atomic actions on server state is calculated
  -- with the global state from after the command is executed
  -- (except where the supplied @oldState@ is used).
  cmdAtomicSemSer :: MonadServer m => State -> UpdAtomic -> m ()
  cmdAtomicSemSer oldState cmd = case cmd of
    UpdRegisterItems{} -> return ()
    UpdCreateActor aid b _ -> do
      actorMaxSkills <- getsState sactorMaxSkills
      when (actorHasShine actorMaxSkills aid) $ invalidateLucidLid $ blid b
      addPerActor aid b
    UpdDestroyActor aid b _ -> do
      let actorMaxSkillsOld = sactorMaxSkills oldState
      when (actorHasShine actorMaxSkillsOld aid) $ invalidateLucidLid $ blid b
      deletePerActor actorMaxSkillsOld aid b
      modifyServer $ \ser ->
        ser { sactorTime = EM.adjust (EM.adjust (EM.delete aid) (blid b)) (bfid b)
                                     (sactorTime ser)
            , strajTime = EM.adjust (EM.adjust (EM.delete aid) (blid b)) (bfid b)
                                    (strajTime ser)
            , strajPushedBy = EM.delete aid (strajPushedBy ser)
            , sactorAn = EM.delete aid (sactorAn ser)
            , sactorStasis = ES.delete aid (sactorStasis ser) }
    UpdCreateItem _ iid _ _ (CFloor lid _) -> validateFloor iid lid
    UpdCreateItem _ iid _ _ (CActor aid CStash) -> do
      lid <- levelOfStash aid
      validateFloor iid lid
    UpdCreateItem _ iid _ _ (CActor aid CGround) -> do
      lid <- getsState $ blid . getActorBody aid
      validateFloor iid lid
    UpdCreateItem _ iid _ _ (CActor aid _) -> do
      discoAspect <- getsState sdiscoAspect
      when (itemAffectsShineRadius discoAspect iid) $
        invalidateLucidAid aid
      when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid
    UpdCreateItem{} -> return ()
    UpdDestroyItem _ iid _ _ (CFloor lid _) -> validateFloor iid lid
    UpdDestroyItem _ iid _ _  (CActor aid CStash) -> do
      lid <- levelOfStash aid
      validateFloor iid lid
    UpdDestroyItem _ iid _ _ (CActor aid CGround) -> do
      lid <- getsState $ blid . getActorBody aid
      validateFloor iid lid
    UpdDestroyItem _ iid _ _ (CActor aid _) -> do
      discoAspect <- getsState sdiscoAspect
      when (itemAffectsShineRadius discoAspect iid) $
        invalidateLucidAid aid
      when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid
    UpdDestroyItem{} -> return ()
    UpdSpotActor aid b -> do
      -- On server, it does't affect aspects, but does affect lucid (Ascend).
      actorMaxSkills <- getsState sactorMaxSkills
      when (actorHasShine actorMaxSkills aid) $ invalidateLucidLid $ blid b
      addPerActor aid b
    UpdLoseActor aid b -> do
      -- On server, it does't affect aspects, but does affect lucid (Ascend).
      let actorMaxSkillsOld = sactorMaxSkills oldState
      when (actorHasShine actorMaxSkillsOld aid) $ invalidateLucidLid $ blid b
      deletePerActor actorMaxSkillsOld aid b
      modifyServer $ \ser ->
        ser { sactorTime = EM.adjust (EM.adjust (EM.delete aid) (blid b)) (bfid b)
                                     (sactorTime ser)
            , strajTime = EM.adjust (EM.adjust (EM.delete aid) (blid b)) (bfid b)
                                    (strajTime ser)
            , strajPushedBy = EM.delete aid (strajPushedBy ser)
            , sactorAn = EM.delete aid (sactorAn ser)
            , sactorStasis = ES.delete aid (sactorStasis ser) }
    UpdSpotItem _ iid _ (CFloor lid _) -> validateFloor iid lid
    UpdSpotItem _ iid _  (CActor aid CStash) -> do
      lid <- levelOfStash aid
      validateFloor iid lid
    UpdSpotItem _ iid _ (CActor aid CGround) -> do
      lid <- getsState $ blid . getActorBody aid
      validateFloor iid lid
    UpdSpotItem _ iid _ (CActor aid _) -> do
      discoAspect <- getsState sdiscoAspect
      when (itemAffectsShineRadius discoAspect iid) $
        invalidateLucidAid aid
      when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid
    UpdSpotItem{} -> return ()
    UpdLoseItem _ iid _ (CFloor lid _) -> validateFloor iid lid
    UpdLoseItem _ iid _ (CActor aid CStash) -> do
      lid <- levelOfStash aid
      validateFloor iid lid
    UpdLoseItem _ iid _ (CActor aid CGround) -> do
      lid <- getsState $ blid . getActorBody aid
      validateFloor iid lid
    UpdLoseItem _ iid _ (CActor aid _) -> do
      discoAspect <- getsState sdiscoAspect
      when (itemAffectsShineRadius discoAspect iid) $
        invalidateLucidAid aid
      when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid
    UpdLoseItem{} -> return ()
    UpdSpotItemBag _ (CFloor lid _) bag  -> validateFloorBag bag lid
    UpdSpotItemBag _ (CActor aid CStash) bag -> do
      lid <- levelOfStash aid
      validateFloorBag bag lid
    UpdSpotItemBag _ (CActor aid CGround) bag -> do
      lid <- getsState $ blid . getActorBody aid
      validateFloorBag bag lid
    UpdSpotItemBag _ (CActor aid _) bag -> do
      discoAspect <- getsState sdiscoAspect
      let iids = EM.keys bag
      when (any (itemAffectsShineRadius discoAspect) iids) $
        invalidateLucidAid aid
      when (any (itemAffectsPerRadius discoAspect) iids) $
        reconsiderPerActor aid
    UpdSpotItemBag{} -> return ()
    UpdLoseItemBag _ (CFloor lid _) bag -> validateFloorBag bag lid
    UpdLoseItemBag _ (CActor aid CStash) bag -> do
      lid <- levelOfStash aid
      validateFloorBag bag lid
    UpdLoseItemBag _ (CActor aid CGround) bag -> do
      lid <- levelOfStash aid
      validateFloorBag bag lid
    UpdLoseItemBag _ (CActor aid _) bag -> do
      discoAspect <- getsState sdiscoAspect
      let iids = EM.keys bag
      when (any (itemAffectsShineRadius discoAspect) iids) $
        invalidateLucidAid aid
      when (any (itemAffectsPerRadius discoAspect) iids) $
        reconsiderPerActor aid
    UpdLoseItemBag{} -> return ()
    UpdMoveActor aid _ _ -> do
      actorMaxSkills <- getsState sactorMaxSkills
      when (actorHasShine actorMaxSkills aid) $ invalidateLucidAid aid
      invalidatePerActor aid
    UpdWaitActor{} -> return ()
    UpdDisplaceActor aid1 aid2 -> do
      actorMaxSkills <- getsState sactorMaxSkills
      when (actorHasShine actorMaxSkills aid1
            || actorHasShine actorMaxSkills aid2) $
        invalidateLucidAid aid1  -- the same lid as aid2
      invalidatePerActor aid1
      invalidatePerActor aid2
    UpdMoveItem iid _k aid s1 s2 -> do
      let dummyVerbose = False
          dummyKit = quantSingle
      cmdAtomicSemSer oldState $
        UpdLoseItem dummyVerbose iid dummyKit (CActor aid s1)
      cmdAtomicSemSer oldState $
        UpdSpotItem dummyVerbose iid dummyKit (CActor aid s2)
    UpdRefillHP{} -> return ()
    UpdRefillCalm aid _ -> do
      actorMaxSk <- getsState $ getActorMaxSkills aid
      body <- getsState $ getActorBody aid
      let sight = Ability.getSk Ability.SkSight actorMaxSk
          oldBody = getActorBody aid oldState
          radiusOld = boundSightByCalm sight (bcalm oldBody)
          radiusNew = boundSightByCalm sight (bcalm body)
      when (radiusOld /= radiusNew) $ invalidatePerActor aid
    UpdTrajectory{} -> return ()
    UpdQuitFaction{} -> return ()
    UpdSpotStashFaction _ fid lid _ -> invalidatePerFidLid fid lid
    UpdLoseStashFaction _ fid lid _ -> invalidatePerFidLid fid lid
    UpdLeadFaction{} -> invalidateArenas
    UpdDiplFaction{} -> return ()
    UpdDoctrineFaction{} -> return ()
    UpdAutoFaction{} -> return ()
    UpdRecordKill{} -> invalidateArenas
    UpdAlterTile lid pos fromTile toTile -> do
      clearChanged <- updateSclear lid pos fromTile toTile
      litChanged <- updateSlit lid pos fromTile toTile
      when (clearChanged || litChanged) $ invalidateLucidLid lid
      when clearChanged $ invalidatePerLid lid
    UpdAlterExplorable{} -> return ()
    UpdAlterGold{} -> return ()
    UpdSearchTile{} -> return ()
    UpdHideTile{} -> return ()
    UpdSpotTile{} -> return ()
    UpdLoseTile{} -> return ()
    UpdSpotEntry{} -> return ()
    UpdLoseEntry{} -> return ()
    UpdAlterSmell{} -> return ()
    UpdSpotSmell{} -> return ()
    UpdLoseSmell{} -> return ()
    UpdTimeItem{} -> return ()
    UpdAgeGame{} -> return ()
    UpdUnAgeGame{} -> return ()
    UpdDiscover{} -> return ()
    UpdCover{} -> return ()
    UpdDiscoverKind{} -> return ()
    UpdCoverKind{} -> return ()
    UpdDiscoverAspect{} -> return ()
    UpdCoverAspect{} -> return ()
    UpdDiscoverServer{} -> return ()
    UpdCoverServer{} -> return ()
    UpdPerception{} -> return ()
    UpdRestart{} -> return ()
    UpdRestartServer{} -> return ()
    UpdResume{} -> return ()
    UpdResumeServer{} -> return ()
    UpdKillExit{} -> return ()
    UpdWriteSave{} -> return ()
    UpdHearFid{} -> return ()
    UpdMuteMessages{} -> return ()
  
  validateFloor :: MonadServer m => ItemId -> LevelId -> m ()
  validateFloor iid lid = do
    discoAspect <- getsState sdiscoAspect
    when (itemAffectsShineRadius discoAspect iid) $ invalidateLucidLid lid
  
  validateFloorBag :: MonadServer m => ItemBag -> LevelId -> m ()
  validateFloorBag bag lid = do
    discoAspect <- getsState sdiscoAspect
    let iids = EM.keys bag
    when (any (itemAffectsShineRadius discoAspect) iids) $
      invalidateLucidLid lid
  
  levelOfStash :: MonadStateRead m => ActorId -> m LevelId
  levelOfStash aid = do
    b <- getsState $ getActorBody aid
    mstash <- getsState $ \s -> gstash $ sfactionD s EM.! bfid b
    case mstash of
      Just (lid, _) -> return lid
      Nothing -> error $ "" `showFailure` (aid, b)
  
  invalidateArenas :: MonadServer m => m ()
  invalidateArenas = modifyServer $ \ser -> ser {svalidArenas = False}
  
  updateSclear :: MonadServer m
               => LevelId -> Point -> ContentId TileKind -> ContentId TileKind
               -> m Bool
  updateSclear lid pos fromTile toTile = do
    COps{coTileSpeedup} <- getsState scops
    let fromClear = Tile.isClear coTileSpeedup fromTile
        toClear = Tile.isClear coTileSpeedup toTile
    if fromClear == toClear then return False else do
      let f FovClear{fovClear} =
            FovClear $ fovClear PointArray.// [(pos, toClear)]
      modifyServer $ \ser ->
        ser {sfovClearLid = EM.adjust f lid $ sfovClearLid ser}
      return True
  
  updateSlit :: MonadServer m
             => LevelId -> Point -> ContentId TileKind -> ContentId TileKind
             -> m Bool
  updateSlit lid pos fromTile toTile = do
    COps{coTileSpeedup} <- getsState scops
    let fromLit = Tile.isLit coTileSpeedup fromTile
        toLit = Tile.isLit coTileSpeedup toTile
    if fromLit == toLit then return False else do
      let f (FovLit set) =
            FovLit $ if toLit then ES.insert pos set else ES.delete pos set
      modifyServer $ \ser -> ser {sfovLitLid = EM.adjust f lid $ sfovLitLid ser}
      return True
  
  invalidateLucidLid :: MonadServer m => LevelId -> m ()
  invalidateLucidLid lid =
    modifyServer $ \ser ->
      ser { sfovLucidLid = EM.insert lid FovInvalid $ sfovLucidLid ser
          , sperValidFid = EM.map (EM.insert lid False) $ sperValidFid ser }
  
  invalidateLucidAid :: MonadServer m => ActorId -> m ()
  invalidateLucidAid aid = do
    lid <- getsState $ blid . getActorBody aid
    invalidateLucidLid lid
  
  actorHasShine :: ActorMaxSkills -> ActorId -> Bool
  actorHasShine actorMaxSkills aid = case EM.lookup aid actorMaxSkills of
    Just actorMaxSk -> Ability.getSk Ability.SkShine actorMaxSk > 0
    Nothing -> error $ "" `showFailure` aid
  
  itemAffectsShineRadius :: DiscoveryAspect -> ItemId -> Bool
  itemAffectsShineRadius discoAspect iid = case EM.lookup iid discoAspect of
    Just arItem -> IA.getSkill Ability.SkShine arItem /= 0
    Nothing -> error $ "" `showFailure` iid
  
  itemAffectsPerRadius :: DiscoveryAspect -> ItemId -> Bool
  itemAffectsPerRadius discoAspect iid =
    case EM.lookup iid discoAspect of
      Just arItem -> IA.getSkill Ability.SkSight arItem /= 0
                 || IA.getSkill Ability.SkSmell arItem /= 0
                 || IA.getSkill Ability.SkNocto arItem /= 0
      Nothing -> error $ "" `showFailure` iid
  
  addPerActor :: MonadServer m => ActorId -> Actor -> m ()
  addPerActor aid b = do
    actorMaxSk <- getsState $ getActorMaxSkills aid
    unless (Ability.getSk Ability.SkSight actorMaxSk <= 0
            && Ability.getSk Ability.SkNocto actorMaxSk <= 0
            && Ability.getSk Ability.SkSmell actorMaxSk <= 0) $
      addPerActorAny aid b
  
  addPerActorAny :: MonadServer m => ActorId -> Actor -> m ()
  addPerActorAny aid b = do
    let fid = bfid b
        lid = blid b
        f PerceptionCache{perActor} = PerceptionCache
          { ptotal = FovInvalid
          , perActor = EM.insert aid FovInvalid perActor }
    modifyServer $ \ser ->
      ser { sperCacheFid = EM.adjust (EM.adjust f lid) fid $ sperCacheFid ser
          , sperValidFid = EM.adjust (EM.insert lid False) fid
                           $ sperValidFid ser }
  
  deletePerActor :: MonadServer m => ActorMaxSkills -> ActorId -> Actor -> m ()
  deletePerActor actorMaxSkillsOld aid b = do
    let actorMaxSk = actorMaxSkillsOld EM.! aid
    unless (Ability.getSk Ability.SkSight actorMaxSk <= 0
            && Ability.getSk Ability.SkNocto actorMaxSk <= 0
            && Ability.getSk Ability.SkSmell actorMaxSk <= 0) $
      deletePerActorAny aid b
  
  deletePerActorAny :: MonadServer m => ActorId -> Actor -> m ()
  deletePerActorAny aid b = do
    let fid = bfid b
        lid = blid b
        f PerceptionCache{perActor} = PerceptionCache
          { ptotal = FovInvalid
          , perActor = EM.delete aid perActor }
    modifyServer $ \ser ->
      ser { sperCacheFid = EM.adjust (EM.adjust f lid) fid $ sperCacheFid ser
          , sperValidFid = EM.adjust (EM.insert lid False) fid
                           $ sperValidFid ser }
  
  invalidatePerActor :: MonadServer m => ActorId -> m ()
  invalidatePerActor aid = do
    actorMaxSk <- getsState $ getActorMaxSkills aid
    unless (Ability.getSk Ability.SkSight actorMaxSk <= 0
            && Ability.getSk Ability.SkNocto actorMaxSk <= 0
            && Ability.getSk Ability.SkSmell actorMaxSk <= 0) $ do
      b <- getsState $ getActorBody aid
      addPerActorAny aid b
  
  reconsiderPerActor :: MonadServer m => ActorId -> m ()
  reconsiderPerActor aid = do
    b <- getsState $ getActorBody aid
    actorMaxSk <- getsState $ getActorMaxSkills aid
    if Ability.getSk Ability.SkSight actorMaxSk <= 0
       && Ability.getSk Ability.SkNocto actorMaxSk <= 0
       && Ability.getSk Ability.SkSmell actorMaxSk <= 0
    then do
      perCacheFid <- getsServer sperCacheFid
      when (EM.member aid $ perActor ((perCacheFid EM.! bfid b) EM.! blid b)) $
        deletePerActorAny aid b
    else addPerActorAny aid b
  
  invalidatePerLid :: MonadServer m => LevelId -> m ()
  invalidatePerLid lid = do
    let f pc@PerceptionCache{perActor}
          | EM.null perActor = pc
          | otherwise = PerceptionCache
            { ptotal = FovInvalid
            , perActor = EM.map (const FovInvalid) perActor }
    modifyServer $ \ser ->
      let perCacheFidNew = EM.map (EM.adjust f lid) $ sperCacheFid ser
          g fid valid |
            ptotal ((perCacheFidNew EM.! fid) EM.! lid) == FovInvalid =
            EM.insert lid False valid
          g _ valid = valid
      in ser { sperCacheFid = perCacheFidNew
             , sperValidFid = EM.mapWithKey g $ sperValidFid ser }
  
  invalidatePerFidLid :: MonadServer m => FactionId -> LevelId -> m ()
  invalidatePerFidLid fid lid = do
    let adj = EM.insert lid False
    modifyServer $ \ser ->
      ser {sperValidFid = EM.adjust adj fid $ sperValidFid ser}
  