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