HaskellでOpenGL

昨日までOpenGLのおの字も知らなかったのだが、
気が向いたのでやってみることにした。
なんというか、思いのほか簡単である。
もっと初期化とかめんどくさいと思っていた。

とりあえず、初期化のコード

main = do
  True <- sdlInit [VIDEO]

  glSetAttribute GL_RED_SIZE   5
  glSetAttribute GL_GREEN_SIZE 5
  glSetAttribute GL_BLUE_SIZE  5
  glSetAttribute GL_DEPTH_SIZE 16
  glSetAttribute GL_DOUBLEBUFFER 1

  setCaption "OpenGL" ""
  sur <- setVideoMode 640 480 16 [OPENGL]

  loop
  sdlQuit

loop = do
  quit <- checkEvent
  when (not quit) $ do
    threadDelay 16666
    loop

あとは普通にOpenGLを呼び出すだけなので、
http://www.wakayama-u.ac.jp/~tokoi/opengl/libglut.html
この辺を読んで勉強してみた。
で、最後まで読んで出来上がったのがこれ。

import Graphics.UI.SDL as SDL hiding (color)
import Graphics.Rendering.OpenGL as GL
import Graphics.Rendering.OpenGL.GLU
import Control.Concurrent
import Control.Monad
import Data.IORef






















































-


























initialize = do
  clearColor $= Color4 0.0 0.0 0.0 1.0
  depthFunc  $= Just Less
  lighting  $= Enabled
  light (Light 0) $= Enabled
  light (Light 1) $= Enabled

initVar = 0.0

setupMat = do
  viewport $= (Position 0 0,GL.Size 640 480)
  matrixMode $= Projection
  loadIdentity
  perspective 30.0 (640.0/480.0) 1.0 100.0

  matrixMode $= Modelview 0
  loadIdentity
  translate $ Vector3 0.0 0.0 (-5.0 :: GLdouble)
  lookAt (Vertex3 3.0 4.0 5.0) (Vertex3 0.0 0.0 0.0) (Vector3 0.0 1.0 0.0)

setupLight = do
  position (Light 0) $= Vertex4 0.0 3.0 5.0 1.0
  position (Light 1) $= Vertex4 5.0 3.0 0.0 1.0
  diffuse  (Light 1) $= Color4  0.0 1.0 0.0 1.0
  specular (Light 1) $= Color4  0.0 1.0 0.0 1.0

cube = do
  renderPrimitive Quads $
    mapM_ (\(n,v) -> do
        normal $ uncurry3 Normal3 n
        mapM_ (\n -> vertex $ Vertex3 (vert!!n!!0) (vert!!n!!1) (vert!!n!!2)) v
      ) $ zip norm face
  where
    vert :: GLdouble
    vert =
      [[0.0,0.0,0.0]
      ,[1.0,0.0,0.0]
      ,[1.0,1.0,0.0]
      ,[0.0,1.0,0.0]
      ,[0.0,0.0,1.0]
      ,[1.0,0.0,1.0]
      ,[1.0,1.0,1.0]
      ,[0.0,1.0,1.0]]

    edge =
      [(0,1),(1,2),(2,3),(3,0)
      ,(4,5),(5,6),(6,7),(7,4)
      ,(0,4),(1,5),(2,6),(3,7)]

    face =
      [[0,1,2,3] ,[1,5,6,2] ,[5,4,7,6]
      ,[4,0,3,7] ,[4,5,1,0] ,[3,2,6,7]]

    col :: [(GLdouble,GLdouble,GLdouble)]
    col =
      [(1.0,0.0,0.0)
      ,(0.0,1.0,0.0)
      ,(0.0,0.0,1.0)
      ,(1.0,1.0,0.0)
      ,(1.0,0.0,1.0)
      ,(0.0,1.0,1.0)]

    norm :: [(GLdouble,GLdouble,GLdouble)]
    norm =
      [( 0.0, 0.0,-1.0)
      ,( 1.0, 0.0, 0.0)
      ,( 0.0, 0.0, 1.0)
      ,(-1.0, 0.0, 0.0)
      ,( 0.0,-1.0, 0.0)
      ,( 0.0, 1.0, 0.0)]

    fromInt = fromInteger . toInteger
    uncurry3 f (a,b,c) = f a b c

render var = do
  r <- readIORef var
  modifyIORef var (+1)
  clear [ColorBuffer,DepthBuffer]

  setupMat
  setupLight

  preservingMatrix $ do
    rotate r $ Vector3 0.0 1.0 (0.0 :: GLdouble)
    materialDiffuse   FrontAndBack $= Color4 0.8 0.2 0.2 1.0
    cube
  preservingMatrix $ do
    translate $ Vector3 2.0 0.0 (0.0 :: GLdouble)
    rotate (r*2) $ Vector3 0.0 1.0 (0.0 :: GLdouble)
    materialDiffuse   FrontAndBack $= Color4 0.0 0.8 0.2 1.0
    cube

  glSwapBuffers






















































-


























main = do
  True <- sdlInit [VIDEO]

  glSetAttribute GL_RED_SIZE   5
  glSetAttribute GL_GREEN_SIZE 5
  glSetAttribute GL_BLUE_SIZE  5
  glSetAttribute GL_DEPTH_SIZE 16
  glSetAttribute GL_DOUBLEBUFFER 1

  setCaption "OpenGL" ""
  sur <- setVideoMode 640 480 16 [OPENGL]

  var <- newIORef initVar
  initialize
  loop $ render var

  sdlQuit

loop f = do
  quit <- checkEvent
  when (not quit) $ do
    f
    threadDelay 16666
    loop f

checkEvent = do
  ev <- pollEvent
  case ev of
    Just QuitEvent -> return True
    Nothing        -> return False
    _              -> checkEvent

テクスチャ周りが何も書いてなかった…