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

(** Labelled frame widget. *)

open Misc
open Widget
open Tsdl

(** Property ["frame_border_width"] to specify the width of the
   frame's border. *)
let border_width = Props.int_prop ~after:[Resize]
  ~default:1 "frame_border_width"
let css_border_width = Theme.int_prop border_width

(** The frame widget. Optional argument [label] can be used
  to pass the widget used in label position. Any widget can be
  used as label. *)
class frame ?classes ?name ?props ?wdata ?label () =
  object(self)
    inherit Bin.bin ?classes ?name ?props ?wdata () as super

    (**/**)
    method kind = "frame"
    val mutable label = (label : Widget.widget option)
    method! set_p p ?delay ?(propagate=false) v =
      [%debug "%s#set_p ~propagate:%b" self#me propagate];
      super#set_p ?delay ~propagate p v ;
      match delay, Props.transition p with
      | Some _, Some _ -> ()
      | _ ->
          if propagate then
            match label with
            | None -> ()
            | Some w -> w#set_p ~propagate p v
          else
            ()

    method! child_reparented w =
      match label with
      | Some c when c#equal w -> self#set_label None
      | _ -> super#child_reparented w

    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
      Option.iter (fun w ->
         w#do_apply_theme ~root ~parent:theme_props path rules)
        label;
      width_constraints <- None ;
      height_constraints <- None

    (**/**)

    (** {2 Properties} *)

    method frame_border_width = self#get_p border_width
    method set_frame_border_width = self#set_p border_width

    (**/**)

    method! wtree =
      let l = match label with
        | None -> []
        | Some w -> [w#wtree]
      in
      let l = match child with
        | None -> l
        | Some w -> l @ [w#wtree]
      in
      Widget.N (self#coerce, l)

    method! render_child renderer ~offset ~g_none ~g_child =
      match child with
      | None -> ()
      | Some _ -> super#render_child renderer ~offset ~g_none ~g_child

    method! render_me_parent rend ~offset geom =
      super#render_with_prepare rend ~offset geom ;
      self#render_label rend ~offset geom

    method render_label rend ~offset:(x,y) geom =
      match label with
      | None -> ()
      | Some w ->
          let offset = (x+g.x+g_inner.x, y+g.y+g_inner.x) in
          let geom = G.translate ~x:(-g.x-g_inner.x) ~y:(-g.y-g_inner.x) geom in
          w#render rend ~offset geom

    method label_width_constraints =
      match label with
      | None -> Widget.size_constraints_fixed 0
      | Some w -> w#width_constraints
    method label_height_constraints =
      match label with
      | None -> Widget.size_constraints_fixed 0
      | Some w -> w#height_constraints
    method label_margin =
    match label with
      | None -> Props.trbl__ 0
      | Some w -> w#margin

    method private top_padding =
      let p = self#padding in
      let label_h = self#label_height_constraints.min in
      max p.top (label_h / 2)

    method! private width_constraints_ =
      let p = self#padding in
      let cm = self#child_margin in
      let cw = self#child_width_constraints.min in
      let bw = self#frame_border_width in
      (* use super#min_width but remove child_min_width *)
      let min = super#width_constraints_.min - cw +
        bw +
          (max (max p.left cm.left + cw - cm.left - cm.right + max p.right cm.right)
           (p.left + self#label_width_constraints.min + p.right)) +
          bw
      in
      (* FIXME: use child max_ fields *)
      { Widget.size_constraints_none with min }

    method! private height_constraints =
      let p = self#padding in
      let bw = self#frame_border_width in
      let lh = self#label_height_constraints.min in
      let lm = self#label_margin in
      let cm = self#child_margin in
      let ch = self#child_height_constraints.min in
      (* use super#min_height but remove child_min_height *)
      let min = super#height_constraints_.min - ch +
      (max (max 0 (lm.top - p.top) + lh - lm.top - lm.bottom + max lm.bottom cm.top)
        (bw + max p.top cm.top)) +
        ch - cm.top - cm.bottom +
        max p.bottom cm.bottom + bw
      in
      (* FIXME: use child max_ fields *)
      { Widget.size_constraints_none with min }

    method! compute_child_geometry w =
      let glabel =
        match label with
        | None -> G.zero
        | Some w -> w#geometry
      in
      let lm = self#label_margin in
      let cm = w#margin in
      let bw = self#frame_border_width in
      let p = self#padding in
      let x = bw + max cm.left p.left in
      let y = max (bw + max cm.top p.top)
        (max 0 (lm.top - p.top) + glabel.h + max lm.bottom cm.top)
      in
      let gc =
        { G.x ; y ;
          w = g_inner.w - x - (bw + max p.right cm.right) ;
          h = g_inner.h - y - (bw + max p.bottom cm.bottom) ;
        }
      in
      [%debug "%s#compute_child_geometry: g=%a, g_inner=%a, gc=%a"
        self#me G.pp g G.pp g_inner G.pp gc];
      gc

    method private set_label_parent =
      match label with
      | None -> ()
      | Some w ->
          w#add_class "frame_label";
          w#set_parent ?with_rend:self#with_renderer(Some self#coerce)

    (**/**)

    (** {2 Label} *)

    (** Returns the label widget, if any. *)
    method label = label

    (** [f#set_label w] sets widget [w] as label, replacing the
      previous one if present. *)
    method set_label w =
      match label, w with
      | Some l, Some w when l#equal w#as_widget ->
          Log.warn (fun m -> m "%s is already label for %s" w#me self#me)
      | _ ->
          Option.iter (fun l ->
             l#rem_class "frame_label";
             l#set_parent ?with_rend:None None) label ;
          label <- w;
          let () =
            match label with
            | None -> ()
            | Some w ->
                Option.iter (fun p -> p#child_reparented w) w#parent ;
                self#set_label_parent
          in
          self#need_resize

    (**/**)

    method! set_geometry geom =
      (match label with
       | None -> ()
       | Some c ->
           let old_geo = c#geometry in
           let w = self#label_width_constraints.min in
           let h = self#label_height_constraints.min in
           let m = self#label_margin in
           let p = self#padding in
           let bw = self#frame_border_width in
           let geo = {
               G.x = bw + p.left + m.left ;
               y = max 0 (m.top - p.top) ;
               w = w - m.left - m.right;
               h = h - m.top - m.bottom}
           in
          [%debug "%s#set_geometry label#geometry=>%a" self#me G.pp geo];
          c#set_geometry geo;
          (* if label's geometry changed, we destroy our texture
             or else the frame border will not be redrawn *)
          if old_geo <> geo then
            self#destroy_texture
      );
      super#set_geometry geom ;

    method! prepare rend geom =
      match self#texture rend with
      | None ->
          [%debug "%s#prepare: no texture" self#me];
          None
      | Some (`Exist t) -> Some t
      | Some (`New t) ->
          [%debug
            "%s#prepare: drawing on my texture" self#me];
          let p = self#padding in
          let bw = self#frame_border_width in
          let label_m = self#label_margin in
          (*let cm = self#child_margin in*)
          let glabel = match label with
            | None -> G.zero
               | Some w ->
                let ge = w#geometry in
                { G.x = p.left + bw ;
                  y = ge.y ;
                  w = ge.w + label_m.left + label_m.right ;
                  h = ge.h (*+ max 0 (label_m.top - p.top) + max label_m.bottom cm.top*) ;
                }
          in
          let () =
            let x = 0 in
            let y = max 0 (glabel.y + (glabel.h - bw) / 2) in
            let w = g_inner.w in
            let h = max 0 (g_inner.h - y) in
            let r = ref { G.x ; y ; w ; h } in
            let i = ref bw in
            while !i > 0 do
              [%debug "%s#prepare draw_rect %a glabel=%a" self#me G.pp !r G.pp glabel];
              Texture.draw_rect_r rend t !r self#fg_color_now;
              decr i;
                 r := G.enlarge ~w:(-1) ~h:(-1) !r;
            done
          in
          (match label with
           | Some _ ->
               Texture.fill_rect rend t (Some glabel) self#bg_color_now
           | None -> ()
          );
          Some t

    method! on_sdl_event_down ~oldpos pos e =
      if self#sensitive then
        let b =
          match label with
          | None -> false
          | Some w ->
              let child_pos = Option.map self#to_child_coords pos in
              let child_oldpos = Option.map self#to_child_coords oldpos in
              w#on_sdl_event_down ~oldpos:child_oldpos child_pos e
        in
        match b with
        | true -> true
        | false -> super#on_sdl_event_down ~oldpos pos e
      else
        false

    method! is_leaf_widget = false
    method! leaf_widget_at ~x ~y =
      match G.inside g ~x ~y with
      | false -> None
      | true ->
          match
            match label with
            | None -> None
            | Some w ->
                let (x,y) = self#to_child_coords (x,y) in
                w#leaf_widget_at ~x ~y
          with
          | None -> super#leaf_widget_at ~x ~y
          | (Some _) as x -> x

    method! next_widget  ?inside ~loop pred w =
      match w, label with
      | None, None -> super#next_widget ?inside ~loop pred None
      | None, Some l ->
          (match l#next_widget ?inside ~loop pred None with
           | None -> super#next_widget ?inside ~loop pred None
           | x -> x)
      | Some w, Some l when w#equal l -> l#next_widget ?inside ~loop pred None
      | Some _, _ -> super#next_widget ?inside ~loop pred None

    method! prev_widget ?inside ~loop pred w =
      match w, child, label, parent, inside with
      | None, None, None, _, Some i when self#equal i#coerce -> None
      | None, None, None, None, _ -> None
      | None, None, None, Some p, _ -> p#prev_widget ?inside ~loop pred (Some self#coerce)
      | None, Some c, None, _, _ -> super#prev_widget ?inside ~loop pred None
      | None, None, Some l, _, Some i when self#equal i#coerce ->
          (match l#prev_widget ?inside ~loop pred None with
           | None -> if loop then self#prev_widget ?inside ~loop pred None else None
           | x -> x)
      | None, None, Some l, None, _ ->
          (match l#prev_widget ?inside ~loop pred None with
           | None -> None
           | x -> x)
      | None, None, Some l, Some p, _ ->
          (match l#prev_widget ?inside ~loop pred None with
           | None -> p#prev_widget ?inside ~loop pred (Some self#coerce)
           | x -> x)
      | Some w, Some c, Some l, _, Some i when self#equal i && w#equal c ->
          (match l#prev_widget ?inside ~loop pred None with
          | None -> if loop then self#prev_widget ?inside ~loop pred None else None
          | x -> x)
      | Some w, Some c, Some l, None, _ when w#equal c->
          (match l#prev_widget ?inside ~loop pred None with
          | None -> None
          | x -> x)
      | Some w, Some c, Some l, Some p, _ when w#equal c ->
          (match l#prev_widget ?inside ~loop pred None with
          | None -> p#prev_widget ?inside ~loop pred (Some self#coerce)
          | x -> x)
      | _, _, _, _, 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)


    initializer
      self#set_label_parent;
      (* TODO: handle properties which should trigger invalidating the texture *)
      ignore(self#connect (Object.Prop_changed Props.is_focus)
        (fun ~prev ~now ->
          [%debug "%s: is_focus -> %b, invalidating texture"
             self#me now];
          self#invalidate_texture))
  end

type Widget.widget_type += Frame of frame

(** Convenient function to create a {!class-frame}.
  Optional arguments [label] can be used to add the widget to
  be placed in label position.
  See {!Widget.widget_arguments} for other arguments. *)
let frame ?classes ?name ?props ?wdata ?label ?pack () =
  let w = new frame ?classes ?name ?props ?wdata ?label () in
  w#set_typ (Frame w);
  Widget.may_pack ?pack w ;
  w

(** Same as {!val:frame} but allows to indicate a text used
  as label widget. The label is returned with the frame. *)
let text_frame ?classes ?name ?props ?wdata ?pack text =
  let label = Text.label ~text () in
  let f = frame ?classes ?name ?props ?wdata ~label:label#coerce ?pack () in
  (f, label)