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

(** Paned widgets. *)

open Misc
open Tsdl
open Widget
open Container

(** A handle position, defined either as percentage or absolute position. *)
type handle_position = [`Percent of float | `Absolute of int]

let handle_position_wrapper =
  let to_json ?with_doc = function
  | `Percent v -> `Float v
  | `Absolute v -> `Int v
  in
  let from_json ?def = function
  | `Float v -> `Percent (max 0. (min 100. v))
  | `Int v -> `Absolute (max 0 v)
  | json -> Ocf.invalid_value json
  in
  Ocf.Wrapper.make to_json from_json

(**/**)

module THandle_positions = struct
    type t = handle_position option list
    let compare = Stdlib.compare
    let wrapper = Some Ocf.Wrapper.(list (option handle_position_wrapper))
    let transition = None
  end
module PHandle_positions = Props.Add_prop_type(THandle_positions)

(**/**)

(** Property ["handle_positions"], to store the positions of the handles
  in a {!class-paned} widget. *)
let handle_positions : handle_position option list Props.prop = PHandle_positions.mk_prop
  ~after:[Props.Resize]
  ~default:[]
  ~inherited:false
  "handle_positions"

let css_handle_positions_prop =
  let string_of_handle_position = function
  | `Percent f -> Printf.sprintf "%f%%" f
  | `Absolute n -> string_of_int n
  in
  let to_string = Theme.(string_of_list (string_of_option_explicit string_of_handle_position)) in
  let handle_position_parser ctx =
    let open Angstrom in
    (Css.U.ws ctx *>
     choice [
       (Css.Vp.number ctx >>= fun f -> Css.U.ws ctx *> char '%' *> return (`Percent f)) ;
       (Theme.Vp.int ctx >>= fun n -> return (`Absolute n)) ;
     ]) <?> "handle_position"
  in
  let parser = Theme.Vp.(list (explicit_opt handle_position_parser)) in
  Theme.mk_prop to_string parser []

let css_handle_positions = css_handle_positions_prop handle_positions

(** How to define handle position when the user moves it: as percentage
  or absolute value. This changes the way handle positions are updated
  when the {!class-paned} widget is resized: with [`Percent], ratios between
  children will be kept, but with [`Absolute] the handles will remain at
  the same position. *)
type user_handle_positionning = [`Percent | `Absolute]

let user_handle_positionnings = [`Percent ; `Absolute]

let string_of_user_handle_positionning = function
| `Percent -> "percent"
| `Absolute -> "absolute"

let user_handle_positionning_of_string =
  Css.T.mk_of_string ~case_sensitive:false
    string_of_user_handle_positionning user_handle_positionnings

let user_handle_positionning_wrapper : user_handle_positionning Ocf.wrapper =
  let to_json ?with_doc x = `String (string_of_user_handle_positionning x) in
  let from_json ?def = function
  | (`String s) as json ->
      (match user_handle_positionning_of_string s with
       | None -> Ocf.invalid_value json
       | Some x -> x
      )
  | json -> Ocf.invalid_value json
  in
  Ocf.Wrapper.make to_json from_json

(**/**)

module TUser_handle_positionning = struct
    type t = user_handle_positionning
    let compare = Stdlib.compare
    let wrapper = Some user_handle_positionning_wrapper
    let transition = None
  end
module PUser_handle_positionning = Props.Add_prop_type(TUser_handle_positionning)

(**/**)

(** Property ["user_handle_positionning"]. *)
let user_handle_positionning : user_handle_positionning Props.prop =
  PUser_handle_positionning.mk_prop
    ~default:`Percent ~inherited:false "user_handle_positionning"

let css_user_handle_positioning_prop = Theme.keyword_prop
  string_of_user_handle_positionning user_handle_positionning_of_string
    `Percent

let css_user_handle_positioning =
  css_user_handle_positioning_prop user_handle_positionning

(**/**)

let default_handle_props =
  let p = Props.empty () in
  Props.(
    set p width 2;
    set p fg_color Color.grey ;
  );
  p

(**/**)

(** Property ["paned_handle_props"] to define appearance of
  handles in {!class-paned} widget.
  Default set {!Props.val-width} to [2] and {!Props.val-fg_color} to
  {!Color.grey}.
*)
let handle_props = Props.props_prop ~after:[Props.Resize]
  ~default:default_handle_props ~inherited:false "paned_handle_props"

(** Property ["paned_user_set_handle_live_update"] defines whether
  to update paned widget on each move of a handle by user ([true]),
  or wait for the user to end moving the handle ([false]).
  Default is [true]. It may be useful to set it to [false] when computation
  of children sizes may take some time. *)
