-- | Monadic operations on slideshows and related data.
module Game.LambdaHack.Client.UI.SlideshowM
  ( overlayToSlideshow, reportToSlideshow, reportToSlideshowKeepHalt
  , displaySpaceEsc, displayMore, displayMoreKeep, displayYesNo, getConfirms
  , displayChoiceScreen, displayChoiceScreenWithRightPane
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , getMenuIx, saveMenuIx, stepChoiceScreen, navigationKeys, findKYX
  , drawHighlight
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

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.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 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
  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
-> Int -> Int -> Int -> Report -> [KM] -> OKX -> Slideshow
splitOverlay FontSetup
fontSetup 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
  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
-> Int -> Int -> Int -> Report -> [KM] -> OKX -> Slideshow
splitOverlay FontSetup
fontSetup 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) -> (SlotChar -> KM) -> KeyOrSlot -> KM
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either KM -> KM
forall a. a -> a
id ([Char] -> SlotChar -> KM
forall a. HasCallStack => [Char] -> a
error ([Char] -> SlotChar -> KM) -> [Char] -> SlotChar -> 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 item slot label (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 =
  (KeyOrSlot -> m OKX)
-> [Char] -> ColorMode -> Bool -> Slideshow -> [KM] -> m KeyOrSlot
forall (m :: * -> *).
MonadClientUI m =>
(KeyOrSlot -> m OKX)
-> [Char] -> ColorMode -> Bool -> Slideshow -> [KM] -> m KeyOrSlot
displayChoiceScreenWithRightPane ((KeyOrSlot -> m OKX)
 -> [Char] -> ColorMode -> Bool -> Slideshow -> [KM] -> m KeyOrSlot)
-> (KeyOrSlot -> m OKX)
-> [Char]
-> ColorMode
-> Bool
-> Slideshow
-> [KM]
-> m KeyOrSlot
forall a b. (a -> b) -> a -> b
$ 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

-- | Display a, potentially, multi-screen menu and return the chosen
-- key or item slot label (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)
  -> String -> ColorMode -> Bool -> Slideshow -> [K.KM]
  -> m KeyOrSlot
displayChoiceScreenWithRightPane :: (KeyOrSlot -> m OKX)
-> [Char] -> ColorMode -> Bool -> Slideshow -> [KM] -> m KeyOrSlot
displayChoiceScreenWithRightPane KeyOrSlot -> m OKX
displayInRightPane
                                 [Char]
menuName ColorMode
dm Bool
sfBlank Slideshow
frsX [KM]
extraKeys = do
  (Int
maxIx, Int
initIx, Int
clearIx, Int -> OKX -> m (Bool, KeyOrSlot, Int)
m) <-
    [Char]
-> ColorMode
-> Bool
-> Slideshow
-> [KM]
-> m (Int, Int, Int, Int -> OKX -> m (Bool, KeyOrSlot, Int))
forall (m :: * -> *).
MonadClientUI m =>
[Char]
-> ColorMode
-> Bool
-> Slideshow
-> [KM]
-> m (Int, Int, Int, Int -> OKX -> m (Bool, KeyOrSlot, Int))
stepChoiceScreen [Char]
menuName ColorMode
dm Bool
sfBlank Slideshow
frsX [KM]
extraKeys
  let loop :: Int -> KeyOrSlot -> m (KeyOrSlot, Int)
      loop :: Int -> KeyOrSlot -> m (KeyOrSlot, Int)
loop Int
pointer KeyOrSlot
km = do
        OKX
okxRight <- KeyOrSlot -> m OKX
displayInRightPane KeyOrSlot
km
        (Bool
final, KeyOrSlot
km1, Int
pointer1) <- Int -> OKX -> m (Bool, KeyOrSlot, Int)
m Int
pointer OKX
okxRight
        if Bool
final
        then (KeyOrSlot, Int) -> m (KeyOrSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (KeyOrSlot
km1, Int
pointer1)
        else Int -> KeyOrSlot -> m (KeyOrSlot, Int)
loop Int
pointer1 KeyOrSlot
km1
  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
  (KeyOrSlot
km, Int
pointer) <- Int -> KeyOrSlot -> m (KeyOrSlot, 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
  KeyOrSlot -> m KeyOrSlot
forall (m :: * -> *) a. Monad m => a -> m a
return KeyOrSlot
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
                 => String -> ColorMode -> Bool -> Slideshow -> [K.KM]
                 -> m ( Int, Int, Int
                      , Int -> OKX -> m (Bool, KeyOrSlot, Int) )
stepChoiceScreen :: [Char]
-> ColorMode
-> Bool
-> Slideshow
-> [KM]
-> m (Int, Int, Int, Int -> OKX -> m (Bool, KeyOrSlot, Int))
stepChoiceScreen [Char]
menuName 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
propFont :: FontSetup -> DisplayFont
monoFont :: FontSetup -> DisplayFont
squareFont :: FontSetup -> DisplayFont
propFont :: DisplayFont
monoFont :: DisplayFont
squareFont :: DisplayFont
..} <- m FontSetup
forall (m :: * -> *). MonadClientUI m => m FontSetup
getFontSetup
  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
      legalKeys :: [KM]
legalKeys = [KM]
keys
                  [KM] -> [KM] -> [KM]
forall a. [a] -> [a] -> [a]
++ [KM]
navigationKeys
                  [KM] -> [KM] -> [KM]
forall a. [a] -> [a] -> [a]
++ (if [Char]
menuName [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"help"
                      then [Char -> KM
K.mkChar Char
'?', [Char] -> KM
K.mkKM [Char]
"F1"]
                      else [])  -- a hack
      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, KeyOrSlot, Int)
      page :: Int -> OKX -> m (Bool, KeyOrSlot, Int)
page Int
pointer (FontOverlayMap
ovsRight0, [KYX]
kyxsRight) = Bool -> m (Bool, KeyOrSlot, Int) -> m (Bool, KeyOrSlot, Int)
forall a. HasCallStack => Bool -> a -> a
assert (Int
pointer Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0)
                                            (m (Bool, KeyOrSlot, Int) -> m (Bool, KeyOrSlot, Int))
-> m (Bool, KeyOrSlot, Int) -> m (Bool, KeyOrSlot, 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, KeyOrSlot, Int)
forall a. HasCallStack => [Char] -> a
error ([Char] -> m (Bool, KeyOrSlot, Int))
-> [Char] -> m (Bool, KeyOrSlot, 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]
kyxs1)
             , (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
              -- 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
ovs1, [KYX]
kyxs1)
                else Int -> Int -> OKX -> OKX -> OKX
sideBySideOKX Int
rwidth Int
0 (FontOverlayMap
ovs1, [KYX]
kyxs1) (FontOverlayMap
ovsRight, [KYX]
kyxsRight)
              tmpResult :: Int -> m (Bool, KeyOrSlot, 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, KeyOrSlot, Int)
forall a. HasCallStack => [Char] -> a
error ([Char] -> m (Bool, KeyOrSlot, Int))
-> [Char] -> m (Bool, KeyOrSlot, 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, KeyOrSlot, Int) -> m (Bool, KeyOrSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, KeyOrSlot
ekm1, Int
pointer1)
              ignoreKey :: m (Bool, KeyOrSlot, Int)
ignoreKey = (Bool, KeyOrSlot, Int) -> m (Bool, KeyOrSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, 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, KeyOrSlot, Int)
              interpretKey :: KM -> m (Bool, KeyOrSlot, 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, KeyOrSlot, 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 Bool -> Bool -> Bool
&& KM
km KM -> [KM] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KM]
keys
                      then (Bool, KeyOrSlot, Int) -> m (Bool, KeyOrSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, KM -> KeyOrSlot
forall a b. a -> Either a b
Left KM
km, Int
pointer)
                      else KM -> m (Bool, KeyOrSlot, Int)
interpretKey KM
km
                    Right SlotChar
c -> (Bool, KeyOrSlot, Int) -> m (Bool, KeyOrSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, SlotChar -> KeyOrSlot
forall a b. b -> Either a b
Right SlotChar
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, KeyOrSlot, Int) -> m (Bool, KeyOrSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, KM -> KeyOrSlot
forall a b. a -> Either a b
Left KM
ikm, 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, KeyOrSlot, Int) -> m (Bool, KeyOrSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, KM -> KeyOrSlot
forall a b. a -> Either a b
Left KM
K.spaceKM, Int
pointer)
                                 else m (Bool, KeyOrSlot, 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, KeyOrSlot, Int) -> m (Bool, KeyOrSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, KM -> KeyOrSlot
forall a b. a -> Either a b
Left KM
km, Int
pointer)
                          else KM -> m (Bool, KeyOrSlot, Int)
interpretKey KM
km
                        Right SlotChar
c  -> (Bool, KeyOrSlot, Int) -> m (Bool, KeyOrSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, SlotChar -> KeyOrSlot
forall a b. b -> Either a b
Right SlotChar
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 -> (Bool, KeyOrSlot, Int) -> m (Bool, KeyOrSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, KM -> KeyOrSlot
forall a b. a -> Either a b
Left KM
ikm, Int
pointer)
                       | KM
K.escKM KM -> [KM] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KM]
keys ->
                           (Bool, KeyOrSlot, Int) -> m (Bool, KeyOrSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, KM -> KeyOrSlot
forall a b. a -> Either a b
Left KM
K.escKM, Int
pointer)
                       | Bool
otherwise -> m (Bool, KeyOrSlot, Int)
ignoreKey
                  Key
K.Space | Int
firstItemOfNextPage Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxIx ->
                    Int -> m (Bool, KeyOrSlot, Int)
tmpResult Int
firstItemOfNextPage
                  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]
                      Bool -> Bool -> Bool
&& Int
firstItemOfNextPage Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxIx
                      Bool -> Bool -> Bool
&& [Char]
menuName [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"help" ->  -- a hack
                    Int -> m (Bool, KeyOrSlot, 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, KeyOrSlot, Int)
tmpResult Int
firstItemOfNextPage
                    else Int -> m (Bool, KeyOrSlot, 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, KeyOrSlot, Int) -> m (Bool, KeyOrSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, KM -> KeyOrSlot
forall a b. a -> Either a b
Left KM
ikm, Int
pointer)
                  Key
_ | KM -> Key
K.key KM
ikm Key -> [Key] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Key
K.Up, Key
K.WheelNorth] ->
                    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 -> KM -> m (Bool, KeyOrSlot, Int)
interpretKey KM
ikm{key :: Key
K.key=Key
K.Left}
                      Just Int
ix -> Int -> m (Bool, KeyOrSlot, 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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Key
K.Down, Key
K.WheelSouth] ->
                    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 -> KM -> m (Bool, KeyOrSlot, Int)
interpretKey KM
ikm{key :: Key
K.key=Key
K.Right}
                      Just Int
ix -> Int -> m (Bool, KeyOrSlot, 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
K.Left -> if Int
pointer Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int -> m (Bool, KeyOrSlot, Int)
tmpResult Int
maxIx
                            else Int -> m (Bool, KeyOrSlot, 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))
                  Key
K.Right -> if Int
pointer Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
maxIx then Int -> m (Bool, KeyOrSlot, Int)
tmpResult Int
0
                             else Int -> m (Bool, KeyOrSlot, 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))
                  Key
