HaskellのOpenGLチュートリアル http://www.haskell.org/haskellwiki/OpenGLTutorial2

Bindings.hs

module Bindings (idle
                , display
                , reshape
                , keyboardMouse) where

import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.UI.GLUT as GLUT
import Data.IORef
import Display

reshape :: GL.Size -> IO ()
reshape s@(GL.Size w h) = do
  GL.viewport GL.$= (GL.Position 0 0, s)

keyboardAct a _ (GLUT.Char ' ') GLUT.Down = do
  a' <- readIORef a
  a GL.$= -a'
keyboardAct a _ (GLUT.Char '+') GLUT.Down = do
  a' <- readIORef a
  a GL.$= 2*a'
keyboardAct a _ (GLUT.Char '-') GLUT.Down = do
  a' <- readIORef a
  a GL.$= a'/2
keyboardAct _ p (GLUT.SpecialKey GLUT.KeyLeft) GLUT.Down = do
  (x,y) <- readIORef p
  p GLUT.$= (x-0.1, y)
keyboardAct _ p (GLUT.SpecialKey GLUT.KeyRight) GLUT.Down = do
  (x,y) <- readIORef p
  p GLUT.$= (x+0.1, y)
keyboardAct _ p (GLUT.SpecialKey GLUT.KeyUp) GLUT.Down = do
  (x,y) <- readIORef p
  p GLUT.$= (x, y+0.1)
keyboardAct _ p (GLUT.SpecialKey GLUT.KeyDown) GLUT.Down = do
  (x,y) <- readIORef p
  p GL.$= (x, y-0.1)
keyboardAct _ _ _ _ = return ()

-- keyboardMouse :: a0 -> a1 -> a2 -> a3 -> IO ()
keyboardMouse angle pos key state modifiers position = do
  keyboardAct angle pos key state

Cube.hs

module Cube (cube, cubeFrame) where

import qualified Graphics.Rendering.OpenGL as GL

vertify3 :: [(GL.GLfloat, GL.GLfloat, GL.GLfloat)] -> IO ()
vertify3 verts = sequence_ $ map (\(a,b,c) -> GL.vertex $ GL.Vertex3 a b c) verts 

cubeFrame :: GL.GLfloat -> IO ()
cubeFrame w = GL.renderPrimitive GL.Lines $ vertify3
  [ ( w,-w, w), ( w, w, w),  ( w, w, w), (-w, w, w),
    (-w, w, w), (-w,-w, w),  (-w,-w, w), ( w,-w, w),
    ( w,-w, w), ( w,-w,-w),  ( w, w, w), ( w, w,-w),
    (-w, w, w), (-w, w,-w),  (-w,-w, w), (-w,-w,-w),
    ( w,-w,-w), ( w, w,-w),  ( w, w,-w), (-w, w,-w),
    (-w, w,-w), (-w,-w,-w),  (-w,-w,-w), ( w,-w,-w) ]

cube :: GL.GLfloat -> IO ()
cube w = GL.renderPrimitive GL.Quads $ vertify3
      [ ( w, w, w), ( w, w,-w), ( w,-w,-w), ( w,-w, w),
        ( w, w, w), ( w, w,-w), (-w, w,-w), (-w, w, w),
        ( w, w, w), ( w,-w, w), (-w,-w, w), (-w, w, w),
        (-w, w, w), (-w, w,-w), (-w,-w,-w), (-w,-w, w),
        ( w,-w, w), ( w,-w,-w), (-w,-w,-w), (-w,-w, w),
        ( w, w,-w), ( w,-w,-w), (-w,-w,-w), (-w, w,-w) ]

