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

(** Simple widgets to display text. *)

open Misc
open Tsdl
open Tsdl_ttf
open Widget

[@@@landmark "auto"]

(**/**)

(* return pos of previous character if we are less than x
  pixels after its end. *)
let previous_char_offset = 5
let pos_from_x font text x =
  [%debug "pos_from_x text=%S x=%d" text x];
  if x < 0 then
    0
  else
    let> (w,_) = Ttf.size_utf8 font text in
    if x >= w then
      Utf8.length text
    else
      let rec iter acc text w x =
        if x <= w then
          let len = Utf8.length text in
          if len <= 0 then
            acc
          else
            match Utf8.sub text ~pos:0 ~len:(len/2) with
            | "" -> if x > 0 then acc+1 else acc
            | left ->
                let> (wl,_) = Ttf.size_utf8 font left in
                if x <= wl then
                  iter acc left wl x
                else
                  let right = Utf8.sub text ~pos:(len/2) ~len:(len-(len/2)) in
                  let> (wr,_) = Ttf.size_utf8 font right in
                  iter (acc + len/2) right wr (x-wl)
        else
          acc
      in
      iter 0 text w (x - previous_char_offset)

(**/**)

(** Class used internally to cache text rendering. *)
class textured_text () =
  object(self)
    val mutable surface = (None : Sdl.surface option)
    val mutable texture = (None : Texture.t option)
    method texture rend =
      match texture with
      | Some t -> Some t
      | None ->
          match surface with
          | None -> None
          | Some s ->
              let t = Texture.from_surface rend s in
              texture <- Some t;
              texture

    val mutable size = (0, 0)
    method size = size

    val mutable data = None
    method redraw_if_changed color text =
      match data with
      | None -> ()
      | Some (font, c, t) ->
          if c <> color || t <> text then
            self#set_text font color text

    method destroy_texture =
      match texture with
      | None -> ()
      | Some t -> texture <- None ; Texture.destroy t

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

    method font = match data with
      | None -> None
      | Some (font,_,_) -> Some font

    method set_text font color text =
      self#destroy_surface;
      data <- Some (font, color, text);
      match text with
      | "" -> size <- 0,0
      | _ ->
          let color = Color.to_sdl_color color in
          let s =
            match Font.render_utf8_blended font text color with
            | Error (`Msg msg) ->
                Log.err (fun m -> m "While rendering %S with font %s: %s"
                   text (Font.font_face_family_name font) msg);
                let> t = Sdl.create_rgb_surface ~w:10 ~h:10 ~depth:8
                  Int32.zero Int32.zero Int32.zero Int32.zero
                in
                Texture.finalise_sdl_surface t ;
                t
            | Ok s -> s
          in
          surface <- Some s;
          size <- Sdl.get_surface_size s

(*    initializer
      Gc.finalise_last (fun o -> prerr_endline ("finalizing text")) self
*)
  end

(** Label widget, displaying a single line text. *)
class label ?classes ?name ?props ?wdata () =
  object(self)
    inherit Widget.widget ?classes ?name ?props ?wdata () as super
    (**/**)
    method kind = "label"
    val ttext = new textured_text ()
    val mutable start_ticks = 1.
    val mutable stop_ticks = 100.
    val mutable duration = 300. (* ms *)
    val mutable font_height = 0

    method text_size = ttext#size
    (**/**)

    (** {2 Properties} *)

    method halign = self#get_p Props.halign
    method set_halign = self#set_p Props.halign

    method valign = self#get_p Props.valign
    method set_valign = self#set_p Props.valign

    method font_desc = self#get_p Props.font_desc
    method set_font_desc = self#set_p Props.font_desc

    method font_size = (self#font_desc).Font.size
    method font_bold = (self#font_desc).Font.bold
    method font_italic = (self#font_desc).Font.italic
    method set_font_size size =
      let fn = self#font_desc in
      let fn = { fn with Font.size } in
      self#set_font_desc fn
    method set_font_bold bold =
      let fn = self#font_desc in
      let fn = { fn with Font.bold } in
      self#set_font_desc fn
    method set_font_italic italic =
      let fn = self#font_desc in
      let fn = { fn with Font.italic } in
      self#set_font_desc fn

    method set_text ?delay ?propagate str =
      (*start_ticks <- Int32.to_float (Sdl.get_ticks()) ;
      stop_ticks <- start_ticks +. duration ;*)
      self#set_p ?delay ?propagate Props.text str

    method text =
      match self#opt_p Props.text with
      | None -> ""
      | Some s -> s

    (**/**)

    method! min_width_ = super#min_width_ + fst ttext#size
    method! min_height_ = super#min_height_ + max (snd ttext#size) font_height

    method! baseline =
      let fn = Props.get_font props in
      let asc = Font.font_ascent fn in
      let y =
        let a = self#get_p Props.valign in
        if a >= 0. && a <= 1. then
            max 0 (truncate (a *. (float (g_inner.h - font_height))))
        else
          (Log.warn (fun m -> m "%s: invalid %s value %f"
              self#me (Props.(name valign)) a);
           0)
      in
      let ptop = self#padding.top in
      let btop = self#border_width.top in
      ptop + btop + y + asc

    method private update_font_height =
      let fn = Props.get_font props in
      let h = Font.font_height fn in
      font_height <- h
      (*      let> (_,h) = Ttf.size_utf8 fn "A" in
      min_font_height <- h;
      *)

    method private update_ =
        let text = self#text in
        [%debug "%s#update_text ~now:%S font=%a" self#me
          text Font.pp_font_desc Props.(get props font_desc)];
        let color = self#fg_color_now in
        let font = Props.get_font props in
        ttext#set_text font color text;
        self#destroy_texture;

    method private update_text : 'a. prev:'a option -> now:'a -> unit =
      fun ~prev ~now ->
        self#update_;
        let (w,h) = ttext#size in
        [%debug "%s#update_text ttext#size=%d,%d" self#me w h];
        (* no need of need_resize since setting text prop in self#update_
           will already ask
        self#need_resize *)

    method! do_apply_theme ~root ~parent parent_path rules =
      super#do_apply_theme ~root ~parent parent_path rules;
      self#update_

    method private gtext =
      let (w,h) = ttext#size in
      let x =
        let a = self#get_p Props.halign in
        if a >= 0. && a <= 1. then
          max 0 (truncate (a *. (float (g_inner.w - w))))
        else
          (Log.warn (fun m -> m "%s: invalid %s value %f"
              self#me (Props.(name halign)) a);
           0)
      in
      let y =
        let a = self#get_p Props.valign in
        if a >= 0. && a <= 1. then
            max 0 (truncate (a *. (float (g_inner.h - h))))
        else
          (Log.warn (fun m -> m "%s: invalid %s value %f"
              self#me (Props.(name valign)) a);
           0)
      in
      G.{ x ; y ; w ; h }

    method render_text ~layer rend ~offset:(x,y) rg =
    (* to handle change of color when hovering *)
      ttext#redraw_if_changed self#fg_color_now self#text ;
      match ttext#texture rend with
      | None -> ()
      | Some text_t ->
          let gtext =
            let gtext = self#gtext in
            G.translate ~x:(g.x+g_inner.x) ~y:(g.y+g_inner.y) gtext
          in
          match G.inter gtext rg with
          | None -> ()
          | Some rg ->
              let src = G.translate ~x:(-gtext.x) ~y:(-gtext.y) rg in
              let dst = G.translate ~x ~y rg in
              Texture.render_copy rend ~src ~dst text_t

    method! render_me ~layer rend ~offset:(x,y) rg =
      [%debug "%s#render_me layer=%a offset=%d,%d rg=%a, g=%a"
         self#me Layer.pp layer x y G.pp rg G.pp g];
      if layer = self#get_p Props.layer then
        self#render_text ~layer rend ~offset:(x,y) rg

    method! set_parent ?with_rend w =
      super#set_parent ?with_rend w;
      ttext#destroy_texture

    initializer
      self#update_font_height ;
      let _ = self#connect (Object.Prop_changed Props.text) self#update_text in
      let _ = self#connect (Object.Prop_changed Props.fg_color) self#update_text in
      let _ = self#connect (Object.Prop_changed Props.fg_color_hover) self#update_text in
      let _ = self#connect (Object.Prop_changed Props.font_desc)
        (fun ~prev ~now ->
           self#update_font_height ;
           self#update_text ~prev ~now)
      in
      [%debug "%s created with props=%a" self#me Props.pp props]
  end

(** Convenient function to create a {!class-label}.
  {!Props.val-halign}, {!Props.val-valign} and {!Props.val-text} properties
  can be specified with the corresponding optional arguments.
  See {!Widget.section-widget_arguments} for other arguments. *)
let label ?classes ?name ?props ?wdata ?halign ?valign ?text ?pack () =
  let l = new label ?classes ?name ?props ?wdata () in
  Widget.may_pack ?pack l#coerce ;
  Option.iter l#set_text text ;
  Option.iter l#set_halign halign ;
  Option.iter l#set_valign valign ;
  l

module Status_msg_id = Misc.Id()
type status_msg_id = Status_msg_id.t

(** A status is a label where messages can be stacked. Only the
  message at the top of the stack is displayed.
  Each message has an id, which can be used to remove the message
  even if not on top of the stack.
*)
class status ?classes ?name ?props ?wdata () =
  object(self)
    inherit label ?classes ?name ?props ?wdata ()

    (**/**)
    method kind = "status"

    val mutable messages = ([] : (status_msg_id * string) list)
    (**/**)

    (** [s#push msg] pushes new message [msg] and returns message id. *)
    method push msg =
      let id = Status_msg_id.gen () in
      self#set_text msg ;
      messages <- (id, msg) :: messages ;
      id

    (** [v#pop] pops message from the stack. If the stack is not empty, then
      the new message on top is displayed. *)
    method pop =
      match messages with
      | [] -> ()
      | _ :: q ->
          messages <- q ;
          match messages with
          | [] -> self#set_text ""
          | (_,msg) :: _ -> self#set_text msg

    (** [v#remove id] removes message with given [id] from the stack. *)
    method remove id =
      let old = messages in
      messages <- List.filter
        (fun (id2,_) -> Status_msg_id.compare id id2 <> 0) messages;
      match old, messages with
      | [], _ -> ()
      | _, [] -> self#set_text ""
      | (_,msg1)::_, (_,msg2)::_ when msg1 = msg2 -> ()
      | _, (_,msg)::_ -> self#set_text msg

    (** Removes all messages. *)
    method remove_all = messages <- []; self#set_text ""

    (** [flash ?delay msg] pushes [msg] to the stack and removes it after
         a given [delay] in seconds (default is [4]). *)
    method flash ?(delay=4) msg =
      let id = self#push msg in
      let t = Lwt_timeout.create delay (fun () -> self#remove id) in
      Lwt_timeout.start t
  end


(** Convenient function to create a {!class-status}.
  See {!Widget.section-widget_arguments} for arguments. *)
let status ?classes ?name ?props ?wdata ?pack () =
  let w = new status ?classes ?name ?props ?wdata () in
  Widget.may_pack ?pack w#coerce ;
  w

(** Class used internally to cache rendering of glyphs. *)
class textured_glyph () =
  object(self)
    val mutable surface = (None : Sdl.surface option)
    val mutable texture = (None : Texture.t option)
    method texture rend =
      match texture with
      | Some t -> Some t
      | None ->
          match surface with
          | None -> None
          | Some s ->
              let t = Texture.from_surface rend s in
              texture <- Some t;
              texture

    val mutable size = (0, 0)
    method size = size

    val mutable data = None
    method redraw_if_changed color glyph =
      match data with
      | None -> ()
      | Some (font, c, gly) ->
          if c <> color || gly <> glyph then
            self#set_glyph font color glyph

    method destroy_texture =
      match texture with
      | None -> ()
      | Some t -> texture <- None; Texture.destroy t

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

    method font = match data with
      | None -> None
      | Some (font,_,_) -> Some font

    method set_glyph font color glyph =
      self#destroy_surface;
      data <- Some (font, color, glyph);
      (* TODO: use Tsdl_ttf.Ttf.glyph_is_provided to draw something else
        if glyph is not provided by font *)
      match glyph with
      | 0 -> size <- 0,0
      | _ ->
          let color = Color.to_sdl_color color in
          let> s = Font.render_glyph_blended font glyph color in
          surface <- Some s;
          size <- Sdl.get_surface_size s

(*    initializer
      Gc.finalise_last (fun () -> prerr_endline "finalizing glyph") self
*)
  end

(** Widget to render a single glyph. *)
class glyph ?classes ?name ?props ?wdata () =
  object(self)
    inherit Widget.widget ?classes ?name ?props ?wdata () as super
    (**/**)
    method kind = "glyph"
    val tglyph = new textured_glyph ()

    method size = tglyph#size
    val mutable font_height = 0

    (**/**)
    (** {2 Properties} *)

    method set_glyph gly = self#set_p Props.glyph gly

    method glyph =
      match self#opt_p Props.glyph with
      | None -> 0
      | Some g -> g

    (**/**)

    method! private min_width_ = super#min_width_ + fst tglyph#size
    method! private min_height_ = super#min_height_ + max (snd tglyph#size) font_height

    method! max_width = Some self#min_width
    method! max_height = Some self#min_height

    method private update_font_height =
      let fn = Props.get_font props in
      font_height <- Font.font_height fn
       (*let> (_,h) = Ttf.size_utf8 fn "A" in
      min_font_height <- h*)

    method private update_ =
      let gly = self#glyph in
      let color = self#fg_color_now in
      let font = Props.get_font props in
      tglyph#set_glyph font color gly;
      self#destroy_texture

    method private update_glyph : 'a. prev:'a option -> now:'a -> unit =
      fun ~prev ~now ->
        self#update_ ;
        self#need_resize

    method! do_apply_theme ~root ~parent parent_path rules =
      super#do_apply_theme ~root ~parent parent_path rules;
      self#update_

    method render_glyph ~layer rend ~offset:(x,y) rg =
      (* to handle change of color when hovering *)
      tglyph#redraw_if_changed self#fg_color_now self#glyph ;
      match tglyph#texture rend with
      | None -> ()
      | Some gly_t ->
          let (w,h) = tglyph#size in
          let ggly = G.translate ~x:g.x ~y:g.y
              { x = g_inner.x ; y = g_inner.y ; w ; h }
          in
          match G.inter ggly rg with
          | None -> ()
          | Some rg ->
              let src = G.translate ~x:(-ggly.x) ~y:(-ggly.y) rg in
              let dst = G.translate ~x ~y rg in
              Texture.render_copy rend ~src ~dst gly_t

    method! render ~layer rend ~offset:(x,y) geom =
      super#render ~layer rend ~offset:(x,y) geom ;
      if self#visible then
        (
         match self#need_rendering geom with
         | None -> ()
         | Some rg ->
             [%debug "%s#render layer=%a offset=%d,%d geom=%a, g=%a"
                self#me Layer.pp layer x y G.pp geom G.pp g];
             if layer = self#get_p Props.layer then
               self#render_glyph ~layer rend ~offset:(x,y) rg
        )

    method! set_parent ?with_rend w =
      super#set_parent ?with_rend w;
      tglyph#destroy_texture

    initializer
      self#update_font_height ;
      let _ = self#connect (Object.Prop_changed Props.glyph) self#update_glyph in
      let _ = self#connect (Object.Prop_changed Props.fg_color) self#update_glyph in
      let _ = self#connect (Object.Prop_changed Props.fg_color_hover) self#update_glyph in
      let _ = self#connect (Object.Prop_changed Props.font_desc)
        (fun ~prev ~now ->
           self#update_font_height ;
           self#update_glyph ~prev ~now)
      in
      [%debug "%s created with props=%a" self#me Props.pp props]
  end


(** Convenient function to create a {!class-glyph}.
  {!Props.val-glyph} property can be specified with the corresponding optional argument.
  See {!Widget.section-widget_arguments} for other arguments. *)
let glyph ?classes ?name ?props ?wdata ?glyph ?pack () =
  let l = new glyph ?classes ?name ?props ?wdata () in
  Widget.may_pack ?pack l#coerce ;
  Option.iter l#set_glyph glyph ;
  l