X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fcomponents%2Ftactics%2Fparamodulation%2Fequality.ml;h=f449d437e91ddb192dfed685e263876af8b1454a;hb=373eac375c2950d0090cac177f44dbfb761389d5;hp=1bc87f8c54fd6e235b903a405e6422b7486ba62e;hpb=d924c0133e2ecd9b68f23eb00cb4230320f155df;p=helm.git

diff --git a/helm/software/components/tactics/paramodulation/equality.ml b/helm/software/components/tactics/paramodulation/equality.ml
index 1bc87f8c5..f449d437e 100644
--- a/helm/software/components/tactics/paramodulation/equality.ml
+++ b/helm/software/components/tactics/paramodulation/equality.ml
@@ -260,7 +260,7 @@ let open_pred pred =
   match pred with 
   | Cic.Lambda (_,_,(Cic.Appl [Cic.MutInd (uri, 0,_);ty;l;r])) 
      when LibraryObjects.is_eq_URI uri -> ty,uri,l,r
-  | _ -> prerr_endline (CicPp.ppterm pred); assert false   
+  | _ -> Utils.debug_print (lazy (CicPp.ppterm pred)); assert false   
 ;;
 
 let is_not_fixed t =
@@ -290,7 +290,7 @@ let canonical t context menv =
        [] -> List.rev acc
      | (l',p)::tl when l=l' -> 
 if acc <> [] then
-prerr_endline ("!!! RISPARMIO " ^ string_of_int (List.length acc) ^ " PASSI");
+Utils.debug_print (lazy ("!!! RISPARMIO " ^ string_of_int (List.length acc) ^ " PASSI"));
          cut_to_last_duplicate l [l',p] tl
      | (l',p)::tl ->
          cut_to_last_duplicate l ((l',p)::acc) tl
@@ -358,7 +358,7 @@ prerr_endline ("!!! RISPARMIO " ^ string_of_int (List.length acc) ^ " PASSI");
                    Cic.Const (LibraryObjects.eq_f_sym_URI ~eq, [])
                  in
                  let rc = Cic.Appl [eq_f_sym;ty1;ty2;f;x;y;p] in
-                 prerr_endline ("CANONICAL " ^ CicPp.ppterm rc);
+                 Utils.debug_print (lazy ("CANONICAL " ^ CicPp.ppterm rc));
                  rc
              | Cic.Appl [Cic.MutConstruct (uri, 0, 1,_);_;_] as t
                  when LibraryObjects.is_eq_URI uri -> t
@@ -371,12 +371,12 @@ prerr_endline ("!!! RISPARMIO " ^ string_of_int (List.length acc) ^ " PASSI");
   
 let compose_contexts ctx1 ctx2 = 
   ProofEngineReduction.replace_lifting 
-    ~equality:(=) ~what:[Cic.Implicit(Some `Hole)] ~with_what:[ctx2] ~where:ctx1
+  ~equality:(fun _ ->(=)) ~context:[] ~what:[Cic.Implicit(Some `Hole)] ~with_what:[ctx2] ~where:ctx1
 ;;
 
 let put_in_ctx ctx t = 
   ProofEngineReduction.replace_lifting
-    ~equality:(=) ~what:[Cic.Implicit (Some `Hole)] ~with_what:[t] ~where:ctx
+  ~equality:(fun _ -> (=)) ~context:[] ~what:[Cic.Implicit (Some `Hole)] ~with_what:[t] ~where:ctx
 ;;
 
 let mk_eq uri ty l r =
@@ -581,8 +581,9 @@ let parametrize_proof p l r =
   let p = CicSubstitution.lift (lift_no-1) p in
   let p = 
     ProofEngineReduction.replace_lifting
-    ~equality:(fun t1 t2 -> 
+    ~equality:(fun _ t1 t2 -> 
       match t1,t2 with Cic.Meta (i,_),Cic.Meta(j,_) -> i=j | _ -> false) 
+    ~context:[]
     ~what ~with_what ~where:p
   in
   let ty_of_m _ = Cic.Implicit (Some `Type) in
@@ -1025,7 +1026,6 @@ let meta_convertibility_eq eq1 eq2 =
         false
 ;;
 
-
 let meta_convertibility t1 t2 =
   if t1 = t2 then
     true
@@ -1037,6 +1037,32 @@ let meta_convertibility t1 t2 =
       false
 ;;
 
+let meta_convertibility_subst t1 t2 menv =
+  if t1 = t2 then
+    Some([])
+  else
+    try
+      let (l,_) = meta_convertibility_aux ([],[]) t1 t2 in
+      let subst =
+	List.map
+	  (fun (x,y) ->
+	     try 
+	       let (_,c,t) = CicUtil.lookup_meta x menv in
+	       let irl = 
+		 CicMkImplicit.identity_relocation_list_for_metavariable c in
+	       (y,(c,Cic.Meta(x,irl),t))
+	     with CicUtil.Meta_not_found _ ->
+	       try 
+		 let (_,c,t) = CicUtil.lookup_meta y menv in
+		 let irl =  
+		   CicMkImplicit.identity_relocation_list_for_metavariable c in
+		   (x,(c,Cic.Meta(y,irl),t))
+	       with CicUtil.Meta_not_found _ -> assert false) l in   
+	Some subst
+    with NotMetaConvertible ->
+      None
+;;
+
 exception TermIsNotAnEquality;;
 
 let term_is_equality term =
@@ -1234,3 +1260,104 @@ let pp_proofterm t =
   pp_proofterm (Some (Cic.Name "Hypothesis")) t []
 ;;
 
+let initial_nameset_list = [
+ "x"; "y"; "z"; "t"; "u"; "v"; "a"; "b"; "c"; "d"; 
+ "e"; "l"; "m"; "n"; "o"; "p"; "q"; "r"; 
+]
+
+module S = Set.Make(String)
+
+let initial_nameset = List.fold_right S.add initial_nameset_list S.empty, [];;
+
+let freshname (nameset, subst) term = 
+  let m = CicUtil.metas_of_term term in
+  let nameset, subst = 
+    List.fold_left 
+      (fun (set,rc) (m,_) -> 
+        if List.mem_assoc m rc then set,rc else
+        let name = S.choose set in
+        let set = S.remove name set in
+        set, 
+        (m,Cic.Const(UriManager.uri_of_string 
+             ("cic:/"^name^".con"),[]))::rc)
+      (nameset,subst) m
+  in
+  let term = 
+   ProofEngineReduction.replace
+    ~equality:(fun i t -> match t with Cic.Meta (j,_) -> i=j| _ -> false) 
+    ~what:(List.map fst subst) 
+    ~with_what:(List.map snd subst) ~where:term
+  in
+  (nameset, subst), term
+;;
+
+let remove_names_in_context (set,subst) names =
+  List.fold_left
+    (fun s n -> 
+      match n with Some (Cic.Name n) -> S.remove n s | _ -> s) 
+    set names, subst
+;;
+
+let string_of_id2 (id_to_eq,_) names nameset id = 
+  if id = 0 then "" else 
+  try
+    let (_,_,(_,l,r,_),_,_) = open_equality (Hashtbl.find id_to_eq id) in
+    let nameset, l = freshname nameset l in
+    let nameset, r = freshname nameset r in
+    Printf.sprintf "%s = %s" (CicPp.pp l names) (CicPp.pp r names)
+  with
+      Not_found -> assert false
+;;
+
+let draw_proof bag names goal_proof proof id =
+  let b = Buffer.create 100 in
+  let fmt = Format.formatter_of_buffer b in 
+  let sint = string_of_int in
+  let fst3 (x,_,_) = x in
+  let visited = ref [] in
+  let nameset = remove_names_in_context initial_nameset names in
+  let rec fact id = function
+    | Exact t -> 
+        if not (List.mem id !visited) then
+          begin
+          visited := id :: !visited;
+          let nameset, t = freshname nameset t in
+          let t = CicPp.pp t names in
+          GraphvizPp.Dot.node (sint id) 
+          ~attrs:["label",t^":"^string_of_id2 bag names nameset id;
+          "shape","rectangle"] fmt;
+          end
+    | Step (_,(_,id1,(_,id2),_)) ->
+        GraphvizPp.Dot.edge (sint id) (sint id1) fmt;
+        GraphvizPp.Dot.edge (sint id) (sint id2) fmt;
+        let p1,_,_ = proof_of_id bag id1 in
+        let p2,_,_ = proof_of_id bag id2 in
+        fact id1 p1;
+        fact id2 p2;
+        if not (List.mem id !visited); then
+          begin
+          visited := id :: !visited;
+          GraphvizPp.Dot.node (sint id) 
+          ~attrs:["label",sint id^":"^string_of_id2 bag names nameset id;
+                  "shape","ellipse"] fmt
+          end
+  in
+  let sleft acc (_,_,id,_,_) =
+    if acc != 0 then GraphvizPp.Dot.edge (sint acc) (sint id) fmt;
+    fact id (fst3 (proof_of_id bag id));
+    id
+  in
+  GraphvizPp.Dot.header ~node_attrs:["fontsize","10"; ] fmt;
+  ignore(List.fold_left sleft id goal_proof);
+  GraphvizPp.Dot.trailer fmt;
+  let oc = open_out "/tmp/matita_paramod.dot" in
+  Buffer.output_buffer oc b;
+  close_out oc;
+  Utils.debug_print (lazy "dot!");
+  ignore(Unix.system 
+    "dot -Tps -o /tmp/matita_paramod.eps /tmp/matita_paramod.dot"
+(* "cat /tmp/matita_paramod.dot| tred | dot -Tps -o /tmp/matita_paramod.eps" *)
+  );
+  ignore(Unix.system "gv /tmp/matita_paramod.eps");
+;;
+