{--
cube w = do
  GL.renderPrimitive GL.Quads $ do
    GL.vertex $ GL.Vertex3 w w w
    GL.vertex $ GL.Vertex3 w w (-w)
    GL.vertex $ GL.Vertex3 w (-w) (-w)
    GL.vertex $ GL.Vertex3 w (-w) w
    GL.vertex $ GL.Vertex3 w w w
    GL.vertex $ GL.Vertex3 w w (-w)
    GL.vertex $ GL.Vertex3 (-w) w (-w)
    GL.vertex $ GL.Vertex3 (-w) w w
    GL.vertex $ GL.Vertex3 w w w
    GL.vertex $ GL.Vertex3 w (-w) w
    GL.vertex $ GL.Vertex3 (-w) (-w) w
    GL.vertex $ GL.Vertex3 (-w) w w
    GL.vertex $ GL.Vertex3 (-w) w w
    GL.vertex $ GL.Vertex3 (-w) w (-w)
    GL.vertex $ GL.Vertex3 (-w) (-w) (-w)
    GL.vertex $ GL.Vertex3 (-w) (-w) w
    GL.vertex $ GL.Vertex3 w (-w) w
    GL.vertex $ GL.Vertex3 w (-w) (-w)
    GL.vertex $ GL.Vertex3 (-w) (-w) (-w)
    GL.vertex $ GL.Vertex3 (-w) (-w) w
    GL.vertex $ GL.Vertex3 w w (-w)
    GL.vertex $ GL.Vertex3 w (-w) (-w)
    GL.vertex $ GL.Vertex3 (-w) (-w) (-w)
    GL.vertex $ GL.Vertex3 (-w) w (-w)
--}

Display.hs

module Display (display, idle) where

import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.UI.GLUT as GLUT

import Data.IORef

import Cube

{--
display :: IO ()
display = do
  GL.clear [GL.ColorBuffer]
  cube (0.2 :: GL.GLfloat)
  GL.flush

points :: [(GL.GLfloat, GL.GLfloat, GL.GLfloat)]
points = map (\k -> (sin(2*pi*k/12),cos(2*pi*k/12),0.0))  [1..12]

 
display = do 
  GL.clear [GL.ColorBuffer]
  GL.scale 0.7 0.7 (0.7::GL.GLfloat)
  mapM_ (\(x,y,z) -> GL.preservingMatrix $ do
    GL.color $ GL.Color3 ((x+1.0)/2.0) ((y+1.0)/2.0) ((z+1.0)/2.0)
    GL.translate $ GL.Vector3 x y z
    cube (0.1::GL.GLfloat)
    ) $ points 10
  GL.flush

--}

points :: Int -> [(GL.GLfloat, GL.GLfloat, GL.GLfloat)]
points n' = let n = fromIntegral n' in
            map (\x -> let t = 2 * pi * x/n in (sin(t), cos(t), 0.0)) [1..n]

display angle position = do
  GL.clear [GL.ColorBuffer, GL.DepthBuffer]
  GLUT.loadIdentity
  (x, y) <- readIORef position
  GL.translate $ GL.Vector3 x y 0
  GL.preservingMatrix $ do
    a <- readIORef angle
    GL.rotate a $ GL.Vector3 0 0.1 (1::GL.GLfloat)
    GL.scale 0.7 0.7 (0.7 :: GL.GLfloat)
    mapM_ (\(x,y,z) -> GL.preservingMatrix $ do
                         GL.color $ GL.Color3 ((x+1.0)/2.0) ((y+1.0)/2.0) ((z+1.0)/2.0)
                         GL.translate $ GL.Vector3 x y z
                         cube (0.1 :: GL.GLfloat)
                         GL.color $ GL.Color3 (0.0::GL.GLfloat) 0.0 0.0 --set outline color to black
                         -- GL.color $ GL.Color3 (1::GL.GLfloat) 1 1 --set outline color to black
                         cubeFrame (0.1::GL.GLfloat)
          ) $ points 7
  -- GL.flush
  GLUT.swapBuffers
 
idle angle delta = do
  a <- readIORef angle
  d <- readIORef delta
  angle GL.$=! (a + d) -- The parens are necessary due to a precedence bug in StateVar
  GLUT.postRedisplay Nothing -- Only required on Mac OS X, which double-buffers internally

HelloWorld.hs

import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.UI.GLUT as GLUT
import Data.IORef

import Bindings

main = do
  (progname, _) <- GLUT.getArgsAndInitialize
  GLUT.initialDisplayMode GL.$= [GLUT.WithDepthBuffer, GLUT.DoubleBuffered]
  GLUT.createWindow "hello, world!"
  GLUT.reshapeCallback GL.$= Just reshape
  GLUT.depthFunc GL.$= Just GL.Less
  angle <- newIORef (0.0)
  delta <- newIORef (0.1)
  pos   <- newIORef (0.0 :: GL.GLfloat,  0.0)
  GLUT.keyboardMouseCallback GL.$= Just (keyboardMouse angle pos)
  GLUT.idleCallback GL.$= Just (idle angle delta)
  GLUT.displayCallback GL.$= (display angle pos)
  GLUT.mainLoop