Sophie

Sophie

distrib > Mandriva > 2010.0 > i586 > media > contrib-release > by-pkgid > 0be7620be6a1578fbd49765844864a01 > files > 1858

ocaml-lablgtk2-doc-2.14.0-2mdv2010.0.i586.rpm

(**************************************************************************)
(*    Lablgtk - Examples                                                  *)
(*                                                                        *)
(*    There is no specific licensing policy, but you may freely           *)
(*    take inspiration from the code, and copy parts of it in your        *)
(*    application.                                                        *)
(*                                                                        *)
(**************************************************************************)

let change_orientation button (table : #GPack.table) toolbar () =
  let toolbar_w = (toolbar :> GObj.widget) in
  let orientation = if button#active then `VERTICAL else `HORIZONTAL in
  table#remove  toolbar_w ;
  toolbar#set_orientation orientation ;
  match orientation with
  | `HORIZONTAL ->
      table#attach ~left:0 ~right:2 ~top:0 ~bottom:1 
	~expand:`X ~fill:`BOTH toolbar_w
  | `VERTICAL ->
      table#attach ~left:0 ~right:1 ~top:0 ~bottom:6
	~expand:`Y ~fill:`BOTH toolbar_w


let change_toolbar_style combo toolbar () =
  toolbar#set_style 
    (List.assoc combo#active 
       [ 0, `ICONS; 1, `TEXT; 2, `BOTH; 3, `BOTH_HORIZ ])

let set_toolbar_style_toggled button combo toolbar () =
  if button#active
  then change_toolbar_style combo toolbar ()
  else toolbar#unset_style () ;
  combo#misc#set_sensitive button#active

    
let change_icon_size combo toolbar () =
  toolbar#set_icon_size
    (List.assoc combo#active
       [ 0, `SMALL_TOOLBAR; 1, `LARGE_TOOLBAR ])

let set_icon_size_toggled button combo toolbar () =
  if button#active
  then change_icon_size combo toolbar ()
  else toolbar#unset_icon_size () ;
  combo#misc#set_sensitive button#active


let create_item_list packing =
  let cols = new GTree.column_list in
  let item_col : Gtk.tool_item Gtk.obj GTree.column = 
    cols#add Gobject.Data.gobject in
  let name_col = cols#add Gobject.Data.string in
  let store = GTree.list_store cols in
  let tree_view = GTree.view ~model:store ~packing () in
  tree_view#append_column
    (GTree.view_column ~title:"Tool Item" 
       ~renderer:(GTree.cell_renderer_text [], [ "text", name_col ]) ()) ;

  let item_property_column ~title ~setter ~getter =
    let cell = GTree.cell_renderer_toggle [] in
    cell#connect#toggled
      (fun path ->
	let item = new GButton.tool_item
	    (store#get ~row:(store#get_iter path) ~column:item_col) in
	setter item (not (getter item))) ;
    let view_column = GTree.view_column ~title () in
    view_column#pack cell ;
    view_column#set_cell_data_func cell 
      (fun model row ->
	let item = new GButton.tool_item (model#get ~row ~column:item_col) in
	cell#set_properties [ `ACTIVE (getter item) ]) ;
    tree_view#append_column view_column 
  in

  item_property_column
    ~title:"Visible (horizontal)"
    ~setter:(fun item -> item#set_visible_horizontal)
    ~getter:(fun item -> item#visible_horizontal) ;
  item_property_column
    ~title:"Visible (vertical)"
    ~setter:(fun item -> item#set_visible_vertical)
    ~getter:(fun item -> item#visible_vertical) ;
  item_property_column
    ~title:"Expand"
    ~setter:(fun item -> item#set_expand)
    ~getter:(fun item -> item#get_expand) ;
  item_property_column
    ~title:"Homogeneous"
    ~setter:(fun item -> item#set_homogeneous)
    ~getter:(fun item -> item#get_homogeneous) ;
  item_property_column
    ~title:"Important"
    ~setter:(fun item -> item#set_is_important)
    ~getter:(fun item -> item#is_important) ;

  (store, name_col, item_col, tree_view)

let context_menu_cb toolbar x y button =
  let menu = GMenu.menu () in
  for i = 1 to 5 do
    let label = Printf.sprintf "Item _%d" i in
    GMenu.menu_item ~label ~use_mnemonic:true ~packing:menu#append ()
  done ;
  menu#popup ~button:0 ~time:(GtkMain.Main.get_current_event_time ()) ;
  true


let targets = [
  { Gtk.target = "application/x-toolbar-item" ; Gtk.flags = [] ; Gtk.info = 0 }
]

(* this doesn't seem to work :( *)
let drag_item = ref None

let toolbar_drag_motion_cb (toolbar : #GButton.toolbar) 
    (ctx : GObj.drag_context) ~x ~y ~time =
  let item =
    match !drag_item with
    | None ->
	let it = GButton.tool_button ~label:"A quite long button" () in
	drag_item := Some it ; it
    | Some it -> it in
  ctx#status ~time (Some `MOVE) ;
  let index = toolbar#get_drop_index x y in
  toolbar#set_drop_highlight_item 
    (Some (item, index)) ;
  true

let toolbar_drag_leave_cb (toolbar : #GButton.toolbar) ctx ~time =
  drag_item := None ;
  toolbar#set_drop_highlight_item None

let toolbar_drag_drop_cb toolbar label ctx ~x ~y ~time =
  let l = string_of_int (toolbar#get_drop_index x y) in
  label#set_label l ;
  true

let main =
  let w = GWindow.window ~title:"Toolbar demo" () in
  w#connect#destroy GMain.quit ;
  
  let table = GPack.table ~rows:5 ~columns:2 ~packing:w#add () in

  let toolbar = GButton.toolbar ~packing:(table#attach ~left:0 ~top:0 ~right:2 
					    ~expand:`X ~fill:`BOTH) () in

  toolbar#connect#popup_context_menu (context_menu_cb toolbar) ;

  begin
    let hbox1 = GPack.hbox ~spacing:3 ~border_width:5 
	~packing:(table#attach ~left:1 ~top:1 ~expand:`X ~fill:`BOTH) () in

    begin
      let checkbox = GButton.check_button ~label:"_Vertical" 
	  ~use_mnemonic:true ~packing:hbox1#pack () in
      checkbox#connect#toggled (change_orientation checkbox table toolbar)
    end ;
    begin
      let checkbox = GButton.check_button ~label:"_Show Arrow" 
	  ~use_mnemonic:true ~packing:hbox1#pack () in
      checkbox#connect#toggled 
	(fun () -> toolbar#set_show_arrow checkbox#active) ;
    end ;
  end ;
  begin
    let hbox2 = GPack.hbox ~spacing:3 ~border_width:5 
	~packing:(table#attach ~left:1 ~top:2 ~expand:`X ~fill:`BOTH) () in
  
    let checkbox = GButton.check_button ~label:"Set _Toolbar Style" 
	~use_mnemonic:true ~packing:hbox2#pack () in
    let (combo, _) = GEdit.combo_box_text
	~strings:[ "icons"; "text"; "both (vertical)"; "both (horizontal)" ] 
	~packing:hbox2#pack () in
    combo#misc#set_sensitive false ;
    combo#set_active
      (List.assoc toolbar#style [ `ICONS, 0; `TEXT, 1;
				  `BOTH, 2; `BOTH_HORIZ, 3 ]) ;
    combo#connect#changed (change_toolbar_style combo toolbar) ;
    checkbox#connect#toggled (set_toolbar_style_toggled checkbox combo toolbar)
  end ;
  begin
    let hbox3 = GPack.hbox ~spacing:3 ~border_width:5 
	~packing:(table#attach ~left:1 ~top:3 ~expand:`X ~fill:`BOTH) () in
    let checkbox = GButton.check_button ~label:"Set _Icon Size"
	~use_mnemonic:true ~packing:hbox3#pack () in
    let (combo, _) = GEdit.combo_box_text
	~strings:[ "small toolbar"; "large toolbar" ]
	~packing:hbox3#pack () in
    combo#misc#set_sensitive false ;
    combo#set_active 
      (List.assoc toolbar#icon_size [ `SMALL_TOOLBAR, 0; `LARGE_TOOLBAR, 1 ]) ;
    combo#connect#changed (change_icon_size combo toolbar) ;
    checkbox#connect#toggled (set_icon_size_toggled checkbox combo toolbar)
  end ;

  begin
    let scrolled_window = GBin.scrolled_window 
	~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC 
	~packing:(table#attach ~left:1 ~top:4 ~expand:`BOTH ~fill:`BOTH) () in
    let (store, name_col, item_col, treeview) = 
      create_item_list scrolled_window#add in

    let add_item name item =
      let row = store#append () in
      store#set ~row ~column:name_col name ;
      store#set ~row ~column:item_col item#as_tool_item ;
      toolbar#insert item
    in
    add_item "New"
      (GButton.tool_button ~stock:`NEW ~expand:true ()) ;
    add_item "Open" 
      (GButton.tool_button ~stock:`OPEN ()) ;
    add_item "-----" 
      (GButton.separator_tool_item ()) ;
    begin
      let item = GButton.tool_button ~stock:`REFRESH () in
      add_item "Refresh" item ;
      item#connect#clicked (fun () -> print_endline "clicked")
    end ;
    begin
      let item = GButton.tool_item () in
      let image = GMisc.image ~stock:`DIALOG_WARNING 
	  ~icon_size:`DIALOG ~packing:item#add () in
      add_item "(Custom Item)" item
    end ;
    add_item "Back" 
      (GButton.tool_button ~stock:`GO_BACK ()) ;
    add_item "-----" 
      (GButton.separator_tool_item ()) ;
    add_item "Forward" 
      (GButton.tool_button ~stock:`GO_FORWARD ()) ;
    begin
      let item = GButton.toggle_tool_button ~stock:`BOLD () in
      item#connect#toggled 
	(fun () -> 
	  Printf.printf "Bold toggled (active=%b)\n" item#get_active ; 
	  flush stdout) ;
      add_item "Bold" item
    end ;
    add_item "-----" 
      (GButton.separator_tool_item ~draw:false ~expand:true ()) ;
    begin
      let item = GButton.radio_tool_button 
	  ~stock:`JUSTIFY_LEFT () in
      add_item "Left" item ;
      add_item "Center"
	(GButton.radio_tool_button ~group:item 
	   ~stock:`JUSTIFY_CENTER ()) ;
      add_item "Right"
	(GButton.radio_tool_button ~group:item 
	   ~stock:`JUSTIFY_RIGHT ())
    end ;
    begin
      let image = GMisc.image ~file:"/usr/share/gtk-2.0/demo/apple-red.png" () in
      let item = GButton.tool_button ~label:"_Apple" 
	  ~use_underline:true () in
      item#set_icon_widget image#coerce ;
      add_item "Apple" item
    end ;
    begin
      let hbox = GPack.hbox ~border_width:5 ~spacing:5 
	  ~packing:(table#attach ~left:1 ~top:5 ~expand:`X ~fill:`BOTH) () in
      let button = GButton.button ~label:"Drag me to the toolbar"
	  ~packing:hbox#pack () in
      let label = GMisc.label ~text:"Drop index:" ~packing:hbox#pack () in
      let label = GMisc.label ~packing:hbox#pack () in
      
      button#drag#source_set ~modi:[`BUTTON1] ~actions:[`MOVE] targets ;
      toolbar#drag#dest_set ~flags:[`DROP] ~actions:[`MOVE] targets ;
      toolbar#drag#connect#motion (toolbar_drag_motion_cb toolbar) ;
      toolbar#drag#connect#leave  (toolbar_drag_leave_cb toolbar) ;
      toolbar#drag#connect#drop   (toolbar_drag_drop_cb toolbar label);
    end ;
  end ;

  w#show () ;
  GMain.main ()