module Game.LambdaHack.Client.UI.HandleHelperM
( FailError, showFailError, MError, mergeMError, FailOrCmd, failWith
, failSer, failMsg, weaveJust
, sortSlots, memberCycle, memberBack, partyAfterLeader
, pickLeader, pickLeaderWithPointer
, itemOverlay, statsOverlay, pickNumber, lookAt
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import qualified Data.Char as Char
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.Function
import Data.Ord
import qualified Data.Text as T
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.EffectDescription
import Game.LambdaHack.Client.UI.ItemDescription
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 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.Point
import Game.LambdaHack.Common.ReqFailure
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Content.ItemKind as IK
import qualified Game.LambdaHack.Content.TileKind as TK
newtype FailError = FailError {failError :: Text}
deriving Show
showFailError :: FailError -> Text
showFailError (FailError err) = "*" <> err <> "*"
type MError = Maybe FailError
mergeMError :: MError -> MError -> MError
mergeMError Nothing Nothing = Nothing
mergeMError merr1@Just{} Nothing = merr1
mergeMError Nothing merr2@Just{} = merr2
mergeMError (Just err1) (Just err2) =
Just $ FailError $ failError err1 <+> "and" <+> failError err2
type FailOrCmd a = Either FailError a
failWith :: MonadClientUI m => Text -> m (FailOrCmd a)
failWith err = assert (not $ T.null err) $ return $ Left $ FailError err
failSer :: MonadClientUI m => ReqFailure -> m (FailOrCmd a)
failSer = failWith . showReqFailure
failMsg :: MonadClientUI m => Text -> m MError
failMsg err = assert (not $ T.null err) $ return $ Just $ FailError err
weaveJust :: FailOrCmd a -> Either MError a
weaveJust (Left ferr) = Left $ Just ferr
weaveJust (Right a) = Right a
sortSlots :: MonadClientUI m => FactionId -> Maybe Actor -> m ()
sortSlots fid mbody = do
itemToF <- getsState itemToFull
s <- getState
let
apperance ItemFull{itemBase} =
(jsymbol itemBase, jname itemBase, jflavour itemBase)
compareItemFull itemFull1 itemFull2 =
case ( jsymbol (itemBase itemFull1)
, jsymbol (itemBase itemFull2) ) of
('$', '$') -> EQ
('$', _) -> LT
(_, '$') -> GT
_ -> case (itemDisco itemFull1, itemDisco itemFull2) of
(Nothing, Nothing) -> comparing apperance itemFull1 itemFull2
(Nothing, Just{}) -> LT
(Just{}, Nothing) -> GT
(Just id1, Just id2) ->
case compare (itemKindId id1) (itemKindId id2) of
EQ -> comparing itemAspect id1 id2
ot -> ot
sortSlotMap :: Bool -> EM.EnumMap SlotChar ItemId
-> EM.EnumMap SlotChar ItemId
sortSlotMap onlyOrgans em =
let onPerson = sharedAllOwnedFid onlyOrgans fid s
onGround = maybe EM.empty
(\b -> getFloorBag (blid b) (bpos b) s)
mbody
inBags = ES.unions $ map EM.keysSet
$ onPerson : [ onGround | not onlyOrgans]
f = (`ES.member` inBags)
(nearItems, farItems) = partition f $ EM.elems em
g iid = (iid, itemToF iid (1, []))
sortItemIds l =
map fst $ sortBy (compareItemFull `on` snd) $ map g l
nearItemAsc = zip newSlots $ sortItemIds nearItems
farLen = if isNothing mbody then 0 else length allZeroSlots
farSlots = drop (length nearItemAsc + farLen) newSlots
farItemAsc = zip farSlots $ sortItemIds farItems
newSlots = concatMap allSlots [0..]
in EM.fromDistinctAscList $ nearItemAsc ++ farItemAsc
ItemSlots itemSlots organSlots <- getsSession sslots
let newSlots = ItemSlots (sortSlotMap False itemSlots)
(sortSlotMap True organSlots)
modifySession $ \sess -> sess {sslots = newSlots}
memberCycle :: MonadClientUI m => Bool -> m MError
memberCycle verbose = do
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
lidV <- viewedLevelUI
leader <- getLeaderUI
body <- getsState $ getActorBody leader
hs <- partyAfterLeader leader
let (autoDun, _) = autoDungeonLevel fact
case filter (\(_, b, _) -> blid b == lidV) hs of
_ | autoDun && lidV /= blid body ->
failMsg $ showReqFailure NoChangeDunLeader
[] -> failMsg "cannot pick any other member on this level"
(np, b, _) : _ -> do
success <- pickLeader verbose np
let !_A = assert (success `blame` "same leader"
`swith` (leader, np, b)) ()
return Nothing
memberBack :: MonadClientUI m => Bool -> m MError
memberBack verbose = do
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
leader <- getLeaderUI
hs <- partyAfterLeader leader
let (autoDun, _) = 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"
`swith` (leader, np, b)) ()
return Nothing
partyAfterLeader :: MonadClientUI m => ActorId -> m [(ActorId, Actor, ActorUI)]
partyAfterLeader leader = do
side <- getsState $ bfid . getActorBody leader
sactorUI <- getsSession sactorUI
allA <- getsState $ EM.assocs . sactorD
let allOurs = filter (\(_, body) ->
not (bproj body) && bfid body == side) allA
allOursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) allOurs
hs = sortBy (comparing keySelected) allOursUI
i = fromMaybe (-1) $ findIndex (\(aid, _, _) -> aid == leader) 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
saimMode <- getsSession saimMode
if leader == aid
then return False
else do
body <- getsState $ getActorBody aid
bodyUI <- getsSession $ getActorUI aid
let !_A = assert (not (bproj body)
`blame` "projectile chosen as the leader"
`swith` (aid, body)) ()
let subject = partActor bodyUI
when verbose $ msgAdd $ makeSentence [subject, "picked as a leader"]
s <- getState
modifyClient $ updateLeader aid s
case saimMode of
Nothing -> return ()
Just _ ->
modifySession $ \sess -> sess {saimMode = Just $ AimMode $ blid body}
lookMsg <- lookAt False "" True (bpos body) aid ""
when verbose $ msgAdd lookMsg
return True
pickLeaderWithPointer :: MonadClientUI m => m MError
pickLeaderWithPointer = do
lidV <- viewedLevelUI
Level{lysize} <- getLevel lidV
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
arena <- getArenaUI
sactorUI <- getsSession sactorUI
ours <- getsState $ filter (not . bproj . snd)
. actorAssocs (== side) lidV
let oursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) ours
viewed = sortBy (comparing keySelected) oursUI
(autoDun, _) = autoDungeonLevel fact
pick (aid, b) =
if | blid b /= arena && autoDun ->
failMsg $ showReqFailure NoChangeDunLeader
| otherwise -> do
void $ pickLeader True aid
return Nothing
Point{..} <- getsSession spointer
if | py == lysize + 2 && px == 0 -> memberBack True
| py == lysize + 2 ->
case drop (px - 1) viewed of
[] -> return Nothing
(aid, b, _) : _ -> pick (aid, b)
| otherwise ->
case find (\(_, b, _) -> bpos b == Point px (py - mapStartY)) oursUI of
Nothing -> failMsg "not pointing at an actor"
Just (aid, b, _) -> pick (aid, b)
itemOverlay :: MonadClientUI m => CStore -> LevelId -> ItemBag -> m OKX
itemOverlay store lid bag = do
localTime <- getsState $ getLocalTime lid
itemToF <- getsState itemToFull
ItemSlots itemSlots organSlots <- getsSession sslots
side <- getsClient sside
factionD <- getsState sfactionD
sEqp <- getsState $ sharedEqp side
let isOrgan = store == COrgan
lSlots = if isOrgan then organSlots else itemSlots
!_A = assert (all (`elem` EM.elems lSlots) (EM.keys bag)
`blame` (store, lid, bag, lSlots)) ()
markEqp iid t =
if store /= CEqp && not isOrgan && iid `EM.member` sEqp
then T.snoc (T.init t) '>'
else t
pr (l, iid) =
case EM.lookup iid bag of
Nothing -> Nothing
Just kit@(k, _) ->
let itemFull = itemToF iid kit
colorSymbol = viewItem $ itemBase itemFull
phrase =
makePhrase [partItemWsRanged side factionD
k store localTime itemFull]
al = textToAL (markEqp iid $ slotLabel l)
<+:> [colorSymbol]
<+:> textToAL phrase
kx = (Right l, (undefined, 0, length al))
in Just ([al], kx)
(ts, kxs) = unzip $ mapMaybe pr $ EM.assocs lSlots
renumber y (km, (_, x1, x2)) = (km, (y, x1, x2))
return (concat ts, zipWith renumber [0..] kxs)
statsOverlay :: MonadClient m => ActorId -> m OKX
statsOverlay aid = do
b <- getsState $ getActorBody aid
ar <- getsState $ getActorAspect aid
let prSlot :: (Y, SlotChar) -> IK.EqpSlot -> (Text, KYX)
prSlot (y, c) eqpSlot =
let statName = slotToName eqpSlot
fullText t =
makePhrase [ MU.Text $ slotLabel c
, MU.Text $ T.justifyLeft 22 ' ' statName
, MU.Text t ]
valueText = slotToDecorator eqpSlot b $ prEqpSlot eqpSlot ar
ft = fullText valueText
in (ft, (Right c, (y, 0, T.length ft)))
(ts, kxs) = unzip $ zipWith prSlot (zip [0..] allZeroSlots) statSlots
return (map textToAL ts, kxs)
pickNumber :: MonadClientUI m => Bool -> Int -> m (Either MError Int)
pickNumber askNumber kAll = assert (kAll >= 1) $ do
let shownKeys = [ K.returnKM, K.mkChar '+', K.mkChar '-'
, K.spaceKM, K.escKM ]
frontKeyKeys = K.backspaceKM : shownKeys ++ map K.mkChar ['0'..'9']
gatherNumber pointer kCur = assert (1 <= kCur && kCur <= kAll) $ do
let kprompt = "Choose number:" <+> tshow kCur
promptAdd kprompt
sli <- reportToSlideshow shownKeys
(ekkm, pointer2) <-
displayChoiceScreen ColorFull False pointer sli frontKeyKeys
case ekkm of
Left kkm ->
case K.key kkm of
K.Char '+' ->
gatherNumber pointer2 $ if kCur + 1 > kAll then 1 else kCur + 1
K.Char '-' ->
gatherNumber pointer2 $ if kCur - 1 < 1 then kAll else kCur - 1
K.Char l | kCur * 10 + Char.digitToInt l > kAll ->
gatherNumber pointer2
$ if Char.digitToInt l == 0
then kAll
else min kAll (Char.digitToInt l)
K.Char l -> gatherNumber pointer2 $ kCur * 10 + Char.digitToInt l
K.BackSpace -> gatherNumber pointer2 $ max 1 (kCur `div` 10)
K.Return -> return $ Right kCur
K.Esc -> weaveJust <$> failWith "never mind"
K.Space -> return $ Left Nothing
_ -> error $ "unexpected key" `showFailure` kkm
Right sc -> error $ "unexpected slot char" `showFailure` sc
if | kAll == 1 || not askNumber -> return $ Right kAll
| otherwise -> do
res <- gatherNumber 0 kAll
case res of
Right k | k <= 0 -> error $ "" `showFailure` (res, kAll)
_ -> return res
lookAt :: MonadClientUI m
=> Bool
-> Text
-> Bool
-> Point
-> ActorId
-> Text
-> m Text
lookAt detailed tilePrefix canSee pos aid msg = do
Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops
itemToF <- getsState itemToFull
b <- getsState $ getActorBody aid
saimMode <- getsSession saimMode
let lidV = maybe (blid b) aimLevelId saimMode
lvl <- getLevel lidV
localTime <- getsState $ getLocalTime lidV
subject <- partAidLeader aid
is <- getsState $ getFloorBag lidV pos
side <- getsClient sside
factionD <- getsState sfactionD
let verb = MU.Text $ if | pos == bpos b && lidV == blid b -> "stand on"
| canSee -> "notice"
| otherwise -> "remember"
let nWs (iid, kit@(k, _)) =
partItemWs side factionD k CGround localTime (itemToF iid kit)
isd = if EM.size is == 0 then ""
else makeSentence [ MU.SubjectVerbSg subject verb
, MU.WWandW $ map nWs $ EM.assocs is]
tile = lvl `at` pos
tileText = TK.tname (okind tile)
tilePart | T.null tilePrefix = MU.Text tileText
| otherwise = MU.AW $ MU.Text tileText
tileDesc = [MU.Text tilePrefix, tilePart]
if | detailed ->
return $! makeSentence tileDesc <+> msg <+> isd
| otherwise ->
return $! msg <+> isd