Re: Pixbuf column for a tree custom model

(**************************************************************************)
(*    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.                                                        *)
(*                                                                        *)
(**************************************************************************)

(* ../src/lablgtk2 -localdir custom_tree_generic.ml *)


let debug = false
let () =
  if debug then begin
  Gc.set { (Gc.get()) with Gc.verbose = 0x00d; space_overhead = 0 };
  ignore (Gc.create_alarm (fun () ->
  let s = Gc.stat () in
  Format.printf "blocks=%d words=%d@."
  s.Gc.live_blocks
  s.Gc.live_words))
  end

module MAKE(TREE:sig type t
		     val sons: t -> t array
                     val custom_value: Gobject.g_type -> t -> column:int -> Gobject.basic
                     val column_list:GTree.column_list
	    end) =
struct
  type custom_tree =
      {finfo: TREE.t;
       mutable sons: custom_tree array;
       mutable parent: custom_tree option;
       fidx: int (* invariant: parent.(fidx)==myself *) }

  let inbound i a = i>=0 && i<Array.length a

  (** The custom model itself *)
  class custom_tree_class column_list =
  object (self)
    inherit
      [custom_tree,custom_tree,unit,unit] GTree.custom_tree_model column_list

    method custom_encode_iter cr = cr, (), ()
    method custom_decode_iter cr () () = cr

    val mutable num_roots : int = 0
    val mutable roots :  custom_tree array = [||]

    method custom_get_iter (path:Gtk.tree_path) : custom_tree option =
      let indices: int array  = GTree.Path.get_indices path in
      match indices with
      | [||] ->
          None
      | _ ->
          if inbound indices.(0) roots then
            let result = ref (roots.(indices.(0))) in
            try
              for depth=1 to Array.length indices - 1 do
                let index = indices.(depth) in
                if inbound index !result.sons then
                  result:=!result.sons.(index)
                else raise Not_found
              done;
              Some !result
            with Not_found ->
              None
          else None

    method custom_get_path (row:custom_tree) : Gtk.tree_path =
      let current_row = ref row in
      let path = ref [] in
      while !current_row.parent <> None do
        path := !current_row.fidx::!path;
        current_row := match !current_row.parent with Some p -> p
        | None -> assert false
      done;
      GTree.Path.create ((!current_row.fidx)::!path)

    method custom_value (t:Gobject.g_type) (row:custom_tree) ~column =
      TREE.custom_value t row.finfo ~column

    method custom_iter_next (row:custom_tree) : custom_tree option =
      let nidx = succ row.fidx in
      match row.parent with
      | None -> if inbound nidx roots then Some roots.(nidx)
        else None
      | Some parent ->
          if inbound nidx parent.sons then
            Some parent.sons.(nidx)
          else None

    method custom_iter_children (rowopt:custom_tree option) :custom_tree option =
      match rowopt with
      | None -> if inbound 0 roots then Some roots.(0) else None
      | Some row -> if inbound 0 row.sons then Some row.sons.(0) else None

    method custom_iter_has_child (row:custom_tree) : bool =
      Array.length row.sons  > 0

    method custom_iter_n_children (rowopt:custom_tree option) : int =
      match rowopt with
      | None -> Array.length roots
      | Some row -> Array.length row.sons

    method custom_iter_nth_child (rowopt:custom_tree option) (n:int)
      : custom_tree option =
      match rowopt with
      | None when inbound n roots -> Some roots.(n)
      | Some row when inbound n row.sons -> Some (row.sons.(n))
      | _ -> None

    method custom_iter_parent (row:custom_tree) : custom_tree option =
      row.parent

    method append_tree (t:TREE.t) =
      let rec make_forest root sons =
        Array.mapi
          (fun i t -> let result = {finfo=t; fidx=i; parent = Some root;
                                    sons = [||] }
           in
           let sons = make_forest result (TREE.sons t) in
           result.sons<-sons;
           result)
          sons
      in
      let pos = num_roots in
      num_roots <- num_roots+1;
      let root = { finfo = t; sons = [||];
                   parent = None;
                   fidx = pos }
      in

      let sons = make_forest root (TREE.sons t)
      in
      root.sons <- sons;
      roots <-
        Array.init num_roots (fun n -> if n = num_roots - 1 then root
                              else roots.(n))

  end

  let custom_tree () =
    new custom_tree_class TREE.column_list
end


  let pix_size = 16
  let pix =
    let f file =
      GdkPixbuf.from_file_at_size file ~width: pix_size ~height: pix_size
    in
    f  Sys.argv.(1)

