module Game.LambdaHack.Display.Gtk
(
FrontendSession
, display, nextEvent
, frontendName, startup, shutdown
) where
import Control.Monad
import Control.Concurrent
import Graphics.UI.Gtk.Gdk.Events
import Graphics.UI.Gtk hiding (Point)
import qualified Data.List as L
import Data.IORef
import qualified Data.Map as M
import qualified Data.ByteString.Char8 as BS
import Game.LambdaHack.Area
import Game.LambdaHack.PointXY
import qualified Game.LambdaHack.Key as K (Key(..), keyTranslate)
import qualified Game.LambdaHack.Color as Color
data FrontendSession = FrontendSession
{ sview :: TextView
, stags :: M.Map Color.Attr TextTag
, schan :: Chan String
}
frontendName :: String
frontendName = "gtk"
startup :: String -> (FrontendSession -> IO ()) -> IO ()
startup configFont k = do
unsafeInitGUIForThreadedRTS
w <- windowNew
ttt <- textTagTableNew
stags <- fmap M.fromList $
mapM (\ ak -> do
tt <- textTagNew Nothing
textTagTableAdd ttt tt
doAttr tt ak
return (ak, tt))
[ Color.Attr{fg, bg}
| fg <- [minBound..maxBound], bg <- Color.legalBG ]
tb <- textBufferNew (Just ttt)
textBufferSetText tb (unlines (replicate 25 (replicate 80 ' ')))
sview <- textViewNewWithBuffer tb
containerAdd w sview
textViewSetEditable sview False
textViewSetCursorVisible sview False
f <- fontDescriptionFromString configFont
widgetModifyFont sview (Just f)
currentfont <- newIORef f
let buttonPressHandler e = case e of
Button { Graphics.UI.Gtk.Gdk.Events.eventButton = RightButton } -> do
fsd <- fontSelectionDialogNew "Choose font"
cf <- readIORef currentfont
fds <- fontDescriptionToString cf
fontSelectionDialogSetFontName fsd fds
fontSelectionDialogSetPreviewText fsd "eee...@.##+##"
resp <- dialogRun fsd
when (resp == ResponseOk) $ do
fn <- fontSelectionDialogGetFontName fsd
case fn of
Just fn' -> do
fd <- fontDescriptionFromString fn'
writeIORef currentfont fd
widgetModifyFont sview (Just fd)
Nothing -> return ()
widgetDestroy fsd
return True
_ -> return False
onButtonPress sview buttonPressHandler
let black = Color minBound minBound minBound
white = Color 0xC500 0xBC00 0xB800
widgetModifyBase sview StateNormal black
widgetModifyText sview StateNormal white
schan <- newChan
forkIO $ k FrontendSession{..}
onKeyPress sview
(\ e -> do
writeChan schan (Graphics.UI.Gtk.Gdk.Events.eventKeyName e)
return True)
onDestroy w mainQuit
widgetShowAll w
yield
mainGUI
shutdown :: FrontendSession -> IO ()
shutdown _ = mainQuit
display :: Area
-> FrontendSession
-> (PointXY -> (Color.Attr, Char))
-> String
-> String
-> IO ()
display (x0, y0, x1, y1) FrontendSession{sview, stags} f msg status =
postGUIAsync $ do
tb <- textViewGetBuffer sview
let fLine y = let (as, cs) = unzip [ f (PointXY (x, y))
| x <- [x0..x1] ]
in ((y, as), BS.pack cs)
memo = L.map fLine [y0..y1]
attrs = L.map fst memo
chars = L.map snd memo
bs = [BS.pack msg, BS.pack "\n", BS.unlines chars, BS.pack status]
textBufferSetByteString tb (BS.concat bs)
mapM_ (setTo tb stags x0) attrs
setTo :: TextBuffer -> M.Map Color.Attr TextTag -> X -> (Y, [Color.Attr])
-> IO ()
setTo _ _ _ (_, []) = return ()
setTo tb tts lx (ly, attr:attrs) = do
ib <- textBufferGetIterAtLineOffset tb (ly + 1) lx
ie <- textIterCopy ib
let setIter :: Color.Attr -> Int -> [Color.Attr] -> IO ()
setIter previous repetitions [] = do
textIterForwardChars ie repetitions
when (previous /= Color.defaultAttr) $
textBufferApplyTag tb (tts M.! previous) ib ie
setIter previous repetitions (a:as)
| a == previous =
setIter a (repetitions + 1) as
| otherwise = do
textIterForwardChars ie repetitions
when (previous /= Color.defaultAttr) $
textBufferApplyTag tb (tts M.! previous) ib ie
textIterForwardChars ib repetitions
setIter a 1 as
setIter attr 1 attrs
nextEvent :: FrontendSession -> IO K.Key
nextEvent sess = do
e <- readUndeadChan (schan sess)
return (K.keyTranslate e)
readUndeadChan :: Chan String -> IO String
readUndeadChan ch = do
x <- readChan ch
if dead x then readUndeadChan ch else return x
where
dead x = case x of
"Shift_R" -> True
"Shift_L" -> True
"Control_L" -> True
"Control_R" -> True
"Super_L" -> True
"Super_R" -> True
"Menu" -> True
"Alt_L" -> True
"Alt_R" -> True
"ISO_Level2_Shift" -> True
"ISO_Level3_Shift" -> True
"ISO_Level2_Latch" -> True
"ISO_Level3_Latch" -> True
"Num_Lock" -> True
"Caps_Lock" -> True
_ -> False
doAttr :: TextTag -> Color.Attr -> IO ()
doAttr tt attr@Color.Attr{fg, bg}
| attr == Color.defaultAttr = return ()
| fg == Color.defFG = set tt [textTagBackground := Color.colorToRGB bg]
| bg == Color.defBG = set tt [textTagForeground := Color.colorToRGB fg]
| otherwise = set tt [textTagForeground := Color.colorToRGB fg,
textTagBackground := Color.colorToRGB bg]