Initial revision

[helm.git] / helm / DEVEL / lablgtk / lablgtk_20000829-0.1.0 / applications / browser / widgets.ml

diff --git a/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/browser/widgets.ml b/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/browser/widgets.ml
new file mode 100644 (file)
index 0000000..c27ca9f
--- /dev/null
+++ b/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/applications/browser/widgets.ml
@@ -0,0 +1,34 @@
+(* $Id$ *)
+
+open GObj
+
+class multibox ~rows ~columns ?(row_view = rows) ?(col_view = columns)
+    ?packing ?show () =
+  let sw =
+    GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC
+      ?show ?packing () in
+  let vp = GBin.viewport ~shadow_type:`NONE ~packing:sw#add in
+  let table =
+    GPack.table ~columns ~rows ~homogeneous:true ~packing:vp#add () in
+  let buttons =
+    Array.init ~len:columns
+      ~f:(fun left -> Array.init ~len:rows
+         ~f:(fun top -> GButton.button
+              ~packing:(table#attach ~top ~left ~expand:`BOTH)))
+  in
+  object (self)
+    inherit widget sw#as_widget
+    method cell ~col ~row = buttons.(col).(row)
+    initializer
+      let id = ref None in
+      id := Some
+         (sw#event#connect#expose ~after:true ~callback:
+            begin fun _ ->
+              may !id ~f:sw#connect#disconnect;
+              let height = table#misc#allocation.height * row_view / rows
+              and width = table#misc#allocation.width * col_view / columns in
+              vp#misc#set_size ~height ~width;
+              false
+            end);
+      table#focus#set_vadjustment vp#vadjustment
+  end