aboutsummaryrefslogtreecommitdiff
path: root/plugins/funind
diff options
context:
space:
mode:
authorglondu2009-09-17 15:58:14 +0000
committerglondu2009-09-17 15:58:14 +0000
commit61ccbc81a2f3b4662ed4a2bad9d07d2003dda3a2 (patch)
tree961cc88c714aa91a0276ea9fbf8bc53b2b9d5c28 /plugins/funind
parent6d3fbdf36c6a47b49c2a4b16f498972c93c07574 (diff)
Delete trailing whitespaces in all *.{v,ml*} files
git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/coq/trunk@12337 85f007b7-540e-0410-9357-904b9bb8a0f7
Diffstat (limited to 'plugins/funind')
-rw-r--r--plugins/funind/Recdef.v12
-rw-r--r--plugins/funind/functional_principles_proofs.ml1168
-rw-r--r--plugins/funind/functional_principles_proofs.mli4
-rw-r--r--plugins/funind/functional_principles_types.ml480
-rw-r--r--plugins/funind/functional_principles_types.mli16
-rw-r--r--plugins/funind/g_indfun.ml4202
-rw-r--r--plugins/funind/indfun.ml600
-rw-r--r--plugins/funind/indfun_common.ml232
-rw-r--r--plugins/funind/indfun_common.mli52
-rw-r--r--plugins/funind/invfun.ml670
-rw-r--r--plugins/funind/merge.ml330
-rw-r--r--plugins/funind/rawterm_to_relation.ml1118
-rw-r--r--plugins/funind/rawterm_to_relation.mli4
-rw-r--r--plugins/funind/rawtermops.ml592
-rw-r--r--plugins/funind/rawtermops.mli60
-rw-r--r--plugins/funind/recdef.ml744
16 files changed, 3142 insertions, 3142 deletions
diff --git a/plugins/funind/Recdef.v b/plugins/funind/Recdef.v
index 2d206220e4..00302a741d 100644
--- a/plugins/funind/Recdef.v
+++ b/plugins/funind/Recdef.v
@@ -20,21 +20,21 @@ Fixpoint iter (n : nat) : (A -> A) -> A -> A :=
End Iter.
Theorem SSplus_lt : forall p p' : nat, p < S (S (p + p')).
- intro p; intro p'; change (S p <= S (S (p + p')));
- apply le_S; apply Gt.gt_le_S; change (p < S (p + p'));
+ intro p; intro p'; change (S p <= S (S (p + p')));
+ apply le_S; apply Gt.gt_le_S; change (p < S (p + p'));
apply Lt.le_lt_n_Sm; apply Plus.le_plus_l.
Qed.
-
+
Theorem Splus_lt : forall p p' : nat, p' < S (p + p').
- intro p; intro p'; change (S p' <= S (p + p'));
+ intro p; intro p'; change (S p' <= S (p + p'));
apply Gt.gt_le_S; change (p' < S (p + p')); apply Lt.le_lt_n_Sm;
apply Plus.le_plus_r.
Qed.
Theorem le_lt_SS : forall x y, x <= y -> x < S (S y).
-intro x; intro y; intro H; change (S x <= S (S y));
- apply le_S; apply Gt.gt_le_S; change (x < S y);
+intro x; intro y; intro H; change (S x <= S (S y));
+ apply le_S; apply Gt.gt_le_S; change (x < S y);
apply Lt.le_lt_n_Sm; exact H.
Qed.
diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml
index 9087f51798..90eb499422 100644
--- a/plugins/funind/functional_principles_proofs.ml
+++ b/plugins/funind/functional_principles_proofs.ml
@@ -1,8 +1,8 @@
open Printer
open Util
open Term
-open Termops
-open Names
+open Termops
+open Names
open Declarations
open Pp
open Entries
@@ -16,7 +16,7 @@ open Indfun_common
open Libnames
let msgnl = Pp.msgnl
-
+
let observe strm =
if do_observe ()
@@ -35,11 +35,11 @@ let do_observe_tac s tac g =
try let v = tac g in (* msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); *) v
with e ->
let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in
- msgnl (str "observation "++ s++str " raised exception " ++
- Cerrors.explain_exn e ++ str " on goal " ++ goal );
+ msgnl (str "observation "++ s++str " raised exception " ++
+ Cerrors.explain_exn e ++ str " on goal " ++ goal );
raise e;;
-let observe_tac_stream s tac g =
+let observe_tac_stream s tac g =
if do_observe ()
then do_observe_tac s tac g
else tac g
@@ -52,54 +52,54 @@ let observe_tac s tac g = observe_tac_stream (str s) tac g
(* else tac *)
-let list_chop ?(msg="") n l =
- try
- list_chop n l
- with Failure (msg') ->
+let list_chop ?(msg="") n l =
+ try
+ list_chop n l
+ with Failure (msg') ->
failwith (msg ^ msg')
-
+
let make_refl_eq constructor type_of_t t =
(* let refl_equal_term = Lazy.force refl_equal in *)
mkApp(constructor,[|type_of_t;t|])
-type pte_info =
- {
+type pte_info =
+ {
proving_tac : (identifier list -> Tacmach.tactic);
is_valid : constr -> bool
}
type ptes_info = pte_info Idmap.t
-type 'a dynamic_info =
- {
+type 'a dynamic_info =
+ {
nb_rec_hyps : int;
- rec_hyps : identifier list ;
+ rec_hyps : identifier list ;
eq_hyps : identifier list;
info : 'a
}
-type body_info = constr dynamic_info
-
+type body_info = constr dynamic_info
+
-let finish_proof dynamic_infos g =
- observe_tac "finish"
+let finish_proof dynamic_infos g =
+ observe_tac "finish"
( h_assumption)
g
-
-let refine c =
+
+let refine c =
Tacmach.refine_no_check c
-let thin l =
+let thin l =
Tacmach.thin_no_check l
-
-let cut_replacing id t tac :tactic=
+
+let cut_replacing id t tac :tactic=
tclTHENS (cut t)
[ tclTHEN (thin_no_check [id]) (introduction_no_check id);
- tac
+ tac
]
let intro_erasing id = tclTHEN (thin [id]) (introduction id)
@@ -108,54 +108,54 @@ let intro_erasing id = tclTHEN (thin [id]) (introduction id)
let rec_hyp_id = id_of_string "rec_hyp"
-let is_trivial_eq t =
- let res = try
+let is_trivial_eq t =
+ let res = try
begin
- match kind_of_term t with
- | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) ->
+ match kind_of_term t with
+ | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) ->
eq_constr t1 t2
| App(f,[|t1;a1;t2;a2|]) when eq_constr f (jmeq ()) ->
eq_constr t1 t2 && eq_constr a1 a2
- | _ -> false
+ | _ -> false
end
with _ -> false
in
(* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *)
res
-let rec incompatible_constructor_terms t1 t2 =
- let c1,arg1 = decompose_app t1
- and c2,arg2 = decompose_app t2
- in
+let rec incompatible_constructor_terms t1 t2 =
+ let c1,arg1 = decompose_app t1
+ and c2,arg2 = decompose_app t2
+ in
(not (eq_constr t1 t2)) &&
- isConstruct c1 && isConstruct c2 &&
+ isConstruct c1 && isConstruct c2 &&
(
- not (eq_constr c1 c2) ||
+ not (eq_constr c1 c2) ||
List.exists2 incompatible_constructor_terms arg1 arg2
)
-let is_incompatible_eq t =
+let is_incompatible_eq t =
let res =
try
- match kind_of_term t with
- | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) ->
+ match kind_of_term t with
+ | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) ->
incompatible_constructor_terms t1 t2
- | App(f,[|u1;t1;u2;t2|]) when eq_constr f (jmeq ()) ->
+ | App(f,[|u1;t1;u2;t2|]) when eq_constr f (jmeq ()) ->
(eq_constr u1 u2 &&
incompatible_constructor_terms t1 t2)
- | _ -> false
+ | _ -> false
with _ -> false
- in
+ in
if res then observe (str "is_incompatible_eq " ++ Printer.pr_lconstr t);
res
-let change_hyp_with_using msg hyp_id t tac : tactic =
- fun g ->
- let prov_id = pf_get_new_id hyp_id g in
+let change_hyp_with_using msg hyp_id t tac : tactic =
+ fun g ->
+ let prov_id = pf_get_new_id hyp_id g in
tclTHENS
((* observe_tac msg *) (assert_by (Name prov_id) t (tclCOMPLETE tac)))
- [tclTHENLIST
- [
+ [tclTHENLIST
+ [
(* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]);
(* observe_tac "change_hyp_with_using rename " *) (h_rename [prov_id,hyp_id])
]] g
@@ -163,20 +163,20 @@ let change_hyp_with_using msg hyp_id t tac : tactic =
exception TOREMOVE
-let prove_trivial_eq h_id context (constructor,type_of_term,term) =
- let nb_intros = List.length context in
+let prove_trivial_eq h_id context (constructor,type_of_term,term) =
+ let nb_intros = List.length context in
tclTHENLIST
[
tclDO nb_intros intro; (* introducing context *)
- (fun g ->
- let context_hyps =
- fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g))
+ (fun g ->
+ let context_hyps =
+ fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g))
in
- let context_hyps' =
+ let context_hyps' =
(mkApp(constructor,[|type_of_term;term|]))::
(List.map mkVar context_hyps)
in
- let to_refine = applist(mkVar h_id,List.rev context_hyps') in
+ let to_refine = applist(mkVar h_id,List.rev context_hyps') in
refine to_refine g
)
]
@@ -191,124 +191,124 @@ let find_rectype env c =
| _ -> raise Not_found
-let isAppConstruct ?(env=Global.env ()) t =
- try
- let t',l = find_rectype (Global.env ()) t in
+let isAppConstruct ?(env=Global.env ()) t =
+ try
+ let t',l = find_rectype (Global.env ()) t in
observe (str "isAppConstruct : " ++ Printer.pr_lconstr t ++ str " -> " ++ Printer.pr_lconstr (applist (t',l)));
true
- with Not_found -> false
+ with Not_found -> false
let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *)
let clos_norm_flags flgs env sigma t =
Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in
clos_norm_flags Closure.betaiotazeta Environ.empty_env Evd.empty
-
-let change_eq env sigma hyp_id (context:rel_context) x t end_of_type =
- let nochange ?t' msg =
- begin
+
+let change_eq env sigma hyp_id (context:rel_context) x t end_of_type =
+ let nochange ?t' msg =
+ begin
observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t ++ str " " ++ match t' with None -> str "" | Some t -> Printer.pr_lconstr t );
- failwith "NoChange";
+ failwith "NoChange";
end
- in
- let eq_constr = Reductionops.is_conv env sigma in
+ in
+ let eq_constr = Reductionops.is_conv env sigma in
if not (noccurn 1 end_of_type)
then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *)
if not (isApp t) then nochange "not an equality";
let f_eq,args = destApp t in
- let constructor,t1,t2,t1_typ =
- try
- if (eq_constr f_eq (Lazy.force eq))
- then
+ let constructor,t1,t2,t1_typ =
+ try
+ if (eq_constr f_eq (Lazy.force eq))
+ then
let t1 = (args.(1),args.(0))
- and t2 = (args.(2),args.(0))
+ and t2 = (args.(2),args.(0))
and t1_typ = args.(0)
in
(Lazy.force refl_equal,t1,t2,t1_typ)
else
- if (eq_constr f_eq (jmeq ()))
- then
+ if (eq_constr f_eq (jmeq ()))
+ then
(jmeq_refl (),(args.(1),args.(0)),(args.(3),args.(2)),args.(0))
else nochange "not an equality"
with _ -> nochange "not an equality"
- in
- if not ((closed0 (fst t1)) && (closed0 (snd t1)))then nochange "not a closed lhs";
- let rec compute_substitution sub t1 t2 =
+ in
+ if not ((closed0 (fst t1)) && (closed0 (snd t1)))then nochange "not a closed lhs";
+ let rec compute_substitution sub t1 t2 =
(* observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *)
- if isRel t2
- then
- let t2 = destRel t2 in
- begin
- try
- let t1' = Intmap.find t2 sub in
+ if isRel t2
+ then
+ let t2 = destRel t2 in
+ begin
+ try
+ let t1' = Intmap.find t2 sub in
if not (eq_constr t1 t1') then nochange "twice bound variable";
sub
- with Not_found ->
+ with Not_found ->
assert (closed0 t1);
Intmap.add t2 t1 sub
end
- else if isAppConstruct t1 && isAppConstruct t2
- then
+ else if isAppConstruct t1 && isAppConstruct t2
+ then
begin
let c1,args1 = find_rectype env t1
and c2,args2 = find_rectype env t2
- in
+ in
if not (eq_constr c1 c2) then nochange "cannot solve (diff)";
List.fold_left2 compute_substitution sub args1 args2
end
- else
+ else
if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reduction.whd_betadeltaiota env t1) t2) "cannot solve (diff)"
in
- let sub = compute_substitution Intmap.empty (snd t1) (snd t2) in
+ let sub = compute_substitution Intmap.empty (snd t1) (snd t2) in
let sub = compute_substitution sub (fst t1) (fst t2) in
- let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *)
- let new_end_of_type =
- (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4
+ let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *)
+ let new_end_of_type =
+ (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4
Can be safely replaced by the next comment for Ocaml >= 3.08.4
*)
- let sub' = Intmap.fold (fun i t acc -> (i,t)::acc) sub [] in
- let sub'' = List.sort (fun (x,_) (y,_) -> Pervasives.compare x y) sub' in
+ let sub' = Intmap.fold (fun i t acc -> (i,t)::acc) sub [] in
+ let sub'' = List.sort (fun (x,_) (y,_) -> Pervasives.compare x y) sub' in
List.fold_left (fun end_of_type (i,t) -> lift 1 (substnl [t] (i-1) end_of_type))
end_of_type_with_pop
sub''
in
let old_context_length = List.length context + 1 in
- let witness_fun =
+ let witness_fun =
mkLetIn(Anonymous,make_refl_eq constructor t1_typ (fst t1),t,
mkApp(mkVar hyp_id,Array.init old_context_length (fun i -> mkRel (old_context_length - i)))
)
in
- let new_type_of_hyp,ctxt_size,witness_fun =
- list_fold_left_i
- (fun i (end_of_type,ctxt_size,witness_fun) ((x',b',t') as decl) ->
- try
- let witness = Intmap.find i sub in
+ let new_type_of_hyp,ctxt_size,witness_fun =
+ list_fold_left_i
+ (fun i (end_of_type,ctxt_size,witness_fun) ((x',b',t') as decl) ->
+ try
+ let witness = Intmap.find i sub in
if b' <> None then anomaly "can not redefine a rel!";
(pop end_of_type,ctxt_size,mkLetIn(x',witness,t',witness_fun))
- with Not_found ->
+ with Not_found ->
(mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun)
)
- 1
+ 1
(new_end_of_type,0,witness_fun)
context
in
let new_type_of_hyp =
- Reductionops.nf_betaiota Evd.empty new_type_of_hyp in
- let new_ctxt,new_end_of_type =
- decompose_prod_n_assum ctxt_size new_type_of_hyp
- in
- let prove_new_hyp : tactic =
+ Reductionops.nf_betaiota Evd.empty new_type_of_hyp in
+ let new_ctxt,new_end_of_type =
+ decompose_prod_n_assum ctxt_size new_type_of_hyp
+ in
+ let prove_new_hyp : tactic =
tclTHEN
(tclDO ctxt_size intro)
(fun g ->
- let all_ids = pf_ids_of_hyps g in
- let new_ids,_ = list_chop ctxt_size all_ids in
- let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in
+ let all_ids = pf_ids_of_hyps g in
+ let new_ids,_ = list_chop ctxt_size all_ids in
+ let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in
refine to_refine g
)
in
- let simpl_eq_tac =
+ let simpl_eq_tac =
change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp prove_new_hyp
in
(* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *)
@@ -328,51 +328,51 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type =
new_ctxt,new_end_of_type,simpl_eq_tac
-let is_property ptes_info t_x full_type_of_hyp =
- if isApp t_x
- then
- let pte,args = destApp t_x in
- if isVar pte && array_for_all closed0 args
- then
- try
- let info = Idmap.find (destVar pte) ptes_info in
- info.is_valid full_type_of_hyp
- with Not_found -> false
- else false
- else false
+let is_property ptes_info t_x full_type_of_hyp =
+ if isApp t_x
+ then
+ let pte,args = destApp t_x in
+ if isVar pte && array_for_all closed0 args
+ then
+ try
+ let info = Idmap.find (destVar pte) ptes_info in
+ info.is_valid full_type_of_hyp
+ with Not_found -> false
+ else false
+ else false
-let isLetIn t =
- match kind_of_term t with
- | LetIn _ -> true
- | _ -> false
+let isLetIn t =
+ match kind_of_term t with
+ | LetIn _ -> true
+ | _ -> false
-let h_reduce_with_zeta =
- h_reduce
+let h_reduce_with_zeta =
+ h_reduce
(Rawterm.Cbv
- {Rawterm.all_flags
- with Rawterm.rDelta = false;
+ {Rawterm.all_flags
+ with Rawterm.rDelta = false;
})
-
+
let rewrite_until_var arg_num eq_ids : tactic =
- (* tests if the declares recursive argument is neither a Constructor nor
- an applied Constructor since such a form for the recursive argument
- will break the Guard when trying to save the Lemma.
+ (* tests if the declares recursive argument is neither a Constructor nor
+ an applied Constructor since such a form for the recursive argument
+ will break the Guard when trying to save the Lemma.
*)
- let test_var g =
- let _,args = destApp (pf_concl g) in
+ let test_var g =
+ let _,args = destApp (pf_concl g) in
not ((isConstruct args.(arg_num)) || isAppConstruct args.(arg_num))
in
- let rec do_rewrite eq_ids g =
- if test_var g
+ let rec do_rewrite eq_ids g =
+ if test_var g
then tclIDTAC g
else
- match eq_ids with
+ match eq_ids with
| [] -> anomaly "Cannot find a way to prove recursive property";
- | eq_id::eq_ids ->
- tclTHEN
+ | eq_id::eq_ids ->
+ tclTHEN
(tclTRY (Equality.rewriteRL (mkVar eq_id)))
(do_rewrite eq_ids)
g
@@ -380,50 +380,50 @@ let rewrite_until_var arg_num eq_ids : tactic =
do_rewrite eq_ids
-let rec_pte_id = id_of_string "Hrec"
-let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
- let coq_False = Coqlib.build_coq_False () in
- let coq_True = Coqlib.build_coq_True () in
- let coq_I = Coqlib.build_coq_I () in
- let rec scan_type context type_of_hyp : tactic =
- if isLetIn type_of_hyp then
+let rec_pte_id = id_of_string "Hrec"
+let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
+ let coq_False = Coqlib.build_coq_False () in
+ let coq_True = Coqlib.build_coq_True () in
+ let coq_I = Coqlib.build_coq_I () in
+ let rec scan_type context type_of_hyp : tactic =
+ if isLetIn type_of_hyp then
let real_type_of_hyp = it_mkProd_or_LetIn ~init:type_of_hyp context in
- let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in
+ let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in
(* length of context didn't change ? *)
- let new_context,new_typ_of_hyp =
+ let new_context,new_typ_of_hyp =
decompose_prod_n_assum (List.length context) reduced_type_of_hyp
in
- tclTHENLIST
+ tclTHENLIST
[
h_reduce_with_zeta
(Tacticals.onHyp hyp_id)
;
- scan_type new_context new_typ_of_hyp
-
+ scan_type new_context new_typ_of_hyp
+
]
- else if isProd type_of_hyp
- then
- begin
- let (x,t_x,t') = destProd type_of_hyp in
- let actual_real_type_of_hyp = it_mkProd_or_LetIn ~init:t' context in
+ else if isProd type_of_hyp
+ then
+ begin
+ let (x,t_x,t') = destProd type_of_hyp in
+ let actual_real_type_of_hyp = it_mkProd_or_LetIn ~init:t' context in
if is_property ptes_infos t_x actual_real_type_of_hyp then
begin
- let pte,pte_args = (destApp t_x) in
- let (* fix_info *) prove_rec_hyp = (Idmap.find (destVar pte) ptes_infos).proving_tac in
- let popped_t' = pop t' in
- let real_type_of_hyp = it_mkProd_or_LetIn ~init:popped_t' context in
- let prove_new_type_of_hyp =
- let context_length = List.length context in
+ let pte,pte_args = (destApp t_x) in
+ let (* fix_info *) prove_rec_hyp = (Idmap.find (destVar pte) ptes_infos).proving_tac in
+ let popped_t' = pop t' in
+ let real_type_of_hyp = it_mkProd_or_LetIn ~init:popped_t' context in
+ let prove_new_type_of_hyp =
+ let context_length = List.length context in
tclTHENLIST
- [
- tclDO context_length intro;
- (fun g ->
- let context_hyps_ids =
+ [
+ tclDO context_length intro;
+ (fun g ->
+ let context_hyps_ids =
fst (list_chop ~msg:"rec hyp : context_hyps"
context_length (pf_ids_of_hyps g))
in
- let rec_pte_id = pf_get_new_id rec_pte_id g in
- let to_refine =
+ let rec_pte_id = pf_get_new_id rec_pte_id g in
+ let to_refine =
applist(mkVar hyp_id,
List.rev_map mkVar (rec_pte_id::context_hyps_ids)
)
@@ -440,39 +440,39 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
)
]
in
- tclTHENLIST
+ tclTHENLIST
[
(* observe_tac "hyp rec" *)
(change_hyp_with_using "rec_hyp_tac" hyp_id real_type_of_hyp prove_new_type_of_hyp);
scan_type context popped_t'
]
end
- else if eq_constr t_x coq_False then
+ else if eq_constr t_x coq_False then
begin
(* observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ *)
(* str " since it has False in its preconds " *)
(* ); *)
raise TOREMOVE; (* False -> .. useless *)
end
- else if is_incompatible_eq t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *)
+ else if is_incompatible_eq t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *)
else if eq_constr t_x coq_True (* Trivial => we remove this precons *)
- then
+ then
(* observe (str "In "++Ppconstr.pr_id hyp_id++ *)
(* str " removing useless precond True" *)
(* ); *)
let popped_t' = pop t' in
- let real_type_of_hyp =
- it_mkProd_or_LetIn ~init:popped_t' context
- in
- let prove_trivial =
- let nb_intro = List.length context in
+ let real_type_of_hyp =
+ it_mkProd_or_LetIn ~init:popped_t' context
+ in
+ let prove_trivial =
+ let nb_intro = List.length context in
tclTHENLIST [
tclDO nb_intro intro;
- (fun g ->
- let context_hyps =
+ (fun g ->
+ let context_hyps =
fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g))
in
- let to_refine =
+ let to_refine =
applist (mkVar hyp_id,
List.rev (coq_I::List.map mkVar context_hyps)
)
@@ -482,19 +482,19 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
]
in
tclTHENLIST[
- change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp
+ change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp
((* observe_tac "prove_trivial" *) prove_trivial);
scan_type context popped_t'
]
- else if is_trivial_eq t_x
- then (* t_x := t = t => we remove this precond *)
+ else if is_trivial_eq t_x
+ then (* t_x := t = t => we remove this precond *)
let popped_t' = pop t' in
let real_type_of_hyp =
it_mkProd_or_LetIn ~init:popped_t' context
in
let hd,args = destApp t_x in
- let get_args hd args =
- if eq_constr hd (Lazy.force eq)
+ let get_args hd args =
+ if eq_constr hd (Lazy.force eq)
then (Lazy.force refl_equal,args.(0),args.(1))
else (jmeq_refl (),args.(0),args.(1))
in
@@ -504,77 +504,77 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
"prove_trivial_eq"
hyp_id
real_type_of_hyp
- ((* observe_tac "prove_trivial_eq" *)
+ ((* observe_tac "prove_trivial_eq" *)
(prove_trivial_eq hyp_id context (get_args hd args)));
scan_type context popped_t'
- ]
- else
+ ]
+ else
begin
- try
- let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in
+ try
+ let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in
tclTHEN
- tac
+ tac
(scan_type new_context new_t')
- with Failure "NoChange" ->
- (* Last thing todo : push the rel in the context and continue *)
+ with Failure "NoChange" ->
+ (* Last thing todo : push the rel in the context and continue *)
scan_type ((x,None,t_x)::context) t'
end
end
else
tclIDTAC
- in
- try
+ in
+ try
scan_type [] (Typing.type_of env sigma (mkVar hyp_id)), [hyp_id]
- with TOREMOVE ->
+ with TOREMOVE ->
thin [hyp_id],[]
-let clean_goal_with_heq ptes_infos continue_tac dyn_infos =
- fun g ->
- let env = pf_env g
- and sigma = project g
+let clean_goal_with_heq ptes_infos continue_tac dyn_infos =
+ fun g ->
+ let env = pf_env g
+ and sigma = project g
in
- let tac,new_hyps =
- List.fold_left (
+ let tac,new_hyps =
+ List.fold_left (
fun (hyps_tac,new_hyps) hyp_id ->
- let hyp_tac,new_hyp =
- clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma
+ let hyp_tac,new_hyp =
+ clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma
in
(tclTHEN hyp_tac hyps_tac),new_hyp@new_hyps
)
(tclIDTAC,[])
dyn_infos.rec_hyps
in
- let new_infos =
- { dyn_infos with
- rec_hyps = new_hyps;
+ let new_infos =
+ { dyn_infos with
+ rec_hyps = new_hyps;
nb_rec_hyps = List.length new_hyps
}
in
- tclTHENLIST
+ tclTHENLIST
[
tac ;
(* observe_tac "clean_hyp_with_heq continue" *) (continue_tac new_infos)
]
- g
+ g
let heq_id = id_of_string "Heq"
-let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos =
- fun g ->
- let heq_id = pf_get_new_id heq_id g in
+let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos =
+ fun g ->
+ let heq_id = pf_get_new_id heq_id g in
let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in
tclTHENLIST
- [
- (* We first introduce the variables *)
+ [
+ (* We first introduce the variables *)
tclDO nb_first_intro (intro_avoiding dyn_infos.rec_hyps);
(* Then the equation itself *)
introduction_no_check heq_id;
- (* Then the new hypothesis *)
+ (* Then the new hypothesis *)
tclMAP introduction_no_check dyn_infos.rec_hyps;
- (* observe_tac "after_introduction" *)(fun g' ->
+ (* observe_tac "after_introduction" *)(fun g' ->
(* We get infos on the equations introduced*)
- let new_term_value_eq = pf_type_of g' (mkVar heq_id) in
+ let new_term_value_eq = pf_type_of g' (mkVar heq_id) in
(* compute the new value of the body *)
let new_term_value =
match kind_of_term new_term_value_eq with
@@ -592,31 +592,31 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos =
)
in
let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in
- let new_infos =
- {dyn_infos with
+ let new_infos =
+ {dyn_infos with
info = new_body;
eq_hyps = heq_id::dyn_infos.eq_hyps
}
- in
+ in
clean_goal_with_heq ptes_infos continue_tac new_infos g'
)
]
g
-let my_orelse tac1 tac2 g =
- try
- tac1 g
- with e ->
+let my_orelse tac1 tac2 g =
+ try
+ tac1 g
+ with e ->
(* observe (str "using snd tac since : " ++ Cerrors.explain_exn e); *)
- tac2 g
+ tac2 g
-let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id =
- let args = Array.of_list (List.map mkVar args_id) in
- let instanciate_one_hyp hid =
+let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id =
+ let args = Array.of_list (List.map mkVar args_id) in
+ let instanciate_one_hyp hid =
my_orelse
( (* we instanciate the hyp if possible *)
- fun g ->
+ fun g ->
let prov_hid = pf_get_new_id hid g in
tclTHENLIST[
pose_proof (Name prov_hid) (mkApp(mkVar hid,args));
@@ -625,21 +625,21 @@ let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id
] g
)
( (*
- if not then we are in a mutual function block
+ if not then we are in a mutual function block
and this hyp is a recursive hyp on an other function.
-
- We are not supposed to use it while proving this
- principle so that we can trash it
-
+
+ We are not supposed to use it while proving this
+ principle so that we can trash it
+
*)
- (fun g ->
+ (fun g ->
(* observe (str "Instanciation: removing hyp " ++ Ppconstr.pr_id hid); *)
thin [hid] g
)
)
in
- if args_id = []
- then
+ if args_id = []
+ then
tclTHENLIST [
tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps;
do_prove hyps
@@ -649,32 +649,32 @@ let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id
[
tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps;
tclMAP instanciate_one_hyp hyps;
- (fun g ->
- let all_g_hyps_id =
+ (fun g ->
+ let all_g_hyps_id =
List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty
- in
- let remaining_hyps =
+ in
+ let remaining_hyps =
List.filter (fun id -> Idset.mem id all_g_hyps_id) hyps
in
do_prove remaining_hyps g
)
]
-let build_proof
+let build_proof
(interactive_proof:bool)
(fnames:constant list)
ptes_infos
dyn_infos
: tactic =
- let rec build_proof_aux do_finalize dyn_infos : tactic =
- fun g ->
+ let rec build_proof_aux do_finalize dyn_infos : tactic =
+ fun g ->
(* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*)
- match kind_of_term dyn_infos.info with
- | Case(ci,ct,t,cb) ->
- let do_finalize_t dyn_info' =
+ match kind_of_term dyn_infos.info with
+ | Case(ci,ct,t,cb) ->
+ let do_finalize_t dyn_info' =
fun g ->
- let t = dyn_info'.info in
- let dyn_infos = {dyn_info' with info =
+ let t = dyn_info'.info in
+ let dyn_infos = {dyn_info' with info =
mkCase(ci,ct,t,cb)} in
let g_nb_prod = nb_prod (pf_concl g) in
let type_of_term = pf_type_of g t in
@@ -686,21 +686,21 @@ let build_proof
h_generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps));
thin dyn_infos.rec_hyps;
pattern_option [(false,[1]),t] None;
- (fun g -> observe_tac "toto" (
+ (fun g -> observe_tac "toto" (
tclTHENSEQ [h_simplest_case t;
- (fun g' ->
- let g'_nb_prod = nb_prod (pf_concl g') in
- let nb_instanciate_partial = g'_nb_prod - g_nb_prod in
+ (fun g' ->
+ let g'_nb_prod = nb_prod (pf_concl g') in
+ let nb_instanciate_partial = g'_nb_prod - g_nb_prod in
observe_tac "treat_new_case"
- (treat_new_case
+ (treat_new_case
ptes_infos
- nb_instanciate_partial
- (build_proof do_finalize)
- t
+ nb_instanciate_partial
+ (build_proof do_finalize)
+ t
dyn_infos)
g'
)
-
+
]) g
)
]
@@ -715,25 +715,25 @@ let build_proof
intro
(fun g' ->
let (id,_,_) = pf_last_hyp g' in
- let new_term =
- pf_nf_betaiota g'
- (mkApp(dyn_infos.info,[|mkVar id|]))
+ let new_term =
+ pf_nf_betaiota g'
+ (mkApp(dyn_infos.info,[|mkVar id|]))
in
let new_infos = {dyn_infos with info = new_term} in
- let do_prove new_hyps =
- build_proof do_finalize
+ let do_prove new_hyps =
+ build_proof do_finalize
{new_infos with
- rec_hyps = new_hyps;
+ rec_hyps = new_hyps;
nb_rec_hyps = List.length new_hyps
}
- in
+ in
(* observe_tac "Lambda" *) (instanciate_hyps_with_args do_prove new_infos.rec_hyps [id]) g'
(* build_proof do_finalize new_infos g' *)
) g
| _ ->
- do_finalize dyn_infos g
+ do_finalize dyn_infos g
end
- | Cast(t,_,_) ->
+ | Cast(t,_,_) ->
build_proof do_finalize {dyn_infos with info = t} g
| Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ ->
do_finalize dyn_infos g
@@ -743,15 +743,15 @@ let build_proof
match kind_of_term f with
| App _ -> assert false (* we have collected all the app in decompose_app *)
| Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ ->
- let new_infos =
- { dyn_infos with
+ let new_infos =
+ { dyn_infos with
info = (f,args)
}
in
build_proof_args do_finalize new_infos g
| Const c when not (List.mem c fnames) ->
- let new_infos =
- { dyn_infos with
+ let new_infos =
+ { dyn_infos with
info = (f,args)
}
in
@@ -759,93 +759,93 @@ let build_proof
build_proof_args do_finalize new_infos g
| Const _ ->
do_finalize dyn_infos g
- | Lambda _ ->
+ | Lambda _ ->
let new_term =
- Reductionops.nf_beta Evd.empty dyn_infos.info in
- build_proof do_finalize {dyn_infos with info = new_term}
+ Reductionops.nf_beta Evd.empty dyn_infos.info in
+ build_proof do_finalize {dyn_infos with info = new_term}
g
- | LetIn _ ->
- let new_infos =
- { dyn_infos with info = nf_betaiotazeta dyn_infos.info }
- in
-
- tclTHENLIST
- [tclMAP
- (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id))
+ | LetIn _ ->
+ let new_infos =
+ { dyn_infos with info = nf_betaiotazeta dyn_infos.info }
+ in
+
+ tclTHENLIST
+ [tclMAP
+ (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id))
dyn_infos.rec_hyps;
h_reduce_with_zeta Tacticals.onConcl;
build_proof do_finalize new_infos
- ]
+ ]
g
- | Cast(b,_,_) ->
+ | Cast(b,_,_) ->
build_proof do_finalize {dyn_infos with info = b } g
| Case _ | Fix _ | CoFix _ ->
- let new_finalize dyn_infos =
- let new_infos =
- { dyn_infos with
+ let new_finalize dyn_infos =
+ let new_infos =
+ { dyn_infos with
info = dyn_infos.info,args
}
- in
- build_proof_args do_finalize new_infos
- in
+ in
+ build_proof_args do_finalize new_infos
+ in
build_proof new_finalize {dyn_infos with info = f } g
end
| Fix _ | CoFix _ ->
error ( "Anonymous local (co)fixpoints are not handled yet")
- | Prod _ -> error "Prod"
- | LetIn _ ->
- let new_infos =
- { dyn_infos with
- info = nf_betaiotazeta dyn_infos.info
+ | Prod _ -> error "Prod"
+ | LetIn _ ->
+ let new_infos =
+ { dyn_infos with
+ info = nf_betaiotazeta dyn_infos.info
}
- in
+ in
- tclTHENLIST
- [tclMAP
- (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id))
+ tclTHENLIST
+ [tclMAP
+ (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id))
dyn_infos.rec_hyps;
h_reduce_with_zeta Tacticals.onConcl;
build_proof do_finalize new_infos
] g
- | Rel _ -> anomaly "Free var in goal conclusion !"
+ | Rel _ -> anomaly "Free var in goal conclusion !"
and build_proof do_finalize dyn_infos g =
(* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *)
observe_tac "build_proof" (build_proof_aux do_finalize dyn_infos) g
and build_proof_args do_finalize dyn_infos (* f_args' args *) :tactic =
fun g ->
- let (f_args',args) = dyn_infos.info in
+ let (f_args',args) = dyn_infos.info in
let tac : tactic =
- fun g ->
+ fun g ->
match args with
| [] ->
- do_finalize {dyn_infos with info = f_args'} g
+ do_finalize {dyn_infos with info = f_args'} g
| arg::args ->
(* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *)
(* fnl () ++ *)
(* pr_goal (Tacmach.sig_it g) *)
(* ); *)
let do_finalize dyn_infos =
- let new_arg = dyn_infos.info in
+ let new_arg = dyn_infos.info in
(* tclTRYD *)
(build_proof_args
do_finalize
{dyn_infos with info = (mkApp(f_args',[|new_arg|])), args}
)
in
- build_proof do_finalize
+ build_proof do_finalize
{dyn_infos with info = arg }
g
in
(* observe_tac "build_proof_args" *) (tac ) g
in
- let do_finish_proof dyn_infos =
- (* tclTRYD *) (clean_goal_with_heq
+ let do_finish_proof dyn_infos =
+ (* tclTRYD *) (clean_goal_with_heq
ptes_infos
finish_proof dyn_infos)
in
(* observe_tac "build_proof" *)
- (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos)
+ (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos)
@@ -858,16 +858,16 @@ let build_proof
-(* Proof of principles from structural functions *)
+(* Proof of principles from structural functions *)
let is_pte_type t =
isSort ((strip_prod t))
-
+
let is_pte (_,_,t) = is_pte_type t
-type static_fix_info =
+type static_fix_info =
{
idx : int;
name : identifier;
@@ -875,18 +875,18 @@ type static_fix_info =
offset : int;
nb_realargs : int;
body_with_param : constr;
- num_in_block : int
+ num_in_block : int
}
-let prove_rec_hyp_for_struct fix_info =
- (fun eq_hyps -> tclTHEN
+let prove_rec_hyp_for_struct fix_info =
+ (fun eq_hyps -> tclTHEN
(rewrite_until_var (fix_info.idx) eq_hyps)
- (fun g ->
- let _,pte_args = destApp (pf_concl g) in
- let rec_hyp_proof =
- mkApp(mkVar fix_info.name,array_get_start pte_args)
+ (fun g ->
+ let _,pte_args = destApp (pf_concl g) in
+ let rec_hyp_proof =
+ mkApp(mkVar fix_info.name,array_get_start pte_args)
in
refine rec_hyp_proof g
))
@@ -894,38 +894,38 @@ let prove_rec_hyp_for_struct fix_info =
let prove_rec_hyp fix_info =
{ proving_tac = prove_rec_hyp_for_struct fix_info
;
- is_valid = fun _ -> true
+ is_valid = fun _ -> true
}
exception Not_Rec
-
-let generalize_non_dep hyp g =
+
+let generalize_non_dep hyp g =
(* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *)
- let hyps = [hyp] in
- let env = Global.env () in
- let hyp_typ = pf_type_of g (mkVar hyp) in
- let to_revert,_ =
+ let hyps = [hyp] in
+ let env = Global.env () in
+ let hyp_typ = pf_type_of g (mkVar hyp) in
+ let to_revert,_ =
Environ.fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) ->
if List.mem hyp hyps
or List.exists (occur_var_in_decl env hyp) keep
or occur_var env hyp hyp_typ
- or Termops.is_section_variable hyp (* should be dangerous *)
+ or Termops.is_section_variable hyp (* should be dangerous *)
then (clear,decl::keep)
else (hyp::clear,keep))
~init:([],[]) (pf_env g)
in
(* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *)
- tclTHEN
+ tclTHEN
((* observe_tac "h_generalize" *) (h_generalize (List.map mkVar to_revert) ))
((* observe_tac "thin" *) (thin to_revert))
g
-
+
let id_of_decl (na,_,_) = (Nameops.out_name na)
let var_of_decl decl = mkVar (id_of_decl decl)
-let revert idl =
- tclTHEN
- (generalize (List.map mkVar idl))
+let revert idl =
+ tclTHEN
+ (generalize (List.map mkVar idl))
(thin idl)
let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
@@ -950,7 +950,7 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
(* observe (str "f_body_with_params_and_other_fun " ++ pr_lconstr f_body_with_params_and_other_fun); *)
let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in
(* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *)
- let type_ctxt,type_of_f = decompose_prod_n_assum (nb_params + nb_args)
+ let type_ctxt,type_of_f = decompose_prod_n_assum (nb_params + nb_args)
(Typeops.type_of_constant_type (Global.env()) f_def.const_type) in
let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in
let lemma_type = it_mkProd_or_LetIn ~init:eqn type_ctxt in
@@ -971,7 +971,7 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
Command.start_proof
(*i The next call to mk_equation_id is valid since we are constructing the lemma
Ensures by: obvious
- i*)
+ i*)
(mk_equation_id f_id)
(Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
lemma_type
@@ -981,72 +981,72 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
-
+
let do_replace params rec_arg_num rev_args_id f fun_num all_funs g =
- let equation_lemma =
- try
- let finfos = find_Function_infos (destConst f) in
+ let equation_lemma =
+ try
+ let finfos = find_Function_infos (destConst f) in
mkConst (Option.get finfos.equation_lemma)
- with (Not_found | Option.IsNone as e) ->
- let f_id = id_of_label (con_label (destConst f)) in
+ with (Not_found | Option.IsNone as e) ->
+ let f_id = id_of_label (con_label (destConst f)) in
(*i The next call to mk_equation_id is valid since we will construct the lemma
Ensures by: obvious
- i*)
- let equation_lemma_id = (mk_equation_id f_id) in
+ i*)
+ let equation_lemma_id = (mk_equation_id f_id) in
generate_equation_lemma all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num;
let _ =
- match e with
- | Option.IsNone ->
- let finfos = find_Function_infos (destConst f) in
- update_Function
+ match e with
+ | Option.IsNone ->
+ let finfos = find_Function_infos (destConst f) in
+ update_Function
{finfos with
equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with
ConstRef c -> c
- | _ -> Util.anomaly "Not a constant"
+ | _ -> Util.anomaly "Not a constant"
)
}
- | _ -> ()
+ | _ -> ()
- in
+ in
Tacinterp.constr_of_id (pf_env g) equation_lemma_id
in
let nb_intro_to_do = nb_prod (pf_concl g) in
tclTHEN
(tclDO nb_intro_to_do intro)
(
- fun g' ->
- let just_introduced = nLastDecls nb_intro_to_do g' in
- let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in
+ fun g' ->
+ let just_introduced = nLastDecls nb_intro_to_do g' in
+ let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in
tclTHEN (Equality.rewriteLR equation_lemma) (revert just_introduced_id) g'
)
g
let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : tactic =
- fun g ->
- let princ_type = pf_concl g in
- let princ_info = compute_elim_sig princ_type in
- let fresh_id =
- let avoid = ref (pf_ids_of_hyps g) in
- (fun na ->
- let new_id =
- match na with
- Name id -> fresh_id !avoid (string_of_id id)
+ fun g ->
+ let princ_type = pf_concl g in
+ let princ_info = compute_elim_sig princ_type in
+ let fresh_id =
+ let avoid = ref (pf_ids_of_hyps g) in
+ (fun na ->
+ let new_id =
+ match na with
+ Name id -> fresh_id !avoid (string_of_id id)
| Anonymous -> fresh_id !avoid "H"
in
- avoid := new_id :: !avoid;
+ avoid := new_id :: !avoid;
(Name new_id)
)
in
- let fresh_decl =
- (fun (na,b,t) ->
+ let fresh_decl =
+ (fun (na,b,t) ->
(fresh_id na,b,t)
)
in
- let princ_info : elim_scheme =
- { princ_info with
+ let princ_info : elim_scheme =
+ { princ_info with
params = List.map fresh_decl princ_info.params;
- predicates = List.map fresh_decl princ_info.predicates;
- branches = List.map fresh_decl princ_info.branches;
+ predicates = List.map fresh_decl princ_info.predicates;
+ branches = List.map fresh_decl princ_info.branches;
args = List.map fresh_decl princ_info.args
}
in
@@ -1062,15 +1062,15 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
| None -> error ( "Cannot define a principle over an axiom ")
in
let fbody = get_body fnames.(fun_num) in
- let f_ctxt,f_body = decompose_lam fbody in
- let f_ctxt_length = List.length f_ctxt in
- let diff_params = princ_info.nparams - f_ctxt_length in
- let full_params,princ_params,fbody_with_full_params =
+ let f_ctxt,f_body = decompose_lam fbody in
+ let f_ctxt_length = List.length f_ctxt in
+ let diff_params = princ_info.nparams - f_ctxt_length in
+ let full_params,princ_params,fbody_with_full_params =
if diff_params > 0
- then
- let princ_params,full_params =
- list_chop diff_params princ_info.params
- in
+ then
+ let princ_params,full_params =
+ list_chop diff_params princ_info.params
+ in
(full_params, (* real params *)
princ_params, (* the params of the principle which are not params of the function *)
substl (* function instanciated with real params *)
@@ -1078,9 +1078,9 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
f_body
)
else
- let f_ctxt_other,f_ctxt_params =
- list_chop (- diff_params) f_ctxt in
- let f_body = compose_lam f_ctxt_other f_body in
+ let f_ctxt_other,f_ctxt_params =
+ list_chop (- diff_params) f_ctxt in
+ let f_body = compose_lam f_ctxt_other f_body in
(princ_info.params, (* real params *)
[],(* all params are full params *)
substl (* function instanciated with real params *)
@@ -1099,32 +1099,32 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
(* observe (str "fbody_with_full_params := " ++ *)
(* pr_lconstr fbody_with_full_params *)
(* ); *)
- let all_funs_with_full_params =
+ let all_funs_with_full_params =
Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs
in
- let fix_offset = List.length princ_params in
- let ptes_to_fix,infos =
- match kind_of_term fbody_with_full_params with
- | Fix((idxs,i),(names,typess,bodies)) ->
- let bodies_with_all_params =
- Array.map
- (fun body ->
+ let fix_offset = List.length princ_params in
+ let ptes_to_fix,infos =
+ match kind_of_term fbody_with_full_params with
+ | Fix((idxs,i),(names,typess,bodies)) ->
+ let bodies_with_all_params =
+ Array.map
+ (fun body ->
Reductionops.nf_betaiota Evd.empty
(applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body,
List.rev_map var_of_decl princ_params))
)
bodies
in
- let info_array =
- Array.mapi
- (fun i types ->
+ let info_array =
+ Array.mapi
+ (fun i types ->
let types = prod_applist types (List.rev_map var_of_decl princ_params) in
{ idx = idxs.(i) - fix_offset;
name = Nameops.out_name (fresh_id names.(i));
- types = types;
+ types = types;
offset = fix_offset;
- nb_realargs =
- List.length
+ nb_realargs =
+ List.length
(fst (decompose_lam bodies.(i))) - fix_offset;
body_with_param = bodies_with_all_params.(i);
num_in_block = i
@@ -1132,65 +1132,65 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
)
typess
in
- let pte_to_fix,rev_info =
- list_fold_left_i
- (fun i (acc_map,acc_info) (pte,_,_) ->
- let infos = info_array.(i) in
- let type_args,_ = decompose_prod infos.types in
- let nargs = List.length type_args in
+ let pte_to_fix,rev_info =
+ list_fold_left_i
+ (fun i (acc_map,acc_info) (pte,_,_) ->
+ let infos = info_array.(i) in
+ let type_args,_ = decompose_prod infos.types in
+ let nargs = List.length type_args in
let f = applist(mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in
let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in
let app_f = mkApp(f,first_args) in
- let pte_args = (Array.to_list first_args)@[app_f] in
- let app_pte = applist(mkVar (Nameops.out_name pte),pte_args) in
- let body_with_param,num =
- let body = get_body fnames.(i) in
- let body_with_full_params =
+ let pte_args = (Array.to_list first_args)@[app_f] in
+ let app_pte = applist(mkVar (Nameops.out_name pte),pte_args) in
+ let body_with_param,num =
+ let body = get_body fnames.(i) in
+ let body_with_full_params =
Reductionops.nf_betaiota Evd.empty (
applist(body,List.rev_map var_of_decl full_params))
in
- match kind_of_term body_with_full_params with
- | Fix((_,num),(_,_,bs)) ->
+ match kind_of_term body_with_full_params with
+ | Fix((_,num),(_,_,bs)) ->
Reductionops.nf_betaiota Evd.empty
(
(applist
- (substl
- (List.rev
- (Array.to_list all_funs_with_full_params))
+ (substl
+ (List.rev
+ (Array.to_list all_funs_with_full_params))
bs.(num),
List.rev_map var_of_decl princ_params))
),num
| _ -> error "Not a mutual block"
in
- let info =
- {infos with
+ let info =
+ {infos with
types = compose_prod type_args app_pte;
body_with_param = body_with_param;
num_in_block = num
}
- in
+ in
(* observe (str "binding " ++ Ppconstr.pr_id (Nameops.out_name pte) ++ *)
(* str " to " ++ Ppconstr.pr_id info.name); *)
(Idmap.add (Nameops.out_name pte) info acc_map,info::acc_info)
)
- 0
- (Idmap.empty,[])
+ 0
+ (Idmap.empty,[])
(List.rev princ_info.predicates)
in
pte_to_fix,List.rev rev_info
| _ -> Idmap.empty,[]
in
- let mk_fixes : tactic =
- let pre_info,infos = list_chop fun_num infos in
- match pre_info,infos with
+ let mk_fixes : tactic =
+ let pre_info,infos = list_chop fun_num infos in
+ match pre_info,infos with
| [],[] -> tclIDTAC
- | _, this_fix_info::others_infos ->
+ | _, this_fix_info::others_infos ->
let other_fix_infos =
List.map
- (fun fi -> fi.name,fi.idx + 1 ,fi.types)
+ (fun fi -> fi.name,fi.idx + 1 ,fi.types)
(pre_info@others_infos)
- in
- if other_fix_infos = []
+ in
+ if other_fix_infos = []
then
(* observe_tac ("h_fix") *) (h_fix (Some this_fix_info.name) (this_fix_info.idx +1))
else
@@ -1199,34 +1199,34 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
| _ -> anomaly "Not a valid information"
in
let first_tac : tactic = (* every operations until fix creations *)
- tclTHENSEQ
- [ (* observe_tac "introducing params" *) (intros_using (List.rev_map id_of_decl princ_info.params));
- (* observe_tac "introducing predictes" *) (intros_using (List.rev_map id_of_decl princ_info.predicates));
- (* observe_tac "introducing branches" *) (intros_using (List.rev_map id_of_decl princ_info.branches));
+ tclTHENSEQ
+ [ (* observe_tac "introducing params" *) (intros_using (List.rev_map id_of_decl princ_info.params));
+ (* observe_tac "introducing predictes" *) (intros_using (List.rev_map id_of_decl princ_info.predicates));
+ (* observe_tac "introducing branches" *) (intros_using (List.rev_map id_of_decl princ_info.branches));
(* observe_tac "building fixes" *) mk_fixes;
]
in
- let intros_after_fixes : tactic =
- fun gl ->
+ let intros_after_fixes : tactic =
+ fun gl ->
let ctxt,pte_app = (decompose_prod_assum (pf_concl gl)) in
let pte,pte_args = (decompose_app pte_app) in
try
- let pte = try destVar pte with _ -> anomaly "Property is not a variable" in
+ let pte = try destVar pte with _ -> anomaly "Property is not a variable" in
let fix_info = Idmap.find pte ptes_to_fix in
- let nb_args = fix_info.nb_realargs in
+ let nb_args = fix_info.nb_realargs in
tclTHENSEQ
[
(* observe_tac ("introducing args") *) (tclDO nb_args intro);
(fun g -> (* replacement of the function by its body *)
- let args = nLastDecls nb_args g in
+ let args = nLastDecls nb_args g in
let fix_body = fix_info.body_with_param in
(* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *)
let args_id = List.map (fun (id,_,_) -> id) args in
- let dyn_infos =
+ let dyn_infos =
{
nb_rec_hyps = -100;
rec_hyps = [];
- info =
+ info =
Reductionops.nf_betaiota Evd.empty
(applist(fix_body,List.rev_map mkVar args_id));
eq_hyps = []
@@ -1235,42 +1235,42 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
tclTHENSEQ
[
(* observe_tac "do_replace" *)
- (do_replace
- full_params
- (fix_info.idx + List.length princ_params)
+ (do_replace
+ full_params
+ (fix_info.idx + List.length princ_params)
(args_id@(List.map (fun (id,_,_) -> Nameops.out_name id ) princ_params))
- (all_funs.(fix_info.num_in_block))
- fix_info.num_in_block
+ (all_funs.(fix_info.num_in_block))
+ fix_info.num_in_block
all_funs
);
(* observe_tac "do_replace" *)
(* (do_replace princ_info.params fix_info.idx args_id *)
(* (List.hd (List.rev pte_args)) fix_body); *)
- let do_prove =
- build_proof
+ let do_prove =
+ build_proof
interactive_proof
- (Array.to_list fnames)
+ (Array.to_list fnames)
(Idmap.map prove_rec_hyp ptes_to_fix)
in
- let prove_tac branches =
- let dyn_infos =
- {dyn_infos with
+ let prove_tac branches =
+ let dyn_infos =
+ {dyn_infos with
rec_hyps = branches;
nb_rec_hyps = List.length branches
}
in
observe_tac "cleaning" (clean_goal_with_heq
- (Idmap.map prove_rec_hyp ptes_to_fix)
- do_prove
+ (Idmap.map prove_rec_hyp ptes_to_fix)
+ do_prove
dyn_infos)
in
(* observe (str "branches := " ++ *)
(* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *)
(* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *)
-
+
(* ); *)
- (* observe_tac "instancing" *) (instanciate_hyps_with_args prove_tac
- (List.rev_map id_of_decl princ_info.branches)
+ (* observe_tac "instancing" *) (instanciate_hyps_with_args prove_tac
+ (List.rev_map id_of_decl princ_info.branches)
(List.rev args_id))
]
g
@@ -1282,14 +1282,14 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
[
tclDO nb_args intro;
(fun g -> (* replacement of the function by its body *)
- let args = nLastDecls nb_args g in
+ let args = nLastDecls nb_args g in
let args_id = List.map (fun (id,_,_) -> id) args in
- let dyn_infos =
+ let dyn_infos =
{
nb_rec_hyps = -100;
rec_hyps = [];
- info =
- Reductionops.nf_betaiota Evd.empty
+ info =
+ Reductionops.nf_betaiota Evd.empty
(applist(fbody_with_full_params,
(List.rev_map var_of_decl princ_params)@
(List.rev_map mkVar args_id)
@@ -1300,44 +1300,44 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in
tclTHENSEQ
[unfold_in_concl [(all_occurrences,Names.EvalConstRef fname)];
- let do_prove =
- build_proof
+ let do_prove =
+ build_proof
interactive_proof
- (Array.to_list fnames)
+ (Array.to_list fnames)
(Idmap.map prove_rec_hyp ptes_to_fix)
in
- let prove_tac branches =
- let dyn_infos =
- {dyn_infos with
+ let prove_tac branches =
+ let dyn_infos =
+ {dyn_infos with
rec_hyps = branches;
nb_rec_hyps = List.length branches
}
in
clean_goal_with_heq
- (Idmap.map prove_rec_hyp ptes_to_fix)
- do_prove
+ (Idmap.map prove_rec_hyp ptes_to_fix)
+ do_prove
dyn_infos
in
- instanciate_hyps_with_args prove_tac
- (List.rev_map id_of_decl princ_info.branches)
+ instanciate_hyps_with_args prove_tac
+ (List.rev_map id_of_decl princ_info.branches)
(List.rev args_id)
]
g
)
- ]
+ ]
gl
in
- tclTHEN
+ tclTHEN
first_tac
intros_after_fixes
g
-
-(* Proof of principles of general functions *)
+
+(* Proof of principles of general functions *)
let h_id = Recdef.h_id
and hrec_id = Recdef.hrec_id
and acc_inv_id = Recdef.acc_inv_id
@@ -1376,73 +1376,73 @@ let prove_with_tcc tcc_lemma_constr eqs : tactic =
gls
-let backtrack_eqs_until_hrec hrec eqs : tactic =
- fun gls ->
- let eqs = List.map mkVar eqs in
- let rewrite =
+let backtrack_eqs_until_hrec hrec eqs : tactic =
+ fun gls ->
+ let eqs = List.map mkVar eqs in
+ let rewrite =
tclFIRST (List.map Equality.rewriteRL eqs )
- in
- let _,hrec_concl = decompose_prod (pf_type_of gls (mkVar hrec)) in
- let f_app = array_last (snd (destApp hrec_concl)) in
- let f = (fst (destApp f_app)) in
- let rec backtrack : tactic =
- fun g ->
- let f_app = array_last (snd (destApp (pf_concl g))) in
- match kind_of_term f_app with
+ in
+ let _,hrec_concl = decompose_prod (pf_type_of gls (mkVar hrec)) in
+ let f_app = array_last (snd (destApp hrec_concl)) in
+ let f = (fst (destApp f_app)) in
+ let rec backtrack : tactic =
+ fun g ->
+ let f_app = array_last (snd (destApp (pf_concl g))) in
+ match kind_of_term f_app with
| App(f',_) when eq_constr f' f -> tclIDTAC g
| _ -> tclTHEN rewrite backtrack g
in
backtrack gls
-
-
-let build_clause eqs =
+
+
+let build_clause eqs =
{
- Tacexpr.onhyps =
- Some (List.map
+ Tacexpr.onhyps =
+ Some (List.map
(fun id -> (Rawterm.all_occurrences_expr,id),InHyp)
eqs
);
- Tacexpr.concl_occs = Rawterm.no_occurrences_expr
+ Tacexpr.concl_occs = Rawterm.no_occurrences_expr
}
-let rec rewrite_eqs_in_eqs eqs =
- match eqs with
+let rec rewrite_eqs_in_eqs eqs =
+ match eqs with
| [] -> tclIDTAC
- | eq::eqs ->
-
- tclTHEN
- (tclMAP
- (fun id gl ->
- observe_tac
- (Format.sprintf "rewrite %s in %s " (string_of_id eq) (string_of_id id))
+ | eq::eqs ->
+
+ tclTHEN
+ (tclMAP
+ (fun id gl ->
+ observe_tac
+ (Format.sprintf "rewrite %s in %s " (string_of_id eq) (string_of_id id))
(tclTRY (Equality.general_rewrite_in true all_occurrences id (mkVar eq) false))
gl
- )
+ )
eqs
)
- (rewrite_eqs_in_eqs eqs)
+ (rewrite_eqs_in_eqs eqs)
-let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
+let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
fun gls ->
- (tclTHENSEQ
+ (tclTHENSEQ
[
backtrack_eqs_until_hrec hrec eqs;
(* observe_tac ("new_prove_with_tcc ( applying "^(string_of_id hrec)^" )" ) *)
(tclTHENS (* We must have exactly ONE subgoal !*)
(apply (mkVar hrec))
- [ tclTHENSEQ
+ [ tclTHENSEQ
[
keep (tcc_hyps@eqs);
apply (Lazy.force acc_inv);
- (fun g ->
- if is_mes
- then
- unfold_in_concl [(all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g
+ (fun g ->
+ if is_mes
+ then
+ unfold_in_concl [(all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g
else tclIDTAC g
);
observe_tac "rew_and_finish"
- (tclTHENLIST
+ (tclTHENLIST
[tclTRY(Recdef.list_rewrite false (List.map mkVar eqs));
observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs);
(observe_tac "finishing using"
@@ -1462,7 +1462,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
])
])
gls
-
+
let is_valid_hypothesis predicates_name =
let predicates_name = List.fold_right Idset.add predicates_name Idset.empty in
@@ -1477,78 +1477,78 @@ let is_valid_hypothesis predicates_name =
in
let rec is_valid_hypothesis typ =
is_pte typ ||
- match kind_of_term typ with
+ match kind_of_term typ with
| Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ'
- | _ -> false
+ | _ -> false
in
- is_valid_hypothesis
+ is_valid_hypothesis
let prove_principle_for_gen
(f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes
- rec_arg_num rec_arg_type relation gl =
- let princ_type = pf_concl gl in
- let princ_info = compute_elim_sig princ_type in
- let fresh_id =
- let avoid = ref (pf_ids_of_hyps gl) in
- fun na ->
- let new_id =
- match na with
- | Name id -> fresh_id !avoid (string_of_id id)
- | Anonymous -> fresh_id !avoid "H"
+ rec_arg_num rec_arg_type relation gl =
+ let princ_type = pf_concl gl in
+ let princ_info = compute_elim_sig princ_type in
+ let fresh_id =
+ let avoid = ref (pf_ids_of_hyps gl) in
+ fun na ->
+ let new_id =
+ match na with
+ | Name id -> fresh_id !avoid (string_of_id id)
+ | Anonymous -> fresh_id !avoid "H"
in
avoid := new_id :: !avoid;
Name new_id
in
let fresh_decl (na,b,t) = (fresh_id na,b,t) in
- let princ_info : elim_scheme =
- { princ_info with
+ let princ_info : elim_scheme =
+ { princ_info with
params = List.map fresh_decl princ_info.params;
- predicates = List.map fresh_decl princ_info.predicates;
- branches = List.map fresh_decl princ_info.branches;
+ predicates = List.map fresh_decl princ_info.predicates;
+ branches = List.map fresh_decl princ_info.branches;
args = List.map fresh_decl princ_info.args
}
in
- let wf_tac =
- if is_mes
- then
+ let wf_tac =
+ if is_mes
+ then
(fun b -> Recdef.tclUSER_if_not_mes tclIDTAC b None)
else fun _ -> prove_with_tcc tcc_lemma_ref []
in
- let real_rec_arg_num = rec_arg_num - princ_info.nparams in
- let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in
+ let real_rec_arg_num = rec_arg_num - princ_info.nparams in
+ let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in
(* observe ( *)
(* str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ *)
(* str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ *)
-
+
(* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *)
(* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *)
(* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *)
(* str "npost_rec_arg := " ++ int npost_rec_arg ); *)
- let (post_rec_arg,pre_rec_arg) =
+ let (post_rec_arg,pre_rec_arg) =
Util.list_chop npost_rec_arg princ_info.args
in
- let rec_arg_id =
- match List.rev post_rec_arg with
- | (Name id,_,_)::_ -> id
- | _ -> assert false
+ let rec_arg_id =
+ match List.rev post_rec_arg with
+ | (Name id,_,_)::_ -> id
+ | _ -> assert false
in
(* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *)
- let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in
- let relation = substl subst_constrs relation in
- let input_type = substl subst_constrs rec_arg_type in
- let wf_thm_id = Nameops.out_name (fresh_id (Name (id_of_string "wf_R"))) in
- let acc_rec_arg_id =
+ let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in
+ let relation = substl subst_constrs relation in
+ let input_type = substl subst_constrs rec_arg_type in
+ let wf_thm_id = Nameops.out_name (fresh_id (Name (id_of_string "wf_R"))) in
+ let acc_rec_arg_id =
Nameops.out_name (fresh_id (Name (id_of_string ("Acc_"^(string_of_id rec_arg_id)))))
- in
- let revert l =
- tclTHEN (h_generalize (List.map mkVar l)) (clear l)
in
- let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in
- let prove_rec_arg_acc g =
+ let revert l =
+ tclTHEN (h_generalize (List.map mkVar l)) (clear l)
+ in
+ let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in
+ let prove_rec_arg_acc g =
((* observe_tac "prove_rec_arg_acc" *)
(tclCOMPLETE
(tclTHEN
- (assert_by (Name wf_thm_id)
+ (assert_by (Name wf_thm_id)
(mkApp (delayed_force well_founded,[|input_type;relation|]))
(fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g))
(
@@ -1562,8 +1562,8 @@ let prove_principle_for_gen
g
in
let args_ids = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.args in
- let lemma =
- match !tcc_lemma_ref with
+ let lemma =
+ match !tcc_lemma_ref with
| None -> anomaly ( "No tcc proof !!")
| Some lemma -> lemma
in
@@ -1578,11 +1578,11 @@ let prove_principle_for_gen
(* f::(list_diff r check_list) *)
(* in *)
let tcc_list = ref [] in
- let start_tac gls =
- let hyps = pf_ids_of_hyps gls in
- let hid =
- next_global_ident_away true
- (id_of_string "prov")
+ let start_tac gls =
+ let hyps = pf_ids_of_hyps gls in
+ let hid =
+ next_global_ident_away true
+ (id_of_string "prov")
hyps
in
tclTHENSEQ
@@ -1590,12 +1590,12 @@ let prove_principle_for_gen
generalize [lemma];
h_intro hid;
Elim.h_decompose_and (mkVar hid);
- (fun g ->
- let new_hyps = pf_ids_of_hyps g in
+ (fun g ->
+ let new_hyps = pf_ids_of_hyps g in
tcc_list := List.rev (list_subtract new_hyps (hid::hyps));
if !tcc_list = []
- then
- begin
+ then
+ begin
tcc_list := [hid];
tclIDTAC g
end
@@ -1605,10 +1605,10 @@ let prove_principle_for_gen
gls
in
tclTHENSEQ
- [
+ [
observe_tac "start_tac" start_tac;
- h_intros
- (List.rev_map (fun (na,_,_) -> Nameops.out_name na)
+ h_intros
+ (List.rev_map (fun (na,_,_) -> Nameops.out_name na)
(princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params)
);
(* observe_tac "" *) (assert_by
@@ -1619,24 +1619,24 @@ let prove_principle_for_gen
(* observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids)));
(* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl () ++ *)
(* str "fix arg num" ++ int (List.length args_ids + 1) ); tclIDTAC g); *)
- (* observe_tac "h_fix " *) (h_fix (Some fix_id) (List.length args_ids + 1));
+ (* observe_tac "h_fix " *) (h_fix (Some fix_id) (List.length args_ids + 1));
(* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_type_of g (mkVar fix_id) )); tclIDTAC g); *)
h_intros (List.rev (acc_rec_arg_id::args_ids));
Equality.rewriteLR (mkConst eq_ref);
- (* observe_tac "finish" *) (fun gl' ->
- let body =
- let _,args = destApp (pf_concl gl') in
+ (* observe_tac "finish" *) (fun gl' ->
+ let body =
+ let _,args = destApp (pf_concl gl') in
array_last args
in
- let body_info rec_hyps =
+ let body_info rec_hyps =
{
nb_rec_hyps = List.length rec_hyps;
rec_hyps = rec_hyps;
eq_hyps = [];
info = body
}
- in
- let acc_inv =
+ in
+ let acc_inv =
lazy (
mkApp (
delayed_force acc_inv_id,
@@ -1645,12 +1645,12 @@ let prove_principle_for_gen
)
in
let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) in
- let predicates_names =
+ let predicates_names =
List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.predicates
in
- let pte_info =
+ let pte_info =
{ proving_tac =
- (fun eqs ->
+ (fun eqs ->
(* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *)
(* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.out_name na)) princ_info.args)); *)
(* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.out_name na)) princ_info.params)); *)
@@ -1658,47 +1658,47 @@ let prove_principle_for_gen
(* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *)
(* observe_tac "new_prove_with_tcc" *)
- (new_prove_with_tcc
- is_mes acc_inv fix_id
-
- (!tcc_list@(List.map
- (fun (na,_,_) -> (Nameops.out_name na))
+ (new_prove_with_tcc
+ is_mes acc_inv fix_id
+
+ (!tcc_list@(List.map
+ (fun (na,_,_) -> (Nameops.out_name na))
(princ_info.args@princ_info.params)
)@ ([acc_rec_arg_id])) eqs
)
-
+
);
is_valid = is_valid_hypothesis predicates_names
}
in
- let ptes_info : pte_info Idmap.t =
+ let ptes_info : pte_info Idmap.t =
List.fold_left
- (fun map pte_id ->
- Idmap.add pte_id
- pte_info
+ (fun map pte_id ->
+ Idmap.add pte_id
+ pte_info
map
)
Idmap.empty
predicates_names
in
- let make_proof rec_hyps =
- build_proof
- false
+ let make_proof rec_hyps =
+ build_proof
+ false
[f_ref]
ptes_info
(body_info rec_hyps)
in
(* observe_tac "instanciate_hyps_with_args" *)
- (instanciate_hyps_with_args
+ (instanciate_hyps_with_args
make_proof
(List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.branches)
(List.rev args_ids)
)
gl'
)
-
+
]
- gl
+ gl
diff --git a/plugins/funind/functional_principles_proofs.mli b/plugins/funind/functional_principles_proofs.mli
index 62eb528e0d..ff98f2b97f 100644
--- a/plugins/funind/functional_principles_proofs.mli
+++ b/plugins/funind/functional_principles_proofs.mli
@@ -6,11 +6,11 @@ val prove_princ_for_struct :
int -> constant array -> constr array -> int -> Tacmach.tactic
-val prove_principle_for_gen :
+val prove_principle_for_gen :
constant*constant*constant -> (* name of the function, the fonctionnal and the fixpoint equation *)
constr option ref -> (* a pointer to the obligation proofs lemma *)
bool -> (* is that function uses measure *)
- int -> (* the number of recursive argument *)
+ int -> (* the number of recursive argument *)
types -> (* the type of the recursive argument *)
constr -> (* the wf relation used to prove the function *)
Tacmach.tactic
diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml
index 49d1a179b4..f6959d77e1 100644
--- a/plugins/funind/functional_principles_types.ml
+++ b/plugins/funind/functional_principles_types.ml
@@ -1,8 +1,8 @@
open Printer
open Util
open Term
-open Termops
-open Names
+open Termops
+open Names
open Declarations
open Pp
open Entries
@@ -19,102 +19,102 @@ exception Toberemoved_with_rel of int*constr
exception Toberemoved
-let pr_elim_scheme el =
- let env = Global.env () in
- let msg = str "params := " ++ Printer.pr_rel_context env el.params in
- let env = Environ.push_rel_context el.params env in
- let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in
- let env = Environ.push_rel_context el.predicates env in
- let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in
- let env = Environ.push_rel_context el.branches env in
- let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in
- let env = Environ.push_rel_context el.args env in
+let pr_elim_scheme el =
+ let env = Global.env () in
+ let msg = str "params := " ++ Printer.pr_rel_context env el.params in
+ let env = Environ.push_rel_context el.params env in
+ let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in
+ let env = Environ.push_rel_context el.predicates env in
+ let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in
+ let env = Environ.push_rel_context el.branches env in
+ let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in
+ let env = Environ.push_rel_context el.args env in
msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl
-let observe s =
- if do_observe ()
- then Pp.msgnl s
+let observe s =
+ if do_observe ()
+ then Pp.msgnl s
-let pr_elim_scheme el =
- let env = Global.env () in
- let msg = str "params := " ++ Printer.pr_rel_context env el.params in
- let env = Environ.push_rel_context el.params env in
- let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in
- let env = Environ.push_rel_context el.predicates env in
- let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in
- let env = Environ.push_rel_context el.branches env in
- let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in
- let env = Environ.push_rel_context el.args env in
+let pr_elim_scheme el =
+ let env = Global.env () in
+ let msg = str "params := " ++ Printer.pr_rel_context env el.params in
+ let env = Environ.push_rel_context el.params env in
+ let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in
+ let env = Environ.push_rel_context el.predicates env in
+ let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in
+ let env = Environ.push_rel_context el.branches env in
+ let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in
+ let env = Environ.push_rel_context el.args env in
msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl
-let observe s =
- if do_observe ()
- then Pp.msgnl s
+let observe s =
+ if do_observe ()
+ then Pp.msgnl s
-(*
- Transform an inductive induction principle into
+(*
+ Transform an inductive induction principle into
a functional one
-*)
+*)
let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
- let princ_type_info = compute_elim_sig princ_type in
- let env = Global.env () in
+ let princ_type_info = compute_elim_sig princ_type in
+ let env = Global.env () in
let env_with_params = Environ.push_rel_context princ_type_info.params env in
let tbl = Hashtbl.create 792 in
- let rec change_predicates_names (avoid:identifier list) (predicates:rel_context) : rel_context =
- match predicates with
+ let rec change_predicates_names (avoid:identifier list) (predicates:rel_context) : rel_context =
+ match predicates with
| [] -> []
- |(Name x,v,t)::predicates ->
- let id = Nameops.next_ident_away x avoid in
+ |(Name x,v,t)::predicates ->
+ let id = Nameops.next_ident_away x avoid in
Hashtbl.add tbl id x;
(Name id,v,t)::(change_predicates_names (id::avoid) predicates)
| (Anonymous,_,_)::_ -> anomaly "Anonymous property binder "
in
let avoid = (Termops.ids_of_context env_with_params ) in
- let princ_type_info =
+ let princ_type_info =
{ princ_type_info with
predicates = change_predicates_names avoid princ_type_info.predicates
}
- in
+ in
(* observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *)
(* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *)
- let change_predicate_sort i (x,_,t) =
+ let change_predicate_sort i (x,_,t) =
let new_sort = sorts.(i) in
- let args,_ = decompose_prod t in
- let real_args =
- if princ_type_info.indarg_in_concl
- then List.tl args
+ let args,_ = decompose_prod t in
+ let real_args =
+ if princ_type_info.indarg_in_concl
+ then List.tl args
else args
in
- Nameops.out_name x,None,compose_prod real_args (mkSort new_sort)
+ Nameops.out_name x,None,compose_prod real_args (mkSort new_sort)
in
- let new_predicates =
+ let new_predicates =
list_map_i
- change_predicate_sort
+ change_predicate_sort
0
princ_type_info.predicates
in
let env_with_params_and_predicates = List.fold_right Environ.push_named new_predicates env_with_params in
- let rel_as_kn =
+ let rel_as_kn =
fst (match princ_type_info.indref with
- | Some (Libnames.IndRef ind) -> ind
+ | Some (Libnames.IndRef ind) -> ind
| _ -> error "Not a valid predicate"
)
in
let ptes_vars = List.map (fun (id,_,_) -> id) new_predicates in
- let is_pte =
- let set = List.fold_right Idset.add ptes_vars Idset.empty in
- fun t ->
- match kind_of_term t with
- | Var id -> Idset.mem id set
- | _ -> false
- in
- let pre_princ =
- it_mkProd_or_LetIn
+ let is_pte =
+ let set = List.fold_right Idset.add ptes_vars Idset.empty in
+ fun t ->
+ match kind_of_term t with
+ | Var id -> Idset.mem id set
+ | _ -> false
+ in
+ let pre_princ =
+ it_mkProd_or_LetIn
~init:
- (it_mkProd_or_LetIn
+ (it_mkProd_or_LetIn
~init:(Option.fold_right
mkProd_or_LetIn
princ_type_info.indarg
@@ -139,7 +139,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
in
let dummy_var = mkVar (id_of_string "________") in
let mk_replacement c i args =
- let res = mkApp(rel_to_fun.(i),Array.map pop (array_get_start args)) in
+ let res = mkApp(rel_to_fun.(i),Array.map pop (array_get_start args)) in
(* observe (str "replacing " ++ pr_lconstr c ++ str " by " ++ pr_lconstr res); *)
res
in
@@ -168,10 +168,10 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
let num = get_fun_num f in
raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args))
| App(f,args) ->
- let args =
- if is_pte f && remove
- then array_get_start args
- else args
+ let args =
+ if is_pte f && remove
+ then array_get_start args
+ else args
in
let new_args,binders_to_remove =
Array.fold_right (compute_new_princ_type_with_acc remove env)
@@ -193,7 +193,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
(* pr_lconstr_env env new_princ_type ++ fnl ()) *)
(* | _ -> () in *)
res
-
+
and compute_new_princ_type_for_binder remove bind_fun env x t b =
begin
try
@@ -240,7 +240,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
(list_union_eq eq_constr binders_to_remove_from_t binders_to_remove_from_v)
(List.map pop binders_to_remove_from_b)
)
-
+
with
| Toberemoved ->
(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *)
@@ -257,54 +257,54 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
new_e::c_acc,list_union_eq eq_constr to_remove_from_e to_remove_acc
in
(* observe (str "Computing new principe from " ++ pr_lconstr_env env_with_params_and_predicates pre_princ); *)
- let pre_res,_ =
- compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ
- in
- let pre_res =
- replace_vars
+ let pre_res,_ =
+ compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ
+ in
+ let pre_res =
+ replace_vars
(list_map_i (fun i id -> (id, mkRel i)) 1 ptes_vars)
(lift (List.length ptes_vars) pre_res)
in
- it_mkProd_or_LetIn
- ~init:(it_mkProd_or_LetIn
- ~init:pre_res (List.map (fun (id,t,b) -> Name(Hashtbl.find tbl id), t,b)
+ it_mkProd_or_LetIn
+ ~init:(it_mkProd_or_LetIn
+ ~init:pre_res (List.map (fun (id,t,b) -> Name(Hashtbl.find tbl id), t,b)
new_predicates)
)
princ_type_info.params
-
-
-let change_property_sort toSort princ princName =
- let princ_info = compute_elim_sig princ in
- let change_sort_in_predicate (x,v,t) =
+
+
+let change_property_sort toSort princ princName =
+ let princ_info = compute_elim_sig princ in
+ let change_sort_in_predicate (x,v,t) =
(x,None,
- let args,_ = decompose_prod t in
+ let args,_ = decompose_prod t in
compose_prod args (mkSort toSort)
)
- in
- let princName_as_constr = Tacinterp.constr_of_id (Global.env ()) princName in
- let init =
- let nargs = (princ_info.nparams + (List.length princ_info.predicates)) in
+ in
+ let princName_as_constr = Tacinterp.constr_of_id (Global.env ()) princName in
+ let init =
+ let nargs = (princ_info.nparams + (List.length princ_info.predicates)) in
mkApp(princName_as_constr,
Array.init nargs
(fun i -> mkRel (nargs - i )))
in
it_mkLambda_or_LetIn
- ~init:
- (it_mkLambda_or_LetIn ~init
+ ~init:
+ (it_mkLambda_or_LetIn ~init
(List.map change_sort_in_predicate princ_info.predicates)
)
princ_info.params
-
-let pp_dur time time' =
+
+let pp_dur time time' =
str (string_of_float (System.time_difference time time'))
(* let qed () = save_named true *)
-let defined () =
- try
- Command.save_named false
- with
+let defined () =
+ try
+ Command.save_named false
+ with
| UserError("extract_proof",msg) ->
Util.errorlabstrm
"defined"
@@ -318,7 +318,7 @@ let defined () =
let build_functional_principle interactive_proof old_princ_type sorts funs i proof_tac hook =
(* First we get the type of the old graph principle *)
- let mutr_nparams = (compute_elim_sig old_princ_type).nparams in
+ let mutr_nparams = (compute_elim_sig old_princ_type).nparams in
(* let time1 = System.get_time () in *)
let new_principle_type =
compute_new_princ_type_from_rel
@@ -346,7 +346,7 @@ let build_functional_principle interactive_proof old_princ_type sorts funs i pro
(* let dur1 = System.time_difference tim1 tim2 in *)
(* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *)
(* end; *)
- get_proof_clean true
+ get_proof_clean true
end
@@ -355,8 +355,8 @@ let generate_functional_principle
interactive_proof
old_princ_type sorts new_princ_name funs i proof_tac
=
- try
-
+ try
+
let f = funs.(i) in
let type_sort = Termops.new_sort_in_family InType in
let new_sorts =
@@ -395,8 +395,8 @@ let generate_functional_principle
Decl_kinds.IsDefinition (Decl_kinds.Scheme)
)
);
- Flags.if_verbose
- (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined"))
+ Flags.if_verbose
+ (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined"))
name;
names := name :: !names
in
@@ -404,21 +404,21 @@ let generate_functional_principle
register_with_sort InSet
in
let (id,(entry,g_kind,hook)) =
- build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook
+ build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook
in
(* Pr 1278 :
Don't forget to close the goal if an error is raised !!!!
- *)
+ *)
save false new_princ_name entry g_kind hook
- with e ->
+ with e ->
begin
- begin
- try
- let id = Pfedit.get_current_proof_name () in
- let s = string_of_id id in
+ begin
+ try
+ let id = Pfedit.get_current_proof_name () in
+ let s = string_of_id id in
let n = String.length "___________princ_________" in
- if String.length s >= n
- then if String.sub s 0 n = "___________princ_________"
+ if String.length s >= n
+ then if String.sub s 0 n = "___________princ_________"
then Pfedit.delete_current_proof ()
else ()
else ()
@@ -431,24 +431,24 @@ let generate_functional_principle
exception Not_Rec
-let get_funs_constant mp dp =
- let rec get_funs_constant const e : (Names.constant*int) array =
- match kind_of_term ((strip_lam e)) with
- | Fix((_,(na,_,_))) ->
- Array.mapi
- (fun i na ->
- match na with
- | Name id ->
- let const = make_con mp dp (label_of_id id) in
+let get_funs_constant mp dp =
+ let rec get_funs_constant const e : (Names.constant*int) array =
+ match kind_of_term ((strip_lam e)) with
+ | Fix((_,(na,_,_))) ->
+ Array.mapi
+ (fun i na ->
+ match na with
+ | Name id ->
+ let const = make_con mp dp (label_of_id id) in
const,i
- | Anonymous ->
- anomaly "Anonymous fix"
+ | Anonymous ->
+ anomaly "Anonymous fix"
)
na
| _ -> [|const,0|]
in
- function const ->
- let find_constant_body const =
+ function const ->
+ let find_constant_body const =
match (Global.lookup_constant const ).const_body with
| Some b ->
let body = force b in
@@ -462,97 +462,97 @@ let get_funs_constant mp dp =
| None -> error ( "Cannot define a principle over an axiom ")
in
let f = find_constant_body const in
- let l_const = get_funs_constant const f in
- (*
- We need to check that all the functions found are in the same block
+ let l_const = get_funs_constant const f in
+ (*
+ We need to check that all the functions found are in the same block
to prevent Reset stange thing
- *)
- let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in
- let l_params,l_fixes = List.split (List.map decompose_lam l_bodies) in
- (* all the paremeter must be equal*)
- let _check_params =
- let first_params = List.hd l_params in
- List.iter
- (fun params ->
- if not ((=) first_params params)
+ *)
+ let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in
+ let l_params,l_fixes = List.split (List.map decompose_lam l_bodies) in
+ (* all the paremeter must be equal*)
+ let _check_params =
+ let first_params = List.hd l_params in
+ List.iter
+ (fun params ->
+ if not ((=) first_params params)
then error "Not a mutal recursive block"
)
l_params
in
- (* The bodies has to be very similar *)
- let _check_bodies =
- try
- let extract_info is_first body =
- match kind_of_term body with
+ (* The bodies has to be very similar *)
+ let _check_bodies =
+ try
+ let extract_info is_first body =
+ match kind_of_term body with
| Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca)
- | _ ->
- if is_first && (List.length l_bodies = 1)
+ | _ ->
+ if is_first && (List.length l_bodies = 1)
then raise Not_Rec
else error "Not a mutal recursive block"
in
- let first_infos = extract_info true (List.hd l_bodies) in
+ let first_infos = extract_info true (List.hd l_bodies) in
let check body = (* Hope this is correct *)
- if not (first_infos = (extract_info false body))
+ if not (first_infos = (extract_info false body))
then error "Not a mutal recursive block"
- in
+ in
List.iter check l_bodies
with Not_Rec -> ()
in
l_const
-exception No_graph_found
-exception Found_type of int
+exception No_graph_found
+exception Found_type of int
-let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_entry list =
- let env = Global.env ()
+let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_entry list =
+ let env = Global.env ()
and sigma = Evd.empty in
- let funs = List.map fst fas in
- let first_fun = List.hd funs in
+ let funs = List.map fst fas in
+ let first_fun = List.hd funs in
let funs_mp,funs_dp,_ = Names.repr_con first_fun in
- let first_fun_kn =
- try
- fst (find_Function_infos first_fun).graph_ind
- with Not_found -> raise No_graph_found
+ let first_fun_kn =
+ try
+ fst (find_Function_infos first_fun).graph_ind
+ with Not_found -> raise No_graph_found
in
let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in
- let this_block_funs = Array.map fst this_block_funs_indexes in
+ let this_block_funs = Array.map fst this_block_funs_indexes in
let prop_sort = InProp in
- let funs_indexes =
- let this_block_funs_indexes = Array.to_list this_block_funs_indexes in
+ let funs_indexes =
+ let this_block_funs_indexes = Array.to_list this_block_funs_indexes in
List.map
(function const -> List.assoc const this_block_funs_indexes)
funs
in
- let ind_list =
- List.map
- (fun (idx) ->
- let ind = first_fun_kn,idx in
+ let ind_list =
+ List.map
+ (fun (idx) ->
+ let ind = first_fun_kn,idx in
let (mib,mip) = Global.lookup_inductive ind in
ind,mib,mip,true,prop_sort
)
funs_indexes
in
- let l_schemes =
+ let l_schemes =
List.map
- (Typing.type_of env sigma)
+ (Typing.type_of env sigma)
(Indrec.build_mutual_indrec env sigma ind_list)
- in
+ in
let i = ref (-1) in
- let sorts =
- List.rev_map (fun (_,x) ->
+ let sorts =
+ List.rev_map (fun (_,x) ->
Termops.new_sort_in_family (Pretyping.interp_elimination_sort x)
- )
- fas
+ )
+ fas
in
(* We create the first priciple by tactic *)
- let first_type,other_princ_types =
- match l_schemes with
+ let first_type,other_princ_types =
+ match l_schemes with
s::l_schemes -> s,l_schemes
| _ -> anomaly ""
in
- let (_,(const,_,_)) =
+ let (_,(const,_,_)) =
try
build_functional_principle false
first_type
@@ -561,15 +561,15 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent
0
(prove_princ_for_struct false 0 (Array.of_list funs))
(fun _ _ _ -> ())
- with e ->
+ with e ->
begin
- begin
- try
- let id = Pfedit.get_current_proof_name () in
- let s = string_of_id id in
+ begin
+ try
+ let id = Pfedit.get_current_proof_name () in
+ let s = string_of_id id in
let n = String.length "___________princ_________" in
- if String.length s >= n
- then if String.sub s 0 n = "___________princ_________"
+ if String.length s >= n
+ then if String.sub s 0 n = "___________princ_________"
then Pfedit.delete_current_proof ()
else ()
else ()
@@ -578,71 +578,71 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent
raise (Defining_principle e)
end
- in
+ in
incr i;
- let opacity =
- let finfos = find_Function_infos this_block_funs.(0) in
- try
- let equation = Option.get finfos.equation_lemma in
- (Global.lookup_constant equation).Declarations.const_opaque
- with Option.IsNone -> (* non recursive definition *)
+ let opacity =
+ let finfos = find_Function_infos this_block_funs.(0) in
+ try
+ let equation = Option.get finfos.equation_lemma in
+ (Global.lookup_constant equation).Declarations.const_opaque
+ with Option.IsNone -> (* non recursive definition *)
false
in
- let const = {const with const_entry_opaque = opacity } in
+ let const = {const with const_entry_opaque = opacity } in
(* The others are just deduced *)
- if other_princ_types = []
+ if other_princ_types = []
then
[const]
else
- let other_fun_princ_types =
- let funs = Array.map mkConst this_block_funs in
- let sorts = Array.of_list sorts in
+ let other_fun_princ_types =
+ let funs = Array.map mkConst this_block_funs in
+ let sorts = Array.of_list sorts in
List.map (compute_new_princ_type_from_rel funs sorts) other_princ_types
in
- let first_princ_body,first_princ_type = const.Entries.const_entry_body, const.Entries.const_entry_type in
+ let first_princ_body,first_princ_type = const.Entries.const_entry_body, const.Entries.const_entry_type in
let ctxt,fix = decompose_lam_assum first_princ_body in (* the principle has for forall ...., fix .*)
- let (idxs,_),(_,ta,_ as decl) = destFix fix in
- let other_result =
+ let (idxs,_),(_,ta,_ as decl) = destFix fix in
+ let other_result =
List.map (* we can now compute the other principles *)
- (fun scheme_type ->
+ (fun scheme_type ->
incr i;
observe (Printer.pr_lconstr scheme_type);
- let type_concl = (strip_prod_assum scheme_type) in
- let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in
+ let type_concl = (strip_prod_assum scheme_type) in
+ let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in
let f = fst (decompose_app applied_f) in
try (* we search the number of the function in the fix block (name of the function) *)
- Array.iteri
- (fun j t ->
- let t = (strip_prod_assum t) in
- let applied_g = List.hd (List.rev (snd (decompose_app t))) in
+ Array.iteri
+ (fun j t ->
+ let t = (strip_prod_assum t) in
+ let applied_g = List.hd (List.rev (snd (decompose_app t))) in
let g = fst (decompose_app applied_g) in
if eq_constr f g
- then raise (Found_type j);
+ then raise (Found_type j);
observe (Printer.pr_lconstr f ++ str " <> " ++
Printer.pr_lconstr g)
-
+
)
ta;
- (* If we reach this point, the two principle are not mutually recursive
- We fall back to the previous method
+ (* If we reach this point, the two principle are not mutually recursive
+ We fall back to the previous method
*)
- let (_,(const,_,_)) =
+ let (_,(const,_,_)) =
build_functional_principle
- false
+ false
(List.nth other_princ_types (!i - 1))
(Array.of_list sorts)
this_block_funs
!i
(prove_princ_for_struct false !i (Array.of_list funs))
(fun _ _ _ -> ())
- in
+ in
const
- with Found_type i ->
- let princ_body =
+ with Found_type i ->
+ let princ_body =
Termops.it_mkLambda_or_LetIn ~init:(mkFix((idxs,i),decl)) ctxt
- in
- {const with
- Entries.const_entry_body = princ_body;
+ in
+ {const with
+ Entries.const_entry_body = princ_body;
Entries.const_entry_type = Some scheme_type
}
)
@@ -650,51 +650,51 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent
in
const::other_result
-let build_scheme fas =
+let build_scheme fas =
Dumpglob.pause ();
- let bodies_types =
- make_scheme
- (List.map
- (fun (_,f,sort) ->
+ let bodies_types =
+ make_scheme
+ (List.map
+ (fun (_,f,sort) ->
let f_as_constant =
try
- match Nametab.global f with
- | Libnames.ConstRef c -> c
+ match Nametab.global f with
+ | Libnames.ConstRef c -> c
| _ -> Util.error "Functional Scheme can only be used with functions"
with Not_found ->
Util.error ("Cannot find "^ Libnames.string_of_reference f)
in
(f_as_constant,sort)
- )
+ )
fas
- )
- in
- List.iter2
- (fun (princ_id,_,_) def_entry ->
- ignore
- (Declare.declare_constant
- princ_id
+ )
+ in
+ List.iter2
+ (fun (princ_id,_,_) def_entry ->
+ ignore
+ (Declare.declare_constant
+ princ_id
(Entries.DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem));
- Flags.if_verbose
+ Flags.if_verbose
(fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) princ_id
)
fas
bodies_types;
Dumpglob.continue ()
-
-let build_case_scheme fa =
- let env = Global.env ()
+
+let build_case_scheme fa =
+ let env = Global.env ()
and sigma = Evd.empty in
(* let id_to_constr id = *)
(* Tacinterp.constr_of_id env id *)
(* in *)
- let funs = (fun (_,f,_) ->
+ let funs = (fun (_,f,_) ->
try Libnames.constr_of_global (Nametab.global f)
- with Not_found ->
- Util.error ("Cannot find "^ Libnames.string_of_reference f)) fa in
- let first_fun = destConst funs in
+ with Not_found ->
+ Util.error ("Cannot find "^ Libnames.string_of_reference f)) fa in
+ let first_fun = destConst funs in
let funs_mp,funs_dp,_ = Names.repr_con first_fun in
let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in
@@ -702,17 +702,17 @@ let build_case_scheme fa =
let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in
- let this_block_funs = Array.map fst this_block_funs_indexes in
+ let this_block_funs = Array.map fst this_block_funs_indexes in
let prop_sort = InProp in
- let funs_indexes =
- let this_block_funs_indexes = Array.to_list this_block_funs_indexes in
+ let funs_indexes =
+ let this_block_funs_indexes = Array.to_list this_block_funs_indexes in
List.assoc (destConst funs) this_block_funs_indexes
in
- let ind_fun =
- let ind = first_fun_kn,funs_indexes in
+ let ind_fun =
+ let ind = first_fun_kn,funs_indexes in
ind,prop_sort
in
- let scheme_type = (Typing.type_of env sigma ) ((fun (ind,sf) -> Indrec.make_case_gen env sigma ind sf) ind_fun) in
+ let scheme_type = (Typing.type_of env sigma ) ((fun (ind,sf) -> Indrec.make_case_gen env sigma ind sf) ind_fun) in
let sorts =
(fun (_,_,x) ->
Termops.new_sort_in_family (Pretyping.interp_elimination_sort x)
@@ -720,7 +720,7 @@ let build_case_scheme fa =
fa
in
let princ_name = (fun (x,_,_) -> x) fa in
- let _ =
+ let _ =
(* Pp.msgnl (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++
pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs
);
diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli
index cf28c6e6c2..fb04c6ec28 100644
--- a/plugins/funind/functional_principles_types.mli
+++ b/plugins/funind/functional_principles_types.mli
@@ -2,26 +2,26 @@ open Names
open Term
-val generate_functional_principle :
+val generate_functional_principle :
(* do we accept interactive proving *)
bool ->
- (* induction principle on rel *)
+ (* induction principle on rel *)
types ->
(* *)
- sorts array option ->
- (* Name of the new principle *)
- (identifier) option ->
+ sorts array option ->
+ (* Name of the new principle *)
+ (identifier) option ->
(* the compute functions to use *)
- constant array ->
+ constant array ->
(* We prove the nth- principle *)
int ->
(* The tactic to use to make the proof w.r
the number of params
*)
- (constr array -> int -> Tacmach.tactic) ->
+ (constr array -> int -> Tacmach.tactic) ->
unit
-val compute_new_princ_type_from_rel : constr array -> sorts array ->
+val compute_new_princ_type_from_rel : constr array -> sorts array ->
types -> types
diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4
index 28fec2e981..0e51eb7e1b 100644
--- a/plugins/funind/g_indfun.ml4
+++ b/plugins/funind/g_indfun.ml4
@@ -11,7 +11,7 @@ open Term
open Names
open Pp
open Topconstr
-open Indfun_common
+open Indfun_common
open Indfun
open Genarg
open Pcoq
@@ -26,14 +26,14 @@ let pr_bindings prc prlc = function
brk (1,1) ++ str "with" ++ brk (1,1) ++
Util.prlist_with_sep spc prc l
| Rawterm.ExplicitBindings l ->
- brk (1,1) ++ str "with" ++ brk (1,1) ++
+ brk (1,1) ++ str "with" ++ brk (1,1) ++
Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
| Rawterm.NoBindings -> mt ()
let pr_with_bindings prc prlc (c,bl) =
prc c ++ hv 0 (pr_bindings prc prlc bl)
-let pr_fun_ind_using prc prlc _ opt_c =
+let pr_fun_ind_using prc prlc _ opt_c =
match opt_c with
| None -> mt ()
| Some (p,b) -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings prc prlc (p,b))
@@ -45,10 +45,10 @@ let pr_fun_ind_using prc prlc _ opt_c =
(prc,prlc)... *)
let pr_with_bindings_typed prc prlc (c,bl) =
- prc c ++
+ prc c ++
hv 0 (pr_bindings (fun c -> prc (snd c)) (fun c -> prlc (snd c)) bl)
-let pr_fun_ind_using_typed prc prlc _ opt_c =
+let pr_fun_ind_using_typed prc prlc _ opt_c =
match opt_c with
| None -> mt ()
| Some (p,b) -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc (p,b))
@@ -67,46 +67,46 @@ END
TACTIC EXTEND newfuninv
- [ "functional" "inversion" quantified_hypothesis(hyp) reference_opt(fname) ] ->
+ [ "functional" "inversion" quantified_hypothesis(hyp) reference_opt(fname) ] ->
[
Invfun.invfun hyp fname
]
END
-let pr_intro_as_pat prc _ _ pat =
- match pat with
+let pr_intro_as_pat prc _ _ pat =
+ match pat with
| Some pat -> spc () ++ str "as" ++ spc () ++ pr_intro_pattern pat
| None -> mt ()
ARGUMENT EXTEND with_names TYPED AS intro_pattern_opt PRINTED BY pr_intro_as_pat
-| [ "as" simple_intropattern(ipat) ] -> [ Some ipat ]
-| [] ->[ None ]
+| [ "as" simple_intropattern(ipat) ] -> [ Some ipat ]
+| [] ->[ None ]
END
TACTIC EXTEND newfunind
- ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] ->
- [
- let c = match cl with
+ ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] ->
+ [
+ let c = match cl with
| [] -> assert false
- | [c] -> c
+ | [c] -> c
| c::cl -> applist(c,cl)
- in
+ in
functional_induction true c princl pat ]
END
(***** debug only ***)
TACTIC EXTEND snewfunind
- ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] ->
- [
- let c = match cl with
+ ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] ->
+ [
+ let c = match cl with
| [] -> assert false
- | [c] -> c
+ | [c] -> c
| c::cl -> applist(c,cl)
- in
+ in
functional_induction false c princl pat ]
END
@@ -130,8 +130,8 @@ ARGUMENT EXTEND auto_using'
END
let pr_rec_annotation2_aux s r id l =
- str ("{"^s^" ") ++ Ppconstr.pr_constr_expr r ++
- Util.pr_opt Nameops.pr_id id ++
+ str ("{"^s^" ") ++ Ppconstr.pr_constr_expr r ++
+ Util.pr_opt Nameops.pr_id id ++
Pptactic.pr_auto_using Ppconstr.pr_constr_expr l ++ str "}"
let pr_rec_annotation2 = function
@@ -143,11 +143,11 @@ VERNAC ARGUMENT EXTEND rec_annotation2
PRINTED BY pr_rec_annotation2
[ "{" "struct" ident(id) "}"] -> [ Struct id ]
| [ "{" "wf" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Wf(r,id,l) ]
-| [ "{" "measure" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Mes(r,id,l) ]
+| [ "{" "measure" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Mes(r,id,l) ]
END
let pr_binder2 (idl,c) =
- str "(" ++ Util.prlist_with_sep spc Nameops.pr_id idl ++ spc () ++
+ str "(" ++ Util.prlist_with_sep spc Nameops.pr_id idl ++ spc () ++
str ": " ++ Ppconstr.pr_lconstr_expr c ++ str ")"
VERNAC ARGUMENT EXTEND binder2
@@ -159,9 +159,9 @@ let make_binder2 (idl,c) =
LocalRawAssum (List.map (fun id -> (Util.dummy_loc,Name id)) idl,Topconstr.default_binder_kind,c)
let pr_rec_definition2 (id,bl,annot,type_,def) =
- Nameops.pr_id id ++ spc () ++ Util.prlist_with_sep spc pr_binder2 bl ++
+ Nameops.pr_id id ++ spc () ++ Util.prlist_with_sep spc pr_binder2 bl ++
Util.pr_opt pr_rec_annotation2 annot ++ spc () ++ str ":" ++ spc () ++
- Ppconstr.pr_lconstr_expr type_ ++ str " :=" ++ spc () ++
+ Ppconstr.pr_lconstr_expr type_ ++ str " :=" ++ spc () ++
Ppconstr.pr_lconstr_expr def
VERNAC ARGUMENT EXTEND rec_definition2
@@ -182,11 +182,11 @@ let make_rec_definitions2 (id,bl,annot,type_,def) =
Pp.str "the recursive argument needs to be specified");
in
let check_exists_args an =
- try
- let id = match an with
- | Struct id -> id | Wf(_,Some id,_) -> id | Mes(_,Some id,_) -> id
- | Wf(_,None,_) | Mes(_,None,_) -> failwith "check_exists_args"
- in
+ try
+ let id = match an with
+ | Struct id -> id | Wf(_,Some id,_) -> id | Mes(_,Some id,_) -> id
+ | Wf(_,None,_) | Mes(_,None,_) -> failwith "check_exists_args"
+ in
(try ignore(Util.list_index0 (Name id) names); annot
with Not_found -> Util.user_err_loc
(Util.dummy_loc,"Function",
@@ -206,33 +206,33 @@ let make_rec_definitions2 (id,bl,annot,type_,def) =
VERNAC COMMAND EXTEND Function
["Function" ne_rec_definition2_list_sep(recsl,"with")] ->
- [
- do_generate_principle false (List.map make_rec_definitions2 recsl);
-
+ [
+ do_generate_principle false (List.map make_rec_definitions2 recsl);
+
]
END
-let pr_fun_scheme_arg (princ_name,fun_name,s) =
- Nameops.pr_id princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++
- Libnames.pr_reference fun_name ++ spc() ++ str "Sort " ++
+let pr_fun_scheme_arg (princ_name,fun_name,s) =
+ Nameops.pr_id princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++
+ Libnames.pr_reference fun_name ++ spc() ++ str "Sort " ++
Ppconstr.pr_rawsort s
VERNAC ARGUMENT EXTEND fun_scheme_arg
PRINTED BY pr_fun_scheme_arg
-| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ]
-END
+| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ]
+END
-let warning_error names e =
- match e with
- | Building_graph e ->
- Pp.msg_warning
- (str "Cannot define graph(s) for " ++
+let warning_error names e =
+ match e with
+ | Building_graph e ->
+ Pp.msg_warning
+ (str "Cannot define graph(s) for " ++
h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++
if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ())
- | Defining_principle e ->
+ | Defining_principle e ->
Pp.msg_warning
- (str "Cannot define principle(s) for "++
+ (str "Cannot define principle(s) for "++
h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++
if do_observe () then Cerrors.explain_exn e else mt ())
| _ -> anomaly ""
@@ -242,29 +242,29 @@ VERNAC COMMAND EXTEND NewFunctionalScheme
["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] ->
[
begin
- try
+ try
Functional_principles_types.build_scheme fas
- with Functional_principles_types.No_graph_found ->
+ with Functional_principles_types.No_graph_found ->
begin
- match fas with
- | (_,fun_name,_)::_ ->
+ match fas with
+ | (_,fun_name,_)::_ ->
begin
begin
make_graph (Nametab.global fun_name)
end
;
try Functional_principles_types.build_scheme fas
- with Functional_principles_types.No_graph_found ->
+ with Functional_principles_types.No_graph_found ->
Util.error ("Cannot generate induction principle(s)")
- | e ->
- let names = List.map (fun (_,na,_) -> na) fas in
+ | e ->
+ let names = List.map (fun (_,na,_) -> na) fas in
warning_error names e
-
+
end
| _ -> assert false (* we can only have non empty list *)
end
- | e ->
- let names = List.map (fun (_,na,_) -> na) fas in
+ | e ->
+ let names = List.map (fun (_,na,_) -> na) fas in
warning_error names e
end
@@ -280,7 +280,7 @@ VERNAC COMMAND EXTEND NewFunctionalCase
END
(***** debug only ***)
-VERNAC COMMAND EXTEND GenerateGraph
+VERNAC COMMAND EXTEND GenerateGraph
["Generate" "graph" "for" reference(c)] -> [ make_graph (Nametab.global c) ]
END
@@ -296,7 +296,7 @@ let msg x = () ;; let pr_lconstr c = str ""
let prconstr c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n")
let prlistconstr lc = List.iter prconstr lc
let prstr s = msg(str s)
-let prNamedConstr s c =
+let prNamedConstr s c =
begin
msg(str "");
msg(str(s^"==>\n ") ++ Printer.pr_lconstr c ++ str "\n<==\n");
@@ -318,8 +318,8 @@ type fapp_info = {
(** [constr_head_match(a b c) a] returns true, false otherwise. *)
let constr_head_match u t=
- if isApp u
- then
+ if isApp u
+ then
let uhd,args= destApp u in
uhd=t
else false
@@ -328,28 +328,28 @@ let constr_head_match u t=
[inu]. DeBruijn are not pushed, so some of them may be unbound in
the result. *)
let rec hdMatchSub inu (test: constr -> bool) : fapp_info list =
- let subres =
+ let subres =
match kind_of_term inu with
- | Lambda (nm,tp,cstr) | Prod (nm,tp,cstr) ->
+ | Lambda (nm,tp,cstr) | Prod (nm,tp,cstr) ->
hdMatchSub tp test @ hdMatchSub (lift 1 cstr) test
| Fix (_,(lna,tl,bl)) -> (* not sure Fix is correct *)
- Array.fold_left
- (fun acc cstr -> acc @ hdMatchSub (lift (Array.length tl) cstr) test)
+ Array.fold_left
+ (fun acc cstr -> acc @ hdMatchSub (lift (Array.length tl) cstr) test)
[] bl
| _ -> (* Cofix will be wrong *)
- fold_constr
- (fun l cstr ->
- l @ hdMatchSub cstr test) [] inu in
+ fold_constr
+ (fun l cstr ->
+ l @ hdMatchSub cstr test) [] inu in
if not (test inu) then subres
else
let f,args = decompose_app inu in
let freeset = Termops.free_rels inu in
let max_rel = try Util.Intset.max_elt freeset with Not_found -> -1 in
{fname = f; largs = args; free = Util.Intset.is_empty freeset;
- max_rel = max_rel; onlyvars = List.for_all isVar args }
+ max_rel = max_rel; onlyvars = List.for_all isVar args }
::subres
-let mkEq typ c1 c2 =
+let mkEq typ c1 c2 =
mkApp (Coqlib.build_coq_eq(),[| typ; c1; c2|])
@@ -357,11 +357,11 @@ let poseq_unsafe idunsafe cstr gl =
let typ = Tacmach.pf_type_of gl cstr in
tclTHEN
(Tactics.letin_tac None (Name idunsafe) cstr None allHypsAndConcl)
- (tclTHENFIRST
- (Tactics.assert_tac Anonymous (mkEq typ (mkVar idunsafe) cstr))
+ (tclTHENFIRST
+ (Tactics.assert_tac Anonymous (mkEq typ (mkVar idunsafe) cstr))
Tactics.reflexivity)
gl
-
+
let poseq id cstr gl =
let x = Tactics.fresh_id [] id gl in
@@ -374,11 +374,11 @@ let list_constr_largs = ref []
let rec poseq_list_ids_rec lcstr gl =
match lcstr with
| [] -> tclIDTAC gl
- | c::lcstr' ->
+ | c::lcstr' ->
match kind_of_term c with
- | Var _ ->
+ | Var _ ->
(list_constr_largs:=c::!list_constr_largs ; poseq_list_ids_rec lcstr' gl)
- | _ ->
+ | _ ->
let _ = prstr "c = " in
let _ = prconstr c in
let _ = prstr "\n" in
@@ -395,16 +395,16 @@ let rec poseq_list_ids_rec lcstr gl =
(poseq_list_ids_rec lcstr')
gl
-let poseq_list_ids lcstr gl =
+let poseq_list_ids lcstr gl =
let _ = list_constr_largs := [] in
poseq_list_ids_rec lcstr gl
(** [find_fapp test g] returns the list of [app_info] of all calls to
functions that satisfy [test] in the conclusion of goal g. Trivial
repetition (not modulo conversion) are deleted. *)
-let find_fapp (test:constr -> bool) g : fapp_info list =
+let find_fapp (test:constr -> bool) g : fapp_info list =
let pre_res = hdMatchSub (Tacmach.pf_concl g) test in
- let res =
+ let res =
List.fold_right (fun x acc -> if List.mem x acc then acc else x::acc) pre_res [] in
(prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) res);
res)
@@ -418,24 +418,24 @@ let find_fapp (test:constr -> bool) g : fapp_info list =
let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info list)
(nexttac:Proof_type.tactic) g =
let test = match oid with
- | Some id ->
+ | Some id ->
let idconstr = mkConst (const_of_id id) in
(fun u -> constr_head_match u idconstr) (* select only id *)
| None -> (fun u -> isApp u) in (* select calls to any function *)
let info_list = find_fapp test g in
let ordered_info_list = heuristic info_list in
- prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) ordered_info_list);
+ prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) ordered_info_list);
if List.length ordered_info_list = 0 then Util.error "function not found in goal\n";
- let taclist: Proof_type.tactic list =
- List.map
+ let taclist: Proof_type.tactic list =
+ List.map
(fun info ->
(tclTHEN
(tclTHEN (poseq_list_ids info.largs)
(
- fun gl ->
- (functional_induction
- true (applist (info.fname, List.rev !list_constr_largs))
- None None) gl))
+ fun gl ->
+ (functional_induction
+ true (applist (info.fname, List.rev !list_constr_largs))
+ None None) gl))
nexttac)) ordered_info_list in
(* we try each (f t u v) until one does not fail *)
(* TODO: try also to mix functional schemes *)
@@ -450,7 +450,7 @@ let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info l
let chose_heuristic (oi:int option) : fapp_info list -> fapp_info list =
match oi with
| Some i -> (fun l -> [ List.nth l (i-1) ]) (* occurrence was given by the user *)
- | None ->
+ | None ->
(* Default heuristic: put first occurrences where all arguments
are *bound* (meaning already introduced) variables *)
let ordering x y =
@@ -464,11 +464,11 @@ let chose_heuristic (oi:int option) : fapp_info list -> fapp_info list =
TACTIC EXTEND finduction
- ["finduction" ident(id) natural_opt(oi)] ->
- [
+ ["finduction" ident(id) natural_opt(oi)] ->
+ [
match oi with
| Some(n) when n<=0 -> Util.error "numerical argument must be > 0"
- | _ ->
+ | _ ->
let heuristic = chose_heuristic oi in
finduction (Some id) heuristic tclIDTAC
]
@@ -477,13 +477,13 @@ END
TACTIC EXTEND fauto
- [ "fauto" tactic(tac)] ->
+ [ "fauto" tactic(tac)] ->
[
let heuristic = chose_heuristic None in
finduction None heuristic (snd tac)
]
|
- [ "fauto" ] ->
+ [ "fauto" ] ->
[
let heuristic = chose_heuristic None in
finduction None heuristic tclIDTAC
@@ -493,7 +493,7 @@ END
TACTIC EXTEND poseq
- [ "poseq" ident(x) constr(c) ] ->
+ [ "poseq" ident(x) constr(c) ] ->
[ poseq x c ]
END
@@ -502,10 +502,10 @@ VERNAC COMMAND EXTEND Showindinfo
END
VERNAC COMMAND EXTEND MergeFunind
- [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")"
- "with" "(" ident(id2) ne_ident_list(cl2) ")" "using" ident(id) ] ->
- [
- let f1 = Constrintern.interp_constr Evd.empty (Global.env())
+ [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")"
+ "with" "(" ident(id2) ne_ident_list(cl2) ")" "using" ident(id) ] ->
+ [
+ let f1 = Constrintern.interp_constr Evd.empty (Global.env())
(CRef (Libnames.Ident (Util.dummy_loc,id1))) in
let f2 = Constrintern.interp_constr Evd.empty (Global.env())
(CRef (Libnames.Ident (Util.dummy_loc,id2))) in
@@ -513,11 +513,11 @@ VERNAC COMMAND EXTEND MergeFunind
let f2type = Typing.type_of (Global.env()) Evd.empty f2 in
let ar1 = List.length (fst (decompose_prod f1type)) in
let ar2 = List.length (fst (decompose_prod f2type)) in
- let _ =
- if ar1 <> List.length cl1 then
+ let _ =
+ if ar1 <> List.length cl1 then
Util.error ("not the right number of arguments for " ^ string_of_id id1) in
- let _ =
- if ar2 <> List.length cl2 then
+ let _ =
+ if ar2 <> List.length cl2 then
Util.error ("not the right number of arguments for " ^ string_of_id id2) in
Merge.merge id1 id2 (Array.of_list cl1) (Array.of_list cl2) id
]
diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml
index 46da3a01d5..7cce53c7c3 100644
--- a/plugins/funind/indfun.ml
+++ b/plugins/funind/indfun.ml
@@ -7,13 +7,13 @@ open Libnames
open Rawterm
open Declarations
-let is_rec_info scheme_info =
- let test_branche min acc (_,_,br) =
+let is_rec_info scheme_info =
+ let test_branche min acc (_,_,br) =
acc || (
- let new_branche =
- it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum br)) in
- let free_rels_in_br = Termops.free_rels new_branche in
- let max = min + scheme_info.Tactics.npredicates in
+ let new_branche =
+ it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum br)) in
+ let free_rels_in_br = Termops.free_rels new_branche in
+ let max = min + scheme_info.Tactics.npredicates in
Util.Intset.exists (fun i -> i >= min && i< max) free_rels_in_br
)
in
@@ -28,38 +28,38 @@ let choose_dest_or_ind scheme_info =
let functional_induction with_clean c princl pat =
Dumpglob.pause ();
- let res = let f,args = decompose_app c in
- fun g ->
- let princ,bindings, princ_type =
- match princl with
+ let res = let f,args = decompose_app c in
+ fun g ->
+ let princ,bindings, princ_type =
+ match princl with
| None -> (* No principle is given let's find the good one *)
begin
match kind_of_term f with
| Const c' ->
- let princ_option =
+ let princ_option =
let finfo = (* we first try to find out a graph on f *)
- try find_Function_infos c'
- with Not_found ->
+ try find_Function_infos c'
+ with Not_found ->
errorlabstrm "" (str "Cannot find induction information on "++
Printer.pr_lconstr (mkConst c') )
in
- match Tacticals.elimination_sort_of_goal g with
+ match Tacticals.elimination_sort_of_goal g with
| InProp -> finfo.prop_lemma
| InSet -> finfo.rec_lemma
| InType -> finfo.rect_lemma
in
let princ = (* then we get the principle *)
try mkConst (Option.get princ_option )
- with Option.IsNone ->
- (*i If there is not default lemma defined then,
- we cross our finger and try to find a lemma named f_ind
+ with Option.IsNone ->
+ (*i If there is not default lemma defined then,
+ we cross our finger and try to find a lemma named f_ind
(or f_rec, f_rect) i*)
- let princ_name =
+ let princ_name =
Indrec.make_elimination_ident
(id_of_label (con_label c'))
(Tacticals.elimination_sort_of_goal g)
in
- try
+ try
mkConst(const_of_id princ_name )
with Not_found -> (* This one is neither defined ! *)
errorlabstrm "" (str "Cannot find induction principle for "
@@ -67,57 +67,57 @@ let functional_induction with_clean c princl pat =
in
(princ,Rawterm.NoBindings, Tacmach.pf_type_of g princ)
| _ -> raise (UserError("",str "functional induction must be used with a function" ))
-
+
end
- | Some ((princ,binding)) ->
+ | Some ((princ,binding)) ->
princ,binding,Tacmach.pf_type_of g princ
in
- let princ_infos = Tactics.compute_elim_sig princ_type in
+ let princ_infos = Tactics.compute_elim_sig princ_type in
let args_as_induction_constr =
- let c_list =
- if princ_infos.Tactics.farg_in_concl
- then [c] else []
+ let c_list =
+ if princ_infos.Tactics.farg_in_concl
+ then [c] else []
in
- List.map (fun c -> Tacexpr.ElimOnConstr (c,NoBindings)) (args@c_list)
- in
- let princ' = Some (princ,bindings) in
- let princ_vars =
- List.fold_right
- (fun a acc ->
+ List.map (fun c -> Tacexpr.ElimOnConstr (c,NoBindings)) (args@c_list)
+ in
+ let princ' = Some (princ,bindings) in
+ let princ_vars =
+ List.fold_right
+ (fun a acc ->
try Idset.add (destVar a) acc
with _ -> acc
)
args
Idset.empty
in
- let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in
- let old_idl = Idset.diff old_idl princ_vars in
- let subst_and_reduce g =
- if with_clean
+ let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in
+ let old_idl = Idset.diff old_idl princ_vars in
+ let subst_and_reduce g =
+ if with_clean
then
- let idl =
- map_succeed
- (fun id ->
+ let idl =
+ map_succeed
+ (fun id ->
if Idset.mem id old_idl then failwith "subst_and_reduce";
- id
+ id
)
(Tacmach.pf_ids_of_hyps g)
- in
- let flag =
+ in
+ let flag =
Rawterm.Cbv
- {Rawterm.all_flags
- with Rawterm.rDelta = false;
+ {Rawterm.all_flags
+ with Rawterm.rDelta = false;
}
in
Tacticals.tclTHEN
(Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Equality.subst [id])) idl )
- (Hiddentac.h_reduce flag Tacticals.allHypsAndConcl)
+ (Hiddentac.h_reduce flag Tacticals.allHypsAndConcl)
g
- else Tacticals.tclIDTAC g
-
+ else Tacticals.tclIDTAC g
+
in
Tacticals.tclTHEN
- (choose_dest_or_ind
+ (choose_dest_or_ind
princ_infos
args_as_induction_constr
princ'
@@ -128,12 +128,12 @@ let functional_induction with_clean c princl pat =
in
Dumpglob.continue ();
res
-
-
-type annot =
- Struct of identifier
+
+
+type annot =
+ Struct of identifier
| Wf of Topconstr.constr_expr * identifier option * Topconstr.constr_expr list
| Mes of Topconstr.constr_expr * identifier option * Topconstr.constr_expr list
@@ -150,12 +150,12 @@ let rec abstract_rawconstr c = function
let interp_casted_constr_with_implicits sigma env impls c =
(* Constrintern.interp_rawconstr_with_implicits sigma env [] impls c *)
- Constrintern.intern_gen false sigma env ~impls:([],impls)
+ Constrintern.intern_gen false sigma env ~impls:([],impls)
~allow_patvar:false ~ltacvars:([],[]) c
-(*
- Construct a fixpoint as a Rawterm
+(*
+ Construct a fixpoint as a Rawterm
and not as a constr
*)
let build_newrecursive
@@ -192,7 +192,7 @@ let build_newrecursive
States.unfreeze fs; def
in
recdef,rec_impls
-
+
let compute_annot (name,annot,args,types,body) =
let names = List.map snd (Topconstr.names_of_local_assums args) in
@@ -207,124 +207,124 @@ let compute_annot (name,annot,args,types,body) =
| Some r -> (name,r,args,types,body)
-(* Checks whether or not the mutual bloc is recursive *)
-let rec is_rec names =
- let names = List.fold_right Idset.add names Idset.empty in
- let check_id id names = Idset.mem id names in
- let rec lookup names = function
+(* Checks whether or not the mutual bloc is recursive *)
+let rec is_rec names =
+ let names = List.fold_right Idset.add names Idset.empty in
+ let check_id id names = Idset.mem id names in
+ let rec lookup names = function
| RVar(_,id) -> check_id id names
| RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ | RDynamic _ -> false
| RCast(_,b,_) -> lookup names b
| RRec _ -> error "RRec not handled"
- | RIf(_,b,_,lhs,rhs) ->
+ | RIf(_,b,_,lhs,rhs) ->
(lookup names b) || (lookup names lhs) || (lookup names rhs)
- | RLetIn(_,na,t,b) | RLambda(_,na,_,t,b) | RProd(_,na,_,t,b) ->
+ | RLetIn(_,na,t,b) | RLambda(_,na,_,t,b) | RProd(_,na,_,t,b) ->
lookup names t || lookup (Nameops.name_fold Idset.remove na names) b
- | RLetTuple(_,nal,_,t,b) -> lookup names t ||
- lookup
- (List.fold_left
+ | RLetTuple(_,nal,_,t,b) -> lookup names t ||
+ lookup
+ (List.fold_left
(fun acc na -> Nameops.name_fold Idset.remove na acc)
names
nal
)
b
| RApp(_,f,args) -> List.exists (lookup names) (f::args)
- | RCases(_,_,_,el,brl) ->
+ | RCases(_,_,_,el,brl) ->
List.exists (fun (e,_) -> lookup names e) el ||
List.exists (lookup_br names) brl
- and lookup_br names (_,idl,_,rt) =
- let new_names = List.fold_right Idset.remove idl names in
+ and lookup_br names (_,idl,_,rt) =
+ let new_names = List.fold_right Idset.remove idl names in
lookup new_names rt
in
lookup names
-let prepare_body (name,annot,args,types,body) rt =
- let n = (Topconstr.local_binders_length args) in
+let prepare_body (name,annot,args,types,body) rt =
+ let n = (Topconstr.local_binders_length args) in
(* Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_rawconstr rt); *)
let fun_args,rt' = chop_rlambda_n n rt in
(fun_args,rt')
let derive_inversion fix_names =
- try
+ try
(* we first transform the fix_names identifier into their corresponding constant *)
- let fix_names_as_constant =
- List.map (fun id -> destConst (Tacinterp.constr_of_id (Global.env ()) id)) fix_names
- in
- (*
- Then we check that the graphs have been defined
- If one of the graphs haven't been defined
+ let fix_names_as_constant =
+ List.map (fun id -> destConst (Tacinterp.constr_of_id (Global.env ()) id)) fix_names
+ in
+ (*
+ Then we check that the graphs have been defined
+ If one of the graphs haven't been defined
we do nothing
*)
List.iter (fun c -> ignore (find_Function_infos c)) fix_names_as_constant ;
try
- Invfun.derive_correctness
+ Invfun.derive_correctness
Functional_principles_types.make_scheme
- functional_induction
+ functional_induction
fix_names_as_constant
- (*i The next call to mk_rel_id is valid since we have just construct the graph
+ (*i The next call to mk_rel_id is valid since we have just construct the graph
Ensures by : register_built
- i*)
+ i*)
(List.map
(fun id -> destInd (Tacinterp.constr_of_id (Global.env ()) (mk_rel_id id)))
fix_names
)
- with e ->
- msg_warning
- (str "Cannot built inversion information" ++
+ with e ->
+ msg_warning
+ (str "Cannot built inversion information" ++
if do_observe () then Cerrors.explain_exn e else mt ())
with _ -> ()
-let warning_error names e =
- let e_explain e =
- match e with
+let warning_error names e =
+ let e_explain e =
+ match e with
| ToShow e -> spc () ++ Cerrors.explain_exn e
| _ -> if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ()
- in
- match e with
- | Building_graph e ->
- Pp.msg_warning
- (str "Cannot define graph(s) for " ++
+ in
+ match e with
+ | Building_graph e ->
+ Pp.msg_warning
+ (str "Cannot define graph(s) for " ++
h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
e_explain e)
- | Defining_principle e ->
+ | Defining_principle e ->
Pp.msg_warning
- (str "Cannot define principle(s) for "++
+ (str "Cannot define principle(s) for "++
h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
e_explain e)
| _ -> anomaly ""
-let error_error names e =
- let e_explain e =
- match e with
+let error_error names e =
+ let e_explain e =
+ match e with
| ToShow e -> spc () ++ Cerrors.explain_exn e
| _ -> if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ()
in
- match e with
- | Building_graph e ->
- errorlabstrm ""
- (str "Cannot define graph(s) for " ++
+ match e with
+ | Building_graph e ->
+ errorlabstrm ""
+ (str "Cannot define graph(s) for " ++
h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
e_explain e)
| _ -> anomaly ""
let generate_principle on_error
- is_general do_built fix_rec_l recdefs interactive_proof
- (continue_proof : int -> Names.constant array -> Term.constr array -> int ->
+ is_general do_built fix_rec_l recdefs interactive_proof
+ (continue_proof : int -> Names.constant array -> Term.constr array -> int ->
Tacmach.tactic) : unit =
let names = List.map (function ((_, name),_,_,_,_) -> name) fix_rec_l in
let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in
let funs_args = List.map fst fun_bodies in
let funs_types = List.map (function (_,_,_,types,_) -> types) fix_rec_l in
- try
+ try
(* We then register the Inductive graphs of the functions *)
Rawterm_to_relation.build_inductive names funs_args funs_types recdefs;
- if do_built
+ if do_built
then
begin
- (*i The next call to mk_rel_id is valid since we have just construct the graph
+ (*i The next call to mk_rel_id is valid since we have just construct the graph
Ensures by : do_built
- i*)
+ i*)
let f_R_mut = Ident (dummy_loc,mk_rel_id (List.nth names 0)) in
let ind_kn =
fst (locate_with_msg
@@ -339,34 +339,34 @@ let generate_principle on_error
locate_constant
f_ref
in
- let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in
- let _ =
+ let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in
+ let _ =
list_map_i
(fun i x ->
- let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in
+ let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in
let princ_type = Typeops.type_of_constant (Global.env()) princ
in
Functional_principles_types.generate_functional_principle
- interactive_proof
+ interactive_proof
princ_type
None
- None
+ None
funs_kn
i
- (continue_proof 0 [|funs_kn.(i)|])
+ (continue_proof 0 [|funs_kn.(i)|])
)
0
fix_rec_l
- in
+ in
Array.iter (add_Function is_general) funs_kn;
()
end
- with e ->
- on_error names e
+ with e ->
+ on_error names e
-let register_struct is_rec fixpoint_exprl =
- match fixpoint_exprl with
- | [((_,fname),_,bl,ret_type,body),_] when not is_rec ->
+let register_struct is_rec fixpoint_exprl =
+ match fixpoint_exprl with
+ | [((_,fname),_,bl,ret_type,body),_] when not is_rec ->
Command.declare_definition
fname
(Decl_kinds.Global,Flags.boxed_definitions (),Decl_kinds.Definition)
@@ -375,65 +375,65 @@ let register_struct is_rec fixpoint_exprl =
body
(Some ret_type)
(fun _ _ -> ())
- | _ ->
+ | _ ->
Command.build_recursive fixpoint_exprl (Flags.boxed_definitions())
-let generate_correction_proof_wf f_ref tcc_lemma_ref
+let generate_correction_proof_wf f_ref tcc_lemma_ref
is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation
- (_: int) (_:Names.constant array) (_:Term.constr array) (_:int) : Tacmach.tactic =
+ (_: int) (_:Names.constant array) (_:Term.constr array) (_:int) : Tacmach.tactic =
Functional_principles_proofs.prove_principle_for_gen
(f_ref,functional_ref,eq_ref)
tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation
let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body
- pre_hook
- =
- let type_of_f = Command.generalize_constr_expr ret_type args in
- let rec_arg_num =
- let names =
+ pre_hook
+ =
+ let type_of_f = Command.generalize_constr_expr ret_type args in
+ let rec_arg_num =
+ let names =
List.map
snd
- (Topconstr.names_of_local_assums args)
- in
- match wf_arg with
- | None ->
+ (Topconstr.names_of_local_assums args)
+ in
+ match wf_arg with
+ | None ->
if List.length names = 1 then 1
else error "Recursive argument must be specified"
- | Some wf_arg ->
- list_index (Name wf_arg) names
+ | Some wf_arg ->
+ list_index (Name wf_arg) names
in
- let unbounded_eq =
- let f_app_args =
- Topconstr.CAppExpl
- (dummy_loc,
+ let unbounded_eq =
+ let f_app_args =
+ Topconstr.CAppExpl
+ (dummy_loc,
(None,(Ident (dummy_loc,fname))) ,
- (List.map
+ (List.map
(function
- | _,Anonymous -> assert false
+ | _,Anonymous -> assert false
| _,Name e -> (Topconstr.mkIdentC e)
- )
+ )
(Topconstr.names_of_local_assums args)
)
- )
+ )
in
Topconstr.CApp (dummy_loc,(None,Topconstr.mkRefC (Qualid (dummy_loc,(qualid_of_string "Logic.eq")))),
[(f_app_args,None);(body,None)])
in
- let eq = Command.generalize_constr_expr unbounded_eq args in
+ let eq = Command.generalize_constr_expr unbounded_eq args in
let hook f_ref tcc_lemma_ref functional_ref eq_ref rec_arg_num rec_arg_type
nb_args relation =
- try
- pre_hook
+ try
+ pre_hook
(generate_correction_proof_wf f_ref tcc_lemma_ref is_mes
functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation
);
derive_inversion [fname]
- with e ->
- (* No proof done *)
+ with e ->
+ (* No proof done *)
()
- in
- Recdef.recursive_definition
+ in
+ Recdef.recursive_definition
is_mes fname rec_impls
type_of_f
wf_rel_expr
@@ -442,115 +442,115 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas
hook
using_lemmas
-
-let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type body =
- let wf_arg_type,wf_arg =
- match wf_arg with
- | None ->
+
+let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type body =
+ let wf_arg_type,wf_arg =
+ match wf_arg with
+ | None ->
begin
- match args with
- | [Topconstr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x
- | _ -> error "Recursive argument must be specified"
+ match args with
+ | [Topconstr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x
+ | _ -> error "Recursive argument must be specified"
end
- | Some wf_args ->
- try
- match
- List.find
- (function
- | Topconstr.LocalRawAssum(l,k,t) ->
- List.exists
- (function (_,Name id) -> id = wf_args | _ -> false)
- l
+ | Some wf_args ->
+ try
+ match
+ List.find
+ (function
+ | Topconstr.LocalRawAssum(l,k,t) ->
+ List.exists
+ (function (_,Name id) -> id = wf_args | _ -> false)
+ l
| _ -> false
)
- args
- with
+ args
+ with
| Topconstr.LocalRawAssum(_,k,t) -> t,wf_args
- | _ -> assert false
- with Not_found -> assert false
+ | _ -> assert false
+ with Not_found -> assert false
in
- let ltof =
- let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) in
- Libnames.Qualid (dummy_loc,Libnames.qualid_of_path
+ let ltof =
+ let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) in
+ Libnames.Qualid (dummy_loc,Libnames.qualid_of_path
(Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (id_of_string "ltof")))
in
- let fun_from_mes =
- let applied_mes =
+ let fun_from_mes =
+ let applied_mes =
Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC wf_arg]) in
- Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],Topconstr.default_binder_kind,wf_arg_type,applied_mes)
+ Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],Topconstr.default_binder_kind,wf_arg_type,applied_mes)
in
- let wf_rel_from_mes =
+ let wf_rel_from_mes =
Topconstr.mkAppC(Topconstr.mkRefC ltof,[wf_arg_type;fun_from_mes])
in
- register_wf ~is_mes:true fname rec_impls wf_rel_from_mes (Some wf_arg)
+ register_wf ~is_mes:true fname rec_impls wf_rel_from_mes (Some wf_arg)
using_lemmas args ret_type body
-
-
-let do_generate_principle on_error register_built interactive_proof fixpoint_exprl =
- let recdefs,rec_impls = build_newrecursive fixpoint_exprl in
- let _is_struct =
- match fixpoint_exprl with
- | [(((_,name),Some (Wf (wf_rel,wf_x,using_lemmas)),args,types,body))] ->
- let pre_hook =
- generate_principle
+
+
+let do_generate_principle on_error register_built interactive_proof fixpoint_exprl =
+ let recdefs,rec_impls = build_newrecursive fixpoint_exprl in
+ let _is_struct =
+ match fixpoint_exprl with
+ | [(((_,name),Some (Wf (wf_rel,wf_x,using_lemmas)),args,types,body))] ->
+ let pre_hook =
+ generate_principle
on_error
true
register_built
- fixpoint_exprl
+ fixpoint_exprl
recdefs
true
- in
- if register_built
+ in
+ if register_built
then register_wf name rec_impls wf_rel wf_x using_lemmas args types body pre_hook;
false
- | [(((_,name),Some (Mes (wf_mes,wf_x,using_lemmas)),args,types,body))] ->
- let pre_hook =
- generate_principle
+ | [(((_,name),Some (Mes (wf_mes,wf_x,using_lemmas)),args,types,body))] ->
+ let pre_hook =
+ generate_principle
on_error
true
register_built
- fixpoint_exprl
+ fixpoint_exprl
recdefs
true
- in
- if register_built
+ in
+ if register_built
then register_mes name rec_impls wf_mes wf_x using_lemmas args types body pre_hook;
true
- | _ ->
- let fix_names =
- List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl
+ | _ ->
+ let fix_names =
+ List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl
in
let is_one_rec = is_rec fix_names in
- let old_fixpoint_exprl =
+ let old_fixpoint_exprl =
List.map
(function
- | (name,Some (Struct id),args,types,body),_ ->
- let annot =
- try Some (dummy_loc, id), Topconstr.CStructRec
- with Not_found ->
- raise (UserError("",str "Cannot find argument " ++
- Ppconstr.pr_id id))
- in
- (name,annot,args,types,body),(None:Vernacexpr.decl_notation)
- | (name,None,args,types,body),recdef ->
+ | (name,Some (Struct id),args,types,body),_ ->
+ let annot =
+ try Some (dummy_loc, id), Topconstr.CStructRec
+ with Not_found ->
+ raise (UserError("",str "Cannot find argument " ++
+ Ppconstr.pr_id id))
+ in
+ (name,annot,args,types,body),(None:Vernacexpr.decl_notation)
+ | (name,None,args,types,body),recdef ->
let names = (Topconstr.names_of_local_assums args) in
if is_one_rec recdef && List.length names > 1 then
user_err_loc
(dummy_loc,"Function",
Pp.str "the recursive argument needs to be specified in Function")
- else
+ else
let loc, na = List.hd names in
(name,(Some (loc, Nameops.out_name na), Topconstr.CStructRec),args,types,body),
(None:Vernacexpr.decl_notation)
- | (_,Some (Wf _),_,_,_),_ | (_,Some (Mes _),_,_,_),_->
- error
+ | (_,Some (Wf _),_,_,_),_ | (_,Some (Mes _),_,_,_),_->
+ error
("Cannot use mutual definition with well-founded recursion or measure")
- )
+ )
(List.combine fixpoint_exprl recdefs)
in
- (* ok all the expressions are structural *)
- let fix_names =
- List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl
+ (* ok all the expressions are structural *)
+ let fix_names =
+ List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl
in
let is_rec = List.exists (is_rec fix_names) recdefs in
if register_built then register_struct is_rec old_fixpoint_exprl;
@@ -559,7 +559,7 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp
false
register_built
fixpoint_exprl
- recdefs
+ recdefs
interactive_proof
(Functional_principles_proofs.prove_princ_for_struct interactive_proof);
if register_built then derive_inversion fix_names;
@@ -568,52 +568,52 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp
()
open Topconstr
-let rec add_args id new_args b =
- match b with
- | CRef r ->
- begin match r with
- | Libnames.Ident(loc,fname) when fname = id ->
+let rec add_args id new_args b =
+ match b with
+ | CRef r ->
+ begin match r with
+ | Libnames.Ident(loc,fname) when fname = id ->
CAppExpl(dummy_loc,(None,r),new_args)
| _ -> b
end
| CFix _ | CCoFix _ -> anomaly "add_args : todo"
- | CArrow(loc,b1,b2) ->
+ | CArrow(loc,b1,b2) ->
CArrow(loc,add_args id new_args b1, add_args id new_args b2)
- | CProdN(loc,nal,b1) ->
+ | CProdN(loc,nal,b1) ->
CProdN(loc,
- List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal,
+ List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal,
add_args id new_args b1)
- | CLambdaN(loc,nal,b1) ->
+ | CLambdaN(loc,nal,b1) ->
CLambdaN(loc,
- List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal,
+ List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal,
add_args id new_args b1)
- | CLetIn(loc,na,b1,b2) ->
+ | CLetIn(loc,na,b1,b2) ->
CLetIn(loc,na,add_args id new_args b1,add_args id new_args b2)
- | CAppExpl(loc,(pf,r),exprl) ->
- begin
- match r with
- | Libnames.Ident(loc,fname) when fname = id ->
+ | CAppExpl(loc,(pf,r),exprl) ->
+ begin
+ match r with
+ | Libnames.Ident(loc,fname) when fname = id ->
CAppExpl(loc,(pf,r),new_args@(List.map (add_args id new_args) exprl))
| _ -> CAppExpl(loc,(pf,r),List.map (add_args id new_args) exprl)
end
- | CApp(loc,(pf,b),bl) ->
- CApp(loc,(pf,add_args id new_args b),
+ | CApp(loc,(pf,b),bl) ->
+ CApp(loc,(pf,add_args id new_args b),
List.map (fun (e,o) -> add_args id new_args e,o) bl)
- | CCases(loc,sty,b_option,cel,cal) ->
+ | CCases(loc,sty,b_option,cel,cal) ->
CCases(loc,sty,Option.map (add_args id new_args) b_option,
- List.map (fun (b,(na,b_option)) ->
+ List.map (fun (b,(na,b_option)) ->
add_args id new_args b,
- (na,Option.map (add_args id new_args) b_option)) cel,
+ (na,Option.map (add_args id new_args) b_option)) cel,
List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal
)
- | CLetTuple(loc,nal,(na,b_option),b1,b2) ->
+ | CLetTuple(loc,nal,(na,b_option),b1,b2) ->
CLetTuple(loc,nal,(na,Option.map (add_args id new_args) b_option),
add_args id new_args b1,
add_args id new_args b2
)
-
- | CIf(loc,b1,(na,b_option),b2,b3) ->
- CIf(loc,add_args id new_args b1,
+
+ | CIf(loc,b1,(na,b_option),b2,b3) ->
+ CIf(loc,add_args id new_args b1,
(na,Option.map (add_args id new_args) b_option),
add_args id new_args b2,
add_args id new_args b3
@@ -622,7 +622,7 @@ let rec add_args id new_args b =
| CPatVar _ -> b
| CEvar _ -> b
| CSort _ -> b
- | CCast(loc,b1,CastConv(ck,b2)) ->
+ | CCast(loc,b1,CastConv(ck,b2)) ->
CCast(loc,add_args id new_args b1,CastConv(ck,add_args id new_args b2))
| CCast(loc,b1,CastCoerce) ->
CCast(loc,add_args id new_args b1,CastCoerce)
@@ -635,70 +635,70 @@ let rec add_args id new_args b =
exception Stop of Topconstr.constr_expr
-(* [chop_n_arrow n t] chops the [n] first arrows in [t]
- Acts on Topconstr.constr_expr
+(* [chop_n_arrow n t] chops the [n] first arrows in [t]
+ Acts on Topconstr.constr_expr
*)
-let rec chop_n_arrow n t =
- if n <= 0
+let rec chop_n_arrow n t =
+ if n <= 0
then t (* If we have already removed all the arrows then return the type *)
- else (* If not we check the form of [t] *)
- match t with
+ else (* If not we check the form of [t] *)
+ match t with
| Topconstr.CArrow(_,_,t) -> (* If we have an arrow, we discard it and recall [chop_n_arrow] *)
chop_n_arrow (n-1) t
- | Topconstr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible :
+ | Topconstr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible :
either we need to discard more than the number of arrows contained
in this product declaration then we just recall [chop_n_arrow] on
- the remaining number of arrow to chop and [t'] we discard it and
- recall [chop_n_arrow], either this product contains more arrows
+ the remaining number of arrow to chop and [t'] we discard it and
+ recall [chop_n_arrow], either this product contains more arrows
than the number we need to chop and then we return the new type
*)
- begin
- try
+ begin
+ try
let new_n =
- let rec aux (n:int) = function
+ let rec aux (n:int) = function
[] -> n
- | (nal,k,t'')::nal_ta' ->
- let nal_l = List.length nal in
+ | (nal,k,t'')::nal_ta' ->
+ let nal_l = List.length nal in
if n >= nal_l
- then
+ then
aux (n - nal_l) nal_ta'
- else
- let new_t' =
+ else
+ let new_t' =
Topconstr.CProdN(dummy_loc,
((snd (list_chop n nal)),k,t'')::nal_ta',t')
- in
+ in
raise (Stop new_t')
in
aux n nal_ta'
- in
+ in
chop_n_arrow new_n t'
with Stop t -> t
end
| _ -> anomaly "Not enough products"
-
-let rec get_args b t : Topconstr.local_binder list *
- Topconstr.constr_expr * Topconstr.constr_expr =
- match b with
- | Topconstr.CLambdaN (loc, (nal_ta), b') ->
+
+let rec get_args b t : Topconstr.local_binder list *
+ Topconstr.constr_expr * Topconstr.constr_expr =
+ match b with
+ | Topconstr.CLambdaN (loc, (nal_ta), b') ->
begin
- let n =
- (List.fold_left (fun n (nal,_,_) ->
+ let n =
+ (List.fold_left (fun n (nal,_,_) ->
n+List.length nal) 0 nal_ta )
in
- let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in
- (List.map (fun (nal,k,ta) ->
- (Topconstr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t''
+ let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in
+ (List.map (fun (nal,k,ta) ->
+ (Topconstr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t''
end
| _ -> [],b,t
let make_graph (f_ref:global_reference) =
- let c,c_body =
- match f_ref with
- | ConstRef c ->
- begin try c,Global.lookup_constant c
- with Not_found ->
+ let c,c_body =
+ match f_ref with
+ | ConstRef c ->
+ begin try c,Global.lookup_constant c
+ with Not_found ->
raise (UserError ("",str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) )
end
| _ -> raise (UserError ("", str "Not a function reference") )
@@ -710,10 +710,10 @@ let make_graph (f_ref:global_reference) =
| Some b ->
let env = Global.env () in
let body = (force b) in
- let extern_body,extern_type =
- with_full_print
- (fun () ->
- (Constrextern.extern_constr false env body,
+ let extern_body,extern_type =
+ with_full_print
+ (fun () ->
+ (Constrextern.extern_constr false env body,
Constrextern.extern_type false env
(Typeops.type_of_constant_type env c_body.const_type)
)
@@ -721,48 +721,48 @@ let make_graph (f_ref:global_reference) =
()
in
let (nal_tas,b,t) = get_args extern_body extern_type in
- let expr_list =
- match b with
- | Topconstr.CFix(loc,l_id,fixexprl) ->
- let l =
+ let expr_list =
+ match b with
+ | Topconstr.CFix(loc,l_id,fixexprl) ->
+ let l =
List.map
- (fun (id,(n,recexp),bl,t,b) ->
+ (fun (id,(n,recexp),bl,t,b) ->
let loc, rec_id = Option.get n in
- let new_args =
- List.flatten
- (List.map
+ let new_args =
+ List.flatten
+ (List.map
(function
| Topconstr.LocalRawDef (na,_)-> []
- | Topconstr.LocalRawAssum (nal,_,_) ->
- List.map
- (fun (loc,n) ->
- CRef(Libnames.Ident(loc, Nameops.out_name n)))
+ | Topconstr.LocalRawAssum (nal,_,_) ->
+ List.map
+ (fun (loc,n) ->
+ CRef(Libnames.Ident(loc, Nameops.out_name n)))
nal
)
nal_tas
)
in
- let b' = add_args (snd id) new_args b in
+ let b' = add_args (snd id) new_args b in
(id, Some (Struct rec_id),nal_tas@bl,t,b')
)
fixexprl
in
l
- | _ ->
- let id = id_of_label (con_label c) in
+ | _ ->
+ let id = id_of_label (con_label c) in
[((dummy_loc,id),None,nal_tas,t,b)]
in
do_generate_principle error_error false false expr_list;
(* We register the infos *)
- let mp,dp,_ = repr_con c in
- List.iter
- (fun ((_,id),_,_,_,_) -> add_Function false (make_con mp dp (label_of_id id)))
+ let mp,dp,_ = repr_con c in
+ List.iter
+ (fun ((_,id),_,_,_,_) -> add_Function false (make_con mp dp (label_of_id id)))
expr_list);
Dumpglob.continue ()
-
+
(* let make_graph _ = assert false *)
-
-let do_generate_principle = do_generate_principle warning_error true
+
+let do_generate_principle = do_generate_principle warning_error true
diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml
index 3583c84484..06f3291fe6 100644
--- a/plugins/funind/indfun_common.ml
+++ b/plugins/funind/indfun_common.ml
@@ -24,13 +24,13 @@ let get_name avoid ?(default="H") = function
| Name n -> Name n
let array_get_start a =
- try
+ try
Array.init
(Array.length a - 1)
(fun i -> a.(i))
- with Invalid_argument "index out of bounds" ->
+ with Invalid_argument "index out of bounds" ->
invalid_argument "array_get_start"
-
+
let id_of_name = function
Name id -> id
| _ -> raise Not_found
@@ -78,7 +78,7 @@ let chop_rlambda_n =
match rt with
| Rawterm.RLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b
| Rawterm.RLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b
- | _ ->
+ | _ ->
raise (Util.UserError("chop_rlambda_n",
str "chop_rlambda_n: Not enough Lambdas"))
in
@@ -107,11 +107,11 @@ let list_union_eq eq_fun l1 l2 =
let list_add_set_eq eq_fun x l =
if List.exists (eq_fun x) l then l else x::l
-
+
let const_of_id id =
- let _,princ_ref =
+ let _,princ_ref =
qualid_of_reference (Libnames.Ident (Util.dummy_loc,id))
in
try Nametab.locate_constant princ_ref
@@ -119,7 +119,7 @@ let const_of_id id =
let def_of_const t =
match (Term.kind_of_term t) with
- Term.Const sp ->
+ Term.Const sp ->
(try (match (Global.lookup_constant sp) with
{Declarations.const_body=Some c} -> Declarations.force c
|_ -> assert false)
@@ -127,17 +127,17 @@ let def_of_const t =
|_ -> assert false
let coq_constant s =
- Coqlib.gen_constant_in_modules "RecursiveDefinition"
+ Coqlib.gen_constant_in_modules "RecursiveDefinition"
(Coqlib.init_modules @ Coqlib.arith_modules) s;;
let constant sl s =
constr_of_global
- (Nametab.locate (make_qualid(Names.make_dirpath
+ (Nametab.locate (make_qualid(Names.make_dirpath
(List.map id_of_string (List.rev sl)))
(id_of_string s)));;
let find_reference sl s =
- (Nametab.locate (make_qualid(Names.make_dirpath
+ (Nametab.locate (make_qualid(Names.make_dirpath
(List.map id_of_string (List.rev sl)))
(id_of_string s)));;
@@ -146,7 +146,7 @@ let refl_equal = lazy(coq_constant "refl_equal")
(*****************************************************************)
(* Copy of the standart save mechanism but without the much too *)
-(* slow reduction function *)
+(* slow reduction function *)
(*****************************************************************)
open Declarations
open Entries
@@ -183,7 +183,7 @@ let save with_clean id const (locality,kind) hook =
let extract_pftreestate pts =
let pfterm,subgoals = Refiner.extract_open_pftreestate pts in
- let tpfsigma = Refiner.evc_of_pftreestate pts in
+ let tpfsigma = Refiner.evc_of_pftreestate pts in
let exl = Evarutil.non_instantiated tpfsigma in
if subgoals <> [] or exl <> [] then
Util.errorlabstrm "extract_proof"
@@ -198,19 +198,19 @@ let extract_pftreestate pts =
let nf_betaiotazeta =
let clos_norm_flags flgs env sigma t =
Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in
- clos_norm_flags Closure.betaiotazeta
+ clos_norm_flags Closure.betaiotazeta
let nf_betaiota =
let clos_norm_flags flgs env sigma t =
Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in
- clos_norm_flags Closure.betaiota
+ clos_norm_flags Closure.betaiota
let cook_proof do_reduce =
- let pfs = Pfedit.get_pftreestate ()
+ let pfs = Pfedit.get_pftreestate ()
(* and ident = Pfedit.get_current_proof_name () *)
and (ident,strength,concl,hook) = Pfedit.current_proof_statement () in
let env,sigma,pfterm = extract_pftreestate pfs in
- let pfterm =
+ let pfterm =
if do_reduce
then nf_betaiota env sigma pfterm
else pfterm
@@ -228,32 +228,32 @@ let new_save_named opacity =
let const = { const with const_entry_opaque = opacity } in
save true id const persistence hook
-let get_proof_clean do_reduce =
- let result = cook_proof do_reduce in
+let get_proof_clean do_reduce =
+ let result = cook_proof do_reduce in
Pfedit.delete_current_proof ();
result
-let with_full_print f a =
+let with_full_print f a =
let old_implicit_args = Impargs.is_implicit_args ()
and old_strict_implicit_args = Impargs.is_strict_implicit_args ()
and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in
- let old_rawprint = !Flags.raw_print in
+ let old_rawprint = !Flags.raw_print in
Flags.raw_print := true;
Impargs.make_implicit_args false;
Impargs.make_strict_implicit_args false;
Impargs.make_contextual_implicit_args false;
Impargs.make_contextual_implicit_args false;
Dumpglob.pause ();
- try
- let res = f a in
+ try
+ let res = f a in
Impargs.make_implicit_args old_implicit_args;
Impargs.make_strict_implicit_args old_strict_implicit_args;
Impargs.make_contextual_implicit_args old_contextual_implicit_args;
Flags.raw_print := old_rawprint;
Dumpglob.continue ();
res
- with
- | e ->
+ with
+ | e ->
Impargs.make_implicit_args old_implicit_args;
Impargs.make_strict_implicit_args old_strict_implicit_args;
Impargs.make_contextual_implicit_args old_contextual_implicit_args;
@@ -268,19 +268,19 @@ let with_full_print f a =
(**********************)
-type function_info =
- {
+type function_info =
+ {
function_constant : constant;
graph_ind : inductive;
equation_lemma : constant option;
correctness_lemma : constant option;
- completeness_lemma : constant option;
+ completeness_lemma : constant option;
rect_lemma : constant option;
rec_lemma : constant option;
prop_lemma : constant option;
is_general : bool; (* Has this function been defined using general recursive definition *)
}
-
+
(* type function_db = function_info list *)
@@ -290,54 +290,54 @@ type function_info =
let from_function = ref Cmap.empty
let from_graph = ref Indmap.empty
(*
-let rec do_cache_info finfo = function
- | [] -> raise Not_found
- | (finfo'::finfos as l) ->
- if finfo' == finfo then l
- else if finfo'.function_constant = finfo.function_constant
+let rec do_cache_info finfo = function
+ | [] -> raise Not_found
+ | (finfo'::finfos as l) ->
+ if finfo' == finfo then l
+ else if finfo'.function_constant = finfo.function_constant
then finfo::finfos
else
- let res = do_cache_info finfo finfos in
+ let res = do_cache_info finfo finfos in
if res == finfos then l else finfo'::l
-
-let cache_Function (_,(finfos)) =
- let new_tbl =
+
+let cache_Function (_,(finfos)) =
+ let new_tbl =
try do_cache_info finfos !function_table
with Not_found -> finfos::!function_table
- in
- if new_tbl != !function_table
+ in
+ if new_tbl != !function_table
then function_table := new_tbl
*)
-let cache_Function (_,finfos) =
+let cache_Function (_,finfos) =
from_function := Cmap.add finfos.function_constant finfos !from_function;
from_graph := Indmap.add finfos.graph_ind finfos !from_graph
let load_Function _ = cache_Function
let open_Function _ = cache_Function
-let subst_Function (_,subst,finfos) =
+let subst_Function (_,subst,finfos) =
let do_subst_con c = fst (Mod_subst.subst_con subst c)
and do_subst_ind (kn,i) = (Mod_subst.subst_kn subst kn,i)
in
- let function_constant' = do_subst_con finfos.function_constant in
- let graph_ind' = do_subst_ind finfos.graph_ind in
- let equation_lemma' = Option.smartmap do_subst_con finfos.equation_lemma in
- let correctness_lemma' = Option.smartmap do_subst_con finfos.correctness_lemma in
- let completeness_lemma' = Option.smartmap do_subst_con finfos.completeness_lemma in
+ let function_constant' = do_subst_con finfos.function_constant in
+ let graph_ind' = do_subst_ind finfos.graph_ind in
+ let equation_lemma' = Option.smartmap do_subst_con finfos.equation_lemma in
+ let correctness_lemma' = Option.smartmap do_subst_con finfos.correctness_lemma in
+ let completeness_lemma' = Option.smartmap do_subst_con finfos.completeness_lemma in
let rect_lemma' = Option.smartmap do_subst_con finfos.rect_lemma in
- let rec_lemma' = Option.smartmap do_subst_con finfos.rec_lemma in
- let prop_lemma' = Option.smartmap do_subst_con finfos.prop_lemma in
- if function_constant' == finfos.function_constant &&
- graph_ind' == finfos.graph_ind &&
+ let rec_lemma' = Option.smartmap do_subst_con finfos.rec_lemma in
+ let prop_lemma' = Option.smartmap do_subst_con finfos.prop_lemma in
+ if function_constant' == finfos.function_constant &&
+ graph_ind' == finfos.graph_ind &&
equation_lemma' == finfos.equation_lemma &&
- correctness_lemma' == finfos.correctness_lemma &&
- completeness_lemma' == finfos.completeness_lemma &&
- rect_lemma' == finfos.rect_lemma &&
- rec_lemma' == finfos.rec_lemma &&
- prop_lemma' == finfos.prop_lemma
- then finfos
+ correctness_lemma' == finfos.correctness_lemma &&
+ completeness_lemma' == finfos.completeness_lemma &&
+ rect_lemma' == finfos.rect_lemma &&
+ rec_lemma' == finfos.rec_lemma &&
+ prop_lemma' == finfos.prop_lemma
+ then finfos
else
{ function_constant = function_constant';
graph_ind = graph_ind';
@@ -355,25 +355,25 @@ let classify_Function infos = Libobject.Substitute infos
let export_Function infos = Some infos
-let discharge_Function (_,finfos) =
+let discharge_Function (_,finfos) =
let function_constant' = Lib.discharge_con finfos.function_constant
- and graph_ind' = Lib.discharge_inductive finfos.graph_ind
- and equation_lemma' = Option.smartmap Lib.discharge_con finfos.equation_lemma
- and correctness_lemma' = Option.smartmap Lib.discharge_con finfos.correctness_lemma
- and completeness_lemma' = Option.smartmap Lib.discharge_con finfos.completeness_lemma
- and rect_lemma' = Option.smartmap Lib.discharge_con finfos.rect_lemma
+ and graph_ind' = Lib.discharge_inductive finfos.graph_ind
+ and equation_lemma' = Option.smartmap Lib.discharge_con finfos.equation_lemma
+ and correctness_lemma' = Option.smartmap Lib.discharge_con finfos.correctness_lemma
+ and completeness_lemma' = Option.smartmap Lib.discharge_con finfos.completeness_lemma
+ and rect_lemma' = Option.smartmap Lib.discharge_con finfos.rect_lemma
and rec_lemma' = Option.smartmap Lib.discharge_con finfos.rec_lemma
and prop_lemma' = Option.smartmap Lib.discharge_con finfos.prop_lemma
in
- if function_constant' == finfos.function_constant &&
- graph_ind' == finfos.graph_ind &&
+ if function_constant' == finfos.function_constant &&
+ graph_ind' == finfos.graph_ind &&
equation_lemma' == finfos.equation_lemma &&
- correctness_lemma' == finfos.correctness_lemma &&
- completeness_lemma' == finfos.completeness_lemma &&
- rect_lemma' == finfos.rect_lemma &&
- rec_lemma' == finfos.rec_lemma &&
- prop_lemma' == finfos.prop_lemma
- then Some finfos
+ correctness_lemma' == finfos.correctness_lemma &&
+ completeness_lemma' == finfos.completeness_lemma &&
+ rect_lemma' == finfos.rect_lemma &&
+ rec_lemma' == finfos.rec_lemma &&
+ prop_lemma' == finfos.prop_lemma
+ then Some finfos
else
Some { function_constant = function_constant' ;
graph_ind = graph_ind' ;
@@ -384,12 +384,12 @@ let discharge_Function (_,finfos) =
rec_lemma = rec_lemma';
prop_lemma = prop_lemma' ;
is_general = finfos.is_general
- }
+ }
open Term
-let pr_info f_info =
+let pr_info f_info =
str "function_constant := " ++ Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++
- str "function_constant_type := " ++
+ str "function_constant_type := " ++
(try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant)) with _ -> mt ()) ++ fnl () ++
str "equation_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++
str "completeness_lemma :=" ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++
@@ -397,15 +397,15 @@ let pr_info f_info =
str "rect_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rect_lemma (mt ()) ) ++ fnl () ++
str "rec_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rec_lemma (mt ()) ) ++ fnl () ++
str "prop_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.prop_lemma (mt ()) ) ++ fnl () ++
- str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl ()
+ str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl ()
-let pr_table tb =
- let l = Cmap.fold (fun k v acc -> v::acc) tb [] in
+let pr_table tb =
+ let l = Cmap.fold (fun k v acc -> v::acc) tb [] in
Util.prlist_with_sep fnl pr_info l
-let in_Function,out_Function =
+let in_Function,out_Function =
Libobject.declare_object
- {(Libobject.default_object "FUNCTIONS_DB") with
+ {(Libobject.default_object "FUNCTIONS_DB") with
Libobject.cache_function = cache_Function;
Libobject.load_function = load_Function;
Libobject.classify_function = classify_Function;
@@ -418,57 +418,57 @@ let in_Function,out_Function =
(* Synchronisation with reset *)
-let freeze () =
+let freeze () =
!from_function,!from_graph
-let unfreeze (functions,graphs) =
+let unfreeze (functions,graphs) =
(* Pp.msgnl (str "unfreezing function_table : " ++ pr_table l); *)
from_function := functions;
from_graph := graphs
-let init () =
+let init () =
(* Pp.msgnl (str "reseting function_table"); *)
from_function := Cmap.empty;
from_graph := Indmap.empty
-let _ =
+let _ =
Summary.declare_summary "functions_db_sum"
{ Summary.freeze_function = freeze;
Summary.unfreeze_function = unfreeze;
Summary.init_function = init }
-let find_or_none id =
- try Some
- (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> Util.anomaly "Not a constant"
- )
+let find_or_none id =
+ try Some
+ (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> Util.anomaly "Not a constant"
+ )
with Not_found -> None
-let find_Function_infos f =
+let find_Function_infos f =
Cmap.find f !from_function
-let find_Function_of_graph ind =
+let find_Function_of_graph ind =
Indmap.find ind !from_graph
-
-let update_Function finfo =
+
+let update_Function finfo =
(* Pp.msgnl (pr_info finfo); *)
Lib.add_anonymous_leaf (in_Function finfo)
-
-
-let add_Function is_general f =
- let f_id = id_of_label (con_label f) in
+
+
+let add_Function is_general f =
+ let f_id = id_of_label (con_label f) in
let equation_lemma = find_or_none (mk_equation_id f_id)
- and correctness_lemma = find_or_none (mk_correct_id f_id)
- and completeness_lemma = find_or_none (mk_complete_id f_id)
+ and correctness_lemma = find_or_none (mk_correct_id f_id)
+ and completeness_lemma = find_or_none (mk_complete_id f_id)
and rect_lemma = find_or_none (Nameops.add_suffix f_id "_rect")
and rec_lemma = find_or_none (Nameops.add_suffix f_id "_rec")
and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind")
- and graph_ind =
- match Nametab.locate (qualid_of_ident (mk_rel_id f_id))
+ and graph_ind =
+ match Nametab.locate (qualid_of_ident (mk_rel_id f_id))
with | IndRef ind -> ind | _ -> Util.anomaly "Not an inductive"
in
- let finfos =
+ let finfos =
{ function_constant = f;
equation_lemma = equation_lemma;
completeness_lemma = completeness_lemma;
@@ -478,7 +478,7 @@ let add_Function is_general f =
prop_lemma = prop_lemma;
graph_ind = graph_ind;
is_general = is_general
-
+
}
in
update_Function finfos
@@ -486,7 +486,7 @@ let add_Function is_general f =
let pr_table () = pr_table !from_function
(*********************************)
(* Debuging *)
-let function_debug = ref false
+let function_debug = ref false
open Goptions
let function_debug_sig =
@@ -501,13 +501,13 @@ let function_debug_sig =
let _ = declare_bool_option function_debug_sig
-let do_observe () =
+let do_observe () =
!function_debug = true
-
-
-
+
+
+
let strict_tcc = ref false
-let is_strict_tcc () = !strict_tcc
+let is_strict_tcc () = !strict_tcc
let strict_tcc_sig =
{
optsync = false;
@@ -520,29 +520,29 @@ let strict_tcc_sig =
let _ = declare_bool_option strict_tcc_sig
-exception Building_graph of exn
+exception Building_graph of exn
exception Defining_principle of exn
exception ToShow of exn
-let init_constant dir s =
- try
+let init_constant dir s =
+ try
Coqlib.gen_constant "Function" dir s
with e -> raise (ToShow e)
-let jmeq () =
- try
- (Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
+let jmeq () =
+ try
+ (Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
init_constant ["Logic";"JMeq"] "JMeq")
with e -> raise (ToShow e)
-let jmeq_rec () =
+let jmeq_rec () =
try
- Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
+ Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
init_constant ["Logic";"JMeq"] "JMeq_rec"
with e -> raise (ToShow e)
-let jmeq_refl () =
- try
+let jmeq_refl () =
+ try
Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
init_constant ["Logic";"JMeq"] "JMeq_refl"
with e -> raise (ToShow e)
diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli
index e9aa692b61..87d646ab89 100644
--- a/plugins/funind/indfun_common.mli
+++ b/plugins/funind/indfun_common.mli
@@ -1,10 +1,10 @@
open Names
open Pp
-(*
- The mk_?_id function build different name w.r.t. a function
- Each of their use is justified in the code
-*)
+(*
+ The mk_?_id function build different name w.r.t. a function
+ Each of their use is justified in the code
+*)
val mk_rel_id : identifier -> identifier
val mk_correct_id : identifier -> identifier
val mk_complete_id : identifier -> identifier
@@ -16,8 +16,8 @@ val msgnl : std_ppcmds -> unit
val invalid_argument : string -> 'a
val fresh_id : identifier list -> string -> identifier
-val fresh_name : identifier list -> string -> name
-val get_name : identifier list -> ?default:string -> name -> name
+val fresh_name : identifier list -> string -> name
+val get_name : identifier list -> ?default:string -> name -> name
val array_get_start : 'a array -> 'a array
@@ -46,11 +46,11 @@ val eq : Term.constr Lazy.t
val refl_equal : Term.constr Lazy.t
val const_of_id: identifier -> constant
val jmeq : unit -> Term.constr
-val jmeq_refl : unit -> Term.constr
+val jmeq_refl : unit -> Term.constr
+
+(* [save_named] is a copy of [Command.save_named] but uses
+ [nf_betaiotazeta] instead of [nf_betaiotaevar_preserving_vm_cast]
-(* [save_named] is a copy of [Command.save_named] but uses
- [nf_betaiotazeta] instead of [nf_betaiotaevar_preserving_vm_cast]
-
DON'T USE IT if you cannot ensure that there is no VMcast in the proof
@@ -59,32 +59,32 @@ val jmeq_refl : unit -> Term.constr
(* val nf_betaiotazeta : Reductionops.reduction_function *)
-val new_save_named : bool -> unit
+val new_save_named : bool -> unit
-val save : bool -> identifier -> Entries.definition_entry -> Decl_kinds.goal_kind ->
- Tacexpr.declaration_hook -> unit
+val save : bool -> identifier -> Entries.definition_entry -> Decl_kinds.goal_kind ->
+ Tacexpr.declaration_hook -> unit
-(* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and
- abort the proof
+(* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and
+ abort the proof
*)
-val get_proof_clean : bool ->
+val get_proof_clean : bool ->
Names.identifier *
(Entries.definition_entry * Decl_kinds.goal_kind *
Tacexpr.declaration_hook)
-
-(* [with_full_print f a] applies [f] to [a] in full printing environment
-
- This function preserves the print settings
+
+(* [with_full_print f a] applies [f] to [a] in full printing environment
+
+ This function preserves the print settings
*)
val with_full_print : ('a -> 'b) -> 'a -> 'b
(*****************)
-type function_info =
- {
+type function_info =
+ {
function_constant : constant;
graph_ind : inductive;
equation_lemma : constant option;
@@ -101,10 +101,10 @@ val find_Function_of_graph : inductive -> function_info
(* WARNING: To be used just after the graph definition !!! *)
val add_Function : bool -> constant -> unit
-val update_Function : function_info -> unit
+val update_Function : function_info -> unit
-(** debugging *)
+(** debugging *)
val pr_info : function_info -> Pp.std_ppcmds
val pr_table : unit -> Pp.std_ppcmds
@@ -113,8 +113,8 @@ val pr_table : unit -> Pp.std_ppcmds
val do_observe : unit -> bool
(* To localize pb *)
-exception Building_graph of exn
+exception Building_graph of exn
exception Defining_principle of exn
-exception ToShow of exn
+exception ToShow of exn
val is_strict_tcc : unit -> bool
diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml
index 5f8587408b..116a3c9913 100644
--- a/plugins/funind/invfun.ml
+++ b/plugins/funind/invfun.ml
@@ -22,7 +22,7 @@ open Hiddentac
(* Some pretty printing function for debugging purpose *)
-let pr_binding prc =
+let pr_binding prc =
function
| loc, Rawterm.NamedHyp id, (_,c) -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c)
| loc, Rawterm.AnonHyp n, (_,c) -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c)
@@ -32,7 +32,7 @@ let pr_bindings prc prlc = function
brk (1,1) ++ str "with" ++ brk (1,1) ++
Util.prlist_with_sep spc (fun (_,c) -> prc c) l
| Rawterm.ExplicitBindings l ->
- brk (1,1) ++ str "with" ++ brk (1,1) ++
+ brk (1,1) ++ str "with" ++ brk (1,1) ++
Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
| Rawterm.NoBindings -> mt ()
@@ -42,7 +42,7 @@ let pr_with_bindings prc prlc (c,bl) =
-let pr_constr_with_binding prc (c,bl) : Pp.std_ppcmds =
+let pr_constr_with_binding prc (c,bl) : Pp.std_ppcmds =
pr_with_bindings prc prc (c,bl)
(* The local debuging mechanism *)
@@ -61,11 +61,11 @@ let observennl strm =
let do_observe_tac s tac g =
let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in
- try
+ try
let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v
with e ->
- msgnl (str "observation "++ s++str " raised exception " ++
- Cerrors.explain_exn e ++ str " on goal " ++ goal );
+ msgnl (str "observation "++ s++str " raised exception " ++
+ Cerrors.explain_exn e ++ str " on goal " ++ goal );
raise e;;
@@ -75,117 +75,117 @@ let observe_tac s tac g =
else tac g
(* [nf_zeta] $\zeta$-normalization of a term *)
-let nf_zeta =
+let nf_zeta =
Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
Environ.empty_env
Evd.empty
(* [id_to_constr id] finds the term associated to [id] in the global environment *)
-let id_to_constr id =
+let id_to_constr id =
try
Tacinterp.constr_of_id (Global.env ()) id
- with Not_found ->
+ with Not_found ->
raise (UserError ("",str "Cannot find " ++ Ppconstr.pr_id id))
-(* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true]
- (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block.
+(* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true]
+ (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block.
- [generate_type true f i] returns
- \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res,
- graph\ x_1\ldots x_n\ res \rightarrow res = fv \] decomposed as the context and the conclusion
+ [generate_type true f i] returns
+ \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res,
+ graph\ x_1\ldots x_n\ res \rightarrow res = fv \] decomposed as the context and the conclusion
- [generate_type false f i] returns
- \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res,
- res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion
+ [generate_type false f i] returns
+ \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res,
+ res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion
*)
-let generate_type g_to_f f graph i =
+let generate_type g_to_f f graph i =
(*i we deduce the number of arguments of the function and its returned type from the graph i*)
- let graph_arity = Inductive.type_of_inductive (Global.env()) (Global.lookup_inductive (destInd graph)) in
- let ctxt,_ = decompose_prod_assum graph_arity in
- let fun_ctxt,res_type =
- match ctxt with
+ let graph_arity = Inductive.type_of_inductive (Global.env()) (Global.lookup_inductive (destInd graph)) in
+ let ctxt,_ = decompose_prod_assum graph_arity in
+ let fun_ctxt,res_type =
+ match ctxt with
| [] | [_] -> anomaly "Not a valid context"
| (_,_,res_type)::fun_ctxt -> fun_ctxt,res_type
in
let nb_args = List.length fun_ctxt in
- let args_from_decl i decl =
- match decl with
+ let args_from_decl i decl =
+ match decl with
| (_,Some _,_) -> incr i; failwith "args_from_decl"
- | _ -> let j = !i in incr i;mkRel (nb_args - j + 1)
+ | _ -> let j = !i in incr i;mkRel (nb_args - j + 1)
in
(*i We need to name the vars [res] and [fv] i*)
- let res_id =
- Termops.next_global_ident_away
+ let res_id =
+ Termops.next_global_ident_away
true
(id_of_string "res")
(map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "") fun_ctxt)
in
- let fv_id =
- Termops.next_global_ident_away
+ let fv_id =
+ Termops.next_global_ident_away
true
(id_of_string "fv")
(res_id::(map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "Anonymous!") fun_ctxt))
in
(*i we can then type the argument to be applied to the function [f] i*)
- let args_as_rels =
+ let args_as_rels =
let i = ref 0 in
- Array.of_list ((map_succeed (args_from_decl i) (List.rev fun_ctxt)))
+ Array.of_list ((map_succeed (args_from_decl i) (List.rev fun_ctxt)))
in
let args_as_rels = Array.map Termops.pop args_as_rels in
(*i
- the hypothesis [res = fv] can then be computed
- We will need to lift it by one in order to use it as a conclusion
+ the hypothesis [res = fv] can then be computed
+ We will need to lift it by one in order to use it as a conclusion
i*)
let res_eq_f_of_args =
mkApp(Coqlib.build_coq_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|])
- in
- (*i
- The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed
- We will need to lift it by one in order to use it as a conclusion
- i*)
- let graph_applied =
- let args_and_res_as_rels =
+ in
+ (*i
+ The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed
+ We will need to lift it by one in order to use it as a conclusion
+ i*)
+ let graph_applied =
+ let args_and_res_as_rels =
let i = ref 0 in
Array.of_list ((map_succeed (args_from_decl i) (List.rev ((Name res_id,None,res_type)::fun_ctxt))) )
in
- let args_and_res_as_rels =
+ let args_and_res_as_rels =
Array.mapi (fun i c -> if i <> Array.length args_and_res_as_rels - 1 then lift 1 c else c) args_and_res_as_rels
in
- mkApp(graph,args_and_res_as_rels)
- in
- (*i The [pre_context] is the defined to be the context corresponding to
+ mkApp(graph,args_and_res_as_rels)
+ in
+ (*i The [pre_context] is the defined to be the context corresponding to
\[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \]
i*)
- let pre_ctxt =
- (Name res_id,None,lift 1 res_type)::(Name fv_id,Some (mkApp(mkConst f,args_as_rels)),res_type)::fun_ctxt
- in
+ let pre_ctxt =
+ (Name res_id,None,lift 1 res_type)::(Name fv_id,Some (mkApp(mkConst f,args_as_rels)),res_type)::fun_ctxt
+ in
(*i and we can return the solution depending on which lemma type we are defining i*)
- if g_to_f
+ if g_to_f
then (Anonymous,None,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args)
else (Anonymous,None,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied)
-(*
+(*
[find_induction_principle f] searches and returns the [body] and the [type] of [f_rect]
-
+
WARNING: while convertible, [type_of body] and [type] can be non equal
*)
-let find_induction_principle f =
- let f_as_constant = match kind_of_term f with
+let find_induction_principle f =
+ let f_as_constant = match kind_of_term f with
| Const c' -> c'
| _ -> error "Must be used with a function"
in
- let infos = find_Function_infos f_as_constant in
- match infos.rect_lemma with
- | None -> raise Not_found
- | Some rect_lemma ->
- let rect_lemma = mkConst rect_lemma in
- let typ = Typing.type_of (Global.env ()) Evd.empty rect_lemma in
+ let infos = find_Function_infos f_as_constant in
+ match infos.rect_lemma with
+ | None -> raise Not_found
+ | Some rect_lemma ->
+ let rect_lemma = mkConst rect_lemma in
+ let typ = Typing.type_of (Global.env ()) Evd.empty rect_lemma in
rect_lemma,typ
-
-
+
+
(* let fname = *)
(* match kind_of_term f with *)
@@ -205,41 +205,41 @@ let find_induction_principle f =
(* c,Typing.type_of (Global.env ()) Evd.empty c *)
-let rec generate_fresh_id x avoid i =
- if i == 0
- then []
+let rec generate_fresh_id x avoid i =
+ if i == 0
+ then []
else
- let id = Termops.next_global_ident_away true x avoid in
+ let id = Termops.next_global_ident_away true x avoid in
id::(generate_fresh_id x (id::avoid) (pred i))
-(* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ]
- is the tactic used to prove correctness lemma.
-
+(* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ]
+ is the tactic used to prove correctness lemma.
+
[functional_induction] is the tactic defined in [indfun] (dependency problem)
[funs_constr], [graphs_constr] [schemes] [lemmas_types_infos] are the mutually recursive functions
- (resp. graphs of the functions and principles and correctness lemma types) to prove correct.
-
+ (resp. graphs of the functions and principles and correctness lemma types) to prove correct.
+
[i] is the indice of the function to prove correct
- The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is
+ The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is
it looks like~:
- [\forall (x_1:t_1)\ldots(x_n:t_n), forall res,
+ [\forall (x_1:t_1)\ldots(x_n:t_n), forall res,
res = f x_1\ldots x_n in, \rightarrow graph\ x_1\ldots x_n\ res]
- The sketch of the proof is the following one~:
+ The sketch of the proof is the following one~:
\begin{enumerate}
\item intros until $x_n$
\item $functional\ induction\ (f.(i)\ x_1\ldots x_n)$ using schemes.(i)
- \item for each generated branch intro [res] and [hres :res = f x_1\ldots x_n], rewrite [hres] and the
+ \item for each generated branch intro [res] and [hres :res = f x_1\ldots x_n], rewrite [hres] and the
apply the corresponding constructor of the corresponding graph inductive.
\end{enumerate}
-
+
*)
let prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : tactic =
fun g ->
- (* first of all we recreate the lemmas types to be used as predicates of the induction principle
+ (* first of all we recreate the lemmas types to be used as predicates of the induction principle
that is~:
\[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\]
*)
@@ -257,8 +257,8 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
in
(* we the get the definition of the graphs block *)
let graph_ind = destInd graphs_constr.(i) in
- let kn = fst graph_ind in
- let mib,_ = Global.lookup_inductive graph_ind in
+ let kn = fst graph_ind in
+ let mib,_ = Global.lookup_inductive graph_ind in
(* and the principle to use in this lemma in $\zeta$ normal form *)
let f_principle,princ_type = schemes.(i) in
let princ_type = nf_zeta princ_type in
@@ -267,9 +267,9 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
let nb_fun_args = nb_prod (pf_concl g) - 2 in
let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in
let ids = args_names@(pf_ids_of_hyps g) in
- (* Since we cannot ensure that the funcitonnal principle is defined in the
+ (* Since we cannot ensure that the funcitonnal principle is defined in the
environement and due to the bug #1174, we will need to pose the principle
- using a name
+ using a name
*)
let principle_id = Termops.next_global_ident_away true (id_of_string "princ") ids in
let ids = principle_id :: ids in
@@ -290,8 +290,8 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
let eq_ind = Coqlib.build_coq_eq () in
let eq_construct = mkConstruct((destInd eq_ind),1) in
(* The next to referencies will be used to find out which constructor to apply in each branch *)
- let ind_number = ref 0
- and min_constr_number = ref 0 in
+ let ind_number = ref 0
+ and min_constr_number = ref 0 in
(* The tactic to prove the ith branch of the principle *)
let prove_branche i g =
(* We get the identifiers of this branch *)
@@ -317,18 +317,18 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
(pre_args,
tclTHEN (h_reduce (Rawterm.Unfold([Rawterm.all_occurrences_expr,EvalVarRef id])) allHyps) pre_tac
)
-
+
else (pre_args,pre_tac)
)
(pf_hyps g)
([],tclIDTAC)
in
- (*
- We can then recompute the arguments of the constructor.
- For each [hid] introduced by this branch, if [hid] has type
+ (*
+ We can then recompute the arguments of the constructor.
+ For each [hid] introduced by this branch, if [hid] has type
$forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are
- [ fv (hid fv (refl_equal fv)) ].
-
+ [ fv (hid fv (refl_equal fv)) ].
+
If [hid] has another type the corresponding argument of the constructor is [hid]
*)
let constructor_args =
@@ -360,21 +360,21 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
let params_id = fst (list_chop princ_infos.nparams args_names) in
(List.map mkVar params_id)@(List.rev constructor_args)
in
- (* We then get the constructor corresponding to this branch and
- modifies the references has needed i.e.
- if the constructor is the last one of the current inductive then
- add one the number of the inductive to take and add the number of constructor of the previous
- graph to the minimal constructor number
+ (* We then get the constructor corresponding to this branch and
+ modifies the references has needed i.e.
+ if the constructor is the last one of the current inductive then
+ add one the number of the inductive to take and add the number of constructor of the previous
+ graph to the minimal constructor number
*)
- let constructor =
- let constructor_num = i - !min_constr_number in
- let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in
+ let constructor =
+ let constructor_num = i - !min_constr_number in
+ let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in
if constructor_num <= length
- then
- begin
+ then
+ begin
(kn,!ind_number),constructor_num
end
- else
+ else
begin
incr ind_number;
min_constr_number := !min_constr_number + length ;
@@ -418,8 +418,8 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
let param_names = fst (list_chop princ_infos.nparams args_names) in
let params = List.map mkVar param_names in
let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in
- (* The bindings of the principle
- that is the params of the principle and the different lemma types
+ (* The bindings of the principle
+ that is the params of the principle and the different lemma types
*)
let bindings =
let params_bindings,avoid =
@@ -435,7 +435,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
let lemmas_bindings =
List.rev (fst (List.fold_left2
(fun (bindings,avoid) (x,_,_) p ->
- let id = Nameops.next_ident_away (Nameops.out_name x) avoid in
+ let id = Nameops.next_ident_away (Nameops.out_name x) avoid in
(dummy_loc,Rawterm.NamedHyp id,inj_open (nf_zeta p))::bindings,id::avoid)
([],avoid)
princ_infos.predicates
@@ -451,7 +451,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
(h_exact f_principle));
tclTHEN_i
(observe_tac "functional_induction" (
- fun g ->
+ fun g ->
observe
(pr_constr_with_binding (Printer.pr_lconstr_env (pf_env g)) (mkVar principle_id,bindings));
functional_induction false (applist(funs_constr.(i),List.map mkVar args_names))
@@ -462,13 +462,13 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
]
g
-(* [generalize_dependent_of x hyp g]
- generalize every hypothesis which depends of [x] but [hyp]
+(* [generalize_dependent_of x hyp g]
+ generalize every hypothesis which depends of [x] but [hyp]
*)
-let generalize_dependent_of x hyp g =
- tclMAP
- (function
- | (id,None,t) when not (id = hyp) &&
+let generalize_dependent_of x hyp g =
+ tclMAP
+ (function
+ | (id,None,t) when not (id = hyp) &&
(Termops.occur_var (pf_env g) x t) -> tclTHEN (h_generalize [mkVar id]) (thin [id])
| _ -> tclIDTAC
)
@@ -479,86 +479,86 @@ let generalize_dependent_of x hyp g =
- (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis
+ (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis
(unfolding, substituting, destructing cases \ldots)
*)
-let rec intros_with_rewrite g =
+let rec intros_with_rewrite g =
observe_tac "intros_with_rewrite" intros_with_rewrite_aux g
-and intros_with_rewrite_aux : tactic =
- fun g ->
- let eq_ind = Coqlib.build_coq_eq () in
- match kind_of_term (pf_concl g) with
- | Prod(_,t,t') ->
- begin
- match kind_of_term t with
- | App(eq,args) when (eq_constr eq eq_ind) ->
+and intros_with_rewrite_aux : tactic =
+ fun g ->
+ let eq_ind = Coqlib.build_coq_eq () in
+ match kind_of_term (pf_concl g) with
+ | Prod(_,t,t') ->
+ begin
+ match kind_of_term t with
+ | App(eq,args) when (eq_constr eq eq_ind) ->
if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2)
then
let id = pf_get_new_id (id_of_string "y") g in
tclTHENSEQ [ h_intro id; thin [id]; intros_with_rewrite ] g
else if isVar args.(1)
- then
- let id = pf_get_new_id (id_of_string "y") g in
+ then
+ let id = pf_get_new_id (id_of_string "y") g in
tclTHENSEQ [ h_intro id;
- generalize_dependent_of (destVar args.(1)) id;
+ generalize_dependent_of (destVar args.(1)) id;
tclTRY (Equality.rewriteLR (mkVar id));
intros_with_rewrite
- ]
+ ]
g
else
- begin
- let id = pf_get_new_id (id_of_string "y") g in
+ begin
+ let id = pf_get_new_id (id_of_string "y") g in
tclTHENSEQ[
h_intro id;
tclTRY (Equality.rewriteLR (mkVar id));
intros_with_rewrite
] g
end
- | Ind _ when eq_constr t (Coqlib.build_coq_False ()) ->
+ | Ind _ when eq_constr t (Coqlib.build_coq_False ()) ->
Tauto.tauto g
- | Case(_,_,v,_) ->
+ | Case(_,_,v,_) ->
tclTHENSEQ[
h_case false (v,Rawterm.NoBindings);
intros_with_rewrite
] g
- | LetIn _ ->
+ | LetIn _ ->
tclTHENSEQ[
- h_reduce
+ h_reduce
(Rawterm.Cbv
- {Rawterm.all_flags
- with Rawterm.rDelta = false;
- })
+ {Rawterm.all_flags
+ with Rawterm.rDelta = false;
+ })
onConcl
;
intros_with_rewrite
] g
- | _ ->
- let id = pf_get_new_id (id_of_string "y") g in
+ | _ ->
+ let id = pf_get_new_id (id_of_string "y") g in
tclTHENSEQ [ h_intro id;intros_with_rewrite] g
end
- | LetIn _ ->
+ | LetIn _ ->
tclTHENSEQ[
- h_reduce
+ h_reduce
(Rawterm.Cbv
- {Rawterm.all_flags
- with Rawterm.rDelta = false;
- })
+ {Rawterm.all_flags
+ with Rawterm.rDelta = false;
+ })
onConcl
;
intros_with_rewrite
] g
- | _ -> tclIDTAC g
-
-let rec reflexivity_with_destruct_cases g =
- let destruct_case () =
- try
- match kind_of_term (snd (destApp (pf_concl g))).(2) with
- | Case(_,_,v,_) ->
+ | _ -> tclIDTAC g
+
+let rec reflexivity_with_destruct_cases g =
+ let destruct_case () =
+ try
+ match kind_of_term (snd (destApp (pf_concl g))).(2) with
+ | Case(_,_,v,_) ->
tclTHENSEQ[
h_case false (v,Rawterm.NoBindings);
intros;
- observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases
+ observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases
]
| _ -> reflexivity
with _ -> reflexivity
@@ -566,13 +566,13 @@ let rec reflexivity_with_destruct_cases g =
let eq_ind = Coqlib.build_coq_eq () in
let discr_inject =
Tacticals.onAllHypsAndConcl (
- fun sc g ->
- match sc with
+ fun sc g ->
+ match sc with
None -> tclIDTAC g
- | Some id ->
- match kind_of_term (pf_type_of g (mkVar id)) with
- | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind ->
- if Equality.discriminable (pf_env g) (project g) t1 t2
+ | Some id ->
+ match kind_of_term (pf_type_of g (mkVar id)) with
+ | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind ->
+ if Equality.discriminable (pf_env g) (project g) t1 t2
then Equality.discrHyp id g
else if Equality.injectable (pf_env g) (project g) t1 t2
then tclTHENSEQ [Equality.injHyp id;thin [id];intros_with_rewrite] g
@@ -583,10 +583,10 @@ let rec reflexivity_with_destruct_cases g =
(tclFIRST
[ reflexivity;
tclTHEN (tclPROGRESS discr_inject) (destruct_case ());
- (* We reach this point ONLY if
- the same value is matched (at least) two times
+ (* We reach this point ONLY if
+ the same value is matched (at least) two times
along binding path.
- In this case, either we have a discriminable hypothesis and we are done,
+ In this case, either we have a discriminable hypothesis and we are done,
either at least an injectable one and we do the injection before continuing
*)
tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases
@@ -594,95 +594,95 @@ let rec reflexivity_with_destruct_cases g =
g
-(* [prove_fun_complete funs graphs schemes lemmas_types_infos i]
- is the tactic used to prove completness lemma.
-
+(* [prove_fun_complete funs graphs schemes lemmas_types_infos i]
+ is the tactic used to prove completness lemma.
+
[funcs], [graphs] [schemes] [lemmas_types_infos] are the mutually recursive functions
- (resp. definitions of the graphs of the functions, principles and correctness lemma types) to prove correct.
-
+ (resp. definitions of the graphs of the functions, principles and correctness lemma types) to prove correct.
+
[i] is the indice of the function to prove complete
- The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is
+ The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is
it looks like~:
- [\forall (x_1:t_1)\ldots(x_n:t_n), forall res,
+ [\forall (x_1:t_1)\ldots(x_n:t_n), forall res,
graph\ x_1\ldots x_n\ res, \rightarrow res = f x_1\ldots x_n in]
- The sketch of the proof is the following one~:
+ The sketch of the proof is the following one~:
\begin{enumerate}
\item intros until $H:graph\ x_1\ldots x_n\ res$
\item $elim\ H$ using schemes.(i)
- \item for each generated branch, intro the news hyptohesis, for each such hyptohesis [h], if [h] has
- type [x=?] with [x] a variable, then subst [x],
- if [h] has type [t=?] with [t] not a variable then rewrite [t] in the subterms, else
- if [h] is a match then destruct it, else do just introduce it,
+ \item for each generated branch, intro the news hyptohesis, for each such hyptohesis [h], if [h] has
+ type [x=?] with [x] a variable, then subst [x],
+ if [h] has type [t=?] with [t] not a variable then rewrite [t] in the subterms, else
+ if [h] is a match then destruct it, else do just introduce it,
after all intros, the conclusion should be a reflexive equality.
\end{enumerate}
-
+
*)
-let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
- fun g ->
- (* We compute the types of the different mutually recursive lemmas
+let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
+ fun g ->
+ (* We compute the types of the different mutually recursive lemmas
in $\zeta$ normal form
*)
- let lemmas =
- Array.map
- (fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn ~init:concl ctxt))
+ let lemmas =
+ Array.map
+ (fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn ~init:concl ctxt))
lemmas_types_infos
in
(* We get the constant and the principle corresponding to this lemma *)
let f = funcs.(i) in
- let graph_principle = nf_zeta schemes.(i) in
- let princ_type = pf_type_of g graph_principle in
- let princ_infos = Tactics.compute_elim_sig princ_type in
- (* Then we get the number of argument of the function
+ let graph_principle = nf_zeta schemes.(i) in
+ let princ_type = pf_type_of g graph_principle in
+ let princ_infos = Tactics.compute_elim_sig princ_type in
+ (* Then we get the number of argument of the function
and compute a fresh name for each of them
*)
- let nb_fun_args = nb_prod (pf_concl g) - 2 in
+ let nb_fun_args = nb_prod (pf_concl g) - 2 in
let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in
let ids = args_names@(pf_ids_of_hyps g) in
(* and fresh names for res H and the principle (cf bug bug #1174) *)
- let res,hres,graph_principle_id =
- match generate_fresh_id (id_of_string "z") ids 3 with
+ let res,hres,graph_principle_id =
+ match generate_fresh_id (id_of_string "z") ids 3 with
| [res;hres;graph_principle_id] -> res,hres,graph_principle_id
- | _ -> assert false
+ | _ -> assert false
in
- let ids = res::hres::graph_principle_id::ids in
+ let ids = res::hres::graph_principle_id::ids in
(* we also compute fresh names for each hyptohesis of each branche of the principle *)
- let branches = List.rev princ_infos.branches in
- let intro_pats =
- List.map
- (fun (_,_,br_type) ->
- List.map
- (fun id -> id)
+ let branches = List.rev princ_infos.branches in
+ let intro_pats =
+ List.map
+ (fun (_,_,br_type) ->
+ List.map
+ (fun id -> id)
(generate_fresh_id (id_of_string "y") ids (nb_prod br_type))
)
branches
in
- (* We will need to change the function by its body
- using [f_equation] if it is recursive (that is the graph is infinite
- or unfold if the graph is finite
+ (* We will need to change the function by its body
+ using [f_equation] if it is recursive (that is the graph is infinite
+ or unfold if the graph is finite
*)
- let rewrite_tac j ids : tactic =
- let graph_def = graphs.(j) in
- let infos = try find_Function_infos (destConst funcs.(j)) with Not_found -> error "No graph found" in
+ let rewrite_tac j ids : tactic =
+ let graph_def = graphs.(j) in
+ let infos = try find_Function_infos (destConst funcs.(j)) with Not_found -> error "No graph found" in
if infos.is_general || Rtree.is_infinite graph_def.mind_recargs
- then
- let eq_lemma =
+ then
+ let eq_lemma =
try Option.get (infos).equation_lemma
with Option.IsNone -> anomaly "Cannot find equation lemma"
- in
+ in
tclTHENSEQ[
tclMAP h_intro ids;
Equality.rewriteLR (mkConst eq_lemma);
(* Don't forget to $\zeta$ normlize the term since the principles have been $\zeta$-normalized *)
- h_reduce
+ h_reduce
(Rawterm.Cbv
- {Rawterm.all_flags
- with Rawterm.rDelta = false;
- })
+ {Rawterm.all_flags
+ with Rawterm.rDelta = false;
+ })
onConcl
;
h_generalize (List.map mkVar ids);
@@ -691,16 +691,16 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
else unfold_in_concl [(all_occurrences,Names.EvalConstRef (destConst f))]
in
(* The proof of each branche itself *)
- let ind_number = ref 0 in
+ let ind_number = ref 0 in
let min_constr_number = ref 0 in
- let prove_branche i g =
+ let prove_branche i g =
(* we fist compute the inductive corresponding to the branch *)
- let this_ind_number =
- let constructor_num = i - !min_constr_number in
- let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in
+ let this_ind_number =
+ let constructor_num = i - !min_constr_number in
+ let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in
if constructor_num <= length
then !ind_number
- else
+ else
begin
incr ind_number;
min_constr_number := !min_constr_number + length;
@@ -719,13 +719,13 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
g
in
let params_names = fst (list_chop princ_infos.nparams args_names) in
- let params = List.map mkVar params_names in
- tclTHENSEQ
+ let params = List.map mkVar params_names in
+ tclTHENSEQ
[ tclMAP h_intro (args_names@[res;hres]);
- observe_tac "h_generalize"
+ observe_tac "h_generalize"
(h_generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]);
h_intro graph_principle_id;
- observe_tac "" (tclTHEN_i
+ observe_tac "" (tclTHEN_i
(observe_tac "elim" ((elim false (mkVar hres,Rawterm.NoBindings) (Some (mkVar graph_principle_id,Rawterm.NoBindings)))))
(fun i g -> observe_tac "prove_branche" (prove_branche i) g ))
]
@@ -737,94 +737,94 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
let do_save () = Command.save_named false
-(* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness
+(* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness
lemmas for each function in [funs] w.r.t. [graphs]
-
- [make_scheme] is Functional_principle_types.make_scheme (dependency pb) and
- [functional_induction] is Indfun.functional_induction (same pb)
+
+ [make_scheme] is Functional_principle_types.make_scheme (dependency pb) and
+ [functional_induction] is Indfun.functional_induction (same pb)
*)
-
-let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) =
+
+let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) =
let funs = Array.of_list funs and graphs = Array.of_list graphs in
let funs_constr = Array.map mkConst funs in
- try
- let graphs_constr = Array.map mkInd graphs in
- let lemmas_types_infos =
- Util.array_map2_i
- (fun i f_constr graph ->
- let const_of_f = destConst f_constr in
- let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info =
+ try
+ let graphs_constr = Array.map mkInd graphs in
+ let lemmas_types_infos =
+ Util.array_map2_i
+ (fun i f_constr graph ->
+ let const_of_f = destConst f_constr in
+ let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info =
generate_type false const_of_f graph i
- in
- let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in
+ in
+ let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in
let type_of_lemma = nf_zeta type_of_lemma in
observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma);
type_of_lemma,type_info
)
funs_constr
- graphs_constr
+ graphs_constr
in
- let schemes =
- (* The functional induction schemes are computed and not saved if there is more that one function
+ let schemes =
+ (* The functional induction schemes are computed and not saved if there is more that one function
if the block contains only one function we can safely reuse [f_rect]
*)
try
if Array.length funs_constr <> 1 then raise Not_found;
[| find_induction_principle funs_constr.(0) |]
- with Not_found ->
- Array.of_list
- (List.map
- (fun entry ->
+ with Not_found ->
+ Array.of_list
+ (List.map
+ (fun entry ->
(entry.Entries.const_entry_body, Option.get entry.Entries.const_entry_type )
)
(make_scheme (array_map_to_list (fun const -> const,Rawterm.RType None) funs))
)
in
- let proving_tac =
+ let proving_tac =
prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos
in
- Array.iteri
- (fun i f_as_constant ->
+ Array.iteri
+ (fun i f_as_constant ->
let f_id = id_of_label (con_label f_as_constant) in
- Command.start_proof
+ Command.start_proof
(*i The next call to mk_correct_id is valid since we are constructing the lemma
Ensures by: obvious
- i*)
+ i*)
(mk_correct_id f_id)
(Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
(fst lemmas_types_infos.(i))
(fun _ _ -> ());
Pfedit.by (observe_tac ("prove correctness ("^(string_of_id f_id)^")") (proving_tac i));
do_save ();
- let finfo = find_Function_infos f_as_constant in
+ let finfo = find_Function_infos f_as_constant in
update_Function
- {finfo with
+ {finfo with
correctness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_correct_id f_id)))
}
)
funs;
- let lemmas_types_infos =
- Util.array_map2_i
- (fun i f_constr graph ->
- let const_of_f = destConst f_constr in
- let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info =
+ let lemmas_types_infos =
+ Util.array_map2_i
+ (fun i f_constr graph ->
+ let const_of_f = destConst f_constr in
+ let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info =
generate_type true const_of_f graph i
- in
- let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in
+ in
+ let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in
let type_of_lemma = nf_zeta type_of_lemma in
observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma);
type_of_lemma,type_info
)
funs_constr
- graphs_constr
+ graphs_constr
in
- let kn,_ as graph_ind = destInd graphs_constr.(0) in
+ let kn,_ as graph_ind = destInd graphs_constr.(0) in
let mib,mip = Global.lookup_inductive graph_ind in
- let schemes =
- Array.of_list
+ let schemes =
+ Array.of_list
(Indrec.build_mutual_indrec (Global.env ()) Evd.empty
- (Array.to_list
+ (Array.to_list
(Array.mapi
(fun i mip -> (kn,i),mib,mip,true,InType)
mib.Declarations.mind_packets
@@ -832,25 +832,25 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g
)
)
in
- let proving_tac =
+ let proving_tac =
prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos
in
- Array.iteri
- (fun i f_as_constant ->
+ Array.iteri
+ (fun i f_as_constant ->
let f_id = id_of_label (con_label f_as_constant) in
- Command.start_proof
+ Command.start_proof
(*i The next call to mk_complete_id is valid since we are constructing the lemma
Ensures by: obvious
- i*)
+ i*)
(mk_complete_id f_id)
(Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
(fst lemmas_types_infos.(i))
(fun _ _ -> ());
Pfedit.by (observe_tac ("prove completeness ("^(string_of_id f_id)^")") (proving_tac i));
do_save ();
- let finfo = find_Function_infos f_as_constant in
+ let finfo = find_Function_infos f_as_constant in
update_Function
- {finfo with
+ {finfo with
completeness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_complete_id f_id)))
}
)
@@ -859,16 +859,16 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g
(* In case of problem, we reset all the lemmas *)
(*i The next call to mk_correct_id is valid since we are erasing the lemmas
Ensures by: obvious
- i*)
- let first_lemma_id =
- let f_id = id_of_label (con_label funs.(0)) in
-
- mk_correct_id f_id
+ i*)
+ let first_lemma_id =
+ let f_id = id_of_label (con_label funs.(0)) in
+
+ mk_correct_id f_id
in
ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,first_lemma_id) with _ -> ());
raise e
-
-
+
+
@@ -876,73 +876,73 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g
(* [revert_graph kn post_tac hid] transforme an hypothesis [hid] having type Ind(kn,num) t1 ... tn res
when [kn] denotes a graph block into
- f_num t1... tn = res (by applying [f_complete] to the first type) before apply post_tac on the result
-
+ f_num t1... tn = res (by applying [f_complete] to the first type) before apply post_tac on the result
+
if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing
*)
let revert_graph kn post_tac hid g =
- let typ = pf_type_of g (mkVar hid) in
- match kind_of_term typ with
- | App(i,args) when isInd i ->
- let ((kn',num) as ind') = destInd i in
- if kn = kn'
+ let typ = pf_type_of g (mkVar hid) in
+ match kind_of_term typ with
+ | App(i,args) when isInd i ->
+ let ((kn',num) as ind') = destInd i in
+ if kn = kn'
then (* We have generated a graph hypothesis so that we must change it if we can *)
- let info =
+ let info =
try find_Function_of_graph ind'
with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*)
anomaly "Cannot retrieve infos about a mutual block"
- in
- (* if we can find a completeness lemma for this function
- then we can come back to the functional form. If not, we do nothing
+ in
+ (* if we can find a completeness lemma for this function
+ then we can come back to the functional form. If not, we do nothing
*)
- match info.completeness_lemma with
+ match info.completeness_lemma with
| None -> tclIDTAC g
- | Some f_complete ->
+ | Some f_complete ->
let f_args,res = array_chop (Array.length args - 1) args in
tclTHENSEQ
[
h_generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])];
thin [hid];
- h_intro hid;
+ h_intro hid;
post_tac hid
]
g
-
+
else tclIDTAC g
| _ -> tclIDTAC g
-(*
+(*
[functional_inversion hid fconst f_correct ] is the functional version of [inversion]
-
+
[hid] is the hypothesis to invert, [fconst] is the function to invert and [f_correct]
is the correctness lemma for [fconst].
- The sketch is the follwing~:
- \begin{enumerate}
- \item Transforms the hypothesis [hid] such that its type is now $res\ =\ f\ t_1 \ldots t_n$
+ The sketch is the follwing~:
+ \begin{enumerate}
+ \item Transforms the hypothesis [hid] such that its type is now $res\ =\ f\ t_1 \ldots t_n$
(fails if it is not possible)
\item replace [hid] with $R\_f t_1 \ldots t_n res$ using [f_correct]
\item apply [inversion] on [hid]
- \item finally in each branch, replace each hypothesis [R\_f ..] by [f ...] using [f_complete] (whenever
+ \item finally in each branch, replace each hypothesis [R\_f ..] by [f ...] using [f_complete] (whenever
such a lemma exists)
\end{enumerate}
*)
-
-let functional_inversion kn hid fconst f_correct : tactic =
- fun g ->
- let old_ids = List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty in
- let type_of_h = pf_type_of g (mkVar hid) in
- match kind_of_term type_of_h with
- | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) ->
- let pre_tac,f_args,res =
- match kind_of_term args.(1),kind_of_term args.(2) with
- | App(f,f_args),_ when eq_constr f fconst ->
+
+let functional_inversion kn hid fconst f_correct : tactic =
+ fun g ->
+ let old_ids = List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty in
+ let type_of_h = pf_type_of g (mkVar hid) in
+ match kind_of_term type_of_h with
+ | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) ->
+ let pre_tac,f_args,res =
+ match kind_of_term args.(1),kind_of_term args.(2) with
+ | App(f,f_args),_ when eq_constr f fconst ->
((fun hid -> h_symmetry (onHyp hid)),f_args,args.(2))
- |_,App(f,f_args) when eq_constr f fconst ->
- ((fun hid -> tclIDTAC),f_args,args.(1))
+ |_,App(f,f_args) when eq_constr f fconst ->
+ ((fun hid -> tclIDTAC),f_args,args.(1))
| _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2)
- in
+ in
tclTHENSEQ[
pre_tac hid;
h_generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])];
@@ -950,7 +950,7 @@ let functional_inversion kn hid fconst f_correct : tactic =
h_intro hid;
Inv.inv FullInversion None (Rawterm.NamedHyp hid);
(fun g ->
- let new_ids = List.filter (fun id -> not (Idset.mem id old_ids)) (pf_ids_of_hyps g) in
+ let new_ids = List.filter (fun id -> not (Idset.mem id old_ids)) (pf_ids_of_hyps g) in
tclMAP (revert_graph kn pre_tac) (hid::new_ids) g
);
] g
@@ -958,62 +958,62 @@ let functional_inversion kn hid fconst f_correct : tactic =
-let invfun qhyp f =
- let f =
- match f with
- | ConstRef f -> f
+let invfun qhyp f =
+ let f =
+ match f with
+ | ConstRef f -> f
| _ -> raise (Util.UserError("",str "Not a function"))
in
- try
- let finfos = find_Function_infos f in
- let f_correct = mkConst(Option.get finfos.correctness_lemma)
+ try
+ let finfos = find_Function_infos f in
+ let f_correct = mkConst(Option.get finfos.correctness_lemma)
and kn = fst finfos.graph_ind
in
- Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f) f_correct) qhyp
- with
- | Not_found -> error "No graph found"
+ Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f) f_correct) qhyp
+ with
+ | Not_found -> error "No graph found"
| Option.IsNone -> error "Cannot use equivalence with graph!"
-let invfun qhyp f g =
- match f with
+let invfun qhyp f g =
+ match f with
| Some f -> invfun qhyp f g
- | None ->
- Tactics.try_intros_until
- (fun hid g ->
- let hyp_typ = pf_type_of g (mkVar hid) in
- match kind_of_term hyp_typ with
- | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) ->
+ | None ->
+ Tactics.try_intros_until
+ (fun hid g ->
+ let hyp_typ = pf_type_of g (mkVar hid) in
+ match kind_of_term hyp_typ with
+ | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) ->
begin
- let f1,_ = decompose_app args.(1) in
- try
+ let f1,_ = decompose_app args.(1) in
+ try
if not (isConst f1) then failwith "";
- let finfos = find_Function_infos (destConst f1) in
- let f_correct = mkConst(Option.get finfos.correctness_lemma)
+ let finfos = find_Function_infos (destConst f1) in
+ let f_correct = mkConst(Option.get finfos.correctness_lemma)
and kn = fst finfos.graph_ind
in
functional_inversion kn hid f1 f_correct g
- with | Failure "" | Option.IsNone | Not_found ->
- try
- let f2,_ = decompose_app args.(2) in
+ with | Failure "" | Option.IsNone | Not_found ->
+ try
+ let f2,_ = decompose_app args.(2) in
if not (isConst f2) then failwith "";
- let finfos = find_Function_infos (destConst f2) in
- let f_correct = mkConst(Option.get finfos.correctness_lemma)
+ let finfos = find_Function_infos (destConst f2) in
+ let f_correct = mkConst(Option.get finfos.correctness_lemma)
and kn = fst finfos.graph_ind
in
functional_inversion kn hid f2 f_correct g
with
- | Failure "" ->
+ | Failure "" ->
errorlabstrm "" (str "Hypothesis" ++ Ppconstr.pr_id hid ++ str " must contain at leat one Function")
- | Option.IsNone ->
- if do_observe ()
+ | Option.IsNone ->
+ if do_observe ()
then
error "Cannot use equivalence with graph for any side of the equality"
else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid)
- | Not_found ->
- if do_observe ()
+ | Not_found ->
+ if do_observe ()
then
- error "No graph found for any side of equality"
+ error "No graph found for any side of equality"
else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid)
end
| _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ")
diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml
index 092830025b..3538f63426 100644
--- a/plugins/funind/merge.ml
+++ b/plugins/funind/merge.ml
@@ -18,7 +18,7 @@ open Vernacexpr
open Pp
open Names
open Term
-open Termops
+open Termops
open Declarations
open Environ
open Rawterm
@@ -32,19 +32,19 @@ let rec popn i c = if i<=0 then c else pop (popn (i-1) c)
(** Substitutions in constr *)
let compare_constr_nosub t1 t2 =
- if compare_constr (fun _ _ -> false) t1 t2
+ if compare_constr (fun _ _ -> false) t1 t2
then true
else false
let rec compare_constr' t1 t2 =
- if compare_constr_nosub t1 t2
+ if compare_constr_nosub t1 t2
then true
else (compare_constr (compare_constr') t1 t2)
let rec substitterm prof t by_t in_u =
if (compare_constr' (lift prof t) in_u)
then (lift prof by_t)
- else map_constr_with_binders succ
+ else map_constr_with_binders succ
(fun i -> substitterm i t by_t) prof in_u
let lift_ldecl n ldecl = List.map (fun (x,y) -> x,lift n y) ldecl
@@ -59,23 +59,23 @@ let name_of_string str = Name (id_of_string str)
let string_of_name nme = string_of_id (id_of_name nme)
(** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *)
-let isVarf f x =
+let isVarf f x =
match x with
- | RVar (_,x) -> Pervasives.compare x f = 0
+ | RVar (_,x) -> Pervasives.compare x f = 0
| _ -> false
(** [ident_global_exist id] returns true if identifier [id] is linked
in global environment. *)
-let ident_global_exist id =
- try
+let ident_global_exist id =
+ try
let ans = CRef (Libnames.Ident (dummy_loc,id)) in
let _ = ignore (Constrintern.intern_constr Evd.empty (Global.env()) ans) in
true
- with _ -> false
+ with _ -> false
(** [next_ident_fresh id] returns a fresh identifier (ie not linked in
global env) with base [id]. *)
-let next_ident_fresh (id:identifier) =
+let next_ident_fresh (id:identifier) =
let res = ref id in
while ident_global_exist !res do res := Nameops.lift_ident !res done;
!res
@@ -89,37 +89,37 @@ let prconstr c = msg (str" " ++ Printer.pr_lconstr c)
let prconstrnl c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n")
let prlistconstr lc = List.iter prconstr lc
let prstr s = msg(str s)
-let prNamedConstr s c =
+let prNamedConstr s c =
begin
msg(str "");
msg(str(s^" {§ ") ++ Printer.pr_lconstr c ++ str " §} ");
msg(str "");
end
-let prNamedRConstr s c =
+let prNamedRConstr s c =
begin
msg(str "");
msg(str(s^" {§ ") ++ Printer.pr_rawconstr c ++ str " §} ");
msg(str "");
end
let prNamedLConstr_aux lc = List.iter (prNamedConstr "\n") lc
-let prNamedLConstr s lc =
+let prNamedLConstr s lc =
begin
prstr "[§§§ ";
prstr s;
prNamedLConstr_aux lc;
prstr " §§§]\n";
end
-let prNamedLDecl s lc =
+let prNamedLDecl s lc =
begin
prstr s; prstr "\n";
List.iter (fun (nm,_,tp) -> prNamedConstr (string_of_name nm) tp) lc;
prstr "\n";
end
-let prNamedRLDecl s lc =
+let prNamedRLDecl s lc =
begin
prstr s; prstr "\n"; prstr "{§§ ";
- List.iter
- (fun x ->
+ List.iter
+ (fun x ->
match x with
| (nm,None,Some tp) -> prNamedRConstr (string_of_name nm) tp
| (nm,Some bdy,None) -> prNamedRConstr ("(letin) "^string_of_name nm) bdy
@@ -133,16 +133,16 @@ let showind (id:identifier) =
let cstrid = Tacinterp.constr_of_id (Global.env()) id in
let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in
let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in
- List.iter (fun (nm, optcstr, tp) ->
+ List.iter (fun (nm, optcstr, tp) ->
print_string (string_of_name nm^":");
- prconstr tp; print_string "\n")
+ prconstr tp; print_string "\n")
ib1.mind_arity_ctxt;
(match ib1.mind_arity with
| Monomorphic x ->
Printf.printf "arity :"; prconstr x.mind_user_arity
- | Polymorphic x ->
+ | Polymorphic x ->
Printf.printf "arity : universe?");
- Array.iteri
+ Array.iteri
(fun i x -> Printf.printf"type constr %d :" i ; prconstr x)
ib1.mind_user_lc
@@ -151,7 +151,7 @@ let showind (id:identifier) =
exception Found of int
(* Array scanning *)
-let array_find (arr: 'a array) (pred: int -> 'a -> bool): int option =
+let array_find (arr: 'a array) (pred: int -> 'a -> bool): int option =
try
for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done;
None
@@ -163,10 +163,10 @@ let array_prfx (arr: 'a array) (pred: int -> 'a -> bool): int =
Array.length arr (* all elt are positive *)
with Found i -> i
-let array_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b array): 'a =
- let i = ref 0 in
- Array.fold_left
- (fun acc x ->
+let array_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b array): 'a =
+ let i = ref 0 in
+ Array.fold_left
+ (fun acc x ->
let res = f !i acc x in i := !i + 1; res)
acc arr
@@ -176,25 +176,25 @@ let list_chop_end i l =
if size_prefix < 0 then failwith "list_chop_end"
else list_chop size_prefix l
-let list_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b list): 'a =
- let i = ref 0 in
- List.fold_left
- (fun acc x ->
+let list_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b list): 'a =
+ let i = ref 0 in
+ List.fold_left
+ (fun acc x ->
let res = f !i acc x in i := !i + 1; res)
acc arr
-let list_filteri (f: int -> 'a -> bool) (l:'a list):'a list =
- let i = ref 0 in
+let list_filteri (f: int -> 'a -> bool) (l:'a list):'a list =
+ let i = ref 0 in
List.filter (fun x -> let res = f !i x in i := !i + 1; res) l
(** Iteration module *)
-module For =
+module For =
struct
let rec map i j (f: int -> 'a) = if i>j then [] else f i :: (map (i+1) j f)
- let rec foldup i j (f: 'a -> int -> 'a) acc =
+ let rec foldup i j (f: 'a -> int -> 'a) acc =
if i>j then acc else let newacc = f acc i in foldup (i+1) j f newacc
- let rec folddown i j (f: 'a -> int -> 'a) acc =
+ let rec folddown i j (f: 'a -> int -> 'a) acc =
if i>j then acc else let newacc = f acc j in folddown i (j-1) f newacc
let fold i j = if i<j then foldup i j else folddown i j
end
@@ -231,7 +231,7 @@ let prlinked x =
| Unlinked -> Printf.sprintf "Unlinked"
| Funres -> Printf.sprintf "Funres"
-let linkmonad f lnkvar =
+let linkmonad f lnkvar =
match lnkvar with
| Linked i -> Linked (f i)
| Unlinked -> Unlinked
@@ -242,7 +242,7 @@ let linklift lnkvar i = linkmonad (fun x -> x+i) lnkvar
(* This map is used to deal with debruijn linked indices. *)
module Link = Map.Make (struct type t = int let compare = Pervasives.compare end)
-let pr_links l =
+let pr_links l =
Printf.printf "links:\n";
Link.iter (fun k e -> Printf.printf "%d : %s\n" k (prlinked e)) l;
Printf.printf "_____________\n"
@@ -255,16 +255,16 @@ type 'a merged_arg =
| Arg_linked of 'a
| Arg_funres
-(** Information about graph merging of two inductives.
+(** Information about graph merging of two inductives.
All rel_decl list are IN REVERSE ORDER (ie well suited for compose) *)
type merge_infos =
{
ident:identifier; (** new inductive name *)
mib1: mutual_inductive_body;
- oib1: one_inductive_body;
+ oib1: one_inductive_body;
mib2: mutual_inductive_body;
- oib2: one_inductive_body;
+ oib2: one_inductive_body;
(** Array of links of the first inductive (should be all stable) *)
lnk1: int merged_arg array;
@@ -275,24 +275,24 @@ type merge_infos =
(** rec params which remain rec param (ie not linked) *)
recprms1: rel_declaration list;
recprms2: rel_declaration list;
- nrecprms1: int;
+ nrecprms1: int;
nrecprms2: int;
(** rec parms which became non parm (either linked to something
or because after a rec parm that became non parm) *)
- otherprms1: rel_declaration list;
- otherprms2: rel_declaration list;
- notherprms1:int;
+ otherprms1: rel_declaration list;
+ otherprms2: rel_declaration list;
+ notherprms1:int;
notherprms2:int;
(** args which remain args in merge *)
- args1:rel_declaration list;
+ args1:rel_declaration list;
args2:rel_declaration list;
nargs1:int;
nargs2:int;
(** functional result args *)
- funresprms1: rel_declaration list;
+ funresprms1: rel_declaration list;
funresprms2: rel_declaration list;
nfunresprms1:int;
nfunresprms2:int;
@@ -301,7 +301,7 @@ type merge_infos =
let pr_merginfo x =
let i,s=
- match x with
+ match x with
| Prm_linked i -> Some i,"Prm_linked"
| Arg_linked i -> Some i,"Arg_linked"
| Prm_stable i -> Some i,"Prm_stable"
@@ -317,7 +317,7 @@ let isPrm_stable x = match x with Prm_stable _ -> true | _ -> false
(* ?? prm_linked?? *)
let isArg_stable x = match x with Arg_stable _ | Prm_arg _ -> true | _ -> false
-let is_stable x =
+let is_stable x =
match x with Arg_stable _ | Prm_stable _ | Prm_arg _ -> true | _ -> false
let isArg_funres x = match x with Arg_funres -> true | _ -> false
@@ -332,22 +332,22 @@ let filter_shift_stable (lnk:int merged_arg array) (l:'a list): 'a list =
of int as several vars may be linked to the same var. *)
let revlinked lnk =
For.fold 0 (Array.length lnk - 1)
- (fun acc k ->
- match lnk.(k) with
- | Unlinked | Funres -> acc
- | Linked i ->
+ (fun acc k ->
+ match lnk.(k) with
+ | Unlinked | Funres -> acc
+ | Linked i ->
let old = try Link.find i acc with Not_found -> [] in
Link.add i (k::old) acc)
Link.empty
-let array_switch arr i j =
+let array_switch arr i j =
let aux = arr.(j) in arr.(j) <- arr.(i); arr.(i) <- aux
let filter_shift_stable_right (lnk:int merged_arg array) (l:'a list): 'a list =
let larr = Array.of_list l in
let _ =
Array.iteri
- (fun j x ->
+ (fun j x ->
match x with
| Prm_linked i -> array_switch larr i j
| Arg_linked i -> array_switch larr i j
@@ -392,7 +392,7 @@ let build_raw_params prms_decl avoid =
let ids_of_rawlist avoid rawl =
List.fold_left Idset.union avoid (List.map ids_of_rawterm rawl)
-
+
(** {1 Merging function graphs} *)
@@ -402,7 +402,7 @@ let ids_of_rawlist avoid rawl =
remain uniform when linked by [lnk]. All parameters are
considered, ie we take parameters of the first inductive body of
[mib1] and [mib2].
-
+
Explanation: The two inductives have parameters, some of the first
are recursively uniform, some of the last are functional result of
the functional graph.
@@ -418,14 +418,14 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array
let linked_targets = revlinked lnk2 in
let is_param_of_mib1 x = x < mib1.mind_nparams_rec in
let is_param_of_mib2 x = x < mib2.mind_nparams_rec in
- let is_targetted_by_non_recparam_lnk1 i =
- try
- let targets = Link.find i linked_targets in
+ let is_targetted_by_non_recparam_lnk1 i =
+ try
+ let targets = Link.find i linked_targets in
List.exists (fun x -> not (is_param_of_mib2 x)) targets
with Not_found -> false in
- let mlnk1 =
+ let mlnk1 =
Array.mapi
- (fun i lkv ->
+ (fun i lkv ->
let isprm = is_param_of_mib1 i in
let prmlost = is_targetted_by_non_recparam_lnk1 i in
match isprm , prmlost, lnk1.(i) with
@@ -435,13 +435,13 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array
| _ , _ , Funres -> assert false (* fun res cannot be a rec param or lost *)
| false , _ , _ -> Arg_stable i) (* Args of lnk1 are not linked *)
lnk1 in
- let mlnk2 =
+ let mlnk2 =
Array.mapi
- (fun i lkv ->
+ (fun i lkv ->
(* Is this correct if some param of ind2 is lost? *)
let isprm = is_param_of_mib2 i in
match isprm , lnk2.(i) with
- | true , Linked j when not (is_param_of_mib1 j) ->
+ | true , Linked j when not (is_param_of_mib1 j) ->
Prm_arg j (* recparam becoming ordinary *)
| true , Linked j -> Prm_linked j (*recparam linked to recparam*)
| true , Unlinked -> Prm_stable i (* recparam remains recparam*)
@@ -456,9 +456,9 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array
(* count params remaining params *)
let n_params1 = array_prfx mlnk1 (fun i x -> not (isPrm_stable x)) in
let n_params2 = array_prfx mlnk2 (fun i x -> not (isPrm_stable x)) in
- let bldprms arity_ctxt mlnk =
+ let bldprms arity_ctxt mlnk =
list_fold_lefti
- (fun i (acc1,acc2,acc3,acc4) x ->
+ (fun i (acc1,acc2,acc3,acc4) x ->
prstr (pr_merginfo mlnk.(i));prstr "\n";
match mlnk.(i) with
| Prm_stable _ -> x::acc1 , acc2 , acc3, acc4
@@ -467,19 +467,19 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array
| Arg_funres -> acc1 , acc2 , acc3, x::acc4
| _ -> acc1 , acc2 , acc3, acc4)
([],[],[],[]) arity_ctxt in
-(* let arity_ctxt2 =
- build_raw_params oib2.mind_arity_ctxt
+(* let arity_ctxt2 =
+ build_raw_params oib2.mind_arity_ctxt
(Idset.elements (ids_of_rawterm oib1.mind_arity_ctxt)) in*)
let recprms1,otherprms1,args1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in
let _ = prstr "\n\n\n" in
let recprms2,otherprms2,args2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in
let _ = prstr "\notherprms1:\n" in
- let _ =
- List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n")
+ let _ =
+ List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n")
otherprms1 in
let _ = prstr "\notherprms2:\n" in
- let _ =
- List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n")
+ let _ =
+ List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n")
otherprms2 in
{
ident=id;
@@ -514,38 +514,38 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array
exception NoMerge
-let rec merge_app c1 c2 id1 id2 shift filter_shift_stable =
+let rec merge_app c1 c2 id1 id2 shift filter_shift_stable =
let lnk = Array.append shift.lnk1 shift.lnk2 in
match c1 , c2 with
- | RApp(_,f1, arr1), RApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 ->
+ | RApp(_,f1, arr1), RApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 ->
let _ = prstr "\nICI1!\n";Pp.flush_all() in
let args = filter_shift_stable lnk (arr1 @ arr2) in
RApp (dummy_loc,RVar (dummy_loc,shift.ident) , args)
| RApp(_,f1, arr1), RApp(_,f2,arr2) -> raise NoMerge
- | RLetIn(_,nme,bdy,trm) , _ ->
- let _ = prstr "\nICI2!\n";Pp.flush_all() in
+ | RLetIn(_,nme,bdy,trm) , _ ->
+ let _ = prstr "\nICI2!\n";Pp.flush_all() in
let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in
RLetIn(dummy_loc,nme,bdy,newtrm)
- | _, RLetIn(_,nme,bdy,trm) ->
- let _ = prstr "\nICI3!\n";Pp.flush_all() in
+ | _, RLetIn(_,nme,bdy,trm) ->
+ let _ = prstr "\nICI3!\n";Pp.flush_all() in
let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in
RLetIn(dummy_loc,nme,bdy,newtrm)
| _ -> let _ = prstr "\nICI4!\n";Pp.flush_all() in
raise NoMerge
-let rec merge_app_unsafe c1 c2 shift filter_shift_stable =
+let rec merge_app_unsafe c1 c2 shift filter_shift_stable =
let lnk = Array.append shift.lnk1 shift.lnk2 in
match c1 , c2 with
- | RApp(_,f1, arr1), RApp(_,f2,arr2) ->
+ | RApp(_,f1, arr1), RApp(_,f2,arr2) ->
let args = filter_shift_stable lnk (arr1 @ arr2) in
RApp (dummy_loc,RVar(dummy_loc,shift.ident) , args)
(* FIXME: what if the function appears in the body of the let? *)
- | RLetIn(_,nme,bdy,trm) , _ ->
- let _ = prstr "\nICI2 '!\n";Pp.flush_all() in
+ | RLetIn(_,nme,bdy,trm) , _ ->
+ let _ = prstr "\nICI2 '!\n";Pp.flush_all() in
let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in
RLetIn(dummy_loc,nme,bdy,newtrm)
- | _, RLetIn(_,nme,bdy,trm) ->
- let _ = prstr "\nICI3 '!\n";Pp.flush_all() in
+ | _, RLetIn(_,nme,bdy,trm) ->
+ let _ = prstr "\nICI3 '!\n";Pp.flush_all() in
let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in
RLetIn(dummy_loc,nme,bdy,newtrm)
| _ -> let _ = prstr "\nICI4 '!\n";Pp.flush_all() in raise NoMerge
@@ -555,33 +555,33 @@ let rec merge_app_unsafe c1 c2 shift filter_shift_stable =
(* Heuristic when merging two lists of hypothesis: merge every rec
calls of branch 1 with all rec calls of branch 2. *)
(* TODO: reecrire cette heuristique (jusqu'a merge_types) *)
-let rec merge_rec_hyps shift accrec
- (ltyp:(Names.name * rawconstr option * rawconstr option) list)
+let rec merge_rec_hyps shift accrec
+ (ltyp:(Names.name * rawconstr option * rawconstr option) list)
filter_shift_stable : (Names.name * rawconstr option * rawconstr option) list =
- let mergeonehyp t reldecl =
+ let mergeonehyp t reldecl =
match reldecl with
- | (nme,x,Some (RApp(_,i,args) as ind))
+ | (nme,x,Some (RApp(_,i,args) as ind))
-> nme,x, Some (merge_app_unsafe ind t shift filter_shift_stable)
| (nme,Some _,None) -> error "letins with recursive calls not treated yet"
- | (nme,None,Some _) -> assert false
+ | (nme,None,Some _) -> assert false
| (nme,None,None) | (nme,Some _,Some _) -> assert false in
match ltyp with
| [] -> []
- | (nme,None,Some (RApp(_,f, largs) as t)) :: lt when isVarf ind2name f ->
+ | (nme,None,Some (RApp(_,f, largs) as t)) :: lt when isVarf ind2name f ->
let rechyps = List.map (mergeonehyp t) accrec in
rechyps @ merge_rec_hyps shift accrec lt filter_shift_stable
| e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable
-let rec build_suppl_reccall (accrec:(name * rawconstr) list) concl2 shift =
+let rec build_suppl_reccall (accrec:(name * rawconstr) list) concl2 shift =
List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec
-let find_app (nme:identifier) ltyp =
+let find_app (nme:identifier) ltyp =
try
ignore
(List.map
- (fun x ->
+ (fun x ->
match x with
| _,None,Some (RApp(_,f,_)) when isVarf nme f -> raise (Found 0)
| _ -> ())
@@ -589,17 +589,17 @@ let find_app (nme:identifier) ltyp =
false
with Found _ -> true
-let prnt_prod_or_letin nm letbdy typ =
+let prnt_prod_or_letin nm letbdy typ =
match letbdy , typ with
| Some lbdy , None -> prNamedRConstr ("(letin) " ^ string_of_name nm) lbdy
| None , Some tp -> prNamedRConstr (string_of_name nm) tp
| _ , _ -> assert false
-
-let rec merge_types shift accrec1
+
+let rec merge_types shift accrec1
(ltyp1:(name * rawconstr option * rawconstr option) list)
(concl1:rawconstr) (ltyp2:(name * rawconstr option * rawconstr option) list) concl2
- : (name * rawconstr option * rawconstr option) list * rawconstr =
+ : (name * rawconstr option * rawconstr option) list * rawconstr =
let _ = prstr "MERGE_TYPES\n" in
let _ = prstr "ltyp 1 : " in
let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp1 in
@@ -608,20 +608,20 @@ let rec merge_types shift accrec1
let _ = prstr "\n" in
let res =
match ltyp1 with
- | [] ->
+ | [] ->
let isrec1 = (accrec1<>[]) in
let isrec2 = find_app ind2name ltyp2 in
let rechyps =
- if isrec1 && isrec2
+ if isrec1 && isrec2
then (* merge_rec_hyps shift accrec1 ltyp2 filter_shift_stable *)
- merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2
+ merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2
filter_shift_stable_right
@ merge_rec_hyps shift accrec1 [name_of_string "concl2",None, Some concl2]
filter_shift_stable
- else if isrec1
+ else if isrec1
(* if rec calls in accrec1 and not in ltyp2, add one to ltyp2 *)
- then
- merge_rec_hyps shift accrec1
+ then
+ merge_rec_hyps shift accrec1
(ltyp2@[name_of_string "concl2",None,Some concl2]) filter_shift_stable
else if isrec2
then merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2
@@ -634,22 +634,22 @@ let rec merge_types shift accrec1
let _ = prstr " with " in
let _ = prNamedRConstr "concl2" concl2 in
let _ = prstr "\n" in
- let concl =
+ let concl =
merge_app concl1 concl2 ind1name ind2name shift filter_shift_stable in
let _ = prstr "FIN " in
let _ = prNamedRConstr "concl" concl in
let _ = prstr "\n" in
rechyps , concl
- | (nme,None, Some t1)as e ::lt1 ->
+ | (nme,None, Some t1)as e ::lt1 ->
(match t1 with
- | RApp(_,f,carr) when isVarf ind1name f ->
- merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2
- | _ ->
+ | RApp(_,f,carr) when isVarf ind1name f ->
+ merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2
+ | _ ->
let recres, recconcl2 =
merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in
- ((nme,None,Some t1) :: recres) , recconcl2)
- | (nme,Some bd, None) ::lt1 ->
+ ((nme,None,Some t1) :: recres) , recconcl2)
+ | (nme,Some bd, None) ::lt1 ->
(* FIXME: what if ind1name appears in bd? *)
let recres, recconcl2 =
merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in
@@ -666,10 +666,10 @@ let rec merge_types shift accrec1
let build_link_map_aux (allargs1:identifier array) (allargs2:identifier array)
(lnk:int merged_arg array) =
array_fold_lefti
- (fun i acc e ->
+ (fun i acc e ->
if i = Array.length lnk - 1 then acc (* functional arg, not in allargs *)
- else
- match e with
+ else
+ match e with
| Prm_linked j | Arg_linked j -> Idmap.add allargs2.(i) allargs1.(j) acc
| _ -> acc)
Idmap.empty lnk
@@ -696,10 +696,10 @@ let build_link_map allargs1 allargs2 lnk =
forall recparams1 (recparams2 without linked params),
forall ordparams1 (ordparams2 without linked params),
- H1a' -> H2a' -> ... -> H2a' -> H2b'(shifted) -> ...
+ H1a' -> H2a' -> ... -> H2a' -> H2b'(shifted) -> ...
-> (newI x1 ... z1 x2 y2 ...z2 without linked params)
- where Hix' have been adapted, ie:
+ where Hix' have been adapted, ie:
- linked vars have been changed,
- rec calls to I1 and I2 have been replaced by rec calls to
newI. More precisely calls to I1 and I2 have been merge by an
@@ -715,26 +715,26 @@ let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr)
(* FIXME: les noms des parametres corerspondent en principe au
parametres du niveau mib, mais il faudrait s'en assurer *)
(* shift.nfunresprmsx last args are functional result *)
- let nargs1 =
+ let nargs1 =
shift.mib1.mind_nparams + shift.oib1.mind_nrealargs - shift.nfunresprms1 in
let nargs2 =
shift.mib2.mind_nparams + shift.oib2.mind_nrealargs - shift.nfunresprms2 in
let allargs1,rest1 = raw_decompose_prod_or_letin_n nargs1 typcstr1 in
- let allargs2,rest2 = raw_decompose_prod_or_letin_n nargs2 typcstr2 in
+ let allargs2,rest2 = raw_decompose_prod_or_letin_n nargs2 typcstr2 in
(* Build map of linked args of [typcstr2], and apply it to [typcstr2]. *)
let linked_map = build_link_map allargs1 allargs2 shift.lnk2 in
let rest2 = change_vars linked_map rest2 in
let hyps1,concl1 = raw_decompose_prod_or_letin rest1 in
let hyps2,concl2' = raw_decompose_prod_or_letin rest2 in
- let ltyp,concl2 =
+ let ltyp,concl2 =
merge_types shift [] (List.rev hyps1) concl1 (List.rev hyps2) concl2' in
let _ = prNamedRLDecl "ltyp result:" ltyp in
let typ = raw_compose_prod_or_letin concl2 (List.rev ltyp) in
- let revargs1 =
+ let revargs1 =
list_filteri (fun i _ -> isArg_stable shift.lnk1.(i)) (List.rev allargs1) in
let _ = prNamedRLDecl "ltyp allargs1" allargs1 in
let _ = prNamedRLDecl "ltyp revargs1" revargs1 in
- let revargs2 =
+ let revargs2 =
list_filteri (fun i _ -> isArg_stable shift.lnk2.(i)) (List.rev allargs2) in
let _ = prNamedRLDecl "ltyp allargs2" allargs2 in
let _ = prNamedRLDecl "ltyp revargs2" revargs2 in
@@ -746,7 +746,7 @@ let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr)
(** constructor numbering *)
let fresh_cstror_suffix , cstror_suffix_init =
let cstror_num = ref 0 in
- (fun () ->
+ (fun () ->
let res = string_of_int !cstror_num in
cstror_num := !cstror_num + 1;
res) ,
@@ -755,7 +755,7 @@ let fresh_cstror_suffix , cstror_suffix_init =
(** [merge_constructor_id id1 id2 shift] returns the identifier of the
new constructor from the id of the two merged constructor and
the merging info. *)
-let merge_constructor_id id1 id2 shift:identifier =
+let merge_constructor_id id1 id2 shift:identifier =
let id = string_of_id shift.ident ^ "_" ^ fresh_cstror_suffix () in
next_ident_fresh (id_of_string id)
@@ -765,43 +765,43 @@ let merge_constructor_id id1 id2 shift:identifier =
constructor [(name*type)]. These are translated to rawterms
first, each of them having distinct var names. *)
let rec merge_constructors (shift:merge_infos) (avoid:Idset.t)
- (typcstr1:(identifier * rawconstr) list)
+ (typcstr1:(identifier * rawconstr) list)
(typcstr2:(identifier * rawconstr) list) : (identifier * rawconstr) list =
- List.flatten
+ List.flatten
(List.map
- (fun (id1,rawtyp1) ->
+ (fun (id1,rawtyp1) ->
List.map
- (fun (id2,rawtyp2) ->
+ (fun (id2,rawtyp2) ->
let typ = merge_one_constructor shift rawtyp1 rawtyp2 in
let newcstror_id = merge_constructor_id id1 id2 shift in
let _ = prstr "\n**************\n" in
newcstror_id , typ)
typcstr2)
typcstr1)
-
+
(** [merge_inductive_body lnk shift avoid oib1 oib2] merges two
inductive bodies [oib1] and [oib2], linking with [lnk], params
info in [shift], avoiding identifiers in [avoid]. *)
let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body)
(oib2:one_inductive_body) =
(* building rawconstr type of constructors *)
- let mkrawcor nme avoid typ =
+ let mkrawcor nme avoid typ =
(* first replace rel 1 by a varname *)
let substindtyp = substitterm 0 (mkRel 1) (mkVar nme) typ in
Detyping.detype false (Idset.elements avoid) [] substindtyp in
- let lcstr1: rawconstr list =
+ let lcstr1: rawconstr list =
Array.to_list (Array.map (mkrawcor ind1name avoid) oib1.mind_user_lc) in
(* add to avoid all indentifiers of lcstr1 *)
let avoid2 = Idset.union avoid (ids_of_rawlist avoid lcstr1) in
- let lcstr2 =
+ let lcstr2 =
Array.to_list (Array.map (mkrawcor ind2name avoid2) oib2.mind_user_lc) in
let avoid3 = Idset.union avoid (ids_of_rawlist avoid lcstr2) in
- let params1 =
- try fst (raw_decompose_prod_n shift.nrecprms1 (List.hd lcstr1))
+ let params1 =
+ try fst (raw_decompose_prod_n shift.nrecprms1 (List.hd lcstr1))
with _ -> [] in
- let params2 =
- try fst (raw_decompose_prod_n shift.nrecprms2 (List.hd lcstr2))
+ let params2 =
+ try fst (raw_decompose_prod_n shift.nrecprms2 (List.hd lcstr2))
with _ -> [] in
let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in
@@ -819,17 +819,17 @@ let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body)
let rec merge_mutual_inductive_body
(mib1:mutual_inductive_body) (mib2:mutual_inductive_body) (shift:merge_infos) =
(* Mutual not treated, we take first ind body of each. *)
- merge_inductive_body shift Idset.empty mib1.mind_packets.(0) mib2.mind_packets.(0)
+ merge_inductive_body shift Idset.empty mib1.mind_packets.(0) mib2.mind_packets.(0)
+
-
let rawterm_to_constr_expr x = (* build a constr_expr from a rawconstr *)
Flags.with_option Flags.raw_print (Constrextern.extern_rawtype Idset.empty) x
-let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) =
+let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) =
let params = prms2 @ prms1 in
let resparams =
List.fold_left
- (fun acc (nme,tp) ->
+ (fun acc (nme,tp) ->
let _ = prstr "param :" in
let _ = prNamedRConstr (string_of_name nme) tp in
let _ = prstr " ; " in
@@ -837,18 +837,18 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) =
LocalRawAssum ([(dummy_loc,nme)], Topconstr.default_binder_kind, typ) :: acc)
[] params in
let concl = Constrextern.extern_constr false (Global.env()) concl in
- let arity,_ =
- List.fold_left
- (fun (acc,env) (nm,_,c) ->
+ let arity,_ =
+ List.fold_left
+ (fun (acc,env) (nm,_,c) ->
let typ = Constrextern.extern_constr false env c in
let newenv = Environ.push_rel (nm,None,c) env in
CProdN (dummy_loc, [[(dummy_loc,nm)],Topconstr.default_binder_kind,typ] , acc) , newenv)
(concl,Global.env())
- (shift.funresprms2 @ shift.funresprms1
- @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in
+ (shift.funresprms2 @ shift.funresprms1
+ @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in
resparams,arity
-
+
(** [rawterm_list_to_inductive_expr ident rawlist] returns the
induct_expr corresponding to the the list of constructor types
@@ -859,17 +859,17 @@ let rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift
let lident = dummy_loc, shift.ident in
let bindlist , cstr_expr = (* params , arities *)
merge_rec_params_and_arity prms1 prms2 shift mkSet in
- let lcstor_expr : (bool * (lident * constr_expr)) list =
+ let lcstor_expr : (bool * (lident * constr_expr)) list =
List.map (* zeta_normalize t ? *)
(fun (id,t) -> false, ((dummy_loc,id),rawterm_to_constr_expr t))
- rawlist in
+ rawlist in
lident , bindlist , Some cstr_expr , lcstor_expr
let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) =
match rdecl with
- | (nme,None,t) ->
+ | (nme,None,t) ->
let traw = Detyping.detype false [] [] t in
RProd (dummy_loc,nme,Explicit,traw,t2)
| (_,Some _,_) -> assert false
@@ -879,7 +879,7 @@ let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) =
let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) =
match rdecl with
- | (nme,None,t) ->
+ | (nme,None,t) ->
let traw = Detyping.detype false [] [] t in
RProd (dummy_loc,nme,Explicit,traw,t2)
| (_,Some _,_) -> assert false
@@ -888,7 +888,7 @@ let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) =
(** [merge_inductive ind1 ind2 lnk] merges two graphs, linking
variables specified in [lnk]. Graphs are not supposed to be mutual
inductives for the moment. *)
-let merge_inductive (ind1: inductive) (ind2: inductive)
+let merge_inductive (ind1: inductive) (ind2: inductive)
(lnk1: linked_var array) (lnk2: linked_var array) id =
let env = Global.env() in
let mib1,_ = Inductive.lookup_mind_specif env ind1 in
@@ -898,14 +898,14 @@ let merge_inductive (ind1: inductive) (ind2: inductive)
let shift_prm = shift_linked_params mib1 mib2 lnk1 lnk2 id in
let prms1,prms2, rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in
let _ = prstr "\nrawlist : " in
- let _ =
+ let _ =
List.iter (fun (nm,tp) -> prNamedRConstr (string_of_id nm) tp;prstr "\n") rawlist in
let _ = prstr "\nend rawlist\n" in
(* FIX: retransformer en constr ici
- let shift_prm =
+ let shift_prm =
{ shift_prm with
recprms1=prms1;
- recprms1=prms1;
+ recprms1=prms1;
} in *)
let indexpr = rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in
(* Declare inductive *)
@@ -927,28 +927,28 @@ let find_Function_infos_safe (id:identifier): Indfun_common.function_info =
[ind1] and [ind2]. identifiers occuring in both arrays [args1] and
[args2] are considered linked (i.e. are the same variable) in the
new graph.
-
+
Warning: For the moment, repetitions of an id in [args1] or
[args2] are not supported. *)
-let merge (id1:identifier) (id2:identifier) (args1:identifier array)
+let merge (id1:identifier) (id2:identifier) (args1:identifier array)
(args2:identifier array) id : unit =
let finfo1 = find_Function_infos_safe id1 in
let finfo2 = find_Function_infos_safe id2 in
(* FIXME? args1 are supposed unlinked. mergescheme (G x x) ?? *)
(* We add one arg (functional arg of the graph) *)
let lnk1 = Array.make (Array.length args1 + 1) Unlinked in
- let lnk2' = (* args2 may be linked to args1 members. FIXME: same
+ let lnk2' = (* args2 may be linked to args1 members. FIXME: same
as above: vars may be linked inside args2?? *)
Array.mapi
- (fun i c ->
+ (fun i c ->
match array_find args1 (fun i x -> x=c) with
| Some j -> Linked j
- | None -> Unlinked)
+ | None -> Unlinked)
args2 in
(* We add one arg (functional arg of the graph) *)
let lnk2 = Array.append lnk2' (Array.make 1 Unlinked) in
(* setting functional results *)
- let _ = lnk1.(Array.length lnk1 - 1) <- Funres in
+ let _ = lnk1.(Array.length lnk1 - 1) <- Funres in
let _ = lnk2.(Array.length lnk2 - 1) <- Funres in
merge_inductive finfo1.graph_ind finfo2.graph_ind lnk1 lnk2 id
@@ -968,12 +968,12 @@ let remove_last_n_arg n c =
(* [funify_branches relinfo nfuns branch] returns the branch [branch]
of the relinfo [relinfo] modified to fit in a functional principle.
- Things to do:
+ Things to do:
- remove indargs from rel applications
- replace *variables only* corresponding to function (recursive)
results by the actual function application. *)
-let funify_branches relinfo nfuns branch =
- let mut_induct, induct =
+let funify_branches relinfo nfuns branch =
+ let mut_induct, induct =
match relinfo.indref with
| None -> assert false
| Some (IndRef ((mutual_ind,i) as ind)) -> mutual_ind,ind
@@ -987,13 +987,13 @@ let funify_branches relinfo nfuns branch =
match kind_of_term c with
| Ind((u,i)) | Construct((u,_),i) -> i
| _ -> assert false in
- let _is_pred c shift =
+ let _is_pred c shift =
match kind_of_term c with
| Rel i -> let reali = i-shift in (reali>=0 && reali<relinfo.nbranches)
| _ -> false in
(* FIXME: *)
(Anonymous,Some mkProp,mkProp)
-
+
let relprinctype_to_funprinctype relprinctype nfuns =
let relinfo = compute_elim_sig relprinctype in
@@ -1010,7 +1010,7 @@ let relprinctype_to_funprinctype relprinctype nfuns =
args = remove_n_fst_list nfuns relinfo_noindarg.args;
concl = popn nfuns relinfo_noindarg.concl
} in
- let new_branches =
+ let new_branches =
List.map (funify_branches relinfo_argsok nfuns) relinfo_argsok.branches in
let relinfo_branches = { relinfo_argsok with branches = new_branches } in
relinfo_branches
@@ -1026,7 +1026,7 @@ let relprinctype_to_funprinctype relprinctype nfuns =
url = "citeseer.ist.psu.edu/bundy93rippling.html" }
*)
-(*
+(*
*** Local Variables: ***
*** compile-command: "make -C ../.. plugins/funind/merge.cmo" ***
*** indent-tabs-mode: nil ***
diff --git a/plugins/funind/rawterm_to_relation.ml b/plugins/funind/rawterm_to_relation.ml
index 7e9ba3f8ea..4bd0385caa 100644
--- a/plugins/funind/rawterm_to_relation.ml
+++ b/plugins/funind/rawterm_to_relation.ml
@@ -1,6 +1,6 @@
open Printer
open Pp
-open Names
+open Names
open Term
open Rawterm
open Libnames
@@ -8,76 +8,76 @@ open Indfun_common
open Util
open Rawtermops
-let observe strm =
+let observe strm =
if do_observe ()
- then Pp.msgnl strm
+ then Pp.msgnl strm
else ()
-let observennl strm =
+let observennl strm =
if do_observe ()
- then Pp.msg strm
+ then Pp.msg strm
else ()
type binder_type =
- | Lambda of name
- | Prod of name
+ | Lambda of name
+ | Prod of name
| LetIn of name
type raw_context = (binder_type*rawconstr) list
-(*
- compose_raw_context [(bt_1,n_1,t_1);......] rt returns
- b_1(n_1,t_1,.....,bn(n_k,t_k,rt)) where the b_i's are the
+(*
+ compose_raw_context [(bt_1,n_1,t_1);......] rt returns
+ b_1(n_1,t_1,.....,bn(n_k,t_k,rt)) where the b_i's are the
binders corresponding to the bt_i's
*)
-let compose_raw_context =
+let compose_raw_context =
let compose_binder (bt,t) acc =
- match bt with
+ match bt with
| Lambda n -> mkRLambda(n,t,acc)
| Prod n -> mkRProd(n,t,acc)
| LetIn n -> mkRLetIn(n,t,acc)
in
List.fold_right compose_binder
-
-(*
+
+(*
The main part deals with building a list of raw constructor expressions
- from the rhs of a fixpoint equation.
+ from the rhs of a fixpoint equation.
*)
-type 'a build_entry_pre_return =
+type 'a build_entry_pre_return =
{
context : raw_context; (* the binding context of the result *)
value : 'a; (* The value *)
}
-type 'a build_entry_return =
+type 'a build_entry_return =
{
- result : 'a build_entry_pre_return list;
+ result : 'a build_entry_pre_return list;
to_avoid : identifier list
}
(*
- [combine_results combine_fun res1 res2] combine two results [res1] and [res2]
+ [combine_results combine_fun res1 res2] combine two results [res1] and [res2]
w.r.t. [combine_fun].
- Informally, both [res1] and [res2] are lists of "constructors" [res1_1;...]
- and [res2_1,....] and we need to produce
+ Informally, both [res1] and [res2] are lists of "constructors" [res1_1;...]
+ and [res2_1,....] and we need to produce
[combine_fun res1_1 res2_1;combine_fun res1_1 res2_2;........]
*)
-let combine_results
- (combine_fun : 'a build_entry_pre_return -> 'b build_entry_pre_return ->
+let combine_results
+ (combine_fun : 'a build_entry_pre_return -> 'b build_entry_pre_return ->
'c build_entry_pre_return
- )
- (res1: 'a build_entry_return)
- (res2 : 'b build_entry_return)
- : 'c build_entry_return
- =
- let pre_result = List.map
+ )
+ (res1: 'a build_entry_return)
+ (res2 : 'b build_entry_return)
+ : 'c build_entry_return
+ =
+ let pre_result = List.map
( fun res1 -> (* for each result in arg_res *)
- List.map (* we add it in each args_res *)
- (fun res2 ->
+ List.map (* we add it in each args_res *)
+ (fun res2 ->
combine_fun res1 res2
)
res2.result
@@ -85,107 +85,107 @@ let combine_results
res1.result
in (* and then we flatten the map *)
{
- result = List.concat pre_result;
+ result = List.concat pre_result;
to_avoid = list_union res1.to_avoid res2.to_avoid
}
-
-(*
- The combination function for an argument with a list of argument
+
+(*
+ The combination function for an argument with a list of argument
*)
-let combine_args arg args =
+let combine_args arg args =
{
- context = arg.context@args.context;
- (* Note that the binding context of [arg] MUST be placed before the one of
- [args] in order to preserve possible type dependencies
+ context = arg.context@args.context;
+ (* Note that the binding context of [arg] MUST be placed before the one of
+ [args] in order to preserve possible type dependencies
*)
value = arg.value::args.value;
}
-let ids_of_binder = function
+let ids_of_binder = function
| LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> []
| LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> [id]
-let rec change_vars_in_binder mapping = function
+let rec change_vars_in_binder mapping = function
[] -> []
| (bt,t)::l ->
- let new_mapping = List.fold_right Idmap.remove (ids_of_binder bt) mapping in
+ let new_mapping = List.fold_right Idmap.remove (ids_of_binder bt) mapping in
(bt,change_vars mapping t)::
(if idmap_is_empty new_mapping
- then l
+ then l
else change_vars_in_binder new_mapping l
)
let rec replace_var_by_term_in_binder x_id term = function
| [] -> []
- | (bt,t)::l ->
+ | (bt,t)::l ->
(bt,replace_var_by_term x_id term t)::
- if List.mem x_id (ids_of_binder bt)
+ if List.mem x_id (ids_of_binder bt)
then l
else replace_var_by_term_in_binder x_id term l
let add_bt_names bt = List.append (ids_of_binder bt)
-let apply_args ctxt body args =
- let need_convert_id avoid id =
- List.exists (is_free_in id) args || List.mem id avoid
- in
- let need_convert avoid bt =
+let apply_args ctxt body args =
+ let need_convert_id avoid id =
+ List.exists (is_free_in id) args || List.mem id avoid
+ in
+ let need_convert avoid bt =
List.exists (need_convert_id avoid) (ids_of_binder bt)
in
- let next_name_away (na:name) (mapping: identifier Idmap.t) (avoid: identifier list) =
- match na with
- | Name id when List.mem id avoid ->
- let new_id = Nameops.next_ident_away id avoid in
+ let next_name_away (na:name) (mapping: identifier Idmap.t) (avoid: identifier list) =
+ match na with
+ | Name id when List.mem id avoid ->
+ let new_id = Nameops.next_ident_away id avoid in
Name new_id,Idmap.add id new_id mapping,new_id::avoid
| _ -> na,mapping,avoid
in
- let next_bt_away bt (avoid:identifier list) =
- match bt with
- | LetIn na ->
- let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in
+ let next_bt_away bt (avoid:identifier list) =
+ match bt with
+ | LetIn na ->
+ let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in
LetIn new_na,mapping,new_avoid
- | Prod na ->
- let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in
+ | Prod na ->
+ let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in
Prod new_na,mapping,new_avoid
- | Lambda na ->
- let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in
+ | Lambda na ->
+ let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in
Lambda new_na,mapping,new_avoid
in
- let rec do_apply avoid ctxt body args =
- match ctxt,args with
+ let rec do_apply avoid ctxt body args =
+ match ctxt,args with
| _,[] -> (* No more args *)
(ctxt,body)
| [],_ -> (* no more fun *)
let f,args' = raw_decompose_app body in
(ctxt,mkRApp(f,args'@args))
- | (Lambda Anonymous,t)::ctxt',arg::args' ->
+ | (Lambda Anonymous,t)::ctxt',arg::args' ->
do_apply avoid ctxt' body args'
- | (Lambda (Name id),t)::ctxt',arg::args' ->
- let new_avoid,new_ctxt',new_body,new_id =
- if need_convert_id avoid id
- then
- let new_avoid = id::avoid in
- let new_id = Nameops.next_ident_away id new_avoid in
- let new_avoid' = new_id :: new_avoid in
- let mapping = Idmap.add id new_id Idmap.empty in
- let new_ctxt' = change_vars_in_binder mapping ctxt' in
- let new_body = change_vars mapping body in
+ | (Lambda (Name id),t)::ctxt',arg::args' ->
+ let new_avoid,new_ctxt',new_body,new_id =
+ if need_convert_id avoid id
+ then
+ let new_avoid = id::avoid in
+ let new_id = Nameops.next_ident_away id new_avoid in
+ let new_avoid' = new_id :: new_avoid in
+ let mapping = Idmap.add id new_id Idmap.empty in
+ let new_ctxt' = change_vars_in_binder mapping ctxt' in
+ let new_body = change_vars mapping body in
new_avoid',new_ctxt',new_body,new_id
- else
- id::avoid,ctxt',body,id
+ else
+ id::avoid,ctxt',body,id
in
let new_body = replace_var_by_term new_id arg new_body in
let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in
do_apply avoid new_ctxt' new_body args'
- | (bt,t)::ctxt',_ ->
- let new_avoid,new_ctxt',new_body,new_bt =
- let new_avoid = add_bt_names bt avoid in
- if need_convert avoid bt
- then
- let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in
+ | (bt,t)::ctxt',_ ->
+ let new_avoid,new_ctxt',new_body,new_bt =
+ let new_avoid = add_bt_names bt avoid in
+ if need_convert avoid bt
+ then
+ let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in
(
new_avoid,
change_vars_in_binder mapping ctxt',
@@ -194,93 +194,93 @@ let apply_args ctxt body args =
)
else new_avoid,ctxt',body,bt
in
- let new_ctxt',new_body =
- do_apply new_avoid new_ctxt' new_body args
+ let new_ctxt',new_body =
+ do_apply new_avoid new_ctxt' new_body args
in
(new_bt,t)::new_ctxt',new_body
- in
+ in
do_apply [] ctxt body args
-let combine_app f args =
- let new_ctxt,new_value = apply_args f.context f.value args.value in
- {
- (* Note that the binding context of [args] MUST be placed before the one of
- the applied value in order to preserve possible type dependencies
+let combine_app f args =
+ let new_ctxt,new_value = apply_args f.context f.value args.value in
+ {
+ (* Note that the binding context of [args] MUST be placed before the one of
+ the applied value in order to preserve possible type dependencies
*)
context = args.context@new_ctxt;
value = new_value;
}
-let combine_lam n t b =
+let combine_lam n t b =
{
- context = [];
- value = mkRLambda(n, compose_raw_context t.context t.value,
+ context = [];
+ value = mkRLambda(n, compose_raw_context t.context t.value,
compose_raw_context b.context b.value )
}
-let combine_prod n t b =
+let combine_prod n t b =
{ context = t.context@((Prod n,t.value)::b.context); value = b.value}
-let combine_letin n t b =
+let combine_letin n t b =
{ context = t.context@((LetIn n,t.value)::b.context); value = b.value}
-let mk_result ctxt value avoid =
- {
- result =
+let mk_result ctxt value avoid =
+ {
+ result =
[{context = ctxt;
value = value}]
;
to_avoid = avoid
}
(*************************************************
- Some functions to deal with overlapping patterns
+ Some functions to deal with overlapping patterns
**************************************************)
-let coq_True_ref =
+let coq_True_ref =
lazy (Coqlib.gen_reference "" ["Init";"Logic"] "True")
-let coq_False_ref =
+let coq_False_ref =
lazy (Coqlib.gen_reference "" ["Init";"Logic"] "False")
(*
[make_discr_match_el \[e1,...en\]] builds match e1,...,en with
(the list of expresions on which we will do the matching)
- *)
-let make_discr_match_el =
+ *)
+let make_discr_match_el =
List.map (fun e -> (e,(Anonymous,None)))
(*
- [make_discr_match_brl i \[pat_1,...,pat_n\]] constructs a discrimination pattern matching on the ith expression.
- that is.
+ [make_discr_match_brl i \[pat_1,...,pat_n\]] constructs a discrimination pattern matching on the ith expression.
+ that is.
match ?????? with \\
| pat_1 => False \\
| pat_{i-1} => False \\
| pat_i => True \\
| pat_{i+1} => False \\
- \vdots
+ \vdots
| pat_n => False
end
*)
-let make_discr_match_brl i =
- list_map_i
- (fun j (_,idl,patl,_) ->
+let make_discr_match_brl i =
+ list_map_i
+ (fun j (_,idl,patl,_) ->
if j=i
then (dummy_loc,idl,patl, mkRRef (Lazy.force coq_True_ref))
else (dummy_loc,idl,patl, mkRRef (Lazy.force coq_False_ref))
)
- 0
-(*
- [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff
- brl_{i} is the first branch matched by [el]
+ 0
+(*
+ [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff
+ brl_{i} is the first branch matched by [el]
Used when we want to simulate the coq pattern matching algorithm
*)
-let make_discr_match brl =
- fun el i ->
+let make_discr_match brl =
+ fun el i ->
mkRCases(None,
make_discr_match_el el,
make_discr_match_brl i brl)
@@ -291,32 +291,32 @@ let pr_name = function
(**********************************************************************)
(* functions used to build case expression from lettuple and if ones *)
-(**********************************************************************)
+(**********************************************************************)
-(* [build_constructors_of_type] construct the array of pattern of its inductive argument*)
-let build_constructors_of_type ind' argl =
+(* [build_constructors_of_type] construct the array of pattern of its inductive argument*)
+let build_constructors_of_type ind' argl =
let (mib,ind) = Inductive.lookup_mind_specif (Global.env()) ind' in
let npar = mib.Declarations.mind_nparams in
Array.mapi (fun i _ ->
- let construct = ind',i+1 in
- let constructref = ConstructRef(construct) in
+ let construct = ind',i+1 in
+ let constructref = ConstructRef(construct) in
let _implicit_positions_of_cst =
Impargs.implicits_of_global constructref
in
- let cst_narg =
+ let cst_narg =
Inductiveops.mis_constructor_nargs_env
(Global.env ())
construct
- in
- let argl =
- if argl = []
+ in
+ let argl =
+ if argl = []
then
- Array.to_list
+ Array.to_list
(Array.init (cst_narg - npar) (fun _ -> mkRHole ())
)
else argl
in
- let pat_as_term =
+ let pat_as_term =
mkRApp(mkRRef (ConstructRef(ind',i+1)),argl)
in
cases_pattern_of_rawconstr Anonymous pat_as_term
@@ -324,36 +324,36 @@ let build_constructors_of_type ind' argl =
ind.Declarations.mind_consnames
(* [find_type_of] very naive attempts to discover the type of an if or a letin *)
-let rec find_type_of nb b =
- let f,_ = raw_decompose_app b in
- match f with
- | RRef(_,ref) ->
- begin
- let ind_type =
- match ref with
- | VarRef _ | ConstRef _ ->
- let constr_of_ref = constr_of_global ref in
- let type_of_ref = Typing.type_of (Global.env ()) Evd.empty constr_of_ref in
- let (_,ret_type) = Reduction.dest_prod (Global.env ()) type_of_ref in
- let ret_type,_ = decompose_app ret_type in
- if not (isInd ret_type) then
+let rec find_type_of nb b =
+ let f,_ = raw_decompose_app b in
+ match f with
+ | RRef(_,ref) ->
+ begin
+ let ind_type =
+ match ref with
+ | VarRef _ | ConstRef _ ->
+ let constr_of_ref = constr_of_global ref in
+ let type_of_ref = Typing.type_of (Global.env ()) Evd.empty constr_of_ref in
+ let (_,ret_type) = Reduction.dest_prod (Global.env ()) type_of_ref in
+ let ret_type,_ = decompose_app ret_type in
+ if not (isInd ret_type) then
begin
(* Pp.msgnl (str "not an inductive" ++ pr_lconstr ret_type); *)
raise (Invalid_argument "not an inductive")
end;
destInd ret_type
| IndRef ind -> ind
- | ConstructRef c -> fst c
+ | ConstructRef c -> fst c
in
- let _,ind_type_info = Inductive.lookup_mind_specif (Global.env()) ind_type in
+ let _,ind_type_info = Inductive.lookup_mind_specif (Global.env()) ind_type in
if not (Array.length ind_type_info.Declarations.mind_consnames = nb )
then raise (Invalid_argument "find_type_of : not a valid inductive");
- ind_type
+ ind_type
end
- | RCast(_,b,_) -> find_type_of nb b
+ | RCast(_,b,_) -> find_type_of nb b
| RApp _ -> assert false (* we have decomposed any application via raw_decompose_app *)
| _ -> raise (Invalid_argument "not a ref")
-
+
@@ -363,32 +363,32 @@ let rec find_type_of nb b =
-let raw_push_named (na,raw_value,raw_typ) env =
- match na with
- | Anonymous -> env
- | Name id ->
- let value = Option.map (Pretyping.Default.understand Evd.empty env) raw_value in
- let typ = Pretyping.Default.understand_type Evd.empty env raw_typ in
+let raw_push_named (na,raw_value,raw_typ) env =
+ match na with
+ | Anonymous -> env
+ | Name id ->
+ let value = Option.map (Pretyping.Default.understand Evd.empty env) raw_value in
+ let typ = Pretyping.Default.understand_type Evd.empty env raw_typ in
Environ.push_named (id,value,typ) env
-let add_pat_variables pat typ env : Environ.env =
- let rec add_pat_variables env pat typ : Environ.env =
+let add_pat_variables pat typ env : Environ.env =
+ let rec add_pat_variables env pat typ : Environ.env =
observe (str "new rel env := " ++ Printer.pr_rel_context_of env);
- match pat with
- | PatVar(_,na) -> Environ.push_rel (na,None,typ) env
- | PatCstr(_,c,patl,na) ->
- let Inductiveops.IndType(indf,indargs) =
+ match pat with
+ | PatVar(_,na) -> Environ.push_rel (na,None,typ) env
+ | PatCstr(_,c,patl,na) ->
+ let Inductiveops.IndType(indf,indargs) =
try Inductiveops.find_rectype env Evd.empty typ
- with Not_found -> assert false
+ with Not_found -> assert false
in
- let constructors = Inductiveops.get_constructors env indf in
- let constructor : Inductiveops.constructor_summary = List.find (fun cs -> cs.Inductiveops.cs_cstr = c) (Array.to_list constructors) in
- let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in
- List.fold_left2 add_pat_variables env patl (List.rev cs_args_types)
+ let constructors = Inductiveops.get_constructors env indf in
+ let constructor : Inductiveops.constructor_summary = List.find (fun cs -> cs.Inductiveops.cs_cstr = c) (Array.to_list constructors) in
+ let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in
+ List.fold_left2 add_pat_variables env patl (List.rev cs_args_types)
in
- let new_env = add_pat_variables env pat typ in
+ let new_env = add_pat_variables env pat typ in
let res =
fst (
Sign.fold_rel_context
@@ -426,15 +426,15 @@ let rec pattern_to_term_and_type env typ = function
(Global.env ())
constr
in
- let Inductiveops.IndType(indf,indargs) =
+ let Inductiveops.IndType(indf,indargs) =
try Inductiveops.find_rectype env Evd.empty typ
- with Not_found -> assert false
+ with Not_found -> assert false
in
- let constructors = Inductiveops.get_constructors env indf in
- let constructor = List.find (fun cs -> cs.Inductiveops.cs_cstr = constr) (Array.to_list constructors) in
- let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in
- let _,cstl = Inductiveops.dest_ind_family indf in
- let csta = Array.of_list cstl in
+ let constructors = Inductiveops.get_constructors env indf in
+ let constructor = List.find (fun cs -> cs.Inductiveops.cs_cstr = constr) (Array.to_list constructors) in
+ let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in
+ let _,cstl = Inductiveops.dest_ind_family indf in
+ let csta = Array.of_list cstl in
let implicit_args =
Array.to_list
(Array.init
@@ -449,44 +449,44 @@ let rec pattern_to_term_and_type env typ = function
implicit_args@patl_as_term
)
-(* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return)
- of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the
- corresponding graphs.
+(* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return)
+ of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the
+ corresponding graphs.
The idea to transform a term [t] into a list of constructors [lc] is the following:
- \begin{itemize}
- \item if the term is a binder (bind x, body) then first compute [lc'] the list corresponding
+ \begin{itemize}
+ \item if the term is a binder (bind x, body) then first compute [lc'] the list corresponding
to [body] and add (bind x. _) to each elements of [lc]
- \item if the term has the form (g t1 ... ... tn) where g does not appears in (fnames)
- then compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn],
- then combine those lists and [g] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn],
+ \item if the term has the form (g t1 ... ... tn) where g does not appears in (fnames)
+ then compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn],
+ then combine those lists and [g] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn],
[g c1 ... cn] is an element of [lc]
- \item if the term has the form (f t1 .... tn) where [f] appears in [fnames] then
- compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn],
+ \item if the term has the form (f t1 .... tn) where [f] appears in [fnames] then
+ compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn],
then compute those lists and [f] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn]
create a new variable [res] and [forall res, R_f c1 ... cn res] is in [lc]
\item if the term is a cast just treat its body part
- \item
- if the term is a match, an if or a lettuple then compute the lists corresponding to each branch of the case
+ \item
+ if the term is a match, an if or a lettuple then compute the lists corresponding to each branch of the case
and concatenate them (informally, each branch of a match produces a new constructor)
\end{itemize}
-
- WARNING: The terms constructed here are only USING the rawconstr syntax but are highly bad formed.
- We must wait to have complete all the current calculi to set the recursive calls.
- At this point, each term [f t1 ... tn] (where f appears in [funnames]) is replaced by
- a pseudo term [forall res, res t1 ... tn, res]. A reconstruction phase is done later.
- We in fact not create a constructor list since then end of each constructor has not the expected form
- but only the value of the function
+
+ WARNING: The terms constructed here are only USING the rawconstr syntax but are highly bad formed.
+ We must wait to have complete all the current calculi to set the recursive calls.
+ At this point, each term [f t1 ... tn] (where f appears in [funnames]) is replaced by
+ a pseudo term [forall res, res t1 ... tn, res]. A reconstruction phase is done later.
+ We in fact not create a constructor list since then end of each constructor has not the expected form
+ but only the value of the function
*)
-let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
+let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
observe (str " Entering : " ++ Printer.pr_rawconstr rt);
- match rt with
- | RRef _ | RVar _ | REvar _ | RPatVar _ | RSort _ | RHole _ ->
+ match rt with
+ | RRef _ | RVar _ | REvar _ | RPatVar _ | RSort _ | RHole _ ->
(* do nothing (except changing type of course) *)
- mk_result [] rt avoid
+ mk_result [] rt avoid
| RApp(_,_,_) ->
let f,args = raw_decompose_app rt in
let args_res : (rawconstr list) build_entry_return =
@@ -502,108 +502,108 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
match f with
| RVar(_,id) when Idset.mem id funnames ->
(* if we have [f t1 ... tn] with [f]$\in$[fnames]
- then we create a fresh variable [res],
- add [res] and its "value" (i.e. [res v1 ... vn]) to each
- pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and
- a pseudo value "v1 ... vn".
+ then we create a fresh variable [res],
+ add [res] and its "value" (i.e. [res v1 ... vn]) to each
+ pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and
+ a pseudo value "v1 ... vn".
The "value" of this branch is then simply [res]
*)
- let rt_as_constr = Pretyping.Default.understand Evd.empty env rt in
- let rt_typ = Typing.type_of env Evd.empty rt_as_constr in
+ let rt_as_constr = Pretyping.Default.understand Evd.empty env rt in
+ let rt_typ = Typing.type_of env Evd.empty rt_as_constr in
let res_raw_type = Detyping.detype false [] (Termops.names_of_rel_context env) rt_typ in
let res = fresh_id args_res.to_avoid "res" in
let new_avoid = res::args_res.to_avoid in
- let res_rt = mkRVar res in
- let new_result =
- List.map
- (fun arg_res ->
- let new_hyps =
+ let res_rt = mkRVar res in
+ let new_result =
+ List.map
+ (fun arg_res ->
+ let new_hyps =
[Prod (Name res),res_raw_type;
Prod Anonymous,mkRApp(res_rt,(mkRVar id)::arg_res.value)]
in
- {context = arg_res.context@new_hyps; value = res_rt }
+ {context = arg_res.context@new_hyps; value = res_rt }
)
args_res.result
- in
+ in
{ result = new_result; to_avoid = new_avoid }
- | RVar _ | REvar _ | RPatVar _ | RHole _ | RSort _ | RRef _ ->
- (* if have [g t1 ... tn] with [g] not appearing in [funnames]
- then
- foreach [ctxt,v1 ... vn] in [args_res] we return
+ | RVar _ | REvar _ | RPatVar _ | RHole _ | RSort _ | RRef _ ->
+ (* if have [g t1 ... tn] with [g] not appearing in [funnames]
+ then
+ foreach [ctxt,v1 ... vn] in [args_res] we return
[ctxt, g v1 .... vn]
*)
{
- args_res with
- result =
- List.map
- (fun args_res ->
+ args_res with
+ result =
+ List.map
+ (fun args_res ->
{args_res with value = mkRApp(f,args_res.value)})
args_res.result
}
| RApp _ -> assert false (* we have collected all the app in [raw_decompose_app] *)
- | RLetIn(_,n,t,b) ->
- (* if we have [(let x := v in b) t1 ... tn] ,
- we discard our work and compute the list of constructor for
- [let x = v in (b t1 ... tn)] up to alpha conversion
+ | RLetIn(_,n,t,b) ->
+ (* if we have [(let x := v in b) t1 ... tn] ,
+ we discard our work and compute the list of constructor for
+ [let x = v in (b t1 ... tn)] up to alpha conversion
*)
- let new_n,new_b,new_avoid =
- match n with
- | Name id when List.exists (is_free_in id) args ->
+ let new_n,new_b,new_avoid =
+ match n with
+ | Name id when List.exists (is_free_in id) args ->
(* need to alpha-convert the name *)
- let new_id = Nameops.next_ident_away id avoid in
+ let new_id = Nameops.next_ident_away id avoid in
let new_avoid = id:: avoid in
- let new_b =
+ let new_b =
replace_var_by_term
id
- (RVar(dummy_loc,id))
+ (RVar(dummy_loc,id))
b
- in
+ in
(Name new_id,new_b,new_avoid)
| _ -> n,b,avoid
in
- build_entry_lc
+ build_entry_lc
env
- funnames
+ funnames
avoid
(mkRLetIn(new_n,t,mkRApp(new_b,args)))
- | RCases _ | RLambda _ | RIf _ | RLetTuple _ ->
+ | RCases _ | RLambda _ | RIf _ | RLetTuple _ ->
(* we have [(match e1, ...., en with ..... end) t1 tn]
- we first compute the result from the case and
+ we first compute the result from the case and
then combine each of them with each of args one
*)
let f_res = build_entry_lc env funnames args_res.to_avoid f in
combine_results combine_app f_res args_res
- | RDynamic _ ->error "Not handled RDynamic"
- | RCast(_,b,_) ->
- (* for an applied cast we just trash the cast part
- and restart the work.
+ | RDynamic _ ->error "Not handled RDynamic"
+ | RCast(_,b,_) ->
+ (* for an applied cast we just trash the cast part
+ and restart the work.
WARNING: We need to restart since [b] itself should be an application term
*)
build_entry_lc env funnames avoid (mkRApp(b,args))
| RRec _ -> error "Not handled RRec"
| RProd _ -> error "Cannot apply a type"
- end (* end of the application treatement *)
+ end (* end of the application treatement *)
| RLambda(_,n,_,t,b) ->
- (* we first compute the list of constructor
- corresponding to the body of the function,
- then the one corresponding to the type
+ (* we first compute the list of constructor
+ corresponding to the body of the function,
+ then the one corresponding to the type
and combine the two result
*)
let t_res = build_entry_lc env funnames avoid t in
- let new_n =
- match n with
- | Name _ -> n
+ let new_n =
+ match n with
+ | Name _ -> n
| Anonymous -> Name (Indfun_common.fresh_id [] "_x")
in
let new_env = raw_push_named (new_n,None,t) env in
let b_res = build_entry_lc new_env funnames avoid b in
combine_results (combine_lam new_n) t_res b_res
| RProd(_,n,_,t,b) ->
- (* we first compute the list of constructor
- corresponding to the body of the function,
- then the one corresponding to the type
+ (* we first compute the list of constructor
+ corresponding to the body of the function,
+ then the one corresponding to the type
and combine the two result
*)
let t_res = build_entry_lc env funnames avoid t in
@@ -611,38 +611,38 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
let b_res = build_entry_lc new_env funnames avoid b in
combine_results (combine_prod n) t_res b_res
| RLetIn(_,n,v,b) ->
- (* we first compute the list of constructor
- corresponding to the body of the function,
- then the one corresponding to the value [t]
+ (* we first compute the list of constructor
+ corresponding to the body of the function,
+ then the one corresponding to the value [t]
and combine the two result
*)
let v_res = build_entry_lc env funnames avoid v in
- let v_as_constr = Pretyping.Default.understand Evd.empty env v in
- let v_type = Typing.type_of env Evd.empty v_as_constr in
- let new_env =
+ let v_as_constr = Pretyping.Default.understand Evd.empty env v in
+ let v_type = Typing.type_of env Evd.empty v_as_constr in
+ let new_env =
match n with
Anonymous -> env
- | Name id -> Environ.push_named (id,Some v_as_constr,v_type) env
+ | Name id -> Environ.push_named (id,Some v_as_constr,v_type) env
in
let b_res = build_entry_lc new_env funnames avoid b in
combine_results (combine_letin n) v_res b_res
- | RCases(_,_,_,el,brl) ->
- (* we create the discrimination function
- and treat the case itself
+ | RCases(_,_,_,el,brl) ->
+ (* we create the discrimination function
+ and treat the case itself
*)
- let make_discr = make_discr_match brl in
+ let make_discr = make_discr_match brl in
build_entry_lc_from_case env funnames make_discr el brl avoid
- | RIf(_,b,(na,e_option),lhs,rhs) ->
+ | RIf(_,b,(na,e_option),lhs,rhs) ->
let b_as_constr = Pretyping.Default.understand Evd.empty env b in
- let b_typ = Typing.type_of env Evd.empty b_as_constr in
- let (ind,_) =
- try Inductiveops.find_inductive env Evd.empty b_typ
- with Not_found ->
- errorlabstrm "" (str "Cannot find the inductive associated to " ++
+ let b_typ = Typing.type_of env Evd.empty b_as_constr in
+ let (ind,_) =
+ try Inductiveops.find_inductive env Evd.empty b_typ
+ with Not_found ->
+ errorlabstrm "" (str "Cannot find the inductive associated to " ++
Printer.pr_rawconstr b ++ str " in " ++
Printer.pr_rawconstr rt ++ str ". try again with a cast")
in
- let case_pats = build_constructors_of_type ind [] in
+ let case_pats = build_constructors_of_type ind [] in
assert (Array.length case_pats = 2);
let brl =
list_map_i
@@ -655,7 +655,7 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
in
(* Pp.msgnl (str "new case := " ++ Printer.pr_rawconstr match_expr); *)
build_entry_lc env funnames avoid match_expr
- | RLetTuple(_,nal,_,b,e) ->
+ | RLetTuple(_,nal,_,b,e) ->
begin
let nal_as_rawconstr =
List.map
@@ -666,15 +666,15 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
nal
in
let b_as_constr = Pretyping.Default.understand Evd.empty env b in
- let b_typ = Typing.type_of env Evd.empty b_as_constr in
- let (ind,_) =
- try Inductiveops.find_inductive env Evd.empty b_typ
- with Not_found ->
- errorlabstrm "" (str "Cannot find the inductive associated to " ++
+ let b_typ = Typing.type_of env Evd.empty b_as_constr in
+ let (ind,_) =
+ try Inductiveops.find_inductive env Evd.empty b_typ
+ with Not_found ->
+ errorlabstrm "" (str "Cannot find the inductive associated to " ++
Printer.pr_rawconstr b ++ str " in " ++
Printer.pr_rawconstr rt ++ str ". try again with a cast")
in
- let case_pats = build_constructors_of_type ind nal_as_rawconstr in
+ let case_pats = build_constructors_of_type ind nal_as_rawconstr in
assert (Array.length case_pats = 1);
let br =
(dummy_loc,[],[case_pats.(0)],e)
@@ -684,25 +684,25 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
end
| RRec _ -> error "Not handled RRec"
- | RCast(_,b,_) ->
+ | RCast(_,b,_) ->
build_entry_lc env funnames avoid b
| RDynamic _ -> error "Not handled RDynamic"
and build_entry_lc_from_case env funname make_discr
(el:tomatch_tuples)
- (brl:Rawterm.cases_clauses) avoid :
- rawconstr build_entry_return =
- match el with
- | [] -> assert false (* this case correspond to match <nothing> with .... !*)
- | el ->
- (* this case correspond to
+ (brl:Rawterm.cases_clauses) avoid :
+ rawconstr build_entry_return =
+ match el with
+ | [] -> assert false (* this case correspond to match <nothing> with .... !*)
+ | el ->
+ (* this case correspond to
match el with brl end
- we first compute the list of lists corresponding to [el] and
- combine them .
- Then for each elemeent of the combinations,
- we compute the result we compute one list per branch in [brl] and
- finally we just concatenate those list
+ we first compute the list of lists corresponding to [el] and
+ combine them .
+ Then for each elemeent of the combinations,
+ we compute the result we compute one list per branch in [brl] and
+ finally we just concatenate those list
*)
- let case_resl =
+ let case_resl =
List.fold_right
(fun (case_arg,_) ctxt_argsl ->
let arg_res = build_entry_lc env funname avoid case_arg in
@@ -711,32 +711,32 @@ and build_entry_lc_from_case env funname make_discr
el
(mk_result [] [] avoid)
in
- let types =
- List.map (fun (case_arg,_) ->
- let case_arg_as_constr = Pretyping.Default.understand Evd.empty env case_arg in
+ let types =
+ List.map (fun (case_arg,_) ->
+ let case_arg_as_constr = Pretyping.Default.understand Evd.empty env case_arg in
Typing.type_of env Evd.empty case_arg_as_constr
) el
in
(****** The next works only if the match is not dependent ****)
let results =
- List.map
- (fun ca ->
+ List.map
+ (fun ca ->
let res = build_entry_lc_from_case_term
env types
funname (make_discr)
- [] brl
+ [] brl
case_resl.to_avoid
ca
- in
+ in
res
- )
- case_resl.result
- in
- {
+ )
+ case_resl.result
+ in
+ {
result = List.concat (List.map (fun r -> r.result) results);
- to_avoid =
+ to_avoid =
List.fold_left (fun acc r -> list_union acc r.to_avoid) [] results
- }
+ }
and build_entry_lc_from_case_term env types funname make_discr patterns_to_prevent brl avoid
matched_expr =
@@ -746,24 +746,24 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
(* alpha convertion to prevent name clashes *)
let _,idl,patl,return = alpha_br avoid br in
let new_avoid = idl@avoid in (* for now we can no more use idl as an indentifier *)
- (* building a list of precondition stating that we are not in this branch
+ (* building a list of precondition stating that we are not in this branch
(will be used in the following recursive calls)
*)
- let new_env = List.fold_right2 add_pat_variables patl types env in
- let not_those_patterns : (identifier list -> rawconstr -> rawconstr) list =
+ let new_env = List.fold_right2 add_pat_variables patl types env in
+ let not_those_patterns : (identifier list -> rawconstr -> rawconstr) list =
List.map2
- (fun pat typ ->
- fun avoid pat'_as_term ->
+ (fun pat typ ->
+ fun avoid pat'_as_term ->
let renamed_pat,_,_ = alpha_pat avoid pat in
- let pat_ids = get_pattern_id renamed_pat in
- let env_with_pat_ids = add_pat_variables pat typ new_env in
- List.fold_right
- (fun id acc ->
- let typ_of_id =
- Typing.type_of env_with_pat_ids Evd.empty (mkVar id)
- in
- let raw_typ_of_id =
- Detyping.detype false []
+ let pat_ids = get_pattern_id renamed_pat in
+ let env_with_pat_ids = add_pat_variables pat typ new_env in
+ List.fold_right
+ (fun id acc ->
+ let typ_of_id =
+ Typing.type_of env_with_pat_ids Evd.empty (mkVar id)
+ in
+ let raw_typ_of_id =
+ Detyping.detype false []
(Termops.names_of_rel_context env_with_pat_ids) typ_of_id
in
mkRProd (Name id,raw_typ_of_id,acc))
@@ -773,21 +773,21 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
patl
types
in
- (* Checking if we can be in this branch
+ (* Checking if we can be in this branch
(will be used in the following recursive calls)
- *)
+ *)
let unify_with_those_patterns : (cases_pattern -> bool*bool) list =
- List.map
- (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat')
+ List.map
+ (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat')
patl
in
- (*
- we first compute the other branch result (in ordrer to keep the order of the matching
+ (*
+ we first compute the other branch result (in ordrer to keep the order of the matching
as much as possible)
*)
let brl'_res =
build_entry_lc_from_case_term
- env
+ env
types
funname
make_discr
@@ -797,9 +797,9 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
matched_expr
in
(* We now create the precondition of this branch i.e.
- 1- the list of variable appearing in the different patterns of this branch and
+ 1- the list of variable appearing in the different patterns of this branch and
the list of equation stating than el = patl (List.flatten ...)
- 2- If there exists a previous branch which pattern unify with the one of this branch
+ 2- If there exists a previous branch which pattern unify with the one of this branch
then a discrimination precond stating that we are not in a previous branch (if List.exists ...)
*)
let those_pattern_preconds =
@@ -807,15 +807,15 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
(
list_map3
(fun pat e typ_as_constr ->
- let this_pat_ids = ids_of_pat pat in
+ let this_pat_ids = ids_of_pat pat in
let typ = Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_as_constr in
let pat_as_term = pattern_to_term pat in
- List.fold_right
- (fun id acc ->
- if Idset.mem id this_pat_ids
+ List.fold_right
+ (fun id acc ->
+ if Idset.mem id this_pat_ids
then (Prod (Name id),
- let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in
- let raw_typ_of_id =
+ let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in
+ let raw_typ_of_id =
Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_of_id
in
raw_typ_of_id
@@ -832,15 +832,15 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
)
@
(if List.exists (function (unifl,_) ->
- let (unif,_) =
+ let (unif,_) =
List.split (List.map2 (fun x y -> x y) unifl patl)
in
List.for_all (fun x -> x) unif) patterns_to_prevent
- then
- let i = List.length patterns_to_prevent in
+ then
+ let i = List.length patterns_to_prevent in
let pats_as_constr = List.map2 (pattern_to_term_and_type new_env) types patl in
[(Prod Anonymous,make_discr pats_as_constr i )]
- else
+ else
[]
)
in
@@ -856,183 +856,183 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
return_res.result
in
{ brl'_res with result = this_branch_res@brl'_res.result }
-
-
-let is_res id =
+
+
+let is_res id =
try
String.sub (string_of_id id) 0 3 = "res"
- with Invalid_argument _ -> false
+ with Invalid_argument _ -> false
exception Continue
-(*
- The second phase which reconstruct the real type of the constructor.
- rebuild the raw constructors expression.
+(*
+ The second phase which reconstruct the real type of the constructor.
+ rebuild the raw constructors expression.
eliminates some meaningless equalities, applies some rewrites......
*)
-let rec rebuild_cons env nb_args relname args crossed_types depth rt =
+let rec rebuild_cons env nb_args relname args crossed_types depth rt =
observe (str "rebuilding : " ++ pr_rawconstr rt);
- match rt with
- | RProd(_,n,k,t,b) ->
- let not_free_in_t id = not (is_free_in id t) in
- let new_crossed_types = t::crossed_types in
+ match rt with
+ | RProd(_,n,k,t,b) ->
+ let not_free_in_t id = not (is_free_in id t) in
+ let new_crossed_types = t::crossed_types in
begin
- match t with
+ match t with
| RApp(_,(RVar(_,res_id) as res_rt),args') when is_res res_id ->
begin
- match args' with
- | (RVar(_,this_relname))::args' ->
- (*i The next call to mk_rel_id is
+ match args' with
+ | (RVar(_,this_relname))::args' ->
+ (*i The next call to mk_rel_id is
valid since we are constructing the graph
Ensures by: obvious
- i*)
-
- let new_t =
- mkRApp(mkRVar(mk_rel_id this_relname),args'@[res_rt])
- in
- let t' = Pretyping.Default.understand Evd.empty env new_t in
- let new_env = Environ.push_rel (n,None,t') env in
- let new_b,id_to_exclude =
+ i*)
+
+ let new_t =
+ mkRApp(mkRVar(mk_rel_id this_relname),args'@[res_rt])
+ in
+ let t' = Pretyping.Default.understand Evd.empty env new_t in
+ let new_env = Environ.push_rel (n,None,t') env in
+ let new_b,id_to_exclude =
rebuild_cons new_env
nb_args relname
args new_crossed_types
(depth + 1) b
- in
+ in
mkRProd(n,new_t,new_b),
Idset.filter not_free_in_t id_to_exclude
| _ -> (* the first args is the name of the function! *)
- assert false
+ assert false
end
- | RApp(loc1,RRef(loc2,eq_as_ref),[ty;RVar(loc3,id);rt])
+ | RApp(loc1,RRef(loc2,eq_as_ref),[ty;RVar(loc3,id);rt])
when eq_as_ref = Lazy.force Coqlib.coq_eq_ref && n = Anonymous
- ->
+ ->
begin
- try
+ try
observe (str "computing new type for eq : " ++ pr_rawconstr rt);
- let t' =
+ let t' =
try Pretyping.Default.understand Evd.empty env t with _ -> raise Continue
in
let is_in_b = is_free_in id b in
- let _keep_eq =
- not (List.exists (is_free_in id) args) || is_in_b ||
- List.exists (is_free_in id) crossed_types
- in
- let new_args = List.map (replace_var_by_term id rt) args in
- let subst_b =
- if is_in_b then b else replace_var_by_term id rt b
- in
+ let _keep_eq =
+ not (List.exists (is_free_in id) args) || is_in_b ||
+ List.exists (is_free_in id) crossed_types
+ in
+ let new_args = List.map (replace_var_by_term id rt) args in
+ let subst_b =
+ if is_in_b then b else replace_var_by_term id rt b
+ in
let new_env = Environ.push_rel (n,None,t') env in
- let new_b,id_to_exclude =
- rebuild_cons
+ let new_b,id_to_exclude =
+ rebuild_cons
new_env
nb_args relname
new_args new_crossed_types
(depth + 1) subst_b
- in
+ in
mkRProd(n,t,new_b),id_to_exclude
- with Continue ->
- let jmeq = Libnames.IndRef (destInd (jmeq ())) in
- let ty' = Pretyping.Default.understand Evd.empty env ty in
- let ind,args' = Inductive.find_inductive env ty' in
- let mib,_ = Global.lookup_inductive ind in
- let nparam = mib.Declarations.mind_nparams in
- let params,arg' =
+ with Continue ->
+ let jmeq = Libnames.IndRef (destInd (jmeq ())) in
+ let ty' = Pretyping.Default.understand Evd.empty env ty in
+ let ind,args' = Inductive.find_inductive env ty' in
+ let mib,_ = Global.lookup_inductive ind in
+ let nparam = mib.Declarations.mind_nparams in
+ let params,arg' =
((Util.list_chop nparam args'))
in
- let rt_typ =
+ let rt_typ =
RApp(Util.dummy_loc,
- RRef (Util.dummy_loc,Libnames.IndRef ind),
- (List.map
- (fun p -> Detyping.detype false []
+ RRef (Util.dummy_loc,Libnames.IndRef ind),
+ (List.map
+ (fun p -> Detyping.detype false []
(Termops.names_of_rel_context env)
- p) params)@(Array.to_list
- (Array.make
- (List.length args' - nparam)
+ p) params)@(Array.to_list
+ (Array.make
+ (List.length args' - nparam)
(mkRHole ()))))
in
- let eq' =
+ let eq' =
RApp(loc1,RRef(loc2,jmeq),[ty;RVar(loc3,id);rt_typ;rt])
in
observe (str "computing new type for jmeq : " ++ pr_rawconstr eq');
let eq'_as_constr = Pretyping.Default.understand Evd.empty env eq' in
observe (str " computing new type for jmeq : done") ;
- let new_args =
- match kind_of_term eq'_as_constr with
- | App(_,[|_;_;ty;_|]) ->
- let ty = Array.to_list (snd (destApp ty)) in
- let ty' = snd (Util.list_chop nparam ty) in
- List.fold_left2
- (fun acc var_as_constr arg ->
- if isRel var_as_constr
- then
- let (na,_,_) =
+ let new_args =
+ match kind_of_term eq'_as_constr with
+ | App(_,[|_;_;ty;_|]) ->
+ let ty = Array.to_list (snd (destApp ty)) in
+ let ty' = snd (Util.list_chop nparam ty) in
+ List.fold_left2
+ (fun acc var_as_constr arg ->
+ if isRel var_as_constr
+ then
+ let (na,_,_) =
Environ.lookup_rel (destRel var_as_constr) env
- in
- match na with
- | Anonymous -> acc
- | Name id' ->
- (id',Detyping.detype false []
+ in
+ match na with
+ | Anonymous -> acc
+ | Name id' ->
+ (id',Detyping.detype false []
(Termops.names_of_rel_context env)
arg)::acc
- else if isVar var_as_constr
- then (destVar var_as_constr,Detyping.detype false []
+ else if isVar var_as_constr
+ then (destVar var_as_constr,Detyping.detype false []
(Termops.names_of_rel_context env)
arg)::acc
else acc
)
[]
arg'
- ty'
+ ty'
| _ -> assert false
in
let is_in_b = is_free_in id b in
- let _keep_eq =
- not (List.exists (is_free_in id) args) || is_in_b ||
- List.exists (is_free_in id) crossed_types
- in
- let new_args =
- List.fold_left
+ let _keep_eq =
+ not (List.exists (is_free_in id) args) || is_in_b ||
+ List.exists (is_free_in id) crossed_types
+ in
+ let new_args =
+ List.fold_left
(fun args (id,rt) ->
List.map (replace_var_by_term id rt) args
)
- args
+ args
((id,rt)::new_args)
- in
- let subst_b =
+ in
+ let subst_b =
if is_in_b then b else replace_var_by_term id rt b
- in
- let new_env =
- let t' = Pretyping.Default.understand Evd.empty env eq' in
+ in
+ let new_env =
+ let t' = Pretyping.Default.understand Evd.empty env eq' in
Environ.push_rel (n,None,t') env
in
- let new_b,id_to_exclude =
- rebuild_cons
+ let new_b,id_to_exclude =
+ rebuild_cons
new_env
nb_args relname
new_args new_crossed_types
(depth + 1) subst_b
- in
+ in
mkRProd(n,eq',new_b),id_to_exclude
end
- (* J.F:. keep this comment it explain how to remove some meaningless equalities
+ (* J.F:. keep this comment it explain how to remove some meaningless equalities
if keep_eq then
mkRProd(n,t,new_b),id_to_exclude
else new_b, Idset.add id id_to_exclude
*)
- | _ ->
+ | _ ->
observe (str "computing new type for prod : " ++ pr_rawconstr rt);
- let t' = Pretyping.Default.understand Evd.empty env t in
- let new_env = Environ.push_rel (n,None,t') env in
- let new_b,id_to_exclude =
+ let t' = Pretyping.Default.understand Evd.empty env t in
+ let new_env = Environ.push_rel (n,None,t') env in
+ let new_b,id_to_exclude =
rebuild_cons new_env
nb_args relname
args new_crossed_types
(depth + 1) b
- in
+ in
match n with
| Name id when Idset.mem id id_to_exclude && depth >= nb_args ->
- new_b,Idset.remove id
+ new_b,Idset.remove id
(Idset.filter not_free_in_t id_to_exclude)
| _ -> mkRProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude
end
@@ -1041,60 +1041,60 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
let not_free_in_t id = not (is_free_in id t) in
let new_crossed_types = t :: crossed_types in
observe (str "computing new type for lambda : " ++ pr_rawconstr rt);
- let t' = Pretyping.Default.understand Evd.empty env t in
+ let t' = Pretyping.Default.understand Evd.empty env t in
match n with
| Name id ->
- let new_env = Environ.push_rel (n,None,t') env in
- let new_b,id_to_exclude =
+ let new_env = Environ.push_rel (n,None,t') env in
+ let new_b,id_to_exclude =
rebuild_cons new_env
nb_args relname
(args@[mkRVar id])new_crossed_types
- (depth + 1 ) b
+ (depth + 1 ) b
in
if Idset.mem id id_to_exclude && depth >= nb_args
- then
+ then
new_b, Idset.remove id (Idset.filter not_free_in_t id_to_exclude)
else
RProd(dummy_loc,n,k,t,new_b),Idset.filter not_free_in_t id_to_exclude
- | _ -> anomaly "Should not have an anonymous function here"
+ | _ -> anomaly "Should not have an anonymous function here"
(* We have renamed all the anonymous functions during alpha_renaming phase *)
-
+
end
- | RLetIn(_,n,t,b) ->
+ | RLetIn(_,n,t,b) ->
begin
- let not_free_in_t id = not (is_free_in id t) in
- let t' = Pretyping.Default.understand Evd.empty env t in
- let type_t' = Typing.type_of env Evd.empty t' in
+ let not_free_in_t id = not (is_free_in id t) in
+ let t' = Pretyping.Default.understand Evd.empty env t in
+ let type_t' = Typing.type_of env Evd.empty t' in
let new_env = Environ.push_rel (n,Some t',type_t') env in
- let new_b,id_to_exclude =
- rebuild_cons new_env
+ let new_b,id_to_exclude =
+ rebuild_cons new_env
nb_args relname
args (t::crossed_types)
(depth + 1 ) b in
- match n with
- | Name id when Idset.mem id id_to_exclude && depth >= nb_args ->
+ match n with
+ | Name id when Idset.mem id id_to_exclude && depth >= nb_args ->
new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude)
| _ -> RLetIn(dummy_loc,n,t,new_b),
Idset.filter not_free_in_t id_to_exclude
end
- | RLetTuple(_,nal,(na,rto),t,b) ->
+ | RLetTuple(_,nal,(na,rto),t,b) ->
assert (rto=None);
begin
- let not_free_in_t id = not (is_free_in id t) in
- let new_t,id_to_exclude' =
+ let not_free_in_t id = not (is_free_in id t) in
+ let new_t,id_to_exclude' =
rebuild_cons env
nb_args
- relname
- args (crossed_types)
- depth t
+ relname
+ args (crossed_types)
+ depth t
in
- let t' = Pretyping.Default.understand Evd.empty env new_t in
- let new_env = Environ.push_rel (na,None,t') env in
- let new_b,id_to_exclude =
+ let t' = Pretyping.Default.understand Evd.empty env new_t in
+ let new_env = Environ.push_rel (na,None,t') env in
+ let new_b,id_to_exclude =
rebuild_cons new_env
nb_args relname
- args (t::crossed_types)
- (depth + 1) b
+ args (t::crossed_types)
+ (depth + 1) b
in
(* match n with *)
(* | Name id when Idset.mem id id_to_exclude -> *)
@@ -1109,125 +1109,125 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
(* debuging wrapper *)
-let rebuild_cons env nb_args relname args crossed_types rt =
+let rebuild_cons env nb_args relname args crossed_types rt =
(* observennl (str "rebuild_cons : rt := "++ pr_rawconstr rt ++ *)
(* str "nb_args := " ++ str (string_of_int nb_args)); *)
- let res =
- rebuild_cons env nb_args relname args crossed_types 0 rt
+ let res =
+ rebuild_cons env nb_args relname args crossed_types 0 rt
in
(* observe (str " leads to "++ pr_rawconstr (fst res)); *)
res
-(* naive implementation of parameter detection.
+(* naive implementation of parameter detection.
- A parameter is an argument which is only preceded by parameters and whose
- calls are all syntaxically equal.
+ A parameter is an argument which is only preceded by parameters and whose
+ calls are all syntaxically equal.
- TODO: Find a valid way to deal with implicit arguments here!
+ TODO: Find a valid way to deal with implicit arguments here!
*)
-let rec compute_cst_params relnames params = function
+let rec compute_cst_params relnames params = function
| RRef _ | RVar _ | REvar _ | RPatVar _ -> params
| RApp(_,RVar(_,relname'),rtl) when Idset.mem relname' relnames ->
compute_cst_params_from_app [] (params,rtl)
- | RApp(_,f,args) ->
+ | RApp(_,f,args) ->
List.fold_left (compute_cst_params relnames) params (f::args)
- | RLambda(_,_,_,t,b) | RProd(_,_,_,t,b) | RLetIn(_,_,t,b) | RLetTuple(_,_,_,t,b) ->
- let t_params = compute_cst_params relnames params t in
+ | RLambda(_,_,_,t,b) | RProd(_,_,_,t,b) | RLetIn(_,_,t,b) | RLetTuple(_,_,_,t,b) ->
+ let t_params = compute_cst_params relnames params t in
compute_cst_params relnames t_params b
| RCases _ ->
- params (* If there is still cases at this point they can only be
+ params (* If there is still cases at this point they can only be
discriminitation ones *)
| RSort _ -> params
| RHole _ -> params
| RIf _ | RRec _ | RCast _ | RDynamic _ ->
raise (UserError("compute_cst_params", str "Not handled case"))
-and compute_cst_params_from_app acc (params,rtl) =
- match params,rtl with
+and compute_cst_params_from_app acc (params,rtl) =
+ match params,rtl with
| _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *)
- | ((Name id,_,is_defined) as param)::params',(RVar(_,id'))::rtl'
- when id_ord id id' == 0 && not is_defined ->
+ | ((Name id,_,is_defined) as param)::params',(RVar(_,id'))::rtl'
+ when id_ord id id' == 0 && not is_defined ->
compute_cst_params_from_app (param::acc) (params',rtl')
- | _ -> List.rev acc
-
-let compute_params_name relnames (args : (Names.name * Rawterm.rawconstr * bool) list array) csts =
- let rels_params =
- Array.mapi
- (fun i args ->
- List.fold_left
- (fun params (_,cst) -> compute_cst_params relnames params cst)
+ | _ -> List.rev acc
+
+let compute_params_name relnames (args : (Names.name * Rawterm.rawconstr * bool) list array) csts =
+ let rels_params =
+ Array.mapi
+ (fun i args ->
+ List.fold_left
+ (fun params (_,cst) -> compute_cst_params relnames params cst)
args
csts.(i)
)
args
- in
- let l = ref [] in
- let _ =
- try
+ in
+ let l = ref [] in
+ let _ =
+ try
list_iter_i
- (fun i ((n,nt,is_defined) as param) ->
- if array_for_all
- (fun l ->
- let (n',nt',is_defined') = List.nth l i in
+ (fun i ((n,nt,is_defined) as param) ->
+ if array_for_all
+ (fun l ->
+ let (n',nt',is_defined') = List.nth l i in
n = n' && Topconstr.eq_rawconstr nt nt' && is_defined = is_defined')
rels_params
- then
+ then
l := param::!l
- )
+ )
rels_params.(0)
- with _ ->
+ with _ ->
()
- in
+ in
List.rev !l
-let rec rebuild_return_type rt =
- match rt with
- | Topconstr.CProdN(loc,n,t') ->
- Topconstr.CProdN(loc,n,rebuild_return_type t')
- | Topconstr.CArrow(loc,t,t') ->
+let rec rebuild_return_type rt =
+ match rt with
+ | Topconstr.CProdN(loc,n,t') ->
+ Topconstr.CProdN(loc,n,rebuild_return_type t')
+ | Topconstr.CArrow(loc,t,t') ->
Topconstr.CArrow(loc,t,rebuild_return_type t')
- | Topconstr.CLetIn(loc,na,t,t') ->
- Topconstr.CLetIn(loc,na,t,rebuild_return_type t')
+ | Topconstr.CLetIn(loc,na,t,t') ->
+ Topconstr.CLetIn(loc,na,t,rebuild_return_type t')
| _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,RType None))
-let do_build_inductive
- funnames (funsargs: (Names.name * rawconstr * bool) list list)
- returned_types
+let do_build_inductive
+ funnames (funsargs: (Names.name * rawconstr * bool) list list)
+ returned_types
(rtl:rawconstr list) =
let _time1 = System.get_time () in
(* Pp.msgnl (prlist_with_sep fnl Printer.pr_rawconstr rtl); *)
let funnames_as_set = List.fold_right Idset.add funnames Idset.empty in
- let funnames = Array.of_list funnames in
- let funsargs = Array.of_list funsargs in
+ let funnames = Array.of_list funnames in
+ let funsargs = Array.of_list funsargs in
let returned_types = Array.of_list returned_types in
(* alpha_renaming of the body to prevent variable capture during manipulation *)
let rtl_alpha = List.map (function rt -> expand_as (alpha_rt [] rt)) rtl in
let rta = Array.of_list rtl_alpha in
(*i The next call to mk_rel_id is valid since we are constructing the graph
Ensures by: obvious
- i*)
+ i*)
let relnames = Array.map mk_rel_id funnames in
- let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in
+ let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in
(* Construction of the pseudo constructors *)
- let env =
- Array.fold_right
- (fun id env ->
+ let env =
+ Array.fold_right
+ (fun id env ->
Environ.push_named (id,None,Typing.type_of env Evd.empty (Tacinterp.constr_of_id env id)) env
)
- funnames
+ funnames
(Global.env ())
- in
- let resa = Array.map (build_entry_lc env funnames_as_set []) rta in
- let env_with_graphs =
+ in
+ let resa = Array.map (build_entry_lc env funnames_as_set []) rta in
+ let env_with_graphs =
let rel_arity i funargs = (* Reduilding arities (with parameters) *)
- let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list =
+ let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list =
funargs
- in
+ in
List.fold_right
- (fun (n,t,is_defined) acc ->
+ (fun (n,t,is_defined) acc ->
if is_defined
- then
+ then
Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_rawconstr Idset.empty t,
acc)
else
@@ -1240,40 +1240,40 @@ let do_build_inductive
rel_first_args
(rebuild_return_type returned_types.(i))
in
- (* We need to lift back our work topconstr but only with all information
- We mimick a Set Printing All.
- Then save the graphs and reset Printing options to their primitive values
+ (* We need to lift back our work topconstr but only with all information
+ We mimick a Set Printing All.
+ Then save the graphs and reset Printing options to their primitive values
*)
let rel_arities = Array.mapi rel_arity funsargs in
- Util.array_fold_left2 (fun env rel_name rel_ar ->
+ Util.array_fold_left2 (fun env rel_name rel_ar ->
Environ.push_named (rel_name,None, Constrintern.interp_constr Evd.empty env rel_ar) env) env relnames rel_arities
in
(* and of the real constructors*)
- let constr i res =
- List.map
- (function result (* (args',concl') *) ->
- let rt = compose_raw_context result.context result.value in
- let nb_args = List.length funsargs.(i) in
+ let constr i res =
+ List.map
+ (function result (* (args',concl') *) ->
+ let rt = compose_raw_context result.context result.value in
+ let nb_args = List.length funsargs.(i) in
(* with_full_print (fun rt -> Pp.msgnl (str "raw constr " ++ pr_rawconstr rt)) rt; *)
fst (
rebuild_cons env_with_graphs nb_args relnames.(i)
[]
[]
- rt
+ rt
)
- )
- res.result
- in
+ )
+ res.result
+ in
(* adding names to constructors *)
- let next_constructor_id = ref (-1) in
- let mk_constructor_id i =
+ let next_constructor_id = ref (-1) in
+ let mk_constructor_id i =
incr next_constructor_id;
(*i The next call to mk_rel_id is valid since we are constructing the graph
Ensures by: obvious
- i*)
+ i*)
id_of_string ((string_of_id (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id))
in
- let rel_constructors i rt : (identifier*rawconstr) list =
+ let rel_constructors i rt : (identifier*rawconstr) list =
next_constructor_id := (-1);
List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt)
in
@@ -1282,18 +1282,18 @@ let do_build_inductive
let rels_params = compute_params_name relnames_as_set funsargs rel_constructors in
let nrel_params = List.length rels_params in
let rel_constructors = (* Taking into account the parameters in constructors *)
- Array.map (List.map
+ Array.map (List.map
(fun (id,rt) -> (id,snd (chop_rprod_n nrel_params rt))))
rel_constructors
in
let rel_arity i funargs = (* Reduilding arities (with parameters) *)
- let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list =
+ let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list =
(snd (list_chop nrel_params funargs))
- in
+ in
List.fold_right
- (fun (n,t,is_defined) acc ->
+ (fun (n,t,is_defined) acc ->
if is_defined
- then
+ then
Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_rawconstr Idset.empty t,
acc)
else
@@ -1306,26 +1306,26 @@ let do_build_inductive
rel_first_args
(rebuild_return_type returned_types.(i))
in
- (* We need to lift back our work topconstr but only with all information
- We mimick a Set Printing All.
- Then save the graphs and reset Printing options to their primitive values
+ (* We need to lift back our work topconstr but only with all information
+ We mimick a Set Printing All.
+ Then save the graphs and reset Printing options to their primitive values
*)
let rel_arities = Array.mapi rel_arity funsargs in
- let rel_params =
- List.map
- (fun (n,t,is_defined) ->
- if is_defined
+ let rel_params =
+ List.map
+ (fun (n,t,is_defined) ->
+ if is_defined
then
Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_rawconstr Idset.empty t)
else
- Topconstr.LocalRawAssum
+ Topconstr.LocalRawAssum
([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_rawconstr Idset.empty t)
)
rels_params
- in
- let ext_rels_constructors =
- Array.map (List.map
- (fun (id,t) ->
+ in
+ let ext_rels_constructors =
+ Array.map (List.map
+ (fun (id,t) ->
false,((dummy_loc,id),
Flags.with_option
Flags.raw_print
@@ -1334,14 +1334,14 @@ let do_build_inductive
))
(rel_constructors)
in
- let rel_ind i ext_rel_constructors =
+ let rel_ind i ext_rel_constructors =
((dummy_loc,relnames.(i)),
rel_params,
Some rel_arities.(i),
ext_rel_constructors),None
in
- let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in
- let rel_inds = Array.to_list ext_rel_constructors in
+ let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in
+ let rel_inds = Array.to_list ext_rel_constructors in
(* let _ = *)
(* Pp.msgnl (\* observe *\) ( *)
(* str "Inductive" ++ spc () ++ *)
@@ -1362,18 +1362,18 @@ let do_build_inductive
(* rel_inds *)
(* ) *)
(* in *)
- let _time2 = System.get_time () in
- try
+ let _time2 = System.get_time () in
+ try
with_full_print (Flags.silently (Command.build_mutual rel_inds)) true
- with
+ with
| UserError(s,msg) as e ->
let _time3 = System.get_time () in
(* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *)
- let repacked_rel_inds =
+ let repacked_rel_inds =
List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn )
rel_inds
in
- let msg =
+ let msg =
str "while trying to define"++ spc () ++
Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds))
++ fnl () ++
@@ -1381,16 +1381,16 @@ let do_build_inductive
in
observe (msg);
raise e
- | e ->
+ | e ->
let _time3 = System.get_time () in
(* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *)
- let repacked_rel_inds =
+ let repacked_rel_inds =
List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn )
rel_inds
in
- let msg =
+ let msg =
str "while trying to define"++ spc () ++
- Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds))
+ Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds))
++ fnl () ++
Cerrors.explain_exn e
in
@@ -1399,9 +1399,9 @@ let do_build_inductive
-let build_inductive funnames funsargs returned_types rtl =
- try
+let build_inductive funnames funsargs returned_types rtl =
+ try
do_build_inductive funnames funsargs returned_types rtl
with e -> raise (Building_graph e)
-
+
diff --git a/plugins/funind/rawterm_to_relation.mli b/plugins/funind/rawterm_to_relation.mli
index 0075fb0a07..a314050f73 100644
--- a/plugins/funind/rawterm_to_relation.mli
+++ b/plugins/funind/rawterm_to_relation.mli
@@ -2,8 +2,8 @@
(*
- [build_inductive parametrize funnames funargs returned_types bodies]
- constructs and saves the graphs of the functions [funnames] taking [funargs] as arguments
+ [build_inductive parametrize funnames funargs returned_types bodies]
+ constructs and saves the graphs of the functions [funnames] taking [funargs] as arguments
and returning [returned_types] using bodies [bodies]
*)
diff --git a/plugins/funind/rawtermops.ml b/plugins/funind/rawtermops.ml
index 92396af590..502960a144 100644
--- a/plugins/funind/rawtermops.ml
+++ b/plugins/funind/rawtermops.ml
@@ -1,11 +1,11 @@
-open Pp
+open Pp
open Rawterm
open Util
open Names
(* Ocaml 3.06 Map.S does not handle is_empty *)
let idmap_is_empty m = m = Idmap.empty
-(*
+(*
Some basic functions to rebuild rawconstr
In each of them the location is Util.dummy_loc
*)
@@ -24,152 +24,152 @@ let mkRCast(b,t) = RCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t))
Some basic functions to decompose rawconstrs
These are analogous to the ones constrs
*)
-let raw_decompose_prod =
- let rec raw_decompose_prod args = function
- | RProd(_,n,k,t,b) ->
- raw_decompose_prod ((n,t)::args) b
+let raw_decompose_prod =
+ let rec raw_decompose_prod args = function
+ | RProd(_,n,k,t,b) ->
+ raw_decompose_prod ((n,t)::args) b
| rt -> args,rt
in
raw_decompose_prod []
-let raw_decompose_prod_or_letin =
- let rec raw_decompose_prod args = function
- | RProd(_,n,k,t,b) ->
- raw_decompose_prod ((n,None,Some t)::args) b
- | RLetIn(_,n,t,b) ->
- raw_decompose_prod ((n,Some t,None)::args) b
+let raw_decompose_prod_or_letin =
+ let rec raw_decompose_prod args = function
+ | RProd(_,n,k,t,b) ->
+ raw_decompose_prod ((n,None,Some t)::args) b
+ | RLetIn(_,n,t,b) ->
+ raw_decompose_prod ((n,Some t,None)::args) b
| rt -> args,rt
in
raw_decompose_prod []
-let raw_compose_prod =
+let raw_compose_prod =
List.fold_left (fun b (n,t) -> mkRProd(n,t,b))
-let raw_compose_prod_or_letin =
+let raw_compose_prod_or_letin =
List.fold_left (
- fun concl decl ->
- match decl with
+ fun concl decl ->
+ match decl with
| (n,None,Some t) -> mkRProd(n,t,concl)
| (n,Some bdy,None) -> mkRLetIn(n,bdy,concl)
| _ -> assert false)
-let raw_decompose_prod_n n =
- let rec raw_decompose_prod i args c =
+let raw_decompose_prod_n n =
+ let rec raw_decompose_prod i args c =
if i<=0 then args,c
else
match c with
- | RProd(_,n,_,t,b) ->
- raw_decompose_prod (i-1) ((n,t)::args) b
+ | RProd(_,n,_,t,b) ->
+ raw_decompose_prod (i-1) ((n,t)::args) b
| rt -> args,rt
in
raw_decompose_prod n []
-let raw_decompose_prod_or_letin_n n =
- let rec raw_decompose_prod i args c =
+let raw_decompose_prod_or_letin_n n =
+ let rec raw_decompose_prod i args c =
if i<=0 then args,c
else
match c with
- | RProd(_,n,_,t,b) ->
- raw_decompose_prod (i-1) ((n,None,Some t)::args) b
- | RLetIn(_,n,t,b) ->
- raw_decompose_prod (i-1) ((n,Some t,None)::args) b
+ | RProd(_,n,_,t,b) ->
+ raw_decompose_prod (i-1) ((n,None,Some t)::args) b
+ | RLetIn(_,n,t,b) ->
+ raw_decompose_prod (i-1) ((n,Some t,None)::args) b
| rt -> args,rt
in
raw_decompose_prod n []
-let raw_decompose_app =
+let raw_decompose_app =
let rec decompose_rapp acc rt =
(* msgnl (str "raw_decompose_app on : "++ Printer.pr_rawconstr rt); *)
- match rt with
- | RApp(_,rt,rtl) ->
+ match rt with
+ | RApp(_,rt,rtl) ->
decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt
| rt -> rt,List.rev acc
in
- decompose_rapp []
+ decompose_rapp []
-(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *)
-let raw_make_eq ?(typ= mkRHole ()) t1 t2 =
+(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *)
+let raw_make_eq ?(typ= mkRHole ()) t1 t2 =
mkRApp(mkRRef (Lazy.force Coqlib.coq_eq_ref),[typ;t2;t1])
-(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *)
-let raw_make_neq t1 t2 =
+(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *)
+let raw_make_neq t1 t2 =
mkRApp(mkRRef (Lazy.force Coqlib.coq_not_ref),[raw_make_eq t1 t2])
-(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *)
+(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *)
let raw_make_or t1 t2 = mkRApp (mkRRef(Lazy.force Coqlib.coq_or_ref),[t1;t2])
-(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding
- to [P1 \/ ( .... \/ Pn)]
-*)
-let rec raw_make_or_list = function
+(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding
+ to [P1 \/ ( .... \/ Pn)]
+*)
+let rec raw_make_or_list = function
| [] -> raise (Invalid_argument "mk_or")
| [e] -> e
| e::l -> raw_make_or e (raw_make_or_list l)
-
-let remove_name_from_mapping mapping na =
- match na with
- | Anonymous -> mapping
+
+let remove_name_from_mapping mapping na =
+ match na with
+ | Anonymous -> mapping
| Name id -> Idmap.remove id mapping
-let change_vars =
- let rec change_vars mapping rt =
- match rt with
- | RRef _ -> rt
- | RVar(loc,id) ->
- let new_id =
- try
- Idmap.find id mapping
- with Not_found -> id
+let change_vars =
+ let rec change_vars mapping rt =
+ match rt with
+ | RRef _ -> rt
+ | RVar(loc,id) ->
+ let new_id =
+ try
+ Idmap.find id mapping
+ with Not_found -> id
in
RVar(loc,new_id)
- | REvar _ -> rt
- | RPatVar _ -> rt
- | RApp(loc,rt',rtl) ->
+ | REvar _ -> rt
+ | RPatVar _ -> rt
+ | RApp(loc,rt',rtl) ->
RApp(loc,
change_vars mapping rt',
List.map (change_vars mapping) rtl
)
- | RLambda(loc,name,k,t,b) ->
+ | RLambda(loc,name,k,t,b) ->
RLambda(loc,
name,
k,
change_vars mapping t,
change_vars (remove_name_from_mapping mapping name) b
)
- | RProd(loc,name,k,t,b) ->
+ | RProd(loc,name,k,t,b) ->
RProd(loc,
name,
k,
change_vars mapping t,
change_vars (remove_name_from_mapping mapping name) b
)
- | RLetIn(loc,name,def,b) ->
+ | RLetIn(loc,name,def,b) ->
RLetIn(loc,
name,
change_vars mapping def,
change_vars (remove_name_from_mapping mapping name) b
)
- | RLetTuple(loc,nal,(na,rto),b,e) ->
- let new_mapping = List.fold_left remove_name_from_mapping mapping nal in
+ | RLetTuple(loc,nal,(na,rto),b,e) ->
+ let new_mapping = List.fold_left remove_name_from_mapping mapping nal in
RLetTuple(loc,
nal,
- (na, Option.map (change_vars mapping) rto),
- change_vars mapping b,
+ (na, Option.map (change_vars mapping) rto),
+ change_vars mapping b,
change_vars new_mapping e
)
- | RCases(loc,sty,infos,el,brl) ->
+ | RCases(loc,sty,infos,el,brl) ->
RCases(loc,sty,
infos,
- List.map (fun (e,x) -> (change_vars mapping e,x)) el,
+ List.map (fun (e,x) -> (change_vars mapping e,x)) el,
List.map (change_vars_br mapping) brl
)
- | RIf(loc,b,(na,e_option),lhs,rhs) ->
+ | RIf(loc,b,(na,e_option),lhs,rhs) ->
RIf(loc,
change_vars mapping b,
(na,Option.map (change_vars mapping) e_option),
@@ -177,211 +177,211 @@ let change_vars =
change_vars mapping rhs
)
| RRec _ -> error "Local (co)fixes are not supported"
- | RSort _ -> rt
- | RHole _ -> rt
- | RCast(loc,b,CastConv (k,t)) ->
+ | RSort _ -> rt
+ | RHole _ -> rt
+ | RCast(loc,b,CastConv (k,t)) ->
RCast(loc,change_vars mapping b, CastConv (k,change_vars mapping t))
- | RCast(loc,b,CastCoerce) ->
+ | RCast(loc,b,CastCoerce) ->
RCast(loc,change_vars mapping b,CastCoerce)
| RDynamic _ -> error "Not handled RDynamic"
- and change_vars_br mapping ((loc,idl,patl,res) as br) =
- let new_mapping = List.fold_right Idmap.remove idl mapping in
- if idmap_is_empty new_mapping
- then br
+ and change_vars_br mapping ((loc,idl,patl,res) as br) =
+ let new_mapping = List.fold_right Idmap.remove idl mapping in
+ if idmap_is_empty new_mapping
+ then br
else (loc,idl,patl,change_vars new_mapping res)
in
- change_vars
+ change_vars
-let rec alpha_pat excluded pat =
- match pat with
- | PatVar(loc,Anonymous) ->
- let new_id = Indfun_common.fresh_id excluded "_x" in
+let rec alpha_pat excluded pat =
+ match pat with
+ | PatVar(loc,Anonymous) ->
+ let new_id = Indfun_common.fresh_id excluded "_x" in
PatVar(loc,Name new_id),(new_id::excluded),Idmap.empty
- | PatVar(loc,Name id) ->
- if List.mem id excluded
- then
- let new_id = Nameops.next_ident_away id excluded in
+ | PatVar(loc,Name id) ->
+ if List.mem id excluded
+ then
+ let new_id = Nameops.next_ident_away id excluded in
PatVar(loc,Name new_id),(new_id::excluded),
(Idmap.add id new_id Idmap.empty)
else pat,excluded,Idmap.empty
- | PatCstr(loc,constr,patl,na) ->
- let new_na,new_excluded,map =
- match na with
- | Name id when List.mem id excluded ->
- let new_id = Nameops.next_ident_away id excluded in
+ | PatCstr(loc,constr,patl,na) ->
+ let new_na,new_excluded,map =
+ match na with
+ | Name id when List.mem id excluded ->
+ let new_id = Nameops.next_ident_away id excluded in
Name new_id,new_id::excluded, Idmap.add id new_id Idmap.empty
| _ -> na,excluded,Idmap.empty
- in
- let new_patl,new_excluded,new_map =
- List.fold_left
- (fun (patl,excluded,map) pat ->
- let new_pat,new_excluded,new_map = alpha_pat excluded pat in
+ in
+ let new_patl,new_excluded,new_map =
+ List.fold_left
+ (fun (patl,excluded,map) pat ->
+ let new_pat,new_excluded,new_map = alpha_pat excluded pat in
(new_pat::patl,new_excluded,Idmap.fold Idmap.add new_map map)
)
([],new_excluded,map)
patl
- in
+ in
PatCstr(loc,constr,List.rev new_patl,new_na),new_excluded,new_map
-let alpha_patl excluded patl =
- let patl,new_excluded,map =
- List.fold_left
- (fun (patl,excluded,map) pat ->
- let new_pat,new_excluded,new_map = alpha_pat excluded pat in
+let alpha_patl excluded patl =
+ let patl,new_excluded,map =
+ List.fold_left
+ (fun (patl,excluded,map) pat ->
+ let new_pat,new_excluded,new_map = alpha_pat excluded pat in
new_pat::patl,new_excluded,(Idmap.fold Idmap.add new_map map)
)
([],excluded,Idmap.empty)
patl
- in
+ in
(List.rev patl,new_excluded,map)
-
-let raw_get_pattern_id pat acc =
- let rec get_pattern_id pat =
- match pat with
+
+let raw_get_pattern_id pat acc =
+ let rec get_pattern_id pat =
+ match pat with
| PatVar(loc,Anonymous) -> assert false
- | PatVar(loc,Name id) ->
+ | PatVar(loc,Name id) ->
[id]
- | PatCstr(loc,constr,patternl,_) ->
- List.fold_right
- (fun pat idl ->
- let idl' = get_pattern_id pat in
+ | PatCstr(loc,constr,patternl,_) ->
+ List.fold_right
+ (fun pat idl ->
+ let idl' = get_pattern_id pat in
idl'@idl
)
- patternl
+ patternl
[]
in
(get_pattern_id pat)@acc
let get_pattern_id pat = raw_get_pattern_id pat []
-
-let rec alpha_rt excluded rt =
- let new_rt =
- match rt with
+
+let rec alpha_rt excluded rt =
+ let new_rt =
+ match rt with
| RRef _ | RVar _ | REvar _ | RPatVar _ -> rt
- | RLambda(loc,Anonymous,k,t,b) ->
- let new_id = Nameops.next_ident_away (id_of_string "_x") excluded in
- let new_excluded = new_id :: excluded in
- let new_t = alpha_rt new_excluded t in
- let new_b = alpha_rt new_excluded b in
+ | RLambda(loc,Anonymous,k,t,b) ->
+ let new_id = Nameops.next_ident_away (id_of_string "_x") excluded in
+ let new_excluded = new_id :: excluded in
+ let new_t = alpha_rt new_excluded t in
+ let new_b = alpha_rt new_excluded b in
RLambda(loc,Name new_id,k,new_t,new_b)
- | RProd(loc,Anonymous,k,t,b) ->
- let new_t = alpha_rt excluded t in
- let new_b = alpha_rt excluded b in
+ | RProd(loc,Anonymous,k,t,b) ->
+ let new_t = alpha_rt excluded t in
+ let new_b = alpha_rt excluded b in
RProd(loc,Anonymous,k,new_t,new_b)
- | RLetIn(loc,Anonymous,t,b) ->
- let new_t = alpha_rt excluded t in
- let new_b = alpha_rt excluded b in
+ | RLetIn(loc,Anonymous,t,b) ->
+ let new_t = alpha_rt excluded t in
+ let new_b = alpha_rt excluded b in
RLetIn(loc,Anonymous,new_t,new_b)
- | RLambda(loc,Name id,k,t,b) ->
- let new_id = Nameops.next_ident_away id excluded in
- let t,b =
- if new_id = id
+ | RLambda(loc,Name id,k,t,b) ->
+ let new_id = Nameops.next_ident_away id excluded in
+ let t,b =
+ if new_id = id
then t,b
- else
- let replace = change_vars (Idmap.add id new_id Idmap.empty) in
+ else
+ let replace = change_vars (Idmap.add id new_id Idmap.empty) in
(t,replace b)
in
- let new_excluded = new_id::excluded in
- let new_t = alpha_rt new_excluded t in
- let new_b = alpha_rt new_excluded b in
+ let new_excluded = new_id::excluded in
+ let new_t = alpha_rt new_excluded t in
+ let new_b = alpha_rt new_excluded b in
RLambda(loc,Name new_id,k,new_t,new_b)
- | RProd(loc,Name id,k,t,b) ->
- let new_id = Nameops.next_ident_away id excluded in
- let new_excluded = new_id::excluded in
- let t,b =
- if new_id = id
+ | RProd(loc,Name id,k,t,b) ->
+ let new_id = Nameops.next_ident_away id excluded in
+ let new_excluded = new_id::excluded in
+ let t,b =
+ if new_id = id
then t,b
- else
- let replace = change_vars (Idmap.add id new_id Idmap.empty) in
+ else
+ let replace = change_vars (Idmap.add id new_id Idmap.empty) in
(t,replace b)
in
- let new_t = alpha_rt new_excluded t in
- let new_b = alpha_rt new_excluded b in
+ let new_t = alpha_rt new_excluded t in
+ let new_b = alpha_rt new_excluded b in
RProd(loc,Name new_id,k,new_t,new_b)
- | RLetIn(loc,Name id,t,b) ->
- let new_id = Nameops.next_ident_away id excluded in
- let t,b =
- if new_id = id
+ | RLetIn(loc,Name id,t,b) ->
+ let new_id = Nameops.next_ident_away id excluded in
+ let t,b =
+ if new_id = id
then t,b
- else
- let replace = change_vars (Idmap.add id new_id Idmap.empty) in
+ else
+ let replace = change_vars (Idmap.add id new_id Idmap.empty) in
(t,replace b)
in
- let new_excluded = new_id::excluded in
- let new_t = alpha_rt new_excluded t in
- let new_b = alpha_rt new_excluded b in
+ let new_excluded = new_id::excluded in
+ let new_t = alpha_rt new_excluded t in
+ let new_b = alpha_rt new_excluded b in
RLetIn(loc,Name new_id,new_t,new_b)
- | RLetTuple(loc,nal,(na,rto),t,b) ->
- let rev_new_nal,new_excluded,mapping =
- List.fold_left
- (fun (nal,excluded,mapping) na ->
- match na with
+ | RLetTuple(loc,nal,(na,rto),t,b) ->
+ let rev_new_nal,new_excluded,mapping =
+ List.fold_left
+ (fun (nal,excluded,mapping) na ->
+ match na with
| Anonymous -> (na::nal,excluded,mapping)
- | Name id ->
- let new_id = Nameops.next_ident_away id excluded in
- if new_id = id
- then
- na::nal,id::excluded,mapping
- else
+ | Name id ->
+ let new_id = Nameops.next_ident_away id excluded in
+ if new_id = id
+ then
+ na::nal,id::excluded,mapping
+ else
(Name new_id)::nal,id::excluded,(Idmap.add id new_id mapping)
)
([],excluded,Idmap.empty)
nal
in
- let new_nal = List.rev rev_new_nal in
- let new_rto,new_t,new_b =
+ let new_nal = List.rev rev_new_nal in
+ let new_rto,new_t,new_b =
if idmap_is_empty mapping
then rto,t,b
- else let replace = change_vars mapping in
+ else let replace = change_vars mapping in
(Option.map replace rto, t,replace b)
in
- let new_t = alpha_rt new_excluded new_t in
- let new_b = alpha_rt new_excluded new_b in
+ let new_t = alpha_rt new_excluded new_t in
+ let new_b = alpha_rt new_excluded new_b in
let new_rto = Option.map (alpha_rt new_excluded) new_rto in
RLetTuple(loc,new_nal,(na,new_rto),new_t,new_b)
- | RCases(loc,sty,infos,el,brl) ->
- let new_el =
- List.map (function (rt,i) -> alpha_rt excluded rt, i) el
- in
- RCases(loc,sty,infos,new_el,List.map (alpha_br excluded) brl)
- | RIf(loc,b,(na,e_o),lhs,rhs) ->
+ | RCases(loc,sty,infos,el,brl) ->
+ let new_el =
+ List.map (function (rt,i) -> alpha_rt excluded rt, i) el
+ in
+ RCases(loc,sty,infos,new_el,List.map (alpha_br excluded) brl)
+ | RIf(loc,b,(na,e_o),lhs,rhs) ->
RIf(loc,alpha_rt excluded b,
(na,Option.map (alpha_rt excluded) e_o),
alpha_rt excluded lhs,
alpha_rt excluded rhs
)
| RRec _ -> error "Not handled RRec"
- | RSort _ -> rt
- | RHole _ -> rt
- | RCast (loc,b,CastConv (k,t)) ->
+ | RSort _ -> rt
+ | RHole _ -> rt
+ | RCast (loc,b,CastConv (k,t)) ->
RCast(loc,alpha_rt excluded b,CastConv(k,alpha_rt excluded t))
- | RCast (loc,b,CastCoerce) ->
+ | RCast (loc,b,CastCoerce) ->
RCast(loc,alpha_rt excluded b,CastCoerce)
| RDynamic _ -> error "Not handled RDynamic"
- | RApp(loc,f,args) ->
+ | RApp(loc,f,args) ->
RApp(loc,
alpha_rt excluded f,
List.map (alpha_rt excluded) args
)
- in
+ in
new_rt
-and alpha_br excluded (loc,ids,patl,res) =
- let new_patl,new_excluded,mapping = alpha_patl excluded patl in
- let new_ids = List.fold_right raw_get_pattern_id new_patl [] in
- let new_excluded = new_ids@excluded in
- let renamed_res = change_vars mapping res in
- let new_res = alpha_rt new_excluded renamed_res in
+and alpha_br excluded (loc,ids,patl,res) =
+ let new_patl,new_excluded,mapping = alpha_patl excluded patl in
+ let new_ids = List.fold_right raw_get_pattern_id new_patl [] in
+ let new_excluded = new_ids@excluded in
+ let renamed_res = change_vars mapping res in
+ let new_res = alpha_rt new_excluded renamed_res in
(loc,new_ids,new_patl,new_res)
-
-(*
+
+(*
[is_free_in id rt] checks if [id] is a free variable in [rt]
*)
let is_free_in id =
@@ -401,12 +401,12 @@ let is_free_in id =
| RCases(_,_,_,el,brl) ->
(List.exists (fun (e,_) -> is_free_in e) el) ||
List.exists is_free_in_br brl
- | RLetTuple(_,nal,_,b,t) ->
- let check_in_nal =
- not (List.exists (function Name id' -> id'= id | _ -> false) nal)
- in
+ | RLetTuple(_,nal,_,b,t) ->
+ let check_in_nal =
+ not (List.exists (function Name id' -> id'= id | _ -> false) nal)
+ in
is_free_in t || (check_in_nal && is_free_in b)
-
+
| RIf(_,cond,_,br1,br2) ->
is_free_in cond || is_free_in br1 || is_free_in br2
| RRec _ -> raise (UserError("",str "Not handled RRec"))
@@ -419,7 +419,7 @@ let is_free_in id =
(not (List.mem id ids)) && is_free_in rt
in
is_free_in
-
+
let rec pattern_to_term = function
@@ -446,23 +446,23 @@ let rec pattern_to_term = function
implicit_args@patl_as_term
)
-
-let replace_var_by_term x_id term =
- let rec replace_var_by_pattern rt =
- match rt with
- | RRef _ -> rt
+
+let replace_var_by_term x_id term =
+ let rec replace_var_by_pattern rt =
+ match rt with
+ | RRef _ -> rt
| RVar(_,id) when id_ord id x_id == 0 -> term
- | RVar _ -> rt
- | REvar _ -> rt
- | RPatVar _ -> rt
- | RApp(loc,rt',rtl) ->
+ | RVar _ -> rt
+ | REvar _ -> rt
+ | RPatVar _ -> rt
+ | RApp(loc,rt',rtl) ->
RApp(loc,
replace_var_by_pattern rt',
List.map replace_var_by_pattern rtl
)
| RLambda(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt
- | RLambda(loc,name,k,t,b) ->
+ | RLambda(loc,name,k,t,b) ->
RLambda(loc,
name,
k,
@@ -470,7 +470,7 @@ let replace_var_by_term x_id term =
replace_var_by_pattern b
)
| RProd(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt
- | RProd(loc,name,k,t,b) ->
+ | RProd(loc,name,k,t,b) ->
RProd(loc,
name,
k,
@@ -478,94 +478,94 @@ let replace_var_by_term x_id term =
replace_var_by_pattern b
)
| RLetIn(_,Name id,_,_) when id_ord id x_id == 0 -> rt
- | RLetIn(loc,name,def,b) ->
+ | RLetIn(loc,name,def,b) ->
RLetIn(loc,
name,
replace_var_by_pattern def,
replace_var_by_pattern b
)
- | RLetTuple(_,nal,_,_,_)
- when List.exists (function Name id -> id = x_id | _ -> false) nal ->
+ | RLetTuple(_,nal,_,_,_)
+ when List.exists (function Name id -> id = x_id | _ -> false) nal ->
rt
- | RLetTuple(loc,nal,(na,rto),def,b) ->
+ | RLetTuple(loc,nal,(na,rto),def,b) ->
RLetTuple(loc,
nal,
(na,Option.map replace_var_by_pattern rto),
replace_var_by_pattern def,
replace_var_by_pattern b
)
- | RCases(loc,sty,infos,el,brl) ->
+ | RCases(loc,sty,infos,el,brl) ->
RCases(loc,sty,
infos,
- List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el,
+ List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el,
List.map replace_var_by_pattern_br brl
)
- | RIf(loc,b,(na,e_option),lhs,rhs) ->
+ | RIf(loc,b,(na,e_option),lhs,rhs) ->
RIf(loc, replace_var_by_pattern b,
(na,Option.map replace_var_by_pattern e_option),
replace_var_by_pattern lhs,
replace_var_by_pattern rhs
)
| RRec _ -> raise (UserError("",str "Not handled RRec"))
- | RSort _ -> rt
- | RHole _ -> rt
- | RCast(loc,b,CastConv(k,t)) ->
+ | RSort _ -> rt
+ | RHole _ -> rt
+ | RCast(loc,b,CastConv(k,t)) ->
RCast(loc,replace_var_by_pattern b,CastConv(k,replace_var_by_pattern t))
- | RCast(loc,b,CastCoerce) ->
+ | RCast(loc,b,CastCoerce) ->
RCast(loc,replace_var_by_pattern b,CastCoerce)
| RDynamic _ -> raise (UserError("",str "Not handled RDynamic"))
- and replace_var_by_pattern_br ((loc,idl,patl,res) as br) =
- if List.exists (fun id -> id_ord id x_id == 0) idl
- then br
+ and replace_var_by_pattern_br ((loc,idl,patl,res) as br) =
+ if List.exists (fun id -> id_ord id x_id == 0) idl
+ then br
else (loc,idl,patl,replace_var_by_pattern res)
in
- replace_var_by_pattern
+ replace_var_by_pattern
-(* checking unifiability of patterns *)
-exception NotUnifiable
+(* checking unifiability of patterns *)
+exception NotUnifiable
-let rec are_unifiable_aux = function
- | [] -> ()
- | eq::eqs ->
- match eq with
- | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs
- | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) ->
- if constructor2 <> constructor1
+let rec are_unifiable_aux = function
+ | [] -> ()
+ | eq::eqs ->
+ match eq with
+ | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs
+ | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) ->
+ if constructor2 <> constructor1
then raise NotUnifiable
- else
- let eqs' =
+ else
+ let eqs' =
try ((List.combine cpl1 cpl2)@eqs)
- with _ -> anomaly "are_unifiable_aux"
+ with _ -> anomaly "are_unifiable_aux"
in
are_unifiable_aux eqs'
-
-let are_unifiable pat1 pat2 =
- try
+
+let are_unifiable pat1 pat2 =
+ try
are_unifiable_aux [pat1,pat2];
true
with NotUnifiable -> false
-let rec eq_cases_pattern_aux = function
- | [] -> ()
- | eq::eqs ->
- match eq with
- | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs
- | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) ->
- if constructor2 <> constructor1
+let rec eq_cases_pattern_aux = function
+ | [] -> ()
+ | eq::eqs ->
+ match eq with
+ | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs
+ | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) ->
+ if constructor2 <> constructor1
then raise NotUnifiable
- else
- let eqs' =
+ else
+ let eqs' =
try ((List.combine cpl1 cpl2)@eqs)
- with _ -> anomaly "eq_cases_pattern_aux"
+ with _ -> anomaly "eq_cases_pattern_aux"
in
eq_cases_pattern_aux eqs'
| _ -> raise NotUnifiable
-let eq_cases_pattern pat1 pat2 =
+let eq_cases_pattern pat1 pat2 =
try
eq_cases_pattern_aux [pat1,pat2];
true
@@ -573,25 +573,25 @@ let eq_cases_pattern pat1 pat2 =
-let ids_of_pat =
- let rec ids_of_pat ids = function
- | PatVar(_,Anonymous) -> ids
- | PatVar(_,Name id) -> Idset.add id ids
+let ids_of_pat =
+ let rec ids_of_pat ids = function
+ | PatVar(_,Anonymous) -> ids
+ | PatVar(_,Name id) -> Idset.add id ids
| PatCstr(_,_,patl,_) -> List.fold_left ids_of_pat ids patl
in
- ids_of_pat Idset.empty
-
-let id_of_name = function
- | Names.Anonymous -> id_of_string "x"
+ ids_of_pat Idset.empty
+
+let id_of_name = function
+ | Names.Anonymous -> id_of_string "x"
| Names.Name x -> x
(* TODO: finish Rec caes *)
-let ids_of_rawterm c =
- let rec ids_of_rawterm acc c =
+let ids_of_rawterm c =
+ let rec ids_of_rawterm acc c =
let idof = id_of_name in
match c with
| RVar (_,id) -> id::acc
- | RApp (loc,g,args) ->
+ | RApp (loc,g,args) ->
ids_of_rawterm [] g @ List.flatten (List.map (ids_of_rawterm []) args) @ acc
| RLambda (loc,na,k,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc
| RProd (loc,na,k,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc
@@ -599,101 +599,101 @@ let ids_of_rawterm c =
| RCast (loc,c,CastConv(k,t)) -> ids_of_rawterm [] c @ ids_of_rawterm [] t @ acc
| RCast (loc,c,CastCoerce) -> ids_of_rawterm [] c @ acc
| RIf (loc,c,(na,po),b1,b2) -> ids_of_rawterm [] c @ ids_of_rawterm [] b1 @ ids_of_rawterm [] b2 @ acc
- | RLetTuple (_,nal,(na,po),b,c) ->
+ | RLetTuple (_,nal,(na,po),b,c) ->
List.map idof nal @ ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc
- | RCases (loc,sty,rtntypopt,tml,brchl) ->
+ | RCases (loc,sty,rtntypopt,tml,brchl) ->
List.flatten (List.map (fun (_,idl,patl,c) -> idl @ ids_of_rawterm [] c) brchl)
| RRec _ -> failwith "Fix inside a constructor branch"
| (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> []
in
(* build the set *)
List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_rawterm [] c)
-
-let zeta_normalize =
- let rec zeta_normalize_term rt =
- match rt with
- | RRef _ -> rt
- | RVar _ -> rt
- | REvar _ -> rt
- | RPatVar _ -> rt
- | RApp(loc,rt',rtl) ->
+
+let zeta_normalize =
+ let rec zeta_normalize_term rt =
+ match rt with
+ | RRef _ -> rt
+ | RVar _ -> rt
+ | REvar _ -> rt
+ | RPatVar _ -> rt
+ | RApp(loc,rt',rtl) ->
RApp(loc,
zeta_normalize_term rt',
List.map zeta_normalize_term rtl
)
- | RLambda(loc,name,k,t,b) ->
+ | RLambda(loc,name,k,t,b) ->
RLambda(loc,
name,
k,
zeta_normalize_term t,
zeta_normalize_term b
)
- | RProd(loc,name,k,t,b) ->
+ | RProd(loc,name,k,t,b) ->
RProd(loc,
- name,
+ name,
k,
zeta_normalize_term t,
zeta_normalize_term b
)
- | RLetIn(_,Name id,def,b) ->
+ | RLetIn(_,Name id,def,b) ->
zeta_normalize_term (replace_var_by_term id def b)
| RLetIn(loc,Anonymous,def,b) -> zeta_normalize_term b
- | RLetTuple(loc,nal,(na,rto),def,b) ->
+ | RLetTuple(loc,nal,(na,rto),def,b) ->
RLetTuple(loc,
nal,
(na,Option.map zeta_normalize_term rto),
zeta_normalize_term def,
zeta_normalize_term b
)
- | RCases(loc,sty,infos,el,brl) ->
+ | RCases(loc,sty,infos,el,brl) ->
RCases(loc,sty,
infos,
- List.map (fun (e,x) -> (zeta_normalize_term e,x)) el,
+ List.map (fun (e,x) -> (zeta_normalize_term e,x)) el,
List.map zeta_normalize_br brl
)
- | RIf(loc,b,(na,e_option),lhs,rhs) ->
+ | RIf(loc,b,(na,e_option),lhs,rhs) ->
RIf(loc, zeta_normalize_term b,
(na,Option.map zeta_normalize_term e_option),
zeta_normalize_term lhs,
zeta_normalize_term rhs
)
| RRec _ -> raise (UserError("",str "Not handled RRec"))
- | RSort _ -> rt
- | RHole _ -> rt
- | RCast(loc,b,CastConv(k,t)) ->
+ | RSort _ -> rt
+ | RHole _ -> rt
+ | RCast(loc,b,CastConv(k,t)) ->
RCast(loc,zeta_normalize_term b,CastConv(k,zeta_normalize_term t))
- | RCast(loc,b,CastCoerce) ->
+ | RCast(loc,b,CastCoerce) ->
RCast(loc,zeta_normalize_term b,CastCoerce)
| RDynamic _ -> raise (UserError("",str "Not handled RDynamic"))
- and zeta_normalize_br (loc,idl,patl,res) =
+ and zeta_normalize_br (loc,idl,patl,res) =
(loc,idl,patl,zeta_normalize_term res)
in
- zeta_normalize_term
+ zeta_normalize_term
-let expand_as =
-
- let rec add_as map pat =
- match pat with
- | PatVar _ -> map
- | PatCstr(_,_,patl,Name id) ->
+let expand_as =
+
+ let rec add_as map pat =
+ match pat with
+ | PatVar _ -> map
+ | PatCstr(_,_,patl,Name id) ->
Idmap.add id (pattern_to_term pat) (List.fold_left add_as map patl)
| PatCstr(_,_,patl,_) -> List.fold_left add_as map patl
- in
- let rec expand_as map rt =
- match rt with
- | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> rt
- | RVar(_,id) ->
+ in
+ let rec expand_as map rt =
+ match rt with
+ | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> rt
+ | RVar(_,id) ->
begin
- try
+ try
Idmap.find id map
- with Not_found -> rt
+ with Not_found -> rt
end
| RApp(loc,f,args) -> RApp(loc,expand_as map f,List.map (expand_as map) args)
| RLambda(loc,na,k,t,b) -> RLambda(loc,na,k,expand_as map t, expand_as map b)
@@ -712,7 +712,7 @@ let expand_as =
| RCases(loc,sty,po,el,brl) ->
RCases(loc, sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el,
List.map (expand_as_br map) brl)
- and expand_as_br map (loc,idl,cpl,rt) =
+ and expand_as_br map (loc,idl,cpl,rt) =
(loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt)
in
- expand_as Idmap.empty
+ expand_as Idmap.empty
diff --git a/plugins/funind/rawtermops.mli b/plugins/funind/rawtermops.mli
index 358c6ba6c7..455e7c89b2 100644
--- a/plugins/funind/rawtermops.mli
+++ b/plugins/funind/rawtermops.mli
@@ -7,12 +7,12 @@ val idmap_is_empty : 'a Names.Idmap.t -> bool
(* [get_pattern_id pat] returns a list of all the variable appearing in [pat] *)
val get_pattern_id : cases_pattern -> Names.identifier list
-(* [pattern_to_term pat] returns a rawconstr corresponding to [pat].
- [pat] must not contain occurences of anonymous pattern
+(* [pattern_to_term pat] returns a rawconstr corresponding to [pat].
+ [pat] must not contain occurences of anonymous pattern
*)
-val pattern_to_term : cases_pattern -> rawconstr
+val pattern_to_term : cases_pattern -> rawconstr
-(*
+(*
Some basic functions to rebuild rawconstr
In each of them the location is Util.dummy_loc
*)
@@ -23,35 +23,35 @@ val mkRLambda : Names.name*rawconstr*rawconstr -> rawconstr
val mkRProd : Names.name*rawconstr*rawconstr -> rawconstr
val mkRLetIn : Names.name*rawconstr*rawconstr -> rawconstr
val mkRCases : rawconstr option * tomatch_tuples * cases_clauses -> rawconstr
-val mkRSort : rawsort -> rawconstr
+val mkRSort : rawsort -> rawconstr
val mkRHole : unit -> rawconstr (* we only build Evd.BinderType Anonymous holes *)
-val mkRCast : rawconstr* rawconstr -> rawconstr
+val mkRCast : rawconstr* rawconstr -> rawconstr
(*
Some basic functions to decompose rawconstrs
These are analogous to the ones constrs
*)
val raw_decompose_prod : rawconstr -> (Names.name*rawconstr) list * rawconstr
-val raw_decompose_prod_or_letin :
+val raw_decompose_prod_or_letin :
rawconstr -> (Names.name*rawconstr option*rawconstr option) list * rawconstr
val raw_decompose_prod_n : int -> rawconstr -> (Names.name*rawconstr) list * rawconstr
-val raw_decompose_prod_or_letin_n : int -> rawconstr ->
+val raw_decompose_prod_or_letin_n : int -> rawconstr ->
(Names.name*rawconstr option*rawconstr option) list * rawconstr
-val raw_compose_prod : rawconstr -> (Names.name*rawconstr) list -> rawconstr
-val raw_compose_prod_or_letin: rawconstr ->
+val raw_compose_prod : rawconstr -> (Names.name*rawconstr) list -> rawconstr
+val raw_compose_prod_or_letin: rawconstr ->
(Names.name*rawconstr option*rawconstr option) list -> rawconstr
val raw_decompose_app : rawconstr -> rawconstr*(rawconstr list)
-(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *)
+(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *)
val raw_make_eq : ?typ:rawconstr -> rawconstr -> rawconstr -> rawconstr
-(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *)
+(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *)
val raw_make_neq : rawconstr -> rawconstr -> rawconstr
-(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *)
+(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *)
val raw_make_or : rawconstr -> rawconstr -> rawconstr
-(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding
- to [P1 \/ ( .... \/ Pn)]
-*)
+(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding
+ to [P1 \/ ( .... \/ Pn)]
+*)
val raw_make_or_list : rawconstr list -> rawconstr
@@ -64,8 +64,8 @@ val change_vars : Names.identifier Names.Idmap.t -> rawconstr -> rawconstr
-(* [alpha_pat avoid pat] rename all the variables present in [pat] s.t.
- the result does not share variables with [avoid]. This function create
+(* [alpha_pat avoid pat] rename all the variables present in [pat] s.t.
+ the result does not share variables with [avoid]. This function create
a fresh variable for each occurence of the anonymous pattern.
Also returns a mapping from old variables to new ones and the concatenation of
@@ -77,8 +77,8 @@ val change_vars : Names.identifier Names.Idmap.t -> rawconstr -> rawconstr
Rawterm.cases_pattern * Names.Idmap.key list *
Names.identifier Names.Idmap.t
-(* [alpha_rt avoid rt] alpha convert [rt] s.t. the result repects barendregt
- conventions and does not share bound variables with avoid
+(* [alpha_rt avoid rt] alpha convert [rt] s.t. the result repects barendregt
+ conventions and does not share bound variables with avoid
*)
val alpha_rt : Names.identifier list -> rawconstr -> rawconstr
@@ -90,35 +90,35 @@ val alpha_br : Names.identifier list ->
Rawterm.rawconstr
-(* Reduction function *)
-val replace_var_by_term :
+(* Reduction function *)
+val replace_var_by_term :
Names.identifier ->
Rawterm.rawconstr -> Rawterm.rawconstr -> Rawterm.rawconstr
-(*
+(*
[is_free_in id rt] checks if [id] is a free variable in [rt]
*)
val is_free_in : Names.identifier -> rawconstr -> bool
-val are_unifiable : cases_pattern -> cases_pattern -> bool
+val are_unifiable : cases_pattern -> cases_pattern -> bool
val eq_cases_pattern : cases_pattern -> cases_pattern -> bool
-(*
- ids_of_pat : cases_pattern -> Idset.t
- returns the set of variables appearing in a pattern
+(*
+ ids_of_pat : cases_pattern -> Idset.t
+ returns the set of variables appearing in a pattern
*)
-val ids_of_pat : cases_pattern -> Names.Idset.t
+val ids_of_pat : cases_pattern -> Names.Idset.t
(* TODO: finish this function (Fix not treated) *)
val ids_of_rawterm: rawconstr -> Names.Idset.t
-(*
- removing let_in construction in a rawterm
+(*
+ removing let_in construction in a rawterm
*)
val zeta_normalize : Rawterm.rawconstr -> Rawterm.rawconstr
diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml
index 876f3de4bf..92438db399 100644
--- a/plugins/funind/recdef.ml
+++ b/plugins/funind/recdef.ml
@@ -49,23 +49,23 @@ open Eauto
open Genarg
-let compute_renamed_type gls c =
+let compute_renamed_type gls c =
rename_bound_var (pf_env gls) [] (pf_type_of gls c)
-let qed () = Command.save_named true
+let qed () = Command.save_named true
let defined () = Command.save_named false
-let pf_get_new_ids idl g =
- let ids = pf_ids_of_hyps g in
+let pf_get_new_ids idl g =
+ let ids = pf_ids_of_hyps g in
List.fold_right
(fun id acc -> next_global_ident_away false id (acc@ids)::acc)
- idl
+ idl
[]
-let pf_get_new_id id g =
+let pf_get_new_id id g =
List.hd (pf_get_new_ids [id] g)
-let h_intros l =
+let h_intros l =
tclMAP h_intro l
let do_observe_tac s tac g =
@@ -73,12 +73,12 @@ let do_observe_tac s tac g =
try let v = tac g in msgnl (goal ++ fnl () ++ (str "recdef ") ++
(str s)++(str " ")++(str "finished")); v
with e ->
- msgnl (str "observation "++str s++str " raised exception " ++
- Cerrors.explain_exn e ++ str " on goal " ++ goal );
+ msgnl (str "observation "++str s++str " raised exception " ++
+ Cerrors.explain_exn e ++ str " on goal " ++ goal );
raise e;;
-let observe_tac s tac g =
+let observe_tac s tac g =
if Tacinterp.get_debug () <> Tactic_debug.DebugOff
then do_observe_tac s tac g
else tac g
@@ -114,11 +114,11 @@ let message s = if Flags.is_verbose () then msgnl(str s);;
let def_of_const t =
match (kind_of_term t) with
- Const sp ->
+ Const sp ->
(try (match (Global.lookup_constant sp) with
{const_body=Some c} -> Declarations.force c
|_ -> assert false)
- with _ ->
+ with _ ->
anomaly ("Cannot find definition of constant "^
(string_of_id (id_of_label (con_label sp))))
)
@@ -135,14 +135,14 @@ let arg_type t =
| _ -> assert false;;
let evaluable_of_global_reference r =
- match r with
+ match r with
ConstRef sp -> EvalConstRef sp
| VarRef id -> EvalVarRef id
| _ -> assert false;;
-let rank_for_arg_list h =
- let predicate a b =
+let rank_for_arg_list h =
+ let predicate a b =
try List.for_all2 eq_constr a b with
Invalid_argument _ -> false in
let rec rank_aux i = function
@@ -150,11 +150,11 @@ let rank_for_arg_list h =
| x::tl -> if predicate h x then Some i else rank_aux (i+1) tl in
rank_aux 0;;
-let rec (find_call_occs : int -> constr -> constr ->
+let rec (find_call_occs : int -> constr -> constr ->
(constr list -> constr) * constr list list) =
fun nb_lam f expr ->
match (kind_of_term expr) with
- App (g, args) when g = f ->
+ App (g, args) when g = f ->
(fun l -> List.hd l), [Array.to_list args]
| App (g, args) ->
let (largs: constr list) = Array.to_list args in
@@ -162,17 +162,17 @@ let rec (find_call_occs : int -> constr -> constr ->
[] -> (fun x -> []), []
| a::upper_tl ->
(match find_aux upper_tl with
- (cf, ((arg1::args) as args_for_upper_tl)) ->
+ (cf, ((arg1::args) as args_for_upper_tl)) ->
(match find_call_occs nb_lam f a with
cf2, (_ :: _ as other_args) ->
let rec avoid_duplicates args =
match args with
| [] -> (fun _ -> []), []
- | h::tl ->
+ | h::tl ->
let recomb_tl, args_for_tl =
avoid_duplicates tl in
match rank_for_arg_list h args_for_upper_tl with
- | None ->
+ | None ->
(fun l -> List.hd l::recomb_tl(List.tl l)),
h::args_for_tl
| Some i ->
@@ -182,7 +182,7 @@ let rec (find_call_occs : int -> constr -> constr ->
in
let recombine, other_args' =
avoid_duplicates other_args in
- let len1 = List.length other_args' in
+ let len1 = List.length other_args' in
(fun l -> cf2 (recombine l)::cf(nthtl(l,len1))),
other_args'@args_for_upper_tl
| _, [] -> (fun x -> a::cf x), args_for_upper_tl)
@@ -203,22 +203,22 @@ let rec (find_call_occs : int -> constr -> constr ->
| Sort(_) -> (fun l -> expr), []
| Cast(b,_,_) -> find_call_occs nb_lam f b
| Prod(_,_,_) -> error "find_call_occs : Prod"
- | Lambda(na,t,b) ->
+ | Lambda(na,t,b) ->
begin
- match find_call_occs (succ nb_lam) f b with
- | _, [] -> (* Lambda are authorized as long as they do not contain
+ match find_call_occs (succ nb_lam) f b with
+ | _, [] -> (* Lambda are authorized as long as they do not contain
recursives calls *)
(fun l -> expr),[]
| _ -> error "find_call_occs : Lambda"
end
- | LetIn(na,v,t,b) ->
+ | LetIn(na,v,t,b) ->
begin
- match find_call_occs nb_lam f v, find_call_occs (succ nb_lam) f b with
- | (_,[]),(_,[]) ->
+ match find_call_occs nb_lam f v, find_call_occs (succ nb_lam) f b with
+ | (_,[]),(_,[]) ->
((fun l -> expr), [])
- | (_,[]),(cf,(_::_ as l)) ->
+ | (_,[]),(cf,(_::_ as l)) ->
((fun l -> mkLetIn(na,v,t,cf l)),l)
- | (cf,(_::_ as l)),(_,[]) ->
+ | (cf,(_::_ as l)),(_,[]) ->
((fun l -> mkLetIn(na,cf l,t,b)), l)
| _ -> error "find_call_occs : LetIn"
end
@@ -233,17 +233,17 @@ let rec (find_call_occs : int -> constr -> constr ->
| CoFix(_) -> error "find_call_occs : CoFix";;
let coq_constant s =
- Coqlib.gen_constant_in_modules "RecursiveDefinition"
+ Coqlib.gen_constant_in_modules "RecursiveDefinition"
(Coqlib.init_modules @ Coqlib.arith_modules) s;;
let constant sl s =
constr_of_global
- (locate (make_qualid(Names.make_dirpath
+ (locate (make_qualid(Names.make_dirpath
(List.map id_of_string (List.rev sl)))
(id_of_string s)));;
let find_reference sl s =
- (locate (make_qualid(Names.make_dirpath
+ (locate (make_qualid(Names.make_dirpath
(List.map id_of_string (List.rev sl)))
(id_of_string s)));;
@@ -295,7 +295,7 @@ let mkCaseEq a : tactic =
tclTHENLIST
[h_generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])];
(fun g2 ->
- change_in_concl None
+ change_in_concl None
(pattern_occs [((false,[1]), a)] (pf_env g2) Evd.empty (pf_concl g2))
g2);
simplest_case a] g);;
@@ -308,21 +308,21 @@ let mkCaseEq a : tactic =
let mkDestructEq :
identifier list -> constr -> goal sigma -> tactic * identifier list =
fun not_on_hyp expr g ->
- let hyps = pf_hyps g in
- let to_revert =
- Util.map_succeed
- (fun (id,_,t) ->
+ let hyps = pf_hyps g in
+ let to_revert =
+ Util.map_succeed
+ (fun (id,_,t) ->
if List.mem id not_on_hyp || not (Termops.occur_term expr t)
then failwith "is_expr_context";
id) hyps in
- let to_revert_constr = List.rev_map mkVar to_revert in
+ let to_revert_constr = List.rev_map mkVar to_revert in
let type_of_expr = pf_type_of g expr in
let new_hyps = mkApp(delayed_force refl_equal, [|type_of_expr; expr|])::
to_revert_constr in
tclTHENLIST
[h_generalize new_hyps;
(fun g2 ->
- change_in_concl None
+ change_in_concl None
(pattern_occs [((false,[1]), expr)] (pf_env g2) Evd.empty (pf_concl g2)) g2);
simplest_case expr], to_revert
@@ -334,15 +334,15 @@ let rec mk_intros_and_continue thin_intros (extra_eqn:bool)
[ h_intro teq;
thin thin_intros;
h_intros thin_intros;
-
- tclMAP
- (fun eq -> tclTRY (Equality.general_rewrite_in true all_occurrences teq eq false))
+
+ tclMAP
+ (fun eq -> tclTRY (Equality.general_rewrite_in true all_occurrences teq eq false))
(List.rev eqs);
- (fun g1 ->
- let ty_teq = pf_type_of g1 (mkVar teq) in
- let teq_lhs,teq_rhs =
- let _,args = try destApp ty_teq with _ -> Pp.msgnl (Printer.pr_goal (sig_it g1) ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false in
- args.(1),args.(2)
+ (fun g1 ->
+ let ty_teq = pf_type_of g1 (mkVar teq) in
+ let teq_lhs,teq_rhs =
+ let _,args = try destApp ty_teq with _ -> Pp.msgnl (Printer.pr_goal (sig_it g1) ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false in
+ args.(1),args.(2)
in
cont_function (mkVar teq::eqs) (replace_term teq_lhs teq_rhs expr) g1
)
@@ -352,32 +352,32 @@ let rec mk_intros_and_continue thin_intros (extra_eqn:bool)
tclTHENSEQ[
thin thin_intros;
h_intros thin_intros;
- cont_function eqs expr
+ cont_function eqs expr
] g
in
- if nb_lam = 0
- then finalize ()
+ if nb_lam = 0
+ then finalize ()
else
match kind_of_term expr with
- | Lambda (n, _, b) ->
- let n1 =
+ | Lambda (n, _, b) ->
+ let n1 =
match n with
Name x -> x
| Anonymous -> ano_id
in
let new_n = pf_get_new_id n1 g in
tclTHEN (h_intro new_n)
- (mk_intros_and_continue thin_intros extra_eqn cont_function eqs
+ (mk_intros_and_continue thin_intros extra_eqn cont_function eqs
(pred nb_lam) (subst1 (mkVar new_n) b)) g
- | _ ->
- assert false
+ | _ ->
+ assert false
(* finalize () *)
let const_of_ref = function
ConstRef kn -> kn
| _ -> anomaly "ConstRef expected"
let simpl_iter clause =
- reduce
+ reduce
(Lazy
{rBeta=true;rIota=true;rZeta= true; rDelta=false;
rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]})
@@ -386,16 +386,16 @@ let simpl_iter clause =
(* The boolean value is_mes expresses that the termination is expressed
using a measure function instead of a well-founded relation. *)
-let tclUSER tac is_mes l g =
- let clear_tac =
- match l with
+let tclUSER tac is_mes l g =
+ let clear_tac =
+ match l with
| None -> h_clear true []
| Some l -> tclMAP (fun id -> tclTRY (h_clear false [id])) (List.rev l)
in
- tclTHENSEQ
+ tclTHENSEQ
[
clear_tac;
- if is_mes
+ if is_mes
then tclTHEN
(unfold_in_concl [(all_occurrences, evaluable_of_global_reference
(delayed_force ltof_ref))])
@@ -403,8 +403,8 @@ let tclUSER tac is_mes l g =
else tac
]
g
-
-
+
+
let list_rewrite (rev:bool) (eqs: constr list) =
tclREPEAT
(List.fold_right
@@ -414,8 +414,8 @@ let list_rewrite (rev:bool) (eqs: constr list) =
let base_leaf_terminate (func:global_reference) eqs expr =
(* let _ = msgnl (str "entering base_leaf") in *)
(fun g ->
- let k',h =
- match pf_get_new_ids [k_id;h_id] g with
+ let k',h =
+ match pf_get_new_ids [k_id;h_id] g with
[k';h] -> k',h
| _ -> assert false
in
@@ -424,9 +424,9 @@ let base_leaf_terminate (func:global_reference) eqs expr =
observe_tac "second split"
(split (ImplicitBindings [delayed_force coq_O]));
observe_tac "intro k" (h_intro k');
- observe_tac "case on k"
+ observe_tac "case on k"
(tclTHENS (simplest_case (mkVar k'))
- [(tclTHEN (h_intro h)
+ [(tclTHEN (h_intro h)
(tclTHEN (simplest_elim (mkApp (delayed_force gt_antirefl,
[| delayed_force coq_O |])))
default_auto)); tclIDTAC ]);
@@ -436,63 +436,63 @@ let base_leaf_terminate (func:global_reference) eqs expr =
list_rewrite true eqs;
default_auto] g);;
-(* La fonction est donnee en premier argument a la
+(* La fonction est donnee en premier argument a la
fonctionnelle suivie d'autres Lambdas et de Case ...
- Pour recuperer la fonction f a partir de la
+ Pour recuperer la fonction f a partir de la
fonctionnelle *)
-let get_f foncl =
+let get_f foncl =
match (kind_of_term (def_of_const foncl)) with
- Lambda (Name f, _, _) -> f
+ Lambda (Name f, _, _) -> f
|_ -> error "la fonctionnelle est mal definie";;
let rec compute_le_proofs = function
[] -> assumption
| a::tl ->
- tclORELSE assumption
+ tclORELSE assumption
(tclTHENS
- (fun g ->
- let le_trans = delayed_force le_trans in
- let t_le_trans = compute_renamed_type g le_trans in
- let m_id =
- let _,_,t = destProd t_le_trans in
- let na,_,_ = destProd t in
+ (fun g ->
+ let le_trans = delayed_force le_trans in
+ let t_le_trans = compute_renamed_type g le_trans in
+ let m_id =
+ let _,_,t = destProd t_le_trans in
+ let na,_,_ = destProd t in
Nameops.out_name na
in
apply_with_bindings
(le_trans,
ExplicitBindings[dummy_loc,NamedHyp m_id,a])
g)
- [compute_le_proofs tl;
+ [compute_le_proofs tl;
tclORELSE (apply (delayed_force le_n)) assumption])
let make_lt_proof pmax le_proof =
tclTHENS
- (fun g ->
- let le_lt_trans = delayed_force le_lt_trans in
- let t_le_lt_trans = compute_renamed_type g le_lt_trans in
- let m_id =
- let _,_,t = destProd t_le_lt_trans in
- let na,_,_ = destProd t in
+ (fun g ->
+ let le_lt_trans = delayed_force le_lt_trans in
+ let t_le_lt_trans = compute_renamed_type g le_lt_trans in
+ let m_id =
+ let _,_,t = destProd t_le_lt_trans in
+ let na,_,_ = destProd t in
Nameops.out_name na
in
apply_with_bindings
(le_lt_trans,
ExplicitBindings[dummy_loc,NamedHyp m_id, pmax]) g)
- [observe_tac "compute_le_proofs" (compute_le_proofs le_proof);
+ [observe_tac "compute_le_proofs" (compute_le_proofs le_proof);
tclTHENLIST[observe_tac "lt_S_n" (apply (delayed_force lt_S_n)); default_full_auto]];;
let rec list_cond_rewrite k def pmax cond_eqs le_proofs =
match cond_eqs with
[] -> tclIDTAC
| eq::eqs ->
- (fun g ->
- let t_eq = compute_renamed_type g (mkVar eq) in
- let k_id,def_id =
- let k_na,_,t = destProd t_eq in
- let _,_,t = destProd t in
- let def_na,_,_ = destProd t in
+ (fun g ->
+ let t_eq = compute_renamed_type g (mkVar eq) in
+ let k_id,def_id =
+ let k_na,_,t = destProd t_eq in
+ let _,_,t = destProd t in
+ let def_na,_,_ = destProd t in
Nameops.out_name k_na,Nameops.out_name def_na
in
tclTHENS
@@ -502,12 +502,12 @@ let rec list_cond_rewrite k def pmax cond_eqs le_proofs =
dummy_loc, NamedHyp def_id, mkVar def]) false)
[list_cond_rewrite k def pmax eqs le_proofs;
observe_tac "make_lt_proof" (make_lt_proof pmax le_proofs)] g
- )
+ )
-let rec introduce_all_equalities func eqs values specs bound le_proofs
+let rec introduce_all_equalities func eqs values specs bound le_proofs
cond_eqs =
match specs with
- [] ->
+ [] ->
fun g ->
let ids = pf_ids_of_hyps g in
let s_max = mkApp(delayed_force coq_S, [|bound|]) in
@@ -530,9 +530,9 @@ let rec introduce_all_equalities func eqs values specs bound le_proofs
observe_tac "clearing k " (clear [k]);
observe_tac "intros k h' def" (h_intros [k;h';def]);
observe_tac "simple_iter" (simpl_iter onConcl);
- observe_tac "unfold functional"
+ observe_tac "unfold functional"
(unfold_in_concl[((true,[1]),evaluable_of_global_reference func)]);
- observe_tac "rewriting equations"
+ observe_tac "rewriting equations"
(list_rewrite true eqs);
observe_tac ("cond rewrite "^(string_of_id k)) (list_cond_rewrite k def bound cond_eqs le_proofs);
observe_tac "refl equal" (apply (delayed_force refl_equal))] g
@@ -554,29 +554,29 @@ let rec introduce_all_equalities func eqs values specs bound le_proofs
h_intros [p; heq];
simplest_elim (mkApp(delayed_force max_constr, [| bound; mkVar p|]));
h_intros [pmax; hle1; hle2];
- introduce_all_equalities func eqs values specs
+ introduce_all_equalities func eqs values specs
(mkVar pmax) ((mkVar pmax)::le_proofs)
(heq::cond_eqs)] g;;
-
+
let string_match s =
if String.length s < 3 then failwith "string_match";
- try
+ try
for i = 0 to 3 do
if String.get s i <> String.get "Acc_" i then failwith "string_match"
done;
with Invalid_argument _ -> failwith "string_match"
-
-let retrieve_acc_var g =
- (* Julien: I don't like this version .... *)
- let hyps = pf_ids_of_hyps g in
- map_succeed
+
+let retrieve_acc_var g =
+ (* Julien: I don't like this version .... *)
+ let hyps = pf_ids_of_hyps g in
+ map_succeed
(fun id -> string_match (string_of_id id);id)
- hyps
+ hyps
let rec introduce_all_values concl_tac is_mes acc_inv func context_fn
eqs hrec args values specs =
(match args with
- [] ->
+ [] ->
tclTHENLIST
[observe_tac "split" (split(ImplicitBindings
[context_fn (List.map mkVar (List.rev values))]));
@@ -588,17 +588,17 @@ let rec introduce_all_values concl_tac is_mes acc_inv func context_fn
let rec_res = next_global_ident_away true rec_res_id ids in
let ids = rec_res::ids in
let hspec = next_global_ident_away true hspec_id ids in
- let tac =
+ let tac =
observe_tac "introduce_all_values" (
introduce_all_values concl_tac is_mes acc_inv func context_fn eqs
hrec args
(rec_res::values)(hspec::specs)) in
(tclTHENS
- (observe_tac "elim h_rec"
+ (observe_tac "elim h_rec"
(simplest_elim (mkApp(mkVar hrec, Array.of_list arg)))
)
[tclTHENLIST [h_intros [rec_res; hspec];
- tac];
+ tac];
(tclTHENS
(observe_tac "acc_inv" (apply (Lazy.force acc_inv)))
[(* tclTHEN (tclTRY(list_rewrite true eqs)) *)
@@ -607,126 +607,126 @@ let rec introduce_all_values concl_tac is_mes acc_inv func context_fn
tclTHENLIST
[
tclTRY(list_rewrite true eqs);
- observe_tac "user proof"
- (fun g ->
+ observe_tac "user proof"
+ (fun g ->
tclUSER
concl_tac
is_mes
(Some (hrec::hspec::(retrieve_acc_var g)@specs))
g
- )
+ )
]
]
)
]) g)
-
+
)
-
-
+
+
let rec_leaf_terminate f_constr concl_tac is_mes acc_inv hrec (func:global_reference) eqs expr =
match find_call_occs 0 f_constr expr with
| context_fn, args ->
- observe_tac "introduce_all_values"
+ observe_tac "introduce_all_values"
(introduce_all_values concl_tac is_mes acc_inv func context_fn eqs hrec args [] [])
-let proveterminate rec_arg_id is_mes acc_inv (hrec:identifier)
- (f_constr:constr) (func:global_reference) base_leaf rec_leaf =
+let proveterminate rec_arg_id is_mes acc_inv (hrec:identifier)
+ (f_constr:constr) (func:global_reference) base_leaf rec_leaf =
let rec proveterminate (eqs:constr list) (expr:constr) =
try
(* let _ = msgnl (str "entering proveterminate") in *)
let v =
match (kind_of_term expr) with
- Case (ci, t, a, l) ->
+ Case (ci, t, a, l) ->
(match find_call_occs 0 f_constr a with
_,[] ->
- (fun g ->
+ (fun g ->
let destruct_tac, rev_to_thin_intro =
- mkDestructEq rec_arg_id a g in
+ mkDestructEq rec_arg_id a g in
tclTHENS destruct_tac
- (list_map_i
- (fun i -> mk_intros_and_continue
- (List.rev rev_to_thin_intro)
- true
- proveterminate
+ (list_map_i
+ (fun i -> mk_intros_and_continue
+ (List.rev rev_to_thin_intro)
+ true
+ proveterminate
eqs
ci.ci_cstr_nargs.(i))
0 (Array.to_list l)) g)
- | _, _::_ ->
+ | _, _::_ ->
(match find_call_occs 0 f_constr expr with
_,[] -> observe_tac "base_leaf" (base_leaf func eqs expr)
- | _, _:: _ ->
- observe_tac "rec_leaf"
+ | _, _:: _ ->
+ observe_tac "rec_leaf"
(rec_leaf is_mes acc_inv hrec func eqs expr)))
| _ ->
(match find_call_occs 0 f_constr expr with
- _,[] ->
+ _,[] ->
(try observe_tac "base_leaf" (base_leaf func eqs expr)
with e -> (msgerrnl (str "failure in base case");raise e ))
- | _, _::_ ->
+ | _, _::_ ->
observe_tac "rec_leaf"
(rec_leaf is_mes acc_inv hrec func eqs expr)) in
v
with e -> begin msgerrnl(str "failure in proveterminate"); raise e end
- in
- proveterminate
-
-let hyp_terminates nb_args func =
- let a_arrow_b = arg_type (constr_of_global func) in
- let rev_args,b = decompose_prod_n nb_args a_arrow_b in
- let left =
- mkApp(delayed_force iter,
- Array.of_list
+ in
+ proveterminate
+
+let hyp_terminates nb_args func =
+ let a_arrow_b = arg_type (constr_of_global func) in
+ let rev_args,b = decompose_prod_n nb_args a_arrow_b in
+ let left =
+ mkApp(delayed_force iter,
+ Array.of_list
(lift 5 a_arrow_b:: mkRel 3::
constr_of_global func::mkRel 1::
List.rev (list_map_i (fun i _ -> mkRel (6+i)) 0 rev_args)
)
)
in
- let right = mkRel 5 in
+ let right = mkRel 5 in
let equality = mkApp(delayed_force eq, [|lift 5 b; left; right|]) in
let result = (mkProd ((Name def_id) , lift 4 a_arrow_b, equality)) in
let cond = mkApp(delayed_force lt, [|(mkRel 2); (mkRel 1)|]) in
let nb_iter =
mkApp(delayed_force ex,
[|delayed_force nat;
- (mkLambda
+ (mkLambda
(Name
p_id,
- delayed_force nat,
- (mkProd (Name k_id, delayed_force nat,
+ delayed_force nat,
+ (mkProd (Name k_id, delayed_force nat,
mkArrow cond result))))|])in
- let value = mkApp(delayed_force coq_sig,
+ let value = mkApp(delayed_force coq_sig,
[|b;
(mkLambda (Name v_id, b, nb_iter))|]) in
compose_prod rev_args value
-
-let tclUSER_if_not_mes concl_tac is_mes names_to_suppress =
- if is_mes
+
+let tclUSER_if_not_mes concl_tac is_mes names_to_suppress =
+ if is_mes
then tclCOMPLETE (h_simplest_apply (delayed_force well_founded_ltof))
else tclUSER concl_tac is_mes names_to_suppress
let termination_proof_header is_mes input_type ids args_id relation
- rec_arg_num rec_arg_id tac wf_tac : tactic =
- begin
- fun g ->
+ rec_arg_num rec_arg_id tac wf_tac : tactic =
+ begin
+ fun g ->
let nargs = List.length args_id in
- let pre_rec_args =
+ let pre_rec_args =
List.rev_map
- mkVar (fst (list_chop (rec_arg_num - 1) args_id))
- in
- let relation = substl pre_rec_args relation in
- let input_type = substl pre_rec_args input_type in
- let wf_thm = next_global_ident_away true (id_of_string ("wf_R")) ids in
- let wf_rec_arg =
- next_global_ident_away true
+ mkVar (fst (list_chop (rec_arg_num - 1) args_id))
+ in
+ let relation = substl pre_rec_args relation in
+ let input_type = substl pre_rec_args input_type in
+ let wf_thm = next_global_ident_away true (id_of_string ("wf_R")) ids in
+ let wf_rec_arg =
+ next_global_ident_away true
(id_of_string ("Acc_"^(string_of_id rec_arg_id)))
- (wf_thm::ids)
- in
+ (wf_thm::ids)
+ in
let hrec = next_global_ident_away true hrec_id
- (wf_rec_arg::wf_thm::ids) in
- let acc_inv =
+ (wf_rec_arg::wf_thm::ids) in
+ let acc_inv =
lazy (
mkApp (
delayed_force acc_inv_id,
@@ -737,40 +737,40 @@ let termination_proof_header is_mes input_type ids args_id relation
tclTHEN
(h_intros args_id)
(tclTHENS
- (observe_tac
- "first assert"
- (assert_tac
- (Name wf_rec_arg)
+ (observe_tac
+ "first assert"
+ (assert_tac
+ (Name wf_rec_arg)
(mkApp (delayed_force acc_rel,
[|input_type;relation;mkVar rec_arg_id|])
)
)
)
[
- (* accesibility proof *)
- tclTHENS
- (observe_tac
- "second assert"
- (assert_tac
+ (* accesibility proof *)
+ tclTHENS
+ (observe_tac
+ "second assert"
+ (assert_tac
(Name wf_thm)
(mkApp (delayed_force well_founded,[|input_type;relation|]))
)
)
- [
+ [
(* interactive proof that the relation is well_founded *)
observe_tac "wf_tac" (wf_tac is_mes (Some args_id));
(* this gives the accessibility argument *)
- observe_tac
- "apply wf_thm"
+ observe_tac
+ "apply wf_thm"
(h_simplest_apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))
)
]
;
(* rest of the proof *)
- tclTHENSEQ
- [observe_tac "generalize"
+ tclTHENSEQ
+ [observe_tac "generalize"
(onNLastHypsId (nargs+1)
- (tclMAP (fun id ->
+ (tclMAP (fun id ->
tclTHEN (h_generalize [mkVar id]) (h_clear false [id]))
))
;
@@ -780,23 +780,23 @@ let termination_proof_header is_mes input_type ids args_id relation
observe_tac "tac" (tac wf_rec_arg hrec acc_inv)
]
]
- ) g
+ ) g
end
-let rec instantiate_lambda t l =
+let rec instantiate_lambda t l =
match l with
| [] -> t
- | a::l ->
+ | a::l ->
let (bound_name, _, body) = destLambda t in
instantiate_lambda (subst1 a body) l
;;
-let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num : tactic =
- begin
- fun g ->
+let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num : tactic =
+ begin
+ fun g ->
let ids = ids_of_named_context (pf_hyps g) in
let func_body = (def_of_const (constr_of_global func)) in
let (f_name, _, body1) = destLambda func_body in
@@ -805,13 +805,13 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a
| Name f_id -> next_global_ident_away true f_id ids
| Anonymous -> anomaly "Anonymous function"
in
- let n_names_types,_ = decompose_lam_n nb_args body1 in
- let n_ids,ids =
- List.fold_left
- (fun (n_ids,ids) (n_name,_) ->
- match n_name with
- | Name id ->
- let n_id = next_global_ident_away true id ids in
+ let n_names_types,_ = decompose_lam_n nb_args body1 in
+ let n_ids,ids =
+ List.fold_left
+ (fun (n_ids,ids) (n_name,_) ->
+ match n_name with
+ | Name id ->
+ let n_id = next_global_ident_away true id ids in
n_id::n_ids,n_id::ids
| _ -> anomaly "anonymous argument"
)
@@ -819,151 +819,151 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a
n_names_types
in
let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in
- let expr = instantiate_lambda func_body (mkVar f_id::(List.map mkVar n_ids)) in
- termination_proof_header
+ let expr = instantiate_lambda func_body (mkVar f_id::(List.map mkVar n_ids)) in
+ termination_proof_header
is_mes
input_type
ids
n_ids
- relation
+ relation
rec_arg_num
rec_arg_id
- (fun rec_arg_id hrec acc_inv g ->
- (proveterminate
+ (fun rec_arg_id hrec acc_inv g ->
+ (proveterminate
[rec_arg_id]
is_mes
- acc_inv
+ acc_inv
hrec
(mkVar f_id)
func
- base_leaf_terminate
+ base_leaf_terminate
(rec_leaf_terminate (mkVar f_id) concl_tac)
[]
expr
)
- g
+ g
)
(tclUSER_if_not_mes concl_tac)
- g
+ g
end
-let get_current_subgoals_types () =
- let pts = get_pftreestate () in
- let _,subs = extract_open_pftreestate pts in
+let get_current_subgoals_types () =
+ let pts = get_pftreestate () in
+ let _,subs = extract_open_pftreestate pts in
List.map snd ((* List.sort (fun (x,_) (y,_) -> x -y ) *)subs )
-let build_and_l l =
- let and_constr = Coqlib.build_coq_and () in
- let conj_constr = coq_conj () in
- let mk_and p1 p2 =
- Term.mkApp(and_constr,[|p1;p2|]) in
- let rec f = function
- | [] -> failwith "empty list of subgoals!"
- | [p] -> p,tclIDTAC,1
- | p1::pl ->
- let c,tac,nb = f pl in
- mk_and p1 c,
+let build_and_l l =
+ let and_constr = Coqlib.build_coq_and () in
+ let conj_constr = coq_conj () in
+ let mk_and p1 p2 =
+ Term.mkApp(and_constr,[|p1;p2|]) in
+ let rec f = function
+ | [] -> failwith "empty list of subgoals!"
+ | [p] -> p,tclIDTAC,1
+ | p1::pl ->
+ let c,tac,nb = f pl in
+ mk_and p1 c,
tclTHENS
- (apply (constr_of_global conj_constr))
+ (apply (constr_of_global conj_constr))
[tclIDTAC;
tac
],nb+1
in f l
-let is_rec_res id =
- let rec_res_name = string_of_id rec_res_id in
- let id_name = string_of_id id in
- try
- String.sub id_name 0 (String.length rec_res_name) = rec_res_name
+let is_rec_res id =
+ let rec_res_name = string_of_id rec_res_id in
+ let id_name = string_of_id id in
+ try
+ String.sub id_name 0 (String.length rec_res_name) = rec_res_name
with _ -> false
-let clear_goals =
- let rec clear_goal t =
- match kind_of_term t with
- | Prod(Name id as na,t,b) ->
- let b' = clear_goal b in
- if noccurn 1 b' && (is_rec_res id)
- then pop b'
- else if b' == b then t
+let clear_goals =
+ let rec clear_goal t =
+ match kind_of_term t with
+ | Prod(Name id as na,t,b) ->
+ let b' = clear_goal b in
+ if noccurn 1 b' && (is_rec_res id)
+ then pop b'
+ else if b' == b then t
else mkProd(na,t,b')
| _ -> map_constr clear_goal t
- in
- List.map clear_goal
+ in
+ List.map clear_goal
-let build_new_goal_type () =
- let sub_gls_types = get_current_subgoals_types () in
- let sub_gls_types = clear_goals sub_gls_types in
- let res = build_and_l sub_gls_types in
+let build_new_goal_type () =
+ let sub_gls_types = get_current_subgoals_types () in
+ let sub_gls_types = clear_goals sub_gls_types in
+ let res = build_and_l sub_gls_types in
res
-
+
(*
-let prove_with_tcc lemma _ : tactic =
+let prove_with_tcc lemma _ : tactic =
fun gls ->
- let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in
- tclTHENSEQ
+ let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in
+ tclTHENSEQ
[
h_generalize [lemma];
h_intro hid;
- Elim.h_decompose_and (mkVar hid);
+ Elim.h_decompose_and (mkVar hid);
gen_eauto(* default_eauto *) false (false,5) [] (Some [])
(* default_auto *)
]
gls
*)
-
-
-let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) =
+
+
+let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) =
let current_proof_name = get_current_proof_name () in
- let name = match goal_name with
- | Some s -> s
- | None ->
- try (add_suffix current_proof_name "_subproof")
+ let name = match goal_name with
+ | Some s -> s
+ | None ->
+ try (add_suffix current_proof_name "_subproof")
with _ -> anomaly "open_new_goal with an unamed theorem"
- in
+ in
let sign = Global.named_context () in
let sign = clear_proofs sign in
let na = next_global_ident_away false name [] in
if occur_existential gls_type then
Util.error "\"abstract\" cannot handle existentials";
- let hook _ _ =
- let opacity =
- let na_ref = Libnames.Ident (dummy_loc,na) in
+ let hook _ _ =
+ let opacity =
+ let na_ref = Libnames.Ident (dummy_loc,na) in
let na_global = Nametab.global na_ref in
- match na_global with
- ConstRef c ->
- let cb = Global.lookup_constant c in
- if cb.Declarations.const_opaque then true
- else begin match cb.const_body with None -> true | _ -> false end
+ match na_global with
+ ConstRef c ->
+ let cb = Global.lookup_constant c in
+ if cb.Declarations.const_opaque then true
+ else begin match cb.const_body with None -> true | _ -> false end
| _ -> anomaly "equation_lemma: not a constant"
in
- let lemma = mkConst (Lib.make_con na) in
+ let lemma = mkConst (Lib.make_con na) in
ref_ := Some lemma ;
- let lid = ref [] in
- let h_num = ref (-1) in
+ let lid = ref [] in
+ let h_num = ref (-1) in
Flags.silently Vernacentries.interp (Vernacexpr.VernacAbort None);
- build_proof
+ build_proof
( fun gls ->
- let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in
- tclTHENSEQ
+ let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in
+ tclTHENSEQ
[
h_generalize [lemma];
h_intro hid;
- (fun g ->
- let ids = pf_ids_of_hyps g in
+ (fun g ->
+ let ids = pf_ids_of_hyps g in
tclTHEN
(Elim.h_decompose_and (mkVar hid))
- (fun g ->
- let ids' = pf_ids_of_hyps g in
+ (fun g ->
+ let ids' = pf_ids_of_hyps g in
lid := List.rev (list_subtract ids' ids);
if !lid = [] then lid := [hid];
tclIDTAC g
)
g
- );
+ );
] gls)
(fun g ->
match kind_of_term (pf_concl g) with
@@ -977,7 +977,7 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_
tclFIRST[
tclTHEN
(eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings))
- e_assumption;
+ e_assumption;
Eauto.eauto_with_bases
false
(true,5)
@@ -993,24 +993,24 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_
in
start_proof
na
- (Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma)
+ (Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma)
sign
- gls_type
+ gls_type
hook ;
if Indfun_common.is_strict_tcc ()
then
- by (tclIDTAC)
+ by (tclIDTAC)
else by (
- fun g ->
- tclTHEN
+ fun g ->
+ tclTHEN
(decompose_and_tac)
- (tclORELSE
- (tclFIRST
+ (tclORELSE
+ (tclFIRST
(List.map
- (fun c ->
+ (fun c ->
tclTHENSEQ
- [intros;
- h_simplest_apply (interp_constr Evd.empty (Global.env()) c);
+ [intros;
+ h_simplest_apply (interp_constr Evd.empty (Global.env()) c);
tclCOMPLETE Auto.default_auto
]
)
@@ -1020,24 +1020,24 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_
try
by tclIDTAC; (* raises UserError _ if the proof is complete *)
if Flags.is_verbose () then (pp (Printer.pr_open_subgoals()))
- with UserError _ ->
+ with UserError _ ->
defined ()
-
-;;
+
+;;
-let com_terminate
- tcc_lemma_name
- tcc_lemma_ref
- is_mes
+let com_terminate
+ tcc_lemma_name
+ tcc_lemma_ref
+ is_mes
fonctional_ref
input_type
- relation
+ relation
rec_arg_num
- thm_name using_lemmas
+ thm_name using_lemmas
nb_args
hook =
- let start_proof (tac_start:tactic) (tac_end:tactic) =
+ let start_proof (tac_start:tactic) (tac_end:tactic) =
let (evmap, env) = Command.get_current_context() in
start_proof thm_name
(Global, Proof Lemma) (Environ.named_context_val env)
@@ -1045,45 +1045,45 @@ let com_terminate
by (observe_tac "starting_tac" tac_start);
by (observe_tac "whole_start" (whole_start tac_end nb_args is_mes fonctional_ref
input_type relation rec_arg_num ))
-
+
in
start_proof tclIDTAC tclIDTAC;
- try
- let new_goal_type = build_new_goal_type () in
+ try
+ let new_goal_type = build_new_goal_type () in
open_new_goal start_proof using_lemmas tcc_lemma_ref
(Some tcc_lemma_name)
(new_goal_type)
- with Failure "empty list of subgoals!" ->
+ with Failure "empty list of subgoals!" ->
(* a non recursive function declared with measure ! *)
defined ()
-
-
-let ind_of_ref = function
+
+
+let ind_of_ref = function
| IndRef (ind,i) -> (ind,i)
| _ -> anomaly "IndRef expected"
let (value_f:constr list -> global_reference -> constr) =
fun al fterm ->
- let d0 = dummy_loc in
- let rev_x_id_l =
+ let d0 = dummy_loc in
+ let rev_x_id_l =
(
- List.fold_left
- (fun x_id_l _ ->
- let x_id = next_global_ident_away true x_id x_id_l in
+ List.fold_left
+ (fun x_id_l _ ->
+ let x_id = next_global_ident_away true x_id x_id_l in
x_id::x_id_l
)
[]
al
)
in
- let fun_body =
+ let fun_body =
RCases
(d0,RegularStyle,None,
[RApp(d0, RRef(d0,fterm), List.rev_map (fun x_id -> RVar(d0, x_id)) rev_x_id_l),
(Anonymous,None)],
- [d0, [v_id], [PatCstr(d0,(ind_of_ref
+ [d0, [v_id], [PatCstr(d0,(ind_of_ref
(delayed_force coq_sig_ref),1),
[PatVar(d0, Name v_id);
PatVar(d0, Anonymous)],
@@ -1091,12 +1091,12 @@ let (value_f:constr list -> global_reference -> constr) =
RVar(d0,v_id)])
in
let value =
- List.fold_left2
- (fun acc x_id a ->
+ List.fold_left2
+ (fun acc x_id a ->
RLambda
(d0, Name x_id, Explicit, RDynamic(d0, constr_in a),
acc
- )
+ )
)
fun_body
rev_x_id_l
@@ -1121,16 +1121,16 @@ let rec n_x_id ids n =
else let x = next_global_ident_away true x_id ids in
x::n_x_id (x::ids) (n-1);;
-let start_equation (f:global_reference) (term_f:global_reference)
+let start_equation (f:global_reference) (term_f:global_reference)
(cont_tactic:identifier list -> tactic) g =
let ids = pf_ids_of_hyps g in
- let terminate_constr = constr_of_global term_f in
- let nargs = nb_prod (type_of_const terminate_constr) in
+ let terminate_constr = constr_of_global term_f in
+ let nargs = nb_prod (type_of_const terminate_constr) in
let x = n_x_id ids nargs in
tclTHENLIST [
h_intros x;
unfold_in_concl [(all_occurrences, evaluable_of_global_reference f)];
- observe_tac "simplest_case"
+ observe_tac "simplest_case"
(simplest_case (mkApp (terminate_constr,
Array.of_list (List.map mkVar x))));
observe_tac "prove_eq" (cont_tactic x)] g;;
@@ -1144,12 +1144,12 @@ let base_leaf_eq func eqs f_id g =
let heq1 = next_global_ident_away true heq_id (heq::v::p::k::ids) in
let hex = next_global_ident_away true hex_id (heq1::heq::v::p::k::ids) in
tclTHENLIST [
- h_intros [v; hex];
+ h_intros [v; hex];
simplest_elim (mkVar hex);
h_intros [p;heq1];
tclTRY
- (rewriteRL
- (mkApp(mkVar heq1,
+ (rewriteRL
+ (mkApp(mkVar heq1,
[|mkApp (delayed_force coq_S, [|mkVar p|]);
mkApp(delayed_force lt_n_Sn, [|mkVar p|]); f_id|])));
simpl_iter onConcl;
@@ -1160,7 +1160,7 @@ let base_leaf_eq func eqs f_id g =
let f_S t = mkApp(delayed_force coq_S, [|t|]);;
-let rec introduce_all_values_eq cont_tac functional termine
+let rec introduce_all_values_eq cont_tac functional termine
f p heq1 pmax bounds le_proofs eqs ids =
function
[] ->
@@ -1169,14 +1169,14 @@ let rec introduce_all_values_eq cont_tac functional termine
[pose_proof (Name heq2)
(mkApp(mkVar heq1, [|f_S(f_S(mkVar pmax))|]));
simpl_iter (onHyp heq2);
- unfold_in_hyp [((true,[1]), evaluable_of_global_reference
+ unfold_in_hyp [((true,[1]), evaluable_of_global_reference
(global_of_constr functional))]
(heq2, InHyp);
tclTHENS
- (fun gls ->
- let t_eq = compute_renamed_type gls (mkVar heq2) in
- let def_id =
- let _,_,t = destProd t_eq in let def_na,_,_ = destProd t in
+ (fun gls ->
+ let t_eq = compute_renamed_type gls (mkVar heq2) in
+ let def_id =
+ let _,_,t = destProd t_eq in let def_na,_,_ = destProd t in
Nameops.out_name def_na
in
observe_tac "rewrite heq" (general_rewrite_bindings false all_occurrences
@@ -1213,7 +1213,7 @@ let rec introduce_all_values_eq cont_tac functional termine
simplest_elim(mkApp(delayed_force max_constr, [|mkVar pmax;
mkVar p'|]));
h_intros [new_pmax;hle1;hle2];
- introduce_all_values_eq
+ introduce_all_values_eq
(fun pmax' le_proofs'->
tclTHENLIST
[cont_tac pmax' le_proofs';
@@ -1221,12 +1221,12 @@ let rec introduce_all_values_eq cont_tac functional termine
observe_tac ("rewriteRL " ^ (string_of_id heq2))
(tclTRY (rewriteLR (mkVar heq2)));
tclTRY (tclTHENS
- ( fun g ->
- let t_eq = compute_renamed_type g (mkVar heq) in
- let k_id,def_id =
- let k_na,_,t = destProd t_eq in
- let _,_,t = destProd t in
- let def_na,_,_ = destProd t in
+ ( fun g ->
+ let t_eq = compute_renamed_type g (mkVar heq) in
+ let k_id,def_id =
+ let k_na,_,t = destProd t_eq in
+ let _,_,t = destProd t in
+ let def_na,_,_ = destProd t in
Nameops.out_name k_na,Nameops.out_name def_na
in
let c_b = (mkVar heq,
@@ -1246,7 +1246,7 @@ let rec introduce_all_values_eq cont_tac functional termine
functional termine f p heq1 new_pmax
(p'::bounds)((mkVar pmax)::le_proofs) eqs
(heq2::heq::hle2::hle1::new_pmax::p'::hex'::v'::ids) args]
-
+
let rec_leaf_eq termine f ids functional eqs expr fn args =
let p = next_global_ident_away true p_id ids in
@@ -1276,15 +1276,15 @@ let rec prove_eq (termine:constr) (f:constr)(functional:global_reference)
(match kind_of_term expr with
Case(ci,t,a,l) ->
(match find_call_occs 0 f a with
- _,[] ->
- (fun g ->
- let destruct_tac,rev_to_thin_intro = mkDestructEq [] a g in
+ _,[] ->
+ (fun g ->
+ let destruct_tac,rev_to_thin_intro = mkDestructEq [] a g in
tclTHENS
destruct_tac
- (list_map_i
+ (list_map_i
(fun i -> mk_intros_and_continue
- (List.rev rev_to_thin_intro) true
- (prove_eq termine f functional)
+ (List.rev rev_to_thin_intro) true
+ (prove_eq termine f functional)
eqs ci.ci_cstr_nargs.(i))
0 (Array.to_list l)) g)
| _,_::_ ->
@@ -1296,13 +1296,13 @@ let rec prove_eq (termine:constr) (f:constr)(functional:global_reference)
rec_leaf_eq termine f ids
(constr_of_global functional)
eqs expr fn args g))
- | _ ->
+ | _ ->
(match find_call_occs 0 f expr with
_,[] -> base_leaf_eq functional eqs f
| fn,args ->
fun g ->
let ids = ids_of_named_context (pf_hyps g) in
- observe_tac "rec_leaf_eq" (rec_leaf_eq
+ observe_tac "rec_leaf_eq" (rec_leaf_eq
termine f ids (constr_of_global functional)
eqs expr fn args) g));;
@@ -1310,14 +1310,14 @@ let (com_eqn : identifier ->
global_reference -> global_reference -> global_reference
-> constr -> unit) =
fun eq_name functional_ref f_ref terminate_ref equation_lemma_type ->
- let opacity =
- match terminate_ref with
- | ConstRef c ->
- let cb = Global.lookup_constant c in
- if cb.Declarations.const_opaque then true
- else begin match cb.const_body with None -> true | _ -> false end
+ let opacity =
+ match terminate_ref with
+ | ConstRef c ->
+ let cb = Global.lookup_constant c in
+ if cb.Declarations.const_opaque then true
+ else begin match cb.const_body with None -> true | _ -> false end
| _ -> anomaly "terminate_lemma: not a constant"
- in
+ in
let (evmap, env) = Command.get_current_context() in
let f_constr = (constr_of_global f_ref) in
let equation_lemma_type = subst1 f_constr equation_lemma_type in
@@ -1326,9 +1326,9 @@ let (com_eqn : identifier ->
by
(start_equation f_ref terminate_ref
(fun x ->
- prove_eq
+ prove_eq
(constr_of_global terminate_ref)
- f_constr
+ f_constr
functional_ref
[]
(instantiate_lambda
@@ -1339,61 +1339,61 @@ let (com_eqn : identifier ->
);
(* (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *)
(* Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript); *)
- Flags.silently (fun () ->Command.save_named opacity) () ;
+ Flags.silently (fun () ->Command.save_named opacity) () ;
(* Pp.msgnl (str "eqn finished"); *)
-
+
);;
-let nf_zeta env =
+let nf_zeta env =
Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
env
Evd.empty
-let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq
+let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq
generate_induction_principle using_lemmas : unit =
let function_type = interp_constr Evd.empty (Global.env()) type_of_f in
let env = push_named (function_name,None,function_type) (Global.env()) in
(* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *)
- let equation_lemma_type = interp_gen (OfType None) Evd.empty env ~impls:([],rec_impls) eq in
+ let equation_lemma_type = interp_gen (OfType None) Evd.empty env ~impls:([],rec_impls) eq in
(* Pp.msgnl (Printer.pr_lconstr equation_lemma_type); *)
- let res_vars,eq' = decompose_prod equation_lemma_type in
+ let res_vars,eq' = decompose_prod equation_lemma_type in
let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> (x,None,y)) res_vars) env in
- let eq' = nf_zeta env_eq' eq' in
- let res =
+ let eq' = nf_zeta env_eq' eq' in
+ let res =
(* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *)
(* Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *)
(* Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *)
- match kind_of_term eq' with
- | App(e,[|_;_;eq_fix|]) ->
+ match kind_of_term eq' with
+ | App(e,[|_;_;eq_fix|]) ->
mkLambda (Name function_name,function_type,subst_var function_name (compose_lam res_vars eq_fix))
| _ -> failwith "Recursive Definition (res not eq)"
in
- let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in
+ let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in
let (_, rec_arg_type, _) = destProd function_type_before_rec_arg in
let arg_types = List.rev_map snd (fst (decompose_prod_n (List.length res_vars) function_type)) in
let equation_id = add_suffix function_name "_equation" in
let functional_id = add_suffix function_name "_F" in
let term_id = add_suffix function_name "_terminate" in
let functional_ref = declare_fun functional_id (IsDefinition Definition) res in
- let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in
- let relation =
+ let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in
+ let relation =
interp_constr
- Evd.empty
+ Evd.empty
env_with_pre_rec_args
r
- in
+ in
let tcc_lemma_name = add_suffix function_name "_tcc" in
- let tcc_lemma_constr = ref None in
+ let tcc_lemma_constr = ref None in
(* let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *)
- let hook _ _ =
+ let hook _ _ =
let term_ref = Nametab.locate (qualid_of_ident term_id) in
let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in
(* message "start second proof"; *)
- let stop = ref false in
- begin
+ let stop = ref false in
+ begin
try com_eqn equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type)
- with e ->
- begin
+ with e ->
+ begin
if Tacinterp.get_debug () <> Tactic_debug.DebugOff
then pperrnl (str "Cannot create equation Lemma " ++ Cerrors.explain_exn e)
else anomaly "Cannot create equation Lemma"
@@ -1405,20 +1405,20 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
if not !stop
then
let eq_ref = Nametab.locate (qualid_of_ident equation_id ) in
- let f_ref = destConst (constr_of_global f_ref)
- and functional_ref = destConst (constr_of_global functional_ref)
+ let f_ref = destConst (constr_of_global f_ref)
+ and functional_ref = destConst (constr_of_global functional_ref)
and eq_ref = destConst (constr_of_global eq_ref) in
generate_induction_principle f_ref tcc_lemma_constr
functional_ref eq_ref rec_arg_num rec_arg_type (nb_prod res) relation;
if Flags.is_verbose ()
- then msgnl (h 1 (Ppconstr.pr_id function_name ++
- spc () ++ str"is defined" )++ fnl () ++
- h 1 (Ppconstr.pr_id equation_id ++
+ then msgnl (h 1 (Ppconstr.pr_id function_name ++
+ spc () ++ str"is defined" )++ fnl () ++
+ h 1 (Ppconstr.pr_id equation_id ++
spc () ++ str"is defined" )
)
in
- try
- com_terminate
+ try
+ com_terminate
tcc_lemma_name
tcc_lemma_constr
is_mes functional_ref
@@ -1428,7 +1428,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
using_lemmas
(List.length res_vars)
hook
- with e ->
+ with e ->
begin
ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ());
(* anomaly "Cannot create termination Lemma" *)
generated by cgit v1.2.3 (git 2.25.1) at 2026-01-31 20:33:27 +0000