-- | The main loop of the server, processing human and computer player
-- moves turn by turn.
module Game.LambdaHack.Server.LoopM
  ( loopSer
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , factionArena, arenasForLoop, handleFidUpd, loopUpd, endClip
  , manageCalmAndDomination, applyPeriodicLevel
  , handleTrajectories, hTrajectories, advanceTrajectory
  , handleActors, hActors, handleUIunderAI, dieSer, restartGame
#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.Client (ReqUI (..), Response (..))
import           Game.LambdaHack.Common.Actor
import           Game.LambdaHack.Common.ActorState
import           Game.LambdaHack.Common.Analytics
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.Misc
import           Game.LambdaHack.Common.MonadStateRead
import           Game.LambdaHack.Common.Perception
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 qualified Game.LambdaHack.Content.ItemKind as IK
import           Game.LambdaHack.Content.ModeKind
import           Game.LambdaHack.Content.RuleKind
import qualified Game.LambdaHack.Definition.Ability as Ability
import           Game.LambdaHack.Definition.Defs
import           Game.LambdaHack.Server.CommonM
import           Game.LambdaHack.Server.HandleEffectM
import           Game.LambdaHack.Server.HandleRequestM
import           Game.LambdaHack.Server.MonadServer
import           Game.LambdaHack.Server.PeriodicM
import           Game.LambdaHack.Server.ProtocolM
import           Game.LambdaHack.Server.ServerOptions
import           Game.LambdaHack.Server.StartM
import           Game.LambdaHack.Server.State

-- | Start a game session, including the clients, and then loop,
-- communicating with the clients.
--
-- The loop is started in server state that is empty, see 'emptyStateServer'.
loopSer :: (MonadServerAtomic m, MonadServerComm m)
        => ServerOptions
             -- ^ player-supplied server options
        -> (Bool -> FactionId -> ChanServer -> IO ())
             -- ^ function that initializes a client and runs its main loop
        -> m ()
loopSer :: ServerOptions -> (Bool -> FactionId -> ChanServer -> IO ()) -> m ()
loopSer ServerOptions
serverOptions Bool -> FactionId -> ChanServer -> IO ()
executorClient = do
  -- Recover states and launch clients.
  (StateServer -> StateServer) -> m ()
forall (m :: * -> *).
MonadServer m =>
(StateServer -> StateServer) -> m ()
modifyServer ((StateServer -> StateServer) -> m ())
-> (StateServer -> StateServer) -> m ()
forall a b. (a -> b) -> a -> b
$ \StateServer
ser -> StateServer
ser { soptionsNxt :: ServerOptions
soptionsNxt = ServerOptions
serverOptions
                             , soptions :: ServerOptions
soptions = ServerOptions
serverOptions }
  COps
cops <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  let updConn :: Bool -> m ()
updConn Bool
startsNewGame = (FactionId -> ChanServer -> IO ()) -> m ()
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
(FactionId -> ChanServer -> IO ()) -> m ()
updateConn ((FactionId -> ChanServer -> IO ()) -> m ())
-> (FactionId -> ChanServer -> IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> FactionId -> ChanServer -> IO ()
executorClient Bool
startsNewGame
  Maybe (State, StateServer)
restored <- m (Maybe (State, StateServer))
forall (m :: * -> *).
MonadServerComm m =>
m (Maybe (State, StateServer))
tryRestore
  case Maybe (State, StateServer)
restored of
    Just (State
sRaw, StateServer
ser) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ServerOptions -> Bool
snewGameSer ServerOptions
serverOptions -> do  -- a restored game
      UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ State -> UpdAtomic
UpdResumeServer
                    (State -> UpdAtomic) -> State -> UpdAtomic
forall a b. (a -> b) -> a -> b
$ (COps -> COps) -> State -> State
updateCOpsAndCachedData (COps -> COps -> COps
forall a b. a -> b -> a
const COps
cops) State
sRaw
      StateServer -> m ()
forall (m :: * -> *). MonadServer m => StateServer -> m ()
putServer StateServer
ser {soptionsNxt :: ServerOptions
soptionsNxt = ServerOptions
serverOptions}
      m ()
forall (m :: * -> *). MonadServer m => m ()
applyDebug
      FactionDict
factionD <- (State -> FactionDict) -> m FactionDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> FactionDict
sfactionD
      let f :: FactionId -> m Bool
f FactionId
fid = let cmd :: UpdAtomic
cmd = State -> UpdAtomic
UpdResumeServer
                            (State -> UpdAtomic) -> State -> UpdAtomic
forall a b. (a -> b) -> a -> b
$ (COps -> COps) -> State -> State
updateCOpsAndCachedData (COps -> COps -> COps
forall a b. a -> b -> a
const COps
cops)
                            (State -> State) -> State -> State
forall a b. (a -> b) -> a -> b
$ StateServer -> EnumMap FactionId State
sclientStates StateServer
ser EnumMap FactionId State -> FactionId -> State
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid
                  in FactionId -> UpdAtomic -> m Bool
forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> UpdAtomic -> m Bool
execUpdAtomicFidCatch FactionId
fid UpdAtomic
cmd
      (FactionId -> m ()) -> [FactionId] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (m Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Bool -> m ()) -> (FactionId -> m Bool) -> FactionId -> m ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FactionId -> m Bool
f) ([FactionId] -> m ()) -> [FactionId] -> m ()
forall a b. (a -> b) -> a -> b
$ FactionDict -> [FactionId]
forall k a. Enum k => EnumMap k a -> [k]
EM.keys FactionDict
factionD
      Bool -> m ()
updConn Bool
False
      m ()
forall (m :: * -> *). MonadServer m => m ()
initPer
      PerFid
pers <- (StateServer -> PerFid) -> m PerFid
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> PerFid
sperFid
      let clear :: b -> Perception
clear = Perception -> b -> Perception
forall a b. a -> b -> a
const Perception
emptyPer
          persFid :: FactionId -> EnumMap LevelId Perception
persFid FactionId
fid | ServerOptions -> Bool
sknowEvents ServerOptions
serverOptions = (Perception -> Perception)
-> EnumMap LevelId Perception -> EnumMap LevelId Perception
forall a b k. (a -> b) -> EnumMap k a -> EnumMap k b
EM.map Perception -> Perception
forall b. b -> Perception
clear (PerFid
pers PerFid -> FactionId -> EnumMap LevelId Perception
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid)
                      | Bool
otherwise = PerFid
pers PerFid -> FactionId -> EnumMap LevelId Perception
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid
      (FactionId -> m ()) -> [FactionId] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (\FactionId
fid -> FactionId -> UpdAtomic -> m ()
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
FactionId -> UpdAtomic -> m ()
sendUpdate FactionId
fid (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> EnumMap LevelId Perception -> UpdAtomic
UpdResume FactionId
fid (FactionId -> EnumMap LevelId Perception
persFid FactionId
fid))
            (FactionDict -> [FactionId]
forall k a. Enum k => EnumMap k a -> [k]
EM.keys FactionDict
factionD)
      EnumSet LevelId
arenasNew <- m (EnumSet LevelId)
forall (m :: * -> *). MonadStateRead m => m (EnumSet LevelId)
arenasForLoop
      (StateServer -> StateServer) -> m ()
forall (m :: * -> *).
MonadServer m =>
(StateServer -> StateServer) -> m ()
modifyServer ((StateServer -> StateServer) -> m ())
-> (StateServer -> StateServer) -> m ()
forall a b. (a -> b) -> a -> b
$ \StateServer
ser2 -> StateServer
ser2 {sarenas :: EnumSet LevelId
sarenas = EnumSet LevelId
arenasNew, svalidArenas :: Bool
svalidArenas = Bool
True}
      -- We dump RNG seeds here, based on @soptionsNxt@, in case the game
      -- wasn't run with @--dumpInitRngs@ previously, but we need the seeds,
      -- e.g., to diagnose a crash.
      RNGs
rngs <- (StateServer -> RNGs) -> m RNGs
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> RNGs
srngs
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ServerOptions -> Bool
sdumpInitRngs ServerOptions
serverOptions) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ RNGs -> m ()
forall (m :: * -> *). MonadServer m => RNGs -> m ()
dumpRngs RNGs
rngs
    Maybe (State, StateServer)
_ -> do  -- starting new game for this savefile (--newGame or fresh save)
      FactionDict
factionDold <- (State -> FactionDict) -> m FactionDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> FactionDict
sfactionD
      State
s <- ServerOptions
-> Maybe (GroupName ModeKind) -> Maybe SMGen -> m State
forall (m :: * -> *).
MonadServer m =>
ServerOptions
-> Maybe (GroupName ModeKind) -> Maybe SMGen -> m State
gameReset ServerOptions
serverOptions Maybe (GroupName ModeKind)
forall a. Maybe a
Nothing Maybe SMGen
forall a. Maybe a
Nothing
             -- get RNG from item boost
      -- Set up commandline options.
      let optionsBarRngs :: ServerOptions
optionsBarRngs =
            ServerOptions
serverOptions {sdungeonRng :: Maybe SMGen
sdungeonRng = Maybe SMGen
forall a. Maybe a
Nothing, smainRng :: Maybe SMGen
smainRng = Maybe SMGen
forall a. Maybe a
Nothing}
      (StateServer -> StateServer) -> m ()
forall (m :: * -> *).
MonadServer m =>
(StateServer -> StateServer) -> m ()
modifyServer ((StateServer -> StateServer) -> m ())
-> (StateServer -> StateServer) -> m ()
forall a b. (a -> b) -> a -> b
$ \StateServer
ser -> StateServer
ser { soptionsNxt :: ServerOptions
soptionsNxt = ServerOptions
optionsBarRngs
                                 , soptions :: ServerOptions
soptions = ServerOptions
optionsBarRngs }
      UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ State -> UpdAtomic
UpdRestartServer State
s
      Bool -> m ()
updConn Bool
True
      m ()
forall (m :: * -> *). MonadServer m => m ()
initPer
      FactionDict -> m ()
forall (m :: * -> *). MonadServerAtomic m => FactionDict -> m ()
reinitGame FactionDict
factionDold
      Bool -> Bool -> m ()
forall (m :: * -> *). MonadServerAtomic m => Bool -> Bool -> m ()
writeSaveAll Bool
False Bool
False
  m () -> m ()
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
m () -> m ()
loopUpd (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> m ()
updConn Bool
True

factionArena :: MonadStateRead m => Faction -> m (Maybe LevelId)
factionArena :: Faction -> m (Maybe LevelId)
factionArena Faction
fact = case Faction -> Maybe ActorId
gleader Faction
fact of
  -- Even spawners need an active arena for their leader,
  -- or they start clogging stairs.
  Just ActorId
leader -> 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
leader
    Maybe LevelId -> m (Maybe LevelId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe LevelId -> m (Maybe LevelId))
-> Maybe LevelId -> m (Maybe LevelId)
forall a b. (a -> b) -> a -> b
$ LevelId -> Maybe LevelId
forall a. a -> Maybe a
Just (LevelId -> Maybe LevelId) -> LevelId -> Maybe LevelId
forall a b. (a -> b) -> a -> b
$ Actor -> LevelId
blid Actor
b
  Maybe ActorId
Nothing -> Maybe LevelId -> m (Maybe LevelId)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe LevelId
forall a. Maybe a
Nothing
    -- This means Allure heroes can kill all aliens on lvl 4, retreat,
    -- hide and sleep on lvl 3 and they are guaranteed aliens don't spawn.
    -- However, animals still spawn, if slowly, and aliens resume
    -- spawning when heroes move on again.

arenasForLoop :: MonadStateRead m => m (ES.EnumSet LevelId)
{-# INLINE arenasForLoop #-}
arenasForLoop :: m (EnumSet LevelId)
arenasForLoop = do
  FactionDict
factionD <- (State -> FactionDict) -> m FactionDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> FactionDict
sfactionD
  [Maybe LevelId]
marenas <- (Faction -> m (Maybe LevelId)) -> [Faction] -> m [Maybe LevelId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Faction -> m (Maybe LevelId)
forall (m :: * -> *).
MonadStateRead m =>
Faction -> m (Maybe LevelId)
factionArena ([Faction] -> m [Maybe LevelId]) -> [Faction] -> m [Maybe LevelId]
forall a b. (a -> b) -> a -> b
$ FactionDict -> [Faction]
forall k a. EnumMap k a -> [a]
EM.elems FactionDict
factionD
  let arenas :: EnumSet LevelId
arenas = [LevelId] -> EnumSet LevelId
forall k. Enum k => [k] -> EnumSet k
ES.fromList ([LevelId] -> EnumSet LevelId) -> [LevelId] -> EnumSet LevelId
forall a b. (a -> b) -> a -> b
$ [Maybe LevelId] -> [LevelId]
forall a. [Maybe a] -> [a]
catMaybes [Maybe LevelId]
marenas
      !_A :: ()
_A = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool -> Bool
not (EnumSet LevelId -> Bool
forall k. EnumSet k -> Bool
ES.null EnumSet LevelId
arenas)
                    Bool -> (String, FactionDict) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"game over not caught earlier"
                    String -> FactionDict -> (String, FactionDict)
forall v. String -> v -> (String, v)
`swith` FactionDict
factionD) ()
  EnumSet LevelId -> m (EnumSet LevelId)
forall (m :: * -> *) a. Monad m => a -> m a
return (EnumSet LevelId -> m (EnumSet LevelId))
-> EnumSet LevelId -> m (EnumSet LevelId)
forall a b. (a -> b) -> a -> b
$! EnumSet LevelId
arenas

handleFidUpd :: forall m. (MonadServerAtomic m, MonadServerComm m)
             => (FactionId -> m ()) -> FactionId -> Faction -> m ()
{-# INLINE handleFidUpd #-}
handleFidUpd :: (FactionId -> m ()) -> FactionId -> Faction -> m ()
handleFidUpd FactionId -> m ()
updatePerFid FactionId
fid Faction
fact = do
  -- Update perception on all levels at once,
  -- in case a leader is changed to actor on another
  -- (possibly not even currently active) level.
  -- This runs for all factions even if save is requested by UI.
  -- Let players ponder new game state while the engine is busy saving.
  -- Also, this ensures perception before game save is exactly the same
  -- as at game resume, which is an invariant we check elsewhere.
  -- However, if perception is not updated after the action, the actor
  -- may not see his vicinity, so may not see enemy that displaces (or hits) him
  -- resulting in breaking the displace action and temporary leader loss,
  -- which is fine, though a bit alarming. So, we update it at the end.
  FactionId -> m ()
updatePerFid FactionId
fid
  -- Move a single actor only. Note that the skipped actors are not marked
  -- as waiting. Normally they will act in the next clip or the next few,
  -- so that's natural. But if there are dozens of them, this is wierd.
  -- E.g., they don't move, but still make nearby foes lose Calm.
  -- However, for KISS, we leave it be.
  --
  -- Bail out if immediate loop break- requested by UI. No check
  -- for @sbreakLoop@ needed, for the same reasons as in @handleActors@.
  let handle :: [LevelId] -> m Bool
      handle :: [LevelId] -> m Bool
handle [] = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      handle (LevelId
lid : [LevelId]
rest) = do
        Bool
breakASAP <- (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> Bool
sbreakASAP
        if Bool
breakASAP
        then Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        else do
          Bool
nonWaitMove <- LevelId -> FactionId -> m Bool
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
LevelId -> FactionId -> m Bool
handleActors LevelId
lid FactionId
fid
          if Bool
nonWaitMove
          then Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          else [LevelId] -> m Bool
handle [LevelId]
rest
      killDying :: [LevelId] -> m ()
      killDying :: [LevelId] -> m ()
killDying = (LevelId -> m ()) -> [LevelId] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ LevelId -> m ()
killDyingLid
      killDyingLid :: LevelId -> m ()
      killDyingLid :: LevelId -> m ()
killDyingLid LevelId
lid = do
        Time
localTime <- (State -> Time) -> m Time
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Time) -> m Time) -> (State -> Time) -> m Time
forall a b. (a -> b) -> a -> b
$ LevelId -> State -> Time
getLocalTime LevelId
lid
        EnumMap ActorId Time
levelTime <- (StateServer -> EnumMap ActorId Time) -> m (EnumMap ActorId Time)
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> EnumMap ActorId Time) -> m (EnumMap ActorId Time))
-> (StateServer -> EnumMap ActorId Time)
-> m (EnumMap ActorId Time)
forall a b. (a -> b) -> a -> b
$ (EnumMap LevelId (EnumMap ActorId Time)
-> LevelId -> EnumMap ActorId Time
forall k a. Enum k => EnumMap k a -> k -> a
EM.! LevelId
lid) (EnumMap LevelId (EnumMap ActorId Time) -> EnumMap ActorId Time)
-> (StateServer -> EnumMap LevelId (EnumMap ActorId Time))
-> StateServer
-> EnumMap ActorId Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
-> FactionId -> EnumMap LevelId (EnumMap ActorId Time)
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid) (EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
 -> EnumMap LevelId (EnumMap ActorId Time))
