Commits

Sébastien Ferré committed 1d67300

A few bug fixes (retract) and improvements (display, ordering, ...)

Comments (0)

Files changed (7)

 	  code_fol_prop ~obs store mode vars p2
       | Prop.Not p1 ->
 	  if mode = Assert
-	  then code_fol_prop ~obs store Assert vars p1
-	  else
+	  then
 	    let vars1, e = extension_of_fol ~obs store vars p1 in
 	    let lc = code_fol_prop ~obs store Retract vars1 p1 in
 	    [Code.foreach e lc]
+	  else invalid_arg "Ambiguous update: retracting a negation"
       | Prop.Cond (Cond p0,p1,p2_opt) ->
 	  let _vars1, ext0 = extension_of_fol ~obs store vars p0 in
 	  let lc1 = code_fol_prop ~obs store mode vars p1 in
 let filter_log = "*.log"
 let filter_jpg = "*.jpg"
 
+let weight_normal = Pango.Tags.weight_to_int `NORMAL
+let weight_new = Pango.Tags.weight_to_int `BOLD
+
 let str_white = "white"
 let str_black = "black"
 let str_lightgrey = "lightgrey"
     method name_opt = increment#name_opt
     method p1_opt = increment#p1_opt
     method lisql_opt = increment#lisql_opt
