module Game.LambdaHack.Display.Gtk
(
FrontendSession
, display, nextEvent, promptGetKey
, frontendName, startup, shutdown
) where
import Control.Monad
import Control.Monad.Reader
import Control.Concurrent
import Control.Exception (finally)
import Graphics.UI.Gtk.Gdk.EventM
import Graphics.UI.Gtk hiding (Point)
import qualified Data.List as L
import Data.IORef
import Data.Maybe
import qualified Data.Map as M
import qualified Data.ByteString.Char8 as BS
import System.Time
import Game.LambdaHack.Utils.Assert
import Game.LambdaHack.Utils.LQueue
import qualified Game.LambdaHack.Key as K (Key(..), keyTranslate, Modifier(..))
import qualified Game.LambdaHack.Color as Color
data FrameState =
FPushed
{ fpushed :: !(LQueue (Maybe GtkFrame))
, fshown :: !GtkFrame
}
| FSet
{ fsetFrame :: !(Maybe GtkFrame)
}
| FNone
data FrontendSession = FrontendSession
{ sview :: !TextView
, stags :: !(M.Map Color.Attr TextTag)
, schanKey :: !(Chan (K.Key, K.Modifier))
, sframeState :: !(MVar FrameState)
, slastFull :: !(IORef (GtkFrame, Bool))
}
data GtkFrame = GtkFrame
{ gfChar :: !BS.ByteString
, gfAttr :: ![[TextTag]]
}
deriving Eq
dummyFrame :: GtkFrame
dummyFrame = GtkFrame BS.empty []
trimQueue :: FrontendSession -> IO ()
trimQueue FrontendSession{sframeState} = do
fs <- takeMVar sframeState
case fs of
FPushed{..} ->
putMVar sframeState FPushed{fpushed = trimLQueue fpushed, ..}
_ ->
putMVar sframeState fs
frontendName :: String
frontendName = "gtk"
startup :: String -> (FrontendSession -> IO ()) -> IO ()
startup configFont k = do
mv <- newEmptyMVar
void $ forkIO (runGtk configFont k `finally` putMVar mv ())
takeMVar mv
runGtk :: String -> (FrontendSession -> IO ()) -> IO ()
runGtk configFont k = do
unsafeInitGUIForThreadedRTS
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)
sview <- textViewNewWithBuffer tb
textViewSetEditable sview False
textViewSetCursorVisible sview False
schanKey <- newChan
let frameState = FNone
sframeState <- newMVar frameState
slastFull <- newIORef (dummyFrame, False)
let sess = FrontendSession{..}
forkIO $ k sess
forkIO $ pollFrames sess Nothing
sview `on` keyPressEvent $ do
n <- eventKeyName
mods <- eventModifier
let !key = K.keyTranslate n
!modifier = modifierTranslate mods
liftIO $ do
unless (deadKey n) $ do
trimQueue sess
writeChan schanKey (key, modifier)
return True
f <- fontDescriptionFromString configFont
widgetModifyFont sview (Just f)
currentfont <- newIORef f
sview `on` buttonPressEvent $ do
but <- eventButton
liftIO $ case but of
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
let black = Color minBound minBound minBound
white = Color 0xC500 0xBC00 0xB800
widgetModifyBase sview StateNormal black
widgetModifyText sview StateNormal white
w <- windowNew
containerAdd w sview
onDestroy w mainQuit
widgetShowAll w
yield
mainGUI
shutdown :: FrontendSession -> IO ()
shutdown _ = mainQuit
output :: FrontendSession
-> GtkFrame
-> IO ()
output FrontendSession{sview, stags} GtkFrame{..} = do
tb <- textViewGetBuffer sview
let attrs = L.zip [0..] gfAttr
defaultAttr = stags M.! Color.defaultAttr
textBufferSetByteString tb gfChar
mapM_ (setTo tb defaultAttr 0) attrs
setTo :: TextBuffer -> TextTag -> Int -> (Int, [TextTag]) -> IO ()
setTo _ _ _ (_, []) = return ()
setTo tb defaultAttr lx (ly, attr:attrs) = do
ib <- textBufferGetIterAtLineOffset tb (ly + 1) lx
ie <- textIterCopy ib
let setIter :: TextTag -> Int -> [TextTag] -> IO ()
setIter previous repetitions [] = do
textIterForwardChars ie repetitions
when (previous /= defaultAttr) $
textBufferApplyTag tb previous ib ie
setIter previous repetitions (a:as)
| a == previous =
setIter a (repetitions + 1) as
| otherwise = do
textIterForwardChars ie repetitions
when (previous /= defaultAttr) $
textBufferApplyTag tb previous ib ie
textIterForwardChars ib repetitions
setIter a 1 as
setIter attr 1 attrs
maxFps :: Int
maxFps = 15
maxPolls :: Int
maxPolls = let maxP = 120
in assert (maxP >= 2 * maxFps `blame` (maxP, maxFps)) $
maxP
addTime :: ClockTime -> Int -> ClockTime
addTime (TOD s p) ms = TOD s (p + fromIntegral (ms * 1000000))
diffTime :: ClockTime -> ClockTime -> Int
diffTime (TOD s1 p1) (TOD s2 p2) =
(fromIntegral $ s1 s2) * 1000000 +
(fromIntegral $ p1 p2) `div` 1000000
pollFrames :: FrontendSession -> Maybe ClockTime -> IO ()
pollFrames sess (Just setTime) = do
curTime <- getClockTime
let diffT = diffTime setTime curTime
if diffT > 1000000 `div` maxPolls
then do
threadDelay $ diffTime curTime setTime `div` 2
pollFrames sess $ Just setTime
else
pollFrames sess Nothing
pollFrames sess@FrontendSession{sframeState} Nothing = do
fs <- takeMVar sframeState
case fs of
FPushed{..} ->
case tryReadLQueue fpushed of
Just (Just frame, queue) -> do
putMVar sframeState FPushed{fpushed = queue, fshown = frame}
postGUIAsync $ output sess frame
curTime <- getClockTime
threadDelay $ 1000000 `div` (maxFps * 2)
pollFrames sess $ Just $ addTime curTime $ 1000000 `div` maxFps
Just (Nothing, queue) -> do
putMVar sframeState FPushed{fpushed = queue, ..}
curTime <- getClockTime
threadDelay $ 1000000 `div` maxFps
pollFrames sess $ Just $ addTime curTime $ 1000000 `div` maxFps
Nothing -> do
putMVar sframeState fs
threadDelay $ 1000000 `div` maxPolls
pollFrames sess Nothing
_ -> do
putMVar sframeState fs
threadDelay $ 1000000 `div` (maxFps * 2)
pollFrames sess Nothing
display :: FrontendSession -> Bool -> Bool -> Maybe Color.SingleFrame -> IO ()
display sess True noDelay rawFrame = pushFrame sess noDelay rawFrame
display sess False _ (Just rawFrame) = setFrame sess rawFrame
display _ _ _ _ = assert `failure` "display: empty frame to be set"
pushFrame :: FrontendSession -> Bool -> Maybe Color.SingleFrame -> IO ()
pushFrame sess@FrontendSession{sframeState, slastFull} noDelay rawFrame = do
(lastFrame, anyFollowed) <- readIORef slastFull
let frame = maybe Nothing (Just . evalFrame sess) rawFrame
nextFrame =
if frame == Just lastFrame
then Nothing
else frame
fs <- takeMVar sframeState
case fs of
FPushed{..} ->
if (isNothing nextFrame && anyFollowed)
then putMVar sframeState fs
else putMVar sframeState
FPushed{fpushed = writeLQueue fpushed nextFrame, ..}
FSet{} -> assert `failure` "pushFrame: FSet, expecting FPushed or FNone"
FNone ->
let fpushed = if isJust nextFrame
then writeLQueue newLQueue nextFrame
else newLQueue
fshown = dummyFrame
in putMVar sframeState FPushed{..}
yield
case nextFrame of
Nothing -> writeIORef slastFull (lastFrame, True)
Just f -> writeIORef slastFull (f, noDelay)
evalFrame :: FrontendSession -> Color.SingleFrame -> GtkFrame
evalFrame FrontendSession{stags} Color.SingleFrame{..} =
let levelChar = L.map (L.map Color.acChar) sfLevel
gfChar = BS.pack $ L.intercalate "\n" $ sfTop : levelChar ++ [sfBottom]
gfAttr = L.reverse $ L.foldl' ff [] sfLevel
ff ll l = (L.reverse $ L.foldl' f [] l) : ll
f l ac = let !tag = stags M.! Color.acAttr ac in tag : l
in GtkFrame{..}
setFrame :: FrontendSession -> Color.SingleFrame -> IO ()
setFrame sess@FrontendSession{slastFull, sframeState} rawFrame = do
(lastFrame, _) <- readIORef slastFull
let frame = evalFrame sess rawFrame
fsetFrame =
if frame == lastFrame
then Nothing
else Just frame
fs <- takeMVar sframeState
case fs of
FPushed{} -> assert `failure` "setFrame: FPushed, expecting FNone"
FSet{} -> assert `failure` "setFrame: FSet, expecting FNone"
FNone -> do
maybe (return ()) (\ fr -> writeIORef slastFull (fr, False)) fsetFrame
putMVar sframeState FSet{..}
nextEvent :: FrontendSession -> Maybe Bool -> IO (K.Key, K.Modifier)
nextEvent FrontendSession{schanKey, sframeState} Nothing = do
fs <- readMVar sframeState
case fs of
FNone -> return ()
FPushed{} -> assert `failure` "nextEvent: FPushed, expecting FNone"
FSet{} -> assert `failure` "nextEvent: FSet, expecting FNone"
km <- readChan schanKey
return km
nextEvent sess@FrontendSession{schanKey, sframeState} (Just False) = do
fs <- takeMVar sframeState
case fs of
FSet{fsetFrame} -> do
maybe (return ()) (postGUIAsync . output sess) fsetFrame
FPushed{} -> assert `failure` "nextEvent: FPushed, expecting FSet"
FNone -> assert `failure` "nextEvent: FNone, expecting FSet"
putMVar sframeState FNone
km <- readChan schanKey
return km
nextEvent sess@FrontendSession{schanKey, sframeState} (Just True) = do
km <- readChan schanKey
trimQueue sess
fs <- takeMVar sframeState
case fs of
FPushed{..} -> do
case tryReadLQueue fpushed of
Just (Just frame, queue) -> assert (nullLQueue queue) $ do
let lastFrame = fshown
nextFrame =
if frame == lastFrame
then Nothing
else Just frame
maybe (return ()) (postGUIAsync . output sess) nextFrame
Just (Nothing, _) -> assert `failure` "nextEvent: trimmed queue"
Nothing -> return ()
FSet{} -> assert `failure` "nextEvent: FSet, expecting FPushed"
FNone -> assert `failure` "nextEvent: FNone, expecting FPushed"
putMVar sframeState FNone
return km
promptGetKey :: FrontendSession -> [(K.Key, K.Modifier)] -> Color.SingleFrame
-> IO (K.Key, K.Modifier)
promptGetKey sess@FrontendSession{sframeState} keys frame = do
fs <- readMVar sframeState
yield
let doPush = case fs of
FPushed{} -> True
FSet{} ->
assert `failure` "promptGetKey: FSet, expecting FPushed or FNone"
FNone -> False
display sess doPush True $ Just frame
km <- nextEvent sess (Just doPush)
let loop km2 =
if null keys || km2 `elem` keys
then return km2
else do
km3 <- nextEvent sess Nothing
loop km3
loop km
deadKey :: String -> Bool
deadKey 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
modifierTranslate :: [Modifier] -> K.Modifier
modifierTranslate mods =
if Control `elem` mods then K.Control else K.NoModifier
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]