-- | Operations for starting and restarting the game.
module Game.LambdaHack.Server.StartM
  ( initPer, reinitGame, gameReset, applyDebug
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , sampleTrunks, sampleItems
  , mapFromFuns, resetFactions, populateDungeon, findEntryPoss
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import qualified Control.Monad.Trans.State.Strict as St
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import qualified Data.IntMap.Strict as IM
import           Data.Key (mapWithKeyM_)
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
import           Data.Tuple (swap)
import qualified NLP.Miniutter.English as MU
import qualified System.Random.SplitMix32 as SM

import           Game.LambdaHack.Atomic
import           Game.LambdaHack.Common.ActorState
import           Game.LambdaHack.Common.Analytics
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.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 qualified Game.LambdaHack.Core.Dice as Dice
import           Game.LambdaHack.Core.Random
import qualified Game.LambdaHack.Definition.Ability as Ability
import qualified Game.LambdaHack.Definition.Color as Color
import           Game.LambdaHack.Definition.Defs
import           Game.LambdaHack.Definition.Flavour
import           Game.LambdaHack.Server.CommonM
import qualified Game.LambdaHack.Server.DungeonGen as DungeonGen
import           Game.LambdaHack.Server.Fov
import           Game.LambdaHack.Server.ItemM
import           Game.LambdaHack.Server.ItemRev
import           Game.LambdaHack.Server.MonadServer
import           Game.LambdaHack.Server.ServerOptions
import           Game.LambdaHack.Server.State

initPer :: MonadServer m => m ()
initPer :: m ()
initPer = do
  ( FovLitLid
sfovLitLid, FovClearLid
sfovClearLid, FovLucidLid
sfovLucidLid
   ,PerValidFid
sperValidFid, PerCacheFid
sperCacheFid, PerFid
sperFid ) <- (State
 -> (FovLitLid, FovClearLid, FovLucidLid, PerValidFid, PerCacheFid,
     PerFid))
-> m (FovLitLid, FovClearLid, FovLucidLid, PerValidFid,
      PerCacheFid, PerFid)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State
-> (FovLitLid, FovClearLid, FovLucidLid, PerValidFid, PerCacheFid,
    PerFid)
perFidInDungeon
  (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 { FovLitLid
sfovLitLid :: FovLitLid
sfovLitLid :: FovLitLid
sfovLitLid, FovClearLid
sfovClearLid :: FovClearLid
sfovClearLid :: FovClearLid
sfovClearLid, FovLucidLid
sfovLucidLid :: FovLucidLid
sfovLucidLid :: FovLucidLid
sfovLucidLid
        , PerValidFid
sperValidFid :: PerValidFid
sperValidFid :: PerValidFid
sperValidFid, PerCacheFid
sperCacheFid :: PerCacheFid
sperCacheFid :: PerCacheFid
sperCacheFid, PerFid
sperFid :: PerFid
sperFid :: PerFid
sperFid }

reinitGame :: MonadServerAtomic m => FactionDict -> m ()
reinitGame :: FactionDict -> m ()
reinitGame FactionDict
factionDold = do
  COps{ContentData ItemKind
coitem :: COps -> ContentData ItemKind
coitem :: ContentData ItemKind
coitem} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  PerFid
pers <- (StateServer -> PerFid) -> m PerFid
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> PerFid
sperFid
  ServerOptions{Challenge
scurChalSer :: ServerOptions -> Challenge
scurChalSer :: Challenge
scurChalSer, Bool
sknowMap :: ServerOptions -> Bool
sknowMap :: Bool
sknowMap, Bool
sshowItemSamples :: ServerOptions -> Bool
sshowItemSamples :: Bool
sshowItemSamples, ClientOptions
sclientOptions :: ServerOptions -> ClientOptions
sclientOptions :: ClientOptions
sclientOptions}
    <- (StateServer -> ServerOptions) -> m ServerOptions
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> ServerOptions
soptions
  -- This state is quite small, fit for transmition to the client.
  -- The biggest part is content, which needs to be updated in clients
  -- at this point to keep them in sync with changes on the server.
  State
s <- m State
forall (m :: * -> *). MonadStateRead m => m State
getState
  DiscoveryKind
discoS <- (State -> DiscoveryKind) -> m DiscoveryKind
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> DiscoveryKind
sdiscoKind
  -- Thanks to the following, for any item with not hidden identity,
  -- the client has its kind from the start. The client needs to know this
  -- to have a fast way (faster that looking for @PresentAs@ flag on a list)
  -- of determining whether an item kind is already identified
  -- or needs identification.
  let discoKindFiltered :: DiscoveryKind
discoKindFiltered =
        let f :: ContentId ItemKind -> Bool
f ContentId ItemKind
kindId = Maybe (GroupName ItemKind) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (GroupName ItemKind) -> Bool)
-> Maybe (GroupName ItemKind) -> Bool
forall a b. (a -> b) -> a -> b
$ ItemKind -> Maybe (GroupName ItemKind)
IK.getMandatoryPresentAsFromKind
                                 (ItemKind -> Maybe (GroupName ItemKind))
-> ItemKind -> Maybe (GroupName ItemKind)
forall a b. (a -> b) -> a -> b
$ ContentData ItemKind -> ContentId ItemKind -> ItemKind
forall a. ContentData a -> ContentId a -> a
okind ContentData ItemKind
coitem ContentId ItemKind
kindId
        in (ContentId ItemKind -> Bool) -> DiscoveryKind -> DiscoveryKind
forall a k. (a -> Bool) -> EnumMap k a -> EnumMap k a
EM.filter ContentId ItemKind -> Bool
f DiscoveryKind
discoS
      defL :: State
defL | Bool
sknowMap = State
s
           | Bool
otherwise = State -> State
localFromGlobal State
s
      defLocal :: State
defLocal = (DiscoveryKind -> DiscoveryKind) -> State -> State
updateDiscoKind (DiscoveryKind -> DiscoveryKind -> DiscoveryKind
forall a b. a -> b -> a
const DiscoveryKind
discoKindFiltered) State
defL
  FactionDict
factionD <- (State -> FactionDict) -> m FactionDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> FactionDict
sfactionD
  EnumMap FactionId State
clientStatesOld <- (StateServer -> EnumMap FactionId State)
-> m (EnumMap FactionId State)
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> EnumMap FactionId State
sclientStates
  (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 {sclientStates :: EnumMap FactionId State
sclientStates = (Faction -> State) -> FactionDict -> EnumMap FactionId State
forall a b k. (a -> b) -> EnumMap k a -> EnumMap k b
EM.map (State -> Faction -> State
forall a b. a -> b -> a
const State
defLocal) FactionDict
factionD}
  -- Some item kinds preserve their identity and flavour throughout
  -- the whole metagame, until the savefiles is removed.
  -- These are usually not man-made items, because these can be made
  -- in many flavours so it may be hard to recognize them.
  -- However, the exact properties of even natural items may vary,
  -- so the random aspects of items, stored in @sdiscoAspect@
  -- are not preserved (a lot of other state components would need
  -- to be partially preserved, too, both on server and clients).
  --
  -- This is a terrible temporary hack until Player becomes content
  -- and we persistently store Player information on the server.
  let metaHolder :: EnumMap a Faction -> Maybe a
metaHolder EnumMap a Faction
factionDict = case ((a, Faction) -> Bool) -> [(a, Faction)] -> Maybe (a, Faction)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(a
_, Faction
fact) ->
                                      Faction -> Maybe TeamContinuity
gteamCont Faction
fact Maybe TeamContinuity -> Maybe TeamContinuity -> Bool
forall a. Eq a => a -> a -> Bool
== TeamContinuity -> Maybe TeamContinuity
forall a. a -> Maybe a
Just (Int -> TeamContinuity
TeamContinuity Int
1))
                                    ([(a, Faction)] -> Maybe (a, Faction))
-> [(a, Faction)] -> Maybe (a, Faction)
forall a b. (a -> b) -> a -> b
$ EnumMap a Faction -> [(a, Faction)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs EnumMap a Faction
factionDict of
        Maybe (a, Faction)
Nothing ->
          (a, Faction) -> a
forall a b. (a, b) -> a
fst ((a, Faction) -> a) -> Maybe (a, Faction) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((a, Faction) -> Bool) -> [(a, Faction)] -> Maybe (a, Faction)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(a
_, Faction
fact) -> Maybe TeamContinuity -> Bool
forall a. Maybe a -> Bool
isNothing (Faction -> Maybe TeamContinuity
gteamCont Faction
fact))
                       (EnumMap a Faction -> [(a, Faction)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs EnumMap a Faction
factionDict)
        Just (a
fid, Faction
_) -> a -> Maybe a
forall a. a -> Maybe a
Just a
fid
      mmetaHolderOld :: Maybe FactionId
mmetaHolderOld = FactionDict -> Maybe FactionId
forall a. Enum a => EnumMap a Faction -> Maybe a
metaHolder FactionDict
factionDold
  case Maybe FactionId
mmetaHolderOld of
    Just FactionId
metaHolderOld -> do
      let metaDiscoOld :: DiscoveryKind
metaDiscoOld =
            let sOld :: State
sOld = EnumMap FactionId State
clientStatesOld EnumMap FactionId State -> FactionId -> State
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
metaHolderOld
                disco :: DiscoveryKind
disco = State -> DiscoveryKind
sdiscoKind State
sOld
                inMetaGame :: ContentId ItemKind -> Bool
inMetaGame ContentId ItemKind
kindId = Flag -> Aspect
IK.SetFlag Flag
Ability.MetaGame
                                    Aspect -> [Aspect] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ItemKind -> [Aspect]
IK.iaspects (ContentData ItemKind -> ContentId ItemKind -> ItemKind
forall a. ContentData a -> ContentId a -> a
okind ContentData ItemKind
coitem ContentId ItemKind
kindId)
            in (ContentId ItemKind -> Bool) -> DiscoveryKind -> DiscoveryKind
forall a k. (a -> Bool) -> EnumMap k a -> EnumMap k a
EM.filter ContentId ItemKind -> Bool
inMetaGame DiscoveryKind
disco
          defDiscoOld :: State
defDiscoOld = (DiscoveryKind -> DiscoveryKind) -> State -> State
updateDiscoKind (DiscoveryKind
metaDiscoOld DiscoveryKind -> DiscoveryKind -> DiscoveryKind
forall k a. EnumMap k a -> EnumMap k a -> EnumMap k a
`EM.union`) State
defLocal
          metaHolderNew :: FactionId
metaHolderNew = Maybe FactionId -> FactionId
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe FactionId -> FactionId) -> Maybe FactionId -> FactionId
forall a b. (a -> b) -> a -> b
$ FactionDict -> Maybe FactionId
forall a. Enum a => EnumMap a Faction -> Maybe a
metaHolder 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 {sclientStates :: EnumMap FactionId State
sclientStates = FactionId
-> State -> EnumMap FactionId State -> EnumMap FactionId State
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert FactionId
metaHolderNew State
defDiscoOld
                             (EnumMap FactionId State -> EnumMap FactionId State)
-> EnumMap FactionId State -> EnumMap FactionId State
forall a b. (a -> b) -> a -> b
$ StateServer -> EnumMap FactionId State
sclientStates StateServer
ser}
    Maybe FactionId
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- probably no previous games
  -- Hack ends.
  EnumMap FactionId State
clientStatesNew <- (StateServer -> EnumMap FactionId State)
-> m (EnumMap FactionId State)
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> EnumMap FactionId State
sclientStates
  let updRestart :: FactionId -> SMGen -> UpdAtomic
updRestart FactionId
fid = FactionId
-> PerLid
-> State
-> Challenge
-> ClientOptions
-> SMGen
-> UpdAtomic
UpdRestart FactionId
fid (PerFid
pers PerFid -> FactionId -> PerLid
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid) (EnumMap FactionId State
clientStatesNew EnumMap FactionId State -> FactionId -> State
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid)
                                  Challenge
scurChalSer ClientOptions
sclientOptions
  (Key (EnumMap FactionId) -> Faction -> m ()) -> FactionDict -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(FoldableWithKey t, Monad m) =>
(Key t -> a -> m b) -> t a -> m ()
mapWithKeyM_ (\Key (EnumMap FactionId)
fid Faction
_ -> do
    -- Different seed for each client, to make sure behaviour is varied.
    SMGen
gen1 <- (StateServer -> SMGen) -> m SMGen
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> SMGen
srandom
    let (SMGen
clientRandomSeed, SMGen
gen2) = SMGen -> (SMGen, SMGen)
SM.splitSMGen SMGen
gen1
    (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 {srandom :: SMGen
srandom = SMGen
gen2}
    UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> SMGen -> UpdAtomic
updRestart Key (EnumMap FactionId)
FactionId
fid SMGen
clientRandomSeed) FactionDict
factionD
  Dungeon
dungeon <- (State -> Dungeon) -> m Dungeon
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> Dungeon
sdungeon
  let sactorTime :: EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
sactorTime = (Faction -> EnumMap LevelId (EnumMap ActorId Time))
-> FactionDict
-> EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
forall a b k. (a -> b) -> EnumMap k a -> EnumMap k b
EM.map (EnumMap LevelId (EnumMap ActorId Time)
-> Faction -> EnumMap LevelId (EnumMap ActorId Time)
forall a b. a -> b -> a
const ((Level -> EnumMap ActorId Time)
-> Dungeon -> EnumMap LevelId (EnumMap ActorId Time)
forall a b k. (a -> b) -> EnumMap k a -> EnumMap k b
EM.map (EnumMap ActorId Time -> Level -> EnumMap ActorId Time
forall a b. a -> b -> a
const EnumMap ActorId Time
forall k a. EnumMap k a
EM.empty) Dungeon
dungeon)) FactionDict
factionD
      strajTime :: EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
strajTime = (Faction -> EnumMap LevelId (EnumMap ActorId Time))
-> FactionDict
-> EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
forall a b k. (a -> b) -> EnumMap k a -> EnumMap k b
EM.map (EnumMap LevelId (EnumMap ActorId Time)
-> Faction -> EnumMap LevelId (EnumMap ActorId Time)
forall a b. a -> b -> a
const ((Level -> EnumMap ActorId Time)
-> Dungeon -> EnumMap LevelId (EnumMap ActorId Time)
forall a b k. (a -> b) -> EnumMap k a -> EnumMap k b
EM.map (EnumMap ActorId Time -> Level -> EnumMap ActorId Time
forall a b. a -> b -> a
const EnumMap ActorId Time
forall k a. EnumMap k a
EM.empty) Dungeon
dungeon)) 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 {EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
sactorTime :: EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
sactorTime :: EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
sactorTime, EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
strajTime :: EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
strajTime :: EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))
strajTime}
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
sshowItemSamples (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    SMGen
genOrig <- (StateServer -> SMGen) -> m SMGen
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> SMGen
srandom
    UniqueSet
uniqueSetOrig <- (StateServer -> UniqueSet) -> m UniqueSet
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> UniqueSet
suniqueSet
    GenerationAnalytics
genOld <- (StateServer -> GenerationAnalytics) -> m GenerationAnalytics
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> GenerationAnalytics
sgenerationAn
    GenerationAnalytics
genSampleTrunks <- Dungeon -> m GenerationAnalytics
forall (m :: * -> *).
MonadServerAtomic m =>
Dungeon -> m GenerationAnalytics
sampleTrunks Dungeon
dungeon
    GenerationAnalytics
genSampleItems <- Dungeon -> m GenerationAnalytics
forall (m :: * -> *).
MonadServerAtomic m =>
Dungeon -> m GenerationAnalytics
sampleItems Dungeon
dungeon
    let sgenerationAn :: GenerationAnalytics
sgenerationAn = [GenerationAnalytics] -> GenerationAnalytics
forall k a. [EnumMap k a] -> EnumMap k a
EM.unions [GenerationAnalytics
genSampleTrunks, GenerationAnalytics
genSampleItems, GenerationAnalytics
genOld]
    (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 {GenerationAnalytics
sgenerationAn :: GenerationAnalytics
sgenerationAn :: GenerationAnalytics
sgenerationAn}
    -- Make sure the debug generations don't affect future RNG behaviour.
    -- However, in the long run, AI behaviour is affected anyway,
    -- because the items randomly chosen for AI actions are ordered by their
    -- @ItemId@, which is affected by the sample item generation.
    (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 {srandom :: SMGen
srandom = SMGen
genOrig, suniqueSet :: UniqueSet
suniqueSet = UniqueSet
uniqueSetOrig}
  m ()
forall (m :: * -> *). MonadServerAtomic m => m ()
populateDungeon
  (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_ (FactionId -> LevelId -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> LevelId -> m ()
updatePer FactionId
fid) (Dungeon -> [LevelId]
forall k a. Enum k => EnumMap k a -> [k]
EM.keys Dungeon
dungeon))
        (FactionDict -> [FactionId]
forall k a. Enum k => EnumMap k a -> [k]
EM.keys FactionDict
factionD)

-- For simplicity only spawnable actors are taken into account, not starting
-- actors of any faction nor summonable actors.
sampleTrunks :: MonadServerAtomic m => Dungeon -> m GenerationAnalytics
sampleTrunks :: Dungeon -> m GenerationAnalytics
sampleTrunks Dungeon
dungeon = do
  COps{ContentData CaveKind
cocave :: COps -> ContentData CaveKind
cocave :: ContentData CaveKind
cocave, ContentData ItemKind
coitem :: ContentData ItemKind
coitem :: COps -> ContentData ItemKind
coitem} <- (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 getGroups :: Level -> [GroupName ItemKind]
getGroups Level{ContentId CaveKind
lkind :: Level -> ContentId CaveKind
lkind :: ContentId CaveKind
lkind} = ((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
$ CaveKind -> [(GroupName ItemKind, Int)]
CK.cactorFreq (CaveKind -> [(GroupName ItemKind, Int)])
-> CaveKind -> [(GroupName ItemKind, Int)]
forall a b. (a -> b) -> a -> b
$ ContentData CaveKind -> ContentId CaveKind -> CaveKind
forall a. ContentData a -> ContentId a -> a
okind ContentData CaveKind
cocave ContentId CaveKind
lkind
      groups :: [GroupName ItemKind]
groups = Set (GroupName ItemKind) -> [GroupName ItemKind]
forall a. Set a -> [a]
S.elems (Set (GroupName ItemKind) -> [GroupName ItemKind])
-> Set (GroupName ItemKind) -> [GroupName ItemKind]
forall a b. (a -> b) -> a -> b
$ [GroupName ItemKind] -> Set (GroupName ItemKind)
forall a. Ord a => [a] -> Set a
S.fromList ([GroupName ItemKind] -> Set (GroupName ItemKind))
-> [GroupName ItemKind] -> Set (GroupName ItemKind)
forall a b. (a -> b) -> a -> b
$ (Level -> [GroupName ItemKind]) -> [Level] -> [GroupName ItemKind]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Level -> [GroupName ItemKind]
getGroups ([Level] -> [GroupName ItemKind])
-> [Level] -> [GroupName ItemKind]
forall a b. (a -> b) -> a -> b
$ Dungeon -> [Level]
forall k a. EnumMap k a -> [a]
EM.elems Dungeon
dungeon
      addGroupToSet :: UniqueSet -> GroupName ItemKind -> UniqueSet
addGroupToSet !UniqueSet
s0 !GroupName ItemKind
grp =
        ContentData ItemKind
-> GroupName ItemKind
-> (UniqueSet
    -> Int -> ContentId ItemKind -> ItemKind -> UniqueSet)
-> UniqueSet
-> UniqueSet
forall a b.
ContentData a
-> GroupName a -> (b -> Int -> ContentId a -> a -> b) -> b -> b
ofoldlGroup' ContentData ItemKind
coitem GroupName ItemKind
grp (\UniqueSet
s Int
_ ContentId ItemKind
ik ItemKind
_ -> ContentId ItemKind -> UniqueSet -> UniqueSet
forall k. Enum k => k -> EnumSet k -> EnumSet k
ES.insert ContentId ItemKind
ik UniqueSet
s) UniqueSet
s0
      trunkKindIds :: [ContentId ItemKind]
trunkKindIds = UniqueSet -> [ContentId ItemKind]
forall k. Enum k => EnumSet k -> [k]
ES.elems (UniqueSet -> [ContentId ItemKind])
-> UniqueSet -> [ContentId ItemKind]
forall a b. (a -> b) -> a -> b
$ (UniqueSet -> GroupName ItemKind -> UniqueSet)
-> UniqueSet -> [GroupName ItemKind] -> UniqueSet
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' UniqueSet -> GroupName ItemKind -> UniqueSet
addGroupToSet UniqueSet
forall k. EnumSet k
ES.empty [GroupName ItemKind]
groups
      minLid :: LevelId
minLid = (LevelId, Level) -> LevelId
forall a b. (a, b) -> a
fst ((LevelId, Level) -> LevelId) -> (LevelId, Level) -> LevelId
forall a b. (a -> b) -> a -> b
$ ((LevelId, Level) -> (LevelId, Level) -> Ordering)
-> [(LevelId, Level)] -> (LevelId, Level)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (((LevelId, Level) -> AbsDepth)
-> (LevelId, Level) -> (LevelId, Level) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Level -> AbsDepth
ldepth (Level -> AbsDepth)
-> ((LevelId, Level) -> Level) -> (LevelId, Level) -> AbsDepth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LevelId, Level) -> Level
forall a b. (a, b) -> b
snd))
                   ([(LevelId, Level)] -> (LevelId, Level))
-> [(LevelId, Level)] -> (LevelId, Level)
forall a b. (a -> b) -> a -> b
$ Dungeon -> [(LevelId, Level)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs Dungeon
dungeon
  Level{AbsDepth
ldepth :: AbsDepth
ldepth :: Level -> AbsDepth
ldepth} <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel LevelId
minLid
  let regItem :: ContentId ItemKind -> m (Maybe ItemId)
regItem ContentId ItemKind
itemKindId = do
        let itemKind :: ItemKind
itemKind = ContentData ItemKind -> ContentId ItemKind -> ItemKind
forall a. ContentData a -> ContentId a -> a
okind ContentData ItemKind
coitem ContentId ItemKind
itemKindId
            freq :: Frequency (ContentId ItemKind, ItemKind)
freq = (ContentId ItemKind, ItemKind)
-> Frequency (ContentId ItemKind, ItemKind)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ContentId ItemKind
itemKindId, ItemKind
itemKind)
        case ItemKind -> FactionDict -> [(FactionId, Faction)]
possibleActorFactions ItemKind
itemKind FactionDict
factionD of
          [] -> Maybe ItemId -> m (Maybe ItemId)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ItemId
forall a. Maybe a
Nothing
          (FactionId
fid, Faction
_) : [(FactionId, Faction)]
_ -> do
            let c :: Container
c = FactionId -> LevelId -> Point -> Container
CTrunk FactionId
fid LevelId
minLid Point
originPoint
                jfid :: Maybe FactionId
jfid = FactionId -> Maybe FactionId
forall a. a -> Maybe a
Just FactionId
fid
            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 -> [Char] -> m (Maybe ItemId)
forall a. HasCallStack => [Char] -> a
error [Char]
"sampleTrunks: can't create actor trunk"
              NewItem (ItemKnown ItemIdentity
kindIx AspectRecord
ar Maybe FactionId
_) ItemFull
itemFullRaw ItemQuant
itemQuant -> do
                let itemKnown :: ItemKnown
itemKnown = ItemIdentity -> AspectRecord -> Maybe FactionId -> ItemKnown
ItemKnown ItemIdentity
kindIx AspectRecord
ar Maybe FactionId
jfid
                    itemFull :: ItemFull
itemFull =
                      ItemFull
itemFullRaw {itemBase :: Item
itemBase = (ItemFull -> Item
itemBase ItemFull
itemFullRaw) {Maybe FactionId
jfid :: Maybe FactionId
jfid :: Maybe FactionId
jfid}}
                ItemId -> Maybe ItemId
forall a. a -> Maybe a
Just (ItemId -> Maybe ItemId) -> m ItemId -> m (Maybe ItemId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> ItemFullKit -> ItemKnown -> Container -> m ItemId
forall (m :: * -> *).
MonadServerAtomic m =>
Bool -> ItemFullKit -> ItemKnown -> Container -> m ItemId
registerItem Bool
False (ItemFull
itemFull, ItemQuant
itemQuant) ItemKnown
itemKnown Container
c
  [Maybe ItemId]
miids <- (ContentId ItemKind -> m (Maybe ItemId))
-> [ContentId ItemKind] -> m [Maybe ItemId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ContentId ItemKind -> m (Maybe ItemId)
regItem [ContentId ItemKind]
trunkKindIds
  GenerationAnalytics -> m GenerationAnalytics
forall (m :: * -> *) a. Monad m => a -> m a
return (GenerationAnalytics -> m GenerationAnalytics)
-> GenerationAnalytics -> m GenerationAnalytics
forall a b. (a -> b) -> a -> b
$! SLore -> EnumMap ItemId Int -> GenerationAnalytics
forall k a. Enum k => k -> a -> EnumMap k a
EM.singleton SLore
STrunk
            (EnumMap ItemId Int -> GenerationAnalytics)
-> EnumMap ItemId Int -> GenerationAnalytics
forall a b. (a -> b) -> a -> b
$ [(ItemId, Int)] -> EnumMap ItemId Int
forall k a. Enum k => [(k, a)] -> EnumMap k a
EM.fromDistinctAscList ([(ItemId, Int)] -> EnumMap ItemId Int)
-> [(ItemId, Int)] -> EnumMap ItemId Int
forall a b. (a -> b) -> a -> b
$ [ItemId] -> [Int] -> [(ItemId, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Maybe ItemId] -> [ItemId]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ItemId]
miids) ([Int] -> [(ItemId, Int)]) -> [Int] -> [(ItemId, Int)]
forall a b. (a -> b) -> a -> b
$ Int -> [Int]
forall a. a -> [a]
repeat Int
0

-- For simplicity, only actors generated on the ground are taken into account.
-- not starting items of any actors nor items that can be create by effects
-- occuring in the game.
sampleItems :: MonadServerAtomic m => Dungeon -> m GenerationAnalytics
sampleItems :: Dungeon -> m GenerationAnalytics
sampleItems Dungeon
dungeon = do
  COps{ContentData CaveKind
cocave :: ContentData CaveKind
cocave :: COps -> ContentData CaveKind
cocave, ContentData ItemKind
coitem :: ContentData ItemKind
coitem :: COps -> ContentData ItemKind
coitem} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  let getGroups :: Level -> [GroupName ItemKind]
getGroups Level{ContentId CaveKind
lkind :: ContentId CaveKind
lkind :: Level -> ContentId CaveKind
lkind} = ((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
$ CaveKind -> [(GroupName ItemKind, Int)]
CK.citemFreq (CaveKind -> [(GroupName ItemKind, Int)])
-> CaveKind -> [(GroupName ItemKind, Int)]
forall a b. (a -> b) -> a -> b
$ ContentData CaveKind -> ContentId CaveKind -> CaveKind
forall a. ContentData a -> ContentId a -> a
okind ContentData CaveKind
cocave ContentId CaveKind
lkind
      groups :: [GroupName ItemKind]
groups = Set (GroupName ItemKind) -> [GroupName ItemKind]
forall a. Set a -> [a]
S.elems (Set (GroupName ItemKind) -> [GroupName ItemKind])
-> Set (GroupName ItemKind) -> [GroupName ItemKind]
forall a b. (a -> b) -> a -> b
$ [GroupName ItemKind] -> Set (GroupName ItemKind)
forall a. Ord a => [a] -> Set a
S.fromList ([GroupName ItemKind] -> Set (GroupName ItemKind))
-> [GroupName ItemKind] -> Set (GroupName ItemKind)
forall a b. (a -> b) -> a -> b
$ (Level -> [GroupName ItemKind]) -> [Level] -> [GroupName ItemKind]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Level -> [GroupName ItemKind]
getGroups ([Level] -> [GroupName ItemKind])
-> [Level] -> [GroupName ItemKind]
forall a b. (a -> b) -> a -> b
$ Dungeon -> [Level]
forall k a. EnumMap k a -> [a]
EM.elems Dungeon
dungeon
      addGroupToSet :: UniqueSet -> GroupName ItemKind -> UniqueSet
addGroupToSet !UniqueSet
s0 !GroupName ItemKind
grp =
        ContentData ItemKind
-> GroupName ItemKind
-> (UniqueSet
    -> Int -> ContentId ItemKind -> ItemKind -> UniqueSet)
-> UniqueSet
-> UniqueSet
forall a b.
ContentData a
-> GroupName a -> (b -> Int -> ContentId a -> a -> b) -> b -> b
ofoldlGroup' ContentData ItemKind
coitem GroupName ItemKind
grp (\UniqueSet
s Int
_ ContentId ItemKind
ik ItemKind
_ -> ContentId ItemKind -> UniqueSet -> UniqueSet
forall k. Enum k => k -> EnumSet k -> EnumSet k
ES.insert ContentId ItemKind
ik UniqueSet
s) UniqueSet
s0
      itemKindIds :: [ContentId ItemKind]
itemKindIds = UniqueSet -> [ContentId ItemKind]
forall k. Enum k => EnumSet k -> [k]
ES.elems (UniqueSet -> [ContentId ItemKind])
-> UniqueSet -> [ContentId ItemKind]
forall a b. (a -> b) -> a -> b
$ (UniqueSet -> GroupName ItemKind -> UniqueSet)
-> UniqueSet -> [GroupName ItemKind] -> UniqueSet
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' UniqueSet -> GroupName ItemKind -> UniqueSet
addGroupToSet UniqueSet
forall k. EnumSet k
ES.empty [GroupName ItemKind]
groups
      minLid :: LevelId
minLid = (LevelId, Level) -> LevelId
forall a b. (a, b) -> a
fst ((LevelId, Level) -> LevelId) -> (LevelId, Level) -> LevelId
forall a b. (a -> b) -> a -> b
$ ((LevelId, Level) -> (LevelId, Level) -> Ordering)
-> [(LevelId, Level)] -> (LevelId, Level)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (((LevelId, Level) -> AbsDepth)
-> (LevelId, Level) -> (LevelId, Level) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Level -> AbsDepth
ldepth (Level -> AbsDepth)
-> ((LevelId, Level) -> Level) -> (LevelId, Level) -> AbsDepth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LevelId, Level) -> Level
forall a b. (a, b) -> b
snd))
                   ([(LevelId, Level)] -> (LevelId, Level))
-> [(LevelId, Level)] -> (LevelId, Level)
forall a b. (a -> b) -> a -> b
$ Dungeon -> [(LevelId, Level)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs Dungeon
dungeon
  Level{AbsDepth
ldepth :: AbsDepth
ldepth :: Level -> AbsDepth
ldepth} <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel LevelId
minLid
  let regItem :: ContentId ItemKind -> m (Maybe ItemId)
regItem ContentId ItemKind
itemKindId = do
        let itemKind :: ItemKind
itemKind = ContentData ItemKind -> ContentId ItemKind -> ItemKind
forall a. ContentData a -> ContentId a -> a
okind ContentData ItemKind
coitem ContentId ItemKind
itemKindId
            freq :: Frequency (ContentId ItemKind, ItemKind)
freq = (ContentId ItemKind, ItemKind)
-> Frequency (ContentId ItemKind, ItemKind)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ContentId ItemKind
itemKindId, ItemKind
itemKind)
            c :: Container
c = LevelId -> Point -> Container
CFloor LevelId
minLid Point
originPoint
        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 -> [Char] -> m (Maybe ItemId)
forall a. HasCallStack => [Char] -> a
error [Char]
"sampleItems: can't create sample item"
          NewItem ItemKnown
itemKnown ItemFull
itemFull ItemQuant
_ ->
            ItemId -> Maybe ItemId
forall a. a -> Maybe a
Just (ItemId -> Maybe ItemId) -> m ItemId -> m (Maybe ItemId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> ItemFullKit -> ItemKnown -> Container -> m ItemId
forall (m :: * -> *).
MonadServerAtomic m =>
Bool -> ItemFullKit -> ItemKnown -> Container -> m ItemId
registerItem Bool
False (ItemFull
itemFull, (Int
0, [])) ItemKnown
itemKnown Container
c
  [Maybe ItemId]
miids <- (ContentId ItemKind -> m (Maybe ItemId))
-> [ContentId ItemKind] -> m [Maybe ItemId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ContentId ItemKind -> m (Maybe ItemId)
regItem [ContentId ItemKind]
itemKindIds
  GenerationAnalytics -> m GenerationAnalytics
forall (m :: * -> *) a. Monad m => a -> m a
return (GenerationAnalytics -> m GenerationAnalytics)
-> GenerationAnalytics -> m GenerationAnalytics
forall a b. (a -> b) -> a -> b
$! SLore -> EnumMap ItemId Int -> GenerationAnalytics
forall k a. Enum k => k -> a -> EnumMap k a
EM.singleton SLore
SItem
            (EnumMap ItemId Int -> GenerationAnalytics)
-> EnumMap ItemId Int -> GenerationAnalytics
forall a b. (a -> b) -> a -> b
$ [(ItemId, Int)] -> EnumMap ItemId Int
forall k a. Enum k => [(k, a)] -> EnumMap k a
EM.fromDistinctAscList ([(ItemId, Int)] -> EnumMap ItemId Int)
-> [(ItemId, Int)] -> EnumMap ItemId Int
forall a b. (a -> b) -> a -> b
$ [ItemId] -> [Int] -> [(ItemId, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Maybe ItemId] -> [ItemId]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ItemId]
miids) ([Int] -> [(ItemId, Int)]) -> [Int] -> [(ItemId, Int)]
forall a b. (a -> b) -> a -> b
$ Int -> [Int]
forall a. a -> [a]
repeat Int
0

mapFromFuns :: Ord b => [a] -> [a -> b] -> M.Map b a
mapFromFuns :: [a] -> [a -> b] -> Map b a
mapFromFuns [a]
domain =
  let fromFun :: (a -> b) -> Map b a -> Map b a
fromFun a -> b
f Map b a
m1 =
        let invAssocs :: [(b, a)]
invAssocs = (a -> (b, a)) -> [a] -> [(b, a)]
forall a b. (a -> b) -> [a] -> [b]
map (\a
c -> (a -> b
f a
c, a
c)) [a]
domain
            m2 :: Map b a
m2 = [(b, a)] -> Map b a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(b, a)]
invAssocs
        in Map b a
m2 Map b a -> Map b a -> Map b a
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map b a
m1
  in ((a -> b) -> Map b a -> Map b a) -> Map b a -> [a -> b] -> Map b a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a -> b) -> Map b a -> Map b a
fromFun Map b a
forall k a. Map k a
M.empty

resetFactions :: FactionDict -> ContentId ModeKind -> Int -> Dice.AbsDepth
              -> Roster
              -> Rnd FactionDict
resetFactions :: FactionDict
-> ContentId ModeKind
-> Int
-> AbsDepth
-> Roster
-> Rnd FactionDict
resetFactions FactionDict
factionDold ContentId ModeKind
gameModeIdOld Int
curDiffSerOld AbsDepth
totalDepth Roster
players = do
  let rawCreate :: (Int,
 (Player, Maybe TeamContinuity, [(Int, Dice, GroupName ItemKind)]))
-> StateT SMGen Identity (FactionId, Faction)
rawCreate (Int
ix, (gplayer :: Player
gplayer@Player{Bool
HiCondPoly
[GroupName ItemKind]
Maybe AutoLeader
Text
Doctrine
Skills
funderAI :: Player -> Bool
fhasUI :: Player -> Bool
fleaderMode :: Player -> Maybe AutoLeader
fdoctrine :: Player -> Doctrine
fhasGender :: Player -> Bool
fhiCondPoly :: Player -> HiCondPoly
fneverEmpty :: Player -> Bool
fcanEscape :: Player -> Bool
fskillsOther :: Player -> Skills
fgroups :: Player -> [GroupName ItemKind]
fname :: Player -> Text
funderAI :: Bool
fhasUI :: Bool
fleaderMode :: Maybe AutoLeader
fdoctrine :: Doctrine
fhasGender :: Bool
fhiCondPoly :: HiCondPoly
fneverEmpty :: Bool
fcanEscape :: Bool
fskillsOther :: Skills
fgroups :: [GroupName ItemKind]
fname :: Text
..}, Maybe TeamContinuity
gteamCont, [(Int, Dice, GroupName ItemKind)]
initialActors)) = do
        let castInitialActors :: (Int, Dice, GroupName ItemKind)
-> StateT SMGen Identity (Int, Int, GroupName ItemKind)
castInitialActors (Int
ln, Dice
d, GroupName ItemKind
actorGroup) = do
              Int
n <- AbsDepth -> AbsDepth -> Dice -> Rnd Int
castDice (Int -> AbsDepth
Dice.AbsDepth (Int -> AbsDepth) -> Int -> AbsDepth
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Num a => a -> a
abs Int
ln) AbsDepth
totalDepth Dice
d
              (Int, Int, GroupName ItemKind)
-> StateT SMGen Identity (Int, Int, GroupName ItemKind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ln, Int
n, GroupName ItemKind
actorGroup)
        [(Int, Int, GroupName ItemKind)]
ginitial <- ((Int, Dice, GroupName ItemKind)
 -> StateT SMGen Identity (Int, Int, GroupName ItemKind))
-> [(Int, Dice, GroupName ItemKind)]
-> StateT SMGen Identity [(Int, Int, GroupName ItemKind)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int, Dice, GroupName ItemKind)
-> StateT SMGen Identity (Int, Int, GroupName ItemKind)
castInitialActors [(Int, Dice, GroupName ItemKind)]
initialActors
        let cmap :: Map Text Color
cmap =
              [Color] -> [Color -> Text] -> Map Text Color
forall b a. Ord b => [a] -> [a -> b] -> Map b a
mapFromFuns [Color]
Color.legalFgCol
                          [Color -> Text
colorToTeamName, Color -> Text
colorToPlainName, Color -> Text
colorToFancyName]
            colorName :: Text
colorName = Text -> Text
T.toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. [a] -> a
head ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words Text
fname
            prefix :: Text
prefix = case (Maybe AutoLeader
fleaderMode, Bool
funderAI) of
              (Maybe AutoLeader
Nothing, Bool
False) -> Text
"Uncoordinated"
              (Maybe AutoLeader
Nothing, Bool
True) -> Text
"Loose"
              (Just{}, Bool
False) -> Text
"Autonomous"
              (Just{}, Bool
True) -> Text
"Controlled"
            gnameNew :: Text
gnameNew = Text
prefix Text -> Text -> Text
<+> if Bool
fhasGender
                                  then [Part] -> Text
makePhrase [Part -> Part
MU.Ws (Part -> Part) -> Part -> Part
forall a b. (a -> b) -> a -> b
$ Text -> Part
MU.Text Text
fname]
                                  else Text
fname
            gcolor :: Color
gcolor = Color -> Text -> Map Text Color -> Color
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Color
Color.BrWhite Text
colorName Map Text Color
cmap
            gvictimsDnew :: EnumMap
  (ContentId ModeKind) (IntMap (EnumMap (ContentId ItemKind) Int))
gvictimsDnew = case (Faction -> Bool) -> [Faction] -> Maybe Faction
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Faction
fact -> Faction -> Text
gname Faction
fact Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
gnameNew)
                                ([Faction] -> Maybe Faction) -> [Faction] -> Maybe Faction
forall a b. (a -> b) -> a -> b
$ FactionDict -> [Faction]
forall k a. EnumMap k a -> [a]
EM.elems FactionDict
factionDold of
              Maybe Faction
Nothing -> EnumMap
  (ContentId ModeKind) (IntMap (EnumMap (ContentId ItemKind) Int))
forall k a. EnumMap k a
EM.empty
              Just Faction
fact ->
                let sing :: IntMap (EnumMap (ContentId ItemKind) Int)
sing = Int
-> EnumMap (ContentId ItemKind) Int
-> IntMap (EnumMap (ContentId ItemKind) Int)
forall a. Int -> a -> IntMap a
IM.singleton Int
curDiffSerOld (Faction -> EnumMap (ContentId ItemKind) Int
gvictims Faction
fact)
                    f :: IntMap (EnumMap k Int)
-> IntMap (EnumMap k Int) -> IntMap (EnumMap k Int)
f = (EnumMap k Int -> EnumMap k Int -> EnumMap k Int)
-> IntMap (EnumMap k Int)
-> IntMap (EnumMap k Int)
-> IntMap (EnumMap k Int)
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith ((Int -> Int -> Int)
-> EnumMap k Int -> EnumMap k Int -> EnumMap k Int
forall a k.
(a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
EM.unionWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+))
                in (IntMap (EnumMap (ContentId ItemKind) Int)
 -> IntMap (EnumMap (ContentId ItemKind) Int)
 -> IntMap (EnumMap (ContentId ItemKind) Int))
-> ContentId ModeKind
-> IntMap (EnumMap (ContentId ItemKind) Int)
-> EnumMap
     (ContentId ModeKind) (IntMap (EnumMap (ContentId ItemKind) Int))
-> EnumMap
     (ContentId ModeKind) (IntMap (EnumMap (ContentId ItemKind) Int))
forall k a.
Enum k =>
(a -> a -> a) -> k -> a -> EnumMap k a -> EnumMap k a
EM.insertWith IntMap (EnumMap (ContentId ItemKind) Int)
-> IntMap (EnumMap (ContentId ItemKind) Int)
-> IntMap (EnumMap (ContentId ItemKind) Int)
forall k.
IntMap (EnumMap k Int)
-> IntMap (EnumMap k Int) -> IntMap (EnumMap k Int)
f ContentId ModeKind
gameModeIdOld IntMap (EnumMap (ContentId ItemKind) Int)
sing (EnumMap
   (ContentId ModeKind) (IntMap (EnumMap (ContentId ItemKind) Int))
 -> EnumMap
      (ContentId ModeKind) (IntMap (EnumMap (ContentId ItemKind) Int)))
-> EnumMap
     (ContentId ModeKind) (IntMap (EnumMap (ContentId ItemKind) Int))
-> EnumMap
     (ContentId ModeKind) (IntMap (EnumMap (ContentId ItemKind) Int))
forall a b. (a -> b) -> a -> b
$ Faction
-> EnumMap
     (ContentId ModeKind) (IntMap (EnumMap (ContentId ItemKind) Int))
gvictimsD Faction
fact
        let gname :: Text
gname = Text
gnameNew
            gdipl :: EnumMap k a
gdipl = EnumMap k a
forall k a. EnumMap k a
EM.empty  -- fixed below
            gquit :: Maybe a
gquit = Maybe a
forall a. Maybe a
Nothing
            _gleader :: Maybe a
_gleader = Maybe a
forall a. Maybe a
Nothing
            gvictims :: EnumMap k a
gvictims = EnumMap k a
forall k a. EnumMap k a
EM.empty
            gvictimsD :: EnumMap
  (ContentId ModeKind) (IntMap (EnumMap (ContentId ItemKind) Int))
gvictimsD = EnumMap
  (ContentId ModeKind) (IntMap (EnumMap (ContentId ItemKind) Int))
gvictimsDnew
            gstash :: Maybe a
gstash = Maybe a
forall a. Maybe a
Nothing
        (FactionId, Faction) -> StateT SMGen Identity (FactionId, Faction)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> FactionId
forall a. Enum a => Int -> a
toEnum (Int -> FactionId) -> Int -> FactionId
forall a b. (a -> b) -> a -> b
$ if Bool
fhasUI then Int
ix else -Int
ix, Faction :: Text
-> Color
-> Player
-> Maybe TeamContinuity
-> [(Int, Int, GroupName ItemKind)]
-> Dipl
-> Maybe Status
-> Maybe ActorId
-> Maybe (LevelId, Point)
-> EnumMap (ContentId ItemKind) Int
-> EnumMap
     (ContentId ModeKind) (IntMap (EnumMap (ContentId ItemKind) Int))
-> Faction
Faction{[(Int, Int, GroupName ItemKind)]
Maybe (LevelId, Point)
Maybe ActorId
Maybe TeamContinuity
Maybe Status
EnumMap (ContentId ItemKind) Int
EnumMap
  (ContentId ModeKind) (IntMap (EnumMap (ContentId ItemKind) Int))
Dipl
Text
Color
Player
forall a. Maybe a
forall k a. EnumMap k a
gstash :: Maybe (LevelId, Point)
_gleader :: Maybe ActorId
gquit :: Maybe Status
gdipl :: Dipl
ginitial :: [(Int, Int, GroupName ItemKind)]
gplayer :: Player
gcolor :: Color
gstash :: forall a. Maybe a
gvictimsD :: EnumMap
  (ContentId ModeKind) (IntMap (EnumMap (ContentId ItemKind) Int))
gvictims :: forall k a. EnumMap k a
_gleader :: forall a. Maybe a
gquit :: forall a. Maybe a
gdipl :: forall k a. EnumMap k a
gname :: Text
gvictimsD :: EnumMap
  (ContentId ModeKind) (IntMap (EnumMap (ContentId ItemKind) Int))
gvictims :: EnumMap (ContentId ItemKind) Int
gname :: Text
gcolor :: Color
ginitial :: [(Int, Int, GroupName ItemKind)]
gteamCont :: Maybe TeamContinuity
gplayer :: Player
gteamCont :: Maybe TeamContinuity
..})
  [(FactionId, Faction)]
lFs <- ((Int,
  (Player, Maybe TeamContinuity, [(Int, Dice, GroupName ItemKind)]))
 -> StateT SMGen Identity (FactionId, Faction))
-> [(Int,
     (Player, Maybe TeamContinuity, [(Int, Dice, GroupName ItemKind)]))]
-> StateT SMGen Identity [(FactionId, Faction)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int,
 (Player, Maybe TeamContinuity, [(Int, Dice, GroupName ItemKind)]))
-> StateT SMGen Identity (FactionId, Faction)
rawCreate ([(Int,
   (Player, Maybe TeamContinuity, [(Int, Dice, GroupName ItemKind)]))]
 -> StateT SMGen Identity [(FactionId, Faction)])
-> [(Int,
     (Player, Maybe TeamContinuity, [(Int, Dice, GroupName ItemKind)]))]
-> StateT SMGen Identity [(FactionId, Faction)]
forall a b. (a -> b) -> a -> b
$ [Int]
-> [(Player, Maybe TeamContinuity,
     [(Int, Dice, GroupName ItemKind)])]
-> [(Int,
     (Player, Maybe TeamContinuity, [(Int, Dice, GroupName ItemKind)]))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] ([(Player, Maybe TeamContinuity,
   [(Int, Dice, GroupName ItemKind)])]
 -> [(Int,
      (Player, Maybe TeamContinuity,
       [(Int, Dice, GroupName ItemKind)]))])
-> [(Player, Maybe TeamContinuity,
     [(Int, Dice, GroupName ItemKind)])]
-> [(Int,
     (Player, Maybe TeamContinuity, [(Int, Dice, GroupName ItemKind)]))]
forall a b. (a -> b) -> a -> b
$ Roster
-> [(Player, Maybe TeamContinuity,
     [(Int, Dice, GroupName ItemKind)])]
rosterList Roster
players
  let swapIx :: [(Text, Text)] -> [(FactionId, FactionId)]
swapIx [(Text, Text)]
l =
        let findPlayerName :: Text -> t (a, Faction) -> Maybe (a, Faction)
findPlayerName Text
name = ((a, Faction) -> Bool) -> t (a, Faction) -> Maybe (a, Faction)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==) (Text -> Bool) -> ((a, Faction) -> Text) -> (a, Faction) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Player -> Text
fname (Player -> Text)
-> ((a, Faction) -> Player) -> (a, Faction) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Faction -> Player
gplayer (Faction -> Player)
-> ((a, Faction) -> Faction) -> (a, Faction) -> Player
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Faction) -> Faction
forall a b. (a, b) -> b
snd)
            f :: (Text, Text) -> (FactionId, FactionId)
