geometra/src/s2/renderer.ml

open! Import
include (val Ohlog.sublogs logger "Ren")

type ivec2 = int * int


(* 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_vec2 : vec2 set_fn = fun (U l) {x; y} -> Gl.uniform2f l x y
let set_ivec2 : ivec2 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 mat3 = Array1.create Float32 C_layout 9 in
  mat3.{6} <- 0.0;
  mat3.{7} <- 0.0;
  mat3.{8} <- 1.0;
  fun (U l) mat ->
    mat3.{0} <- mat.a0;
    mat3.{1} <- mat.a1;
    mat3.{2} <- mat.a2;
    mat3.{3} <- mat.a3;
    mat3.{4} <- mat.a4;
    mat3.{5} <- mat.a5;
    Gl.uniform_matrix3fv l 1 true mat3


(* Geometry *)

type geometry = {
  vao : int;
  draw_mode : Gl.enum;
  indices : [`range of int * int (* | `elems of int*)];
}

let make_geometry
      ~draw_mode
      ~count
      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 =
    Gl.bind_buffer Gl.element_array_buffer 0;
    `range (0, count)
    (* TODO: index buffer (useful for drawing rect borders) *)
  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
  | `range (ofs, len) ->
    Gl.draw_arrays_instanced draw_mode ofs len instances

(* | `elems n -> *)
(*   Gl.draw_elements_instanced draw_mode count type_ offset instances *)


(* Texture *)

type texture = {
  tid : int;
} [@@unboxed]

type pixel_array = (float, Bigarray.float32_elt, Bigarray.c_layout) Array1.t

let make_texture width height fmt (pixels : pixel_array) =
  let tid = Gl.gen_textures 1 Gl._i32; Int32.to_int Gl._i32.{0} in
  Gl.bind_texture Gl.texture_2d tid;
  (* TODO: configurable *)
  Gl.tex_parameteri Gl.texture_2d Gl.texture_wrap_s Gl.clamp_to_edge;
  Gl.tex_parameteri Gl.texture_2d Gl.texture_wrap_t Gl.clamp_to_edge;
  Gl.tex_parameteri Gl.texture_2d Gl.texture_min_filter Gl.linear_mipmap_linear;
  Gl.tex_parameteri Gl.texture_2d Gl.texture_mag_filter Gl.linear;
  Gl.tex_image2d Gl.texture_2d 0 fmt width height 0 fmt Gl.float (`Data pixels);
  Gl.generate_mipmap Gl.texture_2d;
  Gl.bind_texture Gl.texture_2d 0;
  {tid}

let set_tex : texture set_fn =
  fun (U l) {tid} ->
  (* TODO: in order to allow multiple textures, there should something like a LRU cache of
     which texture unit each is bound to. *)
  Gl.bind_texture Gl.texture_2d tid;
  Gl.uniform1i l 0


(* Renderer *)

type t = {
  window : Sdl.window;
  gl_ctx : Sdl.gl_context;

  polygon : shader;
  rect_g : geometry;

  sprite : shader;
  sprite_g : geometry;
  (* sprite_instances : vertex_buffer; *)

  msdf : shader;
  text_g : geometry;
  (* msdf_instances : vertex_buffer; *)
}

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 ~(wnd : Sdl.window) : t =
  debug (fun m -> m "initializing");
  let gl_ctx = Sdl.gl_create_context_exn wnd in
  Sdl.gl_make_current_exn wnd 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_g =
    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
      ~count:4
  in

  let sprite = load_shader ~name:"sprite" in
  let sprite_g =
    make_geometry [
      make_static_vertex_buffer unit_square [
        attr sprite "Vert" `float 2;
      ]
      (* sprite_instances *)
    ]
      ~draw_mode:Gl.triangle_strip
      ~count:4
  in

  let msdf = load_shader ~name:"msdf" in
  let text_g =
    make_geometry [
      make_static_vertex_buffer unit_square [
        attr msdf "Vert" `float 2;
      ]
      (* msdf_instances *)
    ]
      ~draw_mode:Gl.triangle_strip
      ~count:4
  in

  {
    window = wnd;
    gl_ctx;
    polygon;
    rect_g;
    sprite;
    sprite_g;
    msdf;
    text_g;
  }

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;
    use t.polygon; set_ivec2 (uniform t.polygon "Viewport") viewport;
    use t.sprite; set_ivec2 (uniform t.sprite "Viewport") viewport;
    use t.msdf; set_ivec2 (uniform t.msdf "Viewport") viewport;
  end

let post_draw t =
  begin
    Sdl.gl_swap_window t.window;
  end

let clear _t (bg : color) =
  begin
    Gl.clear_color bg.r bg.g bg.b bg.a;
    Gl.clear Gl.color_buffer_bit;
  end

(* TODO: store uniforms *)
(* TODO: instanced rendering *)

let draw_rect t ~tf ~fill rect =
  let sh = t.polygon and ge = t.rect_g in
  begin
    use sh;
    set_mat2a (uniform sh "Transform") tf;
    set_aabb  (uniform sh "BoundingBox") rect;
    set_int   (uniform sh "Border") 0;
    set_color (uniform sh "Fill") fill;
    draw_geometry ge;
  end

let draw_texture t ~tf ~rect ~clip ~tint tex =
  let sh = t.sprite and ge = t.sprite_g in
  begin
    use sh;
    set_mat2a (uniform sh "Transform") tf;
    set_tex   (uniform sh "Texture") tex;
    set_aabb  (uniform sh "Rect") rect;
    set_aabb  (uniform sh "Clip") clip;
    set_color (uniform sh "Tint") tint;
    draw_geometry ge;
  end

let draw_glyph t ~tf ~offset ~atlas ~plane ~fg msdf =
  let sh = t.msdf and ge = t.text_g in
  begin
    use sh;
    set_mat2a (uniform sh "Transform") tf;
    set_tex   (uniform sh "Texture") msdf;
    set_vec2  (uniform sh "Offset") offset;
    set_aabb  (uniform sh "Atlas") atlas;
    set_aabb  (uniform sh "Plane") plane;
    set_color (uniform sh "Fill") fg;
    draw_geometry ge;
  end