OpenGL from Haskell (#3: Matrices)

2014-03-19
,

The following is my translation/adaptation of tutorial #2 at http://www.opengl-tutorial.org. My last post was a translation of tutorial #2, which dealt with triangles — this is the reason why this post’s title is called “#3: Matrices”. The end result of this tutorial is a 3D triangle with 3 different colored vertices that are interpolated smoothly by OpenGL.

My version again uses the code from https://github.com/YPares/Haskell-OpenGL3.1-Tutos. The Data.Vec import is for the Vec package. Like my last post, my code here does does not use Control.Applicative puts everything, including the GLSL shaders directly into the code. The RankNTypes and TypeOperators GHC extensions are only there to suppress warnings from using ghc --make -Wall; if you don’t want to use these extensions, just remove the type signature for the vec3 function near the bottom.

I have also removed the use of backticks for Haskell’s infix notation (`...`). It’s not because I like using parentheses — I just don’t like using infix notation because it runs against the argument handling order of normal functions found everywhere else.

Also, I have fixed YPares’s original lookAt function which is actually broken as of commit 7a027b927d061fbd26138cb7357c40c4cacbc927; you will need my version if you wish to pursue the later tutorials that actually test the validity of this function, such as the keyboard/mouse input tutorial #6 from http://www.opengl-tutorial.org.

The code here is released into the Public Domain.

{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
module Main where

import Control.Monad
import Data.Maybe
import Data.Vec
import Foreign
import Foreign.C.String
import Foreign.C.Types
import qualified "GLFW-b" Graphics.UI.GLFW as GLFW
import Graphics.Rendering.OpenGL.Raw
import System.Exit

data GLIDs = GLIDs
  { progId :: !GLuint
  , vertexArrayId :: !GLuint
  , vertexAttrib :: !GLuint
  , vertexBufferId :: !GLuint
  , colorAttrib :: !GLuint
  , colorBufferId :: !GLuint
  , mvpMatrixUniform :: !GLint
  }

withNewPtr :: Storable b => (Ptr b -> IO a) -> IO b
withNewPtr f = alloca (\p -> f p >> peek p)

initialize :: IO GLFW.Window
initialize = do
  ok <- GLFW.init
  when (not ok) $ do
    _ <- fail "Failed to initialize GLFW"
    exitFailure
  mapM_ GLFW.windowHint
    [ GLFW.WindowHint'Samples 4 -- 4x antialiasing
    , GLFW.WindowHint'ContextVersionMajor 3 -- OpenGL 3.3
    , GLFW.WindowHint'ContextVersionMinor 3
    , GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core
    ]

  win <- GLFW.createWindow 800 600 "Window Title" Nothing Nothing
  when (isNothing win) $ do
    _ <- fail "Failed to create OpenGL window"
    GLFW.terminate
    exitFailure
  let
    win' = fromJust win
  GLFW.makeContextCurrent win
  GLFW.setStickyKeysInputMode win' GLFW.StickyKeysInputMode'Enabled
  return win'

initializeGL :: IO GLIDs
initializeGL = do
  glClearColor 0 0 0.4 0
  progId <- loadProgram
    ("vertexShader2", vertexShader2)
    ("fragmentShader2", fragmentShader2)
  v <- withCString "vertexPosition_modelspace"
    $ glGetAttribLocation progId
  c <- withCString "vertexColor" $ glGetAttribLocation progId
  m <- withCString "MVP" $ glGetUniformLocation progId
  vertexAttrib <- findAttribUniform v "vertexPosition_modelspace"
  colorAttrib <- findAttribUniform c "vertexColor"
  mvpMatrixUniform <- findAttribUniform m "MVP"
  vertexArrayId <- newVAO
  vertexBufferId <- fillNewBuffer vertexBufferData
  colorBufferId <- fillNewBuffer colorBufferData
  return GLIDs{..}
  where
  vertexBufferData :: [GLfloat]
  vertexBufferData =
    -- x, y, z
    [ -1, -1, 0
    ,  1, -1, 0
    ,  0,  1, 0
    ]
  colorBufferData :: [GLfloat]
  colorBufferData =
    [ 1, 0, 0
    , 0, 1, 0
    , 0, 0, 1
    ]
  findAttribUniform x name = if x < 0
    then error $ "`" ++ name ++ "' cannot be found!"
    else return $ fromIntegral x

freeResources :: GLIDs -> IO ()
freeResources GLIDs{..} = do
  with vertexBufferId $ glDeleteBuffers 1
  with colorBufferId $ glDeleteBuffers 1
  with vertexArrayId $ glDeleteVertexArrays 1

newVAO :: IO GLuint
newVAO = do
  vaId <- withNewPtr (glGenVertexArrays 1)
  glBindVertexArray vaId
  return vaId

fillNewBuffer :: [GLfloat] -> IO GLuint
fillNewBuffer xs = do
  bufId <- withNewPtr (glGenBuffers 1)
  glBindBuffer gl_ARRAY_BUFFER bufId
  withArrayLen xs func -- give given vertices to OpenGL
  return bufId
  where
  func len ptr = glBufferData
    gl_ARRAY_BUFFER
    (fromIntegral (len * sizeOf (undefined :: GLfloat)))
    (ptr :: Ptr GLfloat)
    gl_STATIC_DRAW

bindBufferToAttrib :: GLuint -> GLuint -> IO ()
bindBufferToAttrib bufId attribLoc = do
  glEnableVertexAttribArray attribLoc
  glBindBuffer gl_ARRAY_BUFFER bufId
  glVertexAttribPointer
    attribLoc -- attribute location in the shader
    3 -- 3 components per vertex
    gl_FLOAT -- coord type
    (fromBool False) -- normalize?
    0 -- stride
    nullPtr -- vertex buffer offset

loadProgram :: (String, String) -> (String, String) -> IO GLuint
loadProgram vertShader fragShader = do
  shaderIds <- mapM (uncurry loadShader)
    [ (gl_VERTEX_SHADER, vertShader)
    , (gl_FRAGMENT_SHADER, fragShader)
    ]
  progId <- glCreateProgram
  putStrLn "Linking program"
  mapM_ (glAttachShader progId) shaderIds
  glLinkProgram progId
  _ <- checkStatus
    gl_LINK_STATUS glGetProgramiv glGetProgramInfoLog progId
  mapM_ glDeleteShader shaderIds
  return progId

loadShader :: GLenum -> (String, String) -> IO GLuint
loadShader shaderTypeFlag (name, code) = do
  shaderId <- glCreateShader shaderTypeFlag
  withCString code $ \codePtr ->
    with codePtr $ \codePtrPtr ->
      glShaderSource shaderId 1 codePtrPtr nullPtr
  putStrLn $ "Compiling shader `" ++ name ++ "'"
  glCompileShader shaderId
  _ <- checkStatus
    gl_COMPILE_STATUS glGetShaderiv glGetShaderInfoLog shaderId
  return shaderId

checkStatus :: (Integral a1, Storable a1)
  => GLenum
  -> (t -> GLenum -> Ptr a1 -> IO a)
  -> (t -> a1 -> Ptr a3 -> Ptr Foreign.C.Types.CChar -> IO a2)
  -> t
  -> IO Bool
checkStatus statusFlag glGetFn glInfoLogFn componentId = do
  let
    fetch info = withNewPtr (glGetFn componentId info)
  status <- liftM toBool $ fetch statusFlag
  logLength <- fetch gl_INFO_LOG_LENGTH
  when (logLength > 0) $
    allocaArray0 (fromIntegral logLength) $ \msgPtr -> do
      _ <- glInfoLogFn componentId logLength nullPtr msgPtr
      msg <- peekCString msgPtr
      (if status then putStrLn else fail) msg
  return status

fragmentShader2 :: String
fragmentShader2 = unlines
  [ "#version 330 core"
  , "in vec3 fragmentColor;"
  , "out vec3 finalColor;"
  , "void main()"
  , "{"
    , "finalColor= fragmentColor;"
  , "}"
  ]

vertexShader2 :: String
vertexShader2 = unlines
  [ "#version 330 core"
  -- Input vertex data, different for all executions of this shader.
  , "in vec3 vertexPosition_modelspace;"
  , "in vec3 vertexColor;"
  -- Values that stay constant for the whole mesh
  , "uniform mat4 MVP;"
  , "out vec3 fragmentColor;"
  , "void main()"
  , "{"
    , "fragmentColor = vertexColor;"
    , "vec4 v = vec4(vertexPosition_modelspace, 1);"
    , "gl_Position = MVP * v;"
  , "}"
  ]

main :: IO ()
main = do
  win <- initialize
  glids <- initializeGL
  inputLoop win glids
  freeResources glids
  GLFW.terminate
  return ()

inputLoop :: GLFW.Window -> GLIDs -> IO ()
inputLoop win glids = do
  drawStuff glids
  GLFW.swapBuffers win
  GLFW.pollEvents
  keyState <- GLFW.getKey win GLFW.Key'Escape
  closeWindow <- GLFW.windowShouldClose win
  when (keyState /= GLFW.KeyState'Pressed && closeWindow == False) $
    inputLoop win glids

drawStuff :: GLIDs -> IO ()
drawStuff GLIDs{..} = do
  glClear gl_COLOR_BUFFER_BIT
  glClear gl_DEPTH_BUFFER_BIT
  glUseProgram progId
  -- the (fromBool True) is because we are ROW-first (Data.Vec)
  with mvpMatrix
    $ glUniformMatrix4fv mvpMatrixUniform 1 (fromBool True)
    . castPtr
  bindBufferToAttrib vertexBufferId vertexAttrib
  bindBufferToAttrib colorBufferId colorAttrib
  glDrawArrays gl_TRIANGLES 0 3
  glDisableVertexAttribArray colorAttrib
  glDisableVertexAttribArray vertexAttrib

-- Some higher-order math helper functions. Depending on what math
-- library you use, you'd use the functions that comes with that
-- library. The functions here are from the Data.Vec package.
vec3 :: forall a a1 a2. a -> a1 -> a2 -> a :. (a1 :. (a2 :. ()))
vec3 x y z = x :. y :. z:. ()

mvpMatrix :: Mat44 GLfloat
mvpMatrix = multmm (multmm projection view) model
  where
  projection = perspective 0.1 100 (pi/4) (4/3)
  view = lookAt (vec3 4 3 3) (vec3 0 0 0) (vec3 0 1 0)
  model = identity

-- The closest relative to this function is Data.Vec's `rotationLookAt`. We just
-- mirror the code found in the GLM library (glm.g-truc.net). An additional
-- resource is Jeremiah van Oosten's "Understanding the View Matrix", found at
-- http://3dgep.com/?p=1700.
lookAt :: Floating a => Vec3 a -> Vec3 a -> Vec3 a -> Mat44 a
lookAt eye target up = x :. y :. z :. h :. ()
  where
  forward = normalize $ target - eye
  right = normalize $ cross forward up
  up' = cross right forward
  x = snoc right (-(dot right eye))
  y = snoc up' (-(dot up' eye))
  z = snoc (-forward) (dot forward eye)
  h = 0 :. 0 :. 0 :. 1 :. ()