add premultiply_alpha bool to load_texture

src/s2/sprite.ml

@@ -77,7 +77,7 @@ module Asset = struct
   let load_sprite_map ?dpi name =
     let tex_path = Format.sprintf "sprites/%s.png" name in
     let map_path = Format.sprintf "sprites/%s.map" name in
-    let texture = Texture.load_texture tex_path in
+    let texture = Texture.Asset.load_texture tex_path in
     let spritemap = Asset.load_sexp_conv map_path (of_sexp ~texture ?dpi) in
     debug (fun m -> m "loaded sprite map %S" name);
     trace (fun m ->

src/s2/texture.ml

@@ -3,6 +3,22 @@ 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
@@ -19,6 +35,10 @@ let conv_alpha_premultiply ofs_r ofs_g ofs_b ofs_a src width height =
   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
@@ -35,14 +55,14 @@ let conv_noalpha ofs_r ofs_g ofs_b src width height =
 
 let pp_pixfmt ppf x = Format.pp_print_string ppf (Sdl.get_pixel_format_name x)
 
-let of_surface srf =
+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 0 1 2 3
+      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
@@ -53,18 +73,20 @@ let of_surface srf =
   let dst, fmt = conv src width height in
   Renderer.make_texture width height fmt dst
 
-let of_surface_free srf =
+let of_surface_free ?premultiply_alpha srf =
   try
-    let tex = of_surface srf in
+    let tex = of_surface srf ?premultiply_alpha in
     Sdl.free_surface srf; tex
   with e ->
     Sdl.free_surface srf; raise e
 
-let load_texture path =
+module Asset = struct
-  trace (fun m -> m "open image %S" path);
+  let load_texture ?premultiply_alpha path =
-  try
+    trace (fun m -> m "open image %S" path);
-    match Sdl.Image.load (Asset.absolute_path path) with
+    try
-    | Ok srf -> of_surface_free srf
+      match Sdl.Image.load (Asset.absolute_path path) with
-    | Error (`Msg msg) -> failwith msg
+      | Ok srf -> of_surface_free ?premultiply_alpha srf
-  with
+      | Error (`Msg msg) -> failwith msg
-    Failure msg -> raise (Asset.Error (path, msg))
+    with
+      Failure msg -> raise (Asset.Error (path, msg))
+end