refactor texture munching to use Array3 and reshape

This commit is contained in:
tali 2024-01-19 16:56:04 -05:00
parent 2855edbb81
commit 99d136c1e3
4 changed files with 47 additions and 51 deletions

View File

@ -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;

View File

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

View File

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

View File

@ -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