-- | Server operations performed periodically in the game loop
-- and related operations.
module Game.LambdaHack.Server.PeriodicM
  ( spawnMonster, addManyActors
  , advanceTime, advanceTimeTraj, overheadActorTime, swapTime
  , updateCalm, leadLevelSwitch
  , endOrLoop
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , addAnyActor, rollSpawnPos, gameExit
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import           Data.Int (Int64)
import qualified Data.IntMap.Strict as IM
import qualified Data.Text as T

import           Game.LambdaHack.Atomic
import           Game.LambdaHack.Common.Actor
import           Game.LambdaHack.Common.ActorState
import           Game.LambdaHack.Common.Area
import           Game.LambdaHack.Common.Faction
import           Game.LambdaHack.Common.Item
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.Point
import           Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import           Game.LambdaHack.Common.Time
import           Game.LambdaHack.Common.Types
import qualified Game.LambdaHack.Content.CaveKind as CK
import           Game.LambdaHack.Content.ItemKind (ItemKind)
import qualified Game.LambdaHack.Content.ItemKind as IK
import           Game.LambdaHack.Content.ModeKind
import           Game.LambdaHack.Core.Frequency
import           Game.LambdaHack.Core.Random
import qualified Game.LambdaHack.Definition.Ability as Ability
import           Game.LambdaHack.Definition.Defs
import           Game.LambdaHack.Server.CommonM
import           Game.LambdaHack.Server.ItemM
import           Game.LambdaHack.Server.ItemRev
import           Game.LambdaHack.Server.MonadServer
import           Game.LambdaHack.Server.ProtocolM
import           Game.LambdaHack.Server.ServerOptions
import           Game.LambdaHack.Server.State

-- | Spawn, possibly, a monster according to the level's actor groups.
-- We assume heroes are never spawned.
spawnMonster :: MonadServerAtomic m => m ()
spawnMonster :: m ()
spawnMonster = do
 COps{ContentData CaveKind
cocave :: COps -> ContentData CaveKind
cocave :: ContentData CaveKind
cocave} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
 EnumSet LevelId
arenas <- (StateServer -> EnumSet LevelId) -> m (EnumSet LevelId)
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> EnumSet LevelId
sarenas
 Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (EnumSet LevelId -> Bool
forall k. EnumSet k -> Bool
ES.null EnumSet LevelId
arenas) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  -- Do this on only one of the arenas to prevent micromanagement,
  -- e.g., spreading leaders across levels to bump monster generation.
  LevelId
arena <- Rnd LevelId -> m LevelId
forall (m :: * -> *) a. MonadServer m => Rnd a -> m a
rndToAction (Rnd LevelId -> m LevelId) -> Rnd LevelId -> m LevelId
forall a b. (a -> b) -> a -> b
$ [LevelId] -> Rnd LevelId
forall a. [a] -> Rnd a
oneOf ([LevelId] -> Rnd LevelId) -> [LevelId] -> Rnd LevelId
forall a b. (a -> b) -> a -> b
$ EnumSet LevelId -> [LevelId]
forall k. Enum k => EnumSet k -> [k]
ES.elems EnumSet LevelId
arenas
  Level{ContentId CaveKind
lkind :: Level -> ContentId CaveKind
lkind :: ContentId CaveKind
lkind, AbsDepth
ldepth :: Level -> AbsDepth
ldepth :: AbsDepth
ldepth, BigActorMap
lbig :: Level -> BigActorMap
lbig :: BigActorMap
lbig} <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel LevelId
arena
  let ck :: CaveKind
ck = ContentData CaveKind -> ContentId CaveKind -> CaveKind
forall a. ContentData a -> ContentId a -> a
okind ContentData CaveKind
cocave ContentId CaveKind
lkind
  if | CaveKind -> Int
CK.cactorCoeff CaveKind
ck Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| [(GroupName ItemKind, Int)] -> Bool
forall a. [a] -> Bool
null (CaveKind -> [(GroupName ItemKind, Int)]
CK.cactorFreq CaveKind
ck) -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     | BigActorMap -> Int
forall k a. EnumMap k a -> Int
EM.size BigActorMap
lbig Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
300 ->  -- probably not so rare, but debug anyway
       -- Gameplay consideration: not fun to slog through so many actors.
       -- Caves rarely start with more than 100.
       Text -> m ()
forall (m :: * -> *). MonadServer m => Text -> m ()
debugPossiblyPrint Text
"Server: spawnMonster: too many big actors on level"
     | Bool
otherwise -> do
       AbsDepth
totalDepth <- (State -> AbsDepth) -> m AbsDepth
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> AbsDepth
stotalDepth
       Int
lvlSpawned <- (StateServer -> Int) -> m Int
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> Int) -> m Int) -> (StateServer -> Int) -> m Int
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int)
-> (StateServer -> Maybe Int) -> StateServer -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LevelId -> EnumMap LevelId Int -> Maybe Int
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup LevelId
arena (EnumMap LevelId Int -> Maybe Int)
-> (StateServer -> EnumMap LevelId Int) -> StateServer -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> EnumMap LevelId Int
snumSpawned
       let perMillion :: Int
perMillion =
             AbsDepth -> AbsDepth -> Int -> Int -> Int
monsterGenChance AbsDepth
ldepth AbsDepth
totalDepth Int
lvlSpawned (CaveKind -> Int
CK.cactorCoeff CaveKind
ck)
           million :: Int
million = Int
1000000
       Int
k <- Rnd Int -> m Int
forall (m :: * -> *) a. MonadServer m => Rnd a -> m a
rndToAction (Rnd Int -> m Int) -> Rnd Int -> m Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Rnd Int
forall a. Integral a => (a, a) -> Rnd a
randomR (Int
1, Int
million)
       Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
perMillion) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
         let numToSpawn :: Int
numToSpawn | Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
perMillion = Int
3
                        | Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
perMillion = Int
2
                        | Bool
otherwise = Int
1
             alt :: Maybe a -> Maybe a
alt Maybe a
Nothing = a -> Maybe a
forall a. a -> Maybe a
Just a
1
             alt (Just a
n) = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a
1
         (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 { snumSpawned :: EnumMap LevelId Int
snumSpawned = LevelId -> Int -> EnumMap LevelId Int -> EnumMap LevelId Int
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert LevelId
arena (Int
lvlSpawned Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numToSpawn)
                               (EnumMap LevelId Int -> EnumMap LevelId Int)
-> EnumMap LevelId Int -> EnumMap LevelId Int
forall a b. (a -> b) -> a -> b
$ StateServer -> EnumMap LevelId Int
snumSpawned StateServer
ser
               , sbandSpawned :: IntMap Int
sbandSpawned = (Maybe Int -> Maybe Int) -> Int -> IntMap Int -> IntMap Int
forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter Maybe Int -> Maybe Int
forall a. Num a => Maybe a -> Maybe a
alt Int
numToSpawn
                                (IntMap Int -> IntMap Int) -> IntMap Int -> IntMap Int
forall a b. (a -> b) -> a -> b
$ StateServer -> IntMap Int
sbandSpawned StateServer
ser }
         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
arena
         m Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Bool -> m ()) -> m Bool -> m ()
forall a b. (a -> b) -> a -> b
$ Bool
-> Int
-> [(GroupName ItemKind, Int)]
-> LevelId
-> Time
-> Maybe Point
-> Int
-> m Bool
forall (m :: * -> *).
MonadServerAtomic m =>
Bool
-> Int
-> [(GroupName ItemKind, Int)]
-> LevelId
-> Time
-> Maybe Point
-> Int
-> m Bool
addManyActors Bool
False Int
lvlSpawned (CaveKind -> [(GroupName ItemKind, Int)]
CK.cactorFreq CaveKind
ck) LevelId
arena Time
localTime
                              Maybe Point
forall a. Maybe a
Nothing Int
numToSpawn

addAnyActor :: MonadServerAtomic m
            => Bool -> Int -> Freqs ItemKind -> LevelId -> Time -> Maybe Point
            -> m (Maybe (ActorId, Point))
