refactor texture munching to use Array3 and reshape

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,9 +45,13 @@ let main () =
       TG.update tg;
       SG.render sg ~ren;
 
-      Renderer.draw_texture ren cat
+      Renderer.draw_texture ren tex_otters
         ~tf
-        ~bb:(aabb 0.0 0.0 (200.0) (200.0));
+        ~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;
 

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,19 @@ 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; _ } ->

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