f (Text
name1, Text
name2) =
              case (Text -> [(FactionId, Faction)] -> Maybe (FactionId, Faction)
forall (t :: * -> *) a.
Foldable t =>
Text -> t (a, Faction) -> Maybe (a, Faction)
findPlayerName Text
name1 [(FactionId, Faction)]
lFs, Text -> [(FactionId, Faction)] -> Maybe (FactionId, Faction)
forall (t :: * -> *) a.
Foldable t =>
Text -> t (a, Faction) -> Maybe (a, Faction)
findPlayerName Text
name2 [(FactionId, Faction)]
lFs) of
                (Just (FactionId
ix1, Faction
_), Just (FactionId
ix2, Faction
_)) -> (FactionId
ix1, FactionId
ix2)
                (Maybe (FactionId, Faction), Maybe (FactionId, Faction))
_ -> [Char] -> (FactionId, FactionId)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (FactionId, FactionId))
-> [Char] -> (FactionId, FactionId)
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown faction"
                             [Char] -> ((Text, Text), [(FactionId, Faction)]) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` ((Text
name1, Text
name2), [(FactionId, Faction)]
lFs)
            ixs :: [(FactionId, FactionId)]
ixs = ((Text, Text) -> (FactionId, FactionId))
-> [(Text, Text)] -> [(FactionId, FactionId)]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> (FactionId, FactionId)
f [(Text, Text)]
l
        -- Only symmetry is ensured, everything else is permitted, e.g.,
        -- a faction in alliance with two others that are at war.
        in [(FactionId, FactionId)]
ixs [(FactionId, FactionId)]
-> [(FactionId, FactionId)] -> [(FactionId, FactionId)]
forall a. [a] -> [a] -> [a]
++ ((FactionId, FactionId) -> (FactionId, FactionId))
-> [(FactionId, FactionId)] -> [(FactionId, FactionId)]
forall a b. (a -> b) -> [a] -> [b]
map (FactionId, FactionId) -> (FactionId, FactionId)
forall a b. (a, b) -> (b, a)
swap [(FactionId, FactionId)]
ixs
      mkDipl :: Diplomacy
-> EnumMap k Faction -> t (k, FactionId) -> EnumMap k Faction
mkDipl Diplomacy
diplMode =
        let f :: (k, FactionId) -> EnumMap k Faction -> EnumMap k Faction
f (k
ix1, FactionId
ix2) =
              let adj :: Faction -> Faction
adj Faction
fact = Faction
fact {gdipl :: Dipl
gdipl = FactionId -> Diplomacy -> Dipl -> Dipl
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert FactionId
ix2 Diplomacy
diplMode (Faction -> Dipl
gdipl Faction
fact)}
              in (Faction -> Faction) -> k -> EnumMap k Faction -> EnumMap k Faction
forall k a. Enum k => (a -> a) -> k -> EnumMap k a -> EnumMap k a
EM.adjust Faction -> Faction
adj k
ix1
        in ((k, FactionId) -> EnumMap k Faction -> EnumMap k Faction)
-> EnumMap k Faction -> t (k, FactionId) -> EnumMap k Faction
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (k, FactionId) -> EnumMap k Faction -> EnumMap k Faction
f
      rawFs :: FactionDict
rawFs = [(FactionId, Faction)] -> FactionDict
forall k a. Enum k => [(k, a)] -> EnumMap k a
EM.fromList [(FactionId, Faction)]
lFs
      -- War overrides alliance, so 'warFs' second.
      allianceFs :: FactionDict
allianceFs = Diplomacy -> FactionDict -> [(FactionId, FactionId)] -> FactionDict
forall k (t :: * -> *).
(Enum k, Foldable t) =>
Diplomacy
-> EnumMap k Faction -> t (k, FactionId) -> EnumMap k Faction
mkDipl Diplomacy
Alliance FactionDict
rawFs ([(Text, Text)] -> [(FactionId, FactionId)]
swapIx (Roster -> [(Text, Text)]
rosterAlly Roster
players))
      warFs :: FactionDict
warFs = Diplomacy -> FactionDict -> [(FactionId, FactionId)] -> FactionDict
forall k (t :: * -> *).
(Enum k, Foldable t) =>
Diplomacy
-> EnumMap k Faction -> t (k, FactionId) -> EnumMap k Faction
mkDipl Diplomacy
War FactionDict
allianceFs ([(Text, Text)] -> [(FactionId, FactionId)]
swapIx (Roster -> [(Text, Text)]
rosterEnemy Roster
players))
  FactionDict -> Rnd FactionDict
forall (m :: * -> *) a. Monad m => a -> m a
return (FactionDict -> Rnd FactionDict) -> FactionDict -> Rnd FactionDict
forall a b. (a -> b) -> a -> b
$! FactionDict
warFs

gameReset :: MonadServer m
          => ServerOptions -> Maybe (GroupName ModeKind)
          -> Maybe SM.SMGen -> m State
gameReset :: ServerOptions
-> Maybe (GroupName ModeKind) -> Maybe SMGen -> m State
gameReset ServerOptions
serverOptions Maybe (GroupName ModeKind)
mGameMode Maybe SMGen
mrandom = do
  -- Dungeon seed generation has to come first, to ensure item boosting
  -- is determined by the dungeon RNG.
  cops :: COps
cops@COps{ContentData ModeKind
comode :: COps -> ContentData ModeKind
comode :: ContentData ModeKind
comode} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  SMGen
dungeonSeed <- Maybe SMGen -> m SMGen
forall (m :: * -> *). MonadServer m => Maybe SMGen -> m SMGen
getSetGen (Maybe SMGen -> m SMGen) -> Maybe SMGen -> m SMGen
forall a b. (a -> b) -> a -> b
$ ServerOptions -> Maybe SMGen
sdungeonRng ServerOptions
serverOptions Maybe SMGen -> Maybe SMGen -> Maybe SMGen
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe SMGen
mrandom
  SMGen
srandom <- Maybe SMGen -> m SMGen
forall (m :: * -> *). MonadServer m => Maybe SMGen -> m SMGen
getSetGen (Maybe SMGen -> m SMGen) -> Maybe SMGen -> m SMGen
forall a b. (a -> b) -> a -> b
$ ServerOptions -> Maybe SMGen
smainRng ServerOptions
serverOptions Maybe SMGen -> Maybe SMGen -> Maybe SMGen
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe SMGen
mrandom
  let srngs :: RNGs
srngs = Maybe SMGen -> Maybe SMGen -> RNGs
RNGs (SMGen -> Maybe SMGen
forall a. a -> Maybe a
Just SMGen
dungeonSeed) (SMGen -> Maybe SMGen
forall a. a -> Maybe a
Just SMGen
srandom)
  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
srngs
  ScoreDict
scoreTable <- COps -> m ScoreDict
forall (m :: * -> *). MonadServer m => COps -> m ScoreDict
restoreScore COps
cops
  FactionDict
factionDold <- (State -> FactionDict) -> m FactionDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> FactionDict
sfactionD
  ContentId ModeKind
gameModeIdOld <- (State -> ContentId ModeKind) -> m (ContentId ModeKind)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> ContentId ModeKind
sgameModeId
  GearOfTeams
teamGearOld <- (StateServer -> GearOfTeams) -> m GearOfTeams
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> GearOfTeams
steamGear
  FlavourMap
flavourOld <- (StateServer -> FlavourMap) -> m FlavourMap
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> FlavourMap
sflavour
  DiscoveryKindRev
discoKindRevOld <- (StateServer -> DiscoveryKindRev) -> m DiscoveryKindRev
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> DiscoveryKindRev
sdiscoKindRev
  EnumMap FactionId State
clientStatesOld <- (StateServer -> EnumMap FactionId State)
-> m (EnumMap FactionId State)
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> EnumMap FactionId State
sclientStates
  Challenge
curChalSer <- (StateServer -> Challenge) -> m Challenge
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> Challenge) -> m Challenge)
-> (StateServer -> Challenge) -> m Challenge
forall a b. (a -> b) -> a -> b
$ ServerOptions -> Challenge
scurChalSer (ServerOptions -> Challenge)
-> (StateServer -> ServerOptions) -> StateServer -> Challenge
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ServerOptions
soptions
  let gameMode :: GroupName ModeKind
gameMode = GroupName ModeKind
-> Maybe (GroupName ModeKind) -> GroupName ModeKind
forall a. a -> Maybe a -> a
fromMaybe GroupName ModeKind
INSERT_COIN
                 (Maybe (GroupName ModeKind) -> GroupName ModeKind)
-> Maybe (GroupName ModeKind) -> GroupName ModeKind
forall a b. (a -> b) -> a -> b
$ Maybe (GroupName ModeKind)
mGameMode Maybe (GroupName ModeKind)
-> Maybe (GroupName ModeKind) -> Maybe (GroupName ModeKind)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` ServerOptions -> Maybe (GroupName ModeKind)
sgameMode ServerOptions
serverOptions
      rnd :: Rnd (FactionDict, FlavourMap, DiscoveryKind, DiscoveryKindRev,
                  DungeonGen.FreshDungeon, ContentId ModeKind)
      rnd :: Rnd
  (FactionDict, FlavourMap, DiscoveryKind, DiscoveryKindRev,
   FreshDungeon, ContentId ModeKind)
