module Game.LambdaHack.Frontend.Gtk
(
FrontendSession
, display, promptGetAnyKey
, frontendName, startup
) where
import Control.Concurrent
import Control.Monad
import Control.Monad.Reader
import qualified Data.ByteString.Char8 as BS
import Data.IORef
import Data.List
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Graphics.UI.Gtk hiding (Point)
import System.Time
import Game.LambdaHack.Common.Animation (SingleFrame (..))
import qualified Game.LambdaHack.Common.Color as Color
import qualified Game.LambdaHack.Common.Key as K (KM (..), Modifier (..),
keyTranslate)
import Game.LambdaHack.Utils.Assert
import Game.LambdaHack.Utils.LQueue
data FrameState =
FPushed
{ fpushed :: !(LQueue (Maybe GtkFrame))
, fshown :: !GtkFrame
}
| FNone
data FrontendSession = FrontendSession
{ sview :: !TextView
, stags :: !(M.Map Color.Attr TextTag)
, schanKey :: !(Chan K.KM)
, sframeState :: !(MVar FrameState)
, slastFull :: !(MVar (GtkFrame, Bool))
}
data GtkFrame = GtkFrame
{ gfChar :: !BS.ByteString
, gfAttr :: ![[TextTag]]
}
deriving Eq
dummyFrame :: GtkFrame
dummyFrame = GtkFrame BS.empty []
onQueue :: (LQueue (Maybe GtkFrame) -> LQueue (Maybe GtkFrame))
-> FrontendSession -> IO ()
onQueue f FrontendSession{sframeState} = do
fs <- takeMVar sframeState
case fs of
FPushed{..} ->
putMVar sframeState FPushed{fpushed = f fpushed, ..}
_ ->
putMVar sframeState fs
lengthQueue :: FrontendSession -> IO Int
lengthQueue FrontendSession{sframeState} = do
fs <- readMVar sframeState
case fs of
FPushed{..} -> return $ lengthLQueue fpushed
_ -> return 0
frontendName :: String
frontendName = "gtk"
startup :: String -> (FrontendSession -> IO ()) -> IO ()
startup = runGtk
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 <- newMVar (dummyFrame, False)
let sess = FrontendSession{..}
forkIO $ k sess >> postGUIAsync mainQuit
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
len <- lengthQueue sess
if n == "space" && len > 1 then
onQueue dropStartLQueue sess
else
writeChan schanKey K.KM {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
output :: FrontendSession
-> GtkFrame
-> IO ()
output FrontendSession{sview, stags} GtkFrame{..} = do
tb <- textViewGetBuffer sview
let attrs = zip [0..] gfAttr
defAttr = stags M.! Color.defAttr
textBufferSetByteString tb gfChar
mapM_ (setTo tb defAttr 0) attrs
setTo :: TextBuffer -> TextTag -> Int -> (Int, [TextTag]) -> IO ()
setTo _ _ _ (_, []) = return ()
setTo tb defAttr 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 /= defAttr) $
textBufferApplyTag tb previous ib ie
setIter previous repetitions (a:as)
| a == previous =
setIter a (repetitions + 1) as
| otherwise = do
textIterForwardChars ie repetitions
when (previous /= defAttr) $
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
pushFrame :: FrontendSession -> Bool -> Bool -> Maybe SingleFrame -> IO ()
pushFrame sess noDelay immediate rawFrame = do
let FrontendSession{sframeState, slastFull} = sess
let !frame = case rawFrame of
Nothing -> Nothing
Just fr -> Just $! evalFrame sess fr
(lastFrame, anyFollowed) <- takeMVar slastFull
let nextFrame = if frame == Just lastFrame
then Nothing
else frame
fs <- takeMVar sframeState
case fs of
FPushed{..} ->
putMVar sframeState
$ if isNothing nextFrame && anyFollowed
then fs
else FPushed{fpushed = writeLQueue fpushed nextFrame, ..}
FNone | immediate -> do
maybe skip (postGUIAsync . output sess) nextFrame
putMVar sframeState FNone
FNone ->
let fpushed = if isJust nextFrame
then writeLQueue newLQueue nextFrame
else newLQueue
fshown = dummyFrame
in putMVar sframeState FPushed{..}
case nextFrame of
Nothing -> putMVar slastFull (lastFrame, True)
Just f -> putMVar slastFull (f, noDelay)
evalFrame :: FrontendSession -> SingleFrame -> GtkFrame
evalFrame FrontendSession{stags} SingleFrame{..} =
let levelChar = map (T.pack . map Color.acChar) sfLevel
gfChar = encodeUtf8 $ T.intercalate (T.singleton '\n')
$ sfTop : levelChar ++ [sfBottom]
gfAttr = reverse $ foldl' ff [] sfLevel
ff ll l = reverse (foldl' f [] l) : ll
f l ac = let !tag = stags M.! Color.acAttr ac in tag : l
in GtkFrame{..}
trimFrameState :: FrontendSession -> IO ()
trimFrameState sess@FrontendSession{sframeState} = do
fs <- takeMVar sframeState
case fs of
FPushed{..} ->
case lastLQueue fpushed of
Just frame -> do
let lastFrame = fshown
nextFrame = if frame == lastFrame
then Nothing
else Just frame
maybe skip (postGUIAsync . output sess) nextFrame
Nothing -> return ()
FNone -> return ()
putMVar sframeState FNone
display :: FrontendSession -> Bool -> Maybe SingleFrame -> IO ()
display sess noDelay = pushFrame sess noDelay False
promptGetAnyKey :: FrontendSession -> SingleFrame -> IO K.KM
promptGetAnyKey sess@FrontendSession{schanKey} frame = do
pushFrame sess True True $ Just frame
km <- readChan schanKey
trimFrameState sess
return 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.defAttr = 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]