module Game.LambdaHack.Server.LoopAction (loopSer) where
import Control.Arrow ((&&&))
import Control.Monad
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.List
import Data.Maybe
import qualified Data.Ord as Ord
import Game.LambdaHack.Common.Action
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.AtomicCmd
import Game.LambdaHack.Common.ClientCmd
import Game.LambdaHack.Common.Faction
import qualified Game.LambdaHack.Common.Feature as F
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.Random
import Game.LambdaHack.Common.ServerCmd
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Content.ActorKind
import Game.LambdaHack.Frontend
import Game.LambdaHack.Server.Action hiding (sendUpdateAI, sendUpdateUI)
import Game.LambdaHack.Server.Config
import Game.LambdaHack.Server.EffectSem
import Game.LambdaHack.Server.Fov
import Game.LambdaHack.Server.ServerSem
import Game.LambdaHack.Server.StartAction
import Game.LambdaHack.Server.State
import Game.LambdaHack.Utils.Assert
loopSer :: (MonadAtomic m, MonadConnServer m)
=> DebugModeSer
-> (CmdSer -> m Bool)
-> (FactionId -> ChanFrontend -> ChanServer CmdClientUI -> IO ())
-> (FactionId -> ChanServer CmdClientAI -> IO ())
-> Kind.COps
-> m ()
loopSer sdebugNxt cmdSerSem executorUI executorAI !cops = do
restored <- tryRestore cops
case restored of
Nothing -> do
modifyServer $ \ser -> ser {sdebugNxt}
s <- gameReset cops
let speedup = speedupCOps (sallClear sdebugNxt)
execCmdAtomic $ RestartServerA $ updateCOps speedup s
applyDebug sdebugNxt
updateConn executorUI executorAI
initPer
reinitGame
saveBkpAll
Just (sRaw, ser) -> do
let setPreviousCops = const cops
execCmdAtomic $ ResumeServerA $ updateCOps setPreviousCops sRaw
putServer ser {sdebugNxt}
applyDebug sdebugNxt
updateConn executorUI executorAI
initPer
pers <- getsServer sper
broadcastCmdAtomic $ \fid -> ResumeA fid (pers EM.! fid)
let setCurrentCops = const (speedupCOps (sallClear sdebugNxt) cops)
execCmdAtomic $ ResumeServerA $ updateCOps setCurrentCops sRaw
initPer
let loop = do
let factionArena fact = do
let spawn = isSpawnFact cops fact
isHuman = isHumanFact fact
case gleader fact of
Just leader | isHuman || not spawn -> do
b <- getsState $ getActorBody leader
return $ Just $ blid b
_ -> 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 cmdSerSem) arenas
quit <- getsServer squit
if quit then do
modifyServer $ \ser -> ser {squit = False}
endOrLoop (updateConn executorUI executorAI) loop
else do
endClip arenas
loop
loop
saveBkpAll :: (MonadAtomic m, MonadServer m) => m ()
saveBkpAll = do
execCmdAtomic SaveBkpA
saveGameBkp
endClip :: (MonadAtomic m, MonadServer m) => [LevelId] -> m ()
endClip arenas = do
time <- getsState stime
Config{configSaveBkpClips} <- getsServer sconfig
let clipN = time `timeFit` timeClip
cinT = let r = timeTurn `timeFit` timeClip
in assert (r > 2) r
bkpFreq = cinT * configSaveBkpClips
clipMod = clipN `mod` cinT
bkpSave <- getsServer sbkpSave
when (bkpSave || clipN `mod` bkpFreq == 0) $ do
modifyServer $ \ser -> ser {sbkpSave = False}
execCmdAtomic SaveBkpA
saveGameBkp
when (clipMod == 1) $ do
arena <- rndToAction $ oneOf arenas
regenerateLevelHP arena
generateMonster arena
mapM_ (\lid -> execCmdAtomic $ AgeLevelA lid timeClip) arenas
execCmdAtomic $ AgeGameA timeClip
handleActors :: (MonadAtomic m, MonadConnServer m)
=> (CmdSer -> m Bool)
-> LevelId
-> m ()
handleActors cmdSerSem lid = do
Kind.COps{coactor} <- getsState scops
time <- getsState $ getLocalTime lid
prio <- getsLevel lid lprio
quit <- getsServer squit
factionD <- getsState sfactionD
s <- getState
let
isLeader (aid, b) = Just aid /= gleader (factionD EM.! bfid b)
order = Ord.comparing $
((>= 0) . bhp . snd) &&& bfid . snd &&& isLeader &&& bsymbol . snd
(atime, as) = EM.findMin prio
ams = map (\a -> (a, getActorBody a s)) as
mnext | EM.null prio = Nothing
| otherwise = if atime > time
then Nothing
else Just $ minimumBy order ams
case mnext of
_ | quit -> return ()
Nothing -> return ()
Just (aid, b) | bproj b && bhp b < 0 -> do
ais <- getsState $ getActorItem aid
execCmdAtomic $ DestroyActorA aid b ais
handleActors cmdSerSem lid
Just (aid, b) | bhp b <= 0 && not (bproj b)
|| maybe False null (bpath b) -> do
dieSer aid
handleActors cmdSerSem lid
Just (aid, body) -> do
let side = bfid body
fact = factionD EM.! side
mleader = gleader fact
usesAI = usesAIFact fact
hasHumanLeader = isNothing $ gAiLeader fact
queryUI = not usesAI || hasHumanLeader && Just aid == mleader
cmdS <- if queryUI then
sendQueryUI side aid
else do
execSfxAtomic $ DisplayPushD side
sendQueryAI side aid
let leaderNew = aidCmdSer cmdS
leadAtoms =
if leaderNew /= aid
then
assert (mleader == Just aid)
[LeadFactionA side mleader (Just leaderNew)]
else []
mapM_ execCmdAtomic leadAtoms
bPre <- getsState $ getActorBody leaderNew
assert (bfid bPre == side `blame` (bPre, side)) skip
timed <-
if bhp bPre <= 0 && not (bproj bPre)
then execFailure side "You strain, fumble and faint from the exertion."
else cmdSerSem cmdS
assert (queryUI || timed `blame` (cmdS, timed, bPre)) skip
when timed $ advanceTime leaderNew
let previousClipEnd = timeAdd time $ timeNegate timeClip
lastSingleMove = timeAddFromSpeed coactor bPre previousClipEnd
when (btime bPre > lastSingleMove) $
broadcastSfxAtomic DisplayPushD
handleActors cmdSerSem lid
dieSer :: (MonadAtomic m, MonadServer m) => ActorId -> m ()
dieSer aid = do
body <- getsState $ getActorBody aid
electLeader (bfid body) (blid body) aid
dropAllItems aid body
execCmdAtomic $ DestroyActorA aid body {bbag = EM.empty} []
deduceKilled body
dropAllItems :: MonadAtomic m => ActorId -> Actor -> m ()
dropAllItems aid b = do
let f iid k = execCmdAtomic
$ MoveItemA iid k (actorContainer aid (binv b) iid)
(CFloor (blid b) (bpos b))
mapActorItems_ f b
advanceTime :: MonadAtomic m => ActorId -> m ()
advanceTime aid = do
Kind.COps{coactor} <- getsState scops
b <- getsState $ getActorBody aid
unless (bhp b < 0 && bproj b || maybe False null (bpath b)) $ do
let speed = actorSpeed coactor b
t = ticksPerMeter speed
execCmdAtomic $ AgeActorA aid t
generateMonster :: (MonadAtomic m, MonadServer m) => LevelId -> m ()
generateMonster lid = do
cops <- getsState scops
pers <- getsServer sper
lvl@Level{ldepth} <- getsLevel lid id
s <- getState
let f fid = isSpawnFaction fid s
spawns = actorNotProjList f lid s
depth <- getsState sdepth
rc <- rndToAction $ monsterGenChance ldepth depth (length spawns)
when rc $ do
let allPers = ES.unions $ map (totalVisible . (EM.! lid)) $ EM.elems pers
pos <- rndToAction $ rollSpawnPos cops allPers lid lvl s
time <- getsState $ getLocalTime lid
spawnMonsters [pos] lid (const True) time "spawn"
rollSpawnPos :: Kind.COps -> ES.EnumSet Point -> LevelId -> Level -> State
-> Rnd Point
rollSpawnPos Kind.COps{cotile} visible lid Level{ltile, lxsize, lysize} s = do
let factionDist = max lxsize lysize 5
inhabitants = actorNotProjList (const True) lid s
isLit = Tile.isLit cotile
distantAtLeast d p _ =
all (\b -> chessDist lxsize (bpos b) p > d) inhabitants
findPosTry 40 ltile
[ \ _ t -> not (isLit t)
, distantAtLeast factionDist
, distantAtLeast $ factionDist `div` 2
, \ p _ -> not $ p `ES.member` visible
, distantAtLeast $ factionDist `div` 3
, \ _ t -> Tile.hasFeature cotile F.CanActor t
, distantAtLeast $ factionDist `div` 4
, distantAtLeast 3
, \ p t -> Tile.hasFeature cotile F.Walkable t
&& unoccupied (actorList (const True) lid s) p
]
regenerateLevelHP :: MonadAtomic m => LevelId -> m ()
regenerateLevelHP lid = do
Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops
time <- getsState $ getLocalTime lid
s <- getState
let approve (a, m) =
let ak = okind $ bkind m
itemAssocs = getActorItem a s
regen = max 1 $
aregen ak `div`
case strongestRegen itemAssocs of
Just (k, _) -> k + 1
Nothing -> 1
bhpMax = maxDice (ahp ak)
deltaHP = min 1 (bhpMax bhp m)
in if (time `timeFit` timeTurn) `mod` regen /= 0
|| deltaHP <= 0
|| bhp m <= 0
then Nothing
else Just a
toRegen <-
getsState $ mapMaybe approve . actorNotProjAssocs (const True) lid
mapM_ (\aid -> execCmdAtomic $ HealActorA aid 1) toRegen
endOrLoop :: (MonadAtomic m, MonadConnServer m) => m () -> m () -> m ()
endOrLoop updConn loopServer = do
cops <- getsState scops
factionD <- getsState sfactionD
let inGame fact = case gquit fact of
Nothing -> True
Just Status{stOutcome=Camping} -> True
_ -> False
gameOver = not $ any inGame $ EM.elems factionD
let getQuitter fact = case gquit fact of
Just Status{stOutcome=Restart, stInfo} -> Just stInfo
_ -> Nothing
quitters = mapMaybe getQuitter $ EM.elems factionD
let isCamper fact = case gquit fact of
Just Status{stOutcome=Camping} -> True
_ -> False
campers = filter (isCamper . snd) $ EM.assocs factionD
case (quitters, campers) of
(t : _, _) -> do
modifyServer $ \ser -> ser {scenario = t}
restartGame updConn loopServer
_ | gameOver -> restartGame updConn loopServer
(_, []) -> loopServer
(_, _ : _) -> do
mapM_ (\(fid, fact) ->
execCmdAtomic
$ QuitFactionA fid Nothing (gquit fact) Nothing) campers
execCmdAtomic SaveExitA
saveGameSer
killAllClients
persSaved <- getsServer sper
configFov <- fovMode
pers <- getsState $ dungeonPerception cops configFov
assert (persSaved == pers `blame` (persSaved, pers)) skip
restartGame :: (MonadAtomic m, MonadConnServer m)
=> m () -> m () -> m ()
restartGame updConn loopServer = do
cops <- getsState scops
s <- gameReset cops
execCmdAtomic $ RestartServerA s
updConn
initPer
reinitGame
saveBkpAll
loopServer