module Game.LambdaHack.Server.StartAction
( applyDebug, gameReset, reinitGame, initPer
) where
import Control.Monad
import qualified Control.Monad.State as St
import qualified Data.Char as Char
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.Key (mapWithKeyM_)
import Data.List
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Data.Tuple (swap)
import qualified System.Random as R
import Control.Exception.Assert.Sugar
import Game.LambdaHack.Common.Action
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.AtomicCmd
import qualified Game.LambdaHack.Common.Color as Color
import Game.LambdaHack.Common.Faction
import qualified Game.LambdaHack.Common.Feature as F
import Game.LambdaHack.Common.Flavour
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Msg
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.PointXY
import Game.LambdaHack.Common.Random
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Content.ItemKind
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.RuleKind
import Game.LambdaHack.Server.Action hiding (sendUpdateAI, sendUpdateUI)
import Game.LambdaHack.Server.Config
import qualified Game.LambdaHack.Server.DungeonGen as DungeonGen
import Game.LambdaHack.Server.EffectSem
import Game.LambdaHack.Server.Fov
import Game.LambdaHack.Server.ServerSem
import Game.LambdaHack.Server.State
applyDebug :: MonadServer m => m ()
applyDebug = do
DebugModeSer{..} <- getsServer sdebugNxt
modifyServer $ \ser ->
ser {sdebugSer = (sdebugSer ser) { sniffIn
, sniffOut
, sallClear
, sfovMode
, sstopAfter
, sdbgMsgSer
, snewGameSer
, sdumpConfig
, sdebugCli }}
initPer :: MonadServer m => m ()
initPer = do
cops <- getsState scops
fovMode <- getsServer $ sfovMode . sdebugSer
pers <- getsState $ dungeonPerception cops (fromMaybe (Digital 12) fovMode)
modifyServer $ \ser1 -> ser1 {sper = pers}
reinitGame :: (MonadAtomic m, MonadServer m) => m ()
reinitGame = do
Kind.COps{ coitem=Kind.Ops{okind}, corule } <- getsState scops
pers <- getsServer sper
knowMap <- getsServer $ sknowMap . sdebugSer
fromGlobal <- getsState localFromGlobal
s <- getState
let defLoc | knowMap = s
| otherwise = fromGlobal
discoS <- getsServer sdisco
let misteriousSymbols = ritemProject $ Kind.stdRuleset corule
sdisco = let f ik = isymbol (okind ik) `notElem` misteriousSymbols
in EM.filter f discoS
sdebugCli <- getsServer $ sdebugCli . sdebugSer
modeName <- getsServer $ sgameMode . sdebugSer
broadcastCmdAtomic
$ \fid -> RestartA fid sdisco (pers EM.! fid) defLoc sdebugCli modeName
populateDungeon
mapFromInvFuns :: (Bounded a, Enum a, Ord b) => [a -> b] -> M.Map b a
mapFromInvFuns =
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
lowercase :: Text -> Text
lowercase = T.pack . map Char.toLower . T.unpack
createFactions :: Kind.COps -> Players -> Rnd FactionDict
createFactions Kind.COps{cofaction=Kind.Ops{opick}} players = do
let rawCreate gplayer@Player{..} = do
let cmap = mapFromInvFuns
[colorToTeamName, colorToPlainName, colorToFancyName]
nameoc = lowercase playerName
prefix | playerHuman = "Human"
| otherwise = "Autonomous"
(gcolor, gname) = case M.lookup nameoc cmap of
Nothing -> (Color.BrWhite, prefix <+> playerName)
Just c -> (c, prefix <+> playerName <+> "Team")
gkind <- fmap (fromMaybe $ assert `failure` playerFaction)
$ opick playerFaction (const True)
let gdipl = EM.empty
gquit = Nothing
gleader = Nothing
return Faction{..}
lUI <- mapM rawCreate $ filter playerUI $ playersList players
lnoUI <- mapM rawCreate $ filter (not . playerUI) $ playersList players
let lFs = reverse (zip [toEnum (1), toEnum (2)..] lnoUI)
++ zip [toEnum 1..] lUI
swapIx l =
let findPlayerName name = find ((name ==) . playerName . 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 (playersAlly players))
warFs = mkDipl War allianceFs (swapIx (playersEnemy players))
return warFs
gameReset :: MonadServer m
=> Kind.COps -> DebugModeSer -> Maybe R.StdGen -> m State
gameReset cops@Kind.COps{coitem, comode=Kind.Ops{opick, okind}, corule}
sdebug mrandom = do
(sconfig, dungeonSeed, srandom) <- mkConfigRules corule mrandom
scoreTable <- restoreScore sconfig
sstart <- getsServer sstart
let smode = sgameMode sdebug
rnd :: Rnd (FactionDict, FlavourMap, Discovery, DiscoRev,
DungeonGen.FreshDungeon)
rnd = do
modeKind <- fmap (fromMaybe $ assert `failure` smode)
$ opick smode (const True)
let mode = okind modeKind
faction <- createFactions cops $ mplayers mode
sflavour <- dungeonFlavourMap coitem
(sdisco, sdiscoRev) <- serverDiscos coitem
freshDng <- DungeonGen.dungeonGen cops $ mcaves mode
return (faction, sflavour, sdisco, sdiscoRev, freshDng)
let (faction, sflavour, sdisco, sdiscoRev, DungeonGen.FreshDungeon{..}) =
St.evalState rnd dungeonSeed
defState = defStateGlobal freshDungeon freshDepth faction cops scoreTable
defSer = emptyStateServer
{sdisco, sdiscoRev, sflavour, srandom, sconfig, sstart}
putServer defSer
return defState
populateDungeon :: (MonadAtomic m, MonadServer m) => m ()
populateDungeon = do
cops@Kind.COps{cotile} <- getsState scops
let initialItems lid (Level{ltile, litemNum, lxsize, lysize}) =
replicateM litemNum $ do
Level{lfloor} <- getLevel lid
pos <- rndToAction $ findPosTry 1000 ltile
(const (Tile.hasFeature cotile F.CanItem))
[ \p _ -> all (flip EM.notMember lfloor)
$ vicinity lxsize lysize p
, \p _ -> EM.notMember p lfloor
]
createItems 1 pos lid
dungeon <- getsState sdungeon
mapWithKeyM_ initialItems dungeon
factionD <- getsState sfactionD
Config{configHeroNames} <- getsServer sconfig
let (minD, maxD) =
case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of
(Just ((s, _), _), Just ((e, _), _)) -> (s, e)
_ -> assert `failure` "empty dungeon" `twith` dungeon
needInitialCrew = filter ((> 0 ) . playerInitial . gplayer . snd)
$ EM.assocs factionD
getEntryLevel (_, fact) =
max minD $ min maxD $ playerEntry $ gplayer fact
arenas = ES.toList $ ES.fromList $ map getEntryLevel needInitialCrew
initialActors lid = do
lvl <- getLevel lid
let arenaFactions = filter ((== lid) . getEntryLevel) needInitialCrew
entryPoss <- rndToAction
$ findEntryPoss cops lvl (length arenaFactions)
mapM_ (arenaActors lid) $ zip arenaFactions entryPoss
arenaActors _ ((_, Faction{gplayer = Player{playerInitial = 0}}), _) =
return ()
arenaActors lid ((side, fact), ppos) = do
time <- getsState $ getLocalTime lid
let nmult = fromEnum side `mod` 5
ntime = timeAdd time (timeScale timeClip nmult)
validTile t = Tile.hasFeature cotile F.CanActor t
psFree <- getsState $ nearbyFreePoints cotile validTile ppos lid
let ps = take (playerInitial $ gplayer fact) $ zip [0..] psFree
forM_ ps $ \ (n, p) ->
if isSpawnFact cops fact
then spawnMonsters [p] lid ntime side
else do
aid <- addHero side p lid configHeroNames (Just n) ntime
mleader <- getsState
$ gleader . (EM.! side) . sfactionD
when (isNothing mleader) $
execCmdAtomic $ LeadFactionA side Nothing (Just aid)
mapM_ initialActors arenas
findEntryPoss :: Kind.COps -> Level -> Int -> Rnd [Point]
findEntryPoss Kind.COps{cotile} Level{ltile, lxsize, lysize, lstair} k = do
let factionDist = max lxsize lysize 5
dist poss cmin l _ = all (\pos -> chessDist lxsize l pos > cmin) poss
tryFind _ 0 = return []
tryFind ps n = do
np <- findPosTry 1000 ltile
(const (Tile.hasFeature cotile F.CanActor))
[ dist ps $ factionDist `div` 2
, dist ps $ factionDist `div` 3
, dist ps $ factionDist `div` 4
, dist ps $ factionDist `div` 8
, dist ps $ factionDist `div` 16
]
nps <- tryFind (np : ps) (n 1)
return $ np : nps
stairPoss = fst lstair ++ snd lstair
middlePos = toPoint lxsize $ PointXY (lxsize `div` 2, lysize `div` 2)
assert (k > 0 && factionDist > 0) skip
case k of
1 -> tryFind stairPoss k
2 ->
tryFind [middlePos] k
_ | k > 2 -> tryFind [] k
_ -> assert `failure` k