Added a new (reduction) tactic demodulate.
| Type of UriManager.uri * int
type 'lazy_term reduction =
- [ `Normalize
+ [ `Demodulate
+ | `Normalize
| `Reduce
| `Simpl
| `Unfold of 'lazy_term option
let pp_idents idents = "[" ^ String.concat "; " idents ^ "]"
let pp_reduction_kind ~term_pp = function
+ | `Demodulate -> "demodulate"
| `Normalize -> "normalize"
| `Reduce -> "reduce"
| `Simpl -> "simplify"
| 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:[])
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
| `Unfold (Some t) ->
let t = disambiguate_lazy_term lexicon_status_ref t in
`Unfold (Some t)
+ | `Demodulate
| `Normalize
| `Reduce
| `Simpl
[ 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
+++ /dev/null
-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
+++ /dev/null
-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) $<
+++ /dev/null
-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)
-
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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
-;;
+++ /dev/null
-(* 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))
-;;
+++ /dev/null
-(* 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
+++ /dev/null
-(* 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
-;;
+++ /dev/null
-(* 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)))
-;;
+++ /dev/null
-(* $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 ();;
+++ /dev/null
-(* 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 ())
+++ /dev/null
-(* 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
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
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
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
;;
*)
+(*
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) () =
| 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
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
--- /dev/null
+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
--- /dev/null
+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
+
--- /dev/null
+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)
+
+
--- /dev/null
+(* 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
+
--- /dev/null
+(* 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
+
--- /dev/null
+(* 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)
--- /dev/null
+(* 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))
+;;
--- /dev/null
+(* 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
--- /dev/null
+(* 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)*)
+
--- /dev/null
+(* 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)))
+*)
+;;
--- /dev/null
+(* 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
--- /dev/null
+(* $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 ();;
--- /dev/null
+(* 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 ())
--- /dev/null
+(* 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
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
?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 ->
projects / helm.git / commitdiff