module Game.LambdaHack.Server.StartM
( initPer, reinitGame, gameReset, applyDebug
#ifdef EXPOSE_INTERNAL
, 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
( 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 a. (State -> a) -> m a
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 { sfovLitLid, sfovClearLid, sfovLucidLid
, sperValidFid, sperCacheFid, sperFid }
reinitGame :: MonadServerAtomic m => FactionDict -> m ()
reinitGame :: forall (m :: * -> *). MonadServerAtomic m => FactionDict -> m ()
reinitGame FactionDict
factionDold = do
COps{ContentData ItemKind
coitem :: ContentData ItemKind
coitem :: COps -> ContentData ItemKind
coitem} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
PerFid
pers <- (StateServer -> PerFid) -> m PerFid
forall a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> PerFid
sperFid
ServerOptions{Challenge
scurChalSer :: Challenge
scurChalSer :: ServerOptions -> Challenge
scurChalSer, Bool
sknowMap :: Bool
sknowMap :: ServerOptions -> Bool
sknowMap, Bool
sshowItemSamples :: Bool
sshowItemSamples :: ServerOptions -> Bool
sshowItemSamples, ClientOptions
sclientOptions :: ClientOptions
sclientOptions :: ServerOptions -> ClientOptions
sclientOptions}
<- (StateServer -> ServerOptions) -> m ServerOptions
forall a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> ServerOptions
soptions
State
s <- m State
forall (m :: * -> *). MonadStateRead m => m State
getState
DiscoveryKind
discoS <- (State -> DiscoveryKind) -> m DiscoveryKind
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> DiscoveryKind
sdiscoKind
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 a. (State -> a) -> m a
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 a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> EnumMap FactionId State
sclientStates
EnumMap TeamContinuity DiscoveryKind
metaBackupOld <- (StateServer -> EnumMap TeamContinuity DiscoveryKind)
-> m (EnumMap TeamContinuity DiscoveryKind)
forall a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> EnumMap TeamContinuity DiscoveryKind
smetaBackup
let inMetaGame :: ContentId ItemKind -> Bool
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 :: EnumMap FactionId DiscoveryKind
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 -> 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 :: EnumMap TeamContinuity DiscoveryKind
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 :: EnumMap k a -> EnumMap k a -> EnumMap k a
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
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 :: EnumSet TeamContinuity
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
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 -> State
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 :: EnumMap FactionId State
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
(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 = clientStatesNew
, smetaBackup = metaBackupNew }
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
SMGen
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 (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 = 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 a. (State -> a) -> m a
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 {sactorTime, 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 a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> SMGen
srandom
UniqueSet
uniqueSetOrig <- (StateServer -> UniqueSet) -> m UniqueSet
forall a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> UniqueSet
suniqueSet
GenerationAnalytics
genOld <- (StateServer -> GenerationAnalytics) -> m GenerationAnalytics
forall a. (StateServer -> a) -> m a
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 {sgenerationAn}
(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 = genOrig, suniqueSet = 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)
sampleTrunks :: MonadServerAtomic m => Dungeon -> m GenerationAnalytics
sampleTrunks :: forall (m :: * -> *).
MonadServerAtomic m =>
Dungeon -> m GenerationAnalytics
sampleTrunks Dungeon
dungeon = do
COps{ContentData CaveKind
cocave :: ContentData CaveKind
cocave :: COps -> ContentData CaveKind
cocave, ContentData ItemKind
coitem :: COps -> ContentData ItemKind
coitem :: ContentData ItemKind
coitem} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
FactionDict
factionD <- (State -> FactionDict) -> m FactionDict
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> FactionDict
sfactionD
let getGroups :: Level -> [GroupName ItemKind]
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 :: [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 -> 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 :: [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 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
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 :: Level -> AbsDepth
ldepth :: 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 (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
NewItem
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 NewItem
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
[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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ContentId ItemKind -> m (Maybe ItemId)
regItem [ContentId ItemKind]
trunkKindIds
GenerationAnalytics -> m GenerationAnalytics
forall a. a -> m a
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 Y -> GenerationAnalytics
forall k a. Enum k => k -> a -> EnumMap k a
EM.singleton SLore
STrunk
(EnumMap ItemId Y -> GenerationAnalytics)
-> EnumMap ItemId Y -> GenerationAnalytics
forall a b. (a -> b) -> a -> b
$ [(ItemId, Y)] -> EnumMap ItemId Y
forall k a. Enum k => [(k, a)] -> EnumMap k a
EM.fromDistinctAscList ([(ItemId, Y)] -> EnumMap ItemId Y)
-> [(ItemId, Y)] -> EnumMap ItemId Y
forall a b. (a -> b) -> a -> b
$ [ItemId] -> [Y] -> [(ItemId, Y)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Maybe ItemId] -> [ItemId]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ItemId]
miids) ([Y] -> [(ItemId, Y)]) -> [Y] -> [(ItemId, Y)]
forall a b. (a -> b) -> a -> b
$ Y -> [Y]
forall a. a -> [a]
repeat Y
0
sampleItems :: MonadServerAtomic m => Dungeon -> m GenerationAnalytics
sampleItems :: forall (m :: * -> *).
MonadServerAtomic m =>
Dungeon -> m GenerationAnalytics
sampleItems Dungeon
dungeon = do
COps{ContentData CaveKind
cocave :: COps -> ContentData CaveKind
cocave :: ContentData CaveKind
cocave, ContentData ItemKind
coitem :: COps -> ContentData ItemKind
coitem :: ContentData ItemKind
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 -> [GroupName ItemKind]
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 :: [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 -> 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 :: [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 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
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 :: Level -> AbsDepth
ldepth :: 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 (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
NewItem
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 NewItem
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
[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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ContentId ItemKind -> m (Maybe ItemId)
regItem [ContentId ItemKind]
itemKindIds
GenerationAnalytics -> m GenerationAnalytics
forall a. a -> m a
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 Y -> GenerationAnalytics
forall k a. Enum k => k -> a -> EnumMap k a
EM.singleton SLore
SItem
(EnumMap ItemId Y -> GenerationAnalytics)
-> EnumMap ItemId Y -> GenerationAnalytics
forall a b. (a -> b) -> a -> b
$ [(ItemId, Y)] -> EnumMap ItemId Y
forall k a. Enum k => [(k, a)] -> EnumMap k a
EM.fromDistinctAscList ([(ItemId, Y)] -> EnumMap ItemId Y)
-> [(ItemId, Y)] -> EnumMap ItemId Y
forall a b. (a -> b) -> a -> b
$ [ItemId] -> [Y] -> [(ItemId, Y)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Maybe ItemId] -> [ItemId]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ItemId]
miids) ([Y] -> [(ItemId, Y)]) -> [Y] -> [(ItemId, Y)]
forall a b. (a -> b) -> a -> b
$ Y -> [Y]
forall a. a -> [a]
repeat Y
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
ContentId FactionKind
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
gkind@FactionKind{Bool
HiCondPoly
[(GroupName ItemKind, Y)]
Freqs FactionKind
[TeamContinuity]
Text
Doctrine
Skills
TeamContinuity
fteam :: FactionKind -> TeamContinuity
fname :: Text
ffreq :: Freqs FactionKind
fteam :: TeamContinuity
fgroups :: [(GroupName ItemKind, Y)]
fskillsOther :: Skills
fcanEscape :: Bool
fneverEmpty :: Bool
fhiCondPoly :: HiCondPoly
fhasGender :: Bool
finitDoctrine :: Doctrine
fspawnsFast :: Bool
fhasPointman :: Bool
fhasUI :: Bool
finitUnderAI :: Bool
fenemyTeams :: [TeamContinuity]
falliedTeams :: [TeamContinuity]
fname :: FactionKind -> Text
ffreq :: FactionKind -> Freqs FactionKind
fgroups :: FactionKind -> [(GroupName ItemKind, Y)]
fskillsOther :: FactionKind -> Skills
fcanEscape :: FactionKind -> Bool
fneverEmpty :: FactionKind -> Bool
fhiCondPoly :: FactionKind -> HiCondPoly
fhasGender :: FactionKind -> Bool
finitDoctrine :: FactionKind -> Doctrine
fspawnsFast :: FactionKind -> Bool
fhasPointman :: FactionKind -> Bool
fhasUI :: FactionKind -> Bool
finitUnderAI :: FactionKind -> Bool
fenemyTeams :: FactionKind -> [TeamContinuity]
falliedTeams :: FactionKind -> [TeamContinuity]
..} = ContentData FactionKind -> ContentId FactionKind -> FactionKind
forall a. ContentData a -> ContentId a -> a
okind ContentData FactionKind
cofact ContentId FactionKind
gkindId
castInitialActors :: (Y, Dice, GroupName ItemKind)
-> StateT SMGen Identity (Y, Y, GroupName ItemKind)
castInitialActors (Y
ln, Dice
d, GroupName ItemKind
actorGroup) = do
Y
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
(Y, Y, GroupName ItemKind)
-> StateT SMGen Identity (Y, Y, GroupName ItemKind)
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Y
ln, Y
n, GroupName ItemKind
actorGroup)
[(Y, Y, GroupName ItemKind)]
ginitial <- ((Y, Dice, GroupName ItemKind)
-> StateT SMGen Identity (Y, Y, GroupName ItemKind))
-> [(Y, Dice, GroupName ItemKind)]
-> StateT SMGen Identity [(Y, Y, GroupName ItemKind)]
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 (Y, Dice, GroupName ItemKind)
-> StateT SMGen Identity (Y, Y, GroupName ItemKind)
castInitialActors [(Y, 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. (?callStack::CallStack) => [a] -> a
head ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words Text
fname
prefix :: Text
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
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
let gname :: Text
gname = Text
gnameNew
gdoctrine :: Doctrine
gdoctrine = Doctrine
finitDoctrine
gunderAI :: Bool
gunderAI = Bool
finitUnderAI Bool -> Bool -> Bool
|| ModeKind -> Bool
mattract ModeKind
mode Bool -> Bool -> Bool
|| Bool
automateAll
gdipl :: EnumMap k a
gdipl = EnumMap k a
forall k a. EnumMap k a
EM.empty
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
gstash :: Maybe a
gstash = Maybe a
forall a. Maybe a
Nothing
(FactionId, Faction) -> StateT SMGen Identity (FactionId, Faction)
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (FactionId
fid, Faction{Bool
[(Y, Y, GroupName ItemKind)]
Maybe (LevelId, Point)
Maybe ActorId
Maybe Status
Text
EnumMap (ContentId ItemKind) Y
Dipl
Doctrine
Color
FactionKind
forall a. Maybe a
forall k a. EnumMap k a
gkind :: FactionKind
gkind :: FactionKind
ginitial :: [(Y, Y, GroupName ItemKind)]
gcolor :: Color
gname :: Text
gdoctrine :: Doctrine
gunderAI :: Bool
gdipl :: forall k a. EnumMap k a
gquit :: forall a. Maybe a
_gleader :: forall a. Maybe a
gvictims :: forall k a. EnumMap k a
gstash :: forall a. Maybe a
gname :: Text
gcolor :: Color
gdoctrine :: Doctrine
gunderAI :: Bool
ginitial :: [(Y, Y, GroupName ItemKind)]
gdipl :: Dipl
gquit :: Maybe Status
_gleader :: Maybe ActorId
gstash :: Maybe (LevelId, Point)
gvictims :: EnumMap (ContentId ItemKind) Y
..})
[(FactionId, 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
-> 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 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
pairsFromFaction :: (FactionKind -> [TeamContinuity])
-> (FactionId, Faction)
-> [(FactionId, FactionId)]
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 :: FactionDict
rawFs = [(FactionId, Faction)] -> FactionDict
forall k a. Enum k => [(k, a)] -> EnumMap k a
EM.fromList [(FactionId, Faction)]
lFs
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
([(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 :: 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
([(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
FactionDict -> Rnd FactionDict
forall a. a -> StateT SMGen Identity a
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 :: forall (m :: * -> *).
MonadServer m =>
ServerOptions
-> Maybe (GroupName ModeKind) -> Maybe SMGen -> m State
gameReset ServerOptions
serverOptions Maybe (GroupName ModeKind)
mGameMode Maybe SMGen
mrandom = do
cops :: COps
cops@COps{ContentData FactionKind
cofact :: ContentData FactionKind
cofact :: COps -> ContentData FactionKind
cofact, ContentData ModeKind
comode :: ContentData ModeKind
comode :: COps -> ContentData ModeKind
comode} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
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 a. Maybe a -> Maybe a -> Maybe a
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 a. Maybe a -> Maybe a -> Maybe a
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
GearOfTeams
teamGearOld <- (StateServer -> GearOfTeams) -> m GearOfTeams
forall a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> GearOfTeams
steamGear
FlavourMap
flavourOld <- (StateServer -> FlavourMap) -> m FlavourMap
forall a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> FlavourMap
sflavour
DiscoveryKindRev
discoKindRevOld <- (StateServer -> DiscoveryKindRev) -> m DiscoveryKindRev
forall a. (StateServer -> a) -> m a
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 a. (StateServer -> a) -> m a
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> EnumMap FactionId State
sclientStates
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 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 :: 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. (?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 :: ModeKind
mode = ContentData ModeKind -> ContentId ModeKind -> ModeKind
forall a. ContentData a -> ContentId a -> a
okind ContentData ModeKind
comode ContentId ModeKind
modeKindId
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 <- ContentData FactionKind
-> AbsDepth -> ModeKind -> Bool -> Rnd FactionDict
resetFactions ContentData FactionKind
cofact (FreshDungeon -> AbsDepth
DungeonGen.freshTotalDepth FreshDungeon
freshDng)
ModeKind
mode (ServerOptions -> Bool
sautomateAll ServerOptions
serverOptions)
(FactionDict, FlavourMap, DiscoveryKind, DiscoveryKindRev,
FreshDungeon, ContentId ModeKind)
-> Rnd
(FactionDict, FlavourMap, DiscoveryKind, DiscoveryKindRev,
FreshDungeon, ContentId ModeKind)
forall a. a -> StateT SMGen Identity a
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
freshTotalDepth :: FreshDungeon -> AbsDepth
freshDungeon :: Dungeon
freshTotalDepth :: AbsDepth
freshDungeon :: FreshDungeon -> Dungeon
..}, 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 { srandom
, 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 = teamGearOld
, steamGearCur = teamGearOld
, sclientStates = clientStatesOld
, sdiscoKindRev
, sflavour }
State -> m State
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (State -> m State) -> State -> m State
forall a b. (a -> b) -> a -> b
$! State
defState
populateDungeon :: forall m. MonadServerAtomic m => m ()
populateDungeon :: forall (m :: * -> *). MonadServerAtomic m => m ()
populateDungeon = do
cops :: COps
cops@COps{TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
FactionDict
factionD <- (State -> FactionDict) -> m FactionDict
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> FactionDict
sfactionD
Challenge
curChalSer <- (StateServer -> Challenge) -> m Challenge
forall a. (StateServer -> a) -> m a
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 -> [(Y, Y, GroupName ItemKind)]
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
needInitialCrew :: [(FactionId, Faction)]
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) -> [LevelId]
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 :: [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) =
((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 -> 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 -> Y -> Rnd [Point]
findEntryPoss COps
cops Level
lvl ([FactionId] -> Y
forall a. [a] -> Y
length [FactionId]
arenaFactions)
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Point] -> Y
forall a. [a] -> Y
length [Point]
entryPoss Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
< [FactionId] -> Y
forall a. [a] -> Y
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. (?callStack::CallStack) => [a] -> [a]
cycle [Point]
entryPoss
(LevelId, EnumMap FactionId Point)
-> m (LevelId, EnumMap FactionId Point)
forall a. a -> m a
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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) =
((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 -> (Y, Y, 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
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
psFree :: [Point]
psFree = COps -> Level -> (ContentId TileKind -> Bool) -> Point -> [Point]
nearbyFreePoints COps
cops Level
lvl ContentId TileKind -> Bool
validTile Point
ppos
ps :: [Point]
ps = Y -> [Point] -> [Point]
forall a. Y -> [a] -> [a]
take Y
n [Point]
psFree
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Point] -> Y
forall a. [a] -> Y
length [Point]
ps Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
< Y
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 a. (State -> a) -> m a
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
Y
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
delta = Delta Time -> Y -> Delta Time
timeDeltaScale (Time -> Delta Time
forall a. a -> Delta a
Delta Time
timeClip) Y
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. (?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
Maybe ActorId
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
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
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
(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
]
Maybe Point
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
(\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)
(\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] -> 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)
[Point] -> Rnd [Point]
forall a. a -> StateT SMGen Identity a
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 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
px :: Point -> Y
py :: 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
[Point]
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
[Point] -> Rnd [Point]
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Point] -> Rnd [Point]) -> [Point] -> Rnd [Point]
forall a b. (a -> b) -> a -> b
$! [Y] -> [Point] -> [Point]
forall {t :: * -> *} {a} {b}.
(Foldable t, Eq a, Num a, Enum a) =>
t a -> [b] -> [b]
skipIndexes [Y]
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
applyDebug :: MonadServer m => m ()
applyDebug :: forall (m :: * -> *). MonadServer m => m ()
applyDebug = do
ServerOptions{Bool
[Char]
Maybe Y
Maybe SMGen
Maybe (GroupName ModeKind)
ClientOptions
Challenge
scurChalSer :: ServerOptions -> Challenge
sknowMap :: ServerOptions -> Bool
sshowItemSamples :: ServerOptions -> Bool
sclientOptions :: ServerOptions -> ClientOptions
sdungeonRng :: ServerOptions -> Maybe SMGen
smainRng :: ServerOptions -> Maybe SMGen
sdumpInitRngs :: ServerOptions -> Bool
sgameMode :: ServerOptions -> Maybe (GroupName ModeKind)
sautomateAll :: ServerOptions -> Bool
sknowMap :: Bool
sknowEvents :: Bool
sknowItems :: Bool
sniff :: Bool
sallClear :: Bool
sboostRandomItem :: Bool
sgameMode :: Maybe (GroupName ModeKind)
sautomateAll :: Bool
skeepAutomated :: Bool
sdungeonRng :: Maybe SMGen
smainRng :: Maybe SMGen
snewGameSer :: Bool
scurChalSer :: Challenge
sdumpInitRngs :: Bool
ssavePrefixSer :: [Char]
sdbgMsgSer :: Bool
sassertExplored :: Maybe Y
sshowItemSamples :: Bool
sstopAfterGameOver :: Bool
sclientOptions :: ClientOptions
sknowEvents :: ServerOptions -> Bool
sknowItems :: ServerOptions -> Bool
sniff :: ServerOptions -> Bool
sallClear :: ServerOptions -> Bool
sboostRandomItem :: ServerOptions -> Bool
skeepAutomated :: ServerOptions -> Bool
snewGameSer :: ServerOptions -> Bool
ssavePrefixSer :: ServerOptions -> [Char]
sdbgMsgSer :: ServerOptions -> Bool
sassertExplored :: ServerOptions -> Maybe Y
sstopAfterGameOver :: ServerOptions -> Bool
..} <- (StateServer -> ServerOptions) -> m ServerOptions
forall a. (StateServer -> a) -> m a
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 = (soptions ser) { sniff
, sallClear
, sdbgMsgSer
, snewGameSer
, sassertExplored
, sdumpInitRngs
, sclientOptions }}