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
frontendName :: String
frontendName :: String
frontendName = String
"teletype"
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
Handle -> String -> IO ()
SIO.hPutStrLn Handle
SIO.stderr String
""
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
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' ->
(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)
| 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)