module Game.LambdaHack.Client.HandleAtomicM
( MonadClientSetup(..)
, cmdAtomicSemCli
#ifdef EXPOSE_INTERNAL
, wipeBfsIfItemAffectsSkills, tileChangeAffectsBfs, createActor, destroyActor
, addItemToDiscoBenefit, perception
, discoverKind, coverKind, discoverSeed, coverSeed
, killExit
#endif
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import qualified Data.EnumMap.Lazy as LEM
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 qualified Game.LambdaHack.Common.ItemAspect as IA
import Game.LambdaHack.Common.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.State
import qualified Game.LambdaHack.Common.Tile as Tile
import qualified Game.LambdaHack.Content.CaveKind as CK
import Game.LambdaHack.Content.ItemKind (ItemKind)
import Game.LambdaHack.Content.ModeKind (ModeKind, fhasGender)
import Game.LambdaHack.Content.TileKind (TileKind)
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
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
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
UpdMoveActor aid _ _ -> do
invalidateBfsAid aid
b <- getsState $ getActorBody aid
recomputeInMelee (blid b)
UpdDisplaceActor source target -> do
invalidateBfsAid source
invalidateBfsAid target
b <- getsState $ getActorBody source
recomputeInMelee (blid b)
UpdMoveItem _ _ aid s1 s2 -> wipeBfsIfItemAffectsSkills [s1, s2] aid
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}
UpdAutoFaction{} ->
invalidateBfsAll
UpdTacticFaction{} -> do
mleader <- getsClient sleader
mtgt <- case mleader of
Nothing -> return Nothing
Just leader -> getsClient $ EM.lookup leader . stargetD
modifyClient $ \cli ->
cli { stargetD = case (mtgt, mleader) of
(Just tgt, Just leader) -> EM.singleton leader tgt
_ -> EM.empty }
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
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
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
UpdDiscover c iid ik seed -> do
item <- getsState $ getItemBody iid
discoKind <- getsState sdiscoKind
case jkind item of
IdentityObvious _ik -> return ()
IdentityCovered ix _ik | ix `EM.notMember` discoKind ->
discoverKind c ix ik
IdentityCovered _ix _ik -> return ()
discoverSeed c iid seed
UpdCover c iid ik seed -> do
coverSeed c iid seed
item <- getsState $ getItemBody iid
discoKind <- getsState sdiscoKind
case jkind item of
IdentityObvious _ik -> return ()
IdentityCovered ix _ik | ix `EM.member` discoKind ->
coverKind c ix ik
IdentityCovered _ix _ik -> return ()
UpdDiscoverKind c ix ik -> discoverKind c ix ik
UpdCoverKind c ix ik -> coverKind c ix ik
UpdDiscoverSeed c iid seed -> discoverSeed c iid seed
UpdCoverSeed c iid seed -> coverSeed c iid seed
UpdPerception lid outPer inPer -> perception lid outPer inPer
UpdRestart side sfper s scurChal soptions -> do
COps{cocave, comode} <- getsState scops
fact <- getsState $ (EM.! side) . sfactionD
snxtChal <- getsClient snxtChal
svictories <- getsClient svictories
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.cactorCoeff (okind cocave $ lkind lvl) > 150
&& not (fhasGender $ gplayer fact)
sexplored = EM.keysSet $ EM.filter h $ sdungeon s
cli = emptyStateClient side
putClient cli { sexplored
, sfper
, scurChal
, snxtChal
, snxtScenario
, scondInMelee = LEM.fromAscList
$ map (\lid -> (lid, False))
$ EM.keys (sdungeon s)
, svictories
, soptions }
salter <- getsState createSalter
modifyClient $ \cli1 -> cli1 {salter}
restartClient
UpdResume _fid sfperNew -> do
#ifdef WITH_EXPENSIVE_ASSERTIONS
sfperOld <- getsClient sfper
let !_A = assert (sfperNew == sfperOld `blame` (sfperNew, sfperOld)) ()
#endif
modifyClient $ \cli -> cli {sfper=sfperNew}
salter <- getsState createSalter
modifyClient $ \cli -> cli {salter}
UpdKillExit _fid -> killExit
UpdWriteSave -> saveClient
_ -> return ()
recomputeInMelee :: MonadClient m => LevelId -> m ()
recomputeInMelee lid = do
side <- getsClient sside
s <- getState
modifyClient $ \cli ->
cli {scondInMelee = LEM.insert lid (inMelee side lid s) (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
let newPermit = bfid b == side
affect3 tap@TgtAndPath{..} = case tapTgt of
TPoint (TEnemyPos a _) _ _ | a == aid ->
TgtAndPath (TEnemy a newPermit) NoPath
_ -> tap
modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)}
mapM_ (addItemToDiscoBenefit . fst) ais
recomputeInMelee (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 permit | a == aid ->
if destroy then
TPoint TAny (blid b) (bpos b)
else
TPoint (TEnemyPos a permit) (blid b) (bpos b)
_ -> tgt
affect3 TgtAndPath{..} =
let newMPath = case tapPath of
AndPath{pathGoal} | pathGoal /= bpos b -> NoPath
_ -> tapPath
in TgtAndPath (affect tapTgt) newMPath
modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)}
recomputeInMelee (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
fact <- getsState $ (EM.! side) . sfactionD
itemFull <- getsState $ itemToFull iid
let benefit = totalUsefulness cops fact 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
=> Container -> ItemKindIx -> ContentId ItemKind -> m ()
discoverKind _c ix _ik = do
cops <- getsState scops
invalidateBfsAll
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
itemToF <- getsState $ flip itemToFull
let benefit iid =
let itemFull = itemToF iid
in totalUsefulness cops fact itemFull
itemIxMap <- getsState $ (EM.! ix) . sitemIxMap
forM_ (ES.elems itemIxMap) $ \iid -> modifyClient $ \cli ->
cli {sdiscoBenefit = EM.insert iid (benefit iid) (sdiscoBenefit cli)}
coverKind :: Container -> ItemKindIx -> ContentId ItemKind -> m ()
coverKind _c _ix _ik = undefined
discoverSeed :: MonadClient m => Container -> ItemId -> IA.ItemSeed -> m ()
discoverSeed _c iid _seed = do
cops <- getsState scops
invalidateBfsAll
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
itemFull <- getsState $ itemToFull iid
let benefit = totalUsefulness cops fact itemFull
modifyClient $ \cli ->
cli {sdiscoBenefit = EM.insert iid benefit (sdiscoBenefit cli)}
coverSeed :: Container -> ItemId -> IA.ItemSeed -> m ()
coverSeed _c _iid _seed = undefined
killExit :: MonadClient m => m ()
killExit = do
side <- getsClient sside
debugPossiblyPrint $ "Client" <+> tshow side <+> "quitting."
modifyClient $ \cli -> cli {squit = True}
sactorAspect2 <- getsState sactorAspect
salter <- getsClient salter
sbfsD <- getsClient sbfsD
alter <- getsState createSalter
actorAspect <- getsState actorAspectInDungeon
let f aid = do
(canMove, alterSkill) <- condBFS aid
bfsArr <- createBfs canMove alterSkill aid
let bfsPath = EM.empty
return (aid, BfsAndPath{..})
actorD <- getsState sactorD
lbfsD <- mapM f $ EM.keys actorD
let bfsD = EM.fromDistinctAscList lbfsD
g BfsInvalid !_ = True
g _ BfsInvalid = False
g bap1 bap2 = bfsArr bap1 == bfsArr bap2
subBfs = EM.isSubmapOfBy g
let !_A1 = assert (salter == alter
`blame` "wrong accumulated salter on side"
`swith` (side, salter, alter)) ()
!_A2 = assert (sactorAspect2 == actorAspect
`blame` "wrong accumulated sactorAspect on side"
`swith` (side, sactorAspect2, actorAspect)) ()
!_A3 = assert (sbfsD `subBfs` bfsD
`blame` "wrong accumulated sbfsD on side"
`swith` (side, sbfsD, bfsD)) ()
return ()