module Game.LambdaHack.Server.LoopM
( loopSer
#ifdef EXPOSE_INTERNAL
, factionArena, arenasForLoop, handleFidUpd, loopUpd, endClip
, manageCalmAndDomination, applyPeriodicLevel
, handleTrajectories, hTrajectories, advanceTrajectory
, handleActors, hActors, restartGame
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Game.LambdaHack.Atomic
import Game.LambdaHack.Client (ReqUI (..))
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Analytics
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.ItemAspect as IA
import Game.LambdaHack.Common.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.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Common.Types
import Game.LambdaHack.Common.Vector
import qualified Game.LambdaHack.Content.ItemKind as IK
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.RuleKind
import qualified Game.LambdaHack.Definition.Ability as Ability
import Game.LambdaHack.Definition.Defs
import Game.LambdaHack.Server.CommonM
import Game.LambdaHack.Server.EndM
import Game.LambdaHack.Server.HandleEffectM
import Game.LambdaHack.Server.HandleRequestM
import Game.LambdaHack.Server.MonadServer
import Game.LambdaHack.Server.PeriodicM
import Game.LambdaHack.Server.ProtocolM
import Game.LambdaHack.Server.ServerOptions
import Game.LambdaHack.Server.StartM
import Game.LambdaHack.Server.State
loopSer :: (MonadServerAtomic m, MonadServerComm m)
=> ServerOptions
-> (Bool -> FactionId -> ChanServer -> IO ())
-> m ()
loopSer serverOptions executorClient = do
modifyServer $ \ser -> ser { soptionsNxt = serverOptions
, soptions = serverOptions }
cops <- getsState scops
let updConn = updateConn executorClient
restored <- tryRestore
case restored of
Just (sRaw, ser) | not $ snewGameSer serverOptions -> do
execUpdAtomic $ UpdResumeServer
$ updateCOpsAndCachedData (const cops) sRaw
putServer ser {soptionsNxt = serverOptions}
applyDebug
factionD <- getsState sfactionD
let f fid = let cmd = UpdResumeServer
$ updateCOpsAndCachedData (const cops)
$ sclientStates ser EM.! fid
in execUpdAtomicFidCatch fid cmd
mapM_ f $ EM.keys factionD
updConn
initPer
pers <- getsServer sperFid
let clear = const emptyPer
persFid fid | sknowEvents serverOptions = EM.map clear (pers EM.! fid)
| otherwise = pers EM.! fid
mapM_ (\fid -> sendUpdate fid $ UpdResume fid (persFid fid))
(EM.keys factionD)
arenasNew <- arenasForLoop
modifyServer $ \ser2 -> ser2 {sarenas = arenasNew, svalidArenas = True}
rngs <- getsServer srngs
when (sdumpInitRngs serverOptions) $ dumpRngs rngs
_ -> do
s <- gameReset serverOptions Nothing Nothing
let optionsBarRngs =
serverOptions {sdungeonRng = Nothing, smainRng = Nothing}
modifyServer $ \ser -> ser { soptionsNxt = optionsBarRngs
, soptions = optionsBarRngs }
execUpdAtomic $ UpdRestartServer s
updConn
initPer
reinitGame
writeSaveAll False
loopUpd updConn
factionArena :: MonadStateRead m => Faction -> m (Maybe LevelId)
factionArena fact = case gleader fact of
Just leader -> do
b <- getsState $ getActorBody leader
return $ Just $ blid b
Nothing -> return Nothing
arenasForLoop :: MonadStateRead m => m [LevelId]
{-# INLINE arenasForLoop #-}
arenasForLoop = do
factionD <- getsState sfactionD
marenas <- mapM factionArena $ EM.elems factionD
let arenas = ES.toList $ ES.fromList $ catMaybes marenas
!_A = assert (not (null arenas)
`blame` "game over not caught earlier"
`swith` factionD) ()
return $! arenas
handleFidUpd :: forall m. (MonadServerAtomic m, MonadServerComm m)
=> (FactionId -> m ()) -> FactionId -> Faction -> m ()
{-# INLINE handleFidUpd #-}
handleFidUpd updatePerFid fid fact = do
updatePerFid fid
let handle :: [LevelId] -> m Bool
handle [] = return False
handle (lid : rest) = do
breakASAP <- getsServer sbreakASAP
if breakASAP
then return False
else do
nonWaitMove <- handleActors lid fid
if nonWaitMove
then return True
else handle rest
killDying :: [LevelId] -> m ()
killDying = mapM_ killDyingLid
killDyingLid :: LevelId -> m ()
killDyingLid lid = do
localTime <- getsState $ getLocalTime lid
levelTime <- getsServer $ (EM.! lid) . (EM.! fid) . sactorTime
let l = filter (\(_, atime) -> atime <= localTime) $ EM.assocs levelTime
killAid (aid, _) = do
b1 <- getsState $ getActorBody aid
when (bhp b1 <= 0) $ dieSer aid b1
mapM_ killAid l
fa <- factionArena fact
arenas <- getsServer sarenas
let myArenas = case fa of
Just myArena -> myArena : delete myArena arenas
Nothing -> arenas
nonWaitMove <- handle myArenas
breakASAP <- getsServer sbreakASAP
unless breakASAP $ killDying myArenas
when nonWaitMove $ updatePerFid fid
loopUpd :: forall m. (MonadServerAtomic m, MonadServerComm m)
=> m () -> m ()
loopUpd updConn = do
let updatePerFid :: FactionId -> m ()
{-# NOINLINE updatePerFid #-}
updatePerFid fid = do
perValid <- getsServer $ (EM.! fid) . sperValidFid
mapM_ (\(lid, valid) -> unless valid $ updatePer fid lid)
(EM.assocs perValid)
handleFid :: (FactionId, Faction) -> m ()
{-# NOINLINE handleFid #-}
handleFid (fid, fact) = do
breakASAP <- getsServer sbreakASAP
unless breakASAP $ handleFidUpd updatePerFid fid fact
loopConditionally = do
factionD <- getsState sfactionD
mapM_ updatePerFid (EM.keys factionD)
modifyServer $ \ser -> ser { sbreakLoop = False
, sbreakASAP = False }
endOrLoop loopUpdConn (restartGame updConn loopUpdConn)
loopUpdConn = do
factionD <- getsState sfactionD
mapM_ handleFid $ EM.toDescList factionD
breakASAP <- getsServer sbreakASAP
breakLoop <- getsServer sbreakLoop
if breakASAP || breakLoop
then loopConditionally
else do
arenas <- getsServer sarenas
mapM_ (\fid -> mapM_ (`handleTrajectories` fid) arenas)
(EM.keys factionD)
endClip updatePerFid
breakLoop2 <- getsServer sbreakLoop
if breakLoop2
then loopConditionally
else loopUpdConn
loopUpdConn
endClip :: forall m. MonadServerAtomic m => (FactionId -> m ()) -> m ()
{-# INLINE endClip #-}
endClip updatePerFid = do
COps{corule} <- getsState scops
time <- getsState stime
let clipN = time `timeFit` timeClip
breakLoop <- getsServer sbreakLoop
unless breakLoop $ do
arenas <- getsServer sarenas
execUpdAtomic $ UpdAgeGame arenas
when (clipN `mod` rleadLevelClips corule == 0) leadLevelSwitch
case clipN `mod` clipsInTurn of
2 ->
applyPeriodicLevel
4 ->
unless (null arenas) spawnMonster
_ -> return ()
breakLoop2 <- getsServer sbreakLoop
unless breakLoop2 $ do
validArenas <- getsServer svalidArenas
unless validArenas $ do
arenasNew <- arenasForLoop
modifyServer $ \ser -> ser {sarenas = arenasNew, svalidArenas = True}
factionD <- getsState sfactionD
mapM_ updatePerFid (EM.keys factionD)
#ifndef USE_JSFILE
unless breakLoop2 $
when (clipN `mod` rwriteSaveClips corule == 0) $ writeSaveAll False
#endif
manageCalmAndDomination :: MonadServerAtomic m => ActorId -> Actor -> m ()
manageCalmAndDomination aid b = do
performedDomination <-
if bcalm b > 0 then return False else do
hiImpression <- highestImpression b
case hiImpression of
Nothing -> return False
Just (hiImpressionFid, hiImpressionK) -> do
fact <- getsState $ (EM.! bfid b) . sfactionD
if fleaderMode (gplayer fact) /= LeaderNull
|| hiImpressionK >= 10
then dominateFidSfx aid aid hiImpressionFid
else return False
unless performedDomination $ do
newCalmDelta <- getsState $ regenCalmDelta aid b
unless (newCalmDelta == 0) $
updateCalm aid newCalmDelta
applyPeriodicLevel :: MonadServerAtomic m => m ()
applyPeriodicLevel = do
arenas <- getsServer sarenas
let arenasSet = ES.fromDistinctAscList arenas
applyPeriodicItem _ _ (_, (_, [])) = return ()
applyPeriodicItem aid cstore (iid, _) = do
itemFull <- getsState $ itemToFull iid
let arItem = aspectRecordFull itemFull
when (IA.checkFlag Ability.Periodic arItem) $ do
b2 <- getsState $ getActorBody aid
bag <- getsState $ getBodyStoreBag b2 cstore
case iid `EM.lookup` bag of
Nothing -> return ()
Just (k, _) ->
effectAndDestroyAndAddKill
True aid False (k <= 1) False
aid aid iid (CActor aid cstore) True itemFull True
applyPeriodicActor (aid, b) =
when (not (bproj b) && bhp b > 0 && blid b `ES.member` arenasSet) $ do
mapM_ (applyPeriodicItem aid CEqp) $ EM.assocs $ beqp b
mapM_ (applyPeriodicItem aid COrgan) $ EM.assocs $ borgan b
manageCalmAndDomination aid b
allActors <- getsState sactorD
mapM_ applyPeriodicActor $ EM.assocs allActors
handleTrajectories :: MonadServerAtomic m => LevelId -> FactionId -> m ()
handleTrajectories lid fid = do
localTime <- getsState $ getLocalTime lid
levelTime <- getsServer $ (EM.! lid) . (EM.! fid) . strajTime
let l = sort $ map fst
$ filter (\(_, atime) -> atime <= localTime) $ EM.assocs levelTime
mapM_ hTrajectories l
breakLoop <- getsServer sbreakLoop
unless (null l || breakLoop) $
handleTrajectories lid fid
hTrajectories :: MonadServerAtomic m => ActorId -> m ()
{-# INLINE hTrajectories #-}
hTrajectories aid = do
b1 <- getsState $ getActorBody aid
let removePushed b =
modifyServer $ \ser ->
ser { strajTime =
EM.adjust (EM.adjust (EM.delete aid) (blid b)) (bfid b)
(strajTime ser)
, strajPushedBy = EM.delete aid (strajPushedBy ser) }
removeTrajectory b =
assert (not $ bproj b)
$ execUpdAtomic $ UpdTrajectory aid (btrajectory b) Nothing
breakLoop <- getsServer sbreakLoop
if breakLoop then return ()
else if actorDying b1 then dieSer aid b1
else case btrajectory b1 of
Nothing -> removePushed b1
Just ([], _) -> removeTrajectory b1 >> removePushed b1
Just{} -> do
advanceTrajectory aid b1
b2 <- getsState $ getActorBody aid
if actorDying b2
then dieSer aid b2
else case btrajectory b2 of
Nothing -> removePushed b2
Just ([], _) -> removeTrajectory b2 >> removePushed b2
Just{} ->
advanceTimeTraj aid
advanceTrajectory :: MonadServerAtomic m => ActorId -> Actor -> m ()
{-# INLINE advanceTrajectory #-}
advanceTrajectory aid b = do
COps{coTileSpeedup} <- getsState scops
lvl <- getLevel $ blid b
arTrunk <- getsState $ (EM.! btrunk b) . sdiscoAspect
case btrajectory b of
Just (d : lv, speed) -> do
let tpos = bpos b `shift` d
if | Tile.isWalkable coTileSpeedup $ lvl `at` tpos -> do
execUpdAtomic $ UpdTrajectory aid (btrajectory b) (Just (lv, speed))
when (null lv && bproj b
&& not (IA.checkFlag Ability.Blast arTrunk)) $ do
killer <- getsServer $ EM.findWithDefault aid aid . strajPushedBy
addKillToAnalytics killer KillDropLaunch (bfid b) (btrunk b)
let occupied = occupiedBigLvl tpos lvl || occupiedProjLvl tpos lvl
reqMoveHit = reqMoveGeneric False True aid d
reqDisp = reqDisplaceGeneric False aid
if | bproj b ->
reqMoveHit
| occupied ->
case (posToBigLvl tpos lvl, posToProjsLvl tpos lvl) of
(Nothing, []) -> error "advanceTrajectory: not occupied"
(Nothing, [target]) -> reqDisp target
(Nothing, _) -> reqMoveHit
(Just target, []) -> do
b2 <- getsState $ getActorBody target
fact <- getsState $ (EM.! bfid b) . sfactionD
if isFoe (bfid b) fact (bfid b2)
then reqMoveHit
else reqDisp target
(Just _, _) -> reqMoveHit
| otherwise -> reqMoveHit
| bproj b -> do
execUpdAtomic $ UpdTrajectory aid (btrajectory b) Nothing
when (not (IA.checkFlag Ability.Blast arTrunk)) $ do
killer <- getsServer $ EM.findWithDefault aid aid . strajPushedBy
addKillToAnalytics killer KillTileLaunch (bfid b) (btrunk b)
| otherwise -> do
execSfxAtomic $ SfxCollideTile aid tpos
mfail <- reqAlterFail False aid tpos
lvl2 <- getLevel $ blid b
case mfail of
Nothing | Tile.isWalkable coTileSpeedup $ lvl2 `at` tpos ->
return ()
_ -> do
execUpdAtomic $ UpdTrajectory aid (btrajectory b) Nothing
when (bhp b > oneM) $ do
execUpdAtomic $ UpdRefillHP aid minusM
let effect = IK.RefillHP (-2)
execSfxAtomic $ SfxEffect (bfid b) aid effect (-1)
_ -> error $ "Nothing or empty trajectory" `showFailure` (aid, b)
handleActors :: (MonadServerAtomic m, MonadServerComm m)
=> LevelId -> FactionId -> m Bool
handleActors lid fid = do
localTime <- getsState $ getLocalTime lid
levelTime <- getsServer $ (EM.! lid) . (EM.! fid) . sactorTime
let l = sort $ map fst
$ filter (\(_, atime) -> atime <= localTime) $ EM.assocs levelTime
mleader <- getsState $ gleader . (EM.! fid) . sfactionD
hActors $ case mleader of
Just aid | aid `elem` l -> aid : delete aid l
_ -> l
hActors :: forall m. (MonadServerAtomic m, MonadServerComm m)
=> [ActorId] -> m Bool
hActors [] = return False
hActors as@(aid : rest) = do
b1 <- getsState $ getActorBody aid
let !_A = assert (not $ bproj b1) ()
if bhp b1 <= 0 then
hActors rest
else do
let side = bfid b1
fact <- getsState $ (EM.! side) . sfactionD
breakLoop <- getsServer sbreakLoop
let mleader = gleader fact
aidIsLeader = mleader == Just aid
mainUIactor = fhasUI (gplayer fact)
&& (aidIsLeader
|| fleaderMode (gplayer fact) == LeaderNull)
mainUIunderAI = mainUIactor && isAIFact fact && not breakLoop
doQueryAI = not mainUIactor || isAIFact fact
when mainUIunderAI $ do
cmdS <- sendQueryUI side aid
case fst cmdS of
ReqUINop -> return ()
ReqUIAutomate -> execUpdAtomic $ UpdAutoFaction side False
ReqUIGameDropAndExit -> reqGameDropAndExit aid
ReqUIGameSaveAndExit -> reqGameSaveAndExit aid
_ -> error $ "" `showFailure` cmdS
breakASAP <- getsServer sbreakASAP
if breakASAP then return True else do
let mswitchLeader :: Maybe ActorId -> m ActorId
{-# NOINLINE mswitchLeader #-}
mswitchLeader (Just aidNew) = switchLeader side aidNew >> return aidNew
mswitchLeader Nothing = return aid
(aidNew, mtimed) <-
if doQueryAI then do
(cmd, maid) <- sendQueryAI side aid
aidNew <- mswitchLeader maid
mtimed <- handleRequestAI cmd
return (aidNew, mtimed)
else do
(cmd, maid) <- sendQueryUI side aid
aidNew <- mswitchLeader maid
mtimed <- handleRequestUI side aidNew cmd
return (aidNew, mtimed)
case mtimed of
Just timed -> do
nonWaitMove <- handleRequestTimed side aidNew timed
if nonWaitMove then return True else hActors rest
Nothing -> do
breakASAP2 <- getsServer sbreakASAP
if breakASAP2 then return True else hActors as
restartGame :: MonadServerAtomic m
=> m () -> m () -> Maybe (GroupName ModeKind) -> m ()
restartGame updConn loop mgameMode = do
soptionsNxt <- getsServer soptionsNxt
srandom <- getsServer srandom
s <- gameReset soptionsNxt mgameMode (Just srandom)
let optionsBarRngs = soptionsNxt {sdungeonRng = Nothing, smainRng = Nothing}
modifyServer $ \ser -> ser { soptionsNxt = optionsBarRngs
, soptions = optionsBarRngs }
execUpdAtomic $ UpdRestartServer s
updConn
initPer
reinitGame
writeSaveAll False
loop