header

ボタンの簡易な描画 (2015/11/14)

前回は、GLUTで実装をしていましたが、
GLUTのメインループの外で並行処理を試したら、
動作が不安定になったりして、今後の実装に差し支えそうだったので、
GLFWに移行することにしました。

GLFWの雛形

まずは、最もシンプルに黒い画面だけを描画できるようにします。
ここを参考にさせていただきました。

import Control.Monad (unless)
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.UI.GLFW as GLFW
import System.Exit

unless' :: Monad m => m Bool -> m () -> m ()
unless' action falseAction = do
  b <- action
  unless b falseAction

maybe' :: Maybe a -> b -> (a -> b) -> b
maybe' m nothingRes f =
  case m of
    Nothing -> nothingRes
    Just x  -> f x

mainLoop :: GLFW.Window -> IO ()
mainLoop w = unless' (GLFW.windowShouldClose w) $ do
  (width, height) <- GLFW.getFramebufferSize w
  GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral width) (fromIntegral height))
  GL.clear [GL.ColorBuffer]

  GL.matrixMode $= GL.Projection
  GL.loadIdentity
  let w' = fromIntegral width
      h' = fromIntegral height
  GL.ortho (-0.5) (w' - 0.5) (h' - 0.5) (-0.5) (-1.0) 1.0 -- マウス座標に合わせる(http://www.wakayama-u.ac.jp/~tokoi/opengl/libglut-old.html) 
  GL.matrixMode $= GL.Modelview 0
  
  GLFW.swapBuffers w
  GLFW.waitEvents
  mainLoop w

keyCallback :: GLFW.KeyCallback
keyCallback w GLFW.Key'Escape _ GLFW.KeyState'Pressed _ = GLFW.setWindowShouldClose w True
keyCallback w key scancode action mods = return ()

main :: IO ()
main = do
  GLFW.init
  mw <- GLFW.createWindow 300 300 "gui test" Nothing Nothing
  maybe' mw (GLFW.terminate >> exitFailure) $ \w -> do
    GLFW.makeContextCurrent mw
    GLFW.setKeyCallback w (Just keyCallback)
    mainLoop w
    GLFW.destroyWindow w
    GLFW.terminate
    exitSuccess

マウスクリックで位置を取得

GLFWでは、
マウスボタンに関するコールバックと、
マウスカーソル位置変更のコールバックが分かれています。
なので、
マウスボタンを押下した時のEventと、
カーソル位置を状態として持つBehaviorを作成し、
押下のEvent発火時に位置のBehaviorの情報を取ってくる新たなEventを、
snapshotで作成することで実装することにしました。
マウスボタンを離した時も同様にして作成しました。

import Control.Monad (unless, forever)
import System.Exit
import Control.Applicative ((<$>))
import Data.Maybe (fromMaybe)
import Control.Concurrent (threadDelay, forkIO)
import System.IO (hFlush, stdout)

import qualified Graphics.Rendering.OpenGL as GL
import Graphics.Rendering.OpenGL (($=))
import qualified Graphics.UI.GLFW as GLFW
import FRP.Sodium

中略

----- マウスのボタン
type PushEmpty = () -> Reactive ()
mouseButtonCallback :: PushEmpty -> PushEmpty -> GLFW.MouseButtonCallback
mouseButtonCallback pushLP pushLR _ GLFW.MouseButton'1 state _ = do
  let push = case state of
        GLFW.MouseButtonState'Pressed  -> pushLP
        GLFW.MouseButtonState'Released -> pushLR
  sync $ push ()

mouseButtonCallback _ _ w button state mods = return()

----- マウスカーソルの位置
cursorPosCallback :: (Pos -> Reactive ()) -> GLFW.CursorPosCallback
cursorPosCallback push _ x y =
  sync $ push $ Pos (truncate x) (truncate y)
  
main :: IO ()
main = do
  GLFW.init
  mw <- GLFW.createWindow 300 300 "gui test" Nothing Nothing

  ---
  (evLP, pushLP) <- sync newEvent
  (evLR, pushLR) <- sync newEvent
  (behCursorPos, pushCursorPos) <- sync $ newBehavior $ Pos 0 0
  ---
  sync $ listen (snd <$> snapshot (,) evLP behCursorPos) $ \pos -> putStrLn $ "pressed: " ++ show pos
  sync $ listen (snd <$> snapshot (,) evLR behCursorPos) $ \pos -> putStrLn $ "released: " ++ show pos
  ---

  maybe' mw (GLFW.terminate >> exitFailure) $ \w -> do
    GLFW.makeContextCurrent mw
    GLFW.setKeyCallback w (Just keyCallback)
    GLFW.setMouseButtonCallback w (Just $ mouseButtonCallback pushLP pushLR)
    GLFW.setCursorPosCallback w (Just $ cursorPosCallback pushCursorPos)
    mainLoop w
    GLFW.destroyWindow w
    GLFW.terminate
    exitSuccess

クリックの検出

前回と同様に、クリックの検出イベントを作った。

main = do

  中略

  (evLP, pushLP) <- sync newEvent
  (evLR, pushLR) <- sync newEvent
  (behCursorPos, pushCursorPos) <- sync $ newBehavior $ Pos 0 0
  let evLP' = snd <$> snapshot (,) evLP behCursorPos -- with Pos
      evLR' = snd <$> snapshot (,) evLR behCursorPos -- with Pos
  ---
  (behRect, pushRect) <- sync $ newBehavior (Rectangle 100 100 200 130)
  let evPBtn = filterE within' $ snapshot (,) evLP' behRect
      evRBtn = filterE within' $ snapshot (,) evLR' behRect
  behWR <- sync $ hold False ((const True <$> evPBtn) `merge` (const False <$> evLR)) -- WR (Waiting for release)
  let evClick = filterE snd $ snapshot (,) evRBtn behWR

  -- リスナーで確認
  sync $ listen evClick (\a -> putStrLn ("@ clicked! " ++ show a))

ボタンの描画

いよいよボタンを描画します。

しかし、GLFWとforkIOの相性が悪いという問題があるようで、
スレッドが機能しないケースがあって手間取ってしまいました。

必要がある時にのみ、描画をさせたいので、'waitEvents'を利用したいのですが、 残念ながらこれだとスレッドが機能しません。。
仕方が無いので、'pollEvents'を使ったところ、なんとか上手く機能しました。


実装を示しておきます。
GLFWシステムが描画するタイミングで、イベントを発火させて、
そのイベントに描画するリスナーを登録するようにしました。
これで、新しくボタンを作ったときでも、
描画処理をリスナーに登録すれば、自動的に描画してくれます。

並行処理が実現できるか試したかったので、
別スレッドでボタンを動かす処理を実装しました。
ボタンがランダムに動き回ります。
発展させると、スーパーファミコンのマリオペイントのミニゲームにあった'はえたたき'ができそうです。

import Control.Monad (unless, forever)
import System.Exit
import Control.Applicative ((<$>))
import Data.Maybe (fromMaybe, fromJust)
import Control.Concurrent (threadDelay, forkIO)
import System.IO (hFlush, stdout)
import System.Random

import qualified Graphics.Rendering.OpenGL as GL
import Graphics.Rendering.OpenGL (($=))
import qualified Graphics.UI.GLFW as GLFW
import FRP.Sodium

unless' :: Monad m => m Bool -> m () -> m ()
unless' action falseAction = do
  b <- action
  unless b falseAction

maybe' :: Maybe a -> b -> (a -> b) -> b
maybe' m nothingRes f =
  case m of
    Nothing -> nothingRes
    Just x  -> f x

mainLoop :: GLFW.Window -> (() -> Reactive ()) -> IO ()
mainLoop w pushDraw = unless' (GLFW.windowShouldClose w) $ do
  -- putChar '.' >> hFlush stdout

  (width, height) <- GLFW.getFramebufferSize w
  GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral width) (fromIntegral height))
  GL.clear [GL.ColorBuffer]
  GL.clearColor $= GL.Color4 (240/250) (240/250) (240/250) 1

  GL.matrixMode $= GL.Projection
  GL.loadIdentity
  let w' = fromIntegral width
      h' = fromIntegral height
  GL.ortho (-0.5) (w' - 0.5) (h' - 0.5) (-0.5) (-1.0) 1.0 -- マウス座標に合わせる(http://www.wakayama-u.ac.jp/~tokoi/opengl/libglut-old.html) 
  GL.matrixMode $= GL.Modelview 0

  sync $ pushDraw () -- 描画のためのイベント発火

  GLFW.swapBuffers w

  -- GLFW.waitEvents -- これだと並行処理に失敗する...
  GLFW.pollEvents
  mainLoop w pushDraw

keyCallback :: GLFW.KeyCallback
keyCallback w GLFW.Key'Escape _ GLFW.KeyState'Pressed _ = GLFW.setWindowShouldClose w True
keyCallback w key scancode action mods = return ()

----- マウスのボタン
type PushEmpty = () -> Reactive ()
mouseButtonCallback :: PushEmpty -> PushEmpty -> GLFW.MouseButtonCallback
mouseButtonCallback pushLP pushLR _ GLFW.MouseButton'1 state _ = do
  let push = case state of
        GLFW.MouseButtonState'Pressed  -> pushLP
        GLFW.MouseButtonState'Released -> pushLR
  sync $ push ()

mouseButtonCallback _ _ w button state mods = return()

----- マウスカーソルの位置
cursorPosCallback :: (Pos -> Reactive ()) -> GLFW.CursorPosCallback
cursorPosCallback push _ x y =
  sync $ push $ Pos (truncate x) (truncate y)

main :: IO ()
main = do
  GLFW.init
  mw <- GLFW.createWindow 300 300 "gui test" Nothing Nothing
  ---
  (evLP, pushLP) <- sync newEvent
  (evLR, pushLR) <- sync newEvent
  (behCursorPos, pushCursorPos) <- sync $ newBehavior $ Pos 0 0
  let evLP' = snd <$> snapshot (,) evLP behCursorPos -- with Pos
      evLR' = snd <$> snapshot (,) evLR behCursorPos -- with Pos
  ---
  (behRect, pushRect) <- sync $ newBehavior (Rectangle 100 100 200 130)
  let evPBtn = filterE within' $ snapshot (,) evLP' behRect
      evRBtn = filterE within' $ snapshot (,) evLR' behRect
  behWR <- sync $ hold False ((const True <$> evPBtn) `merge` (const False <$> evLR)) -- WR (Waiting for release)
  let evClick = filterE snd $ snapshot (,) evRBtn behWR

  sync $ listen evClick (\a -> putStrLn ("@ clicked! " ++ show a))

  -- ボタンの描画関数
  let drawButton rect = do
        GL.color $ col3i 255 255 255
        GL.renderPrimitive GL.Quads $ vertRect rect -- 塗りつぶし
        GL.color $ col3i 137 140 149
        GL.renderPrimitive GL.LineLoop $ vertRect rect -- ボタンの枠

  (evDraw, pushDraw) <- sync $ newEvent -- GLFWのシステムの描画タイミングで発火させるイベント

  -- リスナーにボタンの描画関数を仕掛ける
  sync $ listen (snd <$> snapshot (,) evDraw behRect) $ drawButton

  -- ボタンをランダムに移動させる
  let moveButton g = do
        -- putChar '*' >> hFlush stdout
        let (dx, g')  = randomR (-3, 3) g
            (dy, g'') = randomR (-3, 3) g'
        sync $ do
          (Rectangle x1 y1 x2 y2) <- sample behRect
          pushRect $ Rectangle (x1+dx) (y1+dy) (x2+dx) (y2+dy)
        threadDelay 10000
        moveButton g''

  g <- newStdGen
  forkIO $ moveButton g
  --

  --
  maybe' mw (GLFW.terminate >> exitFailure) $ \w -> do
    GLFW.makeContextCurrent mw
    GLFW.setKeyCallback w (Just keyCallback)
    GLFW.setMouseButtonCallback w (Just $ mouseButtonCallback pushLP pushLR)
    GLFW.setCursorPosCallback w (Just $ cursorPosCallback pushCursorPos)
    mainLoop w pushDraw
    GLFW.destroyWindow w
    GLFW.terminate
    exitSuccess
  --
  return ()
 where
  within' = uncurry within
  
  
----------

data Pos = Pos Int Int deriving Show
data Rectangle = Rectangle Int Int Int Int deriving Show

within :: Pos -> Rectangle -> Bool
within (Pos x y) (Rectangle x1 y1 x2 y2) =
  x >= x1 && x <= x2 && y >= y1 && y <= y2

vertRect :: Rectangle -> IO ()
vertRect (Rectangle x1 y1 x2 y2) = do
  GL.vertex $ GL.Vertex3 x1' y1' (0::GL.GLfloat)
  GL.vertex $ GL.Vertex3 x2' y1' (0::GL.GLfloat)
  GL.vertex $ GL.Vertex3 x2' y2' (0::GL.GLfloat)
  GL.vertex $ GL.Vertex3 x1' y2' (0::GL.GLfloat)
 where
  x1' = fromIntegral x1
  y1' = fromIntegral y1
  x2' = fromIntegral x2
  y2' = fromIntegral y2
  
col3i :: Int -> Int -> Int -> GL.Color3 GL.GLfloat
col3i r g b = GL.Color3 r' g' b'
  where
    r' = fromIntegral r / 250
    g' = fromIntegral g / 250
    b' = fromIntegral b / 250

疑問点など

下のリスナーは、
pollEventsの開始から動作しなくような感じ。

sync $ listen (value behRect) $ print -- 動作しない!!!

しかし、valueではなく、updatesを使えば動作する。

sync $ listen (updates behRect) $ print -- 動作する

まだ追求はできていません。

処理の隠蔽

最後に、処理を関数に隠します。
依存関係が分かりやすくなりました。

initGUI = do
  GLFW.init
  mw <- GLFW.createWindow 300 300 "gui test" Nothing Nothing
  -----
  (evLP', pushLP) <- sync newEvent
  (evLR', pushLR) <- sync newEvent
  (behCursorPos, pushCursorPos) <- sync $ newBehavior $ Pos 0 0
  (evDraw, pushDraw) <- sync $ newEvent -- GLFWのシステムの描画タイミングで発火させるイベント

  forkIO $ maybe' mw (GLFW.terminate >> exitFailure) $ \w -> do
    GLFW.makeContextCurrent mw
    GLFW.setKeyCallback w (Just keyCallback)
    GLFW.setMouseButtonCallback w (Just $ mouseButtonCallback pushLP pushLR)
    GLFW.setCursorPosCallback w (Just $ cursorPosCallback pushCursorPos)
    mainLoop w pushDraw
    GLFW.destroyWindow w
    GLFW.terminate
    exitSuccess

  let evLP = snd <$> snapshot (,) evLP' behCursorPos -- with Pos
      evLR = snd <$> snapshot (,) evLR' behCursorPos -- with Pos
  return (evDraw, evLP, evLR)

newButton (evDraw, evLP, evLR) = do
  (behRect, pushRect) <- sync $ newBehavior (Rectangle 100 100 200 130)
  let evPBtn = filterE within' $ snapshot (,) evLP behRect
      evRBtn = filterE within' $ snapshot (,) evLR behRect
  behWR <- sync $ hold False ((const True <$> evPBtn) `merge` (const False <$> evLR)) -- WR (Waiting for release)
  let evClick = filterE snd $ snapshot (,) evRBtn behWR
  -- ボタンの描画関数
  let drawButton rect = do
        GL.color $ col3i 255 255 255
        GL.renderPrimitive GL.Quads $ vertRect rect -- 塗りつぶし
        GL.color $ col3i 137 140 149
        GL.renderPrimitive GL.LineLoop $ vertRect rect -- ボタンの枠

  -- リスナーにボタンの描画関数を仕掛ける
  sync $ listen (snd <$> snapshot (,) evDraw behRect) $ drawButton
  --
  return evClick
 where
  within' = uncurry within

main :: IO ()
main = do
  gui <- initGUI
  evClickBtn <- newButton gui
  sync $ listen evClickBtn (\a -> putStrLn ("@ clicked! " ++ show a))
  --
  forever $ threadDelay 100000