Commits

Sébastien Ferré committed 7145724

[gui] custom feature tree model for efficiency reasons

Comments (0)

Files changed (1)

 
 let _ =
   prerr_endline "Gui: parsing command line arguments...";
+(*
   Gc.set { (Gc.get())
 	 with
 	   Gc.major_heap_increment = 512*1024;
 	   Gc.space_overhead = 50;
 	   Gc.max_overhead = 50;
            Gc.stack_limit = 8 * 1024 * 1024 };
+*)
   Arg.parse
     [ ("-user", Arg.String (fun uri -> current_src := uri), "user URI");
       ("-logui", Arg.Unit (fun () -> logui := true), "logs the GUI session");
 
     method grab_focus () = entry_custom#misc#grab_focus ()
 
-    method refresh =
+    method refresh = Common.prof "Gui.entry_features#refresh" (fun () ->
       relative_rank <- 0;
       let place = history#current#place in
       let ltransf = place#transformations in
       refresh_widget_transf item_describe Describe;
       refresh_widget_transf item_select Select;
       refresh_widget_transf item_delete Delete;
-      if not full then refresh_widget_transf button_delete Delete
+      if not full then refresh_widget_transf button_delete Delete)
       
     method input mode () =
       let custom =
 	~text:"Delete the current query focus";
   end
 
+type custom_iter =
+    { incr : incr;
+      idx : int; (* rank as child of parent *)
+      parent : custom_iter option;
+      mutable children : custom_iter array option; (* None means not yet computed *)
+    }
+
+class custom_tree (root : incr) column_list =
+  let inbound i a = i >= 0 && i < Array.length a in
+  let make_children (parent_incr : incr) (parent_opt : custom_iter option) : custom_iter array =
+    (* TODO: optimize? *)
+    let increments = history#current#place#children_increments parent_incr#increment in
+    let increments = List.sort ~cmp:(fun i1 i2 -> Lisql.Feature.compare i1 i2) increments in
+    let sub_increments = Common.sub_list increments 0 100 in
+    let ar_increments = Array.of_list sub_increments in
+    let ar_iters = Array.mapi (fun i increment -> { incr = make_incr increment; idx = i; parent = parent_opt; children = None}) ar_increments in
+    ar_iters
+  in
+object (self)
+  inherit [custom_iter,custom_iter,unit,unit] GTree.custom_tree_model column_list
+
+  method custom_encode_iter iter = iter, (), ()
+  method custom_decode_iter iter () () = iter
+
+  val root_children : custom_iter array = make_children root None
+
+  method private children (iter_opt : custom_iter option) : custom_iter array =
+    match iter_opt with
+      | None -> root_children
+      | Some iter ->
+	( match iter.children with
+	    | None ->
+	      let children = make_children iter.incr (Some iter) in
+	      iter.children <- Some children;
+	      children
+	    | Some children -> children )
+
+  method custom_get_iter (path : Gtk.tree_path) : custom_iter option =
+    let indices : int array = GTree.Path.get_indices path in
+    let d = Array.length indices in
+    if d = 0
+    then None
+    else
+      if inbound indices.(0) root_children
+      then
+	let result = ref (root_children.(indices.(0))) in
+	try
+	  for depth = 1 to d - 1 do
+	    let children = self#children (Some !result) in
+	    let index = indices.(depth) in
+	    if inbound index children
+	    then result := children.(index)
+	    else raise Not_found
+	  done;
+	  Some !result
+	with Not_found -> None
+      else None
+
+  method custom_get_path (row : custom_iter) : Gtk.tree_path =
+    let current_row = ref row in
+    let path = ref [] in
+    while !current_row.parent <> None do
+      path := !current_row.idx::!path;
+      current_row := match !current_row.parent with Some p -> p | None -> assert false
+    done;
+    GTree.Path.create ((!current_row.idx)::!path)
+
+  method get_incr (row : custom_iter) = row.incr
+
+  method get_feature (row : custom_iter) = row.incr#string
+  method get_markup (row : custom_iter) = make_markup (row.incr#display ~obs:Tarpit.blind_observer)
+  method get_count (row : custom_iter) = string_of_int row.incr#supp
+  method get_lift_label (row : custom_iter) =
+    if not check_lift#active
+    then " "
+    else string_of_int row.incr#lift#supp
+  method get_lift_color (row : custom_iter) =
+    if not check_lift_color#active
+    then str_white
+    else row.incr#lift#color
+  method get_row_color (row : custom_iter) =
+    if not check_feat_color#active
+    then str_black
+    else
+      let open Lisql.Feature in
+	  match row.incr#kind with
+	    | Kind_Variable -> str_color_variable
+	    | Kind_Entity -> str_color_entity
+	    | Kind_Literal -> str_color_literal
+	    | Kind_Class -> str_color_class
+	    | Kind_Property -> str_color_property
+	    | Kind_InverseProperty -> str_color_property
+	    | Kind_Structure -> str_color_functor
+	    | Kind_Argument -> str_color_functor
+	    | _ -> str_black
+  method get_row_scale (row : custom_iter) =
+    if not check_scale#active
+    then 1.
+    else row.incr#scale
+  method get_row_weight (row : custom_iter) =
+    if row.incr#anew
+    then 400
+    else 200
+  method get_bg_color (row : custom_iter) = str_white
+  method get_thumb_file (row : custom_iter) = 
+    match row.incr#uri_opt with
+      | None -> ""
+      | Some uri ->
+	match picture_of_name ~obs:Tarpit.blind_observer (Rdf.URI uri) with
+	  | None -> ""
+	  | Some f -> f
+
+  method custom_value (t : Gobject.g_type) (row : custom_iter) ~(column : int) =
+    match column with
+      | 0 -> (* feature *) `STRING (Some (self#get_feature row))
+      | 1 -> (* markup *) `STRING (Some (self#get_markup row))
+      | 2 -> (* count *) `STRING (Some (self#get_count row))
+      | 3 -> (* lift_label *) `STRING (Some (self#get_lift_label row))
+      | 4 -> (* lift_color *) `STRING (Some (self#get_lift_color row))
+      | 5 -> (* row color *) `STRING (Some (self#get_row_color row))
+      | 6 -> (* row_scale *) `FLOAT (self#get_row_scale row)
+      | 7 -> (* row_weight *) `INT (self#get_row_weight row)
+      | 8 -> (* bg_color *) `STRING (Some (self#get_bg_color row))
+      | 9 -> (* thumb_file *) `STRING (Some (self#get_thumb_file row))
+      | _ -> assert false
+
+  method custom_iter_next (row : custom_iter) : custom_iter option =
+    let children = self#children row.parent in
+    let nidx = succ row.idx in
+    if inbound nidx children then Some children.(nidx) else None
+
+  method custom_iter_children (row_opt : custom_iter option) : custom_iter option =
+    let children = self#children row_opt in
+    if inbound 0 children then Some children.(0) else None
+
+  method custom_iter_has_child (row : custom_iter) : bool =
+    Array.length (self#children (Some row)) > 0
+
+  method custom_iter_n_children (row_opt : custom_iter option) : int =
+    Array.length (self#children row_opt)
+
+  method custom_iter_nth_child (row_opt : custom_iter option) (n : int) : custom_iter option =
+    let children = self#children row_opt in
+    if inbound n children then Some children.(n) else None
+
+  method custom_iter_parent (row : custom_iter) : custom_iter option =
+    row.parent
+
+end
 
 class tree_features_callbacks =
   object
   let cols = new GTree.column_list in
   let feature = cols#add string in
   let markup = cols#add string in
-(*      let incr = cols#add caml in *)
   let count = cols#add string in
   let lift_label = cols#add string in
 (*      let lift_scale = cols#add float in *)
 (*      let lift_fg_color = cols#add string in *)
   let lift_color = cols#add string in
-(*      let ext = cols#add caml in *)
   let row_color = cols#add string in
   let row_scale = cols#add float in
   let row_weight = cols#add int in
   let bg_color = cols#add string in
   let thumb_file = cols#add string in
-  let model = GTree.tree_store cols in
-  let h_incr = Hashtbl.create 101 in
-  let view = GTree.view ~model:model ~headers_visible:false ~packing:sw#add () in
+(*  let model = GTree.tree_store cols in *)
+(*  let h_incr = Hashtbl.create 101 in *)
+  let view = GTree.view (*~model:model*) ~headers_visible:false ~packing:sw#add () in
   let cell_count =  GTree.cell_renderer_text [`XALIGN 1.; `YALIGN 0.] in
   let col_count =
     let col =
       GTree.view_column ~title:"Count" ()
 	~renderer:(cell_count, ["text",count]) in
     col # add_attribute cell_count "scale" row_scale;
-    col # set_sizing `GROW_ONLY;
+    col # set_sizing `AUTOSIZE;
     col in
   let cell_lift = GTree.cell_renderer_text [`XALIGN 1.; `YALIGN 0.] in
   let col_lift =
 (*	col # add_attribute cell_lift "scale" lift_scale; *)
 (*	col # add_attribute cell_lift "foreground" lift_fg_color; *)
     col # add_attribute cell_lift "background" lift_color;
-    col # set_sizing `GROW_ONLY;
+    col # set_sizing `AUTOSIZE;
     col in
   let cell_feature = GTree.cell_renderer_text [`YALIGN 0.] in
   let col_feature =
 (*    col # add_attribute cell_feature "foreground" row_color; *)
     col # add_attribute cell_feature "background" bg_color;
     col # add_attribute cell_feature "weight" row_weight;
-    col # set_sizing `GROW_ONLY;
+    col # set_sizing `AUTOSIZE;
     col in
   let cell_thumb = GTree.cell_renderer_pixbuf [`YALIGN 0.] in
   let col_thumb =
 
     method root = v
 
+    val mutable model = new custom_tree (get_incr ()) cols
+
+    method model = model
+
     val mutable ignore_selection_changed = false
 
     method selection_changed () =
       end
 
     method row_activated path vcol =
-      let iter = model # get_iter path in
-      let count = model#get ~row:iter ~column:count in
-      if count <> ""
-      then callbacks # row_activated path
-      else begin (* a function has been activated *)
-	let sf = self # feature_from_path path in
-	if sf = function_top then self # page_top (model#iter_parent iter)
-	else if sf = function_up then self # page_up (model#iter_parent iter)
-	else if sf = function_down then self # page_down (model#iter_parent iter)
-	else if sf = function_bottom then self # page_bottom (model#iter_parent iter)
-	else ()
-      end
+      match model#custom_get_iter path with
+	| None -> ()
+	| Some iter ->
+	  let count = model#get_count iter (*model#get ~row:iter ~column:count*) in
+	  if count <> ""
+	  then callbacks # row_activated path
+	  (*else begin (* a function has been activated *)
+	    let sf = self # feature_from_path path in
+	    if sf = function_top then self # page_top (model#iter_parent iter)
+	    else if sf = function_up then self # page_up (model#iter_parent iter)
+	    else if sf = function_down then self # page_down (model#iter_parent iter)
+	    else if sf = function_bottom then self # page_bottom (model#iter_parent iter)
+	    else ()
+	  end*)
 
     method button_press ev =
       let path_opt =
       else
 	false
 
-    method ext_from_path path : Ext.t =
-      let i = self#incr_from_path path in
-      i#ext
-
-    method feature_from_path path : string =
-      model#get ~row:(model#get_iter path) ~column:feature
+    method incr_from_path path : incr =
+      match model#custom_get_iter path with
+	| None -> failwith "Gui.tree_features#incr_from_path: invalid path"
+	| Some iter -> model#get_incr iter
 
     method incr_from_iter iter : incr =
-      let v = model#get ~row:iter ~column:feature in
-      Hashtbl.find h_incr v
+      self#incr_from_path (model#get_path iter)
 
-    method incr_from_path path : incr =
-      self#incr_from_iter (model#get_iter path)
+    method ext_from_path path : Ext.t =
+      (self#incr_from_path path)#ext
+
+    method feature_from_path path : string =
+      match model#custom_get_iter path with
+	| None -> failwith "Gui.tree_features#feature_from_path"
+	| Some iter -> model#get_feature iter
 
     method spec_from_path path : Lisql.Feature.spec =
-      let i = self#incr_from_path path in
-      i#spec
+      (self#incr_from_path path)#spec
 
     method spec_from_iter iter : Lisql.Feature.spec =
-      let i = self#incr_from_iter iter in
-      i#spec
+      (self#incr_from_iter iter)#spec
 
     method state_view = history # current # get_view v
 
 	sv
 
 (*
-   method is_strict_empty path =
-   let c = model#get ~row:(model#get_iter path) ~column:count in
-   c < history # current # extent # nbobj, c = 0
- *)
-
     method private row_color_from_incr i =
       if not check_feat_color#active
       then str_black
       then 400
       else 200
 
-(*
-   method private count_color_from_incr i =
-   if not check_count_color#active
-   then str_white
-   else i#color
- *)
-
     method private lift_label_from_incr i =
       (* Printf.sprintf "%d%%" (int_of_float (i#lift *. 100.)) *)
       if not check_lift#active
 	| Some oids ->
 	    let inter = Ext.inter oids e in
 	    color_of_ratio (Ext.cardinal inter) (Ext.cardinal oids)
+*)
 
     method selected_paths = view # selection # get_selected_rows
 
       let fs = List.map (fun path -> self # incr_from_path path) paths in
       cb_copy := Features fs
 
-    method private refresh_function_iter iter (s : string) : unit =
+(*
+    method private refresh_function_iter iter (s : string) : unit = Common.prof "Gui.tree_features#refresh_function_iter" (fun () ->
       model#set ~row:iter ~column:feature s;
       model#set ~row:iter ~column:markup s;
       model#set ~row:iter ~column:count "";
       model#set ~row:iter ~column:row_scale 1.;
       model#set ~row:iter ~column:row_weight 400;
       model#set ~row:iter ~column:bg_color str_white;
-      model#set ~row:iter ~column:thumb_file ""
+      model#set ~row:iter ~column:thumb_file "")
 (*
    for i = model#iter_n_children (Some iter) - 1 downto 0 do
    ignore (model#remove (model#iter_children ~nth:i (Some iter)))
    done
  *)
 
-    method private refresh_tree_iter iter i : unit = Common.prof "refresh_tree_iter" (fun () ->
-      Hashtbl.replace h_incr i#string i;
-      model#set ~row:iter ~column:feature i#string;
+    method private refresh_tree_iter iter i : unit = Common.prof "Gui.tree_features#refresh_tree_iter" (fun () ->
+      let s = i#string in
+      Hashtbl.replace h_incr s i;
+      model#set ~row:iter ~column:feature s;
       model#set ~row:iter ~column:markup (make_markup (i#display ~obs:Tarpit.blind_observer));
 (*	  model#set ~row:iter ~column:incr i; *)
       model#set ~row:iter ~column:count (string_of_int i#supp);
       Common.prof "Gui.tree_features#refresh" (fun () ->
 	view#selection#unselect_all ();
 	let i = get_incr () in
-	view#misc#freeze_notify ();
+(*	view#misc#freeze_notify (); *)
 	view#set_model None;
 	self#refresh_view force None i (history#current#get_view i#spec);
-	view#set_model (Some (model :> GTree.model));
-	view#misc#thaw_notify ())
+	view#set_model (Some (model :> GTree.model)))
+(*	view#misc#thaw_notify ()) *)
+*)
 
-    method refresh_preselect unselect =
+    method refresh (force : bool) =
+      Common.prof "Gui.tree_features#refresh" (fun () ->
+	view#selection#unselect_all ();
+	let new_model = new custom_tree (get_incr ()) cols in
+	model <- new_model;
+	view#set_model (Some (new_model :> GTree.model)))
+
+    method refresh_preselect unselect = ()
+(*
       if unselect && view#selection#get_selected_rows <> [] then begin
 	ignore_selection_changed <- true;
 	view#selection#unselect_all ()
 	  (fun path iter ->
 	    model#set ~row:iter ~column:bg_color str_white;
 	    false)
+*)
 
     method expand_row path =
+(*
       let i = self # incr_from_path path in
       let sv = self # state_view_from_path path in
       self # refresh_view false (Some (model#get_iter path)) i sv;
+*)
       view # expand_row path
 
     method collapse_row path =
+(*
       let v = self # spec_from_path path in
       let views = history # current # views in
       (try (Hashtbl.find views v) # set_expanded false with Not_found -> ());
+*)
       view # collapse_row path
 
+(*
     method page_top parent_opt =
       let v = Common.fold_option self#spec_from_iter v parent_opt in
       let sv = Hashtbl.find history#current#views v in
       match parent_opt with
       | None -> self # refresh false
       | Some iter -> self#refresh_view false (Some iter) (self#incr_from_iter iter) sv
+*)
 
     initializer
+(*      model#set_sort_column_id GTree.unsorted_sort_column_id `DESCENDING; *)
       view#selection#set_mode `MULTIPLE;
       col_lift#set_sizing `AUTOSIZE;
 (*
     method mem_persistent_widget w = List.exists (fun w1 -> w#misc#get_oid = w1#misc#get_oid) persistent_widgets
     method clean_persistent_widgets = persistent_widgets <- []
 
-    method refresh =
+    method refresh = Common.prof "Gui.list_answers#refresh" (fun () ->
       answers <- history#current#place#answers;
       ignore (answers#page_top);
-      self#refresh_aux
+      self#refresh_aux)
 
     method private refresh_aux =
       List.iter ~f:sw#remove sw#children;