helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/gList.ml

   1 (* $Id$ *)
   2
   3 open Gaux
   4 open Gtk
   5 open GtkBase
   6 open GtkList
   7 open GObj
   8 open GContainer
   9
  10 class list_item obj = object
  11   inherit container (obj : Gtk.list_item obj)
  12   method event = new GObj.event_ops obj
  13   method as_item = obj
  14   method select () = Item.select obj
  15   method deselect () = Item.deselect obj
  16   method toggle () = Item.toggle obj
  17   method connect = new item_signals obj
  18 end
  19
  20 let list_item ?label ?border_width ?width ?height ?packing ?(show=true) () =
  21   let w = ListItem.create ?label () in
  22   Container.set w ?border_width ?width ?height;
  23   let item = new list_item w in
  24   may packing ~f:(fun f -> (f item : unit));
  25   if show then item#misc#show ();
  26   item
  27
  28 class liste obj = object
  29   inherit [list_item] item_container (obj : Gtk.liste obj)
  30   method private wrap w = new list_item (ListItem.cast w)
  31   method insert w = Liste.insert_item obj w#as_item
  32   method clear_items = Liste.clear_items obj
  33   method select_item = Liste.select_item obj
  34   method unselect_item = Liste.unselect_item obj
  35   method child_position (w : list_item) = Liste.child_position obj w#as_item
  36 end
  37
  38 let liste ?selection_mode ?border_width ?width ?height
  39     ?packing ?show () =
  40   let w = Liste.create () in
  41   may selection_mode ~f:(Liste.set_selection_mode w);
  42   Container.set w ?border_width ?width ?height;
  43   pack_return (new liste w) ~packing ~show
  44
  45 (* Cell lists *)
  46
  47 class clist_signals obj = object
  48   inherit container_signals obj
  49   method click_column =
  50     GtkSignal.connect ~sgn:CList.Signals.click_column obj ~after
  51   method select_row =
  52     GtkSignal.connect ~sgn:CList.Signals.select_row obj ~after
  53   method unselect_row =
  54     GtkSignal.connect ~sgn:CList.Signals.unselect_row obj ~after
  55   method scroll_vertical =
  56     GtkSignal.connect ~sgn:CList.Signals.scroll_vertical obj ~after
  57   method scroll_horizontal =
  58     GtkSignal.connect ~sgn:CList.Signals.scroll_horizontal obj ~after
  59 end
  60
  61 class ['a] clist obj = object (self)
  62   inherit widget (obj : Gtk.clist obj)
  63   method set_border_width = Container.set_border_width obj
  64   method event = new GObj.event_ops obj
  65   method connect = new clist_signals obj
  66   method rows = CList.get_rows obj
  67   method columns = CList.get_columns obj
  68   method focus_row = CList.get_focus_row obj
  69   method hadjustment = new GData.adjustment (CList.get_hadjustment obj)
  70   method vadjustment = new GData.adjustment (CList.get_vadjustment obj)
  71   method set_button_actions = CList.set_button_actions obj
  72   method freeze () = CList.freeze obj
  73   method thaw () = CList.thaw obj
  74   method column_title = CList.get_column_title obj
  75   method column_widget col =
  76     new widget (CList.get_column_widget obj col)
  77   method columns_autosize () = CList.columns_autosize obj
  78   method optimal_column_width = CList.optimal_column_width obj
  79   method moveto ?(row_align=0.) ?(col_align=0.) row col =
  80     CList.moveto obj row col ~row_align ~col_align
  81   method row_is_visible = CList.row_is_visible obj
  82   method cell_type = CList.get_cell_type obj
  83   method cell_text = CList.get_text obj
  84   method cell_pixmap row col =
  85     let pm, mask = CList.get_pixmap obj row col in
  86     may_map pm ~f:(fun x -> new GDraw.pixmap ?mask x)
  87   method cell_style  row col =
  88     try Some (new style (CList.get_cell_style obj row col))
  89     with Gpointer.Null -> None
  90   method row_selectable row = CList.get_selectable obj ~row
  91   method row_style row =
  92     try Some (new style (CList.get_row_style obj ~row))
  93     with Gpointer.Null -> None
  94   method set_shift = CList.set_shift obj
  95   method insert ~row texts =
  96     let texts = List.map texts ~f:(fun x -> Some x) in
  97     CList.insert obj ~row texts
  98   method append = self#insert ~row:self#rows
  99   method prepend = self#insert ~row:0
 100   method remove = CList.remove obj
 101   method select = CList.select obj
 102   method unselect = CList.unselect obj
 103   method clear () = CList.clear obj
 104   method get_row_column = CList.get_row_column obj
 105   method select_all () = CList.select_all obj
 106   method unselect_all () = CList.unselect_all obj
 107   method swap_rows = CList.swap_rows obj
 108   method row_move = CList.row_move obj
 109   method sort () = CList.sort obj
 110   method set_hadjustment adj =
 111     CList.set_hadjustment obj (GData.as_adjustment adj)
 112   method set_vadjustment adj =
 113     CList.set_vadjustment obj (GData.as_adjustment adj)
 114   method set_shadow_type = CList.set_shadow_type obj
 115   method set_button_actions = CList.set_button_actions obj
 116   method set_selection_mode = CList.set_selection_mode obj
 117   method set_reorderable = CList.set_reorderable obj
 118   method set_use_drag_icons = CList.set_use_drag_icons obj
 119   method set_row_height = CList.set_row_height obj
 120   method set_titles_show = CList.set_titles_show obj
 121   method set_titles_active = CList.set_titles_active obj
 122   method set_sort = CList.set_sort obj
 123   method set_column ?widget =
 124     CList.set_column obj ?widget:(may_map widget ~f:as_widget)
 125   method set_row ?foreground ?background ?selectable ?style =
 126     let color = may_map ~f:(fun c -> Gpointer.optboxed (GDraw.optcolor c))
 127     and style = may_map ~f:(fun (st : style) -> st#as_style) style in
 128     CList.set_row obj
 129       ?foreground:(color foreground) ?background:(color background)
 130       ?selectable ?style
 131   method set_cell ?text ?pixmap ?spacing ?style =
 132     let pixmap, mask =
 133       match pixmap with None -> None, None
 134       | Some (pm : GDraw.pixmap) -> Some pm#pixmap, pm#mask
 135     and style = may_map ~f:(fun (st : style) -> st#as_style) style in
 136     CList.set_cell obj ?text ?pixmap ?mask ?spacing ?style
 137   method set_row_data n ~data =
 138     CList.set_row_data obj ~row:n (Obj.repr (data : 'a))
 139   method get_row_data n : 'a = Obj.obj (CList.get_row_data obj ~row:n)
 140   method scroll_vertical =
 141     CList.Signals.emit_scroll obj ~sgn:CList.Signals.scroll_vertical
 142   method scroll_horizontal =
 143     CList.Signals.emit_scroll obj ~sgn:CList.Signals.scroll_horizontal
 144 end
 145
 146 let clist ?(columns=1) ?titles ?hadjustment ?vadjustment
 147     ?shadow_type ?button_actions ?selection_mode
 148     ?reorderable ?use_drag_icons ?row_height
 149     ?titles_show ?titles_active ?auto_sort ?sort_column ?sort_type
 150     ?border_width ?width ?height ?packing ?show () =
 151   let w =
 152     match titles with None -> CList.create ~cols:columns
 153     | Some titles -> CList.create_with_titles (Array.of_list titles)
 154   in
 155   CList.set w
 156     ?hadjustment:(may_map ~f:GData.as_adjustment hadjustment)
 157     ?vadjustment:(may_map ~f:GData.as_adjustment vadjustment)
 158     ?shadow_type ?button_actions ?selection_mode ?reorderable
 159     ?use_drag_icons ?row_height ?titles_show ?titles_active;
 160   CList.set_sort w ?auto:auto_sort ?column:sort_column ?dir:sort_type ();
 161   Container.set w ?border_width ?width ?height;
 162   pack_return (new clist w) ~packing ~show