ボタンの簡易な描画 (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