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

(** Multi-layer widget. *)

[@@@landmark "auto"]

open Tsdl

module A = Dynarray

(** {2 Properties} *)

(** This type describe how SDL events are propagated through layers.*)
type event_direction =
| Upward (* events are handled from bottom layer up to top layer *)
| Downward (* events are handle from top layer down to bottom layer *)

let string_of_event_direction = function
| Upward -> "upward"
| Downward -> "downward"
let event_direction_of_string str =
  match String.lowercase_ascii str with
  | "upward" -> Upward
  | "downward" -> Downward
  | _ ->
      Log.warn (fun m -> m "Invalid event_direction %S" str);
      Upward

module TEvent_direction = struct
    type t = event_direction
    let compare = Stdlib.compare
    let wrapper =
      let to_json ?with_doc x = `String (string_of_event_direction x) in
      let from_json ?def = function
      | `String s -> event_direction_of_string s
      | json -> Ocf.invalid_value json
      in
      Some (Ocf.Wrapper.make to_json from_json)
    let transition = None
  end
module PEvent_direction = Props.Add_prop_type(TEvent_direction)


(** Property used to store event direction. *)
let event_direction : event_direction Props.prop = PEvent_direction.mk_prop
  ~inherited:false ~default:Upward "event_direction"

(**/**)

let array_do_opt_until_true =
  let rec iter f t len i =
    if i >= len then
      false
    else
      f (A.get t i) || iter f t len (i+1)
  in
  fun f t -> iter f t (A.length t) 0

let array_do_until_true f t =
  let g = function None -> false | Some x -> f x in
  array_do_opt_until_true g t

let array_do_opt_until_true_rev =
  let rec iter f t i =
    if i < 0 then
      false
    else
      f (A.get t i) || iter f t (i-1)
  in
  fun f t -> iter f t (A.length t - 1)

let array_do_until_true_rev f t =
  let g = function None -> false | Some x -> f x in
  array_do_opt_until_true_rev g t


let array_doi_opt_until_true =
  let rec iter f t len i =
    if i >= len then
      false
    else
      f i (A.get t i) || iter f t len (i+1)
  in
  fun f t -> iter f t (A.length t) 0

let array_doi_until_true f t =
  let g i = function None -> false | Some x -> f i x in
  array_doi_opt_until_true g t

let array_fold_left f acc t =
  let g acc = function None -> acc | Some x -> f acc x in
  A.fold_left g acc t

let array_fold_right f t acc =
  let g x acc = match x with None -> acc | Some x -> f x acc in
  A.fold_right g t acc

let array_on_first =
  let rec iter f t len i =
    if i >= len then None
    else
      match A.get t i with
      | None -> iter f t len (i+1)
      | Some x -> Some (f x)
  in
  fun f t -> iter f t (A.length t) 0

let array_find_opt =
  let rec iter pred t len i =
    if i >= len then None
    else
      match pred (A.get t i) with
      | true -> Some i
      | false -> iter pred t len (i+1)
  in
  fun pred t -> iter pred t (A.length t) 0

let array_shift_left t pos =
  let len = A.length t in
  if pos <= 0 || pos >= len then
    None
  else
    (
     let ante = pos - 1 in
     let vleft = A.get t ante in
     let vpos = A.get t pos in
     A.set t pos vleft;
     A.set t ante vpos;
     Some ante
    )

let array_shift_right t pos =
  let len = A.length t in
  if pos < 0 || pos >= len - 1 then
    None
  else
    (
     let post = pos + 1 in
     let vright = A.get t post in
     let v = A.get t pos in
     A.set t pos vright ;
     A.set t post v ;
     Some post
    )

(**/**)

(** {2 The layers widget} *)

