-- | Text frontend based on ANSI (via ansi-terminal).
module Game.LambdaHack.Client.UI.Frontend.ANSI
  ( startup, frontendName
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import           Control.Concurrent.Async
import           Data.Char (chr, ord)
import qualified Data.Text as T
import qualified System.Console.ANSI as ANSI
import           System.Exit (die)
import qualified System.IO as SIO

import           Game.LambdaHack.Client.UI.Content.Screen
import           Game.LambdaHack.Client.UI.Frame
import           Game.LambdaHack.Client.UI.Frontend.Common
import qualified Game.LambdaHack.Client.UI.Key as K
import           Game.LambdaHack.Client.UI.PointUI
import           Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray
import           Game.LambdaHack.Content.TileKind (floorSymbol)
import qualified Game.LambdaHack.Definition.Color as Color

-- No session data maintained by this frontend

-- | The name of the frontend.
frontendName :: String
frontendName :: String
frontendName = String
"ANSI"

-- | Starts the main program loop using the frontend input and output.
startup :: ScreenContent -> IO RawFrontend
startup :: ScreenContent -> IO RawFrontend
startup coscreen :: ScreenContent
coscreen@ScreenContent{X
rwidth :: ScreenContent -> X
rwidth :: X
rwidth, X
rheight :: ScreenContent -> X
rheight :: X
rheight} = do
  IO ()
ANSI.clearScreen
  Maybe (X, X)
myx <- IO (Maybe (X, X))
ANSI.getTerminalSize
  case Maybe (X, X)
myx of
    Just (X
y, X
x) | X
x X -> X -> Bool
forall a. Ord a => a -> a -> Bool
< X
rwidth Bool -> Bool -> Bool
|| X
y X -> X -> Bool
forall a. Ord a => a -> a -> Bool
< X
rheight ->
      -- Unlike @error@, @die@ does not move savefiles aside.
      String -> IO RawFrontend
forall a. String -> IO a
die (String -> IO RawFrontend) -> String -> IO RawFrontend
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
        Text
"The terminal is too small. It should have"
        Text -> Text -> Text
<+> X -> Text
forall a. Show a => a -> Text
tshow X
rwidth
        Text -> Text -> Text
<+> Text
"columns and"
        Text -> Text -> Text
<+> X -> Text
forall a. Show a => a -> Text
tshow X
rheight
        Text -> Text -> Text
<+> Text
"rows, but is has"
        Text -> Text -> Text
<+> X -> Text
forall a. Show a => a -> Text
tshow X
x
        Text -> Text -> Text
<+> Text
"columns and"
        Text -> Text -> Text
<+> X -> Text
forall a. Show a => a -> Text
tshow X
y
        Text -> Text -> Text
<+> Text
"rows. Resize it and run the program again."
    Maybe (X, X)
_ -> do
      RawFrontend
rf <- ScreenContent -> (SingleFrame -> IO ()) -> IO () -> IO RawFrontend
createRawFrontend ScreenContent
coscreen (ScreenContent -> SingleFrame -> IO ()
display ScreenContent
coscreen) (ScreenContent -> IO ()
shutdown ScreenContent
coscreen)
      let storeKeys :: IO ()
          storeKeys :: IO ()
storeKeys = do
            Char
c <- IO Char
SIO.getChar  -- blocks here, so no polling
            String
s <- do
              if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\ESC' then do
                Bool
ready <- Handle -> IO Bool
SIO.hReady Handle
SIO.stdin
                if Bool
ready then do
                  Char
c2 <- IO Char
SIO.getChar
                  case Char
c2 of
                    Char
'\ESC' -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return [Char
c]
                    Char
'[' -> String -> IO String
keycodeInput [Char
c, Char
c2]
                    Char
'O' -> String -> IO String
keycodeInput [Char
c, Char
c2]
                    Char
_ -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return [Char
c, Char
c2]  -- Alt modifier
                else String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return [Char
c]
              else String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return [Char
c]
            let K.KM{Modifier
Key
key :: KM -> Key
modifier :: KM -> Modifier
key :: Key
modifier :: Modifier
..} = String -> KM
keyTranslate String
s
            RawFrontend -> Modifier -> Key -> PointUI -> IO ()
saveKMP RawFrontend
rf Modifier
modifier Key
key (X -> X -> PointUI
PointUI X
0 X
0)
            IO ()
storeKeys
          keycodeInput :: String -> IO String
          keycodeInput :: String -> IO String
keycodeInput String
inputSoFar = do
            Bool
ready <- Handle -> IO Bool
SIO.hReady Handle
SIO.stdin
            if Bool
ready then do
              Char
c <- IO Char
SIO.getChar
              if Char -> X
ord Char
'@' X -> X -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> X
ord Char
c Bool -> Bool -> Bool
&& Char -> X
ord Char
c X -> X -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> X
ord Char
'~'  -- terminator
              then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
inputSoFar String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
c]
              else String -> IO String
