module Game.LambdaHack.Client.UI.HandleHumanLocalClient
(
gameDifficultyCycle
, pickLeaderHuman, memberCycleHuman, memberBackHuman
, describeItemHuman, allOwnedHuman
, selectActorHuman, selectNoneHuman, clearHuman, repeatHuman, recordHuman
, historyHuman, markVisionHuman, markSmellHuman, markSuspectHuman
, helpHuman, mainMenuHuman, macroHuman
, moveCursorHuman, tgtFloorHuman, tgtEnemyHuman
, tgtUnknownHuman, tgtItemHuman, tgtStairHuman, tgtAscendHuman
, epsIncrHuman, tgtClearHuman, cancelHuman, acceptHuman
) where
import qualified Paths_LambdaHack as Self (version)
import Control.Exception.Assert.Sugar
import Control.Monad
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.List
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Monoid
import Data.Ord
import qualified Data.Text as T
import Data.Version
import Game.LambdaHack.Client.UI.Frontend (frontendName)
import qualified NLP.Miniutter.English as MU
import Game.LambdaHack.Client.BfsClient
import Game.LambdaHack.Client.CommonClient
import qualified Game.LambdaHack.Client.Key as K
import Game.LambdaHack.Client.MonadClient
import Game.LambdaHack.Client.State
import qualified Game.LambdaHack.Client.UI.HumanCmd as HumanCmd
import Game.LambdaHack.Client.UI.InventoryClient
import Game.LambdaHack.Client.UI.KeyBindings
import Game.LambdaHack.Client.UI.MonadClientUI
import Game.LambdaHack.Client.UI.MsgClient
import Game.LambdaHack.Client.UI.WidgetClient
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.ClientOptions
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 Game.LambdaHack.Common.ItemDescription
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.Request
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Common.Vector
import Game.LambdaHack.Content.ItemKind
import Game.LambdaHack.Content.RuleKind
import Game.LambdaHack.Content.TileKind
gameDifficultyCycle :: MonadClientUI m => m ()
gameDifficultyCycle = do
DebugModeCli{sdifficultyCli} <- getsClient sdebugCli
let d = if sdifficultyCli >= difficultyBound then 1 else sdifficultyCli + 1
modifyClient $ \cli -> cli {sdebugCli = (sdebugCli cli) {sdifficultyCli = d}}
msgAdd $ "Next game difficulty set to" <+> tshow d <> "."
pickLeaderHuman :: MonadClientUI m => Int -> m Slideshow
pickLeaderHuman k = do
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
arena <- getArenaUI
let (autoDun, autoLvl) = autoDungeonLevel fact
s <- getState
case tryFindHeroK s side k of
Nothing -> failMsg "No such member of the party."
Just (aid, b) ->
if blid b == arena && autoLvl
then failMsg $ showReqFailure NoChangeLvlLeader
else if autoDun
then failMsg $ showReqFailure NoChangeDunLeader
else do
void $ pickLeader True aid
return mempty
memberCycleHuman :: MonadClientUI m => m Slideshow
memberCycleHuman = memberCycle True
memberBackHuman :: MonadClientUI m => m Slideshow
memberBackHuman = memberBack True
describeItemHuman :: MonadClientUI m => CStore -> m Slideshow
describeItemHuman cstore = do
leader <- getLeaderUI
describeItemC $ CActor leader cstore
describeItemC :: MonadClientUI m => Container -> m Slideshow
describeItemC c = do
let subject body = partActor body
verbSha body activeItems = if calmEnough body activeItems
then "notice"
else "paw distractedly"
shaBlurb body activeItems = makePhrase
[MU.Capitalize
$ MU.SubjectVerbSg (subject body) (verbSha body activeItems)]
stdBlurb body = makePhrase
[MU.Capitalize $ MU.SubjectVerbSg (subject body) "see"]
itemToF <- itemToFullClient
let verb = "describe"
ggi <- getStoreItem shaBlurb stdBlurb verb c
case ggi of
Right ((iid, _), _) ->
overlayToSlideshow "" $ itemDesc (storeFromC c) (itemToF iid 1)
Left slides -> return slides
allOwnedHuman :: MonadClientUI m => m Slideshow
allOwnedHuman = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
describeItemC $ CTrunk (bfid b) (blid b) (bpos b)
selectActorHuman :: MonadClientUI m => m Slideshow
selectActorHuman = do
leader <- getLeaderUI
body <- getsState $ getActorBody leader
wasMemeber <- getsClient $ ES.member leader . sselected
let upd = if wasMemeber
then ES.delete leader
else ES.insert leader
modifyClient $ \cli -> cli {sselected = upd $ sselected cli}
let subject = partActor body
msgAdd $ makeSentence [subject, if wasMemeber
then "deselected"
else "selected"]
return mempty
selectNoneHuman :: (MonadClientUI m, MonadClient m) => m ()
selectNoneHuman = do
side <- getsClient sside
lidV <- viewedLevel
oursAssocs <- getsState $ actorRegularAssocs (== side) lidV
let ours = ES.fromList $ map fst oursAssocs
oldSel <- getsClient sselected
let wasNone = ES.null $ ES.intersection ours oldSel
upd = if wasNone
then ES.union
else ES.difference
modifyClient $ \cli -> cli {sselected = upd (sselected cli) ours}
let subject = "all party members on the level"
msgAdd $ makeSentence [subject, if wasNone
then "selected"
else "deselected"]
clearHuman :: Monad m => m ()
clearHuman = return ()
repeatHuman :: MonadClient m => Int -> m ()
repeatHuman n = do
(_, seqPrevious, k) <- getsClient slastRecord
let macro = concat $ replicate n $ reverse seqPrevious
modifyClient $ \cli -> cli {slastPlay = macro ++ slastPlay cli}
let slastRecord = ([], [], if k == 0 then 0 else maxK)
modifyClient $ \cli -> cli {slastRecord}
maxK :: Int
maxK = 100
recordHuman :: MonadClientUI m => m Slideshow
recordHuman = do
(_seqCurrent, seqPrevious, k) <- getsClient slastRecord
case k of
0 -> do
let slastRecord = ([], [], maxK)
modifyClient $ \cli -> cli {slastRecord}
promptToSlideshow $ "Macro will be recorded for up to"
<+> tshow maxK <+> "steps."
_ -> do
let slastRecord = (seqPrevious, [], 0)
modifyClient $ \cli -> cli {slastRecord}
promptToSlideshow $ "Macro recording interrupted after"
<+> tshow (maxK k 1) <+> "steps."
historyHuman :: MonadClientUI m => m Slideshow
historyHuman = do
history <- getsClient shistory
arena <- getArenaUI
local <- getsState $ getLocalTime arena
global <- getsState stime
let msg = makeSentence
[ "You survived for"
, MU.CarWs (global `timeFitUp` timeTurn) "half-second turn"
, "(this level:"
, MU.Text (tshow (local `timeFitUp` timeTurn)) MU.:> ")" ]
<+> "Past messages:"
overlayToBlankSlideshow msg $ renderHistory history
markVisionHuman :: MonadClientUI m => m ()
markVisionHuman = do
modifyClient toggleMarkVision
cur <- getsClient smarkVision
msgAdd $ "Visible area display toggled" <+> if cur then "on." else "off."
markSmellHuman :: MonadClientUI m => m ()
markSmellHuman = do
modifyClient toggleMarkSmell
cur <- getsClient smarkSmell
msgAdd $ "Smell display toggled" <+> if cur then "on." else "off."
markSuspectHuman :: MonadClientUI m => m ()
markSuspectHuman = do
modifyClient toggleMarkSuspect
cur <- getsClient smarkSuspect
msgAdd $ "Suspect terrain display toggled" <+> if cur then "on." else "off."
helpHuman :: MonadClientUI m => m Slideshow
helpHuman = do
keyb <- askBinding
return $! keyHelp keyb
mainMenuHuman :: MonadClientUI m => m Slideshow
mainMenuHuman = do
Kind.COps{corule} <- getsState scops
Binding{brevMap, bcmdList} <- askBinding
scurDifficulty <- getsClient scurDifficulty
DebugModeCli{sdifficultyCli} <- getsClient sdebugCli
let stripFrame t = map (T.tail . T.init) $ tail . init $ T.lines t
pasteVersion art =
let pathsVersion = rpathsVersion $ Kind.stdRuleset corule
version = " Version " ++ showVersion pathsVersion
++ " (frontend: " ++ frontendName
++ ", engine: LambdaHack " ++ showVersion Self.version
++ ") "
versionLen = length version
in init art ++ [take (80 versionLen) (last art) ++ version]
kds =
let showKD cmd km = (K.showKM km, HumanCmd.cmdDescription cmd)
revLookup cmd = maybe ("", "") (showKD cmd) $ M.lookup cmd brevMap
cmds = [ (K.showKM km, desc)
| (km, (desc, [HumanCmd.CmdMenu], cmd)) <- bcmdList,
cmd /= HumanCmd.GameDifficultyCycle ]
in [
(fst (revLookup HumanCmd.Cancel), "back to playing")
, (fst (revLookup HumanCmd.Accept), "see more help")
]
++ cmds
++ [ (fst ( revLookup HumanCmd.GameDifficultyCycle)
, "next game difficulty"
<+> tshow sdifficultyCli
<+> "(current"
<+> tshow scurDifficulty <> ")" ) ]
bindingLen = 25
bindings =
let fmt (k, d) = T.justifyLeft bindingLen ' '
$ T.justifyLeft 7 ' ' k <> " " <> d
in map fmt kds
overwrite =
let over [] line = ([], T.pack line)
over bs@(binding : bsRest) line =
let (prefix, lineRest) = break (=='{') line
(braces, suffix) = span (=='{') lineRest
in if length braces == 25
then (bsRest, T.pack prefix <> binding
<> T.drop (T.length binding bindingLen)
(T.pack suffix))
else (bs, T.pack line)
in snd . mapAccumL over bindings
mainMenuArt = rmainMenuArt $ Kind.stdRuleset corule
menuOverlay =
overwrite $ pasteVersion $ map T.unpack $ stripFrame mainMenuArt
case menuOverlay of
[] -> assert `failure` "empty Main Menu overlay" `twith` mainMenuArt
hd : tl -> overlayToBlankSlideshow hd (toOverlay tl)
macroHuman :: MonadClient m => [String] -> m ()
macroHuman kms =
modifyClient $ \cli -> cli {slastPlay = map K.mkKM kms ++ slastPlay cli}
moveCursorHuman :: MonadClientUI m => Vector -> Int -> m Slideshow
moveCursorHuman dir n = do
leader <- getLeaderUI
stgtMode <- getsClient stgtMode
let lidV = maybe (assert `failure` leader) tgtLevelId stgtMode
Level{lxsize, lysize} <- getLevel lidV
lpos <- getsState $ bpos . getActorBody leader
scursor <- getsClient scursor
cursorPos <- cursorToPos
let cpos = fromMaybe lpos cursorPos
shiftB pos = shiftBounded lxsize lysize pos dir
newPos = iterate shiftB cpos !! n
if newPos == cpos then failMsg "never mind"
else do
let tgt = case scursor of
TVector{} -> TVector $ newPos `vectorToFrom` lpos
_ -> TPoint lidV newPos
modifyClient $ \cli -> cli {scursor = tgt}
doLook
doLook :: MonadClientUI m => m Slideshow
doLook = do
Kind.COps{cotile=Kind.Ops{ouniqGroup}} <- getsState scops
let unknownId = ouniqGroup "unknown space"
stgtMode <- getsClient stgtMode
case stgtMode of
Nothing -> return mempty
Just tgtMode -> do
leader <- getLeaderUI
let lidV = tgtLevelId tgtMode
lvl <- getLevel lidV
cursorPos <- cursorToPos
per <- getPerFid lidV
b <- getsState $ getActorBody leader
let p = fromMaybe (bpos b) cursorPos
canSee = ES.member p (totalVisible per)
inhabitants <- if canSee
then getsState $ posToActors p lidV
else return []
seps <- getsClient seps
mnewEps <- makeLine b p seps
itemToF <- itemToFullClient
let aims = isJust mnewEps
enemyMsg = case inhabitants of
[] -> ""
((_, body), _) : rest ->
let subjects = map (partActor . snd . fst) inhabitants
subject = MU.WWandW subjects
verb = "be here"
desc = if not (null rest)
then ""
else case itemDisco $ itemToF (btrunk body) 1 of
Nothing -> ""
Just ItemDisco{itemKind} -> idesc itemKind
pdesc = if desc == "" then "" else "(" <> desc <> ")"
in makeSentence [MU.SubjectVerbSg subject verb] <+> pdesc
vis | lvl `at` p == unknownId = "that is"
| not canSee = "you remember"
| not aims = "you are aware of"
| otherwise = "you see"
lookMsg <- lookAt True vis canSee p leader enemyMsg
let is = lvl `atI` p
if EM.size is <= 2 then
promptToSlideshow lookMsg
else do
msgAdd lookMsg
floorItemOverlay lidV p
floorItemOverlay :: MonadClientUI m => LevelId -> Point -> m Slideshow
floorItemOverlay lid p = describeItemC (CFloor lid p)
tgtFloorHuman :: MonadClientUI m => m Slideshow
tgtFloorHuman = do
lidV <- viewedLevel
leader <- getLeaderUI
lpos <- getsState $ bpos . getActorBody leader
cursorPos <- cursorToPos
scursor <- getsClient scursor
stgtMode <- getsClient stgtMode
bsAll <- getsState $ actorAssocs (const True) lidV
let cursor = fromMaybe lpos cursorPos
tgt = case scursor of
_ | isNothing stgtMode ->
scursor
TEnemy a True -> TEnemy a False
TEnemy{} -> TPoint lidV cursor
TEnemyPos{} -> TPoint lidV cursor
TPoint{} -> TVector $ cursor `vectorToFrom` lpos
TVector{} ->
case find (\(_, m) -> Just (bpos m) == cursorPos) bsAll of
Just (im, _) -> TEnemy im True
Nothing -> TPoint lidV cursor
modifyClient $ \cli -> cli {scursor = tgt, stgtMode = Just $ TgtMode lidV}
doLook
tgtEnemyHuman :: MonadClientUI m => m Slideshow
tgtEnemyHuman = do
lidV <- viewedLevel
leader <- getLeaderUI
lpos <- getsState $ bpos . getActorBody leader
cursorPos <- cursorToPos
scursor <- getsClient scursor
stgtMode <- getsClient stgtMode
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
bsAll <- getsState $ actorAssocs (const True) lidV
let ordPos (_, b) = (chessDist lpos $ bpos b, bpos b)
dbs = sortBy (comparing ordPos) bsAll
pickUnderCursor =
let i = fromMaybe (1)
$ findIndex ((== cursorPos) . Just . bpos . snd) dbs
in splitAt i dbs
(permitAnyActor, (lt, gt)) = case scursor of
TEnemy a permit | isJust stgtMode ->
let i = fromMaybe (1) $ findIndex ((== a) . fst) dbs
in (permit, splitAt (i + 1) dbs)
TEnemy a permit ->
let i = fromMaybe (1) $ findIndex ((== a) . fst) dbs
in (permit, splitAt i dbs)
TEnemyPos _ _ _ permit -> (permit, pickUnderCursor)
_ -> (False, pickUnderCursor)
gtlt = gt ++ lt
isEnemy b = isAtWar fact (bfid b)
&& not (bproj b)
lf = filter (isEnemy . snd) gtlt
tgt | permitAnyActor = case gtlt of
(a, _) : _ -> TEnemy a True
[] -> scursor
| otherwise = case lf of
(a, _) : _ -> TEnemy a False
[] -> scursor
modifyClient $ \cli -> cli {scursor = tgt, stgtMode = Just $ TgtMode lidV}
doLook
tgtUnknownHuman :: MonadClientUI m => m Slideshow
tgtUnknownHuman = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
mpos <- closestUnknown leader
case mpos of
Nothing -> failMsg "no more unknown spots left"
Just p -> do
let tgt = TPoint (blid b) p
modifyClient $ \cli -> cli {scursor = tgt}
doLook
tgtItemHuman :: MonadClientUI m => m Slideshow
tgtItemHuman = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
items <- closestItems leader
case items of
[] -> failMsg "no more items remembered or visible"
(_, (p, _)) : _ -> do
let tgt = TPoint (blid b) p
modifyClient $ \cli -> cli {scursor = tgt}
doLook
tgtStairHuman :: MonadClientUI m => Bool -> m Slideshow
tgtStairHuman up = do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
stairs <- closestTriggers (Just up) False leader
case stairs of
[] -> failMsg $ "no stairs"
<+> if up then "up" else "down"
p : _ -> do
let tgt = TPoint (blid b) p
modifyClient $ \cli -> cli {scursor = tgt}
doLook
tgtAscendHuman :: MonadClientUI m => Int -> m Slideshow
tgtAscendHuman k = do
Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops
dungeon <- getsState sdungeon
scursorOld <- getsClient scursor
cursorPos <- cursorToPos
lidV <- viewedLevel
lvl <- getLevel lidV
let rightStairs = case cursorPos of
Nothing -> Nothing
Just cpos ->
let tile = lvl `at` cpos
in if Tile.hasFeature cotile (F.Cause $ Effect.Ascend k) tile
then Just cpos
else Nothing
case rightStairs of
Just cpos -> do
(nln, npos) <- getsState $ whereTo lidV cpos k . sdungeon
assert (nln /= lidV `blame` "stairs looped" `twith` nln) skip
nlvl <- getLevel nln
let ascDesc (F.Cause (Effect.Ascend _)) = True
ascDesc _ = False
scursor =
if any ascDesc $ tfeature $ okind (nlvl `at` npos)
then TPoint nln npos
else scursorOld
modifyClient $ \cli -> cli {scursor, stgtMode = Just (TgtMode nln)}
doLook
Nothing ->
case ascendInBranch dungeon k lidV of
[] -> failMsg "no more levels in this direction"
nln : _ -> do
modifyClient $ \cli -> cli {stgtMode = Just (TgtMode nln)}
doLook
epsIncrHuman :: MonadClientUI m => Bool -> m Slideshow
epsIncrHuman b = do
stgtMode <- getsClient stgtMode
if isJust stgtMode
then do
modifyClient $ \cli -> cli {seps = seps cli + if b then 1 else 1}
return mempty
else failMsg "never mind"
tgtClearHuman :: MonadClientUI m => m Slideshow
tgtClearHuman = do
leader <- getLeaderUI
tgt <- getsClient $ getTarget leader
case tgt of
Just _ -> do
modifyClient $ updateTarget leader (const Nothing)
return mempty
Nothing -> do
scursorOld <- getsClient scursor
b <- getsState $ getActorBody leader
let scursor = case scursorOld of
TEnemy _ permit -> TEnemy leader permit
TEnemyPos _ _ _ permit -> TEnemy leader permit
TPoint{} -> TPoint (blid b) (bpos b)
TVector{} -> TVector (Vector 0 0)
modifyClient $ \cli -> cli {scursor}
doLook
cancelHuman :: MonadClientUI m => m Slideshow -> m Slideshow
cancelHuman h = do
stgtMode <- getsClient stgtMode
if isJust stgtMode
then targetReject
else h
targetReject :: MonadClientUI m => m Slideshow
targetReject = do
modifyClient $ \cli -> cli {stgtMode = Nothing}
failMsg "targeting canceled"
acceptHuman :: MonadClientUI m => m Slideshow -> m Slideshow
acceptHuman h = do
stgtMode <- getsClient stgtMode
if isJust stgtMode
then do
targetAccept
return mempty
else h
targetAccept :: MonadClientUI m => m ()
targetAccept = do
endTargeting
endTargetingMsg
modifyClient $ \cli -> cli {stgtMode = Nothing}
endTargeting :: MonadClientUI m => m ()
endTargeting = do
leader <- getLeaderUI
scursor <- getsClient scursor
modifyClient $ updateTarget leader $ const $ Just scursor
endTargetingMsg :: MonadClientUI m => m ()
endTargetingMsg = do
leader <- getLeaderUI
(targetMsg, _) <- targetDescLeader leader
subject <- partAidLeader leader
msgAdd $ makeSentence [MU.SubjectVerbSg subject "target", MU.Text targetMsg]