module Game.LambdaHack.Server.StartM
( gameReset, reinitGame, updatePer, initPer, applyDebug
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import Control.Arrow (first)
import qualified Control.Monad.Trans.State.Strict as St
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import qualified Data.IntMap.Strict as IM
import Data.Key (mapWithKeyM_)
import qualified Data.Map.Strict as M
import Data.Ord
import qualified Data.Text as T
import Data.Tuple (swap)
import qualified NLP.Miniutter.English as MU
import qualified System.Random as R
import Game.LambdaHack.Atomic
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.ClientOptions
import qualified Game.LambdaHack.Common.Color as Color
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Flavour
import qualified Game.LambdaHack.Common.HighScore as HighScore
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.Random
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Time
import qualified Game.LambdaHack.Content.ItemKind as IK
import Game.LambdaHack.Content.ModeKind
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.State
initPer :: MonadServer m => m ()
initPer = do
discoAspect <- getsServer sdiscoAspect
( sactorAspect, sfovLitLid, sfovClearLid, sfovLucidLid
,sperValidFid, sperCacheFid, sperFid )
<- getsState $ perFidInDungeon discoAspect
modifyServer $ \ser ->
ser { sactorAspect, sfovLitLid, sfovClearLid, sfovLucidLid
, sperValidFid, sperCacheFid, sperFid }
reinitGame :: (MonadAtomic m, MonadServer m) => m ()
reinitGame = do
Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops
pers <- getsServer sperFid
DebugModeSer{scurChalSer, sknowMap, sdebugCli} <- getsServer sdebugSer
s <- getState
let defLocal | sknowMap = s
| otherwise = localFromGlobal s
discoS <- getsServer sdiscoKind
let sdiscoKind =
let f KindMean{kmKind} = IK.Identified `elem` IK.ifeature (okind kmKind)
in EM.filter f discoS
updRestart fid = UpdRestart fid sdiscoKind (pers EM.! fid) defLocal
scurChalSer sdebugCli
factionD <- getsState sfactionD
mapWithKeyM_ (\fid _ -> execUpdAtomic $ updRestart fid) factionD
dungeon <- getsState sdungeon
let sactorTime = EM.map (const (EM.map (const EM.empty) dungeon)) factionD
modifyServer $ \ser -> ser {sactorTime}
populateDungeon
mapM_ (\fid -> mapM_ (updatePer fid) (EM.keys dungeon))
(EM.keys factionD)
execUpdAtomic $ UpdMsgAll "SortSlots"
updatePer :: (MonadAtomic m, MonadServer m) => FactionId -> LevelId -> m ()
{-# INLINE updatePer #-}
updatePer fid lid = do
modifyServer $ \ser ->
ser {sperValidFid = EM.adjust (EM.insert lid True) fid $ sperValidFid ser}
sperFidOld <- getsServer sperFid
let perOld = sperFidOld EM.! fid EM.! lid
knowEvents <- getsServer $ sknowEvents . sdebugSer
perNew <- recomputeCachePer fid lid
let inPer = diffPer perNew perOld
outPer = diffPer perOld perNew
unless (nullPer outPer && nullPer inPer) $
unless knowEvents $
execSendPer fid lid outPer inPer perNew
mapFromFuns :: (Bounded a, Enum a, Ord b) => [a -> b] -> M.Map b a
mapFromFuns =
let fromFun f m1 =
let invAssocs = map (\c -> (f c, c)) [minBound..maxBound]
m2 = M.fromList invAssocs
in m2 `M.union` m1
in foldr fromFun M.empty
resetFactions :: FactionDict -> Kind.Id ModeKind -> Int -> AbsDepth -> Roster
-> Rnd FactionDict
resetFactions factionDold gameModeIdOld curDiffSerOld totalDepth players = do
let rawCreate (gplayer@Player{..}, initialActors) = do
let castInitialActors (ln, d, actorGroup) = do
n <- castDice (AbsDepth $ abs ln) totalDepth d
return (ln, n, actorGroup)
ginitial <- mapM castInitialActors initialActors
let cmap =
mapFromFuns [colorToTeamName, colorToPlainName, colorToFancyName]
colorName = T.toLower $ head $ T.words fname
prefix = case fleaderMode of
LeaderNull -> "Loose"
LeaderAI _ -> "Autonomous"
LeaderUI _ -> "Controlled"
gnameNew = prefix <+> if fhasGender
then makePhrase [MU.Ws $ MU.Text fname]
else fname
gcolor = M.findWithDefault Color.BrWhite colorName cmap
gvictimsDnew = case find (\fact -> gname fact == gnameNew)
$ EM.elems factionDold of
Nothing -> EM.empty
Just fact ->
let sing = IM.singleton curDiffSerOld (gvictims fact)
f = IM.unionWith (EM.unionWith (+))
in EM.insertWith f gameModeIdOld sing $ gvictimsD fact
let gname = gnameNew
gdipl = EM.empty
gquit = Nothing
_gleader = Nothing
gvictims = EM.empty
gvictimsD = gvictimsDnew
gsha = EM.empty
return $! Faction{..}
lUI <- mapM rawCreate $ filter (fhasUI . fst) $ rosterList players
let !_A = assert (length lUI <= 1
`blame` "currently, at most one faction may have a UI"
`twith` lUI) ()
lnoUI <- mapM rawCreate $ filter (not . fhasUI . fst) $ rosterList players
let lFs = reverse (zip [toEnum (-1), toEnum (-2)..] lnoUI)
++ zip [toEnum 1..] lUI
swapIx l =
let findPlayerName name = find ((name ==) . fname . gplayer . snd)
f (name1, name2) =
case (findPlayerName name1 lFs, findPlayerName name2 lFs) of
(Just (ix1, _), Just (ix2, _)) -> (ix1, ix2)
_ -> assert `failure` "unknown faction"
`twith` ((name1, name2), lFs)
ixs = map f l
in ixs ++ map swap ixs
mkDipl diplMode =
let f (ix1, ix2) =
let adj fact = fact {gdipl = EM.insert ix2 diplMode (gdipl fact)}
in EM.adjust adj ix1
in foldr f
rawFs = EM.fromDistinctAscList lFs
allianceFs = mkDipl Alliance rawFs (swapIx (rosterAlly players))
warFs = mkDipl War allianceFs (swapIx (rosterEnemy players))
return $! warFs
gameReset :: MonadServer m
=> Kind.COps -> DebugModeSer -> Maybe (GroupName ModeKind)
-> Maybe R.StdGen -> m State
gameReset cops@Kind.COps{comode=Kind.Ops{opick, okind}}
sdebug mGameMode mrandom = do
dungeonSeed <- getSetGen $ sdungeonRng sdebug `mplus` mrandom
srandom <- getSetGen $ smainRng sdebug `mplus` mrandom
let srngs = RNGs (Just dungeonSeed) (Just srandom)
when (sdumpInitRngs sdebug) $ dumpRngs srngs
scoreTable <- if sfrontendNull $ sdebugCli sdebug then
return HighScore.empty
else
restoreScore cops
factionDold <- getsState sfactionD
gameModeIdOld <- getsState sgameModeId
curChalSer <- getsServer $ scurChalSer . sdebugSer
#ifdef USE_BROWSER
let startingModeGroup = "starting JS"
#else
let startingModeGroup = "starting"
#endif
gameMode = fromMaybe startingModeGroup
$ mGameMode `mplus` sgameMode sdebug
rnd :: Rnd (FactionDict, FlavourMap, DiscoveryKind, DiscoveryKindRev,
DungeonGen.FreshDungeon, Kind.Id ModeKind)
rnd = do
modeKindId <- fromMaybe (assert `failure` gameMode)
<$> opick gameMode (const True)
let mode = okind modeKindId
automatePS ps = ps {rosterList =
map (first $ automatePlayer True) $ rosterList ps}
players = if sautomateAll sdebug
then automatePS $ mroster mode
else mroster mode
sflavour <- dungeonFlavourMap cops
(sdiscoKind, sdiscoKindRev) <- serverDiscos cops
freshDng <- DungeonGen.dungeonGen cops $ mcaves mode
factionD <- resetFactions factionDold gameModeIdOld
(cdiff curChalSer)
(DungeonGen.freshTotalDepth freshDng)
players
return ( factionD, sflavour, sdiscoKind
, sdiscoKindRev, freshDng, modeKindId )
let ( factionD, sflavour, sdiscoKind
,sdiscoKindRev, DungeonGen.FreshDungeon{..}, modeKindId ) =
St.evalState rnd dungeonSeed
defState = defStateGlobal freshDungeon freshTotalDepth
factionD cops scoreTable modeKindId
defSer = emptyStateServer { srandom
, srngs }
putServer defSer
modifyServer $ \ser -> ser {sdiscoKind, sdiscoKindRev, sflavour}
return $! defState
populateDungeon :: (MonadAtomic m, MonadServer m) => m ()
populateDungeon = do
cops@Kind.COps{coTileSpeedup} <- getsState scops
placeItemsInDungeon
embedItemsInDungeon
dungeon <- getsState sdungeon
factionD <- getsState sfactionD
curChalSer <- getsServer $ scurChalSer . sdebugSer
let ginitialWolf fact1 = if cwolf curChalSer && fhasUI (gplayer fact1)
then case ginitial fact1 of
[] -> []
(ln, _, grp) : _ -> [(ln, 1, grp)]
else ginitial fact1
(minD, maxD) =
case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of
(Just ((s, _), _), Just ((e, _), _)) -> (s, e)
_ -> assert `failure` "empty dungeon" `twith` dungeon
valuePlayer pl = (not $ fcanEscape pl, fname pl)
needInitialCrew = sortBy (comparing $ valuePlayer . gplayer . snd)
$ filter (not . null . ginitialWolf . snd)
$ EM.assocs factionD
g (ln, _, _) = max minD . min maxD . toEnum $ ln
getEntryLevels (_, fact) = map g $ ginitialWolf fact
arenas = ES.toList $ ES.fromList
$ concatMap getEntryLevels needInitialCrew
hasActorsOnArena lid (_, fact) =
any ((== lid) . g) $ ginitialWolf fact
initialActors lid = do
lvl <- getLevel lid
let arenaFactions = filter (hasActorsOnArena lid) needInitialCrew
indexff (fid, _) = findIndex ((== fid) . fst) arenaFactions
representsAlliance ff2@(_, fact2) =
not $ any (\ff3@(fid3, _) ->
indexff ff3 < indexff ff2
&& isAllied fact2 fid3) arenaFactions
arenaAlliances = filter representsAlliance arenaFactions
placeAlliance ((fid3, _), ppos, timeOffset) =
mapM_ (\(fid4, fact4) ->
when (isAllied fact4 fid3 || fid4 == fid3) $
placeActors lid ((fid4, fact4), ppos, timeOffset))
arenaFactions
entryPoss <- rndToAction
$ findEntryPoss cops lid lvl (length arenaAlliances)
mapM_ placeAlliance $ zip3 arenaAlliances entryPoss [0..]
placeActors lid ((fid3, fact3), ppos, timeOffset) = do
localTime <- getsState $ getLocalTime lid
let clipInTurn = timeTurn `timeFit` timeClip
nmult = 1 + timeOffset `mod` clipInTurn
ntime = timeShift localTime (timeDeltaScale (Delta timeClip) nmult)
validTile t = not $ Tile.isNoActor coTileSpeedup t
initActors = ginitialWolf fact3
initGroups = concat [ replicate n actorGroup
| ln3@(_, n, actorGroup) <- initActors
, g ln3 == lid ]
psFree <- getsState $ nearbyFreePoints validTile ppos lid
let ps = zip initGroups psFree
forM_ ps $ \ (actorGroup, p) -> do
maid <- addActor actorGroup fid3 p lid id ntime
case maid of
Nothing -> assert `failure` "can't spawn initial actors"
`twith` (lid, (fid3, fact3))
Just aid -> do
mleader <- getsState $ _gleader . (EM.! fid3) . sfactionD
when (isNothing mleader) $ supplantLeader fid3 aid
return True
mapM_ initialActors arenas
findEntryPoss :: Kind.COps -> LevelId -> Level -> Int -> Rnd [Point]
findEntryPoss Kind.COps{coTileSpeedup}
lid Level{ltile, lxsize, lysize, lstair, lescape} k = do
let factionDist = max lxsize lysize - 10
dist poss cmin l _ = all (\pos -> chessDist l pos > cmin) poss
tryFind _ 0 = return []
tryFind ps n = do
let ds = [ dist ps $ factionDist `div` 2
, dist ps $ factionDist `div` 3
, dist ps $ factionDist `div` 4
, dist ps $ factionDist `div` 6
]
np <- findPosTry2 1000 ltile
(\_ t -> Tile.isWalkable coTileSpeedup t
&& not (Tile.isNoActor coTileSpeedup t))
ds
(\_p t -> Tile.isOftenActor coTileSpeedup t)
ds
nps <- tryFind (np : ps) (n - 1)
return $! np : nps
(deeperStairs, shallowerStairs) =
(if fromEnum lid > 0 then id else swap) lstair
stairPoss = if length deeperStairs > length shallowerStairs
then deeperStairs
else shallowerStairs
middlePos = Point (lxsize `div` 2) (lysize `div` 2)
let !_A = assert (k > 0 && factionDist > 0) ()
onStairs = reverse $ take k $ lescape ++ stairPoss
nk = k - length onStairs
found <- tryFind (middlePos : onStairs) nk
return $! found ++ onStairs
applyDebug :: MonadServer m => m ()
applyDebug = do
DebugModeSer{..} <- getsServer sdebugNxt
modifyServer $ \ser ->
ser {sdebugSer = (sdebugSer ser) { sniffIn
, sniffOut
, sallClear
, sdbgMsgSer
, snewGameSer
, sdumpInitRngs
, sdebugCli }}