1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
|
(*
* The OCaml-gtk interface
*
* Copyright (c) 1997-99 David Monniaux & Pascal Cuoq
*
* This file is distributed under the conditions described in
* the file LICENSE.
*)
(* $Id: gtkEasy.ml,v 1.21 1999/06/21 12:23:51 sven Exp $ *)
open GtkObj
type label =
Label of string
| Widget of widget
let widget_label l =
( match l with
Label s -> (label_new s :> widget)
| Widget w -> w )
module Menu =
struct
type menu = menu_item list
and menu_item =
Item of label * (unit -> unit)
| Submenu of label * menu
| Check_item of label * (bool ref) * (unit -> unit)
| Radio_items of int ref * (string * (unit -> unit)) list
| Separator
let nop = fun () -> ()
let menu_item_of_label label =
( match label with
Label l -> menu_item_new_with_label l
| Widget w ->
let item = menu_item_new () in
item #add w;
item )
let rec make_menu_aux (gtk_menu : GtkObj.menu_shell) (item_list : menu) =
let f = function
Separator ->
let separator = hseparator_new() in
separator #show;
let menu_item = menu_item_new() in
menu_item #add separator;
menu_item #set_sensitive false;
menu_item #show;
gtk_menu #append menu_item
| Item(label,handler) ->
let menu_item = menu_item_of_label label in
ignore (menu_item #connect_activate handler);
menu_item #show;
gtk_menu #append menu_item
| Submenu(label,submenu) ->
let menu_item = menu_item_of_label label in
let gtk_submenu = menu_new () in
make_menu_aux (gtk_submenu :> menu_shell) submenu;
menu_item #set_submenu gtk_submenu;
menu_item #show;
gtk_menu #append menu_item
| Check_item(label,state,handler) ->
let check_item =
( match label with
Label l -> check_menu_item_new_with_label l
| Widget w ->
let item = check_menu_item_new () in
item #add w;
item ) in
check_item #set_state !state;
check_item #show;
let effective_handler () =
state := not !state;
handler ()
in
ignore (check_item #connect_activate effective_handler);
gtk_menu #append (check_item :> GtkObj.menu_item)
| Radio_items(state, item_handler_list) ->
let label_list = List.map fst item_handler_list in
let radio_button_list = radio_menu_items_new_with_labels label_list in
let count = ref 0 in
List.iter2
(fun radio_button item_handler ->
let handler = snd item_handler in
let current_count = !count in
incr count;
let effective_handler () =
state := current_count;
handler ()
in
ignore ((radio_button:>radio_menu_item)#connect_activate effective_handler);
())
radio_button_list
item_handler_list;
List.iter
(fun radio_button ->
gtk_menu #append (radio_button :> GtkObj.menu_item);
radio_button #show)
radio_button_list;
(* unfinnished *)
in
List.iter f item_list
let make_menu_bar (menu : menu) =
let menu_bar = menu_bar_new () in
make_menu_aux (menu_bar:>menu_shell) menu;
menu_bar
end
module Layout =
struct
type extra_space_behavior = {
expand : bool; (* should extra space be used ? *)
fill : bool; (* should the widget grow to fill extra space
(instead of just being centered inside it) ? *)
padding : int (* space to be left empty to each side of the child *)
}
let fixed_5 = { expand = false ; fill = false ; padding=5 } ;;
let fill_5 = { expand = true ; fill = true ; padding=5 } ;;
let fixed_1 = { expand = false ; fill = false ; padding=1 } ;;
let fill_1 = { expand = true ; fill = true ; padding=1 } ;;
type orientation = Horiz | Vert
type structure =
Box of orientation * ((structure*extra_space_behavior) list)
| Paned of orientation * structure * structure
| Notebook of Gtk.position_type * ((structure * label) list)
| Scrolled_window of structure
| Frame of string * Gtk.shadow_type * structure
| Widget of widget
let rec build_box box l =
( match l with
(substructure,{expand=expand;fill=fill;padding=padding})::t ->
let widget = build_structure substructure in
box #pack_start widget expand fill padding;
build_box box t
| [] -> () )
and build_structure s =
let widget =
( match s with
Box(orient,l) ->
let box = (if orient = Horiz then hbox_new else vbox_new) false 0
in
build_box box l;
(box :> widget)
| Paned(orient,s1,s2) ->
let panes = (if orient = Horiz then hpaned_new else vpaned_new) ()
in
panes #add1(build_structure s1);
panes #add2(build_structure s2);
(panes :> widget)
| Notebook(pos,l) ->
let notebook = notebook_new () in
let f(structure,label) =
let page = build_structure structure in
let label = widget_label label in
label #show;
notebook #append_page page label
in
List.iter f l ;
notebook #set_tab_pos pos;
(notebook :> widget)
| Scrolled_window(s1) ->
let sw = scrolled_window_new () in
let w1 = build_structure s1 in
sw #add w1;
(sw :> widget)
| Frame(title,shadow_type,s1) ->
let f = frame_new title in
let w1 = build_structure s1 in
f #add w1;
f #set_shadow_type shadow_type;
(f :> widget)
| Widget w ->
w )
in
widget #show ;
widget;;
let make_window_from_structure s title =
let window = window_new Gtk.WINDOW_TOPLEVEL in
let widget = build_structure s in
window #add(widget) ;
window #border_width 2;
window #set_title title;
window ;;
end
|
