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

(** Container widget. *)

open Misc
open Tsdl
open Widget

(** Type of data which can be associated to child widgets. *)
type child_data = ..

(** A container child, with optional data associated.*)
type child = {
    widget : Widget.widget ;
    mutable data : child_data option ;
  }


(** A container widget is a widget which can contain other widgets.
The type parameter is the type of the position of a widget in the container.
This class must be inherited, as it is for example
by {!class-container_list}, which specialises this class by using
a list to store children widgets.
*)
class virtual ['pos] container ?classes ?name ?props ?wdata () =
  object(self)
    inherit widget ?classes ?name ?props ?wdata () as super

    (**/**)

    val mutable packed_widgets = Oid.Set.empty

    method private virtual child_by_widget : Widget.widget -> child option
    method private virtual find_child_opt : (child -> bool) -> child option
    method private virtual find_child_pos_opt : (child -> bool) -> 'pos option
    method private virtual iter_children : (child -> unit) -> unit
    method private virtual fold_children_right : 'b. (child -> 'b -> 'b) -> 'b -> 'b
    method private virtual fold_children_left : 'b. ('b -> child -> 'b) -> 'b -> 'b
    method private virtual add_to_children : ?pos:'pos -> child -> unit
    method private virtual remove_from_children : Widget.widget -> bool

    method private child_by_widget (w:Widget.widget) =
      let id = w#id in
      self#find_child_opt (fun c -> Oid.equal c.widget#id id)

    method private child_by_coords ~x ~y =
      self#find_child_opt (fun c ->
         c.widget#visible &&
           G.inside ~x ~y c.widget#geometry)

    method private widget_index (w:Widget.widget) =
      let id = w#id in
      self#find_child_pos_opt (fun c -> Oid.equal c.widget#id id)

    method private widget_data (w:Widget.widget) =
      match self#child_by_widget w with
      | None -> None
      | Some c -> c.data

    method private set_widget_data w data =
      match self#child_by_widget w with
      | None -> Log.warn (fun m -> m "No widget %s in %s" w#me self#me)
      | Some c -> c.data <- data

    method! set_p p ?delay ?(propagate=false) v =
      [%debug "%s#set_p %s ~propagate:%b" self#me (Props.name p) propagate];
      super#set_p ?delay ~propagate p v ;
      match delay, Props.transition p with
      | Some _, Some _ -> ()
      | _ ->
          if propagate then
            self#iter_children (fun c -> c.widget#set_p ~propagate p v)

    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
      self#iter_children (fun c ->
         c.widget#do_apply_theme ~root ~parent:theme_props path rules);
      width_constraints <- None ;
      height_constraints <- None

    method private focused_child =
      self#find_child_opt (fun c -> c.widget#get_p Props.is_focus)

    method! focused_widget =
      if self#is_focus then
        match self#focused_child with
        | None -> Some self#coerce
        | Some c -> c.widget#focused_widget
      else
        None

    method! release_focus =
      match
        match self#focused_child with
        | None -> true
        | Some c -> c.widget#release_focus
      with
      | true ->
          self#set_p Props.is_focus false ;
          self#set_p Props.has_focus false ;
          true
      | _ -> false

    method! get_focus =
      match super#get_focus with
      | None -> None
      | Some has_focus ->
          self#iter_children (fun c -> c.widget#set_p Props.is_focus false);
          Some has_focus

    method! set_has_focus b =
      match super#set_has_focus b with
      | true -> true
      | false ->
          match self#focused_child with
          | None -> false
          | Some c -> c.widget#set_has_focus b

    method private visible_children =
      self#fold_children_right
        (fun c acc ->
           if c.widget#visible then c.widget::acc else acc) []

    method private fold_children_for_sdl_event_down = self#fold_children_left
    method private on_sdl_event_down_stop_on_true = false

    method! on_sdl_event_down ~oldpos pos e =
      [%debug "%s#on_sdl_event_down e=%a" self#me Fmts.pp_event 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 self#find_child_opt
                 (fun c -> c.widget#get_p Props.is_focus)
               with
               | None -> false
               | Some c -> c.widget#on_sdl_event_down ~oldpos pos e
              )
          | _ ->
              let stop_on_true = self#on_sdl_event_down_stop_on_true in
              self#fold_children_for_sdl_event_down
                (fun acc c ->
                   match acc && stop_on_true with
                   | true -> acc
                   | false ->
                       let w = c.widget in
                       if w#visible &&
                         ((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 -> false
                         )
                       then
                         (
                          [%debug "%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
        with
        | true -> true
        | false -> self#on_sdl_event pos e
      else
        false

    method! child_reparented w = self#remove w; self#need_resize

    method private add ?pos ?data w =
      Log.info (fun m -> m "%s#add %s" self#me w#me);
      match Oid.Set.mem w#id packed_widgets with
      | true ->
          Log.warn (fun m -> m "%s is already packed in %s" w#me self#me);
          false
      | false ->
          let old_parent = w#parent in
          match old_parent with
          | Some p when p#equal self#as_widget -> false
          | _ ->
              width_constraints <- None ;
              height_constraints <- None ;
              packed_widgets <- Oid.Set.add w#id packed_widgets ;
              self#add_to_children ?pos { widget = w ; data } ;
              Option.iter (fun p -> p#child_reparented w) old_parent ;
              w#set_parent ?with_rend:with_renderer (Some self#coerce) ;
              true

    method private remove (w:widget) =
      let b = self#remove_from_children w in
      if b then
        (
         packed_widgets <- Oid.Set.remove w#id packed_widgets ;
         width_constraints <- None ;
         height_constraints <- None ;
         w#set_parent None
        )
      else
        Log.warn (fun m -> m "%s is not packed in %s, not removing" w#me self#me);
      b

    method! set_parent ?with_rend w =
      super#set_parent ?with_rend w ;
      self#iter_children
        (fun c -> c.widget#set_parent ?with_rend (Some self#coerce))

    method! child_need_resize w =
      match self#find_child_opt (fun c -> Oid.equal c.widget#id w#id) with
      | None ->
          Log.warn (fun m -> m
             "%s#child_need_resize: %s not in children" self#me w#me);
          ()
      | Some c -> if w#visible then self#need_resize

    method! private render_me 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
      [%debug "%s#render_me x=%d, y=%d, g=%a, g_inner=%a, rg=%a"
        self#me x y G.pp g G.pp g_inner G.pp rg];
      self#iter_children (fun c -> c.widget#render ~offset rend rg)

    method! is_leaf_widget = 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 ->  c.widget#leaf_widget_at ~x ~y

    method! destroy =
      self#iter_children (fun c -> c.widget#destroy) ;
      super#destroy ;
  end

(* This class specialises {!class-container} to store children widgets in a list.
It must be inherited (as it is for example by {!Box.class-box} or {!Box.class-paned}).
*)
class virtual container_list ?classes ?name ?props ?wdata () =
  object(self)
    inherit [int] container ?classes ?name ?props ?wdata () as super

    (**/**)
    val mutable children = ([]:child list)
    method private children = children

    method private find_child_opt pred = List.find_opt pred children
    method private find_child_pos_opt pred = List.find_index pred children
    method private iter_children f = List.iter f children
    method private fold_children_right f acc = List.fold_right f children acc
    method private fold_children_left f acc = List.fold_left f acc children

    method private reorder_child w pos =
      let id = w#id in
      match self#child_by_widget w with
      | None -> ()
      | Some child ->
          let rec iter acc p = function
          | [] -> List.rev acc
          | l when p = pos -> iter (child::acc) (p+1) l
          | c :: q ->
              if Oid.equal c.widget#id id then
                iter acc p q
              else iter (c::acc) (p+1) q
          in
          children <- iter [] 0 children;
          self#need_resize

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

    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 rec iter = function
                | [] -> false
                | c :: q ->
                    match c.widget#visible, c.widget#get_p Props.can_focus with
                    | true, true ->
                        (match c.widget#grab_focus ~last () with
                         | false -> iter q
                         | true -> true)
                    | _ -> iter q
                in
                iter (if last then List.rev children else children)
      else
        false

    method private child_move_focus (w:widget) last children on_none =
      let rec iter = function
      | c :: next :: q ->
          if Oid.equal c.widget#id w#id then
            ([%debug "%s#child_move_focus next.widget=%s, visible=%b"
              self#me next.widget#me next.widget#visible];
             if next.widget#visible then
               match next.widget#grab_focus ~last () with
               | false -> iter (c :: q)
               | true -> true
             else
               iter (c :: q)
            )
          else
            iter (next :: q)
      | [] | [_] -> on_none ()
      in
      iter children

    method! child_focus_next (w:widget) =
      self#child_move_focus w false
        children (fun () -> self#focus_next)

    method! child_focus_prev (w:widget) =
      self#child_move_focus w true
        (List.rev children)
        (fun () -> self#focus_prev)

    method private add_to_children ?pos c =
      children <- Misc.list_add ?pos children c

    method private remove_from_children w =
      let len = List.length children in
      children <- List.filter (fun c -> not (Oid.equal c.widget#id w#id)) children ;
      let len2 = List.length children in
      len <> len2

    method! next_widget ?inside ~loop pred w =
      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.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.widget#equal w -> iter q
          | _ :: q -> find q
          in
          find children

    method! prev_widget ?inside ~loop pred w =
      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.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.widget#equal w -> iter q
          | _ :: q -> find q
          in
          find (List.rev children)
  end