HaskellでOpenGL(GLUT)を使って、地面を描画する。

ground.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
    preservingMatrix $ do
        renderPrimitive Quads $ 
            mapM_ drawGround [(x,y)| x<- [-5..5], y <- [-5..5]]
    preservingMatrix $ do
        color (Color3 1 0 0 :: Color3 GLdouble)
        renderObject Solid $ Sphere' 1 20 20
    preservingMatrix $ do
        color (Color3 0 1 0 :: Color3 GLdouble)
        translate (Vector3 (-2) 0 0 :: Vector3 GLdouble)
        renderObject Solid $ Sphere' 1 20 20
    preservingMatrix $ do
        color (Color3 0 0 1 :: Color3 GLdouble)
        translate (Vector3 2 0 0 :: Vector3 GLdouble)
        renderObject Solid $ Sphere' 1 20 20
    swapBuffers

drawGround :: (Int, Int) -> IO ()
drawGround (i, j) = do
    color (groundColor !! n)
    vertex3d $ Vertex3 i' 0 j'
    vertex3d $ Vertex3 i' 0 (j'+1)
    vertex3d $ Vertex3 (i'+1) 0 (j'+1)
    vertex3d $ Vertex3 (i'+1) 0 j'
        where 
            n = (i+j) `mod` 2
            i' = realToFrac i
            j' = realToFrac j
            vertex3d = vertex :: Vertex3 GLdouble -> IO ()

groundColor :: [Color3 GLdouble]
groundColor = [ Color3 1 1 0
              , Color3 0 1 1
              ]

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 1 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