X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FDEVEL%2Flablgtk%2Flablgtk_20000829-0.1.0%2Fapplications%2Fradtest%2Futils.ml;fp=helm%2FDEVEL%2Flablgtk%2Flablgtk_20000829-0.1.0%2Fapplications%2Fradtest%2Futils.ml;h=0000000000000000000000000000000000000000;hb=c7514aaa249a96c5fdd39b1123fbdb38d92f20b6;hp=0b37975c7c439dd7bf38b3142dcf6918a6023625;hpb=1c7fb836e2af4f2f3d18afd0396701f2094265ff;p=helm.git

diff --git a/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/radtest/utils.ml b/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/radtest/utils.ml
deleted file mode 100644
index 0b37975c7..000000000
--- a/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/radtest/utils.ml
+++ /dev/null
@@ -1,353 +0,0 @@
-(* $Id$ *)
-
-open GObj
-
-open Common
-
-external test_modifier : Gdk.Tags.modifier -> int -> bool
-    = "ml_test_GdkModifier_val"
-
-
-(************* types *************)
-(* used in the load_parser and for the selection *)
-
-(* widget: class * name * property list
-   where property = name * value_string *)
-type yywidget = string * string * (string * string) list
-type yywidget_tree = Node of yywidget * yywidget_tree list
-
-
-(*********** some utility functions **************)
-let rec list_remove ~f = function
-  | [] -> []
-  | hd :: tl -> if f hd then tl else hd :: (list_remove ~f tl)
-
-
-(* cut the list at the element elt; elt stays in tail;
-   hd stays in reverse order *)
-let cut_list ~item l =
-  let rec aux h t = match t with
-  | hd :: tl -> if hd = item then h, t
-	else aux (hd :: h) tl
-  | [] -> failwith "cut_list"
-  in aux [] l
-
-let list_pos ~item l =
-  let rec aux pos = function
-    | [] -> raise Not_found
-    | hd :: tl -> if hd = item then pos else aux (pos+1) tl
-  in aux 0 l
-
-(* moves the pos element up; pos is >= 1;
-   the first element is numbered 0 *)
-let rec list_reorder_up ~pos = function
-    | hd1 :: hd2 :: tl when pos = 1 -> hd2 :: hd1 :: tl
-    | hd :: tl when pos > 1 -> hd :: (list_reorder_up ~pos:(pos-1) tl)
-    | _ -> failwith "list_reorder"
-
-(* moves the pos element down; pos is < length of l - 1;
-   the first element is numbered 0 *)
-let rec list_reorder_down ~pos = 
-  list_reorder_up ~pos:(pos+1)
-
-
-let rec list_insert ~item l ~pos =
-  if pos=0 then item :: l
-  else
-    match l with
-    | [] ->  failwith "list_insert"
-    | hd :: tl -> hd :: (list_insert ~item tl ~pos:(pos-1))
-
-
-let rec change_property_name oldname newname = function
-  | (n, p) :: tl when oldname = n -> (newname, p) :: tl
-  | (n, p) :: tl -> (n, p) :: change_property_name oldname newname tl
-  | [] -> failwith "change_property_name: name not found"
-
-
-
-(* contains the list of names of widgets in the current project;
-   used to test if a name is already used;
-   a name is added to the list when a tiwrapper is created (in
-   the initilizer part of tiwrapper,
-   it is removed when the widget is removed from his parent,
-   in method remove_me of tiwrapper *)
-let name_list = ref ([] : string list)
-
-let split name =
-  let l = String.length name in
-  let i = ref (l-1) in
-  while !i >= 0 && name.[!i] >= '0' && name.[!i] <= '9' do decr i done;
-  if !i = l-1 then
-    name, (-1)
-  else
-    (String.sub name ~pos:0 ~len:(!i+1)),
-    int_of_string (String.sub name ~pos:(!i+1) ~len:(l- !i-1))
-
-let test_unique name = not (List.mem name !name_list)
-
-let make_new_name ?(index=1) base =
-  let index, name =
-    if index = -1 then ref 1, ref base
-    else ref index, ref (base ^ (string_of_int index)) in
-  while not (test_unique !name) do
-    incr index;
-    name := base ^ (string_of_int !index)
-  done;
-  !name
-
-let change_name name =
-  let base, index = split name in make_new_name base ~index
-
-let message s =
-  let w = GWindow.window ~show:true ~modal:true () in
-  let v = GPack.vbox ~packing:w#add () in
-  let l = GMisc.label ~text:s ~packing:v#add () in
-  let b = GButton. button ~label:"OK" ~packing:v#add () in
-  b#connect#clicked ~callback:w#destroy;
-  w#connect#destroy ~callback:GMain.Main.quit;
-  GMain.Main.main ()
-
-let message_name () = message "name already in use\npick a new name"
-
-(* better: use a spin button *)
-let get_a_number s default=
-  let res = ref default in
-  let w = GWindow.window ~show:true ~modal:true () in
-  let v = GPack.vbox ~packing:w#add () in
-  let l = GMisc.label ~text:s ~packing:v#add () in
-  let e = GEdit.entry ~text:(string_of_int default) ~packing:v#add () in
-  let b = GButton. button ~label:"OK" ~packing:v#add () in
-  b#connect#clicked ~callback:(fun () ->
-    begin try res := int_of_string e#text with Failure _ -> () end;
-    w#destroy ());
-  w#connect#destroy ~callback:GMain.Main.quit;
-  GMain.Main.main ();
-  !res
-
-
-(*************** file selection *****************)
-
-let get_filename ~callback:set_filename ?(dir="") () =
-  let res = ref false in
-  let file_selection = GWindow.file_selection ~modal:true () in
-  if dir <> "" then file_selection#set_filename dir;
-  file_selection#show ();
-  file_selection#ok_button#connect#clicked
-    ~callback:(fun () -> set_filename file_selection#get_filename;
-      res := true;
-      file_selection#destroy ());
-  file_selection#cancel_button#connect#clicked
-    ~callback:file_selection#destroy;
-  file_selection#connect#destroy ~callback:GMain.Main.quit;
-  GMain.Main.main ();
-  !res
-
-(* returns the directory and the file name (without the extension) *)
-let split_filename filename ~ext =
-  let lext = String.length ext in
-  let l = String.length filename in
-  let filename, l =
-    if (l > lext) && (String.sub filename ~pos:(l - lext) ~len:lext = ext)
-    then (String.sub filename ~pos:0 ~len:(l-lext)), l-lext
-    else filename, l in
-  let i = 1 + (String.rindex filename '/') in
-  String.sub filename ~pos:0 ~len:i,
-  String.sub filename ~pos:i ~len:(l-i)
-
-
-(******************  ML signals *****************)
-let signal_id = ref 0
-
-let next_callback_id () : GtkSignal.id =
-  decr signal_id; Obj.magic (!signal_id : int)
-
-class ['a] signal = object
-  val mutable callbacks : (GtkSignal.id * ('a -> unit)) list = []
-  method connect ~callback ~after =
-    let id = next_callback_id () in
-    callbacks <-
-      if after then callbacks @ [id,callback] else (id,callback)::callbacks;
-    id
-  method call arg =
-    List.iter callbacks ~f:(fun (_,f) -> f arg)
-  method disconnect id =
-    List.mem_assoc id callbacks &&
-    (callbacks <- List.remove_assoc id callbacks; true)
-  method reset () = callbacks <- []
-end
-
-class type disconnector =
-  object
-    method disconnect : GtkSignal.id -> bool
-    method reset : unit -> unit
-  end
-
-class has_ml_signals = object
-  val mutable disconnectors = []
-  method private add_signal (sgn : 'a signal) =
-    disconnectors <- (sgn :> disconnector) :: disconnectors
-
-  method disconnect id =
-    List.exists disconnectors ~f:(fun d -> d#disconnect id)
-end
-
-
-(****************** undo information ********************)
-
-type undo_action =
-  | Add of string * yywidget_tree * int
-  | Remove of string
-  | Property of prop * string
-  | Add_window of yywidget_tree
-  | Remove_window of string
-
-let undo_info = ref ([] : undo_action list)
-let next_undo_info = ref ([] : undo_action list)
-let last_action_was_undo = ref false
-
-let add_undo f =
-  undo_info := f :: !undo_info;
-  last_action_was_undo := false
-
-
-(**********************************************************)
-let ftrue f = fun x -> f x; true
-
-
-(**********************************************************)
-
-let toolbar_child_prop kind =
-  let rt = ref "" and rtt = ref "" and rptt = ref "" and ok = ref false in
-  let w  = GWindow.window ~modal:true () in
-  let v  = GPack.vbox ~packing:w#add () in
-  let h1 = GPack.hbox ~packing:v#pack () in
-  let h2 = GPack.hbox ~packing:v#pack () in
-  let h3 = GPack.hbox ~packing:v#pack () in
-  let h4 = GPack.hbox ~packing:v#pack () in
-  let l1 = GMisc.label ~text:"text" ~packing:h1#pack () in
-  let e1 = GEdit.entry ~packing:h1#pack () in
-  let l2 = GMisc.label ~text:"tooltip_text" ~packing:h2#pack () in
-  let e2 = GEdit.entry ~packing:h2#pack () in
-  let l3 = GMisc.label ~text:"private_text" ~packing:h3#pack () in
-  let e3 = GEdit.entry ~packing:h3#pack () in
-  let b1 = GButton.button ~label:"OK" ~packing:h4#pack () in
-  let b2 = GButton.button ~label:"Cancel" ~packing:h4#pack () in
-  w#show ();
-  b1#connect#clicked
-    ~callback:(fun () -> rt := e1#text; rtt := e2#text;
-      rptt := e3#text; ok := true;
-      w#destroy ());
-  b2#connect#clicked ~callback:w#destroy;
-  w#connect#destroy ~callback:GMain.Main.quit;
-  GMain.Main.main ();
-  !ok, !rt, !rtt, !rptt
-
-
-
-(**********************************************************)
-
-let get5floats_from_string s =
-  try
-    let n1 = String.index s ' ' in
-    let f1 = float_of_string (String.sub s ~pos:0 ~len:(n1-1)) in
-    let n2 = String.index_from s (n1+1) ' ' in
-    let f2 = float_of_string (String.sub s ~pos:(n1+1) ~len:(n2-1)) in
-    let n3 = String.index_from s (n2+1) ' ' in
-    let f3 = float_of_string (String.sub s ~pos:(n2+1) ~len:(n3-1)) in
-    let n4 = String.index_from s (n3+1) ' ' in
-    let f4 = float_of_string (String.sub s ~pos:(n3+1) ~len:(n4-1)) in
-    let f5 = float_of_string (String.sub s ~pos:(n4+1) ~len:
-				((String.length s) -1)) in
-    f1, f2, f3, f4, f5
-  with _ -> failwith "get5floats_of_string"
-
-
-
-(**********************************************************)
-
-exception Float_of_string
-let my_float_of_string s =
-  let l = String.length s in
-  if l=0 then raise Float_of_string;
-  let sign, d = match s.[0] with
-  | '+' ->  1, 1
-  | '-' -> -1, 1
-  | _   ->  1, 0 in
-  let m, p =
-    let p = 
-      try
-	String.index s '.'
-      with Not_found -> l in
-    if p=d then 0, p
-    else
-      try int_of_string (String.sub s ~pos:d ~len:(p-d)), p
-      with Failure "int_of_string" -> raise Float_of_string
-  in
-  if p=l then float_of_int m
-  else begin
-    let f = ref 0. and r = ref 0.1 in
-    for i = p+1 to l-1 do
-      let k = (int_of_char s.[i]) - 48 in
-      if k > 9 || k < 0 then raise Float_of_string;
-      f := !f +. (float_of_int k) *. !r;
-      r := !r *. 0.1
-    done;
-    !f +. (float_of_int m)
-  end
-
-    
-  
-
-class entry_float obj ~init = let rv = ref init in
-object
-  inherit GEdit.entry obj as entry
-  method value =
-    try 
-      let v = my_float_of_string entry#text in
-      rv := v;
-      v
-    with Float_of_string ->
-      let pop = GWindow.window ~title:"error" ~modal:true () in
-      let vb = GPack.vbox ~packing:pop#add () in
-      let l = GMisc.label ~text:"value must be a float" ~packing:vb#pack () in
-      let b = GButton.button ~label:"OK" ~packing:vb#pack () in
-      b#connect#clicked ~callback:pop#destroy;
-      pop#event#connect#delete ~callback:(fun _ -> pop#destroy (); true);
-      pop#connect#destroy ~callback:GtkMain.Main.quit;
-      pop#show ();
-      GtkMain.Main.main ();
-      entry#set_text (string_of_float !rv);
-      !rv
-end
-
-
-let set_editable ?editable ?(width = -2) ?(height = -2) w =
-  Gaux.may editable ~f:(GtkEdit.Editable.set_editable w);
-  if width <> -2 || height <> -2 then GtkBase.Widget.set_usize w ~width ~height
-
-
-let entry_float ~init ?max_length ?visibility ?editable
-    ?width ?height ?packing ?show () = 
-  let w = GtkEdit.Entry.create ?max_length () in
-  GtkEdit.Entry.set w ~text:(string_of_float init) ?visibility;
-  set_editable w ?editable ?width ?height;
-  pack_return (new entry_float w ~init) ~packing ~show
-
-
-(*************************************************************)
-
-
-let split_string s ~sep =
-  let l = String.length s in
-  let r = ref [] in
-  let j = ref 0 in
-  for i = 0 to l-1 do
-    if String.unsafe_get s i = sep then begin
-      r := (String.sub s ~pos:!j ~len:(i - !j)) :: !r;
-      j := i + 1
-    end
-  done;
-  List.rev ((String.sub s ~pos:!j ~len:(l - !j)) :: !r)
-
-