addAnyActor :: Bool
-> Int
-> [(GroupName ItemKind, Int)]
-> LevelId
-> Time
-> Maybe Point
-> m (Maybe (ActorId, Point))
addAnyActor Bool
summoned Int
lvlSpawned [(GroupName ItemKind, Int)]
actorFreq LevelId
lid Time
time Maybe Point
mpos = do
  -- We bootstrap the actor by first creating the trunk of the actor's body
  -- that contains the fixed properties of all actors of that kind.
  COps
cops <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  lvl :: Level
lvl@Level{AbsDepth
ldepth :: AbsDepth
ldepth :: Level -> AbsDepth
ldepth} <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel LevelId
lid
  FactionDict
factionD <- (State -> FactionDict) -> m FactionDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> FactionDict
sfactionD
  Frequency (ContentId ItemKind, ItemKind)
freq <- Int
-> AbsDepth
-> [(GroupName ItemKind, Int)]
-> m (Frequency (ContentId ItemKind, ItemKind))
forall (m :: * -> *).
MonadServerAtomic m =>
Int
-> AbsDepth
-> [(GroupName ItemKind, Int)]
-> m (Frequency (ContentId ItemKind, ItemKind))
prepareItemKind Int
lvlSpawned AbsDepth
ldepth [(GroupName ItemKind, Int)]
actorFreq
  NewItem
m2 <- Frequency (ContentId ItemKind, ItemKind) -> AbsDepth -> m NewItem
forall (m :: * -> *).
MonadServerAtomic m =>
Frequency (ContentId ItemKind, ItemKind) -> AbsDepth -> m NewItem
rollItemAspect Frequency (ContentId ItemKind, ItemKind)
freq AbsDepth
ldepth
  case NewItem
m2 of
    NewItem
NoNewItem -> do
      Text -> m ()
forall (m :: * -> *). MonadServer m => Text -> m ()
debugPossiblyPrint (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
        String
"Server: addAnyActor: trunk failed to roll"
        String
-> (Bool, Int, [(GroupName ItemKind, Int)],
    Frequency (ContentId ItemKind, ItemKind), LevelId, Time,
    Maybe Point)
-> String
forall v. Show v => String -> v -> String
`showFailure` (Bool
summoned, Int
lvlSpawned, [(GroupName ItemKind, Int)]
actorFreq, Frequency (ContentId ItemKind, ItemKind)
freq, LevelId
lid, Time
time, Maybe Point
mpos)
      Maybe (ActorId, Point) -> m (Maybe (ActorId, Point))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ActorId, Point)
forall a. Maybe a
Nothing
    NewItem ItemKnown
itemKnownRaw ItemFull
itemFullRaw ItemQuant
itemQuant -> do
      (FactionId
fid, Faction
_) <- Rnd (FactionId, Faction) -> m (FactionId, Faction)
forall (m :: * -> *) a. MonadServer m => Rnd a -> m a
rndToAction (Rnd (FactionId, Faction) -> m (FactionId, Faction))
-> Rnd (FactionId, Faction) -> m (FactionId, Faction)
forall a b. (a -> b) -> a -> b
$ [(FactionId, Faction)] -> Rnd (FactionId, Faction)
forall a. [a] -> Rnd a
oneOf ([(FactionId, Faction)] -> Rnd (FactionId, Faction))
-> [(FactionId, Faction)] -> Rnd (FactionId, Faction)
forall a b. (a -> b) -> a -> b
$
                    ItemKind -> FactionDict -> [(FactionId, Faction)]
possibleActorFactions (ItemFull -> ItemKind
itemKind ItemFull
itemFullRaw) FactionDict
factionD
      PerFid
pers <- (StateServer -> PerFid) -> m PerFid
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> PerFid
sperFid
      let allPers :: EnumSet Point
allPers = [EnumSet Point] -> EnumSet Point
forall k. [EnumSet k] -> EnumSet k
ES.unions ([EnumSet Point] -> EnumSet Point)
-> [EnumSet Point] -> EnumSet Point
forall a b. (a -> b) -> a -> b
$ (EnumMap LevelId Perception -> EnumSet Point)
-> [EnumMap LevelId Perception] -> [EnumSet Point]
forall a b. (a -> b) -> [a] -> [b]
map (Perception -> EnumSet Point
totalVisible (Perception -> EnumSet Point)
-> (EnumMap LevelId Perception -> Perception)
-> EnumMap LevelId Perception
-> EnumSet Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnumMap LevelId Perception -> LevelId -> Perception
forall k a. Enum k => EnumMap k a -> k -> a
EM.! LevelId
lid))
                    ([EnumMap LevelId Perception] -> [EnumSet Point])
-> [EnumMap LevelId Perception] -> [EnumSet Point]
forall a b. (a -> b) -> a -> b
$ PerFid -> [EnumMap LevelId Perception]
forall k a. EnumMap k a -> [a]
EM.elems (PerFid -> [EnumMap LevelId Perception])
-> PerFid -> [EnumMap LevelId Perception]
forall a b. (a -> b) -> a -> b
$ FactionId -> PerFid -> PerFid
forall k a. Enum k => k -> EnumMap k a -> EnumMap k a
EM.delete FactionId
fid PerFid
pers  -- expensive :(
          -- Checking skill would be more accurate, but skills can be
          -- inside organs, equipment, condition organs, created organs, etc.
          freqNames :: [GroupName ItemKind]
freqNames = ((GroupName ItemKind, Int) -> GroupName ItemKind)
-> [(GroupName ItemKind, Int)] -> [GroupName ItemKind]
forall a b. (a -> b) -> [a] -> [b]
map (GroupName ItemKind, Int) -> GroupName ItemKind
forall a b. (a, b) -> a
fst ([(GroupName ItemKind, Int)] -> [GroupName ItemKind])
-> [(GroupName ItemKind, Int)] -> [GroupName ItemKind]
forall a b. (a -> b) -> a -> b
$ ItemKind -> [(GroupName ItemKind, Int)]
IK.ifreq (ItemKind -> [(GroupName ItemKind, Int)])
-> ItemKind -> [(GroupName ItemKind, Int)]
forall a b. (a -> b) -> a -> b
$ ItemFull -> ItemKind
itemKind ItemFull
itemFullRaw
          mobile :: Bool
mobile = GroupName ItemKind
IK.MOBILE GroupName ItemKind -> [GroupName ItemKind] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [GroupName ItemKind]
freqNames
          aquatic :: Bool
aquatic = GroupName ItemKind
IK.AQUATIC GroupName ItemKind -> [GroupName ItemKind] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [GroupName ItemKind]
freqNames
      Maybe Point
mrolledPos <- case Maybe Point
mpos of
        Just{} -> Maybe Point -> m (Maybe Point)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Point
mpos
        Maybe Point
Nothing -> do
          Rnd (Maybe Point)
rollPos <-
            (State -> Rnd (Maybe Point)) -> m (Rnd (Maybe Point))
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Rnd (Maybe Point)) -> m (Rnd (Maybe Point)))
-> (State -> Rnd (Maybe Point)) -> m (Rnd (Maybe Point))
forall a b. (a -> b) -> a -> b
$ COps
-> EnumSet Point
-> Bool
-> Bool
-> LevelId
-> Level
-> FactionId
-> State
-> Rnd (Maybe Point)
rollSpawnPos COps
cops EnumSet Point
allPers Bool
mobile Bool
aquatic LevelId
lid Level
lvl FactionId
fid
          Rnd (Maybe Point) -> m (Maybe Point)
forall (m :: * -> *) a. MonadServer m => Rnd a -> m a
rndToAction Rnd (Maybe Point)
rollPos
      case Maybe Point
mrolledPos of
        Just Point
pos ->
          (ActorId, Point) -> Maybe (ActorId, Point)
forall a. a -> Maybe a
Just ((ActorId, Point) -> Maybe (ActorId, Point))
-> (ActorId -> (ActorId, Point))
-> ActorId
-> Maybe (ActorId, Point)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ActorId
aid -> (ActorId
aid, Point
pos))
          (ActorId -> Maybe (ActorId, Point))