rnd = do
        ContentId ModeKind
modeKindId <-
          ContentId ModeKind
-> Maybe (ContentId ModeKind) -> ContentId ModeKind
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> ContentId ModeKind
forall a. HasCallStack => [Char] -> a
error ([Char] -> ContentId ModeKind) -> [Char] -> ContentId ModeKind
forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown game mode:" [Char] -> GroupName ModeKind -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` GroupName ModeKind
gameMode)
          (Maybe (ContentId ModeKind) -> ContentId ModeKind)
-> StateT SMGen Identity (Maybe (ContentId ModeKind))
-> StateT SMGen Identity (ContentId ModeKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContentData ModeKind
-> GroupName ModeKind
-> (ModeKind -> Bool)
-> StateT SMGen Identity (Maybe (ContentId ModeKind))
forall a.
Show a =>
ContentData a
-> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))
opick ContentData ModeKind
comode GroupName ModeKind
gameMode (Bool -> ModeKind -> Bool
forall a b. a -> b -> a
const Bool
True)
        let mode :: ModeKind
mode = ContentData ModeKind -> ContentId ModeKind -> ModeKind
forall a. ContentData a -> ContentId a -> a
okind ContentData ModeKind
comode ContentId ModeKind
modeKindId
            automatePS :: Roster -> Roster
