HaskellでOpenGL(再放送)

どう書く?orgに投稿したものにちょっと手を加えたものを、備忘録代わりにこちらにも投稿。

「event handlers」以下が、OpenGL/GLUTを使って時間経過とともに状況(表示)が変わるものを表示するプログラムを書くときのテンプレートになると思います。draw関数に描画のコードを、updateに状況を更新するコードを書けばOK。

import Graphics.UI.GLUT
import Control.Exception
import System.Exit
import Data.IORef

interval     = 0
windowWidth  = 320::GLsizei
windowHeight = 240::GLsizei

data Direction = North | East | South | West deriving Enum

turnRight :: Direction -> Direction
turnRight d = toEnum (((fromEnum d) + 1) `mod` 4)

turnLeft :: Direction -> Direction
turnLeft d = toEnum (((fromEnum d) + 3) `mod` 4)

data Ant = Ant Position Direction

initialEnv :: (Ant, [Position])
initialEnv = (Ant (Position (windowWidth `div` 2) (windowHeight `div` 2)) East, [])

convd :: (Integral a) => a -> GLdouble
convd = fromInteger.toInteger

forward (Position x y) North = Position x (y - 1)
forward (Position x y) East  = Position (x + 1) y
forward (Position x y) South = Position x (y + 1)
forward (Position x y) West  = Position (x - 1) y

draw env = do
  (_, ps) <- readIORef env
  clearColor $= Color4 1.0 1.0 1.0 1.0
  clear [ColorBuffer]
  color $ Color3 (0.0::Double) 0.0 0.0
  renderPrimitive Points $ mapM_ (\ (Position x y) -> vertex $ Vertex2 x y) ps
  swapBuffers

update (Ant pos dir, ps) =
  if elem pos ps
    then (Ant (forward pos right) right, filter (pos /=) ps)
    else (Ant (forward pos left)  left,  pos:ps)
  where
    right = turnRight dir
    left  = turnLeft dir

-- event handlers

display env = do
  draw env

reshape (Size w h) = do
  viewport $= (Position 0 0, Size w h)
  loadIdentity
  ortho (-0.5) ((convd w) - 0.5) ((convd h) - 0.5) (-0.5) (-1.0) (1.0)

keyboardMouse key keystate modifiers position = do
  case key of
    Char 'q' -> throwIO $ ExitException ExitSuccess
    _        -> return ()

timer env = do
  modifyIORef env $ update
  draw env
  addTimerCallback interval $ timer env

main = do
  env <- newIORef initialEnv
  getArgsAndInitialize
  initialDisplayMode    $= [RGBAMode, DoubleBuffered]
  initialWindowPosition $= Position 100 100
  initialWindowSize     $= Size windowWidth windowHeight
  createWindow "doukaku#276"
  displayCallback       $= display env
  reshapeCallback       $= Just reshape
  keyboardMouseCallback $= Just keyboardMouse
  addTimerCallback interval $ timer env
  mainLoop