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

(** Buttons. *)

open Misc
open Widget
open Tsdl

(** Property used to indicate whether a toggle or option
    button is activate.*)
let active = Props.(bool_prop ~after:[Render]
  ~default:false ~inherited:false "active")

(**/**)

let active_widget = Widget.widget_prop
  ~inherited:false "active_widget"

(**/**)

(** {2 Simple buttons} *)

(** Simple button.*)
class button ?classes ?name ?props ?wdata () =
  object(self)
    inherit Bin.bin ?classes ?name ?props ?wdata () as super

    (**/**)
    method kind = "button"
    method! set_child w =
      super#set_child w ;
      w#set_handle_hovering true

    method! render_me_parent ~layer rend ~offset:(x,y) rg =
      if layer = self#get_p Props.layer then
        (
         match button_pressed with
         | Some 1 ->
             let rg = G.translate ~x ~y rg in
             Render.fill_rect rend (Some rg)
               (self#get_p Props.click_mask)
         | _ -> ()
        )

    method! on_key_down pos event key mods =
      [%debug "%s#on_key_down" self#me];
      match key with
      | k when k = Sdl.K.space -> self#activate; true
      | _ -> super#on_key_down pos event key mods

    (**/**)

    (** Triggers the {!Widget.extension-Activated} event on the button. *)
    method activate =
      [%debug "%s activated" self#me];
      self#trigger_unit_event Widget.Activated ()

    (**/**)

    method private on_clicked ev =
      if ev.Widget.button = 1 then
        (self#activate; true)
      else
        false

    initializer
      Props.(set props focusable true);
      self#set_handle_hovering true ;
      let on_button _ = self#need_render ~layer:(self#get_p Props.layer) g; false in
      let _id = self#connect Widget.Button_pressed on_button in
      let _id = self#connect Widget.Button_released on_button in
      let _id = self#connect Widget.Clicked self#on_clicked in
      ()
  end


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

(** Convenient function to create a {!class-button} with
  a {!Text.class-label} as child.
  [text] optional argument is passed to {!Text.val-label}.
  [label_class] is passed as [?class_] argument when creating
  label.
  See {!Widget.widget_arguments} for other arguments. *)
let text_button ?classes ?label_classes ?name ?props ?wdata ?text ?pack () =
  let label = Text.label ?classes:label_classes ?text () in
  let b = button ?classes ?name ?props ?wdata ?pack () in
  b#set_child label#coerce ;
  (b, label)

(** {2 Toggle buttons} *)

(** A toggle button. State is represented by the {!active} property.
  Activating the widget toggles the state.
*)
class togglebutton ?classes ?name ?props ?wdata () =
  object(self)
    inherit button ?classes ?name ?props ?wdata () as super
    method active = self#get_p active
    method set_active x = self#set_p active x

    (**/**)
    method kind = "togglebutton"
    method activate =
      self#set_active (not self#active) ;
      super#activate

    method private widget_border_color = super#border_color
    method! border_color =
      let c = super#border_color in
      if self#active then
        c
      else
        Props.{ top = c.bottom ; right = c.left ;
                bottom = c.top ; left = c.right }
    method render_me_parent ~layer rend ~offset:(x,y) rg = ()
  end

(** Convenient function to create a {!class-togglebutton}.
  Initial state can be specifier with the [active] argument
  (default is false).
  See {!Widget.widget_arguments} for other arguments. *)
let togglebutton ?classes ?name ?props ?wdata ?active ?pack () =
  let w = new togglebutton ?classes ?name ?props ?wdata () in
  Widget.may_pack ?pack w#coerce ;
  Option.iter w#set_active active ;
  w


(** Convenient function to create a {!class-togglebutton} with
  a {!Text.class-label} as child.
  Initial state can be specifier with the [active] argument
  (default is false).
  [text] optional argument is passed to {!Text.val-label}.
  [label_class] is passed as [?class_] argument when creating
  label.
  See {!Widget.widget_arguments} for other arguments. *)
let text_togglebutton ?classes ?label_classes ?name ?props ?wdata ?active ?text ?pack () =
  let label = Text.label ?classes:label_classes ?text () in
  let b = togglebutton ?classes ?name ?props ?wdata ?active ?pack () in
  b#set_child label#coerce ;
  (b, label)

(** {2 Check and radio buttons} *)

(** A group is used to share a state among several checkbuttons,
  so they act as radio buttons (only one can be active at the
  same time). *)
class group =
  object(self)
    inherit Object.o () as super

    (**/**)

    val mutable elements = ([] : Widget.widget list)

    (**/**)

    (** Adds a widget to the group. The widget becomes active
         if it is the first in the group. *)
    method add (w:Widget.widget) =
      elements <- w :: elements;
      match elements with
      | [_] -> self#set_active w
      | _ -> ()

    (** Removes a widget to the group. If the widget was active,
      the first of the remaining widgets become active. *)
    method remove (w:Widget.widget) =
      let id = w#id in
      elements <- List.filter (fun w -> not (Oid.equal id w#id)) elements;
      if w#get_p active then
        match elements with
        | [] -> Props.set_opt props active_widget None
        | w :: _ -> self#set_active w

    (** Sets the active widget. *)
    method set_active (w:Widget.widget) =
      List.iter (fun (w:Widget.widget) -> w#set_p active false) elements;
      w#set_p active true;
      self#set_p active_widget w

    (* Gets the active widget, if any. *)
    method active_element = self#get_p active_widget

    (** Gets the {!Widget.wdata} associated to the active widget, if any. *)
    method wdata = self#active_element#wdata
  end

(** Convenient function to create a {!class-group}. *)
let group () = new group

(** The following properties are used to tune the appearance
  of checkbuttons: a font and active and inactive characters. *)

let check_indicator_font = Props.font_desc_prop
  ~after:[Props.Resize] ~inherited:false ~default:(Font.font_desc ~size:14 "DejaVu Sans")
    "check_indicator_font"

let css_check_indicator_font = Theme.font_desc_prop check_indicator_font

let check_indicator_active_char = Props.uchar_prop
  ~after:[Props.Resize] ~inherited:false ~default:(Uchar.of_int 9724)
  "check_indicator_active_char"

let css_check_indicator_active_char = Theme.uchar_prop check_indicator_active_char

let check_indicator_inactive_char = Props.uchar_prop
  ~after:[Props.Resize] ~inherited:false ~default:(Uchar.of_int 9723)
  "check_indicator_inactive_char"

let css_check_indicator_inactive_char = Theme.uchar_prop check_indicator_inactive_char

(** The checkbutton widget. *)
class checkbutton ?classes ?name ?props ?wdata () =
  object(self)
    inherit togglebutton ?classes ?name ?props ?wdata () as super
    (**/**)
    method kind = "checkbutton"
    val mutable group = (None:group option)
    method! border_color = super#widget_border_color
    (**/**)

    (** {3 Properties} *)

    method indicator_font = self#get_p check_indicator_font
    method set_indicator_font = self#set_p check_indicator_font
    method indicator_active_char = self#get_p check_indicator_active_char
    method set_indicator_active_char = self#set_p check_indicator_active_char
    method indicator_inactive_char = self#get_p check_indicator_inactive_char
    method set_indicator_inactive_char = self#set_p check_indicator_inactive_char
    method private indicator_char =
      if self#active then self#indicator_active_char else self#indicator_inactive_char

    (** {3 The group} *)

    method group = group
    method set_group g =
      (match group with
       | None -> ()
       | Some g -> g#remove self#coerce);
       group <- Some g;
       g#add self#coerce;
      if self#active then g#set_active self#coerce else ()

    (**/**)

    method! set_active b =
      match group, b with
      | None, _ -> super#set_active b
      | Some _, false -> ()
      | Some g, true -> g#set_active self#coerce

    val mutable g_indicator = G.zero
    method update_g_indicator =
      let f = Font.get self#indicator_font in
      let desc = Font.font_descent f in
      let> (w,h) = Font.size_utf8 f (Utf8.string_of_uchar self#indicator_char) in
      let gi = G.{ x = 0 ; y = max 0 ((g_inner.h - (h-desc)) / 2) ; w ; h } in
      (*Log.warn (fun m -> m "%s#update_g_indicator => %a" self#me G.pp gi);*)
      g_indicator <- gi

    method space_for_child =
      let g_ind = g_indicator in
      let ip = self#get_p Pack.inter_padding in
      let x = g_ind.x + g_ind.w + ip in
      { G.x ;
        y = 0 ;
        w = g_inner.w - x ;
        h = g_inner.h ;
      }
    method! compute_child_geometry _ = self#space_for_child
    method! set_geometry geom =
      super#set_geometry geom;
      self#update_g_indicator

    method! private min_width_ =
      self#update_g_indicator ;
      let ip = self#get_p Pack.inter_padding in
      let w = super#widget_min_width_ + g_indicator.x + g_indicator.w + ip + self#child_min_width in
      (*Log.warn (fun m -> m "%s#min_width_=%d (g_indicator=%a)" self#me w G.pp g_indicator);*)
      w
    method! private min_height_ =
      self#update_g_indicator ;
      super#widget_min_height_ + max g_indicator.h self#child_min_height

    method render_me_parent ~layer rend ~offset:(x,y) rg =
      [%debug "#render_me_parent rg=%a, g=%a, g_inner=%a" G.pp rg G.pp g G.pp g_inner];
      if layer = self#get_p Props.layer then
        (
         let g_ind = G.translate ~x:(g.x+g_inner.x) ~y:(g.y+g_inner.y) g_indicator in
         [%debug "#render_me_parent rg=%a, (translated)g_ind=%a" G.pp rg G.pp g_ind];
         match G.inter g_ind rg with
         | None -> ()
         | Some clip ->
             let clip = G.translate ~x ~y clip in
             [%debug "clip rect: %a" G.pp clip];
             let f rend =
               let g_ind = G.translate ~x ~y g_ind in
               let glyph = Uchar.to_int self#indicator_char in
               let font = Font.get self#indicator_font in
               let> surf = Font.render_glyph_blended font glyph
                 (Color.to_sdl_color self#fg_color_now)
               in
               let> t = Sdl.create_texture_from_surface rend surf in
               Texture.finalise_sdl_texture t;
               let src = G.to_rect { g_ind with x = 0; y = 0 } in
               let dst = G.to_rect g_ind in
               let> () = Sdl.render_copy rend ~src ~dst t in
               ()
             in
             Render.with_clip rend (G.to_rect clip) f
        )

  end

(** Convenient function to create a {!class-checkbutton}.
  Initial state can be specifier with the [active] argument
  (default is false).
  See {!Widget.widget_arguments} for other arguments. *)
let checkbutton ?classes ?name ?props ?wdata ?group ?active ?pack () =
  let w = new checkbutton ?classes ?name ?props ?wdata () in
  Widget.may_pack ?pack w#coerce ;
  Option.iter w#set_group group ;
  Option.iter w#set_active active ;
  w

(** Convenient function to create a {!class-checkbutton} acting
  as a radio button (with class ["radiobutton"]).
  Initial state can be specifier with the [active] argument
  (default is false).
  [group] can be used to set the group the radio button belongs to.
  See {!Widget.widget_arguments} for other arguments. *)
let radiobutton ?(classes=[]) ?name ?props ?wdata ?group ?active ?pack () =
  let classes = "radio" :: classes in
  checkbutton ~classes ?name ?props ?wdata ?group ?active ?pack ()

(** Convenient function to create a {!class-checkbutton} with
  a {!Text.class-label} as child.
  Initial state can be specifier with the [active] argument
  (default is false).
  [text] optional argument is passed to {!Text.val-label}.
  [label_classes] is passed as [?classes] argument when creating
  label.
  See {!Widget.widget_arguments} for other arguments. *)
let text_checkbutton ?classes ?label_classes ?name ?props ?wdata ?group ?active ?text ?pack () =
  let label = Text.label ?classes:label_classes ?text () in
  let b = checkbutton ?classes ?name ?props ?wdata ?group ?active ?pack () in
  b#set_child label#coerce ;
  (b, label)

(** Convenient function to create a {!class-checkbutton} acting
  as a radio button (with class ["radiobutton"])
  with a {!Text.class-label} as child.
  Initial state can be specifier with the [active] argument
  (default is false).
  [group] can be used to set the group the radio button belongs to.
  [text] optional argument is passed to {!Text.val-label}.
  [label_classes] is passed as [?classes] argument when creating
  label.
  See {!Widget.widget_arguments} for other arguments. *)
let text_radiobutton ?classes ?label_classes ?name ?props ?wdata ?group ?active ?text ?pack () =
  let label = Text.label ?classes:label_classes ?text () in
  let b = radiobutton ?classes ?name ?props ?wdata ?group ?active ?pack () in
  b#set_child label#coerce ;
  (b, label)