+++ /dev/null
-requires="helm-cic_proof_checking"
-version="0.0.1"
-archive(byte)="cic_acic.cma"
-archive(native)="cic_acic.cmxa"
+++ /dev/null
-requires="helm-cic_acic"
-version="0.0.1"
-archive(byte)="cic_exportation.cma"
-archive(native)="cic_exportation.cmxa"
-linkopts=""
+++ /dev/null
-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=""
-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"
-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"
+++ /dev/null
-requires="helm-hmysql helm-cic_proof_checking"
-version="0.0.1"
-archive(byte)="metadata.cma"
-archive(native)="metadata.cmxa"
-requires="helm-cic_proof_checking helm-library"
+requires="helm-library"
version="0.0.1"
archive(byte)="ng_kernel.cma"
archive(native)="ng_kernel.cmxa"
logger \
getter \
cic \
- cic_proof_checking \
- cic_acic \
- cic_exportation \
- metadata \
library \
ng_kernel \
acic_content \
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
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
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 \
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-(* $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
-
+++ /dev/null
-(* Copyright (C) 2005, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-module 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
-
+++ /dev/null
-(* 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 <asperti@cs.unibo.it> *)
-(* 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
-*)
-
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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 <asperti@cs.unibo.it> *)
-(* 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;;
+++ /dev/null
-(* 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 <asperti@cs.unibo.it> *)
-(* 27/6/2003 *)
-(* *)
-(**************************************************************************)
-
-val cobj2obj : Cic.annterm Content.cobj -> Cic.obj
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 <name, type> 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
| _ -> 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
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;;
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))
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;
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
#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@%)
+++ /dev/null
-extractor.cmo:
-extractor.cmx:
-extractor_manager.cmo:
-extractor_manager.cmx:
+++ /dev/null
-extractor.cmo:
-extractor.cmx:
-extractor_manager.cmo:
-extractor_manager.cmx:
+++ /dev/null
-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
+++ /dev/null
-<?xml version="1.0" encoding="utf-8"?>
-<helm_registry>
- <section name="tmp">
- <key name="dir">.tmp/</key>
- </section>
- <section name="db">
- <key name="metadata">mysql://mowgli.cs.unibo.it mowgli helm helm library</key>
- <key name="metadata">file:///tmp/ user.db helm helm user</key>
- </section>
- <section name="getter">
- <key name="servers">
- file:///projects/helm/library/coq_contribs
- </key>
- <key name="cache_dir">$(tmp.dir)/cache</key>
- <key name="maps_dir">$(tmp.dir)/maps</key>
- <key name="dtd_dir">/projects/helm/xml/dtd</key>
- </section>
-</helm_registry>
+++ /dev/null
-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 ()
-
+++ /dev/null
-(* 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 ()
+++ /dev/null
-table_creator.cmo:
-table_creator.cmx:
+++ /dev/null
-table_creator.cmo:
-table_creator.cmx:
+++ /dev/null
-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
+++ /dev/null
-#!/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."
-
+++ /dev/null
-
-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 ()
-
-
+++ /dev/null
-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
-
+++ /dev/null
-(* 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 <dumpfile> <uri_index>\n" ^
- " <dumpfile> is the file where environment will be dumped\n" ^
- " <uri_index> 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
-
+++ /dev/null
-(* 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 ())
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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 "\e[0;32mOK\e[0m %.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 "\e[0;31mSKIPPED\e[0m\n";
- flush stdout;
- if not !timeout then
- begin
- Printf.eprintf "\e[0;31mContinue with next URI? [y/_]\e[0m";
- 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 "\e[0;31mCIRCULARDEP\e[0m\n"
- | exn ->
- Printf.printf "\e[0;31mFAIL\e[0m\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 -> ()
+++ /dev/null
-(* 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 -> ()
-
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
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
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
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
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
--- /dev/null
+(* 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
+;;
+
+
--- /dev/null
+(* 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 <sacerdot@cs.unibo.it> *)
+(* 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
+++ /dev/null
-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
+++ /dev/null
-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
+++ /dev/null
-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
+++ /dev/null
-(* 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 "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
- X.xml_cdata ("<!DOCTYPE CurrentProof SYSTEM \""^ dtdname ^ "\">\n");
- xml_for_current_proof_body
- >] in
- let xmlty =
- [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
- X.xml_cdata ("<!DOCTYPE ConstantType SYSTEM \""^ dtdname ^ "\">\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
- "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
- X.xml_cdata
- ("<!DOCTYPE ConstantBody SYSTEM \"" ^ dtdname ^ "\">\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 "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
- X.xml_cdata ("<!DOCTYPE ConstantType SYSTEM \""^ dtdname ^ "\">\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 "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
- X.xml_cdata ("<!DOCTYPE Variable SYSTEM \"" ^ dtdname ^ "\">\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 "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
- X.xml_cdata
- ("<!DOCTYPE InductiveDefinition SYSTEM \"" ^ dtdname ^ "\">\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 "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
- X.xml_cdata
- ("<!DOCTYPE InnerTypes SYSTEM \"" ^ dtdname ^ "\">\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 [<>]
- )
- >]
-;;
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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 ())
+++ /dev/null
-(* 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 *)
+++ /dev/null
-(* 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
-;;
+++ /dev/null
-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
+++ /dev/null
-(* 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
-;;
+++ /dev/null
-(* 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
-
-
+++ /dev/null
-cicExportation.cmi:
-cicExportation.cmo: cicExportation.cmi
-cicExportation.cmx: cicExportation.cmi
+++ /dev/null
-cicExportation.cmi:
-cicExportation.cmo: cicExportation.cmi
-cicExportation.cmx: cicExportation.cmi
+++ /dev/null
-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
+++ /dev/null
-(* 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"
-;;
+++ /dev/null
-(* 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
+++ /dev/null
-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
+++ /dev/null
-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
+++ /dev/null
-
-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
+++ /dev/null
-(* 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}
+++ /dev/null
-(* 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
+++ /dev/null
-(* 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 <sacerdot@cs.unibo.it> *)
-(* 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 ()
-;;
+++ /dev/null
-(* 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 <sacerdot@cs.unibo.it> *)
-(* 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 *)
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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)
-;;
+++ /dev/null
-(* 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
+++ /dev/null
-(* 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
-;;
-
-
+++ /dev/null
-(* 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 <sacerdot@cs.unibo.it> *)
-(* 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
+++ /dev/null
-(* 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
-*)
+++ /dev/null
-(* 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
+++ /dev/null
-(* 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;;
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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);;
+++ /dev/null
-(* 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
+++ /dev/null
-(* 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 <tassi@cs.unibo.it> *)
-(* 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
-*)
+++ /dev/null
-(* 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
-
+++ /dev/null
-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)
+++ /dev/null
-(* 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)
-;;
+++ /dev/null
-(* 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
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 [] [
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
(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)
(* *)
(**************************************************************************)
-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 ->
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
(* *)
(***************************************************************************)
-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 ->
| `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:
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 =
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 *)
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
~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
| 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 []
}
;;
| _ -> [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
=
| 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)
;;
| 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"
~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)
| 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
coercDb.mli \
cicCoercion.mli \
librarySync.mli \
- cicElim.mli \
- cicRecord.mli \
cicFix.mli \
libraryClean.mli \
$(NULL)
+++ /dev/null
-(* 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;;
+++ /dev/null
-(* 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
+++ /dev/null
-(* 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;;
+++ /dev/null
-(* 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
;;
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
| 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 =
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
[]
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
HExtlib.list_uniq l
with
exn -> raise exn (* no errors should be accepted *)
+ *)
;;
let close_uri_list cache_of_processed_baseuri uri_to_remove =
;;
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 =
MetadataTypes.count_tbl()]
end
end
+ *)
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
| 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
raise exc
| _ -> ())
statements
+ *)
;;
(* removes uri from the ownerized tables, and returns the list of other objects
* 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
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 =
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
-
+*)
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)
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])
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
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
CoercDb.add_coercion (src_carr, tgt_carr, uri, saturations, cpos);
(* CoercDb.prefer uri; *)
lemmas
+ *)
;;
+++ /dev/null
-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
+++ /dev/null
-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
+++ /dev/null
-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
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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, constants>
- * 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
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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
+++ /dev/null
-(* Copyright (C) 2006, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
-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 *)
- }
-
- (** <adjacency list of the dependency graph,
- * root,
- * generator function,
- * invert edges on render?>
- * 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
-
+++ /dev/null
-(* Copyright (C) 2006, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://helm.cs.unibo.it/
- *)
-
- (** @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
-
+++ /dev/null
-(* 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)
-
+++ /dev/null
-(* 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 <uri, shortname, metadata> *)
-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
-
+++ /dev/null
-(* 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))
-*)
-
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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
-
+++ /dev/null
-(* 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))
-
+++ /dev/null
-(* 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 <table name, table type>; 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
-
type id = string
+let hide_coercions = ref true;;
+
(*
type interpretation_id = int
| 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
type id = string
+val hide_coercions: bool ref
+
val nmap_sequent:
#NCicCoercion.status -> metasenv:NCic.metasenv -> subst:NCic.substitution ->
int * NCic.conjecture ->
Filename.chop_extension name
;;
+let baseuri_of_uri (_,uri) =
+ Filename.dirname uri
+;;
+
module OrderedStrings =
struct
type t = string
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
-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
-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
PREDICATES =
INTERFACE_FILES = \
- nCic2OCic.mli \
- oCic2NCic.mli \
nCicLibrary.mli
IMPLEMENTATION_FILES = \
%.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 $@ $<
+++ /dev/null
-(*
- ||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)
-;;
+++ /dev/null
-(*
- ||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,[])]
-;;
+++ /dev/null
-(*
- ||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
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;;
+++ /dev/null
-(*
- ||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;;
-*)
+++ /dev/null
-(*
- ||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
+++ /dev/null
-(*
- ||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;
-;;
helm-hgdome \
helm-ng_paramodulation \
helm-ng_tactics \
-helm-cic_exportation \
"
FINDLIB_CREQUIRES=" \
$FINDLIB_COMREQUIRES \
(* $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
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
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
-;;
-
-
(* *)
(***************************************************************************)
-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 *)
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
(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);
| 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)
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
| 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
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 ->
| 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);
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
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
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
status := initialize_environment !status
let _ =
- CicFix.init ();
- CicRecord.init ();
- CicElim.init ()
+ CicFix.init ()
;;
(* 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
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.
* <m:mi xlink:href="...">bool</m:mi> *)
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
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 ->
(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 ->
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 ()
| 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 ()
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)
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
~parent:win#toplevel ()
method private dependencies direction uri () =
+ assert false (* MATITA 1.0
let dbd = LibraryDb.instance () in
let graph =
match direction with
| `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 ();
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 =
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
| 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
;;
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
(fun ~add_obj ~add_coercion _ obj ->
output_string f (CicExportation.ppobj baseuri obj);
flush f; []);
+ *)
;;
let compile atstart options fname =
projects / helm.git / commitdiff