open Tsdl
open Tgl4
open Result

(* the bind operator for the exception monad, for quick error
handling *)
let (>>=) x f = match x with
  | Ok v -> f v
  | Error _ as e -> e

(* our vertex shader takes a 2d position and renders it on the screen,
and that's it *)
let vertex_shader =
  "#version 130
in vec2 position;
void main() {
  gl_Position = vec4(position, 0.0, 1.0);
}
"

(* our fragment shader just draws white *)
let fragment_shader =
  "#version 130
out vec4 out_color;
void main() {
  out_color = vec4(1.0, 1.0, 1.0, 1.0);
}
"

(* we use a lot of Bigarrays, which are contiguous chunks of memory
that we can hand off to C *)
let bigarray_create k len = Bigarray.(Array1.create k c_layout len)

(* our vertex data is [0.0, 0.5, 0.5, -0.5, -0.5, -0.5], but in a
contiguous array of memory *)
let vertices =
  let arr = bigarray_create Bigarray.float32 6 in
  arr.{0} <- 0.0;
  arr.{1} <- 0.5;
  arr.{2} <- 0.5;
  arr.{3} <- -0.5;
  arr.{4} <- -0.5;
  arr.{5} <- -0.5;
  arr

(* This takes a function which expects to fill a buffer with a single
32-bit integer; this will call that function and then conver it to an
OCaml integer *)
let buf_to_int =
  let a = bigarray_create Bigarray.int32 1 in
  fun f -> f a; Int32.to_int a.{0}

(* This takes a function that expects to use a buffer containing a
   single 32-bit integer as well as an integer itself; this will
   convert the integer into a buffer and then call the function on
   it *)
let int_as_buf =
  let a = bigarray_create Bigarray.int32 1 in
  fun f i -> a.{0} <- Int32.of_int i; f a

(* Like buf_to_int, but for an arbitrary-sized string *)
let get_string len f =
  let a = bigarray_create Bigarray.char len in
  f a; Gl.string_of_bigarray a

(* The first thing to do is to get a new window from SDL and then
initialize an OpenGL context in that window. *)
let window () =
  Sdl.init Sdl.Init.video >>= fun () ->
  Sdl.create_window ~w:640 ~h:480 "test" Sdl.Window.opengl >>= fun w ->
  Sdl.gl_create_context w >>= fun ctx ->
  Sdl.gl_make_current w ctx >>= fun () ->
  Ok (w, ctx)

(* This compiles a shader, producing an informative error message if
the compilation process fails. *)
let compile_shader typ src =
  let shader = Gl.create_shader typ in
  Gl.shader_source shader src;
  Gl.compile_shader shader;
  if buf_to_int (Gl.get_shaderiv shader Gl.compile_status) = Gl.true_
  then Ok shader
  else
    let len = buf_to_int (Gl.get_shaderiv shader Gl.info_log_length) in
    let log = get_string len (Gl.get_shader_info_log shader len None) in
    (Gl.delete_shader shader; Error (`Msg log))

(* This links our two shaders together into a single OpenGL program,
again producing an informative error message if it fails. *)
let create_program () =
  compile_shader Gl.vertex_shader vertex_shader >>= fun vertex ->
  compile_shader Gl.fragment_shader fragment_shader >>= fun fragment ->
  let program = Gl.create_program () in
  Gl.attach_shader program vertex;
  Gl.attach_shader program fragment;
  Gl.link_program program;
  if buf_to_int (Gl.get_programiv program Gl.link_status) = Gl.true_
  then Ok program
  else
    let len = buf_to_int (Gl.get_programiv program Gl.info_log_length) in
    let log = get_string len (Gl.get_program_info_log program len None) in
    (Gl.delete_program program; Error (`Msg log))

(* This initializes a vertex array and a vertex buffer using our
vertex information above. *)
let init_scene program =
  let array = buf_to_int (Gl.gen_vertex_arrays 1) in
  Gl.bind_vertex_array array;

  let buffer = buf_to_int (Gl.gen_buffers 1) in
  Gl.bind_buffer Gl.array_buffer buffer;
  Gl.buffer_data
    Gl.array_buffer
    (Gl.bigarray_byte_size vertices)
    (Some vertices)
    Gl.static_draw;

  (* This bit is first telling OpenGL where our fragment data can be
  found *)
  Gl.bind_frag_data_location program 0 "out_color";
  (* and then asking it the location of the position attribute *)
  let pos_attr = Gl.get_attrib_location program "position" in
  (* and finally telling OpenGL that the stuff in our vertex buffer
  corresponds to the aforementioned "position" attribute *)
  Gl.enable_vertex_attrib_array pos_attr;
  (* and tells OpenGL that it consists of two floats with no stride
  and no offset. *)
  Gl.vertex_attrib_pointer pos_attr 2 Gl.float false 0 (`Offset 0);

  (* We return these for later use! *)
  (array, buffer)

let draw program buffer w =
  (* we clear the background color to a pleasing robin's-egg blue *)
  Gl.clear_color 0.3 0.6 0.9 1.;
  Gl.clear Gl.color_buffer_bit;

  (* we tell OpenGL we want to use that program we made earlier, and
  the array buffer we created earlier, too *)
  Gl.use_program program;
  Gl.bind_buffer Gl.array_buffer buffer;
  (* and tell it to draw the first 3 things in that array buffer as
  triangles *)
  Gl.draw_arrays Gl.triangles 0 3;
  (* and then clear that shit out. (We can skip this step, to be fair,
  but it's good to get in the habit for later.) *)
  Gl.bind_buffer Gl.array_buffer 0;
  Gl.use_program 0;

  (* and finally swap the window! *)
  Sdl.gl_swap_window w

(* The drawing function here is of type () -> () so we can pass in a
closure and not have to pass other data down the chain *)
let event_loop draw w =
  let e = Sdl.Event.create() in
  (* these helper functions are just to reduce the verbosity down
  below *)
  let keycode e = Sdl.Scancode.enum Sdl.Event.(get e keyboard_scancode) in
  let event e = Sdl.Event.(enum (get e typ)) in
  (* the crunchy center is a loop that draws and then dispatches on
  the relevant events *)
  let rec loop () =
    draw ();
    Sdl.wait_event (Some e) >>= fun () ->
    match event e with
    | `Quit -> Ok ()
    | `Key_down when keycode e = `Escape -> Ok ()
    | `Key_down when keycode e = `Q -> Ok ()
    | _ -> loop ()
  in loop ()

(* and the main function! *)
let main () =
  (* create the window *)
  window () >>= fun (w, ctx) ->
  (* create the program *)
  create_program () >>= fun program ->
  (* create the vertex data *)
  let (array, buffer) = init_scene program in
  (* run the event loop with the relevant drawing function *)
  event_loop (fun () -> draw program array w) w >>= fun () ->
  (* and clean it all up! *)
  int_as_buf (Gl.delete_vertex_arrays 1) array;
  int_as_buf (Gl.delete_buffers 1) buffer;
  Gl.delete_program program;
  Sdl.gl_delete_context ctx;
  Sdl.destroy_window w;
  Sdl.quit ();
  (* s'all good yo *)
  Ok ()

(* and, at the top-level, run it and print any error messages we
get. *)
let () = match main () with
  | Ok () -> ()
  | Error (`Msg e) ->
     Sdl.log "%s" e;
     exit 1