From: Andrea Asperti Date: Thu, 7 Oct 2010 16:24:44 +0000 (+0000) Subject: - cic_exportation, cic_acic, acic_content (only parts related to acic) X-Git-Tag: make_still_working~2795 X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=bfcde2b08d72f1392ed61164c67d199360f0397f;p=helm.git - cic_exportation, cic_acic, acic_content (only parts related to acic) metadata, cic_proof_checking and old binaries removed --- diff --git a/matita/components/METAS/meta.helm-cic_acic.src b/matita/components/METAS/meta.helm-cic_acic.src deleted file mode 100644 index 51afe1bda..000000000 --- a/matita/components/METAS/meta.helm-cic_acic.src +++ /dev/null @@ -1,4 +0,0 @@ -requires="helm-cic_proof_checking" -version="0.0.1" -archive(byte)="cic_acic.cma" -archive(native)="cic_acic.cmxa" diff --git a/matita/components/METAS/meta.helm-cic_exportation.src b/matita/components/METAS/meta.helm-cic_exportation.src deleted file mode 100644 index f73bbeb64..000000000 --- a/matita/components/METAS/meta.helm-cic_exportation.src +++ /dev/null @@ -1,5 +0,0 @@ -requires="helm-cic_acic" -version="0.0.1" -archive(byte)="cic_exportation.cma" -archive(native)="cic_exportation.cmxa" -linkopts="" diff --git a/matita/components/METAS/meta.helm-cic_proof_checking.src b/matita/components/METAS/meta.helm-cic_proof_checking.src deleted file mode 100644 index 223a182a9..000000000 --- a/matita/components/METAS/meta.helm-cic_proof_checking.src +++ /dev/null @@ -1,7 +0,0 @@ -requires="helm-cic helm-logger helm-getter" -version="0.0.1" -archive(byte)="cic_proof_checking.cma" -archive(native)="cic_proof_checking.cmxa" -archive(byte,miniReduction)="cicSubstitution.cmo cicMiniReduction.cmo" -archive(native,miniReduction)="cicSubstitution.cmx cicMiniReduction.cmx" -linkopts="" diff --git a/matita/components/METAS/meta.helm-grafite_engine.src b/matita/components/METAS/meta.helm-grafite_engine.src index 918352ed5..469912fa4 100644 --- a/matita/components/METAS/meta.helm-grafite_engine.src +++ b/matita/components/METAS/meta.helm-grafite_engine.src @@ -1,4 +1,4 @@ -requires="helm-library helm-grafite helm-cic_proof_checking helm-ng_tactics helm-ng_library" +requires="helm-library helm-grafite helm-cic helm-ng_tactics helm-ng_library" version="0.0.1" archive(byte)="grafite_engine.cma" archive(native)="grafite_engine.cmxa" diff --git a/matita/components/METAS/meta.helm-library.src b/matita/components/METAS/meta.helm-library.src index d4955e05d..2871ae878 100644 --- a/matita/components/METAS/meta.helm-library.src +++ b/matita/components/METAS/meta.helm-library.src @@ -1,4 +1,4 @@ -requires="helm-cic_acic helm-metadata" +requires="helm-cic helm-getter helm-hmysql" version="0.0.1" archive(byte)="library.cma" archive(native)="library.cmxa" diff --git a/matita/components/METAS/meta.helm-metadata.src b/matita/components/METAS/meta.helm-metadata.src deleted file mode 100644 index a5b138301..000000000 --- a/matita/components/METAS/meta.helm-metadata.src +++ /dev/null @@ -1,4 +0,0 @@ -requires="helm-hmysql helm-cic_proof_checking" -version="0.0.1" -archive(byte)="metadata.cma" -archive(native)="metadata.cmxa" diff --git a/matita/components/METAS/meta.helm-ng_kernel.src b/matita/components/METAS/meta.helm-ng_kernel.src index b5402e3fa..549e479d7 100644 --- a/matita/components/METAS/meta.helm-ng_kernel.src +++ b/matita/components/METAS/meta.helm-ng_kernel.src @@ -1,4 +1,4 @@ -requires="helm-cic_proof_checking helm-library" +requires="helm-library" version="0.0.1" archive(byte)="ng_kernel.cma" archive(native)="ng_kernel.cmxa" diff --git a/matita/components/Makefile b/matita/components/Makefile index 43503fe26..c9056ef3a 100644 --- a/matita/components/Makefile +++ b/matita/components/Makefile @@ -18,10 +18,6 @@ MODULES = \ logger \ getter \ cic \ - cic_proof_checking \ - cic_acic \ - cic_exportation \ - metadata \ library \ ng_kernel \ acic_content \ diff --git a/matita/components/acic_content/.depend b/matita/components/acic_content/.depend index 89dca0e44..e8b9a6135 100644 --- a/matita/components/acic_content/.depend +++ b/matita/components/acic_content/.depend @@ -1,30 +1,19 @@ content.cmi: -acic2content.cmi: content.cmi -content2cic.cmi: content.cmi cicNotationUtil.cmi: cicNotationPt.cmo cicNotationEnv.cmi: cicNotationPt.cmo cicNotationPp.cmi: cicNotationPt.cmo cicNotationEnv.cmi -acic2astMatcher.cmi: cicNotationPt.cmo termAcicContent.cmi: cicNotationPt.cmo cicNotationPt.cmo: cicNotationPt.cmx: content.cmo: content.cmi content.cmx: content.cmi -acic2content.cmo: content.cmi acic2content.cmi -acic2content.cmx: content.cmx acic2content.cmi -content2cic.cmo: content.cmi content2cic.cmi -content2cic.cmx: content.cmx content2cic.cmi cicNotationUtil.cmo: cicNotationPt.cmo cicNotationUtil.cmi cicNotationUtil.cmx: cicNotationPt.cmx cicNotationUtil.cmi cicNotationEnv.cmo: cicNotationUtil.cmi cicNotationPt.cmo cicNotationEnv.cmi cicNotationEnv.cmx: cicNotationUtil.cmx cicNotationPt.cmx cicNotationEnv.cmi cicNotationPp.cmo: cicNotationPt.cmo cicNotationEnv.cmi cicNotationPp.cmi cicNotationPp.cmx: cicNotationPt.cmx cicNotationEnv.cmx cicNotationPp.cmi -acic2astMatcher.cmo: cicNotationUtil.cmi cicNotationPt.cmo cicNotationPp.cmi \ - acic2astMatcher.cmi -acic2astMatcher.cmx: cicNotationUtil.cmx cicNotationPt.cmx cicNotationPp.cmx \ - acic2astMatcher.cmi termAcicContent.cmo: cicNotationUtil.cmi cicNotationPt.cmo cicNotationPp.cmi \ - acic2content.cmi acic2astMatcher.cmi termAcicContent.cmi + termAcicContent.cmi termAcicContent.cmx: cicNotationUtil.cmx cicNotationPt.cmx cicNotationPp.cmx \ - acic2content.cmx acic2astMatcher.cmx termAcicContent.cmi + termAcicContent.cmi diff --git a/matita/components/acic_content/.depend.opt b/matita/components/acic_content/.depend.opt index 307fceaa0..a679f7253 100644 --- a/matita/components/acic_content/.depend.opt +++ b/matita/components/acic_content/.depend.opt @@ -1,30 +1,19 @@ content.cmi: -acic2content.cmi: content.cmi -content2cic.cmi: content.cmi cicNotationUtil.cmi: cicNotationPt.cmx cicNotationEnv.cmi: cicNotationPt.cmx cicNotationPp.cmi: cicNotationPt.cmx cicNotationEnv.cmi -acic2astMatcher.cmi: cicNotationPt.cmx termAcicContent.cmi: cicNotationPt.cmx cicNotationPt.cmo: cicNotationPt.cmx: content.cmo: content.cmi content.cmx: content.cmi -acic2content.cmo: content.cmi acic2content.cmi -acic2content.cmx: content.cmx acic2content.cmi -content2cic.cmo: content.cmi content2cic.cmi -content2cic.cmx: content.cmx content2cic.cmi cicNotationUtil.cmo: cicNotationPt.cmx cicNotationUtil.cmi cicNotationUtil.cmx: cicNotationPt.cmx cicNotationUtil.cmi cicNotationEnv.cmo: cicNotationUtil.cmi cicNotationPt.cmx cicNotationEnv.cmi cicNotationEnv.cmx: cicNotationUtil.cmx cicNotationPt.cmx cicNotationEnv.cmi cicNotationPp.cmo: cicNotationPt.cmx cicNotationEnv.cmi cicNotationPp.cmi cicNotationPp.cmx: cicNotationPt.cmx cicNotationEnv.cmx cicNotationPp.cmi -acic2astMatcher.cmo: cicNotationUtil.cmi cicNotationPt.cmx cicNotationPp.cmi \ - acic2astMatcher.cmi -acic2astMatcher.cmx: cicNotationUtil.cmx cicNotationPt.cmx cicNotationPp.cmx \ - acic2astMatcher.cmi termAcicContent.cmo: cicNotationUtil.cmi cicNotationPt.cmx cicNotationPp.cmi \ - acic2content.cmi acic2astMatcher.cmi termAcicContent.cmi + termAcicContent.cmi termAcicContent.cmx: cicNotationUtil.cmx cicNotationPt.cmx cicNotationPp.cmx \ - acic2content.cmx acic2astMatcher.cmx termAcicContent.cmi + termAcicContent.cmi diff --git a/matita/components/acic_content/Makefile b/matita/components/acic_content/Makefile index 72aa997d1..119aaaa73 100644 --- a/matita/components/acic_content/Makefile +++ b/matita/components/acic_content/Makefile @@ -3,13 +3,10 @@ PREDICATES = INTERFACE_FILES = \ content.mli \ - acic2content.mli \ - content2cic.mli \ cicNotationUtil.mli \ cicNotationEnv.mli \ cicNotationPp.mli \ - acic2astMatcher.mli \ - termAcicContent.mli \ + termAcicContent.mli \ $(NULL) IMPLEMENTATION_FILES = \ cicNotationPt.ml \ diff --git a/matita/components/acic_content/acic2astMatcher.ml b/matita/components/acic_content/acic2astMatcher.ml deleted file mode 100644 index 2062b6c06..000000000 --- a/matita/components/acic_content/acic2astMatcher.ml +++ /dev/null @@ -1,115 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -(* $Id$ *) - -module Ast = CicNotationPt -module Util = CicNotationUtil - -module Matcher32 = -struct - module Pattern32 = - struct - type cic_mask_t = - Blob - | Uri of UriManager.uri - | NRef of NReference.reference - | Appl of cic_mask_t list - - let uri_of_term t = CicUtil.uri_of_term (Deannotate.deannotate_term t) - - let mask_of_cic = function - | Cic.AAppl (_, tl) -> Appl (List.map (fun _ -> Blob) tl), tl - | Cic.AConst (_, _, []) - | Cic.AVar (_, _, []) - | Cic.AMutInd (_, _, _, []) - | Cic.AMutConstruct (_, _, _, _, []) as t -> Uri (uri_of_term t), [] - | _ -> Blob, [] - - let tag_of_term t = - let mask, tl = mask_of_cic t in - Hashtbl.hash mask, tl - - let mask_of_appl_pattern = function - | Ast.NRefPattern nref -> NRef nref, [] - | Ast.UriPattern uri -> Uri uri, [] - | Ast.ImplicitPattern - | Ast.VarPattern _ -> Blob, [] - | Ast.ApplPattern pl -> Appl (List.map (fun _ -> Blob) pl), pl - - let tag_of_pattern p = - let mask, pl = mask_of_appl_pattern p in - Hashtbl.hash mask, pl - - type pattern_t = Ast.cic_appl_pattern - type term_t = Cic.annterm - - let string_of_pattern = CicNotationPp.pp_cic_appl_pattern - let string_of_term t = CicPp.ppterm (Deannotate.deannotate_term t) - - let classify = function - | Ast.ImplicitPattern - | Ast.VarPattern _ -> PatternMatcher.Variable - | Ast.UriPattern _ - | Ast.NRefPattern _ - | Ast.ApplPattern _ -> PatternMatcher.Constructor - end - - module M = PatternMatcher.Matcher (Pattern32) - - let compiler rows = - let match_cb rows matched_terms constructors = - HExtlib.list_findopt - (fun (pl,pid) _ -> - let env = - try - List.map2 - (fun p t -> - match p with - | Ast.ImplicitPattern -> Util.fresh_name (), t - | Ast.VarPattern name -> name, t - | _ -> assert false) - pl matched_terms - with Invalid_argument _ -> assert false in - let rec check_non_linear_patterns = - function - [] -> true - | (name,t)::tl -> - List.for_all - (fun (name',t') -> - name <> name' || - CicUtil.alpha_equivalence - (Deannotate.deannotate_term t) (Deannotate.deannotate_term t') - ) tl && check_non_linear_patterns tl - in - if check_non_linear_patterns env then - Some (env, constructors, pid) - else - None - ) rows - in - M.compiler rows match_cb (fun () -> None) -end - diff --git a/matita/components/acic_content/acic2astMatcher.mli b/matita/components/acic_content/acic2astMatcher.mli deleted file mode 100644 index 0a9ec6a6b..000000000 --- a/matita/components/acic_content/acic2astMatcher.mli +++ /dev/null @@ -1,34 +0,0 @@ -(* Copyright (C) 2005, HELM Team. - * - * This file is part of HELM, an Hypertextual, Electronic - * Library of Mathematics, developed at the Computer Science - * Department, University of Bologna, Italy. - * - * HELM is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * HELM is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with HELM; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, - * MA 02111-1307, USA. - * - * For details, see the HELM World-Wide-Web page, - * http://helm.cs.unibo.it/ - *) - -module Matcher32: -sig - (** @param l3_patterns level 3 (CIC) patterns (AKA cic_appl_pattern) *) - val compiler : - (CicNotationPt.cic_appl_pattern * int) list -> - (Cic.annterm -> - ((string * Cic.annterm) list * Cic.annterm list * int) option) -end - diff --git a/matita/components/acic_content/acic2content.ml b/matita/components/acic_content/acic2content.ml deleted file mode 100644 index c8ff783c3..000000000 --- a/matita/components/acic_content/acic2content.ml +++ /dev/null @@ -1,1189 +0,0 @@ -(* Copyright (C) 2000, 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/. - *) - -(**************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Andrea Asperti *) -(* 16/6/2003 *) -(* *) -(**************************************************************************) - -(* $Id$ *) - -let object_prefix = "obj:";; -let declaration_prefix = "decl:";; -let definition_prefix = "def:";; -let inductive_prefix = "ind:";; -let joint_prefix = "joint:";; -let proof_prefix = "proof:";; -let conclude_prefix = "concl:";; -let premise_prefix = "prem:";; -let lemma_prefix = "lemma:";; - -let hide_coercions = ref true;; - -(* e se mettessi la conversione di BY nell'apply_context ? *) -(* sarebbe carino avere l'invariante che la proof2pres -generasse sempre prove con contesto vuoto *) - -let gen_id prefix seed = - let res = prefix ^ string_of_int !seed in - incr seed ; - res -;; - -let name_of = function - Cic.Anonymous -> None - | Cic.Name b -> Some b;; - -exception Not_a_proof;; -exception NotImplemented;; -exception NotApplicable;; - -(* we do not care for positivity, here, that in any case is enforced by - well typing. Just a brutal search *) - -let rec occur uri = - let module C = Cic in - function - C.Rel _ -> false - | C.Var _ -> false - | C.Meta _ -> false - | C.Sort _ -> false - | C.Implicit _ -> assert false - | C.Prod (_,s,t) -> (occur uri s) or (occur uri t) - | C.Cast (te,ty) -> (occur uri te) - | C.Lambda (_,s,t) -> (occur uri s) or (occur uri t) (* or false ?? *) - | C.LetIn (_,s,ty,t) -> (occur uri s) or (occur uri ty) or (occur uri t) - | C.Appl l -> - List.fold_left - (fun b a -> - if b then b - else (occur uri a)) false l - | C.Const (_,_) -> false - | C.MutInd (uri1,_,_) -> if uri = uri1 then true else false - | C.MutConstruct (_,_,_,_) -> false - | C.MutCase _ -> false (* presuming too much?? *) - | C.Fix _ -> false (* presuming too much?? *) - | C.CoFix (_,_) -> false (* presuming too much?? *) -;; - -let get_id = - let module C = Cic in - function - C.ARel (id,_,_,_) -> id - | C.AVar (id,_,_) -> id - | C.AMeta (id,_,_) -> id - | C.ASort (id,_) -> id - | C.AImplicit _ -> raise NotImplemented - | C.AProd (id,_,_,_) -> id - | C.ACast (id,_,_) -> id - | C.ALambda (id,_,_,_) -> id - | C.ALetIn (id,_,_,_,_) -> id - | C.AAppl (id,_) -> id - | C.AConst (id,_,_) -> id - | C.AMutInd (id,_,_,_) -> id - | C.AMutConstruct (id,_,_,_,_) -> id - | C.AMutCase (id,_,_,_,_,_) -> id - | C.AFix (id,_,_) -> id - | C.ACoFix (id,_,_) -> id -;; - -let test_for_lifting ~ids_to_inner_types ~ids_to_inner_sorts= - let module C = Cic in - let module C2A = Cic2acic in - (* atomic terms are never lifted, according to my policy *) - function - C.ARel (id,_,_,_) -> - (try - ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; - true; - with Not_found -> false) - | C.AVar (id,_,_) -> - (try - ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; - true; - with Not_found -> false) - | C.AMeta (id,_,_) -> - (try - Hashtbl.find ids_to_inner_sorts id = `Prop - with Not_found -> assert false) - | C.ASort (id,_) -> false - | C.AImplicit _ -> raise NotImplemented - | C.AProd (id,_,_,_) -> false - | C.ACast (id,_,_) -> - (try - ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; - true; - with Not_found -> false) - | C.ALambda (id,_,_,_) -> - (try - ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; - true; - with Not_found -> false) - | C.ALetIn (id,_,_,_,_) -> - (try - ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; - true; - with Not_found -> false) - | C.AAppl (id,_) -> - (try - ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; - true; - with Not_found -> false) - | C.AConst (id,_,_) -> - (try - ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; - true; - with Not_found -> false) - | C.AMutInd (id,_,_,_) -> false - | C.AMutConstruct (id,_,_,_,_) -> - (try - ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; - true; - with Not_found -> false) - (* oppure: false *) - | C.AMutCase (id,_,_,_,_,_) -> - (try - ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; - true; - with Not_found -> false) - | C.AFix (id,_,_) -> - (try - ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; - true; - with Not_found -> false) - | C.ACoFix (id,_,_) -> - (try - ignore (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized; - true; - with Not_found -> false) -;; - -(* transform a proof p into a proof list, concatenating the last -conclude element to the apply_context list, in case context is -empty. Otherwise, it just returns [p] *) - -let flat seed p = - let module K = Content in - if (p.K.proof_context = []) then - if p.K.proof_apply_context = [] then [p] - else - let p1 = - { p with - K.proof_context = []; - K.proof_apply_context = [] - } in - p.K.proof_apply_context@[p1] - else - [p] -;; - -let rec serialize seed = - function - [] -> [] - | a::l -> (flat seed a)@(serialize seed l) -;; - -(* top_down = true if the term is a LAMBDA or a decl *) -let generate_conversion seed top_down id inner_proof ~ids_to_inner_types = - let module C2A = Cic2acic in - let module K = Content in - let exp = (try ((Hashtbl.find ids_to_inner_types id).C2A.annexpected) - with Not_found -> None) - in - match exp with - None -> inner_proof - | Some expty -> - if inner_proof.K.proof_conclude.K.conclude_method = "Intros+LetTac" then - { K.proof_name = inner_proof.K.proof_name; - K.proof_id = gen_id proof_prefix seed; - K.proof_context = [] ; - K.proof_apply_context = []; - K.proof_conclude = - { K.conclude_id = gen_id conclude_prefix seed; - K.conclude_aref = id; - K.conclude_method = "TD_Conversion"; - K.conclude_args = - [K.ArgProof {inner_proof with K.proof_name = None}]; - K.conclude_conclusion = Some expty - }; - } - else - { K.proof_name = inner_proof.K.proof_name; - K.proof_id = gen_id proof_prefix seed; - K.proof_context = [] ; - K.proof_apply_context = [{inner_proof with K.proof_name = None}]; - K.proof_conclude = - { K.conclude_id = gen_id conclude_prefix seed; - K.conclude_aref = id; - K.conclude_method = "BU_Conversion"; - K.conclude_args = - [K.Premise - { K.premise_id = gen_id premise_prefix seed; - K.premise_xref = inner_proof.K.proof_id; - K.premise_binder = None; - K.premise_n = None - } - ]; - K.conclude_conclusion = Some expty - }; - } -;; - -let generate_exact seed t id name ~ids_to_inner_types = - let module C2A = Cic2acic in - let module K = Content in - { K.proof_name = name; - K.proof_id = gen_id proof_prefix seed ; - K.proof_context = [] ; - K.proof_apply_context = []; - K.proof_conclude = - { K.conclude_id = gen_id conclude_prefix seed; - K.conclude_aref = id; - K.conclude_method = "Exact"; - K.conclude_args = [K.Term (false, t)]; - K.conclude_conclusion = - try Some (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized - with Not_found -> None - }; - } -;; - -let generate_intros_let_tac seed id n s ty inner_proof name ~ids_to_inner_types = - let module C2A = Cic2acic in - let module C = Cic in - let module K = Content in - { K.proof_name = name; - K.proof_id = gen_id proof_prefix seed ; - K.proof_context = [] ; - K.proof_apply_context = []; - K.proof_conclude = - { K.conclude_id = gen_id conclude_prefix seed; - K.conclude_aref = id; - K.conclude_method = "Intros+LetTac"; - K.conclude_args = [K.ArgProof inner_proof]; - K.conclude_conclusion = - try Some - (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized - with Not_found -> - (match inner_proof.K.proof_conclude.K.conclude_conclusion with - None -> None - | Some t -> - match ty with - None -> Some (C.AProd ("gen"^id,n,s,t)) - | Some ty -> Some (C.ALetIn ("gen"^id,n,s,ty,t))) - }; - } -;; - -let build_decl_item seed id n s ~ids_to_inner_sorts = - let module K = Content in - let sort = - try - Some (Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id)) - with Not_found -> None - in - match sort with - | Some `Prop -> - `Hypothesis - { K.dec_name = name_of n; - K.dec_id = gen_id declaration_prefix seed; - K.dec_inductive = false; - K.dec_aref = id; - K.dec_type = s - } - | _ -> - `Declaration - { K.dec_name = name_of n; - K.dec_id = gen_id declaration_prefix seed; - K.dec_inductive = false; - K.dec_aref = id; - K.dec_type = s - } -;; - -let infer_dependent ~headless context metasenv = function - | [] -> assert false - | [t] -> [false, t] - | he::tl as l -> - if headless then - List.map (function s -> false,s) l - else - try - let hety,_ = - CicTypeChecker.type_of_aux' - metasenv context (Deannotate.deannotate_term he) - CicUniv.oblivion_ugraph - in - let fstorder t = - match CicReduction.whd context t with - | Cic.Prod _ -> false - | _ -> true - in - let rec dummify_last_tgt t = - match CicReduction.whd context t with - | Cic.Prod (n,s,tgt) -> Cic.Prod(n,s, dummify_last_tgt tgt) - | _ -> Cic.Implicit None - in - let rec aux ty = function - | [] -> [] - | t::tl -> - match - FreshNamesGenerator.clean_dummy_dependent_types - (dummify_last_tgt ty) - with - | Cic.Prod (n,src,tgt) -> - (n <> Cic.Anonymous && fstorder src, t) :: - aux (CicSubstitution.subst - (Deannotate.deannotate_term t) tgt) tl - | _ -> List.map (fun s -> false,s) (t::tl) - in - (false, he) :: aux hety tl - with CicTypeChecker.TypeCheckerFailure _ -> assert false -;; - -let rec build_subproofs_and_args ?(headless=false) seed context metasenv l ~ids_to_inner_types ~ids_to_inner_sorts = - let module C = Cic in - let module K = Content in - let rec aux n = - function - [] -> [],[] - | (dep, t)::l1 -> - let need_lifting = - test_for_lifting t ~ids_to_inner_types ~ids_to_inner_sorts in - let subproofs,args = aux (n + if need_lifting then 1 else 0) l1 in - if need_lifting then - let new_subproof = - acic2content - seed context metasenv - ~name:("H" ^ string_of_int n) ~ids_to_inner_types - ~ids_to_inner_sorts t in - let new_arg = - K.Premise - { K.premise_id = gen_id premise_prefix seed; - K.premise_xref = new_subproof.K.proof_id; - K.premise_binder = new_subproof.K.proof_name; - K.premise_n = None - } in - new_subproof::subproofs,new_arg::args - else - let hd = - (match t with - C.ARel (idr,idref,n,b) -> - let sort = - (try - Hashtbl.find ids_to_inner_sorts idr - with Not_found -> `Type (CicUniv.fresh())) in - if sort = `Prop then - K.Premise - { K.premise_id = gen_id premise_prefix seed; - K.premise_xref = idr; - K.premise_binder = Some b; - K.premise_n = Some n - } - else (K.Term (dep,t)) - | C.AConst(id,uri,[]) -> - let sort = - (try - Hashtbl.find ids_to_inner_sorts id - with Not_found -> `Type (CicUniv.fresh())) in - if sort = `Prop then - K.Lemma - { K.lemma_id = gen_id lemma_prefix seed; - K.lemma_name = UriManager.name_of_uri uri; - K.lemma_uri = UriManager.string_of_uri uri - } - else (K.Term (dep,t)) - | C.AMutConstruct(id,uri,tyno,consno,[]) -> - let sort = - (try - Hashtbl.find ids_to_inner_sorts id - with Not_found -> `Type (CicUniv.fresh())) in - if sort = `Prop then - let inductive_types = - (let o,_ = - CicEnvironment.get_obj CicUniv.oblivion_ugraph uri - in - match o with - | Cic.InductiveDefinition (l,_,_,_) -> l - | _ -> assert false - ) in - let (_,_,_,constructors) = - List.nth inductive_types tyno in - let name,_ = List.nth constructors (consno - 1) in - K.Lemma - { K.lemma_id = gen_id lemma_prefix seed; - K.lemma_name = name; - K.lemma_uri = - UriManager.string_of_uri uri ^ "#xpointer(1/" ^ - string_of_int (tyno+1) ^ "/" ^ string_of_int consno ^ - ")" - } - else (K.Term (dep,t)) - | _ -> (K.Term (dep,t))) in - subproofs,hd::args - in - match (aux 1 (infer_dependent ~headless context metasenv l)) with - [p],args -> - [{p with K.proof_name = None}], - List.map - (function - K.Premise prem when prem.K.premise_xref = p.K.proof_id -> - K.Premise {prem with K.premise_binder = None} - | i -> i) args - | p,a as c -> c - -and - -build_def_item seed context metasenv id n t ty ~ids_to_inner_sorts ~ids_to_inner_types = - let module K = Content in - try - let sort = Hashtbl.find ids_to_inner_sorts id in - if sort = `Prop then - (let p = - (acic2content seed context metasenv ?name:(name_of n) ~ids_to_inner_sorts ~ids_to_inner_types t) - in - `Proof p;) - else - `Definition - { K.def_name = name_of n; - K.def_id = gen_id definition_prefix seed; - K.def_aref = id; - K.def_term = t; - K.def_type = ty - } - with - Not_found -> assert false - -(* the following function must be called with an object of sort -Prop. For debugging purposes this is tested again, possibly raising an -Not_a_proof exception *) - -and acic2content seed context metasenv ?name ~ids_to_inner_sorts ~ids_to_inner_types t = - let rec aux ?name context t = - let module C = Cic in - let module K = Content in - let module C2A = Cic2acic in - let t1 = - match t with - C.ARel (id,idref,n,b) as t -> - let sort = Hashtbl.find ids_to_inner_sorts id in - if sort = `Prop then - generate_exact seed t id name ~ids_to_inner_types - else raise Not_a_proof - | C.AVar (id,uri,exp_named_subst) as t -> - let sort = Hashtbl.find ids_to_inner_sorts id in - if sort = `Prop then - generate_exact seed t id name ~ids_to_inner_types - else raise Not_a_proof - | C.AMeta (id,n,l) as t -> - let sort = Hashtbl.find ids_to_inner_sorts id in - if sort = `Prop then - generate_exact seed t id name ~ids_to_inner_types - else raise Not_a_proof - | C.ASort (id,s) -> raise Not_a_proof - | C.AImplicit _ -> raise NotImplemented - | C.AProd (_,_,_,_) -> raise Not_a_proof - | C.ACast (id,v,t) -> aux context v - | C.ALambda (id,n,s,t) -> - let sort = Hashtbl.find ids_to_inner_sorts id in - if sort = `Prop then - let proof = - aux ((Some (n,Cic.Decl (Deannotate.deannotate_term s)))::context) t - in - let proof' = - if proof.K.proof_conclude.K.conclude_method = "Intros+LetTac" then - match proof.K.proof_conclude.K.conclude_args with - [K.ArgProof p] -> p - | _ -> assert false - else proof in - let proof'' = - { proof' with - K.proof_name = None; - K.proof_context = - (build_decl_item seed id n s ids_to_inner_sorts):: - proof'.K.proof_context - } - in - generate_intros_let_tac seed id n s None proof'' name ~ids_to_inner_types - else - raise Not_a_proof - | C.ALetIn (id,n,s,ty,t) -> - let sort = Hashtbl.find ids_to_inner_sorts id in - if sort = `Prop then - let proof = - aux - ((Some (n, - Cic.Def (Deannotate.deannotate_term s,Deannotate.deannotate_term ty)))::context) t - in - let proof' = - if proof.K.proof_conclude.K.conclude_method = "Intros+LetTac" then - match proof.K.proof_conclude.K.conclude_args with - [K.ArgProof p] -> p - | _ -> assert false - else proof in - let proof'' = - { proof' with - K.proof_name = None; - K.proof_context = - ((build_def_item seed context metasenv (get_id s) n s ty ids_to_inner_sorts - ids_to_inner_types):> Cic.annterm K.in_proof_context_element) - ::proof'.K.proof_context; - } - in - generate_intros_let_tac seed id n s (Some ty) proof'' name ~ids_to_inner_types - else - raise Not_a_proof - | C.AAppl (id,li) -> - (try coercion - seed context metasenv id li ~ids_to_inner_types ~ids_to_inner_sorts - with NotApplicable -> - try rewrite - seed context metasenv name id li ~ids_to_inner_types ~ids_to_inner_sorts - with NotApplicable -> - try inductive - seed context metasenv name id li ~ids_to_inner_types ~ids_to_inner_sorts - with NotApplicable -> - try transitivity - seed context metasenv name id li ~ids_to_inner_types ~ids_to_inner_sorts - with NotApplicable -> - let subproofs, args = - build_subproofs_and_args - seed context metasenv li ~ids_to_inner_types ~ids_to_inner_sorts in -(* - let args_to_lift = - List.filter (test_for_lifting ~ids_to_inner_types) li in - let subproofs = - match args_to_lift with - [_] -> List.map aux args_to_lift - | _ -> List.map (aux ~name:"H") args_to_lift in - let args = build_args seed li subproofs - ~ids_to_inner_types ~ids_to_inner_sorts in *) - { K.proof_name = name; - K.proof_id = gen_id proof_prefix seed; - K.proof_context = []; - K.proof_apply_context = serialize seed subproofs; - K.proof_conclude = - { K.conclude_id = gen_id conclude_prefix seed; - K.conclude_aref = id; - K.conclude_method = "Apply"; - K.conclude_args = args; - K.conclude_conclusion = - try Some - (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized - with Not_found -> None - }; - }) - | C.AConst (id,uri,exp_named_subst) as t -> - let sort = Hashtbl.find ids_to_inner_sorts id in - if sort = `Prop then - generate_exact seed t id name ~ids_to_inner_types - else raise Not_a_proof - | C.AMutInd (id,uri,i,exp_named_subst) -> raise Not_a_proof - | C.AMutConstruct (id,uri,i,j,exp_named_subst) as t -> - let sort = Hashtbl.find ids_to_inner_sorts id in - if sort = `Prop then - generate_exact seed t id name ~ids_to_inner_types - else raise Not_a_proof - | C.AMutCase (id,uri,typeno,ty,te,patterns) -> - let inductive_types,noparams = - (let o, _ = CicEnvironment.get_obj CicUniv.oblivion_ugraph uri in - match o with - Cic.Constant _ -> assert false - | Cic.Variable _ -> assert false - | Cic.CurrentProof _ -> assert false - | Cic.InductiveDefinition (l,_,n,_) -> l,n - ) in - let (_,_,_,constructors) = List.nth inductive_types typeno in - let name_and_arities = - let rec count_prods = - function - C.Prod (_,_,t) -> 1 + count_prods t - | _ -> 0 in - List.map - (function (n,t) -> Some n,((count_prods t) - noparams)) constructors in - let pp = - let build_proof p (name,arity) = - let rec make_context_and_body c p n = - if n = 0 then c,(aux context p) - else - (match p with - Cic.ALambda(idl,vname,s1,t1) -> - let ce = - build_decl_item - seed idl vname s1 ~ids_to_inner_sorts in - make_context_and_body (ce::c) t1 (n-1) - | _ -> assert false) in - let context,body = make_context_and_body [] p arity in - K.ArgProof - {body with K.proof_name = name; K.proof_context=context} in - List.map2 build_proof patterns name_and_arities in - let context,term = - (match - build_subproofs_and_args ~headless:true - seed context metasenv ~ids_to_inner_types ~ids_to_inner_sorts [te] - with - l,[t] -> l,t - | _ -> assert false) in - { K.proof_name = name; - K.proof_id = gen_id proof_prefix seed; - K.proof_context = []; - K.proof_apply_context = serialize seed context; - K.proof_conclude = - { K.conclude_id = gen_id conclude_prefix seed; - K.conclude_aref = id; - K.conclude_method = "Case"; - K.conclude_args = - (K.Aux (UriManager.string_of_uri uri)):: - (K.Aux (string_of_int typeno))::(K.Term (false,ty))::term::pp; - K.conclude_conclusion = - try Some - (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized - with Not_found -> None - } - } - | C.AFix (id, no, funs) -> - let context' = - List.fold_left - (fun ctx (_,n,_,ty,_) -> - let ty = Deannotate.deannotate_term ty in - Some (Cic.Name n,Cic.Decl ty) :: ctx) - [] funs @ context - in - let proofs = - List.map - (function (_,name,_,_,bo) -> `Proof (aux context' ~name bo)) funs in - let fun_name = - List.nth (List.map (fun (_,name,_,_,_) -> name) funs) no - in - let decreasing_args = - List.map (function (_,_,n,_,_) -> n) funs in - let jo = - { K.joint_id = gen_id joint_prefix seed; - K.joint_kind = `Recursive decreasing_args; - K.joint_defs = proofs - } - in - { K.proof_name = name; - K.proof_id = gen_id proof_prefix seed; - K.proof_context = [`Joint jo]; - K.proof_apply_context = []; - K.proof_conclude = - { K.conclude_id = gen_id conclude_prefix seed; - K.conclude_aref = id; - K.conclude_method = "Exact"; - K.conclude_args = - [ K.Premise - { K.premise_id = gen_id premise_prefix seed; - K.premise_xref = jo.K.joint_id; - K.premise_binder = Some fun_name; - K.premise_n = Some no; - } - ]; - K.conclude_conclusion = - try Some - (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized - with Not_found -> None - } - } - | C.ACoFix (id,no,funs) -> - let context' = - List.fold_left - (fun ctx (_,n,ty,_) -> - let ty = Deannotate.deannotate_term ty in - Some (Cic.Name n,Cic.Decl ty) :: ctx) - [] funs @ context - in - let proofs = - List.map - (function (_,name,_,bo) -> `Proof (aux context' ~name bo)) funs in - let jo = - { K.joint_id = gen_id joint_prefix seed; - K.joint_kind = `CoRecursive; - K.joint_defs = proofs - } - in - { K.proof_name = name; - K.proof_id = gen_id proof_prefix seed; - K.proof_context = [`Joint jo]; - K.proof_apply_context = []; - K.proof_conclude = - { K.conclude_id = gen_id conclude_prefix seed; - K.conclude_aref = id; - K.conclude_method = "Exact"; - K.conclude_args = - [ K.Premise - { K.premise_id = gen_id premise_prefix seed; - K.premise_xref = jo.K.joint_id; - K.premise_binder = Some "tiralo fuori"; - K.premise_n = Some no; - } - ]; - K.conclude_conclusion = - try Some - (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized - with Not_found -> None - }; - } - in - let id = get_id t in - generate_conversion seed false id t1 ~ids_to_inner_types -in aux ?name context t - -and inductive seed context metasenv name id li ~ids_to_inner_types ~ids_to_inner_sorts = - let aux context ?name = - acic2content seed context metasenv ~ids_to_inner_types ~ids_to_inner_sorts - in - let module C2A = Cic2acic in - let module K = Content in - let module C = Cic in - match li with - C.AConst (idc,uri,exp_named_subst)::args -> - let uri_str = UriManager.string_of_uri uri in - let suffix = Str.regexp_string "_ind.con" in - let len = String.length uri_str in - let n = (try (Str.search_backward suffix uri_str len) - with Not_found -> -1) in - if n<0 then raise NotApplicable - else - let method_name = - if UriManager.eq uri HelmLibraryObjects.Logic.ex_ind_URI then "Exists" - else if UriManager.eq uri HelmLibraryObjects.Logic.and_ind_URI then "AndInd" - else if UriManager.eq uri HelmLibraryObjects.Logic.false_ind_URI then "FalseInd" - else "ByInduction" in - let prefix = String.sub uri_str 0 n in - let ind_str = (prefix ^ ".ind") in - let ind_uri = UriManager.uri_of_string ind_str in - let inductive_types,noparams = - (let o,_ = CicEnvironment.get_obj CicUniv.oblivion_ugraph ind_uri in - match o with - | Cic.InductiveDefinition (l,_,n,_) -> (l,n) - | _ -> assert false - ) in - let rec split n l = - if n = 0 then ([],l) else - let p,a = split (n-1) (List.tl l) in - ((List.hd l::p),a) in - let params_and_IP,tail_args = split (noparams+1) args in - let constructors = - (match inductive_types with - [(_,_,_,l)] -> l - | _ -> raise NotApplicable) (* don't care for mutual ind *) in - let constructors1 = - let rec clean_up n t = - if n = 0 then t else - (match t with - (label,Cic.Prod (_,_,t)) -> clean_up (n-1) (label,t) - | _ -> assert false) in - List.map (clean_up noparams) constructors in - let no_constructors= List.length constructors in - let args_for_cases, other_args = - split no_constructors tail_args in - let subproofs,other_method_args = - build_subproofs_and_args ~headless:true seed context metasenv - other_args ~ids_to_inner_types ~ids_to_inner_sorts in - let method_args= - let rec build_method_args = - function - [],_-> [] (* extra args are ignored ???? *) - | (name,ty)::tlc,arg::tla -> - let idarg = get_id arg in - let sortarg = - (try (Hashtbl.find ids_to_inner_sorts idarg) - with Not_found -> `Type (CicUniv.fresh())) in - let hdarg = - if sortarg = `Prop then - let (co,bo) = - let rec bc context = - function - Cic.Prod (_,s,t),Cic.ALambda(idl,n,s1,t1) -> - let context' = - Some (n,Cic.Decl(Deannotate.deannotate_term s1)) - ::context - in - let ce = - build_decl_item - seed idl n s1 ~ids_to_inner_sorts in - if (occur ind_uri s) then - ( match t1 with - Cic.ALambda(id2,n2,s2,t2) -> - let context'' = - Some - (n2,Cic.Decl - (Deannotate.deannotate_term s2)) - ::context' - in - let inductive_hyp = - `Hypothesis - { K.dec_name = name_of n2; - K.dec_id = - gen_id declaration_prefix seed; - K.dec_inductive = true; - K.dec_aref = id2; - K.dec_type = s2 - } in - let (context,body) = bc context'' (t,t2) in - (ce::inductive_hyp::context,body) - | _ -> assert false) - else - ( - let (context,body) = bc context' (t,t1) in - (ce::context,body)) - | _ , t -> ([],aux context t) in - bc context (ty,arg) in - K.ArgProof - { bo with - K.proof_name = Some name; - K.proof_context = co; - }; - else (K.Term (false,arg)) in - hdarg::(build_method_args (tlc,tla)) - | _ -> assert false in - build_method_args (constructors1,args_for_cases) in - { K.proof_name = name; - K.proof_id = gen_id proof_prefix seed; - K.proof_context = []; - K.proof_apply_context = serialize seed subproofs; - K.proof_conclude = - { K.conclude_id = gen_id conclude_prefix seed; - K.conclude_aref = id; - K.conclude_method = method_name; - K.conclude_args = - K.Aux (string_of_int no_constructors) - ::K.Term (false,(C.AAppl(id,((C.AConst(idc,uri,exp_named_subst))::params_and_IP)))) - ::method_args@other_method_args; - K.conclude_conclusion = - try Some - (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized - with Not_found -> None - } - } - | _ -> raise NotApplicable - -and coercion seed context metasenv id li ~ids_to_inner_types ~ids_to_inner_sorts = - match li with - | ((Cic.AConst _) as he)::tl - | ((Cic.AMutInd _) as he)::tl - | ((Cic.AMutConstruct _) as he)::tl when - (match CoercDb.is_a_coercion (Deannotate.deannotate_term he) with - | None -> false | Some (_,_,_,_,cpos) -> cpos < List.length tl) - && !hide_coercions -> - let cpos,sats = - match CoercDb.is_a_coercion (Deannotate.deannotate_term he) with - | None -> assert false - | Some (_,_,_,sats,cpos) -> cpos, sats - in - let x = List.nth tl cpos in - let _,rest = - try HExtlib.split_nth (cpos + sats +1) tl with Failure _ -> [],[] - in - if rest = [] then - acic2content - seed context metasenv ~ids_to_inner_types ~ids_to_inner_sorts - x - else - acic2content - seed context metasenv ~ids_to_inner_types ~ids_to_inner_sorts - (Cic.AAppl (id,x::rest)) - | _ -> raise NotApplicable - -and rewrite seed context metasenv name id li ~ids_to_inner_types ~ids_to_inner_sorts = - let aux context ?name = - acic2content seed context metasenv ~ids_to_inner_types ~ids_to_inner_sorts - in - let module C2A = Cic2acic in - let module K = Content in - let module C = Cic in - match li with - C.AConst (sid,uri,exp_named_subst)::args -> - if UriManager.eq uri HelmLibraryObjects.Logic.eq_ind_URI or - UriManager.eq uri HelmLibraryObjects.Logic.eq_ind_r_URI or - LibraryObjects.is_eq_ind_URI uri or - LibraryObjects.is_eq_ind_r_URI uri then - let subproofs,arg = - (match - build_subproofs_and_args - seed context metasenv - ~ids_to_inner_types ~ids_to_inner_sorts [List.nth args 3] - with - l,[p] -> l,p - | _,_ -> assert false) in - let method_args = - let rec ma_aux n = function - [] -> [] - | a::tl -> - let hd = - if n = 0 then arg - else - let aid = get_id a in - let asort = (try (Hashtbl.find ids_to_inner_sorts aid) - with Not_found -> `Type (CicUniv.fresh())) in - if asort = `Prop then - K.ArgProof (aux context a) - else K.Term (false,a) in - hd::(ma_aux (n-1) tl) in - (ma_aux 3 args) in - { K.proof_name = name; - K.proof_id = gen_id proof_prefix seed; - K.proof_context = []; - K.proof_apply_context = serialize seed subproofs; - K.proof_conclude = - { K.conclude_id = gen_id conclude_prefix seed; - K.conclude_aref = id; - K.conclude_method = - if UriManager.eq uri HelmLibraryObjects.Logic.eq_ind_URI - || LibraryObjects.is_eq_ind_URI uri then - "RewriteLR" - else - "RewriteRL"; - K.conclude_args = - K.Term (false,(C.AConst (sid,uri,exp_named_subst)))::method_args; - K.conclude_conclusion = - try Some - (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized - with Not_found -> None - } - } - else raise NotApplicable - | _ -> raise NotApplicable - -and transitivity - seed context metasenv name id li ~ids_to_inner_types ~ids_to_inner_sorts -= - let module C2A = Cic2acic in - let module K = Content in - let module C = Cic in - match li with - | C.AConst (sid,uri,exp_named_subst)::args - when LibraryObjects.is_trans_eq_URI uri -> - let exp_args = List.map snd exp_named_subst in - let t1,t2,t3,p1,p2 = - match exp_args@args with - | [_;t1;t2;t3;p1;p2] -> t1,t2,t3,p1,p2 - | _ -> raise NotApplicable - in - { K.proof_name = name; - K.proof_id = gen_id proof_prefix seed; - K.proof_context = []; - K.proof_apply_context = []; - K.proof_conclude = - { K.conclude_id = gen_id conclude_prefix seed; - K.conclude_aref = id; - K.conclude_method = "Eq_chain"; - K.conclude_args = - K.Term (false,t1):: - (transitivity_aux - seed context metasenv ~ids_to_inner_types ~ids_to_inner_sorts p1) - @ [K.Term (false,t2)]@ - (transitivity_aux - seed context metasenv ~ids_to_inner_types ~ids_to_inner_sorts p2) - @ [K.Term (false,t3)]; - K.conclude_conclusion = - try Some - (Hashtbl.find ids_to_inner_types id).C2A.annsynthesized - with Not_found -> None - } - } - | _ -> raise NotApplicable - -and transitivity_aux seed context metasenv ~ids_to_inner_types ~ids_to_inner_sorts t = - let module C2A = Cic2acic in - let module K = Content in - let module C = Cic in - match t with - | C.AAppl (_,C.AConst (sid,uri,exp_named_subst)::args) - when LibraryObjects.is_trans_eq_URI uri -> - let exp_args = List.map snd exp_named_subst in - let t1,t2,t3,p1,p2 = - match exp_args@args with - | [_;t1;t2;t3;p1;p2] -> t1,t2,t3,p1,p2 - | _ -> raise NotApplicable - in - (transitivity_aux - seed context metasenv ~ids_to_inner_types ~ids_to_inner_sorts p1) - @[K.Term (false,t2)] - @(transitivity_aux - seed context metasenv ~ids_to_inner_types ~ids_to_inner_sorts p2) - | _ -> [K.ArgProof - (acic2content seed context metasenv ~ids_to_inner_sorts ~ids_to_inner_types t)] - -;; - - -let map_conjectures - seed ~ids_to_inner_sorts ~ids_to_inner_types (id,n,context,ty) -= - let module K = Content in - let context' = - List.map - (function - (id,None) -> None - | (id,Some (name,Cic.ADecl t)) -> - Some - (* We should call build_decl_item, but we have not computed *) - (* the inner-types ==> we always produce a declaration *) - (`Declaration - { K.dec_name = name_of name; - K.dec_id = gen_id declaration_prefix seed; - K.dec_inductive = false; - K.dec_aref = get_id t; - K.dec_type = t - }) - | (id,Some (name,Cic.ADef (t,ty))) -> - Some - (* We should call build_def_item, but we have not computed *) - (* the inner-types ==> we always produce a declaration *) - (`Definition - { K.def_name = name_of name; - K.def_id = gen_id definition_prefix seed; - K.def_aref = get_id t; - K.def_term = t; - K.def_type = ty - }) - ) context - in - (id,n,context',ty) -;; - -(* map_sequent is similar to map_conjectures, but the for the hid -of the hypothesis, which are preserved instead of generating -fresh ones. We shall have to adopt a uniform policy, soon or later *) - -let map_sequent ((id,n,context,ty):Cic.annconjecture) = - let module K = Content in - let context' = - List.map - (function - (id,None) -> None - | (id,Some (name,Cic.ADecl t)) -> - Some - (* We should call build_decl_item, but we have not computed *) - (* the inner-types ==> we always produce a declaration *) - (`Declaration - { K.dec_name = name_of name; - K.dec_id = id; - K.dec_inductive = false; - K.dec_aref = get_id t; - K.dec_type = t - }) - | (id,Some (name,Cic.ADef (t,ty))) -> - Some - (* We should call build_def_item, but we have not computed *) - (* the inner-types ==> we always produce a declaration *) - (`Definition - { K.def_name = name_of name; - K.def_id = id; - K.def_aref = get_id t; - K.def_term = t; - K.def_type = ty - }) - ) context - in - (id,n,context',ty) -;; - -let rec annobj2content ~ids_to_inner_sorts ~ids_to_inner_types = - let module C = Cic in - let module K = Content in - let module C2A = Cic2acic in - let seed = ref 0 in - function - C.ACurrentProof (_,_,n,conjectures,bo,ty,params,_) -> - (gen_id object_prefix seed, params, - Some - (List.map - (map_conjectures seed ~ids_to_inner_sorts ~ids_to_inner_types) - conjectures), - `Def (K.Const,ty, - build_def_item - seed [] (Deannotate.deannotate_conjectures conjectures) - (get_id bo) (C.Name n) bo ty - ~ids_to_inner_sorts ~ids_to_inner_types)) - | C.AConstant (_,_,n,Some bo,ty,params,_) -> - (gen_id object_prefix seed, params, None, - `Def (K.Const,ty, - build_def_item seed [] [] (get_id bo) (C.Name n) bo ty - ~ids_to_inner_sorts ~ids_to_inner_types)) - | C.AConstant (id,_,n,None,ty,params,_) -> - (gen_id object_prefix seed, params, None, - `Decl (K.Const, - build_decl_item seed id (C.Name n) ty - ~ids_to_inner_sorts)) - | C.AVariable (_,n,Some bo,ty,params,_) -> - (gen_id object_prefix seed, params, None, - `Def (K.Var,ty, - build_def_item seed [] [] (get_id bo) (C.Name n) bo ty - ~ids_to_inner_sorts ~ids_to_inner_types)) - | C.AVariable (id,n,None,ty,params,_) -> - (gen_id object_prefix seed, params, None, - `Decl (K.Var, - build_decl_item seed id (C.Name n) ty - ~ids_to_inner_sorts)) - | C.AInductiveDefinition (id,l,params,nparams,_) -> - (gen_id object_prefix seed, params, None, - `Joint - { K.joint_id = gen_id joint_prefix seed; - K.joint_kind = `Inductive nparams; - K.joint_defs = List.map (build_inductive seed) l - }) - -and - build_inductive seed = - let module K = Content in - fun (_,n,b,ty,l) -> - `Inductive - { K.inductive_id = gen_id inductive_prefix seed; - K.inductive_name = n; - K.inductive_kind = b; - K.inductive_type = ty; - K.inductive_constructors = build_constructors seed l - } - -and - build_constructors seed l = - let module K = Content in - List.map - (fun (n,t) -> - { K.dec_name = Some n; - K.dec_id = gen_id declaration_prefix seed; - K.dec_inductive = false; - K.dec_aref = ""; - K.dec_type = t - }) l -;; - -(* -and 'term cinductiveType = - id * string * bool * 'term * (* typename, inductive, arity *) - 'term cconstructor list (* constructors *) - -and 'term cconstructor = - string * 'term -*) - - diff --git a/matita/components/acic_content/acic2content.mli b/matita/components/acic_content/acic2content.mli deleted file mode 100644 index 32ce68859..000000000 --- a/matita/components/acic_content/acic2content.mli +++ /dev/null @@ -1,36 +0,0 @@ -(* Copyright (C) 2000, 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/. - *) - -val annobj2content : - ids_to_inner_sorts:(Cic.id, Cic2acic.sort_kind) Hashtbl.t -> - ids_to_inner_types:(Cic.id, Cic2acic.anntypes) Hashtbl.t -> - Cic.annobj -> - Cic.annterm Content.cobj - -val map_sequent : - Cic.annconjecture -> Cic.annterm Content.conjecture - -val hide_coercions: bool ref - diff --git a/matita/components/acic_content/content2cic.ml b/matita/components/acic_content/content2cic.ml deleted file mode 100644 index 33c5921fb..000000000 --- a/matita/components/acic_content/content2cic.ml +++ /dev/null @@ -1,275 +0,0 @@ -(* Copyright (C) 2000, 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/. - *) - -(***************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Andrea Asperti *) -(* 17/06/2003 *) -(* *) -(***************************************************************************) - -(* $Id$ *) - -exception TO_DO;; - -let proof2cic deannotate p = - let rec proof2cic premise_env p = - let module C = Cic in - let module Con = Content in - let rec extend_premise_env current_env = - function - [] -> current_env - | p::atl -> - extend_premise_env - ((p.Con.proof_id,(proof2cic current_env p))::current_env) atl in - let new_premise_env = extend_premise_env premise_env p.Con.proof_apply_context in - let body = conclude2cic new_premise_env p.Con.proof_conclude in - context2cic premise_env p.Con.proof_context body - - and context2cic premise_env context body = - List.fold_right (ce2cic premise_env) context body - - and ce2cic premise_env ce target = - let module C = Cic in - let module Con = Content in - match ce with - `Declaration d -> - (match d.Con.dec_name with - Some s -> - C.Lambda (C.Name s, deannotate d.Con.dec_type, target) - | None -> - C.Lambda (C.Anonymous, deannotate d.Con.dec_type, target)) - | `Hypothesis h -> - (match h.Con.dec_name with - Some s -> - C.Lambda (C.Name s, deannotate h.Con.dec_type, target) - | None -> - C.Lambda (C.Anonymous, deannotate h.Con.dec_type, target)) - | `Proof p -> - let ty = - match p.Con.proof_conclude.Con.conclude_conclusion with - None -> (*Cic.Implicit None*) assert false - | Some ty -> deannotate ty - in - (match p.Con.proof_name with - Some s -> - C.LetIn (C.Name s, proof2cic premise_env p, ty , target) - | None -> - C.LetIn (C.Anonymous, proof2cic premise_env p, ty, target)) - | `Definition d -> - (match d.Con.def_name with - Some s -> - C.LetIn (C.Name s, proof2cic premise_env p, deannotate d.Con.def_type, target) - | None -> - C.LetIn (C.Anonymous, proof2cic premise_env p, deannotate d.Con.def_type, target)) - | `Joint {Con.joint_kind = kind; Con.joint_defs = defs} -> - (match target with - C.Rel n -> - (match kind with - `Recursive l -> - let funs = - List.map2 - (fun n bo -> - match bo with - `Proof bo -> - (match - bo.Con.proof_conclude.Con.conclude_conclusion, - bo.Con.proof_name - with - Some ty, Some name -> - (name,n,deannotate ty, - proof2cic premise_env bo) - | _,_ -> assert false) - | _ -> assert false) - l defs in - C.Fix (n, funs) - | `CoRecursive -> - let funs = - List.map - (function bo -> - match bo with - `Proof bo -> - (match - bo.Con.proof_conclude.Con.conclude_conclusion, - bo.Con.proof_name - with - Some ty, Some name -> - (name,deannotate ty, - proof2cic premise_env bo) - | _,_ -> assert false) - | _ -> assert false) - defs in - C.CoFix (n, funs) - | _ -> (* no inductive types in local contexts *) - assert false) - | _ -> assert false) - - and conclude2cic premise_env conclude = - let module C = Cic in - let module Con = Content in - if conclude.Con.conclude_method = "TD_Conversion" then - (match conclude.Con.conclude_args with - [Con.ArgProof p] -> proof2cic [] p (* empty! *) - | _ -> prerr_endline "1"; assert false) - else if conclude.Con.conclude_method = "BU_Conversion" then - (match conclude.Con.conclude_args with - [Con.Premise prem] -> - (try List.assoc prem.Con.premise_xref premise_env - with Not_found -> - prerr_endline - ("Not_found in BU_Conversion: " ^ prem.Con.premise_xref); - raise Not_found) - | _ -> prerr_endline "2"; assert false) - else if conclude.Con.conclude_method = "Exact" then - (match conclude.Con.conclude_args with - [Con.Term (_,t)] -> deannotate t - | [Con.Premise prem] -> - (match prem.Con.premise_n with - None -> assert false - | Some n -> C.Rel n) - | _ -> prerr_endline "3"; assert false) - else if conclude.Con.conclude_method = "Intros+LetTac" then - (match conclude.Con.conclude_args with - [Con.ArgProof p] -> proof2cic [] p (* empty! *) - | _ -> prerr_endline "4"; assert false) - else if (conclude.Con.conclude_method = "ByInduction" || - conclude.Con.conclude_method = "AndInd" || - conclude.Con.conclude_method = "Exists" || - conclude.Con.conclude_method = "FalseInd") then - (match (List.tl conclude.Con.conclude_args) with - Con.Term (_,C.AAppl ( - id,((C.AConst(idc,uri,exp_named_subst))::params_and_IP)))::args -> - let subst = - List.map (fun (u,t) -> (u, deannotate t)) exp_named_subst in - let cargs = args2cic premise_env args in - let cparams_and_IP = List.map deannotate params_and_IP in - C.Appl (C.Const(uri,subst)::cparams_and_IP@cargs) - | _ -> prerr_endline "5"; assert false) - else if (conclude.Con.conclude_method = "Rewrite") then - (match conclude.Con.conclude_args with - Con.Term (_,C.AConst (sid,uri,exp_named_subst))::args -> - let subst = - List.map (fun (u,t) -> (u, deannotate t)) exp_named_subst in - let cargs = args2cic premise_env args in - C.Appl (C.Const(uri,subst)::cargs) - | _ -> prerr_endline "6"; assert false) - else if (conclude.Con.conclude_method = "Case") then - (match conclude.Con.conclude_args with - Con.Aux(uri)::Con.Aux(notype)::Con.Term(_,ty)::Con.Premise(prem)::patterns -> - C.MutCase - (UriManager.uri_of_string uri, - int_of_string notype, deannotate ty, - List.assoc prem.Con.premise_xref premise_env, - List.map - (function - Con.ArgProof p -> proof2cic [] p - | _ -> prerr_endline "7a"; assert false) patterns) - | Con.Aux(uri)::Con.Aux(notype)::Con.Term(_,ty)::Con.Term(_,te)::patterns -> C.MutCase - (UriManager.uri_of_string uri, - int_of_string notype, deannotate ty, deannotate te, - List.map - (function - (Con.ArgProof p) -> proof2cic [] p - | _ -> prerr_endline "7a"; assert false) patterns) - | _ -> (prerr_endline "7"; assert false)) - else if (conclude.Con.conclude_method = "Apply") then - let cargs = (args2cic premise_env conclude.Con.conclude_args) in - C.Appl cargs - else (prerr_endline "8"; assert false) - - and args2cic premise_env l = - List.map (arg2cic premise_env) l - - and arg2cic premise_env = - let module C = Cic in - let module Con = Content in - function - Con.Aux n -> prerr_endline "8"; assert false - | Con.Premise prem -> - (match prem.Con.premise_n with - Some n -> C.Rel n - | None -> - (try List.assoc prem.Con.premise_xref premise_env - with Not_found -> - prerr_endline ("Not_found in arg2cic: premise " ^ (match prem.Con.premise_binder with None -> "previous" | Some p -> p) ^ ", xref=" ^ prem.Con.premise_xref); - raise Not_found)) - | Con.Lemma lemma -> - CicUtil.term_of_uri (UriManager.uri_of_string lemma.Con.lemma_uri) - | Con.Term (_,t) -> deannotate t - | Con.ArgProof p -> proof2cic [] p (* empty! *) - | Con.ArgMethod s -> raise TO_DO - -in proof2cic [] p -;; - -exception ToDo;; - -let cobj2obj deannotate (id,params,metasenv,obj) = - let module K = Content in - match obj with - `Def (Content.Const,ty,`Proof bo) -> - (match metasenv with - None -> - Cic.Constant - (id, Some (proof2cic deannotate bo), deannotate ty, params, []) - | Some metasenv' -> - let metasenv'' = - List.map - (function (_,i,canonical_context,term) -> - let canonical_context' = - List.map - (function - None -> None - | Some (`Declaration d) - | Some (`Hypothesis d) -> - (match d with - {K.dec_name = Some n ; K.dec_type = t} -> - Some (Cic.Name n, Cic.Decl (deannotate t)) - | _ -> assert false) - | Some (`Definition d) -> - (match d with - {K.def_name = Some n ; K.def_term = t ; K.def_type = ty} -> - Some (Cic.Name n, Cic.Def (deannotate t,deannotate ty)) - | _ -> assert false) - | Some (`Proof d) -> - (match d with - {K.proof_name = Some n } -> - Some (Cic.Name n, - Cic.Def ((proof2cic deannotate d),assert false)) - | _ -> assert false) - ) canonical_context - in - (i,canonical_context',deannotate term) - ) metasenv' - in - Cic.CurrentProof - (id, metasenv'', proof2cic deannotate bo, deannotate ty, params, - [])) - | _ -> raise ToDo -;; - -let cobj2obj = cobj2obj Deannotate.deannotate_term;; diff --git a/matita/components/acic_content/content2cic.mli b/matita/components/acic_content/content2cic.mli deleted file mode 100644 index 9bb6509cc..000000000 --- a/matita/components/acic_content/content2cic.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* Copyright (C) 2000, 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/. - *) - -(**************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Andrea Asperti *) -(* 27/6/2003 *) -(* *) -(**************************************************************************) - -val cobj2obj : Cic.annterm Content.cobj -> Cic.obj diff --git a/matita/components/acic_content/termAcicContent.ml b/matita/components/acic_content/termAcicContent.ml index 6eeb45749..599a0704e 100644 --- a/matita/components/acic_content/termAcicContent.ml +++ b/matita/components/acic_content/termAcicContent.ml @@ -42,35 +42,6 @@ type term_info = uri: (Cic.id, UriManager.uri) Hashtbl.t; } -let get_types uri = - let o,_ = CicEnvironment.get_obj CicUniv.oblivion_ugraph uri in - match o with - | Cic.InductiveDefinition (l,_,lpsno,_) -> l, lpsno - | _ -> assert false - -let name_of_inductive_type uri i = - let types, _ = get_types uri in - let (name, _, _, _) = try List.nth types i with Not_found -> assert false in - name - - (* returns pairs *) -let constructors_of_inductive_type uri i = - let types, _ = get_types uri in - let (_, _, _, constructors) = - try List.nth types i with Not_found -> assert false - in - constructors - - (* returns name only *) -let constructor_of_inductive_type uri i j = - (try - fst (List.nth (constructors_of_inductive_type uri i) (j-1)) - with Not_found -> assert false) - - (* returns the number of left parameters *) -let left_params_no_of_inductive_type uri = - snd (get_types uri) - let destroy_nat annterm = let is_zero = function | Cic.AMutConstruct (_, uri, 0, 1, _) when Obj.is_nat_URI uri -> true @@ -86,215 +57,6 @@ let destroy_nat annterm = | _ -> None in aux 0 annterm -let ast_of_acic0 ~output_type term_info acic k = - let k = k term_info in - let id_to_uris = term_info.uri in - let register_uri id uri = Hashtbl.add id_to_uris id uri in - let sort_of_id id = - try - Hashtbl.find term_info.sort id - with Not_found -> - prerr_endline (sprintf "warning: sort of id %s not found, using Type" id); - `Type (CicUniv.fresh ()) - in - let aux_substs substs = - Some - (List.map - (fun (uri, annterm) -> (UriManager.name_of_uri uri, k annterm)) - substs) - in - let aux_context context = - List.map - (function - | None -> None - | Some annterm -> Some (k annterm)) - context - in - let aux = function - | Cic.ARel (id,_,_,b) -> idref id (Ast.Ident (b, None)) - | Cic.AVar (id,uri,substs) -> - register_uri id uri; - idref id (Ast.Ident (UriManager.name_of_uri uri, aux_substs substs)) - | Cic.AMeta (id,n,l) -> idref id (Ast.Meta (n, aux_context l)) - | Cic.ASort (id,Cic.Prop) -> idref id (Ast.Sort `Prop) - | Cic.ASort (id,Cic.Set) -> idref id (Ast.Sort `Set) - | Cic.ASort (id,Cic.Type u) -> idref id (Ast.Sort (`Type u)) - | Cic.ASort (id,Cic.CProp u) -> idref id (Ast.Sort (`CProp u)) - | Cic.AImplicit (id, Some `Hole) -> idref id Ast.UserInput - | Cic.AImplicit (id, _) -> idref id (Ast.Implicit `JustOne) - | Cic.AProd (id,n,s,t) -> - let binder_kind = - match sort_of_id id with - | `Set | `Type _ | `NType _ -> `Pi - | `Prop | `CProp _ | `NCProp _ -> `Forall - in - idref id (Ast.Binder (binder_kind, - (CicNotationUtil.name_of_cic_name n, Some (k s)), k t)) - | Cic.ACast (id,v,t) -> idref id (Ast.Cast (k v, k t)) - | Cic.ALambda (id,n,s,t) -> - idref id (Ast.Binder (`Lambda, - (CicNotationUtil.name_of_cic_name n, Some (k s)), k t)) - | Cic.ALetIn (id,n,s,ty,t) -> - idref id (Ast.LetIn ((CicNotationUtil.name_of_cic_name n, Some (k ty)), - k s, k t)) - | Cic.AAppl (aid,(Cic.AConst _ as he::tl as args)) - | Cic.AAppl (aid,(Cic.AMutInd _ as he::tl as args)) - | Cic.AAppl (aid,(Cic.AMutConstruct _ as he::tl as args)) as t -> - (match destroy_nat t with - | Some n -> idref aid (Ast.Num (string_of_int n, -1)) - | None -> - let deannot_he = Deannotate.deannotate_term he in - let coercion_info = CoercDb.is_a_coercion deannot_he in - if coercion_info <> None && !Acic2content.hide_coercions then - match coercion_info with - | None -> assert false - | Some (_,_,_,sats,cpos) -> - if cpos < List.length tl then - let _,rest = - try HExtlib.split_nth (cpos+sats+1) tl with Failure _ -> [],[] - in - if rest = [] then - idref aid (k (List.nth tl cpos)) - else - idref aid (Ast.Appl (List.map k (List.nth tl cpos::rest))) - else - idref aid (Ast.Appl (List.map k args)) - else - idref aid (Ast.Appl (List.map k args))) - | Cic.AAppl (aid,args) -> - idref aid (Ast.Appl (List.map k args)) - | Cic.AConst (id,uri,substs) -> - register_uri id uri; - idref id (Ast.Ident (UriManager.name_of_uri uri, aux_substs substs)) - | Cic.AMutInd (id,uri,i,substs) -> - let name = name_of_inductive_type uri i in - let uri_str = UriManager.string_of_uri uri in - let puri_str = sprintf "%s#xpointer(1/%d)" uri_str (i+1) in - register_uri id (UriManager.uri_of_string puri_str); - idref id (Ast.Ident (name, aux_substs substs)) - | Cic.AMutConstruct (id,uri,i,j,substs) -> - let name = constructor_of_inductive_type uri i j in - let uri_str = UriManager.string_of_uri uri in - let puri_str = sprintf "%s#xpointer(1/%d/%d)" uri_str (i + 1) j in - register_uri id (UriManager.uri_of_string puri_str); - idref id (Ast.Ident (name, aux_substs substs)) - | Cic.AMutCase (id,uri,typeno,ty,te,patterns) -> - let name = name_of_inductive_type uri typeno in - let uri_str = UriManager.string_of_uri uri in - let puri_str = sprintf "%s#xpointer(1/%d)" uri_str (typeno+1) in - let ctor_puri j = - UriManager.uri_of_string - (sprintf "%s#xpointer(1/%d/%d)" uri_str (typeno+1) j) - in - let case_indty = name, Some (UriManager.uri_of_string puri_str) in - let constructors = constructors_of_inductive_type uri typeno in - let lpsno = left_params_no_of_inductive_type uri in - let rec eat_branch n ty pat = - match (ty, pat) with - | Cic.Prod (_, _, t), _ when n > 0 -> eat_branch (pred n) t pat - | Cic.Prod (_, _, t), Cic.ALambda (_, name, s, t') -> - let (cv, rhs) = eat_branch 0 t t' in - (CicNotationUtil.name_of_cic_name name, Some (k s)) :: cv, rhs - | _, _ -> [], k pat - in - let j = ref 0 in - let patterns = - try - List.map2 - (fun (name, ty) pat -> - incr j; - let name,(capture_variables,rhs) = - match output_type with - `Term -> name, eat_branch lpsno ty pat - | `Pattern -> "_", ([], k pat) - in - Ast.Pattern (name, Some (ctor_puri !j), capture_variables), rhs - ) constructors patterns - with Invalid_argument _ -> assert false - in - let indty = - match output_type with - `Pattern -> None - | `Term -> Some case_indty - in - idref id (Ast.Case (k te, indty, Some (k ty), patterns)) - | Cic.AFix (id, no, funs) -> - let defs = - List.map - (fun (_, n, decr_idx, ty, bo) -> - let params,bo = - let rec aux = - function - Cic.ALambda (_,name,so,ta) -> - let params,rest = aux ta in - (CicNotationUtil.name_of_cic_name name,Some (k so)):: - params, rest - | t -> [],t - in - aux bo - in - let ty = - let rec eat_pis = - function - 0,ty -> ty - | n,Cic.AProd (_,_,_,ta) -> eat_pis (n - 1,ta) - | n,ty -> - (* I should do a whd here, but I have no context *) - assert false - in - eat_pis ((List.length params),ty) - in - (params,(Ast.Ident (n, None), Some (k ty)), k bo, decr_idx)) - funs - in - let name = - try - (match List.nth defs no with - | _, (Ast.Ident (n, _), _), _, _ when n <> "_" -> n - | _ -> assert false) - with Not_found -> assert false - in - idref id (Ast.LetRec (`Inductive, defs, Ast.Ident (name, None))) - | Cic.ACoFix (id, no, funs) -> - let defs = - List.map - (fun (_, n, ty, bo) -> - let params,bo = - let rec aux = - function - Cic.ALambda (_,name,so,ta) -> - let params,rest = aux ta in - (CicNotationUtil.name_of_cic_name name,Some (k so)):: - params, rest - | t -> [],t - in - aux bo - in - let ty = - let rec eat_pis = - function - 0,ty -> ty - | n,Cic.AProd (_,_,_,ta) -> eat_pis (n - 1,ta) - | n,ty -> - (* I should do a whd here, but I have no context *) - assert false - in - eat_pis ((List.length params),ty) - in - (params,(Ast.Ident (n, None), Some (k ty)), k bo, 0)) - funs - in - let name = - try - (match List.nth defs no with - | _, (Ast.Ident (n, _), _), _, _ when n <> "_" -> n - | _ -> assert false) - with Not_found -> assert false - in - idref id (Ast.LetRec (`CoInductive, defs, Ast.Ident (name, None))) - in - aux acic - (* persistent state *) let initial_level2_patterns32 () = Hashtbl.create 211 @@ -303,7 +65,6 @@ let initial_interpretations () = Hashtbl.create 211 let level2_patterns32 = ref (initial_level2_patterns32 ()) (* symb -> id list ref *) let interpretations = ref (initial_interpretations ()) -let compiled32 = ref None let pattern32_matrix = ref [] let counter = ref ~-1 let find_level2_patterns32 pid = Hashtbl.find !level2_patterns32 pid;; @@ -311,33 +72,24 @@ let find_level2_patterns32 pid = Hashtbl.find !level2_patterns32 pid;; let stack = ref [] let push () = - stack := (!counter,!level2_patterns32,!interpretations,!compiled32,!pattern32_matrix)::!stack; + stack := (!counter,!level2_patterns32,!interpretations,!pattern32_matrix)::!stack; counter := ~-1; level2_patterns32 := initial_level2_patterns32 (); interpretations := initial_interpretations (); - compiled32 := None; pattern32_matrix := [] ;; let pop () = match !stack with [] -> assert false - | (ocounter,olevel2_patterns32,ointerpretations,ocompiled32,opattern32_matrix)::old -> + | (ocounter,olevel2_patterns32,ointerpretations,opattern32_matrix)::old -> stack := old; counter := ocounter; level2_patterns32 := olevel2_patterns32; interpretations := ointerpretations; - compiled32 := ocompiled32; pattern32_matrix := opattern32_matrix ;; -let get_compiled32 () = - match !compiled32 with - | None -> assert false - | Some f -> Lazy.force f - -let set_compiled32 f = compiled32 := Some f - let add_idrefs = List.fold_right (fun idref t -> Ast.AttributedTerm (`IdRef idref, t)) @@ -371,56 +123,9 @@ let instantiate32 term_info idrefs env symbol args = if args = [] then head else Ast.Appl (head :: List.map instantiate_arg args) -let rec ast_of_acic1 ~output_type term_info annterm = - let id_to_uris = term_info.uri in - let register_uri id uri = Hashtbl.add id_to_uris id uri in - match (get_compiled32 ()) annterm with - | None -> - ast_of_acic0 ~output_type term_info annterm (ast_of_acic1 ~output_type) - | Some (env, ctors, pid) -> - let idrefs = - List.map - (fun annterm -> - let idref = CicUtil.id_of_annterm annterm in - (try - register_uri idref - (CicUtil.uri_of_term (Deannotate.deannotate_term annterm)) - with Invalid_argument _ -> ()); - idref) - ctors - in - let env' = - List.map - (fun (name, term) -> name, ast_of_acic1 ~output_type term_info term) env - in - let _, symbol, args, _ = - try - find_level2_patterns32 pid - with Not_found -> assert false - in - let ast = instantiate32 term_info idrefs env' symbol args in - Ast.AttributedTerm (`IdRef (CicUtil.id_of_annterm annterm), ast) - -let load_patterns32s = - let load_patterns32 t = - let t = - HExtlib.filter_map (function (true, ap, id) -> Some (ap, id) | _ -> None) t - in - set_compiled32 (lazy (Acic2astMatcher.Matcher32.compiler t)) - in - ref [load_patterns32] -;; +let load_patterns32s = ref [];; let add_load_patterns32 f = load_patterns32s := f :: !load_patterns32s;; - -let ast_of_acic ~output_type id_to_sort annterm = - debug_print (lazy ("ast_of_acic <- " - ^ CicPp.ppterm (Deannotate.deannotate_term annterm))); - let term_info = { sort = id_to_sort; uri = Hashtbl.create 211 } in - let ast = ast_of_acic1 ~output_type term_info annterm in - debug_print (lazy ("ast_of_acic -> " ^ CicNotationPp.pp_term ast)); - ast, term_info.uri - let fresh_id = fun () -> incr counter; diff --git a/matita/components/acic_content/termAcicContent.mli b/matita/components/acic_content/termAcicContent.mli index bf6ee6a93..f7ac8ccc6 100644 --- a/matita/components/acic_content/termAcicContent.mli +++ b/matita/components/acic_content/termAcicContent.mli @@ -51,15 +51,6 @@ val get_all_interpretations: unit -> (interpretation_id * string) list val get_active_interpretations: unit -> interpretation_id list val set_active_interpretations: interpretation_id list -> unit - (** {2 acic -> content} *) - -val ast_of_acic: - output_type:[`Pattern|`Term] -> - (Cic.id, CicNotationPt.sort_kind) Hashtbl.t -> (* id -> sort *) - Cic.annterm -> (* acic *) - CicNotationPt.term (* ast *) - * (Cic.id, UriManager.uri) Hashtbl.t (* id -> uri *) - (** {2 content -> acic} *) (** @param env environment from argument_pattern to cic terms diff --git a/matita/components/binaries/Makefile b/matita/components/binaries/Makefile index cd732517c..7966f3a61 100644 --- a/matita/components/binaries/Makefile +++ b/matita/components/binaries/Makefile @@ -3,7 +3,7 @@ H=@ #CSC: saturate is broken after the huge refactoring of auto/paramodulation #CSC: by Andrea #BINARIES=extractor table_creator utilities saturate -BINARIES=extractor table_creator utilities transcript heights +BINARIES=transcript heights all: $(BINARIES:%=rec@all@%) opt: $(BINARIES:%=rec@opt@%) diff --git a/matita/components/binaries/extractor/.depend b/matita/components/binaries/extractor/.depend deleted file mode 100644 index 0c39328ae..000000000 --- a/matita/components/binaries/extractor/.depend +++ /dev/null @@ -1,4 +0,0 @@ -extractor.cmo: -extractor.cmx: -extractor_manager.cmo: -extractor_manager.cmx: diff --git a/matita/components/binaries/extractor/.depend.opt b/matita/components/binaries/extractor/.depend.opt deleted file mode 100644 index 0c39328ae..000000000 --- a/matita/components/binaries/extractor/.depend.opt +++ /dev/null @@ -1,4 +0,0 @@ -extractor.cmo: -extractor.cmx: -extractor_manager.cmo: -extractor_manager.cmx: diff --git a/matita/components/binaries/extractor/Makefile b/matita/components/binaries/extractor/Makefile deleted file mode 100644 index 512b13e73..000000000 --- a/matita/components/binaries/extractor/Makefile +++ /dev/null @@ -1,55 +0,0 @@ -H=@ - -all: extractor extractor_manager - $(H)echo -n -opt: extractor.opt extractor_manager.opt - $(H)echo -n - -clean: - rm -f *.cm[ixo] *.[ao] extractor extractor.opt *.err *.out extractor_manager extractor_manager.opt - -extractor: extractor.ml - $(H)echo " OCAMLC $<" - $(H)$(OCAMLFIND) ocamlc \ - -thread -package mysql,helm-metadata,helm-library -linkpkg -rectypes -o $@ $< - -extractor.opt: extractor.ml - $(H)echo " OCAMLOPT $<" - $(H)$(OCAMLFIND) ocamlopt \ - -thread -package mysql,helm-metadata,helm-library -linkpkg -rectypes -o $@ $< - -extractor_manager: extractor_manager.ml - $(H)echo " OCAMLC $<" - $(H)$(OCAMLFIND) ocamlc \ - -thread -package mysql,helm-metadata,helm-library -linkpkg -rectypes -o $@ $< - -extractor_manager.opt: extractor_manager.ml - $(H)echo " OCAMLOPT $<" - $(H)$(OCAMLFIND) ocamlopt \ - -thread -package mysql,helm-metadata,helm-library -linkpkg -rectypes -o $@ $< - -export: extractor.opt extractor_manager.opt - nice -n 20 \ - time \ - ./extractor_manager.opt 1>export.out 2>export.err - -depend: - $(H)echo " OCAMLDEP" - $(H)ocamldep extractor.ml extractor_manager.ml > .depend -depend.opt: - $(H)echo " OCAMLDEP -native" - $(H)ocamldep -native extractor.ml extractor_manager.ml > .depend.opt - -ifeq ($(MAKECMDGOALS),) - include .depend -endif - -ifeq ($(MAKECMDGOALS), all) - include .depend -endif - -ifeq ($(MAKECMDGOALS), opt) - include .depend.opt -endif - -include ../../../Makefile.defs diff --git a/matita/components/binaries/extractor/extractor.conf.xml b/matita/components/binaries/extractor/extractor.conf.xml deleted file mode 100644 index d82b16028..000000000 --- a/matita/components/binaries/extractor/extractor.conf.xml +++ /dev/null @@ -1,18 +0,0 @@ - - -
- .tmp/ -
-
- mysql://mowgli.cs.unibo.it mowgli helm helm library - file:///tmp/ user.db helm helm user -
-
- - file:///projects/helm/library/coq_contribs - - $(tmp.dir)/cache - $(tmp.dir)/maps - /projects/helm/xml/dtd -
- diff --git a/matita/components/binaries/extractor/extractor.ml b/matita/components/binaries/extractor/extractor.ml deleted file mode 100644 index 981900c3c..000000000 --- a/matita/components/binaries/extractor/extractor.ml +++ /dev/null @@ -1,75 +0,0 @@ -let _ = Helm_registry.load_from "extractor.conf.xml" - -let usage () = - prerr_endline " - -!! This binary should not be called by hand, use the extractor_manager. !! - -usage: ./extractor[.opt] path owner - -path: the path for the getter maps -owner: the owner of the tables to update - -" - -let _ = - try - let _ = Sys.argv.(2), Sys.argv.(1) in - if Sys.argv.(1) = "-h"||Sys.argv.(1) = "-help"||Sys.argv.(1) = "--help" then - begin - usage (); - exit 1 - end - with - Invalid_argument _ -> usage (); exit 1 - -let owner = Sys.argv.(2) -let path = Sys.argv.(1) - -let main () = - print_endline (Printf.sprintf "%d alive on path:%s owner:%s" - (Unix.getpid()) path owner); - Helm_registry.load_from "extractor.conf.xml"; - Helm_registry.set "tmp.dir" path; - Http_getter.init (); - let dbspec = LibraryDb.parse_dbd_conf () in - let dbd = HSql.quick_connect dbspec in - MetadataTypes.ownerize_tables owner; - let uris = - let ic = open_in (path ^ "/todo") in - let acc = ref [] in - (try - while true do - let l = input_line ic in - acc := l :: !acc - done - with - End_of_file -> ()); - close_in ic; - !acc - in - let len = float_of_int (List.length uris) in - let i = ref 0 in - let magic = 45 in - List.iter (fun u -> - incr i; - let perc = ((float_of_int !i) /. len *. 100.0) in - let l = String.length u in - let short = - if l < magic then - u ^ String.make (magic + 3 - l) ' ' - else - "..." ^ String.sub u (l - magic) magic - in - Printf.printf "%d (%d of %.0f = %3.1f%%): %s\n" - (Unix.getpid ()) !i len perc short; - flush stdout; - let uri = UriManager.uri_of_string u in - MetadataDb.index_obj ~dbd ~uri; - CicEnvironment.empty ()) - uris; - print_string "END "; Unix.system "date" -;; - -main () - diff --git a/matita/components/binaries/extractor/extractor_manager.ml b/matita/components/binaries/extractor/extractor_manager.ml deleted file mode 100644 index 13e92777f..000000000 --- a/matita/components/binaries/extractor/extractor_manager.ml +++ /dev/null @@ -1,295 +0,0 @@ -(* Copyright (C) 2004-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/ - *) - -(* HELPERS *) - -let create_all dbd = - let obj_tbl = MetadataTypes.obj_tbl () in - let sort_tbl = MetadataTypes.sort_tbl () in - let rel_tbl = MetadataTypes.rel_tbl () in - let name_tbl = MetadataTypes.name_tbl () in - let count_tbl = MetadataTypes.count_tbl () in - let tbls = [ - (obj_tbl,`RefObj) ; (sort_tbl,`RefSort) ; (rel_tbl,`RefRel) ; - (name_tbl,`ObjectName) ; (count_tbl,`Count) ] - in - let statements = - (SqlStatements.create_tables tbls) @ - (SqlStatements.create_indexes tbls) - in - List.iter (fun statement -> - try - ignore (HSql.exec HSql.Library dbd statement) - with - HSql.Error _ as exn -> - match HSql.errno HSql.Library dbd with - | HSql.Table_exists_error -> () - | HSql.OK -> () - | _ -> raise exn - ) statements - -let drop_all dbd = - let obj_tbl = MetadataTypes.obj_tbl () in - let sort_tbl = MetadataTypes.sort_tbl () in - let rel_tbl = MetadataTypes.rel_tbl () in - let name_tbl = MetadataTypes.name_tbl () in - let count_tbl = MetadataTypes.count_tbl () in - let tbls = [ - (obj_tbl,`RefObj) ; (sort_tbl,`RefSort) ; (rel_tbl,`RefRel) ; - (name_tbl,`ObjectName) ; (count_tbl,`Count) ] - in - let statements = - (SqlStatements.drop_tables tbls) @ - (SqlStatements.drop_indexes tbls HSql.Library dbd) - in - List.iter (fun statement -> - try - ignore (HSql.exec HSql.Library dbd statement) - with HSql.Error _ as exn -> - match HSql.errno HSql.Library dbd with - | HSql.Bad_table_error - | HSql.No_such_index | HSql.No_such_table -> () - | _ -> raise exn - ) statements - -let slash_RE = Str.regexp "/" - -let partition l = - let l = List.fast_sort Pervasives.compare l in - let matches s1 s2 = - let l1,l2 = Str.split slash_RE s1, Str.split slash_RE s2 in - match l1,l2 with - | _::x::_,_::y::_ -> x = y - | _ -> false - in - let rec chunk l = - match l with - | [] -> [],[] - | h::(h1::tl as rest) when matches h h1 -> - let ch,todo = chunk rest in - (h::ch),todo - | h::(h1::tl as rest)-> [h],rest - | h::_ -> [h],[] - in - let rec split l = - let ch, todo = chunk l in - match todo with - | [] -> [ch] - | _ -> ch :: split todo - in - split l - - -(* ARGV PARSING *) - -let _ = - try - if Sys.argv.(1) = "-h"||Sys.argv.(1) = "-help"||Sys.argv.(1) = "--help" then - begin - prerr_endline " -usage: ./extractor_manager[.opt] [processes] [owner] - -defaults: - processes = 2 - owner = NEW - -"; - exit 1 - end - with Invalid_argument _ -> () - -let processes = - try - int_of_string (Sys.argv.(1)) - with - Invalid_argument _ -> 2 - -let owner = - try - Sys.argv.(2) - with Invalid_argument _ -> "NEW" - -let create_peons i = - let rec aux = function - | 0 -> [] - | n -> (n,0) :: aux (n-1) - in - ref (aux i) - -let is_a_peon_idle peons = - List.exists (fun (_,x) -> x = 0) !peons - -let get_ide_peon peons = - let p = fst(List.find (fun (_,x) -> x = 0) !peons) in - peons := List.filter (fun (x,_) -> x <> p) !peons; - p - -let assign_peon peon pid peons = - peons := (peon,pid) :: !peons - -let wait_a_peon peons = - let pid,status = Unix.wait () in - (match status with - | Unix.WEXITED 0 -> () - | Unix.WEXITED s -> - prerr_endline (Printf.sprintf "PEON %d EXIT STATUS %d" pid s) - | Unix.WSIGNALED s -> - prerr_endline - (Printf.sprintf "PEON %d HAD A PROBLEM, KILLED BY SIGNAL %d" pid s) - | Unix.WSTOPPED s -> - prerr_endline - (Printf.sprintf "PEON %d HAD A PROBLEM, STOPPED BY %d" pid s)); - let p = fst(List.find (fun (_,x) -> x = pid) !peons) in - peons := List.filter (fun (x,_) -> x <> p) !peons; - peons := (p,0) :: !peons - -let is_a_peon_busy peons = - List.exists (fun (_,x) -> x <> 0) !peons - -(* MAIN *) -let main () = - Helm_registry.load_from "extractor.conf.xml"; - Http_getter.init (); - print_endline "Updating the getter...."; - let base = (Helm_registry.get "tmp.dir") ^ "/maps" in - let formats i = - (Helm_registry.get "tmp.dir") ^ "/"^(string_of_int i)^"/maps" - in - for i = 1 to processes do - let fmt = formats i in - ignore(Unix.system ("rm -rf " ^ fmt)); - ignore(Unix.system ("mkdir -p " ^ fmt)); - ignore(Unix.system ("cp -r " ^ base ^ " " ^ fmt ^ "/../")); - done; - let dbspec = LibraryDb.parse_dbd_conf () in - let dbd = HSql.quick_connect dbspec in - MetadataTypes.ownerize_tables owner; - let uri_RE = Str.regexp ".*\\(ind\\|var\\|con\\)$" in - drop_all dbd; - create_all dbd; - let uris = Http_getter.getalluris () in - let uris = List.filter (fun u -> Str.string_match uri_RE u 0) uris in - let todo = partition uris in - let cur = ref 0 in - let tot = List.length todo in - let peons = create_peons processes in - print_string "START "; flush stdout; - ignore(Unix.system "date"); - while !cur < tot do - if is_a_peon_idle peons then - let peon = get_ide_peon peons in - let fmt = formats peon in - let oc = open_out (fmt ^ "/../todo") in - List.iter (fun s -> output_string oc (s^"\n")) (List.nth todo !cur); - close_out oc; - let pid = Unix.fork () in - if pid = 0 then - Unix.execv - "./extractor.opt" [| "./extractor.opt" ; fmt ^ "/../" ; owner|] - else - begin - assign_peon peon pid peons; - incr cur - end - else - wait_a_peon peons - done; - while is_a_peon_busy peons do wait_a_peon peons done; - print_string "END "; flush stdout; - ignore(Unix.system "date"); - (* and now the rename table stuff *) - let obj_tbl = MetadataTypes.library_obj_tbl in - let sort_tbl = MetadataTypes.library_sort_tbl in - let rel_tbl = MetadataTypes.library_rel_tbl in - let name_tbl = MetadataTypes.library_name_tbl in - let count_tbl = MetadataTypes.library_count_tbl in - let hits_tbl = MetadataTypes.library_hits_tbl in - let obj_tbl_b = obj_tbl ^ "_BACKUP" in - let sort_tbl_b = sort_tbl ^ "_BACKUP" in - let rel_tbl_b = rel_tbl ^ "_BACKUP" in - let name_tbl_b = name_tbl ^ "_BACKUP" in - let count_tbl_b = count_tbl ^ "_BACKUP" in - let obj_tbl_c = MetadataTypes.obj_tbl () in - let sort_tbl_c = MetadataTypes.sort_tbl () in - let rel_tbl_c = MetadataTypes.rel_tbl () in - let name_tbl_c = MetadataTypes.name_tbl () in - let count_tbl_c = MetadataTypes.count_tbl () in - let stats = - SqlStatements.drop_tables [ - (obj_tbl_b,`RefObj); - (sort_tbl_b,`RefSort); - (rel_tbl_b,`RefRel); - (name_tbl_b,`ObjectName); - (count_tbl_b,`Count); - (hits_tbl,`Hits) ] @ - SqlStatements.drop_indexes [ - (obj_tbl,`RefObj); - (sort_tbl,`RefSort); - (rel_tbl,`RefRel); - (name_tbl,`ObjectName); - (count_tbl,`Count); - (obj_tbl_c,`RefObj); - (sort_tbl_c,`RefSort); - (rel_tbl_c,`RefRel); - (name_tbl_c,`ObjectName); - (count_tbl_c,`Count); - (hits_tbl,`Hits) ] HSql.Library dbd @ - SqlStatements.rename_tables [ - (obj_tbl,obj_tbl_b); - (sort_tbl,sort_tbl_b); - (rel_tbl,rel_tbl_b); - (name_tbl,name_tbl_b); - (count_tbl,count_tbl_b) ] @ - SqlStatements.rename_tables [ - (obj_tbl_c,obj_tbl); - (sort_tbl_c,sort_tbl); - (rel_tbl_c,rel_tbl); - (name_tbl_c,name_tbl); - (count_tbl_c,count_tbl) ] @ - SqlStatements.create_tables [ - (hits_tbl,`Hits) ] @ - SqlStatements.fill_hits obj_tbl hits_tbl @ - SqlStatements.create_indexes [ - (obj_tbl,`RefObj); - (sort_tbl,`RefSort); - (rel_tbl,`RefRel); - (name_tbl,`ObjectName); - (count_tbl,`Count); - (hits_tbl,`Hits) ] - in - List.iter (fun statement -> - try - ignore (HSql.exec HSql.Library dbd statement) - with HSql.Error _ as exn -> - match HSql.errno HSql.Library dbd with - | HSql.Table_exists_error - | HSql.Bad_table_error -> () - | _ -> - prerr_endline (Printexc.to_string exn); - raise exn) - stats -;; - -main () diff --git a/matita/components/binaries/table_creator/.depend b/matita/components/binaries/table_creator/.depend deleted file mode 100644 index 33147b949..000000000 --- a/matita/components/binaries/table_creator/.depend +++ /dev/null @@ -1,2 +0,0 @@ -table_creator.cmo: -table_creator.cmx: diff --git a/matita/components/binaries/table_creator/.depend.opt b/matita/components/binaries/table_creator/.depend.opt deleted file mode 100644 index 33147b949..000000000 --- a/matita/components/binaries/table_creator/.depend.opt +++ /dev/null @@ -1,2 +0,0 @@ -table_creator.cmo: -table_creator.cmx: diff --git a/matita/components/binaries/table_creator/Makefile b/matita/components/binaries/table_creator/Makefile deleted file mode 100644 index d5889699f..000000000 --- a/matita/components/binaries/table_creator/Makefile +++ /dev/null @@ -1,56 +0,0 @@ -H=@ - -REQUIRES = mysql helm-metadata - -INTERFACE_FILES = -IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) -EXTRA_OBJECTS_TO_INSTALL = -EXTRA_OBJECTS_TO_CLEAN = \ - table_creator table_creator.opt table_destructor table_destructor.opt - -all: table_creator table_destructor - $(H)echo -n -opt: table_creator.opt table_destructor.opt - $(H)echo -n - -table_creator: table_creator.ml - $(H)echo " OCAMLC $<" - $(H)$(OCAMLFIND) ocamlc \ - -thread -package mysql,helm-metadata -linkpkg -rectypes -o $@ $< - -table_destructor: table_creator - $(H)ln -f $< $@ - -table_creator.opt: table_creator.ml - $(H)echo " OCAMLOPT $<" - $(H)$(OCAMLFIND) ocamlopt \ - -thread -package mysql,helm-metadata -linkpkg -rectypes -o $@ $< - -table_destructor.opt: table_creator.opt - $(H)ln -f $< $@ - -clean: - $(H)rm -f *.cm[iox] *.a *.o - $(H)rm -f table_creator table_creator.opt \ - table_destructor table_destructor.opt - -depend: - $(H)echo " OCAMLDEP" - $(H)ocamldep table_creator.ml > .depend -depend.opt: - $(H)echo " OCAMLDEP -native" - $(H)ocamldep -native table_creator.ml > .depend.opt - -ifeq ($(MAKECMDGOALS),) - include .depend -endif - -ifeq ($(MAKECMDGOALS), all) - include .depend -endif - -ifeq ($(MAKECMDGOALS), opt) - include .depend.opt -endif - -include ../../../Makefile.defs diff --git a/matita/components/binaries/table_creator/sync_db.sh b/matita/components/binaries/table_creator/sync_db.sh deleted file mode 100755 index 7b201382a..000000000 --- a/matita/components/binaries/table_creator/sync_db.sh +++ /dev/null @@ -1,28 +0,0 @@ -#!/bin/sh - -# sync metadata from a source database (usually "mowgli") to a target one -# (usually "matita") -# Created: Fri, 13 May 2005 13:50:16 +0200 zacchiro -# Last-Modified: Fri, 13 May 2005 13:50:16 +0200 zacchiro - -SOURCE_DB="mowgli" -TARGET_DB="matita" -MYSQL_FLAGS="-u helm -h localhost" - -MYSQL="mysql $MYSQL_FLAGS -f" -MYSQLDUMP="mysqldump $MYSQL_FLAGS" -MYSQLRESTORE="mysqlrestore $MYSQL_FLAGS" -TABLES=`./table_creator list all` -DUMP="${SOURCE_DB}_dump.gz" - -echo "Dumping source db $SOURCE_DB ..." -$MYSQLDUMP $SOURCE_DB $TABLES | gzip -c > $DUMP -echo "Destroying old tables in target db $TARGET_DB ..." -./table_destructor table all | $MYSQL $TARGET_DB -echo "Creating table structure in target db $TARGET_DB ..." -echo "Filling target db $TARGET_DB ..." -zcat $DUMP | $MYSQL $TARGET_DB -./table_creator index all | $MYSQL $TARGET_DB -rm $DUMP -echo "Done." - diff --git a/matita/components/binaries/table_creator/table_creator.ml b/matita/components/binaries/table_creator/table_creator.ml deleted file mode 100644 index c735fe67f..000000000 --- a/matita/components/binaries/table_creator/table_creator.ml +++ /dev/null @@ -1,87 +0,0 @@ - -open Printf - -let map = - (MetadataTypes.library_obj_tbl,`RefObj) :: - (MetadataTypes.library_sort_tbl,`RefSort) :: - (MetadataTypes.library_rel_tbl,`RefRel) :: - (MetadataTypes.library_name_tbl,`ObjectName) :: - (MetadataTypes.library_hits_tbl,`Hits) :: - (MetadataTypes.library_count_tbl,`Count) :: [] - -let usage argv_o = - prerr_string "\nusage:"; - prerr_string ("\t" ^ argv_o ^ " what tablename[=rename]\n"); - prerr_string ("\t" ^ argv_o ^ " what all\n\n"); - prerr_endline "what:"; - prerr_endline "\tlist\tlist table names"; - prerr_endline "\ttable\toutput SQL regarding tables"; - prerr_endline "\tindex\toutput SQL regarding indexes"; - prerr_endline "\tfill\toutput SQL filling tables (only \"hits\" supported)\n"; - prerr_string "known tables:\n\t"; - List.iter (fun (n,_) -> prerr_string (" " ^ n)) map; - prerr_endline "\n" - -let eq_RE = Str.regexp "=" - -let parse_args l = - List.map (fun s -> - let parts = Str.split eq_RE s in - let len = List.length parts in - assert (len = 1 || len = 2); - if len = 1 then (s,s) else (List.nth parts 0, List.nth parts 1)) - l - -let destructor_RE = Str.regexp "table_destructor\\(\\|\\.opt\\)$" - -let am_i_destructor () = - try - let _ = Str.search_forward destructor_RE Sys.argv.(0) 0 in true - with Not_found -> false - -let main () = - let len = Array.length Sys.argv in - if len < 3 then - begin - usage Sys.argv.(0); - exit 1 - end - else - begin - let tab,idx,fill = - if am_i_destructor () then - (SqlStatements.drop_tables, - (fun x -> - let dbd = HSql.fake_db_for_mysql HSql.Library in - SqlStatements.drop_indexes x HSql.Library dbd), - fun _ t -> [sprintf "DELETE * FROM %s;" t]) - else - (SqlStatements.create_tables, - SqlStatements.create_indexes, - SqlStatements.fill_hits) - in - let from = 2 in - let what = - match Sys.argv.(1) with - | "list" -> `List - | "index" -> `Index - | "table" -> `Table - | "fill" -> `Fill - | _ -> failwith "what must be one of \"index\", \"table\", \"fill\"" - in - let todo = Array.to_list (Array.sub Sys.argv from (len - from)) in - let todo = match todo with ["all"] -> List.map fst map | todo -> todo in - let todo = parse_args todo in - let todo = List.map (fun (x,name) -> name, (List.assoc x map)) todo in - match what with - | `Index -> print_endline (String.concat "\n" (idx todo)) - | `Table -> print_endline (String.concat "\n" (tab todo)) - | `Fill -> - print_endline (String.concat "\n" - (fill MetadataTypes.library_obj_tbl MetadataTypes.library_hits_tbl)) - | `List -> print_endline (String.concat " " (List.map fst map)) - end - -let _ = main () - - diff --git a/matita/components/binaries/utilities/.depend b/matita/components/binaries/utilities/.depend deleted file mode 100644 index e69de29bb..000000000 diff --git a/matita/components/binaries/utilities/.depend.opt b/matita/components/binaries/utilities/.depend.opt deleted file mode 100644 index e69de29bb..000000000 diff --git a/matita/components/binaries/utilities/Makefile b/matita/components/binaries/utilities/Makefile deleted file mode 100644 index db76fb51d..000000000 --- a/matita/components/binaries/utilities/Makefile +++ /dev/null @@ -1,41 +0,0 @@ -H=@ - -UTILITIES = create_environment parse_library list_uris test_library -UTILITIES_OPT = $(patsubst %,%.opt,$(UTILITIES)) -LINKOPTS = -linkpkg -rectypes -thread -LIBS = helm-cic_proof_checking -OCAMLC = $(OCAMLFIND) ocamlc $(LINKOPTS) -package $(LIBS) -OCAMLOPT = $(OCAMLFIND) opt $(LINKOPTS) -package $(LIBS) -all: $(UTILITIES) - $(H)echo -n -opt: $(UTILITIES_OPT) - $(H)echo -n -%: %.ml - $(H)echo " OCAMLC $<" - $(H)$(OCAMLC) -o $@ $< -%.opt: %.ml - $(H)echo " OCAMLOPT $<" - $(H)$(OCAMLOPT) -o $@ $< -clean: - rm -f $(UTILITIES) $(UTILITIES_OPT) *.cm[iox] *.o -depend: - $(H)echo " OCAMLDEP" - $(H)ocamldep extractor.ml extractor_manager.ml > .depend -depend.opt: - $(H)echo " OCAMLDEP -native" - $(H)ocamldep -native extractor.ml extractor_manager.ml > .depend.opt - -ifeq ($(MAKECMDGOALS),) - include .depend -endif - -ifeq ($(MAKECMDGOALS), all) - include .depend -endif - -ifeq ($(MAKECMDGOALS), opt) - include .depend.opt -endif - -include ../../../Makefile.defs - diff --git a/matita/components/binaries/utilities/create_environment.ml b/matita/components/binaries/utilities/create_environment.ml deleted file mode 100644 index 8a8524d24..000000000 --- a/matita/components/binaries/utilities/create_environment.ml +++ /dev/null @@ -1,73 +0,0 @@ -(* Copyright (C) 2004-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/ - *) - -let trust = true - -let outfname = - match Sys.argv.(1) with - | "-help" | "--help" | "-h" | "--h" -> - print_endline - ("Usage: create_environment \n" ^ - " is the file where environment will be dumped\n" ^ - " is the file containing the URIs, one per line,\n" ^ - " that will be typechecked. Could be \"-\" for\n" ^ - " standard input"); - flush stdout; - exit 0 - | f -> f -let _ = - CicEnvironment.set_trust (fun _ -> trust); - Helm_registry.set "getter.mode" "remote"; - Helm_registry.set "getter.url" "http://mowgli.cs.unibo.it:58081/"; - Sys.catch_break true; - if Sys.file_exists outfname then begin - let ic = open_in outfname in - CicEnvironment.restore_from_channel ic; - close_in ic - end -let urifname = - try - Sys.argv.(2) - with Invalid_argument _ -> "-" -let ic = - match urifname with - | "-" -> stdin - | fname -> open_in fname -let _ = - try - while true do -(* try *) - let uri = input_line ic in - print_endline uri; - flush stdout; - let uri = UriManager.uri_of_string uri in - ignore (CicTypeChecker.typecheck uri) -(* with Sys.Break -> () *) - done - with End_of_file | Sys.Break -> - let oc = open_out outfname in - CicEnvironment.dump_to_channel oc; - close_out oc - diff --git a/matita/components/binaries/utilities/list_uris.ml b/matita/components/binaries/utilities/list_uris.ml deleted file mode 100644 index 90ea51616..000000000 --- a/matita/components/binaries/utilities/list_uris.ml +++ /dev/null @@ -1,30 +0,0 @@ -(* Copyright (C) 2004-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/ - *) - -let ic = open_in Sys.argv.(1) in -CicEnvironment.restore_from_channel ic; -List.iter - (fun uri -> print_endline (UriManager.string_of_uri uri)) - (CicEnvironment.list_uri ()) diff --git a/matita/components/binaries/utilities/parse_library.ml b/matita/components/binaries/utilities/parse_library.ml deleted file mode 100644 index 1d65291cb..000000000 --- a/matita/components/binaries/utilities/parse_library.ml +++ /dev/null @@ -1,54 +0,0 @@ -(* Copyright (C) 2004-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/ - *) - -let trust = true - -let _ = - CicEnvironment.set_trust (fun _ -> trust); - Helm_registry.set "getter.mode" "remote"; - Helm_registry.set "getter.url" "http://mowgli.cs.unibo.it:58081/" -let urifname = - try - Sys.argv.(1) - with Invalid_argument _ -> "-" -let ic = - match urifname with - | "-" -> stdin - | fname -> open_in fname -let _ = - try - while true do - try - let uri = input_line ic in - prerr_endline uri; - let uri = UriManager.uri_of_string uri in - ignore (CicEnvironment.get_obj CicUniv.empty_ugraph uri) -(* with Sys.Break -> () *) - with - | End_of_file -> raise End_of_file - | exn -> () - done - with End_of_file -> Unix.sleep max_int - diff --git a/matita/components/binaries/utilities/test_library.ml b/matita/components/binaries/utilities/test_library.ml deleted file mode 100644 index 98ade3adb..000000000 --- a/matita/components/binaries/utilities/test_library.ml +++ /dev/null @@ -1,153 +0,0 @@ -(* Copyright (C) 2004-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/ - *) - -let trust = true -let deadline = 30 -let conffile = "../../../matita/matita.conf.xml" - -let _ = CicEnvironment.set_trust (fun _ -> trust);; -let _ = Helm_registry.load_from conffile;; - -let old_total = ref 0.0 -let new_total = ref 0.0 - -let separator = "=============" - -let perc newt oldt = (newt -. oldt) /. oldt *. 100.0 - -let _ = - Sys.catch_break true; - at_exit - (fun () -> - Printf.printf "%s\n" separator; - Printf.printf "Total: %.2f\n" !new_total; - if !old_total <> 0.0 then - Printf.printf "Old: %.2f (%.2f%%)\n" !old_total (perc !new_total !old_total)) -;; - -let timeout = ref false;; - -let _ = - Sys.set_signal 14 (* SIGALRM *) - (Sys.Signal_handle (fun _ -> - timeout := true; - raise Sys.Break)) -;; - -let urifname = - try - Sys.argv.(1) - with Invalid_argument _ -> - prerr_endline "You must supply a file with the list of URIs to check"; - exit (-1) - -let ic = open_in urifname - -exception Done;; - -let _ = - try - while true do - try - let uri = input_line ic in - if uri = separator then raise End_of_file; - let uri,res,time = - match Str.split (Str.regexp " ") uri with - uri::res::time::_ -> uri, Some res, Some (float_of_string time) - | [uri;res] -> uri, Some res, None - | [ uri ] -> uri, None, None - | _ -> assert false - in - Printf.printf "%s " uri; - flush stdout; - let uri = UriManager.uri_of_string uri in - let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - ignore (Unix.alarm deadline); - CicTypeChecker.typecheck_obj uri obj; - ignore (Unix.alarm 0); - CicEnvironment.remove_obj uri; - let before = Unix.times () in - ignore (Unix.alarm deadline); - ignore (CicTypeChecker.typecheck_obj uri obj); - ignore (Unix.alarm 0); - let memusage = (Gc.stat ()).Gc.live_words * 4 / 1024 / 1024 in - if memusage > 500 then - begin - prerr_endline ("MEMORIA ALLOCATA: " ^ string_of_int memusage ^ "Mb"); - CicEnvironment.empty (); - Gc.compact (); - let memusage = (Gc.stat ()).Gc.live_words * 4 / 1024 / 1024 in - prerr_endline ("DOPO CicEnvironment.empty: " ^ string_of_int memusage ^ "Mb"); - end; - let after = Unix.times () in - let diff = after.Unix.tms_utime +. after.Unix.tms_stime -. before.Unix.tms_utime -. before.Unix.tms_stime in - new_total := !new_total +. diff; - Printf.printf "OK %.2f" diff; - (match time with - None -> Printf.printf "\n" - | Some time -> - old_total := !old_total +. time; - Printf.printf " %.2f%%\n" (perc diff time)) - with - | End_of_file as exn -> raise exn - | Sys.Break -> - let rec skip_break prompt = - try - if prompt then - begin - Printf.printf "SKIPPED\n"; - flush stdout; - if not !timeout then - begin - Printf.eprintf "Continue with next URI? [y/_]"; - flush stderr; - end; - end; - if not !timeout then - (match input_line stdin with - "y" -> () - | _ -> raise Done) - else - timeout := false - with - Sys.Break -> skip_break false - in - skip_break true - | CicEnvironment.CircularDependency _ -> - Printf.printf "CIRCULARDEP\n" - | exn -> - Printf.printf "FAIL\n"; - flush stdout; - prerr_endline - (match exn with - CicTypeChecker.TypeCheckerFailure msg -> - "TypeCheckerFailure: " ^ Lazy.force msg - | CicTypeChecker.AssertFailure msg -> - "TypeCheckerAssertion: " ^ Lazy.force msg - | _ -> Printexc.to_string exn) - done - with - End_of_file - | Done -> () diff --git a/matita/components/binaries/utilities/test_xml_parser.ml b/matita/components/binaries/utilities/test_xml_parser.ml deleted file mode 100644 index e15468f99..000000000 --- a/matita/components/binaries/utilities/test_xml_parser.ml +++ /dev/null @@ -1,88 +0,0 @@ -(* Copyright (C) 2004-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/ - *) - -(* $Id$ *) - -open Printf - -let _ = - Helm_registry.set "getter.mode" "remote"; - Helm_registry.set "getter.url" "http://mowgli.cs.unibo.it:58081/" - -let body_RE = Str.regexp "^.*\\.body$" -let con_RE = Str.regexp "^.*\\.con$" - -let unlink f = - if Sys.file_exists f then - Unix.unlink f - -let rec parse uri tmpfile1 tmpfile2 = -(*prerr_endline (sprintf "%s %s" tmpfile1 (match tmpfile2 with None -> "None" | Some f -> "Some " ^ f));*) - (try - let uri' = UriManager.uri_of_string uri in - let time_new0 = Unix.gettimeofday () in -(* let obj_new = CicPushParser.CicParser.annobj_of_xml tmpfile1 tmpfile2 in*) - let obj_new = CicParser.annobj_of_xml uri' tmpfile1 tmpfile2 in - let time_new1 = Unix.gettimeofday () in - - let time_old0 = Unix.gettimeofday () in - ignore (Unix.system (sprintf "gunzip -c %s > test.tmp && mv test.tmp %s" - tmpfile1 tmpfile1)); - (match tmpfile2 with - | Some tmpfile2 -> - ignore (Unix.system (sprintf "gunzip -c %s > test.tmp && mv test.tmp %s" - tmpfile2 tmpfile2)); - | None -> ()); - let obj_old = CicPxpParser.CicParser.annobj_of_xml uri' tmpfile1 tmpfile2 in - let time_old1 = Unix.gettimeofday () in - - let time_old = time_old1 -. time_old0 in - let time_new = time_new1 -. time_new0 in - let are_equal = (obj_old = obj_new) in - printf "%s\t%b\t%f\t%f\t%f\n" - uri are_equal time_old time_new (time_new /. time_old *. 100.); - flush stdout; - with - | CicParser.Getter_failure ("key_not_found", uri) - when Str.string_match body_RE uri 0 -> - parse uri tmpfile1 None - | CicParser.Parser_failure msg -> - printf "%s FAILED (%s)\n" uri msg; flush stdout) - -let _ = - try - while true do - let uri = input_line stdin in - let tmpfile1 = Http_getter.getxml uri in - let tmpfile2 = - if Str.string_match con_RE uri 0 then begin - Some (Http_getter.getxml (uri ^ ".body")) - end else - None - in - parse uri tmpfile1 tmpfile2 - done - with End_of_file -> () - diff --git a/matita/components/cic/.depend b/matita/components/cic/.depend index a835b247f..b7f80297d 100644 --- a/matita/components/cic/.depend +++ b/matita/components/cic/.depend @@ -8,6 +8,7 @@ libraryObjects.cmi: cic_indexable.cmi: cic.cmo path_indexing.cmi: cic.cmo cicInspect.cmi: cic.cmo +cicPp.cmi: cic.cmo cic.cmo: cicUniv.cmi cic.cmx: cicUniv.cmx cicUniv.cmo: cicUniv.cmi @@ -30,3 +31,5 @@ path_indexing.cmo: cic.cmo path_indexing.cmi path_indexing.cmx: cic.cmx path_indexing.cmi cicInspect.cmo: cic.cmo cicInspect.cmi cicInspect.cmx: cic.cmx cicInspect.cmi +cicPp.cmo: cicUtil.cmi cicUniv.cmi cic.cmo cicPp.cmi +cicPp.cmx: cicUtil.cmx cicUniv.cmx cic.cmx cicPp.cmi diff --git a/matita/components/cic/.depend.opt b/matita/components/cic/.depend.opt index 8cdd2a86a..7306b25a5 100644 --- a/matita/components/cic/.depend.opt +++ b/matita/components/cic/.depend.opt @@ -8,6 +8,7 @@ libraryObjects.cmi: cic_indexable.cmi: cic.cmx path_indexing.cmi: cic.cmx cicInspect.cmi: cic.cmx +cicPp.cmi: cic.cmx cic.cmo: cicUniv.cmi cic.cmx: cicUniv.cmx cicUniv.cmo: cicUniv.cmi @@ -30,3 +31,5 @@ path_indexing.cmo: cic.cmx path_indexing.cmi path_indexing.cmx: cic.cmx path_indexing.cmi cicInspect.cmo: cic.cmx cicInspect.cmi cicInspect.cmx: cic.cmx cicInspect.cmi +cicPp.cmo: cicUtil.cmi cicUniv.cmi cic.cmx cicPp.cmi +cicPp.cmx: cicUtil.cmx cicUniv.cmx cic.cmx cicPp.cmi diff --git a/matita/components/cic/Makefile b/matita/components/cic/Makefile index 07f1d3f14..2ffea3e4d 100644 --- a/matita/components/cic/Makefile +++ b/matita/components/cic/Makefile @@ -11,7 +11,8 @@ INTERFACE_FILES = \ libraryObjects.mli \ cic_indexable.mli \ path_indexing.mli \ - cicInspect.mli + cicInspect.mli \ + cicPp.mli IMPLEMENTATION_FILES = \ cic.ml $(INTERFACE_FILES:%.mli=%.ml) EXTRA_OBJECTS_TO_INSTALL = cic.ml cic.cmi diff --git a/matita/components/cic/cicPp.ml b/matita/components/cic/cicPp.ml new file mode 100644 index 000000000..931a98135 --- /dev/null +++ b/matita/components/cic/cicPp.ml @@ -0,0 +1,538 @@ +(* Copyright (C) 2000, 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/. + *) + +(*****************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* This module implements a very simple Coq-like pretty printer that, given *) +(* an object of cic (internal representation) returns a string describing *) +(* the object in a syntax similar to that of coq *) +(* *) +(* It also contains the utility functions to check a name w.r.t the Matita *) +(* naming policy *) +(* *) +(*****************************************************************************) + +(* $Id$ *) + +exception CicPpInternalError;; +exception NotEnoughElements;; + +(* Utility functions *) + +let ppname = + function + Cic.Name s -> s + | Cic.Anonymous -> "_" +;; + +(* get_nth l n returns the nth element of the list l if it exists or *) +(* raises NotEnoughElements if l has less than n elements *) +let rec get_nth l n = + match (n,l) with + (1, he::_) -> he + | (n, he::tail) when n > 1 -> get_nth tail (n-1) + | (_,_) -> raise NotEnoughElements +;; + +(* pp t l *) +(* pretty-prints a term t of cic in an environment l where l is a list of *) +(* identifier names used to resolve DeBrujin indexes. The head of l is the *) +(* name associated to the greatest DeBrujin index in t *) +let pp ?metasenv = +let rec pp t l = + assert false (* MATITA 1.0 + let module C = Cic in + match t with + C.Rel n -> + begin + try + (match get_nth l n with + Some (C.Name s) -> s + | Some C.Anonymous -> "__" ^ string_of_int n + | None -> "_hidden_" ^ string_of_int n + ) + with + NotEnoughElements -> string_of_int (List.length l - n) + end + | C.Var (uri,exp_named_subst) -> + UriManager.string_of_uri (*UriManager.name_of_uri*) uri ^ pp_exp_named_subst exp_named_subst l + | C.Meta (n,l1) -> + (match metasenv with + None -> + "?" ^ (string_of_int n) ^ "[" ^ + String.concat " ; " + (List.rev_map (function None -> "_" | Some t -> pp t l) l1) ^ + "]" + | Some metasenv -> + try + let _,context,_ = CicUtil.lookup_meta n metasenv in + "?" ^ (string_of_int n) ^ "[" ^ + String.concat " ; " + (List.rev + (List.map2 + (fun x y -> + match x,y with + _, None + | None, _ -> "_" + | Some _, Some t -> pp t l + ) context l1)) ^ + "]" + with + CicUtil.Meta_not_found _ + | Invalid_argument _ -> + "???" ^ (string_of_int n) ^ "[" ^ + String.concat " ; " + (List.rev_map (function None -> "_" | Some t -> pp t l) l1) ^ + "]" + ) + | C.Sort s -> + (match s with + C.Prop -> "Prop" + | C.Set -> "Set" + | C.Type _ -> "Type" + (*| C.Type u -> ("Type" ^ CicUniv.string_of_universe u)*) + | C.CProp _ -> "CProp" + ) + | C.Implicit (Some `Hole) -> "%" + | C.Implicit _ -> "?" + | C.Prod (b,s,t) -> + (match b with + C.Name n -> "(\\forall " ^ n ^ ":" ^ pp s l ^ "." ^ pp t ((Some b)::l) ^ ")" + | C.Anonymous -> "(" ^ pp s l ^ "\\to " ^ pp t ((Some b)::l) ^ ")" + ) + | C.Cast (v,t) -> "(" ^ pp v l ^ ":" ^ pp t l ^ ")" + | C.Lambda (b,s,t) -> + "(\\lambda " ^ ppname b ^ ":" ^ pp s l ^ "." ^ pp t ((Some b)::l) ^ ")" + | C.LetIn (b,s,ty,t) -> + " let " ^ ppname b ^ ": " ^ pp ty l ^ " \\def " ^ pp s l ^ " in " ^ pp t ((Some b)::l) + | C.Appl li -> + "(" ^ + (List.fold_right + (fun x i -> pp x l ^ (match i with "" -> "" | _ -> " ") ^ i) + li "" + ) ^ ")" + | C.Const (uri,exp_named_subst) -> + UriManager.name_of_uri uri ^ pp_exp_named_subst exp_named_subst l + | C.MutInd (uri,n,exp_named_subst) -> + (try + match fst(CicEnvironment.get_obj CicUniv.empty_ugraph uri) with + C.InductiveDefinition (dl,_,_,_) -> + let (name,_,_,_) = get_nth dl (n+1) in + name ^ pp_exp_named_subst exp_named_subst l + | _ -> raise CicPpInternalError + with + Sys.Break as exn -> raise exn + | _ -> UriManager.string_of_uri uri ^ "#1/" ^ string_of_int (n + 1) + ) + | C.MutConstruct (uri,n1,n2,exp_named_subst) -> + (try + match fst(CicEnvironment.get_obj CicUniv.empty_ugraph uri) with + C.InductiveDefinition (dl,_,_,_) -> + let (_,_,_,cons) = get_nth dl (n1+1) in + let (id,_) = get_nth cons n2 in + id ^ pp_exp_named_subst exp_named_subst l + | _ -> raise CicPpInternalError + with + Sys.Break as exn -> raise exn + | _ -> + UriManager.string_of_uri uri ^ "#1/" ^ string_of_int (n1 + 1) ^ "/" ^ + string_of_int n2 + ) + | C.MutCase (uri,n1,ty,te,patterns) -> + let connames_and_argsno = + (match fst(CicEnvironment.get_obj CicUniv.empty_ugraph uri) with + C.InductiveDefinition (dl,_,paramsno,_) -> + let (_,_,_,cons) = get_nth dl (n1+1) in + List.map + (fun (id,ty) -> + (* this is just an approximation since we do not have + reduction yet! *) + let rec count_prods toskip = + function + C.Prod (_,_,bo) when toskip > 0 -> + count_prods (toskip - 1) bo + | C.Prod (_,_,bo) -> 1 + count_prods 0 bo + | _ -> 0 + in + id, count_prods paramsno ty + ) cons + | _ -> raise CicPpInternalError + ) + in + let connames_and_argsno_and_patterns = + let rec combine = + function + [],[] -> [] + | [],l -> List.map (fun x -> "???",0,Some x) l + | l,[] -> List.map (fun (x,no) -> x,no,None) l + | (x,no)::tlx,y::tly -> (x,no,Some y)::(combine (tlx,tly)) + in + combine (connames_and_argsno,patterns) + in + "\nmatch " ^ pp te l ^ " return " ^ pp ty l ^ " with \n [ " ^ + (String.concat "\n | " + (List.map + (fun (x,argsno,y) -> + let rec aux argsno l = + function + Cic.Lambda (name,ty,bo) when argsno > 0 -> + let args,res = aux (argsno - 1) (Some name::l) bo in + ("(" ^ (match name with C.Anonymous -> "_" | C.Name s -> s)^ + ":" ^ pp ty l ^ ")")::args, res + | t when argsno = 0 -> [],pp t l + | t -> ["{" ^ string_of_int argsno ^ " args missing}"],pp t l + in + let pattern,body = + match y with + None -> x,"" + | Some y when argsno = 0 -> x,pp y l + | Some y -> + let args,body = aux argsno l y in + "(" ^ x ^ " " ^ String.concat " " args ^ ")",body + in + pattern ^ " => " ^ body + ) connames_and_argsno_and_patterns)) ^ + "\n]" + | C.Fix (no, funs) -> + let snames = List.map (fun (name,_,_,_) -> name) funs in + let names = + List.rev (List.map (function name -> Some (C.Name name)) snames) + in + "\nFix " ^ get_nth snames (no + 1) ^ " {" ^ + List.fold_right + (fun (name,ind,ty,bo) i -> "\n" ^ name ^ " / " ^ string_of_int ind ^ + " : " ^ pp ty l ^ " := \n" ^ + pp bo (names@l) ^ i) + funs "" ^ + "}\n" + | C.CoFix (no,funs) -> + let snames = List.map (fun (name,_,_) -> name) funs in + let names = + List.rev (List.map (function name -> Some (C.Name name)) snames) + in + "\nCoFix " ^ get_nth snames (no + 1) ^ " {" ^ + List.fold_right + (fun (name,ty,bo) i -> "\n" ^ name ^ + " : " ^ pp ty l ^ " := \n" ^ + pp bo (names@l) ^ i) + funs "" ^ + "}\n" +and pp_exp_named_subst exp_named_subst l = + if exp_named_subst = [] then "" else + "\\subst[" ^ + String.concat " ; " ( + List.map + (function (uri,t) -> UriManager.name_of_uri uri ^ " \\Assign " ^ pp t l) + exp_named_subst + ) ^ "]" + *) +in + pp +;; + +let ppterm ?metasenv t = + pp ?metasenv t [] +;; + +(* ppinductiveType (typename, inductive, arity, cons) *) +(* pretty-prints a single inductive definition *) +(* (typename, inductive, arity, cons) *) +let ppinductiveType (typename, inductive, arity, cons) = + (if inductive then "\nInductive " else "\nCoInductive ") ^ typename ^ ": " ^ + pp arity [] ^ " =\n " ^ + List.fold_right + (fun (id,ty) i -> id ^ " : " ^ pp ty [] ^ + (if i = "" then "\n" else "\n | ") ^ i) + cons "" +;; + +let ppcontext ?metasenv ?(sep = "\n") context = + let separate s = if s = "" then "" else s ^ sep in + fst (List.fold_right + (fun context_entry (i,name_context) -> + match context_entry with + Some (n,Cic.Decl t) -> + Printf.sprintf "%s%s : %s" (separate i) (ppname n) + (pp ?metasenv t name_context), (Some n)::name_context + | Some (n,Cic.Def (bo,ty)) -> + Printf.sprintf "%s%s : %s := %s" (separate i) (ppname n) + (pp ?metasenv ty name_context) + (pp ?metasenv bo name_context), (Some n)::name_context + | None -> + Printf.sprintf "%s_ :? _" (separate i), None::name_context + ) context ("",[])) + +(* ppobj obj returns a string with describing the cic object obj in a syntax *) +(* similar to the one used by Coq *) +let ppobj obj = + let module C = Cic in + let module U = UriManager in + match obj with + C.Constant (name, Some t1, t2, params, _) -> + "Definition of " ^ name ^ + "(" ^ String.concat ";" (List.map UriManager.string_of_uri params) ^ + ")" ^ ":\n" ^ pp t1 [] ^ " : " ^ pp t2 [] + | C.Constant (name, None, ty, params, _) -> + "Axiom " ^ name ^ + "(" ^ String.concat ";" (List.map UriManager.string_of_uri params) ^ + "):\n" ^ pp ty [] + | C.Variable (name, bo, ty, params, _) -> + "Variable " ^ name ^ + "(" ^ String.concat ";" (List.map UriManager.string_of_uri params) ^ + ")" ^ ":\n" ^ + pp ty [] ^ "\n" ^ + (match bo with None -> "" | Some bo -> ":= " ^ pp bo []) + | C.CurrentProof (name, conjectures, value, ty, params, _) -> + "Current Proof of " ^ name ^ + "(" ^ String.concat ";" (List.map UriManager.string_of_uri params) ^ + ")" ^ ":\n" ^ + let separate s = if s = "" then "" else s ^ " ; " in + List.fold_right + (fun (n, context, t) i -> + let conjectures',name_context = + List.fold_right + (fun context_entry (i,name_context) -> + (match context_entry with + Some (n,C.Decl at) -> + (separate i) ^ + ppname n ^ ":" ^ + pp ~metasenv:conjectures at name_context ^ " ", + (Some n)::name_context + | Some (n,C.Def (at,aty)) -> + (separate i) ^ + ppname n ^ ": " ^ + pp ~metasenv:conjectures aty name_context ^ + ":= " ^ pp ~metasenv:conjectures + at name_context ^ " ", + (Some n)::name_context + | None -> + (separate i) ^ "_ :? _ ", None::name_context) + ) context ("",[]) + in + conjectures' ^ " |- " ^ "?" ^ (string_of_int n) ^ ": " ^ + pp ~metasenv:conjectures t name_context ^ "\n" ^ i + ) conjectures "" ^ + "\n" ^ pp ~metasenv:conjectures value [] ^ " : " ^ + pp ~metasenv:conjectures ty [] + | C.InductiveDefinition (l, params, nparams, _) -> + "Parameters = " ^ + String.concat ";" (List.map UriManager.string_of_uri params) ^ "\n" ^ + "NParams = " ^ string_of_int nparams ^ "\n" ^ + List.fold_right (fun x i -> ppinductiveType x ^ i) l "" +;; + +let ppsort = function + | Cic.Prop -> "Prop" + | Cic.Set -> "Set" + | Cic.Type _ -> "Type" + | Cic.CProp _ -> "CProp" + + +(* MATITA NAMING CONVENTION *) + +let is_prefix prefix string = + let len = String.length prefix in + let len1 = String.length string in + if len <= len1 then + begin + let head = String.sub string 0 len in + if + (String.compare (String.lowercase head) (String.lowercase prefix)=0) then + begin + let diff = len1-len in + let tail = String.sub string len diff in + if ((diff > 0) && (String.rcontains_from tail 0 '_')) then + Some (String.sub tail 1 (diff-1)) + else Some tail + end + else None + end + else None + +let remove_prefix prefix (last,string) = + if string = "" then (last,string) + else + match is_prefix prefix string with + None -> + if last <> "" then + match is_prefix last prefix with + None -> (last,string) + | Some _ -> + (match is_prefix prefix (last^string) with + None -> (last,string) + | Some tail -> (prefix,tail)) + else (last,string) + | Some tail -> (prefix, tail) + +let legal_suffix string = + if string = "" then true else + begin + let legal_s = Str.regexp "_?\\([0-9]+\\|r\\|l\\|'\\|\"\\)" in + (Str.string_match legal_s string 0) && (Str.matched_string string = string) + end + +(** check if a prefix of string_name is legal for term and returns the tail. + chec_rec cannot fail: at worst it return string_name. + The algorithm is greedy, but last contains the last name matched, providing + a one slot buffer. + string_name is here a pair (last,string_name).*) + +let rec check_rec ctx string_name = + assert false (* + function + | Cic.Rel m -> + (match List.nth ctx (m-1) with + Cic.Name name -> + remove_prefix name string_name + | Cic.Anonymous -> string_name) + | Cic.Meta _ -> string_name + | Cic.Sort sort -> remove_prefix (ppsort sort) string_name + | Cic.Implicit _ -> string_name + | Cic.Cast (te,ty) -> check_rec ctx string_name te + | Cic.Prod (name,so,dest) -> + let l_string_name = check_rec ctx string_name so in + check_rec (name::ctx) l_string_name dest + | Cic.Lambda (name,so,dest) -> + let string_name = + match name with + Cic.Anonymous -> string_name + | Cic.Name name -> remove_prefix name string_name in + let l_string_name = check_rec ctx string_name so in + check_rec (name::ctx) l_string_name dest + | Cic.LetIn (name,so,_,dest) -> + let string_name = check_rec ctx string_name so in + check_rec (name::ctx) string_name dest + | Cic.Appl l -> + List.fold_left (check_rec ctx) string_name l + | Cic.Var (uri,exp_named_subst) -> + let name = UriManager.name_of_uri uri in + remove_prefix name string_name + | Cic.Const (uri,exp_named_subst) -> + let name = UriManager.name_of_uri uri in + remove_prefix name string_name + | Cic.MutInd (uri,_,exp_named_subst) -> + let name = UriManager.name_of_uri uri in + remove_prefix name string_name + | Cic.MutConstruct (uri,n,m,exp_named_subst) -> + let name = + (match fst(CicEnvironment.get_obj CicUniv.empty_ugraph uri) with + Cic.InductiveDefinition (dl,_,_,_) -> + let (_,_,_,cons) = get_nth dl (n+1) in + let (id,_) = get_nth cons m in + id + | _ -> assert false) in + remove_prefix name string_name + | Cic.MutCase (_,_,_,te,pl) -> + let string_name = remove_prefix "match" string_name in + let string_name = check_rec ctx string_name te in + List.fold_right (fun t s -> check_rec ctx s t) pl string_name + | Cic.Fix (_,fl) -> + let string_name = remove_prefix "fix" string_name in + let names = List.map (fun (name,_,_,_) -> name) fl in + let onames = + List.rev (List.map (function name -> Cic.Name name) names) + in + List.fold_right + (fun (_,_,_,bo) s -> check_rec (onames@ctx) s bo) fl string_name + | Cic.CoFix (_,fl) -> + let string_name = remove_prefix "cofix" string_name in + let names = List.map (fun (name,_,_) -> name) fl in + let onames = + List.rev (List.map (function name -> Cic.Name name) names) + in + List.fold_right + (fun (_,_,bo) s -> check_rec (onames@ctx) s bo) fl string_name + *) + +let check_name ?(allow_suffix=false) ctx name term = + let (_,tail) = check_rec ctx ("",name) term in + if (not allow_suffix) then (String.length tail = 0) + else legal_suffix tail + +let check_elim ctx conclusion_name = + let elim = Str.regexp "_elim\\|_case" in + if (Str.string_match elim conclusion_name 0) then + let len = String.length conclusion_name in + let tail = String.sub conclusion_name 5 (len-5) in + legal_suffix tail + else false + +let rec check_names ctx hyp_names conclusion_name t = + match t with + | Cic.Prod (name,s,t) -> + (match hyp_names with + [] -> check_names (name::ctx) hyp_names conclusion_name t + | hd::tl -> + if check_name ctx hd s then + check_names (name::ctx) tl conclusion_name t + else + check_names (name::ctx) hyp_names conclusion_name t) + | Cic.Appl ((Cic.Rel n)::args) -> + (match hyp_names with + | [] -> + (check_name ~allow_suffix:true ctx conclusion_name t) || + (check_elim ctx conclusion_name) + | [what_to_elim] -> + (* what to elim could be an argument + of the predicate: e.g. leb_elim *) + let (last,tail) = + List.fold_left (check_rec ctx) ("",what_to_elim) args in + (tail = "" && check_elim ctx conclusion_name) + | _ -> false) + | Cic.MutCase (_,_,Cic.Lambda(name,so,ty),te,_) -> + (match hyp_names with + | [] -> + (match is_prefix "match" conclusion_name with + None -> check_name ~allow_suffix:true ctx conclusion_name t + | Some tail -> check_name ~allow_suffix:true ctx tail t) + | [what_to_match] -> + (* what to match could be the term te or its type so; in this case the + conclusion name should match ty *) + check_name ~allow_suffix:true (name::ctx) conclusion_name ty && + (check_name ctx what_to_match te || check_name ctx what_to_match so) + | _ -> false) + | _ -> + hyp_names=[] && check_name ~allow_suffix:true ctx conclusion_name t + +let check name term = + let names = Str.split (Str.regexp_string "_to_") name in + let hyp_names,conclusion_name = + match List.rev names with + [] -> assert false + | hd::tl -> + let elim = Str.regexp "_elim\\|_case" in + let len = String.length hd in + try + let pos = Str.search_backward elim hd len in + let hyp = String.sub hd 0 pos in + let concl = String.sub hd pos (len-pos) in + List.rev (hyp::tl),concl + with Not_found -> (List.rev tl),hd in + check_names [] hyp_names conclusion_name term +;; + + diff --git a/matita/components/cic/cicPp.mli b/matita/components/cic/cicPp.mli new file mode 100644 index 000000000..e898c352d --- /dev/null +++ b/matita/components/cic/cicPp.mli @@ -0,0 +1,55 @@ +(* Copyright (C) 2000, 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/. + *) + +(*****************************************************************************) +(* *) +(* PROJECT HELM *) +(* *) +(* Claudio Sacerdoti Coen *) +(* 24/01/2000 *) +(* *) +(* This module implements a very simple Coq-like pretty printer that, given *) +(* an object of cic (internal representation) returns a string describing the*) +(* object in a syntax similar to that of coq *) +(* *) +(*****************************************************************************) + +(* ppobj obj returns a string with describing the cic object obj in a syntax*) +(* similar to the one used by Coq *) +val ppobj : Cic.obj -> string + +val ppterm : ?metasenv:Cic.metasenv -> Cic.term -> string + +val ppcontext : ?metasenv:Cic.metasenv -> ?sep:string -> Cic.context -> string + +(* Required only by the topLevel. It is the generalization of ppterm to *) +(* work with environments. *) +val pp : ?metasenv:Cic.metasenv -> Cic.term -> (Cic.name option) list -> string + +val ppname : Cic.name -> string + +val ppsort: Cic.sort -> string + +val check: string -> Cic.term -> bool diff --git a/matita/components/cic_acic/.depend b/matita/components/cic_acic/.depend deleted file mode 100644 index 5449d50aa..000000000 --- a/matita/components/cic_acic/.depend +++ /dev/null @@ -1,12 +0,0 @@ -eta_fixing.cmi: -doubleTypeInference.cmi: -cic2acic.cmi: -cic2Xml.cmi: cic2acic.cmi -eta_fixing.cmo: eta_fixing.cmi -eta_fixing.cmx: eta_fixing.cmi -doubleTypeInference.cmo: doubleTypeInference.cmi -doubleTypeInference.cmx: doubleTypeInference.cmi -cic2acic.cmo: eta_fixing.cmi doubleTypeInference.cmi cic2acic.cmi -cic2acic.cmx: eta_fixing.cmx doubleTypeInference.cmx cic2acic.cmi -cic2Xml.cmo: cic2acic.cmi cic2Xml.cmi -cic2Xml.cmx: cic2acic.cmx cic2Xml.cmi diff --git a/matita/components/cic_acic/.depend.opt b/matita/components/cic_acic/.depend.opt deleted file mode 100644 index 5449d50aa..000000000 --- a/matita/components/cic_acic/.depend.opt +++ /dev/null @@ -1,12 +0,0 @@ -eta_fixing.cmi: -doubleTypeInference.cmi: -cic2acic.cmi: -cic2Xml.cmi: cic2acic.cmi -eta_fixing.cmo: eta_fixing.cmi -eta_fixing.cmx: eta_fixing.cmi -doubleTypeInference.cmo: doubleTypeInference.cmi -doubleTypeInference.cmx: doubleTypeInference.cmi -cic2acic.cmo: eta_fixing.cmi doubleTypeInference.cmi cic2acic.cmi -cic2acic.cmx: eta_fixing.cmx doubleTypeInference.cmx cic2acic.cmi -cic2Xml.cmo: cic2acic.cmi cic2Xml.cmi -cic2Xml.cmx: cic2acic.cmx cic2Xml.cmi diff --git a/matita/components/cic_acic/Makefile b/matita/components/cic_acic/Makefile deleted file mode 100644 index 2669afb11..000000000 --- a/matita/components/cic_acic/Makefile +++ /dev/null @@ -1,13 +0,0 @@ -PACKAGE = cic_acic -PREDICATES = - -INTERFACE_FILES = \ - eta_fixing.mli \ - doubleTypeInference.mli \ - cic2acic.mli \ - cic2Xml.mli \ - $(NULL) -IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) - -include ../../Makefile.defs -include ../Makefile.common diff --git a/matita/components/cic_acic/cic2Xml.ml b/matita/components/cic_acic/cic2Xml.ml deleted file mode 100644 index 0708a839f..000000000 --- a/matita/components/cic_acic/cic2Xml.ml +++ /dev/null @@ -1,493 +0,0 @@ -(* Copyright (C) 2000-2004, 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$ *) - -(*CSC codice cut & paste da cicPp e xmlcommand *) - -exception NotImplemented;; - -let dtdname ~ask_dtd_to_the_getter dtd = - if ask_dtd_to_the_getter then - Helm_registry.get "getter.url" ^ "getdtd?uri=" ^ dtd - else - "http://mowgli.cs.unibo.it/dtd/" ^ dtd -;; - -let param_attribute_of_params params = - String.concat " " (List.map UriManager.string_of_uri params) -;; - -(*CSC ottimizzazione: al posto di curi cdepth (vedi codice) *) -let print_term ?ids_to_inner_sorts = - let find_sort name id = - match ids_to_inner_sorts with - None -> [] - | Some ids_to_inner_sorts -> - [None,name,Cic2acic.string_of_sort (Hashtbl.find ids_to_inner_sorts id)] - in - let rec aux = - let module C = Cic in - let module X = Xml in - let module U = UriManager in - function - C.ARel (id,idref,n,b) -> - let sort = find_sort "sort" id in - X.xml_empty "REL" - (sort @ - [None,"value",(string_of_int n) ; None,"binder",b ; None,"id",id ; - None,"idref",idref]) - | C.AVar (id,uri,exp_named_subst) -> - let sort = find_sort "sort" id in - aux_subst uri - (X.xml_empty "VAR" - (sort @ [None,"uri",U.string_of_uri uri;None,"id",id])) - exp_named_subst - | C.AMeta (id,n,l) -> - let sort = find_sort "sort" id in - X.xml_nempty "META" - (sort @ [None,"no",(string_of_int n) ; None,"id",id]) - (List.fold_left - (fun i t -> - match t with - Some t' -> - [< i ; X.xml_nempty "substitution" [] (aux t') >] - | None -> - [< i ; X.xml_empty "substitution" [] >] - ) [< >] l) - | C.ASort (id,s) -> - let string_of_sort s = - Cic2acic.string_of_sort (Cic2acic.sort_of_sort s) - in - X.xml_empty "SORT" [None,"value",(string_of_sort s) ; None,"id",id] - | C.AImplicit _ -> raise NotImplemented - | C.AProd (last_id,_,_,_) as prods -> - let rec eat_prods = - function - C.AProd (id,n,s,t) -> - let prods,t' = eat_prods t in - (id,n,s)::prods,t' - | t -> [],t - in - let prods,t = eat_prods prods in - let sort = find_sort "type" last_id in - X.xml_nempty "PROD" sort - [< List.fold_left - (fun i (id,binder,s) -> - let sort = find_sort "type" (Cic2acic.source_id_of_id id) in - let attrs = - sort @ ((None,"id",id):: - match binder with - C.Anonymous -> [] - | C.Name b -> [None,"binder",b]) - in - [< i ; X.xml_nempty "decl" attrs (aux s) >] - ) [< >] prods ; - X.xml_nempty "target" [] (aux t) - >] - | C.ACast (id,v,t) -> - let sort = find_sort "sort" id in - X.xml_nempty "CAST" (sort @ [None,"id",id]) - [< X.xml_nempty "term" [] (aux v) ; - X.xml_nempty "type" [] (aux t) - >] - | C.ALambda (last_id,_,_,_) as lambdas -> - let rec eat_lambdas = - function - C.ALambda (id,n,s,t) -> - let lambdas,t' = eat_lambdas t in - (id,n,s)::lambdas,t' - | t -> [],t - in - let lambdas,t = eat_lambdas lambdas in - let sort = find_sort "sort" last_id in - X.xml_nempty "LAMBDA" sort - [< List.fold_left - (fun i (id,binder,s) -> - let sort = find_sort "type" (Cic2acic.source_id_of_id id) in - let attrs = - sort @ ((None,"id",id):: - match binder with - C.Anonymous -> [] - | C.Name b -> [None,"binder",b]) - in - [< i ; X.xml_nempty "decl" attrs (aux s) >] - ) [< >] lambdas ; - X.xml_nempty "target" [] (aux t) - >] - | C.ALetIn (xid,C.Anonymous,s,ty,t) -> - assert false - | C.ALetIn (last_id,C.Name _,_,_,_) as letins -> - let rec eat_letins = - function - C.ALetIn (id,n,s,ty,t) -> - let letins,t' = eat_letins t in - (id,n,s,ty)::letins,t' - | t -> [],t - in - let letins,t = eat_letins letins in - let sort = find_sort "sort" last_id in - X.xml_nempty "LETIN" sort - [< List.fold_left - (fun i (id,binder,s,ty) -> - let sort = find_sort "sort" id in - let attrs = - sort @ ((None,"id",id):: - match binder with - C.Anonymous -> [] - | C.Name b -> [None,"binder",b]) - in - [< i ; X.xml_nempty "def" attrs [< aux s ; aux ty >] >] - ) [< >] letins ; - X.xml_nempty "target" [] (aux t) - >] - | C.AAppl (id,li) -> - let sort = find_sort "sort" id in - X.xml_nempty "APPLY" (sort @ [None,"id",id]) - [< (List.fold_right (fun x i -> [< (aux x) ; i >]) li [<>]) - >] - | C.AConst (id,uri,exp_named_subst) -> - let sort = find_sort "sort" id in - aux_subst uri - (X.xml_empty "CONST" - (sort @ [None,"uri",(U.string_of_uri uri) ; None,"id",id]) - ) exp_named_subst - | C.AMutInd (id,uri,i,exp_named_subst) -> - aux_subst uri - (X.xml_empty "MUTIND" - [None, "uri", (U.string_of_uri uri) ; - None, "noType", (string_of_int i) ; - None, "id", id] - ) exp_named_subst - | C.AMutConstruct (id,uri,i,j,exp_named_subst) -> - let sort = find_sort "sort" id in - aux_subst uri - (X.xml_empty "MUTCONSTRUCT" - (sort @ - [None,"uri", (U.string_of_uri uri) ; - None,"noType",(string_of_int i) ; - None,"noConstr",(string_of_int j) ; - None,"id",id]) - ) exp_named_subst - | C.AMutCase (id,uri,typeno,ty,te,patterns) -> - let sort = find_sort "sort" id in - X.xml_nempty "MUTCASE" - (sort @ - [None,"uriType",(U.string_of_uri uri) ; - None,"noType", (string_of_int typeno) ; - None,"id", id]) - [< X.xml_nempty "patternsType" [] [< (aux ty) >] ; - X.xml_nempty "inductiveTerm" [] [< (aux te) >] ; - List.fold_right - (fun x i -> [< X.xml_nempty "pattern" [] [< aux x >] ; i>]) - patterns [<>] - >] - | C.AFix (id, no, funs) -> - let sort = find_sort "sort" id in - X.xml_nempty "FIX" - (sort @ [None,"noFun", (string_of_int no) ; None,"id",id]) - [< List.fold_right - (fun (id,fi,ai,ti,bi) i -> - [< X.xml_nempty "FixFunction" - [None,"id",id ; None,"name", fi ; - None,"recIndex", (string_of_int ai)] - [< X.xml_nempty "type" [] [< aux ti >] ; - X.xml_nempty "body" [] [< aux bi >] - >] ; - i - >] - ) funs [<>] - >] - | C.ACoFix (id,no,funs) -> - let sort = find_sort "sort" id in - X.xml_nempty "COFIX" - (sort @ [None,"noFun", (string_of_int no) ; None,"id",id]) - [< List.fold_right - (fun (id,fi,ti,bi) i -> - [< X.xml_nempty "CofixFunction" [None,"id",id ; None,"name", fi] - [< X.xml_nempty "type" [] [< aux ti >] ; - X.xml_nempty "body" [] [< aux bi >] - >] ; - i - >] - ) funs [<>] - >] - and aux_subst buri target subst = -(*CSC: I have now no way to assign an ID to the explicit named substitution *) - let id = None in - if subst = [] then - target - else - Xml.xml_nempty "instantiate" - (match id with None -> [] | Some id -> [None,"id",id]) - [< target ; - List.fold_left - (fun i (uri,arg) -> - let relUri = - let buri_frags = - Str.split (Str.regexp "/") (UriManager.string_of_uri buri) in - let uri_frags = - Str.split (Str.regexp "/") (UriManager.string_of_uri uri) in - let rec find_relUri buri_frags uri_frags = - match buri_frags,uri_frags with - [_], _ -> String.concat "/" uri_frags - | he1::tl1, he2::tl2 -> - assert (he1 = he2) ; - find_relUri tl1 tl2 - | _,_ -> assert false (* uri is not relative to buri *) - in - find_relUri buri_frags uri_frags - in - [< i ; Xml.xml_nempty "arg" [None,"relUri", relUri] (aux arg) >] - ) [<>] subst - >] - in - aux -;; - -let xml_of_attrs generate_attributes attributes = - let class_of = function - | `Coercion n -> - Xml.xml_empty "class" [None,"value","coercion";None,"arity",string_of_int n] - | `Elim s -> - Xml.xml_nempty "class" [None,"value","elim"] - [< Xml.xml_empty - "SORT" [None,"value", - (Cic2acic.string_of_sort (Cic2acic.sort_of_sort s)) ; - None,"id","elimination_sort"] >] - | `Record field_names -> - Xml.xml_nempty "class" [None,"value","record"] - (List.fold_right - (fun (name,coercion,arity) res -> - [< Xml.xml_empty "field" - [None,"name", - if coercion then - name ^ " coercion " ^ string_of_int arity - else - name]; - res >] - ) field_names [<>]) - | `Projection -> Xml.xml_empty "class" [None,"value","projection"] - | `InversionPrinciple -> Xml.xml_empty "class" [None,"value","inversion"] - in - let flavour_of = function - | `Definition -> Xml.xml_empty "flavour" [None, "value", "definition"] - | `MutualDefinition -> - Xml.xml_empty "flavour" [None, "value", "mutual_definition"] - | `Fact -> Xml.xml_empty "flavour" [None, "value", "fact"] - | `Lemma -> Xml.xml_empty "flavour" [None, "value", "lemma"] - | `Remark -> Xml.xml_empty "flavour" [None, "value", "remark"] - | `Theorem -> Xml.xml_empty "flavour" [None, "value", "theorem"] - | `Variant -> Xml.xml_empty "flavour" [None, "value", "variant"] - | `Axiom -> Xml.xml_empty "flavour" [None, "value", "axiom"] - in - let xml_attr_of = function - | `Generated -> Xml.xml_empty "generated" [] - | `Class c -> class_of c - | `Flavour f -> flavour_of f - in - let xml_attrs = - List.fold_right - (fun attr res -> [< xml_attr_of attr ; res >]) attributes [<>] - in - if generate_attributes then Xml.xml_nempty "attributes" [] xml_attrs else [<>] - -let print_object uri - ?ids_to_inner_sorts ?(generate_attributes=true) ~ask_dtd_to_the_getter obj = - let module C = Cic in - let module X = Xml in - let module U = UriManager in - let dtdname = dtdname ~ask_dtd_to_the_getter "cic.dtd" in - match obj with - C.ACurrentProof (id,idbody,n,conjectures,bo,ty,params,obj_attrs) -> - let params' = param_attribute_of_params params in - let xml_attrs = xml_of_attrs generate_attributes obj_attrs in - let xml_for_current_proof_body = -(*CSC: Should the CurrentProof also have the list of variables it depends on? *) -(*CSC: I think so. Not implemented yet. *) - X.xml_nempty "CurrentProof" - [None,"of",UriManager.string_of_uri uri ; None,"id", id] - [< xml_attrs; - List.fold_left - (fun i (cid,n,canonical_context,t) -> - [< i ; - X.xml_nempty "Conjecture" - [None,"id",cid ; None,"no",(string_of_int n)] - [< List.fold_left - (fun i (hid,t) -> - [< (match t with - Some (n,C.ADecl t) -> - X.xml_nempty "Decl" - (match n with - C.Name n' -> - [None,"id",hid;None,"name",n'] - | C.Anonymous -> [None,"id",hid]) - (print_term ?ids_to_inner_sorts t) - | Some (n,C.ADef (t,_)) -> - X.xml_nempty "Def" - (match n with - C.Name n' -> - [None,"id",hid;None,"name",n'] - | C.Anonymous -> [None,"id",hid]) - (print_term ?ids_to_inner_sorts t) - | None -> X.xml_empty "Hidden" [None,"id",hid] - ) ; - i - >] - ) [< >] canonical_context ; - X.xml_nempty "Goal" [] - (print_term ?ids_to_inner_sorts t) - >] - >]) - [< >] conjectures ; - X.xml_nempty "body" [] (print_term ?ids_to_inner_sorts bo) >] - in - let xml_for_current_proof_type = - X.xml_nempty "ConstantType" - [None,"name",n ; None,"params",params' ; None,"id", id] - (print_term ?ids_to_inner_sorts ty) - in - let xmlbo = - [< X.xml_cdata "\n" ; - X.xml_cdata ("\n"); - xml_for_current_proof_body - >] in - let xmlty = - [< X.xml_cdata "\n" ; - X.xml_cdata ("\n"); - xml_for_current_proof_type - >] - in - xmlty, Some xmlbo - | C.AConstant (id,idbody,n,bo,ty,params,obj_attrs) -> - let params' = param_attribute_of_params params in - let xml_attrs = xml_of_attrs generate_attributes obj_attrs in - let xmlbo = - match bo with - None -> None - | Some bo -> - Some - [< X.xml_cdata - "\n" ; - X.xml_cdata - ("\n") ; - X.xml_nempty "ConstantBody" - [None,"for",UriManager.string_of_uri uri ; - None,"params",params' ; None,"id", id] - [< print_term ?ids_to_inner_sorts bo >] - >] - in - let xmlty = - [< X.xml_cdata "\n" ; - X.xml_cdata ("\n"); - X.xml_nempty "ConstantType" - [None,"name",n ; None,"params",params' ; None,"id", id] - [< xml_attrs; print_term ?ids_to_inner_sorts ty >] - >] - in - xmlty, xmlbo - | C.AVariable (id,n,bo,ty,params,obj_attrs) -> - let params' = param_attribute_of_params params in - let xml_attrs = xml_of_attrs generate_attributes obj_attrs in - let xmlbo = - match bo with - None -> [< >] - | Some bo -> - X.xml_nempty "body" [] [< print_term ?ids_to_inner_sorts bo >] - in - let aobj = - [< X.xml_cdata "\n" ; - X.xml_cdata ("\n"); - X.xml_nempty "Variable" - [None,"name",n ; None,"params",params' ; None,"id", id] - [< xml_attrs; xmlbo; - X.xml_nempty "type" [] (print_term ?ids_to_inner_sorts ty) - >] - >] - in - aobj, None - | C.AInductiveDefinition (id,tys,params,nparams,obj_attrs) -> - let params' = param_attribute_of_params params in - let xml_attrs = xml_of_attrs generate_attributes obj_attrs in - [< X.xml_cdata "\n" ; - X.xml_cdata - ("\n") ; - X.xml_nempty "InductiveDefinition" - [None,"noParams",string_of_int nparams ; - None,"id",id ; - None,"params",params'] - [< xml_attrs; - (List.fold_left - (fun i (id,typename,finite,arity,cons) -> - [< i ; - X.xml_nempty "InductiveType" - [None,"id",id ; None,"name",typename ; - None,"inductive",(string_of_bool finite) - ] - [< X.xml_nempty "arity" [] - (print_term ?ids_to_inner_sorts arity) ; - (List.fold_left - (fun i (name,lc) -> - [< i ; - X.xml_nempty "Constructor" - [None,"name",name] - (print_term ?ids_to_inner_sorts lc) - >]) [<>] cons - ) - >] - >] - ) [< >] tys - ) - >] - >], None -;; - -let - print_inner_types curi ~ids_to_inner_sorts ~ids_to_inner_types - ~ask_dtd_to_the_getter -= - let module C2A = Cic2acic in - let module X = Xml in - let dtdname = dtdname ~ask_dtd_to_the_getter "cictypes.dtd" in - [< X.xml_cdata "\n" ; - X.xml_cdata - ("\n") ; - X.xml_nempty "InnerTypes" [None,"of",UriManager.string_of_uri curi] - (Hashtbl.fold - (fun id {C2A.annsynthesized = synty ; C2A.annexpected = expty} x -> - [< x ; - X.xml_nempty "TYPE" [None,"of",id] - [< X.xml_nempty "synthesized" [] - [< print_term ~ids_to_inner_sorts synty >] ; - match expty with - None -> [<>] - | Some expty' -> X.xml_nempty "expected" [] - [< print_term ~ids_to_inner_sorts expty' >] - >] - >] - ) ids_to_inner_types [<>] - ) - >] -;; diff --git a/matita/components/cic_acic/cic2Xml.mli b/matita/components/cic_acic/cic2Xml.mli deleted file mode 100644 index dcbff3d0f..000000000 --- a/matita/components/cic_acic/cic2Xml.mli +++ /dev/null @@ -1,47 +0,0 @@ -(* Copyright (C) 2000, 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/. - *) - -exception NotImplemented - -val print_term : - ?ids_to_inner_sorts: (string, Cic2acic.sort_kind) Hashtbl.t -> - Cic.annterm -> - Xml.token Stream.t - -val print_object : - UriManager.uri -> - ?ids_to_inner_sorts: (string, Cic2acic.sort_kind) Hashtbl.t -> - ?generate_attributes:bool -> - ask_dtd_to_the_getter:bool -> - Cic.annobj -> - Xml.token Stream.t * Xml.token Stream.t option - -val print_inner_types : - UriManager.uri -> - ids_to_inner_sorts: (string, Cic2acic.sort_kind) Hashtbl.t -> - ids_to_inner_types: (string, Cic2acic.anntypes) Hashtbl.t -> - ask_dtd_to_the_getter:bool -> - Xml.token Stream.t - diff --git a/matita/components/cic_acic/cic2acic.ml b/matita/components/cic_acic/cic2acic.ml deleted file mode 100644 index 3285dcc15..000000000 --- a/matita/components/cic_acic/cic2acic.ml +++ /dev/null @@ -1,797 +0,0 @@ -(* Copyright (C) 2000, 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$ *) - -type sort_kind = [ `Prop | `Set | `Type of CicUniv.universe | `CProp of CicUniv.universe | `NType of string | `NCProp of string] - -let string_of_sort = function - | `Prop -> "Prop" - | `Set -> "Set" - | `Type u -> "Type:" ^ string_of_int (CicUniv.univno u) ^ ":" ^ UriManager.string_of_uri (CicUniv.univuri u) - | `NType s -> "Type[" ^ s ^ "]" - | `NCProp s -> "CProp[" ^ s ^ "]" - | `CProp u -> "CProp:" ^ string_of_int (CicUniv.univno u) ^ ":" ^ UriManager.string_of_uri (CicUniv.univuri u) - - -let sort_of_sort = function - | Cic.Prop -> `Prop - | Cic.Set -> `Set - | Cic.Type u -> `Type u - | Cic.CProp u -> `CProp u - -(* let hashtbl_add_time = ref 0.0;; *) - -let xxx_add_profiler = HExtlib.profile "xxx_add";; -let xxx_add h k v = - xxx_add_profiler.HExtlib.profile (Hashtbl.add h k) v -;; - -let xxx_type_of_aux' m c t = - let res,_ = - try - CicTypeChecker.type_of_aux' m c t CicUniv.oblivion_ugraph - with - | CicTypeChecker.AssertFailure _ - | CicTypeChecker.TypeCheckerFailure _ -> - Cic.Sort Cic.Prop, CicUniv.oblivion_ugraph - in - res -;; - -let xxx_type_of_aux'_profiler = HExtlib.profile "xxx_type_of_aux'";; -let xxx_type_of_aux' m c t = - xxx_type_of_aux'_profiler.HExtlib.profile (xxx_type_of_aux' m c) t - -type anntypes = - {annsynthesized : Cic.annterm ; annexpected : Cic.annterm option} -;; - -let gen_id seed = - let res = "i" ^ string_of_int !seed in - incr seed ; - res -;; - -let fresh_id seed ids_to_terms ids_to_father_ids = - fun father t -> - let res = gen_id seed in - xxx_add ids_to_father_ids res father ; - xxx_add ids_to_terms res t ; - res -;; - -let source_id_of_id id = "#source#" ^ id;; - -exception NotEnoughElements of string;; - -(*CSC: cut&paste da cicPp.ml *) -(* get_nth l n returns the nth element of the list l if it exists or *) -(* raises NotEnoughElements if l has less than n elements *) -let rec get_nth msg l n = - match (n,l) with - (1, he::_) -> he - | (n, he::tail) when n > 1 -> get_nth msg tail (n-1) - | (_,_) -> raise (NotEnoughElements msg) -;; - - -let profiler_for_find = HExtlib.profile "CicHash" ;; -let profiler_for_whd = HExtlib.profile "whd" ;; - -let cic_CicHash_find a b = - profiler_for_find.HExtlib.profile (Cic.CicHash.find a) b -;; - -let cicReduction_whd c t = - profiler_for_whd.HExtlib.profile (CicReduction.whd c) t -;; - -let acic_of_cic_context' ~computeinnertypes:global_computeinnertypes - seed ids_to_terms ids_to_father_ids ids_to_inner_sorts ids_to_inner_types - metasenv context idrefs t expectedty -= - let module D = DoubleTypeInference in - let module C = Cic in - let fresh_id' = fresh_id seed ids_to_terms ids_to_father_ids in -(* let time1 = Sys.time () in *) - let terms_to_types = -(* - let time0 = Sys.time () in - let prova = CicTypeChecker.type_of_aux' metasenv context t in - let time1 = Sys.time () in - prerr_endline ("*** Fine type_inference:" ^ (string_of_float (time1 -. time0))); - let res = D.double_type_of metasenv context t expectedty in - let time2 = Sys.time () in - prerr_endline ("*** Fine double_type_inference:" ^ (string_of_float (time2 -. time1))); - res -*) - if global_computeinnertypes then - D.double_type_of metasenv context t expectedty - else - Cic.CicHash.create 1 (* empty table *) - in -(* - let time2 = Sys.time () in - prerr_endline - ("++++++++++++ Tempi della double_type_of: "^ string_of_float (time2 -. time1)) ; -*) - let rec aux computeinnertypes father context idrefs tt = - let fresh_id'' = fresh_id' father tt in - (*CSC: computeinnertypes era true, il che e' proprio sbagliato, no? *) - (* First of all we compute the inner type and the inner sort *) - (* of the term. They may be useful in what follows. *) - (*CSC: This is a very inefficient way of computing inner types *) - (*CSC: and inner sorts: very deep terms have their types/sorts *) - (*CSC: computed again and again. *) - let sort_of t = - match cicReduction_whd context t with - C.Sort C.Prop -> `Prop - | C.Sort C.Set -> `Set - | C.Sort (C.Type u) -> `Type u - | C.Meta _ -> `Type (CicUniv.fresh()) - | C.Sort (C.CProp u) -> `CProp u - | t -> - prerr_endline ("Cic2acic.sort_of applied to: " ^ CicPp.ppterm t) ; - assert false - in - let ainnertypes,innertype,innersort,expected_available = - -(*CSC: Here we need the algorithm for Coscoy's double type-inference *) -(*CSC: (expected type + inferred type). Just for now we use the usual *) -(*CSC: type-inference, but the result is very poor. As a very weak *) -(*CSC: patch, I apply whd to the computed type. Full beta *) -(*CSC: reduction would be a much better option. *) -(*CSC: solo per testare i tempi *) -(*XXXXXXX *) - try -(* *) - let {D.synthesized = synthesized; D.expected = expected} = - if computeinnertypes then - cic_CicHash_find terms_to_types tt - else - (* We are already in an inner-type and Coscoy's double *) - (* type inference algorithm has not been applied. *) - { D.synthesized = -(***CSC: patch per provare i tempi - CicReduction.whd context (xxx_type_of_aux' metasenv context tt) ; *) - (*if global_computeinnertypes then - Cic.Sort (Cic.Type (CicUniv.fresh())) - else*) - cicReduction_whd context (xxx_type_of_aux' metasenv context tt); - D.expected = None} - in -(* incr number_new_type_of_aux' ; *) - let innersort = (*XXXXX *) xxx_type_of_aux' metasenv context synthesized (* Cic.Sort Cic.Prop *) in - let ainnertypes,expected_available = - if computeinnertypes then - let annexpected,expected_available = - match expected with - None -> None,false - | Some expectedty' -> - Some - (aux false (Some fresh_id'') context idrefs expectedty'), - true - in - Some - {annsynthesized = - aux false (Some fresh_id'') context idrefs synthesized ; - annexpected = annexpected - }, expected_available - else - None,false - in - ainnertypes,synthesized, sort_of innersort, expected_available -(*XXXXXXXX *) - with - Not_found -> (* l'inner-type non e' nella tabella ==> sort <> Prop *) - (* CSC: Type or Set? I can not tell *) - let u = CicUniv.fresh() in - None,Cic.Sort (Cic.Type u),`Type u,false - (* TASSI non dovrebbe fare danni *) -(* *) - in - let aux' = - if innersort = `Prop then - aux computeinnertypes (Some fresh_id'') - else - aux false (Some fresh_id'') - in - let add_inner_type id = - match ainnertypes with - None -> () - | Some ainnertypes -> xxx_add ids_to_inner_types id ainnertypes - in - match tt with - C.Rel n -> - let id = - match get_nth "1" context n with - (Some (C.Name s,_)) -> s - | _ -> "__" ^ string_of_int n - in - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - if innersort = `Prop && expected_available then - add_inner_type fresh_id'' ; - C.ARel (fresh_id'', List.nth idrefs (n-1), n, id) - | C.Var (uri,exp_named_subst) -> - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - if innersort = `Prop && expected_available then - add_inner_type fresh_id'' ; - let exp_named_subst' = - List.map - (function i,t -> i, (aux' context idrefs t)) exp_named_subst - in - C.AVar (fresh_id'', uri,exp_named_subst') - | C.Meta (n,l) -> - let (_,canonical_context,_) = CicUtil.lookup_meta n metasenv in - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - if innersort = `Prop && expected_available then - add_inner_type fresh_id'' ; - C.AMeta (fresh_id'', n, - (List.map2 - (fun ct t -> - match (ct, t) with - | None, _ -> None - | _, Some t -> Some (aux' context idrefs t) - | Some _, None -> assert false (* due to typing rules *)) - canonical_context l)) - | C.Sort s -> C.ASort (fresh_id'', s) - | C.Implicit annotation -> C.AImplicit (fresh_id'', annotation) - | C.Cast (v,t) -> - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - if innersort = `Prop then - add_inner_type fresh_id'' ; - C.ACast (fresh_id'', aux' context idrefs v, aux' context idrefs t) - | C.Prod (n,s,t) -> - xxx_add ids_to_inner_sorts fresh_id'' - (sort_of innertype) ; - let sourcetype = xxx_type_of_aux' metasenv context s in - xxx_add ids_to_inner_sorts (source_id_of_id fresh_id'') - (sort_of sourcetype) ; - let n' = - match n with - C.Anonymous -> n - | C.Name n' -> - if DoubleTypeInference.does_not_occur 1 t then - C.Anonymous - else - C.Name n' - in - C.AProd - (fresh_id'', n', aux' context idrefs s, - aux' ((Some (n, C.Decl s))::context) (fresh_id''::idrefs) t) - | C.Lambda (n,s,t) -> - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - let sourcetype = xxx_type_of_aux' metasenv context s in - xxx_add ids_to_inner_sorts (source_id_of_id fresh_id'') - (sort_of sourcetype) ; - if innersort = `Prop then - begin - let father_is_lambda = - match father with - None -> false - | Some father' -> - match Hashtbl.find ids_to_terms father' with - C.Lambda _ -> true - | _ -> false - in - if (not father_is_lambda) || expected_available then - add_inner_type fresh_id'' - end ; - C.ALambda - (fresh_id'',n, aux' context idrefs s, - aux' ((Some (n, C.Decl s)::context)) (fresh_id''::idrefs) t) - | C.LetIn (n,s,ty,t) -> - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - if innersort = `Prop then - add_inner_type fresh_id'' ; - C.ALetIn - (fresh_id'', n, aux' context idrefs s, aux' context idrefs ty, - aux' ((Some (n, C.Def(s,ty)))::context) (fresh_id''::idrefs) t) - | C.Appl l -> - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - if innersort = `Prop then - add_inner_type fresh_id'' ; - C.AAppl (fresh_id'', List.map (aux' context idrefs) l) - | C.Const (uri,exp_named_subst) -> - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - if innersort = `Prop && expected_available then - add_inner_type fresh_id'' ; - let exp_named_subst' = - List.map - (function i,t -> i, (aux' context idrefs t)) exp_named_subst - in - C.AConst (fresh_id'', uri, exp_named_subst') - | C.MutInd (uri,tyno,exp_named_subst) -> - let exp_named_subst' = - List.map - (function i,t -> i, (aux' context idrefs t)) exp_named_subst - in - C.AMutInd (fresh_id'', uri, tyno, exp_named_subst') - | C.MutConstruct (uri,tyno,consno,exp_named_subst) -> - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - if innersort = `Prop && expected_available then - add_inner_type fresh_id'' ; - let exp_named_subst' = - List.map - (function i,t -> i, (aux' context idrefs t)) exp_named_subst - in - C.AMutConstruct (fresh_id'', uri, tyno, consno, exp_named_subst') - | C.MutCase (uri, tyno, outty, term, patterns) -> - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - if innersort = `Prop then - add_inner_type fresh_id'' ; - C.AMutCase (fresh_id'', uri, tyno, aux' context idrefs outty, - aux' context idrefs term, List.map (aux' context idrefs) patterns) - | C.Fix (funno, funs) -> - let fresh_idrefs = - List.map (function _ -> gen_id seed) funs in - let new_idrefs = List.rev fresh_idrefs @ idrefs in - let tys,_ = - List.fold_left - (fun (types,len) (n,_,ty,_) -> - (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types, - len+1) - ) ([],0) funs - in - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - if innersort = `Prop then - add_inner_type fresh_id'' ; - C.AFix (fresh_id'', funno, - List.map2 - (fun id (name, indidx, ty, bo) -> - (id, name, indidx, aux' context idrefs ty, - aux' (tys@context) new_idrefs bo) - ) fresh_idrefs funs - ) - | C.CoFix (funno, funs) -> - let fresh_idrefs = - List.map (function _ -> gen_id seed) funs in - let new_idrefs = List.rev fresh_idrefs @ idrefs in - let tys,_ = - List.fold_left - (fun (types,len) (n,ty,_) -> - (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types, - len+1) - ) ([],0) funs - in - xxx_add ids_to_inner_sorts fresh_id'' innersort ; - if innersort = `Prop then - add_inner_type fresh_id'' ; - C.ACoFix (fresh_id'', funno, - List.map2 - (fun id (name, ty, bo) -> - (id, name, aux' context idrefs ty, - aux' (tys@context) new_idrefs bo) - ) fresh_idrefs funs - ) - in -(* - let timea = Sys.time () in - let res = aux true None context idrefs t in - let timeb = Sys.time () in - prerr_endline - ("+++++++++++++ Tempi della aux dentro alla acic_of_cic: "^ string_of_float (timeb -. timea)) ; - res -*) - aux global_computeinnertypes None context idrefs t -;; - -let acic_of_cic_context ~computeinnertypes metasenv context idrefs t = - let ids_to_terms = Hashtbl.create 503 in - let ids_to_father_ids = Hashtbl.create 503 in - let ids_to_inner_sorts = Hashtbl.create 503 in - let ids_to_inner_types = Hashtbl.create 503 in - let seed = ref 0 in - acic_of_cic_context' ~computeinnertypes seed ids_to_terms ids_to_father_ids ids_to_inner_sorts - ids_to_inner_types metasenv context idrefs t, - ids_to_terms, ids_to_father_ids, ids_to_inner_sorts, ids_to_inner_types -;; - -let aconjecture_of_conjecture seed ids_to_terms ids_to_father_ids - ids_to_inner_sorts ids_to_inner_types ids_to_hypotheses hypotheses_seed - metasenv (metano,context,goal) -= - let computeinnertypes = false in - let acic_of_cic_context = - acic_of_cic_context' seed ids_to_terms ids_to_father_ids ids_to_inner_sorts - ids_to_inner_types metasenv in - let _, acontext,final_idrefs = - (List.fold_right - (fun binding (context, acontext,idrefs) -> - let hid = "h" ^ string_of_int !hypotheses_seed in - Hashtbl.add ids_to_hypotheses hid binding ; - incr hypotheses_seed ; - match binding with - Some (n,Cic.Def (t,ty)) -> - let acic = - acic_of_cic_context ~computeinnertypes context idrefs t - None in - let acic2 = - acic_of_cic_context ~computeinnertypes context idrefs ty - None - in - Hashtbl.replace ids_to_father_ids (CicUtil.id_of_annterm acic) - (Some hid); - Hashtbl.replace ids_to_father_ids - (CicUtil.id_of_annterm acic2) (Some hid); - (binding::context), - ((hid,Some (n,Cic.ADef (acic,acic2)))::acontext), - (hid::idrefs) - | Some (n,Cic.Decl t) -> - let acic = acic_of_cic_context ~computeinnertypes context idrefs t None in - Hashtbl.replace ids_to_father_ids (CicUtil.id_of_annterm acic) - (Some hid); - (binding::context), - ((hid,Some (n,Cic.ADecl acic))::acontext),(hid::idrefs) - | None -> - (* Invariant: "" is never looked up *) - (None::context),((hid,None)::acontext),""::idrefs - ) context ([],[],[]) - ) - in - let agoal = acic_of_cic_context ~computeinnertypes context final_idrefs goal None in - (metano,acontext,agoal) -;; - -let asequent_of_sequent (metasenv:Cic.metasenv) (sequent:Cic.conjecture) = - let ids_to_terms = Hashtbl.create 503 in - let ids_to_father_ids = Hashtbl.create 503 in - let ids_to_inner_sorts = Hashtbl.create 503 in - let ids_to_inner_types = Hashtbl.create 503 in - let ids_to_hypotheses = Hashtbl.create 23 in - let hypotheses_seed = ref 0 in - let seed = ref 1 in (* 'i0' is used for the whole sequent *) - let unsh_sequent = - let i,canonical_context,term = sequent in - let canonical_context' = - List.fold_right - (fun d canonical_context' -> - let d = - match d with - None -> None - | Some (n, Cic.Decl t)-> - Some (n, Cic.Decl (Unshare.unshare t)) - | Some (n,Cic.Def (bo,ty)) -> - Some (n, Cic.Def (Unshare.unshare bo,Unshare.unshare ty)) - in - d::canonical_context' - ) canonical_context [] - in - let term' = Unshare.unshare term in - (i,canonical_context',term') - in - let (metano,acontext,agoal) = - aconjecture_of_conjecture seed ids_to_terms ids_to_father_ids - ids_to_inner_sorts ids_to_inner_types ids_to_hypotheses hypotheses_seed - metasenv unsh_sequent in - (unsh_sequent, - (("i0",metano,acontext,agoal), - ids_to_terms,ids_to_father_ids,ids_to_inner_sorts,ids_to_hypotheses)) -;; - -let acic_term_or_object_of_cic_term_or_object ?(eta_fix=false) () = - let module C = Cic in - let module E = Eta_fixing in - let ids_to_terms = Hashtbl.create 503 in - let ids_to_father_ids = Hashtbl.create 503 in - let ids_to_inner_sorts = Hashtbl.create 503 in - let ids_to_inner_types = Hashtbl.create 503 in - let ids_to_conjectures = Hashtbl.create 11 in - let ids_to_hypotheses = Hashtbl.create 127 in - let hypotheses_seed = ref 0 in - let conjectures_seed = ref 0 in - let seed = ref 0 in - let acic_term_of_cic_term_context' = - acic_of_cic_context' seed ids_to_terms ids_to_father_ids ids_to_inner_sorts - ids_to_inner_types in - let acic_term_of_cic_term' = acic_term_of_cic_term_context' [] [] [] in - let aconjecture_of_conjecture' = aconjecture_of_conjecture seed - ids_to_terms ids_to_father_ids ids_to_inner_sorts ids_to_inner_types - ids_to_hypotheses hypotheses_seed in - let eta_fix_and_unshare metasenv context t = - let t = if eta_fix then E.eta_fix metasenv context t else t in - Unshare.unshare t in - (fun context t -> - let map = function - | None -> None - | Some (n, C.Decl ty) -> Some (n, C.Decl (Unshare.unshare ty)) - | Some (n, C.Def (bo, ty)) -> - Some (n, C.Def (Unshare.unshare bo, Unshare.unshare ty)) - in - let t = Unshare.unshare t in - let context = List.map map context in - let idrefs = List.map (function _ -> gen_id seed) context in - let t = acic_term_of_cic_term_context' ~computeinnertypes:true [] context idrefs t None in - t, ids_to_inner_sorts, ids_to_inner_types - ),(function obj -> - let aobj = - match obj with - C.Constant (id,Some bo,ty,params,attrs) -> - let bo' = (*eta_fix_and_unshare[] [] bo*) Unshare.unshare bo in - let ty' = eta_fix_and_unshare [] [] ty in - let abo = acic_term_of_cic_term' ~computeinnertypes:true bo' (Some ty') in - let aty = acic_term_of_cic_term' ~computeinnertypes:false ty' None in - C.AConstant - ("mettereaposto",Some "mettereaposto2",id,Some abo,aty,params,attrs) - | C.Constant (id,None,ty,params,attrs) -> - let ty' = eta_fix_and_unshare [] [] ty in - let aty = acic_term_of_cic_term' ~computeinnertypes:false ty' None in - C.AConstant - ("mettereaposto",None,id,None,aty,params,attrs) - | C.Variable (id,bo,ty,params,attrs) -> - let ty' = eta_fix_and_unshare [] [] ty in - let abo = - match bo with - None -> None - | Some bo -> - let bo' = eta_fix_and_unshare [] [] bo in - Some (acic_term_of_cic_term' ~computeinnertypes:true bo' (Some ty')) - in - let aty = acic_term_of_cic_term' ~computeinnertypes:false ty' None in - C.AVariable - ("mettereaposto",id,abo,aty,params,attrs) - | C.CurrentProof (id,conjectures,bo,ty,params,attrs) -> - let conjectures' = - List.map - (function (i,canonical_context,term) -> - let canonical_context' = - List.fold_right - (fun d canonical_context' -> - let d = - match d with - None -> None - | Some (n, C.Decl t)-> - Some (n, C.Decl (eta_fix_and_unshare conjectures canonical_context' t)) - | Some (n, C.Def (t,ty)) -> - Some (n, - C.Def - (eta_fix_and_unshare conjectures canonical_context' t, - eta_fix_and_unshare conjectures canonical_context' ty)) - in - d::canonical_context' - ) canonical_context [] - in - let term' = eta_fix_and_unshare conjectures canonical_context' term in - (i,canonical_context',term') - ) conjectures - in - let aconjectures = - List.map - (function (i,canonical_context,term) as conjecture -> - let cid = "c" ^ string_of_int !conjectures_seed in - xxx_add ids_to_conjectures cid conjecture ; - incr conjectures_seed ; - let (i,acanonical_context,aterm) - = aconjecture_of_conjecture' conjectures conjecture in - (cid,i,acanonical_context,aterm)) - conjectures' in - (* let bo' = eta_fix conjectures' [] bo in *) - let bo' = bo in - let ty' = eta_fix_and_unshare conjectures' [] ty in -(* - let time2 = Sys.time () in - prerr_endline - ("++++++++++ Tempi della eta_fix: "^ string_of_float (time2 -. time1)) ; - hashtbl_add_time := 0.0 ; - type_of_aux'_add_time := 0.0 ; - DoubleTypeInference.syntactic_equality_add_time := 0.0 ; -*) - let abo = - acic_term_of_cic_term_context' ~computeinnertypes:true conjectures' [] [] bo' (Some ty') in - let aty = acic_term_of_cic_term_context' ~computeinnertypes:false conjectures' [] [] ty' None in -(* - let time3 = Sys.time () in - prerr_endline - ("++++++++++++ Tempi della hashtbl_add_time: " ^ string_of_float !hashtbl_add_time) ; - prerr_endline - ("++++++++++++ Tempi della type_of_aux'_add_time(" ^ string_of_int !number_new_type_of_aux' ^ "): " ^ string_of_float !type_of_aux'_add_time) ; - prerr_endline - ("++++++++++++ Tempi della type_of_aux'_add_time nella double_type_inference(" ^ string_of_int !DoubleTypeInference.number_new_type_of_aux'_double_work ^ ";" ^ string_of_int !DoubleTypeInference.number_new_type_of_aux'_prop ^ "/" ^ string_of_int !DoubleTypeInference.number_new_type_of_aux' ^ "): " ^ string_of_float !DoubleTypeInference.type_of_aux'_add_time) ; - prerr_endline - ("++++++++++++ Tempi della syntactic_equality_add_time: " ^ string_of_float !DoubleTypeInference.syntactic_equality_add_time) ; - prerr_endline - ("++++++++++ Tempi della acic_of_cic: " ^ string_of_float (time3 -. time2)) ; - prerr_endline - ("++++++++++ Numero di iterazioni della acic_of_cic: " ^ string_of_int !seed) ; -*) - C.ACurrentProof - ("mettereaposto","mettereaposto2",id,aconjectures,abo,aty,params,attrs) - | C.InductiveDefinition (tys,params,paramsno,attrs) -> - let tys = - List.map - (fun (name,i,arity,cl) -> - (name,i,Unshare.unshare arity, - List.map (fun (name,ty) -> name,Unshare.unshare ty) cl)) tys in - let context = - List.map - (fun (name,_,arity,_) -> - Some (C.Name name, C.Decl (Unshare.unshare arity))) tys in - let idrefs = List.map (function _ -> gen_id seed) tys in - let atys = - List.map2 - (fun id (name,inductive,ty,cons) -> - let acons = - List.map - (function (name,ty) -> - (name, - acic_term_of_cic_term_context' ~computeinnertypes:false [] context idrefs ty None) - ) cons - in - (id,name,inductive, - acic_term_of_cic_term' ~computeinnertypes:false ty None,acons) - ) (List.rev idrefs) tys - in - C.AInductiveDefinition ("mettereaposto",atys,params,paramsno,attrs) - in - aobj,ids_to_terms,ids_to_father_ids,ids_to_inner_sorts,ids_to_inner_types, - ids_to_conjectures,ids_to_hypotheses -);; - -let acic_object_of_cic_object ?eta_fix = - snd (acic_term_or_object_of_cic_term_or_object ?eta_fix ()) - -let plain_acic_term_of_cic_term = - let module C = Cic in - let mk_fresh_id = - let id = ref 0 in - function () -> incr id; "i" ^ string_of_int !id in - let rec aux context t = - let fresh_id = mk_fresh_id () in - match t with - C.Rel n -> - let idref,id = - match get_nth "2" context n with - idref,(Some (C.Name s,_)) -> idref,s - | idref,_ -> idref,"__" ^ string_of_int n - in - C.ARel (fresh_id, idref, n, id) - | C.Var (uri,exp_named_subst) -> - let exp_named_subst' = - List.map - (function i,t -> i, (aux context t)) exp_named_subst - in - C.AVar (fresh_id,uri,exp_named_subst') - | C.Implicit _ - | C.Meta _ -> assert false - | C.Sort s -> C.ASort (fresh_id, s) - | C.Cast (v,t) -> - C.ACast (fresh_id, aux context v, aux context t) - | C.Prod (n,s,t) -> - C.AProd - (fresh_id, n, aux context s, - aux ((fresh_id, Some (n, C.Decl s))::context) t) - | C.Lambda (n,s,t) -> - C.ALambda - (fresh_id,n, aux context s, - aux ((fresh_id, Some (n, C.Decl s))::context) t) - | C.LetIn (n,s,ty,t) -> - C.ALetIn - (fresh_id, n, aux context s, aux context ty, - aux ((fresh_id, Some (n, C.Def(s,ty)))::context) t) - | C.Appl l -> - C.AAppl (fresh_id, List.map (aux context) l) - | C.Const (uri,exp_named_subst) -> - let exp_named_subst' = - List.map - (function i,t -> i, (aux context t)) exp_named_subst - in - C.AConst (fresh_id, uri, exp_named_subst') - | C.MutInd (uri,tyno,exp_named_subst) -> - let exp_named_subst' = - List.map - (function i,t -> i, (aux context t)) exp_named_subst - in - C.AMutInd (fresh_id, uri, tyno, exp_named_subst') - | C.MutConstruct (uri,tyno,consno,exp_named_subst) -> - let exp_named_subst' = - List.map - (function i,t -> i, (aux context t)) exp_named_subst - in - C.AMutConstruct (fresh_id, uri, tyno, consno, exp_named_subst') - | C.MutCase (uri, tyno, outty, term, patterns) -> - C.AMutCase (fresh_id, uri, tyno, aux context outty, - aux context term, List.map (aux context) patterns) - | C.Fix (funno, funs) -> - let tys,_ = - List.fold_left - (fun (types,len) (n,_,ty,_) -> - (mk_fresh_id (),(Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))))::types, - len+1 - ) ([],0) funs - in - C.AFix (fresh_id, funno, - List.map2 - (fun (id,_) (name, indidx, ty, bo) -> - (id, name, indidx, aux context ty, aux (tys@context) bo) - ) tys funs - ) - | C.CoFix (funno, funs) -> - let tys,_ = - List.fold_left - (fun (types,len) (n,ty,_) -> - (mk_fresh_id (),(Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))))::types, - len+1 - ) ([],0) funs - in - C.ACoFix (fresh_id, funno, - List.map2 - (fun (id,_) (name, ty, bo) -> - (id, name, aux context ty, aux (tys@context) bo) - ) tys funs - ) - in - aux -;; - -let plain_acic_object_of_cic_object obj = - let module C = Cic in - let mk_fresh_id = - let id = ref 0 in - function () -> incr id; "it" ^ string_of_int !id - in - match obj with - C.Constant (id,Some bo,ty,params,attrs) -> - let abo = plain_acic_term_of_cic_term [] bo in - let aty = plain_acic_term_of_cic_term [] ty in - C.AConstant - ("mettereaposto",Some "mettereaposto2",id,Some abo,aty,params,attrs) - | C.Constant (id,None,ty,params,attrs) -> - let aty = plain_acic_term_of_cic_term [] ty in - C.AConstant - ("mettereaposto",None,id,None,aty,params,attrs) - | C.Variable (id,bo,ty,params,attrs) -> - let abo = - match bo with - None -> None - | Some bo -> Some (plain_acic_term_of_cic_term [] bo) - in - let aty = plain_acic_term_of_cic_term [] ty in - C.AVariable - ("mettereaposto",id,abo,aty,params,attrs) - | C.CurrentProof _ -> assert false - | C.InductiveDefinition (tys,params,paramsno,attrs) -> - let context = - List.map - (fun (name,_,arity,_) -> - mk_fresh_id (), Some (C.Name name, C.Decl arity)) tys in - let atys = - List.map2 - (fun (id,_) (name,inductive,ty,cons) -> - let acons = - List.map - (function (name,ty) -> - (name, - plain_acic_term_of_cic_term context ty) - ) cons - in - (id,name,inductive,plain_acic_term_of_cic_term [] ty,acons) - ) context tys - in - C.AInductiveDefinition ("mettereaposto",atys,params,paramsno,attrs) -;; - -let acic_term_of_cic_term ?eta_fix = - fst (acic_term_or_object_of_cic_term_or_object ?eta_fix ()) diff --git a/matita/components/cic_acic/cic2acic.mli b/matita/components/cic_acic/cic2acic.mli deleted file mode 100644 index 0bf874e86..000000000 --- a/matita/components/cic_acic/cic2acic.mli +++ /dev/null @@ -1,68 +0,0 @@ -(* Copyright (C) 2000, 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/. - *) - -exception NotEnoughElements of string - -val source_id_of_id : string -> string - -type anntypes = - {annsynthesized : Cic.annterm ; annexpected : Cic.annterm option} -;; - -type sort_kind = [ `Prop | `Set | `Type of CicUniv.universe | `CProp of CicUniv.universe | `NType of string | `NCProp of string] - -val string_of_sort: sort_kind -> string -(*val sort_of_string: string -> sort_kind*) -val sort_of_sort: Cic.sort -> sort_kind - -val acic_object_of_cic_object : - ?eta_fix: bool -> (* perform eta_fixing; default: true*) - Cic.obj -> (* object *) - Cic.annobj * (* annotated object *) - (Cic.id, Cic.term) Hashtbl.t * (* ids_to_terms *) - (Cic.id, Cic.id option) Hashtbl.t * (* ids_to_father_ids *) - (Cic.id, sort_kind) Hashtbl.t * (* ids_to_inner_sorts *) - (Cic.id, anntypes) Hashtbl.t * (* ids_to_inner_types *) - (Cic.id, Cic.conjecture) Hashtbl.t * (* ids_to_conjectures *) - (Cic.id, Cic.hypothesis) Hashtbl.t (* ids_to_hypotheses *) - -val asequent_of_sequent : - Cic.metasenv -> (* metasenv *) - Cic.conjecture -> (* sequent *) - Cic.conjecture * (* unshared sequent *) - (Cic.annconjecture * (* annotated sequent *) - (Cic.id, Cic.term) Hashtbl.t * (* ids_to_terms *) - (Cic.id, Cic.id option) Hashtbl.t * (* ids_to_father_ids *) - (Cic.id, sort_kind) Hashtbl.t * (* ids_to_inner_sorts *) - (Cic.id, Cic.hypothesis) Hashtbl.t) (* ids_to_hypotheses *) - -val plain_acic_object_of_cic_object : Cic.obj -> Cic.annobj - -val acic_term_of_cic_term : - ?eta_fix: bool -> (* perform eta_fixing; default: true*) - Cic.context -> Cic.term -> (* term and context *) - Cic.annterm * (* annotated term *) - (Cic.id, sort_kind) Hashtbl.t * (* ids_to_inner_sorts *) - (Cic.id, anntypes) Hashtbl.t (* ids_to_inner_types *) diff --git a/matita/components/cic_acic/doubleTypeInference.ml b/matita/components/cic_acic/doubleTypeInference.ml deleted file mode 100644 index 4ca88d4b9..000000000 --- a/matita/components/cic_acic/doubleTypeInference.ml +++ /dev/null @@ -1,682 +0,0 @@ -(* Copyright (C) 2000, 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$ *) - -exception Impossible of int;; -exception NotWellTyped of string;; -exception WrongUriToConstant of string;; -exception WrongUriToVariable of string;; -exception WrongUriToMutualInductiveDefinitions of string;; -exception ListTooShort;; -exception RelToHiddenHypothesis;; - -(*CSC: must alfa-conversion be considered or not? *) - -let xxx_type_of_aux' m c t = - try - Some (fst (CicTypeChecker.type_of_aux' m c t CicUniv.oblivion_ugraph)) - with - | CicTypeChecker.TypeCheckerFailure _ -> None (* because eta_expansion *) -;; - -type types = {synthesized : Cic.term ; expected : Cic.term option};; - -(* does_not_occur n te *) -(* returns [true] if [Rel n] does not occur in [te] *) -let rec does_not_occur n = - let module C = Cic in - function - C.Rel m when m = n -> false - | C.Rel _ -(* FG/CSC: maybe we assume the meta is guarded so we do not recur on its *) -(* explicit subsitutions (copied from the kernel) ??? *) - | C.Meta _ - | C.Sort _ - | C.Implicit _ -> true - | C.Cast (te,ty) -> - does_not_occur n te && does_not_occur n ty - | C.Prod (name,so,dest) -> - does_not_occur n so && - does_not_occur (n + 1) dest - | C.Lambda (name,so,dest) -> - does_not_occur n so && - does_not_occur (n + 1) dest - | C.LetIn (name,so,ty,dest) -> - does_not_occur n so && - does_not_occur n ty && - does_not_occur (n + 1) dest - | C.Appl l -> - List.fold_right (fun x i -> i && does_not_occur n x) l true - | C.Var (_,exp_named_subst) - | C.Const (_,exp_named_subst) - | C.MutInd (_,_,exp_named_subst) - | C.MutConstruct (_,_,_,exp_named_subst) -> - List.fold_right (fun (_,x) i -> i && does_not_occur n x) - exp_named_subst true - | C.MutCase (_,_,out,te,pl) -> - does_not_occur n out && does_not_occur n te && - List.fold_right (fun x i -> i && does_not_occur n x) pl true - | C.Fix (_,fl) -> - let len = List.length fl in - let n_plus_len = n + len in - List.fold_right - (fun (_,_,ty,bo) i -> - i && does_not_occur n ty && - does_not_occur n_plus_len bo - ) fl true - | C.CoFix (_,fl) -> - let len = List.length fl in - let n_plus_len = n + len in - List.fold_right - (fun (_,ty,bo) i -> - i && does_not_occur n ty && - does_not_occur n_plus_len bo - ) fl true -;; - -(* FG: if ~clean:true, unreferenced letins are removed *) -(* (beta-reducttion can cause unreferenced letins) *) -let rec beta_reduce ?(clean=false)= - let module S = CicSubstitution in - let module C = Cic in - function - C.Rel _ as t -> t - | C.Var (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (function (i,t) -> i, beta_reduce ~clean t) exp_named_subst - in - C.Var (uri,exp_named_subst') - | C.Meta (n,l) -> - C.Meta (n, - List.map - (function None -> None | Some t -> Some (beta_reduce ~clean t)) l - ) - | C.Sort _ as t -> t - | C.Implicit _ -> assert false - | C.Cast (te,ty) -> - C.Cast (beta_reduce ~clean te, beta_reduce ~clean ty) - | C.Prod (n,s,t) -> - C.Prod (n, beta_reduce ~clean s, beta_reduce ~clean t) - | C.Lambda (n,s,t) -> - C.Lambda (n, beta_reduce ~clean s, beta_reduce ~clean t) - | C.LetIn (n,s,ty,t) -> - let t' = beta_reduce ~clean t in - if clean && does_not_occur 1 t' then - (* since [Rel 1] does not occur in typ, substituting any term *) - (* in place of [Rel 1] is equivalent to delifting once *) - CicSubstitution.subst (C.Implicit None) t' - else - C.LetIn (n, beta_reduce ~clean s, beta_reduce ~clean ty, t') - | C.Appl ((C.Lambda (name,s,t))::he::tl) -> - let he' = S.subst he t in - if tl = [] then - beta_reduce ~clean he' - else - (match he' with - C.Appl l -> beta_reduce ~clean (C.Appl (l@tl)) - | _ -> beta_reduce ~clean (C.Appl (he'::tl))) - | C.Appl l -> - C.Appl (List.map (beta_reduce ~clean) l) - | C.Const (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (function (i,t) -> i, beta_reduce ~clean t) exp_named_subst - in - C.Const (uri,exp_named_subst') - | C.MutInd (uri,i,exp_named_subst) -> - let exp_named_subst' = - List.map (function (i,t) -> i, beta_reduce ~clean t) exp_named_subst - in - C.MutInd (uri,i,exp_named_subst') - | C.MutConstruct (uri,i,j,exp_named_subst) -> - let exp_named_subst' = - List.map (function (i,t) -> i, beta_reduce ~clean t) exp_named_subst - in - C.MutConstruct (uri,i,j,exp_named_subst') - | C.MutCase (sp,i,outt,t,pl) -> - C.MutCase (sp,i,beta_reduce ~clean outt,beta_reduce ~clean t, - List.map (beta_reduce ~clean) pl) - | C.Fix (i,fl) -> - let fl' = - List.map - (function (name,i,ty,bo) -> - name,i,beta_reduce ~clean ty,beta_reduce ~clean bo - ) fl - in - C.Fix (i,fl') - | C.CoFix (i,fl) -> - let fl' = - List.map - (function (name,ty,bo) -> - name,beta_reduce ~clean ty,beta_reduce ~clean bo - ) fl - in - C.CoFix (i,fl') -;; - -let rec split l n = - match (l,n) with - (l,0) -> ([], l) - | (he::tl, n) -> let (l1,l2) = split tl (n-1) in (he::l1,l2) - | (_,_) -> raise ListTooShort -;; - -let type_of_constant uri = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - let cobj = - match CicEnvironment.is_type_checked CicUniv.oblivion_ugraph uri with - CicEnvironment.CheckedObj (cobj,_) -> cobj - | CicEnvironment.UncheckedObj (uobj,_) -> - raise (NotWellTyped "Reference to an unchecked constant") - in - match cobj with - C.Constant (_,_,ty,_,_) -> ty - | C.CurrentProof (_,_,_,ty,_,_) -> ty - | _ -> raise (WrongUriToConstant (U.string_of_uri uri)) -;; - -let type_of_variable uri = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - match CicEnvironment.is_type_checked CicUniv.oblivion_ugraph uri with - CicEnvironment.CheckedObj ((C.Variable (_,_,ty,_,_)),_) -> ty - | CicEnvironment.UncheckedObj (C.Variable _,_) -> - raise (NotWellTyped "Reference to an unchecked variable") - | _ -> raise (WrongUriToVariable (UriManager.string_of_uri uri)) -;; - -let type_of_mutual_inductive_defs uri i = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - let cobj = - match CicEnvironment.is_type_checked CicUniv.oblivion_ugraph uri with - CicEnvironment.CheckedObj (cobj,_) -> cobj - | CicEnvironment.UncheckedObj (uobj,_) -> - raise (NotWellTyped "Reference to an unchecked inductive type") - in - match cobj with - C.InductiveDefinition (dl,_,_,_) -> - let (_,_,arity,_) = List.nth dl i in - arity - | _ -> raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)) -;; - -let type_of_mutual_inductive_constr uri i j = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - let cobj = - match CicEnvironment.is_type_checked CicUniv.oblivion_ugraph uri with - CicEnvironment.CheckedObj (cobj,_) -> cobj - | CicEnvironment.UncheckedObj (uobj,_) -> - raise (NotWellTyped "Reference to an unchecked constructor") - in - match cobj with - C.InductiveDefinition (dl,_,_,_) -> - let (_,_,_,cl) = List.nth dl i in - let (_,ty) = List.nth cl (j-1) in - ty - | _ -> raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)) -;; - -let pack_coercion = ref (fun _ _ _ -> assert false);; - -let profiler_for_find = HExtlib.profile "CicHash ADD" ;; - -let cic_CicHash_add a b c = - profiler_for_find.HExtlib.profile (Cic.CicHash.add a b) c -;; - -let profiler_for_find1 = HExtlib.profile "CicHash MEM" ;; - -let cic_CicHash_mem a b = - profiler_for_find1.HExtlib.profile (Cic.CicHash.mem a) b -;; - -(* type_of_aux' is just another name (with a different scope) for type_of_aux *) -let rec type_of_aux' subterms_to_types metasenv context t expectedty = - (* Coscoy's double type-inference algorithm *) - (* It computes the inner-types of every subterm of [t], *) - (* even when they are not needed to compute the types *) - (* of other terms. *) - let rec type_of_aux context t expectedty = - let module C = Cic in - let module R = CicReduction in - let module S = CicSubstitution in - let module U = UriManager in - let expectedty = - match expectedty with - None -> None - | Some t -> Some (!pack_coercion metasenv context t) in - let synthesized = - match t with - C.Rel n -> - (try - match List.nth context (n - 1) with - Some (_,C.Decl t) -> S.lift n t - | Some (_,C.Def (_,ty)) -> S.lift n ty - | None -> raise RelToHiddenHypothesis - with - _ -> raise (NotWellTyped "Not a close term") - ) - | C.Var (uri,exp_named_subst) -> - visit_exp_named_subst context uri exp_named_subst ; - CicSubstitution.subst_vars exp_named_subst (type_of_variable uri) - | C.Meta (n,l) -> - (* Let's visit all the subterms that will not be visited later *) - let (_,canonical_context,_) = CicUtil.lookup_meta n metasenv in - let lifted_canonical_context = - let rec aux i = - function - [] -> [] - | (Some (n,C.Decl t))::tl -> - (Some (n,C.Decl (S.subst_meta l (S.lift i t))))::(aux (i+1) tl) - | (Some (n,C.Def (t,ty)))::tl -> - (Some (n, - C.Def - ((S.subst_meta l (S.lift i t)),S.subst_meta l (S.lift i t)))):: - (aux (i+1) tl) - | None::tl -> None::(aux (i+1) tl) - in - aux 1 canonical_context - in - let _ = - List.iter2 - (fun t ct -> - match t,ct with - _,None -> () - | Some t,Some (_,C.Def (ct,_)) -> - let expected_type = - match xxx_type_of_aux' metasenv context ct with - | None -> None - | Some t -> Some (R.whd context t) - in - (* Maybe I am a bit too paranoid, because *) - (* if the term is well-typed than t and ct *) - (* are convertible. Nevertheless, I compute *) - (* the expected type. *) - ignore (type_of_aux context t expected_type) - | Some t,Some (_,C.Decl ct) -> - ignore (type_of_aux context t (Some ct)) - | _,_ -> assert false (* the term is not well typed!!! *) - ) l lifted_canonical_context - in - let (_,canonical_context,ty) = CicUtil.lookup_meta n metasenv in - (* Checks suppressed *) - CicSubstitution.subst_meta l ty - | C.Sort (C.Type t) -> (* TASSI: CONSTRAINT *) - C.Sort (C.Type (CicUniv.fresh())) - | C.Sort _ -> C.Sort (C.Type (CicUniv.fresh())) (* TASSI: CONSTRAINT *) - | C.Implicit _ -> raise (Impossible 21) - | C.Cast (te,ty) -> - (* Let's visit all the subterms that will not be visited later *) - let _ = type_of_aux context te (Some (beta_reduce ty)) in - let _ = type_of_aux context ty None in - (* Checks suppressed *) - ty - | C.Prod (name,s,t) -> - let sort1 = type_of_aux context s None - and sort2 = type_of_aux ((Some (name,(C.Decl s)))::context) t None in - sort_of_prod context (name,s) (sort1,sort2) - | C.Lambda (n,s,t) -> - (* Let's visit all the subterms that will not be visited later *) - let _ = type_of_aux context s None in - let n, expected_target_type = - match expectedty with - | None -> n, None - | Some expectedty' -> - let n, ty = - match R.whd context expectedty' with - | C.Prod (n',_,expected_target_type) -> - let xtt = beta_reduce expected_target_type in - if n <> C.Anonymous then n, xtt else n', xtt - | _ -> assert false - in - n, Some ty - in - let type2 = - type_of_aux ((Some (n,(C.Decl s)))::context) t expected_target_type - in - (* Checks suppressed *) - C.Prod (n,s,type2) - | C.LetIn (n,s,ty,t) -> -(*CSC: What are the right expected types for the source and *) -(*CSC: target of a LetIn? None used. *) - (* Let's visit all the subterms that will not be visited later *) - let _ = type_of_aux context ty None in - let _ = type_of_aux context s (Some ty) in - let t_typ = - (* Checks suppressed *) - type_of_aux ((Some (n,(C.Def (s,ty))))::context) t None - in (* CicSubstitution.subst s t_typ *) - if does_not_occur 1 t_typ then - (* since [Rel 1] does not occur in typ, substituting any term *) - (* in place of [Rel 1] is equivalent to delifting once *) - CicSubstitution.subst (C.Implicit None) t_typ - else - C.LetIn (n,s,ty,t_typ) - | C.Appl (he::tl) when List.length tl > 0 -> - (* - let expected_hetype = - (* Inefficient, the head is computed twice. But I know *) - (* of no other solution. *) - (beta_reduce - (R.whd context (xxx_type_of_aux' metasenv context he))) - in - let hetype = type_of_aux context he (Some expected_hetype) in - let tlbody_and_type = - let rec aux = - function - _,[] -> [] - | C.Prod (n,s,t),he::tl -> - (he, type_of_aux context he (Some (beta_reduce s))):: - (aux (R.whd context (S.subst he t), tl)) - | _ -> assert false - in - aux (expected_hetype, tl) *) - let hetype = R.whd context (type_of_aux context he None) in - let tlbody_and_type = - let rec aux = - function - _,[] -> [] - | C.Prod (n,s,t),he::tl -> - (he, type_of_aux context he (Some (beta_reduce s))):: - (aux (R.whd context (S.subst he t), tl)) - | _ -> assert false - in - aux (hetype, tl) - in - eat_prods context hetype tlbody_and_type - | C.Appl _ -> raise (NotWellTyped "Appl: no arguments") - | C.Const (uri,exp_named_subst) -> - visit_exp_named_subst context uri exp_named_subst ; - CicSubstitution.subst_vars exp_named_subst (type_of_constant uri) - | C.MutInd (uri,i,exp_named_subst) -> - visit_exp_named_subst context uri exp_named_subst ; - CicSubstitution.subst_vars exp_named_subst - (type_of_mutual_inductive_defs uri i) - | C.MutConstruct (uri,i,j,exp_named_subst) -> - visit_exp_named_subst context uri exp_named_subst ; - CicSubstitution.subst_vars exp_named_subst - (type_of_mutual_inductive_constr uri i j) - | C.MutCase (uri,i,outtype,term,pl) -> - let outsort = type_of_aux context outtype None in - let (need_dummy, k) = - let rec guess_args context t = - match CicReduction.whd context t with - C.Sort _ -> (true, 0) - | C.Prod (name, s, t) -> - let (b, n) = guess_args ((Some (name,(C.Decl s)))::context) t in - if n = 0 then - (* last prod before sort *) - match CicReduction.whd context s with - C.MutInd (uri',i',_) when U.eq uri' uri && i' = i -> - (false, 1) - | C.Appl ((C.MutInd (uri',i',_)) :: _) - when U.eq uri' uri && i' = i -> (false, 1) - | _ -> (true, 1) - else - (b, n + 1) - | _ -> raise (NotWellTyped "MutCase: outtype ill-formed") - in - let (b, k) = guess_args context outsort in - if not b then (b, k - 1) else (b, k) - in - let (parameters, arguments,exp_named_subst) = - let type_of_term = - match xxx_type_of_aux' metasenv context term with - | None -> None - | Some t -> Some (beta_reduce t) - in - match - R.whd context (type_of_aux context term type_of_term) - with - (*CSC manca il caso dei CAST *) - C.MutInd (uri',i',exp_named_subst) -> - (* Checks suppressed *) - [],[],exp_named_subst - | C.Appl (C.MutInd (uri',i',exp_named_subst) :: tl) -> - let params,args = - split tl (List.length tl - k) - in params,args,exp_named_subst - | _ -> - raise (NotWellTyped "MutCase: the term is not an inductive one") - in - (* Checks suppressed *) - (* Let's visit all the subterms that will not be visited later *) - let (cl,parsno) = - let obj,_ = - try - CicEnvironment.get_cooked_obj CicUniv.oblivion_ugraph uri - with Not_found -> assert false - in - match obj with - C.InductiveDefinition (tl,_,parsno,_) -> - let (_,_,_,cl) = List.nth tl i in (cl,parsno) - | _ -> - raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)) - in - let _ = - List.fold_left - (fun j (p,(_,c)) -> - let cons = - if parameters = [] then - (C.MutConstruct (uri,i,j,exp_named_subst)) - else - (C.Appl (C.MutConstruct (uri,i,j,exp_named_subst)::parameters)) - in - let expectedtype = - match xxx_type_of_aux' metasenv context cons with - | None -> None - | Some t -> - Some - (beta_reduce - (type_of_branch context parsno need_dummy outtype - cons t)) - in - ignore (type_of_aux context p expectedtype); - j+1 - ) 1 (List.combine pl cl) - in - if not need_dummy then - C.Appl ((outtype::arguments)@[term]) - else if arguments = [] then - outtype - else - C.Appl (outtype::arguments) - | C.Fix (i,fl) -> - (* Let's visit all the subterms that will not be visited later *) - let context' = - List.rev - (List.map - (fun (n,_,ty,_) -> - let _ = type_of_aux context ty None in - (Some (C.Name n,(C.Decl ty))) - ) fl - ) @ - context - in - let _ = - List.iter - (fun (_,_,ty,bo) -> - let expectedty = - beta_reduce (CicSubstitution.lift (List.length fl) ty) - in - ignore (type_of_aux context' bo (Some expectedty)) - ) fl - in - (* Checks suppressed *) - let (_,_,ty,_) = List.nth fl i in - ty - | C.CoFix (i,fl) -> - (* Let's visit all the subterms that will not be visited later *) - let context' = - List.rev - (List.map - (fun (n,ty,_) -> - let _ = type_of_aux context ty None in - (Some (C.Name n,(C.Decl ty))) - ) fl - ) @ - context - in - let _ = - List.iter - (fun (_,ty,bo) -> - let expectedty = - beta_reduce (CicSubstitution.lift (List.length fl) ty) - in - ignore (type_of_aux context' bo (Some expectedty)) - ) fl - in - (* Checks suppressed *) - let (_,ty,_) = List.nth fl i in - ty - in -(* FG: beta-reduction can cause unreferenced letins *) - let synthesized' = beta_reduce ~clean:true synthesized in - let synthesized' = !pack_coercion metasenv context synthesized' in - let types,res = - match expectedty with - None -> - (* No expected type *) - {synthesized = synthesized' ; expected = None}, synthesized - | Some ty when CicUtil.alpha_equivalence synthesized' ty -> - (* The expected type is synthactically equal to *) - (* the synthesized type. Let's forget it. *) - {synthesized = synthesized' ; expected = None}, synthesized - | Some expectedty' -> - {synthesized = synthesized' ; expected = Some expectedty'}, - expectedty' - in -(* assert (not (cic_CicHash_mem subterms_to_types t));*) - cic_CicHash_add subterms_to_types t types ; - res - - and visit_exp_named_subst context uri exp_named_subst = - let uris_and_types = - let obj,_ = - try - CicEnvironment.get_cooked_obj CicUniv.oblivion_ugraph uri - with Not_found -> assert false - in - let params = CicUtil.params_of_obj obj in - List.map - (function uri -> - let obj,_ = - try - CicEnvironment.get_cooked_obj CicUniv.oblivion_ugraph uri - with Not_found -> assert false - in - match obj with - Cic.Variable (_,None,ty,_,_) -> uri,ty - | _ -> assert false (* the theorem is well-typed *) - ) params - in - let rec check uris_and_types subst = - match uris_and_types,subst with - _,[] -> () - | (uri,ty)::tytl,(uri',t)::substtl when uri = uri' -> - ignore (type_of_aux context t (Some ty)) ; - let tytl' = - List.map - (function uri,t' -> uri,(CicSubstitution.subst_vars [uri',t] t')) tytl - in - check tytl' substtl - | _,_ -> assert false (* the theorem is well-typed *) - in - check uris_and_types exp_named_subst - - and sort_of_prod context (name,s) (t1, t2) = - let module C = Cic in - let t1' = CicReduction.whd context t1 in - let t2' = CicReduction.whd ((Some (name,C.Decl s))::context) t2 in - match (t1', t2') with - | (C.Sort _, C.Sort s2) when (s2 = C.Prop || s2 = C.Set) -> C.Sort s2 - | (C.Sort (C.Type t1), C.Sort (C.Type t2)) ->C.Sort(C.Type(CicUniv.fresh())) - | (C.Sort _,C.Sort (C.Type t1)) -> C.Sort (C.Type t1) - | (C.Sort _,C.Sort (C.CProp t1)) -> C.Sort (C.CProp t1) - | (C.Meta _, C.Sort _) -> t2' - | (C.Meta _, (C.Meta (_,_) as t)) - | (C.Sort _, (C.Meta (_,_) as t)) when CicUtil.is_closed t -> - t2' - | (_,_) -> - raise - (NotWellTyped - ("Prod: sort1= " ^ CicPp.ppterm t1' ^ " ; sort2= " ^ CicPp.ppterm t2')) - - and eat_prods context hetype = - (*CSC: siamo sicuri che le are_convertible non lavorino con termini non *) - (*CSC: cucinati *) - function - [] -> hetype - | (hete, hety)::tl -> - (match (CicReduction.whd context hetype) with - Cic.Prod (n,s,t) -> - (* Checks suppressed *) - eat_prods context (CicSubstitution.subst hete t) tl - | _ -> raise (NotWellTyped "Appl: wrong Prod-type") - ) - -and type_of_branch context argsno need_dummy outtype term constype = - let module C = Cic in - let module R = CicReduction in - match R.whd context constype with - C.MutInd (_,_,_) -> - if need_dummy then - outtype - else - C.Appl [outtype ; term] - | C.Appl (C.MutInd (_,_,_)::tl) -> - let (_,arguments) = split tl argsno - in - if need_dummy && arguments = [] then - outtype - else - C.Appl (outtype::arguments@(if need_dummy then [] else [term])) - | C.Prod (name,so,de) -> - let term' = - match CicSubstitution.lift 1 term with - C.Appl l -> C.Appl (l@[C.Rel 1]) - | t -> C.Appl [t ; C.Rel 1] - in - C.Prod (C.Anonymous,so,type_of_branch - ((Some (name,(C.Decl so)))::context) argsno need_dummy - (CicSubstitution.lift 1 outtype) term' de) - | _ -> raise (Impossible 20) - - in - type_of_aux context t expectedty -;; - -let double_type_of metasenv context t expectedty = - let subterms_to_types = Cic.CicHash.create 503 in - ignore (type_of_aux' subterms_to_types metasenv context t expectedty) ; - subterms_to_types -;; diff --git a/matita/components/cic_acic/doubleTypeInference.mli b/matita/components/cic_acic/doubleTypeInference.mli deleted file mode 100644 index dcc7b66bd..000000000 --- a/matita/components/cic_acic/doubleTypeInference.mli +++ /dev/null @@ -1,21 +0,0 @@ -exception Impossible of int -exception NotWellTyped of string -exception WrongUriToConstant of string -exception WrongUriToVariable of string -exception WrongUriToMutualInductiveDefinitions of string -exception ListTooShort -exception RelToHiddenHypothesis - -type types = {synthesized : Cic.term ; expected : Cic.term option};; - -val pack_coercion : (Cic.metasenv -> Cic.context -> Cic.term -> Cic.term) ref;; - -val double_type_of : - Cic.metasenv -> Cic.context -> Cic.term -> Cic.term option -> - types Cic.CicHash.t - -(** Auxiliary functions **) - -(* does_not_occur n te *) -(* returns [true] if [Rel n] does not occur in [te] *) -val does_not_occur : int -> Cic.term -> bool diff --git a/matita/components/cic_acic/eta_fixing.ml b/matita/components/cic_acic/eta_fixing.ml deleted file mode 100644 index 9ebd48b8b..000000000 --- a/matita/components/cic_acic/eta_fixing.ml +++ /dev/null @@ -1,314 +0,0 @@ -(* Copyright (C) 2000, 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$ *) - -exception ReferenceToNonVariable;; - -let prerr_endline _ = ();; - -(* -let rec fix_lambdas_wrt_type ty te = - let module C = Cic in - let module S = CicSubstitution in -(* prerr_endline ("entering fix_lambdas: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *) - match ty with - C.Prod (_,_,ty') -> - (match CicReduction.whd [] te with - C.Lambda (n,s,te') -> - C.Lambda (n,s,fix_lambdas_wrt_type ty' te') - | t -> - let rec get_sources = - function - C.Prod (_,s,ty) -> s::(get_sources ty) - | _ -> [] in - let sources = get_sources ty in - let no_sources = List.length sources in - let rec mk_rels n shift = - if n = 0 then [] - else (C.Rel (n + shift))::(mk_rels (n - 1) shift) in - let t' = S.lift no_sources t in - let t2 = - match t' with - C.Appl l -> - C.LetIn - (C.Name "w",t',C.Appl ((C.Rel 1)::(mk_rels no_sources 1))) - | _ -> - C.Appl (t'::(mk_rels no_sources 0)) in - List.fold_right - (fun source t -> C.Lambda (C.Name "y",source,t)) - sources t2) - | _ -> te -;; *) - -let rec fix_lambdas_wrt_type ty te = - let module C = Cic in - let module S = CicSubstitution in -(* prerr_endline ("entering fix_lambdas: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *) - match ty,te with - C.Prod (_,_,ty'), C.Lambda (n,s,te') -> - C.Lambda (n,s,fix_lambdas_wrt_type ty' te') - | C.Prod (_,s,ty'), t -> - let rec get_sources = - function - C.Prod (_,s,ty) -> s::(get_sources ty) - | _ -> [] in - let sources = get_sources ty in - let no_sources = List.length sources in - let rec mk_rels n shift = - if n = 0 then [] - else (C.Rel (n + shift))::(mk_rels (n - 1) shift) in - let t' = S.lift no_sources t in - let t2 = - match t' with - C.Appl l -> - C.LetIn (C.Name "w",t',assert false, - C.Appl ((C.Rel 1)::(mk_rels no_sources 1))) - | _ -> C.Appl (t'::(mk_rels no_sources 0)) in - List.fold_right - (fun source t -> C.Lambda (C.Name "y",CicReduction.whd [] source,t)) sources t2 - | _, _ -> te -;; - -(* -let rec fix_lambdas_wrt_type ty te = - let module C = Cic in - let module S = CicSubstitution in -(* prerr_endline ("entering fix_lambdas: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *) - match ty,te with - C.Prod (_,_,ty'), C.Lambda (n,s,te') -> - C.Lambda (n,s,fix_lambdas_wrt_type ty' te') - | C.Prod (_,s,ty'), ((C.Appl (C.Const _ ::_)) as t) -> - (* const have a fixed arity *) - (* prerr_endline ("******** fl - eta expansion 0: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *) - let t' = S.lift 1 t in - C.Lambda (C.Name "x",s, - C.LetIn - (C.Name "H", fix_lambdas_wrt_type ty' t', - C.Appl [C.Rel 1;C.Rel 2])) - | C.Prod (_,s,ty'), C.Appl l -> - (* prerr_endline ("******** fl - eta expansion 1: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *) - let l' = List.map (S.lift 1) l in - C.Lambda (C.Name "x",s, - fix_lambdas_wrt_type ty' (C.Appl (l'@[C.Rel 1]))) - | C.Prod (_,s,ty'), _ -> - (* prerr_endline ("******** fl - eta expansion 2: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm te); *) - flush stderr ; - let te' = S.lift 1 te in - C.Lambda (C.Name "x",s, - fix_lambdas_wrt_type ty' (C.Appl [te';C.Rel 1])) - | _, _ -> te -;;*) - -let fix_according_to_type ty hd tl = - let module C = Cic in - let module S = CicSubstitution in - let rec count_prods = - function - C.Prod (_,_,t) -> 1 + (count_prods t) - | _ -> 0 in - let expected_arity = count_prods ty in - let rec aux n ty tl res = - if n = 0 then - (match tl with - [] -> - (match res with - [] -> assert false - | [res] -> res - | _ -> C.Appl res) - | _ -> - match res with - [] -> assert false - | [a] -> C.Appl (a::tl) - | _ -> - (* prerr_endline ("******* too many args: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm (C.Appl res)); *) - C.LetIn - (C.Name "H", - C.Appl res, - assert false, - C.Appl (C.Rel 1::(List.map (S.lift 1) tl)))) - else - let name,source,target = - (match ty with - C.Prod (C.Name _ as n,s,t) -> n,s,t - | C.Prod (C.Anonymous, s,t) -> C.Name "z",s,t - | _ -> (* prods number may only increase for substitution *) - assert false) in - match tl with - [] -> - (* prerr_endline ("******* too few args: type=" ^ CicPp.ppterm ty ^ "term=" ^ CicPp.ppterm (C.Appl res)); *) - let res' = List.map (S.lift 1) res in - C.Lambda - (name, source, aux (n-1) target [] (res'@[C.Rel 1])) - | hd::tl' -> - let hd' = fix_lambdas_wrt_type source hd in - (* (prerr_endline ("++++++prima :" ^(CicPp.ppterm hd)); - prerr_endline ("++++++dopo :" ^(CicPp.ppterm hd'))); *) - aux (n-1) (S.subst hd' target) tl' (res@[hd']) in - aux expected_arity ty tl [hd] -;; - -let eta_fix metasenv context t = - let rec eta_fix' context t = - (* prerr_endline ("entering aux with: term=" ^ CicPp.ppterm t); - flush stderr ; *) - let module C = Cic in - let module S = CicSubstitution in - match t with - C.Rel n -> C.Rel n - | C.Var (uri,exp_named_subst) -> - let exp_named_subst' = fix_exp_named_subst context exp_named_subst in - C.Var (uri,exp_named_subst') - | C.Meta (n,l) -> - let (_,canonical_context,_) = CicUtil.lookup_meta n metasenv in - let l' = - List.map2 - (fun ct t -> - match (ct, t) with - None, _ -> None - | _, Some t -> Some (eta_fix' context t) - | Some _, None -> assert false (* due to typing rules *)) - canonical_context l - in - C.Meta (n,l') - | C.Sort s -> C.Sort s - | C.Implicit _ as t -> t - | C.Cast (v,t) -> C.Cast (eta_fix' context v, eta_fix' context t) - | C.Prod (n,s,t) -> - C.Prod - (n, eta_fix' context s, eta_fix' ((Some (n,(C.Decl s)))::context) t) - | C.Lambda (n,s,t) -> - C.Lambda - (n, eta_fix' context s, eta_fix' ((Some (n,(C.Decl s)))::context) t) - | C.LetIn (n,s,ty,t) -> - C.LetIn - (n,eta_fix' context s,eta_fix' context ty, - eta_fix' ((Some (n,(C.Def (s,ty))))::context) t) - | C.Appl [] -> assert false - | C.Appl (he::tl) -> - let tl' = List.map (eta_fix' context) tl in - let ty,_ = - CicTypeChecker.type_of_aux' metasenv context he - CicUniv.oblivion_ugraph - in - fix_according_to_type ty (eta_fix' context he) tl' -(* - C.Const(uri,exp_named_subst)::l'' -> - let constant_type = - (match CicEnvironment.get_obj uri with - C.Constant (_,_,ty,_) -> ty - | C.Variable _ -> raise ReferenceToVariable - | C.CurrentProof (_,_,_,_,params) -> raise ReferenceToCurrentProof - | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition - ) in - fix_according_to_type - constant_type (C.Const(uri,exp_named_subst)) l'' - | _ -> C.Appl l' *) - | C.Const (uri,exp_named_subst) -> - let exp_named_subst' = fix_exp_named_subst context exp_named_subst in - C.Const (uri,exp_named_subst') - | C.MutInd (uri,tyno,exp_named_subst) -> - let exp_named_subst' = fix_exp_named_subst context exp_named_subst in - C.MutInd (uri, tyno, exp_named_subst') - | C.MutConstruct (uri,tyno,consno,exp_named_subst) -> - let exp_named_subst' = fix_exp_named_subst context exp_named_subst in - C.MutConstruct (uri, tyno, consno, exp_named_subst') - | C.MutCase (uri, tyno, outty, term, patterns) -> - let outty' = eta_fix' context outty in - let term' = eta_fix' context term in - let patterns' = List.map (eta_fix' context) patterns in - let inductive_types,noparams = - let o,_ = CicEnvironment.get_obj CicUniv.oblivion_ugraph uri in - (match o with - Cic.Constant _ -> assert false - | Cic.Variable _ -> assert false - | Cic.CurrentProof _ -> assert false - | Cic.InductiveDefinition (l,_,n,_) -> l,n - ) in - let (_,_,_,constructors) = List.nth inductive_types tyno in - let constructor_types = - let rec clean_up t = - function - [] -> t - | a::tl -> - (match t with - Cic.Prod (_,_,t') -> clean_up (S.subst a t') tl - | _ -> assert false) in - if noparams = 0 then - List.map (fun (_,t) -> t) constructors - else - let term_type,_ = - CicTypeChecker.type_of_aux' metasenv context term - CicUniv.oblivion_ugraph - in - (match term_type with - C.Appl (hd::params) -> - let rec first_n n l = - if n = 0 then [] - else - (match l with - a::tl -> a::(first_n (n-1) tl) - | _ -> assert false) in - List.map - (fun (_,t) -> - clean_up t (first_n noparams params)) constructors - | _ -> prerr_endline ("QUA"); assert false) in - let patterns2 = - List.map2 fix_lambdas_wrt_type - constructor_types patterns' in - C.MutCase (uri, tyno, outty',term',patterns2) - | C.Fix (funno, funs) -> - let fun_types = - List.map (fun (n,_,ty,_) -> Some (C.Name n,(Cic.Decl ty))) funs in - C.Fix (funno, - List.map - (fun (name, no, ty, bo) -> - (name, no, eta_fix' context ty, eta_fix' (fun_types@context) bo)) - funs) - | C.CoFix (funno, funs) -> - let fun_types = - List.map (fun (n,ty,_) -> Some (C.Name n,(Cic.Decl ty))) funs in - C.CoFix (funno, - List.map - (fun (name, ty, bo) -> - (name, eta_fix' context ty, eta_fix' (fun_types@context) bo)) funs) - and fix_exp_named_subst context exp_named_subst = - List.rev - (List.fold_left - (fun newsubst (uri,t) -> - let t' = eta_fix' context t in - let ty = - let o,_ = CicEnvironment.get_obj CicUniv.oblivion_ugraph uri in - match o with - Cic.Variable (_,_,ty,_,_) -> - CicSubstitution.subst_vars newsubst ty - | _ -> raise ReferenceToNonVariable - in - let t'' = fix_according_to_type ty t' [] in - (uri,t'')::newsubst - ) [] exp_named_subst) - in - eta_fix' context t -;; diff --git a/matita/components/cic_acic/eta_fixing.mli b/matita/components/cic_acic/eta_fixing.mli deleted file mode 100644 index c6c68119d..000000000 --- a/matita/components/cic_acic/eta_fixing.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* Copyright (C) 2000, 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/. - *) - -val eta_fix : Cic.metasenv -> Cic.context -> Cic.term -> Cic.term - - diff --git a/matita/components/cic_exportation/.depend b/matita/components/cic_exportation/.depend deleted file mode 100644 index 91be8d88d..000000000 --- a/matita/components/cic_exportation/.depend +++ /dev/null @@ -1,3 +0,0 @@ -cicExportation.cmi: -cicExportation.cmo: cicExportation.cmi -cicExportation.cmx: cicExportation.cmi diff --git a/matita/components/cic_exportation/.depend.opt b/matita/components/cic_exportation/.depend.opt deleted file mode 100644 index 91be8d88d..000000000 --- a/matita/components/cic_exportation/.depend.opt +++ /dev/null @@ -1,3 +0,0 @@ -cicExportation.cmi: -cicExportation.cmo: cicExportation.cmi -cicExportation.cmx: cicExportation.cmi diff --git a/matita/components/cic_exportation/Makefile b/matita/components/cic_exportation/Makefile deleted file mode 100644 index 3062749b6..000000000 --- a/matita/components/cic_exportation/Makefile +++ /dev/null @@ -1,14 +0,0 @@ -PACKAGE = cic_exportation -PREDICATES = - -INTERFACE_FILES = \ - cicExportation.mli \ - $(NULL) -IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) - -# Metadata tools only need zeta-reduction -EXTRA_OBJECTS_TO_INSTALL = -EXTRA_OBJECTS_TO_CLEAN = - -include ../../Makefile.defs -include ../Makefile.common diff --git a/matita/components/cic_exportation/cicExportation.ml b/matita/components/cic_exportation/cicExportation.ml deleted file mode 100644 index c595c6d7d..000000000 --- a/matita/components/cic_exportation/cicExportation.ml +++ /dev/null @@ -1,674 +0,0 @@ -(* Copyright (C) 2000, 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: cicPp.ml 7413 2007-05-29 15:30:53Z tassi $ *) - -exception CicExportationInternalError;; -exception NotEnoughElements;; - -(* *) - -let is_mcu_type u = - UriManager.eq (UriManager.uri_of_string - "cic:/matita/freescale/opcode/mcu_type.ind") u -;; - -(* Utility functions *) - -let analyze_term context t = - match fst(CicTypeChecker.type_of_aux' [] context t CicUniv.oblivion_ugraph)with - | Cic.Sort _ -> `Type - | Cic.MutInd (u,0,_) when is_mcu_type u -> `Optimize - | ty -> - match - fst (CicTypeChecker.type_of_aux' [] context ty CicUniv.oblivion_ugraph) - with - | Cic.Sort Cic.Prop -> `Proof - | _ -> `Term -;; - -let analyze_type context t = - let rec aux = - function - Cic.Sort s -> `Sort s - | Cic.MutInd (u,0,_) when is_mcu_type u -> `Optimize - | Cic.Prod (_,_,t) -> aux t - | _ -> `SomethingElse - in - match aux t with - `Sort _ | `Optimize as res -> res - | `SomethingElse -> - match - fst(CicTypeChecker.type_of_aux' [] context t CicUniv.oblivion_ugraph) - with - Cic.Sort Cic.Prop -> `Statement - | _ -> `Type -;; - -let ppid = - let reserved = - [ "to"; - "mod"; - "val"; - "in"; - "function" - ] - in - function n -> - let n = String.uncapitalize n in - if List.mem n reserved then n ^ "_" else n -;; - -let ppname = - function - Cic.Name s -> ppid s - | Cic.Anonymous -> "_" -;; - -(* get_nth l n returns the nth element of the list l if it exists or *) -(* raises NotEnoughElements if l has less than n elements *) -let rec get_nth l n = - match (n,l) with - (1, he::_) -> he - | (n, he::tail) when n > 1 -> get_nth tail (n-1) - | (_,_) -> raise NotEnoughElements -;; - -let qualified_name_of_uri current_module_uri ?(capitalize=false) uri = - let name = - if capitalize then - String.capitalize (UriManager.name_of_uri uri) - else - ppid (UriManager.name_of_uri uri) in - let filename = - let suri = UriManager.buri_of_uri uri in - let s = String.sub suri 5 (String.length suri - 5) in - let s = Pcre.replace ~pat:"/" ~templ:"_" s in - String.uncapitalize s in - if current_module_uri = UriManager.buri_of_uri uri then - name - else - String.capitalize filename ^ "." ^ name -;; - -let current_go_up = ref "(.!(";; -let at_level2 f x = - try - current_go_up := "(.~("; - let rc = f x in - current_go_up := "(.!("; - rc - with exn -> - current_go_up := "(.!("; - raise exn -;; - -let pp current_module_uri ?metasenv ~in_type = -let rec pp ~in_type t context = - let module C = Cic in - match t with - C.Rel n -> - begin - try - (match get_nth context n with - Some (C.Name s,_) -> ppid s - | Some (C.Anonymous,_) -> "__" ^ string_of_int n - | None -> "_hidden_" ^ string_of_int n - ) - with - NotEnoughElements -> string_of_int (List.length context - n) - end - | C.Var (uri,exp_named_subst) -> - qualified_name_of_uri current_module_uri uri ^ - pp_exp_named_subst exp_named_subst context - | C.Meta (n,l1) -> - (match metasenv with - None -> - "?" ^ (string_of_int n) ^ "[" ^ - String.concat " ; " - (List.rev_map - (function - None -> "_" - | Some t -> pp ~in_type:false t context) l1) ^ - "]" - | Some metasenv -> - try - let _,context,_ = CicUtil.lookup_meta n metasenv in - "?" ^ (string_of_int n) ^ "[" ^ - String.concat " ; " - (List.rev - (List.map2 - (fun x y -> - match x,y with - _, None - | None, _ -> "_" - | Some _, Some t -> pp ~in_type:false t context - ) context l1)) ^ - "]" - with - CicUtil.Meta_not_found _ - | Invalid_argument _ -> - "???" ^ (string_of_int n) ^ "[" ^ - String.concat " ; " - (List.rev_map (function None -> "_" | Some t -> - pp ~in_type:false t context) l1) ^ - "]" - ) - | C.Sort s -> - (match s with - C.Prop -> "Prop" - | C.Set -> "Set" - | C.Type _ -> "Type" - (*| C.Type u -> ("Type" ^ CicUniv.string_of_universe u)*) - | C.CProp _ -> "CProp" - ) - | C.Implicit (Some `Hole) -> "%" - | C.Implicit _ -> "?" - | C.Prod (b,s,t) -> - (match b with - C.Name n -> - let n = "'" ^ String.uncapitalize n in - "(" ^ pp ~in_type:true s context ^ " -> " ^ - pp ~in_type:true t ((Some (Cic.Name n,Cic.Decl s))::context) ^ ")" - | C.Anonymous -> - "(" ^ pp ~in_type:true s context ^ " -> " ^ - pp ~in_type:true t ((Some (b,Cic.Decl s))::context) ^ ")") - | C.Cast (v,t) -> pp ~in_type v context - | C.Lambda (b,s,t) -> - (match analyze_type context s with - `Sort _ - | `Statement -> pp ~in_type t ((Some (b,Cic.Decl s))::context) - | `Optimize -> prerr_endline "XXX lambda";assert false - | `Type -> - "(function " ^ ppname b ^ " -> " ^ - pp ~in_type t ((Some (b,Cic.Decl s))::context) ^ ")") - | C.LetIn (b,s,ty,t) -> - (match analyze_term context s with - | `Type - | `Proof -> pp ~in_type t ((Some (b,Cic.Def (s,ty)))::context) - | `Optimize - | `Term -> - "(let " ^ ppname b ^ (*" : " ^ pp ~in_type:true ty context ^*) - " = " ^ pp ~in_type:false s context ^ " in " ^ - pp ~in_type t ((Some (b,Cic.Def (s,ty)))::context) ^ ")") - | C.Appl (he::tl) when in_type -> - let hes = pp ~in_type he context in - let stl = String.concat "," (clean_args_for_ty context tl) in - (if stl = "" then "" else "(" ^ stl ^ ") ") ^ hes - | C.Appl (C.MutInd _ as he::tl) -> - let hes = pp ~in_type he context in - let stl = String.concat "," (clean_args_for_ty context tl) in - (if stl = "" then "" else "(" ^ stl ^ ") ") ^ hes - | C.Appl (C.MutConstruct (uri,n,_,_) as he::tl) -> - let nparams = - match fst(CicEnvironment.get_obj CicUniv.oblivion_ugraph uri) with - C.InductiveDefinition (_,_,nparams,_) -> nparams - | _ -> assert false in - let hes = pp ~in_type he context in - let stl = String.concat "," (clean_args_for_constr nparams context tl) in - "(" ^ hes ^ (if stl = "" then "" else "(" ^ stl ^ ")") ^ ")" - | C.Appl li -> - "(" ^ String.concat " " (clean_args context li) ^ ")" - | C.Const (uri,exp_named_subst) -> - qualified_name_of_uri current_module_uri uri ^ - pp_exp_named_subst exp_named_subst context - | C.MutInd (uri,n,exp_named_subst) -> - (try - match fst(CicEnvironment.get_obj CicUniv.oblivion_ugraph uri) with - C.InductiveDefinition (dl,_,_,_) -> - let (name,_,_,_) = get_nth dl (n+1) in - qualified_name_of_uri current_module_uri - (UriManager.uri_of_string - (UriManager.buri_of_uri uri ^ "/" ^ name ^ ".con")) ^ - pp_exp_named_subst exp_named_subst context - | _ -> raise CicExportationInternalError - with - Sys.Break as exn -> raise exn - | _ -> UriManager.string_of_uri uri ^ "#1/" ^ string_of_int (n + 1) - ) - | C.MutConstruct (uri,n1,n2,exp_named_subst) -> - (try - match fst(CicEnvironment.get_obj CicUniv.oblivion_ugraph uri) with - C.InductiveDefinition (dl,_,_,_) -> - let _,_,_,cons = get_nth dl (n1+1) in - let id,_ = get_nth cons n2 in - qualified_name_of_uri current_module_uri ~capitalize:true - (UriManager.uri_of_string - (UriManager.buri_of_uri uri ^ "/" ^ id ^ ".con")) ^ - pp_exp_named_subst exp_named_subst context - | _ -> raise CicExportationInternalError - with - Sys.Break as exn -> raise exn - | _ -> - UriManager.string_of_uri uri ^ "#1/" ^ string_of_int (n1 + 1) ^ "/" ^ - string_of_int n2 - ) - | C.MutCase (uri,n1,ty,te,patterns) -> - if in_type then - "unit (* TOO POLYMORPHIC TYPE *)" - else ( - let rec needs_obj_magic ty = - match CicReduction.whd context ty with - | Cic.Lambda (_,_,(Cic.Lambda(_,_,_) as t)) -> needs_obj_magic t - | Cic.Lambda (_,_,t) -> not (DoubleTypeInference.does_not_occur 1 t) - | _ -> false (* it can be a Rel, e.g. in *_rec *) - in - let needs_obj_magic = needs_obj_magic ty in - (match analyze_term context te with - `Type -> assert false - | `Proof -> - (match patterns with - [] -> "assert false" (* empty type elimination *) - | [he] -> - pp ~in_type:false he context (* singleton elimination *) - | _ -> assert false) - | `Optimize - | `Term -> - if patterns = [] then "assert false" - else - (let connames_and_argsno, go_up, go_pu, go_down, go_nwod = - (match fst(CicEnvironment.get_obj CicUniv.oblivion_ugraph uri) with - C.InductiveDefinition (dl,_,paramsno,_) -> - let (_,_,_,cons) = get_nth dl (n1+1) in - let rc = - List.map - (fun (id,ty) -> - (* this is just an approximation since we do not have - reduction yet! *) - let rec count_prods toskip = - function - C.Prod (_,_,bo) when toskip > 0 -> - count_prods (toskip - 1) bo - | C.Prod (_,_,bo) -> 1 + count_prods 0 bo - | _ -> 0 - in - qualified_name_of_uri current_module_uri - ~capitalize:true - (UriManager.uri_of_string - (UriManager.buri_of_uri uri ^ "/" ^ id ^ ".con")), - count_prods paramsno ty - ) cons - in - if not (is_mcu_type uri) then rc, "","","","" - else rc, !current_go_up, "))", "( .< (", " ) >.)" - | _ -> raise CicExportationInternalError - ) - in - let connames_and_argsno_and_patterns = - let rec combine = - function - [],[] -> [] - | (x,no)::tlx,y::tly -> (x,no,y)::(combine (tlx,tly)) - | _,_ -> assert false - in - combine (connames_and_argsno,patterns) - in - go_up ^ - "\n(match " ^ pp ~in_type:false te context ^ " with \n " ^ - (String.concat "\n | " - (List.map - (fun (x,argsno,y) -> - let rec aux argsno context = - function - Cic.Lambda (name,ty,bo) when argsno > 0 -> - let name = - match name with - Cic.Anonymous -> Cic.Anonymous - | Cic.Name n -> Cic.Name (ppid n) in - let args,res = - aux (argsno - 1) (Some (name,Cic.Decl ty)::context) - bo - in - (match analyze_type context ty with - | `Optimize -> prerr_endline "XXX contructor with l2 arg"; assert false - | `Statement - | `Sort _ -> args,res - | `Type -> - (match name with - C.Anonymous -> "_" - | C.Name s -> s)::args,res) - | t when argsno = 0 -> [],pp ~in_type:false t context - | t -> - ["{" ^ string_of_int argsno ^ " args missing}"], - pp ~in_type:false t context - in - let pattern,body = - if argsno = 0 then x,pp ~in_type:false y context - else - let args,body = aux argsno context y in - let sargs = String.concat "," args in - x ^ (if sargs = "" then "" else "(" ^ sargs^ ")"), - body - in - pattern ^ " -> " ^ go_down ^ - (if needs_obj_magic then - "Obj.magic (" ^ body ^ ")" - else - body) ^ go_nwod - ) connames_and_argsno_and_patterns)) ^ - ")\n"^go_pu))) - | C.Fix (no, funs) -> - let names,_ = - List.fold_left - (fun (types,len) (n,_,ty,_) -> - (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types, - len+1) - ) ([],0) funs - in - "let rec " ^ - List.fold_right - (fun (name,ind,ty,bo) i -> name ^ " = \n" ^ - pp ~in_type:false bo (names@context) ^ i) - funs "" ^ - " in " ^ - (match get_nth names (no + 1) with - Some (Cic.Name n,_) -> n - | _ -> assert false) - | C.CoFix (no,funs) -> - let names,_ = - List.fold_left - (fun (types,len) (n,ty,_) -> - (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types, - len+1) - ) ([],0) funs - in - "\nCoFix " ^ " {" ^ - List.fold_right - (fun (name,ty,bo) i -> "\n" ^ name ^ - " : " ^ pp ~in_type:true ty context ^ " := \n" ^ - pp ~in_type:false bo (names@context) ^ i) - funs "" ^ - "}\n" -and pp_exp_named_subst exp_named_subst context = - if exp_named_subst = [] then "" else - "\\subst[" ^ - String.concat " ; " ( - List.map - (function (uri,t) -> UriManager.name_of_uri uri ^ " \\Assign " ^ pp ~in_type:false t context) - exp_named_subst - ) ^ "]" -and clean_args_for_constr nparams context = - let nparams = ref nparams in - HExtlib.filter_map - (function t -> - decr nparams; - match analyze_term context t with - `Term when !nparams < 0 -> Some (pp ~in_type:false t context) - | `Optimize - | `Term - | `Type - | `Proof -> None) -and clean_args context = - function - | [] | [_] -> assert false - | he::arg1::tl as l -> - let head_arg1, rest = - match analyze_term context arg1 with - | `Optimize -> - !current_go_up :: pp ~in_type:false he context :: - pp ~in_type:false arg1 context :: ["))"], tl - | _ -> [], l - in - head_arg1 @ - HExtlib.filter_map - (function t -> - match analyze_term context t with - | `Term -> Some (pp ~in_type:false t context) - | `Optimize -> - prerr_endline "XXX function taking twice (or not as first) a l2 term"; assert false - | `Type - | `Proof -> None) rest -and clean_args_for_ty context = - HExtlib.filter_map - (function t -> - match analyze_term context t with - `Type -> Some (pp ~in_type:true t context) - | `Optimize -> None - | `Proof -> None - | `Term -> None) -in - pp ~in_type -;; - -let ppty current_module_uri = - (* nparams is the number of left arguments - left arguments should either become parameters or be skipped altogether *) - let rec args nparams context = - function - Cic.Prod (n,s,t) -> - let n = - match n with - Cic.Anonymous -> Cic.Anonymous - | Cic.Name n -> Cic.Name (String.uncapitalize n) - in - (match analyze_type context s with - | `Optimize - | `Statement - | `Sort Cic.Prop -> - args (nparams - 1) ((Some (n,Cic.Decl s))::context) t - | `Type when nparams > 0 -> - args (nparams - 1) ((Some (n,Cic.Decl s))::context) t - | `Type -> - let abstr,args = - args (nparams - 1) ((Some (n,Cic.Decl s))::context) t in - abstr,pp ~in_type:true current_module_uri s context::args - | `Sort _ when nparams <= 0 -> - let n = Cic.Name "unit (* EXISTENTIAL TYPE *)" in - args (nparams - 1) ((Some (n,Cic.Decl s))::context) t - | `Sort _ -> - let n = - match n with - Cic.Anonymous -> Cic.Anonymous - | Cic.Name name -> Cic.Name ("'" ^ name) in - let abstr,args = - args (nparams - 1) ((Some (n,Cic.Decl s))::context) t - in - (match n with - Cic.Anonymous -> abstr - | Cic.Name name -> name::abstr), - args) - | _ -> [],[] - in - args -;; - -exception DoNotExtract;; - -let pp_abstracted_ty current_module_uri = - let rec args context = - function - Cic.Lambda (n,s,t) -> - let n = - match n with - Cic.Anonymous -> Cic.Anonymous - | Cic.Name n -> Cic.Name (String.uncapitalize n) - in - (match analyze_type context s with - | `Optimize - | `Statement - | `Type - | `Sort Cic.Prop -> - args ((Some (n,Cic.Decl s))::context) t - | `Sort _ -> - let n = - match n with - Cic.Anonymous -> Cic.Anonymous - | Cic.Name name -> Cic.Name ("'" ^ name) in - let abstr,res = - args ((Some (n,Cic.Decl s))::context) t - in - (match n with - Cic.Anonymous -> abstr - | Cic.Name name -> name::abstr), - res) - | ty -> - match analyze_type context ty with - | `Optimize -> - prerr_endline "XXX abstracted l2 ty"; assert false - | `Sort _ - | `Statement -> raise DoNotExtract - | `Type -> - (* BUG HERE: this can be a real System F type *) - let head = pp ~in_type:true current_module_uri ty context in - [],head - in - args -;; - - -(* ppinductiveType (typename, inductive, arity, cons) *) -(* pretty-prints a single inductive definition *) -(* (typename, inductive, arity, cons) *) -let ppinductiveType current_module_uri nparams (typename, inductive, arity, cons) -= - match analyze_type [] arity with - `Sort Cic.Prop -> "" - | `Optimize - | `Statement - | `Type -> assert false - | `Sort _ -> - if cons = [] then - "type " ^ String.uncapitalize typename ^ " = unit (* empty type *)\n" - else ( - let abstr,scons = - List.fold_right - (fun (id,ty) (_abstr,i) -> (* we should verify _abstr = abstr' *) - let abstr',sargs = ppty current_module_uri nparams [] ty in - let sargs = String.concat " * " sargs in - abstr', - String.capitalize id ^ - (if sargs = "" then "" else " of " ^ sargs) ^ - (if i = "" then "" else "\n | ") ^ i) - cons ([],"") - in - let abstr = - let s = String.concat "," abstr in - if s = "" then "" else "(" ^ s ^ ") " - in - "type " ^ abstr ^ String.uncapitalize typename ^ " =\n" ^ scons ^ "\n") -;; - -let ppobj current_module_uri obj = - let module C = Cic in - let module U = UriManager in - let pp ~in_type = pp ~in_type current_module_uri in - match obj with - C.Constant (name, Some t1, t2, params, _) -> - (match analyze_type [] t2 with - | `Sort Cic.Prop - | `Statement -> "" - | `Optimize - | `Type -> - (match t1 with - | Cic.Lambda (Cic.Name arg, s, t) -> - (match analyze_type [] s with - | `Optimize -> - - "let " ^ ppid name ^ "__1 = function " ^ ppid arg - ^ " -> .< " ^ - at_level2 (pp ~in_type:false t) [Some (Cic.Name arg, Cic.Decl s)] - ^ " >. ;;\n" - ^ "let " ^ ppid name ^ "__2 = ref ([] : (unit list*unit list) list);;\n" - ^ "let " ^ ppid name ^ " = function " ^ ppid arg - ^ " -> (try ignore (List.assoc "^ppid arg^" (Obj.magic !"^ppid name - ^"__2)) with Not_found -> "^ppid name^"__2 := (Obj.magic (" - ^ ppid arg^",.! ("^ppid name^"__1 "^ppid arg^")))::!" - ^ppid name^"__2); .< List.assoc "^ppid arg^" (Obj.magic (!" - ^ppid name^"__2)) >.\n;;\n" - ^" let xxx = prerr_endline \""^ppid name^"\"; .!("^ppid - name^" Matita_freescale_opcode.HCS08)" - | _ -> - "let " ^ ppid name ^ " =\n" ^ pp ~in_type:false t1 [] ^ "\n") - | _ -> "let " ^ ppid name ^ " =\n" ^ pp ~in_type:false t1 [] ^ "\n") - | `Sort _ -> - match analyze_type [] t1 with - `Sort Cic.Prop -> "" - | `Optimize -> prerr_endline "XXX aliasing l2 type"; assert false - | _ -> - (try - let abstr,res = pp_abstracted_ty current_module_uri [] t1 in - let abstr = - let s = String.concat "," abstr in - if s = "" then "" else "(" ^ s ^ ") " - in - "type " ^ abstr ^ ppid name ^ " = " ^ res ^ "\n" - with - DoNotExtract -> "")) - | C.Constant (name, None, ty, params, _) -> - (match analyze_type [] ty with - `Sort Cic.Prop - | `Optimize -> prerr_endline "XXX axiom l2"; assert false - | `Statement -> "" - | `Sort _ -> "type " ^ ppid name ^ "\n" - | `Type -> "let " ^ ppid name ^ " = assert false\n") - | C.Variable (name, bo, ty, params, _) -> - "Variable " ^ name ^ - "(" ^ String.concat ";" (List.map UriManager.string_of_uri params) ^ - ")" ^ ":\n" ^ - pp ~in_type:true ty [] ^ "\n" ^ - (match bo with None -> "" | Some bo -> ":= " ^ pp ~in_type:false bo []) - | C.CurrentProof (name, conjectures, value, ty, params, _) -> - "Current Proof of " ^ name ^ - "(" ^ String.concat ";" (List.map UriManager.string_of_uri params) ^ - ")" ^ ":\n" ^ - let separate s = if s = "" then "" else s ^ " ; " in - List.fold_right - (fun (n, context, t) i -> - let conjectures',name_context = - List.fold_right - (fun context_entry (i,name_context) -> - (match context_entry with - Some (n,C.Decl at) -> - (separate i) ^ - ppname n ^ ":" ^ - pp ~in_type:true ~metasenv:conjectures - at name_context ^ " ", - context_entry::name_context - | Some (n,C.Def (at,aty)) -> - (separate i) ^ - ppname n ^ ":" ^ - pp ~in_type:true ~metasenv:conjectures - aty name_context ^ - ":= " ^ pp ~in_type:false - ~metasenv:conjectures at name_context ^ " ", - context_entry::name_context - | None -> - (separate i) ^ "_ :? _ ", context_entry::name_context) - ) context ("",[]) - in - conjectures' ^ " |- " ^ "?" ^ (string_of_int n) ^ ": " ^ - pp ~in_type:true ~metasenv:conjectures t name_context ^ "\n" ^ i - ) conjectures "" ^ - "\n" ^ pp ~in_type:false ~metasenv:conjectures value [] ^ " : " ^ - pp ~in_type:true ~metasenv:conjectures ty [] - | C.InductiveDefinition (l, params, nparams, _) -> - List.fold_right - (fun x i -> ppinductiveType current_module_uri nparams x ^ i) l "" -;; - -let ppobj current_module_uri obj = - let res = ppobj current_module_uri obj in - if res = "" then "" else res ^ ";;\n\n" -;; diff --git a/matita/components/cic_exportation/cicExportation.mli b/matita/components/cic_exportation/cicExportation.mli deleted file mode 100644 index 4d1c82c86..000000000 --- a/matita/components/cic_exportation/cicExportation.mli +++ /dev/null @@ -1,29 +0,0 @@ -(* Copyright (C) 2000, 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: cicPp.ml 7413 2007-05-29 15:30:53Z tassi $ *) - -(* ppobj current_module_uri obj *) -val ppobj : string -> Cic.obj -> string diff --git a/matita/components/cic_proof_checking/.depend b/matita/components/cic_proof_checking/.depend deleted file mode 100644 index f8a16629e..000000000 --- a/matita/components/cic_proof_checking/.depend +++ /dev/null @@ -1,38 +0,0 @@ -cicLogger.cmi: -cicEnvironment.cmi: -cicPp.cmi: -cicUnivUtils.cmi: -cicSubstitution.cmi: -cicMiniReduction.cmi: -cicReduction.cmi: -cicTypeChecker.cmi: -freshNamesGenerator.cmi: -cicDischarge.cmi: -cicLogger.cmo: cicLogger.cmi -cicLogger.cmx: cicLogger.cmi -cicEnvironment.cmo: cicEnvironment.cmi -cicEnvironment.cmx: cicEnvironment.cmi -cicPp.cmo: cicEnvironment.cmi cicPp.cmi -cicPp.cmx: cicEnvironment.cmx cicPp.cmi -cicUnivUtils.cmo: cicEnvironment.cmi cicUnivUtils.cmi -cicUnivUtils.cmx: cicEnvironment.cmx cicUnivUtils.cmi -cicSubstitution.cmo: cicEnvironment.cmi cicSubstitution.cmi -cicSubstitution.cmx: cicEnvironment.cmx cicSubstitution.cmi -cicMiniReduction.cmo: cicSubstitution.cmi cicMiniReduction.cmi -cicMiniReduction.cmx: cicSubstitution.cmx cicMiniReduction.cmi -cicReduction.cmo: cicSubstitution.cmi cicPp.cmi cicEnvironment.cmi \ - cicReduction.cmi -cicReduction.cmx: cicSubstitution.cmx cicPp.cmx cicEnvironment.cmx \ - cicReduction.cmi -cicTypeChecker.cmo: cicUnivUtils.cmi cicSubstitution.cmi cicReduction.cmi \ - cicPp.cmi cicLogger.cmi cicEnvironment.cmi cicTypeChecker.cmi -cicTypeChecker.cmx: cicUnivUtils.cmx cicSubstitution.cmx cicReduction.cmx \ - cicPp.cmx cicLogger.cmx cicEnvironment.cmx cicTypeChecker.cmi -freshNamesGenerator.cmo: cicTypeChecker.cmi cicSubstitution.cmi \ - freshNamesGenerator.cmi -freshNamesGenerator.cmx: cicTypeChecker.cmx cicSubstitution.cmx \ - freshNamesGenerator.cmi -cicDischarge.cmo: cicTypeChecker.cmi cicSubstitution.cmi cicEnvironment.cmi \ - cicDischarge.cmi -cicDischarge.cmx: cicTypeChecker.cmx cicSubstitution.cmx cicEnvironment.cmx \ - cicDischarge.cmi diff --git a/matita/components/cic_proof_checking/.depend.opt b/matita/components/cic_proof_checking/.depend.opt deleted file mode 100644 index f8a16629e..000000000 --- a/matita/components/cic_proof_checking/.depend.opt +++ /dev/null @@ -1,38 +0,0 @@ -cicLogger.cmi: -cicEnvironment.cmi: -cicPp.cmi: -cicUnivUtils.cmi: -cicSubstitution.cmi: -cicMiniReduction.cmi: -cicReduction.cmi: -cicTypeChecker.cmi: -freshNamesGenerator.cmi: -cicDischarge.cmi: -cicLogger.cmo: cicLogger.cmi -cicLogger.cmx: cicLogger.cmi -cicEnvironment.cmo: cicEnvironment.cmi -cicEnvironment.cmx: cicEnvironment.cmi -cicPp.cmo: cicEnvironment.cmi cicPp.cmi -cicPp.cmx: cicEnvironment.cmx cicPp.cmi -cicUnivUtils.cmo: cicEnvironment.cmi cicUnivUtils.cmi -cicUnivUtils.cmx: cicEnvironment.cmx cicUnivUtils.cmi -cicSubstitution.cmo: cicEnvironment.cmi cicSubstitution.cmi -cicSubstitution.cmx: cicEnvironment.cmx cicSubstitution.cmi -cicMiniReduction.cmo: cicSubstitution.cmi cicMiniReduction.cmi -cicMiniReduction.cmx: cicSubstitution.cmx cicMiniReduction.cmi -cicReduction.cmo: cicSubstitution.cmi cicPp.cmi cicEnvironment.cmi \ - cicReduction.cmi -cicReduction.cmx: cicSubstitution.cmx cicPp.cmx cicEnvironment.cmx \ - cicReduction.cmi -cicTypeChecker.cmo: cicUnivUtils.cmi cicSubstitution.cmi cicReduction.cmi \ - cicPp.cmi cicLogger.cmi cicEnvironment.cmi cicTypeChecker.cmi -cicTypeChecker.cmx: cicUnivUtils.cmx cicSubstitution.cmx cicReduction.cmx \ - cicPp.cmx cicLogger.cmx cicEnvironment.cmx cicTypeChecker.cmi -freshNamesGenerator.cmo: cicTypeChecker.cmi cicSubstitution.cmi \ - freshNamesGenerator.cmi -freshNamesGenerator.cmx: cicTypeChecker.cmx cicSubstitution.cmx \ - freshNamesGenerator.cmi -cicDischarge.cmo: cicTypeChecker.cmi cicSubstitution.cmi cicEnvironment.cmi \ - cicDischarge.cmi -cicDischarge.cmx: cicTypeChecker.cmx cicSubstitution.cmx cicEnvironment.cmx \ - cicDischarge.cmi diff --git a/matita/components/cic_proof_checking/Makefile b/matita/components/cic_proof_checking/Makefile deleted file mode 100644 index a5f97bc1d..000000000 --- a/matita/components/cic_proof_checking/Makefile +++ /dev/null @@ -1,28 +0,0 @@ - -PACKAGE = cic_proof_checking -PREDICATES = - -REDUCTION_IMPLEMENTATION = cicReductionMachine.ml - -INTERFACE_FILES = \ - cicLogger.mli \ - cicEnvironment.mli \ - cicPp.mli \ - cicUnivUtils.mli \ - cicSubstitution.mli \ - cicMiniReduction.mli \ - cicReduction.mli \ - cicTypeChecker.mli \ - freshNamesGenerator.mli \ - cicDischarge.mli \ - $(NULL) -IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) - -# Metadata tools only need zeta-reduction -EXTRA_OBJECTS_TO_INSTALL = \ - cicSubstitution.cmo cicSubstitution.cmx cicSubstitution.o \ - cicMiniReduction.cmo cicMiniReduction.cmx cicMiniReduction.o -EXTRA_OBJECTS_TO_CLEAN = - -include ../../Makefile.defs -include ../Makefile.common diff --git a/matita/components/cic_proof_checking/cicDischarge.ml b/matita/components/cic_proof_checking/cicDischarge.ml deleted file mode 100644 index 65b5cea33..000000000 --- a/matita/components/cic_proof_checking/cicDischarge.ml +++ /dev/null @@ -1,369 +0,0 @@ -(* Copyright (C) 2003-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/. - *) - -module UM = UriManager -module C = Cic -module Un = CicUniv -module E = CicEnvironment -module Ut = CicUtil -module TC = CicTypeChecker -module S = CicSubstitution -module X = HExtlib - -let hashtbl_size = 11 - -let not_implemented = - "discharge of current proofs is not implemented yet" - -let debug = ref false - -let out = prerr_string - -(* helper functions *********************************************************) - -let rec count_prods n = function - | C.Prod (_, _, t) -> count_prods (succ n) t - | _ -> n - -let get_ind_type_psnos uri tyno = - match E.get_obj Un.default_ugraph uri with - | C.InductiveDefinition (tys, _, lpsno, _), _ -> - let _, _, ty, _ = List.nth tys tyno in - lpsno, count_prods 0 ty - | _ -> assert false - -let typecheck b t = - if !debug then begin - out (Printf.sprintf "Pre Check ; %s\n" b); - Ut.pp_term out [] [] t; out "\n"; - let _ = TC.type_of_aux' [] [] t Un.default_ugraph in - out (Printf.sprintf "Typecheck : %s OK\n" b) - end - -let list_pos found l = - let rec aux n = function - | [] -> raise Not_found - | hd :: tl -> if found hd then n else aux (succ n) tl - in - aux 0 l - -let sh a b = if a == b then a else b - -let rec list_map_sh map l = match l with - | [] -> l - | hd :: tl -> - let hd', tl' = map hd, list_map_sh map tl in - if hd' == hd && tl' == tl then l else - sh hd hd' :: sh tl tl' - -let flatten = function - | C.Appl vs :: tl -> vs @ tl - | ts -> ts - -let vars_of_uri uri = - let obj, _ = E.get_obj Un.default_ugraph uri in - match obj with - | C.Constant (_, _, _, vars, _) - | C.Variable (_, _, _, vars, _) - | C.InductiveDefinition (_, vars, _, _) - | C.CurrentProof (_, _, _, _, vars, _) -> vars - -let mk_arg s u = - try List.assq u s - with Not_found -> C.Var (u, []) - -(* main functions ***********************************************************) - -type status = { - dn: string -> string; (* name discharge map *) - du: UM.uri -> UM.uri; (* uri discharge map *) - ls: (UM.uri, UM.uri list) Hashtbl.t; (* var lists of subobjects *) - rl: UM.uri list; (* reverse var list of this object *) - h : int; (* relocation index *) - c : C.context (* local context of this object *) -} - -let add st k es = {st with h = st.h + k; c = List.rev_append es st.c} - -let discharge st u = st.h + list_pos (UM.eq u) st.rl - -let get_args st u = - try Hashtbl.find st.ls u - with Not_found -> - let args = vars_of_uri u in - Hashtbl.add st.ls u args; args - -let proj_fix (s, _, w, _) = s, w - -let proj_cofix (s, w, _) = s, w - -let mk_context proj discharge_term s = - let map e = - let s, w = proj e in - let w' = discharge_term w in - Some (C.Name s, C.Decl w') - in - List.length s, List.rev_map map s - -let rec split_absts named no c = function - | C.Lambda (s, w, t) -> - let e = Some (s, C.Decl w) in - let named = named && s <> C.Anonymous in - split_absts named (succ no) (e :: c) t - | t -> - named, no, c, t - -let close is_type c t = - let map t = function - | Some (b, C.Def (v, w)) -> C.LetIn (b, v, w, t) - | Some (b, C.Decl w) -> - if is_type then C.Prod (b, w, t) else C.Lambda (b, w, t) - | None -> assert false - in - List.fold_left map t c - -let relocate to_what from_what k m = - try - let u = List.nth from_what (m - k) in - let map v m = if UM.eq u v then Some m else None in - match X.list_findopt map to_what with - | Some m -> m + k - | None -> raise (Failure "nth") - with - | Failure "nth" -> assert false - -let rec discharge_term st t = match t with - | C.Implicit _ - | C.Sort _ - | C.Rel _ -> t - | C.Const (u, s) -> - let args = get_args st u in - if args = [] then t else - let s = List.map (mk_arg s) args in - C.Appl (C.Const (st.du u, []) :: discharge_nsubst st s) - | C.MutInd (u, m, s) -> - let args = get_args st u in - if args = [] then t else - let s = List.map (mk_arg s) args in - C.Appl (C.MutInd (st.du u, m, []) :: discharge_nsubst st s) - | C.MutConstruct (u, m, n, s) -> - let args = get_args st u in - if args = [] then t else - let s = List.map (mk_arg s) args in - C.Appl (C.MutConstruct (st.du u, m, n, []) :: discharge_nsubst st s) - | C.Var (u, s) -> -(* We do not discharge the nsubst because variables are not closed *) -(* thus only the identity nsubst should be allowed *) - if s <> [] then assert false else - C.Rel (discharge st u) - | C.Meta (i, s) -> - let s' = list_map_sh (discharge_usubst st) s in - if s' == s then t else C.Meta (i, s') - | C.Appl vs -> - let vs' = list_map_sh (discharge_term st) vs in - if vs' == vs then t else C.Appl (flatten vs') - | C.Cast (v, w) -> - let v', w' = discharge_term st v, discharge_term st w in - if v' == v && w' == w then t else - C.Cast (sh v v', sh w w') - | C.MutCase (u, m, w, v, vs) -> - let args = get_args st u in - let u' = if args = [] then u else st.du u in - let w', v', vs' = - discharge_term st w, discharge_term st v, - list_map_sh (discharge_term st) vs - in -(* BEGIN FIX OUT TYPE *) - let lpsno, psno = get_ind_type_psnos u m in - let rpsno = psno - lpsno in - let named, frpsno, wc, wb = split_absts true 0 [] w' in - let w' = -(* No fixing needed *) - if frpsno = succ rpsno then w' else -(* Fixing needed, no right parametes *) - if frpsno = rpsno && rpsno = 0 then - let vty, _ = TC.type_of_aux' [] st.c v' Un.default_ugraph in - if !debug then begin - out "VTY: "; Ut.pp_term out [] st.c vty; out "\n" - end; - C.Lambda (C.Anonymous, vty, S.lift 1 wb) - else -(* Fixing needed, some right parametes *) - if frpsno = rpsno && named then - let vty, _ = TC.type_of_aux' [] st.c v' Un.default_ugraph in - if !debug then begin - out "VTY: "; Ut.pp_term out [] st.c vty; out "\n" - end; - let vty, wb = S.lift rpsno vty, S.lift 1 wb in - let vty = match vty with - | C.Appl (C.MutInd (fu, fm, _) as hd :: args) - when UM.eq fu u && fm = m && List.length args = psno -> - let largs, _ = X.split_nth lpsno args in - C.Appl (hd :: largs @ Ut.mk_rels rpsno 0) - | _ -> - assert false - in - close false wc (C.Lambda (C.Anonymous, vty, wb)) -(* This case should not happen *) - else assert false - in -(* END FIX OUT TYPE *) - if UM.eq u u' && w' == w && v' == v && vs' == vs then t else - C.MutCase (u', m, sh w w', sh v v', sh vs vs') - | C.Prod (b, w, v) -> - let w' = discharge_term st w in - let es = [Some (b, C.Decl w')] in - let v' = discharge_term (add st 1 es) v in - if w' == w && v' == v then t else - C.Prod (b, sh w w', sh v v') - | C.Lambda (b, w, v) -> - let w' = discharge_term st w in - let es = [Some (b, C.Decl w')] in - let v' = discharge_term (add st 1 es) v in - if w' == w && v' == v then t else - C.Lambda (b, sh w w', sh v v') - | C.LetIn (b, y, w, v) -> - let y', w' = discharge_term st y, discharge_term st w in - let es = [Some (b, C.Def (y, w'))] in - let v' = discharge_term (add st 1 es) v in - if y' == y && w' == w && v' == v then t else - C.LetIn (b, sh y y', sh w w', sh v v') - | C.CoFix (i, s) -> - let no, es = mk_context proj_cofix (discharge_term st) s in - let s' = list_map_sh (discharge_cofun st no es) s in - if s' == s then t else C.CoFix (i, s') - | C.Fix (i, s) -> - let no, es = mk_context proj_fix (discharge_term st) s in - let s' = list_map_sh (discharge_fun st no es) s in - if s' == s then t else C.Fix (i, s') - -and discharge_nsubst st s = - List.map (discharge_term st) s - -and discharge_usubst st s = match s with - | None -> s - | Some t -> - let t' = discharge_term st t in - if t' == t then s else Some t' - -and discharge_cofun st no es f = - let b, w, v = f in - let w', v' = discharge_term st w, discharge_term (add st no es) v in - if w' == w && v' == v then f else - b, sh w w', sh v v' - -and discharge_fun st no es f = - let b, i, w, v = f in - let w', v' = discharge_term st w, discharge_term (add st no es) v in - if w' == w && v' == v then f else - b, i, sh w w', sh v v' - -let close is_type st = close is_type st.c - -let discharge_con st con = - let b, v = con in - let v' = discharge_term st v in - if v' == v && st.rl = [] then con else st.dn b, close true st (sh v v') - -let discharge_type st ind_type = - let b, ind, w, cons = ind_type in - let w', cons' = discharge_term st w, list_map_sh (discharge_con st) cons in - if w' == w && cons' == cons && st.rl = [] then ind_type else - let w'' = close true st (sh w w') in - st.dn b, ind, w'', sh cons cons' - -let rec discharge_object dn du obj = - let ls = Hashtbl.create hashtbl_size in match obj with - | C.Variable (b, None, w, vars, attrs) -> - let st = init_status dn du ls vars in - let w' = discharge_term st w in - if w' == w && vars = [] then obj else - let w'' = sh w w' in -(* We do not typecheck because variables are not closed *) - C.Variable (dn b, None, w'', vars, attrs) - | C.Variable (b, Some v, w, vars, attrs) -> - let st = init_status dn du ls vars in - let w', v' = discharge_term st w, discharge_term st v in - if w' == w && v' == v && vars = [] then obj else - let w'', v'' = sh w w', sh v v' in -(* We do not typecheck because variables are not closed *) - C.Variable (dn b, Some v'', w'', vars, attrs) - | C.Constant (b, None, w, vars, attrs) -> - let st = init_status dn du ls vars in - let w' = discharge_term st w in - if w' == w && vars = [] then obj else - let w'' = close true st (sh w w') in - let _ = typecheck (dn b) w'' in - C.Constant (dn b, None, w'', [], attrs) - | C.Constant (b, Some v, w, vars, attrs) -> - let st = init_status dn du ls vars in - let w', v' = discharge_term st w, discharge_term st v in - if w' == w && v' == v && vars = [] then obj else - let w'', v'' = close true st (sh w w'), close false st (sh v v') in - let _ = typecheck (dn b) (C.Cast (v'', w'')) in - C.Constant (dn b, Some v'', w'', [], attrs) - | C.InductiveDefinition (types, vars, lpsno, attrs) -> - let st = init_status dn du ls vars in - let types' = list_map_sh (discharge_type st) types in - if types' == types && vars = [] then obj else - let lpsno' = lpsno + List.length vars in - C.InductiveDefinition (sh types types', [], lpsno', attrs) - | C.CurrentProof _ -> - HLog.warn not_implemented; obj - -and discharge_uri dn du uri = - let prerr msg obj = - if !debug then begin - out msg; Ut.pp_obj out obj; out "\n" - end - in - let obj, _ = E.get_obj Un.default_ugraph uri in - prerr "Plain : " obj; - let obj' = discharge_object dn du obj in - prerr "Discharged: " obj'; - obj', obj' == obj - -and discharge_vars dn du vars = - let rec aux us c = function - | [] -> c - | u :: tl -> - let e = match discharge_uri dn du u with - | C.Variable (b, None, w, vars, _), _ -> - let map = relocate us (List.rev vars) in - let w = S.lift_map 1 map w in - Some (C.Name b, C.Decl w) - | C.Variable (b, Some v, w, vars, _), _ -> - let map = relocate us (List.rev vars) in - let v, w = S.lift_map 1 map v, S.lift_map 1 map w in - Some (C.Name b, C.Def (v, w)) - | _ -> assert false - in - aux (u :: us) (e :: c) tl - in - aux [] [] vars - -and init_status dn du ls vars = - let c, rl = discharge_vars dn du vars, List.rev vars in - {dn = dn; du = du; ls = ls; rl = rl; h = 1; c = c} diff --git a/matita/components/cic_proof_checking/cicDischarge.mli b/matita/components/cic_proof_checking/cicDischarge.mli deleted file mode 100644 index 2e2790a97..000000000 --- a/matita/components/cic_proof_checking/cicDischarge.mli +++ /dev/null @@ -1,43 +0,0 @@ -(* Copyright (C) 2003-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/. - *) - -(* NOTE. Discharged variables are not well formed. *) -(* For internal recursive use only. *) - -(* discharges the explicit variables of the given object (with sharing) *) -(* the first argument is a map for relacating the names of the objects *) -(* the second argument is a map for relocating the uris of the dependencdes *) -val discharge_object: - (string -> string) -> (UriManager.uri -> UriManager.uri) -> - Cic.obj -> Cic.obj - -(* applies the previous function to the object at the given uri *) -(* returns true if the object does not need discharging *) -val discharge_uri: - (string -> string) -> (UriManager.uri -> UriManager.uri) -> - UriManager.uri -> Cic.obj * bool - -(* if activated prints the received object before and after discharging *) -val debug: bool ref diff --git a/matita/components/cic_proof_checking/cicEnvironment.ml b/matita/components/cic_proof_checking/cicEnvironment.ml deleted file mode 100644 index fde76a60b..000000000 --- a/matita/components/cic_proof_checking/cicEnvironment.ml +++ /dev/null @@ -1,459 +0,0 @@ -(* Copyright (C) 2000, 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/. - *) - -(*****************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 24/01/2000 *) -(* *) -(* This module implements a trival cache system (an hash-table) for cic *) -(* objects. Uses the getter (getter.ml) and the parser (cicParser.ml) *) -(* *) -(*****************************************************************************) - -(* $Id$ *) - -(* ************************************************************************** * - CicEnvironment SETTINGS (trust and clean_tmp) - * ************************************************************************** *) - -let debug = false;; -let cleanup_tmp = true;; -let trust = ref (fun _ -> true);; -let set_trust f = trust := f -let trust_obj uri = !trust uri -let debug_print = if debug then fun x -> prerr_endline (Lazy.force x) else ignore - -(* ************************************************************************** * - TYPES - * ************************************************************************** *) - -type type_checked_obj = - | CheckedObj of (Cic.obj * CicUniv.universe_graph) - | UncheckedObj of Cic.obj * (CicUniv.universe_graph * CicUniv.universe list) option - -exception AlreadyCooked of string;; -exception CircularDependency of string Lazy.t;; -exception CouldNotFreeze of string;; -exception CouldNotUnfreeze of string;; -exception Object_not_found of UriManager.uri;; - - -(* ************************************************************************** * - HERE STARTS THE CACHE MODULE - * ************************************************************************** *) - -(* I think this should be the right place to implement mecanisms and - * invasriants - *) - -(* Cache that uses == instead of = for testing equality *) -(* Invariant: an object is always in at most one of the *) -(* following states: unchecked, frozen and cooked. *) -module Cache : - sig - val find_or_add_to_unchecked : - UriManager.uri -> - get_object_to_add: - (UriManager.uri -> - Cic.obj * (CicUniv.universe_graph * CicUniv.universe list) option) -> - Cic.obj * (CicUniv.universe_graph * CicUniv.universe list) option - val can_be_cooked: - UriManager.uri -> bool - val unchecked_to_frozen : - UriManager.uri -> unit - val frozen_to_cooked : - uri:UriManager.uri -> - Cic.obj -> CicUniv.universe_graph -> CicUniv.universe list -> unit - val find_cooked : - key:UriManager.uri -> - Cic.obj * CicUniv.universe_graph * CicUniv.universe list - val add_cooked : - key:UriManager.uri -> - (Cic.obj * CicUniv.universe_graph * CicUniv.universe list) -> unit - val remove: UriManager.uri -> unit - val dump_to_channel : ?callback:(string -> unit) -> out_channel -> unit - val restore_from_channel : ?callback:(string -> unit) -> in_channel -> unit - val empty : unit -> unit - val is_in_frozen: UriManager.uri -> bool - val is_in_unchecked: UriManager.uri -> bool - val is_in_cooked: UriManager.uri -> bool - val list_all_cooked_uris: unit -> UriManager.uri list - val invalidate: unit -> unit - end -= - struct - (************************************************************************* - TASSI: invariant - The cacheOfCookedObjects will contain only objects with a valid universe - graph. valid means that not None (used if there is no universe file - in the universe generation phase). - **************************************************************************) - - (* DATA: the data structure that implements the CACHE *) - module HashedType = - struct - type t = UriManager.uri - let equal = UriManager.eq - let hash = Hashtbl.hash - end - ;; - - module HT = Hashtbl.Make(HashedType);; - - let cacheOfCookedObjects = HT.create 1009;; - - (* DATA: The parking lists - * the lists elements are (uri * (obj * universe_graph option)) - * ( u, ( o, None )) means that the object has no universes file, this - * should happen only in the universe generation phase. - * FIXME: if the universe generation is integrated in the library - * exportation phase, the 'option' MUST be removed. - * ( u, ( o, Some g)) means that the object has a universes file, - * the usual case. - *) - - (* frozen is used to detect circular dependency. *) - let frozen_list = ref [];; - (* unchecked is used to store objects just fetched, nothing more. *) - let unchecked_list = ref [];; - - let invalidate _ = - let l = HT.fold (fun k (o,g,gl) acc -> (k,(o,Some (g,gl)))::acc) cacheOfCookedObjects [] in - unchecked_list := - HExtlib.list_uniq ~eq:(fun (x,_) (y,_) -> UriManager.eq x y) - (List.sort (fun (x,_) (y,_) -> UriManager.compare x y) (l @ !unchecked_list)); - frozen_list := []; - HT.clear cacheOfCookedObjects; - ;; - - let empty () = - HT.clear cacheOfCookedObjects; - unchecked_list := [] ; - frozen_list := [] - ;; - - (* FIX: universe stuff?? *) - let dump_to_channel ?(callback = ignore) oc = - HT.iter (fun uri _ -> callback (UriManager.string_of_uri uri)) - cacheOfCookedObjects; - Marshal.to_channel oc cacheOfCookedObjects [] - ;; - - (* FIX: universes stuff?? *) - let restore_from_channel ?(callback = ignore) ic = - let restored = Marshal.from_channel ic in - (* FIXME: should this empty clean the frozen and unchecked? - * if not, the only-one-empty-end-not-3 patch is wrong - *) - empty (); - HT.iter - (fun k (v,u,l) -> - callback (UriManager.string_of_uri k); - let reconsed_entry = - CicUtil.rehash_obj v, - CicUniv.recons_graph u, - List.map CicUniv.recons_univ l - in - HT.add cacheOfCookedObjects - (UriManager.uri_of_string (UriManager.string_of_uri k)) - reconsed_entry) - restored - ;; - - - let is_in_frozen uri = - List.mem_assoc uri !frozen_list - ;; - - let is_in_unchecked uri = - List.mem_assoc uri !unchecked_list - ;; - - let is_in_cooked uri = - HT.mem cacheOfCookedObjects uri - ;; - - - (******************************************************************* - TASSI: invariant - we need, in the universe generation phase, to traverse objects - that are not yet committed, so we search them in the frozen list. - Only uncommitted objects without a universe file (see the assertion) - can be searched with method - *******************************************************************) - - let find_or_add_to_unchecked uri ~get_object_to_add = - try - List.assq uri !unchecked_list - with - Not_found -> - if List.mem_assq uri !frozen_list then - (* CIRCULAR DEPENDENCY DETECTED, print the error and raise *) - begin -(* - prerr_endline "\nCircularDependency!\nfrozen list: \n"; - List.iter ( - fun (u,(_,o)) -> - let su = UriManager.string_of_uri u in - let univ = if o = None then "NO_UNIV" else "" in - prerr_endline (su^" "^univ)) - !frozen_list; -*) - raise (CircularDependency (lazy (UriManager.string_of_uri uri))) - end - else - if HT.mem cacheOfCookedObjects uri then - (* DOUBLE COOK DETECTED, raise the exception *) - raise (AlreadyCooked (UriManager.string_of_uri uri)) - else - (* OK, it is not already frozen nor cooked *) - let obj,ugraph_and_univlist = get_object_to_add uri in - unchecked_list := (uri,(obj,ugraph_and_univlist))::!unchecked_list; - obj, ugraph_and_univlist - ;; - - let unchecked_to_frozen uri = - try - let obj,ugraph_and_univlist = List.assq uri !unchecked_list in - unchecked_list := List.remove_assq uri !unchecked_list ; - frozen_list := (uri,(obj,ugraph_and_univlist))::!frozen_list - with - Not_found -> raise (CouldNotFreeze (UriManager.string_of_uri uri)) - ;; - - let frozen_to_cooked ~uri o ug ul = - CicUniv.assert_univs_have_uri ug ul; - frozen_list := List.remove_assq uri !frozen_list ; - HT.add cacheOfCookedObjects uri (o,ug,ul) - ;; - - let can_be_cooked uri = List.mem_assq uri !frozen_list;; - - let find_cooked ~key:uri = HT.find cacheOfCookedObjects uri ;; - - let add_cooked ~key:uri (obj,ugraph,univlist) = - HT.add cacheOfCookedObjects uri (obj,ugraph,univlist) - ;; - - (* invariant - * - * an object can be romeved from the cache only if we are not typechecking - * something. this means check and frozen must be empty. - *) - let remove uri = - if !frozen_list <> [] then - failwith "CicEnvironment.remove while type checking" - else - begin - HT.remove cacheOfCookedObjects uri; - unchecked_list := - List.filter (fun (uri',_) -> not (UriManager.eq uri uri')) !unchecked_list - end - ;; - - let list_all_cooked_uris () = - HT.fold (fun u _ l -> u::l) cacheOfCookedObjects [] - ;; - - end -;; - -(* ************************************************************************ - HERE ENDS THE CACHE MODULE - * ************************************************************************ *) - -(* exported cache functions *) -let dump_to_channel = Cache.dump_to_channel;; -let restore_from_channel = Cache.restore_from_channel;; -let empty = Cache.empty;; - -let total_parsing_time = ref 0.0 - -let get_object_to_add uri = - try - let filename = Http_getter.getxml' uri in - let bodyfilename = - match UriManager.bodyuri_of_uri uri with - None -> None - | Some bodyuri -> - if Http_getter.exists' ~local:false bodyuri then - Some (Http_getter.getxml' bodyuri) - else - None - in - let obj = - try - let time = Unix.gettimeofday() in - let rc = CicParser.obj_of_xml uri filename bodyfilename in - total_parsing_time := - !total_parsing_time +. ((Unix.gettimeofday()) -. time ); - rc - with exn -> - (match exn with - | CicParser.Getter_failure ("key_not_found", uri) -> - raise (Object_not_found (UriManager.uri_of_string uri)) - | _ -> raise exn) - in - let ugraph_and_univlist,filename_univ = - try - let filename_univ = - let univ_uri = UriManager.univgraphuri_of_uri uri in - Http_getter.getxml' univ_uri - in - Some (CicUniv.ugraph_and_univlist_of_xml filename_univ), - Some filename_univ - with - | Http_getter_types.Key_not_found _ - | Http_getter_types.Unresolvable_URI _ -> - debug_print (lazy ( - "WE HAVE NO UNIVERSE FILE FOR " ^ (UriManager.string_of_uri uri))); - None, None - in - obj, ugraph_and_univlist - with Http_getter_types.Key_not_found _ -> raise (Object_not_found uri) -;; - -(* this is the function to fetch the object in the unchecked list and - * nothing more (except returning it) - *) -let find_or_add_to_unchecked uri = - Cache.find_or_add_to_unchecked uri ~get_object_to_add - -(* set_type_checking_info uri *) -(* must be called once the type-checking of uri is finished *) -(* The object whose uri is uri is unfreezed *) -(* *) -(* the replacement ugraph must be the one returned by the *) -(* typechecker, restricted with the CicUnivUtils.clean_and_fill *) -let set_type_checking_info uri (o,ug,ul) = - if not (Cache.can_be_cooked uri) then assert false - else - Cache.frozen_to_cooked ~uri o ug ul -;; - -(* fetch, unfreeze and commit an uri to the cacheOfCookedObjects and - * return the object,ugraph - *) -let add_trusted_uri_to_cache uri = - let o,u_and_ul = find_or_add_to_unchecked uri in - Cache.unchecked_to_frozen uri; - let u,ul = - match u_and_ul with - (* for backward compat with Coq *) - | None -> CicUniv.empty_ugraph, [] - | Some (ug,ul) -> ug, ul - in - set_type_checking_info uri (o,u,ul); - try Cache.find_cooked uri - with Not_found -> assert false -;; - -(* get the uri, if we trust it will be added to the cacheOfCookedObjects *) -let get_cooked_obj_with_univlist ?(trust=true) base_ugraph uri = - try - (* the object should be in the cacheOfCookedObjects *) - let o,u,l = Cache.find_cooked uri in - o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri(*,l*))),l - with Not_found -> - (* this should be an error case, but if we trust the uri... *) - if trust && trust_obj uri then - (* trusting means that we will fetch cook it on the fly *) - let o,u,l = add_trusted_uri_to_cache uri in - o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri(*,l*))),l - else - (* we don't trust the uri, so we fail *) - begin - debug_print (lazy ("CACHE MISS: " ^ (UriManager.string_of_uri uri))); - raise Not_found - end - -let get_cooked_obj ?trust base_ugraph uri = - let o,g,_ = get_cooked_obj_with_univlist ?trust base_ugraph uri in - o,g - -let is_type_checked ?(trust=true) base_ugraph uri = - try - let o,u,l = Cache.find_cooked uri in - CheckedObj (o,(CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri(*,l*)))) - with Not_found -> - (* this should return UncheckedObj *) - if trust && trust_obj uri then - (* trusting means that we will fetch cook it on the fly *) - let o,u,l = add_trusted_uri_to_cache uri in - CheckedObj ( o, CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri(*,l*))) - else - let o,u_and_ul = find_or_add_to_unchecked uri in - Cache.unchecked_to_frozen uri; - UncheckedObj (o,u_and_ul) -;; - -(* as the get cooked, but if not present the object is only fetched, - * not unfreezed and committed - *) -let get_obj base_ugraph uri = - try - (* the object should be in the cacheOfCookedObjects *) - let o,u,_ = Cache.find_cooked uri in - o,CicUniv.merge_ugraphs ~base_ugraph ~increment:(u,uri) - with Not_found -> - (* this should be an error case, but if we trust the uri... *) - let o,u_and_l = find_or_add_to_unchecked uri in - match u_and_l with - | None -> o, base_ugraph - | Some (ug,_) -> o,CicUniv.merge_ugraphs ~base_ugraph ~increment:(ug,uri) -;; - -let in_cache uri = - Cache.is_in_cooked uri || Cache.is_in_frozen uri || Cache.is_in_unchecked uri - -let add_type_checked_obj uri (obj,ugraph,univlist) = - Cache.add_cooked ~key:uri (obj,ugraph,univlist) - -let in_library uri = in_cache uri || Http_getter.exists' ~local:false uri - -let remove_obj = Cache.remove - -let list_uri () = - Cache.list_all_cooked_uris () -;; - -let list_obj () = - try - List.map (fun u -> - let o,ug = get_obj CicUniv.empty_ugraph u in - (u,o,ug)) - (list_uri ()) - with - Not_found -> - debug_print (lazy "Who has removed the uri in the meanwhile?"); - raise Not_found -;; - -let invalidate _ = - Cache.invalidate () -;; diff --git a/matita/components/cic_proof_checking/cicEnvironment.mli b/matita/components/cic_proof_checking/cicEnvironment.mli deleted file mode 100644 index 0979d62d2..000000000 --- a/matita/components/cic_proof_checking/cicEnvironment.mli +++ /dev/null @@ -1,120 +0,0 @@ -(* Copyright (C) 2000, 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/. - *) - -(****************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 24/01/2000 *) -(* *) -(* This module implements a trival cache system (an hash-table) for cic *) -(* ^^^^^^ *) -(* objects. Uses the getter (getter.ml) and the parser (cicParser.ml) *) -(* *) -(****************************************************************************) - -exception CircularDependency of string Lazy.t;; -exception Object_not_found of UriManager.uri;; - -(* as the get cooked, but if not present the object is only fetched, - * not unfreezed and committed - *) -val get_obj : - CicUniv.universe_graph -> UriManager.uri -> - Cic.obj * CicUniv.universe_graph - -type type_checked_obj = - | CheckedObj of (Cic.obj * CicUniv.universe_graph) - | UncheckedObj of Cic.obj * (CicUniv.universe_graph * CicUniv.universe list) option - -val is_type_checked : - ?trust:bool -> CicUniv.universe_graph -> UriManager.uri -> - type_checked_obj - -(* set_type_checking_info uri *) -(* must be called once the type-checking of uri is finished *) -(* The object whose uri is uri is unfreezed and won't be type-checked *) -(* again in the future (is_type_checked will return true) *) -(* *) -(* WARNING: THIS FUNCTION MUST BE CALLED ONLY BY CicTypeChecker *) -val set_type_checking_info : UriManager.uri -> - (Cic.obj * CicUniv.universe_graph * CicUniv.universe list) -> unit - -(* this function is called by CicTypeChecker.typecheck_obj to add to the *) -(* environment a new well typed object that is not yet in the library *) -(* WARNING: THIS FUNCTION MUST BE CALLED ONLY BY CicTypeChecker *) -val add_type_checked_obj : - UriManager.uri -> - (Cic.obj * CicUniv.universe_graph * CicUniv.universe list) -> unit - - (** remove a type checked object - * @raise Object_not_found when given term is not in the environment - * @raise Failure when remove_term is invoked while type checking *) -val remove_obj: UriManager.uri -> unit - -(* get_cooked_obj ~trust uri *) -(* returns the object if it is already type-checked or if it can be *) -(* trusted (if [trust] = true and the trusting function accepts it) *) -(* Otherwise it raises Not_found *) -val get_cooked_obj : - ?trust:bool -> CicUniv.universe_graph -> UriManager.uri -> - Cic.obj * CicUniv.universe_graph - -(* get_cooked_obj_with_univlist ~trust uri *) -(* returns the object if it is already type-checked or if it can be *) -(* trusted (if [trust] = true and the trusting function accepts it) *) -(* Otherwise it raises Not_found *) -val get_cooked_obj_with_univlist : - ?trust:bool -> CicUniv.universe_graph -> UriManager.uri -> - Cic.obj * CicUniv.universe_graph * CicUniv.universe list - -(* FUNCTIONS USED ONLY IN THE TOPLEVEL/PROOF-ENGINE *) - -(* (de)serialization *) -val dump_to_channel : ?callback:(string -> unit) -> out_channel -> unit -val restore_from_channel : ?callback:(string -> unit) -> in_channel -> unit -val empty : unit -> unit - -(** Set trust function. Per default this function is set to (fun _ -> true) *) -val set_trust: (UriManager.uri -> bool) -> unit - - (** @return true for objects currently cooked/frozend/unchecked, false - * otherwise (i.e. objects already parsed from XML) *) -val in_cache : UriManager.uri -> bool - -(* to debug the matitac batch compiler *) -val list_obj: unit -> (UriManager.uri * Cic.obj * CicUniv.universe_graph) list -val list_uri: unit -> UriManager.uri list - - (** @return true for objects available in the library *) -val in_library: UriManager.uri -> bool - - (** total parsing time, only to benchmark the parser *) -val total_parsing_time: float ref - -val invalidate: unit -> unit - -(* EOF *) diff --git a/matita/components/cic_proof_checking/cicLogger.ml b/matita/components/cic_proof_checking/cicLogger.ml deleted file mode 100644 index 5921c61b0..000000000 --- a/matita/components/cic_proof_checking/cicLogger.ml +++ /dev/null @@ -1,62 +0,0 @@ -(* Copyright (C) 2000, 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$ *) - -type msg = - [ `Start_type_checking of UriManager.uri - | `Type_checking_completed of UriManager.uri - | `Trusting of UriManager.uri - ] - -let log ?(level = 1) = - let module U = UriManager in - function - | `Start_type_checking uri -> - HelmLogger.log (`Msg (`DIV (level, None, `T - ("Type-Checking of " ^ (U.string_of_uri uri) ^ " started")))) - | `Type_checking_completed uri -> - HelmLogger.log (`Msg (`DIV (level, Some "green", `T - ("Type-Checking of " ^ (U.string_of_uri uri) ^ " completed")))) - | `Trusting uri -> - HelmLogger.log (`Msg (`DIV (level, Some "blue", `T - ((U.string_of_uri uri) ^ " is trusted.")))) - -class logger = - object - val mutable level = 0 (* indentation level *) - method log (msg: msg) = - match msg with - | `Start_type_checking _ -> - level <- level + 1; - log ~level msg - | `Type_checking_completed _ -> - log ~level msg; - level <- level - 1; - | _ -> log ~level msg - end - -let log msg = log ~level:1 msg - diff --git a/matita/components/cic_proof_checking/cicLogger.mli b/matita/components/cic_proof_checking/cicLogger.mli deleted file mode 100644 index 408bc8879..000000000 --- a/matita/components/cic_proof_checking/cicLogger.mli +++ /dev/null @@ -1,42 +0,0 @@ -(* Copyright (C) 2000, 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 msg = - [ `Start_type_checking of UriManager.uri - | `Type_checking_completed of UriManager.uri - | `Trusting of UriManager.uri - ] - - (** Stateless logging. Each message is logged with indentation level 1 *) -val log: msg -> unit - - (** Stateful logging. Each `Start_type_checing message increase the - * indentation level by 1, each `Type_checking_completed message decrease it by - * the same amount. *) -class logger: - object - method log: msg -> unit - end - diff --git a/matita/components/cic_proof_checking/cicMiniReduction.ml b/matita/components/cic_proof_checking/cicMiniReduction.ml deleted file mode 100644 index f063c1d9b..000000000 --- a/matita/components/cic_proof_checking/cicMiniReduction.ml +++ /dev/null @@ -1,76 +0,0 @@ -(* Copyright (C) 2000, 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 rec letin_nf = - let module C = Cic in - function - C.Rel _ as t -> t - | C.Var (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (function (uri,t) -> (uri,letin_nf t)) exp_named_subst - in - C.Var (uri,exp_named_subst') - | C.Meta _ as t -> t - | C.Sort _ as t -> t - | C.Implicit _ as t -> t - | C.Cast (te,ty) -> C.Cast (letin_nf te, letin_nf ty) - | C.Prod (n,s,t) -> C.Prod (n, letin_nf s, letin_nf t) - | C.Lambda (n,s,t) -> C.Lambda (n, letin_nf s, letin_nf t) - | C.LetIn (n,s,_,t) -> CicSubstitution.subst (letin_nf s) t - | C.Appl l -> C.Appl (List.map letin_nf l) - | C.Const (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (function (uri,t) -> (uri,letin_nf t)) exp_named_subst - in - C.Const (uri,exp_named_subst') - | C.MutInd (uri,typeno,exp_named_subst) -> - let exp_named_subst' = - List.map (function (uri,t) -> (uri,letin_nf t)) exp_named_subst - in - C.MutInd (uri,typeno,exp_named_subst') - | C.MutConstruct (uri,typeno,consno,exp_named_subst) -> - let exp_named_subst' = - List.map (function (uri,t) -> (uri,letin_nf t)) exp_named_subst - in - C.MutConstruct (uri,typeno,consno,exp_named_subst') - | C.MutCase (sp,i,outt,t,pl) -> - C.MutCase (sp,i,letin_nf outt, letin_nf t, List.map letin_nf pl) - | C.Fix (i,fl) -> - let substitutedfl = - List.map - (fun (name,i,ty,bo) -> (name, i, letin_nf ty, letin_nf bo)) - fl - in - C.Fix (i, substitutedfl) - | C.CoFix (i,fl) -> - let substitutedfl = - List.map - (fun (name,ty,bo) -> (name, letin_nf ty, letin_nf bo)) - fl - in - C.CoFix (i, substitutedfl) -;; diff --git a/matita/components/cic_proof_checking/cicMiniReduction.mli b/matita/components/cic_proof_checking/cicMiniReduction.mli deleted file mode 100644 index c923c6acf..000000000 --- a/matita/components/cic_proof_checking/cicMiniReduction.mli +++ /dev/null @@ -1,26 +0,0 @@ -(* Copyright (C) 2000, 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/. - *) - -val letin_nf : Cic.term -> Cic.term diff --git a/matita/components/cic_proof_checking/cicPp.ml b/matita/components/cic_proof_checking/cicPp.ml deleted file mode 100644 index 97213404e..000000000 --- a/matita/components/cic_proof_checking/cicPp.ml +++ /dev/null @@ -1,534 +0,0 @@ -(* Copyright (C) 2000, 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/. - *) - -(*****************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* This module implements a very simple Coq-like pretty printer that, given *) -(* an object of cic (internal representation) returns a string describing *) -(* the object in a syntax similar to that of coq *) -(* *) -(* It also contains the utility functions to check a name w.r.t the Matita *) -(* naming policy *) -(* *) -(*****************************************************************************) - -(* $Id$ *) - -exception CicPpInternalError;; -exception NotEnoughElements;; - -(* Utility functions *) - -let ppname = - function - Cic.Name s -> s - | Cic.Anonymous -> "_" -;; - -(* get_nth l n returns the nth element of the list l if it exists or *) -(* raises NotEnoughElements if l has less than n elements *) -let rec get_nth l n = - match (n,l) with - (1, he::_) -> he - | (n, he::tail) when n > 1 -> get_nth tail (n-1) - | (_,_) -> raise NotEnoughElements -;; - -(* pp t l *) -(* pretty-prints a term t of cic in an environment l where l is a list of *) -(* identifier names used to resolve DeBrujin indexes. The head of l is the *) -(* name associated to the greatest DeBrujin index in t *) -let pp ?metasenv = -let rec pp t l = - let module C = Cic in - match t with - C.Rel n -> - begin - try - (match get_nth l n with - Some (C.Name s) -> s - | Some C.Anonymous -> "__" ^ string_of_int n - | None -> "_hidden_" ^ string_of_int n - ) - with - NotEnoughElements -> string_of_int (List.length l - n) - end - | C.Var (uri,exp_named_subst) -> - UriManager.string_of_uri (*UriManager.name_of_uri*) uri ^ pp_exp_named_subst exp_named_subst l - | C.Meta (n,l1) -> - (match metasenv with - None -> - "?" ^ (string_of_int n) ^ "[" ^ - String.concat " ; " - (List.rev_map (function None -> "_" | Some t -> pp t l) l1) ^ - "]" - | Some metasenv -> - try - let _,context,_ = CicUtil.lookup_meta n metasenv in - "?" ^ (string_of_int n) ^ "[" ^ - String.concat " ; " - (List.rev - (List.map2 - (fun x y -> - match x,y with - _, None - | None, _ -> "_" - | Some _, Some t -> pp t l - ) context l1)) ^ - "]" - with - CicUtil.Meta_not_found _ - | Invalid_argument _ -> - "???" ^ (string_of_int n) ^ "[" ^ - String.concat " ; " - (List.rev_map (function None -> "_" | Some t -> pp t l) l1) ^ - "]" - ) - | C.Sort s -> - (match s with - C.Prop -> "Prop" - | C.Set -> "Set" - | C.Type _ -> "Type" - (*| C.Type u -> ("Type" ^ CicUniv.string_of_universe u)*) - | C.CProp _ -> "CProp" - ) - | C.Implicit (Some `Hole) -> "%" - | C.Implicit _ -> "?" - | C.Prod (b,s,t) -> - (match b with - C.Name n -> "(\\forall " ^ n ^ ":" ^ pp s l ^ "." ^ pp t ((Some b)::l) ^ ")" - | C.Anonymous -> "(" ^ pp s l ^ "\\to " ^ pp t ((Some b)::l) ^ ")" - ) - | C.Cast (v,t) -> "(" ^ pp v l ^ ":" ^ pp t l ^ ")" - | C.Lambda (b,s,t) -> - "(\\lambda " ^ ppname b ^ ":" ^ pp s l ^ "." ^ pp t ((Some b)::l) ^ ")" - | C.LetIn (b,s,ty,t) -> - " let " ^ ppname b ^ ": " ^ pp ty l ^ " \\def " ^ pp s l ^ " in " ^ pp t ((Some b)::l) - | C.Appl li -> - "(" ^ - (List.fold_right - (fun x i -> pp x l ^ (match i with "" -> "" | _ -> " ") ^ i) - li "" - ) ^ ")" - | C.Const (uri,exp_named_subst) -> - UriManager.name_of_uri uri ^ pp_exp_named_subst exp_named_subst l - | C.MutInd (uri,n,exp_named_subst) -> - (try - match fst(CicEnvironment.get_obj CicUniv.empty_ugraph uri) with - C.InductiveDefinition (dl,_,_,_) -> - let (name,_,_,_) = get_nth dl (n+1) in - name ^ pp_exp_named_subst exp_named_subst l - | _ -> raise CicPpInternalError - with - Sys.Break as exn -> raise exn - | _ -> UriManager.string_of_uri uri ^ "#1/" ^ string_of_int (n + 1) - ) - | C.MutConstruct (uri,n1,n2,exp_named_subst) -> - (try - match fst(CicEnvironment.get_obj CicUniv.empty_ugraph uri) with - C.InductiveDefinition (dl,_,_,_) -> - let (_,_,_,cons) = get_nth dl (n1+1) in - let (id,_) = get_nth cons n2 in - id ^ pp_exp_named_subst exp_named_subst l - | _ -> raise CicPpInternalError - with - Sys.Break as exn -> raise exn - | _ -> - UriManager.string_of_uri uri ^ "#1/" ^ string_of_int (n1 + 1) ^ "/" ^ - string_of_int n2 - ) - | C.MutCase (uri,n1,ty,te,patterns) -> - let connames_and_argsno = - (match fst(CicEnvironment.get_obj CicUniv.empty_ugraph uri) with - C.InductiveDefinition (dl,_,paramsno,_) -> - let (_,_,_,cons) = get_nth dl (n1+1) in - List.map - (fun (id,ty) -> - (* this is just an approximation since we do not have - reduction yet! *) - let rec count_prods toskip = - function - C.Prod (_,_,bo) when toskip > 0 -> - count_prods (toskip - 1) bo - | C.Prod (_,_,bo) -> 1 + count_prods 0 bo - | _ -> 0 - in - id, count_prods paramsno ty - ) cons - | _ -> raise CicPpInternalError - ) - in - let connames_and_argsno_and_patterns = - let rec combine = - function - [],[] -> [] - | [],l -> List.map (fun x -> "???",0,Some x) l - | l,[] -> List.map (fun (x,no) -> x,no,None) l - | (x,no)::tlx,y::tly -> (x,no,Some y)::(combine (tlx,tly)) - in - combine (connames_and_argsno,patterns) - in - "\nmatch " ^ pp te l ^ " return " ^ pp ty l ^ " with \n [ " ^ - (String.concat "\n | " - (List.map - (fun (x,argsno,y) -> - let rec aux argsno l = - function - Cic.Lambda (name,ty,bo) when argsno > 0 -> - let args,res = aux (argsno - 1) (Some name::l) bo in - ("(" ^ (match name with C.Anonymous -> "_" | C.Name s -> s)^ - ":" ^ pp ty l ^ ")")::args, res - | t when argsno = 0 -> [],pp t l - | t -> ["{" ^ string_of_int argsno ^ " args missing}"],pp t l - in - let pattern,body = - match y with - None -> x,"" - | Some y when argsno = 0 -> x,pp y l - | Some y -> - let args,body = aux argsno l y in - "(" ^ x ^ " " ^ String.concat " " args ^ ")",body - in - pattern ^ " => " ^ body - ) connames_and_argsno_and_patterns)) ^ - "\n]" - | C.Fix (no, funs) -> - let snames = List.map (fun (name,_,_,_) -> name) funs in - let names = - List.rev (List.map (function name -> Some (C.Name name)) snames) - in - "\nFix " ^ get_nth snames (no + 1) ^ " {" ^ - List.fold_right - (fun (name,ind,ty,bo) i -> "\n" ^ name ^ " / " ^ string_of_int ind ^ - " : " ^ pp ty l ^ " := \n" ^ - pp bo (names@l) ^ i) - funs "" ^ - "}\n" - | C.CoFix (no,funs) -> - let snames = List.map (fun (name,_,_) -> name) funs in - let names = - List.rev (List.map (function name -> Some (C.Name name)) snames) - in - "\nCoFix " ^ get_nth snames (no + 1) ^ " {" ^ - List.fold_right - (fun (name,ty,bo) i -> "\n" ^ name ^ - " : " ^ pp ty l ^ " := \n" ^ - pp bo (names@l) ^ i) - funs "" ^ - "}\n" -and pp_exp_named_subst exp_named_subst l = - if exp_named_subst = [] then "" else - "\\subst[" ^ - String.concat " ; " ( - List.map - (function (uri,t) -> UriManager.name_of_uri uri ^ " \\Assign " ^ pp t l) - exp_named_subst - ) ^ "]" -in - pp -;; - -let ppterm ?metasenv t = - pp ?metasenv t [] -;; - -(* ppinductiveType (typename, inductive, arity, cons) *) -(* pretty-prints a single inductive definition *) -(* (typename, inductive, arity, cons) *) -let ppinductiveType (typename, inductive, arity, cons) = - (if inductive then "\nInductive " else "\nCoInductive ") ^ typename ^ ": " ^ - pp arity [] ^ " =\n " ^ - List.fold_right - (fun (id,ty) i -> id ^ " : " ^ pp ty [] ^ - (if i = "" then "\n" else "\n | ") ^ i) - cons "" -;; - -let ppcontext ?metasenv ?(sep = "\n") context = - let separate s = if s = "" then "" else s ^ sep in - fst (List.fold_right - (fun context_entry (i,name_context) -> - match context_entry with - Some (n,Cic.Decl t) -> - Printf.sprintf "%s%s : %s" (separate i) (ppname n) - (pp ?metasenv t name_context), (Some n)::name_context - | Some (n,Cic.Def (bo,ty)) -> - Printf.sprintf "%s%s : %s := %s" (separate i) (ppname n) - (pp ?metasenv ty name_context) - (pp ?metasenv bo name_context), (Some n)::name_context - | None -> - Printf.sprintf "%s_ :? _" (separate i), None::name_context - ) context ("",[])) - -(* ppobj obj returns a string with describing the cic object obj in a syntax *) -(* similar to the one used by Coq *) -let ppobj obj = - let module C = Cic in - let module U = UriManager in - match obj with - C.Constant (name, Some t1, t2, params, _) -> - "Definition of " ^ name ^ - "(" ^ String.concat ";" (List.map UriManager.string_of_uri params) ^ - ")" ^ ":\n" ^ pp t1 [] ^ " : " ^ pp t2 [] - | C.Constant (name, None, ty, params, _) -> - "Axiom " ^ name ^ - "(" ^ String.concat ";" (List.map UriManager.string_of_uri params) ^ - "):\n" ^ pp ty [] - | C.Variable (name, bo, ty, params, _) -> - "Variable " ^ name ^ - "(" ^ String.concat ";" (List.map UriManager.string_of_uri params) ^ - ")" ^ ":\n" ^ - pp ty [] ^ "\n" ^ - (match bo with None -> "" | Some bo -> ":= " ^ pp bo []) - | C.CurrentProof (name, conjectures, value, ty, params, _) -> - "Current Proof of " ^ name ^ - "(" ^ String.concat ";" (List.map UriManager.string_of_uri params) ^ - ")" ^ ":\n" ^ - let separate s = if s = "" then "" else s ^ " ; " in - List.fold_right - (fun (n, context, t) i -> - let conjectures',name_context = - List.fold_right - (fun context_entry (i,name_context) -> - (match context_entry with - Some (n,C.Decl at) -> - (separate i) ^ - ppname n ^ ":" ^ - pp ~metasenv:conjectures at name_context ^ " ", - (Some n)::name_context - | Some (n,C.Def (at,aty)) -> - (separate i) ^ - ppname n ^ ": " ^ - pp ~metasenv:conjectures aty name_context ^ - ":= " ^ pp ~metasenv:conjectures - at name_context ^ " ", - (Some n)::name_context - | None -> - (separate i) ^ "_ :? _ ", None::name_context) - ) context ("",[]) - in - conjectures' ^ " |- " ^ "?" ^ (string_of_int n) ^ ": " ^ - pp ~metasenv:conjectures t name_context ^ "\n" ^ i - ) conjectures "" ^ - "\n" ^ pp ~metasenv:conjectures value [] ^ " : " ^ - pp ~metasenv:conjectures ty [] - | C.InductiveDefinition (l, params, nparams, _) -> - "Parameters = " ^ - String.concat ";" (List.map UriManager.string_of_uri params) ^ "\n" ^ - "NParams = " ^ string_of_int nparams ^ "\n" ^ - List.fold_right (fun x i -> ppinductiveType x ^ i) l "" -;; - -let ppsort = function - | Cic.Prop -> "Prop" - | Cic.Set -> "Set" - | Cic.Type _ -> "Type" - | Cic.CProp _ -> "CProp" - - -(* MATITA NAMING CONVENTION *) - -let is_prefix prefix string = - let len = String.length prefix in - let len1 = String.length string in - if len <= len1 then - begin - let head = String.sub string 0 len in - if - (String.compare (String.lowercase head) (String.lowercase prefix)=0) then - begin - let diff = len1-len in - let tail = String.sub string len diff in - if ((diff > 0) && (String.rcontains_from tail 0 '_')) then - Some (String.sub tail 1 (diff-1)) - else Some tail - end - else None - end - else None - -let remove_prefix prefix (last,string) = - if string = "" then (last,string) - else - match is_prefix prefix string with - None -> - if last <> "" then - match is_prefix last prefix with - None -> (last,string) - | Some _ -> - (match is_prefix prefix (last^string) with - None -> (last,string) - | Some tail -> (prefix,tail)) - else (last,string) - | Some tail -> (prefix, tail) - -let legal_suffix string = - if string = "" then true else - begin - let legal_s = Str.regexp "_?\\([0-9]+\\|r\\|l\\|'\\|\"\\)" in - (Str.string_match legal_s string 0) && (Str.matched_string string = string) - end - -(** check if a prefix of string_name is legal for term and returns the tail. - chec_rec cannot fail: at worst it return string_name. - The algorithm is greedy, but last contains the last name matched, providing - a one slot buffer. - string_name is here a pair (last,string_name).*) - -let rec check_rec ctx string_name = - function - | Cic.Rel m -> - (match List.nth ctx (m-1) with - Cic.Name name -> - remove_prefix name string_name - | Cic.Anonymous -> string_name) - | Cic.Meta _ -> string_name - | Cic.Sort sort -> remove_prefix (ppsort sort) string_name - | Cic.Implicit _ -> string_name - | Cic.Cast (te,ty) -> check_rec ctx string_name te - | Cic.Prod (name,so,dest) -> - let l_string_name = check_rec ctx string_name so in - check_rec (name::ctx) l_string_name dest - | Cic.Lambda (name,so,dest) -> - let string_name = - match name with - Cic.Anonymous -> string_name - | Cic.Name name -> remove_prefix name string_name in - let l_string_name = check_rec ctx string_name so in - check_rec (name::ctx) l_string_name dest - | Cic.LetIn (name,so,_,dest) -> - let string_name = check_rec ctx string_name so in - check_rec (name::ctx) string_name dest - | Cic.Appl l -> - List.fold_left (check_rec ctx) string_name l - | Cic.Var (uri,exp_named_subst) -> - let name = UriManager.name_of_uri uri in - remove_prefix name string_name - | Cic.Const (uri,exp_named_subst) -> - let name = UriManager.name_of_uri uri in - remove_prefix name string_name - | Cic.MutInd (uri,_,exp_named_subst) -> - let name = UriManager.name_of_uri uri in - remove_prefix name string_name - | Cic.MutConstruct (uri,n,m,exp_named_subst) -> - let name = - (match fst(CicEnvironment.get_obj CicUniv.empty_ugraph uri) with - Cic.InductiveDefinition (dl,_,_,_) -> - let (_,_,_,cons) = get_nth dl (n+1) in - let (id,_) = get_nth cons m in - id - | _ -> assert false) in - remove_prefix name string_name - | Cic.MutCase (_,_,_,te,pl) -> - let string_name = remove_prefix "match" string_name in - let string_name = check_rec ctx string_name te in - List.fold_right (fun t s -> check_rec ctx s t) pl string_name - | Cic.Fix (_,fl) -> - let string_name = remove_prefix "fix" string_name in - let names = List.map (fun (name,_,_,_) -> name) fl in - let onames = - List.rev (List.map (function name -> Cic.Name name) names) - in - List.fold_right - (fun (_,_,_,bo) s -> check_rec (onames@ctx) s bo) fl string_name - | Cic.CoFix (_,fl) -> - let string_name = remove_prefix "cofix" string_name in - let names = List.map (fun (name,_,_) -> name) fl in - let onames = - List.rev (List.map (function name -> Cic.Name name) names) - in - List.fold_right - (fun (_,_,bo) s -> check_rec (onames@ctx) s bo) fl string_name - -let check_name ?(allow_suffix=false) ctx name term = - let (_,tail) = check_rec ctx ("",name) term in - if (not allow_suffix) then (String.length tail = 0) - else legal_suffix tail - -let check_elim ctx conclusion_name = - let elim = Str.regexp "_elim\\|_case" in - if (Str.string_match elim conclusion_name 0) then - let len = String.length conclusion_name in - let tail = String.sub conclusion_name 5 (len-5) in - legal_suffix tail - else false - -let rec check_names ctx hyp_names conclusion_name t = - match t with - | Cic.Prod (name,s,t) -> - (match hyp_names with - [] -> check_names (name::ctx) hyp_names conclusion_name t - | hd::tl -> - if check_name ctx hd s then - check_names (name::ctx) tl conclusion_name t - else - check_names (name::ctx) hyp_names conclusion_name t) - | Cic.Appl ((Cic.Rel n)::args) -> - (match hyp_names with - | [] -> - (check_name ~allow_suffix:true ctx conclusion_name t) || - (check_elim ctx conclusion_name) - | [what_to_elim] -> - (* what to elim could be an argument - of the predicate: e.g. leb_elim *) - let (last,tail) = - List.fold_left (check_rec ctx) ("",what_to_elim) args in - (tail = "" && check_elim ctx conclusion_name) - | _ -> false) - | Cic.MutCase (_,_,Cic.Lambda(name,so,ty),te,_) -> - (match hyp_names with - | [] -> - (match is_prefix "match" conclusion_name with - None -> check_name ~allow_suffix:true ctx conclusion_name t - | Some tail -> check_name ~allow_suffix:true ctx tail t) - | [what_to_match] -> - (* what to match could be the term te or its type so; in this case the - conclusion name should match ty *) - check_name ~allow_suffix:true (name::ctx) conclusion_name ty && - (check_name ctx what_to_match te || check_name ctx what_to_match so) - | _ -> false) - | _ -> - hyp_names=[] && check_name ~allow_suffix:true ctx conclusion_name t - -let check name term = - let names = Str.split (Str.regexp_string "_to_") name in - let hyp_names,conclusion_name = - match List.rev names with - [] -> assert false - | hd::tl -> - let elim = Str.regexp "_elim\\|_case" in - let len = String.length hd in - try - let pos = Str.search_backward elim hd len in - let hyp = String.sub hd 0 pos in - let concl = String.sub hd pos (len-pos) in - List.rev (hyp::tl),concl - with Not_found -> (List.rev tl),hd in - check_names [] hyp_names conclusion_name term -;; - - diff --git a/matita/components/cic_proof_checking/cicPp.mli b/matita/components/cic_proof_checking/cicPp.mli deleted file mode 100644 index e898c352d..000000000 --- a/matita/components/cic_proof_checking/cicPp.mli +++ /dev/null @@ -1,55 +0,0 @@ -(* Copyright (C) 2000, 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/. - *) - -(*****************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Claudio Sacerdoti Coen *) -(* 24/01/2000 *) -(* *) -(* This module implements a very simple Coq-like pretty printer that, given *) -(* an object of cic (internal representation) returns a string describing the*) -(* object in a syntax similar to that of coq *) -(* *) -(*****************************************************************************) - -(* ppobj obj returns a string with describing the cic object obj in a syntax*) -(* similar to the one used by Coq *) -val ppobj : Cic.obj -> string - -val ppterm : ?metasenv:Cic.metasenv -> Cic.term -> string - -val ppcontext : ?metasenv:Cic.metasenv -> ?sep:string -> Cic.context -> string - -(* Required only by the topLevel. It is the generalization of ppterm to *) -(* work with environments. *) -val pp : ?metasenv:Cic.metasenv -> Cic.term -> (Cic.name option) list -> string - -val ppname : Cic.name -> string - -val ppsort: Cic.sort -> string - -val check: string -> Cic.term -> bool diff --git a/matita/components/cic_proof_checking/cicReduction.ml b/matita/components/cic_proof_checking/cicReduction.ml deleted file mode 100644 index 5c5db75b4..000000000 --- a/matita/components/cic_proof_checking/cicReduction.ml +++ /dev/null @@ -1,1280 +0,0 @@ -(* Copyright (C) 2000, 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$ *) - -(* TODO unify exceptions *) - -exception WrongUriToInductiveDefinition;; -exception Impossible of int;; -exception ReferenceToConstant;; -exception ReferenceToVariable;; -exception ReferenceToCurrentProof;; -exception ReferenceToInductiveDefinition;; - -let ndebug = ref false;; -let indent = ref "";; -let times = ref [];; -let pp s = - if !ndebug then - prerr_endline (Printf.sprintf "%-20s" !indent ^ " " ^ Lazy.force s) -;; -let inside c = - if !ndebug then - begin - let time1 = Unix.gettimeofday () in - indent := !indent ^ String.make 1 c; - times := time1 :: !times; - prerr_endline ("{{{" ^ !indent ^ " ") - end -;; -let outside ok = - if !ndebug then - begin - let time2 = Unix.gettimeofday () in - let time1 = - match !times with time1::tl -> times := tl; time1 | [] -> assert false in - prerr_endline ("}}} " ^ string_of_float (time2 -. time1)); - if not ok then prerr_endline "exception raised!"; - try - indent := String.sub !indent 0 (String.length !indent -1) - with - Invalid_argument _ -> indent := "??"; () - end -;; - -let debug = false -let profile = false -let debug_print s = if debug then prerr_endline (Lazy.force s) - -let fdebug = ref 1;; -let debug t env s = - let rec debug_aux t i = - let module C = Cic in - let module U = UriManager in - CicPp.ppobj (C.Variable ("DEBUG", None, t, [], [])) ^ "\n" ^ i - in - if !fdebug = 0 then - debug_print (lazy (s ^ "\n" ^ List.fold_right debug_aux (t::env) "")) -;; - -module type Strategy = - sig - type stack_term - type env_term - type ens_term - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - val to_env : - reduce: (config -> config) -> - unwind: (config -> Cic.term) -> - config -> env_term - val to_ens : - reduce: (config -> config) -> - unwind: (config -> Cic.term) -> - config -> ens_term - val from_stack : stack_term -> config - val from_stack_list_for_unwind : - unwind: (config -> Cic.term) -> - stack_term list -> Cic.term list - val from_env : env_term -> config - val from_env_for_unwind : - unwind: (config -> Cic.term) -> - env_term -> Cic.term - val from_ens : ens_term -> config - val from_ens_for_unwind : - unwind: (config -> Cic.term) -> - ens_term -> Cic.term - val stack_to_env : - reduce: (config -> config) -> - unwind: (config -> Cic.term) -> - stack_term -> env_term - val compute_to_env : - reduce: (config -> config) -> - unwind: (config -> Cic.term) -> - int -> env_term list -> ens_term Cic.explicit_named_substitution -> - Cic.term -> env_term - val compute_to_stack : - reduce: (config -> config) -> - unwind: (config -> Cic.term) -> - config -> stack_term - end -;; - -module CallByValueByNameForUnwind = - struct - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - and stack_term = config - and env_term = config * config (* cbv, cbn *) - and ens_term = config * config (* cbv, cbn *) - - let to_env c = c,c - let to_ens c = c,c - let from_stack config = config - let from_stack_list_for_unwind ~unwind l = List.map unwind l - let from_env (c,_) = c - let from_ens (c,_) = c - let from_env_for_unwind ~unwind (_,c) = unwind c - let from_ens_for_unwind ~unwind (_,c) = unwind c - let stack_to_env ~reduce ~unwind config = reduce config, (0,[],[],unwind config,[]) - let compute_to_env ~reduce ~unwind k e ens t = (k,e,ens,t,[]), (k,e,ens,t,[]) - let compute_to_stack ~reduce ~unwind config = config - end -;; - -module CallByValueByNameForUnwind' = - struct - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - and stack_term = config lazy_t * Cic.term lazy_t (* cbv, cbn *) - and env_term = config lazy_t * Cic.term lazy_t (* cbv, cbn *) - and ens_term = config lazy_t * Cic.term lazy_t (* cbv, cbn *) - - let to_env ~reduce ~unwind c = lazy (reduce c),lazy (unwind c) - let to_ens ~reduce ~unwind c = lazy (reduce c),lazy (unwind c) - let from_stack (c,_) = Lazy.force c - let from_stack_list_for_unwind ~unwind l = List.map (function (_,c) -> Lazy.force c) l - let from_env (c,_) = Lazy.force c - let from_ens (c,_) = Lazy.force c - let from_env_for_unwind ~unwind (_,c) = Lazy.force c - let from_ens_for_unwind ~unwind (_,c) = Lazy.force c - let stack_to_env ~reduce ~unwind config = config - let compute_to_env ~reduce ~unwind k e ens t = - lazy (reduce (k,e,ens,t,[])), lazy (unwind (k,e,ens,t,[])) - let compute_to_stack ~reduce ~unwind config = lazy (reduce config), lazy (unwind config) - end -;; - - -(* Old Machine -module CallByNameStrategy = - struct - type stack_term = Cic.term - type env_term = Cic.term - type ens_term = Cic.term - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - let to_env v = v - let to_ens v = v - let from_stack ~unwind v = v - let from_stack_list ~unwind l = l - let from_env v = v - let from_ens v = v - let from_env_for_unwind ~unwind v = v - let from_ens_for_unwind ~unwind v = v - let stack_to_env ~reduce ~unwind v = v - let compute_to_stack ~reduce ~unwind k e ens t = unwind k e ens t - let compute_to_env ~reduce ~unwind k e ens t = unwind k e ens t - end -;; -*) - -module CallByNameStrategy = - struct - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - and stack_term = config - and env_term = config - and ens_term = config - - let to_env c = c - let to_ens c = c - let from_stack config = config - let from_stack_list_for_unwind ~unwind l = List.map unwind l - let from_env c = c - let from_ens c = c - let from_env_for_unwind ~unwind c = unwind c - let from_ens_for_unwind ~unwind c = unwind c - let stack_to_env ~reduce ~unwind config = 0,[],[],unwind config,[] - let compute_to_env ~reduce ~unwind k e ens t = k,e,ens,t,[] - let compute_to_stack ~reduce ~unwind config = config - end -;; - -module CallByValueStrategy = - struct - type stack_term = Cic.term - type env_term = Cic.term - type ens_term = Cic.term - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - let to_env v = v - let to_ens v = v - let from_stack ~unwind v = v - let from_stack_list ~unwind l = l - let from_env v = v - let from_ens v = v - let from_env_for_unwind ~unwind v = v - let from_ens_for_unwind ~unwind v = v - let stack_to_env ~reduce ~unwind v = v - let compute_to_stack ~reduce ~unwind k e ens t = reduce (k,e,ens,t,[]) - let compute_to_env ~reduce ~unwind k e ens t = reduce (k,e,ens,t,[]) - end -;; - -module CallByValueStrategyByNameOnConstants = - struct - type stack_term = Cic.term - type env_term = Cic.term - type ens_term = Cic.term - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - let to_env v = v - let to_ens v = v - let from_stack ~unwind v = v - let from_stack_list ~unwind l = l - let from_env v = v - let from_ens v = v - let from_env_for_unwind ~unwind v = v - let from_ens_for_unwind ~unwind v = v - let stack_to_env ~reduce ~unwind v = v - let compute_to_stack ~reduce ~unwind k e ens = - function - Cic.Const _ as t -> unwind k e ens t - | t -> reduce (k,e,ens,t,[]) - let compute_to_env ~reduce ~unwind k e ens = - function - Cic.Const _ as t -> unwind k e ens t - | t -> reduce (k,e,ens,t,[]) - end -;; - -module LazyCallByValueStrategy = - struct - type stack_term = Cic.term lazy_t - type env_term = Cic.term lazy_t - type ens_term = Cic.term lazy_t - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - let to_env v = lazy v - let to_ens v = lazy v - let from_stack ~unwind v = Lazy.force v - let from_stack_list ~unwind l = List.map (from_stack ~unwind) l - let from_env v = Lazy.force v - let from_ens v = Lazy.force v - let from_env_for_unwind ~unwind v = Lazy.force v - let from_ens_for_unwind ~unwind v = Lazy.force v - let stack_to_env ~reduce ~unwind v = v - let compute_to_stack ~reduce ~unwind k e ens t = lazy (reduce (k,e,ens,t,[])) - let compute_to_env ~reduce ~unwind k e ens t = lazy (reduce (k,e,ens,t,[])) - end -;; - -module LazyCallByValueStrategyByNameOnConstants = - struct - type stack_term = Cic.term lazy_t - type env_term = Cic.term lazy_t - type ens_term = Cic.term lazy_t - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - let to_env v = lazy v - let to_ens v = lazy v - let from_stack ~unwind v = Lazy.force v - let from_stack_list ~unwind l = List.map (from_stack ~unwind) l - let from_env v = Lazy.force v - let from_ens v = Lazy.force v - let from_env_for_unwind ~unwind v = Lazy.force v - let from_ens_for_unwind ~unwind v = Lazy.force v - let stack_to_env ~reduce ~unwind v = v - let compute_to_stack ~reduce ~unwind k e ens t = - lazy ( - match t with - Cic.Const _ as t -> unwind k e ens t - | t -> reduce (k,e,ens,t,[])) - let compute_to_env ~reduce ~unwind k e ens t = - lazy ( - match t with - Cic.Const _ as t -> unwind k e ens t - | t -> reduce (k,e,ens,t,[])) - end -;; - -module LazyCallByNameStrategy = - struct - type stack_term = Cic.term lazy_t - type env_term = Cic.term lazy_t - type ens_term = Cic.term lazy_t - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - let to_env v = lazy v - let to_ens v = lazy v - let from_stack ~unwind v = Lazy.force v - let from_stack_list ~unwind l = List.map (from_stack ~unwind) l - let from_env v = Lazy.force v - let from_ens v = Lazy.force v - let from_env_for_unwind ~unwind v = Lazy.force v - let from_ens_for_unwind ~unwind v = Lazy.force v - let stack_to_env ~reduce ~unwind v = v - let compute_to_stack ~reduce ~unwind k e ens t = lazy (unwind k e ens t) - let compute_to_env ~reduce ~unwind k e ens t = lazy (unwind k e ens t) - end -;; - -module - LazyCallByValueByNameOnConstantsWhenFromStack_ByNameStrategyWhenFromEnvOrEns -= - struct - type stack_term = reduce:bool -> Cic.term - type env_term = reduce:bool -> Cic.term - type ens_term = reduce:bool -> Cic.term - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - let to_env v = - let value = lazy v in - fun ~reduce -> Lazy.force value - let to_ens v = - let value = lazy v in - fun ~reduce -> Lazy.force value - let from_stack ~unwind v = (v ~reduce:false) - let from_stack_list ~unwind l = List.map (from_stack ~unwind) l - let from_env v = (v ~reduce:true) - let from_ens v = (v ~reduce:true) - let from_env_for_unwind ~unwind v = (v ~reduce:true) - let from_ens_for_unwind ~unwind v = (v ~reduce:true) - let stack_to_env ~reduce ~unwind v = v - let compute_to_stack ~reduce ~unwind k e ens t = - let svalue = - lazy ( - match t with - Cic.Const _ as t -> unwind k e ens t - | t -> reduce (k,e,ens,t,[]) - ) in - let lvalue = - lazy (unwind k e ens t) - in - fun ~reduce -> - if reduce then Lazy.force svalue else Lazy.force lvalue - let compute_to_env ~reduce ~unwind k e ens t = - let svalue = - lazy ( - match t with - Cic.Const _ as t -> unwind k e ens t - | t -> reduce (k,e,ens,t,[]) - ) in - let lvalue = - lazy (unwind k e ens t) - in - fun ~reduce -> - if reduce then Lazy.force svalue else Lazy.force lvalue - end -;; - -module ClosuresOnStackByValueFromEnvOrEnsStrategy = - struct - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - and stack_term = config - and env_term = config - and ens_term = config - - let to_env config = config - let to_ens config = config - let from_stack config = config - let from_stack_list_for_unwind ~unwind l = List.map unwind l - let from_env v = v - let from_ens v = v - let from_env_for_unwind ~unwind config = unwind config - let from_ens_for_unwind ~unwind config = unwind config - let stack_to_env ~reduce ~unwind config = reduce config - let compute_to_env ~reduce ~unwind k e ens t = (k,e,ens,t,[]) - let compute_to_stack ~reduce ~unwind config = config - end -;; - -module ClosuresOnStackByValueFromEnvOrEnsByNameOnConstantsStrategy = - struct - type stack_term = - int * Cic.term list * Cic.term Cic.explicit_named_substitution * Cic.term - type env_term = Cic.term - type ens_term = Cic.term - type config = int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term * stack_term list - let to_env v = v - let to_ens v = v - let from_stack ~unwind (k,e,ens,t) = unwind k e ens t - let from_stack_list ~unwind l = List.map (from_stack ~unwind) l - let from_env v = v - let from_ens v = v - let from_env_for_unwind ~unwind v = v - let from_ens_for_unwind ~unwind v = v - let stack_to_env ~reduce ~unwind (k,e,ens,t) = - match t with - Cic.Const _ as t -> unwind k e ens t - | t -> reduce (k,e,ens,t,[]) - let compute_to_env ~reduce ~unwind k e ens t = - unwind k e ens t - let compute_to_stack ~reduce ~unwind k e ens t = (k,e,ens,t) - end -;; - -module Reduction(RS : Strategy) = - struct - type env = RS.env_term list - type ens = RS.ens_term Cic.explicit_named_substitution - type stack = RS.stack_term list - type config = int * env * ens * Cic.term * stack - - (* k is the length of the environment e *) - (* m is the current depth inside the term *) - let rec unwind' m k e ens t = - let module C = Cic in - let module S = CicSubstitution in - if k = 0 && ens = [] then - t - else - let rec unwind_aux m = - function - C.Rel n as t -> - if n <= m then t else - let d = - try - Some (RS.from_env_for_unwind ~unwind (List.nth e (n-m-1))) - with Failure _ -> None - in - (match d with - Some t' -> - if m = 0 then t' else S.lift m t' - | None -> C.Rel (n-k) - ) - | C.Var (uri,exp_named_subst) -> -(* -debug_print (lazy ("%%%%%UWVAR " ^ String.concat " ; " (List.map (function (uri,t) -> UriManager.string_of_uri uri ^ " := " ^ CicPp.ppterm t) ens))) ; -*) - if List.exists (function (uri',_) -> UriManager.eq uri' uri) ens then - CicSubstitution.lift m (RS.from_ens_for_unwind ~unwind (List.assq uri ens)) - else - let params = - let o,_ = - CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri - in - (match o with - C.Constant _ -> raise ReferenceToConstant - | C.Variable (_,_,_,params,_) -> params - | C.CurrentProof _ -> raise ReferenceToCurrentProof - | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition - ) - in - let exp_named_subst' = - substaux_in_exp_named_subst params exp_named_subst m - in - C.Var (uri,exp_named_subst') - | C.Meta (i,l) -> - let l' = - List.map - (function - None -> None - | Some t -> Some (unwind_aux m t) - ) l - in - C.Meta (i, l') - | C.Sort _ as t -> t - | C.Implicit _ as t -> t - | C.Cast (te,ty) -> C.Cast (unwind_aux m te, unwind_aux m ty) (*CSC ???*) - | C.Prod (n,s,t) -> C.Prod (n, unwind_aux m s, unwind_aux (m + 1) t) - | C.Lambda (n,s,t) -> C.Lambda (n, unwind_aux m s, unwind_aux (m + 1) t) - | C.LetIn (n,s,ty,t) -> - C.LetIn (n, unwind_aux m s, unwind_aux m ty, unwind_aux (m + 1) t) - | C.Appl l -> C.Appl (List.map (unwind_aux m) l) - | C.Const (uri,exp_named_subst) -> - let params = - let o,_ = - CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri - in - (match o with - C.Constant (_,_,_,params,_) -> params - | C.Variable _ -> raise ReferenceToVariable - | C.CurrentProof (_,_,_,_,params,_) -> params - | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition - ) - in - let exp_named_subst' = - substaux_in_exp_named_subst params exp_named_subst m - in - C.Const (uri,exp_named_subst') - | C.MutInd (uri,i,exp_named_subst) -> - let params = - let o,_ = - CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri - in - (match o with - C.Constant _ -> raise ReferenceToConstant - | C.Variable _ -> raise ReferenceToVariable - | C.CurrentProof _ -> raise ReferenceToCurrentProof - | C.InductiveDefinition (_,params,_,_) -> params - ) - in - let exp_named_subst' = - substaux_in_exp_named_subst params exp_named_subst m - in - C.MutInd (uri,i,exp_named_subst') - | C.MutConstruct (uri,i,j,exp_named_subst) -> - let params = - let o,_ = - CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri - in - (match o with - C.Constant _ -> raise ReferenceToConstant - | C.Variable _ -> raise ReferenceToVariable - | C.CurrentProof _ -> raise ReferenceToCurrentProof - | C.InductiveDefinition (_,params,_,_) -> params - ) - in - let exp_named_subst' = - substaux_in_exp_named_subst params exp_named_subst m - in - C.MutConstruct (uri,i,j,exp_named_subst') - | C.MutCase (sp,i,outt,t,pl) -> - C.MutCase (sp,i,unwind_aux m outt, unwind_aux m t, - List.map (unwind_aux m) pl) - | C.Fix (i,fl) -> - let len = List.length fl in - let substitutedfl = - List.map - (fun (name,i,ty,bo) -> - (name, i, unwind_aux m ty, unwind_aux (m+len) bo)) - fl - in - C.Fix (i, substitutedfl) - | C.CoFix (i,fl) -> - let len = List.length fl in - let substitutedfl = - List.map - (fun (name,ty,bo) -> (name, unwind_aux m ty, unwind_aux (m+len) bo)) - fl - in - C.CoFix (i, substitutedfl) - and substaux_in_exp_named_subst params exp_named_subst' m = - (*CSC: codice copiato e modificato dalla cicSubstitution.subst_vars *) - let rec filter_and_lift already_instantiated = - function - [] -> [] - | (uri,t)::tl when - List.for_all - (function (uri',_)-> not (UriManager.eq uri uri')) exp_named_subst' - && - not (List.mem uri already_instantiated) - && - List.mem uri params - -> - (uri,CicSubstitution.lift m (RS.from_ens_for_unwind ~unwind t)) :: - (filter_and_lift (uri::already_instantiated) tl) - | _::tl -> filter_and_lift already_instantiated tl - in - let res = - List.map (function (uri,t) -> uri, unwind_aux m t) exp_named_subst' @ - (filter_and_lift [] (List.rev ens)) - in - let rec reorder = - function - [] -> [] - | uri::tl -> - let he = - try - [uri,List.assoc uri res] - with - Not_found -> [] - in - he@reorder tl - in - reorder params - in - unwind_aux m t - - and unwind (k,e,ens,t,s) = - let t' = unwind' 0 k e ens t in - if s = [] then t' else Cic.Appl (t'::(RS.from_stack_list_for_unwind ~unwind s)) - ;; - -(* - let unwind = - let profiler_unwind = HExtlib.profile ~enable:profile "are_convertible.unwind" in - fun k e ens t -> - profiler_unwind.HExtlib.profile (unwind k e ens) t - ;; -*) - - let reduce ~delta ?(subst = []) context : config -> config = - let module C = Cic in - let module S = CicSubstitution in - let rec reduce = - function - (k, e, _, C.Rel n, s) as config -> - let config' = - if not delta then None - else - try - Some (RS.from_env (List.nth e (n-1))) - with - Failure _ -> - try - begin - match List.nth context (n - 1 - k) with - None -> assert false - | Some (_,C.Decl _) -> None - | Some (_,C.Def (x,_)) -> Some (0,[],[],S.lift (n - k) x,[]) - end - with - Failure _ -> None - in - (match config' with - Some (k',e',ens',t',s') -> reduce (k',e',ens',t',s'@s) - | None -> config) - | (k, e, ens, C.Var (uri,exp_named_subst), s) as config -> - if List.exists (function (uri',_) -> UriManager.eq uri' uri) ens then - let (k',e',ens',t',s') = RS.from_ens (List.assq uri ens) in - reduce (k',e',ens',t',s'@s) - else - ( let o,_ = - CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri - in - match o with - C.Constant _ -> raise ReferenceToConstant - | C.CurrentProof _ -> raise ReferenceToCurrentProof - | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition - | C.Variable (_,None,_,_,_) -> config - | C.Variable (_,Some body,_,_,_) -> - let ens' = push_exp_named_subst k e ens exp_named_subst in - reduce (0, [], ens', body, s) - ) - | (k, e, ens, C.Meta (n,l), s) as config -> - (try - let (_, term,_) = CicUtil.lookup_subst n subst in - reduce (k, e, ens,CicSubstitution.subst_meta l term,s) - with CicUtil.Subst_not_found _ -> config) - | (_, _, _, C.Sort _, _) - | (_, _, _, C.Implicit _, _) as config -> config - | (k, e, ens, C.Cast (te,ty), s) -> - reduce (k, e, ens, te, s) - | (_, _, _, C.Prod _, _) as config -> config - | (_, _, _, C.Lambda _, []) as config -> config - | (k, e, ens, C.Lambda (_,_,t), p::s) -> - reduce (k+1, (RS.stack_to_env ~reduce ~unwind p)::e, ens, t,s) - | (k, e, ens, C.LetIn (_,m,_,t), s) -> - let m' = RS.compute_to_env ~reduce ~unwind k e ens m in - reduce (k+1, m'::e, ens, t, s) - | (_, _, _, C.Appl [], _) -> assert false - | (k, e, ens, C.Appl (he::tl), s) -> - let tl' = - List.map - (function t -> RS.compute_to_stack ~reduce ~unwind (k,e,ens,t,[])) tl - in - reduce (k, e, ens, he, (List.append tl') s) - | (_, _, _, C.Const _, _) as config when delta=false-> config - | (k, e, ens, C.Const (uri,exp_named_subst), s) as config -> - (let o,_ = - CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri - in - match o with - C.Constant (_,Some body,_,_,_) -> - let ens' = push_exp_named_subst k e ens exp_named_subst in - (* constants are closed *) - reduce (0, [], ens', body, s) - | C.Constant (_,None,_,_,_) -> config - | C.Variable _ -> raise ReferenceToVariable - | C.CurrentProof (_,_,body,_,_,_) -> - let ens' = push_exp_named_subst k e ens exp_named_subst in - (* constants are closed *) - reduce (0, [], ens', body, s) - | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition - ) - | (_, _, _, C.MutInd _, _) - | (_, _, _, C.MutConstruct _, _) as config -> config - | (k, e, ens, C.MutCase (mutind,i,outty,term,pl),s) as config -> - let decofix = - function - (k, e, ens, C.CoFix (i,fl), s) -> - let (_,_,body) = List.nth fl i in - let body' = - let counter = ref (List.length fl) in - List.fold_right - (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl))) - fl - body - in - reduce (k,e,ens,body',s) - | config -> config - in - (match decofix (reduce (k,e,ens,term,[])) with - (k', e', ens', C.MutConstruct (_,_,j,_), []) -> - reduce (k, e, ens, (List.nth pl (j-1)), s) - | (k', e', ens', C.MutConstruct (_,_,j,_), s') -> - let r = - let o,_ = - CicEnvironment.get_cooked_obj CicUniv.empty_ugraph mutind - in - match o with - C.InductiveDefinition (_,_,r,_) -> r - | _ -> raise WrongUriToInductiveDefinition - in - let ts = - let num_to_eat = r in - let rec eat_first = - function - (0,l) -> l - | (n,he::s) when n > 0 -> eat_first (n - 1, s) - | _ -> raise (Impossible 5) - in - eat_first (num_to_eat,s') - in - reduce (k, e, ens, (List.nth pl (j-1)), ts@s) - | (_, _, _, C.Cast _, _) - | (_, _, _, C.Implicit _, _) -> - raise (Impossible 2) (* we don't trust our whd ;-) *) - | config' -> - (*CSC: here I am unwinding the configuration and for sure I - will do it twice; to avoid this unwinding I should push the - "match [] with _" continuation on the stack; - another possibility is to just return the original configuration, - partially undoing the weak-head computation *) - (*this code is uncorrect since term' lives in e' <> e - let term' = unwind config' in - (k, e, ens, C.MutCase (mutind,i,outty,term',pl),s) - *) - config) - | (k, e, ens, C.Fix (i,fl), s) as config -> - let (_,recindex,_,body) = List.nth fl i in - let recparam = - try - Some (RS.from_stack (List.nth s recindex)) - with - Failure _ -> None - in - (match recparam with - Some recparam -> - (match reduce recparam with - (_,_,_,C.MutConstruct _,_) as config -> - let leng = List.length fl in - let new_env = - let counter = ref 0 in - let rec build_env e' = - if !counter = leng then e' - else - (incr counter ; - build_env - ((RS.to_env ~reduce ~unwind (k,e,ens,C.Fix (!counter -1, fl),[]))::e')) - in - build_env e - in - let rec replace i s t = - match i,s with - 0,_::tl -> t::tl - | n,he::tl -> he::(replace (n - 1) tl t) - | _,_ -> assert false in - let new_s = - replace recindex s (RS.compute_to_stack ~reduce ~unwind config) - in - reduce (k+leng, new_env, ens, body, new_s) - | _ -> config) - | None -> config - ) - | (_,_,_,C.CoFix _,_) as config -> config - and push_exp_named_subst k e ens = - function - [] -> ens - | (uri,t)::tl -> - push_exp_named_subst k e ((uri,RS.to_ens ~reduce ~unwind (k,e,ens,t,[]))::ens) tl - in - reduce - ;; - - let whd ?(delta=true) ?(subst=[]) context t = - unwind (reduce ~delta ~subst context (0, [], [], t, [])) - ;; - - end -;; - - -(* ROTTO = rompe l'unificazione poiche' riduce gli argomenti di un'applicazione - senza ridurre la testa -module R = Reduction CallByNameStrategy;; OK 56.368s -module R = Reduction CallByValueStrategy;; ROTTO -module R = Reduction CallByValueStrategyByNameOnConstants;; ROTTO -module R = Reduction LazyCallByValueStrategy;; ROTTO -module R = Reduction LazyCallByValueStrategyByNameOnConstants;; ROTTO -module R = Reduction LazyCallByNameStrategy;; OK 0m56.398s -module R = Reduction - LazyCallByValueByNameOnConstantsWhenFromStack_ByNameStrategyWhenFromEnvOrEns;; - OK 59.058s -module R = Reduction ClosuresOnStackByValueFromEnvOrEnsStrategy;; OK 58.583s -module R = Reduction - ClosuresOnStackByValueFromEnvOrEnsByNameOnConstantsStrategy;; OK 58.094s -module R = Reduction(ClosuresOnStackByValueFromEnvOrEnsStrategy);; OK 58.127s -*) -(*module R = Reduction(CallByValueByNameForUnwind);;*) -module RS = CallByValueByNameForUnwind';; -(*module R = Reduction(CallByNameStrategy);;*) -(*module R = Reduction(ClosuresOnStackByValueFromEnvOrEnsStrategy);;*) -module R = Reduction(RS);; -module U = UriManager;; - -let whd = R.whd - -(* -let whd = - let profiler_whd = HExtlib.profile ~enable:profile "are_convertible.whd" in - fun ?(delta=true) ?(subst=[]) context t -> - profiler_whd.HExtlib.profile (whd ~delta ~subst context) t -*) - - (* mimic ocaml (<< 3.08) "=" behaviour. Tests physical equality first then - * fallbacks to structural equality *) -let (===) x y = - Pervasives.compare x y = 0 - -(* t1, t2 must be well-typed *) -let are_convertible whd ?(subst=[]) ?(metasenv=[]) = - let heuristic = ref true in - let rec aux test_equality_only context t1 t2 ugraph = - (*D*)inside 'B'; try let rc = - pp (lazy (CicPp.ppterm t1 ^ " vs " ^ CicPp.ppterm t2)); - let rec aux2 test_equality_only t1 t2 ugraph = - - (* this trivial euristic cuts down the total time of about five times ;-) *) - (* this because most of the time t1 and t2 are "sintactically" the same *) - if t1 === t2 then - true,ugraph - else - begin - let module C = Cic in - match (t1,t2) with - (C.Rel n1, C.Rel n2) -> (n1 = n2),ugraph - | (C.Var (uri1,exp_named_subst1), C.Var (uri2,exp_named_subst2)) -> - if U.eq uri1 uri2 then - (try - List.fold_right2 - (fun (uri1,x) (uri2,y) (b,ugraph) -> - let b',ugraph' = aux test_equality_only context x y ugraph in - (U.eq uri1 uri2 && b' && b),ugraph' - ) exp_named_subst1 exp_named_subst2 (true,ugraph) - with - Invalid_argument _ -> false,ugraph - ) - else - false,ugraph - | (C.Meta (n1,l1), C.Meta (n2,l2)) -> - if n1 = n2 then - let b2, ugraph1 = - let l1 = CicUtil.clean_up_local_context subst metasenv n1 l1 in - let l2 = CicUtil.clean_up_local_context subst metasenv n2 l2 in - List.fold_left2 - (fun (b,ugraph) t1 t2 -> - if b then - match t1,t2 with - None,_ - | _,None -> true,ugraph - | Some t1',Some t2' -> - aux test_equality_only context t1' t2' ugraph - else - false,ugraph - ) (true,ugraph) l1 l2 - in - if b2 then true,ugraph1 else false,ugraph - else - false,ugraph - | C.Meta (n1,l1), _ -> - (try - let _,term,_ = CicUtil.lookup_subst n1 subst in - let term' = CicSubstitution.subst_meta l1 term in -(* -prerr_endline ("%?: " ^ CicPp.ppterm t1 ^ " <==> " ^ CicPp.ppterm t2); -prerr_endline ("%%%%%%: " ^ CicPp.ppterm term' ^ " <==> " ^ CicPp.ppterm t2); -*) - aux test_equality_only context term' t2 ugraph - with CicUtil.Subst_not_found _ -> false,ugraph) - | _, C.Meta (n2,l2) -> - (try - let _,term,_ = CicUtil.lookup_subst n2 subst in - let term' = CicSubstitution.subst_meta l2 term in -(* -prerr_endline ("%?: " ^ CicPp.ppterm t1 ^ " <==> " ^ CicPp.ppterm t2); -prerr_endline ("%%%%%%: " ^ CicPp.ppterm term' ^ " <==> " ^ CicPp.ppterm t1); -*) - aux test_equality_only context t1 term' ugraph - with CicUtil.Subst_not_found _ -> false,ugraph) - | (C.Sort (C.CProp t1|C.Type t1), C.Sort (C.CProp t2|C.Type t2)) - when test_equality_only -> - (try true,(CicUniv.add_eq t2 t1 ugraph) - with CicUniv.UniverseInconsistency _ -> false,ugraph) - | (C.Sort (C.CProp t1|C.Type t1), C.Sort (C.CProp t2|C.Type t2)) - when not test_equality_only -> - (try true,(CicUniv.add_ge t2 t1 ugraph) - with CicUniv.UniverseInconsistency _ -> false,ugraph) - | (C.Sort s1, C.Sort (C.Type _)) - | (C.Sort s1, C.Sort (C.CProp _)) -> (not test_equality_only),ugraph - | (C.Sort s1, C.Sort s2) -> (s1 = s2),ugraph - | (C.Prod (name1,s1,t1), C.Prod(_,s2,t2)) -> - let b',ugraph' = aux true context s1 s2 ugraph in - if b' then - aux test_equality_only ((Some (name1, (C.Decl s1)))::context) - t1 t2 ugraph' - else - false,ugraph - | (C.Lambda (name1,s1,t1), C.Lambda(_,s2,t2)) -> - let b',ugraph' = aux true context s1 s2 ugraph in - if b' then - aux test_equality_only ((Some (name1, (C.Decl s1)))::context) - t1 t2 ugraph' - else - false,ugraph - | (C.LetIn (name1,s1,ty1,t1), C.LetIn(_,s2,ty2,t2)) -> - let b',ugraph' = aux test_equality_only context s1 s2 ugraph in - if b' then - let b',ugraph = aux test_equality_only context ty1 ty2 ugraph in - if b' then - aux test_equality_only - ((Some (name1, (C.Def (s1,ty1))))::context) t1 t2 ugraph' - else - false,ugraph - else - false,ugraph - | (C.Appl l1, C.Appl l2) -> - let b, ugraph = - aux test_equality_only context (List.hd l1) (List.hd l2) ugraph - in - if not b then false, ugraph - else - (try - List.fold_right2 - (fun x y (b,ugraph) -> - if b then - aux true context x y ugraph - else - false,ugraph) (List.tl l1) (List.tl l2) (true,ugraph) - with - Invalid_argument _ -> false,ugraph - ) - | (C.Const (uri1,exp_named_subst1), C.Const (uri2,exp_named_subst2)) -> - let b' = U.eq uri1 uri2 in - if b' then - (try - List.fold_right2 - (fun (uri1,x) (uri2,y) (b,ugraph) -> - if b && U.eq uri1 uri2 then - aux test_equality_only context x y ugraph - else - false,ugraph - ) exp_named_subst1 exp_named_subst2 (true,ugraph) - with - Invalid_argument _ -> false,ugraph - ) - else - false,ugraph - | (C.MutInd (uri1,i1,exp_named_subst1), - C.MutInd (uri2,i2,exp_named_subst2) - ) -> - let b' = U.eq uri1 uri2 && i1 = i2 in - if b' then - (try - List.fold_right2 - (fun (uri1,x) (uri2,y) (b,ugraph) -> - if b && U.eq uri1 uri2 then - aux test_equality_only context x y ugraph - else - false,ugraph - ) exp_named_subst1 exp_named_subst2 (true,ugraph) - with - Invalid_argument _ -> false,ugraph - ) - else - false,ugraph - | (C.MutConstruct (uri1,i1,j1,exp_named_subst1), - C.MutConstruct (uri2,i2,j2,exp_named_subst2) - ) -> - let b' = U.eq uri1 uri2 && i1 = i2 && j1 = j2 in - if b' then - (try - List.fold_right2 - (fun (uri1,x) (uri2,y) (b,ugraph) -> - if b && U.eq uri1 uri2 then - aux test_equality_only context x y ugraph - else - false,ugraph - ) exp_named_subst1 exp_named_subst2 (true,ugraph) - with - Invalid_argument _ -> false,ugraph - ) - else - false,ugraph - | (C.MutCase (uri1,i1,outtype1,term1,pl1), - C.MutCase (uri2,i2,outtype2,term2,pl2)) -> - let b' = U.eq uri1 uri2 && i1 = i2 in - if b' then - let b'',ugraph''=aux test_equality_only context - outtype1 outtype2 ugraph in - if b'' then - let b''',ugraph'''= aux true context - term1 term2 ugraph'' in - List.fold_right2 - (fun x y (b,ugraph) -> - if b then - aux test_equality_only context x y ugraph - else - false,ugraph) - pl1 pl2 (b''',ugraph''') - else - false,ugraph - else - false,ugraph - | (C.Fix (i1,fl1), C.Fix (i2,fl2)) -> - let tys,_ = - List.fold_left - (fun (types,len) (n,_,ty,_) -> - (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types, - len+1) - ) ([],0) fl1 - in - if i1 = i2 then - List.fold_right2 - (fun (_,recindex1,ty1,bo1) (_,recindex2,ty2,bo2) (b,ugraph) -> - if b && recindex1 = recindex2 then - let b',ugraph' = aux test_equality_only context ty1 ty2 - ugraph in - if b' then - aux test_equality_only (tys@context) bo1 bo2 ugraph' - else - false,ugraph - else - false,ugraph) - fl1 fl2 (true,ugraph) - else - false,ugraph - | (C.CoFix (i1,fl1), C.CoFix (i2,fl2)) -> - let tys,_ = - List.fold_left - (fun (types,len) (n,ty,_) -> - (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types, - len+1) - ) ([],0) fl1 - in - if i1 = i2 then - List.fold_right2 - (fun (_,ty1,bo1) (_,ty2,bo2) (b,ugraph) -> - if b then - let b',ugraph' = aux test_equality_only context ty1 ty2 - ugraph in - if b' then - aux test_equality_only (tys@context) bo1 bo2 ugraph' - else - false,ugraph - else - false,ugraph) - fl1 fl2 (true,ugraph) - else - false,ugraph - | C.Cast (bo,_),t -> aux2 test_equality_only bo t ugraph - | t,C.Cast (bo,_) -> aux2 test_equality_only t bo ugraph - | (C.Implicit _, _) | (_, C.Implicit _) -> assert false - | (_,_) -> false,ugraph - end - in - let res = - if !heuristic then - aux2 test_equality_only t1 t2 ugraph - else - false,ugraph - in - if fst res = true then - res - else -begin -(*if !heuristic then prerr_endline ("NON FACILE: " ^ CicPp.ppterm t1 ^ " <===> " ^ CicPp.ppterm t2);*) - (* heuristic := false; *) - debug t1 [t2] "PREWHD"; -(*prerr_endline ("PREWHD: " ^ CicPp.ppterm t1 ^ " <===> " ^ CicPp.ppterm t2);*) -(* -prerr_endline ("PREWHD: " ^ CicPp.ppterm t1 ^ " <===> " ^ CicPp.ppterm t2); - let t1' = whd ?delta:(Some true) ?subst:(Some subst) context t1 in - let t2' = whd ?delta:(Some true) ?subst:(Some subst) context t2 in - debug t1' [t2'] "POSTWHD"; -*) -let rec convert_machines test_equality_only ugraph = - function - [] -> true,ugraph - | ((k1,env1,ens1,h1,s1),(k2,env2,ens2,h2,s2))::tl -> - let (b,ugraph) as res = - aux2 test_equality_only - (R.unwind (k1,env1,ens1,h1,[])) (R.unwind (k2,env2,ens2,h2,[])) ugraph - in - if b then - let problems = - try - Some - (List.combine - (List.map - (fun si-> R.reduce ~delta:false ~subst context(RS.from_stack si)) - s1) - (List.map - (fun si-> R.reduce ~delta:false ~subst context(RS.from_stack si)) - s2) - @ tl) - with - Invalid_argument _ -> None - in - match problems with - None -> false,ugraph - | Some problems -> convert_machines true ugraph problems - else - res -in - convert_machines test_equality_only ugraph - [R.reduce ~delta:true ~subst context (0,[],[],t1,[]), - R.reduce ~delta:true ~subst context (0,[],[],t2,[])] -(*prerr_endline ("POSTWH: " ^ CicPp.ppterm t1' ^ " <===> " ^ CicPp.ppterm t2');*) -(* - aux2 test_equality_only t1' t2' ugraph -*) -end - (*D*)in outside true; rc with exc -> outside false; raise exc - in - aux false (*c t1 t2 ugraph *) -;; - -(* DEBUGGING ONLY -let whd ?(delta=true) ?(subst=[]) context t = - let res = whd ~delta ~subst context t in - let rescsc = CicReductionNaif.whd ~delta ~subst context t in - if not (fst (are_convertible CicReductionNaif.whd ~subst context res rescsc CicUniv.empty_ugraph)) then - begin - debug_print (lazy ("PRIMA: " ^ CicPp.ppterm t)) ; - flush stderr ; - debug_print (lazy ("DOPO: " ^ CicPp.ppterm res)) ; - flush stderr ; - debug_print (lazy ("CSC: " ^ CicPp.ppterm rescsc)) ; - flush stderr ; -fdebug := 0 ; -let _ = are_convertible CicReductionNaif.whd ~subst context res rescsc CicUniv.empty_ugraph in - assert false ; - end - else - res -;; -*) - -let are_convertible = are_convertible whd - -let whd = R.whd - -(* -let profiler_other_whd = HExtlib.profile ~enable:profile "~are_convertible.whd" -let whd ?(delta=true) ?(subst=[]) context t = - let foo () = - whd ~delta ~subst context t - in - profiler_other_whd.HExtlib.profile foo () -*) - -let rec normalize ?(delta=true) ?(subst=[]) ctx term = - let module C = Cic in - let t = whd ~delta ~subst ctx term in - let aux = normalize ~delta ~subst in - let decl name t = Some (name, C.Decl t) in - match t with - | C.Rel n -> t - | C.Var (uri,exp_named_subst) -> - C.Var (uri, List.map (fun (n,t) -> n,aux ctx t) exp_named_subst) - | C.Meta (i,l) -> - C.Meta (i,List.map (function Some t -> Some (aux ctx t) | None -> None) l) - | C.Sort _ -> t - | C.Implicit _ -> t - | C.Cast (te,ty) -> C.Cast (aux ctx te, aux ctx ty) - | C.Prod (n,s,t) -> - let s' = aux ctx s in - C.Prod (n, s', aux ((decl n s')::ctx) t) - | C.Lambda (n,s,t) -> - let s' = aux ctx s in - C.Lambda (n, s', aux ((decl n s')::ctx) t) - | C.LetIn (n,s,_,t) -> - (* the term is already in weak head normal form *) - assert false - | C.Appl (h::l) -> C.Appl (h::(List.map (aux ctx) l)) - | C.Appl [] -> assert false - | C.Const (uri,exp_named_subst) -> - C.Const (uri, List.map (fun (n,t) -> n,aux ctx t) exp_named_subst) - | C.MutInd (uri,typeno,exp_named_subst) -> - C.MutInd (uri,typeno, List.map (fun (n,t) -> n,aux ctx t) exp_named_subst) - | C.MutConstruct (uri,typeno,consno,exp_named_subst) -> - C.MutConstruct (uri, typeno, consno, - List.map (fun (n,t) -> n,aux ctx t) exp_named_subst) - | C.MutCase (sp,i,outt,t,pl) -> - C.MutCase (sp,i, aux ctx outt, aux ctx t, List.map (aux ctx) pl) -(*CSC: to be completed, I suppose *) - | C.Fix _ -> t - | C.CoFix _ -> t - -let normalize ?delta ?subst ctx term = -(* prerr_endline ("NORMALIZE:" ^ CicPp.ppterm term); *) - let t = normalize ?delta ?subst ctx term in -(* prerr_endline ("NORMALIZED:" ^ CicPp.ppterm t); *) - t - - -(* performs an head beta/cast reduction *) -let rec head_beta_reduce ?(delta=false) ?(upto=(-1)) t = - match upto with - 0 -> t - | n -> - match t with - (Cic.Appl (Cic.Lambda (_,_,t)::he'::tl')) -> - let he'' = CicSubstitution.subst he' t in - if tl' = [] then - he'' - else - let he''' = - match he'' with - Cic.Appl l -> Cic.Appl (l@tl') - | _ -> Cic.Appl (he''::tl') - in - head_beta_reduce ~delta ~upto:(upto - 1) he''' - | Cic.Cast (te,_) -> head_beta_reduce ~delta ~upto te - | Cic.Appl (Cic.Const (uri,ens)::tl) as t when delta=true -> - let bo = - match fst (CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri) with - Cic.Constant (_,bo,_,_,_) -> bo - | Cic.Variable _ -> raise ReferenceToVariable - | Cic.CurrentProof (_,_,bo,_,_,_) -> Some bo - | Cic.InductiveDefinition _ -> raise ReferenceToInductiveDefinition - in - (match bo with - None -> t - | Some bo -> - head_beta_reduce ~upto - ~delta (Cic.Appl ((CicSubstitution.subst_vars ens bo)::tl))) - | Cic.Const (uri,ens) as t when delta=true -> - let bo = - match fst (CicEnvironment.get_cooked_obj CicUniv.empty_ugraph uri) with - Cic.Constant (_,bo,_,_,_) -> bo - | Cic.Variable _ -> raise ReferenceToVariable - | Cic.CurrentProof (_,_,bo,_,_,_) -> Some bo - | Cic.InductiveDefinition _ -> raise ReferenceToInductiveDefinition - in - (match bo with - None -> t - | Some bo -> - head_beta_reduce ~delta ~upto (CicSubstitution.subst_vars ens bo)) - | t -> t - -(* -let are_convertible ?subst ?metasenv context t1 t2 ugraph = - let before = Unix.gettimeofday () in - let res = are_convertible ?subst ?metasenv context t1 t2 ugraph in - let after = Unix.gettimeofday () in - let diff = after -. before in - if diff > 0.1 then - begin - let nc = List.map (function None -> None | Some (n,_) -> Some n) context in - prerr_endline - ("\n#(" ^ string_of_float diff ^ "):\n" ^ CicPp.pp t1 nc ^ "\n<=>\n" ^ CicPp.pp t2 nc); - end; - res -*) diff --git a/matita/components/cic_proof_checking/cicReduction.mli b/matita/components/cic_proof_checking/cicReduction.mli deleted file mode 100644 index fd98c4c0b..000000000 --- a/matita/components/cic_proof_checking/cicReduction.mli +++ /dev/null @@ -1,45 +0,0 @@ -(* Copyright (C) 2000, 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/. - *) - -exception WrongUriToInductiveDefinition -exception ReferenceToConstant -exception ReferenceToVariable -exception ReferenceToCurrentProof -exception ReferenceToInductiveDefinition -val ndebug : bool ref -val fdebug : int ref -val whd : - ?delta:bool -> ?subst:Cic.substitution -> Cic.context -> Cic.term -> Cic.term -val are_convertible : - ?subst:Cic.substitution -> ?metasenv:Cic.metasenv -> - Cic.context -> Cic.term -> Cic.term -> CicUniv.universe_graph -> - bool * CicUniv.universe_graph -val normalize: - ?delta:bool -> ?subst:Cic.substitution -> Cic.context -> Cic.term -> Cic.term - -(* performs head beta/(delta)/cast reduction; the default is to not perform - delta reduction; if provided, ~upto is the maximum number of beta redexes - reduced *) -val head_beta_reduce: ?delta:bool -> ?upto:int -> Cic.term -> Cic.term diff --git a/matita/components/cic_proof_checking/cicSubstitution.ml b/matita/components/cic_proof_checking/cicSubstitution.ml deleted file mode 100644 index d111b15b5..000000000 --- a/matita/components/cic_proof_checking/cicSubstitution.ml +++ /dev/null @@ -1,454 +0,0 @@ -(* Copyright (C) 2000, 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$ *) - -exception CannotSubstInMeta;; -exception RelToHiddenHypothesis;; -exception ReferenceToVariable;; -exception ReferenceToConstant;; -exception ReferenceToCurrentProof;; -exception ReferenceToInductiveDefinition;; - -let debug = false -let debug_print = - if debug then - fun m -> prerr_endline (Lazy.force m) - else - fun _ -> () -;; - -let lift_map k map = - let rec liftaux k = - let module C = Cic in - function - C.Rel m -> - if m < k then - C.Rel m - else - C.Rel (map k m) - | C.Var (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (function (uri,t) -> (uri,liftaux k t)) exp_named_subst - in - C.Var (uri,exp_named_subst') - | C.Meta (i,l) -> - let l' = - List.map - (function - None -> None - | Some t -> Some (liftaux k t) - ) l - in - C.Meta(i,l') - | C.Sort _ as t -> t - | C.Implicit _ as t -> t - | C.Cast (te,ty) -> C.Cast (liftaux k te, liftaux k ty) - | C.Prod (n,s,t) -> C.Prod (n, liftaux k s, liftaux (k+1) t) - | C.Lambda (n,s,t) -> C.Lambda (n, liftaux k s, liftaux (k+1) t) - | C.LetIn (n,s,ty,t) -> - C.LetIn (n, liftaux k s, liftaux k ty, liftaux (k+1) t) - | C.Appl l -> C.Appl (List.map (liftaux k) l) - | C.Const (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (function (uri,t) -> (uri,liftaux k t)) exp_named_subst - in - C.Const (uri,exp_named_subst') - | C.MutInd (uri,tyno,exp_named_subst) -> - let exp_named_subst' = - List.map (function (uri,t) -> (uri,liftaux k t)) exp_named_subst - in - C.MutInd (uri,tyno,exp_named_subst') - | C.MutConstruct (uri,tyno,consno,exp_named_subst) -> - let exp_named_subst' = - List.map (function (uri,t) -> (uri,liftaux k t)) exp_named_subst - in - C.MutConstruct (uri,tyno,consno,exp_named_subst') - | C.MutCase (sp,i,outty,t,pl) -> - C.MutCase (sp, i, liftaux k outty, liftaux k t, - List.map (liftaux k) pl) - | C.Fix (i, fl) -> - let len = List.length fl in - let liftedfl = - List.map - (fun (name, i, ty, bo) -> (name, i, liftaux k ty, liftaux (k+len) bo)) - fl - in - C.Fix (i, liftedfl) - | C.CoFix (i, fl) -> - let len = List.length fl in - let liftedfl = - List.map - (fun (name, ty, bo) -> (name, liftaux k ty, liftaux (k+len) bo)) - fl - in - C.CoFix (i, liftedfl) - in - liftaux k - -let lift_from k n = - lift_map k (fun _ m -> m + n) - -let lift n t = - if n = 0 then - t - else - lift_from 1 n t -;; - -(* subst t1 t2 *) -(* substitutes [t1] for [Rel 1] in [t2] *) -(* if avoid_beta_redexes is true (default: false) no new beta redexes *) -(* are generated. WARNING: the substitution can diverge when t2 is not *) -(* well typed and avoid_beta_redexes is true. *) -let rec subst ?(avoid_beta_redexes=false) arg = - let rec substaux k = - let module C = Cic in - function - C.Rel n as t -> - (match n with - n when n = k -> lift (k - 1) arg - | n when n < k -> t - | _ -> C.Rel (n - 1) - ) - | C.Var (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (function (uri,t) -> (uri,substaux k t)) exp_named_subst - in - C.Var (uri,exp_named_subst') - | C.Meta (i, l) -> - let l' = - List.map - (function - None -> None - | Some t -> Some (substaux k t) - ) l - in - C.Meta(i,l') - | C.Sort _ as t -> t - | C.Implicit _ as t -> t - | C.Cast (te,ty) -> C.Cast (substaux k te, substaux k ty) - | C.Prod (n,s,t) -> C.Prod (n, substaux k s, substaux (k + 1) t) - | C.Lambda (n,s,t) -> C.Lambda (n, substaux k s, substaux (k + 1) t) - | C.LetIn (n,s,ty,t) -> - C.LetIn (n, substaux k s, substaux k ty, substaux (k + 1) t) - | C.Appl (he::tl) -> - (* Invariant: no Appl applied to another Appl *) - let tl' = List.map (substaux k) tl in - begin - match substaux k he with - C.Appl l -> C.Appl (l@tl') - (* Experimental *) - | C.Lambda (_,_,bo) when avoid_beta_redexes -> - (match tl' with - [] -> assert false - | [he] -> subst ~avoid_beta_redexes he bo - | he::tl -> C.Appl (subst he bo::tl)) - | _ as he' -> C.Appl (he'::tl') - end - | C.Appl _ -> assert false - | C.Const (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (function (uri,t) -> (uri,substaux k t)) exp_named_subst - in - C.Const (uri,exp_named_subst') - | C.MutInd (uri,typeno,exp_named_subst) -> - let exp_named_subst' = - List.map (function (uri,t) -> (uri,substaux k t)) exp_named_subst - in - C.MutInd (uri,typeno,exp_named_subst') - | C.MutConstruct (uri,typeno,consno,exp_named_subst) -> - let exp_named_subst' = - List.map (function (uri,t) -> (uri,substaux k t)) exp_named_subst - in - C.MutConstruct (uri,typeno,consno,exp_named_subst') - | C.MutCase (sp,i,outt,t,pl) -> - C.MutCase (sp,i,substaux k outt, substaux k t, - List.map (substaux k) pl) - | C.Fix (i,fl) -> - let len = List.length fl in - let substitutedfl = - List.map - (fun (name,i,ty,bo) -> (name, i, substaux k ty, substaux (k+len) bo)) - fl - in - C.Fix (i, substitutedfl) - | C.CoFix (i,fl) -> - let len = List.length fl in - let substitutedfl = - List.map - (fun (name,ty,bo) -> (name, substaux k ty, substaux (k+len) bo)) - fl - in - C.CoFix (i, substitutedfl) - in - substaux 1 -;; - -(*CSC: i controlli di tipo debbono essere svolti da destra a *) -(*CSC: sinistra: i{B/A;b/a} ==> a{B/A;b/a} ==> a{b/a{B/A}} ==> b *) -(*CSC: la sostituzione ora e' implementata in maniera simultanea, ma *) -(*CSC: dovrebbe diventare da sinistra verso destra: *) -(*CSC: t{a=a/A;b/a} ==> \H:a=a.H{b/a} ==> \H:b=b.H *) -(*CSC: per la roba che proviene da Coq questo non serve! *) -let subst_vars exp_named_subst t = -(* -debug_print (lazy ("@@@POSSIBLE BUG: SUBSTITUTION IS NOT SIMULTANEOUS")) ; -*) - let rec substaux k = - let module C = Cic in - function - C.Rel _ as t -> t - | C.Var (uri,exp_named_subst') -> - (try - let (_,arg) = - List.find - (function (varuri,_) -> UriManager.eq uri varuri) exp_named_subst - in - lift (k -1) arg - with - Not_found -> - let params = - let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - (match obj with - C.Constant _ -> raise ReferenceToConstant - | C.Variable (_,_,_,params,_) -> params - | C.CurrentProof _ -> raise ReferenceToCurrentProof - | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition - ) - in - let exp_named_subst'' = - substaux_in_exp_named_subst uri k exp_named_subst' params - in - C.Var (uri,exp_named_subst'') - ) - | C.Meta (i, l) -> - let l' = - List.map - (function - None -> None - | Some t -> Some (substaux k t) - ) l - in - C.Meta(i,l') - | C.Sort _ as t -> t - | C.Implicit _ as t -> t - | C.Cast (te,ty) -> C.Cast (substaux k te, substaux k ty) - | C.Prod (n,s,t) -> C.Prod (n, substaux k s, substaux (k + 1) t) - | C.Lambda (n,s,t) -> C.Lambda (n, substaux k s, substaux (k + 1) t) - | C.LetIn (n,s,ty,t) -> - C.LetIn (n, substaux k s, substaux k ty, substaux (k + 1) t) - | C.Appl (he::tl) -> - (* Invariant: no Appl applied to another Appl *) - let tl' = List.map (substaux k) tl in - begin - match substaux k he with - C.Appl l -> C.Appl (l@tl') - | _ as he' -> C.Appl (he'::tl') - end - | C.Appl _ -> assert false - | C.Const (uri,exp_named_subst') -> - let params = - let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - (match obj with - C.Constant (_,_,_,params,_) -> params - | C.Variable _ -> raise ReferenceToVariable - | C.CurrentProof (_,_,_,_,params,_) -> params - | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition - ) - in - let exp_named_subst'' = - substaux_in_exp_named_subst uri k exp_named_subst' params - in - C.Const (uri,exp_named_subst'') - | C.MutInd (uri,typeno,exp_named_subst') -> - let params = - let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - (match obj with - C.Constant _ -> raise ReferenceToConstant - | C.Variable _ -> raise ReferenceToVariable - | C.CurrentProof _ -> raise ReferenceToCurrentProof - | C.InductiveDefinition (_,params,_,_) -> params - ) - in - let exp_named_subst'' = - substaux_in_exp_named_subst uri k exp_named_subst' params - in - C.MutInd (uri,typeno,exp_named_subst'') - | C.MutConstruct (uri,typeno,consno,exp_named_subst') -> - let params = - let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - (match obj with - C.Constant _ -> raise ReferenceToConstant - | C.Variable _ -> raise ReferenceToVariable - | C.CurrentProof _ -> raise ReferenceToCurrentProof - | C.InductiveDefinition (_,params,_,_) -> params - ) - in - let exp_named_subst'' = - substaux_in_exp_named_subst uri k exp_named_subst' params - in -if (List.map fst exp_named_subst'' <> List.map fst (List.filter (fun (uri,_) -> List.mem uri params) exp_named_subst) @ List.map fst exp_named_subst') then ( -debug_print (lazy "\n\n---- BEGIN ") ; -debug_print (lazy ("----params: " ^ String.concat " ; " (List.map UriManager.string_of_uri params))) ; -debug_print (lazy ("----S(" ^ UriManager.string_of_uri uri ^ "): " ^ String.concat " ; " (List.map (function (uri,_) -> UriManager.string_of_uri uri) exp_named_subst))) ; -debug_print (lazy ("----P: " ^ String.concat " ; " (List.map (function (uri,_) -> UriManager.string_of_uri uri) exp_named_subst'))) ; -debug_print (lazy ("----D: " ^ String.concat " ; " (List.map (function (uri,_) -> UriManager.string_of_uri uri) exp_named_subst''))) ; -debug_print (lazy "---- END\n\n ") ; -); - C.MutConstruct (uri,typeno,consno,exp_named_subst'') - | C.MutCase (sp,i,outt,t,pl) -> - C.MutCase (sp,i,substaux k outt, substaux k t, - List.map (substaux k) pl) - | C.Fix (i,fl) -> - let len = List.length fl in - let substitutedfl = - List.map - (fun (name,i,ty,bo) -> (name, i, substaux k ty, substaux (k+len) bo)) - fl - in - C.Fix (i, substitutedfl) - | C.CoFix (i,fl) -> - let len = List.length fl in - let substitutedfl = - List.map - (fun (name,ty,bo) -> (name, substaux k ty, substaux (k+len) bo)) - fl - in - C.CoFix (i, substitutedfl) - and substaux_in_exp_named_subst uri k exp_named_subst' params = - let rec filter_and_lift = - function - [] -> [] - | (uri,t)::tl when - List.for_all - (function (uri',_) -> not (UriManager.eq uri uri')) exp_named_subst' - && - List.mem uri params - -> - (uri,lift (k-1) t)::(filter_and_lift tl) - | _::tl -> filter_and_lift tl - in - let res = - List.map (function (uri,t) -> (uri,substaux k t)) exp_named_subst' @ - (filter_and_lift exp_named_subst) - in - let rec reorder = - function - [] -> [] - | uri::tl -> - let he = - try - [uri,List.assoc uri res] - with - Not_found -> [] - in - he@reorder tl - in - reorder params - in - if exp_named_subst = [] then t - else substaux 1 t -;; - -(* subst_meta [t_1 ; ... ; t_n] t *) -(* returns the term [t] where [Rel i] is substituted with [t_i] *) -(* [t_i] is lifted as usual when it crosses an abstraction *) -let subst_meta l t = - let module C = Cic in - if l = [] then t else - let rec aux k = function - C.Rel n as t -> - if n <= k then t else - (try - match List.nth l (n-k-1) with - None -> raise RelToHiddenHypothesis - | Some t -> lift k t - with - (Failure _) -> assert false - ) - | C.Var (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst - in - C.Var (uri,exp_named_subst') - | C.Meta (i,l) -> - let l' = - List.map - (function - None -> None - | Some t -> - try - Some (aux k t) - with - RelToHiddenHypothesis -> None - ) l - in - C.Meta(i,l') - | C.Sort _ as t -> t - | C.Implicit _ as t -> t - | C.Cast (te,ty) -> C.Cast (aux k te, aux k ty) (*CSC ??? *) - | C.Prod (n,s,t) -> C.Prod (n, aux k s, aux (k + 1) t) - | C.Lambda (n,s,t) -> C.Lambda (n, aux k s, aux (k + 1) t) - | C.LetIn (n,s,ty,t) -> C.LetIn (n, aux k s, aux k ty, aux (k + 1) t) - | C.Appl l -> C.Appl (List.map (aux k) l) - | C.Const (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst - in - C.Const (uri,exp_named_subst') - | C.MutInd (uri,typeno,exp_named_subst) -> - let exp_named_subst' = - List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst - in - C.MutInd (uri,typeno,exp_named_subst') - | C.MutConstruct (uri,typeno,consno,exp_named_subst) -> - let exp_named_subst' = - List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst - in - C.MutConstruct (uri,typeno,consno,exp_named_subst') - | C.MutCase (sp,i,outt,t,pl) -> - C.MutCase (sp,i,aux k outt, aux k t, List.map (aux k) pl) - | C.Fix (i,fl) -> - let len = List.length fl in - let substitutedfl = - List.map - (fun (name,i,ty,bo) -> (name, i, aux k ty, aux (k+len) bo)) - fl - in - C.Fix (i, substitutedfl) - | C.CoFix (i,fl) -> - let len = List.length fl in - let substitutedfl = - List.map - (fun (name,ty,bo) -> (name, aux k ty, aux (k+len) bo)) - fl - in - C.CoFix (i, substitutedfl) - in - aux 0 t -;; - -Deannotate.lift := lift;; diff --git a/matita/components/cic_proof_checking/cicSubstitution.mli b/matita/components/cic_proof_checking/cicSubstitution.mli deleted file mode 100644 index 68311c68c..000000000 --- a/matita/components/cic_proof_checking/cicSubstitution.mli +++ /dev/null @@ -1,64 +0,0 @@ -(* Copyright (C) 2000, 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/. - *) - -exception CannotSubstInMeta;; -exception RelToHiddenHypothesis;; -exception ReferenceToVariable;; -exception ReferenceToConstant;; -exception ReferenceToInductiveDefinition;; - -(* lift n t *) -(* lifts [t] of [n] *) -(* NOTE: the opposite function (delift_rels) is defined in CicMetaSubst *) -(* since it needs to restrict the metavariables in case of failure *) -val lift : int -> Cic.term -> Cic.term - -(* lift from n t *) -(* as lift but lifts only indexes >= from *) -val lift_from: int -> int -> Cic.term -> Cic.term - -(* lift map t *) -(* as lift_from but lifts indexes by applying a map to them - the first argument of the map is the current depth *) -(* FG: this is used in CicDischarge to perform non-linear relocation *) -val lift_map: int -> (int -> int -> int) -> Cic.term -> Cic.term - -(* subst t1 t2 *) -(* substitutes [t1] for [Rel 1] in [t2] *) -(* if avoid_beta_redexes is true (default: false) no new beta redexes *) -(* are generated. WARNING: the substitution can diverge when t2 is not *) -(* well typed and avoid_beta_redexes is true. *) -val subst : ?avoid_beta_redexes:bool -> Cic.term -> Cic.term -> Cic.term - -(* subst_vars exp_named_subst t2 *) -(* applies [exp_named_subst] to [t2] *) -val subst_vars : - Cic.term Cic.explicit_named_substitution -> Cic.term -> Cic.term - -(* subst_meta [t_1 ; ... ; t_n] t *) -(* returns the term [t] where [Rel i] is substituted with [t_i] *) -(* [t_i] is lifted as usual when it crosses an abstraction *) -val subst_meta : (Cic.term option) list -> Cic.term -> Cic.term - diff --git a/matita/components/cic_proof_checking/cicTypeChecker.ml b/matita/components/cic_proof_checking/cicTypeChecker.ml deleted file mode 100644 index c38c15b93..000000000 --- a/matita/components/cic_proof_checking/cicTypeChecker.ml +++ /dev/null @@ -1,2154 +0,0 @@ -(* Copyright (C) 2000, 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$ *) - -(* TODO factorize functions to frequent errors (e.g. "Unknwon mutual inductive - * ...") *) - -open Printf - -exception AssertFailure of string Lazy.t;; -exception TypeCheckerFailure of string Lazy.t;; - -let fdebug = ref 0;; -let debug t context = - let rec debug_aux t i = - let module C = Cic in - let module U = UriManager in - CicPp.ppobj (C.Variable ("DEBUG", None, t, [], [])) ^ "\n" ^ i - in - if !fdebug = 0 then - raise (TypeCheckerFailure (lazy (List.fold_right debug_aux (t::context) ""))) -;; - -let debug_print = fun _ -> ();; - -let rec split l n = - match (l,n) with - (l,0) -> ([], l) - | (he::tl, n) -> let (l1,l2) = split tl (n-1) in (he::l1,l2) - | (_,_) -> - raise (TypeCheckerFailure (lazy "Parameters number < left parameters number")) -;; - -(* XXX: bug *) -let ugraph_convertibility ug1 ug2 ul2 = true;; - -let check_and_clean_ugraph inferred_ugraph unchecked_ugraph uri obj = - match unchecked_ugraph with - | Some (ug,ul) -> - if not (ugraph_convertibility inferred_ugraph ug ul) then - raise (TypeCheckerFailure (lazy - ("inferred univ graph not equal with declared ugraph"))) - else - ug,ul,obj - | None -> - CicUnivUtils.clean_and_fill uri obj inferred_ugraph -;; - -let debrujin_constructor ?(cb=fun _ _ -> ()) ?(check_exp_named_subst=true) uri number_of_types context = - let rec aux k t = - let module C = Cic in - let res = - match t with - C.Rel n as t when n <= k -> t - | C.Rel _ -> - raise (TypeCheckerFailure (lazy "unbound variable found in constructor type")) - | C.Var (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst - in - C.Var (uri,exp_named_subst') - | C.Meta (i,l) -> - let l' = List.map (function None -> None | Some t -> Some (aux k t)) l in - C.Meta (i,l') - | C.Sort _ - | C.Implicit _ as t -> t - | C.Cast (te,ty) -> C.Cast (aux k te, aux k ty) - | C.Prod (n,s,t) -> C.Prod (n, aux k s, aux (k+1) t) - | C.Lambda (n,s,t) -> C.Lambda (n, aux k s, aux (k+1) t) - | C.LetIn (n,s,ty,t) -> C.LetIn (n, aux k s, aux k ty, aux (k+1) t) - | C.Appl l -> C.Appl (List.map (aux k) l) - | C.Const (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst - in - C.Const (uri,exp_named_subst') - | C.MutInd (uri',tyno,exp_named_subst) when UriManager.eq uri uri' -> - if check_exp_named_subst && exp_named_subst != [] then - raise (TypeCheckerFailure - (lazy ("non-empty explicit named substitution is applied to "^ - "a mutual inductive type which is being defined"))) ; - C.Rel (k + number_of_types - tyno) ; - | C.MutInd (uri',tyno,exp_named_subst) -> - let exp_named_subst' = - List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst - in - C.MutInd (uri',tyno,exp_named_subst') - | C.MutConstruct (uri,tyno,consno,exp_named_subst) -> - let exp_named_subst' = - List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst - in - C.MutConstruct (uri,tyno,consno,exp_named_subst') - | C.MutCase (sp,i,outty,t,pl) -> - C.MutCase (sp, i, aux k outty, aux k t, - List.map (aux k) pl) - | C.Fix (i, fl) -> - let len = List.length fl in - let liftedfl = - List.map - (fun (name, i, ty, bo) -> (name, i, aux k ty, aux (k+len) bo)) - fl - in - C.Fix (i, liftedfl) - | C.CoFix (i, fl) -> - let len = List.length fl in - let liftedfl = - List.map - (fun (name, ty, bo) -> (name, aux k ty, aux (k+len) bo)) - fl - in - C.CoFix (i, liftedfl) - in - cb t res; - res - in - aux (List.length context) -;; - -exception CicEnvironmentError;; - -let check_homogeneous_call context indparamsno n uri reduct tl = - let last = - List.fold_left - (fun k x -> - if k = 0 then 0 - else - match CicReduction.whd context x with - | Cic.Rel m when m = n - (indparamsno - k) -> k - 1 - | _ -> raise (TypeCheckerFailure (lazy - ("Argument "^string_of_int (indparamsno - k + 1) ^ " (of " ^ - string_of_int indparamsno ^ " fixed) is not homogeneous in "^ - "appl:\n"^ CicPp.ppterm reduct)))) - indparamsno tl - in - if last <> 0 then - raise (TypeCheckerFailure - (lazy ("Non-positive occurence in mutual inductive definition(s) [2]"^ - UriManager.string_of_uri uri))) -;; - - -let rec type_of_constant ~logger uri orig_ugraph = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - let cobj,ugraph = - match CicEnvironment.is_type_checked ~trust:true orig_ugraph uri with - CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph' - | CicEnvironment.UncheckedObj (uobj,unchecked_ugraph) -> - logger#log (`Start_type_checking uri) ; - (* let's typecheck the uncooked obj *) - let inferred_ugraph = - match uobj with - C.Constant (_,Some te,ty,_,_) -> - let _,ugraph = type_of ~logger ty CicUniv.empty_ugraph in - let type_of_te,ugraph = type_of ~logger te ugraph in - let b,ugraph = R.are_convertible [] type_of_te ty ugraph in - if not b then - raise (TypeCheckerFailure (lazy (sprintf - "the constant %s is not well typed because the type %s of the body is not convertible to the declared type %s" - (U.string_of_uri uri) (CicPp.ppterm type_of_te) - (CicPp.ppterm ty)))) - else - ugraph - | C.Constant (_,None,ty,_,_) -> - (* only to check that ty is well-typed *) - let _,ugraph = type_of ~logger ty CicUniv.empty_ugraph in - ugraph - | C.CurrentProof (_,conjs,te,ty,_,_) -> - let _,ugraph = - List.fold_left - (fun (metasenv,ugraph) ((_,context,ty) as conj) -> - let _,ugraph = - type_of_aux' ~logger metasenv context ty ugraph - in - (metasenv @ [conj],ugraph) - ) ([],CicUniv.empty_ugraph) conjs - in - let _,ugraph = type_of_aux' ~logger conjs [] ty ugraph in - let type_of_te,ugraph = type_of_aux' ~logger conjs [] te ugraph in - let b,ugraph = R.are_convertible [] type_of_te ty ugraph in - if not b then - raise (TypeCheckerFailure (lazy (sprintf - "the current proof %s is not well typed because the type %s of the body is not convertible to the declared type %s" - (U.string_of_uri uri) (CicPp.ppterm type_of_te) - (CicPp.ppterm ty)))) - else - ugraph - | _ -> - raise - (TypeCheckerFailure (lazy ("Unknown constant:" ^ U.string_of_uri uri))) - in - let ugraph, ul, obj = check_and_clean_ugraph inferred_ugraph unchecked_ugraph uri uobj in - CicEnvironment.set_type_checking_info uri (obj, ugraph, ul); - logger#log (`Type_checking_completed uri) ; - match CicEnvironment.is_type_checked ~trust:false orig_ugraph uri with - CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph' - | CicEnvironment.UncheckedObj _ -> raise CicEnvironmentError - in - match cobj,ugraph with - (C.Constant (_,_,ty,_,_)),g -> ty,g - | (C.CurrentProof (_,_,_,ty,_,_)),g -> ty,g - | _ -> - raise (TypeCheckerFailure (lazy ("Unknown constant:" ^ U.string_of_uri uri))) - -and type_of_variable ~logger uri orig_ugraph = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - (* 0 because a variable is never cooked => no partial cooking at one level *) - match CicEnvironment.is_type_checked ~trust:true orig_ugraph uri with - | CicEnvironment.CheckedObj ((C.Variable (_,_,ty,_,_)),ugraph') -> ty,ugraph' - | CicEnvironment.UncheckedObj - (C.Variable (_,bo,ty,_,_) as uobj, unchecked_ugraph) - -> - logger#log (`Start_type_checking uri) ; - (* only to check that ty is well-typed *) - let _,ugraph = type_of ~logger ty CicUniv.empty_ugraph in - let inferred_ugraph = - match bo with - None -> ugraph - | Some bo -> - let ty_bo,ugraph = type_of ~logger bo ugraph in - let b,ugraph = R.are_convertible [] ty_bo ty ugraph in - if not b then - raise (TypeCheckerFailure - (lazy ("Unknown variable:" ^ U.string_of_uri uri))) - else - ugraph - in - let ugraph, ul, obj = - check_and_clean_ugraph inferred_ugraph unchecked_ugraph uri uobj - in - CicEnvironment.set_type_checking_info uri (obj, ugraph, ul); - logger#log (`Type_checking_completed uri) ; - (match CicEnvironment.is_type_checked ~trust:false orig_ugraph uri with - CicEnvironment.CheckedObj((C.Variable(_,_,ty,_,_)),ugraph)->ty,ugraph - | CicEnvironment.CheckedObj _ - | CicEnvironment.UncheckedObj _ -> raise CicEnvironmentError) - | _ -> - raise (TypeCheckerFailure (lazy - ("Unknown variable:" ^ U.string_of_uri uri))) - -and does_not_occur ?(subst=[]) context n nn te = - let module C = Cic in - match te with - C.Rel m when m > n && m <= nn -> false - | C.Rel m -> - (try - (match List.nth context (m-1) with - Some (_,C.Def (bo,_)) -> - does_not_occur ~subst context n nn (CicSubstitution.lift m bo) - | _ -> true) - with - Failure _ -> assert false) - | C.Sort _ - | C.Implicit _ -> true - | C.Meta (mno,l) -> - List.fold_right - (fun x i -> - match x with - None -> i - | Some x -> i && does_not_occur ~subst context n nn x) l true && - (try - let (canonical_context,term,ty) = CicUtil.lookup_subst mno subst in - does_not_occur ~subst context n nn (CicSubstitution.subst_meta l term) - with - CicUtil.Subst_not_found _ -> true) - | C.Cast (te,ty) -> - does_not_occur ~subst context n nn te && - does_not_occur ~subst context n nn ty - | C.Prod (name,so,dest) -> - does_not_occur ~subst context n nn so && - does_not_occur ~subst ((Some (name,(C.Decl so)))::context) (n + 1) - (nn + 1) dest - | C.Lambda (name,so,dest) -> - does_not_occur ~subst context n nn so && - does_not_occur ~subst ((Some (name,(C.Decl so)))::context) (n+1) (nn+1) - dest - | C.LetIn (name,so,ty,dest) -> - does_not_occur ~subst context n nn so && - does_not_occur ~subst context n nn ty && - does_not_occur ~subst ((Some (name,(C.Def (so,ty))))::context) - (n + 1) (nn + 1) dest - | C.Appl l -> - List.for_all (does_not_occur ~subst context n nn) l - | C.Var (_,exp_named_subst) - | C.Const (_,exp_named_subst) - | C.MutInd (_,_,exp_named_subst) - | C.MutConstruct (_,_,_,exp_named_subst) -> - List.for_all (fun (_,x) -> does_not_occur ~subst context n nn x) - exp_named_subst - | C.MutCase (_,_,out,te,pl) -> - does_not_occur ~subst context n nn out && - does_not_occur ~subst context n nn te && - List.for_all (does_not_occur ~subst context n nn) pl - | C.Fix (_,fl) -> - let len = List.length fl in - let n_plus_len = n + len in - let nn_plus_len = nn + len in - let tys,_ = - List.fold_left - (fun (types,len) (n,_,ty,_) -> - (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types, - len+1) - ) ([],0) fl - in - List.fold_right - (fun (_,_,ty,bo) i -> - i && does_not_occur ~subst context n nn ty && - does_not_occur ~subst (tys @ context) n_plus_len nn_plus_len bo - ) fl true - | C.CoFix (_,fl) -> - let len = List.length fl in - let n_plus_len = n + len in - let nn_plus_len = nn + len in - let tys,_ = - List.fold_left - (fun (types,len) (n,ty,_) -> - (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types, - len+1) - ) ([],0) fl - in - List.fold_right - (fun (_,ty,bo) i -> - i && does_not_occur ~subst context n nn ty && - does_not_occur ~subst (tys @ context) n_plus_len nn_plus_len bo - ) fl true - -(* Inductive types being checked for positivity have *) -(* indexes x s.t. n < x <= nn. *) -and weakly_positive context n nn uri indparamsno posuri te = - let module C = Cic in - (*CSC: Not very nice. *) - let leftno = - match CicEnvironment.get_obj CicUniv.oblivion_ugraph uri with - | Cic.InductiveDefinition (_,_,leftno,_), _ -> leftno - | _ -> assert false - in - let dummy = Cic.Sort Cic.Prop in - (*CSC: to be moved in cicSubstitution? *) - let rec subst_inductive_type_with_dummy = - function - C.MutInd (uri',0,_) when UriManager.eq uri' uri -> - dummy - | C.Appl ((C.MutInd (uri',0,_))::tl) when UriManager.eq uri' uri -> - let _, rargs = HExtlib.split_nth leftno tl in - if rargs = [] then dummy else Cic.Appl (dummy :: rargs) - | C.Cast (te,ty) -> subst_inductive_type_with_dummy te - | C.Prod (name,so,ta) -> - C.Prod (name, subst_inductive_type_with_dummy so, - subst_inductive_type_with_dummy ta) - | C.Lambda (name,so,ta) -> - C.Lambda (name, subst_inductive_type_with_dummy so, - subst_inductive_type_with_dummy ta) - | C.LetIn (name,so,ty,ta) -> - C.LetIn (name, subst_inductive_type_with_dummy so, - subst_inductive_type_with_dummy ty, - subst_inductive_type_with_dummy ta) - | C.Appl tl -> - C.Appl (List.map subst_inductive_type_with_dummy tl) - | C.MutCase (uri,i,outtype,term,pl) -> - C.MutCase (uri,i, - subst_inductive_type_with_dummy outtype, - subst_inductive_type_with_dummy term, - List.map subst_inductive_type_with_dummy pl) - | C.Fix (i,fl) -> - C.Fix (i,List.map (fun (name,i,ty,bo) -> (name,i, - subst_inductive_type_with_dummy ty, - subst_inductive_type_with_dummy bo)) fl) - | C.CoFix (i,fl) -> - C.CoFix (i,List.map (fun (name,ty,bo) -> (name, - subst_inductive_type_with_dummy ty, - subst_inductive_type_with_dummy bo)) fl) - | C.Const (uri,exp_named_subst) -> - let exp_named_subst' = - List.map - (function (uri,t) -> (uri,subst_inductive_type_with_dummy t)) - exp_named_subst - in - C.Const (uri,exp_named_subst') - | C.Var (uri,exp_named_subst) -> - let exp_named_subst' = - List.map - (function (uri,t) -> (uri,subst_inductive_type_with_dummy t)) - exp_named_subst - in - C.Var (uri,exp_named_subst') - | C.MutInd (uri,typeno,exp_named_subst) -> - let exp_named_subst' = - List.map - (function (uri,t) -> (uri,subst_inductive_type_with_dummy t)) - exp_named_subst - in - C.MutInd (uri,typeno,exp_named_subst') - | C.MutConstruct (uri,typeno,consno,exp_named_subst) -> - let exp_named_subst' = - List.map - (function (uri,t) -> (uri,subst_inductive_type_with_dummy t)) - exp_named_subst - in - C.MutConstruct (uri,typeno,consno,exp_named_subst') - | t -> t - in - (* this function has the same semantics of are_all_occurrences_positive - but the i-th context entry role is played by dummy and some checks - are skipped because we already know that are_all_occurrences_positive - of uri in te. *) - let rec aux context n nn te = - match CicReduction.whd context te with - | C.Appl (C.Sort C.Prop::tl) -> - List.for_all (does_not_occur context n nn) tl - | C.Sort C.Prop -> true - | C.Prod (name,source,dest) when - does_not_occur ((Some (name,(C.Decl source)))::context) 0 1 dest -> - (* dummy abstraction, so we behave as in the anonimous case *) - strictly_positive context n nn indparamsno posuri source && - aux ((Some (name,(C.Decl source)))::context) - (n + 1) (nn + 1) dest - | C.Prod (name,source,dest) -> - does_not_occur context n nn source && - aux ((Some (name,(C.Decl source)))::context) - (n + 1) (nn + 1) dest - | _ -> - raise (TypeCheckerFailure (lazy "Malformed inductive constructor type")) - in - aux context n nn (subst_inductive_type_with_dummy te) - -(* instantiate_parameters ps (x1:T1)...(xn:Tn)C *) -(* returns ((x_|ps|:T_|ps|)...(xn:Tn)C){ps_1 / x1 ; ... ; ps_|ps| / x_|ps|} *) -and instantiate_parameters params c = - let module C = Cic in - match (c,params) with - (c,[]) -> c - | (C.Prod (_,_,ta), he::tl) -> - instantiate_parameters tl - (CicSubstitution.subst he ta) - | (C.Cast (te,_), _) -> instantiate_parameters params te - | (t,l) -> raise (AssertFailure (lazy "1")) - -and strictly_positive context n nn indparamsno posuri te = - let module C = Cic in - let module U = UriManager in - match CicReduction.whd context te with - | t when does_not_occur context n nn t -> true - | C.Rel _ when indparamsno = 0 -> true - | C.Cast (te,ty) -> - (*CSC: bisogna controllare ty????*) - strictly_positive context n nn indparamsno posuri te - | C.Prod (name,so,ta) -> - does_not_occur context n nn so && - strictly_positive ((Some (name,(C.Decl so)))::context) (n+1) (nn+1) - indparamsno posuri ta - | C.Appl ((C.Rel m)::tl) as reduct when m > n && m <= nn -> - check_homogeneous_call context indparamsno n posuri reduct tl; - List.fold_right (fun x i -> i && does_not_occur context n nn x) tl true - | C.Appl ((C.MutInd (uri,i,exp_named_subst))::_) - | (C.MutInd (uri,i,exp_named_subst)) as t -> - let tl = match t with C.Appl (_::tl) -> tl | _ -> [] in - let (ok,paramsno,ity,cl,name) = - let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o with - C.InductiveDefinition (tl,_,paramsno,_) -> - let (name,_,ity,cl) = List.nth tl i in - (List.length tl = 1, paramsno, ity, cl, name) - (* (true, paramsno, ity, cl, name) *) - | _ -> - raise - (TypeCheckerFailure - (lazy ("Unknown inductive type:" ^ U.string_of_uri uri))) - in - let (params,arguments) = split tl paramsno in - let lifted_params = List.map (CicSubstitution.lift 1) params in - let cl' = - List.map - (fun (_,te) -> - instantiate_parameters lifted_params - (CicSubstitution.subst_vars exp_named_subst te) - ) cl - in - ok && - List.fold_right - (fun x i -> i && does_not_occur context n nn x) - arguments true && - List.fold_right - (fun x i -> - i && - weakly_positive - ((Some (C.Name name,(Cic.Decl ity)))::context) (n+1) (nn+1) uri - indparamsno posuri x - ) cl' true - | t -> false - -(* the inductive type indexes are s.t. n < x <= nn *) -and are_all_occurrences_positive context uri indparamsno i n nn te = - let module C = Cic in - match CicReduction.whd context te with - C.Appl ((C.Rel m)::tl) as reduct when m = i -> - check_homogeneous_call context indparamsno n uri reduct tl; - List.fold_right (fun x i -> i && does_not_occur context n nn x) tl true - | C.Rel m when m = i -> - if indparamsno = 0 then - true - else - raise (TypeCheckerFailure - (lazy ("Non-positive occurence in mutual inductive definition(s) [3]"^ - UriManager.string_of_uri uri))) - | C.Prod (name,source,dest) when - does_not_occur ((Some (name,(C.Decl source)))::context) 0 1 dest -> - (* dummy abstraction, so we behave as in the anonimous case *) - strictly_positive context n nn indparamsno uri source && - are_all_occurrences_positive - ((Some (name,(C.Decl source)))::context) uri indparamsno - (i+1) (n + 1) (nn + 1) dest - | C.Prod (name,source,dest) -> - does_not_occur context n nn source && - are_all_occurrences_positive ((Some (name,(C.Decl source)))::context) - uri indparamsno (i+1) (n + 1) (nn + 1) dest - | _ -> - raise - (TypeCheckerFailure (lazy ("Malformed inductive constructor type " ^ - (UriManager.string_of_uri uri)))) - -(* Main function to checks the correctness of a mutual *) -(* inductive block definition. This is the function *) -(* exported to the proof-engine. *) -and typecheck_mutual_inductive_defs ~logger uri (itl,_,indparamsno) ugraph = - let module U = UriManager in - (* let's check if the arity of the inductive types are well *) - (* formed *) - let ugrap1 = List.fold_left - (fun ugraph (_,_,x,_) -> let _,ugraph' = - type_of ~logger x ugraph in ugraph') - ugraph itl in - - (* let's check if the types of the inductive constructors *) - (* are well formed. *) - (* In order not to use type_of_aux we put the types of the *) - (* mutual inductive types at the head of the types of the *) - (* constructors using Prods *) - let len = List.length itl in - let tys = - List.rev_map (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) itl in - let _,ugraph2 = - List.fold_right - (fun (_,_,ty,cl) (i,ugraph) -> - let _,ty_sort = split_prods ~subst:[] [] ~-1 ty in - let ugraph'' = - List.fold_left - (fun ugraph (name,te) -> - let te = debrujin_constructor uri len [] te in - let context,te = split_prods ~subst:[] tys indparamsno te in - let con_sort,ugraph = type_of_aux' ~logger [] context te ugraph in - let ugraph = - match - CicReduction.whd context con_sort, CicReduction.whd [] ty_sort - with - Cic.Sort (Cic.Type u1), Cic.Sort (Cic.Type u2) - | Cic.Sort (Cic.CProp u1), Cic.Sort (Cic.CProp u2) - | Cic.Sort (Cic.Type u1), Cic.Sort (Cic.CProp u2) - | Cic.Sort (Cic.CProp u1), Cic.Sort (Cic.Type u2) -> - CicUniv.add_ge u2 u1 ugraph - | Cic.Sort _, Cic.Sort Cic.Prop - | Cic.Sort _, Cic.Sort Cic.CProp _ - | Cic.Sort _, Cic.Sort Cic.Set - | Cic.Sort _, Cic.Sort Cic.Type _ -> ugraph - | a,b -> - raise - (TypeCheckerFailure - (lazy ("Wrong constructor or inductive arity shape: "^ - CicPp.ppterm a ^ " --- " ^ CicPp.ppterm b))) in - (* let's check also the positivity conditions *) - if - not - (are_all_occurrences_positive context uri indparamsno - (i+indparamsno) indparamsno (len+indparamsno) te) - then - raise - (TypeCheckerFailure - (lazy ("Non positive occurence in " ^ U.string_of_uri uri))) - else - ugraph - ) ugraph cl in - (i + 1),ugraph'' - ) itl (1,ugrap1) - in - ugraph2 - -(* Main function to checks the correctness of a mutual *) -(* inductive block definition. *) -and check_mutual_inductive_defs uri obj ugraph = - match obj with - Cic.InductiveDefinition (itl, params, indparamsno, _) -> - typecheck_mutual_inductive_defs uri (itl,params,indparamsno) ugraph - | _ -> - raise (TypeCheckerFailure ( - lazy ("Unknown mutual inductive definition:" ^ - UriManager.string_of_uri uri))) - -and type_of_mutual_inductive_defs ~logger uri i orig_ugraph = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - let cobj,ugraph1 = - match CicEnvironment.is_type_checked ~trust:true orig_ugraph uri with - CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph' - | CicEnvironment.UncheckedObj (uobj,unchecked_ugraph) -> - logger#log (`Start_type_checking uri) ; - let inferred_ugraph = - check_mutual_inductive_defs ~logger uri uobj CicUniv.empty_ugraph - in - let ugraph, ul, obj = check_and_clean_ugraph inferred_ugraph unchecked_ugraph uri uobj in - CicEnvironment.set_type_checking_info uri (obj,ugraph,ul); - logger#log (`Type_checking_completed uri) ; - (match CicEnvironment.is_type_checked ~trust:false orig_ugraph uri with - CicEnvironment.CheckedObj (cobj,ugraph') -> (cobj,ugraph') - | CicEnvironment.UncheckedObj _ -> raise CicEnvironmentError - ) - in - match cobj with - | C.InductiveDefinition (dl,_,_,_) -> - let (_,_,arity,_) = List.nth dl i in - arity,ugraph1 - | _ -> - raise (TypeCheckerFailure - (lazy ("Unknown mutual inductive definition:" ^ U.string_of_uri uri))) - -and type_of_mutual_inductive_constr ~logger uri i j orig_ugraph = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - let cobj,ugraph1 = - match CicEnvironment.is_type_checked ~trust:true orig_ugraph uri with - CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph' - | CicEnvironment.UncheckedObj (uobj,unchecked_ugraph) -> - logger#log (`Start_type_checking uri) ; - let inferred_ugraph = - check_mutual_inductive_defs ~logger uri uobj CicUniv.empty_ugraph - in - let ugraph, ul, obj = check_and_clean_ugraph inferred_ugraph unchecked_ugraph uri uobj in - CicEnvironment.set_type_checking_info uri (obj, ugraph, ul); - logger#log (`Type_checking_completed uri) ; - (match - CicEnvironment.is_type_checked ~trust:false orig_ugraph uri - with - CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph' - | CicEnvironment.UncheckedObj _ -> - raise CicEnvironmentError) - in - match cobj with - C.InductiveDefinition (dl,_,_,_) -> - let (_,_,_,cl) = List.nth dl i in - let (_,ty) = List.nth cl (j-1) in - ty,ugraph1 - | _ -> - raise (TypeCheckerFailure - (lazy ("Unknown mutual inductive definition:" ^ UriManager.string_of_uri uri))) - -and recursive_args context n nn te = - let module C = Cic in - match CicReduction.whd context te with - C.Rel _ - | C.MutInd _ -> [] - | C.Var _ - | C.Meta _ - | C.Sort _ - | C.Implicit _ - | C.Cast _ (*CSC ??? *) -> - raise (AssertFailure (lazy "3")) (* due to type-checking *) - | C.Prod (name,so,de) -> - (not (does_not_occur context n nn so)) :: - (recursive_args ((Some (name,(C.Decl so)))::context) (n+1) (nn + 1) de) - | C.Lambda _ - | C.LetIn _ -> - raise (AssertFailure (lazy "4")) (* due to type-checking *) - | C.Appl _ -> [] - | C.Const _ -> raise (AssertFailure (lazy "5")) - | C.MutConstruct _ - | C.MutCase _ - | C.Fix _ - | C.CoFix _ -> raise (AssertFailure (lazy "6")) (* due to type-checking *) - -and get_new_safes ~subst context p rl safes n nn x = - let module C = Cic in - let module U = UriManager in - let module R = CicReduction in - match R.whd ~subst context p, rl with - | C.Lambda (name,so,ta), b::tl -> - let safes = List.map (fun x -> x + 1) safes in - let safes = if b then 1::safes else safes in - get_new_safes ~subst ((Some (name,(C.Decl so)))::context) - ta tl safes (n+1) (nn+1) (x+1) - | C.MutConstruct _ as e, _ - | (C.Rel _ as e), _ - | e, [] -> (e,safes,n,nn,x,context) - | p,_::_ -> - raise - (AssertFailure (lazy - (Printf.sprintf "Get New Safes: p=%s" (CicPp.ppterm p)))) - -and split_prods ~subst context n te = - let module C = Cic in - let module R = CicReduction in - match (n, R.whd ~subst context te) with - (0, _) -> context,te - | (n, C.Sort _) when n <= 0 -> context,te - | (n, C.Prod (name,so,ta)) -> - split_prods ~subst ((Some (name,(C.Decl so)))::context) (n - 1) ta - | (_, _) -> raise (AssertFailure (lazy "8")) - -and eat_lambdas ~subst context n te = - let module C = Cic in - let module R = CicReduction in - match (n, R.whd ~subst context te) with - (0, _) -> (te, 0, context) - | (n, C.Lambda (name,so,ta)) when n > 0 -> - let (te, k, context') = - eat_lambdas ~subst ((Some (name,(C.Decl so)))::context) (n - 1) ta - in - (te, k + 1, context') - | (n, te) -> - raise (AssertFailure (lazy (sprintf "9 (%d, %s)" n (CicPp.ppterm te)))) - -and specialize_inductive_type ~logger ~subst ~metasenv context t = - let ty,_= type_of_aux' ~logger ~subst metasenv context t CicUniv.oblivion_ugraph in - match CicReduction.whd ~subst context ty with - | Cic.MutInd (uri,_,exp) - | Cic.Appl (Cic.MutInd (uri,_,exp) :: _) as ty -> - let args = match ty with Cic.Appl (_::tl) -> tl | _ -> [] in - let o,_ = CicEnvironment.get_obj CicUniv.oblivion_ugraph uri in - (match o with - | Cic.InductiveDefinition (tl,_,paramsno,_) -> - let left_args,_ = HExtlib.split_nth paramsno args in - List.map (fun (name, isind, arity, cl) -> - let arity = CicSubstitution.subst_vars exp arity in - let arity = instantiate_parameters left_args arity in - let cl = - List.map - (fun (id,ty) -> - let ty = CicSubstitution.subst_vars exp ty in - id, instantiate_parameters left_args ty) - cl - in - name, isind, arity, cl) - tl, paramsno - | _ -> assert false) - | _ -> assert false - -and check_is_really_smaller_arg - ~logger ~metasenv ~subst rec_uri rec_uri_len context n nn kl x safes te -= - let module C = Cic in - let module U = UriManager in - (*CSC: we could perform beta-iota(-zeta?) immediately, and - delta only on-demand when it fails without *) - match CicReduction.whd ~subst context te with - C.Rel m when List.mem m safes -> true - | C.Rel _ - | C.MutConstruct _ - | C.Const _ - | C.Var _ -> false - | C.Appl (he::_) -> - check_is_really_smaller_arg rec_uri rec_uri_len - ~logger ~metasenv ~subst context n nn kl x safes he - | C.Lambda (name,ty,ta) -> - check_is_really_smaller_arg rec_uri rec_uri_len - ~logger ~metasenv ~subst (Some (name,Cic.Decl ty)::context) - (n+1) (nn+1) kl (x+1) (List.map (fun n -> n+1) safes) ta - | C.MutCase (uri,i,outtype,term,pl) -> - (match term with - | C.Rel m | C.Appl ((C.Rel m)::_) when List.mem m safes || m = x -> - let tys,_ = - specialize_inductive_type ~logger ~subst ~metasenv context term - in - let tys_ctx,_ = - List.fold_left - (fun (types,len) (n,_,ty,_) -> - Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types, - len+1) - ([],0) tys - in - let _,isinductive,_,cl = List.nth tys i in - if not isinductive then - List.for_all - (check_is_really_smaller_arg rec_uri rec_uri_len - ~logger ~metasenv ~subst context n nn kl x safes) - pl - else - List.for_all2 - (fun p (_,c) -> - let rec_params = - let c = - debrujin_constructor ~check_exp_named_subst:false - rec_uri rec_uri_len context c in - let len_ctx = List.length context in - recursive_args (context@tys_ctx) len_ctx (len_ctx+rec_uri_len) c - in - let (e, safes',n',nn',x',context') = - get_new_safes ~subst context p rec_params safes n nn x - in - check_is_really_smaller_arg rec_uri rec_uri_len - ~logger ~metasenv ~subst context' n' nn' kl x' safes' e - ) pl cl - | _ -> - List.for_all - (check_is_really_smaller_arg - rec_uri rec_uri_len ~logger ~metasenv ~subst - context n nn kl x safes) pl - ) - | C.Fix (_, fl) -> - let len = List.length fl in - let n_plus_len = n + len - and nn_plus_len = nn + len - and x_plus_len = x + len - and tys,_ = - List.fold_left - (fun (types,len) (n,_,ty,_) -> - (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types, - len+1) - ) ([],0) fl - and safes' = List.map (fun x -> x + len) safes in - List.for_all - (fun (_,_,_,bo) -> - check_is_really_smaller_arg - rec_uri rec_uri_len ~logger ~metasenv ~subst - (tys@context) n_plus_len nn_plus_len kl - x_plus_len safes' bo - ) fl - | t -> - raise (AssertFailure (lazy ("An inhabitant of an inductive type in normal form cannot have this shape: " ^ CicPp.ppterm t))) - -and guarded_by_destructors - ~logger ~metasenv ~subst rec_uri rec_uri_len context n nn kl x safes t -= - let module C = Cic in - let module U = UriManager in - let t = CicReduction.whd ~delta:false ~subst context t in - let res = - match t with - C.Rel m when m > n && m <= nn -> false - | C.Rel m -> - (match List.nth context (m-1) with - Some (_,C.Decl _) -> true - | Some (_,C.Def (bo,_)) -> - guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x safes - (CicSubstitution.lift m bo) - | None -> raise (TypeCheckerFailure (lazy "Reference to deleted hypothesis")) - ) - | C.Meta _ - | C.Sort _ - | C.Implicit _ -> true - | C.Cast (te,ty) -> - guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x safes te && - guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x safes ty - | C.Prod (name,so,ta) -> - guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x safes so && - guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst ((Some (name,(C.Decl so)))::context) - (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta - | C.Lambda (name,so,ta) -> - guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x safes so && - guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst ((Some (name,(C.Decl so)))::context) - (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta - | C.LetIn (name,so,ty,ta) -> - guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x safes so && - guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x safes ty && - guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst ((Some (name,(C.Def (so,ty))))::context) - (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta - | C.Appl ((C.Rel m)::tl) when m > n && m <= nn -> - let k = List.nth kl (m - n - 1) in - if not (List.length tl > k) then false - else - List.for_all - (guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x safes) tl && - check_is_really_smaller_arg - rec_uri rec_uri_len - ~logger ~metasenv ~subst context n nn kl x safes (List.nth tl k) - | C.Var (_,exp_named_subst) - | C.Const (_,exp_named_subst) - | C.MutInd (_,_,exp_named_subst) - | C.MutConstruct (_,_,_,exp_named_subst) -> - List.for_all - (fun (_,t) -> guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x safes t) - exp_named_subst - | C.MutCase (uri,i,outtype,term,pl) -> - (match CicReduction.whd ~subst context term with - | C.Rel m - | C.Appl ((C.Rel m)::_) as t when List.mem m safes || m = x -> - let tl = match t with C.Appl (_::tl) -> tl | _ -> [] in - List.for_all - (guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x safes) - tl && - let tys,_ = - specialize_inductive_type ~logger ~subst ~metasenv context t - in - let tys_ctx,_ = - List.fold_left - (fun (types,len) (n,_,ty,_) -> - Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types, - len+1) - ([],0) tys - in - let _,isinductive,_,cl = List.nth tys i in - if not isinductive then - guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x safes outtype && - guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x safes term && - List.for_all - (guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x safes) - pl - else - guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x safes outtype && - List.for_all2 - (fun p (_,c) -> - let rec_params = - let c = - debrujin_constructor ~check_exp_named_subst:false - rec_uri rec_uri_len context c in - let len_ctx = List.length context in - recursive_args (context@tys_ctx) len_ctx (len_ctx+rec_uri_len) c - in - let (e, safes',n',nn',x',context') = - get_new_safes ~subst context p rec_params safes n nn x - in - guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context' n' nn' kl x' safes' e - ) pl cl - | _ -> - guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x safes outtype && - guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x safes term && - (*CSC: manca ??? il controllo sul tipo di term? *) - List.fold_right - (fun p i -> i && guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x safes p) - pl true - ) - | C.Appl (C.Fix (fixno, fl)::_) | C.Fix (fixno,fl) as t-> - let l = match t with C.Appl (_::tl) -> tl | _ -> [] in - let len = List.length fl in - let n_plus_len = n + len in - let nn_plus_len = nn + len in - let x_plus_len = x + len in - let tys,_ = - List.fold_left - (fun (types,len) (n,_,ty,_) -> - (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types, - len+1) - ) ([],0) fl in - let safes' = List.map (fun x -> x + len) safes in - List.for_all - (guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x safes) l && - snd (List.fold_left - (fun (fixno',i) (_,recno,ty,bo) -> - fixno'+1, - i && - guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x_plus_len safes' ty && - if - fixno' = fixno && - List.length l > recno && - (*case where the recursive argument is already really_smaller *) - check_is_really_smaller_arg - rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x safes - (List.nth l recno) - then - let bo_without_lambdas,_,context = - eat_lambdas ~subst (tys@context) (recno+1) bo - in - (* we assume the formal argument to be safe *) - guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context (n_plus_len+recno+1) - (nn_plus_len+recno+1) kl (x_plus_len+recno+1) - (1::List.map (fun x -> x+recno+1) safes') - bo_without_lambdas - else - guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst (tys@context) n_plus_len nn_plus_len - kl x_plus_len safes' bo - ) (0,true) fl) - | C.CoFix (_, fl) -> - let len = List.length fl in - let n_plus_len = n + len - and nn_plus_len = nn + len - and x_plus_len = x + len - and tys,_ = - List.fold_left - (fun (types,len) (n,ty,_) -> - (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types, - len+1) - ) ([],0) fl - and safes' = List.map (fun x -> x + len) safes in - List.fold_right - (fun (_,ty,bo) i -> - i && - guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x_plus_len safes' ty && - guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst (tys@context) n_plus_len nn_plus_len kl - x_plus_len safes' bo - ) fl true - | C.Appl tl -> - List.fold_right - (fun t i -> i && guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x safes t) - tl true - in - if res then res - else - let t' = CicReduction.whd ~subst context t in - if t = t' then - false - else - guarded_by_destructors rec_uri rec_uri_len ~logger ~metasenv ~subst context n nn kl x safes t' - -(* the boolean h means already protected *) -(* args is the list of arguments the type of the constructor that may be *) -(* found in head position must be applied to. *) -and guarded_by_constructors ~logger ~subst ~metasenv indURI = - let module C = Cic in - let rec aux context n nn h te = - match CicReduction.whd ~subst context te with - | C.Rel m when m > n && m <= nn -> h - | C.Rel _ - | C.Meta _ -> true - | C.Sort _ - | C.Implicit _ - | C.Cast _ - | C.Prod _ - | C.MutInd _ - | C.LetIn _ -> raise (AssertFailure (lazy "17")) - | C.Lambda (name,so,de) -> - does_not_occur ~subst context n nn so && - aux ((Some (name,(C.Decl so)))::context) (n + 1) (nn + 1) h de - | C.Appl ((C.Rel m)::tl) when m > n && m <= nn -> - h && List.for_all (does_not_occur ~subst context n nn) tl - | C.MutConstruct (_,_,_,exp_named_subst) -> - List.for_all - (fun (_,x) -> does_not_occur ~subst context n nn x) exp_named_subst - | C.Appl ((C.MutConstruct (uri,i,j,exp_named_subst))::tl) as t -> - List.for_all - (fun (_,x) -> does_not_occur ~subst context n nn x) exp_named_subst && - let consty, len_tys, tys_ctx, paramsno = - let tys, paramsno = - specialize_inductive_type ~logger ~subst ~metasenv context t in - let _,_,_,cl = List.nth tys i in - let _,ty = List.nth cl (j-1) in - ty, List.length tys, - fst(List.fold_left - (fun (types,len) (n,_,ty,_) -> - Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types, len+1) - ([],0) tys), paramsno - in - let rec_params = - let c = - debrujin_constructor ~check_exp_named_subst:false - indURI len_tys context consty - in - let len_ctx = List.length context in - recursive_args (context@tys_ctx) len_ctx (len_ctx+len_tys) c - in - let rec analyse_instantiated_type rec_spec args = - match rec_spec, args with - | h::rec_spec, he::args -> - aux context n nn h he && - analyse_instantiated_type rec_spec args - | _,[] -> true - | _ -> raise (AssertFailure (lazy - ("Too many args for constructor: " ^ String.concat " " - (List.map (fun x-> CicPp.ppterm x) args)))) - in - let left, args = HExtlib.split_nth paramsno tl in - List.for_all (does_not_occur ~subst context n nn) left && - analyse_instantiated_type rec_params args - | C.Appl ((C.MutCase (_,_,out,te,pl))::_) - | C.MutCase (_,_,out,te,pl) as t -> - let tl = match t with C.Appl (_::tl) -> tl | _ -> [] in - List.for_all (does_not_occur ~subst context n nn) tl && - does_not_occur ~subst context n nn out && - does_not_occur ~subst context n nn te && - List.for_all (aux context n nn h ) pl - | C.Fix (_,fl) - | C.Appl (C.Fix (_,fl)::_) as t -> - let tl = match t with C.Appl (_::tl) -> tl | _ -> [] in - let len = List.length fl in - let n_plus_len = n + len - and nn_plus_len = nn + len - and tys,_ = - List.fold_left - (fun (types,len) (n,_,ty,_) -> - (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types, - len+1) - ) ([],0) fl - in - List.for_all (does_not_occur ~subst context n nn) tl && - List.for_all - (fun (_,_,ty,bo) -> - does_not_occur ~subst context n nn ty && - aux (tys@context) n_plus_len nn_plus_len h bo) - fl - | C.Appl ((C.CoFix (_,fl))::_) - | C.CoFix (_,fl) as t -> - let tl = match t with C.Appl (_::tl) -> tl | _ -> [] in - let len = List.length fl in - let n_plus_len = n + len - and nn_plus_len = nn + len - and tys,_ = - List.fold_left - (fun (types,len) (n,ty,_) -> - (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types, - len+1) - ) ([],0) fl - in - List.for_all (does_not_occur ~subst context n nn) tl && - List.for_all - (fun (_,ty,bo) -> - does_not_occur ~subst context n nn ty && - aux (tys@context) n_plus_len nn_plus_len h bo) - fl - | C.Var _ - | C.Const _ - | C.Appl _ as t -> does_not_occur ~subst context n nn t - in - aux - -and is_non_recursive ctx paramsno t uri = - let t = debrujin_constructor uri 1 [] t in -(* let ctx, t = split_prods ~subst:[] ctx paramsno t in *) - let len = List.length ctx in - let rec aux ctx n nn t = - match CicReduction.whd ctx t with - | Cic.Prod (name,src,tgt) -> - does_not_occur ctx n nn src && - aux (Some (name,Cic.Decl src) :: ctx) (n+1) (nn+1) tgt - | (Cic.Rel k) - | Cic.Appl (Cic.Rel k :: _) when k = nn -> true - | t -> assert false - in - aux ctx (len-1) len t - -and check_allowed_sort_elimination ~subst ~metasenv ~logger context uri i - need_dummy ind arity1 arity2 ugraph = - let module C = Cic in - let module U = UriManager in - let arity1 = CicReduction.whd ~subst context arity1 in - let rec check_allowed_sort_elimination_aux ugraph context arity2 need_dummy = - match arity1, CicReduction.whd ~subst context arity2 with - (C.Prod (name,so1,de1), C.Prod (_,so2,de2)) -> - let b,ugraph1 = - CicReduction.are_convertible ~subst ~metasenv context so1 so2 ugraph in - if b then - check_allowed_sort_elimination ~subst ~metasenv ~logger - ((Some (name,C.Decl so1))::context) uri i - need_dummy (C.Appl [CicSubstitution.lift 1 ind ; C.Rel 1]) de1 de2 - ugraph1 - else - false,ugraph1 - | (C.Sort _, C.Prod (name,so,ta)) when not need_dummy -> - let b,ugraph1 = - CicReduction.are_convertible ~subst ~metasenv context so ind ugraph in - if not b then - false,ugraph1 - else - check_allowed_sort_elimination_aux ugraph1 - ((Some (name,C.Decl so))::context) ta true - | (C.Sort C.Prop, C.Sort C.Prop) when need_dummy -> true,ugraph - | (C.Sort C.Prop, C.Sort C.Set) - | (C.Sort C.Prop, C.Sort (C.CProp _)) - | (C.Sort C.Prop, C.Sort (C.Type _) ) when need_dummy -> - (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o with - C.InductiveDefinition (itl,_,paramsno,_) -> - let itl_len = List.length itl in - let (name,_,ty,cl) = List.nth itl i in - let cl_len = List.length cl in - if (cl_len = 0 || (itl_len = 1 && cl_len = 1)) then - let non_informative,ugraph = - if cl_len = 0 then true,ugraph - else - let b, ug = - is_non_informative ~logger [Some (C.Name name,C.Decl ty)] - paramsno (snd (List.nth cl 0)) ugraph - in - b && - is_non_recursive [Some (C.Name name,C.Decl ty)] - paramsno (snd (List.nth cl 0)) uri, ug - in - (* is it a singleton or empty non recursive and non informative - definition? *) - non_informative, ugraph - else - false,ugraph - | _ -> - raise (TypeCheckerFailure - (lazy ("Unknown mutual inductive definition:" ^ - UriManager.string_of_uri uri))) - ) - | (C.Sort C.Set, C.Sort C.Prop) when need_dummy -> true , ugraph - | (C.Sort C.Set, C.Sort C.Set) when need_dummy -> true , ugraph - | (C.Sort C.Set, C.Sort (C.Type _)) - | (C.Sort C.Set, C.Sort (C.CProp _)) - when need_dummy -> - (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o with - C.InductiveDefinition (itl,_,paramsno,_) -> - let tys = - List.map (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) itl - in - let (_,_,_,cl) = List.nth itl i in - (List.fold_right - (fun (_,x) (i,ugraph) -> - if i then - is_small ~logger tys paramsno x ugraph - else - false,ugraph - ) cl (true,ugraph)) - | _ -> - raise (TypeCheckerFailure - (lazy ("Unknown mutual inductive definition:" ^ - UriManager.string_of_uri uri))) - ) - | (C.Sort (C.Type _), C.Sort _) when need_dummy -> true , ugraph - | (C.Sort (C.CProp _), C.Sort _) when need_dummy -> true , ugraph - | (_,_) -> false,ugraph - in - check_allowed_sort_elimination_aux ugraph context arity2 need_dummy - -and type_of_branch ~subst context argsno need_dummy outtype term constype = - let module C = Cic in - let module R = CicReduction in - match R.whd ~subst context constype with - C.MutInd (_,_,_) -> - if need_dummy then - outtype - else - C.Appl [outtype ; term] - | C.Appl (C.MutInd (_,_,_)::tl) -> - let (_,arguments) = split tl argsno - in - if need_dummy && arguments = [] then - outtype - else - C.Appl (outtype::arguments@(if need_dummy then [] else [term])) - | C.Prod (name,so,de) -> - let term' = - match CicSubstitution.lift 1 term with - C.Appl l -> C.Appl (l@[C.Rel 1]) - | t -> C.Appl [t ; C.Rel 1] - in - C.Prod (name,so,type_of_branch ~subst - ((Some (name,(C.Decl so)))::context) argsno need_dummy - (CicSubstitution.lift 1 outtype) term' de) - | _ -> raise (AssertFailure (lazy "20")) - -(* check_metasenv_consistency checks that the "canonical" context of a -metavariable is consitent - up to relocation via the relocation list l - -with the actual context *) - - -and check_metasenv_consistency ~logger ~subst metasenv context - canonical_context l ugraph -= - let module C = Cic in - let module R = CicReduction in - let module S = CicSubstitution in - let lifted_canonical_context = - let rec aux i = - function - [] -> [] - | (Some (n,C.Decl t))::tl -> - (Some (n,C.Decl (S.subst_meta l (S.lift i t))))::(aux (i+1) tl) - | None::tl -> None::(aux (i+1) tl) - | (Some (n,C.Def (t,ty)))::tl -> - (Some (n,C.Def ((S.subst_meta l (S.lift i t)),S.subst_meta l (S.lift i ty))))::(aux (i+1) tl) - in - aux 1 canonical_context - in - List.fold_left2 - (fun ugraph t ct -> - match (t,ct) with - | _,None -> ugraph - | Some t,Some (_,C.Def (ct,_)) -> - (*CSC: the following optimization is to avoid a possibly expensive - reduction that can be easily avoided and that is quite - frequent. However, this is better handled using levels to - control reduction *) - let optimized_t = - match t with - Cic.Rel n -> - (try - match List.nth context (n - 1) with - Some (_,C.Def (te,_)) -> S.lift n te - | _ -> t - with - Failure _ -> t) - | _ -> t - in -(*if t <> optimized_t && optimized_t = ct then prerr_endline "!!!!!!!!!!!!!!!" -else if t <> optimized_t then prerr_endline ("@@ " ^ CicPp.ppterm t ^ " ==> " ^ CicPp.ppterm optimized_t ^ " <==> " ^ CicPp.ppterm ct);*) - let b,ugraph1 = - R.are_convertible ~subst ~metasenv context optimized_t ct ugraph - in - if not b then - raise - (TypeCheckerFailure - (lazy (sprintf "Not well typed metavariable local context: expected a term convertible with %s, found %s" (CicPp.ppterm ct) (CicPp.ppterm t)))) - else - ugraph1 - | Some t,Some (_,C.Decl ct) -> - let type_t,ugraph1 = - type_of_aux' ~logger ~subst metasenv context t ugraph - in - let b,ugraph2 = - R.are_convertible ~subst ~metasenv context type_t ct ugraph1 - in - if not b then - raise (TypeCheckerFailure - (lazy (sprintf "Not well typed metavariable local context: expected a term of type %s, found %s of type %s" - (CicPp.ppterm ct) (CicPp.ppterm t) - (CicPp.ppterm type_t)))) - else - ugraph2 - | None, _ -> - raise (TypeCheckerFailure - (lazy ("Not well typed metavariable local context: "^ - "an hypothesis, that is not hidden, is not instantiated"))) - ) ugraph l lifted_canonical_context - - -(* - type_of_aux' is just another name (with a different scope) - for type_of_aux -*) - -and type_of_aux' ~logger ?(subst = []) metasenv context t ugraph = - let rec type_of_aux ~logger context t ugraph = - let module C = Cic in - let module R = CicReduction in - let module S = CicSubstitution in - let module U = UriManager in -(* FG: DEBUG ONLY - prerr_endline ("TC: context:\n" ^ CicPp.ppcontext ~metasenv context); - prerr_endline ("TC: term :\n" ^ CicPp.ppterm ~metasenv t ^ "\n"); -*) - match t with - C.Rel n -> - (try - match List.nth context (n - 1) with - Some (_,C.Decl t) -> S.lift n t,ugraph - | Some (_,C.Def (_,ty)) -> S.lift n ty,ugraph - | None -> raise - (TypeCheckerFailure (lazy "Reference to deleted hypothesis")) - with - Failure _ -> - raise (TypeCheckerFailure (lazy "unbound variable")) - ) - | C.Var (uri,exp_named_subst) -> - incr fdebug ; - let ugraph1 = - check_exp_named_subst uri ~logger ~subst context exp_named_subst ugraph - in - let ty,ugraph2 = type_of_variable ~logger uri ugraph1 in - let ty1 = CicSubstitution.subst_vars exp_named_subst ty in - decr fdebug ; - ty1,ugraph2 - | C.Meta (n,l) -> - (try - let (canonical_context,term,ty) = CicUtil.lookup_subst n subst in - let ugraph1 = - check_metasenv_consistency ~logger - ~subst metasenv context canonical_context l ugraph - in - (* assuming subst is well typed !!!!! *) - ((CicSubstitution.subst_meta l ty), ugraph1) - (* type_of_aux context (CicSubstitution.subst_meta l term) *) - with CicUtil.Subst_not_found _ -> - let (_,canonical_context,ty) = CicUtil.lookup_meta n metasenv in - let ugraph1 = - check_metasenv_consistency ~logger - ~subst metasenv context canonical_context l ugraph - in - ((CicSubstitution.subst_meta l ty),ugraph1)) - (* TASSI: CONSTRAINTS *) - | C.Sort (C.CProp t) -> - let t' = CicUniv.fresh() in - (try - let ugraph1 = CicUniv.add_gt t' t ugraph in - (C.Sort (C.Type t')),ugraph1 - with - CicUniv.UniverseInconsistency msg -> raise (TypeCheckerFailure msg)) - | C.Sort (C.Type t) -> - let t' = CicUniv.fresh() in - (try - let ugraph1 = CicUniv.add_gt t' t ugraph in - (C.Sort (C.Type t')),ugraph1 - with - CicUniv.UniverseInconsistency msg -> raise (TypeCheckerFailure msg)) - | C.Sort (C.Prop|C.Set) -> (C.Sort (C.Type (CicUniv.fresh ()))),ugraph - | C.Implicit _ -> raise (AssertFailure (lazy "Implicit found")) - | C.Cast (te,ty) as t -> - let _,ugraph1 = type_of_aux ~logger context ty ugraph in - let ty_te,ugraph2 = type_of_aux ~logger context te ugraph1 in - let b,ugraph3 = - R.are_convertible ~subst ~metasenv context ty_te ty ugraph2 - in - if b then - ty,ugraph3 - else - raise (TypeCheckerFailure - (lazy (sprintf "Invalid cast %s" (CicPp.ppterm t)))) - | C.Prod (name,s,t) -> - let sort1,ugraph1 = type_of_aux ~logger context s ugraph in - let sort2,ugraph2 = - type_of_aux ~logger ((Some (name,(C.Decl s)))::context) t ugraph1 - in - sort_of_prod ~subst context (name,s) (sort1,sort2) ugraph2 - | C.Lambda (n,s,t) -> - let sort1,ugraph1 = type_of_aux ~logger context s ugraph in - (match R.whd ~subst context sort1 with - C.Meta _ - | C.Sort _ -> () - | _ -> - raise - (TypeCheckerFailure (lazy (sprintf - "Not well-typed lambda-abstraction: the source %s should be a type; instead it is a term of type %s" (CicPp.ppterm s) - (CicPp.ppterm sort1)))) - ) ; - let type2,ugraph2 = - type_of_aux ~logger ((Some (n,(C.Decl s)))::context) t ugraph1 - in - (C.Prod (n,s,type2)),ugraph2 - | C.LetIn (n,s,ty,t) -> - (* only to check if s is well-typed *) - let ty',ugraph1 = type_of_aux ~logger context s ugraph in - let _,ugraph1 = type_of_aux ~logger context ty ugraph1 in - let b,ugraph1 = - R.are_convertible ~subst ~metasenv context ty' ty ugraph1 - in - if not b then - raise - (TypeCheckerFailure - (lazy (sprintf - "The type of %s is %s but it is expected to be %s" - (CicPp.ppterm s) (CicPp.ppterm ty') (CicPp.ppterm ty)))) - else - (* The type of a LetIn is a LetIn. Extremely slow since the computed - LetIn is later reduced and maybe also re-checked. - (C.LetIn (n,s, type_of_aux ((Some (n,(C.Def s)))::context) t)) - *) - (* The type of the LetIn is reduced. Much faster than the previous - solution. Moreover the inferred type is probably very different - from the expected one. - (CicReduction.whd ~subst context - (C.LetIn (n,s, type_of_aux ((Some (n,(C.Def s)))::context) t))) - *) - (* One-step LetIn reduction. Even faster than the previous solution. - Moreover the inferred type is closer to the expected one. *) - let ty1,ugraph2 = - type_of_aux ~logger - ((Some (n,(C.Def (s,ty))))::context) t ugraph1 - in - (CicSubstitution.subst ~avoid_beta_redexes:true s ty1),ugraph2 - | C.Appl (he::tl) when List.length tl > 0 -> - let hetype,ugraph1 = type_of_aux ~logger context he ugraph in - let tlbody_and_type,ugraph2 = - List.fold_right ( - fun x (l,ugraph) -> - let ty,ugraph1 = type_of_aux ~logger context x ugraph in - (*let _,ugraph1 = type_of_aux ~logger context ty ugraph1 in*) - ((x,ty)::l,ugraph1)) - tl ([],ugraph1) - in - (* TASSI: questa c'era nel mio... ma non nel CVS... *) - (* let _,ugraph2 = type_of_aux context hetype ugraph2 in *) - eat_prods ~subst context hetype tlbody_and_type ugraph2 - | C.Appl _ -> raise (AssertFailure (lazy "Appl: no arguments")) - | C.Const (uri,exp_named_subst) -> - incr fdebug ; - let ugraph1 = - check_exp_named_subst uri ~logger ~subst context exp_named_subst ugraph - in - let cty,ugraph2 = type_of_constant ~logger uri ugraph1 in - let cty1 = - CicSubstitution.subst_vars exp_named_subst cty - in - decr fdebug ; - cty1,ugraph2 - | C.MutInd (uri,i,exp_named_subst) -> - incr fdebug ; - let ugraph1 = - check_exp_named_subst uri ~logger ~subst context exp_named_subst ugraph - in - let mty,ugraph2 = type_of_mutual_inductive_defs ~logger uri i ugraph1 in - let cty = - CicSubstitution.subst_vars exp_named_subst mty - in - decr fdebug ; - cty,ugraph2 - | C.MutConstruct (uri,i,j,exp_named_subst) -> - let ugraph1 = - check_exp_named_subst uri ~logger ~subst context exp_named_subst ugraph - in - let mty,ugraph2 = - type_of_mutual_inductive_constr ~logger uri i j ugraph1 - in - let cty = - CicSubstitution.subst_vars exp_named_subst mty - in - cty,ugraph2 - | C.MutCase (uri,i,outtype,term,pl) -> - let outsort,ugraph1 = type_of_aux ~logger context outtype ugraph in - let (need_dummy, k) = - let rec guess_args context t = - let outtype = CicReduction.whd ~subst context t in - match outtype with - C.Sort _ -> (true, 0) - | C.Prod (name, s, t) -> - let (b, n) = - guess_args ((Some (name,(C.Decl s)))::context) t in - if n = 0 then - (* last prod before sort *) - match CicReduction.whd ~subst context s with -(*CSC: for _ see comment below about the missing named_exp_subst ?????????? *) - C.MutInd (uri',i',_) when U.eq uri' uri && i' = i -> - (false, 1) -(*CSC: for _ see comment below about the missing named_exp_subst ?????????? *) - | C.Appl ((C.MutInd (uri',i',_)) :: _) - when U.eq uri' uri && i' = i -> (false, 1) - | _ -> (true, 1) - else - (b, n + 1) - | _ -> - raise - (TypeCheckerFailure - (lazy (sprintf - "Malformed case analasys' output type %s" - (CicPp.ppterm outtype)))) - in -(* - let (parameters, arguments, exp_named_subst),ugraph2 = - let ty,ugraph2 = type_of_aux context term ugraph1 in - match R.whd ~subst context ty with - (*CSC manca il caso dei CAST *) -(*CSC: ma servono i parametri (uri,i)? Se si', perche' non serve anche il *) -(*CSC: parametro exp_named_subst? Se no, perche' non li togliamo? *) -(*CSC: Hint: nella DTD servono per gli stylesheet. *) - C.MutInd (uri',i',exp_named_subst) as typ -> - if U.eq uri uri' && i = i' then - ([],[],exp_named_subst),ugraph2 - else - raise - (TypeCheckerFailure - (lazy (sprintf - ("Case analysys: analysed term type is %s, but is expected to be (an application of) %s#1/%d{_}") - (CicPp.ppterm typ) (U.string_of_uri uri) i))) - | C.Appl - ((C.MutInd (uri',i',exp_named_subst) as typ):: tl) as typ' -> - if U.eq uri uri' && i = i' then - let params,args = - split tl (List.length tl - k) - in (params,args,exp_named_subst),ugraph2 - else - raise - (TypeCheckerFailure - (lazy (sprintf - ("Case analysys: analysed term type is %s, "^ - "but is expected to be (an application of) "^ - "%s#1/%d{_}") - (CicPp.ppterm typ') (U.string_of_uri uri) i))) - | _ -> - raise - (TypeCheckerFailure - (lazy (sprintf - ("Case analysis: "^ - "analysed term %s is not an inductive one") - (CicPp.ppterm term)))) -*) - let (b, k) = guess_args context outsort in - if not b then (b, k - 1) else (b, k) in - let (parameters, arguments, exp_named_subst),ugraph2 = - let ty,ugraph2 = type_of_aux ~logger context term ugraph1 in - match R.whd ~subst context ty with - C.MutInd (uri',i',exp_named_subst) as typ -> - if U.eq uri uri' && i = i' then - ([],[],exp_named_subst),ugraph2 - else raise - (TypeCheckerFailure - (lazy (sprintf - ("Case analysys: analysed term type is %s (%s#1/%d{_}), but is expected to be (an application of) %s#1/%d{_}") - (CicPp.ppterm typ) (U.string_of_uri uri') i' (U.string_of_uri uri) i))) - | C.Appl ((C.MutInd (uri',i',exp_named_subst) as typ):: tl) -> - if U.eq uri uri' && i = i' then - let params,args = - split tl (List.length tl - k) - in (params,args,exp_named_subst),ugraph2 - else raise - (TypeCheckerFailure - (lazy (sprintf - ("Case analysys: analysed term type is %s (%s#1/%d{_}), but is expected to be (an application of) %s#1/%d{_}") - (CicPp.ppterm typ) (U.string_of_uri uri') i' (U.string_of_uri uri) i))) - | _ -> - raise - (TypeCheckerFailure - (lazy (sprintf - "Case analysis: analysed term %s is not an inductive one" - (CicPp.ppterm term)))) - in - (* - let's control if the sort elimination is allowed: - [(I q1 ... qr)|B] - *) - let sort_of_ind_type = - if parameters = [] then - C.MutInd (uri,i,exp_named_subst) - else - C.Appl ((C.MutInd (uri,i,exp_named_subst))::parameters) - in - let type_of_sort_of_ind_ty,ugraph3 = - type_of_aux ~logger context sort_of_ind_type ugraph2 in - let b,ugraph4 = - check_allowed_sort_elimination ~subst ~metasenv ~logger context uri i - need_dummy sort_of_ind_type type_of_sort_of_ind_ty outsort ugraph3 - in - if not b then - raise - (TypeCheckerFailure (lazy ("Case analysis: sort elimination not allowed"))); - (* let's check if the type of branches are right *) - let parsno,constructorsno = - let obj,_ = - try - CicEnvironment.get_cooked_obj ~trust:false CicUniv.empty_ugraph uri - with Not_found -> assert false - in - match obj with - C.InductiveDefinition (il,_,parsno,_) -> - let _,_,_,cl = - try List.nth il i with Failure _ -> assert false - in - parsno, List.length cl - | _ -> - raise (TypeCheckerFailure - (lazy ("Unknown mutual inductive definition:" ^ - UriManager.string_of_uri uri))) - in - if List.length pl <> constructorsno then - raise (TypeCheckerFailure - (lazy ("Wrong number of cases in case analysis"))) ; - let (_,branches_ok,ugraph5) = - List.fold_left - (fun (j,b,ugraph) p -> - if b then - let cons = - if parameters = [] then - (C.MutConstruct (uri,i,j,exp_named_subst)) - else - (C.Appl - (C.MutConstruct (uri,i,j,exp_named_subst)::parameters)) - in - let ty_p,ugraph1 = type_of_aux ~logger context p ugraph in - let ty_cons,ugraph3 = type_of_aux ~logger context cons ugraph1 in - (* 2 is skipped *) - let ty_branch = - type_of_branch ~subst context parsno need_dummy outtype cons - ty_cons in - let b1,ugraph4 = - R.are_convertible - ~subst ~metasenv context ty_p ty_branch ugraph3 - in -(* Debugging code -if not b1 then -begin -prerr_endline ("\n!OUTTYPE= " ^ CicPp.ppterm outtype); -prerr_endline ("!CONS= " ^ CicPp.ppterm cons); -prerr_endline ("!TY_CONS= " ^ CicPp.ppterm ty_cons); -prerr_endline ("#### " ^ CicPp.ppterm ty_p ^ "\n<==>\n" ^ CicPp.ppterm ty_branch); -end; -*) - if not b1 then - debug_print (lazy - ("#### " ^ CicPp.ppterm ty_p ^ - " <==> " ^ CicPp.ppterm ty_branch)); - (j + 1,b1,ugraph4) - else - (j,false,ugraph) - ) (1,true,ugraph4) pl - in - if not branches_ok then - raise - (TypeCheckerFailure (lazy "Case analysys: wrong branch type")); - let arguments' = - if not need_dummy then outtype::arguments@[term] - else outtype::arguments in - let outtype = - if need_dummy && arguments = [] then outtype - else CicReduction.head_beta_reduce (C.Appl arguments') - in - outtype,ugraph5 - | C.Fix (i,fl) -> - let types,kl,ugraph1,len = - List.fold_left - (fun (types,kl,ugraph,len) (n,k,ty,_) -> - let _,ugraph1 = type_of_aux ~logger context ty ugraph in - (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types, - k::kl,ugraph1,len+1) - ) ([],[],ugraph,0) fl - in - let ugraph2 = - List.fold_left - (fun ugraph (name,x,ty,bo) -> - let ty_bo,ugraph1 = - type_of_aux ~logger (types@context) bo ugraph - in - let b,ugraph2 = - R.are_convertible ~subst ~metasenv (types@context) - ty_bo (CicSubstitution.lift len ty) ugraph1 in - if b then - begin - let (m, eaten, context') = - eat_lambdas ~subst (types @ context) (x + 1) bo - in - let rec_uri, rec_uri_len = - let he = - match List.hd context' with - Some (_,Cic.Decl he) -> he - | _ -> assert false - in - match CicReduction.whd ~subst (List.tl context') he with - | Cic.MutInd (uri,_,_) - | Cic.Appl (Cic.MutInd (uri,_,_)::_) -> - uri, - (match - CicEnvironment.get_obj - CicUniv.oblivion_ugraph uri - with - | Cic.InductiveDefinition (tl,_,_,_), _ -> - List.length tl - | _ -> assert false) - | _ -> assert false - in - (* - let's control the guarded by - destructors conditions D{f,k,x,M} - *) - if not (guarded_by_destructors ~logger ~metasenv ~subst - rec_uri rec_uri_len context' eaten (len + eaten) kl - 1 [] m) - then - raise - (TypeCheckerFailure - (lazy ("Fix: not guarded by destructors:"^CicPp.ppterm t))) - else - ugraph2 - end - else - raise (TypeCheckerFailure (lazy ("Fix: ill-typed bodies"))) - ) ugraph1 fl in - (*CSC: controlli mancanti solo su D{f,k,x,M} *) - let (_,_,ty,_) = List.nth fl i in - ty,ugraph2 - | C.CoFix (i,fl) -> - let types,ugraph1,len = - List.fold_left - (fun (l,ugraph,len) (n,ty,_) -> - let _,ugraph1 = - type_of_aux ~logger context ty ugraph in - (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::l, - ugraph1,len+1) - ) ([],ugraph,0) fl - in - let ugraph2 = - List.fold_left - (fun ugraph (_,ty,bo) -> - let ty_bo,ugraph1 = - type_of_aux ~logger (types @ context) bo ugraph - in - let b,ugraph2 = - R.are_convertible ~subst ~metasenv (types @ context) ty_bo - (CicSubstitution.lift len ty) ugraph1 - in - if b then - begin - (* let's control that the returned type is coinductive *) - match returns_a_coinductive ~subst context ty with - None -> - raise - (TypeCheckerFailure - (lazy "CoFix: does not return a coinductive type")) - | Some uri -> - (* - let's control the guarded by constructors - conditions C{f,M} - *) - if not (guarded_by_constructors ~logger ~subst ~metasenv uri - (types @ context) 0 len false bo) then - raise - (TypeCheckerFailure - (lazy "CoFix: not guarded by constructors")) - else - ugraph2 - end - else - raise - (TypeCheckerFailure (lazy "CoFix: ill-typed bodies")) - ) ugraph1 fl - in - let (_,ty,_) = List.nth fl i in - ty,ugraph2 - - and check_exp_named_subst uri ~logger ~subst context ens ugraph = - let params = - let obj,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - (match obj with - Cic.Constant (_,_,_,params,_) -> params - | Cic.Variable (_,_,_,params,_) -> params - | Cic.CurrentProof (_,_,_,_,params,_) -> params - | Cic.InductiveDefinition (_,params,_,_) -> params - ) in - let rec check_same_order params ens = - match params,ens with - | _,[] -> () - | [],_::_ -> - raise (TypeCheckerFailure (lazy "Bad explicit named substitution")) - | uri::tl,(uri',_)::tl' when UriManager.eq uri uri' -> - check_same_order tl tl' - | _::tl,l -> check_same_order tl l - in - let rec check_exp_named_subst_aux ~logger esubsts l ugraph = - match l with - [] -> ugraph - | ((uri,t) as item)::tl -> - let ty_uri,ugraph1 = type_of_variable ~logger uri ugraph in - let typeofvar = - CicSubstitution.subst_vars esubsts ty_uri in - let typeoft,ugraph2 = type_of_aux ~logger context t ugraph1 in - let b,ugraph3 = - CicReduction.are_convertible ~subst ~metasenv - context typeoft typeofvar ugraph2 - in - if b then - check_exp_named_subst_aux ~logger (esubsts@[item]) tl ugraph3 - else - begin - CicReduction.fdebug := 0 ; - ignore - (CicReduction.are_convertible - ~subst ~metasenv context typeoft typeofvar ugraph2) ; - fdebug := 0 ; - debug typeoft [typeofvar] ; - raise (TypeCheckerFailure (lazy "Wrong Explicit Named Substitution")) - end - in - check_same_order params ens ; - check_exp_named_subst_aux ~logger [] ens ugraph - - and sort_of_prod ~subst context (name,s) (t1, t2) ugraph = - let module C = Cic in - let t1' = CicReduction.whd ~subst context t1 in - let t2' = CicReduction.whd ~subst ((Some (name,C.Decl s))::context) t2 in - match (t1', t2') with - | (C.Sort s1, C.Sort (C.Prop | C.Set)) -> - (* different from Coq manual!!! *) - t2',ugraph - | (C.Sort (C.Type t1 | C.CProp t1), C.Sort (C.Type t2)) -> - let t' = CicUniv.fresh() in - (try - let ugraph1 = CicUniv.add_ge t' t1 ugraph in - let ugraph2 = CicUniv.add_ge t' t2 ugraph1 in - C.Sort (C.Type t'),ugraph2 - with - CicUniv.UniverseInconsistency msg -> raise (TypeCheckerFailure msg)) - | (C.Sort (C.CProp t1 | C.Type t1), C.Sort (C.CProp t2)) -> - let t' = CicUniv.fresh() in - (try - let ugraph1 = CicUniv.add_ge t' t1 ugraph in - let ugraph2 = CicUniv.add_ge t' t2 ugraph1 in - C.Sort (C.CProp t'),ugraph2 - with - CicUniv.UniverseInconsistency msg -> raise (TypeCheckerFailure msg)) - | (C.Sort _,C.Sort (C.Type t1)) -> C.Sort (C.Type t1),ugraph - | (C.Sort _,C.Sort (C.CProp t1)) -> C.Sort (C.CProp t1),ugraph - | (C.Meta _, C.Sort _) -> t2',ugraph - | (C.Meta _, (C.Meta (_,_) as t)) - | (C.Sort _, (C.Meta (_,_) as t)) when CicUtil.is_closed t -> - t2',ugraph - | (_,_) -> raise (TypeCheckerFailure (lazy (sprintf - "Prod: expected two sorts, found = %s, %s" (CicPp.ppterm t1') - (CicPp.ppterm t2')))) - - and eat_prods ~subst context hetype l ugraph = - (*CSC: siamo sicuri che le are_convertible non lavorino con termini non *) - (*CSC: cucinati *) - match l with - [] -> hetype,ugraph - | (hete, hety)::tl -> - (match (CicReduction.whd ~subst context hetype) with - Cic.Prod (n,s,t) -> - let b,ugraph1 = -(*if (match hety,s with Cic.Sort _,Cic.Sort _ -> false | _,_ -> true) && hety <> s then( -prerr_endline ("AAA22: " ^ CicPp.ppterm hete ^ ": " ^ CicPp.ppterm hety ^ " <==> " ^ CicPp.ppterm s); let res = CicReduction.are_convertible ~subst ~metasenv context hety s ugraph in prerr_endline "#"; res) else*) - CicReduction.are_convertible - ~subst ~metasenv context hety s ugraph - in - if b then - begin - CicReduction.fdebug := -1 ; - eat_prods ~subst context - (CicSubstitution.subst ~avoid_beta_redexes:true hete t) - tl ugraph1 - (*TASSI: not sure *) - end - else - begin - CicReduction.fdebug := 0 ; - ignore (CicReduction.are_convertible - ~subst ~metasenv context s hety ugraph) ; - fdebug := 0 ; - debug s [hety] ; - raise - (TypeCheckerFailure - (lazy (sprintf - ("Appl: wrong parameter-type, expected %s, found %s") - (CicPp.ppterm hetype) (CicPp.ppterm s)))) - end - | _ -> - raise (TypeCheckerFailure - (lazy "Appl: this is not a function, it cannot be applied")) - ) - - and returns_a_coinductive ~subst context ty = - let module C = Cic in - match CicReduction.whd ~subst context ty with - C.MutInd (uri,i,_) -> - (*CSC: definire una funzioncina per questo codice sempre replicato *) - let obj,_ = - try - CicEnvironment.get_cooked_obj ~trust:false CicUniv.empty_ugraph uri - with Not_found -> assert false - in - (match obj with - C.InductiveDefinition (itl,_,_,_) -> - let (_,is_inductive,_,_) = List.nth itl i in - if is_inductive then None else (Some uri) - | _ -> - raise (TypeCheckerFailure - (lazy ("Unknown mutual inductive definition:" ^ - UriManager.string_of_uri uri))) - ) - | C.Appl ((C.MutInd (uri,i,_))::_) -> - (let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - match o with - C.InductiveDefinition (itl,_,_,_) -> - let (_,is_inductive,_,_) = List.nth itl i in - if is_inductive then None else (Some uri) - | _ -> - raise (TypeCheckerFailure - (lazy ("Unknown mutual inductive definition:" ^ - UriManager.string_of_uri uri))) - ) - | C.Prod (n,so,de) -> - returns_a_coinductive ~subst ((Some (n,C.Decl so))::context) de - | _ -> None - - in -(*CSC -debug_print (lazy ("INIZIO TYPE_OF_AUX " ^ CicPp.ppterm t)) ; flush stderr ; -let res = -*) - type_of_aux ~logger context t ugraph -(* -in debug_print (lazy "FINE TYPE_OF_AUX") ; flush stderr ; res -*) - -(* is a small constructor? *) -(*CSC: ottimizzare calcolando staticamente *) -and is_small_or_non_informative ~condition ~logger context paramsno c ugraph = - let rec is_small_or_non_informative_aux ~logger context c ugraph = - let module C = Cic in - match CicReduction.whd context c with - C.Prod (n,so,de) -> - let s,ugraph1 = type_of_aux' ~logger [] context so ugraph in - let b = condition s in - if b then - is_small_or_non_informative_aux - ~logger ((Some (n,(C.Decl so)))::context) de ugraph1 - else - false,ugraph1 - | _ -> true,ugraph (*CSC: we trust the type-checker *) - in - let (context',dx) = split_prods ~subst:[] context paramsno c in - is_small_or_non_informative_aux ~logger context' dx ugraph - -and is_small ~logger = - is_small_or_non_informative - ~condition:(fun s -> s=Cic.Sort Cic.Prop || s=Cic.Sort Cic.Set) - ~logger - -and is_non_informative ~logger = - is_small_or_non_informative - ~condition:(fun s -> s=Cic.Sort Cic.Prop) - ~logger - -and type_of ~logger t ugraph = -(*CSC -debug_print (lazy ("INIZIO TYPE_OF_AUX' " ^ CicPp.ppterm t)) ; flush stderr ; -let res = -*) - type_of_aux' ~logger [] [] t ugraph -(*CSC -in debug_print (lazy "FINE TYPE_OF_AUX'") ; flush stderr ; res -*) -;; - -let typecheck_obj0 ~logger uri (obj,unchecked_ugraph) = - let module C = Cic in - let ugraph = CicUniv.empty_ugraph in - let inferred_ugraph = - match obj with - | C.Constant (_,Some te,ty,_,_) -> - let _,ugraph = type_of ~logger ty ugraph in - let ty_te,ugraph = type_of ~logger te ugraph in - let b,ugraph = (CicReduction.are_convertible [] ty_te ty ugraph) in - if not b then - raise (TypeCheckerFailure - (lazy - ("the type of the body is not the one expected:\n" ^ - CicPp.ppterm ty_te ^ "\nvs\n" ^ - CicPp.ppterm ty))) - else - ugraph - | C.Constant (_,None,ty,_,_) -> - (* only to check that ty is well-typed *) - let _,ugraph = type_of ~logger ty ugraph in - ugraph - | C.CurrentProof (_,conjs,te,ty,_,_) -> - (* this block is broken since the metasenv should - * be topologically sorted before typing metas *) - ignore(assert false); - let _,ugraph = - List.fold_left - (fun (metasenv,ugraph) ((_,context,ty) as conj) -> - let _,ugraph = - type_of_aux' ~logger metasenv context ty ugraph - in - metasenv @ [conj],ugraph - ) ([],ugraph) conjs - in - let _,ugraph = type_of_aux' ~logger conjs [] ty ugraph in - let type_of_te,ugraph = - type_of_aux' ~logger conjs [] te ugraph - in - let b,ugraph = CicReduction.are_convertible [] type_of_te ty ugraph in - if not b then - raise (TypeCheckerFailure (lazy (sprintf - "the current proof is not well typed because the type %s of the body is not convertible to the declared type %s" - (CicPp.ppterm type_of_te) (CicPp.ppterm ty)))) - else - ugraph - | C.Variable (_,bo,ty,_,_) -> - (* only to check that ty is well-typed *) - let _,ugraph = type_of ~logger ty ugraph in - (match bo with - None -> ugraph - | Some bo -> - let ty_bo,ugraph = type_of ~logger bo ugraph in - let b,ugraph = CicReduction.are_convertible [] ty_bo ty ugraph in - if not b then - raise (TypeCheckerFailure - (lazy "the body is not the one expected")) - else - ugraph - ) - | (C.InductiveDefinition _ as obj) -> - check_mutual_inductive_defs ~logger uri obj ugraph - in - check_and_clean_ugraph inferred_ugraph unchecked_ugraph uri obj -;; - -let typecheck ?(trust=true) uri = - let module C = Cic in - let module R = CicReduction in - let module U = UriManager in - let logger = new CicLogger.logger in - match CicEnvironment.is_type_checked ~trust CicUniv.empty_ugraph uri with - | CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph' - | CicEnvironment.UncheckedObj (uobj,unchecked_ugraph) -> - (* let's typecheck the uncooked object *) - logger#log (`Start_type_checking uri) ; - let ugraph, ul, obj = typecheck_obj0 ~logger uri (uobj,unchecked_ugraph) in - CicEnvironment.set_type_checking_info uri (obj,ugraph,ul); - logger#log (`Type_checking_completed uri); - match CicEnvironment.is_type_checked ~trust CicUniv.empty_ugraph uri with - | CicEnvironment.CheckedObj (cobj,ugraph') -> cobj,ugraph' - | _ -> raise CicEnvironmentError -;; - -let typecheck_obj ~logger uri obj = - let ugraph,univlist,obj = typecheck_obj0 ~logger uri (obj,None) in - CicEnvironment.add_type_checked_obj uri (obj,ugraph,univlist) - -(** wrappers which instantiate fresh loggers *) - -let profiler = HExtlib.profile "K/CicTypeChecker.type_of_aux'" - -let type_of_aux' ?(subst = []) metasenv context t ugraph = - let logger = new CicLogger.logger in - profiler.HExtlib.profile - (type_of_aux' ~logger ~subst metasenv context t) ugraph - -let typecheck_obj uri obj = - let logger = new CicLogger.logger in - typecheck_obj ~logger uri obj - -(* check_allowed_sort_elimination uri i s1 s2 - This function is used outside the kernel to determine in advance whether - a MutCase will be allowed or not. - [uri,i] is the type of the term to match - [s1] is the sort of the term to eliminate (i.e. the head of the arity - of the inductive type [uri,i]) - [s2] is the sort of the goal (i.e. the head of the type of the outtype - of the MutCase) *) -let check_allowed_sort_elimination uri i s1 s2 = - fst (check_allowed_sort_elimination ~subst:[] ~metasenv:[] - ~logger:(new CicLogger.logger) [] uri i true - (Cic.Implicit None) (* never used *) (Cic.Sort s1) (Cic.Sort s2) - CicUniv.empty_ugraph) -;; - -Deannotate.type_of_aux' := - fun context t -> - ignore ( - List.fold_right - (fun el context -> - (match el with - None -> () - | Some (_,Cic.Decl ty) -> - ignore (type_of_aux' [] context ty CicUniv.empty_ugraph) - | Some (_,Cic.Def (bo,ty)) -> - ignore (type_of_aux' [] context ty CicUniv.empty_ugraph); - ignore (type_of_aux' [] context bo CicUniv.empty_ugraph)); - el::context - ) context []); - fst (type_of_aux' [] context t CicUniv.empty_ugraph);; diff --git a/matita/components/cic_proof_checking/cicTypeChecker.mli b/matita/components/cic_proof_checking/cicTypeChecker.mli deleted file mode 100644 index a3361fc7b..000000000 --- a/matita/components/cic_proof_checking/cicTypeChecker.mli +++ /dev/null @@ -1,71 +0,0 @@ -(* Copyright (C) 2000, 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/. - *) - -(* These are the only exceptions that will be raised *) -exception TypeCheckerFailure of string Lazy.t -exception AssertFailure of string Lazy.t - -(* this function is exported to be used also by the refiner; - the callback function (defaul value: ignore) is invoked on each - processed subterm; its first argument is the undebrujined term (the - input); its second argument the corresponding debrujined term (the - output). The callback is used to relocalize the error messages *) -val debrujin_constructor : - ?cb:(Cic.term -> Cic.term -> unit) -> - ?check_exp_named_subst: bool -> - UriManager.uri -> int -> Cic.context -> Cic.term -> Cic.term - - (* defaults to true *) -val typecheck : - ?trust:bool -> UriManager.uri -> Cic.obj * CicUniv.universe_graph - -(* FUNCTIONS USED ONLY IN THE TOPLEVEL *) - -(* type_of_aux' metasenv context term *) -val type_of_aux': - ?subst:Cic.substitution -> Cic.metasenv -> Cic.context -> - Cic.term -> CicUniv.universe_graph -> - Cic.term * CicUniv.universe_graph - -(* typechecks the obj and puts it in the environment - * empty universes are filed with the given uri, thus you should - * get the object again after calling this *) -val typecheck_obj : UriManager.uri -> Cic.obj -> unit - -(* check_allowed_sort_elimination uri i s1 s2 - This function is used outside the kernel to determine in advance whether - a MutCase will be allowed or not. - [uri,i] is the type of the term to match - [s1] is the sort of the term to eliminate (i.e. the head of the arity - of the inductive type [uri,i]) - [s2] is the sort of the goal (i.e. the head of the type of the outtype - of the MutCase) *) -val check_allowed_sort_elimination: - UriManager.uri -> int -> Cic.sort -> Cic.sort -> bool - -(* does_not_occur ~subst context n nn t - checks if the semi-open interval of Rels (n,nn] occurs in t *) -val does_not_occur: - ?subst:Cic.substitution -> Cic.context -> int -> int -> Cic.term -> bool diff --git a/matita/components/cic_proof_checking/cicUnivUtils.ml b/matita/components/cic_proof_checking/cicUnivUtils.ml deleted file mode 100644 index 2c35ebe1a..000000000 --- a/matita/components/cic_proof_checking/cicUnivUtils.ml +++ /dev/null @@ -1,149 +0,0 @@ -(* Copyright (C) 2000, 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/. - *) - -(*****************************************************************************) -(* *) -(* PROJECT HELM *) -(* *) -(* Enrico Tassi *) -(* 23/04/2004 *) -(* *) -(* This module implements some useful function regarding univers graphs *) -(* *) -(*****************************************************************************) - -(* $Id$ *) - -module C = Cic -module H = UriManager.UriHashtbl -let eq = UriManager.eq - -(* uri is the uri of the actual object that must be 'skipped' *) -let universes_of_obj uri t = - (* don't the same work twice *) - let visited_objs = H.create 31 in - let visited u = H.replace visited_objs u true in - let is_not_visited u = not (H.mem visited_objs u) in - visited uri; - (* the result *) - let results = ref [] in - let add_result l = results := l :: !results in - (* the iterators *) - let rec aux = function - | C.Const (u,exp_named_subst) when is_not_visited u -> - aux_uri u; - visited u; - C.Const (u, List.map (fun (x,t) -> x,aux t) exp_named_subst) - | C.Var (u,exp_named_subst) when is_not_visited u -> - aux_uri u; - visited u; - C.Var (u, List.map (fun (x,t) -> x,aux t) exp_named_subst) - | C.Const (u,exp_named_subst) -> - C.Const (u, List.map (fun (x,t) -> x,aux t) exp_named_subst) - | C.Var (u,exp_named_subst) -> - C.Var (u, List.map (fun (x,t) -> x,aux t) exp_named_subst) - | C.MutInd (u,x,exp_named_subst) when is_not_visited u -> - aux_uri u; - visited u; - C.MutInd (u,x,List.map (fun (x,t) -> x,aux t) exp_named_subst) - | C.MutInd (u,x,exp_named_subst) -> - C.MutInd (u,x, List.map (fun (x,t) -> x,aux t) exp_named_subst) - | C.MutConstruct (u,x,y,exp_named_subst) when is_not_visited u -> - aux_uri u; - visited u; - C.MutConstruct (u,x,y,List.map (fun (x,t) -> x,aux t) exp_named_subst) - | C.MutConstruct (x,y,z,exp_named_subst) -> - C.MutConstruct (x,y,z,List.map (fun (x,t) -> x,aux t) exp_named_subst) - | C.Meta (n,l1) -> C.Meta (n, List.map (HExtlib.map_option aux) l1) - | C.Sort (C.Type i) -> add_result [i]; - C.Sort (C.Type (CicUniv.name_universe i uri)) - | C.Sort (C.CProp i) -> add_result [i]; - C.Sort (C.CProp (CicUniv.name_universe i uri)) - | C.Rel _ - | C.Sort _ - | C.Implicit _ as x -> x - | C.Cast (v,t) -> C.Cast (aux v, aux t) - | C.Prod (b,s,t) -> C.Prod (b,aux s, aux t) - | C.Lambda (b,s,t) -> C.Lambda (b,aux s, aux t) - | C.LetIn (b,s,ty,t) -> C.LetIn (b,aux s, aux ty, aux t) - | C.Appl li -> C.Appl (List.map aux li) - | C.MutCase (uri,n1,ty,te,patterns) -> - C.MutCase (uri,n1,aux ty,aux te, List.map aux patterns) - | C.Fix (no, funs) -> - C.Fix(no, List.map (fun (x,y,b,c) -> (x,y,aux b,aux c)) funs) - | C.CoFix (no,funs) -> - C.CoFix(no, List.map (fun (x,b,c) -> (x,aux b,aux c)) funs) - and aux_uri u = - if is_not_visited u then - let _, _, l = - CicEnvironment.get_cooked_obj_with_univlist CicUniv.empty_ugraph u in - add_result l - and aux_obj = function - | C.Constant (x,Some te,ty,v,y) -> - List.iter aux_uri v; - C.Constant (x,Some (aux te),aux ty,v,y) - | C.Variable (x,Some te,ty,v,y) -> - List.iter aux_uri v; - C.Variable (x,Some (aux te),aux ty,v,y) - | C.Constant (x,None, ty, v,y) -> - List.iter aux_uri v; - C.Constant (x,None, aux ty, v,y) - | C.Variable (x,None, ty, v,y) -> - List.iter aux_uri v; - C.Variable (x,None, aux ty, v,y) - | C.CurrentProof (_,conjs,te,ty,v,_) -> assert false - | C.InductiveDefinition (l,v,x,y) -> - List.iter aux_uri v; - C.InductiveDefinition ( - List.map - (fun (x,y,t,l') -> - (x,y,aux t, List.map (fun (x,t) -> x,aux t) l')) - l,v,x,y) - in - let o = aux_obj t in - List.flatten !results, o - -let list_uniq l = - HExtlib.list_uniq (List.fast_sort CicUniv.compare l) - -let clean_and_fill uri obj ugraph = - (* universes of obj fills the universes of the obj with the right uri *) - let list_of_universes, obj = universes_of_obj uri obj in - let list_of_universes = list_uniq list_of_universes in -(* CicUniv.print_ugraph ugraph;*) -(* List.iter (fun u -> prerr_endline (CicUniv.string_of_universe u))*) -(* list_of_universes;*) - let ugraph = CicUniv.clean_ugraph ugraph list_of_universes in -(* CicUniv.print_ugraph ugraph;*) - let ugraph, list_of_universes = - CicUniv.fill_empty_nodes_with_uri ugraph list_of_universes uri - in - ugraph, list_of_universes, obj - -(* -let profiler = (HExtlib.profile "clean_and_fill").HExtlib.profile -let clean_and_fill u o g = - profiler (clean_and_fill u o) g -*) diff --git a/matita/components/cic_proof_checking/cicUnivUtils.mli b/matita/components/cic_proof_checking/cicUnivUtils.mli deleted file mode 100644 index eb55a47eb..000000000 --- a/matita/components/cic_proof_checking/cicUnivUtils.mli +++ /dev/null @@ -1,32 +0,0 @@ -(* Copyright (C) 2000, 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/. - *) - - (** cleans the universe graph for a given object and fills universes with URI. - * to be used on qed - *) -val clean_and_fill: - UriManager.uri -> Cic.obj -> CicUniv.universe_graph -> - CicUniv.universe_graph * CicUniv.universe list * Cic.obj - diff --git a/matita/components/cic_proof_checking/doc/inductive.txt b/matita/components/cic_proof_checking/doc/inductive.txt deleted file mode 100644 index f2e49d398..000000000 --- a/matita/components/cic_proof_checking/doc/inductive.txt +++ /dev/null @@ -1,41 +0,0 @@ -Table of allowed eliminations: - - +--------------------+----------------------------------+ - | Inductive Type | Elimination to | - +--------------------+----------------------------------+ - | Sort | "Smallness" | Prop | SetI | SetP | CProp| Type | - +--------------------+----------------------------------+ - | Prop empty | yes yes yes yes yes | - | Prop unit | yes yes yes yes yes | - | Prop small | yes no2 no2 no2 no12 | - | Prop | yes no2 no2 no2 no12 | - | SetI empty | yes yes -- yes yes | - | SetI small | yes yes -- yes yes | - | SetI | yes yes -- no1 no1 | - | SetP empty | yes -- yes yes yes | - | SetP small | yes -- yes yes yes | - | SetP | na3 na3 na3 na3 na3 | - | CProp empty | yes yes yes yes yes | - | CProp small | yes yes yes yes yes | - | CProp | yes yes yes yes yes | - | Type | yes yes yes yes yes | - +--------------------+----------------------------------+ - -Legenda: - no: elimination not allowed - na: not allowed, the inductive definition is rejected - - 1 : due to paradoxes a la Hurkens - 2 : due to code extraction + proof irreleveance incompatibility - (if you define Bool in Prop, you will be able to prove true<>false) - 3 : inductive type is rejected due to universe inconsistency - - SetP : Predicative Set - SetI : Impredicative Set - - non-informative : Constructor arguments are in Prop only - small : Constructor arguments are not in Type and SetP and CProp - unit : Non (mutually) recursive /\ only one constructor /\ non-informative - empty : in Coq: no constructors and non mutually recursive - in Matita: no constructors (but eventually mutually recursive - with non-empty types) diff --git a/matita/components/cic_proof_checking/freshNamesGenerator.ml b/matita/components/cic_proof_checking/freshNamesGenerator.ml deleted file mode 100755 index daa0e5432..000000000 --- a/matita/components/cic_proof_checking/freshNamesGenerator.ml +++ /dev/null @@ -1,367 +0,0 @@ -(* Copyright (C) 2004, 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_print = fun _ -> () - -let rec higher_name arity = - function - Cic.Sort Cic.Prop - | Cic.Sort (Cic.CProp _) -> - if arity = 0 then "A" (* propositions *) - else if arity = 1 then "P" (* predicates *) - else "R" (*relations *) - | Cic.Sort Cic.Set - -> if arity = 0 then "S" else "F" - | Cic.Sort (Cic.Type _ ) -> - if arity = 0 then "T" else "F" - | Cic.Prod (_,_,t) -> higher_name (arity+1) t - | _ -> "f" - -let get_initial s = - if String.length s = 0 then "_" - else - let head = String.sub s 0 1 in - String.lowercase head - -(* only used when the sort is not Prop or CProp *) -let rec guess_a_name context ty = - match ty with - Cic.Rel n -> - (match List.nth context (n-1) with - None -> assert false - | Some (Cic.Anonymous,_) -> "eccomi_qua" - | Some (Cic.Name s,_) -> get_initial s) - | Cic.Var (uri,_) -> get_initial (UriManager.name_of_uri uri) - | Cic.Sort _ -> higher_name 0 ty - | Cic.Implicit _ -> assert false - | Cic.Cast (t1,t2) -> guess_a_name context t1 - | Cic.Prod (na_,_,t) -> higher_name 1 t -(* warning: on appl we should beta reduce before the recursive call - | Cic.Lambda _ -> assert false -*) - | Cic.LetIn (_,s,_,t) -> guess_a_name context (CicSubstitution.subst ~avoid_beta_redexes:true s t) - | Cic.Appl [] -> assert false - | Cic.Appl (he::_) -> guess_a_name context he - | Cic.Const (uri,_) - | Cic.MutInd (uri,_,_) - | Cic.MutConstruct (uri,_,_,_) -> get_initial (UriManager.name_of_uri uri) - | _ -> "x" - -(* mk_fresh_name context name typ *) -(* returns an identifier which is fresh in the context *) -(* and that resembles [name] as much as possible. *) -(* [typ] will be the type of the variable *) -let mk_fresh_name ~subst metasenv context name ~typ = - let module C = Cic in - let basename = - match name with - C.Anonymous -> - (try - let ty,_ = - CicTypeChecker.type_of_aux' ~subst metasenv context typ - CicUniv.oblivion_ugraph - in - (match ty with - C.Sort C.Prop - | C.Sort (C.CProp _) -> "H" - | _ -> guess_a_name context typ - ) - with CicTypeChecker.TypeCheckerFailure _ -> "H" - ) - | C.Name name -> - Str.global_replace (Str.regexp "[0-9']*$") "" name - in - let already_used name = - List.exists (function Some (n,_) -> n=name | _ -> false) context - in - if name <> C.Anonymous && not (already_used name) then - name - else if not (already_used (C.Name basename)) then - C.Name basename - else - let rec try_next n = - let name' = C.Name (basename ^ string_of_int n) in - if already_used name' then - try_next (n+1) - else - name' - in - try_next 1 -;; - -(* let mk_fresh_names ~subst metasenv context t *) -let rec mk_fresh_names ~subst metasenv context t = - match t with - Cic.Rel _ -> t - | Cic.Var (uri,exp_named_subst) -> - let ens = - List.map - (fun (uri,t) -> - (uri,mk_fresh_names ~subst metasenv context t)) exp_named_subst in - Cic.Var (uri,ens) - | Cic.Meta (i,l) -> - let l' = - List.map - (fun t -> - match t with - None -> None - | Some t -> Some (mk_fresh_names ~subst metasenv context t)) l in - Cic.Meta(i,l') - | Cic.Sort _ - | Cic.Implicit _ -> t - | Cic.Cast (te,ty) -> - let te' = mk_fresh_names ~subst metasenv context te in - let ty' = mk_fresh_names ~subst metasenv context ty in - Cic.Cast (te', ty') - | Cic.Prod (n,s,t) -> - let s' = mk_fresh_names ~subst metasenv context s in - let n' = - match n with - Cic.Anonymous -> Cic.Anonymous - | Cic.Name "matita_dummy" -> - mk_fresh_name ~subst metasenv context Cic.Anonymous ~typ:s' - | _ -> n in - let t' = mk_fresh_names ~subst metasenv (Some(n',Cic.Decl s')::context) t in - Cic.Prod (n',s',t') - | Cic.Lambda (n,s,t) -> - let s' = mk_fresh_names ~subst metasenv context s in - let n' = - match n with - Cic.Anonymous -> Cic.Anonymous - | Cic.Name "matita_dummy" -> - mk_fresh_name ~subst metasenv context Cic.Anonymous ~typ:s' - | _ -> n in - let t' = mk_fresh_names ~subst metasenv (Some(n',Cic.Decl s')::context) t in - Cic.Lambda (n',s',t') - | Cic.LetIn (n,s,ty,t) -> - let s' = mk_fresh_names ~subst metasenv context s in - let ty' = mk_fresh_names ~subst metasenv context ty in - let n' = - match n with - Cic.Anonymous -> Cic.Anonymous - | Cic.Name "matita_dummy" -> - mk_fresh_name ~subst metasenv context Cic.Anonymous ~typ:s' - | _ -> n in - let t' = mk_fresh_names ~subst metasenv (Some(n',Cic.Def (s',ty'))::context) t in - Cic.LetIn (n',s',ty',t') - | Cic.Appl l -> - Cic.Appl (List.map (mk_fresh_names ~subst metasenv context) l) - | Cic.Const (uri,exp_named_subst) -> - let ens = - List.map - (fun (uri,t) -> - (uri,mk_fresh_names ~subst metasenv context t)) exp_named_subst in - Cic.Const(uri,ens) - | Cic.MutInd (uri,tyno,exp_named_subst) -> - let ens = - List.map - (fun (uri,t) -> - (uri,mk_fresh_names ~subst metasenv context t)) exp_named_subst in - Cic.MutInd (uri,tyno,ens) - | Cic.MutConstruct (uri,tyno,consno,exp_named_subst) -> - let ens = - List.map - (fun (uri,t) -> - (uri,mk_fresh_names ~subst metasenv context t)) exp_named_subst in - Cic.MutConstruct (uri,tyno,consno, ens) - | Cic.MutCase (sp,i,outty,t,pl) -> - let outty' = mk_fresh_names ~subst metasenv context outty in - let t' = mk_fresh_names ~subst metasenv context t in - let pl' = List.map (mk_fresh_names ~subst metasenv context) pl in - Cic.MutCase (sp, i, outty', t', pl') - | Cic.Fix (i, fl) -> - let tys,_ = - List.fold_left - (fun (types,len) (n,_,ty,_) -> - (Some (Cic.Name n,(Cic.Decl (CicSubstitution.lift len ty)))::types, - len+1) - ) ([],0) fl - in - let fl' = List.map - (fun (n,i,ty,bo) -> - let ty' = mk_fresh_names ~subst metasenv context ty in - let bo' = mk_fresh_names ~subst metasenv (tys@context) bo in - (n,i,ty',bo')) fl in - Cic.Fix (i, fl') - | Cic.CoFix (i, fl) -> - let tys,_ = - List.fold_left - (fun (types,len) (n,ty,_) -> - (Some (Cic.Name n,(Cic.Decl (CicSubstitution.lift len ty)))::types, - len+1) - ) ([],0) fl - in - let fl' = List.map - (fun (n,ty,bo) -> - let ty' = mk_fresh_names ~subst metasenv context ty in - let bo' = mk_fresh_names ~subst metasenv (tys@context) bo in - (n,ty',bo')) fl in - Cic.CoFix (i, fl') -;; - -(* clean_dummy_dependent_types term *) -(* returns a copy of [term] where every dummy dependent product *) -(* have been replaced with a non-dependent product and where *) -(* dummy let-ins have been removed. *) -let clean_dummy_dependent_types t = - let module C = Cic in - let rec aux k = - function - C.Rel m as t -> t,[k - m] - | C.Var (uri,exp_named_subst) -> - let exp_named_subst',rels = - List.fold_right - (fun (uri,t) (exp_named_subst,rels) -> - let t',rels' = aux k t in - (uri,t')::exp_named_subst, rels' @ rels - ) exp_named_subst ([],[]) - in - C.Var (uri,exp_named_subst'),rels - | C.Meta (i,l) -> - let l',rels = - List.fold_right - (fun t (l,rels) -> - let t',rels' = - match t with - None -> None,[] - | Some t -> - let t',rels' = aux k t in - Some t', rels' - in - t'::l, rels' @ rels - ) l ([],[]) - in - C.Meta(i,l'),rels - | C.Sort _ as t -> t,[] - | C.Implicit _ as t -> t,[] - | C.Cast (te,ty) -> - let te',rels1 = aux k te in - let ty',rels2 = aux k ty in - C.Cast (te', ty'), rels1@rels2 - | C.Prod (n,s,t) -> - let s',rels1 = aux k s in - let t',rels2 = aux (k+1) t in - let n' = - match n with - C.Anonymous -> - if List.mem k rels2 then -( - debug_print (lazy "If this happens often, we can do something about it (i.e. we can generate a new fresh name; problem: we need the metasenv and context ;-(. Alternative solution: mk_implicit does not generate entries for the elements in the context that have no name") ; - C.Anonymous -) - else - C.Anonymous - | C.Name _ as n -> - if List.mem k rels2 then n else C.Anonymous - in - C.Prod (n', s', t'), rels1@rels2 - | C.Lambda (n,s,t) -> - let s',rels1 = aux k s in - let t',rels2 = aux (k+1) t in - C.Lambda (n, s', t'), rels1@rels2 - | C.LetIn (n,s,ty,t) -> - let s',rels1 = aux k s in - let ty',rels2 = aux k ty in - let t',rels3 = aux (k+1) t in - let rels = rels1 @ rels2 @ rels3 in - if List.mem k rels3 then - C.LetIn (n, s', ty', t'), rels - else - (* (C.Rel 1) is just a dummy term; any term would fit *) - CicSubstitution.subst (C.Rel 1) t', rels - | C.Appl l -> - let l',rels = - List.fold_right - (fun t (exp_named_subst,rels) -> - let t',rels' = aux k t in - t'::exp_named_subst, rels' @ rels - ) l ([],[]) - in - C.Appl l', rels - | C.Const (uri,exp_named_subst) -> - let exp_named_subst',rels = - List.fold_right - (fun (uri,t) (exp_named_subst,rels) -> - let t',rels' = aux k t in - (uri,t')::exp_named_subst, rels' @ rels - ) exp_named_subst ([],[]) - in - C.Const (uri,exp_named_subst'),rels - | C.MutInd (uri,tyno,exp_named_subst) -> - let exp_named_subst',rels = - List.fold_right - (fun (uri,t) (exp_named_subst,rels) -> - let t',rels' = aux k t in - (uri,t')::exp_named_subst, rels' @ rels - ) exp_named_subst ([],[]) - in - C.MutInd (uri,tyno,exp_named_subst'),rels - | C.MutConstruct (uri,tyno,consno,exp_named_subst) -> - let exp_named_subst',rels = - List.fold_right - (fun (uri,t) (exp_named_subst,rels) -> - let t',rels' = aux k t in - (uri,t')::exp_named_subst, rels' @ rels - ) exp_named_subst ([],[]) - in - C.MutConstruct (uri,tyno,consno,exp_named_subst'),rels - | C.MutCase (sp,i,outty,t,pl) -> - let outty',rels1 = aux k outty in - let t',rels2 = aux k t in - let pl',rels3 = - List.fold_right - (fun t (exp_named_subst,rels) -> - let t',rels' = aux k t in - t'::exp_named_subst, rels' @ rels - ) pl ([],[]) - in - C.MutCase (sp, i, outty', t', pl'), rels1 @ rels2 @rels3 - | C.Fix (i, fl) -> - let len = List.length fl in - let fl',rels = - List.fold_right - (fun (name,i,ty,bo) (fl,rels) -> - let ty',rels1 = aux k ty in - let bo',rels2 = aux (k + len) bo in - (name,i,ty',bo')::fl, rels1 @ rels2 @ rels - ) fl ([],[]) - in - C.Fix (i, fl'),rels - | C.CoFix (i, fl) -> - let len = List.length fl in - let fl',rels = - List.fold_right - (fun (name,ty,bo) (fl,rels) -> - let ty',rels1 = aux k ty in - let bo',rels2 = aux (k + len) bo in - (name,ty',bo')::fl, rels1 @ rels2 @ rels - ) fl ([],[]) - in - C.CoFix (i, fl'),rels - in - fst (aux 0 t) -;; diff --git a/matita/components/cic_proof_checking/freshNamesGenerator.mli b/matita/components/cic_proof_checking/freshNamesGenerator.mli deleted file mode 100644 index b90c0f2f5..000000000 --- a/matita/components/cic_proof_checking/freshNamesGenerator.mli +++ /dev/null @@ -1,46 +0,0 @@ -(* Copyright (C) 2004, 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/. - *) - -(* mk_fresh_name metasenv context name typ *) -(* returns an identifier which is fresh in the context *) -(* and that resembles [name] as much as possible. *) -(* [typ] will be the type of the variable *) -val mk_fresh_name : - subst:Cic.substitution -> - Cic.metasenv -> Cic.context -> Cic.name -> typ:Cic.term -> Cic.name - -(* mk_fresh_names metasenv context term *) -(* returns a term t' convertible with term where all *) -(* matita_dummies have been replaced by fresh names *) - -val mk_fresh_names : - subst:Cic.substitution -> - Cic.metasenv -> Cic.context -> Cic.term -> Cic.term - -(* clean_dummy_dependent_types term *) -(* returns a copy of [term] where every dummy dependent product *) -(* have been replaced with a non-dependent product and where *) -(* dummy let-ins have been removed. *) -val clean_dummy_dependent_types : Cic.term -> Cic.term diff --git a/matita/components/content_pres/content2pres.ml b/matita/components/content_pres/content2pres.ml index 05e4ae3cb..617c9ddca 100644 --- a/matita/components/content_pres/content2pres.ml +++ b/matita/components/content_pres/content2pres.ml @@ -897,20 +897,6 @@ let params2pres params = let params = spatiate (List.map param2pres p) in [B.b_space; B.b_h [] (B.b_text [] "[" :: params @ [ B.b_text [] "]" ])] - -let recursion_kind2pres params kind = - let kind = - match kind with - | `Recursive _ -> "Recursive definition" - | `CoRecursive -> "CoRecursive definition" - | `Inductive i -> - "Inductive definition with "^string_of_int i^" fixed parameter(s)" - | `CoInductive i -> - "Co-Inductive definition with "^string_of_int i^" fixed parameter(s)" - in - B.b_h [] (B.b_kw kind :: params2pres params) -;; - let inductive2pres term2pres ind = let constructor2pres decl = B.b_h [] [ @@ -970,12 +956,6 @@ let definition2pres ?recno term2pres d = B.b_h [] [B.b_space;term2pres body] ] ;; -let joint_def2pres ?recno term2pres def = - match def with - | `Inductive ind -> inductive2pres term2pres ind - | _ -> assert false -;; - let njoint_def2pres ?recno term2pres def = match def with | `Inductive ind -> inductive2pres term2pres ind @@ -1012,63 +992,6 @@ let njoint_def2pres term2pres joint_kind defs = (List.map (njoint_def2pres term2pres) defs))) ;; -let content2pres0 - ?skip_initial_lambdas ?(skip_thm_and_qed=false) term2pres - (id,params,metasenv,obj) -= - match obj with - | `Def (Content.Const, thesis, `Proof p) -> - let name = get_name p.Content.proof_name in - let proof = proof2pres true term2pres ?skip_initial_lambdas p in - if skip_thm_and_qed then - proof - else - B.b_v - [Some "helm","xref","id"] - ([ B.b_h [] (B.b_kw ("theorem " ^ name) :: - params2pres params @ [B.b_kw ":"]); - B.H ([],[B.indent (term2pres thesis) ; B.b_kw "." ])] @ - metasenv2pres term2pres metasenv @ - [proof ; B.b_kw "qed."]) - | `Def (_, ty, `Definition body) -> - let name = get_name body.Content.def_name in - B.b_v - [Some "helm","xref","id"] - ([B.b_h [] - (B.b_kw ("definition " ^ name) :: params2pres params @ [B.b_kw ":"]); - B.indent (term2pres ty)] @ - metasenv2pres term2pres metasenv @ - [B.b_kw ":="; - B.indent (term2pres body.Content.def_term); - B.b_kw "."]) - | `Decl (_, `Declaration decl) - | `Decl (_, `Hypothesis decl) -> - let name = get_name decl.Content.dec_name in - B.b_v - [Some "helm","xref","id"] - ([B.b_h [] (B.b_kw ("axiom " ^ name) :: params2pres params); - B.b_kw "Type:"; - B.indent (term2pres decl.Content.dec_type)] @ - metasenv2pres term2pres metasenv) - | `Joint joint -> - B.b_v [] - (recursion_kind2pres params joint.Content.joint_kind - :: List.map (joint_def2pres term2pres) joint.Content.joint_defs) - | _ -> raise ToDo - -let content2pres - ?skip_initial_lambdas ?skip_thm_and_qed ~ids_to_inner_sorts -= - content2pres0 ?skip_initial_lambdas ?skip_thm_and_qed - (fun ?(prec=90) annterm -> - let ast, ids_to_uris = - TermAcicContent.ast_of_acic ~output_type:`Term ids_to_inner_sorts annterm - in - CicNotationPres.box_of_mpres - (CicNotationPres.render - ~lookup_uri:(CicNotationPres.lookup_uri ids_to_uris) ~prec - (TermContentPres.pp_ast ast))) - let ncontent2pres0 ?skip_initial_lambdas ?(skip_thm_and_qed=false) term2pres (id,params,metasenv,obj : CicNotationPt.term Content.cobj) diff --git a/matita/components/content_pres/content2pres.mli b/matita/components/content_pres/content2pres.mli index db2223a7a..57e75a978 100644 --- a/matita/components/content_pres/content2pres.mli +++ b/matita/components/content_pres/content2pres.mli @@ -32,12 +32,6 @@ (* *) (**************************************************************************) -val content2pres: - ?skip_initial_lambdas:int -> ?skip_thm_and_qed:bool -> - ids_to_inner_sorts:(Cic.id, CicNotationPt.sort_kind) Hashtbl.t -> - Cic.annterm Content.cobj -> - CicNotationPres.boxml_markup - val ncontent2pres: ?skip_initial_lambdas:int -> ?skip_thm_and_qed:bool -> ids_to_nrefs:(NTermCicContent.id, NReference.reference) Hashtbl.t -> diff --git a/matita/components/content_pres/sequent2pres.ml b/matita/components/content_pres/sequent2pres.ml index 549f5c7c5..7951dbf5d 100644 --- a/matita/components/content_pres/sequent2pres.ml +++ b/matita/components/content_pres/sequent2pres.ml @@ -95,17 +95,6 @@ let sequent2pres0 term2pres (_,_,context,ty) = Box.b_space; pres_goal]))]) -let sequent2pres ~ids_to_inner_sorts = - sequent2pres0 - (fun annterm -> - let ast, ids_to_uris = - TermAcicContent.ast_of_acic ~output_type:`Term ids_to_inner_sorts annterm - in - CicNotationPres.box_of_mpres - (CicNotationPres.render - ~lookup_uri:(CicNotationPres.lookup_uri ids_to_uris) - (TermContentPres.pp_ast ast))) - let nsequent2pres ~ids_to_nrefs ~subst = let lookup_uri id = try diff --git a/matita/components/content_pres/sequent2pres.mli b/matita/components/content_pres/sequent2pres.mli index a19e7b195..38570ba64 100644 --- a/matita/components/content_pres/sequent2pres.mli +++ b/matita/components/content_pres/sequent2pres.mli @@ -32,11 +32,6 @@ (* *) (***************************************************************************) -val sequent2pres : - ids_to_inner_sorts:(Cic.id, CicNotationPt.sort_kind) Hashtbl.t -> - Cic.annterm Content.conjecture -> - CicNotationPres.boxml_markup - val nsequent2pres : ids_to_nrefs:(NTermCicContent.id, NReference.reference) Hashtbl.t -> subst:NCic.substitution -> CicNotationPt.term Content.conjecture -> diff --git a/matita/components/grafite_engine/grafiteEngine.ml b/matita/components/grafite_engine/grafiteEngine.ml index 23e713915..a12a246aa 100644 --- a/matita/components/grafite_engine/grafiteEngine.ml +++ b/matita/components/grafite_engine/grafiteEngine.ml @@ -44,22 +44,6 @@ let concat_nuris uris nuris = | `New uris, `New nuris -> `New (nuris@uris) | _ -> assert false ;; -(** create a ProofEngineTypes.mk_fresh_name_type function which uses given - * names as long as they are available, then it fallbacks to name generation - * using FreshNamesGenerator module *) -let namer_of names = - let len = List.length names in - let count = ref 0 in - fun metasenv context name ~typ -> - if !count < len then begin - let name = match List.nth names !count with - | Some s -> Cic.Name s - | None -> Cic.Anonymous - in - incr count; - name - end else - FreshNamesGenerator.mk_fresh_name ~subst:[] metasenv context name ~typ type eval_ast = {ea_go: @@ -302,7 +286,7 @@ let eval_add_constraint status u1 u2 = let status = basic_eval_add_constraint (u1,u2) status in let dump = inject_constraint (u1,u2)::status#dump in let status = status#set_dump dump in - status,`Old [] + status,`New [] ;; let add_coercions_of_lemmas lemmas status = @@ -686,7 +670,7 @@ let rec eval_command = {ec_go = fun ~disambiguate_command opts status match cmd with | GrafiteAst.Default (loc, what, uris) as cmd -> LibraryObjects.set_default what uris; - GrafiteTypes.add_moo_content [cmd] status,`Old [] + GrafiteTypes.add_moo_content [cmd] status,`New [] | GrafiteAst.Drop loc -> raise Drop | GrafiteAst.Include (loc, mode, new_or_old, baseuri) -> (* Old Include command is not recursive; new one is *) @@ -713,9 +697,9 @@ let rec eval_command = {ec_go = fun ~disambiguate_command opts status GrafiteTypes.add_moo_content [GrafiteAst.Include (loc,mode,`New,baseuri)] status in - status,`Old [] - | GrafiteAst.Print (_,_) -> status,`Old [] - | GrafiteAst.Set (loc, name, value) -> status, `Old [] + status,`New [] + | GrafiteAst.Print (_,_) -> status,`New [] + | GrafiteAst.Set (loc, name, value) -> status, `New [] (* GrafiteTypes.set_option status name value,[] *) | GrafiteAst.Obj (loc,obj) -> (* MATITA 1.0 *) assert false in @@ -761,7 +745,7 @@ let rec eval_command = {ec_go = fun ~disambiguate_command opts status ~disambiguate_macro:(fun _ _ -> assert false) status ast in - assert (lemmas=`Old []); + assert (lemmas=`New []); status) status moo } and eval_ast = {ea_go = fun ~disambiguate_command @@ -776,7 +760,7 @@ let rec eval_command = {ec_go = fun ~disambiguate_command opts status | GrafiteAst.Comment (_,c) -> eval_comment.ecm_go ~disambiguate_command opts status (text,prefix_len,c) } and eval_comment = { ecm_go = fun ~disambiguate_command opts status (text,prefix_len,c) -> - status, `Old [] + status, `New [] } ;; diff --git a/matita/components/grafite_engine/grafiteSync.ml b/matita/components/grafite_engine/grafiteSync.ml index 33ec596f5..8e925db62 100644 --- a/matita/components/grafite_engine/grafiteSync.ml +++ b/matita/components/grafite_engine/grafiteSync.ml @@ -55,23 +55,6 @@ let uris_for_inductive_type uri obj = | _ -> [uri] ;; -let is_equational_fact ty = - let rec aux ctx t = - match CicReduction.whd ctx t with - | Cic.Prod (name,src,tgt) -> - let s,u = - CicTypeChecker.type_of_aux' [] ctx src CicUniv.oblivion_ugraph - in - if fst (CicReduction.are_convertible ctx s (Cic.Sort Cic.Prop) u) then - false - else - aux (Some (name,Cic.Decl src)::ctx) tgt - | Cic.Appl [ Cic.MutInd (u,_,_) ; _; _; _] -> LibraryObjects.is_eq_URI u - | _ -> false - in - aux [] ty -;; - let add_coercion ~pack_coercion_obj ~add_composites status uri arity saturations baseuri = diff --git a/matita/components/grafite_parser/grafiteDisambiguate.ml b/matita/components/grafite_parser/grafiteDisambiguate.ml index 330a93a0d..af8c86204 100644 --- a/matita/components/grafite_parser/grafiteDisambiguate.ml +++ b/matita/components/grafite_parser/grafiteDisambiguate.ml @@ -71,13 +71,8 @@ let ncic_mk_choice = function | LexiconAst.Ident_alias (name, uri) -> uri, `Sym_interp (fun l->assert(l = []); - try - let nref = NReference.reference_of_string uri in - NCic.Const nref - with - NReference.IllFormedReference _ -> - let uri = UriManager.uri_of_string uri in - fst (OCic2NCic.convert_term uri (CicUtil.term_of_uri uri))) + let nref = NReference.reference_of_string uri in + NCic.Const nref) ;; @@ -203,7 +198,7 @@ let disambiguate_nobj estatus ?baseuri (text,prefix_len,obj) = | CicNotationPt.Theorem (_,name,_,_,_) -> name ^ ".con" | CicNotationPt.Inductive _ -> assert false in - UriManager.uri_of_string (baseuri ^ "/" ^ name) + NUri.uri_of_string (baseuri ^ "/" ^ name) in let diff, _, _, cic = singleton "third" @@ -212,7 +207,7 @@ let disambiguate_nobj estatus ?baseuri (text,prefix_len,obj) = ~description_of_alias:LexiconAst.description_of_alias ~mk_choice:ncic_mk_choice ~mk_implicit ~fix_instance - ~uri:(OCic2NCic.nuri_of_ouri uri) + ~uri ~rdb:estatus ~aliases:estatus#lstatus.LexiconEngine.aliases ~universe:(Some estatus#lstatus.LexiconEngine.multi_aliases) diff --git a/matita/components/lexicon/lexiconSync.ml b/matita/components/lexicon/lexiconSync.ml index c82caf337..325a8d837 100644 --- a/matita/components/lexicon/lexiconSync.ml +++ b/matita/components/lexicon/lexiconSync.ml @@ -82,13 +82,9 @@ let add_aliases_for_object status uri = | Cic.CurrentProof _ -> assert false let add_aliases_for_objs status = - function - `Old uris -> - List.fold_left - (fun status uri -> - let obj,_ = CicEnvironment.get_obj CicUniv.oblivion_ugraph uri in - add_aliases_for_object status uri obj) status uris - | `New nrefs -> + function + `Old _ -> assert false (* MATITA 1.0 *) + | `New nrefs -> List.fold_left (fun status nref -> let references = NCicLibrary.aliases_of nref in diff --git a/matita/components/library/Makefile b/matita/components/library/Makefile index 5b9dc226f..10f52c680 100644 --- a/matita/components/library/Makefile +++ b/matita/components/library/Makefile @@ -8,8 +8,6 @@ INTERFACE_FILES = \ coercDb.mli \ cicCoercion.mli \ librarySync.mli \ - cicElim.mli \ - cicRecord.mli \ cicFix.mli \ libraryClean.mli \ $(NULL) diff --git a/matita/components/library/cicElim.ml b/matita/components/library/cicElim.ml deleted file mode 100644 index 9f3bda423..000000000 --- a/matita/components/library/cicElim.ml +++ /dev/null @@ -1,461 +0,0 @@ -(* Copyright (C) 2004, 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$ *) - -open Printf - -exception Elim_failure of string Lazy.t -exception Can_t_eliminate - -let debug_print = fun _ -> () -(*let debug_print s = prerr_endline (Lazy.force s) *) - -let counter = ref ~-1 ;; - -let fresh_binder () = Cic.Name "matita_dummy" -(* - incr counter; - Cic.Name ("e" ^ string_of_int !counter) *) - - (** verifies if a given inductive type occurs in a term in target position *) -let rec recursive uri typeno = function - | Cic.Prod (_, _, target) -> recursive uri typeno target - | Cic.MutInd (uri', typeno', []) - | Cic.Appl (Cic.MutInd (uri', typeno', []) :: _) -> - UriManager.eq uri uri' && typeno = typeno' - | _ -> false - - (** given a list of constructor types, return true if at least one of them is - * recursive, false otherwise *) -let recursive_type uri typeno constructors = - let rec aux = function - | Cic.Prod (_, src, tgt) -> recursive uri typeno src || aux tgt - | _ -> false - in - List.exists (fun (_, ty) -> aux ty) constructors - -let unfold_appl = function - | Cic.Appl ((Cic.Appl args) :: tl) -> Cic.Appl (args @ tl) - | t -> t - -let rec split l n = - match (l,n) with - (l,0) -> ([], l) - | (he::tl, n) -> let (l1,l2) = split tl (n-1) in (he::l1,l2) - | (_,_) -> assert false - - (** build elimination principle part related to a single constructor - * @param paramsno number of Prod to ignore in this constructor (i.e. number of - * inductive parameters) - * @param dependent true if we are in the dependent case (i.e. sort <> Prop) *) -let rec delta (uri, typeno) dependent paramsno consno t p args = - match t with - | Cic.MutInd (uri', typeno', []) when - UriManager.eq uri uri' && typeno = typeno' -> - if dependent then - (match args with - | [] -> assert false - | [arg] -> unfold_appl (Cic.Appl [p; arg]) - | _ -> unfold_appl (Cic.Appl [p; unfold_appl (Cic.Appl args)])) - else - p - | Cic.Appl (Cic.MutInd (uri', typeno', []) :: tl) when - UriManager.eq uri uri' && typeno = typeno' -> - let (lparams, rparams) = split tl paramsno in - if dependent then - (match args with - | [] -> assert false - | [arg] -> unfold_appl (Cic.Appl (p :: rparams @ [arg])) - | _ -> - unfold_appl (Cic.Appl (p :: - rparams @ [unfold_appl (Cic.Appl args)]))) - else (* non dependent *) - (match rparams with - | [] -> p - | _ -> Cic.Appl (p :: rparams)) - | Cic.Prod (binder, src, tgt) -> - if recursive uri typeno src then - let args = List.map (CicSubstitution.lift 2) args in - let phi = - let src = CicSubstitution.lift 1 src in - delta (uri, typeno) dependent paramsno consno src - (CicSubstitution.lift 1 p) [Cic.Rel 1] - in - let tgt = CicSubstitution.lift 1 tgt in - Cic.Prod (fresh_binder (), src, - Cic.Prod (Cic.Anonymous, phi, - delta (uri, typeno) dependent paramsno consno tgt - (CicSubstitution.lift 2 p) (args @ [Cic.Rel 2]))) - else (* non recursive *) - let args = List.map (CicSubstitution.lift 1) args in - Cic.Prod (fresh_binder (), src, - delta (uri, typeno) dependent paramsno consno tgt - (CicSubstitution.lift 1 p) (args @ [Cic.Rel 1])) - | _ -> assert false - -let rec strip_left_params consno leftno = function - | t when leftno = 0 -> t (* no need to lift, the term is (hopefully) closed *) - | Cic.Prod (_, _, tgt) (* when leftno > 0 *) -> - (* after stripping the parameters we lift of consno. consno is 1 based so, - * the first constructor will be lifted by 1 (for P), the second by 2 (1 - * for P and 1 for the 1st constructor), and so on *) - if leftno = 1 then - CicSubstitution.lift consno tgt - else - strip_left_params consno (leftno - 1) tgt - | _ -> assert false - -let delta (ury, typeno) dependent paramsno consno t p args = - let t = strip_left_params consno paramsno t in - delta (ury, typeno) dependent paramsno consno t p args - -let rec add_params binder indno ty eliminator = - if indno = 0 then - eliminator - else - match ty with - | Cic.Prod (name, src, tgt) -> - let name = - match name with - Cic.Name _ -> name - | Cic.Anonymous -> fresh_binder () - in - binder name src (add_params binder (indno - 1) tgt eliminator) - | _ -> assert false - -let rec mk_rels consno = function - | 0 -> [] - | n -> Cic.Rel (n+consno) :: mk_rels consno (n-1) - -let rec strip_pi ctx t = - match CicReduction.whd ~delta:true ctx t with - | Cic.Prod (n, s, tgt) -> strip_pi (Some (n,Cic.Decl s) :: ctx) tgt - | t -> t - -let strip_pi t = strip_pi [] t - -let rec count_pi ctx t = - match CicReduction.whd ~delta:true ctx t with - | Cic.Prod (n, s, tgt) -> count_pi (Some (n,Cic.Decl s)::ctx) tgt + 1 - | t -> 0 - -let count_pi t = count_pi [] t - -let rec type_of_p sort dependent leftno indty = function - | Cic.Prod (n, src, tgt) when leftno = 0 -> - let n = - if dependent then - match n with - Cic.Name _ -> n - | Cic.Anonymous -> fresh_binder () - else - n - in - Cic.Prod (n, src, type_of_p sort dependent leftno indty tgt) - | Cic.Prod (_, _, tgt) -> type_of_p sort dependent (leftno - 1) indty tgt - | t -> - if dependent then - Cic.Prod (Cic.Anonymous, indty, Cic.Sort sort) - else - Cic.Sort sort - -let rec add_right_pi dependent strip liftno liftfrom rightno indty = function - | Cic.Prod (_, src, tgt) when strip = 0 -> - Cic.Prod (fresh_binder (), - CicSubstitution.lift_from liftfrom liftno src, - add_right_pi dependent strip liftno (liftfrom + 1) rightno indty tgt) - | Cic.Prod (_, _, tgt) -> - add_right_pi dependent (strip - 1) liftno liftfrom rightno indty tgt - | t -> - if dependent then - Cic.Prod (fresh_binder (), - CicSubstitution.lift_from (rightno + 1) liftno indty, - Cic.Appl (Cic.Rel (1 + liftno + rightno) :: mk_rels 0 (rightno + 1))) - else - Cic.Prod (Cic.Anonymous, - CicSubstitution.lift_from (rightno + 1) liftno indty, - if rightno = 0 then - Cic.Rel (1 + liftno + rightno) - else - Cic.Appl (Cic.Rel (1 + liftno + rightno) :: mk_rels 1 rightno)) - -let rec add_right_lambda dependent strip liftno liftfrom rightno indty case = -function - | Cic.Prod (_, src, tgt) when strip = 0 -> - Cic.Lambda (fresh_binder (), - CicSubstitution.lift_from liftfrom liftno src, - add_right_lambda dependent strip liftno (liftfrom + 1) rightno indty - case tgt) - | Cic.Prod (_, _, tgt) -> - add_right_lambda true (strip - 1) liftno liftfrom rightno indty - case tgt - | t -> - Cic.Lambda (fresh_binder (), - CicSubstitution.lift_from (rightno + 1) liftno indty, case) - -let rec branch (uri, typeno) insource paramsno t fix head args = - match t with - | Cic.MutInd (uri', typeno', []) when - UriManager.eq uri uri' && typeno = typeno' -> - if insource then - (match args with - | [arg] -> Cic.Appl (fix :: args) - | _ -> Cic.Appl (fix :: [Cic.Appl args])) - else - (match args with - | [] -> head - | _ -> Cic.Appl (head :: args)) - | Cic.Appl (Cic.MutInd (uri', typeno', []) :: tl) when - UriManager.eq uri uri' && typeno = typeno' -> - if insource then - let (lparams, rparams) = split tl paramsno in - match args with - | [arg] -> Cic.Appl (fix :: rparams @ args) - | _ -> Cic.Appl (fix :: rparams @ [Cic.Appl args]) - else - (match args with - | [] -> head - | _ -> Cic.Appl (head :: args)) - | Cic.Prod (binder, src, tgt) -> - if recursive uri typeno src then - let args = List.map (CicSubstitution.lift 1) args in - let phi = - let fix = CicSubstitution.lift 1 fix in - let src = CicSubstitution.lift 1 src in - branch (uri, typeno) true paramsno src fix head [Cic.Rel 1] - in - Cic.Lambda (fresh_binder (), src, - branch (uri, typeno) insource paramsno tgt - (CicSubstitution.lift 1 fix) (CicSubstitution.lift 1 head) - (args @ [Cic.Rel 1; phi])) - else (* non recursive *) - let args = List.map (CicSubstitution.lift 1) args in - Cic.Lambda (fresh_binder (), src, - branch (uri, typeno) insource paramsno tgt - (CicSubstitution.lift 1 fix) (CicSubstitution.lift 1 head) - (args @ [Cic.Rel 1])) - | _ -> assert false - -let branch (uri, typeno) insource liftno paramsno t fix head args = - let t = strip_left_params liftno paramsno t in - branch (uri, typeno) insource paramsno t fix head args - -let elim_of ~sort uri typeno = - counter := ~-1; - let (obj, univ) = (CicEnvironment.get_obj CicUniv.oblivion_ugraph uri) in - match obj with - | Cic.InductiveDefinition (indTypes, params, leftno, _) -> - let (name, inductive, ty, constructors) = - try - List.nth indTypes typeno - with Failure _ -> assert false - in - let ty = Unshare.unshare ~fresh_univs:true ty in - let constructors = - List.map (fun (name,c)-> name,Unshare.unshare ~fresh_univs:true c) constructors - in - let paramsno = count_pi ty in (* number of (left or right) parameters *) - let rightno = paramsno - leftno in - let dependent = (strip_pi ty <> Cic.Sort Cic.Prop) in - let head = - match strip_pi ty with - Cic.Sort s -> s - | _ -> assert false - in - let conslen = List.length constructors in - let consno = ref (conslen + 1) in - if - not - (CicTypeChecker.check_allowed_sort_elimination uri typeno head sort) - then - raise Can_t_eliminate; - let indty = - let indty = Cic.MutInd (uri, typeno, []) in - if paramsno = 0 then - indty - else - Cic.Appl (indty :: mk_rels 0 paramsno) - in - let mk_constructor consno = - let constructor = Cic.MutConstruct (uri, typeno, consno, []) in - if leftno = 0 then - constructor - else - Cic.Appl (constructor :: mk_rels consno leftno) - in - let p_ty = type_of_p sort dependent leftno indty ty in - let final_ty = - add_right_pi dependent leftno (conslen + 1) 1 rightno indty ty - in - let eliminator_type = - let cic = - Cic.Prod (Cic.Name "P", p_ty, - (List.fold_right - (fun (_, constructor) acc -> - decr consno; - let p = Cic.Rel !consno in - Cic.Prod (Cic.Anonymous, - (delta (uri, typeno) dependent leftno !consno - constructor p [mk_constructor !consno]), - acc)) - constructors final_ty)) - in - add_params (fun b s t -> Cic.Prod (b, s, t)) leftno ty cic - in - let consno = ref (conslen + 1) in - let eliminator_body = - let fix = Cic.Rel (rightno + 2) in - let is_recursive = recursive_type uri typeno constructors in - let recshift = if is_recursive then 1 else 0 in - let (_, branches) = - List.fold_right - (fun (_, ty) (shift, branches) -> - let head = Cic.Rel (rightno + shift + 1 + recshift) in - let b = - branch (uri, typeno) false - (rightno + conslen + 2 + recshift) leftno ty fix head [] - in - (shift + 1, b :: branches)) - constructors (1, []) - in - let shiftno = conslen + rightno + 2 + recshift in - let outtype = - if dependent then - Cic.Rel shiftno - else - let head = - if rightno = 0 then - CicSubstitution.lift 1 (Cic.Rel shiftno) - else - Cic.Appl - ((CicSubstitution.lift (rightno + 1) (Cic.Rel shiftno)) :: - mk_rels 1 rightno) - in - add_right_lambda true leftno shiftno 1 rightno indty head ty - in - let mutcase = - Cic.MutCase (uri, typeno, outtype, Cic.Rel 1, branches) - in - let body = - if is_recursive then - let fixfun = - add_right_lambda dependent leftno (conslen + 2) 1 rightno - indty mutcase ty - in - (* rightno is the decreasing argument, i.e. the argument of - * inductive type *) - Cic.Fix (0, ["aux", rightno, final_ty, fixfun]) - else - add_right_lambda dependent leftno (conslen + 1) 1 rightno indty - mutcase ty - in - let cic = - Cic.Lambda (Cic.Name "P", p_ty, - (List.fold_right - (fun (_, constructor) acc -> - decr consno; - let p = Cic.Rel !consno in - Cic.Lambda (fresh_binder (), - (delta (uri, typeno) dependent leftno !consno - constructor p [mk_constructor !consno]), - acc)) - constructors body)) - in - add_params (fun b s t -> Cic.Lambda (b, s, t)) leftno ty cic - in -(* -debug_print (lazy (CicPp.ppterm eliminator_type)); -debug_print (lazy (CicPp.ppterm eliminator_body)); -*) - let eliminator_type = - FreshNamesGenerator.mk_fresh_names [] [] [] eliminator_type in - let eliminator_body = - FreshNamesGenerator.mk_fresh_names [] [] [] eliminator_body in -(* -debug_print (lazy (CicPp.ppterm eliminator_type)); -debug_print (lazy (CicPp.ppterm eliminator_body)); -*) - let (computed_type, ugraph) = - try - CicTypeChecker.type_of_aux' [] [] eliminator_body - CicUniv.oblivion_ugraph - with CicTypeChecker.TypeCheckerFailure msg -> - raise (Elim_failure (lazy (sprintf - "type checker failure while type checking:\n%s\nerror:\n%s" - (CicPp.ppterm eliminator_body) (Lazy.force msg)))) - in - if not (fst (CicReduction.are_convertible [] - eliminator_type computed_type ugraph)) - then - raise (Failure (sprintf - "internal error: type mismatch on eliminator type\n%s\n%s" - (CicPp.ppterm eliminator_type) (CicPp.ppterm computed_type))); - let suffix = - match sort with - | Cic.Prop -> "_ind" - | Cic.Set -> "_rec" - | Cic.Type _ -> "_rect" - | _ -> assert false - in - (* let name = UriManager.name_of_uri uri ^ suffix in *) - let name = name ^ suffix in - let buri = UriManager.buri_of_uri uri in - let uri = UriManager.uri_of_string (buri ^ "/" ^ name ^ ".con") in - let obj_attrs = [`Class (`Elim sort); `Generated] in - uri, - Cic.Constant (name, Some eliminator_body, eliminator_type, [], obj_attrs) - | _ -> - failwith (sprintf "not an inductive definition (%s)" - (UriManager.string_of_uri uri)) -;; - -let generate_elimination_principles ~add_obj ~add_coercion uri obj = - match obj with - | Cic.InductiveDefinition (indTypes,_,_,attrs) -> - let _,inductive,_,_ = List.hd indTypes in - if not inductive then [] - else - let _,all_eliminators = - List.fold_left - (fun (i,res) _ -> - let elim sort = - try Some (elim_of ~sort uri i) - with Can_t_eliminate -> None - in - i+1, - HExtlib.filter_map - elim [ Cic.Prop; Cic.Set; (Cic.Type (CicUniv.fresh ())) ] @ res - ) (0,[]) indTypes - in - List.fold_left - (fun lemmas (uri,obj) -> add_obj uri obj @ uri::lemmas) - [] all_eliminators - | _ -> [] -;; - - -let init () = - LibrarySync.add_object_declaration_hook generate_elimination_principles;; diff --git a/matita/components/library/cicElim.mli b/matita/components/library/cicElim.mli deleted file mode 100644 index 70c1c2167..000000000 --- a/matita/components/library/cicElim.mli +++ /dev/null @@ -1,29 +0,0 @@ -(* Copyright (C) 2004, 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/ - *) - - (** internal error while generating elimination principle *) -exception Elim_failure of string Lazy.t - -val init : unit -> unit diff --git a/matita/components/library/cicRecord.ml b/matita/components/library/cicRecord.ml deleted file mode 100644 index e76ca9ca2..000000000 --- a/matita/components/library/cicRecord.ml +++ /dev/null @@ -1,135 +0,0 @@ -(* Copyright (C) 2004-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/ - *) - -(* $Id$ *) - -let rec_ty uri leftno = - let rec_ty = Cic.MutInd (uri,0,[]) in - if leftno = 0 then rec_ty else - Cic.Appl (rec_ty :: (CicUtil.mk_rels leftno 0)) - -let generate_one_proj uri params paramsno fields t i = - let mk_lambdas l start = - List.fold_right (fun (name,ty) acc -> - Cic.Lambda (Cic.Name name,ty,acc)) l start in - let recty = rec_ty uri paramsno in - let outtype = Cic.Lambda (Cic.Name "w'", CicSubstitution.lift 1 recty, t) in - (mk_lambdas params - (Cic.Lambda (Cic.Name "w", recty, - Cic.MutCase (uri,0,outtype, Cic.Rel 1, - [mk_lambdas fields (Cic.Rel i)])))) - -let projections_of uri field_names = - let buri = UriManager.buri_of_uri uri in - let obj,ugraph = CicEnvironment.get_cooked_obj CicUniv.oblivion_ugraph uri in - match obj with - Cic.InductiveDefinition ([_,_,sort,[_,ty]],params,paramsno,_) -> - assert (params = []); (* general case not implemented *) - let leftparams,ty = - let rec aux = - function - 0,ty -> [],ty - | n,Cic.Prod (Cic.Name name,s,t) -> - let leftparams,ty = aux (n - 1,t) in - (name,s)::leftparams,ty - | _,_ -> assert false - in - aux (paramsno,ty) - in - let fields = - let rec aux = - function - Cic.MutInd _, [] - | Cic.Appl _, [] -> [] - | Cic.Prod (_,s,t), name::tl -> (name,s)::aux (t,tl) - | _,_ -> assert false - in - aux ((CicSubstitution.lift 1 ty),field_names) - in - let rec aux i = - function - Cic.MutInd _, [] - | Cic.Appl _, [] -> [] - | Cic.Prod (_,s,t), name::tl -> - let p = generate_one_proj uri leftparams paramsno fields s i in - let puri = UriManager.uri_of_string (buri ^ "/" ^ name ^ ".con") in - (puri,name,p) :: - aux (i - 1) - (CicSubstitution.subst - (Cic.Appl - (Cic.Const (puri,[]) :: - CicUtil.mk_rels paramsno 2 @ [Cic.Rel 1]) - ) t, tl) - | _,_ -> assert false - in - aux (List.length fields) (CicSubstitution.lift 2 ty,field_names) - | _ -> assert false -;; - -let generate_projections ~add_obj ~add_coercion (uri as orig_uri) obj = - match obj with - | Cic.InductiveDefinition (inductivefuns,_,_,attrs) -> - let rec get_record_attrs = - function - | [] -> None - | (`Class (`Record fields))::_ -> Some fields - | _::tl -> get_record_attrs tl - in - (match get_record_attrs attrs with - | None -> [] - | Some fields -> - let uris = ref [] in - let projections = - projections_of uri (List.map (fun (x,_,_) -> x) fields) - in - List.iter2 - (fun (uri, name, bo) (_name, coercion, arity) -> - try - let ty, _ = - CicTypeChecker.type_of_aux' [] [] bo CicUniv.oblivion_ugraph in - let attrs = [`Class `Projection; `Generated] in - let obj = Cic.Constant (name,Some bo,ty,[],attrs) in - let lemmas = add_obj uri obj in - let lemmas1 = - if not coercion then [] else - add_coercion uri arity 0 (UriManager.buri_of_uri orig_uri) - in - uris := lemmas1 @ lemmas @ uri::!uris - with - CicTypeChecker.TypeCheckerFailure s -> - HLog.message ("Unable to create projection " ^ name ^ - " cause: " ^ Lazy.force s); - | CicEnvironment.Object_not_found uri -> - let depend = UriManager.name_of_uri uri in - HLog.message ("Unable to create projection " ^ name ^ - " because it requires " ^ depend) - ) projections fields; - !uris) - | _ -> [] -;; - - -let init () = - LibrarySync.add_object_declaration_hook generate_projections;; diff --git a/matita/components/library/cicRecord.mli b/matita/components/library/cicRecord.mli deleted file mode 100644 index de361cc7c..000000000 --- a/matita/components/library/cicRecord.mli +++ /dev/null @@ -1,26 +0,0 @@ -(* Copyright (C) 2004-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/ - *) - -val init : unit -> unit diff --git a/matita/components/library/coercDb.ml b/matita/components/library/coercDb.ml index b7e390229..0bd9461ca 100644 --- a/matita/components/library/coercDb.ml +++ b/matita/components/library/coercDb.ml @@ -70,6 +70,7 @@ let string_of_carr = function ;; let eq_carr ?(exact=false) src tgt = + assert false (* MATITA 1.0 match src, tgt with | Uri src, Uri tgt -> let coarse_eq = UriManager.eq src tgt in @@ -83,6 +84,7 @@ let eq_carr ?(exact=false) src tgt = | Fun _,Fun _ when not exact -> true (* only one Funclass *) | Fun i,Fun j when i = j -> true (* only one Funclass *) | _, _ -> false + *) ;; let to_list db = diff --git a/matita/components/library/libraryClean.ml b/matita/components/library/libraryClean.ml index 8e9f430ba..c3eb8919f 100644 --- a/matita/components/library/libraryClean.ml +++ b/matita/components/library/libraryClean.ml @@ -46,6 +46,7 @@ let safe_buri_of_suri suri = UM.IllFormedUri _ -> suri let one_step_depend cache_of_processed_baseuri suri dbtype dbd = + assert false (* MATITA 1.0 let buri = safe_buri_of_suri suri in if Hashtbl.mem cache_of_processed_baseuri buri then [] @@ -90,8 +91,10 @@ let one_step_depend cache_of_processed_baseuri suri dbtype dbd = with exn -> raise exn (* no errors should be accepted *) end + *) let db_uris_of_baseuri buri = + [] (* MATITA 1.0 let dbd = LibraryDb.instance () in let dbtype = if Helm_registry.get_bool "matita.system" then HSql.Library else HSql.User @@ -122,6 +125,7 @@ let db_uris_of_baseuri buri = HExtlib.list_uniq l with exn -> raise exn (* no errors should be accepted *) + *) ;; let close_uri_list cache_of_processed_baseuri uri_to_remove = @@ -214,6 +218,7 @@ let moo_root_dir = lazy ( ;; let clean_baseuris ?(verbose=true) buris = + prerr_endline "CLEAN_BASEURIS to be removed MATITA 1.0"; (* MATITA 1.0 let cache_of_processed_baseuri = Hashtbl.create 1024 in let dbd = LibraryDb.instance () in let dbtype = @@ -273,3 +278,4 @@ let clean_baseuris ?(verbose=true) buris = MetadataTypes.count_tbl()] end end + *) diff --git a/matita/components/library/libraryDb.ml b/matita/components/library/libraryDb.ml index e82e91f97..34ad77077 100644 --- a/matita/components/library/libraryDb.ml +++ b/matita/components/library/libraryDb.ml @@ -60,7 +60,7 @@ let instance = let xpointer_RE = Pcre.regexp "#.*$" let file_scheme_RE = Pcre.regexp "^file://" -let clean_owner_environment () = +let clean_owner_environment () = assert false (* MATITA 1.0 let dbd = instance () in let obj_tbl = MetadataTypes.obj_tbl () in let sort_tbl = MetadataTypes.sort_tbl () in @@ -107,9 +107,10 @@ let clean_owner_environment () = | HSql.No_such_index -> () | _ -> raise exn ) statements; + *) ;; -let create_owner_environment () = +let create_owner_environment () = () (* MATITA 1.0 let dbd = instance () in let obj_tbl = MetadataTypes.obj_tbl () in let sort_tbl = MetadataTypes.sort_tbl () in @@ -151,6 +152,7 @@ let create_owner_environment () = raise exc | _ -> ()) statements + *) ;; (* removes uri from the ownerized tables, and returns the list of other objects @@ -159,7 +161,7 @@ let create_owner_environment () = * contain all defined objects. but to double check we do not garbage the * metadata... *) -let remove_uri uri = +let remove_uri uri = assert false (* MATITA 1.0 let obj_tbl = MetadataTypes.obj_tbl () in let sort_tbl = MetadataTypes.sort_tbl () in let rel_tbl = MetadataTypes.rel_tbl () in @@ -188,9 +190,10 @@ let remove_uri uri = exn -> raise exn (* no errors should be accepted *) ) [obj_tbl;sort_tbl;rel_tbl;name_tbl;(*conclno_tbl;conclno_hyp_tbl*)count_tbl]; + *) ;; -let xpointers_of_ind uri = +let xpointers_of_ind uri = assert false (* MATITA 1.0 let dbd = instance () in let name_tbl = MetadataTypes.name_tbl () in let dbtype = @@ -209,4 +212,4 @@ let xpointers_of_ind uri = let l = ref [] in HSql.iter rc (fun a -> match a.(0) with None ->()|Some a -> l := a:: !l); List.map UriManager.uri_of_string !l - +*) diff --git a/matita/components/library/librarySync.ml b/matita/components/library/librarySync.ml index 185ae5315..0eeef7d78 100644 --- a/matita/components/library/librarySync.ml +++ b/matita/components/library/librarySync.ml @@ -74,6 +74,7 @@ let paths_and_uris_of_obj uri = xmlunivgraphpath, univgraphuri let save_object_to_disk uri obj ugraph univlist = + assert false (* let write f x = if not (Helm_registry.get_opt_default Helm_registry.bool "matita.nodisk" ~default:false) @@ -135,18 +136,25 @@ let save_object_to_disk uri obj ugraph univlist = write (Xml.pp ~gzip:true bodyxml) (Some xmlbodypath); [bodyuri, xmlbodypath] | _-> assert false) + *) let typecheck_obj = let profiler = HExtlib.profile "add_obj.typecheck_obj" in - fun uri obj -> profiler.HExtlib.profile (CicTypeChecker.typecheck_obj uri) obj + fun uri obj -> + assert false (* MATITA 1.0 + profiler.HExtlib.profile (CicTypeChecker.typecheck_obj uri) obj + *) let index_obj = let profiler = HExtlib.profile "add_obj.index_obj" in fun ~dbd ~uri -> + assert false (* MATITA 1.0 profiler.HExtlib.profile (fun uri -> MetadataDb.index_obj ~dbd ~uri) uri + *) let remove_obj uri = + assert false (* MATITA 1.0 let derived_uris_of_uri uri = let innertypesuri, bodyuri, univgraphuri = uris_of_obj uri in innertypesuri::univgraphuri::(match bodyuri with None -> [] | Some u -> [u]) @@ -166,8 +174,10 @@ let remove_obj uri = List.iter (fun uri -> ignore (LibraryDb.remove_uri uri)) uris_to_remove ; CicEnvironment.remove_obj uri ;; +*) let rec add_obj uri obj ~pack_coercion_obj = + assert false (* MATITA 1.0 let obj = if CoercDb.is_a_coercion (Cic.Const (uri, [])) = None then pack_coercion_obj obj @@ -217,10 +227,12 @@ let rec add_obj uri obj ~pack_coercion_obj = CoercDb.restore old_db; raise exn (* /ATOMIC *) + *) and add_coercion ~add_composites ~pack_coercion_obj uri arity saturations baseuri = + assert false (* MATITA 1.0 let coer_ty,_ = let coer = CicUtil.term_of_uri uri in CicTypeChecker.type_of_aux' [] [] coer CicUniv.oblivion_ugraph @@ -369,6 +381,7 @@ and CoercDb.add_coercion (src_carr, tgt_carr, uri, saturations, cpos); (* CoercDb.prefer uri; *) lemmas + *) ;; diff --git a/matita/components/metadata/.depend b/matita/components/metadata/.depend deleted file mode 100644 index 78cd97a0d..000000000 --- a/matita/components/metadata/.depend +++ /dev/null @@ -1,25 +0,0 @@ -sqlStatements.cmi: -metadataTypes.cmi: -metadataExtractor.cmi: metadataTypes.cmi -metadataPp.cmi: metadataTypes.cmi -metadataConstraints.cmi: metadataTypes.cmi -metadataDb.cmi: metadataTypes.cmi -metadataDeps.cmi: metadataTypes.cmi -sqlStatements.cmo: sqlStatements.cmi -sqlStatements.cmx: sqlStatements.cmi -metadataTypes.cmo: metadataTypes.cmi -metadataTypes.cmx: metadataTypes.cmi -metadataExtractor.cmo: metadataTypes.cmi metadataExtractor.cmi -metadataExtractor.cmx: metadataTypes.cmx metadataExtractor.cmi -metadataPp.cmo: metadataTypes.cmi metadataPp.cmi -metadataPp.cmx: metadataTypes.cmx metadataPp.cmi -metadataConstraints.cmo: metadataTypes.cmi metadataPp.cmi \ - metadataConstraints.cmi -metadataConstraints.cmx: metadataTypes.cmx metadataPp.cmx \ - metadataConstraints.cmi -metadataDb.cmo: metadataTypes.cmi metadataPp.cmi metadataExtractor.cmi \ - metadataConstraints.cmi metadataDb.cmi -metadataDb.cmx: metadataTypes.cmx metadataPp.cmx metadataExtractor.cmx \ - metadataConstraints.cmx metadataDb.cmi -metadataDeps.cmo: sqlStatements.cmi metadataTypes.cmi metadataDeps.cmi -metadataDeps.cmx: sqlStatements.cmx metadataTypes.cmx metadataDeps.cmi diff --git a/matita/components/metadata/.depend.opt b/matita/components/metadata/.depend.opt deleted file mode 100644 index 78cd97a0d..000000000 --- a/matita/components/metadata/.depend.opt +++ /dev/null @@ -1,25 +0,0 @@ -sqlStatements.cmi: -metadataTypes.cmi: -metadataExtractor.cmi: metadataTypes.cmi -metadataPp.cmi: metadataTypes.cmi -metadataConstraints.cmi: metadataTypes.cmi -metadataDb.cmi: metadataTypes.cmi -metadataDeps.cmi: metadataTypes.cmi -sqlStatements.cmo: sqlStatements.cmi -sqlStatements.cmx: sqlStatements.cmi -metadataTypes.cmo: metadataTypes.cmi -metadataTypes.cmx: metadataTypes.cmi -metadataExtractor.cmo: metadataTypes.cmi metadataExtractor.cmi -metadataExtractor.cmx: metadataTypes.cmx metadataExtractor.cmi -metadataPp.cmo: metadataTypes.cmi metadataPp.cmi -metadataPp.cmx: metadataTypes.cmx metadataPp.cmi -metadataConstraints.cmo: metadataTypes.cmi metadataPp.cmi \ - metadataConstraints.cmi -metadataConstraints.cmx: metadataTypes.cmx metadataPp.cmx \ - metadataConstraints.cmi -metadataDb.cmo: metadataTypes.cmi metadataPp.cmi metadataExtractor.cmi \ - metadataConstraints.cmi metadataDb.cmi -metadataDb.cmx: metadataTypes.cmx metadataPp.cmx metadataExtractor.cmx \ - metadataConstraints.cmx metadataDb.cmi -metadataDeps.cmo: sqlStatements.cmi metadataTypes.cmi metadataDeps.cmi -metadataDeps.cmx: sqlStatements.cmx metadataTypes.cmx metadataDeps.cmi diff --git a/matita/components/metadata/Makefile b/matita/components/metadata/Makefile deleted file mode 100644 index 9943237dd..000000000 --- a/matita/components/metadata/Makefile +++ /dev/null @@ -1,18 +0,0 @@ -PACKAGE = metadata -PREDICATES = - -INTERFACE_FILES = \ - sqlStatements.mli \ - metadataTypes.mli \ - metadataExtractor.mli \ - metadataPp.mli \ - metadataConstraints.mli \ - metadataDb.mli \ - metadataDeps.mli \ - $(NULL) -IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml) -EXTRA_OBJECTS_TO_INSTALL = -EXTRA_OBJECTS_TO_CLEAN = - -include ../../Makefile.defs -include ../Makefile.common diff --git a/matita/components/metadata/metadataConstraints.ml b/matita/components/metadata/metadataConstraints.ml deleted file mode 100644 index 3e8ac2f72..000000000 --- a/matita/components/metadata/metadataConstraints.ml +++ /dev/null @@ -1,698 +0,0 @@ -(* Copyright (C) 2004, 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$ *) - -open Printf -open MetadataTypes - -let debug = false -let debug_print s = if debug then prerr_endline (Lazy.force s) - -let critical_value = 7 -let just_factor = 1 - -module UriManagerSet = UriManager.UriSet -module SetSet = Set.Make (UriManagerSet) - -type term_signature = (UriManager.uri * UriManager.uri list) option * UriManagerSet.t - -type cardinality_condition = - | Eq of int - | Gt of int - | Lt of int - -type rating_criterion = - [ `Hits (** order by number of hits, most used objects first *) - ] - -let default_tables = - (library_obj_tbl,library_rel_tbl,library_sort_tbl,library_count_tbl) - -let current_tables () = - (obj_tbl (),rel_tbl (),sort_tbl (), count_tbl ()) - -let tbln n = "table" ^ string_of_int n - -(* -let add_depth_constr depth_opt cur_tbl where = - match depth_opt with - | None -> where - | Some depth -> (sprintf "%s.h_depth = %d" cur_tbl depth) :: where -*) - -let mk_positions positions cur_tbl = - "(" ^ - String.concat " or " - (List.map - (fun pos -> - let pos_str = MetadataPp.pp_position_tag pos in - match pos with - | `InBody - | `InConclusion - | `InHypothesis - | `MainConclusion None - | `MainHypothesis None -> - sprintf "%s.h_position = \"%s\"" cur_tbl pos_str - | `MainConclusion (Some r) - | `MainHypothesis (Some r) -> - let depth = MetadataPp.pp_relation r in - sprintf "(%s.h_position = \"%s\" and %s.h_depth %s)" - cur_tbl pos_str cur_tbl depth) - (positions :> MetadataTypes.position list)) ^ - ")" - -let explode_card_constr = function - | Eq card -> "=", card - | Gt card -> ">", card - | Lt card -> "<", card - -let add_card_constr tbl col where = function - | None -> where - | Some constr -> - let op, card = explode_card_constr constr in - (* count(_utente).hypothesis = 3 *) - (sprintf "%s.%s %s %d" tbl col op card :: where) - -let add_diff_constr tbl where = function - | None -> where - | Some constr -> - let op, card = explode_card_constr constr in - (sprintf "%s.hypothesis - %s.conclusion %s %d" tbl tbl op card :: where) - -let add_all_constr ?(tbl=library_count_tbl) (n,from,where) concl full diff = - match (concl, full, diff) with - | None, None, None -> (n,from,where) - | _ -> - let cur_tbl = tbln n in - let from = (sprintf "%s as %s" tbl cur_tbl) :: from in - let where = add_card_constr cur_tbl "conclusion" where concl in - let where = add_card_constr cur_tbl "statement" where full in - let where = add_diff_constr cur_tbl where diff in - (n+2,from, - (if n > 0 then - sprintf "table0.source = %s.source" cur_tbl :: where - else - where)) - - -let add_constraint ?(start=0) ?(tables=default_tables) (n,from,where) metadata = - let obj_tbl,rel_tbl,sort_tbl,count_tbl = tables - in - let cur_tbl = tbln n in - let start_table = tbln start in - match metadata with - | `Obj (uri, positions) -> - let from = (sprintf "%s as %s" obj_tbl cur_tbl) :: from in - let where = - (sprintf "(%s.h_occurrence = \"%s\")" cur_tbl (UriManager.string_of_uri uri)) :: - mk_positions positions cur_tbl :: - (if n=start then [] - else [sprintf "%s.source = %s.source" start_table cur_tbl]) @ - where - in - ((n+2), from, where) - | `Rel positions -> - let from = (sprintf "%s as %s" rel_tbl cur_tbl) :: from in - let where = - mk_positions positions cur_tbl :: - (if n=start then [] - else [sprintf "%s.source = %s.source" start_table cur_tbl]) @ - where - in - ((n+2), from, where) - | `Sort (sort, positions) -> - let sort_str = CicPp.ppsort sort in - let from = (sprintf "%s as %s" sort_tbl cur_tbl) :: from in - let where = - (sprintf "%s.h_sort = \"%s\"" cur_tbl sort_str ) :: - mk_positions positions cur_tbl :: - (if n=start then - [] - else - [sprintf "%s.source = %s.source" start_table cur_tbl ]) @ where - in - ((n+2), from, where) - -let exec dbtype ~(dbd:HSql.dbd) ?rating (n,from,where) = - let from = String.concat ", " from in - let where = String.concat " and " where in - let query = - match rating with - | None -> sprintf "select distinct table0.source from %s where %s" from where - | Some `Hits -> - sprintf - ("select distinct table0.source from %s, hits where %s - and table0.source = hits.source order by hits.no desc") - from where - in - (* debug_print (lazy query); *) - let result = HSql.exec dbtype dbd query in - HSql.map result - ~f:(fun row -> - match row.(0) with Some s -> UriManager.uri_of_string s - | _ -> assert false) -;; - -let at_least dbtype ~(dbd:HSql.dbd) ?concl_card ?full_card ?diff ?rating tables - (metadata: MetadataTypes.constr list) -= - let obj_tbl,rel_tbl,sort_tbl, count_tbl = tables in - if (metadata = []) && concl_card = None && full_card = None then - begin - HLog.warn "MetadataConstraints.at_least: no constraints given"; - [] - end - else - let (n,from,where) = - List.fold_left (add_constraint ~tables) (0,[],[]) metadata - in - let (n,from,where) = - add_all_constr ~tbl:count_tbl (n,from,where) concl_card full_card diff - in - exec dbtype ~dbd ?rating (n,from,where) -;; - -let at_least - ~(dbd:HSql.dbd) ?concl_card ?full_card ?diff ?rating - (metadata: MetadataTypes.constr list) -= - if are_tables_ownerized () then - at_least - HSql.Library ~dbd ?concl_card ?full_card ?diff ?rating - default_tables metadata - @ - at_least - HSql.Legacy ~dbd ?concl_card ?full_card ?diff ?rating - default_tables metadata - @ - at_least - HSql.User ~dbd ?concl_card ?full_card ?diff ?rating - (current_tables ()) metadata - - else - at_least - HSql.Library ~dbd ?concl_card ?full_card ?diff ?rating - default_tables metadata - @ - at_least - HSql.Legacy ~dbd ?concl_card ?full_card ?diff ?rating - default_tables metadata - - - (** Prefix handling *) - -let filter_by_card n = - SetSet.filter (fun t -> (UriManagerSet.cardinal t) <= n) - -let merge n a b = - let init = SetSet.union a b in - let merge_single_set s1 b = - SetSet.fold - (fun s2 res -> SetSet.add (UriManagerSet.union s1 s2) res) - b SetSet.empty in - let res = - SetSet.fold (fun s1 res -> SetSet.union (merge_single_set s1 b) res) a init - in - filter_by_card n res - -let rec inspect_children n childs = - List.fold_left - (fun res term -> merge n (inspect_conclusion n term) res) - SetSet.empty childs - -and add_root n root childs = - let childunion = inspect_children n childs in - let addroot = UriManagerSet.add root in - SetSet.fold - (fun child newsets -> SetSet.add (addroot child) newsets) - childunion - (SetSet.singleton (UriManagerSet.singleton root)) - -and inspect_conclusion n t = - if n = 0 then SetSet.empty - else match t with - Cic.Rel _ - | Cic.Meta _ - | Cic.Sort _ - | Cic.Implicit _ -> SetSet.empty - | Cic.Var (u,exp_named_subst) -> SetSet.empty - | Cic.Const (u,exp_named_subst) -> - SetSet.singleton (UriManagerSet.singleton u) - | Cic.MutInd (u, t, exp_named_subst) -> - SetSet.singleton (UriManagerSet.singleton - (UriManager.uri_of_uriref u t None)) - | Cic.MutConstruct (u, t, c, exp_named_subst) -> - SetSet.singleton (UriManagerSet.singleton - (UriManager.uri_of_uriref u t (Some c))) - | Cic.Cast (t, _) -> inspect_conclusion n t - | Cic.Prod (_, s, t) -> - merge n (inspect_conclusion n s) (inspect_conclusion n t) - | Cic.Lambda (_, s, t) -> - merge n (inspect_conclusion n s) (inspect_conclusion n t) - | Cic.LetIn (_, s, ty, t) -> - merge n (inspect_conclusion n s) - (merge n (inspect_conclusion n ty) (inspect_conclusion n t)) - | Cic.Appl ((Cic.Const (u,exp_named_subst))::l) -> - add_root (n-1) u l - | Cic.Appl ((Cic.MutInd (u, t, exp_named_subst))::l) -> - let uri = UriManager.uri_of_uriref u t None in - add_root (n-1) uri l - | Cic.Appl ((Cic.MutConstruct (u, t, c, exp_named_subst))::l) -> - let suri = UriManager.uri_of_uriref u t (Some c) in - add_root (n-1) suri l - | Cic.Appl l -> - SetSet.empty - | Cic.MutCase (u, t, tt, uu, m) -> - SetSet.empty - | Cic.Fix (_, m) -> - SetSet.empty - | Cic.CoFix (_, m) -> - SetSet.empty - -let rec inspect_term n t = - if n = 0 then - assert false - else - match t with - Cic.Rel _ - | Cic.Meta _ - | Cic.Sort _ - | Cic.Implicit _ -> None, SetSet.empty - | Cic.Var (u,exp_named_subst) -> None, SetSet.empty - | Cic.Const (u,exp_named_subst) -> - Some u, SetSet.empty - | Cic.MutInd (u, t, exp_named_subst) -> - let uri = UriManager.uri_of_uriref u t None in - Some uri, SetSet.empty - | Cic.MutConstruct (u, t, c, exp_named_subst) -> - let uri = UriManager.uri_of_uriref u t (Some c) in - Some uri, SetSet.empty - | Cic.Cast (t, _) -> inspect_term n t - | Cic.Prod (_, _, t) -> inspect_term n t - | Cic.LetIn (_, _, _, t) -> inspect_term n t - | Cic.Appl ((Cic.Const (u,exp_named_subst))::l) -> - let childunion = inspect_children (n-1) l in - Some u, childunion - | Cic.Appl ((Cic.MutInd (u, t, exp_named_subst))::l) -> - let suri = UriManager.uri_of_uriref u t None in - if u = HelmLibraryObjects.Logic.eq_URI && n>1 then - (* equality is handled in a special way: in particular, - the type, if defined, is always added to the prefix, - and n is not decremented - it should have been n-2 *) - match l with - Cic.Const (u1,exp_named_subst1)::l1 -> - let inconcl = add_root (n-1) u1 l1 in - Some suri, inconcl - | Cic.MutInd (u1, t1, exp_named_subst1)::l1 -> - let suri1 = UriManager.uri_of_uriref u1 t1 None in - let inconcl = add_root (n-1) suri1 l1 in - Some suri, inconcl - | Cic.MutConstruct (u1, t1, c1, exp_named_subst1)::l1 -> - let suri1 = UriManager.uri_of_uriref u1 t1 (Some c1) in - let inconcl = add_root (n-1) suri1 l1 in - Some suri, inconcl - | _ :: _ -> Some suri, SetSet.empty - | _ -> assert false (* args number must be > 0 *) - else - let childunion = inspect_children (n-1) l in - Some suri, childunion - | Cic.Appl ((Cic.MutConstruct (u, t, c, exp_named_subst))::l) -> - let suri = UriManager.uri_of_uriref u t(Some c) in - let childunion = inspect_children (n-1) l in - Some suri, childunion - | _ -> None, SetSet.empty - -let add_cardinality s = - let l = SetSet.elements s in - let res = - List.map - (fun set -> - let el = UriManagerSet.elements set in - (List.length el, el)) l in - (* ordered by descending cardinality *) - List.sort (fun (n,_) (m,_) -> m - n) ((0,[])::res) - -let prefixes n t = - match inspect_term n t with - Some a, set -> Some a, add_cardinality set - | None, set when (SetSet.is_empty set) -> None, [] - | _, _ -> assert false - - -let rec add children = - List.fold_left - (fun acc t -> UriManagerSet.union (signature_concl t) acc) - (UriManagerSet.empty) children - -(* this function creates the set of all different constants appearing in - the conclusion of the term *) -and signature_concl = - function - Cic.Rel _ - | Cic.Meta _ - | Cic.Sort _ - | Cic.Implicit _ -> UriManagerSet.empty - | Cic.Var (u,exp_named_subst) -> - (*CSC: TODO if the var has a body it must be processed *) - UriManagerSet.empty - | Cic.Const (u,exp_named_subst) -> - UriManagerSet.singleton u - | Cic.MutInd (u, t, exp_named_subst) -> - let rec projections_of uris = - List.flatten - (List.map - (fun uri -> - let o,_ = CicEnvironment.get_obj CicUniv.oblivion_ugraph uri in - projections_of (CicUtil.projections_of_record o uri)) - uris) - in - let uri = UriManager.uri_of_uriref u t None in - List.fold_right UriManagerSet.add - (projections_of [u]) (UriManagerSet.singleton uri) - | Cic.MutConstruct (u, t, c, exp_named_subst) -> - let uri = UriManager.uri_of_uriref u t (Some c) in - UriManagerSet.singleton uri - | Cic.Cast (t, _) -> signature_concl t - | Cic.Prod (_, s, t) -> - UriManagerSet.union (signature_concl s) (signature_concl t) - | Cic.Lambda (_, s, t) -> - UriManagerSet.union (signature_concl s) (signature_concl t) - | Cic.LetIn (_, s, ty, t) -> - UriManagerSet.union (signature_concl s) - (UriManagerSet.union (signature_concl ty) (signature_concl t)) - | Cic.Appl l -> add l - | Cic.MutCase _ - | Cic.Fix _ - | Cic.CoFix _ -> - UriManagerSet.empty - -let rec signature_of = function - | Cic.Cast (t, _) -> signature_of t - | Cic.Prod (_, _, t) -> signature_of t - | Cic.LetIn (_, _, _, t) -> signature_of t - | Cic.Appl ((Cic.Const (u,exp_named_subst))::l) -> - Some (u, []), add l - | Cic.Appl ((Cic.MutInd (u, t, exp_named_subst))::l) -> - let suri = UriManager.uri_of_uriref u t None in - if LibraryObjects.is_eq_URI u then - (* equality is handled in a special way: in particular, - the type, if defined, is always added to the prefix, - and n is not decremented - it should have been n-2 *) - match l with - Cic.Const (u1,exp_named_subst1)::l1 -> - let inconcl = UriManagerSet.remove u1 (add l1) in - Some (suri, [u1]), inconcl - | Cic.MutInd (u1, t1, exp_named_subst1)::l1 -> - let suri1 = UriManager.uri_of_uriref u1 t1 None in - let inconcl = UriManagerSet.remove suri1 (add l1) in - Some (suri, [suri1]), inconcl - | Cic.MutConstruct (u1, t1, c1, exp_named_subst1)::l1 -> - let suri1 = UriManager.uri_of_uriref u1 t1 (Some c1) in - let inconcl = UriManagerSet.remove suri1 (add l1) in - Some (suri, [suri1]), inconcl - | _ :: tl -> Some (suri, []), add tl - | _ -> assert false (* args number must be > 0 *) - else - Some (suri, []), add l - | Cic.Appl ((Cic.MutConstruct (u, t, c, exp_named_subst))::l) -> - let suri = UriManager.uri_of_uriref u t (Some c) in - Some (suri, []), add l - | t -> None, signature_concl t - -(* takes a list of lists and returns the list of all elements - without repetitions *) -let union l = - let rec drop_repetitions = function - [] -> [] - | [a] -> [a] - | u1::u2::l when u1 = u2 -> drop_repetitions (u2::l) - | u::l -> u::(drop_repetitions l) in - drop_repetitions (List.sort Pervasives.compare (List.concat l)) - -let must_of_prefix ?(where = `Conclusion) m s = - let positions = - match where with - | `Conclusion -> [`InConclusion] - | `Statement -> [`InConclusion; `InHypothesis; `MainHypothesis None] - in - let positions = - if m = None then `MainConclusion None :: positions else positions in - let s' = List.map (fun (u:UriManager.uri) -> `Obj (u, positions)) s in - match m with - None -> s' - | Some m -> `Obj (m, [`MainConclusion None]) :: s' - -let escape = Str.global_replace (Str.regexp_string "\'") "\\'" - -let get_constants (dbd:HSql.dbd) ~where uri = - let uri = escape (UriManager.string_of_uri uri) in - let positions = - match where with - | `Conclusion -> [ MetadataTypes.mainconcl_pos; MetadataTypes.inconcl_pos ] - | `Statement -> - [ MetadataTypes.mainconcl_pos; MetadataTypes.inconcl_pos; - MetadataTypes.inhyp_pos; MetadataTypes.mainhyp_pos ] - in - let pos_predicate = - String.concat " OR " - (List.map (fun pos -> sprintf "(h_position = \"%s\")" pos) positions) - in - let query tbl = - sprintf "SELECT h_occurrence FROM %s WHERE source=\"%s\" AND (%s)" - tbl uri pos_predicate - in - let db = [ - HSql.Library, MetadataTypes.library_obj_tbl; - HSql.Legacy, MetadataTypes.library_obj_tbl; - HSql.User, MetadataTypes.obj_tbl ()] - in - let set = ref UriManagerSet.empty in - List.iter - (fun (dbtype, table) -> - let result = HSql.exec dbtype dbd (query table) in - HSql.iter result - (fun col -> - match col.(0) with - | Some uri -> - set := UriManagerSet.add (UriManager.uri_of_string uri) !set - | _ -> assert false)) - db; - !set - -let at_most ~(dbd:HSql.dbd) ?(where = `Conclusion) only u = - let inconcl = get_constants dbd ~where u in - UriManagerSet.subset inconcl only - - (* Special handling of equality. The problem is filtering out theorems just - * containing variables (e.g. all the theorems in cic:/Coq/Ring/). Really - * ad-hoc, no better solution found at the moment *) -let myspeciallist_of_facts = - [0,UriManager.uri_of_string "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)"] -let myspeciallist = - [0,UriManager.uri_of_string "cic:/Coq/Init/Logic/eq.ind#xpointer(1/1/1)"; - (* 0,"cic:/Coq/Init/Logic/sym_eq.con"; *) - 0,UriManager.uri_of_string "cic:/Coq/Init/Logic/trans_eq.con"; - 0,UriManager.uri_of_string "cic:/Coq/Init/Logic/f_equal.con"; - 0,UriManager.uri_of_string "cic:/Coq/Init/Logic/f_equal2.con"; - 0,UriManager.uri_of_string "cic:/Coq/Init/Logic/f_equal3.con"] - - -let compute_exactly ~(dbd:HSql.dbd) ?(facts=false) ~where main prefixes = - List.concat - (List.map - (fun (m,s) -> - let is_eq,card = - match main with - None -> false,m - | Some main -> - (m = 0 && - UriManager.eq main - (UriManager.uri_of_string (HelmLibraryObjects.Logic.eq_XURI))), - m+1 - in - if m = 0 && is_eq then - (if facts then myspeciallist_of_facts - else myspeciallist) - else - let res = - (* this gets rid of the ~750 objects of type Set/Prop/Type *) - if card = 0 then [] - else - let must = must_of_prefix ~where main s in - match where with - | `Conclusion -> at_least ~dbd ~concl_card:(Eq card) must - | `Statement -> at_least ~dbd ~full_card:(Eq card) must - in - List.map (fun uri -> (card, uri)) res) - prefixes) - - (* critical value reached, fallback to "only" constraints *) - -let compute_with_only ~(dbd:HSql.dbd) ?(facts=false) ?(where = `Conclusion) - main prefixes constants -= - let max_prefix_length = - match prefixes with - | [] -> assert false - | (max,_)::_ -> max in - let maximal_prefixes = - let rec filter res = function - [] -> res - | (n,s)::l when n = max_prefix_length -> filter ((n,s)::res) l - | _::_-> res in - filter [] prefixes in - let greater_than = - let all = - union - (List.map - (fun (m,s) -> - let card = if main = None then m else m + 1 in - let must = must_of_prefix ~where main s in - (let res = - match where with - | `Conclusion -> at_least ~dbd ~concl_card:(Gt card) must - | `Statement -> at_least ~dbd ~full_card:(Gt card) must - in - (* we tag the uri with m+1, for sorting purposes *) - List.map (fun uri -> (card, uri)) res)) - maximal_prefixes) - in -(* Printf.fprintf stderr "all: %d\n" (List.length all);flush_all (); *) -(* - List.filter (function (_,uri) -> - at_most ~dbd ~where constants uri) -*) - all - in - let equal_to = compute_exactly ~dbd ~facts ~where main prefixes in - greater_than @ equal_to - - (* real match query implementation *) - -let cmatch ~(dbd:HSql.dbd) ?(facts=false) t = - let (main, constants) = signature_of t in - match main with - | None -> [] - | Some (main, types) -> - (* the type of eq is not counted in constants_no *) - let types_no = List.length types in - let constants_no = UriManagerSet.cardinal constants in - if (constants_no > critical_value) then - let prefixes = prefixes just_factor t in - (match prefixes with - | Some main, all_concl -> - let all_constants = - List.fold_right UriManagerSet.add types (UriManagerSet.add main constants) - in - compute_with_only ~dbd ~facts (Some main) all_concl all_constants - | _, _ -> []) - else - (* in this case we compute all prefixes, and we do not need - to apply the only constraints *) - let prefixes = - if constants_no = 0 then - (if types_no = 0 then - Some main, [0, []] - else - Some main, [0, []; types_no, types]) - else - prefixes (constants_no+types_no+1) t - in - (match prefixes with - Some main, all_concl -> - compute_exactly ~dbd ~facts ~where:`Conclusion (Some main) all_concl - | _, _ -> []) - -let power_upto upto consts = - let l = UriManagerSet.elements consts in - List.sort (fun (n,_) (m,_) -> m - n) - (List.fold_left - (fun res a -> - let res' = - List.filter (function (n,l) -> n <= upto) - (List.map (function (n,l) -> (n+1,a::l)) res) in - res@res') - [(0,[])] l) - -let power consts = - let l = UriManagerSet.elements consts in - List.sort (fun (n,_) (m,_) -> m - n) - (List.fold_left - (fun res a -> res@(List.map (function (n,l) -> (n+1,a::l)) res)) - [(0,[])] l) - -type where = [ `Conclusion | `Statement ] - -let sigmatch ~(dbd:HSql.dbd) ?(facts=false) ?(where = `Conclusion) - (main, constants) -= - let main,types = - match main with - None -> None,[] - | Some (main, types) -> Some main,types - in - let constants_no = UriManagerSet.cardinal constants in - (* debug_print (lazy (("constants_no: ")^(string_of_int constants_no))); *) - if (constants_no > critical_value) then - let subsets = - let subsets = power_upto just_factor constants in - (* let _ = debug_print (lazy (("subsets: ")^ - (string_of_int (List.length subsets)))) in *) - let types_no = List.length types in - if types_no > 0 then - List.map (function (n,l) -> (n+types_no,types@l)) subsets - else subsets - in - debug_print (lazy ("critical_value exceded..." ^ string_of_int constants_no)); - let all_constants = - let all = match main with None -> types | Some m -> m::types in - List.fold_right UriManagerSet.add all constants - in - compute_with_only ~dbd ~where main subsets all_constants - else - (debug_print (lazy ("all subsets..." ^ string_of_int constants_no)); - let subsets = - let subsets = power constants in - let types_no = List.length types in - if types_no > 0 then - (0,[]) :: List.map (function (n,l) -> (n+types_no,types@l)) subsets - else subsets - in - debug_print (lazy "fine1"); - compute_exactly ~dbd ~facts ~where main subsets) - - (* match query wrappers *) - -let cmatch'= cmatch - -let cmatch ~dbd ?(facts=false) term = - List.map snd - (List.sort - (fun x y -> Pervasives.compare (fst y) (fst x)) - (cmatch' ~dbd ~facts term)) - -let constants_of = signature_concl - diff --git a/matita/components/metadata/metadataConstraints.mli b/matita/components/metadata/metadataConstraints.mli deleted file mode 100644 index bc83f65d7..000000000 --- a/matita/components/metadata/metadataConstraints.mli +++ /dev/null @@ -1,112 +0,0 @@ -(* Copyright (C) 2004, 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 UriManagerSet : Set.S with type elt = UriManager.uri -module SetSet: Set.S with type elt = UriManagerSet.t - - (** @return - * main: constant in main position and, for polymorphic constants, type - * instantitation - * constants: constants appearing in term *) -type term_signature = (UriManager.uri * UriManager.uri list) option * UriManagerSet.t - -(** {2 Candidates filtering} *) - - (** @return sorted list of theorem URIs, first URIs in the least have higher - * relevance *) -val cmatch: dbd:HSql.dbd -> ?facts:bool -> Cic.term -> UriManager.uri list - - (** as cmatch, but returned list is not sorted but rather tagged with - * relevance information: higher the tag, higher the relevance *) -val cmatch': dbd:HSql.dbd -> ?facts:bool -> Cic.term -> (int * UriManager.uri) list - -type where = [ `Conclusion | `Statement ] (** signature matching extent *) - - (** @param where defaults to `Conclusion *) -val sigmatch: - dbd:HSql.dbd -> - ?facts:bool -> - ?where:where -> - term_signature -> - (int * UriManager.uri) list - -(** {2 Constraint engine} *) - - (** constraing on the number of distinct constants *) -type cardinality_condition = - | Eq of int - | Gt of int - | Lt of int - -type rating_criterion = - [ `Hits (** order by number of hits, most used objects first *) - ] - -val add_constraint: - ?start:int -> - ?tables:string * string * string * string -> - int * string list * string list -> - MetadataTypes.constr -> - int * string list * string list - - (** @param concl_card cardinality condition on conclusion only - * @param full_card cardinality condition on the whole statement - * @param diff required difference between the number of different constants in - * hypothesis and the number of different constants in body - * @return list of URI satisfying given constraints *) - -val at_least: - dbd:HSql.dbd -> - ?concl_card:cardinality_condition -> - ?full_card:cardinality_condition -> - ?diff:cardinality_condition -> - ?rating:rating_criterion -> - MetadataTypes.constr list -> - UriManager.uri list - - (** @param where defaults to `Conclusion *) -val at_most: - dbd:HSql.dbd -> - ?where:where -> UriManagerSet.t -> - (UriManager.uri -> bool) - -val add_all_constr: - ?tbl:string -> - int * string list * string list -> - cardinality_condition option -> - cardinality_condition option -> - cardinality_condition option -> - int * string list * string list - -val exec: - HSql.dbtype -> - dbd:HSql.dbd -> - ?rating:[ `Hits ] -> - int * string list * string list -> - UriManager.uri list - -val signature_of: Cic.term -> term_signature -val constants_of: Cic.term -> UriManagerSet.t - diff --git a/matita/components/metadata/metadataDb.ml b/matita/components/metadata/metadataDb.ml deleted file mode 100644 index 844a08347..000000000 --- a/matita/components/metadata/metadataDb.ml +++ /dev/null @@ -1,224 +0,0 @@ -(* Copyright (C) 2004, 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$ *) - -open MetadataTypes - -open Printf - -let format_insert dbtype dbd tbl tuples = - if HSql.isMysql dbtype dbd then - [sprintf "INSERT %s VALUES %s;" tbl (String.concat "," tuples)] - else - List.map (fun tup -> - sprintf "INSERT INTO %s VALUES %s;" tbl tup) tuples -;; - -let execute_insert dbd uri (sort_cols, rel_cols, obj_cols) = - let sort_tuples = - List.fold_left (fun s l -> match l with - | [`String a; `String b; `Int c; `String d] -> - sprintf "(\"%s\", \"%s\", %d, \"%s\")" a b c d :: s - | _ -> assert false ) - [] sort_cols - in - let rel_tuples = - List.fold_left (fun s l -> match l with - | [`String a; `String b; `Int c] -> - sprintf "(\"%s\", \"%s\", %d)" a b c :: s - | _ -> assert false) - [] rel_cols - in - let obj_tuples = List.fold_left (fun s l -> match l with - | [`String a; `String b; `String c; `Int d] -> - sprintf "(\"%s\", \"%s\", \"%s\", %d)" a b c d :: s - | [`String a; `String b; `String c; `Null] -> - sprintf "(\"%s\", \"%s\", \"%s\", %s)" a b c "NULL" :: s - | _ -> assert false) - [] obj_cols - in - let dbtype = - if Helm_registry.get_bool "matita.system" then HSql.Library else HSql.User - in - if sort_tuples <> [] then - begin - let query_sort = - format_insert dbtype dbd (sort_tbl ()) sort_tuples - in - List.iter (fun query -> ignore (HSql.exec dbtype dbd query)) query_sort - end; - if rel_tuples <> [] then - begin - let query_rel = - format_insert dbtype dbd (rel_tbl ()) rel_tuples - in - List.iter (fun query -> ignore (HSql.exec dbtype dbd query)) query_rel - end; - if obj_tuples <> [] then - begin - let query_obj = - format_insert dbtype dbd (obj_tbl ()) obj_tuples - in - List.iter (fun query -> ignore (HSql.exec dbtype dbd query)) query_obj - end - - -let count_distinct position l = - MetadataConstraints.UriManagerSet.cardinal - (List.fold_left (fun acc d -> - match position with - | `Conclusion -> - (match d with - | `Obj (name,`InConclusion) - | `Obj (name,`MainConclusion _ ) -> - MetadataConstraints.UriManagerSet.add name acc - | _ -> acc) - | `Hypothesis -> - (match d with - | `Obj (name,`InHypothesis) - | `Obj (name,`MainHypothesis _) -> - MetadataConstraints.UriManagerSet.add name acc - | _ -> acc) - | `Statement -> - (match d with - | `Obj (name,`InBody) -> acc - | `Obj (name,_) -> MetadataConstraints.UriManagerSet.add name acc - | _ -> acc) - ) MetadataConstraints.UriManagerSet.empty l) - -let insert_const_no ~dbd l = - let data = - List.fold_left - (fun acc (uri,_,metadata) -> - let no_concl = count_distinct `Conclusion metadata in - let no_hyp = count_distinct `Hypothesis metadata in - let no_full = count_distinct `Statement metadata in - (sprintf "(\"%s\", %d, %d, %d)" - (UriManager.string_of_uri uri) no_concl no_hyp no_full) :: acc - ) [] l in - let dbtype = - if Helm_registry.get_bool "matita.system" then HSql.Library else HSql.User - in - let insert = - format_insert dbtype dbd (count_tbl ()) data - in - List.iter (fun query -> ignore (HSql.exec dbtype dbd query)) insert - -let insert_name ~dbd l = - let dbtype = - if Helm_registry.get_bool "matita.system" then HSql.Library else HSql.User - in - let data = - List.fold_left - (fun acc (uri,name,_) -> - (sprintf "(\"%s\", \"%s\")" (UriManager.string_of_uri uri) name) :: acc - ) [] l in - let insert = - format_insert dbtype dbd (name_tbl ()) data - in - List.iter (fun query -> ignore (HSql.exec dbtype dbd query)) insert - -type columns = - MetadataPp.t list list * MetadataPp.t list list * MetadataPp.t list list - - (* TODO ZACK: verify if an object has already been indexed *) -let already_indexed _ = false - -(***** TENTATIVE HACK FOR THE DB SLOWDOWN - BEGIN *******) -let analyze_index = ref 0 -let eventually_analyze dbd = - incr analyze_index; - if !analyze_index > 30 then - if HSql.isMysql HSql.User dbd then - begin - let analyze t = "OPTIMIZE TABLE " ^ t ^ ";" in - List.iter - (fun table -> ignore (HSql.exec HSql.User dbd (analyze table))) - [name_tbl (); rel_tbl (); sort_tbl (); obj_tbl(); count_tbl()] - end - -(***** TENTATIVE HACK FOR THE DB SLOWDOWN - END *******) - -let index_obj ~dbd ~uri = - if not (already_indexed uri) then begin - eventually_analyze dbd; - let metadata = MetadataExtractor.compute_obj uri in - let uri = UriManager.string_of_uri uri in - let columns = MetadataPp.columns_of_metadata metadata in - execute_insert dbd uri (columns :> columns); - insert_const_no ~dbd metadata; - insert_name ~dbd metadata - end - - -let tables_to_clean = - [sort_tbl; rel_tbl; obj_tbl; name_tbl; count_tbl] - -let clean ~(dbd:HSql.dbd) = - let owned_uris = (* list of uris in list-of-columns format *) - let query = sprintf "SELECT source FROM %s" (name_tbl ()) in - let result = HSql.exec HSql.User dbd query in - let uris = HSql.map result (fun cols -> - match cols.(0) with - | Some src -> src - | None -> assert false) in - (* and now some stuff to remove #xpointers and duplicates *) - uris - in - let del_from tbl = - let escape s = - Pcre.replace ~pat:"([^\\\\])_" ~templ:"$1\\_" (HSql.escape HSql.User dbd s) - in - let query s = - sprintf - ("DELETE FROM %s WHERE source LIKE \"%s%%\" " ^^ - HSql.escape_string_for_like HSql.User dbd) - (tbl ()) (escape s) - in - List.iter - (fun source_col -> ignore (HSql.exec HSql.User dbd (query source_col))) - owned_uris - in - List.iter del_from tables_to_clean; - owned_uris - -let unindex ~dbd ~uri = - let uri = UriManager.string_of_uri uri in - let del_from tbl = - let escape s = - Pcre.replace - ~pat:"([^\\\\])_" ~templ:"$1\\_" (HSql.escape HSql.User dbd s) - in - let query tbl = - sprintf - ("DELETE FROM %s WHERE source LIKE \"%s%%\" " ^^ - HSql.escape_string_for_like HSql.User dbd) - (tbl ()) (escape uri) - in - ignore (HSql.exec HSql.User dbd (query tbl)) - in - List.iter del_from tables_to_clean - diff --git a/matita/components/metadata/metadataDb.mli b/matita/components/metadata/metadataDb.mli deleted file mode 100644 index b1acc4cbe..000000000 --- a/matita/components/metadata/metadataDb.mli +++ /dev/null @@ -1,41 +0,0 @@ -(* Copyright (C) 2004, 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/ - *) - - - -val index_obj: dbd:HSql.dbd -> uri:UriManager.uri -> unit - -(* TODO Zack indexing of variables and (perhaps?) incomplete proofs *) - - (** remove from the db all metadata pertaining to a given owner - * @return list of uris removed from the db *) -val clean: dbd:HSql.dbd -> string list - -val unindex: dbd:HSql.dbd -> uri:UriManager.uri -> unit - -val count_distinct: - [`Conclusion | `Hypothesis | `Statement ] -> - MetadataTypes.metadata list -> - int diff --git a/matita/components/metadata/metadataDeps.ml b/matita/components/metadata/metadataDeps.ml deleted file mode 100644 index e949984e4..000000000 --- a/matita/components/metadata/metadataDeps.ml +++ /dev/null @@ -1,306 +0,0 @@ -(* 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/ - *) - -open Printf - -open MetadataTypes - -module Pp = GraphvizPp.Dot -module UriSet = UriManager.UriSet - -let strip_prefix s = - let prefix_len = String.length position_prefix in - String.sub s prefix_len (String.length s - prefix_len) - -let parse_pos = - function - | Some s, Some d -> - (match strip_prefix s with - | "MainConclusion" -> `MainConclusion (Some (Eq (int_of_string d))) - | "MainHypothesis" -> `MainHypothesis (Some (Eq (int_of_string d))) - | s -> - prerr_endline ("Invalid main position: " ^ s); - assert false) - | Some s, None -> - (match strip_prefix s with - | "InConclusion" -> `InConclusion - | "InHypothesis" -> `InHypothesis - | "InBody" -> `InBody - | s -> - prerr_endline ("Invalid position: " ^ s); - assert false) - | _ -> assert false - -let unbox_row = function `Obj (uri, pos) -> (uri, pos) - -let direct_deps ~dbd uri = - let obj_metadata_of_row = - function - | [| Some _; Some occurrence; pos; depth |] -> - `Obj (UriManager.uri_of_string occurrence, parse_pos (pos, depth)) - | _ -> - prerr_endline "invalid (direct) refObj metadata row"; - assert false - in - let do_query (dbtype, tbl) = - let res = - HSql.exec dbtype dbd (SqlStatements.direct_deps tbl uri dbtype dbd) - in - let deps = - HSql.map res (fun row -> unbox_row (obj_metadata_of_row row)) in - deps - in - do_query (HSql.User, MetadataTypes.obj_tbl ()) - @ do_query (HSql.Library, MetadataTypes.library_obj_tbl) - @ do_query (HSql.Legacy, MetadataTypes.library_obj_tbl) - -let inverse_deps ~dbd uri = - let inv_obj_metadata_of_row = - function - | [| Some src; Some _; pos; depth |] -> - `Obj (UriManager.uri_of_string src, parse_pos (pos, depth)) - | _ -> - prerr_endline "invalid (inverse) refObj metadata row"; - assert false - in - let do_query (dbtype, tbl) = - let res = - HSql.exec dbtype dbd (SqlStatements.inverse_deps tbl uri dbtype dbd) - in - let deps = - HSql.map res (fun row -> unbox_row (inv_obj_metadata_of_row row)) in - deps - in - do_query (HSql.User, MetadataTypes.obj_tbl ()) - @ do_query (HSql.Library, MetadataTypes.library_obj_tbl) - @ do_query (HSql.Legacy, MetadataTypes.library_obj_tbl) - -let topological_sort ~dbd uris = - let module OrderedUri = - struct - type t = UriManager.uri - let compare = UriManager.compare - end in - let module Topo = HTopoSort.Make(OrderedUri) in - Topo.topological_sort uris - (fun uri -> fst (List.split (direct_deps ~dbd uri))) - -let sorted_uris_of_baseuri ~dbd baseuri = - let sql_pat = - Pcre.replace ~pat:"([^\\\\])_" ~templ:"$1\\_" baseuri ^ "%" - in - let query dbtype tbl = - Printf.sprintf - ("SELECT source FROM %s WHERE source LIKE \"%s\" " - ^^ HSql.escape_string_for_like dbtype dbd) - tbl sql_pat - in - let map cols = match cols.(0) with - | Some s -> UriManager.uri_of_string s - | _ -> assert false - in - let uris = - List.fold_left - (fun acc (dbtype, table) -> - let result = HSql.exec dbtype dbd (query dbtype table) in - HSql.map result map @ acc) - [] - [HSql.User, MetadataTypes.name_tbl (); - HSql.Library, MetadataTypes.library_name_tbl; - HSql.Legacy, MetadataTypes.library_name_tbl] - in - let sorted_uris = topological_sort ~dbd uris in - let filter_map uri = - let s = - Pcre.replace ~rex:(Pcre.regexp "#xpointer\\(1/1\\)") ~templ:"" - (UriManager.string_of_uri uri) - in - try ignore (Pcre.exec ~rex:(Pcre.regexp"#xpointer") s); None - with Not_found -> Some (UriManager.uri_of_string s) - in - HExtlib.filter_map filter_map sorted_uris - -module DepGraph = -struct - module UriTbl = UriManager.UriHashtbl - - let fat_value = 20 - let fat_increment = fat_value - let incomplete_attrs = ["style", "dashed"] - let global_node_attrs = ["fontsize", "12"; "width", ".4"; "height", ".4"] - - let label_of_uri uri = UriManager.name_of_uri uri - (*let label_of_uri uri = UriManager.string_of_uri uri*) - - type neighborhood = - { adjacency: UriManager.uri list lazy_t; (* all outgoing edges *) - mutable shown: int (* amount of edges to show *) - } - - (** - * All dependency graph have a single root, it is kept here to have a - * starting point for graph traversals *) - type t = - neighborhood UriTbl.t * UriManager.uri - * (UriManager.uri -> UriManager.uri list) * bool - - let dummy = - UriTbl.create 0, UriManager.uri_of_string "cic:/a.con", - (fun _ -> []), false - - let render fmt (adjlist, root, _f, invert) = - let is_complete uri = - try - let neighbs = UriTbl.find adjlist uri in - Lazy.lazy_is_val neighbs.adjacency - && neighbs.shown >= List.length (Lazy.force neighbs.adjacency) - with Not_found -> - (*eprintf "Node '%s' not found.\n" (UriManager.string_of_uri uri);*) - assert false - in - Pp.header ~graph_type:"strict digraph" ~graph_attrs:["rankdir", "LR"] ~node_attrs:global_node_attrs fmt; - let rec aux = - function - | [] -> () - | uri :: tl -> - let nice = UriManager.strip_xpointer in - let suri = UriManager.string_of_uri (nice uri) in - Pp.node suri - ~attrs:([ "href", UriManager.string_of_uri uri; - "label", label_of_uri uri - ] @ (if is_complete uri then [] else incomplete_attrs)) - fmt; - let new_nodes = ref [] in - (try - let neighbs = UriTbl.find adjlist uri in - if Lazy.lazy_is_val neighbs.adjacency then begin - let adjacency, _ = - HExtlib.split_nth neighbs.shown (Lazy.force neighbs.adjacency) - in - List.iter - (fun dest -> - let uri1, uri2 = if invert then dest, uri else uri, dest in - Pp.edge (UriManager.string_of_uri (nice uri1)) - (UriManager.string_of_uri (nice uri2)) fmt) - adjacency; - new_nodes := adjacency - end; - with Not_found -> ()); - aux (!new_nodes @ tl) - in - aux [root]; - Pp.trailer fmt - - let expand uri (adjlist, _root, f, _invert) = - (*eprintf "expanding uri %s\n%!" (UriManager.string_of_uri uri);*) - try - let neighbs = UriTbl.find adjlist uri in - if not (Lazy.lazy_is_val neighbs.adjacency) then - (* node has never been expanded *) - let adjacency = Lazy.force neighbs.adjacency in - let weight = min (List.length adjacency) fat_value in - List.iter - (fun dest -> - (* perform look ahead of 1 edge to avoid making as expandable nodes - * which have no outgoing edges *) - let next_level = f dest in - let neighborhood = - if List.length next_level = 0 then begin - (* no further outgoing edges, "expand" the node right now *) - let lazy_val = lazy next_level in - ignore (Lazy.force lazy_val); - { adjacency = lazy_val; shown = 0 } - end else - { adjacency = lazy next_level; shown = 0 } - in - (*UriTbl.add adjlist dest { adjacency = lazy (f dest); shown = 0 }*) - UriTbl.add adjlist dest neighborhood) - adjacency; - neighbs.shown <- weight; - fst (HExtlib.split_nth weight adjacency), weight - else begin (* nodes has been expanded at least once *) - let adjacency = Lazy.force neighbs.adjacency in - let total_nodes = List.length adjacency in - if neighbs.shown < total_nodes then begin - (* some more children to show ... *) - let shown_before = neighbs.shown in - neighbs.shown <- min (neighbs.shown + fat_increment) total_nodes; - let new_shown = neighbs.shown - shown_before in - (fst (HExtlib.split_nth new_shown (List.rev adjacency))), new_shown - end else - [], 0 (* all children are already shown *) - end - with Not_found -> - (*eprintf "uri not found: %s\n%!" (UriManager.string_of_uri uri);*) - [], 0 - - let collapse uri (adjlist, _root, f, _invert) = - try - let neighbs = UriTbl.find adjlist uri in - if Lazy.lazy_is_val neighbs.adjacency then - (* do not collapse already collapsed nodes *) - if Lazy.force neighbs.adjacency <> [] then - (* do not collapse nodes with no outgoing edges *) - UriTbl.replace adjlist uri { adjacency = lazy (f uri); shown = 0 } - with Not_found -> - (* do not add a collapsed node if it was not part of the graph *) - () - - let graph_of_fun ?(invert = false) f ~dbd uri = - let f ~dbd uri = - (*eprintf "invoking graph fun on %s...\n%!" (UriManager.string_of_uri uri);*) - let uris = fst (List.split (f ~dbd uri)) in - let uriset = List.fold_right UriSet.add uris UriSet.empty in - let res = UriSet.elements uriset in - (*eprintf "returned uris: %s\n%!"*) - (*(String.concat " " (List.map UriManager.string_of_uri res));*) - res - in - let adjlist = UriTbl.create 17 in - let gen_f = f ~dbd in - UriTbl.add adjlist uri { adjacency = lazy (gen_f uri); shown = 0 }; - let dep_graph = adjlist, uri, gen_f, invert in - let rec rec_expand weight = - function - | [] -> () - | uri :: tl when weight >= fat_value -> () - | uri :: tl -> - let new_nodes, increase = expand uri dep_graph in - rec_expand (weight + increase) (new_nodes @ tl) in - rec_expand 1 [uri]; - dep_graph - - let direct_deps = graph_of_fun direct_deps - let inverse_deps = graph_of_fun ~invert:true inverse_deps - - let expand uri graph = - try - ignore (expand uri graph) - with Not_found -> () -end - diff --git a/matita/components/metadata/metadataDeps.mli b/matita/components/metadata/metadataDeps.mli deleted file mode 100644 index 12b502cd0..000000000 --- a/matita/components/metadata/metadataDeps.mli +++ /dev/null @@ -1,62 +0,0 @@ -(* 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/ - *) - - (** @return the one step direct dependencies of an object, specified by URI - * (that is, the list of objects on which an given one depends) *) -val direct_deps: - dbd:HSql.dbd -> - UriManager.uri -> (UriManager.uri * MetadataTypes.position) list - - (** @return the one step inverse dependencies of an objects, specified by URI - * (that is, the list of objects which depends on a given object) *) -val inverse_deps: - dbd:HSql.dbd -> - UriManager.uri -> (UriManager.uri * MetadataTypes.position) list - -val topological_sort: - dbd:HSql.dbd -> UriManager.uri list -> UriManager.uri list - -val sorted_uris_of_baseuri: - dbd:HSql.dbd -> string -> UriManager.uri list - - (** Representation of a (lazy) dependency graph. - * Imperative data structure. *) -module DepGraph: -sig - type t - - val dummy: t - - val expand: UriManager.uri -> t -> unit (** ignores uri not found *) - val collapse: UriManager.uri -> t -> unit (** ignores uri not found *) - val render: Format.formatter -> t -> unit - - (** @return the transitive closure of direct_deps *) - val direct_deps: dbd:HSql.dbd -> UriManager.uri -> t - - (** @return the transitive closure of inverse_deps *) - val inverse_deps: dbd:HSql.dbd -> UriManager.uri -> t -end - diff --git a/matita/components/metadata/metadataExtractor.ml b/matita/components/metadata/metadataExtractor.ml deleted file mode 100644 index 63db2331d..000000000 --- a/matita/components/metadata/metadataExtractor.ml +++ /dev/null @@ -1,350 +0,0 @@ -(* Copyright (C) 2004, 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$ *) - -open Printf - -open MetadataTypes - -let is_main_pos = function - | `MainConclusion _ - | `MainHypothesis _ -> true - | _ -> false - -let main_pos (pos: position): main_position = - match pos with - | `MainConclusion depth -> `MainConclusion depth - | `MainHypothesis depth -> `MainHypothesis depth - | _ -> assert false - -let next_pos = function - | `MainConclusion _ -> `InConclusion - | `MainHypothesis _ -> `InHypothesis - | pos -> pos - -let string_of_uri = UriManager.string_of_uri - -module OrderedMetadata = - struct - type t = MetadataTypes.metadata - let compare m1 m2 = (* ignore universes in Cic.Type sort *) - match (m1, m2) with - | `Sort (Cic.Type _, pos1), `Sort (Cic.Type _, pos2) -> - Pervasives.compare pos1 pos2 - | _ -> Pervasives.compare m1 m2 - end - -module MetadataSet = Set.Make (OrderedMetadata) -module UriManagerSet = UriManager.UriSet - -module S = MetadataSet - -let unopt = function Some x -> x | None -> assert false - -let incr_depth = function - | `MainConclusion (Some (Eq depth)) -> `MainConclusion (Some (Eq (depth + 1))) - | `MainHypothesis (Some (Eq depth)) -> `MainHypothesis (Some (Eq (depth + 1))) - | _ -> assert false - -let var_has_body uri = - match CicEnvironment.get_obj CicUniv.oblivion_ugraph uri with - | Cic.Variable (_, Some body, _, _, _), _ -> true - | _ -> false - -let compute_term pos term = - let rec aux (pos: position) set = function - | Cic.Var (uri, subst) when var_has_body uri -> - (* handles variables with body as constants *) - aux pos set (Cic.Const (uri, subst)) - | Cic.Rel _ - | Cic.Var _ -> - if is_main_pos pos then - S.add (`Rel (main_pos pos)) set - else - set - | Cic.Meta (_, local_context) -> - List.fold_left - (fun set context -> - match context with - | None -> set - | Some term -> aux (next_pos pos) set term) - set - local_context - | Cic.Sort sort -> - if is_main_pos pos then - S.add (`Sort (sort, main_pos pos)) set - else - set - | Cic.Implicit _ -> assert false - | Cic.Cast (term, ty) -> - (* TODO consider also ty? *) - aux pos set term - | Cic.Prod (_, source, target) -> - (match pos with - | `MainConclusion _ -> - let set = aux (`MainHypothesis (Some (Eq 0))) set source in - aux (incr_depth pos) set target - | `MainHypothesis _ -> - let set = aux `InHypothesis set source in - aux (incr_depth pos) set target - | `InConclusion - | `InHypothesis - | `InBody -> - let set = aux pos set source in - aux pos set target) - | Cic.Lambda (_, source, target) -> - (*assert (not (is_main_pos pos));*) - let set = aux (next_pos pos) set source in - aux (next_pos pos) set target - | Cic.LetIn (_, term, _, target) -> - if is_main_pos pos then - aux pos set (CicSubstitution.subst term target) - else - let set = aux pos set term in - aux pos set target - | Cic.Appl [] -> assert false - | Cic.Appl (hd :: tl) -> - let set = aux pos set hd in - List.fold_left - (fun set term -> aux (next_pos pos) set term) - set tl - | Cic.Const (uri, subst) -> - let set = S.add (`Obj (uri, pos)) set in - List.fold_left - (fun set (_, term) -> aux (next_pos pos) set term) - set subst - | Cic.MutInd (uri, typeno, subst) -> - let uri = UriManager.uri_of_uriref uri typeno None in - let set = S.add (`Obj (uri, pos)) set in - List.fold_left (fun set (_, term) -> aux (next_pos pos) set term) - set subst - | Cic.MutConstruct (uri, typeno, consno, subst) -> - let uri = UriManager.uri_of_uriref uri typeno (Some consno) in - let set = S.add (`Obj (uri, pos)) set in - List.fold_left (fun set (_, term) -> aux (next_pos pos) set term) - set subst - | Cic.MutCase (uri, _, outtype, term, pats) -> - let pos = next_pos pos in - let set = aux pos set term in - let set = aux pos set outtype in - List.fold_left (fun set term -> aux pos set term) set pats - | Cic.Fix (_, funs) -> - let pos = next_pos pos in - List.fold_left - (fun set (_, _, ty, body) -> - let set = aux pos set ty in - aux pos set body) - set funs - | Cic.CoFix (_, funs) -> - let pos = next_pos pos in - List.fold_left - (fun set (_, ty, body) -> - let set = aux pos set ty in - aux pos set body) - set funs - in - aux pos S.empty term - -module OrderedInt = -struct - type t = int - let compare = Pervasives.compare -end - -module IntSet = Set.Make (OrderedInt) - -let compute_metas term = - let rec aux in_hyp ((concl_metas, hyp_metas) as acc) cic = - match cic with - | Cic.Rel _ - | Cic.Sort _ - | Cic.Var _ -> acc - | Cic.Meta (no, local_context) -> - let acc = - if in_hyp then - (concl_metas, IntSet.add no hyp_metas) - else - (IntSet.add no concl_metas, hyp_metas) - in - List.fold_left - (fun set context -> - match context with - | None -> set - | Some term -> aux in_hyp set term) - acc - local_context - | Cic.Implicit _ -> assert false - | Cic.Cast (term, ty) -> - (* TODO consider also ty? *) - aux in_hyp acc term - | Cic.Prod (_, source, target) -> - if in_hyp then - let acc = aux in_hyp acc source in - aux in_hyp acc target - else - let acc = aux true acc source in - aux in_hyp acc target - | Cic.Lambda (_, source, target) -> - let acc = aux in_hyp acc source in - aux in_hyp acc target - | Cic.LetIn (_, term, _, target) -> - aux in_hyp acc (CicSubstitution.subst term target) - | Cic.Appl [] -> assert false - | Cic.Appl (hd :: tl) -> - let acc = aux in_hyp acc hd in - List.fold_left (fun acc term -> aux in_hyp acc term) acc tl - | Cic.Const (_, subst) - | Cic.MutInd (_, _, subst) - | Cic.MutConstruct (_, _, _, subst) -> - List.fold_left (fun acc (_, term) -> aux in_hyp acc term) acc subst - | Cic.MutCase (uri, _, outtype, term, pats) -> - let acc = aux in_hyp acc term in - let acc = aux in_hyp acc outtype in - List.fold_left (fun acc term -> aux in_hyp acc term) acc pats - | Cic.Fix (_, funs) -> - List.fold_left - (fun acc (_, _, ty, body) -> - let acc = aux in_hyp acc ty in - aux in_hyp acc body) - acc funs - | Cic.CoFix (_, funs) -> - List.fold_left - (fun acc (_, ty, body) -> - let acc = aux in_hyp acc ty in - aux in_hyp acc body) - acc funs - in - aux false (IntSet.empty, IntSet.empty) term - - (** type of inductiveType *) -let compute_type pos uri typeno (name, _, ty, constructors) = - let consno = ref 0 in - let type_metadata = - (UriManager.uri_of_uriref uri typeno None, name, (compute_term pos ty)) - in - let constructors_metadata = - List.map - (fun (name, term) -> - incr consno; - let uri = UriManager.uri_of_uriref uri typeno (Some !consno) in - (uri, name, (compute_term pos term))) - constructors - in - type_metadata :: constructors_metadata - -let compute_ind pos ~uri ~types = - let idx = ref ~-1 in - List.map (fun ty -> incr idx; compute_type pos uri !idx ty) types - -let compute (pos:position) ~body ~ty = - let type_metadata = compute_term pos ty in - let body_metadata = - match body with - | None -> S.empty - | Some body -> compute_term `InBody body - in - let uris = - S.fold - (fun metadata uris -> - match metadata with - | `Obj (uri, _) -> UriManagerSet.add uri uris - | _ -> uris) - type_metadata UriManagerSet.empty - in - S.union - (S.filter - (function - | `Obj (uri, _) when UriManagerSet.mem uri uris -> false - | _ -> true) - body_metadata) - type_metadata - -let depth_offset params = - let non p x = not (p x) in - List.length (List.filter (non var_has_body) params) - -let rec compute_var pos uri = - let o, _ = CicEnvironment.get_obj CicUniv.oblivion_ugraph uri in - match o with - | Cic.Variable (_, Some _, _, _, _) -> S.empty - | Cic.Variable (_, None, ty, params, _) -> - let var_metadata = - List.fold_left - (fun metadata uri -> - S.union metadata (compute_var (next_pos pos) uri)) - S.empty - params - in - (match pos with - | `MainHypothesis (Some (Eq 0)) -> - let pos = `MainHypothesis (Some (Eq (depth_offset params))) in - let ty_metadata = compute_term pos ty in - S.union ty_metadata var_metadata - | `InHypothesis -> - let ty_metadata = compute_term pos ty in - S.union ty_metadata var_metadata - | _ -> assert false) - | _ -> assert false - -let compute_obj uri = - let o, _ = CicEnvironment.get_obj CicUniv.oblivion_ugraph uri in - match o with - | Cic.Variable (_, body, ty, params, _) - | Cic.Constant (_, body, ty, params, _) -> - let pos = `MainConclusion (Some (Eq (depth_offset params))) in - let metadata = compute pos ~body ~ty in - let var_metadata = - List.fold_left - (fun metadata uri -> - S.union metadata (compute_var (`MainHypothesis (Some (Eq 0))) uri)) - S.empty - params - in - [ uri, - UriManager.name_of_uri uri, - S.union metadata var_metadata ] - | Cic.InductiveDefinition (types, params, _, _) -> - let pos = `MainConclusion(Some (Eq (depth_offset params))) in - let metadata = compute_ind pos ~uri ~types in - let var_metadata = - List.fold_left - (fun metadata uri -> - S.union metadata (compute_var (`MainHypothesis (Some (Eq 0))) uri)) - S.empty params - in - List.fold_left - (fun acc m -> - (List.map (fun (uri,name,md) -> (uri,name,S.union md var_metadata)) m) - @ acc) - [] metadata - | Cic.CurrentProof _ -> assert false - -let compute_obj uri = - List.map (fun (u, n, md) -> (u, n, S.elements md)) (compute_obj uri) - -let compute ~body ~ty = - S.elements (compute (`MainConclusion (Some (Eq 0))) ~body ~ty) - diff --git a/matita/components/metadata/metadataExtractor.mli b/matita/components/metadata/metadataExtractor.mli deleted file mode 100644 index 68af269a9..000000000 --- a/matita/components/metadata/metadataExtractor.mli +++ /dev/null @@ -1,42 +0,0 @@ -(* Copyright (C) 2004, 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/ - *) - -val compute: - body:Cic.term option -> - ty:Cic.term -> - MetadataTypes.metadata list - - (** @return tuples *) -val compute_obj: - UriManager.uri -> - (UriManager.uri * string * MetadataTypes.metadata list) list - -module IntSet: Set.S with type elt = int - - (** given a term, returns a pair of sets corresponding respectively to the set - * of meta numbers occurring in term's conclusion and the set of meta numbers - * occurring in term's hypotheses *) -val compute_metas: Cic.term -> IntSet.t * IntSet.t - diff --git a/matita/components/metadata/metadataPp.ml b/matita/components/metadata/metadataPp.ml deleted file mode 100644 index 373ec540f..000000000 --- a/matita/components/metadata/metadataPp.ml +++ /dev/null @@ -1,117 +0,0 @@ -(* Copyright (C) 2004, 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$ *) - -open Printf - -open MetadataTypes - -let pp_relation r = - match r with - | Eq i -> sprintf "= %d" i - | Ge i -> sprintf ">= %d" i - | Gt i -> sprintf "> %d" i - | Le i -> sprintf "<= %d" i - | Lt i -> sprintf "< %d" i - -let pp_position = function - | `MainConclusion (Some d) -> sprintf "MainConclusion(%s)" (pp_relation d) - | `MainConclusion None -> sprintf "MainConclusion" - | `MainHypothesis (Some d) -> sprintf "MainHypothesis(%s)" (pp_relation d) - | `MainHypothesis None -> "MainHypothesis" - | `InConclusion -> "InConclusion" - | `InHypothesis -> "InHypothesis" - | `InBody -> "InBody" - -let pp_position_tag = function - | `MainConclusion _ -> mainconcl_pos - | `MainHypothesis _ -> mainhyp_pos - | `InConclusion -> inconcl_pos - | `InHypothesis -> inhyp_pos - | `InBody -> inbody_pos - -let columns_of_position pos = - match pos with - | `MainConclusion (Some (Eq d)) -> `String mainconcl_pos, `Int d - | `MainConclusion None -> `String mainconcl_pos, `Null - | `MainHypothesis (Some (Eq d)) -> `String mainhyp_pos, `Int d - | `MainHypothesis None -> `String mainhyp_pos, `Null - | `InConclusion -> `String inconcl_pos, `Null - | `InHypothesis -> `String inhyp_pos, `Null - | `InBody -> `String inbody_pos, `Null - | _ -> assert false - -(* -let metadata_ns = "http://www.cs.unibo.it/helm/schemas/schema-helm" -let uri_of_pos pos = String.concat "#" [metadata_ns; pp_position pos] -*) - -type t = [ `Int of int | `String of string | `Null ] - -let columns_of_metadata_aux ~about metadata = - let sort s = `String (CicPp.ppsort s) in - let source = `String (UriManager.string_of_uri about) in - let occurrence u = `String (UriManager.string_of_uri u) in - List.fold_left - (fun (sort_cols, rel_cols, obj_cols) metadata -> - match metadata with - | `Sort (s, p) -> - let (p, d) = columns_of_position (p :> position) in - [source; p; d; sort s] :: sort_cols, rel_cols, obj_cols - | `Rel p -> - let (p, d) = columns_of_position (p :> position) in - sort_cols, [source; p; d] :: rel_cols, obj_cols - | `Obj (o, p) -> - let (p, d) = columns_of_position p in - sort_cols, rel_cols, - [source; occurrence o; p; d] :: obj_cols) - ([], [], []) metadata - -let columns_of_metadata metadata = - List.fold_left - (fun (sort_cols, rel_cols, obj_cols) (uri, _, metadata) -> - let (s, r, o) = columns_of_metadata_aux ~about:uri metadata in - (List.append sort_cols s, List.append rel_cols r, List.append obj_cols o)) - ([], [], []) metadata - -let pp_constr = - function - | `Sort (sort, p) -> - sprintf "Sort %s; [%s]" - (CicPp.ppsort sort) (String.concat ";" (List.map pp_position p)) - | `Rel p -> sprintf "Rel [%s]" (String.concat ";" (List.map pp_position p)) - | `Obj (uri, p) -> sprintf "Obj %s; [%s]" - (UriManager.string_of_uri uri) (String.concat ";" (List.map pp_position p)) - -(* -let pp_columns ?(sep = "\n") (sort_cols, rel_cols, obj_cols) = - String.concat sep - ([ "Sort" ] @ List.map Dbi.sdebug (sort_cols :> Dbi.sql_t list list) @ - [ "Rel" ] @ List.map Dbi.sdebug (rel_cols :> Dbi.sql_t list list) @ - [ "Obj" ] @ List.map Dbi.sdebug (obj_cols :> Dbi.sql_t list list)) -*) - - diff --git a/matita/components/metadata/metadataPp.mli b/matita/components/metadata/metadataPp.mli deleted file mode 100644 index cffb24c48..000000000 --- a/matita/components/metadata/metadataPp.mli +++ /dev/null @@ -1,49 +0,0 @@ -(* Copyright (C) 2004, 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/ - *) - -(** metadata -> string *) - -val pp_position: MetadataTypes.position -> string -val pp_position_tag: MetadataTypes.position -> string -val pp_constr: MetadataTypes.constr -> string - -(** Pretty printer and OCamlDBI friendly interface *) - -type t = - [ `Int of int - | `String of string - | `Null ] - - (** @return columns for Sort, Rel, and Obj respectively *) -val columns_of_metadata: - (UriManager.uri * string * MetadataTypes.metadata list) list -> - t list list * t list list * t list list - -(* -val pp_columns: ?sep:string -> t list list * t list list * t list list -> string -*) - -val pp_relation: MetadataTypes.relation -> string - diff --git a/matita/components/metadata/metadataTypes.ml b/matita/components/metadata/metadataTypes.ml deleted file mode 100644 index fd61d717e..000000000 --- a/matita/components/metadata/metadataTypes.ml +++ /dev/null @@ -1,115 +0,0 @@ -(* Copyright (C) 2004, 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$ *) - -let position_prefix = "http://www.cs.unibo.it/helm/schemas/schema-helm#" -(* let position_prefix = "" *) - -let inconcl_pos = position_prefix ^ "InConclusion" -let mainconcl_pos = position_prefix ^ "MainConclusion" -let mainhyp_pos = position_prefix ^ "MainHypothesis" -let inhyp_pos = position_prefix ^ "InHypothesis" -let inbody_pos = position_prefix ^ "InBody" - -type relation = - | Eq of int - | Le of int - | Lt of int - | Ge of int - | Gt of int - -type main_position = - [ `MainConclusion of relation option (* Pi depth *) - | `MainHypothesis of relation option (* Pi depth *) - ] - -type position = - [ main_position - | `InConclusion - | `InHypothesis - | `InBody - ] - -type pi_depth = int - -type metadata = - [ `Sort of Cic.sort * main_position - | `Rel of main_position - | `Obj of UriManager.uri * position - ] - -type constr = - [ `Sort of Cic.sort * main_position list - | `Rel of main_position list - | `Obj of UriManager.uri * position list - ] - -let constr_of_metadata: metadata -> constr = function - | `Sort (sort, pos) -> `Sort (sort, [pos]) - | `Rel pos -> `Rel [pos] - | `Obj (uri, pos) -> `Obj (uri, [pos]) - - (** the name of the tables in the DB *) -let sort_tbl_original = "refSort" -let rel_tbl_original = "refRel" -let obj_tbl_original = "refObj" -let name_tbl_original = "objectName" -let count_tbl_original = "count" -let hits_tbl_original = "hits" - - (** the names currently used *) -let sort_tbl_real = ref sort_tbl_original -let rel_tbl_real = ref rel_tbl_original -let obj_tbl_real = ref obj_tbl_original -let name_tbl_real = ref name_tbl_original -let count_tbl_real = ref count_tbl_original - - (** the exported symbols *) -let sort_tbl () = ! sort_tbl_real ;; -let rel_tbl () = ! rel_tbl_real ;; -let obj_tbl () = ! obj_tbl_real ;; -let name_tbl () = ! name_tbl_real ;; -let count_tbl () = ! count_tbl_real ;; - - (** to use the owned tables *) -let ownerize_tables owner = - sort_tbl_real := ( sort_tbl_original ^ "_" ^ owner) ; - rel_tbl_real := ( rel_tbl_original ^ "_" ^ owner) ; - obj_tbl_real := ( obj_tbl_original ^ "_" ^ owner) ; - name_tbl_real := ( name_tbl_original ^ "_" ^ owner); - count_tbl_real := ( count_tbl_original ^ "_" ^ owner) -;; - -let library_sort_tbl = sort_tbl_original -let library_rel_tbl = rel_tbl_original -let library_obj_tbl = obj_tbl_original -let library_name_tbl = name_tbl_original -let library_count_tbl = count_tbl_original -let library_hits_tbl = hits_tbl_original - -let are_tables_ownerized () = - sort_tbl () <> library_sort_tbl - diff --git a/matita/components/metadata/metadataTypes.mli b/matita/components/metadata/metadataTypes.mli deleted file mode 100644 index 904d837ad..000000000 --- a/matita/components/metadata/metadataTypes.mli +++ /dev/null @@ -1,86 +0,0 @@ -(* Copyright (C) 2004, 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/ - *) - -val position_prefix : string - -val inconcl_pos : string -val mainconcl_pos : string -val mainhyp_pos : string -val inhyp_pos : string -val inbody_pos : string - -type relation = - | Eq of int - | Le of int - | Lt of int - | Ge of int - | Gt of int - -type main_position = - [ `MainConclusion of relation option (* Pi depth *) - | `MainHypothesis of relation option (* Pi depth *) - ] - -type position = - [ main_position - | `InConclusion - | `InHypothesis - | `InBody - ] - -type pi_depth = int - -type metadata = - [ `Sort of Cic.sort * main_position - | `Rel of main_position - | `Obj of UriManager.uri * position - ] - -type constr = - [ `Sort of Cic.sort * main_position list - | `Rel of main_position list - | `Obj of UriManager.uri * position list - ] - -val constr_of_metadata: metadata -> constr - - (** invoke this function to set the current owner. Afterwards the functions - * below will return the name of the table of the set owner *) -val ownerize_tables : string -> unit -val are_tables_ownerized : unit -> bool - -val sort_tbl: unit -> string -val rel_tbl: unit -> string -val obj_tbl: unit -> string -val name_tbl: unit -> string -val count_tbl: unit -> string - -val library_sort_tbl: string -val library_rel_tbl: string -val library_obj_tbl: string -val library_name_tbl: string -val library_count_tbl: string -val library_hits_tbl: string - diff --git a/matita/components/metadata/sqlStatements.ml b/matita/components/metadata/sqlStatements.ml deleted file mode 100644 index f96b877a4..000000000 --- a/matita/components/metadata/sqlStatements.ml +++ /dev/null @@ -1,221 +0,0 @@ -(* Copyright (C) 2004-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/ - *) - -(* $Id$ *) - -open Printf;; -type tbl = [ `RefObj| `RefSort| `RefRel| `ObjectName| `Hits| `Count] - -(* TABLES *) - -let sprintf_refObj_format name = [ -sprintf "CREATE TABLE %s ( - source varchar(255) not null, - h_occurrence varchar(255) not null, - h_position varchar(62) not null, - h_depth integer -);" name] - -let sprintf_refSort_format name = [ -sprintf "CREATE TABLE %s ( - source varchar(255) not null, - h_position varchar(62) not null, - h_depth integer not null, - h_sort varchar(5) not null -);" name] - -let sprintf_refRel_format name = [ -sprintf "CREATE TABLE %s ( - source varchar(255) not null, - h_position varchar(62) not null, - h_depth integer not null -);" name] - -let sprintf_objectName_format name = [ -sprintf "CREATE TABLE %s ( - source varchar(255) not null, - value varchar(255) not null -);" name] - -let sprintf_hits_format name = [ -sprintf "CREATE TABLE %s ( - source varchar(255) not null, - no integer not null -);" name] - -let sprintf_count_format name = [ -sprintf "CREATE TABLE %s ( - source varchar(255) unique not null, - conclusion smallint(6) not null, - hypothesis smallint(6) not null, - statement smallint(6) not null -);" name] - -let sprintf_refObj_drop name = [sprintf "DROP TABLE %s;" name] - -let sprintf_refSort_drop name = [sprintf "DROP TABLE %s;" name] - -let sprintf_refRel_drop name = [sprintf "DROP TABLE %s;" name] - -let sprintf_objectName_drop name = [sprintf "DROP TABLE %s;" name] - -let sprintf_hits_drop name = [sprintf "DROP TABLE %s;" name] - -let sprintf_count_drop name = [sprintf "DROP TABLE %s;" name] - -(* INDEXES *) - -let sprintf_refObj_index name = [ -sprintf "CREATE INDEX %s_index ON %s (source,h_occurrence,h_position);" name name; -(*sprintf "CREATE INDEX %s_index ON %s (source(219),h_occurrence(219),h_position);" name name;*) -sprintf "CREATE INDEX %s_occurrence ON %s (h_occurrence);" name name ] - -let sprintf_refSort_index name = [ -sprintf "CREATE INDEX %s_index ON %s (source,h_sort,h_position,h_depth);" name name] - -let sprintf_objectName_index name = [ -sprintf "CREATE INDEX %s_value ON %s (value);" name name] - -let sprintf_hits_index name = [ -sprintf "CREATE INDEX %s_source ON %s (source);" name name ; -sprintf "CREATE INDEX %s_no ON %s (no);" name name] - -let sprintf_count_index name = [ -sprintf "CREATE INDEX %s_conclusion ON %s (conclusion);" name name; -sprintf "CREATE INDEX %s_hypothesis ON %s (hypothesis);" name name; -sprintf "CREATE INDEX %s_statement ON %s (statement);" name name] - -let sprintf_refRel_index name = [ -sprintf "CREATE INDEX %s_index ON %s (source,h_position,h_depth);" name name] - -let format_drop name sufix dtype dbd = - if HSql.isMysql dtype dbd then - (sprintf "DROP INDEX %s_%s ON %s;" name sufix name) - else - (sprintf "DROP INDEX %s_%s;" name sufix);; - -let sprintf_refObj_index_drop name dtype dbd= [(format_drop name "index" dtype dbd)] - -let sprintf_refSort_index_drop name dtype dbd = [(format_drop name "index" dtype dbd)] - -let sprintf_objectName_index_drop name dtype dbd = [(format_drop name "value" dtype dbd)] - -let sprintf_hits_index_drop name dtype dbd = [ -(format_drop name "source" dtype dbd); -(format_drop name "no" dtype dbd)] - -let sprintf_count_index_drop name dtype dbd = [ -(format_drop name "source" dtype dbd); -(format_drop name "conclusion" dtype dbd); -(format_drop name "hypothesis" dtype dbd); -(format_drop name "statement" dtype dbd)] - -let sprintf_refRel_index_drop name dtype dbd = - [(format_drop name "index" dtype dbd)] - -let sprintf_rename_table oldname newname = [ -sprintf "RENAME TABLE %s TO %s;" oldname newname -] - - -(* FUNCTIONS *) - -let get_table_format t named = - match t with - | `RefObj -> sprintf_refObj_format named - | `RefSort -> sprintf_refSort_format named - | `RefRel -> sprintf_refRel_format named - | `ObjectName -> sprintf_objectName_format named - | `Hits -> sprintf_hits_format named - | `Count -> sprintf_count_format named - -let get_index_format t named = - match t with - | `RefObj -> sprintf_refObj_index named - | `RefSort -> sprintf_refSort_index named - | `RefRel -> sprintf_refRel_index named - | `ObjectName -> sprintf_objectName_index named - | `Hits -> sprintf_hits_index named - | `Count -> sprintf_count_index named - -let get_table_drop t named = - match t with - | `RefObj -> sprintf_refObj_drop named - | `RefSort -> sprintf_refSort_drop named - | `RefRel -> sprintf_refRel_drop named - | `ObjectName -> sprintf_objectName_drop named - | `Hits -> sprintf_hits_drop named - | `Count -> sprintf_count_drop named - -let get_index_drop t named dtype dbd = - match t with - | `RefObj -> sprintf_refObj_index_drop named dtype dbd - | `RefSort -> sprintf_refSort_index_drop named dtype dbd - | `RefRel -> sprintf_refRel_index_drop named dtype dbd - | `ObjectName -> sprintf_objectName_index_drop named dtype dbd - | `Hits -> sprintf_hits_index_drop named dtype dbd - | `Count -> sprintf_count_index_drop named dtype dbd - -let create_tables l = - List.fold_left (fun s (name,table) -> s @ get_table_format table name) [] l - -let create_indexes l = - List.fold_left (fun s (name,table) -> s @ get_index_format table name) [] l - -let drop_tables l = - List.fold_left (fun s (name,table) -> s @ get_table_drop table name) [] l - -let drop_indexes l dtype dbd= - List.fold_left (fun s (name,table) -> s @ get_index_drop table name dtype dbd) [] l - -let rename_tables l = - List.fold_left (fun s (o,n) -> s @ sprintf_rename_table o n) [] l - -let fill_hits refObj hits = - [ sprintf - "INSERT INTO %s - SELECT h_occurrence, COUNT(source) - FROM %s - GROUP BY h_occurrence;" - hits refObj ] - - -let move_content (name1, tbl1) (name2, tbl2) buri dtype dbd = - let escape s = - Pcre.replace ~pat:"([^\\\\])_" ~templ:"$1\\_" (HSql.escape dtype dbd s) - in - assert (tbl1 = tbl2); - sprintf - "INSERT INTRO %s SELECT * FROM %s WHERE source LIKE \"%s%%\";" - name2 name1 (escape buri) - -let direct_deps refObj uri dtype dbd = - sprintf "SELECT * FROM %s WHERE source = \"%s\";" - refObj (HSql.escape dtype dbd (UriManager.string_of_uri uri)) - -let inverse_deps refObj uri dtype dbd = - sprintf "SELECT * FROM %s WHERE h_occurrence = \"%s\";" - refObj (HSql.escape dtype dbd (UriManager.string_of_uri uri)) - diff --git a/matita/components/metadata/sqlStatements.mli b/matita/components/metadata/sqlStatements.mli deleted file mode 100644 index ca780ee15..000000000 --- a/matita/components/metadata/sqlStatements.mli +++ /dev/null @@ -1,59 +0,0 @@ -(* Copyright (C) 2004-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/ - *) - -(** table shape kinds *) -type tbl = [ `RefObj| `RefSort| `RefRel| `ObjectName| `Hits| `Count] - -(** all functions below return either an SQL statement or a list of SQL - * statements. - * For functions taking as argument (string * tbl) list, the meaning is a list - * of pairs ; where the type specify the desired kind of - * table and name the desired name (e.g. create a `RefObj like table name - * refObj_NEW) *) - -val create_tables: (string * tbl) list -> string list -val create_indexes: (string * tbl) list -> string list -val drop_tables: (string * tbl) list -> string list -val drop_indexes: (string * tbl) list -> HSql.dbtype -> HSql.dbd -> string list -val rename_tables: (string * string) list -> string list - -(** @param refObj name of the refObj table - * @param hits name of the hits table *) -val fill_hits: string -> string -> string list - -(** move content [t1] [t2] [buri] - * moves all the tuples with 'source' that match regex '^buri' from t1 to t2 - * *) -val move_content: (string * tbl) -> (string * tbl) -> string -> HSql.dbtype -> - HSql.dbd -> string - -(** @param refObj name of the refObj table - * @param src uri of the desired 'source' field *) -val direct_deps: string -> UriManager.uri -> HSql.dbtype -> HSql.dbd -> string - -(** @param refObj name of the refObj table - * @param src uri of the desired 'h_occurrence' field *) -val inverse_deps: string -> UriManager.uri -> HSql.dbtype -> HSql.dbd -> string - diff --git a/matita/components/ng_cic_content/nTermCicContent.ml b/matita/components/ng_cic_content/nTermCicContent.ml index 5cfda009c..26d7e98fb 100644 --- a/matita/components/ng_cic_content/nTermCicContent.ml +++ b/matita/components/ng_cic_content/nTermCicContent.ml @@ -34,6 +34,8 @@ let debug_print s = if debug then prerr_endline (Lazy.force s) else () type id = string +let hide_coercions = ref true;; + (* type interpretation_id = int @@ -143,7 +145,7 @@ let nast_of_cic0 status | Some n -> idref (Ast.Num (string_of_int n, -1)) | None -> let args = - if not !Acic2content.hide_coercions then args + if not !hide_coercions then args else match NCicCoercion.match_coercion status ~metasenv ~context ~subst t diff --git a/matita/components/ng_cic_content/nTermCicContent.mli b/matita/components/ng_cic_content/nTermCicContent.mli index 2a1d7bcc7..38c0ebf3c 100644 --- a/matita/components/ng_cic_content/nTermCicContent.mli +++ b/matita/components/ng_cic_content/nTermCicContent.mli @@ -85,6 +85,8 @@ val nast_of_cic : type id = string +val hide_coercions: bool ref + val nmap_sequent: #NCicCoercion.status -> metasenv:NCic.metasenv -> subst:NCic.substitution -> int * NCic.conjecture -> diff --git a/matita/components/ng_kernel/nUri.ml b/matita/components/ng_kernel/nUri.ml index 5d8107294..e92be39e1 100644 --- a/matita/components/ng_kernel/nUri.ml +++ b/matita/components/ng_kernel/nUri.ml @@ -20,6 +20,10 @@ let name_of_uri (_, uri) = Filename.chop_extension name ;; +let baseuri_of_uri (_,uri) = + Filename.dirname uri +;; + module OrderedStrings = struct type t = string diff --git a/matita/components/ng_kernel/nUri.mli b/matita/components/ng_kernel/nUri.mli index 323da90c3..a133c04c8 100644 --- a/matita/components/ng_kernel/nUri.mli +++ b/matita/components/ng_kernel/nUri.mli @@ -15,6 +15,7 @@ type uri val string_of_uri: uri -> string val name_of_uri: uri -> string +val baseuri_of_uri: uri -> string val uri_of_string: string -> uri val eq: uri -> uri -> bool val compare: uri -> uri -> int diff --git a/matita/components/ng_library/.depend b/matita/components/ng_library/.depend index e379b9fc6..48127a325 100644 --- a/matita/components/ng_library/.depend +++ b/matita/components/ng_library/.depend @@ -1,9 +1,3 @@ -nCic2OCic.cmi: -oCic2NCic.cmi: nCicLibrary.cmi: -nCic2OCic.cmo: nCic2OCic.cmi -nCic2OCic.cmx: nCic2OCic.cmi -oCic2NCic.cmo: oCic2NCic.cmi -oCic2NCic.cmx: oCic2NCic.cmi -nCicLibrary.cmo: oCic2NCic.cmi nCic2OCic.cmi nCicLibrary.cmi -nCicLibrary.cmx: oCic2NCic.cmx nCic2OCic.cmx nCicLibrary.cmi +nCicLibrary.cmo: nCicLibrary.cmi +nCicLibrary.cmx: nCicLibrary.cmi diff --git a/matita/components/ng_library/.depend.opt b/matita/components/ng_library/.depend.opt index e379b9fc6..48127a325 100644 --- a/matita/components/ng_library/.depend.opt +++ b/matita/components/ng_library/.depend.opt @@ -1,9 +1,3 @@ -nCic2OCic.cmi: -oCic2NCic.cmi: nCicLibrary.cmi: -nCic2OCic.cmo: nCic2OCic.cmi -nCic2OCic.cmx: nCic2OCic.cmi -oCic2NCic.cmo: oCic2NCic.cmi -oCic2NCic.cmx: oCic2NCic.cmi -nCicLibrary.cmo: oCic2NCic.cmi nCic2OCic.cmi nCicLibrary.cmi -nCicLibrary.cmx: oCic2NCic.cmx nCic2OCic.cmx nCicLibrary.cmi +nCicLibrary.cmo: nCicLibrary.cmi +nCicLibrary.cmx: nCicLibrary.cmi diff --git a/matita/components/ng_library/Makefile b/matita/components/ng_library/Makefile index e5cd7fb1f..861f19acd 100644 --- a/matita/components/ng_library/Makefile +++ b/matita/components/ng_library/Makefile @@ -2,8 +2,6 @@ PACKAGE = ng_library PREDICATES = INTERFACE_FILES = \ - nCic2OCic.mli \ - oCic2NCic.mli \ nCicLibrary.mli IMPLEMENTATION_FILES = \ @@ -14,10 +12,10 @@ EXTRA_OBJECTS_TO_CLEAN = %.cmi: OCAMLOPTIONS += -w Ae %.cmx: OCAMLOPTIONS += -w Ae -all: rt check +all: %: %.ml $(PACKAGE).cma $(OCAMLC) -package helm-$(PACKAGE) -linkpkg -o $@ $< -all.opt opt: rt.opt check.opt +all.opt opt: %.opt: %.ml $(PACKAGE).cmxa $(OCAMLOPT) -package helm-$(PACKAGE) -linkpkg -o $@ $< diff --git a/matita/components/ng_library/check.ml b/matita/components/ng_library/check.ml deleted file mode 100644 index 8f014d4d2..000000000 --- a/matita/components/ng_library/check.ml +++ /dev/null @@ -1,216 +0,0 @@ -(* - ||M|| This file is part of HELM, an Hypertextual, Electronic - ||A|| Library of Mathematics, developed at the Computer Science - ||T|| Department, University of Bologna, Italy. - ||I|| - ||T|| HELM is free software; you can redistribute it and/or - ||A|| modify it under the terms of the GNU General Public License - \ / version 2 or (at your option) any later version. - \ / This software is distributed as is, NO WARRANTY. - V_______________________________________________________________ *) - -(* $Id$ *) - -let debug = true -let ignore_exc = false -let rank_all_dependencies = false -let trust_environment = false -let print_object = true - -let indent = ref 0;; - -let load_graph, get_graph = - let oldg = ref CicUniv.empty_ugraph in - (function uri -> - let _,g = CicEnvironment.get_obj !oldg uri in - oldg := g), - (function _ -> !oldg) -;; - -let logger = - let do_indent () = String.make !indent ' ' in - (function - | `Start_type_checking s -> - if debug then - prerr_endline (do_indent () ^ "Start: " ^ NUri.string_of_uri s); - incr indent - | `Type_checking_completed s -> - decr indent; - if debug then - prerr_endline (do_indent () ^ "End: " ^ NUri.string_of_uri s) - | `Type_checking_interrupted s -> - decr indent; - if debug then - prerr_endline (do_indent () ^ "Break: " ^ NUri.string_of_uri s) - | `Type_checking_failed s -> - decr indent; - if debug then - prerr_endline (do_indent () ^ "Fail: " ^ NUri.string_of_uri s) - | `Trust_obj s -> - if debug then - prerr_endline (do_indent () ^ "Trust: " ^ NUri.string_of_uri s)) -;; - -let mk_type n = - if n = 0 then - [`Type, NUri.uri_of_string ("cic:/matita/pts/Type.univ")] - else - [`Type, NUri.uri_of_string ("cic:/matita/pts/Type"^string_of_int n^".univ")] -;; -let mk_cprop n = - if n = 0 then - [`CProp, NUri.uri_of_string ("cic:/matita/pts/Type.univ")] - else - [`CProp, NUri.uri_of_string ("cic:/matita/pts/Type"^string_of_int n^".univ")] -;; - - -let _ = - let do_old_logging = ref true in - HelmLogger.register_log_callback - (fun ?append_NL html_msg -> - if !do_old_logging then - prerr_endline (HelmLogger.string_of_html_msg html_msg)); - CicParser.impredicative_set := false; - NCicTypeChecker.set_logger logger; - Helm_registry.load_from "conf.xml"; - let alluris = - try - let s = Sys.argv.(1) in - if s = "-alluris" then - begin - let uri_re = Str.regexp ".*\\(ind\\|con\\)$" in - let uris = Http_getter.getalluris () in - let alluris = List.filter (fun u -> Str.string_match uri_re u 0) uris in - let oc = open_out "alluris.txt" in - List.iter (fun s -> output_string oc (s^"\n")) alluris; - close_out oc; - [] - end - else [s] - with Invalid_argument _ -> - let r = ref [] in - let ic = open_in "alluris.txt" in - try while true do r := input_line ic :: !r; done; [] - with _ -> List.rev !r - in - let alluris = - HExtlib.filter_map - (fun u -> try Some (UriManager.uri_of_string u) with _ -> None) alluris - in - (* brutal *) - prerr_endline "computing graphs to load..."; - let roots_alluris = - if not rank_all_dependencies then - alluris - else ( - let dbd = HSql.quick_connect (LibraryDb.parse_dbd_conf ()) in - MetadataTypes.ownerize_tables (Helm_registry.get "matita.owner"); - let uniq l = - HExtlib.list_uniq (List.sort UriManager.compare l) in - let who_uses u = - uniq (List.map (fun (uri,_) -> UriManager.strip_xpointer uri) - (MetadataDeps.inverse_deps ~dbd u)) in - let rec fix acc l = - let acc, todo = - List.fold_left (fun (acc,todo) x -> - let w = who_uses x in - if w = [] then (x::acc,todo) else (acc,uniq (todo@w))) - (acc,[]) l - in - if todo = [] then uniq acc else fix acc todo - in - fix [] alluris) - in - prerr_endline "generating Coq graphs..."; - CicEnvironment.set_trust (fun _ -> trust_environment); - List.iter - (fun u -> - prerr_endline (" - " ^ UriManager.string_of_uri u); - try - ignore(CicTypeChecker.typecheck u); - with - | CicTypeChecker.AssertFailure s - | CicTypeChecker.TypeCheckerFailure s -> - prerr_endline (Lazy.force s); - assert false - ) roots_alluris; - prerr_endline "loading..."; - List.iter - (fun u -> - prerr_endline (" - "^UriManager.string_of_uri u); - try load_graph u with exn -> ()) - roots_alluris; - prerr_endline "finished...."; - let lll, uuu =(CicUniv.do_rank (get_graph ())) in - CicUniv.print_ugraph (get_graph ()); - let lll = List.sort compare lll in - List.iter (fun k -> - prerr_endline (CicUniv.string_of_universe k ^ " = " ^ string_of_int (CicUniv.get_rank k))) uuu; - let _ = - try - let rec aux = function - | a::(b::_ as tl) -> - NCicEnvironment.add_lt_constraint (mk_type a) (mk_type b); - NCicEnvironment.add_lt_constraint (mk_type a) (mk_cprop b); - aux tl - | _ -> () - in - aux lll - with NCicEnvironment.BadConstraint s as e -> - prerr_endline (Lazy.force s); raise e - in - prerr_endline "ranked...."; - prerr_endline (NCicEnvironment.pp_constraints ()); - HExtlib.profiling_enabled := false; - List.iter (fun uu -> - let uu= OCic2NCic.nuri_of_ouri uu in - indent := 0; - let o = NCicLibrary.get_obj uu in - if print_object then prerr_endline (NCicPp.ppobj o); - try - NCicEnvironment.check_and_add_obj o - with - exn -> - let rec aux = function - | NCicTypeChecker.AssertFailure s - | NCicTypeChecker.TypeCheckerFailure s - | NCicEnvironment.ObjectNotFound s - | NCicEnvironment.BadConstraint s as e-> - prerr_endline ("######### " ^ Lazy.force s); - if not ignore_exc then raise e - | NCicEnvironment.BadDependency (s,x) as e -> - prerr_endline ("######### " ^ Lazy.force s); - aux x; - if not ignore_exc then raise e - | e -> raise e - in - aux exn - ) - alluris; - NCicEnvironment.invalidate (); - Gc.compact (); - HExtlib.profiling_enabled := true; - NCicTypeChecker.set_logger (fun _ -> ()); - do_old_logging := false; - prerr_endline "typechecking, first with the new and then with the old kernel"; - let prima = Unix.gettimeofday () in - List.iter - (fun u -> - let u= OCic2NCic.nuri_of_ouri u in - indent := 0; - ignore (NCicEnvironment.get_checked_obj u)) - alluris; - let dopo = Unix.gettimeofday () in - Gc.compact (); - let dopo2 = Unix.gettimeofday () in - Printf.eprintf "NEW typing: %3.2f, gc: %3.2f\n%!" (dopo -. prima) (dopo2 -. dopo); - CicEnvironment.invalidate (); - Gc.compact (); - let prima = Unix.gettimeofday () in - List.iter (fun u -> ignore (CicTypeChecker.typecheck u)) alluris; - let dopo = Unix.gettimeofday () in - Gc.compact (); - let dopo2 = Unix.gettimeofday () in - Printf.eprintf "OLD typing: %3.2f, gc: %3.2f\n%!" (dopo -. prima) (dopo2 -. dopo) -;; diff --git a/matita/components/ng_library/nCic2OCic.ml b/matita/components/ng_library/nCic2OCic.ml deleted file mode 100644 index 1006d03c6..000000000 --- a/matita/components/ng_library/nCic2OCic.ml +++ /dev/null @@ -1,117 +0,0 @@ -(* - ||M|| This file is part of HELM, an Hypertextual, Electronic - ||A|| Library of Mathematics, developed at the Computer Science - ||T|| Department, University of Bologna, Italy. - ||I|| - ||T|| HELM is free software; you can redistribute it and/or - ||A|| modify it under the terms of the GNU General Public License - \ / version 2 or (at your option) any later version. - \ / This software is distributed as is, NO WARRANTY. - V_______________________________________________________________ *) - -(* $Id$ *) - -let ouri_of_nuri u = UriManager.uri_of_string (NUri.string_of_uri u);; - -let ouri_of_reference (NReference.Ref (u,_)) = ouri_of_nuri u;; - -let cprop = [`CProp, NUri.uri_of_string ("cic:/matita/pts/Type.univ")];; - -let nn_2_on = function - | "_" -> Cic.Anonymous - | s -> Cic.Name s -;; - -let convert_term uri n_fl t = - let rec convert_term k = function (* pass k along *) - | NCic.Rel i -> Cic.Rel i - | NCic.Meta _ -> assert false - | NCic.Appl l -> Cic.Appl (List.map (convert_term k) l) - | NCic.Prod (n,s,t) -> - Cic.Prod (nn_2_on n,convert_term k s, convert_term (k+1) t) - | NCic.Lambda (n,s,t) -> - Cic.Lambda(nn_2_on n,convert_term k s, convert_term (k+1) t) - | NCic.LetIn (n,ty_s,s,t) -> - Cic.LetIn (nn_2_on n,convert_term k s,convert_term k ty_s, convert_term (k+1) t) - | NCic.Sort NCic.Prop -> Cic.Sort Cic.Prop - | NCic.Sort (NCic.Type u) when - (* BUG HERE: I should use NCicEnvironment.universe_eq, but I do not - want to add this recursion between the modules *) - (*NCicEnvironment.universe_eq*) u=cprop -> Cic.Sort (Cic.CProp (CicUniv.fresh ())) - | NCic.Sort (NCic.Type _) -> Cic.Sort (Cic.Type (CicUniv.fresh ())) - | NCic.Implicit _ -> assert false - | NCic.Const (NReference.Ref (u,NReference.Ind (_,i,_))) -> - Cic.MutInd (ouri_of_nuri u,i,[]) - | NCic.Const (NReference.Ref (u,NReference.Con (i,j,_))) -> - Cic.MutConstruct (ouri_of_nuri u,i,j,[]) - | NCic.Const (NReference.Ref (u,NReference.Def _)) - | NCic.Const (NReference.Ref (u,NReference.Decl)) -> - Cic.Const (ouri_of_nuri u,[]) - | NCic.Match (NReference.Ref (u,NReference.Ind (_,i,_)),oty,t,pl) -> - Cic.MutCase (ouri_of_nuri u,i, convert_term k oty, convert_term k t, - List.map (convert_term k) pl) - | NCic.Const (NReference.Ref (u,NReference.Fix (i,_,_))) - | NCic.Const (NReference.Ref (u,NReference.CoFix i)) -> - if NUri.eq u uri then - Cic.Rel (n_fl - i + k) - else - let ouri = ouri_of_nuri u in - let ouri = - UriManager.uri_of_string - (UriManager.buri_of_uri ouri ^ "/" ^ - UriManager.name_of_uri ouri ^ string_of_int i ^ ".con") in - Cic.Const (ouri,[]) - | _ -> assert false - in - convert_term 0 t -;; - -let convert_fix is_fix uri k fl = - let n_fl = List.length fl in - if is_fix then - let fl = - List.map - (fun (_, name,recno,ty,bo) -> - name, recno, convert_term uri n_fl ty, convert_term uri n_fl bo) - fl - in - Cic.Fix (k, fl) - else - let fl = - List.map - (fun (_, name,_,ty,bo) -> - name, convert_term uri n_fl ty, convert_term uri n_fl bo) - fl - in - Cic.CoFix (k, fl) -;; - -let convert_nobj = function - | u,_,_,_,NCic.Constant (_, name, Some bo, ty, _) -> - [ouri_of_nuri u,Cic.Constant - (name, Some (convert_term u 0 bo), convert_term u 0 ty, [],[])] - | u,_,_,_,NCic.Constant (_, name, None, ty, _) -> - [ouri_of_nuri u,Cic.Constant (name, None, convert_term u 0 ty, [],[])] - | u,_,_,_,NCic.Fixpoint (is_fix, fl, _) -> - List.map - (fun nth -> - let name = - UriManager.name_of_uri (ouri_of_nuri u) ^ string_of_int nth in - let buri = UriManager.buri_of_uri (ouri_of_nuri u) in - let uri = UriManager.uri_of_string (buri ^"/"^name^".con") in - uri, - Cic.Constant (name, - Some (convert_fix is_fix u nth fl), - convert_term u 0 (let _,_,_,ty,_ = List.hd fl in ty), [], [])) - (let rec seq = function 0 -> [0]|n -> n::seq (n-1) in - seq (List.length fl-1)) - | u,_,_,_,NCic.Inductive (inductive,leftno,itl,_) -> - let itl = - List.map - (function (_,name,ty,cl) -> - let cl=List.map (function (_,name,ty) -> name,convert_term u 0 ty) cl in - name,inductive,convert_term u 0 ty,cl - ) itl - in - [ouri_of_nuri u, Cic.InductiveDefinition (itl,[],leftno,[])] -;; diff --git a/matita/components/ng_library/nCic2OCic.mli b/matita/components/ng_library/nCic2OCic.mli deleted file mode 100644 index db6349ee7..000000000 --- a/matita/components/ng_library/nCic2OCic.mli +++ /dev/null @@ -1,18 +0,0 @@ -(* - ||M|| This file is part of HELM, an Hypertextual, Electronic - ||A|| Library of Mathematics, developed at the Computer Science - ||T|| Department, University of Bologna, Italy. - ||I|| - ||T|| HELM is free software; you can redistribute it and/or - ||A|| modify it under the terms of the GNU General Public License - \ / version 2 or (at your option) any later version. - \ / This software is distributed as is, NO WARRANTY. - V_______________________________________________________________ *) - -(* $Id$ *) - -val ouri_of_nuri: NUri.uri -> UriManager.uri - -val ouri_of_reference: NReference.reference -> UriManager.uri - -val convert_nobj: NCic.obj -> (UriManager.uri * Cic.obj) list diff --git a/matita/components/ng_library/nCicLibrary.ml b/matita/components/ng_library/nCicLibrary.ml index 7cef1e3de..8620f8cd4 100644 --- a/matita/components/ng_library/nCicLibrary.ml +++ b/matita/components/ng_library/nCicLibrary.ml @@ -385,15 +385,8 @@ let get_obj u = with Sys_error _ -> try NUri.UriMap.find u !cache with Not_found -> - let ouri = NCic2OCic.ouri_of_nuri u in - try - let o,_ = CicEnvironment.get_obj CicUniv.oblivion_ugraph ouri in - let l = OCic2NCic.convert_obj ouri o in - List.iter (fun (u,_,_,_,_ as o) -> cache:= NUri.UriMap.add u o !cache) l; - HExtlib.list_last l - with CicEnvironment.Object_not_found u -> - raise (NCicEnvironment.ObjectNotFound - (lazy (NUri.string_of_uri (OCic2NCic.nuri_of_ouri u)))) + raise (NCicEnvironment.ObjectNotFound + (lazy (NUri.string_of_uri u))) ;; let clear_cache () = cache := NUri.UriMap.empty;; diff --git a/matita/components/ng_library/oCic2NCic.ml b/matita/components/ng_library/oCic2NCic.ml deleted file mode 100644 index 50b3207e8..000000000 --- a/matita/components/ng_library/oCic2NCic.ml +++ /dev/null @@ -1,883 +0,0 @@ -(* - ||M|| This file is part of HELM, an Hypertextual, Electronic - ||A|| Library of Mathematics, developed at the Computer Science - ||T|| Department, University of Bologna, Italy. - ||I|| - ||T|| HELM is free software; you can redistribute it and/or - ||A|| modify it under the terms of the GNU General Public License - \ / version 2 or (at your option) any later version. - \ / This software is distributed as is, NO WARRANTY. - V_______________________________________________________________ *) - -(* $Id$ *) - -module Ref = NReference - -let nuri_of_ouri o = NUri.uri_of_string (UriManager.string_of_uri o);; - -let mk_type n = - [`Type, NUri.uri_of_string ("cic:/matita/pts/Type"^string_of_int n^".univ")] -;; - -let mk_cprop n = - [`CProp, NUri.uri_of_string ("cic:/matita/pts/Type"^string_of_int n^".univ")] -;; - -let is_proof_irrelevant context ty = - match - CicReduction.whd context - (fst (CicTypeChecker.type_of_aux' [] context ty CicUniv.oblivion_ugraph)) - with - Cic.Sort Cic.Prop -> true - | Cic.Sort _ -> false - | _ -> assert false -;; - -exception InProp;; - -let get_relevance ty = - let rec aux context ty = - match CicReduction.whd context ty with - Cic.Prod (n,s,t) -> - not (is_proof_irrelevant context s)::aux (Some (n,Cic.Decl s)::context) t - | _ -> [] - in aux [] ty -(* | ty -> if is_proof_irrelevant context ty then raise InProp else [] - in - try aux [] ty - with InProp -> []*) -;; - -(* porcatissima *) -type reference = Ref of NUri.uri * NReference.spec -let reference_of_ouri u indinfo = - let u = nuri_of_ouri u in - NReference.reference_of_string - (NReference.string_of_reference (Obj.magic (Ref (u,indinfo)))) -;; - -type ctx = - | Ce of (NCic.hypothesis * NCic.obj list) Lazy.t - | Fix of (Ref.reference * string * NCic.term) Lazy.t - -let strictify = - function - Ce l -> `Ce (Lazy.force l) - | Fix l -> `Fix (Lazy.force l) -;; - -let count_vars vars = - List.length - (List.filter (fun v -> - match fst (CicEnvironment.get_obj CicUniv.oblivion_ugraph v) with - Cic.Variable (_,Some _,_,_,_) -> false - | Cic.Variable (_,None,_,_,_) -> true - | _ -> assert false) vars) -;; - - -(***** A function to restrict the context of a term getting rid of unsed - variables *******) - -let restrict octx ctx ot = - let odummy = Cic.Implicit None in - let dummy = NCic.Meta (~-1,(0,NCic.Irl 0)) in - let rec aux m acc ot t = - function - [],[] -> (ot,t),acc - | ohe::otl as octx,he::tl -> - if CicTypeChecker.does_not_occur octx 0 1 ot then - aux (m+1) acc (CicSubstitution.subst odummy ot) - (NCicSubstitution.subst dummy t) (otl,tl) - else - (match ohe,strictify he with - None,_ -> assert false - | Some (name,Cic.Decl oty),`Ce ((name', NCic.Decl ty),objs) -> - aux (m+1) ((m+1,objs,None)::acc) (Cic.Lambda (name,oty,ot)) - (NCic.Lambda (name',ty,t)) (otl,tl) - | Some (name,Cic.Decl oty),`Fix (ref,name',ty) -> - aux (m+1) ((m+1,[],Some ref)::acc) (Cic.Lambda (name,oty,ot)) - (NCic.Lambda (name',ty,t)) (otl,tl) - | Some (name,Cic.Def (obo,oty)),`Ce ((name', NCic.Def (bo,ty)),objs) -> - aux (m+1) ((m+1,objs,None)::acc) (Cic.LetIn (name,obo,oty,ot)) - (NCic.LetIn (name',bo,ty,t)) (otl,tl) - | _,_ -> assert false) - | _,_ -> assert false in - let rec split_lambdas_and_letins octx ctx infos (ote,te) = - match infos, ote, te with - ([], _, _) -> octx,ctx,ote - | ((_,objs,None)::tl, Cic.Lambda(name,oso,ota), NCic.Lambda(name',so,ta)) -> - split_lambdas_and_letins ((Some(name,(Cic.Decl oso)))::octx) - (Ce (lazy ((name',NCic.Decl so),objs))::ctx) tl (ota,ta) - | ((_,_,Some r)::tl,Cic.Lambda(name,oso,ota),NCic.Lambda(name',so,ta)) -> - split_lambdas_and_letins ((Some(name,(Cic.Decl oso)))::octx) - (Fix (lazy (r,name',so))::ctx) tl (ota,ta) - | ((_,objs,None)::tl,Cic.LetIn(name,obo,oty,ota),NCic.LetIn(nam',bo,ty,ta))-> - split_lambdas_and_letins ((Some (name,(Cic.Def (obo,oty))))::octx) - (Ce (lazy ((nam',NCic.Def (bo,ty)),objs))::ctx) tl (ota,ta) - | (_, _, _) -> assert false - in - let long_t,infos = aux 0 [] ot dummy (octx,ctx) in - let clean_octx,clean_ctx,clean_ot= split_lambdas_and_letins [] [] infos long_t - in -(*prerr_endline ("RESTRICT PRIMA: " ^ CicPp.pp ot (List.map (function None -> None | Some (name,_) -> Some name) octx)); -prerr_endline ("RESTRICT DOPO: " ^ CicPp.pp clean_ot (List.map (function None -> None | Some (name,_) -> Some name) clean_octx)); -*) - clean_octx,clean_ctx,clean_ot, List.map (fun (rel,_,_) -> rel) infos -;; - - -(**** The translation itself ****) - -let cn_to_s = function - | Cic.Anonymous -> "_" - | Cic.Name s -> s -;; - -let splat mk_pi ctx t = - List.fold_left - (fun (t,l) c -> - match strictify c with - | `Ce ((name, NCic.Def (bo,ty)),l') -> NCic.LetIn (name, ty, bo, t),l@l' - | `Ce ((name, NCic.Decl ty),l') when mk_pi -> NCic.Prod (name, ty, t),l@l' - | `Ce ((name, NCic.Decl ty),l') -> NCic.Lambda (name, ty, t),l@l' - | `Fix (_,name,ty) when mk_pi -> NCic.Prod (name, ty, t),l - | `Fix (_,name,ty) -> NCic.Lambda (name,ty,t),l) - (t,[]) ctx -;; - -let osplat mk_pi ctx t = - List.fold_left - (fun t c -> - match c with - | Some (name, Cic.Def (bo,ty)) -> Cic.LetIn (name, ty, bo, t) - | Some (name, Cic.Decl ty) when mk_pi -> Cic.Prod (name, ty, t) - | Some (name, Cic.Decl ty) -> Cic.Lambda (name, ty, t) - | None -> assert false) - t ctx -;; - -let context_tassonomy ctx = - let rec split inner acc acc1 = function - | Ce _ :: tl when inner -> split inner (acc+1) (acc1+1) tl - | Fix _ ::tl -> split false acc (acc1+1) tl - | _ as l -> - let only_decl () = - List.filter - (function - Ce _ as ce -> - (match strictify ce with - `Ce ((_, NCic.Decl _),_) -> true - | _ -> false) - | Fix _ -> true) l - in - acc, List.length l, lazy (List.length (only_decl ())), acc1 - in - split true 0 1 ctx -;; - -let splat_args_for_rel ctx t ?rels n_fix = - let rels = - match rels with - Some rels -> rels - | None -> - let rec mk_irl = function 0 -> [] | n -> n::mk_irl (n - 1) in - mk_irl (List.length ctx) - in - let bound, free, _, primo_ce_dopo_fix = context_tassonomy ctx in - if free = 0 then t - else - let rec aux = function - | n,_ when n = bound + n_fix -> [] - | n,he::tl -> - (match strictify (List.nth ctx (n-1)) with - | `Fix (refe, _, _) when n < primo_ce_dopo_fix -> - NCic.Const refe :: aux (n-1,tl) - | `Fix _ | `Ce ((_, NCic.Decl _),_) -> - NCic.Rel (he - n_fix)::aux(n-1,tl) - | `Ce ((_, NCic.Def _),_) -> aux (n-1,tl)) - | _,_ -> assert false - in - let args = aux (List.length ctx,rels) in - match args with - [] -> t - | _::_ -> NCic.Appl (t::args) -;; - -let splat_args ctx t n_fix rels = - let bound, _, _, primo_ce_dopo_fix = context_tassonomy ctx in - if ctx = [] then t - else - let rec aux = function - | 0,[] -> [] - | n,he::tl -> - (match strictify (List.nth ctx (n-1)) with - | `Ce ((_, NCic.Decl _),_) when n <= bound -> - NCic.Rel he:: aux (n-1,tl) - | `Fix (refe, _, _) when n < primo_ce_dopo_fix -> - splat_args_for_rel ctx (NCic.Const refe) ~rels n_fix :: aux (n-1,tl) - | `Fix _ | `Ce((_, NCic.Decl _),_)-> NCic.Rel (he - n_fix)::aux(n-1,tl) - | `Ce ((_, NCic.Def _),_) -> aux (n - 1,tl) - ) - | _,_ -> assert false - in - let args = aux (List.length ctx,rels) in - match args with - [] -> t - | _::_ -> NCic.Appl (t::args) -;; - -exception Nothing_to_do;; - -let fix_outty curi tyno t context outty = - let leftno,rightno = - match fst (CicEnvironment.get_obj CicUniv.oblivion_ugraph curi) with - Cic.InductiveDefinition (tyl,_,leftno,_) -> - let _,_,arity,_ = List.nth tyl tyno in - let rec count_prods leftno context arity = - match leftno, CicReduction.whd context arity with - 0, Cic.Sort _ -> 0 - | 0, Cic.Prod (name,so,ty) -> - 1 + count_prods 0 (Some (name, Cic.Decl so)::context) ty - | _, Cic.Prod (name,so,ty) -> - count_prods (leftno - 1) (Some (name, Cic.Decl so)::context) ty - | _,_ -> assert false - in -(*prerr_endline (UriManager.string_of_uri curi); -prerr_endline ("LEFTNO: " ^ string_of_int leftno ^ " " ^ CicPp.ppterm arity);*) - leftno, count_prods leftno [] arity - | _ -> assert false in - let ens,args = - let tty,_= CicTypeChecker.type_of_aux' [] context t CicUniv.oblivion_ugraph in - match CicReduction.whd context tty with - Cic.MutInd (_,_,ens) -> ens,[] - | Cic.Appl (Cic.MutInd (_,_,ens)::args) -> - ens,fst (HExtlib.split_nth leftno args) - | _ -> assert false - in - let rec aux n irl context outsort = - match n, CicReduction.whd context outsort with - 0, Cic.Prod _ -> raise Nothing_to_do - | 0, _ -> - let irl = List.rev irl in - let ty = CicSubstitution.lift rightno (Cic.MutInd (curi,tyno,ens)) in - let ty = - if args = [] && irl = [] then ty - else - Cic.Appl (ty::(List.map (CicSubstitution.lift rightno) args)@irl) in - let he = CicSubstitution.lift (rightno + 1) outty in - let t = - if irl = [] then he - else Cic.Appl (he::List.map (CicSubstitution.lift 1) irl) - in - Cic.Lambda (Cic.Anonymous, ty, t) - | n, Cic.Prod (name,so,ty) -> - let ty' = - aux (n - 1) (Cic.Rel n::irl) (Some (name, Cic.Decl so)::context) ty - in - Cic.Lambda (name,so,ty') - | _,_ -> assert false - in -(*prerr_endline ("RIGHTNO = " ^ string_of_int rightno ^ " OUTTY = " ^ CicPp.ppterm outty);*) - let outsort = - fst (CicTypeChecker.type_of_aux' [] context outty CicUniv.oblivion_ugraph) - in - try aux rightno [] context outsort - with Nothing_to_do -> outty -(*prerr_endline (CicPp.ppterm outty ^ " <==> " ^ CicPp.ppterm outty');*) -;; - -let fix_outtype t = - let module C = Cic in - let rec aux context = - function - C.Rel _ as t -> t - | C.Var (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (function i,t -> i, (aux context t)) exp_named_subst in - C.Var (uri,exp_named_subst') - | C.Implicit _ - | C.Meta _ -> assert false - | C.Sort _ as t -> t - | C.Cast (v,t) -> C.Cast (aux context v, aux context t) - | C.Prod (n,s,t) -> - C.Prod (n, aux context s, aux ((Some (n, C.Decl s))::context) t) - | C.Lambda (n,s,t) -> - C.Lambda (n, aux context s, aux ((Some (n, C.Decl s))::context) t) - | C.LetIn (n,s,ty,t) -> - C.LetIn - (n, aux context s, aux context ty, - aux ((Some (n, C.Def(s,ty)))::context) t) - | C.Appl l -> C.Appl (List.map (aux context) l) - | C.Const (uri,exp_named_subst) -> - let exp_named_subst' = - List.map (function i,t -> i, (aux context t)) exp_named_subst - in - C.Const (uri,exp_named_subst') - | C.MutInd (uri,tyno,exp_named_subst) -> - let exp_named_subst' = - List.map (function i,t -> i, (aux context t)) exp_named_subst - in - C.MutInd (uri, tyno, exp_named_subst') - | C.MutConstruct (uri,tyno,consno,exp_named_subst) -> - let exp_named_subst' = - List.map (function i,t -> i, (aux context t)) exp_named_subst - in - C.MutConstruct (uri, tyno, consno, exp_named_subst') - | C.MutCase (uri, tyno, outty, term, patterns) -> - let outty = fix_outty uri tyno term context outty in - C.MutCase (uri, tyno, aux context outty, - aux context term, List.map (aux context) patterns) - | C.Fix (funno, funs) -> - let tys,_ = - List.fold_left - (fun (types,len) (n,_,ty,_) -> - ((Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))))::types, - len+1 - ) ([],0) funs - in - C.Fix (funno, - List.map - (fun (name, indidx, ty, bo) -> - (name, indidx, aux context ty, aux (tys@context) bo) - ) funs - ) - | C.CoFix (funno, funs) -> - let tys,_ = - List.fold_left - (fun (types,len) (n,ty,_) -> - ((Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))))::types, - len+1 - ) ([],0) funs - in - C.CoFix (funno, - List.map - (fun (name, ty, bo) -> - (name, aux context ty, aux (tys@context) bo) - ) funs - ) - in - aux [] t -;; - -let get_fresh,reset_seed = - let seed = ref 0 in - (function () -> - incr seed; - string_of_int !seed), - (function () -> seed := 0) -;; - -exception NotSimilar -let alpha t1 t2 ref ref' = - let rec aux t1 t2 = match t1,t2 with - | NCic.Rel n, NCic.Rel m when n=m -> () - | NCic.Appl l1, NCic.Appl l2 -> List.iter2 aux l1 l2 - | NCic.Lambda (_,s1,t1), NCic.Lambda (_,s2,t2) - | NCic.Prod (_,s1,t1), NCic.Prod (_,s2,t2) -> aux s1 s2; aux t1 t2 - | NCic.LetIn (_,s1,ty1,t1), NCic.LetIn (_,s2,ty2,t2) -> - aux s1 s2; aux ty1 ty2; aux t1 t2 - | NCic.Const (NReference.Ref (uu1,xp1)), - NCic.Const (NReference.Ref (uu2,xp2)) when - let NReference.Ref (u1,_) = ref in - let NReference.Ref (u2,_) = ref' in - NUri.eq uu1 u1 && NUri.eq uu2 u2 && xp1 = xp2 - -> () - | NCic.Const r1, NCic.Const r2 when NReference.eq r1 r2 -> () - | NCic.Meta _,NCic.Meta _ -> () - | NCic.Implicit _,NCic.Implicit _ -> () - | NCic.Sort x,NCic.Sort y when x=y -> () - | NCic.Match (_,t1,t11,tl1), NCic.Match (_,t2,t22,tl2) -> - aux t1 t2;aux t11 t22;List.iter2 aux tl1 tl2 - | _-> raise NotSimilar - in - try aux t1 t2; true with NotSimilar -> false -;; - -exception Found of NReference.reference;; -let cache = Hashtbl.create 313;; -let same_obj ref ref' = - function - | (_,_,_,_,NCic.Fixpoint (b1,l1,_)), (_,_,_,_,NCic.Fixpoint (b2,l2,_)) - when List.for_all2 (fun (_,_,_,ty1,bo1) (_,_,_,ty2,bo2) -> - alpha ty1 ty2 ref ref' && alpha bo1 bo2 ref ref') l1 l2 && b1=b2-> - true - | _ -> false -;; -let find_in_cache name obj ref = - try - List.iter - (function (ref',obj') -> - let recno, fixno = - match ref with - NReference.Ref (_,NReference.Fix (fixno,recno,_)) -> recno,fixno - | NReference.Ref (_,NReference.CoFix (fixno)) -> ~-1,fixno - | _ -> assert false in - let recno',fixno' = - match ref' with - NReference.Ref (_,NReference.Fix (fixno',recno,_)) -> recno,fixno' - | NReference.Ref (_,NReference.CoFix (fixno')) -> ~-1,fixno' - | _ -> assert false in - if recno = recno' && fixno = fixno' && same_obj ref ref' (obj,obj') then ( -(* -prerr_endline ("!!!!!!!!!!! CACHE HIT !!!!!!!!!!\n" ^ -NReference.string_of_reference ref ^ "\n" ^ -NReference.string_of_reference ref' ^ "\n"); - *) - raise (Found ref')); -(* -prerr_endline ("CACHE SAME NAME: " ^ NReference.string_of_reference ref ^ " <==> " ^ NReference.string_of_reference ref'); - *) - ) (Hashtbl.find_all cache name); -(* prerr_endline "<<< CACHE MISS >>>"; *) - begin - match obj, ref with - | (_,_,_,_,NCic.Fixpoint (true,fl,_)) , - NReference.Ref (_,NReference.Fix _) -> - ignore(List.fold_left (fun i (_,name,rno,_,_) -> - let ref = NReference.mk_fix i rno ref in - Hashtbl.add cache name (ref,obj); - i+1 - ) 0 fl) - | (_,_,_,_,NCic.Fixpoint (false,fl,_)) , - NReference.Ref (_,NReference.CoFix _) -> - ignore(List.fold_left (fun i (_,name,_,_,_) -> - let ref = NReference.mk_cofix i ref in - Hashtbl.add cache name (ref,obj); - i+1 - ) 0 fl) - | _ -> assert false - end; - None - with Found ref -> Some ref -;; - -let cache1 = UriManager.UriHashtbl.create 313;; -let rec get_height = - function u -> - try - UriManager.UriHashtbl.find cache1 u - with - Not_found -> - let h = ref 0 in - let res = - match fst (CicEnvironment.get_obj CicUniv.oblivion_ugraph u) with - Cic.Constant (_,Some bo,ty,params,_) - | Cic.Variable (_,Some bo,ty,params,_) -> - ignore (height_of_term ~h bo); - ignore (height_of_term ~h ty); - List.iter (function uri -> h := max !h (get_height uri)) params; - 1 + !h - | _ -> 0 - in - UriManager.UriHashtbl.add cache1 u res; - res -and height_of_term ?(h=ref 0) t = - let rec aux = - function - Cic.Rel _ - | Cic.Sort _ -> () - | Cic.Implicit _ -> assert false - | Cic.Var (uri,exp_named_subst) - | Cic.Const (uri,exp_named_subst) - | Cic.MutInd (uri,_,exp_named_subst) - | Cic.MutConstruct (uri,_,_,exp_named_subst) -> - h := max !h (get_height uri); - List.iter (function (_,t) -> aux t) exp_named_subst - | Cic.Meta (_,l) -> List.iter (function None -> () | Some t -> aux t) l - | Cic.Cast (t1,t2) - | Cic.Prod (_,t1,t2) - | Cic.Lambda (_,t1,t2) -> aux t1; aux t2 - | Cic.LetIn (_,s,ty,t) -> aux s; aux ty; aux t - | Cic.Appl l -> List.iter aux l - | Cic.MutCase (_,_,outty,t,pl) -> aux outty; aux t; List.iter aux pl - | Cic.Fix (_, fl) -> List.iter (fun (_, _, ty, bo) -> aux ty; aux bo) fl; incr h - | Cic.CoFix (_, fl) -> List.iter (fun (_, ty, bo) -> aux ty; aux bo) fl; incr h - in - aux t; - 1 + !h -;; - - (* k=true if we are converting a term to be pushed in a ctx or if we are - converting the type of a fix; - k=false if we are converting a term to be put in the body of a fix; - in the latter case, we must permute Rels since the Fix abstraction will - preceed its lefts parameters; in the former case, there is nothing to - permute *) - let rec aux k octx (ctx : ctx list) n_fix uri = function - | Cic.CoFix _ as cofix -> - let octx,ctx,fix,rels = restrict octx ctx cofix in - let cofixno,fl = - match fix with Cic.CoFix (cofixno,fl)->cofixno,fl | _-> assert false in - let buri = - UriManager.uri_of_string - (UriManager.buri_of_uri uri^"/"^ - UriManager.name_of_uri uri ^ "___" ^ get_fresh () ^ ".con") - in - let bctx, fixpoints_tys, tys, _ = - List.fold_right - (fun (name,ty,_) (bctx, fixpoints, tys, idx) -> - let ty, fixpoints_ty = aux true octx ctx n_fix uri ty in - let r = reference_of_ouri buri(Ref.CoFix idx) in - bctx @ [Fix (lazy (r,name,ty))], - fixpoints_ty @ fixpoints,ty::tys,idx-1) - fl ([], [], [], List.length fl-1) - in - let bctx = bctx @ ctx in - let n_fl = List.length fl in - let boctx,_ = - List.fold_left - (fun (types,len) (n,ty,_) -> - (Some (Cic.Name n,(Cic.Decl (CicSubstitution.lift len ty)))::types, - len+1)) (octx,0) fl - in - let fl, fixpoints = - List.fold_right2 - (fun (name,_,bo) ty (l,fixpoints) -> - let bo, fixpoints_bo = aux false boctx bctx n_fl buri bo in - let splty,fixpoints_splty = splat true ctx ty in - let splbo,fixpoints_splbo = splat false ctx bo in - (([],name,~-1,splty,splbo)::l), - fixpoints_bo @ fixpoints_splty @ fixpoints_splbo @ fixpoints) - fl tys ([],fixpoints_tys) - in - let obj = - nuri_of_ouri buri,0,[],[], - NCic.Fixpoint (false, fl, (`Generated, `Definition, `Regular)) - in - let r = reference_of_ouri buri (Ref.CoFix cofixno) in - let obj,r = - let _,name,_,_,_ = List.nth fl cofixno in - match find_in_cache name obj r with - Some r' -> [],r' - | None -> [obj],r - in - splat_args ctx (NCic.Const r) n_fix rels, fixpoints @ obj - | Cic.Fix _ as fix -> - let octx,ctx,fix,rels = restrict octx ctx fix in - let fixno,fl = - match fix with Cic.Fix (fixno,fl) -> fixno,fl | _ -> assert false in - let buri = - UriManager.uri_of_string - (UriManager.buri_of_uri uri^"/"^ - UriManager.name_of_uri uri ^ "___" ^ get_fresh () ^ ".con") in - let height = height_of_term fix - 1 in - let bad_bctx, fixpoints_tys, tys, _ = - List.fold_right - (fun (name,recno,ty,_) (bctx, fixpoints, tys, idx) -> - let ty, fixpoints_ty = aux true octx ctx n_fix uri ty in - let r = (* recno is dummy here, must be lifted by the ctx len *) - reference_of_ouri buri (Ref.Fix (idx,recno,height)) - in - bctx @ [Fix (lazy (r,name,ty))], - fixpoints_ty@fixpoints,ty::tys,idx-1) - fl ([], [], [], List.length fl-1) - in - let _, _, free_decls, _ = context_tassonomy (bad_bctx @ ctx) in - let free_decls = Lazy.force free_decls in - let bctx = - List.map (function ce -> match strictify ce with - | `Fix (Ref.Ref (_,Ref.Fix (idx, recno,height)),name, ty) -> - Fix (lazy (reference_of_ouri buri - (Ref.Fix (idx,recno+free_decls,height)),name,ty)) - | _ -> assert false) bad_bctx @ ctx - in - let n_fl = List.length fl in - let boctx,_ = - List.fold_left - (fun (types,len) (n,_,ty,_) -> - (Some (Cic.Name n,(Cic.Decl (CicSubstitution.lift len ty)))::types, - len+1)) (octx,0) fl - in - let rno_fixno = ref 0 in - let fl, fixpoints,_ = - List.fold_right2 - (fun (name,rno,oty,bo) ty (l,fixpoints,idx) -> - let bo, fixpoints_bo = aux false boctx bctx n_fl buri bo in - let splty,fixpoints_splty = splat true ctx ty in - let splbo,fixpoints_splbo = splat false ctx bo in - let rno = rno + free_decls in - if idx = fixno then rno_fixno := rno; - ((get_relevance (osplat true octx oty),name,rno,splty,splbo)::l), - fixpoints_bo@fixpoints_splty@fixpoints_splbo@fixpoints,idx+1) - fl tys ([],fixpoints_tys,0) - in - let obj = - nuri_of_ouri buri,height,[],[], - NCic.Fixpoint (true, fl, (`Generated, `Definition, `Regular)) in -(*prerr_endline ("H(" ^ UriManager.string_of_uri buri ^ ") = " ^ string_of_int * height);*) - let r = reference_of_ouri buri (Ref.Fix (fixno,!rno_fixno,height)) in - let obj,r = - let _,name,_,_,_ = List.nth fl fixno in - match find_in_cache name obj r with - Some r' -> [],r' - | None -> [obj],r - in - splat_args ctx (NCic.Const r) n_fix rels, fixpoints @ obj - | Cic.Rel n -> - let bound, _, _, primo_ce_dopo_fix = context_tassonomy ctx in - (match List.nth ctx (n-1) with - | Fix l when n < primo_ce_dopo_fix -> - let r,_,_ = Lazy.force l in - splat_args_for_rel ctx (NCic.Const r) n_fix, [] - | Ce _ when n <= bound -> NCic.Rel n, [] - | Fix _ when n <= bound -> assert false - | Fix _ | Ce _ when k = true -> NCic.Rel n, [] - | Fix _ | Ce _ -> NCic.Rel (n-n_fix), []) - | Cic.Lambda (name, (s as old_s), t) -> - let s, fixpoints_s = aux k octx ctx n_fix uri s in - let s'_and_fixpoints_s' = lazy (aux true octx ctx n_fix uri old_s) in - let ctx = - Ce (lazy - let s',fixpoints_s' = Lazy.force s'_and_fixpoints_s' in - ((cn_to_s name, NCic.Decl s'),fixpoints_s'))::ctx in - let octx = Some (name, Cic.Decl old_s) :: octx in - let t, fixpoints_t = aux k octx ctx n_fix uri t in - NCic.Lambda (cn_to_s name, s, t), fixpoints_s @ fixpoints_t - | Cic.Prod (name, (s as old_s), t) -> - let s, fixpoints_s = aux k octx ctx n_fix uri s in - let s'_and_fixpoints_s' = lazy (aux true octx ctx n_fix uri old_s) in - let ctx = - Ce (lazy - let s',fixpoints_s' = Lazy.force s'_and_fixpoints_s' in - ((cn_to_s name, NCic.Decl s'),fixpoints_s'))::ctx in - let octx = Some (name, Cic.Decl old_s) :: octx in - let t, fixpoints_t = aux k octx ctx n_fix uri t in - NCic.Prod (cn_to_s name, s, t), fixpoints_s @ fixpoints_t - | Cic.LetIn (name, (te as old_te), (ty as old_ty), t) -> - let te, fixpoints_s = aux k octx ctx n_fix uri te in - let te_and_fixpoints_s' = lazy (aux true octx ctx n_fix uri old_te) in - let ty, fixpoints_ty = aux k octx ctx n_fix uri ty in - let ty_and_fixpoints_ty' = lazy (aux true octx ctx n_fix uri old_ty) in - let ctx = - Ce (lazy - let te',fixpoints_s' = Lazy.force te_and_fixpoints_s' in - let ty',fixpoints_ty' = Lazy.force ty_and_fixpoints_ty' in - let fixpoints' = fixpoints_s' @ fixpoints_ty' in - ((cn_to_s name, NCic.Def (te', ty')),fixpoints'))::ctx in - let octx = Some (name, Cic.Def (old_te, old_ty)) :: octx in - let t, fixpoints_t = aux k octx ctx n_fix uri t in - NCic.LetIn (cn_to_s name, ty, te, t), - fixpoints_s @ fixpoints_t @ fixpoints_ty - | Cic.Cast (t,ty) -> - let t, fixpoints_t = aux k octx ctx n_fix uri t in - let ty, fixpoints_ty = aux k octx ctx n_fix uri ty in - NCic.LetIn ("cast", ty, t, NCic.Rel 1), fixpoints_t @ fixpoints_ty - | Cic.Sort Cic.Prop -> NCic.Sort NCic.Prop,[] - | Cic.Sort (Cic.CProp u) -> - NCic.Sort (NCic.Type (mk_cprop (CicUniv.get_rank u))),[] - | Cic.Sort (Cic.Type u) -> - NCic.Sort (NCic.Type (mk_type (CicUniv.get_rank u))),[] - | Cic.Sort Cic.Set -> NCic.Sort (NCic.Type (mk_type 0)),[] - (* calculate depth in the univ_graph*) - | Cic.Appl l -> - let l, fixpoints = - List.fold_right - (fun t (l,acc) -> - let t, fixpoints = aux k octx ctx n_fix uri t in - (t::l,fixpoints@acc)) - l ([],[]) - in - (match l with - | (NCic.Appl l1)::l2 -> NCic.Appl (l1@l2), fixpoints - | _ -> NCic.Appl l, fixpoints) - | Cic.Const (curi, ens) -> - aux_ens k curi octx ctx n_fix uri ens - (match fst(CicEnvironment.get_obj CicUniv.oblivion_ugraph curi) with - | Cic.Constant (_,Some _,_,_,_) -> - NCic.Const (reference_of_ouri curi (Ref.Def (get_height curi))) - | Cic.Constant (_,None,_,_,_) -> - NCic.Const (reference_of_ouri curi Ref.Decl) - | _ -> assert false) - | Cic.MutInd (curi, tyno, ens) -> - let is_inductive, lno = - match fst (CicEnvironment.get_obj CicUniv.oblivion_ugraph curi) with - Cic.InductiveDefinition ([],vars,lno,_) -> true, lno + count_vars vars - | Cic.InductiveDefinition ((_,b,_,_)::_,vars,lno,_) -> b, lno + count_vars vars - | _ -> assert false - in - aux_ens k curi octx ctx n_fix uri ens - (NCic.Const (reference_of_ouri curi (Ref.Ind (is_inductive,tyno,lno)))) - | Cic.MutConstruct (curi, tyno, consno, ens) -> - let lno = - match fst (CicEnvironment.get_obj CicUniv.oblivion_ugraph curi) with - Cic.InductiveDefinition (_,vars,lno,_) -> lno + count_vars vars - | _ -> assert false - in - aux_ens k curi octx ctx n_fix uri ens - (NCic.Const (reference_of_ouri curi (Ref.Con (tyno,consno,lno)))) - | Cic.Var (curi, ens) -> - (match fst (CicEnvironment.get_obj CicUniv.oblivion_ugraph curi) with - Cic.Variable (_,Some bo,_,_,_) -> - aux k octx ctx n_fix uri (CicSubstitution.subst_vars ens bo) - | _ -> assert false) - | Cic.MutCase (curi, tyno, outty, t, branches) -> - let is_inductive,lno = - match fst (CicEnvironment.get_obj CicUniv.oblivion_ugraph curi) with - Cic.InductiveDefinition ([],vars,lno,_) -> true, lno + count_vars vars - | Cic.InductiveDefinition ((_,b,_,_)::_,vars,lno,_) -> b, lno + count_vars vars - | _ -> assert false in - let r = reference_of_ouri curi (Ref.Ind (is_inductive,tyno,lno)) in - let outty, fixpoints_outty = aux k octx ctx n_fix uri outty in - let t, fixpoints_t = aux k octx ctx n_fix uri t in - let branches, fixpoints = - List.fold_right - (fun t (l,acc) -> - let t, fixpoints = aux k octx ctx n_fix uri t in - (t::l,fixpoints@acc)) - branches ([],[]) - in - NCic.Match (r,outty,t,branches), fixpoints_outty@fixpoints_t@fixpoints - | Cic.Implicit _ | Cic.Meta _ -> assert false - and aux_ens k curi octx ctx n_fix uri ens he = - match ens with - [] -> he,[] - | _::_ -> - let params = - match fst (CicEnvironment.get_obj CicUniv.oblivion_ugraph curi) with - Cic.Constant (_,_,_,params,_) - | Cic.InductiveDefinition (_,params,_,_) -> params - | Cic.Variable _ - | Cic.CurrentProof _ -> assert false - in - let ens,objs = - List.fold_right - (fun luri (l,objs) -> - match fst (CicEnvironment.get_obj CicUniv.oblivion_ugraph luri) with - Cic.Variable (_,Some _,_,_,_) -> l, objs - | Cic.Variable (_,None,_,_,_) -> - let t = List.assoc luri ens in - let t,o = aux k octx ctx n_fix uri t in - t::l, o@objs - | _ -> assert false - ) params ([],[]) - in - match ens with - [] -> he,objs - | _::_ -> NCic.Appl (he::ens),objs -;; - -(* we are lambda-lifting also variables that do not occur *) -(* ctx does not distinguish successive blocks of cofix, since there may be no - * lambda separating them *) -let convert_term uri t = - aux false [] [] 0 uri t -;; - -let cook mode vars t = - let t = fix_outtype t in - let varsno = List.length vars in - let t = CicSubstitution.lift varsno t in - let rec aux n acc l = - let subst = - snd(List.fold_left (fun (i,res) uri -> i+1,(uri,Cic.Rel i)::res) (1,[]) acc) - in - match l with - [] -> CicSubstitution.subst_vars subst t - | uri::uris -> - let bo,ty = - match fst (CicEnvironment.get_obj CicUniv.oblivion_ugraph uri) with - Cic.Variable (_,bo,ty,_,_) -> - HExtlib.map_option fix_outtype bo, fix_outtype ty - | _ -> assert false in - let ty = CicSubstitution.subst_vars subst ty in - let bo = HExtlib.map_option (CicSubstitution.subst_vars subst) bo in - let id = Cic.Name (UriManager.name_of_uri uri) in - let t = aux (n-1) (uri::acc) uris in - match bo,ty,mode with - None,ty,`Lambda -> Cic.Lambda (id,ty,t) - | None,ty,`Pi -> Cic.Prod (id,ty,t) - | Some bo,ty,_ -> Cic.LetIn (id,bo,ty,t) - in - aux varsno [] vars -;; - -let convert_obj_aux uri = function - | Cic.Constant (name, None, ty, vars, _) -> - let ty = cook `Pi vars ty in - let nty, fixpoints = convert_term uri ty in - assert(fixpoints = []); - NCic.Constant (get_relevance ty, name, None, nty, (`Provided,`Theorem,`Regular)), - fixpoints - | Cic.Constant (name, Some bo, ty, vars, _) -> - let bo = cook `Lambda vars bo in - let ty = cook `Pi vars ty in - let nbo, fixpoints_bo = convert_term uri bo in - let nty, fixpoints_ty = convert_term uri ty in - assert(fixpoints_ty = []); - NCic.Constant (get_relevance ty, name, Some nbo, nty, (`Provided,`Theorem,`Regular)), - fixpoints_bo @ fixpoints_ty - | Cic.InductiveDefinition (itl,vars,leftno,_) -> - let ind = let _,x,_,_ = List.hd itl in x in - let itl, fix_itl = - List.fold_right - (fun (name, _, ty, cl) (itl,acc) -> - let ty = cook `Pi vars ty in - let nty, fix_ty = convert_term uri ty in - let cl, fix_cl = - List.fold_right - (fun (name, ty) (cl,acc) -> - let ty = cook `Pi vars ty in - let nty, fix_ty = convert_term uri ty in - (get_relevance ty, name, nty)::cl, acc @ fix_ty) - cl ([],[]) - in - (get_relevance ty, name, nty, cl)::itl, fix_ty @ fix_cl @ acc) - itl ([],[]) - in - NCic.Inductive(ind, leftno + count_vars vars, itl, (`Provided, `Regular)), - fix_itl - | Cic.Variable _ - | Cic.CurrentProof _ -> assert false -;; - -let convert_obj uri obj = - reset_seed (); - let o, fixpoints = convert_obj_aux uri obj in - let obj = nuri_of_ouri uri,get_height uri, [], [], o in -(*prerr_endline ("H(" ^ UriManager.string_of_uri uri ^ ") = " ^ string_of_int * (get_height uri));*) - fixpoints @ [obj] -;; - -let clear () = - Hashtbl.clear cache; - UriManager.UriHashtbl.clear cache1 -;; - -(* -let convert_context uri = - let name_of = function Cic.Name s -> s | _ -> "_" in - List.fold_right - (function - | (Some (s, Cic.Decl t) as e) -> fun (nc,auxc,oc) -> - let t, _ = aux true oc auxc 0 uri t in - (name_of s, NCic.Decl t) :: nc, - Ce (lazy ((name_of s, NCic.Decl t),[])) :: auxc, e :: oc - | (Some (Cic.Name s, Cic.Def (t,ty)) as e) -> fun (nc,auxc,oc) -> - let t, _ = aux true oc auxc 0 uri t in - let t, _ = aux true oc auxc 0 uri ty in - (name_of s, NCic.Def (t,ty)) :: nc, - Ce (lazy ((name_of s, NCic.Def (t,ty)),[])) :: auxc, e :: oc - | None -> nc, , e :: oc -;; - -let convert_term uri ctx t = - aux false [] [] 0 uri t -;; -*) - -let reference_of_oxuri u = - let t = CicUtil.term_of_uri u in - let t',l = convert_term (UriManager.uri_of_string "cic:/dummy/dummy.con") t in - match t',l with - NCic.Const nref, [] -> nref - | _,_ -> assert false -;; - -NCicCoercion.set_convert_term convert_term;; -Ncic2astMatcher.set_reference_of_oxuri reference_of_oxuri;; -NCicDisambiguate.set_reference_of_oxuri reference_of_oxuri;; -(* Why should we set them here? -NCicBlob.set_reference_of_oxuri reference_of_oxuri;; -NCicProof.set_reference_of_oxuri reference_of_oxuri;; -*) diff --git a/matita/components/ng_library/oCic2NCic.mli b/matita/components/ng_library/oCic2NCic.mli deleted file mode 100644 index fa3717ee4..000000000 --- a/matita/components/ng_library/oCic2NCic.mli +++ /dev/null @@ -1,23 +0,0 @@ -(* - ||M|| This file is part of HELM, an Hypertextual, Electronic - ||A|| Library of Mathematics, developed at the Computer Science - ||T|| Department, University of Bologna, Italy. - ||I|| - ||T|| HELM is free software; you can redistribute it and/or - ||A|| modify it under the terms of the GNU General Public License - \ / version 2 or (at your option) any later version. - \ / This software is distributed as is, NO WARRANTY. - V_______________________________________________________________ *) - -(* $Id$ *) - -val nuri_of_ouri: UriManager.uri -> NUri.uri - -val reference_of_ouri: UriManager.uri -> NReference.spec -> NReference.reference - -val reference_of_oxuri: UriManager.uri -> NReference.reference - -val convert_obj: UriManager.uri -> Cic.obj -> NCic.obj list -val convert_term: UriManager.uri -> Cic.term -> NCic.term * NCic.obj list - -val clear: unit -> unit diff --git a/matita/components/ng_library/rt.ml b/matita/components/ng_library/rt.ml deleted file mode 100644 index 997bc2e3c..000000000 --- a/matita/components/ng_library/rt.ml +++ /dev/null @@ -1,42 +0,0 @@ -(* - ||M|| This file is part of HELM, an Hypertextual, Electronic - ||A|| Library of Mathematics, developed at the Computer Science - ||T|| Department, University of Bologna, Italy. - ||I|| - ||T|| HELM is free software; you can redistribute it and/or - ||A|| modify it under the terms of the GNU General Public License - \ / version 2 or (at your option) any later version. - \ / This software is distributed as is, NO WARRANTY. - V_______________________________________________________________ *) - -(* $Id$ *) - -let _ = - Helm_registry.load_from "conf.xml"; - CicParser.impredicative_set := false; - let u = UriManager.uri_of_string Sys.argv.(1) in - let o, _ = CicEnvironment.get_obj CicUniv.oblivion_ugraph u in - prerr_endline "VECCHIO"; - prerr_endline (CicPp.ppobj o); - let l = OCic2NCic.convert_obj u o in - prerr_endline "OGGETTI:........................................."; - List.iter (fun o -> prerr_endline (NCicPp.ppobj o)) l; - prerr_endline "/OGGETTI:........................................."; - let objs = - List.flatten - (List.map NCic2OCic.convert_nobj l) in - List.iter - (fun (u,o) -> - prerr_endline ("round trip: " ^ UriManager.string_of_uri u); - prerr_endline (CicPp.ppobj o); - prerr_endline "tipo......."; - try CicTypeChecker.typecheck_obj u o - with - CicTypeChecker.TypeCheckerFailure s - | CicTypeChecker.AssertFailure s -> - prerr_endline (Lazy.force s) - | CicEnvironment.Object_not_found uri -> - prerr_endline - ("CicEnvironment: Object not found " ^ UriManager.string_of_uri uri)) - objs; -;; diff --git a/matita/configure.ac b/matita/configure.ac index 69eceb4e4..b6f2d4ce1 100644 --- a/matita/configure.ac +++ b/matita/configure.ac @@ -82,7 +82,6 @@ helm-content_pres \ helm-hgdome \ helm-ng_paramodulation \ helm-ng_tactics \ -helm-cic_exportation \ " FINDLIB_CREQUIRES=" \ $FINDLIB_COMREQUIRES \ diff --git a/matita/matita/applyTransformation.ml b/matita/matita/applyTransformation.ml index ad51250d8..6cbad3b50 100644 --- a/matita/matita/applyTransformation.ml +++ b/matita/matita/applyTransformation.ml @@ -35,35 +35,9 @@ (* $Id$ *) -module UM = UriManager -module C = Cic -module Un = CicUniv -module E = CicEnvironment -module TC = CicTypeChecker -module G = GrafiteAst -module GE = GrafiteEngine -module LS = LibrarySync -module Ds = CicDischarge -module N = CicNotationPt - let mpres_document pres_box = Xml.add_xml_declaration (CicNotationPres.print_box pres_box) -let mml_of_cic_sequent metasenv sequent = - let unsh_sequent,(asequent,ids_to_terms, - ids_to_father_ids,ids_to_inner_sorts,ids_to_hypotheses) - = - Cic2acic.asequent_of_sequent metasenv sequent - in - let content_sequent = Acic2content.map_sequent asequent in - let pres_sequent = - Sequent2pres.sequent2pres ~ids_to_inner_sorts content_sequent in - let xmlpres = mpres_document pres_sequent in - (Xml2Gdome.document_of_xml DomMisc.domImpl xmlpres, - unsh_sequent, - (asequent, - (ids_to_terms,ids_to_father_ids,ids_to_hypotheses,ids_to_inner_sorts))) - let nmml_of_cic_sequent status metasenv subst sequent = let content_sequent,ids_to_refs = NTermCicContent.nmap_sequent status ~metasenv ~subst sequent in @@ -81,22 +55,6 @@ let ntxt_of_cic_sequent ~map_unicode_to_tex size status metasenv subst sequent = BoxPp.render_to_string ~map_unicode_to_tex (function x::_ -> x | _ -> assert false) size pres_sequent -let mml_of_cic_object obj = - let (annobj, ids_to_terms, ids_to_father_ids, ids_to_inner_sorts, - ids_to_inner_types, ids_to_conjectures, ids_to_hypotheses) - = - Cic2acic.acic_object_of_cic_object obj - in - let content = - Acic2content.annobj2content ~ids_to_inner_sorts ~ids_to_inner_types annobj - in - let pres = Content2pres.content2pres ~ids_to_inner_sorts content in - let xmlpres = mpres_document pres in - let mathml = Xml2Gdome.document_of_xml DomMisc.domImpl xmlpres in - (mathml,(annobj, - (ids_to_terms, ids_to_father_ids, ids_to_conjectures, ids_to_hypotheses, - ids_to_inner_sorts,ids_to_inner_types))) - let nmml_of_cic_object status obj = let cobj,ids_to_nrefs = NTermCicContent.nmap_obj status obj in let pres_sequent = Content2pres.ncontent2pres ~ids_to_nrefs cobj in @@ -111,214 +69,3 @@ let ntxt_of_cic_object ~map_unicode_to_tex size status obj = BoxPp.render_to_string ~map_unicode_to_tex (function x::_ -> x | _ -> assert false) size pres_sequent ;; - -let txt_of_cic_sequent_all ~map_unicode_to_tex size metasenv sequent = - let unsh_sequent,(asequent,ids_to_terms, - ids_to_father_ids,ids_to_inner_sorts,ids_to_hypotheses) - = - Cic2acic.asequent_of_sequent metasenv sequent - in - let content_sequent = Acic2content.map_sequent asequent in - let pres_sequent = - CicNotationPres.mpres_of_box - (Sequent2pres.sequent2pres ~ids_to_inner_sorts content_sequent) in - let txt = - BoxPp.render_to_string ~map_unicode_to_tex - (function x::_ -> x | _ -> assert false) size pres_sequent - in - (txt, - unsh_sequent, - (asequent, - (ids_to_terms,ids_to_father_ids,ids_to_hypotheses,ids_to_inner_sorts))) - -let txt_of_cic_sequent ~map_unicode_to_tex size metasenv sequent = - let txt,_,_ = txt_of_cic_sequent_all ~map_unicode_to_tex size metasenv sequent - in txt -;; - -let txt_of_cic_sequent_conclusion ~map_unicode_to_tex ~output_type size - metasenv sequent = - let _,(asequent,_,_,ids_to_inner_sorts,_) = - Cic2acic.asequent_of_sequent metasenv sequent - in - let _,_,_,t = Acic2content.map_sequent asequent in - let t, ids_to_uris = - TermAcicContent.ast_of_acic ~output_type ids_to_inner_sorts t in - let t = TermContentPres.pp_ast t in - let t = - CicNotationPres.render ~lookup_uri:(CicNotationPres.lookup_uri ids_to_uris) t - in - BoxPp.render_to_string ~map_unicode_to_tex - (function x::_ -> x | _ -> assert false) size t - -let txt_of_cic_term ~map_unicode_to_tex size metasenv context t = - let fake_sequent = (-1,context,t) in - txt_of_cic_sequent_conclusion ~map_unicode_to_tex ~output_type:`Term size - metasenv fake_sequent -;; - -(****************************************************************************) -(* txt_of_cic_object: IMPROVE ME *) - -let remove_closed_substs s = - Pcre.replace ~pat:"{...}" ~templ:"" s - -let term2pres ~map_unicode_to_tex n ids_to_inner_sorts annterm = - let ast, ids_to_uris = - TermAcicContent.ast_of_acic ~output_type:`Term ids_to_inner_sorts annterm in - let bobj = - CicNotationPres.box_of_mpres ( - CicNotationPres.render ~prec:90 - ~lookup_uri:(CicNotationPres.lookup_uri ids_to_uris) - (TermContentPres.pp_ast ast)) in - let render = function _::x::_ -> x | _ -> assert false in - let mpres = CicNotationPres.mpres_of_box bobj in - let s = BoxPp.render_to_string ~map_unicode_to_tex render n mpres in - remove_closed_substs s - -let enable_notations = function - | true -> - CicNotation.set_active_notations - (List.map fst (CicNotation.get_all_notations ())) - | false -> - CicNotation.set_active_notations [] - -let txt_of_cic_object_all - ~map_unicode_to_tex ?skip_thm_and_qed ?skip_initial_lambdas n params obj -= - let get_aobj obj = - try - let - aobj,ids_to_terms,ids_to_father_ids,ids_to_inner_sorts,ids_to_inner_types,ids_to_conjectures,ids_to_hypotheses = - Cic2acic.acic_object_of_cic_object obj - in - aobj, ids_to_terms, ids_to_father_ids, ids_to_inner_sorts, - ids_to_inner_types,ids_to_conjectures,ids_to_hypotheses - with - | E.Object_not_found uri -> - let msg = "txt_of_cic_object: object not found: " ^ UM.string_of_uri uri in - failwith msg - | e -> - let msg = "txt_of_cic_object: " ^ Printexc.to_string e in - failwith msg - in - (*MATITA1.0 - if List.mem G.IPProcedural params then begin - - Procedural2.debug := A2P.is_debug 1 params; - PO.debug := A2P.is_debug 2 params; -(* - PO.critical := false; - A2P.tex_formatter := Some Format.std_formatter; - let _ = ProceduralTeX.tex_of_obj Format.std_formatter obj in -*) - let obj, info = PO.optimize_obj obj in -(* - let _ = ProceduralTeX.tex_of_obj Format.std_formatter obj in -*) - let aobj, ids_to_terms, ids_to_father_ids, ids_to_inner_sorts, - ids_to_inner_types,ids_to_conjectures,ids_to_hypothesis = get_aobj obj in - let term_pp = term2pres ~map_unicode_to_tex (n - 8) ids_to_inner_sorts in - let lazy_term_pp = term_pp in - let obj_pp = CicNotationPp.pp_obj term_pp in - let stm_pp = - GrafiteAstPp.pp_statement - ~map_unicode_to_tex ~term_pp ~lazy_term_pp ~obj_pp - in - let aux = function - | G.Executable (_, G.Command (_, G.Obj (_, N.Inductive _))) - | G.Executable (_, G.Command (_, G.Obj (_, N.Record _))) as stm - -> - let hc = !Acic2content.hide_coercions in - if List.mem G.IPCoercions params then - Acic2content.hide_coercions := false; - enable_notations false; - let str = stm_pp stm in - enable_notations true; - Acic2content.hide_coercions := hc; - str -(* FG: we disable notation for inductive types to avoid recursive notation *) - | G.Executable (_, G.Tactic _) as stm -> - let hc = !Acic2content.hide_coercions in - Acic2content.hide_coercions := false; - let str = stm_pp stm in - Acic2content.hide_coercions := hc; - str -(* FG: we show coercion because the reconstruction is not aware of them *) - | stm -> - let hc = !Acic2content.hide_coercions in - if List.mem G.IPCoercions params then - Acic2content.hide_coercions := false; - let str = stm_pp stm in - Acic2content.hide_coercions := hc; - str - in - let script = - A2P.procedural_of_acic_object - ~ids_to_inner_sorts ~ids_to_inner_types ~info params aobj - in - String.concat "" (List.map aux script) ^ "\n\n" - end else *) - let aobj, ids_to_terms, ids_to_father_ids, ids_to_inner_sorts, - ids_to_inner_types,ids_to_conjectures,ids_to_hypotheses = get_aobj obj in - let cobj = - Acic2content.annobj2content ids_to_inner_sorts ids_to_inner_types aobj - in - let bobj = - Content2pres.content2pres - ?skip_initial_lambdas ?skip_thm_and_qed ~ids_to_inner_sorts cobj - in - let txt = - remove_closed_substs ( - BoxPp.render_to_string ~map_unicode_to_tex - (function _::x::_ -> x | _ -> assert false) n - (CicNotationPres.mpres_of_box bobj) - ^ "\n\n" - ) - in - (txt,(aobj, - (ids_to_terms, ids_to_father_ids, ids_to_conjectures, ids_to_hypotheses, - ids_to_inner_sorts,ids_to_inner_types))) - -let txt_of_cic_object - ~map_unicode_to_tex ?skip_thm_and_qed ?skip_initial_lambdas n params obj -= - let txt,_ = txt_of_cic_object_all - ~map_unicode_to_tex ?skip_thm_and_qed ?skip_initial_lambdas n params obj - in txt - -let cic_prefix = Str.regexp_string "cic:/" -let matita_prefix = Str.regexp_string "cic:/matita/" -let suffixes = [".ind"; "_rec.con"; "_rect.con"; "_ind.con"; ".con"] - -let replacements = - let map s = String.length s, s, Str.regexp_string s, "_discharged" ^ s in - List.map map suffixes - -let replacement (ok, u) (l, s, x, t) = - if ok then ok, u else - if Str.last_chars u l = s then true, Str.replace_first x t u else ok, u - -let discharge_uri params uri = - let template = - if List.mem G.IPProcedural params then "cic:/matita/procedural/" - else "cic:/matita/declarative/" - in - let s = UM.string_of_uri uri in - if Str.string_match matita_prefix s 0 then uri else - let s = Str.replace_first cic_prefix template s in - let _, s = List.fold_left replacement (false, s) replacements in - UM.uri_of_string s - -let discharge_name s = s ^ "_discharged" - -let txt_of_macro ~map_unicode_to_tex metasenv context m = - GrafiteAstPp.pp_macro - ~term_pp:(txt_of_cic_term ~map_unicode_to_tex 80 metasenv context) - ~lazy_term_pp:(fun (f : Cic.lazy_term) -> - let t,metasenv,_ = f context metasenv CicUniv.empty_ugraph in - txt_of_cic_term ~map_unicode_to_tex 80 metasenv context t) - m -;; - - diff --git a/matita/matita/applyTransformation.mli b/matita/matita/applyTransformation.mli index b5b596927..5816455c2 100644 --- a/matita/matita/applyTransformation.mli +++ b/matita/matita/applyTransformation.mli @@ -33,17 +33,6 @@ (* *) (***************************************************************************) -val mml_of_cic_sequent: - Cic.metasenv -> (* metasenv *) - Cic.conjecture -> (* sequent *) - Gdome.document * (* Math ML *) - Cic.conjecture * (* unshared sequent *) - (Cic.annconjecture * (* annsequent *) - ((Cic.id, Cic.term) Hashtbl.t * (* id -> term *) - (Cic.id, Cic.id option) Hashtbl.t * (* id -> father id *) - (Cic.id, Cic.hypothesis) Hashtbl.t * (* id -> hypothesis *) - (Cic.id, Cic2acic.sort_kind) Hashtbl.t)) (* ids_to_inner_sorts *) - val nmml_of_cic_sequent: #NCicCoercion.status -> NCic.metasenv -> NCic.substitution -> (* metasenv, substitution *) @@ -57,65 +46,7 @@ val ntxt_of_cic_sequent: int * NCic.conjecture -> (* sequent *) string (* text *) -val mml_of_cic_object: - Cic.obj -> (* object *) - Gdome.document * (* Math ML *) - (Cic.annobj * (* annobj *) - ((Cic.id, Cic.term) Hashtbl.t * (* id -> term *) - (Cic.id, Cic.id option) Hashtbl.t * (* id -> father id *) - (Cic.id, Cic.conjecture) Hashtbl.t * (* id -> conjecture *) - (Cic.id, Cic.hypothesis) Hashtbl.t * (* id -> hypothesis *) - (Cic.id, Cic2acic.sort_kind) Hashtbl.t * (* ids_to_inner_sorts *) - (Cic.id, Cic2acic.anntypes) Hashtbl.t)) (* ids_to_inner_types *) - val nmml_of_cic_object: #NCicCoercion.status -> NCic.obj -> Gdome.document val ntxt_of_cic_object: map_unicode_to_tex:bool -> int -> #NCicCoercion.status -> NCic.obj -> string - -val txt_of_cic_sequent_all: - map_unicode_to_tex:bool -> int -> - Cic.metasenv -> (* metasenv *) - Cic.conjecture -> (* sequent *) - string * (* text *) - Cic.conjecture * (* unshared sequent *) - (Cic.annconjecture * (* annsequent *) - ((Cic.id, Cic.term) Hashtbl.t * (* id -> term *) - (Cic.id, Cic.id option) Hashtbl.t * (* id -> father id *) - (Cic.id, Cic.hypothesis) Hashtbl.t * (* id -> hypothesis *) - (Cic.id, Cic2acic.sort_kind) Hashtbl.t)) (* ids_to_inner_sorts *) - -val txt_of_cic_term: - map_unicode_to_tex:bool -> int -> Cic.metasenv -> Cic.context -> Cic.term -> - string -val txt_of_cic_sequent: - map_unicode_to_tex:bool -> int -> Cic.metasenv -> Cic.conjecture -> string -val txt_of_cic_sequent_conclusion: - map_unicode_to_tex:bool -> output_type:[`Pattern | `Term] -> int -> - Cic.metasenv -> Cic.conjecture -> string - -(* columns, params, object *) -val txt_of_cic_object: - map_unicode_to_tex:bool -> - ?skip_thm_and_qed:bool -> ?skip_initial_lambdas:int -> - int -> GrafiteAst.inline_param list -> Cic.obj -> - string - -val txt_of_cic_object_all: - map_unicode_to_tex:bool -> - ?skip_thm_and_qed:bool -> ?skip_initial_lambdas:int -> - int -> GrafiteAst.inline_param list -> Cic.obj -> - string * (* text *) - (Cic.annobj * (* annobj *) - ((Cic.id, Cic.term) Hashtbl.t * (* id -> term *) - (Cic.id, Cic.id option) Hashtbl.t * (* id -> father id *) - (Cic.id, Cic.conjecture) Hashtbl.t * (* id -> conjecture *) - (Cic.id, Cic.hypothesis) Hashtbl.t * (* id -> hypothesis *) - (Cic.id, Cic2acic.sort_kind) Hashtbl.t * (* ids_to_inner_sorts *) - (Cic.id, Cic2acic.anntypes) Hashtbl.t)) (* ids_to_inner_types *) - -val txt_of_macro: - map_unicode_to_tex:bool -> - Cic.metasenv -> - Cic.context -> - (Cic.term, Cic.lazy_term) GrafiteAst.macro -> string diff --git a/matita/matita/matita.ml b/matita/matita/matita.ml index b145c157a..99fa10acb 100644 --- a/matita/matita/matita.ml +++ b/matita/matita/matita.ml @@ -163,7 +163,7 @@ let _ = (fun mi () -> NCicRefiner.debug := mi#active; NCicUnification.debug := mi#active; MultiPassDisambiguator.debug := mi#active; NCicMetaSubst.debug := mi#active); addDebugCheckbox "reduction logging" - (fun mi () -> NCicReduction.debug := mi#active; CicReduction.ndebug := mi#active); + (fun mi () -> NCicReduction.debug := mi#active); addDebugSeparator (); addDebugItem "Expand virtuals" (fun _ -> (MatitaScript.current ())#expandAllVirtuals); diff --git a/matita/matita/matitaEngine.ml b/matita/matita/matitaEngine.ml index 03eccc104..c80405922 100644 --- a/matita/matita/matitaEngine.ml +++ b/matita/matita/matitaEngine.ml @@ -67,7 +67,7 @@ let eval_ast ?do_heavy_checks status (text,prefix_len,ast) = | G.Executable (_, G.Command (_, G.Coercion _)) when dump -> (* FG: some commands can not be executed when mmas are parsed *************) (* To be removed when mmas will be executed *) - status, `Old [] + status, `New [] | ast -> GrafiteEngine.eval_ast ~disambiguate_command:(disambiguate_command lexicon_status_ref) @@ -87,18 +87,11 @@ let eval_ast ?do_heavy_checks status (text,prefix_len,ast) = let v = LexiconAst.description_of_alias value in let b = try - (* this hack really sucks! *) - UriManager.buri_of_uri (UriManager.uri_of_string v) = baseuri + let NReference.Ref (uri,_) = NReference.reference_of_string v in + NUri.baseuri_of_uri uri = baseuri with - UriManager.IllFormedUri _ -> - try - (* this too! *) - let NReference.Ref (uri,_) = NReference.reference_of_string v in - let ouri = NCic2OCic.ouri_of_nuri uri in - UriManager.buri_of_uri ouri = baseuri - with - NReference.IllFormedReference _ -> - false (* v is a description, not a URI *) + NReference.IllFormedReference _ -> + false (* v is a description, not a URI *) in if b then status,acc diff --git a/matita/matita/matitaExcPp.ml b/matita/matita/matitaExcPp.ml index 8ccd85b2e..fe013421d 100644 --- a/matita/matita/matitaExcPp.ml +++ b/matita/matita/matitaExcPp.ml @@ -122,8 +122,6 @@ let rec to_string = | CicNotationParser.Parse_error err -> None, sprintf "Parse error: %s" err | UriManager.IllFormedUri uri -> None, sprintf "invalid uri: %s" uri - | CicEnvironment.Object_not_found uri -> - None, sprintf "object not found: %s" (UriManager.string_of_uri uri) | Unix.Unix_error (code, api, param) -> let err = Unix.error_message code in None, "Unix Error (" ^ api ^ "): " ^ err @@ -159,10 +157,6 @@ let rec to_string = None, "NCicUnification failure: " ^ Lazy.force msg | NCicUnification.Uncertain msg -> None, "NCicUnification uncertain: " ^ Lazy.force msg - | CicTypeChecker.TypeCheckerFailure msg -> - None, "Type checking error: " ^ Lazy.force msg - | CicTypeChecker.AssertFailure msg -> - None, "Type checking assertion failed: " ^ Lazy.force msg | LibrarySync.AlreadyDefined s -> None, "Already defined: " ^ UriManager.string_of_uri s | DisambiguateChoices.Choice_not_found msg -> diff --git a/matita/matita/matitaGui.ml b/matita/matita/matitaGui.ml index 793a914e0..a0d731377 100644 --- a/matita/matita/matitaGui.ml +++ b/matita/matita/matitaGui.ml @@ -867,7 +867,7 @@ class gui () = | false -> CicNotation.set_active_notations []); MatitaGtkMisc.toggle_callback ~check:main#hideCoercionsMenuItem - ~callback:(fun enabled -> Acic2content.hide_coercions := enabled); + ~callback:(fun enabled -> NTermCicContent.hide_coercions := enabled); MatitaGtkMisc.toggle_callback ~check:main#unicodeAsTexMenuItem ~callback:(fun enabled -> Helm_registry.set_bool "matita.paste_unicode_as_tex" enabled); diff --git a/matita/matita/matitaGuiTypes.mli b/matita/matita/matitaGuiTypes.mli index f7df481ae..af4a6b31d 100644 --- a/matita/matita/matitaGuiTypes.mli +++ b/matita/matita/matitaGuiTypes.mli @@ -130,11 +130,9 @@ object inherit clickableMathView (** load a sequent and render it into parent widget *) - method load_sequent: Cic.metasenv -> int -> unit method nload_sequent: #NCicCoercion.status -> NCic.metasenv -> NCic.substitution -> int -> unit - method load_object: Cic.obj -> unit method load_nobject: #NCicCoercion.status -> NCic.obj -> unit end diff --git a/matita/matita/matitaInit.ml b/matita/matita/matitaInit.ml index 43e76cda1..c40f81dff 100644 --- a/matita/matita/matitaInit.ml +++ b/matita/matita/matitaInit.ml @@ -97,8 +97,6 @@ let initialize_db init_status = wants [ ConfigurationFile; CmdLine ] init_status; if not (already_configured [ Db ] init_status) then begin - if not (Helm_registry.get_bool "matita.system") then - MetadataTypes.ownerize_tables (Helm_registry.get "matita.owner"); LibraryDb.create_owner_environment (); Db::init_status end @@ -112,11 +110,6 @@ let initialize_environment init_status = Http_getter.init (); if Helm_registry.get_bool "matita.system" then Http_getter_storage.activate_system_mode (); - CicEnvironment.set_trust (* environment trust *) - (let trust = - Helm_registry.get_opt_default Helm_registry.get_bool - ~default:true "matita.environment_trust" in - fun _ -> trust); Getter::Environment::init_status end else @@ -293,7 +286,5 @@ let initialize_environment () = status := initialize_environment !status let _ = - CicFix.init (); - CicRecord.init (); - CicElim.init () + CicFix.init () ;; diff --git a/matita/matita/matitaMathView.ml b/matita/matita/matitaMathView.ml index 5881c6d83..4b9fa4646 100644 --- a/matita/matita/matitaMathView.ml +++ b/matita/matita/matitaMathView.ml @@ -89,6 +89,7 @@ let closed_goal_mathml = lazy "chiuso per side effect..." (* ids_to_terms should not be passed here, is just for debugging *) let find_root_id annobj id ids_to_father_ids ids_to_terms ids_to_inner_types = + assert false (* MATITA 1.0 let find_parent id ids = let rec aux id = (* (prerr_endline (sprintf "id %s = %s" id @@ -128,6 +129,7 @@ let find_root_id annobj id ids_to_father_ids ids_to_terms ids_to_inner_types = return_father id (mk_ids (ty::inner_types)) | Cic.AInductiveDefinition _ -> assert false (* TODO *) + *) (** @return string content of a dom node having a single text child node, e.g. * bool *) @@ -613,27 +615,6 @@ object (self) val mutable current_mathml = None - method load_sequent metasenv metano = - let sequent = CicUtil.lookup_meta metano metasenv in - let (txt, unsh_sequent, - (_, (ids_to_terms, ids_to_father_ids, ids_to_hypotheses,_ ))) - = - ApplyTransformation.txt_of_cic_sequent_all - ~map_unicode_to_tex:false 80 (*MATITA 1.0??*) metasenv sequent - in - self#set_cic_info - (Some (Some unsh_sequent, - ids_to_terms, ids_to_hypotheses, ids_to_father_ids, - Hashtbl.create 1, None)); - (*MATITA 1.0 - if BuildTimeConf.debug then begin - let name = - "/tmp/sequent_viewer_" ^ string_of_int (Unix.getuid ()) ^ ".xml" in - HLog.debug ("load_sequent: dumping MathML to ./" ^ name); - ignore (domImpl#saveDocumentToFile ~name ~doc:txt ()) - end; *) - self#load_root ~root:txt - method nload_sequent: 'status. #NCicCoercion.status as 'status -> NCic.metasenv -> NCic.substitution -> int -> unit @@ -651,32 +632,6 @@ object (self) end;*) self#load_root ~root:txt - method load_object obj = - let use_diff = false in (* ZACK TODO use XmlDiff when re-rendering? *) - let (txt, - (annobj, (ids_to_terms, ids_to_father_ids, _, ids_to_hypotheses, _, ids_to_inner_types))) - = - ApplyTransformation.txt_of_cic_object_all ~map_unicode_to_tex:false - 80 [] obj - in - self#set_cic_info - (Some (None, ids_to_terms, ids_to_hypotheses, ids_to_father_ids, ids_to_inner_types, Some annobj)); - (match current_mathml with - | Some current_mathml when use_diff -> -assert false (*MATITA1.0 - self#freeze; - XmlDiff.update_dom ~from:current_mathml mathml; - self#thaw*) - | _ -> - (* MATITA1.0 if BuildTimeConf.debug then begin - let name = - "/tmp/cic_browser_" ^ string_of_int (Unix.getuid ()) ^ ".xml" in - HLog.debug ("cic_browser: dumping MathML to ./" ^ name); - ignore (domImpl#saveDocumentToFile ~name ~doc:mathml ()) - end;*) - self#load_root ~root:txt; - current_mathml <- Some txt); - method load_nobject : 'status. #NCicCoercion.status as 'status -> NCic.obj -> unit = fun status obj -> @@ -855,7 +810,7 @@ class sequentsViewer ~(notebook:GPack.notebook) ~(cicMathView:cicMathView) () = (match goal_switch with | Stack.Open goal -> (match _metasenv with - `Old menv -> cicMathView#load_sequent menv goal + `Old menv -> assert false (* MATITA 1.0 *) | `New (menv,subst) -> cicMathView#nload_sequent status menv subst goal) | Stack.Closed goal -> @@ -1036,7 +991,6 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history) object (self) inherit scriptAccessor - val mutable gviz_graph = MetadataDeps.DepGraph.dummy val mutable gviz_uri = UriManager.uri_of_string "cic:/dummy.con"; val dep_contextual_menu = GMenu.menu () @@ -1097,27 +1051,6 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history) | Some uri -> self#load (`Univs uri) | None -> ()); - (* fill dep graph contextual menu *) - let go_menu_item = - GMenu.image_menu_item ~label:"Browse it" - ~packing:dep_contextual_menu#append () in - let expand_menu_item = - GMenu.image_menu_item ~label:"Expand" - ~packing:dep_contextual_menu#append () in - let collapse_menu_item = - GMenu.image_menu_item ~label:"Collapse" - ~packing:dep_contextual_menu#append () in - dep_contextual_menu#append (go_menu_item :> GMenu.menu_item); - dep_contextual_menu#append (expand_menu_item :> GMenu.menu_item); - dep_contextual_menu#append (collapse_menu_item :> GMenu.menu_item); - connect_menu_item go_menu_item (fun () -> self#load (`Uri gviz_uri)); - connect_menu_item expand_menu_item (fun () -> - MetadataDeps.DepGraph.expand gviz_uri gviz_graph; - self#redraw_gviz ~center_on:gviz_uri ()); - connect_menu_item collapse_menu_item (fun () -> - MetadataDeps.DepGraph.collapse gviz_uri gviz_graph; - self#redraw_gviz ~center_on:gviz_uri ()); - self#_load (`About `Blank); toplevel#show () @@ -1210,9 +1143,9 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history) self#_loadTermNCic term metasenv subst ctx | `Dir dir -> self#_loadDir dir | `HBugs `Tutors -> self#_loadHBugsTutors - | `Uri uri -> self#_loadUriManagerUri uri + | `Uri uri -> assert false (* MATITA 1.0 *) | `NRef nref -> self#_loadNReference nref - | `Univs uri -> self#_loadUnivs uri); + | `Univs uri -> assert false (* MATITA 1.0 *)); self#setEntry entry end) @@ -1232,7 +1165,7 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history) if Sys.command "which dot" = 0 then let tmpfile, oc = Filename.open_temp_file "matita" ".dot" in let fmt = Format.formatter_of_out_channel oc in - MetadataDeps.DepGraph.render fmt gviz_graph; + (* MATITA 1.0 MetadataDeps.DepGraph.render fmt gviz_graph;*) close_out oc; gviz#load_graph_from_file ~gviz_cmd:"tred | dot" tmpfile; (match center_on with @@ -1246,6 +1179,7 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history) ~parent:win#toplevel () method private dependencies direction uri () = + assert false (* MATITA 1.0 let dbd = LibraryDb.instance () in let graph = match direction with @@ -1253,7 +1187,7 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history) | `Back -> MetadataDeps.DepGraph.inverse_deps ~dbd uri in gviz_graph <- graph; (** XXX check this for memory consuption *) self#redraw_gviz ~center_on:uri (); - self#_showGviz + self#_showGviz *) method private coerchgraph tred () = load_coerchgraph tred (); @@ -1310,29 +1244,10 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history) self#script#grafite_status#obj | _ -> self#blank () - (** loads a cic uri from the environment - * @param uri UriManager.uri *) - method private _loadUriManagerUri uri = - let uri = UriManager.strip_xpointer uri in - let (obj, _) = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - self#_loadObj obj - method private _loadNReference (NReference.Ref (uri,_)) = let obj = NCicEnvironment.get_checked_obj uri in self#_loadNObj self#script#grafite_status obj - method private _loadUnivs uri = - let uri = UriManager.strip_xpointer uri in - let (_, u) = CicEnvironment.get_obj CicUniv.empty_ugraph uri in - let _,us = CicUniv.do_rank u in - let l = - List.map - (fun u -> - [ CicUniv.string_of_universe u ; string_of_int (CicUniv.get_rank u)]) - us - in - self#_loadList2 l - method private _loadDir dir = let content = Http_getter.ls ~local:false dir in let l = @@ -1354,13 +1269,6 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history) win#browserUri#set_text (MatitaTypes.string_of_entry entry); current_entry <- entry - method private _loadObj obj = - (* showMath must be done _before_ loading the document, since if the - * widget is not mapped (hidden by the notebook) the document is not - * rendered *) - self#_showMath; - mathView#load_object obj - method private _loadNObj status obj = (* showMath must be done _before_ loading the document, since if the * widget is not mapped (hidden by the notebook) the document is not diff --git a/matita/matita/matitaScript.ml b/matita/matita/matitaScript.ml index b6ec2a51f..62305ec00 100644 --- a/matita/matita/matitaScript.ml +++ b/matita/matita/matitaScript.ml @@ -191,7 +191,6 @@ let eval_nmacro include_paths (buffer : GText.buffer) guistuff grafite_status us | TA.NAutoInteractive (_, (Some _,_)) -> assert false let rec eval_macro include_paths (buffer : GText.buffer) guistuff grafite_status user_goal unparsed_text parsed_text script mac = - let module CTC = CicTypeChecker in (* no idea why ocaml wants this *) let parsed_text_length = String.length parsed_text in let dbd = LibraryDb.instance () in diff --git a/matita/matita/matitacLib.ml b/matita/matita/matitacLib.ml index 583911e3e..114ed5937 100644 --- a/matita/matita/matitacLib.ml +++ b/matita/matita/matitacLib.ml @@ -140,6 +140,8 @@ let get_include_paths options = ;; let activate_extraction baseuri fname = + () + (* MATITA 1.0 if Helm_registry.get_bool "matita.extract" then let mangled_baseuri = let baseuri = String.sub baseuri 5 (String.length baseuri - 5) in @@ -152,6 +154,7 @@ let activate_extraction baseuri fname = (fun ~add_obj ~add_coercion _ obj -> output_string f (CicExportation.ppobj baseuri obj); flush f; []); + *) ;; let compile atstart options fname =