Source file image.ml

(** 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 ~inherits:false "image-keep-ratio")

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

    (** {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

    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

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

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

    method! min_width_ =
      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_ =
      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 = Some self#min_width
    method! max_height = 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

    (**/**)

    (** 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 -> 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 -> self#set_surface s

    (**/**)
    method destroy_surface =
      (match surface with
      | None -> ()
      | Some s -> Sdl.free_surface 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 -> Log.warn (fun m -> m "%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
                       let w = Option.value ~default:w0 self#width in
                       let h = Option.value ~default:h0 self#height in
                       Texture.from_scaled_texture rend ~destroy_orig:true ~w ~h t
                 in
                 image_texture <- Some t ;
                 image_texture
            )
          else
            None
      | x -> x

    initializer
      Gc.finalise (fun o -> o#destroy_surface) self
  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.}
  }
  See {!Widget.widget_arguments} for other arguments. *)
let image ?class_ ?name ?props ?width ?height ?keep_ratio ?file ?pack () =
  let w = new image ?class_ ?name ?props () in
  Option.iter w#set_keep_ratio keep_ratio ;
  Option.iter w#set_width width ;
  Option.iter w#set_height height ;
  Option.iter w#load_file file ;
  Widget.may_pack ?pack w ;
  w