{-# 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.ItemStrongest
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.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 $ updateCOps (const cops) sRaw
putServer ser {soptionsNxt = serverOptions}
applyDebug
factionD <- getsState sfactionD
let f fid = let cmd = UpdResumeServer $ updateCOps (const cops)
$ sclientStates ser EM.! fid
in execUpdAtomicFidCatch fid cmd
mapM_ f $ EM.keys factionD
updConn
initPer
pers <- getsServer sperFid
mapM_ (\fid -> sendUpdate fid $ UpdResume fid (pers EM.! 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)
=> Bool -> (FactionId -> m ()) -> FactionId -> Faction -> m Bool
{-# INLINE handleFidUpd #-}
handleFidUpd True _ _ _ = return True
handleFidUpd False updatePerFid fid fact = do
updatePerFid fid
fa <- factionArena fact
arenas <- getsServer sarenas
let handle [] = return False
handle (lid : rest) = do
nonWaitMove <- handleActors lid fid
swriteSave <- getsServer swriteSave
if | nonWaitMove -> return False
| swriteSave -> return True
| otherwise -> handle rest
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 :: Bool -> (FactionId, Faction) -> m Bool
{-# NOINLINE handleFid #-}
handleFid aborted (fid, fact) = handleFidUpd aborted updatePerFid fid fact
loopUpdConn = do
factionD <- getsState sfactionD
aborted <- foldM handleFid False (EM.toDescList factionD)
unless aborted $ do
arenas <- getsServer sarenas
mapM_ (\fid -> mapM_ (`handleTrajectories` fid) arenas)
(EM.keys factionD)
endClip updatePerFid
quit <- getsServer squit
if quit then do
modifyServer $ \ser -> ser {squit = False}
endOrLoop loopUpdConn (restartGame updConn loopUpdConn)
(writeSaveAll True)
else
loopUpdConn
loopUpdConn
endClip :: forall m. MonadServerAtomic m => (FactionId -> m ()) -> m ()
{-# INLINE endClip #-}
endClip updatePerFid = do
Kind.COps{corule} <- getsState scops
let RuleKind{rwriteSaveClips, rleadLevelClips} = Kind.stdRuleset corule
time <- getsState stime
let clipN = time `timeFit` timeClip
clipInTurn = let r = timeTurn `timeFit` timeClip
in assert (r >= 5) r
validArenas <- getsServer svalidArenas
unless validArenas $ do
sarenas <- arenasForLoop
modifyServer $ \ser -> ser {sarenas, svalidArenas = True}
arenas <- getsServer sarenas
quit <- getsServer squit
unless quit $ do
execUpdAtomic $ UpdAgeGame arenas
when (clipN `mod` rleadLevelClips == 0) leadLevelSwitch
case clipN `mod` clipInTurn of
2 ->
applyPeriodicLevel
4 ->
spawnMonster
_ -> return ()
factionD <- getsState sfactionD
mapM_ updatePerFid (EM.keys factionD)
when (clipN `mod` rwriteSaveClips == 0) $ writeSaveAll False
manageCalmAndDomination :: MonadServerAtomic m => ActorId -> Actor -> m ()
manageCalmAndDomination aid b = do
Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops
fact <- getsState $ (EM.! bfid b) . sfactionD
getItem <- getsState $ flip getItemBody
discoKind <- getsState sdiscoKind
let isImpression iid = case EM.lookup (jkindIx $ getItem iid) discoKind of
Just KindMean{kmKind} ->
maybe False (> 0) (lookup "impressed" $ IK.ifreq $ okind kmKind)
Nothing -> error $ "" `showFailure` iid
impressions = EM.filterWithKey (\iid _ -> isImpression iid) $ borgan b
dominated <-
if bcalm b == 0
&& not (null impressions)
&& fleaderMode (gplayer fact) /= LeaderNull
then
let f (_, (k, _)) = k
maxImpression = maximumBy (Ord.comparing f) $ EM.assocs impressions
in case jfid $ getItem $ fst maxImpression of
Nothing -> error $ "" `showFailure` impressions
Just fid1 -> assert (fid1 /= bfid b) $ dominateFidSfx fid1 aid
else return False
unless dominated $ do
ar <- getsState $ getActorAspect aid
newCalmDelta <- getsState $ regenCalmDelta b ar
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
itemToF <- getsState itemToFull
let itemFull = itemToF iid kit
case itemDisco itemFull of
Just ItemDisco {itemKind=IK.ItemKind{IK.ieffects}} ->
when (IK.Periodic `elem` ieffects) $
effectAndDestroy False aid aid iid (CActor aid cstore) True
(filterRecharging ieffects) itemFull
_ -> error $ "" `showFailure` (aid, cstore, iid)
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
s <- getState
let l = sortBy (Ord.comparing fst)
$ filter (\(_, (_, b)) -> isJust (btrajectory b) || bhp b <= 0)
$ map (\(a, atime) -> (atime, (a, getActorBody a s)))
$ filter (\(_, atime) -> atime <= localTime) $ EM.assocs levelTime
mapM_ (hTrajectories . snd) l
unless (null l) $ handleTrajectories lid fid
hTrajectories :: MonadServerAtomic m => (ActorId, Actor) -> m ()
{-# INLINE hTrajectories #-}
hTrajectories (aid, b) = do
b2 <- if actorDying b then return b else do
setTrajectory aid
getsState $ getActorBody aid
if actorDying b2 then dieSer aid b2 else advanceTime aid 100
setTrajectory :: MonadServerAtomic m => ActorId -> m ()
{-# INLINE setTrajectory #-}
setTrajectory aid = do
Kind.COps{coTileSpeedup} <- getsState scops
b <- getsState $ getActorBody aid
lvl <- getLevel $ blid b
case btrajectory b of
Just (d : lv, speed) ->
if Tile.isWalkable coTileSpeedup $ lvl `at` (bpos b `shift` d)
then do
let tpos = bpos b `shift` d
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
refillHP False aid b minusM
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
factionD <- getsState sfactionD
s <- getState
let notLeader (aid, b) = Just aid /= gleader (factionD EM.! bfid b)
l = sortBy (Ord.comparing notLeader)
$ filter (\(_, b) -> isNothing (btrajectory b) && bhp b > 0)
$ map (\(a, _) -> (a, getActorBody a s))
$ filter (\(_, atime) -> atime <= localTime) $ EM.assocs levelTime
hActors fid l
hActors :: forall m. (MonadServerAtomic m, MonadServerReadRequest m)
=> FactionId -> [(ActorId, Actor)] -> m Bool
hActors _ [] = return False
hActors _fid as@((aid, body) : rest) = do
let side = bfid body
!_A = assert (side == _fid) ()
fact <- getsState $ (EM.! side) . sfactionD
squit <- getsServer squit
let mleader = gleader fact
aidIsLeader = mleader == Just aid
mainUIactor = fhasUI (gplayer fact)
&& (aidIsLeader
|| fleaderMode (gplayer fact) == LeaderNull)
mainUIunderAI = mainUIactor && isAIFact fact && not squit
doQueryAI = not mainUIactor || isAIFact fact
when mainUIunderAI $ do
cmdS <- sendQueryUI side aid
case fst cmdS of
ReqUINop -> return ()
ReqUIAutomate -> execUpdAtomic $ UpdAutoFaction side False
ReqUIGameExit -> do
reqGameExit aid
modifyServer $ \ser -> ser {swriteSave = False}
_ -> error $ "" `showFailure` cmdS
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 side rest
Nothing -> do
swriteSave <- getsServer swriteSave
if swriteSave then return False else hActors side 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