-    method pagerank = increment#pagerank
+(*    method pagerank = increment#pagerank *)
 (*    method children = (*increment#children*) *)
     
     val lift = make_lift nbq (*increment#card*) nbqx nbqx
   end
 let make_incr i = new incr i
 
-type links_sort_fun = incr -> incr -> int
+type links_sort_fun = Lisql.Concept.increment -> Lisql.Concept.increment -> int
 let sort_by_count i i' =
   Common.compare_pair (Pervasives.compare, Pervasives.compare) (i'#supp, i#spec) (i#supp, i'#spec)
 let sort_by_name i i' =
   Common.compare_pair (Pervasives.compare, Pervasives.compare) (i#spec, i'#supp) (i'#spec, i#supp)
 let sort_by_feature i i' =
-  Lisql.Feature.compare i#feature i'#feature
+  Lisql.Feature.compare i i'
 
 type cb_copy =
   | Nothing
     val view = v
     val mutable expanded : bool = false
     val mutable links_sort_fun : links_sort_fun = sort_by_feature
-    val mutable links_page_start : int = 1 (* first page *)
-    val mutable links_page_size : int = default_links_page_size (*  use max_int for no limit *)
+    val mutable links_page_start : int = 0 (* offset *)
+    val mutable links_page_size : int = default_links_page_size (* limit, use max_int for no limit *)
 
     method view = view
     method expanded = expanded
 
     method copy (v : id_view) =
       {< view = v;
-	 links_page_start = 1>}
+	 links_page_start = 0>}
   end
 
 class state store (foc : Lisql.AST.focus) = 
 let picture_of_name ~obs name =
   history#store#get_image ~obs name
 
+(* deprecated *)
+(*
 let rec ls ~obs sv (incr : incr) : incr list = Common.prof "ls" (fun () ->
   let proprs = history#current#place#children_increments incr#increment in
   let incrs : incr list =
   else match sv#links_opt with
   | Some links -> links
   | None -> assert false
+*)
 
 (* building the interface *)
 
   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 view = history#current#get_view parent_incr#spec in
     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 increments = List.sort ~cmp:view#links_sort_fun increments in
+    let sub_increments = Common.sub_list increments view#links_page_start view#links_page_size 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
     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
+    then weight_new
+    else weight_normal
+  method get_bg_color (row : custom_iter) =
+    str_white
   method get_thumb_file (row : custom_iter) = 
     match row.incr#uri_opt with
       | None -> ""
       GTree.view_column ~title:"Feature" ()
 	~renderer:(cell_feature, ["markup",markup]) in
     col # add_attribute cell_feature "scale" row_scale;
-(*    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 `AUTOSIZE;
       view#drag#dest_set ~actions:[`MOVE]
 	[ { Gtk.target = "STRING"; Gtk.flags = []; Gtk.info = 0} ];
       view#drag#connect#data_received ~callback:(fun context ~x ~y sel ~info ~time ->
+	GtkSignal.stop_emit ();
 	begin try
 	  view#selection#unselect_all ();
 	  ( match view#get_path_at_pos ~x ~y with
 	  callbacks # data_received ()
 	with _ -> () end;
 	context#finish ~success:true ~del:false ~time);
+      view#drag#connect#data_delete ~callback:(fun context ->
+	GtkSignal.stop_emit ());
       ()
   end
 
 
   let re_var = Str.regexp "^[?]\\([^ \t].*\\)$" in
   let re_a = Str.regexp "^[ \t]*an?[ \t]+\\([^?]*[^ \t]\\)[ \t]*$" in
-  let re_fwd = Str.regexp "^[ \t]*\\([^?]*[^ \t]\\)[ \t]+:[ \t?]*$" in
-  let re_bwd = Str.regexp "^[ \t]*\\([^?]*[^ \t]\\)[ \t]+of[ \t?]*$" in
+  let re_fwd = Str.regexp "^[ \t]*has[ \t]+\\([^?]*[^ \t]\\)[ \t?]*$" in
+  let re_bwd = Str.regexp "^[ \t]*is[ \t]+\\([^?]*[^ \t]\\)[ \t]+of[ \t?]*$" in
   let re_text = Str.regexp "^[ \t]*[\"]\\(.*\\)$" in
   let re_funct = Str.regexp "^[ \t]*\\([^(]+\\)(" in
   let re_funct_intransitive = Str.regexp "^[ \t]*\\([^?]*[^? \t]\\)[ \t]+with[ \t?]*$" in

src/lisql_concept.ml

 
 let is_empty_supp (i,n) = i = 0
 
-class virtual increment ~supp ~anew = 
+class virtual increment ~supp ~anew =
   object (self)
     inherit Feature.feature
     method supp : supp = supp
   let get_count_anew rank total card =
     let c = total * card in
     let count = if rank = 0 then c else total in
-    let anew = rank = 0 || c = 0 in
+    let anew = rank > 0 && c = 0 in
     count, anew
   in
   object (self)
 		  then res
 		  else
 		    new increment_type ~obs store self rank c ~supp:(count,total) ~anew ::
-		    operator_increments_from_class ~obs store self rank c ~supp:(count,total) ~anew:true @ 
+		    operator_increments_from_class ~obs store self rank c ~supp:(count,total) ~anew:false @ 
 		    res
 	      | _ -> res) [] @
 	  Semantics.fold_top_properties ~obs store
 	      match store#get_name c with
 	      | Rdf.URI uri_c when uri_c <> Rdfs.uri_Resource ->
 		  new increment_type ~obs store self rank uri_c ~supp:(count,total) ~anew ::
-		  operator_increments_from_class ~obs store self rank uri_c ~supp:(count,total) ~anew:true @
+		  operator_increments_from_class ~obs store self rank uri_c ~supp:(count,total) ~anew:false @
 		  res
 	      | _ -> res) [] @
 	  index_fwd_props#fold_children ~rank

src/lisql_display.ml

 let rec display_s ~obs store k prec s =
   [`Focus (AtS (s,k), display_s_aux ~obs store k prec s)]
 and display_s_aux ~obs store k prec = function
-  | Is (np,f) -> [`Pair (true,
+  | Is (np,f) -> [`Pair (false (*true*),
 			 display_s1 ~obs store (Is0 (np,f,k)) prec_or np,
 			 display_p1_vp ~obs store (Is1 (np,f,k)) prec_or f)]
   | True -> [`Kwd "true"]
 	  display_s2 ~obs store (Det0 (det,f,k)) head_opt det
       | [(kx,x)] ->
 	  [`Pair (true,
-		  display_s2 ~obs store (Det0 (det,f,k)) head_opt det @ [`Space; `Kwd "that"],
-		  display_p1_vp ~obs store kx prec_or x)]
+		  display_s2 ~obs store (Det0 (det,f,k)) head_opt det (*@ [`Space; `Kwd "that"]*),
+		  display_p1_rel ~obs store kx prec_or x)]
       | _ ->
 	  [`Pair (true,
-		  display_s2 ~obs store (Det0 (det,f,k)) head_opt det @ [`Space; `Kwd "that"],
-		  [`And (List.map (fun (kx,x) -> display_p1_vp ~obs store kx prec_and x) l)])] )
+		  display_s2 ~obs store (Det0 (det,f,k)) head_opt det (*@ [`Space; `Kwd "that"]*),
+		  [`And (List.map (fun (kx,x) -> display_p1_rel ~obs store kx prec_and x) l)])] )
   | NAnd l -> brackets_opt prec prec_and
 	[`And (List.map (fun (n,np1) -> display_s1 ~obs store (NAndN (n,l,k)) prec_not np1) (index_list l))]
   | NOr l -> brackets_opt prec prec_or
   | Every -> [`Kwd "every"]
   | Only -> [`Kwd "only the"]
   | No -> [`Kwd "no" ]
+and display_p1_rel ~obs store k prec f =
+  [`Focus (AtP1 (f,k), `Kwd "that" :: `Space :: display_p1_vp_aux ~obs store k prec f)]
 and display_p1_vp ~obs store k prec f =
   [`Focus (AtP1 (f,k), display_p1_vp_aux ~obs store k prec f)]
 and display_p1_vp_aux ~obs store k prec = function
-  | Type uri -> [`Kwd "a"; `Space; `URI (uri, `Class, string_of_uri ~obs store uri, image_of_uri ~obs store uri)]
+  | Type uri -> [`Kwd "is a"; `Space; `URI (uri, `Class, string_of_uri ~obs store uri, image_of_uri ~obs store uri)]
   | Role (r,np) -> [`Pair (false,
 			   display_p2 ~obs store (Role0 (r,np,k)) prec_or r,
 			   display_s1 ~obs store (Role1 (r,np,k)) prec_or np)]
     | Bwd -> [`Kwd "contained by"]
   else
     match string_of_uri_role ~obs store ori p with
-    | Fwd, s -> [`URI (p, `Property, s, None)]
+    | Fwd, s -> [`Kwd "has"; `Space; `URI (p, `Property, s, None)]
     | Bwd, s -> [`Kwd "is"; `Space; `URI (p, `Property, s, None); `Space; `Kwd "of"]
