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

(** How many rows a widget spans. Default is [1]. *)
let row_span = Props.int_prop ~inherited:false ~default:1 "row_span"

let css_row_span = Theme.int_prop row_span

(** How many columns a widget spans. Default is [1]. *)
let column_span = Props.int_prop ~inherited:false ~default:1 "column_span"

let css_column_span = Theme.int_prop column_span

(**/**)

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)

(**/**)

type position = int * int
type child = Child of Container.child | Span of position

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

    (**/**)
    method kind = "table"
    val mutable children = ([| |]: 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
      (function None -> None
       | Some (Child c) -> Some c.Container.widget
       | Some (Span _) -> None
      ) children

    (**/**)

    method private find_child_opt pred =
      let pred = function
      | None -> false
      | Some (Child c) -> pred c
      | Some (Span _) -> false
      in
      match Misc.array_array_find_opt pred children with
      | Some (Some (Child x)) -> Some x
      | _ -> None
    method private find_child_pos_opt pred =
      let pred = function
      | None -> false
      | Some (Child c) -> pred c
      | Some (Span _) -> false
      in
      Misc.array_array_find_index pred children
    method private iter_children f =
      let f = function
      | None -> ()
      | Some (Child c) -> f c
      | Some (Span _) -> ()
      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 (Child c) -> f c acc
        | Some (Span _) -> 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 (Child c) -> f acc c
        | Some (Span _) -> acc
      in
      Misc.array_array_fold_left f acc children

    method! wtree = Widget.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 (Span _) -> ()
         | Some (Child 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 (Child 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 (Child c) -> Some c.Container.widget
        | Some (Span (row,column)) -> self#widget_at ~row ~column

    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 row_height_constraints i =
      let inter_padding = self#row_inter_padding in
      Array.fold_left
        (fun (acc,vexpand) -> function
           | None -> (acc, vexpand)
           | Some c ->
               let widget = match c with
                 | Child (c:Container.child) -> Some c.widget
                 | Span (row,column) -> self#widget_at ~row ~column
               in
               match widget with
               | None -> (acc, vexpand)
               | Some widget ->
                   let vexp = widget#vexpand in
                   if not widget#visible then
                     (acc, vexpand)
                   else
                     let hc = widget#height_constraints in
                     let row_span = max 1 (widget#get_p row_span) in
                     let minh =
                       if vexp >= 0 then
                         let h = hc.min in
                         let h = h - (row_span - 1) * inter_padding in
                         let h = truncate (ceil (float h /. float row_span)) in
                         max acc.Widget.min h
                       else
                         acc.min
                     in
                     let f acc v =
                       match acc with
                       | None -> None
                       | Some acc ->
                           match v with
                           | None -> None
                           | Some h ->
                               let h = h - (row_span - 1) * inter_padding in
                               let h = truncate (ceil (float h /. float row_span)) in
                               Some (max h acc)
                     in
                     let max_used = f acc.max_used hc.max_used in
                     let max_abs = f acc.max_abs hc.max_abs in
                     let vexp = truncate (ceil (float vexp /. float row_span)) in
                     let acc = { Widget.min = minh ; max_used ; max_abs } in
                     (acc, max vexp vexpand)
        ) (Widget.size_constraints_fixed 0, 0) children.(i)

    method private column_width_constraints j =
      let inter_padding = self#column_inter_padding in
      Array.fold_left
        (fun (acc,hexpand) row ->
           match row.(j) with
           | None -> (acc, hexpand)
           | Some c ->
               let widget = match c with
                 | Child (c:Container.child) -> Some c.widget
                 | Span (row,column) -> self#widget_at ~row ~column
               in
               match widget with
               | None -> (acc, hexpand)
               | Some widget ->
                   let hexp = widget#hexpand in
                   if not widget#visible then
                     (acc, hexpand)
                   else
                     let wc = widget#width_constraints in
                     let col_span = max 1 (widget#get_p column_span) in
                     let minw =
                       if hexp >= 0 then
                         let w = wc.min in
                         let w = w - (col_span - 1) * inter_padding in
                         let w = truncate (ceil (float w /. float col_span)) in
                         max acc.Widget.min w
                       else
                         acc.min
                     in
                     let f acc v =
                       match acc with
                       | None -> None
                       | Some acc ->
                           match v with
                           | None -> None
                           | Some w ->
                               let w = w - (col_span - 1) * inter_padding in
                               let w = truncate (ceil (float w /. float col_span)) in
                               Some (max w acc)
                     in
                     let max_used = f acc.max_used wc.max_used in
                     let max_abs = f acc.max_abs wc.max_abs in
                     let hexp = truncate (ceil (float hexp /. float col_span)) in
                     let acc = { Widget.min = minw ; max_used ; max_abs } in
                     (acc, max hexp hexpand)
        ) (Widget.size_constraints_fixed 0, 0) children

    method private width_constraints_ =
      let c = ref (Widget.size_constraints_fixed 0) in
      for j = 0 to self#columns - 1 do
        let (wc,_) = self#column_width_constraints j in
        [%debug "%s#width_constraints_ column %d: %a" self#me j
           Widget.pp_size_constraints wc];
        c := Widget.size_constraints_add !c wc
      done;
      let more =
        self#widget_min_width +
        (max 0 (self#columns - 1)) * self#column_inter_padding
      in
      let c = Widget.add_to_size_constraints !c more in
      [%debug "%s#width_constraints_ => %a" self#me
           Widget.pp_size_constraints c];
      c

    method private height_constraints_ =
      let (c,i) = Array.fold_left
        (fun (acc,i) t ->
           let (c,_) = self#row_height_constraints i in
           (Widget.size_constraints_add acc c, i+1)
        )
             (Widget.size_constraints_fixed 0, 0) children
      in
      let more =
        self#widget_min_height +
        (max 0 (self#rows - 1)) * self#row_inter_padding
      in
      Widget.add_to_size_constraints c more

    (**/**)

    (** [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. }
       {- [row_span] (resp. [column_span]) sets {!row_span} (resp.
          {!column_span} properties of [w] to the given value.
          Default is to set to 1.}
       {- [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
       {!Box.class-box.pack} is applied, but handling both horizontal
       and vertical sizes and expand values of each widget.
    *)
    method pack ?pos ?row_span:rspan ?column_span:cspan ?hexpand ?vexpand ?hfill ?vfill ?data w =
      [%debug "%s#pack %s" self#me w#me];
      Box.set w Props.hexpand hexpand ;
      Box.set w Props.vexpand vexpand ;
      Box.set w Props.hfill hfill ;
      Box.set w Props.vfill vfill ;
      w#set_p row_span (Option.value ~default:1 rspan);
      w#set_p column_span (Option.value ~default:1 cspan);
      (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 ?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_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 g

    method private set_children_geometry geom =
      [%debug "%s#set_children_geometry geom=%a" self#me G.pp 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 margin = self#margin in
      let w = self#width_constraints.min - margin.left - margin.right in
      let w = max w geom.w in
      let w = w - (self#widget_min_width - margin.left - margin.right) 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#column_width_constraints in
      let mcols = IPacker.compute w_avail
        (fun col -> let (constraints,_) = col_widths.(col) in constraints)
          (fun col -> let (_,hexpand) = col_widths.(col) in hexpand)
          (Array.to_list (Array.init self#columns (fun i -> i)))
      in
      let h = self#height_constraints.min - margin.top - margin.bottom in
      let h = max h geom.h in
      let h = h - (self#widget_min_height - margin.top - margin.bottom) 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#row_height_constraints in
      let mrows = IPacker.compute h_avail
        (fun row -> fst row_heights.(row))
          (fun row -> snd row_heights.(row))
          (Array.to_list (Array.init self#rows (fun i -> i)))
      in
      let get_ map i = match Int_elt.Map.find_opt i map with
        | None -> { Packer.current = 0 ; min = 0 ; max = 0 ; expand = 0; fixed = true ;}
        | Some t -> t
      in
      let get_mcol = get_ mcols in
      let get_mrow = get_ mrows 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 (Span _) -> ()
                            | Some (Child (c:Container.child)) ->
                                let wid = c.widget in
                                if wid#visible then
                                  (
                                   let get b get_t i =
                                     let t = get_t i in
                                     if b then t.Packer.current else t.min
                                   in
                                    let rec iter get stop acc i =
                                     if i > stop
                                     then acc
                                     else iter get stop (acc+get i) (i+1)
                                   in
                                   let col_span = wid#get_p column_span in
                                   let row_span = wid#get_p row_span in
                                   let w = iter (get wid#hfill get_mcol)
                                     (j - 1 + col_span) 0 j
                                   in
                                   let w = w + (col_span - 1) * self#column_inter_padding in
                                   let w = if wid#hfill then w else min wid#width_constraints.min w in
                                   let h = iter (get wid#vfill get_mrow)
                                     (i - 1 + row_span) 0 i
                                   in
                                   let h = h + (row_span - 1) * self#row_inter_padding in
                                   let h = if wid#vfill then h else min wid#height_constraints.min h 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 i row j =
                  if j >= cols || j < 0 then
                    false
                  else
                    match self#widget_at ~row:i ~column:j with
                    | None -> iter_col i row (if last then j-1 else j+1)
                    | Some widget ->
                        match widget#visible, widget#get_p Props.can_focus with
                        | true, true ->
                            (match widget#grab_focus ~last () with
                             | false -> iter_col i row (if last then j-1 else j+1)
                             | true -> true)
                        | _ -> iter_col i 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 i 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 self#child_at ~row:i ~column:j with
              | None | Some (Span _) -> iter (next (i,j))
              | Some (Child c) ->
                  let widget = c.Container.widget in
                  if widget#visible then
                    match 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) ->
            self#unpack_at ~destroy:false ~row:i ~column:j;
            Some (i,j)
      in
      match pos with
      | None -> ()
      | Some (i,j) ->
          let row_span =  c.widget#get_p row_span in
          let col_span =  c.widget#get_p column_span in
          for i2 = i to i - 1 + row_span do
            for j2 = j to j - 1 + col_span do
              if i2 = i && j2 = j then
                children.(i2).(j2) <- Some (Child c)
              else
                children.(i2).(j2) <- Some (Span (i,j))
            done
          done

    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) ->
          let col_span = w#get_p column_span in
          let row_span = w#get_p row_span in
          for i2 = i to i - 1 + row_span do
            for j2 = j to j - 1 + col_span do
              children.(i2).(j2) <- None
            done
          done;
          true

    method private children_as_list =
      let f e acc = match e with
        | None -> acc
        | Some (Span _) -> acc
        | Some (Child 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

type Widget.widget_type += Table of table

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