| 4 | 4 |
|
| 5 | 5 |
/* the bind operator for the exception monad, for quick error
|
| 6 | 6 |
handling */
|
| 7 | |
let (>>=) = fun x f => switch x {
|
| 8 | |
| Ok v => f v
|
| 9 | |
| Error e => Error e
|
| 7 |
let (>>=) = (x, f) => switch x {
|
| 8 |
| Ok(v) => f(v)
|
| 9 |
| Error(e) => Error(e)
|
| 10 | 10 |
};
|
| 11 | 11 |
|
| 12 | 12 |
/* our vertex shader takes a 2d position and renders it on the screen,
|
|
| 30 | 30 |
|
| 31 | 31 |
/* we use a lot of Bigarrays, which are contiguous chunks of memory
|
| 32 | 32 |
that we can hand off to C */
|
| 33 | |
let bigarray_create k len => Bigarray.(Array1.create k c_layout len);
|
| 33 |
let bigarray_create = (k, len) => Bigarray.(Array1.create(k, c_layout, len));
|
| 34 | 34 |
|
| 35 | 35 |
/* our vertex data is [0.0, 0.5, 0.5, -0.5, -0.5, -0.5], but in a
|
| 36 | 36 |
contiguous array of memory */
|
| 37 | 37 |
let vertices = {
|
| 38 | 38 |
open Bigarray.Array1;
|
| 39 | |
let arr = bigarray_create Bigarray.float32 6;
|
| 40 | |
set arr 0 0.0;
|
| 41 | |
set arr 1 0.5;
|
| 42 | |
set arr 2 0.5;
|
| 43 | |
set arr 3 (-0.5);
|
| 44 | |
set arr 4 (-0.5);
|
| 45 | |
set arr 5 (-0.5);
|
| 39 |
let arr = bigarray_create(Bigarray.float32, 6);
|
| 40 |
set(arr, 0, 0.0);
|
| 41 |
set(arr, 1, 0.5);
|
| 42 |
set(arr, 2, 0.5);
|
| 43 |
set(arr, 3, -0.5);
|
| 44 |
set(arr, 4, -0.5);
|
| 45 |
set(arr, 5, -0.5);
|
| 46 | 46 |
arr
|
| 47 | 47 |
};
|
| 48 | 48 |
|
| 49 | 49 |
/* This takes a function which expects to fill a buffer with a single
|
| 50 | 50 |
32-bit integer; this will call that function and then conver it to an
|
| 51 | 51 |
OCaml integer */
|
| 52 | |
let buf_to_int f => {
|
| 53 | |
let a = bigarray_create Bigarray.int32 1;
|
| 54 | |
f a;
|
| 55 | |
Int32.to_int (Bigarray.Array1.get a 0)
|
| 52 |
let buf_to_int = (f) => {
|
| 53 |
let a = bigarray_create(Bigarray.int32, 1);
|
| 54 |
f(a);
|
| 55 |
Int32.to_int (Bigarray.Array1.get(a, 0))
|
| 56 | 56 |
};
|
| 57 | 57 |
|
| 58 | 58 |
/* This takes a function that expects to use a buffer containing a
|
| 59 | 59 |
single 32-bit integer as well as an integer itself; this will
|
| 60 | 60 |
convert the integer into a buffer and then call the function on
|
| 61 | 61 |
it */
|
| 62 | |
let int_as_buf f i => {
|
| 63 | |
let a = bigarray_create Bigarray.int32 1;
|
| 64 | |
Bigarray.Array1.set a 0 (Int32.of_int i);
|
| 65 | |
f a
|
| 62 |
let int_as_buf = (f, i) => {
|
| 63 |
let a = bigarray_create(Bigarray.int32, 1);
|
| 64 |
Bigarray.Array1.set(a, 0, Int32.of_int(i));
|
| 65 |
f(a)
|
| 66 | 66 |
};
|
| 67 | 67 |
|
| 68 | 68 |
/* Like buf_to_int, but for an arbitrary-sized string */
|
| 69 | |
let get_string len f => {
|
| 70 | |
let a = bigarray_create Bigarray.char len;
|
| 71 | |
f a;
|
| 72 | |
Gl.string_of_bigarray a
|
| 69 |
let get_string = (len, f) => {
|
| 70 |
let a = bigarray_create(Bigarray.char, len);
|
| 71 |
f(a);
|
| 72 |
Gl.string_of_bigarray(a)
|
| 73 | 73 |
};
|
| 74 | 74 |
|
| 75 | 75 |
|
| 76 | 76 |
|
| 77 | 77 |
/* The first thing to do is to get a new window from SDL and then
|
| 78 | 78 |
initialize an OpenGL context in that window. */
|
| 79 | |
let window () => {
|
| 80 | |
Sdl.init Sdl.Init.video >>= fun () =>
|
| 81 | |
Sdl.create_window w::640 h::480 "test" Sdl.Window.opengl >>= fun w =>
|
| 82 | |
Sdl.gl_create_context w >>= fun ctx =>
|
| 83 | |
Sdl.gl_make_current w ctx >>= fun () =>
|
| 84 | |
Ok (w, ctx)
|
| 79 |
let window = () => {
|
| 80 |
Sdl.init(Sdl.Init.video) >>= () =>
|
| 81 |
Sdl.create_window(~w=640, ~h=480, "test", Sdl.Window.opengl) >>= (w) =>
|
| 82 |
Sdl.gl_create_context(w) >>= (ctx) =>
|
| 83 |
Sdl.gl_make_current(w, ctx) >>= () =>
|
| 84 |
Ok((w, ctx))
|
| 85 | 85 |
};
|
| 86 | 86 |
|
| 87 | 87 |
/* This compiles a shader, producing an informative error message if
|
| 88 | 88 |
the compilation process fails. */
|
| 89 | |
let compile_shader typ src => {
|
| 90 | |
let shader = Gl.create_shader typ;
|
| 91 | |
Gl.shader_source shader src;
|
| 92 | |
Gl.compile_shader shader;
|
| 93 | |
if (buf_to_int (Gl.get_shaderiv shader Gl.compile_status) == Gl.true_) {
|
| 94 | |
Ok shader
|
| 89 |
let compile_shader = (typ, src) => {
|
| 90 |
let shader = Gl.create_shader(typ);
|
| 91 |
Gl.shader_source(shader, src);
|
| 92 |
Gl.compile_shader(shader);
|
| 93 |
if (buf_to_int(Gl.get_shaderiv(shader, Gl.compile_status)) == Gl.true_) {
|
| 94 |
Ok(shader)
|
| 95 | 95 |
} else {
|
| 96 | |
let len = buf_to_int (Gl.get_shaderiv shader Gl.info_log_length);
|
| 97 | |
let log = get_string len (Gl.get_shader_info_log shader len None);
|
| 98 | |
Gl.delete_shader shader;
|
| 99 | |
Error (`Msg log)
|
| 96 |
let len = buf_to_int(Gl.get_shaderiv(shader, Gl.info_log_length));
|
| 97 |
let log = get_string(len, (Gl.get_shader_info_log(shader, len, None)));
|
| 98 |
Gl.delete_shader(shader);
|
| 99 |
Error(`Msg(log))
|
| 100 | 100 |
}
|
| 101 | 101 |
};
|
| 102 | 102 |
|
| 103 | 103 |
/* This links our two shaders together into a single OpenGL program,
|
| 104 | 104 |
again producing an informative error message if it fails. */
|
| 105 | |
let create_program () => {
|
| 106 | |
compile_shader Gl.vertex_shader vertex_shader >>= fun vertex =>
|
| 107 | |
compile_shader Gl.fragment_shader fragment_shader >>= fun fragment => {
|
| 108 | |
let program = Gl.create_program ();
|
| 109 | |
Gl.attach_shader program vertex;
|
| 110 | |
Gl.attach_shader program fragment;
|
| 111 | |
Gl.link_program program;
|
| 112 | |
if (buf_to_int (Gl.get_programiv program Gl.link_status) == Gl.true_) {
|
| 113 | |
Ok program
|
| 105 |
let create_program = () => {
|
| 106 |
compile_shader(Gl.vertex_shader, vertex_shader) >>= (vertex) =>
|
| 107 |
compile_shader(Gl.fragment_shader, fragment_shader) >>= (fragment) => {
|
| 108 |
let program = Gl.create_program();
|
| 109 |
Gl.attach_shader(program, vertex);
|
| 110 |
Gl.attach_shader(program, fragment);
|
| 111 |
Gl.link_program(program);
|
| 112 |
if (buf_to_int(Gl.get_programiv(program, Gl.link_status)) == Gl.true_) {
|
| 113 |
Ok(program)
|
| 114 | 114 |
} else {
|
| 115 | |
let len = buf_to_int (Gl.get_programiv program Gl.info_log_length);
|
| 116 | |
let log = get_string len (Gl.get_program_info_log program len None);
|
| 117 | |
Gl.delete_program program;
|
| 118 | |
Error (`Msg log)
|
| 115 |
let len = buf_to_int(Gl.get_programiv(program, Gl.info_log_length));
|
| 116 |
let log = get_string(len, (Gl.get_program_info_log(program, len, None)));
|
| 117 |
Gl.delete_program(program);
|
| 118 |
Error(`Msg(log))
|
| 119 | 119 |
}
|
| 120 | 120 |
}
|
| 121 | 121 |
};
|
|
| 123 | 123 |
|
| 124 | 124 |
/* This initializes a vertex array and a vertex buffer using our
|
| 125 | 125 |
vertex information above. */
|
| 126 | |
let init_scene program => {
|
| 127 | |
let array = buf_to_int (Gl.gen_vertex_arrays 1);
|
| 128 | |
Gl.bind_vertex_array array;
|
| 129 | |
|
| 130 | |
let buffer = buf_to_int (Gl.gen_buffers 1);
|
| 131 | |
Gl.bind_buffer Gl.array_buffer buffer;
|
| 132 | |
Gl.buffer_data
|
| 133 | |
Gl.array_buffer
|
| 134 | |
(Gl.bigarray_byte_size vertices)
|
| 135 | |
(Some vertices)
|
| 136 | |
Gl.static_draw;
|
| 126 |
let init_scene = (program) => {
|
| 127 |
let array = buf_to_int(Gl.gen_vertex_arrays(1));
|
| 128 |
Gl.bind_vertex_array(array);
|
| 129 |
|
| 130 |
let buffer = buf_to_int(Gl.gen_buffers(1));
|
| 131 |
Gl.bind_buffer(Gl.array_buffer, buffer);
|
| 132 |
Gl.buffer_data(
|
| 133 |
Gl.array_buffer,
|
| 134 |
Gl.bigarray_byte_size(vertices),
|
| 135 |
Some(vertices),
|
| 136 |
Gl.static_draw
|
| 137 |
);
|
| 137 | 138 |
|
| 138 | 139 |
/* This bit is first telling OpenGL where our fragment data can be
|
| 139 | 140 |
found */
|
| 140 | |
Gl.bind_frag_data_location program 0 "out_color";
|
| 141 |
Gl.bind_frag_data_location(program, 0, "out_color");
|
| 141 | 142 |
/* and then asking it the location of the position attribute */
|
| 142 | |
let pos_attr = Gl.get_attrib_location program "position";
|
| 143 |
let pos_attr = Gl.get_attrib_location(program, "position");
|
| 143 | 144 |
/* and finally telling OpenGL that the stuff in our vertex buffer
|
| 144 | 145 |
corresponds to the aforementioned "position" attribute */
|
| 145 | |
Gl.enable_vertex_attrib_array pos_attr;
|
| 146 |
Gl.enable_vertex_attrib_array(pos_attr);
|
| 146 | 147 |
/* and tells OpenGL that it consists of two floats with no stride
|
| 147 | 148 |
and no offset. */
|
| 148 | |
Gl.vertex_attrib_pointer pos_attr 2 Gl.float false 0 (`Offset 0);
|
| 149 |
Gl.vertex_attrib_pointer(pos_attr, 2, Gl.float, false, 0, `Offset(0));
|
| 149 | 150 |
|
| 150 | 151 |
/* We return these for later use! */
|
| 151 | 152 |
(array, buffer)
|
| 152 | 153 |
};
|
| 153 | 154 |
|
| 154 | 155 |
|
| 155 | |
let draw program buffer w => {
|
| 156 |
let draw = (program, buffer, w) => {
|
| 156 | 157 |
/* we clear the background color to a pleasing robin's-egg blue */
|
| 157 | |
Gl.clear_color 0.3 0.6 0.9 1.;
|
| 158 | |
Gl.clear Gl.color_buffer_bit;
|
| 158 |
Gl.clear_color(0.3, 0.6, 0.9, 1.0);
|
| 159 |
Gl.clear(Gl.color_buffer_bit);
|
| 159 | 160 |
|
| 160 | 161 |
/* we tell OpenGL we want to use that program we made earlier, and
|
| 161 | 162 |
the array buffer we created earlier, too */
|
| 162 | |
Gl.use_program program;
|
| 163 | |
Gl.bind_buffer Gl.array_buffer buffer;
|
| 163 |
Gl.use_program(program);
|
| 164 |
Gl.bind_buffer(Gl.array_buffer, buffer);
|
| 164 | 165 |
/* and tell it to draw the first 3 things in that array buffer as
|
| 165 | 166 |
triangles */
|
| 166 | |
Gl.draw_arrays Gl.triangles 0 3;
|
| 167 |
Gl.draw_arrays(Gl.triangles, 0, 3);
|
| 167 | 168 |
/* and then clear that shit out. (We can skip this step, to be fair,
|
| 168 | 169 |
but it's good to get in the habit for later.) */
|
| 169 | |
Gl.bind_buffer Gl.array_buffer 0;
|
| 170 | |
Gl.use_program 0;
|
| 170 |
Gl.bind_buffer(Gl.array_buffer, 0);
|
| 171 |
Gl.use_program(0);
|
| 171 | 172 |
|
| 172 | 173 |
/* and finally swap the window! */
|
| 173 | |
Sdl.gl_swap_window w
|
| 174 |
Sdl.gl_swap_window(w)
|
| 174 | 175 |
};
|
| 175 | 176 |
|
| 176 | 177 |
|
| 177 | 178 |
/* The drawing function here is of type () -> () so we can pass in a
|
| 178 | 179 |
closure and not have to pass other data down the chain */
|
| 179 | |
let event_loop draw w => {
|
| 180 |
let event_loop = (draw, w) => {
|
| 180 | 181 |
let e = Sdl.Event.create();
|
| 181 | 182 |
/* these helper functions are just to reduce the verbosity down
|
| 182 | 183 |
below */
|
| 183 | |
let keycode e => Sdl.Scancode.enum Sdl.Event.(get e keyboard_scancode);
|
| 184 | |
let event e => Sdl.Event.(enum (get e typ));
|
| 184 |
let keycode = (e) => Sdl.Scancode.enum(Sdl.Event.(get(e, keyboard_scancode)));
|
| 185 |
let event = (e) => Sdl.Event.(enum (get(e, typ)));
|
| 185 | 186 |
/* the crunchy center is a loop that draws and then dispatches on
|
| 186 | 187 |
the relevant events */
|
| 187 | |
let rec loop () => {
|
| 188 |
let rec loop = () => {
|
| 188 | 189 |
draw ();
|
| 189 | |
Sdl.wait_event (Some e) >>= fun () =>
|
| 190 | |
switch (event e) {
|
| 190 |
Sdl.wait_event(Some(e)) >>= () =>
|
| 191 |
switch (event(e)) {
|
| 191 | 192 |
| `Quit => Ok ()
|
| 192 | |
| `Key_down when keycode e == `Escape => Ok ()
|
| 193 | |
| `Key_down when keycode e == `Q => Ok ()
|
| 193 |
| `Key_down when keycode(e) == `Escape => Ok ()
|
| 194 |
| `Key_down when keycode(e) == `Q => Ok ()
|
| 194 | 195 |
| _ => loop ()
|
| 195 | 196 |
}
|
| 196 | 197 |
};
|
|
| 199 | 200 |
|
| 200 | 201 |
|
| 201 | 202 |
/* and the main function! */
|
| 202 | |
let main () => {
|
| 203 |
let main = () => {
|
| 203 | 204 |
/* create the window */
|
| 204 | |
window () >>= fun (w, ctx) =>
|
| 205 |
window () >>= ((w, ctx)) =>
|
| 205 | 206 |
/* create the program */
|
| 206 | |
create_program () >>= fun program => {
|
| 207 |
create_program () >>= (program) => {
|
| 207 | 208 |
/* create the vertex data */
|
| 208 | |
let (array, buffer) = init_scene program;
|
| 209 |
let (array, buffer) = init_scene(program);
|
| 209 | 210 |
/* run the event loop with the relevant drawing function */
|
| 210 | |
event_loop (fun () => draw program array w) w >>= fun () => {
|
| 211 |
event_loop(() => draw(program,array, w), w) >>= () => {
|
| 211 | 212 |
/* and clean it all up! */
|
| 212 | |
int_as_buf (Gl.delete_vertex_arrays 1) array;
|
| 213 | |
int_as_buf (Gl.delete_buffers 1) buffer;
|
| 214 | |
Gl.delete_program program;
|
| 215 | |
Sdl.gl_delete_context ctx;
|
| 216 | |
Sdl.destroy_window w;
|
| 217 | |
Sdl.quit ();
|
| 213 |
int_as_buf(Gl.delete_vertex_arrays(1), array);
|
| 214 |
int_as_buf(Gl.delete_buffers(1), buffer);
|
| 215 |
Gl.delete_program(program);
|
| 216 |
Sdl.gl_delete_context(ctx);
|
| 217 |
Sdl.destroy_window(w);
|
| 218 |
Sdl.quit();
|
| 218 | 219 |
/* s'all good yo */
|
| 219 | |
Ok ()
|
| 220 |
Ok()
|
| 220 | 221 |
}
|
| 221 | 222 |
}
|
| 222 | 223 |
};
|
| 223 | 224 |
|
| 224 | 225 |
/* and, at the top-level, run it and print any error messages we
|
| 225 | 226 |
get. */
|
| 226 | |
switch (main ()) {
|
| 227 | |
| Ok () => ()
|
| 228 | |
| Error (`Msg e) => {
|
| 229 | |
Sdl.log "%s" e;
|
| 230 | |
exit 1
|
| 227 |
switch (main()) {
|
| 228 |
| Ok() => ()
|
| 229 |
| Error(`Msg(e)) => {
|
| 230 |
Sdl.log("%s", e);
|
| 231 |
exit(1)
|
| 231 | 232 |
};
|
| 232 | 233 |
};
|