Commits

Sébastien Ferré  committed 0475a3f

increments represented by objects instead of records.

  • Participants
  • Parent commits 4749ba0

Comments (0)

Files changed (2)

 let str_color_property = str_darkviolet
 let str_color_functor = str_darkcyan
 
+type cb_copy =
+  | Nothing
+  | Features of Lisql.AST.p1 list
+  | Objects of Ext.t
+
+let cb_copy : cb_copy ref = ref Nothing (* clipboard of object ids for copy, paste, ... *)
 
 type id_view = Lisql.AST.p1
 
 
-type lift = {
-    lift_supp : int;
-    lift_scale : float;
-    lift_color : string;
-  }
-
-type incr = {
-    incr_view : id_view; (* the increment logical expression itself *)
-    incr_kind : Lisql.increment_kind; (* the increment kind *)
-    incr_string : string; (* the string representation *)
-    incr_preview : string; (* the preview string *)
-    incr_nameroot : bool; (* whether the increment contains '@' *)
-    incr_anew : bool; (* whether the increment is new compared to smaller ranks *)
-    incr_lift : lift;    (* lift of feature w.r.t. query *)
-    incr_supp : int;    (* support of feature in query *)
-    incr_scale : float; (* scale representing support/query *)
-    incr_color : string; (* grey-level equivalent to scale *)
-    incr_ext : Ext.t;   (* coverage of feature in query *)
-    incr_uri_opt : Uri.t option; (* the URI that the increments possibly contains *)
-    incr_pagerank : float; (* the pagerank of the main resource of the increment *)
-  }
+let expected_supp nbo nbq nbx = (nbx * nbq) / nbo
+
+let scale_of_ratio n m =
+  let max_scale = 1.5 in
+  let min_scale = 0.8 in
+  min_scale +.
+    (max_scale -. min_scale) *.
+    log10 (float_of_int (2 + n)) /. log10 (float_of_int (2 + m))
+    
+let color_of_ratio n m = (* assuming 0 <= n <= m *)
+  let max_intensity = 65535. in
+  let min_intensity = 16000. in
+  let rgb = int_of_float (
+    if m = 0 then max_intensity
+    else if n = 0 then min_intensity
+    else
+      min_intensity +.
+	(max_intensity -. min_intensity) *.
+	log10 (float_of_int (2 * n)) /. log10 (float_of_int (2 * m))) in
+  str_color_of_rgb (rgb,rgb,rgb) (* Gdk.Color.alloc ~colormap (`RGB (rgb,rgb,rgb)) *)
+
+
+class lift nbo nbq nbx nbqx =
+  object
+    val supp : int = nbx
+    method supp = supp
+
+    val scale = scale_of_ratio nbqx nbx
+    method scale = scale
+
+    val color = color_of_ratio nbqx nbx
+    method color = color
+  end
+let make_lift nbo nbq nbx nbqx = new lift nbo nbq nbx nbqx
+
+class incr (increment : Lisql.increment) (nbobj : int) (nbsel : int) =
+  object
+    method view = increment#log
+    method kind = increment#kind
+    method string = increment#string
+    method preview = increment#preview
+    method nameroot = increment#nameroot
+    method anew = increment#anew
+    method supp = increment#supp
+    method ext = increment#ext
+    method uri_opt = increment#uri_opt
+    method pagerank = increment#pagerank
+    
+    val lift = make_lift nbobj nbsel increment#card increment#supp
+    method lift = lift
+
+    val scale = scale_of_ratio increment#supp nbsel
+    method scale = scale
+
+    val color = color_of_ratio increment#supp nbsel
+    method color = color
+  end
+let make_incr i nbobj nbsel = new incr i nbobj nbsel
 
 type links_sort_fun = incr -> incr -> int
 let sort_by_count i i' =
-  Common.compare_pair (Pervasives.compare, Lisql.AST.compare_p1) (i'.incr_supp, i.incr_view) (i.incr_supp, i'.incr_view)
+  Common.compare_pair (Pervasives.compare, Lisql.AST.compare_p1) (i'#supp, i#view) (i#supp, i'#view)
 let sort_by_feature i i' =
-  Common.compare_pair (Lisql.AST.compare_p1, Pervasives.compare) (i.incr_view, i'.incr_supp) (i'.incr_view, i.incr_supp)
+  Common.compare_pair (Lisql.AST.compare_p1, Pervasives.compare) (i#view, i'#supp) (i'#view, i#supp)
 let sort_by_pagerank i i' =
   Common.compare_pair (Pervasives.compare, Common.compare_pair (Pervasives.compare, Lisql.AST.compare_p1))
-    (i.incr_kind, (i'.incr_pagerank, i.incr_view)) (i'.incr_kind, (i.incr_pagerank, i'.incr_view))
+    (i#kind, (i'#pagerank, i#view)) (i'#kind, (i#pagerank, i'#view))
 
 
-type cb_copy =
-  | Nothing
-  | Features of Lisql.AST.p1 list
-  | Objects of Ext.t
-
-let cb_copy : cb_copy ref = ref Nothing (* clipboard of object ids for copy, paste, ... *)
-
 let all_ext_colors, last_ext_color =
 (*      let splits = [| 0; 16; 8; 24; 4; 12; 20; 28; 2; 6; 10; 14; 18; 22; 26; 30;
    1; 3; 5; 7; 9; 11; 13; 15; 17; 19; 21; 23; 25; 27; 29; 31 |] in *)
 	match links_opt with
 	| None -> assert false
 	| Some l ->
-	    List.iter (fun i -> if not i.incr_nameroot then ext_colors # incr_ext_count i.incr_ext) l end
+	    List.iter (fun i -> if not i#nameroot then ext_colors # incr_ext_count i#ext) l end
       else if expanded && not b
       then begin
 	match links_opt with
 	| None -> assert false
 	| Some l ->
-	    List.iter (fun i -> if not i.incr_nameroot then ext_colors # decr_ext_count i.incr_ext) l
+	    List.iter (fun i -> if not i#nameroot then ext_colors # decr_ext_count i#ext) l
       end;
       expanded <- b
 
 	( match links_opt with
 	| None -> ()
 	| Some l_old ->
-	    List.iter (fun i -> if not i.incr_nameroot then ext_colors # decr_ext_count i.incr_ext) l_old);
+	    List.iter (fun i -> if not i#nameroot then ext_colors # decr_ext_count i#ext) l_old);
 	(match l with
 	| None -> ()
 	| Some l_new ->
-	    List.iter (fun i -> if not i.incr_nameroot then ext_colors # incr_ext_count i.incr_ext) l_new)
+	    List.iter (fun i -> if not i#nameroot then ext_colors # incr_ext_count i#ext) l_new)
       end;
       links_opt <- l
 
 let picture_of_name ~obs name =
   history#store#get_image ~obs name
 
-let expected_supp nbo nbq nbx = (nbx * nbq) / nbo
-
-let scale_of_ratio n m =
-  let max_scale = 1.5 in
-  let min_scale = 0.8 in
-  min_scale +.
-    (max_scale -. min_scale) *.
-    log10 (float_of_int (2 + n)) /. log10 (float_of_int (2 + m))
-    
-let color_of_ratio n m = (* assuming 0 <= n <= m *)
-  let max_intensity = 65535. in
-  let min_intensity = 16000. in
-  let rgb = int_of_float (
-    if m = 0 then max_intensity
-    else if n = 0 then min_intensity
-    else
-      min_intensity +.
-	(max_intensity -. min_intensity) *.
-	log10 (float_of_int (2 * n)) /. log10 (float_of_int (2 * m))) in
-  str_color_of_rgb (rgb,rgb,rgb) (* Gdk.Color.alloc ~colormap (`RGB (rgb,rgb,rgb)) *)
-
-
-let lift nbo nbq nbx nbqx = 
-  (* float_of_int nbo *. float_of_int nbqx /. float_of_int nbq /. float_of_int nbx *) (* lift *)
-  (*
-     if nbx = 0
-     then 1.
-     else float_of_int nbqx /. float_of_int nbx
-   *) (* anti-proportion *)
-  { lift_supp = nbx;
-    lift_scale = scale_of_ratio nbqx nbx;
-    lift_color = color_of_ratio nbqx nbx
-      (* begin
-	 let nbo, nbq, nbx, nbqx = float_of_int nbo, float_of_int nbq, float_of_int nbx, float_of_int nbqx in
-	 let base = 10000. in
-	 let marge = 65535. -. base in
-	 if nbqx /. nbx >= nbq /. nbo
-	 then (* positive lift -> green *)
-	 let p = (nbo *. nbqx -. nbx *. nbq) /. nbx /. (nbo -. nbq) in (* in 0..1 *)
-	 let rb = int_of_float (base +. marge *. (1. -. p)) in
-	 str_color_of_rgb (rb,65535,rb) (* Gdk.Color.alloc ~colormap (`RGB (rb,65535,rb)) *)
-	 else (* negative lift -> red *)
-	 let p = (nbx *. nbq -. nbo *. nbqx) /. nbx /. nbq in
-	 let gb = int_of_float (base +. marge *. (1. -. p)) in
-	 str_color_of_rgb (65535,gb,gb) (* Gdk.Color.alloc ~colormap (`RGB (65535,gb,gb)) *)
-	 end *)
-      (* begin
-	 let base = 20000. in
-	 let marge = 65535. -. base in
-	 let p = if nbx = 0 then 0. else float_of_int nbqx /. float_of_int nbx in
-	 let rgb = int_of_float (base +. marge *. p) in
-	 str_color_of_rgb (rgb,rgb,rgb) (* Gdk.Color.alloc ~colormap (`RGB (rgb,rgb,rgb)) *)
-	 end *)
-  }
-
 let get_incr ~obs (i0 : incr) : incr option =
-  let x = i0.incr_view in
+  let x = i0#view in
   Option.map
     (fun p ->
-      { i0 with
-	incr_preview = preview_of_view ~obs x;
-	incr_lift = { i0.incr_lift with
-		      lift_supp = p.Lisql.propr_card};
-	incr_supp = p.Lisql.propr_supp;
-	incr_ext = p.Lisql.propr_ext;
-	incr_anew = p.Lisql.propr_anew;
-      })
+      let nbsel = history#current#extents#current#nbobj in
+      let nbobj = Ext.cardinal (history#store#extent_all ~obs) in
+      make_incr p nbobj nbsel)
     (history#current#extents#current#increment ~obs x)
 
 let rec ls ~obs sv (v : id_view) : incr list = Common.prof "ls" (fun () ->
   let nbsel = history#current#extents#current#nbobj in
   let nbobj = Ext.cardinal (history#store#extent_all ~obs) in
   let incrs : incr list =
-    List.fold_left
-      ~f:(fun res p ->
-	let lift = lift nbobj nbsel p.Lisql.propr_card p.Lisql.propr_supp in
-	let scale = scale_of_ratio p.Lisql.propr_supp nbsel in
-	let color = color_of_ratio p.Lisql.propr_supp nbsel in
-	let log = p.Lisql.propr_log in
-	let i = { incr_view = log;
-		  incr_kind = Lisql.kind_of_increment log;
-		  incr_string = Lisql.Syntax.string_of_class log;
-		  incr_preview = preview_of_view ~obs log;
-		  incr_nameroot = p.Lisql.propr_nameroot;
-		  incr_anew = p.Lisql.propr_anew;
-		  incr_lift = lift;
-		  incr_supp = p.Lisql.propr_supp;
-		  incr_scale = scale;
-		  incr_color = color;
-		  incr_ext = p.Lisql.propr_ext;
-		  incr_uri_opt = Lisql.uri_of_increment log;
-		  incr_pagerank = Lisql.pagerank_of_increment history#store log;
-		} in
-	i::res)
-      ~init:[]
-      proprs in
+    List.rev_map ~f:(fun p -> make_incr p nbobj nbsel) proprs in
   let incrs1 : incr list =
     if v = Lisql.AST.NameRoot || sv#suppmin_opt <> None
     then incrs
     else
       let incrs =
 	List.sort
-	  ~cmp:(fun i1 i2 -> Pervasives.compare (i2.incr_supp,i2.incr_lift.lift_supp) (i1.incr_supp,i1.incr_lift.lift_supp))
+	  ~cmp:(fun i1 i2 -> Pervasives.compare (i2#supp,i2#lift#supp) (i1#supp,i1#lift#supp))
 	  incrs in
       let _, _, incrs1, _ =
 	Common.fold_while
 	    match incrs with
 	    | [] -> None
 	    | i::incrs' ->
-		let supp_card' = (i.incr_supp,i.incr_lift.lift_supp) in
+		let supp_card' = (i#supp,i#lift#supp) in
 		if n1 < sv#links_page_size || supp_card' >= supp_card
 		then Some (incrs', n1+1, i::incrs1, supp_card')
 		else None)
 
     method ext_from_path path : Ext.t =
       let i = self#incr_from_path path in
-      i.incr_ext
+      i#ext
 
     method preview_from_path path : string =
       model#get ~row:(model#get_iter path) ~column:preview
 
     method class_from_path path : Lisql.AST.p1 =
       let i = self#incr_from_path path in
-      i.incr_view
+      i#view
 
     method class_from_iter iter : Lisql.AST.p1 =
       let i = self#incr_from_iter iter in
-      i.incr_view
+      i#view
 
     method state_view = history # current # get_view v
 
       then str_black
       else
 	let open Lisql in
-	match kind_of_increment i.incr_view with
+	match i#kind with
 	| Incr_Variable -> str_color_variable
 	| Incr_Entity -> str_color_entity
 	| Incr_Literal -> str_color_literal
     method private row_scale_from_incr i =
       if not check_scale#active
       then 1.
-      else i.incr_scale
+      else i#scale
 
     method private row_weight_from_incr i =
-      if i.incr_anew
+      if i#anew
       then 400
       else 200
 
    method private count_color_from_incr i =
    if not check_count_color#active
    then str_white
-   else i.incr_color
+   else i#color
  *)
 
     method private lift_label_from_incr i =
-      (* Printf.sprintf "%d%%" (int_of_float (i.incr_lift *. 100.)) *)
+      (* Printf.sprintf "%d%%" (int_of_float (i#lift *. 100.)) *)
       if not check_lift#active
       then " "
-      else string_of_int i.incr_lift.lift_supp
+      else string_of_int i#lift#supp
 
     method private lift_scale_from_incr i =
       if not check_scale#active
       then 1.
-      else i.incr_lift.lift_scale
+      else i#lift#scale
 
     method private lift_color_from_incr i =
       if not check_lift_color#active
       then str_white
-      else i.incr_lift.lift_color
+      else i#lift#color
 
     method private lift_fg_color_from_incr i =
-      if true || not check_lift_color#active || i.incr_scale >= i.incr_lift.lift_scale
+      if true || not check_lift_color#active || i#scale >= i#lift#scale
       then str_black
       else str_white
 
  *)
 
     method private refresh_tree_iter iter i : unit = Common.prof "refresh_tree_iter" (fun () ->
-      Hashtbl.replace h_incr i.incr_string i;
-      model#set ~row:iter ~column:feature i.incr_string;
-      model#set ~row:iter ~column:preview i.incr_preview;
+      Hashtbl.replace h_incr i#string i;
+      model#set ~row:iter ~column:feature i#string;
+      model#set ~row:iter ~column:preview i#preview;
 (*	  model#set ~row:iter ~column:incr i; *)
-      model#set ~row:iter ~column:count (string_of_int i.incr_supp);
+      model#set ~row:iter ~column:count (string_of_int i#supp);
       model#set ~row:iter ~column:lift_label (self # lift_label_from_incr i);
       model#set ~row:iter ~column:lift_color (self # lift_color_from_incr i);
       model#set ~row:iter ~column:row_color (self # row_color_from_incr i);
       model#set ~row:iter ~column:row_scale (self # row_scale_from_incr i);
       model#set ~row:iter ~column:row_weight (self # row_weight_from_incr i);
-      model#set ~row:iter ~column:bg_color (self # bg_color_from_ext history#current#int_preselect i.incr_ext);
+      model#set ~row:iter ~column:bg_color (self # bg_color_from_ext history#current#int_preselect i#ext);
       model#set ~row:iter ~column:thumb_file
-	( match i.incr_uri_opt with
+	( match i#uri_opt with
 	| None -> ""
 	| Some uri ->
 	    match picture_of_name ~obs:Tarpit.blind_observer (Rdf.URI uri) with
 	  self#expand_view false true tree_iter path i
 
     method refresh_view force parent_opt i sv = Common.prof "Gui.tree_features#refresh_view" (fun () ->
-      let v = i.incr_view in
+      let v = i#view in
       let page_start, page_size = sv#links_page_start, sv#links_page_size in
       let incrs = ls_opt ~obs:Tarpit.blind_observer force sv v in
       let nb_incrs = List.length incrs in
 	  else function_up);
       List.iter
 	(fun i ->
-	  if i.incr_nameroot
+	  if i#nameroot
 	  then begin
 	    multi_tree#add_tab i end
 	  else begin
       done)
 
     method private expand_view expd force tree_iter path i = Common.prof "Gui.tree_features#expand_view" (fun () ->
-      let v = i.incr_view in
+      let v = i#view in
       model#set ~row:(model#append ~parent:tree_iter ()) ~column:preview "";
       let st = history # current in
       let views = st # views in
       Common.prof "Gui.tree_features#refresh" (fun () ->
 	view#selection#unselect_all ();
 	self#refresh_view force None
-	  { incr_view = v;
-	    incr_kind = Lisql.kind_of_increment v;
-	    incr_string = Lisql.Syntax.string_of_class v;
-	    incr_preview = preview_of_view ~obs:Tarpit.blind_observer v;
-	    incr_nameroot = Lisql.increment_contains_nameroot v; (* default *)
-	    incr_anew = true;
-	    incr_lift = {lift_supp = -1; lift_scale = 1.; lift_color = str_white};
-	    incr_supp = -1;
-	    incr_scale = 1.;
-	    incr_color = str_white;
-	    incr_ext = Ext.empty;
-	    incr_uri_opt = None;
-	    incr_pagerank = 1.;
-	  } (* the -1 means undefined *)
-	  (history # current # get_view v))
+	  (make_incr (Lisql.make_increment ~obs:Tarpit.blind_observer history#store 0 Ext.empty v Ext.empty true) 0 0)
+	  (history#current#get_view v))
 
     method refresh_preselect unselect =
       if unselect && view#selection#get_selected_rows <> [] then begin
 	model # foreach
 	  (fun path iter ->
 	    let e : Ext.t =
-	      try (self#incr_from_iter iter).incr_ext
+	      try (self#incr_from_iter iter)#ext
 	      with exn -> Ext.empty in (* mystery: fails with exception, but [e] has the right value ! *)
 	    model#set ~row:iter ~column:bg_color (self # bg_color_from_ext int_preselect e);
 	    false)
 		let current = history#current in
 		let extents = current#extents in
 		let incr = self#incr_from_iter iter in
-		if incr.incr_supp = extents#current#nbobj
+		if incr#supp = extents#current#nbobj
 		then
 		  if extents#rank = 0 then str_color_query else str_color_update
 		else
-		  try current#ext_colors#get_ext_color incr.incr_ext
+		  try current#ext_colors#get_ext_color incr#ext
 		  with _ -> str_white
 	      with _ -> str_white
 	    else str_white in
     method collapse_row = self # current # collapse_row
 
     method add_tab i =
-      let v = i.incr_view in
-      let s = i.incr_string in
-      let s_rel = i.incr_preview in
+      let v = i#view in
+      let s = i#string in
+      let s_rel = i#preview in
       try
 	let pos = Hashtbl.find ht_page v in
 	nb#goto_page pos

File src/lisql.ml

     store#get_pagerank name
   with Not_found -> 0.
 
+let rec increment_contains_nameroot = function
+  | NameRoot -> true
+  | Name _ -> false
+  | Type _ -> false
+  | Role (_, Qu (Exists, f1)) -> increment_contains_nameroot f1
+  | Pred (r, pred, fargs) -> List.exists (fun (_,farg) -> increment_contains_nameroot farg) fargs
+  | _ -> false
+
+class increment ~obs store (i : int) (inter : Ext.t) (x : p1) (ext_x : Ext.t) (anew : bool) =
+  object
+    val card : int = Ext.cardinal ext_x
+    method card = card
+
+    val supp : int = i
+    method supp = supp
+
+    val ext : Ext.t = inter
+    method ext = ext
+
+    val log : p1 = x
+    method log = log
+
+    val nameroot : bool = increment_contains_nameroot x
+    method nameroot = nameroot
+
+    val anew : bool = anew
+    method anew = anew
+
+    val kind = kind_of_increment x
+    method kind = kind
+
+    val string : string = Syntax.string_of_class x
+    method string = string
+
+    val preview =
+      if x = NameRoot
+      then Pretty.print_to_string_indent (store#preview_class ~obs ~focus:None) x
+      else Pretty.print_to_string_indent (store#preview_relative_class ~obs) x
+    method preview = preview
+
+    val uri_opt = uri_of_increment x
+    method uri_opt = uri_opt
+
+    val pagerank = pagerank_of_increment store x
+    method pagerank = pagerank
+  end
+let make_increment ~obs store i inter x ext_x anew = new increment ~obs store i inter x ext_x anew
+
 
 let name_incr_limit = max_int
     
   else Pred (r1, pred, [(r,q_facet)]), None
 
 
-let rec increment_contains_nameroot = function
-  | NameRoot -> true
-  | Name _ -> false
-  | Type _ -> false
-  | Role (_, Qu (Exists, f1)) -> increment_contains_nameroot f1
-  | Pred (r, pred, fargs) -> List.exists (fun (_,farg) -> increment_contains_nameroot farg) fargs
-  | _ -> false
-
-
-type propr = {
-    propr_card : int;
-    propr_supp : int;
-    propr_ext : Ext.t;
-    propr_log : p1;
-    propr_nameroot : bool;
-    propr_anew : bool;
-  }
-
-let make_propr i inter x ext_x anew =
-  { propr_card = Ext.cardinal ext_x;
-    propr_supp = i;
-    propr_ext = inter;
-    propr_log = x;
-    propr_nameroot = increment_contains_nameroot x;
-    propr_anew = anew;
-  }
-
 let increment ~obs store place current_extent ?(suppmin : int = 1) x =
   match x with
   | Name name ->
 	    (fun ext_less -> not (Concept.overlap_oids ext_less ext_oid))
 	    true
 	    current_extent#previous_extent in
-	Some (make_propr 1 ext_oid x ext_oid anew)
+	Some (make_increment ~obs store 1 ext_oid x ext_oid anew)
   | NameRoot -> None
   | Var v ->
       ( match Concept.inter_var ~obs store ~suppmin place#intent v with
-      | Some (i,inter) -> Some (make_propr i inter x (store#extent_all ~obs) true)
+      | Some (i,inter) -> Some (make_increment ~obs store i inter x (store#extent_all ~obs) true)
       | None ->
 	  if current_extent#previous_extent <> None (* to make variables in updates accessible *)
-	  then Some (make_propr 0 Ext.empty x (store#extent_all ~obs) true)
+	  then Some (make_increment ~obs store 0 Ext.empty x (store#extent_all ~obs) true)
 	  else None)
   | _ ->
       let ext_place = current_extent#extent in
 	      (fun ext_less -> not (Concept.overlap_oids ext_less ext_x))
 	      true
 	      current_extent#previous_extent in
-	  Some (make_propr i inter x ext_x anew)
+	  Some (make_increment ~obs store i inter x ext_x anew)
 
-let increments ~obs store place current_extent ?(suppmin : int = 1) (v : p1) : propr list =
+let increments ~obs store place current_extent ?(suppmin : int = 1) (v : p1) : increment list =
   Common.prof "Lisql.increments" (fun () ->
     if v = NameRoot
     then Common.prof "Lisql.increments/NameRoot" (fun () ->
 	      (fun ext_less -> not (Concept.overlap_oids ext_less inter))
 	      true
 	      current_extent#previous_extent in
-	  make_propr (Ext.cardinal inter) inter x inter anew :: res)
+	  make_increment ~obs store (Ext.cardinal inter) inter x inter anew :: res)
 	h [])
 (*
       let _, res =
     method oids = oids
     method nbobj : int = nbobj
 
-    method increment ~obs x : propr option =
+    method increment ~obs x : increment option =
       increment ~obs store place self x
 
-    val h_proprs : (p1, propr list Tarpit.view) Hashtbl.t = Hashtbl.create 13
-    method increments ~obs ?suppmin (v : p1) : propr list =
+    val h_proprs : (p1, increment list Tarpit.view) Hashtbl.t = Hashtbl.create 13
+    method increments ~obs ?suppmin (v : p1) : increment list =
       try (Hashtbl.find h_proprs v)#contents ~obs
       with Not_found ->
 	let view = new Tarpit.view in