-> m ActorId -> m (Maybe (ActorId, Point))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> ItemKnown
-> ItemFullKit
-> FactionId
-> Point
-> LevelId
-> Time
-> m ActorId
forall (m :: * -> *).
MonadServerAtomic m =>
Bool
-> ItemKnown
-> ItemFullKit
-> FactionId
-> Point
-> LevelId
-> Time
-> m ActorId
registerActor Bool
summoned ItemKnown
itemKnownRaw (ItemFull
itemFullRaw, ItemQuant
itemQuant)
                            FactionId
fid Point
pos LevelId
lid Time
time
        Maybe Point
Nothing -> do
          Text -> m ()
forall (m :: * -> *). MonadServer m => Text -> m ()
debugPossiblyPrint
            Text
"Server: addAnyActor: failed to find any free position"
          Maybe (ActorId, Point) -> m (Maybe (ActorId, Point))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ActorId, Point)
forall a. Maybe a
Nothing

addManyActors :: MonadServerAtomic m
              => Bool -> Int -> Freqs ItemKind -> LevelId -> Time -> Maybe Point
              -> Int
              -> m Bool
addManyActors :: Bool
-> Int
-> [(GroupName ItemKind, Int)]
-> LevelId
-> Time
-> Maybe Point
-> Int
-> m Bool
addManyActors Bool
summoned Int
lvlSpawned [(GroupName ItemKind, Int)]
actorFreq LevelId
lid Time
time Maybe Point
mpos
              Int
howMany = Bool -> m Bool -> m Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
howMany Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1) (m Bool -> m Bool) -> m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
  Maybe ([ActorId], Point)
mInitialLAidPos <- case Maybe Point
mpos of
    Just Point
pos -> Maybe ([ActorId], Point) -> m (Maybe ([ActorId], Point))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([ActorId], Point) -> m (Maybe ([ActorId], Point)))
-> Maybe ([ActorId], Point) -> m (Maybe ([ActorId], Point))
forall a b. (a -> b) -> a -> b
$ ([ActorId], Point) -> Maybe ([ActorId], Point)
forall a. a -> Maybe a
Just ([], Point
pos)
    Maybe Point
Nothing ->
      (\(ActorId
aid, Point
pos) -> ([ActorId
aid], Point
pos))
      ((ActorId, Point) -> ([ActorId], Point))
-> m (Maybe (ActorId, Point)) -> m (Maybe ([ActorId], Point))
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<$$> Bool
-> Int
-> [(GroupName ItemKind, Int)]
-> LevelId
-> Time
-> Maybe Point
-> m (Maybe (ActorId, Point))
forall (m :: * -> *).
MonadServerAtomic m =>
Bool
-> Int
-> [(GroupName ItemKind, Int)]
-> LevelId
-> Time
-> Maybe Point
-> m (Maybe (ActorId, Point))
addAnyActor Bool
summoned Int
lvlSpawned [(GroupName ItemKind, Int)]
actorFreq LevelId
lid Time
time Maybe Point
forall a. Maybe a
Nothing
  case Maybe ([ActorId], Point)
mInitialLAidPos of
    Maybe ([ActorId], Point)
Nothing -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False  -- suspect content; server debug elsewhere
    Just ([ActorId]
laid, Point
pos) -> do
      cops :: COps
cops@COps{TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
      Level
lvl <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel LevelId
lid
      let validTile :: ContentId TileKind -> Bool
validTile ContentId TileKind
t = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ TileSpeedup -> ContentId TileKind -> Bool
Tile.isNoActor TileSpeedup
coTileSpeedup ContentId TileKind
t
          ps :: [Point]
ps = COps -> Level -> (ContentId TileKind -> Bool) -> Point -> [Point]
nearbyFreePoints COps
cops Level
lvl ContentId TileKind -> Bool
validTile Point
pos
          psNeeded :: [Point]
psNeeded = Int -> [Point] -> [Point]
forall a. Int -> [a] -> [a]
take (Int
howMany Int -> Int -> Int
forall a. Num a => a -> a -> a
- [ActorId] -> Int
forall a. [a] -> Int
length [ActorId]
laid) [Point]
ps
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Point] -> Int
forall a. [a] -> Int
length [Point]
psNeeded Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
howMany Int -> Int -> Int
forall a. Num a => a -> a -> a
- [ActorId] -> Int
forall a. [a] -> Int
length [ActorId]
laid) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        Text -> m ()
forall (m :: * -> *). MonadServer m => Text -> m ()
debugPossiblyPrint (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
          Text
"Server: addManyActors: failed to find enough free positions at"
          Text -> Text -> Text
<+> (LevelId, Point) -> Text
forall a. Show a => a -> Text
tshow (LevelId
lid, Point
pos)
      [Maybe (ActorId, Point)]
maidposs <- [Point]
-> (Point -> m (Maybe (ActorId, Point)))
-> m [Maybe (ActorId, Point)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Point]
psNeeded ((Point -> m (Maybe (ActorId, Point)))
 -> m [Maybe (ActorId, Point)])
-> (Point -> m (Maybe (ActorId, Point)))
-> m [Maybe (ActorId, Point)]
forall a b. (a -> b) -> a -> b
$
        Bool
-> Int
-> [(GroupName ItemKind, Int)]
-> LevelId
-> Time
-> Maybe Point
-> m (Maybe (ActorId, Point))
forall (m :: * -> *).
MonadServerAtomic m =>
Bool
-> Int
-> [(GroupName ItemKind, Int)]
-> LevelId
-> Time
-> Maybe Point
-> m (Maybe (ActorId, Point))
addAnyActor Bool
summoned Int
lvlSpawned [(GroupName ItemKind, Int)]
actorFreq LevelId
lid Time
time (Maybe Point -> m (Maybe (ActorId, Point)))
-> (Point -> Maybe Point) -> Point -> m (Maybe (ActorId, Point))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Maybe Point
forall a. a -> Maybe a
Just
      case [ActorId]
laid [ActorId] -> [ActorId] -> [ActorId]
forall a. [a] -> [a] -> [a]
++ ((ActorId, Point) -> ActorId) -> [(ActorId, Point)] -> [ActorId]
forall a b. (a -> b) -> [a] -> [b]
map (ActorId, Point) -> ActorId
forall a b. (a, b) -> a
fst ([Maybe (ActorId, Point)] -> [(ActorId, Point)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (ActorId, Point)]
maidposs) of
        [] -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        ActorId
aid : [ActorId]
_ -> do
          Actor
b <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
          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.! Actor -> FactionId
bfid Actor
b) (FactionDict -> Faction)
-> (State -> FactionDict) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> FactionDict
sfactionD
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe ActorId -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ActorId
mleader) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> ActorId -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> ActorId -> m ()
setFreshLeader (Actor -> FactionId
bfid Actor
b) ActorId
aid
          Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

rollSpawnPos :: COps -> ES.EnumSet Point
             -> Bool -> Bool -> LevelId -> Level -> FactionId -> State
             -> Rnd (Maybe Point)
rollSpawnPos :: COps
-> EnumSet Point
-> Bool
-> Bool
-> LevelId
-> Level
-> FactionId
-> State
-> Rnd (Maybe Point)
rollSpawnPos COps{TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup} EnumSet Point
visible
             Bool
mobile Bool
aquatic LevelId
lid lvl :: Level
lvl@Level{Area
larea :: Level -> Area
larea :: Area
larea} FactionId
fid State
s = do
  let inhabitants :: [Actor]
inhabitants = FactionId -> LevelId -> State -> [Actor]
foeRegularList FactionId
fid LevelId
lid State
s
      nearInh :: (Int -> Bool) -> Point -> Bool
nearInh !Int -> Bool
df !Point
p = (Actor -> Bool) -> [Actor] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ !Actor
b -> Int -> Bool
df (Int -> Bool) -> Int -> Bool
forall a b. (a -> b) -> a -> b
$ Point -> Point -> Int
chessDist (Actor -> Point
bpos Actor
b) Point
p) [Actor]
inhabitants
      distantMiddle :: Int -> Point -> Bool
distantMiddle !Int
d !Point
p = Point -> Point -> Int
chessDist Point
p (Area -> Point
middlePoint Area
larea) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
d
      condList :: [Point -> Bool]
condList | Bool
mobile =
        [ (Int -> Bool) -> Point -> Bool
nearInh (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
50)  -- don't spawn very far from foes
        , (Int -> Bool) -> Point -> Bool
nearInh (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
100)
        ]
               | Bool
