【Haskell】diagramsでgtkのDrawingAreaにお絵かき

HaskellのdiagramsパッケージでgtkのDrawingAreaに描画してみたので、 minimalなサンプルコードを以下に記しておきます。

手順

• 前回の記事に従って、gtkの開発環境を構築する
• diagrams-gtkのインストール

cabal update
cabal install diagrams-gtk

ソースコード

{-# LANGUAGE NoMonomorphismRestriction #-}
module Main where

import Graphics.UI.Gtk
import Graphics.Rendering.Cairo (liftIO)
import Diagrams.Prelude
import Diagrams.Backend.Gtk
import Diagrams.Backend.Cairo (Cairo)

main :: IO ()
main = do
  initGUI
  window <- windowNew
  canvas <- drawingAreaNew
  set window [windowDefaultWidth   := 1000,
              windowDefaultHeight  := 1000,
              containerBorderWidth := 10,
              containerChild       := canvas]
  widgetShowAll window
  -- Event
  window `on` unrealize $ mainQuit
  canvas `on` exposeEvent $ tryEvent $ do
    liftIO $ defaultRender canvas signalImg
  mainGUI

signalImg :: Diagram Cairo R2
signalImg = pad 1.1 $ hinge ||| housing
 where housing = lights <> roundedRect 2 0.8 0.2 # fc gray
       lights = centerXY $ hcat' (with & sep .~ 0.1) $ zipWith fc [red, yellow, green] (replicate 3 $ circle 0.2)
       hinge = vrule 0.8 ||| hrule 0.4

実行結果

当たり判定をつける (7/19加筆）

diagramは、以下のように簡単に当たり判定をつけることができます。

{-# LANGUAGE NoMonomorphismRestriction #-}
module Main where

import Graphics.UI.Gtk
import Graphics.Rendering.Cairo (liftIO)
import Diagrams.Prelude hiding (Renderable)
import Diagrams.Backend.Gtk
import Diagrams.Backend.Cairo (Cairo)
import Control.Monad (when)

main :: IO ()
main = do
    initGUI
    window <- windowNew    
    canvas <- drawingAreaNew
    widgetSetSizeRequest canvas 500 500
    set window [windowDefaultWidth   := 500,
                windowDefaultHeight  := 500,
                containerBorderWidth := 10,
                containerChild       := canvas]
    widgetShowAll window
    -- Event
    window `on` unrealize $ mainQuit
    canvas `on` exposeEvent $ tryEvent $ do
        drawin <- eventWindow
        liftIO $ renderToGtk drawin c1
    canvas `on` buttonPressEvent $ tryEvent $ do
        button <- eventButton
        (x,y)  <- eventCoordinates
        case sample c1 (p2 (x,y)) of
            Any True -> do
                liftIO $ putStrLn "inside"
                liftIO $ putStrLn $ show (x, y)
                return ()
            Any False -> do
                liftIO $ putStrLn "outside"
                liftIO $ putStrLn $ show (x, y)
                return ()
    mainGUI

c1 :: Diagram Cairo R2
c1 = toGtkCoords $ (circle 100 ||| circle 50) # fc gray

実行結果

円の内側をクリックするとinside、 外側をクリックするとoutsideと表示されます。