From: Stalkern 2 <stalkern2 at tin.it>
Reply-To: stalkern2 at tin.it
To: lablgtk at kaba.or.jp
Subject: Columned tree with editable cells
Date: Wed, 14 Jan 2004 12:52:28 +0100
MIME-Version: 1.0
Content-Type: Multipart/Mixed;
  boundary="Boundary-00=_81SBA8jPE/qg7Ut"
Message-Id: <200401141252.28593.stalkern2 at tin.it>


--Boundary-00=_81SBA8jPE/qg7Ut
Content-Type: text/plain;
  charset="us-ascii"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline

Hello to everybody!

I've put up another code sample.

Could anybody take a look at it, before I publish it for the sake of the 
ocamlers ?

It works fine, maybe I'd just set that cells of missing elements are not 
editable (they lack a place for recording changes), how do I swap 
cell_renderers?


Thanks in advance!


Ernesto

--Boundary-00=_81SBA8jPE/qg7Ut
Content-Type: text/ocaml-src;
  charset="us-ascii";
  name="my_ctree_w_editablecells.ml"
Content-Transfer-Encoding: 7bit
Content-Disposition: attachment;
	filename="my_ctree_w_editablecells.ml"


(* Lablgtk2 Tree View with Tree Mapping and editable Cells*)

(* Wed Jan 14 12:36:15 CET 2004; code written by stalkern at tiscalinet.it *)