let user_set_handle_live_update =
  Props.bool_prop ~after:[Props.Resize]
    ~default:true ~inherited:false "paned_user_set_handle_live_update"

let css_user_set_handle_live_update = Theme.bool_prop user_set_handle_live_update

(*
let honor_child_min_size = Props.bool_prop ~after:[Props.Resize]
  ~default:true ~inherited:false "paned_honor_child_min_size"
*)

(** Paned widget.

  Contains children widget separated by handles. Horizontal (or vertical
  if orientation is [Vertical]) space allocated to each child depends
  on handle positions. The first handle position defines how to distribute
  paned widget space between first and second children. The second handle
  position indicate how to distribube the remaining space between the
  second and third childreb, and so on.

  The widget has class ["vertical"] or ["horizontal"] depending on orientation.
*)
class paned ?classes ?name ?props ?wdata () =
  object(self)
    inherit Container.container_list ?classes ?name ?props ?wdata () as super
    inherit Widget.oriented as oriented

    (**/**)

    method kind = "paned"

    (* coordinates of handles relative to g_inner *)
    val mutable g_handles = ([] : G.t list)
    val mutable handle_cursor =
      let> c = Sdl.(create_system_cursor System_cursor.size_ns) in
      c
    val mutable cursor_on_handle = false
    val mutable state_machine = Misc.empty_state_machine

    method! private themable_props = handle_props :: super#themable_props

    (**/**)

    (** {2 Properties} *)

    method handle_props = self#get_p handle_props
    method set_handle_props = self#set_p handle_props

    method handle_positions = self#get_p handle_positions
    method set_handle_positions = self#set_p handle_positions

    method user_handle_positionning = self#get_p user_handle_positionning
    method set_user_handle_positionning = self#set_p user_handle_positionning

    method user_set_handle_live_update = self#get_p user_set_handle_live_update
    method set_user_set_handle_live_update = self#set_p user_set_handle_live_update
