Source file image.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                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Image widget. *)

open Tsdl
open Tsdl_image
open Misc

(** Property ["image-keep-ratio"] to indicate whether image ratio must be
  perserved. Default is [true].
  Keeping ratio means that when width is set with
  {{!image.set_width}image#set_width}, height of rendered image will
  be set accordingly.
  If height is set with {{!image.set_height}image#set_height}, width or rendered image
  will be set accordingly.
*)
let keep_ratio = Props.(bool_prop
   ~after:[Resize] ~default:true ~inherited:false "image_keep_ratio")
let css_keep_ratio = Theme.bool_prop keep_ratio

(** Property ["image-autosize"] to indicate whether image must fit in
  allocated geometry. Default is [false].*)
let autosize = Props.(bool_prop
   ~after:[Resize] ~default:false ~inherited:false "image_autosize")
let css_autosize = Theme.bool_prop autosize

(** A widget to display an image. *)
class image ?classes ?name ?props ?wdata () =
  object(self)
    inherit Widget.widget ?classes ?name ?props ?wdata () as super
    (**/**)
    val mutable surface = None
    val mutable image_texture = None
    val mutable ratio = None
    val mutable last_set = (None : [`W | `H] option)
    method kind = "image"
    (**/**)

    (** {2 Properties} *)

    method width = self#opt_p Props.width
    method set_width w =
      self#destroy_image_texture ;
      (match self#keep_ratio, ratio with
       | true, Some r ->
           let h = truncate (float w /. r) in
           Props.set props Props.height h
       | _, _ -> ()
      );
      last_set <- Some `W;
      self#set_p Props.width w;
      self#need_render ~layer:self#layer g

    method height = self#opt_p Props.height
    method set_height h =
      self#destroy_image_texture ;
      (match self#keep_ratio, ratio with
       | true, Some r ->
           let w = truncate (float h *. r) in
           Props.set props Props.width w
       | _, _ -> ()
      );
      last_set <- Some `H;
      self#set_p Props.height h;
      self#need_render ~layer:self#layer g

    method keep_ratio = self#get_p keep_ratio
    method set_keep_ratio = self#set_p keep_ratio

    method autosize = self#get_p autosize
    method set_autosize = self#set_p autosize

    (**/**)
    method destroy_image_texture =
      match image_texture with
      | None -> ()
      | Some t -> Texture.destroy t; image_texture <- None

    method! min_width_ =
      if self#autosize then
        0
      else
        match self#width with
        | Some x -> x
        | None ->
            match surface with
            | None -> 0
            | Some s -> fst (Tsdl.Sdl.get_surface_size s)

    method! min_height_ =
      if self#autosize then
        0
      else
        match self#height with
        | Some x -> x
        | None ->
            match surface with
            | None -> 0
            | Some s -> snd (Tsdl.Sdl.get_surface_size s)

    method! max_width = if self#autosize then None else Some self#min_width
    method! max_height = if self#autosize then None else Some self#min_height

    (**/**)

    (** Returns orignal (width, height) of image, if an image is loaded. *)
    method image_size = Option.map Tsdl.Sdl.get_surface_size surface

    (**/**)
    method private update_from_ratio =
      match last_set, ratio with
      | None, _
      | _, None -> ()
      | Some `H, Some r ->
          (match self#height with
           | None -> ()
           | Some h ->
               let w = truncate (float h *. r) in
               Props.set props Props.width w
          )
      | Some `W, Some r ->
          (match self#width with
           | None -> ()
           | Some w ->
               let h = truncate (float w /. r) in
               Props.set props Props.height h
          )

    method private set_surface s =
      self#destroy_surface ;
      surface <- Some s;
      let (w,h) = Tsdl.Sdl.get_surface_size s in
      ratio <- Some (float w /. float h);
      if self#keep_ratio then self#update_from_ratio ;
      self#need_resize

    method! set_geometry geom =
      let old_g = g in
      super#set_geometry geom;
      match self#autosize with
      | false -> ()
      | true when old_g = g -> ()
      | true ->
          match self#keep_ratio, ratio with
          | false, _ ->
              self#set_width g_inner.w ;
              self#set_height g_inner.h
          | _, None -> ()
          | true, Some r when r >= 1. ->
              self#set_width g_inner.w ;
              Option.iter
                (fun h -> if h > g_inner.h then
                     self#set_height g_inner.h)
                self#height
          | true, Some r ->
              self#set_height g_inner.h ;
              Option.iter
                (fun w -> if w > g_inner.w then
                     self#set_width g_inner.w)
                self#width

    (**/**)

    (** Load image from rw operations.
        Beware that this may be a io-blocking operation. *)
    method load_rw rw =
      match Image.load_rw rw true with
      | Error (`Msg msg) ->
          Log.err (fun m -> m "%s: Could not load image from data: %s" self#me msg)
      | Ok s ->
          Gc.finalise (fun s -> Tsdl.Sdl.free_surface s) s;
          self#set_surface s

    (** Load image from file.
        Beware that this is a io-blocking operation. *)
    method load_file file =
      match Image.load file with
      | Error (`Msg msg) ->
          Log.err (fun m -> m "%s: Could not load image from %S: %s" self#me file msg)
      | Ok s ->
          Gc.finalise (fun s -> Tsdl.Sdl.free_surface s) s;
          self#set_surface s

    (** Return the (unscaled) image surface, if any.*)
    method surface = surface

    (**/**)
    method destroy_surface =
      (match surface with
      | None -> ()
      | Some s -> surface <- None);
      self#destroy_image_texture

    method! render_me ~layer rend ~offset geom =
      super#render_with_prepare ~layer rend ~offset geom

    method! prepare ~(layer:Layer.t) (rend:Sdl.renderer) (geom:G.t) =
      if layer = self#get_p Props.layer then
        (match self#image_texture rend with
         | None -> [%debug "%s#render_me: no texture" self#me]; None
         | Some t -> Some t
        )
      else
        None

    method private image_texture rend =
      match image_texture with
      | None ->
          if g_inner.w > 0 && g_inner.h > 0 then
            (
             match surface with
             | None -> None
             | Some s ->
                 let t =
                   match self#width, self#height with
                   | None, None -> (* no scaling *)
                       Texture.from_surface rend s
                   | _ ->
                       let (w0,h0) = Tsdl.Sdl.get_surface_size s in
                       let> t = Sdl.create_texture_from_surface rend s in
                       Texture.finalise_sdl_texture t ;
                       let w = Option.value ~default:w0 self#width in
                       let h = Option.value ~default:h0 self#height in
                       Texture.from_scaled_texture rend ~w ~h t
                 in
                 image_texture <- Some t ;
                 image_texture
            )
          else
            None
      | x -> x

  end


(** Convenient function to create a {!class-image}.
  Optional arguments:
  {ul
   {- [width] specifies width of rendered image.}
   {- [height] specifies height of renderer image.}
   {- [file] specifies a file to load an image from.}
   {- [keep_ratio] specifies the {!val-keep_ratio} property.}
   {- [autosize] specifies the {!val-autosize} property.}
  }
  See {!Widget.widget_arguments} for other arguments. *)
let image ?classes ?name ?props ?wdata ?width ?height ?keep_ratio ?autosize ?file ?pack () =
  let w = new image ?classes ?name ?props ?wdata () in
  Option.iter w#set_keep_ratio keep_ratio ;
  Option.iter w#set_autosize autosize ;
  Option.iter w#set_width width ;
  Option.iter w#set_height height ;
  Option.iter w#load_file file ;
  Widget.may_pack ?pack w ;
  w