automatePS Roster
ps = Roster
ps {rosterList :: [(Player, Maybe TeamContinuity, [(Int, Dice, GroupName ItemKind)])]
rosterList =
              ((Player, Maybe TeamContinuity, [(Int, Dice, GroupName ItemKind)])
 -> (Player, Maybe TeamContinuity,
     [(Int, Dice, GroupName ItemKind)]))
-> [(Player, Maybe TeamContinuity,
     [(Int, Dice, GroupName ItemKind)])]
-> [(Player, Maybe TeamContinuity,
     [(Int, Dice, GroupName ItemKind)])]
forall a b. (a -> b) -> [a] -> [b]
map (\(Player
pl, Maybe TeamContinuity
tc, [(Int, Dice, GroupName ItemKind)]
l) -> (Bool -> Player -> Player
automatePlayer Bool
True Player
pl, Maybe TeamContinuity
tc, [(Int, Dice, GroupName ItemKind)]
l))
                  (Roster
-> [(Player, Maybe TeamContinuity,
     [(Int, Dice, GroupName ItemKind)])]
rosterList Roster
ps)}
            players :: Roster
players = if ServerOptions -> Bool
sautomateAll ServerOptions
serverOptions
                      then Roster -> Roster
automatePS (Roster -> Roster) -> Roster -> Roster
forall a b. (a -> b) -> a -> b
$ ModeKind -> Roster
mroster ModeKind
mode
                      else ModeKind -> Roster
