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

(** Widget which can contain one widget. *)

open Misc
open Tsdl
open Widget

(** Widget containing one child. This widget is usually not used
  directly but inherited. *)
class bin ?classes ?name ?props ?wdata () =
  object(self)
    inherit Widget.widget ?classes ?name ?props ?wdata () as super

    (**/**)
    method kind = "bin"
    val mutable child = (None : widget option)
    method compute_child_geometry : Widget.widget -> G.t =
      fun w ->
        let cg = { super#g_inner with x = 0; y = 0 } in
        let m = w#margin in
        let cg =
          { G.x = m.left ; y = m.top ;
            w = max 0 (cg.w - m.left - m.right) ;
            h = max 0 (cg.h - m.top - m.bottom) ;
          }
        in
        [%debug "%s#compute_child_geometry: %a" self#me G.pp cg];
        cg

    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 child with
            | None -> ()
            | Some w -> w#set_p ~propagate p v
          else
            ()

    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)
        child;
      width_constraints <- None ;
      height_constraints <- None

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

    method to_child_coords (x,y) = (x - g.x - g_inner.x, y - g.y - g_inner.y)

    method! baseline =
      match child with
      | None -> super#baseline
      | Some c ->
          let b = c#baseline in
          let cg = c#geometry in
          b + cg.y + g_inner.y

    method! focused_widget =
      match child with
      | None -> Some self#coerce
      | Some c ->
          match c#focused_widget with
          | None -> Some self#coerce
          | Some w -> Some w

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

    method! set_has_focus b =
      match super#set_has_focus b with
      | true -> true
      | false ->
          match child with
          | None -> false
          | Some w -> w#set_has_focus b

    method! grab_focus ?(last=false) () =
      [%debug "%s#grab_focus ~last:%b" self#me last];
      if self#visible then
        match self#get_p Props.focusable with
        | true ->
            (match self#get_focus with
             | None -> false
             | Some _ -> true
            )
        | _ ->
            match self#get_p Props.can_focus with
            | false -> false
            | true ->
                match child with
                | None -> false
                | Some c -> c#grab_focus ~last ()
      else
        false

    method! on_sdl_event_down ~oldpos pos e =
      if self#sensitive then
        let b =
          match child with
          | None -> false
          | Some w ->
              [%debug "%s#on_sdl_event_down: propagating event to %s"
                 self#me w#me];
              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 -> self#on_sdl_event pos e
      else
        false

    method on_sdl_event_me (pos:(int*int) option) (e:Sdl.event) = false
    method! on_sdl_event (pos:(int*int) option) (e:Sdl.event) =
      match self#on_sdl_event_me pos e with
      | true -> true
      | false -> super#on_sdl_event pos e

    method! set_parent ?with_rend w =
      super#set_parent ?with_rend w ;
      match child with
      | None -> ()
      | Some c -> c#set_parent ?with_rend (Some self#coerce)

    method! child_reparented w =
      match child with
      | Some c when c#equal w ->
          [%debug "%s#child_reparented %s; child <- None" self#me w#me];
          child <- None; self#need_resize
      | _ -> ()

    (**/**)

   method remove_child =
      (match child with
       | None -> ()
       | Some w ->
           child <- None;
           w#set_parent None
      );
      self#need_resize

    method child = child
    method set_child w =
      let old_parent = w#parent in
      match old_parent with
      | Some p when p#equal self#as_widget -> ()
      | _ ->
          self#remove_child ;
          [%debug "%s#set_child %s" self#me w#me];
          child <- Some w;
          Option.iter (fun p -> p#child_reparented w) old_parent ;
          w#set_parent ?with_rend: self#with_renderer (Some self#coerce) ;
          self#need_resize;

    (**/**)

    method update_child_geometry =
      match child with
      | None -> ()
      | Some w -> w#set_geometry (self#compute_child_geometry w)

    method child_geometry =
      match child with
      | None -> G.zero
      | Some w -> w#geometry

    method render_child renderer ~offset:(x,y) ~(g_none:G.t) ~g_child =
      (* coordinates are still using current widget's origin (i.e. relative to parent) *)
      [%debug "%s#render_child ~offset=%d,%d g_none=%a g_child=%a"
         self#me x y G.pp g_none G.pp g_child];
      match child with
      | None ->
          let g_none = G.translate ~x ~y g_none in
          Render.fill_rect renderer (Some g_none) self#bg_color_now
      | Some w ->
          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 g_child = G.translate ~x:(-off_x) ~y:(-off_y) g_child in
          w#render renderer ~offset g_child

    method render_me_parent rend ~offset rg =
      [%debug "%s#render_me_parent offset=(%d,%d) rg=%a"
        self#me (fst offset) (snd offset) G.pp rg];
      ()

    method render_me rend ~offset rg =
      self#render_me_parent rend ~offset rg;
      self#render_child
        rend ~offset ~g_none:self#child_geometry ~g_child:rg

    method child_width_constraints =
      match child with None -> Widget.size_constraints_none | Some w -> w#width_constraints
    method child_height_constraints =
      match child with None -> Widget.size_constraints_none | Some w -> w#height_constraints
    method child_margin =
      match child with None -> Props.trbl__ 0 | Some c -> c#margin

    method private width_constraints_ =
      let w = self#widget_min_width in
      let c = self#child_width_constraints in
      Widget.add_to_size_constraints c w

    method private height_constraints_ =
      let h = self#widget_min_height in
      let c = self#child_height_constraints in
      Widget.add_to_size_constraints c h

    method! set_geometry geom =
      super#set_geometry geom ;
      self#update_child_geometry

    method! is_leaf_widget = false
    method! leaf_widget_at ~x ~y =
      match child with
      | None -> None
      | Some w ->
          let (x,y) = self#to_child_coords (x,y) in
          w#leaf_widget_at ~x ~y
    method! next_widget ?inside ~loop pred w =
      match w, child with
      | None, Some c -> c#next_widget ?inside ~loop pred None
      | _ -> super#next_widget ?inside ~loop pred (Some self#coerce)

    method! prev_widget ?inside ~loop pred w =
      match w, child with
      | None, Some c -> c#prev_widget ?inside ~loop pred None
      | _ -> super#prev_widget ?inside ~loop pred (Some self#coerce)

    method! destroy =
      super#destroy ;
      [%debug "%s#child_destroy" self#me];
      match child with
      | None -> ()
      | Some w -> w#destroy

  end

type Widget.widget_type += Bin of bin

(** Convenient function to create a {!class-bin}.
   See {!Widget.widget_arguments} for arguments. *)
let bin ?classes ?name ?props ?pack ?wdata () =
  let w = new bin ?classes ?name ?props ?wdata () in
  w#set_typ (Bin w);
  Widget.may_pack ?pack w#coerce ;
  w