81 lines
3.0 KiB
OCaml
81 lines
3.0 KiB
OCaml
open Import
|
|
include (val Ohlog.sublogs logger "Texture")
|
|
|
|
type t = Renderer.texture
|
|
|
|
let conv_alpha_no_multiply 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 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 /. 255.;
|
|
dst.{y, x, 1} <- Float.of_int sg /. 255.;
|
|
dst.{y, x, 2} <- Float.of_int sb /. 255.;
|
|
dst.{y, x, 3} <- Float.of_int sa /. 255.;
|
|
done
|
|
done;
|
|
reshape_1 (genarray_of_array3 dst) (height * width * 4), Gl.rgba
|
|
|
|
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 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;
|
|
reshape_1 (genarray_of_array3 dst) (height * width * 4), Gl.rgba
|
|
|
|
let conv_alpha premul ofs_r ofs_g ofs_b ofs_a src width height =
|
|
if premul then conv_alpha_premultiply ofs_r ofs_g ofs_b ofs_a src width height
|
|
else conv_alpha_no_multiply ofs_r ofs_g ofs_b ofs_a src width height
|
|
|
|
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 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;
|
|
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 ?(premultiply_alpha = true) srf =
|
|
let pixfmt = Sdl.get_surface_format_enum 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_alpha 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
|
|
let src = reshape_3 (genarray_of_array1 data) height (pitch / stride) stride in
|
|
let dst, fmt = conv src width height in
|
|
Renderer.make_texture width height fmt dst
|
|
|
|
module Asset = struct
|
|
let load_texture ?premultiply_alpha path =
|
|
Asset.load_image path
|
|
(of_surface ?premultiply_alpha)
|
|
end
|