helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/radtest/propwin.ml

   1 (* $Id$ *)
   2
   3 open GObj
   4
   5 open Common
   6 open Utils
   7
   8 class type tiwidget_base = object
   9   method name : string
  10   method proplist : (string * prop) list
  11 end
  12
  13 let prop_widget (prop : prop) =
  14   match prop#range with
  15     Enum l ->
  16       let w = GEdit.combo ~popdown_strings:l ~use_arrows:`ALWAYS () in
  17       w#entry#connect#changed ~callback:(fun () -> prop#set w#entry#text);
  18       w#entry#set_editable false;
  19       w#entry#set_text prop#get;
  20       w#coerce
  21   | String ->
  22       let w = GEdit.entry ~text:prop#get () in
  23       w#connect#activate ~callback:(fun () -> prop#set w#text);
  24       w#coerce
  25   | File ->
  26       let w = GPack.hbox () in
  27       let e = GEdit.entry ~text:prop#get ~editable:false ~packing:w#pack () in
  28       let b = GButton.button ~label:"..." ~packing:w#pack () in
  29       b#connect#clicked
  30         ~callback:(fun () -> get_filename
  31             ~callback:(fun name -> e#set_text name; prop#set name) (); ());
  32       w#coerce
  33   | Int ->
  34       let adjustment =
  35         GData.adjustment ~value:(float_of_string prop#get)
  36           ~lower:(-2.) ~upper:5000. ~step_incr:1. ~page_incr:10. ~page_size:0. ()
  37       in
  38       let w = GEdit.spin_button ~rate:0.5 ~digits:0 ~adjustment () in
  39       w#connect#activate
  40         ~callback:(fun () -> prop#set (string_of_int w#value_as_int));
  41       w#coerce
  42   | Float (lower, upper) ->
  43 (*      let adjustment =
  44         GData.adjustment ~value:(float_of_string prop#get)
  45           ~lower ~upper ~step_incr:((upper-.lower)/.100.)
  46           ~page_incr:((upper-.lower)/.10.) ~page_size:0. ()
  47       in
  48       let w = GEdit.spin_button ~rate:0.5 ~digits:2 ~adjustment () in
  49       w#connect#activate
  50         ~callback:(fun () -> prop#set (string_of_float w#value));
  51       w#coerce
  52 *)
  53       let w = entry_float ~init:(float_of_string prop#get) () in
  54       w#connect#activate
  55         ~callback:(fun () -> prop#set (string_of_float w#value));
  56       w#coerce
  57 (*  | Adjust ->
  58       let wpop = GWindow.window ~title:"Adjustment values" () in
  59       let vb = GPack.vbox ~packing:wpop#add()  in
  60       let hb1 = GPack.hbox ~packing:vb#pack () in
  61       let l1 = GMisc.label ~text:"lower" ~packing:hb1#pack () in
  62       let e1 = entry_float ~packing:hb1#pack
  63           ~init:(float_of_string prop#get) ~set:prop#set in
  64 *)
  65   | CList_titles ->
  66       let wpop = GWindow.window ~title:"titles of the columns" () in
  67       let vb = GPack.vbox ~packing:wpop#add () in
  68       let titles = split_string prop#get ~sep:' ' in
  69       let n = List.length titles in
  70       let rtitles = ref titles in
  71       let rget = ref [] and rset = ref [] in
  72       for i = 1 to n do
  73         match !rtitles with
  74         | hd::tl ->
  75             let hb = GPack.hbox ~packing:vb#pack () in
  76             let _ = GMisc.label ~text:("column" ^ (string_of_int i))
  77                 ~packing:hb#pack () in
  78             let e = GEdit.entry ~text:hd ~packing:hb#pack () in
  79             rtitles := tl;
  80             rget := (fun () -> e#text) :: !rget;
  81             rset := e#set_text :: !rset;
  82         | _ -> failwith "CList_titles: this cannot happen!!"
  83       done;
  84       rtitles := titles;
  85       rget := List.rev !rget;
  86       rset := List.rev !rset;
  87       let hb = GPack.hbox ~packing:vb#pack () in
  88       let ok = GButton.button ~label:"OK" ~packing:hb#pack () in
  89       let cancel = GButton.button ~label:"Cancel" ~packing:hb#pack () in
  90       ok#connect#pressed
  91         ~callback:(fun () ->
  92           let tit = List.map ~f:(fun f -> f ()) !rget in
  93           prop#set (String.concat ~sep:" " tit);
  94           rtitles := tit;
  95           wpop#misc#hide ());
  96       cancel#connect#pressed
  97         ~callback:(fun () ->
  98           wpop#misc#hide ();
  99           List.iter2 ~f:(fun f v -> f v) !rset !rtitles);
 100       let e = GEdit.entry ~text:"double click here" ~editable:false () in
 101       e#event#connect#button_press ~callback:
 102         (fun ev ->
 103           GdkEvent.get_type ev = `TWO_BUTTON_PRESS &&
 104           GdkEvent.Button.button ev = 1 &&
 105           begin
 106             wpop#misc#show ();
 107             GtkSignal.stop_emit ();
 108             true
 109           end);
 110       e#coerce
 111
 112 let prop_box list =
 113   let vbox = GPack.vbox () in
 114   List.iter list ~f:
 115     begin fun (name, prop) ->
 116       let hbox =
 117         GPack.hbox ~homogeneous:true ~packing:(vbox#pack ~expand:false) () in
 118       GMisc.label ~text:name ~packing:hbox#pack ();
 119       hbox#pack ~fill:true (prop_widget prop);
 120       GMisc.separator `HORIZONTAL ~packing:(vbox#pack ~expand:false) ();
 121       ()
 122     end;
 123   vbox
 124
 125 class ['a] frozen lz = object
 126   method get : 'a = Lazy.force lz
 127 end
 128
 129 let vbox =
 130   new frozen (lazy (GWindow.window ~show:true ~title:"Properties" ()))
 131
 132 let init () = vbox#get
 133
 134 let widget_pool = Hashtbl.create 7
 135
 136 let boxref = ref None
 137 let shown_widget = ref ""
 138
 139 let show_prop_box vb =
 140   Gaux.may !boxref ~f:vbox#get#remove;
 141   vbox#get#add vb#coerce;
 142   boxref := Some vb#coerce
 143
 144 let show (w : #tiwidget_base) =
 145   let name = w#name in
 146   let vb =
 147     try
 148       Hashtbl.find widget_pool name
 149     with Not_found ->
 150       let vb = prop_box w#proplist in
 151       Hashtbl.add widget_pool ~key:name ~data:vb;
 152       vb
 153   in
 154   show_prop_box vb;
 155   shown_widget := name
 156
 157 let add (w : #tiwidget_base) =
 158   let vb = prop_box w#proplist in
 159   Hashtbl.add widget_pool ~key:w#name ~data:vb
 160
 161
 162 let remove name =
 163   Hashtbl.remove widget_pool name;
 164   if !shown_widget = name then begin
 165     shown_widget := "";
 166     show_prop_box (GMisc.label ~text:"No widget selected" ())
 167   end
 168
 169 (*
 170 let change_name oldname newname =
 171   let vb = Hashtbl.find widget_pool oldname in
 172   Hashtbl.remove widget_pool oldname;
 173   Hashtbl.add widget_pool ~key:newname ~data:vb
 174 *)
 175
 176 let update (w : #tiwidget_base) show_modif =
 177   let vb = prop_box w#proplist in
 178   Hashtbl.remove widget_pool w#name;
 179   Hashtbl.add widget_pool ~key:w#name ~data:vb;
 180   if show_modif && !shown_widget = w#name then show_prop_box vb