7 external test_modifier : Gdk.Tags.modifier -> int -> bool
8 = "ml_test_GdkModifier_val"
11 (************* types *************)
12 (* used in the load_parser and for the selection *)
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
20 (*********** some utility functions **************)
21 let rec list_remove ~f = function
23 | hd :: tl -> if f hd then tl else hd :: (list_remove ~f tl)
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
32 | [] -> failwith "cut_list"
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
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"
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)
54 let rec list_insert ~item l ~pos =
55 if pos=0 then item :: l
58 | [] -> failwith "list_insert"
59 | hd :: tl -> hd :: (list_insert ~item tl ~pos:(pos-1))
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"
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)
78 let l = String.length name in
80 while !i >= 0 && name.[!i] >= '0' && name.[!i] <= '9' do decr i done;
84 (String.sub name ~pos:0 ~len:(!i+1)),
85 int_of_string (String.sub name ~pos:(!i+1) ~len:(l- !i-1))
87 let test_unique name = not (List.mem name !name_list)
89 let make_new_name ?(index=1) base =
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
95 name := base ^ (string_of_int !index)
99 let change_name name =
100 let base, index = split name in make_new_name base ~index
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;
111 let message_name () = message "name already in use\npick a new name"
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;
124 w#connect#destroy ~callback:GMain.Main.quit;
129 (*************** file selection *****************)
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;
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;
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
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
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)
159 (****************** ML signals *****************)
160 let signal_id = ref 0
162 let next_callback_id () : GtkSignal.id =
163 decr signal_id; Obj.magic (!signal_id : int)
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
170 if after then callbacks @ [id,callback] else (id,callback)::callbacks;
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 <- []
180 class type disconnector =
182 method disconnect : GtkSignal.id -> bool
183 method reset : unit -> unit
186 class has_ml_signals = object
187 val mutable disconnectors = []
188 method private add_signal (sgn : 'a signal) =
189 disconnectors <- (sgn :> disconnector) :: disconnectors
191 method disconnect id =
192 List.exists disconnectors ~f:(fun d -> d#disconnect id)
196 (****************** undo information ********************)
199 | Add of string * yywidget_tree * int
201 | Property of prop * string
202 | Add_window of yywidget_tree
203 | Remove_window of string
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
210 undo_info := f :: !undo_info;
211 last_action_was_undo := false
214 (**********************************************************)
215 let ftrue f = fun x -> f x; true
218 (**********************************************************)
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
238 ~callback:(fun () -> rt := e1#text; rtt := e2#text;
239 rptt := e3#text; ok := true;
241 b2#connect#clicked ~callback:w#destroy;
242 w#connect#destroy ~callback:GMain.Main.quit;
244 !ok, !rt, !rtt, !rptt
248 (**********************************************************)
250 let get5floats_from_string s =
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
263 with _ -> failwith "get5floats_of_string"
267 (**********************************************************)
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
281 with Not_found -> l in
284 try int_of_string (String.sub s ~pos:d ~len:(p-d)), p
285 with Failure "int_of_string" -> raise Float_of_string
287 if p=l then float_of_int m
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;
296 !f +. (float_of_int m)
302 class entry_float obj ~init = let rv = ref init in
304 inherit GEdit.entry obj as entry
307 let v = my_float_of_string entry#text in
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;
319 GtkMain.Main.main ();
320 entry#set_text (string_of_float !rv);
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
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
338 (*************************************************************)
341 let split_string s ~sep =
342 let l = String.length s in
346 if String.unsafe_get s i = sep then begin
347 r := (String.sub s ~pos:!j ~len:(i - !j)) :: !r;
351 List.rev ((String.sub s ~pos:!j ~len:(l - !j)) :: !r)