Gtk2Hs イベント
ホーム
目次
ボタンクリック
buttonclick.hs
import Graphics.UI.Gtk
buttonclicked :: TextView -> IO ()
buttonclicked textview = do
textbuffer <- textViewGetBuffer textview
end <- textBufferGetEndIter textbuffer
textBufferInsert textbuffer end "\nボタンがクリックされました。"
textViewSetBuffer textview textbuffer
main :: IO ()
main = do
initGUI
window <- windowNew
set window [windowTitle := "ボタン"]
windowSetDefaultSize window 300 200
containerSetBorderWidth window 15
windowSetPosition window WinPosCenter
vbox <- vBoxNew False 15
containerAdd window vbox
halign <- alignmentNew 0 0 1 0
button <- buttonNewWithLabel "クリック"
--widgetSetSizeRequest button 70 30
containerAdd halign button
boxPackStart vbox halign PackNatural 0
-- ここからテキストビュー
sw <- scrolledWindowNew Nothing Nothing
set sw [scrolledWindowVscrollbarPolicy := PolicyAutomatic,
scrolledWindowHscrollbarPolicy := PolicyAutomatic]
textview <- textViewNew
containerAdd (toContainer sw) textview
boxPackStart vbox sw PackGrow 0
-- ここまでテキストビュー
on button buttonActivated $ buttonclicked textview
on window objectDestroy mainQuit
widgetShowAll window
mainGUI
ウィンドウを移動する。
moveevent.hs
import Graphics.UI.Gtk
import Control.Monad.IO.Class
configure :: Window -> Label -> IO ()
configure window label = do
position <- windowGetPosition window
let str = (show (fst position)) ++ ", " ++
(show (snd position))
labelSetText label str
main :: IO ()
main = do
initGUI
window <- windowNew
windowSetPosition window WinPosCenter
windowSetDefaultSize window 300 200
set window [windowTitle := "位置"]
-- ここからラベル
frame <- frameNew
containerSetBorderWidth frame 15
label <- labelNew (Just "")
widgetModifyBg label StateNormal (Color 65535 65535 65535)
font <- fontDescriptionNew
fontDescriptionSetFamily font "Courier"
fontDescriptionSetStyle font StyleItalic
fontDescriptionSetWeight font WeightBook
labelSetAttributes label
[
AttrSize {paStart = 0, paEnd = -1, paSize = 30},
AttrFontDescription {paStart = 0, paEnd = -1, paFontDescription = font},
AttrForeground {paStart = 0, paEnd = -1, paColor =
Color 30000 30000 30000}
]
containerAdd frame label
containerAdd window frame
on window objectDestroy mainQuit
on window configureEvent $ tryEvent $ liftIO $ configure window label
widgetShowAll window
mainGUI
エンターシグナル
「enterNotifyEvent」は、ウィジェットにマウスポインターが重なった時に発せられるイベントです。それに対して「leaveNotifyEvent」は、ウィジェットからマウスポインターが離れた時に発せられるイベントです。
entersignal.hs
import Graphics.UI.Gtk
import Control.Monad.IO.Class --liftIO
enterButton :: Button -> IO ()
enterButton button = do
widgetModifyBg button StateNormal (Color 27000 30000 35000)
widgetModifyFg button StateNormal (Color 65535 65535 65535)
leaveButton :: Button -> IO ()
leaveButton button = do
widgetRestoreBg button StateNormal
widgetRestoreFg button StateNormal
main :: IO ()
main = do
initGUI
window <- windowNew
windowSetPosition window WinPosCenter
windowSetDefaultSize window 300 200
containerSetBorderWidth window 15
set window [windowTitle := "エンターシグナル"]
halign <- alignmentNew 0 1 1 0
button <- buttonNewWithLabel "ボタン"
--widgetSetSizeRequest button 70 30
containerAdd halign button
containerAdd window halign
on button enterNotifyEvent $tryEvent $liftIO
$enterButton button
on button leaveNotifyEvent $tryEvent $liftIO
$leaveButton button
on window objectDestroy mainQuit
widgetShowAll window
mainGUI
ボタンにマウスポインターを重なると、ボタンの背景色と文字色が変わるように設定しています。
WindowsとmacOSでは、背景色だけが変わります。Linuxでは文字色だけが変わります。Gtk2HsのLinuxでは何も変わりません。
イベントの接続と切断
タイトルは「イベントの接続と切断」にしましたが、実際にコードでやっていることは、「イベントの有効化と無効化」になります
disconnect.hs
import Graphics.UI.Gtk
import Control.Monad.IO.Class
buttonclicked :: TextView -> IO ()
buttonclicked textview = do
textbuffer <- textBufferNew Nothing
textbuffer <- textViewGetBuffer textview
end <- textBufferGetEndIter textbuffer
textBufferInsert textbuffer end "ボタンがクリックされました。\n"
textViewSetBuffer textview textbuffer
togglesignal :: (ConnectId Button) -> CheckButton -> Button -> IO ()
togglesignal signalId cb button = do
bool <- toggleButtonGetActive cb
if bool
then signalUnblock signalId
else signalBlock signalId
main :: IO ()
main = do
initGUI
window <- windowNew
windowSetPosition window WinPosCenter
windowSetDefaultSize window 300 200
containerSetBorderWidth window 15
set window [windowTitle := "イベントの接続と切断"]
hbox <- hBoxNew False 15
button <- buttonNewWithLabel "クリック"
widgetSetSizeRequest button 70 30
boxPackStart hbox button PackGrow 0
cb <- checkButtonNewWithLabel "接続"
toggleButtonSetActive cb True
boxPackStart hbox cb PackGrow 0
vbox <- vBoxNew False 5
boxPackStart vbox hbox PackNatural 0
containerAdd window vbox
-- ここからテキストビュー
sw <- scrolledWindowNew Nothing Nothing
textview <- textViewNew
containerAdd (toContainer sw) textview
boxPackStart vbox sw PackGrow 0
-- ここまでテキストビュー
signalId <- on button buttonActivated $buttonclicked textview
on cb buttonActivated $togglesignal signalId cb button
on window objectDestroy mainQuit
widgetShowAll window
mainGUI
ドラッグ ＆ ドロップ
このサンプルはGtk3HsとGtk2Hsでコードが赤色の二行だけ変わります。次のサンプルはGtk3Hsのコードです。Gtk2Hsに対応させるには「import Data.Text」は一行全部を削除します。「case unpack keyName of」は、「unpack」だけを削除します。アプリを終了すには「Control + Q」を押してください。なお、このサンプルはmacOSではウィンドウをドラッグできません。「Control + Q」で終了させることはできます。
dragdrop3.hs
import Graphics.UI.Gtk
import Control.Monad.IO.Class
import Data.Text -- for unpack
buttonpress :: Window -> MouseButton -> IO ()
buttonpress window buttonName = do
if buttonName == LeftButton
then do
(x, y) <- windowGetPosition window
(w, h) <- widgetGetPointer window
windowBeginMoveDrag
window
LeftButton
(x + w)
(y + h)
currentTime
else return ()
main :: IO ()
main = do
initGUI
window <- windowNew
windowSetPosition window WinPosCenter
windowSetDefaultSize window 250 200
set window [windowTitle := "Drag & drop",
windowDecorated := False]
widgetAddEvents window [ButtonPressMask]
on window buttonPressEvent $tryEvent $ do
buttonName <- eventButton
liftIO $ do
buttonpress window buttonName
on window keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
keyName <- eventKeyName
liftIO $
case unpack keyName of
"q" -> do
mainQuit
widgetHide window
on window objectDestroy mainQuit
widgetShowAll window
mainGUI
タイマー
このサンプルは、LinuxのGtk2Hsのみで動作します。
おそらく、このチュートリアルどおりにインストールした場合、WindowsとmacOSのGtk3Hsはバージョンが古いのではないかと思います。
timer3.hs
import Graphics.UI.Gtk
import Graphics.Rendering.Cairo
import Data.Time
onDrawEvent :: DrawingArea -> Render ()
onDrawEvent canvas = do
setSourceRGB 1 1 1
paint
width' <- liftIO $ widgetGetAllocatedWidth canvas
height' <- liftIO $ widgetGetAllocatedHeight canvas
let width = realToFrac width'
height = realToFrac height'
moveTo (width - width/2 - 170) (height - height/2 + 10) -- 位置調整。Adjust position
setSourceRGB 0.5 0.5 0.5
setFontSize 30
selectFontFace "Courier" FontSlantNormal FontWeightNormal
time' <- liftIO $getZonedTime
let time = formatTime defaultTimeLocale "%F %H:%M:%S" time'
showText time
main :: IO ()
main = do
initGUI
window <- windowNew
frame <- frameNew
canvas <- drawingAreaNew
--widgetModifyBg canvas StateNormal (Color 35535 35535 35535)
containerAdd frame canvas
containerAdd window frame
on canvas draw $ onDrawEvent canvas
on window objectDestroy mainQuit
windowSetPosition window WinPosCenter
windowSetDefaultSize window 500 283
set window [windowTitle := "Timer"]
containerSetBorderWidth window 20
widgetShowAll window
timeoutAdd (widgetQueueDraw canvas >> return True) 1000
mainGUI
19702 visits
Posted: Dec. 29, 2018
Update: Dec. 29, 2018