(** A {!class-layers} widget can handle several widget trees,
  allowing multiple layers of widgets. A layer is identified by its
  position. Bottom layer has position [0]. A layer can have a root widget
  associated (see the [pack] method). Widgets (and so, layers) are rendered
  from bottom layer up to top layer, in this order.
*)
class layers ?classes ?name ?props ?wdata () =
  object(self)
    inherit [int] Container.container ?classes ?name ?props ?wdata () as super

    (**/**)

    val mutable layers = (A.create () : Container.child option A.t)

    method kind = "layers"

    method private find_child_opt pred =
      let res = ref None in
      array_do_until_true
        (fun c ->
           match pred c with
           | true -> res := Some c; true
           | _ -> false)
        layers;
      !res

    method private find_child_pos_opt pred =
      let res = ref None in
      array_doi_until_true
        (fun i c ->
           match pred c with
           | true -> res := Some i; true
           | _ -> false)
        layers;
      !res

    method private child_by_widget w =
      self#find_child_opt (fun c -> c.widget#equal w)

    method private remove_from_children w =
      match self#widget_layer w with
      | None -> false
      | Some i -> A.set layers i None; true

    method private iter_children f =
      A.iter (function None -> () | Some c -> f c) layers

    method private fold_children_right f acc =
      array_fold_right f layers acc

    method private fold_children_left f acc =
      array_fold_left f acc layers

    method private add_to_children ?pos child =
      let layer = pos in
      let layer =
        match layer with
        | Some i -> i
        | None ->
            match array_find_opt (function None -> true | _ -> false) layers with
            | None -> A.length layers
            | Some i -> i
      in
      [%debug "%s#add_to_children layer=%d child=%s" self#me layer child.widget#me];
      if layer < 0 then
        Log.err (fun m -> m "%s#pack: invalid layer %d" self#me layer)
      else
        (
         let len = A.length layers in
         if layer < len then
           self#unpack_layer layer
         else
           for i = layer downto len do
             A.add_last layers None
           done;
         A.set layers layer (Some child);
        )

    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! wtree =
      let l = A.fold_right (fun x acc ->
           match x with
           | None -> acc
           | Some c -> c.Container.widget#wtree :: acc)
        layers []
      in
      Widget.N (self#coerce, l)

    method! baseline =
      match self#children_widgets with
      | [] -> super#baseline
      | child :: _ ->
          let b = child#baseline in
          let cg = child#geometry in
          b + cg.G.y + g_inner.y

    method width_constraints_ =
      let min = self#widget_min_width in
      match array_on_first
        (fun c -> c.Container.widget#width_constraints) layers
      with
      | None -> Widget.size_constraints min
      | Some c -> Widget.add_to_size_constraints c min

    method height_constraints_ =
      let min = self#widget_min_height in
      match
        array_on_first (fun c -> c.Container.widget#height_constraints) layers
      with
      | None -> Widget.size_constraints min
      | Some c -> Widget.add_to_size_constraints c min

    (**/**)

    (** {2 Properties} *)

    method event_direction = self#get_p event_direction
    method set_event_direction = self#set_p event_direction

    (** {2 Children widgets} *)

    (** Return the list of children widgets, from bottom layer
       to top layer. Layers with no widget are present with
       [None]. *)
    method children = A.to_list layers

    (** Return the list of children widgets, i.e. the root widget
      of each layer, for layers which have one. *)
    method children_widgets : Widget.widget list =
      A.fold_right
        (fun x acc -> match x with
           | None -> acc
           | Some x -> x.Container.widget :: acc)
        layers []

    (** Return the layer of the given widget. The widget must be
      the root widget of the layer.
      If the widget is not found, [None] is returned.*)
    method widget_layer (w:Widget.widget) =
      match array_find_opt
        (function Some c -> c.Container.widget#equal w | None -> false) layers
      with
      | None ->
          [%debug "%s#widget_layer: no widget %s" self#me w#me];
          None
      | x -> x

    (** {2 Box.ng/unpacking} *)

    (** [#unpack_layer layer] removes the root widget of the given [layer]. *)
    method unpack_layer layer =
      if layer >= 0 && layer < A.length layers then
        (
         match A.get layers layer with
         | None -> ()
         | Some c ->
             match super#remove c.widget with
             | false -> ()
             | true -> if c.widget#visible then self#need_resize
        )
      else
        Log.err (fun m -> m "%s#unpack_layer: invalid layer %d" self#me layer)

    (** [#unpack_widget w] removes the root widget [w], setting root widget
      for the corresponding layer to [None]. If the widget is not found, do
      nothing.*)
    method unpack_widget w =
      match super#remove w with
      | false -> ()
      | true -> if w#visible then self#need_resize

    (** [#pack w] packs widget [w] as root layer.
      Optional arguments are:
      {ul
       {- [layer]: if specified, use [w] as new root widget for
       this layer, eventually removing previous widget. If it is not specified,
       pack the widget as root for the first layer without root widget,
       eventually adding a layer to do so.}
       {- [opacity] sets {!Props.opacity} property of [w].}
       {- [data] associates the given value to [w] (in {!Container.child} structure).}
      }
    *)
    method pack ?layer ?opacity ?data (w:Widget.widget) =
      [%debug "%s#pack %s" self#me w#me];
      Option.iter w#set_opacity opacity ;
      match layer with
      | Some n when n < 0 ->
          Log.err (fun m -> m "%s#pack: invalid layer %d" self#me n)
      | _ ->
          match super#add ?pos:layer ?data w with
          | false -> ()
          | true -> if w#visible then self#need_resize

    (** {2 Operations on layers} *)

    (** [#move_layer layer target] moves layer according to [target], which
      can have the following values:
      {ul
       {- [`Bottom]: moves layer at the bottom of all layers,}
       {- [`Down n]: moves layer [n] positions down (or to the bottom if
          [layer <= n]),}
       {- [`Up n]: moves layer [n] positions up (or to the top if
          [layer + n >= number of layers]),}
       {- [`Top]: moves layer at the top of all layers.}
      }
      The method returns the new position of the layer, if it changed.
      Remember that a layer is only identified by its position. So the
      returned value is the same layer, with the same root widget.
    *)
    method move_layer layer (target:[`Top|`Bottom|`Up of int|`Down of int]) =
      let len = A.length layers in
      match layer with
      | _ when layer < 0 || layer >= len ->
          Log.warn (fun m -> m "%s#move: invalid layer %d" self#me layer);
          None
      | _ ->
          let final =
            match target with
            | `Up n ->
                let rec iter i p =
                  if i < n then
                    match array_shift_right layers p with
                    | None -> p
                    | Some p -> iter (i+1) p
                  else
                    p
                in
                iter 0 layer
            | `Down n ->
                let rec iter i p =
                  if i < n then
                    match array_shift_left layers p with
                    | None -> p
                    | Some p -> iter (i+1) p
                  else
                    p
                in
                iter 0 layer
            | `Top ->
                let rec iter p =
                  match array_shift_right layers p with
                  | None -> p
                  | Some p -> iter p
                in
                iter layer
            | `Bottom ->
                let rec iter p =
                  match array_shift_left layers p with
                  | None -> p
                  | Some p -> iter p
                in
                iter layer
          in
          if final <> layer then
            (self#need_resize;
             Some final
            )
          else
            None

    (**/**)

    method! private fold_children_for_sdl_event_down =
      match self#event_direction with
      | Upward -> self#fold_children_left
      | Downward ->
          fun f acc ->
            let g x acc = f acc x in
            self#fold_children_right g acc
    method! private on_sdl_event_down_stop_on_true = true

    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
                | None :: q -> iter q
                | Some c :: q ->
                    match c.Container.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 self#children else self#children)
      else
        false

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

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

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

    method! set_geometry geom =
      super#set_geometry geom ;
      let g_child = { g_inner with x = 0 ; y = 0 } in
      self#iter_children (fun c -> c.Container.widget#set_geometry g_child)

    method! leaf_widget_at ~x ~y =
      let x = x - g.x - g_inner.x in
      let y = y - g.y - g_inner.y in
      let f acc c =
        match acc with
        | None -> c.Container.widget#leaf_widget_at ~x ~y
        | x -> x
      in
      self#fold_children_left f None

    (**/**)
  end


type Widget.widget_type += Layers of layers

(** Convenient function to create a {!class-layers}.
  See {!Widget.widget_arguments} for other arguments. *)
let layers ?name ?props ?wdata ?event_direction ?pack () =
  let w = new layers ?name ?props ?wdata () in
  w#set_typ (Layers w);
  Option.iter w#set_event_direction event_direction;
  Widget.may_pack ?pack w ;
  w