-- | Monadic operations on slideshows and related data.
module Game.LambdaHack.Client.UI.SlideshowM
  ( overlayToSlideshow, reportToSlideshow, reportToSlideshowKeepHalt
  , displaySpaceEsc, displayMore, displayMoreKeep, displayYesNo, getConfirms
  , displayChoiceScreen
  , displayChoiceScreenWithRightPane
  , displayChoiceScreenWithDefItemKey
  , displayChoiceScreenWithRightPaneKMKM
  , pushFrame, pushReportFrame
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , getMenuIx, saveMenuIx, stepChoiceScreen, navigationKeys, findKYX
  , drawHighlight, basicFrameWithoutReport
#endif
  ) 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.Map.Strict as M
import qualified Data.Text as T

import           Game.LambdaHack.Client.MonadClient
import           Game.LambdaHack.Client.State
import           Game.LambdaHack.Client.UI.Content.Screen
import           Game.LambdaHack.Client.UI.ContentClientUI
import           Game.LambdaHack.Client.UI.Frame
import           Game.LambdaHack.Client.UI.FrameM
import qualified Game.LambdaHack.Client.UI.Key as K
import           Game.LambdaHack.Client.UI.MonadClientUI
import           Game.LambdaHack.Client.UI.Msg
import           Game.LambdaHack.Client.UI.MsgM
import           Game.LambdaHack.Client.UI.Overlay
import           Game.LambdaHack.Client.UI.PointUI
import           Game.LambdaHack.Client.UI.SessionUI
import           Game.LambdaHack.Client.UI.Slideshow
import           Game.LambdaHack.Client.UI.UIOptions
import           Game.LambdaHack.Common.ClientOptions
import           Game.LambdaHack.Common.Faction
import           Game.LambdaHack.Common.MonadStateRead
import           Game.LambdaHack.Common.State
import           Game.LambdaHack.Common.Types
import           Game.LambdaHack.Common.Vector
import qualified Game.LambdaHack.Definition.Color as Color

-- | Add current report to the overlay, split the result and produce,
-- possibly, many slides.
overlayToSlideshow :: MonadClientUI m
                   => Int -> [K.KM] -> OKX -> m Slideshow
overlayToSlideshow :: Int -> [KM] -> OKX -> m Slideshow
overlayToSlideshow Int
y [KM]
keys OKX
okx = do
  CCUI{coscreen :: CCUI -> ScreenContent
coscreen=ScreenContent{Int
rwidth :: ScreenContent -> Int
rwidth :: Int
rwidth}} <- (SessionUI -> CCUI) -> m CCUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  UIOptions{Int
uMsgWrapColumn :: UIOptions -> Int
uMsgWrapColumn :: Int
uMsgWrapColumn} <- (SessionUI -> UIOptions) -> m UIOptions
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> UIOptions
sUIOptions
  Report
report <- Bool -> m Report
forall (m :: * -> *). MonadClientUI m => Bool -> m Report
getReportUI Bool
True
  m ()
forall (m :: * -> *). MonadClientUI m => m ()
recordHistory  -- report will be shown soon, remove it to history
  FontSetup
fontSetup <- m FontSetup
forall (m :: * -> *). MonadClientUI m => m FontSetup
getFontSetup
  Bool
curTutorial <- (SessionUI -> Bool) -> m Bool
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Bool
scurTutorial
  Maybe Bool
overrideTut <- (SessionUI -> Maybe Bool) -> m (Maybe Bool)
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe Bool
soverrideTut
  let displayTutorialHints :: Bool
displayTutorialHints = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
curTutorial Maybe Bool
overrideTut
  Slideshow -> m Slideshow
forall (m :: * -> *) a. Monad m => a -> m a
return (Slideshow -> m Slideshow) -> Slideshow -> m Slideshow
forall a b. (a -> b) -> a -> b
$! FontSetup
-> Bool -> Int -> Int -> Int -> Report -> [KM] -> OKX -> Slideshow
splitOverlay FontSetup
fontSetup Bool
displayTutorialHints
                         Int
rwidth Int
y Int
uMsgWrapColumn Report
report [KM]
keys OKX
okx

-- | Split current report into a slideshow.
reportToSlideshow :: MonadClientUI m => [K.KM] -> m Slideshow
reportToSlideshow :: [KM] -> m Slideshow
reportToSlideshow [KM]
keys = do
  CCUI{coscreen :: CCUI -> ScreenContent
coscreen=ScreenContent{Int
rheight :: ScreenContent -> Int
rheight :: Int
rheight}} <- (SessionUI -> CCUI) -> m CCUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  Int -> [KM] -> OKX -> m Slideshow
forall (m :: * -> *).
MonadClientUI m =>
Int -> [KM] -> OKX -> m Slideshow
overlayToSlideshow (Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) [KM]
keys OKX
emptyOKX

-- | Split current report into a slideshow. Keep report unchanged.
-- Assume the game either halts waiting for a key after this is shown,
-- or many slides are produced, all but the last are displayed
-- with player promts between and the last is either shown
-- in full or ignored if inside macro (can be recovered from history,
-- if important). Unless the prompts interrupt the macro, which is as well.
reportToSlideshowKeepHalt :: MonadClientUI m => Bool -> [K.KM] -> m Slideshow
reportToSlideshowKeepHalt :: Bool -> [KM] -> m Slideshow
reportToSlideshowKeepHalt Bool
insideMenu [KM]
keys = do
  CCUI{coscreen :: CCUI -> ScreenContent
coscreen=ScreenContent{Int
rwidth :: Int
rwidth :: ScreenContent -> Int
rwidth, Int
rheight :: Int
rheight :: ScreenContent -> Int
rheight}} <- (SessionUI -> CCUI) -> m CCUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  UIOptions{Int
uMsgWrapColumn :: Int
uMsgWrapColumn :: UIOptions -> Int
uMsgWrapColumn} <- (SessionUI -> UIOptions) -> m UIOptions
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> UIOptions
sUIOptions
  Report
report <- Bool -> m Report
forall (m :: * -> *). MonadClientUI m => Bool -> m Report
getReportUI Bool
insideMenu
  -- Don't do @recordHistory@; the message is important, but related
  -- to the messages that come after, so should be shown together.
  FontSetup
fontSetup <- m FontSetup
forall (m :: * -> *). MonadClientUI m => m FontSetup
getFontSetup
  Bool
curTutorial <- (SessionUI -> Bool) -> m Bool
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Bool
scurTutorial
  Maybe Bool
overrideTut <- (SessionUI -> Maybe Bool) -> m (Maybe Bool)
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe Bool
soverrideTut
  let displayTutorialHints :: Bool
displayTutorialHints = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
curTutorial Maybe Bool
overrideTut
  Slideshow -> m Slideshow
forall (m :: * -> *) a. Monad m => a -> m a
return (Slideshow -> m Slideshow) -> Slideshow -> m Slideshow
forall a b. (a -> b) -> a -> b
$! FontSetup
-> Bool -> Int -> Int -> Int -> Report -> [KM] -> OKX -> Slideshow
splitOverlay FontSetup
fontSetup Bool
displayTutorialHints
                         Int
rwidth (Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Int
uMsgWrapColumn
                         Report
report [KM]
keys OKX
emptyOKX

-- | Display a message. Return value indicates if the player wants to continue.
-- Feature: if many pages, only the last SPACE exits (but first ESC).
displaySpaceEsc :: MonadClientUI m => ColorMode -> Text -> m Bool
displaySpaceEsc :: ColorMode -> Text -> m Bool
displaySpaceEsc ColorMode
dm Text
prompt = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
prompt) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ MsgClassShow -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgLnAdd MsgClassShow
MsgPromptGeneric Text
prompt
  -- Two frames drawn total (unless @prompt@ very long).
  Slideshow
slides <- [KM] -> m Slideshow
forall (m :: * -> *). MonadClientUI m => [KM] -> m Slideshow
reportToSlideshow [KM
K.spaceKM, KM
K.escKM]
  KM
km <- ColorMode -> [KM] -> Slideshow -> m KM
forall (m :: * -> *).
MonadClientUI m =>
ColorMode -> [KM] -> Slideshow -> m KM
getConfirms ColorMode
dm [KM
K.spaceKM, KM
K.escKM] Slideshow
slides
  Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$! KM
km KM -> KM -> Bool
forall a. Eq a => a -> a -> Bool
== KM
K.spaceKM

-- | Display a message. Ignore keypresses.
-- Feature: if many pages, only the last SPACE exits (but first ESC).
displayMore :: MonadClientUI m => ColorMode -> Text -> m ()
displayMore :: ColorMode -> Text -> m ()
displayMore ColorMode
dm Text
prompt = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
prompt) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ MsgClassShow -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgLnAdd MsgClassShow
MsgPromptGeneric Text
prompt
  Slideshow
slides <- [KM] -> m Slideshow
forall (m :: * -> *). MonadClientUI m => [KM] -> m Slideshow
reportToSlideshow [KM
K.spaceKM]
  m KM -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m KM -> m ()) -> m KM -> m ()
