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

(** Notebook widget. *)

open Misc
open Tsdl
open Widget
open Container
open Pack

(** The ["active_page"] property, representing the 0-based index
  of the active (i.e. displayed) page in a notebook. *)
let active_page = Props.int_prop ~inherited:false "active_page"

(** Property ["tab_props"] to store properties used for notebook tabs. *)
let tab_props = Props.props_prop ~default:(Props.empty()) "tab_props"

(** Notebook widget.

  A notebook widget is a [[Widget.widget] Container.container], i.e. a
  widget containing contents widgets (the pages), each one being associated to
  a widget representing this page in the list of displayed tabs.

  A notebook can be oriented vertically (tabs are on the left and
  and are packed vertically) or horizontally (tabs are on top and
  and are packed horizontally).
*)
class notebook ?classes ?name ?props ?wdata () =
  object(self)
    inherit [Widget.widget] Container.container_list ?classes ?name ?props ?wdata () as super
    inherit Widget.oriented as oriented
    (**/**)
    method kind = "notebook"
    val mutable tab_box = new Pack.box ()
    method private tab_box = tab_box

    method set_orientation o =
      oriented#set_orientation o;
      tab_box#set_p Props.orientation o;
      self#apply_theme

    method! do_apply_theme ~root ~parent parent_path rules =
      super#do_apply_theme ~root ~parent parent_path rules;
      let path = self#css_path ~parent_path () in
      tab_box#do_apply_theme ~root ~parent:theme_props path rules;
      min_width <- None ;
      min_height <- None

    (**/**)

    method active_page = self#opt_p active_page

    (** Make page [p] the active page (0-based index). *)
    method set_active_page p = self#set_active_page_ ~force:false p

    (** [nb#get_page None] returns [None].
        [nb#get_page (Some n)] returns [None] if [n]-th page does not exist,
        or [Some (label_widget, page_widget)].*)
    method get_nth n =
      match n with
      | None -> None
      | Some n ->
          match List.nth_opt self#children n with
          | None -> None
          | Some c -> Some (c.data, c.widget)

    (**/**)
    method private set_active_page_ ?(force=false) p =
      [%debug "%s#set_active_page_ %d" self#me p];
      (*Log.warn (fun m ->
        List.iter
          (fun c -> m "begin %s#set_active_page_ child %s visible: %b" self#me
            c.widget#me c.widget#visible) children);*)
      let len = List.length self#children in
      if p < 0 || p >= len then
        false
      else
        (
         let () =
           match self#active_page with
           | Some prev when prev < len && (prev <> p || force) ->
               (
                let c = List.nth self#children prev in
                c.widget#set_visible false ;
                [%debug "%s#set_active_page_: set is_focus to false for %s"
                   self#me c.widget#me];
                c.widget#set_p Props.is_focus false ;
                c.data#set_selected false;
                match c.data#parent with
                | None -> ()
                | Some p -> p#set_selected false
               )
           | _ -> ()
         in
         let c = List.nth self#children p in
         c.widget#set_visible true ;
         let () =
           c.data#set_selected true;
           match c.data#parent with
           | None -> ()
           | Some p -> p#set_selected true
         in
         self#set_p active_page p ;
         [%debug "%s#set_active_page_: set is_focus to true for %s"
            self#me c.widget#me];
         c.widget#set_p Props.is_focus true ;
         (*Log.warn (fun m ->
            List.iter
              (fun c -> m "end %s#set_active_page_ child %s visible: %b" self#me
                 c.widget#me c.widget#visible) children);*)
         true
        )

    method! wtree =
      N (self#coerce, tab_box#wtree :: List.map (fun c -> c.widget#wtree) children)

    method private tab_widget_by_coords ~x ~y =
      List.find_opt
        (fun w -> G.inside ~x ~y w#geometry) tab_box#children_widgets

    method! private child_by_coords ~x ~y =
      let (px, py) =
        let g = tab_box#geometry in
        (x - g.x - g_inner.x, y - g.y - g_inner.y)
      in
      List.find_opt (fun c ->
         G.inside ~x:px ~y:py c.data#geometry
           || (c.widget#visible && G.inside ~x ~y c.widget#geometry))
           children

    method private tabs_width = tab_box#min_width
    method private tabs_height = tab_box#min_height

    method! private min_width_ =
      let width_tabs = self#tabs_width in
      super#min_width_ +
        (match self#orientation with
         | Props.Horizontal ->
             max width_tabs
               (match self#active_page with
                | None -> 0
                | Some p ->
                    match List.nth_opt self#children p with
                    | None -> 0
                    | Some c -> c.widget#min_width)
         | Vertical ->
             width_tabs +
               (match self#active_page with
                | None -> 0
                | Some p ->
                    match List.nth_opt self#children p with
                    | None -> 0
                    | Some c -> c.widget#min_width)
        )

    method! private min_height_ =
      let height_tabs = self#tabs_height in
      super#min_height_ +
        (match self#orientation with
         | Horizontal ->
             height_tabs +
               (match self#active_page with
                | None -> 0
                | Some p ->
                    match List.nth_opt self#children p with
                    | None -> 0
                    | Some c -> c.widget#min_height)
         | Vertical ->
             max height_tabs
               (match self#active_page with
               | None -> 0
               | Some p ->
                    match  List.nth_opt self#children p with
                    | None -> 0
                    | Some c -> c.widget#min_height)
        )

    method! max_width = None
    method! max_height = None

    method private pack_label ?pos w =
      let b = Bin.bin ~classes:["tab"] () in
      b#set_handle_hovering true ;
      let _ = b#connect Widget.Clicked
        (fun bev ->
          if bev.button = 1 then
            match tab_box#widget_index b#as_widget with
            | None -> false
            | Some p -> self#set_active_page_ p
          else
             false
        )
      in
      b#set_child w ;
      tab_box#pack ?pos ~hexpand:0 ~vexpand:0 ~data:w b#as_widget;
      b

    method private pack_pos ?pos ~label (w:Widget.widget)  =
      [%debug "%s#add %s" self#me w#me];
      let old_len = List.length self#children in
      w#set_visible false;
      match super#add ?pos w label#coerce with
      | false -> None
      | true ->
          self#pack_label ?pos label ;
          match self#widget_index w with
          | None -> None
          | Some 0 when old_len <= 0 ->
              (* setting active page will set widget visibilty to true and
                 will trigger a need_resize in our container *)
              if self#set_active_page_ 0 then
                Some 0
              else
                (
                 Log.err (fun m -> m "%s#set_active_page_: page not set active ??" self#me);
                 None
                )
          | Some n ->
              match self#active_page with
              | None ->
                  Log.err (fun m -> m "%s: no active page but page added in position %d"
                     self#me n);
                  if self#set_active_page_ 0 then
                    Some 0
                  else
                    None
              | Some p ->
                  let _ =
                    if n <= p then
                      self#set_active_page_ ~force:true (p+1)
                    else
                      false
                  in
                  Some p

    (**/**)

    (** [#pack ~label w] adds a new page with contents widget [w]
      and label widget [label]. Optional argument [pos] can be
      used to specify a 0-based position for the new page. Default
      is to append the page. *)
    method pack ?pos ~label w =
      let _ = self#pack_pos ?pos ~label w in
      ()

    (**/**)
    method! child_reparented w = self#unpack w
    (**/**)

    (** [unpack w] removes the page corresponding to the (contents) widget [w]. *)
    method unpack (w : Widget.widget) =
      match self#widget_index w with
      | None -> ()
      | Some i ->
          let c = List.nth self#children i in
          [%debug "%s#unpack %s List.nth self#children %d done"
            self#me w#me i];
          match super#remove w with
          | false -> ()
          | true ->
              (match c.data#parent with
              | None -> Log.warn (fun m -> m "Tab label %s has no parent!" c.data#me)
              | Some p -> tab_box#unpack p
              ) ;
              match self#active_page with
              | None -> self#need_resize
              | Some p ->
                  if p = i then
                    (* removing the active page *)
                    let len = List.length self#children in
                    if len <= 0 then
                      ( (* no more pages *)
                       Props.set_opt props active_page None ;
                       self#need_resize;
                       self#need_render ~layer:(self#get_p Props.layer) g
                      )
                    else
                      ( (* set active page the next one, or the previous one
                          if the removed page was the last one *)
                       let p = if i < len then i else max (len - 1) (i-1) in
                       let _ = self#set_active_page_ p in
                       ()
                      )
                  else
                    if p < i then
                      self#need_resize
                    else (* active page > i, decrement the active page *)
                      let _ = self#set_active_page_ (p-1) in
                      ()

    (** [remove_page i] removes the page at index [i]. *)
    method remove_page i =
      match List.nth_opt children i with
      | None -> Log.warn (fun m -> m "%s#remove_page i=%d page not found" self#me i);
      | Some c -> self#unpack c.widget

    (** [find_child p] returns the first page widget [c] for which [p c] returns [true],
      if any. *)
    method find_child pred = self#find_child_opt pred

    (** [widget_index w] returns the page index corresponding to widget [w], if any. *)
    method! widget_index = super#widget_index

    (**/**)
    method private set_geometry_tab_box =
      let g =
        match self#orientation with
        | Horizontal -> G.{x = 0; y = 0; w = g_inner.w ; h = tab_box#min_height }
        | Vertical -> G.{x = 0; y = 0; w = tab_box#min_width ; h = g_inner.h }
      in
      tab_box#set_geometry g

    method! set_geometry geom =
      super#set_geometry geom ;
      [%debug "%s#set_geometry g=%a" self#me G.pp g];
      self#set_geometry_tab_box ;
      let remain =
        let gt = tab_box#geometry in
        match self#orientation with
        | Horizontal ->
            let y = gt.y + gt.h in
            G.{ x = 0 ; y ; w = g_inner.w ; h = g_inner.h - y }
        | Vertical ->
            let x = gt.x + gt.w in
            G.{ x ; y = 0 ; w = g_inner.w - x ; h = g_inner.h }
      in
      List.iter (fun c -> c.widget#set_geometry remain) self#children

    method! private render_me ~layer rend ~offset:(x,y) rg =
      let off_x = g.x + g_inner.x in
      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
      tab_box#render ~layer rend ~offset rg ;
      match self#active_page with
      | None -> ()
      | Some p ->
          match List.nth_opt self#children p with
          | None -> ()
          | Some c -> c.widget#render ~layer ~offset rend rg

    method! child_need_resize w =
      if Oid.equal w#id tab_box#id then
        self#need_resize
      else
        super#child_need_resize w

    method! on_sdl_event_down ~oldpos pos e =
      if self#sensitive then
        match
          let f (x,y) = (x - g.x - g_inner.x , y - g.y - g_inner.y) in
          let oldpos = Option.map f oldpos in
          let pos = Option.map f pos in
          match Sdl.Event.(enum (get e typ)) with
          | `Key_down | `Key_up | `Text_input | `Text_editing ->
              (
               match List.find_opt
                 (fun c -> c.widget#get_p Props.is_focus)
                   children
               with
               | None -> false
               | Some c -> c.widget#on_sdl_event_down ~oldpos pos e
              )
          | _ ->
              List.fold_left
                (fun acc w ->
                   if
                     (match oldpos with
                      | Some (x,y) -> G.inside ~x ~y w#geometry
                      | None -> false
                     ) ||
                       match pos with
                       | Some (x,y) -> G.inside ~x ~y w#geometry
                       | None -> true
                   then
                     (
                      (*Log.warn (fun m -> m "%s#on_sdl_event_down: propagating event to %s"
                         self#me w#me);*)
                      let b = w#on_sdl_event_down ~oldpos pos e in
                      acc || b
                     )
                   else
                     acc
                )
                false
                (let l =
                   match self#active_page with
                   | None -> []
                   | Some p ->
                       match List.nth_opt self#children p with
                       | None -> []
                       | Some c -> [c.widget]
                 in
                 l @ [tab_box#as_widget])
        with
        | true -> true
        | false -> self#on_sdl_event pos e
      else
        false

    method! leaf_widget_at ~x ~y =
      let x = x - g.x - g_inner.x in
      let y = y - g.y - g_inner.y in
      match self#child_by_coords ~x ~y with
      | None -> None
      | Some c ->
          if G.inside ~x ~y c.widget#geometry then
            c.widget#leaf_widget_at ~x ~y
          else
            let (px, py) =
              let g = tab_box#geometry in
              (x - g.x - g_inner.x, y - g.y - g_inner.y)
            in
            c.data#leaf_widget_at ~x:px ~y:py

    method! next_widget ?inside ~loop pred w =
      match w with
      | Some w when w#equal tab_box#coerce ->
          super#next_widget ?inside ~loop pred None
      | _ -> tab_box#next_widget ?inside ~loop pred w

    method! prev_widget ?inside ~loop pred w =
      let rec iter = function
      | [] -> tab_box#prev_widget ?inside ~loop pred None
      | c :: q when pred c.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 when w#equal tab_box#coerce ->
          (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))
      | Some w ->
          let rec find = function
          | [] -> iter []
          | c :: q when c.widget#equal w -> iter q
          | _ :: q -> find q
          in
          find (List.rev children)


    initializer
      tab_box#set_parent ?with_rend:with_renderer (Some self#coerce)

  end

(** Convenient function to create a {!class-notebook}.
  Default [orientation] is [Horizontal].
  The widget has class ["vertical"] or ["horizontal"] depending on orientation.
  See {!Widget.widget_arguments} for other arguments. *)
let notebook ?(orientation=Props.Horizontal) ?classes ?name ?props ?wdata ?pack () =
  let w = new notebook ?classes ?name ?props ?wdata () in
  w#set_orientation orientation;
  Widget.may_pack ?pack w ;
  w

(** Same as {!val-notebook} but orientation is already fixed to [Horizontal].*)
let hnotebook ?classes ?name ?props ?wdata ?pack () =
  notebook ~orientation:Horizontal ?classes ?name ?props ?wdata ?pack ()

(** Same as {!val-notebook} but orientation is already fixed to [Vertical].*)
let vnotebook ?classes ?name ?props ?wdata ?pack () =
  notebook ~orientation:Vertical ?classes ?name ?props ?wdata ?pack ()