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

(** Range widget.

This widget allows selecting a float value between two bounds.
*)

open Misc
open Widget
open Tsdl

(** {2 Properties}

All properties are not inherited. *)

(** Property ["range_range"] to represent minimum and maximum values.
  Default is [0.]..[1.].
*)
let range = Props.float_pair_prop
  ~after:[Render] ~default:(0., 1.) ~inherited:false "range_range"

(** Property ["range_value"] to store the currnt value of the range. *)
let value = Props.float_prop ~after:[Resize] ~inherited:false "range_value"

(** Property ["range_step"] to specify a step. Used when some left/right or
  up/down arrows are pressed. Default is [0.1]. *)
let step = Props.float_prop ~default:0.1 ~inherited:false "range_step"

(** Property ["range_bigstep"] to specify a step. Used when some page up/down
  keys are pressed. Default is [1.]. *)
let bigstep = Props.float_prop ~default:1. ~inherited:false "range_bigstep"

(** Property ["pole_size"] defines, in pixels, vertical or horizontal size
  of range poles. Default is [15]. *)
let pole_size = Props.int_prop ~default:15 ~after:[Resize] ~inherited:false "pole_size"
let css_pole_size = Theme.int_prop pole_size

(** Property ["pole_width"] defines, in pixels, the width of range poles.
  Default is [4]. *)
let pole_width = Props.int_prop ~default:4 ~after:[Resize] ~inherited:false "pole_width"
let css_pole_width = Theme.int_prop pole_width

(** Property ["pole_color_low"] defines the color of the lower bound pole.*)
let pole_color_low = Props.color_prop ~after:[Render] ~inherited:false "pole_color_low"
let css_pole_color_low = Theme.color_prop pole_color_low

(** Property ["pole_color_high"] defines the color of the upper bound pole.*)
let pole_color_high = Props.color_prop ~after:[Render] ~inherited:false "pole_color_high"
let css_pole_color_high = Theme.color_prop pole_color_high

(** Property ["range_line_width"] defines the width, in pixels,
  of the line between the two poles. Default is [2].*)
let line_width = Props.int_prop ~default:2 ~after:[Resize] ~inherited:false "range_line_width"
let css_line_width = Theme.int_prop line_width

(** Property ["range_cursor_bg_color"] defines the background color of range cursor. *)
let cursor_bg_color = Props.color_prop ~after:[Render] ~inherited:false "range_cursor_bg_color"
let css_cursor_bg_color = Theme.color_prop cursor_bg_color

(** Property ["range_cursor_border_color"] defines the border color of range cursor. *)
let cursor_border_color = Props.color_prop ~after:[Render] ~inherited:false "range_cursor_border_color"
let css_cursor_border_color = Theme.color_prop cursor_border_color


(** {2 Range widget} *)

