module Game.LambdaHack.Client.HumanGlobal
( moveLeader, exploreLeader, runLeader, waitHuman, pickupHuman, dropHuman
, projectLeader, applyHuman, triggerDirHuman, triggerTileHuman
, gameRestartHuman, gameExitHuman, gameSaveHuman, cfgDumpHuman
) where
import Control.Monad
import qualified Data.EnumMap.Strict as EM
import Data.Function
import Data.List
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified NLP.Miniutter.English as MU
import Game.LambdaHack.Client.Action
import Game.LambdaHack.Client.Draw
import Game.LambdaHack.Client.HumanCmd (Trigger (..))
import Game.LambdaHack.Client.HumanLocal
import Game.LambdaHack.Client.RunAction
import Game.LambdaHack.Client.State
import Game.LambdaHack.Common.Action
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import qualified Game.LambdaHack.Common.Effect as Effect
import Game.LambdaHack.Common.Faction
import qualified Game.LambdaHack.Common.Feature as F
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.Key as K
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Msg
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.Vector
import Game.LambdaHack.Content.TileKind as TileKind
import Game.LambdaHack.Utils.Assert
moveLeader :: MonadClientUI m => Vector -> m CmdSer
moveLeader dir = do
leader <- getLeaderUI
return $! MoveSer leader dir
exploreLeader :: MonadClientUI m => Vector -> m CmdSer
exploreLeader dir = do
leader <- getLeaderUI
return $! ExploreSer leader dir
runLeader :: MonadClientUI m => Vector -> m CmdSer
runLeader dir = do
leader <- getLeaderUI
canR <- canRun leader (dir, 0)
when canR $ modifyClient $ \cli -> cli {srunning = Just (dir, 1)}
return $! RunSer leader dir
waitHuman :: MonadClientUI m => m CmdSer
waitHuman = do
leader <- getLeaderUI
return $ WaitSer leader
pickupHuman :: (MonadClientAbort m, MonadClientUI m) => m CmdSer
pickupHuman = do
leader <- getLeaderUI
body <- getsState $ getActorBody leader
lvl <- getsLevel (blid body) id
case EM.minViewWithKey $ lvl `atI` bpos body of
Nothing -> abortWith "nothing here"
Just ((iid, k), _) -> do
item <- getsState $ getItemBody iid
let l = if jsymbol item == '$' then Just $ InvChar '$' else Nothing
case assignLetter iid l body of
Just l2 -> return $ PickupSer leader iid k l2
Nothing -> abortWith "cannot carry any more"
dropHuman :: (MonadClientAbort m, MonadClientUI m) => m CmdSer
dropHuman = do
Kind.COps{coitem} <- getsState scops
leader <- getLeaderUI
bag <- getsState $ getActorBag leader
inv <- getsState $ getActorInv leader
((iid, item), (_, container)) <-
getAnyItem leader "What to drop?" bag inv "in inventory"
case container of
CFloor{} -> neverMind True
CActor aid _ -> do
assert (aid == leader) skip
disco <- getsClient sdisco
subject <- partAidLeader leader
msgAdd $ makeSentence
[ MU.SubjectVerbSg subject "drop"
, partItemWs coitem disco 1 item ]
return $ DropSer leader iid
allObjectsName :: Text
allObjectsName = "Objects"
getAnyItem :: (MonadClientAbort m, MonadClientUI m)
=> ActorId
-> Text
-> ItemBag
-> ItemInv
-> Text
-> m ((ItemId, Item), (Int, Container))
getAnyItem leader prompt = getItem leader prompt (const True) allObjectsName
data ItemDialogState = INone | ISuitable | IAll deriving Eq
getItem :: (MonadClientAbort m, MonadClientUI m)
=> ActorId
-> Text
-> (Item -> Bool)
-> Text
-> ItemBag
-> ItemInv
-> Text
-> m ((ItemId, Item), (Int, Container))
getItem aid prompt p ptext bag inv isn = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
lvl <- getsLevel (blid b) id
s <- getState
body <- getsState $ getActorBody aid
let checkItem (l, iid) =
fmap (\k -> ((iid, getItemBody iid s), (k, l))) $ EM.lookup iid bag
is0 = mapMaybe checkItem $ EM.assocs inv
pos = bpos body
tis = lvl `atI` pos
floorFull = not $ EM.null tis
(floorMsg, floorKey) | floorFull = (", -", [K.Char '-'])
| otherwise = ("", [])
isp = filter (p . snd . fst) is0
bestFull = not $ null isp
(bestMsg, bestKey)
| bestFull =
let bestLetter = invChar $ maximum $ map (snd . snd) isp
in (", RET(" <> T.singleton bestLetter <> ")", [K.Return])
| otherwise = ("", [])
keys ims =
let mls = map (snd . snd) ims
ks = bestKey ++ floorKey ++ [K.Char '?']
++ map (K.Char . invChar) mls
in zipWith K.KM (repeat K.NoModifier) ks
choice ims =
if null ims
then "[?" <> floorMsg
else let mls = map (snd . snd) ims
r = letterRange mls
in "[" <> r <> ", ?" <> floorMsg <> bestMsg
ask = do
when (null is0 && EM.null tis) $
abortWith "Not carrying anything."
perform INone
invP = EM.filter (\iid -> p (getItemBody iid s)) inv
perform itemDialogState = do
let (ims, invOver, msg) = case itemDialogState of
INone -> (isp, EM.empty, prompt)
ISuitable -> (isp, invP, ptext <+> isn <> ".")
IAll -> (is0, inv, allObjectsName <+> isn <> ".")
io <- itemOverlay bag invOver
km@K.KM {..} <-
displayChoiceUI (msg <+> choice ims) io (keys ims)
assert (modifier == K.NoModifier) skip
case key of
K.Char '?' -> case itemDialogState of
INone -> perform ISuitable
ISuitable | ptext /= allObjectsName -> perform IAll
_ -> perform INone
K.Char '-' | floorFull ->
return $ maximumBy (compare `on` fst . fst)
$ map (\(iid, k) ->
((iid, getItemBody iid s),
(k, CFloor (blid b) pos)))
$ EM.assocs tis
K.Char l | InvChar l `elem` map (snd . snd) ims ->
case find ((InvChar l ==) . snd . snd) ims of
Nothing -> assert `failure` (l, ims)
Just (iidItem, (k, l2)) ->
return (iidItem, (k, CActor aid l2))
K.Return | bestFull ->
let (iidItem, (k, l2)) = maximumBy (compare `on` snd . snd) isp
in return (iidItem, (k, CActor aid l2))
_ -> assert `failure` "perform: unexpected key:" <+> K.showKM km
ask
projectLeader :: (MonadClientAbort m, MonadClientUI m)
=> [Trigger] -> m CmdSer
projectLeader ts = do
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
leader <- getLeaderUI
b <- getsState $ getActorBody leader
let lid = blid b
ms <- getsState $ actorNotProjList (isAtWar fact) lid
lxsize <- getsLevel lid lxsize
lysize <- getsLevel lid lysize
if foesAdjacent lxsize lysize (bpos b) ms
then abortWith "You can't aim in melee."
else actorProjectGI leader ts
actorProjectGI :: (MonadClientAbort m, MonadClientUI m)
=> ActorId -> [Trigger] -> m CmdSer
actorProjectGI aid ts = do
seps <- getsClient seps
target <- targetToPos
let (verb1, object1) = case ts of
[] -> ("aim", "object")
tr : _ -> (verb tr, object tr)
triggerSyms = triggerSymbols ts
case target of
Just p -> do
bag <- getsState $ getActorBag aid
inv <- getsState $ getActorInv aid
((iid, _), (_, container)) <-
getGroupItem aid bag inv object1 triggerSyms
(makePhrase ["What to", verb1 MU.:> "?"]) "in inventory"
stgtMode <- getsClient stgtMode
case stgtMode of
Just (TgtAuto _) -> endTargeting True
_ -> return ()
return $! ProjectSer aid p seps iid container
Nothing -> assert `failure` (aid, "target unexpectedly invalid")
triggerSymbols :: [Trigger] -> [Char]
triggerSymbols [] = []
triggerSymbols (ApplyItem{..} : ts) = symbol : triggerSymbols ts
triggerSymbols (_ : ts) = triggerSymbols ts
applyHuman :: (MonadClientAbort m, MonadClientUI m)
=> [Trigger] -> m CmdSer
applyHuman ts = do
leader <- getLeaderUI
bag <- getsState $ getActorBag leader
inv <- getsState $ getActorInv leader
let (verb1, object1) = case ts of
[] -> ("activate", "object")
tr : _ -> (verb tr, object tr)
triggerSyms = triggerSymbols ts
((iid, _), (_, container)) <-
getGroupItem leader bag inv object1 triggerSyms
(makePhrase ["What to", verb1 MU.:> "?"]) "in inventory"
return $! ApplySer leader iid container
getGroupItem :: (MonadClientAbort m, MonadClientUI m)
=> ActorId
-> ItemBag
-> ItemInv
-> MU.Part
-> [Char]
-> Text
-> Text
-> m ((ItemId, Item), (Int, Container))
getGroupItem leader is inv object syms prompt packName = do
let choice i = jsymbol i `elem` syms
header = makePhrase [MU.Capitalize (MU.Ws object)]
getItem leader prompt choice header is inv packName
triggerDirHuman :: (MonadClientAbort m, MonadClientUI m)
=> [Trigger] -> m CmdSer
triggerDirHuman ts = do
let verb1 = case ts of
[] -> "trigger"
tr : _ -> verb tr
keys = zipWith K.KM (repeat K.NoModifier) K.dirAllMoveKey
prompt = makePhrase ["What to", verb1 MU.:> "? [movement key"]
e <- displayChoiceUI prompt [] keys
leader <- getLeaderUI
b <- getsState $ getActorBody leader
let dpos dir = bpos b `shift` dir
lxsize <- getsLevel (blid b) lxsize
K.handleDir lxsize e (bumpTile leader ts . dpos) (neverMind True)
bumpTile :: (MonadClientAbort m, MonadClientUI m)
=> ActorId -> [Trigger] -> Point -> m CmdSer
bumpTile leader ts dpos = do
Kind.COps{cotile} <- getsState scops
b <- getsState $ getActorBody leader
lvl <- getsLevel (blid b) id
let t = lvl `at` dpos
triggerFeats = triggerFeatures ts
case filter (\feat -> Tile.hasFeature cotile feat t) triggerFeats of
[] -> guessBump cotile triggerFeats t
fs -> do
mapM_ (verifyTrigger leader) fs
return $ TriggerSer leader dpos
triggerFeatures :: [Trigger] -> [F.Feature]
triggerFeatures [] = []
triggerFeatures (BumpFeature{..} : ts) = feature : triggerFeatures ts
triggerFeatures (_ : ts) = triggerFeatures ts
verifyTrigger :: (MonadClientAbort m, MonadClientUI m)
=> ActorId -> F.Feature -> m ()
verifyTrigger leader feat = case feat of
F.Cause Effect.Escape -> do
b <- getsState $ getActorBody leader
side <- getsClient sside
spawn <- getsState $ isSpawnFaction side
summon <- getsState $ isSummonFaction side
when (spawn || summon) $ abortWith
"This is the way out, but where would you go in this alien world?"
go <- displayYesNo ColorFull "This is the way out. Really leave now?"
unless go $ abortWith "Game resumed."
(_, total) <- getsState $ calculateTotal b
when (total == 0) $ do
go1 <- displayMore ColorBW
"Afraid of the challenge? Leaving so soon and empty-handed?"
unless go1 $ abortWith "Brave soul!"
go2 <- displayMore ColorBW
"Next time try to grab some loot before escape!"
unless go2 $ abortWith "Here's your chance!"
_ -> return ()
guessBump :: MonadClientAbort m => Kind.Ops TileKind -> [F.Feature] -> Kind.Id TileKind -> m a
guessBump cotile (F.Openable : _) t | Tile.hasFeature cotile F.Closable t =
abortWith "already open"
guessBump _ (F.Openable : _) _ =
abortWith "not a door"
guessBump cotile (F.Closable : _) t | Tile.hasFeature cotile F.Openable t =
abortWith "already closed"
guessBump _ (F.Closable : _) _ =
abortWith "not a door"
guessBump cotile (F.Cause (Effect.Ascend _) : _) t
| Tile.hasFeature cotile F.Descendable t =
abortWith "the way goes down, not up"
guessBump _ (F.Cause (Effect.Ascend _) : _) _ =
abortWith "no stairs up"
guessBump cotile (F.Cause (Effect.Descend _) : _) t
| Tile.hasFeature cotile F.Ascendable t =
abortWith "the way goes up, not down"
guessBump _ (F.Cause (Effect.Descend _) : _) _ =
abortWith "no stairs down"
guessBump _ _ _ = neverMind True
triggerTileHuman :: (MonadClientAbort m, MonadClientUI m)
=> [Trigger] -> m CmdSer
triggerTileHuman ts = do
leader <- getLeaderUI
ppos <- getsState (bpos . getActorBody leader)
bumpTile leader ts ppos
gameRestartHuman :: (MonadClientAbort m, MonadClientUI m) => Text -> m CmdSer
gameRestartHuman t = do
let msg = "You just requested a new" <+> t <+> "game."
b1 <- displayMore ColorFull msg
unless b1 $ neverMind True
b2 <- displayYesNo ColorBW
"Current progress will be lost! Really restart the game?"
msg2 <- rndToAction $ oneOf
[ "Yea, would be a pity to leave them all to die."
, "Yea, a shame to get your own team stranded." ]
unless b2 $ abortWith msg2
leader <- getLeaderUI
return $ GameRestartSer leader t
gameExitHuman :: (MonadClientAbort m, MonadClientUI m) => m CmdSer
gameExitHuman = do
b <- displayYesNo ColorFull "Really save and exit?"
if b then do
leader <- getLeaderUI
return $ GameExitSer leader
else abortWith "Save and exit canceled."
gameSaveHuman :: MonadClientUI m => m CmdSer
gameSaveHuman = do
leader <- getLeaderUI
msgAdd "Saving game backup."
return $ GameSaveSer leader
cfgDumpHuman :: MonadClientUI m => m CmdSer
cfgDumpHuman = do
leader <- getLeaderUI
return $ CfgDumpSer leader