HaskellでOpenGL(GLUT)を使って、キーボードやマウスからの入力を受け付ける。

keyboardmouse.hs

import Graphics.UI.GLUT
import Data.IORef

display :: IORef GLdouble -> DisplayCallback
display rot = do
    clear [ColorBuffer]
    r <- get rot
    loadIdentity
    rotate r $ Vector3 0 1 0
    color (Color3 0 0 0 :: Color3 GLdouble)
    renderPrimitive Polygon $ mapM_ vertex2d [
          Vertex2 (-0.9) (-0.9)
        , Vertex2 0.9 (-0.9)
        , Vertex2 0.9 0.9
        , Vertex2 (-0.9) 0.9
        ]
    flush
        where
            vertex2d = vertex :: Vertex2 GLdouble -> IO ()

resize :: Size -> IO ()
resize s@(Size w h) = do
    viewport $= (Position 0 0,s)
    matrixMode $= Projection
    loadIdentity
    ortho (-w') (w') (-h') (h') (-1.0) (1.0) 
    matrixMode $= Modelview 0
        where
            w' = realToFrac w / 200.0
            h' = realToFrac h / 200.0

mouse :: IORef GLdouble -> MouseCallback
mouse rot button _ _ = do
    case button of
      LeftButton -> rot $~! (+3)
      RightButton -> rot $~! (subtract 3)
      _ -> return ()

keyboard :: KeyboardCallback
keyboard c _ = do
    case c of
      'q' -> leaveMainLoop
      _ -> return ()

idle :: IdleCallback
idle = postRedisplay Nothing

main :: IO ()
main = do
    getArgsAndInitialize
    initialDisplayMode $= [RGBAMode]
    createWindow "Sample"
    clearColor $= Color4 1 1 1 1
    rot <- newIORef 0
    displayCallback $= display rot
    reshapeCallback $= Just resize
    mouseCallback $= Just (mouse rot)
    keyboardCallback $= Just keyboard
    idleCallback $= Just idle
    mainLoop