(* We are planning to work with a Tree View. 
 * To help ourselves do so, we'll set up a classic Ocaml tree structure
 * and use it as an image for the Tree View. This is because the coder of this article feels 
 * that tree structures give their best with Functional Programming; however, gtk functions exist
 * for querying a TreeStore for valid and non valid iters, once you've managed to build it.
 * If tree structures are not your piece of cake, you can build tree views by hand, and jump to the 
 * gtk wrapper classes.
 *
 * It is unpractical to write trees by hand, so we will build up trees of the desired type starting from
 * a list of (content, position)-couples.
 * One problem is that who fills the association list is not bound to writing down all the 
 * logical positions required; one could ask for putting item "Serendipity" at position 3:2, but miss 
 * to say anything about the existence and contents of positions 0, 1, 2, 3, 3:0, 3:1.
 * We'll therefore work out a way to deduct the positions assumed by one, and build a tree that 
 * is the minimum necessary for having the desired position.
 * We can do so for every requested position, and then merge the "assumed" trees to get the 
 * overall tree with all of the requested positions.
 * So far, this is common Ocaml tree programming; now comes GTK-2.
 * Having a tree holding positions behind the scenes would not lead to a gtk-2 tree view 
 * if these positions can't ease up working with Gtk.tree_iter's. That's why we prepare 
 * at every Node a place for a Gtk.tree_iter besides the place for the said position 
 * expressed in terms of a path, i.e. a integer list (that we'll call "PIL").

 * To place the proper Gtk.tree_iters in our tree_iters and paths tree, we modify the classic 
 * function for vertical iteration on a tree, by having it forward the "parent" tree_iter. 
 * This way,  we walking our image and build up the gtk tree store accordingly, and still keep track of
 * the tree_iters in our image.
 *)

(* 
 * Cell editing is set at cell renderer' s level. The GTree.cell_renderer_text_signals class 
 * has a method "edited" accepting a callback that gets a cell path and an edited string.
 * All that is left to do is updating the place where items are recorded. 
 * Please notice that since editing makes it possible to the user to enter text, and we don't know 
 * beforehand whether will such text comply to our charset, we'll wisely choose to 
 * refer to UTF-8, and perform some UTF-8 conversions when needed.
 *)


(*..........................................................................................*)

open StdLabels
open Gobject.Data

(*..........................................................................................*)
(*INITS*)

let theProgramCodesetStr = "ISO-8859-1";;

let utf8ItemsAndPILList = 
  ref 
    [
      ("root",[0]);
      ("child 1-0", [1;0]);
      ("child 1-1", [1;1]);
      ("child 1-2", [1;2]);
      ("child 2-2", [2;2]);
      ("child 3-4-3", [3;4;3]);
    ];;


(*..........................................................................................*)
(*TYPES*)

type myTreeCellRendererType = 
    StringCellRendererBuild of (string GTree.column ) 
  | PixbufCellRendererBuild of (GdkPixbuf.pixbuf GTree.column)
  | ToggleCellRendererBuild of (bool GTree.column)
  | EditableCellRendererBuild of (string GTree.column );;


(*..........................................................................................*)
(*UTF-8 CONVERSION*)
let string_from_utf8 aString = 
  Glib.Convert.convert 
    ~to_codeset: theProgramCodesetStr  
    ~from_codeset: "utf-8" 
    aString
;;

(*..........................................................................................*)

let string_to_utf8 aString = 
  Glib.Convert.convert 
    ~to_codeset: "utf-8" 
    ~from_codeset: theProgramCodesetStr  
    aString
;;

(*..........................................................................................*)
(* TREE STRUCTURE FOR MANAGING THE GTK TREESTORE *)
(*Types for tree mapping *)

type aPathIntegerListType = SuperRoot | Path of int list;;

type 'a treestoreTreeType = 
    Node of 
      ((Gtk.tree_iter option) * aPathIntegerListType) * 
      (((Gtk.tree_iter option) * aPathIntegerListType) treestoreTreeType list);;

(*..........................................................................................*)

let pathString_of_path aPath  = 
  match aPath with
    | SuperRoot -> failwith "Path is SuperRoot"
    | Path aPIL -> 
	match aPIL with
	  | [] -> failwith "Path is Void"
	  | hd::tail -> 
	      List.fold_left
	      ~f:(fun i1str i2 -> (i1str^":"^(string_of_int i2))) 
	      ~init:(string_of_int hd)
	      tail
;;

(*..........................................................................................*)
let parentPath_of_path aPath = 
  match aPath with
    | SuperRoot -> failwith "Path is SuperRoot"
    | Path aPIL -> 
	match aPIL with
	  | hd::[] -> SuperRoot
	  | _ -> Path (List.rev (List.tl (List.rev aPIL)))
;;

(*..........................................................................................*)
let depth_of_path aPath = 
  match aPath with
    | SuperRoot -> failwith "Path is SuperRoot"
    | Path aPIL -> ((List.length aPIL) - 1)
;;

(*..........................................................................................*)
let previousSiblingList_of_path aPath =
  match aPath with
    | SuperRoot -> failwith "Path is SuperRoot"
    | Path aPIL -> 
	let posOfLast = (List.hd (List.rev aPIL)) in
	let parentPIL = (parentPath_of_path aPath)
	in
	let rec walk aCounter aPosOfLast aMatchedL =
	  if (aCounter = aPosOfLast) then 
	    List.rev aMatchedL
	  else	
	    (
	      walk 
	       (aCounter + 1) 
	       aPosOfLast
	       (match parentPIL with 
		  | SuperRoot ->  ((Path [aCounter])::aMatchedL)
		  | Path aParentPIL -> ((Path (aParentPIL@[aCounter]))::aMatchedL)
	       )
	    )
	in
	  walk 0 posOfLast []
;;

(*..........................................................................................*)
(* get full tree supposed by a single item: no iters yet*)	
  	
let rec get_individualPathTree (currentNode: (Gtk.tree_iter option * aPathIntegerListType) treestoreTreeType) =
  match currentNode with
      | Node ((currentIter, currentPath), nodeChildrenPathsL) ->

	  let depthOfCurrentPIL = (depth_of_path currentPath)
	  in
	    
	    if (depthOfCurrentPIL = 0) then 
	      (
		Node
		 ((None, SuperRoot),
		  (
		    (List.map 
		       (fun aPath -> (Node ((None, aPath), [])))
		       (previousSiblingList_of_path currentPath)
		    )@
		    [currentNode]
		  )
		 )
	      )
	    else
	      (
		let newUpperNode =
		  (
		    Node 
		     ((None,(parentPath_of_path currentPath)),
		      (
			(List.map 
			   (fun aPath -> (Node ((None,aPath), [])))
			   (previousSiblingList_of_path currentPath)
			)@
			[currentNode])
		     )	      
		  )
		in		    
		  get_individualPathTree newUpperNode
	      )
;;

(*..........................................................................................*)

let rec iter_tree_vert funcOnNodeData (aTree: 'a treestoreTreeType) =
  match aTree with
    | Node ((ni,nd), nch) -> 
	( 
	  let () = funcOnNodeData nd in
	  (List.iter
	       (fun aNode -> iter_tree_vert funcOnNodeData aNode) 
	       nch 
	    )
	)
;;

(*..........................................................................................*)

let show_tree (aTree:'a treestoreTreeType) =

  let () = 
    (print_endline "-------------------------------------------------------------------------"; flush stdout)
  in

  iter_tree_vert 
    (fun nd -> 
       print_endline 
       (try (pathString_of_path nd ) with exn -> "SuperRoot" );
    flush stdout)
    aTree
;;


(*..........................................................................................*)

let rec matchAllToAll mergingOneToAllFun aL1 aL2 =

  match aL1 with 
    | [] -> aL2
    | hd1::tail1 -> 
	matchAllToAll mergingOneToAllFun tail1 (mergingOneToAllFun hd1 aL2)
;;

(*..........................................................................................*)
(*merge trees, assuming that their data nodes are unique at the same level*)

let rec merge_trees (tree1:'a treestoreTreeType) (tree2List:'a treestoreTreeType list) =

    match (tree1, tree2List) with
      | (tree1, [] ) -> 

	  [tree1]

      | (tree1, t2hd::t2tail ) -> 
	  (
	    match tree1 with 
	      | (Node ((on1i, n1d), n1children )) ->

		  let isAkin aNode2 =
		    match aNode2 with	      
		      | (Node ((on2i, n2d), n2children )) -> (n2d = n1d)
		  in
		    
		  let oneAkinExists =
		    List.exists isAkin tree2List
		  in
		    
		    if oneAkinExists then 
		      (
			List.map 
			 (fun n2 ->

			    if (not (isAkin n2)) then 
			      (*this node2 is not akin to node 1*)
			      n2 
			    else (*node2 is akin to node1 *)
			      (
				if (n2 = tree1) then 
				  (*node2 is not only akin but also equal to to node1;
				   * i.e, tree1 is already in tree2list
				   *) 
				  ( n2 (*i.e., tree1*) )
				else
				  ( (*check out children*)
				    match n2 with
				      | (Node ((on2i,n2d), n2children )) ->
			  
					  (Node 
					     ((on1i, n1d), 
					      (
					  
						match n1children with
						  | [] -> n2children 
						  | n1childhd::n1childtail ->

						      (matchAllToAll 
							 merge_trees 
							 n1children
							 n2children
						      )	  
					      )
					     )
					  )
				  )	  
			      )
			 )
			 tree2List
		      )
		    else (*no akin exists*)		      
		      ( tree2List@[tree1] )
	  )
;;
			


(*..........................................................................................*)
(* get overall full tree *)

let get_overallPathTree  individualPathsTreesList = 
  match individualPathsTreesList with
    | [] -> 
	failwith "No Individual Paths Provided. "
    | hd::tail -> 
	List.fold_left 
	~f:(fun t1 t2 -> 
	      let t1plus2List = (merge_trees t1 [t2]) in 
		(* taking List.hd only here is safe because PIL of 
		 * all the current Nodes of individualPathsTreesList
		 * will be SuperRoot, i.e. the same*)

		List.hd  t1plus2List)
	~init:hd 
	tail
;;
		    
(*..........................................................................................*)

let rec build_treestoreTree_vert (aTree: 'a treestoreTreeType) (aTreeStore: GTree.tree_store) parentOptIter =
  
  let examinedTree =
    
    match aTree with   
      | Node ((oni,nd), nch) ->
	  
	  let optCurrentTreeIter = 
	    (
	    match nd with
	      | SuperRoot -> None
	      | Path pil ->
		  Some 
		  (
		    match oni with
		      | None -> 
			  (match parentOptIter with
			     | None -> 
				 (aTreeStore#append ())
			     | Some pi -> 
				 (aTreeStore#append ~parent:pi ())
			  )
		      | Some ni -> ni
		  )
	  )
	  in
	    Node ((optCurrentTreeIter,nd), nch) 
  in
  
    match  examinedTree with
    
      | Node ((oni,nd), nch) -> 
	(	  

	  Node
	   ((oni,nd), 
	    (List.map 
	       (fun aNode -> 
		  build_treestoreTree_vert 
		  aNode 
		  aTreeStore 
		  (oni) 
	       ) 
	       nch 
	    )
	   )
	)
;;

(*..........................................................................................*)

let rec set_treestoreCells (aTree: 'a treestoreTreeType) (aTreeStore: GTree.tree_store) targetViewColumn =
  match aTree with
    | Node ((oni,nd), nch) -> 
	( 
	  let () =
	    match oni with
	      | None -> () 
	      | Some currentTreeIter ->
		  (
		    aTreeStore#set 
		     ~row:currentTreeIter 
		     ~column:targetViewColumn 
		     (string_from_utf8 
			(try 
			   (""^(fst 
				  (List.find 
				     ~f:(fun (_,il) -> (nd = (Path il)) 
					) 
				     !utf8ItemsAndPILList)
			       ))
			 with exn -> 
			   (" missing ["^
			    (try 
			       (pathString_of_path nd ) 
			     with exn -> "SuperRoot" )^
			    "]"
			   )
			)
		     )	      
		  )
	  in

	  (List.iter
	       (fun aNode -> set_treestoreCells aNode aTreeStore targetViewColumn) 
	       nch 
	    )
	)
;;


(*..........................................................................................*)
(* GTK CLASSES *)


class treeView () =

  let window = GWindow.window ~title:"Tree with editable cells" ~width:200 () in

  let columnList = new GTree.column_list in

  let (titleColumn, titleColumnIndex) = 
    ((columnList#add Gobject.Data.string), 0)
  in

  let populate_tree (aItemsAndPILList: (string * (int list)) list)  (aTreeStore: GTree.tree_store) =

    (*let's start by ensuring that the tree cells will EXIST;
     * we'll fill them with the proper contents afterwards
     *)
    
    let theIndividualPathsTreesList =
      List.map
	(fun (aItem, aPIL) -> get_individualPathTree (Node ((None, Path aPIL), [])) )
	aItemsAndPILList
    in


    let theOverallPathTree =
      get_overallPathTree theIndividualPathsTreesList 
    in

    (*let () = show_tree theOverallPathTree in*)


    (* build Gtk tree and add iters in mapping tree *)
    let theOverallPathTreeWithIters =
      build_treestoreTree_vert 
	theOverallPathTree
	aTreeStore
	None
    in

    let () =
      set_treestoreCells
	theOverallPathTreeWithIters
	aTreeStore
	titleColumn
    in

      ()
  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)]
			 )
	       ()
	    )	
	| EditableCellRendererBuild aColumn ->
	    
	    (
	      GTree.view_column 
	       ~title:aTitle 
	       ~renderer:(
		 let aCellRenderer = (GTree.cell_renderer_text [(`EDITABLE true);(`FOREGROUND "darkBlue")]) in
		 let aCbID = 
		   aCellRenderer#connect#edited 
		     ~callback:
		     (fun editedPath editedString ->
	 
			(*let () = print_endline 
				   ("Cell at path="^
				    (GtkTree.TreePath.to_string editedPath)^
				    " has been edited as string "^	    
				    (string_from_utf8 editedString)^
				    "!");
			  flush stdout 
			in*)
			let () =
			  utf8ItemsAndPILList:=
			  (List.map 
			     (fun (aContent , aPIL) -> 
				if ((Array.to_list (GtkTree.TreePath.get_indices editedPath)) = aPIL) then 
				  ((string_to_utf8 editedString), aPIL)
				else
				  (aContent , aPIL)
			     )
			     !utf8ItemsAndPILList
			  )
			in
			let editedPathIntList = 
			  (Array.to_list (GtkTree.TreePath.get_indices editedPath))
			in
			  (
			    treeStore#set 
			     ~row:(treeStore#get_iter editedPath)
			     ~column:aColumn 
			     (string_from_utf8 (try 
				   (fst 
				      (List.find 
					 ~f:(fun (_,aPIL) -> 
					       (editedPathIntList = aPIL))
					 !utf8ItemsAndPILList
				      )
				   )
				 with exn -> 
				   (" missing ["^
				    (try 
				       (pathString_of_path (Path editedPathIntList) ) 
				     with exn -> "SuperRoot" )^
				    "]"
				   )
				)
			     )	      
			  )
			  
		     )
		 in

		   (aCellRenderer,
		    [("text",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
    


object (self)
  method window = window
  method columnlist = columnList
  method titlecolumn = titleColumn
  method titlecolumnindex = titleColumnIndex	 
  method populate aIPILList () = populate_tree aIPILList 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 treeView () 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 !utf8ItemsAndPILList() in

  let treeView = treeObj#treeview in

  (* set view columns *)
  let titleVwColumn =   
    treeObj#treevwcol
      "Item" 
      (EditableCellRendererBuild  (treeObj#titlecolumn)) 
  in

  let () = vbox#add (treeView#coerce) 
  in


  let clearButton = 
    GButton.button 
      ~label: "Clear"  
      ~packing: vbox#add 
      ()
  in
  let aCbID =
    clearButton #connect#clicked 
      ~callback:(fun () -> treeObj#treestore#clear ()) 
  in

  let repopulateButton = 
    GButton.button 
      ~label: "Rebuild"  
      ~packing: vbox#add 
      ()
  in
  let aCbID =repopulateButton #connect#clicked 
	       ~callback:(fun () -> 
			    let () = treeObj#treestore#clear () in 
			      treeObj#populate !utf8ItemsAndPILList() )
  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 ();;

(*...........................................................................................*)



--Boundary-00=_81SBA8jPE/qg7Ut--