-(*
-  | RAtom (Fwd,p) -> `Kwd "has" :: `Space :: display_uri ~obs store `Property p
-  | RAtom (Bwd,p) -> `Kwd "is a" :: `Space :: display_uri ~obs store `Property p @ [`Space; `Kwd "of"]
-*)
 and display_struct_arg ~obs store k funct args arg_opt =
   [`Pair (false,
 	  [`URI (funct, `Functor, string_of_uri ~obs store funct, None);
     method newline_focus (foc : focus) = ()
   end
 
-let rec markup after_indent (ctx : markup_ctx) = function
+
+let rec markup after_indent(* not used*) (ctx : markup_ctx) = function
   | [] -> ()
   | tok::l -> markup_token after_indent ctx tok; List.iter (markup_token false ctx) l
 and markup_token after_indent ctx = function
       then begin markup false ctx toks1; ctx#space; markup false ctx toks2 end
       else begin markup false ctx toks1; markup true ctx#indent toks2 end
   | `Focus (foc,toks) ->
+      let short = is_short_display toks in
       ctx#open_focus foc;
-      if not after_indent
+      if short (*not after_indent*)
       then ctx#focus_space foc
       else ctx#focus_newline foc;
       markup false ctx toks;
       ctx#close_focus foc;
-      if not after_indent
+      if short (*not after_indent*)
       then ctx#space_focus foc
       else ctx#newline_focus foc

src/lisql_feature.ml

 	Display.to_string (self#display ~obs))
     method uri_opt : Uri.t option = None
     method prop_uri_opt : Uri.t option = None
-    method name_opt : Name.t option = None
+    method name_opt : Name.t option = match self#uri_opt with Some uri -> Some (Rdf.URI uri) | None -> None
     method p1_opt : p1 option = None
     method lisql_opt : (Name.t * s * focus) option = None
     method oids : obs:Tarpit.observer -> Ext.t = fun ~obs -> Ext.empty
   end
 
 let compare f1 f2 =
+  match f1#name_opt, f2#name_opt with
+    | Some n1, Some n2 ->
+      ( match n1, n2 with
+	| Rdf.URI _, Rdf.URI _ -> Pervasives.compare (f1#kind,f2#pagerank) (f2#kind,f1#pagerank)
+	| Rdf.Literal l1, Rdf.Literal l2 -> Name.compare_literal l1 l2
+	| _ -> Pervasives.compare f1#spec f2#spec )
+    | _ -> Pervasives.compare f1#spec f2#spec
+(*
   if f1#kind = f2#kind
   then
     match f1#kind with
     | _ -> Pervasives.compare f2#pagerank f1#pagerank (* decreasing page rank *)
   else
     Pervasives.compare f1#kind f2#kind
+*)
 
 class virtual feature_s1 store (np : s1) =
   object
       (* gYearMonth < gYear & gMonth *)
       (* gMonthDay < gMonth & gDay *)
 
-    let compare (n1 : t) (n2 : t) : int = 
-      match n1, n2 with
-      | Rdf.Literal (s1, Rdf.Typed dt1), Rdf.Literal (s2, Rdf.Typed dt2) ->
-	  if List.for_all (fun dt -> List.mem dt [Xsd.uri_integer; Xsd.uri_decimal; Xsd.uri_double]) [dt1;dt2]
-	  then
+    let compare_literal (l1 : Rdf.literal) (l2 : Rdf.literal) =
+      match l1, l2 with
+	| (s1, Rdf.Typed dt1), (s2, Rdf.Typed dt2) ->
+	  if List.for_all (fun dt -> List.mem dt [Xsd.uri_integer; Xsd.uri_decimal; Xsd.uri_double]) [dt1;dt2] then
 	    try Pervasives.compare (float_of_string s1) (float_of_string s2)
 	    with _ -> Pervasives.compare s1 s2
-	  else Pervasives.compare s1 s2
-      | _ -> Pervasives.compare n1 n2
+	  else
+	    Pervasives.compare s1 s2
+	| _ -> Pervasives.compare l1 l2
+
+    let compare (n1 : t) (n2 : t) : int = 
+      match n1, n2 with
+	| Rdf.Literal l1, Rdf.Literal l2 -> compare_literal l1 l2
+	| _ -> Pervasives.compare n1 n2
 
     let blank_id_prefix = "oid"
 
 	  | Rdf.URI _, Rdf.URI _ -> Pervasives.compare (self#get_pagerank n2) (self#get_pagerank n1)
 	  | Rdf.URI _, _ -> -1
 	  | _, Rdf.URI _ -> 1
+	  | Rdf.Literal l1, Rdf.Literal l2 -> Name.compare_literal l1 l2
 	  | _ -> Pervasives.compare n1 n2
 
 	method new_resource : Name.t = Common.prof "Store.store#new_resource" (fun () ->