otherwise =
        [ Int -> Point -> Bool
distantMiddle Int
8
        , Int -> Point -> Bool
distantMiddle Int
16
        , Int -> Point -> Bool
distantMiddle Int
24
        , Int -> Point -> Bool
distantMiddle Int
26
        , Int -> Point -> Bool
distantMiddle Int
28
        , Int -> Point -> Bool
distantMiddle Int
30
        ]
  -- Not considering TK.OftenActor, because monsters emerge from hidden ducts,
  -- which are easier to hide in crampy corridors that lit halls.
  Int
-> Level
-> (Point -> ContentId TileKind -> Bool)
-> [Point -> ContentId TileKind -> Bool]
-> (Point -> ContentId TileKind -> Bool)
-> [Point -> ContentId TileKind -> Bool]
-> Rnd (Maybe Point)
findPosTry2 (if Bool
mobile then Int
500 else Int
50) Level
lvl
    ( \Point
p !ContentId TileKind
t -> TileSpeedup -> ContentId TileKind -> Bool
Tile.isWalkable TileSpeedup
coTileSpeedup ContentId TileKind
t
               Bool -> Bool -> Bool
&& Bool -> Bool
not (TileSpeedup -> ContentId TileKind -> Bool
Tile.isNoActor TileSpeedup
coTileSpeedup ContentId TileKind
t)
               Bool -> Bool -> Bool
&& Bool -> Bool
not (Point -> Level -> Bool
occupiedBigLvl Point
p Level
lvl)
               Bool -> Bool -> Bool
&& Bool -> Bool
not (Point -> Level -> Bool
occupiedProjLvl Point
p Level
lvl) )
    (((Point -> Bool) -> Point -> ContentId TileKind -> Bool)
-> [Point -> Bool] -> [Point -> ContentId TileKind -> Bool]
forall a b. (a -> b) -> [a] -> [b]
map (\Point -> Bool
f Point
p ContentId TileKind
_ -> Point -> Bool
f Point
p) [Point -> Bool]
condList)
    (\ !Point
p ContentId TileKind
t -> (Int -> Bool) -> Point -> Bool
nearInh (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
4) Point
p  -- otherwise actors in dark rooms swarmed
               Bool -> Bool -> Bool
&& Bool -> Bool
not (Point
p Point -> EnumSet Point -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
`ES.member` EnumSet Point
visible)  -- visibility and plausibility
               Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
aquatic Bool -> Bool -> Bool
|| TileSpeedup -> ContentId TileKind -> Bool
Tile.isAquatic TileSpeedup
coTileSpeedup ContentId TileKind
t))
    [ \ !Point
p ContentId TileKind
_ -> (Int -> Bool) -> Point -> Bool
nearInh (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3) Point
p
                Bool -> Bool -> Bool
&& Bool -> Bool
not (Point
p Point -> EnumSet Point -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
`ES.member` EnumSet Point
visible)
    , \ !Point
p ContentId TileKind
_ -> (Int -> Bool) -> Point -> Bool
nearInh (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2) Point
p  -- otherwise actors hit on entering level
                Bool -> Bool -> Bool
&& Bool -> Bool
not (Point
p Point -> EnumSet Point -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
`ES.member` EnumSet Point
visible)
    , \ !Point
p ContentId TileKind
_ -> Bool -> Bool
not (Point
p Point -> EnumSet Point -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
`ES.member` EnumSet Point
visible)
    ]

-- | Advance the move time for the given actor.
advanceTime :: MonadServerAtomic m => ActorId -> Int -> Bool -> m ()
advanceTime :: ActorId -> Int -> Bool -> m ()
advanceTime ActorId
aid Int
percent Bool
breakStasis = do
  Actor
b <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
  Skills
actorMaxSk <- (State -> Skills) -> m Skills
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Skills) -> m Skills) -> (State -> Skills) -> m Skills
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Skills
getActorMaxSkills ActorId
aid
  let t :: Delta Time
t = Delta Time -> Int -> Delta Time
timeDeltaPercent (Speed -> Delta Time
ticksPerMeter (Speed -> Delta Time) -> Speed -> Delta Time
forall a b. (a -> b) -> a -> b
$ Skills -> Speed
gearSpeed Skills
actorMaxSk) Int
percent
  -- @t@ may be negative; that's OK.
  (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 {sactorTime :: ActorTime
sactorTime = FactionId
-> LevelId -> ActorId -> Delta Time -> ActorTime -> ActorTime
ageActor (Actor -> FactionId
bfid Actor
b) (Actor -> LevelId
blid Actor
b) ActorId
aid Delta Time
t (ActorTime -> ActorTime) -> ActorTime -> ActorTime
forall a b. (a -> b) -> a -> b
$ StateServer -> ActorTime
sactorTime StateServer
ser}
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
breakStasis (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    (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 {sactorStasis :: EnumSet ActorId
sactorStasis = ActorId -> EnumSet ActorId -> EnumSet ActorId
forall k. Enum k => k -> EnumSet k -> EnumSet k
ES.delete ActorId
aid (StateServer -> EnumSet ActorId
sactorStasis StateServer
ser)}
             -- actor moved, so he broke the time stasis, he can be
             -- paralyzed as well as propelled again

-- | Advance the trajectory following time for the given actor.
advanceTimeTraj :: MonadServerAtomic m => ActorId -> m ()
advanceTimeTraj :: ActorId -> m ()
advanceTimeTraj ActorId
aid = do
  Actor
b <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
  let speedTraj :: Speed
speedTraj = case Actor -> Maybe ([Vector], Speed)
btrajectory Actor
b of
        Maybe ([Vector], Speed)
Nothing -> String -> Speed
forall a. (?callStack::CallStack) => String -> a
error (String -> Speed) -> String -> Speed
forall a b. (a -> b) -> a -> b
$ String
"" String -> Actor -> String
forall v. Show v => String -> v -> String
`showFailure` Actor
b
        Just ([Vector]
_, Speed
speed) -> Speed
speed
      t :: Delta Time
t = Speed -> Delta Time
ticksPerMeter Speed
speedTraj
  -- @t@ may be negative; that's OK.
  (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 :: ActorTime
strajTime = FactionId
-> LevelId -> ActorId -> Delta Time -> ActorTime -> ActorTime
ageActor (Actor -> FactionId
bfid Actor
b) (Actor -> LevelId
blid Actor
b) ActorId
aid Delta Time
t (ActorTime -> ActorTime) -> ActorTime -> ActorTime
forall a b. (a -> b) -> a -> b
$ StateServer -> ActorTime
strajTime StateServer
ser}

-- | Add communication overhead time delta to all non-projectile, non-dying
-- faction's actors, except the leader. Effectively, this limits moves
-- of a faction on a level to 10, regardless of the number of actors
-- and their speeds. To avoid animals suddenly acting extremely sluggish
-- whenever monster's leader visits a distant arena that has a crowd
-- of animals, overhead applies only to actors on the same level.
-- Since the number of active levels is limited, this bounds the total moves
-- per turn of each faction as well.
--
-- Leader is immune from overhead and so he is faster than other faction
-- members and of equal speed to leaders of other factions (of equal
-- base speed) regardless how numerous the faction is.
-- Thanks to this, there is no problem with leader of a numerous faction
-- having very long UI turns, introducing UI lag.
overheadActorTime :: MonadServerAtomic m => FactionId -> LevelId -> m ()
overheadActorTime :: FactionId -> LevelId -> m ()
overheadActorTime FactionId
fid LevelId
lid = do
  -- Only non-projectiles processed, because @strajTime@ ignored.
  EnumMap LevelId (EnumMap ActorId Time)
actorTimeFid <- (StateServer -> EnumMap LevelId (EnumMap ActorId Time))
-> m (EnumMap LevelId (EnumMap ActorId Time))
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> EnumMap LevelId (EnumMap ActorId Time))
 -> m (EnumMap LevelId (EnumMap ActorId Time)))
-> (StateServer -> EnumMap LevelId (EnumMap ActorId Time))
-> m (EnumMap LevelId (EnumMap ActorId Time))
forall a b. (a -> b) -> a -> b
$ (ActorTime -> FactionId -> EnumMap LevelId (EnumMap ActorId Time)
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid) (ActorTime -> EnumMap LevelId (EnumMap ActorId Time))
-> (StateServer -> ActorTime)
-> StateServer
-> EnumMap LevelId (EnumMap ActorId Time)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ActorTime
sactorTime
  let actorTimeLid :: EnumMap ActorId Time
actorTimeLid = EnumMap LevelId (EnumMap ActorId Time)
actorTimeFid EnumMap LevelId (EnumMap ActorId Time)
-> LevelId -> EnumMap ActorId Time
forall k a. Enum k => EnumMap k a -> k -> a
EM.! LevelId
lid
  ActorId -> Actor
getActorB <- (State -> ActorId -> Actor) -> m (ActorId -> Actor)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ActorId -> Actor) -> m (ActorId -> Actor))
-> (State -> ActorId -> Actor) -> m (ActorId -> Actor)
forall a b. (a -> b) -> a -> b
$ (ActorId -> State -> Actor) -> State -> ActorId -> Actor
forall a b c. (a -> b -> c) -> b -> a -> c
flip ActorId -> State -> Actor
getActorBody
  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
  let f :: ActorId -> Time -> Time
