-- | 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 = "teletype"

-- | Set up the frontend input and output.
startup :: ScreenContent -> IO RawFrontend
startup :: ScreenContent -> IO RawFrontend
startup coscreen :: 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
        String
l <- IO String
SIO.getLine  -- blocks here, so no polling
        let c :: Char
c = case String
l of
              [] -> '\n'  -- empty line counts as RET
              hd :: Char
hd : _ -> Char
hd
            K.KM{..} = Char -> KM
keyTranslate Char
c
        RawFrontend -> Modifier -> Key -> PointUI -> IO ()
saveKMP RawFrontend
rf Modifier
modifier Key
key (Int -> Int -> PointUI
PointUI 0 0)
        IO ()
storeKeys
  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 coscreen :: ScreenContent
coscreen SingleFrame{..} = do
  let f :: AttrCharW32 -> String -> String
f w :: AttrCharW32
w l :: 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 '.' 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 l :: String
l = let (ch :: String
ch, r :: 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.hPutStrLn Handle
SIO.stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
levelChar
  (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (Handle -> String -> IO ()
SIO.hPutStrLn Handle
SIO.stderr) ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
    ((PointUI, [AttrCharW32]) -> String) -> OverlaySpace -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((AttrCharW32 -> Char) -> [AttrCharW32] -> String
forall a b. (a -> b) -> [a] -> [b]
map AttrCharW32 -> Char
Color.charFromW32 ([AttrCharW32] -> String)
-> ((PointUI, [AttrCharW32]) -> [AttrCharW32])
-> (PointUI, [AttrCharW32])
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PointUI, [AttrCharW32]) -> [AttrCharW32]
forall a b. (a, b) -> b
snd) OverlaySpace
singlePropOverlay

keyTranslate :: Char -> K.KM
keyTranslate :: Char -> KM
keyTranslate e :: Char
e = (\(key :: Key
key, modifier :: 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
    '\ESC' -> (Key
K.Esc,     Modifier
K.NoModifier)
    '\n'   -> (Key
K.Return,  Modifier
K.NoModifier)
    '\r'   -> (Key
K.Return,  Modifier
K.NoModifier)
    ' '    -> (Key
K.Space,   Modifier
K.NoModifier)
    '\t'   -> (Key
K.Tab,     Modifier
K.NoModifier)
    c :: Char
c | Char -> Int
ord '\^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 '\^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 '\^A' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord '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` ['1'..'9'] -> (Char -> Key
K.KP Char
c,              Modifier
K.NoModifier)
      | Bool
otherwise           -> (Char -> Key
K.Char Char
c,            Modifier
K.NoModifier)