module Game.LambdaHack.Client.UI.Frontend.Vty
( startup, frontendName
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import Control.Concurrent.Async
import Graphics.Vty
import qualified Graphics.Vty as Vty
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.ClientOptions
import qualified Game.LambdaHack.Common.Color as Color
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray
newtype FrontendSession = FrontendSession
{ svty :: Vty
}
frontendName :: String
frontendName = "vty"
startup :: ClientOptions -> IO RawFrontend
startup _soptions = do
svty <- mkVty mempty
let sess = FrontendSession{..}
rf <- createRawFrontend (display sess) (Vty.shutdown svty)
let storeKeys :: IO ()
storeKeys = do
e <- nextEvent svty
case e of
EvKey n mods ->
saveKMP rf (modTranslate mods) (keyTranslate n) originPoint
_ -> return ()
storeKeys
void $ async storeKeys
return $! rf
display :: FrontendSession
-> SingleFrame
-> IO ()
display FrontendSession{svty} SingleFrame{singleFrame} =
let img = foldr (<->) emptyImage
. map (foldr (<|>) emptyImage
. map (\w -> char (setAttr $ Color.attrFromW32 w)
(Color.charFromW32 w)))
$ chunk $ PointArray.toListA singleFrame
pic = picForImage img
lxsize = fst normalLevelBound + 1
chunk [] = []
chunk l = let (ch, r) = splitAt lxsize l
in ch : chunk r
in update svty pic
keyTranslate :: Key -> K.Key
keyTranslate n =
case n of
KEsc -> K.Esc
KEnter -> K.Return
(KChar ' ') -> K.Space
(KChar '\t') -> K.Tab
KBackTab -> K.BackTab
KBS -> K.BackSpace
KUp -> K.Up
KDown -> K.Down
KLeft -> K.Left
KRight -> K.Right
KHome -> K.Home
KEnd -> K.End
KPageUp -> K.PgUp
KPageDown -> K.PgDn
KBegin -> K.Begin
KCenter -> K.Begin
KIns -> K.Insert
(KChar c)
| c `elem` ['1'..'9'] -> K.KP c
| otherwise -> K.Char c
_ -> K.Unknown (show n)
modTranslate :: [Modifier] -> K.Modifier
modTranslate mods =
modifierTranslate
(MCtrl `elem` mods) (MShift `elem` mods) (MAlt `elem` mods) False
hack :: Color.Color -> Attr -> Attr
hack c a = if Color.isBright c then withStyle a bold else a
setAttr :: Color.Attr -> Attr
setAttr Color.Attr{..} =
let (fg1, bg1) = case bg of
Color.HighlightNone -> (fg, Color.Black)
Color.HighlightRed -> (Color.Black, Color.defFG)
Color.HighlightBlue ->
if fg /= Color.Blue
then (fg, Color.Blue)
else (fg, Color.BrBlack)
Color.HighlightYellow ->
if fg /= Color.Brown
then (fg, Color.Brown)
else (fg, Color.defFG)
Color.HighlightGrey ->
if fg /= Color.BrBlack
then (fg, Color.BrBlack)
else (fg, Color.defFG)
_ -> (fg, Color.Black)
in hack fg1 $ hack bg1 $
defAttr { attrForeColor = SetTo (aToc fg1)
, attrBackColor = SetTo (aToc bg1) }
aToc :: Color.Color -> Color
aToc Color.Black = black
aToc Color.Red = red
aToc Color.Green = green
aToc Color.Brown = yellow
aToc Color.Blue = blue
aToc Color.Magenta = magenta
aToc Color.Cyan = cyan
aToc Color.White = white
aToc Color.BrBlack = brightBlack
aToc Color.BrRed = brightRed
aToc Color.BrGreen = brightGreen
aToc Color.BrYellow = brightYellow
aToc Color.BrBlue = brightBlue
aToc Color.BrMagenta = brightMagenta
aToc Color.BrCyan = brightCyan
aToc Color.BrWhite = brightWhite