module Game.LambdaHack.Server.LoopServer (loopSer) where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Exception.Assert.Sugar
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 Game.LambdaHack.Atomic
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.ClientOptions
import qualified Game.LambdaHack.Common.Color as Color
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.Random
import Game.LambdaHack.Common.Request
import Game.LambdaHack.Common.Response
import Game.LambdaHack.Common.State
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.EndServer
import Game.LambdaHack.Server.Fov
import Game.LambdaHack.Server.HandleEffectServer
import Game.LambdaHack.Server.HandleRequestServer
import Game.LambdaHack.Server.MonadServer
import Game.LambdaHack.Server.PeriodicServer
import Game.LambdaHack.Server.ProtocolServer
import Game.LambdaHack.Server.StartServer
import Game.LambdaHack.Server.State
loopSer :: (MonadAtomic m, MonadServerReadRequest m)
=> Kind.COps
-> DebugModeSer
-> (FactionId -> ChanServer ResponseUI RequestUI -> IO ())
-> (FactionId -> ChanServer ResponseAI RequestAI -> IO ())
-> m ()
loopSer cops sdebug executorUI executorAI = do
let updConn = updateConn executorUI executorAI
restored <- tryRestore cops sdebug
case restored of
Just (sRaw, ser) | not $ snewGameSer sdebug -> do
let setPreviousCops = const cops
execUpdAtomic $ UpdResumeServer $ updateCOps setPreviousCops sRaw
putServer ser
sdebugNxt <- initDebug cops sdebug
modifyServer $ \ser2 -> ser2 {sdebugNxt}
applyDebug
updConn
initPer
pers <- getsServer sper
broadcastUpdAtomic $ \fid -> UpdResume fid (pers EM.! fid)
let setCurrentCops = const (speedupCOps (sallClear sdebugNxt) cops)
execUpdAtomic $ UpdResumeServer $ updateCOps setCurrentCops sRaw
when (sdumpInitRngs sdebug) dumpRngs
_ -> do
let mrandom = case restored of
Just (_, ser) -> Just $ srandom ser
Nothing -> Nothing
s <- gameReset cops sdebug Nothing mrandom
sdebugNxt <- initDebug cops sdebug
let debugBarRngs = sdebugNxt {sdungeonRng = Nothing, smainRng = Nothing}
modifyServer $ \ser -> ser { sdebugNxt = debugBarRngs
, sdebugSer = debugBarRngs }
let speedup = speedupCOps (sallClear sdebugNxt)
execUpdAtomic $ UpdRestartServer $ updateCOps speedup s
updConn
initPer
reinitGame
writeSaveAll False
resetSessionStart
let arenasForLoop = do
let 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
factionD <- getsState sfactionD
marenas <- mapM factionArena $ EM.elems factionD
let arenas = ES.toList $ ES.fromList $ catMaybes marenas
let !_A = assert (not $ null arenas) ()
return $! arenas
let loop arenasStart [] = do
arenas <- arenasForLoop
continue <- endClip arenasStart
when continue (loop arenas arenas)
loop arenasStart (arena : rest) = do
handleActors arena
quit <- getsServer squit
if quit then do
modifyServer $ \ser -> ser {squit = False}
let loopAgain = loop arenasStart (arena : rest)
endOrLoop loopAgain
(restartGame updConn loopNew) gameExit (writeSaveAll True)
else
loop arenasStart rest
loopNew = do
arenas <- arenasForLoop
loop arenas arenas
loopNew
endClip :: (MonadAtomic m, MonadServer m, MonadServerReadRequest m)
=> [LevelId] -> m Bool
endClip arenas = do
Kind.COps{corule} <- getsState scops
let stdRuleset = Kind.stdRuleset corule
writeSaveClips = rwriteSaveClips stdRuleset
leadLevelClips = rleadLevelClips stdRuleset
ageProcessed lid = EM.insertWith absoluteTimeAdd lid timeClip
ageServer lid ser = ser {sprocessed = ageProcessed lid $ sprocessed ser}
mapM_ (modifyServer . ageServer) arenas
execUpdAtomic $ UpdAgeGame (Delta timeClip) arenas
time <- getsState stime
let clipN = time `timeFit` timeClip
clipInTurn = let r = timeTurn `timeFit` timeClip
in assert (r > 2) r
clipMod = clipN `mod` clipInTurn
when (clipN `mod` writeSaveClips == 0) $ do
modifyServer $ \ser -> ser {swriteSave = False}
writeSaveAll False
when (clipN `mod` leadLevelClips == 0) leadLevelSwitch
if clipMod == 1 then do
mapM_ applyPeriodicLevel arenas
arena <- rndToAction $ oneOf arenas
spawnMonster arena
stopAfter <- getsServer $ sstopAfter . sdebugSer
case stopAfter of
Nothing -> return True
Just stopA -> do
exit <- elapsedSessionTimeGT stopA
if exit then do
tellAllClipPS
gameExit
return False
else return True
else return True
applyPeriodicLevel :: (MonadAtomic m, MonadServer m) => LevelId -> m ()
applyPeriodicLevel lid = do
discoEffect <- getsServer sdiscoEffect
let applyPeriodicItem c aid iid =
case EM.lookup iid discoEffect of
Just ItemAspectEffect{jeffects, jaspects} ->
when (IK.Periodic `elem` jaspects) $ do
bag <- getsState $ getCBag c
case iid `EM.lookup` bag of
Nothing -> return ()
Just kit ->
effectAndDestroy aid aid iid c True
(allRecharging jeffects) jaspects kit
_ -> assert `failure` (lid, aid, c, iid)
applyPeriodicCStore aid cstore = do
let c = CActor aid cstore
bag <- getsState $ getCBag c
mapM_ (applyPeriodicItem c aid) $ EM.keys bag
applyPeriodicActor aid = do
applyPeriodicCStore aid COrgan
applyPeriodicCStore aid CEqp
allActors <- getsState $ actorRegularAssocs (const True) lid
mapM_ (\(aid, _) -> applyPeriodicActor aid) allActors
handleActors :: (MonadAtomic m, MonadServerReadRequest m)
=> LevelId -> m ()
handleActors lid = do
timeCutOff <- getsServer $ EM.findWithDefault timeClip lid . sprocessed
Level{lprio} <- getLevel lid
quit <- getsServer squit
factionD <- getsState sfactionD
s <- getState
let
notDead (_, b) = not $ actorDying b
notProj (_, b) = not $ bproj b
notLeader (aid, b) = Just aid /= fmap fst (gleader (factionD EM.! bfid b))
order = Ord.comparing $
notDead &&& notProj &&& bfid . snd &&& notLeader &&& bsymbol . snd
(atime, as) = EM.findMin lprio
ams = map (\a -> (a, getActorBody a s)) as
mnext | EM.null lprio = Nothing
| otherwise = if atime > timeCutOff
then Nothing
else Just $ minimumBy order ams
startActor aid = execSfxAtomic $ SfxActorStart aid
case mnext of
_ | quit -> return ()
Nothing -> return ()
Just (aid, b) | bproj b && maybe True (null . fst) (btrajectory b) -> do
startActor aid
dieSer aid b False
handleActors lid
Just (aid, b) | bhp b <= 0 -> do
startActor aid
dieSer aid b (bproj b)
handleActors lid
Just (aid, body) -> do
let side = bfid body
fact = factionD EM.! side
mleader = gleader fact
aidIsLeader = fmap fst mleader == Just aid
mainUIactor = fhasUI (gplayer fact)
&& (aidIsLeader
|| fleaderMode (gplayer fact) == LeaderNull)
queryUI <-
if mainUIactor then do
let underAI = isAIFact fact
if underAI then do
sendPingUI side
fact2 <- getsState $ (EM.! side) . sfactionD
let underAI2 = isAIFact fact2
return $! not underAI2
else return True
else return False
let setBWait hasWait aidNew = do
bPre <- getsState $ getActorBody aidNew
when (hasWait /= bwait bPre) $
execUpdAtomic $ UpdWaitActor aidNew hasWait
if isJust $ btrajectory body then do
setTrajectory aid
b2 <- getsState $ getActorBody aid
unless (bproj b2 && actorDying b2) $
advanceTime aid
else if queryUI then do
cmdS <- sendQueryUI side aid
(aidNew, action) <- handleRequestUI side cmdS
let hasWait (ReqUITimed ReqWait{}) = True
hasWait (ReqUILeader _ _ cmd) = hasWait cmd
hasWait _ = False
maybe (return ()) (setBWait (hasWait cmdS)) aidNew
when (aidIsLeader && Just aid /= aidNew) $
maybe (return ()) (swapTime aid) aidNew
maybe (return ()) advanceTime aidNew
action
maybe (return ()) managePerTurn aidNew
else do
when mainUIactor $ execUpdAtomic $ UpdRecordHistory side
cmdS <- sendQueryAI side aid
(aidNew, action) <- handleRequestAI side aid cmdS
let hasWait (ReqAITimed ReqWait{}) = True
hasWait (ReqAILeader _ _ cmd) = hasWait cmd
hasWait _ = False
setBWait (hasWait cmdS) aidNew
advanceTime aidNew
action
managePerTurn aidNew
b3 <- getsState $ getActorBody aid
unless (waitedLastTurn b3) $ startActor aid
handleActors lid
gameExit :: (MonadAtomic m, MonadServerReadRequest m) => m ()
gameExit = do
killAllClients
persAccumulated <- getsServer sper
fovMode <- getsServer $ sfovMode . sdebugSer
ser <- getServer
pers <- getsState $ \s -> dungeonPerception (fromMaybe Digital fovMode) s ser
let !_A = assert (persAccumulated == pers
`blame` "wrong accumulated perception"
`twith` (persAccumulated, pers)) ()
return ()
restartGame :: (MonadAtomic m, MonadServerReadRequest m)
=> m () -> m () -> Maybe (GroupName ModeKind) -> m ()
restartGame updConn loop mgameMode = do
tellGameClipPS
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, MonadServerReadRequest m) => Bool -> m ()
writeSaveAll uiRequested = do
bench <- getsServer $ sbenchmark . sdebugCli . sdebugSer
when (uiRequested || not bench) $ do
factionD <- getsState sfactionD
let ping fid _ = do
sendPingAI fid
when (fhasUI $ gplayer $ factionD EM.! fid) $ sendPingUI fid
mapWithKeyM_ ping factionD
execUpdAtomic UpdWriteSave
saveServer
setTrajectory :: (MonadAtomic m, MonadServer m) => ActorId -> m ()
setTrajectory aid = do
cops <- getsState scops
b <- getsState $ getActorBody aid
lvl <- getLevel $ blid b
case btrajectory b of
Just (d : lv, speed) ->
if not $ accessibleDir cops lvl (bpos b) d
then do
execUpdAtomic $ UpdRefillHP aid minusM
execUpdAtomic $ UpdTrajectory aid
(btrajectory b)
(Just ([], speed))
else do
when (bproj b && null lv) $ do
let toColor = Color.BrBlack
when (bcolor b /= toColor) $
execUpdAtomic $ UpdColorActor aid (bcolor b) toColor
let tpos = bpos b `shift` d
tgt <- getsState $ posToActors tpos (blid b)
case tgt of
[(target, _)] | not (bproj b) -> reqDisplace aid target
_ -> reqMove aid d
b2 <- getsState $ getActorBody aid
unless (btrajectory b2 == Just (lv, speed)) $
execUpdAtomic $ UpdTrajectory aid (btrajectory b2) (Just (lv, speed))
Just ([], _) -> do
let !_A = assert (not $ bproj b) ()
execUpdAtomic $ UpdTrajectory aid (btrajectory b) Nothing
_ -> assert `failure` "Nothing trajectory" `twith` (aid, b)