~ubuntu-branches/ubuntu/trusty/ocamlbricks/trusty-proposed
» Revision
12
: WIDGETS/LEDGRID/ledgrid.ml
« back to all changes in this revision
Viewing changes to WIDGETS/LEDGRID/ledgrid.ml
- browse files at revision 12
- compare with another revision
- download diff
- download tarball
- view history from revision 12
- Committer: Package Import Robot
- Author(s): Lucas Nussbaum
- Date: 2013-05-28 16:38:50 UTC
- mfrom: (3.1.3 sid)
- Revision ID: package-import@ubuntu.com-20130528163850-njreq52k3sdi3szn
Tags: 0.90+bzr364.3-1
* New upstream snapshot. Should fix the build failures on
non-native ocaml architectures.
* Add no-ocamlopt-arches.diff: work-around for partial upstream fix
(see https://bugs.launchpad.net/ocamlbricks/+bug/1130098).
non-native ocaml architectures.
* Add no-ocamlopt-arches.diff: work-around for partial upstream fix
(see https://bugs.launchpad.net/ocamlbricks/+bug/1130098).
- files added:
- .pc/no-ocamlopt-arches.diff
- .pc/no-ocamlopt-arches.diff/Makefile.d
- files removed:
- WIDGETS/LEDGRID
- WIDGETS/LEDGRID/sample-images
- files modified:
- .pc/applied-patches
added
removed
WIDGETS/LEDGRID/ledgrid.ml
1
(* This file is part of our reusable OCaml BRICKS library
2
Copyright (C) 2007, 2008 Luca Saiu
3
4
This program is free software: you can redistribute it and/or modify
5
it under the terms of the GNU General Public License as published by
6
the Free Software Foundation, either version 2 of the License, or
7
(at your option) any later version.
8
9
This program is distributed in the hope that it will be useful,
10
but WITHOUT ANY WARRANTY; without even the implied warranty of
11
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12
GNU General Public License for more details.
13
14
You should have received a copy of the GNU General Public License
15
along with this program. If not, see <http://www.gnu.org/licenses/>. *)
16
17
(** Ledgrid widgets. *)
18
19
(** {2 Constants}
20
Some global constant definitions, for fine-tuning. *)
21
22
(** The duration of a LED light "flash", in milliseconds: *)
23
let flash_duration = 80 (* 125 *)
24
25
(** The duration of a LED light "blink", in milliseconds. The time is
26
measured from the first to the last state change: *)
27
let blink_duration = 250
28
29
(** How many times a LED light changes state during a blink. This
30
includes both on->off and off->on transitions: *)
31
let blink_toggles_no = 8 (* 4 times on + 4 times off *)
32
33
(** {2 Exception}
34
The ways this brick can fail. *)
35
36
(** An exception raised whenever the user refers a non-existing LED light:
37
in a LED grid *)
38
exception Non_existing_led_light of int * int
39
40
(** An exception raised whenever the user refers a non-existing port in a
41
device LED grid: *)
42
exception Non_existing_port of int
43
44
(** {2 Utility stuff} *)
45
46
(** Make a pixmap data structure (not a widget) from the given file: *)
47
let make_pixmap_from_xpm_file ~file_name =
48
GDraw.pixmap_from_xpm ~file:file_name ()
49
50
(** {2 A single LED light}
51
Gtk+ simulation of just {e one} LED light. Particularly useful when arranged in a
52
grid. *)
53
54
(** A LED light is a widget mimicking a single physical LED light, whose state
55
at any given moment can be on or off: its state is represented as a boolean
56
value, and by convention 'true' means 'on'. A LED light keeps its default
57
state until its state is explitly changed by the user. The user can simply set
58
the object's state, or can set its state *also changing the default*. As soon
59
as the current state changes the widget's appearance on screen is updated.
60
A LED light can be also 'flashed', i.e. set to its non-default value for a
61
short time, after which it automatically reverts to its default state, or
62
'blinked', i.e. ordered to repeatedly toggle its state very fast for a short
63
time, before automatically reverting to its default state.
64
Flashing and blinking are *asynchronous* operations: when the user requests
65
them they are scheduled to be executed in background, and the user is immediately
66
given back control. This allows to use concurrency in an extremely simple way,
67
without even exposing a thread interface.
68
LED lights can be used in isolation, but they are mainly intended to be arranged
69
within a grid, allowing for more complex behaviour.
70
Note that already initialized Gtk+ pixmap objects of type GDraw.pixmap (and
71
*not* widgets) must be explicitly supplied at construction time. Pixmaps can
72
and should be shared among differnet LED lights. *)
73
class led_light ?default:(default=false) ?x:(x= -1) ?y:(y= -1) ~off_pixmap ~on_pixmap ~packing () =
74
object(self)
75
(** A notebook with hidden tabs and border is the main widget: it contains two pages with
76
the 'on' and 'off' pixmaps, and can easily change state by 'going' to a different
77
page: *)
78
val notebook =
79
let notebook = GPack.notebook ~tab_pos:`TOP ~packing ~show_border:false ~show_tabs:false () in
80
let _ = (* "on" pixmap widget *)
81
GMisc.pixmap
82
off_pixmap
83
~packing:(fun widget -> ignore (notebook#insert_page ~pos:0 widget))
84
() in
85
let _ = (* "on" pixmap widget *)
86
GMisc.pixmap
87
on_pixmap
88
~packing:(fun widget -> ignore (notebook#insert_page ~pos:1 widget))
89
() in
90
notebook
91
92
(** Default state and current state; see above: *)
93
val default = ref(default)
94
val state = ref(false)
95
96
(** Return the current default state: *)
97
method get_default = !default
98
99
(** Update the default state *and also the current state*; this changes the widget's
100
appearance if the new value is different from the current state: *)
101
method set_default value = default := value;
102
self#set value;
103
()
104
105
(** Return the current state: *)
106
method get = !state
107
108
(** Update the current state, possibly changing the widget's appearance: *)
109
method set value = state := value;
110
notebook#goto_page (if value then 1 else 0);
111
()
112
113
(** Set the widget current state to be equal to its default. This may change the
114
widget's appearance: *)
115
method reset = self#set(!default); ()
116
117
(** Set the widget current state to be on if it's currently off, or vice-versa.
118
This always changes the widget's appearance: *)
119
method toggle = self#set(not self#get); ()
120
121
(** Return the widget position as it was set at creation time, or (-1, -1) if
122
it was not set: *)
123
method get_position = x, y
124
125
(** Return the main Gtk+ widget making up the LED light: *)
126
method get_widget = notebook
127
128
(** Order the LED light to flash (see above) for the established time, and
129
return immediately: *)
130
method flash = self#set (not !default);
131
ignore (GMain.Timeout.add
132
flash_duration
133
(function () -> self#reset; false))
134
135
(** Schedule the LED light to blink 'times' times, then to reset itself. This
136
is internally used to implement blinking: *)
137
method private blink_this_number_of_times times =
138
if times = 0 then
139
self#set(!default)
140
else begin
141
self#toggle;
142
ignore (GMain.Timeout.add
143
(blink_duration / blink_toggles_no)
144
(fun () -> self#blink_this_number_of_times (times - 1); false));
145
end
146
147
(** Order the LED light to blink (see above) for the established time, and
148
return immediately: *)
149
method blink = self#blink_this_number_of_times blink_toggles_no; ()
150
151
(** This just assures that the default state reflects what is visually
152
displayed at creation time: *)
153
initializer self#set !default
154
end
155
156
(** These variables are just used as parameters to Array.make so that types can be
157
correctly inferred. useless_label's widget is never displayed: *)
158
let useless_array_of_led_light_options = Array.make 0 None
159
let useless_label = GMisc.label ()
160
161
162
(** {2 LED grid}
163
Gtk+ simulation of a {e grid} of LED lights. *)
164
165
(** A LED grid visually represents a matrix of LED lights, where each light is
166
independently controllable. A light is identified by its 0-based coordinates,
167
where the origin is top-left.
168
The optional parameter no_leds_at represents a list of coordinates (such as
169
[(0, 1); (3, 4)]) where *no* lights should be placed.
170
Each end of each row and column contains an optional, user-settable text
171
label. Vertical labels can be rotated, to allow for denser writing in
172
vertical.
173
The constructor expects three file names identifying the XPM images to use
174
for the 'on' state, the 'off' state, and for representing the absence of a
175
light. All three pixmaps should have the same size. *)
176
class led_grid ?default:(default=false)
177
~on_xpm_file_name ~off_xpm_file_name ~nothing_xpm_file_name
178
~columns ~rows ~packing ?angle:(angle=90.0)
179
?no_leds_at:(no_leds_at=[]) () = object(self)
180
(** The pixmap objects made from user-supplied files. Notice how the same three
181
pixmaps are shared among all the lights (and 'holes'): *)
182
val off_pixmap = make_pixmap_from_xpm_file ~file_name:off_xpm_file_name
183
val on_pixmap = make_pixmap_from_xpm_file ~file_name:on_xpm_file_name
184
val nothing_pixmap = make_pixmap_from_xpm_file ~file_name:nothing_xpm_file_name
185
186
(** A two-dimensional matrix of led_light option: *)
187
val led_lights_matrix = Array.make columns useless_array_of_led_light_options
188
189
(** Arrays holding the label widgets decorating each end of rows and columns: *)
190
val left_labels = Array.make rows useless_label
191
val right_labels = Array.make rows useless_label
192
val top_labels = Array.make columns useless_label
193
val bottom_labels = Array.make columns useless_label
194
195
(** The Gtk+ widget holding the whole grid: *)
196
val table_widget = GPack.table ~columns:(columns + 2) ~rows:(rows + 2) ~row_spacings:0 ~col_spacings:0
197
~border_width:0 ~packing ()
198
(* To do: use Jean's sets instead of this ugly hash: *)
199
(** A set of positions which should be left empty. This structure must be
200
accessed associatively at initialization time, and is more efficient
201
than a list: *)
202
val no_leds_at = let hash = Hashtbl.create (columns * rows) in
203
List.iter (fun x_y -> Hashtbl.add hash x_y ()) no_leds_at;
204
hash
205
206
(** Initialize the complex state of the grid: *)
207
initializer
208
for x = 0 to columns - 1 do
209
Array.set led_lights_matrix x (Array.make rows None);
210
for y = 0 to rows - 1 do
211
if Hashtbl.mem no_leds_at (x, y) then begin
212
let _ = GMisc.pixmap
213
nothing_pixmap
214
~packing:(table_widget#attach ~left:(x + 1) ~top:(y + 1) ~expand:`BOTH)
215
() in
216
Array.set (Array.get led_lights_matrix x) y None
217
end else
218
let new_led_light =
219
new led_light ~packing:(table_widget#attach ~left:(x + 1) ~top:(y + 1) ~expand:`BOTH)
220
~off_pixmap ~on_pixmap ~default ~x ~y ()
221
in
222
Array.set (Array.get led_lights_matrix x) y (Some new_led_light)
223
done;
224
done;
225
for y = 0 to rows - 1 do
226
let left_label = GMisc.label ~packing:(table_widget#attach ~left:0 ~top:(y + 1)) () in
227
let right_label = GMisc.label ~packing:(table_widget#attach ~left:(columns + 1) ~top:(y + 1)) () in
228
Array.set left_labels y left_label;
229
Array.set right_labels y right_label;
230
done;
231
for x = 0 to columns - 1 do
232
let top_label = GMisc.label ~packing:(table_widget#attach ~left:(x + 1) ~top:0) () in
233
let bottom_label = GMisc.label ~packing:(table_widget#attach ~left:(x + 1) ~top:(rows + 1)) () in
234
top_label#set_angle angle;
235
bottom_label#set_angle angle;
236
Array.set top_labels x top_label;
237
Array.set bottom_labels x bottom_label;
238
done
239
240
(** Return the LED light identified by (x, y), or throw an exception if no light is
241
present at that position: *)
242
method get_led_light x y =
243
match Array.get (Array.get led_lights_matrix x) y with
244
None -> raise (Non_existing_led_light(x, y))
245
| Some(led_light) -> led_light
246
method get = self#get_led_light
247
248
(** Return a random LED light belonging to the grid, if it exists, or loop forever.
249
This is useful for debugging (and for demos :-)): *)
250
method get_random_led_light =
251
let x, y = (Random.int columns, Random.int rows) in
252
try
253
self#get_led_light x y
254
with Non_existing_led_light(_) ->
255
self#get_random_led_light
256
257
(** Get and set the text of each label. Notice that all arrays are 0-based: *)
258
method get_top_label x = (Array.get top_labels x)#text
259
method set_top_label x text = (Array.get top_labels x)#set_text text
260
method get_bottom_label x = (Array.get bottom_labels x)#text
261
method set_bottom_label x text = (Array.get bottom_labels x)#set_text text
262
method get_left_label y = (Array.get left_labels y)#text
263
method set_left_label y text = (Array.get left_labels y)#set_text text
264
method get_right_label y = (Array.get right_labels y)#text
265
method set_right_label y text = (Array.get right_labels y)#set_text text
266
267
(* Set the rotation angle, (90.0 degrees by default) for column labels: *)
268
method set_top_labels_angle alpha = for x = 0 to columns - 1 do
269
(Array.get top_labels x)#set_angle alpha;
270
done
271
method set_bottom_labels_angle alpha = for x = 0 to columns - 1 do
272
(Array.get bottom_labels x)#set_angle alpha;
273
done
274
275
(** Return the Gtk+ widget holding the whole grid: *)
276
method get_widget = table_widget
277
end
278
279
(** To do: recycle this from Jean's library *)
280
let rec range a b =
281
if a > b then [] else a :: (range (a + 1) b)
282
283
(** {2 Device LED Grid}
284
A matrix of LED lights simulating the control panel of a phisical network
285
device such as a switch or a router. *)
286
287
(** A 'device LED grid' is a LED grid specialized as a realistic simulation of
288
the control panel of a physical device such as a switch, a hub or a router.
289
A device LED's appearance can be customized at creation time, and this class
290
allows the user to control each _port_, abstracting from the position of the
291
light or lights representing the port state.
292
Port information can be displayed in either one or two lines, and an optional
293
"100Mb/s" array of lights can also be shown. The number of ports must be even
294
when two lines are requested. Three pixmap file names are required at creation
295
time, as for the LED grid. Labels are automatically set.
296
Reflecting the interface of common network devices, it can be said that a port
297
is either in 'connected' or 'disconnected' state, meaning that its associated
298
lights are 'on' or 'off' (and discounting flashes and blinks).
299
Notice that, as in most real-world switch and hubs, port numeration is
300
1-based. *)
301
class device_led_grid
302
~on_xpm_file_name
303
~off_xpm_file_name
304
~nothing_xpm_file_name
305
?(show_100_mbs=true)
306
~ports
307
?(port_labelling_offset=0)
308
~packing
309
?(angle=90.0)
310
?(lines=1)
311
() =
312
(* Let's prevent stupid errors... *)
313
let _ = assert(ports > 1) in
314
let _ = assert(((ports mod 2) = 0) or (lines = 1)) in
315
let _ = assert((lines = 1) or (lines = 2))
316
in
317
object(self)
318
inherit led_grid
319
~default:false
320
~on_xpm_file_name
321
~off_xpm_file_name
322
~nothing_xpm_file_name
323
~columns:(if lines = 1 then ports else ports / 2)
324
~angle
325
~rows:(match lines, show_100_mbs with
326
| 1, false -> 1
327
| 1, true -> 2
328
| 2, false -> 3
329
| 2, true -> 5
330
| _ -> assert false)
331
~no_leds_at:(match lines, show_100_mbs with
332
| 1, _ -> []
333
| 2, false -> List.map (function x -> x, 1) (range 0 (ports - 1))
334
| 2, true -> List.map (function x -> x, 2) (range 0 (ports / 2 - 1))
335
| _ -> assert false)
336
~packing () as super
337
338
(** Initialize the complex state of this object: *)
339
initializer
340
for x = 0 to (if lines = 1 then ports - 1 else ports / 2 - 1) do
341
(* self#set_top_label x (string_of_int (x + 1)); *)
342
self#set_top_label x (string_of_int (x+port_labelling_offset)); (* 0-based numbering *)
343
done;
344
if lines = 2 then
345
for x = ports / 2 to ports - 1 do
346
self#set_bottom_label (x - ports / 2) (string_of_int (x+port_labelling_offset)); (* 0-based numbering *)
347
done;
348
self#set_right_label 0 "TX/RX";
349
match lines, show_100_mbs with
350
1, false -> ()
351
| 2, false -> self#set_right_label 2 "TX/RX"
352
| 1, true -> self#set_right_label 1 "100Mb/s"
353
| 2, true -> self#set_right_label 1 "100Mb/s";
354
self#set_right_label 3 "100Mb/s";
355
self#set_right_label 4 "TX/RX"
356
| _ -> assert false;
357
358
(** Given a port number, return a list of pairs of coordinates identifying the
359
inolved lights: *)
360
method private port_to_positions port =
361
let port = port + 1 in (* kludge to implement 0-based numbering... *)
362
match lines, show_100_mbs, port <= (ports / 2) with
363
1, false, _ -> [ port - 1, 0 ]
364
| 2, false, true -> [ port - 1, 0 ]
365
| 2, false, false -> [ port - (ports / 2) - 1, 2 ]
366
| 1, true, _ -> [ port - 1, 0; port - 1, 1 ]
367
| 2, true, true -> [ port - 1, 0; port - 1, 1 ]
368
| 2, true, false -> [ port - (ports / 2) - 1, 3; port - (ports / 2) - 1, 4 ]
369
| _ -> assert false
370
371
(** Print the port->coordinates mapping before returning the result of calling
372
port_to_positions: *)
373
method private port_to_positions_ port =
374
let positions = self#port_to_positions port in
375
(*List.iter (function x, y ->
376
print_int port; print_string " -> ("; print_int x; print_string ", ";
377
print_int y; print_string ")\n")
378
positions;*)
379
positions
380
381
(** Given a port number, return the list of LED lights representing it: *)
382
method private port_to_led_lights port =
383
let positions = self#port_to_positions port in
384
List.map (function x, y -> super#get x y) positions
385
386
(** For each LED light representing the given port, call the given function and
387
return the list of results: *)
388
method private for_each_led_light (f : led_light -> 'a) (port : int) : 'a list
389
= List.map (function x, y -> f (super#get x y))
390
(self#port_to_positions port);
391
392
(** Ask every LED light representing the given port to (asynchronously) flash: *)
393
method flash port =
394
ignore (self#for_each_led_light (function led -> led#flash) port)
395
396
(** Ask every LED light representing the given port to (asynchronously) blink: *)
397
method blink port =
398
ignore (self#for_each_led_light (function led -> led#blink) port)
399
400
(** Set the state of all LED lights representing a port, updating their default
401
state: this is a good way to indicate a cable connection or disconnection: *)
402
method set port value =
403
ignore (self#for_each_led_light (function led -> led#set_default value) port)
404
method connect port = self#set port true
405
method disconnect port = self#set port false
406
407
(** Return the number of a random port currently in the 'On' state, or loop forever
408
if no such port exists. This is useful for debugging and demos :-) *)
409
method random_connected_port = (* This does not terminate if there are no connected ports! *)
410
(* let port = (Random.int ports) + 1 in *)
411
let port = (Random.int ports) in (* 0-based numbering *)
412
if self#is_connected port then
413
port
414
else
415
self#random_connected_port
416
417
(** Return true iff the given port is in connected state: *)
418
method is_connected port = List.hd (List.map (function led -> led#get_default)
419
(self#port_to_led_lights port))
420
end
421
422
(** {3 Example}
423
A trivial usage example.
424
425
{[let main ports () =
426
let window = GWindow.window ~title:"Switch n.2" ~border_width:0 () in
427
window#connect#destroy ~callback:GMain.Main.quit;
428
let grid =
429
new device_led_grid ~packing:window#add ~ports ~show_100_mbs:true ~lines:2
430
~off_xpm_file_name:"sample-files/off.xpm"
431
~on_xpm_file_name:"sample-files/on.xpm"
432
~nothing_xpm_file_name:"sample-files/nothing.xpm"
433
() in
434
for i = 1 to ports / 3 do
435
grid#connect ((Random.int ports) + 1);
436
done;
437
438
(** Simulate a distinct communication between two ports every 50 milliseconds: *)
439
GMain.Timeout.add 50 (function () -> grid#blink (grid#random_connected_port);
440
grid#blink (grid#random_connected_port);
441
true);
442
window#show ();
443
Main.main ()
444
let _ = main 64 ()]} *)
445
446
(* To do: should any out-of-bounds access raise a non-existing-led-light exception? *)
447
Loggerhead is a web-based interface for Breezy
Version: 2.0.1