From: Andrea Asperti Date: Thu, 12 Jan 2006 12:38:36 +0000 (+0000) Subject: Moved paramodulation inside tactics. X-Git-Tag: make_still_working~7842 X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=b1527286e32c8651d65619af61e3f638b3b89f8d;p=helm.git Moved paramodulation inside tactics. Added a new (reduction) tactic demodulate. --- diff --git a/helm/ocaml/grafite/grafiteAst.ml b/helm/ocaml/grafite/grafiteAst.ml index c9567155d..6c51fc80a 100644 --- a/helm/ocaml/grafite/grafiteAst.ml +++ b/helm/ocaml/grafite/grafiteAst.ml @@ -37,7 +37,8 @@ type ('term, 'ident) type_spec = | Type of UriManager.uri * int type 'lazy_term reduction = - [ `Normalize + [ `Demodulate + | `Normalize | `Reduce | `Simpl | `Unfold of 'lazy_term option diff --git a/helm/ocaml/grafite/grafiteAstPp.ml b/helm/ocaml/grafite/grafiteAstPp.ml index 6abfa4dd6..8bd5c96f1 100644 --- a/helm/ocaml/grafite/grafiteAstPp.ml +++ b/helm/ocaml/grafite/grafiteAstPp.ml @@ -36,6 +36,7 @@ let command_terminator = tactical_terminator let pp_idents idents = "[" ^ String.concat "; " idents ^ "]" let pp_reduction_kind ~term_pp = function + | `Demodulate -> "demodulate" | `Normalize -> "normalize" | `Reduce -> "reduce" | `Simpl -> "simplify" diff --git a/helm/ocaml/grafite_engine/grafiteEngine.ml b/helm/ocaml/grafite_engine/grafiteEngine.ml index c0a453c93..60b2b6a9d 100644 --- a/helm/ocaml/grafite_engine/grafiteEngine.ml +++ b/helm/ocaml/grafite_engine/grafiteEngine.ml @@ -95,6 +95,8 @@ let tactic_of_ast ast = | GrafiteAst.Fold (_, reduction_kind, term, pattern) -> let reduction = match reduction_kind with + | `Demodulate -> + GrafiteTypes.command_error "demodulation can't be folded" | `Normalize -> PET.const_lazy_reduction (CicReduction.normalize ~delta:false ~subst:[]) @@ -136,11 +138,12 @@ let tactic_of_ast ast = Tactics.letin term ~mk_fresh_name_callback:(namer_of [name]) | GrafiteAst.Reduce (_, reduction_kind, pattern) -> (match reduction_kind with - | `Normalize -> Tactics.normalize ~pattern - | `Reduce -> Tactics.reduce ~pattern - | `Simpl -> Tactics.simpl ~pattern - | `Unfold what -> Tactics.unfold ~pattern what - | `Whd -> Tactics.whd ~pattern) + | `Demodulate -> Tactics.demodulate ~dbd:(LibraryDb.instance ()) ~pattern + | `Normalize -> Tactics.normalize ~pattern + | `Reduce -> Tactics.reduce ~pattern + | `Simpl -> Tactics.simpl ~pattern + | `Unfold what -> Tactics.unfold ~pattern what + | `Whd -> Tactics.whd ~pattern) | GrafiteAst.Reflexivity _ -> Tactics.reflexivity | GrafiteAst.Replace (_, pattern, with_what) -> Tactics.replace ~pattern ~with_what diff --git a/helm/ocaml/grafite_parser/grafiteDisambiguate.ml b/helm/ocaml/grafite_parser/grafiteDisambiguate.ml index 3d6f893ee..f5ea66f2f 100644 --- a/helm/ocaml/grafite_parser/grafiteDisambiguate.ml +++ b/helm/ocaml/grafite_parser/grafiteDisambiguate.ml @@ -81,6 +81,7 @@ let disambiguate_reduction_kind lexicon_status_ref = function | `Unfold (Some t) -> let t = disambiguate_lazy_term lexicon_status_ref t in `Unfold (Some t) + | `Demodulate | `Normalize | `Reduce | `Simpl diff --git a/helm/ocaml/grafite_parser/grafiteParser.ml b/helm/ocaml/grafite_parser/grafiteParser.ml index 90d1898ea..e480efd34 100644 --- a/helm/ocaml/grafite_parser/grafiteParser.ml +++ b/helm/ocaml/grafite_parser/grafiteParser.ml @@ -66,7 +66,8 @@ EXTEND [ tactic_terms = LIST1 tactic_term SEP SYMBOL "," -> tactic_terms ] ]; reduction_kind: [ - [ IDENT "normalize" -> `Normalize + [ IDENT "demodulate" -> `Demodulate + | IDENT "normalize" -> `Normalize | IDENT "reduce" -> `Reduce | IDENT "simplify" -> `Simpl | IDENT "unfold"; t = OPT term -> `Unfold t diff --git a/helm/ocaml/paramodulation/.depend b/helm/ocaml/paramodulation/.depend deleted file mode 100644 index 7c6673bad..000000000 --- a/helm/ocaml/paramodulation/.depend +++ /dev/null @@ -1,12 +0,0 @@ -inference.cmi: utils.cmi -equality_indexing.cmi: utils.cmi inference.cmi -utils.cmo: utils.cmi -utils.cmx: utils.cmi -inference.cmo: utils.cmi inference.cmi -inference.cmx: utils.cmx inference.cmi -equality_indexing.cmo: utils.cmi inference.cmi equality_indexing.cmi -equality_indexing.cmx: utils.cmx inference.cmx equality_indexing.cmi -indexing.cmo: utils.cmi inference.cmi equality_indexing.cmi -indexing.cmx: utils.cmx inference.cmx equality_indexing.cmx -saturation.cmo: utils.cmi inference.cmi indexing.cmo -saturation.cmx: utils.cmx inference.cmx indexing.cmx diff --git a/helm/ocaml/paramodulation/Makefile b/helm/ocaml/paramodulation/Makefile deleted file mode 100644 index 35b650ea7..000000000 --- a/helm/ocaml/paramodulation/Makefile +++ /dev/null @@ -1,38 +0,0 @@ -PACKAGE = paramodulation - -INTERFACE_FILES = \ - utils.mli \ - inference.mli\ - equality_indexing.mli - -IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) \ - indexing.ml \ - saturation.ml - -include ../Makefile.common - -paramodulation.cmo: $(IMPLEMENTATION_FILES:%.ml=%.cmo) - $(OCAMLC) -pack -o $@ $(IMPLEMENTATION_FILES:%.ml=%.cmo) - -paramodulation.cmx: OCAMLOPTIONS=-package "$(REQUIRES)" -predicates "$(PREDICATES)" -thread -paramodulation.cmx: $(IMPLEMENTATION_FILES:%.ml=%.cmx) - $(OCAMLOPT) -pack -o $@ $(IMPLEMENTATION_FILES:%.ml=%.cmx) - -OCAMLOPTIONS+=-for-pack Paramodulation - -$(ARCHIVE): paramodulation.cmo $(LIBRARIES) - $(OCAMLC) $(OCAMLARCHIVEOPTIONS) -a -o $@ \ - paramodulation.cmo - -$(ARCHIVE_OPT): paramodulation.cmx $(LIBRARIES_OPT) - $(OCAMLOPT) $(OCAMLARCHIVEOPTIONS) -a -o $@ \ - paramodulation.cmx - -PARAMOD_OBJS = $(IMPLEMENTATION_FILES:%.ml=%.cmo) -PARAMOD_OBJS_OPT = $(IMPLEMENTATION_FILES:%.ml=%.cmx) - -LOCALLINKOPTS = -package helm-cic_disambiguation,helm-content_pres,helm-grafite,helm-grafite_parser -saturate: saturate_main.ml $(PARAMOD_OBJS) $(LIBRARIES) - $(OCAMLC) $(LOCALLINKOPTS) -thread -linkpkg -o $@ $(PARAMOD_OBJS) $< -saturate.opt: saturate_main.ml $(PARAMOD_OBJS_OPT) $(LIBRARIES) - $(OCAMLOPT) $(LOCALLINKOPTS) -thread -linkpkg -o $@ $(PARAMOD_OBJS_OPT) $< diff --git a/helm/ocaml/paramodulation/README b/helm/ocaml/paramodulation/README deleted file mode 100644 index 98deef5ad..000000000 --- a/helm/ocaml/paramodulation/README +++ /dev/null @@ -1,43 +0,0 @@ -make saturate per compilare l'eseguibile da riga di comando (make saturate.opt per la versione ottimizzata) - -./saturate -h per vedere una lista di parametri: - -./saturate: unknown option `-h'. -Usage: - -full Enable full mode - -f Enable/disable full-reduction strategy (default: enabled) - -r Weight-Age equality selection ratio (default: 4) - -s symbols-based selection ratio (relative to the weight ratio, default: 0) - -c Configuration file (for the db connection) - -o Term ordering. Possible values are: - kbo: Knuth-Bendix ordering - nr-kbo: Non-recursive variant of kbo (default) - lpo: Lexicographic path ordering - -l Time limit in seconds (default: no limit) - -w Maximal width (default: 3) - -d Maximal depth (default: 3) - -retrieve retrieve only - -help Display this list of options - --help Display this list of options - - -./saturate -l 10 -demod-equalities - -dove -l 10 e` il timeout in secondi. - -Il programma legge da standard input il teorema, per esempio - -\forall n:nat.n + n = 2 * n - -l'input termina con una riga vuota (quindi basta un doppio invio alla fine) - -In output, oltre ai vari messaggi di debug, vengono stampati gli insiemi -active e passive alla fine dell'esecuzione. Consiglio di redirigere l'output -su file, per esempio usando tee: - -./saturate -l 10 -demod-equalities | tee output.txt - -Il formato di stampa e` quello per gli oggetti di tipo equality (usa la -funzione Inference.string_of_equality) - - diff --git a/helm/ocaml/paramodulation/equality_indexing.ml b/helm/ocaml/paramodulation/equality_indexing.ml deleted file mode 100644 index 1dffb6399..000000000 --- a/helm/ocaml/paramodulation/equality_indexing.ml +++ /dev/null @@ -1,131 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -module type EqualityIndex = - sig - module PosEqSet : Set.S with type elt = Utils.pos * Inference.equality - val arities : (Cic.term, int) Hashtbl.t - type key = Cic.term - type t = Discrimination_tree.DiscriminationTreeIndexing(PosEqSet).t - val empty : t - val retrieve_generalizations : t -> key -> PosEqSet.t - val retrieve_unifiables : t -> key -> PosEqSet.t - val init_index : unit -> unit - val remove_index : t -> Inference.equality -> t - val index : t -> Inference.equality -> t - val in_index : t -> Inference.equality -> bool - end - -module DT = -struct - module OrderedPosEquality = struct - type t = Utils.pos * Inference.equality - let compare = Pervasives.compare - end - - module PosEqSet = Set.Make(OrderedPosEquality);; - - include Discrimination_tree.DiscriminationTreeIndexing(PosEqSet) - - - (* DISCRIMINATION TREES *) - let init_index () = - Hashtbl.clear arities; - ;; - - let remove_index tree equality = - let _, _, (_, l, r, ordering), _, _ = equality in - match ordering with - | Utils.Gt -> remove_index tree l (Utils.Left, equality) - | Utils.Lt -> remove_index tree r (Utils.Right, equality) - | _ -> - let tree = remove_index tree r (Utils.Right, equality) in - remove_index tree l (Utils.Left, equality) - - let index tree equality = - let _, _, (_, l, r, ordering), _, _ = equality in - match ordering with - | Utils.Gt -> index tree l (Utils.Left, equality) - | Utils.Lt -> index tree r (Utils.Right, equality) - | _ -> - let tree = index tree r (Utils.Right, equality) in - index tree l (Utils.Left, equality) - - - let in_index tree equality = - let _, _, (_, l, r, ordering), _, _ = equality in - let meta_convertibility (pos,equality') = - Inference.meta_convertibility_eq equality equality' - in - in_index tree l meta_convertibility || in_index tree r meta_convertibility - - end - -module PT = - struct - module OrderedPosEquality = struct - type t = Utils.pos * Inference.equality - let compare = Pervasives.compare - end - - module PosEqSet = Set.Make(OrderedPosEquality);; - - include Discrimination_tree.DiscriminationTreeIndexing(PosEqSet) - - - (* DISCRIMINATION TREES *) - let init_index () = - Hashtbl.clear arities; - ;; - - let remove_index tree equality = - let _, _, (_, l, r, ordering), _, _ = equality in - match ordering with - | Utils.Gt -> remove_index tree l (Utils.Left, equality) - | Utils.Lt -> remove_index tree r (Utils.Right, equality) - | _ -> - let tree = remove_index tree r (Utils.Right, equality) in - remove_index tree l (Utils.Left, equality) - - let index tree equality = - let _, _, (_, l, r, ordering), _, _ = equality in - match ordering with - | Utils.Gt -> index tree l (Utils.Left, equality) - | Utils.Lt -> index tree r (Utils.Right, equality) - | _ -> - let tree = index tree r (Utils.Right, equality) in - index tree l (Utils.Left, equality) - - - let in_index tree equality = - let _, _, (_, l, r, ordering), _, _ = equality in - let meta_convertibility (pos,equality') = - Inference.meta_convertibility_eq equality equality' - in - in_index tree l meta_convertibility || in_index tree r meta_convertibility -end - diff --git a/helm/ocaml/paramodulation/equality_indexing.mli b/helm/ocaml/paramodulation/equality_indexing.mli deleted file mode 100644 index d7c3bec5e..000000000 --- a/helm/ocaml/paramodulation/equality_indexing.mli +++ /dev/null @@ -1,43 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -module type EqualityIndex = - sig - module PosEqSet : Set.S with type elt = Utils.pos * Inference.equality - val arities : (Cic.term, int) Hashtbl.t - type key = Cic.term - type t = Discrimination_tree.DiscriminationTreeIndexing(PosEqSet).t - val empty : t - val retrieve_generalizations : t -> key -> PosEqSet.t - val retrieve_unifiables : t -> key -> PosEqSet.t - val init_index : unit -> unit - val remove_index : t -> Inference.equality -> t - val index : t -> Inference.equality -> t - val in_index : t -> Inference.equality -> bool - end - -module DT : EqualityIndex -module PT : EqualityIndex - diff --git a/helm/ocaml/paramodulation/indexing.ml b/helm/ocaml/paramodulation/indexing.ml deleted file mode 100644 index 2d9076ad5..000000000 --- a/helm/ocaml/paramodulation/indexing.ml +++ /dev/null @@ -1,1021 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -module Index = Equality_indexing.DT (* discrimination tree based indexing *) -(* -module Index = Equality_indexing.DT (* path tree based indexing *) -*) - -let debug_print = Utils.debug_print;; - - -type retrieval_mode = Matching | Unification;; - -let print_candidates mode term res = - let _ = - match mode with - | Matching -> - Printf.printf "| candidates Matching %s\n" (CicPp.ppterm term) - | Unification -> - Printf.printf "| candidates Unification %s\n" (CicPp.ppterm term) - in - print_endline - (String.concat "\n" - (List.map - (fun (p, e) -> - Printf.sprintf "| (%s, %s)" (Utils.string_of_pos p) - (Inference.string_of_equality e)) - res)); - print_endline "|"; -;; - - -let indexing_retrieval_time = ref 0.;; - - -let apply_subst = CicMetaSubst.apply_subst - -let index = Index.index -let remove_index = Index.remove_index -let in_index = Index.in_index -let empty = Index.empty -let init_index = Index.init_index - -(* returns a list of all the equalities in the tree that are in relation - "mode" with the given term, where mode can be either Matching or - Unification. - - Format of the return value: list of tuples in the form: - (position - Left or Right - of the term that matched the given one in this - equality, - equality found) - - Note that if equality is "left = right", if the ordering is left > right, - the position will always be Left, and if the ordering is left < right, - position will be Right. -*) -let get_candidates mode tree term = - let t1 = Unix.gettimeofday () in - let res = - let s = - match mode with - | Matching -> Index.retrieve_generalizations tree term - | Unification -> Index.retrieve_unifiables tree term - in - Index.PosEqSet.elements s - in - (* print_candidates mode term res; *) -(* print_endline (Discrimination_tree.string_of_discrimination_tree tree); *) -(* print_newline (); *) - let t2 = Unix.gettimeofday () in - indexing_retrieval_time := !indexing_retrieval_time +. (t2 -. t1); - res -;; - - -let match_unif_time_ok = ref 0.;; -let match_unif_time_no = ref 0.;; - - -(* - finds the first equality in the index that matches "term", of type "termty" - termty can be Implicit if it is not needed. The result (one of the sides of - the equality, actually) should be not greater (wrt the term ordering) than - term - - Format of the return value: - - (term to substitute, [Cic.Rel 1 properly lifted - see the various - build_newtarget functions inside the various - demodulation_* functions] - substitution used for the matching, - metasenv, - ugraph, [substitution, metasenv and ugraph have the same meaning as those - returned by CicUnification.fo_unif] - (equality where the matching term was found, [i.e. the equality to use as - rewrite rule] - uri [either eq_ind_URI or eq_ind_r_URI, depending on the direction of - the equality: this is used to build the proof term, again see one of - the build_newtarget functions] - )) -*) -let rec find_matches metasenv context ugraph lift_amount term termty = - let module C = Cic in - let module U = Utils in - let module S = CicSubstitution in - let module M = CicMetaSubst in - let module HL = HelmLibraryObjects in - let cmp = !Utils.compare_terms in - let check = match termty with C.Implicit None -> false | _ -> true in - function - | [] -> None - | candidate::tl -> - let pos, (_, proof, (ty, left, right, o), metas, args) = candidate in - if check && not (fst (CicReduction.are_convertible - ~metasenv context termty ty ugraph)) then ( - find_matches metasenv context ugraph lift_amount term termty tl - ) else - let do_match c eq_URI = - let subst', metasenv', ugraph' = - let t1 = Unix.gettimeofday () in - try - let r = - Inference.matching (metasenv @ metas) context - term (S.lift lift_amount c) ugraph in - let t2 = Unix.gettimeofday () in - match_unif_time_ok := !match_unif_time_ok +. (t2 -. t1); - r - with Inference.MatchingFailure as e -> - let t2 = Unix.gettimeofday () in - match_unif_time_no := !match_unif_time_no +. (t2 -. t1); - raise e - in - Some (C.Rel (1 + lift_amount), subst', metasenv', ugraph', - (candidate, eq_URI)) - in - let c, other, eq_URI = - if pos = Utils.Left then left, right, Utils.eq_ind_URI () - else right, left, Utils.eq_ind_r_URI () - in - if o <> U.Incomparable then - try - do_match c eq_URI - with Inference.MatchingFailure -> - find_matches metasenv context ugraph lift_amount term termty tl - else - let res = - try do_match c eq_URI - with Inference.MatchingFailure -> None - in - match res with - | Some (_, s, _, _, _) -> - let c' = apply_subst s c in - let other' = U.guarded_simpl context (apply_subst s other) in - let order = cmp c' other' in - let names = U.names_of_context context in - if order = U.Gt then - res - else - find_matches - metasenv context ugraph lift_amount term termty tl - | None -> - find_matches metasenv context ugraph lift_amount term termty tl -;; - - -(* - as above, but finds all the matching equalities, and the matching condition - can be either Inference.matching or Inference.unification -*) -let rec find_all_matches ?(unif_fun=Inference.unification) - metasenv context ugraph lift_amount term termty = - let module C = Cic in - let module U = Utils in - let module S = CicSubstitution in - let module M = CicMetaSubst in - let module HL = HelmLibraryObjects in - let cmp = !Utils.compare_terms in - function - | [] -> [] - | candidate::tl -> - let pos, (_, _, (ty, left, right, o), metas, args) = candidate in - let do_match c eq_URI = - let subst', metasenv', ugraph' = - let t1 = Unix.gettimeofday () in - try - let r = - unif_fun (metasenv @ metas) context - term (S.lift lift_amount c) ugraph in - let t2 = Unix.gettimeofday () in - match_unif_time_ok := !match_unif_time_ok +. (t2 -. t1); - r - with - | Inference.MatchingFailure - | CicUnification.UnificationFailure _ - | CicUnification.Uncertain _ as e -> - let t2 = Unix.gettimeofday () in - match_unif_time_no := !match_unif_time_no +. (t2 -. t1); - raise e - in - (C.Rel (1 + lift_amount), subst', metasenv', ugraph', - (candidate, eq_URI)) - in - let c, other, eq_URI = - if pos = Utils.Left then left, right, Utils.eq_ind_URI () - else right, left, Utils.eq_ind_r_URI () - in - if o <> U.Incomparable then - try - let res = do_match c eq_URI in - res::(find_all_matches ~unif_fun metasenv context ugraph - lift_amount term termty tl) - with - | Inference.MatchingFailure - | CicUnification.UnificationFailure _ - | CicUnification.Uncertain _ -> - find_all_matches ~unif_fun metasenv context ugraph - lift_amount term termty tl - else - try - let res = do_match c eq_URI in - match res with - | _, s, _, _, _ -> - let c' = apply_subst s c - and other' = apply_subst s other in - let order = cmp c' other' in - let names = U.names_of_context context in - if order <> U.Lt && order <> U.Le then - res::(find_all_matches ~unif_fun metasenv context ugraph - lift_amount term termty tl) - else - find_all_matches ~unif_fun metasenv context ugraph - lift_amount term termty tl - with - | Inference.MatchingFailure - | CicUnification.UnificationFailure _ - | CicUnification.Uncertain _ -> - find_all_matches ~unif_fun metasenv context ugraph - lift_amount term termty tl -;; - - -(* - returns true if target is subsumed by some equality in table -*) -let subsumption env table target = - let _, _, (ty, left, right, _), tmetas, _ = target in - let metasenv, context, ugraph = env in - let metasenv = metasenv @ tmetas in - let samesubst subst subst' = - let tbl = Hashtbl.create (List.length subst) in - List.iter (fun (m, (c, t1, t2)) -> Hashtbl.add tbl m (c, t1, t2)) subst; - List.for_all - (fun (m, (c, t1, t2)) -> - try - let c', t1', t2' = Hashtbl.find tbl m in - if (c = c') && (t1 = t1') && (t2 = t2') then true - else false - with Not_found -> - true) - subst' - in - let leftr = - match left with - | Cic.Meta _ -> [] - | _ -> - let leftc = get_candidates Matching table left in - find_all_matches ~unif_fun:Inference.matching - metasenv context ugraph 0 left ty leftc - in - let rec ok what = function - | [] -> false, [] - | (_, subst, menv, ug, ((pos, (_, _, (_, l, r, o), m, _)), _))::tl -> - try - let other = if pos = Utils.Left then r else l in - let subst', menv', ug' = - let t1 = Unix.gettimeofday () in - try - let r = - Inference.matching (metasenv @ menv @ m) context what other ugraph - in - let t2 = Unix.gettimeofday () in - match_unif_time_ok := !match_unif_time_ok +. (t2 -. t1); - r - with Inference.MatchingFailure as e -> - let t2 = Unix.gettimeofday () in - match_unif_time_no := !match_unif_time_no +. (t2 -. t1); - raise e - in - if samesubst subst subst' then - true, subst - else - ok what tl - with Inference.MatchingFailure -> - ok what tl - in - let r, subst = ok right leftr in - let r, s = - if r then - true, subst - else - let rightr = - match right with - | Cic.Meta _ -> [] - | _ -> - let rightc = get_candidates Matching table right in - find_all_matches ~unif_fun:Inference.matching - metasenv context ugraph 0 right ty rightc - in - ok left rightr - in -(* (if r then *) -(* debug_print *) -(* (lazy *) -(* (Printf.sprintf "SUBSUMPTION! %s\n%s\n" *) -(* (Inference.string_of_equality target) (Utils.print_subst s)))); *) - r, s -;; - - -let rec demodulation_aux ?(typecheck=false) - metasenv context ugraph table lift_amount term = - let module C = Cic in - let module S = CicSubstitution in - let module M = CicMetaSubst in - let module HL = HelmLibraryObjects in - let candidates = get_candidates Matching table term in - match term with - | C.Meta _ -> None - | term -> - let termty, ugraph = - if typecheck then - CicTypeChecker.type_of_aux' metasenv context term ugraph - else - C.Implicit None, ugraph - in - let res = - find_matches metasenv context ugraph lift_amount term termty candidates - in - if res <> None then - res - else - match term with - | C.Appl l -> - let res, ll = - List.fold_left - (fun (res, tl) t -> - if res <> None then - (res, tl @ [S.lift 1 t]) - else - let r = - demodulation_aux metasenv context ugraph table - lift_amount t - in - match r with - | None -> (None, tl @ [S.lift 1 t]) - | Some (rel, _, _, _, _) -> (r, tl @ [rel])) - (None, []) l - in ( - match res with - | None -> None - | Some (_, subst, menv, ug, eq_found) -> - Some (C.Appl ll, subst, menv, ug, eq_found) - ) - | C.Prod (nn, s, t) -> - let r1 = - demodulation_aux metasenv context ugraph table lift_amount s in ( - match r1 with - | None -> - let r2 = - demodulation_aux metasenv - ((Some (nn, C.Decl s))::context) ugraph - table (lift_amount+1) t - in ( - match r2 with - | None -> None - | Some (t', subst, menv, ug, eq_found) -> - Some (C.Prod (nn, (S.lift 1 s), t'), - subst, menv, ug, eq_found) - ) - | Some (s', subst, menv, ug, eq_found) -> - Some (C.Prod (nn, s', (S.lift 1 t)), - subst, menv, ug, eq_found) - ) - | C.Lambda (nn, s, t) -> - let r1 = - demodulation_aux metasenv context ugraph table lift_amount s in ( - match r1 with - | None -> - let r2 = - demodulation_aux metasenv - ((Some (nn, C.Decl s))::context) ugraph - table (lift_amount+1) t - in ( - match r2 with - | None -> None - | Some (t', subst, menv, ug, eq_found) -> - Some (C.Lambda (nn, (S.lift 1 s), t'), - subst, menv, ug, eq_found) - ) - | Some (s', subst, menv, ug, eq_found) -> - Some (C.Lambda (nn, s', (S.lift 1 t)), - subst, menv, ug, eq_found) - ) - | t -> - None -;; - - -let build_newtarget_time = ref 0.;; - - -let demod_counter = ref 1;; - -(** demodulation, when target is an equality *) -let rec demodulation_equality newmeta env table sign target = - let module C = Cic in - let module S = CicSubstitution in - let module M = CicMetaSubst in - let module HL = HelmLibraryObjects in - let module U = Utils in - let metasenv, context, ugraph = env in - let _, proof, (eq_ty, left, right, order), metas, args = target in - let metasenv' = metasenv @ metas in - - let maxmeta = ref newmeta in - - let build_newtarget is_left (t, subst, menv, ug, (eq_found, eq_URI)) = - let time1 = Unix.gettimeofday () in - - let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in - let ty = - try fst (CicTypeChecker.type_of_aux' metasenv context what ugraph) - with CicUtil.Meta_not_found _ -> ty - in - let what, other = if pos = Utils.Left then what, other else other, what in - let newterm, newproof = - let bo = U.guarded_simpl context (apply_subst subst (S.subst other t)) in - let name = C.Name ("x_Demod_" ^ (string_of_int !demod_counter)) in - incr demod_counter; - let bo' = - let l, r = if is_left then t, S.lift 1 right else S.lift 1 left, t in - C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []); - S.lift 1 eq_ty; l; r] - in - if sign = Utils.Positive then - (bo, - Inference.ProofBlock ( - subst, eq_URI, (name, ty), bo'(* t' *), eq_found, proof)) - else - let metaproof = - incr maxmeta; - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context in -(* debug_print (lazy (Printf.sprintf "\nADDING META: %d\n" !maxmeta)); *) -(* print_newline (); *) - C.Meta (!maxmeta, irl) - in - let eq_found = - let proof' = - let termlist = - if pos = Utils.Left then [ty; what; other] - else [ty; other; what] - in - Inference.ProofSymBlock (termlist, proof') - in - let what, other = - if pos = Utils.Left then what, other else other, what - in - pos, (0, proof', (ty, other, what, Utils.Incomparable), - menv', args') - in - let target_proof = - let pb = - Inference.ProofBlock (subst, eq_URI, (name, ty), bo', - eq_found, Inference.BasicProof metaproof) - in - match proof with - | Inference.BasicProof _ -> - print_endline "replacing a BasicProof"; - pb - | Inference.ProofGoalBlock (_, parent_proof) -> - print_endline "replacing another ProofGoalBlock"; - Inference.ProofGoalBlock (pb, parent_proof) - | _ -> assert false - in - let refl = - C.Appl [C.MutConstruct (* reflexivity *) - (LibraryObjects.eq_URI (), 0, 1, []); - eq_ty; if is_left then right else left] - in - (bo, - Inference.ProofGoalBlock (Inference.BasicProof refl, target_proof)) - in - let left, right = if is_left then newterm, right else left, newterm in - let m = (Inference.metas_of_term left) @ (Inference.metas_of_term right) in - let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) metas - and newargs = args - in - let ordering = !Utils.compare_terms left right in - - let time2 = Unix.gettimeofday () in - build_newtarget_time := !build_newtarget_time +. (time2 -. time1); - - let res = - let w = Utils.compute_equality_weight eq_ty left right in - (w, newproof, (eq_ty, left, right, ordering), newmetasenv, newargs) - in - !maxmeta, res - in - let res = demodulation_aux metasenv' context ugraph table 0 left in - let newmeta, newtarget = - match res with - | Some t -> - let newmeta, newtarget = build_newtarget true t in - if (Inference.is_identity (metasenv', context, ugraph) newtarget) || - (Inference.meta_convertibility_eq target newtarget) then - newmeta, newtarget - else - demodulation_equality newmeta env table sign newtarget - | None -> - let res = demodulation_aux metasenv' context ugraph table 0 right in - match res with - | Some t -> - let newmeta, newtarget = build_newtarget false t in - if (Inference.is_identity (metasenv', context, ugraph) newtarget) || - (Inference.meta_convertibility_eq target newtarget) then - newmeta, newtarget - else - demodulation_equality newmeta env table sign newtarget - | None -> - newmeta, target - in - (* newmeta, newtarget *) - (* tentiamo di ridurre usando CicReduction.normalize *) - let w, p, (ty, left, right, o), m, a = newtarget in - let left' = ProofEngineReduction.simpl context left in - let right' = ProofEngineReduction.simpl context right in - let newleft = - if !Utils.compare_terms left' left = Utils.Lt then left' else left in - let newright = - if !Utils.compare_terms right' right = Utils.Lt then right' else right in -(* if newleft != left || newright != right then ( *) -(* debug_print *) -(* (lazy *) -(* (Printf.sprintf "left: %s, left': %s\nright: %s, right': %s\n" *) -(* (CicPp.ppterm left) (CicPp.ppterm left') (CicPp.ppterm right) *) -(* (CicPp.ppterm right'))) *) -(* ); *) - let w' = Utils.compute_equality_weight ty newleft newright in - let o' = !Utils.compare_terms newleft newright in - newmeta, (w', p, (ty, newleft, newright, o'), m, a) -;; - - -(** - Performs the beta expansion of the term "term" w.r.t. "table", - i.e. returns the list of all the terms t s.t. "(t term) = t2", for some t2 - in table. -*) -let rec betaexpand_term metasenv context ugraph table lift_amount term = - let module C = Cic in - let module S = CicSubstitution in - let module M = CicMetaSubst in - let module HL = HelmLibraryObjects in - let candidates = get_candidates Unification table term in - let res, lifted_term = - match term with - | C.Meta (i, l) -> - let l', lifted_l = - List.fold_right - (fun arg (res, lifted_tl) -> - match arg with - | Some arg -> - let arg_res, lifted_arg = - betaexpand_term metasenv context ugraph table - lift_amount arg in - let l1 = - List.map - (fun (t, s, m, ug, eq_found) -> - (Some t)::lifted_tl, s, m, ug, eq_found) - arg_res - in - (l1 @ - (List.map - (fun (l, s, m, ug, eq_found) -> - (Some lifted_arg)::l, s, m, ug, eq_found) - res), - (Some lifted_arg)::lifted_tl) - | None -> - (List.map - (fun (r, s, m, ug, eq_found) -> - None::r, s, m, ug, eq_found) res, - None::lifted_tl) - ) l ([], []) - in - let e = - List.map - (fun (l, s, m, ug, eq_found) -> - (C.Meta (i, l), s, m, ug, eq_found)) l' - in - e, C.Meta (i, lifted_l) - - | C.Rel m -> - [], if m <= lift_amount then C.Rel m else C.Rel (m+1) - - | C.Prod (nn, s, t) -> - let l1, lifted_s = - betaexpand_term metasenv context ugraph table lift_amount s in - let l2, lifted_t = - betaexpand_term metasenv ((Some (nn, C.Decl s))::context) ugraph - table (lift_amount+1) t in - let l1' = - List.map - (fun (t, s, m, ug, eq_found) -> - C.Prod (nn, t, lifted_t), s, m, ug, eq_found) l1 - and l2' = - List.map - (fun (t, s, m, ug, eq_found) -> - C.Prod (nn, lifted_s, t), s, m, ug, eq_found) l2 in - l1' @ l2', C.Prod (nn, lifted_s, lifted_t) - - | C.Lambda (nn, s, t) -> - let l1, lifted_s = - betaexpand_term metasenv context ugraph table lift_amount s in - let l2, lifted_t = - betaexpand_term metasenv ((Some (nn, C.Decl s))::context) ugraph - table (lift_amount+1) t in - let l1' = - List.map - (fun (t, s, m, ug, eq_found) -> - C.Lambda (nn, t, lifted_t), s, m, ug, eq_found) l1 - and l2' = - List.map - (fun (t, s, m, ug, eq_found) -> - C.Lambda (nn, lifted_s, t), s, m, ug, eq_found) l2 in - l1' @ l2', C.Lambda (nn, lifted_s, lifted_t) - - | C.Appl l -> - let l', lifted_l = - List.fold_right - (fun arg (res, lifted_tl) -> - let arg_res, lifted_arg = - betaexpand_term metasenv context ugraph table lift_amount arg - in - let l1 = - List.map - (fun (a, s, m, ug, eq_found) -> - a::lifted_tl, s, m, ug, eq_found) - arg_res - in - (l1 @ - (List.map - (fun (r, s, m, ug, eq_found) -> - lifted_arg::r, s, m, ug, eq_found) - res), - lifted_arg::lifted_tl) - ) l ([], []) - in - (List.map - (fun (l, s, m, ug, eq_found) -> (C.Appl l, s, m, ug, eq_found)) l', - C.Appl lifted_l) - - | t -> [], (S.lift lift_amount t) - in - match term with - | C.Meta (i, l) -> res, lifted_term - | term -> - let termty, ugraph = - C.Implicit None, ugraph -(* CicTypeChecker.type_of_aux' metasenv context term ugraph *) - in - let r = - find_all_matches - metasenv context ugraph lift_amount term termty candidates - in - r @ res, lifted_term -;; - - -let sup_l_counter = ref 1;; - -(** - superposition_left - returns a list of new clauses inferred with a left superposition step - the negative equation "target" and one of the positive equations in "table" -*) -let superposition_left newmeta (metasenv, context, ugraph) table target = - let module C = Cic in - let module S = CicSubstitution in - let module M = CicMetaSubst in - let module HL = HelmLibraryObjects in - let module CR = CicReduction in - let module U = Utils in - let weight, proof, (eq_ty, left, right, ordering), _, _ = target in - let expansions, _ = - let term = if ordering = U.Gt then left else right in - betaexpand_term metasenv context ugraph table 0 term - in - let maxmeta = ref newmeta in - let build_new (bo, s, m, ug, (eq_found, eq_URI)) = - -(* debug_print (lazy "\nSUPERPOSITION LEFT\n"); *) - - let time1 = Unix.gettimeofday () in - - let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in - let what, other = if pos = Utils.Left then what, other else other, what in - let newgoal, newproof = - let bo' = U.guarded_simpl context (apply_subst s (S.subst other bo)) in - let name = C.Name ("x_SupL_" ^ (string_of_int !sup_l_counter)) in - incr sup_l_counter; - let bo'' = - let l, r = - if ordering = U.Gt then bo, S.lift 1 right else S.lift 1 left, bo in - C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []); - S.lift 1 eq_ty; l; r] - in - incr maxmeta; - let metaproof = - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context in - C.Meta (!maxmeta, irl) - in - let eq_found = - let proof' = - let termlist = - if pos = Utils.Left then [ty; what; other] - else [ty; other; what] - in - Inference.ProofSymBlock (termlist, proof') - in - let what, other = - if pos = Utils.Left then what, other else other, what - in - pos, (0, proof', (ty, other, what, Utils.Incomparable), menv', args') - in - let target_proof = - let pb = - Inference.ProofBlock (s, eq_URI, (name, ty), bo'', eq_found, - Inference.BasicProof metaproof) - in - match proof with - | Inference.BasicProof _ -> -(* debug_print (lazy "replacing a BasicProof"); *) - pb - | Inference.ProofGoalBlock (_, parent_proof) -> -(* debug_print (lazy "replacing another ProofGoalBlock"); *) - Inference.ProofGoalBlock (pb, parent_proof) - | _ -> assert false - in - let refl = - C.Appl [C.MutConstruct (* reflexivity *) - (LibraryObjects.eq_URI (), 0, 1, []); - eq_ty; if ordering = U.Gt then right else left] - in - (bo', - Inference.ProofGoalBlock (Inference.BasicProof refl, target_proof)) - in - let left, right = - if ordering = U.Gt then newgoal, right else left, newgoal in - let neworder = !Utils.compare_terms left right in - - let time2 = Unix.gettimeofday () in - build_newtarget_time := !build_newtarget_time +. (time2 -. time1); - - let res = - let w = Utils.compute_equality_weight eq_ty left right in - (w, newproof, (eq_ty, left, right, neworder), [], []) - in - res - in - !maxmeta, List.map build_new expansions -;; - - -let sup_r_counter = ref 1;; - -(** - superposition_right - returns a list of new clauses inferred with a right superposition step - between the positive equation "target" and one in the "table" "newmeta" is - the first free meta index, i.e. the first number above the highest meta - index: its updated value is also returned -*) -let superposition_right newmeta (metasenv, context, ugraph) table target = - let module C = Cic in - let module S = CicSubstitution in - let module M = CicMetaSubst in - let module HL = HelmLibraryObjects in - let module CR = CicReduction in - let module U = Utils in - let _, eqproof, (eq_ty, left, right, ordering), newmetas, args = target in - let metasenv' = metasenv @ newmetas in - let maxmeta = ref newmeta in - let res1, res2 = - match ordering with - | U.Gt -> fst (betaexpand_term metasenv' context ugraph table 0 left), [] - | U.Lt -> [], fst (betaexpand_term metasenv' context ugraph table 0 right) - | _ -> - let res l r = - List.filter - (fun (_, subst, _, _, _) -> - let subst = apply_subst subst in - let o = !Utils.compare_terms (subst l) (subst r) in - o <> U.Lt && o <> U.Le) - (fst (betaexpand_term metasenv' context ugraph table 0 l)) - in - (res left right), (res right left) - in - let build_new ordering (bo, s, m, ug, (eq_found, eq_URI)) = - - let time1 = Unix.gettimeofday () in - - let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in - let what, other = if pos = Utils.Left then what, other else other, what in - let newgoal, newproof = - let bo' = apply_subst s (S.subst other bo) in - let t' = - let name = C.Name ("x_SupR_" ^ (string_of_int !sup_r_counter)) in - incr sup_r_counter; - let l, r = - if ordering = U.Gt then bo, S.lift 1 right else S.lift 1 left, bo in - (name, ty, S.lift 1 eq_ty, l, r) - in - let name = C.Name ("x_SupR_" ^ (string_of_int !sup_r_counter)) in - incr sup_r_counter; - let bo'' = - let l, r = - if ordering = U.Gt then bo, S.lift 1 right else S.lift 1 left, bo in - C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []); - S.lift 1 eq_ty; l; r] - in - bo', - Inference.ProofBlock (s, eq_URI, (name, ty), bo'', eq_found, eqproof) - in - let newmeta, newequality = - let left, right = - if ordering = U.Gt then newgoal, apply_subst s right - else apply_subst s left, newgoal in - let neworder = !Utils.compare_terms left right - and newmenv = newmetas @ menv' - and newargs = args @ args' in - let eq' = - let w = Utils.compute_equality_weight eq_ty left right in - (w, newproof, (eq_ty, left, right, neworder), newmenv, newargs) - and env = (metasenv, context, ugraph) in - let newm, eq' = Inference.fix_metas !maxmeta eq' in - newm, eq' - in - maxmeta := newmeta; - - let time2 = Unix.gettimeofday () in - build_newtarget_time := !build_newtarget_time +. (time2 -. time1); - - newequality - in - let new1 = List.map (build_new U.Gt) res1 - and new2 = List.map (build_new U.Lt) res2 in - let ok e = not (Inference.is_identity (metasenv, context, ugraph) e) in - (!maxmeta, - (List.filter ok (new1 @ new2))) -;; - - -(** demodulation, when the target is a goal *) -let rec demodulation_goal newmeta env table goal = - let module C = Cic in - let module S = CicSubstitution in - let module M = CicMetaSubst in - let module HL = HelmLibraryObjects in - let metasenv, context, ugraph = env in - let maxmeta = ref newmeta in - let proof, metas, term = goal in - let metasenv' = metasenv @ metas in - - let build_newgoal (t, subst, menv, ug, (eq_found, eq_URI)) = - let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in - let what, other = if pos = Utils.Left then what, other else other, what in - let ty = - try fst (CicTypeChecker.type_of_aux' metasenv context what ugraph) - with CicUtil.Meta_not_found _ -> ty - in - let newterm, newproof = - let bo = apply_subst subst (S.subst other t) in - let bo' = apply_subst subst t in - let name = C.Name ("x_DemodGoal_" ^ (string_of_int !demod_counter)) in - incr demod_counter; - let metaproof = - incr maxmeta; - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context in -(* debug_print (lazy (Printf.sprintf "\nADDING META: %d\n" !maxmeta)); *) - C.Meta (!maxmeta, irl) - in - let eq_found = - let proof' = - let termlist = - if pos = Utils.Left then [ty; what; other] - else [ty; other; what] - in - Inference.ProofSymBlock (termlist, proof') - in - let what, other = - if pos = Utils.Left then what, other else other, what - in - pos, (0, proof', (ty, other, what, Utils.Incomparable), menv', args') - in - let goal_proof = - let pb = - Inference.ProofBlock (subst, eq_URI, (name, ty), bo', - eq_found, Inference.BasicProof metaproof) - in - let rec repl = function - | Inference.NoProof -> -(* debug_print (lazy "replacing a NoProof"); *) - pb - | Inference.BasicProof _ -> -(* debug_print (lazy "replacing a BasicProof"); *) - pb - | Inference.ProofGoalBlock (_, parent_proof) -> -(* debug_print (lazy "replacing another ProofGoalBlock"); *) - Inference.ProofGoalBlock (pb, parent_proof) - | (Inference.SubProof (term, meta_index, p) as subproof) -> -(* debug_print *) -(* (lazy *) -(* (Printf.sprintf "replacing %s" *) -(* (Inference.string_of_proof subproof))); *) - Inference.SubProof (term, meta_index, repl p) - | _ -> assert false - in repl proof - in - bo, Inference.ProofGoalBlock (Inference.NoProof, goal_proof) - in - let m = Inference.metas_of_term newterm in - let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) metas in - !maxmeta, (newproof, newmetasenv, newterm) - in - let res = - demodulation_aux ~typecheck:true metasenv' context ugraph table 0 term - in - match res with - | Some t -> - let newmeta, newgoal = build_newgoal t in - let _, _, newg = newgoal in - if Inference.meta_convertibility term newg then - newmeta, newgoal - else - demodulation_goal newmeta env table newgoal - | None -> - newmeta, goal -;; - - -(** demodulation, when the target is a theorem *) -let rec demodulation_theorem newmeta env table theorem = - let module C = Cic in - let module S = CicSubstitution in - let module M = CicMetaSubst in - let module HL = HelmLibraryObjects in - let metasenv, context, ugraph = env in - let maxmeta = ref newmeta in - let proof, metas, term = theorem in - let term, termty, metas = theorem in - let metasenv' = metasenv @ metas in - - let build_newtheorem (t, subst, menv, ug, (eq_found, eq_URI)) = - let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in - let what, other = if pos = Utils.Left then what, other else other, what in - let newterm, newty = - let bo = apply_subst subst (S.subst other t) in - let bo' = apply_subst subst t in - let name = C.Name ("x_DemodThm_" ^ (string_of_int !demod_counter)) in - incr demod_counter; - let newproof = - Inference.ProofBlock (subst, eq_URI, (name, ty), bo', eq_found, - Inference.BasicProof term) - in - (Inference.build_proof_term newproof, bo) - in - let m = Inference.metas_of_term newterm in - let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) metas in - !maxmeta, (newterm, newty, newmetasenv) - in - let res = - demodulation_aux ~typecheck:true metasenv' context ugraph table 0 termty - in - match res with - | Some t -> - let newmeta, newthm = build_newtheorem t in - let newt, newty, _ = newthm in - if Inference.meta_convertibility termty newty then - newmeta, newthm - else - demodulation_theorem newmeta env table newthm - | None -> - newmeta, theorem -;; diff --git a/helm/ocaml/paramodulation/inference.ml b/helm/ocaml/paramodulation/inference.ml deleted file mode 100644 index 04cdb0aeb..000000000 --- a/helm/ocaml/paramodulation/inference.ml +++ /dev/null @@ -1,952 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -open Utils;; - - -type equality = - int * (* weight *) - proof * - (Cic.term * (* type *) - Cic.term * (* left side *) - Cic.term * (* right side *) - Utils.comparison) * (* ordering *) - Cic.metasenv * (* environment for metas *) - Cic.term list (* arguments *) - -and proof = - | NoProof - | BasicProof of Cic.term - | ProofBlock of - Cic.substitution * UriManager.uri * - (Cic.name * Cic.term) * Cic.term * (Utils.pos * equality) * proof - | ProofGoalBlock of proof * proof - | ProofSymBlock of Cic.term list * proof - | SubProof of Cic.term * int * proof -;; - - -let string_of_equality ?env = - match env with - | None -> ( - function - | w, _, (ty, left, right, o), _, _ -> - Printf.sprintf "Weight: %d, {%s}: %s =(%s) %s" w (CicPp.ppterm ty) - (CicPp.ppterm left) (string_of_comparison o) (CicPp.ppterm right) - ) - | Some (_, context, _) -> ( - let names = names_of_context context in - function - | w, _, (ty, left, right, o), _, _ -> - Printf.sprintf "Weight: %d, {%s}: %s =(%s) %s" w (CicPp.pp ty names) - (CicPp.pp left names) (string_of_comparison o) - (CicPp.pp right names) - ) -;; - - -let rec string_of_proof = function - | NoProof -> "NoProof" - | BasicProof t -> "BasicProof " ^ (CicPp.ppterm t) - | SubProof (t, i, p) -> - Printf.sprintf "SubProof(%s, %s, %s)" - (CicPp.ppterm t) (string_of_int i) (string_of_proof p) - | ProofSymBlock _ -> "ProofSymBlock" - | ProofBlock _ -> "ProofBlock" - | ProofGoalBlock (p1, p2) -> - Printf.sprintf "ProofGoalBlock(%s, %s)" - (string_of_proof p1) (string_of_proof p2) -;; - - -(* returns an explicit named subst and a list of arguments for sym_eq_URI *) -let build_ens_for_sym_eq sym_eq_URI termlist = - let obj, _ = CicEnvironment.get_obj CicUniv.empty_ugraph sym_eq_URI in - match obj with - | Cic.Constant (_, _, _, uris, _) -> - assert (List.length uris <= List.length termlist); - let rec aux = function - | [], tl -> [], tl - | (uri::uris), (term::tl) -> - let ens, args = aux (uris, tl) in - (uri, term)::ens, args - | _, _ -> assert false - in - aux (uris, termlist) - | _ -> assert false -;; - - -let build_proof_term proof = - let rec do_build_proof proof = - match proof with - | NoProof -> - Printf.fprintf stderr "WARNING: no proof!\n"; - Cic.Implicit None - | BasicProof term -> term - | ProofGoalBlock (proofbit, proof) -> - print_endline "found ProofGoalBlock, going up..."; - do_build_goal_proof proofbit proof - | ProofSymBlock (termlist, proof) -> - let proof = do_build_proof proof in - let ens, args = build_ens_for_sym_eq (Utils.sym_eq_URI ()) termlist in - Cic.Appl ([Cic.Const (Utils.sym_eq_URI (), ens)] @ args @ [proof]) - | ProofBlock (subst, eq_URI, (name, ty), bo, (pos, eq), eqproof) -> - let t' = Cic.Lambda (name, ty, bo) in - let proof' = - let _, proof', _, _, _ = eq in - do_build_proof proof' - in - let eqproof = do_build_proof eqproof in - let _, _, (ty, what, other, _), menv', args' = eq in - let what, other = - if pos = Utils.Left then what, other else other, what - in - CicMetaSubst.apply_subst subst - (Cic.Appl [Cic.Const (eq_URI, []); ty; - what; t'; eqproof; other; proof']) - | SubProof (term, meta_index, proof) -> - let proof = do_build_proof proof in - let eq i = function - | Cic.Meta (j, _) -> i = j - | _ -> false - in - ProofEngineReduction.replace - ~equality:eq ~what:[meta_index] ~with_what:[proof] ~where:term - - and do_build_goal_proof proofbit proof = - match proof with - | ProofGoalBlock (pb, p) -> - do_build_proof (ProofGoalBlock (replace_proof proofbit pb, p)) - | _ -> do_build_proof (replace_proof proofbit proof) - - and replace_proof newproof = function - | ProofBlock (subst, eq_URI, namety, bo, poseq, eqproof) -> - let eqproof' = replace_proof newproof eqproof in - ProofBlock (subst, eq_URI, namety, bo, poseq, eqproof') - | ProofGoalBlock (pb, p) -> - let pb' = replace_proof newproof pb in - ProofGoalBlock (pb', p) - | BasicProof _ -> newproof - | SubProof (term, meta_index, p) -> - SubProof (term, meta_index, replace_proof newproof p) - | p -> p - in - do_build_proof proof -;; - - -let rec metas_of_term = function - | Cic.Meta (i, c) -> [i] - | Cic.Var (_, ens) - | Cic.Const (_, ens) - | Cic.MutInd (_, _, ens) - | Cic.MutConstruct (_, _, _, ens) -> - List.flatten (List.map (fun (u, t) -> metas_of_term t) ens) - | Cic.Cast (s, t) - | Cic.Prod (_, s, t) - | Cic.Lambda (_, s, t) - | Cic.LetIn (_, s, t) -> (metas_of_term s) @ (metas_of_term t) - | Cic.Appl l -> List.flatten (List.map metas_of_term l) - | Cic.MutCase (uri, i, s, t, l) -> - (metas_of_term s) @ (metas_of_term t) @ - (List.flatten (List.map metas_of_term l)) - | Cic.Fix (i, il) -> - List.flatten - (List.map (fun (s, i, t1, t2) -> - (metas_of_term t1) @ (metas_of_term t2)) il) - | Cic.CoFix (i, il) -> - List.flatten - (List.map (fun (s, t1, t2) -> - (metas_of_term t1) @ (metas_of_term t2)) il) - | _ -> [] -;; - - -exception NotMetaConvertible;; - -let meta_convertibility_aux table t1 t2 = - let module C = Cic in - let print_table t = - String.concat ", " - (List.map - (fun (k, v) -> Printf.sprintf "(%d, %d)" k v) t) - in - let rec aux ((table_l, table_r) as table) t1 t2 = - match t1, t2 with - | C.Meta (m1, tl1), C.Meta (m2, tl2) -> - let m1_binding, table_l = - try List.assoc m1 table_l, table_l - with Not_found -> m2, (m1, m2)::table_l - and m2_binding, table_r = - try List.assoc m2 table_r, table_r - with Not_found -> m1, (m2, m1)::table_r - in - if (m1_binding <> m2) || (m2_binding <> m1) then - raise NotMetaConvertible - else ( - try - List.fold_left2 - (fun res t1 t2 -> - match t1, t2 with - | None, Some _ | Some _, None -> raise NotMetaConvertible - | None, None -> res - | Some t1, Some t2 -> (aux res t1 t2)) - (table_l, table_r) tl1 tl2 - with Invalid_argument _ -> - raise NotMetaConvertible - ) - | C.Var (u1, ens1), C.Var (u2, ens2) - | C.Const (u1, ens1), C.Const (u2, ens2) when (UriManager.eq u1 u2) -> - aux_ens table ens1 ens2 - | C.Cast (s1, t1), C.Cast (s2, t2) - | C.Prod (_, s1, t1), C.Prod (_, s2, t2) - | C.Lambda (_, s1, t1), C.Lambda (_, s2, t2) - | C.LetIn (_, s1, t1), C.LetIn (_, s2, t2) -> - let table = aux table s1 s2 in - aux table t1 t2 - | C.Appl l1, C.Appl l2 -> ( - try List.fold_left2 (fun res t1 t2 -> (aux res t1 t2)) table l1 l2 - with Invalid_argument _ -> raise NotMetaConvertible - ) - | C.MutInd (u1, i1, ens1), C.MutInd (u2, i2, ens2) - when (UriManager.eq u1 u2) && i1 = i2 -> aux_ens table ens1 ens2 - | C.MutConstruct (u1, i1, j1, ens1), C.MutConstruct (u2, i2, j2, ens2) - when (UriManager.eq u1 u2) && i1 = i2 && j1 = j2 -> - aux_ens table ens1 ens2 - | C.MutCase (u1, i1, s1, t1, l1), C.MutCase (u2, i2, s2, t2, l2) - when (UriManager.eq u1 u2) && i1 = i2 -> - let table = aux table s1 s2 in - let table = aux table t1 t2 in ( - try List.fold_left2 (fun res t1 t2 -> (aux res t1 t2)) table l1 l2 - with Invalid_argument _ -> raise NotMetaConvertible - ) - | C.Fix (i1, il1), C.Fix (i2, il2) when i1 = i2 -> ( - try - List.fold_left2 - (fun res (n1, i1, s1, t1) (n2, i2, s2, t2) -> - if i1 <> i2 then raise NotMetaConvertible - else - let res = (aux res s1 s2) in aux res t1 t2) - table il1 il2 - with Invalid_argument _ -> raise NotMetaConvertible - ) - | C.CoFix (i1, il1), C.CoFix (i2, il2) when i1 = i2 -> ( - try - List.fold_left2 - (fun res (n1, s1, t1) (n2, s2, t2) -> - let res = aux res s1 s2 in aux res t1 t2) - table il1 il2 - with Invalid_argument _ -> raise NotMetaConvertible - ) - | t1, t2 when t1 = t2 -> table - | _, _ -> raise NotMetaConvertible - - and aux_ens table ens1 ens2 = - let cmp (u1, t1) (u2, t2) = - compare (UriManager.string_of_uri u1) (UriManager.string_of_uri u2) - in - let ens1 = List.sort cmp ens1 - and ens2 = List.sort cmp ens2 in - try - List.fold_left2 - (fun res (u1, t1) (u2, t2) -> - if not (UriManager.eq u1 u2) then raise NotMetaConvertible - else aux res t1 t2) - table ens1 ens2 - with Invalid_argument _ -> raise NotMetaConvertible - in - aux table t1 t2 -;; - - -let meta_convertibility_eq eq1 eq2 = - let _, _, (ty, left, right, _), _, _ = eq1 - and _, _, (ty', left', right', _), _, _ = eq2 in - if ty <> ty' then - false - else if (left = left') && (right = right') then - true - else if (left = right') && (right = left') then - true - else - try - let table = meta_convertibility_aux ([], []) left left' in - let _ = meta_convertibility_aux table right right' in - true - with NotMetaConvertible -> - try - let table = meta_convertibility_aux ([], []) left right' in - let _ = meta_convertibility_aux table right left' in - true - with NotMetaConvertible -> - false -;; - - -let meta_convertibility t1 t2 = - let f t = - String.concat ", " - (List.map - (fun (k, v) -> Printf.sprintf "(%d, %d)" k v) t) - in - if t1 = t2 then - true - else - try - let l, r = meta_convertibility_aux ([], []) t1 t2 in - true - with NotMetaConvertible -> - false -;; - - -let rec check_irl start = function - | [] -> true - | None::tl -> check_irl (start+1) tl - | (Some (Cic.Rel x))::tl -> - if x = start then check_irl (start+1) tl else false - | _ -> false -;; - - -let rec is_simple_term = function - | Cic.Appl ((Cic.Meta _)::_) -> false - | Cic.Appl l -> List.for_all is_simple_term l - | Cic.Meta (i, l) -> check_irl 1 l - | Cic.Rel _ -> true - | Cic.Const _ -> true - | Cic.MutInd (_, _, []) -> true - | Cic.MutConstruct (_, _, _, []) -> true - | _ -> false -;; - - -let lookup_subst meta subst = - match meta with - | Cic.Meta (i, _) -> ( - try let _, (_, t, _) = List.find (fun (m, _) -> m = i) subst in t - with Not_found -> meta - ) - | _ -> assert false -;; - - -let unification_simple metasenv context t1 t2 ugraph = - let module C = Cic in - let module M = CicMetaSubst in - let module U = CicUnification in - let lookup = lookup_subst in - let rec occurs_check subst what where = - match where with - | t when what = t -> true - | C.Appl l -> List.exists (occurs_check subst what) l - | C.Meta _ -> - let t = lookup where subst in - if t <> where then occurs_check subst what t else false - | _ -> false - in - let rec unif subst menv s t = - let s = match s with C.Meta _ -> lookup s subst | _ -> s - and t = match t with C.Meta _ -> lookup t subst | _ -> t - in - match s, t with - | s, t when s = t -> subst, menv - | C.Meta (i, _), C.Meta (j, _) when i > j -> - unif subst menv t s - | C.Meta _, t when occurs_check subst s t -> - raise - (U.UnificationFailure (lazy "Inference.unification.unif")) - | C.Meta (i, l), t -> ( - try - let _, _, ty = CicUtil.lookup_meta i menv in - let subst = - if not (List.mem_assoc i subst) then (i, (context, t, ty))::subst - else subst - in - let menv = menv in (* List.filter (fun (m, _, _) -> i <> m) menv in *) - subst, menv - with CicUtil.Meta_not_found m -> - let names = names_of_context context in - debug_print - (lazy - (Printf.sprintf "Meta_not_found %d!: %s %s\n%s\n\n%s" m - (CicPp.pp t1 names) (CicPp.pp t2 names) - (print_metasenv menv) (print_metasenv metasenv))); - assert false - ) - | _, C.Meta _ -> unif subst menv t s - | C.Appl (hds::_), C.Appl (hdt::_) when hds <> hdt -> - raise (U.UnificationFailure (lazy "Inference.unification.unif")) - | C.Appl (hds::tls), C.Appl (hdt::tlt) -> ( - try - List.fold_left2 - (fun (subst', menv) s t -> unif subst' menv s t) - (subst, menv) tls tlt - with Invalid_argument _ -> - raise (U.UnificationFailure (lazy "Inference.unification.unif")) - ) - | _, _ -> - raise (U.UnificationFailure (lazy "Inference.unification.unif")) - in - let subst, menv = unif [] metasenv t1 t2 in - let menv = - List.filter - (fun (m, _, _) -> - try let _ = List.find (fun (i, _) -> m = i) subst in false - with Not_found -> true) - menv - in - List.rev subst, menv, ugraph -;; - - -let unification metasenv context t1 t2 ugraph = - let subst, menv, ug = - if not (is_simple_term t1) || not (is_simple_term t2) then ( - debug_print - (lazy - (Printf.sprintf "NOT SIMPLE TERMS: %s %s" - (CicPp.ppterm t1) (CicPp.ppterm t2))); - CicUnification.fo_unif metasenv context t1 t2 ugraph - ) else - unification_simple metasenv context t1 t2 ugraph - in - let rec fix_term = function - | (Cic.Meta (i, l) as t) -> - let t' = lookup_subst t subst in - if t <> t' then fix_term t' else t - | Cic.Appl l -> Cic.Appl (List.map fix_term l) - | t -> t - in - let rec fix_subst = function - | [] -> [] - | (i, (c, t, ty))::tl -> (i, (c, fix_term t, fix_term ty))::(fix_subst tl) - in - fix_subst subst, menv, ug -;; - - -let unification = CicUnification.fo_unif;; - -exception MatchingFailure;; - - -(* -let matching_simple metasenv context t1 t2 ugraph = - let module C = Cic in - let module M = CicMetaSubst in - let module U = CicUnification in - let lookup meta subst = - match meta with - | C.Meta (i, _) -> ( - try let _, (_, t, _) = List.find (fun (m, _) -> m = i) subst in t - with Not_found -> meta - ) - | _ -> assert false - in - let rec do_match subst menv s t = - match s, t with - | s, t when s = t -> subst, menv - | s, C.Meta (i, l) -> - let filter_menv i menv = - List.filter (fun (m, _, _) -> i <> m) menv - in - let subst, menv = - let value = lookup t subst in - match value with - | value when value = t -> - let _, _, ty = CicUtil.lookup_meta i menv in - (i, (context, s, ty))::subst, filter_menv i menv - | value when value <> s -> - raise MatchingFailure - | value -> do_match subst menv s value - in - subst, menv - | C.Appl ls, C.Appl lt -> ( - try - List.fold_left2 - (fun (subst, menv) s t -> do_match subst menv s t) - (subst, menv) ls lt - with Invalid_argument _ -> - raise MatchingFailure - ) - | _, _ -> - raise MatchingFailure - in - let subst, menv = do_match [] metasenv t1 t2 in - subst, menv, ugraph -;; -*) - - -let matching metasenv context t1 t2 ugraph = - try - let subst, metasenv, ugraph = - unification metasenv context t1 t2 ugraph - in - let t' = CicMetaSubst.apply_subst subst t1 in - if not (meta_convertibility t1 t') then - raise MatchingFailure - else - let metas = metas_of_term t1 in - let fix_subst = function - | (i, (c, Cic.Meta (j, lc), ty)) when List.mem i metas -> - (j, (c, Cic.Meta (i, lc), ty)) - | s -> s - in - let subst = List.map fix_subst subst in - subst, metasenv, ugraph - with - | CicUnification.UnificationFailure _ - | CicUnification.Uncertain _ -> - raise MatchingFailure -;; - - -let find_equalities context proof = - let module C = Cic in - let module S = CicSubstitution in - let module T = CicTypeChecker in - let eq_uri = LibraryObjects.eq_URI () in - let newmeta = ProofEngineHelpers.new_meta_of_proof ~proof in - let ok_types ty menv = - List.for_all (fun (_, _, mt) -> mt = ty) menv - in - let rec aux index newmeta = function - | [] -> [], newmeta - | (Some (_, C.Decl (term)))::tl -> - let do_find context term = - match term with - | C.Prod (name, s, t) -> - let (head, newmetas, args, newmeta) = - ProofEngineHelpers.saturate_term newmeta [] - context (S.lift index term) 0 - in - let p = - if List.length args = 0 then - C.Rel index - else - C.Appl ((C.Rel index)::args) - in ( - match head with - | C.Appl [C.MutInd (uri, _, _); ty; t1; t2] - when (UriManager.eq uri eq_uri) && (ok_types ty newmetas) -> - debug_print - (lazy - (Printf.sprintf "OK: %s" (CicPp.ppterm term))); - let o = !Utils.compare_terms t1 t2 in - let w = compute_equality_weight ty t1 t2 in - let proof = BasicProof p in - let e = (w, proof, (ty, t1, t2, o), newmetas, args) in - Some e, (newmeta+1) - | _ -> None, newmeta - ) - | C.Appl [C.MutInd (uri, _, _); ty; t1; t2] - when UriManager.eq uri eq_uri -> - let t1 = S.lift index t1 - and t2 = S.lift index t2 in - let o = !Utils.compare_terms t1 t2 in - let w = compute_equality_weight ty t1 t2 in - let e = (w, BasicProof (C.Rel index), (ty, t1, t2, o), [], []) in - Some e, (newmeta+1) - | _ -> None, newmeta - in ( - match do_find context term with - | Some p, newmeta -> - let tl, newmeta' = (aux (index+1) newmeta tl) in - (index, p)::tl, max newmeta newmeta' - | None, _ -> - aux (index+1) newmeta tl - ) - | _::tl -> - aux (index+1) newmeta tl - in - let il, maxm = aux 1 newmeta context in - let indexes, equalities = List.split il in - indexes, equalities, maxm -;; - - -(* -let equations_blacklist = - List.fold_left - (fun s u -> UriManager.UriSet.add (UriManager.uri_of_string u) s) - UriManager.UriSet.empty [ - "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)"; - "cic:/Coq/Init/Logic/trans_eq.con"; - "cic:/Coq/Init/Logic/f_equal.con"; - "cic:/Coq/Init/Logic/f_equal2.con"; - "cic:/Coq/Init/Logic/f_equal3.con"; - "cic:/Coq/Init/Logic/f_equal4.con"; - "cic:/Coq/Init/Logic/f_equal5.con"; - "cic:/Coq/Init/Logic/sym_eq.con"; - "cic:/Coq/Init/Logic/eq_ind.con"; - "cic:/Coq/Init/Logic/eq_ind_r.con"; - "cic:/Coq/Init/Logic/eq_rec.con"; - "cic:/Coq/Init/Logic/eq_rec_r.con"; - "cic:/Coq/Init/Logic/eq_rect.con"; - "cic:/Coq/Init/Logic/eq_rect_r.con"; - "cic:/Coq/Logic/Eqdep/UIP.con"; - "cic:/Coq/Logic/Eqdep/UIP_refl.con"; - "cic:/Coq/Logic/Eqdep_dec/eq2eqT.con"; - "cic:/Coq/ZArith/Zcompare/rename.con"; - (* ALB !!!! questo e` imbrogliare, ma x ora lo lasciamo cosi`... - perche' questo cacchio di teorema rompe le scatole :'( *) - "cic:/Rocq/SUBST/comparith/mult_n_2.con"; - - "cic:/matita/logic/equality/eq_f.con"; - "cic:/matita/logic/equality/eq_f2.con"; - "cic:/matita/logic/equality/eq_rec.con"; - "cic:/matita/logic/equality/eq_rect.con"; - ] -;; -*) -let equations_blacklist = UriManager.UriSet.empty;; - - -let find_library_equalities dbd context status maxmeta = - let module C = Cic in - let module S = CicSubstitution in - let module T = CicTypeChecker in - let blacklist = - List.fold_left - (fun s u -> UriManager.UriSet.add u s) - equations_blacklist - [eq_XURI (); sym_eq_URI (); trans_eq_URI (); eq_ind_URI (); - eq_ind_r_URI ()] - in - let candidates = - List.fold_left - (fun l uri -> - let suri = UriManager.string_of_uri uri in - if UriManager.UriSet.mem uri blacklist then - l - else - let t = CicUtil.term_of_uri uri in - let ty, _ = - CicTypeChecker.type_of_aux' [] context t CicUniv.empty_ugraph - in - (uri, t, ty)::l) - [] - (let t1 = Unix.gettimeofday () in - let eqs = (MetadataQuery.equations_for_goal ~dbd status) in - let t2 = Unix.gettimeofday () in - (debug_print - (lazy - (Printf.sprintf "Tempo di MetadataQuery.equations_for_goal: %.9f\n" - (t2 -. t1)))); - eqs) - in - let eq_uri1 = eq_XURI () - and eq_uri2 = LibraryObjects.eq_URI () in - let iseq uri = - (UriManager.eq uri eq_uri1) || (UriManager.eq uri eq_uri2) - in - let ok_types ty menv = - List.for_all (fun (_, _, mt) -> mt = ty) menv - in - let rec has_vars = function - | C.Meta _ | C.Rel _ | C.Const _ -> false - | C.Var _ -> true - | C.Appl l -> List.exists has_vars l - | C.Prod (_, s, t) | C.Lambda (_, s, t) - | C.LetIn (_, s, t) | C.Cast (s, t) -> - (has_vars s) || (has_vars t) - | _ -> false - in - let rec aux newmeta = function - | [] -> [], newmeta - | (uri, term, termty)::tl -> - debug_print - (lazy - (Printf.sprintf "Examining: %s (%s)" - (CicPp.ppterm term) (CicPp.ppterm termty))); - let res, newmeta = - match termty with - | C.Prod (name, s, t) when not (has_vars termty) -> - let head, newmetas, args, newmeta = - ProofEngineHelpers.saturate_term newmeta [] context termty 0 - in - let p = - if List.length args = 0 then - term - else - C.Appl (term::args) - in ( - match head with - | C.Appl [C.MutInd (uri, _, _); ty; t1; t2] - when (iseq uri) && (ok_types ty newmetas) -> - debug_print - (lazy - (Printf.sprintf "OK: %s" (CicPp.ppterm term))); - let o = !Utils.compare_terms t1 t2 in - let w = compute_equality_weight ty t1 t2 in - let proof = BasicProof p in - let e = (w, proof, (ty, t1, t2, o), newmetas, args) in - Some e, (newmeta+1) - | _ -> None, newmeta - ) - | C.Appl [C.MutInd (uri, _, _); ty; t1; t2] - when iseq uri && not (has_vars termty) -> - let o = !Utils.compare_terms t1 t2 in - let w = compute_equality_weight ty t1 t2 in - let e = (w, BasicProof term, (ty, t1, t2, o), [], []) in - Some e, (newmeta+1) - | _ -> None, newmeta - in - match res with - | Some e -> - let tl, newmeta' = aux newmeta tl in - (uri, e)::tl, max newmeta newmeta' - | None -> - aux newmeta tl - in - let found, maxm = aux maxmeta candidates in - let uriset, eqlist = - (List.fold_left - (fun (s, l) (u, e) -> - if List.exists (meta_convertibility_eq e) (List.map snd l) then ( - debug_print - (lazy - (Printf.sprintf "NO!! %s already there!" - (string_of_equality e))); - (UriManager.UriSet.add u s, l) - ) else (UriManager.UriSet.add u s, (u, e)::l)) - (UriManager.UriSet.empty, []) found) - in - uriset, eqlist, maxm -;; - - -let find_library_theorems dbd env status equalities_uris = - let module C = Cic in - let module S = CicSubstitution in - let module T = CicTypeChecker in - let blacklist = - let refl_equal = - UriManager.uri_of_string "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)" in - let s = - UriManager.UriSet.remove refl_equal - (UriManager.UriSet.union equalities_uris equations_blacklist) - in - List.fold_left - (fun s u -> UriManager.UriSet.add u s) - s [eq_XURI () ;sym_eq_URI (); trans_eq_URI (); eq_ind_URI (); - eq_ind_r_URI ()] - in - let metasenv, context, ugraph = env in - let candidates = - List.fold_left - (fun l uri -> - if UriManager.UriSet.mem uri blacklist then l - else - let t = CicUtil.term_of_uri uri in - let ty, _ = CicTypeChecker.type_of_aux' metasenv context t ugraph in - (t, ty, [])::l) - [] (MetadataQuery.signature_of_goal ~dbd status) - in - let refl_equal = - let u = eq_XURI () in - let t = CicUtil.term_of_uri u in - let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in - (t, ty, []) - in - refl_equal::candidates -;; - - -let find_context_hypotheses env equalities_indexes = - let metasenv, context, ugraph = env in - let _, res = - List.fold_left - (fun (n, l) entry -> - match entry with - | None -> (n+1, l) - | Some _ -> - if List.mem n equalities_indexes then - (n+1, l) - else - let t = Cic.Rel n in - let ty, _ = - CicTypeChecker.type_of_aux' metasenv context t ugraph in - (n+1, (t, ty, [])::l)) - (1, []) context - in - res -;; - - -let fix_metas newmeta ((w, p, (ty, left, right, o), menv, args) as equality) = - let table = Hashtbl.create (List.length args) in - let newargs, newmeta = - List.fold_right - (fun t (newargs, index) -> - match t with - | Cic.Meta (i, l) -> - if Hashtbl.mem table i then - let idx = Hashtbl.find table i in - ((Cic.Meta (idx, l))::newargs, index+1) - else - let _ = Hashtbl.add table i index in - ((Cic.Meta (index, l))::newargs, index+1) - | _ -> assert false) - args ([], newmeta+1) - in - let repl where = - ProofEngineReduction.replace ~equality:(=) ~what:args ~with_what:newargs - ~where - in - let menv' = - List.fold_right - (fun (i, context, term) menv -> - try - let index = Hashtbl.find table i in - (index, context, term)::menv - with Not_found -> - (i, context, term)::menv) - menv [] - in - let ty = repl ty - and left = repl left - and right = repl right in - let metas = (metas_of_term left) @ (metas_of_term right) in - let menv' = List.filter (fun (i, _, _) -> List.mem i metas) menv' in - let newargs = - List.filter - (function Cic.Meta (i, _) -> List.mem i metas | _ -> assert false) newargs - in - let _ = - if List.length metas > 0 then - let first = List.hd metas in - (* this new equality might have less variables than its parents: here - we fill the gap with a dummy arg. Example: - with (f X Y) = X we can simplify - (g X) = (f X Y) in - (g X) = X. - So the new equation has only one variable, but it still has type like - \lambda X,Y:..., so we need to pass a dummy arg for Y - (I hope this makes some sense...) - *) - Hashtbl.iter - (fun k v -> - if not (List.exists - (function Cic.Meta (i, _) -> i = v | _ -> assert false) - newargs) then - Hashtbl.replace table k first) - (Hashtbl.copy table) - in - let rec fix_proof = function - | NoProof -> NoProof - | BasicProof term -> BasicProof (repl term) - | ProofBlock (subst, eq_URI, namety, bo, (pos, eq), p) -> - let subst' = - List.fold_left - (fun s arg -> - match arg with - | Cic.Meta (i, l) -> ( - try - let j = Hashtbl.find table i in - if List.mem_assoc i subst then - s - else - let _, context, ty = CicUtil.lookup_meta i menv in - (i, (context, Cic.Meta (j, l), ty))::s - with Not_found | CicUtil.Meta_not_found _ -> - s - ) - | _ -> assert false) - [] args - in - ProofBlock (subst' @ subst, eq_URI, namety, bo(* t' *), (pos, eq), p) - | p -> assert false - in - let neweq = (w, fix_proof p, (ty, left, right, o), menv', newargs) in - (newmeta + 1, neweq) -;; - - -let term_is_equality term = - let iseq uri = UriManager.eq uri (LibraryObjects.eq_URI ()) in - match term with - | Cic.Appl [Cic.MutInd (uri, _, _); _; _; _] when iseq uri -> true - | _ -> false -;; - - -exception TermIsNotAnEquality;; - -let equality_of_term proof term = - let eq_uri = LibraryObjects.eq_URI () in - let iseq uri = UriManager.eq uri eq_uri in - match term with - | Cic.Appl [Cic.MutInd (uri, _, _); ty; t1; t2] when iseq uri -> - let o = !Utils.compare_terms t1 t2 in - let w = compute_equality_weight ty t1 t2 in - let e = (w, BasicProof proof, (ty, t1, t2, o), [], []) in - e - | _ -> - raise TermIsNotAnEquality -;; - - -type environment = Cic.metasenv * Cic.context * CicUniv.universe_graph;; - - -let is_identity ((metasenv, context, ugraph) as env) = function - | ((_, _, (ty, left, right, _), menv, _) as equality) -> - (left = right || - (* (meta_convertibility left right) || *) - (fst (CicReduction.are_convertible - ~metasenv:(metasenv @ menv) context left right ugraph))) -;; - - -let term_of_equality equality = - let _, _, (ty, left, right, _), menv, args = equality in - let eq i = function Cic.Meta (j, _) -> i = j | _ -> false in - let argsno = List.length args in - let t = - CicSubstitution.lift argsno - (Cic.Appl [Cic.MutInd (LibraryObjects.eq_URI (), 0, []); ty; left; right]) - in - snd ( - List.fold_right - (fun a (n, t) -> - match a with - | Cic.Meta (i, _) -> - let name = Cic.Name ("X" ^ (string_of_int n)) in - let _, _, ty = CicUtil.lookup_meta i menv in - let t = - ProofEngineReduction.replace - ~equality:eq ~what:[i] - ~with_what:[Cic.Rel (argsno - (n - 1))] ~where:t - in - (n-1, Cic.Prod (name, ty, t)) - | _ -> assert false) - args (argsno, t)) -;; diff --git a/helm/ocaml/paramodulation/inference.mli b/helm/ocaml/paramodulation/inference.mli deleted file mode 100644 index 30927dc72..000000000 --- a/helm/ocaml/paramodulation/inference.mli +++ /dev/null @@ -1,133 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -type equality = - int * (* weight *) - proof * (* proof *) - (Cic.term * (* type *) - Cic.term * (* left side *) - Cic.term * (* right side *) - Utils.comparison) * (* ordering *) - Cic.metasenv * (* environment for metas *) - Cic.term list (* arguments *) - -and proof = - | NoProof - | BasicProof of Cic.term (* already a proof of a goal *) - | ProofBlock of (* proof of a rewrite step *) - Cic.substitution * UriManager.uri * (* eq_ind or eq_ind_r *) - (Cic.name * Cic.term) * Cic.term * (Utils.pos * equality) * proof - | ProofGoalBlock of proof * proof - (* proof of the new meta, proof of the goal from which this comes *) - | ProofSymBlock of Cic.term list * proof (* expl.named subst, proof *) - | SubProof of Cic.term * int * proof - (* parent proof, subgoal, proof of the subgoal *) - -type environment = Cic.metasenv * Cic.context * CicUniv.universe_graph - -(** builds the Cic.term encoded by proof *) -val build_proof_term: proof -> Cic.term - -val string_of_proof: proof -> string - -exception MatchingFailure - -(** matching between two terms. Can raise MatchingFailure *) -val matching: - Cic.metasenv -> Cic.context -> Cic.term -> Cic.term -> - CicUniv.universe_graph -> - Cic.substitution * Cic.metasenv * CicUniv.universe_graph - -(** - special unification that checks if the two terms are "simple", and in - such case should be significantly faster than CicUnification.fo_unif -*) -val unification: - Cic.metasenv -> Cic.context -> Cic.term -> Cic.term -> - CicUniv.universe_graph -> - Cic.substitution * Cic.metasenv * CicUniv.universe_graph - - -(** - scans the context to find all Declarations "left = right"; returns a - list of tuples (proof, (type, left, right), newmetas). Uses - PrimitiveTactics.new_metasenv_for_apply to replace bound variables with - fresh metas... -*) -val find_equalities: - Cic.context -> ProofEngineTypes.proof -> int list * equality list * int - -(** - searches the library for equalities that can be applied to the current goal -*) -val find_library_equalities: - HMysql.dbd -> Cic.context -> ProofEngineTypes.status -> int -> - UriManager.UriSet.t * (UriManager.uri * equality) list * int - -(** - searches the library for theorems that are not equalities (returned by the - function above) -*) -val find_library_theorems: - HMysql.dbd -> environment -> ProofEngineTypes.status -> UriManager.UriSet.t -> - (Cic.term * Cic.term * Cic.metasenv) list - -(** - searches the context for hypotheses that are not equalities -*) -val find_context_hypotheses: - environment -> int list -> (Cic.term * Cic.term * Cic.metasenv) list - - -exception TermIsNotAnEquality;; - -(** - raises TermIsNotAnEquality if term is not an equation. - The first Cic.term is a proof of the equation -*) -val equality_of_term: Cic.term -> Cic.term -> equality - -(** - Re-builds the term corresponding to this equality -*) -val term_of_equality: equality -> Cic.term - -val term_is_equality: Cic.term -> bool - -(** tests a sort of alpha-convertibility between the two terms, but on the - metavariables *) -val meta_convertibility: Cic.term -> Cic.term -> bool - -(** meta convertibility between two equations *) -val meta_convertibility_eq: equality -> equality -> bool - -val is_identity: environment -> equality -> bool - -val string_of_equality: ?env:environment -> equality -> string - -val metas_of_term: Cic.term -> int list - -(** ensures that metavariables in equality are unique *) -val fix_metas: int -> equality -> int * equality diff --git a/helm/ocaml/paramodulation/saturate_main.ml b/helm/ocaml/paramodulation/saturate_main.ml deleted file mode 100644 index bec597645..000000000 --- a/helm/ocaml/paramodulation/saturate_main.ml +++ /dev/null @@ -1,161 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -module Trivial_disambiguate: -sig - exception Ambiguous_term of string Lazy.t - (** disambiguate an _unanmbiguous_ term using dummy callbacks which fail if a - * choice from the user is needed to disambiguate the term - * @raise Ambiguous_term for ambiguous term *) - val disambiguate_string: - dbd:HMysql.dbd -> - ?context:Cic.context -> - ?metasenv:Cic.metasenv -> - ?initial_ugraph:CicUniv.universe_graph -> - ?aliases:DisambiguateTypes.environment ->(* previous interpretation status*) - string -> - ((DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list * - Cic.metasenv * (* new metasenv *) - Cic.term * - CicUniv.universe_graph) list (* disambiguated term *) -end -= -struct - exception Ambiguous_term of string Lazy.t - exception Exit - module Callbacks = - struct - let non p x = not (p x) - let interactive_user_uri_choice ~selection_mode ?ok - ?(enable_button_for_non_vars = true) ~title ~msg ~id uris = - List.filter (non UriManager.uri_is_var) uris - let interactive_interpretation_choice interp = raise Exit - let input_or_locate_uri ~(title:string) ?id = raise Exit - end - module Disambiguator = Disambiguate.Make (Callbacks) - let disambiguate_string ~dbd ?(context = []) ?(metasenv = []) ?initial_ugraph - ?(aliases = DisambiguateTypes.Environment.empty) term - = - let ast = - CicNotationParser.parse_level2_ast (Ulexing.from_utf8_string term) - in - try - fst (Disambiguator.disambiguate_term ~dbd ~context ~metasenv ast - ?initial_ugraph ~aliases ~universe:None) - with Exit -> raise (Ambiguous_term (lazy term)) -end - -let configuration_file = ref "../../matita/matita.conf.xml";; - -let core_notation_script = "../../matita/core_notation.moo";; - -let get_from_user ~(dbd:HMysql.dbd) = - 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 (Trivial_disambiguate.disambiguate_string dbd term_string) 0 - in - term, metasenv, ugraph -;; - -let full = ref false;; - -let retrieve_only = ref false;; - -let demod_equalities = ref false;; - -let _ = - let module S = Saturation in - let set_ratio v = S.weight_age_ratio := v; S.weight_age_counter := v - and set_sel v = S.symbols_ratio := v; S.symbols_counter := v; - and set_conf f = configuration_file := f - and set_ordering o = - match o with - | "lpo" -> Utils.compare_terms := Utils.lpo - | "kbo" -> Utils.compare_terms := Utils.kbo - | "nr-kbo" -> Utils.compare_terms := Utils.nonrec_kbo - | "ao" -> Utils.compare_terms := Utils.ao - | o -> raise (Arg.Bad ("Unknown term ordering: " ^ o)) - and set_fullred b = S.use_fullred := b - and set_time_limit v = S.time_limit := float_of_int v - and set_width w = S.maxwidth := w - and set_depth d = S.maxdepth := d - and set_full () = full := true - and set_retrieve () = retrieve_only := true - and set_demod_equalities () = demod_equalities := true - in - Arg.parse [ - "-full", Arg.Unit set_full, "Enable full mode"; - "-f", Arg.Bool set_fullred, - "Enable/disable full-reduction strategy (default: enabled)"; - - "-r", Arg.Int set_ratio, "Weight-Age equality selection ratio (default: 4)"; - - "-s", Arg.Int set_sel, - "symbols-based selection ratio (relative to the weight ratio, default: 0)"; - - "-c", Arg.String set_conf, "Configuration file (for the db connection)"; - - "-o", Arg.String set_ordering, - "Term ordering. Possible values are:\n" ^ - "\tkbo: Knuth-Bendix ordering\n" ^ - "\tnr-kbo: Non-recursive variant of kbo (default)\n" ^ - "\tlpo: Lexicographic path ordering"; - - "-l", Arg.Int set_time_limit, "Time limit in seconds (default: no limit)"; - - "-w", Arg.Int set_width, - Printf.sprintf "Maximal width (default: %d)" !Saturation.maxwidth; - - "-d", Arg.Int set_depth, - Printf.sprintf "Maximal depth (default: %d)" !Saturation.maxdepth; - - "-retrieve", Arg.Unit set_retrieve, "retrieve only"; - "-demod-equalities", Arg.Unit set_demod_equalities, "demod equalities"; - ] (fun a -> ()) "Usage:" -in -Helm_registry.load_from !configuration_file; -ignore (CicNotation2.load_notation [] core_notation_script); -ignore (CicNotation2.load_notation [] "../../matita/coq.ma"); -let dbd = HMysql.quick_connect - ~host:(Helm_registry.get "db.host") - ~user:(Helm_registry.get "db.user") - ~database:(Helm_registry.get "db.database") - () -in -let term, metasenv, ugraph = get_from_user ~dbd in -if !retrieve_only then - Saturation.retrieve_and_print dbd term metasenv ugraph -else if !demod_equalities then - Saturation.main_demod_equalities dbd term metasenv ugraph -else - Saturation.main dbd !full term metasenv ugraph -;; diff --git a/helm/ocaml/paramodulation/saturation.ml b/helm/ocaml/paramodulation/saturation.ml deleted file mode 100644 index eb4a35d6c..000000000 --- a/helm/ocaml/paramodulation/saturation.ml +++ /dev/null @@ -1,2379 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -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.;; -let forward_simpl_new_time = ref 0.;; -let backward_simpl_time = ref 0.;; -let passive_maintainance_time = ref 0.;; - -(* limited-resource-strategy related globals *) -let processed_clauses = ref 0;; (* number of equalities selected so far... *) -let time_limit = ref 0.;; (* in seconds, settable by the user... *) -let start_time = ref 0.;; (* time at which the execution started *) -let elapsed_time = ref 0.;; -(* let maximal_weight = ref None;; *) -let maximal_retained_equality = ref None;; - -(* equality-selection related globals *) -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 *) 3;; -let symbols_counter = ref 0;; - -(* non-recursive Knuth-Bendix term ordering by default *) -Utils.compare_terms := Utils.nonrec_kbo;; -(* Utils.compare_terms := Utils.ao;; *) - -(* statistics... *) -let derived_clauses = ref 0;; -let kept_clauses = ref 0;; - -(* index of the greatest Cic.Meta created - TODO: find a better way! *) -let maxmeta = ref 0;; - -(* varbiables controlling the search-space *) -let maxdepth = ref 3;; -let maxwidth = ref 3;; - - -type result = - | ParamodulationFailure - | ParamodulationSuccess of Inference.proof option * environment -;; - -type goal = proof * Cic.metasenv * Cic.term;; - -type theorem = Cic.term * Cic.term * Cic.metasenv;; - - -let symbols_of_equality ((_, _, (_, left, right, _), _, _) as equality) = - let m1 = symbols_of_term left in - let m = - TermMap.fold - (fun k v res -> - try - let c = TermMap.find k res in - TermMap.add k (c+v) res - with Not_found -> - TermMap.add k v res) - (symbols_of_term right) m1 - in - m -;; - - -module OrderedEquality = struct - type t = Inference.equality - - let compare eq1 eq2 = - match meta_convertibility_eq eq1 eq2 with - | true -> 0 - | false -> - let w1, _, (ty, left, right, _), _, a = eq1 - and w2, _, (ty', left', right', _), _, a' = eq2 in - match Pervasives.compare w1 w2 with - | 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 - ) - | res -> res -end - -module EqualitySet = Set.Make(OrderedEquality);; - - -(** - selects one equality from passive. The selection strategy is a combination - of weight, age and goal-similarity -*) -let select env goals passive (active, _) = - processed_clauses := !processed_clauses + 1; - let goal = - match (List.rev goals) with (_, goal::_)::_ -> goal | _ -> assert false - in - let (neg_list, neg_set), (pos_list, pos_set), passive_table = passive in - let remove eq l = - List.filter (fun e -> e <> eq) l - in - if !weight_age_ratio > 0 then - weight_age_counter := !weight_age_counter - 1; - match !weight_age_counter with - | 0 -> ( - weight_age_counter := !weight_age_ratio; - match neg_list, pos_list with - | hd::tl, pos -> - (* Negatives aren't indexed, no need to remove them... *) - (Negative, hd), - ((tl, EqualitySet.remove hd neg_set), (pos, pos_set), passive_table) - | [], (hd:EqualitySet.elt)::tl -> - let passive_table = - Indexing.remove_index passive_table hd - in - (Positive, hd), - (([], neg_set), (tl, EqualitySet.remove hd pos_set), passive_table) - | _, _ -> assert false - ) - | _ when (!symbols_counter > 0) && (EqualitySet.is_empty neg_set) -> ( - symbols_counter := !symbols_counter - 1; - let cardinality map = - TermMap.fold (fun k v res -> res + v) map 0 - in - let symbols = - let _, _, term = goal in - symbols_of_term term - in - let card = cardinality symbols in - 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 f equality (i, e) = - let common, others = - TermMap.fold foldfun (symbols_of_equality equality) (0, 0) - in - let c = others + (abs (common - card)) in - if c < i then (c, equality) - else (i, e) - in - let e1 = EqualitySet.min_elt pos_set in - let initial = - let common, others = - TermMap.fold foldfun (symbols_of_equality e1) (0, 0) - in - (others + (abs (common - card))), e1 - in - let _, current = EqualitySet.fold f pos_set initial in - let passive_table = - Indexing.remove_index passive_table current - in - (Positive, current), - (([], neg_set), - (remove current pos_list, EqualitySet.remove current pos_set), - passive_table) - ) - | _ -> - symbols_counter := !symbols_ratio; - let set_selection set = EqualitySet.min_elt set in - if EqualitySet.is_empty neg_set then - let current = set_selection pos_set in - let passive = - (neg_list, neg_set), - (remove current pos_list, EqualitySet.remove current pos_set), - Indexing.remove_index passive_table current - in - (Positive, current), passive - else - let current = set_selection neg_set in - let passive = - (remove current neg_list, EqualitySet.remove current neg_set), - (pos_list, pos_set), - passive_table - in - (Negative, current), passive -;; - - -(* initializes the passive set of equalities *) -let make_passive neg pos = - let set_of equalities = - List.fold_left (fun s e -> EqualitySet.add e s) EqualitySet.empty equalities - in - let table = - List.fold_left (fun tbl e -> Indexing.index tbl e) Indexing.empty pos - in - (neg, set_of neg), - (pos, set_of pos), - table -;; - - -let make_active () = - [], Indexing.empty -;; - - -(* adds to passive a list of equalities: new_neg is a list of negative - equalities, new_pos a list of positive equalities *) -let add_to_passive passive (new_neg, new_pos) = - let (neg_list, neg_set), (pos_list, pos_set), table = passive in - let ok set equality = not (EqualitySet.mem equality set) in - let neg = List.filter (ok neg_set) new_neg - and pos = List.filter (ok pos_set) new_pos in - let table = - List.fold_left (fun tbl e -> Indexing.index tbl e) table pos - in - let add set equalities = - List.fold_left (fun s e -> EqualitySet.add e s) set equalities - in - (neg @ neg_list, add neg_set neg), - (pos_list @ pos, add pos_set pos), - table -;; - - -let passive_is_empty = function - | ([], _), ([], _), _ -> true - | _ -> false -;; - - -let size_of_passive ((_, ns), (_, ps), _) = - (EqualitySet.cardinal ns) + (EqualitySet.cardinal ps) -;; - - -let size_of_active (active_list, _) = - List.length active_list -;; - - -(* removes from passive equalities that are estimated impossible to activate - within the current time limit *) -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 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 - (lazy (Printf.sprintf "in_weight: %d, in_age: %d\n" in_weight in_age)); - let symbols, card = - match active 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 counter = ref !symbols_ratio in - let rec pickw w ns ps = - if w > 0 then - if not (EqualitySet.is_empty ns) then - let e = EqualitySet.min_elt ns in - let ns', ps = pickw (w-1) (EqualitySet.remove e ns) ps in - EqualitySet.add e ns', ps - else if !counter > 0 then - let _ = - counter := !counter - 1; - if !counter = 0 then counter := !symbols_ratio - in - match symbols with - | None -> - let e = EqualitySet.min_elt ps in - let ns, ps' = pickw (w-1) ns (EqualitySet.remove e ps) in - ns, EqualitySet.add e ps' - | Some symbols -> - 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 f equality (i, e) = - let common, others = - TermMap.fold foldfun (symbols_of_equality equality) (0, 0) - in - let c = others + (abs (common - card)) in - if c < i then (c, equality) - else (i, e) - in - let e1 = EqualitySet.min_elt ps in - let initial = - let common, others = - TermMap.fold foldfun (symbols_of_equality e1) (0, 0) - in - (others + (abs (common - card))), e1 - in - let _, e = EqualitySet.fold f ps initial in - let ns, ps' = pickw (w-1) ns (EqualitySet.remove e ps) in - ns, EqualitySet.add e ps' - else - let e = EqualitySet.min_elt ps in - let ns, ps' = pickw (w-1) ns (EqualitySet.remove e ps) in - ns, EqualitySet.add e ps' - else - EqualitySet.empty, EqualitySet.empty - in - let ns, ps = pickw in_weight ns ps in - let rec picka w s l = - if w > 0 then - match l with - | [] -> w, s, [] - | hd::tl when not (EqualitySet.mem hd s) -> - let w, s, l = picka (w-1) s tl in - w, EqualitySet.add hd s, hd::l - | hd::tl -> - let w, s, l = picka w s tl in - w, s, hd::l - else - 0, s, l - in - let in_age, ns, nl = picka in_age ns nl in - let _, ps, pl = picka in_age ps pl in - if not (EqualitySet.is_empty ps) then - maximal_retained_equality := Some (EqualitySet.max_elt ps); - let tbl = - EqualitySet.fold - (fun e tbl -> Indexing.index tbl e) ps Indexing.empty - in - (nl, ns), (pl, ps), tbl -;; - - -(** inference of new equalities between current and some in active *) -let infer env sign current (active_list, active_table) = - let new_neg, new_pos = - match sign with - | Negative -> - 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 - maxmeta := maxm; - let rec infer_positive table = function - | [] -> [], [] - | (Negative, equality)::tl -> - 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 -> - let maxm, res = - Indexing.superposition_right !maxmeta env table equality in - maxmeta := maxm; - let neg, pos = infer_positive table tl in - neg, res @ pos - in - let curr_table = Indexing.index Indexing.empty current in - let neg, pos = infer_positive curr_table active_list in - neg, res @ pos - in - derived_clauses := !derived_clauses + (List.length new_neg) + - (List.length new_pos); - match !maximal_retained_equality with - | None -> new_neg, new_pos - | 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 -;; - - -let contains_empty env (negative, positive) = - let metasenv, context, ugraph = env in - try - let found = - List.find - (fun (w, proof, (ty, left, right, ordering), m, a) -> - fst (CicReduction.are_convertible context left right ugraph)) - negative - in - true, Some found - with Not_found -> - false, None -;; - - -(** simplifies current using active and passive *) -let forward_simplify env (sign, current) ?passive (active_list, active_table) = - let pl, passive_table = - match passive with - | None -> [], None - | Some ((pn, _), (pp, _), pt) -> - let pn = List.map (fun e -> (Negative, e)) pn - and pp = List.map (fun e -> (Positive, e)) pp in - pn @ pp, Some pt - in - let all = if pl = [] then active_list else active_list @ pl in - - let demodulate table current = - let newmeta, newcurrent = - Indexing.demodulation_equality !maxmeta env table sign current in - maxmeta := newmeta; - if is_identity env newcurrent then - if sign = Negative then Some (sign, newcurrent) - else ( -(* debug_print *) -(* (lazy *) -(* (Printf.sprintf "\ncurrent was: %s\nnewcurrent is: %s\n" *) -(* (string_of_equality current) *) -(* (string_of_equality newcurrent))); *) -(* debug_print *) -(* (lazy *) -(* (Printf.sprintf "active is: %s" *) -(* (String.concat "\n" *) -(* (List.map (fun (_, e) -> (string_of_equality e)) active_list)))); *) - None - ) - else - Some (sign, newcurrent) - in - let res = - let res = demodulate active_table current in - match res with - | None -> None - | Some (sign, newcurrent) -> - match passive_table with - | None -> res - | Some passive_table -> demodulate passive_table newcurrent - in - match res with - | None -> None - | Some (Negative, c) -> - let ok = not ( - List.exists - (fun (s, eq) -> s = Negative && meta_convertibility_eq eq c) - all) - in - if ok then res else None - | Some (Positive, c) -> - if Indexing.in_index active_table c then - None - else - match passive_table with - | None -> - if fst (Indexing.subsumption env active_table c) then - None - else - res - | Some passive_table -> - if Indexing.in_index passive_table c then None - else - let r1, _ = Indexing.subsumption env active_table c in - if r1 then None else - let r2, _ = Indexing.subsumption env passive_table c in - if r2 then None else res -;; - -type fs_time_info_t = { - mutable build_all: float; - mutable demodulate: float; - mutable subsumption: float; -};; - -let fs_time_info = { build_all = 0.; demodulate = 0.; subsumption = 0. };; - - -(** simplifies new using active and passive *) -let forward_simplify_new env (new_neg, new_pos) ?passive active = - let t1 = Unix.gettimeofday () in - - let active_list, active_table = active in - let pl, passive_table = - match passive with - | None -> [], None - | Some ((pn, _), (pp, _), pt) -> - let pn = List.map (fun e -> (Negative, e)) pn - and pp = List.map (fun e -> (Positive, e)) pp in - pn @ pp, Some pt - in - let all = active_list @ pl in - - let t2 = Unix.gettimeofday () in - fs_time_info.build_all <- fs_time_info.build_all +. (t2 -. t1); - - let demodulate sign table target = - let newmeta, newtarget = - Indexing.demodulation_equality !maxmeta env table sign target in - maxmeta := newmeta; - newtarget - in - let t1 = Unix.gettimeofday () in - - let new_neg, new_pos = - 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 Negative passive_table) new_neg, - List.map (demodulate Positive passive_table) new_pos - in - - let t2 = Unix.gettimeofday () in - fs_time_info.demodulate <- fs_time_info.demodulate +. (t2 -. t1); - - let new_pos_set = - List.fold_left - (fun s e -> - if not (Inference.is_identity env e) then - 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 - - let subs = - match passive_table with - | None -> - (fun e -> not (fst (Indexing.subsumption env active_table e))) - | Some passive_table -> - (fun e -> not ((fst (Indexing.subsumption env active_table e)) || - (fst (Indexing.subsumption env passive_table e)))) - in -(* let t1 = Unix.gettimeofday () in *) -(* let t2 = Unix.gettimeofday () in *) -(* fs_time_info.subsumption <- fs_time_info.subsumption +. (t2 -. t1); *) - let is_duplicate = - match passive_table with - | None -> - (fun e -> not (Indexing.in_index active_table e)) - | Some passive_table -> - (fun e -> - not ((Indexing.in_index active_table e) || - (Indexing.in_index passive_table e))) - in - new_neg, List.filter subs (List.filter is_duplicate new_pos) -;; - - -(** simplifies active usign new *) -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) -> - 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 = - List.exists (fun (s, e) -> meta_convertibility_eq eq1 e) where - in - let active, newa = - List.fold_right - (fun (s, eq) (res, tbl) -> - if List.mem (s, eq) res then - res, tbl - else if (is_identity env eq) || (find eq res) then ( - res, tbl - ) - else - (s, eq)::res, if s = Negative then tbl else Indexing.index tbl eq) - active_list ([], Indexing.empty), - List.fold_right - (fun (s, eq) (n, p) -> - if (s <> Negative) && (is_identity env eq) then ( - (n, p) - ) else - if s = Negative then eq::n, p - else n, eq::p) - newa ([], []) - in - match newa with - | [], [] -> active, None - | _ -> active, Some newa -;; - - -(** simplifies passive using new *) -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) = - let ew, _, _, _, _ = equality in - if ew < min_weight then - 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 - let passive_table = - List.fold_left - (fun tbl e -> Indexing.index tbl e) Indexing.empty pl - in - match newn, newp with - | [], [] -> ((nl, ns), (pl, ps), passive_table), None - | _, _ -> ((nl, ns), (pl, ps), passive_table), Some (newn, newp) -;; - - -let backward_simplify env new' ?passive active = - let new_pos, new_table, min_weight = - List.fold_left - (fun (l, t, w) e -> - let ew, _, _, _, _ = e in - (Positive, e)::l, Indexing.index t e, min ew w) - ([], Indexing.empty, 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 min_weight passive in - active, passive, newa, newp -;; - - -(* returns an estimation of how many equalities in passive can be activated - within the current time limit *) -let get_selection_estimate () = - elapsed_time := (Unix.gettimeofday ()) -. !start_time; - (* !processed_clauses * (int_of_float (!time_limit /. !elapsed_time)) *) - int_of_float ( - ceil ((float_of_int !processed_clauses) *. - ((!time_limit (* *. 2. *)) /. !elapsed_time -. 1.))) -;; - - -(** initializes the set of goals *) -let make_goals goal = - let active = [] - and passive = [0, [goal]] in - active, passive -;; - - -(** initializes the set of theorems *) -let make_theorems theorems = - theorems, [] -;; - - -let activate_goal (active, passive) = - match passive with - | goal_conj::tl -> true, (goal_conj::active, tl) - | [] -> false, (active, passive) -;; - - -let activate_theorem (active, passive) = - match passive with - | theorem::tl -> true, (theorem::active, tl) - | [] -> false, (active, passive) -;; - - -(** simplifies a goal with equalities in active and passive *) -let simplify_goal env goal ?passive (active_list, active_table) = - let pl, passive_table = - match passive with - | None -> [], None - | Some ((pn, _), (pp, _), pt) -> - let pn = List.map (fun e -> (Negative, e)) pn - and pp = List.map (fun e -> (Positive, e)) pp in - pn @ pp, Some pt - in - let all = if pl = [] then active_list else active_list @ pl in - - let demodulate table goal = - let newmeta, newgoal = - Indexing.demodulation_goal !maxmeta env table goal in - maxmeta := newmeta; - goal != newgoal, newgoal - in - let changed, goal = - match passive_table with - | None -> demodulate active_table goal - | Some passive_table -> - let changed, goal = demodulate active_table goal in - let changed', goal = demodulate passive_table goal in - (changed || changed'), goal - in - changed, goal -;; - - -let simplify_goals env goals ?passive active = - let a_goals, p_goals = goals in - let p_goals = - List.map - (fun (d, gl) -> - let gl = - List.map (fun g -> snd (simplify_goal env g ?passive active)) gl in - d, gl) - p_goals - in - let goals = - List.fold_left - (fun (a, p) (d, gl) -> - let changed = ref false in - let gl = - List.map - (fun g -> - let c, g = simplify_goal env g ?passive active in - changed := !changed || c; g) gl in - if !changed then (a, (d, gl)::p) else ((d, gl)::a, p)) - ([], p_goals) a_goals - in - goals -;; - - -let simplify_theorems env theorems ?passive (active_list, active_table) = - let pl, passive_table = - match passive with - | None -> [], None - | Some ((pn, _), (pp, _), pt) -> - let pn = List.map (fun e -> (Negative, e)) pn - and pp = List.map (fun e -> (Positive, e)) pp in - pn @ pp, Some pt - in - let all = if pl = [] then active_list else active_list @ pl in - let a_theorems, p_theorems = theorems in - let demodulate table theorem = - let newmeta, newthm = - Indexing.demodulation_theorem !maxmeta env table theorem in - maxmeta := newmeta; - theorem != newthm, newthm - in - let foldfun table (a, p) theorem = - let changed, theorem = demodulate table theorem in - if changed then (a, theorem::p) else (theorem::a, p) - in - let mapfun table theorem = snd (demodulate table theorem) in - match passive_table with - | None -> - let p_theorems = List.map (mapfun active_table) p_theorems in - List.fold_left (foldfun active_table) ([], p_theorems) a_theorems - | Some passive_table -> - let p_theorems = List.map (mapfun active_table) p_theorems in - let p_theorems, a_theorems = - List.fold_left (foldfun active_table) ([], p_theorems) a_theorems in - let p_theorems = List.map (mapfun passive_table) p_theorems in - List.fold_left (foldfun passive_table) ([], p_theorems) a_theorems -;; - - -(* applies equality to goal to see if the goal can be closed *) -let apply_equality_to_goal env equality goal = - let module C = Cic in - let module HL = HelmLibraryObjects in - let module I = Inference in - let metasenv, context, ugraph = env in - let _, proof, (ty, left, right, _), metas, args = equality in - let eqterm = - C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []); ty; left; right] in - let gproof, gmetas, gterm = goal in -(* debug_print *) -(* (lazy *) -(* (Printf.sprintf "APPLY EQUALITY TO GOAL: %s, %s" *) -(* (string_of_equality equality) (CicPp.ppterm gterm))); *) - try - let subst, metasenv', _ = - let menv = metasenv @ metas @ gmetas in - Inference.unification menv context eqterm gterm ugraph - in - let newproof = - match proof with - | I.BasicProof t -> I.BasicProof (CicMetaSubst.apply_subst subst t) - | I.ProofBlock (s, uri, nt, t, pe, p) -> - I.ProofBlock (subst @ s, uri, nt, t, pe, p) - | _ -> assert false - in - let newgproof = - let rec repl = function - | I.ProofGoalBlock (_, gp) -> I.ProofGoalBlock (newproof, gp) - | I.NoProof -> newproof - | I.BasicProof p -> newproof - | I.SubProof (t, i, p) -> I.SubProof (t, i, repl p) - | _ -> assert false - in - repl gproof - in - true, subst, newgproof - with CicUnification.UnificationFailure _ -> - false, [], I.NoProof -;; - - - -let new_meta metasenv = - let m = CicMkImplicit.new_meta metasenv [] in - incr maxmeta; - while !maxmeta <= m do incr maxmeta done; - !maxmeta -;; - - -(* applies a theorem or an equality to goal, returning a list of subgoals or - an indication of failure *) -let apply_to_goal env theorems ?passive active goal = - let metasenv, context, ugraph = env in - let proof, metas, term = goal in - (* debug_print *) - (* (lazy *) - (* (Printf.sprintf "apply_to_goal with goal: %s" *) - (* (\* (string_of_proof proof) *\)(CicPp.ppterm term))); *) - let status = - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context in - let proof', newmeta = - let rec get_meta = function - | SubProof (t, i, p) -> - let t', i' = get_meta p in - if i' = -1 then t, i else t', i' - | ProofGoalBlock (_, p) -> get_meta p - | _ -> Cic.Implicit None, -1 - in - let p, m = get_meta proof in - if m = -1 then - let n = new_meta (metasenv @ metas) in - Cic.Meta (n, irl), n - else - p, m - in - let metasenv = (newmeta, context, term)::metasenv @ metas in - let bit = new_meta metasenv, context, term in - let metasenv' = bit::metasenv in - ((None, metasenv', Cic.Meta (newmeta, irl), term), newmeta) - in - let rec aux = function - | [] -> `No - | (theorem, thmty, _)::tl -> - try - let subst, (newproof, newgoals) = - PrimitiveTactics.apply_tac_verbose_with_subst ~term:theorem status - in - if newgoals = [] then - let _, _, p, _ = newproof in - let newp = - let rec repl = function - | Inference.ProofGoalBlock (_, gp) -> - Inference.ProofGoalBlock (Inference.BasicProof p, gp) - | Inference.NoProof -> Inference.BasicProof p - | Inference.BasicProof _ -> Inference.BasicProof p - | Inference.SubProof (t, i, p2) -> - Inference.SubProof (t, i, repl p2) - | _ -> assert false - in - repl proof - in - let _, m = status in - let subst = List.filter (fun (i, _) -> i = m) subst in - `Ok (subst, [newp, metas, term]) - else - let _, menv, p, _ = newproof in - let irl = - CicMkImplicit.identity_relocation_list_for_metavariable context - in - let goals = - List.map - (fun i -> - let _, _, ty = CicUtil.lookup_meta i menv in - let p' = - let rec gp = function - | SubProof (t, i, p) -> - SubProof (t, i, gp p) - | ProofGoalBlock (sp1, sp2) -> - ProofGoalBlock (sp1, gp sp2) - | BasicProof _ - | NoProof -> - SubProof (p, i, BasicProof (Cic.Meta (i, irl))) - | ProofSymBlock (s, sp) -> - ProofSymBlock (s, gp sp) - | ProofBlock (s, u, nt, t, pe, sp) -> - ProofBlock (s, u, nt, t, pe, gp sp) - in gp proof - in - (p', menv, ty)) - newgoals - in - let goals = - let weight t = - let w, m = weight_of_term t in - w + 2 * (List.length m) - in - List.sort - (fun (_, _, t1) (_, _, t2) -> - Pervasives.compare (weight t1) (weight t2)) - goals - in - let best = aux tl in - match best with - | `Ok (_, _) -> best - | `No -> `GoOn ([subst, goals]) - | `GoOn sl -> `GoOn ((subst, goals)::sl) - with ProofEngineTypes.Fail msg -> - aux tl - in - let r, s, l = - if Inference.term_is_equality term then - let rec appleq_a = function - | [] -> false, [], [] - | (Positive, equality)::tl -> - let ok, s, newproof = apply_equality_to_goal env equality goal in - if ok then true, s, [newproof, metas, term] else appleq_a tl - | _::tl -> appleq_a tl - in - let rec appleq_p = function - | [] -> false, [], [] - | equality::tl -> - let ok, s, newproof = apply_equality_to_goal env equality goal in - if ok then true, s, [newproof, metas, term] else appleq_p tl - in - let al, _ = active in - match passive with - | None -> appleq_a al - | Some (_, (pl, _), _) -> - let r, s, l = appleq_a al in if r then r, s, l else appleq_p pl - else - false, [], [] - in - if r = true then `Ok (s, l) else aux theorems -;; - - -(* sorts a conjunction of goals in order to detect earlier if it is - unsatisfiable. Non-predicate goals are placed at the end of the list *) -let sort_goal_conj (metasenv, context, ugraph) (depth, gl) = - let gl = - List.stable_sort - (fun (_, e1, g1) (_, e2, g2) -> - let ty1, _ = - CicTypeChecker.type_of_aux' (e1 @ metasenv) context g1 ugraph - and ty2, _ = - CicTypeChecker.type_of_aux' (e2 @ metasenv) context g2 ugraph - in - let prop1 = - let b, _ = - CicReduction.are_convertible context (Cic.Sort Cic.Prop) ty1 ugraph - in - if b then 0 else 1 - and prop2 = - let b, _ = - CicReduction.are_convertible context (Cic.Sort Cic.Prop) ty2 ugraph - in - if b then 0 else 1 - in - if prop1 = 0 && prop2 = 0 then - let e1 = if Inference.term_is_equality g1 then 0 else 1 - and e2 = if Inference.term_is_equality g2 then 0 else 1 in - e1 - e2 - else - prop1 - prop2) - gl - in - (depth, gl) -;; - - -let is_meta_closed goals = - List.for_all (fun (_, _, g) -> CicUtil.is_meta_closed g) goals -;; - - -(* applies a series of theorems/equalities to a conjunction of goals *) -let rec apply_to_goal_conj env theorems ?passive active (depth, goals) = - let aux (goal, r) tl = - let propagate_subst subst (proof, metas, term) = - let rec repl = function - | NoProof -> NoProof - | BasicProof t -> - BasicProof (CicMetaSubst.apply_subst subst t) - | ProofGoalBlock (p, pb) -> - let pb' = repl pb in - ProofGoalBlock (p, pb') - | SubProof (t, i, p) -> - let t' = CicMetaSubst.apply_subst subst t in - let p = repl p in - SubProof (t', i, p) - | ProofSymBlock (ens, p) -> ProofSymBlock (ens, repl p) - | ProofBlock (s, u, nty, t, pe, p) -> - ProofBlock (subst @ s, u, nty, t, pe, p) - in (repl proof, metas, term) - in - (* let r = apply_to_goal env theorems ?passive active goal in *) ( - match r with - | `No -> `No (depth, goals) - | `GoOn sl -> - let l = - List.map - (fun (s, gl) -> - let tl = List.map (propagate_subst s) tl in - sort_goal_conj env (depth+1, gl @ tl)) sl - in - `GoOn l - | `Ok (subst, gl) -> - if tl = [] then - `Ok (depth, gl) - else - let p, _, _ = List.hd gl in - let subproof = - let rec repl = function - | SubProof (_, _, p) -> repl p - | ProofGoalBlock (p1, p2) -> - ProofGoalBlock (repl p1, repl p2) - | p -> p - in - build_proof_term (repl p) - in - let i = - let rec get_meta = function - | SubProof (_, i, p) -> - let i' = get_meta p in - if i' = -1 then i else i' -(* max i (get_meta p) *) - | ProofGoalBlock (_, p) -> get_meta p - | _ -> -1 - in - get_meta p - in - let subst = - let _, (context, _, _) = List.hd subst in - [i, (context, subproof, Cic.Implicit None)] - in - let tl = List.map (propagate_subst subst) tl in - let conj = sort_goal_conj env (depth(* +1 *), tl) in - `GoOn ([conj]) - ) - in - if depth > !maxdepth || (List.length goals) > !maxwidth then - `No (depth, goals) - else - let rec search_best res = function - | [] -> res - | goal::tl -> - let r = apply_to_goal env theorems ?passive active goal in - match r with - | `Ok _ -> (goal, r) - | `No -> search_best res tl - | `GoOn l -> - let newres = - match res with - | _, `Ok _ -> assert false - | _, `No -> goal, r - | _, `GoOn l2 -> - if (List.length l) < (List.length l2) then goal, r else res - in - search_best newres tl - in - let hd = List.hd goals in - let res = hd, (apply_to_goal env theorems ?passive active hd) in - let best = - match res with - | _, `Ok _ -> res - | _, _ -> search_best res (List.tl goals) - in - let res = aux best (List.filter (fun g -> g != (fst best)) goals) in - match res with - | `GoOn ([conj]) when is_meta_closed (snd conj) && - (List.length (snd conj)) < (List.length goals)-> - apply_to_goal_conj env theorems ?passive active conj - | _ -> res -;; - - -(* -module OrderedGoals = struct - type t = int * (Inference.proof * Cic.metasenv * Cic.term) list - - let compare g1 g2 = - let d1, l1 = g1 - and d2, l2 = g2 in - let r = d2 - d1 in - if r <> 0 then r - else let r = (List.length l1) - (List.length l2) in - if r <> 0 then r - else - let res = ref 0 in - let _ = - List.exists2 - (fun (_, _, t1) (_, _, t2) -> - let r = Pervasives.compare t1 t2 in - if r <> 0 then ( - res := r; - true - ) else - false) l1 l2 - in !res -end - -module GoalsSet = Set.Make(OrderedGoals);; - - -exception SearchSpaceOver;; -*) - - -(* -let apply_to_goals env is_passive_empty theorems active goals = - debug_print (lazy "\n\n\tapply_to_goals\n\n"); - let add_to set goals = - List.fold_left (fun s g -> GoalsSet.add g s) set goals - in - let rec aux set = function - | [] -> - debug_print (lazy "HERE!!!"); - if is_passive_empty then raise SearchSpaceOver else false, set - | goals::tl -> - let res = apply_to_goal_conj env theorems active goals in - match res with - | `Ok newgoals -> - let _ = - let d, p, t = - match newgoals with - | (d, (p, _, t)::_) -> d, p, t - | _ -> assert false - in - debug_print - (lazy - (Printf.sprintf "\nOK!!!!\ndepth: %d\nProof: %s\ngoal: %s\n" - d (string_of_proof p) (CicPp.ppterm t))) - in - true, GoalsSet.singleton newgoals - | `GoOn newgoals -> - let set' = add_to set (goals::tl) in - let set' = add_to set' newgoals in - false, set' - | `No newgoals -> - aux set tl - in - let n = List.length goals in - let res, goals = aux (add_to GoalsSet.empty goals) goals in - let goals = GoalsSet.elements goals in - debug_print (lazy "\n\tapply_to_goals end\n"); - let m = List.length goals in - if m = n && is_passive_empty then - raise SearchSpaceOver - else - res, goals -;; -*) - - -(* sorts the list of passive goals to minimize the search for a proof (doesn't - work that well yet...) *) -let sort_passive_goals goals = - List.stable_sort - (fun (d1, l1) (d2, l2) -> - let r1 = d2 - d1 - and r2 = (List.length l1) - (List.length l2) in - let foldfun ht (_, _, t) = - let _ = List.map (fun i -> Hashtbl.replace ht i 1) (metas_of_term t) - in ht - in - let m1 = Hashtbl.length (List.fold_left foldfun (Hashtbl.create 3) l1) - and m2 = Hashtbl.length (List.fold_left foldfun (Hashtbl.create 3) l2) - in let r3 = m1 - m2 in - if r3 <> 0 then r3 - else if r2 <> 0 then r2 - else r1) - (* let _, _, g1 = List.hd l1 *) -(* and _, _, g2 = List.hd l2 in *) -(* let e1 = if Inference.term_is_equality g1 then 0 else 1 *) -(* and e2 = if Inference.term_is_equality g2 then 0 else 1 *) -(* in let r4 = e1 - e2 in *) -(* if r4 <> 0 then r3 else r1) *) - goals -;; - - -let print_goals goals = - (String.concat "\n" - (List.map - (fun (d, gl) -> - let gl' = - List.map - (fun (p, _, t) -> - (* (string_of_proof p) ^ ", " ^ *) (CicPp.ppterm t)) gl - in - Printf.sprintf "%d: %s" d (String.concat "; " gl')) goals)) -;; - - -(* tries to prove the first conjunction in goals with applications of - theorems/equalities, returning new sub-goals or an indication of success *) -let apply_goal_to_theorems dbd env theorems ?passive active goals = - let theorems, _ = theorems in - let a_goals, p_goals = goals in - let goal = List.hd a_goals in - let not_in_active gl = - not - (List.exists - (fun (_, gl') -> - if (List.length gl) = (List.length gl') then - List.for_all2 (fun (_, _, g1) (_, _, g2) -> g1 = g2) gl gl' - else - false) - a_goals) - in - let aux theorems = - let res = apply_to_goal_conj env theorems ?passive active goal in - match res with - | `Ok newgoals -> - true, ([newgoals], []) - | `No _ -> - false, (a_goals, p_goals) - | `GoOn newgoals -> - let newgoals = - List.filter - (fun (d, gl) -> - (d <= !maxdepth) && (List.length gl) <= !maxwidth && - not_in_active gl) - newgoals in - let p_goals = newgoals @ p_goals in - let p_goals = sort_passive_goals p_goals in - false, (a_goals, p_goals) - in - aux theorems -;; - - -let apply_theorem_to_goals env theorems active goals = - let a_goals, p_goals = goals in - let theorem = List.hd (fst theorems) in - let theorems = [theorem] in - let rec aux p = function - | [] -> false, ([], p) - | goal::tl -> - let res = apply_to_goal_conj env theorems active goal in - match res with - | `Ok newgoals -> true, ([newgoals], []) - | `No _ -> aux p tl - | `GoOn newgoals -> aux (newgoals @ p) tl - in - let ok, (a, p) = aux p_goals a_goals in - if ok then - ok, (a, p) - else - let p_goals = - List.stable_sort - (fun (d1, l1) (d2, l2) -> - let r = d2 - d1 in - if r <> 0 then r - else let r = (List.length l1) - (List.length l2) in - if r <> 0 then r - else - let res = ref 0 in - let _ = - List.exists2 - (fun (_, _, t1) (_, _, t2) -> - let r = Pervasives.compare t1 t2 in - if r <> 0 then (res := r; true) else false) l1 l2 - in !res) - p - in - ok, (a_goals, p_goals) -;; - - -(* given-clause algorithm with lazy reduction strategy *) -let rec given_clause dbd env goals theorems passive active = - let goals = simplify_goals env goals active in - let ok, goals = activate_goal goals in - (* let theorems = simplify_theorems env theorems active in *) - if ok then - let ok, goals = apply_goal_to_theorems dbd env theorems active goals in - if ok then - let proof = - match (fst goals) with - | (_, [proof, _, _])::_ -> Some proof - | _ -> assert false - in - ParamodulationSuccess (proof, env) - else - given_clause_aux dbd env goals theorems passive active - else -(* let ok', theorems = activate_theorem theorems in *) - let ok', theorems = false, theorems in - if ok' then - let ok, goals = apply_theorem_to_goals env theorems active goals in - if ok then - let proof = - match (fst goals) with - | (_, [proof, _, _])::_ -> Some proof - | _ -> assert false - in - ParamodulationSuccess (proof, env) - else - given_clause_aux dbd env goals theorems passive active - else - if (passive_is_empty passive) then ParamodulationFailure - else given_clause_aux dbd env goals theorems passive active - -and given_clause_aux dbd env goals theorems passive active = - let time1 = Unix.gettimeofday () in - - let selection_estimate = get_selection_estimate () in - let kept = size_of_passive passive in - let passive = - if !time_limit = 0. || !processed_clauses = 0 then - passive - else if !elapsed_time > !time_limit then ( - debug_print (lazy (Printf.sprintf "Time limit (%.2f) reached: %.2f\n" - !time_limit !elapsed_time)); - make_passive [] [] - ) else if kept > selection_estimate then ( - debug_print - (lazy (Printf.sprintf ("Too many passive equalities: pruning..." ^^ - "(kept: %d, selection_estimate: %d)\n") - kept selection_estimate)); - prune_passive selection_estimate active passive - ) else - passive - in - - let time2 = Unix.gettimeofday () in - passive_maintainance_time := !passive_maintainance_time +. (time2 -. time1); - - kept_clauses := (size_of_passive passive) + (size_of_active active); - match passive_is_empty passive with - | true -> (* ParamodulationFailure *) - given_clause dbd env goals theorems passive active - | false -> - let (sign, current), passive = select env (fst goals) passive active in - let time1 = Unix.gettimeofday () in - let res = forward_simplify env (sign, current) ~passive active in - let time2 = Unix.gettimeofday () in - forward_simpl_time := !forward_simpl_time +. (time2 -. time1); - match res with - | None -> - given_clause dbd env goals theorems passive active - | Some (sign, current) -> - if (sign = Negative) && (is_identity env current) then ( - debug_print - (lazy (Printf.sprintf "OK!!! %s %s" (string_of_sign sign) - (string_of_equality ~env current))); - let _, proof, _, _, _ = current in - ParamodulationSuccess (Some proof, env) - ) else ( - debug_print - (lazy "\n================================================"); - debug_print (lazy (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 - let t2 = Unix.gettimeofday () in - infer_time := !infer_time +. (t2 -. t1); - - let res, goal' = contains_empty env new' in - if res then - let proof = - match goal' with - | Some goal -> let _, proof, _, _, _ = goal in Some proof - | None -> None - in - ParamodulationSuccess (proof, env) - else - let t1 = Unix.gettimeofday () in - let new' = forward_simplify_new env new' active in - let t2 = Unix.gettimeofday () in - let _ = - forward_simpl_new_time := - !forward_simpl_new_time +. (t2 -. t1) - in - let active = - match sign with - | Negative -> active - | Positive -> - let t1 = Unix.gettimeofday () in - let active, _, newa, _ = - backward_simplify env ([], [current]) active - in - let t2 = Unix.gettimeofday () in - backward_simpl_time := - !backward_simpl_time +. (t2 -. t1); - match newa with - | None -> active - | Some (n, p) -> - let al, tbl = active in - let nn = List.map (fun e -> Negative, e) n in - let pp, tbl = - List.fold_right - (fun e (l, t) -> - (Positive, e)::l, - Indexing.index tbl e) - p ([], tbl) - in - nn @ al @ pp, tbl - in - match contains_empty env new' with - | false, _ -> - let active = - let al, tbl = active in - match sign with - | Negative -> (sign, current)::al, tbl - | Positive -> - al @ [(sign, current)], Indexing.index tbl current - in - let passive = add_to_passive passive new' in - let (_, ns), (_, ps), _ = passive in - given_clause dbd env goals theorems passive active - | true, goal -> - let proof = - match goal with - | Some goal -> - let _, proof, _, _, _ = goal in Some proof - | None -> None - in - ParamodulationSuccess (proof, env) - ) -;; - - -(** given-clause algorithm with full reduction strategy *) -let rec given_clause_fullred dbd env goals theorems passive active = - let goals = simplify_goals env goals ~passive active in - let ok, goals = activate_goal goals in -(* let theorems = simplify_theorems env theorems ~passive active in *) - if ok then -(* let _ = *) -(* debug_print *) -(* (lazy *) -(* (Printf.sprintf "\ngoals = \nactive\n%s\npassive\n%s\n" *) -(* (print_goals (fst goals)) (print_goals (snd goals)))); *) -(* let current = List.hd (fst goals) in *) -(* let p, _, t = List.hd (snd current) in *) -(* debug_print *) -(* (lazy *) -(* (Printf.sprintf "goal activated:\n%s\n%s\n" *) -(* (CicPp.ppterm t) (string_of_proof p))); *) -(* in *) - let ok, goals = - apply_goal_to_theorems dbd env theorems ~passive active goals - in - if ok then - let proof = - match (fst goals) with - | (_, [proof, _, _])::_ -> Some proof - | _ -> assert false - in - ParamodulationSuccess (proof, env) - else - given_clause_fullred_aux dbd env goals theorems passive active - else -(* let ok', theorems = activate_theorem theorems in *) -(* if ok' then *) -(* let ok, goals = apply_theorem_to_goals env theorems active goals in *) -(* if ok then *) -(* let proof = *) -(* match (fst goals) with *) -(* | (_, [proof, _, _])::_ -> Some proof *) -(* | _ -> assert false *) -(* in *) -(* ParamodulationSuccess (proof, env) *) -(* else *) -(* given_clause_fullred_aux env goals theorems passive active *) -(* else *) - if (passive_is_empty passive) then ParamodulationFailure - else given_clause_fullred_aux dbd env goals theorems passive active - -and given_clause_fullred_aux dbd env goals theorems passive active = - let time1 = Unix.gettimeofday () in - - let selection_estimate = get_selection_estimate () in - let kept = size_of_passive passive in - let passive = - if !time_limit = 0. || !processed_clauses = 0 then - passive - else if !elapsed_time > !time_limit then ( - debug_print (lazy (Printf.sprintf "Time limit (%.2f) reached: %.2f\n" - !time_limit !elapsed_time)); - make_passive [] [] - ) else if kept > selection_estimate then ( - debug_print - (lazy (Printf.sprintf ("Too many passive equalities: pruning..." ^^ - "(kept: %d, selection_estimate: %d)\n") - kept selection_estimate)); - prune_passive selection_estimate active passive - ) else - passive - in - - let time2 = Unix.gettimeofday () in - passive_maintainance_time := !passive_maintainance_time +. (time2 -. time1); - - kept_clauses := (size_of_passive passive) + (size_of_active active); - match passive_is_empty passive with - | true -> (* ParamodulationFailure *) - given_clause_fullred dbd env goals theorems passive active - | false -> - let (sign, current), passive = select env (fst goals) passive active in - let time1 = Unix.gettimeofday () in - let res = forward_simplify env (sign, current) ~passive active in - let time2 = Unix.gettimeofday () in - forward_simpl_time := !forward_simpl_time +. (time2 -. time1); - match res with - | None -> - given_clause_fullred dbd env goals theorems passive active - | Some (sign, current) -> - if (sign = Negative) && (is_identity env current) then ( - debug_print - (lazy (Printf.sprintf "OK!!! %s %s" (string_of_sign sign) - (string_of_equality ~env current))); - let _, proof, _, _, _ = current in - ParamodulationSuccess (Some proof, env) - ) else ( - debug_print - (lazy "\n================================================"); - debug_print (lazy (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 - let t2 = Unix.gettimeofday () in - infer_time := !infer_time +. (t2 -. t1); - - let active = - if is_identity env current then active - else - let al, tbl = active in - match sign with - | Negative -> (sign, current)::al, tbl - | Positive -> - al @ [(sign, current)], Indexing.index tbl current - in - let rec simplify new' active passive = - let t1 = Unix.gettimeofday () in - let new' = forward_simplify_new env new' ~passive active in - let t2 = Unix.gettimeofday () in - forward_simpl_new_time := - !forward_simpl_new_time +. (t2 -. t1); - let t1 = Unix.gettimeofday () in - let active, passive, newa, retained = - backward_simplify env new' ~passive active in - let t2 = Unix.gettimeofday () in - backward_simpl_time := !backward_simpl_time +. (t2 -. t1); - match newa, retained with - | None, None -> active, passive, new' - | Some (n, p), None - | None, Some (n, p) -> - let nn, np = new' in - simplify (nn @ n, np @ p) active passive - | Some (n, p), Some (rn, rp) -> - let nn, np = new' in - simplify (nn @ n @ rn, np @ p @ rp) active passive - in - let active, passive, new' = simplify new' active passive in - - let k = size_of_passive passive in - if k < (kept - 1) then - processed_clauses := !processed_clauses + (kept - 1 - k); - - let _ = - debug_print - (lazy - (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 - (lazy - (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 - given_clause_fullred dbd env goals theorems passive active - | true, goal -> - let proof = - match goal with - | Some goal -> let _, proof, _, _, _ = goal in Some proof - | None -> None - in - ParamodulationSuccess (proof, env) - ) -;; - - -let rec saturate_equations env goal accept_fun passive active = - elapsed_time := Unix.gettimeofday () -. !start_time; - if !elapsed_time > !time_limit then - (active, passive) - else - let (sign, current), passive = select env [1, [goal]] passive active in - let res = forward_simplify env (sign, current) ~passive active in - match res with - | None -> - saturate_equations env goal accept_fun passive active - | Some (sign, current) -> - assert (sign = Positive); - debug_print - (lazy "\n================================================"); - debug_print (lazy (Printf.sprintf "selected: %s %s" - (string_of_sign sign) - (string_of_equality ~env current))); - let new' = infer env sign current active in - let active = - if is_identity env current then active - else - let al, tbl = active in - al @ [(sign, current)], Indexing.index tbl current - in - let rec simplify new' active passive = - let new' = forward_simplify_new env new' ~passive active in - let active, passive, newa, retained = - backward_simplify env new' ~passive active in - match newa, retained with - | None, None -> active, passive, new' - | Some (n, p), None - | None, Some (n, p) -> - let nn, np = new' in - simplify (nn @ n, np @ p) active passive - | Some (n, p), Some (rn, rp) -> - let nn, np = new' in - simplify (nn @ n @ rn, np @ p @ rp) active passive - in - let active, passive, new' = simplify new' active passive in - let _ = - debug_print - (lazy - (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 - (lazy - (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 - let new' = match new' with _, pos -> [], List.filter accept_fun pos in - let passive = add_to_passive passive new' in - saturate_equations env goal accept_fun passive active -;; - - - - -let main dbd full term metasenv ugraph = - let module C = Cic in - let module T = CicTypeChecker in - let module PET = ProofEngineTypes in - let module PP = CicPp in - let proof = None, (1, [], term)::metasenv, C.Meta (1, []), term 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 eq_indexes, equalities, maxm = find_equalities context proof in - let lib_eq_uris, library_equalities, maxm = - find_library_equalities dbd context (proof, goal') (maxm+2) - in - let library_equalities = List.map snd library_equalities 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 - debug_print - (lazy - (Printf.sprintf "\n\nTIPO DEL GOAL: %s\n\n" (CicPp.ppterm ty))); - Cic.Meta (maxm+1, irl), - (maxm+1, context, ty)::metasenv, - ty - in - let env = (metasenv, context, ugraph) in - let t1 = Unix.gettimeofday () in - let theorems = - if full then - let theorems = find_library_theorems dbd env (proof, goal') lib_eq_uris in - let context_hyp = find_context_hypotheses env eq_indexes in - context_hyp @ theorems, [] - else - let refl_equal = - let us = UriManager.string_of_uri (LibraryObjects.eq_URI ()) in - UriManager.uri_of_string (us ^ "#xpointer(1/1/1)") - in - let t = CicUtil.term_of_uri refl_equal in - let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in - [(t, ty, [])], [] - in - let t2 = Unix.gettimeofday () in - debug_print - (lazy - (Printf.sprintf "Time to retrieve theorems: %.9f\n" (t2 -. t1))); - let _ = - debug_print - (lazy - (Printf.sprintf - "Theorems:\n-------------------------------------\n%s\n" - (String.concat "\n" - (List.map - (fun (t, ty, _) -> - Printf.sprintf - "Term: %s, type: %s" (CicPp.ppterm t) (CicPp.ppterm ty)) - (fst theorems))))) - in - try - let goal = Inference.BasicProof new_meta_goal, [], goal in - let equalities = - let equalities = equalities @ library_equalities in - debug_print - (lazy - (Printf.sprintf "equalities:\n%s\n" - (String.concat "\n" - (List.map string_of_equality equalities)))); - debug_print (lazy "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 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 - (lazy - (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 [] equalities in - Printf.printf "\ncurrent goal: %s\n" - (let _, _, g = goal in CicPp.ppterm g); - 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)); -(* (equalities @ library_equalities))); *) - print_endline "--------------------------------------------------"; - let start = Unix.gettimeofday () in - print_endline "GO!"; - start_time := Unix.gettimeofday (); - let res = - let goals = make_goals goal in - (if !use_fullred then given_clause_fullred else given_clause) - dbd env goals theorems passive active - in - let finish = Unix.gettimeofday () in - let _ = - match res with - | ParamodulationFailure -> - Printf.printf "NO proof found! :-(\n\n" - | ParamodulationSuccess (Some proof, env) -> - let proof = Inference.build_proof_term proof 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); - 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 - 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 default_depth = !maxdepth -and default_width = !maxwidth;; - -let reset_refs () = - maxmeta := 0; - symbols_counter := 0; - weight_age_counter := !weight_age_ratio; - processed_clauses := 0; - start_time := 0.; - elapsed_time := 0.; - maximal_retained_equality := None; - infer_time := 0.; - forward_simpl_time := 0.; - forward_simpl_new_time := 0.; - backward_simpl_time := 0.; - passive_maintainance_time := 0.; - derived_clauses := 0; - kept_clauses := 0; -;; - -let saturate - dbd ?(full=false) ?(depth=default_depth) ?(width=default_width) status = - let module C = Cic in - reset_refs (); - Indexing.init_index (); - maxdepth := depth; - maxwidth := width; - let proof, goal = status in - let goal' = goal in - let uri, metasenv, meta_proof, term_to_prove = proof in - let _, context, goal = CicUtil.lookup_meta goal' metasenv in - let eq_indexes, 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 - (lazy (Printf.sprintf "\n\nTIPO DEL GOAL: %s\n" (CicPp.ppterm ty))); - Cic.Meta (maxm+1, irl), - (maxm+1, context, ty)::metasenv, - ty - in - let ugraph = CicUniv.empty_ugraph in - let env = (metasenv, context, ugraph) in - let goal = Inference.BasicProof new_meta_goal, [], goal in - let res, time = - let t1 = Unix.gettimeofday () in - let lib_eq_uris, library_equalities, maxm = - find_library_equalities dbd context (proof, goal') (maxm+2) - in - let library_equalities = List.map snd library_equalities in - let t2 = Unix.gettimeofday () in - maxmeta := maxm+2; - let equalities = - let equalities = equalities @ library_equalities in - debug_print - (lazy - (Printf.sprintf "equalities:\n%s\n" - (String.concat "\n" - (List.map string_of_equality equalities)))); - debug_print (lazy "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 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 - (lazy - (Printf.sprintf "equalities AFTER:\n%s\n" - (String.concat "\n" - (List.map string_of_equality res)))); - res - in - debug_print - (lazy - (Printf.sprintf "Time to retrieve equalities: %.9f\n" (t2 -. t1))); - let t1 = Unix.gettimeofday () in - let theorems = - if full then - let thms = find_library_theorems dbd env (proof, goal') lib_eq_uris in - let context_hyp = find_context_hypotheses env eq_indexes in - context_hyp @ thms, [] - else - let refl_equal = - let us = UriManager.string_of_uri (LibraryObjects.eq_URI ()) in - UriManager.uri_of_string (us ^ "#xpointer(1/1/1)") - in - let t = CicUtil.term_of_uri refl_equal in - let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in - [(t, ty, [])], [] - in - let t2 = Unix.gettimeofday () in - let _ = - debug_print - (lazy - (Printf.sprintf - "Theorems:\n-------------------------------------\n%s\n" - (String.concat "\n" - (List.map - (fun (t, ty, _) -> - Printf.sprintf - "Term: %s, type: %s" - (CicPp.ppterm t) (CicPp.ppterm ty)) - (fst theorems))))); - debug_print - (lazy - (Printf.sprintf "Time to retrieve theorems: %.9f\n" (t2 -. t1))); - in - let active = make_active () in - let passive = make_passive [] equalities in - let start = Unix.gettimeofday () in - let res = - let goals = make_goals goal in - given_clause_fullred dbd env goals theorems passive active - in - let finish = Unix.gettimeofday () in - (res, finish -. start) - in - match res with - | ParamodulationSuccess (Some proof, env) -> - debug_print (lazy "OK, found a proof!"); - let proof = Inference.build_proof_term proof in - let names = names_of_context context in - let newmetasenv = - let i1 = - match new_meta_goal with - | C.Meta (i, _) -> i | _ -> 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 (lazy (CicPp.pp proof [](* names *))); - debug_print - (lazy - (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 - (lazy - (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 (lazy "THE PROOF DOESN'T TYPECHECK!!!"); - debug_print (lazy (CicPp.pp proof names)); - raise (ProofEngineTypes.Fail - (lazy "Found a proof, but it doesn't typecheck")) - in - debug_print (lazy (Printf.sprintf "\nTIME NEEDED: %.9f" time)); - newstatus - | _ -> - raise (ProofEngineTypes.Fail (lazy "NO proof found")) -;; - -(* dummy function called within matita to trigger linkage *) -let init () = ();; - - -(* UGLY SIDE EFFECT... *) -if connect_to_auto then ( - AutoTactic.paramodulation_tactic := saturate; - AutoTactic.term_is_equality := Inference.term_is_equality; -);; - - -let retrieve_and_print 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 proof = None, (1, [], term)::metasenv, C.Meta (1, []), term 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 uri, metasenv, meta_proof, term_to_prove = proof in - let _, context, goal = CicUtil.lookup_meta goal' metasenv in - let eq_indexes, 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 - (lazy (Printf.sprintf "\n\nTIPO DEL GOAL: %s\n" (CicPp.ppterm ty))); - Cic.Meta (maxm+1, irl), - (maxm+1, context, ty)::metasenv, - ty - in - let ugraph = CicUniv.empty_ugraph in - let env = (metasenv, context, ugraph) in - let goal = Inference.BasicProof new_meta_goal, [], goal in - let t1 = Unix.gettimeofday () in - let lib_eq_uris, library_equalities, maxm = - find_library_equalities dbd context (proof, goal') (maxm+2) - in - let t2 = Unix.gettimeofday () in - maxmeta := maxm+2; - let equalities = - let equalities = (* equalities @ *) library_equalities in - debug_print - (lazy - (Printf.sprintf "\n\nequalities:\n%s\n" - (String.concat "\n" - (List.map - (fun (u, e) -> -(* Printf.sprintf "%s: %s" *) - (UriManager.string_of_uri u) -(* (string_of_equality e) *) - ) - equalities)))); - debug_print (lazy "SIMPLYFYING EQUALITIES..."); - let rec simpl e others others_simpl = - let (u, e) = e in - let active = List.map (fun (u, e) -> (Positive, e)) - (others @ others_simpl) in - let tbl = - List.fold_left - (fun t (_, e) -> Indexing.index t e) - Indexing.empty active - in - let res = forward_simplify env (Positive, e) (active, tbl) in - match others with - | hd::tl -> ( - match res with - | None -> simpl hd tl others_simpl - | Some e -> simpl hd tl ((u, (snd e))::others_simpl) - ) - | [] -> ( - match res with - | None -> others_simpl - | Some e -> (u, (snd e))::others_simpl - ) - in - match equalities with - | [] -> [] - | hd::tl -> - let others = tl in (* List.map (fun e -> (Positive, e)) tl in *) - let res = - List.rev (simpl (*(Positive,*) hd others []) - in - debug_print - (lazy - (Printf.sprintf "\nequalities AFTER:\n%s\n" - (String.concat "\n" - (List.map - (fun (u, e) -> - Printf.sprintf "%s: %s" - (UriManager.string_of_uri u) - (string_of_equality e) - ) - res)))); - res - in - debug_print - (lazy - (Printf.sprintf "Time to retrieve equalities: %.9f\n" (t2 -. t1))) -;; - - -let main_demod_equalities 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 proof = None, (1, [], term)::metasenv, C.Meta (1, []), term 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 eq_indexes, equalities, maxm = find_equalities context proof in - let lib_eq_uris, library_equalities, maxm = - find_library_equalities dbd context (proof, goal') (maxm+2) - in - let library_equalities = List.map snd library_equalities 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 - debug_print - (lazy - (Printf.sprintf "\n\nTRYING TO INFER EQUALITIES MATCHING: %s\n\n" - (CicPp.ppterm ty))); - Cic.Meta (maxm+1, irl), - (maxm+1, context, ty)::metasenv, - ty - in - let env = (metasenv, context, ugraph) in - let t1 = Unix.gettimeofday () in - try - let goal = Inference.BasicProof new_meta_goal, [], goal in - let equalities = - let equalities = equalities @ library_equalities in - debug_print - (lazy - (Printf.sprintf "equalities:\n%s\n" - (String.concat "\n" - (List.map string_of_equality equalities)))); - debug_print (lazy "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 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 - (lazy - (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 [] equalities in - 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 (); - if !time_limit < 1. then time_limit := 60.; - let ra, rp = - saturate_equations env goal (fun e -> true) passive active - in - let finish = Unix.gettimeofday () in - - let initial = - List.fold_left (fun s e -> EqualitySet.add e s) - EqualitySet.empty equalities - in - let addfun s e = - if not (EqualitySet.mem e initial) then EqualitySet.add e s else s - in - - let passive = - match rp with - | (n, _), (p, _), _ -> - EqualitySet.elements (List.fold_left addfun EqualitySet.empty p) - in - let active = - let l = List.map snd (fst ra) in - EqualitySet.elements (List.fold_left addfun EqualitySet.empty l) - in - Printf.printf "\n\nRESULTS:\nActive:\n%s\n\nPassive:\n%s\n" -(* (String.concat "\n" (List.map (string_of_equality ~env) active)) *) - (String.concat "\n" - (List.map (fun e -> CicPp.ppterm (term_of_equality e)) active)) -(* (String.concat "\n" (List.map (string_of_equality ~env) passive)); *) - (String.concat "\n" - (List.map (fun e -> CicPp.ppterm (term_of_equality e)) passive)); - print_newline (); - with e -> - debug_print (lazy ("EXCEPTION: " ^ (Printexc.to_string e))) -;; diff --git a/helm/ocaml/paramodulation/test_indexing.ml b/helm/ocaml/paramodulation/test_indexing.ml deleted file mode 100644 index ba6b2ebe0..000000000 --- a/helm/ocaml/paramodulation/test_indexing.ml +++ /dev/null @@ -1,253 +0,0 @@ -(* $Id$ *) - -open Path_indexing - -(* -let build_equality term = - let module C = Cic in - C.Implicit None, (C.Implicit None, term, C.Rel 1, Utils.Gt), [], [] -;; - - -(* - f = Rel 1 - g = Rel 2 - a = Rel 3 - b = Rel 4 - c = Rel 5 -*) -let path_indexing_test () = - let module C = Cic in - let terms = [ - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Meta (1, [])]; C.Rel 5]; - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Meta (1, [])]; - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Rel 4]; C.Rel 5]; - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 5]; C.Rel 4]; - C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (1, [])] - ] in - let path_strings = List.map (path_strings_of_term 0) terms in - let table = - List.fold_left index PSTrie.empty (List.map build_equality terms) in - let query = - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Rel 5] in - let matches = retrieve_generalizations table query in - let unifications = retrieve_unifiables table query in - let eq1 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (1, [])]) - and eq2 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (2, [])]) in - let res1 = in_index table eq1 - and res2 = in_index table eq2 in - let print_results res = - String.concat "\n" - (PosEqSet.fold - (fun (p, e) l -> - let s = - "(" ^ (Utils.string_of_pos p) ^ ", " ^ - (Inference.string_of_equality e) ^ ")" - in - s::l) - res []) - in - Printf.printf "path_strings:\n%s\n\n" - (String.concat "\n" - (List.map - (fun l -> - "{" ^ (String.concat "; " (List.map string_of_path_string l)) ^ "}" - ) path_strings)); - Printf.printf "table:\n%s\n\n" (string_of_pstrie table); - Printf.printf "matches:\n%s\n\n" (print_results matches); - Printf.printf "unifications:\n%s\n\n" (print_results unifications); - Printf.printf "in_index %s: %s\n" - (Inference.string_of_equality eq1) (string_of_bool res1); - Printf.printf "in_index %s: %s\n" - (Inference.string_of_equality eq2) (string_of_bool res2); -;; - - -let differing () = - let module C = Cic in - let t1 = - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Meta (1, [])]; C.Rel 5] - and t2 = - C.Appl [C.Rel 1; C.Appl [C.Rel 5; C.Rel 4; C.Meta (1, [])]; C.Rel 5] - in - let res = Inference.extract_differing_subterms t1 t2 in - match res with - | None -> print_endline "NO DIFFERING SUBTERMS???" - | Some (t1, t2) -> - Printf.printf "OK: %s, %s\n" (CicPp.ppterm t1) (CicPp.ppterm t2); -;; - - -let next_after () = - let module C = Cic in - let t = - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Rel 4]; C.Rel 5] - in - let pos1 = Discrimination_tree.next_t [1] t in - let pos2 = Discrimination_tree.after_t [1] t in - Printf.printf "next_t 1: %s\nafter_t 1: %s\n" - (CicPp.ppterm (Discrimination_tree.subterm_at_pos pos1 t)) - (CicPp.ppterm (Discrimination_tree.subterm_at_pos pos2 t)); -;; - - -let discrimination_tree_test () = - let module C = Cic in - let terms = [ - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Meta (1, [])]; C.Rel 5]; - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Meta (1, [])]; - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Rel 4]; C.Rel 5]; - C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 5]; C.Rel 4]; - C.Appl [C.Rel 10; C.Meta (5, []); C.Rel 11] - ] in - let path_strings = - List.map Discrimination_tree.path_string_of_term terms in - let table = - List.fold_left - Discrimination_tree.index - Discrimination_tree.DiscriminationTree.empty - (List.map build_equality terms) - in -(* let query = *) -(* C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Rel 5] in *) - let query = C.Appl [C.Rel 10; C.Meta (14, []); C.Meta (13, [])] in - let matches = Discrimination_tree.retrieve_generalizations table query in - let unifications = Discrimination_tree.retrieve_unifiables table query in - let eq1 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (1, [])]) - and eq2 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (2, [])]) in - let res1 = Discrimination_tree.in_index table eq1 - and res2 = Discrimination_tree.in_index table eq2 in - let print_results res = - String.concat "\n" - (Discrimination_tree.PosEqSet.fold - (fun (p, e) l -> - let s = - "(" ^ (Utils.string_of_pos p) ^ ", " ^ - (Inference.string_of_equality e) ^ ")" - in - s::l) - res []) - in - Printf.printf "path_strings:\n%s\n\n" - (String.concat "\n" - (List.map Discrimination_tree.string_of_path_string path_strings)); - Printf.printf "table:\n%s\n\n" - (Discrimination_tree.string_of_discrimination_tree table); - Printf.printf "matches:\n%s\n\n" (print_results matches); - Printf.printf "unifications:\n%s\n\n" (print_results unifications); - Printf.printf "in_index %s: %s\n" - (Inference.string_of_equality eq1) (string_of_bool res1); - Printf.printf "in_index %s: %s\n" - (Inference.string_of_equality eq2) (string_of_bool res2); -;; - - -let test_subst () = - let module C = Cic in - let module M = CicMetaSubst in - let term = C.Appl [ - C.Rel 1; - C.Appl [C.Rel 11; - C.Meta (43, []); - C.Appl [C.Rel 15; C.Rel 12; C.Meta (41, [])]]; - C.Appl [C.Rel 11; - C.Appl [C.Rel 15; C.Meta (10, []); C.Meta (11, [])]; - C.Appl [C.Rel 15; C.Meta (10, []); C.Meta (12, [])]] - ] in - let subst1 = [ - (43, ([], C.Appl [C.Rel 15; C.Meta (10, []); C.Meta (11, [])], C.Rel 16)); - (10, ([], C.Rel 12, C.Rel 16)); - (12, ([], C.Meta (41, []), C.Rel 16)) - ] - and subst2 = [ - (43, ([], C.Appl [C.Rel 15; C.Rel 12; C.Meta (11, [])], C.Rel 16)); - (10, ([], C.Rel 12, C.Rel 16)); - (12, ([], C.Meta (41, []), C.Rel 16)) - ] in - let t1 = M.apply_subst subst1 term - and t2 = M.apply_subst subst2 term in - Printf.printf "t1 = %s\nt2 = %s\n" (CicPp.ppterm t1) (CicPp.ppterm t2); -;; -*) - - -let test_refl () = - let module C = Cic in - let context = [ - Some (C.Name "H", C.Decl ( - C.Prod (C.Name "z", C.Rel 3, - C.Appl [ - C.MutInd (HelmLibraryObjects.Logic.eq_URI, 0, []); - C.Rel 4; C.Rel 3; C.Rel 1]))); - Some (C.Name "x", C.Decl (C.Rel 2)); - Some (C.Name "y", C.Decl (C.Rel 1)); - Some (C.Name "A", C.Decl (C.Sort C.Set)) - ] - in - let term = C.Appl [ - C.Const (HelmLibraryObjects.Logic.eq_ind_URI, []); C.Rel 4; - C.Rel 2; - C.Lambda (C.Name "z", C.Rel 4, - C.Appl [ - C.MutInd (HelmLibraryObjects.Logic.eq_URI, 0, []); - C.Rel 5; C.Rel 1; C.Rel 3 - ]); - C.Appl [C.MutConstruct - (HelmLibraryObjects.Logic.eq_URI, 0, 1, []); (* reflexivity *) - C.Rel 4; C.Rel 2]; - C.Rel 3; -(* C.Appl [C.Const (HelmLibraryObjects.Logic.sym_eq_URI, []); (\* symmetry *\) *) -(* C.Rel 4; C.Appl [C.Rel 1; C.Rel 2]] *) - C.Appl [ - C.Const (HelmLibraryObjects.Logic.eq_ind_URI, []); - C.Rel 4; C.Rel 3; - C.Lambda (C.Name "z", C.Rel 4, - C.Appl [ - C.MutInd (HelmLibraryObjects.Logic.eq_URI, 0, []); - C.Rel 5; C.Rel 1; C.Rel 4 - ]); - C.Appl [C.MutConstruct (HelmLibraryObjects.Logic.eq_URI, 0, 1, []); - C.Rel 4; C.Rel 3]; - C.Rel 2; C.Appl [C.Rel 1; C.Rel 2] - ] - ] in - let ens = [ - (UriManager.uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/A.var", - C.Rel 4); - (UriManager.uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/x.var", - C.Rel 3); - (UriManager.uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/y.var", - C.Rel 2); - ] in - let term2 = C.Appl [ - C.Const (HelmLibraryObjects.Logic.sym_eq_URI, ens); - C.Appl [C.Rel 1; C.Rel 2] - ] in - let ty, ug = - CicTypeChecker.type_of_aux' [] context term CicUniv.empty_ugraph - in - Printf.printf "OK, %s ha tipo %s\n" (CicPp.ppterm term) (CicPp.ppterm ty); - let ty, ug = - CicTypeChecker.type_of_aux' [] context term2 CicUniv.empty_ugraph - in - Printf.printf "OK, %s ha tipo %s\n" (CicPp.ppterm term2) (CicPp.ppterm ty); -;; - - -let test_lib () = - let uri = Sys.argv.(1) in - let t = CicUtil.term_of_uri (UriManager.uri_of_string uri) in - let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in - Printf.printf "Term of %s: %s\n" uri (CicPp.ppterm t); - Printf.printf "type: %s\n" (CicPp.ppterm ty); -;; - - -(* differing ();; *) -(* next_after ();; *) -(* discrimination_tree_test ();; *) -(* path_indexing_test ();; *) -(* test_subst ();; *) -Helm_registry.load_from "../../matita/matita.conf.xml"; -(* test_refl ();; *) -test_lib ();; diff --git a/helm/ocaml/paramodulation/utils.ml b/helm/ocaml/paramodulation/utils.ml deleted file mode 100644 index 5eb591c0b..000000000 --- a/helm/ocaml/paramodulation/utils.ml +++ /dev/null @@ -1,596 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* $Id$ *) - -let debug = true;; - -let debug_print s = if debug then prerr_endline (Lazy.force s);; - -let print_metasenv metasenv = - String.concat "\n--------------------------\n" - (List.map (fun (i, context, term) -> - (string_of_int i) ^ " [\n" ^ (CicPp.ppcontext context) ^ - "\n] " ^ (CicPp.ppterm term)) - metasenv) -;; - - -let print_subst ?(prefix="\n") subst = - String.concat prefix - (List.map - (fun (i, (c, t, ty)) -> - Printf.sprintf "?%d -> %s : %s" i - (CicPp.ppterm t) (CicPp.ppterm ty)) - subst) -;; - -(* (weight of constants, [(meta, weight_of_meta)]) *) -type weight = int * (int * int) list;; - -let string_of_weight (cw, mw) = - let s = - String.concat ", " - (List.map (function (m, w) -> Printf.sprintf "(%d,%d)" m w) mw) - in - Printf.sprintf "[%d; %s]" cw s - - -let weight_of_term ?(consider_metas=true) term = - let module C = Cic in - let vars_dict = Hashtbl.create 5 in - let rec aux = function - | C.Meta (metano, _) when consider_metas -> - (try - let oldw = Hashtbl.find vars_dict metano in - Hashtbl.replace vars_dict metano (oldw+1) - with Not_found -> - Hashtbl.add vars_dict metano 1); - 0 - | C.Meta _ -> 0 (* "variables" are lighter than constants and functions...*) - - | C.Var (_, ens) - | C.Const (_, ens) - | C.MutInd (_, _, ens) - | C.MutConstruct (_, _, _, ens) -> - List.fold_left (fun w (u, t) -> (aux t) + w) 1 ens - - | C.Cast (t1, t2) - | C.Lambda (_, t1, t2) - | C.Prod (_, t1, t2) - | C.LetIn (_, t1, t2) -> - let w1 = aux t1 in - let w2 = aux t2 in - w1 + w2 + 1 - - | C.Appl l -> List.fold_left (+) 0 (List.map aux l) - - | C.MutCase (_, _, outt, t, pl) -> - let w1 = aux outt in - let w2 = aux t in - let w3 = List.fold_left (+) 0 (List.map aux pl) in - w1 + w2 + w3 + 1 - - | C.Fix (_, fl) -> - List.fold_left (fun w (n, i, t1, t2) -> (aux t1) + (aux t2) + w) 1 fl - - | C.CoFix (_, fl) -> - List.fold_left (fun w (n, t1, t2) -> (aux t1) + (aux t2) + w) 1 fl - - | _ -> 1 - in - let w = aux term in - let l = - Hashtbl.fold (fun meta metaw resw -> (meta, metaw)::resw) vars_dict [] in - let compare w1 w2 = - match w1, w2 with - | (m1, _), (m2, _) -> m2 - m1 - in - (w, List.sort compare l) (* from the biggest meta to the smallest (0) *) -;; - - -module OrderedInt = struct - type t = int - - let compare = Pervasives.compare -end - -module IntSet = Set.Make(OrderedInt) - -let compute_equality_weight ty left right = - let metasw = ref 0 in - let weight_of t = - let w, m = (weight_of_term ~consider_metas:true t) in - metasw := !metasw + (2 * (List.length m)); - w - in - (* Warning: the following let cannot be expanded since it forces the - right evaluation order!!!! *) - let w = (weight_of ty) + (weight_of left) + (weight_of right) in - w + !metasw -;; - - -(* returns a "normalized" version of the polynomial weight wl (with type - * weight list), i.e. a list sorted ascending by meta number, - * from 0 to maxmeta. wl must be sorted descending by meta number. Example: - * normalize_weight 5 (3, [(3, 2); (1, 1)]) -> - * (3, [(1, 1); (2, 0); (3, 2); (4, 0); (5, 0)]) *) -let normalize_weight maxmeta (cw, wl) = - let rec aux = function - | 0 -> [] - | m -> (m, 0)::(aux (m-1)) - in - let tmpl = aux maxmeta in - let wl = - List.sort - (fun (m, _) (n, _) -> Pervasives.compare m n) - (List.fold_left - (fun res (m, w) -> (m, w)::(List.remove_assoc m res)) tmpl wl) - in - (cw, wl) -;; - - -let normalize_weights (cw1, wl1) (cw2, wl2) = - let rec aux wl1 wl2 = - match wl1, wl2 with - | [], [] -> [], [] - | (m, w)::tl1, (n, w')::tl2 when m = n -> - let res1, res2 = aux tl1 tl2 in - (m, w)::res1, (n, w')::res2 - | (m, w)::tl1, ((n, w')::_ as wl2) when m < n -> - let res1, res2 = aux tl1 wl2 in - (m, w)::res1, (m, 0)::res2 - | ((m, w)::_ as wl1), (n, w')::tl2 when m > n -> - let res1, res2 = aux wl1 tl2 in - (n, 0)::res1, (n, w')::res2 - | [], (n, w)::tl2 -> - let res1, res2 = aux [] tl2 in - (n, 0)::res1, (n, w)::res2 - | (m, w)::tl1, [] -> - let res1, res2 = aux tl1 [] in - (m, w)::res1, (m, 0)::res2 - | _, _ -> assert false - in - let cmp (m, _) (n, _) = compare m n in - let wl1, wl2 = aux (List.sort cmp wl1) (List.sort cmp wl2) in - (cw1, wl1), (cw2, wl2) -;; - - -type comparison = Lt | Le | Eq | Ge | Gt | Incomparable;; - -let string_of_comparison = function - | Lt -> "<" - | Le -> "<=" - | Gt -> ">" - | Ge -> ">=" - | Eq -> "=" - | Incomparable -> "I" - - -let compare_weights ?(normalize=false) - ((h1, w1) as weight1) ((h2, w2) as weight2)= - let (h1, w1), (h2, w2) = - if normalize then - normalize_weights weight1 weight2 - else - (h1, w1), (h2, w2) - in - let res, diffs = - try - List.fold_left2 - (fun ((lt, eq, gt), diffs) w1 w2 -> - match w1, w2 with - | (meta1, w1), (meta2, w2) when meta1 = meta2 -> - let diffs = (w1 - w2) + diffs in - let r = compare w1 w2 in - if r < 0 then (lt+1, eq, gt), diffs - else if r = 0 then (lt, eq+1, gt), diffs - else (lt, eq, gt+1), diffs - | (meta1, w1), (meta2, w2) -> - debug_print - (lazy - (Printf.sprintf "HMMM!!!! %s, %s\n" - (string_of_weight weight1) (string_of_weight weight2))); - assert false) - ((0, 0, 0), 0) w1 w2 - with Invalid_argument _ -> - debug_print - (lazy - (Printf.sprintf "Invalid_argument: %s{%s}, %s{%s}, normalize = %s\n" - (string_of_weight (h1, w1)) (string_of_weight weight1) - (string_of_weight (h2, w2)) (string_of_weight weight2) - (string_of_bool normalize))); - assert false - in - let hdiff = h1 - h2 in - match res with - | (0, _, 0) -> - if hdiff < 0 then Lt - else if hdiff > 0 then Gt - else Eq (* Incomparable *) - | (m, _, 0) -> - if diffs < (- hdiff) then Lt - else if diffs = (- hdiff) then Le else Incomparable -(* - if hdiff <= 0 then - if m > 0 || hdiff < 0 then Lt - else if diffs >= (- hdiff) then Le else Incomparable - else - if diffs >= (- hdiff) then Le else Incomparable *) - | (0, _, m) -> - if (- hdiff) < diffs then Gt - else if (- hdiff) = diffs then Ge else Incomparable -(* - if hdiff >= 0 then - if m > 0 || hdiff > 0 then Gt - else if (- diffs) >= hdiff then Ge else Incomparable - else - if (- diffs) >= hdiff then Ge else Incomparable *) - | (m, _, n) when m > 0 && n > 0 -> - Incomparable - | _ -> assert false -;; - - -let rec aux_ordering ?(recursion=true) t1 t2 = - let module C = Cic in - let compare_uris u1 u2 = - let res = - compare (UriManager.string_of_uri u1) (UriManager.string_of_uri u2) in - if res < 0 then Lt - else if res = 0 then Eq - else Gt - in - match t1, t2 with - | C.Meta _, _ - | _, C.Meta _ -> Incomparable - - | t1, t2 when t1 = t2 -> Eq - - | C.Rel n, C.Rel m -> if n > m then Lt else Gt - | C.Rel _, _ -> Lt - | _, C.Rel _ -> Gt - - | C.Const (u1, _), C.Const (u2, _) -> compare_uris u1 u2 - | C.Const _, _ -> Lt - | _, C.Const _ -> Gt - - | C.MutInd (u1, _, _), C.MutInd (u2, _, _) -> compare_uris u1 u2 - | C.MutInd _, _ -> Lt - | _, C.MutInd _ -> Gt - - | C.MutConstruct (u1, _, _, _), C.MutConstruct (u2, _, _, _) -> - compare_uris u1 u2 - | C.MutConstruct _, _ -> Lt - | _, C.MutConstruct _ -> Gt - - | C.Appl l1, C.Appl l2 when recursion -> - let rec cmp t1 t2 = - match t1, t2 with - | [], [] -> Eq - | _, [] -> Gt - | [], _ -> Lt - | hd1::tl1, hd2::tl2 -> - let o = aux_ordering hd1 hd2 in - if o = Eq then cmp tl1 tl2 - else o - in - cmp l1 l2 - | C.Appl (h1::t1), C.Appl (h2::t2) when not recursion -> - aux_ordering h1 h2 - - | t1, t2 -> - debug_print - (lazy - (Printf.sprintf "These two terms are not comparable:\n%s\n%s\n\n" - (CicPp.ppterm t1) (CicPp.ppterm t2))); - Incomparable -;; - - -(* w1, w2 are the weights, they should already be normalized... *) -let nonrec_kbo_w (t1, w1) (t2, w2) = - match compare_weights w1 w2 with - | Le -> if aux_ordering t1 t2 = Lt then Lt else Incomparable - | Ge -> if aux_ordering t1 t2 = Gt then Gt else Incomparable - | Eq -> aux_ordering t1 t2 - | res -> res -;; - - -let nonrec_kbo t1 t2 = - let w1 = weight_of_term t1 in - let w2 = weight_of_term t2 in - (* - prerr_endline ("weight1 :"^(string_of_weight w1)); - prerr_endline ("weight2 :"^(string_of_weight w2)); - *) - match compare_weights ~normalize:true w1 w2 with - | Le -> if aux_ordering t1 t2 = Lt then Lt else Incomparable - | Ge -> if aux_ordering t1 t2 = Gt then Gt else Incomparable - | Eq -> aux_ordering t1 t2 - | res -> res -;; - - -let rec kbo t1 t2 = - let aux = aux_ordering ~recursion:false in - let w1 = weight_of_term t1 - and w2 = weight_of_term t2 in - let rec cmp t1 t2 = - match t1, t2 with - | [], [] -> Eq - | _, [] -> Gt - | [], _ -> Lt - | hd1::tl1, hd2::tl2 -> - let o = - kbo hd1 hd2 - in - if o = Eq then cmp tl1 tl2 - else o - in - let comparison = compare_weights ~normalize:true w1 w2 in - match comparison with - | Le -> - let r = aux t1 t2 in - if r = Lt then Lt - else if r = Eq then ( - match t1, t2 with - | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> - if cmp tl1 tl2 = Lt then Lt else Incomparable - | _, _ -> Incomparable - ) else Incomparable - | Ge -> - let r = aux t1 t2 in - if r = Gt then Gt - else if r = Eq then ( - match t1, t2 with - | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> - if cmp tl1 tl2 = Gt then Gt else Incomparable - | _, _ -> Incomparable - ) else Incomparable - | Eq -> - let r = aux t1 t2 in - if r = Eq then ( - match t1, t2 with - | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> - cmp tl1 tl2 - | _, _ -> Incomparable - ) else r - | res -> res -;; - -let rec ao t1 t2 = - let get_hd t = - match t with - Cic.MutConstruct(uri,tyno,cno,_) -> Some(uri,tyno,cno) - | Cic.Appl(Cic.MutConstruct(uri,tyno,cno,_)::_) -> - Some(uri,tyno,cno) - | _ -> None in - let aux = aux_ordering ~recursion:false in - let w1 = weight_of_term t1 - and w2 = weight_of_term t2 in - let rec cmp t1 t2 = - match t1, t2 with - | [], [] -> Eq - | _, [] -> Gt - | [], _ -> Lt - | hd1::tl1, hd2::tl2 -> - let o = - ao hd1 hd2 - in - if o = Eq then cmp tl1 tl2 - else o - in - match get_hd t1, get_hd t2 with - Some(_),None -> Lt - | None,Some(_) -> Gt - | _ -> - let comparison = compare_weights ~normalize:true w1 w2 in - match comparison with - | Le -> - let r = aux t1 t2 in - if r = Lt then Lt - else if r = Eq then ( - match t1, t2 with - | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> - if cmp tl1 tl2 = Lt then Lt else Incomparable - | _, _ -> Incomparable - ) else Incomparable - | Ge -> - let r = aux t1 t2 in - if r = Gt then Gt - else if r = Eq then ( - match t1, t2 with - | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> - if cmp tl1 tl2 = Gt then Gt else Incomparable - | _, _ -> Incomparable - ) else Incomparable - | Eq -> - let r = aux t1 t2 in - if r = Eq then ( - match t1, t2 with - | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> - cmp tl1 tl2 - | _, _ -> Incomparable - ) else r - | res -> res -;; - -let names_of_context context = - List.map - (function - | None -> None - | Some (n, e) -> Some n) - context -;; - - -module OrderedTerm = -struct - type t = Cic.term - - let compare = Pervasives.compare -end - -module TermSet = Set.Make(OrderedTerm);; -module TermMap = Map.Make(OrderedTerm);; - -let symbols_of_term term = - let module C = Cic in - let rec aux map = function - | C.Meta _ -> map - | C.Appl l -> - List.fold_left (fun res t -> (aux res t)) map l - | t -> - let map = - try - let c = TermMap.find t map in - TermMap.add t (c+1) map - with Not_found -> - TermMap.add t 1 map - in - map - in - aux TermMap.empty term -;; - - -let metas_of_term term = - let module C = Cic in - let rec aux = function - | C.Meta _ as t -> TermSet.singleton t - | C.Appl l -> - List.fold_left (fun res t -> TermSet.union res (aux t)) TermSet.empty l - | t -> TermSet.empty (* TODO: maybe add other cases? *) - in - aux term -;; - - -let rec lpo t1 t2 = - let module C = Cic in - match t1, t2 with - | t1, t2 when t1 = t2 -> Eq - | t1, (C.Meta _ as m) -> - if TermSet.mem m (metas_of_term t1) then Gt else Incomparable - | (C.Meta _ as m), t2 -> - if TermSet.mem m (metas_of_term t2) then Lt else Incomparable - | C.Appl (hd1::tl1), C.Appl (hd2::tl2) -> ( - let res = - let f o r t = - if r then true else - match lpo t o with - | Gt | Eq -> true - | _ -> false - in - let res1 = List.fold_left (f t2) false tl1 in - if res1 then Gt - else let res2 = List.fold_left (f t1) false tl2 in - if res2 then Lt - else Incomparable - in - if res <> Incomparable then - res - else - let f o r t = - if not r then false else - match lpo o t with - | Gt -> true - | _ -> false - in - match aux_ordering hd1 hd2 with - | Gt -> - let res = List.fold_left (f t1) false tl2 in - if res then Gt - else Incomparable - | Lt -> - let res = List.fold_left (f t2) false tl1 in - if res then Lt - else Incomparable - | Eq -> ( - let lex_res = - try - List.fold_left2 - (fun r t1 t2 -> if r <> Eq then r else lpo t1 t2) - Eq tl1 tl2 - with Invalid_argument _ -> - Incomparable - in - match lex_res with - | Gt -> - if List.fold_left (f t1) false tl2 then Gt - else Incomparable - | Lt -> - if List.fold_left (f t2) false tl1 then Lt - else Incomparable - | _ -> Incomparable - ) - | _ -> Incomparable - ) - | t1, t2 -> aux_ordering t1 t2 -;; - - -(* settable by the user... *) -let compare_terms = ref nonrec_kbo;; -(* let compare_terms = ref ao;; *) - -let guarded_simpl context t = - let t' = ProofEngineReduction.simpl context t in - let simpl_order = !compare_terms t t' in - if simpl_order = Gt then - (* prerr_endline ("reduce: "^(CicPp.ppterm t)^(CicPp.ppterm t')); *) - t' - else t -;; - -type equality_sign = Negative | Positive;; - -let string_of_sign = function - | Negative -> "Negative" - | Positive -> "Positive" -;; - - -type pos = Left | Right - -let string_of_pos = function - | Left -> "Left" - | Right -> "Right" -;; - - -let eq_ind_URI () = LibraryObjects.eq_ind_URI ~eq:(LibraryObjects.eq_URI ()) -let eq_ind_r_URI () = LibraryObjects.eq_ind_r_URI ~eq:(LibraryObjects.eq_URI ()) -let sym_eq_URI () = LibraryObjects.sym_eq_URI ~eq:(LibraryObjects.eq_URI ()) -let eq_XURI () = - let s = UriManager.string_of_uri (LibraryObjects.eq_URI ()) in - UriManager.uri_of_string (s ^ "#xpointer(1/1/1)") -let trans_eq_URI () = LibraryObjects.trans_eq_URI ~eq:(LibraryObjects.eq_URI ()) diff --git a/helm/ocaml/paramodulation/utils.mli b/helm/ocaml/paramodulation/utils.mli deleted file mode 100644 index d52483ddb..000000000 --- a/helm/ocaml/paramodulation/utils.mli +++ /dev/null @@ -1,82 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://cs.unibo.it/helm/. - *) - -(* (weight of constants, [(meta, weight_of_meta)]) *) -type weight = int * (int * int) list;; - -type comparison = Lt | Le | Eq | Ge | Gt | Incomparable;; - -val print_metasenv: Cic.metasenv -> string - -val print_subst: ?prefix:string -> Cic.substitution -> string - -val string_of_weight: weight -> string - -val weight_of_term: ?consider_metas:bool -> Cic.term -> weight - -val normalize_weight: int -> weight -> weight - -val string_of_comparison: comparison -> string - -val compare_weights: ?normalize:bool -> weight -> weight -> comparison - -val nonrec_kbo: Cic.term -> Cic.term -> comparison - -val nonrec_kbo_w: (Cic.term * weight) -> (Cic.term * weight) -> comparison - -val names_of_context: Cic.context -> (Cic.name option) list - -module TermMap: Map.S with type key = Cic.term - -val symbols_of_term: Cic.term -> int TermMap.t - -val lpo: Cic.term -> Cic.term -> comparison - -val kbo: Cic.term -> Cic.term -> comparison - -val ao: Cic.term -> Cic.term -> comparison - -(** term-ordering function settable by the user *) -val compare_terms: (Cic.term -> Cic.term -> comparison) ref - -val guarded_simpl: Cic.context -> Cic.term -> Cic.term - -type equality_sign = Negative | Positive - -val string_of_sign: equality_sign -> string - -type pos = Left | Right - -val string_of_pos: pos -> string - -val compute_equality_weight: Cic.term -> Cic.term -> Cic.term -> int - -val debug_print: string Lazy.t -> unit - -val eq_ind_URI: unit -> UriManager.uri -val eq_ind_r_URI: unit -> UriManager.uri -val sym_eq_URI: unit -> UriManager.uri -val eq_XURI: unit -> UriManager.uri -val trans_eq_URI: unit -> UriManager.uri diff --git a/helm/ocaml/tactics/.depend b/helm/ocaml/tactics/.depend index 95131ecf4..dd623b9ae 100644 --- a/helm/ocaml/tactics/.depend +++ b/helm/ocaml/tactics/.depend @@ -5,6 +5,9 @@ reductionTactics.cmi: proofEngineTypes.cmi proofEngineStructuralRules.cmi: proofEngineTypes.cmi primitiveTactics.cmi: proofEngineTypes.cmi metadataQuery.cmi: proofEngineTypes.cmi +paramodulation/inference.cmi: proofEngineTypes.cmi +paramodulation/indexing.cmi: proofEngineTypes.cmi +paramodulation/saturation.cmi: proofEngineTypes.cmi variousTactics.cmi: proofEngineTypes.cmi autoTactic.cmi: proofEngineTypes.cmi introductionTactics.cmi: proofEngineTypes.cmi @@ -48,6 +51,22 @@ metadataQuery.cmo: proofEngineTypes.cmi primitiveTactics.cmi \ hashtbl_equiv.cmi metadataQuery.cmi metadataQuery.cmx: proofEngineTypes.cmx primitiveTactics.cmx \ hashtbl_equiv.cmx metadataQuery.cmi +paramodulation/utils.cmo: paramodulation/utils.cmi +paramodulation/utils.cmx: paramodulation/utils.cmi +paramodulation/inference.cmo: proofEngineReduction.cmi proofEngineHelpers.cmi \ + metadataQuery.cmi paramodulation/inference.cmi +paramodulation/inference.cmx: proofEngineReduction.cmx proofEngineHelpers.cmx \ + metadataQuery.cmx paramodulation/inference.cmi +paramodulation/equality_indexing.cmo: paramodulation/equality_indexing.cmi +paramodulation/equality_indexing.cmx: paramodulation/equality_indexing.cmi +paramodulation/indexing.cmo: proofEngineTypes.cmi primitiveTactics.cmi \ + paramodulation/indexing.cmi +paramodulation/indexing.cmx: proofEngineTypes.cmx primitiveTactics.cmx \ + paramodulation/indexing.cmi +paramodulation/saturation.cmo: proofEngineTypes.cmi proofEngineReduction.cmi \ + primitiveTactics.cmi paramodulation/saturation.cmi +paramodulation/saturation.cmx: proofEngineTypes.cmx proofEngineReduction.cmx \ + primitiveTactics.cmx paramodulation/saturation.cmi variousTactics.cmo: tacticals.cmi proofEngineTypes.cmi \ proofEngineReduction.cmi proofEngineHelpers.cmi primitiveTactics.cmi \ variousTactics.cmi diff --git a/helm/ocaml/tactics/Makefile b/helm/ocaml/tactics/Makefile index 1595fb337..57937414c 100644 --- a/helm/ocaml/tactics/Makefile +++ b/helm/ocaml/tactics/Makefile @@ -6,18 +6,26 @@ INTERFACE_FILES = \ continuationals.mli \ tacticals.mli reductionTactics.mli proofEngineStructuralRules.mli \ primitiveTactics.mli hashtbl_equiv.mli metadataQuery.mli \ + paramodulation/utils.mli \ + paramodulation/inference.mli\ + paramodulation/equality_indexing.mli\ + paramodulation/indexing.mli \ + paramodulation/saturation.mli \ variousTactics.mli autoTactic.mli \ introductionTactics.mli eliminationTactics.mli negationTactics.mli \ equalityTactics.mli discriminationTactics.mli inversion.mli ring.mli \ fourier.mli fourierR.mli fwdSimplTactic.mli history.mli \ statefulProofEngine.mli tactics.mli + IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) + all: -tactics.mli: tactics.ml *Tactics.mli *Tactic.mli fourierR.mli ring.mli +tactics.mli: tactics.ml *Tactics.mli *Tactic.mli fourierR.mli ring.mli paramodulation/indexing.mli echo "(* GENERATED FILE, DO NOT EDIT *)" > $@ - $(OCAMLC) -i $< >> $@ + $(OCAMLC) -I paramodulation -i $< >> $@ include ../Makefile.common +OCAMLOPTIONS+= -I paramodulation diff --git a/helm/ocaml/tactics/autoTactic.ml b/helm/ocaml/tactics/autoTactic.ml index dc5b8324c..42df90768 100644 --- a/helm/ocaml/tactics/autoTactic.ml +++ b/helm/ocaml/tactics/autoTactic.ml @@ -295,13 +295,14 @@ let auto_tac ?(depth=default_depth) ?(width=default_width) ~(dbd:HMysql.dbd) ;; *) +(* let paramodulation_tactic = ref (fun dbd ?full ?depth ?width status -> raise (ProofEngineTypes.Fail (lazy "Not Ready yet...")));; let term_is_equality = ref (fun term -> debug_print (lazy "term_is_equality E` DUMMY!!!!"); false);; - +*) let auto_tac ?(depth=default_depth) ?(width=default_width) ?paramodulation ?full ~(dbd:HMysql.dbd) () = @@ -333,12 +334,12 @@ let auto_tac ?(depth=default_depth) ?(width=default_width) ?paramodulation | Some _ -> let _, metasenv, _, _ = proof in let _, _, meta_goal = CicUtil.lookup_meta goal metasenv in - full || (!term_is_equality meta_goal) + full || (Inference.term_is_equality meta_goal) in if paramodulation_ok then ( debug_print (lazy "USO PARAMODULATION..."); (* try *) - !paramodulation_tactic dbd ~depth ~width ~full (proof, goal) + Saturation.saturate dbd ~depth ~width ~full (proof, goal) (* with ProofEngineTypes.Fail _ -> *) (* normal_auto () *) ) else diff --git a/helm/ocaml/tactics/autoTactic.mli b/helm/ocaml/tactics/autoTactic.mli index 696c97007..fe72629f0 100644 --- a/helm/ocaml/tactics/autoTactic.mli +++ b/helm/ocaml/tactics/autoTactic.mli @@ -29,10 +29,3 @@ val auto_tac: dbd:HMysql.dbd -> unit -> ProofEngineTypes.tactic -val paramodulation_tactic: - (HMysql.dbd -> ?full:bool -> ?depth:int -> ?width:int -> - ProofEngineTypes.status -> - ProofEngineTypes.proof * ProofEngineTypes.goal list) ref - -val term_is_equality: - (Cic.term -> bool) ref diff --git a/helm/ocaml/tactics/paramodulation/.depend b/helm/ocaml/tactics/paramodulation/.depend new file mode 100644 index 000000000..b5dd3a819 --- /dev/null +++ b/helm/ocaml/tactics/paramodulation/.depend @@ -0,0 +1,12 @@ +inference.cmi: utils.cmi +equality_indexing.cmi: utils.cmi inference.cmi +utils.cmo: utils.cmi +utils.cmx: utils.cmi +inference.cmo: utils.cmi inference.cmi +inference.cmx: utils.cmx inference.cmi +equality_indexing.cmo: utils.cmi inference.cmi equality_indexing.cmi +equality_indexing.cmx: utils.cmx inference.cmx equality_indexing.cmi +indexing.cmo: utils.cmi inference.cmi equality_indexing.cmi indexing.cmi +indexing.cmx: utils.cmx inference.cmx equality_indexing.cmx indexing.cmi +saturation.cmo: utils.cmi inference.cmi indexing.cmi +saturation.cmx: utils.cmx inference.cmx indexing.cmx diff --git a/helm/ocaml/tactics/paramodulation/Makefile b/helm/ocaml/tactics/paramodulation/Makefile new file mode 100644 index 000000000..af04e29c4 --- /dev/null +++ b/helm/ocaml/tactics/paramodulation/Makefile @@ -0,0 +1,14 @@ +PACKAGE = dummy + +LOCALLINKOPTS = -package helm-cic_disambiguation,helm-content_pres,helm-grafite,helm-grafite_parser,helm-tactics + +saturate: saturate_main.ml $(LIBRARIES) + $(OCAMLC) $(LOCALLINKOPTS) -thread -linkpkg -o $@ $< +saturate.opt: saturate_main.ml $(PARAMOD_OBJS_OPT) $(LIBRARIES) + $(OCAMLOPT) $(LOCALLINKOPTS) -thread -linkpkg -o $@ $(PARAMOD_OBJS_OPT) < + +clean: + rm saturate saturate.cmo saturate.cmx + +include ../../Makefile.common + diff --git a/helm/ocaml/tactics/paramodulation/README b/helm/ocaml/tactics/paramodulation/README new file mode 100644 index 000000000..bf484ae16 --- /dev/null +++ b/helm/ocaml/tactics/paramodulation/README @@ -0,0 +1,45 @@ +make saturate per compilare l'eseguibile da riga di comando (make saturate.opt per la versione ottimizzata) + +./saturate -h per vedere una lista di parametri: + +./saturate: unknown option `-h'. +Usage: + -full Enable full mode + -f Enable/disable full-reduction strategy (default: enabled) + -r Weight-Age equality selection ratio (default: 4) + -s symbols-based selection ratio (relative to the weight ratio, default: 0) + -c Configuration file (for the db connection) + -o Term ordering. Possible values are: + kbo: Knuth-Bendix ordering + nr-kbo: Non-recursive variant of kbo (default) + lpo: Lexicographic path ordering + -l Time limit in seconds (default: no limit) + -w Maximal width (default: 3) + -d Maximal depth (default: 3) + -retrieve retrieve only + -help Display this list of options + --help Display this list of options + + +./saturate -l 10 -demod-equalities + +dove -l 10 e` il timeout in secondi. + +Il programma legge da standard input il teorema, per esempio + +\forall n:nat.n + n = 2 * n +\forall n:R.n + n = 2 * n +\forall n:R.n+n=n+n + +l'input termina con una riga vuota (quindi basta un doppio invio alla fine) + +In output, oltre ai vari messaggi di debug, vengono stampati gli insiemi +active e passive alla fine dell'esecuzione. Consiglio di redirigere l'output +su file, per esempio usando tee: + +./saturate -l 10 -demod-equalities | tee output.txt + +Il formato di stampa e` quello per gli oggetti di tipo equality (usa la +funzione Inference.string_of_equality) + + diff --git a/helm/ocaml/tactics/paramodulation/equality_indexing.ml b/helm/ocaml/tactics/paramodulation/equality_indexing.ml new file mode 100644 index 000000000..1dffb6399 --- /dev/null +++ b/helm/ocaml/tactics/paramodulation/equality_indexing.ml @@ -0,0 +1,131 @@ +(* Copyright (C) 2005, HELM Team. + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://cs.unibo.it/helm/. + *) + +(* $Id$ *) + +module type EqualityIndex = + sig + module PosEqSet : Set.S with type elt = Utils.pos * Inference.equality + val arities : (Cic.term, int) Hashtbl.t + type key = Cic.term + type t = Discrimination_tree.DiscriminationTreeIndexing(PosEqSet).t + val empty : t + val retrieve_generalizations : t -> key -> PosEqSet.t + val retrieve_unifiables : t -> key -> PosEqSet.t + val init_index : unit -> unit + val remove_index : t -> Inference.equality -> t + val index : t -> Inference.equality -> t + val in_index : t -> Inference.equality -> bool + end + +module DT = +struct + module OrderedPosEquality = struct + type t = Utils.pos * Inference.equality + let compare = Pervasives.compare + end + + module PosEqSet = Set.Make(OrderedPosEquality);; + + include Discrimination_tree.DiscriminationTreeIndexing(PosEqSet) + + + (* DISCRIMINATION TREES *) + let init_index () = + Hashtbl.clear arities; + ;; + + let remove_index tree equality = + let _, _, (_, l, r, ordering), _, _ = equality in + match ordering with + | Utils.Gt -> remove_index tree l (Utils.Left, equality) + | Utils.Lt -> remove_index tree r (Utils.Right, equality) + | _ -> + let tree = remove_index tree r (Utils.Right, equality) in + remove_index tree l (Utils.Left, equality) + + let index tree equality = + let _, _, (_, l, r, ordering), _, _ = equality in + match ordering with + | Utils.Gt -> index tree l (Utils.Left, equality) + | Utils.Lt -> index tree r (Utils.Right, equality) + | _ -> + let tree = index tree r (Utils.Right, equality) in + index tree l (Utils.Left, equality) + + + let in_index tree equality = + let _, _, (_, l, r, ordering), _, _ = equality in + let meta_convertibility (pos,equality') = + Inference.meta_convertibility_eq equality equality' + in + in_index tree l meta_convertibility || in_index tree r meta_convertibility + + end + +module PT = + struct + module OrderedPosEquality = struct + type t = Utils.pos * Inference.equality + let compare = Pervasives.compare + end + + module PosEqSet = Set.Make(OrderedPosEquality);; + + include Discrimination_tree.DiscriminationTreeIndexing(PosEqSet) + + + (* DISCRIMINATION TREES *) + let init_index () = + Hashtbl.clear arities; + ;; + + let remove_index tree equality = + let _, _, (_, l, r, ordering), _, _ = equality in + match ordering with + | Utils.Gt -> remove_index tree l (Utils.Left, equality) + | Utils.Lt -> remove_index tree r (Utils.Right, equality) + | _ -> + let tree = remove_index tree r (Utils.Right, equality) in + remove_index tree l (Utils.Left, equality) + + let index tree equality = + let _, _, (_, l, r, ordering), _, _ = equality in + match ordering with + | Utils.Gt -> index tree l (Utils.Left, equality) + | Utils.Lt -> index tree r (Utils.Right, equality) + | _ -> + let tree = index tree r (Utils.Right, equality) in + index tree l (Utils.Left, equality) + + + let in_index tree equality = + let _, _, (_, l, r, ordering), _, _ = equality in + let meta_convertibility (pos,equality') = + Inference.meta_convertibility_eq equality equality' + in + in_index tree l meta_convertibility || in_index tree r meta_convertibility +end + diff --git a/helm/ocaml/tactics/paramodulation/equality_indexing.mli b/helm/ocaml/tactics/paramodulation/equality_indexing.mli new file mode 100644 index 000000000..d7c3bec5e --- /dev/null +++ b/helm/ocaml/tactics/paramodulation/equality_indexing.mli @@ -0,0 +1,43 @@ +(* Copyright (C) 2005, HELM Team. + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://helm.cs.unibo.it/ + *) + +module type EqualityIndex = + sig + module PosEqSet : Set.S with type elt = Utils.pos * Inference.equality + val arities : (Cic.term, int) Hashtbl.t + type key = Cic.term + type t = Discrimination_tree.DiscriminationTreeIndexing(PosEqSet).t + val empty : t + val retrieve_generalizations : t -> key -> PosEqSet.t + val retrieve_unifiables : t -> key -> PosEqSet.t + val init_index : unit -> unit + val remove_index : t -> Inference.equality -> t + val index : t -> Inference.equality -> t + val in_index : t -> Inference.equality -> bool + end + +module DT : EqualityIndex +module PT : EqualityIndex + diff --git a/helm/ocaml/tactics/paramodulation/indexing.ml b/helm/ocaml/tactics/paramodulation/indexing.ml new file mode 100644 index 000000000..b60435e04 --- /dev/null +++ b/helm/ocaml/tactics/paramodulation/indexing.ml @@ -0,0 +1,1044 @@ +(* Copyright (C) 2005, HELM Team. + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://cs.unibo.it/helm/. + *) + +(* $Id$ *) + +module Index = Equality_indexing.DT (* discrimination tree based indexing *) +(* +module Index = Equality_indexing.DT (* path tree based indexing *) +*) + +let debug_print = Utils.debug_print;; + + +type retrieval_mode = Matching | Unification;; + +let print_candidates mode term res = + let _ = + match mode with + | Matching -> + Printf.printf "| candidates Matching %s\n" (CicPp.ppterm term) + | Unification -> + Printf.printf "| candidates Unification %s\n" (CicPp.ppterm term) + in + print_endline + (String.concat "\n" + (List.map + (fun (p, e) -> + Printf.sprintf "| (%s, %s)" (Utils.string_of_pos p) + (Inference.string_of_equality e)) + res)); + print_endline "|"; +;; + + +let indexing_retrieval_time = ref 0.;; + + +let apply_subst = CicMetaSubst.apply_subst + +let index = Index.index +let remove_index = Index.remove_index +let in_index = Index.in_index +let empty = Index.empty +let init_index = Index.init_index + +(* returns a list of all the equalities in the tree that are in relation + "mode" with the given term, where mode can be either Matching or + Unification. + + Format of the return value: list of tuples in the form: + (position - Left or Right - of the term that matched the given one in this + equality, + equality found) + + Note that if equality is "left = right", if the ordering is left > right, + the position will always be Left, and if the ordering is left < right, + position will be Right. +*) +let get_candidates mode tree term = + let t1 = Unix.gettimeofday () in + let res = + let s = + match mode with + | Matching -> Index.retrieve_generalizations tree term + | Unification -> Index.retrieve_unifiables tree term + in + Index.PosEqSet.elements s + in + (* print_candidates mode term res; *) +(* print_endline (Discrimination_tree.string_of_discrimination_tree tree); *) +(* print_newline (); *) + let t2 = Unix.gettimeofday () in + indexing_retrieval_time := !indexing_retrieval_time +. (t2 -. t1); + res +;; + + +let match_unif_time_ok = ref 0.;; +let match_unif_time_no = ref 0.;; + + +(* + finds the first equality in the index that matches "term", of type "termty" + termty can be Implicit if it is not needed. The result (one of the sides of + the equality, actually) should be not greater (wrt the term ordering) than + term + + Format of the return value: + + (term to substitute, [Cic.Rel 1 properly lifted - see the various + build_newtarget functions inside the various + demodulation_* functions] + substitution used for the matching, + metasenv, + ugraph, [substitution, metasenv and ugraph have the same meaning as those + returned by CicUnification.fo_unif] + (equality where the matching term was found, [i.e. the equality to use as + rewrite rule] + uri [either eq_ind_URI or eq_ind_r_URI, depending on the direction of + the equality: this is used to build the proof term, again see one of + the build_newtarget functions] + )) +*) +let rec find_matches metasenv context ugraph lift_amount term termty = + let module C = Cic in + let module U = Utils in + let module S = CicSubstitution in + let module M = CicMetaSubst in + let module HL = HelmLibraryObjects in + let cmp = !Utils.compare_terms in + let check = match termty with C.Implicit None -> false | _ -> true in + function + | [] -> None + | candidate::tl -> + let pos, (_, proof, (ty, left, right, o), metas, args) = candidate in + if check && not (fst (CicReduction.are_convertible + ~metasenv context termty ty ugraph)) then ( + find_matches metasenv context ugraph lift_amount term termty tl + ) else + let do_match c eq_URI = + let subst', metasenv', ugraph' = + let t1 = Unix.gettimeofday () in + try + let r = + Inference.matching (metasenv @ metas) context + term (S.lift lift_amount c) ugraph + in + let t2 = Unix.gettimeofday () in + match_unif_time_ok := !match_unif_time_ok +. (t2 -. t1); + r + with Inference.MatchingFailure as e -> + let t2 = Unix.gettimeofday () in + match_unif_time_no := !match_unif_time_no +. (t2 -. t1); + raise e + in + Some (C.Rel (1 + lift_amount), subst', metasenv', ugraph', + (candidate, eq_URI)) + in + let c, other, eq_URI = + if pos = Utils.Left then left, right, Utils.eq_ind_URI () + else right, left, Utils.eq_ind_r_URI () + in + if o <> U.Incomparable then + try + do_match c eq_URI + with Inference.MatchingFailure -> + find_matches metasenv context ugraph lift_amount term termty tl + else + let res = + try do_match c eq_URI + with Inference.MatchingFailure -> None + in + match res with + | Some (_, s, _, _, _) -> + let c' = apply_subst s c in + (* + let other' = U.guarded_simpl context (apply_subst s other) in *) + let other' = apply_subst s other in + let order = cmp c' other' in + let names = U.names_of_context context in + if order = U.Gt then + res + else + find_matches + metasenv context ugraph lift_amount term termty tl + | None -> + find_matches metasenv context ugraph lift_amount term termty tl +;; + + +(* + as above, but finds all the matching equalities, and the matching condition + can be either Inference.matching or Inference.unification +*) +let rec find_all_matches ?(unif_fun=Inference.unification) + metasenv context ugraph lift_amount term termty = + let module C = Cic in + let module U = Utils in + let module S = CicSubstitution in + let module M = CicMetaSubst in + let module HL = HelmLibraryObjects in + let cmp = !Utils.compare_terms in + function + | [] -> [] + | candidate::tl -> + let pos, (_, _, (ty, left, right, o), metas, args) = candidate in + let do_match c eq_URI = + let subst', metasenv', ugraph' = + let t1 = Unix.gettimeofday () in + try + let r = + unif_fun (metasenv @ metas) context + term (S.lift lift_amount c) ugraph in + let t2 = Unix.gettimeofday () in + match_unif_time_ok := !match_unif_time_ok +. (t2 -. t1); + r + with + | Inference.MatchingFailure + | CicUnification.UnificationFailure _ + | CicUnification.Uncertain _ as e -> + let t2 = Unix.gettimeofday () in + match_unif_time_no := !match_unif_time_no +. (t2 -. t1); + raise e + in + (C.Rel (1 + lift_amount), subst', metasenv', ugraph', + (candidate, eq_URI)) + in + let c, other, eq_URI = + if pos = Utils.Left then left, right, Utils.eq_ind_URI () + else right, left, Utils.eq_ind_r_URI () + in + if o <> U.Incomparable then + try + let res = do_match c eq_URI in + res::(find_all_matches ~unif_fun metasenv context ugraph + lift_amount term termty tl) + with + | Inference.MatchingFailure + | CicUnification.UnificationFailure _ + | CicUnification.Uncertain _ -> + find_all_matches ~unif_fun metasenv context ugraph + lift_amount term termty tl + else + try + let res = do_match c eq_URI in + match res with + | _, s, _, _, _ -> + let c' = apply_subst s c + and other' = apply_subst s other in + let order = cmp c' other' in + let names = U.names_of_context context in + if order <> U.Lt && order <> U.Le then + res::(find_all_matches ~unif_fun metasenv context ugraph + lift_amount term termty tl) + else + find_all_matches ~unif_fun metasenv context ugraph + lift_amount term termty tl + with + | Inference.MatchingFailure + | CicUnification.UnificationFailure _ + | CicUnification.Uncertain _ -> + find_all_matches ~unif_fun metasenv context ugraph + lift_amount term termty tl +;; + + +(* + returns true if target is subsumed by some equality in table +*) +let subsumption env table target = + let _, _, (ty, left, right, _), tmetas, _ = target in + let metasenv, context, ugraph = env in + let metasenv = metasenv @ tmetas in + let samesubst subst subst' = + let tbl = Hashtbl.create (List.length subst) in + List.iter (fun (m, (c, t1, t2)) -> Hashtbl.add tbl m (c, t1, t2)) subst; + List.for_all + (fun (m, (c, t1, t2)) -> + try + let c', t1', t2' = Hashtbl.find tbl m in + if (c = c') && (t1 = t1') && (t2 = t2') then true + else false + with Not_found -> + true) + subst' + in + let leftr = + match left with + | Cic.Meta _ -> [] + | _ -> + let leftc = get_candidates Matching table left in + find_all_matches ~unif_fun:Inference.matching + metasenv context ugraph 0 left ty leftc + in + let rec ok what = function + | [] -> false, [] + | (_, subst, menv, ug, ((pos, (_, _, (_, l, r, o), m, _)), _))::tl -> + try + let other = if pos = Utils.Left then r else l in + let subst', menv', ug' = + let t1 = Unix.gettimeofday () in + try + let r = + Inference.matching (metasenv @ menv @ m) context what other ugraph + in + let t2 = Unix.gettimeofday () in + match_unif_time_ok := !match_unif_time_ok +. (t2 -. t1); + r + with Inference.MatchingFailure as e -> + let t2 = Unix.gettimeofday () in + match_unif_time_no := !match_unif_time_no +. (t2 -. t1); + raise e + in + if samesubst subst subst' then + true, subst + else + ok what tl + with Inference.MatchingFailure -> + ok what tl + in + let r, subst = ok right leftr in + let r, s = + if r then + true, subst + else + let rightr = + match right with + | Cic.Meta _ -> [] + | _ -> + let rightc = get_candidates Matching table right in + find_all_matches ~unif_fun:Inference.matching + metasenv context ugraph 0 right ty rightc + in + ok left rightr + in +(* (if r then *) +(* debug_print *) +(* (lazy *) +(* (Printf.sprintf "SUBSUMPTION! %s\n%s\n" *) +(* (Inference.string_of_equality target) (Utils.print_subst s)))); *) + r, s +;; + + +let rec demodulation_aux ?(typecheck=false) + metasenv context ugraph table lift_amount term = + let module C = Cic in + let module S = CicSubstitution in + let module M = CicMetaSubst in + let module HL = HelmLibraryObjects in + let candidates = get_candidates Matching table term in + match term with + | C.Meta _ -> None + | term -> + let termty, ugraph = + if typecheck then + CicTypeChecker.type_of_aux' metasenv context term ugraph + else + C.Implicit None, ugraph + in + let res = + find_matches metasenv context ugraph lift_amount term termty candidates + in + if res <> None then + res + else + match term with + | C.Appl l -> + let res, ll = + List.fold_left + (fun (res, tl) t -> + if res <> None then + (res, tl @ [S.lift 1 t]) + else + let r = + demodulation_aux metasenv context ugraph table + lift_amount t + in + match r with + | None -> (None, tl @ [S.lift 1 t]) + | Some (rel, _, _, _, _) -> (r, tl @ [rel])) + (None, []) l + in ( + match res with + | None -> None + | Some (_, subst, menv, ug, eq_found) -> + Some (C.Appl ll, subst, menv, ug, eq_found) + ) + | C.Prod (nn, s, t) -> + let r1 = + demodulation_aux metasenv context ugraph table lift_amount s in ( + match r1 with + | None -> + let r2 = + demodulation_aux metasenv + ((Some (nn, C.Decl s))::context) ugraph + table (lift_amount+1) t + in ( + match r2 with + | None -> None + | Some (t', subst, menv, ug, eq_found) -> + Some (C.Prod (nn, (S.lift 1 s), t'), + subst, menv, ug, eq_found) + ) + | Some (s', subst, menv, ug, eq_found) -> + Some (C.Prod (nn, s', (S.lift 1 t)), + subst, menv, ug, eq_found) + ) + | C.Lambda (nn, s, t) -> + let r1 = + demodulation_aux metasenv context ugraph table lift_amount s in ( + match r1 with + | None -> + let r2 = + demodulation_aux metasenv + ((Some (nn, C.Decl s))::context) ugraph + table (lift_amount+1) t + in ( + match r2 with + | None -> None + | Some (t', subst, menv, ug, eq_found) -> + Some (C.Lambda (nn, (S.lift 1 s), t'), + subst, menv, ug, eq_found) + ) + | Some (s', subst, menv, ug, eq_found) -> + Some (C.Lambda (nn, s', (S.lift 1 t)), + subst, menv, ug, eq_found) + ) + | t -> + None +;; + + +let build_newtarget_time = ref 0.;; + + +let demod_counter = ref 1;; + +(** demodulation, when target is an equality *) +let rec demodulation_equality newmeta env table sign target = + let module C = Cic in + let module S = CicSubstitution in + let module M = CicMetaSubst in + let module HL = HelmLibraryObjects in + let module U = Utils in + let metasenv, context, ugraph = env in + let _, proof, (eq_ty, left, right, order), metas, args = target in + let metasenv' = metasenv @ metas in + + let maxmeta = ref newmeta in + + let build_newtarget is_left (t, subst, menv, ug, (eq_found, eq_URI)) = + let time1 = Unix.gettimeofday () in + + let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in + let ty = + try fst (CicTypeChecker.type_of_aux' metasenv context what ugraph) + with CicUtil.Meta_not_found _ -> ty + in + let what, other = if pos = Utils.Left then what, other else other, what in + let newterm, newproof = + let bo = Utils.guarded_simpl context (apply_subst subst (S.subst other t)) in + let name = C.Name ("x_Demod_" ^ (string_of_int !demod_counter)) in + incr demod_counter; + let bo' = + let l, r = if is_left then t, S.lift 1 right else S.lift 1 left, t in + C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []); + S.lift 1 eq_ty; l; r] + in + if sign = Utils.Positive then + (bo, + Inference.ProofBlock ( + subst, eq_URI, (name, ty), bo'(* t' *), eq_found, proof)) + else + let metaproof = + incr maxmeta; + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable context in +(* debug_print (lazy (Printf.sprintf "\nADDING META: %d\n" !maxmeta)); *) +(* print_newline (); *) + C.Meta (!maxmeta, irl) + in + let eq_found = + let proof' = + let termlist = + if pos = Utils.Left then [ty; what; other] + else [ty; other; what] + in + Inference.ProofSymBlock (termlist, proof') + in + let what, other = + if pos = Utils.Left then what, other else other, what + in + pos, (0, proof', (ty, other, what, Utils.Incomparable), + menv', args') + in + let target_proof = + let pb = + Inference.ProofBlock (subst, eq_URI, (name, ty), bo', + eq_found, Inference.BasicProof metaproof) + in + match proof with + | Inference.BasicProof _ -> + print_endline "replacing a BasicProof"; + pb + | Inference.ProofGoalBlock (_, parent_proof) -> + print_endline "replacing another ProofGoalBlock"; + Inference.ProofGoalBlock (pb, parent_proof) + | _ -> assert false + in + let refl = + C.Appl [C.MutConstruct (* reflexivity *) + (LibraryObjects.eq_URI (), 0, 1, []); + eq_ty; if is_left then right else left] + in + (bo, + Inference.ProofGoalBlock (Inference.BasicProof refl, target_proof)) + in + let left, right = if is_left then newterm, right else left, newterm in + let m = (Inference.metas_of_term left) @ (Inference.metas_of_term right) in + let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) (metas @ menv') + and newargs = args + in + let ordering = !Utils.compare_terms left right in + + let time2 = Unix.gettimeofday () in + build_newtarget_time := !build_newtarget_time +. (time2 -. time1); + + let res = + let w = Utils.compute_equality_weight eq_ty left right in + (w, newproof, (eq_ty, left, right, ordering), newmetasenv, newargs) + in + !maxmeta, res + in + let res = demodulation_aux metasenv' context ugraph table 0 left in + let newmeta, newtarget = + match res with + | Some t -> + let newmeta, newtarget = build_newtarget true t in + if (Inference.is_identity (metasenv', context, ugraph) newtarget) || + (Inference.meta_convertibility_eq target newtarget) then + newmeta, newtarget + else + demodulation_equality newmeta env table sign newtarget + | None -> + let res = demodulation_aux metasenv' context ugraph table 0 right in + match res with + | Some t -> + let newmeta, newtarget = build_newtarget false t in + if (Inference.is_identity (metasenv', context, ugraph) newtarget) || + (Inference.meta_convertibility_eq target newtarget) then + newmeta, newtarget + else + demodulation_equality newmeta env table sign newtarget + | None -> + newmeta, target + in + (* newmeta, newtarget *) + (* tentiamo di normalizzare *) + let w, p, (ty, left, right, o), m, a = newtarget in + let left = U.guarded_simpl context left in + let right = U.guarded_simpl context right in + let w' = Utils.compute_equality_weight ty left right in + let o' = !Utils.compare_terms left right in + newmeta, (w', p, (ty, left, right, o'), m, a) +;; + + +(** + Performs the beta expansion of the term "term" w.r.t. "table", + i.e. returns the list of all the terms t s.t. "(t term) = t2", for some t2 + in table. +*) +let rec betaexpand_term metasenv context ugraph table lift_amount term = + let module C = Cic in + let module S = CicSubstitution in + let module M = CicMetaSubst in + let module HL = HelmLibraryObjects in + let candidates = get_candidates Unification table term in + let res, lifted_term = + match term with + | C.Meta (i, l) -> + let l', lifted_l = + List.fold_right + (fun arg (res, lifted_tl) -> + match arg with + | Some arg -> + let arg_res, lifted_arg = + betaexpand_term metasenv context ugraph table + lift_amount arg in + let l1 = + List.map + (fun (t, s, m, ug, eq_found) -> + (Some t)::lifted_tl, s, m, ug, eq_found) + arg_res + in + (l1 @ + (List.map + (fun (l, s, m, ug, eq_found) -> + (Some lifted_arg)::l, s, m, ug, eq_found) + res), + (Some lifted_arg)::lifted_tl) + | None -> + (List.map + (fun (r, s, m, ug, eq_found) -> + None::r, s, m, ug, eq_found) res, + None::lifted_tl) + ) l ([], []) + in + let e = + List.map + (fun (l, s, m, ug, eq_found) -> + (C.Meta (i, l), s, m, ug, eq_found)) l' + in + e, C.Meta (i, lifted_l) + + | C.Rel m -> + [], if m <= lift_amount then C.Rel m else C.Rel (m+1) + + | C.Prod (nn, s, t) -> + let l1, lifted_s = + betaexpand_term metasenv context ugraph table lift_amount s in + let l2, lifted_t = + betaexpand_term metasenv ((Some (nn, C.Decl s))::context) ugraph + table (lift_amount+1) t in + let l1' = + List.map + (fun (t, s, m, ug, eq_found) -> + C.Prod (nn, t, lifted_t), s, m, ug, eq_found) l1 + and l2' = + List.map + (fun (t, s, m, ug, eq_found) -> + C.Prod (nn, lifted_s, t), s, m, ug, eq_found) l2 in + l1' @ l2', C.Prod (nn, lifted_s, lifted_t) + + | C.Lambda (nn, s, t) -> + let l1, lifted_s = + betaexpand_term metasenv context ugraph table lift_amount s in + let l2, lifted_t = + betaexpand_term metasenv ((Some (nn, C.Decl s))::context) ugraph + table (lift_amount+1) t in + let l1' = + List.map + (fun (t, s, m, ug, eq_found) -> + C.Lambda (nn, t, lifted_t), s, m, ug, eq_found) l1 + and l2' = + List.map + (fun (t, s, m, ug, eq_found) -> + C.Lambda (nn, lifted_s, t), s, m, ug, eq_found) l2 in + l1' @ l2', C.Lambda (nn, lifted_s, lifted_t) + + | C.Appl l -> + let l', lifted_l = + List.fold_right + (fun arg (res, lifted_tl) -> + let arg_res, lifted_arg = + betaexpand_term metasenv context ugraph table lift_amount arg + in + let l1 = + List.map + (fun (a, s, m, ug, eq_found) -> + a::lifted_tl, s, m, ug, eq_found) + arg_res + in + (l1 @ + (List.map + (fun (r, s, m, ug, eq_found) -> + lifted_arg::r, s, m, ug, eq_found) + res), + lifted_arg::lifted_tl) + ) l ([], []) + in + (List.map + (fun (l, s, m, ug, eq_found) -> (C.Appl l, s, m, ug, eq_found)) l', + C.Appl lifted_l) + + | t -> [], (S.lift lift_amount t) + in + match term with + | C.Meta (i, l) -> res, lifted_term + | term -> + let termty, ugraph = + C.Implicit None, ugraph +(* CicTypeChecker.type_of_aux' metasenv context term ugraph *) + in + let r = + find_all_matches + metasenv context ugraph lift_amount term termty candidates + in + r @ res, lifted_term +;; + + +let sup_l_counter = ref 1;; + +(** + superposition_left + returns a list of new clauses inferred with a left superposition step + the negative equation "target" and one of the positive equations in "table" +*) +let superposition_left newmeta (metasenv, context, ugraph) table target = + let module C = Cic in + let module S = CicSubstitution in + let module M = CicMetaSubst in + let module HL = HelmLibraryObjects in + let module CR = CicReduction in + let module U = Utils in + let weight, proof, (eq_ty, left, right, ordering), _, _ = target in + let expansions, _ = + let term = if ordering = U.Gt then left else right in + betaexpand_term metasenv context ugraph table 0 term + in + let maxmeta = ref newmeta in + let build_new (bo, s, m, ug, (eq_found, eq_URI)) = + +(* debug_print (lazy "\nSUPERPOSITION LEFT\n"); *) + + let time1 = Unix.gettimeofday () in + + let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in + let what, other = if pos = Utils.Left then what, other else other, what in + let newgoal, newproof = + let bo' = U.guarded_simpl context (apply_subst s (S.subst other bo)) in + let name = C.Name ("x_SupL_" ^ (string_of_int !sup_l_counter)) in + incr sup_l_counter; + let bo'' = + let l, r = + if ordering = U.Gt then bo, S.lift 1 right else S.lift 1 left, bo in + C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []); + S.lift 1 eq_ty; l; r] + in + incr maxmeta; + let metaproof = + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable context in + C.Meta (!maxmeta, irl) + in + let eq_found = + let proof' = + let termlist = + if pos = Utils.Left then [ty; what; other] + else [ty; other; what] + in + Inference.ProofSymBlock (termlist, proof') + in + let what, other = + if pos = Utils.Left then what, other else other, what + in + pos, (0, proof', (ty, other, what, Utils.Incomparable), menv', args') + in + let target_proof = + let pb = + Inference.ProofBlock (s, eq_URI, (name, ty), bo'', eq_found, + Inference.BasicProof metaproof) + in + match proof with + | Inference.BasicProof _ -> +(* debug_print (lazy "replacing a BasicProof"); *) + pb + | Inference.ProofGoalBlock (_, parent_proof) -> +(* debug_print (lazy "replacing another ProofGoalBlock"); *) + Inference.ProofGoalBlock (pb, parent_proof) + | _ -> assert false + in + let refl = + C.Appl [C.MutConstruct (* reflexivity *) + (LibraryObjects.eq_URI (), 0, 1, []); + eq_ty; if ordering = U.Gt then right else left] + in + (bo', + Inference.ProofGoalBlock (Inference.BasicProof refl, target_proof)) + in + let left, right = + if ordering = U.Gt then newgoal, right else left, newgoal in + let neworder = !Utils.compare_terms left right in + + let time2 = Unix.gettimeofday () in + build_newtarget_time := !build_newtarget_time +. (time2 -. time1); + + let res = + let w = Utils.compute_equality_weight eq_ty left right in + (w, newproof, (eq_ty, left, right, neworder), [], []) + in + res + in + !maxmeta, List.map build_new expansions +;; + + +let sup_r_counter = ref 1;; + +(** + superposition_right + returns a list of new clauses inferred with a right superposition step + between the positive equation "target" and one in the "table" "newmeta" is + the first free meta index, i.e. the first number above the highest meta + index: its updated value is also returned +*) +let superposition_right newmeta (metasenv, context, ugraph) table target = + let module C = Cic in + let module S = CicSubstitution in + let module M = CicMetaSubst in + let module HL = HelmLibraryObjects in + let module CR = CicReduction in + let module U = Utils in + let _, eqproof, (eq_ty, left, right, ordering), newmetas, args = target in + let metasenv' = metasenv @ newmetas in + let maxmeta = ref newmeta in + let res1, res2 = + match ordering with + | U.Gt -> fst (betaexpand_term metasenv' context ugraph table 0 left), [] + | U.Lt -> [], fst (betaexpand_term metasenv' context ugraph table 0 right) + | _ -> + let res l r = + List.filter + (fun (_, subst, _, _, _) -> + let subst = apply_subst subst in + let o = !Utils.compare_terms (subst l) (subst r) in + o <> U.Lt && o <> U.Le) + (fst (betaexpand_term metasenv' context ugraph table 0 l)) + in + (res left right), (res right left) + in + let build_new ordering (bo, s, m, ug, (eq_found, eq_URI)) = + + let time1 = Unix.gettimeofday () in + + let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in + let what, other = if pos = Utils.Left then what, other else other, what in + let newgoal, newproof = + (* qua *) + let bo' = Utils.guarded_simpl context (apply_subst s (S.subst other bo)) in + let t' = + let name = C.Name ("x_SupR_" ^ (string_of_int !sup_r_counter)) in + incr sup_r_counter; + let l, r = + if ordering = U.Gt then bo, S.lift 1 right else S.lift 1 left, bo in + (name, ty, S.lift 1 eq_ty, l, r) + in + let name = C.Name ("x_SupR_" ^ (string_of_int !sup_r_counter)) in + incr sup_r_counter; + let bo'' = + let l, r = + if ordering = U.Gt then bo, S.lift 1 right else S.lift 1 left, bo in + C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []); + S.lift 1 eq_ty; l; r] + in + bo', + Inference.ProofBlock (s, eq_URI, (name, ty), bo'', eq_found, eqproof) + in + let newmeta, newequality = + let left, right = + if ordering = U.Gt then newgoal, apply_subst s right + else apply_subst s left, newgoal in + let neworder = !Utils.compare_terms left right + and newmenv = newmetas @ menv' + and newargs = args @ args' in + let eq' = + let w = Utils.compute_equality_weight eq_ty left right in + (w, newproof, (eq_ty, left, right, neworder), newmenv, newargs) + and env = (metasenv, context, ugraph) in + let newm, eq' = Inference.fix_metas !maxmeta eq' in + newm, eq' + in + maxmeta := newmeta; + + let time2 = Unix.gettimeofday () in + build_newtarget_time := !build_newtarget_time +. (time2 -. time1); + + newequality + in + let new1 = List.map (build_new U.Gt) res1 + and new2 = List.map (build_new U.Lt) res2 in + let ok e = not (Inference.is_identity (metasenv, context, ugraph) e) in + (!maxmeta, + (List.filter ok (new1 @ new2))) +;; + + +(** demodulation, when the target is a goal *) +let rec demodulation_goal newmeta env table goal = + let module C = Cic in + let module S = CicSubstitution in + let module M = CicMetaSubst in + let module HL = HelmLibraryObjects in + let metasenv, context, ugraph = env in + let maxmeta = ref newmeta in + let proof, metas, term = goal in + let metasenv' = metasenv @ metas in + + let build_newgoal (t, subst, menv, ug, (eq_found, eq_URI)) = + let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in + let what, other = if pos = Utils.Left then what, other else other, what in + let ty = + try fst (CicTypeChecker.type_of_aux' metasenv context what ugraph) + with CicUtil.Meta_not_found _ -> ty + in + let newterm, newproof = + (* qua *) + let bo = Utils.guarded_simpl context (apply_subst subst (S.subst other t)) in + let bo' = apply_subst subst t in + let name = C.Name ("x_DemodGoal_" ^ (string_of_int !demod_counter)) in + incr demod_counter; + let metaproof = + incr maxmeta; + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable context in +(* debug_print (lazy (Printf.sprintf "\nADDING META: %d\n" !maxmeta)); *) + C.Meta (!maxmeta, irl) + in + let eq_found = + let proof' = + let termlist = + if pos = Utils.Left then [ty; what; other] + else [ty; other; what] + in + Inference.ProofSymBlock (termlist, proof') + in + let what, other = + if pos = Utils.Left then what, other else other, what + in + pos, (0, proof', (ty, other, what, Utils.Incomparable), menv', args') + in + let goal_proof = + let pb = + Inference.ProofBlock (subst, eq_URI, (name, ty), bo', + eq_found, Inference.BasicProof metaproof) + in + let rec repl = function + | Inference.NoProof -> +(* debug_print (lazy "replacing a NoProof"); *) + pb + | Inference.BasicProof _ -> +(* debug_print (lazy "replacing a BasicProof"); *) + pb + | Inference.ProofGoalBlock (_, parent_proof) -> +(* debug_print (lazy "replacing another ProofGoalBlock"); *) + Inference.ProofGoalBlock (pb, parent_proof) + | (Inference.SubProof (term, meta_index, p) as subproof) -> +(* debug_print *) +(* (lazy *) +(* (Printf.sprintf "replacing %s" *) +(* (Inference.string_of_proof subproof))); *) + Inference.SubProof (term, meta_index, repl p) + | _ -> assert false + in repl proof + in + bo, Inference.ProofGoalBlock (Inference.NoProof, goal_proof) + in + let m = Inference.metas_of_term newterm in + let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) metas in + !maxmeta, (newproof, newmetasenv, newterm) + in + let res = + demodulation_aux ~typecheck:true metasenv' context ugraph table 0 term + in + match res with + | Some t -> + let newmeta, newgoal = build_newgoal t in + let _, _, newg = newgoal in + if Inference.meta_convertibility term newg then + newmeta, newgoal + else + demodulation_goal newmeta env table newgoal + | None -> + newmeta, goal +;; + + +(** demodulation, when the target is a theorem *) +let rec demodulation_theorem newmeta env table theorem = + let module C = Cic in + let module S = CicSubstitution in + let module M = CicMetaSubst in + let module HL = HelmLibraryObjects in + let metasenv, context, ugraph = env in + let maxmeta = ref newmeta in + let proof, metas, term = theorem in + let term, termty, metas = theorem in + let metasenv' = metasenv @ metas in + + let build_newtheorem (t, subst, menv, ug, (eq_found, eq_URI)) = + let pos, (_, proof', (ty, what, other, _), menv', args') = eq_found in + let what, other = if pos = Utils.Left then what, other else other, what in + let newterm, newty = + (* qua *) + let bo = Utils.guarded_simpl context (apply_subst subst (S.subst other t)) in + let bo' = apply_subst subst t in + let name = C.Name ("x_DemodThm_" ^ (string_of_int !demod_counter)) in + incr demod_counter; + let newproof = + Inference.ProofBlock (subst, eq_URI, (name, ty), bo', eq_found, + Inference.BasicProof term) + in + (Inference.build_proof_term newproof, bo) + in + let m = Inference.metas_of_term newterm in + let newmetasenv = List.filter (fun (i, _, _) -> List.mem i m) metas in + !maxmeta, (newterm, newty, newmetasenv) + in + let res = + demodulation_aux ~typecheck:true metasenv' context ugraph table 0 termty + in + match res with + | Some t -> + let newmeta, newthm = build_newtheorem t in + let newt, newty, _ = newthm in + if Inference.meta_convertibility termty newty then + newmeta, newthm + else + demodulation_theorem newmeta env table newthm + | None -> + newmeta, theorem +;; + +let demodulate_tac ~dbd ~pattern ((proof,goal) as initialstatus) = + let module I = Inference in + let curi,metasenv,pbo,pty = proof in + let (metano,context,ty) as conjecture = CicUtil.lookup_meta goal metasenv in + let eq_indexes, equalities, maxm = I.find_equalities context proof in + let lib_eq_uris, library_equalities, maxm = + I.find_library_equalities dbd context (proof, goal) (maxm+2) in + let irl = CicMkImplicit.identity_relocation_list_for_metavariable context in + let library_equalities = List.map snd library_equalities in + let goalterm = Cic.Meta (metano,irl) in + let initgoal = Inference.BasicProof goalterm, [], goalterm in + let equalities = equalities @ library_equalities in + let table = + List.fold_left + (fun tbl eq -> index tbl eq) + empty equalities + in + let _,(newproof, newty, newmetasenv) = demodulation_goal + maxm (metasenv,context,CicUniv.empty_ugraph) table initgoal + in + let proofterm = Inference.build_proof_term newproof in + ProofEngineTypes.apply_tactic + (PrimitiveTactics.apply_tac ~term:proofterm) + initialstatus + +let demodulate_tac ~dbd ~pattern = + ProofEngineTypes.mk_tactic (demodulate_tac ~dbd ~pattern) diff --git a/helm/ocaml/tactics/paramodulation/inference.ml b/helm/ocaml/tactics/paramodulation/inference.ml new file mode 100644 index 000000000..6c2a9b9dc --- /dev/null +++ b/helm/ocaml/tactics/paramodulation/inference.ml @@ -0,0 +1,957 @@ +(* Copyright (C) 2005, HELM Team. + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://cs.unibo.it/helm/. + *) + +(* $Id$ *) + +open Utils;; + + +type equality = + int * (* weight *) + proof * + (Cic.term * (* type *) + Cic.term * (* left side *) + Cic.term * (* right side *) + Utils.comparison) * (* ordering *) + Cic.metasenv * (* environment for metas *) + Cic.term list (* arguments *) + +and proof = + | NoProof + | BasicProof of Cic.term + | ProofBlock of + Cic.substitution * UriManager.uri * + (Cic.name * Cic.term) * Cic.term * (Utils.pos * equality) * proof + | ProofGoalBlock of proof * proof + | ProofSymBlock of Cic.term list * proof + | SubProof of Cic.term * int * proof +;; + + +let string_of_equality ?env = + match env with + | None -> ( + function + | w, _, (ty, left, right, o), _, _ -> + Printf.sprintf "Weight: %d, {%s}: %s =(%s) %s" w (CicPp.ppterm ty) + (CicPp.ppterm left) (string_of_comparison o) (CicPp.ppterm right) + ) + | Some (_, context, _) -> ( + let names = names_of_context context in + function + | w, _, (ty, left, right, o), _, _ -> + Printf.sprintf "Weight: %d, {%s}: %s =(%s) %s" w (CicPp.pp ty names) + (CicPp.pp left names) (string_of_comparison o) + (CicPp.pp right names) + ) +;; + + +let rec string_of_proof = function + | NoProof -> "NoProof" + | BasicProof t -> "BasicProof " ^ (CicPp.ppterm t) + | SubProof (t, i, p) -> + Printf.sprintf "SubProof(%s, %s, %s)" + (CicPp.ppterm t) (string_of_int i) (string_of_proof p) + | ProofSymBlock _ -> "ProofSymBlock" + | ProofBlock _ -> "ProofBlock" + | ProofGoalBlock (p1, p2) -> + Printf.sprintf "ProofGoalBlock(%s, %s)" + (string_of_proof p1) (string_of_proof p2) +;; + + +(* returns an explicit named subst and a list of arguments for sym_eq_URI *) +let build_ens_for_sym_eq sym_eq_URI termlist = + let obj, _ = CicEnvironment.get_obj CicUniv.empty_ugraph sym_eq_URI in + match obj with + | Cic.Constant (_, _, _, uris, _) -> + assert (List.length uris <= List.length termlist); + let rec aux = function + | [], tl -> [], tl + | (uri::uris), (term::tl) -> + let ens, args = aux (uris, tl) in + (uri, term)::ens, args + | _, _ -> assert false + in + aux (uris, termlist) + | _ -> assert false +;; + + +let build_proof_term proof = + let rec do_build_proof proof = + match proof with + | NoProof -> + Printf.fprintf stderr "WARNING: no proof!\n"; + Cic.Implicit None + | BasicProof term -> term + | ProofGoalBlock (proofbit, proof) -> + print_endline "found ProofGoalBlock, going up..."; + do_build_goal_proof proofbit proof + | ProofSymBlock (termlist, proof) -> + let proof = do_build_proof proof in + let ens, args = build_ens_for_sym_eq (Utils.sym_eq_URI ()) termlist in + Cic.Appl ([Cic.Const (Utils.sym_eq_URI (), ens)] @ args @ [proof]) + | ProofBlock (subst, eq_URI, (name, ty), bo, (pos, eq), eqproof) -> + let t' = Cic.Lambda (name, ty, bo) in + let proof' = + let _, proof', _, _, _ = eq in + do_build_proof proof' + in + let eqproof = do_build_proof eqproof in + let _, _, (ty, what, other, _), menv', args' = eq in + let what, other = + if pos = Utils.Left then what, other else other, what + in + CicMetaSubst.apply_subst subst + (Cic.Appl [Cic.Const (eq_URI, []); ty; + what; t'; eqproof; other; proof']) + | SubProof (term, meta_index, proof) -> + let proof = do_build_proof proof in + let eq i = function + | Cic.Meta (j, _) -> i = j + | _ -> false + in + ProofEngineReduction.replace + ~equality:eq ~what:[meta_index] ~with_what:[proof] ~where:term + + and do_build_goal_proof proofbit proof = + match proof with + | ProofGoalBlock (pb, p) -> + do_build_proof (ProofGoalBlock (replace_proof proofbit pb, p)) + | _ -> do_build_proof (replace_proof proofbit proof) + + and replace_proof newproof = function + | ProofBlock (subst, eq_URI, namety, bo, poseq, eqproof) -> + let eqproof' = replace_proof newproof eqproof in + ProofBlock (subst, eq_URI, namety, bo, poseq, eqproof') + | ProofGoalBlock (pb, p) -> + let pb' = replace_proof newproof pb in + ProofGoalBlock (pb', p) + | BasicProof _ -> newproof + | SubProof (term, meta_index, p) -> + SubProof (term, meta_index, replace_proof newproof p) + | p -> p + in + do_build_proof proof +;; + + +let rec metas_of_term = function + | Cic.Meta (i, c) -> [i] + | Cic.Var (_, ens) + | Cic.Const (_, ens) + | Cic.MutInd (_, _, ens) + | Cic.MutConstruct (_, _, _, ens) -> + List.flatten (List.map (fun (u, t) -> metas_of_term t) ens) + | Cic.Cast (s, t) + | Cic.Prod (_, s, t) + | Cic.Lambda (_, s, t) + | Cic.LetIn (_, s, t) -> (metas_of_term s) @ (metas_of_term t) + | Cic.Appl l -> List.flatten (List.map metas_of_term l) + | Cic.MutCase (uri, i, s, t, l) -> + (metas_of_term s) @ (metas_of_term t) @ + (List.flatten (List.map metas_of_term l)) + | Cic.Fix (i, il) -> + List.flatten + (List.map (fun (s, i, t1, t2) -> + (metas_of_term t1) @ (metas_of_term t2)) il) + | Cic.CoFix (i, il) -> + List.flatten + (List.map (fun (s, t1, t2) -> + (metas_of_term t1) @ (metas_of_term t2)) il) + | _ -> [] +;; + + +exception NotMetaConvertible;; + +let meta_convertibility_aux table t1 t2 = + let module C = Cic in + let print_table t = + String.concat ", " + (List.map + (fun (k, v) -> Printf.sprintf "(%d, %d)" k v) t) + in + let rec aux ((table_l, table_r) as table) t1 t2 = + match t1, t2 with + | C.Meta (m1, tl1), C.Meta (m2, tl2) -> + let m1_binding, table_l = + try List.assoc m1 table_l, table_l + with Not_found -> m2, (m1, m2)::table_l + and m2_binding, table_r = + try List.assoc m2 table_r, table_r + with Not_found -> m1, (m2, m1)::table_r + in + if (m1_binding <> m2) || (m2_binding <> m1) then + raise NotMetaConvertible + else ( + try + List.fold_left2 + (fun res t1 t2 -> + match t1, t2 with + | None, Some _ | Some _, None -> raise NotMetaConvertible + | None, None -> res + | Some t1, Some t2 -> (aux res t1 t2)) + (table_l, table_r) tl1 tl2 + with Invalid_argument _ -> + raise NotMetaConvertible + ) + | C.Var (u1, ens1), C.Var (u2, ens2) + | C.Const (u1, ens1), C.Const (u2, ens2) when (UriManager.eq u1 u2) -> + aux_ens table ens1 ens2 + | C.Cast (s1, t1), C.Cast (s2, t2) + | C.Prod (_, s1, t1), C.Prod (_, s2, t2) + | C.Lambda (_, s1, t1), C.Lambda (_, s2, t2) + | C.LetIn (_, s1, t1), C.LetIn (_, s2, t2) -> + let table = aux table s1 s2 in + aux table t1 t2 + | C.Appl l1, C.Appl l2 -> ( + try List.fold_left2 (fun res t1 t2 -> (aux res t1 t2)) table l1 l2 + with Invalid_argument _ -> raise NotMetaConvertible + ) + | C.MutInd (u1, i1, ens1), C.MutInd (u2, i2, ens2) + when (UriManager.eq u1 u2) && i1 = i2 -> aux_ens table ens1 ens2 + | C.MutConstruct (u1, i1, j1, ens1), C.MutConstruct (u2, i2, j2, ens2) + when (UriManager.eq u1 u2) && i1 = i2 && j1 = j2 -> + aux_ens table ens1 ens2 + | C.MutCase (u1, i1, s1, t1, l1), C.MutCase (u2, i2, s2, t2, l2) + when (UriManager.eq u1 u2) && i1 = i2 -> + let table = aux table s1 s2 in + let table = aux table t1 t2 in ( + try List.fold_left2 (fun res t1 t2 -> (aux res t1 t2)) table l1 l2 + with Invalid_argument _ -> raise NotMetaConvertible + ) + | C.Fix (i1, il1), C.Fix (i2, il2) when i1 = i2 -> ( + try + List.fold_left2 + (fun res (n1, i1, s1, t1) (n2, i2, s2, t2) -> + if i1 <> i2 then raise NotMetaConvertible + else + let res = (aux res s1 s2) in aux res t1 t2) + table il1 il2 + with Invalid_argument _ -> raise NotMetaConvertible + ) + | C.CoFix (i1, il1), C.CoFix (i2, il2) when i1 = i2 -> ( + try + List.fold_left2 + (fun res (n1, s1, t1) (n2, s2, t2) -> + let res = aux res s1 s2 in aux res t1 t2) + table il1 il2 + with Invalid_argument _ -> raise NotMetaConvertible + ) + | t1, t2 when t1 = t2 -> table + | _, _ -> raise NotMetaConvertible + + and aux_ens table ens1 ens2 = + let cmp (u1, t1) (u2, t2) = + compare (UriManager.string_of_uri u1) (UriManager.string_of_uri u2) + in + let ens1 = List.sort cmp ens1 + and ens2 = List.sort cmp ens2 in + try + List.fold_left2 + (fun res (u1, t1) (u2, t2) -> + if not (UriManager.eq u1 u2) then raise NotMetaConvertible + else aux res t1 t2) + table ens1 ens2 + with Invalid_argument _ -> raise NotMetaConvertible + in + aux table t1 t2 +;; + + +let meta_convertibility_eq eq1 eq2 = + let _, _, (ty, left, right, _), _, _ = eq1 + and _, _, (ty', left', right', _), _, _ = eq2 in + if ty <> ty' then + false + else if (left = left') && (right = right') then + true + else if (left = right') && (right = left') then + true + else + try + let table = meta_convertibility_aux ([], []) left left' in + let _ = meta_convertibility_aux table right right' in + true + with NotMetaConvertible -> + try + let table = meta_convertibility_aux ([], []) left right' in + let _ = meta_convertibility_aux table right left' in + true + with NotMetaConvertible -> + false +;; + + +let meta_convertibility t1 t2 = + let f t = + String.concat ", " + (List.map + (fun (k, v) -> Printf.sprintf "(%d, %d)" k v) t) + in + if t1 = t2 then + true + else + try + let l, r = meta_convertibility_aux ([], []) t1 t2 in + true + with NotMetaConvertible -> + false +;; + + +let rec check_irl start = function + | [] -> true + | None::tl -> check_irl (start+1) tl + | (Some (Cic.Rel x))::tl -> + if x = start then check_irl (start+1) tl else false + | _ -> false +;; + + +let rec is_simple_term = function + | Cic.Appl ((Cic.Meta _)::_) -> false + | Cic.Appl l -> List.for_all is_simple_term l + | Cic.Meta (i, l) -> check_irl 1 l + | Cic.Rel _ -> true + | Cic.Const _ -> true + | Cic.MutInd (_, _, []) -> true + | Cic.MutConstruct (_, _, _, []) -> true + | _ -> false +;; + + +let lookup_subst meta subst = + match meta with + | Cic.Meta (i, _) -> ( + try let _, (_, t, _) = List.find (fun (m, _) -> m = i) subst in t + with Not_found -> meta + ) + | _ -> assert false +;; + + +let unification_simple metasenv context t1 t2 ugraph = + let module C = Cic in + let module M = CicMetaSubst in + let module U = CicUnification in + let lookup = lookup_subst in + let rec occurs_check subst what where = + match where with + | t when what = t -> true + | C.Appl l -> List.exists (occurs_check subst what) l + | C.Meta _ -> + let t = lookup where subst in + if t <> where then occurs_check subst what t else false + | _ -> false + in + let rec unif subst menv s t = + let s = match s with C.Meta _ -> lookup s subst | _ -> s + and t = match t with C.Meta _ -> lookup t subst | _ -> t + in + match s, t with + | s, t when s = t -> subst, menv + | C.Meta (i, _), C.Meta (j, _) when i > j -> + unif subst menv t s + | C.Meta _, t when occurs_check subst s t -> + raise + (U.UnificationFailure (lazy "Inference.unification.unif")) + | C.Meta (i, l), t -> ( + try + let _, _, ty = CicUtil.lookup_meta i menv in + let subst = + if not (List.mem_assoc i subst) then (i, (context, t, ty))::subst + else subst + in + let menv = menv in (* List.filter (fun (m, _, _) -> i <> m) menv in *) + subst, menv + with CicUtil.Meta_not_found m -> + let names = names_of_context context in + debug_print + (lazy + (Printf.sprintf "Meta_not_found %d!: %s %s\n%s\n\n%s" m + (CicPp.pp t1 names) (CicPp.pp t2 names) + (print_metasenv menv) (print_metasenv metasenv))); + assert false + ) + | _, C.Meta _ -> unif subst menv t s + | C.Appl (hds::_), C.Appl (hdt::_) when hds <> hdt -> + raise (U.UnificationFailure (lazy "Inference.unification.unif")) + | C.Appl (hds::tls), C.Appl (hdt::tlt) -> ( + try + List.fold_left2 + (fun (subst', menv) s t -> unif subst' menv s t) + (subst, menv) tls tlt + with Invalid_argument _ -> + raise (U.UnificationFailure (lazy "Inference.unification.unif")) + ) + | _, _ -> + raise (U.UnificationFailure (lazy "Inference.unification.unif")) + in + let subst, menv = unif [] metasenv t1 t2 in + let menv = + List.filter + (fun (m, _, _) -> + try let _ = List.find (fun (i, _) -> m = i) subst in false + with Not_found -> true) + menv + in + List.rev subst, menv, ugraph +;; + + +let unification metasenv context t1 t2 ugraph = + let subst, menv, ug = + if not (is_simple_term t1) || not (is_simple_term t2) then ( + debug_print + (lazy + (Printf.sprintf "NOT SIMPLE TERMS: %s %s" + (CicPp.ppterm t1) (CicPp.ppterm t2))); + CicUnification.fo_unif metasenv context t1 t2 ugraph + ) else + unification_simple metasenv context t1 t2 ugraph + in + let rec fix_term = function + | (Cic.Meta (i, l) as t) -> + let t' = lookup_subst t subst in + if t <> t' then fix_term t' else t + | Cic.Appl l -> Cic.Appl (List.map fix_term l) + | t -> t + in + let rec fix_subst = function + | [] -> [] + | (i, (c, t, ty))::tl -> (i, (c, fix_term t, fix_term ty))::(fix_subst tl) + in + fix_subst subst, menv, ug +;; + + +let unification = CicUnification.fo_unif;; + +exception MatchingFailure;; + + +(* +let matching_simple metasenv context t1 t2 ugraph = + let module C = Cic in + let module M = CicMetaSubst in + let module U = CicUnification in + let lookup meta subst = + match meta with + | C.Meta (i, _) -> ( + try let _, (_, t, _) = List.find (fun (m, _) -> m = i) subst in t + with Not_found -> meta + ) + | _ -> assert false + in + let rec do_match subst menv s t = + match s, t with + | s, t when s = t -> subst, menv + | s, C.Meta (i, l) -> + let filter_menv i menv = + List.filter (fun (m, _, _) -> i <> m) menv + in + let subst, menv = + let value = lookup t subst in + match value with + | value when value = t -> + let _, _, ty = CicUtil.lookup_meta i menv in + (i, (context, s, ty))::subst, filter_menv i menv + | value when value <> s -> + raise MatchingFailure + | value -> do_match subst menv s value + in + subst, menv + | C.Appl ls, C.Appl lt -> ( + try + List.fold_left2 + (fun (subst, menv) s t -> do_match subst menv s t) + (subst, menv) ls lt + with Invalid_argument _ -> + raise MatchingFailure + ) + | _, _ -> + raise MatchingFailure + in + let subst, menv = do_match [] metasenv t1 t2 in + subst, menv, ugraph +;; +*) + + +let matching metasenv context t1 t2 ugraph = + try + let subst, metasenv, ugraph = +try + unification metasenv context t1 t2 ugraph +with CicUtil.Meta_not_found _ as exn -> + Printf.eprintf "t1 = %s\nt2 = %s\nmetasenv = %s\n%!" + (CicPp.ppterm t1) (CicPp.ppterm t2) (CicMetaSubst.ppmetasenv [] metasenv); + raise exn + in + let t' = CicMetaSubst.apply_subst subst t1 in + if not (meta_convertibility t1 t') then + raise MatchingFailure + else + let metas = metas_of_term t1 in + let fix_subst = function + | (i, (c, Cic.Meta (j, lc), ty)) when List.mem i metas -> + (j, (c, Cic.Meta (i, lc), ty)) + | s -> s + in + let subst = List.map fix_subst subst in + subst, metasenv, ugraph + with + | CicUnification.UnificationFailure _ + | CicUnification.Uncertain _ -> + raise MatchingFailure +;; + + +let find_equalities context proof = + let module C = Cic in + let module S = CicSubstitution in + let module T = CicTypeChecker in + let eq_uri = LibraryObjects.eq_URI () in + let newmeta = ProofEngineHelpers.new_meta_of_proof ~proof in + let ok_types ty menv = + List.for_all (fun (_, _, mt) -> mt = ty) menv + in + let rec aux index newmeta = function + | [] -> [], newmeta + | (Some (_, C.Decl (term)))::tl -> + let do_find context term = + match term with + | C.Prod (name, s, t) -> + let (head, newmetas, args, newmeta) = + ProofEngineHelpers.saturate_term newmeta [] + context (S.lift index term) 0 + in + let p = + if List.length args = 0 then + C.Rel index + else + C.Appl ((C.Rel index)::args) + in ( + match head with + | C.Appl [C.MutInd (uri, _, _); ty; t1; t2] + when (UriManager.eq uri eq_uri) && (ok_types ty newmetas) -> + debug_print + (lazy + (Printf.sprintf "OK: %s" (CicPp.ppterm term))); + let o = !Utils.compare_terms t1 t2 in + let w = compute_equality_weight ty t1 t2 in + let proof = BasicProof p in + let e = (w, proof, (ty, t1, t2, o), newmetas, args) in + Some e, (newmeta+1) + | _ -> None, newmeta + ) + | C.Appl [C.MutInd (uri, _, _); ty; t1; t2] + when UriManager.eq uri eq_uri -> + let t1 = S.lift index t1 + and t2 = S.lift index t2 in + let o = !Utils.compare_terms t1 t2 in + let w = compute_equality_weight ty t1 t2 in + let e = (w, BasicProof (C.Rel index), (ty, t1, t2, o), [], []) in + Some e, (newmeta+1) + | _ -> None, newmeta + in ( + match do_find context term with + | Some p, newmeta -> + let tl, newmeta' = (aux (index+1) newmeta tl) in + (index, p)::tl, max newmeta newmeta' + | None, _ -> + aux (index+1) newmeta tl + ) + | _::tl -> + aux (index+1) newmeta tl + in + let il, maxm = aux 1 newmeta context in + let indexes, equalities = List.split il in + indexes, equalities, maxm +;; + + +(* +let equations_blacklist = + List.fold_left + (fun s u -> UriManager.UriSet.add (UriManager.uri_of_string u) s) + UriManager.UriSet.empty [ + "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)"; + "cic:/Coq/Init/Logic/trans_eq.con"; + "cic:/Coq/Init/Logic/f_equal.con"; + "cic:/Coq/Init/Logic/f_equal2.con"; + "cic:/Coq/Init/Logic/f_equal3.con"; + "cic:/Coq/Init/Logic/f_equal4.con"; + "cic:/Coq/Init/Logic/f_equal5.con"; + "cic:/Coq/Init/Logic/sym_eq.con"; + "cic:/Coq/Init/Logic/eq_ind.con"; + "cic:/Coq/Init/Logic/eq_ind_r.con"; + "cic:/Coq/Init/Logic/eq_rec.con"; + "cic:/Coq/Init/Logic/eq_rec_r.con"; + "cic:/Coq/Init/Logic/eq_rect.con"; + "cic:/Coq/Init/Logic/eq_rect_r.con"; + "cic:/Coq/Logic/Eqdep/UIP.con"; + "cic:/Coq/Logic/Eqdep/UIP_refl.con"; + "cic:/Coq/Logic/Eqdep_dec/eq2eqT.con"; + "cic:/Coq/ZArith/Zcompare/rename.con"; + (* ALB !!!! questo e` imbrogliare, ma x ora lo lasciamo cosi`... + perche' questo cacchio di teorema rompe le scatole :'( *) + "cic:/Rocq/SUBST/comparith/mult_n_2.con"; + + "cic:/matita/logic/equality/eq_f.con"; + "cic:/matita/logic/equality/eq_f2.con"; + "cic:/matita/logic/equality/eq_rec.con"; + "cic:/matita/logic/equality/eq_rect.con"; + ] +;; +*) +let equations_blacklist = UriManager.UriSet.empty;; + + +let find_library_equalities dbd context status maxmeta = + let module C = Cic in + let module S = CicSubstitution in + let module T = CicTypeChecker in + let blacklist = + List.fold_left + (fun s u -> UriManager.UriSet.add u s) + equations_blacklist + [eq_XURI (); sym_eq_URI (); trans_eq_URI (); eq_ind_URI (); + eq_ind_r_URI ()] + in + let candidates = + List.fold_left + (fun l uri -> + let suri = UriManager.string_of_uri uri in + if UriManager.UriSet.mem uri blacklist then + l + else + let t = CicUtil.term_of_uri uri in + let ty, _ = + CicTypeChecker.type_of_aux' [] context t CicUniv.empty_ugraph + in + (uri, t, ty)::l) + [] + (let t1 = Unix.gettimeofday () in + let eqs = (MetadataQuery.equations_for_goal ~dbd status) in + let t2 = Unix.gettimeofday () in + (debug_print + (lazy + (Printf.sprintf "Tempo di MetadataQuery.equations_for_goal: %.9f\n" + (t2 -. t1)))); + eqs) + in + let eq_uri1 = eq_XURI () + and eq_uri2 = LibraryObjects.eq_URI () in + let iseq uri = + (UriManager.eq uri eq_uri1) || (UriManager.eq uri eq_uri2) + in + let ok_types ty menv = + List.for_all (fun (_, _, mt) -> mt = ty) menv + in + let rec has_vars = function + | C.Meta _ | C.Rel _ | C.Const _ -> false + | C.Var _ -> true + | C.Appl l -> List.exists has_vars l + | C.Prod (_, s, t) | C.Lambda (_, s, t) + | C.LetIn (_, s, t) | C.Cast (s, t) -> + (has_vars s) || (has_vars t) + | _ -> false + in + let rec aux newmeta = function + | [] -> [], newmeta + | (uri, term, termty)::tl -> + debug_print + (lazy + (Printf.sprintf "Examining: %s (%s)" + (CicPp.ppterm term) (CicPp.ppterm termty))); + let res, newmeta = + match termty with + | C.Prod (name, s, t) when not (has_vars termty) -> + let head, newmetas, args, newmeta = + ProofEngineHelpers.saturate_term newmeta [] context termty 0 + in + let p = + if List.length args = 0 then + term + else + C.Appl (term::args) + in ( + match head with + | C.Appl [C.MutInd (uri, _, _); ty; t1; t2] + when (iseq uri) && (ok_types ty newmetas) -> + debug_print + (lazy + (Printf.sprintf "OK: %s" (CicPp.ppterm term))); + let o = !Utils.compare_terms t1 t2 in + let w = compute_equality_weight ty t1 t2 in + let proof = BasicProof p in + let e = (w, proof, (ty, t1, t2, o), newmetas, args) in + Some e, (newmeta+1) + | _ -> None, newmeta + ) + | C.Appl [C.MutInd (uri, _, _); ty; t1; t2] + when iseq uri && not (has_vars termty) -> + let o = !Utils.compare_terms t1 t2 in + let w = compute_equality_weight ty t1 t2 in + let e = (w, BasicProof term, (ty, t1, t2, o), [], []) in + Some e, (newmeta+1) + | _ -> None, newmeta + in + match res with + | Some e -> + let tl, newmeta' = aux newmeta tl in + (uri, e)::tl, max newmeta newmeta' + | None -> + aux newmeta tl + in + let found, maxm = aux maxmeta candidates in + let uriset, eqlist = + (List.fold_left + (fun (s, l) (u, e) -> + if List.exists (meta_convertibility_eq e) (List.map snd l) then ( + debug_print + (lazy + (Printf.sprintf "NO!! %s already there!" + (string_of_equality e))); + (UriManager.UriSet.add u s, l) + ) else (UriManager.UriSet.add u s, (u, e)::l)) + (UriManager.UriSet.empty, []) found) + in + uriset, eqlist, maxm +;; + + +let find_library_theorems dbd env status equalities_uris = + let module C = Cic in + let module S = CicSubstitution in + let module T = CicTypeChecker in + let blacklist = + let refl_equal = + UriManager.uri_of_string "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)" in + let s = + UriManager.UriSet.remove refl_equal + (UriManager.UriSet.union equalities_uris equations_blacklist) + in + List.fold_left + (fun s u -> UriManager.UriSet.add u s) + s [eq_XURI () ;sym_eq_URI (); trans_eq_URI (); eq_ind_URI (); + eq_ind_r_URI ()] + in + let metasenv, context, ugraph = env in + let candidates = + List.fold_left + (fun l uri -> + if UriManager.UriSet.mem uri blacklist then l + else + let t = CicUtil.term_of_uri uri in + let ty, _ = CicTypeChecker.type_of_aux' metasenv context t ugraph in + (t, ty, [])::l) + [] (MetadataQuery.signature_of_goal ~dbd status) + in + let refl_equal = + let u = eq_XURI () in + let t = CicUtil.term_of_uri u in + let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in + (t, ty, []) + in + refl_equal::candidates +;; + + +let find_context_hypotheses env equalities_indexes = + let metasenv, context, ugraph = env in + let _, res = + List.fold_left + (fun (n, l) entry -> + match entry with + | None -> (n+1, l) + | Some _ -> + if List.mem n equalities_indexes then + (n+1, l) + else + let t = Cic.Rel n in + let ty, _ = + CicTypeChecker.type_of_aux' metasenv context t ugraph in + (n+1, (t, ty, [])::l)) + (1, []) context + in + res +;; + + +let fix_metas newmeta ((w, p, (ty, left, right, o), menv, args) as equality) = + let table = Hashtbl.create (List.length args) in + let newargs, newmeta = + List.fold_right + (fun t (newargs, index) -> + match t with + | Cic.Meta (i, l) -> + if Hashtbl.mem table i then + let idx = Hashtbl.find table i in + ((Cic.Meta (idx, l))::newargs, index+1) + else + let _ = Hashtbl.add table i index in + ((Cic.Meta (index, l))::newargs, index+1) + | _ -> assert false) + args ([], newmeta+1) + in + let repl where = + ProofEngineReduction.replace ~equality:(=) ~what:args ~with_what:newargs + ~where + in + let menv' = + List.fold_right + (fun (i, context, term) menv -> + try + let index = Hashtbl.find table i in + (index, context, term)::menv + with Not_found -> + (i, context, term)::menv) + menv [] + in + let ty = repl ty + and left = repl left + and right = repl right in + let metas = (metas_of_term left) @ (metas_of_term right) in + let menv' = List.filter (fun (i, _, _) -> List.mem i metas) menv' in + let newargs = + List.filter + (function Cic.Meta (i, _) -> List.mem i metas | _ -> assert false) newargs + in + let _ = + if List.length metas > 0 then + let first = List.hd metas in + (* this new equality might have less variables than its parents: here + we fill the gap with a dummy arg. Example: + with (f X Y) = X we can simplify + (g X) = (f X Y) in + (g X) = X. + So the new equation has only one variable, but it still has type like + \lambda X,Y:..., so we need to pass a dummy arg for Y + (I hope this makes some sense...) + *) + Hashtbl.iter + (fun k v -> + if not (List.exists + (function Cic.Meta (i, _) -> i = v | _ -> assert false) + newargs) then + Hashtbl.replace table k first) + (Hashtbl.copy table) + in + let rec fix_proof = function + | NoProof -> NoProof + | BasicProof term -> BasicProof (repl term) + | ProofBlock (subst, eq_URI, namety, bo, (pos, eq), p) -> + let subst' = + List.fold_left + (fun s arg -> + match arg with + | Cic.Meta (i, l) -> ( + try + let j = Hashtbl.find table i in + if List.mem_assoc i subst then + s + else + let _, context, ty = CicUtil.lookup_meta i menv in + (i, (context, Cic.Meta (j, l), ty))::s + with Not_found | CicUtil.Meta_not_found _ -> + s + ) + | _ -> assert false) + [] args + in + ProofBlock (subst' @ subst, eq_URI, namety, bo(* t' *), (pos, eq), p) + | p -> assert false + in + let neweq = (w, fix_proof p, (ty, left, right, o), menv', newargs) in + (newmeta + 1, neweq) +;; + + +let term_is_equality term = + let iseq uri = UriManager.eq uri (LibraryObjects.eq_URI ()) in + match term with + | Cic.Appl [Cic.MutInd (uri, _, _); _; _; _] when iseq uri -> true + | _ -> false +;; + + +exception TermIsNotAnEquality;; + +let equality_of_term proof term = + let eq_uri = LibraryObjects.eq_URI () in + let iseq uri = UriManager.eq uri eq_uri in + match term with + | Cic.Appl [Cic.MutInd (uri, _, _); ty; t1; t2] when iseq uri -> + let o = !Utils.compare_terms t1 t2 in + let w = compute_equality_weight ty t1 t2 in + let e = (w, BasicProof proof, (ty, t1, t2, o), [], []) in + e + | _ -> + raise TermIsNotAnEquality +;; + + +type environment = Cic.metasenv * Cic.context * CicUniv.universe_graph;; + + +let is_identity ((metasenv, context, ugraph) as env) = function + | ((_, _, (ty, left, right, _), menv, _) as equality) -> + (left = right || + (* (meta_convertibility left right) || *) + (fst (CicReduction.are_convertible + ~metasenv:(metasenv @ menv) context left right ugraph))) +;; + + +let term_of_equality equality = + let _, _, (ty, left, right, _), menv, args = equality in + let eq i = function Cic.Meta (j, _) -> i = j | _ -> false in + let argsno = List.length args in + let t = + CicSubstitution.lift argsno + (Cic.Appl [Cic.MutInd (LibraryObjects.eq_URI (), 0, []); ty; left; right]) + in + snd ( + List.fold_right + (fun a (n, t) -> + match a with + | Cic.Meta (i, _) -> + let name = Cic.Name ("X" ^ (string_of_int n)) in + let _, _, ty = CicUtil.lookup_meta i menv in + let t = + ProofEngineReduction.replace + ~equality:eq ~what:[i] + ~with_what:[Cic.Rel (argsno - (n - 1))] ~where:t + in + (n-1, Cic.Prod (name, ty, t)) + | _ -> assert false) + args (argsno, t)) +;; diff --git a/helm/ocaml/tactics/paramodulation/inference.mli b/helm/ocaml/tactics/paramodulation/inference.mli new file mode 100644 index 000000000..30927dc72 --- /dev/null +++ b/helm/ocaml/tactics/paramodulation/inference.mli @@ -0,0 +1,133 @@ +(* Copyright (C) 2005, HELM Team. + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://cs.unibo.it/helm/. + *) + +type equality = + int * (* weight *) + proof * (* proof *) + (Cic.term * (* type *) + Cic.term * (* left side *) + Cic.term * (* right side *) + Utils.comparison) * (* ordering *) + Cic.metasenv * (* environment for metas *) + Cic.term list (* arguments *) + +and proof = + | NoProof + | BasicProof of Cic.term (* already a proof of a goal *) + | ProofBlock of (* proof of a rewrite step *) + Cic.substitution * UriManager.uri * (* eq_ind or eq_ind_r *) + (Cic.name * Cic.term) * Cic.term * (Utils.pos * equality) * proof + | ProofGoalBlock of proof * proof + (* proof of the new meta, proof of the goal from which this comes *) + | ProofSymBlock of Cic.term list * proof (* expl.named subst, proof *) + | SubProof of Cic.term * int * proof + (* parent proof, subgoal, proof of the subgoal *) + +type environment = Cic.metasenv * Cic.context * CicUniv.universe_graph + +(** builds the Cic.term encoded by proof *) +val build_proof_term: proof -> Cic.term + +val string_of_proof: proof -> string + +exception MatchingFailure + +(** matching between two terms. Can raise MatchingFailure *) +val matching: + Cic.metasenv -> Cic.context -> Cic.term -> Cic.term -> + CicUniv.universe_graph -> + Cic.substitution * Cic.metasenv * CicUniv.universe_graph + +(** + special unification that checks if the two terms are "simple", and in + such case should be significantly faster than CicUnification.fo_unif +*) +val unification: + Cic.metasenv -> Cic.context -> Cic.term -> Cic.term -> + CicUniv.universe_graph -> + Cic.substitution * Cic.metasenv * CicUniv.universe_graph + + +(** + scans the context to find all Declarations "left = right"; returns a + list of tuples (proof, (type, left, right), newmetas). Uses + PrimitiveTactics.new_metasenv_for_apply to replace bound variables with + fresh metas... +*) +val find_equalities: + Cic.context -> ProofEngineTypes.proof -> int list * equality list * int + +(** + searches the library for equalities that can be applied to the current goal +*) +val find_library_equalities: + HMysql.dbd -> Cic.context -> ProofEngineTypes.status -> int -> + UriManager.UriSet.t * (UriManager.uri * equality) list * int + +(** + searches the library for theorems that are not equalities (returned by the + function above) +*) +val find_library_theorems: + HMysql.dbd -> environment -> ProofEngineTypes.status -> UriManager.UriSet.t -> + (Cic.term * Cic.term * Cic.metasenv) list + +(** + searches the context for hypotheses that are not equalities +*) +val find_context_hypotheses: + environment -> int list -> (Cic.term * Cic.term * Cic.metasenv) list + + +exception TermIsNotAnEquality;; + +(** + raises TermIsNotAnEquality if term is not an equation. + The first Cic.term is a proof of the equation +*) +val equality_of_term: Cic.term -> Cic.term -> equality + +(** + Re-builds the term corresponding to this equality +*) +val term_of_equality: equality -> Cic.term + +val term_is_equality: Cic.term -> bool + +(** tests a sort of alpha-convertibility between the two terms, but on the + metavariables *) +val meta_convertibility: Cic.term -> Cic.term -> bool + +(** meta convertibility between two equations *) +val meta_convertibility_eq: equality -> equality -> bool + +val is_identity: environment -> equality -> bool + +val string_of_equality: ?env:environment -> equality -> string + +val metas_of_term: Cic.term -> int list + +(** ensures that metavariables in equality are unique *) +val fix_metas: int -> equality -> int * equality diff --git a/helm/ocaml/tactics/paramodulation/saturate_main.ml b/helm/ocaml/tactics/paramodulation/saturate_main.ml new file mode 100644 index 000000000..efcfca4ed --- /dev/null +++ b/helm/ocaml/tactics/paramodulation/saturate_main.ml @@ -0,0 +1,166 @@ +(* Copyright (C) 2005, HELM Team. + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://cs.unibo.it/helm/. + *) + +(* $Id$ *) + +module Trivial_disambiguate: +sig + exception Ambiguous_term of string Lazy.t + (** disambiguate an _unanmbiguous_ term using dummy callbacks which fail if a + * choice from the user is needed to disambiguate the term + * @raise Ambiguous_term for ambiguous term *) + val disambiguate_string: + dbd:HMysql.dbd -> + ?context:Cic.context -> + ?metasenv:Cic.metasenv -> + ?initial_ugraph:CicUniv.universe_graph -> + ?aliases:DisambiguateTypes.environment ->(* previous interpretation status*) + string -> + ((DisambiguateTypes.domain_item * DisambiguateTypes.codomain_item) list * + Cic.metasenv * (* new metasenv *) + Cic.term * + CicUniv.universe_graph) list (* disambiguated term *) +end += +struct + exception Ambiguous_term of string Lazy.t + exception Exit + module Callbacks = + struct + let non p x = not (p x) + let interactive_user_uri_choice ~selection_mode ?ok + ?(enable_button_for_non_vars = true) ~title ~msg ~id uris = + List.filter (non UriManager.uri_is_var) uris + let interactive_interpretation_choice interp = raise Exit + let input_or_locate_uri ~(title:string) ?id = raise Exit + end + module Disambiguator = Disambiguate.Make (Callbacks) + let disambiguate_string ~dbd ?(context = []) ?(metasenv = []) ?initial_ugraph + ?(aliases = DisambiguateTypes.Environment.empty) term + = + let ast = + CicNotationParser.parse_level2_ast (Ulexing.from_utf8_string term) + in + try + fst (Disambiguator.disambiguate_term ~dbd ~context ~metasenv ast + ?initial_ugraph ~aliases ~universe:None) + with Exit -> raise (Ambiguous_term (lazy term)) +end + +let configuration_file = ref "../../../matita/matita.conf.xml";; + +let core_notation_script = "../../../matita/core_notation.moo";; + +let get_from_user ~(dbd:HMysql.dbd) = + 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 (Trivial_disambiguate.disambiguate_string dbd term_string) 0 + in + term, metasenv, ugraph +;; + +let full = ref false;; + +let retrieve_only = ref false;; + +let demod_equalities = ref false;; + +let main () = + let module S = Saturation in + let set_ratio v = S.weight_age_ratio := v; S.weight_age_counter := v + and set_sel v = S.symbols_ratio := v; S.symbols_counter := v; + and set_conf f = configuration_file := f + and set_ordering o = + match o with + | "lpo" -> Utils.compare_terms := Utils.lpo + | "kbo" -> Utils.compare_terms := Utils.kbo + | "nr-kbo" -> Utils.compare_terms := Utils.nonrec_kbo + | "ao" -> Utils.compare_terms := Utils.ao + | o -> raise (Arg.Bad ("Unknown term ordering: " ^ o)) + and set_fullred b = S.use_fullred := b + and set_time_limit v = S.time_limit := float_of_int v + and set_width w = S.maxwidth := w + and set_depth d = S.maxdepth := d + and set_full () = full := true + and set_retrieve () = retrieve_only := true + and set_demod_equalities () = demod_equalities := true + in + Arg.parse [ + "-full", Arg.Unit set_full, "Enable full mode"; + "-f", Arg.Bool set_fullred, + "Enable/disable full-reduction strategy (default: enabled)"; + + "-r", Arg.Int set_ratio, "Weight-Age equality selection ratio (default: 4)"; + + "-s", Arg.Int set_sel, + "symbols-based selection ratio (relative to the weight ratio, default: 0)"; + + "-c", Arg.String set_conf, "Configuration file (for the db connection)"; + + "-o", Arg.String set_ordering, + "Term ordering. Possible values are:\n" ^ + "\tkbo: Knuth-Bendix ordering\n" ^ + "\tnr-kbo: Non-recursive variant of kbo (default)\n" ^ + "\tlpo: Lexicographic path ordering"; + + "-l", Arg.Int set_time_limit, "Time limit in seconds (default: no limit)"; + + "-w", Arg.Int set_width, + Printf.sprintf "Maximal width (default: %d)" !Saturation.maxwidth; + + "-d", Arg.Int set_depth, + Printf.sprintf "Maximal depth (default: %d)" !Saturation.maxdepth; + + "-retrieve", Arg.Unit set_retrieve, "retrieve only"; + "-demod-equalities", Arg.Unit set_demod_equalities, "demod equalities"; + ] (fun a -> ()) "Usage:"; + Helm_registry.load_from !configuration_file; + ignore (CicNotation2.load_notation [] core_notation_script); + ignore (CicNotation2.load_notation [] "../../../matita/library/legacy/coq.ma"); + let dbd = HMysql.quick_connect + ~host:(Helm_registry.get "db.host") + ~user:(Helm_registry.get "db.user") + ~database:(Helm_registry.get "db.database") + () + in + let term, metasenv, ugraph = get_from_user ~dbd in + if !retrieve_only then + Saturation.retrieve_and_print dbd term metasenv ugraph + else if !demod_equalities then + Saturation.main_demod_equalities dbd term metasenv ugraph + else + Saturation.main dbd !full term metasenv ugraph +;; + +let _ = + (*try*) + main () + (*with exn -> prerr_endline (Printexc.to_string exn)*) + diff --git a/helm/ocaml/tactics/paramodulation/saturation.ml b/helm/ocaml/tactics/paramodulation/saturation.ml new file mode 100644 index 000000000..d73428c8a --- /dev/null +++ b/helm/ocaml/tactics/paramodulation/saturation.ml @@ -0,0 +1,2386 @@ +(* Copyright (C) 2005, HELM Team. + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://cs.unibo.it/helm/. + *) + +(* $Id$ *) + +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.;; +let forward_simpl_new_time = ref 0.;; +let backward_simpl_time = ref 0.;; +let passive_maintainance_time = ref 0.;; + +(* limited-resource-strategy related globals *) +let processed_clauses = ref 0;; (* number of equalities selected so far... *) +let time_limit = ref 0.;; (* in seconds, settable by the user... *) +let start_time = ref 0.;; (* time at which the execution started *) +let elapsed_time = ref 0.;; +(* let maximal_weight = ref None;; *) +let maximal_retained_equality = ref None;; + +(* equality-selection related globals *) +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 *) 3;; +let symbols_counter = ref 0;; + +(* non-recursive Knuth-Bendix term ordering by default *) +Utils.compare_terms := Utils.rpo;; +(* Utils.compare_terms := Utils.nonrec_kbo;; *) +(* Utils.compare_terms := Utils.ao;; *) + +(* statistics... *) +let derived_clauses = ref 0;; +let kept_clauses = ref 0;; + +(* index of the greatest Cic.Meta created - TODO: find a better way! *) +let maxmeta = ref 0;; + +(* varbiables controlling the search-space *) +let maxdepth = ref 3;; +let maxwidth = ref 3;; + + +type result = + | ParamodulationFailure + | ParamodulationSuccess of Inference.proof option * environment +;; + +type goal = proof * Cic.metasenv * Cic.term;; + +type theorem = Cic.term * Cic.term * Cic.metasenv;; + + +let symbols_of_equality ((_, _, (_, left, right, _), _, _) as equality) = + let m1 = symbols_of_term left in + let m = + TermMap.fold + (fun k v res -> + try + let c = TermMap.find k res in + TermMap.add k (c+v) res + with Not_found -> + TermMap.add k v res) + (symbols_of_term right) m1 + in + m +;; + + +module OrderedEquality = struct + type t = Inference.equality + + let compare eq1 eq2 = + match meta_convertibility_eq eq1 eq2 with + | true -> 0 + | false -> + let w1, _, (ty, left, right, _), _, a = eq1 + and w2, _, (ty', left', right', _), _, a' = eq2 in + match Pervasives.compare w1 w2 with + | 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 + ) + | res -> res +end + +module EqualitySet = Set.Make(OrderedEquality);; + + +(** + selects one equality from passive. The selection strategy is a combination + of weight, age and goal-similarity +*) +let select env goals passive (active, _) = + processed_clauses := !processed_clauses + 1; + let goal = + match (List.rev goals) with (_, goal::_)::_ -> goal | _ -> assert false + in + let (neg_list, neg_set), (pos_list, pos_set), passive_table = passive in + let remove eq l = + List.filter (fun e -> e <> eq) l + in + if !weight_age_ratio > 0 then + weight_age_counter := !weight_age_counter - 1; + match !weight_age_counter with + | 0 -> ( + weight_age_counter := !weight_age_ratio; + match neg_list, pos_list with + | hd::tl, pos -> + (* Negatives aren't indexed, no need to remove them... *) + (Negative, hd), + ((tl, EqualitySet.remove hd neg_set), (pos, pos_set), passive_table) + | [], (hd:EqualitySet.elt)::tl -> + let passive_table = + Indexing.remove_index passive_table hd + in + (Positive, hd), + (([], neg_set), (tl, EqualitySet.remove hd pos_set), passive_table) + | _, _ -> assert false + ) + | _ when (!symbols_counter > 0) && (EqualitySet.is_empty neg_set) -> ( + symbols_counter := !symbols_counter - 1; + let cardinality map = + TermMap.fold (fun k v res -> res + v) map 0 + in + let symbols = + let _, _, term = goal in + symbols_of_term term + in + let card = cardinality symbols in + 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 f equality (i, e) = + let common, others = + TermMap.fold foldfun (symbols_of_equality equality) (0, 0) + in + let c = others + (abs (common - card)) in + if c < i then (c, equality) + else (i, e) + in + let e1 = EqualitySet.min_elt pos_set in + let initial = + let common, others = + TermMap.fold foldfun (symbols_of_equality e1) (0, 0) + in + (others + (abs (common - card))), e1 + in + let _, current = EqualitySet.fold f pos_set initial in + let passive_table = + Indexing.remove_index passive_table current + in + (Positive, current), + (([], neg_set), + (remove current pos_list, EqualitySet.remove current pos_set), + passive_table) + ) + | _ -> + symbols_counter := !symbols_ratio; + let set_selection set = EqualitySet.min_elt set in + if EqualitySet.is_empty neg_set then + let current = set_selection pos_set in + let passive = + (neg_list, neg_set), + (remove current pos_list, EqualitySet.remove current pos_set), + Indexing.remove_index passive_table current + in + (Positive, current), passive + else + let current = set_selection neg_set in + let passive = + (remove current neg_list, EqualitySet.remove current neg_set), + (pos_list, pos_set), + passive_table + in + (Negative, current), passive +;; + + +(* initializes the passive set of equalities *) +let make_passive neg pos = + let set_of equalities = + List.fold_left (fun s e -> EqualitySet.add e s) EqualitySet.empty equalities + in + let table = + List.fold_left (fun tbl e -> Indexing.index tbl e) Indexing.empty pos + in + (neg, set_of neg), + (pos, set_of pos), + table +;; + + +let make_active () = + [], Indexing.empty +;; + + +(* adds to passive a list of equalities: new_neg is a list of negative + equalities, new_pos a list of positive equalities *) +let add_to_passive passive (new_neg, new_pos) = + let (neg_list, neg_set), (pos_list, pos_set), table = passive in + let ok set equality = not (EqualitySet.mem equality set) in + let neg = List.filter (ok neg_set) new_neg + and pos = List.filter (ok pos_set) new_pos in + let table = + List.fold_left (fun tbl e -> Indexing.index tbl e) table pos + in + let add set equalities = + List.fold_left (fun s e -> EqualitySet.add e s) set equalities + in + (neg @ neg_list, add neg_set neg), + (pos_list @ pos, add pos_set pos), + table +;; + + +let passive_is_empty = function + | ([], _), ([], _), _ -> true + | _ -> false +;; + + +let size_of_passive ((_, ns), (_, ps), _) = + (EqualitySet.cardinal ns) + (EqualitySet.cardinal ps) +;; + + +let size_of_active (active_list, _) = + List.length active_list +;; + + +(* removes from passive equalities that are estimated impossible to activate + within the current time limit *) +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 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 + (lazy (Printf.sprintf "in_weight: %d, in_age: %d\n" in_weight in_age)); + let symbols, card = + match active 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 counter = ref !symbols_ratio in + let rec pickw w ns ps = + if w > 0 then + if not (EqualitySet.is_empty ns) then + let e = EqualitySet.min_elt ns in + let ns', ps = pickw (w-1) (EqualitySet.remove e ns) ps in + EqualitySet.add e ns', ps + else if !counter > 0 then + let _ = + counter := !counter - 1; + if !counter = 0 then counter := !symbols_ratio + in + match symbols with + | None -> + let e = EqualitySet.min_elt ps in + let ns, ps' = pickw (w-1) ns (EqualitySet.remove e ps) in + ns, EqualitySet.add e ps' + | Some symbols -> + 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 f equality (i, e) = + let common, others = + TermMap.fold foldfun (symbols_of_equality equality) (0, 0) + in + let c = others + (abs (common - card)) in + if c < i then (c, equality) + else (i, e) + in + let e1 = EqualitySet.min_elt ps in + let initial = + let common, others = + TermMap.fold foldfun (symbols_of_equality e1) (0, 0) + in + (others + (abs (common - card))), e1 + in + let _, e = EqualitySet.fold f ps initial in + let ns, ps' = pickw (w-1) ns (EqualitySet.remove e ps) in + ns, EqualitySet.add e ps' + else + let e = EqualitySet.min_elt ps in + let ns, ps' = pickw (w-1) ns (EqualitySet.remove e ps) in + ns, EqualitySet.add e ps' + else + EqualitySet.empty, EqualitySet.empty + in + let ns, ps = pickw in_weight ns ps in + let rec picka w s l = + if w > 0 then + match l with + | [] -> w, s, [] + | hd::tl when not (EqualitySet.mem hd s) -> + let w, s, l = picka (w-1) s tl in + w, EqualitySet.add hd s, hd::l + | hd::tl -> + let w, s, l = picka w s tl in + w, s, hd::l + else + 0, s, l + in + let in_age, ns, nl = picka in_age ns nl in + let _, ps, pl = picka in_age ps pl in + if not (EqualitySet.is_empty ps) then + maximal_retained_equality := Some (EqualitySet.max_elt ps); + let tbl = + EqualitySet.fold + (fun e tbl -> Indexing.index tbl e) ps Indexing.empty + in + (nl, ns), (pl, ps), tbl +;; + + +(** inference of new equalities between current and some in active *) +let infer env sign current (active_list, active_table) = + let new_neg, new_pos = + match sign with + | Negative -> + 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 + maxmeta := maxm; + let rec infer_positive table = function + | [] -> [], [] + | (Negative, equality)::tl -> + 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 -> + let maxm, res = + Indexing.superposition_right !maxmeta env table equality in + maxmeta := maxm; + let neg, pos = infer_positive table tl in + neg, res @ pos + in + let curr_table = Indexing.index Indexing.empty current in + let neg, pos = infer_positive curr_table active_list in + neg, res @ pos + in + derived_clauses := !derived_clauses + (List.length new_neg) + + (List.length new_pos); + match !maximal_retained_equality with + | None -> new_neg, new_pos + | 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 +;; + + +let contains_empty env (negative, positive) = + let metasenv, context, ugraph = env in + try + let found = + List.find + (fun (w, proof, (ty, left, right, ordering), m, a) -> + fst (CicReduction.are_convertible context left right ugraph)) + negative + in + true, Some found + with Not_found -> + false, None +;; + + +(** simplifies current using active and passive *) +let forward_simplify env (sign, current) ?passive (active_list, active_table) = + let pl, passive_table = + match passive with + | None -> [], None + | Some ((pn, _), (pp, _), pt) -> + let pn = List.map (fun e -> (Negative, e)) pn + and pp = List.map (fun e -> (Positive, e)) pp in + pn @ pp, Some pt + in + let all = if pl = [] then active_list else active_list @ pl in + + let demodulate table current = + let newmeta, newcurrent = + Indexing.demodulation_equality !maxmeta env table sign current in + maxmeta := newmeta; + if is_identity env newcurrent then + if sign = Negative then Some (sign, newcurrent) + else ( +(* debug_print *) +(* (lazy *) +(* (Printf.sprintf "\ncurrent was: %s\nnewcurrent is: %s\n" *) +(* (string_of_equality current) *) +(* (string_of_equality newcurrent))); *) +(* debug_print *) +(* (lazy *) +(* (Printf.sprintf "active is: %s" *) +(* (String.concat "\n" *) +(* (List.map (fun (_, e) -> (string_of_equality e)) active_list)))); *) + None + ) + else + Some (sign, newcurrent) + in + let res = + let res = demodulate active_table current in + match res with + | None -> None + | Some (sign, newcurrent) -> + match passive_table with + | None -> res + | Some passive_table -> demodulate passive_table newcurrent + in + match res with + | None -> None + | Some (Negative, c) -> + let ok = not ( + List.exists + (fun (s, eq) -> s = Negative && meta_convertibility_eq eq c) + all) + in + if ok then res else None + | Some (Positive, c) -> + if Indexing.in_index active_table c then + None + else + match passive_table with + | None -> + if fst (Indexing.subsumption env active_table c) then + None + else + res + | Some passive_table -> + if Indexing.in_index passive_table c then None + else + let r1, _ = Indexing.subsumption env active_table c in + if r1 then None else + let r2, _ = Indexing.subsumption env passive_table c in + if r2 then None else res +;; + +type fs_time_info_t = { + mutable build_all: float; + mutable demodulate: float; + mutable subsumption: float; +};; + +let fs_time_info = { build_all = 0.; demodulate = 0.; subsumption = 0. };; + + +(** simplifies new using active and passive *) +let forward_simplify_new env (new_neg, new_pos) ?passive active = + let t1 = Unix.gettimeofday () in + + let active_list, active_table = active in + let pl, passive_table = + match passive with + | None -> [], None + | Some ((pn, _), (pp, _), pt) -> + let pn = List.map (fun e -> (Negative, e)) pn + and pp = List.map (fun e -> (Positive, e)) pp in + pn @ pp, Some pt + in + let all = active_list @ pl in + + let t2 = Unix.gettimeofday () in + fs_time_info.build_all <- fs_time_info.build_all +. (t2 -. t1); + + let demodulate sign table target = + let newmeta, newtarget = + Indexing.demodulation_equality !maxmeta env table sign target in + maxmeta := newmeta; + newtarget + in + let t1 = Unix.gettimeofday () in + + let new_neg, new_pos = + 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 Negative passive_table) new_neg, + List.map (demodulate Positive passive_table) new_pos + in + + let t2 = Unix.gettimeofday () in + fs_time_info.demodulate <- fs_time_info.demodulate +. (t2 -. t1); + + let new_pos_set = + List.fold_left + (fun s e -> + if not (Inference.is_identity env e) then + 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 + + let subs = + match passive_table with + | None -> + (fun e -> not (fst (Indexing.subsumption env active_table e))) + | Some passive_table -> + (fun e -> not ((fst (Indexing.subsumption env active_table e)) || + (fst (Indexing.subsumption env passive_table e)))) + in +(* let t1 = Unix.gettimeofday () in *) +(* let t2 = Unix.gettimeofday () in *) +(* fs_time_info.subsumption <- fs_time_info.subsumption +. (t2 -. t1); *) + let is_duplicate = + match passive_table with + | None -> + (fun e -> not (Indexing.in_index active_table e)) + | Some passive_table -> + (fun e -> + not ((Indexing.in_index active_table e) || + (Indexing.in_index passive_table e))) + in + new_neg, List.filter subs (List.filter is_duplicate new_pos) +;; + + +(** simplifies active usign new *) +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) -> + 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 = + List.exists (fun (s, e) -> meta_convertibility_eq eq1 e) where + in + let active, newa = + List.fold_right + (fun (s, eq) (res, tbl) -> + if List.mem (s, eq) res then + res, tbl + else if (is_identity env eq) || (find eq res) then ( + res, tbl + ) + else + (s, eq)::res, if s = Negative then tbl else Indexing.index tbl eq) + active_list ([], Indexing.empty), + List.fold_right + (fun (s, eq) (n, p) -> + if (s <> Negative) && (is_identity env eq) then ( + (n, p) + ) else + if s = Negative then eq::n, p + else n, eq::p) + newa ([], []) + in + match newa with + | [], [] -> active, None + | _ -> active, Some newa +;; + + +(** simplifies passive using new *) +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) = + let ew, _, _, _, _ = equality in + if ew < min_weight then + 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 + let passive_table = + List.fold_left + (fun tbl e -> Indexing.index tbl e) Indexing.empty pl + in + match newn, newp with + | [], [] -> ((nl, ns), (pl, ps), passive_table), None + | _, _ -> ((nl, ns), (pl, ps), passive_table), Some (newn, newp) +;; + + +let backward_simplify env new' ?passive active = + let new_pos, new_table, min_weight = + List.fold_left + (fun (l, t, w) e -> + let ew, _, _, _, _ = e in + (Positive, e)::l, Indexing.index t e, min ew w) + ([], Indexing.empty, 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 min_weight passive in + active, passive, newa, newp +;; + + +(* returns an estimation of how many equalities in passive can be activated + within the current time limit *) +let get_selection_estimate () = + elapsed_time := (Unix.gettimeofday ()) -. !start_time; + (* !processed_clauses * (int_of_float (!time_limit /. !elapsed_time)) *) + int_of_float ( + ceil ((float_of_int !processed_clauses) *. + ((!time_limit (* *. 2. *)) /. !elapsed_time -. 1.))) +;; + + +(** initializes the set of goals *) +let make_goals goal = + let active = [] + and passive = [0, [goal]] in + active, passive +;; + + +(** initializes the set of theorems *) +let make_theorems theorems = + theorems, [] +;; + + +let activate_goal (active, passive) = + match passive with + | goal_conj::tl -> true, (goal_conj::active, tl) + | [] -> false, (active, passive) +;; + + +let activate_theorem (active, passive) = + match passive with + | theorem::tl -> true, (theorem::active, tl) + | [] -> false, (active, passive) +;; + + +(** simplifies a goal with equalities in active and passive *) +let simplify_goal env goal ?passive (active_list, active_table) = + let pl, passive_table = + match passive with + | None -> [], None + | Some ((pn, _), (pp, _), pt) -> + let pn = List.map (fun e -> (Negative, e)) pn + and pp = List.map (fun e -> (Positive, e)) pp in + pn @ pp, Some pt + in + let all = if pl = [] then active_list else active_list @ pl in + + let demodulate table goal = + let newmeta, newgoal = + Indexing.demodulation_goal !maxmeta env table goal in + maxmeta := newmeta; + goal != newgoal, newgoal + in + let changed, goal = + match passive_table with + | None -> demodulate active_table goal + | Some passive_table -> + let changed, goal = demodulate active_table goal in + let changed', goal = demodulate passive_table goal in + (changed || changed'), goal + in + changed, goal +;; + + +let simplify_goals env goals ?passive active = + let a_goals, p_goals = goals in + let p_goals = + List.map + (fun (d, gl) -> + let gl = + List.map (fun g -> snd (simplify_goal env g ?passive active)) gl in + d, gl) + p_goals + in + let goals = + List.fold_left + (fun (a, p) (d, gl) -> + let changed = ref false in + let gl = + List.map + (fun g -> + let c, g = simplify_goal env g ?passive active in + changed := !changed || c; g) gl in + if !changed then (a, (d, gl)::p) else ((d, gl)::a, p)) + ([], p_goals) a_goals + in + goals +;; + + +let simplify_theorems env theorems ?passive (active_list, active_table) = + let pl, passive_table = + match passive with + | None -> [], None + | Some ((pn, _), (pp, _), pt) -> + let pn = List.map (fun e -> (Negative, e)) pn + and pp = List.map (fun e -> (Positive, e)) pp in + pn @ pp, Some pt + in + let all = if pl = [] then active_list else active_list @ pl in + let a_theorems, p_theorems = theorems in + let demodulate table theorem = + let newmeta, newthm = + Indexing.demodulation_theorem !maxmeta env table theorem in + maxmeta := newmeta; + theorem != newthm, newthm + in + let foldfun table (a, p) theorem = + let changed, theorem = demodulate table theorem in + if changed then (a, theorem::p) else (theorem::a, p) + in + let mapfun table theorem = snd (demodulate table theorem) in + match passive_table with + | None -> + let p_theorems = List.map (mapfun active_table) p_theorems in + List.fold_left (foldfun active_table) ([], p_theorems) a_theorems + | Some passive_table -> + let p_theorems = List.map (mapfun active_table) p_theorems in + let p_theorems, a_theorems = + List.fold_left (foldfun active_table) ([], p_theorems) a_theorems in + let p_theorems = List.map (mapfun passive_table) p_theorems in + List.fold_left (foldfun passive_table) ([], p_theorems) a_theorems +;; + + +(* applies equality to goal to see if the goal can be closed *) +let apply_equality_to_goal env equality goal = + let module C = Cic in + let module HL = HelmLibraryObjects in + let module I = Inference in + let metasenv, context, ugraph = env in + let _, proof, (ty, left, right, _), metas, args = equality in + let eqterm = + C.Appl [C.MutInd (LibraryObjects.eq_URI (), 0, []); ty; left; right] in + let gproof, gmetas, gterm = goal in +(* debug_print *) +(* (lazy *) +(* (Printf.sprintf "APPLY EQUALITY TO GOAL: %s, %s" *) +(* (string_of_equality equality) (CicPp.ppterm gterm))); *) + try + let subst, metasenv', _ = + let menv = metasenv @ metas @ gmetas in + Inference.unification menv context eqterm gterm ugraph + in + let newproof = + match proof with + | I.BasicProof t -> I.BasicProof (CicMetaSubst.apply_subst subst t) + | I.ProofBlock (s, uri, nt, t, pe, p) -> + I.ProofBlock (subst @ s, uri, nt, t, pe, p) + | _ -> assert false + in + let newgproof = + let rec repl = function + | I.ProofGoalBlock (_, gp) -> I.ProofGoalBlock (newproof, gp) + | I.NoProof -> newproof + | I.BasicProof p -> newproof + | I.SubProof (t, i, p) -> I.SubProof (t, i, repl p) + | _ -> assert false + in + repl gproof + in + true, subst, newgproof + with CicUnification.UnificationFailure _ -> + false, [], I.NoProof +;; + + + +let new_meta metasenv = + let m = CicMkImplicit.new_meta metasenv [] in + incr maxmeta; + while !maxmeta <= m do incr maxmeta done; + !maxmeta +;; + + +(* applies a theorem or an equality to goal, returning a list of subgoals or + an indication of failure *) +let apply_to_goal env theorems ?passive active goal = + let metasenv, context, ugraph = env in + let proof, metas, term = goal in + (* debug_print *) + (* (lazy *) + (* (Printf.sprintf "apply_to_goal with goal: %s" *) + (* (\* (string_of_proof proof) *\)(CicPp.ppterm term))); *) + let status = + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable context in + let proof', newmeta = + let rec get_meta = function + | SubProof (t, i, p) -> + let t', i' = get_meta p in + if i' = -1 then t, i else t', i' + | ProofGoalBlock (_, p) -> get_meta p + | _ -> Cic.Implicit None, -1 + in + let p, m = get_meta proof in + if m = -1 then + let n = new_meta (metasenv @ metas) in + Cic.Meta (n, irl), n + else + p, m + in + let metasenv = (newmeta, context, term)::metasenv @ metas in + let bit = new_meta metasenv, context, term in + let metasenv' = bit::metasenv in + ((None, metasenv', Cic.Meta (newmeta, irl), term), newmeta) + in + let rec aux = function + | [] -> `No + | (theorem, thmty, _)::tl -> + try + let subst, (newproof, newgoals) = + PrimitiveTactics.apply_tac_verbose_with_subst ~term:theorem status + in + if newgoals = [] then + let _, _, p, _ = newproof in + let newp = + let rec repl = function + | Inference.ProofGoalBlock (_, gp) -> + Inference.ProofGoalBlock (Inference.BasicProof p, gp) + | Inference.NoProof -> Inference.BasicProof p + | Inference.BasicProof _ -> Inference.BasicProof p + | Inference.SubProof (t, i, p2) -> + Inference.SubProof (t, i, repl p2) + | _ -> assert false + in + repl proof + in + let _, m = status in + let subst = List.filter (fun (i, _) -> i = m) subst in + `Ok (subst, [newp, metas, term]) + else + let _, menv, p, _ = newproof in + let irl = + CicMkImplicit.identity_relocation_list_for_metavariable context + in + let goals = + List.map + (fun i -> + let _, _, ty = CicUtil.lookup_meta i menv in + let p' = + let rec gp = function + | SubProof (t, i, p) -> + SubProof (t, i, gp p) + | ProofGoalBlock (sp1, sp2) -> + ProofGoalBlock (sp1, gp sp2) + | BasicProof _ + | NoProof -> + SubProof (p, i, BasicProof (Cic.Meta (i, irl))) + | ProofSymBlock (s, sp) -> + ProofSymBlock (s, gp sp) + | ProofBlock (s, u, nt, t, pe, sp) -> + ProofBlock (s, u, nt, t, pe, gp sp) + in gp proof + in + (p', menv, ty)) + newgoals + in + let goals = + let weight t = + let w, m = weight_of_term t in + w + 2 * (List.length m) + in + List.sort + (fun (_, _, t1) (_, _, t2) -> + Pervasives.compare (weight t1) (weight t2)) + goals + in + let best = aux tl in + match best with + | `Ok (_, _) -> best + | `No -> `GoOn ([subst, goals]) + | `GoOn sl -> `GoOn ((subst, goals)::sl) + with ProofEngineTypes.Fail msg -> + aux tl + in + let r, s, l = + if Inference.term_is_equality term then + let rec appleq_a = function + | [] -> false, [], [] + | (Positive, equality)::tl -> + let ok, s, newproof = apply_equality_to_goal env equality goal in + if ok then true, s, [newproof, metas, term] else appleq_a tl + | _::tl -> appleq_a tl + in + let rec appleq_p = function + | [] -> false, [], [] + | equality::tl -> + let ok, s, newproof = apply_equality_to_goal env equality goal in + if ok then true, s, [newproof, metas, term] else appleq_p tl + in + let al, _ = active in + match passive with + | None -> appleq_a al + | Some (_, (pl, _), _) -> + let r, s, l = appleq_a al in if r then r, s, l else appleq_p pl + else + false, [], [] + in + if r = true then `Ok (s, l) else aux theorems +;; + + +(* sorts a conjunction of goals in order to detect earlier if it is + unsatisfiable. Non-predicate goals are placed at the end of the list *) +let sort_goal_conj (metasenv, context, ugraph) (depth, gl) = + let gl = + List.stable_sort + (fun (_, e1, g1) (_, e2, g2) -> + let ty1, _ = + CicTypeChecker.type_of_aux' (e1 @ metasenv) context g1 ugraph + and ty2, _ = + CicTypeChecker.type_of_aux' (e2 @ metasenv) context g2 ugraph + in + let prop1 = + let b, _ = + CicReduction.are_convertible context (Cic.Sort Cic.Prop) ty1 ugraph + in + if b then 0 else 1 + and prop2 = + let b, _ = + CicReduction.are_convertible context (Cic.Sort Cic.Prop) ty2 ugraph + in + if b then 0 else 1 + in + if prop1 = 0 && prop2 = 0 then + let e1 = if Inference.term_is_equality g1 then 0 else 1 + and e2 = if Inference.term_is_equality g2 then 0 else 1 in + e1 - e2 + else + prop1 - prop2) + gl + in + (depth, gl) +;; + + +let is_meta_closed goals = + List.for_all (fun (_, _, g) -> CicUtil.is_meta_closed g) goals +;; + + +(* applies a series of theorems/equalities to a conjunction of goals *) +let rec apply_to_goal_conj env theorems ?passive active (depth, goals) = + let aux (goal, r) tl = + let propagate_subst subst (proof, metas, term) = + let rec repl = function + | NoProof -> NoProof + | BasicProof t -> + BasicProof (CicMetaSubst.apply_subst subst t) + | ProofGoalBlock (p, pb) -> + let pb' = repl pb in + ProofGoalBlock (p, pb') + | SubProof (t, i, p) -> + let t' = CicMetaSubst.apply_subst subst t in + let p = repl p in + SubProof (t', i, p) + | ProofSymBlock (ens, p) -> ProofSymBlock (ens, repl p) + | ProofBlock (s, u, nty, t, pe, p) -> + ProofBlock (subst @ s, u, nty, t, pe, p) + in (repl proof, metas, term) + in + (* let r = apply_to_goal env theorems ?passive active goal in *) ( + match r with + | `No -> `No (depth, goals) + | `GoOn sl -> + let l = + List.map + (fun (s, gl) -> + let tl = List.map (propagate_subst s) tl in + sort_goal_conj env (depth+1, gl @ tl)) sl + in + `GoOn l + | `Ok (subst, gl) -> + if tl = [] then + `Ok (depth, gl) + else + let p, _, _ = List.hd gl in + let subproof = + let rec repl = function + | SubProof (_, _, p) -> repl p + | ProofGoalBlock (p1, p2) -> + ProofGoalBlock (repl p1, repl p2) + | p -> p + in + build_proof_term (repl p) + in + let i = + let rec get_meta = function + | SubProof (_, i, p) -> + let i' = get_meta p in + if i' = -1 then i else i' +(* max i (get_meta p) *) + | ProofGoalBlock (_, p) -> get_meta p + | _ -> -1 + in + get_meta p + in + let subst = + let _, (context, _, _) = List.hd subst in + [i, (context, subproof, Cic.Implicit None)] + in + let tl = List.map (propagate_subst subst) tl in + let conj = sort_goal_conj env (depth(* +1 *), tl) in + `GoOn ([conj]) + ) + in + if depth > !maxdepth || (List.length goals) > !maxwidth then + `No (depth, goals) + else + let rec search_best res = function + | [] -> res + | goal::tl -> + let r = apply_to_goal env theorems ?passive active goal in + match r with + | `Ok _ -> (goal, r) + | `No -> search_best res tl + | `GoOn l -> + let newres = + match res with + | _, `Ok _ -> assert false + | _, `No -> goal, r + | _, `GoOn l2 -> + if (List.length l) < (List.length l2) then goal, r else res + in + search_best newres tl + in + let hd = List.hd goals in + let res = hd, (apply_to_goal env theorems ?passive active hd) in + let best = + match res with + | _, `Ok _ -> res + | _, _ -> search_best res (List.tl goals) + in + let res = aux best (List.filter (fun g -> g != (fst best)) goals) in + match res with + | `GoOn ([conj]) when is_meta_closed (snd conj) && + (List.length (snd conj)) < (List.length goals)-> + apply_to_goal_conj env theorems ?passive active conj + | _ -> res +;; + + +(* +module OrderedGoals = struct + type t = int * (Inference.proof * Cic.metasenv * Cic.term) list + + let compare g1 g2 = + let d1, l1 = g1 + and d2, l2 = g2 in + let r = d2 - d1 in + if r <> 0 then r + else let r = (List.length l1) - (List.length l2) in + if r <> 0 then r + else + let res = ref 0 in + let _ = + List.exists2 + (fun (_, _, t1) (_, _, t2) -> + let r = Pervasives.compare t1 t2 in + if r <> 0 then ( + res := r; + true + ) else + false) l1 l2 + in !res +end + +module GoalsSet = Set.Make(OrderedGoals);; + + +exception SearchSpaceOver;; +*) + + +(* +let apply_to_goals env is_passive_empty theorems active goals = + debug_print (lazy "\n\n\tapply_to_goals\n\n"); + let add_to set goals = + List.fold_left (fun s g -> GoalsSet.add g s) set goals + in + let rec aux set = function + | [] -> + debug_print (lazy "HERE!!!"); + if is_passive_empty then raise SearchSpaceOver else false, set + | goals::tl -> + let res = apply_to_goal_conj env theorems active goals in + match res with + | `Ok newgoals -> + let _ = + let d, p, t = + match newgoals with + | (d, (p, _, t)::_) -> d, p, t + | _ -> assert false + in + debug_print + (lazy + (Printf.sprintf "\nOK!!!!\ndepth: %d\nProof: %s\ngoal: %s\n" + d (string_of_proof p) (CicPp.ppterm t))) + in + true, GoalsSet.singleton newgoals + | `GoOn newgoals -> + let set' = add_to set (goals::tl) in + let set' = add_to set' newgoals in + false, set' + | `No newgoals -> + aux set tl + in + let n = List.length goals in + let res, goals = aux (add_to GoalsSet.empty goals) goals in + let goals = GoalsSet.elements goals in + debug_print (lazy "\n\tapply_to_goals end\n"); + let m = List.length goals in + if m = n && is_passive_empty then + raise SearchSpaceOver + else + res, goals +;; +*) + + +(* sorts the list of passive goals to minimize the search for a proof (doesn't + work that well yet...) *) +let sort_passive_goals goals = + List.stable_sort + (fun (d1, l1) (d2, l2) -> + let r1 = d2 - d1 + and r2 = (List.length l1) - (List.length l2) in + let foldfun ht (_, _, t) = + let _ = List.map (fun i -> Hashtbl.replace ht i 1) (metas_of_term t) + in ht + in + let m1 = Hashtbl.length (List.fold_left foldfun (Hashtbl.create 3) l1) + and m2 = Hashtbl.length (List.fold_left foldfun (Hashtbl.create 3) l2) + in let r3 = m1 - m2 in + if r3 <> 0 then r3 + else if r2 <> 0 then r2 + else r1) + (* let _, _, g1 = List.hd l1 *) +(* and _, _, g2 = List.hd l2 in *) +(* let e1 = if Inference.term_is_equality g1 then 0 else 1 *) +(* and e2 = if Inference.term_is_equality g2 then 0 else 1 *) +(* in let r4 = e1 - e2 in *) +(* if r4 <> 0 then r3 else r1) *) + goals +;; + + +let print_goals goals = + (String.concat "\n" + (List.map + (fun (d, gl) -> + let gl' = + List.map + (fun (p, _, t) -> + (* (string_of_proof p) ^ ", " ^ *) (CicPp.ppterm t)) gl + in + Printf.sprintf "%d: %s" d (String.concat "; " gl')) goals)) +;; + + +(* tries to prove the first conjunction in goals with applications of + theorems/equalities, returning new sub-goals or an indication of success *) +let apply_goal_to_theorems dbd env theorems ?passive active goals = + let theorems, _ = theorems in + let a_goals, p_goals = goals in + let goal = List.hd a_goals in + let not_in_active gl = + not + (List.exists + (fun (_, gl') -> + if (List.length gl) = (List.length gl') then + List.for_all2 (fun (_, _, g1) (_, _, g2) -> g1 = g2) gl gl' + else + false) + a_goals) + in + let aux theorems = + let res = apply_to_goal_conj env theorems ?passive active goal in + match res with + | `Ok newgoals -> + true, ([newgoals], []) + | `No _ -> + false, (a_goals, p_goals) + | `GoOn newgoals -> + let newgoals = + List.filter + (fun (d, gl) -> + (d <= !maxdepth) && (List.length gl) <= !maxwidth && + not_in_active gl) + newgoals in + let p_goals = newgoals @ p_goals in + let p_goals = sort_passive_goals p_goals in + false, (a_goals, p_goals) + in + aux theorems +;; + + +let apply_theorem_to_goals env theorems active goals = + let a_goals, p_goals = goals in + let theorem = List.hd (fst theorems) in + let theorems = [theorem] in + let rec aux p = function + | [] -> false, ([], p) + | goal::tl -> + let res = apply_to_goal_conj env theorems active goal in + match res with + | `Ok newgoals -> true, ([newgoals], []) + | `No _ -> aux p tl + | `GoOn newgoals -> aux (newgoals @ p) tl + in + let ok, (a, p) = aux p_goals a_goals in + if ok then + ok, (a, p) + else + let p_goals = + List.stable_sort + (fun (d1, l1) (d2, l2) -> + let r = d2 - d1 in + if r <> 0 then r + else let r = (List.length l1) - (List.length l2) in + if r <> 0 then r + else + let res = ref 0 in + let _ = + List.exists2 + (fun (_, _, t1) (_, _, t2) -> + let r = Pervasives.compare t1 t2 in + if r <> 0 then (res := r; true) else false) l1 l2 + in !res) + p + in + ok, (a_goals, p_goals) +;; + + +(* given-clause algorithm with lazy reduction strategy *) +let rec given_clause dbd env goals theorems passive active = + let goals = simplify_goals env goals active in + let ok, goals = activate_goal goals in + (* let theorems = simplify_theorems env theorems active in *) + if ok then + let ok, goals = apply_goal_to_theorems dbd env theorems active goals in + if ok then + let proof = + match (fst goals) with + | (_, [proof, _, _])::_ -> Some proof + | _ -> assert false + in + ParamodulationSuccess (proof, env) + else + given_clause_aux dbd env goals theorems passive active + else +(* let ok', theorems = activate_theorem theorems in *) + let ok', theorems = false, theorems in + if ok' then + let ok, goals = apply_theorem_to_goals env theorems active goals in + if ok then + let proof = + match (fst goals) with + | (_, [proof, _, _])::_ -> Some proof + | _ -> assert false + in + ParamodulationSuccess (proof, env) + else + given_clause_aux dbd env goals theorems passive active + else + if (passive_is_empty passive) then ParamodulationFailure + else given_clause_aux dbd env goals theorems passive active + +and given_clause_aux dbd env goals theorems passive active = + let time1 = Unix.gettimeofday () in + + let selection_estimate = get_selection_estimate () in + let kept = size_of_passive passive in + let passive = + if !time_limit = 0. || !processed_clauses = 0 then + passive + else if !elapsed_time > !time_limit then ( + debug_print (lazy (Printf.sprintf "Time limit (%.2f) reached: %.2f\n" + !time_limit !elapsed_time)); + make_passive [] [] + ) else if kept > selection_estimate then ( + debug_print + (lazy (Printf.sprintf ("Too many passive equalities: pruning..." ^^ + "(kept: %d, selection_estimate: %d)\n") + kept selection_estimate)); + prune_passive selection_estimate active passive + ) else + passive + in + + let time2 = Unix.gettimeofday () in + passive_maintainance_time := !passive_maintainance_time +. (time2 -. time1); + + kept_clauses := (size_of_passive passive) + (size_of_active active); + match passive_is_empty passive with + | true -> (* ParamodulationFailure *) + given_clause dbd env goals theorems passive active + | false -> + let (sign, current), passive = select env (fst goals) passive active in + let time1 = Unix.gettimeofday () in + let res = forward_simplify env (sign, current) ~passive active in + let time2 = Unix.gettimeofday () in + forward_simpl_time := !forward_simpl_time +. (time2 -. time1); + match res with + | None -> + given_clause dbd env goals theorems passive active + | Some (sign, current) -> + if (sign = Negative) && (is_identity env current) then ( + debug_print + (lazy (Printf.sprintf "OK!!! %s %s" (string_of_sign sign) + (string_of_equality ~env current))); + let _, proof, _, _, _ = current in + ParamodulationSuccess (Some proof, env) + ) else ( + debug_print + (lazy "\n================================================"); + debug_print (lazy (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 + let t2 = Unix.gettimeofday () in + infer_time := !infer_time +. (t2 -. t1); + + let res, goal' = contains_empty env new' in + if res then + let proof = + match goal' with + | Some goal -> let _, proof, _, _, _ = goal in Some proof + | None -> None + in + ParamodulationSuccess (proof, env) + else + let t1 = Unix.gettimeofday () in + let new' = forward_simplify_new env new' active in + let t2 = Unix.gettimeofday () in + let _ = + forward_simpl_new_time := + !forward_simpl_new_time +. (t2 -. t1) + in + let active = + match sign with + | Negative -> active + | Positive -> + let t1 = Unix.gettimeofday () in + let active, _, newa, _ = + backward_simplify env ([], [current]) active + in + let t2 = Unix.gettimeofday () in + backward_simpl_time := + !backward_simpl_time +. (t2 -. t1); + match newa with + | None -> active + | Some (n, p) -> + let al, tbl = active in + let nn = List.map (fun e -> Negative, e) n in + let pp, tbl = + List.fold_right + (fun e (l, t) -> + (Positive, e)::l, + Indexing.index tbl e) + p ([], tbl) + in + nn @ al @ pp, tbl + in + match contains_empty env new' with + | false, _ -> + let active = + let al, tbl = active in + match sign with + | Negative -> (sign, current)::al, tbl + | Positive -> + al @ [(sign, current)], Indexing.index tbl current + in + let passive = add_to_passive passive new' in + let (_, ns), (_, ps), _ = passive in + given_clause dbd env goals theorems passive active + | true, goal -> + let proof = + match goal with + | Some goal -> + let _, proof, _, _, _ = goal in Some proof + | None -> None + in + ParamodulationSuccess (proof, env) + ) +;; + + +(** given-clause algorithm with full reduction strategy *) +let rec given_clause_fullred dbd env goals theorems passive active = + let goals = simplify_goals env goals ~passive active in + let ok, goals = activate_goal goals in +(* let theorems = simplify_theorems env theorems ~passive active in *) + if ok then +(* let _ = *) +(* debug_print *) +(* (lazy *) +(* (Printf.sprintf "\ngoals = \nactive\n%s\npassive\n%s\n" *) +(* (print_goals (fst goals)) (print_goals (snd goals)))); *) +(* let current = List.hd (fst goals) in *) +(* let p, _, t = List.hd (snd current) in *) +(* debug_print *) +(* (lazy *) +(* (Printf.sprintf "goal activated:\n%s\n%s\n" *) +(* (CicPp.ppterm t) (string_of_proof p))); *) +(* in *) + let ok, goals = + apply_goal_to_theorems dbd env theorems ~passive active goals + in + if ok then + let proof = + match (fst goals) with + | (_, [proof, _, _])::_ -> Some proof + | _ -> assert false + in + ParamodulationSuccess (proof, env) + else + given_clause_fullred_aux dbd env goals theorems passive active + else +(* let ok', theorems = activate_theorem theorems in *) +(* if ok' then *) +(* let ok, goals = apply_theorem_to_goals env theorems active goals in *) +(* if ok then *) +(* let proof = *) +(* match (fst goals) with *) +(* | (_, [proof, _, _])::_ -> Some proof *) +(* | _ -> assert false *) +(* in *) +(* ParamodulationSuccess (proof, env) *) +(* else *) +(* given_clause_fullred_aux env goals theorems passive active *) +(* else *) + if (passive_is_empty passive) then ParamodulationFailure + else given_clause_fullred_aux dbd env goals theorems passive active + +and given_clause_fullred_aux dbd env goals theorems passive active = + let time1 = Unix.gettimeofday () in + + let selection_estimate = get_selection_estimate () in + let kept = size_of_passive passive in + let passive = + if !time_limit = 0. || !processed_clauses = 0 then + passive + else if !elapsed_time > !time_limit then ( + debug_print (lazy (Printf.sprintf "Time limit (%.2f) reached: %.2f\n" + !time_limit !elapsed_time)); + make_passive [] [] + ) else if kept > selection_estimate then ( + debug_print + (lazy (Printf.sprintf ("Too many passive equalities: pruning..." ^^ + "(kept: %d, selection_estimate: %d)\n") + kept selection_estimate)); + prune_passive selection_estimate active passive + ) else + passive + in + + let time2 = Unix.gettimeofday () in + passive_maintainance_time := !passive_maintainance_time +. (time2 -. time1); + + kept_clauses := (size_of_passive passive) + (size_of_active active); + match passive_is_empty passive with + | true -> (* ParamodulationFailure *) + given_clause_fullred dbd env goals theorems passive active + | false -> + let (sign, current), passive = select env (fst goals) passive active in + let time1 = Unix.gettimeofday () in + let res = forward_simplify env (sign, current) ~passive active in + let time2 = Unix.gettimeofday () in + forward_simpl_time := !forward_simpl_time +. (time2 -. time1); + match res with + | None -> + given_clause_fullred dbd env goals theorems passive active + | Some (sign, current) -> + if (sign = Negative) && (is_identity env current) then ( + debug_print + (lazy (Printf.sprintf "OK!!! %s %s" (string_of_sign sign) + (string_of_equality ~env current))); + let _, proof, _, _, _ = current in + ParamodulationSuccess (Some proof, env) + ) else ( + debug_print + (lazy "\n================================================"); + debug_print (lazy (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 + let t2 = Unix.gettimeofday () in + infer_time := !infer_time +. (t2 -. t1); + + let active = + if is_identity env current then active + else + let al, tbl = active in + match sign with + | Negative -> (sign, current)::al, tbl + | Positive -> + al @ [(sign, current)], Indexing.index tbl current + in + let rec simplify new' active passive = + let t1 = Unix.gettimeofday () in + let new' = forward_simplify_new env new' ~passive active in + let t2 = Unix.gettimeofday () in + forward_simpl_new_time := + !forward_simpl_new_time +. (t2 -. t1); + let t1 = Unix.gettimeofday () in + let active, passive, newa, retained = + backward_simplify env new' ~passive active in + let t2 = Unix.gettimeofday () in + backward_simpl_time := !backward_simpl_time +. (t2 -. t1); + match newa, retained with + | None, None -> active, passive, new' + | Some (n, p), None + | None, Some (n, p) -> + let nn, np = new' in + simplify (nn @ n, np @ p) active passive + | Some (n, p), Some (rn, rp) -> + let nn, np = new' in + simplify (nn @ n @ rn, np @ p @ rp) active passive + in + let active, passive, new' = simplify new' active passive in + + let k = size_of_passive passive in + if k < (kept - 1) then + processed_clauses := !processed_clauses + (kept - 1 - k); + + let _ = + debug_print + (lazy + (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 + (lazy + (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 + given_clause_fullred dbd env goals theorems passive active + | true, goal -> + let proof = + match goal with + | Some goal -> let _, proof, _, _, _ = goal in Some proof + | None -> None + in + ParamodulationSuccess (proof, env) + ) +;; + + +let rec saturate_equations env goal accept_fun passive active = + elapsed_time := Unix.gettimeofday () -. !start_time; + if !elapsed_time > !time_limit then + (active, passive) + else + let (sign, current), passive = select env [1, [goal]] passive active in + let res = forward_simplify env (sign, current) ~passive active in + match res with + | None -> + saturate_equations env goal accept_fun passive active + | Some (sign, current) -> + assert (sign = Positive); + debug_print + (lazy "\n================================================"); + debug_print (lazy (Printf.sprintf "selected: %s %s" + (string_of_sign sign) + (string_of_equality ~env current))); + let new' = infer env sign current active in + let active = + if is_identity env current then active + else + let al, tbl = active in + al @ [(sign, current)], Indexing.index tbl current + in + let rec simplify new' active passive = + let new' = forward_simplify_new env new' ~passive active in + let active, passive, newa, retained = + backward_simplify env new' ~passive active in + match newa, retained with + | None, None -> active, passive, new' + | Some (n, p), None + | None, Some (n, p) -> + let nn, np = new' in + simplify (nn @ n, np @ p) active passive + | Some (n, p), Some (rn, rp) -> + let nn, np = new' in + simplify (nn @ n @ rn, np @ p @ rp) active passive + in + let active, passive, new' = simplify new' active passive in + let _ = + debug_print + (lazy + (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 + (lazy + (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 + let new' = match new' with _, pos -> [], List.filter accept_fun pos in + let passive = add_to_passive passive new' in + saturate_equations env goal accept_fun passive active +;; + + + + +let main dbd full term metasenv ugraph = + let module C = Cic in + let module T = CicTypeChecker in + let module PET = ProofEngineTypes in + let module PP = CicPp in + let proof = None, (1, [], term)::metasenv, C.Meta (1, []), term 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 eq_indexes, equalities, maxm = find_equalities context proof in + let lib_eq_uris, library_equalities, maxm = + find_library_equalities dbd context (proof, goal') (maxm+2) + in + let library_equalities = List.map snd library_equalities 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 + debug_print + (lazy + (Printf.sprintf "\n\nTIPO DEL GOAL: %s\n\n" (CicPp.ppterm ty))); + Cic.Meta (maxm+1, irl), + (maxm+1, context, ty)::metasenv, + ty + in + let env = (metasenv, context, ugraph) in + let t1 = Unix.gettimeofday () in + let theorems = + if full then + let theorems = find_library_theorems dbd env (proof, goal') lib_eq_uris in + let context_hyp = find_context_hypotheses env eq_indexes in + context_hyp @ theorems, [] + else + let refl_equal = + let us = UriManager.string_of_uri (LibraryObjects.eq_URI ()) in + UriManager.uri_of_string (us ^ "#xpointer(1/1/1)") + in + let t = CicUtil.term_of_uri refl_equal in + let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in + [(t, ty, [])], [] + in + let t2 = Unix.gettimeofday () in + debug_print + (lazy + (Printf.sprintf "Time to retrieve theorems: %.9f\n" (t2 -. t1))); + let _ = + debug_print + (lazy + (Printf.sprintf + "Theorems:\n-------------------------------------\n%s\n" + (String.concat "\n" + (List.map + (fun (t, ty, _) -> + Printf.sprintf + "Term: %s, type: %s" (CicPp.ppterm t) (CicPp.ppterm ty)) + (fst theorems))))) + in + (*try*) + let goal = Inference.BasicProof new_meta_goal, [], goal in + let equalities = + let equalities = equalities @ library_equalities in + debug_print + (lazy + (Printf.sprintf "equalities:\n%s\n" + (String.concat "\n" + (List.map string_of_equality equalities)))); + debug_print (lazy "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 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 + (lazy + (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 [] equalities in + Printf.printf "\ncurrent goal: %s\n" + (let _, _, g = goal in CicPp.ppterm g); + 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)); +(* (equalities @ library_equalities))); *) + print_endline "--------------------------------------------------"; + let start = Unix.gettimeofday () in + print_endline "GO!"; + start_time := Unix.gettimeofday (); + let res = + let goals = make_goals goal in + (if !use_fullred then given_clause_fullred else given_clause) + dbd env goals theorems passive active + in + let finish = Unix.gettimeofday () in + let _ = + match res with + | ParamodulationFailure -> + Printf.printf "NO proof found! :-(\n\n" + | ParamodulationSuccess (Some proof, env) -> + let proof = Inference.build_proof_term proof 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); + 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 + 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 default_depth = !maxdepth +and default_width = !maxwidth;; + +let reset_refs () = + maxmeta := 0; + symbols_counter := 0; + weight_age_counter := !weight_age_ratio; + processed_clauses := 0; + start_time := 0.; + elapsed_time := 0.; + maximal_retained_equality := None; + infer_time := 0.; + forward_simpl_time := 0.; + forward_simpl_new_time := 0.; + backward_simpl_time := 0.; + passive_maintainance_time := 0.; + derived_clauses := 0; + kept_clauses := 0; +;; + +let saturate + dbd ?(full=false) ?(depth=default_depth) ?(width=default_width) status = + let module C = Cic in + reset_refs (); + Indexing.init_index (); + maxdepth := depth; + maxwidth := width; + let proof, goal = status in + let goal' = goal in + let uri, metasenv, meta_proof, term_to_prove = proof in + let _, context, goal = CicUtil.lookup_meta goal' metasenv in + let eq_indexes, 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 + (lazy (Printf.sprintf "\n\nTIPO DEL GOAL: %s\n" (CicPp.ppterm ty))); + Cic.Meta (maxm+1, irl), + (maxm+1, context, ty)::metasenv, + ty + in + let ugraph = CicUniv.empty_ugraph in + let env = (metasenv, context, ugraph) in + let goal = Inference.BasicProof new_meta_goal, [], goal in + let res, time = + let t1 = Unix.gettimeofday () in + let lib_eq_uris, library_equalities, maxm = + find_library_equalities dbd context (proof, goal') (maxm+2) + in + let library_equalities = List.map snd library_equalities in + let t2 = Unix.gettimeofday () in + maxmeta := maxm+2; + let equalities = + let equalities = equalities @ library_equalities in + debug_print + (lazy + (Printf.sprintf "equalities:\n%s\n" + (String.concat "\n" + (List.map string_of_equality equalities)))); + debug_print (lazy "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 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 + (lazy + (Printf.sprintf "equalities AFTER:\n%s\n" + (String.concat "\n" + (List.map string_of_equality res)))); + res + in + debug_print + (lazy + (Printf.sprintf "Time to retrieve equalities: %.9f\n" (t2 -. t1))); + let t1 = Unix.gettimeofday () in + let theorems = + if full then + let thms = find_library_theorems dbd env (proof, goal') lib_eq_uris in + let context_hyp = find_context_hypotheses env eq_indexes in + context_hyp @ thms, [] + else + let refl_equal = + let us = UriManager.string_of_uri (LibraryObjects.eq_URI ()) in + UriManager.uri_of_string (us ^ "#xpointer(1/1/1)") + in + let t = CicUtil.term_of_uri refl_equal in + let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in + [(t, ty, [])], [] + in + let t2 = Unix.gettimeofday () in + let _ = + debug_print + (lazy + (Printf.sprintf + "Theorems:\n-------------------------------------\n%s\n" + (String.concat "\n" + (List.map + (fun (t, ty, _) -> + Printf.sprintf + "Term: %s, type: %s" + (CicPp.ppterm t) (CicPp.ppterm ty)) + (fst theorems))))); + debug_print + (lazy + (Printf.sprintf "Time to retrieve theorems: %.9f\n" (t2 -. t1))); + in + let active = make_active () in + let passive = make_passive [] equalities in + let start = Unix.gettimeofday () in + let res = + let goals = make_goals goal in + given_clause_fullred dbd env goals theorems passive active + in + let finish = Unix.gettimeofday () in + (res, finish -. start) + in + match res with + | ParamodulationSuccess (Some proof, env) -> + debug_print (lazy "OK, found a proof!"); + let proof = Inference.build_proof_term proof in + let names = names_of_context context in + let newmetasenv = + let i1 = + match new_meta_goal with + | C.Meta (i, _) -> i | _ -> 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 (lazy (CicPp.pp proof [](* names *))); + debug_print + (lazy + (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 + (lazy + (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 (lazy "THE PROOF DOESN'T TYPECHECK!!!"); + debug_print (lazy (CicPp.pp proof names)); + raise (ProofEngineTypes.Fail + (lazy "Found a proof, but it doesn't typecheck")) + in + debug_print (lazy (Printf.sprintf "\nTIME NEEDED: %.9f" time)); + newstatus + | _ -> + raise (ProofEngineTypes.Fail (lazy "NO proof found")) +;; + +(* dummy function called within matita to trigger linkage *) +let init () = ();; + + +(* UGLY SIDE EFFECT... +if connect_to_auto then ( + AutoTactic.paramodulation_tactic := saturate; + AutoTactic.term_is_equality := Inference.term_is_equality; +);; +*) + +let retrieve_and_print 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 proof = None, (1, [], term)::metasenv, C.Meta (1, []), term 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 uri, metasenv, meta_proof, term_to_prove = proof in + let _, context, goal = CicUtil.lookup_meta goal' metasenv in + let eq_indexes, 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 + (lazy (Printf.sprintf "\n\nTIPO DEL GOAL: %s\n" (CicPp.ppterm ty))); + Cic.Meta (maxm+1, irl), + (maxm+1, context, ty)::metasenv, + ty + in + let ugraph = CicUniv.empty_ugraph in + let env = (metasenv, context, ugraph) in + let goal = Inference.BasicProof new_meta_goal, [], goal in + let t1 = Unix.gettimeofday () in + let lib_eq_uris, library_equalities, maxm = + find_library_equalities dbd context (proof, goal') (maxm+2) + in + let t2 = Unix.gettimeofday () in + maxmeta := maxm+2; + let equalities = + let equalities = (* equalities @ *) library_equalities in + debug_print + (lazy + (Printf.sprintf "\n\nequalities:\n%s\n" + (String.concat "\n" + (List.map + (fun (u, e) -> +(* Printf.sprintf "%s: %s" *) + (UriManager.string_of_uri u) +(* (string_of_equality e) *) + ) + equalities)))); + debug_print (lazy "SIMPLYFYING EQUALITIES..."); + let rec simpl e others others_simpl = + let (u, e) = e in + let active = List.map (fun (u, e) -> (Positive, e)) + (others @ others_simpl) in + let tbl = + List.fold_left + (fun t (_, e) -> Indexing.index t e) + Indexing.empty active + in + let res = forward_simplify env (Positive, e) (active, tbl) in + match others with + | hd::tl -> ( + match res with + | None -> simpl hd tl others_simpl + | Some e -> simpl hd tl ((u, (snd e))::others_simpl) + ) + | [] -> ( + match res with + | None -> others_simpl + | Some e -> (u, (snd e))::others_simpl + ) + in + match equalities with + | [] -> [] + | hd::tl -> + let others = tl in (* List.map (fun e -> (Positive, e)) tl in *) + let res = + List.rev (simpl (*(Positive,*) hd others []) + in + debug_print + (lazy + (Printf.sprintf "\nequalities AFTER:\n%s\n" + (String.concat "\n" + (List.map + (fun (u, e) -> + Printf.sprintf "%s: %s" + (UriManager.string_of_uri u) + (string_of_equality e) + ) + res)))); + res + in + debug_print + (lazy + (Printf.sprintf "Time to retrieve equalities: %.9f\n" (t2 -. t1))) +;; + + +let main_demod_equalities 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 proof = None, (1, [], term)::metasenv, C.Meta (1, []), term 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 eq_indexes, equalities, maxm = find_equalities context proof in + let lib_eq_uris, library_equalities, maxm = + find_library_equalities dbd context (proof, goal') (maxm+2) + in + let library_equalities = List.map snd library_equalities 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 + debug_print + (lazy + (Printf.sprintf "\n\nTRYING TO INFER EQUALITIES MATCHING: %s\n\n" + (CicPp.ppterm ty))); + Cic.Meta (maxm+1, irl), + (maxm+1, context, ty)::metasenv, + ty + in + let env = (metasenv, context, ugraph) in + let t1 = Unix.gettimeofday () in + (*try*) + let goal = Inference.BasicProof new_meta_goal, [], goal in + let equalities = + let equalities = equalities @ library_equalities in + debug_print + (lazy + (Printf.sprintf "equalities:\n%s\n" + (String.concat "\n" + (List.map string_of_equality equalities)))); + debug_print (lazy "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 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 + (lazy + (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 [] equalities in + 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 (); + if !time_limit < 1. then time_limit := 60.; + let ra, rp = + saturate_equations env goal (fun e -> true) passive active + in + let finish = Unix.gettimeofday () in + + let initial = + List.fold_left (fun s e -> EqualitySet.add e s) + EqualitySet.empty equalities + in + let addfun s e = EqualitySet.add e s + (* + if not (EqualitySet.mem e initial) then EqualitySet.add e s else s + *) + in + + let passive = + match rp with + | (n, _), (p, _), _ -> + EqualitySet.elements (List.fold_left addfun EqualitySet.empty p) + in + let active = + let l = List.map snd (fst ra) in + EqualitySet.elements (List.fold_left addfun EqualitySet.empty l) + in + Printf.printf "\n\nRESULTS:\nActive:\n%s\n\nPassive:\n%s\n" + (String.concat "\n" (List.map (string_of_equality ~env) active)) + (* (String.concat "\n" + (List.map (fun e -> CicPp.ppterm (term_of_equality e)) active)) *) +(* (String.concat "\n" (List.map (string_of_equality ~env) passive)); *) + (String.concat "\n" + (List.map (fun e -> CicPp.ppterm (term_of_equality e)) passive)); + print_newline (); +(* + with e -> + debug_print (lazy ("EXCEPTION: " ^ (Printexc.to_string e))) +*) +;; diff --git a/helm/ocaml/tactics/paramodulation/saturation.mli b/helm/ocaml/tactics/paramodulation/saturation.mli new file mode 100644 index 000000000..259ab5e6c --- /dev/null +++ b/helm/ocaml/tactics/paramodulation/saturation.mli @@ -0,0 +1,49 @@ +(* Copyright (C) 2006, HELM Team. + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://helm.cs.unibo.it/ + *) + +(* $Id$ *) + +val saturate : + HMysql.dbd -> + ?full:bool -> + ?depth:int -> + ?width:int -> + ProofEngineTypes.proof * ProofEngineTypes.goal -> + (UriManager.uri option * Cic.conjecture list * Cic.term * Cic.term) * + 'a list + +val weight_age_ratio : int ref +val weight_age_counter: int ref +val symbols_ratio: int ref +val symbols_counter: int ref +val use_fullred: bool ref +val time_limit: float ref +val maxwidth: int ref +val maxdepth: int ref +val retrieve_and_print: HMysql.dbd -> Cic.term -> Cic.conjecture list -> 'a -> unit +val main_demod_equalities: HMysql.dbd -> + Cic.term -> Cic.conjecture list -> CicUniv.universe_graph -> unit +val main: HMysql.dbd -> + bool -> Cic.term -> Cic.conjecture list -> CicUniv.universe_graph -> unit diff --git a/helm/ocaml/tactics/paramodulation/test_indexing.ml b/helm/ocaml/tactics/paramodulation/test_indexing.ml new file mode 100644 index 000000000..ba6b2ebe0 --- /dev/null +++ b/helm/ocaml/tactics/paramodulation/test_indexing.ml @@ -0,0 +1,253 @@ +(* $Id$ *) + +open Path_indexing + +(* +let build_equality term = + let module C = Cic in + C.Implicit None, (C.Implicit None, term, C.Rel 1, Utils.Gt), [], [] +;; + + +(* + f = Rel 1 + g = Rel 2 + a = Rel 3 + b = Rel 4 + c = Rel 5 +*) +let path_indexing_test () = + let module C = Cic in + let terms = [ + C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Meta (1, [])]; C.Rel 5]; + C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Meta (1, [])]; + C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Rel 4]; C.Rel 5]; + C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 5]; C.Rel 4]; + C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (1, [])] + ] in + let path_strings = List.map (path_strings_of_term 0) terms in + let table = + List.fold_left index PSTrie.empty (List.map build_equality terms) in + let query = + C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Rel 5] in + let matches = retrieve_generalizations table query in + let unifications = retrieve_unifiables table query in + let eq1 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (1, [])]) + and eq2 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (2, [])]) in + let res1 = in_index table eq1 + and res2 = in_index table eq2 in + let print_results res = + String.concat "\n" + (PosEqSet.fold + (fun (p, e) l -> + let s = + "(" ^ (Utils.string_of_pos p) ^ ", " ^ + (Inference.string_of_equality e) ^ ")" + in + s::l) + res []) + in + Printf.printf "path_strings:\n%s\n\n" + (String.concat "\n" + (List.map + (fun l -> + "{" ^ (String.concat "; " (List.map string_of_path_string l)) ^ "}" + ) path_strings)); + Printf.printf "table:\n%s\n\n" (string_of_pstrie table); + Printf.printf "matches:\n%s\n\n" (print_results matches); + Printf.printf "unifications:\n%s\n\n" (print_results unifications); + Printf.printf "in_index %s: %s\n" + (Inference.string_of_equality eq1) (string_of_bool res1); + Printf.printf "in_index %s: %s\n" + (Inference.string_of_equality eq2) (string_of_bool res2); +;; + + +let differing () = + let module C = Cic in + let t1 = + C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Meta (1, [])]; C.Rel 5] + and t2 = + C.Appl [C.Rel 1; C.Appl [C.Rel 5; C.Rel 4; C.Meta (1, [])]; C.Rel 5] + in + let res = Inference.extract_differing_subterms t1 t2 in + match res with + | None -> print_endline "NO DIFFERING SUBTERMS???" + | Some (t1, t2) -> + Printf.printf "OK: %s, %s\n" (CicPp.ppterm t1) (CicPp.ppterm t2); +;; + + +let next_after () = + let module C = Cic in + let t = + C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Rel 4]; C.Rel 5] + in + let pos1 = Discrimination_tree.next_t [1] t in + let pos2 = Discrimination_tree.after_t [1] t in + Printf.printf "next_t 1: %s\nafter_t 1: %s\n" + (CicPp.ppterm (Discrimination_tree.subterm_at_pos pos1 t)) + (CicPp.ppterm (Discrimination_tree.subterm_at_pos pos2 t)); +;; + + +let discrimination_tree_test () = + let module C = Cic in + let terms = [ + C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Meta (1, [])]; C.Rel 5]; + C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Meta (1, [])]; + C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Rel 3; C.Rel 4]; C.Rel 5]; + C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 5]; C.Rel 4]; + C.Appl [C.Rel 10; C.Meta (5, []); C.Rel 11] + ] in + let path_strings = + List.map Discrimination_tree.path_string_of_term terms in + let table = + List.fold_left + Discrimination_tree.index + Discrimination_tree.DiscriminationTree.empty + (List.map build_equality terms) + in +(* let query = *) +(* C.Appl [C.Rel 1; C.Appl [C.Rel 2; C.Meta (1, []); C.Rel 4]; C.Rel 5] in *) + let query = C.Appl [C.Rel 10; C.Meta (14, []); C.Meta (13, [])] in + let matches = Discrimination_tree.retrieve_generalizations table query in + let unifications = Discrimination_tree.retrieve_unifiables table query in + let eq1 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (1, [])]) + and eq2 = build_equality (C.Appl [C.Rel 1; C.Meta (1, []); C.Meta (2, [])]) in + let res1 = Discrimination_tree.in_index table eq1 + and res2 = Discrimination_tree.in_index table eq2 in + let print_results res = + String.concat "\n" + (Discrimination_tree.PosEqSet.fold + (fun (p, e) l -> + let s = + "(" ^ (Utils.string_of_pos p) ^ ", " ^ + (Inference.string_of_equality e) ^ ")" + in + s::l) + res []) + in + Printf.printf "path_strings:\n%s\n\n" + (String.concat "\n" + (List.map Discrimination_tree.string_of_path_string path_strings)); + Printf.printf "table:\n%s\n\n" + (Discrimination_tree.string_of_discrimination_tree table); + Printf.printf "matches:\n%s\n\n" (print_results matches); + Printf.printf "unifications:\n%s\n\n" (print_results unifications); + Printf.printf "in_index %s: %s\n" + (Inference.string_of_equality eq1) (string_of_bool res1); + Printf.printf "in_index %s: %s\n" + (Inference.string_of_equality eq2) (string_of_bool res2); +;; + + +let test_subst () = + let module C = Cic in + let module M = CicMetaSubst in + let term = C.Appl [ + C.Rel 1; + C.Appl [C.Rel 11; + C.Meta (43, []); + C.Appl [C.Rel 15; C.Rel 12; C.Meta (41, [])]]; + C.Appl [C.Rel 11; + C.Appl [C.Rel 15; C.Meta (10, []); C.Meta (11, [])]; + C.Appl [C.Rel 15; C.Meta (10, []); C.Meta (12, [])]] + ] in + let subst1 = [ + (43, ([], C.Appl [C.Rel 15; C.Meta (10, []); C.Meta (11, [])], C.Rel 16)); + (10, ([], C.Rel 12, C.Rel 16)); + (12, ([], C.Meta (41, []), C.Rel 16)) + ] + and subst2 = [ + (43, ([], C.Appl [C.Rel 15; C.Rel 12; C.Meta (11, [])], C.Rel 16)); + (10, ([], C.Rel 12, C.Rel 16)); + (12, ([], C.Meta (41, []), C.Rel 16)) + ] in + let t1 = M.apply_subst subst1 term + and t2 = M.apply_subst subst2 term in + Printf.printf "t1 = %s\nt2 = %s\n" (CicPp.ppterm t1) (CicPp.ppterm t2); +;; +*) + + +let test_refl () = + let module C = Cic in + let context = [ + Some (C.Name "H", C.Decl ( + C.Prod (C.Name "z", C.Rel 3, + C.Appl [ + C.MutInd (HelmLibraryObjects.Logic.eq_URI, 0, []); + C.Rel 4; C.Rel 3; C.Rel 1]))); + Some (C.Name "x", C.Decl (C.Rel 2)); + Some (C.Name "y", C.Decl (C.Rel 1)); + Some (C.Name "A", C.Decl (C.Sort C.Set)) + ] + in + let term = C.Appl [ + C.Const (HelmLibraryObjects.Logic.eq_ind_URI, []); C.Rel 4; + C.Rel 2; + C.Lambda (C.Name "z", C.Rel 4, + C.Appl [ + C.MutInd (HelmLibraryObjects.Logic.eq_URI, 0, []); + C.Rel 5; C.Rel 1; C.Rel 3 + ]); + C.Appl [C.MutConstruct + (HelmLibraryObjects.Logic.eq_URI, 0, 1, []); (* reflexivity *) + C.Rel 4; C.Rel 2]; + C.Rel 3; +(* C.Appl [C.Const (HelmLibraryObjects.Logic.sym_eq_URI, []); (\* symmetry *\) *) +(* C.Rel 4; C.Appl [C.Rel 1; C.Rel 2]] *) + C.Appl [ + C.Const (HelmLibraryObjects.Logic.eq_ind_URI, []); + C.Rel 4; C.Rel 3; + C.Lambda (C.Name "z", C.Rel 4, + C.Appl [ + C.MutInd (HelmLibraryObjects.Logic.eq_URI, 0, []); + C.Rel 5; C.Rel 1; C.Rel 4 + ]); + C.Appl [C.MutConstruct (HelmLibraryObjects.Logic.eq_URI, 0, 1, []); + C.Rel 4; C.Rel 3]; + C.Rel 2; C.Appl [C.Rel 1; C.Rel 2] + ] + ] in + let ens = [ + (UriManager.uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/A.var", + C.Rel 4); + (UriManager.uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/x.var", + C.Rel 3); + (UriManager.uri_of_string "cic:/Coq/Init/Logic/Logic_lemmas/equality/y.var", + C.Rel 2); + ] in + let term2 = C.Appl [ + C.Const (HelmLibraryObjects.Logic.sym_eq_URI, ens); + C.Appl [C.Rel 1; C.Rel 2] + ] in + let ty, ug = + CicTypeChecker.type_of_aux' [] context term CicUniv.empty_ugraph + in + Printf.printf "OK, %s ha tipo %s\n" (CicPp.ppterm term) (CicPp.ppterm ty); + let ty, ug = + CicTypeChecker.type_of_aux' [] context term2 CicUniv.empty_ugraph + in + Printf.printf "OK, %s ha tipo %s\n" (CicPp.ppterm term2) (CicPp.ppterm ty); +;; + + +let test_lib () = + let uri = Sys.argv.(1) in + let t = CicUtil.term_of_uri (UriManager.uri_of_string uri) in + let ty, _ = CicTypeChecker.type_of_aux' [] [] t CicUniv.empty_ugraph in + Printf.printf "Term of %s: %s\n" uri (CicPp.ppterm t); + Printf.printf "type: %s\n" (CicPp.ppterm ty); +;; + + +(* differing ();; *) +(* next_after ();; *) +(* discrimination_tree_test ();; *) +(* path_indexing_test ();; *) +(* test_subst ();; *) +Helm_registry.load_from "../../matita/matita.conf.xml"; +(* test_refl ();; *) +test_lib ();; diff --git a/helm/ocaml/tactics/paramodulation/utils.ml b/helm/ocaml/tactics/paramodulation/utils.ml new file mode 100644 index 000000000..3cafedd54 --- /dev/null +++ b/helm/ocaml/tactics/paramodulation/utils.ml @@ -0,0 +1,674 @@ +(* Copyright (C) 2005, HELM Team. + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://cs.unibo.it/helm/. + *) + +(* $Id$ *) + +let debug = true;; + +let debug_print s = if debug then prerr_endline (Lazy.force s);; + +let print_metasenv metasenv = + String.concat "\n--------------------------\n" + (List.map (fun (i, context, term) -> + (string_of_int i) ^ " [\n" ^ (CicPp.ppcontext context) ^ + "\n] " ^ (CicPp.ppterm term)) + metasenv) +;; + + + + +let print_subst ?(prefix="\n") subst = + String.concat prefix + (List.map + (fun (i, (c, t, ty)) -> + Printf.sprintf "?%d -> %s : %s" i + (CicPp.ppterm t) (CicPp.ppterm ty)) + subst) +;; + +type comparison = Lt | Le | Eq | Ge | Gt | Incomparable;; + +let string_of_comparison = function + | Lt -> "<" + | Le -> "<=" + | Gt -> ">" + | Ge -> ">=" + | Eq -> "=" + | Incomparable -> "I" + +module OrderedTerm = +struct + type t = Cic.term + + let compare = Pervasives.compare +end + +module TermSet = Set.Make(OrderedTerm);; +module TermMap = Map.Make(OrderedTerm);; + +let symbols_of_term term = + let module C = Cic in + let rec aux map = function + | C.Meta _ -> map + | C.Appl l -> + List.fold_left (fun res t -> (aux res t)) map l + | t -> + let map = + try + let c = TermMap.find t map in + TermMap.add t (c+1) map + with Not_found -> + TermMap.add t 1 map + in + map + in + aux TermMap.empty term +;; + + +let metas_of_term term = + let module C = Cic in + let rec aux = function + | C.Meta _ as t -> TermSet.singleton t + | C.Appl l -> + List.fold_left (fun res t -> TermSet.union res (aux t)) TermSet.empty l + | t -> TermSet.empty (* TODO: maybe add other cases? *) + in + aux term +;; + + +(************************* rpo ********************************) +let number = [ + UriManager.uri_of_string "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1)",3; + UriManager.uri_of_string "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/1)",6; + UriManager.uri_of_string "cic:/Coq/Init/Datatypes/nat.ind#xpointer(1/1/2)",9; + HelmLibraryObjects.Peano.pred_URI, 12; + HelmLibraryObjects.Peano.plus_URI, 15; + HelmLibraryObjects.Peano.minus_URI, 18; + HelmLibraryObjects.Peano.mult_URI, 21 + ] +;; + +let atomic t = + match t with + Cic.Const _ + | Cic.MutInd _ + | Cic.MutConstruct _ -> true + | _ -> false + +let sig_order t1 t2 = + try + let u1 = CicUtil.uri_of_term t1 in + let u2 = CicUtil.uri_of_term t2 in + let n1 = List.assoc u1 number in + let n2 = List.assoc u2 number in + if n1 < n2 then Lt + else if n1 > n2 then Gt + else + begin + prerr_endline ("t1 = "^(CicPp.ppterm t1)); + prerr_endline ("t2 = "^(CicPp.ppterm t2)); flush; + assert false + end + with + Invalid_argument _ + | Not_found -> Incomparable + +let rec rpo t1 t2 = + let module C = Cic in + match t1,t2 with + C.Meta (_, _), C.Meta (_,_) -> Incomparable + | C.Meta (_,_) as t1,t2 when TermSet.mem t1 (metas_of_term t2) + -> Lt + | t1, (C.Meta (_,_) as t2) when TermSet.mem t2 (metas_of_term t1) + -> Gt + | C.Appl (h1::arg1),C.Appl (h2::arg2) when h1=h2 -> + (match lex arg1 arg2 with + | Lt when (check Gt t2 arg1) -> Lt + | Gt when (check Gt t1 arg2) -> Gt + | _ -> Incomparable ) + | C.Appl (h1::arg1),C.Appl (h2::arg2) -> + (match sig_order h1 h2 with + | Lt when (check Gt t2 arg1) -> Lt + | Gt when (check Gt t1 arg2) -> Gt + | _ -> Incomparable ) + | C.Appl (h1::arg1), t2 when atomic t2 -> + (match sig_order h1 t2 with + | Lt when (check Gt t2 arg1) -> Lt + | Gt -> Gt + | _ -> Incomparable ) + | t1 , C.Appl (h2::arg2) when atomic t1 -> + (match sig_order t1 h2 with + | Lt -> Lt + | Gt when (check Gt t1 arg2) -> Gt + | _ -> Incomparable ) + | C.Appl [] , _ -> assert false + | _ , C.Appl [] -> assert false + | _,_ -> Incomparable + +and lex l1 l2 = + match l1,l2 with + [],[] -> Incomparable + | [],_ -> assert false + | _, [] -> assert false + | a1::l1, a2::l2 when a1 = a2 -> lex l1 l2 + | a1::_, a2::_ -> rpo a1 a2 + +and check o t l = + List.fold_left + (fun b a -> b && (rpo t a = o)) + true l +;; + + +(*********************** fine rpo *****************************) + +(* (weight of constants, [(meta, weight_of_meta)]) *) +type weight = int * (int * int) list;; + +let string_of_weight (cw, mw) = + let s = + String.concat ", " + (List.map (function (m, w) -> Printf.sprintf "(%d,%d)" m w) mw) + in + Printf.sprintf "[%d; %s]" cw s + + +let weight_of_term ?(consider_metas=true) term = + let module C = Cic in + let vars_dict = Hashtbl.create 5 in + let rec aux = function + | C.Meta (metano, _) when consider_metas -> + (try + let oldw = Hashtbl.find vars_dict metano in + Hashtbl.replace vars_dict metano (oldw+1) + with Not_found -> + Hashtbl.add vars_dict metano 1); + 0 + | C.Meta _ -> 0 (* "variables" are lighter than constants and functions...*) + + | C.Var (_, ens) + | C.Const (_, ens) + | C.MutInd (_, _, ens) + | C.MutConstruct (_, _, _, ens) -> + List.fold_left (fun w (u, t) -> (aux t) + w) 1 ens + + | C.Cast (t1, t2) + | C.Lambda (_, t1, t2) + | C.Prod (_, t1, t2) + | C.LetIn (_, t1, t2) -> + let w1 = aux t1 in + let w2 = aux t2 in + w1 + w2 + 1 + + | C.Appl l -> List.fold_left (+) 0 (List.map aux l) + + | C.MutCase (_, _, outt, t, pl) -> + let w1 = aux outt in + let w2 = aux t in + let w3 = List.fold_left (+) 0 (List.map aux pl) in + w1 + w2 + w3 + 1 + + | C.Fix (_, fl) -> + List.fold_left (fun w (n, i, t1, t2) -> (aux t1) + (aux t2) + w) 1 fl + + | C.CoFix (_, fl) -> + List.fold_left (fun w (n, t1, t2) -> (aux t1) + (aux t2) + w) 1 fl + + | _ -> 1 + in + let w = aux term in + let l = + Hashtbl.fold (fun meta metaw resw -> (meta, metaw)::resw) vars_dict [] in + let compare w1 w2 = + match w1, w2 with + | (m1, _), (m2, _) -> m2 - m1 + in + (w, List.sort compare l) (* from the biggest meta to the smallest (0) *) +;; + + +module OrderedInt = struct + type t = int + + let compare = Pervasives.compare +end + +module IntSet = Set.Make(OrderedInt) + +let compute_equality_weight ty left right = + let metasw = ref 0 in + let weight_of t = + let w, m = (weight_of_term ~consider_metas:true t) in + metasw := !metasw + (2 * (List.length m)); + w + in + (* Warning: the following let cannot be expanded since it forces the + right evaluation order!!!! *) + let w = (weight_of ty) + (weight_of left) + (weight_of right) in + w + !metasw +;; + + +(* returns a "normalized" version of the polynomial weight wl (with type + * weight list), i.e. a list sorted ascending by meta number, + * from 0 to maxmeta. wl must be sorted descending by meta number. Example: + * normalize_weight 5 (3, [(3, 2); (1, 1)]) -> + * (3, [(1, 1); (2, 0); (3, 2); (4, 0); (5, 0)]) *) +let normalize_weight maxmeta (cw, wl) = + let rec aux = function + | 0 -> [] + | m -> (m, 0)::(aux (m-1)) + in + let tmpl = aux maxmeta in + let wl = + List.sort + (fun (m, _) (n, _) -> Pervasives.compare m n) + (List.fold_left + (fun res (m, w) -> (m, w)::(List.remove_assoc m res)) tmpl wl) + in + (cw, wl) +;; + + +let normalize_weights (cw1, wl1) (cw2, wl2) = + let rec aux wl1 wl2 = + match wl1, wl2 with + | [], [] -> [], [] + | (m, w)::tl1, (n, w')::tl2 when m = n -> + let res1, res2 = aux tl1 tl2 in + (m, w)::res1, (n, w')::res2 + | (m, w)::tl1, ((n, w')::_ as wl2) when m < n -> + let res1, res2 = aux tl1 wl2 in + (m, w)::res1, (m, 0)::res2 + | ((m, w)::_ as wl1), (n, w')::tl2 when m > n -> + let res1, res2 = aux wl1 tl2 in + (n, 0)::res1, (n, w')::res2 + | [], (n, w)::tl2 -> + let res1, res2 = aux [] tl2 in + (n, 0)::res1, (n, w)::res2 + | (m, w)::tl1, [] -> + let res1, res2 = aux tl1 [] in + (m, w)::res1, (m, 0)::res2 + | _, _ -> assert false + in + let cmp (m, _) (n, _) = compare m n in + let wl1, wl2 = aux (List.sort cmp wl1) (List.sort cmp wl2) in + (cw1, wl1), (cw2, wl2) +;; + + +let compare_weights ?(normalize=false) + ((h1, w1) as weight1) ((h2, w2) as weight2)= + let (h1, w1), (h2, w2) = + if normalize then + normalize_weights weight1 weight2 + else + (h1, w1), (h2, w2) + in + let res, diffs = + try + List.fold_left2 + (fun ((lt, eq, gt), diffs) w1 w2 -> + match w1, w2 with + | (meta1, w1), (meta2, w2) when meta1 = meta2 -> + let diffs = (w1 - w2) + diffs in + let r = compare w1 w2 in + if r < 0 then (lt+1, eq, gt), diffs + else if r = 0 then (lt, eq+1, gt), diffs + else (lt, eq, gt+1), diffs + | (meta1, w1), (meta2, w2) -> + debug_print + (lazy + (Printf.sprintf "HMMM!!!! %s, %s\n" + (string_of_weight weight1) (string_of_weight weight2))); + assert false) + ((0, 0, 0), 0) w1 w2 + with Invalid_argument _ -> + debug_print + (lazy + (Printf.sprintf "Invalid_argument: %s{%s}, %s{%s}, normalize = %s\n" + (string_of_weight (h1, w1)) (string_of_weight weight1) + (string_of_weight (h2, w2)) (string_of_weight weight2) + (string_of_bool normalize))); + assert false + in + let hdiff = h1 - h2 in + match res with + | (0, _, 0) -> + if hdiff < 0 then Lt + else if hdiff > 0 then Gt + else Eq (* Incomparable *) + | (m, _, 0) -> + if hdiff <= 0 then Lt + else if (- diffs) >= hdiff then Le else Incomparable + | (0, _, m) -> + if hdiff >= 0 then Gt + else if diffs >= (- hdiff) then Ge else Incomparable + | (m, _, n) when m > 0 && n > 0 -> + Incomparable + | _ -> assert false + +;; + + +let rec aux_ordering ?(recursion=true) t1 t2 = + let module C = Cic in + let compare_uris u1 u2 = + let res = + compare (UriManager.string_of_uri u1) (UriManager.string_of_uri u2) in + if res < 0 then Lt + else if res = 0 then Eq + else Gt + in + match t1, t2 with + | C.Meta _, _ + | _, C.Meta _ -> Incomparable + + | t1, t2 when t1 = t2 -> Eq + + | C.Rel n, C.Rel m -> if n > m then Lt else Gt + | C.Rel _, _ -> Lt + | _, C.Rel _ -> Gt + + | C.Const (u1, _), C.Const (u2, _) -> compare_uris u1 u2 + | C.Const _, _ -> Lt + | _, C.Const _ -> Gt + + | C.MutInd (u1, _, _), C.MutInd (u2, _, _) -> compare_uris u1 u2 + | C.MutInd _, _ -> Lt + | _, C.MutInd _ -> Gt + + | C.MutConstruct (u1, _, _, _), C.MutConstruct (u2, _, _, _) -> + compare_uris u1 u2 + | C.MutConstruct _, _ -> Lt + | _, C.MutConstruct _ -> Gt + + | C.Appl l1, C.Appl l2 when recursion -> + let rec cmp t1 t2 = + match t1, t2 with + | [], [] -> Eq + | _, [] -> Gt + | [], _ -> Lt + | hd1::tl1, hd2::tl2 -> + let o = aux_ordering hd1 hd2 in + if o = Eq then cmp tl1 tl2 + else o + in + cmp l1 l2 + | C.Appl (h1::t1), C.Appl (h2::t2) when not recursion -> + aux_ordering h1 h2 + + | t1, t2 -> + debug_print + (lazy + (Printf.sprintf "These two terms are not comparable:\n%s\n%s\n\n" + (CicPp.ppterm t1) (CicPp.ppterm t2))); + Incomparable +;; + + +(* w1, w2 are the weights, they should already be normalized... *) +let nonrec_kbo_w (t1, w1) (t2, w2) = + match compare_weights w1 w2 with + | Le -> if aux_ordering t1 t2 = Lt then Lt else Incomparable + | Ge -> if aux_ordering t1 t2 = Gt then Gt else Incomparable + | Eq -> aux_ordering t1 t2 + | res -> res +;; + + +let nonrec_kbo t1 t2 = + let w1 = weight_of_term t1 in + let w2 = weight_of_term t2 in + (* + prerr_endline ("weight1 :"^(string_of_weight w1)); + prerr_endline ("weight2 :"^(string_of_weight w2)); + *) + match compare_weights ~normalize:true w1 w2 with + | Le -> if aux_ordering t1 t2 = Lt then Lt else Incomparable + | Ge -> if aux_ordering t1 t2 = Gt then Gt else Incomparable + | Eq -> aux_ordering t1 t2 + | res -> res +;; + + +let rec kbo t1 t2 = + let aux = aux_ordering ~recursion:false in + let w1 = weight_of_term t1 + and w2 = weight_of_term t2 in + let rec cmp t1 t2 = + match t1, t2 with + | [], [] -> Eq + | _, [] -> Gt + | [], _ -> Lt + | hd1::tl1, hd2::tl2 -> + let o = + kbo hd1 hd2 + in + if o = Eq then cmp tl1 tl2 + else o + in + let comparison = compare_weights ~normalize:true w1 w2 in + match comparison with + | Le -> + let r = aux t1 t2 in + if r = Lt then Lt + else if r = Eq then ( + match t1, t2 with + | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> + if cmp tl1 tl2 = Lt then Lt else Incomparable + | _, _ -> Incomparable + ) else Incomparable + | Ge -> + let r = aux t1 t2 in + if r = Gt then Gt + else if r = Eq then ( + match t1, t2 with + | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> + if cmp tl1 tl2 = Gt then Gt else Incomparable + | _, _ -> Incomparable + ) else Incomparable + | Eq -> + let r = aux t1 t2 in + if r = Eq then ( + match t1, t2 with + | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> + cmp tl1 tl2 + | _, _ -> Incomparable + ) else r + | res -> res +;; + +let rec ao t1 t2 = + let get_hd t = + match t with + Cic.MutConstruct(uri,tyno,cno,_) -> Some(uri,tyno,cno) + | Cic.Appl(Cic.MutConstruct(uri,tyno,cno,_)::_) -> + Some(uri,tyno,cno) + | _ -> None in + let aux = aux_ordering ~recursion:false in + let w1 = weight_of_term t1 + and w2 = weight_of_term t2 in + let rec cmp t1 t2 = + match t1, t2 with + | [], [] -> Eq + | _, [] -> Gt + | [], _ -> Lt + | hd1::tl1, hd2::tl2 -> + let o = + ao hd1 hd2 + in + if o = Eq then cmp tl1 tl2 + else o + in + match get_hd t1, get_hd t2 with + Some(_),None -> Lt + | None,Some(_) -> Gt + | _ -> + let comparison = compare_weights ~normalize:true w1 w2 in + match comparison with + | Le -> + let r = aux t1 t2 in + if r = Lt then Lt + else if r = Eq then ( + match t1, t2 with + | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> + if cmp tl1 tl2 = Lt then Lt else Incomparable + | _, _ -> Incomparable + ) else Incomparable + | Ge -> + let r = aux t1 t2 in + if r = Gt then Gt + else if r = Eq then ( + match t1, t2 with + | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> + if cmp tl1 tl2 = Gt then Gt else Incomparable + | _, _ -> Incomparable + ) else Incomparable + | Eq -> + let r = aux t1 t2 in + if r = Eq then ( + match t1, t2 with + | Cic.Appl (h1::tl1), Cic.Appl (h2::tl2) when h1 = h2 -> + cmp tl1 tl2 + | _, _ -> Incomparable + ) else r + | res -> res +;; + +let names_of_context context = + List.map + (function + | None -> None + | Some (n, e) -> Some n) + context +;; + + +let rec lpo t1 t2 = + let module C = Cic in + match t1, t2 with + | t1, t2 when t1 = t2 -> Eq + | t1, (C.Meta _ as m) -> + if TermSet.mem m (metas_of_term t1) then Gt else Incomparable + | (C.Meta _ as m), t2 -> + if TermSet.mem m (metas_of_term t2) then Lt else Incomparable + | C.Appl (hd1::tl1), C.Appl (hd2::tl2) -> ( + let res = + let f o r t = + if r then true else + match lpo t o with + | Gt | Eq -> true + | _ -> false + in + let res1 = List.fold_left (f t2) false tl1 in + if res1 then Gt + else let res2 = List.fold_left (f t1) false tl2 in + if res2 then Lt + else Incomparable + in + if res <> Incomparable then + res + else + let f o r t = + if not r then false else + match lpo o t with + | Gt -> true + | _ -> false + in + match aux_ordering hd1 hd2 with + | Gt -> + let res = List.fold_left (f t1) false tl2 in + if res then Gt + else Incomparable + | Lt -> + let res = List.fold_left (f t2) false tl1 in + if res then Lt + else Incomparable + | Eq -> ( + let lex_res = + try + List.fold_left2 + (fun r t1 t2 -> if r <> Eq then r else lpo t1 t2) + Eq tl1 tl2 + with Invalid_argument _ -> + Incomparable + in + match lex_res with + | Gt -> + if List.fold_left (f t1) false tl2 then Gt + else Incomparable + | Lt -> + if List.fold_left (f t2) false tl1 then Lt + else Incomparable + | _ -> Incomparable + ) + | _ -> Incomparable + ) + | t1, t2 -> aux_ordering t1 t2 +;; + + +(* settable by the user... *) +(* let compare_terms = ref nonrec_kbo;; *) +(* let compare_terms = ref ao;; *) +let compare_terms = ref rpo;; + +let guarded_simpl context t = t +(* + let t' = ProofEngineReduction.simpl context t in + let simpl_order = !compare_terms t t' in + if simpl_order = Gt then + (* prerr_endline ("reduce: "^(CicPp.ppterm t)^(CicPp.ppterm t')); *) + t' + else t *) +;; + +type equality_sign = Negative | Positive;; + +let string_of_sign = function + | Negative -> "Negative" + | Positive -> "Positive" +;; + + +type pos = Left | Right + +let string_of_pos = function + | Left -> "Left" + | Right -> "Right" +;; + + +let eq_ind_URI () = LibraryObjects.eq_ind_URI ~eq:(LibraryObjects.eq_URI ()) +let eq_ind_r_URI () = LibraryObjects.eq_ind_r_URI ~eq:(LibraryObjects.eq_URI ()) +let sym_eq_URI () = LibraryObjects.sym_eq_URI ~eq:(LibraryObjects.eq_URI ()) +let eq_XURI () = + let s = UriManager.string_of_uri (LibraryObjects.eq_URI ()) in + UriManager.uri_of_string (s ^ "#xpointer(1/1/1)") +let trans_eq_URI () = LibraryObjects.trans_eq_URI ~eq:(LibraryObjects.eq_URI ()) diff --git a/helm/ocaml/tactics/paramodulation/utils.mli b/helm/ocaml/tactics/paramodulation/utils.mli new file mode 100644 index 000000000..2b09e59ae --- /dev/null +++ b/helm/ocaml/tactics/paramodulation/utils.mli @@ -0,0 +1,84 @@ +(* Copyright (C) 2005, HELM Team. + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://cs.unibo.it/helm/. + *) + +(* (weight of constants, [(meta, weight_of_meta)]) *) +type weight = int * (int * int) list;; + +type comparison = Lt | Le | Eq | Ge | Gt | Incomparable;; + +val print_metasenv: Cic.metasenv -> string + +val print_subst: ?prefix:string -> Cic.substitution -> string + +val string_of_weight: weight -> string + +val weight_of_term: ?consider_metas:bool -> Cic.term -> weight + +val normalize_weight: int -> weight -> weight + +val string_of_comparison: comparison -> string + +val compare_weights: ?normalize:bool -> weight -> weight -> comparison + +val nonrec_kbo: Cic.term -> Cic.term -> comparison + +val rpo: Cic.term -> Cic.term -> comparison + +val nonrec_kbo_w: (Cic.term * weight) -> (Cic.term * weight) -> comparison + +val names_of_context: Cic.context -> (Cic.name option) list + +module TermMap: Map.S with type key = Cic.term + +val symbols_of_term: Cic.term -> int TermMap.t + +val lpo: Cic.term -> Cic.term -> comparison + +val kbo: Cic.term -> Cic.term -> comparison + +val ao: Cic.term -> Cic.term -> comparison + +(** term-ordering function settable by the user *) +val compare_terms: (Cic.term -> Cic.term -> comparison) ref + +val guarded_simpl: Cic.context -> Cic.term -> Cic.term + +type equality_sign = Negative | Positive + +val string_of_sign: equality_sign -> string + +type pos = Left | Right + +val string_of_pos: pos -> string + +val compute_equality_weight: Cic.term -> Cic.term -> Cic.term -> int + +val debug_print: string Lazy.t -> unit + +val eq_ind_URI: unit -> UriManager.uri +val eq_ind_r_URI: unit -> UriManager.uri +val sym_eq_URI: unit -> UriManager.uri +val eq_XURI: unit -> UriManager.uri +val trans_eq_URI: unit -> UriManager.uri diff --git a/helm/ocaml/tactics/tactics.ml b/helm/ocaml/tactics/tactics.ml index 170d6887f..d70df41f5 100644 --- a/helm/ocaml/tactics/tactics.ml +++ b/helm/ocaml/tactics/tactics.ml @@ -38,6 +38,7 @@ let contradiction = NegationTactics.contradiction_tac let cut = PrimitiveTactics.cut_tac let decide_equality = DiscriminationTactics.decide_equality_tac let decompose = EliminationTactics.decompose_tac +let demodulate = Indexing.demodulate_tac let discriminate = DiscriminationTactics.discriminate_tac let elim_intros = PrimitiveTactics.elim_intros_tac let elim_intros_simpl = PrimitiveTactics.elim_intros_simpl_tac diff --git a/helm/ocaml/tactics/tactics.mli b/helm/ocaml/tactics/tactics.mli index 25e479b47..c8c225cdd 100644 --- a/helm/ocaml/tactics/tactics.mli +++ b/helm/ocaml/tactics/tactics.mli @@ -23,6 +23,9 @@ val decompose : ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> ?user_types:(UriManager.uri * int) list -> dbd:HMysql.dbd -> string -> ProofEngineTypes.tactic +val demodulate : + dbd:HMysql.dbd -> + pattern:ProofEngineTypes.lazy_pattern -> ProofEngineTypes.tactic val discriminate : term:Cic.term -> ProofEngineTypes.tactic val elim_intros : ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->