Source file texture.ml

(*********************************************************************************)
(*                OCaml-Stk                                                      *)
(*                                                                               *)
(*    Copyright (C) 2023-2024 INRIA All rights reserved.                         *)
(*    Author: Maxence Guesdon, INRIA Saclay                                      *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU General Public License as                    *)
(*    published by the Free Software Foundation, version 3 of the License.       *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the               *)
(*    GNU General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public                  *)
(*    License along with this program; if not, write to the Free Software        *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    As a special exception, you have permission to link this program           *)
(*    with the OCaml compiler and distribute executables, as long as you         *)
(*    follow the requirements of the GNU GPL in regard to all of the             *)
(*    software in the executable aside from the OCaml compiler.                  *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

open Tsdl
open Misc

include (val Log.create_src "stk.texture")

let finalise_sdl_texture t =
  Gc.finalise (fun t ->
     (*prerr_endline "destroying texture";*)
     Tsdl.Sdl.destroy_texture t) t

let finalise_sdl_surface s =
  Gc.finalise (fun s ->
     (*prerr_endline "freeing surface";*)
     Tsdl.Sdl.free_surface s) s

let finalise t =
  (*Gc.finalise_last (fun () -> prerr_endline "finalising Texture.t") t*) 
  ()

type t =
  { tw: int ;
    th : int ;
    format : Sdl.Pixel.format_enum ;
    access : Sdl.Texture.access ;
    w: int ;
    h: int ;
    a: Sdl.texture array array ;
  }

let on_textures f t =
  Array.iter (fun t -> Array.iter f t) t.a

let destroy t =
  ()(*on_textures Sdl.destroy_texture t*)

let cpt = ref 0

let max_texture_size = ref (Some (1000, 1000))

let create ?(format=Sdl.Pixel.format_rgba8888)
    ?(access=Sdl.Texture.access_target) renderer ~w ~h =
   (*incr cpt ;
   if !cpt mod 100 = 0 then
     Log.info (fun m -> m "Texture.create called %d times" !cpt);*)
   (* By now we keep small textures, since using larger ones
      seems to make SDL leak more memory *)
  let tw, th =
    match !max_texture_size with
    | None ->
        let> i = Sdl.get_renderer_info renderer in
        let tw = i.ri_max_texture_width in
        let th = i.ri_max_texture_height in
        (* software renderer returns 0 to indicate no limit *)
        let tw = if tw = 0 then 100_000 (*max_int*) else tw in
        let th = if th = 0 then 100_000 (*max_int*) else th in
        (tw, th)
    | Some (w, h) -> (w, h)
  in
  let size x tx = (x/tx) + if x mod tx = 0 then 0 else 1 in
  let a =
    Array.init (size w tw)
      (fun i ->
         Array.init (size h th)
           (fun j ->
              let w = min tw (w - i * tw) in
              let h = min th (h - j * th) in
              let> t = Sdl.create_texture renderer format access ~w ~h in
              finalise_sdl_texture t ;
              Sdl.set_texture_blend_mode t Sdl.Blend.mode_blend ;
              t
           )
      )
  in
  let t = { tw ; th ; format ; access ; w ; h; a } in
  finalise t ;
  t

let set_blend_mode t m =
  on_textures (fun t -> let> () = Sdl.set_texture_blend_mode t m in ()) t

let set_alpha_mod t m =
  on_textures (fun t -> let> () = Sdl.set_texture_alpha_mod t m in ()) t

let set_color_mod t r g b =
  on_textures (fun t -> let> () = Sdl.set_texture_color_mod t r g b in ()) t

let from_texture renderer tex =
  let> i = Sdl.get_renderer_info renderer in
  let> (format, access, (w,h)) = Sdl.query_texture tex in
  let a = Array.make 1 (Array.make 1 tex) in
  let t = { tw = w ; th = h ; format ; access ; w ; h ; a } in
  finalise t;
  set_blend_mode t Sdl.Blend.mode_blend ;
  t

let from_scaled_texture rend ~w ~h tex =
  debug (fun m  -> m "Texture.from_scaled_texture w=%d, h=%d" w h);
  let> (format, access, (w0,h0)) = Sdl.query_texture tex in
  let> tex2 = Sdl.(create_texture rend format Texture.access_target ~w ~h) in
  finalise_sdl_texture tex2 ;
  let src = Sdl.Rect.create ~x:0 ~y:0 ~w:w0 ~h:h0 in
  let dst = Sdl.Rect.create ~x:0 ~y:0 ~w ~h in
  Render.with_target rend
    (fun rend -> Sdl.render_copy ~src ~dst rend tex)
    (Some tex2);
  let a = Array.make 1 (Array.make 1 tex2) in
  let t = { tw = w ; th = h ; format ; access ; w ; h ; a } in
  finalise t;
  set_blend_mode t Sdl.Blend.mode_blend ;
  t

let query t = Ok (t.format, t.access, (t.w, t.h))

let from_surface renderer surface =
  let> tex = Sdl.create_texture_from_surface renderer surface in
  finalise_sdl_texture tex ;
  (*
  let> (pix_format,_,_) = Sdl.query_texture tex in
  warn (fun m -> m "tex pix format=%s, surface=%s"
    (Sdl.get_pixel_format_name pix_format)
    (Sdl.get_pixel_format_name (Sdl.get_surface_format_enum surface)));*)
  from_texture renderer tex

let with_renderer f rend =
  let old_t = Sdl.get_render_target rend in
  let> (r,g,b,a) = Sdl.get_render_draw_color rend in
  let res =
    try Ok (f rend)
    with e -> Error e
  in
  Sdl.set_render_target rend old_t;
  let> () = Sdl.set_render_draw_color rend r g b a in
  match res with
  | Ok x -> x
  | Error e -> raise e

let of_g t (g : G.t) =
  if g.w = 0 || g.h = 0
    || g.x >= t.w
    || g.y >= t.h
  then
    []
  else
    (
     let res = ref [] in
     let i_start = g.x / t.tw in
     let i_stop =
       let x2 = min t.w (g.x + g.w) - 1  in
       x2 / t.tw
     in
     let j_start = g.y / t.th in
     let j_stop =
       let y2 = min t.h (g.y + g.h) - 1 in
       y2 / t.th
     in
     debug (fun m -> m "Texture.of_g: g=%a, i={%d..%d}, j={%d..%d} t.w=%d t.h=%d t.tw=%d t.th=%d"
        G.pp g i_start i_stop j_start j_stop t.w t.h t.tw t.th);
     debug (fun m -> m "Texture.of_g: t: i=0..%d, j=0..%d"
        (Array.length t.a - 1)
          (if Array.length t.a > 0 then (Array.length t.a.(0) - 1) else -1));

     for i = i_start to i_stop do
       let x = max 0 (g.x - i * t.tw) in
       let w =
         let x2 = (min (g.x + g.w) ((i+1) * t.tw)) - i * t.tw in
         x2 - x
       in
       for j = j_start to j_stop do
         let y = max 0 (g.y - j * t.th) in
         let h =
           let y2 = (min (g.y + g.h) ((j+1) * t.th)) - j * t.th in
           y2 - y
         in
         let r = { G.x ; y ; w ; h } in
         let tex_r =
           let x = i * t.tw in
           let y = j * t.th in
           let w = min t.tw (t.w - x) in
           let h = min t.th (t.h - y) in
           { G.x ; y ; w ; h }
         in
         res := (r, tex_r, t.a.(i).(j)) :: !res
       done
     done;
     info (fun m -> m "Texture.of_g: g=%a" G.pp g);
     let l = List.rev !res in
     List.iter (fun (r,t,_) ->
        info (fun m -> m "Texture.of_g: => r=%a, tex_r=%a" G.pp r G.pp t))
       l;
     l
    )
let fill_rect_ rend t rect color =
  let> () = Render.set_draw_color rend color in
  match rect with
  | None ->
      debug (fun m -> m "Texture.fill_rect_ None");
      on_textures
        (fun tex ->
           Sdl.set_render_target rend (Some tex) ;
           let> () = Sdl.render_fill_rect rend None in ()) t
  | Some g ->
      debug (fun m -> m "Texture.fill_rect_ Some g = %a" G.pp g);
      let l = of_g t g in
      debug (fun m -> m "Texture.fill_rect_ of_g ok");
      List.iter
        (fun (g, _, tex) ->
           let r = G.to_rect g in
           Sdl.set_render_target rend (Some tex) ;
           let> () = Sdl.render_fill_rect rend (Some r) in ())
          l

let fill_rect rend t rect color =
  with_renderer (fun rend -> fill_rect_ rend t rect color) rend

let draw_line_ rend t x1 y1 x2 y2 =
  warn (fun m -> m "Texture.draw_line_ not implemented")

let draw_line_color_ rend t x1 y1 x2 y2 color =
  let> () = Render.set_draw_color rend color in
  draw_line_ rend t x1 y1 x2 x2

let draw_rect_ rend t ~x ~y ~w ~h color =
  let rects =
    [ { G.x ; y ; w ; h = 1 } ;
      { x = x + w - 1; y ; w = 1 ; h } ;
      { x ; y = y + h - 1 ; w ; h = 1 } ;
      { x ; y ; w = 1 ; h } ;
    ]
  in
  debug (fun m -> m "Texture.draw_rects");
  List.iter (fun r ->
     debug (fun m -> m "%a" G.pp r)) rects;

  List.iter (fun r -> fill_rect_ rend t (Some r) color) rects

let draw_rect_r_ rend t r color =
  draw_rect_ rend t ~x:r.G.x ~y:r.y ~w:r.w ~h:r.h color

let draw_rect rend t ~x ~y ~w ~h color =
  with_renderer (fun rend -> draw_rect_ rend t ~x ~y ~w ~h color) rend
let draw_rect_r rend t r color =
  with_renderer (fun rend -> draw_rect_r_ rend t r color) rend

let draw_point rend t ~x ~y color =
   draw_rect_ rend t ~x ~y ~w:1 ~h:1 color

let clear_ rend t =
  let> () = Render.set_draw_color rend (Color.of_rgba 0 0 0 0) in
  let f tex =
    Sdl.set_render_target rend (Some tex);
    let> () = Sdl.render_clear rend in
    ()
  in
  on_textures f t

let clear rend t = with_renderer (fun rend -> clear_ rend t) rend

let render_copy ~src ~dst rend t =
  debug (fun m -> m "Texture.render_copy src=%a dst=%a"
    G.pp src G.pp dst);
  debug (fun m ->
    match Sdl.get_render_target rend with
    | None -> ()
    | Some tex ->
        let> (_,_,(w,h)) = Sdl.query_texture tex in
        if  dst.w > w || dst.h > h
        then
           m "render_copy: src=%a, dst=%a, texture(w,h)=%d,%d"
            G.pp src G.pp dst w h);

  let coeff_w = float src.G.w /. float dst.G.w in
  let coeff_h = float src.h /. float dst.h in
  let l = of_g t src in
  let rec iter = function
  | [] -> ()
  | (s,gt,tex) :: q ->
      let d =
        let x = dst.x + (gt.G.x + s.G.x - src.x) in
        let y = dst.y + (gt.y + s.y - src.y) in
        {
          G.x = x ;
          y = y ;
          w = truncate (float s.G.w /. coeff_w) ;
          h = truncate (float s.h /. coeff_h) ;
        }
      in
      debug (fun m -> m "Texture.render_copy s=%a, d=%a"
         G.pp s G.pp d);

      let src = G.to_rect s in
      let dst = G.to_rect d in
      let>() = Sdl.render_copy rend ~src ~dst tex in
      iter q
  in
  iter l

let copy_texture rend ~from ~src ~x ~y t =
  let> () = Sdl.set_render_target rend (Some t) in
  let> () = Sdl.render_copy rend
    ~src:(G.to_rect src) ~dst:(G.to_rect { src with x ; y })
    from
  in
  ()

let copy rend ~from ~(src:G.t) ~x ~y t =
  (*let> (_,_,(w,h)) = query from in
  let src = { src with w = min src.w w ; h = min src.h h } in
*)
  let pp = G.pp in
  info
    (fun m -> m "Texture.copy src=%a, x=%d, y=%d"
      pp src x y);
  let srcs = of_g from src in
  let dst = { src with x ; y } in
  let dsts = of_g t dst in
  let f rend (gr1,gt1,t1) (gr2,gt2,t2) =
    info
      (fun m -> m "Texture.copy f\ngr1=%a, gt1=%a\ngr2=%a, gt2=%a"
        pp gr1 pp gt1 pp gr2 pp gt2);
    let trans_x1 = gt1.G.x + gr1.G.x - src.x in
    let trans_y1 = gt1.y + gr1.y - src.y in
    let trans_x2 = gt2.G.x + gr2.G.x - x in
    let trans_y2 = gt2.y + gr2.y - y in
    let r1 = { gr1 with x = trans_x1 ; y = trans_y1 } in
    let r2 = { gr2 with x = trans_x2 ; y = trans_y2 } in
    info
      (fun m -> m "Texture.copy r1=%a, r2=%a" pp r1 pp r2);
    match G.inter r1 r2 with
    | Some i when i.w > 0 && i.h > 0 ->
        let src = { i with
            G.x = gr1.x + i.x - trans_x1 ;
            y = gr1.y + i.y - trans_y1 ;
          }
        in
        let x = gr2.x + i.x - trans_x2 in
        let y = gr2.y + i.y - trans_y2 in
        info (fun m -> m
          "COPY i=%a, src=%a, x=%d, y=%d" pp i pp src x y);
        copy_texture rend ~from:t1 ~src ~x ~y t2
    | _ -> (* nothing to copy *)
        ()
  in
  with_renderer
    (fun rend ->
      List.iter
         (fun r_src -> List.iter (f rend r_src) dsts) srcs)
    rend