-> (StateServer
    -> EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time)))
-> StateServer
-> EnumMap LevelId (EnumMap ActorId Time)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer
-> EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
sactorTime
        let l :: [(ActorId, Time)]
l = ((ActorId, Time) -> Bool) -> [(ActorId, Time)] -> [(ActorId, Time)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ActorId
_, Time
atime) -> Time
atime Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Time
localTime) ([(ActorId, Time)] -> [(ActorId, Time)])
-> [(ActorId, Time)] -> [(ActorId, Time)]
forall a b. (a -> b) -> a -> b
$ EnumMap ActorId Time -> [(ActorId, Time)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs EnumMap ActorId Time
levelTime
            killAid :: (ActorId, b) -> m ()
killAid (ActorId
aid, b
_) = do
              Actor
b1 <- (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
              Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Actor -> Int64
bhp Actor
b1 Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> Actor -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> Actor -> m ()
dieSer ActorId
aid Actor
b1
        ((ActorId, Time) -> m ()) -> [(ActorId, Time)] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (ActorId, Time) -> m ()
forall (m :: * -> *) b. MonadServerAtomic m => (ActorId, b) -> m ()
killAid [(ActorId, Time)]
l
  -- Start on arena with leader, if available. This is crucial to ensure
  -- that no actor (even ours) moves before UI declares save(&exit).
  Maybe LevelId
fa <- Faction -> m (Maybe LevelId)
forall (m :: * -> *).
MonadStateRead m =>
Faction -> m (Maybe LevelId)
factionArena Faction
fact
  EnumSet LevelId
arenas <- (StateServer -> EnumSet LevelId) -> m (EnumSet LevelId)
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> EnumSet LevelId
sarenas
  let myArenas :: [LevelId]
myArenas = case Maybe LevelId
fa of
        Just LevelId
myArena -> LevelId
myArena LevelId -> [LevelId] -> [LevelId]
forall a. a -> [a] -> [a]
: LevelId -> [LevelId] -> [LevelId]
forall a. Eq a => a -> [a] -> [a]
delete LevelId
myArena (EnumSet LevelId -> [LevelId]
forall k. Enum k => EnumSet k -> [k]
ES.elems EnumSet LevelId
arenas)
        Maybe LevelId
Nothing -> EnumSet LevelId -> [LevelId]
forall k. Enum k => EnumSet k -> [k]
ES.elems EnumSet LevelId
arenas
  Bool
nonWaitMove <- [LevelId] -> m Bool
handle [LevelId]
myArenas
  Bool
breakASAP <- (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> Bool
sbreakASAP
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
breakASAP (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [LevelId] -> m ()
killDying [LevelId]
myArenas
  -- We update perception at the end, see comment above. This is usually
  -- cheap, and when not, if it's AI faction, it's a waste, but if it's UI,
  -- that's exactly where it prevents lost attack messages, etc.
  -- If the move was a wait, perception unchanged, so no need to update,
  -- unless the actor starts sleeping, in which case his perception
  -- is reduced a bit later, so no harm done.
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
nonWaitMove (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> m ()
updatePerFid FactionId
fid

-- | Handle a clip (the smallest fraction of a game turn for which a frame may
-- potentially be generated). Run the leader and other actors moves.
-- Eventually advance the time and repeat.
loopUpd :: forall m. (MonadServerAtomic m, MonadServerComm m)
        => m () -> m ()
loopUpd :: m () -> m ()
loopUpd m ()
updConn = do
  let updatePerFid :: FactionId -> m ()
      {-# NOINLINE updatePerFid #-}
      updatePerFid :: FactionId -> m ()
updatePerFid FactionId
fid = do  -- {-# SCC updatePerFid #-} do
        EnumMap LevelId Bool
perValid <- (StateServer -> EnumMap LevelId Bool) -> m (EnumMap LevelId Bool)
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> EnumMap LevelId Bool) -> m (EnumMap LevelId Bool))
-> (StateServer -> EnumMap LevelId Bool)
-> m (EnumMap LevelId Bool)
forall a b. (a -> b) -> a -> b
$ (EnumMap FactionId (EnumMap LevelId Bool)
-> FactionId -> EnumMap LevelId Bool
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid) (EnumMap FactionId (EnumMap LevelId Bool) -> EnumMap LevelId Bool)
-> (StateServer -> EnumMap FactionId (EnumMap LevelId Bool))
-> StateServer
-> EnumMap LevelId Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> EnumMap FactionId (EnumMap LevelId Bool)
sperValidFid
        ((LevelId, Bool) -> m ()) -> [(LevelId, Bool)] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (\(LevelId
lid, Bool
valid) -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
valid (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> LevelId -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> LevelId -> m ()
updatePer FactionId
fid LevelId
lid)
              (EnumMap LevelId Bool -> [(LevelId, Bool)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs EnumMap LevelId Bool
perValid)
      handleFid :: (FactionId, Faction) -> m ()
      {-# NOINLINE handleFid #-}
      handleFid :: (FactionId, Faction) -> m ()
handleFid (FactionId
fid, Faction
fact) = do
        Bool
breakASAP <- (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> Bool
sbreakASAP
        -- Don't process other factions, even their perceptions,
        -- if UI saves and/or exits.
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
breakASAP (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ (FactionId -> m ()) -> FactionId -> Faction -> m ()
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
(FactionId -> m ()) -> FactionId -> Faction -> m ()
handleFidUpd FactionId -> m ()
updatePerFid FactionId
fid Faction
fact
      loopConditionally :: m ()
loopConditionally = do
        FactionDict
factionD <- (State -> FactionDict) -> m FactionDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> FactionDict
sfactionD
        -- Update perception one last time to satisfy save/resume assertions,
        -- because we may get here at arbitrary moment due to game over
        -- and so have outdated perception.
        (FactionId -> m ()) -> [FactionId] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ FactionId -> m ()
updatePerFid (FactionDict -> [FactionId]
forall k a. Enum k => EnumMap k a -> [k]
EM.keys FactionDict
factionD)
        (StateServer -> StateServer) -> m ()
forall (m :: * -> *).
MonadServer m =>
(StateServer -> StateServer) -> m ()
modifyServer ((StateServer -> StateServer) -> m ())
-> (StateServer -> StateServer) -> m ()
forall a b. (a -> b) -> a -> b
$ \StateServer
ser -> StateServer
ser { sbreakLoop :: Bool
sbreakLoop = Bool
False
                                   , sbreakASAP :: Bool
sbreakASAP = Bool
False }
        m () -> (Maybe (GroupName ModeKind) -> m ()) -> m ()
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
m () -> (Maybe (GroupName ModeKind) -> m ()) -> m ()
endOrLoop m ()
loopUpdConn (m () -> m () -> Maybe (GroupName ModeKind) -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
m () -> m () -> Maybe (GroupName ModeKind) -> m ()
restartGame m ()
updConn m ()
loopUpdConn)
      loopUpdConn :: m ()
loopUpdConn = do
        FactionDict
factionD <- (State -> FactionDict) -> m FactionDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> FactionDict
sfactionD
        -- Start handling actors with the single UI faction,
        -- to safely save/exit. Note that this hack fails if there are many UI
        -- factions (when we reenable multiplayer). Then players will request
        -- save&exit and others will vote on it and it will happen
        -- after the clip has ended, not at the start.
        -- Note that at most a single actor with a time-consuming action
        -- is processed per faction, so it's fair, but many loops are needed.
        let hasUI :: (a, Faction) -> Bool
hasUI (a
_, Faction
fact) = FactionKind -> Bool
fhasUI (Faction -> FactionKind
gkind Faction
fact)
            ((FactionId, Faction)
factionUI, [(FactionId, Faction)]
factionsRest) = case ((FactionId, Faction) -> Bool)
-> [(FactionId, Faction)]
-> ([(FactionId, Faction)], [(FactionId, Faction)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (FactionId, Faction) -> Bool
forall a. (a, Faction) -> Bool
hasUI ([(FactionId, Faction)]
 -> ([(FactionId, Faction)], [(FactionId, Faction)]))
-> [(FactionId, Faction)]
-> ([(FactionId, Faction)], [(FactionId, Faction)])
forall a b. (a -> b) -> a -> b
$ FactionDict -> [(FactionId, Faction)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs FactionDict
factionD of
              ([(FactionId, Faction)]
noUI1, (FactionId, Faction)
ui : [(FactionId, Faction)]
noUI2) -> ((FactionId, Faction)
ui, [(FactionId, Faction)]
noUI1 [(FactionId, Faction)]
-> [(FactionId, Faction)] -> [(FactionId, Faction)]
forall a. [a] -> [a] -> [a]
++ [(FactionId, Faction)]
noUI2)
              ([(FactionId, Faction)], [(FactionId, Faction)])
_ -> String -> ((FactionId, Faction), [(FactionId, Faction)])
forall a. (?callStack::CallStack) => String -> a
error String
"no UI faction in the game"
        ((FactionId, Faction) -> m ()) -> [(FactionId, Faction)] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (FactionId, Faction) -> m ()
handleFid ([(FactionId, Faction)] -> m ()) -> [(FactionId, Faction)] -> m ()
forall a b. (a -> b) -> a -> b
$ (FactionId, Faction)
factionUI (FactionId, Faction)
-> [(FactionId, Faction)] -> [(FactionId, Faction)]
forall a. a -> [a] -> [a]
: [(FactionId, Faction)]
factionsRest
        Bool
breakASAP <- (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> Bool
sbreakASAP
        Bool
breakLoop <- (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> Bool
sbreakLoop
        if Bool
breakASAP Bool -> Bool -> Bool
|| Bool
breakLoop
        then m ()
loopConditionally
        else do
          -- Projectiles are processed last and not at all if the UI leader
          -- decides to save or exit or restart or if there is game over.
          -- This and UI leader acting before any other ordinary actors
          -- ensures state is not changed and so the clip doesn't need
          -- to be carried through before save.
          EnumSet LevelId
arenas <- (StateServer -> EnumSet LevelId) -> m (EnumSet LevelId)
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> EnumSet LevelId
sarenas
          (FactionId -> m ()) -> [FactionId] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (\FactionId
fid -> (LevelId -> m ()) -> [LevelId] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (LevelId -> FactionId -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
LevelId -> FactionId -> m ()
`handleTrajectories` FactionId
fid) ([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
arenas)
                (FactionDict -> [FactionId]
forall k a. Enum k => EnumMap k a -> [k]
EM.keys FactionDict
factionD)
          (FactionId -> m ()) -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
(FactionId -> m ()) -> m ()
endClip FactionId -> m ()
updatePerFid  -- must be last, in case performs a bkp save
          -- The condition can be changed in @handleTrajectories@ by pushing
          -- onto an escape and in @endClip@.
          Bool
breakLoop2 <- (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> Bool
sbreakLoop
          if Bool
breakLoop2
          then m ()
loopConditionally
          else m ()
loopUpdConn  -- process next iteration unconditionally
  m ()
loopUpdConn

-- | Handle the end of every clip. Do whatever has to be done
-- every fixed number of clips, e.g., monster generation.
-- Advance time. Perform periodic saves, if applicable.
--
-- This is never run if UI requested save or exit or restart and it's correct,
-- because we know nobody moved and no time was or needs to be advanced
-- and arenas are not changed. After game was saved and exited,
-- on game resume the first clip is performed with empty arenas,
-- so arena time is not updated and nobody moves, nor anything happens,
-- but arenas are here correctly updated.
endClip :: forall m. MonadServerAtomic m => (FactionId -> m ()) -> m ()
{-# INLINE endClip #-}
endClip :: (FactionId -> m ()) -> m ()
endClip FactionId -> m ()
updatePerFid = do
  COps{RuleContent
corule :: COps -> RuleContent
corule :: RuleContent
corule} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  Time
time <- (State -> Time) -> m Time
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> Time
stime
  let clipN :: Int
clipN = Time
time Time -> Time -> Int
`timeFit` Time
timeClip
  -- No check if @sbreakASAP@ is set, because then the function is not called.
  Bool
breakLoop <- (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> Bool
sbreakLoop
  -- We don't send a lot of useless info to the client if the game has already
  -- ended. At best wasteful, at worst the player sees strange messages.
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
breakLoop (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    -- I need to send time updates, because I can't add time to each command,
    -- because I'd need to send also all arenas, which should be updated,
    -- and this is too expensive data for each, e.g., projectile move.
    -- I send even if nothing changes so that UI time display can progress.
    -- Possibly @arenas@ are invalid here, but all moves were performed
    -- according to this value, so time should be replenished according
    -- to this value as well.
    -- This is crucial, because tiny time discrepancies can accumulate
    -- magnified by hunders of actors that share the clip slots due to the
    -- restriction that at most one faction member acts each clip.
    EnumSet LevelId
arenas <- (StateServer -> EnumSet LevelId) -> m (EnumSet LevelId)
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> EnumSet LevelId
sarenas
    UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ EnumSet LevelId -> UpdAtomic
UpdAgeGame EnumSet LevelId
arenas
    -- Perform periodic dungeon maintenance.
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
clipN Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` RuleContent -> Int
rleadLevelClips RuleContent
corule Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) m ()
forall (m :: * -> *). MonadServerAtomic m => m ()
leadLevelSwitch
    case Int
clipN Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
clipsInTurn of
      Int
0 ->
        -- Spawn monsters at most once per 3 turns.
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
clipN Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
clipsInTurn) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
          m ()
forall (m :: * -> *). MonadServerAtomic m => m ()
spawnMonster
      Int
4 ->
        -- Periodic activation only once per turn, for speed,
        -- but on all active arenas. Calm updates and domination
        -- happen there as well. Once per turn is too rare for accurate
        -- expiration of short conditions, e.g., 1-turn haste. TODO.
        m ()
forall (m :: * -> *). MonadServerAtomic m => m ()
applyPeriodicLevel
      Int
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  -- @applyPeriodicLevel@ might have, e.g., dominated actors, ending the game.
  -- It could not have unended the game, though.
  Bool
breakLoop2 <- (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> Bool
sbreakLoop
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
breakLoop2 (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    -- Possibly a leader change due to @leadLevelSwitch@, so update arenas here
    -- for 100% accuracy at least at the start of actor moves, before they
    -- change leaders as part of their moves.
    --
    -- After game resume, this is the first non-vacuus computation.
    -- Next call to @loopUpdConn@ really moves actors and updates arena times
    -- so we start in exactly the same place that UI save ended in.
    Bool
validArenas <- (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> Bool
svalidArenas
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
validArenas (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      EnumSet LevelId
arenasNew <- m (EnumSet LevelId)
forall (m :: * -> *). MonadStateRead m => m (EnumSet LevelId)
arenasForLoop
      (StateServer -> StateServer) -> m ()
forall (m :: * -> *).
MonadServer m =>
(StateServer -> StateServer) -> m ()
modifyServer ((StateServer -> StateServer) -> m ())
-> (StateServer -> StateServer) -> m ()
forall a b. (a -> b) -> a -> b
$ \StateServer
ser -> StateServer
ser {sarenas :: EnumSet LevelId
sarenas = EnumSet LevelId
arenasNew, svalidArenas :: Bool
svalidArenas = Bool
True}
  -- Update all perception for visual feedback and to make sure saving
  -- and resuming game doesn't affect gameplay (by updating perception).
  -- Perception updates in @handleFidUpd@ are not enough, because
  -- periodic actions could have invalidated them.
  FactionDict
factionD <- (State -> FactionDict) -> m FactionDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> FactionDict
sfactionD
  (FactionId -> m ()) -> [FactionId] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ FactionId -> m ()
updatePerFid (FactionDict -> [FactionId]
forall k a. Enum k => EnumMap k a -> [k]
EM.keys FactionDict
factionD)
  -- Saving on the browser causes a huge lag, hence autosave disabled.
#ifndef USE_JSFILE
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
breakLoop2 (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$  -- if by chance requested and periodic saves coincide
    -- Periodic save needs to be at the end, so that restore can start
    -- at the beginning. Double save on first turn is avoided with @succ@.
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> Int
forall a. Enum a => a -> a
succ Int
clipN Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` RuleContent -> Int
rwriteSaveClips RuleContent
corule Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      Bool -> Bool -> m ()
forall (m :: * -> *). MonadServerAtomic m => Bool -> Bool -> m ()
writeSaveAll Bool
False Bool
False
#endif

-- | Check if the given actor is dominated and update his calm.
manageCalmAndDomination :: MonadServerAtomic m => ActorId -> Actor -> m ()
manageCalmAndDomination :: ActorId -> Actor -> m ()
manageCalmAndDomination ActorId
aid Actor
b = do
  Bool
performedDomination <-
    if Actor -> Int64
bcalm Actor
b Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0 then Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False else do  -- triggered by zeroed Calm
      Maybe (FactionId, Int)
hiImpression <- Actor -> m (Maybe (FactionId, Int))
forall (m :: * -> *).
MonadServerAtomic m =>
Actor -> m (Maybe (FactionId, Int))
highestImpression Actor
b
      case Maybe (FactionId, Int)
hiImpression of
        Maybe (FactionId, Int)
Nothing -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just (FactionId
hiImpressionFid, Int
hiImpressionK) -> 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
$ (FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> FactionId
bfid Actor
b) (FactionDict -> Faction)
-> (State -> FactionDict) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> FactionDict
sfactionD
          if FactionKind -> Bool
fhasPointman (Faction -> FactionKind
gkind Faction
fact)
               -- animals/robots/human drones never Calm-dominated
             Bool -> Bool -> Bool
|| Int
hiImpressionK Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
10
               -- unless very high impression, e.g., in a dominated hero
          then ActorId -> ActorId -> ItemId -> FactionId -> m Bool
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> ActorId -> ItemId -> FactionId -> m Bool
dominateFidSfx ActorId
aid ActorId
aid (Actor -> ItemId
btrunk Actor
b) FactionId
hiImpressionFid
          else Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
performedDomination (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Int64
newCalmDelta <- (State -> Int64) -> m Int64
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Int64) -> m Int64) -> (State -> Int64) -> m Int64
forall a b. (a -> b) -> a -> b
$ ActorId -> Actor -> State -> Int64
regenCalmDelta ActorId
aid Actor
b
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int64
newCalmDelta Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      -- Update delta for the current player turn.
      ActorId -> Int64 -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> Int64 -> m ()
updateCalm ActorId
aid Int64
newCalmDelta

-- | Trigger periodic items for all actors on the given level.
applyPeriodicLevel :: MonadServerAtomic m => m ()
applyPeriodicLevel :: m ()
applyPeriodicLevel = do
  EnumSet LevelId
arenas <- (StateServer -> EnumSet LevelId) -> m (EnumSet LevelId)
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> EnumSet LevelId
sarenas
  let applyPeriodicItem :: ActorId -> CStore -> (ItemId, (a, [a])) -> m ()
applyPeriodicItem ActorId
_ CStore
_ (ItemId
_, (a
_, [])) = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        -- periodic items always have at least one timer
      applyPeriodicItem ActorId
aid CStore
cstore (ItemId
iid, (a, [a])
_) = do
        ItemFull
itemFull <- (State -> ItemFull) -> m ItemFull
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ItemFull) -> m ItemFull)
-> (State -> ItemFull) -> m ItemFull
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> ItemFull
itemToFull ItemId
iid
        let arItem :: AspectRecord
arItem = ItemFull -> AspectRecord
aspectRecordFull ItemFull
itemFull
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Periodic AspectRecord
arItem) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          -- Check if the item is still in the bag (previous items act!).
          Actor
b2 <- (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
b2 CStore
cstore
          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 -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- item dropped
            Just (Int
k, ItemTimers
_) -> do
              -- Activate even if effects null or vacuous, to possibly
              -- destroy the item.
              let effApplyFlags :: EffApplyFlags
effApplyFlags = EffApplyFlags :: EffToUse
-> Bool -> Bool -> Bool -> ActivationFlag -> Bool -> EffApplyFlags
EffApplyFlags
                    { effToUse :: EffToUse
effToUse            = EffToUse
EffBare  -- no periodic crafting
                    , effVoluntary :: Bool
effVoluntary        = Bool
True
                    , effUseAllCopies :: Bool
effUseAllCopies     = Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
                    , effKineticPerformed :: Bool
effKineticPerformed = Bool
False
                    , effActivation :: ActivationFlag
effActivation       = ActivationFlag
Ability.ActivationPeriodic
                    , effMayDestroy :: Bool
effMayDestroy       = Bool
True
                    }
              m UseResult -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m UseResult -> m ()) -> m UseResult -> m ()
forall a b. (a -> b) -> a -> b
$ EffApplyFlags
-> ActorId
-> ActorId
-> ActorId
-> ItemId
-> Container
-> ItemFull
-> m UseResult
forall (m :: * -> *).
MonadServerAtomic m =>
EffApplyFlags
-> ActorId
-> ActorId
-> ActorId
-> ItemId
-> Container
-> ItemFull
-> m UseResult
effectAndDestroyAndAddKill
                       EffApplyFlags
effApplyFlags
                       ActorId
aid ActorId
aid ActorId
aid ItemId
iid (ActorId -> CStore -> Container
CActor ActorId
aid CStore
cstore) ItemFull
itemFull
      applyPeriodicActor :: (ActorId, Actor) -> m ()
applyPeriodicActor (ActorId
aid, Actor
b) =
        -- While it's fun when projectiles flash or speed up mid-air,
        -- it's very exotic and quite time-intensive whenever hundreds
        -- of projectiles exist due to ongoing explosions.
        -- Nothing activates when actor dying to prevent a regenerating
        -- actor from resurrecting each turn, resulting in silly gameover stats.
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Actor -> Bool
bproj Actor
b) Bool -> Bool -> Bool
&& Actor -> Int64
bhp Actor
b Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0 Bool -> Bool -> Bool
&& Actor -> LevelId
blid Actor
b LevelId -> EnumSet LevelId -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
`ES.member` EnumSet LevelId
arenas) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          -- Equipment goes first, to refresh organs before they expire,
          -- to avoid the message that organ expired.
          ((ItemId, ItemQuant) -> m ()) -> [(ItemId, ItemQuant)] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (ActorId -> CStore -> (ItemId, ItemQuant) -> m ()
forall (m :: * -> *) a a.
MonadServerAtomic m =>
ActorId -> CStore -> (ItemId, (a, [a])) -> m ()
applyPeriodicItem ActorId
aid CStore
CEqp) ([(ItemId, ItemQuant)] -> m ()) -> [(ItemId, ItemQuant)] -> m ()
forall a b. (a -> b) -> a -> b
$ ItemBag -> [(ItemId, ItemQuant)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs (ItemBag -> [(ItemId, ItemQuant)])
-> ItemBag -> [(ItemId, ItemQuant)]
forall a b. (a -> b) -> a -> b
$ Actor -> ItemBag
beqp Actor
b
          ((ItemId, ItemQuant) -> m ()) -> [(ItemId, ItemQuant)] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (ActorId -> CStore -> (ItemId, ItemQuant) -> m ()
forall (m :: * -> *) a a.
MonadServerAtomic m =>
ActorId -> CStore -> (ItemId, (a, [a])) -> m ()
applyPeriodicItem ActorId
aid CStore
COrgan) ([(ItemId, ItemQuant)] -> m ()) -> [(ItemId, ItemQuant)] -> m ()
forall a b. (a -> b) -> a -> b
$ ItemBag -> [(ItemId, ItemQuant)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs (ItemBag -> [(ItemId, ItemQuant)])
-> ItemBag -> [(ItemId, ItemQuant)]
forall a b. (a -> b) -> a -> b
$ Actor -> ItemBag
borgan Actor
b
          -- While we are at it, also update his Calm.
          ActorId -> Actor -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> Actor -> m ()
manageCalmAndDomination ActorId
aid Actor
b
  ActorDict
allActors <- (State -> ActorDict) -> m ActorDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> ActorDict
sactorD
  ((ActorId, Actor) -> m ()) -> [(ActorId, Actor)] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (ActorId, Actor) -> m ()
applyPeriodicActor ([(ActorId, Actor)] -> m ()) -> [(ActorId, Actor)] -> m ()
forall a b. (a -> b) -> a -> b
$ ActorDict -> [(ActorId, Actor)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs ActorDict
allActors

handleTrajectories :: MonadServerAtomic m => LevelId -> FactionId -> m ()
handleTrajectories :: LevelId -> FactionId -> m ()
handleTrajectories LevelId
lid FactionId
fid = do
  Time
localTime <- (State -> Time) -> m Time
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Time) -> m Time) -> (State -> Time) -> m Time
forall a b. (a -> b) -> a -> b
$ LevelId -> State -> Time
getLocalTime LevelId
lid
  EnumMap ActorId Time
levelTime <- (StateServer -> EnumMap ActorId Time) -> m (EnumMap ActorId Time)
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> EnumMap ActorId Time) -> m (EnumMap ActorId Time))
-> (StateServer -> EnumMap ActorId Time)
-> m (EnumMap ActorId Time)
forall a b. (a -> b) -> a -> b
$ (EnumMap LevelId (EnumMap ActorId Time)
-> LevelId -> EnumMap ActorId Time
forall k a. Enum k => EnumMap k a -> k -> a
EM.! LevelId
lid) (EnumMap LevelId (EnumMap ActorId Time) -> EnumMap ActorId Time)
-> (StateServer -> EnumMap LevelId (EnumMap ActorId Time))
-> StateServer
-> EnumMap ActorId Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
-> FactionId -> EnumMap LevelId (EnumMap ActorId Time)
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid) (EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
 -> EnumMap LevelId (EnumMap ActorId Time))
-> (StateServer
    -> EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time)))
-> StateServer
-> EnumMap LevelId (EnumMap ActorId Time)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer
-> EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
strajTime
  let l :: [ActorId]
l = [ActorId] -> [ActorId]
forall a. Ord a => [a] -> [a]
sort ([ActorId] -> [ActorId]) -> [ActorId] -> [ActorId]
forall a b. (a -> b) -> a -> b
$ ((ActorId, Time) -> ActorId) -> [(ActorId, Time)] -> [ActorId]
forall a b. (a -> b) -> [a] -> [b]
map (ActorId, Time) -> ActorId
forall a b. (a, b) -> a
fst
          ([(ActorId, Time)] -> [ActorId]) -> [(ActorId, Time)] -> [ActorId]
forall a b. (a -> b) -> a -> b
$ ((ActorId, Time) -> Bool) -> [(ActorId, Time)] -> [(ActorId, Time)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ActorId
_, Time
atime) -> Time
atime Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Time
localTime) ([(ActorId, Time)] -> [(ActorId, Time)])
-> [(ActorId, Time)] -> [(ActorId, Time)]
forall a b. (a -> b) -> a -> b
$ EnumMap ActorId Time -> [(ActorId, Time)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs EnumMap ActorId Time
levelTime
  -- The @strajTime@ map may be outdated before @hTrajectories@
  -- call (due to other actors following their trajectories),
  -- so it's only used to decide which actors are processed in this
  -- @handleTrajectories@ call. If an actor is added to the map,
  -- the recursive call to @handleTrajectories@ will detect that
  -- and process him later on.
  -- If the actor is no longer on the level or no longer belongs
  -- to the faction, it is nevertheless processed without a problem.
  -- We are guaranteed the actor still exists.
  (ActorId -> m ()) -> [ActorId] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ ActorId -> m ()
forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
hTrajectories [ActorId]
l
  -- Avoid frames between fadeout and fadein.
  Bool
breakLoop <- (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> Bool
sbreakLoop
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ActorId] -> Bool
forall a. [a] -> Bool
null [ActorId]
l Bool -> Bool -> Bool
|| Bool
breakLoop) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    LevelId -> FactionId -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
LevelId -> FactionId -> m ()
handleTrajectories LevelId
lid FactionId
fid  -- for speeds > tile/clip

hTrajectories :: MonadServerAtomic m => ActorId -> m ()
{-# INLINE hTrajectories #-}
hTrajectories :: ActorId -> m ()
hTrajectories ActorId
aid = do
  Actor
b1 <- (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 removePushed :: Actor -> m ()
removePushed Actor
b =
        -- No longer fulfills criteria and was not removed by dying; remove him.
        (StateServer -> StateServer) -> m ()
forall (m :: * -> *).
MonadServer m =>
(StateServer -> StateServer) -> m ()
modifyServer ((StateServer -> StateServer) -> m ())
-> (StateServer -> StateServer) -> m ()
forall a b. (a -> b) -> a -> b
$ \StateServer
ser ->
          StateServer
ser { strajTime :: EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
strajTime =
                  (EnumMap LevelId (EnumMap ActorId Time)
 -> EnumMap LevelId (EnumMap ActorId Time))
-> FactionId
-> EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
-> EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
forall k a. Enum k => (a -> a) -> k -> EnumMap k a -> EnumMap k a
EM.adjust ((EnumMap ActorId Time -> EnumMap ActorId Time)
-> LevelId
-> EnumMap LevelId (EnumMap ActorId Time)
-> EnumMap LevelId (EnumMap ActorId Time)
forall k a. Enum k => (a -> a) -> k -> EnumMap k a -> EnumMap k a
EM.adjust (ActorId -> EnumMap ActorId Time -> EnumMap ActorId Time
forall k a. Enum k => k -> EnumMap k a -> EnumMap k a
EM.delete ActorId
aid) (Actor -> LevelId
blid Actor
b)) (Actor -> FactionId
bfid Actor
b)
                            (StateServer
-> EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
strajTime StateServer
ser)
              , strajPushedBy :: ActorPushedBy
strajPushedBy = ActorId -> ActorPushedBy -> ActorPushedBy
forall k a. Enum k => k -> EnumMap k a -> EnumMap k a
EM.delete ActorId
aid (StateServer -> ActorPushedBy
strajPushedBy StateServer
ser) }
      removeTrajectory :: Actor -> m ()
removeTrajectory Actor
b =
        -- Non-projectile actor stops flying (a projectile with empty trajectory
        -- would be intercepted earlier on as dead).
        -- Will be removed from @strajTime@ in recursive call
        -- to @handleTrajectories@.
        Bool -> m () -> m ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Actor -> Bool
bproj Actor
b)
        (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId
-> Maybe ([Vector], Speed) -> Maybe ([Vector], Speed) -> UpdAtomic
UpdTrajectory ActorId
aid (Actor -> Maybe ([Vector], Speed)
btrajectory Actor
b) Maybe ([Vector], Speed)
forall a. Maybe a
Nothing
  Bool
breakLoop <- (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> Bool
sbreakLoop
  if Bool
breakLoop then () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- don't move if game over via pushing
  else if Actor -> Bool
actorDying Actor
b1 then ActorId -> Actor -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> Actor -> m ()
dieSer ActorId
aid Actor
b1
  else case Actor -> Maybe ([Vector], Speed)
btrajectory Actor
b1 of
    Maybe ([Vector], Speed)
Nothing -> Actor -> m ()
removePushed Actor
b1
    Just ([], Speed
_) -> Actor -> m ()
removeTrajectory Actor
b1 m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Actor -> m ()
removePushed Actor
b1
    Just{} -> do
      ActorId -> Actor -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> Actor -> m ()
advanceTrajectory ActorId
aid Actor
b1
      -- Here, @advanceTrajectory@ might have affected @actorDying@,
      -- so we check again ASAP to make sure the body of the projectile
      -- (or pushed actor) doesn't block movement of other actors,
      -- but vanishes promptly.
      -- Bodies of actors that die not flying remain on the battlefied until
      -- their natural next turn, to give them a chance of rescue.
      -- Note that domination of pushed actors is not checked
      -- nor is their calm updated. They are helpless wrt movement,
      -- but also invulnerable in this respect.
      Actor
b2 <- (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
      if Actor -> Bool
actorDying Actor
b2
      then ActorId -> Actor -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> Actor -> m ()
dieSer ActorId
aid Actor
b2
      else case Actor -> Maybe ([Vector], Speed)
btrajectory Actor
b2 of
        Maybe ([Vector], Speed)
Nothing -> Actor -> m ()
removePushed Actor
b2
        Just ([], Speed
_) -> Actor -> m ()
removeTrajectory Actor
b2 m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Actor -> m ()
removePushed Actor
b2
        Just{} -> -- delay next iteration only if still flying
          ActorId -> m ()
forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
advanceTimeTraj ActorId
aid
  -- if @actorDying@ due to @bhp b <= 0@:
  -- If @b@ is a projectile, it means hits an actor or is hit by actor.
  -- Then the carried item is destroyed and that's all.
  -- If @b@ is not projectile, it dies, his items drop to the ground
  -- and possibly a new leader is elected.
  --
  -- if @actorDying@ due to @btrajectory@ null:
  -- A projectile drops to the ground due to obstacles or range.
  -- The carried item is not destroyed, unless it's fragile,
  -- but drops to the ground.

-- | Manage trajectory of a projectile or a pushed other actor.
--
-- Colliding with a wall or actor doesn't take time, because
-- the projectile does not move (the move is blocked).
-- Not advancing time forces dead projectiles to be destroyed ASAP.
-- Otherwise, with some timings, it can stay on the game map dead,
-- blocking path of human-controlled actors and alarming the hapless human.
advanceTrajectory :: MonadServerAtomic m => ActorId -> Actor -> m ()
advanceTrajectory :: ActorId -> Actor -> m ()
advanceTrajectory ActorId
aid Actor
b1 = 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 -> m Level) -> LevelId -> m Level
forall a b. (a -> b) -> a -> b
$ Actor -> LevelId
blid Actor
b1
  AspectRecord
arTrunk <- (State -> AspectRecord) -> m AspectRecord
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> AspectRecord) -> m AspectRecord)
-> (State -> AspectRecord) -> m AspectRecord
forall a b. (a -> b) -> a -> b
$ (EnumMap ItemId AspectRecord -> ItemId -> AspectRecord
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> ItemId
btrunk Actor
b1) (EnumMap ItemId AspectRecord -> AspectRecord)
-> (State -> EnumMap ItemId AspectRecord) -> State -> AspectRecord
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EnumMap ItemId AspectRecord
sdiscoAspect
  let registerKill :: KillHow -> m ()
registerKill KillHow
killHow =
        -- Kill counts for each blast particle is TMI.
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Actor -> Bool
bproj Actor
b1
              Bool -> Bool -> Bool
&& Bool -> Bool
not (Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Blast AspectRecord
arTrunk)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          ActorId
killer <- (StateServer -> ActorId) -> m ActorId
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> ActorId) -> m ActorId)
-> (StateServer -> ActorId) -> m ActorId
forall a b. (a -> b) -> a -> b
$ ActorId -> ActorId -> ActorPushedBy -> ActorId
forall k a. Enum k => a -> k -> EnumMap k a -> a
EM.findWithDefault ActorId
aid ActorId
aid (ActorPushedBy -> ActorId)
-> (StateServer -> ActorPushedBy) -> StateServer -> ActorId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ActorPushedBy
strajPushedBy
          ActorId -> KillHow -> FactionId -> ItemId -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> KillHow -> FactionId -> ItemId -> m ()
addKillToAnalytics ActorId
killer KillHow
killHow (Actor -> FactionId
bfid Actor
b1) (Actor -> ItemId
btrunk Actor
b1)
  case Actor -> Maybe ([Vector], Speed)
btrajectory Actor
b1 of
    Just (Vector
d : [Vector]
lv, Speed
speed) -> do
      let tpos :: Point
tpos = Actor -> Point
bpos Actor
b1 Point -> Vector -> Point
`shift` Vector
d  -- target position
      if TileSpeedup -> ContentId TileKind -> Bool
Tile.isWalkable TileSpeedup
coTileSpeedup (ContentId TileKind -> Bool) -> ContentId TileKind -> Bool
forall a b. (a -> b) -> a -> b
$ Level
lvl Level -> Point -> ContentId TileKind
`at` Point
tpos then do
           -- Hit will clear trajectories in @reqMelee@,
           -- so no need to do that here.
           UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId
-> Maybe ([Vector], Speed) -> Maybe ([Vector], Speed) -> UpdAtomic
UpdTrajectory ActorId
aid (Actor -> Maybe ([Vector], Speed)
btrajectory Actor
b1) (([Vector], Speed) -> Maybe ([Vector], Speed)
forall a. a -> Maybe a
Just ([Vector]
lv, Speed
speed))
           Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Vector] -> Bool
forall a. [a] -> Bool
null [Vector]
lv) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ KillHow -> m ()
registerKill KillHow
KillDropLaunch
           let occupied :: Bool
occupied = Point -> Level -> Bool
occupiedBigLvl Point
tpos Level
lvl Bool -> Bool -> Bool
|| Point -> Level -> Bool
occupiedProjLvl Point
tpos Level
lvl
               reqMoveHit :: m ()
reqMoveHit = Bool -> Bool -> ActorId -> Vector -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
Bool -> Bool -> ActorId -> Vector -> m ()
reqMoveGeneric Bool
False Bool
True ActorId
aid Vector
d
               reqDisp :: ActorId -> m ()
reqDisp = Bool -> ActorId -> ActorId -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
Bool -> ActorId -> ActorId -> m ()
reqDisplaceGeneric Bool
False ActorId
aid
           if | Actor -> Bool
bproj Actor
b1 -> m ()
reqMoveHit  -- projectiles always hit
              | Bool
occupied ->
                -- Non-projectiles displace if they are ending their flight
                -- or if only a projectile is in the way.
                -- So, no chaos of displacing a whole line of enemies.
                case (Point -> Level -> Maybe ActorId
posToBigLvl Point
tpos Level
lvl, Point -> Level -> [ActorId]
posToProjsLvl Point
tpos Level
lvl) of
                  (Maybe ActorId
Nothing, []) -> String -> m ()
forall a. (?callStack::CallStack) => String -> a
error String
"advanceTrajectory: not occupied"
                  (Maybe ActorId
Nothing, [ActorId
target]) -> ActorId -> m ()
reqDisp ActorId
target
                  (Maybe ActorId
Nothing, [ActorId]
_) -> m ()
reqMoveHit  -- can't displace multiple
                  (Just ActorId
target, []) ->
                    if [Vector] -> Bool
forall a. [a] -> Bool
null [Vector]
lv then ActorId -> m ()
reqDisp ActorId
target else m ()
reqMoveHit
                  (Just ActorId
_, [ActorId]
_) -> m ()
reqMoveHit  -- can't displace multiple
              | Bool
otherwise -> m ()
reqMoveHit  -- if not occupied, just move
      else do
           -- Will be removed from @strajTime@ in recursive call
           -- to @handleTrajectories@.
           Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Actor -> Bool
bproj Actor
b1) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
             SfxAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => SfxAtomic -> m ()
execSfxAtomic (SfxAtomic -> m ()) -> SfxAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> Point -> SfxAtomic
SfxCollideTile ActorId
aid Point
tpos
           ItemBag
embedsPre <- (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
$ LevelId -> Point -> State -> ItemBag
getEmbedBag (Actor -> LevelId
blid Actor
b1) Point
tpos
           -- No crafting by projectiles that bump tiles nor by pushed actors.
           -- The only way is if they land in a tile (are engulfed by it)
           -- and have enough skill. But projectiles transform when hitting,
           -- if terrain permits, not just bump off the obstacle.
           Maybe ReqFailure
mfail <- Bool
-> EffToUse -> Bool -> ActorId -> Point -> m (Maybe ReqFailure)
forall (m :: * -> *).
MonadServerAtomic m =>
Bool
-> EffToUse -> Bool -> ActorId -> Point -> m (Maybe ReqFailure)
reqAlterFail (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Actor -> Bool
bproj Actor
b1) EffToUse
EffBare Bool
False ActorId
aid Point
tpos
           ItemBag
embedsPost <- (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
$ LevelId -> Point -> State -> ItemBag
getEmbedBag (Actor -> LevelId
blid Actor
b1) Point
tpos
           Actor
b2 <- (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 tpos2 :: Point
tpos2 = Actor -> Point
bpos Actor
b2 Point -> Vector -> Point
`shift` Vector
d  -- possibly another level and/or bpos
           Level
lvl2 <- 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
b2
           case Maybe ReqFailure
mfail of
             Maybe ReqFailure
Nothing | TileSpeedup -> ContentId TileKind -> Bool
Tile.isWalkable TileSpeedup
coTileSpeedup (ContentId TileKind -> Bool) -> ContentId TileKind -> Bool
forall a b. (a -> b) -> a -> b
$ Level
lvl2 Level -> Point -> ContentId TileKind
`at` Point
tpos2 ->
               -- Too late to announce anything, but given that the way
               -- is opened, continue flight. Don't even normally lose any HP,
               -- because it's not a hard collision, but altering.
               -- However, if embed was possibly triggered/removed, lose HP.
               if ItemBag
embedsPre ItemBag -> ItemBag -> Bool
forall a. Eq a => a -> a -> Bool
/= ItemBag
embedsPost Bool -> Bool -> Bool
&& Bool -> Bool
not (ItemBag -> Bool
forall k a. EnumMap k a -> Bool
EM.null ItemBag
embedsPre) then
                 if Actor -> Int64
bhp Actor
b2 Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
oneM then do
                   UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> Int64 -> UpdAtomic
UpdRefillHP ActorId
aid Int64
minusM
                   Actor
b3 <- (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
                   ActorId -> Actor -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> Actor -> m ()
advanceTrajectory ActorId
aid Actor
b3
                 else do
                   -- Projectile has too low HP to pierce; terminate its flight.
                   UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId
-> Maybe ([Vector], Speed) -> Maybe ([Vector], Speed) -> UpdAtomic
UpdTrajectory ActorId
aid (Actor -> Maybe ([Vector], Speed)
btrajectory Actor
b2)
                                 (Maybe ([Vector], Speed) -> UpdAtomic)
-> Maybe ([Vector], Speed) -> UpdAtomic
forall a b. (a -> b) -> a -> b
$ ([Vector], Speed) -> Maybe ([Vector], Speed)
forall a. a -> Maybe a
Just ([], Speed
speed)
                   KillHow -> m ()
registerKill KillHow
KillTileLaunch
               else
                 -- Try again with the cleared path and possibly actors
                 -- spawned in the way, etc.
                 ActorId -> Actor -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> Actor -> m ()
advanceTrajectory ActorId
aid Actor
b2
             Maybe ReqFailure
_ -> do
               -- Altering failed to open the passage, probably just a wall,
               -- so lose HP due to being pushed into an obstacle.
               -- Never kill in this way.
               -- Note that sometimes this may come already after one faction
               -- wins the game and end game screens are show. This is OK-ish.
               -- @Nothing@ trajectory of signals an obstacle hit.
               -- If projectile, second call of @actorDying@ above
               -- will take care of dropping dead.
               UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId
-> Maybe ([Vector], Speed) -> Maybe ([Vector], Speed) -> UpdAtomic
UpdTrajectory ActorId
aid (Actor -> Maybe ([Vector], Speed)
btrajectory Actor
b2) Maybe ([Vector], Speed)
forall a. Maybe a
Nothing
               -- If projectile, losing HP due to hitting an obstacle
               -- not needed, because trajectory is halted, so projectile
               -- will die soon anyway
               if Actor -> Bool
bproj Actor
b2
               then KillHow -> m ()
registerKill KillHow
KillTileLaunch
               else Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Actor -> Int64
bhp Actor
b2 Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
oneM) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                 UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> Int64 -> UpdAtomic
UpdRefillHP ActorId
aid Int64
minusM
                 let effect :: Effect
effect = Int -> Effect
IK.RefillHP (-Int
2)  -- -2 is a lie to ensure display
                 SfxAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => SfxAtomic -> m ()
execSfxAtomic (SfxAtomic -> m ()) -> SfxAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> ActorId -> ItemId -> Effect -> Int64 -> SfxAtomic
SfxEffect (Actor -> FactionId
bfid Actor
b2) ActorId
aid (Actor -> ItemId
btrunk Actor
b2) Effect
effect (-Int64
1)
    Maybe ([Vector], Speed)
_ -> String -> m ()
forall a. (?callStack::CallStack) => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Nothing or empty trajectory" String -> (ActorId, Actor) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
aid, Actor
b1)

handleActors :: (MonadServerAtomic m, MonadServerComm m)
             => LevelId -> FactionId -> m Bool
handleActors :: LevelId -> FactionId -> m Bool
handleActors LevelId
lid FactionId
fid = do
  Time
localTime <- (State -> Time) -> m Time
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Time) -> m Time) -> (State -> Time) -> m Time
forall a b. (a -> b) -> a -> b
$ LevelId -> State -> Time
getLocalTime LevelId
lid
  EnumMap ActorId Time
levelTime <- (StateServer -> EnumMap ActorId Time) -> m (EnumMap ActorId Time)
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> EnumMap ActorId Time) -> m (EnumMap ActorId Time))
-> (StateServer -> EnumMap ActorId Time)
-> m (EnumMap ActorId Time)
forall a b. (a -> b) -> a -> b
$ (EnumMap LevelId (EnumMap ActorId Time)
-> LevelId -> EnumMap ActorId Time
forall k a. Enum k => EnumMap k a -> k -> a
EM.! LevelId
lid) (EnumMap LevelId (EnumMap ActorId Time) -> EnumMap ActorId Time)
-> (StateServer -> EnumMap LevelId (EnumMap ActorId Time))
-> StateServer
-> EnumMap ActorId Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
-> FactionId -> EnumMap LevelId (EnumMap ActorId Time)
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid) (EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
 -> EnumMap LevelId (EnumMap ActorId Time))
-> (StateServer
    -> EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time)))
-> StateServer
-> EnumMap LevelId (EnumMap ActorId Time)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer
-> EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
sactorTime
  let l :: [ActorId]
l = [ActorId] -> [ActorId]
forall a. Ord a => [a] -> [a]
sort ([ActorId] -> [ActorId]) -> [ActorId] -> [ActorId]
forall a b. (a -> b) -> a -> b
$ ((ActorId, Time) -> ActorId) -> [(ActorId, Time)] -> [ActorId]
forall a b. (a -> b) -> [a] -> [b]
map (ActorId, Time) -> ActorId
forall a b. (a, b) -> a
fst
          ([(ActorId, Time)] -> [ActorId]) -> [(ActorId, Time)] -> [ActorId]
forall a b. (a -> b) -> a -> b
$ ((ActorId, Time) -> Bool) -> [(ActorId, Time)] -> [(ActorId, Time)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ActorId
_, Time
atime) -> Time
atime Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Time
localTime) ([(ActorId, Time)] -> [(ActorId, Time)])
-> [(ActorId, Time)] -> [(ActorId, Time)]
forall a b. (a -> b) -> a -> b
$ EnumMap ActorId Time -> [(ActorId, Time)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs EnumMap ActorId Time
levelTime
  -- The @sactorTime@ map may be outdated before @hActors@
  -- call (due to other actors on the list acting),
  -- so it's only used to decide which actors are processed in this call.
  -- If the actor is no longer on the level or no longer belongs
  -- to the faction, it is nevertheless processed without a problem
  -- (the client may act wrt slightly outdated Perception and that's all).
  -- We are guaranteed the actor still exists.
  Maybe ActorId
mleader <- (State -> Maybe ActorId) -> m (Maybe ActorId)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Maybe ActorId) -> m (Maybe ActorId))
-> (State -> Maybe ActorId) -> m (Maybe ActorId)
forall a b. (a -> b) -> a -> b
$ Faction -> Maybe ActorId
gleader (Faction -> Maybe ActorId)
-> (State -> Faction) -> State -> Maybe ActorId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid) (FactionDict -> Faction)
-> (State -> FactionDict) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> FactionDict
sfactionD
  -- Leader acts first, so that UI leader can save&exit before state changes.
  [ActorId] -> m Bool
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
[ActorId] -> m Bool
hActors ([ActorId] -> m Bool) -> [ActorId] -> m Bool
forall a b. (a -> b) -> a -> b
$ case Maybe ActorId
mleader of
    Just ActorId
