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

(** Table widget. *)

let p_rows = Props.(int_prop ~after:[Resize] ~default:0 ~inherited:false "rows")
let p_columns = Props.(int_prop ~after:[Resize] ~default:0 ~inherited:false "columns")

(** Property ["column_inter_padding"] use to specify a space between two columns.
  Default is [0]. *)
let column_inter_padding = Props.int_prop ~inherited:false ~default:0 "column_inter_padding"

let css_column_inter_padding = Theme.int_prop column_inter_padding

(** Property ["row_inter_padding"] use to specify a space between two rows.
  Default is [0]. *)
let row_inter_padding = Props.int_prop ~inherited:false ~default:0 "row_inter_padding"

let css_row_inter_padding = Theme.int_prop row_inter_padding

(**/**)

module Int_elt = struct
    type t = int
    let to_string = string_of_int
    module Map = Map.Make(Int)
end
module IPacker = Packer.Make(Int_elt)

(**/**)

(** A widget containing widgets in a fixed number of rows and columns.
  It specialises {!Container.class-container} to store children widgets in arrays.
*)
class ['a] table ?classes ?name ?props ?wdata () =
  object(self)
    inherit ['a, int*int] Container.container ?classes ?name ?props ?wdata () as super

    (**/**)
    method kind = "table"
    val mutable children = ([| |]:'a Container.child option array array)

    (**/**)

    (** {2 Properties} *)

    method column_inter_padding = self#get_p column_inter_padding
    method set_column_inter_padding = self#set_p column_inter_padding
    method row_inter_padding = self#get_p row_inter_padding
    method set_row_inter_padding = self#set_p row_inter_padding

    method rows = self#get_p p_rows
    method columns = self#get_p p_columns

    (** [table#set_rows n] resizes [table], changing only number of rows. *)
    method set_rows rows = self#resize ~rows ~columns:self#columns

    (** [table#set_columns n] resizes [table], changing only number of columns. *)
    method set_columns columns = self#resize ~rows:self#rows ~columns

    (** [resize ~rows ~columns] resizes table. No need to repack
      widgets remaining in the new range of rows and columns. Other
      widgets are unpacked. *)
    method resize ~rows ~columns =
      let rows_now = Array.length children in
      let row_resize =
        if rows_now > rows then
          (self#remove_rows (rows_now - rows) ; true)
        else if rows_now < rows then
            (self#add_rows (rows - rows_now); true)
          else
            false
      in
      let cols_now = if rows <= 0 then 0 else Array.length children.(0) in
      let col_resize =
        if cols_now > columns then
          (self#remove_columns ~now:cols_now ~target:columns; true)
        else if cols_now < columns then
            (self#add_columns ~now:cols_now ~target:columns; true)
          else
            false
      in
      self#ignore_need_resize_do (fun () ->
         if row_resize then self#set_p p_rows rows;
         if col_resize then self#set_p p_columns columns
      );
      if row_resize || col_resize then self#need_resize

    (** {2 Children } *)

    method children = children
    method children_widgets = Misc.array_array_map
      (Option.map (fun c -> c.Container.widget)) children

    (**/**)

    method private find_child_opt pred =
      let pred = function None -> false | Some c -> pred c in
      match Misc.array_array_find_opt pred children with
      | None -> None
      | Some x -> x
    method private find_child_pos_opt pred =
      let pred = function None -> false | Some c -> pred c in
      Misc.array_array_find_index pred children
    method private iter_children f =
      let f = function None -> () | Some c -> f c in
      Array.iter (fun t -> Array.iter f t) children
    method private fold_children_right f acc =
      let f x acc = match x with None -> acc | Some c -> f c acc in
      Misc.array_array_fold_right f children acc
    method private fold_children_left f acc =
      let f acc x = match x with None -> acc | Some c -> f acc c in
      Misc.array_array_fold_left f acc children

    method! wtree = N (self#coerce,
       self#fold_children_right (fun c acc -> c.Container.widget#wtree :: acc) [])

    method private remove_rows n =
      let now = Array.length children in
      for i = 1 to n do
        Array.iter (function None -> () | Some c -> self#unpack c.Container.widget)
          children.(now - i)
      done;
      children <- Array.sub children 0 (now - n)

    method private add_rows n =
      let now = Array.length children in
      let c = Array.init (now+n) (fun _ -> Array.make self#columns None) in
      Array.blit children 0 c 0 now ;
      children <- c

    method private remove_columns ~now ~target =
      children <- Array.map
        (fun row ->
           Array.iteri (fun i -> function
              | Some c when i > target -> self#unpack c.Container.widget
              | _ -> ()) row;
           Array.sub row 0 target
        ) children

    method private add_columns ~now ~target =
      children <- Array.map
        (fun row ->
           let r = Array.make target None in
           Array.blit row 0 r 0 now;
           r
        ) children

    (**/**)

    method widget_at ~row ~column =
      if row < 0 || row >= self#rows ||
        column < 0 || column >= self#columns then
        None
      else
        match children.(row).(column) with
        | None -> None
        | Some c -> Some c.Container.widget

    method child_at ~row ~column =
      if row < 0 || row >= self#rows ||
        column < 0 || column >= self#columns then
        None
      else
        children.(row).(column)

    method widget_pos w = self#widget_index w

    (**/**)

    method private min_row_height i =
      Array.fold_left
        (fun (h,vexpand) -> function
           | None -> (h, vexpand)
           | Some (c:'a Container.child) ->
               if c.widget#visible && c.widget#vexpand >= 0
               then (max c.widget#min_height h, max c.widget#vexpand vexpand)
               else (h, vexpand)
        ) (0, 0) children.(i)

    method private min_col_width j =
      Array.fold_left
        (fun (w,hexpand) row ->
           match row.(j) with
           | None -> (w, hexpand)
           | Some (c:'a Container.child) ->
               if c.widget#visible && c.widget#hexpand >= 0
               then (max c.widget#min_width w, max c.widget#hexpand hexpand)
               else (w, hexpand)
        ) (0, 0) children

    method! private min_width_ =
      let w = ref 0 in
      for j = 0 to self#columns - 1 do
         w := !w + (fst (self#min_col_width j))
      done;
      super#min_width_ + !w + (max 0 (self#columns - 1)) * self#column_inter_padding

    method! private min_height_ =
      let (h,i) = Array.fold_left
        (fun (acc,i) t -> (acc + fst (self#min_row_height i), i+1)) (0,0) children
      in
      super#min_height_ + h + (max 0 (self#rows - 1)) * self#row_inter_padding

    (**/**)

    (** [o#pack w] adds widget [w] to [o]. Optional parameters are:
      {ul
       {- [pos], a pair [(row,column)] indicates a position to insert [w];
          default is to pack [w] to the first empty table cell. }
       {- [hexpand] (resp. [vexpand]) sets {!Props.hexpand} (resp.
          {!Props.vexpand}) property of [w] to the given value. }
       {- [hfill] (resp. [vfill]) sets {!Props.hfill} (resp.
          {!Props.vfill}) property of [w] to the given value. }
       {- [data] associates the given value to [w]. All data associated
          to children must have the same type (this type is the type
          parameter of class {!class-table}. }
      }
       To allocate space for table cells, the same algorithm as in
       {!Pack.box#pack} is applied, but handling both horizontal
       and vertical sizes and expand values of each widget.
    *)
    method pack ?pos ?hexpand ?vexpand ?hfill ?vfill ?data w =
      [%debug "%s#pack %s" self#me w#me];
      Pack.set w Props.hexpand hexpand ;
      Pack.set w Props.vexpand vexpand ;
      Pack.set w Props.hfill hfill ;
      Pack.set w Props.vfill vfill ;
      (match pos with
       | None -> ()
       | Some (i,j) ->
           if i < 0 || j < 0 || i >= self#rows || j >= self#columns then
             failwith (Printf.sprintf "Invalid position (%d,%d) in table of size (%d,%d)"
              i j self#rows self#columns)
      );
      match super#add ?pos w data 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_at ~row ~columns] removes child widget [w] at given position, if any.
       [destroy] indicates whether to call [#destroy] on children after removing. *)
    method unpack_at ~destroy ~row ~column =
      match self#widget_at ~row ~column with
      | None -> ()
      | Some w ->
          self#unpack w;
          if destroy then w#destroy

   (** [o#unpack_all ~destroy] removes all children from [o]. [destroy]
       indicates whether to call [#destroy] on children after removing. *)
    method unpack_all ~destroy =
      self#ignore_need_resize_do
        (fun () ->
           self#iter_children
             (fun c ->
                let w = c.Container.widget in
                self#unpack w;
                if destroy then w#destroy
             )
        );
      self#need_resize

   (**/**)
    method! set_geometry geom =
      super#set_geometry geom ;
      [%debug "%s#set_geometry g=%a g_inner=%a"
         self#me G.pp g G.pp g_inner];
      if Array.length children > 0 && Array.length children.(0) > 0 then
        self#set_children_geometry geom ;
      self#need_render ~layer:(self#get_p Props.layer) g

    method private set_children_geometry geom =
      let row_ip = self#row_inter_padding in
      let col_ip = self#column_inter_padding in
      [%debug "%s#set_children_geometry row_inter_padding=%d, column_inter_padding=%d"
         self#me row_ip col_ip];
      let w = self#min_width in
      let w = max w geom.w in
      let w = w - super#min_width_ in
      let w_avail =
        let spaces = (max 0 (self#columns - 1)) * col_ip in
        max 0 (w - spaces)
      in
      let col_widths = Array.init self#columns self#min_col_width in
      let mcols = IPacker.compute w_avail
        (fun col -> fst col_widths.(col))
          (fun col -> None)
          (fun col -> snd col_widths.(col))
          (Array.to_list (Array.init self#columns (fun i -> i)))
      in
      let h = self#min_height in
      let h = max h geom.h in
      let h = h - super#min_height_ in
      let h_avail =
        let spaces = (max 0 (self#rows - 1)) * row_ip in
        max 0 (h - spaces)
      in
      let row_heights = Array.init self#rows self#min_row_height in
      let mrows = IPacker.compute h_avail
        (fun row -> fst row_heights.(row))
          (fun row -> None)
          (fun row -> snd row_heights.(row))
          (Array.to_list (Array.init self#rows (fun i -> i)))
      in
      let _ =
        Array.fold_left
          (fun (y,i) row ->
             [%debug "%s#set_children_geometry (%d,%d) row -> "
                self#me y i];
             [%debug "%s: mrows=%s" self#me
                (String.concat ", " (List.map (fun (i, _) -> Printf.sprintf "%d=>..." i)
                  (Int_elt.Map.bindings mrows)))];
             match Int_elt.Map.find_opt i mrows with
             | None -> (* no widget on row *)
                 y, i+1
             | Some trow ->
                 Array.fold_left
                   (fun (x,j) col ->
                      match Int_elt.Map.find_opt j mcols with
                      | None -> (* no widget in col *)
                          x,j+1
                      | Some tcol ->
                          let () =
                            match children.(i).(j) with
                            | None -> ()
                            | Some (c:'a Container.child) ->
                                let wid = c.widget in
                                if wid#visible then
                                  (
                                   let w =
                                     if wid#hfill
                                     then tcol.current
                                     else tcol.min
                                   in
                                   let h =
                                     if wid#vfill
                                     then trow.current
                                     else trow.min
                                   in
                                   let geo = { G.x; y ; w ; h } in
                                   wid#set_geometry geo
                                  )
                          in
                          (x + tcol.current + col_ip, j+1)
                   ) (0,0) row;
                 (y + trow.current + row_ip, i+1)
          ) (0,0) children
      in
      [%debug "%s#wtree: %a" self#me Widget.pp_widget_tree self#wtree];
      ()

    method! grab_focus ?(last=false) () =
      [%debug "%s#grab_focus ~last:%b" self#me last];
      if self#visible then
        match self#get_p Props.can_focus with
        | false -> false
        | true ->
            match super#grab_focus ~last () with
            | true -> true
            | false ->
                let rows = Array.length children in
                let cols = self#columns in
                let rec iter_col row j =
                  if j >= cols || j < 0 then
                    false
                  else
                    match row.(j) with
                    | None -> iter_col row (if last then j-1 else j+1)
                    | Some c ->
                        match c.Container.widget#visible, c.widget#get_p Props.can_focus with
                        | true, true ->
                            (match c.widget#grab_focus ~last () with
                             | false -> iter_col row (if last then j-1 else j+1)
                             | true -> true)
                        | _ -> iter_col row (if last then j-1 else j+1)
                in
                let rec iter i =
                  if i >= rows || i < 0 then
                    false
                  else
                    let row = children.(i) in
                    match iter_col row (if last then cols - 1 else 0) with
                    | false -> iter (if last then i-1 else i+1)
                    | true -> true
                in
                iter (if last then rows - 1 else 0)
      else
        false

    method private child_move_focus (w:Widget.widget) ~forward ~last on_none =
      let id = w#id in
      match self#find_child_pos_opt (fun c -> Oid.equal c.widget#id id) with
      | None -> on_none ()
      | Some (i,j) ->
          let rows = self#rows in
          let cols = self#columns in
          let next =
            match forward with
            | true ->
                (fun (i,j) ->
                   let j = j+1 in
                   if j < cols then Some (i,j)
                   else
                     let i = i + 1 in
                     if i < rows
                     then Some (i,0)
                     else None
                )
            | false ->
                (fun (i,j) ->
                   let j = j-1 in
                   if j > 0 then Some (i,j)
                   else
                     let i = i - 1 in
                     if i >= 0
                     then Some (i,cols-1)
                     else None
                )
          in
          let rec iter = function
          | None -> on_none ()
          | Some (i, j) ->
                match children.(i).(j) with
                | None -> iter (next (i,j))
                | Some next_c ->
                    if next_c.Container.widget#visible then
                      match next_c.widget#grab_focus ~last () with
                      | false -> iter (next (i,j))
                      | true -> true
                    else
                      iter (next (i,j))
          in
          iter (next (i,j))

    method! child_focus_next (w:Widget.widget) =
      self#child_move_focus w ~forward:true ~last:false
        (fun () -> self#focus_next)

    method! child_focus_prev (w:Widget.widget) =
      self#child_move_focus w ~forward:false ~last:true
        (fun () -> self#focus_prev)

    method private find_first_empty =
      Misc.array_array_find_index
        (function Some _ -> false | None -> true) children

    method private add_to_children ?pos c =
      let pos =
        match pos with
        | None ->
            (match self#find_first_empty with
             | None ->
                 Log.warn (fun m -> m "%s: could not add widget %s, no empty cell in table"
                    self#me c.Container.widget#me);
                 None
             | x -> x)
        | Some (i,j) ->
            Option.iter (fun c -> c.Container.widget#set_parent None) children.(i).(j) ;
            Some (i,j)
      in
      match pos with
      | None -> ()
      | Some (i,j) -> children.(i).(j) <- Some c

    method private remove_from_children w =
      let id = w#id in
      match self#find_child_pos_opt (fun c -> Oid.equal c.widget#id id) with
      | None -> false
      | Some (i,j) -> children.(i).(j) <- None; true

    method private children_as_list =
      let f e acc = match e with None -> acc | Some x -> x :: acc in
      Misc.array_array_fold_right f children []

    method! next_widget ?inside ~loop pred w =
      let children = self#children_as_list in
      let rec iter = function
      | [] ->
          (match inside, parent with
           | Some i,_ when self#equal i ->
               if loop then self#next_widget ?inside ~loop pred None else None
           | _, None -> None
           | _, Some p -> p#next_widget ?inside ~loop pred (Some self#coerce))
      | c :: q when pred c.Container.widget -> Some c.widget
      | c :: q ->
          match c.widget#next_widget ?inside ~loop pred None with
          | None -> iter q
          | x -> x
      in
      match w with
      | None -> iter children
      | Some w ->
          let rec find = function
          | [] -> iter []
          | c :: q when c.Container.widget#equal w -> iter q
          | _ :: q -> find q
          in
          find children

    method! prev_widget ?inside ~loop pred w =
      let children = self#children_as_list in
      let rec iter = function
      | [] ->
          (match inside, parent with
           | Some i, _ when self#equal i ->
               if loop then self#prev_widget ?inside ~loop pred None else None
           | _, None -> None
           | _, Some p -> p#prev_widget ?inside ~loop pred (Some self#coerce))
      | c :: q when pred c.Container.widget -> Some c.widget
      | c :: q ->
          match c.widget#prev_widget ?inside ~loop pred None with
          | None -> iter q
          | x -> x
      in
      match w with
      | None -> iter (List.rev children)
      | Some w ->
          let rec find = function
          | [] -> iter []
          | c :: q when c.Container.widget#equal w -> iter q
          | _ :: q -> find q
          in
          find (List.rev children)

    initializer
      self#resize ~rows:self#rows ~columns:self#columns
  end

let table ?classes ?name ?props ?wdata ?(rows=1) ?(columns=1) ?pack () =
  let w = new table ?classes ?name ?props ?wdata () in
  w#resize ~rows ~columns ;
  Widget.may_pack ?pack w ;
  w