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                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Widgets 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

    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 ~layer 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 layer=%a ~offset=%d,%d g_none=%a g_child=%a"
         self#me Layer.pp layer x y G.pp g_none G.pp g_child];
      match child with
      | None ->
          if layer = self#get_p Props.layer then
            let g_none = G.translate ~x ~y g_none in
            Render.fill_rect renderer (Some g_none) self#bg_color_now
          else
            ()
      | 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 ~layer renderer ~offset g_child

    method render_me_parent ~layer 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 ~layer rend ~offset rg =
      self#render_me_parent ~layer rend ~offset rg;
      self#render_child ~layer
        rend ~offset ~g_none:self#child_geometry ~g_child:rg

    method child_min_width =
      match child with None -> 0 | Some w -> w#min_width
    method child_min_height =
      match child with None -> 0 | Some w -> w#min_height
    method child_max_width =
      match child with None -> None | Some w -> w#max_width
    method child_max_height =
      match child with None -> None | Some w -> w#max_height
    method child_margin =
      match child with None -> Props.trbl__ 0 | Some c -> c#margin

    method! private min_width_ = super#min_width_ + self#child_min_width
    method! private min_height_ = super#min_height_ + self#child_min_height
    method! max_width =
      match self#child_max_width with
      | None -> super#max_width
      | Some n -> Some (super#min_width_ + n)
    method! max_height =
      match self#child_max_height with
      | None -> super#max_height
      | Some n -> Some (super#min_height_ + n)

    method private widget_min_width_ = super#min_width_
    method private widget_min_height_ = super#min_height_

    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

(** 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
  Widget.may_pack ?pack w#coerce ;
  w

(** {2 Event boxes} *)

(** An event_box is a {!class-bin} widget which differs in the way events are
  propagated: if an event is not handled by this widget, then it is
  propagated to its child. This is useful for example to catch
  keystrokes for keyboard shortcuts. *)
class event_box ?classes ?name ?props ?wdata () =
  object(self)
    inherit bin ?classes ?name ?props ?wdata () as super

    (**/**)

    method kind = "event_box"

    method! on_sdl_event_down ~oldpos pos e =
      if self#sensitive then
        match self#on_sdl_event pos e with
        | true -> true
        | false ->
            match child 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
      else
        false
  end

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

(** {2 Fixed-size widget} *)

(** A [fixed_size] widget is a {!class-bin} widget whose width and
  height can be fixed. *)
class fixed_size ?classes ?name ?props ?wdata ?w ?h () =
  object(self)
    inherit bin ?classes ?name ?props ?wdata () as super

    (**{3 Properties} *)

    method set_height h = self#set_p Props.height h
    method set_width w = self#set_p Props.width w

    (**/**)
    method kind = "fixed_size"

    method private min_width_ =
      match self#opt_p Props.width with
      | Some w when w >= 0 -> w
      | _ -> self#child_min_width
    method private min_height_ =
      match self#opt_p Props.height with
      | Some h when h >= 0 -> h
      | _ -> self#child_min_height
    method! max_width =
      match self#opt_p Props.width with
      | Some x -> Some (abs x)
      | _ -> self#child_max_width
    method! max_height =
      match self#opt_p Props.height with
      | Some x -> Some (abs x)
      | _ -> self#child_max_height

    initializer
      (* modify props here rather than before object(self) so
         that they have been duplicated in widget init *)
      let () = match w with None -> () | Some w -> Props.set props Props.width w in
      let () = match h with None -> () | Some h -> Props.set props Props.height h in
      ()
  end

(** Convenient function to create a {!class-fixed_size}.
  [w] and [h] optional arguments specify width and height.
  See {!Widget.widget_arguments} for other arguments. *)
let fixed_size ?classes ?name ?props ?wdata ?w ?h ?pack () =
  let w = new fixed_size ?classes ?name ?props ?wdata ?w ?h () in
  Widget.may_pack ?pack w#coerce ;
  w

(** {2 Scrollboxes} *)

type _ Events.ev +=
| HScrolled : (unit -> unit) Events.ev (* a horizontal scroll occured *)
| VScrolled : (unit -> unit) Events.ev (* a vertical scroll occured *)

(** Policy for scrollbars:
  {ul
  {- [`ALWAYS]: always displays scrollbar, even when not needed.}
  {- [`NEVER]: never displays scrollbar, even when needed.}
  {- [`AUTOMATIC]: displays scrollbar only when needed, i.e. when
     child content is larger than the scrollbox in the considered
     direction (horizontal or vertical).}
  {- [`NOSCROLL]: do not scroll, constraint child with available width or height.}
  }
*)
type scrollbar_policy = [`ALWAYS | `NEVER | `AUTOMATIC | `NOSCROLL ]

let scrollbar_policies = [`ALWAYS ; `NEVER ; `AUTOMATIC ; `NOSCROLL ]

let string_of_scrollbar_policy : scrollbar_policy -> string = function
| `ALWAYS -> "always"
| `NEVER -> "never"
| `AUTOMATIC -> "automatic"
| `NOSCROLL -> "noscroll"

let scrollbar_policy_of_string =
  Css.T.mk_of_string ~case_sensitive:false
    string_of_scrollbar_policy scrollbar_policies

(** {!Ocf} wrapper for {!scrollbar_policy}. *)
let scrollbar_policy_wrapper : scrollbar_policy Ocf.Wrapper.t =
  let to_json ?with_doc x = `String (string_of_scrollbar_policy x) in
  let from_json ?def json =
    match json with
    | `String s ->
        (match scrollbar_policy_of_string s with
         | None -> Ocf.invalid_value json
         | Some x -> x
        )
    | _ -> Ocf.invalid_value json
  in
  Ocf.Wrapper.make to_json from_json

module TScrollbar_policy = struct
    type t = scrollbar_policy
    let compare = Stdlib.compare
    let wrapper = Some scrollbar_policy_wrapper
    let transition = None
  end
module PScrollbar_policy = Props.Add_prop_type(TScrollbar_policy)

let scrollbar_policy_prop : scrollbar_policy Props.mk_prop =
  PScrollbar_policy.mk_prop

let css_scrollbar_policy_prop = Theme.keyword_prop
  string_of_scrollbar_policy scrollbar_policy_of_string `AUTOMATIC

let hscrollbar_policy = scrollbar_policy_prop
  ~default:`AUTOMATIC "hscrollbar_policy"

let css_hscrollbar_policy = css_scrollbar_policy_prop hscrollbar_policy

let vscrollbar_policy = scrollbar_policy_prop
 ~default:`AUTOMATIC "vscrollbar_policy"

let css_vscrollbar_policy = css_scrollbar_policy_prop vscrollbar_policy

let hscrollbar_covers_child = Props.bool_prop
  ~after:[Props.Resize]
  ~default:true ~inherited:true "hscrollbar_covers_child"

let css_hscrollbar_covers_child = Theme.bool_prop hscrollbar_covers_child

let vscrollbar_covers_child = Props.bool_prop
  ~after:[Props.Resize]
  ~default:true ~inherited:true "vscrollbar_covers_child"

let css_vscrollbar_covers_child = Theme.bool_prop vscrollbar_covers_child

(* FIXME: use render layer to render scrollbars ? *)
class scrollbox ?classes ?name ?props ?wdata () =
  object(self)
    inherit bin ?classes ?name ?props ?wdata () as super

    (**/**)
    method kind = "scrollbox"
    val mutable content_w = 0
    val mutable content_h = 0
    val mutable offset_x = 0
    val mutable offset_y = 0
    val mutable g_handle_v = G.zero
    val mutable g_handle_h = G.zero
    val mutable state_machine :
      [`Base|`Moving_handle of int * int * Props.orientation] Misc.state_machine =
        Misc.empty_state_machine
    (**/**)

    (** {3 Properties} *)

    method hscrollbar_policy = self#get_p hscrollbar_policy
    method set_hscrollbar_policy = self#set_p hscrollbar_policy
    method vscrollbar_policy = self#get_p vscrollbar_policy
    method set_vscrollbar_policy = self#set_p vscrollbar_policy
    method hscrollbar_covers_child = self#get_p hscrollbar_covers_child
    method set_hscrollbar_covers_child = self#set_p hscrollbar_covers_child
    method vscrollbar_covers_child = self#get_p vscrollbar_covers_child
    method set_vscrollbar_covers_child = self#set_p vscrollbar_covers_child
    method scrollbar_width = self#get_p Props.scrollbar_width
    method set_scrollbar_width = self#set_p Props.scrollbar_width

    (** {3 Other methods} *)

    (**/**)

    method! to_child_coords (x,y) =
      (offset_x + x - g.x - g_inner.x,
       offset_y + y - g.y - g_inner.y)

    method! to_desktop_coords ~x ~y =
      let x = x - offset_x and y = y - offset_y in
      super#to_desktop_coords ~x ~y

    method! child_visible_rect w =
      G.{ g_inner with x = offset_x ; y = offset_y }

    (**/**)

    (** [#vscroll off] vertically scrolls by off. A negative offset
     moves up, a positive one moves down. Checks are performed not to
     scroll out of bounds.*)
    method vscroll offset =
      let gch = self#gchild_h in
      let new_off_y = max 0 (min (offset_y + offset) (content_h - gch)) in
      if new_off_y <> offset_y then
        (
         [%debug "%s#vscroll offset_y: %d => %d" self#me offset_y new_off_y];
         offset_y <- new_off_y ;
         self#set_g_handle_v ;
         super#need_render ~layer:(self#get_p Props.layer) g;
         self#trigger_unit_event VScrolled ()
        )

    (** [#hscroll off] horizontally scrolls by off. A negative offset
     moves left, a positive one moves right. Checks are performed not to
     scroll out of bounds.*)
   method hscroll offset =
      let gcw = self#gchild_w in
      let new_off_x = max 0 (min (offset_x + offset) (content_w - gcw)) in
      if new_off_x <> offset_x then
        (
         offset_x <- new_off_x ;
         self#set_g_handle_h ;
         super#need_render ~layer:(self#get_p Props.layer) g ;
         self#trigger_unit_event HScrolled ()
        )

    (** [#offsets] return x-offset and y-offset, i.e. the top left corner
      coordinates displayed of the child content. *)
    method offsets = (offset_x, offset_y)

    (** [#scroll_to ~x ~y] sets x-offset and y-offset to [x] and [y].
       [x] and [y] are corrected to valid bounds
         (> 0 and < content - displayed rect).
    *)
    method scroll_to ~x ~y =
      [%debug "%s#scroll_to ~x:%d ~y:%d" self#me x y];
      let old_x = offset_x in
      let old_y = offset_y in
      offset_x <- max 0 (min x (content_w - self#gchild_w));
      offset_y <- max 0 (min y (content_h - self#gchild_h));
      [%debug "%s#scroll_to offset_y: %d => %d" self#me old_y offset_y];
      let bx = if offset_x <> old_x then (self#set_g_handle_h ; true) else false in
      let by = if offset_y <> old_y then (self#set_g_handle_v ; true) else false in
      let () = if bx || by then super#need_render ~layer:(self#get_p Props.layer) g in
      let () = if bx then self#trigger_unit_event HScrolled () in
      let () = if by then self#trigger_unit_event VScrolled () in
      ()

    (** [#hscroll_range] returns the start and stop horizontal range (from 0. to 1.)
       of the child which is currently displayed. *)
    method hscroll_range =
      if content_h <= 0 then
        (0., 0.)
      else
        let ch = self#gchild_h in
        let h = float content_h in
        (float offset_y /. h, float (offset_y + ch) /. h)

    (** [#vscroll_range] returns the start and stop vertical range (from 0. to 1.)
       of the child which is currently displayed. *)
    method vscroll_range =
      if content_h <= 0 then
        (0., 0.)
      else
        let ch = self#gchild_h in
        let h = float content_h in
        (float offset_y /. h, float (offset_y + ch) /. h)

    (**/**)

    method! show_child_rect r =
      let exposed = G.{ x = offset_x ; y = offset_y ; w = self#gchild_w ; h = self#gchild_h } in
      [%debug "%s#show_child_rect r=%a exposed=%a" self#me G.pp r G.pp exposed];
      let f rx rw ex ew =
        if rw >= ew then
          rx
        else
          if rx >= ex then
            if rx + rw <= ex + ew then
              ex
            else
              ex + (rx + rw) - (ex + ew)
          else
            rx
      in
      let x = f r.x r.w exposed.x exposed.w in
      let y = f r.y r.h exposed.y exposed.h in
      [%debug "%s#show_child_rect scroll to x:%d y:%d" self#me x y];
      self#scroll_to ~x ~y;
      self#show

    method! on_key_down pos event key mods =
      [%debug "%s#on_key_down: %s" self#me (Tsdl.Sdl.get_key_name key)];
      let old_off_x = offset_x in
      let old_off_y = offset_y in
      let handled =
        match key with
        | k when k = Sdl.K.home -> self#vscroll (-max_int); true
        | k when k = Sdl.K.kend -> self#vscroll (max_int-offset_y); true
        | k when k = Sdl.K.pageup -> self#vscroll (-g_inner.h); true
        | k when k = Sdl.K.pagedown -> self#vscroll g_inner.h; true
        | k when k = Sdl.K.up -> self#vscroll (-25); true
        | k when k = Sdl.K.down -> self#vscroll 25; true
        | k when k = Sdl.K.left -> self#hscroll (-25); true
        | k when k = Sdl.K.right -> self#hscroll (25); true
        | _ -> false
      in
      match handled with
      | true -> (offset_x <> old_off_x || offset_y <> old_off_y)
      | false -> super#on_key_down pos event key mods

    method on_sdl_event_me pos ev =
      if self#sensitive then
        match state_machine.f pos ev with
        | false -> super#on_sdl_event_me pos ev
        | true -> true
      else
        false

    method! on_sdl_event_down ~oldpos pos e =
      if self#sensitive then
        let b =
          match child with
          | None -> false
          | Some w ->
              (* propagate events with coords only if pos or oldpos is in child *)
              match oldpos, pos with
              | None, None ->
                  w#on_sdl_event_down ~oldpos:None None e
              | _ ->
                  let gc = self#g_child in
                  [%debug "%s#on_sdl_event_down: g_child=%a, pos=%s"
                     self#me G.pp gc
                       (match pos with None -> "None" | Some (x,y) -> Printf.sprintf "%d,%d" x y)];
                  let f = function
                  | None -> false
                  | Some (x,y) ->
                      let x = x - g.x - g_inner.x in
                      let y = y - g.y - g_inner.y in
                      G.inside ~x ~y gc
                  in
                  if f oldpos || f pos then
                    (
                     [%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
                    )
                  else
                    false
        in
        match b with
        | true -> true
        | false -> self#on_sdl_event pos e
      else
        false

    method on_mouse_leave =
      (match state_machine.state () with
       | `Moving_handle _ -> state_machine.set_state `Base
       | _ -> ()
      );
      super#on_mouse_leave

    method state_on_event state pos ev =
      match state, pos, Sdl.Event.(enum (get ev typ)) with
      | `Base, _, `Mouse_wheel ->
          if mouse_on_widget then
            (
             let old_off_x = offset_x in
             let old_off_y = offset_y in
             let x = Sdl.Event.(get ev mouse_wheel_x) in
             let y = Sdl.Event.(get ev mouse_wheel_y) in
             [%debug
                "%s#on_even mouse wheel (%d,%d) content_w=%d, g.w=%d, content_h=%d, g.h=%d"
                  self#me x y content_w g.w content_h g.h];
             self#vscroll (- y * 25);
             self#hscroll (- x * 25);
             Some (`Base, offset_x <> old_off_x || offset_y <> old_off_y)
            )
          else
            None
      | `Base, Some (x,y), `Mouse_button_down ->
          let x = x - g.x - g_inner.x in
          let y = y - g.y - g_inner.y in
          if G.inside ~x ~y g_handle_h then
            Some (`Moving_handle (offset_x, x, Props.Horizontal), true)
          else
            if G.inside ~x ~y g_handle_v then
             Some (`Moving_handle (offset_y, y, Props.Vertical), true)
            else
              None
      | `Moving_handle (off, cursor_offset, Props.Horizontal), Some (x,_), `Mouse_motion ->
          let x = x - g.x - g_inner.x in
          let r = float content_w /. float self#gchild_w in
          let x = off + (truncate (float (x - cursor_offset) *. r)) in
          self#scroll_to ~x ~y:offset_y;
          None
      | `Moving_handle (off, cursor_offset, Props.Vertical), Some (_,y), `Mouse_motion ->
          let y = y - g.y - g_inner.y in
          let r = float content_h /. float self#gchild_h in
          let y = off + (truncate (float (y - cursor_offset) *. r)) in
          self#scroll_to ~x:offset_x ~y;
          None
      | `Moving_handle _, _, `Mouse_button_up ->
          Some (`Base, true)
      | (`Base|`Moving_handle _), _, _ -> None

    method private gchild_w =
      match self#vscrollbar_covers_child with
      | true -> g_inner.w
      | false ->  g_inner.w - g_handle_v.w - 2
    method private gchild_h =
      match self#hscrollbar_covers_child with
      | true -> g_inner.h
      | false ->  g_inner.h - g_handle_h.h - 2

    method private must_show_scroll_h =
      match self#hscrollbar_policy with
      | `NEVER | `NOSCROLL -> false
      | `ALWAYS -> true
      | `AUTOMATIC ->
          let gc_w = self#gchild_w in
          [%debug "%s#must_show_scroll_h content_w=%d, gc_w=%d"
            self#me content_w gc_w];
          content_w > gc_w

    method private must_show_scroll_v =
      match self#vscrollbar_policy with
      | `NEVER | `NOSCROLL -> false
      | `ALWAYS -> true
      | `AUTOMATIC ->
          let gc_h = self#gchild_h in
          content_h > gc_h

    method g_child =
      let gc = { g_inner with w = self#gchild_w ; h = self#gchild_h } in
      [%debug "%s#g_child => %a" self#me G.pp gc];
      gc

    method private set_g_handle_h =
      let gcw = self#gchild_w in
      let w =
        let ratio = float gcw /. float content_w in
        let w = truncate (float g_inner.w *. ratio) in
        max (self#get_p Props.scrollbar_handle_min_size) w
      in
      let x =
        let ratio = float offset_x /. float (content_w - gcw) in
        max 0 (truncate (float (g_inner.w - w) *. ratio))
      in
      let sw = self#get_p Props.scrollbar_width in
      let gh = { G.x ; G.y = g_inner.h - 1 - sw ; w; h = sw } in
      [%debug "scroll: g_handle_h set to %a" G.pp gh];
      g_handle_h <- gh

    method private set_g_handle_v =
      let gch = self#gchild_h in
      let h =
        let ratio = float gch /. float content_h in
        let h = truncate (float g_inner.h *. ratio) in
        max (self#get_p Props.scrollbar_handle_min_size) h
      in
      let y =
        let ratio = float offset_y /. float (content_h - gch) in
        max 0 (truncate (float (g_inner.h - h) *. ratio))
      in
      let sw = self#get_p Props.scrollbar_width in
      let gh = { G.x = g_inner.w - 1 - sw ; y ; w = sw; h } in
      [%debug "scroll: g_handle_v set to %a" G.pp gh];
      g_handle_v <- gh

    method render_hscroll_if_needed renderer ~offset:(x,y) geom =
      if self#must_show_scroll_h then
        let sw = self#get_p Props.scrollbar_width in
        let g_scroll = {
            G.x = g.x + g_inner.x ;
            y = g.y + g_inner.y + g_inner.h - 1 - sw ;
            w = g_inner.w ;
            h = sw;
          }
        in
        match G.inter geom g_scroll with
        | None -> ()
        | Some g_bg ->
            let g_bg = G.translate ~x ~y g_bg in
            [%debug "%s rendering hscroll: %a"
               self#me G.pp g_bg];
            Render.fill_rect renderer (Some g_bg)
              (self#get_p Props.scrollbar_bg_color);
            let g_handle = G.translate
              ~x:(g.x+g_inner.x) ~y:(g.y+g_inner.y) g_handle_h
            in
            match G.inter geom g_handle with
            | None -> ()
            | Some gh ->
                let gh = G.translate ~x ~y gh in
                [%debug "%s rendering hscroll handle: %a"
                   self#me G.pp gh];
                Render.fill_rect renderer (Some gh)
                  (self#get_p Props.scrollbar_handle_color)

    method render_vscroll_if_needed renderer ~offset:(x,y) geom =
      if self#must_show_scroll_v then
        let sw = self#get_p Props.scrollbar_width in
        let g_scroll = {
            G.x = g.x + g_inner.x + g_inner.w - 1 - sw ;
            y = g.y + g_inner.y ;
            w = sw ;
            h = g_inner.h ;
          }
        in
        match G.inter geom g_scroll with
        | None -> ()
        | Some g_bg ->
            let g_bg = G.translate ~x ~y g_bg in
            [%debug "%s rendering vscroll: %a"
              self#me G.pp g_bg];
            Render.fill_rect renderer (Some g_bg)
              (self#get_p Props.scrollbar_bg_color);
            let g_handle = G.translate
              ~x:(g.x+g_inner.x) ~y:(g.y+g_inner.y) g_handle_v
            in
            match G.inter geom g_handle with
            | None -> ()
            | Some gh ->
                let gh = G.translate ~x ~y gh in
                [%debug "%s rendering vscroll handle: %a"
                   self#me G.pp gh];
                Render.fill_rect renderer (Some gh)
                  (self#get_p Props.scrollbar_handle_color)

    method render_scrolls_if_needed renderer ~offset geom =
      self#render_hscroll_if_needed renderer ~offset geom ;
      self#render_vscroll_if_needed renderer ~offset geom

    method render_me ~layer rend ~offset:(x,y) rg =
      (
       let gc = self#g_child in
       match G.inter rg
         { gc with x = g_inner.x + g.x ; y = g_inner.y + g.y }
       with
       | None ->
           [%debug "%s#render_me G.inter %a %a = None"
              self#me G.pp rg G.pp g_inner]
       | Some rg ->
           [%debug "%s#render_me rendering g=%a (rg ∩ g_inner)=%a"
              self#me G.pp g G.pp rg];
           (* ask child to render the exposed rectangle *)
           let g_child =
             { rg with
               x = offset_x + rg.x ;
               y = offset_y + rg.y ;
             }
           in
           [%debug "%s#render_me g_child=%a, offset_x=%d, offset_y=%d\n"
              self#me G.pp g_child offset_x offset_y];
           (* coordinates in render_child are still relative to
              current widget; they will be translated to child's coordinates
              when render_child calls child#render *)
           let (x,y) = (x - offset_x, y - offset_y) in
           self#render_child ~layer rend ~offset:(x,y)
             ~g_none:rg ~g_child
      );
      (*[%debug "%s#render Texture.copy src=%a ~x:%d y:%d"
         self#me G.pp g_child rg.x rg.y);
         Texture.copy ~from:t ~src:g_child ~x ~y rend target ;*)
      if layer = self#get_p Props.layer then
        self#render_scrolls_if_needed rend ~offset:(x,y) rg;

    method set_geometry geom =
      super#set_geometry geom;
      [%debug "%s#set_geometry: offset_x=%d, content_w=%d, g_inner.w=%d, offset_y=%d, content_h=%d, g_inner.h=%d"
        self#me offset_x content_w g_inner.w offset_y content_h g_inner.y];
      offset_x <- max 0 (min offset_x (content_w - g_inner.w)) ;
      let old_offset_y = offset_y in
      offset_y <- max 0 (min offset_y (content_h - g_inner.h)) ;
      self#set_g_handle_h ;
      self#set_g_handle_v ;
      [%debug "%s#set_geometry: offset_y: %d => %d" self#me old_offset_y offset_y]

    method! compute_child_geometry w =
      let cm = w#margin in
      content_w <-
        (match self#hscrollbar_policy with
        | `NOSCROLL -> self#gchild_w
        | _ ->
            let cw = w#min_width in
            max cw self#gchild_w
        );
      content_h <-
        (match self#vscrollbar_policy with
         | `NOSCROLL -> self#gchild_h
         | _ ->
             let ch = w#min_height in
             max ch self#gchild_h
        );
      { G.x = cm.left; y = cm.top;
        w = content_w - cm.left - cm.right ;
        h = content_h - cm.top - cm.bottom ;
      }

    method! private min_width_ =
      let m = self#get_p Props.margin in
      let p = self#get_p Props.padding in
      let b = self#get_p Props.border_width in
      m.left + b.left + p.left + p.right + b.right + m.right
    method! private min_height_ =
      let m = self#get_p Props.margin in
      let p = self#get_p Props.padding in
      let b = self#get_p Props.border_width in
      m.top + b.top + p.top + p.bottom + b.bottom + m.bottom
    method! max_width = self#child_max_width
    method! max_height = self#child_max_height

    method child_need_render ~layer geom =
      [%debug "%s#child_need_render ~layer:%a on %a"
         self#me Layer.pp layer G.pp geom];
      (* convert exposed part to child coord and see what part
         of required rendering should effectively be asked
         for rendering. *)
      let exposed = G.{ g_inner with x = offset_x; y = offset_y } in
      match G.inter exposed geom with
      | None -> ()
      | Some rg ->
          (* if child shrinked, we must render also the rest of
             the canvas *)
          let cg =
            match child with
            | None -> rg (* strange *)
            | Some c -> c#geometry
          in
          let w = if g_inner.w > cg.w then g_inner.w - rg.x else rg.w in
          let h = if g_inner.h > cg.h then g_inner.h - rg.y else rg.h in
          let rg = G.translate
            ~x:(g.x + g_inner.x - offset_x)
              ~y:(g.y + g_inner.y - offset_y) { rg with w ; h }
          in
          [%debug "%s#child_need_render final rg=%a"
             self#me G.pp rg];
          self#need_render ~layer rg

    initializer
      state_machine <- Misc.mk_state_machine `Base self#state_on_event ;
  end

(** Convenient function to create a {!class-fixed_size}.
  [hpolicy] and [vpolicy] optional arguments specify horizontal
  and vertical scrollbar policies.
  See {!Widget.widget_arguments} for other arguments. *)
let scrollbox ?classes ?name ?props ?wdata ?hpolicy ?vpolicy
  ?hcovers_child ?vcovers_child ?pack () =
  let w = new scrollbox ?classes ?name ?props ?wdata () in
  Option.iter w#set_hscrollbar_policy hpolicy ;
  Option.iter w#set_vscrollbar_policy vpolicy ;
  Option.iter w#set_hscrollbar_covers_child hcovers_child ;
  Option.iter w#set_vscrollbar_covers_child vcovers_child ;
  Widget.may_pack ?pack w#coerce ;
  w