mroster ModeKind
mode
        FlavourMap
flavour <- COps -> FlavourMap -> Rnd FlavourMap
dungeonFlavourMap COps
cops FlavourMap
flavourOld
        (DiscoveryKind
discoKind, DiscoveryKindRev
sdiscoKindRev) <- COps -> DiscoveryKindRev -> Rnd (DiscoveryKind, DiscoveryKindRev)
serverDiscos COps
cops DiscoveryKindRev
discoKindRevOld
        FreshDungeon
freshDng <- COps -> ServerOptions -> Caves -> Rnd FreshDungeon
DungeonGen.dungeonGen COps
cops ServerOptions
serverOptions (Caves -> Rnd FreshDungeon) -> Caves -> Rnd FreshDungeon
forall a b. (a -> b) -> a -> b
$ ModeKind -> Caves
mcaves ModeKind
mode
        FactionDict
factionD <- FactionDict
-> ContentId ModeKind
-> Int
-> AbsDepth
-> Roster
-> Rnd FactionDict
resetFactions FactionDict
factionDold ContentId ModeKind
gameModeIdOld
                                  (Challenge -> Int
cdiff Challenge
curChalSer)
                                  (FreshDungeon -> AbsDepth
DungeonGen.freshTotalDepth FreshDungeon
freshDng)
                                  Roster
