implement gl pipeline with ability to draw a rectangle

assets/shaders/polygon.frag

@@ -0,0 +1,9 @@
+#version 150 core
+
+uniform vec4 Fill;
+
+out vec4 FragColor;
+
+void main() {
+  FragColor = Fill;
+}

assets/shaders/polygon.vert

@@ -0,0 +1,18 @@
+#version 150 core
+
+uniform ivec2 Viewport;
+uniform mat3  Transform;
+uniform vec4  BoundingBox;
+uniform int   Border;
+
+in vec2 Vert;
+in vec2 Norm;
+
+void main() {
+  vec2 vert = mix(BoundingBox.xy, BoundingBox.zw, Vert) + Border * Norm;
+  vec3 pos = Transform * vec3(vert, 1.0);
+
+  gl_Position.xy = pos.xy * vec2(2.0, -2.0) / Viewport + vec2(-1.0, 1.0);
+  gl_Position.z = 0.0;
+  gl_Position.w = 1.0;
+}

src/gl.ml

@@ -0,0 +1,43 @@
+open! Import
+include Tgl4.Gl
+
+exception Error of string * string
+
+let error_names = [
+  invalid_enum,                  "Invalid enum";
+  invalid_value,                 "Invalid value";
+  invalid_operation,             "Invalid operation";
+  invalid_framebuffer_operation, "Invalid framebuffer operation";
+  out_of_memory,                 "Out of memory";
+  stack_underflow,               "Stack underflow";
+  stack_overflow,                "Stack overflow";
+]
+
+let check_error why =
+  let err = get_error () in
+  if err <> no_error then
+    raise (Error (why, List.assoc err error_names))
+
+let _i32 = Array1.create Int32 C_layout 1
+
+let get_integer param =
+  get_integerv param _i32;
+  Int32.to_int _i32.{0}
+
+let gen_get_status gen_get gen_get_info_log status_enum obj =
+  gen_get obj status_enum _i32;
+  if Int32.to_int _i32.{0} = true_ then Ok ()
+  else
+    let len =
+      gen_get obj info_log_length _i32;
+      Int32.to_int _i32.{0}
+    in
+    let buf = Array1.create Char C_layout len in
+    gen_get_info_log obj len None buf;
+    Error (String.init (len - 1) (fun i -> buf.{i}))
+
+let get_shader_compile_status obj =
+  gen_get_status get_shaderiv get_shader_info_log compile_status obj
+
+let get_program_link_status obj =
+  gen_get_status get_programiv get_program_info_log link_status obj

src/import.ml

@@ -1,4 +1,5 @@
 include Adam
+module Array1 = Bigarray.Array1
 
 module Sdl = struct
   include Tsdl.Sdl

src/main.ml

@@ -33,7 +33,11 @@ let main () =
 
       (* let time = Sdl.get_ticks () |> Int32.to_int in *)
       Renderer.pre_draw ren;
-      Renderer.clear ren (rgb24 0xff8833);
+      Renderer.clear ren (rgb24 0x000000);
+      Renderer.draw_rect ren
+        ~tf:(mat2a 100.0 50.0 1.0 1.0)
+        ~bb:(aabb (-5.0) (-10.0) 50.0 200.0)
+        ~fill:(rgb24 0xff0000);
       Renderer.post_draw ren;
     done
   with Quit ->
@@ -48,4 +52,5 @@ let () =
   try main () with
   | Failure msg -> error (fun m -> m "%s" msg)
   | Sdl.Error msg -> error (fun m -> m "SDL error: %s" msg)
+  | Gl.Error (why, msg) -> error (fun m -> m "OpenGL error (%s): %s" why msg)
   | Asset.Error (path, msg) -> error (fun m -> m "failed to load %S: %s" path msg)

src/renderer.ml

@@ -1,37 +1,298 @@
 open! Import
 include (val Ohlog.sublogs logger "Ren")
 
