module Game.LambdaHack.Client.HumanLocal
(
moveCursor, retargetLeader
, selectHeroHuman, memberCycleHuman, memberBackHuman
, inventoryHuman, tgtFloorLeader, tgtEnemyLeader, tgtAscendHuman
, epsIncrHuman, cancelHuman, displayMainMenu, acceptHuman, clearHuman
, historyHuman, humanMarkVision, humanMarkSmell, humanMarkSuspect
, helpHuman
, endTargeting, floorItemOverlay, itemOverlay, viewedLevel, selectLeader
, stopRunning, lookAt
) where
import qualified Paths_LambdaHack as Self (version)
import Control.Monad
import Control.Monad.Writer.Strict (WriterT, tell)
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.Function
import Data.List
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Ord
import Data.Text (Text)
import qualified Data.Text as T
import Data.Version
import Game.LambdaHack.Frontend (frontendName)
import qualified NLP.Miniutter.English as MU
import Game.LambdaHack.Client.Action
import Game.LambdaHack.Client.Binding
import qualified Game.LambdaHack.Client.HumanCmd as HumanCmd
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.Perception
import Game.LambdaHack.Common.Point
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.RuleKind
import Game.LambdaHack.Utils.Assert
moveCursor :: MonadClientUI m => Vector -> Int -> WriterT Slideshow m ()
moveCursor dir n = do
leader <- getLeaderUI
lpos <- getsState $ bpos . getActorBody leader
scursor <- getsClient scursor
let cpos = fromMaybe lpos scursor
Level{lxsize, lysize} <- cursorLevel
let shiftB pos = shiftBounded lxsize (1, 1, lxsize 2, lysize 2) pos dir
modifyClient $ \cli -> cli {scursor = Just $ iterate shiftB cpos !! n}
doLook
cursorLevel :: MonadClient m => m Level
cursorLevel = do
dungeon <- getsState sdungeon
stgtMode <- getsClient stgtMode
let tgtId =
maybe (assert `failure` "not targetting right now") tgtLevelId stgtMode
return $! dungeon EM.! tgtId
viewedLevel :: MonadClientUI m => m (LevelId, Level)
viewedLevel = do
arena <- getArenaUI
dungeon <- getsState sdungeon
stgtMode <- getsClient stgtMode
let tgtId = maybe arena tgtLevelId stgtMode
return (tgtId, dungeon EM.! tgtId)
lookAt :: MonadClientUI m
=> Bool
-> Bool
-> Point
-> ActorId
-> Text
-> m Text
lookAt detailed canSee pos aid msg = do
Kind.COps{coitem, cotile=Kind.Ops{oname}} <- getsState scops
(_, lvl) <- viewedLevel
subject <- partAidLeader aid
s <- getState
let is = lvl `atI` pos
verb = MU.Text $ if canSee then "see" else "remember"
disco <- getsClient sdisco
let nWs (iid, k) = partItemWs coitem disco k (getItemBody iid s)
isd = case detailed of
_ | EM.size is == 0 -> ""
_ | EM.size is <= 2 ->
makeSentence [ MU.SubjectVerbSg subject verb
, MU.WWandW $ map nWs $ EM.assocs is]
True -> "Objects:"
_ -> "Objects here."
if detailed
then let tile = lvl `at` pos
in return $! makeSentence [MU.Text $ oname tile] <+> msg <+> isd
else return $! msg <+> isd
doLook :: MonadClientUI m => WriterT Slideshow m ()
doLook = do
Kind.COps{coactor} <- getsState scops
scursor <- getsClient scursor
(lid, lvl) <- viewedLevel
per <- getPerFid lid
leader <- getLeaderUI
lpos <- getsState $ bpos . getActorBody leader
target <- getsClient $ getTarget leader
hms <- getsState $ actorList (const True) lid
let p = fromMaybe lpos scursor
canSee = ES.member p (totalVisible per)
ihabitant | canSee = find (\m -> bpos m == p) hms
| otherwise = Nothing
enemyMsg =
maybe "" (\m -> let subject = partActor coactor m
verb = "be here"
in makeSentence [MU.SubjectVerbSg subject verb])
ihabitant
vis | not $ p `ES.member` totalVisible per = " (not visible)"
| actorSeesLoc per leader p = ""
| otherwise = " (not visible)"
mode = case target of
Just TEnemy{} -> "[targeting foe" <> vis <> "]"
Just TPos{} -> "[targeting position" <> vis <> "]"
Nothing -> "[targeting current" <> vis <> "]"
is = lvl `atI` p
lookMsg <- lookAt True canSee p leader enemyMsg
modifyClient (\st -> st {slastKey = Nothing})
if EM.size is <= 2 then do
slides <- promptToSlideshow (mode <+> lookMsg)
tell slides
else do
io <- floorItemOverlay is
slides <- overlayToSlideshow (mode <+> lookMsg) io
tell slides
floorItemOverlay :: MonadClient m => ItemBag -> m Overlay
floorItemOverlay bag = do
Kind.COps{coitem} <- getsState scops
s <- getState
disco <- getsClient sdisco
let is = zip (EM.assocs bag) (allLetters ++ repeat (InvChar ' '))
pr ((iid, k), l) =
makePhrase [ letterLabel l
, partItemWs coitem disco k (getItemBody iid s) ]
<> " "
return $ map pr is
itemOverlay :: MonadClient m => ItemBag -> ItemInv -> m Overlay
itemOverlay bag inv = do
Kind.COps{coitem} <- getsState scops
s <- getState
disco <- getsClient sdisco
let checkItem (l, iid) = fmap (\k -> (l, iid, k)) $ EM.lookup iid bag
is = mapMaybe checkItem $ EM.assocs inv
pr (l, iid, k) =
makePhrase [ letterLabel l
, partItemWs coitem disco k (getItemBody iid s) ]
<> " "
return $ map pr is
retargetLeader :: MonadClientUI m => WriterT Slideshow m ()
retargetLeader = do
arena <- getArenaUI
msgAdd "Last target invalid."
modifyClient $ \cli -> cli {scursor = Nothing, seps = 0}
tgtEnemyLeader $ TgtAuto arena
selectHeroHuman :: (MonadClientAbort m, MonadClientUI m) => Int -> m ()
selectHeroHuman k = do
side <- getsClient sside
s <- getState
case tryFindHeroK s side k of
Nothing -> abortWith "No such member of the party."
Just (aid, _) -> void $ selectLeader aid
memberCycleHuman :: (MonadClientAbort m, MonadClientUI m) => m ()
memberCycleHuman = do
leader <- getLeaderUI
body <- getsState $ getActorBody leader
hs <- partyAfterLeader leader
case filter (\(_, b) -> blid b == blid body) hs of
[] -> abortWith "Cannot select any other member on this level."
(np, b) : _ -> do
success <- selectLeader np
assert (success `blame` (leader, np, b)) skip
partyAfterLeader :: MonadActionRO m
=> ActorId
-> m [(ActorId, Actor)]
partyAfterLeader leader = do
faction <- getsState $ bfid . getActorBody leader
allA <- getsState $ EM.assocs . sactorD
s <- getState
let hs9 = mapMaybe (tryFindHeroK s faction) [0..9]
factionA = filter (\(_, body) ->
not (bproj body) && bfid body == faction) allA
hs = hs9 ++ deleteFirstsBy ((==) `on` fst) factionA hs9
i = fromMaybe (1) $ findIndex ((== leader) . fst) hs
(lt, gt) = (take i hs, drop (i + 1) hs)
return $ gt ++ lt
selectLeader :: MonadClientUI m => ActorId -> m Bool
selectLeader actor = do
Kind.COps{coactor} <- getsState scops
leader <- getLeaderUI
stgtMode <- getsClient stgtMode
if leader == actor
then return False
else do
pbody <- getsState $ getActorBody actor
let subject = partActor coactor pbody
msgAdd $ makeSentence [subject, "selected"]
s <- getState
modifyClient $ updateLeader actor s
assert (not (bproj pbody) `blame` (actor, pbody)) skip
when (isJust stgtMode) $ setTgtId $ blid pbody
lookMsg <- lookAt False True (bpos pbody) actor ""
msgAdd lookMsg
stopRunning
return True
stopRunning :: MonadClient m => m ()
stopRunning = modifyClient (\ cli -> cli { srunning = Nothing })
memberBackHuman :: (MonadClientAbort m, MonadClientUI m) => m ()
memberBackHuman = do
leader <- getLeaderUI
hs <- partyAfterLeader leader
case reverse hs of
[] -> abortWith "No other member in the party."
(np, b) : _ -> do
success <- selectLeader np
assert (success `blame` (leader, np, b)) skip
inventoryHuman :: (MonadClientAbort m, MonadClientUI m)
=> WriterT Slideshow m ()
inventoryHuman = do
leader <- getLeaderUI
subject <- partAidLeader leader
bag <- getsState $ getActorBag leader
inv <- getsState $ getActorInv leader
if EM.null bag
then abortWith $ makeSentence
[ MU.SubjectVerbSg subject "be"
, "not carrying anything" ]
else do
let blurb = makePhrase
[MU.Capitalize $ MU.SubjectVerbSg subject "be carrying:"]
io <- itemOverlay bag inv
slides <- overlayToSlideshow blurb io
tell slides
tgtFloorLeader :: MonadClientUI m => TgtMode -> WriterT Slideshow m ()
tgtFloorLeader stgtModeNew = do
leader <- getLeaderUI
ppos <- getsState (bpos . getActorBody leader)
target <- getsClient $ getTarget leader
stgtMode <- getsClient stgtMode
let tgt = case target of
Just (TEnemy _ _) -> Nothing
_ | isJust stgtMode ->
Just (TPos ppos)
t -> t
modifyClient $ updateTarget leader (const tgt)
setCursor stgtModeNew
setCursor :: MonadClientUI m => TgtMode -> WriterT Slideshow m ()
setCursor stgtModeNew = do
stgtModeOld <- getsClient stgtMode
scursorOld <- getsClient scursor
sepsOld <- getsClient seps
scursor <- targetToPos
let seps = if scursor == scursorOld then sepsOld else 0
stgtMode = if isNothing stgtModeOld
then Just stgtModeNew
else stgtModeOld
modifyClient $ \cli2 -> cli2 {scursor, seps, stgtMode}
doLook
tgtEnemyLeader :: MonadClientUI m => TgtMode -> WriterT Slideshow m ()
tgtEnemyLeader stgtModeNew = do
leader <- getLeaderUI
ppos <- getsState (bpos . getActorBody leader)
(lid, Level{lxsize}) <- viewedLevel
per <- getPerFid lid
target <- getsClient $ getTarget leader
stgtMode <- getsClient stgtMode
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
ms <- getsState $ actorNotProjAssocs (isAtWar fact) lid
let plms = filter ((/= leader) . fst) ms
ordPos (_, m) = (chessDist lxsize ppos $ bpos m, bpos m)
dms = sortBy (comparing ordPos) plms
(lt, gt) = case target of
Just (TEnemy n _) | isJust stgtMode ->
let i = fromMaybe (1) $ findIndex ((== n) . fst) dms
in splitAt (i + 1) dms
Just (TEnemy n _) ->
let i = fromMaybe (1) $ findIndex ((== n) . fst) dms
in splitAt i dms
_ -> (dms, [])
gtlt = gt ++ lt
seen (_, m) =
let mpos = bpos m
in actorSeesLoc per leader mpos
lf = filter seen gtlt
tgt = case lf of
[] -> target
(na, nm) : _ -> Just (TEnemy na (bpos nm))
modifyClient $ updateTarget leader (const tgt)
setCursor stgtModeNew
tgtAscendHuman :: (MonadClientAbort m, MonadClientUI m)
=> Int -> WriterT Slideshow m ()
tgtAscendHuman k = do
Kind.COps{cotile} <- getsState scops
dungeon <- getsState sdungeon
s <- getState
cursor <- getsClient scursor
(tgtId, lvl) <- viewedLevel
let rightStairs = case cursor of
Nothing -> False
Just cpos ->
let tile = lvl `at` cpos
in k == 1
&& Tile.hasFeature cotile (F.Cause $ Effect.Ascend 1) tile
|| k == 1
&& Tile.hasFeature cotile (F.Cause $ Effect.Descend 1) tile
if rightStairs
then case whereTo s tgtId k of
Nothing ->
abortWith "no more levels in this direction"
Just (nln, npos) ->
assert (nln /= tgtId `blame` (nln, "stairs looped")) $ do
let scursor =
if Tile.hasFeature cotile F.Exit (lvl `at` npos)
then Just npos
else cursor
modifyClient $ \cli -> cli {scursor}
setTgtId nln
else
case ascendInBranch dungeon tgtId k of
[] -> abortWith "no more levels in this direction"
nln : _ -> setTgtId nln
doLook
setTgtId :: MonadClient m => LevelId -> m ()
setTgtId nln = do
stgtMode <- getsClient stgtMode
case stgtMode of
Just (TgtAuto _) ->
modifyClient $ \cli -> cli {stgtMode = Just (TgtAuto nln)}
_ ->
modifyClient $ \cli -> cli {stgtMode = Just (TgtExplicit nln)}
epsIncrHuman :: MonadClientAbort m => Bool -> m ()
epsIncrHuman b = do
stgtMode <- getsClient stgtMode
if isJust stgtMode
then modifyClient $ \cli -> cli {seps = seps cli + if b then 1 else 1}
else neverMind True
cancelHuman :: MonadClientUI m
=> WriterT Slideshow m () -> WriterT Slideshow m ()
cancelHuman h = do
stgtMode <- getsClient stgtMode
if isJust stgtMode
then endTargeting False
else h
displayMainMenu :: MonadClientUI m => WriterT Slideshow m ()
displayMainMenu = do
Kind.COps{corule} <- getsState scops
Binding{krevMap} <- askBinding
let stripFrame t = case T.uncons t of
Just ('\n', art) -> map (T.tail . T.init) $ tail . init $ T.lines art
_ -> assert `failure` "displayMainMenu:" <+> 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 krevMap
cmds = [ HumanCmd.GameSave
, HumanCmd.GameExit
, HumanCmd.GameRestart "campaign"
, HumanCmd.GameRestart "skirmish"
, HumanCmd.GameRestart "PvP"
, HumanCmd.GameRestart "Coop"
, HumanCmd.GameRestart "defense"
]
in [ (fst (revLookup HumanCmd.Cancel), "back to playing")
, (fst (revLookup HumanCmd.Accept), "see more help") ]
++ map revLookup cmds
bindings =
let bindingLen = 25
fmt (k, d) =
let gapLen = (8 T.length k) `max` 1
padLen = bindingLen T.length k gapLen T.length d
in k <> T.replicate gapLen " " <> d <> T.replicate padLen " "
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.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"
hd : tl -> do
slides <- overlayToSlideshow hd tl
tell slides
acceptHuman :: MonadClientUI m
=> WriterT Slideshow m () -> WriterT Slideshow m ()
acceptHuman h = do
stgtMode <- getsClient stgtMode
if isJust stgtMode
then endTargeting True
else h
endTargeting :: MonadClientUI m => Bool -> m ()
endTargeting accept = do
when accept $ do
leader <- getLeaderUI
target <- getsClient $ getTarget leader
scursor <- getsClient scursor
(lid, _) <- viewedLevel
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
ms <- getsState $ actorNotProjAssocs (isAtWar fact) lid
case target of
Just TEnemy{} ->
case find (\ (_im, m) -> Just (bpos m) == scursor) ms of
Just (im, m) ->
let tgt = Just $ TEnemy im (bpos m)
in modifyClient $ updateTarget leader (const tgt)
Nothing -> return ()
_ -> case scursor of
Nothing -> return ()
Just cpos ->
modifyClient $ updateTarget leader (const $ Just $ TPos cpos)
if accept
then endTargetingMsg
else msgAdd "targeting canceled"
modifyClient $ \cli -> cli { stgtMode = Nothing }
endTargetingMsg :: MonadClientUI m => m ()
endTargetingMsg = do
Kind.COps{coactor} <- getsState scops
leader <- getLeaderUI
pbody <- getsState $ getActorBody leader
target <- getsClient $ getTarget leader
s <- getState
Level{lxsize} <- cursorLevel
let targetMsg = case target of
Just (TEnemy a _ll) ->
if memActor a (blid pbody) s
then partActor coactor $ getActorBody a s
else "a fear of the past"
Just (TPos tpos) ->
MU.Text $ "position" <+> showPoint lxsize tpos
Nothing -> "current cursor position continuously"
subject <- partAidLeader leader
msgAdd $ makeSentence [MU.SubjectVerbSg subject "target", targetMsg]
clearHuman :: Monad m => m ()
clearHuman = return ()
historyHuman :: MonadClientUI m => WriterT Slideshow m ()
historyHuman = do
history <- getsClient shistory
arena <- getArenaUI
local <- getsState $ getLocalTime arena
global <- getsState stime
let msg = makeSentence
[ "You survived for"
, MU.CarWs (global `timeFit` timeTurn) "half-second turn"
, "(this level:"
, MU.Text (showT (local `timeFit` timeTurn)) MU.:> ")" ]
<+> "Past messages:"
slides <- overlayToSlideshow msg $ renderHistory history
tell slides
humanMarkVision :: MonadClientUI m => m ()
humanMarkVision = do
modifyClient toggleMarkVision
cur <- getsClient smarkVision
msgAdd $ "Visible area display toggled" <+> if cur then "on." else "off."
humanMarkSmell :: MonadClientUI m => m ()
humanMarkSmell = do
modifyClient toggleMarkSmell
cur <- getsClient smarkSmell
msgAdd $ "Smell display toggled" <+> if cur then "on." else "off."
humanMarkSuspect :: MonadClientUI m => m ()
humanMarkSuspect = do
modifyClient toggleMarkSuspect
cur <- getsClient smarkSuspect
msgAdd $ "Suspect terrain display toggled" <+> if cur then "on." else "off."
helpHuman :: MonadClientUI m => WriterT Slideshow m ()
helpHuman = do
keyb <- askBinding
tell $ keyHelp keyb