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

(** Canvas.

A canvas widget is composed of a root canvas {!class-group}. A
group can contain {!class-full_item}s (a {!class-group}s is
a [fullitem] too).

Coordinates of an item are relative to its parent group.

All item classes takes optional [x] and [y] arguments to define
their coordinates relatively to their group, with default value [0].
The group can be given with the optional [group] argument,
or set with the [set_group] method. These three arguments are
also handled by {{!convenient_functions}convenient functions
to create items}.
*)

open Tsdl

(**/**)
module Bounds = Set.Make
  (struct
     type t = int * Oid.t
     let compare (n1, id1) (n2, id2) =
       match Stdlib.compare n1 n2 with
       | 0 -> Oid.compare id1 id2
       | n -> n
   end)
(**/**)

(** {2 Items} *)

(** This virtual class defines the item interface. Most of the
  virtual methods correspond to methods of {!Widget.class-widget}
  and are defined by inherting from {!Widget.class-widget} or other
  widgets. *)
class virtual item ?(group:group option) ?(x=0) ?(y=0) () =
  let init_group = group in
  object(self)
    method as_item = (self :> item)
    method virtual id : Oid.t

    (**/**)
    method virtual set_geometry: G.t -> unit
    val virtual mutable g : G.t
    (**/**)
    method virtual geometry : G.t

    (**/**)
    val virtual mutable frozen : bool
    (**/**)

    method virtual get_p : 'a. 'a Props.prop -> 'a
    method virtual coerce : Widget.widget
    method virtual wtree : Widget.widget Widget.tree
    method virtual me : string

    (**/**)
    method virtual set_parent :
      ?with_rend:((Sdl.renderer -> unit Lwt.t) -> unit Lwt.t)
      -> Widget.widget option -> unit
    val virtual mutable min_width : int option
    val virtual mutable min_height : int option
    method virtual private min_width_ : int
    method virtual private min_height_ : int
    (**/**)

    method virtual min_width : int
    method virtual min_height : int
    method virtual as_full_item : full_item

    (**/**)
    method update_bounds ~(recur:bool) = ()
    (**/**)

    (** {2 Coordinates} *)

    method x = self#geometry.x
    method y = self#geometry.y
    method set_x (x_:int) = self#set_xy (x_, self#y)
    method set_y (y_:int) = self#set_xy (self#x, y_)
    method set_xy (x,y) =
      [%debug "%s#set_xy (%d,%d)" self#me x y];
      let g0 = self#geometry in
      self#set_geometry { g0 with x ; y } ;
      let g1 = self#geometry in
      self#update_bounds_in_parent_group ~g0 ~g1

    method move ?(x=self#x) ?(y=self#y) () = self#set_xy (x,y)

    method to_canvas_coords ~x ~y =
      match group with
      | None -> (x, y)
      | Some g -> g#to_canvas_coords ~x ~y

    (** {2 Group} *)

    (**/**)
    val mutable group = (None : group option)
    (**/**)
    method group = group
    method set_group g =
      Option.iter (fun (g:group) -> g#remove_item (self#as_full_item)) group ;
      group <- g

    (**/**)
    (** this method should be used only is the group class, to prevent
       a recursive call to remove_item, trying to remove the item
       twice from the same group, issuing a warning. *)
    method set_group_none = group <- None
    (**/**)

    (** {2 Accessing items} *)

    method on_items_at (f:full_item->bool Lwt.t) ~(x:int) ~(y:int) = Lwt.return_false
    method get_item_at ~x ~y =
      if G.inside ~x ~y self#geometry then Some self#as_full_item else None

    method get_leaf_items_at acc ~x ~y =
      match self#get_item_at ~x ~y with
      | None -> acc
      | Some i -> i::acc

    (**/**)

    method virtual render : layer:Layer.t -> Sdl.renderer ->
      offset:(int*int) -> G.t -> unit

    method need_render ~layer geom =
      if not frozen then
        match group with
        | None -> ()
        | Some group ->
            [%debug "item%s#need_render: geom=%a" self#me G.pp geom];
            group#child_need_render ~layer geom

    method need_resize =
      let g0 = g in
      min_width <- None ;
      min_height <- None ;
      let w = self#min_width in
      let h = self#min_height in
      self#set_geometry { g0 with w ; h };
      let g1 = self#geometry in
      [%debug "%s[item]#need_resize: g0=%a g1=%a"
        self#me G.pp g0 G.pp g1];
      self#update_bounds_in_parent_group ~g0 ~g1

    method update_bounds_in_parent_group ~g0 ~g1 =
      match group with
      | None -> ()
      | Some group ->
          let id = self#id in
          group#set_item_hbound g0 id g1 ;
          group#set_item_vbound g0 id g1

    initializer
      match init_group with
      | None -> ()
      | Some group -> group#add_item ?x:(Some x) ?y:(Some y) (self#as_full_item)

  end

(** A [full_item] is a {!Widget.class-widget} with item interface.*)
and virtual full_item ?classes ?name ?props ?wdata ?group ?x ?y () =
  object(self)
    inherit Widget.widget ?classes ?name ?props ?wdata () as widget
    inherit item ?group ?x ?y () as super
    method as_full_item = (self :> full_item)
    (**/**)
    method! need_resize =
      min_width <- None ;
      min_height <- None ;
      match group with
      | None -> widget#need_resize
      | _ -> (* child should call set_item_vbound and set_item_hbound *)
          (*Log.warn
           (fun m -> m "%s#child_need_resize should not be called when item has a group"
             self#me)*)
           ()
  end

(** a [container_item] is a {!Container.class-container} with item interface. *)
and virtual ['a] container_item ?classes ?name ?props ?wdata ?group ?x ?y () =
  object(self)
    inherit ['a] Container.container_list ?classes ?name ?props ?wdata () as widget
    inherit item ?group ?x ?y () as super
    method as_full_item = ((self :> 'a container_item) :> full_item)
    (**/**)
    method need_resize =
      min_width <- None ;
      min_height <- None ;
      match group with
      | None -> widget#need_resize
      | _ -> (* child should call set_item_vbound and set_item_hbound *)
          (*Log.warn
           (fun m -> m "%s#child_need_resize should not be called when item has a group"
             self#me)*)
          ()
  end

(** A group is a \[[full_item]\] {!class-container_item}.
  Its kind is ["canvas_group"]. *)
and group ?classes ?name ?props ?wdata ?group ?x ?y () =
  object(self)
    inherit [full_item] container_item ?classes ?name ?props ?wdata ?group ?x ?y () as super
    (**/**)
    method kind = "canvas_group"
    val mutable hbounds = Bounds.empty
    val mutable vbounds = Bounds.empty
    (**/**)

    method as_group = (self :> group)
    method items = List.map (fun c -> c.Container.data) children

    (** Removes all items from group. *)
    method clear =
      List.iter (fun i -> self#remove_item i) self#items

    (**/**)
    method! set_geometry g =
      [%debug "%s#set_geometry %a" self#me G.pp g];
      super#set_geometry g

    method! to_canvas_coords ~x ~y =
      let (x, y) = g.x + g_inner.x + x, g.y + g_inner.y + y in
      match group with
      | None -> (x,y)
      | Some g -> g#to_canvas_coords ~x ~y
    (**/**)

    method of_canvas_coords ~x ~y =
      let (x, y) = x - g.x - g_inner.x, y - g.y + g_inner.y in
      match group with
      | None -> (x,y)
      | Some g -> g#of_canvas_coords ~x ~y

    (**/**)
    method! freeze =
      super#freeze ;
      List.iter (fun c -> c.Container.data#freeze) children

    method! unfreeze =
      super#unfreeze ;
      List.iter (fun c -> c.Container.data#unfreeze) children

    method! get_item_at ~x:x_ ~y:y_ =
      if G.inside ~x:x_ ~y:y_ g then
        (
         let x = x_ - g.x - g_inner.x in
         let y = y_ - g.y - g_inner.y in
         let rec iter = function
         | [] -> Some (self#as_full_item)
         | c :: q ->
             match c.Container.data#get_item_at ~x ~y with
             | None -> iter q
             | x -> x
         in
         iter children
        )
      else
        None

    method! get_leaf_items_at acc ~x:x_ ~y:y_ =
      if G.inside ~x:x_ ~y:y_ g then
        (
         let x = x_ - g.x - g_inner.x in
         let y = y_ - g.y - g_inner.y in
         List.fold_left
           (fun acc c -> c.Container.data#get_leaf_items_at acc ~x ~y)
           acc children
        )
      else
        acc

    method! on_items_at f ~x:x_ ~y:y_ =
      [%debug "%s#on_items_at ~x:%d ~y:%d" self#me x_ y_];
      let x = x_ - g.x - g_inner.x in
      let y = y_ - g.y - g_inner.y in
      let rec iter = function
      | [] -> Lwt.return_false
      | c :: q ->
          let i = c.Container.data in
          [%debug "%s#on_items_at i=%s i#g=%a x=%d, y=%d"
            self#me i#me G.pp i#geometry x y];
          if G.inside ~x ~y i#geometry then
            match%lwt f i with
            | false -> i#on_items_at f ~x ~y
            | true -> Lwt.return_true
          else
            iter q
      in
      iter children
    (**/**)

    method width =
      let w = match Bounds.max_elt_opt hbounds with
        | None -> 0
        | Some (w,_) -> w
      in
      super#min_width_ + w
    method height =
      let h = match Bounds.max_elt_opt vbounds with
      | None -> 0
      | Some (h,_) -> h
      in
      super#min_height_ + h

    (**/**)
    method! private min_width_ = self#width
    method! private min_height_ = self#height

    method update_bounds ~recur =
      if recur then
        List.iter (fun c -> c.Container.data#update_bounds ~recur) children;
      self#update_hbound;
      self#update_vbound;
      self#set_geometry { g with w = self#width ; h = self#height }

    method update_hbound =
      hbounds <- List.fold_left
        (fun acc c ->
          let i = c.Container.data in
          let g = i#geometry in Bounds.add (g.G.x + g.w, i#id) acc)
        Bounds.empty children;

    method update_vbound =
      vbounds <- List.fold_left
        (fun acc c ->
          let i = c.Container.data in
          let g = i#geometry in Bounds.add (g.G.y + g.h, i#id) acc)
        Bounds.empty children

    method set_item_hbound (oldg:G.t) id (g:G.t) =
      [%debug "%s#set_item_hbound oldg=%a id=%a g=%a"
         self#me G.pp oldg Oid.pp id G.pp g];
      let my_oldg = self#geometry in
      let oldw = self#width in
      let s = Bounds.remove (oldg.x + oldg.w, id) hbounds in
      hbounds <- Bounds.add (g.x + g.w, id) s;
      self#set_geometry { my_oldg with w = self#width };
      let w = self#width in
      [%debug "%s#set_item_hbound oldw=%d, w=%d, id=%a\nbounds=%s"
         self#me oldw w Oid.pp id
           (String.concat ", "
            (List.map
             (fun (x,id) -> Printf.sprintf "(%d,%s)" x (Oid.to_string id))
               (Bounds.elements hbounds))
            )];
      if oldw <> w then
        match group with
        | Some group ->
            group#set_item_hbound my_oldg self#id self#geometry;
            if not frozen then
              self#need_render ~layer:(self#get_p Props.layer) g
        | None ->
            if not frozen then super#need_resize

    method set_item_vbound (oldg:G.t) id (g:G.t) =
      [%debug "%s#set_item_vbound oldg=%a id=%a g=%a"
         self#me G.pp oldg Oid.pp id G.pp g];
      let my_oldg = self#geometry in
      let oldh = self#height in
      let s = Bounds.remove (oldg.y + oldg.h, id) vbounds in
      vbounds <- Bounds.add (g.y + g.h, id) s;
      self#set_geometry { my_oldg with h = self#height };
      let h = self#height in
      [%debug "%s#set_item_vbound oldh=%d, h=%d, id=%a\nbounds=%s"
         self#me oldh h Oid.pp id
           (String.concat ", "
            (List.map
             (fun (y,id) -> Printf.sprintf "(%d,%s)" y (Oid.to_string id))
               (Bounds.elements vbounds))
           )];
      if oldh <> h then
        match group with
        | Some group ->
            group#set_item_vbound my_oldg self#id self#geometry;
            if not frozen then
              self#need_render ~layer:(self#get_p Props.layer) g
        | None ->
            if not frozen then super#need_resize
    (**/**)

    (** Adds the given item to group. The item's coordinates
      can be set with [x] and [y] optional arguments. *)
    method add_item ?x ?y (i:full_item) =
      match super#add i#coerce i with
      | false -> ()
      | true ->
         i#set_group (Some (self:>group));
          match x, y with
          | None, None -> i#set_xy (i#x, i#y)
          | Some x, None -> i#set_x x
          | None, Some y -> i#set_y y
          | Some x, Some y -> i#set_xy (x, y)

    (** Removes the given item from the group. *)
    method remove_item (i:full_item) =
      [%debug "%s#remove_item %s" self#me i#me];
      match super#remove i#coerce with
      | false -> ()
      | true ->
          let g0 = self#geometry in
          i#set_group_none ;
          let _g = i#geometry in
          self#update_bounds ~recur:false;
          let g1 = self#geometry in
          Log.info (fun m -> m "%s#remove_item %s: g0=%a, g1=%a" self#me i#me
             G.pp g0 G.pp g1);
          if g0 <> g1 then
            self#update_bounds_in_parent_group ~g0 ~g1

    (**/**)
    val mutable child_need_render_cb = (None : (layer:Layer.t -> G.t -> unit) option)
    method set_child_need_render_cb x = child_need_render_cb <- x
    method child_need_render ~layer geom =
      if not frozen then
        (
         [%debug "%s#child_need_render: geom=%a" self#me G.pp geom];
         let g = self#geometry in
         let g_inner = self#g_inner in
         let geom = { geom with
             G.x = geom.G.x + g.x + g_inner.x;
             y = geom.y + g.y + g_inner.y;
           }
         in
         self#need_render ~layer geom
        )

    method need_render ~layer geom =
      match group with
      | Some group -> group#child_need_render ~layer geom
      | None ->
          match child_need_render_cb with
          | None -> ()
          | Some f -> f ~layer geom
    (**/**)

    (** Raises the given item above all the other items of the group. *)
    method raise (item : full_item) =
      match self#widget_data item#coerce with
      | None -> ()
      | Some data ->
          super#remove item#coerce ;
          ignore(super#add item#coerce data)

  end

(** An item to draw a rectangle.
   Its kind is ["rect"]. Width and height of the
   rectangle can be specified with optional arguments [w] and [h]. *)
class rect ?classes ?name ?props ?wdata ?group ?x ?y ~w ~h () =
  object(self)
    inherit full_item ?classes ?name ?props ?wdata ?group ?x ?y () as super
    (**/**)
    method kind = "rect"
    val mutable h = h
    val mutable w = w
    method private set_width w_ = w <- w_
    method private set_height h_ = h <- h_
    method! private min_width_ = w
    method! private min_height_ = h
    method! max_width = Some w
    method! max_height = Some h

    method! geometry = { g with h ; w }
    method! set_geometry g = super#set_geometry { g with h ; w }
    (**/**)

    method resize ?w ?h () =
      let g0 = self#geometry in
      Option.iter self#set_width w;
      Option.iter self#set_height h;
      self#set_geometry g ;
      let g1 = self#geometry in
      self#update_bounds_in_parent_group ~g0 ~g1

    (**/**)
    method! is_leaf_widget = true
    (**/**)
    initializer
      self#set_geometry { g with w ; h };
  end

(* From https://www.geeksforgeeks.org/cubic-bezier-curve-implementation-in-c/ *)
let bezier_points =
  let pow = Float.pow in
  let f p u =
    let u' = 1. -. u in
    let r =
      (pow u' 3.) *. p.(0)
        +. 3. *. u *. (pow u' 2.) *. p.(1)
        +. 3. *. u' *. (pow u 2.) *. p.(2)
        +. (pow u 3.) *. p.(3)
    in
    truncate r
  in
  let rec spline step points_x points_y acc min_x min_y max_x max_y last_x last_y u =
     if u > 1. then
      (acc, min_x, min_y, max_x, max_y, last_x, last_y)
    else
      let x = f points_x u in
      let y = f points_y u in
      if x = last_x && y = last_y then
        spline step points_x points_y acc min_x min_y max_x max_y last_x last_y (u+.step)
      else
        let min_x = min min_x x in
        let min_y = min min_y y in
        let max_x = max max_x x in
        let max_y = max max_y y in
        spline step points_x points_y
          ((x,y) :: acc)
          min_x min_y max_x max_y x y (u+.step)
  in
  let rec splines step acc min_x min_y max_x max_y last_x last_y = function
  | [_] -> (acc, min_x, min_y, max_x, max_y)
  | (x1, y1) :: (x2, y2) :: (x3, y3) :: (x4, y4) :: q ->
      let (acc, min_x, min_y, max_x, max_y, last_x, last_y) =
        let points_x = [| float x1 ; float x2 ; float x3 ; float x4 |] in
        let points_y = [| float y1 ; float y2 ; float y3 ; float y4 |] in
        spline step points_x points_y acc min_x min_y max_x max_y last_x last_y 0.
      in
      splines step acc min_x min_y max_x max_y last_x last_y ((x4, y4) :: q)
  | _ -> assert false
  in
  fun points ->
    match List.length points with
    | n when n mod 3 <> 1 ->
        Log.warn (fun m -> m "Invalid Bezier curve points: [| %s |]"
           (String.concat ", "
             (List.map (fun (x,y) -> Printf.sprintf "(%d, %d)" x y) points)));
        None
    | len ->
        let (min_x, min_y, max_x, max_y) = List.fold_right
          (fun (x,y) (min_x, min_y, max_x, max_y) ->
             (min x min_x, min y min_y, max x max_x, max y max_y))
            points (max_int, max_int, min_int, min_int)
        in
        let w = max_x - min_x in
        let h = max_y - min_y in
        let steps = 50 * max w h in
        let step = 1. /. (float steps) in
        let (p, min_x, min_y, max_x, max_y) =
          splines step [] max_int max_int min_int min_int min_int min_int points
        in
        let g = {
            G.x = min_x ; y = min_y ;
            w = max 0 (max_x - min_x + 1);
            h = max 0 (max_y - min_y + 1);
          }
        in
        (* normalize by translating all points by -min{x,y} *)
        let p = List.rev_map (fun (x,y) -> (x - min_x, y - min_y)) p in
        Some (g, p)

class bezier_curve ?classes ?name ?props ?wdata ?group ?x ?y ?points () =
  object(self)
    inherit full_item ?classes ?name ?props ?wdata ?group ?x ?y () as super
    (**/**)
    method kind = "bezier_curve"
    val mutable rpoints = None
    val mutable h = 0
    val mutable w = 0
    method! private min_width_ = w
    method! private min_height_ = h
    method! max_width = Some w
    method! max_height = Some h

    method! geometry = { g with h ; w }
    method! set_geometry g = super#set_geometry { g with h ; w }
    (**/**)

    method set_points p =
      let g0 = self#geometry in
      let g1 =
        match p with
        | None -> w <- 0; h <- 0; rpoints <- None; g
        | Some p ->
            match bezier_points p with
            | None -> rpoints <- None; g
            | Some (bounds, rp) ->
                w <- bounds.w;
                h <- bounds.h;
                (*Log.warn (fun m -> m "bezier curve: w=%d, h=%d" w h);*)
                rpoints <- Some (p, rp);
                bounds
      in
      self#set_geometry g1 ;
      self#update_bounds_in_parent_group ~g0 ~g1

    method private draw_points rend ~offset:(x,y) =
      match rpoints with
      | None -> ()
      | Some (spec, p) ->
          let ox = x + g.x in
          let oy = y + g.y in
          let open Misc in
          (*let (x0, y0) = List.hd p in
          let (x3, y3) = List.hd (List.rev p) in
          Log.warn (fun m -> m "%s: x0=%d, y0=%d, x3=%d, y3=%d" self#me x0 y0 x3 y3);
          Render.draw_circle rend ~x:(ox+x0) ~y:(oy+y0) ~r:2 Color.green ;
          Render.draw_circle rend ~x:(ox+x3) ~y:(oy+y3) ~r:2 Color.red ;*)
          List.iter (fun (x,y) ->
             let> () = Sdl.render_draw_point rend (ox + x) (oy + y) in
             ()
          ) p

    method private draw_curve rend ~offset:(x,y) rg =
      match points with
      | None -> ()
      | Some p ->
          let clip = G.translate ~x ~y rg in
          let f rend =
            Render.with_color rend self#fg_color (self#draw_points ~offset:(x,y))
          in
          (*Log.warn (fun m -> m "%s: clip %a, g=%a, offset=%d,%d" self#me G.pp clip G.pp g x y) ;*)
          Render.with_clip rend (G.to_rect clip) f

    method render ~layer rend ~offset geom =
      if self#visible && layer = self#get_p Props.layer then
        (
         match self#need_rendering geom with
         | None -> ()
         | Some rg ->
             self#draw_curve rend ~offset rg;
             if not self#sensitive then
               self#render_insensitive rend ~offset rg
        )

    (**/**)
    method! is_leaf_widget = true
    (**/**)
    initializer
      self#set_points points
  end

(** Widgets inheriting a widget and an {!class-item} keeps
  the original widget kind but can be identified specifically
  in theming for example by using ["canvas > <kind>"]. *)

(** A {!Bin.class-bin} as item. *)
class bin ?classes ?name ?props ?wdata ?group ?x ?y () =
  object(self)
    inherit Bin.bin ?classes ?name ?props ?wdata () as bin
    inherit item ?group ?x ?y () as super
    method as_full_item = (self :> full_item)
    method set_geometry g = bin#set_geometry g
  end

(** A {!Text.class-label} as item. *)
class label ?classes ?name ?props ?wdata ?group ?x ?y () =
  object(self)
    inherit Text.label ?classes ?name ?props ?wdata () as widget
    inherit item ?group ?x ?y () as super
    method as_full_item = (self :> full_item)
  end

(** A {!Text.class-glyph} as item. *)
class glyph ?classes ?name ?props ?wdata ?group ?x ?y () =
  object(self)
    inherit Text.glyph ?classes ?name ?props ?wdata () as widget
    inherit item ?group ?x ?y () as super
    method as_full_item = (self :> full_item)
  end

(** A {!Pack.class-box} as item. *)
class ['a] box ?classes ?name ?props ?wdata ?group ?x ?y () =
  object(self)
    inherit ['a] Pack.box ?classes ?name ?props ?wdata () as widget
    inherit item ?group ?x ?y () as super
    method as_full_item = (self :> full_item)
    method set_geometry g = widget#set_geometry g
  end

(** A {!Pack.class-paned} as item. *)
class paned ?classes ?name ?props ?wdata ?group ?x ?y () =
  object(self)
    inherit Pack.paned ?classes ?name ?props ?wdata () as widget
    inherit item ?group ?x ?y () as super
    method as_full_item = (self :> full_item)
    method set_geometry g = widget#set_geometry g
  end

(** A {!Bin.class-fixed_size} as item. *)
class fixed_size ?classes ?name ?props ?wdata ?group ?x ?y ?w ?h () =
  object(self)
    inherit Bin.fixed_size ?classes ?name ?props ?wdata ?w ?h () as widget
    inherit item ?group ?x ?y () as super
    method as_full_item = (self :> full_item)
    method set_geometry g = widget#set_geometry g
  end

(** A {!Flex.class-flex} as item. *)
class ['a] flex ?classes ?name ?props ?wdata ?group ?x ?y () =
  object(self)
    inherit ['a] Flex.flex ?classes ?name ?props ?wdata () as flex
    inherit item ?group ?x ?y () as super
    method as_full_item = (self :> full_item)
    method set_geometry g = flex#set_geometry g
  end

(** {2:convenient_functions Convenient functions to create items}

These convenient functions are used to create items.
They all take [x] and [y] optional arguments to
specify the coordinates of the created item, and
[group] to specify the group the item belongs to.
Other arguments are {{!Widget.widget_arguments}generic widget arguments}
or arguments specific to the kind of item.
*)

(** Creates a {!class-group}. *)
let group ?classes ?name ?props ?wdata ?group ?x ?y () =
  new group ?classes ?name ?props ?wdata ?group ?x ?y ()

(** Creates a {!class-rect}. *)
let rect ?classes ?name ?props ?wdata ?group ?x ?y ~w ~h () =
  new rect ?classes ?name ?props ?wdata ?group ?x ?y ~w ~h ()

(** Creates a {!class-bezier_curve}. *)
let bezier_curve ?classes ?name ?props ?wdata ?group ?x ?y ?points () =
  new bezier_curve ?classes ?name ?props ?wdata ?group ?x ?y ?points ()

(** Creates a {!class-bin}. *)
let bin ?classes ?name ?props ?wdata ?group ?x ?y () =
  let t = new bin ?classes ?name ?props ?wdata ?group ?x ?y () in
  t

(** Creates a {!class-label}. *)
let label ?classes ?name ?props ?wdata ?group ?x ?y text =
  let t = new label ?classes ?name ?props ?wdata ?group ?x ?y () in
  t#set_text text ;
  t

(** Creates a {!class-glyph}. *)
let glyph ?classes ?name ?props ?wdata ?group ?x ?y gly =
  let t = new glyph ?classes ?name ?props ?wdata ?group ?x ?y () in
  t#set_glyph gly ;
  t

(** Creates a {!class-box} with vertical orientation.*)
let vbox ?classes ?name ?props ?wdata ?group ?x ?y () =
  let w = new box ?classes ?name ?props ?wdata ?group ?x ?y () in
  w#set_orientation Props.Vertical;
  w

(** Creates a {!class-box} with horizontal orientation.*)
let hbox ?classes ?name ?props ?wdata ?group ?x ?y () =
  let w = new box ?classes ?name ?props ?wdata ?group ?x ?y () in
  w#set_orientation Props.Horizontal ;
  w

(** Creates a {!class-paned} with vertical orientation. *)
let vpaned ?classes ?name ?props ?wdata ?group ?x ?y () =
  let w = new paned ?classes ?name ?props ?wdata ?group ?x ?y () in
  w#set_orientation Props.Vertical;
  w

(** Creates a {!class-paned} with horizontal orientation. *)
let hpaned ?classes ?name ?props ?wdata ?group ?x ?y () =
  let w = new paned ?classes ?name ?props ?wdata ?group ?x ?y () in
  w#set_orientation Props.Horizontal ;
  w

(** Creates a {!class-fixed_size}.*)
let fixed_size ?classes ?name ?props ?wdata ?group ?x ?y ?w ?h () =
  new fixed_size ?classes ?name ?props ?wdata ?group ?x ?y ?w ?h ()

(** Creates a {!class-flex}.*)
let flex ?classes ?name ?props ?wdata ?group ?x ?y
  ?(orientation=Props.Horizontal)
    ?justification ?items_alignment ?content_alignment
    ?inter_space ?wrap ?wrap_on_break ?collapse_spaces  () =
  let w = new flex ?classes ?name ?props ?wdata ?group ?x ?y () in
  w#set_orientation orientation ;
  Option.map w#set_justification justification ;
  Option.map w#set_items_alignment items_alignment ;
  Option.map w#set_content_alignment content_alignment ;
  Option.map w#set_inter_space inter_space ;
  Option.map w#set_wrap wrap ;
  Option.map w#set_wrap_on_break wrap_on_break ;
  Option.map w#set_collapse_spaces collapse_spaces;
  w

(** {2 Canvas widget} *)

class canvas ?classes ?name ?props ?wdata () =
  object(self)
    inherit Widget.widget ?classes ?name ?props ?wdata () as super

    (**/**)
    method kind = "canvas"
    val mutable root = new group ()

    method! do_apply_theme ~root:rprops ~parent parent_path rules =
      super#do_apply_theme ~root:rprops ~parent parent_path rules;
      let path = self#css_path ~parent_path () in
      root#do_apply_theme ~root:rprops ~parent:theme_props path rules;
      min_width <- None ;
      min_height <- None

    (**/**)

    (** Returns root group. *)
    method root = root

    (** Sets root group. *)
    method set_root r =
      root#set_child_need_render_cb None ;
      root <- r ;
      r#set_parent ?with_rend:with_renderer (Some self#coerce) ;
      root#set_child_need_render_cb
        (Some self#child_need_render)

    (** Freezes, removes all items from root group and unfreezes. *)
    method clear =
      self#freeze ;
      root#clear ;
      self#unfreeze

    (** Returns item at the given coordinates, if any. Coordinates have
        the same origin as the canvas coordinates. *)
    method get_item_at ~x ~y =
      let g = root#geometry in
      root#get_item_at ~x:(x - g.x - g_inner.x) ~y:(y - g.y - g_inner.y)

    (** Get leaf items at the given coordinates. Coordinates have
        the same origin as the canvas coordinates. *)
    method get_leaf_items_at ~x ~y =
      let g = root#geometry in
      let items = root#get_leaf_items_at []
        ~x:(x - g.x - g_inner.x)
        ~y:(y - g.y - g_inner.y)
      in
      [%debug "%s#get_leaf_items => %s"
        self#me (String.concat ", " (List.map (fun i -> i#me) items))];
      items

    (**/**)
    method! wtree = Widget.N (self#coerce, [root#wtree])

    val mutable frozen_to_render = (None: G.t option)
    method! freeze =
      frozen_to_render <- Some G.zero;
      root#freeze
    method! unfreeze =
      match frozen_to_render with
      | None -> ()
      | Some rg ->
          frozen_to_render <- None;
          root#unfreeze;
          root#update_bounds ~recur:true;
          self#need_resize;
          self#need_render ~layer:(self#get_p Props.layer) rg

    method! child_need_render ~layer geom =
      let geom =
        let g = self#geometry in
        let g_inner = self#g_inner in
        { geom with
          x = geom.x + g.x + g_inner.x ;
          y = geom.y + g.y + g_inner.y }
      in
      match frozen_to_render with
      | None -> self#need_render ~layer geom
      | Some rg -> frozen_to_render <- Some (G.union rg geom)

    method! private min_width_ =
      let w = super#min_width_ + root#width in
      [%debug "%s#min_width => %d" self#me w];
      w
    method! private min_height_ =
      let h = super#min_height_ + root#height in
      [%debug "%s#min_height => %d" self#me h];
      h

    method! render_me ~layer rend ~offset:(x,y) rg =
      let (x,y) = (x + g.x + g_inner.x, y + g.y + g_inner.y) in
      let rg = G.translate ~x:(-g.x-g_inner.x) ~y:(-g.y-g_inner.y) rg in
      root#render ~layer rend ~offset:(x,y) rg

    method! set_geometry g =
      let g = { g with w = max self#min_width g.w ; h = max self#min_height g.h } in
      [%debug "%s#set_geometry with g=%a" self#me G.pp g];
      super#set_geometry g

    (* propagate only events with position = Some (mouse events)
       or keyboard related events (sent to the widget only if
       is_focus property is true. *)
    method! on_sdl_event_down ~oldpos pos e =
      if self#sensitive then
        let b =
          let pass_event =
            match Sdl.Event.(enum (get e typ)) with
            | `Key_down | `Key_up | `Text_input | `Text_editing -> true
            | _ -> pos <> None
          in
          if pass_event then
            let f (x,y) = (x - g.x - g_inner.x , y - g.y - g_inner.y) in
            let child_oldpos = Option.map f oldpos in
            let child_pos = Option.map f pos in
            root#on_sdl_event_down ~oldpos:child_oldpos child_pos e
          else
            false
        in
        (*Log.warn (fun m -> m "%s#on_sdl_event_down => return %b" self#me b);*)
        match b with
        | true -> true
        | false -> self#on_sdl_event pos e
      else
        false

    method! release_focus =
      match root#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 -> root#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 ->
            [%debug "%s#grab_focus: i'm focusable" self#me];
            let b = match self#get_focus with
              | None -> false
              | Some _ -> true
            in
            [%debug "%s#grab_focus: get_focus => %b" self#me b];
            b
        | _ ->
            match self#get_p Props.can_focus with
            | false -> false
            | true -> root#grab_focus ~last ()
      else
        false

    initializer
      self#set_root root;
  end


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