+
+(* Buffer *)
+
+type buffer = {
+  bo : int;
+} [@@unboxed]
+
+let set_buffer_data ?(usage = Gl.stream_draw) {bo} data =
+  let size = Array1.size_in_bytes data in
+  Gl.bind_buffer Gl.array_buffer bo;
+  Gl.buffer_data Gl.array_buffer size (Some data) usage
+
+let make_buffer ?data () =
+  let bo = Gl.gen_buffers 1 Gl._i32; Int32.to_int Gl._i32.{0} in
+  let buf = {bo} in
+  Option.iter (set_buffer_data buf ~usage:Gl.static_draw) data;
+  buf
+
+let buffer_size_in_bytes { bo } =
+  Gl.get_named_buffer_parameteriv bo Gl.buffer_size Gl._i32;
+  Int32.to_int Gl._i32.{0}
+
+
+(* Vertex buffer attributes *)
+
+type attr = {
+  aidx : int;
+  atype : [`float];
+  asize : int;
+}
+
+let attr_type at = match at.atype with
+  | `float -> Gl.float
+
+let attr_size_in_bytes at = match at.atype with
+  | `float -> at.asize * 4
+
+type vertex_buffer = {
+  vbuf : buffer;
+  vats : attr list;
+  vdiv : int;
+}
+
+let make_static_vertex_buffer data vats =
+  let vbuf = make_buffer () ~data in
+  { vbuf; vats; vdiv = 0 }
+
+(* let make_instance_vertex_buffer vats = *)
+(*   let vbuf = make_buffer () in *)
+(*   {vbuf; vats; vdiv = 1} *)
+
+let bind_vertex_buffer { vbuf; vdiv; vats } =
+  Gl.bind_buffer Gl.array_buffer vbuf.bo;
+  let stride =
+    List.fold_left (fun n at -> n + attr_size_in_bytes at) 0 vats
+  in
+  let enable ofs at =
+    Gl.vertex_attrib_pointer
+      at.aidx at.asize (attr_type at)
+      false stride (`Offset ofs);
+    Gl.vertex_attrib_divisor at.aidx vdiv;
+    Gl.enable_vertex_attrib_array at.aidx;
+    ofs + attr_size_in_bytes at
+  in
+  ignore (List.fold_left enable 0 vats : int)
+
+
+(* Shaders *)
+
+type shader = {
+  spo : int;
+} [@@unboxed]
+
+type 'a uniform = U : int -> 'a uniform [@@unboxed]
+
+let compile_shader ~vert ~frag =
+  let spo = Gl.create_program () in
+  let compile type_ name src =
+    let so = Gl.create_shader type_ in
+    Gl.attach_shader spo so;
+    (* "If a shader object to be deleted is attached to a program object, it will be
+     * flagged for deletion, but it will not be deleted until it is no longer attached
+     * to any program object" *)
+    Gl.delete_shader so;
+    Gl.shader_source so src;
+    Gl.compile_shader so;
+    match Gl.get_shader_compile_status so with
+    | Ok () -> ()
+    | Error info_log ->
+      Gl.delete_program spo;
+      Printf.ksprintf failwith "Error compiling %s shader: %s" name info_log
+  in
+  let link () =
+    Gl.link_program spo;
+    match Gl.get_program_link_status spo with
+    | Ok () -> { spo }
+    | Error info_log ->
+      Gl.delete_program spo;
+      Printf.ksprintf failwith "Error linking shader: %s" info_log
+  in
+  compile Gl.vertex_shader "vertex" vert;
+  compile Gl.fragment_shader "fragment" frag;
+  link ()
+
+let load_shader ~name =
+  let shd =
+    compile_shader
+      ~vert:(Printf.ksprintf Asset.load_file "shaders/%s.vert" name)
+      ~frag:(Printf.ksprintf Asset.load_file "shaders/%s.frag" name)
+  in
+  debug (fun m -> m "loaded shader %S" name); shd
+
+let use {spo} =
+  Gl.use_program spo
+
+let attr {spo} aname atype asize =
+  match Gl.get_attrib_location spo aname with
+  | -1 -> Printf.ksprintf failwith "No such attribute %S" aname
+  | aidx -> { aidx; atype; asize }
+
+let uniform {spo} name =
+  match Gl.get_uniform_location spo name with
+  | -1 -> Printf.ksprintf failwith "No such uniform: %S" name
+  | loc -> U loc
+
+type 'a set_fn = 'a uniform -> 'a -> unit
+
+let set_int : int set_fn = fun (U l) x -> Gl.uniform1i l x
+let set_ivec2 : (int*int) set_fn = fun (U l) (x, y) -> Gl.uniform2i l x y
+let set_color : color set_fn = fun (U l) c -> Gl.uniform4f l c.r c.g c.b c.a
+let set_aabb : aabb set_fn = fun (U l) b -> Gl.uniform4f l b.x0 b.y0 b.x1 b.y1
+
+let set_mat2a : mat2a set_fn =
+  let _mat3x3 = Array1.create Float32 C_layout 9 in
+  _mat3x3.{6} <- 0.0;
+  _mat3x3.{7} <- 0.0;
+  _mat3x3.{8} <- 1.0;
+  fun (U l) mat ->
+    _mat3x3.{0} <- mat.a0;
+    _mat3x3.{1} <- mat.a1;
+    _mat3x3.{2} <- mat.a2;
+    _mat3x3.{3} <- mat.a3;
+    _mat3x3.{4} <- mat.a4;
+    _mat3x3.{5} <- mat.a5;
+    Gl.uniform_matrix3fv l 1 true _mat3x3
+
+
+(* Geometry *)
+
+type geometry = {
+  vao : int;
+  draw_mode : Gl.enum;
+  indices : [`count of int | `elems of int];
+}
+
+let make_geometry
+      ~draw_mode
+      ~index
+      vertex_buffers
+  =
+  let vao = Gl.gen_vertex_arrays 1 Gl._i32; Int32.to_int Gl._i32.{0} in
+  Gl.bind_vertex_array vao;
+  let indices = match index with
+    | `count n ->
+      Gl.bind_buffer Gl.element_array_buffer 0;
+      `count n
+    | `elems ibuf ->
+      Gl.bind_buffer Gl.element_array_buffer ibuf.bo;
+      (* divide by 2 since the buffer should contain int16_unsigned *)
+      `elems (buffer_size_in_bytes ibuf / 2)
+  in
+  List.iter bind_vertex_buffer vertex_buffers;
+  {
+    vao;
+    draw_mode;
+    indices
+  }
+
+let draw_geometry ?(instances = 1) { vao; draw_mode; indices } =
+  Gl.bind_vertex_array vao;
+  match indices with
+  | `count n ->
+    Gl.draw_arrays_instanced draw_mode 0 n instances
+  | `elems n ->
+    let offset = `Offset 0 in
+    let type_ = Gl.unsigned_short in
+    Gl.draw_elements_instanced draw_mode n type_ offset instances
+
+
+(* Renderer *)
+
 type t = {
   window : Sdl.window;
   gl_ctx : Sdl.gl_context;
+
+  polygon : shader;
+  rect : geometry;
 }
 
+let unit_square =
+  (* 1--0
+   * |  |
+   * 3--2
+  *)
+  Array1.of_array Float32 C_layout @@
+  Array.concat [
+    [| 1.; 0.; |];
+    [| 0.; 0.; |];
+    [| 1.; 1.; |];
+    [| 0.; 1.; |];
+  ]
+
+let unit_square_with_norm =
+  (* 5    4
+   *  1--0
+   *  |  |
+   *  3--2
+   * 7    6
+  *)
+  Array1.of_array Float32 C_layout @@
+  Array.concat [
+    [| 1.; 0.;  0.;  0. |];
+    [| 0.; 0.;  0.;  0. |];
+    [| 1.; 1.;  0.;  0. |];
+    [| 0.; 1.;  0.;  0. |];
+    [| 1.; 0.;  1.; -1. |];
+    [| 0.; 0.; -1.; -1. |];
+    [| 1.; 1.;  1.;  1. |];
+    [| 0.; 1.; -1.;  1. |];
+  ]
+
 let make ~(window : Sdl.window) : t =
   debug (fun m -> m "initializing");
   let gl_ctx = Sdl.gl_create_context_exn window in
   Sdl.gl_make_current_exn window gl_ctx;
   Sdl.gl_set_swap_interval_exn 1;
 
+  Gl.enable Gl.blend;
+  Gl.blend_func Gl.one Gl.one_minus_src_alpha;
+  Gl.check_error "setup";
+
+  let polygon =
+    load_shader
+      ~name:"polygon"
+  in
+
+  let rect =
+    make_geometry [
+      make_static_vertex_buffer unit_square_with_norm [
+        attr polygon "Vert" `float 2;
+        attr polygon "Norm" `float 2;
+      ]
+    ]
+      ~draw_mode:Gl.triangle_strip
+      ~index:(`count 4)
+  in
+
   {
     window;
     gl_ctx;
+    polygon;
+    rect;
   }
 
 let destroy t =
   Sdl.gl_delete_context t.gl_ctx
 
 let pre_draw t =
+  let viewport = Sdl.get_window_size t.window in
   begin
     Sdl.gl_make_current_exn t.window t.gl_ctx;
-    (* let size = Sdl.get_window_size t.window in *)
+    set_ivec2 (uniform t.polygon "Viewport") viewport;
   end
 
-let clear (_t : t) (bg : color) =
+let clear _t (bg : color) =
   begin
     Gl.clear_color bg.r bg.g bg.b bg.a;
     Gl.clear Gl.color_buffer_bit;
   end
 
+let draw_rect t ~(tf : mat2a) ~(bb : aabb) ~(fill : color) =
+  let sh = t.polygon in
+  begin
+    (* TODO: cache/store uniform locations in some way *)
+    use sh;
+    set_mat2a (uniform sh "Transform") tf;
+    set_aabb  (uniform sh "BoundingBox") bb;
+    set_int   (uniform sh "Border") 0;
+    set_color (uniform sh "Fill") fill;
+    draw_geometry t.rect;
+  end
+
 let post_draw t =
   begin
     Sdl.gl_swap_window t.window;