OpenGL from Haskell (#3: Matrices)

2014-03-19*
haskell, opengl

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.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
{-# 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 :. ()