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