-- | Line terminal text frontend based on stdin/stdout, intended for logging
-- tests, but may be used on a teletype terminal, or with keyboard and printer.
module Game.LambdaHack.Client.UI.Frontend.Teletype
  ( startup, frontendName
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import           Control.Concurrent.Async
import           Data.Char (chr, ord)
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 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
"teletype"

-- | Set up the frontend input and output.
startup :: ScreenContent -> IO RawFrontend
startup :: ScreenContent -> IO RawFrontend
startup ScreenContent
coscreen = do
  RawFrontend
rf <- ScreenContent -> (SingleFrame -> IO ()) -> IO () -> IO RawFrontend
createRawFrontend ScreenContent
coscreen (ScreenContent -> SingleFrame -> IO ()
display ScreenContent
coscreen) IO ()
shutdown
  let storeKeys :: IO ()
      storeKeys :: IO ()
storeKeys = do
        Char
c <- IO Char
SIO.getChar  -- blocks here, so no polling
        let K.KM{Modifier
Key
key :: KM -> Key
modifier :: KM -> Modifier
key :: Key
modifier :: Modifier
..} = Char -> KM
keyTranslate Char
c
        RawFrontend -> Modifier -> Key -> PointUI -> IO ()
saveKMP RawFrontend
rf Modifier
modifier Key
key (Int -> Int -> PointUI
PointUI Int
0 Int
0)
        IO ()
storeKeys
  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 Int -> BufferMode
SIO.BlockBuffering (Maybe Int -> BufferMode) -> Maybe Int -> BufferMode
forall a b. (a -> b) -> a -> b
$
    Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* ScreenContent -> Int
rwidth ScreenContent
coscreen Int -> Int -> Int
forall a. Num a => a -> a -> a
* ScreenContent -> Int
rheight ScreenContent
coscreen
  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

shutdown :: IO ()
shutdown :: IO ()
shutdown = 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
coscreen SingleFrame{Array AttrCharW32
singleArray :: SingleFrame -> Array AttrCharW32
singleArray :: Array AttrCharW32
singleArray} = do
  let f :: AttrCharW32 -> String -> String
f AttrCharW32
w String
l =
        let acCharRaw :: Char
acCharRaw = AttrCharW32 -> Char
Color.charFromW32 AttrCharW32
w
            acChar :: Char
acChar = if Char
acCharRaw Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
floorSymbol then Char
'.' else Char
acCharRaw
        in Char
acChar Char -> String -> String
forall a. a -> [a] -> [a]
: String
l
      levelChar :: [String]
levelChar = String -> [String]
chunk (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ (AttrCharW32 -> String -> String)
-> String -> Array AttrCharW32 -> String
forall c a. UnboxRepClass c => (c -> a -> a) -> a -> Array c -> a
PointArray.foldrA AttrCharW32 -> String -> String
f [] Array AttrCharW32
singleArray
      chunk :: String -> [String]
chunk [] = []
      chunk String
l = let (String
ch, String
r) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt (ScreenContent -> Int
rwidth ScreenContent
coscreen) String
l
                in String
ch String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
chunk String
r
  Handle -> String -> IO ()
SIO.hPutStr Handle
SIO.stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
levelChar
  Handle -> IO ()
SIO.hFlush Handle
SIO.stderr

keyTranslate :: Char -> K.KM
keyTranslate :: Char -> KM
keyTranslate Char
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 Char
e of
    Char
'\ESC' -> (Key
K.Esc,     Modifier
K.NoModifier)
    Char
'\n'   -> (Key
K.Return,  Modifier
K.NoModifier)
    Char
'\r'   -> (Key
K.Return,  Modifier
K.NoModifier)
    Char
' '    -> (Key
K.Space,   Modifier
K.NoModifier)
    Char
'\t'   -> (Key
K.Tab,     Modifier
K.NoModifier)
    Char
c | Char -> Int
ord Char
'\^A' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> Int
ord Char
c Bool -> Bool -> Bool
&& Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> Int
ord Char
'\^Z' ->
        -- Alas, only lower-case letters.
        (Char -> Key
K.Char (Char -> Key) -> Char -> Key
forall a b. (a -> b) -> a -> b
$ Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'\^A' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
'a', Modifier
K.Control)
        -- Movement keys are more important than leader picking,
        -- so disabling the latter and interpreting the keypad numbers
        -- as movement:
      | 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)