content: -- | 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 = "ANSI"
  
  -- | Starts the main program loop using the frontend input and output.
  startup :: ScreenContent -> IO RawFrontend
  startup coscreen@ScreenContent{rwidth, rheight} = do
    ANSI.clearScreen
    myx <- ANSI.getTerminalSize
    case myx of
      Just (y, x) | x < rwidth || y < rheight ->
        -- Unlike @error@, @die@ does not move savefiles aside.
        die $ T.unpack $
          "The terminal is too small. It should have"
          <+> tshow rwidth
          <+> "columns and"
          <+> tshow rheight
          <+> "rows, but is has"
          <+> tshow x
          <+> "columns and"
          <+> tshow y
          <+> "rows. Resize it and run the program again."
      _ -> do
        rf <- createRawFrontend coscreen (display coscreen) (shutdown coscreen)
        let storeKeys :: IO ()
            storeKeys = do
              c <- SIO.getChar  -- blocks here, so no polling
              s <- do
                if c == '\ESC' then do
                  ready <- SIO.hReady SIO.stdin
                  if ready then do
                    c2 <- SIO.getChar
                    case c2 of
                      '\ESC' -> return [c]
                      '[' -> keycodeInput [c, c2]
                      'O' -> keycodeInput [c, c2]
                      _ -> return [c, c2]  -- Alt modifier
                  else return [c]
                else return [c]
              let K.KM{..} = keyTranslate s
              saveKMP rf modifier key (PointUI 0 0)
              storeKeys
            keycodeInput :: String -> IO String
            keycodeInput inputSoFar = do
              ready <- SIO.hReady SIO.stdin
              if ready then do
                c <- SIO.getChar
                if ord '@' <= ord c && ord c <= ord '~'  -- terminator
                then return $ inputSoFar ++ [c]
                else keycodeInput  $ inputSoFar ++ [c]
              else return inputSoFar
        SIO.hSetBuffering SIO.stdin SIO.NoBuffering
        SIO.hSetBuffering SIO.stderr $ SIO.BlockBuffering $
          Just $ 2 * rwidth * rheight
        void $ async storeKeys
        return $! 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 e = (\(key, modifier) -> K.KM modifier key) $
    case e of
      "\ESC" -> (K.Esc, K.NoModifier)  -- equals @^[@
      '\ESC' : '[' : rest -> keycodeTranslate rest
      '\ESC' : 'O' : rest -> ocodeTranslate rest
      ['\ESC', c] -> (K.Char c, K.Alt)
      "\b" -> (K.BackSpace, K.NoModifier)  -- same as "\BS" and "\^H" but fails
      "\DEL" -> (K.BackSpace, K.NoModifier)  -- works; go figure
      "\n" -> (K.Return, K.NoModifier)
      "\r" -> (K.Return, K.NoModifier)
      " "  -> (K.Space, K.NoModifier)
      "\t" -> (K.Tab, K.NoModifier)  -- apparently equals @\^I@ and @\HT@
      [c] | ord '\^A' <= ord c && ord c <= ord '\^Z' ->
            -- Alas, only lower-case letters.
            (K.Char $ chr $ ord c - ord '\^A' + ord 'a', 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.
            c `elem` ['1'..'9'] -> (K.KP c, K.NoModifier)
          | otherwise           -> (K.Char c, K.NoModifier)
      _ -> (K.Unknown e, K.NoModifier)
  
  -- From https://en.wikipedia.org/wiki/ANSI_escape_code#Terminal_input_sequences
  keycodeTranslate :: String -> (K.Key, K.Modifier)
  keycodeTranslate e =
    case e of
      "1~" -> (K.Home, K.NoModifier)
      "2~" -> (K.Insert, K.NoModifier)
      "3~" -> (K.Delete, K.NoModifier)
      "4~" -> (K.End , K.NoModifier)
      "5~" -> (K.PgUp, K.NoModifier)
      "6~" -> (K.PgDn, K.NoModifier)
      "7~" -> (K.Home, K.NoModifier)
      "8~" -> (K.End, K.NoModifier)
      "9~" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)
      "10~" -> (K.Fun 0, K.NoModifier)
      "11~" -> (K.Fun 1, K.NoModifier)
      "12~" -> (K.Fun 2, K.NoModifier)
      "13~" -> (K.Fun 3, K.NoModifier)
      "14~" -> (K.Fun 4, K.NoModifier)
      "15~" -> (K.Fun 5, K.NoModifier)
      "17~" -> (K.Fun 6, K.NoModifier)
      "18~" -> (K.Fun 7, K.NoModifier)
      "19~" -> (K.Fun 8, K.NoModifier)
      "20~" -> (K.Fun 9, K.NoModifier)
      "21~" -> (K.Fun 10, K.NoModifier)
      "22~" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)
      "23~" -> (K.Fun 11, K.NoModifier)
      "24~" -> (K.Fun 12, K.NoModifier)
      "25~" -> (K.Fun 13, K.NoModifier)
      "26~" -> (K.Fun 14, K.NoModifier)
      "27~" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)
      "28~" -> (K.Fun 15, K.NoModifier)
      "29~" -> (K.Fun 16, K.NoModifier)
      "30~" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)
      "32~" -> (K.Fun 18 , K.NoModifier)
      "33~" -> (K.Fun 19 , K.NoModifier)
      "34~" -> (K.Fun 20 , K.NoModifier)
      "35~" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)
  
      "A" -> (K.Up, K.NoModifier)
      "B" -> (K.Down, K.NoModifier)
      "C" -> (K.Right, K.NoModifier)
      "D" -> (K.Left, K.NoModifier)
      "E" -> (K.Begin, K.NoModifier)
      "F" -> (K.End, K.NoModifier)
      "G" -> (K.KP '5', K.NoModifier)
      "H" -> (K.Home, K.NoModifier)
      "I" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)
      "J" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)
      "K" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)
      "L" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)
      "M" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)
      "N" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)
      "O" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)
      "1P" -> (K.Fun 1, K.NoModifier)
      "1Q" -> (K.Fun 2, K.NoModifier)
      "1R" -> (K.Fun 3, K.NoModifier)
      "1S" -> (K.Fun 4, K.NoModifier)
      "T" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)
      "U" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)
      "V" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)
      "W" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)
      "X" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)
      "Y" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)
      "Z" -> (K.BackTab, K.NoModifier)
  
  --    "r" -> (K.Begin, K.NoModifier)
  --    "u" -> (K.Begin, K.NoModifier)
  
      _ -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)
  
  -- From guesswork, cargo-culting and @sed -n l@.
  ocodeTranslate :: String -> (K.Key, K.Modifier)
  ocodeTranslate e =
    case e of
      "P" -> (K.Fun 1, K.NoModifier)
      "Q" -> (K.Fun 2, K.NoModifier)
      "R" -> (K.Fun 3, K.NoModifier)
      "S" -> (K.Fun 4, K.NoModifier)
  
      "p" -> (K.KP '0', K.Shift)
      "q" -> (K.KP '1', K.Shift)
      "r" -> (K.KP '2', K.Shift)
      "s" -> (K.KP '3', K.Shift)
      "t" -> (K.KP '4', K.Shift)
      "u" -> (K.KP '5', K.Shift)
      "v" -> (K.KP '6', K.Shift)
      "w" -> (K.KP '7', K.Shift)
      "x" -> (K.KP '8', K.Shift)
      "y" -> (K.KP '9', K.Shift)
  
      _ -> (K.Unknown $ "\\ESCO" ++ e, K.NoModifier)
  
  shutdown :: ScreenContent -> IO ()
  shutdown ScreenContent{rheight} = do
    -- The lowest position guaranteed to exist.
    ANSI.hSetCursorPosition SIO.stderr (rheight - 1) 0
    SIO.hFlush SIO.stdout >> SIO.hFlush SIO.stderr
  
  -- | Output to the screen via the frontend.
  display :: ScreenContent
          -> SingleFrame
          -> IO ()
  display ScreenContent{rwidth} SingleFrame{singleArray} = do
    ANSI.hHideCursor SIO.stderr
    let cutInChunks [] = []
        cutInChunks l = let (ch, r) = splitAt rwidth l
                        in ch : cutInChunks r
        f (!y, chunk) = do
          ANSI.hSetCursorPosition SIO.stderr y 0
          SIO.hPutStr SIO.stderr $ g chunk
        g = concatMap 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 !w =
          let acChar = squashChar $ Color.charFromW32 w
              (fg, bg) = setAttr $ Color.attrFromW32 w
          in ANSI.setSGRCode [ uncurry (ANSI.SetColor ANSI.Foreground)
                               $ colorTranslate fg
                             , uncurry (ANSI.SetColor ANSI.Background)
                               $ colorTranslate bg ]
             ++ [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]
  -}
    mapM_ f $ zip [0 ..] $ cutInChunks $ PointArray.toListA singleArray
    let Point{..} = PointArray.maxIndexByA (comparing Color.bgFromW32) singleArray
    ANSI.hSetCursorPosition SIO.stderr py px
    ANSI.hShowCursor SIO.stderr
    -- Do not trash people's terminals when interrupted:
    ANSI.hSetSGR SIO.stderr [uncurry (ANSI.SetColor ANSI.Foreground)
                             $ colorTranslate Color.White]
    ANSI.hSetSGR SIO.stderr [uncurry (ANSI.SetColor ANSI.Background)
                             $ colorTranslate Color.Black]
    SIO.hFlush SIO.stderr
  
  squashChar :: Char -> Char
  squashChar c = if c == floorSymbol then '.' else c
  
  setAttr :: Color.Attr -> (Color.Color, Color.Color)
  setAttr Color.Attr{..} =
    let (fg1, bg1) = case bg of
          Color.HighlightNone -> (fg, Color.Black)
          Color.HighlightWhite ->
            if fg /= Color.Magenta
            then (fg, Color.Magenta)
            else (fg, Color.BrBlack)
          Color.HighlightRed ->
            if fg /= Color.Red
            then (fg, Color.Red)
            else (fg, Color.defFG)
          Color.HighlightYellow -> (fg, Color.Black)  -- cursor used instead
          Color.HighlightYellowAim -> (Color.Black, Color.defFG)
          Color.HighlightRedAim ->
            if fg /= Color.Red
            then (fg, Color.Red)
            else (fg, Color.defFG)
          Color.HighlightNoneCursor -> (fg, Color.Black)
          _ -> if fg /= Color.highlightToColor bg
               then (fg, Color.highlightToColor bg)
               else (fg, if fg == Color.BrBlack
                         then Color.Black
                         else Color.BrBlack)
    in (fg1, bg1)
  
  colorTranslate :: Color.Color -> (ANSI.ColorIntensity, ANSI.Color)
  colorTranslate Color.Black     = (ANSI.Dull, ANSI.Black)
  colorTranslate Color.Red       = (ANSI.Dull, ANSI.Red)
  colorTranslate Color.Green     = (ANSI.Dull, ANSI.Green)
  colorTranslate Color.Brown     = (ANSI.Dull, ANSI.Yellow)
  colorTranslate Color.Blue      = (ANSI.Dull, ANSI.Blue)
  colorTranslate Color.Magenta   = (ANSI.Dull, ANSI.Magenta)
  colorTranslate Color.Cyan      = (ANSI.Dull, ANSI.Cyan)
  colorTranslate Color.White     = (ANSI.Dull, ANSI.White)
  colorTranslate Color.AltWhite  = (ANSI.Dull, ANSI.White)
  colorTranslate Color.BrBlack   = (ANSI.Vivid, ANSI.Black)
  colorTranslate Color.BrRed     = (ANSI.Vivid, ANSI.Red)
  colorTranslate Color.BrGreen   = (ANSI.Vivid, ANSI.Green)
  colorTranslate Color.BrYellow  = (ANSI.Vivid, ANSI.Yellow)
  colorTranslate Color.BrBlue    = (ANSI.Vivid, ANSI.Blue)
  colorTranslate Color.BrMagenta = (ANSI.Vivid, ANSI.Magenta)
  colorTranslate Color.BrCyan    = (ANSI.Vivid, ANSI.Cyan)
  colorTranslate Color.BrWhite   = (ANSI.Vivid, ANSI.White)
  