f !ActorId
aid !Time
time =
        let body :: Actor
body = ActorId -> Actor
getActorB ActorId
aid
        in if Actor -> Int64
bhp Actor
body Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0  -- speed up all-move-at-once carcass removal
              Bool -> Bool -> Bool
&& ActorId -> Maybe ActorId
forall a. a -> Maybe a
Just ActorId
aid Maybe ActorId -> Maybe ActorId -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe ActorId
mleader  -- leader fast, for UI to be fast
           then Time -> Delta Time -> Time
timeShift Time
time (Time -> Delta Time
forall a. a -> Delta a
Delta Time
timeClip)
           else Time
time
      actorTimeLid2 :: EnumMap ActorId Time
actorTimeLid2 = (ActorId -> Time -> Time)
-> EnumMap ActorId Time -> EnumMap ActorId Time
forall k a b. Enum k => (k -> a -> b) -> EnumMap k a -> EnumMap k b
EM.mapWithKey ActorId -> Time -> Time
f EnumMap ActorId Time
actorTimeLid
      actorTimeFid2 :: EnumMap LevelId (EnumMap ActorId Time)
actorTimeFid2 = LevelId
-> EnumMap ActorId Time
-> EnumMap LevelId (EnumMap ActorId Time)
-> EnumMap LevelId (EnumMap ActorId Time)
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert LevelId
lid EnumMap ActorId Time
actorTimeLid2 EnumMap LevelId (EnumMap ActorId Time)
actorTimeFid
  (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 {sactorTime :: ActorTime
sactorTime = FactionId
-> EnumMap LevelId (EnumMap ActorId Time) -> ActorTime -> ActorTime
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert FactionId
fid EnumMap LevelId (EnumMap ActorId Time)
actorTimeFid2 (ActorTime -> ActorTime) -> ActorTime -> ActorTime
forall a b. (a -> b) -> a -> b
$ StateServer -> ActorTime
sactorTime StateServer
ser}

-- | Swap the relative move times of two actors (e.g., when switching
-- a UI leader). Notice that their trajectory move times are not swapped.
swapTime :: MonadServerAtomic m => ActorId -> ActorId -> m ()
swapTime :: ActorId -> ActorId -> m ()
swapTime ActorId
source ActorId
target = do
  Actor
sb <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
source
  Actor
tb <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
target
  Time
slvl <- (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 (Actor -> LevelId
blid Actor
sb)
  Time
tlvl <- (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 (Actor -> LevelId
blid Actor
tb)
  Time
btime_sb <-
    (StateServer -> Time) -> m Time
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer
    ((StateServer -> Time) -> m Time)
-> (StateServer -> Time) -> m Time
forall a b. (a -> b) -> a -> b
$ Maybe Time -> Time
forall a. (?callStack::CallStack) => Maybe a -> a
fromJust (Maybe Time -> Time)
-> (StateServer -> Maybe Time) -> StateServer -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FactionId -> LevelId -> ActorId -> ActorTime -> Maybe Time
lookupActorTime (Actor -> FactionId
bfid Actor
sb) (Actor -> LevelId
blid Actor
sb) ActorId
source (ActorTime -> Maybe Time)
-> (StateServer -> ActorTime) -> StateServer -> Maybe Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ActorTime
sactorTime
  Time
btime_tb <-
    (StateServer -> Time) -> m Time
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer
    ((StateServer -> Time) -> m Time)
-> (StateServer -> Time) -> m Time
forall a b. (a -> b) -> a -> b
$ Maybe Time -> Time
forall a. (?callStack::CallStack) => Maybe a -> a
fromJust (Maybe Time -> Time)
-> (StateServer -> Maybe Time) -> StateServer -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FactionId -> LevelId -> ActorId -> ActorTime -> Maybe Time
lookupActorTime (Actor -> FactionId
bfid Actor
tb) (Actor -> LevelId
blid Actor
tb) ActorId
target (ActorTime -> Maybe Time)
-> (StateServer -> ActorTime) -> StateServer -> Maybe Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ActorTime
sactorTime
  let lvlDelta :: Delta Time
lvlDelta = Time
slvl Time -> Time -> Delta Time
`timeDeltaToFrom` Time
tlvl
      bDelta :: Delta Time
bDelta = Time
btime_sb Time -> Time -> Delta Time
`timeDeltaToFrom` Time
btime_tb
      sdelta :: Delta Time
sdelta = Delta Time -> Delta Time -> Delta Time
timeDeltaSubtract Delta Time
lvlDelta Delta Time
bDelta
      tdelta :: Delta Time
tdelta = Delta Time -> Delta Time
timeDeltaReverse Delta Time
sdelta
  -- Equivalent, for the assert:
  let !_A :: ()
_A = let sbodyDelta :: Delta Time
sbodyDelta = Time
btime_sb Time -> Time -> Delta Time
`timeDeltaToFrom` Time
slvl
                tbodyDelta :: Delta Time
tbodyDelta = Time
btime_tb Time -> Time -> Delta Time
`timeDeltaToFrom` Time
tlvl
                sgoal :: Time
sgoal = Time
slvl Time -> Delta Time -> Time
`timeShift` Delta Time
tbodyDelta
                tgoal :: Time
tgoal = Time
tlvl Time -> Delta Time -> Time
`timeShift` Delta Time
sbodyDelta
                sdelta' :: Delta Time
sdelta' = Time
sgoal Time -> Time -> Delta Time
`timeDeltaToFrom` Time
btime_sb
                tdelta' :: Delta Time
tdelta' = Time
tgoal Time -> Time -> Delta Time
`timeDeltaToFrom` Time
btime_tb
            in Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Delta Time
sdelta Delta Time -> Delta Time -> Bool
forall a. Eq a => a -> a -> Bool
== Delta Time
sdelta' Bool -> Bool -> Bool
&& Delta Time
tdelta Delta Time -> Delta Time -> Bool
forall a. Eq a => a -> a -> Bool
== Delta Time
tdelta'
                       Bool
-> (Time, Time, Time, Time, Delta Time, Delta Time, Delta Time,
    Delta Time)
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` ( Time
slvl, Time
tlvl, Time
btime_sb, Time
btime_tb
                               , Delta Time
sdelta, Delta Time
sdelta', Delta Time
tdelta, Delta Time
tdelta' )) ()
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Delta Time
sdelta Delta Time -> Delta Time -> Bool
forall a. Eq a => a -> a -> Bool
/= Time -> Delta Time
forall a. a -> Delta a
Delta Time
timeZero) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ (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 {sactorTime :: ActorTime
sactorTime = FactionId
-> LevelId -> ActorId -> Delta Time -> ActorTime -> ActorTime
ageActor (Actor -> FactionId
bfid Actor
sb) (Actor -> LevelId
blid Actor
sb) ActorId
source Delta Time
sdelta
                      (ActorTime -> ActorTime) -> ActorTime -> ActorTime
forall a b. (a -> b) -> a -> b
$ StateServer -> ActorTime
sactorTime StateServer
ser}
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Delta Time
tdelta Delta Time -> Delta Time -> Bool
forall a. Eq a => a -> a -> Bool
/= Time -> Delta Time
forall a. a -> Delta a
Delta Time
timeZero) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ (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 {sactorTime :: ActorTime
sactorTime = FactionId
-> LevelId -> ActorId -> Delta Time -> ActorTime -> ActorTime
ageActor (Actor -> FactionId
bfid Actor
tb) (Actor -> LevelId
blid Actor
tb) ActorId
target Delta Time
tdelta
                      (ActorTime -> ActorTime) -> ActorTime -> ActorTime
forall a b. (a -> b) -> a -> b
$ StateServer -> ActorTime
sactorTime StateServer
ser}

updateCalm :: MonadServerAtomic m => ActorId -> Int64 -> m ()
updateCalm :: ActorId -> Int64 -> m ()
updateCalm ActorId
target Int64
deltaCalm = do
  Actor
tb <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
target
  Skills
actorMaxSk <- (State -> Skills) -> m Skills
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Skills) -> m Skills) -> (State -> Skills) -> m Skills
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Skills
getActorMaxSkills ActorId
target
  let calmMax64 :: Int64
calmMax64 = Int -> Int64
xM (Int -> Int64) -> Int -> Int64
forall a b. (a -> b) -> a -> b
$ Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkMaxCalm Skills
actorMaxSk
  UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> Int64 -> UpdAtomic
UpdRefillCalm ActorId
target Int64
deltaCalm
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Actor -> Int64
bcalm Actor
tb Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
calmMax64
        Bool -> Bool -> Bool
&& Actor -> Int64
bcalm Actor
tb Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
deltaCalm Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
calmMax64) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    -- We don't dominate the actor here, because if so, players would
    -- disengage after one of their actors is dominated and wait for him
    -- to regenerate Calm. This is unnatural and boring. Better fight
    -- and hope he gets his Calm again to 0 and then defects back.
    -- We could instead tell here that Calm is fully regenerated,
    -- but that would be too verbose.

leadLevelSwitch :: MonadServerAtomic m => m ()
leadLevelSwitch :: m ()
leadLevelSwitch = do
  COps{ContentData CaveKind
cocave :: ContentData CaveKind
cocave :: COps -> ContentData CaveKind
cocave} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  FactionDict
factionD <- (State -> FactionDict) -> m FactionDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> FactionDict
sfactionD
  let canSwitch :: Faction -> Bool
canSwitch Faction
fact = (Bool, Bool) -> Bool
forall a b. (a, b) -> a
fst (Faction -> (Bool, Bool)
autoDungeonLevel Faction
fact)
                       -- a hack to help AI, until AI client can switch levels
                       Bool -> Bool -> Bool
|| Player -> Bool
funderAI (Faction -> Player
gplayer Faction
fact)
                          Bool -> Bool -> Bool
&& Maybe AutoLeader -> Bool
forall a. Maybe a -> Bool
isJust (Player -> Maybe AutoLeader
fleaderMode (Faction -> Player
gplayer Faction
fact))
      flipFaction :: (FactionId, Faction) -> m ()
flipFaction (FactionId
_, Faction
fact) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Faction -> Bool
canSwitch Faction
fact = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      flipFaction (FactionId
fid, Faction
fact) =
        case Faction -> Maybe ActorId
gleader Faction
fact of
          Maybe ActorId
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just ActorId
leader -> do
            Actor
body <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
leader
            let !_A :: ()
_A = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (FactionId
fid FactionId -> FactionId -> Bool
forall a. Eq a => a -> a -> Bool
== Actor -> FactionId
bfid Actor
body) ()
            State
s <- (StateServer -> State) -> m State
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> State) -> m State)
-> (StateServer -> State) -> m State
forall a b. (a -> b) -> a -> b
$ (EnumMap FactionId State -> FactionId -> State
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid) (EnumMap FactionId State -> State)
-> (StateServer -> EnumMap FactionId State) -> StateServer -> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> EnumMap FactionId State
sclientStates
            let leaderStuck :: Bool
leaderStuck = Actor -> Bool
actorWaits Actor
body
                lvlsRaw :: [((LevelId, Level), (Bool, [(ActorId, Actor)]))]
lvlsRaw =
                  [ ((LevelId
lid, Level
lvl), (Bool
allSeen, [(ActorId, Actor)]
as))
                  | (LevelId
lid, Level
lvl) <- EnumMap LevelId Level -> [(LevelId, Level)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs (EnumMap LevelId Level -> [(LevelId, Level)])
-> EnumMap LevelId Level -> [(LevelId, Level)]
forall a b. (a -> b) -> a -> b
$ State -> EnumMap LevelId Level
sdungeon State
s
                  , LevelId
lid LevelId -> LevelId -> Bool
forall a. Eq a => a -> a -> Bool
/= Actor -> LevelId
blid Actor
body Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
leaderStuck
                  , let asRaw :: [(ActorId, Actor)]
asRaw = -- Drama levels ignored, hence @Regular@.
                                FactionId -> LevelId -> State -> [(ActorId, Actor)]
fidActorRegularAssocs FactionId
fid LevelId
lid State
s
                        isAlert :: (a, Actor) -> Bool
isAlert (a
_, Actor
b) = case Actor -> Watchfulness
bwatch Actor
b of
                          Watchfulness
WWatch -> Bool
True
                          WWait Int
n -> Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                          Watchfulness
WSleep -> Bool
False
                          Watchfulness
WWake -> Bool
True  -- probably in danger
                        ([(ActorId, Actor)]
alert, [(ActorId, Actor)]
relaxed) = ((ActorId, Actor) -> Bool)
-> [(ActorId, Actor)] -> ([(ActorId, Actor)], [(ActorId, Actor)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (ActorId, Actor) -> Bool
forall a. (a, Actor) -> Bool
isAlert [(ActorId, Actor)]
asRaw
                        as :: [(ActorId, Actor)]
as = [(ActorId, Actor)]
alert [(ActorId, Actor)] -> [(ActorId, Actor)] -> [(ActorId, Actor)]
forall a. [a] -> [a] -> [a]
++ [(ActorId, Actor)]
relaxed  -- best switch leader to alert
                  , Bool -> Bool
not ([(ActorId, Actor)] -> Bool
forall a. [a] -> Bool
null [(ActorId, Actor)]
as)
                  , let allSeen :: Bool
allSeen =
                          Level -> Int
lexpl Level
lvl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Level -> Int
lseen Level
lvl
                          Bool -> Bool -> Bool
|| CaveKind -> Int
CK.cactorCoeff (ContentData CaveKind -> ContentId CaveKind -> CaveKind
forall a. ContentData a -> ContentId a -> a
okind ContentData CaveKind
cocave (ContentId CaveKind -> CaveKind) -> ContentId CaveKind -> CaveKind
forall a b. (a -> b) -> a -> b
$ Level -> ContentId CaveKind
lkind Level
lvl) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
150
                             Bool -> Bool -> Bool
&& Bool -> Bool
not (Player -> Bool
fhasGender (Player -> Bool) -> Player -> Bool
forall a b. (a -> b) -> a -> b
$ Faction -> Player
gplayer Faction
fact)
                  ]
                ([((LevelId, Level), (Bool, [(ActorId, Actor)]))]
lvlsSeen, [((LevelId, Level), (Bool, [(ActorId, Actor)]))]
lvlsNotSeen) = (((LevelId, Level), (Bool, [(ActorId, Actor)])) -> Bool)
-> [((LevelId, Level), (Bool, [(ActorId, Actor)]))]
-> ([((LevelId, Level), (Bool, [(ActorId, Actor)]))],
    [((LevelId, Level), (Bool, [(ActorId, Actor)]))])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Bool, [(ActorId, Actor)]) -> Bool
forall a b. (a, b) -> a
fst ((Bool, [(ActorId, Actor)]) -> Bool)
-> (((LevelId, Level), (Bool, [(ActorId, Actor)]))
    -> (Bool, [(ActorId, Actor)]))
-> ((LevelId, Level), (Bool, [(ActorId, Actor)]))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((LevelId, Level), (Bool, [(ActorId, Actor)]))
-> (Bool, [(ActorId, Actor)])
forall a b. (a, b) -> b
snd) [((LevelId, Level), (Bool, [(ActorId, Actor)]))]
lvlsRaw
                -- Monster AI changes leadership mostly to move from level
                -- to level and, in particular, to quickly bring troops
                -- to the frontline level and so prevent human from killing
                -- monsters at numerical advantage.
                -- However, an AI boss that can't move between levels
                -- disrupts this by hogging leadership. To prevent that,
                -- assuming the boss resides below the frontline level,
                -- only the two shallowest levels that are not yet fully
                -- explored are considered to choose the new leader from.
                -- This frontier moves as the levels are explored or emptied
                -- and sometimes the level with the boss is counted among
                -- them, but it never happens in the crucial periods when
                -- AI armies are transferred from level to level.
                f :: ((a, Level), b) -> AbsDepth
f ((a
_, Level
lvl), b
_) = Level -> AbsDepth
ldepth Level
lvl
                lvls :: [((LevelId, Level), (Bool, [(ActorId, Actor)]))]
lvls = [((LevelId, Level), (Bool, [(ActorId, Actor)]))]
lvlsSeen [((LevelId, Level), (Bool, [(ActorId, Actor)]))]
-> [((LevelId, Level), (Bool, [(ActorId, Actor)]))]
-> [((LevelId, Level), (Bool, [(ActorId, Actor)]))]
forall a. [a] -> [a] -> [a]
++ Int
-> [((LevelId, Level), (Bool, [(ActorId, Actor)]))]
-> [((LevelId, Level), (Bool, [(ActorId, Actor)]))]
forall a. Int -> [a] -> [a]
take Int
2 ((((LevelId, Level), (Bool, [(ActorId, Actor)]))
 -> ((LevelId, Level), (Bool, [(ActorId, Actor)])) -> Ordering)
-> [((LevelId, Level), (Bool, [(ActorId, Actor)]))]
-> [((LevelId, Level), (Bool, [(ActorId, Actor)]))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((((LevelId, Level), (Bool, [(ActorId, Actor)])) -> AbsDepth)
-> ((LevelId, Level), (Bool, [(ActorId, Actor)]))
-> ((LevelId, Level), (Bool, [(ActorId, Actor)]))
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((LevelId, Level), (Bool, [(ActorId, Actor)])) -> AbsDepth
forall a b. ((a, Level), b) -> AbsDepth
f) [((LevelId, Level), (Bool, [(ActorId, Actor)]))]
lvlsNotSeen)
            -- Actors on desolate levels (not many own or enemy non-projectiles)
            -- tend to become (or stay) leaders so that they can join the main
            -- force where it matters ASAP. Unfortunately, this keeps hero
            -- scouts as leader, but foes spawn very fast early on ,
            -- so they give back leadership rather quickly to let others follow.
            -- We count non-mobile and sleeping actors, because they may
            -- be dangerous, especially if adjacent to stairs.
            let overOwnStash :: Actor -> Bool
overOwnStash Actor
b = (LevelId, Point) -> Maybe (LevelId, Point)
forall a. a -> Maybe a
Just (Actor -> LevelId
blid Actor
b, Actor -> Point
bpos Actor
b) Maybe (LevelId, Point) -> Maybe (LevelId, Point) -> Bool
forall a. Eq a => a -> a -> Bool
== Faction -> Maybe (LevelId, Point)
gstash Faction
fact
                freqList :: [(Int, (LevelId, ActorId))]
freqList = [ (Int
k, (LevelId
lid, ActorId
aid))
                           | ((LevelId
lid, Level
lvl), (Bool
_, (ActorId
aid, Actor
b) : [(ActorId, Actor)]
rest)) <- [((LevelId, Level), (Bool, [(ActorId, Actor)]))]
lvls
                           , let len :: Int
len = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
20 (BigActorMap -> Int
forall k a. EnumMap k a -> Int
EM.size (BigActorMap -> Int) -> BigActorMap -> Int
forall a b. (a -> b) -> a -> b
$ Level -> BigActorMap
lbig Level
lvl)
                                 n :: Int
n = Int
1000000 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len)
                                 -- Visit the stash guard rarely, but not too
                                 -- rarely, to regen Calm and fling at foes.
                                 k :: Int
k = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ if [(ActorId, Actor)] -> Bool
forall a. [a] -> Bool
null [(ActorId, Actor)]
rest Bool -> Bool -> Bool
&& Actor -> Bool
overOwnStash Actor
b
                                             then Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
30
                                             else Int
n
                           ]
                closeToFactStash :: (FactionId, Faction) -> Bool
closeToFactStash (FactionId
fid2, Faction
fact2) = case Faction -> Maybe (LevelId, Point)
gstash Faction
fact2 of
                  Just (LevelId
lid, Point
pos) ->
                    (FactionId
fid FactionId -> FactionId -> Bool
forall a. Eq a => a -> a -> Bool
== FactionId
fid2 Bool -> Bool -> Bool
|| FactionId -> Faction -> FactionId -> Bool
isFoe FactionId
fid (FactionDict
factionD FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid) FactionId
fid2)
                    Bool -> Bool -> Bool
&& LevelId
lid LevelId -> LevelId -> Bool
forall a. Eq a => a -> a -> Bool
== Actor -> LevelId
blid Actor
body
                    Bool -> Bool -> Bool
&& Point -> Point -> Int
chessDist Point
pos (Actor -> Point
bpos Actor
body) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1  -- visible
                  Maybe (LevelId, Point)
Nothing -> Bool
False
                closeToEnemyStash :: Bool
closeToEnemyStash = ((FactionId, Faction) -> Bool) -> [(FactionId, Faction)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FactionId, Faction) -> Bool
closeToFactStash ([(FactionId, Faction)] -> Bool) -> [(FactionId, Faction)] -> Bool
forall a b. (a -> b) -> a -> b
$ FactionDict -> [(FactionId, Faction)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs FactionDict
factionD
            [Actor]
foes <- (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
$ FactionId -> LevelId -> State -> [Actor]
foeRegularList FactionId
fid (Actor -> LevelId
blid Actor
body)
            [Actor]
ours <- (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, Actor) -> Actor) -> [(ActorId, Actor)] -> [Actor]
forall a b. (a -> b) -> [a] -> [b]
map (ActorId, Actor) -> Actor
forall a b. (a, b) -> b
snd
                                ([(ActorId, Actor)] -> [Actor])
-> (State -> [(ActorId, Actor)]) -> State -> [Actor]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FactionId -> LevelId -> State -> [(ActorId, Actor)]
fidActorRegularAssocs FactionId
fid (Actor -> LevelId
blid Actor
body)
            let foesClose :: [Actor]
foesClose = (Actor -> Bool) -> [Actor] -> [Actor]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Actor
b -> Point -> Point -> Int
chessDist (Actor -> Point
bpos Actor
body) (Actor -> Point
bpos Actor
b) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2)
                                   [Actor]
foes
                oursCloseMelee :: [Actor]
oursCloseMelee =
                  (Actor -> Bool) -> [Actor] -> [Actor]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Actor
b -> Point -> Point -> Int
chessDist (Actor -> Point
bpos Actor
body) (Actor -> Point
bpos Actor
b) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2
                                Bool -> Bool -> Bool
&& Actor -> Int
bweapon Actor
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Actor -> Int
bweapBenign Actor
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)
                         [Actor]
ours
                canHelpMelee :: Bool
canHelpMelee =
                  Bool -> Bool
not Bool
leaderStuck
                  Bool -> Bool -> Bool
&& [Actor] -> Int
forall a. [a] -> Int
length [Actor]
oursCloseMelee Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
                  Bool -> Bool -> Bool
&& [Actor] -> Int
forall a. [a] -> Int
length [Actor]
foesClose Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1
                  Bool -> Bool -> Bool
&& Bool -> Bool
not ((Actor -> Bool) -> [Actor] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Actor
b -> (Actor -> Bool) -> [Actor] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Point -> Point -> Bool
adjacent (Actor -> Point
bpos Actor
b) (Point -> Bool) -> (Actor -> Point) -> Actor -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Actor -> Point
bpos) [Actor]
foes)
                              [Actor]
oursCloseMelee)
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
closeToEnemyStash Bool -> Bool -> Bool
|| Bool
canHelpMelee Bool -> Bool -> Bool
|| [(Int, (LevelId, ActorId))] -> Bool
forall a. [a] -> Bool
null [(Int, (LevelId, ActorId))]
freqList) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
              (LevelId
lid, ActorId
a) <- Rnd (LevelId, ActorId) -> m (LevelId, ActorId)
forall (m :: * -> *) a. MonadServer m => Rnd a -> m a
rndToAction (Rnd (LevelId, ActorId) -> m (LevelId, ActorId))
-> Rnd (LevelId, ActorId) -> m (LevelId, ActorId)
forall a b. (a -> b) -> a -> b
$ Frequency (LevelId, ActorId) -> Rnd (LevelId, ActorId)
forall a. Show a => Frequency a -> Rnd a
frequency
                                      (Frequency (LevelId, ActorId) -> Rnd (LevelId, ActorId))
-> Frequency (LevelId, ActorId) -> Rnd (LevelId, ActorId)
forall a b. (a -> b) -> a -> b
$ Text -> [(Int, (LevelId, ActorId))] -> Frequency (LevelId, ActorId)
forall a. Text -> [(Int, a)] -> Frequency a
toFreq Text
"leadLevel" [(Int, (LevelId, ActorId))]
freqList
              Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LevelId
lid LevelId -> LevelId -> Bool
forall a. Eq a => a -> a -> Bool
== Actor -> LevelId
blid Actor
body) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$  -- flip levels rather than actors
                FactionId -> ActorId -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> ActorId -> m ()
setFreshLeader FactionId
fid ActorId
a
  ((FactionId, Faction) -> m ()) -> [(FactionId, Faction)] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (FactionId, Faction) -> m ()
flipFaction ([(FactionId, Faction)] -> m ()) -> [(FactionId, Faction)] -> m ()
forall a b. (a -> b) -> a -> b
$ FactionDict -> [(FactionId, Faction)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs FactionDict
factionD

-- | Continue or exit or restart the game.
endOrLoop :: (MonadServerAtomic m, MonadServerComm m)
          => m () -> (Maybe (GroupName ModeKind) -> m ())
          -> m ()
{-# INLINE endOrLoop #-}
endOrLoop :: m () -> (Maybe (GroupName ModeKind) -> m ()) -> m ()
endOrLoop m ()
loop Maybe (GroupName ModeKind) -> m ()
restart = do
  FactionDict
factionD <- (State -> FactionDict) -> m FactionDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> FactionDict
sfactionD
  let inGame :: Faction -> Bool
inGame Faction
fact = case Faction -> Maybe Status
gquit Faction
fact of
        Maybe Status
Nothing -> Bool
True
        Just Status{stOutcome :: Status -> Outcome
stOutcome=Outcome
Camping} -> Bool
True
        Maybe Status
_ -> Bool
False
      gameOver :: Bool
gameOver = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Faction -> Bool) -> [Faction] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Faction -> Bool
inGame ([Faction] -> Bool) -> [Faction] -> Bool
forall a b. (a -> b) -> a -> b
$ FactionDict -> [Faction]
forall k a. EnumMap k a -> [a]
EM.elems FactionDict
factionD
  let getQuitter :: Faction -> Maybe (GroupName ModeKind)
getQuitter Faction
fact = case Faction -> Maybe Status
gquit Faction
fact of
        Just Status{stOutcome :: Status -> Outcome
stOutcome=Outcome
Restart, Maybe (GroupName ModeKind)
stNewGame :: Status -> Maybe (GroupName ModeKind)
stNewGame :: Maybe (GroupName ModeKind)
stNewGame} -> Maybe (GroupName ModeKind)
stNewGame
        Maybe Status
_ -> Maybe (GroupName ModeKind)
forall a. Maybe a
Nothing
      quitters :: [GroupName ModeKind]
quitters = (Faction -> Maybe (GroupName ModeKind))
-> [Faction] -> [GroupName ModeKind]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Faction -> Maybe (GroupName ModeKind)
getQuitter ([Faction] -> [GroupName ModeKind])
-> [Faction] -> [GroupName ModeKind]
forall a b. (a -> b) -> a -> b
$ FactionDict -> [Faction]
forall k a. EnumMap k a -> [a]
EM.elems FactionDict
factionD
      restartNeeded :: Bool
restartNeeded = Bool
gameOver Bool -> Bool -> Bool
|| Bool -> Bool
not ([GroupName ModeKind] -> Bool
forall a. [a] -> Bool
null [GroupName ModeKind]
quitters)
  let isCamper :: Faction -> Bool
isCamper Faction
fact = case Faction -> Maybe Status
gquit Faction
fact of
        Just Status{stOutcome :: Status -> Outcome
stOutcome=Outcome
Camping} -> Bool
True
        Maybe Status
_ -> Bool
False
      campers :: [(FactionId, Faction)]
campers = ((FactionId, Faction) -> Bool)
-> [(FactionId, Faction)] -> [(FactionId, Faction)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Faction -> Bool
isCamper (Faction -> Bool)
-> ((FactionId, Faction) -> Faction)
-> (FactionId, Faction)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FactionId, Faction) -> Faction
forall a b. (a, b) -> b
snd) ([(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
  -- Wipe out the quit flag for the savegame files.
  ((FactionId, Faction) -> m ()) -> [(FactionId, Faction)] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (\(FactionId
fid, Faction
fact) ->
    UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId
-> Maybe Status
-> Maybe Status
-> Maybe (FactionAnalytics, GenerationAnalytics)
-> UpdAtomic
UpdQuitFaction FactionId
fid (Faction -> Maybe Status
gquit Faction
fact) Maybe Status
forall a. Maybe a
Nothing Maybe (FactionAnalytics, GenerationAnalytics)
forall a. Maybe a
Nothing) [(FactionId, Faction)]
campers
  Bool
swriteSave <- (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> Bool
swriteSave
  Bool
sstopAfterGameOver <-
    (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> Bool) -> m Bool)
-> (StateServer -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ ServerOptions -> Bool
sstopAfterGameOver (ServerOptions -> Bool)
-> (StateServer -> ServerOptions) -> StateServer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ServerOptions
soptions
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
swriteSave (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    (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 {swriteSave :: Bool
swriteSave = Bool
False}
    Bool -> Bool -> m ()
forall (m :: * -> *). MonadServerAtomic m => Bool -> Bool -> m ()
writeSaveAll Bool
True Bool
False
  if | Bool
gameOver Bool -> Bool -> Bool
&& Bool
sstopAfterGameOver -> m ()
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
m ()
gameExit
     | Bool
restartNeeded -> Maybe (GroupName ModeKind) -> m ()
restart ([GroupName ModeKind] -> Maybe (GroupName ModeKind)
forall a. [a] -> Maybe a
listToMaybe [GroupName ModeKind]
quitters)
     | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(FactionId, Faction)] -> Bool
forall a. [a] -> Bool
null [(FactionId, Faction)]
campers -> m ()
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
m ()
gameExit  -- and @loop@ is not called
     | Bool
otherwise -> m ()
loop  -- continue current game

gameExit :: (MonadServerAtomic m, MonadServerComm m) => m ()
gameExit :: m ()
gameExit = do
--  debugPossiblyPrint "Server: Verifying all perceptions."
  -- Verify that the possibly not saved caches are equal to future
  -- reconstructed. Otherwise, save/restore would change game state.
  -- This is done even in released binaries, because it only prolongs
  -- game shutdown a bit. The same checks at each periodic game save
  -- would icrease the game saving lag, so they are normally avoided.
  m ()
forall (m :: * -> *). MonadServer m => m ()
verifyCaches
  -- Kill all clients, including those that did not take part
  -- in the current game.
  -- Clients exit not now, but after they print all ending screens.
--  debugPossiblyPrint "Server: Killing all clients."
  m ()
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
m ()
killAllClients
--  debugPossiblyPrint "Server: All clients killed."
  () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()