]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/examples/testgtk.ml
"Final" commit that patches termViewer while still enabling XML Diffing.
[helm.git] / helm / DEVEL / lablgtk / lablgtk_20000829-0.1.0 / examples / testgtk.ml
1 (* $Id$ *)
2
3 open GdkKeysyms
4 open GMain
5 open GObj
6
7 let create_bbox direction title spacing child_w child_h layout =
8   let frame = GBin.frame ~label: title () in
9   let bbox = GPack.button_box direction ~border_width: 5 ~packing: frame#add 
10       ~layout: layout ~child_height: child_h ~child_width: child_w
11       ~spacing: spacing () in
12   GButton.button ~label: "OK"     ~packing: bbox#add ();
13   GButton.button ~label: "Cancel" ~packing: bbox#add ();
14   GButton.button ~label: "Help"   ~packing: bbox#add ();
15   frame#coerce
16
17 let create_button_box =
18   let rw = ref None in
19   let aux () =
20     match !rw with
21     | None ->
22         let window = GWindow.window ~title: "Button Boxes" ~border_width: 0 () in
23         rw := Some window;
24         window #connect#destroy ~callback:(fun _ -> rw := None);
25
26         let main_vbox = GPack.vbox ~packing: (window#add) () in
27
28         let frame_horz = GBin.frame ~label: "Horizontal Button Boxes"
29             ~packing:(main_vbox#pack ~expand:true ~fill:true ~padding:10) () in
30         
31         let vbox = GPack.vbox ~border_width: 10 ~packing: frame_horz#add () in
32         
33         vbox#add  (create_bbox `HORIZONTAL "Spread" 40 85 20 `SPREAD);
34         vbox#pack (create_bbox `HORIZONTAL "Edge"   40 85 20 `EDGE) 
35           ~expand: true ~fill: true ~padding: 5;
36         vbox#pack (create_bbox `HORIZONTAL "Start"  40 85 20 `START)
37           ~expand: true ~fill: true ~padding: 5;
38         vbox#pack (create_bbox `HORIZONTAL "End"    40 85 20 `END)
39           ~expand: true ~fill: true ~padding: 5;
40
41         let frame_vert = GBin.frame ~label: "Vertical Button Boxes"
42             ~packing:(main_vbox#pack ~expand:true ~fill:true ~padding:10) () in
43         
44         let hbox = GPack.hbox ~border_width: 10 ~packing: frame_vert#add () in
45         hbox#add  (create_bbox `VERTICAL "Spread" 30 85 20 `SPREAD);
46         hbox#pack (create_bbox `VERTICAL "Edge"   30 85 20 `EDGE)
47           ~expand: true ~fill: true ~padding: 5;
48         hbox#pack (create_bbox `VERTICAL "Start"  30 85 20 `START)
49           ~expand: true ~fill: true ~padding: 5;
50         hbox#pack (create_bbox `VERTICAL "End"    30 85 20 `END)
51           ~expand: true ~fill: true ~padding: 5;
52         window #show () 
53
54     | Some window -> window #destroy ()
55 in aux
56
57
58 let button_window button _ =
59   if button #misc#visible then
60     button #misc#hide ()
61   else
62     button #misc#show ()
63
64 let create_buttons =
65   let rw = ref None in
66   let aux () =
67     match !rw with
68     | None ->
69         let window = GWindow.window ~title: "GtkButton" ~border_width: 0 () in
70         rw := Some window;
71         window #connect#destroy ~callback:(fun _ -> rw := None);
72
73         let box1 = GPack.vbox ~packing:window#add () in
74         
75         let table = GPack.table ~rows:3 ~columns:3 ~homogeneous:false 
76             ~row_spacings:3 ~col_spacings:3 ~border_width:10
77             ~packing:box1#add () in
78
79         let button = Array.create 9 (GButton.button ~label:"button1" ()) in
80         for i = 2 to 9 do
81           button.(i-1) <- GButton.button ~label:("button" ^ string_of_int i) ();
82         done;
83
84         let f i l r t b =
85           button.(i) #connect#clicked ~callback:(button_window button.(i+1));
86           table #attach button.(i)#coerce ~left:l ~right:r ~top:t ~bottom:b
87             ~xpadding:0 ~ypadding:0 ~expand:`BOTH
88         in
89         f 0 0 1 0 1;
90         f 1 1 2 1 2;
91         f 2 2 3 2 3;
92         f 3 0 1 2 3;
93         f 4 2 3 0 1;
94         f 5 1 2 2 3;
95         f 6 1 2 0 1;
96         f 7 2 3 1 2;
97         button.(8) #connect#clicked ~callback:(button_window button.(0)); 
98         table #attach button.(8)#coerce ~left:0 ~right:1 ~top:1 ~bottom:2
99           ~xpadding:0 ~ypadding:0 ~expand:`BOTH;
100
101         GMisc.separator `HORIZONTAL ~packing:box1#pack ();
102         
103         let box2 = GPack.vbox ~spacing: 10 ~border_width: 10
104             ~packing: box1#pack () in
105
106         let button = GButton.button ~label: "close" ~packing: box2#add () in
107         button #connect#clicked ~callback: window#destroy;
108         button #grab_default ();
109         window #show ()
110
111     | Some window -> window #destroy ()
112 in aux
113
114
115
116 let create_check_buttons =
117   let rw = ref None in
118   let aux () =
119     match !rw with
120     | None ->
121         let window = GWindow.window ~title: "GtkCheckButton"
122             ~border_width: 0 () in
123         rw := Some window;
124         window #connect#destroy ~callback:(fun _ -> rw := None);
125
126         let box1 = GPack.vbox ~packing:window#add () in
127         let box2 = GPack.vbox ~spacing: 10 ~border_width: 10
128             ~packing: box1#pack () in
129         
130         for i = 1 to 3 do
131           GButton.check_button ~label:("button" ^ (string_of_int i))
132             ~packing: box2#add ();
133         done;
134
135         GMisc.separator `HORIZONTAL ~packing: box1#pack ();
136         
137         let box2 = GPack.vbox ~spacing:10 ~border_width:10
138             ~packing: box1#pack () in
139
140         let button = GButton.button ~label: "close" ~packing:box2#add () in
141         button #connect#clicked ~callback: window#destroy;
142         button #grab_default ();
143         window #show ()
144         
145     | Some window ->  window #destroy ()
146 in aux
147
148
149 let create_radio_buttons =
150   let rw = ref None in
151   let aux () =
152     match !rw with
153     | None ->
154         let window = GWindow.window ~title: "radio buttons"
155             ~border_width: 0 () in
156         rw := Some window;
157         window #connect#destroy ~callback:(fun _ -> rw := None);
158
159         let box1 = GPack.vbox ~packing:window#add () in
160         
161         let box2 = GPack.vbox ~spacing:10 ~border_width:10 
162             ~packing: box1#pack () in
163         
164         let button = GButton.radio_button ~label:"button1"
165             ~packing: box2#add () in
166
167         let button = GButton.radio_button ~label:"button2" ~group:button#group
168             ~packing: box2#add ~active:true () in
169         
170         let button = GButton.radio_button ~label:"button3" ~group:button#group
171             ~packing: box2#add () in
172
173         GMisc.separator `HORIZONTAL ~packing: box1#pack ();
174         
175         let box2 = GPack.vbox ~spacing:10 ~border_width:10
176             ~packing: box1#pack () in
177
178         let button = GButton.button ~label: "close" ~packing: box2#add () in
179         button #connect#clicked ~callback: window #destroy;
180         button #grab_default ();
181         window #show ()
182         
183     | Some window -> window #destroy ()
184 in aux
185
186
187 let create_toggle_buttons =
188   let rw = ref None in
189   let aux () =
190     match !rw with
191     | None ->
192         let window = GWindow.window ~title: "GtkToggleButton"
193             ~border_width: 0 () in
194         rw := Some window;
195         window #connect#destroy ~callback:(fun _ -> rw := None);
196
197         let box1 = GPack.vbox ~packing: window#add () in
198         
199         let box2 = GPack.vbox ~spacing: 10 ~border_width: 10
200             ~packing: box1#pack () in
201         
202         for i = 1 to 3 do
203           GButton.toggle_button ~label:("button" ^ (string_of_int i))
204             ~packing: box2#add ()
205         done;
206
207         GMisc.separator `HORIZONTAL ~packing: box1#pack ();
208         
209         let box2 = GPack.vbox ~spacing: 10 ~border_width: 10
210             ~packing: box1#pack () in
211
212         let button = GButton.button ~label: "close" ~packing:box2#add () in
213         button #connect#clicked ~callback: window#destroy;
214         button #grab_default ();
215         window #show ()
216         
217     | Some window -> window #destroy ()
218 in aux
219
220
221 (* Menus *)
222
223 let create_menu depth tearoff =
224   let rec aux depth tearoff =
225     let menu = GMenu.menu () and group = ref None in
226     if tearoff then ignore (GMenu.tearoff_item ~packing: menu#append ());
227     for i = 0 to 4 do
228       let menuitem = GMenu.radio_menu_item ?group:!group
229           ~label:("item " ^ string_of_int depth ^ " - " ^ string_of_int (i+1))
230           ~packing:menu#append ~show_toggle:(depth mod 2 <> 0)
231           () in
232       group := Some (menuitem #group);
233       if i = 3 then menuitem #misc#set_sensitive false;
234       if depth > 1 then
235         menuitem #set_submenu (aux (depth-1) true)
236     done;
237
238     menu
239   in aux depth tearoff
240
241
242 let create_menus =
243   let rw = ref None in
244   fun () ->
245     match !rw with
246     | None ->
247         let window = GWindow.window ~title: "menus"
248             ~border_width: 0 () in
249         rw := Some window;
250         window #connect#destroy ~callback:(fun _ -> rw := None);
251         window #event#connect#delete ~callback:(fun _ -> true);
252
253         let accel_group = GtkData.AccelGroup.create () in
254         window #add_accel_group accel_group  ;
255
256         let box1 = GPack.vbox ~packing:window#add () in
257
258         let menubar = GMenu.menu_bar ~packing: box1#pack () in
259
260         let menuitem = GMenu.menu_item ~label:"test\nline2"
261             ~packing: menubar#append () in
262         menuitem #set_submenu (create_menu 2 true);
263
264         let menuitem = GMenu.menu_item ~label:"foo"
265             ~packing: menubar#append () in
266         menuitem #set_submenu (create_menu 3 true);
267         menuitem #right_justify ();
268
269         let box2 = GPack.vbox ~spacing: 10 ~packing: box1#add
270             ~border_width: 10 () in
271
272         let menu = create_menu 1 false in
273         menu #set_accel_group accel_group;
274
275         let menuitem = GMenu.check_menu_item ~label:"Accelerate Me"
276             ~packing:menu#append () in
277         menuitem #add_accelerator ~group:accel_group _M
278           ~flags:[`VISIBLE; `SIGNAL_VISIBLE];
279
280         let menuitem = GMenu.check_menu_item ~label:"Accelerator Locked"
281             ~packing:menu#append () in
282         menuitem #add_accelerator ~group:accel_group _L
283           ~flags:[`VISIBLE; `LOCKED];
284
285         let menuitem = GMenu.check_menu_item ~label:"Accelerators Frozen"
286             ~packing:menu#append () in
287         menuitem #add_accelerator ~group:accel_group _F
288           ~flags:[`VISIBLE];
289         menuitem #misc#lock_accelerators ();
290
291         let optionmenu = GMenu.option_menu ~packing: box2#add () in
292         optionmenu #set_menu menu;
293         optionmenu #set_history 3;
294
295         GMisc.separator `HORIZONTAL ~packing: box1#pack ();
296
297         let box2 = GPack.vbox ~spacing:10 ~border_width:10
298             ~packing: box1#pack () in
299
300         let button = GButton.button ~label: "close" ~packing: box2#add () in
301         button #connect#clicked ~callback: window#destroy;
302         button #grab_default ();
303         window #show ()
304
305     | Some window -> window #destroy ()
306
307
308
309 (* Modal windows *)
310
311 let cmw_destroy_cb _ =
312   Main.quit ()
313
314 let cmw_color parent _ =
315   let csd = GWindow.color_selection_dialog ~modal:true
316       ~title:"This is a modal color selection dialog" () in
317   csd # set_transient_for parent;
318   csd # connect#destroy ~callback:cmw_destroy_cb;
319   csd # ok_button # connect#clicked ~callback:csd#destroy;
320   csd # cancel_button # connect#clicked ~callback:csd#destroy;
321   csd # show ();
322   Main.main ()
323
324 let cmw_file parent _ =
325   let fs = GWindow.file_selection ~modal:true
326       ~title:"This is a modal file selection dialog" () in
327   fs # set_transient_for parent;
328   fs # connect#destroy ~callback:cmw_destroy_cb;
329   fs # ok_button # connect#clicked ~callback:fs#destroy;
330   fs # cancel_button # connect#clicked ~callback:fs#destroy;
331   fs # show ();
332   Main.main ()
333
334 let create_modal_window () =
335   let window = GWindow.window ~modal:true ~title:"This window is modal" () in
336   let box1 = GPack.vbox ~spacing:5 ~border_width:3 ~packing:window#add () in
337   let frame1 = GBin.frame ~label:"Standard dialogs in modal form"
338       ~packing:(box1#pack ~expand:true ~padding:4) () in
339   let box2 = GPack.vbox ~homogeneous:true ~spacing:5 ~packing:frame1#add () in
340   let btnColor = GButton.button ~label:"Color" 
341       ~packing:(box2#pack ~padding:4) ()
342   and btnFile = GButton.button ~label:"File selection" 
343       ~packing:(box2#pack ~padding:4) ()
344   and btnClose = GButton.button ~label:"Close" 
345       ~packing:(box2#pack ~padding:4) () in
346   GMisc.separator `HORIZONTAL
347     ~packing:(box1#pack ~padding:4) ();
348   
349   btnClose #connect#clicked ~callback:(fun _ -> window #destroy ());
350   window #connect#destroy ~callback:cmw_destroy_cb;
351   btnColor #connect#clicked ~callback: (cmw_color window);
352   btnFile #connect#clicked ~callback: (cmw_file window);
353   window # show ();
354   Main.main ()
355
356
357 (* corrected bug in testgtk.c *)
358 let scrolled_windows_remove, scrolled_windows_clean =
359   let parent = ref None and float_parent = ref None in
360   let remove (scrollwin : GBin.scrolled_window) () =
361     match !parent with
362     | None ->
363         parent := scrollwin#misc#parent;
364         let f = GWindow.window ~title:"new parent" () in
365         float_parent := Some f#coerce;
366         f #set_default_size ~width:200 ~height:200;
367         scrollwin #misc#reparent f#coerce;
368         f #show ()
369     | Some p ->
370         scrollwin #misc#reparent p;
371         match !float_parent with
372         | None -> ()
373         | Some f ->
374           f #destroy ();
375         float_parent := None;
376         parent := None
377   and clean () =
378     match !float_parent with
379     | None -> ()
380     | Some p -> p #destroy (); parent := None; float_parent := None
381   in remove, clean
382
383
384 (* scrolled windows *)
385
386 let create_scrolled_windows =
387   let rw = ref None in
388   let aux () =
389     match !rw with
390     | None ->
391         let window = GWindow.dialog ~title:"dialog" ~border_width:0 () in
392         rw := Some window;
393         window #connect#destroy ~callback:(fun  _ -> rw := None);
394         window #connect#destroy ~callback:scrolled_windows_clean;
395
396         let scrolled_window = GBin.scrolled_window ~border_width:10
397             ~hpolicy: `AUTOMATIC ~vpolicy:`AUTOMATIC
398             ~packing: window#vbox#add () in
399
400         let table = GPack.table ~rows:20 ~columns:20 ~row_spacings:10
401             ~col_spacings:10 ~packing:scrolled_window#add_with_viewport () in
402         table #focus#set_hadjustment (Some scrolled_window # hadjustment);
403         table #focus#set_vadjustment (Some scrolled_window # vadjustment);
404
405         for i = 0 to 19 do
406           for j=0 to 19 do
407             GButton.toggle_button
408               ~label:("button ("^ string_of_int i ^","^ string_of_int j ^")\n")
409               ~packing:(table #attach ~left:i ~top:j ~expand:`BOTH) ()
410           done
411         done;
412
413         let button = GButton.button ~label:"close"
414             ~packing:window#action_area#add () in
415         button #connect#clicked ~callback:(window #destroy);
416         button #grab_default ();
417
418         let button = GButton.button ~label:"remove"
419             ~packing:window#action_area#add () in
420         button #connect#clicked
421           ~callback:(scrolled_windows_remove scrolled_window);
422         button #grab_default ();
423         
424         window #set_default_size ~width:300 ~height:300;
425         window #show ()
426
427     | Some window -> window #destroy ()
428   in aux
429
430
431 (* Toolbar *)
432
433 let make_toolbar (toolbar : GButton.toolbar) window =
434   let icon =
435     let info = GDraw.pixmap_from_xpm ~file:"test.xpm" ~window () in
436     fun () -> (GMisc.pixmap info ())#coerce
437   in
438
439   toolbar #insert_button ~text:"Horizontal"
440     ~tooltip:"Horizontal toolbar layout"
441     ~tooltip_private:"Toolbar/Horizontal"
442     ~icon:(icon ())
443     ~callback:(fun _ -> toolbar #set_orientation `HORIZONTAL) ();
444   
445   toolbar #insert_button ~text:"Vertical"
446     ~tooltip:"Vertical toolbar layout"
447     ~tooltip_private:"Toolbar/Vertical"
448     ~icon:(icon ())
449     ~callback:(fun _ -> toolbar #set_orientation `VERTICAL) ();
450   
451   toolbar #insert_space ();
452   
453   toolbar #insert_button ~text:"Icons"
454     ~tooltip: "Only show toolbar icons"
455     ~tooltip_private:"Toolbar/IconsOnly"
456     ~icon:(icon ())
457     ~callback:(fun _ -> toolbar #set_style `ICONS) ();
458   
459   toolbar #insert_button ~text:"Text"
460     ~tooltip: "Only show toolbar text"
461     ~tooltip_private:"Toolbar/TextOnly"
462     ~icon:(icon ())
463     ~callback:(fun _ -> toolbar #set_style `TEXT) ();
464   
465   toolbar #insert_button ~text:"Both"
466     ~tooltip: "Show toolbar icons and text"
467     ~tooltip_private:"Toolbar/Both"
468     ~icon:(icon ())
469     ~callback:(fun _ -> toolbar #set_style `BOTH) ();
470   
471   toolbar #insert_space ();
472   
473   GEdit.entry ~packing:(toolbar #insert_widget
474                          ~tooltip:"This is an unusable GtkEntry"
475                          ~tooltip_private: "Hey don't click me!!!") ();
476   
477   toolbar #insert_button ~text:"Small"
478     ~tooltip:"Use small spaces"
479     ~tooltip_private:"Toolbar/Small"
480     ~icon:(icon ())
481     ~callback:(fun _ -> toolbar #set_space_size 5) ();
482   
483   toolbar #insert_button ~text:"Big"
484     ~tooltip:"Use big spaces"
485     ~tooltip_private:"Toolbar/Big"
486     ~icon:(icon ())
487     ~callback:(fun _ -> toolbar #set_space_size 10) ();
488   
489   toolbar #insert_space ();
490   
491   toolbar #insert_button ~text:"Enable"
492     ~tooltip:"Enable tooltips"
493     ~icon:(icon ())
494     ~callback:(fun _ -> toolbar #set_tooltips true) ();
495   
496   toolbar #insert_button ~text:"Disable"
497     ~tooltip:"Disable tooltips"
498     ~icon:(icon ())
499     ~callback:(fun _ -> toolbar #set_tooltips false) ();
500   
501   toolbar #insert_space ();
502   
503   toolbar #insert_button ~text:"Borders"
504     ~tooltip:"Show borders"
505     ~icon:(icon ())
506     ~callback:(fun _ -> toolbar #set_button_relief `NORMAL) ();
507   
508   toolbar #insert_button ~text:"Borderless"
509     ~tooltip:"Hide borders"
510     ~icon:(icon ())
511     ~callback:(fun _ -> toolbar #set_button_relief `NONE) ();
512   
513   toolbar #insert_space ();
514   
515   toolbar #insert_button ~text:"Empty"
516     ~tooltip:"Empty spaces"
517     ~icon:(icon ())
518     ~callback:(fun _ -> toolbar #set_space_style `EMPTY) ();
519   
520   toolbar #insert_button ~text:"Lines"
521     ~tooltip:"Lines in spaces"
522     ~icon:(icon ())
523     ~callback:(fun _ -> toolbar #set_space_style `LINE) ();
524   ()
525  
526 let create_toolbar =
527   let rw = ref None in
528   let aux () =
529     match !rw with
530     | None ->
531         let window = GWindow.window ~title: "Toolbar test"
532             ~border_width: 0 ~allow_shrink: false ~allow_grow: true
533             ~auto_shrink: true () in
534         rw := Some window;
535         window #connect#destroy ~callback:(fun _ -> rw := None);
536         window #misc #realize ();
537         
538         let toolbar = GButton.toolbar ~packing: window#add () in
539         make_toolbar toolbar window;
540         
541         window #show ()
542           
543     | Some window -> window #destroy ()
544   in aux
545
546
547 (* Handlebox *)
548
549 let handle_box_child_signal action (hb : GBin.handle_box) child =
550   Printf.printf "%s: child <%s> %s\n" hb#misc#get_type child#misc#get_type action
551
552 let create_handle_box =
553   let rw = ref None in
554   let aux () =
555     match !rw with
556     | None ->
557         let window = GWindow.window ~title: "Handle box test"
558             ~border_width: 20 ~allow_shrink: false ~allow_grow: true
559             ~auto_shrink: true () in
560         rw := Some window;
561         window #connect#destroy ~callback:(fun _ -> rw := None);
562         window #misc #realize ();
563
564         let vbox = GPack.vbox ~packing:window#add () in
565
566         GMisc.label ~text:"Above" ~packing:vbox#add ();
567         GMisc.separator `HORIZONTAL ~packing:vbox#add ();
568
569         let hbox = GPack.hbox ~spacing:10 ~packing:vbox#add () in
570         GMisc.separator `HORIZONTAL ~packing:vbox#add ();
571
572         GMisc.label ~text:"Below" ~packing:vbox#add ();
573         let handle_box = GBin.handle_box ~packing:hbox#pack () in
574         handle_box #connect#child_attached
575           ~callback:(handle_box_child_signal "attached" handle_box);
576         handle_box #connect#child_detached
577           ~callback:(handle_box_child_signal "detached" handle_box);
578
579         let toolbar = GButton.toolbar ~packing:handle_box#add () in
580         make_toolbar toolbar window;
581         toolbar #set_button_relief `NORMAL;
582
583         let handle_box = GBin.handle_box ~packing:hbox#pack () in
584         handle_box #connect#child_attached
585           ~callback:(handle_box_child_signal "attached" handle_box);
586         handle_box #connect#child_detached
587           ~callback:(handle_box_child_signal "detached" handle_box);
588
589         let handle_box2 = GBin.handle_box ~packing:handle_box#add () in
590         handle_box2 #connect#child_attached
591           ~callback:(handle_box_child_signal "attached" handle_box);
592         handle_box2 #connect#child_detached
593           ~callback:(handle_box_child_signal "detached" handle_box);
594
595         GMisc.label ~text:"Fooo!" ~packing:handle_box2#add ();
596         window #show ()
597           
598     | Some window -> window #destroy ()
599   in aux
600
601
602
603 (* Tree *)
604
605 class tree_and_buttons () =
606 object
607   val tree = GTree.tree ()
608   val add_button = GButton.button ~label: "Add Item" ()
609   val remove_button = GButton.button ~label:"Remove Item(s)" ()
610   val subtree_button = GButton.button ~label:"Remove Subtree" ()
611   val mutable nb_item_add = 0
612
613   method tree = tree
614   method add_button = add_button
615   method remove_button = remove_button
616   method subtree_button = subtree_button
617   method nb_item_add = nb_item_add
618   method incr_nb_item_add = nb_item_add <- nb_item_add + 1
619 end
620
621 let cb_tree_destroy_event w = ()
622
623 let cb_add_new_item (treeb : tree_and_buttons) _ =
624   let subtree =
625     match treeb#tree#selection with
626     | []  -> treeb#tree
627     | selected_item :: _ ->
628        match selected_item#subtree with Some t -> t
629        | None ->
630            let t = GTree.tree () in
631            selected_item#set_subtree t;
632            t
633   in
634   let item_new = GTree.tree_item ~packing:(subtree#insert ~pos:0)
635       ~label:("item add " ^ string_of_int treeb # nb_item_add) () in
636   treeb #incr_nb_item_add
637
638
639 let cb_remove_item (treeb : tree_and_buttons) _  = 
640   let tree = treeb#tree in
641   match tree #selection with
642   | [] -> ()
643   |  selected -> tree #remove_items selected
644
645
646 let cb_remove_subtree (treeb : tree_and_buttons) _ =
647   match treeb#tree #selection with
648   | [] -> ()
649   | selected_item :: _ ->
650     try selected_item#subtree; selected_item#remove_subtree ()
651     with Not_found -> ()
652
653 let cb_tree_changed (treeb : tree_and_buttons) _ =
654   let tree = treeb#tree in
655   let nb_selected = List.length (tree#selection) in
656   if nb_selected = 0 then begin
657     treeb # remove_button #misc#set_sensitive false;
658     treeb # subtree_button #misc#set_sensitive false;
659   end else begin
660     treeb # remove_button #misc#set_sensitive true;
661     treeb # subtree_button #misc#set_sensitive (nb_selected = 1);
662     treeb # add_button #misc#set_sensitive (nb_selected = 1);
663   end
664   
665   
666 let rec create_subtree (item : GTree.tree_item) level nb_item_max
667     recursion_level_max =
668   if level = recursion_level_max then ()
669   else begin
670     let item_subtree = GTree.tree () in
671     for nb_item = 1 to nb_item_max do
672       let item_new = GTree.tree_item ~packing:(item_subtree#insert ~pos:0)
673           ~label:("item" ^ string_of_int level ^ "-" ^ string_of_int nb_item) ()
674       in
675       create_subtree item_new (level + 1) nb_item_max recursion_level_max;
676     done;
677     item # set_subtree item_subtree
678   end
679
680
681 let create_tree_sample selection_mode draw_line view_line no_root_item
682     nb_item_max recursion_level_max =
683   let window = GWindow.window ~title:"Tree Sample" () in
684   let box1 = GPack.vbox ~packing:window#add () in
685   let box2 = GPack.vbox ~packing:box1#add ~border_width:5 () in
686   let scrolled_win = GBin.scrolled_window ~packing:box2#add
687       ~hpolicy: `AUTOMATIC ~vpolicy:`AUTOMATIC
688       ~width:200 ~height:200 () in
689
690   let root_treeb = new tree_and_buttons () in
691   let root_tree = root_treeb#tree in
692   root_tree #connect#selection_changed ~callback:(cb_tree_changed root_treeb);
693   scrolled_win #add_with_viewport root_tree#coerce;
694   root_tree #set_selection_mode selection_mode;
695   root_tree #set_view_lines draw_line;
696   root_tree #set_view_mode
697     (match view_line with `LINE -> `ITEM | `ITEM -> `LINE);
698
699   if no_root_item then
700     for nb_item = 1 to nb_item_max do
701       let item_new = GTree.tree_item ~label:("item0-" ^ string_of_int nb_item)
702           ~packing:(root_tree#insert ~pos:0) () in
703       create_subtree item_new 1 nb_item_max recursion_level_max;
704     done
705   else begin
706     let root_item = GTree.tree_item ~label:"root item"
707         ~packing:(root_tree #insert ~pos:0) () in
708     create_subtree root_item 0 nb_item_max recursion_level_max
709   end;
710
711   let box2 = GPack.vbox ~border_width:5 ~packing:box1#pack () in
712
713   let button = root_treeb #add_button in
714   button #misc#set_sensitive false;
715   button #connect#clicked ~callback:(cb_add_new_item root_treeb);
716   box2 #add button#coerce;
717
718   let button = root_treeb #remove_button in
719   button #misc#set_sensitive false;
720   button #connect#clicked ~callback:(cb_remove_item root_treeb);
721   box2 #add button#coerce;
722
723   let button = root_treeb #subtree_button in
724   button #misc#set_sensitive false;
725   button #connect#clicked ~callback:(cb_remove_subtree root_treeb);
726   box2 #add button#coerce;
727
728   GMisc.separator `HORIZONTAL ~packing:box1#pack ();
729
730   let button = GButton.button ~label:"Close" ~packing:box2#add () in
731   button #connect#clicked ~callback:window#destroy;
732
733   window #show ()
734
735
736 let create_tree_mode_window =
737   let rw = ref None in
738   let aux () =
739     let default_number_of_item = 3.0 in
740     let default_recursion_level = 3.0 in
741     let single_button = GButton.radio_button ~label:"SINGLE" () in
742     let browse_button = GButton.radio_button
743         ~group:single_button#group ~label:"BROWSE" () in
744     let multiple_button = GButton.radio_button
745         ~group:browse_button#group ~label:"MULTIPLE" () in
746     let draw_line_button = GButton.check_button ~label:"Draw line" () in
747     let view_line_button = GButton.check_button ~label:"View line mode" () in
748     let no_root_item_button = GButton.check_button
749         ~label:"Without Root item" () in
750     let nb_item_spinner = GEdit.spin_button
751         ~adjustment:(GData.adjustment ~value:default_number_of_item
752            ~lower:1.0 ~upper:255.0 ~step_incr:1.0 ~page_incr:5.0
753            ~page_size:0.0 ()) ~rate:0. ~digits:0 () in
754     let recursion_spinner = GEdit.spin_button
755         ~adjustment:(GData.adjustment ~value:default_recursion_level
756            ~lower:0.0 ~upper:255.0 ~step_incr:1.0 ~page_incr:5.0
757            ~page_size:0.0 ()) ~rate:0. ~digits:0 () in
758     let cb_create_tree _ =
759       let selection_mode =
760         if single_button #active then `SINGLE
761         else if browse_button #active then `BROWSE
762         else `MULTIPLE in
763       let nb_item = nb_item_spinner#value_as_int  in
764       let recursion_level = recursion_spinner#value_as_int in
765       create_tree_sample selection_mode (draw_line_button #active)
766         (if (view_line_button #active) then `ITEM else `LINE)
767         (no_root_item_button #active)
768         nb_item recursion_level
769     in
770     match !rw with
771     | None ->
772         let window = GWindow.window ~title:"Set Tree Parameters" () in
773         rw := Some window;
774         window #connect#destroy ~callback:(fun _ -> rw := None);
775
776         let box1 = GPack.vbox ~packing:window#add () in
777
778         let box2 = GPack.vbox ~spacing:5 ~packing:box1#add
779             ~border_width:5 () in
780
781         let box3 = GPack.hbox ~spacing:5 ~packing:box2#add () in
782
783         let frame = GBin.frame ~label:"Selection Mode" ~packing:box3#add ()
784         in
785         
786         let box4 = GPack.vbox ~packing:frame#add ~border_width:5 () in
787
788         box4 #add single_button#coerce;
789         box4 #add browse_button#coerce;
790         box4 #add multiple_button#coerce;
791
792         let frame = GBin.frame ~label:"Options" ~packing:box3#add () in
793         
794         let box4 = GPack.vbox ~packing:frame#add ~border_width:5 () in
795         box4 #add draw_line_button#coerce;
796         draw_line_button #set_active true;
797         
798         box4 #add view_line_button#coerce;
799         view_line_button #set_active true;
800         
801         box4 #add no_root_item_button#coerce;
802
803         let frame = GBin.frame ~label:"Size Parameters" ~packing:box2#add ()
804         in
805
806         let box4 = GPack.hbox ~spacing:5 ~packing:frame#add ~border_width:5 () in
807
808         let box5 = GPack.hbox ~spacing:5 ~packing:box4#add () in
809         let label = GMisc.label ~text:"Number of items : "
810             ~xalign:0. ~yalign:0.5 ~packing:box5#pack () in
811         box5 #pack nb_item_spinner#coerce;
812         
813         let label = GMisc.label ~text:"Depth : " ~xalign:0. ~yalign:0.5
814             ~packing:box5#pack () in
815         box5 #pack recursion_spinner#coerce;
816         
817         GMisc.separator `HORIZONTAL ~packing:box1#pack ();
818
819         let box2 = GPack.hbox ~homogeneous:true ~spacing:10 ~border_width:5
820             ~packing:box1#pack () in
821
822         let button = GButton.button ~label:"Create Tree"
823             ~packing:box2#add () in
824         button #connect#clicked ~callback:cb_create_tree;
825
826         let button = GButton.button ~label: "close" ~packing:box2#add () in
827         button #connect#clicked ~callback: window#destroy;
828         button #grab_default ();
829         window #show ()
830         
831     | Some window -> window #destroy ()
832   in aux
833
834
835
836 (* Tooltips *)
837
838 let tips_query_widget_entered (toggle : GButton.toggle_button)
839     (tq : GMisc.tips_query) _ ~text ~privat:_  =
840   if toggle #active then begin
841     tq #set_text
842       (match text with
843       | None -> "There is no tip!" | Some _ -> "There is a tip!");
844     GtkSignal.stop_emit ()
845   end
846
847 let tips_query_widget_selected (w : #widget option) ~text ~privat:tp _ =
848   (match w with
849   | None -> ()
850   | Some w -> 
851     Printf.printf "Help \"%s\" requested for <%s>\n"
852         (match tp with None -> "None" | Some t -> t)
853         (w #misc#get_type));
854    true
855
856
857 let create_tooltips =
858   let rw = ref None in
859   let aux () =
860      match !rw with
861     | None ->
862
863         let window = GWindow.window ~title:"Tooltips"
864             ~border_width:0 ~allow_shrink:false ~allow_grow:false
865             ~auto_shrink:true () in
866         rw := Some window;
867         let tooltips = GData.tooltips () in
868         window #connect#destroy 
869           ~callback:(fun _ -> tooltips #destroy ();  rw := None);
870
871         let box1 = GPack.vbox ~packing:window#add () in
872
873         let box2 = GPack.vbox ~spacing:10 ~border_width:10
874             ~packing:box1#add () in
875
876         let button = GButton.toggle_button ~label:"button1"
877             ~packing:box2#add ()
878         in
879         tooltips #set_tip button#coerce ~text:"This is button1"
880           ~privat:"ContextHelp/buttons/1";
881         
882         let button = GButton.toggle_button ~label:"button2"
883             ~packing:box2#add ()
884         in
885         tooltips #set_tip button#coerce
886           ~text:"This is button 2. This is also a really long tooltip which probably won't fit on a single line and will therefore need to be wrapped. Hopefully the wrapping will work correctly."
887           ~privat:"ContextHelp/buttons/2_long";
888
889         let toggle = GButton.toggle_button ~label:"Override TipsQuery Label" 
890             ~packing:box2#add () in
891         tooltips #set_tip toggle#coerce ~text:"Toggle TipsQuery view."
892           ~privat:"Hi msw! ;)";
893
894         let box3 = GPack.vbox ~spacing:5 ~border_width:5 () in
895
896         let button = GButton.button ~label:"[?]" 
897             ~packing:box3#pack () in
898
899         let tips_query = GMisc.tips_query ~packing:box3#add () in
900         button #connect#clicked ~callback:(tips_query #start);
901
902         tooltips #set_tip button#coerce ~text:"Start the Tooltips Inspector"
903           ~privat:"ContextHelp/buttons/?";
904
905         tips_query #set_caller button#coerce;
906         tips_query #connect#widget_entered
907           ~callback:(tips_query_widget_entered toggle tips_query);
908         tips_query #connect#widget_selected ~callback:tips_query_widget_selected;
909
910         let frame = GBin.frame ~label:"Tooltips Inspector"
911             ~border_width:0 ~packing:(box2#pack ~expand:true ~padding:10) 
912             ~label_xalign:0.5 ~label_yalign:0.0 () in
913         frame #add box3#coerce;
914
915         GMisc.separator `HORIZONTAL ~packing:box1#pack ();
916
917         let box2 = GPack.vbox ~spacing: 10 ~border_width: 10
918             ~packing: box1#pack () in
919
920         let button = GButton.button ~label: "close" ~packing: box2#add () in
921         button #connect#clicked ~callback: window#destroy;
922         button #grab_default ();
923         tooltips #set_tip button#coerce ~text:"Push this button to close window"
924           ~privat:"ContextHelp/buttons/Close";
925
926         window #show ();
927
928     | Some window -> window #destroy ()
929   in aux
930
931
932 (* Labels *)
933 let create_labels =
934   let rw = ref None in
935   let aux () =
936      match !rw with
937     | None ->
938
939         let window = GWindow.window ~title:"Labels" ~border_width:5 () in
940         rw := Some window;
941         window #connect#destroy 
942           ~callback:(fun _ -> rw := None);
943
944         let hbox = GPack.hbox ~spacing:5 ~packing:window#add () in
945         let vbox = GPack.vbox ~spacing:5 ~packing:hbox#add () in
946
947         let frame = GBin.frame ~label:"Normal Label"
948             ~packing:vbox#pack () in
949         GMisc.label ~text:"This is a normal label" ~packing:frame#add ();
950
951         let frame = GBin.frame ~label:"Multi_line Label"
952             ~packing:vbox#pack () in
953         GMisc.label ~packing:frame#add
954           ~text:"This is a multi-line label.\nSecond line\nThird line" ();
955
956         let frame = GBin.frame ~label:"Left Justified Label"
957             ~packing:vbox#pack () in
958         GMisc.label ~packing:frame#add ~justify:`LEFT
959           ~text:"This is a left justified\nmulti_line label\nThird line" ();
960
961         let frame = GBin.frame ~label:"Right Justified Label"
962             ~packing:vbox#pack () in
963         GMisc.label ~packing:frame#add ~justify:`RIGHT
964           ~text:"This is a right justified\nmulti_line label\nThird line" ();
965
966         let vbox = GPack.vbox ~spacing:5 ~packing:hbox#add () in
967
968         let frame = GBin.frame ~label:"Line wrapped Label"
969             ~packing:vbox#pack () in
970         GMisc.label ~packing:frame#add ~line_wrap:true
971           ~text:"This is an example of a line-wrapped label.  It should not be taking up the entire             width allocated to it, but automatically wraps the words to fit.  The time has come, for all good men, to come to the aid of their party.  The sixth sheik's six sheep's sick.\n     It supports multiple paragraphs correctly, and  correctly   adds many          extra  spaces. " ();
972
973         let frame = GBin.frame ~label:"Underlined Label"
974             ~packing:vbox#pack () in
975         GMisc.label ~text:"This label is underlined!\nThis one is underlined in a quite a funky fashion" ~packing:frame#add
976           ~justify:`LEFT ~pattern:"_________________________ _ _________ _ _____ _ __ __  ___ ____ _____" ();
977
978         window #show ();
979
980     | Some window -> window #destroy ()
981   in aux
982
983
984 (* reparent *)
985
986
987 let set_parent child old_parent =
988   let name_opt = function
989     | None -> "(NULL)"
990     | Some w -> w#misc#get_type in
991   Printf.printf
992     "set parent for \"%s\": new parent: \"%s\", old parent: \"%s\"\n" 
993     child#misc#get_type
994     (match child#misc#parent with Some p -> p#misc#get_type | None -> "(NULL)")
995     (name_opt old_parent)
996
997 let reparent_label (label : GMisc.label) new_parent _ =
998   label #misc#reparent new_parent
999
1000
1001
1002 let create_reparent =
1003   let rw = ref None in
1004   let aux () =
1005      match !rw with
1006     | None ->
1007
1008         let window = GWindow.window ~title:"Reparent" ~border_width:5 () in
1009         rw := Some window;
1010         window #connect#destroy ~callback:(fun _ -> rw := None);
1011
1012         let vbox = GPack.vbox ~packing:window#add () in
1013         let hbox = GPack.hbox ~spacing:5 ~border_width:10
1014             ~packing:vbox#add () in
1015
1016         let frame = GBin.frame ~label:"Frame1"  ~packing:hbox#add () in
1017         let vbox2 = GPack.vbox ~spacing:5 ~border_width:5
1018             ~packing:frame#add () in
1019         let label = GMisc.label ~text:"Hello world"
1020             ~packing:vbox2#pack () in
1021         label #misc#connect#parent_set ~callback:(set_parent label);
1022         let button = GButton.button ~label:"switch"
1023             ~packing:vbox2#pack () in
1024         button #connect#clicked ~callback:(reparent_label label vbox2#coerce);
1025
1026         let frame = GBin.frame ~label:"Frame2"  ~packing:hbox#add () in
1027         let vbox2 = GPack.vbox ~spacing:5 ~packing:frame#add ~border_width:5 () in
1028         let button = GButton.button ~label:"switch"
1029             ~packing:vbox2#pack () in
1030         button #connect#clicked ~callback:(reparent_label label vbox2#coerce);
1031
1032         GMisc.separator `HORIZONTAL ~packing:vbox#pack ();
1033
1034         let vbox = GPack.vbox ~spacing:10 ~border_width:10
1035             ~packing:vbox#pack () in
1036
1037         let button = GButton.button ~label: "close" ~packing:vbox#add () in
1038         button #connect#clicked ~callback: window#destroy;
1039         button #grab_default ();
1040
1041         window #show ();
1042
1043     | Some window -> window #destroy ()
1044   in aux
1045
1046
1047
1048
1049 let create_main_window () =
1050   let buttons = [
1051     "button box", Some create_button_box;
1052     "buttons", Some create_buttons;
1053     "check buttons", Some create_check_buttons;
1054     "clist", None;
1055     "color selection", None;
1056     "ctree", None;
1057     "cursors", None;
1058     "dialog", None;
1059     "entry", None;
1060     "event watcher", None;
1061     "file selection", None;
1062     "font selection", None;
1063     "gamma curve", None;
1064     "handle box", Some create_handle_box;
1065     "item factory", None;
1066     "labels", Some create_labels;
1067     "layout", None;
1068     "list", None;
1069     "menus", Some create_menus;
1070     "modal windows", Some create_modal_window;
1071     "notebooks", None;
1072     "panes", None;
1073     "pixmap", None;
1074     "preview color", None;
1075     "preview gray", None;
1076     "progress bar", None;
1077     "radio buttons", Some create_radio_buttons;
1078     "range controls", None;
1079     "rc file", None;
1080     "reparent", Some create_reparent;
1081     "rulers", None;
1082     "saved position", None;
1083     "scrolled windows", Some create_scrolled_windows;
1084     "shapes", None;
1085     "spinbutton", None;
1086     "statusbar", None;
1087     "test idle", None;
1088     "test mainloop", None;
1089     "test scrolling", None;
1090     "test selection", None;
1091     "test timeout", None;
1092     "text", None;
1093     "toggle buttons", Some create_toggle_buttons;
1094     "toolbar", Some create_toolbar;
1095     "tooltips", Some create_tooltips;
1096     "tree", Some create_tree_mode_window;
1097     "WM hints", None
1098   ] in
1099
1100   let window = GWindow.window ~title:"main window" ~allow_shrink:false
1101       ~allow_grow:false ~auto_shrink:false ~width:200 ~height:400 ~x:20 ~y:20 () in
1102
1103   window #connect#destroy ~callback: Main.quit;
1104
1105   let box1 = GPack.vbox ~packing: window#add () in
1106
1107   GMisc.label ~text: "Gtk+ v1.2" ~packing:box1#pack ();
1108
1109   let scrolled_window = GBin.scrolled_window ~border_width: 10
1110       ~hpolicy: `AUTOMATIC ~vpolicy: `AUTOMATIC
1111       ~packing:box1#add () in
1112
1113   let box2 = GPack.vbox ~border_width: 10
1114       ~packing:scrolled_window#add_with_viewport () in
1115   box2 #focus#set_vadjustment (Some scrolled_window#vadjustment);
1116
1117   let rec aux = function
1118     | [] -> ()
1119     | (_,     None) :: tl -> aux tl
1120     | (label, Some func) :: tl ->
1121         let button = GButton.button ~label: label ~packing: box2#add () in
1122         button #connect#clicked ~callback: func;
1123         aux tl
1124   in aux buttons;
1125
1126   GMisc.separator `HORIZONTAL ~packing: box1#pack ();
1127
1128   let box2 = GPack.vbox ~spacing: 10 ~border_width: 10
1129       ~packing: box1#pack () in
1130
1131   let button = GButton.button ~label: "close"  ~packing: box2#add () in
1132   button #connect#clicked ~callback: window#destroy;
1133   button #grab_default ();
1134
1135   window #show ();
1136
1137   Main.main ()
1138
1139 let _ = create_main_window ()
1140