module Game.LambdaHack.Client.HandleAtomicM
( MonadClientSetup(..)
, cmdAtomicSemCli
#ifdef EXPOSE_INTERNAL
, invalidateInMelee, wipeBfsIfItemAffectsSkills, tileChangeAffectsBfs
, createActor, destroyActor
, addItemToDiscoBenefit, perception
, discoverKind, discoverKindAndAspect, coverKind, coverAspectAndKind
, discoverAspect, coverAspect
, killExit
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import qualified Data.Map.Strict as M
import Data.Ord
import Game.LambdaHack.Atomic
import Game.LambdaHack.Client.Bfs
import Game.LambdaHack.Client.BfsM
import Game.LambdaHack.Client.CommonM
import Game.LambdaHack.Client.MonadClient
import Game.LambdaHack.Client.Preferences
import Game.LambdaHack.Client.State
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Item
import Game.LambdaHack.Common.Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Types
import qualified Game.LambdaHack.Content.CaveKind as CK
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.TileKind (TileKind)
import Game.LambdaHack.Definition.Defs
class MonadClient m => MonadClientSetup m where
saveClient :: m ()
restartClient :: m ()
cmdAtomicSemCli :: MonadClientSetup m => State -> UpdAtomic -> m ()
{-# INLINE cmdAtomicSemCli #-}
cmdAtomicSemCli oldState cmd = case cmd of
UpdCreateActor aid b ais -> createActor aid b ais
UpdDestroyActor aid b _ -> destroyActor aid b True
UpdCreateItem iid _ _ (CActor aid store) -> do
wipeBfsIfItemAffectsSkills [store] aid
addItemToDiscoBenefit iid
UpdCreateItem iid _ _ _ -> addItemToDiscoBenefit iid
UpdDestroyItem _ _ _ (CActor aid store) ->
wipeBfsIfItemAffectsSkills [store] aid
UpdDestroyItem{} -> return ()
UpdSpotActor aid b ais -> createActor aid b ais
UpdLoseActor aid b _ -> destroyActor aid b False
UpdSpotItem _ iid _ _ (CActor aid store) -> do
wipeBfsIfItemAffectsSkills [store] aid
addItemToDiscoBenefit iid
UpdSpotItem _ iid _ _ _ -> addItemToDiscoBenefit iid
UpdLoseItem _ _ _ _ (CActor aid store) ->
wipeBfsIfItemAffectsSkills [store] aid
UpdLoseItem{} -> return ()
UpdSpotItemBag (CActor aid store) _bag ais -> do
wipeBfsIfItemAffectsSkills [store] aid
mapM_ (addItemToDiscoBenefit . fst) ais
UpdSpotItemBag _ _ ais ->
mapM_ (addItemToDiscoBenefit . fst) ais
UpdLoseItemBag (CActor aid store) _bag _ais ->
wipeBfsIfItemAffectsSkills [store] aid
UpdLoseItemBag{} -> return ()
UpdMoveActor aid _ _ -> do
invalidateBfsAid aid
b <- getsState $ getActorBody aid
unless (bproj b) $ invalidateBfsPathLid (blid b) $ bpos b
invalidateInMelee (blid b)
UpdWaitActor aid _fromW toW ->
when (toW == WSleep) $
modifyClient $ updateTarget aid (const Nothing)
UpdDisplaceActor source target -> do
invalidateBfsAid source
invalidateBfsAid target
b <- getsState $ getActorBody source
unless (bproj b) $ invalidateBfsPathLid (blid b) $ bpos b
tb <- getsState $ getActorBody target
unless (bproj tb) $ invalidateBfsPathLid (blid tb) $ bpos tb
invalidateInMelee (blid b)
UpdMoveItem _ _ aid s1 s2 -> wipeBfsIfItemAffectsSkills [s1, s2] aid
UpdRefillHP{} -> return ()
UpdRefillCalm{} -> return ()
UpdTrajectory{} -> return ()
UpdQuitFaction fid _ toSt _ -> do
side <- getsClient sside
when (side == fid && maybe False ((/= Camping) . stOutcome) toSt) $ do
let won = case toSt of
Just Status{stOutcome=Conquer} -> True
Just Status{stOutcome=Escape} -> True
_ -> False
when won $ do
gameModeId <- getsState sgameModeId
scurChal <- getsClient scurChal
let sing = M.singleton scurChal 1
f = M.unionWith (+)
g = EM.insertWith f gameModeId sing
modifyClient $ \cli -> cli {svictories = g $ svictories cli}
UpdLeadFaction fid source target -> do
side <- getsClient sside
when (side == fid) $ do
mleader <- getsClient sleader
let !_A = assert (mleader == source
|| mleader == target
`blame` "unexpected leader"
`swith` (cmd, mleader)) ()
modifyClient $ \cli -> cli {_sleader = target}
UpdDiplFaction{} -> return ()
UpdAutoFaction{} ->
invalidateBfsAll
UpdRecordKill{} -> return ()
UpdTacticFaction{} -> do
mleader <- getsClient sleader
mtgt <- case mleader of
Nothing -> return Nothing
Just leader -> getsClient $ EM.lookup leader . stargetD
modifyClient $ \cli ->
let stargetD | Just tgt <- mtgt
, Just leader <- mleader
= EM.singleton leader tgt
| otherwise = EM.empty
in cli {stargetD}
UpdAlterTile lid p fromTile toTile -> do
updateSalter lid [(p, toTile)]
cops <- getsState scops
let lvl = (EM.! lid) . sdungeon $ oldState
t = lvl `at` p
let !_A = assert (t == fromTile) ()
when (tileChangeAffectsBfs cops fromTile toTile) $
invalidateBfsLid lid
UpdAlterExplorable{} -> return ()
UpdAlterGold{} -> return ()
UpdSearchTile aid p toTile -> do
COps{cotile} <- getsState scops
b <- getsState $ getActorBody aid
let lid = blid b
updateSalter lid [(p, toTile)]
cops <- getsState scops
let lvl = (EM.! lid) . sdungeon $ oldState
t = lvl `at` p
let !_A = assert (Just t == Tile.hideAs cotile toTile) ()
when (tileChangeAffectsBfs cops t toTile) $
invalidateBfsLid lid
UpdHideTile{} -> return ()
UpdSpotTile lid ts -> do
updateSalter lid ts
cops <- getsState scops
let lvl = (EM.! lid) . sdungeon $ oldState
affects (p, toTile) =
let fromTile = lvl `at` p
in tileChangeAffectsBfs cops fromTile toTile
bs = map affects ts
when (or bs) $ invalidateBfsLid lid
UpdLoseTile lid ts -> do
updateSalter lid ts
invalidateBfsLid lid
UpdSpotEntry{} -> return ()
UpdLoseEntry{} -> return ()
UpdAlterSmell{} -> return ()
UpdSpotSmell{} -> return ()
UpdLoseSmell{} -> return ()
UpdTimeItem{} -> return ()
UpdAgeGame{} -> return ()
UpdUnAgeGame{} -> return ()
UpdDiscover _ iid _ _ -> do
item <- getsState $ getItemBody iid
case jkind item of
IdentityObvious _ik -> discoverAspect iid
IdentityCovered ix _ik ->
if ix `EM.notMember` sdiscoKind oldState
then discoverKindAndAspect ix
else discoverAspect iid
UpdCover _ iid _ _ -> do
item <- getsState $ getItemBody iid
newState <- getState
case jkind item of
IdentityObvious _ik -> coverAspect iid
IdentityCovered ix _ik ->
if ix `EM.member` sdiscoKind newState
then coverAspectAndKind ix
else coverAspect iid
UpdDiscoverKind _c ix _ik -> discoverKind ix
UpdCoverKind _c ix _ik -> coverKind ix
UpdDiscoverAspect _c iid _arItem -> discoverAspect iid
UpdCoverAspect _c iid _arItem -> coverAspect iid
UpdDiscoverServer{} -> error "server command leaked to client"
UpdCoverServer{} -> error "server command leaked to client"
UpdPerception lid outPer inPer -> perception lid outPer inPer
UpdRestart side sfper s scurChal soptions srandom -> do
COps{cocave, comode} <- getsState scops
fact <- getsState $ (EM.! side) . sfactionD
snxtChal <- getsClient snxtChal
svictories <- getsClient svictories
stabs <- getsClient stabs
let f !acc _p !i _a = i : acc
modes = zip [0..] $ ofoldlGroup' comode "campaign scenario" f []
g :: (Int, ContentId ModeKind) -> Int
g (_, mode) = case EM.lookup mode svictories of
Nothing -> 0
Just cm -> fromMaybe 0 (M.lookup snxtChal cm)
(snxtScenario, _) = minimumBy (comparing g) modes
h lvl = CK.labyrinth (okind cocave $ lkind lvl)
&& not (fhasGender $ gplayer fact)
sexplored = EM.keysSet $ EM.filter h $ sdungeon s
cli = emptyStateClient side
putClient cli { sexplored
, sfper
, srandom
, scurChal
, snxtChal
, snxtScenario
, scondInMelee = EM.empty
, svictories
, soptions
, stabs }
salter <- getsState createSalter
modifyClient $ \cli1 -> cli1 {salter}
restartClient
UpdRestartServer{} -> return ()
UpdResume _side sfperNew -> do
#ifdef WITH_EXPENSIVE_ASSERTIONS
sfperOld <- getsClient sfper
let !_A = assert (sfperNew == sfperOld
`blame` (_side, sfperNew, sfperOld)) ()
#endif
modifyClient $ \cli -> cli {sfper = sfperNew}
salter <- getsState createSalter
modifyClient $ \cli -> cli {salter}
UpdResumeServer{} -> return ()
UpdKillExit _fid -> killExit
UpdWriteSave -> saveClient
UpdHearFid{} -> return ()
invalidateInMelee :: MonadClient m => LevelId -> m ()
invalidateInMelee lid =
modifyClient $ \cli -> cli {scondInMelee = EM.delete lid (scondInMelee cli)}
wipeBfsIfItemAffectsSkills :: MonadClient m => [CStore] -> ActorId -> m ()
wipeBfsIfItemAffectsSkills stores aid =
unless (null $ intersect stores [CEqp, COrgan]) $ invalidateBfsAid aid
tileChangeAffectsBfs :: COps
-> ContentId TileKind -> ContentId TileKind
-> Bool
tileChangeAffectsBfs COps{coTileSpeedup} fromTile toTile =
Tile.alterMinWalk coTileSpeedup fromTile
/= Tile.alterMinWalk coTileSpeedup toTile
createActor :: MonadClient m => ActorId -> Actor -> [(ItemId, Item)] -> m ()
createActor aid b ais = do
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
let affect3 tap@TgtAndPath{..} = case tapTgt of
TPoint (TEnemyPos a) _ _ | a == aid ->
let tgt | isFoe side fact (bfid b) = TEnemy a
| otherwise = TPoint TKnown (blid b) (bpos b)
in TgtAndPath tgt Nothing
_ -> tap
modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)}
mapM_ (addItemToDiscoBenefit . fst) ais
unless (bproj b) $ invalidateBfsPathLid (blid b) $ bpos b
invalidateInMelee (blid b)
destroyActor :: MonadClient m => ActorId -> Actor -> Bool -> m ()
destroyActor aid b destroy = do
when destroy $ modifyClient $ updateTarget aid (const Nothing)
modifyClient $ \cli -> cli {sbfsD = EM.delete aid $ sbfsD cli}
let affect tgt = case tgt of
TEnemy a | a == aid ->
if destroy then
TPoint TKnown (blid b) (bpos b)
else
TPoint (TEnemyPos a) (blid b) (bpos b)
TNonEnemy a | a == aid -> TPoint TKnown (blid b) (bpos b)
_ -> tgt
affect3 TgtAndPath{..} =
let newMPath = case tapPath of
Just AndPath{pathGoal} | pathGoal /= bpos b -> Nothing
_ -> tapPath
in TgtAndPath (affect tapTgt) newMPath
modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)}
unless (bproj b) $ invalidateBfsPathLid (blid b) $ bpos b
invalidateInMelee (blid b)
addItemToDiscoBenefit :: MonadClient m => ItemId -> m ()
addItemToDiscoBenefit iid = do
cops <- getsState scops
discoBenefit <- getsClient sdiscoBenefit
case EM.lookup iid discoBenefit of
Just{} -> return ()
Nothing -> do
side <- getsClient sside
factionD <- getsState sfactionD
itemFull <- getsState $ itemToFull iid
let benefit = totalUsefulness cops side factionD itemFull
modifyClient $ \cli ->
cli {sdiscoBenefit = EM.insert iid benefit (sdiscoBenefit cli)}
perception :: MonadClient m => LevelId -> Perception -> Perception -> m ()
perception lid outPer inPer = do
let adj Nothing = error $ "no perception to alter" `showFailure` lid
adj (Just per) = Just $ addPer (diffPer per outPer) inPer
f = EM.alter adj lid
modifyClient $ \cli -> cli {sfper = f (sfper cli)}
discoverKind :: MonadClient m => ItemKindIx -> m ()
discoverKind = discoverKindAndAspect
discoverKindAndAspect :: MonadClient m => ItemKindIx -> m ()
discoverKindAndAspect ix = do
cops <- getsState scops
invalidateBfsAll
side <- getsClient sside
factionD <- getsState sfactionD
itemToF <- getsState $ flip itemToFull
let benefit iid = totalUsefulness cops side factionD (itemToF iid)
itemIxMap <- getsState $ (EM.! ix) . sitemIxMap
forM_ (ES.elems itemIxMap) $ \iid -> modifyClient $ \cli ->
cli {sdiscoBenefit = EM.insert iid (benefit iid) (sdiscoBenefit cli)}
coverKind :: ItemKindIx -> m ()
coverKind = coverAspectAndKind
coverAspectAndKind :: ItemKindIx -> m ()
coverAspectAndKind _ix = undefined
discoverAspect :: MonadClient m => ItemId -> m ()
discoverAspect iid = do
cops <- getsState scops
invalidateBfsAll
side <- getsClient sside
factionD <- getsState sfactionD
itemFull <- getsState $ itemToFull iid
let benefit = totalUsefulness cops side factionD itemFull
modifyClient $ \cli ->
cli {sdiscoBenefit = EM.insert iid benefit (sdiscoBenefit cli)}
coverAspect :: ItemId -> m ()
coverAspect _iid = undefined
killExit :: MonadClient m => m ()
killExit = do
side <- getsClient sside
debugPossiblyPrint $ "Client" <+> tshow side <+> "quitting."
modifyClient $ \cli -> cli {squit = True}
sactorMaxSkills2 <- getsState sactorMaxSkills
salter <- getsClient salter
sbfsD <- getsClient sbfsD
alter <- getsState createSalter
actorMaxSkills <- getsState maxSkillsInDungeon
let f aid = do
(canMove, alterSkill) <- condBFS aid
bfsArr <- createBfs canMove alterSkill aid
let bfsPath = EM.empty
return (aid, BfsAndPath bfsArr bfsPath)
actorD <- getsState sactorD
lbfsD <- mapM f $ EM.keys actorD
let bfsD = EM.fromDistinctAscList lbfsD
g BfsInvalid !_ = True
g _ BfsInvalid = False
g (BfsAndPath bfsArr1 _) (BfsAndPath bfsArr2 _) = bfsArr1 == bfsArr2
subBfs = EM.isSubmapOfBy g
let !_A1 = assert (salter == alter
`blame` "wrong accumulated salter on side"
`swith` (side, salter, alter)) ()
!_A2 = assert (sactorMaxSkills2 == actorMaxSkills
`blame` "wrong accumulated sactorMaxSkills on side"
`swith` (side, sactorMaxSkills2, actorMaxSkills)) ()
!_A3 = assert (sbfsD `subBfs` bfsD
`blame` "wrong accumulated sbfsD on side"
`swith` (side, sbfsD, bfsD)) ()
return ()