-- | 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           Data.Key (mapWithKeyM_)
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
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.FactionKind
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.Frequency
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 :: forall (m :: * -> *). MonadServer m => m ()
initPer = do
  ( sfovLitLid, sfovClearLid, sfovLucidLid
   ,sperValidFid, sperCacheFid, sperFid ) <- (State
 -> (FovLitLid, FovClearLid, FovLucidLid, PerValidFid, PerCacheFid,
     PerFid))
-> m (FovLitLid, FovClearLid, FovLucidLid, PerValidFid,
      PerCacheFid, PerFid)
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State
-> (FovLitLid, FovClearLid, FovLucidLid, PerValidFid, PerCacheFid,
    PerFid)
perFidInDungeon
  modifyServer $ \StateServer
ser ->
    StateServer
ser { sfovLitLid, sfovClearLid, sfovLucidLid
        , sperValidFid, sperCacheFid, sperFid }

reinitGame :: MonadServerAtomic m => FactionDict -> m ()
reinitGame :: forall (m :: * -> *). MonadServerAtomic m => FactionDict -> m ()
reinitGame FactionDict
factionDold = do
  COps{coitem} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  pers <- getsServer sperFid
  ServerOptions{scurChalSer, sknowMap, sshowItemSamples, sclientOptions}
    <- getsServer 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.
  s <- getState
  discoS <- getsState 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 =
        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 | Bool
sknowMap = State
s
           | Bool
otherwise = State -> State
localFromGlobal State
s
      defLocal = (DiscoveryKind -> DiscoveryKind) -> State -> State
updateDiscoKind (DiscoveryKind -> DiscoveryKind -> DiscoveryKind
forall a b. a -> b -> a
const DiscoveryKind
discoKindFiltered) State
defL
  factionD <- getsState sfactionD
  clientStatesOld <- getsServer sclientStates
  metaBackupOld <- getsServer smetaBackup
  -- Some item kinds preserve their identity and flavour throughout
  -- the whole meta-game, until the savefiles are removed.
  -- These are usually not common man-made items, because these can be made
  -- in many flavours so it may be hard to recognize them.
  -- Character backstories and rare artifacts are uncommon enough
  -- to requiring learning their identify only once.
  -- 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).
  let inMetaGame ContentId ItemKind
kindId = Flag -> Aspect
IK.SetFlag Flag
Ability.MetaGame
                          Aspect -> [Aspect] -> Bool
forall a. Eq a => a -> [a] -> 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)
      metaDiscoOldFid =
        (State -> DiscoveryKind)
-> EnumMap FactionId State -> EnumMap FactionId DiscoveryKind
forall a b k. (a -> b) -> EnumMap k a -> EnumMap k b
EM.map ((ContentId ItemKind -> Bool) -> DiscoveryKind -> DiscoveryKind
forall a k. (a -> Bool) -> EnumMap k a -> EnumMap k a
EM.filter ContentId ItemKind -> Bool
inMetaGame (DiscoveryKind -> DiscoveryKind)
-> (State -> DiscoveryKind) -> State -> DiscoveryKind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> DiscoveryKind
sdiscoKind) EnumMap FactionId State
clientStatesOld
      fidToTeam :: FactionId -> TeamContinuity
      fidToTeam FactionId
fid = FactionKind -> TeamContinuity
fteam (FactionKind -> TeamContinuity) -> FactionKind -> TeamContinuity
forall a b. (a -> b) -> a -> b
$ Faction -> FactionKind
gkind (Faction -> FactionKind) -> Faction -> FactionKind
forall a b. (a -> b) -> a -> b
$ FactionDict
factionDold FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid
      metaDiscoOldTeam =
        [(TeamContinuity, DiscoveryKind)]
-> EnumMap TeamContinuity DiscoveryKind
forall k a. Enum k => [(k, a)] -> EnumMap k a
EM.fromList ([(TeamContinuity, DiscoveryKind)]
 -> EnumMap TeamContinuity DiscoveryKind)