K.Home -> Int -> m (Bool, KeyOrSlot, Int)
tmpResult Int
clearIx
                  Key
K.End -> Int -> m (Bool, KeyOrSlot, Int)
tmpResult Int
maxIx
                  Key
K.PgUp ->
                    Int -> m (Bool, KeyOrSlot, 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, KeyOrSlot, Int)
tmpResult (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
maxIx Int
firstItemOfNextPage)
                  Key
K.Space -> if Int
pointer Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
maxIx
                             then Int -> m (Bool, KeyOrSlot, Int)
tmpResult Int
clearIx
                             else Int -> m (Bool, KeyOrSlot, Int)
tmpResult Int
maxIx
                  Key
_ -> [Char] -> m (Bool, KeyOrSlot, Int)
forall a. HasCallStack => [Char] -> a
error ([Char] -> m (Bool, KeyOrSlot, Int))
-> [Char] -> m (Bool, KeyOrSlot, 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, KeyOrSlot, Int)
interpretKey KM
pkm
      m :: Int -> OKX -> m (Bool, KeyOrSlot, Int)
m Int
pointer OKX
okxRight =
        if [OKX] -> Bool
forall a. [a] -> Bool
null [OKX]
frs
        then (Bool, KeyOrSlot, Int) -> m (Bool, KeyOrSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, KM -> KeyOrSlot
forall a b. a -> Either a b
Left KM
K.escKM, Int
pointer)
        else do
          (Bool
final, KeyOrSlot
km, Int
pointer1) <- Int -> OKX -> m (Bool, KeyOrSlot, Int)
page Int
pointer OKX
okxRight
          let !_A1 :: ()