forall a b. (a -> b) -> a -> b
$ ColorMode -> [KM] -> Slideshow -> m KM
forall (m :: * -> *).
MonadClientUI m =>
ColorMode -> [KM] -> Slideshow -> m KM
getConfirms ColorMode
dm [KM
K.spaceKM, KM
K.escKM] Slideshow
slides

displayMoreKeep :: MonadClientUI m => ColorMode -> Text -> m ()
displayMoreKeep :: ColorMode -> Text -> m ()
displayMoreKeep ColorMode
dm Text
prompt = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
prompt) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ MsgClassShow -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgLnAdd MsgClassShow
MsgPromptGeneric Text
prompt
  Slideshow
slides <- Bool -> [KM] -> m Slideshow
forall (m :: * -> *).
MonadClientUI m =>
Bool -> [KM] -> m Slideshow
reportToSlideshowKeepHalt Bool
True [KM
K.spaceKM]
  m KM -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m KM -> m ()) -> m KM -> m ()
forall a b. (a -> b) -> a -> b
$ ColorMode -> [KM] -> Slideshow -> m KM
forall (m :: * -> *).
MonadClientUI m =>
ColorMode -> [KM] -> Slideshow -> m KM
getConfirms ColorMode
dm [KM
K.spaceKM, KM
K.escKM] Slideshow
slides

-- | Print a yes/no question and return the player's answer. Use black
-- and white colours to turn player's attention to the choice.
displayYesNo :: MonadClientUI m => ColorMode -> Text -> m Bool
displayYesNo :: ColorMode -> Text -> m Bool
displayYesNo ColorMode
dm Text
prompt = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
prompt) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ MsgClassShow -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgLnAdd MsgClassShow
MsgPromptGeneric Text
prompt
  let yn :: [KM]
yn = (Char -> KM) -> [Char] -> [KM]
forall a b. (a -> b) -> [a] -> [b]
map Char -> KM
K.mkChar [Char
'y', Char
'n']
  Slideshow
slides <- [KM] -> m Slideshow
forall (m :: * -> *). MonadClientUI m => [KM] -> m Slideshow
reportToSlideshow [KM]
yn
  KM
km <- ColorMode -> [KM] -> Slideshow -> m KM
forall (m :: * -> *).
MonadClientUI m =>
ColorMode -> [KM] -> Slideshow -> m KM
getConfirms ColorMode
dm (KM
K.escKM KM -> [KM] -> [KM]
forall a. a -> [a] -> [a]
: [KM]
yn) Slideshow
slides
  Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$! KM
km KM -> KM -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> KM
K.mkChar Char
'y'

getConfirms :: MonadClientUI m
            => ColorMode -> [K.KM] -> Slideshow -> m K.KM
getConfirms :: ColorMode -> [KM] -> Slideshow -> m KM
getConfirms ColorMode
dm [KM]
extraKeys Slideshow
slides = do
  KeyOrSlot
ekm <- [Char] -> ColorMode -> Bool -> Slideshow -> [KM] -> m KeyOrSlot
forall (m :: * -> *).
MonadClientUI m =>
[Char] -> ColorMode -> Bool -> Slideshow -> [KM] -> m KeyOrSlot
displayChoiceScreen [Char]
"" ColorMode
dm Bool
False Slideshow
slides [KM]
extraKeys
  KM -> m KM
forall (m :: * -> *) a. Monad m => a -> m a
return (KM -> m KM) -> KM -> m KM
forall a b. (a -> b) -> a -> b
$! (KM -> KM) -> (MenuSlot -> KM) -> KeyOrSlot -> KM
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either KM -> KM
forall a. a -> a
id ([Char] -> MenuSlot -> KM
forall a. HasCallStack => [Char] -> a
error ([Char] -> MenuSlot -> KM) -> [Char] -> MenuSlot -> KM
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char] -> KeyOrSlot -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` KeyOrSlot
ekm) KeyOrSlot
ekm

-- | Display a, potentially, multi-screen menu and return the chosen
-- key or menu slot (and save the index in the whole menu so that the cursor
-- can again be placed at that spot next time menu is displayed).
--
-- This function is one of only two sources of menus and so,
-- effectively, UI modes.
displayChoiceScreen :: forall m . MonadClientUI m
                    => String -> ColorMode -> Bool -> Slideshow -> [K.KM]
                    -> m KeyOrSlot
displayChoiceScreen :: [Char] -> ColorMode -> Bool -> Slideshow -> [KM] -> m KeyOrSlot
displayChoiceScreen = do
  (KeyOrSlot -> m OKX)
-> Bool
-> [Char]
-> ColorMode
-> Bool
-> Slideshow
-> [KM]
-> m KeyOrSlot
forall (m :: * -> *).
MonadClientUI m =>
(KeyOrSlot -> m OKX)
-> Bool
-> [Char]
-> ColorMode
-> Bool
-> Slideshow
-> [KM]
-> m KeyOrSlot
displayChoiceScreenWithRightPane (m OKX -> KeyOrSlot -> m OKX
forall a b. a -> b -> a
const (m OKX -> KeyOrSlot -> m OKX) -> m OKX -> KeyOrSlot -> m OKX
forall a b. (a -> b) -> a -> b
$ OKX -> m OKX
forall (m :: * -> *) a. Monad m => a -> m a
return OKX
emptyOKX) Bool
False

-- | Display a, potentially, multi-screen menu and return the chosen
-- key or menu slot (and save the index in the whole menu so that the cursor
-- can again be placed at that spot next time menu is displayed).
-- Additionally, display something on the right half of the screen,
-- depending on which menu item is currently highlighted
--
-- This function is one of only two sources of menus and so,
-- effectively, UI modes.
displayChoiceScreenWithRightPane
  :: forall m . MonadClientUI m
  => (KeyOrSlot -> m OKX)
  -> Bool -> String -> ColorMode -> Bool -> Slideshow -> [K.KM]
  -> m KeyOrSlot
displayChoiceScreenWithRightPane :: (KeyOrSlot -> m OKX)
-> Bool
-> [Char]
-> ColorMode
-> Bool
-> Slideshow
-> [KM]
-> m KeyOrSlot
displayChoiceScreenWithRightPane KeyOrSlot -> m OKX
displayInRightPane
                                 Bool
highlightBullet [Char]
menuName ColorMode
dm Bool
sfBlank
                                 Slideshow
frsX [KM]
extraKeys = do
  Either (KM, KeyOrSlot) MenuSlot
kmkm <- (KeyOrSlot -> m OKX)
-> Bool
-> [Char]
-> ColorMode
-> Bool
-> Slideshow
-> [KM]
-> m (Either (KM, KeyOrSlot) MenuSlot)
forall (m :: * -> *).
MonadClientUI m =>
(KeyOrSlot -> m OKX)
-> Bool
-> [Char]
-> ColorMode
-> Bool
-> Slideshow
-> [KM]
-> m (Either (KM, KeyOrSlot) MenuSlot)
displayChoiceScreenWithRightPaneKMKM
                                 KeyOrSlot -> m OKX
displayInRightPane
                                 Bool
highlightBullet [Char]
menuName ColorMode
dm Bool
sfBlank
                                 Slideshow
frsX [KM]
extraKeys
  KeyOrSlot -> m KeyOrSlot
forall (m :: * -> *) a. Monad m => a -> m a
return (KeyOrSlot -> m KeyOrSlot) -> KeyOrSlot -> m KeyOrSlot
forall a b. (a -> b) -> a -> b
$! case Either (KM, KeyOrSlot) MenuSlot
kmkm of
    Left (KM
km, KeyOrSlot
_) -> KM -> KeyOrSlot
forall a b. a -> Either a b
Left KM
km
    Right MenuSlot
slot -> MenuSlot -> KeyOrSlot
forall a b. b -> Either a b
Right MenuSlot
slot

-- | A specialized variant of 'displayChoiceScreenWithRightPane'.
displayChoiceScreenWithDefItemKey :: MonadClientUI m
                                  => (Int -> MenuSlot -> m OKX)
                                  -> Slideshow
                                  -> [K.KM]
                                  -> String
                                  -> m KeyOrSlot
displayChoiceScreenWithDefItemKey :: (Int -> MenuSlot -> m OKX)
-> Slideshow -> [KM] -> [Char] -> m KeyOrSlot
displayChoiceScreenWithDefItemKey Int -> MenuSlot -> m OKX
f Slideshow
sli [KM]
itemKeys [Char]
menuName = do
  CCUI{coscreen :: CCUI -> ScreenContent
coscreen=ScreenContent{Int
rwidth :: Int
rwidth :: ScreenContent -> Int
rwidth}} <- (SessionUI -> CCUI) -> m CCUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  FontSetup{DisplayFont
propFont :: FontSetup -> DisplayFont
propFont :: DisplayFont
propFont} <- m FontSetup
forall (m :: * -> *). MonadClientUI m => m FontSetup
getFontSetup
  let g :: KeyOrSlot -> m OKX
g KeyOrSlot
ekm = case KeyOrSlot
ekm of
        Left{} -> OKX -> m OKX
forall (m :: * -> *) a. Monad m => a -> m a
return OKX
emptyOKX
        Right MenuSlot
slot -> do
          if DisplayFont -> Bool
isSquareFont DisplayFont
propFont
          then OKX -> m OKX
forall (m :: * -> *) a. Monad m => a -> m a
return OKX
emptyOKX
          else Int -> MenuSlot -> m OKX
f (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) MenuSlot
slot
  (KeyOrSlot -> m OKX)
-> Bool
-> [Char]
-> ColorMode
-> Bool
-> Slideshow
-> [KM]
-> m KeyOrSlot
forall (m :: * -> *).
MonadClientUI m =>
(KeyOrSlot -> m OKX)
-> Bool
-> [Char]
-> ColorMode
-> Bool
-> Slideshow
-> [KM]
-> m KeyOrSlot
displayChoiceScreenWithRightPane
    KeyOrSlot -> m OKX
g Bool
True [Char]
menuName ColorMode
ColorFull Bool
False Slideshow
sli [KM]
itemKeys

-- | A variant providing for a keypress the information about the label
-- of the menu slot which was selected during the keypress.
displayChoiceScreenWithRightPaneKMKM
  :: forall m . MonadClientUI m
  => (KeyOrSlot -> m OKX)
  -> Bool -> String -> ColorMode -> Bool -> Slideshow -> [K.KM]
  -> m (Either (K.KM, KeyOrSlot) MenuSlot)
displayChoiceScreenWithRightPaneKMKM :: (KeyOrSlot -> m OKX)
-> Bool
-> [Char]
-> ColorMode
-> Bool
-> Slideshow
-> [KM]
-> m (Either (KM, KeyOrSlot) MenuSlot)
displayChoiceScreenWithRightPaneKMKM KeyOrSlot -> m OKX
displayInRightPane
                                     Bool
highlightBullet [Char]
menuName ColorMode
dm Bool
sfBlank
                                     Slideshow
frsX [KM]
extraKeys = do
  (Int
maxIx, Int
initIx, Int
clearIx, Int -> OKX -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
m)
    <- Bool
-> ColorMode
-> Bool
-> Slideshow
-> [KM]
-> m (Int, Int, Int,
      Int -> OKX -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int))
forall (m :: * -> *).
MonadClientUI m =>
Bool
-> ColorMode
-> Bool
-> Slideshow
-> [KM]
-> m (Int, Int, Int,
      Int -> OKX -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int))
stepChoiceScreen Bool
highlightBullet ColorMode
dm Bool
sfBlank Slideshow
frsX [KM]
extraKeys
  let loop :: Int -> KeyOrSlot -> m (Either (K.KM, KeyOrSlot) MenuSlot, Int)
      loop :: Int -> KeyOrSlot -> m (Either (KM, KeyOrSlot) MenuSlot, Int)
loop Int
pointer KeyOrSlot
km = do
        OKX
okxRight <- KeyOrSlot -> m OKX
displayInRightPane KeyOrSlot
km
        (Bool
final, Either (KM, KeyOrSlot) MenuSlot
kmkm1, Int
pointer1) <- Int -> OKX -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
m Int
pointer OKX
okxRight
        if Bool
final
        then (Either (KM, KeyOrSlot) MenuSlot, Int)
-> m (Either (KM, KeyOrSlot) MenuSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (KM, KeyOrSlot) MenuSlot
kmkm1, Int
pointer1)
        else Int -> KeyOrSlot -> m (Either (KM, KeyOrSlot) MenuSlot, Int)
loop Int
pointer1 (KeyOrSlot -> m (Either (KM, KeyOrSlot) MenuSlot, Int))
-> KeyOrSlot -> m (Either (KM, KeyOrSlot) MenuSlot, Int)
forall a b. (a -> b) -> a -> b
$ case Either (KM, KeyOrSlot) MenuSlot
kmkm1 of
          Left (KM
km1, KeyOrSlot
_) -> KM -> KeyOrSlot
forall a b. a -> Either a b
Left KM
km1
          Right MenuSlot
slot -> MenuSlot -> KeyOrSlot
forall a b. b -> Either a b
Right MenuSlot
slot
  Int
pointer0 <- [Char] -> Int -> Int -> Int -> m Int
forall (m :: * -> *).
MonadClientUI m =>
[Char] -> Int -> Int -> Int -> m Int
getMenuIx [Char]
menuName Int
maxIx Int
initIx Int
clearIx
  let km0 :: KeyOrSlot
km0 = case Int -> [OKX] -> Maybe (OKX, KYX, Int)
findKYX Int
pointer0 ([OKX] -> Maybe (OKX, KYX, Int)) -> [OKX] -> Maybe (OKX, KYX, Int)
forall a b. (a -> b) -> a -> b
$ Slideshow -> [OKX]
slideshow Slideshow
frsX of
        Maybe (OKX, KYX, Int)
Nothing -> [Char] -> KeyOrSlot
forall a. HasCallStack => [Char] -> a
error ([Char] -> KeyOrSlot) -> [Char] -> KeyOrSlot
forall a b. (a -> b) -> a -> b
$ [Char]
"no menu keys" [Char] -> Slideshow -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` Slideshow
frsX
        Just (OKX
_, (KeyOrSlot
ekm, (PointUI, ButtonWidth)
_), Int
_) -> KeyOrSlot
ekm
  (Either (KM, KeyOrSlot) MenuSlot
km, Int
pointer) <- Int -> KeyOrSlot -> m (Either (KM, KeyOrSlot) MenuSlot, Int)
loop Int
pointer0 KeyOrSlot
km0
  [Char] -> Int -> Int -> m ()