(*
    method honor_child_min_size = self#get_p honor_child_min_size
    method set_honor_child_min_size = self#set_p honor_child_min_size
*)

    (** {2 Children} *)

    (** [o#children_widgets] returns the list of children widget of [o]. *)
    method children_widgets = List.map (fun c -> c.widget) self#children

    (** [o#reorder_child w pos] moves child widget [w] to new position [pos]
       (if possible). *)
    method reorder_child w pos = super#reorder_child w pos

    (**/**)
    method private width_constraints_ =
      let min = self#widget_min_width in
      let inter_padding = Props.(get self#handle_props width) in
      match self#orientation with
      | Horizontal -> Box.width_constraints_horizontal children ~inter_padding min
      | Vertical -> Box.width_constraints_vertical children ~inter_padding min

    method private height_constraints_ =
      let min = self#widget_min_height in
      let inter_padding = Props.(get self#handle_props width) in
      match self#orientation with
      | Horizontal -> Box.height_constraints_horizontal children ~inter_padding min
      | Vertical -> Box.height_constraints_vertical children ~inter_padding min

    method private min_handles_width =
      let vchildren = self#visible_children in
      match self#orientation with
      | Horizontal ->
        let w = Props.(get self#handle_props width) in
        (max 0 (List.length vchildren - 1)) * w
      | Vertical -> 0

    method private min_handles_height =
      let vchildren = self#visible_children in
      match self#orientation with
      | Horizontal ->
          let w = Props.(get self#handle_props width) in
          (max 0 (List.length vchildren - 1)) * w
      | Vertical -> 0

    method private set_geometry_horizontal =
      let handle_w = Props.(get self#handle_props width) in
      let rec iter acc vchildren handle_pos x =
        match vchildren with
        | [] -> List.rev acc
        | [w] ->
            w#set_geometry { G.x ; y = 0 ; w = g_inner.w - x ; h = g_inner.h };
            List.rev acc
        | w1 :: qw ->
            let remain_w = max 0 (g_inner.w - x - handle_w) in
            let (target_w, qpos) =
              match handle_pos with
              | [] as q
              | None :: q -> remain_w / 2, q
              | (Some (`Absolute p)) :: q -> min remain_w p, q
              | (Some (`Percent p)) :: q ->
                  truncate (float remain_w *. (p /. 100.)), q
            in
            let g1 =
              let w =
                let wc = w1#width_constraints in
                let w = max wc.min target_w in
                match wc.max_abs with
                | None -> w
                | Some maxw -> min w maxw
              in
              { G.x ; y = 0 ; w ; h = g_inner.h }
            in
            w1#set_geometry g1;
            let gh = { G.x = g1.x + g1.w ; y = 0 ; w = handle_w ; h = g_inner.h } in
            iter (gh :: acc) qw qpos (gh.x + gh.w)
      in
      g_handles <- iter [] self#visible_children self#handle_positions 0

    method private set_geometry_vertical =
      let handle_h = Props.(get self#handle_props width) in
      let rec iter acc vchildren handle_pos y =
        match vchildren with
        | [] -> List.rev acc
        | [w] ->
            w#set_geometry { G.x = 0 ; y ; w = g_inner.w ; h = g_inner.h - y };
            List.rev acc
        | w1 :: qw ->
            let remain_h = max 0 (g_inner.h - y - handle_h) in
            let (target_h, qpos) =
              match handle_pos with
              | [] as q
              | None :: q -> remain_h / 2, q
              | (Some (`Absolute p)) :: q -> min remain_h p, q
              | (Some (`Percent p)) :: q ->
                  truncate (float remain_h *. (p /. 100.)), q
            in
            let g1 =
              let h =
                let hc = w1#height_constraints in
                let h = max hc.min target_h in
                match hc.max_abs with
                | None -> h
                | Some maxh -> min h maxh
              in
              { G.x = 0 ; y ; w = g_inner.w ; h }
            in
            w1#set_geometry g1;
            let gh = { G.x = 0; y = g1.y + g1.h ; w = g_inner.w ; h = handle_h } in
            iter (gh :: acc) qw qpos (gh.y + gh.h)
      in
      g_handles <- iter [] self#visible_children self#handle_positions 0

    method! set_geometry geom =
      super#set_geometry geom ;
      [%debug "%s#set_geometry g=%a" self#me G.pp g];
      (match self#orientation with
      | Horizontal -> self#set_geometry_horizontal
      | Vertical -> self#set_geometry_vertical);
      self#need_render g

    (**/**)

    (** [o#pack w] adds widget [w] to [o]. Optional parameter
        [pos] indicates a position to insert [w]; default is to
          append [w] to children.
        Optional parameter [data] associates the given value to [w].
    *)
    method pack ?pos ?data w =
      [%debug "%s#add %s" self#me w#me];
      match super#add ?pos ?data w with
      | false -> ()
      | true -> if w#visible then self#need_resize

    (** [o#unpack w] removes child widget [w] from [o]. *)
    method unpack (w : Widget.widget) =
      match super#remove w with
      | false -> ()
      | true -> if w#visible then self#need_resize

    (** [o#unpack_all ~destroy] removes all children from [o]. [destroy]
       indicates whether to call [#destroy] on children after removing. *)
    method unpack_all ~destroy =
      match self#children_widgets with
      | [] -> ()
      | l ->
          let old_nr = ignore_need_resize in
          self#ignore_need_resize ;
          List.iter
            (fun w ->
              self#unpack w;
              if destroy then w#destroy
            )
            l;
          if not old_nr then
            (self#handle_need_resize ;
             self#need_resize)

    (**/**)

    (* coordinates relative to g_inner *)
    method private handle_from_coords ~x ~y =
      let rec iter n = function
      | [] -> None
      | gh :: q ->
          let gh = match self#orientation with
            | Horizontal -> G.enlarge ~w:2 gh
            | Vertical -> G.enlarge ~h:2 gh
          in
          if G.inside ~x ~y gh then Some n else iter (n+1) q
      in
      iter 0 g_handles

    method private user_set_handle_pos n ~x ~y =
      let rec iter acc prev_bound i (lgh : G.t list) lpos =
        match lgh with
        | [] -> List.rev acc
        | gh :: qgh when i = n ->
            let bound = match self#orientation with
              | Horizontal ->
                  max 0 ((min x g_inner.w) - prev_bound)
              | Vertical ->
                  max 0 ((min y g_inner.h) - prev_bound)
            in
            let bound =
              match self#user_handle_positionning with
              | `Absolute -> `Absolute bound
              | `Percent ->
                  let limit =
                    match self#orientation with
                    | Horizontal -> g_inner.w
                    | Vertical -> g_inner.h
                  in
                  `Percent ((float bound /. float (limit - prev_bound)) *. 100.)
            in
            let lpos =
              match lpos with
              | [] -> [Some bound]
              | _ :: lpos -> (Some bound) :: lpos
            in
            (List.rev acc @ lpos)
        | gh :: qgh ->
            let prev_bound =
              match self#orientation with
              | Horizontal -> gh.x + gh.w + 1
              | Vertical -> gh.y + gh.h + 1
            in
            let (acc, lpos) =
              match lpos with
              | [] -> None :: acc, []
              | p :: q -> (p :: acc), q
            in
            iter acc prev_bound (i+1) qgh lpos
      in
      let new_pos = iter [] 0 0 g_handles self#handle_positions in
      [%debug "%s#user_set_handle_pos n=%d x=%d y=%d handle_positions=%a"
        self#me n x y (Props.pp_prop handle_positions) new_pos];
      self#set_handle_positions new_pos

    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 private restore_cursor = Sdl.set_cursor self#top_widget#cursor

    method state_on_event state pos ev =
      match state, pos, Sdl.Event.(enum (get ev typ)) with
      | `Base, Some(x,y), `Mouse_motion ->
          (
           (* change cursor if needed *)
           (*Log.warn (fun m -> m "%s#state_on_event mouse_motion g=%a x=%d y=%d"
              self#me G.pp g x y);*)
           let (x, y) = self#to_g_inner_coords ~x ~y in
           match self#handle_from_coords ~x ~y, cursor_on_handle with
           | None, false -> None
           | None, true ->
               self#restore_cursor ;
               cursor_on_handle <- false;
               None
           | Some _, true -> None
           | Some _, false ->
               cursor_on_handle <- true ;
               Sdl.set_cursor (Some handle_cursor);
               None
          )
      | `Moving_handle n, Some (x, y), `Mouse_motion ->
          if G.inside ~x ~y g then
            (
             let (x, y) = self#to_g_inner_coords ~x ~y in
             if self#user_set_handle_live_update then
               self#user_set_handle_pos n ~x ~y;
             Some (`Moving_handle n, true)
            )
          else
            (
             cursor_on_handle <- false ;
             self#restore_cursor ;
             Some (`Base, false)
            )
      | `Base, Some (x,y), `Mouse_button_down ->
          let button = Sdl.Event.(get ev mouse_button_button) in
          if button = 1 then
            let (x, y) = self#to_g_inner_coords ~x ~y in
            match self#handle_from_coords ~x ~y with
            | None -> None
            | Some n -> Some (`Moving_handle n, true)
          else
            None
      | `Moving_handle n, Some (x, y), `Mouse_button_up ->
          let (x, y) = self#to_g_inner_coords ~x ~y in
          self#user_set_handle_pos n ~x ~y;
          Some (`Base, false)
      | (`Base|`Moving_handle _), _, _ -> None

    method! render_me (rend:Sdl.renderer) ~offset:(x,y) (rg:G.t) =
      let off_x = g.x + g_inner.x in
      super#render_me rend ~offset:(x,y) rg ;
      let off_y = g.y + g_inner.y in
      let offset = (x + off_x, y + off_y) in
      let rg = G.translate ~x:(-off_x) ~y:(-off_y) rg in
      List.iter (self#render_handle rend ~offset rg) g_handles

    method render_handle rend ~offset:(x,y) rg gh =
      match G.inter rg gh with
      | None -> ()
      | Some clip ->
          let clip = G.translate ~x ~y clip in
          let f rend =
            let gh = G.translate ~x ~y gh in
            let col = Props.(get self#handle_props fg_color) in
            Render.fill_rect rend (Some gh) col
          in
          Render.with_clip rend (G.to_rect clip) f

    method! destroy =
      super#destroy ;
      Sdl.free_cursor handle_cursor

    initializer
      state_machine <- Misc.mk_state_machine `Base self#state_on_event ;
      ignore(self#connect (Object.Prop_changed Props.orientation)
       (fun ~prev ~now ->
          Sdl.free_cursor handle_cursor ;
          let> c = Sdl.(create_system_cursor
             System_cursor.(
              match self#orientation with
              | Horizontal -> size_we
              | Vertical -> size_ns))
          in
          handle_cursor <- c
       ))

  end

type Widget.widget_type += Paned of paned

let paned orientation ?classes ?name ?user_set_handle_live_update ?props ?wdata ?pack () =
  let w = new paned ?classes ?name ?props ?wdata () in
  w#set_typ (Paned w);
  w#set_orientation orientation ;
  Option.iter w#set_user_set_handle_live_update user_set_handle_live_update ;
  Widget.may_pack ?pack w ;
  w

let hpaned = paned Horizontal
let vpaned = paned Vertical