{-# LANGUAGE GADTs #-}
module Game.LambdaHack.Server.LoopM
( loopSer
#ifdef EXPOSE_INTERNAL
, factionArena, arenasForLoop, handleFidUpd, loopUpd, endClip
, manageCalmAndDomination, applyPeriodicLevel
, handleTrajectories, hTrajectories, setTrajectory
, handleActors, hActors, restartGame
#endif
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import qualified Data.Ord as Ord
import Game.LambdaHack.Atomic
import Game.LambdaHack.Client
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
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.Perception
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Common.Vector
import qualified Game.LambdaHack.Content.ItemKind as IK
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.RuleKind
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, MonadServerReadRequest 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)
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 -> if fleaderMode (gplayer fact) == LeaderNull
|| EM.null (gvictims fact)
then return Nothing
else Just <$> getEntryArena fact
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 :: (MonadServerAtomic m, MonadServerReadRequest m)
=> (FactionId -> m ()) -> FactionId -> Faction -> m ()
{-# INLINE handleFidUpd #-}
handleFidUpd updatePerFid fid fact = do
updatePerFid fid
let handle [] = return ()
handle (lid : rest) = do
breakASAP <- getsServer sbreakASAP
unless breakASAP $ do
nonWaitMove <- handleActors lid fid
unless nonWaitMove $ handle rest
fa <- factionArena fact
arenas <- getsServer sarenas
let myArenas = case fa of
Just myArena -> myArena : delete myArena arenas
Nothing -> arenas
handle myArenas
loopUpd :: forall m. (MonadServerAtomic m, MonadServerReadRequest 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) = 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 <- getsState scops
let rules = getStdRuleset cops
time <- getsState stime
let clipN = time `timeFit` timeClip
clipInTurn = let r = timeTurn `timeFit` timeClip
in assert (r >= 5) r
breakLoop <- getsServer sbreakLoop
unless breakLoop $ do
arenas <- getsServer sarenas
execUpdAtomic $ UpdAgeGame arenas
when (clipN `mod` rleadLevelClips rules == 0) leadLevelSwitch
let clipMod = clipN `mod` clipInTurn
if | clipMod == clipInTurn - 1 ->
applyPeriodicLevel
| clipMod == 2 ->
unless (null arenas) spawnMonster
| otherwise -> 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 rules == 0) $ writeSaveAll False
#endif
manageCalmAndDomination :: MonadServerAtomic m => ActorId -> Actor -> m ()
manageCalmAndDomination aid b = do
fact <- getsState $ (EM.! bfid b) . sfactionD
hiImpression <- highestImpression aid
dominated <-
if bcalm b == 0
&& fleaderMode (gplayer fact) /= LeaderNull
then maybe (return False) (dominateFidSfx aid) hiImpression
else return False
unless dominated $ do
newCalmDelta <- getsState $ regenCalmDelta aid b
unless (newCalmDelta == 0) $
udpateCalm aid newCalmDelta
applyPeriodicLevel :: MonadServerAtomic m => m ()
applyPeriodicLevel = do
arenas <- getsServer sarenas
let arenasSet = ES.fromDistinctAscList arenas
applyPeriodicItem _ _ _ (_, (_, [])) = return ()
applyPeriodicItem aid cstore getStore (iid, _) = do
bag <- getsState $ getStore . getActorBody aid
case iid `EM.lookup` bag of
Nothing -> return ()
Just kit -> do
itemFull@ItemFull{itemKind} <- getsState $ itemToFull iid
when (IK.Periodic `elem` IK.ifeature itemKind) $
effectAndDestroy False aid aid iid (CActor aid cstore) True
(IK.filterRecharging $ IK.ieffects itemKind)
(itemFull, kit)
applyPeriodicActor (aid, b) =
when (not (bproj b) && blid b `ES.member` arenasSet) $ do
mapM_ (applyPeriodicItem aid COrgan borgan) $ EM.assocs $ borgan b
mapM_ (applyPeriodicItem aid CEqp beqp) $ EM.assocs $ beqp 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) . sactorTime
getActorB <- getsState $ flip getActorBody
let l = map (fst . snd)
$ sortBy (Ord.comparing fst)
$ filter (\(_, (_, b)) -> isJust (btrajectory b) || bhp b <= 0)
$ map (\(a, atime) -> (atime, (a, getActorB a)))
$ filter (\(_, atime) -> atime <= localTime) $ EM.assocs levelTime
mapM_ hTrajectories l
unless (null l) $ handleTrajectories lid fid
hTrajectories :: MonadServerAtomic m => ActorId -> m ()
{-# INLINE hTrajectories #-}
hTrajectories aid = do
b1 <- getsState $ getActorBody aid
if | actorDying b1 -> dieSer aid b1
| isJust (btrajectory b1) -> do
setTrajectory aid b1
b2 <- getsState $ getActorBody aid
if actorDying b2 then dieSer aid b2 else advanceTime aid 100 False
| otherwise -> return ()
setTrajectory :: MonadServerAtomic m => ActorId -> Actor -> m ()
{-# INLINE setTrajectory #-}
setTrajectory aid b = do
COps{coTileSpeedup} <- getsState scops
lvl <- getLevel $ blid b
case btrajectory b of
Just (d : lv, speed) -> do
let tpos = bpos b `shift` d
if Tile.isWalkable coTileSpeedup $ lvl `at` tpos
then do
case posToAidsLvl tpos lvl of
[target] | not (bproj b) -> reqDisplace aid target
_ -> reqMove aid d
b2 <- getsState $ getActorBody aid
unless ((fst <$> btrajectory b2) == Just []) $
execUpdAtomic $ UpdTrajectory aid (btrajectory b2) (Just (lv, speed))
else do
execUpdAtomic $ UpdTrajectory aid (btrajectory b) Nothing
if bproj b then
when (bhp b > oneM) $
execUpdAtomic $ UpdRefillHP aid minusM
else do
execSfxAtomic $ SfxCollideTile aid tpos
mfail <- reqAlterFail aid tpos
case mfail of
Nothing -> return ()
Just{} ->
when (bhp b > oneM) $ do
execUpdAtomic $ UpdRefillHP aid minusM
let effect = IK.RefillHP (-2)
execSfxAtomic $ SfxEffect (bfid b) aid effect (-1)
Just ([], _) ->
assert (not $ bproj b)
$ execUpdAtomic $ UpdTrajectory aid (btrajectory b) Nothing
_ -> error $ "Nothing trajectory" `showFailure` (aid, b)
handleActors :: (MonadServerAtomic m, MonadServerReadRequest m)
=> LevelId -> FactionId -> m Bool
handleActors lid fid = do
localTime <- getsState $ getLocalTime lid
levelTime <- getsServer $ (EM.! lid) . (EM.! fid) . sactorTime
getActorB <- getsState $ flip getActorBody
let l = map (fst . snd)
$ sortBy (Ord.comparing fst)
$ filter (\(_, (_, b)) -> isNothing (btrajectory b) && bhp b > 0)
$ map (\(a, atime) -> (atime, (a, getActorB a)))
$ 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, MonadServerReadRequest m)
=> [ActorId] -> m Bool
hActors [] = return False
hActors as@(aid : rest) = do
b1 <- getsState $ getActorBody aid
let side = bfid b1
!_A = assert (not $ bproj 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 (RequestAnyAbility 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