helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/gtkRange.ml

   1 (* $Id$ *)
   2
   3 open Gaux
   4 open Gtk
   5 open Tags
   6 open GtkBase
   7
   8 module Progress = struct
   9   let cast w : progress obj = Object.try_cast w "GtkProgress"
  10   external set_show_text : [>`progress] obj -> bool -> unit
  11       = "ml_gtk_progress_set_show_text"
  12   external set_text_alignment :
  13       [>`progress] obj -> ?x:float -> ?y:float -> unit -> unit
  14       = "ml_gtk_progress_set_show_text"
  15   external set_format_string : [>`progress] obj -> string -> unit
  16       = "ml_gtk_progress_set_format_string"
  17   external set_adjustment : [>`progress] obj -> [>`adjustment] obj -> unit
  18       = "ml_gtk_progress_set_adjustment"
  19   external configure :
  20       [>`progress] obj -> current:float -> min:float -> max:float -> unit
  21       = "ml_gtk_progress_configure"
  22   external set_percentage : [>`progress] obj -> float -> unit
  23       = "ml_gtk_progress_set_percentage"
  24   external set_value : [>`progress] obj -> float -> unit
  25       = "ml_gtk_progress_set_value"
  26   external get_value : [>`progress] obj -> float
  27       = "ml_gtk_progress_get_value"
  28   external get_percentage : [>`progress] obj -> float
  29       = "ml_gtk_progress_get_current_percentage"
  30   external set_activity_mode : [>`progress] obj -> bool -> unit
  31       = "ml_gtk_progress_set_activity_mode"
  32   external get_current_text : [>`progress] obj -> string
  33       = "ml_gtk_progress_get_current_text"
  34   external get_adjustment : [>`progress] obj -> adjustment obj
  35       = "ml_gtk_progress_get_adjustment"
  36   let set ?value ?percentage ?activity_mode
  37       ?show_text ?format_string ?text_xalign ?text_yalign w =
  38     may value ~f:(set_value w);
  39     may percentage ~f:(set_percentage w);
  40     may activity_mode ~f:(set_activity_mode w);
  41     may show_text ~f:(set_show_text w);
  42     may format_string ~f:(set_format_string w);
  43     if text_xalign <> None || text_yalign <> None then
  44       set_text_alignment w ?x:text_xalign ?y:text_yalign ()
  45 end
  46
  47 module ProgressBar = struct
  48   let cast w : progress_bar obj = Object.try_cast w "GtkProgressBar"
  49   external create : unit -> progress_bar obj = "ml_gtk_progress_bar_new"
  50   external create_with_adjustment : [>`adjustment] obj -> progress_bar obj
  51       = "ml_gtk_progress_bar_new_with_adjustment"
  52   external set_bar_style :
  53       [>`progressbar] obj -> [`CONTINUOUS|`DISCRETE] -> unit
  54       = "ml_gtk_progress_bar_set_bar_style"
  55   external set_discrete_blocks : [>`progressbar] obj -> int -> unit
  56       = "ml_gtk_progress_bar_set_discrete_blocks"
  57   external set_activity_step : [>`progressbar] obj -> int -> unit
  58       = "ml_gtk_progress_bar_set_activity_step"
  59   external set_activity_blocks : [>`progressbar] obj -> int -> unit
  60       = "ml_gtk_progress_bar_set_activity_blocks"
  61   external set_orientation :
  62       [>`progressbar] obj -> Tags.progress_bar_orientation -> unit
  63       = "ml_gtk_progress_bar_set_orientation"
  64   let set ?bar_style ?discrete_blocks ?activity_step ?activity_blocks w =
  65     let may_set f opt = may opt ~f:(f w) in
  66     may_set set_bar_style bar_style;
  67     may_set set_discrete_blocks discrete_blocks;
  68     may_set set_activity_step activity_step;
  69     may_set set_activity_blocks activity_blocks
  70 end
  71
  72 module Range = struct
  73   let cast w : range obj = Object.try_cast w "GtkRange"
  74   external coerce : [>`range] obj -> range obj = "%identity"
  75   external get_adjustment : [>`range] obj -> adjustment obj
  76       = "ml_gtk_range_get_adjustment"
  77   external set_adjustment : [>`range] obj -> [>`adjustment] obj -> unit
  78       = "ml_gtk_range_set_adjustment"
  79   external set_update_policy : [>`range] obj -> update_type -> unit
  80       = "ml_gtk_range_set_update_policy"
  81   let set ?adjustment ?update_policy w =
  82     may adjustment ~f:(set_adjustment w);
  83     may update_policy ~f:(set_update_policy w)
  84 end
  85
  86 module Scale = struct
  87   let cast w : scale obj = Object.try_cast w "GtkScale"
  88   external hscale_new : [>`adjustment] optobj -> scale obj
  89       = "ml_gtk_hscale_new"
  90   external vscale_new : [>`adjustment] optobj -> scale obj
  91       = "ml_gtk_vscale_new"
  92   let create ?adjustment (dir : orientation) =
  93     let create = if dir = `HORIZONTAL then hscale_new else vscale_new  in
  94     create (Gpointer.optboxed adjustment)
  95   external set_digits : [>`scale] obj -> int -> unit
  96       = "ml_gtk_scale_set_digits"
  97   external set_draw_value : [>`scale] obj -> bool -> unit
  98       = "ml_gtk_scale_set_draw_value"
  99   external set_value_pos : [>`scale] obj -> position -> unit
 100       = "ml_gtk_scale_set_value_pos"
 101   external get_value_width : [>`scale] obj -> int
 102       = "ml_gtk_scale_get_value_width"
 103   external draw_value : [>`scale] obj -> unit
 104       = "ml_gtk_scale_draw_value"
 105   let set ?digits ?draw_value ?value_pos w =
 106     may digits ~f:(set_digits w);
 107     may draw_value ~f:(set_draw_value w);
 108     may value_pos ~f:(set_value_pos w)
 109 end
 110
 111 module Scrollbar = struct
 112   let cast w : scrollbar obj = Object.try_cast w "GtkScrollbar"
 113   external hscrollbar_new : [>`adjustment] optobj -> scrollbar obj
 114       = "ml_gtk_hscrollbar_new"
 115   external vscrollbar_new : [>`adjustment] optobj -> scrollbar obj
 116       = "ml_gtk_vscrollbar_new"
 117   let create ?adjustment (dir : orientation) =
 118     let create = if dir = `HORIZONTAL then hscrollbar_new else vscrollbar_new
 119     in create (Gpointer.optboxed adjustment)
 120 end
 121
 122 module Ruler = struct
 123   let cast w : ruler obj = Object.try_cast w "GtkRuler"
 124   external hruler_new : unit -> ruler obj = "ml_gtk_hruler_new"
 125   external vruler_new : unit -> ruler obj = "ml_gtk_vruler_new"
 126   let create (dir : orientation) =
 127     if dir = `HORIZONTAL then hruler_new () else vruler_new ()
 128   external set_metric : [>`ruler] obj -> metric_type -> unit
 129       = "ml_gtk_ruler_set_metric"
 130   external set_range :
 131       [>`ruler] obj ->
 132       lower:float -> upper:float -> position:float -> max_size:float -> unit
 133       = "ml_gtk_ruler_set_range"
 134   external get_lower : [>`ruler] obj -> float = "ml_gtk_ruler_get_lower"
 135   external get_upper : [>`ruler] obj -> float = "ml_gtk_ruler_get_upper"
 136   external get_position : [>`ruler] obj -> float = "ml_gtk_ruler_get_position"
 137   external get_max_size : [>`ruler] obj -> float = "ml_gtk_ruler_get_max_size"
 138   let set_range ?lower ?upper ?position ?max_size w =
 139     set_range w ~lower:(may_default get_lower w ~opt:lower)
 140       ~upper:(may_default get_upper w ~opt:upper)
 141       ~position:(may_default get_position w ~opt:position)
 142       ~max_size:(may_default get_max_size w ~opt:max_size)
 143   let set ?metric ?lower ?upper ?position ?max_size w =
 144     may metric ~f:(set_metric w);
 145     if lower <> None || upper <> None || position <> None || max_size <> None
 146     then set_range w ?lower ?upper ?position ?max_size
 147 end