keycodeInput  (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
inputSoFar String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
c]
            else String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
inputSoFar
      Handle -> BufferMode -> IO ()
SIO.hSetBuffering Handle
SIO.stdin BufferMode
SIO.NoBuffering
      Handle -> BufferMode -> IO ()
SIO.hSetBuffering Handle
SIO.stderr (BufferMode -> IO ()) -> BufferMode -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe X -> BufferMode
SIO.BlockBuffering (Maybe X -> BufferMode) -> Maybe X -> BufferMode
forall a b. (a -> b) -> a -> b
$
        X -> Maybe X
forall a. a -> Maybe a
Just (X -> Maybe X) -> X -> Maybe X
forall a b. (a -> b) -> a -> b
$ X
2 X -> X -> X
forall a. Num a => a -> a -> a
* X
rwidth X -> X -> X
forall a. Num a => a -> a -> a
* X
rheight
      IO (Async ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async ()) -> IO ()) -> IO (Async ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async IO ()
storeKeys
      RawFrontend -> IO RawFrontend
forall (m :: * -> *) a. Monad m => a -> m a
return (RawFrontend -> IO RawFrontend) -> RawFrontend -> IO RawFrontend
forall a b. (a -> b) -> a -> b
$! RawFrontend
rf

-- This is contrived, because we don't want to depend on libraries
-- that read and interpret terminfo or similar on different architectures.
-- The "works" comments are mostly about Gnome terminal.
-- On the Gnome terminal, fo the keys mention on game help screen,
-- the following don't work: C-TAB, C-S-TAB, C-R, C-?. C-/, C-{, C-}, C-q,
-- C-S, C-P, C-keypad. This is acceptable. No worth adding functionality
-- for decoding modifiers that would, with much luck, enable C-keypad,
-- but no other broken keys. Unless more is broken on other terminals.
-- On rxvt, sadly, KP_5 is a dead key.
keyTranslate :: String -> K.KM
keyTranslate :: String -> KM
keyTranslate String
e = (\(Key
key, Modifier
modifier) -> Modifier -> Key -> KM
K.KM Modifier
modifier Key
key) ((Key, Modifier) -> KM) -> (Key, Modifier) -> KM
forall a b. (a -> b) -> a -> b
$
  case String
e of
    String
"\ESC" -> (Key
K.Esc, Modifier
K.NoModifier)  -- equals @^[@
    Char
'\ESC' : Char
'[' : String
rest -> String -> (Key, Modifier)
keycodeTranslate String
rest
    Char
'\ESC' : Char
'O' : String
rest -> String -> (Key, Modifier)
ocodeTranslate String
rest
    [Char
'\ESC', Char
c] -> (Char -> Key
K.Char Char
c, Modifier
K.Alt)
    String
"\b" -> (Key
K.BackSpace, Modifier
K.NoModifier)  -- same as "\BS" and "\^H" but fails
    String
"\DEL" -> (Key
K.BackSpace, Modifier
K.NoModifier)  -- works; go figure
    String
"\n" -> (Key
K.Return, Modifier
K.NoModifier)
    String
"\r" -> (Key
K.Return, Modifier
K.NoModifier)
    String
" "  -> (Key
K.Space, Modifier
K.NoModifier)
    String
"\t" -> (Key
K.Tab, Modifier
K.NoModifier)  -- apparently equals @\^I@ and @\HT@
    [Char
c] | Char -> X
ord Char
'\^A' X -> X -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> X
ord Char
c Bool -> Bool -> Bool
&& Char -> X
ord Char
c X -> X -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> X
ord Char
'\^Z' ->
          -- Alas, only lower-case letters.
          (Char -> Key
K.Char (Char -> Key) -> Char -> Key
forall a b. (a -> b) -> a -> b
$ X -> Char
chr (X -> Char) -> X -> Char
forall a b. (a -> b) -> a -> b
$ Char -> X
ord Char
c X -> X -> X
forall a. Num a => a -> a -> a
- Char -> X
ord Char
'\^A' X -> X -> X
forall a. Num a => a -> a -> a
+ Char -> X
ord Char
'a', Modifier
K.Control)
        | -- On (some) terminal emulators Shift-keypad direction produces
          -- the same code as number keys. A sensible workaround for that
          -- is using Control for running, but it's not clear how portable
          -- this is, so we do not rely on this exclusively. Since movement
          -- keys are more important than leader picking, we are disabling
          -- the latter and interpreting the keypad numbers as movement.
          --
          -- BTW, S-KP_5 and C-KP_5 are probably still not correctly handled
          -- on some terminals, so this may be the biggest portability problem.
          Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'1'..Char
'9'] -> (Char -> Key
K.KP Char
c, Modifier
K.NoModifier)
        | Bool
otherwise           -> (Char -> Key
K.Char Char
c, Modifier
K.NoModifier)
    String
_ -> (String -> Key
K.Unknown String
e, Modifier
K.NoModifier)

-- From https://en.wikipedia.org/wiki/ANSI_escape_code#Terminal_input_sequences
keycodeTranslate :: String -> (K.Key, K.Modifier)
keycodeTranslate :: String -> (Key, Modifier)
keycodeTranslate String
e =
  case String
e of
    String
"1~" -> (Key
K.Home, Modifier
K.NoModifier)
    String
"2~" -> (Key
K.Insert, Modifier
K.NoModifier)
    String
"3~" -> (Key
K.Delete, Modifier
K.NoModifier)
    String
"4~" -> (Key
K.End , Modifier
K.NoModifier)
    String
"5~" -> (Key
K.PgUp, Modifier
K.NoModifier)
    String
"6~" -> (Key
K.PgDn, Modifier
K.NoModifier)
    String
"7~" -> (Key
K.Home, Modifier
K.NoModifier)
    String
"8~" -> (Key
K.End, Modifier
K.NoModifier)
    String
"9~" -> (String -> Key
K.Unknown (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ String
"\\ESC[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e, Modifier
K.NoModifier)
    String
"10~" -> (X -> Key
K.Fun X
0, Modifier
K.NoModifier)
    String
"11~" -> (X -> Key
K.Fun X
1, Modifier
K.NoModifier)
    String
"12~" -> (X -> Key
K.Fun X
2, Modifier
K.NoModifier)
    String
"13~" -> (X -> Key
K.Fun X
3, Modifier
K.NoModifier)
    String
"14~" -> (X -> Key
K.Fun X
4, Modifier
K.NoModifier)
    String
"15~" -> (X -> Key
K.Fun X
5, Modifier
K.NoModifier)
    String
"17~" -> (X -> Key
K.Fun X
6, Modifier
K.NoModifier)
    String
"18~" -> (X -> Key
K.Fun X
7, Modifier
K.NoModifier)
    String
"19~" -> (X -> Key
K.Fun X
8, Modifier
K.NoModifier)
    String
"20~" -> (X -> Key
K.Fun X
9, Modifier
K.NoModifier)
    String
"21~" -> (X -> Key
K.Fun X
10, Modifier
K.NoModifier)
    String
"22~" -> (String -> Key
K.Unknown (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ String
"\\ESC[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e, Modifier
K.NoModifier)
    String
"23~" -> (X -> Key
K.Fun X
11, Modifier
K.NoModifier)
    String
"24~" -> (X -> Key
K.Fun X
12, Modifier
K.NoModifier)
    String
"25~" -> (X -> Key
K.Fun X
13, Modifier
K.NoModifier)
    String
"26~" -> (X -> Key
K.Fun X
14, Modifier
K.NoModifier)
    String
"27~" -> (String -> Key
K.Unknown (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ String
"\\ESC[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e, Modifier
K.NoModifier)
    String
"28~" -> (X -> Key
K.Fun X
15, Modifier
K.NoModifier)
    String
"29~" -> (X -> Key
K.Fun X
16, Modifier
K.NoModifier)
    String
"30~" -> (String -> Key
K.Unknown (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ String
"\\ESC[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e, Modifier
K.NoModifier)
    String
"32~" -> (X -> Key
K.Fun X
18 , Modifier
K.NoModifier)
    String
"33~" -> (X -> Key
K.Fun X
19 , Modifier
K.NoModifier)
    String
"34~" -> (X -> Key
K.Fun X
20 , Modifier
K.NoModifier)
    String
"35~" -> (String -> Key
K.Unknown (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ String
"\\ESC[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e, Modifier
K.NoModifier)

    String
"A" -> (Key
K.Up, Modifier
K.NoModifier)
    String
"B" -> (Key
K.Down, Modifier
K.NoModifier)
    String
"C" -> (Key
K.Right, Modifier
K.NoModifier)
    String
"D" -> (Key
K.Left, Modifier
K.NoModifier)
    String
"E" -> (Key
K.Begin, Modifier
K.NoModifier)
    String
"F" -> (Key
K.End, Modifier
K.NoModifier)
    String
"G" -> (Char -> Key
K.KP Char
'5', Modifier
K.NoModifier)
    String
"H" -> (Key
K.Home, Modifier
K.NoModifier)
    String
"I" -> (String -> Key
K.Unknown (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ String
"\\ESC[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e, Modifier
K.NoModifier)
    String
"J" -> (String -> Key
K.Unknown (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ String
"\\ESC[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e, Modifier
K.NoModifier)
    String
"K" -> (String -> Key
K.Unknown (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ String
"\\ESC[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e, Modifier
K.NoModifier)
    String
"L" -> (String -> Key
K.Unknown (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ String
"\\ESC[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e, Modifier
K.NoModifier)
    String
"M" -> (String -> Key
K.Unknown (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ String
"\\ESC[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e, Modifier
K.NoModifier)
    String
"N" -> (String -> Key
K.Unknown (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ String
"\\ESC[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e, Modifier
K.NoModifier)
    String
"O" -> (String -> Key
K.Unknown (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ String
"\\ESC[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e, Modifier
K.NoModifier)
    String
"1P" -> (X -> Key
K.Fun X
1, Modifier
K.NoModifier)
    String
"1Q" -> (X -> Key
K.Fun X
2, Modifier
K.NoModifier)
    String
"1R" -> (X -> Key
K.Fun X
3, Modifier
K.NoModifier)
    String
"1S" -> (X -> Key
K.Fun X
4, Modifier
K.NoModifier)
    String
"T" -> (String -> Key
K.Unknown (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ String
"\\ESC[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e, Modifier
K.NoModifier)
    String
"U" -> (String -> Key
K.Unknown (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ String
"\\ESC[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e, Modifier
K.NoModifier)
    String
"V" -> (String -> Key
K.Unknown (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ String
"\\ESC[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e, Modifier
K.NoModifier)
    String
"W" -> (String -> Key
K.Unknown (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ String
"\\ESC[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e, Modifier
K.NoModifier)
    String
"X" -> (String -> Key
K.Unknown (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ String
"\\ESC[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e, Modifier
K.NoModifier)
    String
"Y" -> (String -> Key
K.Unknown (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ String
"\\ESC[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e, Modifier
K.NoModifier)
    String
"Z" -> (Key
K.BackTab, Modifier
K.NoModifier)

--    "r" -> (K.Begin, K.NoModifier)
--    "u" -> (K.Begin, K.NoModifier)

    String
_ -> (String -> Key
K.Unknown (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ String
"\\ESC[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e, Modifier
K.NoModifier)

-- From guesswork, cargo-culting and @sed -n l@.
ocodeTranslate :: String -> (K.Key, K.Modifier)
ocodeTranslate :: String -> (Key, Modifier)
ocodeTranslate String
e =
  case String
e of
    String
"P" -> (X -> Key
K.Fun X
1, Modifier
K.NoModifier)
    String
"Q" -> (X -> Key
K.Fun X
2, Modifier
K.NoModifier)
    String
"R" -> (X -> Key
K.Fun X
3, Modifier
K.NoModifier)
    String
"S" -> (X -> Key
K.Fun X
4, Modifier
K.NoModifier)

    String
"p" -> (Char -> Key
K.KP Char
'0', Modifier
K.Shift)
    String
"q" -> (Char -> Key
K.KP Char
'1', Modifier
K.Shift)
    String
"r" -> (Char -> Key
K.KP Char
'2', Modifier
K.Shift)
    String
"s" -> (Char -> Key
K.KP Char
'3', Modifier
K.Shift)
    String
"t" -> (Char -> Key
K.KP Char
'4', Modifier
K.Shift)
    String
"u" -> (Char -> Key
K.KP Char
'5', Modifier
K.Shift)
    String
"v" -> (Char -> Key
K.KP Char
'6', Modifier
K.Shift)
    String
"w" -> (Char -> Key
K.KP Char
'7', Modifier
K.Shift)
    String
"x" -> (Char -> Key
K.KP Char
'8', Modifier
K.Shift)
    String
"y" -> (Char -> Key
K.KP Char
'9', Modifier
K.Shift)

    String
_ -> (String -> Key
K.Unknown (String -> Key) -> String -> Key
forall a b. (a -> b) -> a -> b
$ String
"\\ESCO" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e, Modifier
K.NoModifier)

shutdown :: ScreenContent -> IO ()
shutdown :: ScreenContent -> IO ()
shutdown ScreenContent{X
rheight :: X
rheight :: ScreenContent -> X
rheight} = do
  -- The lowest position guaranteed to exist.
  Handle -> X -> X -> IO ()
ANSI.hSetCursorPosition Handle
SIO.stderr (X
rheight X -> X -> X
forall a. Num a => a -> a -> a
- X
1) X
0
  Handle -> IO ()
SIO.hFlush Handle
SIO.stdout IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
SIO.hFlush Handle
SIO.stderr

-- | Output to the screen via the frontend.
display :: ScreenContent
        -> SingleFrame
        -> IO ()
display :: ScreenContent -> SingleFrame -> IO ()
display ScreenContent{X
rwidth :: X
rwidth :: ScreenContent -> X
rwidth} SingleFrame{Array AttrCharW32
singleArray :: SingleFrame -> Array AttrCharW32
singleArray :: Array AttrCharW32
singleArray} = do
  Handle -> IO ()
ANSI.hHideCursor Handle
SIO.stderr
  let cutInChunks :: [AttrCharW32] -> [[AttrCharW32]]
cutInChunks [] = []
      cutInChunks [AttrCharW32]
l = let ([AttrCharW32]
ch, [AttrCharW32]
r) = X -> [AttrCharW32] -> ([AttrCharW32], [AttrCharW32])
forall a. X -> [a] -> ([a], [a])
splitAt X
rwidth [AttrCharW32]
l
                      in [AttrCharW32]
ch [AttrCharW32] -> [[AttrCharW32]] -> [[AttrCharW32]]
forall a. a -> [a] -> [a]
: [AttrCharW32] -> [[AttrCharW32]]
cutInChunks [AttrCharW32]
r
      f :: (X, [AttrCharW32]) -> IO ()
f (!X
y, [AttrCharW32]
chunk) = do
        Handle -> X -> X -> IO ()
ANSI.hSetCursorPosition Handle
SIO.stderr X
y X
0
        Handle -> String -> IO ()
SIO.hPutStr Handle
SIO.stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [AttrCharW32] -> String
g [AttrCharW32]
chunk
      g :: [AttrCharW32] -> String
g = (AttrCharW32 -> String) -> [AttrCharW32] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AttrCharW32 -> String
h
      -- Not emitting ANSI if the previous character had the same fg and bg
      -- gains little in terms of maximal lag, due to checkerboard levels/rooms
      -- (even though it triples FPS in normal rooms; but comparing with
      -- previous frame gains even more in normal cases and copes well
      -- with checkerboard; both not worth the effort for this frontend).
      h :: AttrCharW32 -> String
h !AttrCharW32
w =
        let acChar :: Char
acChar = Char -> Char
squashChar (Char -> Char) -> Char -> Char
forall a b. (a -> b) -> a -> b
$ AttrCharW32 -> Char
Color.charFromW32 AttrCharW32
w
            (Color
fg, Color
bg) = Attr -> (Color, Color)
setAttr (Attr -> (Color, Color)) -> Attr -> (Color, Color)
forall a b. (a -> b) -> a -> b
$ AttrCharW32 -> Attr
Color.attrFromW32 AttrCharW32
w
        in [SGR] -> String
ANSI.setSGRCode [ (ColorIntensity -> Color -> SGR) -> (ColorIntensity, Color) -> SGR
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground)
                             ((ColorIntensity, Color) -> SGR) -> (ColorIntensity, Color) -> SGR
forall a b. (a -> b) -> a -> b
$ Color -> (ColorIntensity, Color)
colorTranslate Color
fg
                           , (ColorIntensity -> Color -> SGR) -> (ColorIntensity, Color) -> SGR
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Background)
                             ((ColorIntensity, Color) -> SGR) -> (ColorIntensity, Color) -> SGR
forall a b. (a -> b) -> a -> b
$ Color -> (ColorIntensity, Color)
colorTranslate Color
bg ]
           String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
acChar]
{-
This is dubious, because I can't force bright background colour with that,
only bright foregrounds. And I have at least one bright backround: bright black.
        -- A hack to get bright colors via the bold attribute.
        -- Depending on terminal settings this is needed or not
        -- and the characters really get bold or not.
        -- HSCurses does this by default, in Vty you have to request the hack,
        -- with ANSI we probably need it as well.
        ANSI.hSetSGR SIO.stderr [ANSI.SetConsoleIntensity
                                 $ if Color.isBright fg
                                   then ANSI.BoldIntensity
                                   else ANSI.NormalIntensity]
-}
  ((X, [AttrCharW32]) -> IO ()) -> [(X, [AttrCharW32])] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (X, [AttrCharW32]) -> IO ()
f ([(X, [AttrCharW32])] -> IO ()) -> [(X, [AttrCharW32])] -> IO ()
forall a b. (a -> b) -> a -> b
$ [X] -> [[AttrCharW32]] -> [(X, [AttrCharW32])]
forall a b. [a] -> [b] -> [(a, b)]
zip [X
0 ..] ([[AttrCharW32]] -> [(X, [AttrCharW32])])
-> [[AttrCharW32]] -> [(X, [AttrCharW32])]
forall a b. (a -> b) -> a -> b
$ [AttrCharW32] -> [[AttrCharW32]]
cutInChunks ([AttrCharW32] -> [[AttrCharW32]])
-> [AttrCharW32] -> [[AttrCharW32]]
forall a b. (a -> b) -> a -> b
$ Array AttrCharW32 -> [AttrCharW32]
forall c. UnboxRepClass c => Array c -> [c]
PointArray.toListA Array AttrCharW32
singleArray
  let Point{X
py :: Point -> X
px :: Point -> X
py :: X
px :: X
..} = (AttrCharW32 -> AttrCharW32 -> Ordering)
-> Array AttrCharW32 -> Point
forall c.
UnboxRepClass c =>
(c -> c -> Ordering) -> Array c -> Point
PointArray.maxIndexByA ((AttrCharW32 -> Highlight)
-> AttrCharW32 -> AttrCharW32 -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing AttrCharW32 -> Highlight
Color.bgFromW32) Array AttrCharW32
singleArray
  Handle -> X -> X -> IO ()
ANSI.hSetCursorPosition Handle
SIO.stderr X
py X
px
  Handle -> IO ()
ANSI.hShowCursor Handle
SIO.stderr
  -- Do not trash people's terminals when interrupted:
  Handle -> [SGR] -> IO ()
ANSI.hSetSGR Handle
SIO.stderr [(ColorIntensity -> Color -> SGR) -> (ColorIntensity, Color) -> SGR
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Foreground)
                           ((ColorIntensity, Color) -> SGR) -> (ColorIntensity, Color) -> SGR
forall a b. (a -> b) -> a -> b
$ Color -> (ColorIntensity, Color)
colorTranslate Color
Color.White]
  Handle -> [SGR] -> IO ()
ANSI.hSetSGR Handle
SIO.stderr [(ColorIntensity -> Color -> SGR) -> (ColorIntensity, Color) -> SGR
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ConsoleLayer -> ColorIntensity -> Color -> SGR
ANSI.SetColor ConsoleLayer
ANSI.Background)
                           ((ColorIntensity, Color) -> SGR) -> (ColorIntensity, Color) -> SGR
forall a b. (a -> b) -> a -> b
$ Color -> (ColorIntensity, Color)
colorTranslate Color
Color.Black]
  Handle -> IO ()
SIO.hFlush Handle
SIO.stderr

squashChar :: Char -> Char
squashChar :: Char -> Char
squashChar Char
c = if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
floorSymbol then Char
'.' else Char
c

setAttr :: Color.Attr -> (Color.Color, Color.Color)
setAttr :: Attr -> (Color, Color)
setAttr Color.Attr{Highlight
Color
bg :: Attr -> Highlight
fg :: Attr -> Color
bg :: Highlight
fg :: Color
..} =
  let (Color
fg1, Color
bg1) = case Highlight
bg of
        Highlight
Color.HighlightNone -> (Color
fg, Color
Color.Black)
        Highlight
Color.HighlightWhite ->
          if Color
fg Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
/= Color
Color.Magenta
          then (Color
fg, Color
Color.Magenta)
          else (Color
fg, Color
Color.BrBlack)
        Highlight
Color.HighlightRed ->
          if Color
fg Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
/= Color
Color.Red
          then (Color
fg, Color
Color.Red)
          else (Color
fg, Color
Color.defFG)
        Highlight
Color.HighlightYellow -> (Color
fg, Color
Color.Black)  -- cursor used instead
        Highlight
Color.HighlightYellowAim -> (Color
Color.Black, Color
Color.defFG)
        Highlight
Color.HighlightRedAim ->
          if Color
fg Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
/= Color
Color.Red
          then (Color
fg, Color
Color.Red)
          else (Color
fg, Color
Color.defFG)
        Highlight
Color.HighlightNoneCursor -> (Color
fg, Color
Color.Black)
        Highlight
_ -> if Color
fg Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
/= Highlight -> Color
Color.highlightToColor Highlight
bg
             then (Color
fg, Highlight -> Color
Color.highlightToColor Highlight
bg)
             else (Color
fg, if Color
fg Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
Color.BrBlack
                       then Color
Color.Black
                       else Color
Color.BrBlack)
  in (Color
fg1, Color
bg1)

colorTranslate :: Color.Color -> (ANSI.ColorIntensity, ANSI.Color)
colorTranslate :: Color -> (ColorIntensity, Color)
colorTranslate Color
Color.Black     = (ColorIntensity
ANSI.Dull, Color
ANSI.Black)
colorTranslate Color
Color.Red       = (ColorIntensity
ANSI.Dull, Color
ANSI.Red)
colorTranslate Color
Color.Green     = (ColorIntensity
ANSI.Dull, Color
ANSI.Green)
colorTranslate Color
Color.Brown     = (ColorIntensity
ANSI.Dull, Color
ANSI.Yellow)
colorTranslate Color
Color.Blue      = (ColorIntensity
ANSI.Dull, Color
ANSI.Blue)
colorTranslate Color
Color.Magenta   = (ColorIntensity
ANSI.Dull, Color
ANSI.Magenta)
colorTranslate Color
Color.Cyan      = (ColorIntensity
ANSI.Dull, Color
ANSI.Cyan)
colorTranslate Color
Color.White     = (ColorIntensity
ANSI.Dull, Color
ANSI.White)
colorTranslate Color
Color.AltWhite  = (ColorIntensity
ANSI.Dull, Color
ANSI.White)
colorTranslate Color
Color.BrBlack   = (ColorIntensity
ANSI.Vivid, Color
ANSI.Black)
colorTranslate Color
Color.BrRed     = (ColorIntensity
ANSI.Vivid, Color
ANSI.Red)
colorTranslate Color
Color.BrGreen   = (ColorIntensity
ANSI.Vivid, Color
ANSI.Green)
colorTranslate Color
Color.BrYellow  = (ColorIntensity
ANSI.Vivid, Color
ANSI.Yellow)
colorTranslate Color
Color.BrBlue    = (ColorIntensity
ANSI.Vivid, Color
ANSI.Blue)
colorTranslate Color
Color.BrMagenta = (ColorIntensity
ANSI.Vivid, Color
ANSI.Magenta)
colorTranslate Color
Color.BrCyan    = (ColorIntensity
ANSI.Vivid, Color
ANSI.Cyan)
colorTranslate Color
Color.BrWhite   = (ColorIntensity
ANSI.Vivid, Color
ANSI.White)