(** The range widget. *)
class range ?classes ?name ?props ?wdata () =
  object(self)
    inherit Widget.widget ?classes ?name ?props ?wdata () as super

    (**/**)
    method kind = "range"
    val mutable cursor_rect = G.zero
    val mutable state_machine = Misc.empty_state_machine
    (**/**)

    (** {2 Properties} *)

    method value = self#get_p value

    (** Setting a value out or bounds will only log an error message. *)
    method set_value v =
      let (start, stop) = self#range in
      if v < start || v > stop then
        Log.err (fun m -> m "%s: value %f out of range (%f, %f)" self#me v start stop)
      else
        (self#set_p value v;
         self#update_cursor_rect
        )

    (** Normalized value, i.e. between [0.] and [1.]. *)
    method norm_value =
        let (lo,hi) = self#range in
        let d = hi -. lo in
        ((self#value -. lo) /. d)

    method range = self#get_p range
    method set_range r =
      let (start, stop) = r in
      if start > stop then
        Log.err (fun m -> m "%s: invalid range (%f, %f)" self#me start stop)
      else
        (self#set_p range r;
         let v = self#value in
         if v < start then
           self#set_value start
         else if v > stop then
             self#set_value stop
        )

    method orientation = self#get_p Props.orientation
    method set_orientation = self#set_p Props.orientation

    method line_width = self#get_p line_width
    method set_line_width = self#set_p line_width
    method pole_width = self#get_p pole_width
    method set_pole_width = self#set_p pole_width
    method pole_size = self#get_p pole_size
    method set_pole_size = self#set_p pole_size
    method cursor_width = self#get_p Props.cursor_width
    method set_cursor_width = self#set_p Props.cursor_width
    method cursor_bg_color = self#get_p cursor_bg_color
    method set_cursor_bg_color = self#set_p cursor_bg_color
    method cursor_border_color = self#get_p cursor_border_color
    method set_cursor_border_color = self#set_p cursor_border_color

    method step = self#get_p step
    method set_step = self#set_p step
    method bigstep = self#get_p bigstep
    method set_bigstep = self#set_p bigstep

    (**/**)
    method! private min_width_ =
      super#min_width_ +
        match self#orientation with
        | Horizontal -> 2 * self#pole_width + 1
        | Vertical -> max self#pole_size self#line_width

    method! private min_height_ =
      super#min_height_ +
        match self#orientation with
        | Vertical -> 2 * self#pole_width + 1
        | Horizontal -> max self#pole_size self#line_width

    method update_cursor_rect =
      let r =
        let cw = self#cursor_width in
        match self#orientation with
        | Props.Vertical ->
            let x = 0 in
            let y = truncate ((1. -. self#norm_value) *. float (g_inner.h - cw)) in
            let w = g_inner.w in
            let h = cw in
            { G.x ; y ; w ; h }
        | Props.Horizontal ->
            let x = truncate (self#norm_value *. float (g_inner.w - cw)) in
            let y = 0 in
            let w = cw in
            let h = g_inner.h in
            { G.x ; y ; w ; h }
      in
      [%debug "%s#update_cursor_rect => %a" self#me G.pp r];
      cursor_rect <- r;
      self#invalidate_texture ;
      self#need_render ~layer:(self#get_p Props.layer) g

    method! set_geometry geom =
      super#set_geometry geom ;
      self#update_cursor_rect

    method render_cursor rend t =
      Texture.fill_rect rend t (Some cursor_rect) self#cursor_bg_color;
      Texture.draw_rect_r rend t cursor_rect self#cursor_border_color

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

    method! prepare ~layer rend geom =
     if layer = self#get_p Props.layer then
        (
         match self#texture rend with
         | None ->
             [%debug "%s#prepare: no texture" self#me];
             None
         | Some (`Exist t) -> Some t
         | Some (`New t) ->
             [%debug "%s: rendering on texture" self#me];
             (* When orientation=Horizontal:
               p00                     p10
               |(low pole)  (high pole)|
               p1=========p0===========p2
               |                       |
               p01                     p11
               When orientation=Vertical:
               p10-p1-p11 (high pole)
                   |
                   |
                   p0
                   |
                   |
               p00-p2-p01 (low pole)
             *)
             let x0 = g_inner.w / 2 and y0 = g_inner.h / 2 in
             let lw = self#line_width in
             let pole_width = self#pole_width in
             let x1,y1,w,h,xlo,ylo,wlo,hlo,xhi,yhi,whi,hhi =
               match self#orientation with
               | Horizontal ->
                  let x1 = 0 and y1 = y0 - (lw / 2) in
                  let w = x0 * 2 and h = lw in
                  let xlo = x1 and ylo = 0 in
                  let wlo = pole_width and hlo = 2 * y0 in
                  let xhi = x0 * 2 - pole_width and yhi = 0 in
                  let whi = pole_width and hhi = 2 * y0 in
                  x1,y1,w,h,xlo,ylo,wlo,hlo,xhi,yhi,whi,hhi
               | Vertical ->
                   let x1 = x0 - (lw / 2) and y1 = 0 in
                   let w = lw and h = y0 * 2 in
                   let xlo = 0 and ylo = g_inner.h - pole_width in
                   let wlo = 2 * x0 and hlo = pole_width in
                   let xhi = 0 and yhi = y1 in
                   let whi = 2 * x0 and hhi = pole_width in
                   x1,y1,w,h,xlo,ylo,wlo,hlo,xhi,yhi,whi,hhi
             in
             let () =
               let r = G.create ~x:x1 ~y:y1 ~w ~h in
               Texture.fill_rect rend t (Some r) self#fg_color_now
             in
             let () =
               let c = match self#opt_p pole_color_low with
                 | None -> self#fg_color_now
                 | Some c -> c
               in
               let r = G.create ~x:xlo ~y:ylo ~w:wlo ~h:hlo in
               Texture.fill_rect rend t (Some r) c
             in
             let () =
               let c = match self#opt_p pole_color_high with
                 | None -> self#fg_color_now
                 | Some c -> c
               in
               let r = G.create ~x:xhi ~y:yhi ~w:whi ~h:hhi in
               [%debug "%s: g_inner=%a, r(high pole)=%a"
                  self#me G.pp g_inner G.pp r];
               Texture.fill_rect rend t (Some r) c
             in
             self#render_cursor rend t;
             Some t
        )
      else None

    method! on_sdl_event_down ~oldpos pos ev =
      if self#sensitive then
        match state_machine.f pos ev with
        | false -> super#on_sdl_event_down ~oldpos pos ev
        | true -> true
      else
        false

    method on_mouse_leave =
      (match state_machine.state () with
       | `Moving_handle -> state_machine.set_state `Base
       | _ -> ()
      );
      super#on_mouse_leave

    method user_set_cursor_pos ~x ~y =
      let v =
        let (lo,hi) = self#range in
        let ratio =
          match self#orientation with
          | Vertical -> 1. -. (float y /. (float (g_inner.h - self#cursor_width)))
          | Horizontal -> float x /. (float (g_inner.w - self#cursor_width))
        in
        max lo (min hi (lo +. ratio *. (hi -. lo)))
      in
      self#set_value v

    method state_on_event state pos ev =
      match state, pos, Sdl.Event.(enum (get ev typ)) with
      | `Base, Some(x,y), `Mouse_motion ->
          None
      | `Moving_handle, Some (x, y), `Mouse_motion ->
          if G.inside ~x ~y g then
            (
             let (x, y) = self#to_g_inner_coords ~x ~y in
             self#user_set_cursor_pos ~x ~y;
             None
            )
          else
            (
             Some (`Base, false)
            )
      | `Base, Some (x,y), `Mouse_button_down ->
          let button = Sdl.Event.(get ev mouse_button_button) in
          if button = 1 && G.inside ~x ~y g then
            let _ = self#grab_focus () in
            let (x, y) = self#to_g_inner_coords ~x ~y in
            if G.inside ~x ~y cursor_rect then
              Some (`Moving_handle, true)
            else
              (
               self#user_set_cursor_pos ~x ~y;
               Some (`Base, true)
              )
          else
            None
      | `Moving_handle, Some (x, y), `Mouse_button_up ->
          Some (`Base, false)
      | (`Base|`Moving_handle), _, _ -> None

    method! on_key_down pos ev key keymod =
      match key with
      | k when k = Sdl.K.home -> self#set_value (fst self#range); true
      | k when k = Sdl.K.kend -> self#set_value (snd self#range); true
      | k when k = Sdl.K.pageup ->
          self#set_value (min (snd self#range) (self#value +. self#bigstep));
          true
      | k when k = Sdl.K.pagedown ->
          self#set_value (max (fst self#range) (self#value -. self#bigstep));
          true
      | k when k = Sdl.K.up || k = Sdl.K.right ->
          self#set_value (min (snd self#range) (self#value +. self#step));
          true
      | k when k = Sdl.K.down || k = Sdl.K.left ->
          self#set_value (max (fst self#range) (self#value -. self#step));
            true
      | _ -> super#on_key_down pos ev key keymod

    initializer
      self#set_value (fst self#range);
      state_machine <- Misc.mk_state_machine `Base self#state_on_event ;
      ignore(self#connect (Object.Prop_changed Props.has_focus)
        (fun ~prev ~now -> self#invalidate_texture))

  end


(** Convenient function to create a {!class-range}.
  See {!Widget.widget_arguments} for optional arguments [classes],
  [name], [props] and [pack]. Other arguments will set range properties.*)
let range ?classes ?name ?props ?wdata ?orientation ?range ?step ?bigstep ?value ?pack () =
  let w = new range ?classes ?name ?props ?wdata () in
  Option.iter w#set_orientation orientation ;
  Option.iter w#set_range range ;
  Option.iter w#set_step step ;
  Option.iter w#set_bigstep bigstep ;
  Option.iter w#set_value value ;
  Widget.may_pack ?pack w ;
  w