From 635d7423631c99b5ba9a21c9e32e650fa890b615 Mon Sep 17 00:00:00 2001 From: tali Date: Fri, 19 Jan 2024 16:03:50 -0500 Subject: [PATCH] add loading textures from sdl surfaces --- src/main.ml | 15 ++++++--- src/s2/asset.ml | 9 +++-- src/s2/dune | 1 + src/s2/renderer.ml | 37 +++++++++++++++++--- src/s2/s2.ml | 6 +++- src/s2/s2.mli | 10 +++++- src/s2/sdl.ml | 1 + src/s2/texture.ml | 84 ++++++++++++++++++++++++++++++++++++++++++++++ 8 files changed, 146 insertions(+), 17 deletions(-) create mode 100644 src/s2/texture.ml diff --git a/src/main.ml b/src/main.ml index 70a0d4e..40010c3 100644 --- a/src/main.ml +++ b/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) diff --git a/src/s2/asset.ml b/src/s2/asset.ml index d9cd273..ae42efb 100644 --- a/src/s2/asset.ml +++ b/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 diff --git a/src/s2/dune b/src/s2/dune index ef1b595..b3b6bb2 100644 --- a/src/s2/dune +++ b/src/s2/dune @@ -6,5 +6,6 @@ ohlog tsdl + tsdl-image tgls.tgl4 sexplib)) diff --git a/src/s2/renderer.ml b/src/s2/renderer.ml index b2d3ce9..88926e9 100644 --- a/src/s2/renderer.ml +++ b/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; diff --git a/src/s2/s2.ml b/src/s2/s2.ml index 87a688c..4cd257e 100644 --- a/src/s2/s2.ml +++ b/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 diff --git a/src/s2/s2.mli b/src/s2/s2.mli index 5e608dc..38ed3e4 100644 --- a/src/s2/s2.mli +++ b/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 diff --git a/src/s2/sdl.ml b/src/s2/sdl.ml index df32bcd..90e45d0 100644 --- a/src/s2/sdl.ml +++ b/src/s2/sdl.ml @@ -1,5 +1,6 @@ open! Import include Tsdl.Sdl +include Tsdl_image exception Error of string diff --git a/src/s2/texture.ml b/src/s2/texture.ml new file mode 100644 index 0000000..7b81ab0 --- /dev/null +++ b/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