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 = "teletype"
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
let c :: Char
c = case String
l of
[] -> '\n'
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
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' ->
(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)
| 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)