forall (m :: * -> *).
MonadClientUI m =>
[Char] -> Int -> Int -> m ()
saveMenuIx [Char]
menuName Int
initIx Int
pointer
  Either (KM, KeyOrSlot) MenuSlot
-> m (Either (KM, KeyOrSlot) MenuSlot)
forall (m :: * -> *) a. Monad m => a -> m a
return Either (KM, KeyOrSlot) MenuSlot
km

getMenuIx :: MonadClientUI m => String -> Int -> Int -> Int -> m Int
getMenuIx :: [Char] -> Int -> Int -> Int -> m Int
getMenuIx [Char]
menuName Int
maxIx Int
initIx Int
clearIx = do
  Map [Char] Int
menuIxMap <- (SessionUI -> Map [Char] Int) -> m (Map [Char] Int)
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Map [Char] Int
smenuIxMap
  -- Beware, values in @menuIxMap@ may be negative (meaning: a key, not slot).
  let menuIx :: Int
menuIx = if [Char]
menuName [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
""
               then Int
clearIx
               else Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
clearIx (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
initIx) ([Char] -> Map [Char] Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [Char]
menuName Map [Char] Int
menuIxMap)
                      -- this may still be negative, from different context
  Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> m Int) -> Int -> m Int
forall a b. (a -> b) -> a -> b
$! Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
clearIx (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
maxIx Int
menuIx  -- so clamp to point at item, not key

saveMenuIx :: MonadClientUI m => String -> Int -> Int -> m ()
saveMenuIx :: [Char] -> Int -> Int -> m ()
saveMenuIx [Char]
menuName Int
initIx Int
pointer =
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Char]
menuName [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"") (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    (SessionUI -> SessionUI) -> m ()
forall (m :: * -> *).
MonadClientUI m =>
(SessionUI -> SessionUI) -> m ()
modifySession ((SessionUI -> SessionUI) -> m ())
-> (SessionUI -> SessionUI) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionUI
sess ->
      SessionUI
sess {smenuIxMap :: Map [Char] Int
smenuIxMap = [Char] -> Int -> Map [Char] Int -> Map [Char] Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert [Char]
menuName (Int
pointer Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
initIx) (Map [Char] Int -> Map [Char] Int)
-> Map [Char] Int -> Map [Char] Int
forall a b. (a -> b) -> a -> b
$ SessionUI -> Map [Char] Int
smenuIxMap SessionUI
sess}

-- | This is one step of UI menu management user session.
--
-- There is limited looping involved to return a changed position
-- in the menu each time so that the surrounding code has anything
-- interesting to do. The exception is when finally confirming a selection,
-- in which case it's usually not changed compared to last step,
-- but it's presented differently to indicate it was confirmed.
--
-- Any extra keys in the `OKX` argument on top of the those in @Slideshow@
-- argument need to be contained in the @[K.KM]@ argument. Otherwise
-- they are not accepted.
stepChoiceScreen :: forall m . MonadClientUI m
                 => Bool -> ColorMode -> Bool -> Slideshow -> [K.KM]
                 -> m ( Int, Int, Int
                      , Int -> OKX
                        -> m (Bool, Either (K.KM, KeyOrSlot) MenuSlot, Int) )
stepChoiceScreen :: Bool
-> ColorMode
-> Bool
-> Slideshow
-> [KM]
-> m (Int, Int, Int,
      Int -> OKX -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int))
