X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Focaml%2Fparamodulation%2Fsaturation.ml;h=6d5ecee159a8ba72f0d39b4351af16a044d837eb;hb=162a34842afbb574f89e3a358a79a310e7ec8b16;hp=793e48423b1d999d97a342fa8affe2048d2f3399;hpb=c9d7e6a946744890def5b5471c93b4dbd78c4ac9;p=helm.git diff --git a/helm/ocaml/paramodulation/saturation.ml b/helm/ocaml/paramodulation/saturation.ml index 793e48423..6d5ecee15 100644 --- a/helm/ocaml/paramodulation/saturation.ml +++ b/helm/ocaml/paramodulation/saturation.ml @@ -2,6 +2,10 @@ open Inference;; open Utils;; +(* set to false to disable paramodulation inside auto_tac *) +let connect_to_auto = true;; + + (* profiling statistics... *) let infer_time = ref 0.;; let forward_simpl_time = ref 0.;; @@ -18,12 +22,15 @@ let elapsed_time = ref 0.;; let maximal_retained_equality = ref None;; (* equality-selection related globals *) -let use_fullred = ref false;; -let weight_age_ratio = ref 0;; (* settable by the user from the command line *) +let use_fullred = ref true;; +let weight_age_ratio = ref (* 5 *) 4;; (* settable by the user *) let weight_age_counter = ref !weight_age_ratio;; -let symbols_ratio = ref 0;; +let symbols_ratio = ref (* 0 *) 3;; let symbols_counter = ref 0;; +(* non-recursive Knuth-Bendix term ordering by default *) +Utils.compare_terms := Utils.nonrec_kbo;; + (* statistics... *) let derived_clauses = ref 0;; let kept_clauses = ref 0;; @@ -33,8 +40,8 @@ let maxmeta = ref 0;; type result = - | Failure - | Success of Inference.equality option * environment + | ParamodulationFailure + | ParamodulationSuccess of Inference.equality option * environment ;; @@ -44,7 +51,7 @@ let symbols_of_equality (_, (_, left, right), _, _) = ;; *) -let symbols_of_equality ((_, (_, left, right, _), _, _) as equality) = +let symbols_of_equality ((_, _, (_, left, right, _), _, _) as equality) = let m1 = symbols_of_term left in let m = TermMap.fold @@ -64,17 +71,6 @@ let symbols_of_equality ((_, (_, left, right, _), _, _) as equality) = ;; -let weight_of_equality (_, (ty, left, right, _), _, _) = - let meta_number = ref 0 in - let weight_of t = - let weight, ml = weight_of_term t in - meta_number := !meta_number + (List.fold_left (fun r (_, n) -> r+n) 0 ml); - weight - in - (weight_of ty) + (weight_of left) + (weight_of right), meta_number -;; - - module OrderedEquality = struct type t = Inference.equality @@ -82,17 +78,25 @@ module OrderedEquality = struct match meta_convertibility_eq eq1 eq2 with | true -> 0 | false -> - let _, (ty, left, right, _), _, _ = eq1 - and _, (ty', left', right', _), _, _ = eq2 in -(* let w1, m1 = weight_of_equality eq1 *) -(* and w2, m2 = weight_of_equality eq2 in *) - let weight_of t = fst (weight_of_term ~consider_metas:false t) in - let w1 = (weight_of ty) + (weight_of left) + (weight_of right) - and w2 = (weight_of ty') + (weight_of left') + (weight_of right') in + let w1, _, (ty, left, right, _), _, a = eq1 + and w2, _, (ty', left', right', _), _, a' = eq2 in +(* let weight_of t = fst (weight_of_term ~consider_metas:false t) in *) +(* let w1 = (weight_of ty) + (weight_of left) + (weight_of right) *) +(* and w2 = (weight_of ty') + (weight_of left') + (weight_of right') in *) match Pervasives.compare w1 w2 with - | 0 -> Pervasives.compare eq1 eq2 -(* let res = Pervasives.compare m1 m2 in *) -(* if res = 0 then Pervasives.compare eq1 eq2 else res *) + | 0 -> + let res = (List.length a) - (List.length a') in + if res <> 0 then res else ( + try + let res = Pervasives.compare (List.hd a) (List.hd a') in + if res <> 0 then res else Pervasives.compare eq1 eq2 + with Failure "hd" -> Pervasives.compare eq1 eq2 +(* match a, a' with *) +(* | (Cic.Meta (i, _)::_), (Cic.Meta (j, _)::_) -> *) +(* let res = Pervasives.compare i j in *) +(* if res <> 0 then res else Pervasives.compare eq1 eq2 *) +(* | _, _ -> Pervasives.compare eq1 eq2 *) + ) | res -> res end @@ -278,9 +282,13 @@ let prune_passive howmany (active, _) passive = let (nl, ns), (pl, ps), tbl = passive in let howmany = float_of_int howmany and ratio = float_of_int !weight_age_ratio in - let in_weight = int_of_float (howmany *. ratio /. (ratio +. 1.)) - and in_age = int_of_float (howmany /. (ratio +. 1.)) in - Printf.printf "in_weight: %d, in_age: %d\n" in_weight in_age; + let round v = + let t = ceil v in + int_of_float (if t -. v < 0.5 then t else v) + in + let in_weight = round (howmany *. ratio /. (ratio +. 1.)) + and in_age = round (howmany /. (ratio +. 1.)) in + debug_print (Printf.sprintf "in_weight: %d, in_age: %d\n" in_weight in_age); let symbols, card = match active with | (Negative, e)::_ -> @@ -361,7 +369,7 @@ let prune_passive howmany (active, _) passive = let _, ps, pl = picka in_age ps pl in if not (EqualitySet.is_empty ps) then (* maximal_weight := Some (weight_of_equality (EqualitySet.max_elt ps)); *) - maximal_retained_equality := Some (EqualitySet.max_elt ps); + maximal_retained_equality := Some (EqualitySet.max_elt ps); let tbl = EqualitySet.fold (fun e tbl -> Indexing.index tbl e) ps (Indexing.empty_table ()) @@ -379,7 +387,10 @@ let infer env sign current (active_list, active_table) = let new_neg, new_pos = match sign with | Negative -> - Indexing.superposition_left env active_table current, [] + let maxm, res = + Indexing.superposition_left !maxmeta env active_table current in + maxmeta := maxm; + res, [] | Positive -> let maxm, res = Indexing.superposition_right !maxmeta env active_table current in @@ -387,7 +398,9 @@ let infer env sign current (active_list, active_table) = let rec infer_positive table = function | [] -> [], [] | (Negative, equality)::tl -> - let res = Indexing.superposition_left env table equality in + let maxm, res = + Indexing.superposition_left !maxmeta env table equality in + maxmeta := maxm; let neg, pos = infer_positive table tl in res @ neg, pos | (Positive, equality)::tl -> @@ -403,11 +416,52 @@ let infer env sign current (active_list, active_table) = in derived_clauses := !derived_clauses + (List.length new_neg) + (List.length new_pos); - match (* !maximal_weight *)!maximal_retained_equality with + match !maximal_retained_equality with | None -> new_neg, new_pos - | Some (* w *) eq -> - let new_pos = - List.filter (fun e -> (* (weight_of_equality e) <= w *) OrderedEquality.compare e eq <= 0) new_pos in + | Some eq -> + (* if we have a maximal_retained_equality, we can discard all equalities + "greater" than it, as they will never be reached... An equality is + greater than maximal_retained_equality if it is bigger + wrt. OrderedEquality.compare and it is less similar than + maximal_retained_equality to the current goal *) + let symbols, card = + match active_list with + | (Negative, e)::_ -> + let symbols = symbols_of_equality e in + let card = TermMap.fold (fun k v res -> res + v) symbols 0 in + Some symbols, card + | _ -> None, 0 + in + let new_pos = + match symbols with + | None -> + List.filter (fun e -> OrderedEquality.compare e eq <= 0) new_pos + | Some symbols -> + let filterfun e = + if OrderedEquality.compare e eq <= 0 then + true + else + let foldfun k v (r1, r2) = + if TermMap.mem k symbols then + let c = TermMap.find k symbols in + let c1 = abs (c - v) in + let c2 = v - c1 in + r1 + c2, r2 + c1 + else + r1, r2 + v + in + let initial = + let common, others = + TermMap.fold foldfun (symbols_of_equality eq) (0, 0) in + others + (abs (common - card)) + in + let common, others = + TermMap.fold foldfun (symbols_of_equality e) (0, 0) in + let c = others + (abs (common - card)) in + if c < initial then true else false + in + List.filter filterfun new_pos + in new_neg, new_pos ;; @@ -417,7 +471,7 @@ let contains_empty env (negative, positive) = try let found = List.find - (fun (proof, (ty, left, right, ordering), m, a) -> + (fun (w, proof, (ty, left, right, ordering), m, a) -> fst (CicReduction.are_convertible context left right ugraph)) negative in @@ -438,7 +492,7 @@ let forward_simplify env (sign, current) ?passive (active_list, active_table) = in let all = if pl = [] then active_list else active_list @ pl in -(* let rec find_duplicate sign current = function *) + (* let rec find_duplicate sign current = function *) (* | [] -> false *) (* | (s, eq)::tl when s = sign -> *) (* if meta_convertibility_eq current eq then true *) @@ -458,11 +512,11 @@ let forward_simplify env (sign, current) ?passive (active_list, active_table) = let demodulate table current = let newmeta, newcurrent = - Indexing.demodulation !maxmeta env table current in + Indexing.demodulation !maxmeta env table sign current in maxmeta := newmeta; if is_identity env newcurrent then if sign = Negative then Some (sign, newcurrent) - else (Inference.delete_proof newcurrent; None) + else None else Some (sign, newcurrent) in @@ -486,13 +540,12 @@ let forward_simplify env (sign, current) ?passive (active_list, active_table) = if ok then res else None | Some (Positive, c) -> if Indexing.in_index active_table c then - (Inference.delete_proof c; None) + None else match passive_table with | None -> res | Some passive_table -> - if Indexing.in_index passive_table c then - (Inference.delete_proof c; None) + if Indexing.in_index passive_table c then None else res (* | Some (s, c) -> if find_duplicate s c all then None else res *) @@ -546,8 +599,9 @@ let forward_simplify_new env (new_neg, new_pos) ?passive active = let t2 = Unix.gettimeofday () in fs_time_info.build_all <- fs_time_info.build_all +. (t2 -. t1); - let demodulate table target = - let newmeta, newtarget = Indexing.demodulation !maxmeta env table target in + let demodulate sign table target = + let newmeta, newtarget = + Indexing.demodulation !maxmeta env table sign target in maxmeta := newmeta; newtarget in @@ -559,13 +613,13 @@ let forward_simplify_new env (new_neg, new_pos) ?passive active = let t1 = Unix.gettimeofday () in let new_neg, new_pos = - let new_neg = List.map (demodulate active_table) new_neg - and new_pos = List.map (demodulate active_table) new_pos in + let new_neg = List.map (demodulate Negative active_table) new_neg + and new_pos = List.map (demodulate Positive active_table) new_pos in match passive_table with | None -> new_neg, new_pos | Some passive_table -> - List.map (demodulate passive_table) new_neg, - List.map (demodulate passive_table) new_pos + List.map (demodulate Negative passive_table) new_neg, + List.map (demodulate Positive passive_table) new_pos in let t2 = Unix.gettimeofday () in @@ -575,12 +629,9 @@ let forward_simplify_new env (new_neg, new_pos) ?passive active = List.fold_left (fun s e -> if not (Inference.is_identity env e) then - if EqualitySet.mem e s then - (Inference.delete_proof e; s) - else - EqualitySet.add e s - else - (Inference.delete_proof e; s)) + if EqualitySet.mem e s then s + else EqualitySet.add e s + else s) EqualitySet.empty new_pos in let new_pos = EqualitySet.elements new_pos_set in @@ -612,16 +663,11 @@ let forward_simplify_new env (new_neg, new_pos) ?passive active = let is_duplicate = match passive_table with | None -> - (fun e -> - let ok = not (Indexing.in_index active_table e) in - if not ok then Inference.delete_proof e; - ok) + (fun e -> not (Indexing.in_index active_table e)) | Some passive_table -> (fun e -> - let ok = not ((Indexing.in_index active_table e) || - (Indexing.in_index passive_table e)) in - if not ok then Inference.delete_proof e; - ok) + not ((Indexing.in_index active_table e) || + (Indexing.in_index passive_table e))) in new_neg, List.filter is_duplicate new_pos @@ -635,18 +681,22 @@ let forward_simplify_new env (new_neg, new_pos) ?passive active = ;; -let backward_simplify_active env new_pos new_table active = +let backward_simplify_active env new_pos new_table min_weight active = let active_list, active_table = active in let active_list, newa = List.fold_right (fun (s, equality) (res, newn) -> - match forward_simplify env (s, equality) (new_pos, new_table) with - | None -> res, newn - | Some (s, e) -> - if equality = e then - (s, e)::res, newn - else - res, (s, e)::newn) + let ew, _, _, _, _ = equality in + if ew < min_weight then + (s, equality)::res, newn + else + match forward_simplify env (s, equality) (new_pos, new_table) with + | None -> res, newn + | Some (s, e) -> + if equality = e then + (s, e)::res, newn + else + res, (s, e)::newn) active_list ([], []) in let find eq1 where = @@ -658,7 +708,6 @@ let backward_simplify_active env new_pos new_table active = if List.mem (s, eq) res then res, tbl else if (is_identity env eq) || (find eq res) then ( - Inference.delete_proof eq; res, tbl ) (* else if (find eq res) then *) (* res, tbl *) @@ -668,7 +717,6 @@ let backward_simplify_active env new_pos new_table active = List.fold_right (fun (s, eq) (n, p) -> if (s <> Negative) && (is_identity env eq) then ( - Inference.delete_proof eq; (n, p) ) else if s = Negative then eq::n, p @@ -681,17 +729,22 @@ let backward_simplify_active env new_pos new_table active = ;; -let backward_simplify_passive env new_pos new_table passive = +let backward_simplify_passive env new_pos new_table min_weight passive = let (nl, ns), (pl, ps), passive_table = passive in let f sign equality (resl, ress, newn) = - match forward_simplify env (sign, equality) (new_pos, new_table) with - | None -> resl, EqualitySet.remove equality ress, newn - | Some (s, e) -> - if equality = e then - equality::resl, ress, newn - else - let ress = EqualitySet.remove equality ress in - resl, ress, e::newn + let ew, _, _, _, _ = equality in + if ew < min_weight then +(* let _ = debug_print (Printf.sprintf "OK: %d %d" ew min_weight) in *) + equality::resl, ress, newn + else + match forward_simplify env (sign, equality) (new_pos, new_table) with + | None -> resl, EqualitySet.remove equality ress, newn + | Some (s, e) -> + if equality = e then + equality::resl, ress, newn + else + let ress = EqualitySet.remove equality ress in + resl, ress, e::newn in let nl, ns, newn = List.fold_right (f Negative) nl ([], ns, []) and pl, ps, newp = List.fold_right (f Positive) pl ([], ps, []) in @@ -706,18 +759,21 @@ let backward_simplify_passive env new_pos new_table passive = let backward_simplify env new' ?passive active = - let new_pos, new_table = + let new_pos, new_table, min_weight = List.fold_left - (fun (l, t) e -> (Positive, e)::l, Indexing.index t e) - ([], Indexing.empty_table ()) (snd new') - in - let active, newa = backward_simplify_active env new_pos new_table active in + (fun (l, t, w) e -> + let ew, _, _, _, _ = e in + (Positive, e)::l, Indexing.index t e, min ew w) + ([], Indexing.empty_table (), 1000000) (snd new') + in + let active, newa = + backward_simplify_active env new_pos new_table min_weight active in match passive with | None -> active, (make_passive [] []), newa, None | Some passive -> let passive, newp = - backward_simplify_passive env new_pos new_table passive in + backward_simplify_passive env new_pos new_table min_weight passive in active, passive, newa, newp ;; @@ -740,12 +796,13 @@ let rec given_clause env passive active = if !time_limit = 0. || !processed_clauses = 0 then passive else if !elapsed_time > !time_limit then ( - Printf.printf "Time limit (%.2f) reached: %.2f\n" - !time_limit !elapsed_time; + debug_print (Printf.sprintf "Time limit (%.2f) reached: %.2f\n" + !time_limit !elapsed_time); make_passive [] [] ) else if kept > selection_estimate then ( - Printf.printf ("Too many passive equalities: pruning... (kept: %d, " ^^ - "selection_estimate: %d)\n") kept selection_estimate; + debug_print (Printf.sprintf ("Too many passive equalities: pruning..." ^^ + "(kept: %d, selection_estimate: %d)\n") + kept selection_estimate); prune_passive selection_estimate active passive ) else passive @@ -757,7 +814,7 @@ let rec given_clause env passive active = kept_clauses := (size_of_passive passive) + (size_of_active active); match passive_is_empty passive with - | true -> Failure + | true -> ParamodulationFailure | false -> let (sign, current), passive = select env passive active in let time1 = Unix.gettimeofday () in @@ -769,15 +826,14 @@ let rec given_clause env passive active = given_clause env passive active | Some (sign, current) -> if (sign = Negative) && (is_identity env current) then ( - Printf.printf "OK!!! %s %s" (string_of_sign sign) - (string_of_equality ~env current); - print_newline (); - Success (Some current, env) + debug_print (Printf.sprintf "OK!!! %s %s" (string_of_sign sign) + (string_of_equality ~env current)); + ParamodulationSuccess (Some current, env) ) else ( - print_endline "\n================================================"; - Printf.printf "selected: %s %s" - (string_of_sign sign) (string_of_equality ~env current); - print_newline (); + debug_print "\n================================================"; + debug_print (Printf.sprintf "selected: %s %s" + (string_of_sign sign) + (string_of_equality ~env current)); let t1 = Unix.gettimeofday () in let new' = infer env sign current active in @@ -786,7 +842,7 @@ let rec given_clause env passive active = let res, goal = contains_empty env new' in if res then - Success (goal, env) + ParamodulationSuccess (goal, env) else let t1 = Unix.gettimeofday () in let new' = forward_simplify_new env new' (* ~passive *) active in @@ -849,7 +905,7 @@ let rec given_clause env passive active = al @ [(sign, current)], Indexing.index tbl current in let passive = add_to_passive passive new' in -(* let (_, ns), (_, ps), _ = passive in *) + let (_, ns), (_, ps), _ = passive in (* Printf.printf "passive:\n%s\n" *) (* (String.concat "\n" *) (* ((List.map (fun e -> "Negative " ^ *) @@ -861,7 +917,7 @@ let rec given_clause env passive active = (* print_newline (); *) given_clause env passive active | true, goal -> - Success (goal, env) + ParamodulationSuccess (goal, env) ) ;; @@ -875,12 +931,13 @@ let rec given_clause_fullred env passive active = if !time_limit = 0. || !processed_clauses = 0 then passive else if !elapsed_time > !time_limit then ( - Printf.printf "Time limit (%.2f) reached: %.2f\n" - !time_limit !elapsed_time; + debug_print (Printf.sprintf "Time limit (%.2f) reached: %.2f\n" + !time_limit !elapsed_time); make_passive [] [] ) else if kept > selection_estimate then ( - Printf.printf ("Too many passive equalities: pruning... (kept: %d, " ^^ - "selection_estimate: %d)\n") kept selection_estimate; + debug_print (Printf.sprintf ("Too many passive equalities: pruning..." ^^ + "(kept: %d, selection_estimate: %d)\n") + kept selection_estimate); prune_passive selection_estimate active passive ) else passive @@ -892,7 +949,7 @@ let rec given_clause_fullred env passive active = kept_clauses := (size_of_passive passive) + (size_of_active active); match passive_is_empty passive with - | true -> Failure + | true -> ParamodulationFailure | false -> let (sign, current), passive = select env passive active in let time1 = Unix.gettimeofday () in @@ -904,15 +961,14 @@ let rec given_clause_fullred env passive active = given_clause_fullred env passive active | Some (sign, current) -> if (sign = Negative) && (is_identity env current) then ( - Printf.printf "OK!!! %s %s" (string_of_sign sign) - (string_of_equality ~env current); - print_newline (); - Success (Some current, env) + debug_print (Printf.sprintf "OK!!! %s %s" (string_of_sign sign) + (string_of_equality ~env current)); + ParamodulationSuccess (Some current, env) ) else ( - print_endline "\n================================================"; - Printf.printf "selected: %s %s" - (string_of_sign sign) (string_of_equality ~env current); - print_newline (); + debug_print "\n================================================"; + debug_print (Printf.sprintf "selected: %s %s" + (string_of_sign sign) + (string_of_equality ~env current)); let t1 = Unix.gettimeofday () in let new' = infer env sign current active in @@ -953,156 +1009,373 @@ let rec given_clause_fullred env passive active = if k < (kept - 1) then processed_clauses := !processed_clauses + (kept - 1 - k); -(* let _ = *) -(* Printf.printf "active:\n%s\n" *) -(* (String.concat "\n" *) -(* ((List.map *) -(* (fun (s, e) -> (string_of_sign s) ^ " " ^ *) -(* (string_of_equality ~env e)) (fst active)))); *) -(* print_newline (); *) -(* in *) -(* let _ = *) -(* match new' with *) -(* | neg, pos -> *) -(* Printf.printf "new':\n%s\n" *) -(* (String.concat "\n" *) -(* ((List.map *) -(* (fun e -> "Negative " ^ *) -(* (string_of_equality ~env e)) neg) @ *) -(* (List.map *) -(* (fun e -> "Positive " ^ *) -(* (string_of_equality ~env e)) pos))); *) -(* print_newline (); *) -(* in *) + let _ = + debug_print ( + Printf.sprintf "active:\n%s\n" + (String.concat "\n" + ((List.map + (fun (s, e) -> (string_of_sign s) ^ " " ^ + (string_of_equality ~env e)) (fst active))))) + in + let _ = + match new' with + | neg, pos -> + debug_print ( + Printf.sprintf "new':\n%s\n" + (String.concat "\n" + ((List.map + (fun e -> "Negative " ^ + (string_of_equality ~env e)) neg) @ + (List.map + (fun e -> "Positive " ^ + (string_of_equality ~env e)) pos)))) + in match contains_empty env new' with | false, _ -> let passive = add_to_passive passive new' in +(* let (_, ns), (_, ps), _ = passive in *) +(* Printf.printf "passive:\n%s\n" *) +(* (String.concat "\n" *) +(* ((List.map (fun e -> "Negative " ^ *) +(* (string_of_equality ~env e)) *) +(* (EqualitySet.elements ns)) @ *) +(* (List.map (fun e -> "Positive " ^ *) +(* (string_of_equality ~env e)) *) +(* (EqualitySet.elements ps)))); *) +(* print_newline (); *) given_clause_fullred env passive active | true, goal -> - Success (goal, env) + ParamodulationSuccess (goal, env) ) ;; -let get_from_user () = - let dbd = Mysql.quick_connect - ~host:"localhost" ~user:"helm" ~database:"mowgli" () in - let rec get () = - match read_line () with - | "" -> [] - | t -> t::(get ()) - in - let term_string = String.concat "\n" (get ()) in - let env, metasenv, term, ugraph = - List.nth (Disambiguate.Trivial.disambiguate_string dbd term_string) 0 - in - term, metasenv, ugraph -;; - - let given_clause_ref = ref given_clause;; -let main () = +let main dbd term metasenv ugraph = let module C = Cic in let module T = CicTypeChecker in let module PET = ProofEngineTypes in let module PP = CicPp in - let term, metasenv, ugraph = get_from_user () in let proof = None, (1, [], term)::metasenv, C.Meta (1, []), term in - let proof, goals = - PET.apply_tactic (PrimitiveTactics.intros_tac ()) (proof, 1) in - let goal = List.nth goals 0 in + let status = PET.apply_tactic (PrimitiveTactics.intros_tac ()) (proof, 1) in + let proof, goals = status in + let goal' = List.nth goals 0 in let _, metasenv, meta_proof, _ = proof in - let _, context, goal = CicUtil.lookup_meta goal metasenv in + let _, context, goal = CicUtil.lookup_meta goal' metasenv in let equalities, maxm = find_equalities context proof in - maxmeta := maxm; (* TODO ugly!! *) + let library_equalities, maxm = + find_library_equalities ~dbd context (proof, goal') (maxm+2) + in + maxmeta := maxm+2; (* TODO ugly!! *) + let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in + let new_meta_goal, metasenv, type_of_goal = + let _, context, ty = CicUtil.lookup_meta goal' metasenv in + Printf.printf "\n\nTIPO DEL GOAL: %s\n" (CicPp.ppterm ty); + print_newline (); + Cic.Meta (maxm+1, irl), + (maxm+1, context, ty)::metasenv, + ty + in +(* let new_meta_goal = Cic.Meta (goal', irl) in *) let env = (metasenv, context, ugraph) in try - let term_equality = equality_of_term meta_proof goal in - let meta_proof, (eq_ty, left, right, ordering), _, _ = term_equality in - let active = make_active () in - let passive = make_passive [term_equality] equalities in - Printf.printf "\ncurrent goal: %s\n" - (string_of_equality ~env term_equality); - Printf.printf "\ncontext:\n%s\n" (PP.ppcontext context); - Printf.printf "\nmetasenv:\n%s\n" (print_metasenv metasenv); - Printf.printf "\nequalities:\n%s\n" - (String.concat "\n" - (List.map - (string_of_equality ~env) - equalities)); - print_endline "--------------------------------------------------"; - let start = Unix.gettimeofday () in - print_endline "GO!"; - start_time := Unix.gettimeofday (); - let res = - (if !use_fullred then given_clause_fullred else given_clause) - env passive active - in - let finish = Unix.gettimeofday () in - let _ = - match res with - | Failure -> - Printf.printf "NO proof found! :-(\n\n" - | Success (Some goal, env) -> - Printf.printf "OK, found a proof!\n"; - let proof = Inference.build_term_proof goal in - print_endline (PP.pp proof (names_of_context context)); - print_endline (string_of_float (finish -. start)); - | Success (None, env) -> - Printf.printf "Success, but no proof?!?\n\n" - in - Printf.printf ("infer_time: %.9f\nforward_simpl_time: %.9f\n" ^^ - "forward_simpl_new_time: %.9f\n" ^^ - "backward_simpl_time: %.9f\n") - !infer_time !forward_simpl_time !forward_simpl_new_time - !backward_simpl_time; - Printf.printf "passive_maintainance_time: %.9f\n" - !passive_maintainance_time; - Printf.printf " successful unification/matching time: %.9f\n" - !Indexing.match_unif_time_ok; - Printf.printf " failed unification/matching time: %.9f\n" - !Indexing.match_unif_time_no; - Printf.printf " indexing retrieval time: %.9f\n" - !Indexing.indexing_retrieval_time; - Printf.printf " demodulate_term.build_newtarget_time: %.9f\n" - !Indexing.build_newtarget_time; - Printf.printf "derived %d clauses, kept %d clauses.\n" - !derived_clauses !kept_clauses; + let term_equality = equality_of_term new_meta_goal goal in + let _, meta_proof, (eq_ty, left, right, ordering), _, _ = term_equality in + if is_identity env term_equality then + let proof = + Cic.Appl [Cic.MutConstruct (* reflexivity *) + (HelmLibraryObjects.Logic.eq_URI, 0, 1, []); + eq_ty; left] + in + let _ = + Printf.printf "OK, found a proof!\n"; + let names = names_of_context context in + print_endline (PP.pp proof names) + in + () + else + let equalities = + let equalities = equalities @ library_equalities in + debug_print ( + Printf.sprintf "equalities:\n%s\n" + (String.concat "\n" + (List.map string_of_equality equalities))); + debug_print "SIMPLYFYING EQUALITIES..."; + let rec simpl e others others_simpl = + let active = others @ others_simpl in + let tbl = + List.fold_left + (fun t (_, e) -> Indexing.index t e) + (Indexing.empty_table ()) active + in + let res = forward_simplify env e (active, tbl) in + match others with + | hd::tl -> ( + match res with + | None -> simpl hd tl others_simpl + | Some e -> simpl hd tl (e::others_simpl) + ) + | [] -> ( + match res with + | None -> others_simpl + | Some e -> e::others_simpl + ) + in + match equalities with + | [] -> [] + | hd::tl -> + let others = List.map (fun e -> (Positive, e)) tl in + let res = + List.rev (List.map snd (simpl (Positive, hd) others [])) + in + debug_print ( + Printf.sprintf "equalities AFTER:\n%s\n" + (String.concat "\n" + (List.map string_of_equality res))); + res + in + let active = make_active () in + let passive = make_passive [term_equality] equalities in + Printf.printf "\ncurrent goal: %s\n" + (string_of_equality ~env term_equality); + Printf.printf "\ncontext:\n%s\n" (PP.ppcontext context); + Printf.printf "\nmetasenv:\n%s\n" (print_metasenv metasenv); + Printf.printf "\nequalities:\n%s\n" + (String.concat "\n" + (List.map + (string_of_equality ~env) + (equalities @ library_equalities))); + print_endline "--------------------------------------------------"; + let start = Unix.gettimeofday () in + print_endline "GO!"; + start_time := Unix.gettimeofday (); + let res = + (if !use_fullred then given_clause_fullred else given_clause) + env passive active + in + let finish = Unix.gettimeofday () in + let _ = + match res with + | ParamodulationFailure -> + Printf.printf "NO proof found! :-(\n\n" + | ParamodulationSuccess (Some goal, env) -> + let proof = Inference.build_proof_term goal in + let newmetasenv = + List.fold_left + (fun m (_, _, _, menv, _) -> m @ menv) metasenv equalities + in + let _ = + try + let ty, ug = + CicTypeChecker.type_of_aux' newmetasenv context proof ugraph + in + Printf.printf "OK, found a proof!\n"; + (* REMEMBER: we have to instantiate meta_proof, we should use + apply the "apply" tactic to proof and status + *) + let names = names_of_context context in + print_endline (PP.pp proof names); + (* print_endline (PP.ppterm proof); *) + + print_endline (string_of_float (finish -. start)); + Printf.printf + "\nGOAL was: %s\nPROOF has type: %s\nconvertible?: %s\n\n" + (CicPp.pp type_of_goal names) (CicPp.pp ty names) + (string_of_bool + (fst (CicReduction.are_convertible + context type_of_goal ty ug))); + with e -> + Printf.printf "\nEXCEPTION!!! %s\n" (Printexc.to_string e); + Printf.printf "MAXMETA USED: %d\n" !maxmeta; + print_endline (string_of_float (finish -. start)); + in + () + + | ParamodulationSuccess (None, env) -> + Printf.printf "Success, but no proof?!?\n\n" + in + Printf.printf ("infer_time: %.9f\nforward_simpl_time: %.9f\n" ^^ + "forward_simpl_new_time: %.9f\n" ^^ + "backward_simpl_time: %.9f\n") + !infer_time !forward_simpl_time !forward_simpl_new_time + !backward_simpl_time; + Printf.printf "passive_maintainance_time: %.9f\n" + !passive_maintainance_time; + Printf.printf " successful unification/matching time: %.9f\n" + !Indexing.match_unif_time_ok; + Printf.printf " failed unification/matching time: %.9f\n" + !Indexing.match_unif_time_no; + Printf.printf " indexing retrieval time: %.9f\n" + !Indexing.indexing_retrieval_time; + Printf.printf " demodulate_term.build_newtarget_time: %.9f\n" + !Indexing.build_newtarget_time; + Printf.printf "derived %d clauses, kept %d clauses.\n" + !derived_clauses !kept_clauses; with exc -> print_endline ("EXCEPTION: " ^ (Printexc.to_string exc)); raise exc ;; -let configuration_file = ref "../../gTopLevel/gTopLevel.conf.xml";; - -let _ = - let set_ratio v = weight_age_ratio := (v+1); weight_age_counter := (v+1) - and set_sel v = symbols_ratio := v; symbols_counter := v; - and set_conf f = configuration_file := f - and set_lpo () = Utils.compare_terms := lpo - and set_kbo () = Utils.compare_terms := nonrec_kbo - and set_fullred () = use_fullred := true - and set_time_limit v = time_limit := float_of_int v +let saturate dbd (proof, goal) = + let module C = Cic in + maxmeta := 0; + let goal' = goal in + let uri, metasenv, meta_proof, term_to_prove = proof in + let _, context, goal = CicUtil.lookup_meta goal' metasenv in + let equalities, maxm = find_equalities context proof in + let new_meta_goal, metasenv, type_of_goal = + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable context in + let _, context, ty = CicUtil.lookup_meta goal' metasenv in + debug_print (Printf.sprintf "\n\nTIPO DEL GOAL: %s\n" (CicPp.ppterm ty)); + Cic.Meta (maxm+1, irl), + (maxm+1, context, ty)::metasenv, + ty in - Arg.parse [ - "-f", Arg.Unit set_fullred, "Use full-reduction strategy"; - - "-r", Arg.Int set_ratio, "Weight-Age equality selection ratio (default: 0)"; - - "-s", Arg.Int set_sel, - "symbols-based selection ratio (relative to the weight ratio)"; + let ugraph = CicUniv.empty_ugraph in + let env = (metasenv, context, ugraph) in +(* try *) + let term_equality = equality_of_term new_meta_goal goal in + let res, time = + if is_identity env term_equality then + let w, _, (eq_ty, left, right, o), m, a = term_equality in + let proof = + Cic.Appl [Cic.MutConstruct (* reflexivity *) + (HelmLibraryObjects.Logic.eq_URI, 0, 1, []); + eq_ty; left] + in + (ParamodulationSuccess + (Some (0, Inference.BasicProof proof, + (eq_ty, left, right, o), m, a), env), 0.) + else + let library_equalities, maxm = + find_library_equalities ~dbd context (proof, goal') (maxm+2) + in + maxmeta := maxm+2; + let equalities = + let equalities = equalities @ library_equalities in + debug_print ( + Printf.sprintf "equalities:\n%s\n" + (String.concat "\n" + (List.map string_of_equality equalities))); + debug_print "SIMPLYFYING EQUALITIES..."; + let rec simpl e others others_simpl = + let active = others @ others_simpl in + let tbl = + List.fold_left + (fun t (_, e) -> Indexing.index t e) + (Indexing.empty_table ()) active + in + let res = forward_simplify env e (active, tbl) in + match others with + | hd::tl -> ( + match res with + | None -> simpl hd tl others_simpl + | Some e -> simpl hd tl (e::others_simpl) + ) + | [] -> ( + match res with + | None -> others_simpl + | Some e -> e::others_simpl + ) + in + match equalities with + | [] -> [] + | hd::tl -> + let others = List.map (fun e -> (Positive, e)) tl in + let res = + List.rev (List.map snd (simpl (Positive, hd) others [])) + in + debug_print ( + Printf.sprintf "equalities AFTER:\n%s\n" + (String.concat "\n" + (List.map string_of_equality res))); + res + in + let active = make_active () in + let passive = make_passive [term_equality] equalities in + let start = Unix.gettimeofday () in + let res = given_clause_fullred env passive active in + let finish = Unix.gettimeofday () in + (res, finish -. start) + in + match res with + | ParamodulationSuccess (Some goal, env) -> + debug_print "OK, found a proof!"; + let proof = Inference.build_proof_term goal in + let names = names_of_context context in + let newmetasenv = + let i1 = + match new_meta_goal with + | C.Meta (i, _) -> i | _ -> assert false + in +(* let i2 = *) +(* match meta_proof with *) +(* | C.Meta (i, _) -> i *) +(* | t -> *) +(* Printf.printf "\nHMMM!!! meta_proof: %s\ngoal': %s" *) +(* (CicPp.pp meta_proof names) (string_of_int goal'); *) +(* print_newline (); *) +(* assert false *) +(* in *) + List.filter (fun (i, _, _) -> i <> i1 && i <> goal') metasenv + in + let newstatus = + try + let ty, ug = + CicTypeChecker.type_of_aux' newmetasenv context proof ugraph + in + debug_print (CicPp.pp proof [](* names *)); + debug_print + (Printf.sprintf + "\nGOAL was: %s\nPROOF has type: %s\nconvertible?: %s\n" + (CicPp.pp type_of_goal names) (CicPp.pp ty names) + (string_of_bool + (fst (CicReduction.are_convertible + context type_of_goal ty ug)))); + let equality_for_replace i t1 = + match t1 with + | C.Meta (n, _) -> n = i + | _ -> false + in + let real_proof = + ProofEngineReduction.replace + ~equality:equality_for_replace + ~what:[goal'] ~with_what:[proof] + ~where:meta_proof + in + debug_print ( + Printf.sprintf "status:\n%s\n%s\n%s\n%s\n" + (match uri with Some uri -> UriManager.string_of_uri uri + | None -> "") + (print_metasenv newmetasenv) + (CicPp.pp real_proof [](* names *)) + (CicPp.pp term_to_prove names)); + ((uri, newmetasenv, real_proof, term_to_prove), []) + with CicTypeChecker.TypeCheckerFailure _ -> + debug_print "THE PROOF DOESN'T TYPECHECK!!!"; + debug_print (CicPp.pp proof names); + raise (ProofEngineTypes.Fail + "Found a proof, but it doesn't typecheck") + in + debug_print (Printf.sprintf "\nTIME NEEDED: %.9f" time); + newstatus + | _ -> + raise (ProofEngineTypes.Fail "NO proof found") +(* with e -> *) +(* raise (Failure "saturation failed") *) +;; - "-c", Arg.String set_conf, "Configuration file (for the db connection)"; - "-lpo", Arg.Unit set_lpo, "Use lpo term ordering"; +(* dummy function called within matita to trigger linkage *) +let init () = ();; - "-kbo", Arg.Unit set_kbo, "Use (non-recursive) kbo term ordering (default)"; - "-l", Arg.Int set_time_limit, "Time limit (in seconds)"; - ] (fun a -> ()) "Usage:" -in -Helm_registry.load_from !configuration_file; -main () +(* UGLY SIDE EFFECT... *) +if connect_to_auto then ( + AutoTactic.paramodulation_tactic := saturate; + AutoTactic.term_is_equality := Inference.term_is_equality; +);;