module Game.LambdaHack.Server.LoopServer (loopSer) where
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 qualified Game.LambdaHack.Common.Effect as Effect
import Game.LambdaHack.Common.Faction
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.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.ItemServer
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)
=> DebugModeSer
-> (FactionId -> ChanServer ResponseUI RequestUI -> IO ())
-> (FactionId -> ChanServer ResponseAI RequestAI -> IO ())
-> Kind.COps
-> m ()
loopSer sdebug executorUI executorAI !cops = 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 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 loop = do
let factionArena fact = do
case gleader fact of
Just (leader, _) -> do
b <- getsState $ getActorBody leader
return $ Just $ blid b
Nothing -> return Nothing
factionD <- getsState sfactionD
marenas <- mapM factionArena $ EM.elems factionD
let arenas = ES.toList $ ES.fromList $ catMaybes marenas
assert (not $ null arenas) skip
mapM_ handleActors arenas
quit <- getsServer squit
if quit then do
modifyServer $ \ser -> ser {squit = False}
endOrLoop loop (restartGame updConn loop) gameExit (writeSaveAll True)
else do
continue <- endClip arenas
when continue loop
loop
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 processed =
EM.insertWith absoluteTimeAdd lid timeClip processed
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) leadLevelFlip
if clipMod == 1 then do
arena <- rndToAction $ oneOf arenas
activatePeriodicLevel arena
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
activatePeriodicLevel :: (MonadAtomic m, MonadServer m) => LevelId -> m ()
activatePeriodicLevel lid = do
time <- getsState $ getLocalTime lid
let turnN = time `timeFit` timeTurn
activatePeriodicItem aid (iid, itemFull) = do
case strengthFromEqpSlot Effect.EqpSlotPeriodic itemFull of
Nothing -> return ()
Just n -> when (turnN `mod` (100 `div` n) == 0) $
void $ itemEffect aid aid iid itemFull False True
activatePeriodicActor aid = do
allItems <- fullAssocsServer aid [COrgan, CEqp]
mapM_ (activatePeriodicItem aid) allItems
allActors <- getsState $ actorRegularAssocs (const True) lid
mapM_ (\(aid, _) -> activatePeriodicActor 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
isLeader (aid, b) = Just aid /= fmap fst (gleader (factionD EM.! bfid b))
order = Ord.comparing $
((>= 0) . bhp . snd) &&& bfid . snd &&& isLeader &&& 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) | maybe False (null .fst) (btrajectory b) && bproj b -> do
assert (bproj b) skip
startActor aid
dieSer aid b False
handleActors lid
Just (aid, b) | bhp b < 0 && bproj b -> do
startActor aid
dieSer aid b True
handleActors lid
Just (aid, b) | bhp b <= 0 && not (bproj b) -> do
startActor aid
dieSer aid b False
handleActors lid
Just (aid, body) -> do
startActor aid
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
timed <- setTrajectory aid
when timed $ advanceTime aid
else if queryUI then do
cmdS <- sendQueryUI side aid
aidNew <- handleRequestUI side cmdS
let hasWait (ReqUITimed ReqWait{}) = True
hasWait (ReqUILeader _ _ cmd) = hasWait cmd
hasWait _ = False
maybe skip (setBWait (hasWait cmdS)) aidNew
maybe skip advanceTime aidNew
else do
when mainUIactor $ execUpdAtomic $ UpdRecordHistory side
cmdS <- sendQueryAI side aid
aidNew <- handleRequestAI side aid cmdS
let hasWait (ReqAITimed ReqWait{}) = True
hasWait (ReqAILeader _ _ cmd) = hasWait cmd
hasWait _ = False
setBWait (hasWait cmdS) aidNew
advanceTime aidNew
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
assert (persAccumulated == pers `blame` "wrong accumulated perception"
`twith` (persAccumulated, pers)) skip
restartGame :: (MonadAtomic m, MonadServerReadRequest m)
=> m () -> m () -> m ()
restartGame updConn loop = do
tellGameClipPS
cops <- getsState scops
sdebugNxt <- getsServer sdebugNxt
srandom <- getsServer srandom
s <- gameReset cops sdebugNxt $ 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 Bool
setTrajectory aid = do
cops <- getsState scops
b <- getsState $ getActorBody aid
lvl <- getLevel $ blid b
let clearTrajectory speed = do
execUpdAtomic $ UpdRefillHP aid minusM
execUpdAtomic $ UpdTrajectory aid
(btrajectory b)
(Just ([], speed))
return $ not $ bproj b
case btrajectory b of
Just ((d : lv), speed) ->
if not $ accessibleDir cops lvl (bpos b) d
then clearTrajectory speed
else do
when (bproj b && null lv) $ do
let toColor = Color.BrBlack
when (bcolor b /= toColor) $
execUpdAtomic $ UpdColorActor aid (bcolor b) toColor
reqMove aid d
b2 <- getsState $ getActorBody aid
if actorDying b2 then return $ not $ bproj b
else do
unless (maybe False (null . fst) (btrajectory b2)) $
execUpdAtomic $ UpdTrajectory aid
(btrajectory b2)
(Just (lv, speed))
return True
Just ([], _) -> do
assert (not $ bproj b) skip
execUpdAtomic $ UpdTrajectory aid (btrajectory b) Nothing
return False
_ -> assert `failure` "Nothing trajectory" `twith` (aid, b)