players
        (FactionDict, FlavourMap, DiscoveryKind, DiscoveryKindRev,
 FreshDungeon, ContentId ModeKind)
-> Rnd
     (FactionDict, FlavourMap, DiscoveryKind, DiscoveryKindRev,
      FreshDungeon, ContentId ModeKind)
forall (m :: * -> *) a. Monad m => a -> m a
return ( FactionDict
factionD, FlavourMap
flavour, DiscoveryKind
discoKind
               , DiscoveryKindRev
sdiscoKindRev, FreshDungeon
freshDng, ContentId ModeKind
modeKindId )
  let ( FactionDict
factionD, FlavourMap
sflavour, DiscoveryKind
discoKind
       ,DiscoveryKindRev
sdiscoKindRev, DungeonGen.FreshDungeon{Dungeon
AbsDepth
freshDungeon :: FreshDungeon -> Dungeon
freshTotalDepth :: AbsDepth
freshDungeon :: Dungeon
freshTotalDepth :: FreshDungeon -> AbsDepth
..}, ContentId ModeKind
modeKindId ) =
        Rnd
  (FactionDict, FlavourMap, DiscoveryKind, DiscoveryKindRev,
   FreshDungeon, ContentId ModeKind)
-> SMGen
-> (FactionDict, FlavourMap, DiscoveryKind, DiscoveryKindRev,
    FreshDungeon, ContentId ModeKind)
forall s a. State s a -> s -> a
St.evalState Rnd
  (FactionDict, FlavourMap, DiscoveryKind, DiscoveryKindRev,
   FreshDungeon, ContentId ModeKind)
rnd SMGen
dungeonSeed
      defState :: State
defState = Dungeon
-> AbsDepth
-> FactionDict
-> COps
-> ScoreDict
-> ContentId ModeKind
-> DiscoveryKind
-> State
defStateGlobal Dungeon
freshDungeon AbsDepth
freshTotalDepth
                                FactionDict
factionD COps
cops ScoreDict
scoreTable ContentId ModeKind
modeKindId DiscoveryKind
discoKind
      defSer :: StateServer
defSer = StateServer
emptyStateServer { SMGen
srandom :: SMGen
srandom :: SMGen
srandom
                                , RNGs
srngs :: RNGs
srngs :: RNGs
srngs }
  StateServer -> m ()
forall (m :: * -> *). MonadServer m => StateServer -> m ()
putServer StateServer
defSer
  (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 { steamGear :: GearOfTeams
steamGear = GearOfTeams
teamGearOld
                             , steamGearCur :: GearOfTeams
steamGearCur = GearOfTeams
teamGearOld
                             , sclientStates :: EnumMap FactionId State
sclientStates = EnumMap FactionId State
clientStatesOld  -- reset later
                             , DiscoveryKindRev
sdiscoKindRev :: DiscoveryKindRev
sdiscoKindRev :: DiscoveryKindRev
sdiscoKindRev
                             , FlavourMap
sflavour :: FlavourMap
sflavour :: FlavourMap
sflavour }
  State -> m State
forall (m :: * -> *) a. Monad m => a -> m a
return (State -> m State) -> State -> m State
forall a b. (a -> b) -> a -> b
$! State
defState

-- Spawn initial actors. Clients should notice this, to set their leaders.
populateDungeon :: forall m. MonadServerAtomic m => m ()
populateDungeon :: m ()
populateDungeon = 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
  FactionDict
factionD <- (State -> FactionDict) -> m FactionDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> FactionDict
sfactionD
  Challenge
curChalSer <- (StateServer -> Challenge) -> m Challenge
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> Challenge) -> m Challenge)
-> (StateServer -> Challenge) -> m Challenge
forall a b. (a -> b) -> a -> b
$ ServerOptions -> Challenge
scurChalSer (ServerOptions -> Challenge)
-> (StateServer -> ServerOptions) -> StateServer -> Challenge
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ServerOptions
soptions
  let nGt0 :: (a, a, c) -> Bool
nGt0 (a
_, a
n, c
_) = a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0
      ginitialWolf :: Faction -> [(Int, Int, GroupName ItemKind)]
ginitialWolf Faction
fact1 = if Challenge -> Bool
cwolf Challenge
curChalSer Bool -> Bool -> Bool
&& Player -> Bool
fhasUI (Faction -> Player
gplayer Faction
fact1)
                           then case ((Int, Int, GroupName ItemKind) -> Bool)
-> [(Int, Int, GroupName ItemKind)]
-> [(Int, Int, GroupName ItemKind)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int, Int, GroupName ItemKind) -> Bool
forall a a c. (Ord a, Num a) => (a, a, c) -> Bool
nGt0 ([(Int, Int, GroupName ItemKind)]
 -> [(Int, Int, GroupName ItemKind)])
-> [(Int, Int, GroupName ItemKind)]
-> [(Int, Int, GroupName ItemKind)]
forall a b. (a -> b) -> a -> b
$ Faction -> [(Int, Int, GroupName ItemKind)]
ginitial Faction
fact1 of
                             [] -> []
                             (Int
ln, Int
_, GroupName ItemKind
grp) : [(Int, Int, GroupName ItemKind)]
_ -> [(Int
ln, Int
1, GroupName ItemKind
grp)]
                           else Faction -> [(Int, Int, GroupName ItemKind)]
ginitial Faction
fact1
      -- Keep the same order of factions as in roster.
      needInitialCrew :: [(FactionId, Faction)]
needInitialCrew = ((FactionId, Faction) -> (FactionId, Faction) -> Ordering)
-> [(FactionId, Faction)] -> [(FactionId, Faction)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((FactionId, Faction) -> Int)
-> (FactionId, Faction) -> (FactionId, Faction) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (((FactionId, Faction) -> Int)
 -> (FactionId, Faction) -> (FactionId, Faction) -> Ordering)
-> ((FactionId, Faction) -> Int)
-> (FactionId, Faction)
-> (FactionId, Faction)
-> Ordering
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Num a => a -> a
abs (Int -> Int)
-> ((FactionId, Faction) -> Int) -> (FactionId, Faction) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FactionId -> Int
forall a. Enum a => a -> Int
fromEnum (FactionId -> Int)
-> ((FactionId, Faction) -> FactionId)
-> (FactionId, Faction)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FactionId, Faction) -> FactionId
forall a b. (a, b) -> a
fst)
                        ([(FactionId, Faction)] -> [(FactionId, Faction)])