aid | ActorId
aid ActorId -> [ActorId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ActorId]
l -> ActorId
aid ActorId -> [ActorId] -> [ActorId]
forall a. a -> [a] -> [a]
: ActorId -> [ActorId] -> [ActorId]
forall a. Eq a => a -> [a] -> [a]
delete ActorId
aid [ActorId]
l
    Maybe ActorId
_ -> [ActorId]
l

hActors :: forall m. (MonadServerAtomic m, MonadServerComm m)
        => [ActorId] -> m Bool
hActors :: [ActorId] -> m Bool
hActors [] = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
hActors as :: [ActorId]
as@(ActorId
aid : [ActorId]
rest) = do
 Actor
b1 <- (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. (?callStack::CallStack) => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Actor -> Bool
bproj Actor
b1) ()
 if Actor -> Int64
bhp Actor
b1 Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
0 then
   -- Will be killed in a later pass, making it possible to revive him now.
   [ActorId] -> m Bool
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
[ActorId] -> m Bool
hActors [ActorId]
rest
 else do
  let side :: FactionId
side = Actor -> FactionId
bfid Actor
b1
  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
$ (FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
side) (FactionDict -> Faction)
-> (State -> FactionDict) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> FactionDict
sfactionD
  Bool
breakLoop <- (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> Bool
sbreakLoop
  let mleader :: Maybe ActorId
mleader = Faction -> Maybe ActorId
gleader Faction
fact
      aidIsLeader :: Bool
aidIsLeader = Maybe ActorId
mleader Maybe ActorId -> Maybe ActorId -> Bool
forall a. Eq a => a -> a -> Bool
== ActorId -> Maybe ActorId
forall a. a -> Maybe a
Just ActorId
aid
      mainUIactor :: Bool
mainUIactor = FactionKind -> Bool
fhasUI (Faction -> FactionKind
gkind Faction
fact)
                    Bool -> Bool -> Bool
&& (Bool
aidIsLeader Bool -> Bool -> Bool
|| Bool -> Bool
not (FactionKind -> Bool
fhasPointman (Faction -> FactionKind
gkind Faction
fact)))
      -- Checking @breakLoop@, to avoid doubly setting faction status to Camping
      -- in case AI-controlled UI client asks to exit game at exactly
      -- the same moment as natural game over was detected.
      mainUIunderAI :: Bool
mainUIunderAI = Bool
mainUIactor Bool -> Bool -> Bool
&& Faction -> Bool
gunderAI Faction
fact Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
breakLoop
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
mainUIunderAI (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    FactionId -> ActorId -> m ()
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
FactionId -> ActorId -> m ()
handleUIunderAI FactionId
side ActorId
aid
  Faction
factNew <- (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
$ (FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
side) (FactionDict -> Faction)
-> (State -> FactionDict) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> FactionDict
sfactionD
  let doQueryAI :: Bool
doQueryAI = Bool -> Bool
not Bool
mainUIactor Bool -> Bool -> Bool
|| Faction -> Bool
gunderAI Faction
factNew
  Bool
breakASAP <- (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> Bool
sbreakASAP
  -- If breaking out of the game loop, pretend there was a non-wait move.
  -- we don't need additionally to check @sbreakLoop@, because it occurs alone
  -- only via action of an actor and at most one action is performed here.
  if Bool
breakASAP then Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else do
    let mswitchLeader :: Maybe ActorId -> m ActorId
        {-# NOINLINE mswitchLeader #-}
        mswitchLeader :: Maybe ActorId -> m ActorId
mswitchLeader (Just ActorId
aidNew) = FactionId -> ActorId -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> ActorId -> m ()
switchLeader FactionId
side ActorId
aidNew m () -> m ActorId -> m ActorId
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ActorId -> m ActorId
forall (m :: * -> *) a. Monad m => a -> m a
return ActorId
aidNew
        mswitchLeader Maybe ActorId
Nothing = ActorId -> m ActorId
forall (m :: * -> *) a. Monad m => a -> m a
return ActorId
aid
    (ActorId
aidNew, Maybe RequestTimed
mtimed) <-
      if Bool
doQueryAI then do
        (ReqAI
cmd, Maybe ActorId
maid) <- FactionId -> ActorId -> m (ReqAI, Maybe ActorId)
forall (m :: * -> *).
MonadServerComm m =>
FactionId -> ActorId -> m (ReqAI, Maybe ActorId)
sendQueryAI FactionId
side ActorId
aid
        ActorId
aidNew <- Maybe ActorId -> m ActorId
mswitchLeader Maybe ActorId
maid
        Maybe RequestTimed
mtimed <- ReqAI -> m (Maybe RequestTimed)
forall (m :: * -> *).
MonadServerAtomic m =>
ReqAI -> m (Maybe RequestTimed)
handleRequestAI ReqAI
cmd
        (ActorId, Maybe RequestTimed) -> m (ActorId, Maybe RequestTimed)
forall (m :: * -> *) a. Monad m => a -> m a
return (ActorId
aidNew, Maybe RequestTimed
mtimed)
      else do
        (ReqUI
cmd, Maybe ActorId
maid) <- Response -> FactionId -> ActorId -> m (ReqUI, Maybe ActorId)
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
Response -> FactionId -> ActorId -> m (ReqUI, Maybe ActorId)
sendQueryUI Response
RespQueryUI FactionId
side ActorId
aid
        ActorId
aidNew <- Maybe ActorId -> m ActorId
mswitchLeader Maybe ActorId
maid
        Maybe RequestTimed
mtimed <- FactionId -> ActorId -> ReqUI -> m (Maybe RequestTimed)
forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> ActorId -> ReqUI -> m (Maybe RequestTimed)
handleRequestUI FactionId
side ActorId
aidNew ReqUI
cmd
        (ActorId, Maybe RequestTimed) -> m (ActorId, Maybe RequestTimed)
forall (m :: * -> *) a. Monad m => a -> m a
return (ActorId
aidNew, Maybe RequestTimed
mtimed)
    case Maybe RequestTimed
mtimed of
      Just RequestTimed
timed -> do
        Bool
nonWaitMove <- FactionId -> ActorId -> RequestTimed -> m Bool
forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> ActorId -> RequestTimed -> m Bool
handleRequestTimed FactionId
side ActorId
aidNew RequestTimed
timed
        -- Even if the actor got a free turn of time via a scroll,
        -- he will not act again this clip, only next clip.
        -- Clip is small, so not a big deal and it's faster and avoids
        -- complete game time freezes, e.g., due to an exploit.
        if Bool
nonWaitMove then Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else [ActorId] -> m Bool
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
[ActorId] -> m Bool
hActors [ActorId]
rest
      Maybe RequestTimed
Nothing -> do
        Bool
breakASAP2 <- (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> Bool
sbreakASAP
        -- If breaking out of the game lopp, pretend there was a non-wait move.
        if Bool
breakASAP2 then Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else [ActorId] -> m Bool
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
[ActorId] -> m Bool
hActors [ActorId]
as

handleUIunderAI :: (MonadServerAtomic m, MonadServerComm m)
                => FactionId -> ActorId -> m ()
handleUIunderAI :: FactionId -> ActorId -> m ()
handleUIunderAI FactionId
side ActorId
aid = do
  (ReqUI, Maybe ActorId)
cmdS <- Response -> FactionId -> ActorId -> m (ReqUI, Maybe ActorId)
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
Response -> FactionId -> ActorId -> m (ReqUI, Maybe ActorId)
sendQueryUI Response
RespQueryUIunderAI FactionId
side ActorId
aid
  case (ReqUI, Maybe ActorId) -> ReqUI
forall a b. (a, b) -> a
fst (ReqUI, Maybe ActorId)
cmdS of
    ReqUI
ReqUINop -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ReqUI
ReqUIAutomate -> UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> Bool -> UpdAtomic
UpdAutoFaction FactionId
side Bool
False
    ReqUI
ReqUIGameDropAndExit -> ActorId -> m ()
forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
reqGameDropAndExit ActorId
aid
    ReqUI
ReqUIGameSaveAndExit -> ActorId -> m ()
forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
reqGameSaveAndExit ActorId
aid
    ReqUI
_ -> String -> m ()
forall a. (?callStack::CallStack) => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"" String -> (ReqUI, Maybe ActorId) -> String
forall v. Show v => String -> v -> String
`showFailure` (ReqUI, Maybe ActorId)
cmdS

dieSer :: MonadServerAtomic m => ActorId -> Actor -> m ()
dieSer :: ActorId -> Actor -> m ()
dieSer ActorId
aid Actor
b2 = do
  if Actor -> Bool
bproj Actor
b2 then
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe ([Vector], Speed) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ([Vector], Speed) -> Bool)
-> Maybe ([Vector], Speed) -> Bool
forall a b. (a -> b) -> a -> b
$ Actor -> Maybe ([Vector], Speed)
btrajectory Actor
b2) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId
-> Maybe ([Vector], Speed) -> Maybe ([Vector], Speed) -> UpdAtomic
UpdTrajectory ActorId
aid (Actor -> Maybe ([Vector], Speed)
btrajectory Actor
b2) Maybe ([Vector], Speed)
forall a. Maybe a
Nothing
        -- needed only to ensure display of the last position of projectile
  else do
    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
$ ItemId -> State -> ContentId ItemKind
getIidKindIdServer (ItemId -> State -> ContentId ItemKind)
-> ItemId -> State -> ContentId ItemKind
forall a b. (a -> b) -> a -> b
$ Actor -> ItemId
btrunk Actor
b2
    UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> ContentId ItemKind -> Int -> UpdAtomic
UpdRecordKill ActorId
aid ContentId ItemKind
kindId Int
1
    -- At this point the actor's body exists and his items are not dropped.
    ActorId -> m ()
forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
deduceKilled ActorId
aid
    -- Most probabaly already done, but just in case (e.g., when actor
    -- created with 0 HP):
    FactionId -> LevelId -> ActorId -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> LevelId -> ActorId -> m ()
electLeader (Actor -> FactionId
bfid Actor
b2) (Actor -> LevelId
blid Actor
b2) ActorId
aid
  -- If an explosion blast, before the particle is destroyed, it tries
  -- to modify terrain with it as well as do some easy crafting,
  -- e.g., cooking on fire.
  AspectRecord
arTrunk <- (State -> AspectRecord) -> m AspectRecord
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> AspectRecord) -> m AspectRecord)
-> (State -> AspectRecord) -> m AspectRecord
forall a b. (a -> b) -> a -> b
$ (EnumMap ItemId AspectRecord -> ItemId -> AspectRecord
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> ItemId
btrunk Actor
b2) (EnumMap ItemId AspectRecord -> AspectRecord)
-> (State -> EnumMap ItemId AspectRecord) -> State -> AspectRecord
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EnumMap ItemId AspectRecord
sdiscoAspect
  let spentProj :: Bool
spentProj = Actor -> Bool
bproj Actor
b2 Bool -> Bool -> Bool
&& ItemBag -> Bool
forall k a. EnumMap k a -> Bool
EM.null (Actor -> ItemBag
beqp Actor
b2)
      isBlast :: Bool
isBlast = Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Blast AspectRecord
arTrunk
      -- Let thrown food cook in fire (crafting) and other projectiles
      -- transform terrain they fall onto. Big actors are inert at death.
      (EffToUse
effScope, Bool
bumping) = if Actor -> Bool
bproj Actor
b2
                            then (EffToUse
EffBareAndOnCombine, Bool
False)
                            else (EffToUse
EffBare, Bool
True)
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
spentProj Bool -> Bool -> Bool
&& Bool
isBlast) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    m (Maybe ReqFailure) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe ReqFailure) -> m ()) -> m (Maybe ReqFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Bool
-> EffToUse -> Bool -> ActorId -> Point -> m (Maybe ReqFailure)
forall (m :: * -> *).
MonadServerAtomic m =>
Bool
-> EffToUse -> Bool -> ActorId -> Point -> m (Maybe ReqFailure)
reqAlterFail Bool
bumping EffToUse
effScope Bool
False ActorId
aid (Actor -> Point
bpos Actor
b2)
  Actor
b3 <- (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
  -- Items need to do dropped now, so that they can be transformed by effects
  -- of the embedded items, if they are activated.
  -- If the actor was a projectile and no effect was triggered by hitting
  -- an enemy, the item still exists and @OnSmash@ effects will be triggered.
  ActorId -> Actor -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> Actor -> m ()
dropAllEquippedItems ActorId
aid Actor
b3
  -- Also destroy, not just drop, all organs, to trigger any effects.
  -- Note that some effects may be invoked on an actor that has
  -- no trunk any more. Conditions are ignored to avoid spam about them ending.
  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
b3 CStore
COrgan
  EnumMap ItemId AspectRecord
discoAspect <- (State -> EnumMap ItemId AspectRecord)
-> m (EnumMap ItemId AspectRecord)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> EnumMap ItemId AspectRecord
sdiscoAspect
  let f :: ItemId -> ItemQuant -> m ()
f = m UseResult -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m UseResult -> m ())
-> (ItemId -> ItemQuant -> m UseResult)
-> ItemId
-> ItemQuant
-> m ()
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> Bool
-> Bool
-> CStore
-> ActorId
-> Actor
-> Int
-> ItemId
-> ItemQuant
-> m UseResult
forall (m :: * -> *).
MonadServerAtomic m =>
Bool
-> Bool
-> CStore
-> ActorId
-> Actor
-> Int
-> ItemId
-> ItemQuant
-> m UseResult
dropCStoreItem Bool
False Bool
True CStore
COrgan ActorId
aid Actor
b3 Int
forall a. Bounded a => a
maxBound
      isCondition :: ItemId -> Bool
isCondition = Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Condition (AspectRecord -> Bool)
-> (ItemId -> AspectRecord) -> ItemId -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnumMap ItemId AspectRecord
discoAspect EnumMap ItemId AspectRecord -> ItemId -> AspectRecord
forall k a. Enum k => EnumMap k a -> k -> a
EM.!)
  ((ItemId, ItemQuant) -> m ()) -> [(ItemId, ItemQuant)] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ ((ItemId -> ItemQuant -> m ()) -> (ItemId, ItemQuant) -> m ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ItemId -> ItemQuant -> m ()
f) ([(ItemId, ItemQuant)] -> m ()) -> [(ItemId, ItemQuant)] -> m ()
forall a b. (a -> b) -> a -> b
$ ((ItemId, ItemQuant) -> Bool)
-> [(ItemId, ItemQuant)] -> [(ItemId, ItemQuant)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((ItemId, ItemQuant) -> Bool) -> (ItemId, ItemQuant) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ItemId -> Bool
isCondition (ItemId -> Bool)
-> ((ItemId, ItemQuant) -> ItemId) -> (ItemId, ItemQuant) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ItemId, ItemQuant) -> ItemId
forall a b. (a, b) -> a
fst) ([(ItemId, ItemQuant)] -> [(ItemId, ItemQuant)])
-> [(ItemId, ItemQuant)] -> [(ItemId, ItemQuant)]
forall a b. (a -> b) -> a -> b
$ ItemBag -> [(ItemId, ItemQuant)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs ItemBag
bag
  -- As the last act of heroism, the actor (even if projectile)
  -- changes the terrain with its embedded items, if possible.
  -- Note that all the resulting effects are invoked on an actor that has
  -- no trunk any more.
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
spentProj Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isBlast) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    m (Maybe ReqFailure) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe ReqFailure) -> m ()) -> m (Maybe ReqFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Bool
-> EffToUse -> Bool -> ActorId -> Point -> m (Maybe ReqFailure)
forall (m :: * -> *).
MonadServerAtomic m =>
Bool
-> EffToUse -> Bool -> ActorId -> Point -> m (Maybe ReqFailure)
reqAlterFail Bool
bumping EffToUse
effScope Bool
False ActorId
aid (Actor -> Point
bpos Actor
b2)
      -- old bpos; OK, safer
  Actor
b4 <- (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
  UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> Actor -> [(ItemId, Item)] -> UpdAtomic
UpdDestroyActor ActorId
aid Actor
b4 []

restartGame :: MonadServerAtomic m
            => m () -> m () -> Maybe (GroupName ModeKind) -> m ()
restartGame :: m () -> m () -> Maybe (GroupName ModeKind) -> m ()
restartGame m ()
updConn m ()
loop Maybe (GroupName ModeKind)
mgameMode = do
  -- This goes only to the old UI client.
  SfxAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => SfxAtomic -> m ()
execSfxAtomic SfxAtomic
SfxRestart
  ServerOptions
soptionsNxt <- (StateServer -> ServerOptions) -> m ServerOptions
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> ServerOptions
soptionsNxt
  SMGen
srandom <- (StateServer -> SMGen) -> m SMGen
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> SMGen
srandom
  FactionDict
factionDold <- (State -> FactionDict) -> m FactionDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> FactionDict
sfactionD
  -- Create new factions.
  State
s <- ServerOptions
-> Maybe (GroupName ModeKind) -> Maybe SMGen -> m State
forall (m :: * -> *).
MonadServer m =>
ServerOptions
-> Maybe (GroupName ModeKind) -> Maybe SMGen -> m State
gameReset ServerOptions
soptionsNxt Maybe (GroupName ModeKind)
mgameMode (SMGen -> Maybe SMGen
forall a. a -> Maybe a
Just SMGen
srandom)
  -- Note how we also no longer assert exploration, because there may not be
  -- enough time left in the debug run to explore again in a new game.
  let optionsBarRngs :: ServerOptions
optionsBarRngs = ServerOptions
soptionsNxt { sdungeonRng :: Maybe SMGen
sdungeonRng = Maybe SMGen
forall a. Maybe a
Nothing
                                   , smainRng :: Maybe SMGen
smainRng = Maybe SMGen
forall a. Maybe a
Nothing
                                   , sassertExplored :: Maybe Int
sassertExplored = Maybe Int
forall a. Maybe a
Nothing }
  (StateServer -> StateServer) -> m ()
forall (m :: * -> *).
MonadServer m =>
(StateServer -> StateServer) -> m ()
modifyServer ((StateServer -> StateServer) -> m ())
-> (StateServer -> StateServer) -> m ()
forall a b. (a -> b) -> a -> b
$ \StateServer
ser -> StateServer
ser { soptionsNxt :: ServerOptions
soptionsNxt = ServerOptions
optionsBarRngs
                             , soptions :: ServerOptions
soptions = ServerOptions
optionsBarRngs }
  -- This reaches only the intersection of old and new clients.
  UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ State -> UpdAtomic
UpdRestartServer State
s
  -- Spawn new clients, as needed, according to new factions.
  m ()
updConn
  m ()
forall (m :: * -> *). MonadServer m => m ()
initPer
  FactionDict -> m ()
forall (m :: * -> *). MonadServerAtomic m => FactionDict -> m ()
reinitGame FactionDict
factionDold
  -- Save a just started noConfirm game to preserve history of the just
  -- ended normal game, in case the user exits brutally.
  Bool -> Bool -> m ()
forall (m :: * -> *). MonadServerAtomic m => Bool -> Bool -> m ()
writeSaveAll Bool
False Bool
True
  m ()
loop