stepChoiceScreen Bool
highlightBullet ColorMode
dm Bool
sfBlank Slideshow
frsX [KM]
extraKeys = do
  CCUI{coscreen :: CCUI -> ScreenContent
coscreen=ScreenContent{Int
rwidth :: Int
rwidth :: ScreenContent -> Int
rwidth, Int
rheight :: Int
rheight :: ScreenContent -> Int
rheight}} <- (SessionUI -> CCUI) -> m CCUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  FontSetup{DisplayFont
monoFont :: FontSetup -> DisplayFont
squareFont :: FontSetup -> DisplayFont
propFont :: DisplayFont
monoFont :: DisplayFont
squareFont :: DisplayFont
propFont :: FontSetup -> DisplayFont
..} <- m FontSetup
forall (m :: * -> *). MonadClientUI m => m FontSetup
getFontSetup
  UIOptions{Bool
uVi :: UIOptions -> Bool
uVi :: Bool
uVi, Bool
uLeftHand :: UIOptions -> Bool
uLeftHand :: Bool
uLeftHand} <- (SessionUI -> UIOptions) -> m UIOptions
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> UIOptions
sUIOptions
  let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (KM
K.escKM KM -> [KM] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KM]
extraKeys) ()
      frs :: [OKX]
frs = Slideshow -> [OKX]
slideshow Slideshow
frsX
      keys :: [KM]
keys = (OKX -> [KM]) -> [OKX] -> [KM]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([KeyOrSlot] -> [KM]
forall a b. [Either a b] -> [a]
lefts ([KeyOrSlot] -> [KM]) -> (OKX -> [KeyOrSlot]) -> OKX -> [KM]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KYX -> KeyOrSlot) -> [KYX] -> [KeyOrSlot]
forall a b. (a -> b) -> [a] -> [b]
map KYX -> KeyOrSlot
forall a b. (a, b) -> a
fst ([KYX] -> [KeyOrSlot]) -> (OKX -> [KYX]) -> OKX -> [KeyOrSlot]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OKX -> [KYX]
forall a b. (a, b) -> b
snd) [OKX]
frs [KM] -> [KM] -> [KM]
forall a. [a] -> [a] -> [a]
++ [KM]
extraKeys
      cardinalKeys :: [KM]
cardinalKeys = Bool -> Bool -> [KM]
K.cardinalAllKM Bool
uVi Bool
uLeftHand
      handleDir :: KM -> Maybe Vector
handleDir = [KM] -> KM -> Maybe Vector
K.handleCardinal [KM]
cardinalKeys
      legalKeys :: [KM]
legalKeys = [KM]
keys [KM] -> [KM] -> [KM]
forall a. [a] -> [a] -> [a]
++ [KM]
navigationKeys [KM] -> [KM] -> [KM]
forall a. [a] -> [a] -> [a]
++ [KM]
cardinalKeys
      allOKX :: [KYX]
allOKX = (OKX -> [KYX]) -> [OKX] -> [KYX]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap OKX -> [KYX]
forall a b. (a, b) -> b
snd [OKX]
frs
      maxIx :: Int
maxIx = [KYX] -> Int
forall a. [a] -> Int
length [KYX]
allOKX Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      initIx :: Int
initIx = case (KYX -> Bool) -> [KYX] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (KeyOrSlot -> Bool
forall a b. Either a b -> Bool
isRight (KeyOrSlot -> Bool) -> (KYX -> KeyOrSlot) -> KYX -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KYX -> KeyOrSlot
forall a b. (a, b) -> a
fst) [KYX]
allOKX of
        Just Int
p -> Int
p
        Maybe Int
_ -> Int
0  -- can't be @length allOKX@ or a multi-page item menu
                -- mangles saved index of other item munus
      clearIx :: Int
clearIx = if Int
initIx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxIx then Int
0 else Int
initIx
      canvasLength :: Int
canvasLength = if Bool
sfBlank then Int
rheight else Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2
      trimmedY :: Int
trimmedY = Int
canvasLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2  -- will be translated down 2 lines
      trimmedAlert :: (PointUI, AttrLine)
trimmedAlert = ( Int -> Int -> PointUI
PointUI Int
0 Int
trimmedY
                     , [Char] -> AttrLine
stringToAL [Char]
"--a portion of the text trimmed--" )
      page :: Int -> OKX -> m (Bool, Either (K.KM, KeyOrSlot) MenuSlot, Int)
      page :: Int -> OKX -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
page Int
pointer (FontOverlayMap
ovsRight0, [KYX]
kyxsRight) = Bool
-> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
-> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
forall a. HasCallStack => Bool -> a -> a
assert (Int
pointer Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0)
                                            (m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
 -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int))
-> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
-> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
forall a b. (a -> b) -> a -> b
$ case Int -> [OKX] -> Maybe (OKX, KYX, Int)
findKYX Int
pointer [OKX]
frs of
        Maybe (OKX, KYX, Int)
Nothing -> [Char] -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
forall a. HasCallStack => [Char] -> a
error ([Char] -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int))
-> [Char] -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
forall a b. (a -> b) -> a -> b
$ [Char]
"no menu keys" [Char] -> [OKX] -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` [OKX]
frs
        Just ( (FontOverlayMap
ovs0, [KYX]
kyxs2)
             , (KeyOrSlot
ekm, (PointUI Int
x1 Int
y, ButtonWidth
buttonWidth))
             , Int
ixOnPage ) -> do
          let ovs1 :: FontOverlayMap
ovs1 = (Overlay -> Overlay) -> FontOverlayMap -> FontOverlayMap
forall a b k. (a -> b) -> EnumMap k a -> EnumMap k b
EM.map (Int -> (Int -> AttrString -> AttrString) -> Overlay -> Overlay
updateLine Int
y ((Int -> AttrString -> AttrString) -> Overlay -> Overlay)
-> (Int -> AttrString -> AttrString) -> Overlay -> Overlay
forall a b. (a -> b) -> a -> b
$ Int -> ButtonWidth -> Int -> AttrString -> AttrString
drawHighlight Int
x1 ButtonWidth
buttonWidth) FontOverlayMap
ovs0
              ovs2 :: FontOverlayMap
ovs2 = if Bool
highlightBullet
                     then (Overlay -> Overlay) -> FontOverlayMap -> FontOverlayMap
forall a b k. (a -> b) -> EnumMap k a -> EnumMap k b
EM.map ([KYX] -> Overlay -> Overlay
highBullet [KYX]
kyxs2) FontOverlayMap
ovs1
                     else FontOverlayMap
ovs1
              -- We add spaces in proportional font under the report rendered
              -- in mono font and the right pane text in prop font,
              -- but over menu lines in proportional font that can be
              -- very long an should not peek from under the right pane text.
              --
              -- We translate the pane by two characters right, because it looks
              -- better when a couple last characters of a line vanish
              -- off-screen than when characters touch in the middle
              -- of the screen. The code producing right panes should take care
              -- to generate lines two shorter than usually.
              --
              -- We move the pane two characters down, because normally
              -- reports should not be longer than three lines
              -- and the third no longer than half width.
              -- We also add two to three lines of backdrop at the bottom.
              ymax :: Int
ymax = FontOverlayMap -> Int
maxYofFontOverlayMap FontOverlayMap
ovsRight0
              -- Apparently prop spaces can be really narrow, hence so many.
              -- With square font, this obscures the link in main menu,
              -- so would need to complicated.
              spaceRectangle :: Overlay
spaceRectangle | DisplayFont -> Bool
isSquareFont DisplayFont
propFont = []
                             | Bool
otherwise =
                                 Int -> Int -> Overlay
rectangleOfSpaces (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4)
                                                   (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
canvasLength (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
ymax Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5)
              trim :: Overlay -> Overlay
trim = ((PointUI, AttrLine) -> Bool) -> Overlay -> Overlay
forall a. (a -> Bool) -> [a] -> [a]
filter (\(PointUI Int
_ Int
yRight, AttrLine
_) -> Int
yRight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
trimmedY)
              -- The alert not clickable, because the player can enter
              -- the menu entry and scroll through the unabridged blurb.
              ovsRight1 :: FontOverlayMap
ovsRight1 = if Int
ymax Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
trimmedY
                          then FontOverlayMap
ovsRight0
                          else (Overlay -> Overlay -> Overlay)
-> FontOverlayMap -> FontOverlayMap -> FontOverlayMap
forall a k.
(a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
EM.unionWith Overlay -> Overlay -> Overlay
forall a. [a] -> [a] -> [a]
(++)
                                 ((Overlay -> Overlay) -> FontOverlayMap -> FontOverlayMap
forall a b k. (a -> b) -> EnumMap k a -> EnumMap k b
EM.map Overlay -> Overlay
trim FontOverlayMap
ovsRight0)
                                 (DisplayFont -> Overlay -> FontOverlayMap
forall k a. Enum k => k -> a -> EnumMap k a
EM.singleton DisplayFont
monoFont [(PointUI, AttrLine)
trimmedAlert])
              ovsRight :: FontOverlayMap
ovsRight = (Overlay -> Overlay -> Overlay)
-> FontOverlayMap -> FontOverlayMap -> FontOverlayMap
forall a k.
(a -> a -> a) -> EnumMap k a -> EnumMap k a -> EnumMap k a
EM.unionWith Overlay -> Overlay -> Overlay
forall a. [a] -> [a] -> [a]
(++)
                           (DisplayFont -> Overlay -> FontOverlayMap
forall k a. Enum k => k -> a -> EnumMap k a
EM.singleton DisplayFont
propFont Overlay
spaceRectangle)
                           ((Overlay -> Overlay) -> FontOverlayMap -> FontOverlayMap
forall a b k. (a -> b) -> EnumMap k a -> EnumMap k b
EM.map (Int -> Int -> Overlay -> Overlay
xytranslateOverlay Int
2 Int
2) FontOverlayMap
ovsRight1)
              (FontOverlayMap
ovs, [KYX]
kyxs) =
                if FontOverlayMap -> Bool
forall k a. EnumMap k a -> Bool
EM.null FontOverlayMap
ovsRight0
                then (FontOverlayMap
ovs2, [KYX]
kyxs2)
                else Int -> Int -> OKX -> OKX -> OKX
sideBySideOKX Int
rwidth Int
0 (FontOverlayMap
ovs2, [KYX]
kyxs2) (FontOverlayMap
ovsRight, [KYX]
kyxsRight)
              kmkm :: Either a b -> Either (a, Either a b) b
kmkm Either a b
ekm2 = case Either a b
ekm2 of
                Left a
km -> (a, Either a b) -> Either (a, Either a b) b
forall a b. a -> Either a b
Left (a
km, Either a b
ekm2)
                Right b
slot -> b -> Either (a, Either a b) b
forall a b. b -> Either a b
Right b
slot
              tmpResult :: Int -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
tmpResult Int
pointer1 = case Int -> [OKX] -> Maybe (OKX, KYX, Int)
findKYX Int
pointer1 [OKX]
frs of
                Maybe (OKX, KYX, Int)
Nothing -> [Char] -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
forall a. HasCallStack => [Char] -> a
error ([Char] -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int))
-> [Char] -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
forall a b. (a -> b) -> a -> b
$ [Char]
"no menu keys" [Char] -> [OKX] -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` [OKX]
frs
                Just (OKX
_, (KeyOrSlot
ekm1, (PointUI, ButtonWidth)
_), Int
_) -> (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
-> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, KeyOrSlot -> Either (KM, KeyOrSlot) MenuSlot
forall a b. Either a b -> Either (a, Either a b) b
kmkm KeyOrSlot
ekm1, Int
pointer1)
              ignoreKey :: m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