-> [(FactionId, Faction)] -> [(FactionId, Faction)]
forall a b. (a -> b) -> a -> b
$ ((FactionId, Faction) -> Bool)
-> [(FactionId, Faction)] -> [(FactionId, Faction)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((FactionId, Faction) -> Bool) -> (FactionId, Faction) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, Int, GroupName ItemKind)] -> Bool
forall a. [a] -> Bool
null ([(Int, Int, GroupName ItemKind)] -> Bool)
-> ((FactionId, Faction) -> [(Int, Int, GroupName ItemKind)])
-> (FactionId, Faction)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Faction -> [(Int, Int, GroupName ItemKind)]
ginitialWolf (Faction -> [(Int, Int, GroupName ItemKind)])
-> ((FactionId, Faction) -> Faction)
-> (FactionId, Faction)
-> [(Int, Int, GroupName ItemKind)]
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
      getEntryLevels :: (FactionId, Faction) -> [LevelId]
getEntryLevels (FactionId
_, Faction
fact) =
        ((Int, Int, GroupName ItemKind) -> LevelId)
-> [(Int, Int, GroupName ItemKind)] -> [LevelId]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
ln, Int
_, GroupName ItemKind
_) -> Int -> LevelId
forall a. Enum a => Int -> a
toEnum Int
ln) ([(Int, Int, GroupName ItemKind)] -> [LevelId])
-> [(Int, Int, GroupName ItemKind)] -> [LevelId]
forall a b. (a -> b) -> a -> b
$ Faction -> [(Int, Int, GroupName ItemKind)]
ginitialWolf Faction
fact
      arenas :: [LevelId]
arenas = EnumSet LevelId -> [LevelId]
forall k. Enum k => EnumSet k -> [k]
ES.elems (EnumSet LevelId -> [LevelId]) -> EnumSet LevelId -> [LevelId]
forall a b. (a -> b) -> a -> b
$ [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
$ ((FactionId, Faction) -> [LevelId])
-> [(FactionId, Faction)] -> [LevelId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FactionId, Faction) -> [LevelId]
getEntryLevels [(FactionId, Faction)]
needInitialCrew
      hasActorsOnArena :: LevelId -> (FactionId, Faction) -> Bool
hasActorsOnArena LevelId
lid (FactionId
_, Faction
fact) =
        ((Int, Int, GroupName ItemKind) -> Bool)
-> [(Int, Int, GroupName ItemKind)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Int
ln, Int
_, GroupName ItemKind
_) -> Int -> LevelId
forall a. Enum a => Int -> a
toEnum Int
ln LevelId -> LevelId -> Bool
forall a. Eq a => a -> a -> Bool
== LevelId
lid) ([(Int, Int, GroupName ItemKind)] -> Bool)
-> [(Int, Int, GroupName ItemKind)] -> Bool
forall a b. (a -> b) -> a -> b
$ Faction -> [(Int, Int, GroupName ItemKind)]
ginitialWolf Faction
fact
      initialActorPositions :: LevelId
                            -> m (LevelId, EM.EnumMap FactionId Point)
      initialActorPositions :: LevelId -> m (LevelId, EnumMap FactionId Point)
initialActorPositions LevelId
lid = do
        Level
lvl <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel LevelId
lid
        let arenaFactions :: [FactionId]
arenaFactions =
              ((FactionId, Faction) -> FactionId)
-> [(FactionId, Faction)] -> [FactionId]
forall a b. (a -> b) -> [a] -> [b]
map (FactionId, Faction) -> FactionId
forall a b. (a, b) -> a
fst ([(FactionId, Faction)] -> [FactionId])
-> [(FactionId, Faction)] -> [FactionId]
forall a b. (a -> b) -> a -> b
$ ((FactionId, Faction) -> Bool)
-> [(FactionId, Faction)] -> [(FactionId, Faction)]
forall a. (a -> Bool) -> [a] -> [a]
filter (LevelId -> (FactionId, Faction) -> Bool
hasActorsOnArena LevelId
lid) [(FactionId, Faction)]
needInitialCrew
        [Point]
entryPoss <- Rnd [Point] -> m [Point]
forall (m :: * -> *) a. MonadServer m => Rnd a -> m a
rndToAction (Rnd [Point] -> m [Point]) -> Rnd [Point] -> m [Point]
forall a b. (a -> b) -> a -> b
$ COps -> Level -> Int -> Rnd [Point]
findEntryPoss COps
cops Level
lvl ([FactionId] -> Int
forall a. [a] -> Int
length [FactionId]
arenaFactions)
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Point] -> Int
forall a. [a] -> Int
length [Point]
entryPoss Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [FactionId] -> Int
forall a. [a] -> Int
length [FactionId]
arenaFactions) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). MonadServer m => Text -> m ()
debugPossiblyPrint
          Text
"Server: populateDungeon: failed to find enough distinct faction starting positions; some factions share positions"
        let usedPoss :: EnumMap FactionId Point
usedPoss = [(FactionId, Point)] -> EnumMap FactionId Point
forall k a. Enum k => [(k, a)] -> EnumMap k a
EM.fromList ([(FactionId, Point)] -> EnumMap FactionId Point)
-> [(FactionId, Point)] -> EnumMap FactionId Point
forall a b. (a -> b) -> a -> b
$ [FactionId] -> [Point] -> [(FactionId, Point)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FactionId]
arenaFactions ([Point] -> [(FactionId, Point)])
-> [Point] -> [(FactionId, Point)]
forall a b. (a -> b) -> a -> b
$ [Point] -> [Point]
forall a. [a] -> [a]
cycle [Point]
entryPoss
        (LevelId, EnumMap FactionId Point)
-> m (LevelId, EnumMap FactionId Point)
forall (m :: * -> *) a. Monad m => a -> m a
return (LevelId
lid, EnumMap FactionId Point
usedPoss)
  EnumMap LevelId (EnumMap FactionId Point)
factionPositions <- [(LevelId, EnumMap FactionId Point)]
-> EnumMap LevelId (EnumMap FactionId Point)
forall k a. Enum k => [(k, a)] -> EnumMap k a
EM.fromDistinctAscList
                      ([(LevelId, EnumMap FactionId Point)]
 -> EnumMap LevelId (EnumMap FactionId Point))
-> m [(LevelId, EnumMap FactionId Point)]
-> m (EnumMap LevelId (EnumMap FactionId Point))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LevelId -> m (LevelId, EnumMap FactionId Point))
-> [LevelId] -> m [(LevelId, EnumMap FactionId Point)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LevelId -> m (LevelId, EnumMap FactionId Point)
initialActorPositions [LevelId]
arenas
  let initialActors :: (FactionId, Faction) -> m ()
      initialActors :: (FactionId, Faction) -> m ()
initialActors (FactionId
fid3, Faction
fact3) =
        ((Int, Int, GroupName ItemKind) -> m ())
-> [(Int, Int, GroupName ItemKind)] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (FactionId -> (Int, Int, GroupName ItemKind) -> m ()
placeActors FactionId
fid3) ([(Int, Int, GroupName ItemKind)] -> m ())
-> [(Int, Int, GroupName ItemKind)] -> m ()
forall a b. (a -> b) -> a -> b
$ Faction -> [(Int, Int, GroupName ItemKind)]
ginitialWolf Faction
fact3
      placeActors :: FactionId -> (Int, Int, GroupName ItemKind) -> m ()
      placeActors :: FactionId -> (Int, Int, GroupName ItemKind) -> m ()
placeActors FactionId
fid3 (Int
ln, Int
n, GroupName ItemKind
actorGroup) = do
        let lid :: LevelId
lid = Int -> LevelId
forall a. Enum a => Int -> a
toEnum Int
ln
        Level
lvl <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel LevelId
lid
        let ppos :: Point
ppos = EnumMap LevelId (EnumMap FactionId Point)
factionPositions EnumMap LevelId (EnumMap FactionId Point)
-> LevelId -> EnumMap FactionId Point
forall k a. Enum k => EnumMap k a -> k -> a
EM.! LevelId
lid EnumMap FactionId Point -> FactionId -> Point
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid3
            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
            -- This takes into account already spawned actors of this
            -- and other factions. If not enough space, some are skipped.
            psFree :: [Point]
psFree = COps -> Level -> (ContentId TileKind -> Bool) -> Point -> [Point]
nearbyFreePoints COps
cops Level
lvl ContentId TileKind -> Bool
validTile Point
ppos
            ps :: [Point]
ps = Int -> [Point] -> [Point]
forall a. Int -> [a] -> [a]
take Int
n [Point]
psFree
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Point] -> Int
forall a. [a] -> Int
length [Point]
ps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *). MonadServer m => Text -> m ()
debugPossiblyPrint
          Text
"Server: populateDungeon: failed to find enough initial actor positions; some actors are not generated"
        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
        [Point] -> (Point -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t a -> (a -> m ()) -> m ()
forM_ [Point]
ps ((Point -> m ()) -> m ()) -> (Point -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Point
p -> do
          Int
rndDelay <- 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
clipsInTurn Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
          let delta :: Delta Time
delta = Delta Time -> Int -> Delta Time
timeDeltaScale (Time -> Delta Time
forall a. a -> Delta a
Delta Time
timeClip) Int
rndDelay
              rndTime :: Time
rndTime = Time -> Delta Time -> Time
timeShift Time
localTime Delta Time
delta
          Maybe ActorId
maid <- GroupName ItemKind
-> FactionId -> Point -> LevelId -> Time -> m (Maybe ActorId)
forall (m :: * -> *).
MonadServerAtomic m =>
GroupName ItemKind
-> FactionId -> Point -> LevelId -> Time -> m (Maybe ActorId)
addActorFromGroup GroupName ItemKind
actorGroup FactionId
fid3 Point
p LevelId
lid Time
rndTime
          case Maybe ActorId
maid of
            Maybe ActorId
Nothing -> [Char] -> m ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"can't spawn initial actors"
                               [Char] -> (LevelId, FactionId) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (LevelId
lid, FactionId
fid3)
            Just ActorId
aid -> do
              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
fid3) (FactionDict -> Faction)
-> (State -> FactionDict) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> FactionDict
sfactionD
              -- Sleeping actor may become a leader, but it's quickly corrected.
              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 FactionId
fid3 ActorId
aid
  EnumMap LevelId (EnumMap FactionId Point) -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
EnumMap LevelId (EnumMap FactionId Point) -> m ()
placeItemsInDungeon EnumMap LevelId (EnumMap FactionId Point)
factionPositions
  m ()
forall (m :: * -> *). MonadServerAtomic m => m ()
embedItemsInDungeon
  ((FactionId, Faction) -> m ()) -> [(FactionId, Faction)] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (FactionId, Faction) -> m ()
initialActors [(FactionId, Faction)]
needInitialCrew

-- | Find starting postions for all factions. Try to make them distant
-- from each other. Place as many of the factions, as possible,
-- over stairs. Place the first faction(s) over escape(s)
-- (we assume they are guardians of the escapes).
-- This implies the inital factions (if any) start far from escapes.
findEntryPoss :: COps -> Level -> Int -> Rnd [Point]
findEntryPoss :: COps -> Level -> Int -> Rnd [Point]
findEntryPoss COps{ContentData CaveKind
cocave :: ContentData CaveKind
cocave :: COps -> ContentData CaveKind
cocave, TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup}
              lvl :: Level
lvl@Level{ContentId CaveKind
lkind :: ContentId CaveKind
lkind :: Level -> ContentId CaveKind
lkind, Area
larea :: Level -> Area
larea :: Area
larea, ([Point], [Point])
lstair :: Level -> ([Point], [Point])
lstair :: ([Point], [Point])
lstair, [Point]
lescape :: Level -> [Point]
lescape :: [Point]
lescape}
              Int
kRaw = do
  let lskip :: [Int]
lskip = CaveKind -> [Int]
CK.cskip (CaveKind -> [Int]) -> CaveKind -> [Int]
forall a b. (a -> b) -> a -> b
$ ContentData CaveKind -> ContentId CaveKind -> CaveKind
forall a. ContentData a -> ContentId a -> a
okind ContentData CaveKind
cocave ContentId CaveKind
lkind
      k :: Int
k = Int
kRaw Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. [a] -> Int
length [Int]
lskip  -- if @lskip@ is bogus, will be too large; OK
      (Point
_, Int
xspan, Int
yspan) = Area -> (Point, Int, Int)
spanArea Area
larea
      factionDist :: Int
factionDist = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
xspan Int
yspan Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
10
      dist :: t Point -> Int -> Point -> p -> Bool
dist !t Point
poss !Int
cmin !Point
l p
_ = (Point -> Bool) -> t Point -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ !Point
pos -> Point -> Point -> Int
chessDist Point
l Point
pos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
cmin) t Point
poss
      tryFind :: [Point] -> Int -> Rnd [Point]
