john7rv

前回は平面の三角形だったので今回は立体を描画してみます
立方体の関数っは以下のようになります

drawCubeWithColor len = do

   let color3f = color :: Color3 GLfloat -> IO ()
       vertex3f = vertex :: Vertex3 GLfloat -> IO ()

   renderPrimitive Quads $ do
      color3f  (Color3    0    1    0  )
      vertex3f (Vertex3   len    len  (-len) )
      vertex3f (Vertex3 (-len)   len  (-len) )
      vertex3f (Vertex3 (-len)   len    len  )
      vertex3f (Vertex3   len    len    len  ) 
      
      color3f  (Color3    1  0.5    0  ) 
      vertex3f (Vertex3   len  (-len)   len  ) 
      vertex3f (Vertex3 (-len) (-len)   len  ) 
      vertex3f (Vertex3 (-len) (-len) (-len) ) 
      vertex3f (Vertex3   len  (-len) (-len) ) 
  
      color3f  (Color3    1    0    0  ) 
      vertex3f (Vertex3   len    len    len  ) 
      vertex3f (Vertex3 (-len)   len    len  ) 
      vertex3f (Vertex3 (-len) (-len)   len  ) 
      vertex3f (Vertex3   len  (-len)   len  ) 
  
      color3f  (Color3    1    1    0  ) 
      vertex3f (Vertex3   len  (-len) (-len) ) 
      vertex3f (Vertex3 (-len) (-len) (-len) ) 
      vertex3f (Vertex3 (-len)   len  (-len) ) 
      vertex3f (Vertex3   len    len  (-len) ) 
  
      color3f  (Color3    0    0    1  ) 
      vertex3f (Vertex3 (-len)   len    len  ) 
      vertex3f (Vertex3 (-len)   len  (-len) ) 
      vertex3f (Vertex3 (-len) (-len) (-len) ) 
      vertex3f (Vertex3 (-len) (-len)   len  ) 
  
      color3f  (Color3    1    0    1  ) 
      vertex3f (Vertex3   len    len  (-len) ) 
      vertex3f (Vertex3   len    len    len  ) 
      vertex3f (Vertex3   len  (-len)   len  ) 
      vertex3f (Vertex3   len  (-len) (-len) )  

ただ立体を描くには
どちらの面が前面になるか奥行きも設定しなければなりません
3Dプログラミングでは隠面消去といいます

myInit :: IO ()
myInit = do
   clearColor $= Color4 0 0 0 0
   shadeModel $= Flat
   depthFunc $= Just Less

隠面消去は
depthFunc $= Just Less
で設定します


ソースファイル全文

import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL.GLU
import System.Exit ( exitWith, ExitCode(ExitSuccess) )

myInit :: IO ()
myInit = do
   clearColor $= Color4 0 0 0 0
   shadeModel $= Flat
   depthFunc $= Just Less

main :: IO ()
main = do
    (progName, _args) <- getArgsAndInitialize
    initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]
    initialWindowSize $= Size 1024 768
    initialWindowPosition $= Position 100 100
    _ <- createWindow "Test2 Haskell GL"
    myInit
    displayCallback $= display
    reshapeCallback $= Just reshape
    keyboardMouseCallback $= Just keyboard
    mainLoop
    
drawCubeWithColor len = do

   let color3f = color :: Color3 GLfloat -> IO ()
       vertex3f = vertex :: Vertex3 GLfloat -> IO ()

   renderPrimitive Quads $ do
      color3f  (Color3    0    1    0  )
      vertex3f (Vertex3   len    len  (-len) )
      vertex3f (Vertex3 (-len)   len  (-len) )
      vertex3f (Vertex3 (-len)   len    len  )
      vertex3f (Vertex3   len    len    len  ) 
      
      color3f  (Color3    1  0.5    0  ) 
      vertex3f (Vertex3   len  (-len)   len  ) 
      vertex3f (Vertex3 (-len) (-len)   len  ) 
      vertex3f (Vertex3 (-len) (-len) (-len) ) 
      vertex3f (Vertex3   len  (-len) (-len) ) 
  
      color3f  (Color3    1    0    0  ) 
      vertex3f (Vertex3   len    len    len  ) 
      vertex3f (Vertex3 (-len)   len    len  ) 
      vertex3f (Vertex3 (-len) (-len)   len  ) 
      vertex3f (Vertex3   len  (-len)   len  ) 
  
      color3f  (Color3    1    1    0  ) 
      vertex3f (Vertex3   len  (-len) (-len) ) 
      vertex3f (Vertex3 (-len) (-len) (-len) ) 
      vertex3f (Vertex3 (-len)   len  (-len) ) 
      vertex3f (Vertex3   len    len  (-len) ) 
  
      color3f  (Color3    0    0    1  ) 
      vertex3f (Vertex3 (-len)   len    len  ) 
      vertex3f (Vertex3 (-len)   len  (-len) ) 
      vertex3f (Vertex3 (-len) (-len) (-len) ) 
      vertex3f (Vertex3 (-len) (-len)   len  ) 
  
      color3f  (Color3    1    0    1  ) 
      vertex3f (Vertex3   len    len  (-len) ) 
      vertex3f (Vertex3   len    len    len  ) 
      vertex3f (Vertex3   len  (-len)   len  ) 
      vertex3f (Vertex3   len  (-len) (-len) )  
    
keyboard :: KeyboardMouseCallback
keyboard (Char 'q')            _ _ _ = exitWith ExitSuccess
keyboard _                     _ _ _ = postRedisplay Nothing

reshape :: ReshapeCallback
reshape size@(Size width height) = do      
    viewport $= (Position 0 0, size)
    matrixMode $= Projection
    loadIdentity
    perspective 90 (fromIntegral width / fromIntegral height) 1 100
    matrixMode $= Modelview 0
   
display :: DisplayCallback
display = do
   loadIdentity
   lookAt (Vertex3 0 0 5) (Vertex3 0 0 0) (Vector3 0 1 0)
   clear [ ColorBuffer, DepthBuffer ]
   

   let color3f = color :: Color3 GLfloat -> IO ()
       vertex3f = vertex :: Vertex3 GLfloat -> IO ()
       r = 60.0 :: GLfloat

   preservingMatrix $ do
   rotate r (Vector3 0.0 1.0 0.0)
   drawCubeWithColor 1.0
   
   swapBuffers