module Game.LambdaHack.Client.HandleAtomicClient
( cmdAtomicSemCli, cmdAtomicFilterCli
) where
import Control.Applicative
import Control.Exception.Assert.Sugar
import Control.Monad
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.Maybe
import qualified Data.Text as T
import qualified NLP.Miniutter.English as MU
import Game.LambdaHack.Atomic
import Game.LambdaHack.Client.CommonClient
import Game.LambdaHack.Client.MonadClient
import Game.LambdaHack.Client.State
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.ClientOptions
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Item
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.Msg
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Content.ItemKind (ItemKind)
import qualified Game.LambdaHack.Content.ItemKind as IK
import qualified Game.LambdaHack.Content.TileKind as TK
cmdAtomicFilterCli :: MonadClient m => UpdAtomic -> m [UpdAtomic]
cmdAtomicFilterCli cmd = case cmd of
UpdMoveActor aid _ toP -> do
cmdSml <- deleteSmell aid toP
return $ [cmd] ++ cmdSml
UpdDisplaceActor source target -> do
bs <- getsState $ getActorBody source
bt <- getsState $ getActorBody target
cmdSource <- deleteSmell source (bpos bt)
cmdTarget <- deleteSmell target (bpos bs)
return $ [cmd] ++ cmdSource ++ cmdTarget
UpdAlterTile lid p fromTile toTile -> do
Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops
lvl <- getLevel lid
let t = lvl `at` p
if t == fromTile
then return [cmd]
else do
let subject = ""
verb = "turn into"
msg = makeSentence [ "the", MU.Text $ TK.tname $ okind t
, "at position", MU.Text $ T.pack $ show p
, "suddenly"
, MU.SubjectVerbSg subject verb
, MU.AW $ MU.Text $ TK.tname $ okind toTile ]
return [ cmd
, UpdMsgAll msg
]
UpdSearchTile aid p fromTile toTile -> do
b <- getsState $ getActorBody aid
lvl <- getLevel $ blid b
let t = lvl `at` p
return $!
if t == fromTile
then
[ cmd
, UpdAlterTile (blid b) p fromTile toTile
]
else if t == toTile
then [cmd]
else
assert `failure` "LoseTile fails to reset memory"
`twith` (aid, p, fromTile, toTile, b, t, cmd)
UpdLearnSecrets aid fromS _toS -> do
b <- getsState $ getActorBody aid
lvl <- getLevel $ blid b
return $! if lsecret lvl == fromS
then [cmd]
else []
UpdSpotTile lid ts -> do
Kind.COps{cotile} <- getsState scops
lvl <- getLevel lid
let notKnown (p, t) = let tClient = lvl `at` p
in t /= tClient
&& (not (knownLsecret lvl && isSecretPos lvl p)
|| t /= Tile.hideAs cotile tClient)
newTs = filter notKnown ts
return $! if null newTs then [] else [UpdSpotTile lid newTs]
UpdAlterSmell lid p fromSm _toSm -> do
lvl <- getLevel lid
let msml = EM.lookup p $ lsmell lvl
return $ if msml /= fromSm then
[UpdAlterSmell lid p msml fromSm, cmd]
else
[cmd]
UpdDiscover lid p iid _ seed -> do
itemD <- getsState sitemD
case EM.lookup iid itemD of
Nothing -> return []
Just item -> do
discoKind <- getsClient sdiscoKind
if jkindIx item `EM.member` discoKind
then do
discoEffect <- getsClient sdiscoEffect
if iid `EM.member` discoEffect
then return []
else return [UpdDiscoverSeed lid p iid seed]
else return [cmd]
UpdCover lid p iid ik _ -> do
itemD <- getsState sitemD
case EM.lookup iid itemD of
Nothing -> return []
Just item -> do
discoKind <- getsClient sdiscoKind
if jkindIx item `EM.notMember` discoKind
then return []
else do
discoEffect <- getsClient sdiscoEffect
if iid `EM.notMember` discoEffect
then return [cmd]
else return [UpdCoverKind lid p iid ik]
UpdDiscoverKind _ _ iid _ -> do
itemD <- getsState sitemD
case EM.lookup iid itemD of
Nothing -> return []
Just item -> do
discoKind <- getsClient sdiscoKind
if jkindIx item `EM.notMember` discoKind
then return []
else return [cmd]
UpdCoverKind _ _ iid _ -> do
itemD <- getsState sitemD
case EM.lookup iid itemD of
Nothing -> return []
Just item -> do
discoKind <- getsClient sdiscoKind
if jkindIx item `EM.notMember` discoKind
then return []
else return [cmd]
UpdDiscoverSeed _ _ iid _ -> do
itemD <- getsState sitemD
case EM.lookup iid itemD of
Nothing -> return []
Just item -> do
discoKind <- getsClient sdiscoKind
if jkindIx item `EM.notMember` discoKind
then return []
else do
discoEffect <- getsClient sdiscoEffect
if iid `EM.member` discoEffect
then return []
else return [cmd]
UpdCoverSeed _ _ iid _ -> do
itemD <- getsState sitemD
case EM.lookup iid itemD of
Nothing -> return []
Just item -> do
discoKind <- getsClient sdiscoKind
if jkindIx item `EM.notMember` discoKind
then return []
else do
discoEffect <- getsClient sdiscoEffect
if iid `EM.notMember` discoEffect
then return []
else return [cmd]
UpdPerception lid outPer inPer -> do
perOld <- getPerFid lid
perception lid outPer inPer
perNew <- getPerFid lid
s <- getState
fid <- getsClient sside
let outFov = totalVisible perOld ES.\\ totalVisible perNew
outPrio = concatMap (\p -> posToActors p lid s) $ ES.elems outFov
fActor ((aid, b), ais) =
if not (bproj b) && bfid b == fid
then Nothing
else Just $ UpdLoseActor aid b ais
outActor = mapMaybe fActor outPrio
lvl <- getLevel lid
let inFov = ES.elems $ totalVisible perNew ES.\\ totalVisible perOld
pMaybe p = maybe Nothing (\x -> Just (p, x))
inContainer fc itemFloor =
let inItem = mapMaybe (\p -> pMaybe p $ EM.lookup p itemFloor) inFov
fItem p (iid, kit) =
UpdLoseItem iid (getItemBody iid s) kit (fc lid p)
fBag (p, bag) = map (fItem p) $ EM.assocs bag
in concatMap fBag inItem
inFloor = inContainer CFloor (lfloor lvl)
inEmbed = inContainer CEmbed (lembed lvl)
let inSmellFov = smellVisible perNew ES.\\ smellVisible perOld
inSm = mapMaybe (\p -> pMaybe p $ EM.lookup p (lsmell lvl))
(ES.elems inSmellFov)
inSmell = if null inSm then [] else [UpdLoseSmell lid inSm]
let seenNew = seenAtomicCli False fid perNew
seenOld = seenAtomicCli False fid perOld
psActor <- mapM posUpdAtomic outActor
assert (allB seenOld psActor) skip
assert (allB (not . seenNew) psActor) skip
let inTileSmell = inFloor ++ inEmbed ++ inSmell
psItemSmell <- mapM posUpdAtomic inTileSmell
assert (allB (not . seenOld) psItemSmell) skip
assert (allB seenNew psItemSmell) skip
return $! cmd : outActor ++ inTileSmell
_ -> return [cmd]
deleteSmell :: MonadClient m => ActorId -> Point -> m [UpdAtomic]
deleteSmell aid pos = do
b <- getsState $ getActorBody aid
smellRadius <- sumOrganEqpClient IK.EqpSlotAddSmell aid
if smellRadius <= 0 then return []
else do
lvl <- getLevel $ blid b
let msml = EM.lookup pos $ lsmell lvl
return $
maybe [] (\sml -> [UpdAlterSmell (blid b) pos (Just sml) Nothing]) msml
cmdAtomicSemCli :: MonadClient m => UpdAtomic -> m ()
cmdAtomicSemCli cmd = case cmd of
UpdCreateActor aid body _ -> createActor aid body
UpdDestroyActor aid b _ -> destroyActor aid b True
UpdSpotActor aid body _ -> createActor aid body
UpdLoseActor aid b _ -> destroyActor aid b False
UpdLeadFaction fid source target -> do
side <- getsClient sside
when (side == fid) $ do
mleader <- getsClient _sleader
assert (mleader == fmap fst source
|| mleader == fmap fst target
`blame` "unexpected leader" `twith` (cmd, mleader)) skip
modifyClient $ \cli -> cli {_sleader = fmap fst target}
case target of
Nothing -> return ()
Just (aid, mtgt) ->
modifyClient $ \cli ->
cli {stargetD = EM.alter (const $ (,Nothing) <$> mtgt)
aid (stargetD cli)}
UpdAutoFaction{} -> 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 }
UpdDiscover lid p iid ik seed -> do
discoverKind lid p iid ik
discoverSeed lid p iid seed
UpdCover lid p iid ik seed -> do
coverSeed lid p iid seed
coverKind lid p iid ik
UpdDiscoverKind lid p iid ik -> discoverKind lid p iid ik
UpdCoverKind lid p iid ik -> coverKind lid p iid ik
UpdDiscoverSeed lid p iid seed -> discoverSeed lid p iid seed
UpdCoverSeed lid p iid seed -> coverSeed lid p iid seed
UpdPerception lid outPer inPer -> perception lid outPer inPer
UpdRestart side sdiscoKind sfper _ sdebugCli sgameMode -> do
shistory <- getsClient shistory
sreport <- getsClient sreport
isAI <- getsClient sisAI
let cli = defStateClient shistory sreport side isAI
putClient cli { sdiscoKind
, sfper
, scurDifficulty = sdifficultyCli sdebugCli
, sgameMode
, sdebugCli }
UpdResume _fid sfper -> modifyClient $ \cli -> cli {sfper}
UpdKillExit _fid -> killExit
UpdWriteSave -> saveClient
_ -> return ()
createActor :: MonadClient m => ActorId -> Actor -> m ()
createActor aid _b = do
let affect tgt = case tgt of
TEnemyPos a _ _ permit | a == aid -> TEnemy a permit
_ -> tgt
affect3 (tgt, mpath) = case tgt of
TEnemyPos a _ _ permit | a == aid -> (TEnemy a permit, Nothing)
_ -> (tgt, mpath)
modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)}
modifyClient $ \cli -> cli {scursor = affect $ scursor cli}
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 -> TEnemyPos a (blid b) (bpos b) permit
_ -> tgt
affect3 (tgt, mpath) =
let newMPath = case mpath of
Just (_, (goal, _)) | goal /= bpos b -> Nothing
_ -> mpath
in (affect tgt, newMPath)
modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)}
modifyClient $ \cli -> cli {scursor = affect $ scursor cli}
perception :: MonadClient m => LevelId -> Perception -> Perception -> m ()
perception lid outPer inPer = do
perOld <- getPerFid lid
let interAlready per =
Just $ totalVisible per `ES.intersection` totalVisible perOld
unset = maybe False ES.null (interAlready inPer)
|| maybe False (not . ES.null) (interAlready outPer)
when unset $ do
let adj Nothing = assert `failure` "no perception to alter" `twith` 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
=> LevelId -> Point -> ItemId -> Kind.Id ItemKind -> m ()
discoverKind lid p iid ik = do
item <- getsState $ getItemBody iid
let f Nothing = Just ik
f Just{} = assert `failure` "already discovered"
`twith` (lid, p, iid, ik)
modifyClient $ \cli -> cli {sdiscoKind = EM.alter f (jkindIx item) (sdiscoKind cli)}
coverKind :: MonadClient m
=> LevelId -> Point -> ItemId -> Kind.Id ItemKind -> m ()
coverKind lid p iid ik = do
item <- getsState $ getItemBody iid
let f Nothing = assert `failure` "already covered" `twith` (lid, p, iid, ik)
f (Just ik2) = assert (ik == ik2 `blame` "unexpected covered item kind"
`twith` (ik, ik2)) Nothing
modifyClient $ \cli -> cli {sdiscoKind = EM.alter f (jkindIx item) (sdiscoKind cli)}
discoverSeed :: MonadClient m
=> LevelId -> Point -> ItemId -> ItemSeed -> m ()
discoverSeed lid p iid seed = do
Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops
discoKind <- getsClient sdiscoKind
item <- getsState $ getItemBody iid
Level{ldepth} <- getLevel (jlid item)
totalDepth <- getsState stotalDepth
case EM.lookup (jkindIx item) discoKind of
Nothing -> assert `failure` "kind not known"
`twith` (lid, p, iid, seed)
Just ik -> do
let kind = okind ik
f Nothing = Just $ seedToAspectsEffects seed kind ldepth totalDepth
f Just{} = assert `failure` "already discovered"
`twith` (lid, p, iid, seed)
modifyClient $ \cli -> cli {sdiscoEffect = EM.alter f iid (sdiscoEffect cli)}
coverSeed :: MonadClient m
=> LevelId -> Point -> ItemId -> ItemSeed -> m ()
coverSeed lid p iid ik = do
let f Nothing = assert `failure` "already covered" `twith` (lid, p, iid, ik)
f Just{} = Nothing
modifyClient $ \cli -> cli {sdiscoEffect = EM.alter f iid (sdiscoEffect cli)}
killExit :: MonadClient m => m ()
killExit = modifyClient $ \cli -> cli {squit = True}