module Game.LambdaHack.Client.UI.InventoryM
( Suitability(..)
, getFull, getGroupItem, getStoreItem
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import qualified Data.Char as Char
import Data.Either
import qualified Data.EnumMap.Strict as EM
import qualified Data.Text as T
import Data.Tuple (swap)
import qualified NLP.Miniutter.English as MU
import Game.LambdaHack.Client.MonadClient
import Game.LambdaHack.Client.State
import Game.LambdaHack.Client.UI.ActorUI
import Game.LambdaHack.Client.UI.Content.Screen
import Game.LambdaHack.Client.UI.ContentClientUI
import Game.LambdaHack.Client.UI.HandleHelperM
import Game.LambdaHack.Client.UI.HumanCmd
import Game.LambdaHack.Client.UI.ItemSlot
import qualified Game.LambdaHack.Client.UI.Key as K
import Game.LambdaHack.Client.UI.MonadClientUI
import Game.LambdaHack.Client.UI.MsgM
import Game.LambdaHack.Client.UI.Overlay
import Game.LambdaHack.Client.UI.SessionUI
import Game.LambdaHack.Client.UI.Slideshow
import Game.LambdaHack.Client.UI.SlideshowM
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.ItemAspect as IA
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.ReqFailure
import Game.LambdaHack.Common.State
import Game.LambdaHack.Common.Types
import qualified Game.LambdaHack.Definition.Ability as Ability
import Game.LambdaHack.Definition.Defs
data ItemDialogState = ISuitable | IAll
deriving (Show, Eq)
accessModeBag :: ActorId -> State -> ItemDialogMode -> ItemBag
accessModeBag leader s (MStore cstore) = let b = getActorBody leader s
in getBodyStoreBag b cstore s
accessModeBag leader s MOrgans = let b = getActorBody leader s
in getBodyStoreBag b COrgan s
accessModeBag leader s MOwned = let fid = bfid $ getActorBody leader s
in combinedItems fid s
accessModeBag _ _ MSkills = EM.empty
accessModeBag _ s MLore{} = EM.map (const (1, [])) $ sitemD s
accessModeBag _ _ MPlaces = EM.empty
getGroupItem :: MonadClientUI m
=> m Suitability
-> Text
-> Text
-> [CStore]
-> [CStore]
-> m (Either Text ( (ItemId, ItemFull)
, (ItemDialogMode, Either K.KM SlotChar) ))
getGroupItem psuit prompt promptGeneric
cLegalRaw cLegalAfterCalm = do
soc <- getFull psuit
(\_ _ _ cCur _ -> prompt <+> ppItemDialogModeFrom cCur)
(\_ _ _ cCur _ -> promptGeneric <+> ppItemDialogModeFrom cCur)
cLegalRaw cLegalAfterCalm True False
case soc of
Left err -> return $ Left err
Right ([(iid, (itemFull, _))], cekm) ->
return $ Right ((iid, itemFull), cekm)
Right _ -> error $ "" `showFailure` soc
getStoreItem :: MonadClientUI m
=> (Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State
-> Text)
-> ItemDialogMode
-> m ( Either Text (ItemId, ItemBag, SingleItemSlots)
, (ItemDialogMode, Either K.KM SlotChar) )
getStoreItem prompt cInitial = do
let itemCs = map MStore [CEqp, CInv, CGround, CSha]
loreCs = map MLore [minBound..maxBound] ++ [MPlaces]
allCs = case cInitial of
MLore{} -> loreCs
MPlaces -> loreCs
_ -> itemCs ++ [MOwned, MOrgans, MSkills]
(pre, rest) = break (== cInitial) allCs
post = dropWhile (== cInitial) rest
remCs = post ++ pre
soc <- getItem (return SuitsEverything)
prompt prompt cInitial remCs
True False (cInitial : remCs)
case soc of
(Left err, cekm) -> return (Left err, cekm)
(Right ([iid], itemBag, lSlots), cekm) ->
return (Right (iid, itemBag, lSlots), cekm)
(Right{}, _) -> error $ "" `showFailure` soc
getFull :: MonadClientUI m
=> m Suitability
-> (Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State
-> Text)
-> (Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State
-> Text)
-> [CStore]
-> [CStore]
-> Bool
-> Bool
-> m (Either Text ( [(ItemId, ItemFullKit)]
, (ItemDialogMode, Either K.KM SlotChar) ))
getFull psuit prompt promptGeneric cLegalRaw cLegalAfterCalm
askWhenLone permitMulitple = do
side <- getsClient sside
leader <- getLeaderUI
let aidNotEmpty store aid = do
body <- getsState $ getActorBody aid
bag <- getsState $ getBodyStoreBag body store
return $! not $ EM.null bag
partyNotEmpty store = do
as <- getsState $ fidActorNotProjGlobalAssocs side
bs <- mapM (aidNotEmpty store . fst) as
return $! or bs
mpsuit <- psuit
let psuitFun = case mpsuit of
SuitsEverything -> \_ _ -> True
SuitsSomething f -> f
b <- getsState $ getActorBody leader
getCStoreBag <- getsState $ \s cstore -> getBodyStoreBag b 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]
return $ Left $ "no items" <+> ppLegal
else return $ Left $ showReqFailure ItemNotCalm
haveThis@(headThisActor : _) -> do
itemToF <- getsState $ flip itemToFull
let suitsThisActor store =
let bag = getCStoreBag store
in any (\(iid, kit) -> psuitFun (itemToF iid) kit) $ EM.assocs bag
firstStore = fromMaybe headThisActor $ find suitsThisActor haveThis
cLegal <- filterM partyNotEmpty cLegalRaw
let breakStores cInit =
let (pre, rest) = break (== cInit) cLegal
post = dropWhile (== cInit) rest
in (MStore cInit, map MStore $ post ++ pre)
let (modeFirst, modeRest) = breakStores firstStore
res <- getItem psuit prompt promptGeneric modeFirst modeRest
askWhenLone permitMulitple (map MStore cLegal)
case res of
(Left t, _) -> return $ Left t
(Right (iids, itemBag, _lSlots), cekm) -> do
let f iid = (iid, (itemToF iid, itemBag EM.! iid))
return $ Right (map f iids, cekm)
getItem :: MonadClientUI m
=> m Suitability
-> (Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State
-> Text)
-> (Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State
-> Text)
-> ItemDialogMode
-> [ItemDialogMode]
-> Bool
-> Bool
-> [ItemDialogMode]
-> m ( Either Text ([ItemId], ItemBag, SingleItemSlots)
, (ItemDialogMode, Either K.KM SlotChar) )
getItem psuit prompt promptGeneric cCur cRest askWhenLone permitMulitple
cLegal = do
leader <- getLeaderUI
accessCBag <- getsState $ accessModeBag leader
let storeAssocs = EM.assocs . accessCBag
allAssocs = concatMap storeAssocs (cCur : cRest)
case allAssocs of
[(iid, k)] | null cRest && not askWhenLone -> do
ItemSlots itemSlots <- getsSession sslots
let lSlots = itemSlots EM.! IA.loreFromMode cCur
slotChar = fromMaybe (error $ "" `showFailure` (iid, lSlots))
$ lookup iid $ map swap $ EM.assocs lSlots
return ( Right ([iid], EM.singleton iid k, EM.singleton slotChar iid)
, (cCur, Right slotChar) )
_ ->
transition psuit prompt promptGeneric permitMulitple cLegal
0 cCur cRest ISuitable
data DefItemKey m = DefItemKey
{ defLabel :: Either Text K.KM
, defCond :: Bool
, defAction :: Either K.KM SlotChar
-> m ( Either Text ([ItemId], ItemBag, SingleItemSlots)
, (ItemDialogMode, Either K.KM SlotChar) )
}
data Suitability =
SuitsEverything
| SuitsSomething (ItemFull -> ItemQuant -> Bool)
transition :: forall m. MonadClientUI m
=> m Suitability
-> (Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State
-> Text)
-> (Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State
-> Text)
-> Bool
-> [ItemDialogMode]
-> Int
-> ItemDialogMode
-> [ItemDialogMode]
-> ItemDialogState
-> m ( Either Text ([ItemId], ItemBag, SingleItemSlots)
, (ItemDialogMode, Either K.KM SlotChar) )
transition psuit prompt promptGeneric permitMulitple cLegal
numPrefix cCur cRest itemDialogState = do
let recCall = transition psuit prompt promptGeneric permitMulitple cLegal
ItemSlots itemSlots <- getsSession sslots
leader <- getLeaderUI
body <- getsState $ getActorBody leader
bodyUI <- getsSession $ getActorUI leader
actorMaxSk <- getsState $ getActorMaxSkills leader
fact <- getsState $ (EM.! bfid body) . sfactionD
hs <- partyAfterLeader leader
bagAll <- getsState $ \s -> accessModeBag leader s cCur
itemToF <- getsState $ flip itemToFull
revCmd <- revCmdMap
mpsuit <- psuit
psuitFun <- case mpsuit of
SuitsEverything -> return $ \_ _ -> True
SuitsSomething f -> return f
let getResult :: Either K.KM SlotChar -> [ItemId]
-> ( Either Text ([ItemId], ItemBag, SingleItemSlots)
, (ItemDialogMode, Either K.KM SlotChar) )
getResult ekm iids = (Right (iids, bagAll, bagItemSlotsAll), (cCur, ekm))
filterP iid = psuitFun (itemToF iid)
bagAllSuit = EM.filterWithKey filterP bagAll
lSlots = case cCur of
MOrgans -> mergeItemSlots itemToF [ itemSlots EM.! SOrgan
, itemSlots EM.! STrunk
, itemSlots EM.! SCondition ]
MSkills -> EM.empty
MPlaces -> EM.empty
_ -> itemSlots EM.! IA.loreFromMode cCur
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
bagSuit = EM.fromList $ map (\iid -> (iid, bagAllSuit EM.! iid))
(EM.elems suitableItemSlotsOpen)
(bagFiltered, promptChosen) <- getsState $ \s ->
case itemDialogState of
ISuitable -> (bagSuit, prompt body bodyUI actorMaxSk cCur s <> ":")
IAll -> (bag, promptGeneric body bodyUI actorMaxSk cCur s <> ":")
let (autoDun, _) = autoDungeonLevel fact
multipleSlots = if itemDialogState == IAll
then bagItemSlotsAll
else suitableItemSlotsAll
maySwitchLeader MOwned = False
maySwitchLeader MLore{} = False
maySwitchLeader MPlaces = False
maySwitchLeader _ = True
keyDefs :: [(K.KM, DefItemKey m)]
keyDefs = filter (defCond . snd) $
[ let km = K.mkChar '/'
in (km, changeContainerDef True $ Right km)
, (K.mkKP '/', changeContainerDef True $ Left "")
, let km = K.mkChar '?'
in (km, changeContainerDef False $ Right km)
, (K.mkKP '?', changeContainerDef False $ Left "")
, let km = K.mkChar '+'
in (km, DefItemKey
{ defLabel = Right km
, defCond = bag /= bagSuit
, defAction = \_ -> recCall numPrefix cCur cRest
$ case itemDialogState of
ISuitable -> IAll
IAll -> ISuitable
})
, let km = K.mkChar '!'
in (km, useMultipleDef $ Right km)
, (K.mkKP '*', useMultipleDef $ Left "")
, let km = revCmd (K.KM K.NoModifier K.Tab) MemberCycle
in (km, DefItemKey
{ defLabel = Right km
, defCond = maySwitchLeader cCur
&& any (\(_, b, _) -> blid b == blid body) hs
, defAction = \_ -> do
err <- memberCycle False
let !_A = assert (isNothing err `blame` err) ()
(cCurUpd, cRestUpd) <- legalWithUpdatedLeader cCur cRest
recCall numPrefix cCurUpd cRestUpd itemDialogState
})
, let km = revCmd (K.KM K.NoModifier K.BackTab) MemberBack
in (km, DefItemKey
{ defLabel = Right km
, defCond = maySwitchLeader cCur && not (autoDun || null hs)
, defAction = \_ -> do
err <- memberBack False
let !_A = assert (isNothing err `blame` err) ()
(cCurUpd, cRestUpd) <- legalWithUpdatedLeader cCur cRest
recCall numPrefix cCurUpd cRestUpd itemDialogState
})
, (K.KM K.NoModifier K.LeftButtonRelease, DefItemKey
{ defLabel = Left ""
, defCond = maySwitchLeader cCur && not (null hs)
, defAction = \ekm -> do
merror <- pickLeaderWithPointer
case merror of
Nothing -> do
(cCurUpd, cRestUpd) <- legalWithUpdatedLeader cCur cRest
recCall numPrefix cCurUpd cRestUpd itemDialogState
Just{} -> return (Left "not a teammate", (cCur, ekm))
})
, let km = revCmd (K.KM K.NoModifier $ K.Char '^') SortSlots
in (km, DefItemKey
{ defLabel = Right km
, defCond = cCur /= MOrgans
&& cCur /= MSkills
&& cCur /= MPlaces
&& EM.size bagFiltered > 1
, defAction = \_ -> do
sortSlots
recCall numPrefix cCur cRest itemDialogState
})
, (K.escKM, DefItemKey
{ defLabel = Right K.escKM
, defCond = True
, defAction = \ekm -> return (Left "never mind", (cCur, ekm))
})
]
++ numberPrefixes
changeContainerDef forward defLabel = DefItemKey
{ defLabel
, defCond = True
, defAction = \_ -> do
let calmE = calmEnough body actorMaxSk
mcCur = filter (`elem` cLegal) [cCur]
(cCurAfterCalm, cRestAfterCalm) =
if forward
then case cRest ++ mcCur of
c1@(MStore CSha) : c2 : rest | not calmE ->
(c2, c1 : rest)
[MStore CSha] | not calmE -> error $ "" `showFailure` cRest
c1 : rest -> (c1, rest)
[] -> error $ "" `showFailure` cRest
else case reverse $ mcCur ++ cRest of
c1@(MStore CSha) : c2 : rest | not calmE ->
(c2, reverse $ c1 : rest)
[MStore CSha] | not calmE -> error $ "" `showFailure` cRest
c1 : rest -> (c1, reverse rest)
[] -> error $ "" `showFailure` cRest
recCall numPrefix cCurAfterCalm cRestAfterCalm itemDialogState
}
useMultipleDef defLabel = DefItemKey
{ defLabel
, defCond = permitMulitple && not (EM.null multipleSlots)
, defAction = \ekm ->
let eslots = EM.elems multipleSlots
in return $ getResult ekm eslots
}
prefixCmdDef d =
(K.mkChar $ Char.intToDigit d, DefItemKey
{ defLabel = Left ""
, defCond = True
, defAction = \_ ->
recCall (10 * numPrefix + d) cCur cRest itemDialogState
})
numberPrefixes = map prefixCmdDef [0..9]
lettersDef :: DefItemKey m
lettersDef = DefItemKey
{ defLabel = Left ""
, defCond = True
, defAction = \ekm ->
let slot = case ekm of
Left K.KM{key=K.Char l} -> SlotChar numPrefix l
Left km ->
error $ "unexpected key:" `showFailure` K.showKM km
Right sl -> sl
in case EM.lookup slot bagItemSlotsAll of
Nothing -> error $ "unexpected slot"
`showFailure` (slot, bagItemSlots)
Just iid -> return $! getResult (Right slot) [iid]
}
case cCur of
MSkills -> do
io <- skillsOverlay leader
let slotLabels = map fst $ snd io
slotKeys = mapMaybe (keyOfEKM numPrefix) slotLabels
skillsDef :: DefItemKey m
skillsDef = DefItemKey
{ defLabel = Left ""
, defCond = True
, defAction = \ekm ->
let slot = case ekm of
Left K.KM{key} -> case key of
K.Char l -> SlotChar numPrefix l
_ -> error $ "unexpected key:"
`showFailure` K.showKey key
Right sl -> sl
in return (Left "skills", (MSkills, Right slot))
}
runDefItemKey keyDefs skillsDef io slotKeys promptChosen cCur
MPlaces -> do
io <- placesOverlay
let slotLabels = map fst $ snd io
slotKeys = mapMaybe (keyOfEKM numPrefix) slotLabels
placesDef :: DefItemKey m
placesDef = DefItemKey
{ defLabel = Left ""
, defCond = True
, defAction = \ekm ->
let slot = case ekm of
Left K.KM{key} -> case key of
K.Char l -> SlotChar numPrefix l
_ -> error $ "unexpected key:"
`showFailure` K.showKey key
Right sl -> sl
in return (Left "places", (MPlaces, Right slot))
}
runDefItemKey keyDefs placesDef io slotKeys promptChosen cCur
_ -> do
io <- itemOverlay lSlots (blid body) bagFiltered
let slotKeys = mapMaybe (keyOfEKM numPrefix . Right)
$ EM.keys bagItemSlots
runDefItemKey keyDefs lettersDef io slotKeys promptChosen cCur
keyOfEKM :: Int -> Either [K.KM] SlotChar -> Maybe K.KM
keyOfEKM _ (Left kms) = error $ "" `showFailure` kms
keyOfEKM numPrefix (Right SlotChar{..}) | slotPrefix == numPrefix =
Just $ K.mkChar slotChar
keyOfEKM _ _ = Nothing
legalWithUpdatedLeader :: MonadClientUI m
=> ItemDialogMode
-> [ItemDialogMode]
-> m (ItemDialogMode, [ItemDialogMode])
legalWithUpdatedLeader cCur cRest = do
leader <- getLeaderUI
let newLegal = cCur : cRest
b <- getsState $ getActorBody leader
actorMaxSk <- getsState $ getActorMaxSkills leader
let calmE = calmEnough b actorMaxSk
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)
[] -> error $ "" `showFailure` (cCur, cRest)
return legalAfterCalm
runDefItemKey :: MonadClientUI m
=> [(K.KM, DefItemKey m)]
-> DefItemKey m
-> OKX
-> [K.KM]
-> Text
-> ItemDialogMode
-> m ( Either Text ([ItemId], ItemBag, SingleItemSlots)
, (ItemDialogMode, Either K.KM SlotChar) )
runDefItemKey keyDefs lettersDef okx slotKeys prompt cCur = do
let itemKeys = slotKeys ++ map fst keyDefs
wrapB s = "[" <> s <> "]"
(keyLabelsRaw, keys) = partitionEithers $ map (defLabel . snd) keyDefs
keyLabels = filter (not . T.null) keyLabelsRaw
choice = T.intercalate " " $ map wrapB $ nub keyLabels
promptAdd0 $ prompt <+> choice
CCUI{coscreen=ScreenContent{rheight}} <- getsSession sccui
ekm <- do
okxs <- overlayToSlideshow (rheight - 2) keys okx
displayChoiceScreen (show cCur) ColorFull False okxs itemKeys
case ekm of
Left km -> case km `lookup` keyDefs of
Just keyDef -> defAction keyDef ekm
Nothing -> defAction lettersDef ekm
Right _slot -> defAction lettersDef ekm