HaskellでOpenGL(GLUT)を使って、立方体を描画する。(GLUTの関数編)

3d-cube2.hs

import Graphics.UI.GLUT
import Data.IORef

display :: IORef GLdouble -> IORef GLdouble -> DisplayCallback
display rot1 rot2 = do
    clear [ColorBuffer, DepthBuffer]
    r1 <- get rot1
    r2 <- get rot2
    loadIdentity
    rotate r1 $ Vector3 1 0 0
    rotate r2 $ Vector3 0 1 0
    color (Color3 0 0 0 :: Color3 GLdouble)
    renderObject Solid $ Cube 1
    swapBuffers

resize :: Size -> IO ()
resize s@(Size w h) = do
    viewport $= (Position 0 0,s)
    matrixMode $= Projection
    loadIdentity
    perspective 45.0 (w'/h') 1.0 100.0
    lookAt (Vertex3 0 0 (-5)) (Vertex3 0 0 0) (Vector3 0 1 0)
    matrixMode $= Modelview 0
        where
            w' = realToFrac w
            h' = realToFrac h

keyboard :: IORef GLdouble -> IORef GLdouble -> KeyboardCallback
keyboard rot1 rot2 c _ = do
    case c of
      'j' -> rot1 $~! (subtract 1)
      'k' -> rot1 $~! (+1)
      'h' -> rot2 $~! (subtract 1)
      'l' -> rot2 $~! (+1)
      'q' -> leaveMainLoop
      _ -> return ()

idle :: IdleCallback
idle = postRedisplay Nothing

main :: IO ()
main = do
    getArgsAndInitialize
    initialDisplayMode $= [RGBAMode, DoubleBuffered, WithDepthBuffer]
    createWindow "Sample"
    clearColor $= Color4 1 1 1 1
    depthFunc $= Just Less
    rot1 <- newIORef 0
    rot2 <- newIORef 0
    displayCallback $= display rot1 rot2
    reshapeCallback $= Just resize
    keyboardCallback $= Just (keyboard rot1 rot2)
    idleCallback $= Just idle
    mainLoop