ignoreKey = (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
-> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, KeyOrSlot -> Either (KM, KeyOrSlot) MenuSlot
forall a b. Either a b -> Either (a, Either a b) b
kmkm KeyOrSlot
ekm, Int
pointer)
              pageLen :: Int
pageLen = [KYX] -> Int
forall a. [a] -> Int
length [KYX]
kyxs
              xix :: KYX -> Bool
              xix :: KYX -> Bool
xix (KeyOrSlot
_, (PointUI Int
x1' Int
_, ButtonWidth
_)) = Int
x1' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 Bool -> Bool -> Bool
&& Int
x1' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2
              firstRowOfNextPage :: Int
firstRowOfNextPage = Int
pointer Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
pageLen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ixOnPage
              restOKX :: [KYX]
restOKX = Int -> [KYX] -> [KYX]
forall a. Int -> [a] -> [a]
drop Int
firstRowOfNextPage [KYX]
allOKX
              -- This does not take into account the right pane, which is fine.
              firstItemOfNextPage :: Int
firstItemOfNextPage = case (KYX -> Bool) -> [KYX] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (KeyOrSlot -> Bool
forall a b. Either a b -> Bool
isRight (KeyOrSlot -> Bool) -> (KYX -> KeyOrSlot) -> KYX -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KYX -> KeyOrSlot
forall a b. (a, b) -> a
fst) [KYX]
restOKX of
                Just Int
p -> Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
firstRowOfNextPage
                Maybe Int
_ -> Int
firstRowOfNextPage
              interpretKey :: K.KM
                           -> m (Bool, Either (K.KM, KeyOrSlot) MenuSlot, Int)
              interpretKey :: KM -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
interpretKey KM
ikm =
                case KM -> Key
K.key KM
ikm of
                  Key
_ | KM
ikm KM -> KM -> Bool
forall a. Eq a => a -> a -> Bool
== KM
K.controlP -> do
                    -- Silent, because any prompt would be shown too late.
                    m ()
forall (m :: * -> *). MonadClientUI m => m ()
printScreen
                    m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
ignoreKey
                  Key
K.Return -> case KeyOrSlot
ekm of
                    Left KM
km ->
                      if KM -> Key
K.key KM
km Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
K.Return
                      then (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
-> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, (KM, KeyOrSlot) -> Either (KM, KeyOrSlot) MenuSlot
forall a b. a -> Either a b
Left (KM
km, KeyOrSlot
ekm), Int
pointer)
                      else KM -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
interpretKey KM
km
                    Right MenuSlot
c -> (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
-> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, MenuSlot -> Either (KM, KeyOrSlot) MenuSlot
forall a b. b -> Either a b
Right MenuSlot
c, Int
pointer)
                  Key
K.LeftButtonRelease -> do
                    PointUI Int
mx Int
my <- (SessionUI -> PointUI) -> m PointUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> PointUI
spointer
                    let onChoice :: KYX -> Bool
onChoice (KeyOrSlot
_, (PointUI Int
cx Int
cy, ButtonWidth DisplayFont
font Int
clen)) =
                          let blen :: Int
blen | DisplayFont -> Bool
isSquareFont DisplayFont
font = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
clen
                                   | Bool
otherwise = Int
clen
                          in Int
my Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
cy Bool -> Bool -> Bool
&& Int
mx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
cx Bool -> Bool -> Bool
&& Int
mx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
cx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
blen
                    case (KYX -> Bool) -> [KYX] -> Maybe KYX
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find KYX -> Bool
onChoice [KYX]
kyxs of
                      Maybe KYX
Nothing | KM
ikm KM -> [KM] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KM]
keys ->
                        (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
-> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, (KM, KeyOrSlot) -> Either (KM, KeyOrSlot) MenuSlot
forall a b. a -> Either a b
Left (KM
ikm, KeyOrSlot
ekm), Int
pointer)
                      Maybe KYX
Nothing ->
                        if KM
K.spaceKM KM -> [KM] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KM]
keys
                        then (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
-> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, (KM, KeyOrSlot) -> Either (KM, KeyOrSlot) MenuSlot
forall a b. a -> Either a b
Left (KM
K.spaceKM, KeyOrSlot
ekm), Int
pointer)
                        else m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
ignoreKey
                      Just (KeyOrSlot
ckm, (PointUI, ButtonWidth)
_) -> case KeyOrSlot
ckm of
                        Left KM
km ->
                          if KM -> Key
K.key KM
km Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
K.Return Bool -> Bool -> Bool
&& KM
km KM -> [KM] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KM]
keys
                          then (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
-> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, (KM, KeyOrSlot) -> Either (KM, KeyOrSlot) MenuSlot
forall a b. a -> Either a b
Left (KM
km, KeyOrSlot
ekm), Int
pointer)
                          else KM -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
interpretKey KM
km
                        Right MenuSlot
c  -> (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
-> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, MenuSlot -> Either (KM, KeyOrSlot) MenuSlot
forall a b. b -> Either a b
Right MenuSlot
c, Int
pointer)
                  Key
K.RightButtonRelease ->
                    if KM
ikm KM -> [KM] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KM]
keys
                    then (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
-> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, (KM, KeyOrSlot) -> Either (KM, KeyOrSlot) MenuSlot
forall a b. a -> Either a b
Left (KM
ikm, KeyOrSlot
ekm), Int
pointer)
                    else (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
-> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, (KM, KeyOrSlot) -> Either (KM, KeyOrSlot) MenuSlot
forall a b. a -> Either a b
Left (KM
K.escKM, KeyOrSlot
ekm), Int
pointer)
                  Key
K.Space | Int
firstItemOfNextPage Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxIx ->
                    Int -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
tmpResult Int
firstItemOfNextPage
                  K.Unknown [Char]
"SAFE_SPACE" ->
                    if Int
firstItemOfNextPage Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxIx
                    then Int -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
tmpResult Int
firstItemOfNextPage
                    else Int -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
tmpResult Int
clearIx
                  Key
_ | KM
ikm KM -> [KM] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KM]
keys ->
                    (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
-> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, (KM, KeyOrSlot) -> Either (KM, KeyOrSlot) MenuSlot
forall a b. a -> Either a b
Left (KM
ikm, KeyOrSlot
ekm), Int
pointer)
                  Key
_ | KM -> Key
K.key KM
ikm Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
K.WheelNorth
                      Bool -> Bool -> Bool
|| KM -> Maybe Vector
handleDir KM
ikm Maybe Vector -> Maybe Vector -> Bool
forall a. Eq a => a -> a -> Bool
== Vector -> Maybe Vector
forall a. a -> Maybe a
Just (Int -> Int -> Vector
Vector Int
0 (-Int
1)) ->
                    case (KYX -> Bool) -> [KYX] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex KYX -> Bool
xix ([KYX] -> Maybe Int) -> [KYX] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ [KYX] -> [KYX]
forall a. [a] -> [a]
reverse ([KYX] -> [KYX]) -> [KYX] -> [KYX]
forall a b. (a -> b) -> a -> b
$ Int -> [KYX] -> [KYX]
forall a. Int -> [a] -> [a]
take Int
ixOnPage [KYX]
kyxs of
                      Maybe Int
