module Game.LambdaHack.Server.LoopAction (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.List
import Data.Maybe
import qualified Data.Ord as Ord
import Data.Text (Text)
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.Content.ModeKind
import Game.LambdaHack.Content.RuleKind
import Game.LambdaHack.Frontend
import Game.LambdaHack.Server.Action hiding (sendUpdateAI, sendUpdateUI)
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.Frequency
loopSer :: (MonadAtomic m, MonadConnServer m)
=> DebugModeSer
-> (CmdSer -> m Bool)
-> (FactionId -> ChanFrontend -> ChanServer CmdClientUI CmdSer
-> IO ())
-> (FactionId -> ChanServer CmdClientAI CmdTakeTimeSer
-> IO ())
-> Kind.COps
-> m ()
loopSer sdebug cmdSerSem executorUI executorAI !cops = do
restored <- tryRestore cops sdebug
case restored of
Just (sRaw, ser) | not $ snewGameSer sdebug -> do
let setPreviousCops = const cops
execCmdAtomic $ ResumeServerA $ updateCOps setPreviousCops sRaw
putServer ser
sdebugNxt <- initDebug cops sdebug
modifyServer $ \ser2 -> ser2 {sdebugNxt}
applyDebug
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
_ -> 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)
execCmdAtomic $ RestartServerA $ updateCOps speedup s
updateConn executorUI executorAI
initPer
reinitGame
when (sdumpInitRngs sdebug) $ dumpRngs
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 cmdSerSem) arenas
quit <- getsServer squit
if quit then do
modifyServer $ \ser -> ser {squit = False}
endOrLoop (updateConn executorUI executorAI) loop
else do
continue <- endClip arenas
when continue loop
loop
initDebug :: MonadActionRO m => Kind.COps -> DebugModeSer -> m DebugModeSer
initDebug Kind.COps{corule} sdebugSer = do
let stdRuleset = Kind.stdRuleset corule
return $!
(\dbg -> dbg {sfovMode =
sfovMode dbg `mplus` Just (rfovMode stdRuleset)}) .
(\dbg -> dbg {ssavePrefixSer =
ssavePrefixSer dbg `mplus` Just (rsavePrefix stdRuleset)})
$ sdebugSer
endClip :: (MonadAtomic m, MonadServer m, MonadConnServer m)
=> [LevelId] -> m Bool
endClip arenas = do
Kind.COps{corule} <- getsState scops
let stdRuleset = Kind.stdRuleset corule
saveBkpClips = rsaveBkpClips stdRuleset
leadLevelClips = rleadLevelClips stdRuleset
mapM_ (\lid -> execCmdAtomic $ AgeLevelA lid timeClip) arenas
execCmdAtomic $ AgeGameA timeClip
time <- getsState stime
let clipN = time `timeFit` timeClip
clipInTurn = let r = timeTurn `timeFit` timeClip
in assert (r > 2) r
clipMod = clipN `mod` clipInTurn
bkpSave <- getsServer sbkpSave
when (bkpSave || clipN `mod` saveBkpClips == 0) $ do
modifyServer $ \ser -> ser {sbkpSave = False}
saveBkpAll False
when (clipN `mod` leadLevelClips == 0) leadLevelFlip
if clipMod == 1 then do
arena <- rndToAction $ oneOf arenas
regenerateLevelHP arena
generateMonster arena
stopAfter <- getsServer $ sstopAfter . sdebugSer
case stopAfter of
Nothing -> return True
Just stopA -> do
exit <- elapsedSessionTimeGT stopA
if exit then do
tellAllClipPS
saveAndExit
return False
else return True
else return True
handleActors :: (MonadAtomic m, MonadConnServer m)
=> (CmdSer -> m Bool)
-> LevelId
-> m ()
handleActors cmdSerSem lid = do
time <- getsState $ getLocalTime lid
Level{lprio} <- getLevel lid
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 lprio
ams = map (\a -> (a, getActorBody a s)) as
mnext | EM.null lprio = Nothing
| otherwise = if atime > time
then Nothing
else Just $ minimumBy order ams
case mnext of
_ | quit -> return ()
Nothing -> return ()
Just (aid, b) | bhp b < 0 && bproj b -> do
dieSer aid b True
handleActors cmdSerSem lid
Just (aid, b) | maybe False null (btrajectory b) -> do
assert (bproj b) skip
execSfxAtomic $ DisplayPushD (bfid b)
dieSer aid b False
handleActors cmdSerSem lid
Just (aid, b) | bhp b <= 0 && not (bproj b) -> do
dieSer aid b False
handleActors cmdSerSem lid
Just (aid, body) -> do
let side = bfid body
fact = factionD EM.! side
mleader = gleader fact
aidIsLeader = mleader == Just aid
queryUI | aidIsLeader = not $ playerAiLeader $ gplayer fact
| otherwise = not $ playerAiOther $ gplayer fact
switchLeader cmdS = do
let aidNew = aidCmdSer cmdS
bPre <- getsState $ getActorBody aidNew
let leadAtoms =
if aidNew /= aid
then
assert (aidIsLeader
&& not (bproj bPre)
&& not (isSpawnFact fact)
`blame` (aid, body, aidNew, bPre, cmdS, fact))
[LeadFactionA side mleader (Just aidNew)]
else []
mapM_ execCmdAtomic leadAtoms
assert (bfid bPre == side
`blame` "client tries to move other faction actors"
`twith` (bPre, side)) skip
return (aidNew, bPre)
setBWait (CmdTakeTimeSer WaitSer{}) aidNew bPre = do
let fromWait = bwait bPre
unless fromWait $ execCmdAtomic $ WaitActorA aidNew fromWait True
setBWait _ aidNew bPre = do
let fromWait = bwait bPre
when fromWait $ execCmdAtomic $ WaitActorA aidNew fromWait False
extraFrames bPre = do
let previousClipEnd = timeAdd time $ timeNegate timeClip
lastSingleMove = timeAddFromSpeed bPre previousClipEnd
when (btime bPre > lastSingleMove) $
broadcastSfxAtomic DisplayPushD
if bproj body then do
execSfxAtomic $ DisplayPushD side
let cmdS = CmdTakeTimeSer $ SetTrajectorySer aid
timed <- cmdSerSem cmdS
assert timed skip
b <- getsState $ getActorBody aid
unless (bhp b < 0 || maybe False null (btrajectory b)) $ do
advanceTime aid
extraFrames b
else if queryUI then do
cmdS <- sendQueryUI side aid
(aidNew, bPre) <- switchLeader cmdS
timed <-
if bhp bPre <= 0 && not (bproj bPre) then do
execSfxAtomic
$ MsgFidD side "You strain, fumble and faint from the exertion."
return False
else cmdSerSem cmdS
setBWait cmdS aidNew bPre
when timed $ advanceTime aidNew
extraFrames bPre
else do
execSfxAtomic $ DisplayPushD side
let mainUIactor = playerUI (gplayer fact) && aidIsLeader
when mainUIactor $ execSfxAtomic $ RecordHistoryD side
cmdTimed <- sendQueryAI side aid
let cmdS = CmdTakeTimeSer cmdTimed
(aidNew, bPre) <- switchLeader cmdS
assert (not (bhp bPre <= 0 && not (bproj bPre))
`blame` "AI switches to an incapacitated actor"
`twith` (cmdS, bPre, side)) skip
timed <- cmdSerSem cmdS
assert timed skip
setBWait cmdS aidNew bPre
advanceTime aidNew
extraFrames bPre
handleActors cmdSerSem lid
dieSer :: (MonadAtomic m, MonadServer m) => ActorId -> Actor -> Bool -> m ()
dieSer aid b hit = do
if bproj b then do
dropAllItems aid b hit
b2 <- getsState $ getActorBody aid
execCmdAtomic $ DestroyActorA aid b2 []
else do
electLeader (bfid b) (blid b) aid
deduceKilled b
dropAllItems aid b False
b2 <- getsState $ getActorBody aid
execCmdAtomic $ DestroyActorA aid b2 []
dropAllItems :: (MonadAtomic m, MonadServer m)
=> ActorId -> Actor -> Bool -> m ()
dropAllItems aid b hit = do
Kind.COps{coitem} <- getsState scops
discoS <- getsServer sdisco
let isDestroyed item = hit || bproj b && isFragile coitem discoS item
f iid k = do
let container = actorContainer aid (binv b) iid
item <- getsState $ getItemBody iid
if isDestroyed item then
case isExplosive coitem discoS item of
Nothing -> execCmdAtomic $ DestroyItemA iid item k container
Just cgroup -> do
let ik = fromJust $ jkind discoS item
execCmdAtomic $ DiscoverA (blid b) (bpos b) iid ik
execCmdAtomic $ DestroyItemA iid item k container
explodeItem aid b container cgroup
else
execCmdAtomic $ MoveItemA iid k container (CFloor (blid b) (bpos b))
mapActorItems_ f b
explodeItem :: (MonadAtomic m, MonadServer m)
=> ActorId -> Actor -> Container -> Text -> m ()
explodeItem aid b container cgroup = do
Kind.COps{coitem} <- getsState scops
flavour <- getsServer sflavour
discoRev <- getsServer sdiscoRev
Level{ldepth} <- getLevel $ blid b
depth <- getsState sdepth
let itemFreq = toFreq "shrapnel group" [(1, cgroup)]
(item, n1, _) <- rndToAction
$ newItem coitem flavour discoRev itemFreq ldepth depth
iid <- registerItem item n1 container False
let Point x y = bpos b
projectN n = replicateM_ n $ do
tpxy <- rndToAction $ do
border <- randomR (1, 4)
case border :: Int of
1 -> fmap (Point (x 10)) $ randomR (y 10, y + 10)
2 -> fmap (Point (x + 10)) $ randomR (y 10, y + 10)
3 -> fmap (flip Point (y 10)) $ randomR (x 10, x + 10)
4 -> fmap (flip Point (y + 10)) $ randomR (x 10, x + 10)
_ -> assert `failure` border
let eps = px tpxy + py tpxy
mfail <- projectFail aid tpxy eps iid container True
case mfail of
Nothing -> return ()
Just ProjectBlockTerrain -> return ()
Just failMsg -> execFailure aid failMsg
projectN n1
bag2 <- getsState $ bbag . getActorBody aid
let mn2 = EM.lookup iid bag2
maybe skip projectN mn2
bag3 <- getsState $ bbag . getActorBody aid
let mn3 = EM.lookup iid bag3
maybe skip (\k -> execCmdAtomic $ LoseItemA iid item k container) mn3
advanceTime :: MonadAtomic m => ActorId -> m ()
advanceTime aid = do
b <- getsState $ getActorBody aid
let t = ticksPerMeter $ bspeed b
execCmdAtomic $ AgeActorA aid t
generateMonster :: (MonadAtomic m, MonadServer m) => LevelId -> m ()
generateMonster lid = do
cops <- getsState scops
pers <- getsServer sper
lvl@Level{ldepth} <- getLevel lid
s <- getState
let f fid = isSpawnFaction fid s
spawns = actorNotProjList f lid s
depth <- getsState sdepth
rc <- rndToAction $ monsterGenChance ldepth depth (length spawns)
factionD <- getsState sfactionD
when rc $ do
time <- getsState $ getLocalTime lid
let freq = toFreq "spawn"
$ map (\(fid, fact) -> (playerSpawn $ gplayer fact, fid))
$ EM.assocs factionD
mfid <- if nullFreq freq then
return Nothing
else fmap Just $ rndToAction $ frequency freq
case mfid of
Nothing -> return ()
Just fid -> do
let allPers = ES.unions $ map (totalVisible . (EM.! lid))
$ EM.elems $ EM.delete fid pers
pos <- rndToAction $ rollSpawnPos cops allPers lid lvl fid s
spawnMonsters [pos] lid time fid
rollSpawnPos :: Kind.COps -> ES.EnumSet Point
-> LevelId -> Level -> FactionId -> State
-> Rnd Point
rollSpawnPos Kind.COps{cotile} visible
lid Level{ltile, lxsize, lysize} fid s = do
let factionDist = max lxsize lysize 5
inhabitants = actorNotProjList (/= fid) lid s
as = actorList (const True) lid s
isLit = Tile.isLit cotile
distantAtLeast d p _ =
all (\b -> chessDist (bpos b) p > d) inhabitants
findPosTry 40 ltile
( \p t -> Tile.isWalkable cotile t
&& unoccupied as p)
[ \_ 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
]
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
leadLevelFlip :: (MonadAtomic m, MonadServer m) => m ()
leadLevelFlip = do
Kind.COps{cotile} <- getsState scops
let canFlip fact = playerAiLeader (gplayer fact)
|| isSpawnFact fact
flipFaction fact | not $ canFlip fact = return ()
flipFaction fact = do
case gleader fact of
Nothing -> return ()
Just leader -> do
body <- getsState $ getActorBody leader
lvl2 <- getLevel $ blid body
let leaderStuck = waitedLastTurn body
t = lvl2 `at` bpos body
unless (not leaderStuck && Tile.isStair cotile t) $ do
actorD <- getsState sactorD
let ourLvl (lid, lvl) =
( lid
, EM.size (lfloor lvl)
, actorNotProjAssocsLvl (== bfid body) lvl actorD )
ours <- getsState $ map ourLvl . EM.assocs . sdungeon
let freqList = [ (k, (lid, a))
| (lid, itemN, (a, b) : rest) <- ours
, bhp b > 0
, not leaderStuck || lid /= blid body
, let len = 1 + (min 10 $ length rest)
k = 1000000 `div` (3 * itemN + len) ]
unless (null freqList) $ do
(lid, a) <- rndToAction $ frequency
$ toFreq "leadLevel" freqList
unless (lid == blid body) $
execCmdAtomic
$ LeadFactionA (bfid body) (Just leader) (Just a)
factionD <- getsState sfactionD
mapM_ flipFaction $ EM.elems factionD
endOrLoop :: (MonadAtomic m, MonadConnServer m) => m () -> m () -> m ()
endOrLoop updConn loopServer = do
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
(sgameMode : _, _) -> do
modifyServer $ \ser -> ser {sdebugNxt = (sdebugNxt ser) {sgameMode}}
restartGame updConn loopServer
_ | gameOver -> restartGame updConn loopServer
([], []) -> loopServer
([], _ : _) -> do
mapM_ (\(fid, fact) ->
execCmdAtomic
$ QuitFactionA fid Nothing (gquit fact) Nothing) campers
saveAndExit
saveAndExit :: (MonadAtomic m, MonadConnServer m) => m ()
saveAndExit = do
cops <- getsState scops
saveBkpAll True
killAllClients
persSaved <- getsServer sper
fovMode <- getsServer $ sfovMode . sdebugSer
pers <- getsState $ dungeonPerception cops
(fromMaybe (Digital 12) fovMode)
assert (persSaved == pers `blame` "wrong saved perception"
`twith` (persSaved, pers)) skip
restartGame :: (MonadAtomic m, MonadConnServer m)
=> m () -> m () -> m ()
restartGame updConn loopServer = 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 }
execCmdAtomic $ RestartServerA s
updConn
initPer
reinitGame
loopServer