Source file frame.ml

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

(** 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 ?(class_="frame") ?name ?props ?label () =
  object(self)
    inherit Bin.bin ~class_ ?name ?props () as super

    (**/**)
    val mutable label = (label : Widget.widget option)
    method! set_p ?(propagate=false) p v =
      Log.debug (fun m -> m "%s#set_p ~propagate:%b" self#me propagate);
      super#set_p ~propagate p v ;
      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

    (**/**)

    (** {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 ~layer renderer ~offset ~g_none ~g_child =
      match child with
      | None -> ()
      | Some _ -> super#render_child ~layer renderer ~offset ~g_none ~g_child

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

    method render_label ~layer 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 ~layer rend ~offset geom

    method label_min_width =
      match label with
      | None -> 0
      | Some w -> w#min_width
    method label_min_height =
      match label with
      | None -> 0
      | Some w -> w#min_height
    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_min_height in
      max p.top (label_h / 2)

    method! private min_width_ =
      let p = self#padding in
      let cm = self#child_margin in
      let cw = self#child_min_width in
      let bw = self#frame_border_width in
      (* use super#min_width but remove child_min_width *)
      super#min_width_ - cw +
      bw +
      (max (max p.left cm.left + cw - cm.left - cm.right + max p.right cm.right)
         (p.left + self#label_min_width + p.right)) +
        bw

    method! private min_height_ =
      let p = self#padding in
      let bw = self#frame_border_width in
      let lh = self#label_min_height in
      let lm = self#label_margin in
      let cm = self#child_margin in
      let ch = self#child_min_height in
      (* use super#min_height but remove child_min_height *)
      super#min_height_ - 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

    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
      Log.debug (fun m -> m "%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#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#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_min_width in
           let h = self#label_min_height 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
          Log.debug (fun m -> m "%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 ~layer rend geom =
      if layer = self#get_p Props.layer then
        (
         match self#texture rend with
         | None ->
             Log.debug (fun m -> m "%s#prepare: no texture" self#me);
             None
         | Some (`Exist t) -> Some t
         | Some (`New t) ->
             Log.debug (fun m -> m
                "%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
                 Log.debug (fun m -> m "%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
        )
      else
        None

    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 ->
          Log.debug (fun m -> m "%s: is_focus -> %b, invalidating texture"
             self#me now);
          self#invalidate_texture))
  end

(** 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 ?name ?props ?label ?pack () =
  let w = new frame ?name ?props ?label () in
  Widget.may_pack ?pack w ;
  w