tryFind [Point]
_ Int
0 = [Point] -> Rnd [Point]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      tryFind ![Point]
ps !Int
n = do
        let ds :: [Point -> ContentId TileKind -> Bool]
ds = [ [Point] -> Int -> Point -> ContentId TileKind -> Bool
forall (t :: * -> *) p.
Foldable t =>
t Point -> Int -> Point -> p -> Bool
dist [Point]
ps Int
factionDist
                 , [Point] -> Int -> Point -> ContentId TileKind -> Bool
forall (t :: * -> *) p.
Foldable t =>
t Point -> Int -> Point -> p -> Bool
dist [Point]
ps (Int -> Point -> ContentId TileKind -> Bool)
-> Int -> Point -> ContentId TileKind -> Bool
forall a b. (a -> b) -> a -> b
$ Int
factionDist Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
                 , [Point] -> Int -> Point -> ContentId TileKind -> Bool
forall (t :: * -> *) p.
Foldable t =>
t Point -> Int -> Point -> p -> Bool
dist [Point]
ps (Int -> Point -> ContentId TileKind -> Bool)
-> Int -> Point -> ContentId TileKind -> Bool
forall a b. (a -> b) -> a -> b
$ Int
factionDist Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3
                 , [Point] -> Int -> Point -> ContentId TileKind -> Bool
forall (t :: * -> *) p.
Foldable t =>
t Point -> Int -> Point -> p -> Bool
dist [Point]
ps (Int -> Point -> ContentId TileKind -> Bool)
-> Int -> Point -> ContentId TileKind -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
5 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
factionDist Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5
                 , [Point] -> Int -> Point -> ContentId TileKind -> Bool
forall (t :: * -> *) p.
Foldable t =>
t Point -> Int -> Point -> p -> Bool
dist [Point]
ps (Int -> Point -> ContentId TileKind -> Bool)
-> Int -> Point -> ContentId TileKind -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
2 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
factionDist Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
10
                 ]
        Maybe Point
mp <- Int
-> Level
-> (Point -> ContentId TileKind -> Bool)
-> [Point -> ContentId TileKind -> Bool]
-> (Point -> ContentId TileKind -> Bool)
-> [Point -> ContentId TileKind -> Bool]
-> Rnd (Maybe Point)
findPosTry2 Int
500 Level
lvl  -- try really hard, for skirmish fairness
                (\Point
_ !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))
                (Int
-> [Point -> ContentId TileKind -> Bool]
-> [Point -> ContentId TileKind -> Bool]
forall a. Int -> [a] -> [a]
take Int
2 [Point -> ContentId TileKind -> Bool]
ds)  -- don't pick too close @isOftenActor@ locations
                (\Point
_ !ContentId TileKind
t -> TileSpeedup -> ContentId TileKind -> Bool
Tile.isOftenActor TileSpeedup
coTileSpeedup ContentId TileKind
t)
                [Point -> ContentId TileKind -> Bool]
ds
        case Maybe Point
mp of
          Just Point
np -> do
            [Point]
nps <- [Point] -> Int -> Rnd [Point]
tryFind (Point
np Point -> [Point] -> [Point]
forall a. a -> [a] -> [a]
: [Point]
ps) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
            [Point] -> Rnd [Point]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Point] -> Rnd [Point]) -> [Point] -> Rnd [Point]
forall a b. (a -> b) -> a -> b
$! Point
np Point -> [Point] -> [Point]
forall a. a -> [a] -> [a]
: [Point]
nps
          Maybe Point
Nothing -> [Point] -> Rnd [Point]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      sameStaircase :: [Point] -> Point -> Bool
      sameStaircase :: [Point] -> Point -> Bool
sameStaircase [Point]
upStairs Point{Int
py :: Point -> Int
px :: Point -> Int
py :: Int
px :: Int
..} =
        (Point -> Bool) -> [Point] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Point Int
ux Int
uy) -> Int
uy Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
py Bool -> Bool -> Bool
&& Int
ux Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
px) [Point]
upStairs
      upAndSomeDownStairs :: [Point]
upAndSomeDownStairs =
        ([Point], [Point]) -> [Point]
forall a b. (a, b) -> a
fst ([Point], [Point])
lstair
        [Point] -> [Point] -> [Point]
forall a. [a] -> [a] -> [a]
++ (Point -> Bool) -> [Point] -> [Point]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Point -> Bool) -> Point -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point] -> Point -> Bool
sameStaircase (([Point], [Point]) -> [Point]
forall a b. (a, b) -> a
fst ([Point], [Point])
lstair)) (([Point], [Point]) -> [Point]
forall a b. (a, b) -> b
snd ([Point], [Point])
lstair)
      skipIndexes :: t a -> [b] -> [b]
skipIndexes t a
ixs [b]
l = ((a, b) -> b) -> [(a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> b
forall a b. (a, b) -> b
snd ([(a, b)] -> [b]) -> [(a, b)] -> [b]
forall a b. (a -> b) -> a -> b
$ ((a, b) -> Bool) -> [(a, b)] -> [(a, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(a
ix, b
_) -> a
ix a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` t a
ixs)
                                  ([(a, b)] -> [(a, b)]) -> [(a, b)] -> [(a, b)]
forall a b. (a -> b) -> a -> b
$ [a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a
0..] [b]
l
  let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
factionDist Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) ()
      onEscapes :: [Point]
onEscapes = Int -> [Point] -> [Point]
forall a. Int -> [a] -> [a]
take Int
k [Point]
lescape
      onStairs :: [Point]
onStairs = Int -> [Point] -> [Point]
forall a. Int -> [a] -> [a]
take (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Point] -> Int
forall a. [a] -> Int
length [Point]
onEscapes) [Point]
upAndSomeDownStairs
      nk :: Int
nk = Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Point] -> Int
forall a. [a] -> Int
length [Point]
onEscapes Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Point] -> Int
forall a. [a] -> Int
length [Point]
onStairs
  -- Starting in the middle is too easy.
  [Point]
found <- [Point] -> Int -> Rnd [Point]
tryFind (Area -> Point
middlePoint Area
larea Point -> [Point] -> [Point]
forall a. a -> [a] -> [a]
: [Point]
onEscapes [Point] -> [Point] -> [Point]
forall a. [a] -> [a] -> [a]
++ [Point]
onStairs) Int
nk
  [Point] -> Rnd [Point]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Point] -> Rnd [Point]) -> [Point] -> Rnd [Point]
forall a b. (a -> b) -> a -> b
$! [Int] -> [Point] -> [Point]
forall (t :: * -> *) a b.
(Foldable t, Eq a, Num a, Enum a) =>
t a -> [b] -> [b]
skipIndexes [Int]
lskip ([Point] -> [Point]) -> [Point] -> [Point]
forall a b. (a -> b) -> a -> b
$ [Point]
onEscapes [Point] -> [Point] -> [Point]
forall a. [a] -> [a] -> [a]
++ [Point]
onStairs [Point] -> [Point] -> [Point]
forall a. [a] -> [a] -> [a]
++ [Point]
found

-- | Apply options that don't need a new game.
applyDebug :: MonadServer m => m ()
applyDebug :: m ()
applyDebug = do
  ServerOptions{Bool
[Char]
Maybe Int
Maybe SMGen
Maybe (GroupName ModeKind)
ClientOptions
Challenge
sstopAfterGameOver :: ServerOptions -> Bool
sassertExplored :: ServerOptions -> Maybe Int
sdbgMsgSer :: ServerOptions -> Bool
ssavePrefixSer :: ServerOptions -> [Char]
snewGameSer :: ServerOptions -> Bool
skeepAutomated :: ServerOptions -> Bool
sboostRandomItem :: ServerOptions -> Bool
sallClear :: ServerOptions -> Bool
sniff :: ServerOptions -> Bool
sknowItems :: ServerOptions -> Bool
sknowEvents :: ServerOptions -> Bool
sclientOptions :: ClientOptions
sstopAfterGameOver :: Bool
sshowItemSamples :: Bool
sassertExplored :: Maybe Int
sdbgMsgSer :: Bool
ssavePrefixSer :: [Char]
sdumpInitRngs :: Bool
scurChalSer :: Challenge
snewGameSer :: Bool
smainRng :: Maybe SMGen
sdungeonRng :: Maybe SMGen
skeepAutomated :: Bool
sautomateAll :: Bool
sgameMode :: Maybe (GroupName ModeKind)
sboostRandomItem :: Bool
sallClear :: Bool
sniff :: Bool
sknowItems :: Bool
sknowEvents :: Bool
sknowMap :: Bool
sautomateAll :: ServerOptions -> Bool
sgameMode :: ServerOptions -> Maybe (GroupName ModeKind)
sdumpInitRngs :: ServerOptions -> Bool
smainRng :: ServerOptions -> Maybe SMGen
sdungeonRng :: ServerOptions -> Maybe SMGen
sclientOptions :: ServerOptions -> ClientOptions
sshowItemSamples :: ServerOptions -> Bool
sknowMap :: ServerOptions -> Bool
scurChalSer :: ServerOptions -> Challenge
..} <- (StateServer -> ServerOptions) -> m ServerOptions
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> ServerOptions
soptionsNxt
  (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 {soptions :: ServerOptions
soptions = (StateServer -> ServerOptions
soptions StateServer
ser) { Bool
sniff :: Bool
sniff :: Bool
sniff
                                   , Bool
sallClear :: Bool
sallClear :: Bool
sallClear
                                   , Bool
sdbgMsgSer :: Bool
sdbgMsgSer :: Bool
sdbgMsgSer
                                   , Bool
snewGameSer :: Bool
snewGameSer :: Bool
snewGameSer
                                   , Maybe Int
sassertExplored :: Maybe Int
sassertExplored :: Maybe Int
sassertExplored
                                   , Bool
sdumpInitRngs :: Bool
sdumpInitRngs :: Bool
sdumpInitRngs
                                   , ClientOptions
sclientOptions :: ClientOptions
sclientOptions :: ClientOptions
sclientOptions }}