_A1 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert ((KM -> Bool) -> (SlotChar -> Bool) -> KeyOrSlot -> 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) (Bool -> SlotChar -> Bool
forall a b. a -> b -> a
const Bool
True) KeyOrSlot
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, KeyOrSlot, Int) -> m (Bool, KeyOrSlot, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
final, KeyOrSlot
km, Int
pointer1)
  (Int, Int, Int, Int -> OKX -> m (Bool, KeyOrSlot, Int))
-> m (Int, Int, Int, Int -> OKX -> m (Bool, KeyOrSlot, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
maxIx, Int
initIx, Int
clearIx, Int -> OKX -> m (Bool, KeyOrSlot, Int)
m)

navigationKeys :: [K.KM]
navigationKeys :: [KM]
navigationKeys = [ KM
K.leftButtonReleaseKM, KM
K.rightButtonReleaseKM
                 , KM
K.returnKM, KM
K.spaceKM
                 , KM
K.upKM, KM
K.downKM, KM
K.wheelNorthKM, KM
K.wheelSouthKM
                 , KM
K.leftKM, KM
K.rightKM, KM
K.pgupKM, KM
K.pgdnKM
                 , KM
K.homeKM, KM
K.endKM, KM
K.controlP ]

-- | 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}}
      -- 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
      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
      as2High :: AttrString
as2High = case (AttrCharW32 -> AttrCharW32) -> AttrString -> AttrString
forall a b. (a -> b) -> [a] -> [b]
map AttrCharW32 -> AttrCharW32
highW32 AttrString
as2 of
        [] -> []
        AttrCharW32
ch : AttrString
chrest -> AttrCharW32 -> AttrCharW32
cursorW32 AttrCharW32
ch AttrCharW32 -> AttrString -> AttrString
forall a. a -> [a] -> [a]
: AttrString
chrest
  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]
++ AttrString
as2High AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++ AttrString
as3