As usual, you can cut-and-paste the code below to a file.ml and try it out with command
$ lablgtk2 file.ml
Take the required flagging pixmaps here.
(*CUT HERE*)
(* List Tree View with activation flags and right-click popup menu *)
(* Summarizing some teachings by Jacques Garrigue and Olivier Andrieu *)
(* Tue Dec 30 10:48:05 CET 2003; code composed by stalkern at tiscalinet.it *)
(* How does the right-click popup work?
* First, a callback is bound to a List View so that a mouse button click on the List View will pop up
* a popup Menu. The popup Menu is not built on-the-fly, but is defined once as an object on its own.
* The Menu object is built so to contain a value that it can use as an argument for an action,
* e.g. printing it out when a Menu option is activated.
* The List View passes arguments to the Menu that it pops up on-the-fly, by
* 1) setting the argument value in the Menu object
* 2) letting the Menu object use the current (i.e. updated) argument value according
* to its own callbacks.
* Actually, the List first lends a value to the Menu, that the Menu is instructed to give back
* upon some condition. This loop is useful because we want the final return to depend
* both on clicking on a specific row in the List AND on selecting a specific Menu option.
* Please notice that since in Ocaml you can store as values inside objects not only data structures
* but also functions, a lot of control over the callbacks of the popup menu is allowed.
* This is shown here with the "Run Ocaml Bonus Function" Menu option.
* This may be particularly useful when you want to bind to the popup menu some action that
* refers to a bigger contest than the actual menu or the actual list.
*)
(*.............*)
open StdLabels
open Gobject.Data
(*.............*)
let titlesAndAuthorsList =
[("The Art of Computer Programming","Donald E. Knuth");
("The Mart of Tomputer Progapping","Vito De Zito");
("Peh Prat of Momputer Gropamming", "Agur Ropankanyami");
("The Cart of Pomputer Crogramming","Zemilyankatkinin Yvan");
("Che Part of Procuter Mogramming", "Chow Li") ];;
let aCheckedRowPixbuf = GdkPixbuf.from_file "roundledchecked22x22.xpm";;
let aUncheckedRowPixbuf = GdkPixbuf.from_file "roundledunchecked22x22.xpm";;
let activatedRows = ref [];;
type myTreeCellRendererType =
StringCellRendererBuild of (string GTree.column )
| PixbufCellRendererBuild of (GdkPixbuf.pixbuf GTree.column)
| ToggleCellRendererBuild of (bool GTree.column);;
(*.............*)
class popupMenu () =
object (self)
val theMenu = GMenu.menu ()
val mutable thePrintedString = "DEFAULT STRING"
val mutable aUnitToUnitCallbackFunction = (fun () -> ())
method menu = theMenu
method add_printingmenuitem label =
let menuItem =
GMenu.menu_item
˜label
˜packing: theMenu#append
()
in
(menuItem#connect#activate ˜callback:(fun () -> (print_endline thePrintedString; flush stdout)))
method add_ocamlbonusmenuitem label =
let menuItem =
GMenu.menu_item
˜label
˜packing: theMenu#append
()
in
(menuItem#connect#activate ˜callback:(fun () -> aUnitToUnitCallbackFunction () ))
method enhancedpopup ˜button ˜time printablecontent ocamlbonusfunction=
let () = thePrintedString <- printablecontent in
let () = aUnitToUnitCallbackFunction <- ocamlbonusfunction in
theMenu#popup ˜button ˜time
end
;;
class treeViewWithPopup () =
let window = GWindow.window () in
let columnList = new GTree.column_list in
let (flagColumn, flagColumnIndex) =
((columnList#add Gobject.Data.gobject), 0)
in
let (toggledFlagColumn, toggledFlagColumnIndex) =
((columnList#add Gobject.Data.boolean), 1)
in
let (titleColumn, titleColumnIndex) =
((columnList#add Gobject.Data.string), 2)
in
let (authorColumn, authorColumnIndex) =
((columnList#add Gobject.Data.string), 3)
in
let populate_tree (aTitleAndAuthorList: (string *string) list) (aTreeStore: GTree.tree_store) =
List.iter
(fun (aTitle, aAuthor) ->
let lastFilledRow = aTreeStore#append () in
let () =
aTreeStore#set ˜row:lastFilledRow ˜column:flagColumn aUncheckedRowPixbuf in
let () =
aTreeStore#set ˜row:lastFilledRow ˜column:toggledFlagColumn false in
let () =
aTreeStore#set ˜row:lastFilledRow ˜column:titleColumn aTitle in
let () =
aTreeStore#set ˜row:lastFilledRow ˜column:authorColumn aAuthor in
()
)
titlesAndAuthorsList
in
let treeStore =GTree.tree_store columnList in
let firstTreeView =
GTree.view
˜model:treeStore
˜headers_clickable:true
˜headers_visible:true
()
in
let create_vwColumn ?(appendto = firstTreeView)?(resizable = true) ?(sortingfor = None) (aTitle:string) (aRendererType:myTreeCellRendererType) =
let aVwCol =
match aRendererType with
| StringCellRendererBuild aColumn ->
(
GTree.view_column
˜title:aTitle
˜renderer:((GTree.cell_renderer_text []),
["text",aColumn])
()
)
| PixbufCellRendererBuild aColumn ->
(
GTree.view_column
˜title:aTitle
˜renderer:((GTree.cell_renderer_pixbuf []),
[("pixbuf",aColumn)])
()
)
| ToggleCellRendererBuild aColumn ->
(
GTree.view_column
˜title:aTitle
˜renderer:((GTree.cell_renderer_toggle [(`RADIO true)]),
[("active",aColumn)])
()
)
in
let colNum= appendto #append_column aVwCol in
let () = if resizable then (aVwCol#set_resizable true) else () in
(* we set the column of the column list of the tree store to sort this column according to*)
let () =
match sortingfor with
| Some num ->
(aVwCol#set_sort_column_id num)
| None -> ()
in
aVwCol
in
let menuObj = new popupMenu () in
let aCallbackID = menuObj#add_printingmenuitem "Print Content of Row"
in
let aCallbackID = menuObj#add_ocamlbonusmenuitem "Run Ocaml Bonus Function"
in
(* Callback for the row_activated signal:
* after Jacques Garrigue's tree.ml example,
* plus changing flag pixmap
* and radio buttons toggled *)
let _ =
firstTreeView#connect#after#row_activated
˜callback:
(fun path vcol ->
let selectionIter = treeStore#get_iter path in
(*unflag previous activations*)
let () =
List.iter
(fun eliter ->
let () =
treeStore#set
˜row:eliter
˜column:(flagColumn)
aUncheckedRowPixbuf
in
let () =
treeStore#set
˜row:eliter
˜column:(toggledFlagColumn)
false
in
()
)
!activatedRows
in
let () = activatedRows := []
in
(*keep track of this activation*)
let () = activatedRows := selectionIter::!activatedRows in
let () =
if (treeStore#iter_is_valid selectionIter) then
(
let () =
print_endline
("You've been activating \""^
(treeStore#get ˜row:selectionIter ˜column:(titleColumn))^
"\"")
in
let () =
let () =
treeStore#set
˜row:selectionIter
˜column:(flagColumn)
aCheckedRowPixbuf
in
let () =
treeStore#set
˜row:selectionIter
˜column:(toggledFlagColumn)
true
in
()
in
()
)
else
()
in
()
)
in
(* Quoting http://mail.gnome.org/archives/gtk-list/1999-March/msg00697.html:
*
* "basically, incomming X events get translated to gdk events which
* will then cause signal emissions on the widgets taht these gdk events belong to.
* signals are introduced per widget class and provide (simply speaking) a
* generic mechanism to hook callback functions into the call sequence upon
* execution of an object method."
*
*)
(* right-clicking detection, after Olivier Andrieu*)
let make_event w =
new GObj.event_ops w#as_widget
in
let aCallbackID =
(make_event firstTreeView)#connect#button_press
˜callback:(fun event ->
(* We are intercepting the signal,
* and the other effects that it may cause
* wil take place AFTER this callback.
* But we can not miss the change in selection:
* so, we'll try to recover it
*)
let () = firstTreeView#selection#unselect_all () in
(* One technique to select the row that we were above
* at the time of the button_press event,
* is to detect what path corresponds to the
* "current" mouse position
*)
let (x, y) =
((truncate (GdkEvent.Button.x event)),
(truncate (GdkEvent.Button.y event)))
in
let optPathColXY =
GtkTree.TreeView.get_path_at_pos ˜x ˜y
(GtkTree.TreeView.cast (firstTreeView#as_widget))
in
let () =
match optPathColXY with
| Some (pathWherePointer,_,_,_) ->
(
(*let's select our path by hand*)
firstTreeView#selection#select_path pathWherePointer
)
| None -> ()
in
(*Now, we'll check out that the mouse button pressed was the 3rd one*)
let () =
if ((GdkEvent.Button.button event) = 3) then
let stringToPrint =
match (firstTreeView#selection#get_selected_rows) with
| [] -> ""
| firstSelectedPath::tail ->
(Format.sprintf
"Welcome to \"%s\" by %s."
(treeStore#get
˜row:(treeStore#get_iter firstSelectedPath)
˜column:titleColumn)
(treeStore#get
˜row:(treeStore#get_iter firstSelectedPath)
˜column:authorColumn)
)
in
(* this popup call wraps menu#popup by modifying the
* string to print on-the-fly
*)
(menuObj#enhancedpopup
˜button:3
˜time:(GdkEvent.get_time event)
(* now we pass a string that the menu will work out somehow*)
stringToPrint
(* but we can pass a whole function instead of a simple string! *)
(
let bonusFun =
(
let aRandomInt = (Random.int 1024) in
if ((aRandomInt mod 2) = 0) then
(fun () ->
let aNum = (aRandomInt * aRandomInt) in
(print_endline
(string_of_int aNum);
flush stdout)
)
else
(fun () ->
let aNum = (sqrt (Pervasives.float aRandomInt)) in
(print_endline
(string_of_float aNum);
flush stdout)
)
)
in
bonusFun
)
)
else
()
in
(false) (*let's NOT stop the signal*)
)
in
object (self)
method window = window
method columnlist = columnList
method flagcolumn = flagColumn
method toggledflagcolumn = toggledFlagColumn
method titlecolumn = titleColumn
method titlecolumnindex = titleColumnIndex
method authorcolumn = authorColumn
method authorcolumnindex = authorColumnIndex
method populate aTAList () = populate_tree aTAList treeStore
method treestore = treeStore
method treeview = firstTreeView
method treevwcol ?appendto ?resizable ?sortingfor aTitle aRendererDescription =
create_vwColumn
?appendto
?resizable
?sortingfor
aTitle
(aRendererDescription:myTreeCellRendererType)
end
;;
(*.............*)
let main () =
let treeObj = new treeViewWithPopup () in
let window = treeObj#window in
let vbox = GPack.vbox ˜packing:window#add () in
let _ = window#connect#destroy ˜callback:GMain.quit in
let () = treeObj#populate titlesAndAuthorsList () in
let treeView = treeObj#treeview in
(* set view columns *)
let flagVwColumn =
treeObj#treevwcol
"Double-clicked"
(PixbufCellRendererBuild (treeObj#flagcolumn))
in
let toggledFlagVwColumn =
treeObj#treevwcol
"Double-clicked"
(ToggleCellRendererBuild (treeObj#toggledflagcolumn))
in
let titleVwColumn =
treeObj#treevwcol
˜sortingfor:(Some treeObj#titlecolumnindex )
"Title"
(StringCellRendererBuild (treeObj#titlecolumn))
in
let title2VwColumn =
treeObj#treevwcol
˜sortingfor:(Some treeObj#titlecolumnindex)
"Another View Column for Title"
(StringCellRendererBuild (treeObj#titlecolumn))
in
let authorVwColumn =
treeObj#treevwcol
˜sortingfor:(Some treeObj#authorcolumnindex)
"Author"
(StringCellRendererBuild (treeObj#authorcolumn))
in
let () = vbox#add (treeView#coerce)
in
(*Let's sort books by title first - simulating a click on column thanks to Olivier Andrieu*)
let () =
GtkSignal.emit_unit titleVwColumn#as_column GtkTree.TreeViewColumn.S.clicked
in
let clearButton =
GButton.button
˜label: "Clear"
˜packing: vbox#add
()
in
let aCbID =
clearButton #connect#clicked
˜callback:(fun () -> treeObj#treestore#clear ())
in
let populateButton =
GButton.button
˜label: "Populate"
˜packing: vbox#add
()
in
let aCbID =populateButton #connect#clicked
˜callback:(fun () -> treeObj#populate titlesAndAuthorsList () )
in
let closeButton =
GButton.button
˜label: "Close"
˜packing: vbox#add
()
in
let aCbID =
closeButton #connect#clicked
˜callback:(fun () -> window#destroy ())
in
let () =
window#show ()
in
GMain.main ()
;;
(*.............*)
let _ = main ();;
(*CUT HERE*)
|
18 febbraio 2004