-> [(TeamContinuity, DiscoveryKind)]
-> EnumMap TeamContinuity DiscoveryKind
forall a b. (a -> b) -> a -> b
$ ((FactionId, DiscoveryKind) -> (TeamContinuity, DiscoveryKind))
-> [(FactionId, DiscoveryKind)]
-> [(TeamContinuity, DiscoveryKind)]
forall a b. (a -> b) -> [a] -> [b]
map ((FactionId -> TeamContinuity)
-> (FactionId, DiscoveryKind) -> (TeamContinuity, DiscoveryKind)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first FactionId -> TeamContinuity
fidToTeam) ([(FactionId, DiscoveryKind)] -> [(TeamContinuity, DiscoveryKind)])
-> [(FactionId, DiscoveryKind)]
-> [(TeamContinuity, DiscoveryKind)]
forall a b. (a -> b) -> a -> b
$ EnumMap FactionId DiscoveryKind -> [(FactionId, DiscoveryKind)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs EnumMap FactionId DiscoveryKind
metaDiscoOldFid
      exclusiveUnion = (a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
forall a k.
(a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
EM.unionWith ((a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a)
-> (a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
forall a b. (a -> b) -> a -> b
$ \a
_ a
_ -> [Char] -> a
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"forbidden duplicate"
      metaDiscoAll = EnumMap TeamContinuity DiscoveryKind
metaDiscoOldTeam EnumMap TeamContinuity DiscoveryKind
-> EnumMap TeamContinuity DiscoveryKind
-> EnumMap TeamContinuity DiscoveryKind
forall {k} {a}. EnumMap k a -> EnumMap k a -> EnumMap k a
`exclusiveUnion` EnumMap TeamContinuity DiscoveryKind
metaBackupOld
      currentTeams = [TeamContinuity] -> EnumSet TeamContinuity
forall k. Enum k => [k] -> EnumSet k
ES.fromList ([TeamContinuity] -> EnumSet TeamContinuity)
-> [TeamContinuity] -> EnumSet TeamContinuity
forall a b. (a -> b) -> a -> b
$ (Faction -> TeamContinuity) -> [Faction] -> [TeamContinuity]
forall a b. (a -> b) -> [a] -> [b]
map (FactionKind -> TeamContinuity
fteam (FactionKind -> TeamContinuity)
-> (Faction -> FactionKind) -> Faction -> TeamContinuity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Faction -> FactionKind
gkind) ([Faction] -> [TeamContinuity]) -> [Faction] -> [TeamContinuity]
forall a b. (a -> b) -> a -> b
$ FactionDict -> [Faction]
forall k a. EnumMap k a -> [a]
EM.elems FactionDict
factionD
      metaBackupNew = EnumMap TeamContinuity DiscoveryKind
-> EnumSet TeamContinuity -> EnumMap TeamContinuity DiscoveryKind
forall k a. Enum k => EnumMap k a -> EnumSet k -> EnumMap k a
EM.withoutKeys EnumMap TeamContinuity DiscoveryKind
metaDiscoAll EnumSet TeamContinuity
currentTeams
      stateNew Faction
fact = case TeamContinuity
-> EnumMap TeamContinuity DiscoveryKind -> Maybe DiscoveryKind
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup (FactionKind -> TeamContinuity
fteam (FactionKind -> TeamContinuity) -> FactionKind -> TeamContinuity
forall a b. (a -> b) -> a -> b
$ Faction -> FactionKind
gkind Faction
fact) EnumMap TeamContinuity DiscoveryKind
metaDiscoAll of
        Maybe DiscoveryKind
Nothing -> State
defLocal
        Just DiscoveryKind
disco -> (DiscoveryKind -> DiscoveryKind) -> State -> State
updateDiscoKind (DiscoveryKind
disco DiscoveryKind -> DiscoveryKind -> DiscoveryKind
forall {k} {a}. EnumMap k a -> EnumMap k a -> EnumMap k a
`EM.union`) State
defLocal
      clientStatesNew = (Faction -> State) -> FactionDict -> EnumMap FactionId State
forall a b k. (a -> b) -> EnumMap k a -> EnumMap k b
EM.map Faction -> State
stateNew FactionDict
factionD
  modifyServer $ \StateServer
ser -> StateServer
ser { sclientStates = clientStatesNew
                             , smetaBackup = metaBackupNew }
  let 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
  mapWithKeyM_ (\Key (EnumMap FactionId)
fid Faction
_ -> do
    -- Different seed for each client, to make sure behaviour is varied.
    gen1 <- (StateServer -> SMGen) -> m SMGen
forall a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> SMGen
srandom
    let (clientRandomSeed, gen2) = SM.splitSMGen gen1
    modifyServer $ \StateServer
ser -> StateServer
ser {srandom = gen2}
    execUpdAtomic $ updRestart fid clientRandomSeed) factionD
  dungeon <- getsState sdungeon
  let 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 = (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
  modifyServer $ \StateServer
ser -> StateServer
ser {sactorTime, strajTime}
  when sshowItemSamples $ do
    genOrig <- getsServer srandom
    uniqueSetOrig <- getsServer suniqueSet
    genOld <- getsServer sgenerationAn
    genSampleTrunks <- sampleTrunks dungeon
    genSampleItems <- sampleItems dungeon
    let sgenerationAn = [GenerationAnalytics] -> GenerationAnalytics
forall k a. [EnumMap k a] -> EnumMap k a
EM.unions [GenerationAnalytics
genSampleTrunks, GenerationAnalytics
genSampleItems, GenerationAnalytics
genOld]
    modifyServer $ \StateServer
ser -> StateServer
ser {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.
    modifyServer $ \StateServer
ser -> StateServer
ser {srandom = genOrig, suniqueSet = uniqueSetOrig}
  populateDungeon
  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))
        (EM.keys 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 :: forall (m :: * -> *).
MonadServerAtomic m =>
Dungeon -> m GenerationAnalytics
sampleTrunks Dungeon
dungeon = do
  COps{cocave, coitem} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  factionD <- getsState sfactionD
  let getGroups Level{ContentId CaveKind
lkind :: ContentId CaveKind
lkind :: Level -> ContentId CaveKind
lkind} = ((GroupName ItemKind, Y) -> GroupName ItemKind)
-> [(GroupName ItemKind, Y)] -> [GroupName ItemKind]
forall a b. (a -> b) -> [a] -> [b]
map (GroupName ItemKind, Y) -> GroupName ItemKind
forall a b. (a, b) -> a
fst ([(GroupName ItemKind, Y)] -> [GroupName ItemKind])
-> [(GroupName ItemKind, Y)] -> [GroupName ItemKind]
forall a b. (a -> b) -> a -> b
$ CaveKind -> [(GroupName ItemKind, Y)]
CK.cactorFreq (CaveKind -> [(GroupName ItemKind, Y)])
-> CaveKind -> [(GroupName ItemKind, Y)]
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 = 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
s0 !GroupName ItemKind
grp =
        ContentData ItemKind
-> GroupName ItemKind
-> (UniqueSet -> Y -> ContentId ItemKind -> ItemKind -> UniqueSet)
-> UniqueSet
-> UniqueSet
forall a b.
ContentData a
-> GroupName a -> (b -> Y -> ContentId a -> a -> b) -> b -> b
ofoldlGroup' ContentData ItemKind
coitem GroupName ItemKind
grp (\UniqueSet
s Y
_ 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 = 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 b a. (b -> a -> b) -> b -> [a] -> b
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, 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{ldepth} <- getLevel minLid
  let 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 (GroupName ItemKind, ContentId ItemKind, ItemKind)
freq = (GroupName ItemKind, ContentId ItemKind, ItemKind)
-> Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
forall a. a -> Frequency a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupName ItemKind
IK.HORROR, ContentId ItemKind
itemKindId, ItemKind
itemKind)
        case Frequency (FactionId, Faction) -> [(Y, (FactionId, Faction))]
forall a. Frequency a -> [(Y, a)]
runFrequency (Frequency (FactionId, Faction) -> [(Y, (FactionId, Faction))])
-> Frequency (FactionId, Faction) -> [(Y, (FactionId, Faction))]
forall a b. (a -> b) -> a -> b
$ [GroupName ItemKind]
-> ItemKind -> FactionDict -> Frequency (FactionId, Faction)
possibleActorFactions [] ItemKind
itemKind FactionDict
factionD of
          [] -> [Char] -> m (Maybe ItemId)
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"sampleTrunks: null faction frequency"
          (Y
_, (FactionId
fid, Faction
_)) : [(Y, (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
            m2 <- Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
-> AbsDepth -> m NewItem
forall (m :: * -> *).
MonadServerAtomic m =>
Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
-> AbsDepth -> m NewItem
rollItemAspect Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
freq AbsDepth
ldepth
            case m2 of
              NewItem
NoNewItem -> [Char] -> m (Maybe ItemId)
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"sampleTrunks: can't create actor trunk"
              NewItem GroupName ItemKind
_ (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 = (itemBase itemFullRaw) {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
  miids <- mapM regItem trunkKindIds
  return $! EM.singleton STrunk
            $ EM.fromDistinctAscList $ zip (catMaybes miids) $ repeat 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 :: forall (m :: * -> *).
MonadServerAtomic m =>
Dungeon -> m GenerationAnalytics
sampleItems Dungeon
dungeon = do
  COps{cocave, coitem} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  let getGroups Level{ContentId CaveKind
lkind :: Level -> ContentId CaveKind
lkind :: ContentId CaveKind
lkind} = ((GroupName ItemKind, Y) -> GroupName ItemKind)
-> [(GroupName ItemKind, Y)] -> [GroupName ItemKind]
forall a b. (a -> b) -> [a] -> [b]
map (GroupName ItemKind, Y) -> GroupName ItemKind
forall a b. (a, b) -> a
fst ([(GroupName ItemKind, Y)] -> [GroupName ItemKind])
-> [(GroupName ItemKind, Y)] -> [GroupName ItemKind]
forall a b. (a -> b) -> a -> b
$ CaveKind -> [(GroupName ItemKind, Y)]
CK.citemFreq (CaveKind -> [(GroupName ItemKind, Y)])
-> CaveKind -> [(GroupName ItemKind, Y)]
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 = 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
s0 !GroupName ItemKind
grp =
        ContentData ItemKind
-> GroupName ItemKind
-> (UniqueSet -> Y -> ContentId ItemKind -> ItemKind -> UniqueSet)
-> UniqueSet
-> UniqueSet
forall a b.
ContentData a
-> GroupName a -> (b -> Y -> ContentId a -> a -> b) -> b -> b
ofoldlGroup' ContentData ItemKind
coitem GroupName ItemKind
grp (\UniqueSet
s Y
_ 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 = 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 b a. (b -> a -> b) -> b -> [a] -> b
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, 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{ldepth} <- getLevel minLid
  let 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 (GroupName ItemKind, ContentId ItemKind, ItemKind)
freq = (GroupName ItemKind, ContentId ItemKind, ItemKind)
-> Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
forall a. a -> Frequency a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GroupName ItemKind
IK.HORROR, ContentId ItemKind
itemKindId, ItemKind
itemKind)
            c :: Container
c = LevelId -> Point -> Container
CFloor LevelId
minLid Point
originPoint
        m2 <- Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
-> AbsDepth -> m NewItem
forall (m :: * -> *).
MonadServerAtomic m =>
Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
-> AbsDepth -> m NewItem
rollItemAspect Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
freq AbsDepth
ldepth
        case m2 of
          NewItem
NoNewItem -> [Char] -> m (Maybe ItemId)
forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"sampleItems: can't create sample item"
          NewItem GroupName ItemKind
_ 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, (Y
0, [])) ItemKnown
itemKnown Container
c
  miids <- mapM regItem itemKindIds
  return $! EM.singleton SItem
            $ EM.fromDistinctAscList $ zip (catMaybes miids) $ repeat 0

mapFromFuns :: Ord b => [a] -> [a -> b] -> M.Map b a
mapFromFuns :: forall b a. Ord b => [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 a b. (a -> b -> b) -> b -> [a] -> b
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 :: ContentData FactionKind -> Dice.AbsDepth -> ModeKind -> Bool
              -> Rnd FactionDict
resetFactions :: ContentData FactionKind
-> AbsDepth -> ModeKind -> Bool -> Rnd FactionDict
resetFactions ContentData FactionKind
cofact AbsDepth
totalDepth ModeKind
mode
              Bool
automateAll = do
  let rawCreate :: (FactionId,
 (GroupName FactionKind, [(Y, Dice, GroupName ItemKind)]))
-> StateT SMGen Identity (FactionId, Faction)
rawCreate (FactionId
fid, (GroupName FactionKind
fkGroup, [(Y, Dice, GroupName ItemKind)]
initialActors)) = do
        -- Validation of content guarantess the existence of such faction kind.
        gkindId <- Maybe (ContentId FactionKind) -> ContentId FactionKind
forall a. (?callStack::CallStack) => Maybe a -> a
fromJust (Maybe (ContentId FactionKind) -> ContentId FactionKind)
-> StateT SMGen Identity (Maybe (ContentId FactionKind))
-> StateT SMGen Identity (ContentId FactionKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContentData FactionKind
-> GroupName FactionKind
-> (FactionKind -> Bool)
-> StateT SMGen Identity (Maybe (ContentId FactionKind))
forall a.
Show a =>
ContentData a
-> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))
opick ContentData FactionKind
cofact GroupName FactionKind
fkGroup (Bool -> FactionKind -> Bool
forall a b. a -> b -> a
const Bool
True)
        let gkind@FactionKind{..} = okind cofact gkindId
            castInitialActors (Y
ln, Dice
d, GroupName ItemKind
actorGroup) = do
              n <- AbsDepth -> AbsDepth -> Dice -> Rnd Y
castDice (Y -> AbsDepth
Dice.AbsDepth (Y -> AbsDepth) -> Y -> AbsDepth
forall a b. (a -> b) -> a -> b
$ Y -> Y
forall a. Num a => a -> a
abs Y
ln) AbsDepth
totalDepth Dice
d
              return (ln, n, actorGroup)
        ginitial <- mapM castInitialActors initialActors
        let 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 -> Text
T.toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. (?callStack::CallStack) => [a] -> a
head ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words Text
fname
            prefix = case (Bool
fhasPointman, Bool
finitUnderAI) of
              (Bool
False, Bool
False) -> Text
"Uncoordinated"
              (Bool
False, Bool
True) -> Text
"Loose"
              (Bool
True, Bool
False) -> Text
"Autonomous"
              (Bool
True, Bool
True) -> Text
"Controlled"
            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 -> 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
        let gname = Text
gnameNew
            gdoctrine = Doctrine
finitDoctrine
            gunderAI = Bool
finitUnderAI Bool -> Bool -> Bool
|| ModeKind -> Bool
mattract ModeKind
mode Bool -> Bool -> Bool
|| Bool
automateAll
            gdipl = EnumMap k a
forall k a. EnumMap k a
EM.empty  -- fixed below
            gquit = Maybe a
forall a. Maybe a
Nothing
            _gleader = Maybe a
forall a. Maybe a
Nothing
            gvictims = EnumMap k a
forall k a. EnumMap k a
EM.empty
            gstash = Maybe a
forall a. Maybe a
Nothing
        return (fid, Faction{..})
  lFs <- ((FactionId,
  (GroupName FactionKind, [(Y, Dice, GroupName ItemKind)]))
 -> StateT SMGen Identity (FactionId, Faction))
-> [(FactionId,
     (GroupName FactionKind, [(Y, 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (FactionId,
 (GroupName FactionKind, [(Y, Dice, GroupName ItemKind)]))
-> StateT SMGen Identity (FactionId, Faction)
rawCreate ([(FactionId,
   (GroupName FactionKind, [(Y, Dice, GroupName ItemKind)]))]
 -> StateT SMGen Identity [(FactionId, Faction)])
-> [(FactionId,
     (GroupName FactionKind, [(Y, Dice, GroupName ItemKind)]))]
-> StateT SMGen Identity [(FactionId, Faction)]
forall a b. (a -> b) -> a -> b
$ [FactionId]
-> [(GroupName FactionKind, [(Y, Dice, GroupName ItemKind)])]
-> [(FactionId,
     (GroupName FactionKind, [(Y, Dice, GroupName ItemKind)]))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Y -> FactionId
forall a. Enum a => Y -> a
toEnum Y
1 ..] ([(GroupName FactionKind, [(Y, Dice, GroupName ItemKind)])]
 -> [(FactionId,
      (GroupName FactionKind, [(Y, Dice, GroupName ItemKind)]))])
-> [(GroupName FactionKind, [(Y, Dice, GroupName ItemKind)])]
-> [(FactionId,
     (GroupName FactionKind, [(Y, Dice, GroupName ItemKind)]))]
forall a b. (a -> b) -> a -> b
$ ModeKind
-> [(GroupName FactionKind, [(Y, Dice, GroupName ItemKind)])]
mroster ModeKind
mode
  let mkDipl Diplomacy
diplMode =
        let f :: (k, FactionId) -> EnumMap k Faction -> EnumMap k Faction
f (k
ix1, FactionId
ix2) =
              let adj1 :: Faction -> Faction
adj1 Faction
fact = Faction
fact {gdipl = EM.insert ix2 diplMode (gdipl 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
adj1 k
ix1
        in ((k, FactionId) -> EnumMap k Faction -> EnumMap k Faction)
-> EnumMap k Faction -> t (k, FactionId) -> EnumMap k Faction
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (k, FactionId) -> EnumMap k Faction -> EnumMap k Faction
f
      -- Only symmetry is ensured, everything else is permitted,
      -- e.g., a faction in alliance with two others that are at war.
      pairsFromFaction :: (FactionKind -> [TeamContinuity])
                       -> (FactionId, Faction)
                       -> [(FactionId, FactionId)]
      pairsFromFaction FactionKind -> [TeamContinuity]
selector (FactionId
fid, Faction
fact) =
        let teams :: [TeamContinuity]
teams = FactionKind -> [TeamContinuity]
selector (FactionKind -> [TeamContinuity])
-> FactionKind -> [TeamContinuity]
forall a b. (a -> b) -> a -> b
$ Faction -> FactionKind
gkind Faction
fact
            hasTeam :: TeamContinuity -> (a, Faction) -> Bool
hasTeam TeamContinuity
team (a
_, Faction
fact2) = TeamContinuity
team TeamContinuity -> TeamContinuity -> Bool
forall a. Eq a => a -> a -> Bool
== FactionKind -> TeamContinuity
fteam (Faction -> FactionKind
gkind Faction
fact2)
            pairsFromTeam :: TeamContinuity -> [(FactionId, FactionId)]
pairsFromTeam TeamContinuity
team = case ((FactionId, Faction) -> Bool)
-> [(FactionId, Faction)] -> Maybe (FactionId, Faction)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TeamContinuity -> (FactionId, Faction) -> Bool
forall {a}. TeamContinuity -> (a, Faction) -> Bool
hasTeam TeamContinuity
team) [(FactionId, Faction)]
lFs of
              Just (FactionId
fid2, Faction
_) -> [(FactionId
fid, FactionId
fid2), (FactionId
fid2, FactionId
fid)]
              Maybe (FactionId, Faction)
Nothing -> []
        in (TeamContinuity -> [(FactionId, FactionId)])
-> [TeamContinuity] -> [(FactionId, FactionId)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TeamContinuity -> [(FactionId, FactionId)]
pairsFromTeam [TeamContinuity]
teams
      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. Consequently, if a faction
      -- is allied with a faction that is at war with them, they will be
      -- symmetrically at war.
      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
                   ([(FactionId, FactionId)] -> FactionDict)
-> [(FactionId, FactionId)] -> FactionDict
forall a b. (a -> b) -> a -> b
$ ((FactionId, Faction) -> [(FactionId, FactionId)])
-> [(FactionId, Faction)] -> [(FactionId, FactionId)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((FactionKind -> [TeamContinuity])
-> (FactionId, Faction) -> [(FactionId, FactionId)]
pairsFromFaction FactionKind -> [TeamContinuity]
falliedTeams) ([(FactionId, Faction)] -> [(FactionId, FactionId)])
-> [(FactionId, Faction)] -> [(FactionId, FactionId)]
forall a b. (a -> b) -> a -> b
$ FactionDict -> [(FactionId, Faction)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs FactionDict
rawFs
      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
              ([(FactionId, FactionId)] -> FactionDict)
-> [(FactionId, FactionId)] -> FactionDict
forall a b. (a -> b) -> a -> b
$ ((FactionId, Faction) -> [(FactionId, FactionId)])
-> [(FactionId, Faction)] -> [(FactionId, FactionId)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((FactionKind -> [TeamContinuity])
-> (FactionId, Faction) -> [(FactionId, FactionId)]
pairsFromFaction FactionKind -> [TeamContinuity]
fenemyTeams) ([(FactionId, Faction)] -> [(FactionId, FactionId)])
-> [(FactionId, Faction)] -> [(FactionId, FactionId)]
forall a b. (a -> b) -> a -> b
$ FactionDict -> [(FactionId, Faction)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs FactionDict
allianceFs
  return $! warFs

gameReset :: MonadServer m
          => ServerOptions -> Maybe (GroupName ModeKind)
          -> Maybe SM.SMGen -> m State
gameReset :: forall (m :: * -> *).
MonadServer m =>
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{cofact, comode} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  dungeonSeed <- getSetGen $ sdungeonRng serverOptions `mplus` mrandom
  srandom <- getSetGen $ smainRng serverOptions `mplus` mrandom
  let 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)
  when (sdumpInitRngs serverOptions) $ dumpRngs srngs
  scoreTable <- restoreScore cops
  teamGearOld <- getsServer steamGear
  flavourOld <- getsServer sflavour
  discoKindRevOld <- getsServer sdiscoKindRev
  clientStatesOld <- getsServer sclientStates
  let 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 a. Maybe a -> Maybe a -> Maybe a
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 = do
        modeKindId <-
          ContentId ModeKind
-> Maybe (ContentId ModeKind) -> ContentId ModeKind
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> ContentId ModeKind
forall a. (?callStack::CallStack) => [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 = ContentData ModeKind -> ContentId ModeKind -> ModeKind
forall a. ContentData a -> ContentId a -> a
okind ContentData ModeKind
comode ContentId ModeKind
modeKindId
        flavour <- dungeonFlavourMap cops flavourOld
        (discoKind, sdiscoKindRev) <- serverDiscos cops discoKindRevOld
        freshDng <- DungeonGen.dungeonGen cops serverOptions $ mcaves mode
        factionD <- resetFactions cofact (DungeonGen.freshTotalDepth freshDng)
                                  mode (sautomateAll serverOptions)
        return ( factionD, flavour, discoKind
               , sdiscoKindRev, freshDng, modeKindId )
  let ( factionD, sflavour, discoKind
       ,sdiscoKindRev, DungeonGen.FreshDungeon{..}, modeKindId ) =
        St.evalState rnd dungeonSeed
      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
emptyStateServer { srandom
                                , srngs }
  putServer defSer
  modifyServer $ \StateServer
ser -> StateServer
ser { steamGear = teamGearOld
                             , steamGearCur = teamGearOld
                             , sclientStates = clientStatesOld  -- reset later
                             , sdiscoKindRev
                             , sflavour }
  return $! defState

-- Spawn initial actors. Clients should notice this, to set their leaders.
populateDungeon :: forall m. MonadServerAtomic m => m ()
populateDungeon :: forall (m :: * -> *). MonadServerAtomic m => m ()
populateDungeon = do
  cops@COps{coTileSpeedup} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  factionD <- getsState sfactionD
  curChalSer <- getsServer $ scurChalSer . soptions
  let nGt0 (a
_, a
n, c
_) = a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0
      ginitialWolf Faction
fact1 = if Challenge -> Bool
cwolf Challenge
curChalSer Bool -> Bool -> Bool
&& FactionKind -> Bool
fhasUI (Faction -> FactionKind
gkind Faction
fact1)
                           then case ((Y, Y, GroupName ItemKind) -> Bool)
-> [(Y, Y, GroupName ItemKind)] -> [(Y, Y, GroupName ItemKind)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Y, Y, GroupName ItemKind) -> Bool
forall {a} {a} {c}. (Ord a, Num a) => (a, a, c) -> Bool
nGt0 ([(Y, Y, GroupName ItemKind)] -> [(Y, Y, GroupName ItemKind)])
-> [(Y, Y, GroupName ItemKind)] -> [(Y, Y, GroupName ItemKind)]
forall a b. (a -> b) -> a -> b
$ Faction -> [(Y, Y, GroupName ItemKind)]
ginitial Faction
fact1 of
                             [] -> []
                             (Y
ln, Y
_, GroupName ItemKind
grp) : [(Y, Y, GroupName ItemKind)]
_ -> [(Y
ln, Y
1, GroupName ItemKind
grp)]
                           else Faction -> [(Y, Y, GroupName ItemKind)]
ginitial Faction
fact1
      -- Keep the same order of factions as in roster.
      needInitialCrew = ((FactionId, Faction) -> (FactionId, Faction) -> Ordering)
-> [(FactionId, Faction)] -> [(FactionId, Faction)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((FactionId, Faction) -> FactionId)
-> (FactionId, Faction) -> (FactionId, Faction) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (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
. [(Y, Y, GroupName ItemKind)] -> Bool
forall a. [a] -> Bool
null ([(Y, Y, GroupName ItemKind)] -> Bool)
-> ((FactionId, Faction) -> [(Y, Y, GroupName ItemKind)])
-> (FactionId, Faction)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Faction -> [(Y, Y, GroupName ItemKind)]
ginitialWolf (Faction -> [(Y, Y, GroupName ItemKind)])
-> ((FactionId, Faction) -> Faction)
-> (FactionId, Faction)
-> [(Y, Y, 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
fact) =
        ((Y, Y, GroupName ItemKind) -> LevelId)
-> [(Y, Y, GroupName ItemKind)] -> [LevelId]
forall a b. (a -> b) -> [a] -> [b]
map (\(Y
ln, Y
_, GroupName ItemKind
_) -> Y -> LevelId
forall a. Enum a => Y -> a
toEnum Y
ln) ([(Y, Y, GroupName ItemKind)] -> [LevelId])
-> [(Y, Y, GroupName ItemKind)] -> [LevelId]
forall a b. (a -> b) -> a -> b
$ Faction -> [(Y, Y, GroupName ItemKind)]
ginitialWolf Faction
fact
      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
lid (FactionId
_, Faction
fact) =
        ((Y, Y, GroupName ItemKind) -> Bool)
-> [(Y, Y, GroupName ItemKind)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Y
ln, Y
_, GroupName ItemKind
_) -> Y -> LevelId
forall a. Enum a => Y -> a
toEnum Y
ln LevelId -> LevelId -> Bool
forall a. Eq a => a -> a -> Bool
== LevelId
lid) ([(Y, Y, GroupName ItemKind)] -> Bool)
-> [(Y, Y, GroupName ItemKind)] -> Bool
forall a b. (a -> b) -> a -> b
$ Faction -> [(Y, Y, GroupName ItemKind)]
ginitialWolf Faction
fact
      initialActorPositions :: LevelId
                            -> m (LevelId, EM.EnumMap FactionId Point)
      initialActorPositions LevelId
lid = do
        lvl <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel LevelId
lid
        let 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
        entryPoss <- rndToAction $ findEntryPoss cops lvl (length arenaFactions)
        when (length entryPoss < length arenaFactions) $ debugPossiblyPrint
          "Server: populateDungeon: failed to find enough distinct faction starting positions; some factions share positions"
        let 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. (?callStack::CallStack) => [a] -> [a]
cycle [Point]
entryPoss
        return (lid, usedPoss)
  factionPositions <- EM.fromDistinctAscList
                      <$> mapM initialActorPositions arenas
  let initialActors :: (FactionId, Faction) -> m ()
      initialActors (FactionId
fid3, Faction
fact3) =
        ((Y, Y, GroupName ItemKind) -> m ())
-> [(Y, Y, GroupName ItemKind)] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (FactionId -> (Y, Y, GroupName ItemKind) -> m ()
placeActors FactionId
fid3) ([(Y, Y, GroupName ItemKind)] -> m ())
-> [(Y, Y, GroupName ItemKind)] -> m ()
forall a b. (a -> b) -> a -> b
$ Faction -> [(Y, Y, GroupName ItemKind)]
ginitialWolf Faction
fact3
      placeActors :: FactionId -> (Int, Int, GroupName ItemKind) -> m ()
      placeActors FactionId
fid3 (Y
ln, Y
n, GroupName ItemKind
actorGroup) = do
        let lid :: LevelId
lid = Y -> LevelId
forall a. Enum a => Y -> a
toEnum Y
ln
        lvl <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel LevelId
lid
        let 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
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 = COps -> Level -> (ContentId TileKind -> Bool) -> Point -> [Point]
nearbyFreePoints COps
cops Level
lvl ContentId TileKind -> Bool
validTile Point
ppos
            ps = Y -> [Point] -> [Point]
forall a. Y -> [a] -> [a]
take Y
n [Point]
psFree
        when (length ps < n) $ debugPossiblyPrint
          "Server: populateDungeon: failed to find enough initial actor positions; some actors are not generated"
        localTime <- getsState $ getLocalTime lid
        forM_ ps $ \Point
p -> do
          rndDelay <- Rnd Y -> m Y
forall (m :: * -> *) a. MonadServer m => Rnd a -> m a
rndToAction (Rnd Y -> m Y) -> Rnd Y -> m Y
forall a b. (a -> b) -> a -> b
$ (Y, Y) -> Rnd Y
forall a. Integral a => (a, a) -> Rnd a
randomR (Y
1, Y
clipsInTurn Y -> Y -> Y
forall a. Num a => a -> a -> a
- Y
1)
          let delta = Delta Time -> Y -> Delta Time
timeDeltaScale (Time -> Delta Time
forall a. a -> Delta a
Delta Time
timeClip) Y
rndDelay
              rndTime = Time -> Delta Time -> Time
timeShift Time
localTime Delta Time
delta
          maid <- addActorFromGroup actorGroup fid3 p lid rndTime
          case maid of
            Maybe ActorId
Nothing -> [Char] -> m ()
forall a. (?callStack::CallStack) => [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
              mleader <- (State -> Maybe ActorId) -> m (Maybe ActorId)
forall a. (State -> a) -> m a
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.
              when (isNothing mleader) $ setFreshLeader fid3 aid
  placeItemsInDungeon factionPositions
  embedItemsInDungeon
  mapM_ initialActors 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 -> Y -> Rnd [Point]
findEntryPoss COps{ContentData CaveKind
cocave :: COps -> ContentData CaveKind
cocave :: ContentData CaveKind
cocave, TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup}
              lvl :: Level
lvl@Level{ContentId CaveKind
lkind :: Level -> ContentId CaveKind
lkind :: ContentId CaveKind
lkind, Area
larea :: Area
larea :: Level -> Area
larea, ([Point], [Point])
lstair :: ([Point], [Point])
lstair :: Level -> ([Point], [Point])
lstair, [Point]
lescape :: [Point]
lescape :: Level -> [Point]
lescape}
              Y
kRaw = do
  let lskip :: [Y]
lskip = CaveKind -> [Y]
CK.cskip (CaveKind -> [Y]) -> CaveKind -> [Y]
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 :: Y
k = Y
kRaw Y -> Y -> Y
forall a. Num a => a -> a -> a
+ [Y] -> Y
forall a. [a] -> Y
length [Y]
lskip  -- if @lskip@ is bogus, will be too large; OK
      (Point
_, Y
xspan, Y
yspan) = Area -> (Point, Y, Y)
spanArea Area
larea
      factionDist :: Y
factionDist = Y -> Y -> Y
forall a. Ord a => a -> a -> a
max Y
xspan Y
yspan Y -> Y -> Y
forall a. Num a => a -> a -> a
- Y
10
      dist :: t Point -> Y -> Point -> p -> Bool
dist !t Point
poss !Y
cmin !Point
l p
_ = (Point -> Bool) -> t Point -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ !Point
pos -> Point -> Point -> Y
chessDist Point
l Point
pos Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
> Y
cmin) t Point
poss
      tryFind :: [Point] -> Y -> Rnd [Point]
tryFind [Point]
_ Y
0 = [Point] -> Rnd [Point]
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return []
      tryFind ![Point]
ps !Y
n = do
        let ds :: [Point -> ContentId TileKind -> Bool]
ds = [ [Point] -> Y -> Point -> ContentId TileKind -> Bool
forall {t :: * -> *} {p}.
Foldable t =>
t Point -> Y -> Point -> p -> Bool
dist [Point]
ps Y
factionDist
                 , [Point] -> Y -> Point -> ContentId TileKind -> Bool
forall {t :: * -> *} {p}.
Foldable t =>
t Point -> Y -> Point -> p -> Bool
dist [Point]
ps (Y -> Point -> ContentId TileKind -> Bool)
-> Y -> Point -> ContentId TileKind -> Bool
forall a b. (a -> b) -> a -> b
$ Y
factionDist Y -> Y -> Y
forall a. Integral a => a -> a -> a
`div` Y
2
                 , [Point] -> Y -> Point -> ContentId TileKind -> Bool
forall {t :: * -> *} {p}.
Foldable t =>
t Point -> Y -> Point -> p -> Bool
dist [Point]
ps (Y -> Point -> ContentId TileKind -> Bool)
-> Y -> Point -> ContentId TileKind -> Bool
forall a b. (a -> b) -> a -> b
$ Y
factionDist Y -> Y -> Y
forall a. Integral a => a -> a -> a
`div` Y
3
                 , [Point] -> Y -> Point -> ContentId TileKind -> Bool
forall {t :: * -> *} {p}.
Foldable t =>
t Point -> Y -> Point -> p -> Bool
dist [Point]
ps (Y -> Point -> ContentId TileKind -> Bool)
-> Y -> Point -> ContentId TileKind -> Bool
forall a b. (a -> b) -> a -> b
$ Y -> Y -> Y
forall a. Ord a => a -> a -> a
max Y
5 (Y -> Y) -> Y -> Y
forall a b. (a -> b) -> a -> b
$ Y
factionDist Y -> Y -> Y
forall a. Integral a => a -> a -> a
`div` Y
5
                 , [Point] -> Y -> Point -> ContentId TileKind -> Bool
forall {t :: * -> *} {p}.
Foldable t =>
t Point -> Y -> Point -> p -> Bool
dist [Point]
ps (Y -> Point -> ContentId TileKind -> Bool)
-> Y -> Point -> ContentId TileKind -> Bool
forall a b. (a -> b) -> a -> b
$ Y -> Y -> Y
forall a. Ord a => a -> a -> a
max Y
2 (Y -> Y) -> Y -> Y
forall a b. (a -> b) -> a -> b
$ Y
factionDist Y -> Y -> Y
forall a. Integral a => a -> a -> a
`div` Y
10
                 ]
        mp <- Y
-> Level
-> (Point -> ContentId TileKind -> Bool)
-> [Point -> ContentId TileKind -> Bool]
-> (Point -> ContentId TileKind -> Bool)
-> [Point -> ContentId TileKind -> Bool]
-> Rnd (Maybe Point)
findPosTry2 Y
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))
                (Y
-> [Point -> ContentId TileKind -> Bool]
-> [Point -> ContentId TileKind -> Bool]
forall a. Y -> [a] -> [a]
take Y
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 mp of
          Just Point
np -> do
            nps <- [Point] -> Y -> Rnd [Point]
tryFind (Point
np Point -> [Point] -> [Point]
forall a. a -> [a] -> [a]
: [Point]
ps) (Y
n Y -> Y -> Y
forall a. Num a => a -> a -> a
- Y
1)
            return $! np : nps
          Maybe Point
Nothing -> [Point] -> Rnd [Point]
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return []
      sameStaircase :: [Point] -> Point -> Bool
      sameStaircase :: [Point] -> Point -> Bool
sameStaircase [Point]
upStairs Point{Y
px :: Y
py :: Y
py :: Point -> Y
px :: Point -> Y
..} =
        (Point -> Bool) -> [Point] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Point Y
ux Y
uy) -> Y
uy Y -> Y -> Bool
forall a. Eq a => a -> a -> Bool
== Y
py Bool -> Bool -> Bool
&& Y
ux Y -> Y -> Y
forall a. Num a => a -> a -> a
+ Y
2 Y -> Y -> Bool
forall a. Eq a => a -> a -> Bool
== Y
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. (?callStack::CallStack) => Bool -> a -> a
assert (Y
k Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
> Y
0 Bool -> Bool -> Bool
&& Y
factionDist Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
> Y
0) ()
      onEscapes :: [Point]
onEscapes = Y -> [Point] -> [Point]
forall a. Y -> [a] -> [a]
take Y
k [Point]
lescape
      onStairs :: [Point]
onStairs = Y -> [Point] -> [Point]
forall a. Y -> [a] -> [a]
take (Y
k Y -> Y -> Y
forall a. Num a => a -> a -> a
- [Point] -> Y
forall a. [a] -> Y
length [Point]
onEscapes) [Point]
upAndSomeDownStairs
      nk :: Y
nk = Y
k Y -> Y -> Y
forall a. Num a => a -> a -> a
- [Point] -> Y
forall a. [a] -> Y
length [Point]
onEscapes Y -> Y -> Y
forall a. Num a => a -> a -> a
- [Point] -> Y
forall a. [a] -> Y
length [Point]
onStairs
  -- Starting in the middle is too easy.
  found <- [Point] -> Y -> 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) Y
nk
  return $! skipIndexes lskip $ onEscapes ++ onStairs ++ found

-- | Apply options that don't need a new game.
applyDebug :: MonadServer m => m ()
applyDebug :: forall (m :: * -> *). MonadServer m => m ()
applyDebug = do
  ServerOptions{..} <- (StateServer -> ServerOptions) -> m ServerOptions
forall a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> ServerOptions
soptionsNxt
  modifyServer $ \StateServer
ser ->
    StateServer
ser {soptions = (soptions ser) { sniff
                                   , sallClear
                                   , sdbgMsgSer
                                   , snewGameSer
                                   , sassertExplored
                                   , sdumpInitRngs
                                   , sclientOptions }}