module Game.LambdaHack.Client.UI.InventoryClient
( Suitability(..)
, getGroupItem, getAnyItems, getStoreItem
, memberCycle, memberBack, pickLeader
, cursorPointerFloor, cursorPointerEnemy
, moveCursorHuman, tgtFloorHuman, tgtEnemyHuman, epsIncrHuman, tgtClearHuman
, doLook, describeItemC
) where
import Control.Applicative
import Control.Exception.Assert.Sugar
import Control.Monad
import Data.Char (intToDigit)
import qualified Data.Char as Char
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 Data.Text (Text)
import qualified Data.Text as T
import qualified NLP.Miniutter.English as MU
import Game.LambdaHack.Client.CommonClient
import Game.LambdaHack.Client.ItemSlot
import qualified Game.LambdaHack.Client.Key as K
import Game.LambdaHack.Client.MonadClient
import Game.LambdaHack.Client.State
import Game.LambdaHack.Client.UI.HumanCmd
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 qualified Game.LambdaHack.Common.Ability as Ability
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Item
import Game.LambdaHack.Common.ItemDescription
import Game.LambdaHack.Common.ItemStrongest
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 Game.LambdaHack.Common.Vector
import qualified Game.LambdaHack.Content.ItemKind as IK
data ItemDialogState = ISuitable | IAll | INoSuitable | INoAll
deriving (Show, Eq)
ppItemDialogMode :: ItemDialogMode -> (Text, Text)
ppItemDialogMode (MStore cstore) = ppCStore cstore
ppItemDialogMode MOwned = ("in", "our possession")
ppItemDialogMode MStats = ("among", "strenghts")
ppItemDialogModeIn :: ItemDialogMode -> Text
ppItemDialogModeIn c = let (tIn, t) = ppItemDialogMode c in tIn <+> t
ppItemDialogModeFrom :: ItemDialogMode -> Text
ppItemDialogModeFrom c = let (_tIn, t) = ppItemDialogMode c in "from" <+> t
storeFromMode :: ItemDialogMode -> CStore
storeFromMode c = case c of
MStore cstore -> cstore
MOwned -> CGround
MStats -> CGround
accessModeBag :: ActorId -> State -> ItemDialogMode -> ItemBag
accessModeBag leader s (MStore cstore) = getActorBag leader cstore s
accessModeBag leader s MOwned = let fid = bfid $ getActorBody leader s
in sharedAllOwnedFid False fid s
accessModeBag _ _ MStats = EM.empty
getGroupItem :: MonadClientUI m
=> m Suitability
-> Text
-> Text
-> Bool
-> [CStore]
-> [CStore]
-> m (SlideOrCmd ((ItemId, ItemFull), ItemDialogMode))
getGroupItem psuit prompt promptGeneric cursor cLegalRaw cLegalAfterCalm = do
let dialogState = if cursor then INoSuitable else ISuitable
soc <- getFull psuit
(\_ _ cCur -> prompt <+> ppItemDialogModeFrom cCur)
(\_ _ cCur -> promptGeneric <+> ppItemDialogModeFrom cCur)
cursor cLegalRaw cLegalAfterCalm True False dialogState
case soc of
Left sli -> return $ Left sli
Right ([(iid, itemFull)], c) -> return $ Right ((iid, itemFull), c)
Right _ -> assert `failure` soc
getAnyItems :: MonadClientUI m
=> MU.Part
-> [CStore]
-> [CStore]
-> Bool
-> Bool
-> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode))
getAnyItems verb cLegalRaw cLegalAfterCalm askWhenLone askNumber = do
let prompt _ _ cCur =
makePhrase ["What to", verb, MU.Text $ ppItemDialogModeFrom cCur]
soc <- getFull (return SuitsEverything)
prompt prompt False
cLegalRaw cLegalAfterCalm
askWhenLone True ISuitable
case soc of
Left _ -> return soc
Right ([(iid, itemFull)], c) -> do
socK <- pickNumber askNumber $ itemK itemFull
case socK of
Left slides -> return $ Left slides
Right k ->
return $ Right ([(iid, itemFull{itemK=k})], c)
Right _ -> return soc
getStoreItem :: MonadClientUI m
=> (Actor -> [ItemFull] -> ItemDialogMode -> Text)
-> ItemDialogMode
-> m (SlideOrCmd ((ItemId, ItemFull), ItemDialogMode))
getStoreItem prompt cInitial = do
let allCs = map MStore [CEqp, CInv, CSha]
++ [MOwned]
++ map MStore [CGround, COrgan]
++ [MStats]
(pre, rest) = break (== cInitial) allCs
post = dropWhile (== cInitial) rest
remCs = post ++ pre
soc <- getItem (return SuitsEverything)
prompt prompt False cInitial remCs
True False (cInitial:remCs) ISuitable
case soc of
Left sli -> return $ Left sli
Right ([(iid, itemFull)], c) -> return $ Right ((iid, itemFull), c)
Right _ -> assert `failure` soc
getFull :: MonadClientUI m
=> m Suitability
-> (Actor -> [ItemFull] -> ItemDialogMode -> Text)
-> (Actor -> [ItemFull] -> ItemDialogMode -> Text)
-> Bool
-> [CStore]
-> [CStore]
-> Bool
-> Bool
-> ItemDialogState
-> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode))
getFull psuit prompt promptGeneric cursor cLegalRaw cLegalAfterCalm
askWhenLone permitMulitple initalState = do
side <- getsClient sside
leader <- getLeaderUI
let aidNotEmpty store aid = do
bag <- getsState $ getCBag (CActor aid store)
return $! not $ EM.null bag
partyNotEmpty store = do
as <- getsState $ fidActorNotProjAssocs side
bs <- mapM (aidNotEmpty store . fst) as
return $! or bs
mpsuit <- psuit
let psuitFun = case mpsuit of
SuitsEverything -> const True
SuitsNothing _ -> const False
SuitsSomething f -> f
getCStoreBag <- getsState $ \s cstore -> getCBag (CActor leader cstore) s
let hasThisActor = not . EM.null . getCStoreBag
case filter hasThisActor cLegalAfterCalm of
[] ->
if isNothing (find hasThisActor cLegalRaw) then do
let contLegalRaw = map MStore cLegalRaw
tLegal = map (MU.Text . ppItemDialogModeIn) contLegalRaw
ppLegal = makePhrase [MU.WWxW "nor" tLegal]
failWith $ "no items" <+> ppLegal
else failSer ItemNotCalm
haveThis@(headThisActor : _) -> do
itemToF <- itemToFullClient
let suitsThisActor store =
let bag = getCStoreBag store
in any (\(iid, kit) -> psuitFun $ itemToF iid kit) $ EM.assocs bag
cThisActor cDef = case find suitsThisActor haveThis of
Nothing -> cDef
Just cSuits -> cSuits
cLegal <- filterM partyNotEmpty cLegalRaw
let breakStores cInit =
let (pre, rest) = break (== cInit) cLegal
post = dropWhile (== cInit) rest
in (MStore cInit, map MStore $ post ++ pre)
lastStore <- getsClient slastStore
firstStore <-
if lastStore `notElem` cLegalAfterCalm
then return $! cThisActor headThisActor
else do
(itemSlots, organSlots) <- getsClient sslots
let lSlots = if lastStore == COrgan then organSlots else itemSlots
lastSlot <- getsClient slastSlot
case EM.lookup lastSlot lSlots of
Nothing -> return $! cThisActor headThisActor
Just lastIid -> case EM.lookup lastIid $ getCStoreBag lastStore of
Nothing -> return $! cThisActor headThisActor
Just kit -> do
let lastItemFull = itemToF lastIid kit
lastSuits = psuitFun lastItemFull
cLast = cThisActor lastStore
return $! if lastSuits && cLast /= CGround
then lastStore
else cLast
let (modeFirst, modeRest) = breakStores firstStore
getItem psuit prompt promptGeneric cursor modeFirst modeRest
askWhenLone permitMulitple (map MStore $ cLegal) initalState
getItem :: MonadClientUI m
=> m Suitability
-> (Actor -> [ItemFull] -> ItemDialogMode -> Text)
-> (Actor -> [ItemFull] -> ItemDialogMode -> Text)
-> Bool
-> ItemDialogMode
-> [ItemDialogMode]
-> Bool
-> Bool
-> [ItemDialogMode]
-> ItemDialogState
-> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode))
getItem psuit prompt promptGeneric cursor cCur cRest askWhenLone permitMulitple
cLegal initalState = do
leader <- getLeaderUI
accessCBag <- getsState $ accessModeBag leader
let storeAssocs = EM.assocs . accessCBag
allAssocs = concatMap storeAssocs (cCur : cRest)
case (cRest, allAssocs) of
([], [(iid, k)]) | not askWhenLone -> do
itemToF <- itemToFullClient
return $ Right ([(iid, itemToF iid k)], cCur)
_ ->
transition psuit prompt promptGeneric cursor permitMulitple cLegal
0 cCur cRest initalState
data DefItemKey m = DefItemKey
{ defLabel :: Text
, defCond :: !Bool
, defAction :: K.KM -> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode))
}
data Suitability =
SuitsEverything
| SuitsNothing Msg
| SuitsSomething (ItemFull -> Bool)
transition :: forall m. MonadClientUI m
=> m Suitability
-> (Actor -> [ItemFull] -> ItemDialogMode -> Text)
-> (Actor -> [ItemFull] -> ItemDialogMode -> Text)
-> Bool
-> Bool
-> [ItemDialogMode]
-> Int
-> ItemDialogMode
-> [ItemDialogMode]
-> ItemDialogState
-> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode))
transition psuit prompt promptGeneric cursor permitMulitple cLegal
numPrefix cCur cRest itemDialogState = do
let recCall =
transition psuit prompt promptGeneric cursor permitMulitple cLegal
(itemSlots, organSlots) <- getsClient sslots
leader <- getLeaderUI
body <- getsState $ getActorBody leader
activeItems <- activeItemsClient leader
fact <- getsState $ (EM.! bfid body) . sfactionD
hs <- partyAfterLeader leader
bagAll <- getsState $ \s -> accessModeBag leader s cCur
lastSlot <- getsClient slastSlot
itemToF <- itemToFullClient
Binding{brevMap} <- askBinding
mpsuit <- psuit
(suitsEverything, psuitFun) <- case mpsuit of
SuitsEverything -> return (True, const True)
SuitsNothing err -> do
slides <- promptToSlideshow $ err <+> moreMsg
void $ getInitConfirms ColorFull [] $ slides <> toSlideshow Nothing [[]]
return (False, const False)
SuitsSomething f -> return (False, f)
let getSingleResult :: ItemId -> (ItemId, ItemFull)
getSingleResult iid = (iid, itemToF iid (bagAll EM.! iid))
getResult :: ItemId -> ([(ItemId, ItemFull)], ItemDialogMode)
getResult iid = ([getSingleResult iid], cCur)
getMultResult :: [ItemId] -> ([(ItemId, ItemFull)], ItemDialogMode)
getMultResult iids = (map getSingleResult iids, cCur)
filterP iid kit = psuitFun $ itemToF iid kit
bagAllSuit = EM.filterWithKey filterP bagAll
isOrgan = cCur == MStore COrgan
lSlots = if isOrgan then organSlots else itemSlots
bagItemSlotsAll = EM.filter (`EM.member` bagAll) lSlots
hasPrefixOpen x _ = slotPrefix x == numPrefix || numPrefix == 0
bagItemSlotsOpen = EM.filterWithKey hasPrefixOpen bagItemSlotsAll
hasPrefix x _ = slotPrefix x == numPrefix
bagItemSlots = EM.filterWithKey hasPrefix bagItemSlotsOpen
bag = EM.fromList $ map (\iid -> (iid, bagAll EM.! iid))
(EM.elems bagItemSlotsOpen)
suitableItemSlotsAll = EM.filter (`EM.member` bagAllSuit) lSlots
suitableItemSlotsOpen =
EM.filterWithKey hasPrefixOpen suitableItemSlotsAll
suitableItemSlots = EM.filterWithKey hasPrefix suitableItemSlotsOpen
bagSuit = EM.fromList $ map (\iid -> (iid, bagAllSuit EM.! iid))
(EM.elems suitableItemSlotsOpen)
(autoDun, autoLvl) = autoDungeonLevel fact
multipleSlots = if itemDialogState `elem` [IAll, INoAll]
then bagItemSlotsAll
else suitableItemSlotsAll
keyDefs :: [(K.KM, DefItemKey m)]
keyDefs = filter (defCond . snd) $
[ (K.toKM K.NoModifier $ K.Char '?', DefItemKey
{ defLabel = "?"
, defCond = not (EM.null bag)
, defAction = \_ -> recCall numPrefix cCur cRest
$ case itemDialogState of
INoSuitable -> if EM.null bagSuit then IAll else ISuitable
ISuitable -> if suitsEverything then INoAll else IAll
IAll -> if EM.null bag then INoSuitable else INoAll
INoAll -> if suitsEverything then ISuitable else INoSuitable
})
, (K.toKM K.NoModifier $ K.Char '/', DefItemKey
{ defLabel = "/"
, defCond = not $ null cRest
, defAction = \_ -> do
let calmE = calmEnough body activeItems
mcCur = filter (`elem` cLegal) [cCur]
(cCurAfterCalm, cRestAfterCalm) = case cRest ++ mcCur of
c1@(MStore CSha) : c2 : rest | not calmE ->
(c2, c1 : rest)
[MStore CSha] | not calmE -> assert `failure` cRest
c1 : rest -> (c1, rest)
[] -> assert `failure` cRest
recCall numPrefix cCurAfterCalm cRestAfterCalm itemDialogState
})
, (K.toKM K.NoModifier $ K.Char '*', DefItemKey
{ defLabel = "*"
, defCond = permitMulitple && not (EM.null multipleSlots)
, defAction = \_ ->
let eslots = EM.elems multipleSlots
in return $ Right $ getMultResult eslots
})
, (K.toKM K.NoModifier K.Return, DefItemKey
{ defLabel = if lastSlot `EM.member` labelItemSlotsOpen
then let l = makePhrase [slotLabel lastSlot]
in "RET(" <> l <> ")"
else "RET"
, defCond = not (EM.null labelItemSlotsOpen)
, defAction = \_ -> case EM.lookup lastSlot labelItemSlotsOpen of
Just iid -> return $ Right $ getResult iid
Nothing -> case EM.minViewWithKey labelItemSlotsOpen of
Nothing -> assert `failure` "labelItemSlotsOpen empty"
`twith` labelItemSlotsOpen
Just ((l, _), _) -> do
modifyClient $ \cli ->
cli { slastSlot = l
, slastStore = storeFromMode cCur }
recCall numPrefix cCur cRest itemDialogState
})
, let km = M.findWithDefault (K.toKM K.NoModifier K.Tab)
MemberCycle brevMap
in (km, DefItemKey
{ defLabel = K.showKM km
, defCond = not (cCur == MOwned
|| autoLvl
|| not (any (\(_, b) -> blid b == blid body) hs))
, defAction = \_ -> do
err <- memberCycle False
let !_A = assert (err == mempty `blame` err) ()
(cCurUpd, cRestUpd) <- legalWithUpdatedLeader cCur cRest
recCall numPrefix cCurUpd cRestUpd itemDialogState
})
, let km = M.findWithDefault (K.toKM K.NoModifier K.BackTab)
MemberBack brevMap
in (km, DefItemKey
{ defLabel = K.showKM km
, defCond = not (cCur == MOwned || autoDun || null hs)
, defAction = \_ -> do
err <- memberBack False
let !_A = assert (err == mempty `blame` err) ()
(cCurUpd, cRestUpd) <- legalWithUpdatedLeader cCur cRest
recCall numPrefix cCurUpd cRestUpd itemDialogState
})
, let km = M.findWithDefault (K.toKM K.NoModifier (K.KP '/'))
TgtFloor brevMap
in cursorCmdDef False km tgtFloorHuman
, let hackyCmd = Macro "" ["KP_Divide"]
km = M.findWithDefault (K.toKM K.NoModifier K.RightButtonPress)
hackyCmd brevMap
in cursorCmdDef False km tgtEnemyHuman
, let km = M.findWithDefault (K.toKM K.NoModifier (K.KP '*'))
TgtEnemy brevMap
in cursorCmdDef False km tgtEnemyHuman
, let hackyCmd = Macro "" ["KP_Multiply"]
km = M.findWithDefault (K.toKM K.NoModifier K.RightButtonPress)
hackyCmd brevMap
in cursorCmdDef False km tgtEnemyHuman
, let km = M.findWithDefault (K.toKM K.NoModifier K.BackSpace)
TgtClear brevMap
in cursorCmdDef False km tgtClearHuman
]
++ numberPrefixes
++ [ let plusMinus = K.Char $ if b then '+' else '-'
km = M.findWithDefault (K.toKM K.NoModifier plusMinus)
(EpsIncr b) brevMap
in cursorCmdDef False km (epsIncrHuman b)
| b <- [True, False]
]
++ arrows
++ [
let km = M.findWithDefault (K.toKM K.NoModifier K.MiddleButtonPress)
CursorPointerEnemy brevMap
in cursorCmdDef False km (cursorPointerEnemy False False)
, let km = M.findWithDefault (K.toKM K.Shift K.MiddleButtonPress)
CursorPointerFloor brevMap
in cursorCmdDef False km (cursorPointerFloor False False)
, let km = M.findWithDefault (K.toKM K.NoModifier K.RightButtonPress)
TgtPointerEnemy brevMap
in cursorCmdDef True km (cursorPointerEnemy True True)
]
prefixCmdDef d =
(K.toKM K.NoModifier $ K.Char (intToDigit d), DefItemKey
{ defLabel = ""
, defCond = True
, defAction = \_ ->
recCall (10 * numPrefix + d) cCur cRest itemDialogState
})
numberPrefixes = map prefixCmdDef [0..9]
cursorCmdDef verbose km cmd =
(km, DefItemKey
{ defLabel = "keypad, mouse"
, defCond = cursor && EM.null bagFiltered
, defAction = \_ -> do
look <- cmd
when verbose $
void $ getInitConfirms ColorFull []
$ look <> toSlideshow Nothing [[]]
recCall numPrefix cCur cRest itemDialogState
})
arrows =
let kCmds = K.moveBinding False False
(`moveCursorHuman` 1) (`moveCursorHuman` 10)
in map (uncurry $ cursorCmdDef False) kCmds
lettersDef :: DefItemKey m
lettersDef = DefItemKey
{ defLabel = slotRange $ EM.keys labelItemSlots
, defCond = True
, defAction = \K.KM{key} -> case key of
K.Char l -> case EM.lookup (SlotChar numPrefix l) bagItemSlots of
Nothing -> assert `failure` "unexpected slot"
`twith` (l, bagItemSlots)
Just iid -> return $ Right $ getResult iid
_ -> assert `failure` "unexpected key:" `twith` K.showKey key
}
(labelItemSlotsOpen, labelItemSlots, bagFiltered, promptChosen) =
case itemDialogState of
ISuitable -> (suitableItemSlotsOpen,
suitableItemSlots,
bagSuit,
prompt body activeItems cCur <> ":")
IAll -> (bagItemSlotsOpen,
bagItemSlots,
bag,
promptGeneric body activeItems cCur <> ":")
INoSuitable -> (suitableItemSlotsOpen,
suitableItemSlots,
EM.empty,
prompt body activeItems cCur <> ":")
INoAll -> (bagItemSlotsOpen,
bagItemSlots,
EM.empty,
promptGeneric body activeItems cCur <> ":")
io <- case cCur of
MStats -> statsOverlay leader
_ -> itemOverlay (storeFromMode cCur) (blid body) bagFiltered
runDefItemKey keyDefs lettersDef io bagItemSlots promptChosen
statsOverlay :: MonadClient m => ActorId -> m Overlay
statsOverlay aid = do
b <- getsState $ getActorBody aid
activeItems <- activeItemsClient aid
let block n = n + if braced b then 50 else 0
prSlot :: (IK.EqpSlot, Int -> Text) -> Text
prSlot (eqpSlot, f) =
let fullText t =
" "
<> makePhrase [ MU.Text $ T.justifyLeft 22 ' '
$ IK.slotName eqpSlot
, MU.Text t ]
<> " "
valueText = f $ sumSlotNoFilter eqpSlot activeItems
in fullText valueText
slotList =
[ (IK.EqpSlotAddHurtMelee, \t -> tshow t <> "%")
, (IK.EqpSlotAddArmorMelee, \t -> "[" <> tshow (block t) <> "%]")
, (IK.EqpSlotAddArmorRanged, \t -> "{" <> tshow (block t) <> "%}")
, (IK.EqpSlotAddMaxHP, \t -> tshow $ max 0 t)
, (IK.EqpSlotAddMaxCalm, \t -> tshow $ max 0 t)
, (IK.EqpSlotAddSpeed, \t -> tshow (max 0 t) <> "m/10s")
, (IK.EqpSlotAddSight, \t ->
tshow (max 0 $ min (fromIntegral $ bcalm b `div` (5 * oneM)) t)
<> "m")
, (IK.EqpSlotAddSmell, \t -> tshow (max 0 t) <> "m")
, (IK.EqpSlotAddLight, \t -> tshow (max 0 t) <> "m")
]
skills = sumSkills activeItems
prAbility :: Ability.Ability -> Text
prAbility ability =
let fullText t =
" "
<> makePhrase [ MU.Text $ T.justifyLeft 22 ' '
$ "ability" <+> tshow ability
, MU.Text t ]
<> " "
valueText = tshow $ EM.findWithDefault 0 ability skills
in fullText valueText
abilityList = [minBound..maxBound]
return $! toOverlay $ map prSlot slotList ++ map prAbility abilityList
legalWithUpdatedLeader :: MonadClientUI m
=> ItemDialogMode
-> [ItemDialogMode]
-> m (ItemDialogMode, [ItemDialogMode])
legalWithUpdatedLeader cCur cRest = do
leader <- getLeaderUI
let newLegal = cCur : cRest
b <- getsState $ getActorBody leader
activeItems <- activeItemsClient leader
let calmE = calmEnough b activeItems
legalAfterCalm = case newLegal of
c1@(MStore CSha) : c2 : rest | not calmE -> (c2, c1 : rest)
[MStore CSha] | not calmE -> (MStore CGround, newLegal)
c1 : rest -> (c1, rest)
[] -> assert `failure` (cCur, cRest)
return legalAfterCalm
runDefItemKey :: MonadClientUI m
=> [(K.KM, DefItemKey m)]
-> DefItemKey m
-> Overlay
-> EM.EnumMap SlotChar ItemId
-> Text
-> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode))
runDefItemKey keyDefs lettersDef io labelItemSlots prompt = do
let itemKeys =
let slotKeys = map (K.Char . slotChar) (EM.keys labelItemSlots)
defKeys = map fst keyDefs
in map (K.toKM K.NoModifier) slotKeys ++ defKeys
choice = let letterRange = defLabel lettersDef
keyLabelsRaw = letterRange : map (defLabel . snd) keyDefs
keyLabels = filter (not . T.null) keyLabelsRaw
in "[" <> T.intercalate ", " (nub keyLabels)
akm <- displayChoiceUI (prompt <+> choice) io itemKeys
case akm of
Left slides -> failSlides slides
Right km ->
case lookup km{K.pointer=dummyPoint} keyDefs of
Just keyDef -> defAction keyDef km
Nothing -> defAction lettersDef km
pickNumber :: MonadClientUI m => Bool -> Int -> m (SlideOrCmd Int)
pickNumber askNumber kAll = do
let kDefault = kAll
if askNumber && kAll > 1 then do
let tDefault = tshow kDefault
kbound = min 9 kAll
kprompt = "Choose number [1-" <> tshow kbound
<> ", RET(" <> tDefault <> ")"
kkeys = map (K.toKM K.NoModifier)
$ map (K.Char . Char.intToDigit) [1..kbound]
++ [K.Return]
kkm <- displayChoiceUI kprompt emptyOverlay kkeys
case kkm of
Left slides -> failSlides slides
Right K.KM{key} ->
case key of
K.Char l -> return $ Right $ Char.digitToInt l
K.Return -> return $ Right kDefault
_ -> assert `failure` "unexpected key:" `twith` kkm
else return $ Right kAll
memberCycle :: MonadClientUI m => Bool -> m Slideshow
memberCycle verbose = do
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
leader <- getLeaderUI
body <- getsState $ getActorBody leader
hs <- partyAfterLeader leader
let autoLvl = snd $ autoDungeonLevel fact
case filter (\(_, b) -> blid b == blid body) hs of
_ | autoLvl -> failMsg $ showReqFailure NoChangeLvlLeader
[] -> failMsg "cannot pick any other member on this level"
(np, b) : _ -> do
success <- pickLeader verbose np
let !_A = assert (success `blame` "same leader" `twith` (leader, np, b)) ()
return mempty
memberBack :: MonadClientUI m => Bool -> m Slideshow
memberBack verbose = do
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
leader <- getLeaderUI
hs <- partyAfterLeader leader
let autoDun = fst $ autoDungeonLevel fact
case reverse hs of
_ | autoDun -> failMsg $ showReqFailure NoChangeDunLeader
[] -> failMsg "no other member in the party"
(np, b) : _ -> do
success <- pickLeader verbose np
let !_A = assert (success `blame` "same leader" `twith` (leader, np, b)) ()
return mempty
partyAfterLeader :: MonadStateRead m => ActorId -> m [(ActorId, Actor)]
partyAfterLeader leader = do
faction <- getsState $ bfid . getActorBody leader
allA <- getsState $ EM.assocs . sactorD
let factionA = filter (\(_, body) ->
not (bproj body) && bfid body == faction) allA
hs = sortBy (comparing keySelected) factionA
i = fromMaybe (1) $ findIndex ((== leader) . fst) hs
(lt, gt) = (take i hs, drop (i + 1) hs)
return $! gt ++ lt
pickLeader :: MonadClientUI m => Bool -> ActorId -> m Bool
pickLeader verbose aid = do
leader <- getLeaderUI
stgtMode <- getsClient stgtMode
if leader == aid
then return False
else do
pbody <- getsState $ getActorBody aid
let !_A = assert (not (bproj pbody)
`blame` "projectile chosen as the leader"
`twith` (aid, pbody)) ()
let subject = partActor pbody
when verbose $ msgAdd $ makeSentence [subject, "picked as a leader"]
s <- getState
modifyClient $ updateLeader aid s
case stgtMode of
Nothing -> return ()
Just _ ->
modifyClient $ \cli -> cli {stgtMode = Just $ TgtMode $ blid pbody}
lookMsg <- lookAt False "" True (bpos pbody) aid ""
when verbose $ msgAdd lookMsg
return True
cursorPointerFloor :: MonadClientUI m => Bool -> Bool -> m Slideshow
cursorPointerFloor verbose addMoreMsg = do
km <- getsClient slastKM
let newPos@Point{..} = K.pointer km
lidV <- viewedLevel
Level{lxsize, lysize} <- getLevel lidV
if px < 0 || py < 0 || px >= lxsize || py >= lysize then do
stopPlayBack
return mempty
else do
let scursor = TPoint lidV newPos
modifyClient $ \cli -> cli {scursor, stgtMode = Just $ TgtMode lidV}
if verbose then
doLook addMoreMsg
else do
displayPush ""
displayDelay
return mempty
cursorPointerEnemy :: MonadClientUI m => Bool -> Bool -> m Slideshow
cursorPointerEnemy verbose addMoreMsg = do
km <- getsClient slastKM
let newPos@Point{..} = K.pointer km
lidV <- viewedLevel
Level{lxsize, lysize} <- getLevel lidV
if px < 0 || py < 0 || px >= lxsize || py >= lysize then do
stopPlayBack
return mempty
else do
bsAll <- getsState $ actorAssocs (const True) lidV
let scursor =
case find (\(_, m) -> bpos m == newPos) bsAll of
Just (im, _) -> TEnemy im True
Nothing -> TPoint lidV newPos
modifyClient $ \cli -> cli {scursor, stgtMode = Just $ TgtMode lidV}
if verbose then
doLook addMoreMsg
else do
displayPush ""
displayDelay
return mempty
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 False
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 False
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 False
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 False
doLook :: MonadClientUI m => Bool -> m Slideshow
doLook addMoreMsg = 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 False 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} -> IK.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
promptToSlideshow $ lookMsg <+> if addMoreMsg then moreMsg else ""
_floorItemOverlay :: MonadClientUI m
=> LevelId -> Point
-> m (SlideOrCmd (RequestTimed 'Ability.AbMoveItem))
_floorItemOverlay _lid _p = describeItemC MOwned
describeItemC :: MonadClientUI m
=> ItemDialogMode
-> m (SlideOrCmd (RequestTimed 'Ability.AbMoveItem))
describeItemC c = do
let subject = partActor
verbSha body activeItems = if calmEnough body activeItems
then "notice"
else "paw distractedly"
prompt body activeItems c2 =
let (tIn, t) = ppItemDialogMode c2
in case c2 of
MStore CGround ->
makePhrase
[ MU.Capitalize $ MU.SubjectVerbSg (subject body) "notice"
, MU.Text "at"
, MU.WownW (MU.Text $ bpronoun body) $ MU.Text "feet" ]
MStore CSha ->
makePhrase
[ MU.Capitalize
$ MU.SubjectVerbSg (subject body) (verbSha body activeItems)
, MU.Text tIn
, MU.Text t ]
MStore COrgan ->
makePhrase
[ MU.Capitalize $ MU.SubjectVerbSg (subject body) "feel"
, MU.Text tIn
, MU.WownW (MU.Text $ bpronoun body) $ MU.Text t ]
MOwned ->
makePhrase
[ MU.Capitalize $ MU.SubjectVerbSg (subject body) "recall"
, MU.Text tIn
, MU.Text t ]
MStats ->
makePhrase
[ MU.Capitalize $ MU.SubjectVerbSg (subject body) "estimate"
, MU.WownW (MU.Text $ bpronoun body) $ MU.Text t ]
_ ->
makePhrase
[ MU.Capitalize $ MU.SubjectVerbSg (subject body) "see"
, MU.Text tIn
, MU.WownW (MU.Text $ bpronoun body) $ MU.Text t ]
ggi <- getStoreItem prompt c
case ggi of
Right ((iid, itemFull), c2) -> do
leader <- getLeaderUI
b <- getsState $ getActorBody leader
activeItems <- activeItemsClient leader
let calmE = calmEnough b activeItems
localTime <- getsState $ getLocalTime (blid b)
let io = itemDesc (storeFromMode c2) (blid b) localTime itemFull
case c2 of
MStore COrgan -> do
let symbol = jsymbol (itemBase itemFull)
blurb | symbol == '+' = "drop temporary conditions"
| otherwise = "amputate organs"
Left <$> overlayToSlideshow ("Can't"
<+> blurb
<> ", but here's the description.") io
MStore CSha | not calmE -> do
Left <$> overlayToSlideshow "Not enough calm to take items from the shared stash, but here's the description." io
MStore fromCStore -> do
let prompt2 = "Where to move the item?"
fstores :: [(K.Key, (CStore, Text))]
fstores =
filter ((/= fromCStore) . fst . snd) $
[ (K.Char 'e', (CEqp, "'e'quipment"))
, (K.Char 'p', (CInv, "inventory 'p'ack")) ]
++ [ (K.Char 's', (CSha, "shared 's'tash")) | calmE ]
++ [ (K.Char 'g', (CGround, "'g'round")) ]
choice = "[" <> T.intercalate ", " (map (snd . snd) fstores)
keys = map (K.toKM K.NoModifier . K.Char) "epsg"
akm <- displayChoiceUI (prompt2 <+> choice) io keys
case akm of
Left slides -> failSlides slides
Right km -> do
socK <- pickNumber True $ itemK itemFull
case socK of
Left slides -> return $ Left slides
Right k -> do
let lr toCStore = return $ Right $ ReqMoveItems
[(iid, k, fromCStore, toCStore)]
case lookup (K.key km) fstores of
Just (store, _) -> lr store
Nothing -> return $ Left mempty
MOwned -> do
found <- getsState $ findIid leader (bfid b) iid
let !_A = assert (not (null found) `blame` ggi) ()
let ppLoc (_, CSha) = MU.Text $ ppCStoreIn CSha <+> "of the party"
ppLoc (b2, store) = MU.Text $ ppCStoreIn store <+> "of" <+> bname b2
foundTexts = map ppLoc found
prompt2 = makeSentence ["The item is", MU.WWandW foundTexts]
Left <$> overlayToSlideshow prompt2 io
MStats -> assert `failure` ggi
Left slides -> return $ Left slides