module T=struct
  type leaf = {mutable checked: bool; mutable lname: string; }
  type t = Leaf of leaf |  Node of string* t list

  let sons t = match t with
  | Leaf _ -> [||]
  | Node (_,s)-> Array.of_list s

  (** The columns in our custom model *)
  let column_list = new GTree.column_list ;;
  let col_file = (column_list#add Gobject.Data.caml: t GTree.column);;
  let col_bool = column_list#add Gobject.Data.boolean;;
  let col_int = column_list#add Gobject.Data.int;;
  let col_is_leaf = column_list#add Gobject.Data.boolean;;
  let col_pb = (column_list#add Gobject.Data.caml: GdkPixbuf.pixbuf GTree.column);;

  let custom_value _ t ~column =
    match column with
    | 0 -> (* col_file *) `CAML (Obj.repr t)
    | 1 -> (* col_bool *) `BOOL false
    | 2 -> (* col_int *) `INT 0
    | 3 -> (* col_is_leaf*) `BOOL (match t with Leaf _ -> true | _ -> false)
    | 4 -> (* col_pb *) `CAML (Obj.repr pix)
    | _ -> assert false

end

module MODEL=MAKE(T)

let nb = ref 0

let make_tree n p =
  let rec aux p0 =
    if p=p0 then
      begin
        incr nb;
        T.Leaf {T.lname = "Leaf "^string_of_int !nb; checked = false}
      end
    else begin
      incr nb;
      let name = "Node "^string_of_int !nb in
      T.Node (name,aux_list n (succ p0))
    end
  and aux_list n p =
    if n = 0 then []
    else aux p::aux_list (n-1) p
  in
  aux 0

let fill_model t =
  for i = 0 to 10000 do
    t#append_tree (make_tree 1 1)
  done



let create_view_and_model () : GTree.view =
  let custom_tree = MODEL.custom_tree () in
  fill_model custom_tree;
  let view = GTree.view ~fixed_height_mode:true ~model:custom_tree () in
  let renderer = GTree.cell_renderer_text [] in
  let col_name = GTree.view_column ~title:"Name" ~renderer:(renderer,[]) () in
  col_name#set_sizing `FIXED;
  col_name#set_fixed_width 150;
  col_name#set_cell_data_func
    renderer
    (fun model row ->
       try
	 let data = model#get ~row ~column:T.col_file in
	 match data with
	 | T.Leaf {T.lname = s} | T.Node (s,_) ->
	     renderer#set_properties [ `TEXT s ];
       with exn ->
	 let s = GtkTree.TreePath.to_string (model#get_path row) in
	 Format.printf "Accessing %s, got '%s' @." s (Printexc.to_string exn));
  ignore (view#append_column col_name);

  let renderer = GTree.cell_renderer_toggle [] in
  let col_tog = GTree.view_column ~title:"Check"
    ~renderer:(renderer,["visible", T.col_is_leaf])
    ()
  in
  col_tog#set_sizing `FIXED;
  col_tog#set_fixed_width 10;
  col_tog#set_cell_data_func
    renderer
    (fun model row ->
       try
	 let data = model#get ~row ~column:T.col_file in
	 match data with
	 | T.Leaf {T.checked = b}  -> renderer#set_properties [ `ACTIVE b ]
         | _ -> ()
       with exn ->
	 let s = GtkTree.TreePath.to_string (model#get_path row) in
	 Format.printf "Accessing %s, got '%s' @." s (Printexc.to_string exn));

  ignore(renderer#connect#toggled
           (fun path ->
              let row = custom_tree#custom_get_iter path in
              match row with
              | Some {MODEL.finfo=T.Leaf l} ->
                  l.T.checked <- not l.T.checked
              | _ -> ()));
  ignore (view#append_column col_tog);

  let pix_renderer = GTree.cell_renderer_pixbuf [] in
  let col_pb = GTree.view_column () ~renderer: (pix_renderer, ["pixbuf",T.col_pb]) in
  col_pb#set_sizing `FIXED;
  col_pb#set_fixed_width 16;
  col_pb#set_cell_data_func
    pix_renderer
    (fun model row ->
       try
	       pix_renderer#set_properties [ `PIXBUF pix ]
       with exn ->
	      let s = GtkTree.TreePath.to_string (model#get_path row) in
	      Format.printf "Accessing %s, got '%s' @." s (Printexc.to_string exn)
	 );

  ignore (view#append_column col_pb);
  view

let _ =
  ignore (GtkMain.Main.init ());
  let window = GWindow.window ~width:200 ~height:400 () in
  ignore
    (window#event#connect#delete
       ~callback:(fun _ -> exit 0));
  let scrollwin = GBin.scrolled_window ~packing:window#add () in
  let view = create_view_and_model () in
  scrollwin#add view#coerce;
  window#show ();
  GtkMain.Main.main ()