helm/DEVEL/lablgtk/lablgtk_20001129-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