helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/applications/radtest/utils.ml

   1 (* $Id$ *)
   2
   3 open GObj
   4
   5 open Common
   6
   7 external test_modifier : Gdk.Tags.modifier -> int -> bool
   8     = "ml_test_GdkModifier_val"
   9
  10
  11 (************* types *************)
  12 (* used in the load_parser and for the selection *)
  13
  14 (* widget: class * name * property list
  15    where property = name * value_string *)
  16 type yywidget = string * string * (string * string) list
  17 type yywidget_tree = Node of yywidget * yywidget_tree list
  18
  19
  20 (*********** some utility functions **************)
  21 let rec list_remove ~f = function
  22   | [] -> []
  23   | hd :: tl -> if f hd then tl else hd :: (list_remove ~f tl)
  24
  25
  26 (* cut the list at the element elt; elt stays in tail;
  27    hd stays in reverse order *)
  28 let cut_list ~item l =
  29   let rec aux h t = match t with
  30   | hd :: tl -> if hd = item then h, t
  31         else aux (hd :: h) tl
  32   | [] -> failwith "cut_list"
  33   in aux [] l
  34
  35 let list_pos ~item l =
  36   let rec aux pos = function
  37     | [] -> raise Not_found
  38     | hd :: tl -> if hd = item then pos else aux (pos+1) tl
  39   in aux 0 l
  40
  41 (* moves the pos element up; pos is >= 1;
  42    the first element is numbered 0 *)
  43 let rec list_reorder_up ~pos = function
  44     | hd1 :: hd2 :: tl when pos = 1 -> hd2 :: hd1 :: tl
  45     | hd :: tl when pos > 1 -> hd :: (list_reorder_up ~pos:(pos-1) tl)
  46     | _ -> failwith "list_reorder"
  47
  48 (* moves the pos element down; pos is < length of l - 1;
  49    the first element is numbered 0 *)
  50 let rec list_reorder_down ~pos =
  51   list_reorder_up ~pos:(pos+1)
  52
  53
  54 let rec list_insert ~item l ~pos =
  55   if pos=0 then item :: l
  56   else
  57     match l with
  58     | [] ->  failwith "list_insert"
  59     | hd :: tl -> hd :: (list_insert ~item tl ~pos:(pos-1))
  60
  61
  62 let rec change_property_name oldname newname = function
  63   | (n, p) :: tl when oldname = n -> (newname, p) :: tl
  64   | (n, p) :: tl -> (n, p) :: change_property_name oldname newname tl
  65   | [] -> failwith "change_property_name: name not found"
  66
  67
  68
  69 (* contains the list of names of widgets in the current project;
  70    used to test if a name is already used;
  71    a name is added to the list when a tiwrapper is created (in
  72    the initilizer part of tiwrapper,
  73    it is removed when the widget is removed from his parent,
  74    in method remove_me of tiwrapper *)
  75 let name_list = ref ([] : string list)
  76
  77 let split name =
  78   let l = String.length name in
  79   let i = ref (l-1) in
  80   while !i >= 0 && name.[!i] >= '0' && name.[!i] <= '9' do decr i done;
  81   if !i = l-1 then
  82     name, (-1)
  83   else
  84     (String.sub name ~pos:0 ~len:(!i+1)),
  85     int_of_string (String.sub name ~pos:(!i+1) ~len:(l- !i-1))
  86
  87 let test_unique name = not (List.mem name !name_list)
  88
  89 let make_new_name ?(index=1) base =
  90   let index, name =
  91     if index = -1 then ref 1, ref base
  92     else ref index, ref (base ^ (string_of_int index)) in
  93   while not (test_unique !name) do
  94     incr index;
  95     name := base ^ (string_of_int !index)
  96   done;
  97   !name
  98
  99 let change_name name =
 100   let base, index = split name in make_new_name base ~index
 101
 102 let message s =
 103   let w = GWindow.window ~show:true ~modal:true () in
 104   let v = GPack.vbox ~packing:w#add () in
 105   let l = GMisc.label ~text:s ~packing:v#add () in
 106   let b = GButton. button ~label:"OK" ~packing:v#add () in
 107   b#connect#clicked ~callback:w#destroy;
 108   w#connect#destroy ~callback:GMain.Main.quit;
 109   GMain.Main.main ()
 110
 111 let message_name () = message "name already in use\npick a new name"
 112
 113 (* better: use a spin button *)
 114 let get_a_number s default=
 115   let res = ref default in
 116   let w = GWindow.window ~show:true ~modal:true () in
 117   let v = GPack.vbox ~packing:w#add () in
 118   let l = GMisc.label ~text:s ~packing:v#add () in
 119   let e = GEdit.entry ~text:(string_of_int default) ~packing:v#add () in
 120   let b = GButton. button ~label:"OK" ~packing:v#add () in
 121   b#connect#clicked ~callback:(fun () ->
 122     begin try res := int_of_string e#text with Failure _ -> () end;
 123     w#destroy ());
 124   w#connect#destroy ~callback:GMain.Main.quit;
 125   GMain.Main.main ();
 126   !res
 127
 128
 129 (*************** file selection *****************)
 130
 131 let get_filename ~callback:set_filename ?(dir="") () =
 132   let res = ref false in
 133   let file_selection = GWindow.file_selection ~modal:true () in
 134   if dir <> "" then file_selection#set_filename dir;
 135   file_selection#show ();
 136   file_selection#ok_button#connect#clicked
 137     ~callback:(fun () -> set_filename file_selection#get_filename;
 138       res := true;
 139       file_selection#destroy ());
 140   file_selection#cancel_button#connect#clicked
 141     ~callback:file_selection#destroy;
 142   file_selection#connect#destroy ~callback:GMain.Main.quit;
 143   GMain.Main.main ();
 144   !res
 145
 146 (* returns the directory and the file name (without the extension) *)
 147 let split_filename filename ~ext =
 148   let lext = String.length ext in
 149   let l = String.length filename in
 150   let filename, l =
 151     if (l > lext) && (String.sub filename ~pos:(l - lext) ~len:lext = ext)
 152     then (String.sub filename ~pos:0 ~len:(l-lext)), l-lext
 153     else filename, l in
 154   let i = 1 + (String.rindex filename '/') in
 155   String.sub filename ~pos:0 ~len:i,
 156   String.sub filename ~pos:i ~len:(l-i)
 157
 158
 159 (******************  ML signals *****************)
 160 let signal_id = ref 0
 161
 162 let next_callback_id () : GtkSignal.id =
 163   decr signal_id; Obj.magic (!signal_id : int)
 164
 165 class ['a] signal = object
 166   val mutable callbacks : (GtkSignal.id * ('a -> unit)) list = []
 167   method connect ~callback ~after =
 168     let id = next_callback_id () in
 169     callbacks <-
 170       if after then callbacks @ [id,callback] else (id,callback)::callbacks;
 171     id
 172   method call arg =
 173     List.iter callbacks ~f:(fun (_,f) -> f arg)
 174   method disconnect id =
 175     List.mem_assoc id callbacks &&
 176     (callbacks <- List.remove_assoc id callbacks; true)
 177   method reset () = callbacks <- []
 178 end
 179
 180 class type disconnector =
 181   object
 182     method disconnect : GtkSignal.id -> bool
 183     method reset : unit -> unit
 184   end
 185
 186 class has_ml_signals = object
 187   val mutable disconnectors = []
 188   method private add_signal (sgn : 'a signal) =
 189     disconnectors <- (sgn :> disconnector) :: disconnectors
 190
 191   method disconnect id =
 192     List.exists disconnectors ~f:(fun d -> d#disconnect id)
 193 end
 194
 195
 196 (****************** undo information ********************)
 197
 198 type undo_action =
 199   | Add of string * yywidget_tree * int
 200   | Remove of string
 201   | Property of prop * string
 202   | Add_window of yywidget_tree
 203   | Remove_window of string
 204
 205 let undo_info = ref ([] : undo_action list)
 206 let next_undo_info = ref ([] : undo_action list)
 207 let last_action_was_undo = ref false
 208
 209 let add_undo f =
 210   undo_info := f :: !undo_info;
 211   last_action_was_undo := false
 212
 213
 214 (**********************************************************)
 215 let ftrue f = fun x -> f x; true
 216
 217
 218 (**********************************************************)
 219
 220 let toolbar_child_prop kind =
 221   let rt = ref "" and rtt = ref "" and rptt = ref "" and ok = ref false in
 222   let w  = GWindow.window ~modal:true () in
 223   let v  = GPack.vbox ~packing:w#add () in
 224   let h1 = GPack.hbox ~packing:v#pack () in
 225   let h2 = GPack.hbox ~packing:v#pack () in
 226   let h3 = GPack.hbox ~packing:v#pack () in
 227   let h4 = GPack.hbox ~packing:v#pack () in
 228   let l1 = GMisc.label ~text:"text" ~packing:h1#pack () in
 229   let e1 = GEdit.entry ~packing:h1#pack () in
 230   let l2 = GMisc.label ~text:"tooltip_text" ~packing:h2#pack () in
 231   let e2 = GEdit.entry ~packing:h2#pack () in
 232   let l3 = GMisc.label ~text:"private_text" ~packing:h3#pack () in
 233   let e3 = GEdit.entry ~packing:h3#pack () in
 234   let b1 = GButton.button ~label:"OK" ~packing:h4#pack () in
 235   let b2 = GButton.button ~label:"Cancel" ~packing:h4#pack () in
 236   w#show ();
 237   b1#connect#clicked
 238     ~callback:(fun () -> rt := e1#text; rtt := e2#text;
 239       rptt := e3#text; ok := true;
 240       w#destroy ());
 241   b2#connect#clicked ~callback:w#destroy;
 242   w#connect#destroy ~callback:GMain.Main.quit;
 243   GMain.Main.main ();
 244   !ok, !rt, !rtt, !rptt
 245
 246
 247
 248 (**********************************************************)
 249
 250 let get5floats_from_string s =
 251   try
 252     let n1 = String.index s ' ' in
 253     let f1 = float_of_string (String.sub s ~pos:0 ~len:(n1-1)) in
 254     let n2 = String.index_from s (n1+1) ' ' in
 255     let f2 = float_of_string (String.sub s ~pos:(n1+1) ~len:(n2-1)) in
 256     let n3 = String.index_from s (n2+1) ' ' in
 257     let f3 = float_of_string (String.sub s ~pos:(n2+1) ~len:(n3-1)) in
 258     let n4 = String.index_from s (n3+1) ' ' in
 259     let f4 = float_of_string (String.sub s ~pos:(n3+1) ~len:(n4-1)) in
 260     let f5 = float_of_string (String.sub s ~pos:(n4+1) ~len:
 261                                 ((String.length s) -1)) in
 262     f1, f2, f3, f4, f5
 263   with _ -> failwith "get5floats_of_string"
 264
 265
 266
 267 (**********************************************************)
 268
 269 exception Float_of_string
 270 let my_float_of_string s =
 271   let l = String.length s in
 272   if l=0 then raise Float_of_string;
 273   let sign, d = match s.[0] with
 274   | '+' ->  1, 1
 275   | '-' -> -1, 1
 276   | _   ->  1, 0 in
 277   let m, p =
 278     let p =
 279       try
 280         String.index s '.'
 281       with Not_found -> l in
 282     if p=d then 0, p
 283     else
 284       try int_of_string (String.sub s ~pos:d ~len:(p-d)), p
 285       with Failure "int_of_string" -> raise Float_of_string
 286   in
 287   if p=l then float_of_int m
 288   else begin
 289     let f = ref 0. and r = ref 0.1 in
 290     for i = p+1 to l-1 do
 291       let k = (int_of_char s.[i]) - 48 in
 292       if k > 9 || k < 0 then raise Float_of_string;
 293       f := !f +. (float_of_int k) *. !r;
 294       r := !r *. 0.1
 295     done;
 296     !f +. (float_of_int m)
 297   end
 298
 299
 300
 301
 302 class entry_float obj ~init = let rv = ref init in
 303 object
 304   inherit GEdit.entry obj as entry
 305   method value =
 306     try
 307       let v = my_float_of_string entry#text in
 308       rv := v;
 309       v
 310     with Float_of_string ->
 311       let pop = GWindow.window ~title:"error" ~modal:true () in
 312       let vb = GPack.vbox ~packing:pop#add () in
 313       let l = GMisc.label ~text:"value must be a float" ~packing:vb#pack () in
 314       let b = GButton.button ~label:"OK" ~packing:vb#pack () in
 315       b#connect#clicked ~callback:pop#destroy;
 316       pop#event#connect#delete ~callback:(fun _ -> pop#destroy (); true);
 317       pop#connect#destroy ~callback:GtkMain.Main.quit;
 318       pop#show ();
 319       GtkMain.Main.main ();
 320       entry#set_text (string_of_float !rv);
 321       !rv
 322 end
 323
 324
 325 let set_editable ?editable ?(width = -2) ?(height = -2) w =
 326   Gaux.may editable ~f:(GtkEdit.Editable.set_editable w);
 327   if width <> -2 || height <> -2 then GtkBase.Widget.set_usize w ~width ~height
 328
 329
 330 let entry_float ~init ?max_length ?visibility ?editable
 331     ?width ?height ?packing ?show () =
 332   let w = GtkEdit.Entry.create ?max_length () in
 333   GtkEdit.Entry.set w ~text:(string_of_float init) ?visibility;
 334   set_editable w ?editable ?width ?height;
 335   pack_return (new entry_float w ~init) ~packing ~show
 336
 337
 338 (*************************************************************)
 339
 340
 341 let split_string s ~sep =
 342   let l = String.length s in
 343   let r = ref [] in
 344   let j = ref 0 in
 345   for i = 0 to l-1 do
 346     if String.unsafe_get s i = sep then begin
 347       r := (String.sub s ~pos:!j ~len:(i - !j)) :: !r;
 348       j := i + 1
 349     end
 350   done;
 351   List.rev ((String.sub s ~pos:!j ~len:(l - !j)) :: !r)
 352
 353