module Game.LambdaHack.Server.LoopAction (loopSer) where
import Control.Arrow ((&&&))
import Control.Monad
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.Key (mapWithKeyM_)
import Data.List
import Data.Maybe
import qualified Data.Ord as Ord
import Control.Exception.Assert.Sugar
import qualified Game.LambdaHack.Common.Ability as Ability
import Game.LambdaHack.Common.Action
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.AtomicCmd
import Game.LambdaHack.Common.ClientCmd
import Game.LambdaHack.Common.Faction
import qualified Game.LambdaHack.Common.Feature as F
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.Random
import Game.LambdaHack.Common.ServerCmd
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Content.ActorKind
import Game.LambdaHack.Content.FactionKind
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Frontend
import Game.LambdaHack.Server.Action hiding (sendUpdateAI, sendUpdateUI)
import Game.LambdaHack.Server.Config
import Game.LambdaHack.Server.EffectSem
import Game.LambdaHack.Server.Fov
import Game.LambdaHack.Server.ServerSem
import Game.LambdaHack.Server.StartAction
import Game.LambdaHack.Server.State
loopSer :: (MonadAtomic m, MonadConnServer m)
=> DebugModeSer
-> (CmdSer -> m Bool)
-> (FactionId -> ChanFrontend -> ChanServer CmdClientUI CmdSer
-> IO ())
-> (FactionId -> ChanServer CmdClientAI CmdSerTakeTime
-> IO ())
-> Kind.COps
-> m ()
loopSer sdebug cmdSerSem executorUI executorAI !cops = do
restored <- tryRestore cops sdebug
case restored of
Just (sRaw, ser) | not $ snewGameSer sdebug -> do
let setPreviousCops = const cops
execCmdAtomic $ ResumeServerA $ updateCOps setPreviousCops sRaw
putServer ser
sdebugNxt <- initDebug sdebug
modifyServer $ \ser2 -> ser2 {sdebugNxt}
applyDebug
updateConn executorUI executorAI
initPer
pers <- getsServer sper
broadcastCmdAtomic $ \fid -> ResumeA fid (pers EM.! fid)
let setCurrentCops = const (speedupCOps (sallClear sdebugNxt) cops)
execCmdAtomic $ ResumeServerA $ updateCOps setCurrentCops sRaw
initPer
_ -> do
let mrandom = case restored of
Just (_, ser) -> Just $ srandom ser
Nothing -> Nothing
s <- gameReset cops sdebug mrandom
sdebugNxt <- initDebug sdebug
modifyServer $ \ser -> ser {sdebugNxt, sdebugSer = sdebugNxt}
let speedup = speedupCOps (sallClear sdebugNxt)
execCmdAtomic $ RestartServerA $ updateCOps speedup s
updateConn executorUI executorAI
initPer
reinitGame
when (sdumpConfig sdebug) $ void $ dumpCfg
resetSessionStart
let loop = do
let factionArena fact = do
case gleader fact of
Just leader -> do
b <- getsState $ getActorBody leader
return $ Just $ blid b
_ -> return Nothing
factionD <- getsState sfactionD
marenas <- mapM factionArena $ EM.elems factionD
let arenas = ES.toList $ ES.fromList $ catMaybes marenas
assert (not $ null arenas) skip
mapM_ (handleActors cmdSerSem) arenas
quit <- getsServer squit
if quit then do
modifyServer $ \ser -> ser {squit = False}
endOrLoop (updateConn executorUI executorAI) loop
else do
continue <- endClip arenas
when continue loop
loop
initDebug :: MonadServer m => DebugModeSer -> m DebugModeSer
initDebug sdebugSer = do
sconfig <- getsServer sconfig
return $
(\dbg -> dbg {sfovMode =
sfovMode dbg `mplus` Just (configFovMode sconfig)}) .
(\dbg -> dbg {ssavePrefixSer =
ssavePrefixSer dbg `mplus` Just (configSavePrefix sconfig)})
$ sdebugSer
saveBkpAll :: (MonadAtomic m, MonadServer m, MonadConnServer m) => m ()
saveBkpAll = do
factionD <- getsState sfactionD
let ping fid _ = do
sendPingAI fid
when (playerUI $ gplayer $ factionD EM.! fid) $ sendPingUI fid
mapWithKeyM_ ping factionD
execCmdAtomic SaveBkpA
saveServer
endClip :: (MonadAtomic m, MonadServer m, MonadConnServer m)
=> [LevelId] -> m Bool
endClip arenas = do
mapM_ (\lid -> execCmdAtomic $ AgeLevelA lid timeClip) arenas
execCmdAtomic $ AgeGameA timeClip
time <- getsState stime
Config{configSaveBkpClips} <- getsServer sconfig
let clipN = time `timeFit` timeClip
cinT = let r = timeTurn `timeFit` timeClip
in assert (r > 2) r
clipMod = clipN `mod` cinT
bkpSave <- getsServer sbkpSave
when (bkpSave || clipN `mod` configSaveBkpClips == 0) $ do
modifyServer $ \ser -> ser {sbkpSave = False}
saveBkpAll
if clipMod == 1 then do
arena <- rndToAction $ oneOf arenas
regenerateLevelHP arena
generateMonster arena
sstopAfter <- getsServer $ sstopAfter . sdebugSer
case sstopAfter of
Nothing -> return True
Just stopAfter -> do
exit <- elapsedSessionTimeGT stopAfter
if exit then do
saveAndExit
return False
else return True
else return True
handleActors :: (MonadAtomic m, MonadConnServer m)
=> (CmdSer -> m Bool)
-> LevelId
-> m ()
handleActors cmdSerSem lid = do
Kind.COps{cofaction=Kind.Ops{okind}} <- getsState scops
time <- getsState $ getLocalTime lid
Level{lprio} <- getLevel lid
quit <- getsServer squit
factionD <- getsState sfactionD
s <- getState
let
isLeader (aid, b) = Just aid /= gleader (factionD EM.! bfid b)
order = Ord.comparing $
((>= 0) . bhp . snd) &&& bfid . snd &&& isLeader &&& bsymbol . snd
(atime, as) = EM.findMin lprio
ams = map (\a -> (a, getActorBody a s)) as
mnext | EM.null lprio = Nothing
| otherwise = if atime > time
then Nothing
else Just $ minimumBy order ams
case mnext of
_ | quit -> return ()
Nothing -> return ()
Just (aid, b) | bproj b && bhp b < 0 -> do
ais <- getsState $ getActorItem aid
execCmdAtomic $ DestroyActorA aid b ais
handleActors cmdSerSem lid
Just (aid, b) | bhp b <= 0 && not (bproj b)
|| maybe False null (bpath b) -> do
dieSer aid
handleActors cmdSerSem lid
Just (aid, body) -> do
let side = bfid body
fact = factionD EM.! side
mleader = gleader fact
queryUI | Just aid == mleader = not $ playerAiLeader $ gplayer fact
| otherwise = not $ playerAiOther $ gplayer fact
switchLeader cmdS = do
let aidNew = aidCmdSer cmdS
bPre <- getsState $ getActorBody aidNew
let leadAtoms =
if aidNew /= aid
then
assert (mleader == Just aid && not (bproj bPre)
`blame` (aid, aidNew, bPre, cmdS, fact))
[LeadFactionA side mleader (Just aidNew)]
else []
mapM_ execCmdAtomic leadAtoms
assert (bfid bPre == side
`blame` "client tries to move other faction actors"
`twith` (bPre, side)) skip
return (aidNew, bPre)
extraFrames bPre = do
let previousClipEnd = timeAdd time $ timeNegate timeClip
lastSingleMove = timeAddFromSpeed bPre previousClipEnd
when (btime bPre > lastSingleMove) $
broadcastSfxAtomic DisplayPushD
if queryUI then do
cmdS <- sendQueryUI side aid
(aidNew, bPre) <- switchLeader cmdS
timed <-
if bhp bPre <= 0 && not (bproj bPre) then do
execSfxAtomic
$ MsgFidD side "You strain, fumble and faint from the exertion."
return False
else cmdSerSem cmdS
when timed $ advanceTime aidNew
extraFrames bPre
else do
execSfxAtomic $ DisplayPushD side
let factionAbilities
| Just aid == mleader = fAbilityLeader $ okind $ gkind fact
| otherwise = fAbilityOther $ okind $ gkind fact
canMove = playerUI (gplayer fact)
&& not (bproj body)
&& (Ability.Chase `elem` factionAbilities
|| Ability.Wander `elem` factionAbilities)
when canMove $ execSfxAtomic $ RecordHistoryD side
cmdT <- sendQueryAI side aid
let cmdS = TakeTimeSer cmdT
(aidNew, bPre) <- switchLeader cmdS
assert (not (bhp bPre <= 0 && not (bproj bPre))
`blame` "AI switches to an incapacitated actor"
`twith` (cmdS, bPre, side)) skip
void $ cmdSerSem cmdS
advanceTime aidNew
extraFrames bPre
handleActors cmdSerSem lid
dieSer :: (MonadAtomic m, MonadServer m) => ActorId -> m ()
dieSer aid = do
body <- getsState $ getActorBody aid
electLeader (bfid body) (blid body) aid
dropAllItems aid body
execCmdAtomic $ DestroyActorA aid body {bbag = EM.empty} []
deduceKilled body
dropAllItems :: MonadAtomic m => ActorId -> Actor -> m ()
dropAllItems aid b = do
let f iid k = execCmdAtomic
$ MoveItemA iid k (actorContainer aid (binv b) iid)
(CFloor (blid b) (bpos b))
mapActorItems_ f b
advanceTime :: MonadAtomic m => ActorId -> m ()
advanceTime aid = do
b <- getsState $ getActorBody aid
unless (bhp b < 0 && bproj b || maybe False null (bpath b)) $ do
let t = ticksPerMeter $ bspeed b
execCmdAtomic $ AgeActorA aid t
generateMonster :: (MonadAtomic m, MonadServer m) => LevelId -> m ()
generateMonster lid = do
cops <- getsState scops
pers <- getsServer sper
lvl@Level{ldepth} <- getLevel lid
s <- getState
let f fid = isSpawnFaction fid s
spawns = actorNotProjList f lid s
depth <- getsState sdepth
rc <- rndToAction $ monsterGenChance ldepth depth (length spawns)
when rc $ do
time <- getsState $ getLocalTime lid
mfid <- pickFaction "spawn" (const True)
case mfid of
Nothing -> return ()
Just fid -> do
let allPers = ES.unions $ map (totalVisible . (EM.! lid))
$ EM.elems $ EM.delete fid pers
pos <- rndToAction $ rollSpawnPos cops allPers lid lvl fid s
spawnMonsters [pos] lid time fid
rollSpawnPos :: Kind.COps -> ES.EnumSet Point
-> LevelId -> Level -> FactionId -> State
-> Rnd Point
rollSpawnPos Kind.COps{cotile} visible
lid Level{ltile, lxsize, lysize} fid s = do
let factionDist = max lxsize lysize 5
inhabitants = actorNotProjList (/= fid) lid s
as = actorList (const True) lid s
isLit = Tile.isLit cotile
distantAtLeast d p _ =
all (\b -> chessDist lxsize (bpos b) p > d) inhabitants
findPosTry 40 ltile
( \p t -> Tile.hasFeature cotile F.Walkable t
&& unoccupied as p)
[ \_ t -> not (isLit t)
, distantAtLeast factionDist
, distantAtLeast $ factionDist `div` 2
, \p _ -> not $ p `ES.member` visible
, distantAtLeast $ factionDist `div` 3
, \_ t -> Tile.hasFeature cotile F.CanActor t
, distantAtLeast $ factionDist `div` 4
, distantAtLeast 3
]
regenerateLevelHP :: MonadAtomic m => LevelId -> m ()
regenerateLevelHP lid = do
Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops
time <- getsState $ getLocalTime lid
s <- getState
let approve (a, m) =
let ak = okind $ bkind m
itemAssocs = getActorItem a s
regen = max 1 $
aregen ak `div`
case strongestRegen itemAssocs of
Just (k, _) -> k + 1
Nothing -> 1
bhpMax = maxDice (ahp ak)
deltaHP = min 1 (bhpMax bhp m)
in if (time `timeFit` timeTurn) `mod` regen /= 0
|| deltaHP <= 0
|| bhp m <= 0
then Nothing
else Just a
toRegen <-
getsState $ mapMaybe approve . actorNotProjAssocs (const True) lid
mapM_ (\aid -> execCmdAtomic $ HealActorA aid 1) toRegen
endOrLoop :: (MonadAtomic m, MonadConnServer m) => m () -> m () -> m ()
endOrLoop updConn loopServer = do
factionD <- getsState sfactionD
let inGame fact = case gquit fact of
Nothing -> True
Just Status{stOutcome=Camping} -> True
_ -> False
gameOver = not $ any inGame $ EM.elems factionD
let getQuitter fact = case gquit fact of
Just Status{stOutcome=Restart, stInfo} -> Just stInfo
_ -> Nothing
quitters = mapMaybe getQuitter $ EM.elems factionD
let isCamper fact = case gquit fact of
Just Status{stOutcome=Camping} -> True
_ -> False
campers = filter (isCamper . snd) $ EM.assocs factionD
case (quitters, campers) of
(sgameMode : _, _) -> do
modifyServer $ \ser -> ser {sdebugNxt = (sdebugNxt ser) {sgameMode}}
restartGame updConn loopServer
_ | gameOver -> restartGame updConn loopServer
(_, []) -> loopServer
(_, _ : _) -> do
mapM_ (\(fid, fact) ->
execCmdAtomic
$ QuitFactionA fid Nothing (gquit fact) Nothing) campers
saveAndExit
saveAndExit :: (MonadAtomic m, MonadConnServer m) => m ()
saveAndExit = do
cops <- getsState scops
saveBkpAll
killAllClients
persSaved <- getsServer sper
fovMode <- getsServer $ sfovMode . sdebugSer
pers <- getsState $ dungeonPerception cops
(fromMaybe (Digital 12) fovMode)
assert (persSaved == pers `blame` "wrong saved perception"
`twith` (persSaved, pers)) skip
restartGame :: (MonadAtomic m, MonadConnServer m)
=> m () -> m () -> m ()
restartGame updConn loopServer = do
cops <- getsState scops
sdebugNxt <- getsServer sdebugNxt
srandom <- getsServer srandom
s <- gameReset cops sdebugNxt $ Just srandom
modifyServer $ \ser -> ser {sdebugNxt, sdebugSer = sdebugNxt}
execCmdAtomic $ RestartServerA s
updConn
initPer
reinitGame
loopServer