refactor texture munching to use Array3 and reshape

assets/shaders/sprite.frag

@@ -0,0 +1,12 @@
+#version 150 core
+
+uniform sampler2D Texture;
+uniform vec4 Tint;
+
+in vec2 TextureCoord;
+
+out vec4 FragColor;
+
+void main() {
+  FragColor = texture2D(Texture, TextureCoord) * Tint;
+}

assets/shaders/sprite.vert

@@ -0,0 +1,25 @@
+#version 150 core
+
+uniform ivec2 Viewport;
+uniform mat3  Transform;
+uniform vec4  BoundingBox;
+
+in vec2 Vert;
+
+/* TODO: instances */
+// in vec4 Rect;
+// in vec4 Clip;
+
+out vec2 TextureCoord;
+
+void main() {
+  vec2 vert = mix(BoundingBox.xy, BoundingBox.zw, Vert);
+  vec3 pos = Transform * vec3(vert, 1.0);
+
+  // TextureCoord = mix(Clip.st, Clip.pq, Vert) / textureSize(T, 0);
+  TextureCoord = Vert;
+
+  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/main.ml

@@ -13,8 +13,8 @@ let main () =
   let ren = Renderer.make ~wnd in
   info (fun m -> m "renderer initialized");
 
-  let cat = Asset.load_texture "catthumbsup.png" in
-  info (fun m -> m "%dx%d" (Texture.width cat) (Texture.height cat));
+  let tex_cat = Asset.load_texture "catthumbsup.png" in
+  let tex_otters = Asset.load_texture "otters.jpg" in
   debug (fun m -> m "loaded assets");
 
   let tg = TG.make () in
@@ -45,6 +45,14 @@ let main () =
       TG.update tg;
       SG.render sg ~ren;
 
+      Renderer.draw_texture ren tex_otters
+        ~tf
+        ~bb:(aabb 0.0 (-200.0) (300.0) (200.0));
+
+      Renderer.draw_texture ren tex_cat
+        ~tf
+        ~bb:(aabb (-200.0) (-100.0) 0.0 (100.0));
+
       Renderer.post_draw ren;
 
       Gc.minor ();

src/s2/import.ml

@@ -1,4 +1,4 @@
 include Adam
-module Array1 = Bigarray.Array1
+include Bigarray
 
 include (val Ohlog.logs "S2")

src/s2/renderer.ml

@@ -201,20 +201,26 @@ type texture = {
 
 type pixel_array = (float, Bigarray.float32_elt, Bigarray.c_layout) Array1.t
 
-let make_texture ~size ~format (pixels : pixel_array) =
+let make_texture width height fmt (pixels : pixel_array) =
   Gl.gen_textures 1 Gl._i32;
   let tid = Int32.to_int Gl._i32.{0} in
-  let width, height = size 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 format width height 0 format Gl.float (`Data pixels);
+  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; tsize = size }
+  { tid; tsize = width, height }
+
+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 *)
@@ -224,7 +230,11 @@ type t = {
   gl_ctx : Sdl.gl_context;
 
   polygon : shader;
-  rect : geometry;
+  polygon_rect : geometry;
+
+  sprite : shader;
+  sprite_rect : geometry;
+  (* sprite_instances : vertex_buffer; *)
 }
 
 let unit_square =
@@ -269,12 +279,8 @@ let make ~(wnd : Sdl.window) : t =
   Gl.blend_func Gl.one Gl.one_minus_src_alpha;
   Gl.check_error "setup";
 
-  let polygon =
-    load_shader
-      ~name:"polygon"
-  in
-
-  let rect =
+  let polygon = load_shader ~name:"polygon" in
+  let polygon_rect =
     make_geometry [
       make_static_vertex_buffer unit_square_with_norm [
         attr polygon "Vert" `float 2;
@@ -285,11 +291,25 @@ let make ~(wnd : Sdl.window) : t =
       ~index:(`count 4)
   in
 
+  let sprite = load_shader ~name:"sprite" in
+  let sprite_rect =
+    make_geometry [
+      make_static_vertex_buffer unit_square [
+        attr polygon "Vert" `float 2;
+      ]
+      (* sprite_instances *)
+    ]
+      ~draw_mode:Gl.triangle_strip
+      ~index:(`count 4)
+  in
+
   {
     window = wnd;
     gl_ctx;
     polygon;
-    rect;
+    polygon_rect;
+    sprite;
+    sprite_rect;
   }
 
 let destroy t =
@@ -299,7 +319,8 @@ let pre_draw t =
   let viewport = Sdl.get_window_size t.window in
   begin
     Sdl.gl_make_current_exn t.window t.gl_ctx;
-    set_ivec2 (uniform t.polygon "Viewport") viewport;
+    use t.polygon; set_ivec2 (uniform t.polygon "Viewport") viewport;
+    use t.sprite; set_ivec2 (uniform t.sprite "Viewport") viewport;
   end
 
 let post_draw t =
@@ -313,7 +334,7 @@ let clear _t (bg : color) =
     Gl.clear Gl.color_buffer_bit;
   end
 
-let draw_rect t ~(tf : mat2a) ~(bb : aabb) ~(fill : color) =
+let draw_rect t ~tf ~bb ~fill =
   let sh = t.polygon in
   begin
     (* TODO: cache/store uniform locations in some way *)
@@ -322,5 +343,19 @@ let draw_rect t ~(tf : mat2a) ~(bb : aabb) ~(fill : color) =
     set_aabb  (uniform sh "BoundingBox") bb;
     set_int   (uniform sh "Border") 0;
     set_color (uniform sh "Fill") fill;
-    draw_geometry t.rect;
+    draw_geometry t.polygon_rect;
+  end
+
+let _white = Color.white ()
+
+let draw_texture t ~tf ~bb ?(tint = _white) tex =
+  let sh = t.sprite 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_tex   (uniform sh "Texture") tex;
+    set_color (uniform sh "Tint") tint;
+    draw_geometry t.sprite_rect;
   end

src/s2/s2.mli

@@ -31,7 +31,7 @@ module Renderer : sig
   val post_draw : t -> unit
   val clear : t -> color -> unit
   val draw_rect : t -> tf:mat2a -> bb:aabb -> fill:color -> unit
-  (* val draw_texture : t -> tf:mat2a -> bb:aabb -> tex:Texture.t -> unit *)
+  val draw_texture : t -> tf:mat2a -> bb:aabb -> ?tint:color -> Texture.t -> unit
 end
 
 module Asset : sig

src/s2/texture.ml

@@ -6,60 +6,55 @@ type t = texture
 let width t = fst t.tsize
 let height t = snd t.tsize
 
-let conv_alpha_premultiply ~size ~pitch ~stride src ofs_r ofs_g ofs_b ofs_a =
-  trace (fun m -> m "premultiply alpha: %d,%d,%d,%d,%d,%d,%d,%d"
-                    (fst size) (snd size) pitch stride ofs_r ofs_g ofs_b ofs_a);
-  let width, height = size in
-  let dst = Array1.create Float32 C_layout (width * height * 4) in
+let conv_alpha_premultiply ofs_r ofs_g ofs_b ofs_a src width height =
+  let dst = Array3.create Float32 C_layout height width 4 in
   for y = 0 to height - 1 do
     for x = 0 to width - 1 do
-      let idx = y * pitch + x * stride in
-      let sr = src.{idx + ofs_r} in
-      let sg = src.{idx + ofs_g} in
-      let sb = src.{idx + ofs_b} in
-      let sa = src.{idx + ofs_a} in
-      let i = (y * width + x) * 4 in
-      dst.{i + 0} <- Float.of_int (sr * sa) /. 65025.;
-      dst.{i + 1} <- Float.of_int (sg * sa) /. 65025.;
-      dst.{i + 2} <- Float.of_int (sb * sa) /. 65025.;
-      dst.{i + 3} <- Float.of_int sa        /. 255.;
+      let sr = src.{y, x, ofs_r} in
+      let sg = src.{y, x, ofs_g} in
+      let sb = src.{y, x, ofs_b} in
+      let sa = src.{y, x, ofs_a} in
+      dst.{y, x, 0} <- Float.of_int (sr * sa) /. 65025.;
+      dst.{y, x, 1} <- Float.of_int (sg * sa) /. 65025.;
+      dst.{y, x, 2} <- Float.of_int (sb * sa) /. 65025.;
+      dst.{y, x, 3} <- Float.of_int sa        /. 255.;
     done
   done;
-  make_texture dst ~size ~format:Gl.rgba
+  reshape_1 (genarray_of_array3 dst) (height * width * 4), Gl.rgba
 
-let conv_noalpha ~size ~pitch ~stride src ofs_r ofs_g ofs_b =
-  trace (fun m -> m "no alpha: %d,%d,%d,%d,%d,%d,%d"
-                    (fst size) (snd size) pitch stride ofs_r ofs_g ofs_b);
-  let width, height = size in
-  let dst = Array1.create Float32 C_layout (width * height * 3) in
+let conv_noalpha ofs_r ofs_g ofs_b src width height =
+  let dst = Array3.create Float32 C_layout height width 3 in
   for y = 0 to height - 1 do
     for x = 0 to width - 1 do
-      let idx = (y * pitch) + (x * stride) in
-      let sr = src.{idx + ofs_r} in
-      let sg = src.{idx + ofs_g} in
-      let sb = src.{idx + ofs_b} in
-      let i = (y * width + x) * 3 in
-      dst.{i + 0} <- Float.of_int sr /. 255.;
-      dst.{i + 1} <- Float.of_int sg /. 255.;
-      dst.{i + 2} <- Float.of_int sb /. 255.;
+      let sr = src.{y, x, ofs_r} in
+      let sg = src.{y, x, ofs_g} in
+      let sb = src.{y, x, ofs_b} in
+      dst.{y, x, 0} <- Float.of_int sr /. 255.;
+      dst.{y, x, 1} <- Float.of_int sg /. 255.;
+      dst.{y, x, 2} <- Float.of_int sb /. 255.;
     done
   done;
-  make_texture dst ~size ~format:Gl.rgb
+  reshape_1 (genarray_of_array3 dst) (height * width * 3), Gl.rgb
 
 let pp_pixfmt ppf x = Format.pp_print_string ppf (Sdl.get_pixel_format_name x)
 
 let of_surface srf =
   let pixfmt = Sdl.get_surface_format_enum srf in
-  let size = Sdl.get_surface_size srf in
+  let width, height = Sdl.get_surface_size srf in
+  trace (fun m -> m "converting %dx%d texture from %a" width height pp_pixfmt pixfmt);
   let pitch = Sdl.get_surface_pitch srf in
+  let stride, conv =
+    if Sdl.Pixel.eq pixfmt Sdl.Pixel.format_abgr8888 then
+      4, conv_alpha_premultiply 0 1 2 3
+    else if Sdl.Pixel.eq pixfmt Sdl.Pixel.format_rgb24 then
+      3, conv_noalpha 0 1 2
+    else
+      0, Format.kasprintf failwith "unsupported pixel format %a" pp_pixfmt pixfmt
+  in
   let data = Sdl.get_surface_pixels srf Int8_unsigned in
-  trace (fun m -> m "converting texture from %a" pp_pixfmt pixfmt);
-  if Sdl.Pixel.eq pixfmt Sdl.Pixel.format_abgr8888 then
-    conv_alpha_premultiply data ~size ~pitch ~stride:4 0 1 2 3
-  else if Sdl.Pixel.eq pixfmt Sdl.Pixel.format_rgb24 then
-    conv_noalpha data ~size ~pitch ~stride:3 0 1 2
-  else
-    Format.kasprintf failwith "unsupported pixel format %a" pp_pixfmt pixfmt
+  let src = reshape_3 (genarray_of_array1 data) height (pitch / stride) stride in
+  let dst, fmt = conv src width height in
+  make_texture width height fmt dst
 
 let of_surface_free srf =
   try
@@ -75,10 +70,8 @@ module Asset = struct
     trace (fun m -> m "open image %S" path);
     try
       match Sdl.Image.load (absolute_path path) with
-      | Ok srf ->
-        of_surface_free srf
-      | Error (`Msg msg) ->
-        failwith msg
+      | Ok srf -> of_surface_free srf
+      | Error (`Msg msg) -> failwith msg
     with
       Failure msg -> raise (Error (path, msg))
 end