module Game.LambdaHack.Client.UI
(
MonadClientUI
, queryUI, pongUI
, displayRespUpdAtomicUI, displayRespSfxAtomicUI
, srtFrontend, KeyKind, SessionUI
, ColorMode(..), displayMore, msgAdd
#ifdef EXPOSE_INTERNAL
, humanCommand
#endif
) where
import Control.Exception.Assert.Sugar
import Control.Monad
import qualified Data.EnumMap.Strict as EM
import qualified Data.Map.Strict as M
import Data.Maybe
import Game.LambdaHack.Atomic
import qualified Game.LambdaHack.Client.Key as K
import Game.LambdaHack.Client.MonadClient
import Game.LambdaHack.Client.State
import Game.LambdaHack.Client.UI.Config
import Game.LambdaHack.Client.UI.Content.KeyKind
import Game.LambdaHack.Client.UI.DisplayAtomicClient
import Game.LambdaHack.Client.UI.HandleHumanClient
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.RunClient
import Game.LambdaHack.Client.UI.StartupFrontendClient
import Game.LambdaHack.Client.UI.WidgetClient
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Msg
import Game.LambdaHack.Common.Request
import Game.LambdaHack.Common.State
import Game.LambdaHack.Content.ModeKind
queryUI :: MonadClientUI m => m RequestUI
queryUI = do
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
let (leader, mtgt) = fromMaybe (assert `failure` fact) $ gleader fact
srunning <- getsClient srunning
req <- case srunning of
Nothing -> humanCommand Nothing
Just RunParams{runMembers}
| noRunWithMulti fact && runMembers /= [leader] -> do
stopRunning
Config{configRunStopMsgs} <- askConfig
let msg = if configRunStopMsgs
then Just $ "Run stop: automatic leader change"
else Nothing
humanCommand msg
Just runParams -> do
runOutcome <- continueRun runParams
case runOutcome of
Left stopMsg -> do
stopRunning
Config{configRunStopMsgs} <- askConfig
let msg = if configRunStopMsgs
then Just $ "Run stop:" <+> stopMsg
else Nothing
humanCommand msg
Right (paramNew, runCmd) -> do
modifyClient $ \cli -> cli {srunning = Just paramNew}
displayPush
return $! anyToUI $ runCmd
leader2 <- getLeaderUI
mtgt2 <- getsClient $ fmap fst . EM.lookup leader2 . stargetD
if (leader2, mtgt2) /= (leader, mtgt)
then return $! ReqUILeader leader2 mtgt2 req
else return $! req
humanCommand :: forall m. MonadClientUI m
=> Maybe Msg -> m RequestUI
humanCommand msgRunStop = do
modifyClient $ \cli -> cli {sbfsD = EM.empty}
let loop :: Maybe (Bool, Overlay) -> m RequestUI
loop mover = do
(lastBlank, over) <- case mover of
Nothing -> do
sli <- promptToSlideshow ""
return (False, head . snd $! slideshow sli)
Just bLast ->
return bLast
(seqCurrent, seqPrevious, k) <- getsClient slastRecord
case k of
0 -> do
let slastRecord = ([], seqCurrent, 0)
modifyClient $ \cli -> cli {slastRecord}
_ -> do
let slastRecord = ([], seqCurrent ++ seqPrevious, k 1)
modifyClient $ \cli -> cli {slastRecord}
km <- getKeyOverlayCommand lastBlank over
recordHistory
abortOrCmd <- do
Binding{bcmdMap} <- askBinding
case M.lookup km bcmdMap of
Just (_, _, cmd) -> do
stgtMode <- getsClient stgtMode
modifyClient $ \cli -> cli
{swaitTimes = if swaitTimes cli > 0
then swaitTimes cli
else 0}
if km == K.escKM && isNothing stgtMode && isJust mover
then cmdHumanSem Clear
else cmdHumanSem cmd
Nothing -> let msgKey = "unknown command <" <> K.showKM km <> ">"
in fmap Left $ promptToSlideshow msgKey
case abortOrCmd of
Right cmdS ->
return cmdS
Left slides -> do
let (onBlank, sli) = slideshow slides
mLast <- case sli of
[] -> return Nothing
[sLast] ->
return $ Just (onBlank, sLast)
_ -> do
go <- getInitConfirms ColorFull [km] slides
return $! if go then Just (onBlank, last sli) else Nothing
loop mLast
case msgRunStop of
Nothing -> loop Nothing
Just msg -> do
sli <- promptToSlideshow msg
loop $ Just (False, head . snd $ slideshow sli)
pongUI :: MonadClientUI m => m RequestUI
pongUI = do
escPressed <- tryTakeMVarSescMVar
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
let pong ats = return $ ReqUIPong ats
underAI = isAIFact fact
if escPressed && underAI && fleaderMode (gplayer fact) /= LeaderNull then do
let atomicCmd = UpdAtomic $ UpdAutoFaction side False
pong [atomicCmd]
else do
when underAI syncFrames
pong []