From 511bcda179ea3437a0ff9e4106e4782aabf5f38f Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Tue, 14 Jun 2022 11:46:46 +0200
Subject: [PATCH 01/43] Update docker image version.
---
.github/workflows/build.yml | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml
index 4c2d264e8..7b751b9cb 100644
--- a/.github/workflows/build.yml
+++ b/.github/workflows/build.yml
@@ -12,7 +12,7 @@ jobs:
- '8.14'
ocaml_version:
- '4.07-flambda'
- - '4.12-flambda'
+ - '4.14-flambda'
target: [ local, opam, quick ]
fail-fast: true
From 1610c2d9382f9139fe238f41ecd747861968f260 Mon Sep 17 00:00:00 2001
From: Arthur Adjedj
Date: Tue, 14 Jun 2022 15:12:51 +0200
Subject: [PATCH 02/43] Remove mutual inductiveness from whne def (#711)
* Fix : Remove mutual inductiveness from whne def
---
pcuic/theories/PCUICNormal.v | 37 ++++++++++++++++++------------------
1 file changed, 19 insertions(+), 18 deletions(-)
diff --git a/pcuic/theories/PCUICNormal.v b/pcuic/theories/PCUICNormal.v
index 990faf564..f0121c2e1 100644
--- a/pcuic/theories/PCUICNormal.v
+++ b/pcuic/theories/PCUICNormal.v
@@ -39,24 +39,7 @@ Section Normal.
Context (flags : RedFlags.t).
Context (Σ : global_env).
- (* Relative to reduction flags *)
- Inductive whnf (Γ : context) : term -> Type :=
- | whnf_ne t : whne Γ t -> whnf Γ t
- | whnf_sort s : whnf Γ (tSort s)
- | whnf_prod na A B : whnf Γ (tProd na A B)
- | whnf_lam na A B : whnf Γ (tLambda na A B)
- | whnf_cstrapp i n u v : whnf Γ (mkApps (tConstruct i n u) v)
- | whnf_indapp i u v : whnf Γ (mkApps (tInd i u) v)
- | whnf_fixapp mfix idx v :
- match unfold_fix mfix idx with
- | Some (rarg, body) => nth_error v rarg = None
- | None => True
- end ->
- whnf Γ (mkApps (tFix mfix idx) v)
- | whnf_cofixapp mfix idx v : whnf Γ (mkApps (tCoFix mfix idx) v)
- (* | whnf_prim p : whnf Γ (tPrim p) *)
-
- with whne (Γ : context) : term -> Type :=
+ Inductive whne (Γ : context) : term -> Type :=
| whne_rel i :
option_map decl_body (nth_error Γ i) = Some None ->
whne Γ (tRel i)
@@ -119,6 +102,24 @@ Section Normal.
RedFlags.iota flags = false ->
whne Γ (tProj p c).
+
+ (* Relative to reduction flags *)
+ Inductive whnf (Γ : context) : term -> Type :=
+ | whnf_ne t : whne Γ t -> whnf Γ t
+ | whnf_sort s : whnf Γ (tSort s)
+ | whnf_prod na A B : whnf Γ (tProd na A B)
+ | whnf_lam na A B : whnf Γ (tLambda na A B)
+ | whnf_cstrapp i n u v : whnf Γ (mkApps (tConstruct i n u) v)
+ | whnf_indapp i u v : whnf Γ (mkApps (tInd i u) v)
+ | whnf_fixapp mfix idx v :
+ match unfold_fix mfix idx with
+ | Some (rarg, body) => nth_error v rarg = None
+ | None => True
+ end ->
+ whnf Γ (mkApps (tFix mfix idx) v)
+ | whnf_cofixapp mfix idx v : whnf Γ (mkApps (tCoFix mfix idx) v)
+ (* | whnf_prim p : whnf Γ (tPrim p) *).
+
Lemma whne_mkApps :
forall Γ t args,
whne Γ t ->
From 74b9db2f96606eca2bb5523d672d7f4f32c51d47 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Fri, 17 Jun 2022 10:12:34 +0200
Subject: [PATCH 03/43] Fill one admitted proof in Firstorder, remove dead code
---
pcuic/theories/PCUICCanonicity.v | 197 -------------------
pcuic/theories/PCUICExchange.v | 260 -------------------------
pcuic/theories/PCUICFirstorder.v | 179 +++++++++++++----
safechecker/theories/PCUICSafeReduce.v | 128 ------------
template-coq/theories/common/uGraph.v | 40 ----
5 files changed, 143 insertions(+), 661 deletions(-)
delete mode 100644 pcuic/theories/PCUICExchange.v
diff --git a/pcuic/theories/PCUICCanonicity.v b/pcuic/theories/PCUICCanonicity.v
index 56b1e9ace..f852089a4 100644
--- a/pcuic/theories/PCUICCanonicity.v
+++ b/pcuic/theories/PCUICCanonicity.v
@@ -556,205 +556,8 @@ Qed.
- subst concl; eapply typing_spine_more_inv in sp; try lia.
Qed.
- (* Lemma app_fix_prod_indarg Σ mfix idx args na dom codom decl :
- wf Σ.1 ->
- Σ ;;; [] |- mkApps (tFix mfix idx) args : tProd na dom codom ->
- nth_error mfix idx = Some decl ->
- #|args| = decl.(rarg) ->
- ∑ ind u indargs, dom = mkApps (tInd ind u) indargs *
- isType Σ [] (mkApps (tInd ind u) indargs) *
- (check_recursivity_kind Σ.1 (inductive_mind ind) Finite).
- Proof.
- intros wfΣ tapp.
- eapply inversion_mkApps in tapp as [A [Hfix Hargs]]; eauto.
- eapply inversion_Fix in Hfix;eauto.
- destruct Hfix as [decl [fixg [Hnth [Hist [_ [wf cum]]]]]].
- rewrite /wf_fixpoint in wf. *)
-
End Spines.
-(*
-Section Normalization.
- Context {cf:checker_flags} (Σ : global_env_ext).
- Context {wfΣ : wf Σ}.
-
- Section reducible.
- Lemma reducible Γ t : sum (∑ t', red1 Σ Γ t t') (forall t', red1 Σ Γ t t' -> False).
- Proof.
- Local Ltac lefte := left; eexists; econstructor; eauto.
- Local Ltac leftes := left; eexists; econstructor; solve [eauto].
- Local Ltac righte := right; intros t' red; depelim red; solve_discr; eauto 2.
- induction t in Γ |- * using term_forall_list_ind.
- (*all:try solve [righte].
- - destruct (nth_error Γ n) eqn:hnth.
- destruct c as [na [b|] ty]; [lefte|righte].
- * rewrite hnth; reflexivity.
- * rewrite hnth /= // in e.
- * righte. rewrite hnth /= // in e.
- - admit.
- - destruct (IHt1 Γ) as [[? ?]|]; [lefte|].
- destruct (IHt2 (Γ ,, vass n t1)) as [[? ?]|]; [|righte].
- leftes.
- - destruct (IHt1 Γ) as [[? ?]|]; [lefte|].
- destruct (IHt2 (Γ ,, vass n t1)) as [[? ?]|]; [|righte].
- leftes.
- - destruct (IHt1 Γ) as [[? ?]|]; [lefte|].
- destruct (IHt2 Γ) as [[? ?]|]; [lefte|].
- destruct (IHt3 (Γ ,, vdef n t1 t2)) as [[? ?]|]; [|].
- leftes. lefte.
- - destruct (IHt1 Γ) as [[? ?]|]; [lefte|].
- destruct (IHt2 Γ) as [[? ?]|]; [leftes|].
- destruct (PCUICParallelReductionConfluence.view_lambda_fix_app t1 t2).
- * rewrite [tApp _ _](mkApps_app _ _ [a]).
- destruct (unfold_fix mfix i) as [[rarg body]|] eqn:unf.
- destruct (is_constructor rarg (l ++ [a])) eqn:isc; [leftes|]; eauto.
- right => t' red; depelim red; solve_discr; eauto.
- rewrite mkApps_app in H. noconf H. eauto.
- rewrite mkApps_app in H. noconf H. eauto.
- eapply (f_equal (@length _)) in H1. rewrite /= app_length /= // in H1; lia.
- eapply (f_equal (@length _)) in H1. rewrite /= app_length /= // in H1; lia.
- righte; try (rewrite mkApps_app in H; noconf H); eauto.
- eapply (f_equal (@length _)) in H1. rewrite /= app_length /= // in H1; lia.
- eapply (f_equal (@length _)) in H1. rewrite /= app_length /= // in H1; lia.
- * admit.
- * righte. destruct args using rev_case; solve_discr; noconf H.
- rewrite H in i. eapply negb_False; eauto.
- rewrite mkApps_app; eapply isFixLambda_app_mkApps' => //.
- - admit.
- - admit.
- - admit.
- - admit.
- - admit.*)
-
- Qed.
- End reducible.
-
- Lemma reducible' Γ t : sum (∑ t', red1 Σ Γ t t') (normal Σ Γ t).
- Proof.
- Ltac lefte := left; eexists; econstructor; eauto.
- Ltac leftes := left; eexists; econstructor; solve [eauto].
- Ltac righte := right; (solve [repeat (constructor; eauto)])||(repeat constructor).
- induction t in Γ |- * using term_forall_list_ind.
- all:try solve [righte].
- - destruct (nth_error Γ n) eqn:hnth.
- destruct c as [na [b|] ty]; [lefte|].
- * rewrite hnth; reflexivity.
- * right. do 2 constructor; rewrite hnth /= //.
- * righte. rewrite hnth /= //.
- - admit.
- - destruct (IHt1 Γ) as [[? ?]|]; [lefte|].
- destruct (IHt2 (Γ ,, vass n t1)) as [[? ?]|]; [|].
- leftes. right; solve[constructor; eauto].
- - destruct (IHt1 Γ) as [[? ?]|]; [lefte|].
- destruct (IHt2 (Γ ,, vass n t1)) as [[? ?]|]; [leftes|leftes].
- - destruct (IHt1 Γ) as [[? ?]|]; [lefte|].
- destruct (IHt2 Γ) as [[? ?]|]; [leftes|].
- destruct (PCUICParallelReductionConfluence.view_lambda_fix_app t1 t2).
- * rewrite [tApp _ _](mkApps_app _ _ [a]).
- destruct (unfold_fix mfix i) as [[rarg body]|] eqn:unf.
- destruct (is_constructor rarg (l ++ [a])) eqn:isc; [leftes|]; eauto.
- right; constructor. rewrite mkApps_app. constructor. admit. admit. admit.
- * admit.
- * admit.
- - admit.
- - admit.
- - admit.
- - admit.
- - admit.
- Qed.
-
- Lemma normalizer {Γ t ty} :
- Σ ;;; Γ |- t : ty ->
- ∑ nf, (red Σ.1 Γ t nf) * normal Σ Γ nf.
- Proof.
- intros Hty.
- unshelve epose proof (PCUICSN.normalisation Σ Γ t (iswelltyped _ _ _ ty Hty)).
- clear ty Hty.
- move: t H. eapply Fix_F.
- intros x IH.
- destruct (reducible' Γ x) as [[t' red]|nred].
- specialize (IH t'). forward IH by (constructor; auto).
- destruct IH as [nf [rednf norm]].
- exists nf; split; auto. now transitivity t'.
- exists x. split; [constructor|assumption].
- Qed.
-
- Derive Signature for neutral normal.
-
- Lemma typing_var {Γ n ty} : Σ ;;; Γ |- (tVar n) : ty -> False.
- Proof. intros Hty; depind Hty; eauto. Qed.
-
- Lemma typing_evar {Γ n l ty} : Σ ;;; Γ |- (tEvar n l) : ty -> False.
- Proof. intros Hty; depind Hty; eauto. Qed.
-
- Definition axiom_free Σ :=
- forall c decl, declared_constant Σ c decl -> cst_body decl <> None.
-
- Lemma neutral_empty t ty : axiom_free Σ -> Σ ;;; [] |- t : ty -> neutral Σ [] t -> False.
- Proof.
- intros axfree typed ne.
- pose proof (PCUICClosed.subject_closed wfΣ typed) as cl.
- depind ne.
- - now simpl in cl.
- - now eapply typing_var in typed.
- - now eapply typing_evar in typed.
- - eapply inversion_Const in typed as [decl [wfd [declc [cu cum]]]]; eauto.
- specialize (axfree _ _ declc). specialize (H decl).
- destruct (cst_body decl); try congruence.
- now specialize (H t declc eq_refl).
- - simpl in cl; move/andP: cl => [clf cla].
- eapply inversion_App in typed as [na [A [B [Hf _]]]]; eauto.
- - simpl in cl; move/andP: cl => [/andP[_ clc] _].
- eapply inversion_Case in typed; pcuicfo eauto.
- - eapply inversion_Proj in typed; pcuicfo auto.
- Qed.
-
- Lemma ind_normal_constructor t i u args :
- axiom_free Σ ->
- Σ ;;; [] |- t : mkApps (tInd i u) args -> normal Σ [] t -> construct_cofix_discr (head t).
- Proof.
- intros axfree Ht capp. destruct capp.
- - eapply neutral_empty in H; eauto.
- - eapply inversion_Sort in Ht as (? & ? & ? & ? & ?); auto.
- eapply ws_cumul_pb_Sort_l_inv in c as (? & ? & ?).
- eapply invert_red_mkApps_tInd in r as (? & eq & ?); eauto; eauto.
- solve_discr.
- - eapply inversion_Prod in Ht as (? & ? & ? & ? & ?); auto.
- eapply ws_cumul_pb_Sort_l_inv in c as (? & ? & ?).
- eapply invert_red_mkApps_tInd in r as (? & eq & ?); eauto; eauto.
- solve_discr.
- - eapply inversion_Lambda in Ht as (? & ? & ? & ? & ?); auto.
- eapply ws_cumul_pb_Prod_l_inv in c as (? & ? & ? & (? & ?) & ?); auto.
- eapply invert_red_mkApps_tInd in r as (? & eq & ?); eauto; eauto.
- solve_discr.
- - now rewrite head_mkApps /= /head /=.
- - eapply PCUICValidity.inversion_mkApps in Ht as (? & ? & ?); auto.
- eapply inversion_Ind in t as (? & ? & ? & decli & ? & ?); auto.
- eapply PCUICSpine.typing_spine_strengthen in t0; eauto.
- pose proof (on_declared_inductive wfΣ as decli) [onind oib].
- rewrite oib.(ind_arity_eq) in t0.
- rewrite !subst_instance_it_mkProd_or_LetIn in t0.
- eapply typing_spine_arity_mkApps_Ind in t0; eauto.
- eexists; split; [sq|]; eauto.
- now do 2 eapply isArity_it_mkProd_or_LetIn.
- - admit. (* wf of fixpoints *)
- - now rewrite /head /=.
- Qed.
-
- Lemma red_normal_constructor t i u args :
- axiom_free Σ ->
- Σ ;;; [] |- t : mkApps (tInd i u) args ->
- ∑ hnf, (red Σ.1 [] t hnf) * construct_cofix_discr (head hnf).
- Proof.
- intros axfree Ht. destruct (normalizer Ht) as [nf [rednf capp]].
- exists nf; split; auto.
- eapply subject_reduction in Ht; eauto.
- now eapply ind_normal_constructor.
- Qed.
-
-End Normalization.
-*)
-
(** Evaluation is a subrelation of reduction: *)
Tactic Notation "redt" uconstr(y) := eapply (CRelationClasses.transitivity (R:=red _ _) (y:=y)).
diff --git a/pcuic/theories/PCUICExchange.v b/pcuic/theories/PCUICExchange.v
deleted file mode 100644
index 4c028d39a..000000000
--- a/pcuic/theories/PCUICExchange.v
+++ /dev/null
@@ -1,260 +0,0 @@
-
-(* Distributed under the terms of the MIT license. *)
-From Coq Require Import Morphisms.
-From MetaCoq.Template Require Import config utils.
-From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction
- PCUICLiftSubst PCUICUnivSubst PCUICEquality PCUICTyping PCUICWeakeningEnv
- PCUICClosed PCUICReduction PCUICPosition PCUICGeneration
- PCUICSigmaCalculus PCUICRename PCUICOnFreeVars.
-
-Require Import ssreflect ssrbool.
-From Equations Require Import Equations.
-
-Implicit Types cf : checker_flags.
-
-(* l, r, p -> r, l, p *)
-Definition exchange_renaming l r p :=
- fun i =>
- if p <=? i then
- if p + r <=? i then
- if p + r + l <=? i then i
- else i - r
- else i + l
- else i.
-
-Variant exchange_renaming_spec l r p i : nat -> Type :=
-| exch_below : i < p -> exchange_renaming_spec l r p i i
-| exch_right : p <= i < p + r -> exchange_renaming_spec l r p i (i + l)
-| exch_left : p + r <= i < p + r + l -> exchange_renaming_spec l r p i (i - r)
-| exch_above : p + r + l <= i -> exchange_renaming_spec l r p i i.
-
-Lemma exchange_renamingP l r p i :
- exchange_renaming_spec l r p i (exchange_renaming l r p i).
-Proof.
- unfold exchange_renaming.
- case: leb_spec_Set; [|constructor; auto].
- elim: leb_spec_Set; [|constructor; auto].
- elim: leb_spec_Set; [|constructor; auto].
- intros.
- constructor 4; auto.
-Qed.
-
-Lemma shiftn_exchange_renaming n l r p :
- shiftn n (exchange_renaming l r p) =1
- exchange_renaming l r (n + p).
-Proof.
- intros i.
- case: exchange_renamingP.
- * case: shiftnP; try lia.
- case: exchange_renamingP; lia.
- * case: shiftnP; try lia.
- case: exchange_renamingP; lia.
- * case: shiftnP; try lia.
- case: exchange_renamingP; lia.
- * case: shiftnP; try lia.
- case: exchange_renamingP; lia.
-Qed.
-
-Lemma exchange_renaming_lift_renaming l r p i k :
- i < p ->
- exchange_renaming l r p (lift_renaming (S i) 0 k) =
- lift_renaming (S i) 0
- (shiftn (p - S i) (exchange_renaming l r 0) k).
-Proof.
- intros ip.
- rewrite shiftn_exchange_renaming.
- rewrite /lift_renaming /=.
- case: exchange_renamingP; try lia; intros Hp.
- all: case: exchange_renamingP; lia.
-Qed.
-
-Definition exchange_contexts Γ Γl Γr Δ :=
- (Γ ,,, rename_context (strengthen 0 #|Γl|) Γr ,,,
- rename_context (lift_renaming #|Γr| 0) Γl ,,,
- rename_context (exchange_renaming #|Γl| #|Γr| 0) Δ).
-
-Definition exchange_rename Γl Γr Δ i :=
- if Δ <=? i then
- if Δ + Γr <=? i then
- if Δ + Γr + Γl <=? i then ren_id
- else (lift_renaming Γr (Γl - S (i - Γr - Δ)))
- else (shiftn (Γr - S (i - Δ)) (strengthen 0 Γl))
- else (exchange_renaming Γl Γr (Δ - S i)).
-
-Lemma lookup_exchange_contexts Γ Γl Γr Δ i :
- nth_error (exchange_contexts Γ Γl Γr Δ) (exchange_renaming #|Γl| #|Γr| #|Δ| i) =
- option_map (map_decl (rename (exchange_rename #|Γl| #|Γr| #|Δ| i)))
- (nth_error (Γ ,,, Γl,,, Γr,,, Δ) i).
-Proof.
- rewrite /exchange_renaming /exchange_contexts /exchange_rename.
- case: (leb_spec_Set #|Δ| i) => hΔ.
- * case: leb_spec_Set => hΓr.
- + case: leb_spec_Set => hΓl.
- - do 6 (rewrite nth_error_app_ge; len; try lia => //).
- assert (i - #|Δ| - #|Γl| - #|Γr| = i - #|Δ| - #|Γr| - #|Γl|) as -> by lia.
- now rewrite rename_ren_id map_decl_id option_map_id.
- - rewrite nth_error_app_ge; len; try lia => //.
- rewrite nth_error_app_lt; len; try lia => //.
- rewrite nth_error_app_ge; len; try lia => //.
- rewrite nth_error_app_ge; len; try lia => //.
- rewrite nth_error_app_lt; len; try lia => //.
- rewrite nth_error_rename_context.
- assert (i - #|Δ| - #|Γr| = i - #|Γr| - #|Δ|) as -> by lia.
- apply option_map_ext => //.
- intros d. apply map_decl_ext => t.
- now rewrite shiftn_lift_renaming Nat.add_0_r.
- + rewrite nth_error_app_ge; len; try lia => //.
- rewrite nth_error_app_ge; len; try lia => //.
- rewrite nth_error_app_lt; len; try lia => //.
- rewrite nth_error_app_ge; len; try lia => //.
- rewrite nth_error_app_lt; len; try lia => //.
- rewrite nth_error_rename_context.
- assert (i + #|Γl| - #|Δ| - #|Γl| = i - #|Δ|) as -> by lia.
- reflexivity.
- * rewrite nth_error_app_lt; len; try lia => //.
- rewrite nth_error_app_lt; len; try lia => //.
- rewrite nth_error_rename_context.
- now rewrite shiftn_exchange_renaming Nat.add_0_r.
-Qed.
-
-(*
-Lemma exchange_renaming_add Γl Γr Δ n :
- exchange_renaming Γl Γr Δ n = n + exchange_renaming Γl Γr Δ 0.
-Proof.
- case: exchange_renamingP; case: exchange_renamingP; simpl; try lia.
- - intros.
- *)
-
-Lemma exchange_rename_Δ Γl Γr Δ i (k : nat) :
- (* noccur_between_ctx 0 Γl Γr -> *)
- i < Δ ->
- (* From the i-prefix of Γ Γl Γr Δ to Γ Γr Γl Δ *)
- exchange_renaming Γl Γr Δ (S i + k) =
- S (i + exchange_renaming Γl Γr (Δ - S i) k).
-Proof.
- rewrite /exchange_renaming.
- repeat nat_compare_specs; lia.
-Qed.
-
-Lemma exchange_rename_Γr Γl Γr Δ i (k : nat) :
- (* noccur_between_ctx 0 Γl Γr -> *)
- Δ <= i < Δ + Γr ->
- k < Γr - S (i - Δ) \/ Γr - S (i - Δ) + Γl <= k ->
- (* From the i-prefix of Γ Γl Γr Δ to Γ Γr Γl Δ *)
- exchange_renaming Γl Γr Δ (S i + k) =
- S (i + Γl + strengthen (Γr - S (i - Δ)) Γl k).
-Proof.
- rewrite /exchange_renaming /strengthen.
- repeat nat_compare_specs.
-Qed.
-(*
-Lemma exchange_rename_Γl Γl Γr Δ i (k : nat) :
- (* noccur_between_ctx 0 Γl Γr -> *)
- Δ + Γr <= i < Δ + Γr + Γl ->
- (* From the i-prefix of Γ Γl Γr Δ to Γ Γr Γl Δ *)
- exchange_renaming Γl Γr Δ (S i + k) =
- S (i + exchange_renaming Γl Γr (Δ - S i) k).
-Proof.
- rewrite /exchange_renaming.
- repeat nat_compare_specs; lia.
-Qed. *)
-
-
-Lemma exchange_lift_rename {Γ Γl Γr Δ : context} {i d} :
- noccur_between_ctx 0 #|Γl| Γr ->
- nth_error (Γ,,, Γl,,, Γr,,, Δ) i = Some d ->
- rename_decl (fun k => exchange_renaming #|Γl| #|Γr| #|Δ| (S (i + k))) d =
- rename_decl (fun k => S (exchange_renaming #|Γl| #|Γr| #|Δ| i + exchange_rename #|Γl| #|Γr| #|Δ| i k)) d.
-Proof.
- intros nocc hlen.
- move: hlen.
- case: lookup_declP => // d' Hi hnth [=]; intros ->; [|move: hnth; len in Hi].
- { apply map_decl_ext, rename_ext => k.
- rewrite {2}/exchange_renaming /exchange_rename. nat_compare_specs.
- now apply exchange_rename_Δ. }
- case: lookup_declP => // d' Hi' hnth [=]; intros ->; [|move: hnth; len in Hi'].
- { eapply nth_error_noccur_between_ctx in nocc; eauto.
- simpl in nocc. move: nocc.
- apply rename_decl_ext_cond => k Hk.
- rewrite {2}/exchange_renaming /exchange_rename.
- repeat nat_compare_specs.
- rewrite shiftn_strengthen_rel Nat.add_0_r //.
- now rewrite exchange_rename_Γr. }
- case: lookup_declP => // d' Hi'' hnth [=]; intros ->; [|move: hnth; len in Hi''].
- { apply map_decl_ext, rename_ext => k.
- rewrite /exchange_renaming /exchange_rename /lift_renaming;
- repeat nat_compare_specs. }
- { move/nth_error_Some_length => hlen.
- apply map_decl_ext, rename_ext => k.
- rewrite /exchange_renaming /exchange_rename; repeat nat_compare_specs.
- now unfold ren_id. }
-Qed.
-
-Lemma exchange_urenaming P Γ Γl Γr Δ :
- noccur_between_ctx 0 #|Γl| Γr ->
- urenaming P
- (exchange_contexts Γ Γl Γr Δ)
- (Γ ,,, Γl ,,, Γr ,,, Δ)
- (exchange_renaming #|Γl| #|Γr| #|Δ|).
-Proof.
- intros nocc i d hpi hnth.
- rewrite lookup_exchange_contexts hnth => /=.
- eexists; split; eauto.
- pose proof (exchange_lift_rename nocc hnth).
- rewrite !rename_compose /lift_renaming /=.
- destruct d as [na [b|] ty]; noconf H; simpl in *.
- - split => //.
- split => //.
- f_equal.
- rewrite !rename_compose.
- rewrite /lift_renaming /= //.
- - split => //.
-Qed.
-
-
-Lemma exchange_wf_local {cf: checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Γl Γr Δ} :
- noccur_between_ctx 0 #|Γl| Γr ->
- wf_local Σ (Γ ,,, Γl ,,, Γr ,,, Δ) ->
- wf_local Σ (exchange_contexts Γ Γl Γr Δ).
-Proof.
- intros nocc wf.
- pose proof (env_prop_wf_local _ _ typing_rename_prop _ wfΣ _ wf).
- simpl in X. rewrite /exchange_contexts.
- eapply All_local_env_app_inv in X as [XΓ XΓ'].
- apply wf_local_app_ind => //.
- - rewrite rename_context_lift_context /strengthen /=.
- eapply weakening_wf_local_eq; eauto with wf.
- * admit.
- * now len.
- - intros wfstr.
- apply All_local_env_fold.
- eapply (All_local_env_impl_ind XΓ').
- intros Δ' t [T|] IH; unfold lift_typing; simpl.
- * intros Hf. red.
- eapply meta_conv_all. 2: reflexivity.
- 2-3:now rewrite shiftn_exchange_renaming.
- apply Hf. split.
- + apply wf_local_app; auto.
- apply All_local_env_fold in IH. apply IH.
- + setoid_rewrite shiftn_exchange_renaming. apply exchange_urenaming.
- - intros [s Hs]; exists s. red.
- rewrite -/(lift_context #|Γ''| 0 Δ).
- rewrite Nat.add_0_r !lift_rename. apply Hs.
- split.
- + apply wf_local_app; auto.
- apply All_local_env_fold in IH. apply IH.
- + apply (weakening_renaming Γ Δ Γ'').
-Qed.
-
-Lemma exchange_typing `{cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Γ' Γ''} {t T} :
- wf_local Σ (Γ ,,, Γ'') ->
- Σ ;;; Γ ,,, Γ' |- t : T ->
- Σ ;;; Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ' |- lift #|Γ''| #|Γ'| t : lift #|Γ''| #|Γ'| T.
-Proof.
- intros wfext Ht.
- rewrite !lift_rename.
- eapply (env_prop_typing _ _ typing_rename_prop); eauto.
- split.
- - eapply weakening_wf_local; eauto with pcuic.
- - now apply weakening_renaming.
-Qed.
diff --git a/pcuic/theories/PCUICFirstorder.v b/pcuic/theories/PCUICFirstorder.v
index 3c466a053..6bda76a50 100644
--- a/pcuic/theories/PCUICFirstorder.v
+++ b/pcuic/theories/PCUICFirstorder.v
@@ -66,14 +66,13 @@ Section firstorder.
Definition firstorder_mutind (mind : mutual_inductive_body) :=
(* if forallb (fun decl => firstorder_type decl.(decl_type)) mind.(ind_params) then *)
+ (mind.(ind_finite) == Finite) &&
forallb (firstorder_oneind mind) mind.(ind_bodies)
(* else repeat false (length mind.(ind_bodies)). *).
Definition firstorder_ind (i : inductive) :=
match lookup_env Σ.1 (inductive_mind i) with
- | Some (InductiveDecl mind) =>
- check_recursivity_kind (lookup_env Σ) (inductive_mind i) Finite &&
- firstorder_mutind mind
+ | Some (InductiveDecl mind) => firstorder_mutind mind
| _ => false
end.
@@ -145,11 +144,12 @@ Proof using Type.
red. sq.
unfold PCUICEnvironment.fst_ctx in *. rewrite d1 in H |- *.
solve_all.
- unfold firstorder_mutind in H0.
- rewrite d2. eapply forallb_nth_error in H0; tea.
+ unfold firstorder_mutind in H.
+ rewrite d2. move/andP: H => [ind H0].
+ eapply forallb_nth_error in H0; tea.
erewrite d2 in H0. cbn in H0.
unfold firstorder_oneind in H0. solve_all.
- destruct (ind_sort oind) eqn:E2; inv H1.
+ destruct (ind_sort oind) eqn:E2; inv H0.
eapply PCUICInductives.declared_inductive_type in d.
rewrite d. rewrite E2.
now rewrite destArity_it_mkProd_or_LetIn.
@@ -262,36 +262,43 @@ Proof using Type.
move=> n. destruct a; cbn. f_equal. apply hp. apply IHΓ.
Qed.
-Lemma plookup_env_lookup_env Σ kn b :
+Arguments firstorder_mutind : clear implicits.
+
+Lemma plookup_env_lookup_env {Σ : global_env_ext} kn b :
plookup_env (firstorder_env Σ) kn = Some b ->
- ∑ decl, lookup_env Σ kn = Some decl ×
+ ∑ Σ' decl, lookup_env Σ kn = Some decl ×
+ extends_decls Σ' Σ ×
match decl with
| ConstantDecl _ => b = false
| InductiveDecl mind =>
- b = check_recursivity_kind (lookup_env Σ) kn Finite &&
- firstorder_mutind (Σb := firstorder_env Σ) mind
+ b = firstorder_mutind (firstorder_env' (declarations Σ')) mind
end.
Proof using.
destruct Σ as [[univs Σ] ext].
induction Σ; cbn => //.
destruct a as [kn' d] => //. cbn.
case: eqb_specT.
- * intros ->. eexists; split => //.
- destruct d => //. cbn in H. rewrite eqb_refl in H. congruence. admit.
- (* intros neq h. specialize (IHΣ h) as [decl [Hdecl ?]].
- eexists; split => //. exact Hdecl.
- destruct decl => //. cbn.
- rewrite /lookup_env /=. rewrite y. f_equal.
- unfold check_recursivity_kind. case: eqb_spec => //.
- unfold firstorder_mutind. unfold firstorder_oneind.
- eapply forallb_ext. intros x. f_equal.
- eapply forallb_ext. intros cstr. unfold firstorder_con.
- eapply alli_ext => i' [] => /= _ _ ty.
- unfold firstorder_type.
- admit.
- - cbn.
-*)
-Admitted.
+ * intros ->.
+ destruct d => //; cbn; rewrite eqb_refl => [=] <-;
+ exists {| universes := univs; declarations := Σ |}.
+ eexists; split => //. cbn. split => //.
+ red. split => //. eexists (_ :: []); cbn; trea.
+ eexists; split => //. cbn; split => //.
+ red. split => //. eexists (_ :: []); cbn; trea.
+ * intros neq h.
+ destruct d => //. cbn in h.
+ move: h. case: eqb_specT=> // _ h'.
+ unfold firstorder_env in IHΣ. cbn in IHΣ.
+ specialize (IHΣ h') as [Σ' [decl [Hdecl [ext' ?]]]].
+ exists Σ', decl; split => //. split => //.
+ destruct ext' as [equ [Σ'' eq]]. split => //.
+ eexists (_ :: Σ''). cbn in *. rewrite eq. trea.
+ move: h. cbn. apply neqb in neq. rewrite (negbTE neq).
+ intros h'; specialize (IHΣ h') as [Σ' [decl [Hdecl [ext' ?]]]].
+ exists Σ', decl; split => //. split => //.
+ destruct ext' as [equ [Σ'' eq]]. split => //.
+ eexists (_ :: Σ''). cbn in *. rewrite eq. trea.
+Qed.
Lemma firstorder_spine_let {Σ : global_env_ext} {wfΣ : wf Σ} {Γ na a A B args T'} :
firstorder_spine Σ Γ (B {0 := a}) args T' ->
@@ -329,6 +336,101 @@ Proof using Type.
now eapply isType_ws_cumul_pb_refl. eauto.
Qed.
+Arguments firstorder_type : clear implicits.
+
+(* Lemma firstorder_env'_app x y :
+ firstorder_env' (x ++ y) = firstorder_env' x ++ firstorder_env' y.
+Proof.
+ induction x in y |- *; cbn => //.
+ destruct a => //. destruct g => //. cbn. f_equal; eauto.
+ cbn; f_equal; eauto.
+ f_equal. f_equal. eauto. *)
+
+Import PCUICGlobalMaps.
+
+Lemma fresh_global_app decls decls' kn :
+ fresh_global kn (decls ++ decls') ->
+ fresh_global kn decls /\ fresh_global kn decls'.
+Proof.
+ induction decls => /= //.
+ - intros f; split => //.
+ - intros f; depelim f.
+ specialize (IHdecls f) as [].
+ split; eauto. constructor => //.
+Qed.
+
+Lemma plookup_env_Some_not_fresh g kn b :
+ plookup_env (firstorder_env' g) kn = Some b ->
+ ~ PCUICGlobalMaps.fresh_global kn g.
+Proof.
+ induction g; cbn => //.
+ destruct a => //. destruct g0 => //.
+ - cbn.
+ case: eqb_spec.
+ + move=> -> [=].
+ intros neq hf. depelim hf. now cbn in H.
+ + move=> neq hl hf.
+ apply IHg => //. now depelim hf.
+ - cbn.
+ case: eqb_spec.
+ + move=> -> [=].
+ intros neq hf. depelim hf. now cbn in H.
+ + move=> neq hl hf.
+ apply IHg => //. now depelim hf.
+Qed.
+
+Lemma plookup_env_extends {Σ Σ' : global_env} kn b :
+ extends_decls Σ' Σ ->
+ wf Σ ->
+ plookup_env (firstorder_env' (declarations Σ')) kn = Some b ->
+ plookup_env (firstorder_env' (declarations Σ)) kn = Some b.
+Proof.
+ intros [equ [Σ'' eq]]. rewrite eq.
+ clear equ. intros []. clear o.
+ rewrite eq in o0. clear eq. move: o0.
+ generalize (declarations Σ'). clear Σ'.
+ induction Σ''.
+ - cbn => //.
+ - cbn. destruct a => //. intros gs ong.
+ depelim ong. specialize (IHΣ'' _ ong).
+ destruct g => //.
+ * intros hl. specialize (IHΣ'' hl).
+ eapply plookup_env_Some_not_fresh in hl.
+ cbn. case: eqb_spec.
+ + intros <-. apply fresh_global_app in f as [].
+ contradiction.
+ + now intros neq.
+ * intros hl. specialize (IHΣ'' hl).
+ eapply plookup_env_Some_not_fresh in hl.
+ cbn. case: eqb_spec.
+ + intros <-. apply fresh_global_app in f as [].
+ contradiction.
+ + now intros neq.
+Qed.
+
+Lemma firstorder_mutind_ext {Σ Σ' : global_env_ext} m :
+ extends_decls Σ' Σ ->
+ wf Σ ->
+ firstorder_mutind (firstorder_env' (declarations Σ')) m ->
+ firstorder_mutind (firstorder_env Σ) m.
+Proof.
+ intros [equ [Σ'' eq]] wf.
+ unfold firstorder_env. rewrite eq.
+ unfold firstorder_mutind.
+ move/andP => [] -> /=. apply forallb_impl => x _.
+ unfold firstorder_oneind.
+ move/andP => [] h -> /=; rewrite andb_true_r.
+ eapply forallb_impl; tea => c _.
+ unfold firstorder_con.
+ eapply alli_impl => i [] _ _ ty.
+ unfold firstorder_type.
+ destruct decompose_app => // /=.
+ destruct t => //. destruct ind => //.
+ destruct plookup_env eqn:hl => //. destruct b => //.
+ eapply (plookup_env_extends (Σ:=Σ)) in hl. 2:split; eauto.
+ rewrite eq in hl. rewrite hl //. apply wf.
+Qed.
+
Lemma firstorder_args {Σ : global_env_ext} {wfΣ : wf Σ} { mind cbody i n ui args u pandi oind} :
declared_constructor Σ (i, n) mind oind cbody ->
PCUICArities.typing_spine Σ [] (type_of_constructor mind cbody (i, n) ui) args (mkApps (tInd i u) pandi) ->
@@ -350,25 +452,27 @@ Proof using Type.
{ clear Hspine. destruct Hdecl as [[d1 d3] d2]. pose proof d3 as Hdecl.
unfold firstorder_ind in Hind.
rewrite d1 in Hind. solve_all. clear a.
+ move/andP: Hind => [indf H0].
eapply forallb_nth_error in H0 as H'.
erewrite d3 in H'.
unfold firstorder_oneind in H'. cbn in H'.
rtoProp.
- eapply nth_error_forallb in H1. 2: eauto.
- unfold firstorder_con in H1.
- revert H1. cbn.
+ eapply nth_error_forallb in H. 2: eauto.
+ unfold firstorder_con in H.
+ revert H. cbn.
unfold cstr_concl.
rewrite PCUICUnivSubst.subst_instance_mkApps subst_mkApps.
rewrite subst_instance_length app_length.
unfold cstr_concl_head. rewrite PCUICInductives.subst_inds_concl_head. now eapply nth_error_Some_length in Hdecl.
rewrite -app_length.
- generalize (cstr_args cbody ++ ind_params mind)%list. clear -d1 H H0 Hdecl.
+ generalize (cstr_args cbody ++ ind_params mind)%list.
+ clear -wfΣ d1 indf H1 H0 Hdecl.
(* generalize conclusion to mkApps tInd args *)
intros c.
change (list context_decl) with context in c.
move: (map (subst (inds _ _ _) _) _).
intros args.
- rewrite (alli_subst_instance _ ui (fun k t => firstorder_type #|ind_bodies mind| k t)).
+ rewrite (alli_subst_instance _ ui (fun k t => firstorder_type _ #|ind_bodies mind| k t)).
{ intros k t.
rewrite /firstorder_type.
rewrite -PCUICUnivSubstitutionConv.subst_instance_decompose_app /=.
@@ -424,7 +528,7 @@ Proof using Type.
rewrite Nat.add_0_r in fot. eapply Nat.ltb_lt in fot.
cbn. rewrite nth_error_inds. lia. cbn.
econstructor.
- { rewrite /firstorder_ind d1 H H0 //. }
+ { rewrite /firstorder_ind d1 /= /firstorder_mutind indf H0 //. }
intros x.
rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn subst_mkApps /=. len.
rewrite -subst_app_context' // PCUICSigmaCalculus.subst_context_decompo.
@@ -458,8 +562,9 @@ Proof using Type.
constructor. {
unfold firstorder_ind. destruct ind. cbn in *.
destruct plookup_env eqn:hp => //.
- eapply plookup_env_lookup_env in hp as [decl [eq ]].
- rewrite eq. destruct decl; subst b => //. }
+ eapply plookup_env_lookup_env in hp as [Σ' [decl [eq [ext he]]]].
+ rewrite eq. destruct decl; subst b => //.
+ eapply (firstorder_mutind_ext (Σ' := (empty_ext Σ'))); tea. }
intros x. rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn subst_mkApps /=; len.
rewrite -subst_app_context' // PCUICSigmaCalculus.subst_context_decompo.
eapply X. now len. len.
@@ -560,7 +665,8 @@ Proof using Type.
red in Hfo. unfold firstorder_ind in Hfo.
rewrite Hlookup in Hfo.
eapply andb_true_iff in Hfo as [Hfo _].
- eapply check_recursivity_kind_inj in Hty; eauto. congruence.
+ rewrite /check_recursivity_kind Hlookup in Hty.
+ apply eqb_eq in Hfo, Hty. congruence.
- destruct t; inv Hhead.
+ exfalso. now eapply invert_ind_ind in Hty.
+ apply inversion_mkApps in Hty as Hcon; auto.
@@ -593,7 +699,8 @@ Proof using Type.
red in Hfo. unfold firstorder_ind in Hfo.
rewrite Hlookup in Hfo.
eapply andb_true_iff in Hfo as [Hfo _].
- eapply check_recursivity_kind_inj in Hty; eauto. congruence.
+ rewrite /check_recursivity_kind Hlookup in Hty.
+ apply eqb_eq in Hfo, Hty. congruence.
Qed.
End cf.
diff --git a/safechecker/theories/PCUICSafeReduce.v b/safechecker/theories/PCUICSafeReduce.v
index 22c0a4f1f..655c7231d 100644
--- a/safechecker/theories/PCUICSafeReduce.v
+++ b/safechecker/theories/PCUICSafeReduce.v
@@ -1116,44 +1116,6 @@ Corollary R_Acc_aux :
End reducewf.
- (* Equations reduce_stack_full (Γ : context) (t : term) (π : stack)
- (h : forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ (zip (t,π))) :
- { t' : term * stack | forall Σ (wfΣ : abstract_env_ext_rel X Σ), Req Σ Γ t' (t, π) /\ Pr t' π /\ Pr' t' } :=
- reduce_stack_full Γ t π h :=
- Fix_F (R := fun t t' => forall Σ (wfΣ : abstract_env_ext_rel X Σ), R Σ Γ t t')
- (fun x => (forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ (zip x))
- -> { t' : term * stack | forall Σ (wfΣ : abstract_env_ext_rel X Σ), Req Σ Γ t' x /\ Pr t' (snd x) /\ Pr' t' })
- (fun t' f => _) (x := (t, π)) _ _.
- Next Obligation.
- eapply _reduce_stack.
- - assumption.
- - intros t' π' h'.
- eapply f.
- + assumption.
- + intros. specialize (h' _ wfΣ). simple inversion h'.
- * cbn in H1. cbn in H2.
- inversion H1. subst. inversion H2. subst. clear H1 H2.
- intros.
- destruct (hΣ _ wfΣ) as [wΣ].
- eapply cored_welltyped.
- ++ eassumption.
- ++ eapply H; eauto.
- ++ eauto.
- * cbn in H1. cbn in H2.
- inversion H1. subst. inversion H2. subst. clear H1 H2.
- intros. cbn. rewrite H3. eauto.
- Defined.
- Next Obligation.
- revert h. generalize (t, π).
- refine (Acc_intro_generator
- (R:=fun x y => forall Σ (wfΣ : abstract_env_ext_rel X Σ), R Σ Γ x y)
- (P:=fun x => forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ (zip x))
- (fun x y Px Hy => _) 1000 _); intros.
- - simpl in *. eapply welltyped_R_pres; eauto.
- - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]].
- destruct (hΣ _ wfΣ) as [hΣ]. eapply R_Acc; eassumption.
- Defined. *)
-
Definition reduce_stack Γ t π h :=
let '(exist ts _) := reduce_stack_full Γ t π h in ts.
@@ -1262,44 +1224,6 @@ Corollary R_Acc_aux :
refine (reduce_stack_sound _ _ _ _ [] _); eauto.
Qed.
- (* (* Potentially hard? Ok with SN? *) *)
- (* Lemma Ind_canonicity : *)
- (* forall Γ ind uni args t, *)
- (* Σ ;;; Γ |- t : mkApps (tInd ind uni) args -> *)
- (* RedFlags.iota flags -> *)
- (* let '(u,l) := decompose_app t in *)
- (* (isLambda u -> l = []) -> *)
- (* whnf flags Σ Γ u -> *)
- (* discr_construct u -> *)
- (* whne flags Σ Γ u. *)
- (* Proof. *)
- (* intros Γ ind uni args t ht hiota. *)
- (* case_eq (decompose_app t). *)
- (* intros u l e hl h d. *)
- (* induction h. *)
- (* - assumption. *)
- (* - apply decompose_app_inv in e. subst. *)
- (* (* Inversion on ht *) *)
- (* admit. *)
- (* - apply decompose_app_inv in e. subst. *)
- (* (* Inversion on ht *) *)
- (* admit. *)
- (* - cbn in hl. specialize (hl eq_refl). subst. *)
- (* apply decompose_app_inv in e. subst. cbn in ht. *)
- (* (* Inversion on ht *) *)
- (* admit. *)
- (* - apply decompose_app_eq_mkApps in e. subst. *)
- (* cbn in d. simp discr_construct in d. easy. *)
- (* - apply decompose_app_inv in e. subst. *)
- (* (* Inversion on ht *) *)
- (* admit. *)
- (* - apply decompose_app_inv in e. subst. *)
- (* (* Not very clear now. *)
- (* Perhaps we ought to show whnf of the mkApps entirely. *)
- (* And have a special whne case for Fix that don't reduce? *)
- (* *) *)
- (* Abort. *)
-
Scheme Acc_ind' := Induction for Acc Sort Prop.
Lemma Fix_F_prop :
@@ -2166,56 +2090,4 @@ Section ReduceFns.
Local Instance wellfounded Σ wfΣ : WellFounded (@hnf_subterm_rel _ Σ) :=
@wf_hnf_subterm _ _ (heΣ _ X Σ wfΣ).
- (** not used anymore **)
- (*
- Equations? (noeqns) reduce_to_arity (Γ : context) (T : term)
- (wt : forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ T)
- : (conv_arity Γ T) + {forall Σ (wfΣ : abstract_env_ext_rel X Σ), ~ Is_conv_to_Arity Σ Γ T}
- by wf ((Γ ; T ; wt) : (∑ Γ t, forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ t)) hnf_subterm_rel :=
- reduce_to_arity Γ T wt with inspect (hnf Γ T wt) :=
- | exist Thnf eqhnf with view_prod_sortc Thnf := {
- | view_prod_sort_prod na A B with reduce_to_arity (Γ,, vass na A) B _ := {
- | inleft car => inleft {| conv_ar_context := (na, A) :: conv_ar_context car;
- conv_ar_univ := conv_ar_univ car |};
- | inright nocar => inright _
- };
- | view_prod_sort_sort u => inleft {| conv_ar_context := [];
- conv_ar_univ := u |};
- | view_prod_sort_other Thnf notprod notsort => inright _
- }.
- Proof.
- all: pose proof (@hnf_sound Γ T wt) as [r].
- all: rewrite <- ?eqhnf in r.
- all: destruct HΣ as [wf].
- - destruct wt as (?&typ).
- eapply subject_reduction_closed in r; eauto.
- apply inversion_Prod in r as (?&?&?&?&?); auto.
- econstructor; eauto.
- - constructor.
- eexists _; split. 1:eapply r.
- unshelve eexists _; [constructor; constructor|]; auto.
- - destruct car as [c_ar c_univ [c_red]]; cbn.
- constructor.
- etransitivity; eauto.
- eapply closed_red_prod_codom; eauto.
- - eapply Is_conv_to_Arity_red in H as (?&[r']&isar); eauto.
- apply invert_red_prod in r' as (?&?&[-> ? ?]); auto.
- contradiction nocar.
- eexists; eauto using sq.
- - constructor; auto.
- - pose proof (@hnf_complete Γ T wt) as [w].
- destruct HΣ.
- apply Is_conv_to_Arity_inv in H as [(na&A&B&[r'])|(u&[r'])]; auto.
- + eapply PCUICContextConversion.closed_red_confluence in r' as (?&r1&r2); eauto.
- apply invert_red_prod in r2 as (?&?&[-> ? ?]); auto.
- eapply whnf_red_inv in r1; eauto.
- depelim r1.
- rewrite H in notprod; auto.
- + eapply PCUICContextConversion.closed_red_confluence in r' as (?&r1&r2); eauto.
- apply invert_red_sort in r2 as ->.
- eapply whnf_red_inv in r1; eauto.
- depelim r1.
- rewrite H in notsort; cbn in *; auto.
- Qed. *)
-
End ReduceFns.
diff --git a/template-coq/theories/common/uGraph.v b/template-coq/theories/common/uGraph.v
index f915c8dc5..626c307f1 100644
--- a/template-coq/theories/common/uGraph.v
+++ b/template-coq/theories/common/uGraph.v
@@ -2034,46 +2034,6 @@ Section CheckLeq.
End CheckLeq.
-
-Section CheckLeq'.
- Context {cf:checker_flags}.
-
- Context (G : universes_graph)
- uctx (Huctx: global_gc_uctx_invariants uctx) (HC : gc_consistent uctx.2)
- (HG : G = make_graph uctx).
-
- (*Lemma check_gc_constraint_complete gcs
- : gc_consistent gcs -> check_gc_constraints G gcs.
- Proof.
- unfold check_gc_constraints. cbn.
- intros [v Hv].
- unfold gc_satisfies in Hv.
- apply GoodConstraintSetFact.for_all_iff in Hv; eauto. 2:typeclasses eauto.
- apply GoodConstraintSetFact.for_all_iff; eauto. typeclasses eauto.
- intros gc hc. specialize (Hv gc hc). cbn in Hv.
- unfold gc_satisfies0 in Hv.
- destruct gc as [l z l'|k l|k n|l k|n k].
- - cbn. apply (leqb_level_n_spec G uctx Huctx HC HG). admit. admit.
- intros v' Hv'. cbn.
- specialize (HH v Hv). cbn in *. toProp.
- pose proof (val_level_of_variable_level v l).
- pose proof (val_level_of_variable_level v l').
- destruct l, l'; cbn in *; lled; lia.
- - intros HH v Hv; apply leqb_level_n_spec0 in HH.
- specialize (HH v Hv). cbn -[Z.of_nat] in HH. unfold gc_satisfies0. toProp.
- cbn in *. lled; lia.
- - intros HH v Hv; apply leqb_level_n_spec0 in HH.
- specialize (HH v Hv). cbn in HH. unfold gc_satisfies0. toProp.
- lled; lia.
- - intros HH v Hv; apply leqb_level_n_spec0 in HH.
- specialize (HH v Hv). cbn in HH. unfold gc_satisfies0. toProp.
- lled; lia.
- - intros HH v Hv; apply leqb_level_n_spec0 in HH.
- specialize (HH v Hv). cbn in HH. unfold gc_satisfies0. toProp.
- lled; lia.
- Qed. *)
-End CheckLeq'.
-
(* This section: specif in term of raw uctx *)
Section CheckLeq2.
Context {cf:checker_flags}.
From 63906fb56f6d586a1d9e9b3f6938ccb68a472008 Mon Sep 17 00:00:00 2001
From: Yannick Forster
Date: Sat, 25 Jun 2022 14:43:27 +0200
Subject: [PATCH 04/43] Option to see constructors as block in EWcbvEval,
needed for extraction in CertiCoq and to OCaml/Malfunction (#716)
* constructors as blocks
* evaluation rules for constructors as blocks
* tranformation to constructors as blocks
* correctness proof for constructors as blocks
---
erasure/_CoqProject.in | 1 +
erasure/theories/EAst.v | 2 +-
erasure/theories/EAstUtils.v | 12 +-
erasure/theories/ECSubst.v | 3 +-
erasure/theories/EConstructorsAsBlocks.v | 878 +++++++++++++++++++++++
erasure/theories/EDeps.v | 17 +-
erasure/theories/EEtaExpanded.v | 69 +-
erasure/theories/EEtaExpandedFix.v | 255 +++----
erasure/theories/EGlobalEnv.v | 2 +-
erasure/theories/EInduction.v | 19 +-
erasure/theories/EInlineProjections.v | 29 +-
erasure/theories/ELiftSubst.v | 11 +-
erasure/theories/EOptimizePropDiscr.v | 71 +-
erasure/theories/EPretty.v | 4 +-
erasure/theories/EReflect.v | 9 +
erasure/theories/ERemoveParams.v | 91 +--
erasure/theories/ESpineView.v | 2 +-
erasure/theories/ETransform.v | 57 +-
erasure/theories/EWcbvEval.v | 280 ++++++--
erasure/theories/EWcbvEvalEtaInd.v | 93 +--
erasure/theories/EWcbvEvalInd.v | 175 +++--
erasure/theories/EWellformed.v | 9 +-
erasure/theories/Erasure.v | 14 +-
erasure/theories/ErasureCorrectness.v | 6 +-
erasure/theories/ErasureFunction.v | 4 +-
erasure/theories/ErasureProperties.v | 18 +-
erasure/theories/Extract.v | 6 +-
27 files changed, 1708 insertions(+), 429 deletions(-)
create mode 100644 erasure/theories/EConstructorsAsBlocks.v
diff --git a/erasure/_CoqProject.in b/erasure/_CoqProject.in
index 617a15e08..e4d218591 100644
--- a/erasure/_CoqProject.in
+++ b/erasure/_CoqProject.in
@@ -34,4 +34,5 @@ theories/EProgram.v
theories/ERemoveParams.v
theories/EInlineProjections.v
theories/ETransform.v
+theories/EConstructorsAsBlocks.v
theories/Erasure.v
diff --git a/erasure/theories/EAst.v b/erasure/theories/EAst.v
index b0c8bbd72..16bf3e1a7 100644
--- a/erasure/theories/EAst.v
+++ b/erasure/theories/EAst.v
@@ -33,7 +33,7 @@ Inductive term : Set :=
| tLetIn : name -> term (* the term *) -> term -> term
| tApp : term -> term -> term
| tConst : kername -> term
-| tConstruct : inductive -> nat -> term
+| tConstruct : inductive -> nat -> list term -> term
| tCase : (inductive * nat) (* # of parameters *) ->
term (* discriminee *) -> list (list name * term) (* branches *) -> term
| tProj : projection -> term -> term
diff --git a/erasure/theories/EAstUtils.v b/erasure/theories/EAstUtils.v
index 6db80c98d..53c531708 100644
--- a/erasure/theories/EAstUtils.v
+++ b/erasure/theories/EAstUtils.v
@@ -283,7 +283,7 @@ Definition isCoFix t :=
Definition isConstruct t :=
match t with
- | tConstruct _ _ => true
+ | tConstruct _ _ _ => true
| _ => false
end.
@@ -328,6 +328,8 @@ Definition string_of_def {A : Set} (f : A -> string) (def : def A) :=
"(" ^ string_of_name (dname def) ^ "," ^ f (dbody def) ^ ","
^ string_of_nat (rarg def) ^ ")".
+Definition maybe_string_of_list {A} f (l : list A) := match l with [] => "" | _ => string_of_list f l end.
+
Fixpoint string_of_term (t : term) : string :=
match t with
| tBox => "∎"
@@ -338,7 +340,7 @@ Fixpoint string_of_term (t : term) : string :=
| tLetIn na b t => "LetIn(" ^ string_of_name na ^ "," ^ string_of_term b ^ "," ^ string_of_term t ^ ")"
| tApp f l => "App(" ^ string_of_term f ^ "," ^ string_of_term l ^ ")"
| tConst c => "Const(" ^ string_of_kername c ^ ")"
- | tConstruct i n => "Construct(" ^ string_of_inductive i ^ "," ^ string_of_nat n ^ ")"
+ | tConstruct i n args => "Construct(" ^ string_of_inductive i ^ "," ^ string_of_nat n ^ maybe_string_of_list string_of_term args ^ ")"
| tCase (ind, i) t brs =>
"Case(" ^ string_of_inductive ind ^ "," ^ string_of_nat i ^ "," ^ string_of_term t ^ ","
^ string_of_list (fun b => string_of_term (snd b)) brs ^ ")"
@@ -354,8 +356,10 @@ Fixpoint string_of_term (t : term) : string :=
Fixpoint term_global_deps (t : EAst.term) :=
match t with
- | EAst.tConst kn
- | EAst.tConstruct {| inductive_mind := kn |} _ => KernameSet.singleton kn
+ | EAst.tConst kn => KernameSet.singleton kn
+ | EAst.tConstruct {| inductive_mind := kn |} _ args =>
+ List.fold_left (fun acc x => KernameSet.union (term_global_deps x) acc) args
+ (KernameSet.singleton kn)
| EAst.tLambda _ x => term_global_deps x
| EAst.tApp x y
| EAst.tLetIn _ x y => KernameSet.union (term_global_deps x) (term_global_deps y)
diff --git a/erasure/theories/ECSubst.v b/erasure/theories/ECSubst.v
index 7edceca5d..65a0695d3 100644
--- a/erasure/theories/ECSubst.v
+++ b/erasure/theories/ECSubst.v
@@ -36,6 +36,7 @@ Fixpoint csubst t k u :=
let k' := List.length mfix + k in
let mfix' := List.map (map_def (csubst t k')) mfix in
tCoFix mfix' idx
+ | tConstruct ind n args => tConstruct ind n (map (csubst t k) args)
| x => x
end.
@@ -57,7 +58,7 @@ Proof.
destruct (nth_error_spec [t] (n - k) ).
simpl in l0; lia.
now rewrite Nat.sub_1_r.
- + now destruct (Nat.leb_spec k n); try lia.
+ + now destruct (Nat.leb_spec k n); try lia.
Qed.
Lemma substl_subst s u : forallb (closedn 0) s ->
diff --git a/erasure/theories/EConstructorsAsBlocks.v b/erasure/theories/EConstructorsAsBlocks.v
new file mode 100644
index 000000000..8bc48e29b
--- /dev/null
+++ b/erasure/theories/EConstructorsAsBlocks.v
@@ -0,0 +1,878 @@
+(* Distributed under the terms of the MIT license. *)
+From Coq Require Import Utf8 Program.
+From MetaCoq.Template Require Import config utils Kernames BasicAst EnvMap.
+From MetaCoq.Erasure Require Import EAst EAstUtils EInduction EArities
+ ELiftSubst ESpineView EGlobalEnv EWellformed EEnvMap
+ EWcbvEval EEtaExpanded ECSubst EWcbvEvalEtaInd EProgram.
+
+Local Open Scope string_scope.
+Set Asymmetric Patterns.
+Import MCMonadNotation.
+
+From Equations Require Import Equations.
+Set Equations Transparent.
+Local Set Keyed Unification.
+From Coq Require Import ssreflect ssrbool.
+
+(** We assume [Prop = Type] and universes are checked correctly in the following. *)
+(* Local Existing Instance extraction_checker_flags. *)
+Ltac introdep := let H := fresh in intros H; depelim H.
+
+#[global]
+Hint Constructors eval : core.
+
+Import MCList (map_InP, map_InP_elim, map_InP_spec).
+
+Section transform_blocks.
+ Context (Σ : global_context).
+ Section Def.
+ Import TermSpineView.
+
+ Equations? transform_blocks (t : term) : term
+ by wf t (fun x y : EAst.term => size x < size y) :=
+ | e with TermSpineView.view e := {
+ | tRel i => EAst.tRel i
+ | tEvar ev args => EAst.tEvar ev (map_InP args (fun x H => transform_blocks x))
+ | tLambda na M => EAst.tLambda na (transform_blocks M)
+ | tApp u v napp nnil with construct_viewc u :=
+ { | view_construct ind i block_args with lookup_constructor_pars_args Σ ind i := {
+ | Some (npars, nargs) =>
+ let args := map_InP v (fun x H => transform_blocks x) in
+ let '(args, rest) := MCList.chop nargs args in
+ EAst.mkApps (EAst.tConstruct ind i args) rest
+ | None =>
+ let args := map_InP v (fun x H => transform_blocks x) in
+ EAst.tConstruct ind i args }
+ | view_other _ _ => mkApps (transform_blocks u) (map_InP v (fun x H => transform_blocks x)) }
+
+ | tLetIn na b b' => EAst.tLetIn na (transform_blocks b) (transform_blocks b')
+ | tCase ind c brs =>
+ let brs' := map_InP brs (fun x H => (x.1, transform_blocks x.2)) in
+ EAst.tCase (ind.1, 0) (transform_blocks c) brs'
+ | tProj p c => EAst.tProj {| proj_ind := p.(proj_ind); proj_npars := 0; proj_arg := p.(proj_arg) |} (transform_blocks c)
+ | tFix mfix idx =>
+ let mfix' := map_InP mfix (fun d H => {| dname := dname d; dbody := transform_blocks d.(dbody); rarg := d.(rarg) |}) in
+ EAst.tFix mfix' idx
+ | tCoFix mfix idx =>
+ let mfix' := map_InP mfix (fun d H => {| dname := dname d; dbody := transform_blocks d.(dbody); rarg := d.(rarg) |}) in
+ EAst.tCoFix mfix' idx
+ | tBox => EAst.tBox
+ | tVar n => EAst.tVar n
+ | tConst n => EAst.tConst n
+ | tConstruct ind i block_args => EAst.tConstruct ind i [] }.
+ Proof.
+ all:try lia.
+ all:try apply (In_size); tea.
+ all:try lia.
+ - now apply (In_size id size).
+ - change (fun x => size (id x)) with size in H.
+ eapply (In_size id size) in H. unfold id in H.
+ change (fun x => size x) with size in H.
+ rewrite size_mkApps. cbn. lia.
+ - change (fun x => size (id x)) with size in H.
+ eapply (In_size id size) in H. unfold id in H.
+ change (fun x => size x) with size in H.
+ rewrite size_mkApps. cbn. lia.
+ - now eapply size_mkApps_f.
+ - change (fun x => size (id x)) with size in H.
+ eapply (In_size id size) in H. unfold id in H.
+ change (fun x => size x) with size in H.
+ pose proof (size_mkApps_l napp nnil). lia.
+ - eapply (In_size snd size) in H. cbn in *. lia.
+ Qed.
+
+ End Def.
+
+ Hint Rewrite @map_InP_spec : transform_blocks.
+
+ Arguments eqb : simpl never.
+
+ Opaque transform_blocks_unfold_clause_1.
+ Opaque transform_blocks.
+ Opaque isEtaExp.
+ Opaque isEtaExp_unfold_clause_1.
+
+
+ Lemma chop_firstn_skipn {A} n (l : list A) : chop n l = (firstn n l, skipn n l).
+ Proof using Type.
+ induction n in l |- *; destruct l; simpl; auto.
+ now rewrite IHn skipn_S.
+ Qed.
+
+ Lemma chop_eq {A} n (l : list A) l1 l2 : chop n l = (l1, l2) -> l = l1 ++ l2.
+ Proof.
+ rewrite chop_firstn_skipn. intros [= <- <-].
+ now rewrite firstn_skipn.
+ Qed.
+
+ Lemma closed_transform_blocks t k : closedn k t -> closedn k (transform_blocks t).
+ Proof using Type.
+ funelim (transform_blocks t); simp transform_blocks; rewrite <-?transform_blocks_equation_1; toAll; simpl;
+ intros; try easy;
+ rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length;
+ unfold test_def in *;
+ simpl closed in *;
+ try solve [simpl; subst; simpl closed; f_equal; auto; rtoProp; solve_all; solve_all]; try easy.
+ - rewrite !closedn_mkApps in H1 *.
+ rtoProp; intuition auto. solve_all.
+ - destruct (chop nargs v) eqn:E.
+ erewrite chop_map; eauto.
+ eapply chop_eq in E as ->.
+ rewrite !closedn_mkApps in H0 *.
+ rtoProp; intuition auto; cbn; solve_all; eapply All_app in H1;
+ repeat solve_all.
+ - rewrite !closedn_mkApps /= in H0 *. rtoProp.
+ repeat solve_all.
+ Qed.
+
+ Hint Rewrite @forallb_InP_spec : isEtaExp.
+ Transparent isEtaExp_unfold_clause_1.
+
+ Transparent transform_blocks_unfold_clause_1.
+
+ Local Lemma transform_blocks_mkApps f v :
+ ~~ isApp f ->
+ transform_blocks (mkApps f v) = match construct_viewc f with
+ | view_construct ind i block_args =>
+ match lookup_constructor_pars_args Σ ind i with
+ | Some (npars, nargs) =>
+ let args := map transform_blocks v in
+ let '(args, rest) := MCList.chop nargs args in
+ EAst.mkApps (EAst.tConstruct ind i args) rest
+ | None =>
+ let args := map transform_blocks v in
+ EAst.tConstruct ind i args
+ end
+ | view_other _ _ => mkApps (transform_blocks f) (map transform_blocks v)
+ end.
+ Proof using Type.
+ intros napp; simp transform_blocks.
+ destruct (construct_viewc f) eqn:vc.
+ - destruct lookup_constructor_pars_args as [[]|] eqn:heq.
+ destruct v eqn:hargs. cbn.
+ * destruct n1 => //.
+ * set (v' := TermSpineView.view _).
+ destruct (TermSpineView.view_mkApps v') as [hf [vn eq]] => //.
+ rewrite eq /=. rewrite heq /=. now simp transform_blocks.
+ * destruct v eqn:hargs => //.
+ set (v' := TermSpineView.view _).
+ destruct (TermSpineView.view_mkApps v') as [hf [vn eq]] => //.
+ rewrite eq /=. rewrite heq /=. now simp transform_blocks.
+ - destruct v eqn:hargs => //.
+ simp transform_blocks.
+ set (v' := TermSpineView.view _).
+ destruct (TermSpineView.view_mkApps v') as [hf [vn eq]] => //.
+ rewrite eq /= vc /=. now simp transform_blocks.
+ Qed.
+
+ Lemma transform_blocks_decompose f :
+ transform_blocks f =
+ let (fn, args) := decompose_app f in
+ match construct_viewc fn with
+ | view_construct kn c _ =>
+ match lookup_constructor_pars_args Σ kn c with
+ | Some (npars, nargs) =>
+ let args := map (transform_blocks) args in
+ let '(args, rest) := MCList.chop nargs args in
+ mkApps (tConstruct kn c args) rest
+ | None =>
+ let args := map transform_blocks args in
+ tConstruct kn c args
+ end
+ | view_other fn nconstr =>
+ mkApps (transform_blocks fn) (map transform_blocks args)
+ end.
+ Proof.
+ destruct (decompose_app f) eqn:da.
+ rewrite (decompose_app_inv da). rewrite transform_blocks_mkApps.
+ now eapply decompose_app_notApp.
+ destruct construct_viewc; try reflexivity.
+ Qed.
+
+ Lemma transform_blocks_mkApps_eta (P : term -> Prop) fn args :
+ (* wf_glob Σ ->
+ *)~~ EAst.isApp fn ->
+ isEtaExp Σ (mkApps fn args) ->
+ (match construct_viewc fn with
+ | view_construct kn c block_args =>
+ forall pars nargs,
+ lookup_constructor_pars_args Σ kn c = Some (pars, nargs) ->
+ let cargs := map transform_blocks args in
+ let '(cargs, rest) := MCList.chop nargs cargs in
+ P (mkApps (tConstruct kn c cargs) rest)
+ | view_other fn nconstr =>
+ P (mkApps (transform_blocks fn) (map transform_blocks args))
+ end) ->
+ P (transform_blocks (mkApps fn args)).
+ Proof.
+ intros napp.
+ move/isEtaExp_mkApps.
+ rewrite decompose_app_mkApps //.
+ destruct construct_viewc eqn:vc.
+ + rewrite /isEtaExp_app.
+ destruct lookup_constructor_pars_args as [[]|] eqn:hl.
+ rewrite transform_blocks_decompose decompose_app_mkApps // /= hl.
+ move=> /andP[] /andP[] /Nat.leb_le hargs etaargs bargs.
+ destruct block_args; invs bargs.
+ move/(_ _ _ eq_refl).
+ destruct chop eqn:eqch => //.
+ move => /andP[] => //.
+ + intros ht. rewrite transform_blocks_mkApps // vc //.
+ Qed.
+
+ Lemma transform_blocks_mkApps_eta_fn f args : isEtaExp Σ f ->
+ transform_blocks (mkApps f args) = mkApps (transform_blocks f) (map (transform_blocks) args).
+ Proof.
+ intros ef.
+ destruct (decompose_app f) eqn:df.
+ rewrite (decompose_app_inv df) in ef |- *.
+ rewrite -mkApps_app.
+ move/isEtaExp_mkApps: ef.
+ pose proof (decompose_app_notApp _ _ _ df).
+ rewrite decompose_app_mkApps /= //.
+ rewrite transform_blocks_decompose.
+ rewrite decompose_app_mkApps /= //.
+ destruct (construct_viewc t) eqn:vc.
+ + move=> /andP[] etanl etal.
+ destruct lookup_constructor_pars_args as [[pars args']|] eqn:hl => //.
+ cbn.
+ rewrite chop_firstn_skipn.
+ rewrite transform_blocks_decompose.
+ rewrite decompose_app_mkApps // /= hl.
+ rewrite chop_firstn_skipn.
+ rewrite - mkApps_app.
+ move: etanl. rewrite /isEtaExp_app hl.
+ move => /andP[] /Nat.leb_le => hl' hall.
+ rewrite firstn_map.
+ rewrite firstn_app.
+ assert (args' - #|l| = 0) as -> by lia.
+ rewrite firstn_O // app_nil_r. f_equal. f_equal.
+ rewrite firstn_map //. rewrite map_app skipn_map.
+ rewrite skipn_app. len.
+ assert (args' - #|l| = 0) as -> by lia.
+ now rewrite skipn_0 -skipn_map.
+ move: etanl. rewrite /isEtaExp_app hl //.
+ + move => /andP[] etat etal.
+ rewrite (transform_blocks_decompose (mkApps t l)).
+ rewrite decompose_app_mkApps //.
+ rewrite vc. rewrite -mkApps_app. f_equal.
+ now rewrite map_app.
+ Qed.
+
+ Lemma transform_blocks_csubst a k b :
+ closed a ->
+ isEtaExp Σ a ->
+ isEtaExp Σ b ->
+ transform_blocks (ECSubst.csubst a k b) = ECSubst.csubst (transform_blocks a) k (transform_blocks b).
+ Proof using Type.
+ funelim (transform_blocks b); cbn; simp transform_blocks isEtaExp; rewrite -?isEtaExp_equation_1 -?transform_blocks_equation_1; toAll; simpl;
+ intros; try easy;
+ rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length;
+ unfold test_def in *;
+ simpl closed in *; try solve [simpl subst; simpl closed; f_equal; auto; rtoProp; solve_all]; try easy.
+
+ - destruct Nat.compare => //.
+ - f_equal. solve_all. move/andP: b => [] _ he. solve_all.
+ - rewrite csubst_mkApps.
+ rtoProp. solve_all.
+ assert (
+ mkApps (transform_blocks u) (map transform_blocks v) =
+ transform_blocks (mkApps u v)
+ ) as ->. { rewrite transform_blocks_mkApps. eauto. now rewrite Heq. }
+ eapply (transform_blocks_mkApps_eta (fun x => transform_blocks (mkApps (csubst a k u) (map (csubst a k) v)) =
+ csubst (transform_blocks a) k x)); eauto.
+ rewrite Heq.
+ rewrite csubst_mkApps.
+ rewrite isEtaExp_mkApps_napp in H3 => //. rewrite Heq in H3.
+ rtoProp. rename H3 into etau. rename H4 into etav.
+ rewrite - H //.
+ rewrite transform_blocks_mkApps_eta_fn.
+ now eapply etaExp_csubst.
+ f_equal.
+ rewrite !map_map_compose. solve_all.
+ - pose proof (etaExp_csubst _ _ k _ H1 H2).
+ rewrite !csubst_mkApps /= in H3 *.
+ assert (map (csubst a k) v <> []).
+ { destruct v; cbn; congruence. }
+ rewrite transform_blocks_mkApps //.
+ rewrite isEtaExp_Constructor // in H3.
+ move: H3 => /andP[] /andP[]. rewrite map_length. move=> etaapp etav bargs.
+ destruct block_args; invs bargs.
+ cbn -[lookup_constructor_pars_args].
+ unfold isEtaExp_app in etaapp.
+ rewrite Heq in etaapp |- *.
+ destruct (chop nargs v) eqn:heqc.
+ rewrite map_map_compose.
+ erewrite !chop_map; eauto.
+ rewrite csubst_mkApps. cbn.
+ eapply chop_eq in heqc as ->.
+ cbn.
+ rewrite isEtaExp_Constructor in H2.
+ move: H2 => /andP[] /andP[] He1 He2 He3.
+ cbn. f_equal. f_equal.
+ all: rewrite !map_map_compose; solve_all; eapply All_app in He2.
+ all: repeat solve_all.
+ - pose proof (etaExp_csubst _ _ k _ H1 H2).
+ rewrite !csubst_mkApps /= in H3 *.
+ assert (map (csubst a k) v <> []).
+ { destruct v; cbn; congruence. }
+ rewrite transform_blocks_mkApps //.
+ rewrite isEtaExp_Constructor // in H3.
+ move/andP : H3 => [] /andP[]. rewrite map_length. move=> etaapp etav bargs.
+ cbn -[lookup_inductive_pars].
+ unfold isEtaExp_app in etaapp.
+ destruct lookup_constructor_pars_args as [[pars args]|] eqn:eqpars => //.
+ Qed.
+
+ Lemma transform_blocks_substl s t :
+ forallb (closedn 0) s ->
+ forallb (isEtaExp Σ) s ->
+ isEtaExp Σ t ->
+ transform_blocks (substl s t) = substl (map transform_blocks s) (transform_blocks t).
+ Proof using Type.
+ induction s in t |- *; simpl; auto.
+ move=> /andP[] cla cls /andP[] etaa etas etat.
+ rewrite IHs //. now eapply etaExp_csubst. f_equal.
+ now rewrite transform_blocks_csubst.
+ Qed.
+
+ Lemma transform_blocks_iota_red pars args br :
+ forallb (closedn 0) args ->
+ forallb (isEtaExp Σ) args ->
+ isEtaExp Σ br.2 ->
+ transform_blocks (EGlobalEnv.iota_red pars args br) = EGlobalEnv.iota_red pars (map transform_blocks args) (on_snd transform_blocks br).
+ Proof using Type.
+ intros cl etaargs etabr.
+ unfold EGlobalEnv.iota_red.
+ rewrite transform_blocks_substl //.
+ rewrite forallb_rev forallb_skipn //.
+ rewrite forallb_rev forallb_skipn //.
+ now rewrite map_rev map_skipn.
+ Qed.
+
+ Lemma transform_blocks_fix_subst mfix : EGlobalEnv.fix_subst (map (map_def transform_blocks) mfix) = map transform_blocks (EGlobalEnv.fix_subst mfix).
+ Proof using Type.
+ unfold EGlobalEnv.fix_subst.
+ rewrite map_length.
+ generalize #|mfix|.
+ induction n; simpl; auto.
+ f_equal; auto. now simp transform_blocks.
+ Qed.
+
+ Lemma transform_blocks_cofix_subst mfix : EGlobalEnv.cofix_subst (map (map_def transform_blocks) mfix) = map transform_blocks (EGlobalEnv.cofix_subst mfix).
+ Proof using Type.
+ unfold EGlobalEnv.cofix_subst.
+ rewrite map_length.
+ generalize #|mfix|.
+ induction n; simpl; auto.
+ f_equal; auto. now simp transform_blocks.
+ Qed.
+
+ Lemma transform_blocks_cunfold_fix mfix idx n f :
+ forallb (closedn 0) (fix_subst mfix) ->
+ forallb (fun d => isLambda (dbody d) && isEtaExp Σ (dbody d)) mfix ->
+ cunfold_fix mfix idx = Some (n, f) ->
+ cunfold_fix (map (map_def transform_blocks) mfix) idx = Some (n, transform_blocks f).
+ Proof using Type.
+ intros hfix heta.
+ unfold cunfold_fix.
+ rewrite nth_error_map.
+ destruct nth_error eqn:heq.
+ intros [= <- <-] => /=. f_equal. f_equal.
+ rewrite transform_blocks_substl //.
+ now apply isEtaExp_fix_subst.
+ solve_all. eapply nth_error_all in heta; tea. cbn in heta.
+ rtoProp; intuition auto.
+ f_equal. f_equal. apply transform_blocks_fix_subst.
+ discriminate.
+ Qed.
+
+
+ Lemma transform_blocks_cunfold_cofix mfix idx n f :
+ forallb (closedn 0) (cofix_subst mfix) ->
+ forallb (isEtaExp Σ ∘ dbody) mfix ->
+ cunfold_cofix mfix idx = Some (n, f) ->
+ cunfold_cofix (map (map_def transform_blocks) mfix) idx = Some (n, transform_blocks f).
+ Proof using Type.
+ intros hcofix heta.
+ unfold cunfold_cofix.
+ rewrite nth_error_map.
+ destruct nth_error eqn:heq.
+ intros [= <- <-] => /=. f_equal.
+ rewrite transform_blocks_substl //.
+ now apply isEtaExp_cofix_subst.
+ solve_all. now eapply nth_error_all in heta; tea.
+ f_equal. f_equal. apply transform_blocks_cofix_subst.
+ discriminate.
+ Qed.
+
+ Lemma transform_blocks_nth {n l d} :
+ transform_blocks (nth n l d) = nth n (map transform_blocks l) (transform_blocks d).
+ Proof using Type.
+ induction l in n |- *; destruct n; simpl; auto.
+ Qed.
+
+ Definition switch_constructor_as_block fl : WcbvFlags :=
+ EWcbvEval.Build_WcbvFlags fl.(@with_prop_case) fl.(@with_guarded_fix) true.
+
+End transform_blocks.
+
+Definition transform_blocks_constant_decl Σ cb :=
+ {| cst_body := option_map (transform_blocks Σ) cb.(cst_body) |}.
+
+Definition transform_blocks_decl Σ d :=
+ match d with
+ | ConstantDecl cb => ConstantDecl (transform_blocks_constant_decl Σ cb)
+ | InductiveDecl idecl => d
+ end.
+
+Definition transform_blocks_env Σ :=
+ map (on_snd (transform_blocks_decl Σ)) Σ.
+
+Definition transform_blocks_program (p : eprogram_env) :=
+ (transform_blocks_env p.1, transform_blocks p.1 p.2).
+
+Definition term_flags :=
+ {|
+ has_tBox := true;
+ has_tRel := true;
+ has_tVar := false;
+ has_tEvar := false;
+ has_tLambda := true;
+ has_tLetIn := true;
+ has_tApp := true;
+ has_tConst := true;
+ has_tConstruct := true;
+ has_tCase := true;
+ has_tProj := false;
+ has_tFix := true;
+ has_tCoFix := false
+ |}.
+
+Definition env_flags :=
+ {| has_axioms := false;
+ has_cstr_params := false;
+ term_switches := term_flags |}.
+
+Local Existing Instance env_flags.
+
+Lemma Qpreserves_wellformed Σ : wf_glob Σ -> Qpreserves (fun n x => wellformed Σ n x) Σ.
+Proof.
+ intros clΣ.
+ split.
+ - red. move=> n t.
+ destruct t; cbn; intuition auto; try solve [constructor; auto].
+ eapply on_letin; rtoProp; intuition auto.
+ eapply on_app; rtoProp; intuition auto.
+ eapply on_case; rtoProp; intuition auto. solve_all.
+ eapply on_fix. solve_all. move/andP: H => [] _ ha. solve_all.
+ - red. intros kn decl.
+ move/(lookup_env_wellformed clΣ).
+ unfold wf_global_decl. destruct cst_body => //.
+ - red. move=> hasapp n t args. rewrite wellformed_mkApps //.
+ split; intros; rtoProp; intuition auto; solve_all.
+ - red. cbn => //.
+ (* move=> hascase n ci discr brs. simpl.
+ destruct lookup_inductive eqn:hl => /= //.
+ split; intros; rtoProp; intuition auto; solve_all. *)
+ - red. move=> hasproj n p discr. now cbn in hasproj.
+ - red. move=> t args clt cll.
+ eapply wellformed_substl. solve_all. now rewrite Nat.add_0_r.
+ - red. move=> n mfix idx. cbn. unfold wf_fix.
+ split; intros; rtoProp; intuition auto; solve_all. now apply Nat.ltb_lt.
+ - red. move=> n mfix idx. cbn.
+ split; intros; rtoProp; intuition auto; solve_all.
+Qed.
+
+Definition block_wcbv_flags :=
+ {| with_prop_case := false ; with_guarded_fix := false ; with_constructor_as_block := true |}.
+
+Local Hint Resolve wellformed_closed : core.
+
+Lemma wellformed_lookup_inductive_pars Σ kn mdecl :
+ wf_glob Σ ->
+ lookup_minductive Σ kn = Some mdecl -> mdecl.(ind_npars) = 0.
+Proof.
+ induction 1; cbn => //.
+ case: eqb_spec => [|].
+ - intros ->. destruct d => //. intros [= <-].
+ cbn in H0. unfold wf_minductive in H0.
+ rtoProp. cbn in H0. now eapply eqb_eq in H0.
+ - intros _. eapply IHwf_glob.
+Qed.
+
+Lemma wellformed_lookup_constructor_pars {Σ kn c mdecl idecl cdecl} :
+ wf_glob Σ ->
+ lookup_constructor Σ kn c = Some (mdecl, idecl, cdecl) -> mdecl.(ind_npars) = 0.
+Proof.
+ intros wf. cbn -[lookup_minductive].
+ destruct lookup_minductive eqn:hl => //.
+ do 2 destruct nth_error => //.
+ eapply wellformed_lookup_inductive_pars in hl => //. congruence.
+Qed.
+
+Lemma lookup_constructor_pars_args_spec {Σ ind n mdecl idecl cdecl} :
+ wf_glob Σ ->
+ lookup_constructor Σ ind n = Some (mdecl, idecl, cdecl) ->
+ lookup_constructor_pars_args Σ ind n = Some (mdecl.(ind_npars), cdecl.(cstr_nargs)).
+Proof.
+ cbn -[lookup_constructor] => wfΣ.
+ destruct lookup_constructor as [[[mdecl' idecl'] [pars args]]|] eqn:hl => //.
+ intros [= -> -> <-]. cbn. f_equal.
+Qed.
+
+Lemma wellformed_lookup_constructor_pars_args {Σ ind n block_args} :
+ wf_glob Σ ->
+ wellformed Σ 0 (EAst.tConstruct ind n block_args) ->
+ ∑ args, lookup_constructor_pars_args Σ ind n = Some (0, args).
+Proof.
+ intros wfΣ wf. cbn -[lookup_constructor] in wf.
+ destruct lookup_constructor as [[[mdecl idecl] cdecl]|] eqn:hl => //.
+ exists cdecl.(cstr_nargs).
+ pose proof (wellformed_lookup_constructor_pars wfΣ hl).
+ eapply lookup_constructor_pars_args_spec in hl => //. congruence.
+Qed.
+
+Lemma constructor_isprop_pars_decl_params {Σ ind c b pars cdecl} :
+ wf_glob Σ ->
+ constructor_isprop_pars_decl Σ ind c = Some (b, pars, cdecl) -> pars = 0.
+Proof.
+ intros hwf.
+ rewrite /constructor_isprop_pars_decl /lookup_constructor /lookup_inductive.
+ destruct lookup_minductive as [mdecl|] eqn:hl => /= //.
+ do 2 destruct nth_error => //.
+ eapply wellformed_lookup_inductive_pars in hl => //. congruence.
+Qed.
+
+Lemma skipn_ge m {A} (l : list A) :
+ m >= length l -> skipn m l = [].
+Proof.
+ induction l in m |- *.
+ - destruct m; reflexivity.
+ - cbn. destruct m; try lia. intros H.
+ eapply IHl. lia.
+Qed.
+
+Lemma chop_all {A} (l : list A) m :
+ m >= length l -> chop m l = (l, nil).
+Proof.
+ intros Hl. rewrite chop_firstn_skipn.
+ rewrite firstn_ge; try lia. rewrite skipn_ge; try lia.
+ eauto.
+Qed.
+
+Lemma transform_blocks_tApp Σ t a (P : term -> Set) k :
+ wf_glob Σ ->
+ wellformed Σ k (tApp t a) ->
+ (let (fn, args) := decompose_app (tApp t a) in
+ match construct_viewc fn with
+ | view_construct kn c block_args =>
+ match lookup_constructor_pars_args Σ kn c with
+ | Some (0, nargs) =>
+ let cargs := map (transform_blocks Σ) args in
+ let '(cargs, rest) := MCList.chop nargs cargs in
+ (args <> [] /\ t = mkApps (tConstruct kn c block_args) (remove_last args) /\ a = last args a) ->
+ P (mkApps (tConstruct kn c cargs) rest)
+ | _ => True
+ end
+ | view_other fn nconstr =>
+ P (tApp (transform_blocks Σ t) (transform_blocks Σ a))
+ end) ->
+ P (transform_blocks Σ (tApp t a)).
+Proof.
+ intros wfΣ wf.
+ rewrite (transform_blocks_decompose _ (tApp t a)).
+ destruct decompose_app eqn:da.
+ pose proof (decompose_app_notApp _ _ _ da).
+ pose proof (EInduction.decompose_app_app _ _ _ _ da).
+ destruct construct_viewc eqn:vc.
+ + eapply EEtaExpandedFix.decompose_app_tApp_split in da as [Ha Ht].
+ cbn in wf.
+ move: wf => /andP[]. rewrite Ha wellformed_mkApps // => /andP[] wfc wfl wft.
+ destruct (wellformed_lookup_constructor_pars_args wfΣ wfc).
+ rewrite e. cbn.
+ destruct chop eqn:eqch => //.
+ intros. apply H1. intuition auto.
+ + pose proof (decompose_app_notApp _ _ _ da).
+ pose proof (EInduction.decompose_app_app _ _ _ _ da).
+ eapply EEtaExpandedFix.decompose_app_tApp_split in da as [Ha Ht].
+ rewrite Ha Ht.
+ rewrite transform_blocks_mkApps // vc.
+ rewrite {3} (remove_last_last l a) => //.
+ now rewrite map_app mkApps_app.
+Qed.
+
+Lemma eval_mkApps_Construct_inv {fl : WcbvFlags} Σ kn c args e block_args mdecl idecl cdecl :
+ with_constructor_as_block = false ->
+ lookup_constructor Σ kn c = Some (mdecl, idecl, cdecl) ->
+ eval Σ (mkApps (tConstruct kn c block_args) args) e ->
+ ∑ args', (e = mkApps (tConstruct kn c []) args') × All2 (eval Σ) args args' × block_args = [] × #|args| <= cstr_arity mdecl cdecl.
+Proof.
+ intros hblock hlook.
+ revert e; induction args using rev_ind; intros e.
+ - intros ev. depelim ev. congruence. exists []=> //. invs i. destruct block_args; invs H0 => //. cbn. repeat split. econstructor. lia.
+ - intros ev. rewrite mkApps_app /= in ev.
+ depelim ev; try solve_discr.
+ destruct (IHargs _ ev1) as [? []]. solve_discr.
+ all:try specialize (IHargs _ ev1) as [? []]; try solve_discr; try noconf H.
+ * destruct p as (? & ? & ?). exists (x0 ++ [a']). split => //.
+ rewrite mkApps_app /= //. split => //. eapply All2_app; eauto.
+ split => //. eapply All2_length in a. len. rewrite e1 in hlook; invs hlook. lia.
+ * destruct p as (? & ? & ?). subst f'.
+ cbn in i.
+ rewrite isConstructApp_mkApps in i. cbn in i.
+ rewrite orb_true_r in i. cbn in i. congruence.
+ * now cbn in i.
+Qed.
+
+Lemma transform_blocks_isConstructApp Σ t :
+ wf_glob Σ -> wellformed Σ 0 t ->
+ isConstructApp (transform_blocks Σ t) = isConstructApp t.
+Proof.
+ intros Hwf Hwf'.
+ induction t; try now cbn; eauto.
+ eapply transform_blocks_tApp; eauto.
+ destruct decompose_app.
+ destruct construct_viewc.
+ - destruct lookup_constructor_pars_args as [ [[]] | ]; eauto.
+ cbn. destruct chop. intros (? & ? & ?). subst.
+ rewrite -[tApp _ _](mkApps_app _ _ [t2]).
+ rewrite !isConstructApp_mkApps. cbn. reflexivity.
+ - change (tApp t1 t2) with (mkApps t1 [t2]).
+ change (tApp (transform_blocks Σ t1) (transform_blocks Σ t2)) with
+ (mkApps (transform_blocks Σ t1) [transform_blocks Σ t2]).
+ rewrite !isConstructApp_mkApps.
+ eapply IHt1. cbn in Hwf'. rtoProp. intuition.
+Qed.
+
+Lemma lookup_env_transform_blocks Σ kn :
+ lookup_env (transform_blocks_env Σ) kn =
+ option_map (transform_blocks_decl Σ) (lookup_env Σ kn).
+Proof.
+ unfold transform_blocks_env.
+ induction Σ at 2 4; simpl; auto.
+ case: eqb_spec => //.
+Qed.
+
+Lemma transform_blocks_declared_constant Σ c decl :
+ declared_constant Σ c decl -> declared_constant (transform_blocks_env Σ) c (transform_blocks_constant_decl Σ decl).
+Proof.
+ intros H. red in H; red.
+ rewrite lookup_env_transform_blocks H //.
+Qed.
+
+Lemma lookup_constructor_transform_blocks Σ ind c :
+lookup_constructor (transform_blocks_env Σ) ind c =
+lookup_constructor Σ ind c.
+Proof.
+ unfold lookup_constructor, lookup_inductive, lookup_minductive in *.
+ rewrite lookup_env_transform_blocks.
+ destruct lookup_env as [ [] | ]; cbn; congruence.
+Qed.
+
+Lemma transform_blocks_eval (fl := EWcbvEval.target_wcbv_flags) :
+ forall Σ, isEtaExp_env Σ -> wf_glob Σ ->
+ forall t t',
+ wellformed Σ 0 t ->
+ isEtaExp Σ t ->
+ EWcbvEval.eval Σ t t' ->
+ @EWcbvEval.eval block_wcbv_flags (transform_blocks_env Σ) (transform_blocks Σ t) (transform_blocks Σ t').
+Proof.
+ intros Σ etaΣ wfΣ.
+ eapply
+ (EWcbvEvalEtaInd.eval_preserve_mkApps_ind fl eq_refl (efl := env_flags) Σ _
+ (wellformed Σ) (Qpres := Qpreserves_wellformed _ wfΣ)) => //; eauto.
+ { intros. eapply EWcbvEval.eval_wellformed => //; tea. }
+ all:intros *.
+ - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end.
+ eapply transform_blocks_tApp. eauto. { cbn. rtoProp; eauto. }
+ destruct decompose_app as [fn args] eqn:heq.
+ destruct construct_viewc eqn:heqv.
+ + destruct lookup_constructor_pars_args as [[[] args']|] => // /=.
+ destruct chop eqn:eqch.
+ intros [Hl [ha ht]]. rewrite ha in H.
+ destruct with_constructor_as_block eqn:E.
+ * eapply eval_mkApps_Construct_block_inv in H as (args'' & Ha1 & Ha2 & Ha3); eauto. congruence.
+ * rewrite ha in i3. rewrite wellformed_mkApps in i3; eauto. rtoProp. cbn [wellformed] in H0.
+ rtoProp. destruct lookup_constructor as [ [[]] | ] eqn:hel; cbn in H4; try congruence.
+ eapply eval_mkApps_Construct_inv in H as (args'' & Ha1 & Ha2 & -> & ?); eauto.
+ solve_discr.
+ + econstructor; tea.
+ - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end.
+ eapply transform_blocks_tApp. eauto. cbn. rtoProp; eauto.
+ destruct decompose_app as [fn args] eqn:heq.
+ destruct construct_viewc eqn:heqv.
+ + destruct lookup_constructor_pars_args as [[] |] => // /=.
+ destruct n0; eauto.
+ destruct chop eqn:eqch.
+ intros [Hl [ha ht]]. rewrite ha in H.
+ destruct with_constructor_as_block eqn:E.
+ * eapply eval_mkApps_Construct_block_inv in H as (args'' & Ha1 & Ha2 & Ha3); eauto. congruence.
+ * rewrite ha in i7. rewrite wellformed_mkApps in i7; eauto. rtoProp. cbn [wellformed] in H0.
+ rtoProp. destruct lookup_constructor as [ [[]] | ] eqn:hel; cbn in H5; try congruence.
+ eapply eval_mkApps_Construct_inv in H as (args'' & Ha1 & Ha2 & -> & ?); eauto.
+ solve_discr.
+ + econstructor.
+ * revert e1. set (x := transform_blocks Σ f0).
+ simp transform_blocks.
+ * eauto.
+ * rewrite transform_blocks_csubst in e; eauto.
+ 1: now simp_eta in i10.
+ now rewrite - transform_blocks_equation_1.
+ - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end.
+ simp transform_blocks. rewrite -!transform_blocks_equation_1.
+ econstructor; eauto.
+ rewrite -transform_blocks_csubst; eauto.
+ - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end.
+ simp transform_blocks. rewrite -!transform_blocks_equation_1.
+ cbn [plus].
+ rewrite transform_blocks_mkApps in e0 => //.
+ assert (pars = 0) as -> by now (eapply constructor_isprop_pars_decl_params; eauto).
+ cbn [construct_viewc] in e0.
+ pose proof (Hcon := H2).
+ rewrite /constructor_isprop_pars_decl in H2.
+ destruct lookup_constructor as [[[]] | ] eqn:eqc; cbn in H2; invs H2.
+ rewrite -> lookup_constructor_pars_args_cstr_arity with (1 := eqc) in e0.
+ erewrite chop_all in e0. 2:len.
+ eapply eval_iota_block => //.
+ + cbn [fst]. eapply e0.
+ + unfold constructor_isprop_pars_decl.
+ rewrite lookup_constructor_transform_blocks. cbn [fst].
+ rewrite eqc //= H8 //.
+ + now rewrite map_InP_spec nth_error_map H3; eauto.
+ + len.
+ + rewrite H9. len.
+ + rewrite wellformed_mkApps in i4 => //.
+ rewrite isEtaExp_Constructor in i6 => //. rtoProp.
+ rewrite -transform_blocks_iota_red.
+ * solve_all.
+ * solve_all.
+ * eapply forallb_nth_error in H. rewrite -> H3 in H => //.
+ * now rewrite H9.
+ - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end.
+ eapply transform_blocks_tApp. eauto. eauto; cbn; rtoProp; eauto.
+ destruct decompose_app as [ f args] eqn:heq.
+ destruct construct_viewc eqn:heqv.
+ + destruct lookup_constructor_pars_args as [[] |] => // /=.
+ destruct n0; eauto.
+ destruct chop eqn:eqch.
+ intros [Hl [ha ht]]. rewrite ha in H0.
+ destruct with_constructor_as_block eqn:E.
+ * eapply eval_mkApps_Construct_block_inv in H0 as (args'' & Ha1 & Ha2 & Ha3); eauto. congruence.
+ * rewrite ha in i7. rewrite wellformed_mkApps in i7; eauto. rtoProp. cbn [wellformed] in H1.
+ rtoProp. destruct lookup_constructor as [ [[]] | ] eqn:hel; cbn in H9; try congruence.
+ eapply eval_mkApps_Construct_inv in H0 as (args'' & Ha1 & Ha2 & -> & ?); eauto.
+ solve_discr.
+ + eapply eval_fix'.
+ * eauto.
+ * revert e1. set (x := transform_blocks Σ f5).
+ simp transform_blocks.
+ * rewrite map_InP_spec.
+ cbn in i8. unfold wf_fix in i8. rtoProp.
+ erewrite <- transform_blocks_cunfold_fix => //.
+ all: eauto.
+ eapply closed_fix_subst. solve_all. destruct x; cbn in H5 |- *. eauto.
+ simp_eta in i10.
+ * eauto.
+ * revert e.
+ eapply transform_blocks_tApp => //.
+ -- cbn. rtoProp. split; eauto. eapply wellformed_cunfold_fix; eauto.
+ -- destruct (decompose_app (tApp fn av)) eqn:E; eauto.
+ destruct (construct_viewc t0) eqn:E1; eauto.
+ destruct (lookup_constructor_pars_args Σ ind n) as [ [[ ]] | ] eqn:E2; eauto.
+ cbn zeta. destruct chop eqn:E3. intros (? & ? & ?).
+ subst. rewrite -> H7 in *. intros He.
+ eapply eval_mkApps_Construct_block_inv in He as (? & ? & ? & ?); eauto. subst.
+ rewrite -[tApp _ _](mkApps_app _ _ [last l av]) in i1.
+ rewrite H7 - remove_last_last in i1 => //.
+ rewrite isEtaExp_Constructor in i1. rtoProp.
+ rewrite isEtaExp_Constructor in H3. rtoProp.
+ unfold isEtaExp_app in *.
+ rewrite E2 in H3, H5.
+ eapply leb_complete in H3, H5.
+ exfalso.
+ enough (n0 >= #|l|).
+ { destruct l; try congruence. rewrite remove_last_length in H3. cbn in H5, H3, H13. lia. }
+ destruct (chop n0 l) eqn:Ec.
+ erewrite chop_map in E3 => //. 2: eauto.
+ inversion E3. subst. destruct l2; invs H15.
+ rewrite chop_firstn_skipn in Ec. invs Ec.
+ eapply PCUICSR.skipn_nil_length in H15. lia.
+ - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end.
+ simp transform_blocks. rewrite -!transform_blocks_equation_1.
+ rewrite map_InP_spec. cbn [plus].
+ eapply eval_wellformed in H2; eauto.
+ rewrite wellformed_mkApps in H2; eauto.
+ rtoProp. now cbn in H2.
+ - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end.
+ simp transform_blocks. rewrite -!transform_blocks_equation_1.
+ econstructor.
+ eapply transform_blocks_declared_constant; eauto.
+ destruct decl. cbn in *. now rewrite H0.
+ eauto.
+ - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end.
+ eapply transform_blocks_tApp; eauto. cbn; rtoProp; eauto.
+ destruct decompose_app as [ f args] eqn:heq.
+ destruct construct_viewc eqn:heqv.
+ + destruct lookup_constructor_pars_args as [[] args'|] eqn:hl => // /=.
+ destruct n0; eauto.
+ destruct chop eqn:eqch.
+ intros [Hl [ha ht]]. pose proof ev as Hev. rewrite ha in Hev.
+ destruct with_constructor_as_block eqn:E.
+ * eapply eval_mkApps_Construct_block_inv in Hev as (args'' & Ha1 & Ha2 & Ha3); eauto. subst.
+ destruct args as [ | []]; cbn in *; congruence.
+ * rewrite ha in i3. rewrite wellformed_mkApps in i3; eauto. rtoProp. cbn [wellformed] in H.
+ rtoProp. destruct lookup_constructor as [ [[]] | ] eqn:hel; cbn in H6; try congruence.
+ eapply eval_mkApps_Construct_inv in Hev as (args'' & Ha1 & Ha2 & -> & ?); eauto. subst.
+ rewrite isConstructApp_mkApps in H1. rewrite orb_true_r in H1 => //.
+ + eapply transform_blocks_tApp; eauto. cbn; rtoProp; eauto.
+ destruct (decompose_app (tApp f' a')). destruct (construct_viewc t0).
+ * destruct lookup_constructor_pars_args as [ [[]] | ] eqn:hpa; eauto.
+ cbn [plus]. destruct chop eqn:heqch.
+ intros [hl [ht ha]]. rewrite ht in H1. rewrite isConstructApp_mkApps orb_true_r in H1 => //.
+ * eapply eval_app_cong; eauto.
+ revert H1.
+ destruct f'; try now cbn; tauto.
+ intros H. cbn in H.
+ rewrite transform_blocks_isConstructApp; eauto.
+ destruct (isConstructApp (tApp f'1 f'2)).
+ -- cbn in H. congruence.
+ -- eapply transform_blocks_tApp; eauto. clear.
+ destruct decompose_app.
+ destruct construct_viewc; try now cbn; eauto.
+ destruct lookup_constructor_pars_args as [[[]] | ]; eauto.
+ cbn. destruct chop. cbn. intros.
+ destruct l1 using rev_case; cbn; eauto.
+ rewrite mkApps_app; cbn; eauto.
+ - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end.
+ simp transform_blocks. rewrite -!transform_blocks_equation_1.
+ rewrite !transform_blocks_mkApps => //.
+ cbn [construct_viewc].
+ erewrite lookup_constructor_pars_args_cstr_arity; eauto.
+ destruct (chop (cstr_nargs cdecl) args) eqn:E1.
+ destruct (chop (cstr_nargs cdecl) args') eqn:E2.
+ erewrite !chop_map; eauto.
+ specialize H as Heq.
+ unfold lookup_constructor, lookup_inductive, lookup_minductive in Heq.
+ destruct lookup_env eqn:E; try now inv Heq.
+ eapply lookup_env_wellformed in E; eauto.
+ destruct g; cbn in Heq; try now inv Heq.
+ cbn in E.
+ destruct nth_error; try now inv Heq.
+ destruct nth_error; invs Heq.
+ rewrite /wf_minductive in E. rtoProp.
+ cbn in H4. eapply eqb_eq in H4.
+ unfold cstr_arity in H0.
+ rewrite -> H4 in *. cbn in H0.
+ revert E1 E2.
+ rewrite <- H0.
+ rewrite !chop_firstn_skipn !firstn_all. intros [= <- <-] [= <- <-].
+ eapply All2_length in X0 as Hlen.
+ cbn.
+ rewrite !skipn_all Hlen skipn_all firstn_all. cbn.
+ eapply eval_mkApps_Construct_block; eauto.
+ now rewrite lookup_constructor_transform_blocks.
+ len. unfold cstr_arity. lia.
+ solve_all. destruct H6; eauto.
+ - intros. econstructor. destruct t; cbn in H |- *; try congruence.
+Qed.
diff --git a/erasure/theories/EDeps.v b/erasure/theories/EDeps.v
index 1b72d5c12..90399e1a8 100644
--- a/erasure/theories/EDeps.v
+++ b/erasure/theories/EDeps.v
@@ -57,6 +57,8 @@ Proof.
now constructor.
- depelim er.
now constructor.
+ - depelim er.
+ econstructor; eauto.
- depelim er.
econstructor; eauto.
induction X; [easy|].
@@ -105,6 +107,8 @@ Proof.
now constructor.
- depelim er.
now constructor.
+ - depelim er.
+ econstructor; eauto.
- depelim er.
econstructor; eauto.
induction X; [easy|].
@@ -160,6 +164,8 @@ Proof.
now constructor.
- depelim er.
now constructor.
+ - depelim er.
+ cbn. econstructor; eauto.
- depelim er.
econstructor; [easy|easy|easy|easy|easy|].
induction X; [easy|].
@@ -253,7 +259,7 @@ Qed.
Notation "Σ ⊢ s ▷ t" := (eval Σ s t) (at level 50, s, t at next level) : type_scope.
-Lemma erases_deps_eval {wfl:WcbvFlags} Σ t v Σ' :
+Lemma erases_deps_eval {wfl:WcbvFlags} {hcon : with_constructor_as_block = false} Σ t v Σ' :
Σ' ⊢ t ▷ v ->
erases_deps Σ Σ' t ->
erases_deps Σ Σ' v.
@@ -275,8 +281,9 @@ Proof.
+ intuition auto.
apply erases_deps_mkApps_inv in H4.
now apply Forall_rev, Forall_skipn.
- + eapply nth_error_forall in e0; [|now eauto].
+ + eapply nth_error_forall in e1; [|now eauto].
assumption.
+ - congruence.
- depelim er.
subst brs; cbn in *.
depelim H3.
@@ -326,10 +333,12 @@ Proof.
intuition auto.
apply erases_deps_mkApps_inv in H3 as (? & ?).
apply IHev2.
- now eapply nth_error_forall in e1.
+ now eapply nth_error_forall in e2.
+ - congruence.
- constructor.
- depelim er.
now constructor.
+ - congruence.
- depelim er. now constructor.
- easy.
Qed.
@@ -367,7 +376,7 @@ Lemma erases_deps_forall_ind Σ Σ'
declared_constructor Σ' (ind, c) mdecl' idecl' cdecl' ->
erases_one_inductive_body idecl idecl' ->
erases_mutual_inductive_body mdecl mdecl' ->
- P (Extract.E.tConstruct ind c))
+ P (Extract.E.tConstruct ind c []))
(Hcase : forall (p : inductive × nat) mdecl idecl mdecl' idecl' (discr : Extract.E.term) (brs : list (list name × Extract.E.term)),
PCUICAst.declared_inductive Σ (fst p) mdecl idecl ->
EGlobalEnv.declared_inductive Σ' (fst p) mdecl' idecl' ->
diff --git a/erasure/theories/EEtaExpanded.v b/erasure/theories/EEtaExpanded.v
index f43c00455..42b442e59 100644
--- a/erasure/theories/EEtaExpanded.v
+++ b/erasure/theories/EEtaExpanded.v
@@ -26,15 +26,15 @@ Hint Constructors eval : core.
Import MCList (map_InP, map_InP_elim, map_InP_spec).
Equations discr_construct (t : term) : Prop :=
-discr_construct (tConstruct ind n) := False ;
+discr_construct (tConstruct ind n block_args) := False ;
discr_construct _ := True.
Inductive construct_view : term -> Type :=
-| view_construct : forall ind n, construct_view (tConstruct ind n)
+| view_construct : forall ind n block_args, construct_view (tConstruct ind n block_args)
| view_other : forall t, discr_construct t -> construct_view t.
Equations construct_viewc t : construct_view t :=
-construct_viewc (tConstruct ind n) := view_construct ind n ;
+construct_viewc (tConstruct ind n block_args) := view_construct ind n block_args ;
construct_viewc t := view_other t I.
Ltac toAll :=
@@ -55,6 +55,8 @@ Section isEtaExp.
Import TermSpineView.
+ Definition is_nil {A} (l : list A) := match l with [] => true | _ => false end.
+
Equations? isEtaExp (e : EAst.term) : bool
by wf e (fun x y : EAst.term => size x < size y) :=
| e with TermSpineView.view e := {
@@ -62,7 +64,7 @@ Section isEtaExp.
| tEvar ev args => forallb_InP args (fun x H => isEtaExp x)
| tLambda na M => isEtaExp M
| tApp u v napp nnil with construct_viewc u :=
- { | view_construct ind i => isEtaExp_app ind i (List.length v) && forallb_InP v (fun x H => isEtaExp x)
+ { | view_construct ind i block_args => isEtaExp_app ind i (List.length v) && forallb_InP v (fun x H => isEtaExp x) && is_nil block_args
| view_other _ _ => isEtaExp u && forallb_InP v (fun x H => isEtaExp x) }
| tLetIn na b b' => isEtaExp b && isEtaExp b'
| tCase ind c brs => isEtaExp c && forallb_InP brs (fun x H => isEtaExp x.2)
@@ -72,15 +74,16 @@ Section isEtaExp.
| tBox => true
| tVar _ => true
| tConst _ => true
- | tConstruct ind i => isEtaExp_app ind i 0 }.
+ | tConstruct ind i block_args => isEtaExp_app ind i 0 && is_nil block_args }.
Proof.
all:try lia.
all:try apply (In_size); tea.
all:try lia.
- now apply (In_size id size).
- rewrite size_mkApps.
- change (fun x => size (id x)) with size in H. cbn.
- now apply (In_size id size).
+ eapply (In_size id size) in H.
+ change (fun x => size (id x)) with size in H. unfold id in *; cbn.
+ lia.
- now eapply size_mkApps_f.
- change (fun x => size (id x)) with size in H.
eapply (In_size id size) in H. unfold id in H.
@@ -102,7 +105,7 @@ Section isEtaExp.
Lemma isEtaExp_mkApps_nonnil f v :
~~ isApp f -> v <> [] ->
isEtaExp (mkApps f v) = match construct_viewc f with
- | view_construct ind i => isEtaExp_app Σ ind i #|v| && forallb isEtaExp v
+ | view_construct ind i block_args => isEtaExp_app Σ ind i #|v| && forallb isEtaExp v && is_nil block_args
| view_other t discr => isEtaExp f && forallb isEtaExp v
end.
Proof using Type.
@@ -114,7 +117,7 @@ Section isEtaExp.
Lemma isEtaExp_mkApps_napp f v : ~~ isApp f ->
isEtaExp (mkApps f v) = match construct_viewc f with
- | view_construct ind i => isEtaExp_app Σ ind i #|v| && forallb isEtaExp v
+ | view_construct ind i block_args => isEtaExp_app Σ ind i #|v| && forallb isEtaExp v && is_nil block_args
| view_other t discr => isEtaExp f && forallb isEtaExp v
end.
Proof using Type.
@@ -124,8 +127,8 @@ Section isEtaExp.
- rewrite isEtaExp_mkApps_nonnil //.
Qed.
- Lemma isEtaExp_Constructor ind i v :
- isEtaExp (mkApps (EAst.tConstruct ind i) v) = isEtaExp_app Σ ind i #|v| && forallb isEtaExp v.
+ Lemma isEtaExp_Constructor ind i v block_args :
+ isEtaExp (mkApps (EAst.tConstruct ind i block_args) v) = isEtaExp_app Σ ind i #|v| && forallb isEtaExp v && is_nil block_args.
Proof using Type.
rewrite isEtaExp_mkApps_napp //.
Qed.
@@ -134,7 +137,7 @@ Section isEtaExp.
Lemma isEtaExp_mkApps f u : isEtaExp (mkApps f u) ->
let (hd, args) := decompose_app (mkApps f u) in
match construct_viewc hd with
- | view_construct kn c => isEtaExp_app Σ kn c #|args| && forallb isEtaExp args
+ | view_construct kn c block_args => isEtaExp_app Σ kn c #|args| && forallb isEtaExp args && is_nil block_args
| view_other u discr => isEtaExp hd && forallb isEtaExp args
end.
Proof using Type.
@@ -143,7 +146,7 @@ Section isEtaExp.
pose proof (decompose_app_notApp _ _ _ da).
destruct l. cbn -[isEtaExp].
intros eq; rewrite eq.
- destruct (construct_viewc t) => //. simp isEtaExp in eq; now rewrite eq.
+ destruct (construct_viewc t) => //. simp isEtaExp in eq. rtoProp. solve_all.
assert (t0 :: l <> []) by congruence.
revert da H0. generalize (t0 :: l). clear t0 l; intros l.
intros da nnil.
@@ -179,9 +182,9 @@ Section isEtaExp.
Lemma isEtaExp_tApp {f u} : isEtaExp (EAst.tApp f u) ->
let (hd, args) := decompose_app (EAst.tApp f u) in
match construct_viewc hd with
- | view_construct kn c =>
+ | view_construct kn c block_args =>
args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\
- isEtaExp_app Σ kn c #|args| && forallb isEtaExp args
+ isEtaExp_app Σ kn c #|args| && forallb isEtaExp args && is_nil block_args
| view_other _ discr =>
[&& isEtaExp hd, forallb isEtaExp args, isEtaExp f & isEtaExp u]
end.
@@ -232,17 +235,19 @@ Section WeakEtaExp.
pose proof (decompose_app_notApp _ _ _ da).
destruct l0. simp_eta.
- rewrite isEtaExp_mkApps_napp //.
- destruct construct_viewc. cbn. len.
- rtoProp; repeat solve_all. cbn in et. simp isEtaExp in et.
+ destruct construct_viewc. cbn. len.
+ rtoProp; repeat solve_all. cbn in et. rtoProp. rename H0 into et. simp isEtaExp in et.
eapply isEtaExp_app_mon; tea; lia.
- eapply All_app_inv; eauto. rewrite et forallb_app /=.
+ eapply All_app_inv; eauto.
+ cbn in et. rtoProp. rename H0 into et. simp isEtaExp in et.
+ rewrite et forallb_app /=.
rtoProp; repeat solve_all.
- rewrite isEtaExp_mkApps_napp in et => //.
destruct construct_viewc.
rewrite -mkApps_app. rewrite isEtaExp_Constructor.
- cbn. cbn. rtoProp; solve_all.
- eapply isEtaExp_app_mon; tea. cbn. len. now depelim H1.
- depelim H1. solve_all. eapply All_app_inv => //.
+ rtoProp; solve_all.
+ eapply isEtaExp_app_mon; tea. cbn. len. solve_all. depelim H2.
+ solve_all. eapply All_app_inv => //. econstructor; eauto.
eapply All_app_inv => //. eauto.
rewrite -mkApps_app. rewrite isEtaExp_mkApps_napp //.
destruct (construct_viewc t0) => //.
@@ -259,6 +264,7 @@ Section WeakEtaExp.
- intros. simp isEtaExp ; cbn. destruct Nat.compare => //. simp_eta in H.
- move/andP: H2 => [] etab etab'.
apply/andP. split; eauto.
+ - rtoProp. intuition eauto. now destruct block_args.
- rtoProp. intuition eauto.
solve_all.
- move/andP: b => [] etaexp h.
@@ -269,6 +275,7 @@ Section WeakEtaExp.
rewrite csubst_mkApps /=.
rewrite isEtaExp_Constructor. solve_all.
rewrite map_length. rtoProp; solve_all. solve_all.
+ now destruct block_args.
- rewrite csubst_mkApps /=.
move/andP: H2 => [] eu ev.
specialize (H _ k H1 eu).
@@ -459,7 +466,7 @@ Inductive expanded : term -> Prop :=
declared_constructor Σ (ind, idx) mind idecl cdecl ->
#|args| >= cstr_arity mind cdecl ->
Forall expanded args ->
- expanded (mkApps (tConstruct ind idx) args)
+ expanded (mkApps (tConstruct ind idx []) args)
| expanded_tBox : expanded tBox.
End expanded.
@@ -497,7 +504,7 @@ forall (Σ : global_declarations) (P : term -> Prop),
(idecl : one_inductive_body) cdecl
(args : list term),
declared_constructor Σ (ind, idx) mind idecl cdecl ->
- #|args| >= cstr_arity mind cdecl -> Forall (expanded Σ) args -> Forall P args -> P (mkApps (tConstruct ind idx) args)) ->
+ #|args| >= cstr_arity mind cdecl -> Forall (expanded Σ) args -> Forall P args -> P (mkApps (tConstruct ind idx []) args)) ->
(P tBox) ->
forall t : term, expanded Σ t -> P t.
Proof.
@@ -570,7 +577,8 @@ Proof.
- rewrite forallb_InP_spec in H0. eapply forallb_Forall in H0. eapply In_All in H.
econstructor. solve_all.
- eapply andb_true_iff in H1 as []; eauto.
- - eapply isEtaExp_app_expanded in H as (? & ? & ? & ? & ?).
+ - rtoProp. eapply isEtaExp_app_expanded in H as (? & ? & ? & ? & ?).
+ destruct block_args; inv H0.
eapply expanded_tConstruct_app with (args := []); eauto.
- eapply andb_true_iff in H1 as []. destruct ind. econstructor; eauto.
rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2.
@@ -581,9 +589,10 @@ Proof.
intuition auto.
- econstructor. rewrite forallb_InP_spec in H0. eapply forallb_Forall in H0.
eapply In_All in H. solve_all.
- - eapply andb_true_iff in H0 as []. eapply In_All in H.
- rewrite forallb_InP_spec in H1. eapply forallb_Forall in H1.
+ - rtoProp. eapply In_All in H.
+ rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2.
eapply isEtaExp_app_expanded in H0 as (? & ? & ? & ? & ?).
+ destruct block_args; inv H1.
eapply expanded_tConstruct_app; eauto. solve_all.
- eapply andb_true_iff in H1 as []. rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2.
econstructor.
@@ -603,8 +612,8 @@ Proof.
eauto).
- eapply isEtaExp_mkApps_intro; eauto. solve_all.
- solve_all. now rewrite b H.
- - rewrite isEtaExp_Constructor. eapply andb_true_iff.
- split. 2: eapply forallb_Forall.
+ - rewrite isEtaExp_Constructor. rtoProp; repeat split.
+ 2: eapply forallb_Forall.
2: solve_all. eapply expanded_isEtaExp_app_; eauto.
Qed.
@@ -668,8 +677,8 @@ Proof.
eapply In_All in H0; solve_all.
- eapply In_All in H. simp_eta; rtoProp; intuition auto. solve_all.
- eapply In_All in H. simp_eta; rtoProp; intuition auto.
- rewrite EEtaExpanded.isEtaExp_Constructor. apply/andP; split. exact H1.
- solve_all.
+ rewrite EEtaExpanded.isEtaExp_Constructor. rtoProp; repeat split. eauto.
+ solve_all. destruct block_args; cbn in *; eauto.
- eapply In_All in H, H0. simp_eta.
move => /andP[] /andP[] etafix etamfix etav.
eapply EEtaExpanded.isEtaExp_mkApps_intro. simp_eta.
diff --git a/erasure/theories/EEtaExpandedFix.v b/erasure/theories/EEtaExpandedFix.v
index bb087a915..3d8101415 100644
--- a/erasure/theories/EEtaExpandedFix.v
+++ b/erasure/theories/EEtaExpandedFix.v
@@ -58,7 +58,7 @@ Inductive expanded (Γ : list nat): term -> Prop :=
declared_constructor Σ (ind, idx) mind idecl cdecl ->
#|args| >= ind_npars mind + cdecl.(cstr_nargs) ->
Forall (expanded Γ) args ->
- expanded Γ (mkApps (tConstruct ind idx) args)
+ expanded Γ (mkApps (tConstruct ind idx []) args)
| expanded_tBox : expanded Γ tBox.
End expanded.
@@ -135,7 +135,7 @@ Lemma expanded_ind :
→ #|args| ≥ ind_npars mind + cdecl.(cstr_nargs)
→ Forall (expanded Σ Γ) args
→ Forall (P Γ) args
- → P Γ (mkApps (tConstruct ind idx) args))
+ → P Γ (mkApps (tConstruct ind idx []) args))
→ (∀ Γ : list nat, P Γ tBox)
→ ∀ (Γ : list nat) (t : term), expanded Σ Γ t → P Γ t.
Proof.
@@ -225,19 +225,19 @@ Proof.
Qed.
Equations discr_expanded_head (t : term) : Prop :=
- discr_expanded_head (tConstruct ind n) := False ;
+ discr_expanded_head (tConstruct ind n block_args) := False ;
discr_expanded_head (tFix mfix idx) := False ;
discr_expanded_head (tRel n) := False ;
discr_expanded_head _ := True.
Inductive expanded_head_view : term -> Type :=
-| expanded_head_construct : forall ind n, expanded_head_view (tConstruct ind n)
+| expanded_head_construct : forall ind n block_args, expanded_head_view (tConstruct ind n block_args)
| expanded_head_fix : forall mfix idx, expanded_head_view (tFix mfix idx)
| expanded_head_rel : forall n, expanded_head_view (tRel n)
| expanded_head_other : forall t, discr_expanded_head t -> expanded_head_view t.
Equations expanded_head_viewc t : expanded_head_view t :=
- expanded_head_viewc (tConstruct ind n) := expanded_head_construct ind n ;
+ expanded_head_viewc (tConstruct ind n block_args) := expanded_head_construct ind n block_args;
expanded_head_viewc (tFix mfix idx) := expanded_head_fix mfix idx ;
expanded_head_viewc (tRel n) := expanded_head_rel n ;
expanded_head_viewc t := expanded_head_other t I.
@@ -266,6 +266,8 @@ Section isEtaExp.
Import TermSpineView.
+ Definition is_nil {A} (l : list A) := match l with nil => true | _ => false end.
+
Equations? isEtaExp (Γ : list nat) (e : EAst.term) : bool
by wf e (fun x y : EAst.term => size x < size y) :=
isEtaExp Γ e with TermSpineView.view e := {
@@ -273,7 +275,7 @@ Section isEtaExp.
| tEvar ev args => forallb_InP args (fun x H => isEtaExp Γ x)
| tLambda na M => isEtaExp (0 :: Γ) M
| tApp u v napp nnil with expanded_head_viewc u :=
- { | expanded_head_construct ind i => isEtaExp_app ind i (List.length v) && forallb_InP v (fun x H => isEtaExp Γ x)
+ { | expanded_head_construct ind i block_args => isEtaExp_app ind i (List.length v) && forallb_InP v (fun x H => isEtaExp Γ x) && is_nil block_args
| expanded_head_fix mfix idx =>
isEtaExp_fixapp mfix idx (List.length v) &&
forallb_InP mfix (fun x H => isLambda x.(dbody) && isEtaExp (rev_map (S ∘ rarg) mfix ++ Γ) x.(dbody)) && forallb_InP v (fun x H => isEtaExp Γ x)
@@ -287,14 +289,15 @@ Section isEtaExp.
| tBox => true
| tVar _ => true
| tConst _ => true
- | tConstruct ind i => isEtaExp_app ind i 0 }.
+ | tConstruct ind i block_args => isEtaExp_app ind i 0 && is_nil block_args }.
Proof using Σ.
all:try lia.
all:try apply (In_size); tea.
all:try lia.
- now apply (In_size id size).
- - rewrite size_mkApps.
- now apply (In_size id size).
+ - rewrite size_mkApps. cbn.
+ apply (In_size id size) in H.
+ unfold id in H. change (fun x => size x) with size in H. lia.
- rewrite size_mkApps.
apply (In_size id (fun d => size d.(dbody))) in H. unfold id in H.
change (fun x => size x) with size in H. cbn. lia.
@@ -325,7 +328,7 @@ Section isEtaExp.
Lemma isEtaExp_mkApps_nonnil Γ f v :
~~ isApp f -> v <> [] ->
isEtaExp Γ (mkApps f v) = match expanded_head_viewc f with
- | expanded_head_construct ind i => isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v
+ | expanded_head_construct ind i block_args => isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v && is_nil block_args
| expanded_head_fix mfix idx => isEtaExp_fixapp mfix idx #|v| &&
forallb (fun x => isLambda x.(dbody) && isEtaExp (rev_map (S ∘ rarg) mfix ++ Γ) x.(dbody)) mfix && forallb (isEtaExp Γ) v
| expanded_head_rel n => option_default (fun m => m <=? List.length v) (nth_error Γ n) false && forallb (fun x => isEtaExp Γ x) v
@@ -345,7 +348,7 @@ Section isEtaExp.
Lemma isEtaExp_mkApps Γ f v : ~~ isApp f ->
isEtaExp Γ (mkApps f v) = match expanded_head_viewc f with
- | expanded_head_construct ind i => isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v
+ | expanded_head_construct ind i block_args => isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v && is_nil block_args
| expanded_head_fix mfix idx =>
isEtaExp_fixapp mfix idx #|v| &&
forallb (fun x => isLambda x.(dbody) && isEtaExp (rev_map (S ∘ rarg) mfix ++ Γ) x.(dbody)) mfix && forallb (isEtaExp Γ) v
@@ -362,8 +365,8 @@ Section isEtaExp.
- rewrite isEtaExp_mkApps_nonnil //.
Qed.
- Lemma isEtaExp_Constructor Γ ind i v :
- isEtaExp Γ (mkApps (EAst.tConstruct ind i) v) = isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v.
+ Lemma isEtaExp_Constructor Γ ind i block_args v :
+ isEtaExp Γ (mkApps (EAst.tConstruct ind i block_args) v) = isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v && is_nil block_args.
Proof.
now rewrite isEtaExp_mkApps.
Qed.
@@ -380,7 +383,7 @@ Section isEtaExp.
- rewrite isEtaExp_mkApps //.
destruct expanded_head_viewc.
+ cbn. len.
- rtoProp; repeat solve_all. cbn in et. simp isEtaExp in et.
+ rtoProp; repeat solve_all; cbn in et; rtoProp; eauto. rename H0 into et. simp isEtaExp in et.
eapply isEtaExp_app_mon; tea; lia.
eapply All_app_inv; eauto.
+ cbn in *; congruence.
@@ -393,9 +396,9 @@ Section isEtaExp.
- rewrite isEtaExp_mkApps in et => //.
destruct expanded_head_viewc.
+ rewrite -mkApps_app. rewrite isEtaExp_Constructor.
- cbn. cbn. rtoProp; solve_all.
- eapply isEtaExp_app_mon; tea. cbn. len. now depelim H1.
- depelim H1. solve_all. eapply All_app_inv => //.
+ rtoProp; solve_all.
+ eapply isEtaExp_app_mon; tea. cbn. len. solve_all. depelim H2.
+ eapply All_app_inv => //. econstructor; eauto.
eapply All_app_inv => //. eauto.
+ rewrite -mkApps_app. rewrite isEtaExp_mkApps //. simp expanded_head_viewc.
rewrite /isEtaExp_fixapp in et |- *.
@@ -439,8 +442,10 @@ Section isEtaExp.
rewrite ?closedn_mkApps; rtoProp; (try toAll); repeat solve_all.
- destruct nth_error eqn:Hn; cbn in H; try easy.
eapply nth_error_Some_length in Hn. now eapply Nat.ltb_lt.
+ - destruct block_args; cbn in *; eauto.
- eapply a in b. 2: f_equal. revert b. now len.
- eapply a in b. 2: f_equal. revert b. now len.
+ - cbn. destruct block_args; cbn in *; eauto.
- cbn. solve_all. rtoProp; intuition auto. eapply a in H0. 2: reflexivity. revert H0. now len.
- destruct nth_error eqn:Hn; cbn in H1; try easy.
eapply nth_error_Some_length in Hn. now eapply Nat.ltb_lt.
@@ -466,6 +471,7 @@ Section isEtaExp.
- move/andP: H2 => [] etab etab'. simp_eta.
apply/andP. split; eauto.
eapply H0 with (Γ := 0 :: Γ0); cbn; eauto.
+ - rtoProp. intuition eauto. destruct block_args; cbn in *; eauto.
- rtoProp. intuition eauto.
solve_all. rewrite app_assoc. eapply a0; cbn; eauto. now len. cbn.
now rewrite app_assoc.
@@ -473,7 +479,7 @@ Section isEtaExp.
- fold csubst. move/andP: H1 => [] etaexp h.
rewrite csubst_mkApps /=.
rewrite isEtaExp_Constructor. solve_all.
- rewrite map_length. rtoProp; solve_all. solve_all.
+ rewrite map_length. rtoProp; solve_all. solve_all. destruct block_args; cbn in *; eauto.
- rewrite csubst_mkApps /=.
move/andP : H2 => [] /andP [] eu ef ev.
rewrite isEtaExp_mkApps //.
@@ -504,7 +510,7 @@ Section isEtaExp.
Qed.
Lemma etaExp_csubst a b n :
- isEtaExp []a -> isEtaExp [n] b -> isEtaExp [] (ECSubst.csubst a 0 b).
+ isEtaExp []a -> isEtaExp [n] b -> isEtaExp [] (ECSubst.csubst a 0 b).
Proof.
intros.
eapply etaExp_csubst' with (Γ := []); eauto.
@@ -535,6 +541,7 @@ Section isEtaExp.
apply/andP. split; eauto.
eapply H; eauto. solve_all.
eapply H0 with (Γ := 0 :: Γ0); eauto. solve_all.
+ - rtoProp. intuition eauto. destruct block_args; eauto.
- rtoProp. intuition eauto.
solve_all. rewrite app_assoc. eapply a; cbn-[isEtaExp]; eauto. now len. cbn.
now rewrite app_assoc.
@@ -552,7 +559,7 @@ Section isEtaExp.
eapply All_impl; tea; cbv beta.
intros x Hx.
eapply Hx; eauto.
- solve_all. apply Hx.
+ solve_all. apply Hx. now destruct block_args.
- solve_all. rewrite csubst_mkApps /=.
move/andP : H2 => [] /andP [] eu ef ev.
rewrite isEtaExp_mkApps //.
@@ -730,7 +737,7 @@ Section isEtaExp.
Lemma isEtaExp_tApp Γ f u : isEtaExp Γ (mkApps f u) ->
let (hd, v) := decompose_app (mkApps f u) in
match expanded_head_viewc hd with
- | expanded_head_construct ind i => isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v
+ | expanded_head_construct ind i block_args => isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v && is_nil block_args
| expanded_head_fix mfix idx => isEtaExp_fixapp mfix idx #|v| &&
forallb (fun x => isLambda x.(dbody) && isEtaExp (rev_map (S ∘ rarg) mfix ++ Γ) x.(dbody)) mfix && forallb (isEtaExp Γ) v
| expanded_head_rel n => (option_default (fun m => m <=? List.length v) (nth_error Γ n) false) && forallb (fun x => isEtaExp Γ x) v
@@ -788,16 +795,18 @@ Proof.
- eapply expanded_tRel_app with (args := []). destruct (nth_error); invs H. f_equal. eapply Nat.eqb_eq in H1; eauto. cbn. lia. econstructor.
- rewrite forallb_InP_spec in H0. eapply forallb_Forall in H0. eapply In_All in H. econstructor. solve_all.
- eapply andb_true_iff in H1 as []; eauto.
- - eapply isEtaExp_app_expanded in H as (? & ? & ? & ? & ?).
+ - rtoProp. eapply isEtaExp_app_expanded in H as (? & ? & ? & ? & ?).
+ destruct block_args; cbn in *; eauto.
eapply expanded_tConstruct_app with (args := []); eauto.
- eapply andb_true_iff in H1 as []. destruct ind. econstructor; eauto.
rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2.
eapply In_All in H0. solve_all.
- econstructor. rewrite forallb_InP_spec in H0. eapply forallb_Forall in H0.
eapply In_All in H. solve_all.
- - eapply andb_true_iff in H0 as []. eapply In_All in H.
- rewrite forallb_InP_spec in H1. eapply forallb_Forall in H1.
+ - rtoProp. eapply In_All in H.
+ rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2.
eapply isEtaExp_app_expanded in H0 as (? & ? & ? & ? & ?).
+ destruct block_args; cbn in *; eauto.
eapply expanded_tConstruct_app; eauto. solve_all.
- rtoProp. rewrite forallb_InP_spec in H2. rewrite forallb_InP_spec in H3. eapply In_All in H. eapply In_All in H0.
unfold isEtaExp_fixapp in H1. destruct nth_error eqn:E; try congruence.
@@ -830,9 +839,9 @@ Proof.
+ unfold isEtaExp_fixapp. rewrite H4. eapply Nat.ltb_lt. lia.
+ solve_all; rtoProp; intuition auto.
+ solve_all.
- - rewrite isEtaExp_Constructor. eapply andb_true_iff.
- split. 2: eapply forallb_Forall.
- 2: solve_all. eapply expanded_isEtaExp_app_; eauto.
+ - rewrite isEtaExp_Constructor. rtoProp. repeat split.
+ 2: eapply forallb_Forall; solve_all.
+ eapply expanded_isEtaExp_app_; eauto.
Qed.
Definition isEtaExp_constant_decl Σ cb :=
@@ -871,9 +880,9 @@ Arguments isEtaExp : simpl never.
Lemma isEtaExp_tApp' {Σ} {Γ} {f u} : isEtaExp Σ Γ (tApp f u) ->
let (hd, args) := decompose_app (tApp f u) in
match expanded_head_viewc hd with
- | expanded_head_construct kn c =>
+ | expanded_head_construct kn c block_args =>
args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\
- isEtaExp_app Σ kn c #|args| && forallb (isEtaExp Σ Γ) args
+ isEtaExp_app Σ kn c #|args| && forallb (isEtaExp Σ Γ) args && is_nil block_args
| expanded_head_fix mfix idx =>
args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\
isEtaExp_fixapp mfix idx #|args| && forallb (fun d => isLambda d.(dbody) && isEtaExp Σ (rev_map (fun d => 1 + d.(rarg)) mfix ++ Γ) d.(dbody)) mfix && forallb (isEtaExp Σ Γ) args
@@ -1008,22 +1017,22 @@ Qed.
Arguments lookup_inductive_pars_constructor_pars_args {Σ ind n pars args}.
-Lemma eval_etaexp {fl : WcbvFlags} {efl : EEnvFlags} {Σ a a'} :
+Lemma eval_etaexp {fl : WcbvFlags} {efl : EEnvFlags} {wcon : with_constructor_as_block = false} {Σ a a'} :
isEtaExp_env Σ ->
wf_glob Σ ->
eval Σ a a' -> isEtaExp Σ [] a -> isEtaExp Σ [] a'.
Proof.
intros etaΣ wfΣ.
- induction 1 as [ | ? ? ? ? ? ? ? ? IHs | | | | ? ? ? ? ? ? ? ? ? ? ? IHs | ? ? ? ? ? ? ? ? ? ? ? IHs
- | ? ? ? ? ? ? ? ? ? ? IHs | | | | | | | | ] using eval_mkApps_rect.
+ induction 1 as [ | ? ? ? ? ? ? ? ? IHs | | | | | ? ? ? ? ? ? ? ? ? ? ? IHs | ? ? ? ? ? ? ? ? ? ? ? IHs
+ | ? ? ? ? ? ? ? ? ? ? IHs | | | | | | | | | | ] using eval_mkApps_rect; try now congruence.
all:try simp isEtaExp; rewrite -!isEtaExp_equation_1 => //.
6:{
move/isEtaExp_tApp'.
destruct decompose_app eqn:da.
destruct expanded_head_viewc eqn:vc.
- * move => [hl [hf [ha /andP[] ise etal]]].
+ * move => [hl [hf [ha /andP[] /andP[] ise etal bargs]]]. destruct block_args; cbn in *; eauto.
pose proof (H' := H).
- rewrite hf in H'. eapply eval_mkApps_Construct_inv in H' as [? []]. exfalso. solve_discr.
+ rewrite hf in H'. eapply eval_mkApps_Construct_inv in H' as [? []]. exfalso. solve_discr. auto.
* move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel.
pose proof (mkApps_app (EAst.tFix mfix idx) argsv [av]).
cbn in H3. rewrite <- H3. clear H3.
@@ -1064,8 +1073,8 @@ Proof.
move/isEtaExp_tApp'.
destruct decompose_app eqn:da.
destruct expanded_head_viewc eqn:vc.
- * move => [hl [hf [ha /andP[] ise etal]]]. clear IHs.
- rewrite hf in H. eapply eval_mkApps_Construct_inv in H as [? []]. exfalso. solve_discr.
+ * move => [hl [hf [ha /andP[] /andP[] ise etal bargs]]]. clear IHs. destruct block_args; inv bargs.
+ rewrite hf in H. eapply eval_mkApps_Construct_inv in H as [? []]. exfalso. solve_discr. auto.
* move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel.
subst.
eapply IHeval3.
@@ -1114,11 +1123,11 @@ Proof.
11:{ move/isEtaExp_tApp'.
destruct decompose_app eqn:da.
destruct expanded_head_viewc.
- * move=> [] hl [] hf [] ha /andP[] hl' etal.
+ * move=> [] hl [] hf [] ha /andP[] /andP[] hl' etal bargs. destruct block_args; inv bargs.
move: H H0. rewrite hf => H H0.
- destruct (eval_construct_size H) as [args' []]. subst f'.
- rewrite isConstructApp_mkApps /= in H1.
- rewrite !negb_or in H1. rtoProp; intuition auto. now cbn in H3.
+ destruct (eval_construct_size wcon H) as [args' []]. subst f'.
+ rewrite isConstructApp_mkApps /= in i.
+ rewrite !negb_or in i. rtoProp; intuition auto. now cbn in H3.
* move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel.
subst.
@@ -1127,7 +1136,7 @@ Proof.
{
specialize eval_mkApps_tFix_inv_size with (Heval := H); intros [(args' & ? & Heq) | (? & ? & ? & ? & ?)]; eauto.
- -- subst. rewrite isFixApp_mkApps in H1 => //. destruct EAst.isLambda; easy.
+ -- subst. rewrite isFixApp_mkApps in i => //. destruct EAst.isLambda; easy.
-- eapply (isEtaExp_mkApps_intro _ _ f' [a']); eauto.
eapply IHeval1. rewrite isEtaExp_mkApps => //.
cbn [expanded_head_viewc]. rtoProp.
@@ -1135,7 +1144,7 @@ Proof.
2: eapply All_firstn; eauto.
unfold isEtaExp_fixapp, cunfold_fix in *.
destruct nth_error; try easy.
- invs H5. eapply Nat.ltb_lt. lia.
+ invs H4. eapply Nat.ltb_lt. lia.
}
{
@@ -1145,7 +1154,7 @@ Proof.
unshelve eapply H0. 2: eauto. lia.
eapply (isEtaExp_mkApps_intro).
eapply (isEtaExp_mkApps_intro _ _ fn [a_']); eauto. 2: econstructor; [ | econstructor].
- ++ eapply isEtaExp_cunfold_fix. 2: eauto. solve_all. now rewrite app_nil_r in H5.
+ ++ eapply isEtaExp_cunfold_fix. 2: eauto. solve_all. now rewrite app_nil_r in H4.
++ solve_all. eapply All_firstn in isel. unfold remove_last in Heq. eapply All_Forall in isel.
setoid_rewrite Heq in isel. invs isel. eauto.
++ eapply forallb_Forall in isel. eapply Forall_firstn in isel. unfold remove_last in Heq.
@@ -1153,7 +1162,7 @@ Proof.
destruct b0. unshelve eapply H0. 2: eauto. lia. eauto.
}
* intros (? & ? & ? & ?). rtoProp. solve_all.
- rewrite nth_error_nil in H6. easy.
+ rewrite nth_error_nil in H5. easy.
* move/and4P => [] etat etal etaf etaa.
eapply (isEtaExp_mkApps_intro _ _ f' [a']); eauto.
}
@@ -1161,64 +1170,65 @@ Proof.
move/isEtaExp_tApp'.
destruct decompose_app eqn:da.
destruct expanded_head_viewc.
- * move=> [] hl [] hf [] ha /andP[] hl' etal.
+ * move=> [] hl [] hf [] ha /andP[] /andP[] hl' etal bargs. destruct block_args; inv bargs.
rewrite -[EAst.tApp _ _](mkApps_app _ _ [a']).
- rewrite isEtaExp_Constructor.
- move: H0 H1. rewrite hf. intros H0 H1.
- destruct (eval_mkApps_Construct_size H0) as [args'' [evc []]].
- eapply mkApps_eq_inj in e as [] => //. subst args''. noconf H3.
+ rewrite isEtaExp_Constructor. cbn. rewrite andb_true_r.
+ revert H H0. rewrite hf. intros H H0.
+ destruct (eval_mkApps_Construct_size wcon H) as [args'' [evc []]].
+ eapply mkApps_eq_inj in e1 as [] => //. subst args''. noconf H2.
apply/andP; split => //.
- + len.
- rewrite (remove_last_last l a) // in hl'.
+ + len.
+ rewrite (remove_last_last l0 a) // in hl'.
rewrite app_length in hl'.
cbn in hl'.
now rewrite -(All2_length a0).
+ solve_all.
- rewrite (remove_last_last l a) // in etal.
+ rewrite (remove_last_last l0 a) // in etal.
eapply All_app in etal as [etal etaa].
depelim etaa. clear etaa. rewrite -ha in i.
eapply All_app_inv; try constructor; eauto.
- clear -H1 a0 etal. solve_all.
- destruct b as [ev Hev]. eapply (H1 _ _ ev) => //. lia.
+ solve_all.
+ destruct b as [ev Hev]. eapply (H0 _ _ ev) => //. lia.
* move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel.
subst.
assert (isEtaExp Σ [] a). { rewrite ha. eapply Forall_last; solve_all. }
destruct with_guarded_fix eqn:guarded.
- { specialize eval_mkApps_tFix_inv_size with (Heval := H0); intros [(args' & ? & Heq) | (? & ? & ? & ? & ?)]; eauto.
+ { specialize eval_mkApps_tFix_inv_size with (Heval := H); intros [(args' & ? & Heq) | (? & ? & ? & ? & ?)]; eauto.
-- subst. solve_discr.
+
-- eapply (isEtaExp_mkApps_intro _ _ _ [a']); eauto.
eapply IHeval1. rewrite isEtaExp_mkApps => //.
cbn [expanded_head_viewc]. rtoProp.
repeat split; solve_all.
2: eapply All_firstn; eauto.
unfold isEtaExp_fixapp, cunfold_fix in *.
- destruct nth_error; try easy. noconf H6.
+ destruct nth_error; try easy. noconf H4.
eapply Nat.ltb_lt. lia.
}
{
- specialize eval_mkApps_tFix_inv_size_unguarded with (Heval := H0); intros Hinv; destruct Hinv as [[Heq Hv] | (a_ & a_' & args' & argsv & Heq & Hall & n & fn & Hunf & Haa' & Hev & Hev' & Hsz)]; eauto.
+ specialize eval_mkApps_tFix_inv_size_unguarded with (Heval := H); intros Hinv; destruct Hinv as [[Heq Hv] | (a_ & a_' & args' & argsv & Heq & Hall & n & fn & Hunf & Haa' & Hev & Hev' & Hsz)]; eauto.
-- cbn in *. solve_discr.
-- eapply (isEtaExp_mkApps_intro _ _ _ [a']); eauto.
- unshelve eapply H1. 2: eauto. lia.
+ unshelve eapply H0. 2: eauto. lia.
eapply (isEtaExp_mkApps_intro).
eapply (isEtaExp_mkApps_intro _ _ fn [a_']); eauto. 2: econstructor; [ | econstructor].
- ++ eapply isEtaExp_cunfold_fix. 2: eauto. solve_all. now rewrite app_nil_r in H6.
+ ++ eapply isEtaExp_cunfold_fix. 2: eauto. solve_all. now rewrite app_nil_r in H4.
++ solve_all. eapply All_firstn in isel. unfold remove_last in Heq. eapply All_Forall in isel.
setoid_rewrite Heq in isel. invs isel. eauto.
++ eapply forallb_Forall in isel. eapply Forall_firstn in isel. unfold remove_last in Heq.
setoid_rewrite Heq in isel. eapply Forall_All in isel. invs isel. solve_all. subst; eauto.
- destruct b0. unshelve eapply H1. 2: eauto. lia. eauto.
+ destruct b0. unshelve eapply H0. 2: eauto. lia. eauto.
}
- * intros (? & ? & ? & ?). rtoProp. solve_all. rewrite nth_error_nil in H7. easy.
- * move/and4P => [] etat etal etaf etaa.
+ * intros (? & ? & ? & ?). rtoProp. solve_all. rewrite nth_error_nil in H5. easy.
+ * move/and4P => [] etat etal etaf etaa.
eapply (isEtaExp_mkApps_intro _ _ _ [a']); eauto.
}
1:{ move/isEtaExp_tApp'.
destruct decompose_app eqn:da.
destruct expanded_head_viewc.
- * clear IHs. move=> [] hl [] hf [] ha /andP[] hl' etal.
+ * clear IHs. move=> [] hl [] hf [] ha /andP[] /andP[] hl' etal bargs. destruct block_args; inv bargs.
move: H H0. rewrite hf => H H0.
- eapply eval_mkApps_Construct_inv in H as [? []];solve_discr.
+ eapply (eval_mkApps_Construct_inv _ _ _ _ _ wcon) in H as [? []];solve_discr.
* solve_all. rtoProp. solve_all. subst.
destruct with_guarded_fix eqn:guarded.
@@ -1265,10 +1275,10 @@ Proof.
eapply IHeval2. rewrite /iota_red.
eapply isEtaExp_substl with (Γ := repeat 0 #|br.1|); eauto.
{ len. }
- rewrite isEtaExp_Constructor // in H5. solve_all.
- eapply All_skipn. move/andP: H5 => []. repeat solve_all.
- eapply forallb_nth_error in H7; tea.
- now erewrite H1 in H7.
+ rewrite isEtaExp_Constructor // in H1. solve_all.
+ eapply All_skipn. move/andP: H1 => []. repeat solve_all. rtoProp. solve_all.
+ eapply forallb_nth_error in H3; tea.
+ now erewrite e2 in H3.
- rtoProp; intuition auto.
eapply IHeval2. eapply isEtaExp_substl. shelve.
now apply forallb_repeat.
@@ -1278,9 +1288,9 @@ Proof.
- move/isEtaExp_tApp'.
destruct decompose_app eqn:da.
destruct expanded_head_viewc.
- * clear IHs. move=> [] hl [] hf [] ha /andP[] hl' etal.
+ * clear IHs. move=> [] hl [] hf [] ha /andP[] /andP[] hl' etal bargs. destruct block_args; inv bargs.
move: H H0. rewrite hf => H H0.
- clear H0; eapply eval_mkApps_Construct_inv in H as [? []]; solve_discr.
+ clear H0; eapply (eval_mkApps_Construct_inv _ _ _ _ _ wcon) in H as [? []]; solve_discr.
* solve_all. rtoProp. solve_all. subst.
specialize eval_mkApps_tFix_inv_size_unguarded with (Heval := H); intros Hinv;
destruct Hinv as [[Heq Heq'] | (a_ & a_' & args' & argsv & Heq & Hall & n & fn_ & Hunf & Hav & Hsza & Hev & Hsz)]; eauto; try congruence.
@@ -1327,9 +1337,9 @@ Proof.
eapply IHeval2. specialize (IHeval1 hd).
move: IHeval1.
rewrite isEtaExp_Constructor.
- destruct args => //. now rewrite nth_error_nil in H2.
- move=> /andP[] _ hargs.
- eapply nth_error_forallb in H2; tea.
+ destruct args => //. now rewrite nth_error_nil in e3.
+ intros. rtoProp.
+ eapply nth_error_forallb in e3; tea.
Qed.
Lemma isEtaExp_fixapp_mon {mfix idx n n'} : n <= n' -> isEtaExp_fixapp mfix idx n -> isEtaExp_fixapp mfix idx n'.
@@ -1465,18 +1475,18 @@ Lemma neval_to_stuck_fix {efl : EEnvFlags} {Σ mfix idx t} :
isEtaExp Σ [] t -> @eval opt_wcbv_flags Σ t (tFix mfix idx) -> False.
Proof.
intros etaΣ wfΣ he hev.
- pose proof (eval_etaexp etaΣ wfΣ hev he).
+ unshelve epose proof (eval_etaexp etaΣ wfΣ hev he). eauto.
now apply isEtaExp_tFix in H.
Qed.
-Lemma neval_to_stuck_fix_app {efl : EEnvFlags} {fl Σ mfix idx t args} :
+Lemma neval_to_stuck_fix_app {efl : EEnvFlags} {fl} {wcon : with_constructor_as_block = false} {Σ mfix idx t args} :
with_guarded_fix ->
isEtaExp_env Σ ->
wf_glob Σ ->
isEtaExp Σ [] t -> @eval fl Σ t (mkApps (tFix mfix idx) args) -> False.
Proof.
intros wguard etaΣ wfΣ he hev.
- pose proof (eval_etaexp etaΣ wfΣ hev he).
+ unshelve epose proof (eval_etaexp etaΣ wfΣ hev he); eauto.
move: H.
move/isEtaExp_tApp.
rewrite decompose_app_mkApps // /= // app_nil_r //.
@@ -1491,13 +1501,14 @@ Qed.
Lemma isEtaExp_tApp_eval {fl} {Σ} {f u v} :
with_guarded_fix ->
+ with_constructor_as_block = false ->
@eval fl Σ f v ->
isEtaExp Σ [] (tApp f u) ->
- (forall kn c args, v <> mkApps (tConstruct kn c) args) ->
+ (forall kn c args block_args, v <> mkApps (tConstruct kn c block_args) args) ->
(forall mfix idx args, v <> mkApps (tFix mfix idx) args) ->
let (hd, args) := decompose_app (tApp f u) in
match expanded_head_viewc hd with
- | expanded_head_construct kn c => False
+ | expanded_head_construct kn c _ => False
| expanded_head_fix mfix idx =>
args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\
[&& isEtaExp_fixapp mfix idx #|remove_last args|,
@@ -1508,14 +1519,14 @@ Lemma isEtaExp_tApp_eval {fl} {Σ} {f u v} :
[&& isEtaExp Σ [] hd, forallb (isEtaExp Σ []) args, isEtaExp Σ [] f & isEtaExp Σ [] u]
end.
Proof.
- intros wguard ev eta; revert eta ev.
+ intros wguard wcon ev eta; revert eta ev.
move/isEtaExp_tApp'.
cbn -[decompose_app]. destruct decompose_app eqn:da.
destruct expanded_head_viewc eqn:cv => //.
- * move=> [] hl [] ha [] ht /andP[] etaap etal.
+ * move=> [] hl [] ha [] ht /andP[] /andP[] etaap etal bargs. destruct block_args; inv bargs.
rewrite ha. intros h.
eapply eval_mkApps_Construct_inv in h as [? []]. subst v.
- intros Hc _. specialize (Hc ind n x). now apply Hc.
+ intros Hc _. specialize (Hc ind n x). now eapply Hc. auto.
* move=> [] hl [] ha [] ht /andP[] /andP[] etafix etab etal.
rewrite ha.
intros H; eapply eval_stuck_fix_eq in H as [args' [Hargs' [[]|]]]. subst v.
@@ -1608,12 +1619,12 @@ Proof.
eapply eval_app_cong_tApp'. now eapply eval_to_value in evf''. exact e0. exact evres.
Qed.
-Lemma All_eval_etaexp {fl : WcbvFlags} {efl : EEnvFlags} Σ l l' :
+Lemma All_eval_etaexp {fl : WcbvFlags} {wcon : with_constructor_as_block = false } {efl : EEnvFlags} Σ l l' :
isEtaExp_env Σ ->
wf_glob Σ ->
All2 (eval Σ) l l' -> forallb (isEtaExp Σ []) l -> forallb (isEtaExp Σ []) l'.
Proof.
- intros; solve_all. now eapply eval_etaexp.
+ intros; solve_all. eapply eval_etaexp; eauto. Unshelve. eauto.
Qed.
Lemma isFix_mkApps f args : ~~ isFix f -> ~~ isFix (mkApps f args).
@@ -1632,7 +1643,7 @@ Proof.
intros h. now apply isFix_mkApps.
Qed.
-Lemma eval_opt_to_target {fl: WcbvFlags} {efl : EEnvFlags} Σ t v :
+Lemma eval_opt_to_target {fl: WcbvFlags} {wcon : with_constructor_as_block = false} {efl : EEnvFlags} Σ t v :
with_guarded_fix ->
isEtaExp_env Σ ->
wf_glob Σ ->
@@ -1643,7 +1654,7 @@ Proof.
intros wguard etaΣ wfΣ.
intros H.
induction H using eval_mkApps_rect.
- - move/(isEtaExp_tApp_eval wguard H) => IH.
+ - move/(isEtaExp_tApp_eval wguard wcon H) => IH.
forward IH by (intros; intro; solve_discr).
forward IH by (intros; intro; solve_discr).
destruct (decompose_app (tApp a t)) eqn:da.
@@ -1661,7 +1672,7 @@ Proof.
forward IHeval2 => //.
econstructor; eauto.
- clear H0.
- move/(isEtaExp_tApp_eval wguard H) => IH.
+ move/(isEtaExp_tApp_eval wguard wcon H) => IH.
forward IH by (intros; intro; solve_discr).
forward IH by (intros; intro; solve_discr).
destruct (decompose_app (tApp f0 a)) eqn:da.
@@ -1689,14 +1700,15 @@ Proof.
eapply eval_etaexp in IHeval1; tea.
- simp_eta. move=> /andP[] etad etabrs.
forward IHeval1 => //.
- move: (eval_etaexp etaΣ wfΣ IHeval1 etad).
- rewrite isEtaExp_Constructor => /andP[] etac etaargs.
+ unshelve epose proof (eval_etaexp etaΣ wfΣ IHeval1 etad). eauto.
+ revert H1.
+ rewrite isEtaExp_Constructor => /andP[] /andP[] etac etaargs bargs.
forward_keep IHeval2 => //.
eapply isEtaExp_iota_red'; eauto.
- eapply forallb_nth_error in etabrs; tea. erewrite H1 in etabrs.
- cbn in etabrs. now rewrite -H3 app_nil_r skipn_length in etabrs.
+ eapply forallb_nth_error in etabrs; tea. erewrite e2 in etabrs.
+ cbn in etabrs. now rewrite -e4 app_nil_r skipn_length in etabrs.
econstructor; tea.
-
+ - congruence.
- simp_eta. move=> /andP[] etad etabrs.
forward IHeval1 => //.
eapply eval_iota_sing => //. tea.
@@ -1710,9 +1722,9 @@ Proof.
move/isEtaExp_tApp'.
destruct decompose_app eqn:da.
destruct expanded_head_viewc.
- * move=> [] hl [] hf [] ha heta.
+ * move=> [] hl [] hf [] ha /andP[]/ andP[] heta heta2 bargs. destruct block_args; inv bargs.
clear H0.
- rewrite hf in H. eapply eval_mkApps_Construct_inv in H as [? []]; solve_discr.
+ rewrite hf in H. eapply eval_mkApps_Construct_inv in H as [? []]; try solve_discr. auto.
* move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel.
set (H' := H); assert (eval_depth H' = eval_depth H) by reflexivity.
clearbody H'. move: H' H4. rewrite {1 2}hf. intros H'.
@@ -1769,8 +1781,8 @@ Proof.
move/isEtaExp_tApp'.
destruct decompose_app eqn:da.
destruct expanded_head_viewc.
- * move=> [] hl [] hf [] ha heta.
- rewrite hf in H. eapply eval_mkApps_Construct_inv in H as [? []]; solve_discr.
+ * move=> [] hl [] hf [] ha /andP[]/ andP[] heta heta2 bargs. destruct block_args; inv bargs.
+ rewrite hf in H. eapply eval_mkApps_Construct_inv in H as [? []]; try solve_discr. eauto.
* move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel.
rewrite hf in H.
elimtype False.
@@ -1820,10 +1832,11 @@ Proof.
forward IHeval1 by tas.
forward IHeval2.
{ eapply eval_etaexp in H; tea.
- move: H; rewrite isEtaExp_mkApps // /= => /andP[] etaapp etaargs.
+ move: H; rewrite isEtaExp_mkApps // /= => /andP[] /andP[] etaapp etaargs bargs.
eapply forallb_nth_error in etaargs; tea.
- now erewrite H2 in etaargs. }
+ now erewrite e3 in etaargs. }
eapply eval_proj; tea.
+ - congruence.
- simp_eta => etad.
forward IHeval by tas.
eapply eval_proj_prop ; tea.
@@ -1831,13 +1844,13 @@ Proof.
destruct decompose_app eqn:da.
rewrite (decompose_app_inv da).
destruct expanded_head_viewc.
- * move=> [] hl [] hf [] ha /andP[] heta etal.
- set (H' := H0) ; assert (eval_depth H' = eval_depth H0) by reflexivity.
- clearbody H'. move: H' H4. rewrite {1 2}hf. intros H'.
- destruct (eval_mkApps_Construct_size H') as [args'' [evc [evcs hargs heq]]].
- eapply mkApps_eq_inj in heq as [] => //. noconf H4. noconf H5.
+ * move=> [] hl [] hf [] ha /andP[] /andP[] heta etal bargs. destruct block_args; inv bargs.
+ set (H' := H) ; assert (eval_depth H' = eval_depth H) by reflexivity.
+ clearbody H'. move: H' H2. rewrite {1 2}hf. intros H'.
+ destruct (eval_mkApps_Construct_size wcon H') as [args'' [evc [evcs hargs heq]]].
+ eapply mkApps_eq_inj in heq as [] => //. noconf H2. noconf H3.
intros hevd.
- rewrite (remove_last_last l a hl).
+ rewrite (remove_last_last l0 a hl).
rewrite -[tApp _ _](mkApps_app _ _ [a']).
eapply eval_mkApps_Construct; tea.
{ now constructor. }
@@ -1846,22 +1859,22 @@ Proof.
eapply forallb_remove_last, forallb_All in etal.
eapply All2_All_mix_left in hargs; tea.
eapply All2_impl; tea. cbn; intros ? ? [].
- destruct s as [evxy hevxy]. unshelve eapply H1; tea. lia.
+ destruct s as [evxy hevxy]. unshelve eapply H0; tea. lia.
constructor; [|constructor]. rewrite -ha.
eapply IHeval2. rewrite ha. now eapply forallb_last.
* move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel.
forward IHeval2. { rewrite ha. now eapply forallb_last. }
- rewrite (remove_last_last l a hl) /=.
+ rewrite (remove_last_last l0 a hl) /=.
rewrite mkApps_app. eapply eval_construct; tea.
- pose proof H0 as Hfix.
+ pose proof H as Hfix.
rewrite hf in Hfix.
eapply eval_stuck_fix_eq in Hfix as [args' [hargs [[hstuck ?]|]]]; auto.
{ solve_discr. }
- { cbn in H2.
+ { cbn in H1.
rewrite hf in IHeval1. eapply IHeval1.
rewrite isEtaExp_mkApps // /= i /= etab /=.
move: isel.
- now rewrite {1}(remove_last_last l a hl) /= forallb_app => /andP[]. }
+ now rewrite {1}(remove_last_last l0 a hl) /= forallb_app => /andP[]. }
{ now rewrite -ha. }
* move=> [] hl [] ha [] ht /andP[] hnth.
now rewrite nth_error_nil /= in hnth.
@@ -1870,21 +1883,22 @@ Proof.
forward IHeval2 by tas.
rewrite -(decompose_app_inv da).
eapply eval_construct; tea.
+ - congruence.
- move/isEtaExp_tApp'.
destruct decompose_app eqn:da.
rewrite (decompose_app_inv da).
destruct expanded_head_viewc.
- * move=> [] hl [] hf [] ha /andP[] heta etal.
+ * move=> [] hl [] hf [] ha /andP[] /andP[] heta etal bargs. destruct block_args; inv bargs.
set (H' := H) ; assert (eval_depth H' = eval_depth H) by reflexivity.
- clearbody H'. move: H' H3. rewrite {1 2}hf. intros H'.
- destruct (eval_mkApps_Construct_size H') as [args'' [evc [evcs hargs heq]]].
+ clearbody H'. move: H' H2. rewrite {1 2}hf. intros H'.
+ destruct (eval_mkApps_Construct_size wcon H') as [args'' [evc [evcs hargs heq]]].
subst f'.
- rewrite isConstructApp_mkApps /isConstructApp /= in H1.
- now rewrite !negb_or /= !andb_false_r in H1.
+ rewrite isConstructApp_mkApps /isConstructApp /= in i.
+ now rewrite !negb_or /= !andb_false_r in i.
* move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel.
forward IHeval2. { rewrite ha. now eapply forallb_last. }
rewrite (remove_last_last l a hl) /=.
- rewrite mkApps_app. rewrite wguard in H1.
+ rewrite mkApps_app. rewrite wguard in i.
move: H H0. rewrite hf.
intros H IH.
eapply eval_app_cong; tea.
@@ -1892,12 +1906,12 @@ Proof.
unshelve eapply IH. exact H. lia.
pose proof H as Hfix.
eapply eval_stuck_fix_eq in Hfix as [args' [hargs [[hstuck ?]|]]]; auto.
- { subst f'. rewrite isFixApp_mkApps in H1.
- now rewrite !negb_or /= !andb_false_r in H1. }
- { rewrite isEtaExp_mkApps // /= i /= etab /=.
+ { subst f'. rewrite isFixApp_mkApps in i.
+ now rewrite !negb_or /= !andb_false_r in i. }
+ { rewrite isEtaExp_mkApps // /= i0 /= etab /=.
move: isel.
now rewrite {1}(remove_last_last l a hl) /= forallb_app => /andP[]. }
- cbn. move: H1. rewrite !negb_or; rtoProp; intuition auto.
+ cbn. move: i. rewrite !negb_or; rtoProp; intuition auto.
now eapply nisFixApp_nisFix.
* move=> [] hl [] ha [] ht /andP[] hnth.
now rewrite nth_error_nil /= in hnth.
@@ -1906,10 +1920,11 @@ Proof.
forward IHeval2 by tas.
rewrite -(decompose_app_inv da).
eapply eval_app_cong; tea.
- cbn. rewrite wguard in H1.
- cbn. move: H1. rewrite !negb_or; rtoProp; intuition auto.
+ cbn. rewrite wguard in i.
+ cbn. move: i. rewrite !negb_or; rtoProp; intuition auto.
now eapply nisFixApp_nisFix.
- intros hexp. now eapply eval_atom.
+ Unshelve. all: eauto.
Qed.
Lemma expanded_global_env_isEtaExp_env {Σ} : expanded_global_env Σ -> isEtaExp_env Σ.
diff --git a/erasure/theories/EGlobalEnv.v b/erasure/theories/EGlobalEnv.v
index 3448f7540..60aefe00d 100644
--- a/erasure/theories/EGlobalEnv.v
+++ b/erasure/theories/EGlobalEnv.v
@@ -247,7 +247,7 @@ Definition is_constructor_app_or_box t :=
| a =>
let (f, a) := decompose_app a in
match f with
- | tConstruct _ _ => true
+ | tConstruct _ _ _ => true
| _ => false
end
end.
diff --git a/erasure/theories/EInduction.v b/erasure/theories/EInduction.v
index 61a591530..659d24b37 100644
--- a/erasure/theories/EInduction.v
+++ b/erasure/theories/EInduction.v
@@ -25,7 +25,8 @@ Lemma term_forall_list_ind :
P t -> forall t0 : term, P t0 -> P (tLetIn n t t0)) ->
(forall t u : term, P t -> P u -> P (tApp t u)) ->
(forall s, P (tConst s)) ->
- (forall (i : inductive) (n : nat), P (tConstruct i n)) ->
+ (forall (i : inductive) (n : nat) (args : list term),
+ All P args -> P (tConstruct i n args)) ->
(forall (p : inductive * nat) (t : term),
P t -> forall l : list (list name * term),
All (fun x => P x.2) l -> P (tCase p t l)) ->
@@ -50,6 +51,11 @@ Proof.
destruct l; constructor; [|apply auxl'].
apply auxt.
+ revert l.
+ fix auxl' 1.
+ destruct l; constructor; [|apply auxl'].
+ apply auxt.
+
revert m.
fix auxm 1.
destruct m; constructor; [|apply auxm].
@@ -93,6 +99,7 @@ Fixpoint size t : nat :=
| tProj p c => S (size c)
| tFix mfix idx => S (list_size (fun x => size (dbody x)) mfix)
| tCoFix mfix idx => S (list_size (fun x => size (dbody x)) mfix)
+ | tConstruct _ _ ignore_args => S (list_size size ignore_args)
| _ => 1
end.
@@ -168,7 +175,7 @@ Qed.
Lemma size_mkApps_l {f l} (Hf : ~~ isApp f) (Hl : l <> []) : list_size size l < size (mkApps f l).
Proof.
rewrite size_mkApps.
- destruct f => /= //; lia.
+ destruct f => /= //; try lia.
Qed.
(** Custom induction principle on syntax, dealing with the various lists appearing in terms. *)
@@ -202,7 +209,7 @@ Section MkApps_rec.
(papp : forall t u,
~~ isApp t -> u <> nil -> P t -> All P u -> P (mkApps t u))
(pconst : forall s, P (tConst s))
- (pconstruct : forall (i : inductive) (n : nat), P (tConstruct i n))
+ (pconstruct : forall (i : inductive) (n : nat) args, All P args -> P (tConstruct i n args))
(pcase : forall (p : inductive * nat) (t : term),
P t -> forall l : list (list name * term),
All (fun x => P x.2) l -> P (tCase p t l))
@@ -229,7 +236,7 @@ Section MkApps_rec.
let pl := All_rec P id l (fun x H => rec x) in
rew _ in papp t l napp nonnil pt pl }
| tConst k => pconst k
- | tConstruct i n => pconstruct i n
+ | tConstruct i n args => pconstruct i n _ (All_rec P id args (fun x H => rec x))
| tCase ina c brs => pcase ina c (rec c) brs (All_rec P (fun x => x.2) brs (fun x H => rec x))
| tProj p c => pproj p c (rec c)
| tFix mfix idx => pfix mfix idx (All_rec P dbody mfix (fun x H => rec x))
@@ -260,7 +267,7 @@ Section MkApps_rec.
(plet : forall (n : name) (t : term), forall t0 : term, P (tLetIn n t t0))
(papp : forall t u, ~~ isApp t -> u <> nil -> P (mkApps t u))
(pconst : forall s, P (tConst s))
- (pconstruct : forall (i : inductive) (n : nat), P (tConstruct i n))
+ (pconstruct : forall (i : inductive) (n : nat) args, P (tConstruct i n args))
(pcase : forall (p : inductive * nat) (t : term) (l : list (list name * term)), P (tCase p t l))
(pproj : forall (s : projection) (t : term), P (tProj s t))
(pfix : forall (m : mfixpoint term) (n : nat), P (tFix m n))
@@ -281,7 +288,7 @@ Section MkApps_rec.
let nonnil := decompose_app_app _ _ _ _ da in
rew [P] (eq_sym (decompose_app_inv da)) in papp t l napp nonnil }
| tConst k => pconst k
- | tConstruct i n => pconstruct i n
+ | tConstruct i n args => pconstruct i n args
| tCase ina c brs => pcase ina c brs
| tProj p c => pproj p c
| tFix mfix idx => pfix mfix idx
diff --git a/erasure/theories/EInlineProjections.v b/erasure/theories/EInlineProjections.v
index 3f99c9e9c..da5debd48 100644
--- a/erasure/theories/EInlineProjections.v
+++ b/erasure/theories/EInlineProjections.v
@@ -90,7 +90,7 @@ Section optimize.
| tBox => t
| tVar _ => t
| tConst _ => t
- | tConstruct _ _ => t
+ | tConstruct _ _ _ => t
(* | tPrim _ => t *)
end.
@@ -142,6 +142,7 @@ Section optimize.
unfold wf_fix, test_def in *;
simpl closed in *; try solve [simpl subst; simpl closed; f_equal; auto; rtoProp; solve_all]; try easy.
- destruct (k ?= n0)%nat; auto.
+ - f_equal. rtoProp. now destruct args; inv H0.
- move/andP: wft => [] /andP[] hi hb hl. rewrite IHb. f_equal. unfold on_snd; solve_all.
repeat toAll. f_equal. solve_all. unfold on_snd; cbn. f_equal.
rewrite a0 //. now rewrite -Nat.add_assoc.
@@ -406,7 +407,7 @@ Proof.
now rewrite List.rev_length hskip Nat.add_0_r.
Qed.
-Definition disable_prop_cases fl := {| with_prop_case := false; with_guarded_fix := fl.(@with_guarded_fix) |}.
+Definition disable_prop_cases fl := {| with_prop_case := false; with_guarded_fix := fl.(@with_guarded_fix) ; with_constructor_as_block := false |}.
Lemma isFix_mkApps t l : isFix (mkApps t l) = isFix t && match l with [] => true | _ => false end.
Proof.
@@ -472,7 +473,7 @@ Proof.
* intros hnth. now apply IHs.
Qed.
-Lemma optimize_correct (efl := all_env_flags) {fl} {Σ : GlobalContextMap.t} t v :
+Lemma optimize_correct (efl := all_env_flags) {fl} {wcon : with_constructor_as_block = false} { Σ : GlobalContextMap.t} t v :
wf_glob Σ ->
@eval fl Σ t v ->
wellformed Σ 0 t ->
@@ -501,11 +502,13 @@ Proof.
eapply nth_error_forallb in wfbrs; tea.
rewrite Nat.add_0_r in wfbrs.
forward IHev2. eapply wellformed_iota_red; tea => //.
- rewrite optimize_iota_red in IHev2 => //. now rewrite e2.
+ rewrite optimize_iota_red in IHev2 => //. now rewrite e3.
econstructor; eauto.
rewrite -is_propositional_cstr_optimize //. tea.
- rewrite nth_error_map e0 //. len. len.
-
+ rewrite nth_error_map e1 //. len. len.
+
+ - congruence.
+
- move/andP => [] /andP[] hl wfd wfbrs.
forward IHev2. eapply wellformed_substl; tea => //.
rewrite forallb_repeat //. len.
@@ -587,7 +590,7 @@ Proof.
move/wf_mkApps: ev1 => [] wfc wfargs.
destruct lookup_projection as [[[[mdecl idecl] cdecl'] pdecl]|] eqn:hl' => //.
pose proof (lookup_projection_lookup_constructor hl').
- rewrite (constructor_isprop_pars_decl_constructor H) in e. noconf e.
+ rewrite (constructor_isprop_pars_decl_constructor H) in e0. noconf e0.
forward IHev1 by auto.
forward IHev2. eapply nth_error_forallb in wfargs; tea.
rewrite optimize_mkApps /= in IHev1.
@@ -604,11 +607,13 @@ Proof.
rewrite nth_error_rev. len. rewrite skipn_length. lia.
rewrite List.rev_involutive. len. rewrite skipn_length.
rewrite nth_error_skipn nth_error_map.
- rewrite e0 -H1.
+ rewrite e1 -H1.
assert((ind_npars mdecl + cstr_nargs cdecl - ind_npars mdecl) = cstr_nargs cdecl) by lia.
rewrite H3.
- eapply (f_equal (option_map (optimize Σ))) in e1.
- cbn in e1. rewrite -e1. f_equal. f_equal. lia.
+ eapply (f_equal (option_map (optimize Σ))) in e2.
+ cbn in e2. rewrite -e2. f_equal. f_equal. lia.
+
+ - congruence.
- move=> /andP[] iss cld.
rewrite GlobalContextMap.lookup_projection_spec.
@@ -629,11 +634,13 @@ Proof.
- move/andP=> [] clf cla.
rewrite optimize_mkApps.
eapply eval_construct; tea.
- rewrite -lookup_constructor_optimize //. exact e.
+ rewrite -lookup_constructor_optimize //. exact e0.
rewrite optimize_mkApps in IHev1. now eapply IHev1.
now len.
now eapply IHev2.
+ - congruence.
+
- move/andP => [] clf cla.
specialize (IHev1 clf). specialize (IHev2 cla).
eapply eval_app_cong; eauto.
diff --git a/erasure/theories/ELiftSubst.v b/erasure/theories/ELiftSubst.v
index 91f9b59ad..f269e6574 100644
--- a/erasure/theories/ELiftSubst.v
+++ b/erasure/theories/ELiftSubst.v
@@ -34,7 +34,7 @@ Fixpoint lift n k t : term :=
| tBox => t
| tVar _ => t
| tConst _ => t
- | tConstruct _ _ => t
+ | tConstruct ind i args => tConstruct ind i (map (lift n k) args)
(* | tPrim _ => t *)
end.
@@ -69,6 +69,7 @@ Fixpoint subst s k u :=
let k' := List.length mfix + k in
let mfix' := List.map (map_def (subst s k')) mfix in
tCoFix mfix' idx
+ | tConstruct ind i args => tConstruct ind i (map (subst s k) args)
| x => x
end.
@@ -95,6 +96,7 @@ Fixpoint closedn k (t : term) : bool :=
| tCoFix mfix idx =>
let k' := List.length mfix + k in
List.forallb (test_def (closedn k')) mfix
+ | tConstruct ind i args => forallb (closedn k) args
| _ => true
end.
@@ -106,7 +108,7 @@ Require Import PeanoNat.
Import Nat.
Lemma lift_rel_ge :
- forall k n p, p <= n -> lift k p (tRel n) = tRel (k + n).
+ forall k n p, p <= n -> lift k p (tRel n) = tRel (k + n).
Proof.
intros; simpl in |- *.
now elim (leb_spec p n).
@@ -450,8 +452,8 @@ Proof.
revert H. elim (Nat.ltb_spec n0 k); intros; try easy.
- cbn. f_equal; auto.
rtoProp; solve_all.
- rtoProp; solve_all.
- destruct x; f_equal; cbn in *. now apply a0.
+ rtoProp; solve_all.
+ destruct x; f_equal; cbn in *. eauto.
Qed.
Lemma closed_upwards {k t} k' : closedn k t -> k' >= k -> closedn k' t.
@@ -604,6 +606,7 @@ Proof.
- specialize (IHt2 (S k')).
rewrite <- Nat.add_succ_comm in IHt2.
rewrite IHt1 // IHt2 //.
+ - eapply All_forallb_eq_forallb; eauto.
- rewrite IHt //.
f_equal. eapply All_forallb_eq_forallb; tea. cbn.
intros. specialize (H (#|x.1| + k')).
diff --git a/erasure/theories/EOptimizePropDiscr.v b/erasure/theories/EOptimizePropDiscr.v
index 64a4ef6f7..2626cbd70 100644
--- a/erasure/theories/EOptimizePropDiscr.v
+++ b/erasure/theories/EOptimizePropDiscr.v
@@ -61,7 +61,7 @@ Section optimize.
| tBox => t
| tVar _ => t
| tConst _ => t
- | tConstruct _ _ => t
+ | tConstruct ind i args => tConstruct ind i (map optimize args)
(* | tPrim _ => t *)
end.
@@ -366,7 +366,8 @@ Proof.
lookup_projection
GlobalContextMap.inductive_isprop_and_pars]; intros => //.
all:unfold wf_fix_gen in *; rtoProp; intuition auto.
- all:f_equal; eauto; solve_all.
+ all:try now f_equal; eauto; solve_all.
+ - destruct args; inv H2. reflexivity.
- rewrite !GlobalContextMap.inductive_isprop_and_pars_spec.
assert (map (on_snd (optimize Σ)) l = map (on_snd (optimize Σ')) l) as -> by solve_all.
rewrite (extends_inductive_isprop_and_pars H0 H1 H2).
@@ -522,7 +523,7 @@ Proof.
destruct nth_error => //. congruence.
Qed.
-Lemma optimize_correct {efl : EEnvFlags} {fl} {Σ : GlobalContextMap.t} t v :
+Lemma optimize_correct {efl : EEnvFlags} {fl}{wcon : with_constructor_as_block = false} {Σ : GlobalContextMap.t} t v :
wf_glob Σ ->
closed_env Σ ->
@Ee.eval fl Σ t v ->
@@ -550,11 +551,26 @@ Proof.
rewrite optimize_iota_red in IHev2.
eapply eval_closed in ev1 => //.
rewrite GlobalContextMap.inductive_isprop_and_pars_spec.
- rewrite (constructor_isprop_pars_decl_inductive e).
- eapply eval_iota; eauto. tea.
+ rewrite (constructor_isprop_pars_decl_inductive e0).
+ eapply eval_iota; eauto.
now rewrite -is_propositional_cstr_optimize.
- rewrite nth_error_map e0 //. now len. cbn.
- rewrite -e2. rewrite !skipn_length map_length //.
+ rewrite nth_error_map e1 //. now len. cbn.
+ rewrite -e3. rewrite !skipn_length map_length //.
+ eapply IHev2.
+ eapply closed_iota_red => //; tea.
+ eapply nth_error_forallb in clbrs; tea. cbn in clbrs.
+ now rewrite Nat.add_0_r in clbrs.
+
+ - move/andP => [] cld clbrs.
+ have := (eval_closed _ clΣ _ _ cld ev1). intros cl.
+ rewrite optimize_iota_red in IHev2.
+ eapply eval_closed in ev1 => //.
+ rewrite GlobalContextMap.inductive_isprop_and_pars_spec.
+ rewrite (constructor_isprop_pars_decl_inductive e0).
+ eapply eval_iota_block. eauto. eauto.
+ now rewrite -is_propositional_cstr_optimize.
+ rewrite nth_error_map e1 //. now len. cbn.
+ rewrite -e3. rewrite !skipn_length map_length //.
eapply IHev2.
eapply closed_iota_red => //; tea.
eapply nth_error_forallb in clbrs; tea. cbn in clbrs.
@@ -657,14 +673,25 @@ Proof.
eapply eval_closed in ev1; tea.
move: ev1; rewrite closedn_mkApps /= => clargs.
rewrite GlobalContextMap.inductive_isprop_and_pars_spec.
- rewrite (constructor_isprop_pars_decl_inductive e).
+ rewrite (constructor_isprop_pars_decl_inductive e0).
rewrite optimize_mkApps in IHev1.
specialize (IHev1 cld).
eapply Ee.eval_proj; tea.
now rewrite -is_propositional_cstr_optimize.
- now len. rewrite nth_error_map e1 //.
+ now len. rewrite nth_error_map e2 //.
+ eapply IHev2.
+ eapply nth_error_forallb in e2; tea.
+
+ - move=> cld.
+ eapply eval_closed in ev1; tea.
+ rewrite GlobalContextMap.inductive_isprop_and_pars_spec.
+ rewrite (constructor_isprop_pars_decl_inductive e0).
+ specialize (IHev1 cld).
+ eapply Ee.eval_proj_block; tea.
+ now rewrite -is_propositional_cstr_optimize.
+ now len. rewrite nth_error_map e2 //.
eapply IHev2.
- eapply nth_error_forallb in e1; tea.
+ eapply nth_error_forallb in e2; tea.
- rewrite GlobalContextMap.inductive_isprop_and_pars_spec.
now rewrite e.
@@ -672,11 +699,13 @@ Proof.
- move/andP=> [] clf cla.
rewrite optimize_mkApps.
eapply eval_construct; tea.
- rewrite -lookup_constructor_optimize //. exact e.
+ rewrite -lookup_constructor_optimize //. exact e0.
rewrite optimize_mkApps in IHev1. now eapply IHev1.
now len.
now eapply IHev2.
+ - congruence.
+
- move/andP => [] clf cla.
specialize (IHev1 clf). specialize (IHev2 cla).
eapply Ee.eval_app_cong; eauto.
@@ -698,22 +727,10 @@ Proof.
destruct args using rev_case => // /=. rewrite map_app !mkApps_app /= //.
destruct v => /= //.
- destruct t => //.
- all:constructor; eauto.
+ all:constructor; eauto. cbn in *. destruct l; eauto.
+ Unshelve. all: repeat econstructor.
Qed.
-(*
-Lemma optimize_extends Σ Σ' :
- wf_glob Σ' ->
- extends Σ Σ' ->
- forall t b, optimize Σ t = b -> optimize Σ' t = b.
-Proof.
- intros wf ext.
- induction t using EInduction.term_forall_list_ind; cbn => //.
- all:try solve [f_equal; solve_all].
- destruct inductive_isp
- rewrite (extends_is_propositional wf ext).
- *)
-
From MetaCoq.Erasure Require Import EEtaExpanded.
Lemma isLambda_optimize Σ t : isLambda t -> isLambda (optimize Σ t).
@@ -841,6 +858,7 @@ Proof.
intros wfΣ hbox hrel.
induction t in n |- * using EInduction.term_forall_list_ind => //.
all:try solve [cbn; rtoProp; intuition auto; solve_all].
+ - cbn. intros. rtoProp; intuition eauto. now destruct args; inv H0.
- cbn -[GlobalContextMap.inductive_isprop_and_pars lookup_inductive]. move/and3P => [] hasc /andP[]hs ht hbrs.
destruct GlobalContextMap.inductive_isprop_and_pars as [[[|] _]|] => /= //.
destruct l as [|[br n'] [|l']] eqn:eql; simpl.
@@ -879,7 +897,8 @@ Proof.
destruct (cst_body c) => //.
- rewrite lookup_env_optimize //.
destruct lookup_env eqn:hl => // /=.
- destruct g eqn:hg => /= //.
+ destruct g eqn:hg => /= //.
+ all: try now (intros; rtoProp; congruence).
- rewrite lookup_env_optimize //.
destruct lookup_env eqn:hl => // /=.
destruct g eqn:hg => /= //. subst g.
diff --git a/erasure/theories/EPretty.v b/erasure/theories/EPretty.v
index 4322008aa..96f534226 100644
--- a/erasure/theories/EPretty.v
+++ b/erasure/theories/EPretty.v
@@ -111,11 +111,11 @@ Module PrintTermTree.
| tApp f l =>
parens (top || inapp) (print_term Γ false true f ^ " " ^ print_term Γ false false l)
| tConst c => string_of_kername c
- | tConstruct (mkInd i k as ind) l =>
+ | tConstruct (mkInd i k as ind) l args =>
match lookup_ind_decl Σ i k with
| Some oib =>
match nth_error oib.(ind_ctors) l with
- | Some cstr => cstr.(cstr_name)
+ | Some cstr => cstr.(cstr_name) ^ maybe_string_of_list string_of_term args
| None =>
"UnboundConstruct(" ^ string_of_inductive ind ^ "," ^ string_of_nat l ^ ")"
end
diff --git a/erasure/theories/EReflect.v b/erasure/theories/EReflect.v
index 99dc459ef..039df2bc7 100644
--- a/erasure/theories/EReflect.v
+++ b/erasure/theories/EReflect.v
@@ -59,6 +59,15 @@ Proof.
- destruct (IHx1 t1) ; nodec.
destruct (IHx2 t2) ; nodec.
subst. left. reflexivity.
+ - revert l. induction X ; intro l0.
+ + destruct l0.
+ * left. reflexivity.
+ * right. discriminate.
+ + destruct l0.
+ * right. discriminate.
+ * destruct (IHX l0) ; nodec.
+ destruct (p t) ; nodec.
+ inversion e. subst; left; reflexivity.
- destruct (IHx t) ; nodec.
subst. revert l0. clear IHx.
induction X ; intro l0.
diff --git a/erasure/theories/ERemoveParams.v b/erasure/theories/ERemoveParams.v
index 134be90a4..d17d52665 100644
--- a/erasure/theories/ERemoveParams.v
+++ b/erasure/theories/ERemoveParams.v
@@ -36,10 +36,10 @@ Section strip.
| tEvar ev args => EAst.tEvar ev (map_InP args (fun x H => strip x))
| tLambda na M => EAst.tLambda na (strip M)
| tApp u v napp nnil with construct_viewc u := {
- | view_construct kn c with GlobalContextMap.lookup_inductive_pars Σ (inductive_mind kn) := {
+ | view_construct kn c block_args with GlobalContextMap.lookup_inductive_pars Σ (inductive_mind kn) := {
| Some npars :=
- mkApps (EAst.tConstruct kn c) (List.skipn npars (map_InP v (fun x H => strip x)))
- | None => mkApps (EAst.tConstruct kn c) (map_InP v (fun x H => strip x)) }
+ mkApps (EAst.tConstruct kn c block_args) (List.skipn npars (map_InP v (fun x H => strip x)))
+ | None => mkApps (EAst.tConstruct kn c block_args) (map_InP v (fun x H => strip x)) }
| view_other u nconstr =>
mkApps (strip u) (map_InP v (fun x H => strip x))
}
@@ -57,15 +57,15 @@ Section strip.
| tBox => EAst.tBox
| tVar n => EAst.tVar n
| tConst n => EAst.tConst n
- | tConstruct ind i => EAst.tConstruct ind i }.
+ | tConstruct ind i block_args => EAst.tConstruct ind i block_args }.
Proof.
all:try lia.
all:try apply (In_size); tea.
- now eapply (In_size id size).
- rewrite size_mkApps.
- now eapply (In_size id size) in H.
+ eapply (In_size id size) in H. change (fun x => size (id x)) with size in H. unfold id in H. cbn. lia.
- rewrite size_mkApps.
- now eapply (In_size id size) in H.
+ eapply (In_size id size) in H. change (fun x => size (id x)) with size in H. unfold id in H. cbn. lia.
- now eapply size_mkApps_f.
- pose proof (size_mkApps_l napp nnil).
eapply (In_size id size) in H. change (fun x => size (id x)) with size in H. unfold id in H. lia.
@@ -108,9 +108,9 @@ Section strip.
- rewrite !closedn_mkApps in H1 *.
rtoProp; intuition auto.
solve_all.
- - rewrite !closedn_mkApps /= in H0 *.
- rewrite forallb_skipn; solve_all.
- - rewrite !closedn_mkApps /= in H0 *; solve_all.
+ - rewrite !closedn_mkApps /= in H0 *. rtoProp.
+ rewrite forallb_skipn; solve_all. solve_all.
+ - rewrite !closedn_mkApps /= in H0 *. rtoProp. repeat solve_all.
Qed.
Hint Rewrite @forallb_InP_spec : isEtaExp.
@@ -119,10 +119,10 @@ Section strip.
Local Lemma strip_mkApps_nonnil f v :
~~ isApp f -> v <> [] ->
strip (mkApps f v) = match construct_viewc f with
- | view_construct kn c =>
+ | view_construct kn c block_args =>
match lookup_inductive_pars Σ (inductive_mind kn) with
- | Some npars => mkApps (EAst.tConstruct kn c) (List.skipn npars (map strip v))
- | None => mkApps (EAst.tConstruct kn c) (map strip v)
+ | Some npars => mkApps (EAst.tConstruct kn c block_args) (List.skipn npars (map strip v))
+ | None => mkApps (EAst.tConstruct kn c block_args) (map strip v)
end
| view_other u nconstr => mkApps (strip f) (map strip v)
end.
@@ -139,10 +139,10 @@ Section strip.
Lemma strip_mkApps f v : ~~ isApp f ->
strip (mkApps f v) = match construct_viewc f with
- | view_construct kn c =>
+ | view_construct kn c block_args =>
match lookup_inductive_pars Σ (inductive_mind kn) with
- | Some npars => mkApps (EAst.tConstruct kn c) (List.skipn npars (map strip v))
- | None => mkApps (EAst.tConstruct kn c) (map strip v)
+ | Some npars => mkApps (EAst.tConstruct kn c block_args) (List.skipn npars (map strip v))
+ | None => mkApps (EAst.tConstruct kn c block_args) (map strip v)
end
| view_other u nconstr => mkApps (strip f) (map strip v)
end.
@@ -177,7 +177,8 @@ Section strip.
simpl closed in *; try solve [simpl subst; simpl closed; f_equal; auto; rtoProp; solve_all]; try easy.
- destruct Nat.compare => //.
- - f_equal. solve_all. move/andP: b => [] _ he. solve_all.
+ - f_equal. rtoProp. solve_all. destruct block_args; inv H2. eauto.
+ - f_equal. solve_all. move/andP: b => [] _ he. solve_all.
- specialize (H a k H1 H2).
rewrite !csubst_mkApps in H2 *.
rewrite isEtaExp_mkApps_napp // in H3.
@@ -208,7 +209,7 @@ Section strip.
rewrite (lookup_inductive_pars_constructor_pars_args eqpars).
rewrite -mkApps_app /= !skipn_map. f_equal.
rewrite skipn_app map_app. f_equal.
- assert (pars - #|l| = 0). eapply Nat.leb_le in ise; lia.
+ assert (pars - #|l| = 0). rtoProp. rename H4 into ise. eapply Nat.leb_le in ise; lia.
rewrite H4 skipn_0.
rewrite !map_map_compose.
clear -H1 H2 ev H0. solve_all. }
@@ -225,7 +226,7 @@ Section strip.
rewrite /isEtaExp_app in H4.
destruct lookup_constructor_pars_args as [[pars args]|] eqn:eqpars => // /=.
rewrite (lookup_inductive_pars_constructor_pars_args eqpars).
- assert (pars = 0). eapply Nat.leb_le in H4. lia.
+ assert (pars = 0). rtoProp. eapply Nat.leb_le in H4. lia.
subst pars. rewrite skipn_0.
simp strip; rewrite -strip_equation_1.
{ f_equal. rewrite !map_map_compose. clear -H1 H2 ev H0. solve_all. } }
@@ -240,11 +241,12 @@ Section strip.
unfold isEtaExp_app in etaapp.
rewrite GlobalContextMap.lookup_inductive_pars_spec in Heq.
rewrite Heq in etaapp *.
- f_equal. rewrite map_skipn. f_equal.
+ f_equal.
+ now destruct block_args; inv etav.
+ rewrite map_skipn. f_equal.
rewrite !map_map_compose.
- rewrite isEtaExp_Constructor // in H2.
- move/andP: H2 => [] etaapp' ev.
- clear -H0 H1 ev H. solve_all.
+ rewrite isEtaExp_Constructor // in H2. rtoProp.
+ solve_all.
- pose proof (etaExp_csubst _ _ k _ H1 H2).
rewrite !csubst_mkApps /= in H3 *.
assert (map (csubst a k) v <> []).
@@ -433,9 +435,9 @@ Arguments isEtaExp : simpl never.
Lemma isEtaExp_mkApps {Σ} {f u} : isEtaExp Σ (tApp f u) ->
let (hd, args) := decompose_app (tApp f u) in
match construct_viewc hd with
- | view_construct kn c =>
+ | view_construct kn c block_args =>
args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\
- isEtaExp_app Σ kn c #|args| && forallb (isEtaExp Σ) args
+ isEtaExp_app Σ kn c #|args| && forallb (isEtaExp Σ) args && is_nil block_args
| view_other _ discr =>
[&& isEtaExp Σ hd, forallb (isEtaExp Σ) args, isEtaExp Σ f & isEtaExp Σ u]
end.
@@ -496,7 +498,7 @@ Proof.
rewrite isEtaExp_mkApps_napp // in etaf.
simp construct_viewc in etaf.
move/andP: etaf => []. rewrite /isEtaExp_app hl.
- move/Nat.leb_le. lia. }
+ move => /andP[] /Nat.leb_le. lia. }
{ move/and4P=> [] iset isel _ _. rewrite (decompose_app_inv da).
pose proof (decompose_app_notApp _ _ _ da).
rewrite strip_mkApps //.
@@ -531,9 +533,9 @@ Module Fast.
| app, tCoFix mfix idx =>
let mfix' := strip_defs mfix in
mkApps (EAst.tCoFix mfix' idx) app
- | app, tConstruct kn c with GlobalContextMap.lookup_inductive_pars Σ (inductive_mind kn) := {
- | Some npars => mkApps (EAst.tConstruct kn c) (List.skipn npars app)
- | None => mkApps (EAst.tConstruct kn c) app }
+ | app, tConstruct kn c block_args with GlobalContextMap.lookup_inductive_pars Σ (inductive_mind kn) := {
+ | Some npars => mkApps (EAst.tConstruct kn c block_args) (List.skipn npars app)
+ | None => mkApps (EAst.tConstruct kn c block_args) app }
| app, x => mkApps x app }
where strip_args (t : list term) : list term :=
@@ -646,22 +648,22 @@ Proof.
rewrite mkApps_app /= //.
Qed.
-Lemma isLambda_mkApps_Construct ind n l :
- ~~ EAst.isLambda (EAst.mkApps (EAst.tConstruct ind n) l).
+Lemma isLambda_mkApps_Construct ind n block_args l :
+ ~~ EAst.isLambda (EAst.mkApps (EAst.tConstruct ind n block_args) l).
Proof.
induction l using rev_ind; cbn; try congruence.
rewrite mkApps_app /= //.
Qed.
-Lemma isBox_mkApps_Construct ind n l :
- ~~ isBox (EAst.mkApps (EAst.tConstruct ind n) l).
+Lemma isBox_mkApps_Construct ind n block_args l :
+ ~~ isBox (EAst.mkApps (EAst.tConstruct ind n block_args) l).
Proof.
induction l using rev_ind; cbn; try congruence.
rewrite mkApps_app /= //.
Qed.
-Lemma isFix_mkApps_Construct ind n l :
- ~~ isFix (EAst.mkApps (EAst.tConstruct ind n) l).
+Lemma isFix_mkApps_Construct ind n block_args l :
+ ~~ isFix (EAst.mkApps (EAst.tConstruct ind n block_args) l).
Proof.
induction l using rev_ind; cbn; try congruence.
rewrite mkApps_app /= //.
@@ -673,7 +675,7 @@ Proof.
funelim (strip Σ f); cbn -[strip]; (try simp_strip) => //.
rewrite (negbTE (isLambda_mkApps' _ _ _)) //.
rewrite (negbTE (isLambda_mkApps' _ _ _)) //; try apply map_nil => //.
- all:rewrite !(negbTE (isLambda_mkApps_Construct _ _ _)) //.
+ all:rewrite !(negbTE (isLambda_mkApps_Construct _ _ _ _)) //.
Qed.
Lemma strip_isBox Σ f :
@@ -683,7 +685,7 @@ Proof.
all:rewrite map_InP_spec.
rewrite (negbTE (isBox_mkApps' _ _ _)) //.
rewrite (negbTE (isBox_mkApps' _ _ _)) //; try apply map_nil => //.
- all:rewrite !(negbTE (isBox_mkApps_Construct _ _ _)) //.
+ all:rewrite !(negbTE (isBox_mkApps_Construct _ _ _ _)) //.
Qed.
Lemma isApp_mkApps u v : v <> nil -> isApp (mkApps u v).
@@ -708,7 +710,7 @@ Proof.
all:rewrite map_InP_spec.
rewrite (negbTE (isFix_mkApps' _ _ _)) //.
rewrite (negbTE (isFix_mkApps' _ _ _)) //; try apply map_nil => //.
- all:rewrite !(negbTE (isFix_mkApps_Construct _ _ _)) //.
+ all:rewrite !(negbTE (isFix_mkApps_Construct _ _ _ _)) //.
Qed.
Lemma strip_isFixApp Σ f :
@@ -776,15 +778,16 @@ Proof.
destruct construct_viewc eqn:vc.
+ move=> /andP[] hl0 etal0.
rewrite -mkApps_app.
- rewrite (strip_mkApps Σ (tConstruct ind n)) // /=.
+ rewrite (strip_mkApps Σ (tConstruct ind n block_args)) // /=.
rewrite strip_mkApps // /=.
unfold isEtaExp_app in hl0.
destruct lookup_constructor_pars_args as [[pars args']|] eqn:hl => //.
- eapply Nat.leb_le in hl0.
+ rtoProp.
+ eapply Nat.leb_le in H.
rewrite (lookup_inductive_pars_constructor_pars_args hl).
rewrite -mkApps_app. f_equal. rewrite map_app.
rewrite skipn_app. len. assert (pars - #|l| = 0) by lia.
- now rewrite H skipn_0.
+ now rewrite H1 skipn_0.
+ move=> /andP[] etat0 etal0.
rewrite -mkApps_app !strip_mkApps; try now eapply decompose_app_notApp.
rewrite vc. rewrite -mkApps_app !map_app //.
@@ -820,7 +823,7 @@ Proof.
split; intros; rtoProp; intuition auto; solve_all.
Qed.
-Lemma strip_eval (efl := all_env_flags) {wfl:WcbvFlags} {Σ : GlobalContextMap.t} t v :
+Lemma strip_eval (efl := all_env_flags) {wfl:WcbvFlags} {wcon : with_constructor_as_block = false} {Σ : GlobalContextMap.t} t v :
closed_env Σ ->
isEtaExp_env Σ ->
wf_glob Σ ->
@@ -831,7 +834,7 @@ Lemma strip_eval (efl := all_env_flags) {wfl:WcbvFlags} {Σ : GlobalContextMap.t
Proof.
intros clΣ etaΣ wfΣ ev clt etat.
revert t v clt etat ev.
- apply (eval_preserve_mkApps_ind wfl Σ (fun x y => eval (strip_env Σ) (strip Σ x) (strip Σ y))
+ unshelve eapply (eval_preserve_mkApps_ind wfl wcon Σ (fun x y => eval (strip_env Σ) (strip Σ x) (strip Σ y))
(fun n x => closedn n x) (Qpres := Qpreserves_closedn Σ clΣ)) => //.
{ intros. eapply eval_closed; tea. }
all:intros; simpl in *.
@@ -863,7 +866,7 @@ Proof.
* cbn -[strip].
have etaargs : forallb (isEtaExp Σ) args.
{ rewrite isEtaExp_Constructor in i6.
- now move/andP: i6 => []. }
+ now move/andP: i6 => [] /andP[]. }
rewrite strip_iota_red // in e.
rewrite closedn_mkApps in i4. now move/andP: i4.
cbn. now eapply nth_error_forallb in H; tea.
@@ -1172,7 +1175,7 @@ Proof.
rewrite strip_mkApps // /=.
move: Heq.
rewrite GlobalContextMap.lookup_inductive_pars_spec.
- unfold wellformed in wfc. move/andP: wfc => [] hacc hc.
+ unfold wellformed in wfc. move/andP: wfc => [] /andP[] hacc hc bargs.
unfold lookup_inductive_pars. destruct lookup_minductive eqn:heq => //.
unfold lookup_constructor, lookup_inductive in hc. rewrite heq /= // in hc.
Qed.
diff --git a/erasure/theories/ESpineView.v b/erasure/theories/ESpineView.v
index 7bee803c6..8bbb0ca70 100644
--- a/erasure/theories/ESpineView.v
+++ b/erasure/theories/ESpineView.v
@@ -17,7 +17,7 @@ Inductive t : term -> Set :=
| tLetIn n b b' : t (EAst.tLetIn n b b')
| tApp (f : term) (l : list term) (napp : ~~ isApp f) (nnil : l <> nil) : t (mkApps f l)
| tConst kn : t (tConst kn)
-| tConstruct i n : t (tConstruct i n)
+| tConstruct i n args : t (tConstruct i n args)
| tCase ci p brs : t (tCase ci p brs)
| tProj p c : t (tProj p c)
| tFix mfix idx : t (tFix mfix idx)
diff --git a/erasure/theories/ETransform.v b/erasure/theories/ETransform.v
index 9b34d1a0b..82f2318b3 100644
--- a/erasure/theories/ETransform.v
+++ b/erasure/theories/ETransform.v
@@ -111,7 +111,7 @@ Qed.
Import EWcbvEval (WcbvFlags, with_prop_case, with_guarded_fix).
-Program Definition guarded_to_unguarded_fix {fl : EWcbvEval.WcbvFlags} {efl : EEnvFlags} (wguard : with_guarded_fix) :
+Program Definition guarded_to_unguarded_fix {fl : EWcbvEval.WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} {efl : EEnvFlags} (wguard : with_guarded_fix) :
Transform.t eprogram_env eprogram_env EAst.term EAst.term
(eval_eprogram_env fl) (eval_eprogram_env (EWcbvEval.switch_unguarded_fix fl)) :=
{| name := "switching to unguarded fixpoints";
@@ -122,10 +122,10 @@ Program Definition guarded_to_unguarded_fix {fl : EWcbvEval.WcbvFlags} {efl : EE
Next Obligation. cbn. eauto. Qed.
Next Obligation.
cbn.
- move=> fl efl wguard [Σ t] v [wfp [etae etat]]. cbn in *.
+ move=> fl wcon efl wguard [Σ t] v [wfp [etae etat]]. cbn in *.
intros [ev]. exists v. split => //.
red. sq. cbn in *.
- apply EEtaExpandedFix.eval_opt_to_target => //. 2:apply wfp.
+ unshelve eapply EEtaExpandedFix.eval_opt_to_target => //. auto. 2:apply wfp.
now eapply EEtaExpandedFix.expanded_global_env_isEtaExp_env.
now eapply EEtaExpandedFix.expanded_isEtaExp.
Qed.
@@ -147,7 +147,7 @@ Next Obligation.
cbn. intros fl efl input v [] ev p'; exists v. split => //.
Qed.
-Program Definition remove_params_optimization {fl : EWcbvEval.WcbvFlags}
+Program Definition remove_params_optimization {fl : EWcbvEval.WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false}
(efl := all_env_flags):
Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) :=
{| name := "stripping constructor parameters";
@@ -156,7 +156,7 @@ Program Definition remove_params_optimization {fl : EWcbvEval.WcbvFlags}
post p := wf_eprogram (switch_no_params efl) p /\ EEtaExpanded.expanded_eprogram_cstrs p;
obseq g g' v v' := v' = (ERemoveParams.strip g.1 v) |}.
Next Obligation.
- move=> fl efl [Σ t] [wfp etap].
+ move=> fl wcon efl [Σ t] [wfp etap].
simpl.
cbn -[ERemoveParams.strip] in *.
split. now eapply ERemoveParams.strip_program_wf.
@@ -164,16 +164,17 @@ Next Obligation.
Qed.
Next Obligation.
- red. move=> ? [Σ t] /= v [[wfe wft] etap] [ev].
+ red. move=> ? wcon [Σ t] /= v [[wfe wft] etap] [ev].
eapply ERemoveParams.strip_eval in ev; eauto.
eexists; split => /= //. now sq. cbn in *.
now eapply wellformed_closed_env.
now move/andP: etap.
now eapply wellformed_closed.
now move/andP: etap.
+ Unshelve. auto.
Qed.
-Program Definition remove_params_fast_optimization (fl : EWcbvEval.WcbvFlags)
+Program Definition remove_params_fast_optimization (fl : EWcbvEval.WcbvFlags) {wcon : EWcbvEval.with_constructor_as_block = false}
(efl := all_env_flags) :
Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) :=
{| name := "stripping constructor parameters (faster?)";
@@ -182,7 +183,7 @@ Program Definition remove_params_fast_optimization (fl : EWcbvEval.WcbvFlags)
post p := wf_eprogram (switch_no_params efl) p /\ EEtaExpanded.expanded_eprogram_cstrs p;
obseq g g' v v' := v' = (ERemoveParams.strip g.1 v) |}.
Next Obligation.
- move=> fl efl [Σ t] [wfp etap].
+ move=> fl wcon efl [Σ t] [wfp etap].
simpl.
cbn -[ERemoveParams.strip] in *.
rewrite -ERemoveParams.Fast.strip_fast -ERemoveParams.Fast.strip_env_fast.
@@ -192,7 +193,7 @@ Next Obligation.
Qed.
Next Obligation.
- red. move=> ? [Σ t] /= v [[wfe wft] etap] [ev].
+ red. move=> ? wcon [Σ t] /= v [[wfe wft] etap] [ev].
rewrite -ERemoveParams.Fast.strip_fast -ERemoveParams.Fast.strip_env_fast.
eapply ERemoveParams.strip_eval in ev; eauto.
eexists; split => /= //.
@@ -201,11 +202,12 @@ Next Obligation.
now move/andP: etap.
now eapply wellformed_closed.
now move/andP: etap.
+ Unshelve. auto.
Qed.
Import EOptimizePropDiscr EWcbvEval.
-Program Definition optimize_prop_discr_optimization {fl : WcbvFlags} {efl : EEnvFlags} {hastrel : has_tRel} {hastbox : has_tBox} :
+Program Definition optimize_prop_discr_optimization {fl : WcbvFlags} {wcon : with_constructor_as_block = false} {efl : EEnvFlags} {hastrel : has_tRel} {hastbox : has_tBox} :
Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram (disable_prop_cases fl)) :=
{| name := "optimize_prop_discr";
transform p _ := optimize_program p ;
@@ -214,22 +216,23 @@ Program Definition optimize_prop_discr_optimization {fl : WcbvFlags} {efl : EEnv
obseq g g' v v' := v' = EOptimizePropDiscr.optimize g.1 v |}.
Next Obligation.
- move=> fl efl hastrel hastbox [Σ t] [wfp etap].
+ move=> fl wcon efl hastrel hastbox [Σ t] [wfp etap].
cbn in *. split.
- now eapply optimize_program_wf.
- now eapply optimize_program_expanded.
Qed.
Next Obligation.
- red. move=> fl efl hastrel hastbox [Σ t] /= v [wfe wft] [ev].
+ red. move=> fl wcon efl hastrel hastbox [Σ t] /= v [wfe wft] [ev].
eapply EOptimizePropDiscr.optimize_correct in ev; eauto.
eexists; split => //. red. sq; auto. cbn. apply wfe.
eapply wellformed_closed_env, wfe.
eapply wellformed_closed, wfe.
+ Unshelve. eauto.
Qed.
From MetaCoq.Erasure Require Import EInlineProjections.
-Program Definition inline_projections_optimization {fl : WcbvFlags} (efl := all_env_flags)
+Program Definition inline_projections_optimization {fl : WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} (efl := all_env_flags)
{hastrel : has_tRel} {hastbox : has_tBox} :
Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) :=
{| name := "primitive projection inlining";
@@ -239,14 +242,36 @@ Program Definition inline_projections_optimization {fl : WcbvFlags} (efl := all_
obseq g g' v v' := v' = EInlineProjections.optimize g.1 v |}.
Next Obligation.
- move=> fl efl hastrel hastbox [Σ t] [wfp etap].
+ move=> fl wcon efl hastrel hastbox [Σ t] [wfp etap].
cbn in *. split.
- now eapply optimize_program_wf.
- now eapply optimize_program_expanded.
Qed.
Next Obligation.
- red. move=> fl hastrel hastbox [Σ t] /= v [wfe wft] [ev].
+ red. move=> fl wcon hastrel hastbox [Σ t] /= v [wfe wft] [ev].
eapply EInlineProjections.optimize_correct in ev; eauto.
eexists; split => //. red. sq; auto. cbn. apply wfe.
- cbn. eapply wfe.
+ cbn. eapply wfe. Unshelve. auto.
+Qed.
+
+From MetaCoq.Erasure Require Import EConstructorsAsBlocks.
+
+Program Definition constructors_as_blocks_transformation (efl := all_env_flags)
+ {hastrel : has_tRel} {hastbox : has_tBox} :
+ Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env target_wcbv_flags) (eval_eprogram block_wcbv_flags) :=
+ {| name := "transforming to constuctors as blocks";
+ transform p _ := EConstructorsAsBlocks.transform_blocks_program p ;
+ pre p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p;
+ post p := wf_eprogram (disable_projections_env_flag efl) p /\ EEtaExpanded.expanded_eprogram_cstrs p;
+ obseq g g' v v' := True |}.
+
+Next Obligation.
+ move=> efl hastrel hastbox [Σ t] [wfp etap].
+ cbn in *. split.
+ - todo "".
+ - todo "".
+Qed.
+Next Obligation.
+ red. move=> hastrel hastbox [Σ t] /= v [wfe wft] [ev].
+ todo "".
Qed.
\ No newline at end of file
diff --git a/erasure/theories/EWcbvEval.v b/erasure/theories/EWcbvEval.v
index c498a85ef..fa2208429 100644
--- a/erasure/theories/EWcbvEval.v
+++ b/erasure/theories/EWcbvEval.v
@@ -30,7 +30,7 @@ Local Ltac inv H := inversion H; subst.
Definition atom t :=
match t with
| tBox
- | tConstruct _ _
+ | tConstruct _ _ []
| tCoFix _ _
| tLambda _ _
| tFix _ _ => true
@@ -54,17 +54,17 @@ Proof.
Qed.
(* Tells if the evaluation relation should include match-prop and proj-prop reduction rules. *)
-Class WcbvFlags := { with_prop_case : bool ; with_guarded_fix : bool }.
+Class WcbvFlags := { with_prop_case : bool ; with_guarded_fix : bool ; with_constructor_as_block : bool }.
Definition disable_prop_cases fl : WcbvFlags :=
- {| with_prop_case := false; with_guarded_fix := fl.(@with_guarded_fix) |}.
+ {| with_prop_case := false; with_guarded_fix := fl.(@with_guarded_fix) ; with_constructor_as_block := fl.(@with_constructor_as_block) |}.
Definition switch_unguarded_fix fl : WcbvFlags :=
- EWcbvEval.Build_WcbvFlags fl.(@with_prop_case) false.
+ EWcbvEval.Build_WcbvFlags fl.(@with_prop_case) false fl.(@with_constructor_as_block).
-Definition default_wcbv_flags := {| with_prop_case := true ; with_guarded_fix := true |}.
-Definition opt_wcbv_flags := {| with_prop_case := false ; with_guarded_fix := true |}.
-Definition target_wcbv_flags := {| with_prop_case := false ; with_guarded_fix := false |}.
+Definition default_wcbv_flags := {| with_prop_case := true ; with_guarded_fix := true ; with_constructor_as_block := false |}.
+Definition opt_wcbv_flags := {| with_prop_case := false ; with_guarded_fix := true ; with_constructor_as_block := false|}.
+Definition target_wcbv_flags := {| with_prop_case := false ; with_guarded_fix := false ; with_constructor_as_block := false |}.
Section Wcbv.
Context {wfl : WcbvFlags}.
@@ -93,7 +93,19 @@ Section Wcbv.
(** Case *)
| eval_iota ind pars cdecl discr c args brs br res :
- eval discr (mkApps (tConstruct ind c) args) ->
+ with_constructor_as_block = false ->
+ eval discr (mkApps (tConstruct ind c []) args) ->
+ constructor_isprop_pars_decl Σ ind c = Some (false, pars, cdecl) ->
+ nth_error brs c = Some br ->
+ #|args| = pars + cdecl.(cstr_nargs) ->
+ #|skipn pars args| = #|br.1| ->
+ eval (iota_red pars args br) res ->
+ eval (tCase (ind, pars) discr brs) res
+
+ (** Case *)
+ | eval_iota_block ind pars cdecl discr c args brs br res :
+ with_constructor_as_block = true ->
+ eval discr (tConstruct ind c args) ->
constructor_isprop_pars_decl Σ ind c = Some (false, pars, cdecl) ->
nth_error brs c = Some br ->
#|args| = pars + cdecl.(cstr_nargs) ->
@@ -159,7 +171,18 @@ Section Wcbv.
(** Proj *)
| eval_proj p cdecl discr args a res :
- eval discr (mkApps (tConstruct p.(proj_ind) 0) args) ->
+ with_constructor_as_block = false ->
+ eval discr (mkApps (tConstruct p.(proj_ind) 0 []) args) ->
+ constructor_isprop_pars_decl Σ p.(proj_ind) 0 = Some (false, p.(proj_npars), cdecl) ->
+ #|args| = p.(proj_npars) + cdecl.(cstr_nargs) ->
+ nth_error args (p.(proj_npars) + p.(proj_arg)) = Some a ->
+ eval a res ->
+ eval (tProj p discr) res
+
+ (** Proj *)
+ | eval_proj_block p cdecl discr args a res :
+ with_constructor_as_block = true ->
+ eval discr (tConstruct p.(proj_ind) 0 args) ->
constructor_isprop_pars_decl Σ p.(proj_ind) 0 = Some (false, p.(proj_npars), cdecl) ->
#|args| = p.(proj_npars) + cdecl.(cstr_nargs) ->
nth_error args (p.(proj_npars) + p.(proj_arg)) = Some a ->
@@ -175,12 +198,21 @@ Section Wcbv.
(** Constructor congruence: we do not allow over-applications *)
| eval_construct ind c mdecl idecl cdecl f args a a' :
+ with_constructor_as_block = false ->
lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) ->
- eval f (mkApps (tConstruct ind c) args) ->
+ eval f (mkApps (tConstruct ind c []) args) ->
#|args| < cstr_arity mdecl cdecl ->
eval a a' ->
- eval (tApp f a) (tApp (mkApps (tConstruct ind c) args) a')
+ eval (tApp f a) (tApp (mkApps (tConstruct ind c []) args) a')
+ (** Constructor congruence: we do not allow over-applications *)
+ | eval_construct_block ind c mdecl idecl cdecl args args' a a' :
+ with_constructor_as_block = true ->
+ lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) ->
+ #|args| < cstr_arity mdecl cdecl ->
+ eval (tConstruct ind c args) (tConstruct ind c args') ->
+ eval a a' ->
+ eval (tConstruct ind c (args ++ [a])) (tConstruct ind c (args' ++ [a']))
(** Atoms (non redex-producing heads) applied to values are values *)
| eval_app_cong f f' a a' :
@@ -214,9 +246,10 @@ Section Wcbv.
Variant value_head (nargs : nat) : term -> Type :=
| value_head_cstr ind c mdecl idecl cdecl :
+ with_constructor_as_block = false ->
lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) ->
nargs <= cstr_arity mdecl cdecl ->
- value_head nargs (tConstruct ind c)
+ value_head nargs (tConstruct ind c [])
| value_head_cofix mfix idx : value_head nargs (tCoFix mfix idx)
| value_head_fix mfix idx rarg fn :
cunfold_fix mfix idx = Some (rarg, fn) ->
@@ -228,6 +261,11 @@ Section Wcbv.
Inductive value : term -> Type :=
| value_atom t : atom t -> value t
+ | value_constructor ind c mdecl idecl cdecl args :
+ with_constructor_as_block = true ->
+ lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) ->
+ #|args| <= cstr_arity mdecl cdecl ->
+ All value args -> value (tConstruct ind c args)
| value_app_nonnil f args : value_head #|args| f -> args <> [] -> All value args -> value (mkApps f args).
Derive Signature for value.
@@ -251,13 +289,18 @@ Section Wcbv.
Lemma value_values_ind : forall P : term -> Type,
(forall t, atom t -> P t) ->
+ (forall (ind : inductive) (c : nat) (mdecl : mutual_inductive_body) (idecl : one_inductive_body) (cdecl : constructor_body)
+ (args : list term) (e : with_constructor_as_block = true) (e0 : lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl))
+ (l : #|args| <= cstr_arity mdecl cdecl) (a : All value args) , All P args ->
+ P (tConstruct ind c args)) ->
(forall f args, value_head #|args| f -> args <> [] -> All value args -> All P args -> P (mkApps f args)) ->
forall t : term, value t -> P t.
Proof.
- intros P ??.
+ intros P X X0 X1.
fix value_values_ind 2. destruct 1.
- apply X; auto.
- - eapply X0; auto; tea.
+ - eapply X0; auto; tea. clear -a value_values_ind. induction a; econstructor; auto.
+ - eapply X1; auto; tea.
clear v n. revert args a. fix aux 2. destruct 1. constructor; auto.
constructor. now eapply value_values_ind. now apply aux.
Defined.
@@ -277,12 +320,19 @@ Section Wcbv.
Lemma value_mkApps_inv t l :
~~ isApp t ->
value (mkApps t l) ->
- ((l = []) /\ atom t) + ([× l <> [], value_head #|l| t & All value l]).
+ ((l = []) /\ atom t)
+ + (l = [] × ∑ ind c mdecl idecl cdecl args, [ × with_constructor_as_block , lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl), t = tConstruct ind c args, #|args| <= cstr_arity mdecl cdecl & All value args])
+ + ([× l <> [], value_head #|l| t & All value l]).
Proof.
intros H H'. generalize_eq x (mkApps t l).
revert x H' t H. apply: value_values_ind.
- intros. subst.
now eapply atom_mkApps in H.
+ - intros * wcon lup len H IH t ht hcon.
+ destruct l using rev_ind.
+ + cbn in hcon. invs hcon. left. right.
+ repeat eexists; eauto.
+ + rewrite mkApps_app in hcon. invs hcon.
- intros * vh nargs hargs ih t isapp appeq.
move: (value_head_nApp vh) => Ht.
right. apply mkApps_eq_inj in appeq => //. intuition subst; auto => //.
@@ -294,8 +344,18 @@ Section Wcbv.
All value l.
Proof.
intros val not_app.
- now apply value_mkApps_inv in val as [(-> & ?)|[]].
+ now apply value_mkApps_inv in val as [[(-> & ?) | [-> ] ] |[]].
Qed.
+
+ Lemma eval_Construct_inv ind c args e :
+ eval (tConstruct ind c args) e ->
+ ∑ args', e = tConstruct ind c args' × All2 eval args args'.
+ Proof.
+ intros H. depind H.
+ - edestruct IHeval1 as (args'' & [= ->] & H2); eauto.
+ repeat eexists; eauto. eapply All2_app; eauto.
+ - invs i. destruct args; invs H0. exists []. repeat econstructor.
+ Qed.
Lemma eval_to_value e e' : eval e e' -> value e'.
Proof.
@@ -304,7 +364,10 @@ Section Wcbv.
- change (tApp ?h ?a) with (mkApps h [a]).
rewrite -mkApps_app.
apply value_mkApps_inv in IHev1; [|easy].
- destruct IHev1 as [(-> & _)|[]].
+ destruct IHev1 as [[(-> & _) | [-> ] ] |[]].
+ + apply value_app; auto. len.
+ cbn in *. econstructor; tea.
+ destruct with_guarded_fix => //. cbn; auto.
+ apply value_app; auto. len.
cbn in *. econstructor; tea.
destruct with_guarded_fix => //. cbn; auto.
@@ -314,12 +377,20 @@ Section Wcbv.
len; lia. apply All_app_inv; auto.
- apply value_mkApps_inv in IHev1; [|easy].
- destruct IHev1 as [(-> & _)|[]].
+ destruct IHev1 as [[(-> & _)|[-> ]] | []].
+ + cbn. eapply (value_app _ [a']); cbn; auto. econstructor; tea.
+ cbn. eapply (value_app _ [a']); cbn; auto. econstructor; tea.
+ rewrite -[tApp _ _](mkApps_app _ _ [a']).
eapply value_app. cbn; auto. econstructor; tea. cbn; len.
eapply All_app_inv; auto.
-
+
+ - invs IHev1.
+ + invs H. destruct args'; invs H1. econstructor 2; eauto. len; lia. now econstructor.
+ + rewrite e0 in H3; invs H3.
+ eapply eval_Construct_inv in ev1 as (? & [= <-] & Hall).
+ econstructor 2; eauto. len. eapply All2_length in Hall. lia.
+ eapply All_app_inv; eauto.
+ + destruct H1. destruct args0 using rev_ind. eauto. rewrite mkApps_app in H. invs H.
- destruct (mkApps_elim f' [a']).
eapply value_mkApps_inv in IHev1 => //.
destruct IHev1 as [?|[]]; intuition subst.
@@ -332,6 +403,13 @@ Section Wcbv.
now cbn in i. now cbn in i.
+ constructor.
+ econstructor; auto.
+ * destruct b0 as (ind & c & mdecl & idecl & cdecl & args & [H1 H2 H3 H4]).
+ rewrite -[tApp _ _](mkApps_app _ (firstn n l) [a']).
+ rewrite a0 in i |- *. simpl in *.
+ apply (value_app f0 [a']).
+ destruct f0; simpl in * |- *; try congruence.
+ + rewrite !negb_or /= in i; rtoProp; intuition auto.
+ + destruct with_guarded_fix. now cbn in i. now cbn in i.
* rewrite -[tApp _ _](mkApps_app _ (firstn n l) [a']).
eapply value_app; eauto with pcuic. 2:eapply All_app_inv; auto.
len.
@@ -484,6 +562,7 @@ Section Wcbv.
- destruct L using rev_ind.
reflexivity.
rewrite mkApps_app in i. inv i.
+ - EAstUtils.solve_discr.
- EAstUtils.solve_discr. depelim v.
Qed.
@@ -528,6 +607,8 @@ Section Wcbv.
unfold atom in isatom. destruct argsv using rev_case => //.
split; auto. simpl. simpl in isatom. rewrite H //.
rewrite mkApps_app /= // in isatom.
+ - intros. destruct argsv using rev_case => //.
+ rewrite mkApps_app in Heqtfix => //.
- intros * vf hargs vargs ihargs eq. solve_discr => //. depelim vf. rewrite e.
intros [= <- <-]. destruct with_guarded_fix => //. split => //.
unfold isStuckFix. rewrite e. now apply Nat.leb_le.
@@ -546,13 +627,14 @@ Section Wcbv.
Qed.
Lemma eval_mkApps_Construct ind c mdecl idecl cdecl f args args' :
+ with_constructor_as_block = false ->
lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) ->
- eval f (tConstruct ind c) ->
+ eval f (tConstruct ind c []) ->
#|args| <= cstr_arity mdecl cdecl ->
All2 eval args args' ->
- eval (mkApps f args) (mkApps (tConstruct ind c) args').
+ eval (mkApps f args) (mkApps (tConstruct ind c []) args').
Proof.
- intros hdecl evf hargs. revert args'.
+ intros hblock hdecl evf hargs. revert args'.
induction args using rev_ind; intros args' evargs.
- depelim evargs. now cbn.
- eapply All2_app_inv_l in evargs as [r1 [r2 [-> [evl evr]]]].
@@ -564,6 +646,23 @@ Section Wcbv.
rewrite -(All2_length evl). lia.
Qed.
+ Lemma eval_mkApps_Construct_block ind c mdecl idecl cdecl f args args' :
+ with_constructor_as_block ->
+ lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) ->
+ eval f (tConstruct ind c []) ->
+ #|args| <= cstr_arity mdecl cdecl ->
+ All2 eval args args' ->
+ eval (tConstruct ind c args) (tConstruct ind c args').
+ Proof.
+ intros hblock hdecl evf hargs. revert args'.
+ induction args using rev_ind; intros args' evargs.
+ - depelim evargs. econstructor. now cbn.
+ - eapply All2_app_inv_l in evargs as [r1 [r2 [-> [evl evr]]]].
+ depelim evr. depelim evr.
+ eapply eval_construct_block; tea. 1: revert hargs; len.
+ eapply IHargs => //. 1: revert hargs; len.
+ Qed.
+
Lemma eval_mkApps_CoFix f mfix idx args args' :
eval f (tCoFix mfix idx) ->
All2 eval args args' ->
@@ -620,6 +719,13 @@ Section Wcbv.
Proof.
move: e; eapply value_values_ind; simpl; intros; eauto with value.
- now constructor.
+ - assert (All2 eval args args).
+ { clear -X; induction X; constructor; auto. }
+ induction args using rev_ind. repeat econstructor.
+ eapply All_app in a as [? HH]; eauto; invs HH.
+ eapply All_app in X as [? HH]; eauto; invs HH.
+ eapply All2_app_inv in X0 as [? HH]; eauto; invs HH.
+ econstructor; eauto. revert l. len. eapply IHargs; eauto. revert l. len.
- assert (All2 eval args args).
{ clear -X0; induction X0; constructor; auto. }
eapply eval_mkApps_cong => //. now eapply value_head_final.
@@ -656,9 +762,18 @@ Section Wcbv.
apply mkApps_eq_inj in apps_eq as (eq1 & eq2); try easy.
noconf eq1. noconf eq2.
noconf IHev1.
- pose proof e0. rewrite e4 in H. noconf H.
- pose proof e as e'. rewrite e3 in e'. noconf e'.
- rewrite -> (uip e e3), (uip e0 e4), (uip e1 e5), (uip e2 e6).
+ pose proof e0. rewrite e5 in H. noconf H.
+ pose proof e as e'. rewrite e4 in e'. noconf e'.
+ assert (br0 = br) as -> by congruence.
+ rewrite -> (uip e e4), (uip e0 e5), (uip e1 e6), (uip e2 e7), (uip e3 e8).
+ specialize (IHev2 _ ev'2); noconf IHev2.
+ reflexivity.
+ - depelim ev'; try go.
+ + specialize (IHev1 _ ev'1); noconf IHev1.
+ pose proof e0. rewrite e5 in H. noconf H.
+ pose proof e as e'. rewrite e4 in e'. noconf e'.
+ assert (br0 = br) as -> by congruence.
+ rewrite -> (uip e e4), (uip e0 e5), (uip e1 e6), (uip e2 e7), (uip e3 e8).
specialize (IHev2 _ ev'2); noconf IHev2.
reflexivity.
- depelim ev'; try go.
@@ -760,27 +875,48 @@ Section Wcbv.
specialize (IHev1 _ ev'1).
pose proof (mkApps_eq_inj (f_equal pr1 IHev1) eq_refl eq_refl) as (? & <-).
noconf H. noconf IHev1.
- pose proof e as e'. rewrite e2 in e'; noconf e'.
- rewrite -> (uip e e2), (uip e0 e3).
- pose proof e4 as e4'. rewrite e1 in e4'; noconf e4'.
- rewrite (uip e1 e4).
+ assert (a0 = a) as -> by congruence.
+ pose proof e0 as e'. rewrite e4 in e'; noconf e'.
+ rewrite -> (uip e e3), (uip e0 e4).
+ pose proof e5 as e4'. rewrite e1 in e4'; noconf e4'.
+ rewrite -> (uip e1 e5), (uip e2 e6).
+ now specialize (IHev2 _ ev'2); noconf IHev2.
+ - depelim ev'; try go.
+ specialize (IHev1 _ ev'1); noconf IHev1.
+ assert (a0 = a) as -> by congruence.
+ pose proof e0 as e'. rewrite e4 in e'; noconf e'.
+ rewrite -> (uip e e3), (uip e0 e4).
+ pose proof e5 as e4'. rewrite e1 in e4'; noconf e4'.
+ rewrite -> (uip e1 e5), (uip e2 e6).
now specialize (IHev2 _ ev'2); noconf IHev2.
- depelim ev'; try go.
specialize (IHev _ ev'). noconf IHev.
rewrite (uip e e0).
now rewrite (uip i i0).
- - depelim ev'; try go.
+ - depelim ev'; try now go.
+ move: (IHev1 _ ev'1).
eapply DepElim.simplification_sigma1 => heq IHev1'.
apply mkApps_eq_inj in heq as H'; auto.
destruct H' as (H' & <-). noconf H'.
noconf IHev1'.
- pose proof e as e'. rewrite e0 in e'; noconf e'.
+ pose proof e0 as e'. rewrite e2 in e'; noconf e'.
specialize (IHev2 _ ev'2). noconf IHev2.
- now rewrite -> (uip e e0), (PCUICWcbvEval.le_irrel _ _ l l0).
+ now rewrite -> (uip e e1), (uip e0 e2), (PCUICWcbvEval.le_irrel _ _ l l0).
+ specialize (IHev1 _ ev'1). noconf IHev1.
exfalso. rewrite isConstructApp_mkApps in i.
cbn in i. rewrite !negb_or in i. rtoProp; intuition auto.
+ - depelim ev'; try go.
+ + eapply app_inj_tail in e3 as e4. destruct e4 as [-> ->].
+ rewrite (uip e3 eq_refl) in H. cbn in H. subst.
+ move: (IHev1 _ ev'1).
+ eapply DepElim.simplification_sigma1 => heq IHev1'.
+ noconf heq.
+ noconf IHev1'.
+ specialize (IHev2 _ ev'2). noconf IHev2.
+ pose proof e2 as E.
+ rewrite e0 in E. noconf E.
+ now rewrite -> (uip e e1), (uip e0 e2), (PCUICWcbvEval.le_irrel _ _ l l0).
+ + exfalso. invs i. destruct args; invs H0.
- depelim ev'; try go.
+ exfalso. rewrite !negb_or in i. specialize (IHev1 _ ev'1); noconf IHev1.
cbn in i. rtoProp; intuition auto.
@@ -799,7 +935,8 @@ Section Wcbv.
specialize (IHev2 _ ev'2); noconf IHev2.
now assert (i0 = i) as -> by now apply uip.
- depelim ev'; try go.
- now assert (i0 = i) as -> by now apply uip.
+ 2: now assert (i0 = i) as -> by now apply uip.
+ exfalso. invs i. destruct args; cbn in H0; invs H0.
Qed.
Lemma eval_unique {t v} :
@@ -1075,7 +1212,12 @@ Proof.
move: IHev1; rewrite closedn_mkApps => /andP[] _ clargs.
apply IHev2. rewrite /iota_red.
eapply closed_substl. now rewrite forallb_rev forallb_skipn.
- len. rewrite e2. eapply nth_error_forallb in Hc'; tea.
+ len. rewrite e3. eapply nth_error_forallb in Hc'; tea.
+ now rewrite Nat.add_0_r in Hc'.
+ - specialize (IHev1 Hc).
+ apply IHev2. rewrite /iota_red.
+ eapply closed_substl. now rewrite forallb_rev forallb_skipn.
+ len. rewrite e3. eapply nth_error_forallb in Hc'; tea.
now rewrite Nat.add_0_r in Hc'.
- subst brs. cbn in Hc'. rewrite andb_true_r in Hc'.
eapply IHev2. eapply closed_substl.
@@ -1111,9 +1253,15 @@ Proof.
rewrite closedn_mkApps /= => clargs.
eapply IHev2; eauto.
eapply nth_error_forallb in clargs; tea.
+ - have := (IHev1 Hc). intros clargs.
+ eapply IHev2; eauto.
+ eapply nth_error_forallb in clargs; tea.
- have := (IHev1 Hc).
rewrite closedn_mkApps /= => clargs.
rewrite clargs IHev2 //.
+ - rtoProp; intuition auto. forward IHev1; solve_all;
+ eapply All_app in Hc; solve_all.
+ eapply All_app_inv; solve_all. invs b. econstructor. eauto. econstructor.
- rtoProp; intuition auto.
Qed.
@@ -1148,6 +1296,9 @@ Proof.
- eapply IHev2; eauto.
eapply wellformed_iota_red_brs; tea => //.
rewrite wellformed_mkApps // in H2. move/andP: H2 => [] //.
+ - eapply IHev2; eauto.
+ eapply wellformed_iota_red_brs; tea => //.
+ now destruct args; inv H3.
- subst brs. eapply IHev2. sim in H0.
eapply wellformed_substl => //.
eapply All_forallb, All_repeat => //.
@@ -1175,6 +1326,10 @@ Proof.
eapply IHev2; eauto.
move/andP: clargs => [/andP[] hasc wfc wfargs].
eapply nth_error_forallb in wfargs; tea.
+ - eapply IHev2.
+ eapply nth_error_forallb in e2; eauto.
+ now destruct args; inv H0.
+ - destruct args; invs Hc''.
Qed.
Lemma remove_last_length {X} {l : list X} :
@@ -1235,6 +1390,9 @@ Proof.
- unshelve eexists; eauto. eapply eval_fix_value; eauto. eapply IHHe1. eapply IHHe2. cbn. destruct IHHe1, IHHe2. lia.
- unshelve eexists. eapply eval_construct; eauto.
eapply IHHe1. eapply IHHe2. cbn. destruct IHHe1, IHHe2. cbn. lia.
+ - unshelve eexists. eapply eval_construct_block; eauto.
+ { clear - l He1. eapply eval_Construct_inv in He1 as (? & ? & ?). eapply All2_length in a. invs e. lia. }
+ eapply IHHe1. eapply IHHe2. cbn. destruct IHHe1, IHHe2; lia.
- unshelve eexists. eapply eval_app_cong; eauto. eapply IHHe1. eapply IHHe2. cbn. destruct IHHe1, IHHe2. lia.
Qed.
@@ -1358,11 +1516,13 @@ Proof.
Qed.
Lemma eval_mkApps_Construct_inv {fl : WcbvFlags} Σ kn c args e :
- eval Σ (mkApps (tConstruct kn c) args) e ->
- ∑ args', (e = mkApps (tConstruct kn c) args') × All2 (eval Σ) args args'.
+ with_constructor_as_block = false ->
+ eval Σ (mkApps (tConstruct kn c []) args) e ->
+ ∑ args', (e = mkApps (tConstruct kn c []) args') × All2 (eval Σ) args args'.
Proof.
+ intros hblock.
revert e; induction args using rev_ind; intros e.
- - intros ev. depelim ev. exists []=> //.
+ - intros ev. depelim ev. congruence. exists []=> //.
- intros ev. rewrite mkApps_app /= in ev.
depelim ev; try solve_discr.
destruct (IHargs _ ev1) as [? []]. solve_discr.
@@ -1376,6 +1536,25 @@ Proof.
* now cbn in i.
Qed.
+Lemma eval_mkApps_Construct_block_inv {fl : WcbvFlags} Σ kn c args oargs e :
+ with_constructor_as_block ->
+ eval Σ (mkApps (tConstruct kn c args) oargs) e ->
+ ∑ args', oargs = [] × (e = tConstruct kn c args') × All2 (eval Σ) args args'.
+Proof.
+ intros hblock.
+ revert e; induction oargs using rev_ind; intros e.
+ - intros ev. depelim ev.
+ + eexists. split. reflexivity. split. reflexivity.
+ eapply eval_Construct_inv in ev1 as (? & [= <-] & ?).
+ eapply All2_app; eauto.
+ + invs i. destruct args; invs H0. exists []. repeat econstructor.
+ - intros ev. rewrite mkApps_app /= in ev.
+ depelim ev; try solve_discr.
+ all: try specialize (IHoargs _ ev1) as (? & ? & E & ?); try congruence; try solve_discr; try noconf E.
+ * subst. cbn in i. destruct with_guarded_fix; cbn in *; eauto.
+ * invs i.
+Qed.
+
Lemma eval_mkApps_inv_size {wfl : WcbvFlags} {Σ f args v} :
forall ev : eval Σ (mkApps f args) v,
∑ f' args' (evf : eval Σ f f'),
@@ -1464,31 +1643,33 @@ Proof.
Qed.
Lemma eval_mkApps_Construct_size {wfl : WcbvFlags} {Σ ind c args v} :
- forall ev : eval Σ (mkApps (tConstruct ind c) args) v,
- ∑ args' (evf : eval Σ (tConstruct ind c) (tConstruct ind c)),
+ with_constructor_as_block = false ->
+ forall ev : eval Σ (mkApps (tConstruct ind c []) args) v,
+ ∑ args' (evf : eval Σ (tConstruct ind c []) (tConstruct ind c [])),
[× eval_depth evf <= eval_depth ev,
All2 (fun a a' => ∑ eva : eval Σ a a', eval_depth eva < eval_depth ev) args args' &
- v = mkApps (tConstruct ind c) args'].
+ v = mkApps (tConstruct ind c []) args'].
Proof.
- intros ev.
+ intros hblock ev.
destruct (eval_mkApps_inv_size ev) as [f'' [args' [? []]]].
exists args'.
- exists (eval_atom _ (tConstruct ind c) eq_refl).
+ exists (eval_atom _ (tConstruct ind c []) eq_refl).
cbn. split => //. destruct ev; cbn => //; auto with arith.
clear l.
- destruct (eval_mkApps_Construct_inv _ _ _ _ _ ev) as [? []]. subst v.
- eapply (eval_mkApps_Construct_inv _ _ _ []) in x as [? []]. subst f''. depelim a1.
+ destruct (eval_mkApps_Construct_inv _ _ _ _ _ hblock ev) as [? []]. subst v.
+ eapply (@eval_mkApps_Construct_inv _ _ _ _ ) with (args0 := []) in x as [? []]; auto. subst f''. depelim a1.
f_equal.
eapply eval_deterministic_all; tea.
- eapply All2_impl; tea; cbn; eauto. now intros x y [].
+ eapply All2_impl; tea; cbn; eauto. now intros x y [].
Qed.
Lemma eval_construct_size {fl : WcbvFlags} [Σ kn c args e] :
- forall (ev : eval Σ (mkApps (tConstruct kn c) args) e),
- ∑ args', (e = mkApps (tConstruct kn c) args') ×
+ with_constructor_as_block = false ->
+ forall (ev : eval Σ (mkApps (tConstruct kn c []) args) e),
+ ∑ args', (e = mkApps (tConstruct kn c []) args') ×
All2 (fun x y => ∑ ev' : eval Σ x y, eval_depth ev' < eval_depth ev) args args'.
Proof.
- intros ev; destruct (eval_mkApps_Construct_size ev) as [args'[evf [_ hargs hv]]].
+ intros hblock ev; destruct (eval_mkApps_Construct_size hblock ev) as [args'[evf [_ hargs hv]]].
exists args'; intuition auto.
Qed.
@@ -1503,5 +1684,4 @@ Proof.
depelim H2.
specialize (IHx e _ H' H). simpl.
rewrite mkApps_app. simpl. econstructor; eauto.
-Qed.
-
+Qed.
\ No newline at end of file
diff --git a/erasure/theories/EWcbvEvalEtaInd.v b/erasure/theories/EWcbvEvalEtaInd.v
index 8707820dc..a9f8f3403 100644
--- a/erasure/theories/EWcbvEvalEtaInd.v
+++ b/erasure/theories/EWcbvEvalEtaInd.v
@@ -14,14 +14,14 @@ Hint Constructors eval : core.
Definition atomic_term (t : term) :=
match t with
- | tBox | tConstruct _ _ | tConst _ | tRel _ | tVar _ => true
+ | tBox | tConstruct _ _ _ | tConst _ | tRel _ | tVar _ => true
| _ => false
end.
Definition has_atom {etfl : ETermFlags} (t : term) :=
match t with
| tBox => has_tBox
- | tConstruct _ _ => has_tConstruct
+ | tConstruct _ _ _ => has_tConstruct
| tConst _ => has_tConst
| tRel _ => has_tRel
| tVar _ => has_tVar
@@ -141,7 +141,7 @@ Class Qpreserves {etfl : ETermFlags} (Q : nat -> term -> Type) Σ :=
qpres_qcofix :> Qcofix Q }.
Lemma eval_preserve_mkApps_ind :
-∀ (wfl : WcbvFlags) {efl : EEnvFlags} (Σ : global_declarations)
+∀ (wfl : WcbvFlags), with_constructor_as_block = false -> forall {efl : EEnvFlags} (Σ : global_declarations)
(P' : term → term → Type)
(Q : nat -> term -> Type)
{Qpres : Qpreserves Q Σ}
@@ -175,8 +175,8 @@ Lemma eval_preserve_mkApps_ind :
(list name × term))
(br : list name × term) (res : term),
forallb (λ x : list name × term, isEtaExp Σ x.2) brs ->
- eval Σ discr (mkApps (tConstruct ind c) args)
- → P discr (mkApps (tConstruct ind c) args)
+ eval Σ discr (mkApps (tConstruct ind c []) args)
+ → P discr (mkApps (tConstruct ind c []) args)
→ constructor_isprop_pars_decl Σ ind c = Some (false, pars, cdecl)
→ nth_error brs c = Some br
→ #|args| = pars + cdecl.(cstr_nargs)
@@ -280,8 +280,8 @@ Lemma eval_preserve_mkApps_ind :
→ (∀ p cdecl (discr : term) (args : list term) a (res : term),
has_tProj ->
eval Σ discr
- (mkApps (tConstruct p.(proj_ind) 0) args)
- → P discr (mkApps (tConstruct p.(proj_ind) 0) args)
+ (mkApps (tConstruct p.(proj_ind) 0 []) args)
+ → P discr (mkApps (tConstruct p.(proj_ind) 0 []) args)
→ constructor_isprop_pars_decl Σ p.(proj_ind) 0 = Some (false, p.(proj_npars), cdecl)
→ #|args| = p.(proj_npars) + cdecl.(cstr_nargs)
-> nth_error args (p.(proj_npars) + p.(proj_arg)) = Some a
@@ -308,15 +308,15 @@ Lemma eval_preserve_mkApps_ind :
#|args| = cstr_arity mdecl cdecl ->
All2 (eval Σ) args args' ->
isEtaExp_app Σ ind i #|args| ->
- Q 0 (mkApps (tConstruct ind i) args) ->
- Q 0 (mkApps (tConstruct ind i) args') ->
+ Q 0 (mkApps (tConstruct ind i []) args) ->
+ Q 0 (mkApps (tConstruct ind i []) args') ->
All2 P args args' ->
- P' (mkApps (tConstruct ind i) args) (mkApps (tConstruct ind i) args')) →
+ P' (mkApps (tConstruct ind i []) args) (mkApps (tConstruct ind i []) args')) →
(∀ t : term, atom t → Q 0 t -> isEtaExp Σ t -> P' t t) ->
∀ (t t0 : term), Q 0 t -> isEtaExp Σ t -> eval Σ t t0 → P' t t0.
Proof.
- intros * Qpres P P'Q etaΣ wfΣ hasapp.
+ intros wfl hcon. intros * Qpres P P'Q etaΣ wfΣ hasapp.
assert (qfixs: Qfixs Q) by tc.
assert (qcofixs: Qcofixs Q) by tc.
intros.
@@ -362,22 +362,22 @@ Proof.
eapply H; tea; (apply and_assum; [ih|hp' P'Q])
end.
destruct ev.
- 1-15:eapply qpres in qt as qt'; depelim qt' => //.
+ 1-18:eapply qpres in qt as qt'; depelim qt' => //.
- move/isEtaExp_tApp.
destruct decompose_app as [hd args] eqn:da.
destruct (construct_viewc hd) eqn:cv.
- * move=> [] argsn [] ha [] ht /andP[] etaind etaargs.
+ * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs.
clear IH; rewrite ha in ev1. elimtype False.
- eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr.
+ eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. auto.
* move=> /and4P [] etat0 etaargs etaa etat.
split. eapply X; tea; (apply and_assum; [ih|hp' P'Q]).
iheta q.
- move/isEtaExp_tApp.
destruct decompose_app as [hd args] eqn:da.
destruct (construct_viewc hd) eqn:cv.
- * move=> [] argsn [] ha [] ht /andP[] etaind etaargs.
+ * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs.
clear IH; rewrite ha in ev1. elimtype False.
- eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr.
+ eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. auto.
* move=> /and4P [] etat0 etaargs etaa etat.
assert (ql : Q 0 (tLambda na b)).
{ eapply P'Q; tea. ih. }
@@ -404,25 +404,26 @@ Proof.
- simp_eta. move=> /andP[etad etabrs].
assert (isEtaExp Σ (iota_red pars args br)).
{ eapply isEtaExp_iota_red.
- assert (isEtaExp Σ (mkApps (tConstruct ind c) args)) by iheta q.
- rewrite isEtaExp_mkApps_napp /= // in H.
+ assert (isEtaExp Σ (mkApps (tConstruct ind c []) args)) by iheta q.
+ rewrite isEtaExp_mkApps_napp /= // in H. rewrite andb_true_r in H.
now move/andP: H => [].
- now clear IH; eapply nth_error_forallb in e0; tea. }
+ now clear IH; eapply nth_error_forallb in e1; tea. }
assert (Q 0 (iota_red pars args br)).
{ unfold iota_red.
eapply nth_error_all in a; tea. cbn in a.
- rewrite -e2 in a.
+ rewrite -e3 in a.
rewrite -(List.rev_length (skipn pars args)) in a.
rewrite Nat.add_0_r in a.
eapply (qsubst _ (List.rev (skipn pars args))) in a.
2:{ eapply All_rev, All_skipn.
- assert (Q 0 (mkApps (tConstruct ind c) args)).
+ assert (Q 0 (mkApps (tConstruct ind c []) args)).
eapply P'Q; tea; ih.
eapply qapp in X13; tea. eapply X13. }
exact a. }
split. eapply X2; tea. 1,3:(apply and_assum; [ih|hp' P'Q]).
eapply nth_error_all in a; tea; cbn. now rewrite Nat.add_0_r in a.
iheta X13.
+ - congruence.
- simp_eta; move=> /andP[etad etabrs].
assert (isEtaExp Σ (substl (repeat tBox #|n|) f)).
{ eapply isEtaExp_substl => //. rewrite forallb_repeat //.
@@ -438,9 +439,9 @@ Proof.
- move/isEtaExp_tApp.
destruct decompose_app as [hd args] eqn:da.
destruct (construct_viewc hd) eqn:cv.
- * move=> [] argsn [] ha [] ht /andP[] etaind etaargs.
+ * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs.
clear IH; rewrite ha in ev1. elimtype False.
- eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr.
+ eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. auto.
* move=> /and4P [] etat0 etaargs etaa etat.
pose proof (ev1' := ev1). eapply P'Q in ev1' => //. 2:{ clear ev1'; ih. }
eapply qapp in ev1' as [hfix qargs] => //.
@@ -472,9 +473,9 @@ Proof.
- move/isEtaExp_tApp.
destruct decompose_app as [hd args] eqn:da.
destruct (construct_viewc hd) eqn:cv.
- * move=> [] argsn [] ha [] ht /andP[] etaind etaargs.
+ * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs.
clear IH; rewrite ha in ev1. elimtype False.
- eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr.
+ eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. auto.
* move=> /and4P [] etat0 etaargs etaa etat.
assert (isEtaExp Σ (tApp (mkApps (tFix mfix idx) argsv) av)).
{ rewrite -[tApp _ _](mkApps_app _ _ [av]).
@@ -488,9 +489,9 @@ Proof.
- move/isEtaExp_tApp.
destruct decompose_app as [hd args] eqn:da.
destruct (construct_viewc hd) eqn:cv.
- * move=> [] argsn [] ha [] ht /andP[] etaind etaargs.
+ * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs.
clear IH; rewrite ha in ev1. elimtype False.
- eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr.
+ eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. auto.
* move=> /and4P [] etat0 etaargs etaa etat.
assert (qav : Q 0 av).
{ eapply P'Q; tea; ih. }
@@ -571,13 +572,14 @@ Proof.
{ eapply nth_error_all in qargs; tea. }
clear ev1'; ih. }
assert (isEtaExp Σ a).
- { assert (isEtaExp Σ (mkApps (tConstruct p.(proj_ind) 0) args)) by iheta q.
+ { assert (isEtaExp Σ (mkApps (tConstruct p.(proj_ind) 0 []) args)) by iheta q.
move: H; simp_eta.
rewrite isEtaExp_mkApps_napp // /=.
- move=> /andP[] etaapp etaargs.
- eapply nth_error_forallb in etaargs; tea. }
+ move=> /andP[] /andP[] etaapp etaargs.
+ eapply nth_error_forallb in etaargs; tea. eauto. }
split. eapply X10; tea; (apply and_assum; [ih|hp' P'Q]).
iheta X13.
+ - congruence.
- simp_eta => etadiscr.
split. unshelve eapply X11; tea; try (intros; apply and_assum; [ih|hp' P'Q]).
now idtac.
@@ -585,11 +587,11 @@ Proof.
rename args into cargs.
destruct decompose_app as [hd args] eqn:da.
destruct (construct_viewc hd) eqn:cv.
- * move=> [] argsn [] ha [] ht /andP[] etaind etaargs.
+ * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs.
assert (eval_depth ev1 = eval_depth ev1) by reflexivity.
set (ev1' := ev1). change ev1 with ev1' in H at 1. clearbody ev1'. move: H.
subst f.
- pose proof (eval_construct_size ev1') as [ex []].
+ pose proof (eval_construct_size hcon ev1') as [ex []].
cbn in IH. intros eq.
assert (All2 (λ x y : term, ∑ ev' : eval Σ x y, eval_depth ev' < S (Nat.max (eval_depth ev1) (eval_depth ev2)))
(remove_last args ++ [a]) (ex ++ [a'])).
@@ -613,12 +615,12 @@ Proof.
eapply All2_All_mix_left in X15. 2:exact X14.
eapply All2_All_right; tea; cbn.
intros ? ? [? [? [? []]]]. split. eapply P'Q; tea. apply p. apply p. }
- eapply mkApps_eq_inj in e0 as [] => //. subst ex. noconf H.
+ eapply mkApps_eq_inj in e1 as [] => //. subst ex. noconf H.
split.
unshelve eapply Xcappexp; tea.
+ rewrite ht -remove_last_last //.
move: etaind; rewrite /isEtaExp_app.
- rewrite (lookup_constructor_pars_args_cstr_arity _ _ _ _ _ _ e).
+ rewrite (lookup_constructor_pars_args_cstr_arity _ _ _ _ _ _ e0).
move/Nat.leb_le. move: l. rewrite /cstr_arity.
eapply All2_length in X13. move: X13.
rewrite ht /= -remove_last_last //. len.
@@ -639,26 +641,28 @@ Proof.
+ rewrite isEtaExp_Constructor.
apply/andP. split. rewrite -(All2_length X16).
rewrite ht -remove_last_last //.
- eapply All_forallb. eapply All_impl; tea. cbn; intuition auto.
+ rtoProp. split. eauto.
+ eapply All_forallb. eapply All_impl; tea. cbn; intuition auto. auto.
* move=> /and4P [] etat0 etaargs etaa etat.
rewrite -[tApp _ a'](mkApps_app _ _ [a']).
- assert (P' f (mkApps (tConstruct ind c) cargs) × isEtaExp Σ (mkApps (tConstruct ind c) cargs)).
+ assert (P' f (mkApps (tConstruct ind c []) cargs) × isEtaExp Σ (mkApps (tConstruct ind c []) cargs)).
{ unshelve eapply IH; tea. cbn. lia. }
elimtype False.
destruct X13 as [p'f etac].
move: etac. rewrite isEtaExp_Constructor.
move/andP => []. rewrite /isEtaExp_app.
- rewrite /lookup_constructor_pars_args e /=.
- move/Nat.leb_le. clear IH. move: l; rewrite /cstr_arity. lia.
+ rewrite /lookup_constructor_pars_args e0 /=.
+ move => /andP[] /Nat.leb_le. clear IH. move: l; rewrite /cstr_arity. lia.
+ - congruence.
- move/isEtaExp_tApp.
destruct decompose_app as [hd args] eqn:da.
destruct (construct_viewc hd) eqn:cv.
- * move=> [] argsn [] ha [] ht /andP[] etaind etaargs.
+ * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs.
assert (eval_depth ev1 = eval_depth ev1) by reflexivity.
set (ev1' := ev1). change ev1 with ev1' in H at 1. clearbody ev1'. move: H.
subst f. exfalso.
eapply eval_mkApps_Construct_inv in ev1' as [? [hf' hargs']]. subst f'.
- clear IH; move: i; rewrite !negb_or isConstructApp_mkApps /= !andb_false_r //.
+ clear IH; move: i; rewrite !negb_or isConstructApp_mkApps /= !andb_false_r //. auto.
* move=> /and4P [] etat0 etaargs etaa etat.
split. eapply (X12 _ _ _ _ ev1); tea.
1,3:(apply and_assum; [ih|hp' P'Q]).
@@ -688,18 +692,19 @@ Ltac destruct_nary_times :=
| [ H : [× _, _, _, _ & _] |- _ ] => destruct H
end.
-Lemma eval_etaexp {fl : WcbvFlags} (efl := all_env_flags) {Σ a a'} :
+Lemma eval_etaexp {fl : WcbvFlags} (efl := all_env_flags) {Σ a a'} :
+ with_constructor_as_block = false ->
isEtaExp_env Σ ->
wf_glob Σ ->
eval Σ a a' -> isEtaExp Σ a -> isEtaExp Σ a'.
Proof.
- intros etaΣ wfΣ ev eta.
+ intros hcon etaΣ wfΣ ev eta.
generalize I. intros q. revert a a' q eta ev.
- eapply (eval_preserve_mkApps_ind (efl:=all_env_flags) fl Σ (fun _ x => isEtaExp Σ x) (fun _ _ => True) (Qpres := Qpreserves_True Σ)) => //.
+ eapply (eval_preserve_mkApps_ind (efl:=all_env_flags) fl hcon Σ (fun _ x => isEtaExp Σ x) (fun _ _ => True) (Qpres := Qpreserves_True Σ)) => //.
all:intros; repeat destruct_nary_times.
all:intuition auto.
- rewrite isEtaExp_Constructor => //.
- rewrite -(All2_length X0) H1.
+ rewrite -(All2_length X0) H1. cbn. rtoProp; intuition eauto.
cbn; eapply All_forallb. eapply All2_All_right; tea.
cbn. intros x y []; auto.
Qed.
diff --git a/erasure/theories/EWcbvEvalInd.v b/erasure/theories/EWcbvEvalInd.v
index 97a600227..1435dc6ed 100644
--- a/erasure/theories/EWcbvEvalInd.v
+++ b/erasure/theories/EWcbvEvalInd.v
@@ -37,18 +37,36 @@ Section eval_mkApps_rect.
→ eval Σ (ECSubst.csubst b0' 0 b1) res
→ P (ECSubst.csubst b0' 0 b1) res →
P (tLetIn na b0 b1) res)
- → (∀ (ind : Kernames.inductive) (pars : nat) cdecl (discr : term)
- (c : nat) (args : list term) (brs : list (list BasicAst.name × term))
- (br : list BasicAst.name × term) (res : term),
- eval Σ discr (mkApps (tConstruct ind c) args)
- → P discr (mkApps (tConstruct ind c) args)
- → constructor_isprop_pars_decl Σ ind c = Some (false, pars, cdecl)
- → nth_error brs c = Some br
- → #|args| = pars + cdecl.(cstr_nargs)
- → #|skipn pars args| = #|br.1|
- → eval Σ (iota_red pars args br) res
- → P (iota_red pars args br) res
- → P (tCase (ind, pars) discr brs) res)
+ → (∀ (ind : inductive) (pars : nat) (cdecl : constructor_body)
+ (discr : term) (c : nat) (args : list term)
+ (brs : list (list name × term)) (br : list name × term)
+ (res : term) (e : with_constructor_as_block = false)
+ (e0 : eval Σ discr (mkApps (tConstruct ind c []) args)),
+ P discr (mkApps (tConstruct ind c []) args)
+ → ∀ (e1 : constructor_isprop_pars_decl Σ ind c =
+ Some (false, pars, cdecl)) (e2 :
+ nth_error brs c =
+ Some br)
+ (e3 : #|args| = pars + cstr_nargs cdecl)
+ (e4 : #|skipn pars args| = #|br.1|)
+ (e5 : eval Σ (iota_red pars args br) res),
+ P (iota_red pars args br) res
+ → P (tCase (ind, pars) discr brs) res)
+ → (∀ (ind : inductive) (pars : nat) (cdecl : constructor_body)
+ (discr : term) (c : nat) (args : list term)
+ (brs : list (list name × term)) (br : list name × term)
+ (res : term) (e : with_constructor_as_block = true)
+ (e0 : eval Σ discr (tConstruct ind c args)),
+ P discr (tConstruct ind c args)
+ → ∀ (e1 : constructor_isprop_pars_decl Σ ind c =
+ Some (false, pars, cdecl))
+ (e2 : nth_error brs c = Some br)
+ (e3 : #|args| = pars + cstr_nargs cdecl)
+ (e4 : #|skipn pars args| = #|br.1|)
+ (e5 : eval Σ (iota_red pars args br) res),
+ P (iota_red pars args br) res
+ → P (tCase (ind, pars) discr brs) res)
+
→ (∀ (ind : Kernames.inductive) (pars : nat) (discr : term)
(brs : list (list BasicAst.name × term))
(n : list BasicAst.name) (f3 res : term),
@@ -60,6 +78,7 @@ Section eval_mkApps_rect.
→ eval Σ (ECSubst.substl (repeat tBox #|n|) f3) res
→ P (ECSubst.substl (repeat tBox #|n|) f3) res
→ P (tCase (ind, pars) discr brs) res)
+
→ (∀ (f4 : term) (mfix : mfixpoint term)
(idx : nat) (argsv : list term)
(a av fn res : term),
@@ -121,16 +140,47 @@ Section eval_mkApps_rect.
cst_body decl = Some body
→ eval Σ body res
→ P body res → P (tConst c) res)
- → (∀ p (discr : term) (args : list term)
- (res : term) cdecl a,
- eval Σ discr (mkApps (tConstruct p.(proj_ind) 0) args)
- → P discr (mkApps (tConstruct p.(proj_ind) 0) args)
- → constructor_isprop_pars_decl Σ p.(proj_ind) 0 = Some (false, p.(proj_npars), cdecl)
- → #|args| = p.(proj_npars) + cdecl.(cstr_nargs)
- -> nth_error args (p.(proj_npars) + p.(proj_arg)) = Some a
- -> eval Σ a res
- → P a res
- → P (tProj p discr) res)
+
+ → (∀ (p : projection) (cdecl : constructor_body)
+ (discr : term) (args : list term)
+ (a res : term) (e : with_constructor_as_block =
+ false)
+ (e0 : eval Σ discr
+ (mkApps
+ (tConstruct
+ (proj_ind p) 0 []) args)),
+ P discr
+ (mkApps
+ (tConstruct (proj_ind p) 0 [])
+ args)
+ → ∀ (e1 : constructor_isprop_pars_decl Σ
+ (proj_ind p) 0 =
+ Some (false, proj_npars p, cdecl))
+ (e2 : #|args| =
+ proj_npars p + cstr_nargs cdecl)
+ (e3 : nth_error args
+ (proj_npars p + proj_arg p) =
+ Some a) (e4 : eval Σ a res),
+ P a res
+ → P (tProj p discr) res)
+ → (∀ (p : projection) (cdecl : constructor_body)
+ (discr : term) (args : list term)
+ (a res : term) (e :
+ with_constructor_as_block =
+ true)
+ (e0 : eval Σ discr
+ (tConstruct (proj_ind p) 0 args)),
+ P discr (tConstruct (proj_ind p) 0 args)
+ → ∀ (e1 : constructor_isprop_pars_decl Σ
+ (proj_ind p) 0 =
+ Some (false, proj_npars p, cdecl))
+ (e2 : #|args| =
+ proj_npars p + cstr_nargs cdecl)
+ (e3 : nth_error args
+ (proj_npars p + proj_arg p) =
+ Some a) (e4 : eval Σ a res),
+ P a res
+ → P (tProj p discr) res)
→ (∀ p (discr : term),
with_prop_case
@@ -139,30 +189,72 @@ Section eval_mkApps_rect.
→ inductive_isprop_and_pars Σ p.(proj_ind) = Some (true, p.(proj_npars))
→ P (tProj p discr) tBox)
- → (∀ ind c mdecl idecl cdecl f args a a',
- lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) ->
- forall (ev : eval Σ f (mkApps (tConstruct ind c) args)),
- IH _ _ ev ->
+ → (∀ (ind : inductive)
+ (c : nat) (mdecl : mutual_inductive_body)
+ (idecl : one_inductive_body)
+ (cdecl : constructor_body)
+ (f14 : term) (args : list term)
+ (a a' : term)
+ (e : with_constructor_as_block = false)
+ (e0 : lookup_constructor Σ ind c =
+ Some (mdecl, idecl, cdecl))
+ (e1 : eval Σ f14
+ (mkApps
+ (tConstruct ind c [])
+ args)),
+ IH _ _ e1 ->
+ P f14
+ (mkApps (tConstruct ind c [])
+ args)
+ → ∀ (l : #|args| < cstr_arity mdecl cdecl)
+ (e2 : eval Σ a a'),
+ P a a'
+ → P (tApp f14 a)
+ (tApp
+ (mkApps
+ (tConstruct ind c
+ []) args) a'))
- P f (mkApps (tConstruct ind c) args) ->
- #|args| < cstr_arity mdecl cdecl ->
- eval Σ a a' ->
- P a a' ->
- P (tApp f a) (tApp (mkApps (tConstruct ind c) args) a'))
+ → (∀ (ind : inductive)
+ (c : nat) (mdecl : mutual_inductive_body)
+ (idecl : one_inductive_body)
+ (cdecl : constructor_body)
+ (args args' :
+ list term) (a a' : term)
+ (e : with_constructor_as_block = true)
+ (e0 : lookup_constructor Σ ind c =
+ Some (mdecl, idecl, cdecl))
+ (l : #|args| < cstr_arity mdecl cdecl)
+ (e1 : eval Σ
+ (tConstruct ind c args)
+ (tConstruct ind c args')),
+ P (tConstruct ind c args)
+ (tConstruct ind c args')
+ → ∀ e2 : eval Σ a a',
+ P a a'
+ → P (tConstruct ind c (args ++ [a]))
+ (tConstruct ind c
+ (args' ++ [a'])))
- → (∀ (f11 f' : term) a a' ,
- forall (ev : eval Σ f11 f'),
- P f11 f' ->
- IH _ _ ev
- → ~~ (isLambda f' || (if with_guarded_fix then isFixApp f' else isFix f') || isBox f'
- || isConstructApp f')
- → eval Σ a a'
- → P a a'
- → P (tApp f11 a) (tApp f' a'))
+ → (∀ (f15 f' a a' : term) (e : eval Σ f15 f'),
+ P f15 f' -> IH _ _ e
+ → ∀ (i : ~~
+ (isLambda f'
+ ||
+ (if with_guarded_fix
+ then isFixApp f'
+ else isFix f') ||
+ isBox f' ||
+ isConstructApp f'))
+ (e0 : eval Σ a a'),
+ P a a'
+ → P (tApp f15 a)
+ (tApp f' a')
+ )
→ (∀ t : term, atom t → P t t)
→ ∀ t t0 : term, eval Σ t t0 → P t t0.
Proof using Type.
- intros ?????????????????? H.
+ intros ????????????????????? H.
pose proof (p := @Fix_F { t : _ & { t0 : _ & eval Σ t t0 }}).
specialize (p (MR lt (fun x => eval_depth x.π2.π2))).
set(foo := existT _ t (existT _ t0 H) : { t : _ & { t0 : _ & eval Σ t t0 }}).
@@ -193,4 +285,3 @@ Proof using Type.
Qed.
End eval_mkApps_rect.
-
diff --git a/erasure/theories/EWellformed.v b/erasure/theories/EWellformed.v
index 27828e501..67d031d0f 100644
--- a/erasure/theories/EWellformed.v
+++ b/erasure/theories/EWellformed.v
@@ -76,6 +76,8 @@ Section wf.
Definition wf_fix_gen (wf : nat -> term -> bool) k mfix idx :=
let k' := List.length mfix + k in
(idx #|mfix|) && List.forallb (test_def (wf k')) mfix.
+
+ Definition is_nil {A} (l : list A) := match l with [] => true | _ => false end.
Fixpoint wellformed k (t : term) : bool :=
match t with
@@ -96,7 +98,7 @@ Section wf.
| Some d => has_axioms || isSome d.(cst_body)
| _ => false
end
- | tConstruct ind c => has_tConstruct && isSome (lookup_constructor Σ ind c)
+ | tConstruct ind c block_args => has_tConstruct && isSome (lookup_constructor Σ ind c) && is_nil block_args
| tVar _ => has_tVar
end.
@@ -158,7 +160,8 @@ Section EEnvFlags.
autorewrite with map;
simpl wellformed in *; intuition auto;
unfold wf_fix, test_def, test_snd in *;
- try solve [simpl lift; simpl closed; f_equal; auto; repeat (rtoProp; simpl in *; solve_all)]; try easy.
+ try solve [simpl lift; simpl closed; f_equal; auto; repeat (rtoProp; simpl in *; solve_all)]; try easy.
+ destruct args; firstorder.
Qed.
Lemma wellformed_closed_decl {t} : wf_global_decl Σ t -> closed_decl t.
@@ -193,6 +196,7 @@ Section EEnvFlags.
elim (Nat.ltb_spec); auto. apply Nat.ltb_lt in H1. lia.
simpl; rewrite H0 /=. elim (Nat.ltb_spec); auto. intros.
apply Nat.ltb_lt in H1. lia.
+ - solve_all. destruct args; firstorder.
- solve_all. rewrite Nat.add_assoc. eauto.
- len. move/andP: H1 => [] -> ha. cbn. solve_all.
rewrite Nat.add_assoc; eauto.
@@ -231,6 +235,7 @@ Section EEnvFlags.
- specialize (IHt2 (S k')).
rewrite <- Nat.add_succ_comm in IHt2.
eapply IHt2; auto.
+ - now destruct args; inv H0.
- specialize (a (#|x.1| + k')) => //.
rewrite Nat.add_assoc (Nat.add_comm k) in a.
rewrite !Nat.add_assoc. eapply a => //.
diff --git a/erasure/theories/Erasure.v b/erasure/theories/Erasure.v
index 11ff060f7..fcc4c85aa 100644
--- a/erasure/theories/Erasure.v
+++ b/erasure/theories/Erasure.v
@@ -43,17 +43,17 @@ Program Definition erasure_pipeline {guard : abstract_guard_impl} (efl := EWellf
(* Simulation of the guarded fixpoint rules with a single unguarded one:
the only "stuck" fixpoints remaining are unapplied.
This translation is a noop on terms and environments. *)
- guarded_to_unguarded_fix eq_refl ▷
+ guarded_to_unguarded_fix (wcon := eq_refl) eq_refl ▷
(* Remove all constructor parameters *)
- remove_params_optimization ▷
+ remove_params_optimization (wcon := eq_refl) ▷
(* Rebuild the efficient lookup table *)
rebuild_wf_env_transform (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) ▷
(* Remove all cases / projections on propositional content *)
- optimize_prop_discr_optimization (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) (hastrel := eq_refl) (hastbox := eq_refl) ▷
+ optimize_prop_discr_optimization (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) (wcon := eq_refl) (hastrel := eq_refl) (hastbox := eq_refl) ▷
(* Rebuild the efficient lookup table *)
rebuild_wf_env_transform (efl := EWellformed.all_env_flags) ▷
(* Inline projections to cases *)
- inline_projections_optimization (fl := EWcbvEval.target_wcbv_flags) (hastrel := eq_refl) (hastbox := eq_refl).
+ inline_projections_optimization (fl := EWcbvEval.target_wcbv_flags) (wcon := eq_refl) (hastrel := eq_refl) (hastbox := eq_refl).
(* At the end of erasure we get a well-formed program (well-scoped globally and localy), without
parameters in inductive declarations. The constructor applications are also expanded, and
the evaluation relation does not need to consider guarded fixpoints or case analyses on propositional
@@ -96,10 +96,10 @@ Program Definition erasure_pipeline_fast {guard : abstract_guard_impl} (efl := E
template_to_pcuic_transform ▷
pcuic_expand_lets_transform ▷
erase_transform ▷
- guarded_to_unguarded_fix eq_refl ▷
- remove_params_fast_optimization _ ▷
+ guarded_to_unguarded_fix (wcon := eq_refl) eq_refl ▷
+ remove_params_fast_optimization (wcon := eq_refl) _ ▷
rebuild_wf_env_transform (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) ▷
- optimize_prop_discr_optimization (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) (hastrel := eq_refl) (hastbox := eq_refl).
+ optimize_prop_discr_optimization (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) (wcon := eq_refl) (hastrel := eq_refl) (hastbox := eq_refl).
Next Obligation.
destruct H; split => //. now eapply ETransform.expanded_eprogram_env_expanded_eprogram_cstrs.
Qed.
diff --git a/erasure/theories/ErasureCorrectness.v b/erasure/theories/ErasureCorrectness.v
index f559b1aa2..a3073b40c 100644
--- a/erasure/theories/ErasureCorrectness.v
+++ b/erasure/theories/ErasureCorrectness.v
@@ -325,7 +325,7 @@ Proof.
invs H2.
-- exists x2. split; eauto.
- constructor. econstructor. eauto. 2:eauto.
+ constructor. econstructor. eauto. eauto. 2:eauto.
4:{ unfold EGlobalEnv.iota_red.
rewrite ECSubst.substl_subst //.
rewrite forallb_rev forallb_skipn //.
@@ -1021,7 +1021,7 @@ Proof.
eapply erases_deps_eval in Hed1; tea.
eapply erases_deps_mkApps_inv in Hed1 as [].
depelim H8.
- constructor. eapply Ee.eval_construct; tea.
+ constructor. eapply Ee.eval_construct; tea. eauto.
eapply (EGlobalEnv.declared_constructor_lookup H9).
rewrite -(Forall2_length H7).
rewrite /EAst.cstr_arity.
@@ -1305,4 +1305,4 @@ Proof.
+ constructor => //.
eapply erases_deps_mkApps_inv in etaΣ as [].
solve_all.
-Qed.
\ No newline at end of file
+Qed.
diff --git a/erasure/theories/ErasureFunction.v b/erasure/theories/ErasureFunction.v
index 4b6fc0280..0e61fb071 100644
--- a/erasure/theories/ErasureFunction.v
+++ b/erasure/theories/ErasureFunction.v
@@ -393,7 +393,7 @@ Section Erase.
| tSort u := !%prg
| tConst kn u := E.tConst kn
| tInd kn u := !%prg
- | tConstruct kn k u := E.tConstruct kn k
+ | tConstruct kn k u := E.tConstruct kn k []
| tProd _ _ _ := !%prg
| tLambda na b b' := let t' := erase (vass na b :: Γ) b' _ in
E.tLambda na.(binder_name) t'
@@ -1942,7 +1942,7 @@ Section wffix.
| tCoFix mfix idx =>
(idx #|mfix|) && List.forallb (wf_fixpoints ∘ dbody) mfix
| tConst kn => true
- | tConstruct ind c => true
+ | tConstruct ind c _ => true
| tVar _ => true
| tBox => true
end.
diff --git a/erasure/theories/ErasureProperties.v b/erasure/theories/ErasureProperties.v
index 8450c1c80..1b1ca62c5 100644
--- a/erasure/theories/ErasureProperties.v
+++ b/erasure/theories/ErasureProperties.v
@@ -635,7 +635,7 @@ Proof.
simpl; try solve [solve_all].
- now apply Nat.ltb_lt.
- eapply trans_lookup_constant in wfa; tea.
- - eapply trans_lookup_constructor in wfa; tea.
+ - eapply trans_lookup_constructor in wfa; tea. now rewrite wfa.
- move/andP: wfa => [] /andP[] lookup wfc wfbrs.
apply/andP. split. apply/andP. split; eauto.
eapply trans_lookup_inductive; tea.
@@ -677,7 +677,8 @@ Lemma eval_empty_brs {wfl : Ee.WcbvFlags} Σ ci p e : Σ ⊢ E.tCase ci p [] ▷
Proof.
intros He.
depind He.
- - clear -e0. now rewrite nth_error_nil in e0.
+ - clear -e1. now rewrite nth_error_nil in e1.
+ - clear -e1. now rewrite nth_error_nil in e1.
- discriminate.
- eapply IHHe2.
- cbn in i. discriminate.
@@ -693,6 +694,7 @@ Proof.
- depelim He1. clear -H. symmetry in H. elimtype False.
destruct args using rev_case. discriminate.
rewrite EAstUtils.mkApps_app in H. discriminate.
+ - depelim He1.
- exists n, f. intuition auto.
- depelim He1. clear -H. symmetry in H. elimtype False.
destruct args using rev_case. discriminate.
@@ -709,6 +711,8 @@ Proof.
depind He.
- pose proof (Ee.eval_deterministic He1 Hc). subst c'.
econstructor; eauto. now eapply Ee.value_final, Ee.eval_to_value.
+ - pose proof (Ee.eval_deterministic He1 Hc). subst c'.
+ eapply Ee.eval_iota_block; eauto. now eapply Ee.value_final, Ee.eval_to_value.
- pose proof (Ee.eval_deterministic He1 Hc). subst c'.
eapply Ee.eval_iota_sing; tea. now constructor.
- pose proof (Ee.eval_deterministic He1 Hc). subst c'.
@@ -726,6 +730,8 @@ Proof.
depind He.
- pose proof (eval_trans' Hc He1); subst discr.
econstructor; eauto.
+ - pose proof (eval_trans' Hc He1); subst discr.
+ now econstructor; eauto.
- pose proof (eval_trans' Hc He1); subst discr.
eapply Ee.eval_iota_sing; tea.
- pose proof (eval_trans' Hc He1); subst discr.
@@ -739,13 +745,15 @@ Lemma eval_proj_eval_inv_discr {wfl : Ee.WcbvFlags} {Σ p c c' e} :
Σ ⊢ E.tProj p c' ▷ e.
Proof.
intros He Hc.
- depind He.
+ depind He.
- pose proof (eval_trans' Hc He1); subst discr.
econstructor; eauto.
- pose proof (eval_trans' Hc He1); subst discr.
- eapply Ee.eval_proj; tea.
+ now econstructor; tea.
+ - pose proof (eval_trans' Hc He1); subst discr.
+ now econstructor; tea.
- pose proof (eval_trans' Hc He); subst discr.
- eapply Ee.eval_proj_prop; tea.
+ now econstructor; tea.
- cbn in i. discriminate.
Qed.
diff --git a/erasure/theories/Extract.v b/erasure/theories/Extract.v
index 94b6fb0a9..9f0136c81 100644
--- a/erasure/theories/Extract.v
+++ b/erasure/theories/Extract.v
@@ -55,7 +55,7 @@ Inductive erases (Σ : global_env_ext) (Γ : context) : term -> E.term -> Prop :
Σ;;; Γ |- tConst kn u ⇝ℇ E.tConst kn
| erases_tConstruct : forall (kn : inductive) (k : nat) (n : Instance.t),
isPropositional Σ kn false ->
- Σ;;; Γ |- tConstruct kn k n ⇝ℇ E.tConstruct kn k
+ Σ;;; Γ |- tConstruct kn k n ⇝ℇ E.tConstruct kn k []
| erases_tCase1 (ci : case_info) (p : predicate term) (c : term)
(brs : list (branch term)) (c' : E.term)
(brs' : list (list name × E.term)) :
@@ -113,7 +113,7 @@ Lemma erases_forall_list_ind
P Γ (tConst kn u) (E.tConst kn))
(Hconstruct : forall Γ kn k n,
isPropositional Σ kn false ->
- P Γ (tConstruct kn k n) (E.tConstruct kn k))
+ P Γ (tConstruct kn k n) (E.tConstruct kn k []))
(Hcase : forall Γ ci p c brs c' brs',
PCUICElimination.Informative Σ ci.(ci_ind) ->
Σ;;; Γ |- c ⇝ℇ c' ->
@@ -266,7 +266,7 @@ Inductive erases_deps (Σ : global_env) (Σ' : E.global_declarations) : E.term -
EGlobalEnv.declared_constructor Σ' (ind, c) mdecl' idecl' cdecl' ->
erases_mutual_inductive_body mdecl mdecl' ->
erases_one_inductive_body idecl idecl' ->
- erases_deps Σ Σ' (E.tConstruct ind c)
+ erases_deps Σ Σ' (E.tConstruct ind c [])
| erases_deps_tCase p mdecl idecl mdecl' idecl' discr brs :
declared_inductive Σ (fst p) mdecl idecl ->
EGlobalEnv.declared_inductive Σ' (fst p) mdecl' idecl' ->
From 488ac9dd5ea69a9dc938df27a1935b9aaa9dfa15 Mon Sep 17 00:00:00 2001
From: Yannick Forster
Date: Sun, 26 Jun 2022 12:53:21 +0200
Subject: [PATCH 05/43] Replace all uses of `todo` and `Admitted` by axioms
(#717)
* remove all todos, all Admitteds and add a checktodos make target
* Squash the axioms to avoid introducing useless dependencies in extracted code
Co-authored-by: Matthieu Sozeau
---
INSTALL.md | 8 +++---
Makefile | 5 +++-
README.md | 29 ++++++++++++++--------
RELEASING.md | 1 +
checktodos.sh | 21 ++++++++++++++++
erasure/theories/EArities.v | 3 +++
erasure/theories/Erasure.v | 18 +++++++++++---
pcuic/theories/PCUICEquality.v | 2 +-
pcuic/theories/PCUICInversion.v | 2 +-
pcuic/theories/PCUICSafeLemmata.v | 2 +-
pcuic/theories/utils/PCUICAstUtils.v | 6 ++---
safechecker/theories/Extraction.v | 9 ++++++-
safechecker/theories/PCUICEqualityDec.v | 2 +-
safechecker/theories/PCUICSafeConversion.v | 8 +++---
safechecker/theories/PCUICTypeChecker.v | 2 +-
template-coq/theories/AstUtils.v | 2 +-
template-coq/theories/Checker.v | 19 --------------
template-coq/theories/EnvMap.v | 4 +--
template-coq/theories/LiftSubst.v | 4 +--
template-coq/theories/TemplateCheckWf.v | 7 ++++--
template-coq/theories/TemplateProgram.v | 24 +++++++++++++++---
template-coq/theories/Universes.v | 2 +-
template-coq/theories/monad_utils.v | 3 ---
template-coq/theories/utils/All_Forall.v | 2 +-
24 files changed, 120 insertions(+), 65 deletions(-)
create mode 100755 checktodos.sh
diff --git a/INSTALL.md b/INSTALL.md
index a550810ef..334ffae8e 100644
--- a/INSTALL.md
+++ b/INSTALL.md
@@ -72,12 +72,12 @@ To setup a fresh `opam` installation, you might want to create a
one yet. You need to use **opam 2** to obtain the right version of
`Equations`.
- # opam switch create coq.8.14 4.07.1
+ # opam switch create coq.8.16 --packages=ocaml-variants.4.13.1+options,ocaml-option-flambda
# eval $(opam env)
-This creates the `coq.8.14` switch which initially contains only the
-basic `OCaml` `4.07.1` compiler, and puts you in the right environment
-(check with `ocamlc -v`).
+This creates the `coq.8.16` switch which initially contains only the
+basic `OCaml` `4.13.1` compiler with the `flambda` option enabled,
+and puts you in the right environment (check with `ocamlc -v`).
Once in the right switch, you can install `Coq` and the `Equations` package using:
diff --git a/Makefile b/Makefile
index 79389f0fe..46150a69e 100644
--- a/Makefile
+++ b/Makefile
@@ -95,7 +95,7 @@ ci-local-noclean:
./configure.sh local
$(MAKE) all test-suite TIMED=pretty-timed
-ci-local: ci-local-noclean
+ci-local: ci-local-noclean
$(MAKE) clean
ci-quick:
@@ -106,3 +106,6 @@ ci-opam:
# Use -v so that regular output is produced
opam install -v -y .
opam remove -y coq-metacoq coq-metacoq-template
+
+checktodos:
+ sh checktodos.sh
diff --git a/README.md b/README.md
index 2daec5930..f1fe701a8 100644
--- a/README.md
+++ b/README.md
@@ -54,9 +54,14 @@ Template-Coq with additional features. Each extension is in dedicated folder.
Template-Coq is a quoting library for [Coq](http://coq.inria.fr). It
takes `Coq` terms and constructs a representation of their syntax tree as
-a `Coq` inductive data type. The representation is based on the kernel's
+an inductive data type. The representation is based on the kernel's
term representation.
+After importing `MetaCoq.Template.Loader` there are commands `MetaCoq Test Quote t.`,
+`MetaCoq Quote Definition name := (t).` and `MetaCoq Quote Recursively Definition name := (t).` as
+well as a tactic `quote_term t k`,
+where in all cases `t` is a term and `k` a continuation tactic.
+
In addition to this representation of terms, Template Coq includes:
- Reification of the environment structures, for constant and inductive
@@ -66,9 +71,9 @@ In addition to this representation of terms, Template Coq includes:
- A monad for manipulating global declarations, calling the type
checker, and inserting them in the global environment, in
- the style of MTac.
+ the style of MTac. Monadic programs `p : TemplateMonad A` can be run using `MetaCoq Run p`.
-- A formalisation of the expected typing rules reflecting the ones of Coq
+- A formalisation of the typing rules reflecting the ones of Coq, not covering eta-expansion and template polymorphism.
### [PCUIC](https://github.com/MetaCoq/metacoq/tree/coq-8.11/pcuic)
@@ -92,7 +97,14 @@ calculus has proofs of standard metatheoretical results:
that singleton elimination (from Prop to Type) is only allowed
on singleton inductives in Prop.
-### [Safe Checker](https://github.com/MetaCoq/metacoq/tree/coq-8.13/safechecker)
+- Canonicity: The weak head normal form of erms of inductive type is a constructor application.
+
+- Consistency under the assumption of strong normalization
+
+- Weak call-by-value standardization: Normal forms of terms of first-order inductive type
+can be found via weak call-by-value evaluation.
+
+### [Safe Checker](https://github.com/MetaCoq/metacoq/tree/coq-8.16/safechecker)
Implementation of a fuel-free and verified reduction machine, conversion
checker and type checker for PCUIC. This relies on a postulate of
@@ -108,12 +120,11 @@ type-checker, one can use:
MetaCoq CoqCheck
-
-### [Erasure](https://github.com/MetaCoq/metacoq/tree/coq-8.13/erasure)
+### [Erasure](https://github.com/MetaCoq/metacoq/tree/coq-8.16/erasure)
An erasure procedure to untyped lambda-calculus accomplishing the
-same as the Extraction plugin of Coq. The extracted safe erasure is
-available in Coq through a new vernacular command:
+same as the type and proof erasure phase of the Extraction plugin of Coq.
+The extracted safe erasure is available in Coq through a new vernacular command:
MetaCoq Erase
@@ -138,8 +149,6 @@ Examples of translations built on top of this:
and [test-suite/safechecker_test.v](https://github.com/MetaCoq/metacoq/tree/coq-8.13/test-suite/safechecker_test.v) show example
uses (and current limitations of) the verified checker and erasure.
-
-
## Papers
- ["Coq Coq Correct! Verification of Type Checking and Erasure for Coq, in Coq"](https://metacoq.github.io/coqcoqcorrect)
diff --git a/RELEASING.md b/RELEASING.md
index 91e4c35e3..4d2613a6d 100644
--- a/RELEASING.md
+++ b/RELEASING.md
@@ -1 +1,2 @@
- Change the "version:" fields in opam files.
+
diff --git a/checktodos.sh b/checktodos.sh
new file mode 100755
index 000000000..25b2476f3
--- /dev/null
+++ b/checktodos.sh
@@ -0,0 +1,21 @@
+#!/bin/sh
+
+if [[ $(git grep -c todo | grep theories) = template-coq/theories/utils/MCUtils.v:3 ]]
+then
+ echo "No todos found"
+ if [[ $(git grep -c Admitted | grep theories) = "" ]]
+ then
+ echo "No Admitted results found"
+ exit 0
+ else
+ echo "Found Admitted results:"
+ git grep -c Admitted | grep theories
+ exit 1
+ fi
+else
+ echo "Found todos:"
+ git grep -c todo | grep theories
+ exit 1
+fi
+endef
+
diff --git a/erasure/theories/EArities.v b/erasure/theories/EArities.v
index 492c0d74c..f687356d5 100644
--- a/erasure/theories/EArities.v
+++ b/erasure/theories/EArities.v
@@ -22,6 +22,9 @@ Local Existing Instance extraction_checker_flags.
Implicit Types (cf : checker_flags) (Σ : global_env_ext).
+(* TODO move *)
+#[global] Existing Instance extends_refl.
+
Lemma isErasable_Proof Σ Γ t :
Is_proof Σ Γ t -> isErasable Σ Γ t.
Proof.
diff --git a/erasure/theories/Erasure.v b/erasure/theories/Erasure.v
index 11ff060f7..f3f570c61 100644
--- a/erasure/theories/Erasure.v
+++ b/erasure/theories/Erasure.v
@@ -108,20 +108,32 @@ Definition run_erase_program_fast {guard : abstract_guard_impl} := run erasure_p
Local Open Scope string_scope.
+Axiom fake_guard_impl_properties :
+forall (fix_cofix: PCUICTyping.FixCoFix)
+ (Σ: PCUICAst.PCUICEnvironment.global_env_ext)
+ (Γ: PCUICAst.PCUICEnvironment.context)
+ (mfix: BasicAst.mfixpoint PCUICAst.term),
+PCUICTyping.guard fix_cofix Σ Γ mfix <-> fake_guard_impl fix_cofix Σ Γ mfix.
+
+
Global Program Instance fake_guard_impl : abstract_guard_impl :=
{| guard_impl := fake_guard_impl |}.
-Next Obligation. Admitted.
+Next Obligation. apply fake_guard_impl_properties. Qed.
(** This uses the retyping-based erasure and assumes that the global environment and term
are welltyped (for speed). As such this should only be used for testing, or when we know that
the environment is wellformed and the term well-typed (e.g. when it comes directly from a
Coq definition). *)
+
+
+Axiom assume_that_we_only_erase_on_welltyped_programs :
+ forall (p : Ast.Env.program), squash (TemplateProgram.wt_template_program p).
Definition erase_and_print_template_program {cf : checker_flags} (p : Ast.Env.program)
: string :=
- let p' := run_erase_program p (sq (todo "assuming quoted environment and term are well-typed")) in
+ let p' := run_erase_program p (assume_that_we_only_erase_on_welltyped_programs p) in
time "Pretty printing" EPretty.print_program p'.
Program Definition erase_fast_and_print_template_program {cf : checker_flags} (p : Ast.Env.program)
: string :=
- let p' := run_erase_program_fast p (sq (todo "wf_env and welltyped term")) in
+ let p' := run_erase_program_fast p (assume_that_we_only_erase_on_welltyped_programs p) in
time "pretty-printing" EPretty.print_program p'.
diff --git a/pcuic/theories/PCUICEquality.v b/pcuic/theories/PCUICEquality.v
index ff3b500b6..cdef24b7d 100644
--- a/pcuic/theories/PCUICEquality.v
+++ b/pcuic/theories/PCUICEquality.v
@@ -1291,7 +1291,7 @@ Proof.
eapply eq_term_upto_univ_trans; exact _.
Qed.
-(* todo: rename *)
+(* TODO: rename *)
(* Definition nleq_term t t' := *)
(* eqb_term_upto_univ eqb eqb t t'. *)
diff --git a/pcuic/theories/PCUICInversion.v b/pcuic/theories/PCUICInversion.v
index 23d7c369d..68b65c5e8 100644
--- a/pcuic/theories/PCUICInversion.v
+++ b/pcuic/theories/PCUICInversion.v
@@ -6,7 +6,7 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICCases PCUICLiftSubst PCUICUnivSu
PCUICOnFreeVars PCUICClosedTyp PCUICWellScopedCumulativity.
Require Import Equations.Prop.DepElim.
-(* todo: make wf arguments implicit *)
+(* TODO: make wf arguments implicit *)
Section Inversion.
Context `{checker_flags}.
diff --git a/pcuic/theories/PCUICSafeLemmata.v b/pcuic/theories/PCUICSafeLemmata.v
index 92f2d72b7..bf439d604 100644
--- a/pcuic/theories/PCUICSafeLemmata.v
+++ b/pcuic/theories/PCUICSafeLemmata.v
@@ -346,7 +346,7 @@ Section Lemmata.
destruct h; depelim wf; simpl in *.
all: destruct l; econstructor; eauto.
Qed.
- (* todo: rename alpha_eq *)
+ (* TODO: rename alpha_eq *)
Lemma compare_decls_conv Γ Γ' :
eq_context_upto_names Γ Γ' ->
conv_context cumulAlgo_gen Σ Γ Γ'.
diff --git a/pcuic/theories/utils/PCUICAstUtils.v b/pcuic/theories/utils/PCUICAstUtils.v
index b91b6b3b7..006243ec1 100644
--- a/pcuic/theories/utils/PCUICAstUtils.v
+++ b/pcuic/theories/utils/PCUICAstUtils.v
@@ -205,7 +205,7 @@ Fixpoint remove_arity (n : nat) (t : term) : term :=
| O => t
| S n => match t with
| tProd _ _ B => remove_arity n B
- | _ => t (* todo *)
+ | _ => t (* TODO *)
end
end.
@@ -282,7 +282,7 @@ Fixpoint decompose_prod_n_assum (Γ : context) n (t : term) : option (context *
end
end.
-(* todo move *)
+(* TODO move *)
Lemma it_mkLambda_or_LetIn_app l l' t :
it_mkLambda_or_LetIn (l ++ l') t = it_mkLambda_or_LetIn l' (it_mkLambda_or_LetIn l t).
Proof. induction l in l', t |- *; simpl; auto. Qed.
@@ -402,7 +402,7 @@ Ltac merge_All :=
#[global]
Hint Rewrite @map_def_id @map_id : map.
-(* todo move *)
+(* TODO move *)
Ltac close_All :=
match goal with
| H : Forall _ _ |- Forall _ _ => apply (Forall_impl H); clear H; simpl
diff --git a/safechecker/theories/Extraction.v b/safechecker/theories/Extraction.v
index b269dda4f..03ffbfcf5 100644
--- a/safechecker/theories/Extraction.v
+++ b/safechecker/theories/Extraction.v
@@ -37,12 +37,19 @@ Extraction Inline Equations.Prop.Logic.True_rect_dep Equations.Prop.Logic.False_
Extraction Inline PCUICPrimitive.prim_val_reflect_eq.
Cd "src".
+Axiom fake_abstract_guard_impl_properties:
+ forall (fix_cofix : PCUICTyping.FixCoFix)
+ (Σ : PCUICAst.PCUICEnvironment.global_env_ext)
+ (Γ : PCUICAst.PCUICEnvironment.context)
+ (mfix : BasicAst.mfixpoint PCUICAst.term),
+ PCUICTyping.guard fix_cofix Σ Γ mfix <->
+ PCUICWfEnvImpl.fake_guard_impl fix_cofix Σ Γ mfix.
#[local,program] Instance fake_abstract_guard_impl : PCUICWfEnvImpl.abstract_guard_impl :=
{
guard_impl := PCUICWfEnvImpl.fake_guard_impl
}.
-Next Obligation. Admitted.
+Next Obligation. eapply fake_abstract_guard_impl_properties. Qed.
Definition infer_and_print_template_program_with_guard {cf} {nor} :=
@SafeTemplateChecker.infer_and_print_template_program cf nor fake_abstract_guard_impl.
diff --git a/safechecker/theories/PCUICEqualityDec.v b/safechecker/theories/PCUICEqualityDec.v
index 7f48784cc..633942d43 100644
--- a/safechecker/theories/PCUICEqualityDec.v
+++ b/safechecker/theories/PCUICEqualityDec.v
@@ -13,7 +13,7 @@ Local Set Keyed Unification.
Set Default Goal Selector "!".
-(*todo move*)
+(* TODO move*)
Lemma consistent_instance_wf_universe `{checker_flags} Σ uctx u :
consistent_instance_ext Σ uctx u ->
diff --git a/safechecker/theories/PCUICSafeConversion.v b/safechecker/theories/PCUICSafeConversion.v
index b3a733b30..8fb8f19d1 100644
--- a/safechecker/theories/PCUICSafeConversion.v
+++ b/safechecker/theories/PCUICSafeConversion.v
@@ -5850,13 +5850,13 @@ match
(LevelSet.add Level.lzero LevelSet.empty, ConstraintSet.empty);
declarations := []
|}, Monomorphic_ctx);
- referenced_impl_ext_wf := todo "foo"
+ referenced_impl_ext_wf := TODO "foo"
|} [] Cumul (tSort (Universe.lType (Universe.make' (Level.lzero, 0))))
- (todo "") (tSort (Universe.lType (Universe.make' (Level.lzero, 0))))
- (todo "")
+ (TODO "") (tSort (Universe.lType (Universe.make' (Level.lzero, 0))))
+ (TODO "")
with
| ConvSuccess => "success"
-| ConvError _ => todo "foo"
+| ConvError _ => TODO "foo"
end = "success".
Proof.
lazy. reflexivity.
diff --git a/safechecker/theories/PCUICTypeChecker.v b/safechecker/theories/PCUICTypeChecker.v
index d63905b02..0598c4dbc 100644
--- a/safechecker/theories/PCUICTypeChecker.v
+++ b/safechecker/theories/PCUICTypeChecker.v
@@ -1771,7 +1771,7 @@ Section Typecheck.
Qed.
Next Obligation.
- (*todo: factor*)
+ (*TODO: factor*)
cbn in *. pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq.
apply eqb_eq in i. subst I.
eapply eqb_eq in i0.
diff --git a/template-coq/theories/AstUtils.v b/template-coq/theories/AstUtils.v
index d971222c9..6c81955fa 100644
--- a/template-coq/theories/AstUtils.v
+++ b/template-coq/theories/AstUtils.v
@@ -192,7 +192,7 @@ Fixpoint remove_arity (n : nat) (t : term) : term :=
| O => t
| S n => match t with
| tProd _ _ B => remove_arity n B
- | _ => t (* todo *)
+ | _ => t (* TODO *)
end
end.
diff --git a/template-coq/theories/Checker.v b/template-coq/theories/Checker.v
index 0a84dd2a5..20ba48c6b 100644
--- a/template-coq/theories/Checker.v
+++ b/template-coq/theories/Checker.v
@@ -614,25 +614,6 @@ Definition check_conv `{checker_flags} {F:Fuel} := check_conv_gen Conv.
Definition is_graph_of_global_env_ext `{checker_flags} Σ G :=
is_graph_of_uctx G (global_ext_uctx Σ).
-Lemma conv_spec : forall `{checker_flags} {F:Fuel} Σ G Γ t u,
- is_graph_of_global_env_ext Σ G ->
- Σ ;;; Γ |- t = u <~> check_conv (fst Σ) G Γ t u = Checked ().
-Proof.
- intros. todo "Checker.conv_spec".
-Defined.
-
-Lemma cumul_spec : forall `{checker_flags} {F:Fuel} Σ G Γ t u,
- is_graph_of_global_env_ext Σ G ->
- Σ ;;; Γ |- t <= u <~> check_conv_leq (fst Σ) G Γ t u = Checked ().
-Proof.
- intros. todo "Checker.cumul_spec".
-Defined.
-
-Lemma reduce_cumul :
- forall `{checker_flags} Σ Γ n t, Σ ;;; Γ |- try_reduce (fst Σ) Γ n t <= t.
-Proof. intros. todo "Checker.reduce_cumul". Defined.
-
-
Section Typecheck.
Context {F : Fuel}.
Context (Σ : global_env).
diff --git a/template-coq/theories/EnvMap.v b/template-coq/theories/EnvMap.v
index b9f1389d1..d7b39028f 100644
--- a/template-coq/theories/EnvMap.v
+++ b/template-coq/theories/EnvMap.v
@@ -293,7 +293,7 @@ Context {A : Type}.
Lemma pos_of_string_cont_inj s s' p : pos_of_string_cont s p = pos_of_string_cont s' p -> s = s'.
Proof.
induction s; destruct s' => /= //.
- Admitted.
+ Qed. (* TODO *)
Fixpoint pos_of_dirpath_cont (d : dirpath) (cont : positive) : positive :=
match d with
@@ -324,7 +324,7 @@ Context {A : Type}.
induction a; destruct m => /= //.
cbn.
- Admitted.
+ Qed. (* TODO *)
Definition empty : t := PTree.empty _.
diff --git a/template-coq/theories/LiftSubst.v b/template-coq/theories/LiftSubst.v
index 28f215634..5a506f748 100644
--- a/template-coq/theories/LiftSubst.v
+++ b/template-coq/theories/LiftSubst.v
@@ -461,7 +461,7 @@ Qed.
Lemma noccur_between_subst k n t : noccur_between k n t ->
closedn (n + k) t -> closedn k t.
Proof.
-Admitted. *)
+Qed. *) (* TODO *)
Lemma strip_casts_lift n k t :
strip_casts (lift n k t) = lift n k (strip_casts t).
@@ -524,4 +524,4 @@ Proof.
pose (subst_context_snoc n k ctx a). unfold snoc in e. rewrite e. clear e.
simpl. rewrite -> IHctx.
pose (subst_context_snoc n k ctx a). simpl. now destruct a as [na [b|] ty].
-Qed.
\ No newline at end of file
+Qed.
diff --git a/template-coq/theories/TemplateCheckWf.v b/template-coq/theories/TemplateCheckWf.v
index 492d0b29a..6ed3e103d 100644
--- a/template-coq/theories/TemplateCheckWf.v
+++ b/template-coq/theories/TemplateCheckWf.v
@@ -9,8 +9,11 @@ Open Scope bs_scope.
Definition run_eta_program := Transform.run template_eta_expand.
+Axiom assume_welltypedness_of_input : forall p, ∥ wt_template_program p ∥.
Definition eta_expand p :=
- run_eta_program p (todo "assume well-typedness").
+ run_eta_program p (assume_welltypedness_of_input p).
+
+Compute (Transform.pre template_eta_expand _).
Definition check_def (d : kername × global_decl) : TemplateMonad unit :=
match d.2 with
@@ -72,4 +75,4 @@ Definition check_wf_eta (g : Ast.Env.program) : TemplateMonad unit :=
(* To test that a program's eta-expansion is indeed well-typed according to Coq's kernel use:
- MetaCoq Run (tmQuoteRec wf_program >>= check_wf_eta). *)
\ No newline at end of file
+ MetaCoq Run (tmQuoteRec wf_program >>= check_wf_eta). *)
diff --git a/template-coq/theories/TemplateProgram.v b/template-coq/theories/TemplateProgram.v
index f243eaca5..9a1d1aba6 100644
--- a/template-coq/theories/TemplateProgram.v
+++ b/template-coq/theories/TemplateProgram.v
@@ -31,6 +31,24 @@ Definition template_expand_obseq (p p' : template_program) (v v' : Ast.term) :=
Local Obligation Tactic := idtac.
+Axiom eta_expansion_preserves_wf_ext_and_typing :
+ forall (cf : checker_flags)
+ (Σ : global_env)
+ (t : term)
+ (wfext : wf_ext (empty_ext (Σ, t).1))
+ (ht : ∑ T : term, empty_ext (Σ, t).1;;; [] |- (Σ, t).2 : T),
+ ∥ wt_template_program (eta_expand_program (Σ, t)) ∥.
+
+Axiom eta_expansion_preserves_evaluation :
+ forall (cf : checker_flags)
+ (Σ : global_env)
+ (t v : term)
+ (w : wf_ext (empty_ext (Σ, t).1))
+ (s : ∑ T : term, empty_ext (Σ, t).1;;; [] |- (Σ, t).2 : T)
+ (ev : ∥ eval Σ t v ∥),
+ ∥ eval (eta_expand_global_env Σ) (eta_expand (declarations Σ) [] t)
+ (eta_expand (declarations Σ) [] v) ∥.
+
Program Definition template_eta_expand {cf : checker_flags} : self_transform template_program Ast.term eval_template_program eval_template_program :=
{| name := "eta-expansion of template program";
pre p := ∥ wt_template_program p ∥;
@@ -39,7 +57,7 @@ Program Definition template_eta_expand {cf : checker_flags} : self_transform tem
obseq := template_expand_obseq |}.
Next Obligation.
intros cf [Σ t] [[wfext ht]].
- cbn. split. split. todo "eta-expansion preserves wf ext and typing".
+ cbn. split. eapply eta_expansion_preserves_wf_ext_and_typing; eauto.
red.
destruct ht as [T ht].
split; cbn. eapply EtaExpand.eta_expand_global_env_expanded. apply wfext.
@@ -53,7 +71,7 @@ Next Obligation.
red. intros cf [Σ t] v [[]].
unfold eval_template_program.
cbn. intros ev.
- exists (EtaExpand.eta_expand (Ast.Env.declarations Σ) [] v). split. split.
- todo "eta-expansion preserves evaluation".
+ exists (EtaExpand.eta_expand (Ast.Env.declarations Σ) [] v). split.
+ eapply eta_expansion_preserves_evaluation; eauto.
red. reflexivity.
Qed.
diff --git a/template-coq/theories/Universes.v b/template-coq/theories/Universes.v
index 37c510990..d5ccb7008 100644
--- a/template-coq/theories/Universes.v
+++ b/template-coq/theories/Universes.v
@@ -2531,7 +2531,7 @@ Definition polymorphic_instance uctx :=
| Monomorphic_ctx => Instance.empty
| Polymorphic_ctx c => fst (AUContext.repr c)
end.
-(* todo: duplicate of polymorphic_instance *)
+(* TODO: duplicate of polymorphic_instance *)
Definition abstract_instance decl :=
match decl with
| Monomorphic_ctx => Instance.empty
diff --git a/template-coq/theories/monad_utils.v b/template-coq/theories/monad_utils.v
index 07cc7c175..dc3f08eac 100644
--- a/template-coq/theories/monad_utils.v
+++ b/template-coq/theories/monad_utils.v
@@ -1,6 +1,3 @@
-(* todo(gmm): This file should really be replaced by a real
- * monad library.
- *)
Require Import Arith List.
From MetaCoq.Template Require Import All_Forall MCSquash.
From Equations Require Import Equations.
diff --git a/template-coq/theories/utils/All_Forall.v b/template-coq/theories/utils/All_Forall.v
index 4adaadac6..a6a09502b 100644
--- a/template-coq/theories/utils/All_Forall.v
+++ b/template-coq/theories/utils/All_Forall.v
@@ -1767,7 +1767,7 @@ Proof.
move=> [= <-]. now rewrite (IHHa _ E').
Qed.
-(* todo: move *)
+(* TODO: move *)
Lemma All_mapi {A B} P f l k :
Alli (fun i x => P (f i x)) k l -> All P (@mapi_rec A B f l k).
Proof.
From b6daf8cda78c57ac3c2ba094cc525e2177bbf581 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Mon, 27 Jun 2022 10:58:46 +0200
Subject: [PATCH 06/43] Ensure constant constructors are declared in evaluation
(#718)
---
erasure/theories/EEtaExpandedFix.v | 2 +-
erasure/theories/EInlineProjections.v | 2 ++
erasure/theories/EOptimizePropDiscr.v | 3 ++-
erasure/theories/ERemoveParams.v | 7 +++--
erasure/theories/EWcbvEval.v | 38 ++++++++++++++-------------
erasure/theories/EWcbvEvalEtaInd.v | 2 +-
erasure/theories/EWcbvEvalInd.v | 2 +-
erasure/theories/ErasureCorrectness.v | 5 ++--
8 files changed, 35 insertions(+), 26 deletions(-)
diff --git a/erasure/theories/EEtaExpandedFix.v b/erasure/theories/EEtaExpandedFix.v
index bb087a915..6ec3fffb5 100644
--- a/erasure/theories/EEtaExpandedFix.v
+++ b/erasure/theories/EEtaExpandedFix.v
@@ -1840,7 +1840,7 @@ Proof.
rewrite (remove_last_last l a hl).
rewrite -[tApp _ _](mkApps_app _ _ [a']).
eapply eval_mkApps_Construct; tea.
- { now constructor. }
+ { constructor. cbn [atom]; rewrite H //. }
{ len. rewrite (All2_length hargs). lia. }
eapply All2_app.
eapply forallb_remove_last, forallb_All in etal.
diff --git a/erasure/theories/EInlineProjections.v b/erasure/theories/EInlineProjections.v
index 3f99c9e9c..2afb1ba1c 100644
--- a/erasure/theories/EInlineProjections.v
+++ b/erasure/theories/EInlineProjections.v
@@ -656,6 +656,8 @@ Proof.
destruct v => /= //.
- destruct t => //.
all:constructor; eauto.
+ cbn [atom optimize] in i |- *.
+ rewrite -lookup_constructor_optimize //.
Qed.
From MetaCoq.Erasure Require Import EEtaExpanded.
diff --git a/erasure/theories/EOptimizePropDiscr.v b/erasure/theories/EOptimizePropDiscr.v
index 64a4ef6f7..a19b19144 100644
--- a/erasure/theories/EOptimizePropDiscr.v
+++ b/erasure/theories/EOptimizePropDiscr.v
@@ -698,7 +698,8 @@ Proof.
destruct args using rev_case => // /=. rewrite map_app !mkApps_app /= //.
destruct v => /= //.
- destruct t => //.
- all:constructor; eauto.
+ all:constructor; eauto. cbn [atom optimize] in i |- *.
+ rewrite -lookup_constructor_optimize //.
Qed.
(*
diff --git a/erasure/theories/ERemoveParams.v b/erasure/theories/ERemoveParams.v
index 134be90a4..a9e351b1b 100644
--- a/erasure/theories/ERemoveParams.v
+++ b/erasure/theories/ERemoveParams.v
@@ -964,7 +964,7 @@ Proof.
rewrite (lookup_constructor_lookup_inductive_pars H).
eapply eval_mkApps_Construct; tea.
+ rewrite lookup_constructor_strip H //.
- + now constructor.
+ + constructor. cbn [atom]. rewrite lookup_constructor_strip H //.
+ rewrite /cstr_arity /=.
move: H0; rewrite /cstr_arity /=.
rewrite skipn_length map_length => ->. lia.
@@ -973,7 +973,10 @@ Proof.
intros x y []; auto.
- destruct t => //.
- all:constructor; eauto.
+ all:constructor; eauto. simp strip.
+ cbn [atom strip] in H |- *.
+ rewrite lookup_constructor_strip.
+ destruct lookup_constructor eqn:hl => //. destruct p as [[] ?] => //.
Qed.
From MetaCoq.Erasure Require Import EEtaExpanded.
diff --git a/erasure/theories/EWcbvEval.v b/erasure/theories/EWcbvEval.v
index c498a85ef..f56783f91 100644
--- a/erasure/theories/EWcbvEval.v
+++ b/erasure/theories/EWcbvEval.v
@@ -27,13 +27,13 @@ Local Ltac inv H := inversion H; subst.
(** ** Big step version of weak cbv beta-zeta-iota-fix-delta reduction. *)
-Definition atom t :=
+Definition atom Σ t :=
match t with
| tBox
- | tConstruct _ _
| tCoFix _ _
| tLambda _ _
| tFix _ _ => true
+ | tConstruct ind c => isSome (lookup_constructor Σ ind c)
| _ => false
end.
@@ -47,7 +47,7 @@ Definition isStuckFix t (args : list term) :=
| _ => false
end.
-Lemma atom_mkApps f l : atom (mkApps f l) -> (l = []) /\ atom f.
+Lemma atom_mkApps Σ f l : atom Σ (mkApps f l) -> (l = []) /\ atom Σ f.
Proof.
revert f; induction l using rev_ind. simpl. intuition auto.
simpl. intros. now rewrite mkApps_app in H.
@@ -197,7 +197,7 @@ Section Wcbv.
(** Atoms are values (includes abstractions, cofixpoints and constructors) *)
- | eval_atom t : atom t -> eval t t.
+ | eval_atom t : atom Σ t -> eval t t.
Hint Constructors eval : core.
Derive Signature for eval.
@@ -227,7 +227,7 @@ Section Wcbv.
Derive Signature NoConfusion for value_head.
Inductive value : term -> Type :=
- | value_atom t : atom t -> value t
+ | value_atom t : atom Σ t -> value t
| value_app_nonnil f args : value_head #|args| f -> args <> [] -> All value args -> value (mkApps f args).
Derive Signature for value.
@@ -245,12 +245,12 @@ Section Wcbv.
Lemma value_app f args : value_head #|args| f -> All value args -> value (mkApps f args).
Proof.
destruct args.
- - intros [] hv; now constructor.
+ - intros [] hv; constructor; try easy. cbn [atom mkApps]. now rewrite e.
- intros vh av. eapply value_app_nonnil => //.
Qed.
Lemma value_values_ind : forall P : term -> Type,
- (forall t, atom t -> P t) ->
+ (forall t, atom Σ t -> P t) ->
(forall f args, value_head #|args| f -> args <> [] -> All value args -> All P args -> P (mkApps f args)) ->
forall t : term, value t -> P t.
Proof.
@@ -270,14 +270,14 @@ Section Wcbv.
Proof. destruct t; auto. Qed.
Hint Resolve isStuckfix_nApp : core.
- Lemma atom_nApp {t} : atom t -> ~~ isApp t.
+ Lemma atom_nApp {t} : atom Σ t -> ~~ isApp t.
Proof. destruct t; auto. Qed.
Hint Resolve atom_nApp : core.
Lemma value_mkApps_inv t l :
~~ isApp t ->
value (mkApps t l) ->
- ((l = []) /\ atom t) + ([× l <> [], value_head #|l| t & All value l]).
+ ((l = []) /\ atom Σ t) + ([× l <> [], value_head #|l| t & All value l]).
Proof.
intros H H'. generalize_eq x (mkApps t l).
revert x H' t H. apply: value_values_ind.
@@ -353,7 +353,7 @@ Section Wcbv.
value_head n t -> eval t t.
Proof.
destruct 1.
- - now constructor.
+ - constructor; try easy. now cbn [atom]; rewrite e.
- now eapply eval_atom.
- now eapply eval_atom.
Qed.
@@ -362,9 +362,9 @@ Section Wcbv.
(* It means no redex can remain at the head of an evaluated term. *)
Lemma value_head_spec' n t :
- value_head n t -> (~~ (isLambda t || isBox t)) && atom t.
+ value_head n t -> (~~ (isLambda t || isBox t)) && atom Σ t.
Proof.
- induction 1; cbn => //.
+ induction 1; auto. cbn [atom]; rewrite e //.
Qed.
@@ -953,7 +953,9 @@ Section WcbvEnv.
induction ev; try solve [econstructor;
eauto using (extends_lookup_constructor wf ex), (extends_constructor_isprop_pars_decl wf ex), (extends_is_propositional wf ex)].
econstructor; eauto.
- red in isdecl |- *. eauto using extends_lookup.
+ red in isdecl |- *. eauto using extends_lookup. constructor.
+ destruct t => //. cbn [atom] in i. destruct lookup_constructor eqn:hl => //.
+ eapply (extends_lookup_constructor wf ex) in hl. now cbn [atom].
Qed.
End WcbvEnv.
@@ -1359,7 +1361,7 @@ Qed.
Lemma eval_mkApps_Construct_inv {fl : WcbvFlags} Σ kn c args e :
eval Σ (mkApps (tConstruct kn c) args) e ->
- ∑ args', (e = mkApps (tConstruct kn c) args') × All2 (eval Σ) args args'.
+ ∑ args', [× isSome (lookup_constructor Σ kn c), (e = mkApps (tConstruct kn c) args') & All2 (eval Σ) args args'].
Proof.
revert e; induction args using rev_ind; intros e.
- intros ev. depelim ev. exists []=> //.
@@ -1472,18 +1474,18 @@ Lemma eval_mkApps_Construct_size {wfl : WcbvFlags} {Σ ind c args v} :
Proof.
intros ev.
destruct (eval_mkApps_inv_size ev) as [f'' [args' [? []]]].
- exists args'.
- exists (eval_atom _ (tConstruct ind c) eq_refl).
+ exists args'.
+ destruct (eval_mkApps_Construct_inv _ _ _ _ _ ev) as [? []]. subst v.
+ exists (eval_atom _ (tConstruct ind c) i).
cbn. split => //. destruct ev; cbn => //; auto with arith.
clear l.
- destruct (eval_mkApps_Construct_inv _ _ _ _ _ ev) as [? []]. subst v.
eapply (eval_mkApps_Construct_inv _ _ _ []) in x as [? []]. subst f''. depelim a1.
f_equal.
eapply eval_deterministic_all; tea.
eapply All2_impl; tea; cbn; eauto. now intros x y [].
Qed.
-Lemma eval_construct_size {fl : WcbvFlags} [Σ kn c args e] :
+Lemma eval_construct_size {fl : WcbvFlags} [Σ kn c args e] :
forall (ev : eval Σ (mkApps (tConstruct kn c) args) e),
∑ args', (e = mkApps (tConstruct kn c) args') ×
All2 (fun x y => ∑ ev' : eval Σ x y, eval_depth ev' < eval_depth ev) args args'.
diff --git a/erasure/theories/EWcbvEvalEtaInd.v b/erasure/theories/EWcbvEvalEtaInd.v
index 8707820dc..7cbf6e778 100644
--- a/erasure/theories/EWcbvEvalEtaInd.v
+++ b/erasure/theories/EWcbvEvalEtaInd.v
@@ -313,7 +313,7 @@ Lemma eval_preserve_mkApps_ind :
All2 P args args' ->
P' (mkApps (tConstruct ind i) args) (mkApps (tConstruct ind i) args')) →
- (∀ t : term, atom t → Q 0 t -> isEtaExp Σ t -> P' t t) ->
+ (∀ t : term, atom Σ t → Q 0 t -> isEtaExp Σ t -> P' t t) ->
∀ (t t0 : term), Q 0 t -> isEtaExp Σ t -> eval Σ t t0 → P' t t0.
Proof.
intros * Qpres P P'Q etaΣ wfΣ hasapp.
diff --git a/erasure/theories/EWcbvEvalInd.v b/erasure/theories/EWcbvEvalInd.v
index 97a600227..9c14cc8e6 100644
--- a/erasure/theories/EWcbvEvalInd.v
+++ b/erasure/theories/EWcbvEvalInd.v
@@ -159,7 +159,7 @@ Section eval_mkApps_rect.
→ eval Σ a a'
→ P a a'
→ P (tApp f11 a) (tApp f' a'))
- → (∀ t : term, atom t → P t t)
+ → (∀ t : term, atom Σ t → P t t)
→ ∀ t t0 : term, eval Σ t t0 → P t t0.
Proof using Type.
intros ?????????????????? H.
diff --git a/erasure/theories/ErasureCorrectness.v b/erasure/theories/ErasureCorrectness.v
index f559b1aa2..cdb5e374d 100644
--- a/erasure/theories/ErasureCorrectness.v
+++ b/erasure/theories/ErasureCorrectness.v
@@ -1102,7 +1102,8 @@ Proof.
* eexists. split. 2: now constructor; econstructor.
econstructor; eauto.
+ invs He.
- * eexists. split. 2: now constructor; econstructor.
+ * eexists. split. 2:{ constructor; econstructor. cbn [EWcbvEval.atom].
+ depelim Hed. eapply EGlobalEnv.declared_constructor_lookup in H0. now rewrite H0. }
econstructor; eauto.
* eexists. split. 2: now constructor; econstructor.
eauto.
@@ -1114,7 +1115,7 @@ Proof.
* eexists. split; eauto. now constructor; econstructor.
* eexists. split. 2: now constructor; econstructor.
econstructor; eauto.
- Unshelve. all: repeat econstructor.
+ Unshelve. all: repeat econstructor.
Qed.
(* Print Assumptions erases_correct. *)
From 17b949276b209659b4d4894f2025116f0a28e9ed Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Mon, 27 Jun 2022 15:03:46 +0200
Subject: [PATCH 07/43] Update readmes (#719)
* Update README.md
* Cleanup erasure and add a readme there
* Fix typo
* Remove a leftover Compute
* Fix erasure _CoqProject.in
---
README.md | 83 +++++++++++++++++++------
erasure/_CoqProject.in | 2 -
erasure/theories/EAll.v | 3 -
erasure/theories/ECoFixToFix.v | 23 -------
erasure/theories/EWndEval.v | 67 --------------------
erasure/theories/README.md | 79 +++++++++++++++++++++++
template-coq/theories/TemplateCheckWf.v | 2 -
7 files changed, 142 insertions(+), 117 deletions(-)
delete mode 100644 erasure/theories/EAll.v
delete mode 100644 erasure/theories/ECoFixToFix.v
delete mode 100644 erasure/theories/EWndEval.v
create mode 100644 erasure/theories/README.md
diff --git a/README.md b/README.md
index f1fe701a8..427883bda 100644
--- a/README.md
+++ b/README.md
@@ -4,7 +4,8 @@
-[![Build status](https://github.com/MetaCoq/metacoq/workflows/Test%20compilation/badge.svg?branch=coq-8.13)](https://github.com/MetaCoq/metacoq/actions) [![MetaCoq Chat](https://img.shields.io/badge/zulip-join_chat-brightgreen.svg)](https://coq.zulipchat.com)
+[![Build status](https://github.com/MetaCoq/metacoq/actions/workflows/build.yml/badge.svg?branch=coq-8.16)](https://github.com/MetaCoq/metacoq/actions) [![MetaCoq Chat](https://img.shields.io/badge/zulip-join_chat-brightgreen.svg)](https://coq.zulipchat.com)
+[![Open in Visual Studio Code](https://open.vscode.dev/badges/open-in-vscode.svg)](https://open.vscode.dev/metacoq/metacoq)
MetaCoq is a project formalizing Coq in Coq and providing tools for
manipulating Coq terms and developing certified plugins
@@ -48,7 +49,7 @@ See [DOC.md](https://github.com/MetaCoq/metacoq/tree/coq-8.13/DOC.md)
At the center of this project is the Template-Coq quoting library for
Coq. The project currently has a single repository extending
-Template-Coq with additional features. Each extension is in dedicated folder.
+Template-Coq with additional features. Each extension is in a dedicated folder.
### [Template-Coq](https://github.com/MetaCoq/metacoq/tree/coq-8.13/template-coq)
@@ -65,17 +66,18 @@ where in all cases `t` is a term and `k` a continuation tactic.
In addition to this representation of terms, Template Coq includes:
- Reification of the environment structures, for constant and inductive
- declarations.
+ declarations along with their universe structures.
-- Denotation of terms and global declarations
+- Denotation of terms and global declarations.
-- A monad for manipulating global declarations, calling the type
+- A monad for querying the environment, manipulating global declarations, calling the type
checker, and inserting them in the global environment, in
the style of MTac. Monadic programs `p : TemplateMonad A` can be run using `MetaCoq Run p`.
-- A formalisation of the typing rules reflecting the ones of Coq, not covering eta-expansion and template polymorphism.
+- A formalisation of the typing rules reflecting the ones of Coq, covering all of Coq
+ except eta-expansion and template polymorphism.
-### [PCUIC](https://github.com/MetaCoq/metacoq/tree/coq-8.11/pcuic)
+### [PCUIC](https://github.com/MetaCoq/metacoq/tree/coq-8.16/pcuic)
PCUIC, the Polymorphic Cumulative Calculus of Inductive Constructions is
a cleaned up version of the term language of Coq and its associated
@@ -87,28 +89,36 @@ calculus has proofs of standard metatheoretical results:
- Confluence of reduction using a notion of parallel reduction
-- Context conversion and validity of typing.
+- Context cumulativity / conversion and validity of typing.
- Subject Reduction (case/cofix reduction excluded)
- Principality: every typeable term has a smallest type.
+- Bidirectional presentation: an equivalent presentation of the system
+ that enforces directionality of the typing rules. Strengthening follows
+ from this presentation.
+
- Elimination restrictions: the elimination restrictions ensure
that singleton elimination (from Prop to Type) is only allowed
on singleton inductives in Prop.
-- Canonicity: The weak head normal form of erms of inductive type is a constructor application.
+- Canonicity: The weak head normal form of a term of inductive type is a constructor application.
- Consistency under the assumption of strong normalization
- Weak call-by-value standardization: Normal forms of terms of first-order inductive type
can be found via weak call-by-value evaluation.
+See the PCUIC [README](https://github.com/MetaCoq/metacoq/tree/coq-8.16/pcuic/theories/README.md) for
+a detailed view of the development.
+
### [Safe Checker](https://github.com/MetaCoq/metacoq/tree/coq-8.16/safechecker)
Implementation of a fuel-free and verified reduction machine, conversion
checker and type checker for PCUIC. This relies on a postulate of
strong normalization of the reduction relation of PCUIC on well-typed terms.
+The checker is shown to be correct and complete w.r.t. the PCUIC specification.
The extracted safe checker is available in Coq through a new vernacular command:
MetaCoq SafeCheck
@@ -120,6 +130,12 @@ type-checker, one can use:
MetaCoq CoqCheck
+This also includes a verified, efficient re-typing procedure (useful in tactics) in
+`MetaCoq.SafeChecker.PCUICSafeRetyping`.
+
+See the SafeChecker [README](https://github.com/MetaCoq/metacoq/tree/coq-8.16/safechecker/theories/README.md) for
+a detailed view of the development.
+
### [Erasure](https://github.com/MetaCoq/metacoq/tree/coq-8.16/erasure)
An erasure procedure to untyped lambda-calculus accomplishing the
@@ -130,6 +146,12 @@ The extracted safe erasure is available in Coq through a new vernacular command:
After importing `MetaCoq.Erasure.Loader`.
+The erasure pipeline includes verified optimizations to remove lets in constructors,
+remove cases on propositional terms, switch to an unguarded fixpoint reduction rule and
+transform the higher-order constructor applications to first-order blocks for easier
+translation to usual programming languages. See the erasure
+[README](https://github.com/MetaCoq/metacoq/tree/coq-8.16/erasure/theories/README.md) for
+a detailed view of the development.
### [Translations](https://github.com/MetaCoq/metacoq/tree/coq-8.13/translations)
@@ -137,7 +159,7 @@ Examples of translations built on top of this:
- a parametricity plugin in [translations/param_original.v](https://github.com/MetaCoq/metacoq/tree/coq-8.13/translations/param_original.v)
-- a plugin to negate funext in [translations/times_bool_fun.v](https://github.com/MetaCoq/metacoq/tree/coq-8.13/translations/times_bool_fun.v)
+- a plugin to negate functional extensionality in [translations/times_bool_fun.v](https://github.com/MetaCoq/metacoq/tree/coq-8.16/translations/times_bool_fun.v)
### Examples
@@ -145,16 +167,28 @@ Examples of translations built on top of this:
- An example Coq plugin built on the Template Monad, which can be used to
add a constructor to any inductive type is in [examples/add_constructor.v](https://github.com/MetaCoq/metacoq/tree/coq-8.13/examples/add_constructor.v)
-- The test-suite files [test-suite/erasure_test.v](https://github.com/MetaCoq/metacoq/tree/coq-8.13/test-suite/erasure_test.v)
- and [test-suite/safechecker_test.v](https://github.com/MetaCoq/metacoq/tree/coq-8.13/test-suite/safechecker_test.v) show example
+- An example *extracted* Coq plugin built on the extractable Template Monad, which can be used to
+ derive lenses associated to a record type is in [test-suite/plugin-demo](https://github.com/MetaCoq/metacoq/tree/coq-8.16/test-suite/plugin-demo). The plugin runs in OCaml and is a template for writing extracted plugins.
+
+- The test-suite files [test-suite/erasure_test.v](https://github.com/MetaCoq/metacoq/tree/coq-8.16/test-suite/erasure_test.v)
+ and [test-suite/safechecker_test.v](https://github.com/MetaCoq/metacoq/tree/coq-8.16/test-suite/safechecker_test.v) show example
uses (and current limitations of) the verified checker and erasure.
## Papers
+- ["The Curious Case of Case"](https://sozeau.gitlabpages.inria.fr/www/research/publications/The_Curious_Case_of_Case-WITS22-220122.pdf) Matthieu Sozeau, Meven Lennon-Bertrand and Yannick Forster. WITS 2022 presentation, Philadelphia.
+ This presents the challenges around the representation of cases in Coq and PCUIC.
+
+- ["Bidirectional Typing for the Calculus of Inductive Constructions"](https://www.meven.ac/category/phd-thesis.html) Meven Lennon-Bertrand, PhD thesis, June 2022.
+ Part 2 describes in detail the bidirectional variant of typing and its use to verify correctness and completeness of the type checker.
+
- ["Coq Coq Correct! Verification of Type Checking and Erasure for Coq, in Coq"](https://metacoq.github.io/coqcoqcorrect)
Matthieu Sozeau, Simon Boulier, Yannick Forster, Nicolas Tabareau
and Théo Winterhalter. POPL 2020, New Orleans.
+- ["Formalisation and meta-theory of type theory"](https://theowinterhalter.github.io/#phd) Théo Winterhalter, PhD thesis, September 2020.
+ Part 3 describes in detail the verified reduction, conversion and type checker.
+
- ["Coq Coq Codet! Towards a Verified Toolchain for Coq in
MetaCoq"](http://www.irif.fr/~sozeau/research/publications/Coq_Coq_Codet-CoqWS19.pdf)
Matthieu Sozeau, Simon Boulier, Yannick Forster, Nicolas Tabareau and
@@ -182,8 +216,6 @@ Examples of translations built on top of this:
- The system was presented at [Coq'PL 2018](https://popl18.sigplan.org/event/coqpl-2018-typed-template-coq)
-
-
## Team & Credits
@@ -203,17 +235,25 @@ alt="Cyril Cohen" width="150px"/>
src="https://github.com/MetaCoq/metacoq.github.io/raw/master/assets/yannick-forster.jpg"
alt="Yannick Forster" width="150px"/>
+
+alt="Gregory Malecha" width="150px"/>
+
+alt="Matthieu Sozeau" width="150px"/>
+
+
MetaCoq is developed by (left to right)
Abhishek Anand,
@@ -221,7 +261,9 @@ MetaCoq is developed by (left to right)
Simon Boulier,
Cyril Cohen,
Yannick Forster,
+Meven Lennon-Bertrand,
Gregory Malecha,
+Jakob Botsch Nielsen,
Matthieu Sozeau,
Nicolas Tabareau and
Théo Winterhalter.
@@ -229,10 +271,11 @@ MetaCoq is developed by (left to right)
```
-Copyright (c) 2014-2020 Gregory Malecha
-Copyright (c) 2015-2020 Abhishek Anand, Matthieu Sozeau
-Copyright (c) 2017-2020 Simon Boulier, Nicolas Tabareau, Cyril Cohen
-Copyright (c) 2018-2020 Danil Annenkov, Yannick Forster, Théo Winterhalter
+Copyright (c) 2014-2022 Gregory Malecha
+Copyright (c) 2015-2022 Abhishek Anand, Matthieu Sozeau
+Copyright (c) 2017-2022 Simon Boulier, Nicolas Tabareau, Cyril Cohen
+Copyright (c) 2018-2022 Danil Annenkov, Yannick Forster, Théo Winterhalter
+Copyright (c) 2020-2022 Jakob Botsch Nielsen, Meven Lennon-Bertrand
```
This software is distributed under the terms of the MIT license.
diff --git a/erasure/_CoqProject.in b/erasure/_CoqProject.in
index 617a15e08..37d9b3020 100644
--- a/erasure/_CoqProject.in
+++ b/erasure/_CoqProject.in
@@ -10,7 +10,6 @@ theories/EPretty.v
theories/ECSubst.v
theories/EWcbvEval.v
# theories/EWtAst.v
-theories/EWndEval.v
theories/EGlobalEnv.v
theories/EWellformed.v
theories/EEnvMap.v
@@ -18,7 +17,6 @@ theories/EWcbvEvalInd.v
theories/EWcbvEvalEtaInd.v
theories/Extract.v
theories/EDeps.v
-theories/EAll.v
theories/Extraction.v
theories/Prelim.v
theories/ESubstitution.v
diff --git a/erasure/theories/EAll.v b/erasure/theories/EAll.v
deleted file mode 100644
index 06e48834b..000000000
--- a/erasure/theories/EAll.v
+++ /dev/null
@@ -1,3 +0,0 @@
-(* Distributed under the terms of the MIT license. *)
-From MetaCoq.Erasure Require Export EAst EInduction ELiftSubst EGlobalEnv EWcbvEval
- EWndEval Extract.
diff --git a/erasure/theories/ECoFixToFix.v b/erasure/theories/ECoFixToFix.v
deleted file mode 100644
index 401644e9b..000000000
--- a/erasure/theories/ECoFixToFix.v
+++ /dev/null
@@ -1,23 +0,0 @@
-(* Distributed under the terms of the MIT license. *)
-From Coq Require Import Program.
-From MetaCoq.Template Require Import config utils.
-From MetaCoq.PCUIC Require PCUICWcbvEval.
-From MetaCoq.Erasure Require Import EAst EAstUtils ELiftSubst ECSubst EReflect EGlobalEnv.
-
-From Equations Require Import Equations.
-Require Import ssreflect ssrbool.
-
-(** * Weak-head call-by-value evaluation strategy.
-
- The [wcbveval] inductive relation specifies weak cbv evaluation. It
- is shown to be a subrelation of the 1-step reduction relation from
- which conversion is defined. Hence two terms that reduce to the same
- wcbv head normal form are convertible.
-
- This reduction strategy is supposed to mimick at the Coq level the
- reduction strategy of ML programming languages. It is used to state
- the extraction conjecture that can be applied to Coq terms to produce
- (untyped) terms where all proofs are erased to a dummy value. *)
-
-
-Local Ltac inv H := inversion H; subst.
diff --git a/erasure/theories/EWndEval.v b/erasure/theories/EWndEval.v
deleted file mode 100644
index ce6779e55..000000000
--- a/erasure/theories/EWndEval.v
+++ /dev/null
@@ -1,67 +0,0 @@
-(* Distributed under the terms of the MIT license. *)
-From MetaCoq.Erasure Require Import EAst ELiftSubst EGlobalEnv.
-
-(** * 1-step non-deterministic weak reduction **)
-
-
-Section Wnd.
- Context (Σ : global_declarations).
- (* The local context is fixed: we are only doing weak reductions *)
-
-Inductive Wnd : term -> term -> Prop :=
- (*** contraction steps ***)
-(** Constant unfolding *)
-| wConst c decl body (isdecl: declared_constant Σ c decl):
- decl.(cst_body) = Some body -> Wnd (tConst c) body
-(** Beta *)
-| wBeta na a b: Wnd (tApp (tLambda na b) a) (subst10 a b)
-(** Let *)
-| wLet na b0 b1: Wnd (tLetIn na b0 b1) (subst10 b0 b1).
-
-
-
-End Wnd.
-
-(********************************
-| sConst: forall (s:string) (t:Term),
- LookupDfn s p t -> wndEval (TConst s) t
-| sBeta: forall (nm:name) (bod arg:Term),
- wndEval (TApp (TLambda nm bod) arg) (whBetaStep bod arg)
-(* note: [instantiate] is total *)
-| sLetIn: forall (nm:name) (dfn bod:Term),
- wndEval (TLetIn nm dfn bod) (instantiate dfn 0 bod)
-(* Case argument must be in Canonical form *)
-(* n is the number of parameters of the datatype *)
-| sCase: forall (ml:inductive * nat) (s mch:Term)
- (args ts:Terms) (brs:Brs) (n npars nargs:nat),
- canonicalP mch = Some (n, npars, nargs, args) ->
- tskipn (snd ml) args = Some ts ->
- whCaseStep n ts brs = Some s ->
- wndEval (TCase ml mch brs) s
-| sFix: forall (dts:Defs) (m:nat) (arg:Term) (x:Term) (ix:nat),
- (** ix is index of recursive argument **)
- dnthBody m dts = Some (x, ix) ->
- wndEval (TApp (TFix dts m) arg) (pre_whFixStep x dts arg)
-| sProofApp arg: wndEval (TApp TProof arg) TProof
-| sProj: forall bod r npars nargs args arg x ind,
- canonicalP bod = Some (r, npars, nargs, args) ->
- List.nth_error args (npars + arg) = Some x ->
- wndEval (TProj (ind, npars, arg) bod) x
-(*** congruence steps ***)
-(** no xi rules: sLambdaR, sLetInR,
- *** no congruence on Case branches ***)
-| sAppFn: forall (t r arg:Term),
- wndEval t r -> wndEval (TApp t arg) (TApp r arg)
-| sAppArg: forall (t arg brg:Term),
- wndEval arg brg -> wndEval (TApp t arg) (TApp t brg)
-| sLetInDef:forall (nm:name) (d1 d2 bod:Term),
- wndEval d1 d2 -> wndEval (TLetIn nm d1 bod) (TLetIn nm d2 bod)
-| sCaseArg: forall (nl:inductive * nat) (mch can:Term) (brs:Brs),
- wndEval mch can -> wndEval (TCase nl mch brs) (TCase nl can brs)
-| sProjBod: forall prj bod Bod,
- wndEval bod Bod -> wndEval (TProj prj bod) (TProj prj Bod).
-#[global]
-Hint Constructors wndEval.
-
-
-**********************)
diff --git a/erasure/theories/README.md b/erasure/theories/README.md
new file mode 100644
index 000000000..4f3e77ec2
--- /dev/null
+++ b/erasure/theories/README.md
@@ -0,0 +1,79 @@
+# Erasure
+
+Implementation of a verified extraction pipeline from PCUIC to untyped lambda calculus
+extended with a box construct for erased terms.
+
+
+| File | Description |
+|-----------------------|------------------------------------------------------|
+| [Prelim] | Preliminaries on PCUIC
+| [EArities] | Meta-theoretic lemmas on PCUIC needed for erasure correctness
+| [EAst] | AST of λ-box terms
+| [EAstUtils] | Utility definitions and lemmas on the AST
+| [ELiftSubst] | Lifting and substitution for λ-box terms
+| [ECSubst] | Definition of closed substitution (without lifting)
+| [EReflect] | Reflection of equality on the AST
+| [ESpineView] | Spine-view of λ-box terms (i.e., n-ary applications)
+| [EDeps] | Definitions of λ-box term dependencies (used to optimize erasure)
+| [EEnvMap] | Efficient global environment definition
+| [EGlobalEnv] | Global environment interface
+| [EEtaExpanded] | Eta-expansion predicates on λ-box terms, only for constructors
+| [EEtaExpandedFix] | Eta-expansion predicates on λ-box terms, for constructors and fixpoints
+| [EInduction] | Induction principles on λ-box terms
+| [EExtends] | Weakening of global environments
+| [EPretty] | Pretty-printing of λ-box programs
+| [EProgram] | Definition of well-formed λ-box programs and associated evaluation
+| [EWcbvEval] | Weak call-by-value evaluation definition
+| [EWcbvEvalEtaInd] | Induction principle on weak call-by-value evaluation preserving eta-expansion
+| [EWcbvEvalInd] | Induction principle on weak call-by-value evaluation
+| [EWellformed] | Well-formedness predicate on erased terms
+| [Erasure] | The erasure relation
+| [ESubstitution] | Substitution and weakening lemmas for the erasure relation
+| [ErasureCorrectness] | The erasure relation correctness proof
+| [ErasureProperties] | Properties of the erasure relation
+| [ErasureFunction] | The erasure function defined on well-typed terms and its correctness proof
+| [EInlineProjections] | Transformation that inlines projections to cases
+| [EOptimizePropDiscr] | Transformation removing cases on propositional content
+| [ERemoveParams] | Remove constructor parameters
+| [ETransform] | Definitions of transformations from PCUIC to λ-box
+| [Extract] | The complete erasure pipeline
+| [Extraction] | Extraction directives for the plugin
+| [Loader] | Loads the erasure plugin
+
+[EAll]: EAll.v
+[EArities]: EArities.v
+[EAst]: EAst.v
+[EAstUtils]: EAstUtils.v
+[ECSubst]: ECSubst.v
+[ECoFixToFix]: ECoFixToFix.v
+[EDeps]: EDeps.v
+[EEnvMap]: EEnvMap.v
+[EEtaExpanded]: EEtaExpanded.v
+[EEtaExpandedFix]: EEtaExpandedFix.v
+[EExtends]: EExtends.v
+[EGlobalEnv]: EGlobalEnv.v
+[EInduction]: EInduction.v
+[EInlineProjections]: EInlineProjections.v
+[ELiftSubst]: ELiftSubst.v
+[EOptimizePropDiscr]: EOptimizePropDiscr.v
+[EPretty]: EPretty.v
+[EProgram]: EProgram.v
+[EReflect]: EReflect.v
+[ERemoveParams]: ERemoveParams.v
+[ESpineView]: ESpineView.v
+[ESubstitution]: ESubstitution.v
+[ETransform]: ETransform.v
+[EWcbvEval]: EWcbvEval.v
+[EWcbvEvalEtaInd]: EWcbvEvalEtaInd.v
+[EWcbvEvalInd]: EWcbvEvalInd.v
+[EWellformed]: EWellformed.v
+[EWndEval]: EWndEval.v
+[EWtAst]: EWtAst.v
+[Erasure]: Erasure.v
+[ErasureCorrectness]: ErasureCorrectness.v
+[ErasureFunction]: ErasureFunction.v
+[ErasureProperties]: ErasureProperties.v
+[Extract]: Extract.v
+[Extraction]: Extraction.v
+[Loader]: Loader.v
+[Prelim]: Prelim.v
\ No newline at end of file
diff --git a/template-coq/theories/TemplateCheckWf.v b/template-coq/theories/TemplateCheckWf.v
index 6ed3e103d..2b31d1719 100644
--- a/template-coq/theories/TemplateCheckWf.v
+++ b/template-coq/theories/TemplateCheckWf.v
@@ -13,8 +13,6 @@ Axiom assume_welltypedness_of_input : forall p, ∥ wt_template_program p ∥.
Definition eta_expand p :=
run_eta_program p (assume_welltypedness_of_input p).
-Compute (Transform.pre template_eta_expand _).
-
Definition check_def (d : kername × global_decl) : TemplateMonad unit :=
match d.2 with
| ConstantDecl cb =>
From a247fa62b9758e9c58d5bf00b603e8f1ae1feede Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Mon, 27 Jun 2022 15:22:43 +0200
Subject: [PATCH 08/43] Fix README
---
erasure/theories/README.md | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/erasure/theories/README.md b/erasure/theories/README.md
index 4f3e77ec2..554d351d3 100644
--- a/erasure/theories/README.md
+++ b/erasure/theories/README.md
@@ -27,7 +27,7 @@ extended with a box construct for erased terms.
| [EWcbvEvalEtaInd] | Induction principle on weak call-by-value evaluation preserving eta-expansion
| [EWcbvEvalInd] | Induction principle on weak call-by-value evaluation
| [EWellformed] | Well-formedness predicate on erased terms
-| [Erasure] | The erasure relation
+| [Extract] | The erasure relation
| [ESubstitution] | Substitution and weakening lemmas for the erasure relation
| [ErasureCorrectness] | The erasure relation correctness proof
| [ErasureProperties] | Properties of the erasure relation
@@ -36,7 +36,7 @@ extended with a box construct for erased terms.
| [EOptimizePropDiscr] | Transformation removing cases on propositional content
| [ERemoveParams] | Remove constructor parameters
| [ETransform] | Definitions of transformations from PCUIC to λ-box
-| [Extract] | The complete erasure pipeline
+| [Erasure] | The complete erasure pipeline
| [Extraction] | Extraction directives for the plugin
| [Loader] | Loads the erasure plugin
From f8510b013f694eeea6d2a20b4474cdf31f05e8bc Mon Sep 17 00:00:00 2001
From: Yannick Forster
Date: Tue, 28 Jun 2022 13:54:38 +0200
Subject: [PATCH 09/43] Remove warnings (#720)
* remove warnings
* remove warnings and remove axion on eta expansion
* fix build.yml
* fix build.yml
* fix compilation
* use bash for checktodos.sh
* always run CI even if there are todos
* improve output
* Set Warnings
* separate todo job
---
.github/workflows/build.yml | 11 ++++
checktodos.sh | 4 +-
erasure/_PluginProject.in | 6 +++
erasure/src/metacoq_erasure_plugin.mlpack | 3 ++
erasure/theories/EWcbvEvalEtaInd.v | 2 +
erasure/theories/EWellformed.v | 8 +--
erasure/theories/Erasure.v | 41 +++++++++++----
pcuic/theories/PCUICProgress.v | 2 +-
safechecker/_PluginProject.in | 2 +
.../src/metacoq_safechecker_plugin.mlpack | 1 +
safechecker/theories/PCUICSafeConversion.v | 7 +--
template-coq/_PluginProject | 6 ---
template-coq/theories/EtaExpand.v | 8 +--
template-coq/theories/TemplateCheckWf.v | 5 +-
template-coq/theories/TemplateProgram.v | 51 -------------------
template-coq/theories/common/uGraph.v | 6 +--
test-suite/hott_example.v | 2 +-
test-suite/safechecker_test.v | 1 +
translations/MiniHoTT.v | 14 +++--
translations/MiniHoTT_paths.v | 10 ++--
translations/param_binary.v | 2 +
translations/param_generous_packed.v | 1 +
translations/standard_model.v | 2 +-
translations/times_bool_fun.v | 7 ++-
translations/times_bool_fun2.v | 2 +
25 files changed, 107 insertions(+), 97 deletions(-)
diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml
index 7b751b9cb..769d2b2c6 100644
--- a/.github/workflows/build.yml
+++ b/.github/workflows/build.yml
@@ -3,6 +3,17 @@ name: MetaCoq CI
on: [push, pull_request]
jobs:
+ checktodos:
+ runs-on: ubuntu-latest
+ steps:
+ - name: Checkout code
+ uses: actions/checkout@v2
+ with:
+ fetch-depth: 1
+
+ - name: Check for todos
+ run: ./checktodos.sh
+
build:
runs-on: ubuntu-latest
diff --git a/checktodos.sh b/checktodos.sh
index 25b2476f3..f4eef771e 100755
--- a/checktodos.sh
+++ b/checktodos.sh
@@ -1,4 +1,4 @@
-#!/bin/sh
+#!/bin/bash
if [[ $(git grep -c todo | grep theories) = template-coq/theories/utils/MCUtils.v:3 ]]
then
@@ -14,7 +14,7 @@ then
fi
else
echo "Found todos:"
- git grep -c todo | grep theories
+ git grep -c todo | grep theories | grep -v "template-coq/theories/utils/MCUtils.v:3"
exit 1
fi
endef
diff --git a/erasure/_PluginProject.in b/erasure/_PluginProject.in
index aa47c2482..9909b2e98 100644
--- a/erasure/_PluginProject.in
+++ b/erasure/_PluginProject.in
@@ -18,6 +18,12 @@ src/wGraph.ml
src/wGraph.mli
src/envMap.mli
src/envMap.ml
+src/mCProd.mli
+src/mCProd.ml
+src/transform.mli
+src/transform.ml
+src/etaExpand.mli
+src/etaExpand.ml
# src/reflect.mli
# src/reflect.ml
diff --git a/erasure/src/metacoq_erasure_plugin.mlpack b/erasure/src/metacoq_erasure_plugin.mlpack
index 520b59552..66c282909 100644
--- a/erasure/src/metacoq_erasure_plugin.mlpack
+++ b/erasure/src/metacoq_erasure_plugin.mlpack
@@ -7,6 +7,9 @@ Utils
WGraph
UGraph0
EnvMap
+MCProd
+Transform
+EtaExpand
WcbvEval
Classes0
diff --git a/erasure/theories/EWcbvEvalEtaInd.v b/erasure/theories/EWcbvEvalEtaInd.v
index 7cbf6e778..2c3ae7d7b 100644
--- a/erasure/theories/EWcbvEvalEtaInd.v
+++ b/erasure/theories/EWcbvEvalEtaInd.v
@@ -130,6 +130,7 @@ Class Qconst Σ (Q : nat -> term -> Type) := qconst :
end.
#[export] Hint Mode Qconst - ! : typeclass_instances.
+Set Warnings "-future-coercion-class-field".
Class Qpreserves {etfl : ETermFlags} (Q : nat -> term -> Type) Σ :=
{ qpres_qpres :> Qpres Q;
qpres_qcons :> Qconst Σ Q;
@@ -139,6 +140,7 @@ Class Qpreserves {etfl : ETermFlags} (Q : nat -> term -> Type) Σ :=
qpres_qsubst :> Qsubst Q;
qpres_qfix :> Qfix Q;
qpres_qcofix :> Qcofix Q }.
+Set Warnings "+future-coercion-class-field".
Lemma eval_preserve_mkApps_ind :
∀ (wfl : WcbvFlags) {efl : EEnvFlags} (Σ : global_declarations)
diff --git a/erasure/theories/EWellformed.v b/erasure/theories/EWellformed.v
index 27828e501..68412ffc1 100644
--- a/erasure/theories/EWellformed.v
+++ b/erasure/theories/EWellformed.v
@@ -35,11 +35,13 @@ Class ETermFlags :=
; has_tCoFix : bool
}.
+Set Warnings "-future-coercion-class-field".
Class EEnvFlags := {
has_axioms : bool;
has_cstr_params : bool;
term_switches :> ETermFlags }.
-
+Set Warnings "+future-coercion-class-field".
+
Definition all_term_flags :=
{| has_tBox := true
; has_tRel := true
@@ -281,7 +283,7 @@ Section EEnvFlags.
forallb (wellformed 0) (fix_subst mfix).
Proof using Type.
intros hm. unfold fix_subst.
- generalize (le_refl #|mfix|).
+ generalize (Nat.le_refl #|mfix|).
move: {1 3}#|mfix| => n.
induction n => //.
intros hn. cbn. rewrite hast /=. rewrite /wf_fix_gen hm /= andb_true_r.
@@ -293,7 +295,7 @@ Section EEnvFlags.
forallb (wellformed 0) (cofix_subst mfix).
Proof using Type.
intros hm. unfold cofix_subst.
- generalize (le_refl #|mfix|).
+ generalize (Nat.le_refl #|mfix|).
move: {1 3}#|mfix| => n.
induction n => //.
intros hn. cbn. rewrite hasco /=. rewrite /wf_fix_gen hm /= andb_true_r.
diff --git a/erasure/theories/Erasure.v b/erasure/theories/Erasure.v
index f3f570c61..3288adb96 100644
--- a/erasure/theories/Erasure.v
+++ b/erasure/theories/Erasure.v
@@ -1,13 +1,12 @@
(* Distributed under the terms of the MIT license. *)
From Coq Require Import Program ssreflect ssrbool.
-From MetaCoq.Template Require Import Transform bytestring config utils.
+From MetaCoq.Template Require Import Transform bytestring config utils EtaExpand.
From MetaCoq.PCUIC Require PCUICAst PCUICAstUtils PCUICProgram.
From MetaCoq.SafeChecker Require Import PCUICErrors PCUICWfEnvImpl.
From MetaCoq.Erasure Require EAstUtils ErasureFunction ErasureCorrectness EPretty Extract.
From MetaCoq.Erasure Require Import ETransform.
Import PCUICProgram.
-Import TemplateProgram (template_eta_expand).
Import PCUICTransform (template_to_pcuic_transform, pcuic_expand_lets_transform).
Import bytestring.
@@ -32,8 +31,6 @@ Program Definition erasure_pipeline {guard : abstract_guard_impl} (efl := EWellf
Ast.term EAst.term
TemplateProgram.eval_template_program
(EProgram.eval_eprogram {| with_prop_case := false; with_guarded_fix := false |}) :=
- (* Eta expansion of constructors and fixpoints *)
- template_eta_expand ▷
(* Casts are removed, application is binary, case annotations are inferred from the global environment *)
template_to_pcuic_transform ▷
(* Branches of cases are expanded to bind only variables, constructor types are expanded accordingly *)
@@ -92,7 +89,6 @@ Qed.
Definition run_erase_program {guard : abstract_guard_impl} := run erasure_pipeline.
Program Definition erasure_pipeline_fast {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) :=
- template_eta_expand ▷
template_to_pcuic_transform ▷
pcuic_expand_lets_transform ▷
erase_transform ▷
@@ -126,14 +122,41 @@ Next Obligation. apply fake_guard_impl_properties. Qed.
Coq definition). *)
-Axiom assume_that_we_only_erase_on_welltyped_programs :
+Axiom assume_that_we_only_erase_on_welltyped_programs : forall {cf : checker_flags},
forall (p : Ast.Env.program), squash (TemplateProgram.wt_template_program p).
-Definition erase_and_print_template_program {cf : checker_flags} (p : Ast.Env.program)
+
+Program Definition erase_and_print_template_program {cf : checker_flags} (p : Ast.Env.program)
: string :=
- let p' := run_erase_program p (assume_that_we_only_erase_on_welltyped_programs p) in
+ let p' := run_erase_program (eta_expand_program p) _ in
time "Pretty printing" EPretty.print_program p'.
+Next Obligation.
+ assert (ht : ∥ TemplateProgram.wt_template_program p ∥) by eapply assume_that_we_only_erase_on_welltyped_programs.
+ split; auto.
+ apply assume_that_we_only_erase_on_welltyped_programs.
+ red.
+ destruct ht as [[wfext [T ht]]].
+ split; cbn. eapply EtaExpand.eta_expand_global_env_expanded. eapply wfext.
+ eapply EtaExpand.expanded_env_irrel.
+ epose proof (EtaExpand.eta_expand_expanded (Σ := Ast.Env.empty_ext p.1) [] [] p.2 T).
+ forward H. apply wfext. specialize (H ht).
+ forward H by constructor. cbn in H.
+ destruct p as [ [] ]; cbn in *. exact H.
+Qed.
Program Definition erase_fast_and_print_template_program {cf : checker_flags} (p : Ast.Env.program)
: string :=
- let p' := run_erase_program_fast p (assume_that_we_only_erase_on_welltyped_programs p) in
+ let p' := run_erase_program_fast (eta_expand_program p) _ in
time "pretty-printing" EPretty.print_program p'.
+Next Obligation.
+ assert (ht : ∥ TemplateProgram.wt_template_program p ∥) by eapply assume_that_we_only_erase_on_welltyped_programs.
+ split; auto.
+ apply assume_that_we_only_erase_on_welltyped_programs.
+ red.
+ destruct ht as [[wfext [T ht]]].
+ split; cbn. eapply EtaExpand.eta_expand_global_env_expanded. eapply wfext.
+ eapply EtaExpand.expanded_env_irrel.
+ epose proof (EtaExpand.eta_expand_expanded (Σ := Ast.Env.empty_ext p.1) [] [] p.2 T).
+ forward H. apply wfext. specialize (H ht).
+ forward H by constructor. cbn in H.
+ destruct p as [ [] ]; cbn in *. exact H.
+Qed.
\ No newline at end of file
diff --git a/pcuic/theories/PCUICProgress.v b/pcuic/theories/PCUICProgress.v
index 0393eef9c..6ac0f0e48 100644
--- a/pcuic/theories/PCUICProgress.v
+++ b/pcuic/theories/PCUICProgress.v
@@ -735,7 +735,7 @@ Proof.
1,2: now rewrite closed_subst; eauto; econstructor; eauto.
- now rewrite e0 /cstr_arity -e1 -e2.
- rewrite !tApp_mkApps -!mkApps_app. econstructor. eauto.
- unfold is_constructor. now rewrite nth_error_app2 // minus_diag.
+ unfold is_constructor. now rewrite nth_error_app2 // Nat.sub_diag.
- unfold cunfold_cofix in e. destruct nth_error as [d | ] eqn:E; try congruence.
inversion e; subst.
econstructor. unfold unfold_cofix. rewrite E. repeat f_equal.
diff --git a/safechecker/_PluginProject.in b/safechecker/_PluginProject.in
index 788756c48..fa2d6a61a 100644
--- a/safechecker/_PluginProject.in
+++ b/safechecker/_PluginProject.in
@@ -16,6 +16,8 @@ src/wGraph.ml
src/wGraph.mli
src/envMap.mli
src/envMap.ml
+src/mCProd.mli
+src/mCProd.ml
# From PCUIC
# src/pCUICPrimitive.mli
diff --git a/safechecker/src/metacoq_safechecker_plugin.mlpack b/safechecker/src/metacoq_safechecker_plugin.mlpack
index 1c0e60a37..50582b0b6 100644
--- a/safechecker/src/metacoq_safechecker_plugin.mlpack
+++ b/safechecker/src/metacoq_safechecker_plugin.mlpack
@@ -5,6 +5,7 @@ WGraph
UGraph0
EnvMap
Reflect
+MCProd
Classes0
Logic1
diff --git a/safechecker/theories/PCUICSafeConversion.v b/safechecker/theories/PCUICSafeConversion.v
index 8fb8f19d1..77c871f31 100644
--- a/safechecker/theories/PCUICSafeConversion.v
+++ b/safechecker/theories/PCUICSafeConversion.v
@@ -213,8 +213,7 @@ Section Conversion.
Defined.
Derive Signature for Subterm.lexprod.
- Derive Signature for dlexmod.
-
+
Lemma R_aux_Acc :
forall Γ t p w q s,
(forall Σ, abstract_env_ext_rel X Σ -> welltyped Σ Γ t) ->
@@ -5710,7 +5709,9 @@ Qed.
_isconv Fallback Γ t1 π1 h1 t2 π2 h2 aux :=
λ { | leq | hx | r1 | r2 | hd := _isconv_fallback Γ leq t1 π1 h1 t2 π2 h2 r1 r2 hd hx aux }.
-
+
+ Derive Signature for dlexmod.
+
Lemma welltyped_R_zipc Σ (wfΣ : abstract_env_ext_rel X Σ) Γ :
forall x y : pack Γ, welltyped Σ Γ (zipc (tm1 x) (stk1 x)) -> R Γ y x -> welltyped Σ Γ (zipc (tm1 y) (stk1 y)).
Proof using Type.
diff --git a/template-coq/_PluginProject b/template-coq/_PluginProject
index e49dae931..e0b2967b6 100644
--- a/template-coq/_PluginProject
+++ b/template-coq/_PluginProject
@@ -110,8 +110,6 @@ gen-src/mCList.ml
gen-src/mCList.mli
gen-src/mCOption.ml
gen-src/mCOption.mli
-gen-src/mCProd.ml
-gen-src/mCProd.mli
gen-src/mCRelations.ml
gen-src/mCRelations.mli
gen-src/mCReflect.mli
@@ -205,10 +203,6 @@ gen-src/termEquality.mli
gen-src/termEquality.ml
gen-src/typing0.mli
gen-src/typing0.ml
-gen-src/transform.mli
-gen-src/transform.ml
-gen-src/etaExpand.mli
-gen-src/etaExpand.ml
gen-src/templateProgram.mli
gen-src/templateProgram.ml
diff --git a/template-coq/theories/EtaExpand.v b/template-coq/theories/EtaExpand.v
index 04a77ca1c..e4267fb2c 100644
--- a/template-coq/theories/EtaExpand.v
+++ b/template-coq/theories/EtaExpand.v
@@ -781,9 +781,9 @@ Proof.
2:{ replace (S n0 - #|l|) with 0 by lia. cbn. econstructor. }
rewrite EE in H4.
rewrite seq_app, rev_map_spec, map_app, rev_app_distr in H4.
- eapply Forall_app in H4 as []. rewrite Min.min_l. 2: len; lia.
+ eapply Forall_app in H4 as []. rewrite Nat.min_l. 2: len; lia.
rewrite <- EE in H0.
- revert H0. len. rewrite !firstn_length, Min.min_l. 2:len;lia.
+ revert H0. len. rewrite !firstn_length, Nat.min_l. 2:len;lia.
rewrite rev_map_spec. intros.
rewrite Forall_forall in H0 |- *. intros.
specialize (H0 _ H1). rewrite <- in_rev in H1.
@@ -949,7 +949,7 @@ Proof.
destruct n0.
* cbn. econstructor. now rewrite nth_error_map, H1.
* rewrite seq_S,rev_map_spec, map_app, rev_app_distr. subst.
- rewrite <- context_assumptions_lift, !Min.min_l; try lia.
+ rewrite <- context_assumptions_lift, !Nat.min_l; try lia.
econstructor.
-- rewrite nth_error_app2. 2: rewrite repeat_length; lia.
rewrite repeat_length. replace (S n0 + n - S n0) with n by lia.
@@ -1128,7 +1128,7 @@ Proof.
assert (#| (case_branch_context_gen (ci_ind ci) mdecl (pparams p)
(puinst p) (bcontext y) x)| = #|bcontext y|). { clear - a0.
unfold case_branch_context_gen. rewrite map2_length.
- rewrite Min.min_l; try lia. eapply All2_length in a0.
+ rewrite Nat.min_l; try lia. eapply All2_length in a0.
unfold inst_case_context. unfold subst_context.
unfold subst_instance, subst_instance_context, map_context.
rewrite fold_context_k_length, map_length. unfold aname. lia.
diff --git a/template-coq/theories/TemplateCheckWf.v b/template-coq/theories/TemplateCheckWf.v
index 2b31d1719..8bb7798b4 100644
--- a/template-coq/theories/TemplateCheckWf.v
+++ b/template-coq/theories/TemplateCheckWf.v
@@ -7,11 +7,8 @@ Open Scope bs_scope.
#[local] Existing Instance config.default_checker_flags.
-Definition run_eta_program := Transform.run template_eta_expand.
-
-Axiom assume_welltypedness_of_input : forall p, ∥ wt_template_program p ∥.
Definition eta_expand p :=
- run_eta_program p (assume_welltypedness_of_input p).
+ EtaExpand.eta_expand_program p.
Definition check_def (d : kername × global_decl) : TemplateMonad unit :=
match d.2 with
diff --git a/template-coq/theories/TemplateProgram.v b/template-coq/theories/TemplateProgram.v
index 9a1d1aba6..ec0280282 100644
--- a/template-coq/theories/TemplateProgram.v
+++ b/template-coq/theories/TemplateProgram.v
@@ -24,54 +24,3 @@ Definition wt_template_program {cf : checker_flags} (p : template_program) :=
Definition eval_template_program (p : Ast.Env.program) (v : Ast.term) :=
∥ WcbvEval.eval p.1 p.2 v ∥.
-(* Eta-expansion *)
-
-Definition template_expand_obseq (p p' : template_program) (v v' : Ast.term) :=
- v' = EtaExpand.eta_expand p.1.(Ast.Env.declarations) [] v.
-
-Local Obligation Tactic := idtac.
-
-Axiom eta_expansion_preserves_wf_ext_and_typing :
- forall (cf : checker_flags)
- (Σ : global_env)
- (t : term)
- (wfext : wf_ext (empty_ext (Σ, t).1))
- (ht : ∑ T : term, empty_ext (Σ, t).1;;; [] |- (Σ, t).2 : T),
- ∥ wt_template_program (eta_expand_program (Σ, t)) ∥.
-
-Axiom eta_expansion_preserves_evaluation :
- forall (cf : checker_flags)
- (Σ : global_env)
- (t v : term)
- (w : wf_ext (empty_ext (Σ, t).1))
- (s : ∑ T : term, empty_ext (Σ, t).1;;; [] |- (Σ, t).2 : T)
- (ev : ∥ eval Σ t v ∥),
- ∥ eval (eta_expand_global_env Σ) (eta_expand (declarations Σ) [] t)
- (eta_expand (declarations Σ) [] v) ∥.
-
-Program Definition template_eta_expand {cf : checker_flags} : self_transform template_program Ast.term eval_template_program eval_template_program :=
- {| name := "eta-expansion of template program";
- pre p := ∥ wt_template_program p ∥;
- transform p _ := EtaExpand.eta_expand_program p;
- post p := ∥ wt_template_program p ∥ /\ EtaExpand.expanded_program p;
- obseq := template_expand_obseq |}.
-Next Obligation.
- intros cf [Σ t] [[wfext ht]].
- cbn. split. eapply eta_expansion_preserves_wf_ext_and_typing; eauto.
- red.
- destruct ht as [T ht].
- split; cbn. eapply EtaExpand.eta_expand_global_env_expanded. apply wfext.
- eapply EtaExpand.expanded_env_irrel.
- epose proof (EtaExpand.eta_expand_expanded (Σ := Ast.Env.empty_ext Σ) [] [] t T).
- forward H. apply wfext. specialize (H ht).
- forward H by constructor. cbn in H.
- destruct Σ; cbn in *. exact H.
-Qed.
-Next Obligation.
- red. intros cf [Σ t] v [[]].
- unfold eval_template_program.
- cbn. intros ev.
- exists (EtaExpand.eta_expand (Ast.Env.declarations Σ) [] v). split.
- eapply eta_expansion_preserves_evaluation; eauto.
- red. reflexivity.
-Qed.
diff --git a/template-coq/theories/common/uGraph.v b/template-coq/theories/common/uGraph.v
index 626c307f1..49326d738 100644
--- a/template-coq/theories/common/uGraph.v
+++ b/template-coq/theories/common/uGraph.v
@@ -2940,7 +2940,7 @@ Proof.
Qed.
-Instance subgraph_proper : Proper ((=_g) ==> (=_g) ==> iff) subgraph.
+#[global] Instance subgraph_proper : Proper ((=_g) ==> (=_g) ==> iff) subgraph.
Proof.
unshelve apply: proper_sym_impl_iff_2.
move=> g1 g1' [eqv1 [eqe1 eqs1]] g2 g2' [eqv2 [eqe2 eqs2]].
@@ -2950,7 +2950,7 @@ Proof.
+ by rewrite <- eqs1, <- eqs2.
Qed.
-Instance full_subgraph_proper : Proper ((=_g) ==> (=_g) ==> iff) full_subgraph.
+#[global] Instance full_subgraph_proper : Proper ((=_g) ==> (=_g) ==> iff) full_subgraph.
Proof.
unshelve apply: proper_sym_impl_iff_2.
move=> g1 g1' eq1 g2 g2' eq2.
@@ -2984,7 +2984,7 @@ Proof.
apply: make_graph_invariants.
Qed.
-Existing Instance correct_labelling_proper.
+#[export] Existing Instance correct_labelling_proper.
Lemma correct_labelling_of_valuation_satisfies_iff `{checker_flags} [uctx G v] :
is_graph_of_uctx G uctx ->
diff --git a/test-suite/hott_example.v b/test-suite/hott_example.v
index 90281a880..40a925025 100644
--- a/test-suite/hott_example.v
+++ b/test-suite/hott_example.v
@@ -1,4 +1,4 @@
-
+Set Warnings "-future-coercion-class-field".
Set Universe Polymorphism.
(* Basic notations *)
diff --git a/test-suite/safechecker_test.v b/test-suite/safechecker_test.v
index cb629545d..f6a893761 100644
--- a/test-suite/safechecker_test.v
+++ b/test-suite/safechecker_test.v
@@ -29,6 +29,7 @@ Definition bignat : nat := Nat.of_num_uint 10000%uint.
MetaCoq SafeCheck bignat.
MetaCoq CoqCheck bignat.
+Set Warnings "-notation-overriden".
From MetaCoq.TestSuite Require Import hott_example.
MetaCoq SafeCheck @issect'.
diff --git a/translations/MiniHoTT.v b/translations/MiniHoTT.v
index 5b4e2e874..b83923b0f 100644
--- a/translations/MiniHoTT.v
+++ b/translations/MiniHoTT.v
@@ -1,4 +1,4 @@
-
+Set Warnings "-notation-overridden".
Local Set Primitive Projections.
Record sigT {A} (P : A -> Type) : Type := existT
@@ -93,6 +93,11 @@ Ltac transitivity x := etransitivity x.
Notation idmap := (fun x => x).
+Declare Scope equiv_scope.
+Declare Scope path_scope.
+Declare Scope fibration_scope.
+Declare Scope trunc_scope.
+
Delimit Scope equiv_scope with equiv.
Delimit Scope function_scope with function.
Delimit Scope path_scope with path.
@@ -134,7 +139,7 @@ Notation "g 'o' f" := (compose g%function f%function) (at level 40, left associa
Definition composeD {A B C} (g : forall b, C b) (f : A -> B) := fun x : A => g (f x).
Global Arguments composeD {A B C}%type_scope (g f)%function_scope x.
#[global]
-Hint Unfold composeD.
+Hint Unfold composeD : core.
Notation "g 'oD' f" := (composeD g f) (at level 40, left associativity) : function_scope.
Notation "x = y :> A" := (paths A x y) : type_scope.
@@ -266,7 +271,7 @@ Arguments center A {_}.
Class Funext := { isequiv_apD10 : forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }.
-Existing Instance isequiv_apD10.
+Global Existing Instance isequiv_apD10.
Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A, P x) : f == g -> f = g
:= (@apD10 A P f g)^-1.
@@ -1312,6 +1317,7 @@ Hint Resolve
inv_pp inv_V
: path_hints.
+#[global]
Hint Rewrite
@concat_p1
@concat_1p
@@ -3038,7 +3044,7 @@ Definition equiv_path_sigma `(P : A -> Type) (u v : sigT P)
:= BuildEquiv _ _ (path_sigma_uncurried P u v) _.
(* A contravariant version of [isequiv_path_sigma'] *)
-Instance isequiv_path_sigma_contra `{P : A -> Type} {u v : sigT P}
+Global Instance isequiv_path_sigma_contra `{P : A -> Type} {u v : sigT P}
: IsEquiv (path_sigma_uncurried_contra P u v) | 0.
unshelve eapply (isequiv_adjointify (path_sigma_uncurried_contra P u v)).
- intros []. exists 1. reflexivity.
diff --git a/translations/MiniHoTT_paths.v b/translations/MiniHoTT_paths.v
index af9b3170f..242b49bd5 100644
--- a/translations/MiniHoTT_paths.v
+++ b/translations/MiniHoTT_paths.v
@@ -1,4 +1,4 @@
-
+Set Warnings "-notation-overridden".
Local Set Primitive Projections.
Record sigT {A} (P : A -> Type) : Type := existT
@@ -33,18 +33,17 @@ Defined.
(* *********************************************** *)
-
Arguments sigT {A}%type P%type.
Arguments existT {A}%type P%type _ _.
Arguments projT1 {A P} _ / .
Arguments projT2 {A P} _ / .
+
Notation "'exists' x .. y , p" := (sigT (fun x => .. (sigT (fun y => p)) ..))
(at level 200, x binder, right associativity,
format "'[' 'exists' '/ ' x .. y , '/ ' p ']'")
: type_scope.
Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope.
-
Definition relation (A : Type) := A -> A -> Type.
Class Reflexive {A} (R : relation A) :=
@@ -97,6 +96,11 @@ Ltac transitivity x := etransitivity x.
Notation idmap := (fun x => x).
+Declare Scope equiv_scope.
+Declare Scope path_scope.
+Declare Scope fibration_scope.
+Declare Scope trunc_scope.
+
Delimit Scope equiv_scope with equiv.
Delimit Scope function_scope with function.
Delimit Scope path_scope with path.
diff --git a/translations/param_binary.v b/translations/param_binary.v
index 08201be6d..6b251e565 100644
--- a/translations/param_binary.v
+++ b/translations/param_binary.v
@@ -199,6 +199,7 @@ Definition tsl_mind_body (E : tsl_table) (mp : modpath) (kn : kername)
Defined.
+#[global]
Instance param : Translation :=
{| tsl_id := tsl_ident ;
tsl_tm := fun ΣE t => ret (tsl_rec1 (snd ΣE) t) ;
@@ -217,6 +218,7 @@ MetaCoq Run (
tmUnquote tm' >>= tmDebug
).
+Set Warnings "-unexpected-implicit-declaration".
MetaCoq Run (
typ <- tmQuote (forall A B, B -> (A -> B -> B) -> B) ;;
typ' <- tmEval all (tsl_rec1 [] typ) ;;
diff --git a/translations/param_generous_packed.v b/translations/param_generous_packed.v
index 37d19a9c0..b540f2e41 100644
--- a/translations/param_generous_packed.v
+++ b/translations/param_generous_packed.v
@@ -1,4 +1,5 @@
(* Distributed under the terms of the MIT license. *)
+Set Warnings "-notation-overridden".
From MetaCoq.Template Require Import utils Checker All.
From MetaCoq.Translations Require Import translation_utils MiniHoTT_paths.
diff --git a/translations/standard_model.v b/translations/standard_model.v
index 13fbe8dfb..7641f3e37 100644
--- a/translations/standard_model.v
+++ b/translations/standard_model.v
@@ -89,7 +89,7 @@ with tsl_ctx (ΣE : tsl_context) (Γ : context) {struct Γ} : tsl_result term :=
end.
-
+#[global]
Instance param : Translation :=
{| tsl_id := tsl_ident ;
tsl_tm := fun ΣE => tsl ΣE [] ;
diff --git a/translations/times_bool_fun.v b/translations/times_bool_fun.v
index 74449f088..3f8164067 100644
--- a/translations/times_bool_fun.v
+++ b/translations/times_bool_fun.v
@@ -1,4 +1,6 @@
(* Distributed under the terms of the MIT license. *)
+Set Warnings "-notation-overridden".
+
From MetaCoq.Template Require Import utils All Checker.
From MetaCoq.Translations Require Import translation_utils MiniHoTT.
Import MCMonadNotation.
@@ -12,6 +14,7 @@ Arguments π1 {_ _} _.
Arguments π2 {_ _} _.
Arguments pair {_ _} _ _.
+Declare Scope prod_scope.
Notation "( x ; y )" := (pair x y) : prod_scope.
Notation " A × B " := (prod A B) : type_scope.
Open Scope prod_scope.
@@ -37,7 +40,7 @@ Definition pairTrue typ tm := tApp tpair [typ; tbool; tm; ttrue].
Local Instance tit : config.checker_flags := config.type_in_type.
-Existing Instance Checker.default_fuel.
+Local Existing Instance Checker.default_fuel.
Fixpoint tsl_rec (fuel : nat) (Σ : global_env_ext) (E : tsl_table) (Γ : context) (t : term) {struct fuel}
: tsl_result term :=
@@ -216,7 +219,7 @@ Fixpoint refresh_universes (t : term) {struct t} :=
| _ => t
end.
-Instance tsl_fun : Translation
+Global Instance tsl_fun : Translation
:= {| tsl_id := tsl_ident ;
tsl_tm := fun ΣE t => t' <- tsl_rec fuel (fst ΣE) (snd ΣE) [] t ;;
ret (refresh_universes t');
diff --git a/translations/times_bool_fun2.v b/translations/times_bool_fun2.v
index cdd8fce87..71678ef4b 100644
--- a/translations/times_bool_fun2.v
+++ b/translations/times_bool_fun2.v
@@ -1,4 +1,6 @@
(* Distributed under the terms of the MIT license. *)
+Set Warnings "-notation-overridden".
+
From MetaCoq.Template Require Import utils All.
Unset Universe Checking.
From MetaCoq.Translations Require Import translation_utils times_bool_fun MiniHoTT.
From 78b5df89974165230b6f744c754e6cef3c893901 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Thu, 30 Jun 2022 15:08:33 +0200
Subject: [PATCH 10/43] Constructor tactic example (#725)
---
examples/_CoqProject | 1 +
examples/constructor_tac.v | 43 ++++++++++++++++++++++++++++++++++++++
2 files changed, 44 insertions(+)
create mode 100644 examples/constructor_tac.v
diff --git a/examples/_CoqProject b/examples/_CoqProject
index c68a2627f..a4603b8bf 100644
--- a/examples/_CoqProject
+++ b/examples/_CoqProject
@@ -8,6 +8,7 @@
-R . MetaCoq.Examples
demo.v
+constructor_tac.v
add_constructor.v
tauto.v
typing_correctness.v
diff --git a/examples/constructor_tac.v b/examples/constructor_tac.v
new file mode 100644
index 000000000..31f58df31
--- /dev/null
+++ b/examples/constructor_tac.v
@@ -0,0 +1,43 @@
+From Coq Require Import List.
+From MetaCoq.Template Require Import All Loader.
+Import MCMonadNotation.
+Open Scope bs.
+
+Definition constructor (goal : Ast.term): TemplateMonad typed_term :=
+ let '(hd, iargs) := decompose_app goal in
+ match hd with
+ | Ast.tInd ind u =>
+ qi <- tmQuoteInductive (inductive_mind ind) ;;
+ match nth_error qi.(Ast.Env.ind_bodies) (inductive_ind ind) with
+ | Some oib =>
+ let cstrs := Ast.Env.ind_ctors oib in
+ match cstrs with
+ | [] => tmFail "no constructor in this inductive type"
+ | hd :: _ =>
+ let args := cstr_args hd in
+ let params := firstn qi.(ind_npars) iargs in
+ let args := (params ++ map (fun _ => Ast.hole) args)%list in
+ let term := Ast.tApp (Ast.tConstruct ind 0 u) args in
+ term' <- tmEval all term ;;
+ tmUnquote term'
+ end
+ | None => tmFail "anomaly"
+ end
+ | _ => tmFail "goal is not an inductive type"
+ end.
+
+Ltac constructor_tac :=
+ match goal with
+ |- ?T =>
+ let k tm := refine tm.(my_projT2) in
+ unshelve quote_term T ltac:(fun gl => run_template_program (constructor gl) k)
+ end.
+
+Goal True.
+ constructor_tac.
+Qed.
+
+Goal True + False.
+ repeat constructor_tac.
+Qed.
+
From 5b410f1b5272ce6f7633229e69ff6279ccc38226 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Fri, 1 Jul 2022 10:00:08 +0200
Subject: [PATCH 11/43] Constructors as blocks (#723)
* Option to see constructors as block in EWcbvEval, needed for extraction in CertiCoq and to OCaml/Malfunction (#716)
* constructors as blocks
* evaluation rules for constructors as blocks
* tranformation to constructors as blocks
* correctness proof for constructors as blocks
* Fixes after merge
* Fixes after merge
* everything apart from wf_global for transform_blocks
* fix workflow
* generalize transformation on env
* don't skip test
* fix names
Co-authored-by: Yannick Forster
---
.github/workflows/build.yml | 6 +-
erasure/_CoqProject.in | 2 +
erasure/theories/EAst.v | 2 +-
erasure/theories/EAstUtils.v | 12 +-
erasure/theories/ECSubst.v | 3 +-
erasure/theories/EConstructorsAsBlocks.v | 1004 ++++++++++++++++++++++
erasure/theories/EDeps.v | 17 +-
erasure/theories/EEtaExpanded.v | 69 +-
erasure/theories/EEtaExpandedFix.v | 257 +++---
erasure/theories/EGenericMapEnv.v | 339 ++++++++
erasure/theories/EGlobalEnv.v | 2 +-
erasure/theories/EInduction.v | 19 +-
erasure/theories/EInlineProjections.v | 60 +-
erasure/theories/ELiftSubst.v | 11 +-
erasure/theories/EOptimizePropDiscr.v | 51 +-
erasure/theories/EPretty.v | 4 +-
erasure/theories/EReflect.v | 9 +
erasure/theories/ERemoveParams.v | 118 +--
erasure/theories/ESpineView.v | 2 +-
erasure/theories/ETransform.v | 60 +-
erasure/theories/EWcbvEval.v | 304 +++++--
erasure/theories/EWcbvEvalEtaInd.v | 93 +-
erasure/theories/EWcbvEvalInd.v | 175 +++-
erasure/theories/EWellformed.v | 31 +-
erasure/theories/Erasure.v | 39 +-
erasure/theories/ErasureCorrectness.v | 4 +-
erasure/theories/ErasureFunction.v | 4 +-
erasure/theories/ErasureProperties.v | 18 +-
erasure/theories/Extract.v | 6 +-
29 files changed, 2239 insertions(+), 482 deletions(-)
create mode 100644 erasure/theories/EConstructorsAsBlocks.v
create mode 100644 erasure/theories/EGenericMapEnv.v
diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml
index 769d2b2c6..892463022 100644
--- a/.github/workflows/build.yml
+++ b/.github/workflows/build.yml
@@ -1,9 +1,13 @@
name: MetaCoq CI
-on: [push, pull_request]
+on:
+ push:
+ pull_request:
+ types: [opened, synchronize, reopened, ready_for_review]
jobs:
checktodos:
+ if: github.event_name != 'pull_request' || github.event.pull_request.draft == false
runs-on: ubuntu-latest
steps:
- name: Checkout code
diff --git a/erasure/_CoqProject.in b/erasure/_CoqProject.in
index 37d9b3020..9240b90d9 100644
--- a/erasure/_CoqProject.in
+++ b/erasure/_CoqProject.in
@@ -11,6 +11,7 @@ theories/ECSubst.v
theories/EWcbvEval.v
# theories/EWtAst.v
theories/EGlobalEnv.v
+theories/EGenericMapEnv.v
theories/EWellformed.v
theories/EEnvMap.v
theories/EWcbvEvalInd.v
@@ -32,4 +33,5 @@ theories/EProgram.v
theories/ERemoveParams.v
theories/EInlineProjections.v
theories/ETransform.v
+theories/EConstructorsAsBlocks.v
theories/Erasure.v
diff --git a/erasure/theories/EAst.v b/erasure/theories/EAst.v
index b0c8bbd72..16bf3e1a7 100644
--- a/erasure/theories/EAst.v
+++ b/erasure/theories/EAst.v
@@ -33,7 +33,7 @@ Inductive term : Set :=
| tLetIn : name -> term (* the term *) -> term -> term
| tApp : term -> term -> term
| tConst : kername -> term
-| tConstruct : inductive -> nat -> term
+| tConstruct : inductive -> nat -> list term -> term
| tCase : (inductive * nat) (* # of parameters *) ->
term (* discriminee *) -> list (list name * term) (* branches *) -> term
| tProj : projection -> term -> term
diff --git a/erasure/theories/EAstUtils.v b/erasure/theories/EAstUtils.v
index 6db80c98d..53c531708 100644
--- a/erasure/theories/EAstUtils.v
+++ b/erasure/theories/EAstUtils.v
@@ -283,7 +283,7 @@ Definition isCoFix t :=
Definition isConstruct t :=
match t with
- | tConstruct _ _ => true
+ | tConstruct _ _ _ => true
| _ => false
end.
@@ -328,6 +328,8 @@ Definition string_of_def {A : Set} (f : A -> string) (def : def A) :=
"(" ^ string_of_name (dname def) ^ "," ^ f (dbody def) ^ ","
^ string_of_nat (rarg def) ^ ")".
+Definition maybe_string_of_list {A} f (l : list A) := match l with [] => "" | _ => string_of_list f l end.
+
Fixpoint string_of_term (t : term) : string :=
match t with
| tBox => "∎"
@@ -338,7 +340,7 @@ Fixpoint string_of_term (t : term) : string :=
| tLetIn na b t => "LetIn(" ^ string_of_name na ^ "," ^ string_of_term b ^ "," ^ string_of_term t ^ ")"
| tApp f l => "App(" ^ string_of_term f ^ "," ^ string_of_term l ^ ")"
| tConst c => "Const(" ^ string_of_kername c ^ ")"
- | tConstruct i n => "Construct(" ^ string_of_inductive i ^ "," ^ string_of_nat n ^ ")"
+ | tConstruct i n args => "Construct(" ^ string_of_inductive i ^ "," ^ string_of_nat n ^ maybe_string_of_list string_of_term args ^ ")"
| tCase (ind, i) t brs =>
"Case(" ^ string_of_inductive ind ^ "," ^ string_of_nat i ^ "," ^ string_of_term t ^ ","
^ string_of_list (fun b => string_of_term (snd b)) brs ^ ")"
@@ -354,8 +356,10 @@ Fixpoint string_of_term (t : term) : string :=
Fixpoint term_global_deps (t : EAst.term) :=
match t with
- | EAst.tConst kn
- | EAst.tConstruct {| inductive_mind := kn |} _ => KernameSet.singleton kn
+ | EAst.tConst kn => KernameSet.singleton kn
+ | EAst.tConstruct {| inductive_mind := kn |} _ args =>
+ List.fold_left (fun acc x => KernameSet.union (term_global_deps x) acc) args
+ (KernameSet.singleton kn)
| EAst.tLambda _ x => term_global_deps x
| EAst.tApp x y
| EAst.tLetIn _ x y => KernameSet.union (term_global_deps x) (term_global_deps y)
diff --git a/erasure/theories/ECSubst.v b/erasure/theories/ECSubst.v
index 7edceca5d..65a0695d3 100644
--- a/erasure/theories/ECSubst.v
+++ b/erasure/theories/ECSubst.v
@@ -36,6 +36,7 @@ Fixpoint csubst t k u :=
let k' := List.length mfix + k in
let mfix' := List.map (map_def (csubst t k')) mfix in
tCoFix mfix' idx
+ | tConstruct ind n args => tConstruct ind n (map (csubst t k) args)
| x => x
end.
@@ -57,7 +58,7 @@ Proof.
destruct (nth_error_spec [t] (n - k) ).
simpl in l0; lia.
now rewrite Nat.sub_1_r.
- + now destruct (Nat.leb_spec k n); try lia.
+ + now destruct (Nat.leb_spec k n); try lia.
Qed.
Lemma substl_subst s u : forallb (closedn 0) s ->
diff --git a/erasure/theories/EConstructorsAsBlocks.v b/erasure/theories/EConstructorsAsBlocks.v
new file mode 100644
index 000000000..f85a3083b
--- /dev/null
+++ b/erasure/theories/EConstructorsAsBlocks.v
@@ -0,0 +1,1004 @@
+(* Distributed under the terms of the MIT license. *)
+From Coq Require Import Utf8 Program.
+From MetaCoq.Template Require Import config utils Kernames BasicAst EnvMap.
+From MetaCoq.Erasure Require Import EAst EAstUtils EInduction EArities
+ ELiftSubst ESpineView EGlobalEnv EWellformed EEnvMap
+ EWcbvEval EEtaExpanded ECSubst EWcbvEvalEtaInd EProgram.
+
+Local Open Scope string_scope.
+Set Asymmetric Patterns.
+Import MCMonadNotation.
+
+From Equations Require Import Equations.
+Set Equations Transparent.
+Local Set Keyed Unification.
+From Coq Require Import ssreflect ssrbool.
+
+(** We assume [Prop = Type] and universes are checked correctly in the following. *)
+(* Local Existing Instance extraction_checker_flags. *)
+Ltac introdep := let H := fresh in intros H; depelim H.
+
+#[global]
+Hint Constructors eval : core.
+
+Import MCList (map_InP, map_InP_elim, map_InP_spec).
+
+Section transform_blocks.
+ Context (Σ : global_context).
+ Section Def.
+ Import TermSpineView.
+
+ Equations? transform_blocks (t : term) : term
+ by wf t (fun x y : EAst.term => size x < size y) :=
+ | e with TermSpineView.view e := {
+ | tRel i => EAst.tRel i
+ | tEvar ev args => EAst.tEvar ev (map_InP args (fun x H => transform_blocks x))
+ | tLambda na M => EAst.tLambda na (transform_blocks M)
+ | tApp u v napp nnil with construct_viewc u :=
+ { | view_construct ind i block_args with lookup_constructor_pars_args Σ ind i := {
+ | Some (npars, nargs) =>
+ let args := map_InP v (fun x H => transform_blocks x) in
+ let '(args, rest) := MCList.chop nargs args in
+ EAst.mkApps (EAst.tConstruct ind i args) rest
+ | None =>
+ let args := map_InP v (fun x H => transform_blocks x) in
+ EAst.tConstruct ind i args }
+ | view_other _ _ => mkApps (transform_blocks u) (map_InP v (fun x H => transform_blocks x)) }
+
+ | tLetIn na b b' => EAst.tLetIn na (transform_blocks b) (transform_blocks b')
+ | tCase ind c brs =>
+ let brs' := map_InP brs (fun x H => (x.1, transform_blocks x.2)) in
+ EAst.tCase (ind.1, 0) (transform_blocks c) brs'
+ | tProj p c => EAst.tProj {| proj_ind := p.(proj_ind); proj_npars := 0; proj_arg := p.(proj_arg) |} (transform_blocks c)
+ | tFix mfix idx =>
+ let mfix' := map_InP mfix (fun d H => {| dname := dname d; dbody := transform_blocks d.(dbody); rarg := d.(rarg) |}) in
+ EAst.tFix mfix' idx
+ | tCoFix mfix idx =>
+ let mfix' := map_InP mfix (fun d H => {| dname := dname d; dbody := transform_blocks d.(dbody); rarg := d.(rarg) |}) in
+ EAst.tCoFix mfix' idx
+ | tBox => EAst.tBox
+ | tVar n => EAst.tVar n
+ | tConst n => EAst.tConst n
+ | tConstruct ind i block_args => EAst.tConstruct ind i [] }.
+ Proof.
+ all:try lia.
+ all:try apply (In_size); tea.
+ all:try lia.
+ - now apply (In_size id size).
+ - change (fun x => size (id x)) with size in H.
+ eapply (In_size id size) in H. unfold id in H.
+ change (fun x => size x) with size in H.
+ rewrite size_mkApps. cbn. lia.
+ - change (fun x => size (id x)) with size in H.
+ eapply (In_size id size) in H. unfold id in H.
+ change (fun x => size x) with size in H.
+ rewrite size_mkApps. cbn. lia.
+ - now eapply size_mkApps_f.
+ - change (fun x => size (id x)) with size in H.
+ eapply (In_size id size) in H. unfold id in H.
+ change (fun x => size x) with size in H.
+ pose proof (size_mkApps_l napp nnil). lia.
+ - eapply (In_size snd size) in H. cbn in *. lia.
+ Qed.
+
+ End Def.
+
+ Hint Rewrite @map_InP_spec : transform_blocks.
+
+ Arguments eqb : simpl never.
+
+ Opaque transform_blocks_unfold_clause_1.
+ Opaque transform_blocks.
+ Opaque isEtaExp.
+ Opaque isEtaExp_unfold_clause_1.
+
+
+ Lemma chop_firstn_skipn {A} n (l : list A) : chop n l = (firstn n l, skipn n l).
+ Proof using Type.
+ induction n in l |- *; destruct l; simpl; auto.
+ now rewrite IHn skipn_S.
+ Qed.
+
+ Lemma chop_eq {A} n (l : list A) l1 l2 : chop n l = (l1, l2) -> l = l1 ++ l2.
+ Proof.
+ rewrite chop_firstn_skipn. intros [= <- <-].
+ now rewrite firstn_skipn.
+ Qed.
+
+ Lemma closed_transform_blocks t k : closedn k t -> closedn k (transform_blocks t).
+ Proof using Type.
+ funelim (transform_blocks t); simp transform_blocks; rewrite <-?transform_blocks_equation_1; toAll; simpl;
+ intros; try easy;
+ rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length;
+ unfold test_def in *;
+ simpl closed in *;
+ try solve [simpl; subst; simpl closed; f_equal; auto; rtoProp; solve_all; solve_all]; try easy.
+ - rewrite !closedn_mkApps in H1 *.
+ rtoProp; intuition auto. solve_all.
+ - destruct (chop nargs v) eqn:E.
+ erewrite chop_map; eauto.
+ eapply chop_eq in E as ->.
+ rewrite !closedn_mkApps in H0 *.
+ rtoProp; intuition auto; cbn; solve_all; eapply All_app in H1;
+ repeat solve_all.
+ - rewrite !closedn_mkApps /= in H0 *. rtoProp.
+ repeat solve_all.
+ Qed.
+
+ Hint Rewrite @forallb_InP_spec : isEtaExp.
+ Transparent isEtaExp_unfold_clause_1.
+
+ Transparent transform_blocks_unfold_clause_1.
+
+ Local Lemma transform_blocks_mkApps f v :
+ ~~ isApp f ->
+ transform_blocks (mkApps f v) = match construct_viewc f with
+ | view_construct ind i block_args =>
+ match lookup_constructor_pars_args Σ ind i with
+ | Some (npars, nargs) =>
+ let args := map transform_blocks v in
+ let '(args, rest) := MCList.chop nargs args in
+ EAst.mkApps (EAst.tConstruct ind i args) rest
+ | None =>
+ let args := map transform_blocks v in
+ EAst.tConstruct ind i args
+ end
+ | view_other _ _ => mkApps (transform_blocks f) (map transform_blocks v)
+ end.
+ Proof using Type.
+ intros napp; simp transform_blocks.
+ destruct (construct_viewc f) eqn:vc.
+ - destruct lookup_constructor_pars_args as [[]|] eqn:heq.
+ destruct v eqn:hargs. cbn.
+ * destruct n1 => //.
+ * set (v' := TermSpineView.view _).
+ destruct (TermSpineView.view_mkApps v') as [hf [vn eq]] => //.
+ rewrite eq /=. rewrite heq /=. now simp transform_blocks.
+ * destruct v eqn:hargs => //.
+ set (v' := TermSpineView.view _).
+ destruct (TermSpineView.view_mkApps v') as [hf [vn eq]] => //.
+ rewrite eq /=. rewrite heq /=. now simp transform_blocks.
+ - destruct v eqn:hargs => //.
+ simp transform_blocks.
+ set (v' := TermSpineView.view _).
+ destruct (TermSpineView.view_mkApps v') as [hf [vn eq]] => //.
+ rewrite eq /= vc /=. now simp transform_blocks.
+ Qed.
+
+ Lemma transform_blocks_decompose f :
+ transform_blocks f =
+ let (fn, args) := decompose_app f in
+ match construct_viewc fn with
+ | view_construct kn c _ =>
+ match lookup_constructor_pars_args Σ kn c with
+ | Some (npars, nargs) =>
+ let args := map (transform_blocks) args in
+ let '(args, rest) := MCList.chop nargs args in
+ mkApps (tConstruct kn c args) rest
+ | None =>
+ let args := map transform_blocks args in
+ tConstruct kn c args
+ end
+ | view_other fn nconstr =>
+ mkApps (transform_blocks fn) (map transform_blocks args)
+ end.
+ Proof.
+ destruct (decompose_app f) eqn:da.
+ rewrite (decompose_app_inv da). rewrite transform_blocks_mkApps.
+ now eapply decompose_app_notApp.
+ destruct construct_viewc; try reflexivity.
+ Qed.
+
+ Lemma transform_blocks_mkApps_eta (P : term -> Prop) fn args :
+ (* wf_glob Σ ->
+ *)~~ EAst.isApp fn ->
+ isEtaExp Σ (mkApps fn args) ->
+ (match construct_viewc fn with
+ | view_construct kn c block_args =>
+ forall pars nargs,
+ lookup_constructor_pars_args Σ kn c = Some (pars, nargs) ->
+ let cargs := map transform_blocks args in
+ let '(cargs, rest) := MCList.chop nargs cargs in
+ P (mkApps (tConstruct kn c cargs) rest)
+ | view_other fn nconstr =>
+ P (mkApps (transform_blocks fn) (map transform_blocks args))
+ end) ->
+ P (transform_blocks (mkApps fn args)).
+ Proof.
+ intros napp.
+ move/isEtaExp_mkApps.
+ rewrite decompose_app_mkApps //.
+ destruct construct_viewc eqn:vc.
+ + rewrite /isEtaExp_app.
+ destruct lookup_constructor_pars_args as [[]|] eqn:hl.
+ rewrite transform_blocks_decompose decompose_app_mkApps // /= hl.
+ move=> /andP[] /andP[] /Nat.leb_le hargs etaargs bargs.
+ destruct block_args; invs bargs.
+ move/(_ _ _ eq_refl).
+ destruct chop eqn:eqch => //.
+ move => /andP[] => //.
+ + intros ht. rewrite transform_blocks_mkApps // vc //.
+ Qed.
+
+ Lemma transform_blocks_mkApps_eta_fn f args : isEtaExp Σ f ->
+ transform_blocks (mkApps f args) = mkApps (transform_blocks f) (map (transform_blocks) args).
+ Proof.
+ intros ef.
+ destruct (decompose_app f) eqn:df.
+ rewrite (decompose_app_inv df) in ef |- *.
+ rewrite -mkApps_app.
+ move/isEtaExp_mkApps: ef.
+ pose proof (decompose_app_notApp _ _ _ df).
+ rewrite decompose_app_mkApps /= //.
+ rewrite transform_blocks_decompose.
+ rewrite decompose_app_mkApps /= //.
+ destruct (construct_viewc t) eqn:vc.
+ + move=> /andP[] etanl etal.
+ destruct lookup_constructor_pars_args as [[pars args']|] eqn:hl => //.
+ cbn.
+ rewrite chop_firstn_skipn.
+ rewrite transform_blocks_decompose.
+ rewrite decompose_app_mkApps // /= hl.
+ rewrite chop_firstn_skipn.
+ rewrite - mkApps_app.
+ move: etanl. rewrite /isEtaExp_app hl.
+ move => /andP[] /Nat.leb_le => hl' hall.
+ rewrite firstn_map.
+ rewrite firstn_app.
+ assert (args' - #|l| = 0) as -> by lia.
+ rewrite firstn_O // app_nil_r. f_equal. f_equal.
+ rewrite firstn_map //. rewrite map_app skipn_map.
+ rewrite skipn_app. len.
+ assert (args' - #|l| = 0) as -> by lia.
+ now rewrite skipn_0 -skipn_map.
+ move: etanl. rewrite /isEtaExp_app hl //.
+ + move => /andP[] etat etal.
+ rewrite (transform_blocks_decompose (mkApps t l)).
+ rewrite decompose_app_mkApps //.
+ rewrite vc. rewrite -mkApps_app. f_equal.
+ now rewrite map_app.
+ Qed.
+
+ Lemma transform_blocks_csubst a k b :
+ closed a ->
+ isEtaExp Σ a ->
+ isEtaExp Σ b ->
+ transform_blocks (ECSubst.csubst a k b) = ECSubst.csubst (transform_blocks a) k (transform_blocks b).
+ Proof using Type.
+ intros cla etaa. move b at bottom.
+ funelim (transform_blocks b); cbn; simp transform_blocks isEtaExp; rewrite -?isEtaExp_equation_1 -?transform_blocks_equation_1; toAll; simpl;
+ intros; try easy;
+ rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length;
+ unfold test_def in *;
+ simpl closed in *; try solve [simpl subst; simpl closed; f_equal; auto; rtoProp; solve_all]; try easy.
+
+ - destruct Nat.compare => //.
+ - f_equal. solve_all. move/andP: b => [] _ he. solve_all.
+ - rewrite csubst_mkApps.
+ rtoProp. solve_all.
+ assert (
+ mkApps (transform_blocks u) (map transform_blocks v) =
+ transform_blocks (mkApps u v)
+ ) as ->. { rewrite transform_blocks_mkApps. eauto. now rewrite Heq. }
+ eapply (transform_blocks_mkApps_eta (fun x => transform_blocks (mkApps (csubst a k u) (map (csubst a k) v)) =
+ csubst (transform_blocks a) k x)); eauto.
+ rewrite Heq.
+ rewrite csubst_mkApps.
+ rewrite isEtaExp_mkApps_napp in H1 => //. rewrite Heq in H1.
+ rtoProp. rename H1 into etau. rename H2 into etav.
+ rewrite - H //.
+ rewrite transform_blocks_mkApps_eta_fn.
+ now eapply etaExp_csubst.
+ f_equal.
+ rewrite !map_map_compose. solve_all.
+ - assert (H1 := etaExp_csubst _ _ k _ etaa H0).
+ rewrite !csubst_mkApps /= in H1 *.
+ assert (map (csubst a k) v <> []).
+ { destruct v; cbn; congruence. }
+ rewrite transform_blocks_mkApps //.
+ rewrite isEtaExp_Constructor // in H1.
+ move: H1 => /andP[] /andP[]. rewrite map_length. move=> etaapp etav bargs.
+ destruct block_args; invs bargs.
+ cbn -[lookup_constructor_pars_args].
+ unfold isEtaExp_app in etaapp.
+ rewrite Heq in etaapp |- *.
+ destruct (chop nargs v) eqn:heqc.
+ rewrite map_map_compose.
+ erewrite !chop_map; eauto.
+ rewrite csubst_mkApps. cbn.
+ eapply chop_eq in heqc as ->.
+ cbn.
+ rewrite isEtaExp_Constructor in H0.
+ move: H0 => /andP[] /andP[] He1 He2 He3.
+ cbn. f_equal. f_equal.
+ all: rewrite !map_map_compose; solve_all; eapply All_app in He2.
+ all: repeat solve_all.
+ - assert (H1 := etaExp_csubst _ _ k _ etaa H0).
+ rewrite !csubst_mkApps /= in H1 *.
+ assert (map (csubst a k) v <> []).
+ { destruct v; cbn; congruence. }
+ rewrite transform_blocks_mkApps //.
+ rewrite isEtaExp_Constructor // in H1.
+ move/andP : H1 => [] /andP[]. rewrite map_length. move=> etaapp etav bargs.
+ cbn -[lookup_inductive_pars].
+ unfold isEtaExp_app in etaapp.
+ destruct lookup_constructor_pars_args as [[pars args]|] eqn:eqpars => //.
+ Qed.
+
+ Lemma transform_blocks_substl s t :
+ forallb (closedn 0) s ->
+ forallb (isEtaExp Σ) s ->
+ isEtaExp Σ t ->
+ transform_blocks (substl s t) = substl (map transform_blocks s) (transform_blocks t).
+ Proof using Type.
+ induction s in t |- *; simpl; auto.
+ move=> /andP[] cla cls /andP[] etaa etas etat.
+ rewrite IHs //. now eapply etaExp_csubst. f_equal.
+ now rewrite transform_blocks_csubst.
+ Qed.
+
+ Lemma transform_blocks_iota_red pars args br :
+ forallb (closedn 0) args ->
+ forallb (isEtaExp Σ) args ->
+ isEtaExp Σ br.2 ->
+ transform_blocks (EGlobalEnv.iota_red pars args br) = EGlobalEnv.iota_red pars (map transform_blocks args) (on_snd transform_blocks br).
+ Proof using Type.
+ intros cl etaargs etabr.
+ unfold EGlobalEnv.iota_red.
+ rewrite transform_blocks_substl //.
+ rewrite forallb_rev forallb_skipn //.
+ rewrite forallb_rev forallb_skipn //.
+ now rewrite map_rev map_skipn.
+ Qed.
+
+ Lemma transform_blocks_fix_subst mfix : EGlobalEnv.fix_subst (map (map_def transform_blocks) mfix) = map transform_blocks (EGlobalEnv.fix_subst mfix).
+ Proof using Type.
+ unfold EGlobalEnv.fix_subst.
+ rewrite map_length.
+ generalize #|mfix|.
+ induction n; simpl; auto.
+ f_equal; auto. now simp transform_blocks.
+ Qed.
+
+ Lemma transform_blocks_cofix_subst mfix : EGlobalEnv.cofix_subst (map (map_def transform_blocks) mfix) = map transform_blocks (EGlobalEnv.cofix_subst mfix).
+ Proof using Type.
+ unfold EGlobalEnv.cofix_subst.
+ rewrite map_length.
+ generalize #|mfix|.
+ induction n; simpl; auto.
+ f_equal; auto. now simp transform_blocks.
+ Qed.
+
+ Lemma transform_blocks_cunfold_fix mfix idx n f :
+ forallb (closedn 0) (fix_subst mfix) ->
+ forallb (fun d => isLambda (dbody d) && isEtaExp Σ (dbody d)) mfix ->
+ cunfold_fix mfix idx = Some (n, f) ->
+ cunfold_fix (map (map_def transform_blocks) mfix) idx = Some (n, transform_blocks f).
+ Proof using Type.
+ intros hfix heta.
+ unfold cunfold_fix.
+ rewrite nth_error_map.
+ destruct nth_error eqn:heq.
+ intros [= <- <-] => /=. f_equal. f_equal.
+ rewrite transform_blocks_substl //.
+ now apply isEtaExp_fix_subst.
+ solve_all. eapply nth_error_all in heta; tea. cbn in heta.
+ rtoProp; intuition auto.
+ f_equal. f_equal. apply transform_blocks_fix_subst.
+ discriminate.
+ Qed.
+
+
+ Lemma transform_blocks_cunfold_cofix mfix idx n f :
+ forallb (closedn 0) (cofix_subst mfix) ->
+ forallb (isEtaExp Σ ∘ dbody) mfix ->
+ cunfold_cofix mfix idx = Some (n, f) ->
+ cunfold_cofix (map (map_def transform_blocks) mfix) idx = Some (n, transform_blocks f).
+ Proof using Type.
+ intros hcofix heta.
+ unfold cunfold_cofix.
+ rewrite nth_error_map.
+ destruct nth_error eqn:heq.
+ intros [= <- <-] => /=. f_equal.
+ rewrite transform_blocks_substl //.
+ now apply isEtaExp_cofix_subst.
+ solve_all. now eapply nth_error_all in heta; tea.
+ f_equal. f_equal. apply transform_blocks_cofix_subst.
+ discriminate.
+ Qed.
+
+ Lemma transform_blocks_nth {n l d} :
+ transform_blocks (nth n l d) = nth n (map transform_blocks l) (transform_blocks d).
+ Proof using Type.
+ induction l in n |- *; destruct n; simpl; auto.
+ Qed.
+
+ Definition switch_constructor_as_block fl : WcbvFlags :=
+ EWcbvEval.Build_WcbvFlags fl.(@with_prop_case) fl.(@with_guarded_fix) true.
+
+End transform_blocks.
+
+Definition transform_blocks_constant_decl Σ cb :=
+ {| cst_body := option_map (transform_blocks Σ) cb.(cst_body) |}.
+
+Definition transform_blocks_decl Σ d :=
+ match d with
+ | ConstantDecl cb => ConstantDecl (transform_blocks_constant_decl Σ cb)
+ | InductiveDecl idecl => d
+ end.
+
+Definition transform_blocks_env Σ :=
+ map (on_snd (transform_blocks_decl Σ)) Σ.
+
+Definition transform_blocks_program (p : eprogram_env) :=
+ (transform_blocks_env p.1, transform_blocks p.1 p.2).
+
+Definition term_flags :=
+ {|
+ has_tBox := true;
+ has_tRel := true;
+ has_tVar := false;
+ has_tEvar := false;
+ has_tLambda := true;
+ has_tLetIn := true;
+ has_tApp := true;
+ has_tConst := true;
+ has_tConstruct := true;
+ has_tCase := true;
+ has_tProj := false;
+ has_tFix := true;
+ has_tCoFix := false
+ |}.
+
+Definition env_flags :=
+ {| has_axioms := false;
+ has_cstr_params := false;
+ term_switches := term_flags ;
+ cstr_as_blocks := false
+ |}.
+
+
+Definition env_flags_blocks :=
+ {| has_axioms := false;
+ has_cstr_params := false;
+ term_switches := term_flags ;
+ cstr_as_blocks := true
+ |}.
+
+
+Local Existing Instance env_flags.
+
+Lemma Qpreserves_wellformed Σ : wf_glob Σ -> Qpreserves (fun n x => wellformed Σ n x) Σ.
+Proof.
+ intros clΣ.
+ split.
+ - red. move=> n t.
+ destruct t; cbn; intuition auto; try solve [constructor; auto].
+ eapply on_letin; rtoProp; intuition auto.
+ eapply on_app; rtoProp; intuition auto.
+ eapply on_case; rtoProp; intuition auto. solve_all.
+ eapply on_fix. solve_all. move/andP: H => [] _ ha. solve_all.
+ - red. intros kn decl.
+ move/(lookup_env_wellformed clΣ).
+ unfold wf_global_decl. destruct cst_body => //.
+ - red. move=> hasapp n t args. rewrite wellformed_mkApps //.
+ split; intros; rtoProp; intuition auto; solve_all.
+ - red. cbn => //.
+ (* move=> hascase n ci discr brs. simpl.
+ destruct lookup_inductive eqn:hl => /= //.
+ split; intros; rtoProp; intuition auto; solve_all. *)
+ - red. move=> hasproj n p discr. now cbn in hasproj.
+ - red. move=> t args clt cll.
+ eapply wellformed_substl. solve_all. now rewrite Nat.add_0_r.
+ - red. move=> n mfix idx. cbn. unfold wf_fix.
+ split; intros; rtoProp; intuition auto; solve_all. now apply Nat.ltb_lt.
+ - red. move=> n mfix idx. cbn.
+ split; intros; rtoProp; intuition auto; solve_all.
+Qed.
+
+Definition block_wcbv_flags :=
+ {| with_prop_case := false ; with_guarded_fix := false ; with_constructor_as_block := true |}.
+
+Local Hint Resolve wellformed_closed : core.
+
+Lemma wellformed_lookup_inductive_pars Σ kn mdecl :
+ wf_glob Σ ->
+ lookup_minductive Σ kn = Some mdecl -> mdecl.(ind_npars) = 0.
+Proof.
+ induction 1; cbn => //.
+ case: eqb_spec => [|].
+ - intros ->. destruct d => //. intros [= <-].
+ cbn in H0. unfold wf_minductive in H0.
+ rtoProp. cbn in H0. now eapply eqb_eq in H0.
+ - intros _. eapply IHwf_glob.
+Qed.
+
+Lemma wellformed_lookup_constructor_pars {Σ kn c mdecl idecl cdecl} :
+ wf_glob Σ ->
+ lookup_constructor Σ kn c = Some (mdecl, idecl, cdecl) -> mdecl.(ind_npars) = 0.
+Proof.
+ intros wf. cbn -[lookup_minductive].
+ destruct lookup_minductive eqn:hl => //.
+ do 2 destruct nth_error => //.
+ eapply wellformed_lookup_inductive_pars in hl => //. congruence.
+Qed.
+
+Lemma lookup_constructor_pars_args_spec {Σ ind n mdecl idecl cdecl} :
+ wf_glob Σ ->
+ lookup_constructor Σ ind n = Some (mdecl, idecl, cdecl) ->
+ lookup_constructor_pars_args Σ ind n = Some (mdecl.(ind_npars), cdecl.(cstr_nargs)).
+Proof.
+ cbn -[lookup_constructor] => wfΣ.
+ destruct lookup_constructor as [[[mdecl' idecl'] [pars args]]|] eqn:hl => //.
+ intros [= -> -> <-]. cbn. f_equal.
+Qed.
+
+Lemma wellformed_lookup_constructor_pars_args {Σ ind n block_args} :
+ wf_glob Σ ->
+ wellformed Σ 0 (EAst.tConstruct ind n block_args) ->
+ ∑ args, lookup_constructor_pars_args Σ ind n = Some (0, args).
+Proof.
+ intros wfΣ wf. cbn -[lookup_constructor] in wf.
+ destruct lookup_constructor as [[[mdecl idecl] cdecl]|] eqn:hl => //.
+ exists cdecl.(cstr_nargs).
+ pose proof (wellformed_lookup_constructor_pars wfΣ hl).
+ eapply lookup_constructor_pars_args_spec in hl => //. congruence.
+Qed.
+
+Lemma constructor_isprop_pars_decl_params {Σ ind c b pars cdecl} :
+ wf_glob Σ ->
+ constructor_isprop_pars_decl Σ ind c = Some (b, pars, cdecl) -> pars = 0.
+Proof.
+ intros hwf.
+ rewrite /constructor_isprop_pars_decl /lookup_constructor /lookup_inductive.
+ destruct lookup_minductive as [mdecl|] eqn:hl => /= //.
+ do 2 destruct nth_error => //.
+ eapply wellformed_lookup_inductive_pars in hl => //. congruence.
+Qed.
+
+Lemma skipn_ge m {A} (l : list A) :
+ m >= length l -> skipn m l = [].
+Proof.
+ induction l in m |- *.
+ - destruct m; reflexivity.
+ - cbn. destruct m; try lia. intros H.
+ eapply IHl. lia.
+Qed.
+
+Lemma chop_all {A} (l : list A) m :
+ m >= length l -> chop m l = (l, nil).
+Proof.
+ intros Hl. rewrite chop_firstn_skipn.
+ rewrite firstn_ge; try lia. rewrite skipn_ge; try lia.
+ eauto.
+Qed.
+
+Lemma transform_blocks_tApp Σ t a (P : term -> Set) k :
+ wf_glob Σ ->
+ wellformed Σ k (tApp t a) ->
+ (let (fn, args) := decompose_app (tApp t a) in
+ match construct_viewc fn with
+ | view_construct kn c block_args =>
+ match lookup_constructor_pars_args Σ kn c with
+ | Some (0, nargs) =>
+ let cargs := map (transform_blocks Σ) args in
+ let '(cargs, rest) := MCList.chop nargs cargs in
+ (args <> [] /\ t = mkApps (tConstruct kn c block_args) (remove_last args) /\ a = last args a) ->
+ P (mkApps (tConstruct kn c cargs) rest)
+ | _ => True
+ end
+ | view_other fn nconstr =>
+ P (tApp (transform_blocks Σ t) (transform_blocks Σ a))
+ end) ->
+ P (transform_blocks Σ (tApp t a)).
+Proof.
+ intros wfΣ wf.
+ rewrite (transform_blocks_decompose _ (tApp t a)).
+ destruct decompose_app eqn:da.
+ pose proof (decompose_app_notApp _ _ _ da).
+ pose proof (EInduction.decompose_app_app _ _ _ _ da).
+ destruct construct_viewc eqn:vc.
+ + eapply EEtaExpandedFix.decompose_app_tApp_split in da as [Ha Ht].
+ cbn in wf.
+ move: wf => /andP[]. rewrite Ha wellformed_mkApps // => /andP[] wfc wfl wft.
+ destruct (wellformed_lookup_constructor_pars_args wfΣ wfc).
+ rewrite e. cbn.
+ destruct chop eqn:eqch => //.
+ intros. apply H1. intuition auto.
+ + pose proof (decompose_app_notApp _ _ _ da).
+ pose proof (EInduction.decompose_app_app _ _ _ _ da).
+ eapply EEtaExpandedFix.decompose_app_tApp_split in da as [Ha Ht].
+ rewrite Ha Ht.
+ rewrite transform_blocks_mkApps // vc.
+ rewrite {3} (remove_last_last l a) => //.
+ now rewrite map_app mkApps_app.
+Qed.
+
+Lemma eval_mkApps_Construct_inv {fl : WcbvFlags} Σ kn c args e block_args mdecl idecl cdecl :
+ with_constructor_as_block = false ->
+ lookup_constructor Σ kn c = Some (mdecl, idecl, cdecl) ->
+ eval Σ (mkApps (tConstruct kn c block_args) args) e ->
+ ∑ args', (e = mkApps (tConstruct kn c []) args') × All2 (eval Σ) args args' × block_args = [] × #|args| <= cstr_arity mdecl cdecl.
+Proof.
+ intros hblock hlook.
+ revert e; induction args using rev_ind; intros e.
+ - intros ev. depelim ev. congruence. exists []=> //. invs i. destruct block_args; invs H0 => //. cbn. repeat split. econstructor. lia.
+ - intros ev. rewrite mkApps_app /= in ev.
+ depelim ev; try solve_discr.
+ destruct (IHargs _ ev1) as [? []]. solve_discr.
+ all:try specialize (IHargs _ ev1) as [? []]; try solve_discr; try noconf H.
+ * destruct p as (? & ? & ?). exists (x0 ++ [a']). split => //.
+ rewrite mkApps_app /= //. split => //. eapply All2_app; eauto.
+ split => //. eapply All2_length in a. len. rewrite e1 in hlook; invs hlook. lia.
+ * destruct p as (? & ? & ?). subst f'.
+ cbn in i.
+ rewrite isConstructApp_mkApps in i. cbn in i.
+ rewrite orb_true_r in i. cbn in i. congruence.
+ * now cbn in i.
+Qed.
+
+Lemma transform_blocks_isConstructApp Σ t :
+ wf_glob Σ -> wellformed Σ 0 t ->
+ isConstructApp (transform_blocks Σ t) = isConstructApp t.
+Proof.
+ intros Hwf Hwf'.
+ induction t; try now cbn; eauto.
+ eapply transform_blocks_tApp; eauto.
+ destruct decompose_app.
+ destruct construct_viewc.
+ - destruct lookup_constructor_pars_args as [ [[]] | ]; eauto.
+ cbn. destruct chop. intros (? & ? & ?). subst.
+ rewrite -[tApp _ _](mkApps_app _ _ [t2]).
+ rewrite !isConstructApp_mkApps. cbn. reflexivity.
+ - change (tApp t1 t2) with (mkApps t1 [t2]).
+ change (tApp (transform_blocks Σ t1) (transform_blocks Σ t2)) with
+ (mkApps (transform_blocks Σ t1) [transform_blocks Σ t2]).
+ rewrite !isConstructApp_mkApps.
+ eapply IHt1. cbn in Hwf'. rtoProp. intuition.
+Qed.
+
+Lemma lookup_env_transform_blocks Σ kn :
+ lookup_env (transform_blocks_env Σ) kn =
+ option_map (transform_blocks_decl Σ) (lookup_env Σ kn).
+Proof.
+ unfold transform_blocks_env.
+ induction Σ at 2 4; simpl; auto.
+ case: eqb_spec => //.
+Qed.
+
+Lemma transform_blocks_declared_constant Σ c decl :
+ declared_constant Σ c decl -> declared_constant (transform_blocks_env Σ) c (transform_blocks_constant_decl Σ decl).
+Proof.
+ intros H. red in H; red.
+ rewrite lookup_env_transform_blocks H //.
+Qed.
+
+Lemma lookup_constructor_transform_blocks Σ ind c :
+lookup_constructor (transform_blocks_env Σ) ind c =
+lookup_constructor Σ ind c.
+Proof.
+ unfold lookup_constructor, lookup_inductive, lookup_minductive in *.
+ rewrite lookup_env_transform_blocks.
+ destruct lookup_env as [ [] | ]; cbn; congruence.
+Qed.
+
+Lemma transform_wellformed' Σ n t :
+ wf_glob Σ ->
+ @wellformed env_flags Σ n t ->
+ isEtaExp Σ t ->
+ @wellformed env_flags_blocks Σ n (transform_blocks Σ t).
+Proof.
+ revert n. funelim (transform_blocks Σ t); simp_eta; cbn-[transform_blocks lookup_constructor_pars_args isEtaExp]; intros m Hwf Hw; rtoProp; try split; eauto.
+ all: rewrite ?map_InP_spec; toAll; eauto; try now solve_all.
+ - destruct H1. unfold isEtaExp_app in H1. unfold lookup_constructor_pars_args in *.
+ destruct (lookup_constructor Σ) as [[[]] | ]; try congruence; cbn - [transform_blocks].
+ 2: eauto. split; auto.
+ - destruct H4. solve_all.
+ - unfold wf_fix in *. rtoProp. solve_all. len. solve_all. len. destruct x.
+ cbn -[transform_blocks isEtaExp] in *. rtoProp. eauto.
+ - rewrite !wellformed_mkApps in Hw |- * => //. rtoProp. intros.
+ eapply isEtaExp_mkApps in H3. rewrite decompose_app_mkApps in H3; eauto.
+ destruct construct_viewc; eauto. cbn in d. eauto.
+ rtoProp. eauto. repeat solve_all.
+ - Opaque isEtaExp. destruct chop eqn:Ec. rewrite !wellformed_mkApps in Hw |- * => //. rtoProp.
+ cbn -[lookup_constructor transform_blocks ] in *. intros. rtoProp.
+ rewrite isEtaExp_Constructor in H2.
+ rtoProp. unfold isEtaExp_app in *. unfold lookup_constructor_pars_args in H2.
+ repeat split; eauto;
+ rewrite ?lookup_constructor_transform_blocks; eauto.
+ * destruct lookup_constructor as [ [[]] | ] eqn:E; cbn -[transform_blocks] in *; eauto.
+ invs Heq. rewrite chop_firstn_skipn in Ec. invs Ec.
+ rewrite firstn_length. len. eapply Nat.leb_le in H2. eapply Nat.leb_le.
+ destruct lookup_env as [ [] | ] eqn:E'; try congruence.
+ eapply lookup_env_wellformed in E'; eauto.
+ cbn in E'. red in E'. unfold wf_minductive in E'.
+ rewrite andb_true_iff in E'.
+ cbn in E'. destruct E'.
+ eapply Nat.eqb_eq in H6.
+ destruct nth_error; invs E.
+ destruct nth_error; invs H9.
+ rewrite H6. lia.
+ * rewrite chop_firstn_skipn in Ec. invs Ec.
+ solve_all. eapply All_firstn. solve_all.
+ * rewrite chop_firstn_skipn in Ec. invs Ec.
+ solve_all. eapply All_skipn. solve_all.
+ - rewrite wellformed_mkApps in Hw; eauto. rtoProp. cbn in *. rtoProp.
+ cbn in *. destruct lookup_env as [[] | ]; cbn in *; eauto; try congruence.
+ - rewrite isEtaExp_Constructor in H0. rtoProp. unfold lookup_constructor_pars_args in *.
+ destruct lookup_constructor as [ [[]] | ]; cbn in Heq; try congruence.
+ cbn. split; eauto. rewrite wellformed_mkApps in Hw; eauto. rtoProp. solve_all.
+Qed.
+
+From MetaCoq.Erasure Require Import EGenericMapEnv.
+
+Lemma transform_blocks_extends :
+ ∀ (Σ : global_context) (t : term) (n : nat),
+ wellformed Σ n t
+ → ∀ Σ' : global_context,
+ extends Σ Σ'
+ → wf_glob Σ' → transform_blocks Σ t = transform_blocks Σ' t.
+Proof.
+ intros Σ t.
+ Opaque transform_blocks.
+ funelim (transform_blocks Σ t); cbn -[lookup_constant lookup_inductive
+ lookup_projection]; intros => //; simp transform_blocks; rewrite -?transform_blocks_equation_1.
+ all: try rewrite !map_InP_spec.
+ all: try toAll.
+ all: try f_equal.
+ all: rtoProp; solve_all.
+ - f_equal. eauto. solve_all.
+ - unfold wf_fix in *. rtoProp. f_equal. solve_all.
+ - rewrite wellformed_mkApps in H1 => //. rtoProp.
+ rewrite transform_blocks_mkApps; eauto. destruct construct_viewc; cbn in d; eauto.
+ f_equal. eapply H; eauto. solve_all.
+ - destruct chop eqn:E.
+ rewrite wellformed_mkApps in H0 => //. rewrite transform_blocks_mkApps => //.
+ rtoProp. cbn [construct_viewc]. unfold lookup_constructor_pars_args in *.
+ destruct (lookup_constructor Σ) as [ [[]] | ] eqn:E'; invs Heq.
+ erewrite extends_lookup_constructor; eauto. cbn.
+ destruct (chop (cstr_nargs c) (map (transform_blocks Σ') v) ) eqn:Ec.
+ rewrite !chop_firstn_skipn in E, Ec. invs E. invs Ec.
+ f_equal. f_equal. f_equal. solve_all. f_equal. solve_all.
+ - rewrite wellformed_mkApps in H0 => //. cbn -[lookup_constructor] in H0. rtoProp.
+ unfold lookup_constructor_pars_args in Heq.
+ destruct lookup_constructor as [ [[]] | ]; cbn in *; try congruence.
+Qed.
+
+Lemma transform_wellformed Σ n t :
+ wf_glob Σ ->
+ @wellformed env_flags Σ n t ->
+ isEtaExp Σ t ->
+ @wellformed env_flags_blocks (transform_blocks_env Σ) n (transform_blocks Σ t).
+Proof.
+ intros. eapply gen_transform_wellformed_irrel; eauto.
+ 2:{eapply transform_wellformed'; eauto. }
+ eapply transform_blocks_extends.
+Qed.
+
+Lemma transform_wf_global Σ :
+ EEtaExpanded.isEtaExp_env Σ ->
+ @wf_glob env_flags Σ ->
+ @wf_glob env_flags_blocks (transform_blocks_env Σ).
+Proof.
+ intros pre.
+ eapply gen_transform_env_wf => //.
+ 2:{ intros. eapply transform_wellformed'; eauto. eapply H1. }
+ { eapply transform_blocks_extends. }
+
+ induction Σ as [ | ]; cbn in *; eauto.
+ rtoProp. destruct a. cbn in *. split; eauto.
+ destruct g; cbn in *; eauto.
+ unfold isEtaExp_constant_decl in H.
+ destruct (cst_body c); eauto.
+Qed.
+
+Transparent transform_blocks.
+
+Lemma transform_blocks_eval (fl := EWcbvEval.target_wcbv_flags) :
+ forall Σ, isEtaExp_env Σ -> wf_glob Σ ->
+ forall t t',
+ wellformed Σ 0 t ->
+ isEtaExp Σ t ->
+ EWcbvEval.eval Σ t t' ->
+ @EWcbvEval.eval block_wcbv_flags (transform_blocks_env Σ) (transform_blocks Σ t) (transform_blocks Σ t').
+Proof.
+ intros Σ etaΣ wfΣ.
+ eapply
+ (EWcbvEvalEtaInd.eval_preserve_mkApps_ind fl eq_refl (efl := env_flags) Σ _
+ (wellformed Σ) (Qpres := Qpreserves_wellformed _ wfΣ)) => //; eauto.
+ { intros. eapply EWcbvEval.eval_wellformed => //; tea. }
+ all:intros *.
+ - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end.
+ eapply transform_blocks_tApp. eauto. { cbn. rtoProp; eauto. }
+ destruct decompose_app as [fn args] eqn:heq.
+ destruct construct_viewc eqn:heqv.
+ + destruct lookup_constructor_pars_args as [[[] args']|] => // /=.
+ destruct chop eqn:eqch.
+ intros [Hl [ha ht]]. rewrite ha in H.
+ destruct with_constructor_as_block eqn:E.
+ * eapply eval_mkApps_Construct_block_inv in H as (args'' & Ha1 & Ha2 & Ha3); eauto. congruence.
+ * rewrite ha in i3. rewrite wellformed_mkApps in i3; eauto. rtoProp. cbn [wellformed] in H0.
+ rtoProp. destruct lookup_constructor as [ [[]] | ] eqn:hel; cbn in H4; try congruence.
+ eapply eval_mkApps_Construct_inv in H as (args'' & Ha1 & Ha2 & -> & ?); eauto.
+ solve_discr.
+ + econstructor; tea.
+ - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end.
+ eapply transform_blocks_tApp. eauto. cbn. rtoProp; eauto.
+ destruct decompose_app as [fn args] eqn:heq.
+ destruct construct_viewc eqn:heqv.
+ + destruct lookup_constructor_pars_args as [[] |] => // /=.
+ destruct n0; eauto.
+ destruct chop eqn:eqch.
+ intros [Hl [ha ht]]. rewrite ha in H.
+ destruct with_constructor_as_block eqn:E.
+ * eapply eval_mkApps_Construct_block_inv in H as (args'' & Ha1 & Ha2 & Ha3); eauto. congruence.
+ * rewrite ha in i7. rewrite wellformed_mkApps in i7; eauto. rtoProp. cbn [wellformed] in H0.
+ rtoProp. destruct lookup_constructor as [ [[]] | ] eqn:hel; cbn in H5; try congruence.
+ eapply eval_mkApps_Construct_inv in H as (args'' & Ha1 & Ha2 & -> & ?); eauto.
+ solve_discr.
+ + econstructor.
+ * revert e1. set (x := transform_blocks Σ f0).
+ simp transform_blocks.
+ * eauto.
+ * rewrite transform_blocks_csubst in e; eauto.
+ 1: now simp_eta in i10.
+ now rewrite - transform_blocks_equation_1.
+ - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end.
+ simp transform_blocks. rewrite -!transform_blocks_equation_1.
+ econstructor; eauto.
+ rewrite -transform_blocks_csubst; eauto.
+ - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end.
+ simp transform_blocks. rewrite -!transform_blocks_equation_1.
+ cbn [plus].
+ rewrite transform_blocks_mkApps in e0 => //.
+ assert (pars = 0) as -> by now (eapply constructor_isprop_pars_decl_params; eauto).
+ cbn [construct_viewc] in e0.
+ pose proof (Hcon := H2).
+ rewrite /constructor_isprop_pars_decl in H2.
+ destruct lookup_constructor as [[[]] | ] eqn:eqc; cbn in H2; invs H2.
+ rewrite -> lookup_constructor_pars_args_cstr_arity with (1 := eqc) in e0.
+ erewrite chop_all in e0. 2:len.
+ eapply eval_iota_block => //.
+ + cbn [fst]. eapply e0.
+ + unfold constructor_isprop_pars_decl.
+ rewrite lookup_constructor_transform_blocks. cbn [fst].
+ rewrite eqc //= H8 //.
+ + now rewrite map_InP_spec nth_error_map H3; eauto.
+ + len.
+ + rewrite H9. len.
+ + rewrite wellformed_mkApps in i4 => //.
+ rewrite isEtaExp_Constructor in i6 => //. rtoProp.
+ rewrite -transform_blocks_iota_red.
+ * solve_all.
+ * solve_all.
+ * eapply forallb_nth_error in H. rewrite -> H3 in H => //.
+ * now rewrite H9.
+ - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end.
+ eapply transform_blocks_tApp. eauto. eauto; cbn; rtoProp; eauto.
+ destruct decompose_app as [ f args] eqn:heq.
+ destruct construct_viewc eqn:heqv.
+ + destruct lookup_constructor_pars_args as [[] |] => // /=.
+ destruct n0; eauto.
+ destruct chop eqn:eqch.
+ intros [Hl [ha ht]]. rewrite ha in H0.
+ destruct with_constructor_as_block eqn:E.
+ * eapply eval_mkApps_Construct_block_inv in H0 as (args'' & Ha1 & Ha2 & Ha3); eauto. congruence.
+ * rewrite ha in i7. rewrite wellformed_mkApps in i7; eauto. rtoProp. cbn [wellformed] in H1.
+ rtoProp. destruct lookup_constructor as [ [[]] | ] eqn:hel; cbn in H9; try congruence.
+ eapply eval_mkApps_Construct_inv in H0 as (args'' & Ha1 & Ha2 & -> & ?); eauto.
+ solve_discr.
+ + eapply eval_fix'.
+ * eauto.
+ * revert e1. set (x := transform_blocks Σ f5).
+ simp transform_blocks.
+ * rewrite map_InP_spec.
+ cbn in i8. unfold wf_fix in i8. rtoProp.
+ erewrite <- transform_blocks_cunfold_fix => //.
+ all: eauto.
+ eapply closed_fix_subst. solve_all. destruct x; cbn in H5 |- *. eauto.
+ simp_eta in i10.
+ * eauto.
+ * revert e.
+ eapply transform_blocks_tApp => //.
+ -- cbn. rtoProp. split; eauto. eapply wellformed_cunfold_fix; eauto.
+ -- destruct (decompose_app (tApp fn av)) eqn:E; eauto.
+ destruct (construct_viewc t0) eqn:E1; eauto.
+ destruct (lookup_constructor_pars_args Σ ind n) as [ [[ ]] | ] eqn:E2; eauto.
+ cbn zeta. destruct chop eqn:E3. intros (? & ? & ?).
+ subst. rewrite -> H7 in *. intros He.
+ eapply eval_mkApps_Construct_block_inv in He as (? & ? & ? & ?); eauto. subst.
+ rewrite -[tApp _ _](mkApps_app _ _ [last l av]) in i1.
+ rewrite H7 - remove_last_last in i1 => //.
+ rewrite isEtaExp_Constructor in i1. rtoProp.
+ rewrite isEtaExp_Constructor in H3. rtoProp.
+ unfold isEtaExp_app in *.
+ rewrite E2 in H3, H5.
+ eapply leb_complete in H3, H5.
+ exfalso.
+ enough (n0 >= #|l|).
+ { destruct l; try congruence. rewrite remove_last_length in H3. cbn in H5, H3, H13. lia. }
+ destruct (chop n0 l) eqn:Ec.
+ erewrite chop_map in E3 => //. 2: eauto.
+ inversion E3. subst. destruct l2; invs H15.
+ rewrite chop_firstn_skipn in Ec. invs Ec.
+ eapply PCUICSR.skipn_nil_length in H15. lia.
+ - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end.
+ simp transform_blocks. rewrite -!transform_blocks_equation_1.
+ rewrite map_InP_spec. cbn [plus].
+ eapply eval_wellformed in H2; eauto.
+ rewrite wellformed_mkApps in H2; eauto.
+ rtoProp. now cbn in H2.
+ - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end.
+ simp transform_blocks. rewrite -!transform_blocks_equation_1.
+ econstructor.
+ eapply transform_blocks_declared_constant; eauto.
+ destruct decl. cbn in *. now rewrite H0.
+ eauto.
+ - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end.
+ eapply transform_blocks_tApp; eauto. cbn; rtoProp; eauto.
+ destruct decompose_app as [ f args] eqn:heq.
+ destruct construct_viewc eqn:heqv.
+ + destruct lookup_constructor_pars_args as [[npars args']|] eqn:hl => // /=.
+ destruct npars; eauto.
+ destruct chop eqn:eqch.
+ intros [Hl [ha ht]]. pose proof ev as Hev. rewrite ha in Hev.
+ destruct with_constructor_as_block eqn:E.
+ * eapply eval_mkApps_Construct_block_inv in Hev as (args'' & Ha1 & Ha2 & Ha3); eauto. subst.
+ destruct args as [ | []]; cbn in *; congruence.
+ * rewrite ha in i3. rewrite wellformed_mkApps in i3; eauto. rtoProp. cbn [wellformed] in H.
+ rtoProp. destruct lookup_constructor as [ [[]] | ] eqn:hel; cbn in H6; try congruence.
+ eapply eval_mkApps_Construct_inv in Hev as (args'' & Ha1 & Ha2 & -> & ?); eauto. subst.
+ rewrite isConstructApp_mkApps in H1. rewrite orb_true_r in H1 => //.
+ + eapply transform_blocks_tApp; eauto. cbn; rtoProp; eauto.
+ destruct (decompose_app (tApp f' a')). destruct (construct_viewc t0).
+ * destruct lookup_constructor_pars_args as [ [[]] | ] eqn:hpa; eauto.
+ cbn [plus]. destruct chop eqn:heqch.
+ intros [hl [ht ha]]. rewrite ht in H1. rewrite isConstructApp_mkApps orb_true_r in H1 => //.
+ * eapply eval_app_cong; eauto.
+ revert H1.
+ destruct f'; try now cbn; tauto.
+ intros H. cbn in H.
+ rewrite transform_blocks_isConstructApp; eauto.
+ destruct (isConstructApp (tApp f'1 f'2)).
+ -- cbn in H. congruence.
+ -- eapply transform_blocks_tApp; eauto. clear.
+ destruct decompose_app.
+ destruct construct_viewc; try now cbn; eauto.
+ destruct lookup_constructor_pars_args as [[[]] | ]; eauto.
+ cbn. destruct chop. cbn. intros.
+ destruct l1 using rev_case; cbn; eauto.
+ rewrite mkApps_app; cbn; eauto.
+ - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end.
+ simp transform_blocks. rewrite -!transform_blocks_equation_1.
+ rewrite !transform_blocks_mkApps => //.
+ cbn [construct_viewc].
+ erewrite lookup_constructor_pars_args_cstr_arity; eauto.
+ destruct (chop (cstr_nargs cdecl) args) eqn:E1.
+ destruct (chop (cstr_nargs cdecl) args') eqn:E2.
+ erewrite !chop_map; eauto.
+ specialize H as Heq.
+ unfold lookup_constructor, lookup_inductive, lookup_minductive in Heq.
+ destruct lookup_env eqn:E; try now inv Heq.
+ eapply lookup_env_wellformed in E; eauto.
+ destruct g; cbn in Heq; try now inv Heq.
+ cbn in E.
+ destruct nth_error; try now inv Heq.
+ destruct nth_error; invs Heq.
+ rewrite /wf_minductive in E. rtoProp.
+ cbn in H4. eapply eqb_eq in H4.
+ unfold cstr_arity in H0.
+ rewrite -> H4 in *. cbn in H0.
+ revert E1 E2.
+ rewrite <- H0.
+ rewrite !chop_firstn_skipn !firstn_all. intros [= <- <-] [= <- <-].
+ eapply All2_length in X0 as Hlen.
+ cbn.
+ rewrite !skipn_all Hlen skipn_all firstn_all. cbn.
+ eapply eval_mkApps_Construct_block; tea. eauto.
+ now rewrite lookup_constructor_transform_blocks.
+ constructor. cbn [atom]. now rewrite lookup_constructor_transform_blocks H.
+ len. unfold cstr_arity. lia.
+ solve_all. destruct H6; eauto.
+ - intros. econstructor. destruct t; try solve [cbn in H, H0 |- *; try congruence].
+ cbn -[lookup_constructor] in H |- *. destruct l => //. now rewrite lookup_constructor_transform_blocks H.
+Qed.
diff --git a/erasure/theories/EDeps.v b/erasure/theories/EDeps.v
index 1b72d5c12..90399e1a8 100644
--- a/erasure/theories/EDeps.v
+++ b/erasure/theories/EDeps.v
@@ -57,6 +57,8 @@ Proof.
now constructor.
- depelim er.
now constructor.
+ - depelim er.
+ econstructor; eauto.
- depelim er.
econstructor; eauto.
induction X; [easy|].
@@ -105,6 +107,8 @@ Proof.
now constructor.
- depelim er.
now constructor.
+ - depelim er.
+ econstructor; eauto.
- depelim er.
econstructor; eauto.
induction X; [easy|].
@@ -160,6 +164,8 @@ Proof.
now constructor.
- depelim er.
now constructor.
+ - depelim er.
+ cbn. econstructor; eauto.
- depelim er.
econstructor; [easy|easy|easy|easy|easy|].
induction X; [easy|].
@@ -253,7 +259,7 @@ Qed.
Notation "Σ ⊢ s ▷ t" := (eval Σ s t) (at level 50, s, t at next level) : type_scope.
-Lemma erases_deps_eval {wfl:WcbvFlags} Σ t v Σ' :
+Lemma erases_deps_eval {wfl:WcbvFlags} {hcon : with_constructor_as_block = false} Σ t v Σ' :
Σ' ⊢ t ▷ v ->
erases_deps Σ Σ' t ->
erases_deps Σ Σ' v.
@@ -275,8 +281,9 @@ Proof.
+ intuition auto.
apply erases_deps_mkApps_inv in H4.
now apply Forall_rev, Forall_skipn.
- + eapply nth_error_forall in e0; [|now eauto].
+ + eapply nth_error_forall in e1; [|now eauto].
assumption.
+ - congruence.
- depelim er.
subst brs; cbn in *.
depelim H3.
@@ -326,10 +333,12 @@ Proof.
intuition auto.
apply erases_deps_mkApps_inv in H3 as (? & ?).
apply IHev2.
- now eapply nth_error_forall in e1.
+ now eapply nth_error_forall in e2.
+ - congruence.
- constructor.
- depelim er.
now constructor.
+ - congruence.
- depelim er. now constructor.
- easy.
Qed.
@@ -367,7 +376,7 @@ Lemma erases_deps_forall_ind Σ Σ'
declared_constructor Σ' (ind, c) mdecl' idecl' cdecl' ->
erases_one_inductive_body idecl idecl' ->
erases_mutual_inductive_body mdecl mdecl' ->
- P (Extract.E.tConstruct ind c))
+ P (Extract.E.tConstruct ind c []))
(Hcase : forall (p : inductive × nat) mdecl idecl mdecl' idecl' (discr : Extract.E.term) (brs : list (list name × Extract.E.term)),
PCUICAst.declared_inductive Σ (fst p) mdecl idecl ->
EGlobalEnv.declared_inductive Σ' (fst p) mdecl' idecl' ->
diff --git a/erasure/theories/EEtaExpanded.v b/erasure/theories/EEtaExpanded.v
index f43c00455..42b442e59 100644
--- a/erasure/theories/EEtaExpanded.v
+++ b/erasure/theories/EEtaExpanded.v
@@ -26,15 +26,15 @@ Hint Constructors eval : core.
Import MCList (map_InP, map_InP_elim, map_InP_spec).
Equations discr_construct (t : term) : Prop :=
-discr_construct (tConstruct ind n) := False ;
+discr_construct (tConstruct ind n block_args) := False ;
discr_construct _ := True.
Inductive construct_view : term -> Type :=
-| view_construct : forall ind n, construct_view (tConstruct ind n)
+| view_construct : forall ind n block_args, construct_view (tConstruct ind n block_args)
| view_other : forall t, discr_construct t -> construct_view t.
Equations construct_viewc t : construct_view t :=
-construct_viewc (tConstruct ind n) := view_construct ind n ;
+construct_viewc (tConstruct ind n block_args) := view_construct ind n block_args ;
construct_viewc t := view_other t I.
Ltac toAll :=
@@ -55,6 +55,8 @@ Section isEtaExp.
Import TermSpineView.
+ Definition is_nil {A} (l : list A) := match l with [] => true | _ => false end.
+
Equations? isEtaExp (e : EAst.term) : bool
by wf e (fun x y : EAst.term => size x < size y) :=
| e with TermSpineView.view e := {
@@ -62,7 +64,7 @@ Section isEtaExp.
| tEvar ev args => forallb_InP args (fun x H => isEtaExp x)
| tLambda na M => isEtaExp M
| tApp u v napp nnil with construct_viewc u :=
- { | view_construct ind i => isEtaExp_app ind i (List.length v) && forallb_InP v (fun x H => isEtaExp x)
+ { | view_construct ind i block_args => isEtaExp_app ind i (List.length v) && forallb_InP v (fun x H => isEtaExp x) && is_nil block_args
| view_other _ _ => isEtaExp u && forallb_InP v (fun x H => isEtaExp x) }
| tLetIn na b b' => isEtaExp b && isEtaExp b'
| tCase ind c brs => isEtaExp c && forallb_InP brs (fun x H => isEtaExp x.2)
@@ -72,15 +74,16 @@ Section isEtaExp.
| tBox => true
| tVar _ => true
| tConst _ => true
- | tConstruct ind i => isEtaExp_app ind i 0 }.
+ | tConstruct ind i block_args => isEtaExp_app ind i 0 && is_nil block_args }.
Proof.
all:try lia.
all:try apply (In_size); tea.
all:try lia.
- now apply (In_size id size).
- rewrite size_mkApps.
- change (fun x => size (id x)) with size in H. cbn.
- now apply (In_size id size).
+ eapply (In_size id size) in H.
+ change (fun x => size (id x)) with size in H. unfold id in *; cbn.
+ lia.
- now eapply size_mkApps_f.
- change (fun x => size (id x)) with size in H.
eapply (In_size id size) in H. unfold id in H.
@@ -102,7 +105,7 @@ Section isEtaExp.
Lemma isEtaExp_mkApps_nonnil f v :
~~ isApp f -> v <> [] ->
isEtaExp (mkApps f v) = match construct_viewc f with
- | view_construct ind i => isEtaExp_app Σ ind i #|v| && forallb isEtaExp v
+ | view_construct ind i block_args => isEtaExp_app Σ ind i #|v| && forallb isEtaExp v && is_nil block_args
| view_other t discr => isEtaExp f && forallb isEtaExp v
end.
Proof using Type.
@@ -114,7 +117,7 @@ Section isEtaExp.
Lemma isEtaExp_mkApps_napp f v : ~~ isApp f ->
isEtaExp (mkApps f v) = match construct_viewc f with
- | view_construct ind i => isEtaExp_app Σ ind i #|v| && forallb isEtaExp v
+ | view_construct ind i block_args => isEtaExp_app Σ ind i #|v| && forallb isEtaExp v && is_nil block_args
| view_other t discr => isEtaExp f && forallb isEtaExp v
end.
Proof using Type.
@@ -124,8 +127,8 @@ Section isEtaExp.
- rewrite isEtaExp_mkApps_nonnil //.
Qed.
- Lemma isEtaExp_Constructor ind i v :
- isEtaExp (mkApps (EAst.tConstruct ind i) v) = isEtaExp_app Σ ind i #|v| && forallb isEtaExp v.
+ Lemma isEtaExp_Constructor ind i v block_args :
+ isEtaExp (mkApps (EAst.tConstruct ind i block_args) v) = isEtaExp_app Σ ind i #|v| && forallb isEtaExp v && is_nil block_args.
Proof using Type.
rewrite isEtaExp_mkApps_napp //.
Qed.
@@ -134,7 +137,7 @@ Section isEtaExp.
Lemma isEtaExp_mkApps f u : isEtaExp (mkApps f u) ->
let (hd, args) := decompose_app (mkApps f u) in
match construct_viewc hd with
- | view_construct kn c => isEtaExp_app Σ kn c #|args| && forallb isEtaExp args
+ | view_construct kn c block_args => isEtaExp_app Σ kn c #|args| && forallb isEtaExp args && is_nil block_args
| view_other u discr => isEtaExp hd && forallb isEtaExp args
end.
Proof using Type.
@@ -143,7 +146,7 @@ Section isEtaExp.
pose proof (decompose_app_notApp _ _ _ da).
destruct l. cbn -[isEtaExp].
intros eq; rewrite eq.
- destruct (construct_viewc t) => //. simp isEtaExp in eq; now rewrite eq.
+ destruct (construct_viewc t) => //. simp isEtaExp in eq. rtoProp. solve_all.
assert (t0 :: l <> []) by congruence.
revert da H0. generalize (t0 :: l). clear t0 l; intros l.
intros da nnil.
@@ -179,9 +182,9 @@ Section isEtaExp.
Lemma isEtaExp_tApp {f u} : isEtaExp (EAst.tApp f u) ->
let (hd, args) := decompose_app (EAst.tApp f u) in
match construct_viewc hd with
- | view_construct kn c =>
+ | view_construct kn c block_args =>
args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\
- isEtaExp_app Σ kn c #|args| && forallb isEtaExp args
+ isEtaExp_app Σ kn c #|args| && forallb isEtaExp args && is_nil block_args
| view_other _ discr =>
[&& isEtaExp hd, forallb isEtaExp args, isEtaExp f & isEtaExp u]
end.
@@ -232,17 +235,19 @@ Section WeakEtaExp.
pose proof (decompose_app_notApp _ _ _ da).
destruct l0. simp_eta.
- rewrite isEtaExp_mkApps_napp //.
- destruct construct_viewc. cbn. len.
- rtoProp; repeat solve_all. cbn in et. simp isEtaExp in et.
+ destruct construct_viewc. cbn. len.
+ rtoProp; repeat solve_all. cbn in et. rtoProp. rename H0 into et. simp isEtaExp in et.
eapply isEtaExp_app_mon; tea; lia.
- eapply All_app_inv; eauto. rewrite et forallb_app /=.
+ eapply All_app_inv; eauto.
+ cbn in et. rtoProp. rename H0 into et. simp isEtaExp in et.
+ rewrite et forallb_app /=.
rtoProp; repeat solve_all.
- rewrite isEtaExp_mkApps_napp in et => //.
destruct construct_viewc.
rewrite -mkApps_app. rewrite isEtaExp_Constructor.
- cbn. cbn. rtoProp; solve_all.
- eapply isEtaExp_app_mon; tea. cbn. len. now depelim H1.
- depelim H1. solve_all. eapply All_app_inv => //.
+ rtoProp; solve_all.
+ eapply isEtaExp_app_mon; tea. cbn. len. solve_all. depelim H2.
+ solve_all. eapply All_app_inv => //. econstructor; eauto.
eapply All_app_inv => //. eauto.
rewrite -mkApps_app. rewrite isEtaExp_mkApps_napp //.
destruct (construct_viewc t0) => //.
@@ -259,6 +264,7 @@ Section WeakEtaExp.
- intros. simp isEtaExp ; cbn. destruct Nat.compare => //. simp_eta in H.
- move/andP: H2 => [] etab etab'.
apply/andP. split; eauto.
+ - rtoProp. intuition eauto. now destruct block_args.
- rtoProp. intuition eauto.
solve_all.
- move/andP: b => [] etaexp h.
@@ -269,6 +275,7 @@ Section WeakEtaExp.
rewrite csubst_mkApps /=.
rewrite isEtaExp_Constructor. solve_all.
rewrite map_length. rtoProp; solve_all. solve_all.
+ now destruct block_args.
- rewrite csubst_mkApps /=.
move/andP: H2 => [] eu ev.
specialize (H _ k H1 eu).
@@ -459,7 +466,7 @@ Inductive expanded : term -> Prop :=
declared_constructor Σ (ind, idx) mind idecl cdecl ->
#|args| >= cstr_arity mind cdecl ->
Forall expanded args ->
- expanded (mkApps (tConstruct ind idx) args)
+ expanded (mkApps (tConstruct ind idx []) args)
| expanded_tBox : expanded tBox.
End expanded.
@@ -497,7 +504,7 @@ forall (Σ : global_declarations) (P : term -> Prop),
(idecl : one_inductive_body) cdecl
(args : list term),
declared_constructor Σ (ind, idx) mind idecl cdecl ->
- #|args| >= cstr_arity mind cdecl -> Forall (expanded Σ) args -> Forall P args -> P (mkApps (tConstruct ind idx) args)) ->
+ #|args| >= cstr_arity mind cdecl -> Forall (expanded Σ) args -> Forall P args -> P (mkApps (tConstruct ind idx []) args)) ->
(P tBox) ->
forall t : term, expanded Σ t -> P t.
Proof.
@@ -570,7 +577,8 @@ Proof.
- rewrite forallb_InP_spec in H0. eapply forallb_Forall in H0. eapply In_All in H.
econstructor. solve_all.
- eapply andb_true_iff in H1 as []; eauto.
- - eapply isEtaExp_app_expanded in H as (? & ? & ? & ? & ?).
+ - rtoProp. eapply isEtaExp_app_expanded in H as (? & ? & ? & ? & ?).
+ destruct block_args; inv H0.
eapply expanded_tConstruct_app with (args := []); eauto.
- eapply andb_true_iff in H1 as []. destruct ind. econstructor; eauto.
rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2.
@@ -581,9 +589,10 @@ Proof.
intuition auto.
- econstructor. rewrite forallb_InP_spec in H0. eapply forallb_Forall in H0.
eapply In_All in H. solve_all.
- - eapply andb_true_iff in H0 as []. eapply In_All in H.
- rewrite forallb_InP_spec in H1. eapply forallb_Forall in H1.
+ - rtoProp. eapply In_All in H.
+ rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2.
eapply isEtaExp_app_expanded in H0 as (? & ? & ? & ? & ?).
+ destruct block_args; inv H1.
eapply expanded_tConstruct_app; eauto. solve_all.
- eapply andb_true_iff in H1 as []. rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2.
econstructor.
@@ -603,8 +612,8 @@ Proof.
eauto).
- eapply isEtaExp_mkApps_intro; eauto. solve_all.
- solve_all. now rewrite b H.
- - rewrite isEtaExp_Constructor. eapply andb_true_iff.
- split. 2: eapply forallb_Forall.
+ - rewrite isEtaExp_Constructor. rtoProp; repeat split.
+ 2: eapply forallb_Forall.
2: solve_all. eapply expanded_isEtaExp_app_; eauto.
Qed.
@@ -668,8 +677,8 @@ Proof.
eapply In_All in H0; solve_all.
- eapply In_All in H. simp_eta; rtoProp; intuition auto. solve_all.
- eapply In_All in H. simp_eta; rtoProp; intuition auto.
- rewrite EEtaExpanded.isEtaExp_Constructor. apply/andP; split. exact H1.
- solve_all.
+ rewrite EEtaExpanded.isEtaExp_Constructor. rtoProp; repeat split. eauto.
+ solve_all. destruct block_args; cbn in *; eauto.
- eapply In_All in H, H0. simp_eta.
move => /andP[] /andP[] etafix etamfix etav.
eapply EEtaExpanded.isEtaExp_mkApps_intro. simp_eta.
diff --git a/erasure/theories/EEtaExpandedFix.v b/erasure/theories/EEtaExpandedFix.v
index 6ec3fffb5..0e3a1cce9 100644
--- a/erasure/theories/EEtaExpandedFix.v
+++ b/erasure/theories/EEtaExpandedFix.v
@@ -58,7 +58,7 @@ Inductive expanded (Γ : list nat): term -> Prop :=
declared_constructor Σ (ind, idx) mind idecl cdecl ->
#|args| >= ind_npars mind + cdecl.(cstr_nargs) ->
Forall (expanded Γ) args ->
- expanded Γ (mkApps (tConstruct ind idx) args)
+ expanded Γ (mkApps (tConstruct ind idx []) args)
| expanded_tBox : expanded Γ tBox.
End expanded.
@@ -135,7 +135,7 @@ Lemma expanded_ind :
→ #|args| ≥ ind_npars mind + cdecl.(cstr_nargs)
→ Forall (expanded Σ Γ) args
→ Forall (P Γ) args
- → P Γ (mkApps (tConstruct ind idx) args))
+ → P Γ (mkApps (tConstruct ind idx []) args))
→ (∀ Γ : list nat, P Γ tBox)
→ ∀ (Γ : list nat) (t : term), expanded Σ Γ t → P Γ t.
Proof.
@@ -225,19 +225,19 @@ Proof.
Qed.
Equations discr_expanded_head (t : term) : Prop :=
- discr_expanded_head (tConstruct ind n) := False ;
+ discr_expanded_head (tConstruct ind n block_args) := False ;
discr_expanded_head (tFix mfix idx) := False ;
discr_expanded_head (tRel n) := False ;
discr_expanded_head _ := True.
Inductive expanded_head_view : term -> Type :=
-| expanded_head_construct : forall ind n, expanded_head_view (tConstruct ind n)
+| expanded_head_construct : forall ind n block_args, expanded_head_view (tConstruct ind n block_args)
| expanded_head_fix : forall mfix idx, expanded_head_view (tFix mfix idx)
| expanded_head_rel : forall n, expanded_head_view (tRel n)
| expanded_head_other : forall t, discr_expanded_head t -> expanded_head_view t.
Equations expanded_head_viewc t : expanded_head_view t :=
- expanded_head_viewc (tConstruct ind n) := expanded_head_construct ind n ;
+ expanded_head_viewc (tConstruct ind n block_args) := expanded_head_construct ind n block_args;
expanded_head_viewc (tFix mfix idx) := expanded_head_fix mfix idx ;
expanded_head_viewc (tRel n) := expanded_head_rel n ;
expanded_head_viewc t := expanded_head_other t I.
@@ -266,6 +266,8 @@ Section isEtaExp.
Import TermSpineView.
+ Definition is_nil {A} (l : list A) := match l with nil => true | _ => false end.
+
Equations? isEtaExp (Γ : list nat) (e : EAst.term) : bool
by wf e (fun x y : EAst.term => size x < size y) :=
isEtaExp Γ e with TermSpineView.view e := {
@@ -273,7 +275,7 @@ Section isEtaExp.
| tEvar ev args => forallb_InP args (fun x H => isEtaExp Γ x)
| tLambda na M => isEtaExp (0 :: Γ) M
| tApp u v napp nnil with expanded_head_viewc u :=
- { | expanded_head_construct ind i => isEtaExp_app ind i (List.length v) && forallb_InP v (fun x H => isEtaExp Γ x)
+ { | expanded_head_construct ind i block_args => isEtaExp_app ind i (List.length v) && forallb_InP v (fun x H => isEtaExp Γ x) && is_nil block_args
| expanded_head_fix mfix idx =>
isEtaExp_fixapp mfix idx (List.length v) &&
forallb_InP mfix (fun x H => isLambda x.(dbody) && isEtaExp (rev_map (S ∘ rarg) mfix ++ Γ) x.(dbody)) && forallb_InP v (fun x H => isEtaExp Γ x)
@@ -287,14 +289,15 @@ Section isEtaExp.
| tBox => true
| tVar _ => true
| tConst _ => true
- | tConstruct ind i => isEtaExp_app ind i 0 }.
+ | tConstruct ind i block_args => isEtaExp_app ind i 0 && is_nil block_args }.
Proof using Σ.
all:try lia.
all:try apply (In_size); tea.
all:try lia.
- now apply (In_size id size).
- - rewrite size_mkApps.
- now apply (In_size id size).
+ - rewrite size_mkApps. cbn.
+ apply (In_size id size) in H.
+ unfold id in H. change (fun x => size x) with size in H. lia.
- rewrite size_mkApps.
apply (In_size id (fun d => size d.(dbody))) in H. unfold id in H.
change (fun x => size x) with size in H. cbn. lia.
@@ -325,7 +328,7 @@ Section isEtaExp.
Lemma isEtaExp_mkApps_nonnil Γ f v :
~~ isApp f -> v <> [] ->
isEtaExp Γ (mkApps f v) = match expanded_head_viewc f with
- | expanded_head_construct ind i => isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v
+ | expanded_head_construct ind i block_args => isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v && is_nil block_args
| expanded_head_fix mfix idx => isEtaExp_fixapp mfix idx #|v| &&
forallb (fun x => isLambda x.(dbody) && isEtaExp (rev_map (S ∘ rarg) mfix ++ Γ) x.(dbody)) mfix && forallb (isEtaExp Γ) v
| expanded_head_rel n => option_default (fun m => m <=? List.length v) (nth_error Γ n) false && forallb (fun x => isEtaExp Γ x) v
@@ -345,7 +348,7 @@ Section isEtaExp.
Lemma isEtaExp_mkApps Γ f v : ~~ isApp f ->
isEtaExp Γ (mkApps f v) = match expanded_head_viewc f with
- | expanded_head_construct ind i => isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v
+ | expanded_head_construct ind i block_args => isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v && is_nil block_args
| expanded_head_fix mfix idx =>
isEtaExp_fixapp mfix idx #|v| &&
forallb (fun x => isLambda x.(dbody) && isEtaExp (rev_map (S ∘ rarg) mfix ++ Γ) x.(dbody)) mfix && forallb (isEtaExp Γ) v
@@ -362,8 +365,8 @@ Section isEtaExp.
- rewrite isEtaExp_mkApps_nonnil //.
Qed.
- Lemma isEtaExp_Constructor Γ ind i v :
- isEtaExp Γ (mkApps (EAst.tConstruct ind i) v) = isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v.
+ Lemma isEtaExp_Constructor Γ ind i block_args v :
+ isEtaExp Γ (mkApps (EAst.tConstruct ind i block_args) v) = isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v && is_nil block_args.
Proof.
now rewrite isEtaExp_mkApps.
Qed.
@@ -380,7 +383,7 @@ Section isEtaExp.
- rewrite isEtaExp_mkApps //.
destruct expanded_head_viewc.
+ cbn. len.
- rtoProp; repeat solve_all. cbn in et. simp isEtaExp in et.
+ rtoProp; repeat solve_all; cbn in et; rtoProp; eauto. rename H0 into et. simp isEtaExp in et.
eapply isEtaExp_app_mon; tea; lia.
eapply All_app_inv; eauto.
+ cbn in *; congruence.
@@ -393,9 +396,9 @@ Section isEtaExp.
- rewrite isEtaExp_mkApps in et => //.
destruct expanded_head_viewc.
+ rewrite -mkApps_app. rewrite isEtaExp_Constructor.
- cbn. cbn. rtoProp; solve_all.
- eapply isEtaExp_app_mon; tea. cbn. len. now depelim H1.
- depelim H1. solve_all. eapply All_app_inv => //.
+ rtoProp; solve_all.
+ eapply isEtaExp_app_mon; tea. cbn. len. solve_all. depelim H2.
+ eapply All_app_inv => //. econstructor; eauto.
eapply All_app_inv => //. eauto.
+ rewrite -mkApps_app. rewrite isEtaExp_mkApps //. simp expanded_head_viewc.
rewrite /isEtaExp_fixapp in et |- *.
@@ -439,8 +442,10 @@ Section isEtaExp.
rewrite ?closedn_mkApps; rtoProp; (try toAll); repeat solve_all.
- destruct nth_error eqn:Hn; cbn in H; try easy.
eapply nth_error_Some_length in Hn. now eapply Nat.ltb_lt.
+ - destruct block_args; cbn in *; eauto.
- eapply a in b. 2: f_equal. revert b. now len.
- eapply a in b. 2: f_equal. revert b. now len.
+ - cbn. destruct block_args; cbn in *; eauto.
- cbn. solve_all. rtoProp; intuition auto. eapply a in H0. 2: reflexivity. revert H0. now len.
- destruct nth_error eqn:Hn; cbn in H1; try easy.
eapply nth_error_Some_length in Hn. now eapply Nat.ltb_lt.
@@ -466,6 +471,7 @@ Section isEtaExp.
- move/andP: H2 => [] etab etab'. simp_eta.
apply/andP. split; eauto.
eapply H0 with (Γ := 0 :: Γ0); cbn; eauto.
+ - rtoProp. intuition eauto. destruct block_args; cbn in *; eauto.
- rtoProp. intuition eauto.
solve_all. rewrite app_assoc. eapply a0; cbn; eauto. now len. cbn.
now rewrite app_assoc.
@@ -473,7 +479,7 @@ Section isEtaExp.
- fold csubst. move/andP: H1 => [] etaexp h.
rewrite csubst_mkApps /=.
rewrite isEtaExp_Constructor. solve_all.
- rewrite map_length. rtoProp; solve_all. solve_all.
+ rewrite map_length. rtoProp; solve_all. solve_all. destruct block_args; cbn in *; eauto.
- rewrite csubst_mkApps /=.
move/andP : H2 => [] /andP [] eu ef ev.
rewrite isEtaExp_mkApps //.
@@ -504,7 +510,7 @@ Section isEtaExp.
Qed.
Lemma etaExp_csubst a b n :
- isEtaExp []a -> isEtaExp [n] b -> isEtaExp [] (ECSubst.csubst a 0 b).
+ isEtaExp []a -> isEtaExp [n] b -> isEtaExp [] (ECSubst.csubst a 0 b).
Proof.
intros.
eapply etaExp_csubst' with (Γ := []); eauto.
@@ -535,6 +541,7 @@ Section isEtaExp.
apply/andP. split; eauto.
eapply H; eauto. solve_all.
eapply H0 with (Γ := 0 :: Γ0); eauto. solve_all.
+ - rtoProp. intuition eauto. destruct block_args; eauto.
- rtoProp. intuition eauto.
solve_all. rewrite app_assoc. eapply a; cbn-[isEtaExp]; eauto. now len. cbn.
now rewrite app_assoc.
@@ -552,7 +559,7 @@ Section isEtaExp.
eapply All_impl; tea; cbv beta.
intros x Hx.
eapply Hx; eauto.
- solve_all. apply Hx.
+ solve_all. apply Hx. now destruct block_args.
- solve_all. rewrite csubst_mkApps /=.
move/andP : H2 => [] /andP [] eu ef ev.
rewrite isEtaExp_mkApps //.
@@ -730,7 +737,7 @@ Section isEtaExp.
Lemma isEtaExp_tApp Γ f u : isEtaExp Γ (mkApps f u) ->
let (hd, v) := decompose_app (mkApps f u) in
match expanded_head_viewc hd with
- | expanded_head_construct ind i => isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v
+ | expanded_head_construct ind i block_args => isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v && is_nil block_args
| expanded_head_fix mfix idx => isEtaExp_fixapp mfix idx #|v| &&
forallb (fun x => isLambda x.(dbody) && isEtaExp (rev_map (S ∘ rarg) mfix ++ Γ) x.(dbody)) mfix && forallb (isEtaExp Γ) v
| expanded_head_rel n => (option_default (fun m => m <=? List.length v) (nth_error Γ n) false) && forallb (fun x => isEtaExp Γ x) v
@@ -788,16 +795,18 @@ Proof.
- eapply expanded_tRel_app with (args := []). destruct (nth_error); invs H. f_equal. eapply Nat.eqb_eq in H1; eauto. cbn. lia. econstructor.
- rewrite forallb_InP_spec in H0. eapply forallb_Forall in H0. eapply In_All in H. econstructor. solve_all.
- eapply andb_true_iff in H1 as []; eauto.
- - eapply isEtaExp_app_expanded in H as (? & ? & ? & ? & ?).
+ - rtoProp. eapply isEtaExp_app_expanded in H as (? & ? & ? & ? & ?).
+ destruct block_args; cbn in *; eauto.
eapply expanded_tConstruct_app with (args := []); eauto.
- eapply andb_true_iff in H1 as []. destruct ind. econstructor; eauto.
rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2.
eapply In_All in H0. solve_all.
- econstructor. rewrite forallb_InP_spec in H0. eapply forallb_Forall in H0.
eapply In_All in H. solve_all.
- - eapply andb_true_iff in H0 as []. eapply In_All in H.
- rewrite forallb_InP_spec in H1. eapply forallb_Forall in H1.
+ - rtoProp. eapply In_All in H.
+ rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2.
eapply isEtaExp_app_expanded in H0 as (? & ? & ? & ? & ?).
+ destruct block_args; cbn in *; eauto.
eapply expanded_tConstruct_app; eauto. solve_all.
- rtoProp. rewrite forallb_InP_spec in H2. rewrite forallb_InP_spec in H3. eapply In_All in H. eapply In_All in H0.
unfold isEtaExp_fixapp in H1. destruct nth_error eqn:E; try congruence.
@@ -830,9 +839,9 @@ Proof.
+ unfold isEtaExp_fixapp. rewrite H4. eapply Nat.ltb_lt. lia.
+ solve_all; rtoProp; intuition auto.
+ solve_all.
- - rewrite isEtaExp_Constructor. eapply andb_true_iff.
- split. 2: eapply forallb_Forall.
- 2: solve_all. eapply expanded_isEtaExp_app_; eauto.
+ - rewrite isEtaExp_Constructor. rtoProp. repeat split.
+ 2: eapply forallb_Forall; solve_all.
+ eapply expanded_isEtaExp_app_; eauto.
Qed.
Definition isEtaExp_constant_decl Σ cb :=
@@ -871,9 +880,9 @@ Arguments isEtaExp : simpl never.
Lemma isEtaExp_tApp' {Σ} {Γ} {f u} : isEtaExp Σ Γ (tApp f u) ->
let (hd, args) := decompose_app (tApp f u) in
match expanded_head_viewc hd with
- | expanded_head_construct kn c =>
+ | expanded_head_construct kn c block_args =>
args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\
- isEtaExp_app Σ kn c #|args| && forallb (isEtaExp Σ Γ) args
+ isEtaExp_app Σ kn c #|args| && forallb (isEtaExp Σ Γ) args && is_nil block_args
| expanded_head_fix mfix idx =>
args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\
isEtaExp_fixapp mfix idx #|args| && forallb (fun d => isLambda d.(dbody) && isEtaExp Σ (rev_map (fun d => 1 + d.(rarg)) mfix ++ Γ) d.(dbody)) mfix && forallb (isEtaExp Σ Γ) args
@@ -1008,22 +1017,22 @@ Qed.
Arguments lookup_inductive_pars_constructor_pars_args {Σ ind n pars args}.
-Lemma eval_etaexp {fl : WcbvFlags} {efl : EEnvFlags} {Σ a a'} :
+Lemma eval_etaexp {fl : WcbvFlags} {efl : EEnvFlags} {wcon : with_constructor_as_block = false} {Σ a a'} :
isEtaExp_env Σ ->
wf_glob Σ ->
eval Σ a a' -> isEtaExp Σ [] a -> isEtaExp Σ [] a'.
Proof.
intros etaΣ wfΣ.
- induction 1 as [ | ? ? ? ? ? ? ? ? IHs | | | | ? ? ? ? ? ? ? ? ? ? ? IHs | ? ? ? ? ? ? ? ? ? ? ? IHs
- | ? ? ? ? ? ? ? ? ? ? IHs | | | | | | | | ] using eval_mkApps_rect.
+ induction 1 as [ | ? ? ? ? ? ? ? ? IHs | | | | | ? ? ? ? ? ? ? ? ? ? ? IHs | ? ? ? ? ? ? ? ? ? ? ? IHs
+ | ? ? ? ? ? ? ? ? ? ? IHs | | | | | | | | | | ] using eval_mkApps_rect; try now congruence.
all:try simp isEtaExp; rewrite -!isEtaExp_equation_1 => //.
6:{
move/isEtaExp_tApp'.
destruct decompose_app eqn:da.
destruct expanded_head_viewc eqn:vc.
- * move => [hl [hf [ha /andP[] ise etal]]].
+ * move => [hl [hf [ha /andP[] /andP[] ise etal bargs]]]. destruct block_args; cbn in *; eauto.
pose proof (H' := H).
- rewrite hf in H'. eapply eval_mkApps_Construct_inv in H' as [? []]. exfalso. solve_discr.
+ rewrite hf in H'. eapply eval_mkApps_Construct_inv in H' as [? []]. exfalso. solve_discr. auto.
* move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel.
pose proof (mkApps_app (EAst.tFix mfix idx) argsv [av]).
cbn in H3. rewrite <- H3. clear H3.
@@ -1064,8 +1073,8 @@ Proof.
move/isEtaExp_tApp'.
destruct decompose_app eqn:da.
destruct expanded_head_viewc eqn:vc.
- * move => [hl [hf [ha /andP[] ise etal]]]. clear IHs.
- rewrite hf in H. eapply eval_mkApps_Construct_inv in H as [? []]. exfalso. solve_discr.
+ * move => [hl [hf [ha /andP[] /andP[] ise etal bargs]]]. clear IHs. destruct block_args; inv bargs.
+ rewrite hf in H. eapply eval_mkApps_Construct_inv in H as [? []]. exfalso. solve_discr. auto.
* move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel.
subst.
eapply IHeval3.
@@ -1114,11 +1123,11 @@ Proof.
11:{ move/isEtaExp_tApp'.
destruct decompose_app eqn:da.
destruct expanded_head_viewc.
- * move=> [] hl [] hf [] ha /andP[] hl' etal.
+ * move=> [] hl [] hf [] ha /andP[] /andP[] hl' etal bargs. destruct block_args; inv bargs.
move: H H0. rewrite hf => H H0.
- destruct (eval_construct_size H) as [args' []]. subst f'.
- rewrite isConstructApp_mkApps /= in H1.
- rewrite !negb_or in H1. rtoProp; intuition auto. now cbn in H3.
+ destruct (eval_construct_size wcon H) as [args' []]. subst f'.
+ rewrite isConstructApp_mkApps /= in i.
+ rewrite !negb_or in i. rtoProp; intuition auto. now cbn in H3.
* move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel.
subst.
@@ -1127,7 +1136,7 @@ Proof.
{
specialize eval_mkApps_tFix_inv_size with (Heval := H); intros [(args' & ? & Heq) | (? & ? & ? & ? & ?)]; eauto.
- -- subst. rewrite isFixApp_mkApps in H1 => //. destruct EAst.isLambda; easy.
+ -- subst. rewrite isFixApp_mkApps in i => //. destruct EAst.isLambda; easy.
-- eapply (isEtaExp_mkApps_intro _ _ f' [a']); eauto.
eapply IHeval1. rewrite isEtaExp_mkApps => //.
cbn [expanded_head_viewc]. rtoProp.
@@ -1135,7 +1144,7 @@ Proof.
2: eapply All_firstn; eauto.
unfold isEtaExp_fixapp, cunfold_fix in *.
destruct nth_error; try easy.
- invs H5. eapply Nat.ltb_lt. lia.
+ invs H4. eapply Nat.ltb_lt. lia.
}
{
@@ -1145,7 +1154,7 @@ Proof.
unshelve eapply H0. 2: eauto. lia.
eapply (isEtaExp_mkApps_intro).
eapply (isEtaExp_mkApps_intro _ _ fn [a_']); eauto. 2: econstructor; [ | econstructor].
- ++ eapply isEtaExp_cunfold_fix. 2: eauto. solve_all. now rewrite app_nil_r in H5.
+ ++ eapply isEtaExp_cunfold_fix. 2: eauto. solve_all. now rewrite app_nil_r in H4.
++ solve_all. eapply All_firstn in isel. unfold remove_last in Heq. eapply All_Forall in isel.
setoid_rewrite Heq in isel. invs isel. eauto.
++ eapply forallb_Forall in isel. eapply Forall_firstn in isel. unfold remove_last in Heq.
@@ -1153,7 +1162,7 @@ Proof.
destruct b0. unshelve eapply H0. 2: eauto. lia. eauto.
}
* intros (? & ? & ? & ?). rtoProp. solve_all.
- rewrite nth_error_nil in H6. easy.
+ rewrite nth_error_nil in H5. easy.
* move/and4P => [] etat etal etaf etaa.
eapply (isEtaExp_mkApps_intro _ _ f' [a']); eauto.
}
@@ -1161,64 +1170,65 @@ Proof.
move/isEtaExp_tApp'.
destruct decompose_app eqn:da.
destruct expanded_head_viewc.
- * move=> [] hl [] hf [] ha /andP[] hl' etal.
+ * move=> [] hl [] hf [] ha /andP[] /andP[] hl' etal bargs. destruct block_args; inv bargs.
rewrite -[EAst.tApp _ _](mkApps_app _ _ [a']).
- rewrite isEtaExp_Constructor.
- move: H0 H1. rewrite hf. intros H0 H1.
- destruct (eval_mkApps_Construct_size H0) as [args'' [evc []]].
- eapply mkApps_eq_inj in e as [] => //. subst args''. noconf H3.
+ rewrite isEtaExp_Constructor. cbn. rewrite andb_true_r.
+ revert H H0. rewrite hf. intros H H0.
+ destruct (eval_mkApps_Construct_size wcon H) as [args'' [evc []]].
+ eapply mkApps_eq_inj in e1 as [] => //. subst args''. noconf H2.
apply/andP; split => //.
- + len.
- rewrite (remove_last_last l a) // in hl'.
+ + len.
+ rewrite (remove_last_last l0 a) // in hl'.
rewrite app_length in hl'.
cbn in hl'.
now rewrite -(All2_length a0).
+ solve_all.
- rewrite (remove_last_last l a) // in etal.
+ rewrite (remove_last_last l0 a) // in etal.
eapply All_app in etal as [etal etaa].
depelim etaa. clear etaa. rewrite -ha in i.
eapply All_app_inv; try constructor; eauto.
- clear -H1 a0 etal. solve_all.
- destruct b as [ev Hev]. eapply (H1 _ _ ev) => //. lia.
+ solve_all.
+ destruct b as [ev Hev]. eapply (H0 _ _ ev) => //. lia.
* move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel.
subst.
assert (isEtaExp Σ [] a). { rewrite ha. eapply Forall_last; solve_all. }
destruct with_guarded_fix eqn:guarded.
- { specialize eval_mkApps_tFix_inv_size with (Heval := H0); intros [(args' & ? & Heq) | (? & ? & ? & ? & ?)]; eauto.
+ { specialize eval_mkApps_tFix_inv_size with (Heval := H); intros [(args' & ? & Heq) | (? & ? & ? & ? & ?)]; eauto.
-- subst. solve_discr.
+
-- eapply (isEtaExp_mkApps_intro _ _ _ [a']); eauto.
eapply IHeval1. rewrite isEtaExp_mkApps => //.
cbn [expanded_head_viewc]. rtoProp.
repeat split; solve_all.
2: eapply All_firstn; eauto.
unfold isEtaExp_fixapp, cunfold_fix in *.
- destruct nth_error; try easy. noconf H6.
+ destruct nth_error; try easy. noconf H4.
eapply Nat.ltb_lt. lia.
}
{
- specialize eval_mkApps_tFix_inv_size_unguarded with (Heval := H0); intros Hinv; destruct Hinv as [[Heq Hv] | (a_ & a_' & args' & argsv & Heq & Hall & n & fn & Hunf & Haa' & Hev & Hev' & Hsz)]; eauto.
+ specialize eval_mkApps_tFix_inv_size_unguarded with (Heval := H); intros Hinv; destruct Hinv as [[Heq Hv] | (a_ & a_' & args' & argsv & Heq & Hall & n & fn & Hunf & Haa' & Hev & Hev' & Hsz)]; eauto.
-- cbn in *. solve_discr.
-- eapply (isEtaExp_mkApps_intro _ _ _ [a']); eauto.
- unshelve eapply H1. 2: eauto. lia.
+ unshelve eapply H0. 2: eauto. lia.
eapply (isEtaExp_mkApps_intro).
eapply (isEtaExp_mkApps_intro _ _ fn [a_']); eauto. 2: econstructor; [ | econstructor].
- ++ eapply isEtaExp_cunfold_fix. 2: eauto. solve_all. now rewrite app_nil_r in H6.
+ ++ eapply isEtaExp_cunfold_fix. 2: eauto. solve_all. now rewrite app_nil_r in H4.
++ solve_all. eapply All_firstn in isel. unfold remove_last in Heq. eapply All_Forall in isel.
setoid_rewrite Heq in isel. invs isel. eauto.
++ eapply forallb_Forall in isel. eapply Forall_firstn in isel. unfold remove_last in Heq.
setoid_rewrite Heq in isel. eapply Forall_All in isel. invs isel. solve_all. subst; eauto.
- destruct b0. unshelve eapply H1. 2: eauto. lia. eauto.
+ destruct b0. unshelve eapply H0. 2: eauto. lia. eauto.
}
- * intros (? & ? & ? & ?). rtoProp. solve_all. rewrite nth_error_nil in H7. easy.
- * move/and4P => [] etat etal etaf etaa.
+ * intros (? & ? & ? & ?). rtoProp. solve_all. rewrite nth_error_nil in H5. easy.
+ * move/and4P => [] etat etal etaf etaa.
eapply (isEtaExp_mkApps_intro _ _ _ [a']); eauto.
}
1:{ move/isEtaExp_tApp'.
destruct decompose_app eqn:da.
destruct expanded_head_viewc.
- * clear IHs. move=> [] hl [] hf [] ha /andP[] hl' etal.
+ * clear IHs. move=> [] hl [] hf [] ha /andP[] /andP[] hl' etal bargs. destruct block_args; inv bargs.
move: H H0. rewrite hf => H H0.
- eapply eval_mkApps_Construct_inv in H as [? []];solve_discr.
+ eapply (eval_mkApps_Construct_inv _ _ _ _ _ wcon) in H as [? []];solve_discr.
* solve_all. rtoProp. solve_all. subst.
destruct with_guarded_fix eqn:guarded.
@@ -1265,10 +1275,10 @@ Proof.
eapply IHeval2. rewrite /iota_red.
eapply isEtaExp_substl with (Γ := repeat 0 #|br.1|); eauto.
{ len. }
- rewrite isEtaExp_Constructor // in H5. solve_all.
- eapply All_skipn. move/andP: H5 => []. repeat solve_all.
- eapply forallb_nth_error in H7; tea.
- now erewrite H1 in H7.
+ rewrite isEtaExp_Constructor // in H1. solve_all.
+ eapply All_skipn. move/andP: H1 => []. repeat solve_all. rtoProp. solve_all.
+ eapply forallb_nth_error in H3; tea.
+ now erewrite e2 in H3.
- rtoProp; intuition auto.
eapply IHeval2. eapply isEtaExp_substl. shelve.
now apply forallb_repeat.
@@ -1278,9 +1288,9 @@ Proof.
- move/isEtaExp_tApp'.
destruct decompose_app eqn:da.
destruct expanded_head_viewc.
- * clear IHs. move=> [] hl [] hf [] ha /andP[] hl' etal.
+ * clear IHs. move=> [] hl [] hf [] ha /andP[] /andP[] hl' etal bargs. destruct block_args; inv bargs.
move: H H0. rewrite hf => H H0.
- clear H0; eapply eval_mkApps_Construct_inv in H as [? []]; solve_discr.
+ clear H0; eapply (eval_mkApps_Construct_inv _ _ _ _ _ wcon) in H as [? []]; solve_discr.
* solve_all. rtoProp. solve_all. subst.
specialize eval_mkApps_tFix_inv_size_unguarded with (Heval := H); intros Hinv;
destruct Hinv as [[Heq Heq'] | (a_ & a_' & args' & argsv & Heq & Hall & n & fn_ & Hunf & Hav & Hsza & Hev & Hsz)]; eauto; try congruence.
@@ -1327,9 +1337,9 @@ Proof.
eapply IHeval2. specialize (IHeval1 hd).
move: IHeval1.
rewrite isEtaExp_Constructor.
- destruct args => //. now rewrite nth_error_nil in H2.
- move=> /andP[] _ hargs.
- eapply nth_error_forallb in H2; tea.
+ destruct args => //. now rewrite nth_error_nil in e3.
+ intros. rtoProp.
+ eapply nth_error_forallb in e3; tea.
Qed.
Lemma isEtaExp_fixapp_mon {mfix idx n n'} : n <= n' -> isEtaExp_fixapp mfix idx n -> isEtaExp_fixapp mfix idx n'.
@@ -1465,18 +1475,18 @@ Lemma neval_to_stuck_fix {efl : EEnvFlags} {Σ mfix idx t} :
isEtaExp Σ [] t -> @eval opt_wcbv_flags Σ t (tFix mfix idx) -> False.
Proof.
intros etaΣ wfΣ he hev.
- pose proof (eval_etaexp etaΣ wfΣ hev he).
+ unshelve epose proof (eval_etaexp etaΣ wfΣ hev he). eauto.
now apply isEtaExp_tFix in H.
Qed.
-Lemma neval_to_stuck_fix_app {efl : EEnvFlags} {fl Σ mfix idx t args} :
+Lemma neval_to_stuck_fix_app {efl : EEnvFlags} {fl} {wcon : with_constructor_as_block = false} {Σ mfix idx t args} :
with_guarded_fix ->
isEtaExp_env Σ ->
wf_glob Σ ->
isEtaExp Σ [] t -> @eval fl Σ t (mkApps (tFix mfix idx) args) -> False.
Proof.
intros wguard etaΣ wfΣ he hev.
- pose proof (eval_etaexp etaΣ wfΣ hev he).
+ unshelve epose proof (eval_etaexp etaΣ wfΣ hev he); eauto.
move: H.
move/isEtaExp_tApp.
rewrite decompose_app_mkApps // /= // app_nil_r //.
@@ -1491,13 +1501,14 @@ Qed.
Lemma isEtaExp_tApp_eval {fl} {Σ} {f u v} :
with_guarded_fix ->
+ with_constructor_as_block = false ->
@eval fl Σ f v ->
isEtaExp Σ [] (tApp f u) ->
- (forall kn c args, v <> mkApps (tConstruct kn c) args) ->
+ (forall kn c args block_args, v <> mkApps (tConstruct kn c block_args) args) ->
(forall mfix idx args, v <> mkApps (tFix mfix idx) args) ->
let (hd, args) := decompose_app (tApp f u) in
match expanded_head_viewc hd with
- | expanded_head_construct kn c => False
+ | expanded_head_construct kn c _ => False
| expanded_head_fix mfix idx =>
args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\
[&& isEtaExp_fixapp mfix idx #|remove_last args|,
@@ -1508,14 +1519,14 @@ Lemma isEtaExp_tApp_eval {fl} {Σ} {f u v} :
[&& isEtaExp Σ [] hd, forallb (isEtaExp Σ []) args, isEtaExp Σ [] f & isEtaExp Σ [] u]
end.
Proof.
- intros wguard ev eta; revert eta ev.
+ intros wguard wcon ev eta; revert eta ev.
move/isEtaExp_tApp'.
cbn -[decompose_app]. destruct decompose_app eqn:da.
destruct expanded_head_viewc eqn:cv => //.
- * move=> [] hl [] ha [] ht /andP[] etaap etal.
+ * move=> [] hl [] ha [] ht /andP[] /andP[] etaap etal bargs. destruct block_args; inv bargs.
rewrite ha. intros h.
eapply eval_mkApps_Construct_inv in h as [? []]. subst v.
- intros Hc _. specialize (Hc ind n x). now apply Hc.
+ intros Hc _. specialize (Hc ind n x). now eapply Hc. auto.
* move=> [] hl [] ha [] ht /andP[] /andP[] etafix etab etal.
rewrite ha.
intros H; eapply eval_stuck_fix_eq in H as [args' [Hargs' [[]|]]]. subst v.
@@ -1608,12 +1619,12 @@ Proof.
eapply eval_app_cong_tApp'. now eapply eval_to_value in evf''. exact e0. exact evres.
Qed.
-Lemma All_eval_etaexp {fl : WcbvFlags} {efl : EEnvFlags} Σ l l' :
+Lemma All_eval_etaexp {fl : WcbvFlags} {wcon : with_constructor_as_block = false } {efl : EEnvFlags} Σ l l' :
isEtaExp_env Σ ->
wf_glob Σ ->
All2 (eval Σ) l l' -> forallb (isEtaExp Σ []) l -> forallb (isEtaExp Σ []) l'.
Proof.
- intros; solve_all. now eapply eval_etaexp.
+ intros; solve_all. eapply eval_etaexp; eauto. Unshelve. eauto.
Qed.
Lemma isFix_mkApps f args : ~~ isFix f -> ~~ isFix (mkApps f args).
@@ -1632,7 +1643,7 @@ Proof.
intros h. now apply isFix_mkApps.
Qed.
-Lemma eval_opt_to_target {fl: WcbvFlags} {efl : EEnvFlags} Σ t v :
+Lemma eval_opt_to_target {fl: WcbvFlags} {wcon : with_constructor_as_block = false} {efl : EEnvFlags} Σ t v :
with_guarded_fix ->
isEtaExp_env Σ ->
wf_glob Σ ->
@@ -1643,7 +1654,7 @@ Proof.
intros wguard etaΣ wfΣ.
intros H.
induction H using eval_mkApps_rect.
- - move/(isEtaExp_tApp_eval wguard H) => IH.
+ - move/(isEtaExp_tApp_eval wguard wcon H) => IH.
forward IH by (intros; intro; solve_discr).
forward IH by (intros; intro; solve_discr).
destruct (decompose_app (tApp a t)) eqn:da.
@@ -1661,7 +1672,7 @@ Proof.
forward IHeval2 => //.
econstructor; eauto.
- clear H0.
- move/(isEtaExp_tApp_eval wguard H) => IH.
+ move/(isEtaExp_tApp_eval wguard wcon H) => IH.
forward IH by (intros; intro; solve_discr).
forward IH by (intros; intro; solve_discr).
destruct (decompose_app (tApp f0 a)) eqn:da.
@@ -1689,14 +1700,15 @@ Proof.
eapply eval_etaexp in IHeval1; tea.
- simp_eta. move=> /andP[] etad etabrs.
forward IHeval1 => //.
- move: (eval_etaexp etaΣ wfΣ IHeval1 etad).
- rewrite isEtaExp_Constructor => /andP[] etac etaargs.
+ unshelve epose proof (eval_etaexp etaΣ wfΣ IHeval1 etad). eauto.
+ revert H1.
+ rewrite isEtaExp_Constructor => /andP[] /andP[] etac etaargs bargs.
forward_keep IHeval2 => //.
eapply isEtaExp_iota_red'; eauto.
- eapply forallb_nth_error in etabrs; tea. erewrite H1 in etabrs.
- cbn in etabrs. now rewrite -H3 app_nil_r skipn_length in etabrs.
+ eapply forallb_nth_error in etabrs; tea. erewrite e2 in etabrs.
+ cbn in etabrs. now rewrite -e4 app_nil_r skipn_length in etabrs.
econstructor; tea.
-
+ - congruence.
- simp_eta. move=> /andP[] etad etabrs.
forward IHeval1 => //.
eapply eval_iota_sing => //. tea.
@@ -1710,9 +1722,9 @@ Proof.
move/isEtaExp_tApp'.
destruct decompose_app eqn:da.
destruct expanded_head_viewc.
- * move=> [] hl [] hf [] ha heta.
+ * move=> [] hl [] hf [] ha /andP[]/ andP[] heta heta2 bargs. destruct block_args; inv bargs.
clear H0.
- rewrite hf in H. eapply eval_mkApps_Construct_inv in H as [? []]; solve_discr.
+ rewrite hf in H. eapply eval_mkApps_Construct_inv in H as [? []]; try solve_discr. auto.
* move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel.
set (H' := H); assert (eval_depth H' = eval_depth H) by reflexivity.
clearbody H'. move: H' H4. rewrite {1 2}hf. intros H'.
@@ -1769,8 +1781,8 @@ Proof.
move/isEtaExp_tApp'.
destruct decompose_app eqn:da.
destruct expanded_head_viewc.
- * move=> [] hl [] hf [] ha heta.
- rewrite hf in H. eapply eval_mkApps_Construct_inv in H as [? []]; solve_discr.
+ * move=> [] hl [] hf [] ha /andP[]/ andP[] heta heta2 bargs. destruct block_args; inv bargs.
+ rewrite hf in H. eapply eval_mkApps_Construct_inv in H as [? []]; try solve_discr. eauto.
* move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel.
rewrite hf in H.
elimtype False.
@@ -1820,10 +1832,11 @@ Proof.
forward IHeval1 by tas.
forward IHeval2.
{ eapply eval_etaexp in H; tea.
- move: H; rewrite isEtaExp_mkApps // /= => /andP[] etaapp etaargs.
+ move: H; rewrite isEtaExp_mkApps // /= => /andP[] /andP[] etaapp etaargs bargs.
eapply forallb_nth_error in etaargs; tea.
- now erewrite H2 in etaargs. }
+ now erewrite e3 in etaargs. }
eapply eval_proj; tea.
+ - congruence.
- simp_eta => etad.
forward IHeval by tas.
eapply eval_proj_prop ; tea.
@@ -1831,37 +1844,37 @@ Proof.
destruct decompose_app eqn:da.
rewrite (decompose_app_inv da).
destruct expanded_head_viewc.
- * move=> [] hl [] hf [] ha /andP[] heta etal.
- set (H' := H0) ; assert (eval_depth H' = eval_depth H0) by reflexivity.
- clearbody H'. move: H' H4. rewrite {1 2}hf. intros H'.
- destruct (eval_mkApps_Construct_size H') as [args'' [evc [evcs hargs heq]]].
- eapply mkApps_eq_inj in heq as [] => //. noconf H4. noconf H5.
+ * move=> [] hl [] hf [] ha /andP[] /andP[] heta etal bargs. destruct block_args; inv bargs.
+ set (H' := H) ; assert (eval_depth H' = eval_depth H) by reflexivity.
+ clearbody H'. move: H' H2. rewrite {1 2}hf. intros H'.
+ destruct (eval_mkApps_Construct_size wcon H') as [args'' [evc [evcs hargs heq]]].
+ eapply mkApps_eq_inj in heq as [] => //. noconf H2. noconf H3.
intros hevd.
- rewrite (remove_last_last l a hl).
+ rewrite (remove_last_last l0 a hl).
rewrite -[tApp _ _](mkApps_app _ _ [a']).
eapply eval_mkApps_Construct; tea.
- { constructor. cbn [atom]; rewrite H //. }
+ { constructor. cbn [atom]; rewrite e0 //. }
{ len. rewrite (All2_length hargs). lia. }
eapply All2_app.
eapply forallb_remove_last, forallb_All in etal.
eapply All2_All_mix_left in hargs; tea.
eapply All2_impl; tea. cbn; intros ? ? [].
- destruct s as [evxy hevxy]. unshelve eapply H1; tea. lia.
+ destruct s as [evxy hevxy]. unshelve eapply H0; tea. lia.
constructor; [|constructor]. rewrite -ha.
eapply IHeval2. rewrite ha. now eapply forallb_last.
* move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel.
forward IHeval2. { rewrite ha. now eapply forallb_last. }
- rewrite (remove_last_last l a hl) /=.
+ rewrite (remove_last_last l0 a hl) /=.
rewrite mkApps_app. eapply eval_construct; tea.
- pose proof H0 as Hfix.
+ pose proof H as Hfix.
rewrite hf in Hfix.
eapply eval_stuck_fix_eq in Hfix as [args' [hargs [[hstuck ?]|]]]; auto.
{ solve_discr. }
- { cbn in H2.
+ { cbn in H1.
rewrite hf in IHeval1. eapply IHeval1.
rewrite isEtaExp_mkApps // /= i /= etab /=.
move: isel.
- now rewrite {1}(remove_last_last l a hl) /= forallb_app => /andP[]. }
+ now rewrite {1}(remove_last_last l0 a hl) /= forallb_app => /andP[]. }
{ now rewrite -ha. }
* move=> [] hl [] ha [] ht /andP[] hnth.
now rewrite nth_error_nil /= in hnth.
@@ -1870,21 +1883,22 @@ Proof.
forward IHeval2 by tas.
rewrite -(decompose_app_inv da).
eapply eval_construct; tea.
+ - congruence.
- move/isEtaExp_tApp'.
destruct decompose_app eqn:da.
rewrite (decompose_app_inv da).
destruct expanded_head_viewc.
- * move=> [] hl [] hf [] ha /andP[] heta etal.
+ * move=> [] hl [] hf [] ha /andP[] /andP[] heta etal bargs. destruct block_args; inv bargs.
set (H' := H) ; assert (eval_depth H' = eval_depth H) by reflexivity.
- clearbody H'. move: H' H3. rewrite {1 2}hf. intros H'.
- destruct (eval_mkApps_Construct_size H') as [args'' [evc [evcs hargs heq]]].
+ clearbody H'. move: H' H2. rewrite {1 2}hf. intros H'.
+ destruct (eval_mkApps_Construct_size wcon H') as [args'' [evc [evcs hargs heq]]].
subst f'.
- rewrite isConstructApp_mkApps /isConstructApp /= in H1.
- now rewrite !negb_or /= !andb_false_r in H1.
+ rewrite isConstructApp_mkApps /isConstructApp /= in i.
+ now rewrite !negb_or /= !andb_false_r in i.
* move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel.
forward IHeval2. { rewrite ha. now eapply forallb_last. }
rewrite (remove_last_last l a hl) /=.
- rewrite mkApps_app. rewrite wguard in H1.
+ rewrite mkApps_app. rewrite wguard in i.
move: H H0. rewrite hf.
intros H IH.
eapply eval_app_cong; tea.
@@ -1892,12 +1906,12 @@ Proof.
unshelve eapply IH. exact H. lia.
pose proof H as Hfix.
eapply eval_stuck_fix_eq in Hfix as [args' [hargs [[hstuck ?]|]]]; auto.
- { subst f'. rewrite isFixApp_mkApps in H1.
- now rewrite !negb_or /= !andb_false_r in H1. }
- { rewrite isEtaExp_mkApps // /= i /= etab /=.
+ { subst f'. rewrite isFixApp_mkApps in i.
+ now rewrite !negb_or /= !andb_false_r in i. }
+ { rewrite isEtaExp_mkApps // /= i0 /= etab /=.
move: isel.
now rewrite {1}(remove_last_last l a hl) /= forallb_app => /andP[]. }
- cbn. move: H1. rewrite !negb_or; rtoProp; intuition auto.
+ cbn. move: i. rewrite !negb_or; rtoProp; intuition auto.
now eapply nisFixApp_nisFix.
* move=> [] hl [] ha [] ht /andP[] hnth.
now rewrite nth_error_nil /= in hnth.
@@ -1906,10 +1920,11 @@ Proof.
forward IHeval2 by tas.
rewrite -(decompose_app_inv da).
eapply eval_app_cong; tea.
- cbn. rewrite wguard in H1.
- cbn. move: H1. rewrite !negb_or; rtoProp; intuition auto.
+ cbn. rewrite wguard in i.
+ cbn. move: i. rewrite !negb_or; rtoProp; intuition auto.
now eapply nisFixApp_nisFix.
- intros hexp. now eapply eval_atom.
+ Unshelve. all: eauto.
Qed.
Lemma expanded_global_env_isEtaExp_env {Σ} : expanded_global_env Σ -> isEtaExp_env Σ.
diff --git a/erasure/theories/EGenericMapEnv.v b/erasure/theories/EGenericMapEnv.v
new file mode 100644
index 000000000..1f1df5bc2
--- /dev/null
+++ b/erasure/theories/EGenericMapEnv.v
@@ -0,0 +1,339 @@
+(* Distributed under the terms of the MIT license. *)
+From Coq Require Import Utf8 Program.
+From MetaCoq.Template Require Import config utils Kernames BasicAst EnvMap.
+From MetaCoq.Erasure Require Import EAst EAstUtils EInduction EArities
+ ELiftSubst ESpineView EGlobalEnv EWellformed EEnvMap
+ EWcbvEval EEtaExpanded ECSubst EWcbvEvalEtaInd EProgram.
+
+Local Open Scope string_scope.
+Set Asymmetric Patterns.
+Import MCMonadNotation.
+
+From Equations Require Import Equations.
+Set Equations Transparent.
+Local Set Keyed Unification.
+Require Import ssreflect ssrbool.
+
+Section sec.
+
+Variable gen_transform : global_context -> term -> term.
+
+Definition gen_transform_constant_decl Σ cb :=
+ {| cst_body := option_map (gen_transform Σ) cb.(cst_body) |}.
+
+Definition gen_transform_decl Σ d :=
+ match d with
+ | ConstantDecl cb => ConstantDecl (gen_transform_constant_decl Σ cb)
+ | InductiveDecl idecl => d
+ end.
+
+Definition gen_transform_env Σ :=
+ map (on_snd (gen_transform_decl Σ)) Σ.
+
+Program Fixpoint gen_transform_env' Σ : global_context :=
+match Σ with
+| [] => []
+| hd :: tl => on_snd (gen_transform_decl tl) hd :: gen_transform_env' tl
+end.
+
+Import EGlobalEnv EExtends.
+
+Lemma extends_lookup_projection {efl : EEnvFlags} {Σ Σ' p} : extends Σ Σ' -> wf_glob Σ' ->
+isSome (lookup_projection Σ p) ->
+lookup_projection Σ p = lookup_projection Σ' p.
+Proof.
+intros ext wf; cbn -[lookup_projection].
+unfold lookup_projection.
+destruct lookup_constructor as [[[mdecl idecl] cdecl]|] eqn:hl => //.
+simpl.
+rewrite (extends_lookup_constructor wf ext _ _ _ hl) //.
+Qed.
+
+Variable efl' : EEnvFlags.
+Variable efl : EEnvFlags.
+
+Hypothesis wellformed_gen_transform_extends : forall {Σ : global_context} t,
+forall n, EWellformed.wellformed Σ n t ->
+forall {Σ' : global_context}, extends Σ Σ' -> wf_glob Σ' ->
+gen_transform Σ t = gen_transform Σ' t.
+
+Lemma wellformed_gen_transform_decl_extends {Σ : global_context} t :
+wf_global_decl Σ t ->
+forall {Σ' : global_context}, extends Σ Σ' -> wf_glob Σ' ->
+gen_transform_decl Σ t = gen_transform_decl Σ' t.
+Proof.
+destruct t => /= //.
+intros wf Σ' ext wf'. f_equal. unfold gen_transform_constant_decl. f_equal.
+destruct (cst_body c) => /= //. f_equal.
+now eapply wellformed_gen_transform_extends.
+Qed.
+
+Lemma lookup_env_gen_transform_env_Some {Σ : global_context} kn d :
+wf_glob Σ ->
+lookup_env Σ kn = Some d ->
+∑ Σ' : global_context,
+ [× extends Σ' Σ, wf_global_decl Σ' d &
+ lookup_env (gen_transform_env Σ) kn = Some (gen_transform_decl Σ' d)].
+Proof.
+induction Σ in |- *; simpl; auto => //.
+intros wfg.
+case: eqb_specT => //.
+- intros ->. cbn. intros [= <-]. exists Σ. split.
+ now eexists [_].
+ cbn. now depelim wfg.
+ f_equal. symmetry. eapply wellformed_gen_transform_decl_extends. cbn. now depelim wfg.
+ cbn. now exists [a]. now cbn.
+- intros _.
+ cbn in IHΣ. forward IHΣ. now depelim wfg.
+ intros hl. specialize (IHΣ hl) as [Σ'' [ext wfgd hl']].
+ exists Σ''. split => //.
+ * destruct ext as [? ->].
+ now exists (a :: x).
+ * rewrite -hl'. f_equal.
+ clear -wfg wellformed_gen_transform_extends.
+ eapply map_ext_in => kn hin. unfold on_snd. f_equal.
+ symmetry. eapply wellformed_gen_transform_decl_extends => //. cbn.
+ eapply lookup_env_In in hin. 2:now depelim wfg.
+ depelim wfg. eapply lookup_env_wellformed; tea.
+ cbn. now exists [a].
+Qed.
+
+Lemma lookup_env_map_snd Σ f kn : lookup_env (List.map (on_snd f) Σ) kn = option_map f (lookup_env Σ kn).
+Proof.
+induction Σ; cbn; auto.
+case: eqb_spec => //.
+Qed.
+
+Lemma lookup_env_gen_transform_env_None {Σ : global_context} kn :
+lookup_env Σ kn = None ->
+lookup_env (gen_transform_env Σ) kn = None.
+Proof.
+cbn. intros hl. rewrite lookup_env_map_snd hl //.
+Qed.
+
+Lemma lookup_env_gen_transform {Σ : global_context} kn :
+wf_glob Σ ->
+lookup_env (gen_transform_env Σ) kn = option_map (gen_transform_decl Σ) (lookup_env Σ kn).
+Proof.
+intros wf.
+destruct (lookup_env Σ kn) eqn:hl.
+- eapply lookup_env_gen_transform_env_Some in hl as [Σ' [ext wf' hl']] => /=.
+ rewrite hl'. f_equal.
+ eapply wellformed_gen_transform_decl_extends; eauto. auto.
+
+- cbn. now eapply lookup_env_gen_transform_env_None in hl.
+Qed.
+
+
+Lemma is_propositional_gen_transform {Σ : global_context} ind :
+ wf_glob Σ ->
+ inductive_isprop_and_pars Σ ind = inductive_isprop_and_pars (gen_transform_env Σ) ind.
+Proof.
+ rewrite /inductive_isprop_and_pars => wf.
+ rewrite /lookup_inductive /lookup_minductive.
+ rewrite (lookup_env_gen_transform (inductive_mind ind) wf).
+ rewrite /GlobalContextMap.inductive_isprop_and_pars /GlobalContextMap.lookup_inductive
+ /GlobalContextMap.lookup_minductive.
+ destruct lookup_env as [[decl|]|] => //.
+Qed.
+
+Lemma is_propositional_cstr_gen_transform {Σ : global_context} ind c :
+ wf_glob Σ ->
+ constructor_isprop_pars_decl Σ ind c = constructor_isprop_pars_decl (gen_transform_env Σ) ind c.
+Proof.
+ rewrite /constructor_isprop_pars_decl => wf.
+ rewrite /lookup_constructor /lookup_inductive /lookup_minductive.
+ rewrite (lookup_env_gen_transform (inductive_mind ind) wf).
+ rewrite /GlobalContextMap.inductive_isprop_and_pars /GlobalContextMap.lookup_inductive
+ /GlobalContextMap.lookup_minductive.
+ destruct lookup_env as [[decl|]|] => //.
+Qed.
+
+Lemma isFix_mkApps t l : isFix (mkApps t l) = isFix t && match l with [] => true | _ => false end.
+Proof.
+ induction l using rev_ind; cbn.
+ - now rewrite andb_true_r.
+ - rewrite mkApps_app /=. now destruct l => /= //; rewrite andb_false_r.
+Qed.
+
+Lemma lookup_constructor_gen_transform {Σ : global_context} {ind c} :
+ wf_glob Σ ->
+ lookup_constructor Σ ind c = lookup_constructor (gen_transform_env Σ) ind c.
+Proof.
+ intros wfΣ. rewrite /lookup_constructor /lookup_inductive /lookup_minductive.
+ rewrite lookup_env_gen_transform // /=. destruct lookup_env => // /=.
+ destruct g => //.
+Qed.
+
+Lemma lookup_projection_gen_transform {Σ : global_context} {p} :
+ wf_glob Σ ->
+ lookup_projection Σ p = lookup_projection (gen_transform_env Σ) p.
+Proof.
+ intros wfΣ. rewrite /lookup_projection.
+ rewrite -lookup_constructor_gen_transform //.
+Qed.
+
+Lemma constructor_isprop_pars_decl_inductive {Σ ind c} {prop pars cdecl} :
+ constructor_isprop_pars_decl Σ ind c = Some (prop, pars, cdecl) ->
+ inductive_isprop_and_pars Σ ind = Some (prop, pars).
+Proof.
+ rewrite /constructor_isprop_pars_decl /inductive_isprop_and_pars /lookup_constructor.
+ destruct lookup_inductive as [[mdecl idecl]|]=> /= //.
+ destruct nth_error => //. congruence.
+Qed.
+
+Lemma constructor_isprop_pars_decl_constructor {Σ ind c} {mdecl idecl cdecl} :
+ lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) ->
+ constructor_isprop_pars_decl Σ ind c = Some (ind_propositional idecl, ind_npars mdecl, cdecl).
+Proof.
+ rewrite /constructor_isprop_pars_decl. intros -> => /= //.
+Qed.
+
+Lemma wf_mkApps (ha : has_tApp) Σ k f args : reflect (wellformed Σ k f /\ forallb (wellformed Σ k) args) (wellformed Σ k (mkApps f args)).
+Proof.
+ rewrite wellformed_mkApps //. eapply andP.
+Qed.
+
+Lemma gen_transform_env_extends' {Σ Σ' : global_context} :
+ extends Σ Σ' ->
+ wf_glob Σ' ->
+ List.map (on_snd (gen_transform_decl Σ)) Σ =
+ List.map (on_snd (gen_transform_decl Σ')) Σ.
+Proof.
+ intros ext.
+ move=> wfΣ.
+ assert (Hext : extends Σ Σ); auto. now exists [].
+ assert (Hwfg : wf_glob Σ).
+ { eapply extends_wf_glob. exact ext. tea. }
+ revert Hext Hwfg.
+ generalize Σ at 1 3 5 6. intros Σ''.
+ induction Σ'' => //. cbn.
+ intros hin wfg. depelim wfg.
+ f_equal.
+ 2:{ eapply IHΣ'' => //. destruct hin. exists (x ++ [(kn, d)]). rewrite -app_assoc /= //. }
+ unfold on_snd. cbn. f_equal.
+ eapply wellformed_gen_transform_decl_extends => //. cbn.
+ eapply extends_wf_global_decl. 3:tea.
+ eapply extends_wf_glob; tea.
+ destruct hin. exists (x ++ [(kn, d)]). rewrite -app_assoc /= //.
+Qed.
+
+Lemma gen_transform_env_eq (Σ : global_context) : wf_glob Σ -> gen_transform_env Σ = gen_transform_env' Σ.
+Proof.
+ intros wf.
+ unfold gen_transform_env.
+ induction Σ => //.
+ cbn. f_equal.
+ destruct a as [kn d]; unfold on_snd; cbn. f_equal. symmetry.
+ eapply wellformed_gen_transform_decl_extends => //. cbn. now depelim wf. cbn. now exists [(kn, d)]. cbn.
+ erewrite <- IHΣ.
+ 2:now depelim wf.
+ symmetry. eapply gen_transform_env_extends'; eauto.
+ cbn. now exists [a].
+Qed.
+
+Variable Pre : global_context -> term -> Prop.
+
+Hypothesis gen_transform_wellformed : forall {Σ : global_context} n t,
+ has_tBox -> has_tRel -> Pre Σ t ->
+ @wf_glob efl Σ -> @EWellformed.wellformed efl Σ n t ->
+ EWellformed.wellformed (efl := efl') Σ n (gen_transform Σ t).
+
+Import EWellformed.
+
+Lemma gen_transform_wellformed_irrel {Σ : global_context} t :
+ wf_glob Σ ->
+ forall n, wellformed (efl := efl') Σ n t ->
+ wellformed (efl := efl') (gen_transform_env Σ) n t.
+Proof.
+ intros wfΣ. induction t using EInduction.term_forall_list_ind; cbn => //.
+ all:try solve [intros; unfold wf_fix_gen in *; rtoProp; intuition eauto; solve_all].
+ - rewrite lookup_env_gen_transform //.
+ destruct lookup_env eqn:hl => // /=.
+ destruct g eqn:hg => /= //. destruct (cst_body c); cbn; eauto.
+ - rewrite lookup_env_gen_transform //.
+ destruct lookup_env eqn:hl => // /=; intros; rtoProp; eauto.
+ destruct g eqn:hg => /= //; intros; rtoProp; eauto.
+ repeat split; eauto. destruct cstr_as_blocks; rtoProp; repeat split; eauto. solve_all.
+ - rewrite lookup_env_gen_transform //.
+ destruct lookup_env eqn:hl => // /=.
+ destruct g eqn:hg => /= //. subst g.
+ destruct nth_error => /= //.
+ intros; rtoProp; intuition auto; solve_all.
+ - rewrite lookup_env_gen_transform //.
+ destruct lookup_env eqn:hl => // /=; intros; rtoProp; repeat split; eauto.
+ destruct g eqn:hg => /= //.
+Qed.
+
+Lemma gen_transform_wellformed_decl_irrel {Σ : global_context} d :
+ wf_glob Σ ->
+ wf_global_decl (efl:= efl') Σ d ->
+ wf_global_decl (efl := efl') (gen_transform_env Σ) d.
+Proof.
+ intros wf; destruct d => /= //.
+ destruct (cst_body c) => /= //.
+ now eapply gen_transform_wellformed_irrel.
+Qed.
+
+Hypothesis axioms_efl : forall _ : is_true (@has_axioms efl), is_true (@has_axioms efl').
+Hypothesis cstrs_efl : forall _ : is_true (@has_cstr_params efl), is_true (@has_cstr_params efl').
+
+Definition Pre_decl Σ d := match d with ConstantDecl cb => match cb.(cst_body) with Some b => Pre Σ b | _ => True end | _ => True end.
+
+Lemma gen_transform_decl_wf {Σ : global_context} :
+ has_tBox -> has_tRel -> wf_glob Σ ->
+ forall d, wf_global_decl Σ d -> Pre_decl Σ d ->
+ wf_global_decl (efl := efl') (gen_transform_env Σ) (gen_transform_decl Σ d).
+Proof.
+ intros hasb hasr wf d.
+ intros hd. intros pre.
+ eapply gen_transform_wellformed_decl_irrel; tea; eauto.
+ move: hd.
+ destruct d => /= //. cbn in pre.
+ destruct (cst_body c) => /= //.
+ intros hwf. eapply gen_transform_wellformed => //. auto.
+ destruct efl => //; eauto. destruct m => //. cbn. unfold wf_minductive.
+ cbn. move/andP => [] hp //. rtoProp. solve_all.
+ eapply orb_true_iff. eapply orb_true_iff in hp as []; eauto.
+ left. eapply cstrs_efl. now rewrite H.
+Qed.
+
+Lemma fresh_global_gen_transform_env {Σ : global_context} kn :
+ fresh_global kn Σ ->
+ fresh_global kn (gen_transform_env Σ).
+Proof.
+ induction 1; cbn; constructor; auto.
+ now eapply Forall_map; cbn.
+Qed.
+
+Fixpoint Pre_glob Σ :=
+ match Σ with
+ | nil => True
+ | (kn, d) :: Σ => Pre_decl Σ d /\ Pre_glob Σ
+ end.
+
+Lemma gen_transform_env_wf {Σ : global_context} :
+ has_tBox -> has_tRel -> Pre_glob Σ ->
+ wf_glob Σ -> wf_glob (efl := efl') (gen_transform_env Σ).
+Proof.
+ intros hasb hasrel pre.
+ intros wfg. rewrite gen_transform_env_eq //.
+ induction wfg; cbn; constructor; invs pre; auto.
+ - rewrite /= -(gen_transform_env_eq Σ) => //. eauto.
+ eapply gen_transform_decl_wf => //.
+ - rewrite /= -(gen_transform_env_eq Σ) //.
+ now eapply fresh_global_gen_transform_env.
+Qed.
+
+(* Definition gen_transform_program (p : eprogram_env) :=
+ (gen_transform_env p.1, gen_transform p.1 p.2).
+
+Definition gen_transform_program_wf (p : eprogram_env) {hastbox : has_tBox} {hastrel : has_tRel} :
+ wf_eprogram_env efl p -> wf_eprogram (efl') (gen_transform_program p).
+Proof.
+ intros []; split.
+ now eapply gen_transform_env_wf.
+ cbn. eapply gen_transform_wellformed_irrel => //. now eapply gen_transform_wellformed.
+Qed. *)
+
+End sec.
\ No newline at end of file
diff --git a/erasure/theories/EGlobalEnv.v b/erasure/theories/EGlobalEnv.v
index 3448f7540..60aefe00d 100644
--- a/erasure/theories/EGlobalEnv.v
+++ b/erasure/theories/EGlobalEnv.v
@@ -247,7 +247,7 @@ Definition is_constructor_app_or_box t :=
| a =>
let (f, a) := decompose_app a in
match f with
- | tConstruct _ _ => true
+ | tConstruct _ _ _ => true
| _ => false
end
end.
diff --git a/erasure/theories/EInduction.v b/erasure/theories/EInduction.v
index 61a591530..659d24b37 100644
--- a/erasure/theories/EInduction.v
+++ b/erasure/theories/EInduction.v
@@ -25,7 +25,8 @@ Lemma term_forall_list_ind :
P t -> forall t0 : term, P t0 -> P (tLetIn n t t0)) ->
(forall t u : term, P t -> P u -> P (tApp t u)) ->
(forall s, P (tConst s)) ->
- (forall (i : inductive) (n : nat), P (tConstruct i n)) ->
+ (forall (i : inductive) (n : nat) (args : list term),
+ All P args -> P (tConstruct i n args)) ->
(forall (p : inductive * nat) (t : term),
P t -> forall l : list (list name * term),
All (fun x => P x.2) l -> P (tCase p t l)) ->
@@ -50,6 +51,11 @@ Proof.
destruct l; constructor; [|apply auxl'].
apply auxt.
+ revert l.
+ fix auxl' 1.
+ destruct l; constructor; [|apply auxl'].
+ apply auxt.
+
revert m.
fix auxm 1.
destruct m; constructor; [|apply auxm].
@@ -93,6 +99,7 @@ Fixpoint size t : nat :=
| tProj p c => S (size c)
| tFix mfix idx => S (list_size (fun x => size (dbody x)) mfix)
| tCoFix mfix idx => S (list_size (fun x => size (dbody x)) mfix)
+ | tConstruct _ _ ignore_args => S (list_size size ignore_args)
| _ => 1
end.
@@ -168,7 +175,7 @@ Qed.
Lemma size_mkApps_l {f l} (Hf : ~~ isApp f) (Hl : l <> []) : list_size size l < size (mkApps f l).
Proof.
rewrite size_mkApps.
- destruct f => /= //; lia.
+ destruct f => /= //; try lia.
Qed.
(** Custom induction principle on syntax, dealing with the various lists appearing in terms. *)
@@ -202,7 +209,7 @@ Section MkApps_rec.
(papp : forall t u,
~~ isApp t -> u <> nil -> P t -> All P u -> P (mkApps t u))
(pconst : forall s, P (tConst s))
- (pconstruct : forall (i : inductive) (n : nat), P (tConstruct i n))
+ (pconstruct : forall (i : inductive) (n : nat) args, All P args -> P (tConstruct i n args))
(pcase : forall (p : inductive * nat) (t : term),
P t -> forall l : list (list name * term),
All (fun x => P x.2) l -> P (tCase p t l))
@@ -229,7 +236,7 @@ Section MkApps_rec.
let pl := All_rec P id l (fun x H => rec x) in
rew _ in papp t l napp nonnil pt pl }
| tConst k => pconst k
- | tConstruct i n => pconstruct i n
+ | tConstruct i n args => pconstruct i n _ (All_rec P id args (fun x H => rec x))
| tCase ina c brs => pcase ina c (rec c) brs (All_rec P (fun x => x.2) brs (fun x H => rec x))
| tProj p c => pproj p c (rec c)
| tFix mfix idx => pfix mfix idx (All_rec P dbody mfix (fun x H => rec x))
@@ -260,7 +267,7 @@ Section MkApps_rec.
(plet : forall (n : name) (t : term), forall t0 : term, P (tLetIn n t t0))
(papp : forall t u, ~~ isApp t -> u <> nil -> P (mkApps t u))
(pconst : forall s, P (tConst s))
- (pconstruct : forall (i : inductive) (n : nat), P (tConstruct i n))
+ (pconstruct : forall (i : inductive) (n : nat) args, P (tConstruct i n args))
(pcase : forall (p : inductive * nat) (t : term) (l : list (list name * term)), P (tCase p t l))
(pproj : forall (s : projection) (t : term), P (tProj s t))
(pfix : forall (m : mfixpoint term) (n : nat), P (tFix m n))
@@ -281,7 +288,7 @@ Section MkApps_rec.
let nonnil := decompose_app_app _ _ _ _ da in
rew [P] (eq_sym (decompose_app_inv da)) in papp t l napp nonnil }
| tConst k => pconst k
- | tConstruct i n => pconstruct i n
+ | tConstruct i n args => pconstruct i n args
| tCase ina c brs => pcase ina c brs
| tProj p c => pproj p c
| tFix mfix idx => pfix mfix idx
diff --git a/erasure/theories/EInlineProjections.v b/erasure/theories/EInlineProjections.v
index 2afb1ba1c..810ceab5f 100644
--- a/erasure/theories/EInlineProjections.v
+++ b/erasure/theories/EInlineProjections.v
@@ -23,8 +23,15 @@ Ltac introdep := let H := fresh in intros H; depelim H.
Hint Constructors eval : core.
(** Allow everything in terms *)
-Local Existing Instance all_env_flags.
+Definition switch_no_params (efl : EEnvFlags) :=
+ {| has_axioms := has_axioms;
+ has_cstr_params := false;
+ term_switches := term_switches ;
+ cstr_as_blocks := false
+ |}.
+Definition flags_after_projs := (switch_no_params all_env_flags).
+Local Existing Instance flags_after_projs.
Arguments lookup_projection : simpl never.
Arguments GlobalContextMap.lookup_projection : simpl never.
@@ -90,7 +97,7 @@ Section optimize.
| tBox => t
| tVar _ => t
| tConst _ => t
- | tConstruct _ _ => t
+ | tConstruct ind n args => tConstruct ind n (map optimize args)
(* | tPrim _ => t *)
end.
@@ -116,6 +123,7 @@ Section optimize.
rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length;
unfold wf_fix_gen, test_def in *;
simpl closed in *; try solve [simpl subst; simpl closed; f_equal; auto; rtoProp; solve_all]; try easy.
+ - rtoProp. split; eauto. destruct args; eauto.
- move/andP: H => [] /andP[] -> clt cll /=.
rewrite IHt //=. solve_all.
- rewrite GlobalContextMap.lookup_projection_spec.
@@ -142,6 +150,7 @@ Section optimize.
unfold wf_fix, test_def in *;
simpl closed in *; try solve [simpl subst; simpl closed; f_equal; auto; rtoProp; solve_all]; try easy.
- destruct (k ?= n0)%nat; auto.
+ - f_equal. rtoProp. now destruct args; inv H0.
- move/andP: wft => [] /andP[] hi hb hl. rewrite IHb. f_equal. unfold on_snd; solve_all.
repeat toAll. f_equal. solve_all. unfold on_snd; cbn. f_equal.
rewrite a0 //. now rewrite -Nat.add_assoc.
@@ -284,7 +293,8 @@ Lemma wellformed_optimize_extends {wfl: EEnvFlags} {Σ : GlobalContextMap.t} t :
Proof.
induction t using EInduction.term_forall_list_ind; cbn -[lookup_constant lookup_inductive
GlobalContextMap.lookup_projection]; intros => //.
- all:unfold wf_fix_gen in *; rtoProp; intuition auto.
+ all:unfold wf_fix_gen in *; rtoProp; intuition auto.
+ 5:{ destruct cstr_as_blocks; rtoProp. f_equal; eauto; solve_all. destruct args; cbn in *; eauto. }
all:f_equal; eauto; solve_all.
- rewrite !GlobalContextMap.lookup_projection_spec.
rewrite -(extends_lookup_projection H0 H1 H3).
@@ -364,7 +374,7 @@ Proof.
rewrite hl'. f_equal.
eapply wellformed_optimize_decl_extends; eauto. auto.
- - cbn. now eapply lookup_env_optimize_env_None in hl.
+ - cbn. now eapply lookup_env_optimize_env_None in hl.
Qed.
Lemma is_propositional_optimize {efl : EEnvFlags} {Σ : GlobalContextMap.t} ind :
@@ -406,7 +416,7 @@ Proof.
now rewrite List.rev_length hskip Nat.add_0_r.
Qed.
-Definition disable_prop_cases fl := {| with_prop_case := false; with_guarded_fix := fl.(@with_guarded_fix) |}.
+Definition disable_prop_cases fl := {| with_prop_case := false; with_guarded_fix := fl.(@with_guarded_fix) ; with_constructor_as_block := false |}.
Lemma isFix_mkApps t l : isFix (mkApps t l) = isFix t && match l with [] => true | _ => false end.
Proof.
@@ -472,7 +482,8 @@ Proof.
* intros hnth. now apply IHs.
Qed.
-Lemma optimize_correct (efl := all_env_flags) {fl} {Σ : GlobalContextMap.t} t v :
+
+Lemma optimize_correct {fl} {wcon : with_constructor_as_block = false} { Σ : GlobalContextMap.t} t v :
wf_glob Σ ->
@eval fl Σ t v ->
wellformed Σ 0 t ->
@@ -486,7 +497,7 @@ Proof.
eapply eval_wellformed in ev2; tea => //.
eapply eval_wellformed in ev1; tea => //.
econstructor; eauto.
- rewrite -(optimize_csubst _ 1) //.
+ rewrite -(optimize_csubst _ 1) //.
apply IHev3. eapply wellformed_csubst => //.
- move/andP => [] clb0 clb1.
@@ -501,11 +512,13 @@ Proof.
eapply nth_error_forallb in wfbrs; tea.
rewrite Nat.add_0_r in wfbrs.
forward IHev2. eapply wellformed_iota_red; tea => //.
- rewrite optimize_iota_red in IHev2 => //. now rewrite e2.
+ rewrite optimize_iota_red in IHev2 => //. now rewrite e3.
econstructor; eauto.
rewrite -is_propositional_cstr_optimize //. tea.
- rewrite nth_error_map e0 //. len. len.
-
+ rewrite nth_error_map e1 //. len. len.
+
+ - congruence.
+
- move/andP => [] /andP[] hl wfd wfbrs.
forward IHev2. eapply wellformed_substl; tea => //.
rewrite forallb_repeat //. len.
@@ -587,7 +600,7 @@ Proof.
move/wf_mkApps: ev1 => [] wfc wfargs.
destruct lookup_projection as [[[[mdecl idecl] cdecl'] pdecl]|] eqn:hl' => //.
pose proof (lookup_projection_lookup_constructor hl').
- rewrite (constructor_isprop_pars_decl_constructor H) in e. noconf e.
+ rewrite (constructor_isprop_pars_decl_constructor H) in e0. noconf e0.
forward IHev1 by auto.
forward IHev2. eapply nth_error_forallb in wfargs; tea.
rewrite optimize_mkApps /= in IHev1.
@@ -604,11 +617,13 @@ Proof.
rewrite nth_error_rev. len. rewrite skipn_length. lia.
rewrite List.rev_involutive. len. rewrite skipn_length.
rewrite nth_error_skipn nth_error_map.
- rewrite e0 -H1.
+ rewrite e1 -H1.
assert((ind_npars mdecl + cstr_nargs cdecl - ind_npars mdecl) = cstr_nargs cdecl) by lia.
rewrite H3.
- eapply (f_equal (option_map (optimize Σ))) in e1.
- cbn in e1. rewrite -e1. f_equal. f_equal. lia.
+ eapply (f_equal (option_map (optimize Σ))) in e2.
+ cbn in e2. rewrite -e2. f_equal. f_equal. lia.
+
+ - congruence.
- move=> /andP[] iss cld.
rewrite GlobalContextMap.lookup_projection_spec.
@@ -629,11 +644,13 @@ Proof.
- move/andP=> [] clf cla.
rewrite optimize_mkApps.
eapply eval_construct; tea.
- rewrite -lookup_constructor_optimize //. exact e.
+ rewrite -lookup_constructor_optimize //. exact e0.
rewrite optimize_mkApps in IHev1. now eapply IHev1.
now len.
now eapply IHev2.
+ - congruence.
+
- move/andP => [] clf cla.
specialize (IHev1 clf). specialize (IHev2 cla).
eapply eval_app_cong; eauto.
@@ -658,6 +675,7 @@ Proof.
all:constructor; eauto.
cbn [atom optimize] in i |- *.
rewrite -lookup_constructor_optimize //.
+ destruct l; cbn in *; eauto.
Qed.
From MetaCoq.Erasure Require Import EEtaExpanded.
@@ -786,7 +804,8 @@ Definition disable_projections_term_flags (et : ETermFlags) :=
Definition disable_projections_env_flag (efl : EEnvFlags) :=
{| has_axioms := true;
term_switches := disable_projections_term_flags term_switches;
- has_cstr_params := true |}.
+ has_cstr_params := true ;
+ cstr_as_blocks := efl.(cstr_as_blocks) |}.
Lemma optimize_wellformed {efl : EEnvFlags} {Σ : GlobalContextMap.t} n t :
has_tBox -> has_tRel ->
@@ -798,6 +817,10 @@ Proof.
all:try solve [cbn; rtoProp; intuition auto; solve_all].
- simpl. destruct lookup_constant => //.
move/andP => [] hasc _ => //. now rewrite hasc.
+ - cbn -[lookup_constructor_pars_args]. intros. rtoProp. repeat split; eauto.
+ destruct cstr_as_blocks; rtoProp; eauto.
+ destruct lookup_constructor_pars_args as [ [] | ]; eauto. split; len. solve_all. split; eauto.
+ solve_all. now destruct args; invs H0.
- cbn. move/andP => [] /andP[] hast hl wft.
rewrite GlobalContextMap.lookup_projection_spec.
destruct lookup_projection as [[[[mdecl idecl] cdecl] pdecl]|] eqn:hl'; auto => //.
@@ -825,8 +848,9 @@ Proof.
destruct lookup_env eqn:hl => // /=.
destruct g eqn:hg => /= //.
- rewrite lookup_env_optimize //.
- destruct lookup_env eqn:hl => // /=.
- destruct g eqn:hg => /= //.
+ destruct lookup_env eqn:hl => // /=; intros; rtoProp; eauto.
+ destruct g eqn:hg => /= //; intros; rtoProp; eauto.
+ repeat split; eauto. destruct cstr_as_blocks; rtoProp; repeat split; eauto. solve_all.
- rewrite lookup_env_optimize //.
destruct lookup_env eqn:hl => // /=.
destruct g eqn:hg => /= //. subst g.
diff --git a/erasure/theories/ELiftSubst.v b/erasure/theories/ELiftSubst.v
index 91f9b59ad..f269e6574 100644
--- a/erasure/theories/ELiftSubst.v
+++ b/erasure/theories/ELiftSubst.v
@@ -34,7 +34,7 @@ Fixpoint lift n k t : term :=
| tBox => t
| tVar _ => t
| tConst _ => t
- | tConstruct _ _ => t
+ | tConstruct ind i args => tConstruct ind i (map (lift n k) args)
(* | tPrim _ => t *)
end.
@@ -69,6 +69,7 @@ Fixpoint subst s k u :=
let k' := List.length mfix + k in
let mfix' := List.map (map_def (subst s k')) mfix in
tCoFix mfix' idx
+ | tConstruct ind i args => tConstruct ind i (map (subst s k) args)
| x => x
end.
@@ -95,6 +96,7 @@ Fixpoint closedn k (t : term) : bool :=
| tCoFix mfix idx =>
let k' := List.length mfix + k in
List.forallb (test_def (closedn k')) mfix
+ | tConstruct ind i args => forallb (closedn k) args
| _ => true
end.
@@ -106,7 +108,7 @@ Require Import PeanoNat.
Import Nat.
Lemma lift_rel_ge :
- forall k n p, p <= n -> lift k p (tRel n) = tRel (k + n).
+ forall k n p, p <= n -> lift k p (tRel n) = tRel (k + n).
Proof.
intros; simpl in |- *.
now elim (leb_spec p n).
@@ -450,8 +452,8 @@ Proof.
revert H. elim (Nat.ltb_spec n0 k); intros; try easy.
- cbn. f_equal; auto.
rtoProp; solve_all.
- rtoProp; solve_all.
- destruct x; f_equal; cbn in *. now apply a0.
+ rtoProp; solve_all.
+ destruct x; f_equal; cbn in *. eauto.
Qed.
Lemma closed_upwards {k t} k' : closedn k t -> k' >= k -> closedn k' t.
@@ -604,6 +606,7 @@ Proof.
- specialize (IHt2 (S k')).
rewrite <- Nat.add_succ_comm in IHt2.
rewrite IHt1 // IHt2 //.
+ - eapply All_forallb_eq_forallb; eauto.
- rewrite IHt //.
f_equal. eapply All_forallb_eq_forallb; tea. cbn.
intros. specialize (H (#|x.1| + k')).
diff --git a/erasure/theories/EOptimizePropDiscr.v b/erasure/theories/EOptimizePropDiscr.v
index a19b19144..4e7d019cd 100644
--- a/erasure/theories/EOptimizePropDiscr.v
+++ b/erasure/theories/EOptimizePropDiscr.v
@@ -61,7 +61,7 @@ Section optimize.
| tBox => t
| tVar _ => t
| tConst _ => t
- | tConstruct _ _ => t
+ | tConstruct ind i args => tConstruct ind i (map optimize args)
(* | tPrim _ => t *)
end.
@@ -366,7 +366,8 @@ Proof.
lookup_projection
GlobalContextMap.inductive_isprop_and_pars]; intros => //.
all:unfold wf_fix_gen in *; rtoProp; intuition auto.
- all:f_equal; eauto; solve_all.
+ all:try now f_equal; eauto; solve_all.
+ - destruct cstr_as_blocks; rtoProp; eauto. f_equal. solve_all. destruct args; inv H2. reflexivity.
- rewrite !GlobalContextMap.inductive_isprop_and_pars_spec.
assert (map (on_snd (optimize Σ)) l = map (on_snd (optimize Σ')) l) as -> by solve_all.
rewrite (extends_inductive_isprop_and_pars H0 H1 H2).
@@ -522,7 +523,7 @@ Proof.
destruct nth_error => //. congruence.
Qed.
-Lemma optimize_correct {efl : EEnvFlags} {fl} {Σ : GlobalContextMap.t} t v :
+Lemma optimize_correct {efl : EEnvFlags} {fl}{wcon : with_constructor_as_block = false} {Σ : GlobalContextMap.t} t v :
wf_glob Σ ->
closed_env Σ ->
@Ee.eval fl Σ t v ->
@@ -550,16 +551,18 @@ Proof.
rewrite optimize_iota_red in IHev2.
eapply eval_closed in ev1 => //.
rewrite GlobalContextMap.inductive_isprop_and_pars_spec.
- rewrite (constructor_isprop_pars_decl_inductive e).
- eapply eval_iota; eauto. tea.
+ rewrite (constructor_isprop_pars_decl_inductive e0).
+ eapply eval_iota; eauto.
now rewrite -is_propositional_cstr_optimize.
- rewrite nth_error_map e0 //. now len. cbn.
- rewrite -e2. rewrite !skipn_length map_length //.
+ rewrite nth_error_map e1 //. now len. cbn.
+ rewrite -e3. rewrite !skipn_length map_length //.
eapply IHev2.
eapply closed_iota_red => //; tea.
eapply nth_error_forallb in clbrs; tea. cbn in clbrs.
now rewrite Nat.add_0_r in clbrs.
+ - congruence.
+
- move/andP => [] cld clbrs.
rewrite GlobalContextMap.inductive_isprop_and_pars_spec.
rewrite e e0 /=.
@@ -657,14 +660,16 @@ Proof.
eapply eval_closed in ev1; tea.
move: ev1; rewrite closedn_mkApps /= => clargs.
rewrite GlobalContextMap.inductive_isprop_and_pars_spec.
- rewrite (constructor_isprop_pars_decl_inductive e).
+ rewrite (constructor_isprop_pars_decl_inductive e0).
rewrite optimize_mkApps in IHev1.
specialize (IHev1 cld).
eapply Ee.eval_proj; tea.
now rewrite -is_propositional_cstr_optimize.
- now len. rewrite nth_error_map e1 //.
+ now len. rewrite nth_error_map e2 //.
eapply IHev2.
- eapply nth_error_forallb in e1; tea.
+ eapply nth_error_forallb in e2; tea.
+
+ - congruence.
- rewrite GlobalContextMap.inductive_isprop_and_pars_spec.
now rewrite e.
@@ -672,11 +677,13 @@ Proof.
- move/andP=> [] clf cla.
rewrite optimize_mkApps.
eapply eval_construct; tea.
- rewrite -lookup_constructor_optimize //. exact e.
+ rewrite -lookup_constructor_optimize //. exact e0.
rewrite optimize_mkApps in IHev1. now eapply IHev1.
now len.
now eapply IHev2.
+ - congruence.
+
- move/andP => [] clf cla.
specialize (IHev1 clf). specialize (IHev2 cla).
eapply Ee.eval_app_cong; eauto.
@@ -699,22 +706,9 @@ Proof.
destruct v => /= //.
- destruct t => //.
all:constructor; eauto. cbn [atom optimize] in i |- *.
- rewrite -lookup_constructor_optimize //.
+ rewrite -lookup_constructor_optimize //. destruct l => //.
Qed.
-(*
-Lemma optimize_extends Σ Σ' :
- wf_glob Σ' ->
- extends Σ Σ' ->
- forall t b, optimize Σ t = b -> optimize Σ' t = b.
-Proof.
- intros wf ext.
- induction t using EInduction.term_forall_list_ind; cbn => //.
- all:try solve [f_equal; solve_all].
- destruct inductive_isp
- rewrite (extends_is_propositional wf ext).
- *)
-
From MetaCoq.Erasure Require Import EEtaExpanded.
Lemma isLambda_optimize Σ t : isLambda t -> isLambda (optimize Σ t).
@@ -842,6 +836,8 @@ Proof.
intros wfΣ hbox hrel.
induction t in n |- * using EInduction.term_forall_list_ind => //.
all:try solve [cbn; rtoProp; intuition auto; solve_all].
+ - cbn -[lookup_constructor]. intros. destruct cstr_as_blocks; rtoProp; repeat split; eauto. 2:solve_all.
+ 2: now destruct args; inv H0. len. eauto.
- cbn -[GlobalContextMap.inductive_isprop_and_pars lookup_inductive]. move/and3P => [] hasc /andP[]hs ht hbrs.
destruct GlobalContextMap.inductive_isprop_and_pars as [[[|] _]|] => /= //.
destruct l as [|[br n'] [|l']] eqn:eql; simpl.
@@ -879,8 +875,9 @@ Proof.
destruct g eqn:hg => /= //. subst g.
destruct (cst_body c) => //.
- rewrite lookup_env_optimize //.
- destruct lookup_env eqn:hl => // /=.
- destruct g eqn:hg => /= //.
+ destruct lookup_env eqn:hl => // /=; intros; rtoProp; eauto.
+ destruct g eqn:hg => /= //; intros; rtoProp; eauto.
+ repeat split; eauto. destruct cstr_as_blocks; rtoProp; repeat split; len; eauto. 1: solve_all.
- rewrite lookup_env_optimize //.
destruct lookup_env eqn:hl => // /=.
destruct g eqn:hg => /= //. subst g.
diff --git a/erasure/theories/EPretty.v b/erasure/theories/EPretty.v
index 4322008aa..96f534226 100644
--- a/erasure/theories/EPretty.v
+++ b/erasure/theories/EPretty.v
@@ -111,11 +111,11 @@ Module PrintTermTree.
| tApp f l =>
parens (top || inapp) (print_term Γ false true f ^ " " ^ print_term Γ false false l)
| tConst c => string_of_kername c
- | tConstruct (mkInd i k as ind) l =>
+ | tConstruct (mkInd i k as ind) l args =>
match lookup_ind_decl Σ i k with
| Some oib =>
match nth_error oib.(ind_ctors) l with
- | Some cstr => cstr.(cstr_name)
+ | Some cstr => cstr.(cstr_name) ^ maybe_string_of_list string_of_term args
| None =>
"UnboundConstruct(" ^ string_of_inductive ind ^ "," ^ string_of_nat l ^ ")"
end
diff --git a/erasure/theories/EReflect.v b/erasure/theories/EReflect.v
index 99dc459ef..039df2bc7 100644
--- a/erasure/theories/EReflect.v
+++ b/erasure/theories/EReflect.v
@@ -59,6 +59,15 @@ Proof.
- destruct (IHx1 t1) ; nodec.
destruct (IHx2 t2) ; nodec.
subst. left. reflexivity.
+ - revert l. induction X ; intro l0.
+ + destruct l0.
+ * left. reflexivity.
+ * right. discriminate.
+ + destruct l0.
+ * right. discriminate.
+ * destruct (IHX l0) ; nodec.
+ destruct (p t) ; nodec.
+ inversion e. subst; left; reflexivity.
- destruct (IHx t) ; nodec.
subst. revert l0. clear IHx.
induction X ; intro l0.
diff --git a/erasure/theories/ERemoveParams.v b/erasure/theories/ERemoveParams.v
index a9e351b1b..2e760b906 100644
--- a/erasure/theories/ERemoveParams.v
+++ b/erasure/theories/ERemoveParams.v
@@ -36,10 +36,10 @@ Section strip.
| tEvar ev args => EAst.tEvar ev (map_InP args (fun x H => strip x))
| tLambda na M => EAst.tLambda na (strip M)
| tApp u v napp nnil with construct_viewc u := {
- | view_construct kn c with GlobalContextMap.lookup_inductive_pars Σ (inductive_mind kn) := {
+ | view_construct kn c block_args with GlobalContextMap.lookup_inductive_pars Σ (inductive_mind kn) := {
| Some npars :=
- mkApps (EAst.tConstruct kn c) (List.skipn npars (map_InP v (fun x H => strip x)))
- | None => mkApps (EAst.tConstruct kn c) (map_InP v (fun x H => strip x)) }
+ mkApps (EAst.tConstruct kn c block_args) (List.skipn npars (map_InP v (fun x H => strip x)))
+ | None => mkApps (EAst.tConstruct kn c block_args) (map_InP v (fun x H => strip x)) }
| view_other u nconstr =>
mkApps (strip u) (map_InP v (fun x H => strip x))
}
@@ -57,15 +57,15 @@ Section strip.
| tBox => EAst.tBox
| tVar n => EAst.tVar n
| tConst n => EAst.tConst n
- | tConstruct ind i => EAst.tConstruct ind i }.
+ | tConstruct ind i block_args => EAst.tConstruct ind i block_args }.
Proof.
all:try lia.
all:try apply (In_size); tea.
- now eapply (In_size id size).
- rewrite size_mkApps.
- now eapply (In_size id size) in H.
+ eapply (In_size id size) in H. change (fun x => size (id x)) with size in H. unfold id in H. cbn. lia.
- rewrite size_mkApps.
- now eapply (In_size id size) in H.
+ eapply (In_size id size) in H. change (fun x => size (id x)) with size in H. unfold id in H. cbn. lia.
- now eapply size_mkApps_f.
- pose proof (size_mkApps_l napp nnil).
eapply (In_size id size) in H. change (fun x => size (id x)) with size in H. unfold id in H. lia.
@@ -108,9 +108,9 @@ Section strip.
- rewrite !closedn_mkApps in H1 *.
rtoProp; intuition auto.
solve_all.
- - rewrite !closedn_mkApps /= in H0 *.
- rewrite forallb_skipn; solve_all.
- - rewrite !closedn_mkApps /= in H0 *; solve_all.
+ - rewrite !closedn_mkApps /= in H0 *. rtoProp.
+ rewrite forallb_skipn; solve_all. solve_all.
+ - rewrite !closedn_mkApps /= in H0 *. rtoProp. repeat solve_all.
Qed.
Hint Rewrite @forallb_InP_spec : isEtaExp.
@@ -119,10 +119,10 @@ Section strip.
Local Lemma strip_mkApps_nonnil f v :
~~ isApp f -> v <> [] ->
strip (mkApps f v) = match construct_viewc f with
- | view_construct kn c =>
+ | view_construct kn c block_args =>
match lookup_inductive_pars Σ (inductive_mind kn) with
- | Some npars => mkApps (EAst.tConstruct kn c) (List.skipn npars (map strip v))
- | None => mkApps (EAst.tConstruct kn c) (map strip v)
+ | Some npars => mkApps (EAst.tConstruct kn c block_args) (List.skipn npars (map strip v))
+ | None => mkApps (EAst.tConstruct kn c block_args) (map strip v)
end
| view_other u nconstr => mkApps (strip f) (map strip v)
end.
@@ -139,10 +139,10 @@ Section strip.
Lemma strip_mkApps f v : ~~ isApp f ->
strip (mkApps f v) = match construct_viewc f with
- | view_construct kn c =>
+ | view_construct kn c block_args =>
match lookup_inductive_pars Σ (inductive_mind kn) with
- | Some npars => mkApps (EAst.tConstruct kn c) (List.skipn npars (map strip v))
- | None => mkApps (EAst.tConstruct kn c) (map strip v)
+ | Some npars => mkApps (EAst.tConstruct kn c block_args) (List.skipn npars (map strip v))
+ | None => mkApps (EAst.tConstruct kn c block_args) (map strip v)
end
| view_other u nconstr => mkApps (strip f) (map strip v)
end.
@@ -170,6 +170,7 @@ Section strip.
isEtaExp Σ b ->
strip (ECSubst.csubst a k b) = ECSubst.csubst (strip a) k (strip b).
Proof using Type.
+ intros cla etaa; move cla before a. move etaa before a.
funelim (strip b); cbn; simp strip isEtaExp; rewrite -?isEtaExp_equation_1 -?strip_equation_1; toAll; simpl;
intros; try easy;
rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length;
@@ -177,10 +178,11 @@ Section strip.
simpl closed in *; try solve [simpl subst; simpl closed; f_equal; auto; rtoProp; solve_all]; try easy.
- destruct Nat.compare => //.
- - f_equal. solve_all. move/andP: b => [] _ he. solve_all.
- - specialize (H a k H1 H2).
- rewrite !csubst_mkApps in H2 *.
- rewrite isEtaExp_mkApps_napp // in H3.
+ - f_equal. rtoProp. solve_all. destruct block_args; inv H0. eauto.
+ - f_equal. solve_all. move/andP: b => [] _ he. solve_all.
+ - specialize (H a etaa cla k).
+ rewrite !csubst_mkApps in H1 *.
+ rewrite isEtaExp_mkApps_napp // in H1.
destruct construct_viewc.
* cbn. rewrite strip_mkApps //.
* move/andP: H3 => [] et ev.
@@ -208,8 +210,8 @@ Section strip.
rewrite (lookup_inductive_pars_constructor_pars_args eqpars).
rewrite -mkApps_app /= !skipn_map. f_equal.
rewrite skipn_app map_app. f_equal.
- assert (pars - #|l| = 0). eapply Nat.leb_le in ise; lia.
- rewrite H4 skipn_0.
+ assert (pars - #|l| = 0). rtoProp. rename H2 into ise. eapply Nat.leb_le in ise; lia.
+ rewrite H2 skipn_0.
rewrite !map_map_compose.
clear -H1 H2 ev H0. solve_all. }
{ rewrite -mkApps_app.
@@ -225,7 +227,7 @@ Section strip.
rewrite /isEtaExp_app in H4.
destruct lookup_constructor_pars_args as [[pars args]|] eqn:eqpars => // /=.
rewrite (lookup_inductive_pars_constructor_pars_args eqpars).
- assert (pars = 0). eapply Nat.leb_le in H4. lia.
+ assert (pars = 0). rtoProp. eapply Nat.leb_le in H2. lia.
subst pars. rewrite skipn_0.
simp strip; rewrite -strip_equation_1.
{ f_equal. rewrite !map_map_compose. clear -H1 H2 ev H0. solve_all. } }
@@ -240,13 +242,13 @@ Section strip.
unfold isEtaExp_app in etaapp.
rewrite GlobalContextMap.lookup_inductive_pars_spec in Heq.
rewrite Heq in etaapp *.
- f_equal. rewrite map_skipn. f_equal.
+ f_equal.
+ now destruct block_args; inv etav.
+ rewrite map_skipn. f_equal.
rewrite !map_map_compose.
- rewrite isEtaExp_Constructor // in H2.
- move/andP: H2 => [] etaapp' ev.
- clear -H0 H1 ev H. solve_all.
- - pose proof (etaExp_csubst _ _ k _ H1 H2).
- rewrite !csubst_mkApps /= in H3 *.
+ rewrite isEtaExp_Constructor // in H0. rtoProp. solve_all.
+ - pose proof (etaExp_csubst _ _ k _ etaa H0).
+ rewrite !csubst_mkApps /= in H1 *.
assert (map (csubst a k) v <> []).
{ destruct v; cbn; congruence. }
rewrite strip_mkApps //.
@@ -433,9 +435,9 @@ Arguments isEtaExp : simpl never.
Lemma isEtaExp_mkApps {Σ} {f u} : isEtaExp Σ (tApp f u) ->
let (hd, args) := decompose_app (tApp f u) in
match construct_viewc hd with
- | view_construct kn c =>
+ | view_construct kn c block_args =>
args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\
- isEtaExp_app Σ kn c #|args| && forallb (isEtaExp Σ) args
+ isEtaExp_app Σ kn c #|args| && forallb (isEtaExp Σ) args && is_nil block_args
| view_other _ discr =>
[&& isEtaExp Σ hd, forallb (isEtaExp Σ) args, isEtaExp Σ f & isEtaExp Σ u]
end.
@@ -496,7 +498,7 @@ Proof.
rewrite isEtaExp_mkApps_napp // in etaf.
simp construct_viewc in etaf.
move/andP: etaf => []. rewrite /isEtaExp_app hl.
- move/Nat.leb_le. lia. }
+ move => /andP[] /Nat.leb_le. lia. }
{ move/and4P=> [] iset isel _ _. rewrite (decompose_app_inv da).
pose proof (decompose_app_notApp _ _ _ da).
rewrite strip_mkApps //.
@@ -531,9 +533,9 @@ Module Fast.
| app, tCoFix mfix idx =>
let mfix' := strip_defs mfix in
mkApps (EAst.tCoFix mfix' idx) app
- | app, tConstruct kn c with GlobalContextMap.lookup_inductive_pars Σ (inductive_mind kn) := {
- | Some npars => mkApps (EAst.tConstruct kn c) (List.skipn npars app)
- | None => mkApps (EAst.tConstruct kn c) app }
+ | app, tConstruct kn c block_args with GlobalContextMap.lookup_inductive_pars Σ (inductive_mind kn) := {
+ | Some npars => mkApps (EAst.tConstruct kn c block_args) (List.skipn npars app)
+ | None => mkApps (EAst.tConstruct kn c block_args) app }
| app, x => mkApps x app }
where strip_args (t : list term) : list term :=
@@ -646,22 +648,22 @@ Proof.
rewrite mkApps_app /= //.
Qed.
-Lemma isLambda_mkApps_Construct ind n l :
- ~~ EAst.isLambda (EAst.mkApps (EAst.tConstruct ind n) l).
+Lemma isLambda_mkApps_Construct ind n block_args l :
+ ~~ EAst.isLambda (EAst.mkApps (EAst.tConstruct ind n block_args) l).
Proof.
induction l using rev_ind; cbn; try congruence.
rewrite mkApps_app /= //.
Qed.
-Lemma isBox_mkApps_Construct ind n l :
- ~~ isBox (EAst.mkApps (EAst.tConstruct ind n) l).
+Lemma isBox_mkApps_Construct ind n block_args l :
+ ~~ isBox (EAst.mkApps (EAst.tConstruct ind n block_args) l).
Proof.
induction l using rev_ind; cbn; try congruence.
rewrite mkApps_app /= //.
Qed.
-Lemma isFix_mkApps_Construct ind n l :
- ~~ isFix (EAst.mkApps (EAst.tConstruct ind n) l).
+Lemma isFix_mkApps_Construct ind n block_args l :
+ ~~ isFix (EAst.mkApps (EAst.tConstruct ind n block_args) l).
Proof.
induction l using rev_ind; cbn; try congruence.
rewrite mkApps_app /= //.
@@ -673,7 +675,7 @@ Proof.
funelim (strip Σ f); cbn -[strip]; (try simp_strip) => //.
rewrite (negbTE (isLambda_mkApps' _ _ _)) //.
rewrite (negbTE (isLambda_mkApps' _ _ _)) //; try apply map_nil => //.
- all:rewrite !(negbTE (isLambda_mkApps_Construct _ _ _)) //.
+ all:rewrite !(negbTE (isLambda_mkApps_Construct _ _ _ _)) //.
Qed.
Lemma strip_isBox Σ f :
@@ -683,7 +685,7 @@ Proof.
all:rewrite map_InP_spec.
rewrite (negbTE (isBox_mkApps' _ _ _)) //.
rewrite (negbTE (isBox_mkApps' _ _ _)) //; try apply map_nil => //.
- all:rewrite !(negbTE (isBox_mkApps_Construct _ _ _)) //.
+ all:rewrite !(negbTE (isBox_mkApps_Construct _ _ _ _)) //.
Qed.
Lemma isApp_mkApps u v : v <> nil -> isApp (mkApps u v).
@@ -708,7 +710,7 @@ Proof.
all:rewrite map_InP_spec.
rewrite (negbTE (isFix_mkApps' _ _ _)) //.
rewrite (negbTE (isFix_mkApps' _ _ _)) //; try apply map_nil => //.
- all:rewrite !(negbTE (isFix_mkApps_Construct _ _ _)) //.
+ all:rewrite !(negbTE (isFix_mkApps_Construct _ _ _ _)) //.
Qed.
Lemma strip_isFixApp Σ f :
@@ -776,15 +778,16 @@ Proof.
destruct construct_viewc eqn:vc.
+ move=> /andP[] hl0 etal0.
rewrite -mkApps_app.
- rewrite (strip_mkApps Σ (tConstruct ind n)) // /=.
+ rewrite (strip_mkApps Σ (tConstruct ind n block_args)) // /=.
rewrite strip_mkApps // /=.
unfold isEtaExp_app in hl0.
destruct lookup_constructor_pars_args as [[pars args']|] eqn:hl => //.
- eapply Nat.leb_le in hl0.
+ rtoProp.
+ eapply Nat.leb_le in H.
rewrite (lookup_inductive_pars_constructor_pars_args hl).
rewrite -mkApps_app. f_equal. rewrite map_app.
rewrite skipn_app. len. assert (pars - #|l| = 0) by lia.
- now rewrite H skipn_0.
+ now rewrite H1 skipn_0.
+ move=> /andP[] etat0 etal0.
rewrite -mkApps_app !strip_mkApps; try now eapply decompose_app_notApp.
rewrite vc. rewrite -mkApps_app !map_app //.
@@ -820,7 +823,7 @@ Proof.
split; intros; rtoProp; intuition auto; solve_all.
Qed.
-Lemma strip_eval (efl := all_env_flags) {wfl:WcbvFlags} {Σ : GlobalContextMap.t} t v :
+Lemma strip_eval (efl := all_env_flags) {wfl:WcbvFlags} {wcon : with_constructor_as_block = false} {Σ : GlobalContextMap.t} t v :
closed_env Σ ->
isEtaExp_env Σ ->
wf_glob Σ ->
@@ -831,7 +834,7 @@ Lemma strip_eval (efl := all_env_flags) {wfl:WcbvFlags} {Σ : GlobalContextMap.t
Proof.
intros clΣ etaΣ wfΣ ev clt etat.
revert t v clt etat ev.
- apply (eval_preserve_mkApps_ind wfl Σ (fun x y => eval (strip_env Σ) (strip Σ x) (strip Σ y))
+ unshelve eapply (eval_preserve_mkApps_ind wfl wcon Σ (fun x y => eval (strip_env Σ) (strip Σ x) (strip Σ y))
(fun n x => closedn n x) (Qpres := Qpreserves_closedn Σ clΣ)) => //.
{ intros. eapply eval_closed; tea. }
all:intros; simpl in *.
@@ -863,7 +866,7 @@ Proof.
* cbn -[strip].
have etaargs : forallb (isEtaExp Σ) args.
{ rewrite isEtaExp_Constructor in i6.
- now move/andP: i6 => []. }
+ now move/andP: i6 => [] /andP[]. }
rewrite strip_iota_red // in e.
rewrite closedn_mkApps in i4. now move/andP: i4.
cbn. now eapply nth_error_forallb in H; tea.
@@ -1057,8 +1060,15 @@ Proof.
destruct g eqn:hg => /= //. subst g.
destruct (cst_body c) => //.
- rewrite lookup_env_strip //.
- destruct lookup_env eqn:hl => // /=.
- destruct g eqn:hg => /= //.
+ destruct lookup_env eqn:hl => // /=; intros; rtoProp; eauto.
+ destruct g eqn:hg => /= //; intros; rtoProp; eauto.
+ destruct cstr_as_blocks; repeat split; eauto.
+ destruct nth_error => /= //.
+ destruct nth_error => /= //.
+ destruct nth_error => /= //.
+ destruct nth_error => /= //. rtoProp. split. solve_all.
+ eapply Nat.leb_le in H0. eapply Nat.leb_le. lia.
+ solve_all.
destruct nth_error => /= //.
destruct nth_error => /= //.
- rewrite lookup_env_strip //.
@@ -1088,7 +1098,9 @@ Qed.
Definition switch_no_params (efl : EEnvFlags) :=
{| has_axioms := has_axioms;
has_cstr_params := false;
- term_switches := term_switches |}.
+ term_switches := term_switches ;
+ cstr_as_blocks := false
+ |}.
Lemma strip_decl_wf (efl := all_env_flags) {Σ : GlobalContextMap.t} :
wf_glob Σ ->
@@ -1175,7 +1187,7 @@ Proof.
rewrite strip_mkApps // /=.
move: Heq.
rewrite GlobalContextMap.lookup_inductive_pars_spec.
- unfold wellformed in wfc. move/andP: wfc => [] hacc hc.
+ unfold wellformed in wfc. move/andP: wfc => [] /andP[] hacc hc bargs.
unfold lookup_inductive_pars. destruct lookup_minductive eqn:heq => //.
unfold lookup_constructor, lookup_inductive in hc. rewrite heq /= // in hc.
Qed.
diff --git a/erasure/theories/ESpineView.v b/erasure/theories/ESpineView.v
index 7bee803c6..8bbb0ca70 100644
--- a/erasure/theories/ESpineView.v
+++ b/erasure/theories/ESpineView.v
@@ -17,7 +17,7 @@ Inductive t : term -> Set :=
| tLetIn n b b' : t (EAst.tLetIn n b b')
| tApp (f : term) (l : list term) (napp : ~~ isApp f) (nnil : l <> nil) : t (mkApps f l)
| tConst kn : t (tConst kn)
-| tConstruct i n : t (tConstruct i n)
+| tConstruct i n args : t (tConstruct i n args)
| tCase ci p brs : t (tCase ci p brs)
| tProj p c : t (tProj p c)
| tFix mfix idx : t (tFix mfix idx)
diff --git a/erasure/theories/ETransform.v b/erasure/theories/ETransform.v
index 9b34d1a0b..ab608037b 100644
--- a/erasure/theories/ETransform.v
+++ b/erasure/theories/ETransform.v
@@ -111,7 +111,7 @@ Qed.
Import EWcbvEval (WcbvFlags, with_prop_case, with_guarded_fix).
-Program Definition guarded_to_unguarded_fix {fl : EWcbvEval.WcbvFlags} {efl : EEnvFlags} (wguard : with_guarded_fix) :
+Program Definition guarded_to_unguarded_fix {fl : EWcbvEval.WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} {efl : EEnvFlags} (wguard : with_guarded_fix) :
Transform.t eprogram_env eprogram_env EAst.term EAst.term
(eval_eprogram_env fl) (eval_eprogram_env (EWcbvEval.switch_unguarded_fix fl)) :=
{| name := "switching to unguarded fixpoints";
@@ -122,10 +122,10 @@ Program Definition guarded_to_unguarded_fix {fl : EWcbvEval.WcbvFlags} {efl : EE
Next Obligation. cbn. eauto. Qed.
Next Obligation.
cbn.
- move=> fl efl wguard [Σ t] v [wfp [etae etat]]. cbn in *.
+ move=> fl wcon efl wguard [Σ t] v [wfp [etae etat]]. cbn in *.
intros [ev]. exists v. split => //.
red. sq. cbn in *.
- apply EEtaExpandedFix.eval_opt_to_target => //. 2:apply wfp.
+ unshelve eapply EEtaExpandedFix.eval_opt_to_target => //. auto. 2:apply wfp.
now eapply EEtaExpandedFix.expanded_global_env_isEtaExp_env.
now eapply EEtaExpandedFix.expanded_isEtaExp.
Qed.
@@ -147,7 +147,7 @@ Next Obligation.
cbn. intros fl efl input v [] ev p'; exists v. split => //.
Qed.
-Program Definition remove_params_optimization {fl : EWcbvEval.WcbvFlags}
+Program Definition remove_params_optimization {fl : EWcbvEval.WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false}
(efl := all_env_flags):
Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) :=
{| name := "stripping constructor parameters";
@@ -156,7 +156,7 @@ Program Definition remove_params_optimization {fl : EWcbvEval.WcbvFlags}
post p := wf_eprogram (switch_no_params efl) p /\ EEtaExpanded.expanded_eprogram_cstrs p;
obseq g g' v v' := v' = (ERemoveParams.strip g.1 v) |}.
Next Obligation.
- move=> fl efl [Σ t] [wfp etap].
+ move=> fl wcon efl [Σ t] [wfp etap].
simpl.
cbn -[ERemoveParams.strip] in *.
split. now eapply ERemoveParams.strip_program_wf.
@@ -164,16 +164,17 @@ Next Obligation.
Qed.
Next Obligation.
- red. move=> ? [Σ t] /= v [[wfe wft] etap] [ev].
+ red. move=> ? wcon [Σ t] /= v [[wfe wft] etap] [ev].
eapply ERemoveParams.strip_eval in ev; eauto.
eexists; split => /= //. now sq. cbn in *.
now eapply wellformed_closed_env.
now move/andP: etap.
now eapply wellformed_closed.
now move/andP: etap.
+ Unshelve. auto.
Qed.
-Program Definition remove_params_fast_optimization (fl : EWcbvEval.WcbvFlags)
+Program Definition remove_params_fast_optimization (fl : EWcbvEval.WcbvFlags) {wcon : EWcbvEval.with_constructor_as_block = false}
(efl := all_env_flags) :
Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) :=
{| name := "stripping constructor parameters (faster?)";
@@ -182,7 +183,7 @@ Program Definition remove_params_fast_optimization (fl : EWcbvEval.WcbvFlags)
post p := wf_eprogram (switch_no_params efl) p /\ EEtaExpanded.expanded_eprogram_cstrs p;
obseq g g' v v' := v' = (ERemoveParams.strip g.1 v) |}.
Next Obligation.
- move=> fl efl [Σ t] [wfp etap].
+ move=> fl wcon efl [Σ t] [wfp etap].
simpl.
cbn -[ERemoveParams.strip] in *.
rewrite -ERemoveParams.Fast.strip_fast -ERemoveParams.Fast.strip_env_fast.
@@ -192,7 +193,7 @@ Next Obligation.
Qed.
Next Obligation.
- red. move=> ? [Σ t] /= v [[wfe wft] etap] [ev].
+ red. move=> ? wcon [Σ t] /= v [[wfe wft] etap] [ev].
rewrite -ERemoveParams.Fast.strip_fast -ERemoveParams.Fast.strip_env_fast.
eapply ERemoveParams.strip_eval in ev; eauto.
eexists; split => /= //.
@@ -201,11 +202,12 @@ Next Obligation.
now move/andP: etap.
now eapply wellformed_closed.
now move/andP: etap.
+ Unshelve. auto.
Qed.
Import EOptimizePropDiscr EWcbvEval.
-Program Definition optimize_prop_discr_optimization {fl : WcbvFlags} {efl : EEnvFlags} {hastrel : has_tRel} {hastbox : has_tBox} :
+Program Definition optimize_prop_discr_optimization {fl : WcbvFlags} {wcon : with_constructor_as_block = false} {efl : EEnvFlags} {hastrel : has_tRel} {hastbox : has_tBox} :
Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram (disable_prop_cases fl)) :=
{| name := "optimize_prop_discr";
transform p _ := optimize_program p ;
@@ -214,22 +216,23 @@ Program Definition optimize_prop_discr_optimization {fl : WcbvFlags} {efl : EEnv
obseq g g' v v' := v' = EOptimizePropDiscr.optimize g.1 v |}.
Next Obligation.
- move=> fl efl hastrel hastbox [Σ t] [wfp etap].
+ move=> fl wcon efl hastrel hastbox [Σ t] [wfp etap].
cbn in *. split.
- now eapply optimize_program_wf.
- now eapply optimize_program_expanded.
Qed.
Next Obligation.
- red. move=> fl efl hastrel hastbox [Σ t] /= v [wfe wft] [ev].
+ red. move=> fl wcon efl hastrel hastbox [Σ t] /= v [wfe wft] [ev].
eapply EOptimizePropDiscr.optimize_correct in ev; eauto.
eexists; split => //. red. sq; auto. cbn. apply wfe.
eapply wellformed_closed_env, wfe.
eapply wellformed_closed, wfe.
+ Unshelve. eauto.
Qed.
From MetaCoq.Erasure Require Import EInlineProjections.
-Program Definition inline_projections_optimization {fl : WcbvFlags} (efl := all_env_flags)
+Program Definition inline_projections_optimization {fl : WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} (efl := switch_no_params all_env_flags)
{hastrel : has_tRel} {hastbox : has_tBox} :
Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) :=
{| name := "primitive projection inlining";
@@ -239,14 +242,39 @@ Program Definition inline_projections_optimization {fl : WcbvFlags} (efl := all_
obseq g g' v v' := v' = EInlineProjections.optimize g.1 v |}.
Next Obligation.
- move=> fl efl hastrel hastbox [Σ t] [wfp etap].
+ move=> fl wcon efl hastrel hastbox [Σ t] [wfp etap].
cbn in *. split.
- now eapply optimize_program_wf.
- now eapply optimize_program_expanded.
Qed.
Next Obligation.
- red. move=> fl hastrel hastbox [Σ t] /= v [wfe wft] [ev].
+ red. move=> fl wcon hastrel hastbox [Σ t] /= v [wfe wft] [ev].
eapply EInlineProjections.optimize_correct in ev; eauto.
eexists; split => //. red. sq; auto. cbn. apply wfe.
- cbn. eapply wfe.
+ cbn. eapply wfe. Unshelve. auto.
+Qed.
+
+From MetaCoq.Erasure Require Import EConstructorsAsBlocks.
+
+Program Definition constructors_as_blocks_transformation (efl := env_flags)
+ {hastrel : has_tRel} {hastbox : has_tBox} :
+ Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env target_wcbv_flags) (eval_eprogram block_wcbv_flags) :=
+ {| name := "transforming to constuctors as blocks";
+ transform p _ := EConstructorsAsBlocks.transform_blocks_program p ;
+ pre p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p;
+ post p := wf_eprogram env_flags_blocks p ;
+ obseq g g' v v' := True |}.
+
+Next Obligation.
+ move=> efl hastrel hastbox [Σ t] [] [wftp wft] /andP [etap etat].
+ cbn in *. split.
+ - eapply transform_wf_global; eauto.
+ - subst efl. eapply transform_wellformed; eauto.
+Qed.
+Next Obligation.
+ red. move=> hastrel hastbox [Σ t] /= v [[wfe1 wfe2] wft] [ev].
+ eexists. split; [ | eauto].
+ unfold EEtaExpanded.expanded_eprogram_env_cstrs in *.
+ revert wft. move => /andP // [e1 e2]. cbn in *.
+ econstructor. eapply transform_blocks_eval; cbn; eauto.
Qed.
\ No newline at end of file
diff --git a/erasure/theories/EWcbvEval.v b/erasure/theories/EWcbvEval.v
index f56783f91..5e3683b85 100644
--- a/erasure/theories/EWcbvEval.v
+++ b/erasure/theories/EWcbvEval.v
@@ -33,7 +33,7 @@ Definition atom Σ t :=
| tCoFix _ _
| tLambda _ _
| tFix _ _ => true
- | tConstruct ind c => isSome (lookup_constructor Σ ind c)
+ | tConstruct ind c [] => isSome (lookup_constructor Σ ind c)
| _ => false
end.
@@ -54,17 +54,17 @@ Proof.
Qed.
(* Tells if the evaluation relation should include match-prop and proj-prop reduction rules. *)
-Class WcbvFlags := { with_prop_case : bool ; with_guarded_fix : bool }.
+Class WcbvFlags := { with_prop_case : bool ; with_guarded_fix : bool ; with_constructor_as_block : bool }.
Definition disable_prop_cases fl : WcbvFlags :=
- {| with_prop_case := false; with_guarded_fix := fl.(@with_guarded_fix) |}.
+ {| with_prop_case := false; with_guarded_fix := fl.(@with_guarded_fix) ; with_constructor_as_block := fl.(@with_constructor_as_block) |}.
Definition switch_unguarded_fix fl : WcbvFlags :=
- EWcbvEval.Build_WcbvFlags fl.(@with_prop_case) false.
+ EWcbvEval.Build_WcbvFlags fl.(@with_prop_case) false fl.(@with_constructor_as_block).
-Definition default_wcbv_flags := {| with_prop_case := true ; with_guarded_fix := true |}.
-Definition opt_wcbv_flags := {| with_prop_case := false ; with_guarded_fix := true |}.
-Definition target_wcbv_flags := {| with_prop_case := false ; with_guarded_fix := false |}.
+Definition default_wcbv_flags := {| with_prop_case := true ; with_guarded_fix := true ; with_constructor_as_block := false |}.
+Definition opt_wcbv_flags := {| with_prop_case := false ; with_guarded_fix := true ; with_constructor_as_block := false|}.
+Definition target_wcbv_flags := {| with_prop_case := false ; with_guarded_fix := false ; with_constructor_as_block := false |}.
Section Wcbv.
Context {wfl : WcbvFlags}.
@@ -93,7 +93,19 @@ Section Wcbv.
(** Case *)
| eval_iota ind pars cdecl discr c args brs br res :
- eval discr (mkApps (tConstruct ind c) args) ->
+ with_constructor_as_block = false ->
+ eval discr (mkApps (tConstruct ind c []) args) ->
+ constructor_isprop_pars_decl Σ ind c = Some (false, pars, cdecl) ->
+ nth_error brs c = Some br ->
+ #|args| = pars + cdecl.(cstr_nargs) ->
+ #|skipn pars args| = #|br.1| ->
+ eval (iota_red pars args br) res ->
+ eval (tCase (ind, pars) discr brs) res
+
+ (** Case *)
+ | eval_iota_block ind pars cdecl discr c args brs br res :
+ with_constructor_as_block = true ->
+ eval discr (tConstruct ind c args) ->
constructor_isprop_pars_decl Σ ind c = Some (false, pars, cdecl) ->
nth_error brs c = Some br ->
#|args| = pars + cdecl.(cstr_nargs) ->
@@ -159,7 +171,18 @@ Section Wcbv.
(** Proj *)
| eval_proj p cdecl discr args a res :
- eval discr (mkApps (tConstruct p.(proj_ind) 0) args) ->
+ with_constructor_as_block = false ->
+ eval discr (mkApps (tConstruct p.(proj_ind) 0 []) args) ->
+ constructor_isprop_pars_decl Σ p.(proj_ind) 0 = Some (false, p.(proj_npars), cdecl) ->
+ #|args| = p.(proj_npars) + cdecl.(cstr_nargs) ->
+ nth_error args (p.(proj_npars) + p.(proj_arg)) = Some a ->
+ eval a res ->
+ eval (tProj p discr) res
+
+ (** Proj *)
+ | eval_proj_block p cdecl discr args a res :
+ with_constructor_as_block = true ->
+ eval discr (tConstruct p.(proj_ind) 0 args) ->
constructor_isprop_pars_decl Σ p.(proj_ind) 0 = Some (false, p.(proj_npars), cdecl) ->
#|args| = p.(proj_npars) + cdecl.(cstr_nargs) ->
nth_error args (p.(proj_npars) + p.(proj_arg)) = Some a ->
@@ -175,12 +198,21 @@ Section Wcbv.
(** Constructor congruence: we do not allow over-applications *)
| eval_construct ind c mdecl idecl cdecl f args a a' :
+ with_constructor_as_block = false ->
lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) ->
- eval f (mkApps (tConstruct ind c) args) ->
+ eval f (mkApps (tConstruct ind c []) args) ->
#|args| < cstr_arity mdecl cdecl ->
eval a a' ->
- eval (tApp f a) (tApp (mkApps (tConstruct ind c) args) a')
+ eval (tApp f a) (tApp (mkApps (tConstruct ind c []) args) a')
+ (** Constructor congruence: we do not allow over-applications *)
+ | eval_construct_block ind c mdecl idecl cdecl args args' a a' :
+ with_constructor_as_block = true ->
+ lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) ->
+ #|args| < cstr_arity mdecl cdecl ->
+ eval (tConstruct ind c args) (tConstruct ind c args') ->
+ eval a a' ->
+ eval (tConstruct ind c (args ++ [a])) (tConstruct ind c (args' ++ [a']))
(** Atoms (non redex-producing heads) applied to values are values *)
| eval_app_cong f f' a a' :
@@ -214,9 +246,10 @@ Section Wcbv.
Variant value_head (nargs : nat) : term -> Type :=
| value_head_cstr ind c mdecl idecl cdecl :
+ with_constructor_as_block = false ->
lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) ->
nargs <= cstr_arity mdecl cdecl ->
- value_head nargs (tConstruct ind c)
+ value_head nargs (tConstruct ind c [])
| value_head_cofix mfix idx : value_head nargs (tCoFix mfix idx)
| value_head_fix mfix idx rarg fn :
cunfold_fix mfix idx = Some (rarg, fn) ->
@@ -228,6 +261,11 @@ Section Wcbv.
Inductive value : term -> Type :=
| value_atom t : atom Σ t -> value t
+ | value_constructor ind c mdecl idecl cdecl args :
+ with_constructor_as_block = true ->
+ lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) ->
+ #|args| <= cstr_arity mdecl cdecl ->
+ All value args -> value (tConstruct ind c args)
| value_app_nonnil f args : value_head #|args| f -> args <> [] -> All value args -> value (mkApps f args).
Derive Signature for value.
@@ -245,19 +283,24 @@ Section Wcbv.
Lemma value_app f args : value_head #|args| f -> All value args -> value (mkApps f args).
Proof.
destruct args.
- - intros [] hv; constructor; try easy. cbn [atom mkApps]. now rewrite e.
+ - intros [] hv; constructor; try easy. cbn [atom mkApps]. now rewrite e0.
- intros vh av. eapply value_app_nonnil => //.
Qed.
Lemma value_values_ind : forall P : term -> Type,
(forall t, atom Σ t -> P t) ->
+ (forall (ind : inductive) (c : nat) (mdecl : mutual_inductive_body) (idecl : one_inductive_body) (cdecl : constructor_body)
+ (args : list term) (e : with_constructor_as_block = true) (e0 : lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl))
+ (l : #|args| <= cstr_arity mdecl cdecl) (a : All value args) , All P args ->
+ P (tConstruct ind c args)) ->
(forall f args, value_head #|args| f -> args <> [] -> All value args -> All P args -> P (mkApps f args)) ->
forall t : term, value t -> P t.
Proof.
- intros P ??.
+ intros P X X0 X1.
fix value_values_ind 2. destruct 1.
- apply X; auto.
- - eapply X0; auto; tea.
+ - eapply X0; auto; tea. clear -a value_values_ind. induction a; econstructor; auto.
+ - eapply X1; auto; tea.
clear v n. revert args a. fix aux 2. destruct 1. constructor; auto.
constructor. now eapply value_values_ind. now apply aux.
Defined.
@@ -277,12 +320,19 @@ Section Wcbv.
Lemma value_mkApps_inv t l :
~~ isApp t ->
value (mkApps t l) ->
- ((l = []) /\ atom Σ t) + ([× l <> [], value_head #|l| t & All value l]).
+ ((l = []) /\ atom Σ t)
+ + (l = [] × ∑ ind c mdecl idecl cdecl args, [ × with_constructor_as_block , lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl), t = tConstruct ind c args, #|args| <= cstr_arity mdecl cdecl & All value args])
+ + ([× l <> [], value_head #|l| t & All value l]).
Proof.
intros H H'. generalize_eq x (mkApps t l).
revert x H' t H. apply: value_values_ind.
- intros. subst.
now eapply atom_mkApps in H.
+ - intros * wcon lup len H IH t ht hcon.
+ destruct l using rev_ind.
+ + cbn in hcon. invs hcon. left. right.
+ repeat eexists; eauto.
+ + rewrite mkApps_app in hcon. invs hcon.
- intros * vh nargs hargs ih t isapp appeq.
move: (value_head_nApp vh) => Ht.
right. apply mkApps_eq_inj in appeq => //. intuition subst; auto => //.
@@ -294,8 +344,18 @@ Section Wcbv.
All value l.
Proof.
intros val not_app.
- now apply value_mkApps_inv in val as [(-> & ?)|[]].
+ now apply value_mkApps_inv in val as [[(-> & ?) | [-> ] ] |[]].
Qed.
+
+ Lemma eval_Construct_inv ind c args e :
+ eval (tConstruct ind c args) e ->
+ ∑ args', e = tConstruct ind c args' × All2 eval args args'.
+ Proof.
+ intros H. depind H.
+ - edestruct IHeval1 as (args'' & [= ->] & H2); eauto.
+ repeat eexists; eauto. eapply All2_app; eauto.
+ - invs i. destruct args; invs H0. exists []. repeat econstructor.
+ Qed.
Lemma eval_to_value e e' : eval e e' -> value e'.
Proof.
@@ -304,7 +364,10 @@ Section Wcbv.
- change (tApp ?h ?a) with (mkApps h [a]).
rewrite -mkApps_app.
apply value_mkApps_inv in IHev1; [|easy].
- destruct IHev1 as [(-> & _)|[]].
+ destruct IHev1 as [[(-> & _) | [-> ] ] |[]].
+ + apply value_app; auto. len.
+ cbn in *. econstructor; tea.
+ destruct with_guarded_fix => //. cbn; auto.
+ apply value_app; auto. len.
cbn in *. econstructor; tea.
destruct with_guarded_fix => //. cbn; auto.
@@ -314,12 +377,20 @@ Section Wcbv.
len; lia. apply All_app_inv; auto.
- apply value_mkApps_inv in IHev1; [|easy].
- destruct IHev1 as [(-> & _)|[]].
+ destruct IHev1 as [[(-> & _)|[-> ]] | []].
+ + cbn. eapply (value_app _ [a']); cbn; auto. econstructor; tea.
+ cbn. eapply (value_app _ [a']); cbn; auto. econstructor; tea.
+ rewrite -[tApp _ _](mkApps_app _ _ [a']).
eapply value_app. cbn; auto. econstructor; tea. cbn; len.
eapply All_app_inv; auto.
-
+
+ - invs IHev1.
+ + invs H. destruct args'; invs H1. econstructor 2; eauto. len; lia. now econstructor.
+ + rewrite e0 in H3; invs H3.
+ eapply eval_Construct_inv in ev1 as (? & [= <-] & Hall).
+ econstructor 2; eauto. len. eapply All2_length in Hall. lia.
+ eapply All_app_inv; eauto.
+ + destruct H1. destruct args0 using rev_ind. eauto. rewrite mkApps_app in H. invs H.
- destruct (mkApps_elim f' [a']).
eapply value_mkApps_inv in IHev1 => //.
destruct IHev1 as [?|[]]; intuition subst.
@@ -332,6 +403,13 @@ Section Wcbv.
now cbn in i. now cbn in i.
+ constructor.
+ econstructor; auto.
+ * destruct b0 as (ind & c & mdecl & idecl & cdecl & args & [H1 H2 H3 H4]).
+ rewrite -[tApp _ _](mkApps_app _ (firstn n l) [a']).
+ rewrite a0 in i |- *. simpl in *.
+ apply (value_app f0 [a']).
+ destruct f0; simpl in * |- *; try congruence.
+ + rewrite !negb_or /= in i; rtoProp; intuition auto.
+ + destruct with_guarded_fix. now cbn in i. now cbn in i.
* rewrite -[tApp _ _](mkApps_app _ (firstn n l) [a']).
eapply value_app; eauto with pcuic. 2:eapply All_app_inv; auto.
len.
@@ -353,7 +431,7 @@ Section Wcbv.
value_head n t -> eval t t.
Proof.
destruct 1.
- - constructor; try easy. now cbn [atom]; rewrite e.
+ - constructor; try easy. now cbn [atom]; rewrite e0.
- now eapply eval_atom.
- now eapply eval_atom.
Qed.
@@ -364,7 +442,7 @@ Section Wcbv.
Lemma value_head_spec' n t :
value_head n t -> (~~ (isLambda t || isBox t)) && atom Σ t.
Proof.
- induction 1; auto. cbn [atom]; rewrite e //.
+ induction 1; auto. cbn [atom]; rewrite e0 //.
Qed.
@@ -484,6 +562,7 @@ Section Wcbv.
- destruct L using rev_ind.
reflexivity.
rewrite mkApps_app in i. inv i.
+ - EAstUtils.solve_discr.
- EAstUtils.solve_discr. depelim v.
Qed.
@@ -528,6 +607,8 @@ Section Wcbv.
unfold atom in isatom. destruct argsv using rev_case => //.
split; auto. simpl. simpl in isatom. rewrite H //.
rewrite mkApps_app /= // in isatom.
+ - intros. destruct argsv using rev_case => //.
+ rewrite mkApps_app in Heqtfix => //.
- intros * vf hargs vargs ihargs eq. solve_discr => //. depelim vf. rewrite e.
intros [= <- <-]. destruct with_guarded_fix => //. split => //.
unfold isStuckFix. rewrite e. now apply Nat.leb_le.
@@ -546,13 +627,14 @@ Section Wcbv.
Qed.
Lemma eval_mkApps_Construct ind c mdecl idecl cdecl f args args' :
+ with_constructor_as_block = false ->
lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) ->
- eval f (tConstruct ind c) ->
+ eval f (tConstruct ind c []) ->
#|args| <= cstr_arity mdecl cdecl ->
All2 eval args args' ->
- eval (mkApps f args) (mkApps (tConstruct ind c) args').
+ eval (mkApps f args) (mkApps (tConstruct ind c []) args').
Proof.
- intros hdecl evf hargs. revert args'.
+ intros hblock hdecl evf hargs. revert args'.
induction args using rev_ind; intros args' evargs.
- depelim evargs. now cbn.
- eapply All2_app_inv_l in evargs as [r1 [r2 [-> [evl evr]]]].
@@ -564,6 +646,23 @@ Section Wcbv.
rewrite -(All2_length evl). lia.
Qed.
+ Lemma eval_mkApps_Construct_block ind c mdecl idecl cdecl f args args' :
+ with_constructor_as_block ->
+ lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) ->
+ eval f (tConstruct ind c []) ->
+ #|args| <= cstr_arity mdecl cdecl ->
+ All2 eval args args' ->
+ eval (tConstruct ind c args) (tConstruct ind c args').
+ Proof.
+ intros hblock hdecl evf hargs. revert args'.
+ induction args using rev_ind; intros args' evargs.
+ - depelim evargs. econstructor. now cbn [atom]; rewrite hdecl.
+ - eapply All2_app_inv_l in evargs as [r1 [r2 [-> [evl evr]]]].
+ depelim evr. depelim evr.
+ eapply eval_construct_block; tea. 1: revert hargs; len.
+ eapply IHargs => //. 1: revert hargs; len.
+ Qed.
+
Lemma eval_mkApps_CoFix f mfix idx args args' :
eval f (tCoFix mfix idx) ->
All2 eval args args' ->
@@ -620,6 +719,14 @@ Section Wcbv.
Proof.
move: e; eapply value_values_ind; simpl; intros; eauto with value.
- now constructor.
+ - assert (All2 eval args args).
+ { clear -X; induction X; constructor; auto. }
+ induction args using rev_ind. repeat econstructor.
+ cbn [atom]; now rewrite e0.
+ eapply All_app in a as [? HH]; eauto; invs HH.
+ eapply All_app in X as [? HH]; eauto; invs HH.
+ eapply All2_app_inv in X0 as [? HH]; eauto; invs HH.
+ econstructor; eauto. revert l. len. eapply IHargs; eauto. revert l. len.
- assert (All2 eval args args).
{ clear -X0; induction X0; constructor; auto. }
eapply eval_mkApps_cong => //. now eapply value_head_final.
@@ -656,9 +763,18 @@ Section Wcbv.
apply mkApps_eq_inj in apps_eq as (eq1 & eq2); try easy.
noconf eq1. noconf eq2.
noconf IHev1.
- pose proof e0. rewrite e4 in H. noconf H.
- pose proof e as e'. rewrite e3 in e'. noconf e'.
- rewrite -> (uip e e3), (uip e0 e4), (uip e1 e5), (uip e2 e6).
+ pose proof e0. rewrite e5 in H. noconf H.
+ pose proof e as e'. rewrite e4 in e'. noconf e'.
+ assert (br0 = br) as -> by congruence.
+ rewrite -> (uip e e4), (uip e0 e5), (uip e1 e6), (uip e2 e7), (uip e3 e8).
+ specialize (IHev2 _ ev'2); noconf IHev2.
+ reflexivity.
+ - depelim ev'; try go.
+ + specialize (IHev1 _ ev'1); noconf IHev1.
+ pose proof e0. rewrite e5 in H. noconf H.
+ pose proof e as e'. rewrite e4 in e'. noconf e'.
+ assert (br0 = br) as -> by congruence.
+ rewrite -> (uip e e4), (uip e0 e5), (uip e1 e6), (uip e2 e7), (uip e3 e8).
specialize (IHev2 _ ev'2); noconf IHev2.
reflexivity.
- depelim ev'; try go.
@@ -760,27 +876,48 @@ Section Wcbv.
specialize (IHev1 _ ev'1).
pose proof (mkApps_eq_inj (f_equal pr1 IHev1) eq_refl eq_refl) as (? & <-).
noconf H. noconf IHev1.
- pose proof e as e'. rewrite e2 in e'; noconf e'.
- rewrite -> (uip e e2), (uip e0 e3).
- pose proof e4 as e4'. rewrite e1 in e4'; noconf e4'.
- rewrite (uip e1 e4).
+ assert (a0 = a) as -> by congruence.
+ pose proof e0 as e'. rewrite e4 in e'; noconf e'.
+ rewrite -> (uip e e3), (uip e0 e4).
+ pose proof e5 as e4'. rewrite e1 in e4'; noconf e4'.
+ rewrite -> (uip e1 e5), (uip e2 e6).
+ now specialize (IHev2 _ ev'2); noconf IHev2.
+ - depelim ev'; try go.
+ specialize (IHev1 _ ev'1); noconf IHev1.
+ assert (a0 = a) as -> by congruence.
+ pose proof e0 as e'. rewrite e4 in e'; noconf e'.
+ rewrite -> (uip e e3), (uip e0 e4).
+ pose proof e5 as e4'. rewrite e1 in e4'; noconf e4'.
+ rewrite -> (uip e1 e5), (uip e2 e6).
now specialize (IHev2 _ ev'2); noconf IHev2.
- depelim ev'; try go.
specialize (IHev _ ev'). noconf IHev.
rewrite (uip e e0).
now rewrite (uip i i0).
- - depelim ev'; try go.
+ - depelim ev'; try now go.
+ move: (IHev1 _ ev'1).
eapply DepElim.simplification_sigma1 => heq IHev1'.
apply mkApps_eq_inj in heq as H'; auto.
destruct H' as (H' & <-). noconf H'.
noconf IHev1'.
- pose proof e as e'. rewrite e0 in e'; noconf e'.
+ pose proof e0 as e'. rewrite e2 in e'; noconf e'.
specialize (IHev2 _ ev'2). noconf IHev2.
- now rewrite -> (uip e e0), (PCUICWcbvEval.le_irrel _ _ l l0).
+ now rewrite -> (uip e e1), (uip e0 e2), (PCUICWcbvEval.le_irrel _ _ l l0).
+ specialize (IHev1 _ ev'1). noconf IHev1.
exfalso. rewrite isConstructApp_mkApps in i.
cbn in i. rewrite !negb_or in i. rtoProp; intuition auto.
+ - depelim ev'; try go.
+ + eapply app_inj_tail in e3 as e4. destruct e4 as [-> ->].
+ rewrite (uip e3 eq_refl) in H. cbn in H. subst.
+ move: (IHev1 _ ev'1).
+ eapply DepElim.simplification_sigma1 => heq IHev1'.
+ noconf heq.
+ noconf IHev1'.
+ specialize (IHev2 _ ev'2). noconf IHev2.
+ pose proof e2 as E.
+ rewrite e0 in E. noconf E.
+ now rewrite -> (uip e e1), (uip e0 e2), (PCUICWcbvEval.le_irrel _ _ l l0).
+ + exfalso. invs i. destruct args; invs H0.
- depelim ev'; try go.
+ exfalso. rewrite !negb_or in i. specialize (IHev1 _ ev'1); noconf IHev1.
cbn in i. rtoProp; intuition auto.
@@ -799,7 +936,8 @@ Section Wcbv.
specialize (IHev2 _ ev'2); noconf IHev2.
now assert (i0 = i) as -> by now apply uip.
- depelim ev'; try go.
- now assert (i0 = i) as -> by now apply uip.
+ 2: now assert (i0 = i) as -> by now apply uip.
+ exfalso. invs i. destruct args; cbn in H0; invs H0.
Qed.
Lemma eval_unique {t v} :
@@ -954,7 +1092,7 @@ Section WcbvEnv.
eauto using (extends_lookup_constructor wf ex), (extends_constructor_isprop_pars_decl wf ex), (extends_is_propositional wf ex)].
econstructor; eauto.
red in isdecl |- *. eauto using extends_lookup. constructor.
- destruct t => //. cbn [atom] in i. destruct lookup_constructor eqn:hl => //.
+ destruct t => //. cbn [atom] in i. destruct l => //. destruct lookup_constructor eqn:hl => //.
eapply (extends_lookup_constructor wf ex) in hl. now cbn [atom].
Qed.
@@ -1077,7 +1215,12 @@ Proof.
move: IHev1; rewrite closedn_mkApps => /andP[] _ clargs.
apply IHev2. rewrite /iota_red.
eapply closed_substl. now rewrite forallb_rev forallb_skipn.
- len. rewrite e2. eapply nth_error_forallb in Hc'; tea.
+ len. rewrite e3. eapply nth_error_forallb in Hc'; tea.
+ now rewrite Nat.add_0_r in Hc'.
+ - specialize (IHev1 Hc).
+ apply IHev2. rewrite /iota_red.
+ eapply closed_substl. now rewrite forallb_rev forallb_skipn.
+ len. rewrite e3. eapply nth_error_forallb in Hc'; tea.
now rewrite Nat.add_0_r in Hc'.
- subst brs. cbn in Hc'. rewrite andb_true_r in Hc'.
eapply IHev2. eapply closed_substl.
@@ -1113,9 +1256,15 @@ Proof.
rewrite closedn_mkApps /= => clargs.
eapply IHev2; eauto.
eapply nth_error_forallb in clargs; tea.
+ - have := (IHev1 Hc). intros clargs.
+ eapply IHev2; eauto.
+ eapply nth_error_forallb in clargs; tea.
- have := (IHev1 Hc).
rewrite closedn_mkApps /= => clargs.
rewrite clargs IHev2 //.
+ - rtoProp; intuition auto. forward IHev1; solve_all;
+ eapply All_app in Hc; solve_all.
+ eapply All_app_inv; solve_all. invs b. econstructor. eauto. econstructor.
- rtoProp; intuition auto.
Qed.
@@ -1126,10 +1275,11 @@ Ltac forward_keep H :=
assert (H' : X) ; [|specialize (H H')]
end.
-Definition mk_env_flags has_ax has_pars tfl :=
+Definition mk_env_flags has_ax has_pars tfl has_blocks :=
{| has_axioms := has_ax;
has_cstr_params := has_pars;
- term_switches := tfl |}.
+ term_switches := tfl ;
+ cstr_as_blocks := has_blocks |}.
Global Hint Rewrite andb_true_r andb_false_r : simplifications.
Global Hint Rewrite orb_false_r orb_true_r : simplifications.
@@ -1140,16 +1290,22 @@ Ltac sim := repeat (cbn ; autorewrite with simplifications).
Lemma eval_wellformed {efl : EEnvFlags} {wfl : WcbvFlags} Σ :
forall (has_app : has_tApp), (* necessary due to mkApps *)
+ efl.(cstr_as_blocks) = false ->
wf_glob Σ ->
forall t u, wellformed Σ 0 t -> eval Σ t u -> wellformed Σ 0 u.
Proof.
- move=> has_app clΣ t u Hc ev. move: Hc.
+ move=> has_app blcks clΣ t u Hc ev. move: Hc.
induction ev; simpl in *; auto;
(move/andP=> [/andP[Hc Hc'] Hc''] || move/andP=> [Hc Hc'] || move=>Hc); auto.
all:intros; intuition auto; rtoProp; intuition auto; rtoProp; eauto using wellformed_csubst.
- eapply IHev2; eauto.
eapply wellformed_iota_red_brs; tea => //.
rewrite wellformed_mkApps // in H2. move/andP: H2 => [] //.
+ - eapply IHev2; eauto.
+ eapply wellformed_iota_red_brs; tea => //.
+ destruct cstr_as_blocks; solve_all.
+ destruct lookup_constructor_pars_args as [ [] | ]; rtoProp; repeat solve_all.
+ destruct args; cbn in H3; eauto; econstructor.
- subst brs. eapply IHev2. sim in H0.
eapply wellformed_substl => //.
eapply All_forallb, All_repeat => //.
@@ -1177,6 +1333,13 @@ Proof.
eapply IHev2; eauto.
move/andP: clargs => [/andP[] hasc wfc wfargs].
eapply nth_error_forallb in wfargs; tea.
+ - eapply IHev2.
+ eapply nth_error_forallb in e2; eauto.
+ destruct cstr_as_blocks; eauto.
+ destruct lookup_constructor_pars_args as [ [] | ]; rtoProp; repeat solve_all.
+ destruct args; cbn in H0; eauto.
+ - destruct cstr_as_blocks; try congruence.
+ now destruct args; invs Hc''.
Qed.
Lemma remove_last_length {X} {l : list X} :
@@ -1237,6 +1400,9 @@ Proof.
- unshelve eexists; eauto. eapply eval_fix_value; eauto. eapply IHHe1. eapply IHHe2. cbn. destruct IHHe1, IHHe2. lia.
- unshelve eexists. eapply eval_construct; eauto.
eapply IHHe1. eapply IHHe2. cbn. destruct IHHe1, IHHe2. cbn. lia.
+ - unshelve eexists. eapply eval_construct_block; eauto.
+ { clear - l He1. eapply eval_Construct_inv in He1 as (? & ? & ?). eapply All2_length in a. invs e. lia. }
+ eapply IHHe1. eapply IHHe2. cbn. destruct IHHe1, IHHe2; lia.
- unshelve eexists. eapply eval_app_cong; eauto. eapply IHHe1. eapply IHHe2. cbn. destruct IHHe1, IHHe2. lia.
Qed.
@@ -1360,11 +1526,13 @@ Proof.
Qed.
Lemma eval_mkApps_Construct_inv {fl : WcbvFlags} Σ kn c args e :
- eval Σ (mkApps (tConstruct kn c) args) e ->
- ∑ args', [× isSome (lookup_constructor Σ kn c), (e = mkApps (tConstruct kn c) args') & All2 (eval Σ) args args'].
+ with_constructor_as_block = false ->
+ eval Σ (mkApps (tConstruct kn c []) args) e ->
+ ∑ args', [× isSome (lookup_constructor Σ kn c), (e = mkApps (tConstruct kn c []) args') & All2 (eval Σ) args args'].
Proof.
+ intros hblock.
revert e; induction args using rev_ind; intros e.
- - intros ev. depelim ev. exists []=> //.
+ - intros ev. depelim ev. congruence. exists []=> //.
- intros ev. rewrite mkApps_app /= in ev.
depelim ev; try solve_discr.
destruct (IHargs _ ev1) as [? []]. solve_discr.
@@ -1378,6 +1546,25 @@ Proof.
* now cbn in i.
Qed.
+Lemma eval_mkApps_Construct_block_inv {fl : WcbvFlags} Σ kn c args oargs e :
+ with_constructor_as_block ->
+ eval Σ (mkApps (tConstruct kn c args) oargs) e ->
+ ∑ args', oargs = [] × (e = tConstruct kn c args') × All2 (eval Σ) args args'.
+Proof.
+ intros hblock.
+ revert e; induction oargs using rev_ind; intros e.
+ - intros ev. depelim ev.
+ + eexists. split. reflexivity. split. reflexivity.
+ eapply eval_Construct_inv in ev1 as (? & [= <-] & ?).
+ eapply All2_app; eauto.
+ + invs i. destruct args; invs H0. exists []. repeat econstructor.
+ - intros ev. rewrite mkApps_app /= in ev.
+ depelim ev; try solve_discr.
+ all: try specialize (IHoargs _ ev1) as (? & ? & E & ?); try congruence; try solve_discr; try noconf E.
+ * subst. cbn in i. destruct with_guarded_fix; cbn in *; eauto.
+ * invs i.
+Qed.
+
Lemma eval_mkApps_inv_size {wfl : WcbvFlags} {Σ f args v} :
forall ev : eval Σ (mkApps f args) v,
∑ f' args' (evf : eval Σ f f'),
@@ -1466,31 +1653,33 @@ Proof.
Qed.
Lemma eval_mkApps_Construct_size {wfl : WcbvFlags} {Σ ind c args v} :
- forall ev : eval Σ (mkApps (tConstruct ind c) args) v,
- ∑ args' (evf : eval Σ (tConstruct ind c) (tConstruct ind c)),
+ with_constructor_as_block = false ->
+ forall ev : eval Σ (mkApps (tConstruct ind c []) args) v,
+ ∑ args' (evf : eval Σ (tConstruct ind c []) (tConstruct ind c [])),
[× eval_depth evf <= eval_depth ev,
All2 (fun a a' => ∑ eva : eval Σ a a', eval_depth eva < eval_depth ev) args args' &
- v = mkApps (tConstruct ind c) args'].
+ v = mkApps (tConstruct ind c []) args'].
Proof.
- intros ev.
+ intros hblock ev.
destruct (eval_mkApps_inv_size ev) as [f'' [args' [? []]]].
exists args'.
- destruct (eval_mkApps_Construct_inv _ _ _ _ _ ev) as [? []]. subst v.
- exists (eval_atom _ (tConstruct ind c) i).
+ destruct (eval_mkApps_Construct_inv _ _ _ _ _ hblock ev) as [? []]. subst v.
+ exists (eval_atom _ (tConstruct ind c []) i).
cbn. split => //. destruct ev; cbn => //; auto with arith.
clear l.
- eapply (eval_mkApps_Construct_inv _ _ _ []) in x as [? []]. subst f''. depelim a1.
+ eapply (eval_mkApps_Construct_inv _ _ _ [] _ hblock) in x as [? []]; auto. subst f''. depelim a1.
f_equal.
eapply eval_deterministic_all; tea.
- eapply All2_impl; tea; cbn; eauto. now intros x y [].
+ eapply All2_impl; tea; cbn; eauto. now intros x y [].
Qed.
-Lemma eval_construct_size {fl : WcbvFlags} [Σ kn c args e] :
- forall (ev : eval Σ (mkApps (tConstruct kn c) args) e),
- ∑ args', (e = mkApps (tConstruct kn c) args') ×
+Lemma eval_construct_size {fl : WcbvFlags} [Σ kn c args e] :
+ with_constructor_as_block = false ->
+ forall (ev : eval Σ (mkApps (tConstruct kn c []) args) e),
+ ∑ args', (e = mkApps (tConstruct kn c []) args') ×
All2 (fun x y => ∑ ev' : eval Σ x y, eval_depth ev' < eval_depth ev) args args'.
Proof.
- intros ev; destruct (eval_mkApps_Construct_size ev) as [args'[evf [_ hargs hv]]].
+ intros hblock ev; destruct (eval_mkApps_Construct_size hblock ev) as [args'[evf [_ hargs hv]]].
exists args'; intuition auto.
Qed.
@@ -1505,5 +1694,4 @@ Proof.
depelim H2.
specialize (IHx e _ H' H). simpl.
rewrite mkApps_app. simpl. econstructor; eauto.
-Qed.
-
+Qed.
\ No newline at end of file
diff --git a/erasure/theories/EWcbvEvalEtaInd.v b/erasure/theories/EWcbvEvalEtaInd.v
index 2c3ae7d7b..927479125 100644
--- a/erasure/theories/EWcbvEvalEtaInd.v
+++ b/erasure/theories/EWcbvEvalEtaInd.v
@@ -14,14 +14,14 @@ Hint Constructors eval : core.
Definition atomic_term (t : term) :=
match t with
- | tBox | tConstruct _ _ | tConst _ | tRel _ | tVar _ => true
+ | tBox | tConstruct _ _ _ | tConst _ | tRel _ | tVar _ => true
| _ => false
end.
Definition has_atom {etfl : ETermFlags} (t : term) :=
match t with
| tBox => has_tBox
- | tConstruct _ _ => has_tConstruct
+ | tConstruct _ _ _ => has_tConstruct
| tConst _ => has_tConst
| tRel _ => has_tRel
| tVar _ => has_tVar
@@ -143,7 +143,7 @@ Class Qpreserves {etfl : ETermFlags} (Q : nat -> term -> Type) Σ :=
Set Warnings "+future-coercion-class-field".
Lemma eval_preserve_mkApps_ind :
-∀ (wfl : WcbvFlags) {efl : EEnvFlags} (Σ : global_declarations)
+∀ (wfl : WcbvFlags), with_constructor_as_block = false -> forall {efl : EEnvFlags} (Σ : global_declarations)
(P' : term → term → Type)
(Q : nat -> term -> Type)
{Qpres : Qpreserves Q Σ}
@@ -177,8 +177,8 @@ Lemma eval_preserve_mkApps_ind :
(list name × term))
(br : list name × term) (res : term),
forallb (λ x : list name × term, isEtaExp Σ x.2) brs ->
- eval Σ discr (mkApps (tConstruct ind c) args)
- → P discr (mkApps (tConstruct ind c) args)
+ eval Σ discr (mkApps (tConstruct ind c []) args)
+ → P discr (mkApps (tConstruct ind c []) args)
→ constructor_isprop_pars_decl Σ ind c = Some (false, pars, cdecl)
→ nth_error brs c = Some br
→ #|args| = pars + cdecl.(cstr_nargs)
@@ -282,8 +282,8 @@ Lemma eval_preserve_mkApps_ind :
→ (∀ p cdecl (discr : term) (args : list term) a (res : term),
has_tProj ->
eval Σ discr
- (mkApps (tConstruct p.(proj_ind) 0) args)
- → P discr (mkApps (tConstruct p.(proj_ind) 0) args)
+ (mkApps (tConstruct p.(proj_ind) 0 []) args)
+ → P discr (mkApps (tConstruct p.(proj_ind) 0 []) args)
→ constructor_isprop_pars_decl Σ p.(proj_ind) 0 = Some (false, p.(proj_npars), cdecl)
→ #|args| = p.(proj_npars) + cdecl.(cstr_nargs)
-> nth_error args (p.(proj_npars) + p.(proj_arg)) = Some a
@@ -310,15 +310,15 @@ Lemma eval_preserve_mkApps_ind :
#|args| = cstr_arity mdecl cdecl ->
All2 (eval Σ) args args' ->
isEtaExp_app Σ ind i #|args| ->
- Q 0 (mkApps (tConstruct ind i) args) ->
- Q 0 (mkApps (tConstruct ind i) args') ->
+ Q 0 (mkApps (tConstruct ind i []) args) ->
+ Q 0 (mkApps (tConstruct ind i []) args') ->
All2 P args args' ->
- P' (mkApps (tConstruct ind i) args) (mkApps (tConstruct ind i) args')) →
+ P' (mkApps (tConstruct ind i []) args) (mkApps (tConstruct ind i []) args')) →
(∀ t : term, atom Σ t → Q 0 t -> isEtaExp Σ t -> P' t t) ->
∀ (t t0 : term), Q 0 t -> isEtaExp Σ t -> eval Σ t t0 → P' t t0.
Proof.
- intros * Qpres P P'Q etaΣ wfΣ hasapp.
+ intros wfl hcon. intros * Qpres P P'Q etaΣ wfΣ hasapp.
assert (qfixs: Qfixs Q) by tc.
assert (qcofixs: Qcofixs Q) by tc.
intros.
@@ -364,22 +364,22 @@ Proof.
eapply H; tea; (apply and_assum; [ih|hp' P'Q])
end.
destruct ev.
- 1-15:eapply qpres in qt as qt'; depelim qt' => //.
+ 1-18:eapply qpres in qt as qt'; depelim qt' => //.
- move/isEtaExp_tApp.
destruct decompose_app as [hd args] eqn:da.
destruct (construct_viewc hd) eqn:cv.
- * move=> [] argsn [] ha [] ht /andP[] etaind etaargs.
+ * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs.
clear IH; rewrite ha in ev1. elimtype False.
- eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr.
+ eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. auto.
* move=> /and4P [] etat0 etaargs etaa etat.
split. eapply X; tea; (apply and_assum; [ih|hp' P'Q]).
iheta q.
- move/isEtaExp_tApp.
destruct decompose_app as [hd args] eqn:da.
destruct (construct_viewc hd) eqn:cv.
- * move=> [] argsn [] ha [] ht /andP[] etaind etaargs.
+ * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs.
clear IH; rewrite ha in ev1. elimtype False.
- eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr.
+ eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. auto.
* move=> /and4P [] etat0 etaargs etaa etat.
assert (ql : Q 0 (tLambda na b)).
{ eapply P'Q; tea. ih. }
@@ -406,25 +406,26 @@ Proof.
- simp_eta. move=> /andP[etad etabrs].
assert (isEtaExp Σ (iota_red pars args br)).
{ eapply isEtaExp_iota_red.
- assert (isEtaExp Σ (mkApps (tConstruct ind c) args)) by iheta q.
- rewrite isEtaExp_mkApps_napp /= // in H.
+ assert (isEtaExp Σ (mkApps (tConstruct ind c []) args)) by iheta q.
+ rewrite isEtaExp_mkApps_napp /= // in H. rewrite andb_true_r in H.
now move/andP: H => [].
- now clear IH; eapply nth_error_forallb in e0; tea. }
+ now clear IH; eapply nth_error_forallb in e1; tea. }
assert (Q 0 (iota_red pars args br)).
{ unfold iota_red.
eapply nth_error_all in a; tea. cbn in a.
- rewrite -e2 in a.
+ rewrite -e3 in a.
rewrite -(List.rev_length (skipn pars args)) in a.
rewrite Nat.add_0_r in a.
eapply (qsubst _ (List.rev (skipn pars args))) in a.
2:{ eapply All_rev, All_skipn.
- assert (Q 0 (mkApps (tConstruct ind c) args)).
+ assert (Q 0 (mkApps (tConstruct ind c []) args)).
eapply P'Q; tea; ih.
eapply qapp in X13; tea. eapply X13. }
exact a. }
split. eapply X2; tea. 1,3:(apply and_assum; [ih|hp' P'Q]).
eapply nth_error_all in a; tea; cbn. now rewrite Nat.add_0_r in a.
iheta X13.
+ - congruence.
- simp_eta; move=> /andP[etad etabrs].
assert (isEtaExp Σ (substl (repeat tBox #|n|) f)).
{ eapply isEtaExp_substl => //. rewrite forallb_repeat //.
@@ -440,9 +441,9 @@ Proof.
- move/isEtaExp_tApp.
destruct decompose_app as [hd args] eqn:da.
destruct (construct_viewc hd) eqn:cv.
- * move=> [] argsn [] ha [] ht /andP[] etaind etaargs.
+ * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs.
clear IH; rewrite ha in ev1. elimtype False.
- eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr.
+ eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. auto.
* move=> /and4P [] etat0 etaargs etaa etat.
pose proof (ev1' := ev1). eapply P'Q in ev1' => //. 2:{ clear ev1'; ih. }
eapply qapp in ev1' as [hfix qargs] => //.
@@ -474,9 +475,9 @@ Proof.
- move/isEtaExp_tApp.
destruct decompose_app as [hd args] eqn:da.
destruct (construct_viewc hd) eqn:cv.
- * move=> [] argsn [] ha [] ht /andP[] etaind etaargs.
+ * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs.
clear IH; rewrite ha in ev1. elimtype False.
- eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr.
+ eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. auto.
* move=> /and4P [] etat0 etaargs etaa etat.
assert (isEtaExp Σ (tApp (mkApps (tFix mfix idx) argsv) av)).
{ rewrite -[tApp _ _](mkApps_app _ _ [av]).
@@ -490,9 +491,9 @@ Proof.
- move/isEtaExp_tApp.
destruct decompose_app as [hd args] eqn:da.
destruct (construct_viewc hd) eqn:cv.
- * move=> [] argsn [] ha [] ht /andP[] etaind etaargs.
+ * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs.
clear IH; rewrite ha in ev1. elimtype False.
- eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr.
+ eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. auto.
* move=> /and4P [] etat0 etaargs etaa etat.
assert (qav : Q 0 av).
{ eapply P'Q; tea; ih. }
@@ -573,13 +574,14 @@ Proof.
{ eapply nth_error_all in qargs; tea. }
clear ev1'; ih. }
assert (isEtaExp Σ a).
- { assert (isEtaExp Σ (mkApps (tConstruct p.(proj_ind) 0) args)) by iheta q.
+ { assert (isEtaExp Σ (mkApps (tConstruct p.(proj_ind) 0 []) args)) by iheta q.
move: H; simp_eta.
rewrite isEtaExp_mkApps_napp // /=.
- move=> /andP[] etaapp etaargs.
- eapply nth_error_forallb in etaargs; tea. }
+ move=> /andP[] /andP[] etaapp etaargs.
+ eapply nth_error_forallb in etaargs; tea. eauto. }
split. eapply X10; tea; (apply and_assum; [ih|hp' P'Q]).
iheta X13.
+ - congruence.
- simp_eta => etadiscr.
split. unshelve eapply X11; tea; try (intros; apply and_assum; [ih|hp' P'Q]).
now idtac.
@@ -587,11 +589,11 @@ Proof.
rename args into cargs.
destruct decompose_app as [hd args] eqn:da.
destruct (construct_viewc hd) eqn:cv.
- * move=> [] argsn [] ha [] ht /andP[] etaind etaargs.
+ * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs.
assert (eval_depth ev1 = eval_depth ev1) by reflexivity.
set (ev1' := ev1). change ev1 with ev1' in H at 1. clearbody ev1'. move: H.
subst f.
- pose proof (eval_construct_size ev1') as [ex []].
+ pose proof (eval_construct_size hcon ev1') as [ex []].
cbn in IH. intros eq.
assert (All2 (λ x y : term, ∑ ev' : eval Σ x y, eval_depth ev' < S (Nat.max (eval_depth ev1) (eval_depth ev2)))
(remove_last args ++ [a]) (ex ++ [a'])).
@@ -615,12 +617,12 @@ Proof.
eapply All2_All_mix_left in X15. 2:exact X14.
eapply All2_All_right; tea; cbn.
intros ? ? [? [? [? []]]]. split. eapply P'Q; tea. apply p. apply p. }
- eapply mkApps_eq_inj in e0 as [] => //. subst ex. noconf H.
+ eapply mkApps_eq_inj in e1 as [] => //. subst ex. noconf H.
split.
unshelve eapply Xcappexp; tea.
+ rewrite ht -remove_last_last //.
move: etaind; rewrite /isEtaExp_app.
- rewrite (lookup_constructor_pars_args_cstr_arity _ _ _ _ _ _ e).
+ rewrite (lookup_constructor_pars_args_cstr_arity _ _ _ _ _ _ e0).
move/Nat.leb_le. move: l. rewrite /cstr_arity.
eapply All2_length in X13. move: X13.
rewrite ht /= -remove_last_last //. len.
@@ -641,26 +643,28 @@ Proof.
+ rewrite isEtaExp_Constructor.
apply/andP. split. rewrite -(All2_length X16).
rewrite ht -remove_last_last //.
- eapply All_forallb. eapply All_impl; tea. cbn; intuition auto.
+ rtoProp. split. eauto.
+ eapply All_forallb. eapply All_impl; tea. cbn; intuition auto. auto.
* move=> /and4P [] etat0 etaargs etaa etat.
rewrite -[tApp _ a'](mkApps_app _ _ [a']).
- assert (P' f (mkApps (tConstruct ind c) cargs) × isEtaExp Σ (mkApps (tConstruct ind c) cargs)).
+ assert (P' f (mkApps (tConstruct ind c []) cargs) × isEtaExp Σ (mkApps (tConstruct ind c []) cargs)).
{ unshelve eapply IH; tea. cbn. lia. }
elimtype False.
destruct X13 as [p'f etac].
move: etac. rewrite isEtaExp_Constructor.
move/andP => []. rewrite /isEtaExp_app.
- rewrite /lookup_constructor_pars_args e /=.
- move/Nat.leb_le. clear IH. move: l; rewrite /cstr_arity. lia.
+ rewrite /lookup_constructor_pars_args e0 /=.
+ move => /andP[] /Nat.leb_le. clear IH. move: l; rewrite /cstr_arity. lia.
+ - congruence.
- move/isEtaExp_tApp.
destruct decompose_app as [hd args] eqn:da.
destruct (construct_viewc hd) eqn:cv.
- * move=> [] argsn [] ha [] ht /andP[] etaind etaargs.
+ * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs.
assert (eval_depth ev1 = eval_depth ev1) by reflexivity.
set (ev1' := ev1). change ev1 with ev1' in H at 1. clearbody ev1'. move: H.
subst f. exfalso.
eapply eval_mkApps_Construct_inv in ev1' as [? [hf' hargs']]. subst f'.
- clear IH; move: i; rewrite !negb_or isConstructApp_mkApps /= !andb_false_r //.
+ clear IH; move: i; rewrite !negb_or isConstructApp_mkApps /= !andb_false_r //. auto.
* move=> /and4P [] etat0 etaargs etaa etat.
split. eapply (X12 _ _ _ _ ev1); tea.
1,3:(apply and_assum; [ih|hp' P'Q]).
@@ -690,18 +694,19 @@ Ltac destruct_nary_times :=
| [ H : [× _, _, _, _ & _] |- _ ] => destruct H
end.
-Lemma eval_etaexp {fl : WcbvFlags} (efl := all_env_flags) {Σ a a'} :
+Lemma eval_etaexp {fl : WcbvFlags} (efl := all_env_flags) {Σ a a'} :
+ with_constructor_as_block = false ->
isEtaExp_env Σ ->
wf_glob Σ ->
eval Σ a a' -> isEtaExp Σ a -> isEtaExp Σ a'.
Proof.
- intros etaΣ wfΣ ev eta.
+ intros hcon etaΣ wfΣ ev eta.
generalize I. intros q. revert a a' q eta ev.
- eapply (eval_preserve_mkApps_ind (efl:=all_env_flags) fl Σ (fun _ x => isEtaExp Σ x) (fun _ _ => True) (Qpres := Qpreserves_True Σ)) => //.
+ eapply (eval_preserve_mkApps_ind (efl:=all_env_flags) fl hcon Σ (fun _ x => isEtaExp Σ x) (fun _ _ => True) (Qpres := Qpreserves_True Σ)) => //.
all:intros; repeat destruct_nary_times.
all:intuition auto.
- rewrite isEtaExp_Constructor => //.
- rewrite -(All2_length X0) H1.
+ rewrite -(All2_length X0) H1. cbn. rtoProp; intuition eauto.
cbn; eapply All_forallb. eapply All2_All_right; tea.
cbn. intros x y []; auto.
Qed.
diff --git a/erasure/theories/EWcbvEvalInd.v b/erasure/theories/EWcbvEvalInd.v
index 9c14cc8e6..5d1e69291 100644
--- a/erasure/theories/EWcbvEvalInd.v
+++ b/erasure/theories/EWcbvEvalInd.v
@@ -37,18 +37,36 @@ Section eval_mkApps_rect.
→ eval Σ (ECSubst.csubst b0' 0 b1) res
→ P (ECSubst.csubst b0' 0 b1) res →
P (tLetIn na b0 b1) res)
- → (∀ (ind : Kernames.inductive) (pars : nat) cdecl (discr : term)
- (c : nat) (args : list term) (brs : list (list BasicAst.name × term))
- (br : list BasicAst.name × term) (res : term),
- eval Σ discr (mkApps (tConstruct ind c) args)
- → P discr (mkApps (tConstruct ind c) args)
- → constructor_isprop_pars_decl Σ ind c = Some (false, pars, cdecl)
- → nth_error brs c = Some br
- → #|args| = pars + cdecl.(cstr_nargs)
- → #|skipn pars args| = #|br.1|
- → eval Σ (iota_red pars args br) res
- → P (iota_red pars args br) res
- → P (tCase (ind, pars) discr brs) res)
+ → (∀ (ind : inductive) (pars : nat) (cdecl : constructor_body)
+ (discr : term) (c : nat) (args : list term)
+ (brs : list (list name × term)) (br : list name × term)
+ (res : term) (e : with_constructor_as_block = false)
+ (e0 : eval Σ discr (mkApps (tConstruct ind c []) args)),
+ P discr (mkApps (tConstruct ind c []) args)
+ → ∀ (e1 : constructor_isprop_pars_decl Σ ind c =
+ Some (false, pars, cdecl)) (e2 :
+ nth_error brs c =
+ Some br)
+ (e3 : #|args| = pars + cstr_nargs cdecl)
+ (e4 : #|skipn pars args| = #|br.1|)
+ (e5 : eval Σ (iota_red pars args br) res),
+ P (iota_red pars args br) res
+ → P (tCase (ind, pars) discr brs) res)
+ → (∀ (ind : inductive) (pars : nat) (cdecl : constructor_body)
+ (discr : term) (c : nat) (args : list term)
+ (brs : list (list name × term)) (br : list name × term)
+ (res : term) (e : with_constructor_as_block = true)
+ (e0 : eval Σ discr (tConstruct ind c args)),
+ P discr (tConstruct ind c args)
+ → ∀ (e1 : constructor_isprop_pars_decl Σ ind c =
+ Some (false, pars, cdecl))
+ (e2 : nth_error brs c = Some br)
+ (e3 : #|args| = pars + cstr_nargs cdecl)
+ (e4 : #|skipn pars args| = #|br.1|)
+ (e5 : eval Σ (iota_red pars args br) res),
+ P (iota_red pars args br) res
+ → P (tCase (ind, pars) discr brs) res)
+
→ (∀ (ind : Kernames.inductive) (pars : nat) (discr : term)
(brs : list (list BasicAst.name × term))
(n : list BasicAst.name) (f3 res : term),
@@ -60,6 +78,7 @@ Section eval_mkApps_rect.
→ eval Σ (ECSubst.substl (repeat tBox #|n|) f3) res
→ P (ECSubst.substl (repeat tBox #|n|) f3) res
→ P (tCase (ind, pars) discr brs) res)
+
→ (∀ (f4 : term) (mfix : mfixpoint term)
(idx : nat) (argsv : list term)
(a av fn res : term),
@@ -121,16 +140,47 @@ Section eval_mkApps_rect.
cst_body decl = Some body
→ eval Σ body res
→ P body res → P (tConst c) res)
- → (∀ p (discr : term) (args : list term)
- (res : term) cdecl a,
- eval Σ discr (mkApps (tConstruct p.(proj_ind) 0) args)
- → P discr (mkApps (tConstruct p.(proj_ind) 0) args)
- → constructor_isprop_pars_decl Σ p.(proj_ind) 0 = Some (false, p.(proj_npars), cdecl)
- → #|args| = p.(proj_npars) + cdecl.(cstr_nargs)
- -> nth_error args (p.(proj_npars) + p.(proj_arg)) = Some a
- -> eval Σ a res
- → P a res
- → P (tProj p discr) res)
+
+ → (∀ (p : projection) (cdecl : constructor_body)
+ (discr : term) (args : list term)
+ (a res : term) (e : with_constructor_as_block =
+ false)
+ (e0 : eval Σ discr
+ (mkApps
+ (tConstruct
+ (proj_ind p) 0 []) args)),
+ P discr
+ (mkApps
+ (tConstruct (proj_ind p) 0 [])
+ args)
+ → ∀ (e1 : constructor_isprop_pars_decl Σ
+ (proj_ind p) 0 =
+ Some (false, proj_npars p, cdecl))
+ (e2 : #|args| =
+ proj_npars p + cstr_nargs cdecl)
+ (e3 : nth_error args
+ (proj_npars p + proj_arg p) =
+ Some a) (e4 : eval Σ a res),
+ P a res
+ → P (tProj p discr) res)
+ → (∀ (p : projection) (cdecl : constructor_body)
+ (discr : term) (args : list term)
+ (a res : term) (e :
+ with_constructor_as_block =
+ true)
+ (e0 : eval Σ discr
+ (tConstruct (proj_ind p) 0 args)),
+ P discr (tConstruct (proj_ind p) 0 args)
+ → ∀ (e1 : constructor_isprop_pars_decl Σ
+ (proj_ind p) 0 =
+ Some (false, proj_npars p, cdecl))
+ (e2 : #|args| =
+ proj_npars p + cstr_nargs cdecl)
+ (e3 : nth_error args
+ (proj_npars p + proj_arg p) =
+ Some a) (e4 : eval Σ a res),
+ P a res
+ → P (tProj p discr) res)
→ (∀ p (discr : term),
with_prop_case
@@ -139,30 +189,72 @@ Section eval_mkApps_rect.
→ inductive_isprop_and_pars Σ p.(proj_ind) = Some (true, p.(proj_npars))
→ P (tProj p discr) tBox)
- → (∀ ind c mdecl idecl cdecl f args a a',
- lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) ->
- forall (ev : eval Σ f (mkApps (tConstruct ind c) args)),
- IH _ _ ev ->
+ → (∀ (ind : inductive)
+ (c : nat) (mdecl : mutual_inductive_body)
+ (idecl : one_inductive_body)
+ (cdecl : constructor_body)
+ (f14 : term) (args : list term)
+ (a a' : term)
+ (e : with_constructor_as_block = false)
+ (e0 : lookup_constructor Σ ind c =
+ Some (mdecl, idecl, cdecl))
+ (e1 : eval Σ f14
+ (mkApps
+ (tConstruct ind c [])
+ args)),
+ IH _ _ e1 ->
+ P f14
+ (mkApps (tConstruct ind c [])
+ args)
+ → ∀ (l : #|args| < cstr_arity mdecl cdecl)
+ (e2 : eval Σ a a'),
+ P a a'
+ → P (tApp f14 a)
+ (tApp
+ (mkApps
+ (tConstruct ind c
+ []) args) a'))
- P f (mkApps (tConstruct ind c) args) ->
- #|args| < cstr_arity mdecl cdecl ->
- eval Σ a a' ->
- P a a' ->
- P (tApp f a) (tApp (mkApps (tConstruct ind c) args) a'))
+ → (∀ (ind : inductive)
+ (c : nat) (mdecl : mutual_inductive_body)
+ (idecl : one_inductive_body)
+ (cdecl : constructor_body)
+ (args args' :
+ list term) (a a' : term)
+ (e : with_constructor_as_block = true)
+ (e0 : lookup_constructor Σ ind c =
+ Some (mdecl, idecl, cdecl))
+ (l : #|args| < cstr_arity mdecl cdecl)
+ (e1 : eval Σ
+ (tConstruct ind c args)
+ (tConstruct ind c args')),
+ P (tConstruct ind c args)
+ (tConstruct ind c args')
+ → ∀ e2 : eval Σ a a',
+ P a a'
+ → P (tConstruct ind c (args ++ [a]))
+ (tConstruct ind c
+ (args' ++ [a'])))
- → (∀ (f11 f' : term) a a' ,
- forall (ev : eval Σ f11 f'),
- P f11 f' ->
- IH _ _ ev
- → ~~ (isLambda f' || (if with_guarded_fix then isFixApp f' else isFix f') || isBox f'
- || isConstructApp f')
- → eval Σ a a'
- → P a a'
- → P (tApp f11 a) (tApp f' a'))
+ → (∀ (f15 f' a a' : term) (e : eval Σ f15 f'),
+ P f15 f' -> IH _ _ e
+ → ∀ (i : ~~
+ (isLambda f'
+ ||
+ (if with_guarded_fix
+ then isFixApp f'
+ else isFix f') ||
+ isBox f' ||
+ isConstructApp f'))
+ (e0 : eval Σ a a'),
+ P a a'
+ → P (tApp f15 a)
+ (tApp f' a')
+ )
→ (∀ t : term, atom Σ t → P t t)
→ ∀ t t0 : term, eval Σ t t0 → P t t0.
Proof using Type.
- intros ?????????????????? H.
+ intros ????????????????????? H.
pose proof (p := @Fix_F { t : _ & { t0 : _ & eval Σ t t0 }}).
specialize (p (MR lt (fun x => eval_depth x.π2.π2))).
set(foo := existT _ t (existT _ t0 H) : { t : _ & { t0 : _ & eval Σ t t0 }}).
@@ -193,4 +285,3 @@ Proof using Type.
Qed.
End eval_mkApps_rect.
-
diff --git a/erasure/theories/EWellformed.v b/erasure/theories/EWellformed.v
index 68412ffc1..61ea8148a 100644
--- a/erasure/theories/EWellformed.v
+++ b/erasure/theories/EWellformed.v
@@ -39,7 +39,9 @@ Set Warnings "-future-coercion-class-field".
Class EEnvFlags := {
has_axioms : bool;
has_cstr_params : bool;
- term_switches :> ETermFlags }.
+ term_switches :> ETermFlags ;
+ cstr_as_blocks : bool ;
+ }.
Set Warnings "+future-coercion-class-field".
Definition all_term_flags :=
@@ -61,7 +63,14 @@ Definition all_term_flags :=
Definition all_env_flags :=
{| has_axioms := true;
term_switches := all_term_flags;
- has_cstr_params := true |}.
+ has_cstr_params := true ;
+ cstr_as_blocks := false |}.
+
+Definition all_env_flags_blocks :=
+ {| has_axioms := true;
+ term_switches := all_term_flags;
+ has_cstr_params := true ;
+ cstr_as_blocks := true |}.
Section wf.
@@ -78,6 +87,8 @@ Section wf.
Definition wf_fix_gen (wf : nat -> term -> bool) k mfix idx :=
let k' := List.length mfix + k in
(idx #|mfix|) && List.forallb (test_def (wf k')) mfix.
+
+ Definition is_nil {A} (l : list A) := match l with [] => true | _ => false end.
Fixpoint wellformed k (t : term) : bool :=
match t with
@@ -98,7 +109,7 @@ Section wf.
| Some d => has_axioms || isSome d.(cst_body)
| _ => false
end
- | tConstruct ind c => has_tConstruct && isSome (lookup_constructor Σ ind c)
+ | tConstruct ind c block_args => has_tConstruct && isSome (lookup_constructor Σ ind c) && if cstr_as_blocks then match lookup_constructor_pars_args Σ ind c with Some (p, a) => p + a <=? #|block_args| | _ => true end && forallb (wellformed k) block_args else is_nil block_args
| tVar _ => has_tVar
end.
@@ -160,7 +171,9 @@ Section EEnvFlags.
autorewrite with map;
simpl wellformed in *; intuition auto;
unfold wf_fix, test_def, test_snd in *;
- try solve [simpl lift; simpl closed; f_equal; auto; repeat (rtoProp; simpl in *; solve_all)]; try easy.
+ try solve [simpl lift; simpl closed; f_equal; auto; repeat (rtoProp; simpl in *; solve_all)]; try easy.
+ destruct cstr_as_blocks. 2: destruct args; eauto; solve_all.
+ rtoProp. solve_all.
Qed.
Lemma wellformed_closed_decl {t} : wf_global_decl Σ t -> closed_decl t.
@@ -178,7 +191,9 @@ Section EEnvFlags.
simpl wellformed in *; intuition auto;
unfold wf_fix, test_def, test_snd in *;
try solve [simpl lift; simpl closed; f_equal; auto; repeat (rtoProp; simpl in *; solve_all)]; try easy.
- eapply Nat.ltb_lt. now eapply Nat.ltb_lt in H2.
+ - eapply Nat.ltb_lt. now eapply Nat.ltb_lt in H2.
+ - destruct cstr_as_blocks; eauto. solve_all.
+ destruct lookup_constructor_pars_args as [ [] |]; rtoProp; repeat solve_all.
Qed.
Lemma wellformed_lift n k k' t : wellformed k t -> wellformed (k + n) (lift n k' t).
@@ -195,6 +210,8 @@ Section EEnvFlags.
elim (Nat.ltb_spec); auto. apply Nat.ltb_lt in H1. lia.
simpl; rewrite H0 /=. elim (Nat.ltb_spec); auto. intros.
apply Nat.ltb_lt in H1. lia.
+ - destruct cstr_as_blocks; eauto. destruct lookup_constructor_pars_args as [ [] | ]; rtoProp; repeat solve_all.
+ destruct args; firstorder.
- solve_all. rewrite Nat.add_assoc. eauto.
- len. move/andP: H1 => [] -> ha. cbn. solve_all.
rewrite Nat.add_assoc; eauto.
@@ -233,6 +250,8 @@ Section EEnvFlags.
- specialize (IHt2 (S k')).
rewrite <- Nat.add_succ_comm in IHt2.
eapply IHt2; auto.
+ - destruct cstr_as_blocks; eauto.
+ destruct lookup_constructor_pars_args as [ [] | ]; rtoProp; repeat solve_all. now destruct args; inv H0.
- specialize (a (#|x.1| + k')) => //.
rewrite Nat.add_assoc (Nat.add_comm k) in a.
rewrite !Nat.add_assoc. eapply a => //.
@@ -437,6 +456,8 @@ Proof.
induction t using EInduction.term_forall_list_ind; cbn => //; intros; rtoProp; intuition auto; solve_all.
all:try destruct lookup_env eqn:hl => //; try rewrite (extends_lookup wf ex hl).
all:try destruct g => //.
+ - destruct cstr_as_blocks; eauto; solve_all.
+ destruct lookup_constructor_pars_args as [ [] | ]; rtoProp; repeat solve_all.
- move/andP: H0 => [] hn hf. unfold wf_fix. rewrite hn /=. solve_all.
- move/andP: H0 => [] hn hf. unfold wf_fix. rewrite hn /=. solve_all.
Qed.
diff --git a/erasure/theories/Erasure.v b/erasure/theories/Erasure.v
index 3288adb96..3349efccc 100644
--- a/erasure/theories/Erasure.v
+++ b/erasure/theories/Erasure.v
@@ -40,17 +40,17 @@ Program Definition erasure_pipeline {guard : abstract_guard_impl} (efl := EWellf
(* Simulation of the guarded fixpoint rules with a single unguarded one:
the only "stuck" fixpoints remaining are unapplied.
This translation is a noop on terms and environments. *)
- guarded_to_unguarded_fix eq_refl ▷
+ guarded_to_unguarded_fix (wcon := eq_refl) eq_refl ▷
(* Remove all constructor parameters *)
- remove_params_optimization ▷
+ remove_params_optimization (wcon := eq_refl) ▷
(* Rebuild the efficient lookup table *)
rebuild_wf_env_transform (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) ▷
(* Remove all cases / projections on propositional content *)
- optimize_prop_discr_optimization (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) (hastrel := eq_refl) (hastbox := eq_refl) ▷
+ optimize_prop_discr_optimization (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) (wcon := eq_refl) (hastrel := eq_refl) (hastbox := eq_refl) ▷
(* Rebuild the efficient lookup table *)
- rebuild_wf_env_transform (efl := EWellformed.all_env_flags) ▷
+ rebuild_wf_env_transform (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) ▷
(* Inline projections to cases *)
- inline_projections_optimization (fl := EWcbvEval.target_wcbv_flags) (hastrel := eq_refl) (hastbox := eq_refl).
+ inline_projections_optimization (fl := EWcbvEval.target_wcbv_flags) (wcon := eq_refl) (hastrel := eq_refl) (hastbox := eq_refl).
(* At the end of erasure we get a well-formed program (well-scoped globally and localy), without
parameters in inductive declarations. The constructor applications are also expanded, and
the evaluation relation does not need to consider guarded fixpoints or case analyses on propositional
@@ -58,33 +58,10 @@ Program Definition erasure_pipeline {guard : abstract_guard_impl} (efl := EWellf
Import EGlobalEnv EWellformed.
-Lemma wf_global_switch_no_params (efl : EWellformed.EEnvFlags) Σ :
- wf_glob (efl := ERemoveParams.switch_no_params efl) Σ ->
- wf_glob (efl := efl) Σ.
-Proof.
- induction 1; constructor; auto.
- destruct d; cbn in *. auto.
- move/andP: H0 => [] hasp. unfold wf_minductive.
- cbn in hasp. rewrite hasp. rewrite orb_true_r //.
-Qed.
-
-Lemma wf_eprogram_switch_no_params (p : EProgram.eprogram) :
- EProgram.wf_eprogram (ERemoveParams.switch_no_params all_env_flags) p ->
- EProgram.wf_eprogram all_env_flags p.
-Proof.
- destruct p as [Σ p].
- intros []; split; cbn in * => //.
- now eapply wf_global_switch_no_params.
-Qed.
-
Next Obligation.
destruct H. split => //. sq.
now eapply ETransform.expanded_eprogram_env_expanded_eprogram_cstrs.
Qed.
-Next Obligation.
- split => //.
- now apply wf_eprogram_switch_no_params.
-Qed.
Definition run_erase_program {guard : abstract_guard_impl} := run erasure_pipeline.
@@ -92,10 +69,10 @@ Program Definition erasure_pipeline_fast {guard : abstract_guard_impl} (efl := E
template_to_pcuic_transform ▷
pcuic_expand_lets_transform ▷
erase_transform ▷
- guarded_to_unguarded_fix eq_refl ▷
- remove_params_fast_optimization _ ▷
+ guarded_to_unguarded_fix (wcon := eq_refl) eq_refl ▷
+ remove_params_fast_optimization (wcon := eq_refl) _ ▷
rebuild_wf_env_transform (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) ▷
- optimize_prop_discr_optimization (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) (hastrel := eq_refl) (hastbox := eq_refl).
+ optimize_prop_discr_optimization (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) (wcon := eq_refl) (hastrel := eq_refl) (hastbox := eq_refl).
Next Obligation.
destruct H; split => //. now eapply ETransform.expanded_eprogram_env_expanded_eprogram_cstrs.
Qed.
diff --git a/erasure/theories/ErasureCorrectness.v b/erasure/theories/ErasureCorrectness.v
index cdb5e374d..29d71b7b2 100644
--- a/erasure/theories/ErasureCorrectness.v
+++ b/erasure/theories/ErasureCorrectness.v
@@ -325,7 +325,7 @@ Proof.
invs H2.
-- exists x2. split; eauto.
- constructor. econstructor. eauto. 2:eauto.
+ constructor. econstructor. eauto. eauto. 2:eauto.
4:{ unfold EGlobalEnv.iota_red.
rewrite ECSubst.substl_subst //.
rewrite forallb_rev forallb_skipn //.
@@ -1021,7 +1021,7 @@ Proof.
eapply erases_deps_eval in Hed1; tea.
eapply erases_deps_mkApps_inv in Hed1 as [].
depelim H8.
- constructor. eapply Ee.eval_construct; tea.
+ constructor. eapply Ee.eval_construct; tea. eauto.
eapply (EGlobalEnv.declared_constructor_lookup H9).
rewrite -(Forall2_length H7).
rewrite /EAst.cstr_arity.
diff --git a/erasure/theories/ErasureFunction.v b/erasure/theories/ErasureFunction.v
index 4b6fc0280..0e61fb071 100644
--- a/erasure/theories/ErasureFunction.v
+++ b/erasure/theories/ErasureFunction.v
@@ -393,7 +393,7 @@ Section Erase.
| tSort u := !%prg
| tConst kn u := E.tConst kn
| tInd kn u := !%prg
- | tConstruct kn k u := E.tConstruct kn k
+ | tConstruct kn k u := E.tConstruct kn k []
| tProd _ _ _ := !%prg
| tLambda na b b' := let t' := erase (vass na b :: Γ) b' _ in
E.tLambda na.(binder_name) t'
@@ -1942,7 +1942,7 @@ Section wffix.
| tCoFix mfix idx =>
(idx #|mfix|) && List.forallb (wf_fixpoints ∘ dbody) mfix
| tConst kn => true
- | tConstruct ind c => true
+ | tConstruct ind c _ => true
| tVar _ => true
| tBox => true
end.
diff --git a/erasure/theories/ErasureProperties.v b/erasure/theories/ErasureProperties.v
index 8450c1c80..1b1ca62c5 100644
--- a/erasure/theories/ErasureProperties.v
+++ b/erasure/theories/ErasureProperties.v
@@ -635,7 +635,7 @@ Proof.
simpl; try solve [solve_all].
- now apply Nat.ltb_lt.
- eapply trans_lookup_constant in wfa; tea.
- - eapply trans_lookup_constructor in wfa; tea.
+ - eapply trans_lookup_constructor in wfa; tea. now rewrite wfa.
- move/andP: wfa => [] /andP[] lookup wfc wfbrs.
apply/andP. split. apply/andP. split; eauto.
eapply trans_lookup_inductive; tea.
@@ -677,7 +677,8 @@ Lemma eval_empty_brs {wfl : Ee.WcbvFlags} Σ ci p e : Σ ⊢ E.tCase ci p [] ▷
Proof.
intros He.
depind He.
- - clear -e0. now rewrite nth_error_nil in e0.
+ - clear -e1. now rewrite nth_error_nil in e1.
+ - clear -e1. now rewrite nth_error_nil in e1.
- discriminate.
- eapply IHHe2.
- cbn in i. discriminate.
@@ -693,6 +694,7 @@ Proof.
- depelim He1. clear -H. symmetry in H. elimtype False.
destruct args using rev_case. discriminate.
rewrite EAstUtils.mkApps_app in H. discriminate.
+ - depelim He1.
- exists n, f. intuition auto.
- depelim He1. clear -H. symmetry in H. elimtype False.
destruct args using rev_case. discriminate.
@@ -709,6 +711,8 @@ Proof.
depind He.
- pose proof (Ee.eval_deterministic He1 Hc). subst c'.
econstructor; eauto. now eapply Ee.value_final, Ee.eval_to_value.
+ - pose proof (Ee.eval_deterministic He1 Hc). subst c'.
+ eapply Ee.eval_iota_block; eauto. now eapply Ee.value_final, Ee.eval_to_value.
- pose proof (Ee.eval_deterministic He1 Hc). subst c'.
eapply Ee.eval_iota_sing; tea. now constructor.
- pose proof (Ee.eval_deterministic He1 Hc). subst c'.
@@ -726,6 +730,8 @@ Proof.
depind He.
- pose proof (eval_trans' Hc He1); subst discr.
econstructor; eauto.
+ - pose proof (eval_trans' Hc He1); subst discr.
+ now econstructor; eauto.
- pose proof (eval_trans' Hc He1); subst discr.
eapply Ee.eval_iota_sing; tea.
- pose proof (eval_trans' Hc He1); subst discr.
@@ -739,13 +745,15 @@ Lemma eval_proj_eval_inv_discr {wfl : Ee.WcbvFlags} {Σ p c c' e} :
Σ ⊢ E.tProj p c' ▷ e.
Proof.
intros He Hc.
- depind He.
+ depind He.
- pose proof (eval_trans' Hc He1); subst discr.
econstructor; eauto.
- pose proof (eval_trans' Hc He1); subst discr.
- eapply Ee.eval_proj; tea.
+ now econstructor; tea.
+ - pose proof (eval_trans' Hc He1); subst discr.
+ now econstructor; tea.
- pose proof (eval_trans' Hc He); subst discr.
- eapply Ee.eval_proj_prop; tea.
+ now econstructor; tea.
- cbn in i. discriminate.
Qed.
diff --git a/erasure/theories/Extract.v b/erasure/theories/Extract.v
index 94b6fb0a9..9f0136c81 100644
--- a/erasure/theories/Extract.v
+++ b/erasure/theories/Extract.v
@@ -55,7 +55,7 @@ Inductive erases (Σ : global_env_ext) (Γ : context) : term -> E.term -> Prop :
Σ;;; Γ |- tConst kn u ⇝ℇ E.tConst kn
| erases_tConstruct : forall (kn : inductive) (k : nat) (n : Instance.t),
isPropositional Σ kn false ->
- Σ;;; Γ |- tConstruct kn k n ⇝ℇ E.tConstruct kn k
+ Σ;;; Γ |- tConstruct kn k n ⇝ℇ E.tConstruct kn k []
| erases_tCase1 (ci : case_info) (p : predicate term) (c : term)
(brs : list (branch term)) (c' : E.term)
(brs' : list (list name × E.term)) :
@@ -113,7 +113,7 @@ Lemma erases_forall_list_ind
P Γ (tConst kn u) (E.tConst kn))
(Hconstruct : forall Γ kn k n,
isPropositional Σ kn false ->
- P Γ (tConstruct kn k n) (E.tConstruct kn k))
+ P Γ (tConstruct kn k n) (E.tConstruct kn k []))
(Hcase : forall Γ ci p c brs c' brs',
PCUICElimination.Informative Σ ci.(ci_ind) ->
Σ;;; Γ |- c ⇝ℇ c' ->
@@ -266,7 +266,7 @@ Inductive erases_deps (Σ : global_env) (Σ' : E.global_declarations) : E.term -
EGlobalEnv.declared_constructor Σ' (ind, c) mdecl' idecl' cdecl' ->
erases_mutual_inductive_body mdecl mdecl' ->
erases_one_inductive_body idecl idecl' ->
- erases_deps Σ Σ' (E.tConstruct ind c)
+ erases_deps Σ Σ' (E.tConstruct ind c [])
| erases_deps_tCase p mdecl idecl mdecl' idecl' discr brs :
declared_inductive Σ (fst p) mdecl idecl ->
EGlobalEnv.declared_inductive Σ' (fst p) mdecl' idecl' ->
From 1f4566280d450129f3bc0aece60969d2a80104ab Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Fri, 1 Jul 2022 10:08:43 +0200
Subject: [PATCH 12/43] [doc] Update erasure README.md for
constructors-as-blocks
---
erasure/theories/README.md | 76 ++++++++++++++++++++------------------
1 file changed, 40 insertions(+), 36 deletions(-)
diff --git a/erasure/theories/README.md b/erasure/theories/README.md
index 554d351d3..72fb993d4 100644
--- a/erasure/theories/README.md
+++ b/erasure/theories/README.md
@@ -4,41 +4,43 @@ Implementation of a verified extraction pipeline from PCUIC to untyped lambda ca
extended with a box construct for erased terms.
-| File | Description |
-|-----------------------|------------------------------------------------------|
-| [Prelim] | Preliminaries on PCUIC
-| [EArities] | Meta-theoretic lemmas on PCUIC needed for erasure correctness
-| [EAst] | AST of λ-box terms
-| [EAstUtils] | Utility definitions and lemmas on the AST
-| [ELiftSubst] | Lifting and substitution for λ-box terms
-| [ECSubst] | Definition of closed substitution (without lifting)
-| [EReflect] | Reflection of equality on the AST
-| [ESpineView] | Spine-view of λ-box terms (i.e., n-ary applications)
-| [EDeps] | Definitions of λ-box term dependencies (used to optimize erasure)
-| [EEnvMap] | Efficient global environment definition
-| [EGlobalEnv] | Global environment interface
-| [EEtaExpanded] | Eta-expansion predicates on λ-box terms, only for constructors
-| [EEtaExpandedFix] | Eta-expansion predicates on λ-box terms, for constructors and fixpoints
-| [EInduction] | Induction principles on λ-box terms
-| [EExtends] | Weakening of global environments
-| [EPretty] | Pretty-printing of λ-box programs
-| [EProgram] | Definition of well-formed λ-box programs and associated evaluation
-| [EWcbvEval] | Weak call-by-value evaluation definition
-| [EWcbvEvalEtaInd] | Induction principle on weak call-by-value evaluation preserving eta-expansion
-| [EWcbvEvalInd] | Induction principle on weak call-by-value evaluation
-| [EWellformed] | Well-formedness predicate on erased terms
-| [Extract] | The erasure relation
-| [ESubstitution] | Substitution and weakening lemmas for the erasure relation
-| [ErasureCorrectness] | The erasure relation correctness proof
-| [ErasureProperties] | Properties of the erasure relation
-| [ErasureFunction] | The erasure function defined on well-typed terms and its correctness proof
-| [EInlineProjections] | Transformation that inlines projections to cases
-| [EOptimizePropDiscr] | Transformation removing cases on propositional content
-| [ERemoveParams] | Remove constructor parameters
-| [ETransform] | Definitions of transformations from PCUIC to λ-box
-| [Erasure] | The complete erasure pipeline
-| [Extraction] | Extraction directives for the plugin
-| [Loader] | Loads the erasure plugin
+| File | Description |
+|-------------------------|------------------------------------------------------|
+| [Prelim] | Preliminaries on PCUIC
+| [EArities] | Meta-theoretic lemmas on PCUIC needed for erasure correctness
+| [EAst] | AST of λ-box terms
+| [EAstUtils] | Utility definitions and lemmas on the AST
+| [ELiftSubst] | Lifting and substitution for λ-box terms
+| [ECSubst] | Definition of closed substitution (without lifting)
+| [EReflect] | Reflection of equality on the AST
+| [ESpineView] | Spine-view of λ-box terms (i.e., n-ary applications)
+| [EDeps] | Definitions of λ-box term dependencies (used to optimize erasure)
+| [EEnvMap] | Efficient global environment definition
+| [EGlobalEnv] | Global environment interface
+| [EGenericMapEnv] | Generic well-formedness preservation proof for global environments
+| [EEtaExpanded] | Eta-expansion predicates on λ-box terms, only for constructors
+| [EEtaExpandedFix] | Eta-expansion predicates on λ-box terms, for constructors and fixpoints
+| [EInduction] | Induction principles on λ-box terms
+| [EExtends] | Weakening of global environments
+| [EPretty] | Pretty-printing of λ-box programs
+| [EProgram] | Definition of well-formed λ-box programs and associated evaluation
+| [EWcbvEval] | Weak call-by-value evaluation definition
+| [EWcbvEvalEtaInd] | Induction principle on weak call-by-value evaluation preserving eta-expansion
+| [EWcbvEvalInd] | Induction principle on weak call-by-value evaluation
+| [EWellformed] | Well-formedness predicate on erased terms
+| [Extract] | The erasure relation
+| [ESubstitution] | Substitution and weakening lemmas for the erasure relation
+| [ErasureCorrectness] | The erasure relation correctness proof
+| [ErasureProperties] | Properties of the erasure relation
+| [ErasureFunction] | The erasure function defined on well-typed terms and its correctness proof
+| [EInlineProjections] | Transformation that inlines projections to cases
+| [EOptimizePropDiscr] | Transformation removing cases on propositional content
+| [EConstructorsAsBlocks] | Transform constructor applications into an atomic construct (always fully-applied constructors)
+| [ERemoveParams] | Remove constructor parameters
+| [ETransform] | Definitions of transformations from PCUIC to λ-box
+| [Erasure] | The complete erasure pipeline
+| [Extraction] | Extraction directives for the plugin
+| [Loader] | Loads the erasure plugin
[EAll]: EAll.v
[EArities]: EArities.v
@@ -48,6 +50,7 @@ extended with a box construct for erased terms.
[ECoFixToFix]: ECoFixToFix.v
[EDeps]: EDeps.v
[EEnvMap]: EEnvMap.v
+[EGenericMapEnv]: EGenericMapEnv.v
[EEtaExpanded]: EEtaExpanded.v
[EEtaExpandedFix]: EEtaExpandedFix.v
[EExtends]: EExtends.v
@@ -69,7 +72,8 @@ extended with a box construct for erased terms.
[EWellformed]: EWellformed.v
[EWndEval]: EWndEval.v
[EWtAst]: EWtAst.v
-[Erasure]: Erasure.v
+[Erasure]: Erasure.v
+[EConstructorsAsBlocks]: EConstructorsAsBlocks.v
[ErasureCorrectness]: ErasureCorrectness.v
[ErasureFunction]: ErasureFunction.v
[ErasureProperties]: ErasureProperties.v
From 7fde2fbb0bf1bd48592c426666932ac38c5566cb Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Fri, 1 Jul 2022 10:23:05 +0200
Subject: [PATCH 13/43] Update README.md and self_erasure file
---
.vscode/metacoq.code-workspace | 1 +
README.md | 11 ++++++++++-
test-suite/self_erasure.v | 2 --
3 files changed, 11 insertions(+), 3 deletions(-)
diff --git a/.vscode/metacoq.code-workspace b/.vscode/metacoq.code-workspace
index e51f9f5b8..cb90e4fbb 100644
--- a/.vscode/metacoq.code-workspace
+++ b/.vscode/metacoq.code-workspace
@@ -6,6 +6,7 @@
],
"settings": {
"coqtop.args": [
+ "-I", "template-coq",
// "-bt", get backtraces from Coq on errors
"-I", "template-coq/build",
"-R", "template-coq/theories", "MetaCoq.Template",
diff --git a/README.md b/README.md
index 427883bda..99e58d56f 100644
--- a/README.md
+++ b/README.md
@@ -170,9 +170,18 @@ Examples of translations built on top of this:
- An example *extracted* Coq plugin built on the extractable Template Monad, which can be used to
derive lenses associated to a record type is in [test-suite/plugin-demo](https://github.com/MetaCoq/metacoq/tree/coq-8.16/test-suite/plugin-demo). The plugin runs in OCaml and is a template for writing extracted plugins.
+- An example ``constructor`` tactic written using the Template Monad is in [examples/constructor_tac.v](https://github.com/MetaCoq/metacoq/tree/coq-8.16/examples/constructor_tac.v),
+ and a more elaborate verified tautology checker is in [examples/tauto.v](https://github.com/MetaCoq/metacoq/tree/coq-8.16/examples/tauto.v).
+
- The test-suite files [test-suite/erasure_test.v](https://github.com/MetaCoq/metacoq/tree/coq-8.16/test-suite/erasure_test.v)
and [test-suite/safechecker_test.v](https://github.com/MetaCoq/metacoq/tree/coq-8.16/test-suite/safechecker_test.v) show example
- uses (and current limitations of) the verified checker and erasure.
+ uses (and current limitations of) the extracted verified checker and erasure.
+
+- The [test-suite/self_erasure.v](https://github.com/MetaCoq/metacoq/tree/coq-8.16/test-suite/self_erasure.v) file checks that erasure
+ works on the verified typechecking and erasure programs themselves.
+
+- The test-suite file [test-suite/erasure_live_test.v](https://github.com/MetaCoq/metacoq/tree/coq-8.16/test-suite/erasure_live_test.v)
+ shows uses of the verified erasure running *inside* Coq.
## Papers
diff --git a/test-suite/self_erasure.v b/test-suite/self_erasure.v
index 9f0718618..3d37be9e7 100644
--- a/test-suite/self_erasure.v
+++ b/test-suite/self_erasure.v
@@ -1,7 +1,5 @@
From MetaCoq.Erasure Require Import Loader Erasure.
From MetaCoq.SafeChecker Require Import PCUICSafeChecker.
Set MetaCoq Timing.
-(* <1sec *)
MetaCoq Fast Erase @erase_and_print_template_program.
-(* 2sec *)
MetaCoq Fast Erase @typecheck_program.
From 0102668f2a28e380e71976118ed533eacab42006 Mon Sep 17 00:00:00 2001
From: Matthieu Sozeau
Date: Fri, 1 Jul 2022 11:06:22 +0200
Subject: [PATCH 14/43] Update DOC.md and dependency graph
---
DOC.md | 33 +-
README.md | 35 +-
dependency-graph/depgraph-2022-07-01.dot | 540 ++++
dependency-graph/depgraph-2022-07-01.png | Bin 0 -> 2160294 bytes
dependency-graph/depgraph-2022-07-01.svg | 3241 ++++++++++++++++++++++
dependency-graph/generate-depgraph.sh | 2 +-
6 files changed, 3815 insertions(+), 36 deletions(-)
create mode 100644 dependency-graph/depgraph-2022-07-01.dot
create mode 100644 dependency-graph/depgraph-2022-07-01.png
create mode 100644 dependency-graph/depgraph-2022-07-01.svg
diff --git a/DOC.md b/DOC.md
index fc525a99f..2fa24e5a3 100644
--- a/DOC.md
+++ b/DOC.md
@@ -2,7 +2,7 @@
## Branches and compatibility
-**tl;dr** You should do your PRs against [coq-8.11](https://github.com/MetaCoq/metacoq/tree/coq-8.11).
+**tl;dr** You should do your PRs against [coq-8.16](https://github.com/MetaCoq/metacoq/tree/coq-8.16).
Coq's kernel API is not stable yet, and changes there are reflected in MetaCoq's reified structures,
@@ -11,9 +11,8 @@ so we do not ensure any compatibility from version to version. There is one bran
The *main branch* or *current branch* is the one which appers when you go on
[https://github.com/MetaCoq/metacoq](https://github.com/MetaCoq/metacoq).
Currently (unless you are reading the README of an outdated branch),
-it is the [coq-8.11](https://github.com/MetaCoq/metacoq/tree/coq-8.11).
+it is the [coq-8.16](https://github.com/MetaCoq/metacoq/tree/coq-8.16).
You should use it both for usage of MetaCoq and development of MetaCoq.
-We should move soon to [coq-8.13](https://github.com/MetaCoq/metacoq/tree/coq-8.12).
The [master](https://github.com/MetaCoq/metacoq/tree/master) branch is following Coq's master
branch and gets regular updates from the the main development branch which follows the latest
@@ -23,29 +22,25 @@ stable release of Coq.
+The branches [coq-8.14](https://github.com/MetaCoq/metacoq/tree/coq-8.14), [coq-8.15](https://github.com/MetaCoq/metacoq/tree/coq-8.15)
+and [coq-8.16](https://github.com/MetaCoq/metacoq/tree/coq-8.16) are being kept in sync.
The branches [coq-8.6](https://github.com/MetaCoq/metacoq/tree/coq-8.6),
[coq-8.7](https://github.com/MetaCoq/metacoq/tree/coq-8.7), [coq-8.8](https://github.com/MetaCoq/metacoq/tree/coq-8.8)
-and [coq-8.9](https://github.com/MetaCoq/metacoq/tree/coq-8.9), and [coq-8.10](https://github.com/MetaCoq/metacoq/tree/coq-8.10) are frozen.
-
+and [coq-8.9](https://github.com/MetaCoq/metacoq/tree/coq-8.9), [coq-8.10](https://github.com/MetaCoq/metacoq/tree/coq-8.10),
+[coq-8.11](https://github.com/MetaCoq/metacoq/tree/coq-8.11), [coq-8.12](https://github.com/MetaCoq/metacoq/tree/coq-8.12)
+and [coq-8.13](https://github.com/MetaCoq/metacoq/tree/coq-8.13) are frozen.
## Program and Equations
-MetaCoq relies on `Program` and `Equations` plugins.
-
-**Important**: We keep the `template-coq` folder not relying on Equations so that
-it compiles without external dependency.
-That's why first lemmas involving Equations are in `PCUICUtils.v`.
-
-Besides, try to avoid `Program`. It inserts some JMeq and UIP axioms silently. You can
-use `Equations` to do some dependent induction (`dependent induction`,
+MetaCoq relies on `Program` and `Equations` plugins, however try to avoid `Program` as it
+inserts some JMeq and UIP axioms silently, whereas we try to keep the development axiom-free.
+You can use `Equations` to do some dependent induction (`dependent induction`,
`dependent destruction`, `depelim`). You may need to add:
```
Require Import Equations.Prop.DepElim.
```
-
-
## ident vs. qualid. vs kername
MetaCoq uses three types convertible to `string` which have a different intended meaning:
@@ -56,7 +51,7 @@ MetaCoq uses three types convertible to `string` which have a different intended
- `qualid` is the type of partially qualified names.
E.g. `Datatypes.nat`
-- `kername` is the type of fully qualified names.
+- `kername` is a structured type of fully qualified names.
E.g. `Coq.Init.Datatypes.nat`
Quoting always produce fully qualified names. On the converse, unquoting allow to
@@ -100,10 +95,10 @@ a fresh level when `MetaCoq Strict Unquote Universe Mode` is off.
## Dependency graph between files
-Generated on 2020/09/24, sources [there](https://github.com/MetaCoq/metacoq/tree/coq-8.11/dependency-graph).
+Generated on 2022/07/01, sources [there](https://github.com/MetaCoq/metacoq/tree/coq-8.16/dependency-graph).
-
@@ -115,6 +110,6 @@ The file `README.md` in https://github.com/MetaCoq/metacoq.github.io is supposed
`README.md` in [https://github.com/MetaCoq/metacoq/](https://github.com/MetaCoq/metacoq/).
That's why we can't use relative links and have to use absolute ones.
-E.g. [INSTALL.md](https://github.com/MetaCoq/metacoq/tree/coq-8.11/INSTALL.md) and not [INSTALL.md](INSTALL.md).
+E.g. [INSTALL.md](https://github.com/MetaCoq/metacoq/tree/coq-8.16/INSTALL.md) and not [INSTALL.md](INSTALL.md).
Thus, when switching to a new default branch, we have to search and replace the old branch with the new one.
diff --git a/README.md b/README.md
index 99e58d56f..b8f9274fc 100644
--- a/README.md
+++ b/README.md
@@ -4,7 +4,7 @@
-[![Build status](https://github.com/MetaCoq/metacoq/actions/workflows/build.yml/badge.svg?branch=coq-8.16)](https://github.com/MetaCoq/metacoq/actions) [![MetaCoq Chat](https://img.shields.io/badge/zulip-join_chat-brightgreen.svg)](https://coq.zulipchat.com)
+[![Build status](https://github.com/MetaCoq/metacoq/actions/workflows/build.yml/badge.svg?branch=coq-8.15)](https://github.com/MetaCoq/metacoq/actions) [![MetaCoq Chat](https://img.shields.io/badge/zulip-join_chat-brightgreen.svg)](https://coq.zulipchat.com)
[![Open in Visual Studio Code](https://open.vscode.dev/badges/open-in-vscode.svg)](https://open.vscode.dev/metacoq/metacoq)
MetaCoq is a project formalizing Coq in Coq and providing tools for
@@ -50,8 +50,11 @@ See [DOC.md](https://github.com/MetaCoq/metacoq/tree/coq-8.13/DOC.md)
At the center of this project is the Template-Coq quoting library for
Coq. The project currently has a single repository extending
Template-Coq with additional features. Each extension is in a dedicated folder.
+The [dependency graph](https://raw.githubusercontent.com/MetaCoq/metacoq.github.io/master/assets/depgraph-2022-07-01.png)
+might be useful to navigate the project.
+Statistics: ~150kLoC of Coq, ~30kLoC of OCaml.
-### [Template-Coq](https://github.com/MetaCoq/metacoq/tree/coq-8.13/template-coq)
+### [Template-Coq](https://github.com/MetaCoq/metacoq/tree/coq-8.15/template-coq/theories)
Template-Coq is a quoting library for [Coq](http://coq.inria.fr). It
takes `Coq` terms and constructs a representation of their syntax tree as
@@ -77,7 +80,7 @@ In addition to this representation of terms, Template Coq includes:
- A formalisation of the typing rules reflecting the ones of Coq, covering all of Coq
except eta-expansion and template polymorphism.
-### [PCUIC](https://github.com/MetaCoq/metacoq/tree/coq-8.16/pcuic)
+### [PCUIC](https://github.com/MetaCoq/metacoq/tree/coq-8.15/pcuic/theories)
PCUIC, the Polymorphic Cumulative Calculus of Inductive Constructions is
a cleaned up version of the term language of Coq and its associated
@@ -110,10 +113,10 @@ calculus has proofs of standard metatheoretical results:
- Weak call-by-value standardization: Normal forms of terms of first-order inductive type
can be found via weak call-by-value evaluation.
-See the PCUIC [README](https://github.com/MetaCoq/metacoq/tree/coq-8.16/pcuic/theories/README.md) for
+See the PCUIC [README](https://github.com/MetaCoq/metacoq/tree/coq-8.15/pcuic/theories/README.md) for
a detailed view of the development.
-### [Safe Checker](https://github.com/MetaCoq/metacoq/tree/coq-8.16/safechecker)
+### [Safe Checker](https://github.com/MetaCoq/metacoq/tree/coq-8.15/safechecker/theories)
Implementation of a fuel-free and verified reduction machine, conversion
checker and type checker for PCUIC. This relies on a postulate of
@@ -133,10 +136,10 @@ type-checker, one can use:
This also includes a verified, efficient re-typing procedure (useful in tactics) in
`MetaCoq.SafeChecker.PCUICSafeRetyping`.
-See the SafeChecker [README](https://github.com/MetaCoq/metacoq/tree/coq-8.16/safechecker/theories/README.md) for
+See the SafeChecker [README](https://github.com/MetaCoq/metacoq/tree/coq-8.15/safechecker/theories/README.md) for
a detailed view of the development.
-### [Erasure](https://github.com/MetaCoq/metacoq/tree/coq-8.16/erasure)
+### [Erasure](https://github.com/MetaCoq/metacoq/tree/coq-8.15/erasure/theories)
An erasure procedure to untyped lambda-calculus accomplishing the
same as the type and proof erasure phase of the Extraction plugin of Coq.
@@ -150,7 +153,7 @@ The erasure pipeline includes verified optimizations to remove lets in construct
remove cases on propositional terms, switch to an unguarded fixpoint reduction rule and
transform the higher-order constructor applications to first-order blocks for easier
translation to usual programming languages. See the erasure
-[README](https://github.com/MetaCoq/metacoq/tree/coq-8.16/erasure/theories/README.md) for
+[README](https://github.com/MetaCoq/metacoq/tree/coq-8.15/erasure/theories/README.md) for
a detailed view of the development.
### [Translations](https://github.com/MetaCoq/metacoq/tree/coq-8.13/translations)
@@ -159,7 +162,7 @@ Examples of translations built on top of this:
- a parametricity plugin in [translations/param_original.v](https://github.com/MetaCoq/metacoq/tree/coq-8.13/translations/param_original.v)
-- a plugin to negate functional extensionality in [translations/times_bool_fun.v](https://github.com/MetaCoq/metacoq/tree/coq-8.16/translations/times_bool_fun.v)
+- a plugin to negate functional extensionality in [translations/times_bool_fun.v](https://github.com/MetaCoq/metacoq/tree/coq-8.15/translations/times_bool_fun.v)
### Examples
@@ -168,19 +171,19 @@ Examples of translations built on top of this:
add a constructor to any inductive type is in [examples/add_constructor.v](https://github.com/MetaCoq/metacoq/tree/coq-8.13/examples/add_constructor.v)
- An example *extracted* Coq plugin built on the extractable Template Monad, which can be used to
- derive lenses associated to a record type is in [test-suite/plugin-demo](https://github.com/MetaCoq/metacoq/tree/coq-8.16/test-suite/plugin-demo). The plugin runs in OCaml and is a template for writing extracted plugins.
+ derive lenses associated to a record type is in [test-suite/plugin-demo](https://github.com/MetaCoq/metacoq/tree/coq-8.15/test-suite/plugin-demo). The plugin runs in OCaml and is a template for writing extracted plugins.
-- An example ``constructor`` tactic written using the Template Monad is in [examples/constructor_tac.v](https://github.com/MetaCoq/metacoq/tree/coq-8.16/examples/constructor_tac.v),
- and a more elaborate verified tautology checker is in [examples/tauto.v](https://github.com/MetaCoq/metacoq/tree/coq-8.16/examples/tauto.v).
+- An example ``constructor`` tactic written using the Template Monad is in [examples/constructor_tac.v](https://github.com/MetaCoq/metacoq/tree/coq-8.15/examples/constructor_tac.v),
+ and a more elaborate verified tautology checker is in [examples/tauto.v](https://github.com/MetaCoq/metacoq/tree/coq-8.15/examples/tauto.v).
-- The test-suite files [test-suite/erasure_test.v](https://github.com/MetaCoq/metacoq/tree/coq-8.16/test-suite/erasure_test.v)
- and [test-suite/safechecker_test.v](https://github.com/MetaCoq/metacoq/tree/coq-8.16/test-suite/safechecker_test.v) show example
+- The test-suite files [test-suite/erasure_test.v](https://github.com/MetaCoq/metacoq/tree/coq-8.15/test-suite/erasure_test.v)
+ and [test-suite/safechecker_test.v](https://github.com/MetaCoq/metacoq/tree/coq-8.15/test-suite/safechecker_test.v) show example
uses (and current limitations of) the extracted verified checker and erasure.
-- The [test-suite/self_erasure.v](https://github.com/MetaCoq/metacoq/tree/coq-8.16/test-suite/self_erasure.v) file checks that erasure
+- The [test-suite/self_erasure.v](https://github.com/MetaCoq/metacoq/tree/coq-8.15/test-suite/self_erasure.v) file checks that erasure
works on the verified typechecking and erasure programs themselves.
-- The test-suite file [test-suite/erasure_live_test.v](https://github.com/MetaCoq/metacoq/tree/coq-8.16/test-suite/erasure_live_test.v)
+- The test-suite file [test-suite/erasure_live_test.v](https://github.com/MetaCoq/metacoq/tree/coq-8.15/test-suite/erasure_live_test.v)
shows uses of the verified erasure running *inside* Coq.
## Papers
diff --git a/dependency-graph/depgraph-2022-07-01.dot b/dependency-graph/depgraph-2022-07-01.dot
new file mode 100644
index 000000000..29de49597
--- /dev/null
+++ b/dependency-graph/depgraph-2022-07-01.dot
@@ -0,0 +1,540 @@
+digraph dependencies {
+node[style=filled]
+"safechecker/Extraction"[label="Extraction", color=paleturquoise1]
+"safechecker/PCUICConsistency"[label="PCUICConsistency", color=paleturquoise1]
+"safechecker/PCUICRetypingEnvIrrelevance"[label="PCUICRetypingEnvIrrelevance", color=paleturquoise1]
+"safechecker/PCUICSafeRetyping"[label="PCUICSafeRetyping", color=paleturquoise1]
+"safechecker/SafeTemplateChecker"[label="SafeTemplateChecker", color=paleturquoise1]
+"safechecker/PCUICWfEnvImpl"[label="PCUICWfEnvImpl", color=paleturquoise1]
+"safechecker/PCUICSafeChecker"[label="PCUICSafeChecker", color=paleturquoise1]
+"safechecker/PCUICTypeChecker"[label="PCUICTypeChecker", color=paleturquoise1]
+"safechecker/PCUICWfReduction"[label="PCUICWfReduction", color=paleturquoise1]
+"safechecker/PCUICSafeConversion"[label="PCUICSafeConversion", color=paleturquoise1]
+"safechecker/PCUICSafeReduce"[label="PCUICSafeReduce", color=paleturquoise1]
+"safechecker/PCUICWfEnv"[label="PCUICWfEnv", color=paleturquoise1]
+"safechecker/PCUICErrors"[label="PCUICErrors", color=paleturquoise1]
+"safechecker/PCUICEqualityDec"[label="PCUICEqualityDec", color=paleturquoise1]
+"pcuic/Bidirectional/BDToPCUIC" -> "pcuic/Bidirectional/BDFromPCUIC"
+"pcuic/Bidirectional/BDTyping" -> "pcuic/Bidirectional/BDToPCUIC"
+"pcuic/PCUICSR" -> "pcuic/Bidirectional/BDToPCUIC"
+"pcuic/PCUICCumulativity" -> "pcuic/Bidirectional/BDTyping"
+"pcuic/PCUICTyping" -> "pcuic/Bidirectional/BDTyping"
+"pcuic/Bidirectional/BDFromPCUIC" -> "pcuic/Bidirectional/BDUnique"
+"pcuic/PCUICGlobalEnv" -> "pcuic/Conversion/PCUICClosedConv"
+"pcuic/PCUICReduction" -> "pcuic/Conversion/PCUICClosedConv"
+"pcuic/PCUICWeakeningEnv" -> "pcuic/Conversion/PCUICClosedConv"
+"pcuic/Conversion/PCUICUnivSubstitutionConv" -> "pcuic/Conversion/PCUICInstConv"
+"pcuic/Typing/PCUICWeakeningTyp" -> "pcuic/Conversion/PCUICInstConv"
+"pcuic/Conversion/PCUICRenameConv" -> "pcuic/Conversion/PCUICOnFreeVarsConv"
+"pcuic/Syntax/PCUICViews" -> "pcuic/Conversion/PCUICRenameConv"
+"pcuic/Typing/PCUICClosedTyp" -> "pcuic/Conversion/PCUICRenameConv"
+"pcuic/PCUICCumulativity" -> "pcuic/Conversion/PCUICUnivSubstitutionConv"
+"pcuic/PCUICGuardCondition" -> "pcuic/Conversion/PCUICUnivSubstitutionConv"
+"pcuic/PCUICWeakeningEnv" -> "pcuic/Conversion/PCUICUnivSubstitutionConv"
+"pcuic/Conversion/PCUICRenameConv" -> "pcuic/Conversion/PCUICWeakeningConv"
+"pcuic/PCUICCumulativity" -> "pcuic/Conversion/PCUICWeakeningEnvConv"
+"pcuic/PCUICCumulativitySpec" -> "pcuic/Conversion/PCUICWeakeningEnvConv"
+"pcuic/PCUICWeakeningEnv" -> "pcuic/Conversion/PCUICWeakeningEnvConv"
+"pcuic/PCUICInductiveInversion" -> "pcuic/PCUICAlpha"
+"pcuic/PCUICContexts" -> "pcuic/PCUICArities"
+"pcuic/PCUICInversion" -> "pcuic/PCUICArities"
+"pcuic/PCUICWfUniverses" -> "pcuic/PCUICArities"
+"pcuic/utils/PCUICPrimitive" -> "pcuic/PCUICAst"
+"pcuic/PCUICReduction" -> "pcuic/PCUICCSubst"
+"pcuic/PCUICTyping" -> "pcuic/PCUICCSubst"
+"pcuic/PCUICElimination" -> "pcuic/PCUICCanonicity"
+"pcuic/PCUICWcbvEval" -> "pcuic/PCUICCanonicity"
+"pcuic/PCUICEquality" -> "pcuic/PCUICCasesContexts"
+"pcuic/PCUICSigmaCalculus" -> "pcuic/PCUICCasesContexts"
+"pcuic/PCUICParallelReductionConfluence" -> "pcuic/PCUICConfluence"
+"pcuic/PCUICRedTypeIrrelevance" -> "pcuic/PCUICConfluence"
+"pcuic/PCUICWellScopedCumulativity" -> "pcuic/PCUICContextConversion"
+"pcuic/PCUICSubstitution" -> "pcuic/PCUICContextReduction"
+"pcuic/Syntax/PCUICLiftSubst" -> "pcuic/PCUICContextSubst"
+"pcuic/PCUICGeneration" -> "pcuic/PCUICContexts"
+"pcuic/PCUICSubstitution" -> "pcuic/PCUICContexts"
+"pcuic/Typing/PCUICUnivSubstitutionTyp" -> "pcuic/PCUICContexts"
+"pcuic/PCUICNormal" -> "pcuic/PCUICConvCumInversion"
+"pcuic/PCUICContextConversion" -> "pcuic/PCUICConversion"
+"pcuic/PCUICSafeLemmata" -> "pcuic/PCUICCumulProp"
+"pcuic/PCUICReduction" -> "pcuic/PCUICCumulativity"
+"pcuic/Syntax/PCUICOnFreeVars" -> "pcuic/PCUICCumulativitySpec"
+"pcuic/utils/PCUICOnOne" -> "pcuic/PCUICCumulativitySpec"
+"pcuic/PCUICCumulProp" -> "pcuic/PCUICElimination"
+"pcuic/Syntax/PCUICLiftSubst" -> "pcuic/PCUICEquality"
+"pcuic/Syntax/PCUICReflect" -> "pcuic/PCUICEquality"
+"pcuic/PCUICTyping" -> "pcuic/PCUICGeneration"
+"pcuic/PCUICTyping" -> "pcuic/PCUICGlobalEnv"
+"pcuic/PCUICReduction" -> "pcuic/PCUICGuardCondition"
+"pcuic/Syntax/PCUICInstDef" -> "pcuic/PCUICGuardCondition"
+"pcuic/Syntax/PCUICNamelessDef" -> "pcuic/PCUICGuardCondition"
+"pcuic/PCUICValidity" -> "pcuic/PCUICInductiveInversion"
+"pcuic/PCUICSpine" -> "pcuic/PCUICInductives"
+"pcuic/PCUICConversion" -> "pcuic/PCUICInversion"
+"pcuic/PCUICSR" -> "pcuic/PCUICNormal"
+"template-coq/UnivSubst" -> "pcuic/PCUICNormal"
+"pcuic/PCUICSubstitution" -> "pcuic/PCUICParallelReduction"
+"pcuic/Syntax/PCUICDepth" -> "pcuic/PCUICParallelReduction"
+"pcuic/PCUICParallelReduction" -> "pcuic/PCUICParallelReductionConfluence"
+"pcuic/PCUICCumulProp" -> "pcuic/PCUICPrincipality"
+"pcuic/PCUICGlobalEnv" -> "pcuic/PCUICProgram"
+"template-coq/EnvMap" -> "pcuic/PCUICProgram"
+"pcuic/PCUICContextReduction" -> "pcuic/PCUICRedTypeIrrelevance"
+"pcuic/Syntax/PCUICClosed" -> "pcuic/PCUICReduction"
+"pcuic/Syntax/PCUICPosition" -> "pcuic/PCUICReduction"
+"pcuic/Syntax/PCUICTactics" -> "pcuic/PCUICReduction"
+"pcuic/utils/PCUICOnOne" -> "pcuic/PCUICReduction"
+"pcuic/PCUICSafeLemmata" -> "pcuic/PCUICSN"
+"pcuic/PCUICAlpha" -> "pcuic/PCUICSR"
+"pcuic/PCUICNormal" -> "pcuic/PCUICSafeLemmata"
+"pcuic/Syntax/PCUICLiftSubst" -> "pcuic/PCUICSigmaCalculus"
+"pcuic/PCUICArities" -> "pcuic/PCUICSpine"
+"pcuic/PCUICCasesContexts" -> "pcuic/PCUICSpine"
+"pcuic/Typing/PCUICContextConversionTyp" -> "pcuic/PCUICSpine"
+"pcuic/Typing/PCUICInstTyp" -> "pcuic/PCUICSubstitution"
+"pcuic/PCUICCumulativitySpec" -> "pcuic/PCUICTyping"
+"pcuic/Syntax/PCUICPosition" -> "pcuic/PCUICTyping"
+"pcuic/utils/PCUICUtils" -> "pcuic/PCUICTyping"
+"pcuic/PCUICInductives" -> "pcuic/PCUICValidity"
+"pcuic/PCUICCSubst" -> "pcuic/PCUICWcbvEval"
+"pcuic/Typing/PCUICClosedTyp" -> "pcuic/PCUICWcbvEval"
+"pcuic/utils/PCUICAstUtils" -> "pcuic/PCUICWeakeningEnv"
+"template-coq/utils/LibHypsNaming" -> "pcuic/PCUICWeakeningEnv"
+"pcuic/PCUICConfluence" -> "pcuic/PCUICWellScopedCumulativity"
+"pcuic/PCUICGeneration" -> "pcuic/PCUICWfUniverses"
+"pcuic/PCUICSubstitution" -> "pcuic/PCUICWfUniverses"
+"pcuic/utils/PCUICAstUtils" -> "pcuic/Syntax/PCUICCases"
+"pcuic/PCUICSigmaCalculus" -> "pcuic/Syntax/PCUICClosed"
+"pcuic/Syntax/PCUICUnivSubst" -> "pcuic/Syntax/PCUICClosed"
+"pcuic/Syntax/PCUICInduction" -> "pcuic/Syntax/PCUICDepth"
+"pcuic/Syntax/PCUICCases" -> "pcuic/Syntax/PCUICInduction"
+"template-coq/utils/LibHypsNaming" -> "pcuic/Syntax/PCUICInduction"
+"pcuic/Syntax/PCUICRenameDef" -> "pcuic/Syntax/PCUICInstDef"
+"pcuic/Syntax/PCUICInduction" -> "pcuic/Syntax/PCUICLiftSubst"
+"pcuic/PCUICTyping" -> "pcuic/Syntax/PCUICNamelessDef"
+"pcuic/PCUICEquality" -> "pcuic/Syntax/PCUICOnFreeVars"
+"pcuic/Syntax/PCUICClosed" -> "pcuic/Syntax/PCUICOnFreeVars"
+"template-coq/utils/MCPred" -> "pcuic/Syntax/PCUICOnFreeVars"
+"pcuic/PCUICEquality" -> "pcuic/Syntax/PCUICPosition"
+"pcuic/Syntax/PCUICInduction" -> "pcuic/Syntax/PCUICReflect"
+"pcuic/PCUICTyping" -> "pcuic/Syntax/PCUICRenameDef"
+"pcuic/PCUICSigmaCalculus" -> "pcuic/Syntax/PCUICTactics"
+"pcuic/Syntax/PCUICInduction" -> "pcuic/Syntax/PCUICUnivSubst"
+"pcuic/Syntax/PCUICReflect" -> "pcuic/Syntax/PCUICViews"
+"pcuic/utils/PCUICOnOne" -> "pcuic/Syntax/PCUICViews"
+"pcuic/PCUICProgram" -> "pcuic/TemplateToPCUIC"
+"template-coq/TemplateProgram" -> "pcuic/TemplateToPCUIC"
+"pcuic/Conversion/PCUICClosedConv" -> "pcuic/Typing/PCUICClosedTyp"
+"pcuic/Typing/PCUICWeakeningEnvTyp" -> "pcuic/Typing/PCUICClosedTyp"
+"pcuic/PCUICConversion" -> "pcuic/Typing/PCUICContextConversionTyp"
+"pcuic/Conversion/PCUICInstConv" -> "pcuic/Typing/PCUICInstTyp"
+"pcuic/Conversion/PCUICOnFreeVarsConv" -> "pcuic/Typing/PCUICRenameTyp"
+"pcuic/Conversion/PCUICUnivSubstitutionConv" -> "pcuic/Typing/PCUICUnivSubstitutionTyp"
+"pcuic/Typing/PCUICWeakeningEnvTyp" -> "pcuic/Typing/PCUICUnivSubstitutionTyp"
+"pcuic/Conversion/PCUICWeakeningEnvConv" -> "pcuic/Typing/PCUICWeakeningEnvTyp"
+"pcuic/PCUICContextSubst" -> "pcuic/Typing/PCUICWeakeningEnvTyp"
+"pcuic/PCUICGlobalEnv" -> "pcuic/Typing/PCUICWeakeningEnvTyp"
+"pcuic/PCUICGuardCondition" -> "pcuic/Typing/PCUICWeakeningEnvTyp"
+"pcuic/Conversion/PCUICWeakeningConv" -> "pcuic/Typing/PCUICWeakeningTyp"
+"pcuic/Typing/PCUICRenameTyp" -> "pcuic/Typing/PCUICWeakeningTyp"
+"pcuic/utils/PCUICSize" -> "pcuic/utils/PCUICAstUtils"
+"template-coq/common/uGraph" -> "pcuic/utils/PCUICAstUtils"
+"pcuic/PCUICAst" -> "pcuic/utils/PCUICOnOne"
+"pcuic/utils/PCUICAstUtils" -> "pcuic/utils/PCUICPretty"
+"template-coq/EnvironmentTyping" -> "pcuic/utils/PCUICPrimitive"
+"template-coq/Reflect" -> "pcuic/utils/PCUICPrimitive"
+"pcuic/PCUICAst" -> "pcuic/utils/PCUICSize"
+"template-coq/config" -> "pcuic/utils/PCUICUtils"
+"template-coq/utils" -> "pcuic/utils/PCUICUtils"
+"template-coq/EnvironmentTyping" -> "template-coq/Ast"
+"template-coq/Ast" -> "template-coq/AstUtils"
+"template-coq/Kernames" -> "template-coq/BasicAst"
+"template-coq/Reflect" -> "template-coq/EnvMap"
+"template-coq/common/uGraph" -> "template-coq/EnvMap"
+"template-coq/utils/canonicaltries/CanonicalTries" -> "template-coq/EnvMap"
+"template-coq/Universes" -> "template-coq/Environment"
+"template-coq/Environment" -> "template-coq/EnvironmentTyping"
+"template-coq/Typing" -> "template-coq/EtaExpand"
+"template-coq/common/uGraph" -> "template-coq/EtaExpand"
+"template-coq/AstUtils" -> "template-coq/Induction"
+"template-coq/utils" -> "template-coq/Kernames"
+"template-coq/WfAst" -> "template-coq/LiftSubst"
+"template-coq/Universes" -> "template-coq/Reflect"
+"template-coq/Induction" -> "template-coq/ReflectAst"
+"template-coq/Reflect" -> "template-coq/ReflectAst"
+"template-coq/EtaExpand" -> "template-coq/TemplateProgram"
+"template-coq/Transform" -> "template-coq/TemplateProgram"
+"template-coq/WcbvEval" -> "template-coq/TemplateProgram"
+"template-coq/Induction" -> "template-coq/TermEquality"
+"template-coq/Reflect" -> "template-coq/TermEquality"
+"template-coq/utils" -> "template-coq/Transform"
+"template-coq/LiftSubst" -> "template-coq/Typing"
+"template-coq/ReflectAst" -> "template-coq/Typing"
+"template-coq/TermEquality" -> "template-coq/Typing"
+"template-coq/Typing" -> "template-coq/TypingWf"
+"template-coq/Induction" -> "template-coq/UnivSubst"
+"template-coq/BasicAst" -> "template-coq/Universes"
+"template-coq/config" -> "template-coq/Universes"
+"template-coq/TypingWf" -> "template-coq/WcbvEval"
+"template-coq/UnivSubst" -> "template-coq/WfAst"
+"template-coq/Universes" -> "template-coq/common/uGraph"
+"template-coq/utils/wGraph" -> "template-coq/common/uGraph"
+"template-coq/utils/All_Forall" -> "template-coq/monad_utils"
+"template-coq/monad_utils" -> "template-coq/utils"
+"template-coq/utils/MCUtils" -> "template-coq/utils"
+"template-coq/utils/MCOption" -> "template-coq/utils/All_Forall"
+"template-coq/utils/MCSquash" -> "template-coq/utils/All_Forall"
+"template-coq/utils/ByteCompare" -> "template-coq/utils/ByteCompareSpec"
+"template-coq/utils/MCCompare" -> "template-coq/utils/ByteCompareSpec"
+"template-coq/utils/ReflectEq" -> "template-coq/utils/ByteCompareSpec"
+"template-coq/utils/MCPrelude" -> "template-coq/utils/MCList"
+"template-coq/utils/MCRelations" -> "template-coq/utils/MCList"
+"template-coq/utils/ReflectEq" -> "template-coq/utils/MCList"
+"template-coq/utils/MCList" -> "template-coq/utils/MCOption"
+"template-coq/utils/MCProd" -> "template-coq/utils/MCOption"
+"template-coq/utils/MCReflect" -> "template-coq/utils/MCOption"
+"template-coq/utils/MCOption" -> "template-coq/utils/MCPred"
+"template-coq/utils/MCPrelude" -> "template-coq/utils/MCReflect"
+"template-coq/utils/bytestring" -> "template-coq/utils/MCString"
+"template-coq/utils/All_Forall" -> "template-coq/utils/MCUtils"
+"template-coq/utils/MCArith" -> "template-coq/utils/MCUtils"
+"template-coq/utils/MCEquality" -> "template-coq/utils/MCUtils"
+"template-coq/utils/MCString" -> "template-coq/utils/MCUtils"
+"template-coq/utils/ByteCompareSpec" -> "template-coq/utils/bytestring"
+"template-coq/utils/canonicaltries/String2pos" -> "template-coq/utils/canonicaltries/CanonicalTries"
+"template-coq/utils/MCUtils" -> "template-coq/utils/wGraph"
+"template-coq/utils/MC_ExtrOCamlZPosInt" -> "safechecker/Extraction"
+"safechecker/SafeTemplateChecker" -> "safechecker/Extraction"
+"safechecker/PCUICSafeReduce" -> "safechecker/PCUICConsistency"
+"safechecker/PCUICWfEnvImpl" -> "safechecker/PCUICConsistency"
+"pcuic/PCUICWfUniverses" -> "safechecker/PCUICEqualityDec"
+"pcuic/utils/PCUICPretty" -> "safechecker/PCUICErrors"
+"safechecker/PCUICSafeRetyping" -> "safechecker/PCUICRetypingEnvIrrelevance"
+"safechecker/PCUICTypeChecker" -> "safechecker/PCUICSafeChecker"
+"pcuic/PCUICConvCumInversion" -> "safechecker/PCUICSafeConversion"
+"pcuic/PCUICPrincipality" -> "safechecker/PCUICSafeConversion"
+"safechecker/PCUICEqualityDec" -> "safechecker/PCUICSafeConversion"
+"safechecker/PCUICSafeReduce" -> "safechecker/PCUICSafeConversion"
+"pcuic/PCUICCanonicity" -> "safechecker/PCUICSafeReduce"
+"safechecker/PCUICErrors" -> "safechecker/PCUICSafeReduce"
+"safechecker/PCUICWfReduction" -> "safechecker/PCUICSafeReduce"
+"pcuic/Bidirectional/BDUnique" -> "safechecker/PCUICSafeRetyping"
+"pcuic/PCUICConvCumInversion" -> "safechecker/PCUICSafeRetyping"
+"safechecker/PCUICSafeReduce" -> "safechecker/PCUICSafeRetyping"
+"pcuic/Bidirectional/BDUnique" -> "safechecker/PCUICTypeChecker"
+"safechecker/PCUICSafeConversion" -> "safechecker/PCUICTypeChecker"
+"pcuic/PCUICSafeLemmata" -> "safechecker/PCUICWfEnv"
+"template-coq/EnvMap" -> "safechecker/PCUICWfEnv"
+"safechecker/PCUICEqualityDec" -> "safechecker/PCUICWfEnvImpl"
+"safechecker/PCUICWfEnv" -> "safechecker/PCUICWfEnvImpl"
+"pcuic/PCUICSN" -> "safechecker/PCUICWfReduction"
+"pcuic/utils/PCUICPretty" -> "safechecker/PCUICWfReduction"
+"safechecker/PCUICWfEnv" -> "safechecker/PCUICWfReduction"
+"pcuic/TemplateToPCUIC" -> "safechecker/SafeTemplateChecker"
+"safechecker/PCUICSafeChecker" -> "safechecker/SafeTemplateChecker"
+"safechecker/PCUICWfEnvImpl" -> "safechecker/SafeTemplateChecker"
+"template-coq/Extraction"[label="Extraction", color=aquamarine]
+"template-coq/Constants"[label="Constants", color=aquamarine]
+"template-coq/monad_utils"[label="monad_utils", color=aquamarine]
+"template-coq/TemplateMonad/Extractable"[label="Extractable", color=aquamarine]
+"template-coq/TemplateMonad/Core"[label="Core", color=aquamarine]
+"template-coq/TemplateMonad/Common"[label="Common", color=aquamarine]
+"template-coq/TemplateMonad"[label="TemplateMonad", color=aquamarine]
+"template-coq/TemplateProgram"[label="TemplateProgram", color=aquamarine]
+"template-coq/EtaExpand"[label="EtaExpand", color=aquamarine]
+"template-coq/Checker"[label="Checker", color=aquamarine]
+"template-coq/WcbvEval"[label="WcbvEval", color=aquamarine]
+"template-coq/Normal"[label="Normal", color=aquamarine]
+"template-coq/TypingWf"[label="TypingWf", color=aquamarine]
+"template-coq/Reduction"[label="Reduction", color=aquamarine]
+"template-coq/Typing"[label="Typing", color=aquamarine]
+"template-coq/TermEquality"[label="TermEquality", color=aquamarine]
+"template-coq/Pretty"[label="Pretty", color=aquamarine]
+"template-coq/UnivSubst"[label="UnivSubst", color=aquamarine]
+"template-coq/LiftSubst"[label="LiftSubst", color=aquamarine]
+"template-coq/WfAst"[label="WfAst", color=aquamarine]
+"template-coq/EnvironmentTyping"[label="EnvironmentTyping", color=aquamarine]
+"template-coq/Induction"[label="Induction", color=aquamarine]
+"template-coq/EnvMap"[label="EnvMap", color=aquamarine]
+"template-coq/ReflectAst"[label="ReflectAst", color=aquamarine]
+"template-coq/Reflect"[label="Reflect", color=aquamarine]
+"template-coq/AstUtils"[label="AstUtils", color=aquamarine]
+"template-coq/Ast"[label="Ast", color=aquamarine]
+"template-coq/Environment"[label="Environment", color=aquamarine]
+"template-coq/BasicAst"[label="BasicAst", color=aquamarine]
+"template-coq/Universes"[label="Universes", color=aquamarine]
+"template-coq/Kernames"[label="Kernames", color=aquamarine]
+"template-coq/config"[label="config", color=aquamarine]
+"template-coq/utils"[label="utils", color=aquamarine]
+"template-coq/Transform"[label="Transform", color=aquamarine]
+"template-coq/common/uGraph"[label="uGraph", color=aquamarine]
+"template-coq/utils/ReflectEq"[label="ReflectEq", color=aquamarine]
+"template-coq/utils/MC_ExtrOCamlZPosInt"[label="MC_ExtrOCamlZPosInt", color=aquamarine]
+"template-coq/utils/MCUtils"[label="MCUtils", color=aquamarine]
+"template-coq/utils/wGraph"[label="wGraph", color=aquamarine]
+"template-coq/utils/MCString"[label="MCString", color=aquamarine]
+"template-coq/utils/MCSquash"[label="MCSquash", color=aquamarine]
+"template-coq/utils/MCRelations"[label="MCRelations", color=aquamarine]
+"template-coq/utils/MCPred"[label="MCPred", color=aquamarine]
+"template-coq/utils/MCProd"[label="MCProd", color=aquamarine]
+"template-coq/utils/MCOption"[label="MCOption", color=aquamarine]
+"template-coq/utils/MCList"[label="MCList", color=aquamarine]
+"template-coq/utils/LibHypsNaming"[label="LibHypsNaming", color=aquamarine]
+"template-coq/utils/MCEquality"[label="MCEquality", color=aquamarine]
+"template-coq/utils/MCCompare"[label="MCCompare", color=aquamarine]
+"template-coq/utils/MCArith"[label="MCArith", color=aquamarine]
+"template-coq/utils/All_Forall"[label="All_Forall", color=aquamarine]
+"template-coq/utils/MCReflect"[label="MCReflect", color=aquamarine]
+"template-coq/utils/MCPrelude"[label="MCPrelude", color=aquamarine]
+"template-coq/utils/bytestring"[label="bytestring", color=aquamarine]
+"template-coq/utils/ByteCompareSpec"[label="ByteCompareSpec", color=aquamarine]
+"template-coq/utils/ByteCompare"[label="ByteCompare", color=aquamarine]
+"template-coq/utils/canonicaltries/CanonicalTries"[label="CanonicalTries", color=aquamarine]
+"template-coq/utils/canonicaltries/String2pos"[label="String2pos", color=aquamarine]
+"template-coq/Typing" -> "template-coq/Checker"
+"template-coq/common/uGraph" -> "template-coq/Checker"
+"template-coq/TemplateMonad" -> "template-coq/Constants"
+"template-coq/TemplateMonad/Extractable" -> "template-coq/Constants"
+"template-coq/common/uGraph" -> "template-coq/Constants"
+"template-coq/Pretty" -> "template-coq/Extraction"
+"template-coq/TemplateMonad/Extractable" -> "template-coq/Extraction"
+"template-coq/TemplateProgram" -> "template-coq/Extraction"
+"template-coq/utils/MC_ExtrOCamlZPosInt" -> "template-coq/Extraction"
+"template-coq/Typing" -> "template-coq/Normal"
+"template-coq/LiftSubst" -> "template-coq/Pretty"
+"template-coq/Typing" -> "template-coq/Reduction"
+"template-coq/TemplateMonad/Core" -> "template-coq/TemplateMonad"
+"template-coq/Ast" -> "template-coq/TemplateMonad/Common"
+"template-coq/AstUtils" -> "template-coq/TemplateMonad/Core"
+"template-coq/TemplateMonad/Common" -> "template-coq/TemplateMonad/Core"
+"template-coq/AstUtils" -> "template-coq/TemplateMonad/Extractable"
+"template-coq/TemplateMonad/Common" -> "template-coq/TemplateMonad/Extractable"
+"erasure/Erasure"[label="Erasure", color=tan]
+"erasure/EConstructorsAsBlocks"[label="EConstructorsAsBlocks", color=tan]
+"erasure/ETransform"[label="ETransform", color=tan]
+"erasure/EInlineProjections"[label="EInlineProjections", color=tan]
+"erasure/ERemoveParams"[label="ERemoveParams", color=tan]
+"erasure/EProgram"[label="EProgram", color=tan]
+"erasure/EEtaExpanded"[label="EEtaExpanded", color=tan]
+"erasure/EEtaExpandedFix"[label="EEtaExpandedFix", color=tan]
+"erasure/EOptimizePropDiscr"[label="EOptimizePropDiscr", color=tan]
+"erasure/EExtends"[label="EExtends", color=tan]
+"erasure/ErasureFunction"[label="ErasureFunction", color=tan]
+"erasure/ErasureCorrectness"[label="ErasureCorrectness", color=tan]
+"erasure/ErasureProperties"[label="ErasureProperties", color=tan]
+"erasure/EArities"[label="EArities", color=tan]
+"erasure/ESubstitution"[label="ESubstitution", color=tan]
+"erasure/Prelim"[label="Prelim", color=tan]
+"erasure/Extraction"[label="Extraction", color=tan]
+"erasure/EDeps"[label="EDeps", color=tan]
+"erasure/Extract"[label="Extract", color=tan]
+"erasure/EWcbvEvalEtaInd"[label="EWcbvEvalEtaInd", color=tan]
+"erasure/EWcbvEvalInd"[label="EWcbvEvalInd", color=tan]
+"erasure/EEnvMap"[label="EEnvMap", color=tan]
+"erasure/EWellformed"[label="EWellformed", color=tan]
+"erasure/EGlobalEnv"[label="EGlobalEnv", color=tan]
+"erasure/EWcbvEval"[label="EWcbvEval", color=tan]
+"erasure/ECSubst"[label="ECSubst", color=tan]
+"erasure/EPretty"[label="EPretty", color=tan]
+"erasure/ESpineView"[label="ESpineView", color=tan]
+"erasure/EReflect"[label="EReflect", color=tan]
+"erasure/ELiftSubst"[label="ELiftSubst", color=tan]
+"erasure/EInduction"[label="EInduction", color=tan]
+"erasure/EAstUtils"[label="EAstUtils", color=tan]
+"erasure/EAst"[label="EAst", color=tan]
+"pcuic/PCUICInductiveInversion" -> "pcuic/PCUICEtaExpand"
+"pcuic/TemplateToPCUIC" -> "pcuic/PCUICEtaExpand"
+"pcuic/PCUICProgram" -> "pcuic/PCUICExpandLets"
+"pcuic/PCUICCanonicity" -> "pcuic/PCUICExpandLetsCorrectness"
+"pcuic/PCUICEtaExpand" -> "pcuic/PCUICExpandLetsCorrectness"
+"pcuic/PCUICExpandLets" -> "pcuic/PCUICExpandLetsCorrectness"
+"pcuic/PCUICCanonicity" -> "pcuic/PCUICFirstorder"
+"pcuic/PCUICPrincipality" -> "pcuic/PCUICFirstorder"
+"pcuic/PCUICSN" -> "pcuic/PCUICFirstorder"
+"pcuic/PCUICFirstorder" -> "pcuic/PCUICProgress"
+"pcuic/PCUICExpandLetsCorrectness" -> "pcuic/PCUICTransform"
+"pcuic/TemplateToPCUICExpanded" -> "pcuic/PCUICTransform"
+"pcuic/TemplateToPCUICWcbvEval" -> "pcuic/PCUICTransform"
+"pcuic/PCUICInductiveInversion" -> "pcuic/TemplateToPCUICCorrectness"
+"pcuic/TemplateToPCUIC" -> "pcuic/TemplateToPCUICCorrectness"
+"pcuic/PCUICEtaExpand" -> "pcuic/TemplateToPCUICExpanded"
+"pcuic/TemplateToPCUICCorrectness" -> "pcuic/TemplateToPCUICExpanded"
+"pcuic/PCUICCanonicity" -> "pcuic/TemplateToPCUICWcbvEval"
+"pcuic/TemplateToPCUICCorrectness" -> "pcuic/TemplateToPCUICWcbvEval"
+"pcuic/PCUICCanonicity" -> "erasure/EArities"
+"pcuic/PCUICPrincipality" -> "erasure/EArities"
+"erasure/Extract" -> "erasure/EArities"
+"template-coq/Universes" -> "erasure/EAst"
+"erasure/EAst" -> "erasure/EAstUtils"
+"erasure/ELiftSubst" -> "erasure/ECSubst"
+"erasure/EGenericMapEnv" -> "erasure/EConstructorsAsBlocks"
+"erasure/EExtends" -> "erasure/EDeps"
+"erasure/ESubstitution" -> "erasure/EDeps"
+"template-coq/EnvMap" -> "erasure/EEnvMap"
+"erasure/EGlobalEnv" -> "erasure/EEnvMap"
+"erasure/EEtaExpandedFix" -> "erasure/EEtaExpanded"
+"erasure/EExtends" -> "erasure/EEtaExpandedFix"
+"erasure/EProgram" -> "erasure/EEtaExpandedFix"
+"erasure/ESpineView" -> "erasure/EEtaExpandedFix"
+"erasure/EWcbvEvalInd" -> "erasure/EEtaExpandedFix"
+"erasure/EWellformed" -> "erasure/EExtends"
+"erasure/EArities" -> "erasure/EGenericMapEnv"
+"erasure/EWcbvEvalEtaInd" -> "erasure/EGenericMapEnv"
+"erasure/ECSubst" -> "erasure/EGlobalEnv"
+"erasure/EReflect" -> "erasure/EGlobalEnv"
+"pcuic/utils/PCUICSize" -> "erasure/EInduction"
+"erasure/EAstUtils" -> "erasure/EInduction"
+"erasure/EArities" -> "erasure/EInlineProjections"
+"erasure/EEtaExpanded" -> "erasure/EInlineProjections"
+"erasure/EInduction" -> "erasure/ELiftSubst"
+"safechecker/PCUICWfEnvImpl" -> "erasure/EOptimizePropDiscr"
+"erasure/EDeps" -> "erasure/EOptimizePropDiscr"
+"erasure/EEtaExpanded" -> "erasure/EOptimizePropDiscr"
+"erasure/EGlobalEnv" -> "erasure/EPretty"
+"pcuic/PCUICProgram" -> "erasure/EProgram"
+"template-coq/Transform" -> "erasure/EProgram"
+"erasure/EEnvMap" -> "erasure/EProgram"
+"erasure/EPretty" -> "erasure/EProgram"
+"erasure/EWcbvEval" -> "erasure/EProgram"
+"erasure/EInduction" -> "erasure/EReflect"
+"erasure/EArities" -> "erasure/ERemoveParams"
+"erasure/EWcbvEvalEtaInd" -> "erasure/ERemoveParams"
+"erasure/EReflect" -> "erasure/ESpineView"
+"erasure/Prelim" -> "erasure/ESubstitution"
+"pcuic/PCUICTransform" -> "erasure/ETransform"
+"template-coq/Pretty" -> "erasure/ETransform"
+"erasure/EConstructorsAsBlocks" -> "erasure/ETransform"
+"erasure/EInlineProjections" -> "erasure/ETransform"
+"erasure/EOptimizePropDiscr" -> "erasure/ETransform"
+"erasure/ERemoveParams" -> "erasure/ETransform"
+"erasure/ErasureFunction" -> "erasure/ETransform"
+"pcuic/PCUICWcbvEval" -> "erasure/EWcbvEval"
+"erasure/EWellformed" -> "erasure/EWcbvEval"
+"erasure/EEtaExpanded" -> "erasure/EWcbvEvalEtaInd"
+"template-coq/EnvMap" -> "erasure/EWcbvEvalInd"
+"erasure/EWcbvEval" -> "erasure/EWcbvEvalInd"
+"pcuic/Syntax/PCUICTactics" -> "erasure/EWellformed"
+"erasure/EGlobalEnv" -> "erasure/EWellformed"
+"erasure/ETransform" -> "erasure/Erasure"
+"pcuic/PCUICEtaExpand" -> "erasure/ErasureCorrectness"
+"erasure/EEtaExpandedFix" -> "erasure/ErasureCorrectness"
+"erasure/ErasureProperties" -> "erasure/ErasureCorrectness"
+"pcuic/PCUICProgress" -> "erasure/ErasureFunction"
+"safechecker/PCUICRetypingEnvIrrelevance" -> "erasure/ErasureFunction"
+"erasure/ErasureCorrectness" -> "erasure/ErasureFunction"
+"erasure/EDeps" -> "erasure/ErasureProperties"
+"pcuic/PCUICElimination" -> "erasure/Extract"
+"pcuic/PCUICWcbvEval" -> "erasure/Extract"
+"erasure/EGlobalEnv" -> "erasure/Extract"
+"erasure/Erasure" -> "erasure/Extraction"
+"safechecker/PCUICErrors" -> "erasure/Prelim"
+"erasure/EArities" -> "erasure/Prelim"
+"erasure/EWcbvEval" -> "erasure/Prelim"
+"pcuic/PCUICWeakeningEnv"[label="PCUICWeakeningEnv", color=lemonchiffon1]
+"pcuic/Bidirectional/BDStrengthening"[label="BDStrengthening", color=lemonchiffon1]
+"pcuic/Bidirectional/BDUnique"[label="BDUnique", color=lemonchiffon1]
+"pcuic/Bidirectional/BDFromPCUIC"[label="BDFromPCUIC", color=lemonchiffon1]
+"pcuic/Bidirectional/BDToPCUIC"[label="BDToPCUIC", color=lemonchiffon1]
+"pcuic/Bidirectional/BDTyping"[label="BDTyping", color=lemonchiffon1]
+"pcuic/PCUICTransform"[label="PCUICTransform", color=lemonchiffon1]
+"pcuic/PCUICExpandLetsCorrectness"[label="PCUICExpandLetsCorrectness", color=lemonchiffon1]
+"pcuic/PCUICExpandLets"[label="PCUICExpandLets", color=lemonchiffon1]
+"pcuic/PCUICToTemplateCorrectness"[label="PCUICToTemplateCorrectness", color=lemonchiffon1]
+"pcuic/PCUICToTemplate"[label="PCUICToTemplate", color=lemonchiffon1]
+"pcuic/TemplateToPCUICExpanded"[label="TemplateToPCUICExpanded", color=lemonchiffon1]
+"pcuic/TemplateToPCUICWcbvEval"[label="TemplateToPCUICWcbvEval", color=lemonchiffon1]
+"pcuic/TemplateToPCUICCorrectness"[label="TemplateToPCUICCorrectness", color=lemonchiffon1]
+"pcuic/TemplateToPCUIC"[label="TemplateToPCUIC", color=lemonchiffon1]
+"pcuic/PCUICProgram"[label="PCUICProgram", color=lemonchiffon1]
+"pcuic/PCUICEtaExpand"[label="PCUICEtaExpand", color=lemonchiffon1]
+"pcuic/PCUICSafeLemmata"[label="PCUICSafeLemmata", color=lemonchiffon1]
+"pcuic/PCUICProgress"[label="PCUICProgress", color=lemonchiffon1]
+"pcuic/PCUICFirstorder"[label="PCUICFirstorder", color=lemonchiffon1]
+"pcuic/PCUICSigmaCalculus"[label="PCUICSigmaCalculus", color=lemonchiffon1]
+"pcuic/PCUICPrincipality"[label="PCUICPrincipality", color=lemonchiffon1]
+"pcuic/PCUICSN"[label="PCUICSN", color=lemonchiffon1]
+"pcuic/PCUICElimination"[label="PCUICElimination", color=lemonchiffon1]
+"pcuic/PCUICCumulProp"[label="PCUICCumulProp", color=lemonchiffon1]
+"pcuic/PCUICWcbvEval"[label="PCUICWcbvEval", color=lemonchiffon1]
+"pcuic/PCUICCSubst"[label="PCUICCSubst", color=lemonchiffon1]
+"pcuic/PCUICCanonicity"[label="PCUICCanonicity", color=lemonchiffon1]
+"pcuic/PCUICSR"[label="PCUICSR", color=lemonchiffon1]
+"pcuic/PCUICInductiveInversion"[label="PCUICInductiveInversion", color=lemonchiffon1]
+"pcuic/PCUICValidity"[label="PCUICValidity", color=lemonchiffon1]
+"pcuic/PCUICInductives"[label="PCUICInductives", color=lemonchiffon1]
+"pcuic/PCUICSpine"[label="PCUICSpine", color=lemonchiffon1]
+"pcuic/PCUICWfUniverses"[label="PCUICWfUniverses", color=lemonchiffon1]
+"pcuic/PCUICArities"[label="PCUICArities", color=lemonchiffon1]
+"pcuic/PCUICContexts"[label="PCUICContexts", color=lemonchiffon1]
+"pcuic/PCUICAlpha"[label="PCUICAlpha", color=lemonchiffon1]
+"pcuic/PCUICGeneration"[label="PCUICGeneration", color=lemonchiffon1]
+"pcuic/PCUICRedTypeIrrelevance"[label="PCUICRedTypeIrrelevance", color=lemonchiffon1]
+"pcuic/PCUICConvCumInversion"[label="PCUICConvCumInversion", color=lemonchiffon1]
+"pcuic/PCUICConversion"[label="PCUICConversion", color=lemonchiffon1]
+"pcuic/PCUICContextConversion"[label="PCUICContextConversion", color=lemonchiffon1]
+"pcuic/PCUICWellScopedCumulativity"[label="PCUICWellScopedCumulativity", color=lemonchiffon1]
+"pcuic/PCUICConfluence"[label="PCUICConfluence", color=lemonchiffon1]
+"pcuic/PCUICParallelReductionConfluence"[label="PCUICParallelReductionConfluence", color=lemonchiffon1]
+"pcuic/PCUICParallelReduction"[label="PCUICParallelReduction", color=lemonchiffon1]
+"pcuic/PCUICCumulativitySpec"[label="PCUICCumulativitySpec", color=lemonchiffon1]
+"pcuic/PCUICCumulativity"[label="PCUICCumulativity", color=lemonchiffon1]
+"pcuic/PCUICContextReduction"[label="PCUICContextReduction", color=lemonchiffon1]
+"pcuic/PCUICSubstitution"[label="PCUICSubstitution", color=lemonchiffon1]
+"pcuic/PCUICEquality"[label="PCUICEquality", color=lemonchiffon1]
+"pcuic/PCUICNormal"[label="PCUICNormal", color=lemonchiffon1]
+"pcuic/PCUICInversion"[label="PCUICInversion", color=lemonchiffon1]
+"pcuic/PCUICGlobalEnv"[label="PCUICGlobalEnv", color=lemonchiffon1]
+"pcuic/PCUICGuardCondition"[label="PCUICGuardCondition", color=lemonchiffon1]
+"pcuic/PCUICTyping"[label="PCUICTyping", color=lemonchiffon1]
+"pcuic/PCUICReduction"[label="PCUICReduction", color=lemonchiffon1]
+"pcuic/PCUICCasesContexts"[label="PCUICCasesContexts", color=lemonchiffon1]
+"pcuic/PCUICContextSubst"[label="PCUICContextSubst", color=lemonchiffon1]
+"pcuic/Typing/PCUICContextConversionTyp"[label="PCUICContextConversionTyp", color=lemonchiffon1]
+"pcuic/Typing/PCUICClosedTyp"[label="PCUICClosedTyp", color=lemonchiffon1]
+"pcuic/Typing/PCUICUnivSubstitutionTyp"[label="PCUICUnivSubstitutionTyp", color=lemonchiffon1]
+"pcuic/Typing/PCUICWeakeningTyp"[label="PCUICWeakeningTyp", color=lemonchiffon1]
+"pcuic/Typing/PCUICWeakeningEnvTyp"[label="PCUICWeakeningEnvTyp", color=lemonchiffon1]
+"pcuic/Typing/PCUICInstTyp"[label="PCUICInstTyp", color=lemonchiffon1]
+"pcuic/Typing/PCUICRenameTyp"[label="PCUICRenameTyp", color=lemonchiffon1]
+"pcuic/Typing/PCUICNamelessTyp"[label="PCUICNamelessTyp", color=lemonchiffon1]
+"pcuic/Conversion/PCUICOnFreeVarsConv"[label="PCUICOnFreeVarsConv", color=lemonchiffon1]
+"pcuic/Conversion/PCUICClosedConv"[label="PCUICClosedConv", color=lemonchiffon1]
+"pcuic/Conversion/PCUICWeakeningConv"[label="PCUICWeakeningConv", color=lemonchiffon1]
+"pcuic/Conversion/PCUICUnivSubstitutionConv"[label="PCUICUnivSubstitutionConv", color=lemonchiffon1]
+"pcuic/Conversion/PCUICWeakeningEnvConv"[label="PCUICWeakeningEnvConv", color=lemonchiffon1]
+"pcuic/Conversion/PCUICInstConv"[label="PCUICInstConv", color=lemonchiffon1]
+"pcuic/Conversion/PCUICRenameConv"[label="PCUICRenameConv", color=lemonchiffon1]
+"pcuic/Conversion/PCUICNamelessConv"[label="PCUICNamelessConv", color=lemonchiffon1]
+"pcuic/Syntax/PCUICViews"[label="PCUICViews", color=lemonchiffon1]
+"pcuic/Syntax/PCUICClosed"[label="PCUICClosed", color=lemonchiffon1]
+"pcuic/Syntax/PCUICUnivSubst"[label="PCUICUnivSubst", color=lemonchiffon1]
+"pcuic/Syntax/PCUICTactics"[label="PCUICTactics", color=lemonchiffon1]
+"pcuic/Syntax/PCUICLiftSubst"[label="PCUICLiftSubst", color=lemonchiffon1]
+"pcuic/Syntax/PCUICInstDef"[label="PCUICInstDef", color=lemonchiffon1]
+"pcuic/Syntax/PCUICRenameDef"[label="PCUICRenameDef", color=lemonchiffon1]
+"pcuic/Syntax/PCUICOnFreeVars"[label="PCUICOnFreeVars", color=lemonchiffon1]
+"pcuic/Syntax/PCUICNamelessDef"[label="PCUICNamelessDef", color=lemonchiffon1]
+"pcuic/Syntax/PCUICReflect"[label="PCUICReflect", color=lemonchiffon1]
+"pcuic/Syntax/PCUICPosition"[label="PCUICPosition", color=lemonchiffon1]
+"pcuic/Syntax/PCUICDepth"[label="PCUICDepth", color=lemonchiffon1]
+"pcuic/Syntax/PCUICInduction"[label="PCUICInduction", color=lemonchiffon1]
+"pcuic/Syntax/PCUICCases"[label="PCUICCases", color=lemonchiffon1]
+"pcuic/utils/PCUICPretty"[label="PCUICPretty", color=lemonchiffon1]
+"pcuic/utils/PCUICSize"[label="PCUICSize", color=lemonchiffon1]
+"pcuic/utils/PCUICUtils"[label="PCUICUtils", color=lemonchiffon1]
+"pcuic/utils/PCUICAstUtils"[label="PCUICAstUtils", color=lemonchiffon1]
+"pcuic/utils/PCUICPrimitive"[label="PCUICPrimitive", color=lemonchiffon1]
+"pcuic/utils/PCUICOnOne"[label="PCUICOnOne", color=lemonchiffon1]
+"pcuic/PCUICAst"[label="PCUICAst", color=lemonchiffon1]
+"pcuic/Bidirectional/BDFromPCUIC" -> "pcuic/Bidirectional/BDStrengthening"
+"pcuic/Conversion/PCUICUnivSubstitutionConv" -> "pcuic/Conversion/PCUICNamelessConv"
+"pcuic/Typing/PCUICClosedTyp" -> "pcuic/Conversion/PCUICNamelessConv"
+"template-coq/AstUtils" -> "pcuic/PCUICToTemplate"
+"pcuic/Syntax/PCUICCases" -> "pcuic/PCUICToTemplate"
+"template-coq/Reduction" -> "pcuic/PCUICToTemplateCorrectness"
+"template-coq/TypingWf" -> "pcuic/PCUICToTemplateCorrectness"
+"pcuic/PCUICSafeLemmata" -> "pcuic/PCUICToTemplateCorrectness"
+"pcuic/PCUICToTemplate" -> "pcuic/PCUICToTemplateCorrectness"
+"pcuic/Conversion/PCUICNamelessConv" -> "pcuic/Typing/PCUICNamelessTyp"
+"pcuic/PCUICConversion" -> "pcuic/Typing/PCUICNamelessTyp"
+}
diff --git a/dependency-graph/depgraph-2022-07-01.png b/dependency-graph/depgraph-2022-07-01.png
new file mode 100644
index 0000000000000000000000000000000000000000..fb92b658348a72ef7dd91db09a972195a30fbef0
GIT binary patch
literal 2160294
zcmaI7bzD^K_C8E^DcwDQfOMCXbW2KicXu~Kj7Wn@3rb0MgOt)pGaw+{4e#chE
z{CzzS5?AyOKg8)#h{gdKN~C{rgwo5FOx^He?0zw9AC7!>la7my#Zq9bG;5Z0Kc;{Z
zw622QIoq!{V-t*X&r1m_gjASAC<5KKEW&qKPrU8F)$Jz2ikPR25;m%S`+s7wjT
z86M~_ct9~#k4x0Mn>RxBa8Z4-pE9Vf1bGLARb|CWXg2S?FZg**DZ_b?8vfrjUg?G&kjj$DGj
zuwG59m)vQiwMby5SuJ_|-qp{|g4J9Sx>uKo2y3jrobss;w@!Xc`?Zu!olMy8qD9C3
z>zrt^aFa|+(?CC_zmcagc;02sCi>z?JuFS|c5o#ZB8`h?l*<40?&loH0AtD-QCku7nWI&D2zu8Q#F+mLv*a
zl*jBIU|!C}u|1#0sw+jeD?9Kh8L{$3w#&+0t}D{0ObW@#9uTGcvbSYe(eUMo_b`l4
z@I>+cR_!)oCTe9C!S_Sem^3uu-CjcUo>}&Dbm=pXpK+7<)I1CX$F$;E;{3!CFT&)e
z5SQhqgT>U-C~OaVZ6`=$hKRz$7+ZN>O+d~O884&>)GL$1!X(rOy5&p?B6&Jry1=FH
z7DbRZFy%*xd{d>&Af0I&JHQu>aEMEVOpR98y0V?m=1`Py#8CV7yKbajXvNBz(Y<_~@|v3IT6dQkq?(Y%smGYu!rC3iz}fkOptROp
zg=8OHPppC?m}R%BO^0YZVLQ`5n_XP-`=ONWeD_Pel0F3-T=dn}@;zZm8`hSwT|bVb
zT^*4qJ731q0$ZBuC*eP3L!*rS`@ZKb3dB`-w`0UJb50TWUbb>{5^*W2;H-D)WqCYZ
z0!IN?Cbuiz)}QxV1^GE&B=nUK*lDPnLO5%gmv)H|Xv8*4b%-P5O!ebCdU2G_h0T=^
z7z<<0xO;r9-8olY5#%)D)94#P2aSb^8=E?080%D=@-qw?j&Nd?Jju5_rYC+y
z)lSfe|FSkBlee|EEhVF1`#4}eYgsow>?n+Y(hDN~T!(FR<2%|jS|Tfg-7g(dH2IJH
z(b2NYMTZ~%-j1xWH)>VPYk3-RVoK`rc!WH)C}qsFj(5TIw?NOS~Ft7J1VXGWj8j
z%t&UkP!v}pl}L%Ndk7qJAz9?#8*u=dCK6!F)wenYBP2?Lg;`o#x`CFA4Rpb
zgHurqCbxPRAuisua^>{c7kwRK86>Ez6~=aEJmWvvM?({k@FW>U3L~iKxhuiGb!#95
zA~X+rsnbu_c;$*Q2+#VHcvr%rVHN9s^nfyFU%_J{(BSf^wSZ#uqI$bbdYo67aD{Mb
zU?YAOU=MVp=i$(E9}?Hv7bBuGVoWQ&E(qKuQlyTf9VjBwPSH*kuDzU<#m%xYCw06H
zuapKsC5Sh28=|Ccxlfo_JUhD6Pj0nyRIVV{)cAGU;Pshnn
z7fOFu@KxangRkQ-`u}rZuKbF|%p>Im;M&Q434?2y`t=y3X9hYMuX(u!i=1H$7RbBI
z30ccOhK!Z=DlihPBrUO#M7kQA&}1l5L#hhQ_BO?PKyWNpYzn2Fq;ZaAmVWZzzM?t1
zlKChypx?ltI8UuwiC~r&YDjn-o_}HIv(0-J)S}0^AUCvrUVN9hGR~f0Q`h{
zCaoK-=6rzkX`?NO7bM-aibnG^jo1pGq>&f*Gh<>u-A=al=_|7+G%Z?lg)npzLfzL=r2N4i_440(^=?A=q~cbSVM_%MnlDWMdU+h*@2D!=Rx}?Ams{y;B0Ei*cd^+9
z-LXIl8QC3`Gj2~oIMRFdZbv=fy8WM)=S`BS_UJfoPJuGLZIPibE9noFh#EBR?1+h&
z!*j-KoV|7yfwk`+aXnX;2s__|r6U}Lb|VAFS(
zPJbNl@j{nO@};Dl(s|00T#$OgGXi)Xmp)Nw)31x%wm%)T4TXllhe4QDbdImhSNde4
z6X%9x-b_fKz(a5x7`9~}p5HA+wzngd>hOp7gQ@FP5N+`X8D)@faA9IQ#*+$sR`6Zo_~gg7*`Y0iS%_)!IN64^_X))TC*kB7Mo@rdQScOfA$avU#5t%&AkA*}`QdP*WEjQJ5sp>M|{5#b57Mn6TDn$!CU
z+@P8q^WytUC4eT*T(vsD5$HtIb_@;<1<5l^`LJTapXJVRbMQzpsg?6@>48!dtZH&oa=`R4}R9bpGLh7Rs8>j*L>xPIxi3rqyDYY$&eh^euiy*mxm9}
zjI_xS&eY1%G8LSsJ=YD&G&PY+KL6BeOSYZejl=0DH&7HoHC7GTYrq%WrTuimrBa-P
zJE-zUPtT67BkP@-gd|Hett%r7kxuXgE{taMZJ9EVPdeJ(Cpv@i-IPy3c5A4*=G}WtMOU>#`Fm
zkPvdgy-k7R162mg6R4-YJ5hLGj}jj)qGHlqkP4QWm1r&UKC>af0MlhPV#vvpN3i>(
z$rEVggx4qpnRj-8J9{wzB9SwQ%c4@L$yxNCWGEbBA>wCmcxM{x0>u6aVvGkp@e7tJTft)Cj5!I1{|=^t?tnwjSp`roh7x#>{*KxNj31zXS$!bHV@s~AJ=
z(24JQp~M%38chK#MvyFr12(h%s65we12MsJ5Av7jNWBdW*=ym*IAQ569ggxPiFSC@
z#AjPxe%7U>c5akq6XHt^rmp?qj`x3d$IZ3|ugeyz(Ceoj&6ZEuXuOqeJ3TyW3M*w(Sv0%c!BbQ^d^
z3Hq{-XE^Vd&Q7R9t0N^%jGZ~J{6oZ1MJf_;9!!wmT7&&q$^wGm*;xqGPpSt_MR;F@ts@@T)@dCi`9@QOM{*~
znY`Y8i!x$v53&vBnUh-!zLV($FR0UzdX+8w!Qyeyt;+z}Qp0^cLTj6&SkZT$ES;O(
zw=As(awHdIOYho7PDIy74i*P9t(Jt#p{L`pw_5}Qv12>;5Y97y%a2Yh_iJ>68r1!=!Ie1wHEm9eul_*n0x7VDM$Dwl~VnD
zyNMzQ1L&Eud%hOtMNtkV9#F5GJwuB`L6r0+&6=z6XJre35|CWH@eHiw=i~rDx^6tX
z(hZ5-Cw9-iHz&!*Sz1Ps4i6*ZX4QgkLccMsD3*k`ttmJt$A|nvMKFrhDd=5rYB;&A
zO6oob>dYDGyCYOT+`xOJTj5bHlKS19LH7WQd(jD
z207W>FM%@?6({z@$DT>KDDW)Ed#`C86)}{h@kXsk-`_H--r#C1t?F0zgFoMSIfOBt
zllQzaxPK_0Auyq}Q0Vg4{DU;rxhG
z*SE6{VwWRfEe}KOYj*a(haPSX>M15xG9Uui&1uzZ2M>GGcW<+9Q@I$g4&LtSww+fd
zPT@+V1Cpw@A^rUa8%~81O9!~nsHALPMbdXer_8^r*FIV?WpX6z&KQt2?-gT|eQ82tbp%#hkE^Qyn^Nt|a&L#B=I@TUtDf%qkaO~FPU%tc=KG;9Wj>1qA{a`l#
znv1!Fp6p=z$|g?4KvIqJ_WS@ZPZ&3D~8ruaeq*fwZv>HOI3-
z6)-}9JXGTHb%sxRah_lAFBoDipX{!^ji=7rSAls_s?WBgLI1Q%1HpCgk)~BCF9x~P
zJhjoTaAh>ueK7pqS6Iy744tRUxlz=)$KxZJ|TSm8NeiP=#c
zuC#4wQLqSo!NJ0Gmj2U4M7ep_o`sjW(1~?_oO^VCa(Vhf^!H-kV*PUe&D+DuT7cIh
z_f-T$-Z-g7B8GV*VCVZbMZ(B$vQg6uah(Usd-j=psiGyH%E@0G)9~xRTao9C@?hO1
zzy|$Lq@vbX7%~k4vTJ*1tHMtMKpJj$^169&(aV*??
z*n3CM*!5mjk~lY9oSRbf`z@oOQ&QubS
z1wr||uSn}FFZcV2eEx7ah_-K!NMi{2zOae7x>>9*ZOQBn^2TdsjxcNYx`G|!fPOxi
zJ^X%yY!JoT8)L%3F1d=nFH(zH9(aujz8}?|yZue`Ld#+OlC&M%Ygy=`LZ7wCT4bUv
zK&vdAqE<}q)d6+%_ki_N@LH4g;y4Ln>zSDy-c)Ik_(4f!<_xRxQh?cW{(bA&J7K=O
zCI>$v*GW9ZiEvNq>aW?Tmhr5R2UnJhV06ul1$TJ4e_B^^^G(gG!7XLX`qB*Rxe^?&tc8|JFw;p0Wrne@2p}qH2K=o@3%U>H-2YzHl
zgLM%@Oh%0qaZ?iaJwM~`*N$>TBXiAR4%7i%kT@^!xTeGB*ngntWn1F7%Lt!kiQ#sg|SyghP>n_FPrED7^(CH6FmAfKV@+y*=&N-{YA^Ly>ZJSsBkunioOC8zuhCG`JFIJ(aB9}<{t1qftC2A;gclE_t8
zBhqiaE=~S+Q#kNTfd;v2MqMyJ*ppKS1!w>47RvsCXW=oM0U$0`Q{;F(0WKN>vCFvP
zwD29$1=bDRNm~%Z(ET;u!R@Z-($#ie$qS}O@X&F-StjydmqG(2{LWwtO5|(v>xWGg
zy3ZEyzdk%+xt&^uaW*gDfPQz=b)LUtxjTVW%}?3S_O*{TfxB#=0%tQb(63)DfI!w}
z7|%?(^-H2a@F)Au$Py4{Wi`~{P?K(bxh1JZ8=%zeN|yRQF9~kiW=3|DF(3Kfuz6p5
z`0|$kncH1q%UQly3J#{l|IksYH
z+ew~vS!&*Rm~Hk!2C&BtL+Bpm@jX`4y*G+!HTZQVO3xk{b7?P0e@qne#3D&`abaIq
zz}HZH&M1Nufp1Ci)HhKHLS?-`BKz#8P-^f82-i5>VC@+BrimpA#QkDz7A$WLd!*Xy
zMX_Ish-GsP2@LJtth%&FTsL(GNdo23?Mio?PJsub-PgZ7q{#z4SHbf~^*^K>QqDKP
zfTATedOPsTYWb7*xmvsc6aglZJP1Ky-zPh*-347TF$X-g4P(5;F`?r>L%Xg*63}sQ
z)%mAHNTjw#v^HSXl_K2*cFf2ZcZl*9n{w%j{cQf?uxmqXwLNWN;E_(>@-2-#B6g~s
z6EuQ3kVI(gPf&Xw{KS~med59IvxD16O_eqY06toLx(~eV&o#quR|8!ub8oK1jP|R5
ztbQKfGVrS9VnuV3!5DlTLT_84P0mmZ?p72n0?BPYA+O|n`BllksZCs2_cQz3hxjRz
z%?3(+)Q%KCinxFl*AWm4FDW9V-`%?%kbtlQ6g=OCHcy-1mdw{>?V+dDtmpRotj6Z4
z@|(dC-rl^l)c2sk9TUq@rIP*qL!zzr*r%;|U(@w9HZ=9&j^65Sn*onpAZCy-XYifE
z=o+M5q#ICcl!y9=kk|D-%gM>F_h+9uh@P)$idn5^=M#J0VgO85^YsobL-In2{FtY)
z*<;_kq+dnkzJWXlU5Q98ex5F$V#n)U)uSOhQC>$sl8rw4E)u--Jx?4CSV^mzcdthh
zZG5mnD~d<#rt(`?jRmI<^vw{!sk-+_jib3%74j1cY+3`K%66`E4Bv0m&y&$^ot!La
z2MrgTs92377DHbQtO9f~8t$gDF=gkJ|GD5DfX^nsc?jWD`5nkMMXpI-2Al;Vjb$qi
zo;XEen`f3^-ndm=Qv%!o%J#EOYc~|>Hb)_6xlAYUX~O?6Px~N&_Hi`qo4xZ`KEb^
z%Ga6BhWtdSVlH@j_fUabR>P&XtHi2#o>WZ;mnFX+-@&fup~a3LWz7v#bGY$~=E@K|
zk?ZN3@7iCHjYlS&dNvjoHNz5Fc3lKKc|WI}#uBA0vUNcFXIrWjUSrgUSx}gFfT9i
zv2v{(9baZU^(?XFw1OeU#!d$X$K>%n092zV7>YT>G80?LR2
zy4!^(LUUZ~$wCLb77WBZvK46i$vhT&S?;^@9|=$SdYk9X*SX=639!&gz$Zeb8T(&L
z8z&nH%$EC-_2h>qk-g);Szm4Z8ZpOsxuS5fJic*4uGqUt3PZ&0p+C>_4b7%!XJK(8
z5sH_w#QqWV^DLd0F%eiS2|>@j6;a7KF~}7-K>BKMj=?05@gIQVjKuone*c`etu86K
zCXvQ#*!jGi(Z(+yKD^`8XL)%*Ej9o0Z@FC8T^*~KckQ?#(Xz{$J}zv(4}CB^rOmxM
zz991W<)VLi&@9V5ywgSdN8qTuRw}A*O;>Wy!!sLL4?*$Mdtrmv=pecz=#Ap8=cQ&C
z?il)a7N8D~f#Koymrg_NEsO})PsLAuR{q|8;%xD*1
z`CZOL-v53dmOHaAPwl4jY( WYo`*CeO${P5ky^Eu?zJ>+Jk9G!5YpO$kX#1eePhQ3OBDbbh`y`4ne<}mo(=emxZ}v=kIK7gG(bq
z-uq=@j$BNo%{+(qUxHS{gecbHyzZjq2m?9DknA^K;ck6WcdLP!1vaG}L~}KTiQ*Pt
z+m;2twR)r$kG%Udz!=RsR-HacF1Ak=PIuJH?F_v&(`0hjsglCBC9R`ivq*`{thck*
z_tjw(#WhWK4uGy*`##pGF%!MK2m4`nB1L&0-v|kb$))_GyS>~}st_-*bOXa^)YzsJ
zpah`lqtIMWOw_3Lnm!LuD$;sLW|55H_>dJ{d{AnG`h9g@$qco+;^UWvMc_^
zaQ6>=1uE%5tD#4>|8{G^^j{GR91DV;EY>2G)2KfeyZFIvM*TcEo;oZ&uvgzdVdN24
zAD1eyd@m+j?0?_>X-@CNaaz9Z4_m6ct?@{9^9*W?-~z2UIhtIBJ=mPM0G)TTGjkm(93l-wTr1va&pElvp&
zi-CGrx*u$nB|E)W13DQ%CdC5F0Bnmv=xOcuFbNi#<$kLXr`RulYoH084XA1Uo(&-
z-`?eqNY1STPn_qb9*V?V*ZJBO&cSkZz+J3ewXQf|%
z)w<)uCZ-*^SyAeZ?Y%mfgLW$#Ta(?;cA)6%K-88|mv%J!2g}T07zkXQ={Ejv=$h6U
z$ECQiWhwh);)MvC$ah|a8+eP!jsb36b!9mZfXEBit`1sz%n$t{gU%ipbiRulGhakM
zIQ&yv|IGTR?#ln}T%_fCWd4Y!vAe(24u#Tcen0H%$npYQcsHk-2Ae?K@T&Ci!;uKE
zB*pQ0#=&H-#_8w}pOaPJ%qVQfTgqHhA`!}tbS~u%1B0RO{f0fjBIM)2KtpEly@9ta
zX*#fU3J^i>X9lAL1N)_h;uHt;w28{H&{$2<4F6R^ArUVc9d#&sU8_V0T;o`F$g=
zz}YO3sB)PvHw(c_|3BE~SZr(gVxps)5B|hkhIi7-Uwy7ITQHS&b-sn}QI>aT%m-Ht
zCR9{q#CIZcr)q07TM*V33LWv)%jf>*L!b-;0Od8pyqkI%J}
zMHn%*`~&0FkIlrzJ_7@Vjve@k9_|rmM(XG3q;7qv4aYSu8&+QTn14)4b(lb`j{SME
zmJ&sS=kA!&VdM8&wWK+tB!|~n+x)nrBB`Hf8IAz;{kzubF7wO5ON;Hi+?9A?i4!yPLY^>#4kGj=
zQ`AFMKoC{V(AnVSy^oEbK(`kIfhenjew)QXU8Xgz3m5Hm%Xi?WeVT0D?S?WtrgYA_
zkniy5si$qKj`Ye2LLdHQuC^f97KMx#qJ7LNV
zz=Lj%iWcO~FK!aXnBoMA$9f~zfs!-c5t7LE{jUku;Ye51VvBcvGF~HVWZ8OmKJTP*
zPV*0bq;!Tv$O})dC=3*?(2tF5=42fd*10n@r+oq0={%duk6e2(U~EoyAXN(pHy|ADs#&!G=L6{e#~oacsu^fg%GapP
zu~>UdYdH7IA+y3x9Co=r5S9I)%+DTg`FEDG247Hg0qYKr`epL{enIJ{$lYgQgXG$Z
z`wgabt?luTKkC8OHgs8I1vJt0JZz*GVbn58CbtW7_HPeS;{tEIv_!7ZrgrL9zK?M`*VYWzpvXJmC6sy^;f@M#I3m>Zis}
zk<#sVLf~(2zH7a!T%EdTyqxm`guCfY*9Opkn+Vrp0_60#y8fs~RQ9nSScoG#E1{N^
zhkV%Tb*8K^kMeZ&6qW33PvQA#4pt2egIdQHe%i%K~moKZiUq3c|Y4&-TZdYye
z#l>u99w6p<_iosI>25CIU4=d+);lEz5ceI-G@WI849@vPo_jiD`d*Dh;O>FNOzsWVfSGuTlJF+6X
z%TZtwwIJwD6bpTf)iLsY_c8K=z2JDV~+x?Ocd{Xe+qUNYJqH3^qo`A({BcE+tUvr3l><$&!
z-O@8z68HOB{52W4;mHl4P(69WpiN_v4KiN~DOBKSqX%bq#67ah1(Cu|h~-J@Mx9>#
zqm^iAT&;OYi)=uf^ydHcPQD>8T7+e7)ImQ_@l+h(Q|)+7fIf&+EM;<`ydk?d@P>jN
z16V{9UB784vvt8=hrv1Yt}5IOGHGxAOwi1X2-f@^%Dv0dpOFgYa(mcL%Q;&J
zlbfc%UcKjkPN>bvNxeBQ&!tlNWo+_1#N7kvF#7ZG!*tgV=~LVS|MsE4al8Ka)Ba+K
z^ZXdeV$d-1RKgRZtykxm{~P)k_Kfm^a3AlmC|*9alUT2m+OmHh5kEsM?>?R@ESAxueB)7
z)ZIjqnJ*F2(jPuX51NB+TQmmOOe4*DRYm0Mb=fOTol(1S4g0wUeoGx|wz{kXi=J~v
z_ak2m%MK@bsxPqh}%O++V-#8jxbv3O66R&@j6Dfhpn
zSH9}y8>A5628@rJdI(Gyzfu5JST-3h)Z1JGs?#QE%Zbd5p+Uq-u%qF5%P=p^8EXdQ
zE*p_QJ>JLCj+?VHX8vGL?(W84(}AO`m_>R~DIwKAOK`BE>B9Xld4I^tx-}yeY!x(|
z5Cfw^kf!${-wvJXpwv>TXN(5My;O+k+UzNv1#}jephM1PUFp_q8!~t9PG)*$^7!01
zf0A&9%D~jsc!vCb@Vusw%L%v8Ar9TUZ<@Pocqpbi7#Ippaj(zG0G9j`lwj>9SXl@X
zEuVp~5XJZO_F^y~+Eu4@%S^K8p>@0|j)&aqJO)Cop&|Vlzn_8B+b5}Wo$T{uIPlx^
zuJwS=mq{-=eiW|2N8`gYydS_DJ~d}U4o13d`A)(6GaUBwYk?B$gn0U#|IAOwQY-#e
z8|6HQy8&&>9avE>;I?-;gXlQCi3$xFqlQSfMco)zq>lZj%vaSjy)zcMaVO(2Ws5)6
z`lBIcFAUl0KDC8D0{b6O6Rb|K%rzr)gbP=-E^6muCrSVk_%%tLIh&OjFr9&UzS2F3
zC$OD_506aH)?-|hoVvU5ttwQ{uo&aj**vlihire}1|C=R5)ZjOIcAHpuDuh%cKkCR
z>KL^G7c9wv-sD|+j{%uzuTo&{i-UcV*+T5+10`qpo3>$9G+*7Iei8a7Fr|LRghB?*UrPEqu==1LQERdkM&kU580VlpUMAbk?xQL?
ztyVn`0j5*y8Lb!`Sw19vfmy}*g3fGYtXdJ&_LLFsz)$7~bC~+Ov))yad$D9w2V~*H
z-da;*BRk)&cyq@hTn~
zf2_WJKy~In;RD*w#3uvo>#7bPk|W;KHR9+`G+)2B-f||<9WDyiCmS?WuLs6znRxtP
zI}{KoNjo9Iz{8WWhmk2$Rj5oKQs|}22nacwb*iFp#FQtK?^?TND8ZHnFh-MafCgO8
zfsH5|x?p@1ke^zLvld2ZIxv=6wa(d?7>PAMFH1|Q)~%IkmZ)}JztxtWkOLhs0}1d~
z()sB=AyiK1C+I$|Ddc86(mGBZ>JHoQ$WEbzCKG3*Ld6loxA>axm|7*%yvaBppX
zJ*gHRniHw1=lF*r4qZB+*eKf9njN>A#RBebM5d
zJxmp6V-8tNG^CPzTG)tBEXLBtfh2HOhw91Ofb|I|vD)NJrPutP(
zFjSN32um%EF+q|;rs!D)sdgDG7QmS{<{X*dV7abJ$gmYkO?b}2**R1x_fUUQ*^%%9
zR%fiQ{OK3pJ^yp4At6#mD=vj@Tta!y^mEC&+n9_Pm@hptU+GBMEu>G)qS~=G#`oC$
zfCz&Q>KxeQk*m8vRe@q%tlRGnQ)QK!tNl<3TX~Ws<7`i6T*n~`2y?Qu^phI$T;hrm
zZEGyoXG-0Dc$^usAX*p9^bRen(DdD&5ldiNmsZo8mav_9Hr0L=)o?XN6OljT6_S~p
zRS!&s5w^IzwK2WNZVx&7SZN$Z)0R6wDSHM>5u~>S7SCKH2?S^VF=m9jCg!ys%IhMU
z&uzXC>jHME20k!D7)SCFzbc5#QxjcW-X?bM?8f#jt{7w_QXB@Cl;CyJcW+K286+S6
zl-8$D>m*Bld@}Oda*0}%0Rp!E2{KE%DNzH{(E`XLt!IC97_&10@Q!NE9{xu9IhHsr
zEbl}QZ|2-VC=&C3oeADze1#tw=orR^jrhx0Fk7wKgL-0)4$#!v>E8^lpQCE
ziR1W_uxR=`m+q}R?!2`rGV3LZ%^xecZ@Ko?ogZ)*Xywd+A#13**i&q7lYN5CQl;Hv
zTA6baxNohCGGKy1v=mYbnyf-%x4`aBUSx>4C{|y}DC0OI2($R*ny5XnRT`2--T>U0
zrZ=i|R}O)ygQvz$j0OP)nlooC_v;l?{+FD1CEJ{Q;(!aj_i<9(Ew(DQ{?SKLB16O&
zX8(jArsTx-5!gK9YV*T~ILyT}ggtAhe8E1$%5yo3k4od%t%ND6c-BoZ!8?oUi4mD3
z&tZc>o4VQ{+nc!{eJ%-7jVT^6Tqg3t(yMn7(#?-FnLYD3P`qKR7We*c|Ba2mlAT3;
ztha$k{&QF4({!YKl8z}Xz(XNQ=zi8F436h3orEzzbZ9j+kjBN9blKTw3HJv&UT>RK
z9If#1aqNUcFQJQGZr_g>Kwio4uW%spE$=2I1SmWwBoHZXlMfWQCkt?tb#5x6$iryV
zi9+LO)EQ|a#QE`&c3?lMMlDr1wZ-)vC!ahyTKM@GMX(gXy7P@+fncw8{fO6LqWHI&G+rz
zR7dc9g%B>LMeTi)xv3RODc))U`#5Qh%jwU&p*E+D>)M6DekbpFW3yub$vGFcp
z7Z3qaWi;oMD2PAV`YIiIa~HQurT>*{+r!;Kjr+Fx%l2E>{l-lSButXY-@G1|W~-GV
z-zt$+?7Qswg-xl6;=tdg-gd?8b(bRnH4QwGB3;lE`jY8OQMbcVO9tirVN}ccFT3F!
zAz)GTtOAdakip^(UK)7H=&-6@)2O^hLF8U1f|y7Lbw(=*r!~LJ_ceDsexUtL;HPXI
zp!7b-8V&b~8y4`{s=FLiIxY(Cx11>F`u<_+OQalA3A)yJw69!?8CKEuux@ULnRZOF
z^^0dmz{j`OTQzFd%V$Dp&);$k^eMwKRf&jFB46?IeAIXX|47fDz`t)Z4#?w@HpsuK
zp6BsdD23(>g`Y7zNUI8E-5*OYrR_e2a2dB#!3AT6x!bR=P!S@}@dKB}!g8&IMD8Vx
zo{S0|I71Wo)Ya9yrnHSlDgw`#V`F1|FMrBvU!kf+<@w%nOD#?J+w#1^4TRgXr4hs*
ziZnzd)14jc0~?5EhR@bmVYgpTRd`>n
zMhR@Z)3`jzdl)|5p1{7kcMSc~#r^YD0`Rn1m0V3_1*m&?0HZf|qUpENFmJ#(jCxf{
zT$p%466tp8&mZsiaCUBTyp~oYNga**!Q>0>6H2$cR$|@T?&pWJ$pF8NzoME(Cq2?o
zp_;}eJ%mz!GeVdiFJh+mT+0@pzvdHgHd5?<4f1q#NqTnWr&YGJrA}2g^MZ+K^`iYj
zL`CEb4;Q4k!XS1f$KvkIm`Urg@G98XzpDKp;kLCf%-ZYp%KFWxKfXpvQDYRbBG``1
zh|I*vo5gzm+BL0N7R2V2{o`V%^JvEz3}$5$CQZ<^#%Vu(Ih=RS+bs=NINk9aVy#zw^QI@@
zVzGbDDsPdt|9vi$ezJ(L4k!LrBsvf09?Q>^@mL++GHZpUNG@SFi~Ih=_Rf_ZXTG^1^!F{`yh)^y=7yD9G-xVpN+Us^Ud
zb_oV7-==u$@WuV&sytv_%rwt=#A)J!Y3S^!&2z5qVCBR;WnJM~aua2^1>7u0{n8Hv
zx@lK)66xepfWHN1%|Klae*eCzi8
zJE){KIp?%HTLq(-BgnHt_t~15n0Uc!Il%vVyIA;gB`ls&EH^wn{DWDJW}W?9S2woU
zu-lkOKVjP;;`sQu^~_g;A60Kq&-dnK_I}m+Y@}+lWPV=wp2~bRHx}5p{BZ9j=(Rr_
zhApaNQz-c#;~q`SnJ_GCFcNtA-w(F4CrULKIJvmOz%JoEJyLxMq%xkKy!A`I%+S7s
ze7}o*#VlUdE$b9z4NFT9?dy2s$r3ev|D)b=-I_>LT#$~iFeax1f-#3~g6b5#EBPS;(eAI($Zej7W!br@q<>)mM7TLh=
zTum4lv`x41`*%uaru@bJ;#`#(@zd3#~zu`zk;k=JRz9kJd#4bPf>>xOTn(ILq22!JcOo#`(?YGK;g*i3$T%eQ5{nGkq)&Ed2pe1F+5b_|d}
z&icAJU}enfd~ulxn}Ly$Lc>(@wo^Yz$*zkGoEgaCQ2rA1)Y7r#3F)@kE-h|LN}Ccr+X?|^+ke8u}!>E8lr
zX4Vfb^g3Ab2WYnCunV0tOVo%|s{|lymawC*$_^w!ZsMY2mX;4aIE!WT56;M|frs$dz7oM`Fq;C_wKnmWzS)
zuccN$z{oBzxlky$2=Xo~O99XkKRDjV{T|8cA4sO%UTo&e;&ZaRKHX+9Y?*yx)aUqr
zjY`eV9+sgDkTNkb`JpyCfJmtSN>7i3S^I0j+j_?ZZ)gGrDQ~=V904M^k|0CCVJ9*M
zg>d>?$Hs`&?kGrVsj(Bz%QGCwulmN`+c}uGj`lZ>huGECBWIyQZ&Gqs6Z7g
zaC`0RzXp>Heh?1>V!W}DX7qB|a$EI($weopIe7d(#}z>3m6eMM3c@{hrV+^tCEWi^
z#*}Ila{?ELjf>l!sh|YBPA?=Rv}HXmU;^Y9P~^^o^l3>+NgXNl3bHCH#cKJlf#2&A
zEHqtVT)S8~2PLZ8+|m*Wum+QeJs1G_wC#!FN5%Vy(SSZ0w8{%008+pFThK!wNI6^9
z)s@q!{f;;2{vGF7e%0q`NuZKIp>5vQg;Yd#jD2@q>K1_myd
zHL3H1Wy(iul9Q9g0iN;Mt?IuV^=j+>Rci;pFsk7D(N~WKwj3c%6sv3k_J0J>wxF<3
z4T!!wH+k1!lvVv)jTNPuAj>@HAE#&{|KpS#Rae(zfw!Uv(Q$E5u+To0kWdzo*hi4O
z+i)N!Iem`J<9Nqi9%<$o?Q3@1Nyh8*y`eu-Wf|-yaHy!L;xZbD!~(8#W!e=W9-dU-
zRF|V(!jmPx14MEKWPl9Dfjs$OwuLv6E0V=r(UL+f8CmJJscbo#ZSy2)rc(aNWd`@J
zY5x`&0D`qMhC`19=6k+72wdU0J9nwx;K&F)@ay&$n;{TLH^4m^f*vov=+&YDTqh13
z(*f(4waPyLDStZ?bVmqycO77UEC3bQ`1sO*L<4N1d$b9_01op395ggEZvb?M>i=<)
z+*InEvXqXn&3>TwPt^;o<$L
zH0l13zlC5qmOFy4t>2kMEy>8jVm@82yD|S4%~J~g4F6MPxImGC*w_+T-_{|J7s}HE
ziR1C-&F|5iq5Hd=?fH7(SvRl+kgfp7d|t?MYLm+o4QSZR^=km6-6NnsBJ66Vm@WTu
zJefcWVAi8nWe0N4_jIe%uA-H|z5GO3Ss5#MqubUVARP>V!+{_I;`5E6Aeo@M^^c$b
z+67r_M@jncTXzWnt6?6CEt`%A9vN%B^@pHpt(U;P4Tt<--B`6D2$An)F}FTKZx1$Yx+
z29uFYp4;o0c1ysxZ%)g(F}Muss;W5d!lhjRkt71@>PM@emsYt>XIVv?{3E^mss%LF
z=j8XSZ&Pw}M*-})+R9Jd8ZSf#TA;%w9mMb7qk!s!Wl+n=;IiU0?tlSOL>V|MLo7&?
z%W~MbBN!Hl#y?(rqO}+bf%@I_xT;jt*C%_7%-r1E0w6YTw`9aV0fBtvK3Tfw?!w#g
z(lpNiwzXMq6M1a0Gx%L-fP^>hiGBt+jfdBMmi_%pgYQ7jkFo__DLfM7f5^#0c?c*S
zJT$fTz`GCm*%v?^0*I^Mb-3CMKrn+2o+`8{!5D^6FQV@`CknWI>
z?rs4|3F!_61VjPp5H`}?ol=5ycXvwXCf>E5-#K{xAKvToimp>lIYSd`Yg+JW?>tF5gCQ2%oC=|-{z2P_OgPOaqS7o|x@QG0=k+8fX64;T?5
zvEu!+9YGDkfTby*24LC4EWumDNCWr?
zj0K>wH2j1mF5uMuVOfqpP2==`fhWJb9PsToygecSrAyAk!(*_t{~5pQp9(LnKy)VJ
zFhb7HS@KCoEl8vhpm;1adHaXa+=H7sN>9)~kEtL7DhQmmwl+LX?))b-qF=3ns0nPQ
zD53aFY40YAfcTjo&dN*v^5sdL(^jiVxZp3a5d)v`7@o45$qkk|g@t_m3d7>vU2EH#
zrAM~4YxtkgiMxUR@egwu@Ar*K>F{Bsr_fg
zT=u5FMMQ|0nVAhL=QS$Pw#T!YXaU6fpC7WGU~U0oABRREqom~JrW@Y?lXh7^4|Dw&
zz!_kO4hm~0zzr!WDNwNcjX*+zx(GvK0QH-IRORO8;+GGI*xD9FVK69DV$-n@hmi;-
zf(4I@Lx-Mh;rxfu=gMda{llf5RE&*{Yc|tDzk9i%EU&E8f~wgC)BrfFWZoL^7{+mc
z07)CN7(8@J0SHJ2mIj1HDWDVUy$NC-9(?jiTxj5lC;)dg1^(mpmZI(gtZ+1qF~RoUb~0b~r2s{a_X-Akz+~W15b@VgRWd
zcK~z+pqd*WmY0oT5)~{IOVb58OzOcheDUW8K%Cs^|MKI`u(hK4KgIx<7_~}XY+9J(
z^#tMN7dW|r{bBbwvCyfoXi1X@?ds}E1uXeh=U?!8@c%v-H9I@|=2P=R5VH{=F-onc
z*a*38djU)A2N0uOYAi80qy<`dA|N5h-7)k@Qx240Zibb1cD+ul==z*JhN8K
zd$PmBLl{6rN8?u6Es!`>l#41TgsruqV1|gtbJ-B;*SnaWYz{eX4t@Y-3r3NO4H`fG
zC(04K@2g}~EMUk01!$K9`O&LuNuzhJq4h<<*<(fHTezvE6_!QLwTGuq$vqvvO(N)
zPB?S*uI7Nz0aGDnb#*m$G(NIW*l
zu1_4;bDCL!37~-0>}d9uP}^1z$zy2Lx}-@
zjfUwZP)JLFwugm7W}JZxQ2XGyQTcQ#Ba@O)7gyU
z|6pqD-&$^2X*HGxkR7m7>P^~>?-v(t0I+}e_pevY*scT#Uz5T108k3?^r6(1TtZzS
zp#2}AErWkG0saYaFunn+LQYN&tlr3Ysfi?PL9-Mg{q_4zvOp{_nv#;!&>)p~xv>Gk
z($h0#c-gI414sxcXK%MhbDef4SvTG8;a;WE?4H}xNds2Kz`y{?MF9ZSqjns{5|=$4
zm~U-cw?z$eOu&~A0anNk)EzY_Nr1h8?X`(z)NTdkt7h>dDu_1qc%W*^JWj3t)b9(y
zxFT>xfSTj}7>36KLQME^jC-KqVrw~;hZjXHZ`|?`k&>F)Vaha))$8KDMv>k#Ck{kLVPOd1MZl1Y=^*>w)qz;L~gLsQeFI+u{fS_{p(}`OnJcRSSBaMF5owtS^`y1fFoT
z*bwrS2xhrI_z6>O`@VNjzo?XY7@dKYCqN-<)?#%phQfWsN3!Jo!_=t&S-J!*A8C-N
zmsN^Fmk<2_h{o83hJ-BfFI=Jn(WahKng^>%An(e&p)MqDi|`~q7e-d2Iap4NxiT<{
z>G`KN2;leOqCZB;@kR^al9nS`Xm9|ifGH9O;t$lU4ghr0GBV_JbRl5phkuA6fx7tV
z4FXaIPzM_j-xMI!qrnfc2gdVZ8|iHXNF*d;`TH>9({214N2~yUzBYM7%iNF6;6M)A
zg9bbS0VopP=ddTw%}!Ycz>Pw`?M{Xraxg5*0(-PFlTP$MO;FpW^TvH;5XY(M>Up3-
z3
zHPiFlt9;d{uJ1fcZ!^GI4RmzUPrsR>lGr=ehgIkYqlOehK(sJRlF@LRYk;zSpeW
z^KR+?+1Xs<27GkB5C6yAGPd(Ug@BQ>_ZL5_u_?YG2L=WP;bFkb$jWX3(Ta&Rz_9cl
z)cjv1AOT>VsblEET?$yOsMuHyp$|uTqabC0DwL+hd1{^T}16zQN
zf*%O$L4krC8pOBX(b*XV@*PAGOpes;6q$f1^#Tw6N-`gJLf@4bY@=i&a3KQH(#T;|
z9yrMPJlgMJ?0D{E(iAXrkM4|mk#a~$vp2*7K;
zhMw)g64VXQop_)g5FR}NY(}lH!eZzncmNQ=9RTA&9ulo|hSRXH><66BfknZiEO-hl
zUO73N@ztFj9jriIffBA9nETP*V(TEq^Uu=syJBFyB!L|mDl_d#{ZDn;z`f^&VfjEn
z&wB1R0vnIS5ds8{O114Ay&RQaMh0by+wx<8@vp#()E@pKdd6XaS#Can&ZiStzm=5~
z7GL9@15gIohq{3w^aC)s7|SQX5War7a5Y{H<8dJ6I+L$yllNhK5h!T4>%&fW5OrIi
z2mt%6bJiCW2&et|b&pm{HqJAz-Q(=^%v5Cl{JSc)L(
zy8dI3sfGLnz90KQj00RFIjwrn)7wE{sMitVlmi6$OPE*&b}{G)h<$ou1R|n9x0-p=
z0x!$`cpb(*-d}Xty$fnH0&2!VZ4~ynyGw80CV~G=Nmicic3l&V6H-yjqV>%*g?MYjTajZfGW{{wbS&k5Q!{XG$adL?ZS2
z2{bFxbv9hJ-9pm~3dsLnxu&Kject8n=3LW0k-hxg1T%B}F5A4@3L4CaCvk>cUwgs0
z>O>Lo9kltbC$8xv^GG@fl#b%%_WL{=zNEwb3Y?gre_RH&8$95dfR%wYD1IzxJP8!N
zULn1E0~iu~*2qRobo4w%Sq8vB(T?ecZ|{kXU|Ne;ro*pV}rKeN)H
z%>v?)*VZ!0PZ?T?=B>P7uf~-Uwc(EFhU5(5h_pZ
z{oXsxyBA*FK2-m|byBH}1Qu#~xR4A$Mr%(F!c6ml6!^^HQjo?Doy4vOATo}+D8dhb
zoBA1+1Hk12pd0SqYd4vU}an)=RKye!nzFauC6e|f1$zrJQW
zFaH8KmC}^hyxT%Bf7JWxWC=*1jjSYFasVqJ1ww;V5K)8LV2l*NH!Nsj(h!&u9$F!_
z0AoQY!7v>u{-hm1n5#Ie!2eQbv^>i#9s(HvuAi=fKmdYi8#vyO2(%K6WCLb%F@N6F
z35o*D4+0Ksx!XTo1Hi5k+kfASS{+MEIvCgC=dW*2i;0hyGBB9O$`n^;;dj|xEbSy&
zaczbY!^n!H@D&yyw!GF5SZabO0^ZNh$x;*d+slpoIouLh!7lb%V^|yEZd-ck3qrL9
zpc^1eBKG#IU}^9i*L#0dR74A3FJa7j>=dq5+kq1hFtoV_?M72zKL}i|Mmg1>6QV}@gu1fadmVhRMKk3&yfZG7q
z|Jj?gwmFd7y}&sIss;2pU}k*1>pnGLc`&C86d!=512D@1w7D2bWYjn77jBpl5fMA*
zHgp%R@IkP+j6LK-(=_yUzT5!m0@l`$m*I1egoK2i@6Bm1MEEXvnM~x>D|o>A-hyHa
z%P0JQO?=SVwQ9Xrb*e`lEI!`=fMO95$pXiWz|hNn@S76~pYwJ*fYtE8YAcU!URur6{a6kG@b9or<+ncAJ9~RF?m+Jtt9{@_n8Los;5q@O@
zq8YGbO^M$MeLw{18(_0AGXsa5b5Wc|1N7}ThtfeiVVw2uT2@vTtp1_Vn!{g#*z&g-
z7JYNQA)F2J1t1P^WU-u{Cw~I&6-?oSJ{3#J+uzuL1qX+OfC#qW=)O2yaX*_fN04!M
zf*lV6U;^kOteuENjN}Kn>LEyb%&)I8W(>e-6~O+V3Anuk3StdLfx%|LXGZrc4p~Ik
z|Eb#vK0dY}|Aq`~X+76DXW+4CqYNh}a@kA|);Yg}0}4h8$n6ITPF~SB
z_VbL9NY90CUVeBI$q?e&@SJ0^J;CMSAP;KO3xjY^;<
z*)4}Dg)SBmU_lO)5PWcWcy>iag;(U_4-h<0LCptbxH+8G3=%@CBtoa08lfT+qT=+P
zm;gu6t!D|n@fQC2V&WmF)EBwC*q1dRm`0A#$QZ+iL{(x#6m)lB
zT}#k;f
z7SCQ%z%{+x3hJEAE;!JMdKwv=Ep!Nephx>qgd3r<{{_3A?#@JUHedw1^Nr9P#4NGK
ztL^+RPg$40gt;=)QOTf7tWBf|;+6+tJJ3;vM;^60O59*lgke5zS4z^_#!~cN&XHww
z4oMd})DsbStfu!{ZcG!LYXC;2@lcusqh3wK%+jX%9XekZiAj;dgoIH6VC?FsiBu
zk5r^_LWVfJ5M}^cAICOLesqOV``u*-)o{|&FDaxAdiWW-Y
zbU^5y`dLe3xKLuZ#Sr`b;*QvzVboLXkRSM^lqrjPbWBWZJ%+bz|10gDHeY}Z3W_8^
zMe=V5RJ}A1ugKBS(Gd@Wdt{EJk6!zyDY2!eE*?OPTlQ7df$l9$$8KswGOn^)S4GJ|
z%LCDqr#Nw88_AN8^)fKNMVS_o?zFj)oo7v`ii@6aG5SIdVY$|ikmE%P<+7z58dzGM
z&=B*tz~=Zu%zqXD?PzaT0?YwMYC&(0j+i1Go2wjBxNA;?=p_p8N&D!9c+NGRK+I|N
zVR9hm$ML(d^Nf8Q$M+=WbVyn2fqr%EL(vZtBSajnh9eV4sn0S<>_F8z*_j9jq7{Ir
z*R@G!`(TkizeceE?D&k}Z7n&C;@!XJ&0%YYQS|hQ3E__CvuH`^f
z?ZXyh4Hm8TenlaK#ZTEZgFCt=VYDlx9ycgh^oGry1|8-{=$E8{o<~|&yTY}Ur}^gB
zT9P=-z6MCQwg;Ezs|eKrInn?CRL&P!(4+(|LJ_PaTLlsw2=1gX5(2Q8TEHp!=}?G!<}SpaQcs9T){G&sk*@h?hUjtcjinfK^kTx@)7j4ny=s#5uB
zj(f1x;-IPBNA?LbGh1t$_u0^Jm!+aUA2Gz2*>tVcY&7GrB~1y{N@atx$7G`(1Ph$T!zA({EJWNZD3&o(_}n~qSlQMo+Q(GectKSsZ|K1~>PU*sdC
zCZwZU`9m5d=qPl`Y%S9ks`G8M4zX{hBF#C8tHN$1cDzq#@FlLI7`hja{a^l)S9QOz
z=1IuPU{yO;k6ACR$sqzVaKVKckw(tvmq%K}#+DLH%o)^7(iyyu1M)3@(@B971S=sl
zDX>F1uzoe*jPRJGq!`a>C%p{-4F^8&+ds3lfLvqnlu&a=4Dg*r{x)!+qrW@8y{;%I
z@Az>U6`YOZyd`3z6D1Xo2^4_9-Su&Fbo6tVW+0*f*~!ezY;SKL%#tVaIR7IL8uGOl
z%c0L+zJY^vke2Dx6Oolcs#zatNs{Q&y^x8X6zl(8KD3elEvP8us@)#T*+P)+PNdm=@amcMcEXTKsY`%HM9`=$cSK8BR
zBus}R+idVKFEd>DHXd+~600$K&{l2(8bqtngA<%A`uRb{m=gO3ARDlQ3mfLQp}mAq
z?RJGTRgd?1bG5bPCXZD`10J>(TpvO%XU=^!42r;MA4*EfL2x1noNiJCgaFoB0q3nK
z$jHbRS7Xu(-q(BlLCXrL|~Sd8lTdy
zv*`9pYLgDTT!`3yKSCv6I^Ixxzjl1LetMTIm0mLSd8+a+Ea^CHYu)asdAf7Ph9sf#QA$YXhK{
zUe|A9I`UPP_azhSCrkn*e+|mvkBJqj)C5Xx<$vwJJh#8^M2=$pmNb8|&B~=bT*dft
zjH07T2Yu3ToYa%K97)aXp>FbJ)-|PeF9)qw1#%=*VRy)%)Yr*6?PGkt)Y9wwlhVtG
zXx+`|j&GPw)8G-L$wMv{Th$}U$r()uNF#d8admhEJ`A?pjlYm1B^-=<#36t*At4cp
zDX7IZJ79Kn8Sizb^5A*AfR0ChzxvqLXL$1G7f@9Jqr`6_3|2#ti52AE65Ahs|9kd_
zZ|9zle2kTR%rMo5v>GY)ts@04I!0gzN79gRIO%GXoNH5Std;q*d(wc`FWc6|X@O5q
zMaBJ6MpqmNRUtL06v?HcViHbvG~c~o;zIF2Q&URcggWhfFIZ*iR!DMh1+
zaSvH93rtw1cGH8Am;7ye)s?aR@Q=Fe64E
zk?^}g^vK1%_ZUR9$+pR@*uPVAkdbXleVCMeti4MWDrij!At!GqVf=GNlGA+vVKWXk
zqa6G&O{p4Zwz0+gSFI+K|7)|UsOt_0&9Ad_MJhf;@5fPf#u4HvEnupw`SQBrhsNNy
zyj~fXV>_WAe!+pMBe-J04_ozQ9qUxMH+g8NM58-)m*uOJ#oLFC5b2ZfwYkX3Sb|DM>atc2Xnp-#(!rO}N50nUVn@gy7*3u9B4bg>NLo1xGUaN2
z4KYHVe#5-8;Ll-buTMEbJv)zeo}gth8Cgox`=ZE{uc$};}wP9!o}=;;>9g*~}6=>fFb
zyGB_2+5g{PlYVYj!yx{$&v?&-Snla{@}v75GS&ITeA_`2jhz{de3ww2
zUf#Ds6RR)j=%K{2sfA~ZSPw>a2Y+0fl)+yAN!h+*`KsEg%oZi&;6aksfRN!STnA(#5eYAdZwc|oOU~lv)d*31KPW0|zq~eIbEmuic6H3Z-%d;2%HY+?
z=7LBp5tGA>Ruh}mjs@D7mb%@{S><@aIs|zS$V9(n@e1aWT7(J6xP_tZrgm*Pjfuo#
z8ZGuzqzP8~hdHX8skAAWV0UDaA2_EVZq9iYu(41_O?(3
zPodjrMf_s3nWM^pRwF_e3;9r=xfc&Tx$M$;n*DBg>(T2K<-WQ_@>OIlNfZVbYOhp4
z2F}K&3Or8*9mZ`l*8E6Db99s5TR%yDt#3aa{wx|qFXgA1{>TT*J~EfYJMB5?*Wl7CvaSA-&ea>3G#br
zToZLRW|p=sB;%G)__j0-Q_XVk;P@Tl3tV(n_FR%v9Zrf|lO%e%V^SI&NFnncj#N>e
znvPoU(FWTjnAQO!c=@u>h{055sH4k>!<&KB74^iIN^v|*QnEVgZILDSd#(1tfd5SK
z_Md%7u24ynGg8e2Z6D_6qoK<;felW_Vhty2NZL2UUrhe!HrNRdgx3Yd+4=CP-ydg=-zO~GnQAyMid#*WHp~*%xuiYif
zE!<9oar?1V(0#RF?q|JlLc8M5$qHoQf<(goGW%MuiczcoM7Mc>D%UVw;_gp_$Nq}k
z&G6mP?`6*HQ*#{fguB_%1Q!!)_Jg$NMlzSYbm(&baA
zufpN2Xcg0d@i>Lz;a#F(fAjwBPpL(DI$F)}3jHF`l|5~=ZmdF`rAkCDxX4l4E-#N7&mstV-*uy97hgT)MMuBZHh-p3Wkd-?y~-2nz`gZNn|eAiGbotU6HzH
zS~2uon{fa4x8d4Fc_9-d36LvvI7v$Ww%qz{46X_6!%@U8I2@NKiN~9VAVX{_))F&-B6_P7uwe07)y!8
zuv+4o-1;(qXY79cML5g1!#+}#8k%sTyKgQs18Z{-xvbL&p#T$;P45|kT8s9~>oU_0
zMFG9oTQ)(}+xk}0a|@Y}qi2W>9p-w{C90=k<}?zFl+~@Wk*^8{+Fzq>Ca`@*RJ{2L
zR?L#U;?ADk<#JeEpyoypo5kY&@IXG>gc6Mv*vm-S`lJf0FyoyXCb&HE
z>2%Y%=d|~7ik;HgLVjPjm}LRnzwsH+6}~`|@H}U|Vi7JJ+?ZaI)hzXx-m%uN$rB|#
zSIQLsZAPlSn~CF0zsEy!^ce9v;S?9AaP+)-C8St2l*F($OmqM8F=GAM@LfvM<3NmS
z+rA#31L5l*ck%*v3$Bg>)4s~*ty$S8li40VknSsi2_`AeumKIPuD;^yBCkm6V!JQv
zG5o&m^M&e~dFV29%Az8Vbm_=jMI!$nkVT>S_g;eeCJst`XBa)5SvwW=`&SP9gwB=&
zS)zRP&-z8E*ZZh>}A$OsrOr1Qos8>tukzD^k~JemFGi2XlJ)M
z$0@5Qb!G9&Dr}J{Zd?nEow_qaoh+$`qyhjO1lf?DU3l*fOyMcz<>BzH9#33GtM8&S
zhW-Vsgzx{hb(4Qg?Y@u;j`UZ3Pp?b++<5V(`sGcmWc=~5d3gNU*;4-gP=g`26=&^Y
zFm&C!&YxG<^HWXxL+09ZhE9Rk1I6LwJ8RWpN$IpK5Gl)tpJl^nmv-l_p6wVUwWahy
zhOOS)O`{XR{VY1wo#gOj1?j)rbsap$(gZIe-7?e@+UfCKjQ#DcBR;S8j^%741%bX`
zJOK3arNZ+Bwkrd0lr@xEK2zcNm(z3iOM8f-MDPRF0Jm^ruaMXnp9WPtM2)ig)@%}z
zyt;yc^pMx&)?Vghhm|;%^TjhQUzNEU$|Drx%&@~AJAz=CMkCcSeU}qWn?Kpd$w8$T
zq8X97TQEA&DCg{cV}fIai4qk28XcDz)#Z;-$MId(fEINy`uAPiJmGdN5aL6@*j_oJp%
z+b#`TznhdJ`?eSwM5ENeLh5%hjr6%-XW{$6pKy$5E|YidBbT9?*s2sMO#8)epxf3~
zTsg8|>ng+DeMon_H=HImLdG?J--@zj52TIwVwf(N^LkzEpXZD;U?smsr^3ZCTc~NjO~jmv#&=tpjy8<
zzFxD|ZHm?K_l)woDLI-6bG3cGFIaPx>U?{7y6>=ZC#WuTQ)1TU@#MOHLXmf6
zt7$=#;O;GIVU7f`@5w*bH;i|DiTbCTk-@Gc6(Dz}q$APM#x`fy6voFySPmBQ!nz|U
zXpZad_XavN=q~8W={F&H2Nj2f>ymP|R7^-nczRD<5#RbAh+~R+x|TNVxNgsyL$ngD1_f2}d)f!^7G~gDG-VXDB|4$56F@VAH1d
zq{~~SbIdlux!ldJ7!Jodxe`d+%P)67{DpMUgI8VVJhXkZS5D&odDc1U>HCEV3*Hg}
z@K=;nnF%GKOzW&8>P#C`;rg75E#FQRVuQQgi4EYkWR7KeYh7M9Uz+wXxG|mD&)@Ye
zBwQXu^*+C2s4DI^n<-sxzW>QKgYFoESdoZ%_?
zNyvlylHVorazHyEFV*X*STG*EoElJALdJ$MxEhL@9N0#C4ErTk+dCCa1uT2Tgbzh}
zJ~YNdLxtHvK3mvJV;EbtBMhebx~|Jz;}AI6y7nGJ-S+vj%Y_sxnz)+EBeFexzQr|N
zzd-f9dr(e#M^VphyGCmGth0h>-~5o&5LVLrue4F!E|Y{;Nezh&eZJ%QdIn~D>J1QK
zTz~hSJAK*%@l3GknK;@O6keO^X;R3jdC2p=ztLeMeDkvM+etIDr{OjkQhKmO0H<{p
zx78`Yt#CpzyVoG*7|n)A>6QZ!r2Z>YC37Chh?gRJ-9m4RaZ
z?|C#n1l>teDP9U{p)mOKOt_cl1Ou^lch+k`ppaUQX5J|8pHFo=!;RX_EJugedXCWa
z-gH3RZ+vOka?j%?OV=rW$=REp3rT@2f_~4fIss`C&B^N{-AYZ?Uag)y?yK#PHz`
z>^qKA&bJo>xs4*?U&REred9y8tjBYg0vthw3XWD;L!XG%ACh^HrJFJX91KjdVOLCpCbTCm?|kPszVFJOH%1Q+2cqa(eCr;5;QwIwBMKAx
zn?mx`6~$#QQ%t8(p0?mGty-_Ji1Avr_?TaQ>{5v>llq}V>x3vnV6ipNp&J$TeeGOQ
z!C3a3s+MTW?MfdU_Tn!h?JqEBN+^0VY$LF)W3ZxC`r;u
zD(opp<8`H{aM4@4dcOUuvxzkdiy*nLP184=sb?N>v1PzFw8cER^=J53GVD;c+ih9!
zBcKuNBzakE$FH|_uC++3f{6?3%+NdTzWXvYKRteCOD7Zq&Gv~2xfAeD7`TqLaKVSu
zzO4Q3*)svJb#v0wXQC&9ZAn$KN~ifdkhA;6BDJsr`C&(fS;XfpyBd`!JsBQ=cVDZ0A$2
zle_xwp*}bJdbeEz2`9-c$1M!9Za3T*a0lH3f3hbe!LOf8-C2Y`A?A;)zB^+4DP%}A
z_vr~3;X8D~V|dej=Wu;#Ug9Xri_u>b0u{37jM?Gh6n=yhbtqMQZX*%N5jr)Lg<5}4
zPluO+iQRDi(aum61wrMHNk=3ylw^FL_SoC_LY!0+5AlD4y$
zefIau@&0_{AI{3b;}H=QzL^Y+O5ERfJ)#A(;Rf|Y;B~y%rkcbbPbvs@mhNw98Rew?
z7~2*vY!t$H%|Y|-oamz;3B{x1&Yq^0QNvia5MhfQommtS($1PFCG-~
zg_c)B?z&Ht+?QhSs3Y;x!J`*l?6B~-90jaHld|%|YHCXLrX5%98%_t=t@TS2Kj65s
z2xAEDJK+!b1b{nFaBa-r+rh81SS{G!Q_(|va0PK72an6M`aLMU0WVvF%N>%OF>MjD
z-QD>o%gCIV$k4FAE{=e`_{1E{;5B8w+V@T0=vsk$DrCwgsQ9$?dS-uZHD3tf)z9Ur
z@Rw%4BlDK
z%*aEJJfTU^!=FNMZ}C=fLL`WK0-u@BUQij-tZ5c_+mfvmC-?WdpGT-iAaN-86}tH%
z9CjzJ@137byX|TE3goI8o!#^4y^wkK3-?eM{!^
z)#-ASFmyuf?vsms>WzTw@f>(R<-vTYZS}sgIC8ER@>0=P?~rQatZ@TK&`y-APm-`4
z)VKF?)EV|=wX3exDudab3)~igoY9ZAbq;Dnf|SB-_coe4OH2|R&d<->eKA9J&qyp%
z5@Yq_n`f#zQ+S&WZ`bk@Weq^~RzYud4rf&)%f`aSGB^kDf+*@=LSC7NnGYtc&~45o
z-$Add-4?s;9QyK`?Pgyf^V}FV{e(1M5YJ!k96zalkDZ_56{0FDR1FPtaVNoWnsYx7
zA^6~L2tg`uI-`oMH+N@B9J^5TK;wi$@{(d8vWGvLMy;pNMTY$58=&o>4L5P-&jj2b
z%mtCOA)&@`+BH{C{Q6@6kF*^Nwp=3Rpb)i3Np!$~DvjD*(m=d-Wp
z&M|i4VPT$OX9!Ep!_EPN<{8`^DUR;(YKspsQO7%swFYM(zP>Szd;ziEa(es^T_
znZsRNjQ8vox9Vsi9o5A9k9^0?VHMdKBV^8T#@Y{~A9SymLGD1IRmgd^diR$rb
zTJ)uTsZaL3ZO*-xCh(Ir79F+|=}|@TqOg^7n-R3uu8TAvMpQj))5QuWaGVT=g|F9NUKHMi<1kY9d#aMD7_}KX6o7xJsr5i^3p|6Bu4u=yPVGkksX2a3Oq^SblMJ?tAvx%$)Ub
zhh6Kq_d&`<+|1MSK*hb=KvEBH(#<-@oSox0q+sjWNYzf5q6UVcCuIyLc
zbnQok*>qW|NGZLpsh#A_=9(nX4c&8EX9CiZxD<*ogcq^p`_A?6ex*A!+ELU+$=jo*
z^!)W8U*0?JVIrgsbQT?S-0DPCO0_;XA$4xYHre`jh{z8VZl>|X%WhLLiyG`bX2L3o
zTxL3RC-i?yWH%q2*HO<`My%SzsdMA@xJU>+f={-pUG=$p@N1R-b4Ju40
zl*MvvS0BXv=Y}1Q#=u3Wqw{1fWXHERRQQTXH?G)tYoBxjeE8XMZ7v+;HenA6TK)5C
z%Q`J`)weu@KCkthxV$@)e-fSFCNz6pE@<71$~K%BnqFUqE*MSH3_MKDF=WZ(w$1b!
zeG7JsECZmb-6_{+w{mI;Y4v=SCgWU3{^S0N)^`%^L3Df%DAb;alwpC0MFU4ZLU
zfh$y^MBTVn123!Jujn~)GCO8FGvuWUVWoI_d>N_@ofV~@hkAyc8@PS_(-vlW%{lVa
zerW3Cx%+dw`SbUVAqCt1eFg4k>hu#f#v@5~Q8E>JuQ*@y+2dAB-kz_$t*g9ZJ6FII>|g4R*3V3TcY_j3+R0VdVg20s(!}`zT@;4f
z4PW%B`^z2F)TX>g7f|rqNDUV16^sf8ycR+*@NQK?D8Z6j-Fi)tLKXqj0yWm**e7=O
zPIEbCtl|7xbX=%9qV7m$JKt5sP`!L&;@5|wmMIBDj@^QlrFYHEy72bL%dV4UyZWzv
z|D>t$bi3`MTq+iwQ6EI=sZ>KV?rJ98Rj>*!|}!g^DL0+-ZiEq)q4mp6*#EjoZ8u#1v
z`dlwx3jXRpZ#H5b>M)4KeFlo&u5GYxR+Kg{B*IkD|sh=Te#YeKmq3wMF6i7Ca+cl$ec)B
z7~A@VO(4+60G^cvyUwJZswlVY{
zzt6S~D5WFAXAecSkl}tprwpg<$;tSXZWxPV;?10LgUm8}#E>^`m*sF{rXh6o0QPvT
z^}Ykwcl0KIny=%Xj~5nA0M}L{Z$YiT=GKjE?CED(a}ul)2GsWL{Q16dTWcmEI<&R?(=VW=b
z;iEv$GAu;)=gJyycaYrHig-sg$4X54JnEj$K$hXX;dpMZ*>k2UzHZ#D#Jwe0Ej3zV
zoA#};k#-PD|mw@dd
z^0VWFratB__AT?*DA5U(k-W~iq?qu=pAGx-zt=nV;SR>dj@_V3?!D0YWJc(SULC1$
zFrBM++>$Ew{$b_NcWV$PKL?K$%zx6+{BcH2clCIrfnlq!^
zk>+`87e4Wt5?^r9r1Yq?8B3hJ!DHgC%zg+(L*N2easI;a3$!(x=Z=OOyD$1HM)aXb
zCtv)I_aynl6Y{v+6B-K|9I?O9?O(wrl|90A!>{~*v_&OILpBm}gzikK+u%2ez1__)
z)v!uTuFdN4gjCMpoLSPe8Q`vXcS0-C_8I|k4dmi3
zNpYxuUrnC~~Z~X9k&rniBCI!}k{Z)nAVacJ?f%H{W
zzgIyOljzT9Cr`X1b?~u-I^X;nMDt4}E=WN`jZ;3u&^(-+@a^)4+~J$gx~Wfo(~)cI
z*8x@Fbd0|(tW0r_Y~_bV-mWC_<}0p=m+k+V!^Fq&Z)0>=*#X}B61f8(lm7=YJO$k{
z&R)hS_ot#S8NoU4I5}Y3`qQGWYMK@Ltq1q2a{AE8E$!iRS)r)SXD+y@tOFe<8>G*~
zg@(9%=cTe$3Vcl;hyJ+~ruK#s)}fPNx@6#&Uby-$0VN;clt|O;&JVOAGXF5iwAe2(
zyv))7Pn5aZM6w?Q0e>?f7C&QT>*NFXKbL`>UaDlc`<*hTN8;XY7P5mDFxKZw4uom-
zLk@+{^;*(+k0Xo5H1Nn$QMJ7ieyj!@a6h=~eq@k2>!?PA+gI@Q-BVHKp^}x|AF-5*
zB_R`ZG@^rM6H4^oD1#q9{1yh~=2^iT+r3isD*bM4?9NL@J*^7%vE*Z~E{nqjF2dGE
z#Xn~&!FD>Mhuy$|Z3`$0IPDjF(%5G_eTx=?*$xd6ZCD_pWv;aa_x($&hAkRWJT
zm`;i*`@WL=LxG^2HjBjFsjt@5BcV~7qND%0`ou^2Z`i2F=4E`4ocyV)rro;XVOekh@m7g-Mi`>CIV*o+&sh;orR0#@*87);AWalfC%gX+OyXm||NeJwaaOmj
zkLWE*X2%o|MO@2jBW|Dkc(KbPssE89yyU|KogK6IRu|&K3~BZhTRjnBW1Es+Wyv15
zKcUv-e=c+JB#^tv7mXji{JdPU@*EG)m)BINQ~l6UY^wK1#nTO0&N|{>4xP*y^|z)!
z$t>S5ze@1E+$p4zPSm8^aIaDldr-1CHqJTLjuOloV(=xKXoyRTggSN*06Fz>EVVhjTBSVt=)&1yNE?Sff
zWLoN9otrHW>#Bc;I5TC&QaVnxzl-K3;BY!f>^4o`>b^Xof>=y`L)XE3oMPl?_8@EE
zW(fCfKUpIij#@aC@Tz#BITBifEN4&7TTadlORr=t2laO$aBur9JKowq==hQv+_H+Z
zB|hPLk91p@_xaHpN#2K&=N7Y9ko5`qgT$8zPWg4dum=i1_$g???Xdt5@OoTFLY1+Y
z7@{L49Kl{f3Z!9{ooi(nIcvOCNBA)*NnuK=&nl6oThVI=Q9&IM-Q0C
zc2hsV>6!E8eUzKymPmX~{v^wf4EJTUs7EA@%ioDaT0#%S_eSRzxqdrBeW
zkB@LPW5l1cCS-&i66EY&D~;yL20>L`A>`*8;c*tEC0b!We5mkx^py+(yz+}=I=@b2
zo>;F>N?rE2gK@J8H$e~Y_br3s&A%49mFzHwLXz%lD%qUWPXVUI_=6|$_}DArb?+Z^
zJRx7OYK1Q_rC}-kil?UiB+Z^U(+`JsSWSdTe1CBKpPX>4mNG7;sNQaD?uh4Ij(mOgwE`-49Z`6~|E
zNJa?uV6yd9lq9LcGZB)TE~=S{#QP;3Rk=@vJqfhO8mevdR&GJ`c~Wp+ajF<8ZuKwo
zoKK!R$T?zV#xsUxNBqEj|2%LN2aVUL^V_5G(x?u#l6Vv=X|pW&EdJ5Y*7Or=Sf(8M
zJRwE+nwE@#g?(~X`md=tDG7TLaw*06T%P4@H4ss>Dxo};V5OiXpE#Dy&n0hJm&3AW
zx93vo-++2ZfPy-Mc$
zMfX&f_;@;cB*YKAR4);x$HNa3S|ubI{PyHUMkwokIs6W*o^a@tWM1Cw5$bTgJ4X6G
z>x&%N-WoPVm+=8@v@FtUKJ7C`&bt(~v3cr9PQ0E653ZtmkU#UJh+b*)%oa1XC!CKH
zc^!XdVcmk>wJ)L$STmz!PEQd|s*ku+OD7`3-*m0Hp*#~ML-_qJr6IfO$LEJLx#s-#
zRjLDA+fy>%9kwkeO^IJWMn;yZ+8LV?;t(4DIzpF3vLluCW-`j!BSO}-ENP)Ga&71D
zDM>4$`wb$N_{^c3Ywl=#Fsm$jy9MbOxEZny5X7|!OxE*$5}=tP{#aJV)&xf0vVqxJx8`U2n|#)oJGnN@(sn;moXpU~r#Az7
zF%;i0kpE&`WseZJGM_Konp7p`FC)ZO8x)~>OrMh-`7nl~B-w-B;>|`-UhvnAVC1b{
z-(2tgx)Dnc>n;Ii(xUh4*qQN9^?zp(Y2%vD*Kznhcl`Xfe2t#n!y{jvhl+J}io^EQ
zD}=R#5TzN5)X$HwN$H<($kWQ0&+AxGt5G_B&oc3@!F)!M8qeqvAz!UOUl%FiT6V4r
zmseQ02D?HAyNd;G&6|Mp)_U(-5Sfm=Hy1Oc$^&_H**YfW+oz<6)hQDhEU*YCBvz*R
zkJ1z$vX%D{hA&h!`}vWBP>h>j9S(Z#VLH#)_PnmUTc+tKruaR${C8Yg?ERJWW>fO5
zx%qynJ_22pS=OKpS--}zHFZBaq15h?^*-O>t_41B(m2AdPt#*$T1uH>xsX~K-V@5C
z`PE3f%L-L#gfYq-vR9msT_RIIQF8WGQ{`rTu)=PaR&EY22a>eva3!_2VbV!o@Y+do
z<$AOR(hMO@Dr&8V&ml$KZQVNf{EA7Dnk@?=^eU
zl!E(sm?I+X1BbNAs2Mfmxaqjl9CJ+bRim2iNWu&^i%*afpFCu!4W4acT+ozz0!n0v
zD&NsU8v)5hT*s!0tYwyb%vKzZ%$qPF&5Y&1KCz{jRv+{6o}N=W6aKs8l+IqT*_q&a
z_XO;uKlki=1TdI^0!*|r>Kw+p05d3lf~$binJN!IWX6xj%2EICW}|D${T)Eai@
z91Q&?wpdW!Zw#g?eFtMX7T5k!78qyX5d!W{(kRLlw*Py16g+&!`2A5=mF!_~psmudc6u`u}@q4sdS}
zpINW#f5S?A&iTPzT4`6Y#iP&%X={_CC@!1KO8ukp;e9DJUA@4fbleedsQ
z#W-ya0A!B~KG-#NRhumen_IH}om?7%uLMBd2SEM+-V{M)F)pYors*BeEPS-0$%*hZ
zy=%TB=^Q}W5Fkv=q`4gbjxI2JK7Ra&$s4^%aqTUd9RG8AgiHz`97MQ_P(~5h28dJL
zNu=kx=jP^4;s`S8M<=7E*8zl4DJWcx4}NiWhG-z>2!mlxEKhOiGV@*Wi5fqAB5ry
zDC>7XT;yIb928aBVU3dUj7gp}G&KAGs%;>A1hW6&dIOjXb0AN6kw`0w-6OUA+eVa6
zCulPfXsRvIoPHo)em6XuZ#*hc>4ab266)pHXa_mg5Jb>x2&^3tAxdg$Qcg}z
z@cD038@&KUC`%cPtR=FJ9ZBK{%oW7ZrC)R;d0g%8T?E3LS%c)s;Hj-?PYiLERTcnK
zKuWei5*E-GBdTpum;IG5I@TAC9m(b-fGa0sEPwn%5JtdKfYeJC4B09#uXFPdvo0g(KVVLj
z!V-Yb!Ns@_6Hk&1w(|XNL+m{@#DLcbq8bPY?7-3mDSsnK^lvgTnKJv&%orov=jD;H
zi3teU#(@Z=2V6^pbp~7qo(0vAix0YfRSypj2Zf%#CYX~s9rgn&X#B7`_5Q``8?t@Z
zA+wUVp>jMv;-s&r7gR~)jyKSv8t~bWaRU+b-g>)m*t>VZ@$qo-F6ot!?l|-7^ejd)
z^W+?annVvcgYbw52aJC+C-Amj(-mY+Ktx{^(5np+dzcf4(0_eZTCB}A0QKmCwif}j
z!_Wf+yRK;d&;AKL*+0eQUR8K~P{R-LC)P*fBGzuez3SoV*l*cJdqiMjNT
z5Tf-*FkA>F)fE*T9QZ6Ir!0R$d578z}5V^C-=39vEs!2d96mB#=`IJ~n{krMBSSa1&W|7R!rndtxRC*w2V
z#34E%yfp6Vm}(&9z`ra3er^OKPx)sL;a-!LL_#*uDEJNHUeRV(9P+^Ys3C?T3XkY|
zG7qpvGn-G$CNB}-2oIE%>zY|AWMpM=5STpV=n&_=B;_$c*x_~9c?k{+p-qD3-w$-6
z5eUu+;Z-0L{uSm8(gX^+Q+-Hx)X6)`WL(6T0I?zd=y3T+A4~y3$U^k$oV9|XdmKj}
zJ0z|Gkr!a5h)Ns6CfkBUh?>MbQaVhuuV24b1yCOQ7V5v97ln@qCF0GI=!UQh5ZD7C
z7S_NxJxMY(f&LR~v8pX9dM5s0!QlUJUU?s24*^fK>Tl;5dg>f0=10qT{|j-{p^_lO
ztw)>};0<8(xvGr4vrS%WQ>~K#Z~FzvpkLtKv>}6+6AI;Vv%4n;j-~(fwjH%K+lgaI
zf6E2Xk5}U!SGU2@HeZ&%SNX3yCxqrh3x=kO9M={(0{`<{fYXQobjBZ`PO!gP{RMu@
zm}bRp_qf9@mb2-uvNAG5N4oLC2BK*}dq1VaWt0NG^~0g{2Gy#dyY1w=%4ojUA0FGg?J
zZK!rV*DYXd)F7Qy
zj@=YO+5&kk;$2PM|DFgB3U~!I`$hQJlV6lKHDwYwn3dnzayha^`VD{(8bJwG1z2~F
zIIguKIQrx+qo(F&$o3HxEKnfZ0mBRlfNPzRH>CAbxm|Kt+$)t1uwKZP0$DHudja^L
zCyAt@_c4I#Sq>5W7ZFN4h%+#1|7)C|b~XWY*MblPD70_Z^UB~T)F^s_(?5Tn
zL@;a!9a-hcD;j~Loi=(#Mr_{j3zGOXezw2`7h}Ha8($b_8{N?iTLi
zmk{Wao}M1zB^uOrXn}!n8F4Z8M$8(5DB#adTv^`DlUUX51_{LfSrKJWg-1lxL-_^R
z%F*dNI5;>m@%&{3N{jTt5;tDH2WN_WJYX)e%Qmm6XqbyKP=|KM!OuW)Rou3xlS70+
zDb;SDI_Tsd4JSL?n)Ni`A}#^pBNk1^HN(SH2iS-}@_OIN>41Nk<<_kUApV=xij+vF
zD1teAKt{Z{aR~GS3xwy6c;0NMMH56257~O|J0&UOOU#hh9fU`9&2qpx=rJ5$-$K$L
z;?o@N;wP7*LkN^Bz~TA=a1QWY!ce|Fdh}@TpxBD16-dVF^uH_L17Qy$c>lZ;j2QO6
zX+CC(YtdBlWh!FzX{*rA40s};{7`e2q;sd^|;p)c*
zv9-YH9BPu>V!=e?2QypF%k67#M`~qZiJqCacSnC}9c^f#A}l+tquoAKAag@5yb4&L
z7^LWcDZFjencQw6Wh?+x(el1EO}40C(ptNUn5Rhwwe_9*_F5I1#}RPuB|2jaH^YyWdMMHMe}6a
zVI>V@2TwivYMKP!M`UdgK^+wWxArmk9f6%jc}6Tr9_kn6JG6kA8JGmLQOP&+NwKuF
zzYYS80=Z9oBu_9YpFOKdFC!tNs^C4+X+Y&7tsQ)QFQAm~jVvoZek{oos}Dpx$0_#s
zflP&~`B3vC19(ktSk45@Nnl)iDc-|C=vj8aptE&|c}@Nkx>0=qDkjuZJrfDZ!gnD5
z2F_mTkSU}J8rD6J{%1R#vT3`|zlEMWKzj;C<{c6yFUW^25S}JPn9?E~~1DA}DVW1-JN$X%vMOdn^
z1o$BxK*E~}(FJB0l#r$yl1~W;2x1^deGa8<;Hq{gpqrq1iBtK(;)?>~JCY>T`#Wpg
zi@9B{b(Sj#(+Ro?3CW$hmh@1&mXidbyAkl{ZxL+0ib{d_3huSEZD`?SeGd?C6v;zM
zfQ&^#fOqXP@Mh5XCRdq-6wPs`SxX;C2z!jAXps6KOUUMOxUVcjo1PR2ZVmutXUXw>
zUP8|j_n2d^2?qoQCkHVhJVkSJ#^u1Czl>4oT=1UXi3dt`qm+kxTL31H(`Azs7Dk6@
zG})MJg9U<~A`5vLMW4wrB~lbMoOgadeDo+!kw=mQDs}`nkAk>bfX;gS&$r=Y@&2bz
zPu@%jpf*?R4o!5sf|D#6Vpc977t+ldPEYjX!
zpxlW!{h@LEP_iQZ-28kI%!1uwUf)d5XB9vFPjsR&SIk4AI1Bddd7Yc6SFy0*zK~N}
z)c2u>i}|BpeQ;4%y+ee5E&D5%hL&%Nr0BKzg!(?y8-oFq4^5YI1iM0Z3
z3}Vo|TlEp$=F}2*wX`OwC4*>lnv1dmsOemG?-kB7^E=PhK4%K}`tBOaGmIL{=r;2r
z5g(G2wU|@eay!oA)4QZX^v~hIaW(-?chK;n6AezQUbX$ErW7weD(XPggb4ow-^Ros
zBGHqvAbXCSL>sgCNc{~5fb^BiO*6s7$dmR38nbmD+u@-c9fS@#x49XC3ymz
zhoOc~OyJb_gWI4?2dgvdJkvR`C+4W>o*0+(P49i26hGfUDa4EiC#@ocwKX>zGQJ5t
zv!d`b(+&L=`0P1P>=c&PHdUx7duvum?q{SJBbO$H9b(^KkIZ4KHM#4R;_3h3xVLAF0Lt^LI&K%wJ5Sf*`
z1NS><{a#O5Y7o}ylB6u3!eJD}r(VqeXO1MQz8t?fzC`il;~VheJg57yDYHWnOV1}_
z$cT2wsnzW>uDEzKhj}NQV@sl6Pak4x&Pwqo!h_@3H#guS=B2N*k{6vC626mJljcL_
zs|ZyRpzo1m-&bHHAJfx;s2da;E32tFVm5S_gX0UZ9U|MEX-DZ^3ZcqV|9v~+
z=14;#9k*3;M&9TzR)=0qI5sO-aqvdcKWt()cWLG#cZ8qbB`*-G+Ol!e`mAIp9OtLD
zaN1nocuoQ5`q6E+sJPr!^Cr{`b;wQ750aCYZYeQI8cTjfSB>XxOA)ZzC&Gi55G)qa
z*=bIVDOb70O{FqUEG>DHMS`p){#*FJf6_hG6FPxz3@`NF`+Rd#%YQJY@zamaMqkV9fTt&&tlrAGAxFDyR$h<+CqzYKtCs;ly1&6L}
z!++%AssOy>^5Np7cCGs=i*k;$XI|oKYA8Krj-ek(Qabi~O60cE&hPEnWF>kzuF0gB
zwREhV^)SCku3s1yMn%{mRS}e}XXoq!W8tGNvGw&|F`~o}c^V<*f^|b6_<69UrV{tp
z^hhF#59bEp9a8x(3+$bBs)8cHQ;I^m(yNnJDcy4Kl-e8?bV-maPnq4Jv}Hr?Nk8=a
zmihc#-F~rqJDv@y&$$vLOugW}sCet$vs&I4Yrj6Py)qw1d*Wb(YC_0Fg_k}3^_+9n
zN57*4QE5-p+Sj}WO5GKAg#`|8Tlik^#tovDMX{oL|IgbjA`w)+hKsye$y7n)t$Pc)
zOq}qw*4-iGu|>WZB!|~ZOx*5?eHUCMlA)*%X}kUF@;Cp}myFhDkBiCV&BVAX^B?sH
zdKgneEauMJMCB)!`QZhT%L>AkVR%yrFRsa(FQ0oT$M^Z8HqE0_X`GE@?>n;XGAaF=
zz1Q-~^P)jWB#WEVPkcrZE?I=ihiPBA9Yg7_p^}?;klAJhELN3M;
zKAwxV`hSAY8!~RwNnEC?y8Vmo^)tB-k<7Xte|2h5Y(9NuulKwATZ|N;Ql;43_pjr4
ze)_3BwU|U=cw`BY+E=&mhSP%)T$R+zt-#tmH({)bj_dHHsHc{`CsH$pv+1Or$OEpf0E?5%3-~ZAsF%q&!zMIno`AYH^zJD8iK!}Um&b4FBp~?M@be)zCs>qXFdNJ@g9?;A5P}}*KGA76H
zz!I`sV|vhsL@D%nX~-p=qwDlAJV)HEjBZ$;;oyRDc=gisAS-rxV_MRGE;lAQ@BQ|poN`s`tyGNGc}HHpXW
zhM})pu$zRQ$s}H#oDs{24aY6OoqnAEB}|I)=}sz+FK&?R_u2JdN$ceG_=#2`{2#*U
z25N2@NBg}rc9IP|P`JPqQBGq2>68J{U3qebq}C-D0@pd77@R{T{5}|p(m>b5y*>_i
zuisyIMuT(j2W|L+`zUg~&(Bd}=;E>ZJdsHj_lhc}&kMhWf3N9mxL#9l+}5CHYI-PH
z0@id_1m!br@zWX1bvfBZy+M?%LQOkI10`#JJ~de`PmYz@ijki`uM>&GMuQRb;dPy{
zdZ3zLkENRWkeX@R=gc)D`JP^-p+RGlOkuvb*Lit^QtImWP5st12nxU%A{HvGgsizm<8OJn`T<1A^SyHxb~
zlDUgUsDo&aLT8!{8mV)>{51RL3qJW4
z1}43$f!}I>SbC+Cqq0f-l*Tqd@yTI6XE?vRfuZj0T3KB!5rkq?V@X;~ETWjv9Bdz^
zIJbj!Jw2_*V3C4W#8p?w(E|^AwsPdJ+k;eLr=Rcc!y3=Tm_RvLB;%Eai;DK$h1LJL
zqK>k7B<9hFFueue$2fCp_Xl}A4$cWTQZV)Ymf#b@dvvdbmQn<>zL>~~`aT-Q`9H5b
z*(f~Q9-JDq!>e0F^B4ZzPs!D?40uyH^w-eX?d{oVLeR6VU44k>A8m53oli^iQC&uG;Ms*?{kx@2>V*yVW;iFql`JfCDZ^U!qg+JW=%Ks;r+ilUdvC#k0XuZ7;3
z%_^5M&o&aVha}X?xud`jHF@u+qvYP<{O0(>F+WRHcJNQ7e?z>KqW!H6-dn_XbS$Rj
zH>nJ>Or9RBy---)W#d0sJDTgwLC4_oqL4{_QSg=+6_(t#*s!(MqAU+k#v-$c@4~Wg
z(b8C=yrF&j`=dOG{LR}5N>i#2N_`?;6nn`Zu3u2}!kG(mu*uuJ=v`zZ*o|k5Zr!3?
zz4TMtU65|HBt11?qpjlpKxYB>PJM*+L~Kc4LT-Vm;j$~{RW@I|bzkd~X^{+BIDU^~
zou$%0no=q3I!-5(P*fi5Rbjz&$z|u7FR8OlMc~T!~
z;PLq7?DT4>n0IHRFeXC2F<4jQ#-n(XXY(qsls!tF}!y3K*H6%^n1P
zHLabKE7G#{#vLaMQ?_;}^#tX*|jjbXCogX$iho
zrROPGSSp8M+40puM%=MB6PBi0qd<}dtEtaDd6^m3R*Ph2*>=P?^W4v)5~`gtPL
z#qNy>2bvBSM?&!J6!on=r4iOyET+2`?@Q`)-b+s7yfrj5e`)TZ|n_U+=UucxyM{T2*xYVeR+f+Zl03_$G0V9;OU^A>5qrQ|HtO$M#rhvYApWstM1^IcBSm
z2J|d{omz=_%x}QonzykYAGGnrJQ#EN&;;+r(E+IHvyyW@g~O_#+93}D9*B6X$hGxF
z=F>)}K!q|RhBp@Vf^_bZ{1Wc@S?*o4;vfB#MQ(GJ)&-c&zv_#f&s=Vx*xy)Skd#?$
z<#yQ~;71ossKKzw8j)DB%nrS+kMSnWKh3yHIs9n$wx?Y4_=pQr;?KCE=Po6Y_ltDS
z*VV5q`Mp@_v&^C#9u~3?yTz&AG<(54L@c5UaY7P>?k$(
zsH!5gj5+I0TPw*w(7td}T^6z2p?R8~YBsffVQa?)2Ex>Sn*2>brM_
zR0z6WEJ(aIrvU%7jq)(UEXi<*9hv*!aOKW#o@IBpo#S5Y4OL&e
z^-0y@C<&X-hSDV7(c@9zz4|Y+p{SdKLl^-7^hBNA6-5WKEI;tGR}cQ>%1e=DWSYN(znbu{IF`#6k`QE`;g>J`)i(j0}_-;vmkquQ>#Q~>hYh)Ex-&jw=
z=1Y@Ex~zTfGZpXa!)rg={W9rWX=-z^{l4{$o%8Y($)}QqLxzvZC40O!efC4jh2auh
zGK1bSXq5*?oHpRxP!MNF;Nt9GLU+L1rs2d8sAWUdJiQ+ZQF`syJAvuLP!?)19Eimb
zNom4}gIO=R8_tsnx#hGh_vzptkKf>wo>PM^yl_E#DPy+fb6%&dea
zCd?(k)$E_)V_hyFBHX&+3f|H$!YopD>h>ftD}`T0oF#$0hO?3tARWdwtt<3g_Rra3
z?_H5U=xZ(An6LOVY;C(byyYSa_Wz$Tef&64@JdVfXHC*h&BoZX4ILJ9+ocN2W&i9y
z>$YaIp0?$g-{uu>87}5~mz~ru$xgSAa{(tAyq}uJ=j(rxHF)7qL>(?-q1Y|v?HqeI!W6Z}KS|t*EB|Hh8|((|YiOw8zM6j0Pd+~A
zuSlG{vTyTbol`jVH|vsR{KB7I*orq?dQ^6X%LIOxR*Z>Gb)V0$UoUzSw_Hy^{{8G+
z@xtMJdP-jNQu&LKywN7Cp)7flJKL^(DHpF_DdXSz%uc*FAm85EUSqD}=+Sm?C|16@
z{hWWLTKcADVF=9@Uln}wEFbxs!ekM#SPMpQP6mRThH{4;DI`lngWWBqYgzhL74c2(
zM_liopm#>CjAXOJ$aD{D1yV~5Np#wHJkpPr*HEyVNU8_6Mj9ff+bAuK?}%O!a8OuV
zU`$|sVxlOY^X_akrtOej&-()NLDRlJ@9Om}UyTb8*>0w(9;Vf+?)_q@*^-**eqRAT
z=jy0`d8)oNH#%KF!dU-*#ucS_B*-`DuMuFb5)8SgXgq@P{3_;f4tOu?wUw9aKJxhAS|TekSZ
zLv=xQl!J9Gr|kLBKU+rBEy~x5O;7LoOFFQhS_V#TXa8Gm@2%#&sjCt)^VPoR;=RwJ
zj_r>Lm{-|ujd)xnC+h2EXX)G>pIhQ%eUr_JvZ
z67zDSkGGVcpF7xDM_jamjLRIGU|x#fiiGS@B<7IOLWqO7>#b;8m!7g>ow7Vz@#pCR
zFK3cd$`=o0WlYtzR>~Z}3iCXaZJUn{MKLCYp4%0X+cV$C@h_c*Nx?QQ@luU&!Ke@
zC5*}8oFUe(lLkcHuRECp_g?k1KG%9AQ#Ug%Qnl>S_hWzK5@aXUT5UzX=j6(~JvDpI
zm1?mvi);&fG6`g5&9(R7FMb$r(MnR9-Hu((3ean8cl!!)U=d+h_Tm$lRC8
z?(k*DWoUT0tp2Kl2L*q3eeR{>FUeP?(<%hZTX}8@ABWfz@QTecCHW*X;tQ%%@9}S{ZXe`rfW8jx;oo?olKi25(D|8MxN}CAFZs)ZvA-y
zn&iv;M=wmrz4@@?*y3I=#Wm+d#MYOvl-2SnwWT;4{H`Z0_=e#+T4UW~LP$C`9Y*rsnV=9kSA`us=^E@8ksYvsyhJ>(tiq&!kH#Pw73$Kj
z7wfyk^zr=zskr$z(5KsDUt5i+h1!Qu3yC}<5|oiylog79Lb4e;oc)7ZZ$|J*$-$+t
zt66%2KRP>l3*7<(*VSfp1m>Da!u_-6Ayz3VAdMemk#W}*B6B>w(4WkFdC!I5zdDR$V&Z&f#P$*i2Yy0P
z7R9bg;}+w
z5psDbwN$*Xy0?xtyezNb1Fp7;8Q)r+u?e1!3Rjf~PNXMJ!#R7NnKbv^hGYwi+ng
z>TI27BDy-!qIKj7#W5rd@_VIbd!L^5-aBN2g0Tg)gxSnqhnorKEjR^>AvY9vb@fZC
z)n6v*P``}-79|OIp_QTmGN(CF*bpRs0f6y;cxkhvzVy=CfhOC+!x4QLJ%~
ze*?4KR&9aZRP+${)b(jA$Bw5lPY66uqLA^I!p2yE>kBZU1#u*lcM*0U8t0|V8MpYr%^?@o~g_Z
zxi=_u8V5L-7+i-<+4%l0*;s1AqUr_7n%DEK3hP%?Val{bJy_V&>PS(oBi|G49C
zPsJ&hwX+brBqU~KEj7{CDmFqdqSlx)^eQ~b4Up8@yJ6nw;*h24Ui<(*Mo{}6sX;7F`7+#kWsdhupbMKIZY
zlo@ff*%9L0Q`ApxL^}>h5QH=Q{_Ej((VD(yg^;&|=7KUDq{NkMUcA-&?hC|(WSr|V
zkQ8>B2=ef%y!iQxOj8PuN?NUP822}{RJrEw!@8soD@ehTRR_e2+~f}sWR=(~N((h#
z$0R&5Bh4N;Ja?!3YvjcAlj#AI<)=fwJ&qIS#*j1$#Ux%$kemo9D3Tz9C_R{2ySH_q
zW!`f4$GAUlg*<$gg3!Hc0~zg}q_%G}OBFdYcU_XUzGGKqYJa+8`n$&D=(4N-ZK_wW
zV~~+3^X=Z#5pZC$9%7JK>br`D8gMAX|A