Nothing -> if Int
pointer Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
tmpResult Int
maxIx
                                 else Int -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
tmpResult (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
pointer Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
                      Just Int
ix -> Int -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
tmpResult (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
pointer Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
                  Key
_ | KM -> Key
K.key KM
ikm Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
K.WheelSouth
                      Bool -> Bool -> Bool
|| KM -> Maybe Vector
handleDir KM
ikm Maybe Vector -> Maybe Vector -> Bool
forall a. Eq a => a -> a -> Bool
== Vector -> Maybe Vector
forall a. a -> Maybe a
Just (Int -> Int -> Vector
Vector Int
0 Int
1) ->
                    case (KYX -> Bool) -> [KYX] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex KYX -> Bool
xix ([KYX] -> Maybe Int) -> [KYX] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> [KYX] -> [KYX]
forall a. Int -> [a] -> [a]
drop (Int
ixOnPage Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [KYX]
kyxs of
                      Maybe Int
Nothing -> if Int
pointer Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
maxIx then Int -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
tmpResult Int
0
                                 else Int -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
tmpResult (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
maxIx (Int
pointer Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
                      Just Int
ix -> Int -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
tmpResult (Int
pointer Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                  Key
_ | KM -> Maybe Vector
handleDir KM
ikm Maybe Vector -> Maybe Vector -> Bool
forall a. Eq a => a -> a -> Bool
== Vector -> Maybe Vector
forall a. a -> Maybe a
Just (Int -> Int -> Vector
Vector (-Int
1) Int
0) ->
                    case Int -> [OKX] -> Maybe (OKX, KYX, Int)
findKYX (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
pointer Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) [OKX]
frs of
                      Just (OKX
_, (KeyOrSlot
_, (PointUI Int
_ Int
y2, ButtonWidth
_)), Int
_) | Int
y2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
y ->
                        Int -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
tmpResult (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
pointer Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
                      Maybe (OKX, KYX, Int)
_ -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
ignoreKey
                  Key
_ | KM -> Maybe Vector
handleDir KM
ikm Maybe Vector -> Maybe Vector -> Bool
forall a. Eq a => a -> a -> Bool
== Vector -> Maybe Vector
forall a. a -> Maybe a
Just (Int -> Int -> Vector
Vector Int
1 Int
0) ->
                    case Int -> [OKX] -> Maybe (OKX, KYX, Int)
findKYX (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
maxIx (Int
pointer Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) [OKX]
frs of
                      Just (OKX
_, (KeyOrSlot
_, (PointUI Int
_ Int
y2, ButtonWidth
_)), Int
_) | Int
y2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
y ->
                        Int -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
tmpResult (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
maxIx (Int
pointer Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
                      Maybe (OKX, KYX, Int)
_ -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
ignoreKey
                  Key
K.Home -> Int -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
tmpResult Int
clearIx
                  Key
K.End -> Int -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
tmpResult Int
maxIx
                  Key
K.PgUp ->
                    Int -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
tmpResult (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
pointer Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ixOnPage Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
                  Key
K.PgDn ->
                    -- This doesn't scroll by screenful when header very long
                    -- and menu non-empty, but that scenario is rare, so OK,
                    -- arrow keys may be used instead.
                    Int -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
tmpResult (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
maxIx Int
firstItemOfNextPage)
                  Key
K.Space -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
ignoreKey
                  Key
_ | KM -> Key
K.key KM
ikm Key -> [Key] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char -> Key
K.Char Char
'?', Int -> Key
K.Fun Int
1] -> do
                    -- Clear macros and invoke the help macro.
                    (SessionUI -> SessionUI) -> m ()
forall (m :: * -> *).
MonadClientUI m =>
(SessionUI -> SessionUI) -> m ()
modifySession ((SessionUI -> SessionUI) -> m ())
-> (SessionUI -> SessionUI) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionUI
sess ->
                      SessionUI
sess { smacroFrame :: KeyMacroFrame
smacroFrame =
                               KeyMacroFrame
emptyMacroFrame {keyPending :: KeyMacro
keyPending =
                                                  [KM] -> KeyMacro
KeyMacro [[Char] -> KM
K.mkKM [Char]
"F1"]}
                           , smacroStack :: [KeyMacroFrame]
smacroStack = [] }
                    (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
-> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, (KM, KeyOrSlot) -> Either (KM, KeyOrSlot) MenuSlot
forall a b. a -> Either a b
Left (KM
K.escKM, KeyOrSlot
ekm), Int
pointer)
                  Key
_ -> [Char] -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
forall a. HasCallStack => [Char] -> a
error ([Char] -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int))
-> [Char] -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown key" [Char] -> KM -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` KM
ikm
          KM
pkm <- ColorMode -> FontOverlayMap -> Bool -> [KM] -> m KM
forall (m :: * -> *).
MonadClientUI m =>
ColorMode -> FontOverlayMap -> Bool -> [KM] -> m KM
promptGetKey ColorMode
dm FontOverlayMap
ovs Bool
sfBlank [KM]
legalKeys
          KM -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
interpretKey KM
pkm
      m :: Int -> OKX -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
m Int
pointer OKX
okxRight =
        if [OKX] -> Bool
forall a. [a] -> Bool
null [OKX]
frs
        then (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
-> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, (KM, KeyOrSlot) -> Either (KM, KeyOrSlot) MenuSlot
forall a b. a -> Either a b
Left (KM
K.escKM, KM -> KeyOrSlot
forall a b. a -> Either a b
Left KM
K.escKM), Int
pointer)
        else do
          (Bool
final, Either (KM, KeyOrSlot) MenuSlot
km, Int
pointer1) <- Int -> OKX -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
page Int
pointer OKX
okxRight
          let !_A1 :: ()
_A1 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (((KM, KeyOrSlot) -> Bool)
-> (MenuSlot -> Bool) -> Either (KM, KeyOrSlot) MenuSlot -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((KM -> [KM] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KM]
keys) (KM -> Bool) -> ((KM, KeyOrSlot) -> KM) -> (KM, KeyOrSlot) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KM, KeyOrSlot) -> KM
forall a b. (a, b) -> a
fst) (Bool -> MenuSlot -> Bool
forall a b. a -> b -> a
const Bool
True) Either (KM, KeyOrSlot) MenuSlot
km) ()
          -- Pointer at a button included, hence greater than 0, not @clearIx@.
          let !_A2 :: ()
_A2 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
pointer1 Bool -> Bool -> Bool
&& Int
pointer1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxIx
                             Bool -> (Int, Int) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame`  (Int
pointer1, Int
maxIx)) ()
          (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
-> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
final, Either (KM, KeyOrSlot) MenuSlot
km, Int
pointer1)
  (Int, Int, Int,
 Int -> OKX -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int))
-> m (Int, Int, Int,
      Int -> OKX -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
maxIx, Int
initIx, Int
clearIx, Int -> OKX -> m (Bool, Either (KM, KeyOrSlot) MenuSlot, Int)
m)

navigationKeys :: [K.KM]
navigationKeys :: [KM]
navigationKeys = [ KM
K.leftButtonReleaseKM, KM
K.rightButtonReleaseKM
                 , KM
K.returnKM, KM
K.spaceKM, KM
K.wheelNorthKM, KM
K.wheelSouthKM
                 , KM
K.pgupKM, KM
K.pgdnKM, KM
K.homeKM, KM
K.endKM, KM
K.controlP
                 , Char -> KM
K.mkChar Char
'?', [Char] -> KM
K.mkKM [Char]
"F1" ]

-- | Find a position in a menu.
-- The arguments go from first menu line and menu page to the last,
-- in order. Their indexing is from 0. We select the nearest item
-- with the index equal or less to the pointer.
findKYX :: Int -> [OKX] -> Maybe (OKX, KYX, Int)
findKYX :: Int -> [OKX] -> Maybe (OKX, KYX, Int)
findKYX Int
_ [] = Maybe (OKX, KYX, Int)
forall a. Maybe a
Nothing
findKYX Int
pointer (okx :: OKX
okx@(FontOverlayMap
_, [KYX]
kyxs) : [OKX]
frs2) =
  case Int -> [KYX] -> [KYX]
forall a. Int -> [a] -> [a]
drop Int
pointer [KYX]
kyxs of
    [] ->  -- not enough menu items on this page
      case Int -> [OKX] -> Maybe (OKX, KYX, Int)
findKYX (Int
pointer Int -> Int -> Int
forall a. Num a => a -> a -> a
- [KYX] -> Int
forall a. [a] -> Int
length [KYX]
kyxs) [OKX]
frs2 of
        Maybe (OKX, KYX, Int)
Nothing ->  -- no more menu items in later pages
          case [KYX] -> [KYX]
forall a. [a] -> [a]
reverse [KYX]
kyxs of
            [] -> Maybe (OKX, KYX, Int)
forall a. Maybe a
Nothing
            KYX
kyx : [KYX]
_ -> (OKX, KYX, Int) -> Maybe (OKX, KYX, Int)
forall a. a -> Maybe a
Just (OKX
okx, KYX
kyx, [KYX] -> Int
forall a. [a] -> Int
length [KYX]
kyxs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        Maybe (OKX, KYX, Int)
res -> Maybe (OKX, KYX, Int)
res
    KYX
kyx : [KYX]
_ -> (OKX, KYX, Int) -> Maybe (OKX, KYX, Int)
forall a. a -> Maybe a
Just (OKX
okx, KYX
kyx, Int
pointer)

drawHighlight :: Int -> ButtonWidth -> Int -> AttrString -> AttrString
drawHighlight :: Int -> ButtonWidth -> Int -> AttrString -> AttrString
drawHighlight Int
x1 (ButtonWidth DisplayFont
font Int
len) Int
xstart AttrString
as =
  let highableAttrs :: [Attr]
highableAttrs = [Attr
Color.defAttr, Attr
Color.defAttr {fg :: Color
Color.fg = Color
Color.BrBlack}]
      highAttr :: AttrChar -> AttrChar
highAttr AttrChar
c | AttrChar -> Attr
Color.acAttr AttrChar
c Attr -> [Attr] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Attr]
highableAttrs
                   Bool -> Bool -> Bool
|| AttrChar -> Char
Color.acChar AttrChar
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' = AttrChar
c
      highAttr AttrChar
c = AttrChar
c {acAttr :: Attr
Color.acAttr =
                        (AttrChar -> Attr
Color.acAttr AttrChar
c) {fg :: Color
Color.fg = Color
Color.BrWhite}}
      cursorAttr :: AttrChar -> AttrChar
cursorAttr AttrChar
c = AttrChar
c {acAttr :: Attr
Color.acAttr =
                          (AttrChar -> Attr
Color.acAttr AttrChar
c)
                             {bg :: Highlight
Color.bg = Highlight
Color.HighlightNoneCursor}}
      noCursorAttr :: AttrChar -> AttrChar
noCursorAttr AttrChar
c = AttrChar
c {acAttr :: Attr
Color.acAttr =
                            (AttrChar -> Attr
Color.acAttr AttrChar
c)
                               {bg :: Highlight
Color.bg = Highlight
Color.HighlightNone}}
      -- This also highlights dull white item symbols, but who cares.
      lenUI :: Int
lenUI = if DisplayFont -> Bool
isSquareFont DisplayFont
font then Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 else Int
len
      x1MinusXStartChars :: Int
x1MinusXStartChars = if DisplayFont -> Bool
isSquareFont DisplayFont
font
                           then (Int
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
xstart) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
                           else Int
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
xstart
      (AttrString
as1, AttrString
asRest) = Int -> AttrString -> (AttrString, AttrString)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
x1MinusXStartChars AttrString
as
      (AttrString
as2, AttrString
as3) = Int -> AttrString -> (AttrString, AttrString)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
len AttrString
asRest
      highW32 :: AttrCharW32 -> AttrCharW32
highW32 = AttrChar -> AttrCharW32
Color.attrCharToW32 (AttrChar -> AttrCharW32)
-> (AttrCharW32 -> AttrChar) -> AttrCharW32 -> AttrCharW32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrChar -> AttrChar
highAttr (AttrChar -> AttrChar)
-> (AttrCharW32 -> AttrChar) -> AttrCharW32 -> AttrChar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrCharW32 -> AttrChar
Color.attrCharFromW32
      as2High :: AttrString
as2High = (AttrCharW32 -> AttrCharW32) -> AttrString -> AttrString
forall a b. (a -> b) -> [a] -> [b]
map AttrCharW32 -> AttrCharW32
highW32 AttrString
as2
      cursorW32 :: AttrCharW32 -> AttrCharW32
cursorW32 = AttrChar -> AttrCharW32
Color.attrCharToW32 (AttrChar -> AttrCharW32)
-> (AttrCharW32 -> AttrChar) -> AttrCharW32 -> AttrCharW32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrChar -> AttrChar
cursorAttr (AttrChar -> AttrChar)
-> (AttrCharW32 -> AttrChar) -> AttrCharW32 -> AttrChar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrCharW32 -> AttrChar
Color.attrCharFromW32
      (AttrString
nonAlpha, AttrString
alpha) = (AttrCharW32 -> Bool) -> AttrString -> (AttrString, AttrString)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Bool
Char.isAlphaNum (Char -> Bool) -> (AttrCharW32 -> Char) -> AttrCharW32 -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrCharW32 -> Char
Color.charFromW32) AttrString
as2High
      as2Cursor :: AttrString
as2Cursor = case AttrString
alpha of
        [] -> []
        AttrCharW32
ch : AttrString
chrest -> AttrCharW32 -> AttrCharW32
cursorW32 AttrCharW32
ch AttrCharW32 -> AttrString -> AttrString
forall a. a -> [a] -> [a]
: AttrString
chrest
      noCursorW32 :: AttrCharW32 -> AttrCharW32
noCursorW32 = AttrChar -> AttrCharW32
Color.attrCharToW32 (AttrChar -> AttrCharW32)
-> (AttrCharW32 -> AttrChar) -> AttrCharW32 -> AttrCharW32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrChar -> AttrChar
noCursorAttr (AttrChar -> AttrChar)
-> (AttrCharW32 -> AttrChar) -> AttrCharW32 -> AttrChar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrCharW32 -> AttrChar
Color.attrCharFromW32
  in if Int
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lenUI Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
xstart
     then AttrString
as
     else AttrString
as1 AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++ (AttrCharW32 -> AttrCharW32) -> AttrString -> AttrString
forall a b. (a -> b) -> [a] -> [b]
map AttrCharW32 -> AttrCharW32
noCursorW32 AttrString
nonAlpha AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++ AttrString
as2Cursor AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++ AttrString
as3

drawBullet :: Int -> ButtonWidth -> Int -> AttrString -> AttrString
drawBullet :: Int -> ButtonWidth -> Int -> AttrString -> AttrString
drawBullet Int
x1 (ButtonWidth DisplayFont
font Int
len) Int
xstart AttrString
as0 =
  let diminishChar :: Char -> Char
diminishChar Char
'-' = Char
' '
      diminishChar Char
'^' = Char
'^'
      diminishChar Char
'"' = Char
'"'
      diminishChar Char
_ = Char
'·'
      highableAttr :: Attr
highableAttr = Attr
Color.defAttr {bg :: Highlight
Color.bg = Highlight
Color.HighlightNoneCursor}
      highW32 :: AttrCharW32 -> AttrCharW32
highW32 AttrCharW32
ac32 =
        let ac :: AttrChar
ac = AttrCharW32 -> AttrChar
Color.attrCharFromW32 AttrCharW32
ac32
            ch :: Char
ch = Char -> Char
diminishChar (Char -> Char) -> Char -> Char
forall a b. (a -> b) -> a -> b
$ AttrChar -> Char
Color.acChar AttrChar
ac
        in if | AttrChar -> Attr
Color.acAttr AttrChar
ac Attr -> Attr -> Bool
forall a. Eq a => a -> a -> Bool
/= Attr
highableAttr -> AttrCharW32
ac32
              | AttrChar -> Char
Color.acChar AttrChar
ac Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' ->
                  [Char] -> AttrCharW32
forall a. HasCallStack => [Char] -> a
error ([Char] -> AttrCharW32) -> [Char] -> AttrCharW32
forall a b. (a -> b) -> a -> b
$ [Char]
"drawBullet: HighlightNoneCursor space forbidden"
                          [Char] -> (AttrChar, [Char]) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` (AttrChar
ac, (AttrCharW32 -> Char) -> AttrString -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map AttrCharW32 -> Char
Color.charFromW32 AttrString
as0)
              | Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' -> AttrCharW32
Color.spaceAttrW32
              | Bool
otherwise ->
                  AttrChar -> AttrCharW32
Color.attrCharToW32
                  (AttrChar -> AttrCharW32) -> AttrChar -> AttrCharW32
forall a b. (a -> b) -> a -> b
$ AttrChar
ac { acAttr :: Attr
Color.acAttr = Attr
Color.defAttr {fg :: Color
Color.fg = Color
Color.BrBlack}
                       , acChar :: Char
Color.acChar = Char
ch }
      lenUI :: Int
lenUI = if DisplayFont -> Bool
isSquareFont DisplayFont
font then Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 else Int
len
      x1MinusXStartChars :: Int
x1MinusXStartChars = if DisplayFont -> Bool
isSquareFont DisplayFont
font
                           then (Int
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
xstart) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
                           else Int
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
xstart
      (AttrString
as1, AttrString
asRest) = Int -> AttrString -> (AttrString, AttrString)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
x1MinusXStartChars AttrString
as0
      (AttrString
as2, AttrString
as3) = Int -> AttrString -> (AttrString, AttrString)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
len AttrString
asRest
      highAs :: AttrString -> AttrString
highAs = \case
        AttrCharW32
toHighlight : AttrString
rest -> AttrCharW32 -> AttrCharW32
highW32 AttrCharW32
toHighlight AttrCharW32 -> AttrString -> AttrString
forall a. a -> [a] -> [a]
: AttrString
rest
        [] -> []
  in if Int
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lenUI Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
xstart
     then AttrString
as0
     else AttrString
as1 AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++ AttrString -> AttrString
highAs AttrString
as2 AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++ AttrString
as3

highBullet :: [KYX] -> Overlay -> Overlay
highBullet :: [KYX] -> Overlay -> Overlay
highBullet [KYX]
kyxs Overlay
ov0 =
  let f :: (a, (PointUI, ButtonWidth)) -> Overlay -> Overlay
f (a
_, (PointUI Int
x1 Int
y, ButtonWidth
buttonWidth)) =
        Int -> (Int -> AttrString -> AttrString) -> Overlay -> Overlay
updateLine Int
y ((Int -> AttrString -> AttrString) -> Overlay -> Overlay)
-> (Int -> AttrString -> AttrString) -> Overlay -> Overlay
forall a b. (a -> b) -> a -> b
$ Int -> ButtonWidth -> Int -> AttrString -> AttrString
drawBullet Int
x1 ButtonWidth
buttonWidth
  in (KYX -> Overlay -> Overlay) -> Overlay -> [KYX] -> Overlay
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr KYX -> Overlay -> Overlay
forall a. (a, (PointUI, ButtonWidth)) -> Overlay -> Overlay
f Overlay
ov0 [KYX]
kyxs

-- This is not our turn, so we can't obstruct screen with messages
-- and message reformatting causes distraction, so there's no point
-- trying to squeeze the report into the single available line,
-- except when it's not our turn permanently, because AI runs UI.
--
-- The only real drawback of this is that when resting for longer time
-- I can't see the boring messages accumulate until a non-boring interrupts me.
basicFrameWithoutReport :: MonadClientUI m
                        => LevelId -> Maybe Bool -> m PreFrame3
basicFrameWithoutReport :: LevelId -> Maybe Bool -> m PreFrame3
basicFrameWithoutReport LevelId
arena Maybe Bool
forceReport = do
  FontSetup{DisplayFont
propFont :: DisplayFont
propFont :: FontSetup -> DisplayFont
propFont} <- m FontSetup
forall (m :: * -> *). MonadClientUI m => m FontSetup
getFontSetup
  Bool
sbenchMessages <- (StateClient -> Bool) -> m Bool
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient ((StateClient -> Bool) -> m Bool)
-> (StateClient -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ ClientOptions -> Bool
sbenchMessages (ClientOptions -> Bool)
-> (StateClient -> ClientOptions) -> StateClient -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateClient -> ClientOptions
soptions
  FactionId
side <- (StateClient -> FactionId) -> m FactionId
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> FactionId
sside
  Faction
fact <- (State -> Faction) -> m Faction
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Faction) -> m Faction)
-> (State -> Faction) -> m Faction
forall a b. (a -> b) -> a -> b
$ (EnumMap FactionId Faction -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
side) (EnumMap FactionId Faction -> Faction)
-> (State -> EnumMap FactionId Faction) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EnumMap FactionId Faction
sfactionD
  FontOverlayMap
truncRep <-
    if | Bool
sbenchMessages -> do
         Slideshow
slides <- Bool -> [KM] -> m Slideshow
forall (m :: * -> *).
MonadClientUI m =>
Bool -> [KM] -> m Slideshow
reportToSlideshowKeepHalt Bool
False []
         case Slideshow -> [OKX]
slideshow Slideshow
slides of
           [] -> FontOverlayMap -> m FontOverlayMap
forall (m :: * -> *) a. Monad m => a -> m a
return FontOverlayMap
forall k a. EnumMap k a
EM.empty
           (FontOverlayMap
ov, [KYX]
_) : [OKX]
_ -> do
             -- See @stepQueryUI@. This strips either "--end-" or "--more-".
             let ovProp :: Overlay
ovProp = FontOverlayMap
ov FontOverlayMap -> DisplayFont -> Overlay
forall k a. Enum k => EnumMap k a -> k -> a
EM.! DisplayFont
propFont
             FontOverlayMap -> m FontOverlayMap
forall (m :: * -> *) a. Monad m => a -> m a
return (FontOverlayMap -> m FontOverlayMap)
-> FontOverlayMap -> m FontOverlayMap
forall a b. (a -> b) -> a -> b
$!
               DisplayFont -> Overlay -> FontOverlayMap
forall k a. Enum k => k -> a -> EnumMap k a
EM.singleton DisplayFont
propFont
               (Overlay -> FontOverlayMap) -> Overlay -> FontOverlayMap
forall a b. (a -> b) -> a -> b
$ if FontOverlayMap -> Int
forall k a. EnumMap k a -> Int
EM.size FontOverlayMap
ov Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then Overlay
ovProp else Overlay -> Overlay
forall a. [a] -> [a]
init Overlay
ovProp
       | Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe (Faction -> Bool
gunderAI Faction
fact) Maybe Bool
forceReport -> do
         Report
report <- Bool -> m Report
forall (m :: * -> *). MonadClientUI m => Bool -> m Report
getReportUI Bool
False
         let par1 :: AttrLine
par1 = AttrString -> AttrLine
firstParagraph (AttrString -> AttrLine) -> AttrString -> AttrLine
forall a b. (a -> b) -> a -> b
$ (AttrString -> AttrString -> AttrString)
-> AttrString -> [AttrString] -> AttrString
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr AttrString -> AttrString -> AttrString
(<+:>) [] ([AttrString] -> AttrString) -> [AttrString] -> AttrString
forall a b. (a -> b) -> a -> b
$ Bool -> Report -> [AttrString]
renderReport Bool
True Report
report
         FontOverlayMap -> m FontOverlayMap
forall (m :: * -> *) a. Monad m => a -> m a
return (FontOverlayMap -> m FontOverlayMap)
-> FontOverlayMap -> m FontOverlayMap
forall a b. (a -> b) -> a -> b
$! [(DisplayFont, Overlay)] -> FontOverlayMap
forall k a. Enum k => [(k, a)] -> EnumMap k a
EM.fromList [(DisplayFont
propFont, [(Int -> Int -> PointUI
PointUI Int
0 Int
0, AttrLine
par1)])]
       | Bool
otherwise -> FontOverlayMap -> m FontOverlayMap
forall (m :: * -> *) a. Monad m => a -> m a
return FontOverlayMap
forall k a. EnumMap k a
EM.empty
  ColorMode -> Bool -> FontOverlayMap -> LevelId -> m PreFrame3
forall (m :: * -> *).
MonadClientUI m =>
ColorMode -> Bool -> FontOverlayMap -> LevelId -> m PreFrame3
drawOverlay ColorMode
ColorFull Bool
False FontOverlayMap
truncRep LevelId
arena

-- | Push the frame depicting the current level to the frame queue.
-- Only one line of the report is shown, as in animations,
-- because it may not be our turn, so we can't clear the message
-- to see what is underneath.
pushFrame :: MonadClientUI m => Bool -> m ()
pushFrame :: Bool -> m ()
pushFrame Bool
delay = do
  -- The delay before reaction to keypress was too long in case of many
  -- projectiles flying and ending flight, so frames need to be skipped.
  Bool
keyPressed <- m Bool
forall (m :: * -> *). MonadClientUI m => m Bool
anyKeyPressed
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
keyPressed (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    LevelId
lidV <- m LevelId
forall (m :: * -> *). MonadClientUI m => m LevelId
viewedLevelUI
    PreFrame3
frame <- LevelId -> Maybe Bool -> m PreFrame3
forall (m :: * -> *).
MonadClientUI m =>
LevelId -> Maybe Bool -> m PreFrame3
basicFrameWithoutReport LevelId
lidV Maybe Bool
forall a. Maybe a
Nothing
    -- Pad with delay before and after to let player see, e.g., door being
    -- opened a few ticks after it came into vision, the same turn.
    LevelId -> PreFrames3 -> m ()
forall (m :: * -> *).
MonadClientUI m =>
LevelId -> PreFrames3 -> m ()
displayFrames LevelId
lidV (PreFrames3 -> m ()) -> PreFrames3 -> m ()
forall a b. (a -> b) -> a -> b
$
      if Bool
delay then [Maybe PreFrame3
forall a. Maybe a
Nothing, PreFrame3 -> Maybe PreFrame3
forall a. a -> Maybe a
Just PreFrame3
frame, Maybe PreFrame3
forall a. Maybe a
Nothing] else [PreFrame3 -> Maybe PreFrame3
forall a. a -> Maybe a
Just PreFrame3
frame]

pushReportFrame :: MonadClientUI m => m ()
pushReportFrame :: m ()
pushReportFrame = do
  LevelId
lidV <- m LevelId
forall (m :: * -> *). MonadClientUI m => m LevelId
viewedLevelUI
  PreFrame3
frame <- LevelId -> Maybe Bool -> m PreFrame3
forall (m :: * -> *).
MonadClientUI m =>
LevelId -> Maybe Bool -> m PreFrame3
basicFrameWithoutReport LevelId
lidV (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
  LevelId -> PreFrames3 -> m ()
forall (m :: * -> *).
MonadClientUI m =>
LevelId -> PreFrames3 -> m ()
displayFrames LevelId
lidV [PreFrame3 -> Maybe PreFrame3
forall a. a -> Maybe a
Just PreFrame3
frame]