]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/browser/widgets.ml
rebuilt
[helm.git] / helm / DEVEL / lablgtk / lablgtk_20000829-0.1.0 / applications / browser / widgets.ml
1 (* $Id$ *)
2
3 open GObj
4
5 class multibox ~rows ~columns ?(row_view = rows) ?(col_view = columns)
6     ?packing ?show () =
7   let sw =
8     GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC
9       ?show ?packing () in
10   let vp = GBin.viewport ~shadow_type:`NONE ~packing:sw#add in
11   let table =
12     GPack.table ~columns ~rows ~homogeneous:true ~packing:vp#add () in
13   let buttons =
14     Array.init ~len:columns
15       ~f:(fun left -> Array.init ~len:rows
16           ~f:(fun top -> GButton.button
17               ~packing:(table#attach ~top ~left ~expand:`BOTH)))
18   in
19   object (self)
20     inherit widget sw#as_widget
21     method cell ~col ~row = buttons.(col).(row)
22     initializer
23       let id = ref None in
24       id := Some
25           (sw#event#connect#expose ~after:true ~callback:
26              begin fun _ ->
27                may !id ~f:sw#connect#disconnect;
28                let height = table#misc#allocation.height * row_view / rows
29                and width = table#misc#allocation.width * col_view / columns in
30                vp#misc#set_size ~height ~width;
31                false
32              end);
33       table#focus#set_vadjustment vp#vadjustment
34   end