{-# LANGUAGE TupleSections #-}
module Game.LambdaHack.Server.CommonM
( execFailure, getPerFid
, revealItems, moveStores, deduceQuits, deduceKilled
, electLeader, supplantLeader
, addActor, registerActor, addActorIid, projectFail, discoverIfNoEffects
, pickWeaponServer, currentSkillsServer
, recomputeCachePer
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import qualified Data.EnumMap.Strict as EM
import qualified Data.Text as T
import qualified Text.Show.Pretty as Show.Pretty
import Game.LambdaHack.Atomic
import qualified Game.LambdaHack.Common.Ability as Ability
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
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.Perception
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.Random
import Game.LambdaHack.Common.Request
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Content.ItemKind (ItemKind)
import qualified Game.LambdaHack.Content.ItemKind as IK
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.RuleKind
import Game.LambdaHack.Server.Fov
import Game.LambdaHack.Server.ItemM
import Game.LambdaHack.Server.ItemRev
import Game.LambdaHack.Server.MonadServer
import Game.LambdaHack.Server.State
execFailure :: (MonadAtomic m, MonadServer m)
=> ActorId -> RequestTimed a -> ReqFailure -> m ()
execFailure aid req failureSer = do
body <- getsState $ getActorBody aid
let fid = bfid body
msg = showReqFailure failureSer
impossible = impossibleReqFailure failureSer
debugShow :: Show a => a -> Text
debugShow = T.pack . Show.Pretty.ppShow
possiblyAlarm = if impossible
then debugPossiblyPrintAndExit
else debugPossiblyPrint
possiblyAlarm $
"execFailure:" <+> msg <> "\n"
<> debugShow body <> "\n" <> debugShow req <> "\n" <> debugShow failureSer
execSfxAtomic $ SfxMsgFid fid $ SfxUnexpected failureSer
getPerFid :: MonadServer m => FactionId -> LevelId -> m Perception
getPerFid fid lid = do
pers <- getsServer sperFid
let failFact = error $ "no perception for faction" `showFailure` (lid, fid)
fper = EM.findWithDefault failFact fid pers
failLvl = error $ "no perception for level" `showFailure` (lid, fid)
per = EM.findWithDefault failLvl lid fper
return $! per
revealItems :: (MonadAtomic m, MonadServer m) => Maybe FactionId -> m ()
revealItems mfid = do
itemToF <- itemToFullServer
let discover aid store iid k =
let itemFull = itemToF iid k
c = CActor aid store
in case itemDisco itemFull of
Just ItemDisco{itemKindId} -> do
seed <- getsServer $ (EM.! iid) . sitemSeedD
execUpdAtomic $ UpdDiscover c iid itemKindId seed
_ -> error $ "" `showFailure` (mfid, c, iid, itemFull)
f aid = do
b <- getsState $ getActorBody aid
let ourSide = maybe True (== bfid b) mfid
when (not (bproj b) && ourSide) $
join $ getsState $ mapActorItems_ (discover aid) b
as <- getsState $ EM.keys . sactorD
mapM_ f as
moveStores :: (MonadAtomic m, MonadServer m)
=> Bool -> ActorId -> CStore -> CStore -> m ()
moveStores verbose aid fromStore toStore = do
b <- getsState $ getActorBody aid
let g iid (k, _) = do
move <- generalMoveItem verbose iid k (CActor aid fromStore)
(CActor aid toStore)
mapM_ execUpdAtomic move
mapActorCStore_ fromStore g b
quitF :: (MonadAtomic m, MonadServer m) => Status -> FactionId -> m ()
quitF status fid = do
fact <- getsState $ (EM.! fid) . sfactionD
let oldSt = gquit fact
case stOutcome <$> oldSt of
Just Killed -> return ()
Just Defeated -> return ()
Just Conquer -> return ()
Just Escape -> return ()
_ -> do
when (fhasUI $ gplayer fact) $ do
keepAutomated <- getsServer $ skeepAutomated . sdebugSer
when (isAIFact fact
&& fleaderMode (gplayer fact) /= LeaderNull
&& not keepAutomated) $
execUpdAtomic $ UpdAutoFaction fid False
revealItems (Just fid)
registerScore status fid
execUpdAtomic $ UpdQuitFaction fid oldSt $ Just status
modifyServer $ \ser -> ser {squit = True}
deduceQuits :: (MonadAtomic m, MonadServer m) => FactionId -> Status -> m ()
deduceQuits fid0 status@Status{stOutcome}
| stOutcome `elem` [Defeated, Camping, Restart, Conquer] =
error $ "no quitting to deduce" `showFailure` (fid0, status)
deduceQuits fid0 status = do
fact0 <- getsState $ (EM.! fid0) . sfactionD
let factHasUI = fhasUI . gplayer
quitFaction (stOutcome, (fid, _)) = quitF status{stOutcome} fid
mapQuitF outfids = do
let (withUI, withoutUI) =
partition (factHasUI . snd . snd)
((stOutcome status, (fid0, fact0)) : outfids)
mapM_ quitFaction (withoutUI ++ withUI)
inGameOutcome (fid, fact) = do
let mout | fid == fid0 = Just $ stOutcome status
| otherwise = stOutcome <$> gquit fact
case mout of
Just Killed -> False
Just Defeated -> False
Just Restart -> False
_ -> True
factionD <- getsState sfactionD
let assocsInGame = filter inGameOutcome $ EM.assocs factionD
assocsKeepArena = filter (keepArenaFact . snd) assocsInGame
assocsUI = filter (factHasUI . snd) assocsInGame
nonHorrorAIG = filter (not . isHorrorFact . snd) assocsInGame
worldPeace =
all (\(fid1, _) -> all (\(_, fact2) -> not $ isAtWar fact2 fid1)
nonHorrorAIG)
nonHorrorAIG
othersInGame = filter ((/= fid0) . fst) assocsInGame
if | null assocsUI ->
mapQuitF $ zip (repeat Conquer) othersInGame
| null assocsKeepArena ->
mapQuitF $ zip (repeat Conquer) othersInGame
| worldPeace ->
mapQuitF $ zip (repeat Conquer) othersInGame
| stOutcome status == Escape -> do
let (victors, losers) = partition (flip isAllied fid0 . snd) othersInGame
mapQuitF $ zip (repeat Escape) victors ++ zip (repeat Defeated) losers
| otherwise -> quitF status fid0
keepArenaFact :: Faction -> Bool
keepArenaFact fact = fleaderMode (gplayer fact) /= LeaderNull
&& fneverEmpty (gplayer fact)
deduceKilled :: (MonadAtomic m, MonadServer m) => ActorId -> m ()
deduceKilled aid = do
Kind.COps{corule} <- getsState scops
body <- getsState $ getActorBody aid
let firstDeathEnds = rfirstDeathEnds $ Kind.stdRuleset corule
fact <- getsState $ (EM.! bfid body) . sfactionD
when (fneverEmpty $ gplayer fact) $ do
actorsAlive <- anyActorsAlive (bfid body) aid
when (not actorsAlive || firstDeathEnds) $
deduceQuits (bfid body) $ Status Killed (fromEnum $ blid body) Nothing
anyActorsAlive :: MonadServer m => FactionId -> ActorId -> m Bool
anyActorsAlive fid aid = do
as <- getsState $ fidActorNotProjAssocs fid
return $! map fst as /= [aid]
electLeader :: MonadAtomic m => FactionId -> LevelId -> ActorId -> m ()
electLeader fid lid aidDead = do
mleader <- getsState $ _gleader . (EM.! fid) . sfactionD
when (mleader == Just aidDead) $ do
actorD <- getsState sactorD
let ours (_, b) = bfid b == fid && not (bproj b)
party = filter ours $ EM.assocs actorD
onLevel <- getsState $ fidActorRegularIds fid lid
let mleaderNew = case filter (/= aidDead) $ onLevel ++ map fst party of
[] -> Nothing
aid : _ -> Just aid
execUpdAtomic $ UpdLeadFaction fid mleader mleaderNew
supplantLeader :: MonadAtomic m => FactionId -> ActorId -> m ()
supplantLeader fid aid = do
fact <- getsState $ (EM.! fid) . sfactionD
unless (fleaderMode (gplayer fact) == LeaderNull) $
execUpdAtomic $ UpdLeadFaction fid (_gleader fact) (Just aid)
projectFail :: (MonadAtomic m, MonadServer m)
=> ActorId
-> Point
-> Int
-> ItemId
-> CStore
-> Bool
-> m (Maybe ReqFailure)
projectFail source tpxy eps iid cstore isBlast = do
Kind.COps{coTileSpeedup} <- getsState scops
sb <- getsState $ getActorBody source
let lid = blid sb
spos = bpos sb
lvl@Level{lxsize, lysize} <- getLevel lid
case bla lxsize lysize eps spos tpxy of
Nothing -> return $ Just ProjectAimOnself
Just [] -> error $ "projecting from the edge of level"
`showFailure` (spos, tpxy)
Just (pos : restUnlimited) -> do
bag <- getsState $ getBodyStoreBag sb cstore
case EM.lookup iid bag of
Nothing -> return $ Just ProjectOutOfReach
Just kit -> do
itemToF <- itemToFullServer
actorSk <- currentSkillsServer source
actorAspect <- getsServer sactorAspect
let ar = actorAspect EM.! source
skill = EM.findWithDefault 0 Ability.AbProject actorSk
itemFull@ItemFull{itemBase} = itemToF iid kit
forced = isBlast || bproj sb
calmE = calmEnough sb ar
legal = permittedProject forced skill calmE "" itemFull
case legal of
Left reqFail -> return $ Just reqFail
Right _ -> do
let lobable = IK.Lobable `elem` jfeature itemBase
rest = if lobable
then take (chessDist spos tpxy - 1) restUnlimited
else restUnlimited
t = lvl `at` pos
if not $ Tile.isWalkable coTileSpeedup t
then return $ Just ProjectBlockTerrain
else do
lab <- getsState $ posToAssocs pos lid
if not $ all (bproj . snd) lab
then if isBlast && bproj sb then do
projectBla source spos (pos:rest) iid cstore isBlast
return Nothing
else return $ Just ProjectBlockActor
else do
if isBlast && bproj sb && eps `mod` 2 == 0 then
projectBla source spos (pos:rest) iid cstore isBlast
else
projectBla source pos rest iid cstore isBlast
return Nothing
projectBla :: (MonadAtomic m, MonadServer m)
=> ActorId
-> Point
-> [Point]
-> ItemId
-> CStore
-> Bool
-> m ()
projectBla source pos rest iid cstore isBlast = do
sb <- getsState $ getActorBody source
item <- getsState $ getItemBody iid
let lid = blid sb
localTime <- getsState $ getLocalTime lid
unless isBlast $ execSfxAtomic $ SfxProject source iid cstore
bag <- getsState $ getBodyStoreBag sb cstore
case iid `EM.lookup` bag of
Nothing -> error $ "" `showFailure` (source, pos, rest, iid, cstore)
Just kit@(_, it) -> do
let btime = absoluteTimeAdd timeEpsilon localTime
addProjectile pos rest iid kit lid (bfid sb) btime isBlast
let c = CActor source cstore
execUpdAtomic $ UpdLoseItem False iid item (1, take 1 it) c
addProjectile :: (MonadAtomic m, MonadServer m)
=> Point -> [Point] -> ItemId -> ItemQuant -> LevelId
-> FactionId -> Time -> Bool
-> m ()
addProjectile bpos rest iid (_, it) blid bfid btime _isBlast = do
itemToF <- itemToFullServer
let itemFull@ItemFull{itemBase} = itemToF iid (1, take 1 it)
(trajectory, (speed, _)) = itemTrajectory itemBase (bpos : rest)
tweakBody b = b { bhp = oneM
, bproj = True
, btrajectory = Just (trajectory, speed)
, beqp = EM.singleton iid (1, take 1 it)
, borgan = EM.empty }
void $ addActorIid iid itemFull True bfid bpos blid tweakBody btime
addActor :: (MonadAtomic m, MonadServer m)
=> GroupName ItemKind -> FactionId -> Point -> LevelId
-> (Actor -> Actor) -> Time
-> m (Maybe ActorId)
addActor actorGroup bfid pos lid tweakBody time = do
let trunkFreq = [(actorGroup, 1)]
m5 <- rollItem 0 lid trunkFreq
case m5 of
Nothing -> return Nothing
Just (itemKnownRaw, itemFullRaw, itemDisco, seed, _) ->
registerActor itemKnownRaw itemFullRaw itemDisco seed
bfid pos lid tweakBody time
registerActor :: (MonadAtomic m, MonadServer m)
=> ItemKnown -> ItemFull -> ItemDisco -> ItemSeed
-> FactionId -> Point -> LevelId -> (Actor -> Actor) -> Time
-> m (Maybe ActorId)
registerActor (kindIx, ar, damage, _) itemFullRaw itemDisco seed
bfid pos lid tweakBody time = do
let container = CTrunk bfid lid pos
jfid = if IK.Identified `elem` IK.ifeature (itemKind itemDisco)
then Just bfid
else Nothing
itemKnown = (kindIx, ar, damage, jfid)
itemFull = itemFullRaw {itemBase = (itemBase itemFullRaw) {jfid}}
trunkId <- registerItem itemFull itemKnown seed container False
addActorIid trunkId itemFull False bfid pos lid tweakBody time
addActorIid :: (MonadAtomic m, MonadServer m)
=> ItemId -> ItemFull -> Bool -> FactionId -> Point -> LevelId
-> (Actor -> Actor) -> Time
-> m (Maybe ActorId)
addActorIid trunkId trunkFull@ItemFull{..} bproj
bfid pos lid tweakBody time = do
let trunkKind = case itemDisco of
Just ItemDisco{itemKind} -> itemKind
Nothing -> error $ "" `showFailure` trunkFull
aspects = fromJust $ itemAspect $ fromJust itemDisco
hp = xM (max 2 $ aMaxHP aspects) `div` 2
calm = xM (max 0 $ aMaxCalm aspects)
factionD <- getsState sfactionD
let fact = factionD EM.! bfid
curChalSer <- getsServer $ scurChalSer . sdebugSer
nU <- nUI
let diffBonusCoeff = difficultyCoeff $ cdiff curChalSer
hasUIorEscapes Faction{gplayer} =
fhasUI gplayer || nU == 0 && fcanEscape gplayer
boostFact = not bproj
&& if diffBonusCoeff > 0
then hasUIorEscapes fact
|| any hasUIorEscapes
(filter (`isAllied` bfid) $ EM.elems factionD)
else any hasUIorEscapes
(filter (`isAtWar` bfid) $ EM.elems factionD)
diffHP | boostFact = if cdiff curChalSer `elem` [1, difficultyBound]
then xM 999 - hp
else hp * 2 ^ abs diffBonusCoeff
| otherwise = hp
bonusHP = fromEnum $ (diffHP - hp) `divUp` oneM
healthOrgans = [(Just bonusHP, ("bonus HP", COrgan)) | bonusHP /= 0]
b = actorTemplate trunkId diffHP calm pos lid bfid
withTrunk = b { borgan = EM.singleton trunkId (itemK, itemTimer)
, bweapon = if isMelee itemBase then 1 else 0 }
aid <- getsServer sacounter
modifyServer $ \ser -> ser {sacounter = succ aid}
execUpdAtomic $ UpdCreateActor aid (tweakBody withTrunk) [(trunkId, itemBase)]
modifyServer $ \ser ->
ser {sactorTime = updateActorTime bfid lid aid time $ sactorTime ser}
forM_ (healthOrgans ++ map (Nothing,) (IK.ikit trunkKind))
$ \(mk, (ikText, cstore)) -> do
let container = CActor aid cstore
itemFreq = [(ikText, 1)]
mIidEtc <- rollAndRegisterItem lid itemFreq container False mk
case mIidEtc of
Nothing -> error $ "" `showFailure` (lid, itemFreq, container, mk)
Just (iid, (itemFull, _)) -> discoverIfNoEffects container iid itemFull
return $ Just aid
discoverIfNoEffects :: (MonadAtomic m, MonadServer m)
=> Container -> ItemId -> ItemFull -> m ()
discoverIfNoEffects c iid itemFull = case itemFull of
ItemFull{itemDisco=Just ItemDisco{itemKind=IK.ItemKind{IK.ieffects}}}
| any IK.forIdEffect ieffects -> return ()
_ -> do
seed <- getsServer $ (EM.! iid) . sitemSeedD
execUpdAtomic $ UpdDiscoverSeed c iid seed
pickWeaponServer :: MonadServer m => ActorId -> m (Maybe (ItemId, CStore))
pickWeaponServer source = do
eqpAssocs <- fullAssocsServer source [CEqp]
bodyAssocs <- fullAssocsServer source [COrgan]
actorSk <- currentSkillsServer source
actorAspect <- getsServer sactorAspect
sb <- getsState $ getActorBody source
let allAssocsRaw = eqpAssocs ++ bodyAssocs
forced = bproj sb
allAssocs | forced = allAssocsRaw
| otherwise = filter (isMelee . itemBase . snd) allAssocsRaw
strongest <- pickWeaponM Nothing allAssocs actorSk actorAspect source
case strongest of
[] -> return Nothing
iis@((maxS, _) : _) -> do
let maxIis = map snd $ takeWhile ((== maxS) . fst) iis
(iid, _) <- rndToAction $ oneOf maxIis
let cstore = if isJust (lookup iid bodyAssocs) then COrgan else CEqp
return $ Just (iid, cstore)
currentSkillsServer :: MonadServer m => ActorId -> m Ability.Skills
currentSkillsServer aid = do
ar <- getsServer $ (EM.! aid) . sactorAspect
body <- getsState $ getActorBody aid
fact <- getsState $ (EM.! bfid body) . sfactionD
let mleader = _gleader fact
getsState $ actorSkills mleader aid ar
getCacheLucid :: MonadServer m => LevelId -> m FovLucid
getCacheLucid lid = do
discoAspect <- getsServer sdiscoAspect
actorAspect <- getsServer sactorAspect
fovClearLid <- getsServer sfovClearLid
fovLitLid <- getsServer sfovLitLid
fovLucidLid <- getsServer sfovLucidLid
let getNewLucid = getsState $ \s ->
lucidFromLevel discoAspect actorAspect fovClearLid fovLitLid
s lid (sdungeon s EM.! lid)
case EM.lookup lid fovLucidLid of
Just (FovValid fovLucid) -> return fovLucid
_ -> do
newLucid <- getNewLucid
modifyServer $ \ser ->
ser {sfovLucidLid = EM.insert lid (FovValid newLucid)
$ sfovLucidLid ser}
return newLucid
getCacheTotal :: MonadServer m => FactionId -> LevelId -> m CacheBeforeLucid
getCacheTotal fid lid = do
sperCacheFidOld <- getsServer sperCacheFid
let perCacheOld = sperCacheFidOld EM.! fid EM.! lid
case ptotal perCacheOld of
FovValid total -> return total
FovInvalid -> do
actorAspect <- getsServer sactorAspect
fovClearLid <- getsServer sfovClearLid
getActorB <- getsState $ flip getActorBody
let perActorNew =
perActorFromLevel (perActor perCacheOld) getActorB
actorAspect (fovClearLid EM.! lid)
total = totalFromPerActor perActorNew
perCache = PerceptionCache { ptotal = FovValid total
, perActor = perActorNew }
fperCache = EM.adjust (EM.insert lid perCache) fid
modifyServer $ \ser -> ser {sperCacheFid = fperCache $ sperCacheFid ser}
return total
recomputeCachePer :: MonadServer m => FactionId -> LevelId -> m Perception
recomputeCachePer fid lid = do
total <- getCacheTotal fid lid
fovLucid <- getCacheLucid lid
let perNew = perceptionFromPTotal fovLucid total
fper = EM.adjust (EM.insert lid perNew) fid
modifyServer $ \ser -> ser {sperFid = fper $ sperFid ser}
return perNew