{-# LANGUAGE GADTs #-}
module Game.LambdaHack.Server.LoopM
( loopSer
#ifdef EXPOSE_INTERNAL
, factionArena, arenasForLoop, handleFidUpd, loopUpd, endClip
, applyPeriodicLevel
, handleTrajectories, hTrajectories, handleActors, hActors
, gameExit, restartGame, writeSaveAll, setTrajectory
#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 (Config, SessionUI)
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.ClientOptions
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.Request
import Game.LambdaHack.Common.Response
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.EndM
import Game.LambdaHack.Server.Fov
import Game.LambdaHack.Server.HandleEffectM
import Game.LambdaHack.Server.HandleRequestM
import Game.LambdaHack.Server.ItemM
import Game.LambdaHack.Server.MonadServer
import Game.LambdaHack.Server.PeriodicM
import Game.LambdaHack.Server.ProtocolM
import Game.LambdaHack.Server.StartM
import Game.LambdaHack.Server.State
loopSer :: (MonadAtomic m, MonadServerReadRequest m)
=> DebugModeSer
-> Config
-> (Maybe SessionUI -> FactionId -> ChanServer -> IO ())
-> m ()
loopSer sdebug sconfig executorClient = do
cops <- getsState scops
let updConn = updateConn sconfig executorClient
restored <- tryRestore cops sdebug
case restored of
Just (sRaw, ser) | not $ snewGameSer sdebug -> do
execUpdAtomic $ UpdResumeServer $ updateCOps (const cops) sRaw
putServer ser
modifyServer $ \ser2 -> ser2 {sdebugNxt = sdebug}
applyDebug
updConn
initPer
pers <- getsServer sperFid
factionD <- getsState sfactionD
mapM_ (\fid -> sendUpdate fid $ UpdResume fid (pers EM.! fid))
(EM.keys factionD)
rngs <- getsServer srngs
when (sdumpInitRngs sdebug) $ dumpRngs rngs
_ -> do
s <- gameReset cops sdebug Nothing Nothing
let debugBarRngs = sdebug {sdungeonRng = Nothing, smainRng = Nothing}
modifyServer $ \ser -> ser { sdebugNxt = debugBarRngs
, sdebugSer = debugBarRngs }
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 :: (MonadAtomic 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. (MonadAtomic 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)
gameExit (writeSaveAll True)
else
loopUpdConn
loopUpdConn
endClip :: forall m. (MonadAtomic m, MonadServer 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 :: (MonadAtomic m, MonadServer 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 <- getsServer 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
actorAspect <- getsServer sactorAspect
let ar = actorAspect EM.! aid
newCalmDelta <- getsState $ regenCalmDelta b ar
unless (newCalmDelta == 0) $
udpateCalm aid newCalmDelta
applyPeriodicLevel :: (MonadAtomic m, MonadServer 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 <- itemToFullServer
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 :: (MonadAtomic m, MonadServer 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 :: (MonadAtomic m, MonadServer 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 :: (MonadAtomic m, MonadServer 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
execUpdAtomic $ UpdRefillHP aid minusM
Just ([], _) ->
assert (not $ bproj b)
$ execUpdAtomic $ UpdTrajectory aid (btrajectory b) Nothing
_ -> error $ "Nothing trajectory" `showFailure` (aid, b)
handleActors :: (MonadAtomic 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. (MonadAtomic 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
gameExit :: (MonadAtomic m, MonadServerReadRequest m) => m ()
gameExit = do
sperCacheFid <- getsServer sperCacheFid
sperValidFid <- getsServer sperValidFid
sactorAspect <- getsServer sactorAspect
sfovLucidLid <- getsServer sfovLucidLid
sfovClearLid <- getsServer sfovClearLid
sfovLitLid <- getsServer sfovLitLid
sperFid <- getsServer sperFid
discoAspect <- getsServer sdiscoAspect
( actorAspect, fovLitLid, fovClearLid, fovLucidLid
,perValidFid, perCacheFid, perFid )
<- getsState $ perFidInDungeon discoAspect
let !_A7 = assert (sfovLitLid == fovLitLid
`blame` "wrong accumulated sfovLitLid"
`swith` (sfovLitLid, fovLitLid)) ()
!_A6 = assert (sfovClearLid == fovClearLid
`blame` "wrong accumulated sfovClearLid"
`swith` (sfovClearLid, fovClearLid)) ()
!_A5 = assert (sactorAspect == actorAspect
`blame` "wrong accumulated sactorAspect"
`swith` (sactorAspect, actorAspect)) ()
!_A4 = assert (sfovLucidLid == fovLucidLid
`blame` "wrong accumulated sfovLucidLid"
`swith` (sfovLucidLid, fovLucidLid)) ()
!_A3 = assert (sperValidFid == perValidFid
`blame` "wrong accumulated sperValidFid"
`swith` (sperValidFid, perValidFid)) ()
!_A2 = assert (sperCacheFid == perCacheFid
`blame` "wrong accumulated sperCacheFid"
`swith` (sperCacheFid, perCacheFid)) ()
!_A1 = assert (sperFid == perFid
`blame` "wrong accumulated perception"
`swith` (sperFid, perFid)) ()
killAllClients
return ()
restartGame :: (MonadAtomic m, MonadServer m)
=> m () -> m () -> Maybe (GroupName ModeKind) -> m ()
restartGame updConn loop mgameMode = do
cops <- getsState scops
sdebugNxt <- getsServer sdebugNxt
srandom <- getsServer srandom
s <- gameReset cops sdebugNxt mgameMode (Just srandom)
let debugBarRngs = sdebugNxt {sdungeonRng = Nothing, smainRng = Nothing}
modifyServer $ \ser -> ser { sdebugNxt = debugBarRngs
, sdebugSer = debugBarRngs }
execUpdAtomic $ UpdRestartServer s
updConn
initPer
reinitGame
writeSaveAll False
loop
writeSaveAll :: (MonadAtomic m, MonadServer m) => Bool -> m ()
writeSaveAll uiRequested = do
bench <- getsServer $ sbenchmark . sdebugCli . sdebugSer
noConfirmsGame <- isNoConfirmsGame
when (uiRequested || not bench && not noConfirmsGame) $ do
execUpdAtomic UpdWriteSave
saveServer