Как нарисовать треугольник с OpenGL и Haskell

Question

Я читаю учебник от http://www.arcsynthesis.org/gltut. Я пишу тестовую программу haskell. Я хочу видеть треугольник с интерполирующими цветами в центре окна, но на окне один цвет.

module Shaders where 

import Graphics.UI.GLUT 
import Foreign.Marshal.Array 
import Foreign.Ptr 
import Foreign.Storable() 
import Foreign.C.Types() 
import qualified Data.ByteString as BS 
import System.IO 
import Control.Monad 

data State = State 
    { 
     vertexBuffer :: BufferObject, 
     gpuProgram :: Program 
    } 

triangleVertexes :: [GLfloat] 
triangleVertexes = [ 
    0.0, 0.5, 0.0, 1.0, 
    0.5, -0.366, 0.0, 1.0, 
    -0.5, -0.366, 0.0, 1.0, 
    1.0, 0.0, 0.0, 1.0, 
    0.0, 1.0, 0.0, 1.0, 
    0.0, 0.0, 1.0, 1.0 
    ] 

main :: IO() 
main = do 
    (progName, args) <- getArgsAndInitialize 
    initialDisplayMode $= [ DoubleBuffered, RGBAMode, WithAlphaComponent, WithDepthBuffer ] 
    _ <- createWindow progName 
    state <- initializeState 
    displayCallback $= display state 
    reshapeCallback $= Just (reshape state) 
    mainLoop 

fragmentShaderFilePath :: FilePath 
fragmentShaderFilePath = "shader.frag" 

vertexShaderFilePath :: FilePath 
vertexShaderFilePath = "shader.vert" 

createVertexBuffer :: [GLfloat] -> IO BufferObject 
createVertexBuffer vertexes = do 
    bufferObject <- genObjectName 
    bindBuffer ArrayBuffer $= Just bufferObject 
    withArrayLen vertexes $ \count arr -> 
     bufferData ArrayBuffer $= (fromIntegral count, arr, StaticDraw) 
    vertexAttribArray (AttribLocation 0) $= Enabled 
    vertexAttribArray (AttribLocation 1) $= Enabled 
    vertexAttribPointer (AttribLocation 0) $= (ToFloat, VertexArrayDescriptor vertexNumComponents Float 0 nullPtr) 
    vertexAttribPointer (AttribLocation 1) $= (ToFloat, VertexArrayDescriptor colorNumComponents Float 0 (plusPtr nullPtr 48)) 
    return bufferObject 

vertexNumComponents :: NumComponents 
vertexNumComponents = 4 

colorNumComponents :: NumComponents 
colorNumComponents = 4 

initializeState :: IO State 
initializeState = do 
    bufferObject <- createVertexBuffer triangleVertexes 
    program <- initGPUProgram 
    return $ State 
     { 
      vertexBuffer = bufferObject, 
      gpuProgram = program 
     } 

loadShader :: ShaderType -> FilePath -> IO Shader 
loadShader t path = do 
    shader <- createShader t 
    source <- BS.readFile path 
    shaderSourceBS shader $= source 
    compileShader shader 
    status <- get (compileStatus shader) 
    unless status $ hPutStrLn stdout . (("message" ++ " log: ") ++) =<< get (shaderInfoLog shader) 
    return shader 

initGPUProgram :: IO Program 
initGPUProgram = do 
    vertexShader <- loadShader VertexShader vertexShaderFilePath 
    fragmentShader <- loadShader FragmentShader fragmentShaderFilePath 
    let shaders = [vertexShader, fragmentShader] 
    program <- createProgram 
    attachShader program vertexShader 
    attachShader program fragmentShader 
    linkProgram program 
    mapM_ (detachShader program) shaders 
    return program 

display :: State -> DisplayCallback 
display state = do 
    clearColor $= Color4 1.0 0.0 1.0 1.0 
    clear [ ColorBuffer ] 
    bindBuffer ArrayBuffer $= Just (vertexBuffer state) 
    vertexAttribArray (AttribLocation 0) $= Enabled 
    vertexAttribArray (AttribLocation 1) $= Enabled 
    vertexAttribPointer (AttribLocation 0) $= (ToFloat, VertexArrayDescriptor vertexNumComponents Float 0 nullPtr) 
    vertexAttribPointer (AttribLocation 1) $= (ToFloat, VertexArrayDescriptor colorNumComponents Float 0 (plusPtr nullPtr 48)) 
    drawArrays Triangles 0 3 
    vertexAttribArray (AttribLocation 0) $= Disabled 
    vertexAttribArray (AttribLocation 1) $= Disabled 
    swapBuffers 
    checkError "display" 

reshape :: State -> ReshapeCallback 
reshape state size = do 
    viewport $= (Position 0 0, size) 

checkError :: String -> IO() 
checkError functionName = get errors >>= mapM_ reportError 
    where reportError e = 
      hPutStrLn stdout (showError e ++ " detected in " ++ functionName) 
     showError (Error category message) = 
      "GL error " ++ show category ++ " (" ++ message ++ ")" 

-- shader.frag 
#version 330 

smooth in vec4 theColor; 

out vec4 outputColor; 

void main() 
{ 
    outputColor = theColor; 
} 

-- shader.vert 
#version 330 

layout (location = 0) in vec4 position; 
layout (location = 1) in vec4 color; 

smooth out vec4 theColor; 

void main() 
{ 
    gl_Position = position + vec4(0.5, 0.5, 0.0, 1.0); 
    theColor = color; 
} 

1) В учебнике автор использует функцию glUseProgram. В привязке Haskell к OpenGL эта функция отсутствует. Какой аналог glUseProgram?

2) Что я делаю неправильно?

Answer 1

Проблема решена с помощью glUseProgram. Аналогом Haskell является currentProgram. Другой код ошибки:

withArrayLen vertexes $ \count arr -> 
    bufferData ArrayBuffer $= (fromIntegral count, arr, StaticDraw) 

Должно быть

withArrayLen vertexes $ \count arr -> 
    bufferData ArrayBuffer $= (fromIntegral count * 4, arr, StaticDraw) 

Это работает!

Answer 2

Этот учебник по haskell.org работал лучше для меня: https://www.haskell.org/haskellwiki/OpenGLTutorial1

Это на вики Haskell.org, поэтому он обновляется с любыми изменениями API для библиотек.