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

(**/**)

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 rend ~offset:(x,y) rg =
      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 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

type Widget.widget_type += Button of button

(** 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
  w#set_typ (Button w);
  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 {!Props.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 Props.active
    method set_active x = self#set_p Props.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 rend ~offset:(x,y) rg = ()
  end

type Widget.widget_type += Togglebutton of togglebutton

(** 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
  w#set_typ (Togglebutton w);
  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 Props.active then
        match elements with
        | [] -> Props.set_opt props active_widget None
        | w :: _ -> self#set_active w

    (** Sets the active widget. *)
    method set_active (wid:Widget.widget) =
      List.iter (fun (w:Widget.widget) ->
         (* do not set wid's active to false to prevent looping *)
         if not (w#equal wid) then w#set_p Props.active false) elements;
      wid#set_p Props.active true;
      self#set_p active_widget wid

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

    (** Gets the {!Widget.wdata} associated to the active widget, if any. *)
    method wdata =
      match self#active_element with
      | None -> None
      | Some w -> w#wdata
  end

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

(** The checkbutton widget. *)
class checkbutton ?classes ?name ?props ?wdata () =
  let hbox = Box.hbox () in
  let indicator = Indicator.indicator ~pack:(hbox#pack ~hexpand:0) () in
  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
    (**/**)

    (** The {!Indicator.class-indicator} widget. *)
    method indicator = indicator

    (** {3 Properties} *)

    method indicator_font = indicator#font
    method set_indicator_font_desc = indicator#set_font_desc
    method indicator_active_char = indicator#active_char
    method set_indicator_active_char = indicator#set_active_char
    method indicator_inactive_char = indicator#inactive_char
    method set_indicator_inactive_char = indicator#set_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

    method! set_child w =
      let ind_w = indicator#coerce in
      List.iter (fun w -> if not (w#equal ind_w) then hbox#unpack w)
        hbox#children_widgets;
      hbox#pack w

    initializer
      super#set_child hbox#as_widget ;
      indicator#connect_to_active self#as_o
  end

type Widget.widget_type += Checkbutton of checkbutton

(** 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
  w#set_typ (Checkbutton w);
  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)

class type button_box =
  object
    method box : Box.box
    method flex : Flex.flex
    method add_space : Flex.space
    method add_text_button : ?onclick:(unit -> unit) -> string -> button * Text.label
    method add_button : ?onclick:(unit -> unit) -> unit -> button
  end

let button_box ?(classes=[]) ?name ?props ?wdata ?pack () : button_box =
  let box = Box.vbox ~classes:("button_box"::classes) ?name ?props ?wdata ?pack () in
  let flex = Flex.hflex ~wrap:false ~pack:box#pack () in
  let opt_connect_activate (b:button) = function
  | None -> ()
  | Some f -> ignore(b#connect Widget.Activated f)
  in
  let add_text_button ?onclick text =
    let (b,l) = text_button ~pack:flex#pack ~text () in
    opt_connect_activate b onclick ;
    (b, l)
  in
  let add_button ?onclick () =
    let b = button ~pack:flex#pack () in
    opt_connect_activate b onclick ;
    b
  in
  object
    method box = box
    method flex = flex
    method add_space = flex#pack_space ()
    method add_text_button = add_text_button
    method add_button = add_button
  end