add loading textures from sdl surfaces

src/main.ml

@@ -8,16 +8,21 @@ include (val Ohlog.logs "Main")
 
 let main () =
   debug (fun m -> m "initializing");
-  let window = Window.make ~title:"GEOMETRA" in
+  let wnd = Window.make ~title:"GEOMETRA" in
   info (fun m -> m "window initialized");
-  let ren = Renderer.make ~window in
+  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));
+  debug (fun m -> m "loaded assets");
+
   let tg = TG.make () in
   let sg = SG.make () in
 
   let scene = Scene.load "main" ~tg ~sg in
   let root = Scene.get scene "root" in
+  debug (fun m -> m "loaded scene");
 
   let render time =
     begin
@@ -45,16 +50,16 @@ let main () =
       Gc.minor ();
     end
   in
-  Window.event_loop window ~render;
+  Window.event_loop wnd ~render;
 
   begin
     info (fun m -> m "quitting");
-    Window.destroy window;
+    Window.destroy wnd;
     Renderer.destroy ren;
   end
 
 let () =
-  Ohlog.init () ~min_level:DEBUG;
+  Ohlog.init () ~min_level:TRACE;
 
   try main () with
   | Sdl.Error msg -> error (fun m -> m "SDL error: %s" msg)

src/s2/asset.ml

@@ -3,14 +3,13 @@ include (val Ohlog.sublogs logger "asset")
 
 exception Error of string * string
 
+let absolute_path path =
+  Unix.realpath (Printf.sprintf "assets/%s" path)
+
 let load_file path =
   trace (fun m -> m "open text file %S" path);
-  let abspath =
-    Unix.realpath
-      (Printf.sprintf "assets/%s" path)
-  in
   let fd =
-    try Unix.openfile abspath [O_RDONLY] 0
+    try Unix.openfile (absolute_path path) [O_RDONLY] 0
     with Unix.Unix_error (ENOENT, _, _) ->
       raise (Error (path, "not found"))
   in

src/s2/dune

@@ -6,5 +6,6 @@
 
    ohlog
    tsdl
+   tsdl-image
    tgls.tgl4
    sexplib))

src/s2/renderer.ml

@@ -1,6 +1,8 @@
 open! Import
 include (val Ohlog.sublogs logger "Ren")
 
+type ivec2 = int * int
+
 
 (* Buffer *)
 
@@ -129,7 +131,7 @@ let uniform {spo} name =
 type 'a set_fn = 'a uniform -> 'a -> unit
 
 let set_int : int set_fn = fun (U l) x -> Gl.uniform1i l x
-let set_ivec2 : (int*int) set_fn = fun (U l) (x, y) -> Gl.uniform2i l x y
+let set_ivec2 : ivec2 set_fn = fun (U l) (x, y) -> Gl.uniform2i l x y
 let set_color : color set_fn = fun (U l) c -> Gl.uniform4f l c.r c.g c.b c.a
 let set_aabb : aabb set_fn = fun (U l) b -> Gl.uniform4f l b.x0 b.y0 b.x1 b.y1
 
@@ -190,6 +192,31 @@ let draw_geometry ?(instances = 1) { vao; draw_mode; indices } =
     Gl.draw_elements_instanced draw_mode n type_ offset instances
 
 
+(* Texture *)
+
+type texture = {
+  tid : int;
+  tsize : ivec2;
+}
+
+type pixel_array = (float, Bigarray.float32_elt, Bigarray.c_layout) Array1.t
+
+let make_texture ~size ~format (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.generate_mipmap Gl.texture_2d;
+  Gl.bind_texture Gl.texture_2d 0;
+  { tid; tsize = size }
+
+
 (* Renderer *)
 
 type t = {
@@ -232,10 +259,10 @@ let unit_square_with_norm =
     [| 0.; 1.; -1.;  1. |];
   ]
 
-let make ~(window : Sdl.window) : t =
+let make ~(wnd : Sdl.window) : t =
   debug (fun m -> m "initializing");
-  let gl_ctx = Sdl.gl_create_context_exn window in
-  Sdl.gl_make_current_exn window gl_ctx;
+  let gl_ctx = Sdl.gl_create_context_exn wnd in
+  Sdl.gl_make_current_exn wnd gl_ctx;
   Sdl.gl_set_swap_interval_exn 1;
 
   Gl.enable Gl.blend;
@@ -259,7 +286,7 @@ let make ~(window : Sdl.window) : t =
   in
 
   {
-    window;
+    window = wnd;
     gl_ctx;
     polygon;
     rect;

src/s2/s2.ml

@@ -1,5 +1,9 @@
 module Window = Window
-module Asset = Asset
 module Renderer = Renderer
+module Texture = Texture
+module Asset = struct
+  include Asset
+  include Texture.Asset
+end
 module Sdl = Sdl
 module Gl = Gl

src/s2/s2.mli

@@ -14,17 +14,24 @@ module Window : sig
   val event_loop : t -> render:(float -> unit) -> unit
 end
 
+module Texture : sig
+  type t
+  val width : t -> int
+  val height : t -> int
+end
+
 module Renderer : sig
   open Adam
 
   type t
-  val make : window:Window.t -> t
+  val make : wnd:Window.t -> t
   val destroy : t -> unit
 
   val pre_draw : t -> unit
   val post_draw : t -> unit
   val clear : t -> color -> unit
   val draw_rect : t -> tf:mat2a -> bb:aabb -> fill:color -> unit
+  (* val draw_texture : t -> tf:mat2a -> bb:aabb -> tex:Texture.t -> unit *)
 end
 
 module Asset : sig
@@ -34,4 +41,5 @@ module Asset : sig
 
   val load_file : string -> string
   val load_sexp_conv : string -> (Sexp.t -> 'a) -> 'a
+  val load_texture : string -> Texture.t
 end

src/s2/sdl.ml

@@ -1,5 +1,6 @@
 open! Import
 include Tsdl.Sdl
+include Tsdl_image
 
 exception Error of string
 

src/s2/texture.ml

@@ -0,0 +1,84 @@
+open Import
+open Renderer
+
+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
+  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.;
+    done
+  done;
+  make_texture dst ~size ~format: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
+  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.;
+    done
+  done;
+  make_texture dst ~size ~format: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 pitch = Sdl.get_surface_pitch srf 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 of_surface_free srf =
+  try
+    let tex = of_surface srf in
+    Sdl.free_surface srf; tex
+  with e ->
+    Sdl.free_surface srf; raise e
+
+module Asset = struct
+  open Asset
+
+  let load_texture path =
+    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
+    with
+      Failure msg -> raise (Error (path, msg))
+end