diff --git a/.gitignore b/.gitignore index b1ef4047..dc2d1100 100644 --- a/.gitignore +++ b/.gitignore @@ -17,4 +17,7 @@ Makefile.coq.conf _opam -*.dot \ No newline at end of file +*.dot +docs/dependency_graph.png + +docs/dependency_graph.pre diff --git a/Makefile b/Makefile index 9a52aa2d..2d86f506 100644 --- a/Makefile +++ b/Makefile @@ -2,6 +2,8 @@ all: partial-fun logrel +autosubst: + autosubst -f -s ucoq -v ge813 -p ./theories/AutoSubst/Ast_preamble -no-static -o ./theories/AutoSubst/Ast.v ./theories/AutoSubst/Ast.sig partial-fun: @+$(MAKE) -C coq-partialfun all @@ -21,4 +23,4 @@ force _CoqProject Makefile: ; %: Makefile.coq force @+$(MAKE) -f Makefile.coq $@ -.PHONY: all clean force partial-fun logrel \ No newline at end of file +.PHONY: all clean force partial-fun logrel autosubst \ No newline at end of file diff --git a/README.md b/README.md index badfaadd..04488ba5 100644 --- a/README.md +++ b/README.md @@ -22,13 +22,12 @@ Browsing the development The development, rendered using `coqdoc`, can be [browsed online](https://coqhott.github.io/logrel-coq/). A dependency graph for the project is available [here](https://coqhott.github.io/logrel-coq/dependency_graph.png). -Syntax (re)generation -============ +Syntax regeneration +==================== -The syntax boilerplate has been generated using AutoSubst OCaml from the root folder, with the options `-s ucoq -v ge813 -no-static -p ./theories/AutoSubst/Ast_preamble` (see the [AutoSubst OCaml documentation](https://github.com/uds-psl/autosubst-ocaml) for installation instructions). Currently, this package works only with older version of Coq (8.14), so we cannot add a recipe to the MakeFile for automatically -re-generating the syntax. +For simplicity, we include the syntax file (`Ast.v`) generated using [autosubst-ocaml](https://github.com/uds-psl/autosubst-ocaml). -**If you wish to regenerate the syntax** by hand, you need to install AutoSubst from source using Coq 8.14, and use it with the previous options. +It can be re-generated using the `make autosubst` recipe, once `autosubst-ocaml` has been installed. Note that we include modified versions of the `core` and `unscoped` files, which fix their dependency inclusion. Thus, when the recipe offers to overwrite these, one should choose __not to__, and only let AutoSubst overwrite `Ast.v`. Getting started with using the development ================= diff --git a/_CoqProject b/_CoqProject index a043dab5..c4c2f315 100644 --- a/_CoqProject +++ b/_CoqProject @@ -3,23 +3,32 @@ -Q theories LogRel theories/Utils.v -theories/BasicAst.v +theories/Syntax/BasicAst.v theories/AutoSubst/core.v theories/AutoSubst/unscoped.v theories/AutoSubst/Ast.v theories/AutoSubst/Extra.v -theories/Context.v -theories/Notations.v -theories/NormalForms.v -theories/Weakening.v -theories/UntypedReduction.v -theories/UntypedValues.v -theories/GenericTyping.v +theories/Syntax/Context.v +theories/Syntax/Notations.v +theories/Syntax/TermNotations.v +theories/Syntax/NormalForms.v +theories/Syntax/Weakening.v +theories/Syntax/UntypedReduction.v +theories/Syntax/Sections.v +theories/Syntax/All.v +theories/GenericTyping.v theories/DeclarativeTyping.v -theories/DeclarativeInstance.v + +theories/TypingProperties/PropertiesDefinition.v +theories/TypingProperties/DeclarativeProperties.v +theories/TypingProperties/SubstConsequences.v +theories/TypingProperties/TypeConstructorsInj.v +theories/TypingProperties/NeutralConvProperties.v +theories/TypingProperties/NormalisationConsequences.v +theories/TypingProperties/LogRelConsequences.v theories/LogicalRelation.v theories/LogicalRelation/Induction.v @@ -39,44 +48,41 @@ theories/LogicalRelation/Application.v theories/LogicalRelation/SimpleArr.v theories/LogicalRelation/Id.v -theories/Validity.v -theories/Substitution/Irrelevance.v -theories/Substitution/Properties.v -theories/Substitution/Escape.v -theories/Substitution/Conversion.v -theories/Substitution/Reflexivity.v -theories/Substitution/Reduction.v -theories/Substitution/SingleSubst.v -theories/Substitution/Introductions/Application.v -theories/Substitution/Introductions/Universe.v -theories/Substitution/Introductions/Poly.v -theories/Substitution/Introductions/Pi.v -theories/Substitution/Introductions/Lambda.v -theories/Substitution/Introductions/SimpleArr.v -theories/Substitution/Introductions/Var.v -theories/Substitution/Introductions/Nat.v -theories/Substitution/Introductions/Empty.v -theories/Substitution/Introductions/Sigma.v -theories/Substitution/Introductions/Id.v +theories/Validity/Validity.v +theories/Validity/Irrelevance.v +theories/Validity/Properties.v +theories/Validity/Escape.v +theories/Validity/Conversion.v +theories/Validity/Reflexivity.v +theories/Validity/Reduction.v +theories/Validity/SingleSubst.v +theories/Validity/Introductions/Application.v +theories/Validity/Introductions/Universe.v +theories/Validity/Introductions/Poly.v +theories/Validity/Introductions/Pi.v +theories/Validity/Introductions/Lambda.v +theories/Validity/Introductions/SimpleArr.v +theories/Validity/Introductions/Var.v +theories/Validity/Introductions/Nat.v +theories/Validity/Introductions/Empty.v +theories/Validity/Introductions/Sigma.v +theories/Validity/Introductions/Id.v theories/Fundamental.v theories/AlgorithmicTyping.v -theories/DeclarativeSubst.v -theories/TypeConstructorsInj.v -theories/Normalisation.v -theories/Consequences.v - -theories/BundledAlgorithmicTyping.v -theories/AlgorithmicConvProperties.v -theories/AlgorithmicTypingProperties.v -theories/TypeUniqueness.v +theories/Algorithmic/UntypedAlgorithmicConversion.v +theories/Algorithmic/BundledAlgorithmicTyping.v +theories/Algorithmic/AlgorithmicConvProperties.v +theories/Algorithmic/AlgorithmicTypingProperties.v theories/Decidability/Functions.v +theories/Decidability/UntypedFunctions.v theories/Decidability/Soundness.v +theories/Decidability/NegativeSoundness.v theories/Decidability/Completeness.v theories/Decidability/Termination.v +theories/Decidability/UntypedSoundness.v +theories/Decidability/UntypedCompleteness.v theories/Decidability.v -theories/TermNotations.v -theories/Decidability/Execution.v -theories/Positivity.v +theories/Decidability/Execution.v \ No newline at end of file diff --git a/coq-partialfun b/coq-partialfun index 2caa189b..b8c22d9d 160000 --- a/coq-partialfun +++ b/coq-partialfun @@ -1 +1 @@ -Subproject commit 2caa189be95f9f70d430c6df8c58543a13f1702c +Subproject commit b8c22d9d99775f0b234c3a0d26906bef79378603 diff --git a/generate_deps.pl b/generate_deps.pl index ead6235b..931844bd 100644 --- a/generate_deps.pl +++ b/generate_deps.pl @@ -1,23 +1,33 @@ print "digraph logrel_deps {\n"; -print " node [shape = ellipse,style=filled];\n"; +# See here for color schemes: https://graphviz.org/doc/info/colors.html +print " node [shape = ellipse,style=filled,colorscheme = paired12];\n"; print " subgraph cluster_autosubst { label=\"AutoSubst\" \n}"; +print " subgraph cluster_syntax { label=\"Syntax\" \n}"; print " subgraph cluster_logrel { label=\"LogicalRelation\" \n}"; print " subgraph cluster_subst { label=\"Validity\" \n}"; +print " subgraph cluster_typing { label=\"Typing Properties\" \n}"; +print " subgraph cluster_algo { label=\"Algorithmic\" \n}"; print " subgraph cluster_dec { label=\"Decidability\" \n}"; while (<>) { if (m/.*?theories\/([^\s]*)\.vo.*:(.*)/) { $dests = $2 ; ($path,$src) = ($1 =~ s/\//\./rg =~ m/(.*\.)?([^.]*)$/); if ($path =~ m/AutoSubst\./) { - print "subgraph cluster_autosubst { \"$path$src\"[label=\"$src\",fillcolor=firebrick]}" + print "subgraph cluster_autosubst { \"$path$src\"[label=\"$src\",fillcolor=1]}" + }elsif ($path =~ m/Syntax\./) { + print "subgraph cluster_syntax { \"$path$src\"[label=\"$src\",fillcolor=2,fontcolor=white]}" }elsif ($path =~ m/LogicalRelation\./) { - print "subgraph cluster_logrel { \"$path$src\"[label=\"$src\",fillcolor=forestgreen]}" - }elsif ($path =~ m/Substitution\./) { - print "subgraph cluster_subst { \"$path$src\"[label=\"$src\",fillcolor=goldenrod1]}" + print "subgraph cluster_logrel { \"$path$src\"[label=\"$src\",fillcolor=3]}" + }elsif ($path =~ m/Validity\./) { + print "subgraph cluster_subst { \"$path$src\"[label=\"$src\",fillcolor=4,fontcolor=white]}" + }elsif ($path =~ m/TypingProperties\./) { + print "subgraph cluster_typing { \"$path$src\"[label=\"$src\",fillcolor=5]}" + }elsif ($path =~ m/Algorithmic\./) { + print "subgraph cluster_algo { \"$path$src\"[label=\"$src\",fillcolor=9]}" }elsif ($path =~ m/Decidability\./) { - print "subgraph cluster_dec { \"$path$src\"[label=\"$src\",fillcolor=deeppink3]}" + print "subgraph cluster_dec { \"$path$src\"[label=\"$src\",fillcolor=10,fontcolor=white]}" }else { - print "\"$path$src\"[label=\"$src\",fillcolor=dodgerblue1]" + print "\"$path$src\"[label=\"$src\",fillcolor=6,fontcolor=white]" } for my $dest (split(" ", $dests)) { $dest =~ s/\//\./g ; diff --git a/opam b/opam index f96e436c..7d500fae 100644 --- a/opam +++ b/opam @@ -1,5 +1,5 @@ opam-version: "2.0" -version: "8.19.dev" +version: "8.20.dev" maintainer: "Meven.Bertrand@univ-nantes.fr" dev-repo: "git+https://github.com/CoqHott/logrel-coq.git" bug-reports: "https://github.com/CoqHott/logrel-coq/issues" @@ -8,6 +8,8 @@ authors: ["Meven Lennon-Bertrand " "Kenji Maillard " "Pierre-Marie Pédrot " ] +homepage: "https://github.com/CoqHott/logrel-coq" +synopsis:"A formalisation of meta-theory for a dependent type system, in Coq" license: "MIT" depends: [ "coq" { >= "8.20" & < "8.21~" } diff --git a/theories/AlgorithmicConvProperties.v b/theories/Algorithmic/AlgorithmicConvProperties.v similarity index 70% rename from theories/AlgorithmicConvProperties.v rename to theories/Algorithmic/AlgorithmicConvProperties.v index bb5f73fc..c8415fc4 100644 --- a/theories/AlgorithmicConvProperties.v +++ b/theories/Algorithmic/AlgorithmicConvProperties.v @@ -1,12 +1,246 @@ (** * LogRel.AlgorithmicConvProperties: properties of algorithmic conversion. *) -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening UntypedReduction - GenericTyping DeclarativeTyping DeclarativeInstance AlgorithmicTyping DeclarativeSubst TypeConstructorsInj Normalisation BundledAlgorithmicTyping Fundamental. -From LogRel.LogicalRelation Require Import Escape. -From LogRel.Substitution Require Import Properties Escape. +From LogRel Require Import Utils Sections Syntax.All GenericTyping DeclarativeTyping AlgorithmicTyping. +From LogRel.TypingProperties Require Import DeclarativeProperties PropertiesDefinition SubstConsequences TypeConstructorsInj NeutralConvProperties. +From LogRel.Algorithmic Require Import BundledAlgorithmicTyping. +Import DeclarativeTypingProperties AlgorithmicTypingData. -Import AlgorithmicTypingData BundledTypingData DeclarativeTypingProperties. +(** ** Stability of algorithmic conversion by type/term expansion *) + + Lemma algo_conv_ty_expand Γ A A' B B': + [A ⤳* A'] -> [B ⤳* B'] -> [Γ |-[al] A' ≅ B'] -> [Γ |-[al] A ≅ B]. + Proof. + intros ?? Hconv. + inversion Hconv ; subst ; clear Hconv ; refold. + econstructor ; [..|eassumption]. + all: now etransitivity. + Qed. + + Lemma algo_conv_tm_expand Γ A A' t t' u u': + [A ⤳* A'] -> [t ⤳* t'] -> [u ⤳* u'] -> [Γ |-[al] t' ≅ u' : A'] -> [Γ |-[al] t ≅ u : A]. + Proof. + intros ??? Hconv. + inversion Hconv ; subst ; clear Hconv ; refold. + econstructor ; [..|eassumption]. + all: now etransitivity. + Qed. + + (** ** Strengthening *) + (** Removing unused variables from a context*) + +Section ConvStr. + + Let PTyEq (Γ : context) (A B : term) := forall Δ (ρ : Γ ≤ Δ) A' B', + A = A'⟨ρ⟩ -> B = B'⟨ρ⟩ -> + [Δ |- A' ≅ B']. + Let PTyRedEq (Γ : context) (A B : term) := forall Δ (ρ : Γ ≤ Δ) A' B', + A = A'⟨ρ⟩ -> B = B'⟨ρ⟩ -> + [Δ |- A' ≅h B']. + Let PNeEq (Γ : context) (A t u : term) := forall Δ (ρ : Γ ≤ Δ) t' u', + t = t'⟨ρ⟩ -> u = u'⟨ρ⟩ -> + ∑ A', A = A'⟨ρ⟩ × [Δ |- t' ~ u' ▹ A']. + Let PNeRedEq (Γ : context) (A t u : term) := forall Δ (ρ : Γ ≤ Δ) t' u', + t = t'⟨ρ⟩ -> u = u'⟨ρ⟩ -> + ∑ A', A = A'⟨ρ⟩ × [Δ |- t' ~h u' ▹ A']. + Let PTmEq (Γ : context) (A t u : term) := forall Δ (ρ : Γ ≤ Δ) t' u' A', + A = A'⟨ρ⟩ -> t = t'⟨ρ⟩ -> u = u'⟨ρ⟩ -> + [Δ |- t' ≅ u' : A']. + Let PTmRedEq (Γ : context) (A t u : term) := forall Δ (ρ : Γ ≤ Δ) t' u' A', + A = A'⟨ρ⟩ -> t = t'⟨ρ⟩ -> u = u'⟨ρ⟩ -> + [Δ |- t' ≅h u' : A']. + + #[local] Ltac push_renaming := + repeat match goal with + | eq : _ = ?t⟨_⟩ |- _ => + destruct t ; cbn in * ; try solve [congruence] ; + inversion eq ; subst ; clear eq + end. + + Theorem algo_conv_str : + AlgoConvInductionConcl PTyEq PTyRedEq + PNeEq PNeRedEq PTmEq PTmRedEq. + Proof. + subst PTyEq PTyRedEq PNeEq PNeRedEq PTmEq PTmRedEq. + apply AlgoConvInduction. + - intros * Hred Hred' ? IH * -> ->. + eapply credalg_str in Hred as [? [->]], Hred' as [? [->]]. + econstructor ; tea. + now eapply IH. + - intros * ? IHA ? IHB ? **. + push_renaming. + econstructor. + + now eapply IHA. + + now eapply IHB with(ρ := wk_up _ ρ). + - intros ; push_renaming. + econstructor. + - intros ; push_renaming. + now econstructor. + - intros ; push_renaming. + now econstructor. + - intros * ? IHA ? IHB ? * ??. + push_renaming. + econstructor. + + now eapply IHA. + + now eapply IHB with (ρ := wk_up _ ρ). + - intros * ? IHA ? IHa ? IHa' **. + push_renaming. + econstructor. + + eapply IHA ; reflexivity. + + eapply IHa ; reflexivity. + + eapply IHa' ; reflexivity. + - intros * ?? ? IH ** ; subst. + edestruct IH as [? [->]]. + 1-2 : reflexivity. + econstructor ; tea. + all: now eapply whne_ren. + - intros * Hin **. + push_renaming. + apply in_ctx_str in Hin as [? [-> ]]. + eexists ; split. + 1: reflexivity. + eapply section_inj in H1 as ->. + 2: eapply section_wk. + now econstructor. + - intros * ? IHm ? IHt **. + push_renaming. + edestruct IHm as [? []]. + 1-2: reflexivity. + push_renaming. + eexists ; split. + 2: econstructor ; tea. + 2: eapply IHt. + 2-4: reflexivity. + now bsimpl. + - intros * ? IHn ? IHP ? IHz ? IHs **. + push_renaming. + edestruct IHn as [? []]. + 1-2: reflexivity. + push_renaming. + eexists ; split ; cycle -1. + 1: econstructor ; tea. + + eapply IHP with (ρ := wk_up tNat ρ). + all: reflexivity. + + eapply IHz. + 2-3: reflexivity. + now bsimpl. + + eapply IHs. + 2-3: reflexivity. + unfold elimSuccHypTy ; cbn. + now bsimpl. + + now bsimpl. + - intros * ? IHn ? IHP **. + push_renaming. + edestruct IHn as [? []]. + 1-2: reflexivity. + push_renaming. + eexists ; split ; cycle -1. + 1: econstructor ; tea. + + eapply IHP with (ρ := wk_up tEmpty ρ). + all: reflexivity. + + now bsimpl. + - intros * ? IHm **. + push_renaming. + edestruct IHm as [? []]. + 1-2: reflexivity. + push_renaming. + eexists ; split. + 2: econstructor ; tea. + reflexivity. + - intros * ? IHm **. + push_renaming. + edestruct IHm as [? []]. + 1-2: reflexivity. + push_renaming. + eexists ; split. + 2: econstructor ; tea. + now bsimpl. + - intros * ? IHn ? IHP ? IHe **. + push_renaming. + edestruct IHn as [? []]. + 1-2: reflexivity. + push_renaming. + eexists ; split ; cycle -1. + 1: econstructor ; tea. + + unshelve eapply IHP. + * unshelve eexists. + 1: exact (_wk_up (_wk_up ρ)). + evar (A : term) ; replace (tId _ _ _) with A ; subst A. + 1: do 2 eapply well_up ; eauto. + now bsimpl. + * reflexivity. + * reflexivity. + + eapply IHe. + 2-3: reflexivity. + now bsimpl. + + now bsimpl. + - intros * ? IH red ** ; subst. + edestruct IH as [? []]. + 1-2: reflexivity. + subst. + eapply credalg_str in red as [? [-> ]]. + eexists ; split ; [reflexivity|..]. + econstructor ; tea. + now eapply whnf_ren. + - intros * red red' red'' ? IH * -> -> ->. + eapply credalg_str in red as [? [->]], red' as [? [->]], red'' as [? [->]]. + now econstructor. + - intros * ? IHA ? IHB **. + push_renaming. + econstructor. + + eapply IHA ; reflexivity. + + eapply IHB with (ρ := wk_up _ ρ). + all: reflexivity. + - intros ; push_renaming. + econstructor. + - intros ; push_renaming. + econstructor. + - intros * ? IH **. + push_renaming. + econstructor. + eapply IH. + all: reflexivity. + - intros ; push_renaming. + econstructor. + - intros * ?? ? IH **. + subst. + push_renaming. + econstructor. + 1-2: now eapply whnf_ren. + eapply IH with (ρ := wk_up _ ρ). + all: now bsimpl. + - intros * ? IHA ? IHB **. + push_renaming. + econstructor. + + eapply IHA ; reflexivity. + + eapply IHB with (ρ := wk_up _ ρ). + all: reflexivity. + - intros * ?? ? IHf ? IHs **. + subst. + push_renaming. + econstructor. + 1-2: now eapply whnf_ren. + + eapply IHf ; reflexivity. + + eapply IHs. + 2-3: reflexivity. + now bsimpl. + - intros * ? IHA ? IHa ? IHa' **. + push_renaming. + econstructor. + + eapply IHA ; reflexivity. + + eapply IHa ; reflexivity. + + eapply IHa' ; reflexivity. + - intros **. + push_renaming. + now econstructor. + - intros * ? IH **. + subst. + edestruct IH as [? [-> ]]. + 1-2: reflexivity. + econstructor ; tea. + now eapply isPosType_ren. + Qed. + +End ConvStr. (** ** Stability of algorithmic conversion by context and type change *) @@ -14,6 +248,7 @@ Import AlgorithmicTypingData BundledTypingData DeclarativeTypingProperties. ones, algorithmic conversion still holds, possibly with a different output type (when there is one). *) Section AlgoConvConv. + Context `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)}. Lemma in_ctx_conv_r Γ' Γ n decl : [|-[de] Γ' ≅ Γ] -> @@ -66,12 +301,12 @@ Section AlgoConvConv. ∑ A', [Γ' |-[al] t ~ u ▹ A'] × [Γ' |-[de] A' ≅ A]. Let PNeRedEq' (Γ : context) (A t u : term) := forall Γ', [|-[de] Γ' ≅ Γ] -> - ∑ A', [× [Γ' |-[al] t ~h u ▹ A'], [Γ' |-[de] A' ≅ A] & isType A']. + ∑ A', [× [Γ' |-[al] t ~h u ▹ A'], isType A' & [Γ' |-[de] A' ≅ A]]. Let PTmEq' (Γ : context) (A t u : term) := forall Γ' A', [|-[de] Γ' ≅ Γ] -> [Γ' |-[de] A ≅ A'] -> [Γ' |-[al] t ≅ u : A']. Let PTmRedEq' (Γ : context) (A t u : term) := forall Γ' A', - [|-[de] Γ' ≅ Γ] -> [Γ' |-[de] A ≅ A'] -> isType A' -> + [|-[de] Γ' ≅ Γ] -> isType A' -> [Γ' |-[de] A ≅ A'] -> [Γ' |-[al] t ≅h u : A']. Theorem bundled_conv_conv : @@ -106,7 +341,7 @@ Section AlgoConvConv. - intros * ? ihA ? ihx ? ihy ? h **. econstructor; [now eapply ihA| eapply ihx | eapply ihy]; tea. 1,2: eapply stability; tea; now eapply lrefl. - - intros * ? IHM **. + - intros * ?? ? IHM **. edestruct IHM as [[? []]] ; tea. now econstructor. - intros * HΓ **. @@ -115,9 +350,7 @@ Section AlgoConvConv. 1: now econstructor. eassumption. - intros * ? IHm Ht [IHt []%boundary] **. - edestruct IHm as [[? [? (?&?&[HconvP HconvA])%red_ty_compl_prod_r]] ?] ; tea. - eapply redty_red, red_whnf in HconvP as ->. - 2: gen_typing. + edestruct IHm as [[? [?? (?&?&[->])%conv_prod_r]] ?] ; tea. eexists ; split. + econstructor ; tea. now eapply IHt. @@ -125,19 +358,12 @@ Section AlgoConvConv. econstructor. now eapply stability. - intros * ? IHn ? IHP ? IHz ? IHs **. - edestruct IHn as [[A []][]] ; tea. - replace A with tNat in *. - 2:{ - symmetry. - apply red_whnf. - 2: gen_typing. - now eapply redty_red, red_ty_compl_nat_r. - } + edestruct IHn as [[? [?? ->%conv_nat_r]][]] ; tea. eexists ; split. 1: econstructor. + eauto. + eapply IHP. - now econstructor. + econstructor ; tea ; do 2 econstructor ; boundary. + eapply IHz ; tea. econstructor. eapply stability ; tea. @@ -154,51 +380,58 @@ Section AlgoConvConv. eapply typing_subst1. all: now boundary. - intros * ? IHe ? IHP **. - edestruct IHe as [[A []][]] ; tea. - replace A with tEmpty in *. - 2:{ - symmetry. - apply red_whnf. - 2: gen_typing. - now eapply redty_red, red_ty_compl_empty_r. - } + edestruct IHe as [[? [?? ->%conv_empty_r]][]] ; tea. eexists ; split. 1: econstructor. + eauto. + eapply IHP. - now econstructor. + econstructor ; tea ; do 2 econstructor ; boundary. + econstructor. destruct IHP. eapply stability ; tea. eapply typing_subst1. all: now boundary. - - intros * ? [ih [? ihm ihn]] ? hm hn ??. - edestruct ih as [?[? [?[?[r] ]]%red_ty_compl_sig_r isTy]]; tea. - pose proof (redty_whnf r (isType_whnf _ isTy)); subst. + - intros * ? [ih [? ihm ihn]] [hm hn] ??. + edestruct ih as [?[?? [?[? [->] ]]%conv_sig_r]]; tea. eexists; split; tea; now econstructor. - intros * ? [ih [? ihm ihn]] **. - edestruct ih as [?[? [?[?[r] ]]%red_ty_compl_sig_r isTy]]; tea. - pose proof (redty_whnf r (isType_whnf _ isTy)); subst. + edestruct ih as [?[?? [?[? [->] ]]%conv_sig_r]]; tea. eexists; split. 1: now econstructor. - eapply typing_subst1. 2: now symmetry. - eapply TermConv; refold; [|now symmetry]. - econstructor; eapply lrefl. - now eapply stability. - - intros * ? [ih [? ihm ihn]] ? [ihA] ? [ihx] ? [ihP] ? [ihhr] ? [ihy] ? hm hn **. - edestruct ih as [? [? [?[?[?[red]]]]%red_ty_compl_id_r isTy]]; tea. - pose proof hm as [? hm']. - eapply stability in hm' as [? [[-> ]]]%termGen'; tea. - pose proof (redty_whnf red (isType_whnf _ isTy)); subst. - assert [Γ' |-[de] A ≅ A] by (eapply stability; tea; now eapply lrefl). - assert [Γ' |-[de] x ≅ x : A] by (eapply stability; tea; now eapply lrefl). - assert [|- (Γ',, A),, tId A⟨@wk1 Γ' A⟩ x⟨@wk1 Γ' A⟩ (tRel 0) ≅ (Γ,, A),, tId A⟨@wk1 Γ A⟩ x⟨@wk1 Γ A⟩ (tRel 0)]. - 1: eapply idElimMotiveCtxConv; first [now econstructor| now symmetry| boundary]. - assert [Γ' |-[ de ] P[tRefl A x .: x..] ≅ P[tRefl A x .: x..]]. - 1: eapply TypeRefl; refold; now boundary. + eapply typing_subst1 ; tea. + do 3 econstructor. + 1: eapply stability ; boundary. + symmetry. + econstructor ; tea. + boundary. + - intros * ? [ih [? ihm ihn]] ? [ihP] ? [ihhr] [hm hn] **. + assert (well_typed (ta := de) Γ' (tIdElim A x P hr y e)) as hm' + by (edestruct hm ; eexists ; now eapply stability). + assert (well_typed (ta := de) Γ' (tIdElim A' x' P' hr' y' e')) as hn' + by (edestruct hn ; eexists ; now eapply stability). + edestruct ih as (?&[[? ihe]%dup]) ; tea. + pose proof hm' as [? [? [[] ]]%termGen']. + pose proof hn' as [? [? [[] ]]%termGen']. + eapply algo_conv_sound in ihe as []. + 2-3: now eexists. + epose proof (idElimConv hm' hn') as (?&?&?&[]) ; tea ; subst. + 1: gen_typing. eexists; split. 1: econstructor; tea; eauto. - eapply TypeRefl; refold; now boundary. + + eapply ihP. + symmetry. + eapply idElimMotiveCtxConv ; tea. + * econstructor. boundary. + * now econstructor. + + eapply ihhr ; tea. + econstructor. + eapply typing_subst2 ; tea. + 1: boundary. + eapply typing_meta_conv. + 1: econstructor ; boundary. + cbn. + now bsimpl. + + eapply TypeRefl; refold; now boundary. - intros * ? IHm **. edestruct IHm as [[A'' []] []]; tea. assert [Γ' |-[de] A' ≅ A''] as HconvA'. @@ -206,7 +439,7 @@ Section AlgoConvConv. eapply conv_red_l ; tea. now symmetry. } - pose proof HconvA' as [? []]%red_ty_complete. + pose proof HconvA' as [? []]%red_ty_complete_l. 2:{ eapply type_isType ; tea. now boundary. @@ -216,21 +449,19 @@ Section AlgoConvConv. 1: eauto. 1: now eapply redty_red. gen_typing. + + eassumption. + symmetry ; etransitivity ; tea. now eapply RedConvTyC. - + eassumption. - - intros * ? ? ? []%algo_conv_wh IH ? ? ? ? A'' **. + - intros * ? ? ? []%algo_conv_wh IH [] ? A'' **. assert [Γ' |-[de] A' ≅ A''] as HconvA' by now eapply conv_red_l. - pose proof HconvA' as [? []]%red_ty_complete ; tea. + pose proof HconvA' as [? []]%red_ty_complete_l ; tea. econstructor ; tea. 1: now eapply redty_red. eapply IH ; tea. etransitivity ; tea. now eapply RedConvTyC. - - intros * ? [IHA HconvA] ? IHB ? ? ? * ? HconvU ?. - eapply red_ty_compl_univ_l, redty_red, red_whnf in HconvU as ->. - 2: gen_typing. + - intros * ? [IHA HconvA] ? IHB ? ? ? * ? ? ->%conv_univ_l ; tea. econstructor. + eapply IHA ; tea. do 2 econstructor. @@ -246,81 +477,47 @@ Section AlgoConvConv. all: econstructor ; tea. econstructor. all: gen_typing. - - intros. - replace A' with U. - 2:{ - symmetry. - eapply red_whnf. - 2: gen_typing. - now eapply redty_red, red_ty_compl_univ_l. - } + - intros * ??? * ?? ->%conv_univ_l ; tea. now econstructor. - - intros. - replace A' with tNat. - 2:{ - symmetry. - eapply red_whnf. - 2: gen_typing. - now eapply redty_red, red_ty_compl_nat_l. - } + - intros * ??? * ?? ->%conv_nat_l ; tea. now econstructor. - - intros * ? IH **. - replace A' with tNat. - 2:{ - symmetry. - eapply red_whnf. - 2: gen_typing. - now eapply redty_red, red_ty_compl_nat_l. - } + - intros * ? IH [] * ?? ->%conv_nat_l ; tea. econstructor. eapply IH ; tea. - now do 2 econstructor. - - intros * ? IH **. - replace A' with U. - 2:{ - symmetry. - eapply red_whnf. - 2: gen_typing. - now eapply redty_red, red_ty_compl_univ_l. - } + do 2 econstructor ; boundary. + - intros * ??? * ?? ->%conv_univ_l ; tea. now econstructor. - - intros * ? ? ? IHf ? ? ? * ? (?&?&[HconvP])%red_ty_compl_prod_l ?. - eapply redty_red, red_whnf in HconvP as ->. - 2: gen_typing. + - intros * ? ? ? IHf ? ? ? * ? ? (?&?&[->])%conv_prod_l ; tea. econstructor ; tea. eapply IHf ; tea. - now econstructor. - - intros * ? [ihA] ? [ihB] ?????? r%red_ty_compl_univ_l wh%isType_whnf. - pose proof (redty_whnf r wh); subst. + now econstructor. + - intros * ? [ihA] ? [ihB] [] * ?? ->%conv_univ_l ; tea. econstructor. - 1: eapply ihA; tea; gen_typing. - assert [ |-[ de ] Γ',, A ≅ Γ,, A]. 1:{ - econstructor; tea; eapply stability; tea. - eapply lrefl; now econstructor. - } + + eapply ihA ; tea. + do 2 econstructor ; boundary. + + assert [ |-[ de ] Γ',, A ≅ Γ,, A]. + { + econstructor; tea; eapply stability; tea. + eapply lrefl; now econstructor. + } eapply ihB; tea. do 2 constructor; boundary. - - intros * ??? [ihA] ? [ihB] ?????? [?[?[r]]]%red_ty_compl_sig_l wh%isType_whnf. - pose proof (redty_whnf r wh); subst. + - intros * ??? [ihA] ? [ihB] [] * ?? [?[?[->]]]%conv_sig_l ; tea. econstructor; tea. 1: eapply ihA; tea; now symmetry. eapply ihB; tea. eapply typing_subst1; tea. - eapply TermConv; refold; [|now symmetry]. - eapply TermRefl, stability; tea. - now econstructor. - - intros * ? [ihA] ? [ihx] ? [ihy] ? hm ? * ? r%red_ty_compl_univ_l wh%isType_whnf. - pose proof (redty_whnf r wh); subst. + do 2 econstructor. + now eapply stability. + - intros * ? [ihA] ? [ihx] ? [ihy] ? * ? ? ->%conv_univ_l ; tea. assert [Γ' |-[de] A ≅ A] by (eapply stability; tea; eapply lrefl; now econstructor). econstructor; tea. + eapply ihA; tea; constructor; eapply stability; tea; now boundary. + eapply ihx; tea. + eapply ihy; tea. - - intros * ? [ihA] ? [ihx] ??? * ? [?[?[? [r]]]]%red_ty_compl_id_l wh%isType_whnf. - pose proof (redty_whnf r wh); subst. - econstructor; tea; eauto. - eapply ihx; tea; eapply stability; tea; now eapply lrefl. - - intros * ? IHm HtyP ? ? ? * ? HconvN HtyA'. + - intros * ??? * ? ? [?[?[? [->]]]]%conv_id_l ; tea. + now econstructor. + - intros * ? IHm HtyP ? ? ? * ? HtyA' HconvN. edestruct IHm as [[? []] ?] ; tea. unshelve eapply ty_conv_inj in HconvN. 1: now gen_typing. @@ -335,20 +532,20 @@ Section AlgoConvConv. Let PTyRedEq (Γ : context) (A B : term) := True. Let PNeEq (Γ : context) (A t u : term) := forall Γ', [|-[de] Γ' ≅ Γ] -> - (well_typed Γ t) -> - (well_typed Γ u) -> + (well_typed (ta := de) Γ t) -> + (well_typed (ta := de) Γ u) -> ∑ A', [Γ' |-[al] t ~ u ▹ A'] × [Γ' |-[de] A' ≅ A]. Let PNeRedEq (Γ : context) (A t u : term) := forall Γ', [|-[de] Γ' ≅ Γ] -> - (well_typed Γ t) -> - (well_typed Γ u) -> - ∑ A', [× [Γ' |-[al] t ~h u ▹ A'], [Γ' |-[de] A' ≅ A] & isType A']. + (well_typed (ta := de) Γ t) -> + (well_typed (ta := de) Γ u) -> + ∑ A', [× [Γ' |-[al] t ~h u ▹ A'], isType A' & [Γ' |-[de] A' ≅ A]]. Let PTmEq (Γ : context) (A t u : term) := forall Γ' A', [|-[de] Γ' ≅ Γ] -> [Γ' |-[de] A ≅ A'] -> [Γ |-[de] t : A] -> [Γ |-[de] u : A ] -> [Γ' |-[al] t ≅ u : A']. Let PTmRedEq (Γ : context) (A t u : term) := forall Γ' A', - [|-[de] Γ' ≅ Γ] -> [Γ' |-[de] A ≅ A'] -> isType A' -> + [|-[de] Γ' ≅ Γ] -> isType A' -> [Γ' |-[de] A ≅ A'] -> [Γ |-[de] t : A] -> [Γ |-[de] u : A ] -> [Γ' |-[al] t ≅h u : A']. @@ -372,6 +569,7 @@ End AlgoConvConv. (** ** Lifting of algorithmic conversion from terms at the universe to types *) Section TermTypeConv. + Context `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)}. Let PTyEq (Γ : context) (A B : term) := True. Let PNeEq (Γ : context) (A t u : term) := True. @@ -402,8 +600,9 @@ Section TermTypeConv. congruence. - intros; congruence. - intros; congruence. - - intros. - now econstructor. + - intros * H. + econstructor ; tea. + all: now apply algo_conv_wh in H. Qed. End TermTypeConv. @@ -411,6 +610,7 @@ End TermTypeConv. (** ** Symmetry *) Section Symmetry. + Context `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)}. Let PTyEq (Γ : context) (A B : term) := forall Δ, [|-[de] Γ ≅ Δ] -> @@ -456,7 +656,7 @@ Section Symmetry. eapply ihB. econstructor; tea. now eapply ihA. - - intros * ? ihA ? [ihx] ? [ihy] ? [? []]%id_ty_inv [? []]%id_ty_inv * ?. + - intros * ? ihA ? [ihx] ? [ihy] [[]%id_ty_inv []%id_ty_inv] * ?. econstructor. + now eapply ihA. + eapply algo_conv_conv. @@ -477,7 +677,7 @@ Section Symmetry. eapply wfTermConv; refold; tea. now symmetry. * now eapply stability. - - intros * ? IHM **. + - intros * ?? ? IHM **. edestruct IHM as [[U' [IHM' HconvM]] []] ; tea. now econstructor. - intros * HΓ **. @@ -486,10 +686,12 @@ Section Symmetry. 1: now econstructor. now eapply stability. - intros * ? IHm ? [IHt Hwft] **. - edestruct IHm as [[? [IHm' Hconv]] []] ; tea ; clear IHm. - eapply red_ty_compl_prod_l in Hconv as (?&?&[Hred]). - eapply redty_red, red_whnf in Hred as ->. - 2: now eapply algo_conv_wh in IHm' as [] ; gen_typing. + edestruct IHm as [[? [IHm' (?&?&[->])%conv_prod_l]] []] ; tea ; clear IHm. + 2:{ + eapply type_isType. + 1: boundary. + now eapply algo_conv_wh in IHm' as []. + } eexists ; split. + econstructor. 1: eassumption. @@ -509,14 +711,18 @@ Section Symmetry. eapply stability ; tea. now symmetry. - intros * ? IHn ? IHP ? IHz ? IHs **. - edestruct IHn as [[? [IHn' Hconv]] []] ; tea ; clear IHn. - eapply red_ty_compl_nat_l, redty_red, red_whnf in Hconv as ->. - 2: now eapply algo_conv_wh in IHn' as [] ; gen_typing. + edestruct IHn as [[? [IHn' ->%conv_nat_l]] []] ; tea ; clear IHn. + 2:{ + eapply type_isType. + 1: boundary. + now eapply algo_conv_wh in IHn' as []. + } eexists ; split. 1: econstructor ; tea. + eapply IHP. econstructor ; tea. - now do 2 econstructor. + econstructor. + boundary. + eapply algo_conv_conv. * now eapply IHz. * now eapply conv_ctx_refl_r. @@ -524,7 +730,8 @@ Section Symmetry. 2: now symmetry. eapply typing_subst1. 2: eapply IHP. - now do 2 econstructor. + do 2 econstructor. + boundary. * eapply stability. 2: now symmetry. destruct IHz. @@ -540,7 +747,7 @@ Section Symmetry. 2: now symmetry. destruct IHP. eapply elimSuccHypTy_conv ; tea. - now boundary. + all: now boundary. * eapply stability. 2: now symmetry. destruct IHs. @@ -556,16 +763,21 @@ Section Symmetry. 1: now eapply IHP. symmetry. econstructor ; tea. - now do 2 econstructor. + do 2 econstructor. + boundary. - intros * ? IHe ? IHP **. - edestruct IHe as [[? [IHe' Hconv]] []] ; tea ; clear IHe. - eapply red_ty_compl_empty_l, redty_whnf in Hconv as ->. - 2: now eapply algo_conv_wh in IHe' as [] ; gen_typing. + edestruct IHe as [[? [IHe' ->%conv_empty_l]] []] ; tea ; clear IHe. + 2:{ + eapply type_isType. + 1: boundary. + now eapply algo_conv_wh in IHe' as []. + } eexists ; split. 1: econstructor ; tea. + eapply IHP. econstructor ; tea. - now do 2 econstructor. + do 2 econstructor. + boundary. + eapply (typing_subst1 _). * eapply stability ; tea. now symmetry. @@ -573,57 +785,76 @@ Section Symmetry. 1: now eapply IHP. symmetry. econstructor ; tea. - now do 2 econstructor. - - intros * ? [ih []] ?????. - edestruct ih as [? [hconv [?[?[r%redty_whnf]]]%red_ty_compl_sig_l]]; tea; subst. - 2: now apply algo_conv_wh in hconv as []. + do 2 econstructor. + boundary. + - intros * ? [ih []] **. + edestruct ih as [? [hconv (?&?&[])%conv_sig_l]]; tea; subst. + 2:{ + eapply type_isType. + 1: boundary. + now eapply algo_conv_wh in hconv as []. + } eexists; split. 1: now econstructor. now symmetry. - - intros * ? [ih []] ?????. - edestruct ih as [? [hconv [?[?[r%redty_whnf]]]%red_ty_compl_sig_l]]; tea; subst. - 2: now apply algo_conv_wh in hconv as []. + - intros * ? [ih []] **. + edestruct ih as [? [hconv (?&?&[])%conv_sig_l]]; tea; subst. + 2:{ + eapply type_isType. + 1: boundary. + now eapply algo_conv_wh in hconv as []. + } eexists; split. 1: now econstructor. eapply typing_subst1; tea. - eapply TermConv; refold; [|now symmetry]. - eapply stability; [now econstructor|now symmetry]. - - intros * ? [ihe [? ihme]] ? [ihA] ? [ihx] ? [ihP] ? [ihhr] ? [ihy] ? hm hn * ?. - edestruct ihe as [? [hconv [? [? [? [r%redty_whnf]]]]%red_ty_compl_id_l]]; tea; subst. - 2: now apply algo_conv_wh in hconv as []. + econstructor. + now eapply stability. + - intros * ? [ihe [? ihme]] ? [ihP] ? [ihhr] [hm hn] * ?. + edestruct ihe as [? [[hconv hconv']%dup]] ; tea; subst. + destruct hm as [? [? [? [[->] ]]%termGen']%dup]. + destruct hn as [? [? [? [[->] ]]%termGen']%dup]. + eapply algo_conv_sound in hconv' as []. + 2-3: now eexists ; eapply stability. + epose proof (idElimConv (e := e) (e' := e')) as (?&?&?&[]) ; tea. + 1-2: eexists ; eapply stability ; tea ; now symmetry. + 1: now symmetry. + now eapply algo_conv_wh in hconv as []. + subst. + eassert [(Δ,, A'),, tId A'⟨wk1 A'⟩ x'⟨wk1 A'⟩ (tRel 0) |-[ al ] P' ≅ P]. + { + eapply ihP. + eapply idElimMotiveCtxConv; tea. + * now symmetry. + * now symmetry. + * symmetry ; now econstructor. + } eexists; split. 1: econstructor; tea. - + now eapply ihA. - + eapply algo_conv_conv. - * now eapply ihx. - * now eapply conv_ctx_refl_r. - * now eapply stability. - * eapply stability; [| now symmetry]; now boundary. - * eapply stability; [| now symmetry]; now boundary. - + eapply ihP; symmetry. - eapply idElimMotiveCtxConv; tea; eapply idElimMotiveCtx; tea; try boundary. - all: eapply stability; [|now symmetry]; try boundary. - econstructor; tea; now boundary. + eapply algo_conv_conv. * now eapply ihhr. * now eapply conv_ctx_refl_r. - * eapply stability; tea;[| now symmetry]. - eapply typing_subst2; tea. - cbn; rewrite 2!wk1_ren_on, 2!shift_subst_eq; now econstructor. - * eapply stability; [| now symmetry]; now boundary. - * eapply stability; [| now symmetry]; now boundary. - + eapply algo_conv_conv. - * now eapply ihy. - * now eapply conv_ctx_refl_r. - * now eapply stability. + * eapply typing_subst2; tea. + 1: boundary. + all: cycle -1. + -- eapply stability ; tea. + eapply idElimMotiveCtxConv ; tea. + all: econstructor. + all: boundary. + -- eapply convtm_meta_conv. + 1: econstructor. + 4: reflexivity. + 1-2: eassumption. + cbn; rewrite 2!wk1_ren_on, 2!shift_one_eq; now econstructor. * eapply stability; [| now symmetry]; now boundary. * eapply stability; [| now symmetry]; now boundary. + eapply stability; tea;[| now symmetry]. eapply typing_subst2; tea. - cbn; rewrite 2!wk1_ren_on, 2!shift_subst_eq; tea. + 1: boundary. + 1: now eapply stability. + cbn; rewrite 2!wk1_ren_on, 2!shift_one_eq; tea. econstructor; tea. - eapply ihme. - now destruct hm as [? [? [[]]]%termGen']. + symmetry. + now econstructor. - intros * ? IHm **. edestruct IHm as [[A'' [IHm' Hconv]] [Hwf]] ; tea ; clear IHm. assert [Δ |-[de] A' ≅ A''] as Hconv'. @@ -635,7 +866,7 @@ Section Symmetry. 2: now symmetry. boundary. } - pose proof Hconv' as [? []]%red_ty_complete. + pose proof Hconv' as [? []]%red_ty_complete_l. 2: now eapply type_isType ; boundary. eexists ; split. + econstructor. @@ -658,8 +889,8 @@ Section Symmetry. - intros * ? IH **. econstructor. now eapply IH. - - now econstructor. - - intros * ? ? ? IH ? Hf **. + - now econstructor. + - intros * ? ? ? IH [Hf] **. econstructor. 1-2: assumption. eapply IH. @@ -671,7 +902,7 @@ Section Symmetry. 1: now eapply ihA. eapply ihB; econstructor; tea. econstructor; now eapply ihA. - - intros * ??? [ihFst] ? [ihSnd] ? ihp ihq **. + - intros * ??? [ihFst] ? [ihSnd] [ihp ihq] **. econstructor; tea. 1: now eapply ihFst. assert [Δ |-[ de ] B[(tFst p)..] ≅ B[(tFst q)..]]. 1:{ @@ -689,7 +920,7 @@ Section Symmetry. 2,3: now symmetry. now econstructor. * eapply stability; [now econstructor| now symmetry]. - - intros * ? [ihA] ? [ihx] ? [ihy] ? [? [[->]]]%termGen' [? [[->]]]%termGen' * ?. + - intros * ? [ihA] ? [ihx] ? [ihy] [[? [[->]]]%termGen' [? [[->]]]%termGen'] * ?. econstructor. + now eapply ihA. + eapply algo_conv_conv. @@ -711,17 +942,7 @@ Section Symmetry. eapply wfTermConv; refold; tea. econstructor; now symmetry. * now eapply stability. - - intros* ? [ihA] ? [ihx] ? [? [[->]]]%termGen' [? [[->]]]%termGen' * ?. - econstructor. - + now eapply ihA. - + eapply algo_conv_conv. - * now eapply ihx. - * now eapply conv_ctx_refl_r. - * eapply stability; tea; now symmetry. - * eapply stability; [|now symmetry]. - econstructor; tea. - now symmetry. - * now eapply stability. + - econstructor. - intros * ? IH **. edestruct IH as [[? []] []] ; tea. now econstructor. @@ -732,6 +953,7 @@ End Symmetry. (** ** Transitivity *) Section Transitivity. + Context `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)}. Let PTyEq (Γ : context) (A B : term) := forall Δ C, [|-[de] Γ ≅ Δ] -> @@ -770,8 +992,8 @@ Section Transitivity. assert (A'0 = B') as ->. { eapply whred_det ; tea. - - eapply algo_conv_wh in H7 as [] ; gen_typing. - - eapply algo_conv_wh in Hconv as [] ; gen_typing. + - eapply algo_conv_wh in H5 as [] ; gen_typing. + - eapply algo_conv_wh in Hconv as [] ; gen_typing. } econstructor ; tea. eapply IH ; tea. @@ -785,16 +1007,16 @@ Section Transitivity. + eapply IHA ; tea. + eapply IHB ; tea. now econstructor. - - intros * ? ? _ * ? Hconv. + - intros * [_] * ? Hconv. inversion Hconv ; subst ; clear Hconv. 2:{ apply algo_conv_wh in H2 as [e _]. now inversion e. } now constructor. - - intros * ? ? _ * ? Hconv. + - intros * [_] * ? Hconv. inversion Hconv ; subst ; refold. 1: now constructor. eapply algo_conv_wh in H2 as [e _]. now inversion e. - - intros * ? ? _ * ? Hconv. + - intros * [_] * ? Hconv. inversion Hconv ; subst ; clear Hconv. 2:{ apply algo_conv_wh in H2 as [e _]. now inversion e. } now constructor. @@ -815,11 +1037,11 @@ Section Transitivity. + now eapply ihA. + eapply ihx; tea; now symmetry. + eapply ihy; tea; now symmetry. - - intros * ? IH ? ? ? * ? Hconv. + - intros * ?? ? IH ? ? ? * ? Hconv. inversion Hconv ; subst ; clear Hconv ; refold; cycle -1. - 1:econstructor; now eapply IH. - all: apply algo_conv_wh in H as [_ e] ; now inversion e. - - intros * Hin ? _ _ * ? Hconv. + 1: econstructor ; tea ; now eapply IH. + all: apply algo_conv_wh in H1 as [_ e] ; now inversion e. + - intros * Hin [_] * ? Hconv. inversion Hconv ; subst ; clear Hconv ; refold. split. + now econstructor. @@ -829,7 +1051,7 @@ Section Transitivity. now subst. - intros * ? IHm ? IHt ? ? ? * ? Hconv. inversion Hconv ; subst ; clear Hconv ; refold. - eapply IHm in H9 as [? []%prod_ty_inj] ; tea. + eapply IHm in H7 as [? []%prod_ty_inj] ; tea. split. + econstructor ; tea. now eapply IHt. @@ -839,64 +1061,70 @@ Section Transitivity. now symmetry. - intros * ? IHn ? IHP ? IHz ? IHs ? ? ? * ? Hconv. inversion Hconv ; subst ; clear Hconv ; refold. - eapply IHn in H13 as [? _] ; tea. + eapply IHn in H11 as [? _] ; tea. split. + econstructor ; tea. * eapply IHP ; tea. econstructor ; tea. - now do 2 econstructor. + do 2 econstructor. + boundary. * eapply IHz ; tea. symmetry. eapply typing_subst1. 2: eapply IHP. - now do 2 econstructor. + do 2 econstructor. + boundary. * eapply IHs ; tea. symmetry. destruct IHP. eapply elimSuccHypTy_conv ; tea. - now boundary. + all: now boundary. + eapply typing_subst1 ; tea. 1: eapply IHn. eapply IHP. - intros * ? IHe ? IHP ? ? ? ? * ? Hconv. inversion Hconv ; subst ; clear Hconv ; refold. - eapply IHe in H9 as [? _] ; tea. + eapply IHe in H7 as [? _] ; tea. split. + econstructor ; tea. eapply IHP ; tea. econstructor ; tea. - now do 2 econstructor. + do 2 econstructor. + boundary. + eapply typing_subst1 ; tea. 1: eapply IHe. eapply IHP. - - intros * ? [ih []] ??????? hconv. + - intros * ? [ih []] [] * ? hconv. inversion hconv; subst; clear hconv; refold. edestruct ih as [? []%sig_ty_inj]; tea. split; [now econstructor|now symmetry]. - - intros * ? [ih []] ??????? hconv. + - intros * ? [ih []] [] * ? hconv. inversion hconv; subst; clear hconv; refold. edestruct ih as [? []%sig_ty_inj]; tea. split; [now econstructor|]. eapply typing_subst1; tea. - eapply TermConv; refold; [now econstructor|now symmetry]. - - intros * ? [ihe [? ihme]] ? [ihA] ? [ihx] ? [ihP] ? [ihhr] ? [ihy] ? hm ? * ? hconv. + now econstructor. + - intros * hconve [ihe [? ihme]] ? [ihP] ? [ihhr] [hm hn] * ? hconv. inversion hconv; subst; clear hconv; refold. edestruct ihe as [? []%id_ty_inj]; tea. + eapply algo_conv_sound in hconve as []. + 2: edestruct hm as [? [? [[-> ]]]%termGen'] ; now eexists. + 2: edestruct hn as [? [? [[-> ]]]%termGen'] ; now eexists. + epose proof (idElimConv hm hn) as (?&?&?&[]) ; tea. + 1: eapply TypeRefl ; refold ; boundary. + now econstructor. split. + econstructor; tea; eauto. - * eapply ihx; tea; now symmetry. * eapply ihP; tea; symmetry. - eapply idElimMotiveCtxConv; tea; eapply idElimMotiveCtx. - 3,4: eapply stability;[|now symmetry]. - 4: econstructor; tea. - all: boundary. + eapply idElimMotiveCtxConv ; tea ; eapply idElimMotiveCtx. * eapply ihhr; tea; symmetry. eapply typing_subst2; tea. - cbn; rewrite 2!wk1_ren_on, 2!shift_subst_eq. + 1: boundary. + cbn; rewrite 2!wk1_ren_on, 2!shift_one_eq. now econstructor. - * eapply ihy; tea; now symmetry. + eapply typing_subst2; tea. - cbn; rewrite 2!wk1_ren_on, 2!shift_subst_eq. + 1: boundary. + cbn; rewrite 2!wk1_ren_on, 2!shift_one_eq. econstructor; tea. eapply ihme. now pose proof hm as [? [? [[]]]%termGen']. @@ -912,7 +1140,7 @@ Section Transitivity. - intros * ? ? Hu Ht' IHt ? ? ? * ? HconvA Hconv. inversion Hconv ; subst ; clear Hconv ; refold. eapply whred_det in Hu ; tea. - 2,3: now eapply algo_conv_wh in H8 as [], Ht' as []. + 2,3: now eapply algo_conv_wh in H6 as [], Ht' as []. subst. econstructor ; tea. eapply IHt ; tea. @@ -920,17 +1148,17 @@ Section Transitivity. 1: symmetry. 1,3: eapply RedConvTyC, subject_reduction_type ; tea ; boundary. eassumption. - - intros * ? [IHA HpostA] ? IHB ? ? ? ? A'' ? HΓ Hconvty Hconv. + - intros * ? [IHA HpostA] ? IHB [] ? A'' ? HΓ Hconvty Hconv. replace A'' with U in *. 2:{ eapply algo_conv_wh in Hconv as []. symmetry. eapply red_whnf. 2: gen_typing. - now eapply red_ty_compl_univ_r, redty_red in Hconvty. + now eapply red_compl_univ_r, redty_red in Hconvty. } inversion Hconv ; subst ; clear Hconv ; refold. - 2: inversion H4. + 2: now inversion H1. econstructor. 1: now eapply IHA. eapply IHB. @@ -940,55 +1168,55 @@ Section Transitivity. * now symmetry in HΓ ; boundary. * econstructor. boundary. - - intros * ? ? _ ? A' ? ? Hconvty Hconv. + - intros * [_] ? A' ? ? Hconvty Hconv. replace A' with U in *. 2:{ eapply algo_conv_wh in Hconv as []. symmetry. eapply red_whnf. 2: gen_typing. - now eapply red_ty_compl_univ_r, redty_red in Hconvty. + now eapply red_compl_univ_r, redty_red in Hconvty. } inversion Hconv ; subst ; clear Hconv ; refold. + now econstructor. - + inversion H2. - - intros * ?? _ ? A' ? ? Hconvty Hconv. + + inversion H0. + - intros * [_] ? A' ? ? Hconvty Hconv. replace A' with tNat in *. 2:{ eapply algo_conv_wh in Hconv as []. symmetry. eapply red_whnf. 2: gen_typing. - now eapply red_ty_compl_nat_r, redty_red in Hconvty. + now eapply red_compl_nat_r, redty_red in Hconvty. } inversion Hconv ; subst ; clear Hconv ; refold. - 2: now inversion H2. + 2: now inversion H0. now econstructor. - - intros * ? IHt ??? ? A' ? ? Hconvty Hconv. + - intros * ? IHt [] ? A' ? ? Hconvty Hconv. replace A' with tNat in *. 2:{ eapply algo_conv_wh in Hconv as []. symmetry. eapply red_whnf. 2: gen_typing. - now eapply red_ty_compl_nat_r, redty_red in Hconvty. + now eapply red_compl_nat_r, redty_red in Hconvty. } inversion Hconv ; subst ; clear Hconv ; refold. - 2: now inversion H4. + 2: now inversion H1. now econstructor. - - intros * ? IHt _ ? A' ? ? Hconvty Hconv. + - intros * [] ? A' ? ? Hconvty Hconv. replace A' with U in *. 2:{ eapply algo_conv_wh in Hconv as []. symmetry. eapply red_whnf. 2: gen_typing. - now eapply red_ty_compl_univ_r, redty_red in Hconvty. - } + now eapply red_compl_univ_r, redty_red in Hconvty. + } inversion Hconv ; subst ; clear Hconv ; refold. - 2: now inversion H1. + 2: now inversion H0. now econstructor. - - intros * ? ? ? IH ? ? ? * ? h Hconv. + - intros * ? ? ? IH [] * ? h Hconv. inversion Hconv ; subst ; clear Hconv ; refold. all: try match goal with H : isPosType _ |- _ => destruct H end. all: try solve [now unshelve eapply ty_conv_inj in h ; [econstructor | econstructor | cbn in *]]. @@ -996,17 +1224,17 @@ Section Transitivity. econstructor ; tea. eapply IH ; tea. now econstructor. - - intros * ? [IHA HpostA] ? IHB ? ? ? ? A'' ? HΓ Hconvty Hconv. + - intros * ? [IHA HpostA] ? IHB [] ? A'' ? HΓ Hconvty Hconv. replace A'' with U in *. 2:{ eapply algo_conv_wh in Hconv as []. symmetry. eapply red_whnf. 2: gen_typing. - now eapply red_ty_compl_univ_r, redty_red in Hconvty. + now eapply red_compl_univ_r, redty_red in Hconvty. } inversion Hconv ; subst ; clear Hconv ; refold. - 2: inversion H4. + 2: inversion H1. econstructor. 1: now eapply IHA. eapply IHB. @@ -1016,7 +1244,7 @@ Section Transitivity. * now symmetry in HΓ ; boundary. * econstructor. boundary. - - intros * ? ? ? [ihFst] ? ihSnd ? ? ????? h Hconv. + - intros * ? ? ? [ihFst] ? ihSnd [] * ? h Hconv. inversion Hconv ; subst ; clear Hconv ; refold. all: try match goal with H : isPosType _ |- _ => destruct H end. all: try solve [now unshelve eapply ty_conv_inj in h ; [econstructor | econstructor | cbn in *]]. @@ -1025,22 +1253,21 @@ Section Transitivity. 1: eapply ihFst ; tea; now econstructor. eapply ihSnd; tea. eapply typing_subst1; tea. - now symmetry. - - intros * ? [ihA] ? [ihx] ? [ihy] ??? * ? r%red_ty_compl_univ_r hconv. + symmetry. + now econstructor. + - intros * ? [ihA] ? [ihx] ? [ihy] ??? * ? r%red_compl_univ_r hconv. inversion hconv; subst; clear hconv. 1,2: unshelve epose proof (redty_whnf r _); try constructor; congruence. - 2: refold; apply algo_conv_wh in H6 as [? _]; inv_whne. + 2: refold; apply algo_conv_wh in H4 as [? _]; inv_whne. econstructor; tea. * eapply ihA; tea; do 2 econstructor; boundary. * eapply ihx; tea; econstructor; now symmetry. * eapply ihy; tea; econstructor; now symmetry. - - intros * ? [ihA] ? [ihx] ??? * ? [? [? [? [r]]]]%red_ty_compl_id_r hconv. + - intros * ??? * ? [? [? [? [r]]]]%red_compl_id_r hconv. inversion hconv; subst; clear hconv; refold. 1,2: unshelve epose proof (redty_whnf r _); try constructor; congruence. - 2: refold; apply algo_conv_wh in H5 as [? _]; inv_whne. + 2: refold; apply algo_conv_wh in H1 as [? _]; inv_whne. econstructor. - * now eapply ihA. - * eapply ihx; tea; now symmetry. - intros * Hnconv IH ? ? ? ? * ? h Hconv. inversion Hconv ; subst ; clear Hconv ; refold. 1-5,7,9,10: now inversion Hnconv. @@ -1054,6 +1281,8 @@ End Transitivity. (** ** Instances *) +Import BundledTypingData. + Module AlgorithmicConvProperties. Export AlgorithmicTypingData. @@ -1062,7 +1291,9 @@ Module AlgorithmicConvProperties. repeat match goal with | H : context [bn] |- _ => destruct H end ; econstructor ; try assumption. - #[export, refine] Instance ConvTypeAlgProperties : ConvTypeProperties (ta := bn) := {}. + #[export, refine] Instance ConvTypeAlgProperties + `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} : + ConvTypeProperties (ta := bn) := {}. Proof. 2: split. - intros_bn. @@ -1082,10 +1313,7 @@ Module AlgorithmicConvProperties. now apply algo_conv_wk. - intros_bn. 1-2: now eapply algo_typing_sound. - inversion bun_conv_ty ; subst ; clear bun_conv_ty. - econstructor. - 1-2: now etransitivity. - eassumption. + now eapply algo_conv_ty_expand. - intros_bn. 1-2: now econstructor. do 2 econstructor. @@ -1117,7 +1345,9 @@ Module AlgorithmicConvProperties. now econstructor. Qed. - #[export, refine] Instance ConvTermAlgProperties : ConvTermProperties (ta := bn) := {}. + #[export, refine] Instance ConvTermAlgProperties + `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} : + ConvTermProperties (ta := bn) := {}. Proof. 1: split. - red ; intros_bn. @@ -1138,16 +1368,10 @@ Qed. - intros_bn. 1-3: now apply typing_wk. now apply algo_conv_wk. - - intros *; intros HRt HRu _ _ _ _; revert HRt HRu. intros_bn. - all: eapply algo_typing_sound in bun_inf_conv_inf0, bun_inf_conv_inf ; tea. - + gen_typing. - + gen_typing. - + inversion bun_conv_tm ; subst ; clear bun_conv_tm. - econstructor. - * eassumption. - * now etransitivity. - * now etransitivity. - * eassumption. + - intros_bn. + 1-2: now eapply inf_conv_decl. + eapply algo_conv_tm_expand ; tea. + reflexivity. - intros_bn. + boundary. + eapply algo_conv_sound in bun_conv_ne_conv as [[]%boundary] ; tea. @@ -1230,7 +1454,9 @@ Qed. now econstructor. Qed. - #[export, refine] Instance ConvNeuAlgProperties : ConvNeuProperties (ta := bn) := {}. + #[export, refine] Instance ConvNeuAlgProperties + `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} : + ConvNeuProperties (ta := bn) := {}. Proof. 1: split. - intros ? ? []. @@ -1275,7 +1501,7 @@ Qed. + now econstructor. + eassumption. - intros * - [? ? ? ? ? ? Hf (?&?&[])%red_ty_compl_prod_r] + [? ? ? ? ? ? Hf (?&?&[])%red_compl_prod_r] [? ? ? ? Ht]. econstructor ; tea. + eapply algo_conv_sound in Hf as [Hf] ; tea. @@ -1324,7 +1550,7 @@ Qed. + econstructor ; tea. econstructor ; tea. 2: now econstructor. - now eapply redty_red, red_ty_compl_nat_r. + now eapply redty_red, red_compl_nat_r. + econstructor. eapply typing_subst1 ; tea. eapply algo_conv_sound in bun_conv_ne_conv as [Hconv _]; tea. @@ -1346,14 +1572,14 @@ Qed. + econstructor ; tea. econstructor ; tea. 2: now econstructor. - now eapply redty_red, red_ty_compl_empty_r. + now eapply redty_red, red_compl_empty_r. + econstructor. eapply typing_subst1 ; tea. eapply algo_conv_sound in bun_conv_ne_conv as [Hconv _]; tea. eapply boundary in Hconv as []. now econstructor. - intros * []. - pose proof bun_conv_ne_conv_conv as [?[?[]]]%red_ty_compl_sig_r. + pose proof bun_conv_ne_conv_conv as [?[?[]]]%red_compl_sig_r. econstructor; tea. + eexists. econstructor; tea. @@ -1371,7 +1597,7 @@ Qed. 2: constructor. now eapply redty_red. - intros * []. - pose proof bun_conv_ne_conv_conv as [?[?[]]]%red_ty_compl_sig_r. + pose proof bun_conv_ne_conv_conv as [?[?[]]]%red_compl_sig_r. econstructor; tea. + eexists. econstructor; tea. @@ -1388,15 +1614,13 @@ Qed. + do 2 econstructor; tea. 2: constructor. now eapply redty_red. - + eapply typing_subst1. - 2: now symmetry. + + eapply typing_subst1 ; tea. apply algo_conv_sound in bun_conv_ne_conv as []; tea. econstructor; eapply lrefl. eapply TermConv; tea; refold. etransitivity; tea. symmetry; econstructor; tea. - 1: boundary. - now symmetry. + boundary. - intros * tyA tyx convA convx convP convhr convy [?????? conve conv]. pose proof convA as ?%bn_conv_sound. pose proof convx as ?%bn_conv_sound. @@ -1413,12 +1637,9 @@ Qed. * eapply stability; [boundary|]. eapply idElimMotiveCtxConv; tea. 1: now eapply ctx_refl. - 1,2: eapply idElimMotiveCtx. - 4: econstructor; tea. - all: boundary. * econstructor; [now boundary|]. eapply typing_subst2; tea. - cbn ; rewrite 2!wk1_ren_on, 2! shift_subst_eq. + cbn ; rewrite 2!wk1_ren_on, 2! shift_one_eq. now econstructor. * econstructor; tea; boundary. * apply algo_conv_sound in conve as [? ]; tea. @@ -1426,12 +1647,12 @@ Qed. etransitivity; tea. econstructor; tea. + destruct convA, convx, convP, convhr, convy. - pose proof conv as [?[?[?[[]]]]]%red_ty_compl_id_r. + pose proof conv as [?[?[?[[]]]]]%red_compl_id_r. econstructor; tea. econstructor; constructor + tea. + eapply TypeRefl; refold; eapply typing_subst2; tea. all: try boundary. - cbn; rewrite 2!wk1_ren_on, 2!shift_subst_eq. + cbn; rewrite 2!wk1_ren_on, 2!shift_one_eq. apply algo_conv_sound in conve as [? ]; tea. econstructor; [boundary|]; tea. Qed. @@ -1455,7 +1676,9 @@ Module IntermediateTypingProperties. all: unfold_bni ; gen_typing. Qed. - #[export, refine] Instance TypingIntProperties : TypingProperties (ta := bni) := {}. + #[export, refine] Instance TypingIntProperties + `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} : + TypingProperties (ta := bni) := {}. Proof. all: unfold_bni. - gen_typing. @@ -1485,7 +1708,9 @@ Module IntermediateTypingProperties. now eapply algo_conv_sound in bun_conv_ty. Qed. - #[export, refine] Instance ConvTypeIntProperties : ConvTypeProperties (ta := bni) := {}. + #[export, refine] Instance ConvTypeIntProperties + `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} : + ConvTypeProperties (ta := bni) := {}. Proof. all: unfold_bni. - gen_typing. @@ -1495,10 +1720,7 @@ Module IntermediateTypingProperties. now split. - intros * [] [] [] ; econstructor. 1-3: eassumption. - inversion bun_conv_ty ; subst ; clear bun_conv_ty ; refold. - econstructor. - 3: eassumption. - 1-2: now etransitivity. + now eapply algo_conv_ty_expand. - intros ? ?. split. 2-3: econstructor. @@ -1527,7 +1749,9 @@ Module IntermediateTypingProperties. - intros. gen_typing. Qed. - #[export, refine] Instance ConvTermIntProperties : ConvTermProperties (ta := bni) := {}. + #[export, refine] Instance ConvTermIntProperties + `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} : + ConvTermProperties (ta := bni) := {}. Proof. all: unfold_bni. - gen_typing. @@ -1537,10 +1761,8 @@ Module IntermediateTypingProperties. now econstructor. - intros * [] [] _ _ _ _ []. econstructor ; tea. - + inversion bun_conv_tm ; subst ; clear bun_conv_tm ; refold. - econstructor. - 4: eassumption. - all: now etransitivity. + eapply algo_conv_tm_expand ; tea. + reflexivity. - gen_typing. - intros * ? [] []. split ; tea. @@ -1596,7 +1818,9 @@ Module IntermediateTypingProperties. - intros. gen_typing. Qed. - #[export, refine] Instance ConvNeuIntProperties : ConvNeuProperties (ta := bni) := {}. + #[export, refine] Instance ConvNeuIntProperties + `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} : + ConvNeuProperties (ta := bni) := {}. Proof. all: unfold_bni. - gen_typing. @@ -1636,12 +1860,9 @@ Module IntermediateTypingProperties. * eapply stability; [boundary|]. eapply idElimMotiveCtxConv; tea. 1: now eapply ctx_refl. - 1,2: eapply idElimMotiveCtx. - 4: econstructor; tea. - all: boundary. * econstructor; [now boundary|]. eapply typing_subst2; tea. - cbn ; rewrite 2!wk1_ren_on, 2! shift_subst_eq. + cbn ; rewrite 2!wk1_ren_on, 2! shift_one_eq. now econstructor. * econstructor; tea; boundary. * apply algo_conv_sound in conve as [? ]; tea. @@ -1649,17 +1870,18 @@ Module IntermediateTypingProperties. etransitivity; tea. econstructor; tea. + destruct convA, convx, convP, convhr, convy. - pose proof conv as [?[?[?[[]]]]]%red_ty_compl_id_r. + pose proof conv as [?[?[?[[]]]]]%red_compl_id_r. econstructor; tea. econstructor; constructor + tea. + eapply TypeRefl; refold; eapply typing_subst2; tea. all: try boundary. - cbn; rewrite 2!wk1_ren_on, 2!shift_subst_eq. + cbn; rewrite 2!wk1_ren_on, 2!shift_one_eq. apply algo_conv_sound in conve as [? ]; tea. econstructor; [boundary|]; tea. Qed. - #[export, refine] Instance RedTermIntProperties : + #[export, refine] Instance RedTermIntProperties + `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} : RedTermProperties (ta := bni) := {}. Proof. all: unfold_bni. @@ -1764,7 +1986,8 @@ Module IntermediateTypingProperties. now etransitivity. Qed. - #[export, refine] Instance RedTypeIntProperties : + #[export, refine] Instance RedTypeIntProperties + `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} : RedTypeProperties (ta := bni) := {}. Proof. all: unfold_bni. @@ -1789,19 +2012,8 @@ Module IntermediateTypingProperties. now etransitivity. Qed. - #[export] Instance IntermediateTypingProperties : GenericTypingProperties bni _ _ _ _ _ _ _ _ _ _ := {}. - -End IntermediateTypingProperties. - -(** ** Consequence: Completeness of algorithmic conversion *) - -(** We use the intermediate instance derived above, and the fundamental lemma. *) - -Import BundledIntermediateData IntermediateTypingProperties. + #[export] Instance IntermediateTypingProperties + `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} : + GenericTypingProperties bni _ _ _ _ _ _ _ _ _ _ := {}. -Lemma algo_conv_complete Γ A B : - [Γ |-[de] A ≅ B] -> - [Γ |-[al] A ≅ B]. -Proof. - now intros [HΓ ? _ []%(escapeEq (ta := bni))]%Fundamental. -Qed. \ No newline at end of file +End IntermediateTypingProperties. \ No newline at end of file diff --git a/theories/AlgorithmicTypingProperties.v b/theories/Algorithmic/AlgorithmicTypingProperties.v similarity index 71% rename from theories/AlgorithmicTypingProperties.v rename to theories/Algorithmic/AlgorithmicTypingProperties.v index ee46baa5..a780fc3d 100644 --- a/theories/AlgorithmicTypingProperties.v +++ b/theories/Algorithmic/AlgorithmicTypingProperties.v @@ -1,10 +1,9 @@ (** * LogRel.AlgorithmicTypingProperties: properties of algorithmic typing. *) -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening UntypedReduction - GenericTyping DeclarativeTyping DeclarativeInstance AlgorithmicTyping DeclarativeSubst TypeConstructorsInj BundledAlgorithmicTyping AlgorithmicConvProperties. -From LogRel Require Import LogicalRelation Validity Fundamental. -From LogRel.LogicalRelation Require Import Escape. -From LogRel.Substitution Require Import Properties Escape. +From LogRel Require Import Syntax.All GenericTyping DeclarativeTyping AlgorithmicTyping. +From LogRel.TypingProperties Require Import PropertiesDefinition DeclarativeProperties SubstConsequences TypeConstructorsInj NeutralConvProperties. +From LogRel.Algorithmic Require Import BundledAlgorithmicTyping AlgorithmicConvProperties. + +From LogRel Require Import Utils. Import DeclarativeTypingProperties AlgorithmicTypingData BundledTypingData. @@ -15,7 +14,9 @@ while in the definition of algorithmic typing we only allow it when A is a non-c type (in which case it has to be small). So we need to show admissibility of the more general rule. *) -Lemma algo_typing_small_large Γ A : +Lemma algo_typing_small_large + `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} + Γ A : [Γ |-[bn] A : U] -> [Γ |-[bn] A]. Proof. @@ -30,13 +31,14 @@ Proof. eapply H. 2: reflexivity. do 2 (econstructor ; tea). - now eapply redty_red, red_ty_compl_univ_r. + now eapply redty_red, red_compl_univ_r. } eapply BundledTypingInduction. all: try solve [ econstructor | - intros; econstructor; [intros Hcan; inversion Hcan| econstructor;[now econstructor|now eapply redty_red, red_ty_compl_univ_r]]| + intros; econstructor; [intros Hcan; inversion Hcan| econstructor;[now econstructor|now eapply redty_red, red_compl_univ_r]]| intros; match goal with H : [_ |- _ ≅ _] |- _ => unshelve eapply ty_conv_inj in H; try now econstructor; now cbn in H end ]. + - intros * ? [IH] **; subst. eapply IH. eapply subject_reduction_type ; tea. @@ -57,7 +59,9 @@ Module AlgorithmicTypingProperties. repeat match goal with | H : context [bn] |- _ => destruct H end ; econstructor ; try assumption. - #[export, refine] Instance WfCtxAlgProperties : WfContextProperties (ta := bn) := {}. + #[export, refine] Instance WfCtxAlgProperties + `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} : + WfContextProperties (ta := bn) := {}. Proof. 1-8: intros_bn. - now do 2 constructor. @@ -65,16 +69,20 @@ Module AlgorithmicTypingProperties. now apply algo_typing_sound. Qed. - #[export, refine] Instance WfTypeAlgProperties : WfTypeProperties (ta := bn) := {}. + #[export, refine] Instance WfTypeAlgProperties + `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} `{!ConvComplete (ta := de) (ta' := al)}: + WfTypeProperties (ta := bn) := {}. Proof. all: cycle -1. 1: intros; now eapply algo_typing_small_large. 1: intros_bn; now eapply algo_typing_wk. 1-3: intros_bn; now econstructor. - intros_bn; econstructor; tea; econstructor; tea; now eapply algo_conv_complete. + intros_bn; econstructor; tea; econstructor ; tea; now eapply ty_conv_compl. Qed. - #[export, refine] Instance TypingAlgProperties : TypingProperties (ta := bn) := {}. + #[export, refine] Instance TypingAlgProperties + `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} `{!ConvComplete (ta := de) (ta' := al)}: + TypingProperties (ta := bn) := {}. Proof. - intros_bn. + now eapply algo_typing_wk. @@ -85,18 +93,18 @@ Module AlgorithmicTypingProperties. now eapply in_ctx_wf. - intros_bn. + do 2 econstructor ; tea. - all: now eapply (redty_red (ta := de)), red_ty_compl_univ_r. + all: now eapply (redty_red (ta := de)), red_compl_univ_r. + now do 2 econstructor. - intros_bn. + now econstructor. + econstructor ; tea. 2: econstructor. all: boundary. - - intros * [? ? ? (?&?&[])%red_ty_compl_prod_r] []. + - intros * [? ? ? (?&?&[])%red_compl_prod_r] []. esplit ; tea. + do 2 econstructor ; tea. 1: now eapply (redty_red (ta := de)). - eapply algo_conv_complete. + eapply ty_conv_compl. now etransitivity. + eapply typing_subst1 ; tea. econstructor. @@ -109,16 +117,16 @@ Module AlgorithmicTypingProperties. now do 2 econstructor. - intros_bn. + do 2 econstructor ; tea. - now eapply (redty_red (ta := de)), red_ty_compl_nat_r. + now eapply (redty_red (ta := de)), red_compl_nat_r. + now do 2 econstructor. - intros_bn. 1: econstructor ; tea. + econstructor ; tea. - now eapply (redty_red (ta := de)), red_ty_compl_nat_r. + now eapply (redty_red (ta := de)), red_compl_nat_r. + econstructor ; tea. - now eapply algo_conv_complete. + now eapply ty_conv_compl. + econstructor ; tea. - now eapply algo_conv_complete. + now eapply ty_conv_compl. + econstructor. eapply typing_subst1. 1: eauto using inf_conv_decl. @@ -129,43 +137,43 @@ Module AlgorithmicTypingProperties. - intros_bn. 1: econstructor ; tea. + econstructor ; tea. - now eapply (redty_red (ta := de)), red_ty_compl_empty_r. + now eapply (redty_red (ta := de)), red_compl_empty_r. + econstructor. eapply typing_subst1. 1: eauto using inf_conv_decl. now eapply algo_typing_sound. - intros_bn. 1: do 2 econstructor; tea. - 1,2: now eapply (redty_red (ta:=de)), red_ty_compl_univ_r. + 1,2: now eapply (redty_red (ta:=de)), red_compl_univ_r. gen_typing. - intros_bn. - 1: do 2 (econstructor; tea); now eapply algo_conv_complete. + 1: do 2 (econstructor; tea); now eapply ty_conv_compl. econstructor. 2,3: eapply TypeRefl; refold. 1,2: boundary. now eapply algo_typing_sound. - intros * []. - pose proof bun_inf_conv_conv as [?[?[]]]%red_ty_compl_sig_r . + pose proof bun_inf_conv_conv as [?[?[]]]%red_compl_sig_r . econstructor; tea. do 2 econstructor; tea; now eapply (redty_red (ta:=de)). - intros * []. - pose proof bun_inf_conv_conv as [?[?[]]]%red_ty_compl_sig_r . + pose proof bun_inf_conv_conv as [?[?[]]]%red_compl_sig_r . econstructor; tea. 1: do 2 econstructor; tea; now eapply (redty_red (ta:=de)). - eapply typing_subst1; [|now symmetry]. - eapply TermConv; refold; [|now symmetry]. + eapply typing_subst1; tea. + eapply TermConv; refold ; [|now symmetry]. econstructor. eapply TermRefl. now eapply inf_conv_decl. - intros_bn. + econstructor; tea. - 2,3: econstructor ; tea; now eapply algo_conv_complete. - econstructor; tea; now eapply red_ty_compl_univ_r. + 2,3: econstructor ; tea; now eapply ty_conv_compl. + econstructor; tea; now eapply red_compl_univ_r. + now do 2 econstructor. - intros * tyA tyx. pose proof tyA as ?%bn_alg_typing_sound. pose proof tyx as ?%bn_typing_sound. destruct tyA, tyx. - do 3 (econstructor; tea); now eapply algo_conv_complete. + do 3 (econstructor; tea); now eapply ty_conv_compl. - intros * tyA tyx tyP tyhr tyy tye. pose proof tyA as ?%bn_alg_typing_sound. pose proof tyx as ?%bn_typing_sound. @@ -176,9 +184,9 @@ Module AlgorithmicTypingProperties. destruct tyA, tyx, tyP, tyhr, tyy, tye. econstructor; tea. + econstructor; tea; econstructor; tea. - all: now eapply algo_conv_complete. + all: now eapply ty_conv_compl. + econstructor; eapply typing_subst2; tea. - cbn; now rewrite 2!wk1_ren_on, 2!shift_subst_eq. + cbn; now rewrite 2!wk1_ren_on, 2!shift_one_eq. - intros_bn. 1: eassumption. etransitivity ; tea. @@ -191,7 +199,8 @@ Module AlgorithmicTypingProperties. now eapply algo_conv_sound in bun_conv_ty. Qed. - #[export, refine] Instance RedTermAlgProperties : + #[export, refine] Instance RedTermAlgProperties + `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} `{!ConvComplete (ta := de) (ta' := al)}: RedTermProperties (ta := bn) := {}. Proof. - intros_bn. @@ -207,7 +216,7 @@ Module AlgorithmicTypingProperties. + econstructor. 1: now do 2 econstructor. econstructor ; tea. - now eapply algo_conv_complete. + now eapply ty_conv_compl. + eapply typing_subst1 ; tea. econstructor. now eapply inf_conv_decl. @@ -226,18 +235,17 @@ Module AlgorithmicTypingProperties. econstructor. * eassumption. * do 2 econstructor ; tea. - now eapply (redty_red (ta := de)), red_ty_compl_nat_r. + now eapply (redty_red (ta := de)), red_compl_nat_r. * now do 2 econstructor. + apply redalg_one_step; now constructor. - intros_bn. - + eapply red_ty_compl_prod_r in bun_inf_conv_conv0 as (?&?&[]). + + eapply red_compl_prod_r in bun_inf_conv_conv0 as (?&?&[]). econstructor ; tea. 1: econstructor. * econstructor ; tea. now eapply (redty_red (ta := de)). * econstructor ; tea. - eapply algo_conv_complete. - now etransitivity. + eapply ty_conv_compl ; now etransitivity. * eapply typing_subst1 ; tea. econstructor. now eapply inf_conv_decl. @@ -246,27 +254,27 @@ Module AlgorithmicTypingProperties. assert [Γ |-[al] n ▹h tNat]. { econstructor ; tea. - now eapply (redty_red (ta := de)), red_ty_compl_nat_r. + now eapply (redty_red (ta := de)), red_compl_nat_r. } split ; tea. 1: econstructor ; tea. 1: econstructor ; tea. + econstructor ; tea. - now eapply algo_conv_complete. + now eapply ty_conv_compl. + econstructor ; tea. - now eapply algo_conv_complete. + now eapply ty_conv_compl. + econstructor. eapply typing_subst1. all: eapply algo_typing_sound ; tea. 2: now econstructor. econstructor ; tea. - now eapply algo_conv_complete. + now eapply ty_conv_compl. + now apply redalg_natElim. - intros * [] [?[]]. assert [Γ |-[al] n ▹h tEmpty]. { econstructor ; tea. - now eapply (redty_red (ta := de)), red_ty_compl_empty_r. + now eapply (redty_red (ta := de)), red_compl_empty_r. } split ; tea. 1: econstructor ; tea. @@ -276,7 +284,7 @@ Module AlgorithmicTypingProperties. all: eapply algo_typing_sound ; tea. 2: now econstructor. econstructor ; tea. - now eapply algo_conv_complete. + now eapply ty_conv_compl. + now apply redalg_natEmpty. - intros_bn. 2: econstructor; [|reflexivity]; now constructor. @@ -284,10 +292,10 @@ Module AlgorithmicTypingProperties. 1: tea. 2: eapply TypeRefl; refold; now boundary. do 2 econstructor. - 1: do 2 (econstructor; tea); now eapply algo_conv_complete. + 1: do 2 (econstructor; tea); now eapply ty_conv_compl. reflexivity. - intros * [? []]. - pose proof bun_inf_conv_conv as [?[?[]]]%red_ty_compl_sig_r. + pose proof bun_inf_conv_conv as [?[?[]]]%red_compl_sig_r. econstructor; tea. 2: now apply redalg_fst. econstructor; tea. @@ -296,10 +304,9 @@ Module AlgorithmicTypingProperties. 2: econstructor; [|reflexivity]; now constructor. econstructor. 1: tea. - (* 2: eapply TypeRefl; refold; now boundary. *) + do 2 econstructor. 2: reflexivity. - do 2 (econstructor; tea); now eapply algo_conv_complete. + do 2 (econstructor; tea); now eapply ty_conv_compl. + eapply TypeRefl; eapply typing_subst1. 2: now eapply algo_typing_sound. do 2 econstructor. @@ -308,13 +315,12 @@ Module AlgorithmicTypingProperties. * now eapply inf_conv_decl. * now eapply inf_conv_decl. - intros * [? []]. - pose proof bun_inf_conv_conv as [?[?[]]]%red_ty_compl_sig_r. + pose proof bun_inf_conv_conv as [?[?[]]]%red_compl_sig_r. econstructor; tea. 2: now apply redalg_snd. econstructor; tea. do 2 econstructor; tea; now eapply (redty_red (ta:=de)). - eapply typing_subst1. - 2: now symmetry. + eapply typing_subst1 ; tea. eapply TermRefl; eapply wfTermConv; refold; [|now symmetry]. econstructor; now eapply inf_conv_decl. - intros * tyA tyx tyP tyhr tyy tyA' tyz convA convxy convxz. @@ -338,10 +344,10 @@ Module AlgorithmicTypingProperties. econstructor; tea. + econstructor; tea; econstructor; tea. 4: econstructor; tea; econstructor; tea. - all: eapply algo_conv_complete; tea. + all: eapply ty_conv_compl; tea. now etransitivity. + econstructor; eapply typing_subst2; tea. - cbn; rewrite 2!wk1_ren_on, 2!shift_subst_eq. + cbn; rewrite 2!wk1_ren_on, 2!shift_one_eq. econstructor; [econstructor; tea|tea]. now econstructor. - intros * tyA tyx tyP tyhr tyy [? tye]. @@ -352,9 +358,9 @@ Module AlgorithmicTypingProperties. 2: now eapply redalg_idElim. econstructor; tea. + econstructor; tea; econstructor; tea. - all: now eapply algo_conv_complete. + all: now eapply ty_conv_compl. + econstructor; eapply typing_subst2; tea. - cbn; now rewrite 2!wk1_ren_on, 2!shift_subst_eq. + cbn; now rewrite 2!wk1_ren_on, 2!shift_one_eq. - intros_bn. eapply algo_conv_sound in bun_conv_ty ; tea. econstructor ; tea. @@ -366,7 +372,8 @@ Module AlgorithmicTypingProperties. now econstructor. Qed. - #[export, refine] Instance RedTypeAlgProperties : + #[export, refine] Instance RedTypeAlgProperties + `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} : RedTypeProperties (ta := bn) := {}. Proof. - intros_bn. @@ -382,31 +389,24 @@ Module AlgorithmicTypingProperties. now etransitivity. Qed. - #[export] Instance AlgorithmicTypingProperties : GenericTypingProperties bn _ _ _ _ _ _ _ _ _ _ := {}. + #[export] Instance AlgorithmicTypingProperties + `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} `{!ConvComplete (ta := de) (ta' := al)}: + GenericTypingProperties bn _ _ _ _ _ _ _ _ _ _ := {}. End AlgorithmicTypingProperties. (** ** Consequences *) -Import AlgorithmicTypingProperties. - -(** *** Completeness of algorithmic typing *) - -Corollary algo_typing_complete Γ A t : - [Γ |-[de] t : A] -> - [Γ |-[bn] t : A]. -Proof. - now intros [_ _ ?%escapeTm]%(Fundamental (ta := bn)). -Qed. +Import AlgorithmicTypingData AlgorithmicTypingProperties. (** *** Uniqueness of types *) -Lemma type_uniqueness Γ A A' t : +Lemma type_uniqueness `{! TypingComplete (ta := de) (ta' := bn)} Γ A A' t : [Γ |-[de] t : A] -> [Γ |-[de] t : A'] -> [Γ |-[de] A ≅ A']. Proof. - intros [?? Hinf]%algo_typing_complete [?? Hinf']%algo_typing_complete. + intros [?? Hinf]%tm_compl [?? Hinf']%tm_compl. eapply algo_typing_det in Hinf. 2: eassumption. subst. diff --git a/theories/Algorithmic/BundledAlgorithmicTyping.v b/theories/Algorithmic/BundledAlgorithmicTyping.v new file mode 100644 index 00000000..de7c7604 --- /dev/null +++ b/theories/Algorithmic/BundledAlgorithmicTyping.v @@ -0,0 +1,1671 @@ +(** * LogRel.BundledAlgorithmicTyping: algorithmic typing bundled with its pre-conditions, and a tailored induction principle. *) + +From LogRel Require Import Utils Syntax.All GenericTyping DeclarativeTyping AlgorithmicTyping. +From LogRel.TypingProperties Require Import DeclarativeProperties PropertiesDefinition SubstConsequences TypeConstructorsInj NeutralConvProperties. + +Import DeclarativeTypingProperties AlgorithmicTypingData. + + +(** ** Definition of bundled algorithmic typing *) + +Definition bn : tag. +Proof. +constructor. +Qed. + +Definition bni : tag. +Proof. +constructor. +Qed. + +(** The idea of these definitions is to put together an algorithmic derivation with the +pre-conditions that ensure it is sensible. Indeed, for instance [Γ |-[al] A] does not +re-check that Γ is well-typed: in the algorithm, this information is instead maintained as +an invariant. But this means that algorithmic variants, do not unconditionally +imply its declarative counterpart, they only do so if their pre-conditions are fulfilled, +eg if the context or type are well-formed. *) + +(** Also note that in the case of judgements that “output” a type, ie type inference and +neutral conversion, we allow for an arbitrary conversion to “rectify” the output type. +This makes it easier to handle these in the logical relation, because it means the interface +is stable by arbitrary conversion. *) + +(** In the case of a context, there is no judgement, only a pre-condition, as algorithmic +typing never re-checks a context. *) + +Record WfContextBun Γ := +{ + bn_wf_ctx : [|-[de] Γ] ; +}. + +Record WfTypeBun Γ A := +{ + bun_wf_ty_ctx : [|-[de] Γ] ; + bun_wf_ty : [Γ |-[al] A] ; +}. + +Record InferBun Γ A t := +{ + bun_inf_ctx : [|-[de] Γ] ; + bun_inf : [Γ |-[al] t ▹ A] +}. + +Record InferConvBun Γ A t := +{ + bun_inf_conv_ctx : [|-[de] Γ] ; + bun_inf_conv_ty : term ; + bun_inf_conv_inf : [Γ |-[al] t ▹ bun_inf_conv_ty] ; + (** Allows to change the type to any convertible one. *) + bun_inf_conv_conv : [Γ |-[de] bun_inf_conv_ty ≅ A] +}. + +Record InferRedBun Γ A t := +{ + bun_inf_red_ctx : [|-[de] Γ] ; + bun_inf_red : [Γ |-[al] t ▹h A] +}. + +Record CheckBun Γ A t := +{ + bun_chk_ctx : [|-[de] Γ] ; + bun_chk_ty : [Γ |-[de] A] ; + bun_chk : [Γ |-[al] t ◃ A] +}. + +Record ConvTypeBun Γ A B := +{ + bun_conv_ty_ctx : [|-[de] Γ] ; + bun_conv_ty_l : [Γ |-[de] A] ; + bun_conv_ty_r : [Γ |-[de] B] ; + bun_conv_ty : [Γ |-[al] A ≅ B] +}. + +Record ConvTypeRedBun Γ A B := +{ + bun_conv_ty_red_ctx : [|-[de] Γ] ; + bun_conv_ty_red_l : [Γ |-[de] A] ; + bun_conv_ty_red_wh_l : isType A ; + bun_conv_ty_red_r : [Γ |-[de] B] ; + bun_conv_ty_red_wh_r : isType B ; + bun_conv_ty_red : [Γ |-[al] A ≅h B] +}. + +Record ConvTermBun Γ A t u := +{ + bun_conv_tm_ctx : [|-[de] Γ] ; + bun_conv_tm_ty : [Γ |-[de] A] ; + bun_conv_tm_l : [Γ |-[de] t : A] ; + bun_conv_tm_r : [Γ |-[de] u : A] ; + bun_conv_tm : [Γ |-[al] t ≅ u : A] +}. + +Record ConvTermRedBun Γ A t u := +{ + bun_conv_tm_red_ctx : [|-[de] Γ] ; + bun_conv_tm_red_ty : [Γ |-[de] A] ; + bun_conv_tm_red_wh_ty : isType A ; + bun_conv_tm_red_l : [Γ |-[de] t : A] ; + bun_conv_tm_red_wh_l : whnf t ; + bun_conv_tm_red_r : [Γ |-[de] u : A] ; + bun_conv_tm_red_wh_r : whnf u ; + bun_conv_tm_red : [Γ |-[al] t ≅h u : A] +}. + +Record ConvNeuBun Γ A m n := +{ + bun_conv_ne_ctx : [|-[de] Γ] ; + bun_conv_ne_l : well_typed (ta := de) Γ m ; + bun_conv_ne_wh_l : whne m ; + bun_conv_ne_r : well_typed (ta := de) Γ n ; + bun_conv_ne_wh_r : whne n ; + bun_conv_ne : [Γ |-[al] m ~ n ▹ A] +}. + +Record ConvNeuRedBun Γ A m n := +{ + bun_conv_ne_red_ctx : [|-[de] Γ] ; + bun_conv_ne_red_l : well_typed (ta := de) Γ m ; + bun_conv_ne_red_wh_l : whne m ; + bun_conv_ne_red_r : well_typed (ta := de) Γ n ; + bun_conv_ne_red_wh_r : whne n ; + bun_conv_ne_red : [Γ |-[al] m ~h n ▹ A] +}. + +Record ConvNeuConvBun Γ A m n := +{ + bun_conv_ne_conv_ctx : [|-[de] Γ] ; + bun_conv_ne_conv_l : well_typed (ta := de) Γ m ; + bun_conv_ne_conv_wh_l : whne m ; + bun_conv_ne_conv_r : well_typed (ta := de) Γ n ; + bun_conv_ne_conv_wh_r : whne n ; + bun_conv_ne_conv_ty : term ; + bun_conv_ne_conv : [Γ |-[al] m ~ n ▹ bun_conv_ne_conv_ty] ; + bun_conv_ne_conv_conv : [Γ |-[de] bun_conv_ne_conv_ty ≅ A] +}. + +Record RedTypeBun Γ A B := +{ + bun_red_ty_ctx : [|-[de] Γ] ; + bun_red_ty_ty : [Γ |-[al] A] ; + bun_red_ty : [A ⤳* B] ; +}. + +Record OneStepRedTermBun Γ A t u := +{ + bun_osred_tm_ctx : [|-[de] Γ] ; + (** We do not have the instance yet, so we have to specify it by hand, + but this really is [Γ |-[bn] t : A]. *) + bun_osred_tm_tm : typing (ta := bn) (Typing := InferConvBun) Γ A t ; + bun_osred_tm : [t ⤳ u] +}. + +Record RedTermBun Γ A t u := +{ + bun_red_tm_ctx : [|-[de] Γ] ; + bun_red_tm_tm : typing (ta := bn) (Typing := InferConvBun) Γ A t ; + bun_red_tm : [t ⤳* u] ; +}. + +Record RedTypeBunI Γ A B := +{ + buni_red_ty_ctx : [|-[de] Γ] ; + buni_red_ty_ty : [Γ |-[de] A] ; + buni_red_ty : [A ⤳* B] ; +}. + +Record OneStepRedTermBunI Γ A t u := +{ + buni_osred_tm_ctx : [|-[de] Γ] ; + buni_osred_tm_tm : [Γ |-[de] t : A] ; + buni_osred_tm : [t ⤳ u] +}. + +Record RedTermBunI Γ A t u := +{ + buni_red_tm_ctx : [|-[de] Γ] ; + buni_red_tm_tm : [Γ |-[de] t : A] ; + buni_red_tm : [t ⤳* u] ; +}. + +(** ** Instances *) + +(** We actually define two instances, one fully-algorithmic and one where only conversion +is algorithmic, but typing is not. This is needed because we cannot show right away that +(bundled) algorithmic typing has all the properties to be an instance of the generic interface. +The issue is that the logical relation does not give enough properties of neutrals, in particular +we cannot derive that neutral application is injective, ie if [tApp n u] and [tApp n' u'] are +convertible then [n] and [n'] are and so are [u] and [u']. Thus, we use the mixed instance, which +we can readily show, to gather more properties of conversion, enough to show the fully +algorithmic one. *) + +Module BundledTypingData. + + #[export] Instance WfContext_Bundle : WfContext bn := WfContextBun. + #[export] Instance WfType_Bundle : WfType bn := WfTypeBun. + #[export] Instance Inferring_Bundle : Inferring bn := InferBun. + #[export] Instance InferringRed_Bundle : InferringRed bn := InferRedBun. + #[export] Instance Typing_Bundle : Typing bn := InferConvBun. + #[export] Instance Checking_Bundle : Checking bn := CheckBun. + #[export] Instance ConvType_Bundle : ConvType bn := ConvTypeBun. + #[export] Instance ConvTypeRed_Bundle : ConvTypeRed bn := ConvTypeRedBun. + #[export] Instance ConvTerm_Bundle : ConvTerm bn := ConvTermBun. + #[export] Instance ConvTermRed_Bundle : ConvTermRed bn := ConvTermRedBun. + #[export] Instance ConvNeu_Bundle : ConvNeu bn := ConvNeuBun. + #[export] Instance ConvNeuRed_Bundle : ConvNeuRed bn := ConvNeuRedBun. + #[export] Instance ConvNeuConv_Bundle : ConvNeuConv bn := ConvNeuConvBun. + #[export] Instance RedType_Bundle : RedType bn := RedTypeBun. + #[export] Instance OneStepRedTerm_Bundle : OneStepRedTerm bn := OneStepRedTermBun. + #[export] Instance RedTerm_Bundle : RedTerm bn := RedTermBun. + + Ltac fold_bun := + change WfContextBun with (wf_context (ta := bn)) in *; + change WfTypeBun with (wf_type (ta := bn)) in *; + change InferBun with (inferring (ta := bn)) in * ; + change InferRedBun with (infer_red (ta := bn)) in * ; + change InferConvBun with (typing (ta := bn)) in * ; + change CheckBun with (check (ta := bn)) in * ; + change ConvTypeBun with (conv_type (ta := bn)) in * ; + change ConvTermBun with (conv_term (ta := bn)) in * ; + change ConvNeuBun with (conv_neu (ta := bn)) in * ; + change ConvTypeRedBun with (conv_type_red (ta := bn)) in * ; + change ConvTermRedBun with (conv_term_red (ta := bn)) in * ; + change ConvNeuRedBun with (conv_neu_red (ta := bn)) in *; + change ConvNeuConvBun with (conv_neu_ty (ta := bn)) in *; + change RedTypeBun with (red_ty (ta := bn)) in * ; + change OneStepRedTermBun with (osred_tm (ta := bn)) in * ; + change RedTermBun with (red_tm (ta := bn)) in *. + + (** If bundled judgements are complete, then so are the unbundled judgments *) + + #[refine]Instance CompleteBundledAlgoConv + `{ta : tag} `{!ConvType ta} `{ConvTerm ta} `{! ConvComplete (ta := ta) (ta' := bn)} : + ConvComplete (ta := ta) (ta' := al) := {}. + Proof. + - now intros * []%(ty_conv_compl (ta' := bn)). + - now intros * []%(tm_conv_compl (ta' := bn)). + Qed. + +End BundledTypingData. + +Import BundledTypingData. + +Module BundledIntermediateData. + + #[export] Instance WfContext_BundleInt : WfContext bni := WfContextDecl. + #[export] Instance WfType_BundleInt : WfType bni := WfTypeDecl. + #[export] Instance Typing_BundleInt : Typing bni := TypingDecl. + #[export] Instance ConvType_BundleInt : ConvType bni := ConvTypeBun. + #[export] Instance ConvTerm_BundleInt : ConvTerm bni := ConvTermBun. + #[export] Instance ConvNeuConv_BundleInt : ConvNeuConv bni := ConvNeuConvBun. + #[export] Instance RedType_BundleInt : RedType bni := RedTypeBunI. + #[export] Instance OneStepRedTerm_BundleInt : OneStepRedTerm bni := OneStepRedTermBunI. + #[export] Instance RedTerm_BundleInt : RedTerm bni := RedTermBunI. + + Ltac unfold_bni := + change (wf_context (ta := bni)) with (wf_context (ta := de)) in *; + change (wf_type (ta := bni)) with (wf_type (ta := de)) in *; + change (typing (ta := bni)) with (typing (ta := de)) in * ; + change (conv_type (ta := bni)) with (conv_type (ta := bn)) in * ; + change (conv_term (ta := bni)) with (conv_term (ta := bn)) in * ; + change (conv_neu_ty (ta := bni)) with (conv_neu_ty (ta := bn)) in *. + + (** If bundled judgements are complete, then so are the unbundled judgments *) + + #[refine]Instance CompleteBundledAlgoConv + `{ta : tag} `{!ConvType ta} `{ConvTerm ta} `{! ConvComplete (ta := ta) (ta' := bni)} : + ConvComplete (ta := ta) (ta' := al) := {}. + Proof. + - now intros * []%(ty_conv_compl (ta' := bni)). + - now intros * []%(tm_conv_compl (ta' := bni)). + Qed. + +End BundledIntermediateData. + +Set Universe Polymorphism. + + +(** ** Invariants of algorithmic typing (aka McBride discipline): + for each rule, + - assuming pre-conditions to the conclusion and post-conditions of previous premises + implies the pre-condition of a premise; + - assuming pre-conditions to the conclusion and post-conditions of all premises + implies the post-condition of the conclusion. + + This is so regular that the statements used to be generated using meta-programming. + This is not the case anymore to avoid a nasty dependency on MetaCoq which caused + proof engineering problems in places, but might be added again in the future. + + These lemmas are proven one by one rather than "inlined" in a proof of soundness + because they appear again and again, when working with the untyped algorithm, and + the functions. + +*) + +Section Invariants. + Context `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)}. + + Lemma typeConvRed_prem2 (Γ : context) (A A' B B' : term) : + [A ⤳* A'] -> + [B ⤳* B'] -> + [Γ |-[ de ] A] × [Γ |-[ de ] B] -> + [Γ |-[ de ] A'] × [Γ |-[ de ] B']. + Proof. + intros * HA HB []. + eapply subject_reduction_type, reddecl_conv in HA, HB ; tea. + split ; boundary. + Qed. + + Lemma typeConvRed_concl (Γ : context) (A A' B B' : term) : + [A ⤳* A'] -> + [B ⤳* B'] -> + [Γ |-[ de ] A' ≅ B'] -> + [Γ |-[ de ] A] × [Γ |-[ de ] B] -> + [Γ |-[ de ] A ≅ B]. + Proof. + intros * HA HB IHA' [? ?]. + eapply subject_reduction_type, reddecl_conv in HA, HB ; tea. + do 2 etransitivity ; tea. + all: now econstructor. + Qed. + + Lemma typePiCongAlg_prem0 (Γ : context) (A B A' B' : term) : + [Γ |-[ de ] tProd A B] × [Γ |-[ de ] tProd A' B'] -> + [Γ |-[ de ] A] × [Γ |-[ de ] A']. + Proof. + now intros * [[]%prod_ty_inv []%prod_ty_inv]. + Qed. + + Lemma typePiCongAlg_prem1 (Γ : context) (A B A' B' : term) : + [Γ |-[ de ] A ≅ A'] -> + [Γ |-[ de ] tProd A B] × [Γ |-[ de ] tProd A' B'] -> + [Γ,, A |-[ de ] B] × [Γ,, A |-[ de ] B']. + Proof. + intros * ? [[]%prod_ty_inv []%prod_ty_inv]. + split ; [gen_typing|..]. + now eapply stability1. + Qed. + + Lemma typePiCongAlg_concl (Γ : context) (A B A' B' : term) : + [Γ |-[ de ] A ≅ A'] -> + [Γ,, A |-[ de ] B ≅ B'] -> + [Γ |-[ de ] tProd A B] × [Γ |-[ de ] tProd A' B'] -> + [Γ |-[ de ] tProd A B ≅ tProd A' B']. + Proof. + intros * ?? _. + econstructor ; tea. + boundary. + Qed. + + Lemma typeSigCongAlg_prem0 (Γ : context) (A B A' B' : term) : + [Γ |-[ de ] tSig A B] × [Γ |-[ de ] tSig A' B'] -> + [Γ |-[ de ] A] × [Γ |-[ de ] A']. + Proof. + now intros * [[]%sig_ty_inv []%sig_ty_inv]. + Qed. + + Lemma typeSigCongAlg_prem1 (Γ : context) (A B A' B' : term) : + [Γ |-[ de ] A ≅ A'] -> + [Γ |-[ de ] tSig A B] × [Γ |-[ de ] tSig A' B'] -> + [Γ,, A |-[ de ] B] × [Γ,, A |-[ de ] B']. + Proof. + intros * ? [[]%sig_ty_inv []%sig_ty_inv]. + split ; [gen_typing|..]. + now eapply stability1. + Qed. + + Lemma typeSigCongAlg_concl (Γ : context) (A B A' B' : term) : + [Γ |-[ de ] A ≅ A'] -> + [Γ,, A |-[ de ] B ≅ B'] -> + [Γ |-[ de ] tSig A B] × [Γ |-[ de ] tSig A' B'] -> + [Γ |-[ de ] tSig A B ≅ tSig A' B']. + Proof. + intros * ?? _. + econstructor ; tea. + boundary. + Qed. + + Lemma typeIdCongAlg_prem0 (Γ : context) (A A' x x' y y' : term) : + [Γ |-[ de ] tId A x y] × [Γ |-[ de ] tId A' x' y'] -> + [Γ |-[ de ] A] × [Γ |-[ de ] A']. + Proof. + now intros * [[]%id_ty_inv []%id_ty_inv]. + Qed. + + Lemma typeIdCongAlg_prem1 (Γ : context) (A A' x x' y y' : term) : + [Γ |-[ de ] A ≅ A'] -> + [Γ |-[ de ] tId A x y] × [Γ |-[ de ] tId A' x' y'] -> + [Γ |-[ de ] x : A] × [Γ |-[ de ] x' : A]. + Proof. + intros * ? [[]%id_ty_inv []%id_ty_inv]. + split ; [assumption|now econstructor]. + Qed. + + Lemma typeIdCongAlg_prem2 (Γ : context) (A A' x x' y y' : term) : + [Γ |-[ de ] A ≅ A'] -> + [Γ |-[ de ] x ≅ x' : A] -> + [Γ |-[ de ] tId A x y] × [Γ |-[ de ] tId A' x' y'] -> + [Γ |-[ de ] y : A] × [Γ |-[ de ] y' : A]. + Proof. + intros * ?? [[]%id_ty_inv []%id_ty_inv]. + split ; [assumption|now econstructor]. + Qed. + + Lemma typeIdCongAlg_concl (Γ : context) (A A' x x' y y' : term) : + [Γ |-[ de ] A ≅ A'] -> + [Γ |-[ de ] x ≅ x' : A] -> + [Γ |-[ de ] y ≅ y' : A] -> + [Γ |-[ de ] tId A x y] × [Γ |-[ de ] tId A' x' y'] -> + [Γ |-[ de ] tId A x y ≅ tId A' x' y']. + Proof. + intros * ??? [[]%id_ty_inv []%id_ty_inv]. + now econstructor. + Qed. + + + Lemma typeNeuConvAlg_prem2 (Γ : context) (M N : term) : + whne M -> whne N -> + [Γ |-[ de ] M] × [Γ |-[ de ] N] -> + well_typed (ta := de) Γ M × well_typed (ta := de) Γ N. + Proof. + intros * ?? [?%neutral_ty_inv ?%neutral_ty_inv] ; tea. + now split ; eexists. + Qed. + + Lemma typeNeuConvAlg_concl (Γ : context) (M N T : term) : + whne M -> + whne N -> + [× [Γ |-[ de ] M ≅ N : T], forall T' : term, [Γ |-[ de ] M : T'] -> [Γ |-[ de ] T ≅ T'] + & forall T' : term, [Γ |-[ de ] N : T'] -> [Γ |-[ de ] T ≅ T']] -> + [Γ |-[ de ] M] × [Γ |-[ de ] N] -> [Γ |-[ de ] M ≅ N]. + Proof. + intros * ?? [? HM] [?%neutral_ty_inv] ; tea. + do 2 econstructor ; tea. + now eapply HM. + Qed. + + Lemma neuVarConvAlg_concl (Γ : context) (n : nat) (decl : term) : + in_ctx Γ n decl -> + well_typed (ta := de) Γ (tRel n) × well_typed (ta := de) Γ (tRel n) -> + [× [Γ |-[ de ] tRel n ≅ tRel n : decl], + forall T : term, [Γ |-[ de ] tRel n : T] -> [Γ |-[ de ] decl ≅ T] + & forall T : term, [Γ |-[ de ] tRel n : T] -> [Γ |-[ de ] decl ≅ T]]. + Proof. + intros * Hin [_ []]. + split. + - do 2 constructor ; gen_typing. + - intros T Hty. + eapply termGen' in Hty as [? [[? [->]] ?]]. + eapply in_ctx_inj in Hin ; tea ; subst. + eassumption. + - intros T Hty. + eapply termGen' in Hty as [? [[? [->]] ?]]. + eapply in_ctx_inj in Hin ; tea ; subst. + eassumption. + Qed. + + Lemma neuAppCongAlg_prem0 (Γ : context) (m n t u : term) : + well_typed (ta := de) Γ (tApp m t) × well_typed (ta := de) Γ (tApp n u) -> + well_typed (ta := de) Γ m × well_typed (ta := de) Γ n. + Proof. + intros * [[? (?&(?&?&[->])&?)%termGen'] [? (?&(?&?&[->])&?)%termGen']]. + split ; now eexists. + Qed. + + Lemma neuAppCongAlg_prem1 (Γ : context) (m n t u A B : term) : + [× [Γ |-[ de ] m ≅ n : tProd A B], + forall T : term, [Γ |-[ de ] m : T] -> [Γ |-[ de ] tProd A B ≅ T] + & forall T : term, [Γ |-[ de ] n : T] -> [Γ |-[ de ] tProd A B ≅ T]] -> + well_typed (ta := de) Γ (tApp m t) × well_typed (ta := de) Γ (tApp n u) -> + [Γ |-[ de ] t : A] × [Γ |-[ de ] u : A]. + Proof. + intros * [? Hm Hn] [[? (?&(?&?&[->])&?)%termGen'] [? (?&(?&?&[->])&?)%termGen']]. + eapply prod_ty_inj in Hm as [] ; tea. + eapply prod_ty_inj in Hn as [] ; tea. + split ; now econstructor. + Qed. + + Lemma neuAppCongAlg_concl (Γ : context) (m n t u A B : term) : + [× [Γ |-[ de ] m ≅ n : tProd A B], + forall T : term, [Γ |-[ de ] m : T] -> [Γ |-[ de ] tProd A B ≅ T] + & forall T : term, [Γ |-[ de ] n : T] -> [Γ |-[ de ] tProd A B ≅ T]] -> + [Γ |-[ de ] t ≅ u : A] -> + well_typed (ta := de) Γ (tApp m t) × well_typed (ta := de) Γ (tApp n u) -> + [× [Γ |-[ de ] tApp m t ≅ tApp n u : B[t..]], + forall T : term, [Γ |-[ de ] tApp m t : T] -> [Γ |-[ de ] B[t..] ≅ T] + & forall T : term, [Γ |-[ de ] tApp n u : T] -> [Γ |-[ de ] B[t..] ≅ T]]. + Proof. + intros * [? Hm Hn] ? [[? (?&(?&?&[->])&?)%termGen'] [? (?&(?&?&[->])&?)%termGen']]. + split. + + econstructor ; gen_typing. + + intros ? Happ. + eapply termGen' in Happ as [? [(?&?&[-> Htym']) ?]]. + eapply prod_ty_inj in Hm as [] ; tea. + etransitivity ; [..|eassumption]. + eapply typing_subst1 ; tea. + now econstructor. + + intros ? Happ. + eapply termGen' in Happ as [? [(?&?&[-> Htym']) ?]]. + eapply prod_ty_inj in Hn as [] ; tea. + etransitivity ; [..|eassumption]. + eapply typing_subst1. + 2: eassumption. + econstructor ; tea. + now symmetry. + Qed. + + Lemma neuNatElimCong_prem0 (Γ : context) (n n' P P' hz hz' hs hs' : term) : + well_typed (ta := de) Γ (tNatElim P hz hs n) × + well_typed (ta := de) Γ (tNatElim P' hz' hs' n') -> + well_typed (ta := de) Γ n × well_typed (ta := de) Γ n'. + Proof. + intros * [[? (?&[->]&?)%termGen'] [? (?&[->]&?)%termGen']]. + split ; now eexists. + Qed. + + Lemma neuNatElimCong_prem1 (Γ : context) (n n' P P' hz hz' hs hs' : term) : + [× [Γ |-[ de ] n ≅ n' : tNat], forall T : term, [Γ |-[ de ] n : T] -> [Γ |-[ de ] tNat ≅ T] + & forall T : term, [Γ |-[ de ] n' : T] -> [Γ |-[ de ] tNat ≅ T]] -> + well_typed (ta := de) Γ (tNatElim P hz hs n) × + well_typed (ta := de) Γ (tNatElim P' hz' hs' n') -> + [Γ,, tNat |-[ de ] P] × [Γ,, tNat |-[ de ] P']. + Proof. + intros * [? Hn Hn'] [[? (?&[->]&?)%termGen'] [? (?&[->]&?)%termGen']]. + now split. + Qed. + + Lemma neuNatElimCong_prem2 (Γ : context) (n n' P P' hz hz' hs hs' : term) : + [× [Γ |-[ de ] n ≅ n' : tNat], forall T : term, [Γ |-[ de ] n : T] -> [Γ |-[ de ] tNat ≅ T] + & forall T : term, [Γ |-[ de ] n' : T] -> [Γ |-[ de ] tNat ≅ T]] -> + [Γ,, tNat |-[ de ] P ≅ P'] -> + well_typed (ta := de) Γ (tNatElim P hz hs n) × + well_typed (ta := de) Γ (tNatElim P' hz' hs' n') -> + [Γ |-[ de ] hz : P[tZero..]] × [Γ |-[ de ] hz' : P[tZero..]]. + Proof. + intros * [? Hn Hn'] HP [[? (?&[->]&?)%termGen'] [? (?&[->]&?)%termGen']]. + split. + 1: eassumption. + econstructor ; tea. + symmetry. + eapply typing_subst1 ; tea. + gen_typing. + Qed. + + Lemma neuNatElimCong_prem3 (Γ : context) (n n' P P' hz hz' hs hs' : term) : + [× [Γ |-[ de ] n ≅ n' : tNat], forall T : term, [Γ |-[ de ] n : T] -> [Γ |-[ de ] tNat ≅ T] + & forall T : term, [Γ |-[ de ] n' : T] -> [Γ |-[ de ] tNat ≅ T]] -> + [Γ,, tNat |-[ de ] P ≅ P'] -> + [Γ |-[ de ] hz ≅ hz' : P[tZero..]] -> + well_typed (ta := de) Γ (tNatElim P hz hs n) × + well_typed (ta := de) Γ (tNatElim P' hz' hs' n') -> + [Γ |-[ de ] hs : elimSuccHypTy P] × [Γ |-[ de ] hs' : elimSuccHypTy P]. + Proof. + intros * [? Hn Hn'] HP _ [[? (?&[->]&?)%termGen'] [? (?&[->]&?)%termGen']]. + split. + 1: eassumption. + econstructor ; tea. + symmetry. + eapply elimSuccHypTy_conv. + all: gen_typing. + Qed. + + Lemma neuNatElimCong_concl (Γ : context) (n n' P P' hz hz' hs hs' : term) : + [× [Γ |-[ de ] n ≅ n' : tNat], forall T : term, [Γ |-[ de ] n : T] -> [Γ |-[ de ] tNat ≅ T] + & forall T : term, [Γ |-[ de ] n' : T] -> [Γ |-[ de ] tNat ≅ T]] -> + [Γ,, tNat |-[ de ] P ≅ P'] -> + [Γ |-[ de ] hz ≅ hz' : P[tZero..]] -> + [Γ |-[ de ] hs ≅ hs' : elimSuccHypTy P] -> + well_typed (ta := de) Γ (tNatElim P hz hs n) × + well_typed (ta := de) Γ (tNatElim P' hz' hs' n') -> + [× [Γ |-[ de ] tNatElim P hz hs n ≅ tNatElim P' hz' hs' n' : P[n..]], + forall T : term, [Γ |-[ de ] tNatElim P hz hs n : T] -> [Γ |-[ de ] P[n..] ≅ T] + & forall T : term, [Γ |-[ de ] tNatElim P' hz' hs' n' : T] -> [Γ |-[ de ] P[n..] ≅ T]]. + Proof. + intros * [? Hn Hn'] HP ? ? [[? (?&[->]&?)%termGen'] [? (?&[->]&?)%termGen']]. + split. + + now econstructor. + + now intros ?[? [[->]]]%termGen'. + + intros ?[? [[->]]]%termGen'. + etransitivity. + 1: eapply typing_subst1. + all: eassumption. + Qed. + + Lemma neuEmptyElimCong_prem0 (Γ : context) (P P' e e' : term) : + well_typed (ta := de) Γ (tEmptyElim P e) × well_typed (ta := de) Γ (tEmptyElim P' e') -> + well_typed (ta := de) Γ e × well_typed (ta := de) Γ e'. + Proof. + intros * [[? (?&[->]&?)%termGen'] [? (?&[->]&?)%termGen']]. + split ; now eexists. + Qed. + + Lemma neuEmptyElimCong_prem1 (Γ : context) (P P' e e' : term) : + [× [Γ |-[ de ] e ≅ e' : tEmpty], forall T : term, [Γ |-[ de ] e : T] -> [Γ |-[ de ] tEmpty ≅ T] + & forall T : term, [Γ |-[ de ] e' : T] -> [Γ |-[ de ] tEmpty ≅ T]] -> + well_typed (ta := de) Γ (tEmptyElim P e) × well_typed (ta := de) Γ (tEmptyElim P' e') -> + [Γ,, tEmpty |-[ de ] P] × [Γ,, tEmpty |-[ de ] P']. + Proof. + intros * [? Hn Hn'] [[? (?&[->]&?)%termGen'] [? (?&[->]&?)%termGen']]. + now split. + Qed. + + Lemma neuEmptyElimCong_concl (Γ : context) (P P' e e' : term) : + [× [Γ |-[ de ] e ≅ e' : tEmpty], forall T : term, [Γ |-[ de ] e : T] -> [Γ |-[ de ] tEmpty ≅ T] + & forall T : term, [Γ |-[ de ] e' : T] -> [Γ |-[ de ] tEmpty ≅ T]] -> + [Γ,, tEmpty |-[ de ] P ≅ P'] -> + well_typed (ta := de) Γ (tEmptyElim P e) × well_typed (ta := de) Γ (tEmptyElim P' e') -> + [× [Γ |-[ de ] tEmptyElim P e ≅ tEmptyElim P' e' : P[e..]], + forall T : term, [Γ |-[ de ] tEmptyElim P e : T] -> [Γ |-[ de ] P[e..] ≅ T] + & forall T : term, [Γ |-[ de ] tEmptyElim P' e' : T] -> [Γ |-[ de ] P[e..] ≅ T]]. + Proof. + intros * [? Hn Hn'] HP [[? (?&[->]&?)%termGen'] [? (?&[->]&?)%termGen']]. + split. + + now econstructor. + + now intros ?[? [[->]]]%termGen'. + + intros ?[? [[->]]]%termGen'. + etransitivity. + 1: eapply typing_subst1. + all: eassumption. + Qed. + + Lemma neuFstCongAlg_prem0 (Γ : context) (m n : term) : + well_typed (ta := de) Γ (tFst m) × well_typed (ta := de) Γ (tFst n) -> + well_typed (ta := de) Γ m × well_typed (ta := de) Γ n. + Proof. + intros * [[? (?&(?&?&[->])&?)%termGen'] [? (?&(?&?&[->])&?)%termGen']]. + split ; now eexists. + Qed. + + Lemma neuFstCongAlg_concl (Γ : context) (m n A B : term) : + [× [Γ |-[ de ] m ≅ n : tSig A B], + forall T : term, [Γ |-[ de ] m : T] -> [Γ |-[ de ] tSig A B ≅ T] + & forall T : term, [Γ |-[ de ] n : T] -> [Γ |-[ de ] tSig A B ≅ T]] -> + well_typed (ta := de) Γ (tFst m) × well_typed (ta := de) Γ (tFst n) -> + [× [Γ |-[ de ] tFst m ≅ tFst n : A], + forall T : term, [Γ |-[ de ] tFst m : T] -> [Γ |-[ de ] A ≅ T] + & forall T : term, [Γ |-[ de ] tFst n : T] -> [Γ |-[ de ] A ≅ T]]. + Proof. + intros * [? Hm Hn] [[? (?&(?&?&[->])&?)%termGen'] [? (?&(?&?&[->])&?)%termGen']]. + split. + + now econstructor. + + intros ? ?%termGen' ; cbn in * ; prod_hyp_splitter ; subst. + eapply sig_ty_inj in Hm as []. + 2: eassumption. + now etransitivity. + + intros ? ?%termGen' ; cbn in * ; prod_hyp_splitter ; subst. + eapply sig_ty_inj in Hn as []. + 2: eassumption. + now etransitivity. + Qed. + + Lemma neuSndCongAlg_prem0 (Γ : context) (m n : term) : + well_typed (ta := de) Γ (tSnd m) × well_typed (ta := de) Γ (tSnd n) -> + well_typed (ta := de) Γ m × well_typed (ta := de) Γ n. + Proof. + intros * [[? (?&(?&?&[->])&?)%termGen'] [? (?&(?&?&[->])&?)%termGen']]. + split ; now eexists. + Qed. + + Lemma neuSndCongAlg_concl (Γ : context) (m n A B : term) : + [× [Γ |-[ de ] m ≅ n : tSig A B], + forall T : term, [Γ |-[ de ] m : T] -> [Γ |-[ de ] tSig A B ≅ T] + & forall T : term, [Γ |-[ de ] n : T] -> [Γ |-[ de ] tSig A B ≅ T]] -> + well_typed (ta := de) Γ (tSnd m) × well_typed (ta := de) Γ (tSnd n) -> + [× [Γ |-[ de ] tSnd m ≅ tSnd n : B[(tFst m)..]], + forall T : term, [Γ |-[ de ] tSnd m : T] -> [Γ |-[ de ] B[(tFst m)..] ≅ T] + & forall T : term, [Γ |-[ de ] tSnd n : T] -> [Γ |-[ de ] B[(tFst m)..] ≅ T]]. + Proof. + intros * [? Hm Hn] [[? (?&(?&?&[->])&?)%termGen'] [? (?&(?&?&[->])&?)%termGen']]. + split. + + now econstructor. + + intros ? ?%termGen' ; cbn in * ; prod_hyp_splitter ; subst. + eapply sig_ty_inj in Hm as []. + 2: eassumption. + etransitivity; tea. + eapply typing_subst1; tea ; do 2 econstructor. + boundary. + + intros ? ?%termGen' ; cbn in * ; prod_hyp_splitter ; subst. + eapply sig_ty_inj in Hn as []. + 2: eassumption. + etransitivity; tea. + eapply typing_subst1; tea. + now econstructor. + Qed. + + Lemma neuIdElimCong_prem0 (Γ : context) (A A' x x' P P' hr hr' y y' e e' : term) : + well_typed (ta := de) Γ (tIdElim A x P hr y e) × + well_typed (ta := de) Γ (tIdElim A' x' P' hr' y' e') -> + well_typed (ta := de) Γ e × well_typed (ta := de) Γ e'. + Proof. + intros * [[? (?&[->]&?)%termGen'] [? (?&[->]&?)%termGen']]. + split ; now eexists. + Qed. + + Lemma neuIdElimCong_prem1 (Γ : context) (A A' A'' x x' x'' P P' hr hr' y y' y'' e e' : term) : + [× [Γ |-[ de ] e ≅ e' : tId A'' x'' y''], + forall T : term, [Γ |-[ de ] e : T] -> [Γ |-[ de ] tId A'' x'' y'' ≅ T] + & forall T : term, [Γ |-[ de ] e' : T] -> [Γ |-[ de ] tId A'' x'' y'' ≅ T]] -> + well_typed (ta := de) Γ (tIdElim A x P hr y e) × + well_typed (ta := de) Γ (tIdElim A' x' P' hr' y' e') -> + [(Γ,, A),, tId A⟨wk1 (Γ := Γ) A⟩ x⟨wk1 (Γ := Γ) A⟩ (tRel 0) |-[ de ] P] + × [(Γ,, A),, tId A⟨wk1 (Γ := Γ) A⟩ x⟨wk1 (Γ := Γ) A⟩ (tRel 0) |-[ de ] P']. + Proof. + intros * [? Hn Hn'] [[Hwn Hwn'] [[? (?&[->]&?)%termGen'] [? (?&[->]&?)%termGen']]]%dup. + split. + 1: eassumption. + epose proof (idElimConv Hwn Hwn') as (?&?&?&[]) ; tea. + 1: eapply TypeRefl ; refold ; boundary. + 1: constructor. + eapply stability; tea. + eapply idElimMotiveCtxConv; tea. + 1: eapply ctx_refl ; boundary. + 2: econstructor ; tea. + all: now symmetry. + Qed. + + Lemma neuIdElimCong_prem2 (Γ : context) (A A' A'' x x' x'' P P' hr hr' y y' y'' e e' : term) : + [× [Γ |-[ de ] e ≅ e' : tId A'' x'' y''], + forall T : term, [Γ |-[ de ] e : T] -> [Γ |-[ de ] tId A'' x'' y'' ≅ T] + & forall T : term, [Γ |-[ de ] e' : T] -> [Γ |-[ de ] tId A'' x'' y'' ≅ T]] -> + [(Γ,, A),, tId A⟨wk1 (Γ := Γ) A⟩ x⟨wk1 (Γ := Γ) A⟩ (tRel 0) |-[ de ] P ≅ P'] -> + well_typed (ta := de) Γ (tIdElim A x P hr y e) × + well_typed (ta := de) Γ (tIdElim A' x' P' hr' y' e') -> + [Γ |-[ de ] hr : P[tRefl A x .: x..]] × [Γ |-[ de ] hr' : P[tRefl A x .: x..]]. + Proof. + intros * [? Hn Hn'] HP [[Hwn Hwn'] [[? (?&[->]&?)%termGen'] [? (?&[->]&?)%termGen']]]%dup. + split. + 1: eassumption. + epose proof (idElimConv Hwn Hwn') as (?&?&?&[]) ; tea. + 1: eapply TypeRefl ; refold ; boundary. + 1: constructor. + econstructor ; tea. + symmetry. + eapply typing_subst2 ; tea. + 1: boundary. + cbn; rewrite 2!wk1_ren_on, 2!shift_one_eq; now econstructor. + Qed. + + Lemma neuIdElimCong_concl (Γ : context) (A A' A'' x x' x'' P P' hr hr' y y' y'' e e' : term) : + [× [Γ |-[ de ] e ≅ e' : tId A'' x'' y''], + forall T : term, [Γ |-[ de ] e : T] -> [Γ |-[ de ] tId A'' x'' y'' ≅ T] + & forall T : term, [Γ |-[ de ] e' : T] -> [Γ |-[ de ] tId A'' x'' y'' ≅ T]] -> + [(Γ,, A),, tId A⟨wk1 (Γ := Γ) A⟩ x⟨wk1 (Γ := Γ) A⟩ (tRel 0) |-[ de ] P ≅ P'] -> + [Γ |-[ de ] hr ≅ hr' : P[tRefl A x .: x..]] -> + well_typed (ta := de) Γ (tIdElim A x P hr y e) × + well_typed (ta := de) Γ (tIdElim A' x' P' hr' y' e') -> + [× [Γ |-[ de ] tIdElim A x P hr y e ≅ tIdElim A' x' P' hr' y' e' : P[e .: y..]], + forall T : term, [Γ |-[ de ] tIdElim A x P hr y e : T] -> [Γ |-[ de ] P[e .: y..] ≅ T] + & forall T : term, + [Γ |-[ de ] tIdElim A' x' P' hr' y' e' : T] -> [Γ |-[ de ] P[e .: y..] ≅ T]]. + Proof. + intros * [? Hn Hn'] HP Hr [[Hwn Hwn'] [[? (?&[->]&?)%termGen'] [? (?&[->]&?)%termGen']]]%dup. + epose proof (idElimConv Hwn Hwn') as (?&?&?&[He]) ; tea. + 1: eapply TypeRefl ; refold ; boundary. + 1: constructor. + inversion_clear He. + split. + + econstructor ; tea. + econstructor ; tea. + symmetry. + now econstructor. + + now intros ?[? [[->]]]%termGen'. + + intros ?[? [[->]]]%termGen'. + etransitivity. + 2: eassumption. + eapply typing_subst2 ; tea. + 1: boundary. + econstructor ; tea. + symmetry. + cbn; rewrite 2!wk1_ren_on, 2!shift_one_eq. + now constructor. + Qed. + + Lemma neuConvRed_prem0 (Γ : context) (m n : term) : + well_typed (ta := de) Γ m × well_typed (ta := de) Γ n -> + well_typed (ta := de) Γ m × well_typed (ta := de) Γ n. + Proof. + easy. + Qed. + + Lemma neuConvRed_concl (Γ : context) (m n A A' : term) : + [× [Γ |-[ de ] m ≅ n : A], forall T : term, [Γ |-[ de ] m : T] -> [Γ |-[ de ] A ≅ T] + & forall T : term, [Γ |-[ de ] n : T] -> [Γ |-[ de ] A ≅ T]] -> + [A ⤳* A'] -> + whnf A' -> + well_typed (ta := de) Γ m × well_typed (ta := de) Γ n -> + [× [Γ |-[ de ] m ≅ n : A'], forall T : term, [Γ |-[ de ] m : T] -> [Γ |-[ de ] A' ≅ T] + & forall T : term, [Γ |-[ de ] n : T] -> [Γ |-[ de ] A' ≅ T]]. + Proof. + eintros * [] ?%subject_reduction_type%reddecl_conv ? []. + 2: boundary. + split. + - now econstructor. + - intros. + etransitivity. + 2: eauto. + now symmetry. + - intros. + etransitivity. + 2: eauto. + now symmetry. + Qed. + + Lemma termConvRed_prem3 (Γ : context) (t t' u u' A A' : term) : + [A ⤳* A'] -> + [t ⤳* t'] -> + [u ⤳* u'] -> + [Γ |-[ de ] t : A] × [Γ |-[ de ] u : A] -> [Γ |-[ de ] t' : A'] × [Γ |-[ de ] u' : A']. + Proof. + eintros * HA Ht Hu []. + eapply subject_reduction_type, reddecl_conv in HA. + 2: boundary. + eapply subject_reduction in Ht ; tea. + eapply subject_reduction in Hu ; tea. + split. + all: econstructor ; tea. + all: boundary. + Qed. + + Lemma termConvRed_concl (Γ : context) (t t' u u' A A' : term) : + [A ⤳* A'] -> + [t ⤳* t'] -> + [u ⤳* u'] -> + [Γ |-[ de ] t' ≅ u' : A'] -> [Γ |-[ de ] t : A] × [Γ |-[ de ] u : A] -> [Γ |-[ de ] t ≅ u : A]. + Proof. + eintros * HA Ht Hu ? []. + eapply subject_reduction_type, reddecl_conv in HA. + 2: boundary. + eapply subject_reduction, RedConvTeC in Ht ; tea. + eapply subject_reduction, RedConvTeC in Hu ; tea. + etransitivity ; tea. + etransitivity. + 1: now econstructor. + now symmetry. + Qed. + + Lemma termPiCongAlg_prem0 (Γ : context) (A B A' B' : term) : + [Γ |-[ de ] tProd A B : U] × [Γ |-[ de ] tProd A' B' : U] -> + [Γ |-[ de ] A : U] × [Γ |-[ de ] A' : U]. + Proof. + intros * [[? [[->] _]]%termGen' [? [[->] _]]%termGen']. + now split. + Qed. + + Lemma termPiCongAlg_prem1 (Γ : context) (A B A' B' : term) : + [Γ |-[ de ] A ≅ A' : U] -> + [Γ |-[ de ] tProd A B : U] × [Γ |-[ de ] tProd A' B' : U] -> + [Γ,, A |-[ de ] B : U] × [Γ,, A |-[ de ] B' : U]. + Proof. + intros * ? [[? [[->] _]]%termGen' [? [[->] _]]%termGen']. + split. + 1: eassumption. + eapply stability1 ; tea. + now constructor. + Qed. + + Lemma termPiCongAlg_concl (Γ : context) (A B A' B' : term) : + [Γ |-[ de ] A ≅ A' : U] -> + [Γ,, A |-[ de ] B ≅ B' : U] -> + [Γ |-[ de ] tProd A B : U] × [Γ |-[ de ] tProd A' B' : U] -> + [Γ |-[ de ] tProd A B ≅ tProd A' B' : U]. + Proof. + intros. + constructor ; tea. + boundary. + Qed. + + Lemma termSuccCongAlg_prem0 (Γ : context) (t t' : term) : + [Γ |-[ de ] tSucc t : tNat] × [Γ |-[ de ] tSucc t' : tNat] -> + [Γ |-[ de ] t : tNat] × [Γ |-[ de ] t' : tNat]. + Proof. + now intros * [(?&[->]&?)%termGen' (?&[->]&?)%termGen']. + Qed. + + Lemma termSuccCongAlg_concl (Γ : context) (t t' : term) : + [Γ |-[ de ] t ≅ t' : tNat] -> + [Γ |-[ de ] tSucc t : tNat] × [Γ |-[ de ] tSucc t' : tNat] -> + [Γ |-[ de ] tSucc t ≅ tSucc t' : tNat]. + Proof. + now constructor. + Qed. + + Lemma termFunConvAlg_prem2 (Γ : context) (f g A B : term) : + whnf f -> + whnf g -> + [Γ |-[ de ] f : tProd A B] × [Γ |-[ de ] g : tProd A B] -> + [Γ,, A |-[ de ] tApp f⟨↑⟩ (tRel 0) : B] × [Γ,, A |-[ de ] tApp g⟨↑⟩ (tRel 0) : B]. + Proof. + intros * ?? [?%typing_eta' ?%typing_eta']. + now split. + Qed. + + Lemma termFunConvAlg_concl (Γ : context) (f g A B : term) : + whnf f -> + whnf g -> + [Γ,, A |-[ de ] tApp f⟨↑⟩ (tRel 0) ≅ tApp g⟨↑⟩ (tRel 0) : B] -> + [Γ |-[ de ] f : tProd A B] × [Γ |-[ de ] g : tProd A B] -> [Γ |-[ de ] f ≅ g : tProd A B]. + Proof. + intros * ?? ? []. + etransitivity; [|now eapply TermFunEta]. + etransitivity; [symmetry; now eapply TermFunEta|]. + econstructor ; tea. + 2-3: constructor. + all: boundary. + Qed. + + Lemma termSigCongAlg_prem0 (Γ : context) (A B A' B' : term) : + [Γ |-[ de ] tSig A B : U] × [Γ |-[ de ] tSig A' B' : U] -> + [Γ |-[ de ] A : U] × [Γ |-[ de ] A' : U]. + Proof. + intros * [[? [[->] _]]%termGen' [? [[->] _]]%termGen']. + now split. + Qed. + + Lemma termSigCongAlg_prem1 (Γ : context) (A B A' B' : term) : + [Γ |-[ de ] A ≅ A' : U] -> + [Γ |-[ de ] tSig A B : U] × [Γ |-[ de ] tSig A' B' : U] -> + [Γ,, A |-[ de ] B : U] × [Γ,, A |-[ de ] B' : U]. + Proof. + intros * ? [[? [[->] _]]%termGen' [? [[->] _]]%termGen']. + split. + 1: eassumption. + eapply stability1 ; tea. + now constructor. + Qed. + + Lemma termSigCongAlg_concl (Γ : context) (A B A' B' : term) : + [Γ |-[ de ] A ≅ A' : U] -> + [Γ,, A |-[ de ] B ≅ B' : U] -> + [Γ |-[ de ] tSig A B : U] × [Γ |-[ de ] tSig A' B' : U] -> + [Γ |-[ de ] tSig A B ≅ tSig A' B' : U]. + Proof. + intros. + constructor ; tea. + boundary. + Qed. + + Lemma termPairConvAlg_prem2 (Γ : context) (p q A B : term) : + whnf p -> + whnf q -> + [Γ |-[ de ] p : tSig A B] × [Γ |-[ de ] q : tSig A B] -> + [Γ |-[ de ] tFst p : A] × [Γ |-[ de ] tFst q : A]. + Proof. + intros * ?? []. + split. + all: now econstructor. + Qed. + + Lemma termPairConvAlg_prem3 (Γ : context) (p q A B : term) : + whnf p -> + whnf q -> + [Γ |-[ de ] tFst p ≅ tFst q : A] -> + [Γ |-[ de ] p : tSig A B] × [Γ |-[ de ] q : tSig A B] -> + [Γ |-[ de ] tSnd p : B[(tFst p)..]] × [Γ |-[ de ] tSnd q : B[(tFst p)..]]. + Proof. + intros * ?? ? [Hp ]. + split. + 1: now econstructor. + econstructor. + 1: now econstructor. + eapply typing_subst1. + 1: now symmetry. + constructor. + now eapply boundary, sig_ty_inv in Hp as []. + Qed. + + Lemma termPairConvAlg_concl (Γ : context) (p q A B : term) : + whnf p -> + whnf q -> + [Γ |-[ de ] tFst p ≅ tFst q : A] -> + [Γ |-[ de ] tSnd p ≅ tSnd q : B[(tFst p)..]] -> + [Γ |-[ de ] p : tSig A B] × [Γ |-[ de ] q : tSig A B] -> [Γ |-[ de ] p ≅ q : tSig A B]. + Proof. + intros * ?? ? ? [Hp]. + etransitivity; [|now eapply TermPairEta]. + etransitivity; [symmetry; now eapply TermPairEta|]. + eapply boundary, sig_ty_inv in Hp as []. + econstructor ; tea. + all: constructor ; boundary. + Qed. + + Lemma termIdCongAlg_prem0 (Γ : context) (A A' x x' y y' : term) : + [Γ |-[ de ] tId A x y : U] × [Γ |-[ de ] tId A' x' y' : U] -> + [Γ |-[ de ] A : U] × [Γ |-[ de ] A' : U]. + Proof. + now intros * [(?&[->]&?)%termGen' (?&[->]&?)%termGen']. + Qed. + + Lemma termIdCongAlg_prem1 (Γ : context) (A A' x x' y y' : term) : + [Γ |-[ de ] A ≅ A' : U] -> + [Γ |-[ de ] tId A x y : U] × [Γ |-[ de ] tId A' x' y' : U] -> + [Γ |-[ de ] x : A] × [Γ |-[ de ] x' : A]. + Proof. + intros * ? [(?&[->]&?)%termGen' (?&[->]&?)%termGen']. + split. + 1: assumption. + econstructor ; tea. + now constructor. + Qed. + + Lemma termIdCongAlg_prem2 (Γ : context) (A A' x x' y y' : term) : + [Γ |-[ de ] A ≅ A' : U] -> + [Γ |-[ de ] x ≅ x' : A] -> + [Γ |-[ de ] tId A x y : U] × [Γ |-[ de ] tId A' x' y' : U] -> + [Γ |-[ de ] y : A] × [Γ |-[ de ] y' : A]. + Proof. + intros * ?? [(?&[->]&?)%termGen' (?&[->]&?)%termGen']. + split. + 1: assumption. + econstructor ; tea. + now constructor. + Qed. + + Lemma termIdCongAlg_concl (Γ : context) (A A' x x' y y' : term) : + [Γ |-[ de ] A ≅ A' : U] -> + [Γ |-[ de ] x ≅ x' : A] -> + [Γ |-[ de ] y ≅ y' : A] -> + [Γ |-[ de ] tId A x y : U] × [Γ |-[ de ] tId A' x' y' : U] -> + [Γ |-[ de ] tId A x y ≅ tId A' x' y' : U]. + Proof. + intros * ??? [(?&[->]&?)%termGen' (?&[->]&?)%termGen']. + now econstructor. + Qed. + + Lemma termIdReflCong_concl (Γ : context) (A A' A'' x x' y y' : term) : + [Γ |-[ de ] tRefl A x : tId A'' y y'] × [Γ |-[ de ] tRefl A' x' : tId A'' y y'] -> + [Γ |-[ de ] tRefl A x ≅ tRefl A' x' : tId A'' y y']. + Proof. + intros * [[?[[-> ??] []%id_ty_inj]]%termGen' [?[[-> ??] []%id_ty_inj]]%termGen']. + assert [Γ |-[de] A ≅ A'] by + (etransitivity ; tea ; now symmetry). + econstructor. + 1: econstructor. + 3: econstructor. + + eassumption. + + etransitivity ; tea. + symmetry. + now econstructor. + + now symmetry. + + eassumption. + + eassumption. + Qed. + + Lemma termNeuConvAlg_prem0 (Γ : context) (m n P : term) : + [Γ |-[ de ] m : P] × [Γ |-[ de ] n : P] -> + well_typed (ta := de) Γ m × well_typed (ta := de) Γ n. + Proof. + intros * []. + split ; now eexists. + Qed. + + Lemma termNeuConvAlg_concl (Γ : context) (m n T P : term) : + [× [Γ |-[ de ] m ≅ n : T], forall T' : term, [Γ |-[ de ] m : T'] -> [Γ |-[ de ] T ≅ T'] + & forall T' : term, [Γ |-[ de ] n : T'] -> [Γ |-[ de ] T ≅ T']] -> + isPosType P -> [Γ |-[ de ] m : P] × [Γ |-[ de ] n : P] -> [Γ |-[ de ] m ≅ n : P]. + Proof. + intros * [] ? []. + now econstructor. + Qed. + +End Invariants. + +(** ** Induction principle for bundled algorithmic conversion *) + +(** We show an induction principle tailored for the bundled predicates: it threads the invariants +of the algorithm through the derivation, giving us stronger hypothesis in the minor premises, +corresponding to both the pre-conditions being true, and the post-conditions of the induction +hypotheses holding. *) + +Section BundledConv. + Universe u. + + Context `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)}. + + + Context (PTyEq PTyRedEq : context -> term -> term -> Type@{u}) + (PNeEq PNeRedEq PTmEq PTmRedEq : context -> term -> term -> term -> Type@{u}). + + (** Rather than writing by hand the various large statements of the induction principles, + we use Ltac to derive them generically. Hopefully, there is no need to touch any part of + this code when extending modifying the language with more features. *) + #[local] Ltac pre_cond Hyp := + lazymatch Hyp with + | context [PTyEq ?Γ ?A ?B] => + constr:([Γ |-[de] A] × [Γ |-[de] B] -> Hyp) + | context [PTyRedEq ?Γ ?A ?B] => + constr:([Γ |-[de] A] × [Γ |-[de] B] -> Hyp) + | context [PNeEq ?Γ ?A ?t ?u] => + constr:((well_typed (ta := de) Γ t) × (well_typed (ta := de) Γ u) -> Hyp) + | context [PNeRedEq ?Γ ?A ?t ?u] => + constr:((well_typed (ta := de) Γ t) × (well_typed (ta := de) Γ u) -> Hyp) + | context [PTmEq ?Γ ?A ?t ?u] => + constr:(([Γ |-[de] t : A]) × ([Γ |-[de] u : A]) -> Hyp) + | context [PTmRedEq ?Γ ?A ?t ?u] => + constr:(([Γ |-[de] t : A]) × ([Γ |-[de] u : A]) -> Hyp) + end. + + #[local] Ltac post_cond Hyp := + lazymatch Hyp with + | context C [PTyEq ?Γ ?A ?B] => + context C [PTyEq Γ A B × [Γ |-[de] A ≅ B]] + | context C [PTyRedEq ?Γ ?A ?B] => + context C [PTyRedEq Γ A B × [Γ |-[de] A ≅ B]] + | context C [PNeEq ?Γ ?A ?m ?n] => + context C [PNeEq Γ A m n × + [× ([Γ |-[de] m ≅ n : A]), + (forall T, [Γ |-[de] m : T] -> [Γ |-[de] A ≅ T]) & + (forall T, [Γ |-[de] n : T] -> [Γ |-[de] A ≅ T])]] + | context C [PNeRedEq ?Γ ?A ?m ?n] => + context C [PNeRedEq Γ A m n × + [× ([Γ |-[de] m ≅ n : A]), + (forall T, [Γ |-[de] m : T] -> [Γ |-[de] A ≅ T]) & + (forall T, [Γ |-[de] n : T] -> [Γ |-[de] A ≅ T])]] + | context C [PTmEq ?Γ ?A ?t ?u] => + context C [PTmEq Γ A t u × [Γ |-[de] t ≅ u : A]] + | context C [PTmRedEq ?Γ ?A ?t ?u] => + context C [PTmRedEq Γ A t u × [Γ |-[de] t ≅ u : A]] + | ?Hyp' => Hyp' + end. + + #[local] Ltac bundle Hyp := + lazymatch Hyp with + | [?Γ |-[al] ?A ≅ ?B] => constr:([Γ |-[bn] A ≅ B]) + | [?Γ |-[al] ?A ≅h ?B] => constr:([Γ |-[bn] A ≅h B]) + | [?Γ |-[al] ?t ≅ ?u : ?A] => constr:([Γ |-[bn] t ≅ u : A]) + | [?Γ |-[al] ?t ≅h ?u : ?A] => constr:([Γ |-[bn] t ≅h u : A]) + | [?Γ |-[al] ?m ~ ?n ▹ ?A] => constr:([Γ |-[bn] m ~ n ▹ A]) + | [?Γ |-[al] ?m ~h ?n ▹ ?A] => constr:([Γ |-[bn] m ~h n ▹ A]) + | ?Hyp' => constr:(Hyp') + end. + + #[local] Ltac strong_step step := + lazymatch step with + | ?Hyp -> ?T => let Hyp' := (post_cond Hyp) with T' := (strong_step T) in constr:(Hyp' -> T') + | forall x : ?Hyp, @?T x => constr:(forall x : Hyp, ltac:( + let T' := ltac:(eval hnf in (T x)) in let T'' := strong_step T' in exact T'')) + | ?T => (pre_cond T) + end. + + #[local] Ltac weak_concl concl := + lazymatch concl with + | ?Hyp -> ?T => let T' := weak_concl T in let Hyp' := bundle Hyp in constr:(Hyp' -> T') + | forall x : ?Hyp, @?T x => constr:(forall x : Hyp, ltac:( + let T' := ltac:(eval hnf in (T x)) in let T'' := weak_concl T' in exact T'')) + | ?T => constr:(T) + end. + + #[local] Ltac strong_concl concl := + lazymatch concl with + | forall x : ?Hyp, @?T x => constr:(forall x : Hyp, ltac:( + let T' := ltac:(eval hnf in (T x)) in let T'' := strong_concl T' in exact T'')) + | ?T => let T' := (post_cond T) in let T'' := (pre_cond T') in constr:(T'') + end. + + #[local] Ltac strong_statement T := + lazymatch T with + | ?Step -> ?T => let Step' := strong_step Step in let T' := strong_statement T in constr:(Step' -> T') + | ?Chd × ?Ctl => let Chd' := strong_concl Chd in let Ctl' := strong_statement Ctl in constr:(Chd' × Ctl') + | ?Cend => let Cend' := strong_concl Cend in constr:(Cend') + end. + + #[local] Ltac weak_statement T := + lazymatch T with + | ?Step -> ?T => let Step' := strong_step Step in let T' := weak_statement T in constr:(Step' -> T') + | ?Chd × ?Ctl => let Chd' := weak_concl Chd in let Ctl' := weak_statement Ctl in constr:(Chd' × Ctl') + | ?Chd × ?Ctl => let Chd' := weak_concl Chd in let Ctl' := weak_statement Ctl in constr:(Chd' × Ctl') + | ?Cend => let Cend' := weak_concl Cend in constr:(Cend') + end. + + #[local] Definition algo_conv_discipline_stmt := + ltac:( + let t := (type of (AlgoConvInduction PTyEq PTyRedEq PNeEq PNeRedEq PTmEq PTmRedEq)) in + let ind := strong_statement t in + exact ind). + + (** The main theorem *) + Theorem algo_conv_discipline : algo_conv_discipline_stmt. + Proof. + unfold algo_conv_discipline_stmt; intros. + apply AlgoConvInduction. + - intros * ?? ? IHA [? Hconcl]%dup. + eapply typeConvRed_prem2, IHA in Hconcl as [? [? Hpre2]%dup] ; eauto. + eapply typeConvRed_concl in Hpre2 ; eauto. + - intros * ? IHA ? IHB [? Hconcl]%dup. + eapply typePiCongAlg_prem0, IHA in Hconcl as [? [? Hpre0]%dup] ; eauto. + eapply typePiCongAlg_prem1, IHB in Hpre0 as [? [? Hpre1]%dup] ; eauto. + eapply typePiCongAlg_concl in Hpre1 ; eauto. + - intros * []. + split ; [now eauto|..]. + now constructor. + - intros * []. + split ; [now eauto|..]. + now constructor. + - intros * []. + split ; [now eauto|..]. + now constructor. + - intros * ? IHA ? IHB [? Hconcl]%dup. + eapply typeSigCongAlg_prem0, IHA in Hconcl as [? [? Hpre0]%dup] ; eauto. + eapply typeSigCongAlg_prem1, IHB in Hpre0 as [? [? Hpre1]%dup] ; eauto. + eapply typeSigCongAlg_concl in Hpre1 ; eauto. + - intros * ? IHA ? IHx ? IHy [? Hconcl]%dup. + eapply typeIdCongAlg_prem0, IHA in Hconcl as [? [? Hpre0]%dup] ; eauto. + eapply typeIdCongAlg_prem1, IHx in Hpre0 as [? [? Hpre1]%dup] ; eauto. + eapply typeIdCongAlg_prem2, IHy in Hpre1 as [? [? Hpre2]%dup] ; eauto. + eapply typeIdCongAlg_concl in Hpre2 ; eauto 20. + - intros * ?? Hconv IH [? Hconcl]%dup. + eapply typeNeuConvAlg_prem2, IH in Hconcl as [? [? Hpre2]%dup] ; eauto. + eapply typeNeuConvAlg_concl in Hpre2 ; eauto. + - intros * ? [? Hconcl]%dup. + eapply neuVarConvAlg_concl in Hconcl ; eauto. + - intros * ? IHm ? IHt [? Hconcl]%dup. + eapply neuAppCongAlg_prem0, IHm in Hconcl as [? [? Hpre0]%dup] ; eauto. + eapply neuAppCongAlg_prem1, IHt in Hpre0 as [? [? Hpre1]%dup] ; eauto. + eapply neuAppCongAlg_concl in Hpre1 ; eauto. + - intros * ? IHn ? IHP ? IHz ? IHs [? Hconcl]%dup. + eapply neuNatElimCong_prem0, IHn in Hconcl as [? [? Hpre0]%dup] ; eauto. + eapply neuNatElimCong_prem1, IHP in Hpre0 as [? [? Hpre1]%dup] ; eauto. + eapply neuNatElimCong_prem2, IHz in Hpre1 as [? [? Hpre2]%dup] ; eauto. + eapply neuNatElimCong_prem3, IHs in Hpre2 as [? [? Hpre3]%dup] ; eauto. + eapply neuNatElimCong_concl in Hpre3 ; eauto 20. + - intros * ? IHe ? IHP [? Hconcl]%dup. + eapply neuEmptyElimCong_prem0, IHe in Hconcl as [? [? Hpre0]%dup] ; eauto. + eapply neuEmptyElimCong_prem1, IHP in Hpre0 as [? [? Hpre1]%dup] ; eauto. + eapply neuEmptyElimCong_concl in Hpre1 ; eauto. + - intros * ? IH [? Hconcl]%dup. + eapply neuFstCongAlg_prem0, IH in Hconcl as [? [? Hpre0]%dup] ; eauto. + eapply neuFstCongAlg_concl in Hpre0 ; eauto. + - intros * ? IH [? Hconcl]%dup. + eapply neuSndCongAlg_prem0, IH in Hconcl as [? [? Hpre0]%dup] ; eauto. + eapply neuSndCongAlg_concl in Hpre0 ; eauto. + - intros * ? IHn ? IHP ? IHe [? Hconcl]%dup. + eapply neuIdElimCong_prem0, IHn in Hconcl as [? [? Hpre0]%dup] ; eauto. + eapply neuIdElimCong_prem1, IHP in Hpre0 as [? [? Hpre1]%dup] ; eauto. + eapply neuIdElimCong_prem2, IHe in Hpre1 as [? [? Hpre2]%dup] ; eauto. + eapply neuIdElimCong_concl in Hpre2 ; eauto 20. + - intros * ? IHm ?? [? Hconcl]%dup. + eapply IHm in Hconcl as [? [? Hpre0]]%dup. + eapply neuConvRed_concl in Hpre0 as [? Hconcl]%dup ; eauto. + - intros * ??? ? IH [? Hconcl]%dup. + eapply termConvRed_prem3, IH in Hconcl as [? [? Hpre3]%dup] ; eauto. + eapply termConvRed_concl in Hpre3 ; eauto. + - intros * ? IHA ? IHB [? Hconcl]%dup. + eapply termPiCongAlg_prem0, IHA in Hconcl as [? [? Hpre0]%dup] ; eauto. + eapply termPiCongAlg_prem1, IHB in Hpre0 as [? [? Hpre1]%dup] ; eauto. + eapply termPiCongAlg_concl in Hpre1 ; eauto. + - intros. + split ; [eauto|..]. + now econstructor. + - intros. + split ; [eauto|..]. + now econstructor. + - intros * ? IHt [? Hconcl]%dup. + eapply termSuccCongAlg_prem0, IHt in Hconcl as [? [? Hpre0]%dup] ; eauto. + eapply termSuccCongAlg_concl in Hpre0 ; eauto. + - intros. + split ; [eauto|..]. + now econstructor. + - intros * ??? IH [? Hconcl]%dup. + eapply termFunConvAlg_prem2, IH in Hconcl as [? [? Hpre0]%dup] ; eauto. + eapply termFunConvAlg_concl in Hpre0 ; eauto. + - intros * ? IHA ? IHB [? Hconcl]%dup. + eapply termSigCongAlg_prem0, IHA in Hconcl as [? [? Hpre0]%dup] ; eauto. + eapply termSigCongAlg_prem1, IHB in Hpre0 as [? [? Hpre1]%dup] ; eauto. + eapply termSigCongAlg_concl in Hpre1 ; eauto. + - intros * ??? IHf ? IHs [? Hconcl]%dup. + eapply termPairConvAlg_prem2, IHf in Hconcl as [? [? Hpre2]%dup] ; eauto. + eapply termPairConvAlg_prem3, IHs in Hpre2 as [? [? Hpre3]%dup] ; eauto. + eapply termPairConvAlg_concl in Hpre3 ; eauto. + - intros * ? IHA ? IHx ? IHy [? Hconcl]%dup. + eapply termIdCongAlg_prem0, IHA in Hconcl as [? [? Hpre0]%dup] ; eauto. + eapply termIdCongAlg_prem1, IHx in Hpre0 as [? [? Hpre1]%dup] ; eauto. + eapply termIdCongAlg_prem2, IHy in Hpre1 as [? [? Hpre2]%dup] ; eauto. + eapply termIdCongAlg_concl in Hpre2 ; eauto 20. + - intros * [? Hconcl]%dup. + eapply termIdReflCong_concl in Hconcl ; eauto. + - intros * ? IH ? [? Hconcl]%dup. + eapply termNeuConvAlg_prem0, IH in Hconcl as [? [? Hpre0]%dup] ; eauto. + eapply termNeuConvAlg_concl in Hpre0 ; eauto. +Qed. + + Definition BundledConvInductionConcl : Type := + ltac:(let t := eval red in (AlgoConvInductionConcl PTyEq PTyRedEq PNeEq PNeRedEq PTmEq PTmRedEq) in + let t' := weak_statement t in exact t'). + + (** As a corollary, we get the desired induction principle. The difference with the above one + is that we do not get the post-condition of the algorithm in the conclusion, but this is + in general not necessary. *) + Corollary BundledConvInduction : + ltac:( + let t := (type of (AlgoConvInduction PTyEq PTyRedEq PNeEq PNeRedEq PTmEq PTmRedEq)) in + let ind := weak_statement t in + exact ind). + Proof. + intros. + repeat split. + all: intros * []. + all: now apply algo_conv_discipline. + Qed. + +End BundledConv. + +(** ** Soundness of algorithmic conversion *) + +(** Contrarily to the induction principle above, if we instantiate the main principle with +only constant true predicates, we get only the post-conditions, ie a soundness theorem: bundled algorithmic conversion judgments imply their declarative counterparts. *) + +Section ConvSoundness. + + Context `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)}. + + + Let PTyEq (Γ : context) (A B : term) := + [Γ |-[de] A] -> + [Γ |-[de] B] -> + [Γ |-[de] A ≅ B]. + Let PTmEq (Γ : context) (A t u : term) := + [Γ |-[de] t : A] -> [Γ |-[de] u : A] -> + [Γ |-[de] t ≅ u : A]. + Let PNeEq (Γ : context) (A : term) (m n : term) := + (well_typed (ta := de) Γ m) -> + (well_typed (ta := de) Γ n) -> + [× [Γ |-[de] m ≅ n : A], + (forall T, [Γ |-[de] m : T] -> [Γ |-[de] A ≅ T]) & + (forall T, [Γ |-[de] n : T] -> [Γ |-[de] A ≅ T])]. + + Theorem algo_conv_sound : AlgoConvInductionConcl PTyEq PTyEq PNeEq PNeEq PTmEq PTmEq. + Proof. + subst PTyEq PTmEq PNeEq. + red. + pose proof (algo_conv_discipline + (fun _ _ _ => True) (fun _ _ _ => True) (fun _ _ _ _ => True) + (fun _ _ _ _ => True) (fun _ _ _ _ => True) (fun _ _ _ _ => True)) as [H' H] ; + cycle -1. + 1:{ + repeat (split ; [intros ; apply H' ; eauto |..] ; clear H' ; try destruct H as [H' H]). + intros ; apply H ; eauto. + } + all: now constructor. + Qed. + +End ConvSoundness. + +Theorem bn_conv_sound + `{!TypingSubst (ta := de)} + `{!TypeReductionComplete (ta := de)} + `{!TypeConstructorsInj (ta := de)} : + + BundledConvInductionConcl + (fun Γ A B => [Γ |-[de] A ≅ B]) + (fun Γ A B => [Γ |-[de] A ≅ B]) + (fun Γ A t u => [Γ |-[de] t ≅ u : A]) + (fun Γ A t u => [Γ |-[de] t ≅ u : A]) + (fun Γ A t u => [Γ |-[de] t ≅ u : A]) + (fun Γ A t u => [Γ |-[de] t ≅ u : A]). +Proof. + red. + prod_splitter. + all: intros * []. + all: match goal with H : context [al] |- _ => eapply algo_conv_sound in H end. + all: prod_hyp_splitter. + all: try eassumption. + all: now eexists. +Qed. + +(** ** Induction principle for bundled algorithmic typing *) + +(** This is repeating the same ideas as before, but for typing. *) + +Section BundledTyping. + + Context `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)}. + + Context (PTy : context -> term -> Type) + (PInf PInfRed PCheck : context -> term -> term -> Type). + + #[local] Ltac pre_cond Hyp := + lazymatch Hyp with + | context [PTy ?Γ ?A] => + constr:([|-[de] Γ] -> Hyp) + | context [PInf ?Γ ?A ?t] => + constr:([|-[de] Γ] -> Hyp) + | context [PInfRed ?Γ ?A ?t] => + constr:([|-[de] Γ] -> Hyp) + | context [PCheck ?Γ ?A ?t] => + constr:([|-[de] Γ] -> [Γ |-[de] A] -> Hyp) + end. + + #[local] Ltac post_cond Hyp := + lazymatch Hyp with + | context C [PTy ?Γ ?A] => + context C [PTy Γ A × [Γ |-[de] A]] + | context C [PInf ?Γ ?A ?t] => + context C [PInf Γ A t × [Γ |-[de] t : A]] + | context C [PInfRed ?Γ ?A ?t] => + context C [PInfRed Γ A t × [Γ |-[de] t : A]] + | context C [PCheck ?Γ ?A ?t] => + context C [PCheck Γ A t × [Γ |-[de] t : A]] + | ?Hyp' => Hyp' + end. + + #[local] Ltac bundle Hyp := + lazymatch Hyp with + | [?Γ |-[al] ?A] => constr:([Γ |-[bn] A]) + | [?Γ |-[al] ?t ▹ ?A] => constr:([Γ |-[bn] t ▹ A]) + | [?Γ |-[al] ?t ▹h ?A] => constr:([Γ |-[bn] t ▹h A]) + | [?Γ |-[al] ?t ◃ ?A] => constr:([Γ |-[bn] t ◃ A]) + | ?Hyp' => constr:(Hyp') + end. + + #[local] Ltac strong_step step := + lazymatch step with + | ?Hyp -> ?T => let Hyp' := (post_cond Hyp) with T' := (strong_step T) in constr:(Hyp' -> T') + | forall x : ?Hyp, @?T x => constr:(forall x : Hyp, ltac:( + let T' := ltac:(eval hnf in (T x)) in let T'' := strong_step T' in exact T'')) + | ?T => (pre_cond T) + end. + + #[local] Ltac weak_concl concl := + lazymatch concl with + | ?Hyp -> ?T => let T' := weak_concl T in let Hyp' := bundle Hyp in constr:(Hyp' -> T') + | forall x : ?Hyp, @?T x => constr:(forall x : Hyp, ltac:( + let T' := ltac:(eval hnf in (T x)) in let T'' := weak_concl T' in exact T'')) + | ?T => constr:(T) + end. + + #[local] Ltac strong_concl concl := + lazymatch concl with + | forall x : ?Hyp, @?T x => constr:(forall x : Hyp, ltac:( + let T' := ltac:(eval hnf in (T x)) in let T'' := strong_concl T' in exact T'')) + | ?T => let T' := (post_cond T) in let T'' := (pre_cond T') in constr:(T'') + end. + + #[local] Ltac strong_statement T := + lazymatch T with + | ?Step -> ?T => let Step' := strong_step Step in let T' := strong_statement T in constr:(Step' -> T') + | ?Chd × ?Ctl => let Chd' := strong_concl Chd in let Ctl' := strong_statement Ctl in constr:(Chd' × Ctl') + | ?Cend => let Cend' := strong_concl Cend in constr:(Cend') + end. + + #[local] Ltac weak_statement T := + lazymatch T with + | ?Step -> ?T => let Step' := strong_step Step in let T' := weak_statement T in constr:(Step' -> T') + | ?Chd × ?Ctl => let Chd' := weak_concl Chd in let Ctl' := weak_statement Ctl in constr:(Chd' × Ctl') + | ?Chd × ?Ctl => let Chd' := weak_concl Chd in let Ctl' := weak_statement Ctl in constr:(Chd' × Ctl') + | ?Cend => let Cend' := weak_concl Cend in constr:(Cend') + end. + + Let PTy' (c : context) (t : term) := + [ |-[ de ] c] -> PTy c t × [c |-[ de ] t]. + Let PInf' (c : context) (t t1 : term) := + [ |-[ de ] c] -> PInf c t t1 × [c |-[ de ] t1 : t]. + Let PInfRed' (c : context) (t t1 : term) := + [ |-[ de ] c] -> PInfRed c t t1 × [c |-[ de ] t1 : t]. + Let PCheck' (c : context) (t t1 : term) := + [ |-[ de ] c] -> + [c |-[ de ] t] -> PCheck c t t1 × [c |-[ de ] t1 : t]. + + (** The main theorem *) + Theorem algo_typing_discipline : ltac:( + let t := (type of (AlgoTypingInduction PTy PInf PInfRed PCheck)) in + let ind := strong_statement t in + exact ind). + Proof. + intros. + subst PTy' PInf' PInfRed' PCheck'. + apply AlgoTypingInduction. + 1-10: solve [intros ; + repeat unshelve ( + match reverse goal with + | IH : context [prod] |- _ => destruct IH ; [..|shelve] ; gen_typing + end) ; + now split ; [|econstructor] ; eauto]. + - intros * ? IHI ? IHC ?. + destruct IHI as [? IHt]. + 1: gen_typing. + destruct IHC ; tea. + 1: now eapply boundary, prod_ty_inv in IHt as []. + split ; [|econstructor] ; eauto. + - intros. + split ; [eauto|..]. + now econstructor. + - intros. + split ; [eauto|..]. + now econstructor. + - intros. + split ; [eauto|..]. + now econstructor. + - intros * ? IHn ? IHP ? IHz ? IHs ?. + assert [|-[de] Γ,, tNat] + by (econstructor ; tea ; now econstructor). + assert [Γ |-[ de ] P[tZero..]]. + { + eapply typing_subst1. + 1: now econstructor. + now eapply IHP. + } + assert [Γ |-[de] elimSuccHypTy P] + by now eapply elimSuccHypTy_ty. + split ; [eauto 10 |..]. + econstructor. + + now eapply IHP. + + now eapply IHz. + + now eapply IHs. + + now eapply IHn. + - intros. + split ; [eauto|..]. + now econstructor. + - intros * ? IHe ? IHP ?. + assert [|-[de] Γ,, tEmpty] + by (econstructor ; tea ; now econstructor). + split ; [eauto|..]. + econstructor. + + now eapply IHP. + + now eapply IHe. + - intros * ? ihA ? ihB ?. + edestruct ihA as []; tea. + edestruct ihB as []. + 1: gen_typing. + split; [eauto|now econstructor]. + - intros * ? ihA ? ihB ? iha ? ihb ?. + edestruct ihA as []; tea. + edestruct ihB as []. + 1: gen_typing. + edestruct iha as []; tea. + edestruct ihb as []; tea. + 1: now eapply typing_subst1. + split;[eauto|now econstructor]. + (* why is that not found by eauto ? *) + eapply X17; tea; now split. + - intros * ? ih ?. + edestruct ih as []; tea. + split;[eauto|now econstructor]. + - intros * ? ih ?. + edestruct ih as []; tea. + split;[eauto|now econstructor]. + - intros * ? ihA ? ihx ? ihy ?. + edestruct ihA as []; tea. + assert [Γ |-[de] A] by now econstructor. + split; [eauto|]. + econstructor; tea; [now eapply ihx | now eapply ihy]. + - intros * ? ihA ? ihx ?. + assert [Γ |-[de] A] by now eapply ihA. + split; [eauto|]. + econstructor; tea; now eapply ihx. + - intros * ? ihA ? ihx ? ihP ? ihhr ? ihy ? ihe ?. + assert [Γ |-[de] A] by now eapply ihA. + assert [Γ |-[de] x : A] by now eapply ihx. + assert [ |-[ de ] (Γ,, A),, tId A⟨@wk1 Γ A⟩ x⟨@wk1 Γ A⟩ (tRel 0)] by now eapply idElimMotiveCtx. + assert [Γ |-[de] P[tRefl A x .: x..]]. + 1:{ + eapply typing_subst2; tea;[| now eapply ihP]. + cbn;rewrite 2!wk1_ren_on, 2!shift_one_eq; now econstructor. + } + assert [Γ |-[de] tId A x y] by now econstructor. + split. 1:eapply X22; eauto. (* ??? *) + econstructor; tea; [eapply ihP| eapply ihhr| eapply ihy | eapply ihe]; eauto. + - intros * ? IH HA ?. + destruct IH as [? IH] ; tea. + split ; [eauto|..]. + econstructor ; tea. + eapply subject_reduction_type, reddecl_conv in HA. + 1: eassumption. + now boundary. + - intros * ? IHt HA ?. + destruct IHt as [? IHt] ; eauto. + split ; [eauto|]. + econstructor ; tea. + eapply algo_conv_sound in HA ; tea. + now boundary. + Qed. + + Definition BundledTypingInductionConcl : Type := + ltac:(let t := eval red in (AlgoTypingInductionConcl PTy PInf PInfRed PCheck) in + let t' := weak_statement t in exact t'). + + Corollary BundledTypingInduction : + ltac:( + let t := (type of (AlgoTypingInduction PTy PInf PInfRed PCheck)) in + let ind := weak_statement t in + exact ind). + Proof. + intros. + repeat match goal with |- prod _ _ => split end. + all: intros * []. + all: apply algo_typing_discipline ; assumption. + Qed. + +End BundledTyping. + +Section TypingSoundness. + Context `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)}. + + Let PTy (Γ : context) (A : term) := + [|-[de] Γ] -> [Γ |-[de] A]. + Let PInf (Γ : context) (A t : term) := + [|-[de] Γ] -> + [Γ |-[de] t : A]. + Let PCheck (Γ : context) (A t : term) := + [Γ |-[de] A] -> + [Γ |-[de] t : A]. + + Theorem algo_typing_sound : AlgoTypingInductionConcl PTy PInf PInf PCheck. + Proof. + subst PTy PInf PCheck. + red. + pose proof (algo_typing_discipline + (fun _ _ => True) (fun _ _ _ => True) (fun _ _ _ => True) (fun _ _ _ => True)) as [H' H] + ; + cycle -1. + 1: repeat (split ; [ + intros ; apply H' ; tea ; match goal with H : sigT _ |- _ => destruct H | _ => idtac end ; gen_typing + | ..] ; clear H' ; try destruct H as [H' H]). + 1: now intros ; apply H ; gen_typing. + all: now constructor. + Qed. + +End TypingSoundness. + +Theorem bn_alg_typing_sound + `{!TypingSubst (ta := de)} + `{!TypeReductionComplete (ta := de)} + `{!TypeConstructorsInj (ta := de)} : + + BundledTypingInductionConcl + (fun Γ A => [Γ |-[de] A]) + (fun Γ A t => [Γ |-[de] t : A]) + (fun Γ A t => [Γ |-[de] t : A]) + (fun Γ A t => [Γ |-[de] t : A]). +Proof. + red. + prod_splitter. + all: intros * []. + all: match goal with H : context [al] |- _ => eapply algo_typing_sound in H end. + all: prod_hyp_splitter. + all: now eassumption. +Qed. + +Lemma bn_typing_sound + `{!TypingSubst (ta := de)} + `{!TypeReductionComplete (ta := de)} + `{!TypeConstructorsInj (ta := de)} + Γ t A : + [Γ |-[bn] t : A] -> [Γ |-[de] t : A]. +Proof. + intros [???Hty?]. + econstructor ; tea. + now eapply algo_typing_sound in Hty. +Qed. + +Corollary inf_conv_decl + `{!TypingSubst (ta := de)} + `{!TypeReductionComplete (ta := de)} + `{!TypeConstructorsInj (ta := de)} + Γ t A A' : + [Γ |-[al] t ▹ A] -> + [Γ |-[de] A ≅ A'] -> + [Γ |-[de] t : A']. +Proof. + intros Ht Hconv. + apply algo_typing_sound in Ht. + 2: boundary. + now econstructor. +Qed. \ No newline at end of file diff --git a/theories/Algorithmic/UntypedAlgorithmicConversion.v b/theories/Algorithmic/UntypedAlgorithmicConversion.v new file mode 100644 index 00000000..4dc529f4 --- /dev/null +++ b/theories/Algorithmic/UntypedAlgorithmicConversion.v @@ -0,0 +1,1141 @@ +(** * LogRel.UntypedAlgorithmicConversion: alternative definition of algorithmic conversion. *) + +From LogRel Require Import Utils Syntax.All GenericTyping DeclarativeTyping AlgorithmicTyping. +From LogRel Require Import Sections. +From LogRel.TypingProperties Require Import PropertiesDefinition DeclarativeProperties SubstConsequences TypeConstructorsInj NeutralConvProperties. +From LogRel.Algorithmic Require Import BundledAlgorithmicTyping AlgorithmicConvProperties. + +Import DeclarativeTypingProperties AlgorithmicTypingData. + + +(** ** Definitions *) + +(** **** Conversion of types/terms: there is no distinction here *) +Inductive UConvAlg : term -> term -> Type := + | termConvRed {t t' u u'} : + [t ⤳* t'] -> + [u ⤳* u' ] -> + [t' ≅h u'] -> + [t ≅ u] +(** **** Conversion of types/terms reduced to a weak-head normal form *) +with UConvRedAlg : term -> term -> Type := + | UnivReflUAlg : + [U ≅h U] + | PiCongUAlg {A B A' B'} : + [A ≅ A'] -> + [B ≅ B'] -> + [tProd A B ≅h tProd A' B'] + | NatReflUAlg : + [tNat ≅h tNat] + | ZeroReflUAlg : + [tZero ≅h tZero] + | SuccCongUAlg {t t'} : + [t ≅ t'] -> + [tSucc t ≅h tSucc t'] + | EmptyReflUAlg : + [tEmpty ≅h tEmpty] + | LamCongUAlg {A t A' t'} : + [t ≅ t'] -> + [tLambda A t ≅h tLambda A' t'] + | LambNeUAlg {A t n'} : + whne n' -> + [t ≅ eta_expand n'] -> + [tLambda A t ≅h n'] + | NeLamUAlg {n A' t'} : + whne n -> + [eta_expand n ≅ t'] -> + [n ≅h tLambda A' t'] + | SigCongUAlg {A B A' B'} : + [A ≅ A'] -> + [ B ≅ B'] -> + [tSig A B ≅h tSig A' B'] + | PairCongUAlg {A B p q A' B' p' q'} : + [p ≅ p'] -> + [q ≅ q'] -> + [tPair A B p q ≅h tPair A' B' p' q'] + | PairNeUAlg {A B p q n'} : + whne n' -> + [p ≅ tFst n'] -> + [q ≅ tSnd n'] -> + [tPair A B p q ≅h n'] + | NePairUAlg {n A' B' p' q'} : + whne n -> + [tFst n ≅ p'] -> + [tSnd n ≅ q'] -> + [n ≅h tPair A' B' p' q'] + | IdCongUAlg {A A' x x' y y'} : + [A ≅ A'] -> + [x ≅ x'] -> + [y ≅ y'] -> + [tId A x y ≅h tId A' x' y'] + | termIdReflCong {A x A' x'} : + [tRefl A x ≅h tRefl A' x'] + | NeuConvUAlg {m n} : + [m ~ n] -> + [m ≅h n] + +(** **** Conversion of neutral terms *) +with UConvNeuAlg : term -> term -> Type := + | VarConvUAlg {n} : + [tRel n ~ tRel n] + | AppCongUAlg {m n t u} : + [m ~ n] -> + [t ≅ u] -> + [tApp m t ~ tApp n u] + | NatElimCongUAlg {n n' P P' hz hz' hs hs'} : + [n ~ n'] -> + [P ≅ P'] -> + [hz ≅ hz'] -> + [hs ≅ hs'] -> + [tNatElim P hz hs n ~ tNatElim P' hz' hs' n'] + | EmptyElimCongUAlg {P P' e e'} : + [e ~ e'] -> + [P ≅ P'] -> + [tEmptyElim P e ~ tEmptyElim P' e'] + | FstCongUAlg {m n} : + [m ~ n] -> + [tFst m ~ tFst n] + | SndCongUAlg {m n} : + [m ~ n] -> + [tSnd m ~ tSnd n] + | IdElimCongUAlg {A A' x x' P P' hr hr' y y' e e'} : + [e ~ e'] -> + [P ≅ P'] -> + [hr ≅ hr'] -> + [tIdElim A x P hr y e ~ tIdElim A' x' P' hr' y' e'] + +where "[ A ≅ B ]" := (UConvAlg A B) +and "[ A ≅h B ]" := (UConvRedAlg A B) +and "[ m ~ n ]" := (UConvNeuAlg m n). + +(** ** Induction principles *) + +Scheme + Minimality for UConvAlg Sort Type with + Minimality for UConvRedAlg Sort Type with + Minimality for UConvNeuAlg Sort Type. + +Combined Scheme UAlgoConvInduction from + UConvAlg_rect_nodep, + UConvRedAlg_rect_nodep, + UConvNeuAlg_rect_nodep. + +Arguments UAlgoConvInduction PEq PRedEq PNeEq : rename. + + +Definition UAlgoConvInductionConcl := + ltac:( + let t := type of UAlgoConvInduction in + let t' := remove_steps t in + exact t'). + +(** ** Relation to weak-head normal forms *) + +Section UAlgoConvWh. + + Let PEq (A B : term) := True. + Let PNeEq (m n : term) := + whne m × whne n. + Let PRedEq (t u : term) := + whnf t × whnf u. + + Theorem algo_uconv_wh : + UAlgoConvInductionConcl PEq PRedEq PNeEq. + Proof. + subst PEq PRedEq PNeEq ; cbn. + apply UAlgoConvInduction. + all: intros ; prod_splitter ; prod_hyp_splitter. + all: now constructor. + Qed. + +End UAlgoConvWh. + +Notation "[ A ≅ B ]" := (UConvAlg A B). +Notation "[ A ≅h B ]" := (UConvRedAlg A B). +Notation "[ m ~ n ]" := (UConvNeuAlg m n). + +Section UConvStr. + + Let PEq (A B : term) := forall Γ Δ (ρ : Γ ≤ Δ) A' B', + A = A'⟨ρ⟩ -> B = B'⟨ρ⟩ -> + [A' ≅ B']. + Let PRedEq (A B : term) := forall Γ Δ (ρ : Γ ≤ Δ) A' B', + A = A'⟨ρ⟩ -> B = B'⟨ρ⟩ -> + [A' ≅h B']. + Let PNeEq (t u : term) := forall Γ Δ (ρ : Γ ≤ Δ) t' u', + t = t'⟨ρ⟩ -> u = u'⟨ρ⟩ -> + [t' ~ u']. + + #[local] Ltac push_renaming := + repeat match goal with + | eq : _ = ?t⟨_⟩ |- _ => + destruct t ; cbn in * ; try solve [congruence] ; + inversion eq ; subst ; clear eq + end. + + Theorem algo_uconv_str : + UAlgoConvInductionConcl PEq PRedEq PNeEq. + Proof. + subst PEq PRedEq PNeEq. + apply UAlgoConvInduction. + - intros * Hred Hred' ? IH * -> ->. + eapply credalg_str in Hred as [? [->]] , Hred' as [? [->]]. + now econstructor. + - solve [intros ; push_renaming ; now econstructor]. + - intros * ? IHA ? IHB ? **. + push_renaming. + econstructor. + + now eapply IHA. + + now unshelve eapply IHB with(ρ := wk_up _ ρ). + - solve [intros ; push_renaming ; now econstructor]. + - solve [intros ; push_renaming ; now econstructor]. + - intros * ? IH ** ; push_renaming ; econstructor ; now eapply IH. + - solve [intros ; push_renaming ; now econstructor]. + - intros * ? IH ** ; push_renaming ; econstructor ; now + unshelve eapply IH with (ρ := wk_up _ ρ). + - intros * ?? IH ** ; subst ; push_renaming ; econstructor. + + now eapply whne_ren. + + unshelve eapply IH with (ρ := wk_up _ ρ). + 1: assumption. + all: now bsimpl. + - intros * ?? IH ** ; subst ; push_renaming ; econstructor. + + now eapply whne_ren. + + unshelve eapply IH with (ρ := wk_up _ ρ). + 1: assumption. + all: now bsimpl. + - intros * ? IHA ? IHB ** ; push_renaming ; econstructor. + + now eapply IHA. + + unshelve eapply IHB with (ρ := wk_up _ ρ). + 1: assumption. + all: now bsimpl. + - intros * ? IHf ? IHs ** ; push_renaming ; econstructor. + + now eapply IHf. + + now eapply IHs. + - intros * ?? IHf ? IHs ** ; subst ; push_renaming ; econstructor. + + now eapply whne_ren. + + now eapply IHf. + + now eapply IHs. + - intros * ?? IHf ? IHs ** ; subst ; push_renaming ; econstructor. + + now eapply whne_ren. + + now eapply IHf. + + now eapply IHs. + - intros * ? IHA ? IHa ? IHa' ** ; push_renaming ; econstructor. + + now eapply IHA. + + now eapply IHa. + + now eapply IHa'. + - solve [intros ; push_renaming ; now econstructor]. + - intros * ? IH ** ; subst. + econstructor. + now eapply IH. + - intros ; push_renaming. + eapply section_inj in H1 as ->. + 2: eapply section_wk. + now econstructor. + - intros * ? IH ? IH' ** ; push_renaming. + econstructor. + + now eapply IH. + + now eapply IH'. + - intros * ? IHn ? IHP ? IHz ? IHs ** ; push_renaming. + econstructor. + + now eapply IHn. + + unshelve eapply IHP with (ρ := wk_up _ ρ). + 1: assumption. + all: now bsimpl. + + now eapply IHz. + + now eapply IHs. + - intros * ? IHn ? IHP ** ; push_renaming. + econstructor. + + now eapply IHn. + + unshelve eapply IHP with (ρ := wk_up _ ρ). + 1: assumption. + all: now bsimpl. + - intros * ? IH ** ; push_renaming. + econstructor. + now eapply IH. + - intros * ? IH ** ; push_renaming. + econstructor. + now eapply IH. + - intros * ? IHn ? IHP ? IHr ** ; push_renaming. + econstructor. + + now eapply IHn. + + unshelve eapply IHP with (ρ := wk_up _ (wk_up _ ρ)). + 1-2: assumption. + all: now bsimpl. + + now eapply IHr. + Qed. + +End UConvStr. + +Section NeutralConversion. + Context `{!TypingSubst (ta := de)} `{!TypeConstructorsInj (ta := de)} `{!TypeReductionComplete (ta := de)} `{!ConvComplete (ta := de) (ta' := al)}. + + + Import AlgorithmicTypingData. + + Lemma ne_conv_conv (Γ : context) (A A' m n : term) : + [Γ |-[de] A] -> + isType A -> + well_typed Γ m -> + well_typed Γ n -> + [Γ |-[al] m ~ n ▹ A'] -> + [Γ |-[de] A' ≅ A] -> + [Γ |-[al] m ≅h n : A]. + Proof. + intros * ???? [[]%algo_conv_wh Hconv]%dup ? ; tea. + eapply algo_conv_sound in Hconv as [[Hconv]%dup] ; tea. + eapply tm_conv_compl, algo_conv_conv in Hconv ; cycle 1. + - eapply ctx_refl ; boundary. + - eassumption. + - boundary. + - boundary. + - destruct Hconv as [??????? hA hm hn] ; subst ; refold. + eapply red_whnf in hA as -> ; [| gen_typing]. + eapply red_whnf in hm as -> ; [| gen_typing]. + eapply red_whnf in hn as -> ; [| gen_typing]. + assumption. + Qed. + + Lemma conv_wh_conv_red (Γ : context) (A A' m n : term) : + [A ⤳* A'] -> + whnf A' -> + whnf m -> + whnf n -> + [Γ |-[al] m ≅ n : A] -> + [Γ |-[al] m ≅h n : A']. + Proof. + intros hred hA hm hn hconv. + destruct hconv as [??????? redA ?? hconv] ; refold. + eapply red_whnf in hm, hn ; tea ; subst. + eapply whred_det in redA ; tea ; subst. + 2: now eapply algo_conv_wh in hconv as [] ; gen_typing. + eassumption. + Qed. + +End NeutralConversion. + +Section PremisePreserve. + Context `{!TypingSubst (ta := de)} `{!TypeConstructorsInj (ta := de)} `{!TypeReductionComplete (ta := de)}. + + + Lemma LamCongUAlg_prem0 Γ T A t A' t' : + [Γ |-[ de ] tLambda A t : T] × [Γ |-[ de ] tLambda A' t' : T] -> + ∑ A'' B, [× [T ⤳* tProd A'' B], [Γ ,, A'' |- t : B] & [Γ ,, A'' |- t' : B]]. + Proof. + intros [[? [[B [->]] Hconv]]%termGen' [? [[B' [->]] Hconv']]%termGen']. + eapply red_compl_prod_l in Hconv as (A''&B''&[Hred]). + edestruct prod_ty_inj. + { + etransitivity ; tea. + now eapply RedConvTyC. + } + + do 2 eexists ; split. + - now eapply redty_sound. + - now econstructor ; [eapply stability1|..] ; cycle 1. + - now econstructor ; [eapply stability1|..]. + Qed. + + + Lemma LamNeUAlg_prem0 Γ T A t n' : + [Γ |-[ de ] tLambda A t : T] × [Γ |-[ de ] n' : T] -> + ∑ A'' B, [× [T ⤳* tProd A'' B], [Γ ,, A'' |- t : B] & [Γ ,, A'' |- eta_expand n' : B]]. + Proof. + intros [[? [[B [->]] Hconv]]%termGen' Hn]. + eapply red_compl_prod_l in Hconv as (A''&B''&[Hred]). + do 2 eexists ; split. + + - now eapply redty_sound. + - now econstructor ; [eapply stability1 |..]. + - eapply typing_eta' ; econstructor ; tea. + now eapply RedConvTyC. + Qed. + + Lemma NeLamUAlg_prem0 Γ T n A' t' : + [Γ |-[ de ] n : T] × [Γ |-[ de ] tLambda A' t' : T] -> + ∑ A'' B, [× [T ⤳* tProd A'' B], [Γ ,, A'' |- eta_expand n : B] & [Γ ,, A'' |- t' : B]]. + Proof. + intros [Hn [? [[B [->]] Hconv]]%termGen']. + eapply red_compl_prod_l in Hconv as (A''&B''&[Hred]). + do 2 eexists ; split. + + - now eapply redty_sound. + - eapply typing_eta' ; econstructor ; tea. + now eapply RedConvTyC. + - now econstructor ; [eapply stability1 | ..]. + Qed. + + Lemma PairCongUAlg_prem0 Γ T A B p q A' B' p' q' : + [Γ |-[ de ] tPair A B p q : T] × [Γ |-[ de ] tPair A' B' p' q' : T] -> + ∑ A'' B'', [T ⤳* tSig A'' B''] × ([Γ |- p : A''] × [Γ |- p' : A'']). + Proof. + intros [[? [[->] Hconv]]%termGen' [? [[->] Hconv']]%termGen']. + eapply red_compl_sig_l in Hconv as (A''&B''&[Hred]). + + edestruct sig_ty_inj. + { + etransitivity ; tea. + now eapply RedConvTyC. + } + do 2 eexists ; split ; [..|split]. + - now eapply redty_sound. + - now econstructor. + - now econstructor. + Qed. + + Lemma PairCongUAlg_prem1 Γ A B p q A' B' p' q' A'' B'' T : + [Γ |-[ de ] tPair A B p q : T] × [Γ |-[ de ] tPair A' B' p' q' : T] -> + [T ⤳* tSig A'' B''] -> + [Γ |-[de] p ≅ p' : A''] -> + [Γ |- q : B''[(tFst (tPair A B p q))..]] × [Γ |- q' : B''[(tFst (tPair A B p q))..]]. + Proof. + intros * [[? [[->] Hconv]]%termGen' [? [[->] Hconv']]%termGen'] ? ?. + eapply (TypeTrans (B := T)), sig_ty_inj in Hconv as []. + 2: eapply RedConvTyC, subject_reduction_type ; boundary. + eapply (TypeTrans (B := T)), sig_ty_inj in Hconv' as []. + 2: eapply RedConvTyC, subject_reduction_type ; boundary. + + assert [Γ |-[de] p' : A] + by (econstructor ; tea ; etransitivity ; tea ; now symmetry). + assert [Γ |-[ de ] p ≅ tFst (tPair A B p q) : A] by + (econstructor ; symmetry ; now econstructor). + + split. + all: econstructor ; tea. + all: eapply typing_subst1 ; tea. + etransitivity. + all: eapply TermConv ; refold ; tea. + 3: etransitivity ; tea. + all: now symmetry. + Qed. + + Lemma PairNeUAlg_prem0 Γ T A B p q n' : + [Γ |-[ de ] tPair A B p q : T] × [Γ |-[ de ] n' : T] -> + ∑ A'' B'', [T ⤳* tSig A'' B''] × ([Γ |- p : A''] × [Γ |- tFst n' : A'']). + Proof. + intros [[? [[->] [Hconv Hconv']%dup]]%termGen' ?]. + eapply red_compl_sig_l in Hconv as (?&?&[Hred]). + + do 2 eexists ; split ; [..|split]. + - now eapply redty_sound. + - now econstructor. + - do 2 econstructor ; tea. + now eapply RedConvTyC. + Qed. + + Lemma PairNeUAlg_prem1 Γ A B p q n' A'' B'' T : + [Γ |-[ de ] tPair A B p q : T] × [Γ |-[ de ] n' : T] -> + [T ⤳* tSig A'' B''] -> + [Γ |-[de] p ≅ tFst n' : A''] -> + [Γ |- q : B''[(tFst (tPair A B p q))..]] × [Γ |- tSnd n' : B''[(tFst (tPair A B p q))..]]. + Proof. + intros * [[? [[->] Hconv]]%termGen'?] ? ?. + + assert [Γ |-[de] T ≅ tSig A'' B''] by + (eapply RedConvTyC, subject_reduction_type ; boundary). + eapply (TypeTrans (B := T)), sig_ty_inj in Hconv as [] ; tea. + + assert [Γ |-[ de ] p ≅ tFst (tPair A B p q) : A] by + (econstructor ; symmetry ; now econstructor). + + split. + - econstructor ; tea. + now eapply typing_subst1. + - econstructor. + 1: now do 2 econstructor. + eapply typing_subst1. + 2: constructor ; boundary. + etransitivity ; tea. + econstructor. + all: now symmetry. + Qed. + + Lemma NePairUAlg_prem0 Γ T n A' B' p' q' : + [Γ |-[ de ] n : T] × [Γ |-[ de ] tPair A' B' p' q' : T] -> + ∑ A'' B'', [T ⤳* tSig A'' B''] × ([Γ |- tFst n : A''] × [Γ |- p' : A'']). + Proof. + intros [? [? [[->] [Hconv Hconv']%dup]]%termGen']. + eapply red_compl_sig_l in Hconv as (?&?&[Hred]). + do 2 eexists ; split ; [..|split]. + - now eapply redty_sound. + - do 2 econstructor ; tea. + now eapply RedConvTyC. + - now econstructor. + Qed. + + Lemma NePairUAlg_prem1 Γ n A' B' p' q' A'' B'' T : + [Γ |-[ de ] n : T] × [Γ |-[ de ] tPair A' B' p' q' : T] -> + [T ⤳* tSig A'' B''] -> + [Γ |-[de] tFst n ≅ p' : A''] -> + [Γ |- tSnd n : B''[(tFst n)..]] × [Γ |- q' : B''[(tFst n)..]]. + Proof. + intros * [? [? [[->] Hconv]]%termGen'] ? ?. + + assert [Γ |-[de] T ≅ tSig A'' B''] by + (eapply RedConvTyC, subject_reduction_type ; boundary). + eapply (TypeTrans (B := T)), sig_ty_inj in Hconv as [] ; tea. + + split. + - now do 2 econstructor. + - econstructor ; tea. + eapply typing_subst1 ; tea. + econstructor. + all: now symmetry. + Qed. + + Lemma AppCongUAlg_bridge Γ T m n t u : + [Γ |-[al] m ~ n ▹ T] -> + well_typed Γ (tApp m t) × well_typed Γ (tApp n u) -> + ∑ A B, + [T ⤳* tProd A B] × + [× [Γ |-[ de ] m ≅ n : tProd A B], + forall T', [Γ |-[ de ] m : T'] -> [Γ |-[ de ] tProd A B ≅ T'] + & forall T', [Γ |-[ de ] n : T'] -> [Γ |-[ de ] tProd A B ≅ T']]. + Proof. + intros Hal [[? [? [(A&B&[-> Hm])]]%termGen'] [? [? [(A'&B'&[->])]]%termGen']]. + eapply algo_conv_sound in Hal as [? Hpri]. + 2-3: now eexists. + epose proof Hm as Hconv%Hpri. + eapply red_compl_prod_r in Hconv as (?&?&[]). + do 2 eexists ; split ; [..|split]. + - now eapply redty_sound. + - econstructor ; tea. + now eapply RedConvTyC. + - intros. + etransitivity ; eauto. + symmetry. + now eapply RedConvTyC. + - intros. + etransitivity ; eauto. + symmetry. + now eapply RedConvTyC. + Qed. + + Lemma NatElimCongUAlg_bridge Γ T P hz hs n P' hz' hs' n' : + [Γ |-[al] n ~ n' ▹ T] -> + well_typed Γ (tNatElim P hz hs n) × well_typed Γ (tNatElim P' hz' hs' n') -> + [T ⤳* tNat] × + [× [Γ |-[ de ] n ≅ n' : tNat], + forall T', [Γ |-[ de ] n : T'] -> [Γ |-[ de ] tNat ≅ T'] + & forall T', [Γ |-[ de ] n' : T'] -> [Γ |-[ de ] tNat ≅ T']]. + Proof. + intros Hal [[? [? [[-> ??? Hn]]]%termGen'] [? [? [[->]]]%termGen']]. + eapply algo_conv_sound in Hal as [? Hpri]. + 2-3: now eexists. + epose proof Hn as Hconv%Hpri. + eapply red_compl_nat_r in Hconv. + split ; [..|split]. + - now eapply redty_sound. + - econstructor ; tea. + now eapply RedConvTyC. + - intros. + etransitivity ; eauto. + symmetry. + now eapply RedConvTyC. + - intros. + etransitivity ; eauto. + symmetry. + now eapply RedConvTyC. + Qed. + + Lemma EmptyElimCongUAlg_bridge Γ T P n P' n' : + [Γ |-[al] n ~ n' ▹ T] -> + well_typed Γ (tEmptyElim P n) × well_typed Γ (tEmptyElim P' n') -> + [T ⤳* tEmpty] × + [× [Γ |-[ de ] n ≅ n' : tEmpty], + forall T', [Γ |-[ de ] n : T'] -> [Γ |-[ de ] tEmpty ≅ T'] + & forall T', [Γ |-[ de ] n' : T'] -> [Γ |-[ de ] tEmpty ≅ T']]. + Proof. + intros Hal [[? [? [[-> ? Hn]]]%termGen'] [? [? [[->]]]%termGen']]. + eapply algo_conv_sound in Hal as [? Hpri]. + 2-3: now eexists. + epose proof Hn as Hconv%Hpri. + eapply red_compl_empty_r in Hconv. + split ; [..|split]. + - now eapply redty_sound. + - econstructor ; tea. + now eapply RedConvTyC. + - intros. + etransitivity ; eauto. + symmetry. + now eapply RedConvTyC. + - intros. + etransitivity ; eauto. + symmetry. + now eapply RedConvTyC. + Qed. + + Lemma FstCongUAlg_bridge Γ T m n : + [Γ |-[al] m ~ n ▹ T] -> + well_typed Γ (tFst m) × well_typed Γ (tFst n) -> + ∑ A B, + [T ⤳* tSig A B] × + [× [Γ |-[ de ] m ≅ n : tSig A B], + forall T', [Γ |-[ de ] m : T'] -> [Γ |-[ de ] tSig A B ≅ T'] + & forall T', [Γ |-[ de ] n : T'] -> [Γ |-[ de ] tSig A B ≅ T']]. + Proof. + intros Hal [[? [? [(A&B&[-> Hm])]]%termGen'] [? [? [(A'&B'&[->])]]%termGen']]. + eapply algo_conv_sound in Hal as [? Hpri]. + 2-3: now eexists. + epose proof Hm as Hconv%Hpri. + eapply red_compl_sig_r in Hconv as (?&?&[]). + do 2 eexists ; split ; [..|split]. + - now eapply redty_sound. + - econstructor ; tea. + now eapply RedConvTyC. + - intros. + etransitivity ; eauto. + symmetry. + now eapply RedConvTyC. + - intros. + etransitivity ; eauto. + symmetry. + now eapply RedConvTyC. + Qed. + + Lemma SndCongUAlg_bridge Γ T m n : + [Γ |-[al] m ~ n ▹ T] -> + well_typed Γ (tSnd m) × well_typed Γ (tSnd n) -> + ∑ A B, + [T ⤳* tSig A B] × + [× [Γ |-[ de ] m ≅ n : tSig A B], + forall T', [Γ |-[ de ] m : T'] -> [Γ |-[ de ] tSig A B ≅ T'] + & forall T', [Γ |-[ de ] n : T'] -> [Γ |-[ de ] tSig A B ≅ T']]. + Proof. + intros Hal [[? [? [(A&B&[-> Hm])]]%termGen'] [? [? [(A'&B'&[->])]]%termGen']]. + eapply algo_conv_sound in Hal as [? Hpri]. + 2-3: now eexists. + epose proof Hm as Hconv%Hpri. + eapply red_compl_sig_r in Hconv as (?&?&[]). + do 2 eexists ; split ; [..|split]. + - now eapply redty_sound. + - econstructor ; tea. + now eapply RedConvTyC. + - intros. + etransitivity ; eauto. + symmetry. + now eapply RedConvTyC. + - intros. + etransitivity ; eauto. + symmetry. + now eapply RedConvTyC. + Qed. + + Lemma IdElimCongUAlg_bridge Γ T A x P hr y e A' x' P' hr' y' e' : + [Γ |-[al] e ~ e' ▹ T] -> + well_typed Γ (tIdElim A x P hr y e) × well_typed Γ (tIdElim A' x' P' hr' y' e') -> + ∑ A'' x'' y'', [T ⤳* tId A'' x'' y''] × + [× [Γ |-[ de ] e ≅ e' : tId A'' x'' y''], + forall T', [Γ |-[ de ] e : T'] -> [Γ |-[ de ] tId A'' x'' y'' ≅ T'] + & forall T', [Γ |-[ de ] e' : T'] -> [Γ |-[ de ] tId A'' x'' y'' ≅ T']]. + Proof. + intros Hal [[? [? [[-> ????? He]]]%termGen'] [? [? [[->]]]%termGen']]. + eapply algo_conv_sound in Hal as [? Hpri]. + 2-3: now eexists. + epose proof He as Hconv%Hpri. + eapply red_compl_id_r in Hconv as (?&?&?&[]). + do 3 eexists. + split ; [..|split]. + - now eapply redty_sound. + - econstructor ; tea. + now eapply RedConvTyC. + - intros. + etransitivity ; eauto. + symmetry. + now eapply RedConvTyC. + - intros. + etransitivity ; eauto. + symmetry. + now eapply RedConvTyC. + Qed. + +End PremisePreserve. + +Section Soundness. + Context + `{!TypingSubst (ta := de)} + `{!TypeConstructorsInj (ta := de)} + `{!TypeReductionComplete (ta := de)} + `{!ConvComplete (ta := de) (ta' := al)} + `{!Normalisation (ta := de)}. + + Let PEq (t u : term) := + (forall Γ, [Γ |-[de] t] × [Γ |-[de] u] -> [Γ |-[al] t ≅ u]) × + (forall Γ A, [Γ |-[de] t : A] × [Γ |-[de] u : A] -> [Γ |-[al] t ≅ u : A]). + + Let PRedEq (t u : term) := + (forall Γ, [Γ |-[de] t] × [Γ |-[de] u] -> [Γ |-[al] t ≅h u]) × + (forall Γ A, isType A -> [Γ |-[de] t : A] × [Γ |-[de] u : A] -> [Γ |-[al] t ≅h u : A]). + + Let PNeEq (t u : term) := + forall Γ, well_typed Γ t × well_typed Γ u -> + ∑ A'', [Γ |-[al] t ~ u ▹ A'']. + + Lemma uconv_sound : + UAlgoConvInductionConcl PEq PRedEq PNeEq. + Proof. + subst PEq PRedEq PNeEq. + unfold UAlgoConvInductionConcl. + apply UAlgoConvInduction. + + - intros * Ht Hu Ht' [Hty Htm]. + split. + + intros * Hconcl. + eapply typeConvRed_prem2 in Hconcl. + 2-3: eassumption. + now econstructor. + + intros * [Hconcl []]%dup. + assert [Γ |-[de] A] as [[? ? wh]%ty_norm]%dup by boundary. + eapply termConvRed_prem3 in Hconcl ; tea. + econstructor ; eauto. + eapply Htm ; eauto. + eapply type_isType ; tea. + now eapply subject_reduction_raw_ty. + + - split. + + now econstructor. + + intros * ? [[? [[] ]]%termGen' _]. + + - intros * HA [IHA_ty IHA_tm] HB [IHB_ty IHB_tm]. + split. + + intros ? [Hconcl]%dup. + eapply typePiCongAlg_prem0 in Hconcl as [Hpre0 []]%dup. + eapply IHA_ty, algo_conv_sound, typePiCongAlg_prem1 in Hpre0 ; tea. + now econstructor. + + + intros ? T ? [Hconcl [[Hty]%dup]]%dup. + + eapply termGen' in Hty as (?&[->]&->%conv_univ_l) ; tea. + eapply termPiCongAlg_prem0 in Hconcl as [Hpre0 []]%dup. + eapply IHA_tm, algo_conv_sound, termPiCongAlg_prem1 in Hpre0 ; eauto. + now econstructor. + + - split. + 1: now econstructor. + intros ? T ? [Hty]. + + assert (T = U) as -> by + now eapply termGen' in Hty as (?&->&?%conv_univ_l). + constructor. + + - split. + + + intros * [Hz%type_isType _]. + 2: constructor. + inversion Hz ; inv_whne. + + + intros ? T ? [Hty]. + assert (T = tNat) as ->. + { + eapply termGen' in Hty as (?&->&?%red_compl_nat_l%redty_sound%red_whnf) ; tea. + gen_typing. + } + constructor. + + - split. + + + intros * [Hz%type_isType _]. + 2: constructor. + inversion Hz ; inv_whne. + + + intros ? T ? [Hconcl [Hty]]%dup. + assert (T = tNat) as ->. + { + eapply termGen' in Hty as (?&[->]&?%red_compl_nat_l%redty_sound%red_whnf) ; tea. + gen_typing. + } + + eapply termSuccCongAlg_prem0 in Hconcl. + now constructor. + + - split. + 1: now econstructor. + intros ? T ? [Hty]. + assert (T = U) as ->. + { + eapply termGen' in Hty as (?&->&?%red_compl_univ_l%redty_sound%red_whnf) ; tea. + gen_typing. + } + constructor. + + - intros * ? []. + split. + + + intros * [Hz%type_isType _]. + 2: constructor. + inversion Hz ; inv_whne. + + + intros ? T ? [Hconv]%dup. + eapply LamCongUAlg_prem0 in Hconv as (?&?&[Hred]); tea. + eapply red_whnf in Hred as ->. + 2: gen_typing. + + econstructor. + 1-2: now constructor. + eapply algo_conv_tm_expand ; eauto. + 1: reflexivity. + 1-2: eapply redalg_one_step, eta_expand_beta. + + - intros * ?? []. + split. + + + intros * [Hz%type_isType _]. + 2: constructor. + inversion Hz ; inv_whne. + + + intros ? T ? [Hconv]%dup. + eapply LamNeUAlg_prem0 in Hconv as (?&?&[Hred]); tea. + eapply red_whnf in Hred as ->. + 2: gen_typing. + + econstructor. + 1-2: now constructor. + eapply algo_conv_tm_expand ; eauto. + 1,3: reflexivity. + eapply redalg_one_step, eta_expand_beta. + + + - intros * ?? []. + split. + + + intros * [_ Hz%type_isType]. + 2: constructor. + inversion Hz ; inv_whne. + + + intros ? T ? [Hconv]%dup. + eapply NeLamUAlg_prem0 in Hconv as (?&?&[Hred]); tea. + eapply red_whnf in Hred as ->. + 2: gen_typing. + + econstructor. + 1-2: now constructor. + eapply algo_conv_tm_expand ; eauto. + 1,2: reflexivity. + eapply redalg_one_step, eta_expand_beta. + + - intros * HA [IHA_ty IHA_tm] HB [IHB_ty IHB_tm]. + split. + + intros ? [Hconcl]%dup. + eapply typeSigCongAlg_prem0 in Hconcl as [Hpre0 []]%dup. + eapply IHA_ty, algo_conv_sound, typeSigCongAlg_prem1 in Hpre0 ; tea. + now econstructor. + + + intros ? T ? [Hconcl [[Hty]%dup]]%dup. + + eapply termGen' in Hty as (?&[->]&->%red_compl_univ_l%redty_sound%red_whnf) ; tea. + 2: gen_typing. + + eapply termSigCongAlg_prem0 in Hconcl as [Hpre0 []]%dup. + + eapply IHA_tm, algo_conv_sound, termSigCongAlg_prem1 in Hpre0 ; eauto. + now econstructor. + + - intros * Hp [_ IHp] Hq [_ IHq]. + split. + + + intros * [Hz%type_isType _]. + 2: constructor. + inversion Hz ; inv_whne. + + + intros * ? [Hconcl [[Hty]%dup]]%dup. + + eapply PairCongUAlg_prem0 in Hconcl as (?&?&[Hred [Hpre0 []]%dup]) ; tea. + eapply red_whnf in Hred as ->. + 2: gen_typing. + + eapply IHp, algo_conv_sound, PairCongUAlg_prem1 in Hpre0 ; eauto. + 2: reflexivity. + econstructor. + 1-2: now constructor. + + all: eapply algo_conv_tm_expand. + all: solve [eapply redalg_one_step ; now constructor | reflexivity | eauto]. + + - intros * ? Hp [_ IHp] Hq [_ IHq]. + split. + + + intros * [Hz%type_isType _]. + 2: constructor. + inversion Hz ; inv_whne. + + + intros * ? [Hconcl [[Hty]%dup]]%dup. + + eapply PairNeUAlg_prem0 in Hconcl as (?&?&[Hred [Hpre0 []]%dup]) ; tea. + eapply red_whnf in Hred as ->. + 2: gen_typing. + + eapply IHp, algo_conv_sound, PairNeUAlg_prem1 in Hpre0 ; eauto. + econstructor. + 1-2: now constructor. + 3: reflexivity. + + all: eapply algo_conv_tm_expand. + all: solve [eapply redalg_one_step ; now constructor | reflexivity | eauto]. + + - intros * ? Hp [_ IHp] Hq [_ IHq]. + split. + + + intros * [_ Hz%type_isType]. + 2: constructor. + inversion Hz ; inv_whne. + + + intros * ? [Hconcl [[Hty]%dup]]%dup. + + eapply NePairUAlg_prem0 in Hconcl as (?&?&[Hred [Hpre0 []]%dup]) ; tea. + eapply red_whnf in Hred as ->. + 2: gen_typing. + + eapply IHp, algo_conv_sound, NePairUAlg_prem1 in Hpre0 ; eauto. + econstructor. + 1-2: now constructor. + 3: reflexivity. + + all: eapply algo_conv_tm_expand. + all: solve [eapply redalg_one_step ; now constructor | reflexivity | eauto]. + + - intros * HA [IHA_ty IHA_tm] Hx [_ IHx_tm] Hy [_ IHy_tm]. + split. + + + intros ? [Hconcl]%dup. + eapply typeIdCongAlg_prem0 in Hconcl as [Hpre0 []]%dup. + eapply IHA_ty, algo_conv_sound in Hpre0 as [Hpost0]%dup; eauto. + eapply typeIdCongAlg_prem1 in Hpost0 as [Hpre1 []]%dup ; eauto. + eapply IHx_tm, algo_conv_sound, typeIdCongAlg_prem2 in Hpre1 as [Hpre2]%dup; eauto. + now econstructor. + + + intros ? T ? [Hconcl [[Hty]%dup]]%dup. + + eapply termGen' in Hty as (?&[->]&->%red_compl_univ_l%redty_sound%red_whnf) ; tea. + 2: gen_typing. + + eapply termIdCongAlg_prem0 in Hconcl as [Hpre0 []]%dup. + eapply IHA_tm, algo_conv_sound in Hpre0 as [Hpost0]%dup; eauto. + eapply termIdCongAlg_prem1 in Hpost0 as [Hpre1 []]%dup ; eauto. + eapply IHx_tm, algo_conv_sound, termIdCongAlg_prem2 in Hpre1 as [Hpre2]%dup; eauto. + now econstructor. + + - split. + + + intros * [Hz%type_isType _]. + 2: constructor. + inversion Hz ; inv_whne. + + + intros ? T ? [[? [[->] Hconv]]%termGen' _]. + eapply red_compl_id_l in Hconv as (?&?&?&[Hred]). + eapply redty_sound, red_whnf in Hred as ->. + 2: gen_typing. + econstructor. + + - intros * Hconv IH. + split. + + + intros * [Hconcl]%dup. + eapply algo_uconv_wh in Hconv as []. + eapply typeNeuConvAlg_prem2 in Hconcl ; tea. + edestruct IH ; tea. + now econstructor. + + + intros * ? [Hconcl []]%dup. + pose proof Hconv as []%algo_uconv_wh. + eapply termNeuConvAlg_prem0 in Hconcl as [] ; tea. + edestruct IH as [? IHconv] ; eauto. + epose proof IHconv as []%algo_conv_sound ; tea. + eapply ne_conv_conv in IHconv ; eauto. + boundary. + + - intros * [[? [? [[decl [-> ? Hdecl]] ]]%termGen'] _]. + eexists. + now econstructor. + + - intros * ? IH ? [_] ? [Hconcl]%dup. + + eapply neuAppCongAlg_prem0 in Hconcl as [Hpre0 []]%dup ; eauto. + eapply IH in Hpre0 as [? [Hpost0]%dup]. + eapply AppCongUAlg_bridge in Hpost0 as (?&?&[? [Hpre1 []]%dup]); eauto. + eapply neuAppCongAlg_prem1 in Hpre1 ; eauto. + eexists ; econstructor ; eauto. + econstructor ; tea. + constructor. + + - intros * ? IH ? [IHP] ? [_ IHz] ? [_ IHs] ? [Hconcl]%dup. + + eapply neuNatElimCong_prem0 in Hconcl as [Hpre0 []]%dup ; eauto. + eapply IH in Hpre0 as [? [Hpost0]%dup]. + eapply NatElimCongUAlg_bridge in Hpost0 as [? [Hpost0]%dup]; eauto. + eapply neuNatElimCong_prem1 in Hpost0 as [Hpre1 []]%dup ; eauto. + eapply IHP in Hpre1 as [Hpos1]%dup ; eauto. + eapply algo_conv_sound in Hpos1 as [Hpos1]%dup ; eauto. + eapply neuNatElimCong_prem2 in Hpos1 as [Hpre2 []]%dup ; eauto. + eapply IHz in Hpre2 as [Hpos2]%dup ; eauto. + eapply algo_conv_sound in Hpos2 as [Hpos2]%dup ; eauto. + eapply neuNatElimCong_prem3 in Hpos2 as [Hpre3 []]%dup ; eauto. + eapply IHs in Hpre3 as Hpos3 ; eauto. + eexists ; econstructor ; tea. + econstructor ; eauto. + now econstructor. + + - intros * ? IH ? [IHP] ? [Hconcl]%dup. + + eapply neuEmptyElimCong_prem0 in Hconcl as [Hpre0 []]%dup ; eauto. + eapply IH in Hpre0 as [? [Hpost0]%dup]. + eapply EmptyElimCongUAlg_bridge in Hpost0 as [? [Hpost0]%dup]; eauto. + eapply neuEmptyElimCong_prem1 in Hpost0 as [Hpre1 []]%dup ; eauto. + eapply IHP in Hpre1 as [Hpos1]%dup ; eauto. + eexists. + repeat (econstructor ; eauto). + + - intros * ? IH ? [Hconcl]%dup. + + eapply neuFstCongAlg_prem0 in Hconcl as [Hpre0 []]%dup ; eauto. + eapply IH in Hpre0 as [? [Hpost0]%dup]. + eapply FstCongUAlg_bridge in Hpost0 as (?&?&[? [Hpre1 []]%dup]); eauto. + eexists ; econstructor ; eauto. + econstructor ; tea. + constructor. + + - intros * ? IH ? [Hconcl]%dup. + + eapply neuSndCongAlg_prem0 in Hconcl as [Hpre0 []]%dup ; eauto. + eapply IH in Hpre0 as [? [Hpost0]%dup]. + eapply SndCongUAlg_bridge in Hpost0 as (?&?&[? [Hpre1 []]%dup]); eauto. + eexists ; econstructor ; eauto. + econstructor ; tea. + constructor. + + - intros * ? IH ? [IHP] ? [_ IHr] ? [Hconcl]%dup. + + eapply neuIdElimCong_prem0 in Hconcl as [Hpre0 []]%dup ; eauto. + eapply IH in Hpre0 as [? [Hpost0]%dup]. + eapply IdElimCongUAlg_bridge in Hpost0 as [? (?&?&?&[Hpost0]%dup)]; eauto. + eapply neuIdElimCong_prem1 in Hpost0 as [Hpre1 []]%dup ; eauto. + eapply IHP in Hpre1 as [Hpos1]%dup ; eauto. + eapply algo_conv_sound in Hpos1 as [Hpos1]%dup ; eauto. + eapply neuIdElimCong_prem2 in Hpos1 as [Hpre2 []]%dup ; eauto. + eapply IHr in Hpre2 as [Hpos2]%dup ; eauto. + eexists ; econstructor ; tea. + econstructor ; eauto. + now econstructor. + Qed. + +End Soundness. + +Section Completeness. + Context + `{!TypingSubst (ta := de)} + `{!TypeConstructorsInj (ta := de)} + `{!TypeReductionComplete (ta := de)} + `{!ConvComplete (ta := de) (ta' := al)}. + + Lemma whne_app_inv f g : + [tApp f⟨↑⟩ (tRel 0) ~ tApp g⟨↑⟩ (tRel 0)] -> + [f ~ g]. + Proof. + inversion 1 ; subst. + unshelve eapply algo_uconv_str. + 6: eassumption. + 3: unshelve eapply wk1 ; tea ; exact ε. + all: now bsimpl. + Qed. + + Let PTyEq (Γ : context) (A B : term) := + [A ≅ B] × (whne A -> whne B -> [A ~ B]). + Let PTyRedEq (Γ : context) (A B : term) := + [A ≅h B] × (whne A -> whne B -> [A ~ B]). + Let PNeEq (Γ : context) (A t u : term) := [t ~ u]. + Let PNeRedEq (Γ : context) (A t u : term) := [t ~ u]. + Let PTmEq (Γ : context) (A t u : term) := + [t ≅ u] × (whne t -> whne u -> [t ~ u]). + Let PTmRedEq (Γ : context) (A t u : term) := + [t ≅h u] × (whne t -> whne u -> [t ~ u]). + + Theorem bundled_conv_uconv : + BundledConvInductionConcl PTyEq PTyRedEq PNeEq PNeRedEq PTmEq PTmRedEq. + Proof. + all: subst PTyEq PTyRedEq PNeEq PNeRedEq PTmEq PTmRedEq. + apply BundledConvInduction ; cbn in *. + all: try solve [ + intros ; prod_hyp_splitter ; + now econstructor | + intros ; prod_hyp_splitter ; + split ; [now econstructor|..] ; + intros ; + repeat match goal with + | H : [_ ⤳* _] |- _ => eapply red_whne in H ; [..|eassumption] end ; + now subst | + intros ; prod_hyp_splitter ; + split ; [now econstructor|..] ; + intros Hne ; now inversion Hne]. + - intros ; now prod_hyp_splitter. + - intros * whf whg ? [[IHconv IHne]] [Hf Hg]. + eapply fun_isFun in Hf ; tea. + eapply fun_isFun in Hg ; tea. + destruct Hf, Hg. + + split. + 2: intros Hne ; inversion Hne. + econstructor. + inversion IHconv ; subst. + econstructor ; tea. + all: eapply eta_expand_beta_inv ; tea. + all: now eapply algo_uconv_wh in H2 as []. + + split. + 2: intros Hne ; inversion Hne. + econstructor ; tea. + inversion IHconv ; subst. + econstructor ; tea. + eapply eta_expand_beta_inv ; tea. + now eapply algo_uconv_wh in H2 as []. + + split. + 2: intros ? Hne ; inversion Hne. + econstructor ; tea. + inversion IHconv ; subst. + econstructor ; tea. + eapply eta_expand_beta_inv ; tea. + now eapply algo_uconv_wh in H2 as []. + + split. + 1: econstructor. + 2: intros _ _. + all: eapply whne_app_inv, IHne ; econstructor ; now eapply whne_ren. + - intros * whp whq ? [[IHconv IHne]] ? [[IHconv' IHne']] [Hp Hq]. + eapply sig_isPair in Hp ; tea. + eapply sig_isPair in Hq ; tea. + destruct Hp, Hq. + + split. + 2: intros Hne ; inversion Hne. + econstructor. + * inversion IHconv ; subst. + econstructor ; tea. + all: eapply eta_expand_fst_inv ; tea. + all: now eapply algo_uconv_wh in H3 as []. + * inversion IHconv' ; subst. + econstructor ; tea. + all: eapply eta_expand_snd_inv ; tea. + all: now eapply algo_uconv_wh in H3 as []. + + split. + 2: intros Hne ; inversion Hne. + econstructor ; tea. + * inversion IHconv ; subst. + econstructor ; tea. + eapply eta_expand_fst_inv ; tea. + now eapply algo_uconv_wh in H3 as []. + * inversion IHconv' ; subst. + econstructor ; tea. + all: eapply eta_expand_snd_inv ; tea. + all: now eapply algo_uconv_wh in H3 as []. + + split. + 2: intros ? Hne ; inversion Hne. + econstructor ; tea. + * inversion IHconv ; subst. + econstructor ; tea. + eapply eta_expand_fst_inv ; tea. + now eapply algo_uconv_wh in H3 as []. + * inversion IHconv' ; subst. + econstructor ; tea. + all: eapply eta_expand_snd_inv ; tea. + all: now eapply algo_uconv_wh in H3 as []. + + split. + 1: econstructor. + 2: intros _ _. + all: unshelve (epose proof (IHne _ _) as IHne_ ; inversion IHne_ ; subst ; tea). + all: now econstructor. + Qed. + +End Completeness. \ No newline at end of file diff --git a/theories/AlgorithmicTyping.v b/theories/AlgorithmicTyping.v index e8d5426d..34debed3 100644 --- a/theories/AlgorithmicTyping.v +++ b/theories/AlgorithmicTyping.v @@ -1,7 +1,6 @@ (** * LogRel.AlgorithmicTyping: definition of algorithmic conversion and typing. *) From Coq Require Import ssrbool. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening UntypedReduction GenericTyping. +From LogRel Require Import Utils Syntax.All GenericTyping. Section Definitions. @@ -40,6 +39,8 @@ Section Definitions. [ Γ |- y ≅ y' : A] -> [ Γ |- tId A x y ≅h tId A' x' y'] | typeNeuConvAlg {Γ M N T} : + whne M -> + whne N -> [ Γ |- M ~ N ▹ T] -> [ Γ |- M ≅h N] (** **** Conversion of neutral terms *) @@ -71,7 +72,7 @@ Section Definitions. | neuSndCongAlg {Γ m n A B} : [ Γ |- m ~h n ▹ tSig A B ] -> [ Γ |- tSnd m ~ tSnd n ▹ B[(tFst m)..] ] - | neuIdEmlimCong {Γ A A' A'' x x' x'' P P' hr hr' y y' y'' e e'} : + | neuIdElimCong {Γ A A' A'' x x' x'' P P' hr hr' y y' y'' e e'} : [Γ |- e ~h e' ▹ tId A'' x'' y''] -> (* [Γ |- A'' ] -> *) (* [Γ |- A'' ≅ A] -> *) @@ -79,11 +80,11 @@ Section Definitions. (* [Γ |- x'' ≅ x : A] -> *) (* [Γ |- y'' ◃ A] -> *) (* [Γ |- y'' ≅ y : A] -> *) - [Γ |- A ≅ A'] -> + (* [Γ |- A ≅ A'] -> [Γ |- x ≅ x' : A] -> + [Γ |- y ≅ y' : A] -> *) [Γ ,, A ,, tId A⟨@wk1 Γ A⟩ x⟨@wk1 Γ A⟩ (tRel 0) |- P ≅ P'] -> [Γ |- hr ≅ hr' : P[tRefl A x .: x..]] -> - [Γ |- y ≅ y' : A] -> [Γ |- tIdElim A x P hr y e ~ tIdElim A' x' P' hr' y' e' ▹ P[e .: y..] ] (** **** Conversion of neutral terms at a type reduced to weak-head normal form*) with ConvNeuRedAlg : context -> term -> term -> term -> Type := @@ -136,8 +137,6 @@ Section Definitions. [Γ |- y ≅ y' : A] -> [Γ |- tId A x y ≅h tId A' x' y' : U] | termIdReflCong {Γ A A' A'' x x' y y'} : - [Γ |- A ≅ A'] -> - [Γ |- x ≅ x' : A] -> [Γ |- tRefl A x ≅h tRefl A' x' : tId A'' y y' ] | termNeuConvAlg {Γ m n T P} : [Γ |- m ~ n ▹ T] -> @@ -456,7 +455,9 @@ Section TypingWk. now eapply IHB. - intros; now econstructor. - intros. - now econstructor. + econstructor. + 3: easy. + all: now apply whne_ren. - intros * ? ? ?. eapply convne_meta_conv. 1: econstructor ; eauto using in_ctx_wk. @@ -496,7 +497,7 @@ Section TypingWk. - intros ??? A? ? IH *; cbn. rewrite (subst_ren_wk_up (A:=A)). econstructor; now eapply IH. - - intros * ? IHe (*?? ?? ??*) ?? ?? ? IHp **; erewrite <-2!wk_idElim, subst_ren_wk_up2. + - intros * ? IHe (*?? ?? ?? ?? ?? *) ? IHp **; erewrite <-2!wk_idElim, subst_ren_wk_up2. econstructor; eauto. + rewrite 2!(wk_up_wk1 ρ). eapply IHp; constructor; tea. @@ -544,7 +545,7 @@ Section TypingWk. - intros. econstructor. + eauto. - + eauto using isPosType_ren. + + now eapply isPosType_ren. Qed. Let PTy (Γ : context) (A : term) := forall Δ (ρ : Δ ≤ Γ), [Δ |- A⟨ρ⟩]. @@ -757,7 +758,7 @@ Proof. inversion Hconv; subst; clear Hconv; refold. apply IH in H3. now inversion H3. - - intros * ? IH (*? _ ? _ ? _*) ? _ ? _ ? _ ? _ ? _ * Hconv. + - intros * _ * _ * _ * ? ? ? _ ? _ * Hconv. inversion Hconv; now subst. - intros * ? IH ???? Hconv. inversion Hconv ; subst ; clear Hconv ; refold. diff --git a/theories/AutoSubst/Ast.v b/theories/AutoSubst/Ast.v index 43a91298..7acaf6c8 100644 --- a/theories/AutoSubst/Ast.v +++ b/theories/AutoSubst/Ast.v @@ -1,5 +1,5 @@ From LogRel.AutoSubst Require Import core unscoped. -From LogRel Require Import BasicAst. +From LogRel.Syntax Require Import BasicAst. From Coq Require Import Setoid Morphisms Relation_Definitions. @@ -204,7 +204,7 @@ Proof. exact (scons (tRel var_zero) (funcomp (ren_term shift) sigma)). Defined. -Fixpoint subst_term (sigma_term : nat -> term) (s : term) {struct s} : +Fixpoint subst_term (sigma_term : nat -> term) (s : term) {struct s} : term := match s with | tRel s0 => sigma_term s0 @@ -1054,38 +1054,38 @@ Qed. Class Up_term X Y := up_term : X -> Y. -#[global]Instance Subst_term : (Subst1 _ _ _) := @subst_term. +#[global] Instance Subst_term : (Subst1 _ _ _) := @subst_term. -#[global]Instance Up_term_term : (Up_term _ _) := @up_term_term. +#[global] Instance Up_term_term : (Up_term _ _) := @up_term_term. -#[global]Instance Ren_term : (Ren1 _ _ _) := @ren_term. +#[global] Instance Ren_term : (Ren1 _ _ _) := @ren_term. #[global] Instance VarInstance_term : (Var _ _) := @tRel. (* Notation "[ sigma_term ]" := (subst_term sigma_term) - ( at level 1, left associativity, only printing) : fscope. *) +( at level 1, left associativity, only printing) : fscope. *) Notation "s [ sigma_term ]" := (subst_term sigma_term s) - ( at level 7, left associativity, only printing) : subst_scope. +( at level 7, left associativity, only printing) : subst_scope. -Notation "↑__term" := up_term (only printing) : subst_scope. +Notation "↑__term" := up_term (only printing) : subst_scope. -Notation "↑__term" := up_term_term (only printing) : subst_scope. +Notation "↑__term" := up_term_term (only printing) : subst_scope. Notation "⟨ xi_term ⟩" := (ren_term xi_term) - ( at level 1, left associativity, only printing) : fscope. +( at level 1, left associativity, only printing) : fscope. Notation "s ⟨ xi_term ⟩" := (ren_term xi_term s) - ( at level 7, left associativity, only printing) : subst_scope. +( at level 7, left associativity, only printing) : subst_scope. -Notation "'var'" := tRel ( at level 1, only printing) : subst_scope. +Notation "'var'" := tRel ( at level 1, only printing) : subst_scope. Notation "x '__term'" := (@ids _ _ VarInstance_term x) - ( at level 5, format "x __term", only printing) : subst_scope. +( at level 5, format "x __term", only printing) : subst_scope. -Notation "x '__term'" := (tRel x) ( at level 5, format "x __term") : - subst_scope. +Notation "x '__term'" := (tRel x) ( at level 5, format "x __term") : +subst_scope. #[global] Instance subst_term_morphism : @@ -1132,7 +1132,7 @@ Tactic Notation "auto_unfold" "in" "*" := repeat unfold VarInstance_term, Var, ids, Ren_term, Ren1, ren1, Up_term_term, Up_term, up_term, - Subst_term, Subst1, subst1 + Subst_term, Subst1, subst1 in *. Ltac asimpl' := repeat (first @@ -1179,9 +1179,9 @@ Module Extra. Import Core. -#[global]Hint Opaque subst_term: rewrite. +#[global] Hint Opaque subst_term: rewrite. -#[global]Hint Opaque ren_term: rewrite. +#[global] Hint Opaque ren_term: rewrite. End Extra. diff --git a/theories/AutoSubst/Ast_preamble b/theories/AutoSubst/Ast_preamble index 28af9d37..6ae04b32 100644 --- a/theories/AutoSubst/Ast_preamble +++ b/theories/AutoSubst/Ast_preamble @@ -1,5 +1,5 @@ From LogRel.AutoSubst Require Import core unscoped. -From LogRel Require Import BasicAst. +From LogRel.Syntax Require Import BasicAst. From Coq Require Import Setoid Morphisms Relation_Definitions. diff --git a/theories/AutoSubst/Extra.v b/theories/AutoSubst/Extra.v index 35646a5b..d15b6a80 100644 --- a/theories/AutoSubst/Extra.v +++ b/theories/AutoSubst/Extra.v @@ -3,8 +3,10 @@ (** This is the only file in the AutoSubst submodule that is not automatically generated. *) From smpl Require Import Smpl. From Coq Require Import ssrbool List. -From LogRel.AutoSubst Require Import core unscoped Ast. -From LogRel Require Import Utils BasicAst. +From Equations Require Import Equations. +From LogRel.AutoSubst Require Export core unscoped Ast. +From LogRel Require Import Utils. +From LogRel.Syntax Require Import BasicAst. (* Export UnscopedNotations. #[global] Open Scope subst_scope. *) @@ -74,6 +76,9 @@ Proof. now asimpl. Qed. Lemma shift_up_eq {t σ} : t⟨↑⟩[up_term_term σ] = t[σ]⟨↑⟩. Proof. now asimpl. Qed. +Lemma shift_one_eq t a : t⟨↑⟩[a..] = t. +Proof. now asimpl. Qed. + Lemma up_single_subst {t σ u} : t[up_term_term σ][u..] = t[u .: σ]. Proof. now asimpl. Qed. @@ -88,4 +93,6 @@ Lemma liftSubst_scons_eq {t u v: term} σ : t[u]⇑[v .: σ] = t[u[v .: σ] .: Proof. now asimpl. Qed. Definition elimSuccHypTy P := - tProd tNat (arr P P[tSucc (tRel 0)]⇑). \ No newline at end of file + tProd tNat (arr P P[tSucc (tRel 0)]⇑). + +Equations Derive NoConfusion Subterm for term. \ No newline at end of file diff --git a/theories/BundledAlgorithmicTyping.v b/theories/BundledAlgorithmicTyping.v deleted file mode 100644 index 83213535..00000000 --- a/theories/BundledAlgorithmicTyping.v +++ /dev/null @@ -1,1085 +0,0 @@ -(** * LogRel.BundledAlgorithmicTyping: algorithmic typing bundled with its pre-conditions, and a tailored induction principle. *) -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening UntypedReduction GenericTyping DeclarativeTyping DeclarativeInstance AlgorithmicTyping DeclarativeSubst TypeConstructorsInj. - -Import DeclarativeTypingProperties AlgorithmicTypingData. - -(** ** Definition of bundled algorithmic typing *) - -Definition bn : tag. -Proof. -constructor. -Qed. - -Definition bni : tag. -Proof. -constructor. -Qed. - -(** The idea of these definitions is to put together an algorithmic derivation with the -pre-conditions that ensure it is sensible. Indeed, for instance [Γ |-[al] A] does not -re-check that Γ is well-typed: in the algorithm, this information is instead maintained as -an invariant. But this means that algorithmic variants, do not unconditionally -imply its declarative counterpart, they only do so if their pre-conditions are fulfilled, -eg if the context or type are well-formed. *) - -(** Also note that in the case of judgements that “output” a type, ie type inference and -neutral conversion, we allow for an arbitrary conversion to “rectify” the output type. -This makes it easier to handle these in the logical relation, because it means the interface -is stable by arbitrary conversion. *) - -(** In the case of a context, there is no judgement, only a pre-condition, as algorithmic -typing never re-checks a context. *) -Record WfContextBun Γ := -{ - bn_wf_ctx : [|-[de] Γ] ; -}. - -Record WfTypeBun Γ A := -{ - bun_wf_ty_ctx : [|-[de] Γ] ; - bun_wf_ty : [Γ |-[al] A] ; -}. - -Record InferBun Γ A t := -{ - bun_inf_ctx : [|-[de] Γ] ; - bun_inf : [Γ |-[al] t ▹ A] -}. - -Record InferConvBun Γ A t := -{ - bun_inf_conv_ctx : [|-[de] Γ] ; - bun_inf_conv_ty : term ; - bun_inf_conv_inf : [Γ |-[al] t ▹ bun_inf_conv_ty] ; - (** Allows to change the type to any convertible one. *) - bun_inf_conv_conv : [Γ |-[de] bun_inf_conv_ty ≅ A] -}. - -Record InferRedBun Γ A t := -{ - bun_inf_red_ctx : [|-[de] Γ] ; - bun_inf_red : [Γ |-[al] t ▹h A] -}. - -Record CheckBun Γ A t := -{ - bun_chk_ctx : [|-[de] Γ] ; - bun_chk_ty : [Γ |-[de] A] ; - bun_chk : [Γ |-[al] t ◃ A] -}. - -Record ConvTypeBun Γ A B := -{ - bun_conv_ty_ctx : [|-[de] Γ] ; - bun_conv_ty_l : [Γ |-[de] A] ; - bun_conv_ty_r : [Γ |-[de] B] ; - bun_conv_ty : [Γ |-[al] A ≅ B] -}. - -Record ConvTypeRedBun Γ A B := -{ - bun_conv_ty_red_ctx : [|-[de] Γ] ; - bun_conv_ty_red_l : [Γ |-[de] A] ; - bun_conv_ty_red_wh_l : isType A ; - bun_conv_ty_red_r : [Γ |-[de] B] ; - bun_conv_ty_red_wh_r : isType B ; - bun_conv_ty_red : [Γ |-[al] A ≅h B] -}. - -Record ConvTermBun Γ A t u := -{ - bun_conv_tm_ctx : [|-[de] Γ] ; - bun_conv_tm_ty : [Γ |-[de] A] ; - bun_conv_tm_l : [Γ |-[de] t : A] ; - bun_conv_tm_r : [Γ |-[de] u : A] ; - bun_conv_tm : [Γ |-[al] t ≅ u : A] -}. - -Record ConvTermRedBun Γ A t u := -{ - bun_conv_tm_red_ctx : [|-[de] Γ] ; - bun_conv_tm_red_ty : [Γ |-[de] A] ; - bun_conv_tm_red_wh_ty : isType A ; - bun_conv_tm_red_l : [Γ |-[de] t : A] ; - bun_conv_tm_red_wh_l : whnf t ; - bun_conv_tm_red_r : [Γ |-[de] u : A] ; - bun_conv_tm_red_wh_r : whnf u ; - bun_conv_tm_red : [Γ |-[al] t ≅h u : A] -}. - -Record ConvNeuBun Γ A m n := -{ - bun_conv_ne_ctx : [|-[de] Γ] ; - bun_conv_ne_l : well_typed (ta := de) Γ m ; - bun_conv_ne_wh_l : whne m ; - bun_conv_ne_r : well_typed (ta := de) Γ n ; - bun_conv_ne_wh_r : whne n ; - bun_conv_ne : [Γ |-[al] m ~ n ▹ A] -}. - -Record ConvNeuRedBun Γ A m n := -{ - bun_conv_ne_red_ctx : [|-[de] Γ] ; - bun_conv_ne_red_l : well_typed (ta := de) Γ m ; - bun_conv_ne_red_wh_l : whne m ; - bun_conv_ne_red_r : well_typed (ta := de) Γ n ; - bun_conv_ne_red_wh_r : whne n ; - bun_conv_ne_red : [Γ |-[al] m ~h n ▹ A] -}. - -Record ConvNeuConvBun Γ A m n := -{ - bun_conv_ne_conv_ctx : [|-[de] Γ] ; - bun_conv_ne_conv_l : well_typed (ta := de) Γ m ; - bun_conv_ne_conv_wh_l : whne m ; - bun_conv_ne_conv_r : well_typed (ta := de) Γ n ; - bun_conv_ne_conv_wh_r : whne n ; - bun_conv_ne_conv_ty : term ; - bun_conv_ne_conv : [Γ |-[al] m ~ n ▹ bun_conv_ne_conv_ty] ; - bun_conv_ne_conv_conv : [Γ |-[de] bun_conv_ne_conv_ty ≅ A] -}. - -Record RedTypeBun Γ A B := -{ - bun_red_ty_ctx : [|-[de] Γ] ; - bun_red_ty_ty : [Γ |-[al] A] ; - bun_red_ty : [A ⤳* B] ; -}. - -Record OneStepRedTermBun Γ A t u := -{ - bun_osred_tm_ctx : [|-[de] Γ] ; - (** We do not have the instance yet, so we have to specify it by hand, - but this really is [Γ |-[bn] t : A]. *) - bun_osred_tm_tm : typing (ta := bn) (Typing := InferConvBun) Γ A t ; - bun_osred_tm : [t ⤳ u] -}. - -Record RedTermBun Γ A t u := -{ - bun_red_tm_ctx : [|-[de] Γ] ; - bun_red_tm_tm : typing (ta := bn) (Typing := InferConvBun) Γ A t ; - bun_red_tm : [t ⤳* u] ; -}. - -Record RedTypeBunI Γ A B := -{ - buni_red_ty_ctx : [|-[de] Γ] ; - buni_red_ty_ty : [Γ |-[de] A] ; - buni_red_ty : [A ⤳* B] ; -}. - -Record OneStepRedTermBunI Γ A t u := -{ - buni_osred_tm_ctx : [|-[de] Γ] ; - buni_osred_tm_tm : [Γ |-[de] t : A] ; - buni_osred_tm : [t ⤳ u] -}. - -Record RedTermBunI Γ A t u := -{ - buni_red_tm_ctx : [|-[de] Γ] ; - buni_red_tm_tm : [Γ |-[de] t : A] ; - buni_red_tm : [t ⤳* u] ; -}. - -(** ** Instances *) - -(** We actually define two instances, one fully-algorithmic and one where only conversion -is algorithmic, but typing is not. This is needed because we cannot show right away that -(bundled) algorithmic typing has all the properties to be an instance of the generic interface. -The issue is that the logical relation does not give enough properties of neutrals, in particular -we cannot derive that neutral application is injective, ie if [tApp n u] and [tApp n' u'] are -convertible then [n] and [n'] are and so are [u] and [u']. Thus, we use the mixed instance, which -we can readily show, to gather more properties of conversion, enough to show the fully -algorithmic one. *) - -Module BundledTypingData. - - #[export] Instance WfContext_Bundle : WfContext bn := WfContextBun. - #[export] Instance WfType_Bundle : WfType bn := WfTypeBun. - #[export] Instance Inferring_Bundle : Inferring bn := InferBun. - #[export] Instance InferringRed_Bundle : InferringRed bn := InferRedBun. - #[export] Instance Typing_Bundle : Typing bn := InferConvBun. - #[export] Instance Checking_Bundle : Checking bn := CheckBun. - #[export] Instance ConvType_Bundle : ConvType bn := ConvTypeBun. - #[export] Instance ConvTypeRed_Bundle : ConvTypeRed bn := ConvTypeRedBun. - #[export] Instance ConvTerm_Bundle : ConvTerm bn := ConvTermBun. - #[export] Instance ConvTermRed_Bundle : ConvTermRed bn := ConvTermRedBun. - #[export] Instance ConvNeu_Bundle : ConvNeu bn := ConvNeuBun. - #[export] Instance ConvNeuRed_Bundle : ConvNeuRed bn := ConvNeuRedBun. - #[export] Instance ConvNeuConv_Bundle : ConvNeuConv bn := ConvNeuConvBun. - #[export] Instance RedType_Bundle : RedType bn := RedTypeBun. - #[export] Instance OneStepRedTerm_Bundle : OneStepRedTerm bn := OneStepRedTermBun. - #[export] Instance RedTerm_Bundle : RedTerm bn := RedTermBun. - - Ltac fold_bun := - change WfContextBun with (wf_context (ta := bn)) in *; - change WfTypeBun with (wf_type (ta := bn)) in *; - change InferBun with (inferring (ta := bn)) in * ; - change InferRedBun with (infer_red (ta := bn)) in * ; - change InferConvBun with (typing (ta := bn)) in * ; - change CheckBun with (check (ta := bn)) in * ; - change ConvTypeBun with (conv_type (ta := bn)) in * ; - change ConvTermBun with (conv_term (ta := bn)) in * ; - change ConvNeuBun with (conv_neu (ta := bn)) in * ; - change ConvTypeRedBun with (conv_type_red (ta := bn)) in * ; - change ConvTermRedBun with (conv_term_red (ta := bn)) in * ; - change ConvNeuRedBun with (conv_neu_red (ta := bn)) in *; - change ConvNeuConvBun with (conv_neu_conv (ta := bn)) in *; - change RedTypeBun with (red_ty (ta := bn)) in * ; - change OneStepRedTermBun with (osred_tm (ta := bn)) in * ; - change RedTermBun with (red_tm (ta := bn)) in *. - -End BundledTypingData. - -Import BundledTypingData. - -Module BundledIntermediateData. - - #[export] Instance WfContext_BundleInt : WfContext bni := WfContextDecl. - #[export] Instance WfType_BundleInt : WfType bni := WfTypeDecl. - #[export] Instance Typing_BundleInt : Typing bni := TypingDecl. - #[export] Instance ConvType_BundleInt : ConvType bni := ConvTypeBun. - #[export] Instance ConvTerm_BundleInt : ConvTerm bni := ConvTermBun. - #[export] Instance ConvNeuConv_BundleInt : ConvNeuConv bni := ConvNeuConvBun. - #[export] Instance RedType_BundleInt : RedType bni := RedTypeBunI. - #[export] Instance OneStepRedTerm_BundleInt : OneStepRedTerm bni := OneStepRedTermBunI. - #[export] Instance RedTerm_BundleInt : RedTerm bni := RedTermBunI. - - Ltac unfold_bni := - change (wf_context (ta := bni)) with (wf_context (ta := de)) in *; - change (wf_type (ta := bni)) with (wf_type (ta := de)) in *; - change (typing (ta := bni)) with (typing (ta := de)) in * ; - change (conv_type (ta := bni)) with (conv_type (ta := bn)) in * ; - change (conv_term (ta := bni)) with (conv_term (ta := bn)) in * ; - change (conv_neu_conv (ta := bni)) with (conv_neu_conv (ta := bn)) in *. - -End BundledIntermediateData. - -Set Universe Polymorphism. - -(** ** Induction principle for bundled algorithmic conversion *) - -(** We show an induction principle tailored for the bundled predicates: it threads the invariants -of the algorithm through the derivation, giving us stronger hypothesis in the minor premises, -corresponding to both the pre-conditions being true, and the post-conditions of the induction -hypotheses holding. *) - -Section BundledConv. - Universe u. - - Context (PTyEq PTyRedEq : context -> term -> term -> Type@{u}) - (PNeEq PNeRedEq PTmEq PTmRedEq : context -> term -> term -> term -> Type@{u}). - - (** Rather than writing by hand the various large statements of the induction principles, - we use Ltac to derive them generically. Hopefully, there is no need to touch any part of - this code when extending modifying the language with more features. *) - #[local] Ltac pre_cond Hyp := - lazymatch Hyp with - | context [PTyEq ?Γ ?A ?B] => - constr:([|-[de] Γ] -> [Γ |-[de] A] -> [Γ |-[de] B] -> Hyp) - | context [PTyRedEq ?Γ ?A ?B] => - constr:([|-[de] Γ] -> [Γ |-[de] A] -> [Γ |-[de] B] -> Hyp) - | context [PNeEq ?Γ ?A ?t ?u] => - constr:([|-[de] Γ] -> (well_typed (ta := de) Γ t) -> (well_typed (ta := de) Γ u) -> Hyp) - | context [PNeRedEq ?Γ ?A ?t ?u] => - constr:([|-[de] Γ] -> (well_typed (ta := de) Γ t) -> (well_typed (ta := de) Γ u) -> Hyp) - | context [PTmEq ?Γ ?A ?t ?u] => - constr:([|-[de] Γ] -> ([Γ |-[de] t : A]) -> ([Γ |-[de] u : A]) -> Hyp) - | context [PTmRedEq ?Γ ?A ?t ?u] => - constr:([|-[de] Γ] -> ([Γ |-[de] t : A]) -> ([Γ |-[de] u : A]) -> Hyp) - end. - - #[local] Ltac post_cond Hyp := - lazymatch Hyp with - | context C [PTyEq ?Γ ?A ?B] => - context C [PTyEq Γ A B × [Γ |-[de] A ≅ B]] - | context C [PTyRedEq ?Γ ?A ?B] => - context C [PTyRedEq Γ A B × [Γ |-[de] A ≅ B]] - | context C [PNeEq ?Γ ?A ?m ?n] => - context C [PNeEq Γ A m n × - [× ([Γ |-[de] m ≅ n : A]), - (forall T, [Γ |-[de] m : T] -> [Γ |-[de] A ≅ T]) & - (forall T, [Γ |-[de] n : T] -> [Γ |-[de] A ≅ T])]] - | context C [PNeRedEq ?Γ ?A ?m ?n] => - context C [PNeRedEq Γ A m n × - [× ([Γ |-[de] m ≅ n : A]), - (forall T, [Γ |-[de] m : T] -> [Γ |-[de] A ≅ T]) & - (forall T, [Γ |-[de] n : T] -> [Γ |-[de] A ≅ T])]] - | context C [PTmEq ?Γ ?A ?t ?u] => - context C [PTmEq Γ A t u × [Γ |-[de] t ≅ u : A]] - | context C [PTmRedEq ?Γ ?A ?t ?u] => - context C [PTmRedEq Γ A t u × [Γ |-[de] t ≅ u : A]] - | ?Hyp' => Hyp' - end. - - #[local] Ltac bundle Hyp := - lazymatch Hyp with - | [?Γ |-[al] ?A ≅ ?B] => constr:([Γ |-[bn] A ≅ B]) - | [?Γ |-[al] ?A ≅h ?B] => constr:([Γ |-[bn] A ≅h B]) - | [?Γ |-[al] ?t ≅ ?u : ?A] => constr:([Γ |-[bn] t ≅ u : A]) - | [?Γ |-[al] ?t ≅h ?u : ?A] => constr:([Γ |-[bn] t ≅h u : A]) - | [?Γ |-[al] ?m ~ ?n ▹ ?A] => constr:([Γ |-[bn] m ~ n ▹ A]) - | [?Γ |-[al] ?m ~h ?n ▹ ?A] => constr:([Γ |-[bn] m ~h n ▹ A]) - | ?Hyp' => constr:(Hyp') - end. - - #[local] Ltac strong_step step := - lazymatch step with - | ?Hyp -> ?T => let Hyp' := (post_cond Hyp) with T' := (strong_step T) in constr:(Hyp' -> T') - | forall x : ?Hyp, @?T x => constr:(forall x : Hyp, ltac:( - let T' := ltac:(eval hnf in (T x)) in let T'' := strong_step T' in exact T'')) - | ?T => (pre_cond T) - end. - - (* Eval cbn beta in ltac:(let T := strong_step (forall (Γ : context) (na' : aname) (A B A' B' : term), - [Γ |-[ al ] A ≅ A'] -> - PTyEq Γ A A' -> - [Γ,, A |-[ al ] B ≅ B'] -> - PTyEq (Γ,, A) B B' -> PTyRedEq Γ (tProd A B) (tProd na' A' B')) in exact T). - *) - - #[local] Ltac weak_concl concl := - lazymatch concl with - | ?Hyp -> ?T => let T' := weak_concl T in let Hyp' := bundle Hyp in constr:(Hyp' -> T') - | forall x : ?Hyp, @?T x => constr:(forall x : Hyp, ltac:( - let T' := ltac:(eval hnf in (T x)) in let T'' := weak_concl T' in exact T'')) - | ?T => constr:(T) - end. - - #[local] Ltac strong_concl concl := - lazymatch concl with - | forall x : ?Hyp, @?T x => constr:(forall x : Hyp, ltac:( - let T' := ltac:(eval hnf in (T x)) in let T'' := strong_concl T' in exact T'')) - | ?T => let T' := (post_cond T) in let T'' := (pre_cond T') in constr:(T'') - end. - - #[local] Ltac strong_statement T := - lazymatch T with - | ?Step -> ?T => let Step' := strong_step Step in let T' := strong_statement T in constr:(Step' -> T') - | ?Chd × ?Ctl => let Chd' := strong_concl Chd in let Ctl' := strong_statement Ctl in constr:(Chd' × Ctl') - | ?Cend => let Cend' := strong_concl Cend in constr:(Cend') - end. - - #[local] Ltac weak_statement T := - lazymatch T with - | ?Step -> ?T => let Step' := strong_step Step in let T' := weak_statement T in constr:(Step' -> T') - | ?Chd × ?Ctl => let Chd' := weak_concl Chd in let Ctl' := weak_statement Ctl in constr:(Chd' × Ctl') - | ?Chd × ?Ctl => let Chd' := weak_concl Chd in let Ctl' := weak_statement Ctl in constr:(Chd' × Ctl') - | ?Cend => let Cend' := weak_concl Cend in constr:(Cend') - end. - - #[local] Definition algo_conv_discipline_stmt := - ltac:( - let t := (type of (AlgoConvInduction PTyEq PTyRedEq PNeEq PNeRedEq PTmEq PTmRedEq)) in - let ind := strong_statement t in - exact ind). - - (** The main theorem *) - Theorem algo_conv_discipline : algo_conv_discipline_stmt. - Proof. - unfold algo_conv_discipline_stmt; intros. - apply AlgoConvInduction. - - intros * HA HB ? IHA' ? ? ?. - pose proof (HA' := HA). - pose proof (HB' := HB). - eapply subject_reduction_type, RedConvTyC in HA', HB' ; tea. - destruct IHA'. - 1-3: boundary. - split ; [now eauto|..]. - symmetry in HB'. - do 2 etransitivity ; tea. - now econstructor. - - intros * ? IHA ? IHB ? HP HP'. - eapply prod_ty_inv in HP as [], HP' as [? HB']. - assert [Γ,, A |-[de] B']. - { eapply stability ; tea. - econstructor. - 1: now eapply ctx_refl. - now eapply IHA. - } - split ; [gen_typing|..]. - destruct IHB as []. - 1-3: gen_typing. - now econstructor. - - intros. - split ; [now eauto|..]. - now gen_typing. - - intros * ?? _. - split ; [gen_typing|..]. - now econstructor. - - intros * ?? _. - split ; [gen_typing|..]. - now econstructor. - - intros * ? IHA ? IHB ? HP HP'. - eapply sig_ty_inv in HP as [], HP' as [? HB']. - assert [Γ,, A |-[de] B']. - { eapply stability ; tea. - econstructor. - 1: now eapply ctx_refl. - now eapply IHA. - } - split ; [gen_typing|..]. - destruct IHB as []. - 1-3: gen_typing. - now econstructor. - - intros * Hconv IHA ? IHx ? IHy ? HM HN. - pose proof HM as [? []]%id_ty_inv. - pose proof HN as [? []]%id_ty_inv. - assert [Γ |-[de] x' : A] by (eapply wfTermConv; tea; refold; now symmetry). - assert [Γ |-[de] y' : A] by (eapply wfTermConv; tea; refold; now symmetry). - split; [eauto|]. - econstructor; [eapply IHA| eapply IHx | eapply IHy]; eauto. - - intros * Hconv IH ? HM HN. - assert [Γ |-[de] M : U]. - { - eapply algo_conv_wh in Hconv as [neM neN]. - now eapply neutral_ty_inv. - } - assert [Γ |-[de] N : U]. - { - eapply algo_conv_wh in Hconv as [neM neN]. - now eapply neutral_ty_inv. - } - assert (well_typed (ta := de) Γ M) by now eexists. - assert (well_typed (ta := de) Γ N) by now eexists. - split ; [now eauto|..]. - do 2 econstructor. - all: now apply IH. - - intros * Hin ? ? _. - split ; [now eauto|..]. - split. - + do 2 constructor ; gen_typing. - + intros T Hty. - eapply termGen' in Hty as [? [[? [->]] ?]]. - eapply in_ctx_inj in Hin ; tea ; subst. - eassumption. - + intros T Hty. - eapply termGen' in Hty as [? [[? [->]] ?]]. - eapply in_ctx_inj in Hin ; tea ; subst. - eassumption. - - intros * ? IHm ? IHt ? Htym Htyn. - pose proof Htym as [? Htym']. - pose proof Htyn as [? Htyn']. - eapply termGen' in Htym' as [? [[? [? [-> Htym']]] ?]]. - eapply termGen' in Htyn' as [? [[? [? [-> Htyn']]] ?]]. - edestruct IHm as [? [IHmc IHm' IHn']]. - 1: easy. - 1-2: now econstructor. - unshelve eapply IHm', prod_ty_inj in Htym' as []. - unshelve eapply IHn', prod_ty_inj in Htyn' as []. - edestruct IHt. - 1: easy. - 1-2: now gen_typing. - split ; [now eauto|..]. - split. - + econstructor ; gen_typing. - + intros ? Happ. - eapply termGen' in Happ as [? [(?&?&[-> Htym']) ?]]. - eapply IHm', prod_ty_inj in Htym' as []. - etransitivity ; [..|eassumption]. - eapply typing_subst1 ; tea. - now econstructor. - + intros ? Happ. - eapply termGen' in Happ as [? [(?&?&[-> Htyn']) ?]]. - eapply IHn', prod_ty_inj in Htyn' as [HA ?]. - etransitivity ; [..|eassumption]. - eapply typing_subst1. - 2: eassumption. - symmetry in HA. - now gen_typing. - - intros * ? IHn ? IHP ? IHz ? IHs ? Hty Hty'. - pose proof Hty as [? Hty2]. - pose proof Hty' as [? Hty2']. - eapply termGen' in Hty2 as [? [[->]]]. - eapply termGen' in Hty2' as [? [[->]]]. - edestruct IHn as [? [IHnc IHnty IHnty']]. - 1: easy. - 1-2: now eexists. - assert [|-[de] Γ,, tNat] by boundary. - assert [Γ,, tNat |-[de] P ≅ P'] - by now edestruct IHP. - assert [Γ |-[de] hz' : P[tZero..]]. - { - econstructor ; tea. - symmetry. - eapply typing_subst1 ; tea. - now do 2 econstructor. - } - assert [Γ |-[de] hs' : elimSuccHypTy P]. - { - econstructor ; tea. - symmetry. - now eapply elimSuccHypTy_conv. - } - split ; [eauto 10 |..]. - split. - + now econstructor. - + now intros ?[? [[->]]]%termGen'. - + intros ?[? [[->]]]%termGen'. - etransitivity. - 1: eapply typing_subst1. - all: eassumption. - - intros * ? IHe ? IHP ? Hty Hty'. - pose proof Hty as [? Hty2]. - pose proof Hty' as [? Hty2']. - eapply termGen' in Hty2 as [? [[->]]]. - eapply termGen' in Hty2' as [? [[->]]]. - edestruct IHe as [? [IHec IHnty IHnty']]. - 1: easy. - 1-2: now eexists. - assert [|-[de] Γ,, tEmpty] by boundary. - assert [Γ,, tEmpty |-[de] P ≅ P'] - by now edestruct IHP. - split ; [eauto |..]. - split. - + now econstructor. - + now intros ?[? [[->]]]%termGen'. - + intros ?[? [[->]]]%termGen'. - etransitivity. - 1: eapply typing_subst1. - all: eassumption. - - intros * ? ih ? hm hn. - pose proof hm as [? [?[[?[?[->]]]]]%termGen']. - pose proof hn as [? [?[[?[?[->]]]]]%termGen']. - edestruct ih as [? [? ihm ihn]]; tea. - 1,2: now eexists. - split; [eauto| split]. - + now econstructor. - + intros ? [?[[?[?[-> []%ihm%sig_ty_inj]]]]]%termGen'. - etransitivity; tea; now symmetry. - + intros ? [?[[?[?[-> []%ihn%sig_ty_inj]]]]]%termGen'. - etransitivity; tea; now symmetry. - - intros * ? ih ? hm hn. - pose proof hm as [? [?[[?[?[-> hm']]]]]%termGen']. - pose proof hn as [? [?[[?[?[->]]]]]%termGen']. - edestruct ih as [? [? ihm ihn]]; tea. - 1,2: now eexists. - split; [eauto| split]. - + now econstructor. - + intros ? [?[[?[?[-> h%ihm]]]]]%termGen'. - pose proof h as []%sig_ty_inj. - etransitivity; tea. - eapply typing_subst1; tea; econstructor; eapply TermConv; tea. - refold; now eapply lrefl. - + intros ? [?[[?[?[-> h%ihn]]]]]%termGen'. - pose proof h as []%sig_ty_inj. - etransitivity; tea. - eapply typing_subst1; tea; econstructor; eapply TermConv; tea. - - intros * ? ihe (*? ihA'' ? ihx'' ? ihy''*) ? ihA ? ihx ? ihP ? ihhr ? ihy ? hm hn. - pose proof hm as [? [? [[-> ????? he]]]%termGen']. - pose proof hn as [? [? [[->]]]%termGen']. - edestruct ihe as [? [? ihm ihn]]; tea. - 1,2: now eexists. - pose proof (ihm _ he). - assert [Γ |-[de] A ≅ A'] by now eapply ihA. - assert [Γ |-[de] x' : A] by (eapply wfTermConv; tea; refold; now symmetry). - assert [Γ |-[de] x ≅ x' : A] by now eapply ihx. - assert [Γ |-[de] y' : A] by (eapply wfTermConv; tea; refold; now symmetry). - assert [ |-[ de ] (Γ,, A),, tId A⟨wk1 A⟩ x⟨wk1 A⟩ (tRel 0)] by boundary. - assert [(Γ,, A),, tId A⟨@wk1 Γ A⟩ x⟨@wk1 Γ A⟩ (tRel 0) |-[ de ] P']. - 1: eapply stability; tea; symmetry; eapply idElimMotiveCtxConv; tea; now boundary + eapply ctx_refl. - assert [(Γ,, A),, tId A⟨@wk1 Γ A⟩ x⟨@wk1 Γ A⟩ (tRel 0) |-[ de ] P ≅ P'] by now eapply ihP. - assert [Γ |-[ de ] hr' : P[tRefl A x .: x..]]. - 1:{ - eapply wfTermConv; tea; refold; symmetry. - eapply typing_subst2; tea. - cbn; rewrite 2!wk1_ren_on, 2!shift_subst_eq; now econstructor. - } - split. 1: eapply X13; eauto. (* ?? *) - split. - + econstructor; tea; [now eapply ihhr| now eapply ihy| now eapply TermConv]. - + now intros ? [? [[->]]]%termGen'. - + intros ? [? [[->]]]%termGen'; transitivity (P'[e' .: y'..]) ; tea. - eapply typing_subst2; tea; [now eapply ihy|]. - cbn; rewrite 2!wk1_ren_on, 2!shift_subst_eq. - eapply TermConv; tea; eapply ihe; tea; now eexists. - - intros * ? IHm HA ? ? Htym Htyn. - pose proof Htym as [? Htym']. - pose proof Htyn as [? Htyn']. - edestruct IHm as [_ [IHmc IHm' IHn']]. - 1: easy. - 1-2: now eexists. - pose proof (HA' := HA). - eapply subject_reduction_type, RedConvTyC in HA'. - 2: boundary. - split ; [now eauto|..]. - split. - + gen_typing. - + intros. - symmetry in HA'. - etransitivity ; gen_typing. - + intros. - symmetry in HA'. - etransitivity ; gen_typing. - - intros * HA Ht Hu ? IH ? Htyt Htyu. - pose proof (HA' := HA). - pose proof (Ht' := Ht). - pose proof (Hu' := Hu). - eapply subject_reduction_type, RedConvTyC in HA'. - 2: boundary. - eapply subject_reduction, RedConvTeC in Ht' ; tea. - eapply subject_reduction, RedConvTeC in Hu' ; tea. - pose proof (Ht'' := Ht'). - pose proof (Hu'' := Hu'). - eapply boundary in Ht'' as [], Hu'' as []. - split ; [now gen_typing|..]. - etransitivity ; [..|etransitivity]. - 1: eassumption. - 2: now symmetry. - econstructor. - 2: now symmetry. - eapply IH. - all: gen_typing. - - intros * ? IHA ? IHB ? Hty Hty'. - pose proof (Htyd := Hty). - pose proof (Htyd' := Hty'). - eapply termGen' in Htyd as [? [[->] _]]. - eapply termGen' in Htyd' as [? [[->] _]]. - assert [Γ,, A |-[de] B' : U]. - { eapply stability ; tea. - econstructor. - 1: now eapply ctx_refl. - now econstructor. - } - split ; [now gen_typing|..]. - econstructor. - + assumption. - + now eapply IHA. - + now eapply IHB ; gen_typing. - - intros. - split ; [eauto|..]. - now econstructor. - - intros. - split ; [eauto|..]. - now econstructor. - - intros * ? IHt ? Htyt Htyt'. - pose proof (Htyd := Htyt). - pose proof (Htyd' := Htyt'). - eapply termGen' in Htyd as [? [[->] _]]. - eapply termGen' in Htyd' as [? [[->] _]]. - split ; [eauto|..]. - now econstructor. - - intros. - split ; eauto. - now econstructor. - - intros * ? ? ? IH ? Hf Hg. - assert [Γ |-[de] A] by - (now eapply boundary, prod_ty_inv in Hf). - pose proof (Hf' := Hf). - pose proof (Hg' := Hg). - eapply typing_eta' in Hf'. - eapply typing_eta' in Hg'. - split ; [now gen_typing|..]. - etransitivity; [|now eapply TermFunEta]. - etransitivity; [symmetry; now eapply TermFunEta|]. - econstructor ; tea; try now constructor. - now eapply IH ; gen_typing. - - intros * ? ihA ? ihB ? hty hty'. - pose proof hty as [?[[->]]]%termGen'. - pose proof hty' as [?[[->]]]%termGen'. - edestruct ihA as []; tea. - edestruct ihB as []; tea. - 1: gen_typing. - 1: eapply stability1; tea; gen_typing. - split ; [eauto|now econstructor]. - - intros * ??? ihfst ? ihsnd ? hp hq. - edestruct ihfst as []; tea. - 1,2: now econstructor. - pose proof hp as []%boundary%sig_ty_inv. - edestruct ihsnd as []; tea. - 1: now econstructor. - 2:{ split; [eauto|]. - eapply TermTrans; [|now constructor]. - eapply TermTrans; [eapply TermSym; now constructor|]. - constructor; tea; now apply TypeRefl. } - eapply wfTermConv; [now econstructor|]. - eapply typing_subst1; [now symmetry|]. - now eapply TypeRefl. - - intros * ? ihA ? ihx ? ihy ? hm hn. - pose proof hm as [?[[->]]]%termGen'. - pose proof hn as [?[[->]]]%termGen'. - assert [Γ |-[de] A ≅ A'] by (econstructor; now eapply ihA). - assert [Γ |-[de] x' : A] by (eapply wfTermConv; tea; refold; now symmetry). - assert [Γ |-[de] y' : A] by (eapply wfTermConv; tea; refold; now symmetry). - split; [eauto|]. - econstructor; [eapply ihA|eapply ihx| eapply ihy]; tea. - - intros * ? ihA ? ihx ? hm hn. - pose proof hm as [?[[->]]]%termGen'. - pose proof hn as [?[[-> ??] []%id_ty_inj]]%termGen'. - assert [Γ |-[de] x' : A] by (eapply wfTermConv; tea; refold; now symmetry). - split; [eauto|]. - econstructor; tea; econstructor; tea; now symmetry. - - intros * ? IHm ? ? Htym Htyn. - edestruct IHm as [? [? Hm']]. - 1: easy. - 1-2: now eexists. - split ; [now eauto|..]. - econstructor ; tea. - now eapply Hm'. -Qed. - - Definition BundledConvInductionConcl : Type := - ltac:(let t := eval red in (AlgoConvInductionConcl PTyEq PTyRedEq PNeEq PNeRedEq PTmEq PTmRedEq) in - let t' := weak_statement t in exact t'). - - (** As a corollary, we get the desired induction principle. The difference with the above one - is that we do not get the post-condition of the algorithm in the conclusion, but this is - in general not necessary. *) - Corollary BundledConvInduction : - ltac:( - let t := (type of (AlgoConvInduction PTyEq PTyRedEq PNeEq PNeRedEq PTmEq PTmRedEq)) in - let ind := weak_statement t in - exact ind). - Proof. - intros. - repeat split. - all: intros * []. - all: apply algo_conv_discipline ; assumption. - Qed. - -End BundledConv. - -(** ** Soundness of algorithmic conversion *) - -(** Contrarily to the induction principle above, if we instantiate the main principle with -only constant true predicates, we get only the post-conditions, ie a soundness theorem: bundled algorithmic conversion judgments imply their declarative counterparts. *) - -Section ConvSoundness. - - Let PTyEq (Γ : context) (A B : term) := - [Γ |-[de] A] -> - [Γ |-[de] B] -> - [Γ |-[de] A ≅ B]. - Let PTmEq (Γ : context) (A t u : term) := - [Γ |-[de] t : A] -> [Γ |-[de] u : A] -> - [Γ |-[de] t ≅ u : A]. - Let PNeEq (Γ : context) (A : term) (m n : term) := - (well_typed (ta := de) Γ m) -> - (well_typed (ta := de) Γ n) -> - [× [Γ |-[de] m ≅ n : A], - (forall T, [Γ |-[de] m : T] -> [Γ |-[de] A ≅ T]) & - (forall T, [Γ |-[de] n : T] -> [Γ |-[de] A ≅ T])]. - - Theorem algo_conv_sound : AlgoConvInductionConcl PTyEq PTyEq PNeEq PNeEq PTmEq PTmEq. - Proof. - subst PTyEq PTmEq PNeEq. - red. - pose proof (algo_conv_discipline - (fun _ _ _ => True) (fun _ _ _ => True) (fun _ _ _ _ => True) - (fun _ _ _ _ => True) (fun _ _ _ _ => True) (fun _ _ _ _ => True)) as [H' H] ; - cycle -1. - 1:{ - repeat (split ; [ - intros ; apply H' ; tea ; match goal with H : well_typed _ _ |- _ => destruct H | _ => idtac end ; gen_typing - | ..] ; clear H' ; try destruct H as [H' H]). - intros ; apply H ; gen_typing. } - all: now constructor. - Qed. - -End ConvSoundness. - -Theorem bn_conv_sound : -BundledConvInductionConcl - (fun Γ A B => [Γ |-[de] A ≅ B]) - (fun Γ A B => [Γ |-[de] A ≅ B]) - (fun Γ A t u => [Γ |-[de] t ≅ u : A]) - (fun Γ A t u => [Γ |-[de] t ≅ u : A]) - (fun Γ A t u => [Γ |-[de] t ≅ u : A]) - (fun Γ A t u => [Γ |-[de] t ≅ u : A]). -Proof. - red. - prod_splitter. - all: intros * []. - all: match goal with H : context [al] |- _ => eapply algo_conv_sound in H end. - all: prod_hyp_splitter. - all: try eassumption. - all: now eexists. -Qed. - -(** ** Induction principle for bundled algorithmic typing *) - -(** This is repeating the same ideas as before, but for typing. *) - -Section BundledTyping. - - Context (PTy : context -> term -> Type) - (PInf PInfRed PCheck : context -> term -> term -> Type). - - #[local] Ltac pre_cond Hyp := - lazymatch Hyp with - | context [PTy ?Γ ?A] => - constr:([|-[de] Γ] -> Hyp) - | context [PInf ?Γ ?A ?t] => - constr:([|-[de] Γ] -> Hyp) - | context [PInfRed ?Γ ?A ?t] => - constr:([|-[de] Γ] -> Hyp) - | context [PCheck ?Γ ?A ?t] => - constr:([|-[de] Γ] -> [Γ |-[de] A] -> Hyp) - end. - - #[local] Ltac post_cond Hyp := - lazymatch Hyp with - | context C [PTy ?Γ ?A] => - context C [PTy Γ A × [Γ |-[de] A]] - | context C [PInf ?Γ ?A ?t] => - context C [PInf Γ A t × [Γ |-[de] t : A]] - | context C [PInfRed ?Γ ?A ?t] => - context C [PInfRed Γ A t × [Γ |-[de] t : A]] - | context C [PCheck ?Γ ?A ?t] => - context C [PCheck Γ A t × [Γ |-[de] t : A]] - | ?Hyp' => Hyp' - end. - - #[local] Ltac bundle Hyp := - lazymatch Hyp with - | [?Γ |-[al] ?A] => constr:([Γ |-[bn] A]) - | [?Γ |-[al] ?t ▹ ?A] => constr:([Γ |-[bn] t ▹ A]) - | [?Γ |-[al] ?t ▹h ?A] => constr:([Γ |-[bn] t ▹h A]) - | [?Γ |-[al] ?t ◃ ?A] => constr:([Γ |-[bn] t ◃ A]) - | ?Hyp' => constr:(Hyp') - end. - - #[local] Ltac strong_step step := - lazymatch step with - | ?Hyp -> ?T => let Hyp' := (post_cond Hyp) with T' := (strong_step T) in constr:(Hyp' -> T') - | forall x : ?Hyp, @?T x => constr:(forall x : Hyp, ltac:( - let T' := ltac:(eval hnf in (T x)) in let T'' := strong_step T' in exact T'')) - | ?T => (pre_cond T) - end. - - #[local] Ltac weak_concl concl := - lazymatch concl with - | ?Hyp -> ?T => let T' := weak_concl T in let Hyp' := bundle Hyp in constr:(Hyp' -> T') - | forall x : ?Hyp, @?T x => constr:(forall x : Hyp, ltac:( - let T' := ltac:(eval hnf in (T x)) in let T'' := weak_concl T' in exact T'')) - | ?T => constr:(T) - end. - - #[local] Ltac strong_concl concl := - lazymatch concl with - | forall x : ?Hyp, @?T x => constr:(forall x : Hyp, ltac:( - let T' := ltac:(eval hnf in (T x)) in let T'' := strong_concl T' in exact T'')) - | ?T => let T' := (post_cond T) in let T'' := (pre_cond T') in constr:(T'') - end. - - #[local] Ltac strong_statement T := - lazymatch T with - | ?Step -> ?T => let Step' := strong_step Step in let T' := strong_statement T in constr:(Step' -> T') - | ?Chd × ?Ctl => let Chd' := strong_concl Chd in let Ctl' := strong_statement Ctl in constr:(Chd' × Ctl') - | ?Cend => let Cend' := strong_concl Cend in constr:(Cend') - end. - - #[local] Ltac weak_statement T := - lazymatch T with - | ?Step -> ?T => let Step' := strong_step Step in let T' := weak_statement T in constr:(Step' -> T') - | ?Chd × ?Ctl => let Chd' := weak_concl Chd in let Ctl' := weak_statement Ctl in constr:(Chd' × Ctl') - | ?Chd × ?Ctl => let Chd' := weak_concl Chd in let Ctl' := weak_statement Ctl in constr:(Chd' × Ctl') - | ?Cend => let Cend' := weak_concl Cend in constr:(Cend') - end. - - Let PTy' (c : context) (t : term) := - [ |-[ de ] c] -> PTy c t × [c |-[ de ] t]. - Let PInf' (c : context) (t t1 : term) := - [ |-[ de ] c] -> PInf c t t1 × [c |-[ de ] t1 : t]. - Let PInfRed' (c : context) (t t1 : term) := - [ |-[ de ] c] -> PInfRed c t t1 × [c |-[ de ] t1 : t]. - Let PCheck' (c : context) (t t1 : term) := - [ |-[ de ] c] -> - [c |-[ de ] t] -> PCheck c t t1 × [c |-[ de ] t1 : t]. - - (** The main theorem *) - Theorem algo_typing_discipline : ltac:( - let t := (type of (AlgoTypingInduction PTy PInf PInfRed PCheck)) in - let ind := strong_statement t in - exact ind). - Proof. - intros. - subst PTy' PInf' PInfRed' PCheck'. - apply AlgoTypingInduction. - 1-10: solve [intros ; - repeat unshelve ( - match reverse goal with - | IH : context [prod] |- _ => destruct IH ; [..|shelve] ; gen_typing - end) ; - now split ; [|econstructor] ; eauto]. - - intros * ? IHI ? IHC ?. - destruct IHI as [? IHt]. - 1: gen_typing. - destruct IHC ; tea. - 1: now eapply boundary, prod_ty_inv in IHt as []. - split ; [|econstructor] ; eauto. - - intros. - split ; [eauto|..]. - now econstructor. - - intros. - split ; [eauto|..]. - now econstructor. - - intros. - split ; [eauto|..]. - now econstructor. - - intros * ? IHn ? IHP ? IHz ? IHs ?. - assert [|-[de] Γ,, tNat] - by (econstructor ; tea ; now econstructor). - assert [Γ |-[ de ] P[tZero..]]. - { - eapply typing_subst1. - 1: now econstructor. - now eapply IHP. - } - assert [Γ |-[de] elimSuccHypTy P] - by now eapply elimSuccHypTy_ty. - split ; [eauto 10 |..]. - econstructor. - + now eapply IHP. - + now eapply IHz. - + now eapply IHs. - + now eapply IHn. - - intros. - split ; [eauto|..]. - now econstructor. - - intros * ? IHe ? IHP ?. - assert [|-[de] Γ,, tEmpty] - by (econstructor ; tea ; now econstructor). - split ; [eauto|..]. - econstructor. - + now eapply IHP. - + now eapply IHe. - - intros * ? ihA ? ihB ?. - edestruct ihA as []; tea. - edestruct ihB as []. - 1: gen_typing. - split; [eauto|now econstructor]. - - intros * ? ihA ? ihB ? iha ? ihb ?. - edestruct ihA as []; tea. - edestruct ihB as []. - 1: gen_typing. - edestruct iha as []; tea. - edestruct ihb as []; tea. - 1: now eapply typing_subst1. - split;[eauto|now econstructor]. - (* why is that not found by eauto ? *) - eapply X17; tea; now split. - - intros * ? ih ?. - edestruct ih as []; tea. - split;[eauto|now econstructor]. - - intros * ? ih ?. - edestruct ih as []; tea. - split;[eauto|now econstructor]. - - intros * ? ihA ? ihx ? ihy ?. - edestruct ihA as []; tea. - assert [Γ |-[de] A] by now econstructor. - split; [eauto|]. - econstructor; tea; [now eapply ihx | now eapply ihy]. - - intros * ? ihA ? ihx ?. - assert [Γ |-[de] A] by now eapply ihA. - split; [eauto|]. - econstructor; tea; now eapply ihx. - - intros * ? ihA ? ihx ? ihP ? ihhr ? ihy ? ihe ?. - assert [Γ |-[de] A] by now eapply ihA. - assert [Γ |-[de] x : A] by now eapply ihx. - assert [ |-[ de ] (Γ,, A),, tId A⟨@wk1 Γ A⟩ x⟨@wk1 Γ A⟩ (tRel 0)] by now eapply idElimMotiveCtx. - assert [Γ |-[de] P[tRefl A x .: x..]]. - 1:{ - eapply typing_subst2; tea;[| now eapply ihP]. - cbn;rewrite 2!wk1_ren_on, 2!shift_subst_eq; now econstructor. - } - assert [Γ |-[de] tId A x y] by now econstructor. - split. 1:eapply X22; eauto. (* ??? *) - econstructor; tea; [eapply ihP| eapply ihhr| eapply ihy | eapply ihe]; eauto. - - intros * ? IH HA ?. - destruct IH as [? IH] ; tea. - split ; [eauto|..]. - econstructor ; tea. - eapply subject_reduction_type, RedConvTyC in HA. - 1: eassumption. - now boundary. - - intros * ? IHt HA ?. - destruct IHt as [? IHt] ; eauto. - split ; [eauto|]. - econstructor ; tea. - eapply algo_conv_sound in HA ; tea. - now boundary. - Qed. - - Definition BundledTypingInductionConcl : Type := - ltac:(let t := eval red in (AlgoTypingInductionConcl PTy PInf PInfRed PCheck) in - let t' := weak_statement t in exact t'). - - Corollary BundledTypingInduction : - ltac:( - let t := (type of (AlgoTypingInduction PTy PInf PInfRed PCheck)) in - let ind := weak_statement t in - exact ind). - Proof. - intros. - repeat match goal with |- prod _ _ => split end. - all: intros * []. - all: apply algo_typing_discipline ; assumption. - Qed. - -End BundledTyping. - -Section TypingSoundness. - - Let PTy (Γ : context) (A : term) := - [|-[de] Γ] -> [Γ |-[de] A]. - Let PInf (Γ : context) (A t : term) := - [|-[de] Γ] -> - [Γ |-[de] t : A]. - Let PCheck (Γ : context) (A t : term) := - [Γ |-[de] A] -> - [Γ |-[de] t : A]. - - Theorem algo_typing_sound : AlgoTypingInductionConcl PTy PInf PInf PCheck. - Proof. - subst PTy PInf PCheck. - red. - pose proof (algo_typing_discipline - (fun _ _ => True) (fun _ _ _ => True) (fun _ _ _ => True) (fun _ _ _ => True)) as [H' H] - ; - cycle -1. - 1: repeat (split ; [ - intros ; apply H' ; tea ; match goal with H : sigT _ |- _ => destruct H | _ => idtac end ; gen_typing - | ..] ; clear H' ; try destruct H as [H' H]). - 1: now intros ; apply H ; gen_typing. - all: now constructor. - Qed. - -End TypingSoundness. - -Theorem bn_alg_typing_sound : -BundledTypingInductionConcl - (fun Γ A => [Γ |-[de] A]) - (fun Γ A t => [Γ |-[de] t : A]) - (fun Γ A t => [Γ |-[de] t : A]) - (fun Γ A t => [Γ |-[de] t : A]). -Proof. - red. - prod_splitter. - all: intros * []. - all: match goal with H : context [al] |- _ => eapply algo_typing_sound in H end. - all: prod_hyp_splitter. - all: now eassumption. -Qed. - -Lemma bn_typing_sound Γ t A : - [Γ |-[bn] t : A] -> [Γ |-[de] t : A]. -Proof. - intros [???Hty?]. - econstructor ; tea. - now eapply algo_typing_sound in Hty. -Qed. - -Corollary inf_conv_decl Γ t A A' : -[Γ |-[al] t ▹ A] -> -[Γ |-[de] A ≅ A'] -> -[Γ |-[de] t : A']. -Proof. - intros Ht Hconv. - apply algo_typing_sound in Ht. - 2: boundary. - now econstructor. -Qed. \ No newline at end of file diff --git a/theories/Consequences.v b/theories/Consequences.v deleted file mode 100644 index 47077003..00000000 --- a/theories/Consequences.v +++ /dev/null @@ -1,95 +0,0 @@ -(** * LogRel.Consequences: important meta-theoretic consequences of normalization: canonicity of natural numbers and consistency. *) -From Coq Require Import CRelationClasses. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening UntypedReduction - LogicalRelation Fundamental Validity LogicalRelation.Induction Substitution.Escape LogicalRelation.Irrelevance - GenericTyping DeclarativeTyping DeclarativeInstance TypeConstructorsInj Normalisation. - - -Import DeclarativeTypingData DeclarativeTypingProperties. - - -Lemma no_neutral_empty_ctx {A t} : whne t -> [ε |-[de] t : A] -> False. -Proof. - intros wh; induction wh in A |- *. - - intros [? [[? [?? h]]]]%termGen'; inversion h. - - intros [? [[? [? []]]]]%termGen'; eauto. - - intros [? [[? []]]]%termGen'; eauto. - - intros [? [[? []]]]%termGen'; eauto. - - intros [? [[? [? []]]]]%termGen'; eauto. - - intros [? [[? [? []]]]]%termGen'; eauto. - - intros [? [[?]]]%termGen'; eauto. -Qed. - -Lemma wty_norm {Γ t A} : [Γ |- t : A] -> - ∑ wh, [× whnf wh, [Γ |- t ⤳* wh : A]& [Γ |- wh : A]]. -Proof. - intros wtyt. - pose proof (normalisation wtyt) as [wh red]. - pose proof (h := subject_reduction _ _ _ _ wtyt red). - assert [Γ |- wh : A] by (destruct h; boundary). - now eexists. -Qed. - -(** *** Consistency: there are no closed proofs of false, i.e. no closed inhabitants of the empty type. *) - -Lemma consistency {t} : [ε |- t : tEmpty] -> False. -Proof. - intros [wh []]%wty_norm; refold. - eapply no_neutral_empty_ctx; tea. - eapply empty_isEmpty; tea. -Qed. - -Print Assumptions consistency. - -(** *** Canonicity: every closed natural number is a numeral, i.e. an iteration of [tSucc] on [tZero]. *) - -Section NatCanonicityInduction. - - Let numeral : nat -> term := fun n => Nat.iter n tSucc tZero. - - #[local] Coercion numeral : nat >-> term. - - #[local] Lemma red_nat_empty : [ε ||-Nat tNat]. - Proof. - repeat econstructor. - Qed. - - Lemma nat_red_empty_ind : - (forall t u, [ε ||-Nat t ≅ u : tNat | red_nat_empty] -> - ∑ n : nat, [ε |- t ≅ n : tNat]) × - (forall t u, NatPropEq red_nat_empty t u -> ∑ n : nat, [ε |- t ≅ n : tNat]). - Proof. - apply NatRedEqInduction. - - intros * [? []] ? ? _ [n] ; refold. - exists n. - now etransitivity. - - exists 0 ; cbn. - now repeat constructor. - - intros ? ? _ [n]. - exists (S n) ; simpl. - now econstructor. - - intros ? ? [? ? []]. - exfalso. - now eapply no_neutral_empty_ctx. - Qed. - - Lemma _nat_canonicity {t} : [ε |- t : tNat] -> - ∑ n : nat, [ε |- t ≅ n : tNat]. - Proof. - intros Ht. - assert [LRNat_ one red_nat_empty | ε ||- t : tNat] as ?%nat_red_empty_ind. - { - apply Fundamental in Ht as [?? Vt%reducibleTmEq]. - irrelevance. - } - now assumption. - Qed. - -End NatCanonicityInduction. - -Lemma nat_canonicity {t} : [ε |- t : tNat] -> - ∑ n : nat, [ε |- t ≅ Nat.iter n tSucc tZero : tNat]. -Proof. - now apply _nat_canonicity. -Qed. \ No newline at end of file diff --git a/theories/Decidability.v b/theories/Decidability.v index 60285e3c..2d6b8516 100644 --- a/theories/Decidability.v +++ b/theories/Decidability.v @@ -1,17 +1,28 @@ (** * LogRel.Decidability: type-checking is decidable. *) From Equations Require Import Equations. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Context Notations UntypedReduction DeclarativeTyping DeclarativeInstance GenericTyping NormalForms. -From LogRel Require Import AlgorithmicTyping BundledAlgorithmicTyping AlgorithmicConvProperties AlgorithmicTypingProperties. +From LogRel Require Import Utils Syntax.All DeclarativeTyping GenericTyping + AlgorithmicTyping BundledAlgorithmicTyping AlgorithmicConvProperties + AlgorithmicTypingProperties PropertiesDefinition NeutralConvProperties LogRelConsequences. + From LogRel.Decidability Require Import Functions Soundness Completeness Termination. From PartialFun Require Import Monad PartialFun MonadExn. -Import AlgorithmicTypingData DeclarativeTypingProperties. +Import AlgorithmicTypingProperties DeclarativeTypingProperties. +Set Universe Polymorphism. + +Import IntermediateTypingProperties BundledTypingData. + +#[local]Existing Instance TypingSubstLogRel. +#[local]Existing Instance RedCompleteLogRel. +#[local]Existing Instance TypeConstructorsInjLogRel. +#[local]Existing Instance NormalisationLogRel. +#[local]Existing Instance ConvCompleteLogRel. +#[local]Existing Instance TypingCompleteLogRel. -Definition inspect {A} (a : A) : {b | a = b} := - exist _ a eq_refl. +Definition inspect {A} (a : A) : ∑ b, a = b := + (a;eq_refl). -Notation "x 'eqn:' p" := (exist _ x p) (only parsing, at level 20). +Notation "x 'eqn:' p" := ((x;p)) (only parsing, at level 20). #[global] Obligation Tactic := idtac. @@ -19,23 +30,24 @@ Obligation Tactic := idtac. Equations check (Γ : context) (t T : term) (hΓ : [|- Γ]) (hT : [Γ |- T]) : [Γ |- t : T] + ~[Γ |- t : T] := -check Γ t T hΓ hT with (inspect (def typing (check_state;Γ;T;t) _)) := +check Γ t T hΓ hT with (inspect (def (typing tconv) (check_state;Γ;T;t) _)) := { | success _ eqn: e => inl _ | exception _ eqn: e => inr _ }. Next Obligation. intros. - now apply typing_terminates. + apply typing_terminates ; tea. + - apply implem_tconv_sound. + - now intros ; eapply tconv_terminates. Qed. Next Obligation. - intros. + intros * e ; cbn in *. apply bn_alg_typing_sound. - set (Hter := check_obligations_obligation_1 _ _ _ _ _) in *. - clearbody Hter. - pose proof (def_graph_sound _ _ Hter) as Hgraph. + epose proof (def_graph_sound _ _ _) as Hgraph. rewrite e in Hgraph. apply implem_typing_sound in Hgraph ; cbn in Hgraph. + 2: apply implem_tconv_sound. now constructor. Qed. Next Obligation. @@ -43,16 +55,20 @@ Next Obligation. set (Hter := check_obligations_obligation_1 _ _ _ _ _) in *. clearbody Hter. pose proof (def_graph_sound _ _ Hter) as Hgraph. - enough (graph typing (check_state;Γ;T;t) ok). + enough (graph (typing tconv) (check_state;Γ;T;t) ok). { eapply orec_graph_functional in Hgraph ; tea. assert (ok = exception e0) as [=] by (etransitivity ; eassumption). } - eapply algo_typing_complete in Hty as []. + + change [Γ |-[de] t : T] in Hty. + eapply (tm_compl (ta' := bn)) in Hty as []. + apply typing_complete. + 1: now apply implem_conv_complete. constructor ; tea. econstructor ; tea. - now eapply algo_conv_complete. + now apply ty_conv_compl. Qed. -Print Assumptions check. +Print Assumptions check. \ No newline at end of file diff --git a/theories/Decidability/Completeness.v b/theories/Decidability/Completeness.v index 91a612c7..e4dcddd0 100644 --- a/theories/Decidability/Completeness.v +++ b/theories/Decidability/Completeness.v @@ -1,27 +1,29 @@ (** * LogRel.Decidability.Completeness: the inductive predicates imply the implementation answer positively. *) From Coq Require Import Nat Lia Arith. From Equations Require Import Equations. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Context Notations UntypedReduction DeclarativeTyping DeclarativeInstance GenericTyping NormalForms. -From LogRel Require Import Validity LogicalRelation Fundamental DeclarativeSubst TypeConstructorsInj AlgorithmicTyping BundledAlgorithmicTyping Normalisation AlgorithmicTypingProperties. +From LogRel Require Import Syntax.All DeclarativeTyping GenericTyping AlgorithmicTyping. +From LogRel.TypingProperties Require Import DeclarativeProperties PropertiesDefinition SubstConsequences TypeConstructorsInj NeutralConvProperties. +From LogRel.Algorithmic Require Import BundledAlgorithmicTyping AlgorithmicConvProperties AlgorithmicTypingProperties. +From LogRel Require Import Utils. + From LogRel.Decidability Require Import Functions Soundness. From PartialFun Require Import Monad PartialFun MonadExn. Set Universe Polymorphism. +#[global] Unset Asymmetric Patterns. -Import DeclarativeTypingProperties. - -Equations Derive NoConfusion Subterm for term. - +Import DeclarativeTypingProperties AlgorithmicTypingData. Section RedImplemComplete. + Context `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)}. + #[local]Definition R_aux := lexprod term term cored term_subterm. #[local]Definition R (t u : term × stack) := R_aux (Datatypes.pair (zip (fst t) (snd t)) (fst t)) (Datatypes.pair (zip (fst u) (snd u)) (fst u)). - #[local]Lemma R_acc t π : + Lemma R_acc t π : Acc cored (zip t π) -> Acc R (t, π). Proof. @@ -37,17 +39,35 @@ Section RedImplemComplete. - eapply well_founded_term_subterm. Qed. - #[local] Lemma well_typed_acc Γ t π : + (* Lemma well_typed_acc Γ t π : well_formed Γ (zip t π) -> Acc R (t,π). Proof. intros. - now eapply R_acc, typing_SN. + now eapply R_acc, typing_acc_cored. + Qed. *) + + Lemma normalising_acc t π t' : + [(zip t π) ⤳* t'] -> + whnf t' -> + Acc R (t,π). + Proof. + intros Hred Hnf. + eapply R_acc. + set (t'' := (zip t π)) in *. + clearbody t''. + clear -Hred Hnf. + induction Hred. + - constructor. + intros ? []. + now edestruct whnf_nored. + - constructor. + now eintros ? [<-%ored_det]. Qed. Lemma well_typed_zip Γ t π : - well_typed Γ (zip t π) -> - ∑ T', [Γ |- t : T'] × (forall u, [Γ |- t ≅ u : T'] -> well_typed Γ (zip u π)). + well_typed (ta := de) Γ (zip t π) -> + ∑ T', [Γ |-[de] t : T'] × (forall u, [Γ |-[de] t ≅ u : T'] -> well_typed (ta := de) Γ (zip u π)). Proof. intros H. induction π as [|[]] in t, H |- * ; cbn. @@ -106,32 +126,17 @@ Section RedImplemComplete. econstructor; tea; eapply TypeRefl + eapply TermRefl; refold; tea. Qed. - Lemma isType_ty Γ T t : - [Γ |- t : T] -> - isType t -> - ~ whne t -> - [Γ |- U ≅ T]. - Proof. - intros Hty HisT Hne. - all: inversion HisT ; subst ; clear HisT ; cycle -1. - 1: now exfalso. - all: clear Hne. - all: eapply termGen' in Hty as (?&[]&?); subst. - all: eassumption. - Qed. - Lemma zip1_notType Γ T t π : isType t -> ~ whne t -> - [Γ |- zip1 t π : T] -> - False. + ~ [Γ |-[de] zip1 t π : T]. Proof. intros Ht Ht' Hty. destruct π ; cbn in * ; eapply termGen' in Hty as (?&[]&?) ; subst ; prod_hyp_splitter ; match goal with H : [_ |-[de] t : _] |- _ => (unshelve eapply isType_ty, ty_conv_inj in H) end ; tea. - all: try solve [now econstructor]. - all: now easy. + all: try solve + [now econstructor| now eapply not_whne_can ; tea ; eapply isType_whnf | now cbn in *]. Qed. Ltac termInvContradiction Hty := @@ -144,14 +149,17 @@ Section RedImplemComplete. end end. - Lemma wh_red_stack_complete Γ t π : + Lemma wh_red_stack_complete Γ t π t' : well_typed Γ (zip t π) -> + [(zip t π) ⤳* t'] -> + whnf t' -> domain wh_red_stack (t,π). Proof. - intros Hty. - pose proof (Hacc := well_typed_acc _ _ _ Hty). + intros Hty Hred Hnf. + pose proof (Hacc := normalising_acc _ _ _ Hred Hnf). change (zip t π) with (zip (fst (t,π)) (snd (t,π))) in *. set (z := (t, π)) in *. clearbody z. + clear Hnf Hred. induction Hacc as [z H IH] in Hty |- *. apply compute_domain. funelim (wh_red_stack z). all: simpl. @@ -230,14 +238,15 @@ Section RedImplemComplete. Corollary wh_red_complete Γ t : well_formed Γ t -> + normalising t -> domain wh_red t. Proof. - intros [|w]%well_formed_well_typed. + intros [|w]%well_formed_well_typed []. all: eapply compute_domain; cbn. all: split ; [|easy]. - eapply wh_red_stack_complete ; tea. - inversion w ; subst ; clear w; cycle -1. - 1: eapply wh_red_stack_complete ; now econstructor. + 1: eapply wh_red_stack_complete ; tea ; now econstructor. all: econstructor ; cbn ; red. all: simp wh_red_stack ; cbn. all: now econstructor. @@ -252,6 +261,7 @@ Section RedImplemComplete. assert (domain wh_red t) as h. { eapply (wh_red_complete Γ). + 2: now econstructor. destruct K as [|A] ; unshelve econstructor ; [left|right|..] ; cbn. 2-3: eassumption. } @@ -285,20 +295,6 @@ Section RedImplemComplete. End RedImplemComplete. -Section ConversionComplete. - -Let PTyEq (Γ : context) (A B : term) := - forall v, graph conv (ty_state;Γ;v;A;B) ok. -Let PTyRedEq (Γ : context) (A B : term) := - forall v, graph conv (ty_red_state;Γ;v;A;B) ok. -Let PNeEq (Γ : context) (A t u : term) := - forall v, graph conv (ne_state;Γ;v;t;u) (success A). -Let PNeRedEq (Γ : context) (A t u : term) := - forall v, graph conv (ne_red_state;Γ;v;t;u) (success A). -Let PTmEq (Γ : context) (A t u : term) := - graph conv (tm_state;Γ;A;t;u) (success tt). -Let PTmRedEq (Γ : context) (A t u : term) := - graph conv (tm_red_state;Γ;A;t;u) (success tt). Definition whne_ne_view1 {N} (w : whne N) : ne_view1 N := match w with @@ -341,34 +337,52 @@ Proof. - rewrite whne_ty_view2 ; cbn ; tea. reflexivity. - unshelve erewrite whne_ty_view1 ; tea. - reflexivity. + cbn. + unshelve erewrite whne_nf_view1 ; tea ; cbn. + destruct (build_nf_view1 _) eqn:e ; try easy. + all: unshelve erewrite whne_nf_view1 in e ; tea. + all: inversion e. Qed. -Arguments PFun_instance_1 : simpl never. - - (* The combinator rec throws in a return branch with a type necessarily convertible to the exception errors type, but the syntactic mismatch between the 2 types prevents `rec_graph` from `apply`ing. This tactic fixes the type in the return branch to what's expected syntactically. *) -Ltac patch_rec_ret := - try (unfold rec; - match goal with - | |- orec_graph _ (_rec _ (fun _ : ?Bx => _)) ?hBa => - let Ba := type of hBa in change Bx with Ba - end). - -Lemma implem_conv_complete : + Ltac patch_rec_ret := + try (unfold rec; + match goal with + | |- orec_graph _ (_rec _ (fun _ : ?Bx => _)) ?hBa => + let Ba := type of hBa in change Bx with Ba + end). + +Section ConversionComplete. + +Context `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)}. + +Let PTyEq (Γ : context) (A B : term) := + forall v, graph _conv (ty_state;Γ;v;A;B) ok. +Let PTyRedEq (Γ : context) (A B : term) := + forall v, graph _conv (ty_red_state;Γ;v;A;B) ok. +Let PNeEq (Γ : context) (A t u : term) := + forall v, graph _conv (ne_state;Γ;v;t;u) (success A). +Let PNeRedEq (Γ : context) (A t u : term) := + forall v, graph _conv (ne_red_state;Γ;v;t;u) (success A). +Let PTmEq (Γ : context) (A t u : term) := + graph _conv (tm_state;Γ;A;t;u) ok. +Let PTmRedEq (Γ : context) (A t u : term) := + graph _conv (tm_red_state;Γ;A;t;u) ok. + +Arguments PFun_instance_1 : simpl never. + +Lemma _implem_conv_complete : BundledConvInductionConcl PTyEq PTyRedEq PNeEq PNeRedEq PTmEq PTmRedEq. Proof. subst PTyEq PTyRedEq PNeEq PNeRedEq PTmEq PTmRedEq. apply BundledConvInduction. - - intros * ?? Hconv [IH] **. + - intros * ?? Hconv [IH] [] **. unfold graph. - simp conv conv_ty ; cbn. - (* destruct v. - change ((conv_full_cod (ty_red_state; Γ; tt; A; B))) with ((conv_full_cod (ty_state; Γ; tt; A; B))). *) + simp _conv conv_ty ; cbn. repeat (match goal with |- orec_graph _ _ _ => econstructor end) ; cbn. + eapply wh_red_complete_whnf_ty ; tea. eapply algo_conv_wh in Hconv as []. @@ -380,26 +394,26 @@ Proof. + cbn; econstructor. - intros * HA [IHA] HB [IHB] ** ; cbn in *. unfold graph. - simp conv conv_ty_red ; cbn. + simp _conv conv_ty_red ; cbn. econstructor. 1: exact (IHA tt). cbn; patch_rec_ret; econstructor. 1: exact (IHB tt). now econstructor. - intros ; cbn in *. unfold graph. - simp conv conv_ty_red ; cbn. + simp _conv conv_ty_red ; cbn. econstructor. - intros. unfold graph. - simp conv conv_ty_red ; cbn. + simp _conv conv_ty_red ; cbn. econstructor. - intros. unfold graph. - simp conv conv_ty_red ; cbn. + simp _conv conv_ty_red ; cbn. econstructor. - intros * HA [IHA] HB [IHB] **; cbn in *. unfold graph. - simp conv conv_ty_red ; cbn. + simp _conv conv_ty_red ; cbn. econstructor. 1: exact (IHA tt). cbn; patch_rec_ret; econstructor. @@ -407,7 +421,7 @@ Proof. now econstructor. - intros * hA [ihA] hx [ihx] hy [ihy] **; cbn in *. unfold graph. - simp conv conv_ty_red. + simp _conv conv_ty_red. econstructor. 1: exact (ihA tt). econstructor. @@ -415,9 +429,9 @@ Proof. cbn; patch_rec_ret; econstructor. 1: exact ihy. now econstructor. - - intros * HM [IHM []] **. + - intros * ?? HM [IHM []] **. unfold graph. - simp conv conv_ty_red ; cbn. + simp _conv conv_ty_red ; cbn. rewrite whne_ty_view2. 2-3: now eapply algo_conv_wh in HM as []. cbn. @@ -426,13 +440,13 @@ Proof. now constructor. - intros **. unfold graph. - simp conv conv_ne. + simp _conv conv_ne. rewrite Nat.eqb_refl ; cbn. erewrite ctx_access_complete ; tea ; cbn. now econstructor. - intros * Hm [IHm []] Ht [IHt] **. unfold graph. - simp conv conv_ne ; cbn. + simp _conv conv_ne ; cbn. econstructor. 1: exact (IHm tt). cbn. @@ -441,7 +455,7 @@ Proof. now constructor. - intros * ? [IHn []] ? [IHP] ? [IHz] ? [IHs] **. unfold graph. - simp conv conv_ne ; cbn. + simp _conv conv_ne ; cbn. econstructor. 1: exact (IHn tt). econstructor. @@ -453,7 +467,7 @@ Proof. now econstructor. - intros * ? [IHe []] ? [IHP] **. unfold graph. - simp conv conv_ne ; cbn. + simp _conv conv_ne ; cbn. econstructor. 1: exact (IHe tt). econstructor. @@ -461,55 +475,49 @@ Proof. now econstructor. - intros * ? [IH []] **. unfold graph. - simp conv conv_ne; cbn. + simp _conv conv_ne; cbn. econstructor. 1: exact (IH tt). econstructor. - intros * ? [IH []] **. unfold graph. - simp conv conv_ne; cbn. + simp _conv conv_ne; cbn. econstructor. 1: exact (IH tt). econstructor. - - intros * ? [ihe []] ? [ihA] ? [ihx] ? [ihP] ? [ihhr] ? [ihy] **. + - intros * ? [ihe []] ? [ihP] ? [ihhr] **. unfold graph. - simp conv conv_ne; cbn. + simp _conv conv_ne; cbn. econstructor. 1: exact (ihe tt). econstructor. - 1: exact (ihA tt). - econstructor. - 1: exact ihx. - econstructor. 1: do 2 erewrite <- Weakening.wk1_ren_on; exact (ihP tt). econstructor. 1: exact ihhr. cbn; patch_rec_ret; econstructor. - 1: exact ihy. - now econstructor. - intros * ? [IHm []] **. unfold graph. - simp conv conv_ne_red ; cbn. + simp _conv conv_ne_red ; cbn. econstructor. 1: exact (IHm tt). econstructor. 2: now econstructor. eapply wh_red_complete_whnf_ty ; tea. boundary. - - intros * ??? []%algo_conv_wh [IHt'] **. + - intros * ??? []%algo_conv_wh [IHt'] [] **. unfold graph. - simp conv conv_tm ; cbn -[PFun_instance_1]. + simp _conv conv_tm ; cbn -[PFun_instance_1]. repeat (match goal with |- orec_graph _ _ _ => econstructor end) ; cbn -[PFun_instance_1]. + eapply wh_red_complete_whnf_ty ; tea. 1: boundary. now gen_typing. - + now eapply wh_red_complete_whnf_tm. - + now eapply wh_red_complete_whnf_tm. + + eapply wh_red_complete_whnf_tm ; eassumption. + + eapply wh_red_complete_whnf_tm ; eassumption. + exact IHt'. + cbn; econstructor. - intros * ? [IHA] ? [IHB] **. unfold graph. - simp conv conv_tm_red ; cbn. + simp _conv conv_tm_red ; cbn. econstructor. 1: exact IHA. cbn; patch_rec_ret; econstructor. @@ -517,31 +525,31 @@ Proof. now constructor. - intros. unfold graph. - simp conv conv_tm_red. + simp _conv conv_tm_red. constructor. - intros. unfold graph. - simp conv conv_tm_red. + simp _conv conv_tm_red. constructor. - intros * ? [IHt] **. unfold graph. - simp conv conv_tm_red; cbn. + simp _conv conv_tm_red; cbn. patch_rec_ret; econstructor. 1: exact IHt. now constructor. - intros. unfold graph. - simp conv conv_tm_red. + simp _conv conv_tm_red. now constructor. - intros * ?? ? [IHf] **. unfold graph. - simp conv conv_tm_red ; cbn. + simp _conv conv_tm_red ; cbn. patch_rec_ret; econstructor. 1: exact IHf. now constructor. - intros * ? [IHA] ? [IHB] **. unfold graph. - simp conv conv_tm_red ; cbn. + simp _conv conv_tm_red ; cbn. econstructor. 1: exact IHA. cbn; patch_rec_ret; econstructor. @@ -549,7 +557,7 @@ Proof. now constructor. - intros * ??? [ihFst] ? [ihSnd] **. unfold graph. - simp conv conv_tm_red ; cbn. + simp _conv conv_tm_red ; cbn. econstructor. 1: exact ihFst. cbn; patch_rec_ret; econstructor. @@ -557,7 +565,7 @@ Proof. now constructor. - intros * ? [ihA] ? [ihx] ? [ihy] **. unfold graph. - simp conv conv_tm_red ; cbn. + simp _conv conv_tm_red ; cbn. econstructor. 1: exact ihA. econstructor. @@ -565,27 +573,46 @@ Proof. cbn; patch_rec_ret; econstructor. 1: exact ihy. now econstructor. - - intros * ? [ihA] ? [ihx] **. + - intros **. unfold graph. - simp conv conv_tm_red ; cbn. - econstructor. - 1: exact (ihA tt). - cbn; patch_rec_ret; econstructor. - 1: exact ihx. + simp _conv conv_tm_red ; cbn. now econstructor. - intros * ? [IHm []] wP **. unfold graph. - simp conv conv_tm_red ; cbn. + simp _conv conv_tm_red ; cbn. unshelve erewrite whne_nf_view3 ; tea. 2-3: now eapply algo_conv_wh in H as []. destruct wP ; cbn. all: now econstructor ; [exact (IHm tt)|constructor]. Qed. +Corollary implem_conv_complete `{!ConvComplete (ta := de) (ta' := al)} Γ A B : + [Γ |-[de] A ≅ B] -> + graph tconv (Γ,A,B) ok. +Proof. + intros. + unfold graph. + simp tconv ; cbn. + econstructor ; cbn. + - apply _implem_conv_complete. + split. + 1-3: boundary. + now apply ty_conv_compl. + - econstructor. +Qed. + End ConversionComplete. Section TypingComplete. +Context `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)}. + +Variable conv : (context × term × term) ⇀ exn errors unit. + +Hypothesis conv_complete : forall Γ T V, + [Γ |-[de] T ≅ V] -> + graph conv (Γ,T,V) ok. + Definition isCanonical_ty_view1 t (c : ~ isCanonical t) : ne_view1 t. Proof. revert c. @@ -608,17 +635,10 @@ Proof. all: reflexivity. Qed. -Ltac patch_rec_ret := - try (unfold rec; - match goal with - | |- orec_graph _ (_rec _ (fun _ : ?Bx => _)) ?hBa => - let Ba := type of hBa in change Bx with Ba - end). - -Let PTy Γ A := forall v, graph typing (wf_ty_state;Γ;v;A) (success tt). -Let PInf Γ A t := forall v, graph typing (inf_state;Γ;v;t) (success A). -Let PInfRed Γ A t := forall v, whnf A -> graph typing (inf_red_state;Γ;v;t) (success A). -Let PCheck Γ A t := graph typing (check_state;Γ;A;t) (success tt). +Let PTy Γ A := forall v, graph (typing conv) (wf_ty_state;Γ;v;A) ok. +Let PInf Γ A t := forall v, graph (typing conv) (inf_state;Γ;v;t) (success A). +Let PInfRed Γ A t := forall v, whnf A -> graph (typing conv) (inf_red_state;Γ;v;t) (success A). +Let PCheck Γ A t := graph (typing conv) (check_state;Γ;A;t) ok. Arguments _bind : simpl nomatch. @@ -631,7 +651,7 @@ Proof. all: unfold graph in *. all: simp typing typing_inf typing_wf_ty typing_inf_red typing_check. (* Well formed types *) - 1-5:repeat match goal with | |- orec_graph typing _ _ => patch_rec_ret ; econstructor ; try eauto ; cbn end. + 1-5:repeat match goal with | |- orec_graph (typing conv) _ _ => patch_rec_ret ; econstructor ; try eauto ; cbn end. - cbn in *. econstructor. 1: exact (g1 tt). @@ -744,9 +764,10 @@ Proof. cbn. econstructor. 2: econstructor. - eapply implem_conv_complete. - split ; tea. - now boundary. + cbn. + eapply conv_complete. + eapply algo_conv_sound in H0. + all: now boundary. Qed. -End TypingComplete. +End TypingComplete. \ No newline at end of file diff --git a/theories/Decidability/Execution.v b/theories/Decidability/Execution.v index bf30e221..58f71212 100644 --- a/theories/Decidability/Execution.v +++ b/theories/Decidability/Execution.v @@ -1,56 +1,59 @@ (** * LogRel.Decidability.Execution: example executions of the type checker, in Coq. *) -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils Notations BasicAst Context GenericTyping DeclarativeTyping DeclarativeInstance BundledAlgorithmicTyping AlgorithmicTypingProperties. +From LogRel Require Import Utils Syntax.All DeclarativeTyping GenericTyping AlgorithmicTyping. +From LogRel.Algorithmic Require Import BundledAlgorithmicTyping AlgorithmicTypingProperties. +From LogRel.TypingProperties Require Import LogRelConsequences. + From PartialFun Require Import Monad PartialFun MonadExn. From LogRel.Decidability Require Import Functions Soundness. From LogRel Require TermNotations. -Import DeclarativeTypingProperties. +Import DeclarativeTypingData. +#[local] Existing Instances TypingSubstLogRel RedCompleteLogRel TypeConstructorsInjLogRel. + #[local] Definition infer (Γ : context) (t : term) : Fueled (exn errors term) := - (fueled typing 1000 (inf_state;Γ;tt;t)). + (fueled (typing tconv) 1000 (inf_state;Γ;tt;t)). #[local] Definition check (Γ : context) (T t : term) : Fueled (exn errors unit) := - (fueled typing 1000 (check_state;Γ;T;t)). + (fueled (typing tconv) 1000 (check_state;Γ;T;t)). #[local] Definition check_ty (Γ : context) (t : term) : Fueled (exn errors unit) := - (fueled typing 1000 (wf_ty_state;Γ;tt;t)). + (fueled (typing tconv) 1000 (wf_ty_state;Γ;tt;t)). -#[local] Definition conv_tm (Γ : context) (T: term) (t1 : term) (t2 : term) : Fueled _ := - (fueled conv 1000 (tm_state;Γ;T;t1;t2)). +#[local] Definition conv_tm (Γ : context) (T: term) (t1 : term) (t2 : term) : Fueled (exn errors unit) := + (fueled _conv 1000 (tm_state;Γ;T;t1;t2)). Ltac infer_auto := match goal with | |- [ε |- ?t : ?T] => assert [|- ε] by econstructor ; - eassert (graph typing (inf_state;ε;tt;t) (success _)) + eassert (graph (typing tconv) (inf_state;ε;tt;t) (success _)) as ?%implem_typing_sound%algo_typing_sound - by (apply (fueled_graph_sound typing 1000 (inf_state;_)) ; reflexivity) - end ; auto. + by (apply (fueled_graph_sound (typing tconv) 1000 (inf_state;_)) ; reflexivity) + end ; auto using implem_tconv_sound. Ltac wf_ty_auto := match goal with | |- [ε |- ?T] => assert [|- ε] by econstructor ; - eassert (graph typing (wf_ty_state;ε;tt;T) (success _)) + eassert (graph (typing tconv) (wf_ty_state;ε;tt;T) (success _)) as ?%implem_typing_sound%algo_typing_sound - by (apply (fueled_graph_sound typing 1000 (wf_ty_state;_)) ; reflexivity) - end ; auto. + by (apply (fueled_graph_sound (typing tconv) 1000 (wf_ty_state;_)) ; reflexivity) + end ; auto using implem_tconv_sound. Ltac check_auto := match goal with | |- [ε |- ?t : ?T] => assert [|- ε] by econstructor ; - eassert (graph typing (check_state;ε;T;t) (success _)) + eassert (graph (typing tconv) (check_state;ε;T;t) (success _)) as ?%implem_typing_sound%algo_typing_sound - by (apply (fueled_graph_sound typing 1000 (check_state;_)) ; reflexivity) ; - eassert (graph typing (wf_ty_state;ε;tt;T) (success _)) + by (apply (fueled_graph_sound (typing tconv) 1000 (check_state;_)) ; reflexivity) ; + eassert (graph (typing tconv) (wf_ty_state;ε;tt;T) (success _)) as ?%implem_typing_sound%algo_typing_sound - by (apply (fueled_graph_sound typing 1000 (wf_ty_state;_)) ; reflexivity) ; - auto -end. + by (apply (fueled_graph_sound (typing tconv) 1000 (wf_ty_state;_)) ; reflexivity) +end ; auto using implem_tconv_sound. Import TermNotations. @@ -65,17 +68,17 @@ Proof. infer_auto. Qed. -Check ((fun x => nat_rec (fun _ => nat) 0 (fun _ ih => S (S ih)) x) : nat -> nat). +Succeed Check ((fun x => nat_rec (fun _ => nat) 0 (fun _ ih => S (S ih)) x) : nat -> nat). Goal ⟪ε |- λ ℕ, indℕ ℕ 0 (λ ℕ ℕ, x₀.+2) 2 : ℕ → ℕ⟫. Proof. infer_auto. Qed. -Check (eq_refl : (nat_rect (fun _ => Type) nat (fun _ ih => nat -> ih) 3) = (nat -> nat -> nat -> nat)). +Succeed Check (eq_refl : (nat_rect (fun _ => Type) nat (fun _ ih => nat -> ih) 3) = (nat -> nat -> nat -> nat)). Goal ⟪ ε |- rfl □ (ℕ → ℕ → ℕ → ℕ) : (ℕ → ℕ → ℕ → ℕ) =⟨ □ ⟩ indℕ □ ℕ (λ ℕ □, ℕ → x₀) 3⟫. Proof. check_auto. -Qed. +Qed. \ No newline at end of file diff --git a/theories/Decidability/Functions.v b/theories/Decidability/Functions.v index 921ffeb4..d35eebe2 100644 --- a/theories/Decidability/Functions.v +++ b/theories/Decidability/Functions.v @@ -2,8 +2,7 @@ From Coq Require Import Nat Lia. From Equations Require Import Equations. From PartialFun Require Import Monad PartialFun MonadExn. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Context. +From LogRel Require Import Utils BasicAst AutoSubst.Extra Context. Import MonadNotations. Set Universe Polymorphism. @@ -13,136 +12,264 @@ Set Printing Universes. #[global] Obligation Tactic := idtac. +Definition ok {M} `{Monad M} : M unit := ret tt. Inductive errors : Type := - | variable_not_in_context (n : nat) (Γ : context) : errors - | head_mismatch (T : option term) (t t' : term) : errors - | variable_mismatch (n n' : nat) : errors - | destructor_mismatch (t t' : term) : errors + | variable_not_in_context : errors + | head_mismatch : errors + | variable_mismatch : errors + | destructor_mismatch : errors | conv_error : errors | type_error : errors. -#[export]Existing Instance OrecEffectExn. -#[export]Existing Instance MonadExn | 1. -#[export]Existing Instance MonadRaiseExn. - -Equations ctx_access (Γ : context) (n : nat) : exn errors term := - ctx_access ε _ := raise (A := term) (variable_not_in_context n ε) ; (** The context does not contain the variable! *) - ctx_access (_,,d) 0 := ret (d⟨↑⟩) ; - ctx_access (Γ,,_) (S n') := d ← (ctx_access Γ n') ;; ret d⟨↑⟩. - -Definition eq_sort (s s' : sort) : exn errors unit := success tt. - -Variant ty_entry : term -> Type := - | eSort s : ty_entry (tSort s) - | eProd A B : ty_entry (tProd A B) - | eNat : ty_entry tNat - | eEmpty : ty_entry tEmpty - | eSig A B : ty_entry (tSig A B) - | eId A x y : ty_entry (tId A x y). - -Variant nat_entry : term -> Type := - | eZero : nat_entry tZero - | eSucc t : nat_entry (tSucc t). - -Variant dest_entry : Type := - | eEmptyElim (P : term) - | eNatElim (P : term) (hs hz : term) - | eApp (u : term) - | eFst - | eSnd - | eIdElim (A x P hr y : term). - -Definition zip1 (t : term) (e : dest_entry) : term := - match e with - | eEmptyElim P => (tEmptyElim P t) - | eNatElim P hs hz => (tNatElim P hs hz t) - | eApp u => (tApp t u) - | eFst => tFst t - | eSnd => tSnd t - | eIdElim A x P hr y => tIdElim A x P hr y t - end. - -Variant tm_view1 : term -> Type := - | tm_view1_type {t} : ty_entry t -> tm_view1 t - | tm_view1_fun A t : tm_view1 (tLambda A t) - | tm_view1_rel n : tm_view1 (tRel n) - | tm_view1_nat {t} : nat_entry t -> tm_view1 t - | tm_view1_sig A B a b : tm_view1 (tPair A B a b) - | tm_view1_id A x : tm_view1 (tRefl A x) - | tm_view1_dest t (s : dest_entry) : tm_view1 (zip1 t s). - -Definition build_tm_view1 t : tm_view1 t := - match t with - | tRel n => tm_view1_rel n - | tSort s => tm_view1_type (eSort s) - | tProd A B => tm_view1_type (eProd A B) - | tLambda A t => tm_view1_fun A t - | tApp t u => tm_view1_dest t (eApp u) - | tNat => tm_view1_type (eNat) - | tZero => tm_view1_nat (eZero) - | tSucc t => tm_view1_nat (eSucc t) - | tNatElim P hs hz t => tm_view1_dest t (eNatElim P hs hz) - | tEmpty => tm_view1_type (eEmpty) - | tEmptyElim P t => tm_view1_dest t (eEmptyElim P) - | tSig A B => tm_view1_type (eSig A B) - | tPair A B a b => tm_view1_sig A B a b - | tFst t => tm_view1_dest t eFst - | tSnd t => tm_view1_dest t eSnd - | tId A x y => tm_view1_type (eId A x y) - | tRefl A x => tm_view1_id A x - | tIdElim A x P hr y e => tm_view1_dest e (eIdElim A x P hr y) - end. - -Variant ne_view1 : term -> Type := - | ne_view1_rel n : ne_view1 (tRel n) - | ne_view1_dest t s : ne_view1 (zip1 t s). - -Variant nf_view1 : term -> Type := - | nf_view1_type {t} : ty_entry t -> nf_view1 t - | nf_view1_fun A t : nf_view1 (tLambda A t) - | nf_view1_nat {t} : nat_entry t -> nf_view1 t - | nf_view1_sig A B a b : nf_view1 (tPair A B a b) - | nf_view1_id A x : nf_view1 (tRefl A x) - | nf_view1_ne {t} : ne_view1 t -> nf_view1 t. - -Definition build_nf_view1 t : nf_view1 t := - match t with - | tRel n => nf_view1_ne (ne_view1_rel n) - | tSort s => nf_view1_type (eSort s) - | tProd A B => nf_view1_type (eProd A B) - | tLambda A t => nf_view1_fun A t - | tApp t u => nf_view1_ne (ne_view1_dest t (eApp u)) - | tNat => nf_view1_type (eNat) - | tZero => nf_view1_nat (eZero) - | tSucc t => nf_view1_nat (eSucc t) - | tNatElim P hs hz t => nf_view1_ne (ne_view1_dest t (eNatElim P hs hz)) - | tEmpty => nf_view1_type (eEmpty) - | tEmptyElim P t => nf_view1_ne (ne_view1_dest t (eEmptyElim P)) - | tSig A B => nf_view1_type (eSig A B) - | tPair A B a b => nf_view1_sig A B a b - | tFst t => nf_view1_ne (ne_view1_dest t eFst) - | tSnd t => nf_view1_ne (ne_view1_dest t eSnd) - | tId A x y => nf_view1_type (eId A x y) - | tRefl A x => nf_view1_id A x - | tIdElim A x P hr y e => nf_view1_ne (ne_view1_dest e (eIdElim A x P hr y)) - end. - -Variant ty_view1 : term -> Type := - | ty_view1_ty {t} : ty_entry t -> ty_view1 t - | ty_view1_small {t} : ne_view1 t -> ty_view1 t - | ty_view1_anomaly {t} : ty_view1 t. - -Definition build_ty_view1 t : ty_view1 t := - match (build_tm_view1 t) with - | tm_view1_type e => ty_view1_ty e - | tm_view1_rel n => ty_view1_small (ne_view1_rel n) - | tm_view1_dest t s => ty_view1_small (ne_view1_dest t s) - | tm_view1_fun _ _ - | tm_view1_nat _ - | tm_view1_sig _ _ _ _ - | tm_view1_id _ _ => ty_view1_anomaly - end. +Section Views. + + Variant ty_entry : term -> Type := + | eSort s : ty_entry (tSort s) + | eProd A B : ty_entry (tProd A B) + | eNat : ty_entry tNat + | eEmpty : ty_entry tEmpty + | eSig A B : ty_entry (tSig A B) + | eId A x y : ty_entry (tId A x y). + + Variant nat_entry : term -> Type := + | eZero : nat_entry tZero + | eSucc t : nat_entry (tSucc t). + + Variant dest_entry : Type := + | eEmptyElim (P : term) + | eNatElim (P : term) (hs hz : term) + | eApp (u : term) + | eFst + | eSnd + | eIdElim (A x P hr y : term). + + Definition zip1 (t : term) (e : dest_entry) : term := + match e with + | eEmptyElim P => (tEmptyElim P t) + | eNatElim P hs hz => (tNatElim P hs hz t) + | eApp u => (tApp t u) + | eFst => tFst t + | eSnd => tSnd t + | eIdElim A x P hr y => tIdElim A x P hr y t + end. + + Variant tm_view1 : term -> Type := + | tm_view1_type {t} : ty_entry t -> tm_view1 t + | tm_view1_fun A t : tm_view1 (tLambda A t) + | tm_view1_rel n : tm_view1 (tRel n) + | tm_view1_nat {t} : nat_entry t -> tm_view1 t + | tm_view1_sig A B a b : tm_view1 (tPair A B a b) + | tm_view1_id A x : tm_view1 (tRefl A x) + | tm_view1_dest t (s : dest_entry) : tm_view1 (zip1 t s). + + Definition build_tm_view1 t : tm_view1 t := + match t with + | tRel n => tm_view1_rel n + | tSort s => tm_view1_type (eSort s) + | tProd A B => tm_view1_type (eProd A B) + | tLambda A t => tm_view1_fun A t + | tApp t u => tm_view1_dest t (eApp u) + | tNat => tm_view1_type (eNat) + | tZero => tm_view1_nat (eZero) + | tSucc t => tm_view1_nat (eSucc t) + | tNatElim P hs hz t => tm_view1_dest t (eNatElim P hs hz) + | tEmpty => tm_view1_type (eEmpty) + | tEmptyElim P t => tm_view1_dest t (eEmptyElim P) + | tSig A B => tm_view1_type (eSig A B) + | tPair A B a b => tm_view1_sig A B a b + | tFst t => tm_view1_dest t eFst + | tSnd t => tm_view1_dest t eSnd + | tId A x y => tm_view1_type (eId A x y) + | tRefl A x => tm_view1_id A x + | tIdElim A x P hr y e => tm_view1_dest e (eIdElim A x P hr y) + end. + + Variant ne_view1 : term -> Type := + | ne_view1_rel n : ne_view1 (tRel n) + | ne_view1_dest t s : ne_view1 (zip1 t s). + + Variant nf_view1 : term -> Type := + | nf_view1_type {t} : ty_entry t -> nf_view1 t + | nf_view1_fun A t : nf_view1 (tLambda A t) + | nf_view1_nat {t} : nat_entry t -> nf_view1 t + | nf_view1_sig A B a b : nf_view1 (tPair A B a b) + | nf_view1_id A x : nf_view1 (tRefl A x) + | nf_view1_ne {t} : ne_view1 t -> nf_view1 t. + + Definition build_nf_view1 t : nf_view1 t := + match t with + | tRel n => nf_view1_ne (ne_view1_rel n) + | tSort s => nf_view1_type (eSort s) + | tProd A B => nf_view1_type (eProd A B) + | tLambda A t => nf_view1_fun A t + | tApp t u => nf_view1_ne (ne_view1_dest t (eApp u)) + | tNat => nf_view1_type (eNat) + | tZero => nf_view1_nat (eZero) + | tSucc t => nf_view1_nat (eSucc t) + | tNatElim P hs hz t => nf_view1_ne (ne_view1_dest t (eNatElim P hs hz)) + | tEmpty => nf_view1_type (eEmpty) + | tEmptyElim P t => nf_view1_ne (ne_view1_dest t (eEmptyElim P)) + | tSig A B => nf_view1_type (eSig A B) + | tPair A B a b => nf_view1_sig A B a b + | tFst t => nf_view1_ne (ne_view1_dest t eFst) + | tSnd t => nf_view1_ne (ne_view1_dest t eSnd) + | tId A x y => nf_view1_type (eId A x y) + | tRefl A x => nf_view1_id A x + | tIdElim A x P hr y e => nf_view1_ne (ne_view1_dest e (eIdElim A x P hr y)) + end. + + Variant ty_view1 : term -> Type := + | ty_view1_ty {t} : ty_entry t -> ty_view1 t + | ty_view1_small {t} : ne_view1 t -> ty_view1 t + | ty_view1_anomaly {t} : ty_view1 t. + + Definition build_ty_view1 t : ty_view1 t := + match (build_nf_view1 t) with + | nf_view1_type e => ty_view1_ty e + | nf_view1_ne s => ty_view1_small s + | nf_view1_fun _ _ + | nf_view1_nat _ + | nf_view1_sig _ _ _ _ + | nf_view1_id _ _ => ty_view1_anomaly + end. + + Inductive nf_ty_view2 : term -> term -> Type := + | ty_sorts (s1 s2 : sort) : nf_ty_view2 (tSort s1) (tSort s2) + | ty_prods (A A' B B' : term) : + nf_ty_view2 (tProd A B) (tProd A' B') + | ty_nats : nf_ty_view2 tNat tNat + | ty_emptys : nf_ty_view2 tEmpty tEmpty + | ty_sigs (A A' B B' : term) : nf_ty_view2 (tSig A B) (tSig A' B') + | ty_ids A A' x x' y y' : nf_ty_view2 (tId A x y) (tId A' x' y') + | ty_neutrals (n n' : term) : nf_ty_view2 n n' + | ty_mismatch (t u : term) : nf_ty_view2 t u + | ty_anomaly (t u : term) : nf_ty_view2 t u. + + Equations build_nf_ty_view2 (A A' : term) : nf_ty_view2 A A' := + build_nf_ty_view2 A A' with (build_ty_view1 A), (build_ty_view1 A') := { + (** Matching types *) + | ty_view1_ty (eSort s1), ty_view1_ty (eSort s2) := + ty_sorts s1 s2 ; + | ty_view1_ty (eProd A B), ty_view1_ty (eProd A' B') := + ty_prods A A' B B' ; + | ty_view1_ty eNat, ty_view1_ty eNat := + ty_nats; + | ty_view1_ty eEmpty, ty_view1_ty eEmpty := + ty_emptys; + | ty_view1_ty (eSig A B), ty_view1_ty (eSig A' B') := + ty_sigs A A' B B' + | ty_view1_ty (eId A x y), ty_view1_ty (eId A' x' y') := + ty_ids A A' x x' y y' + | ty_view1_small _, ty_view1_small _ := + ty_neutrals _ _ ; + (** Mismatching sorts *) + | ty_view1_ty _, ty_view1_ty _ := + ty_mismatch _ _ ; + | ty_view1_small _, ty_view1_ty _ := + ty_mismatch _ _ ; + | ty_view1_ty _, ty_view1_small _ := + ty_mismatch _ _ ; + (** Anomaly *) + | ty_view1_anomaly,_ := ty_anomaly _ _ ; + | _, ty_view1_anomaly := ty_anomaly _ _; + }. + + Inductive nf_view3 : term -> term -> term -> Type := + | types {A A'} (s : sort) : nf_ty_view2 A A' -> nf_view3 (tSort s) A A' + | functions A B t t' : nf_view3 (tProd A B) t t' + | zeros : nf_view3 tNat tZero tZero + | succs t t' : nf_view3 tNat (tSucc t) (tSucc t') + | pairs A B t t' : nf_view3 (tSig A B) t t' + | refls A x y A' x' A'' x'' : nf_view3 (tId A x y) (tRefl A' x') (tRefl A'' x'') + | neutrals (A n n' : term) : nf_view3 A n n' + | mismatch (A t u : term) : nf_view3 A t u + | anomaly (A t u : term) : nf_view3 A t u. + + Equations build_nf_view3 T t t' : nf_view3 T t t' := + build_nf_view3 T t t' with (build_ty_view1 T) := { + (** Matching typed *) + | ty_view1_ty (eSort s) := types s (build_nf_ty_view2 t t') ; + (** Functions *) + | ty_view1_ty (eProd A B) := functions A B _ _ ; + (** Naturals *) + | ty_view1_ty eNat with (build_nf_view1 t), (build_nf_view1 t') := + { + | nf_view1_nat eZero, nf_view1_nat eZero := + zeros ; + | nf_view1_nat (eSucc u), nf_view1_nat (eSucc u') := + succs u u' ; + | nf_view1_ne _, nf_view1_ne _ := neutrals _ _ _ ; + | nf_view1_nat _, nf_view1_nat _ := + mismatch _ _ _ ; + | nf_view1_ne _, nf_view1_nat _ := + mismatch _ _ _ ; + | nf_view1_nat _, nf_view1_ne _ := + mismatch _ _ _ ; + | _, _ := anomaly _ _ _ ; + } ; + (** Inhabitants of the empty type must be neutrals *) + | ty_view1_ty eEmpty with (build_nf_view1 t), (build_nf_view1 t') := + { + | nf_view1_ne _, nf_view1_ne _ := + neutrals _ _ _ ; + | _, _ := anomaly _ _ _ ; + } + (** Pairs *) + | ty_view1_ty (eSig A B) := pairs A B _ _ ; + (** Identity witnesses *) + | ty_view1_ty (eId A x y) with (build_nf_view1 t), (build_nf_view1 t') := + { + | nf_view1_id A' x', nf_view1_id A'' x'' := refls A x y A' x' A'' x'' ; + | nf_view1_ne _, nf_view1_ne _ := neutrals _ _ _ ; + | nf_view1_ne _, nf_view1_id _ _ := + mismatch _ _ _ ; + | nf_view1_id _ _, nf_view1_ne _ := + mismatch _ _ _ ; + | _, _ := anomaly _ _ _ ; + } + (** Neutral type *) + | ty_view1_small _ with (build_nf_view1 t), (build_nf_view1 t') := + { + | nf_view1_ne _, nf_view1_ne _ := neutrals _ _ _ ; + | _, _ := anomaly _ _ _ ; + } + (** The type is not a type *) + | ty_view1_anomaly := anomaly _ _ _ ; + }. + + Inductive ne_view2 : term -> term -> Type := + | ne_rels (n n' : nat) : ne_view2 (tRel n) (tRel n') + | ne_apps f u f' u' : ne_view2 (tApp f u) (tApp f' u') + | ne_nats n P hz hs n' P' hz' hs' : ne_view2 (tNatElim P hz hs n) (tNatElim P' hz' hs' n') + | ne_emptys n P n' P' : ne_view2 (tEmptyElim P n) (tEmptyElim P' n') + | ne_fsts p p' : ne_view2 (tFst p) (tFst p') + | ne_snds p p' : ne_view2 (tSnd p) (tSnd p') + | ne_ids A x P hr y e A' x' P' hr' y' e' : ne_view2 (tIdElim A x P hr y e) (tIdElim A' x' P' hr' y' e') + | ne_mismatch (t u : term) : ne_view2 t u + | ne_anomaly (t u : term) : ne_view2 t u. + + Equations build_ne_view2 (t t' : term) : ne_view2 t t' := + build_ne_view2 t t' with (build_nf_view1 t), (build_nf_view1 t') := { + | nf_view1_ne v, nf_view1_ne v' with v, v' := { + | ne_view1_rel n, ne_view1_rel n' := ne_rels n n' ; + | ne_view1_dest f (eApp u), ne_view1_dest f' (eApp u') := ne_apps f u f' u' ; + | ne_view1_dest n (eNatElim P hz hs), ne_view1_dest n' (eNatElim P' hz' hs') := + ne_nats n P hz hs n' P' hz' hs' ; + | ne_view1_dest n (eEmptyElim P), ne_view1_dest n' (eEmptyElim P') := + ne_emptys n P n' P' ; + | ne_view1_dest p eFst, ne_view1_dest p' eFst := + ne_fsts p p' ; + | ne_view1_dest p eSnd, ne_view1_dest p' eSnd := + ne_snds p p' ; + | ne_view1_dest e (eIdElim A x P hr y), ne_view1_dest e' (eIdElim A' x' P' hr' y') := + ne_ids A x P hr y e A' x' P' hr' y' e' ; + | _, _ := ne_mismatch _ _ ; + } + | _, _ := ne_anomaly _ _ + }. + +End Views. Definition stack := list dest_entry. @@ -152,6 +279,16 @@ Fixpoint zip t (π : stack) := | cons s π => zip (zip1 t s) π end. +#[export]Existing Instance OrecEffectExn. +#[export]Existing Instance MonadExn | 1. +#[export]Existing Instance MonadRaiseExn. + +Equations ctx_access (Γ : context) (n : nat) : exn errors term := + ctx_access ε _ := raise variable_not_in_context ; (** The context does not contain the variable! *) + ctx_access (_,,d) 0 := ret (d⟨↑⟩) ; + ctx_access (Γ,,_) (S n') := d ← (ctx_access Γ n') ;; ret d⟨↑⟩. + +Definition eq_sort (s s' : sort) : exn errors unit := ok. (* Introduce the following in PartialFun *) @@ -250,106 +387,6 @@ Definition wh_red : ∇(t : term), [Sing wh_red_stack]⇒ term := Definition wh_red_fuel n t := fueled wh_red n t. -Inductive nf_ty_view2 : term -> term -> Type := - | ty_sorts (s1 s2 : sort) : nf_ty_view2 (tSort s1) (tSort s2) - | ty_prods (A A' B B' : term) : - nf_ty_view2 (tProd A B) (tProd A' B') - | ty_nats : nf_ty_view2 tNat tNat - | ty_emptys : nf_ty_view2 tEmpty tEmpty - | ty_sigs (A A' B B' : term) : nf_ty_view2 (tSig A B) (tSig A' B') - | ty_ids A A' x x' y y' : nf_ty_view2 (tId A x y) (tId A' x' y') - | ty_neutrals (n n' : term) : nf_ty_view2 n n' - | ty_mismatch (t u : term) : nf_ty_view2 t u - | ty_anomaly (t u : term) : nf_ty_view2 t u. - -Equations build_nf_ty_view2 (A A' : term) : nf_ty_view2 A A' := - build_nf_ty_view2 A A' with (build_ty_view1 A), (build_ty_view1 A') := { - (** Matching types *) - | ty_view1_ty (eSort s1), ty_view1_ty (eSort s2) := - ty_sorts s1 s2 ; - | ty_view1_ty (eProd A B), ty_view1_ty (eProd A' B') := - ty_prods A A' B B' ; - | ty_view1_ty eNat, ty_view1_ty eNat := - ty_nats; - | ty_view1_ty eEmpty, ty_view1_ty eEmpty := - ty_emptys; - | ty_view1_ty (eSig A B), ty_view1_ty (eSig A' B') := - ty_sigs A A' B B' - | ty_view1_ty (eId A x y), ty_view1_ty (eId A' x' y') := - ty_ids A A' x x' y y' - | ty_view1_small _, ty_view1_small _ := - ty_neutrals _ _ ; - (** Mismatching sorts *) - | ty_view1_ty _, ty_view1_ty _ := - ty_mismatch _ _ ; - | ty_view1_small _, ty_view1_ty _ := - ty_mismatch _ _ ; - | ty_view1_ty _, ty_view1_small _ := - ty_mismatch _ _ ; - (** Anomaly *) - | ty_view1_anomaly,_ := ty_anomaly _ _ ; - | _, ty_view1_anomaly := ty_anomaly _ _; - }. - -Inductive nf_view3 : term -> term -> term -> Type := -| types {A A'} (s : sort) : nf_ty_view2 A A' -> nf_view3 (tSort s) A A' -| functions A B t t' : nf_view3 (tProd A B) t t' -| zeros : nf_view3 tNat tZero tZero -| succs t t' : nf_view3 tNat (tSucc t) (tSucc t') -| pairs A B t t' : nf_view3 (tSig A B) t t' -| refls A x y A' x' A'' x'' : nf_view3 (tId A x y) (tRefl A' x') (tRefl A'' x'') -| neutrals (A n n' : term) : nf_view3 A n n' -| mismatch (A t u : term) : nf_view3 A t u -| anomaly (A t u : term) : nf_view3 A t u. - -Equations build_nf_view3 T t t' : nf_view3 T t t' := - build_nf_view3 T t t' with (build_ty_view1 T) := { - (** Matching typed *) - | ty_view1_ty (eSort s) := types s (build_nf_ty_view2 t t') ; - (** Functions *) - | ty_view1_ty (eProd A B) := functions A B _ _ ; - (** Naturals *) - | ty_view1_ty eNat with (build_nf_view1 t), (build_nf_view1 t') := - { - | nf_view1_nat eZero, nf_view1_nat eZero := - zeros ; - | nf_view1_nat (eSucc u), nf_view1_nat (eSucc u') := - succs u u' ; - | nf_view1_ne _, nf_view1_ne _ := neutrals _ _ _ ; - | nf_view1_nat _, nf_view1_nat _ := - mismatch _ _ _ ; - | nf_view1_ne _, nf_view1_nat _ := - mismatch _ _ _ ; - | nf_view1_nat _, nf_view1_ne _ := - mismatch _ _ _ ; - | _, _ := anomaly _ _ _ ; - } ; - (** Inhabitants of the empty type must be neutrals *) - | ty_view1_ty eEmpty with (build_nf_view1 t), (build_nf_view1 t') := - { - | nf_view1_ne _, nf_view1_ne _ := - neutrals _ _ _ ; - | _, _ := anomaly _ _ _ ; - } - (** Pairs *) - | ty_view1_ty (eSig A B) := pairs A B _ _ ; - (** Identity witnesses *) - | ty_view1_ty (eId A x y) with (build_nf_view1 t), (build_nf_view1 t') := - { - | nf_view1_id A' x', nf_view1_id A'' x'' := refls A x y A' x' A'' x'' ; - | nf_view1_ne _, nf_view1_ne _ := neutrals _ _ _ ; - | nf_view1_ne _, nf_view1_id _ _ := - mismatch _ _ _ ; - | nf_view1_id _ _, nf_view1_ne _ := - mismatch _ _ _ ; - | _, _ := anomaly _ _ _ ; - } - (** Neutral type *) - | ty_view1_small _ := neutrals _ _ _ ; - (** The type is not a type *) - | ty_view1_anomaly := anomaly _ _ _ ; - }. - Variant conv_state : Type := | ty_state (** Conversion of arbitrary types *) | ty_red_state (** Comparison of types in weak-head normal forms *) @@ -400,16 +437,6 @@ Equations conv_ty : conv_stmt ty_state := r ← rec (ty_red_state;Γ;tt;T';V') ;;[M] ret (A:= unit) r. -(* Goal True. *) -(* pose (c := conv_stmt ty_red_state). *) -(* unfold conv_stmt in c. *) -(* unfold combined in c. *) -(* Unset Printing Notations. *) -(* unfold M0 in c. *) -(* Eval unfold conv_stmt in conv_stmt ty_red_state. *) - -Definition ok {M} `{Monad M} : M unit := ret tt. - Equations conv_ty_red : conv_stmt ty_red_state := | (Γ;inp;T;T') with (build_nf_ty_view2 T T') := { @@ -428,7 +455,7 @@ Equations conv_ty_red : conv_stmt ty_red_state := rec (ty_state;Γ;tt;A;A') ;; rec (tm_state;Γ;A;x;x') ;; rec (tm_state;Γ;A;y;y') - | ty_mismatch _ _ := raise (head_mismatch None T T') ; + | ty_mismatch _ _ := raise (head_mismatch) ; | ty_anomaly _ _ := undefined ; }. @@ -459,7 +486,7 @@ Equations conv_tm_red : conv_stmt tm_red_state := rec (tm_state;Γ;A;y;y') | types _ (ty_neutrals _ _) := rec (ne_state;Γ;tt;t;u) ;; ok ; - | types s (ty_mismatch _ _) := raise (head_mismatch (Some (tSort s)) t u) ; + | types s (ty_mismatch _ _) := raise head_mismatch ; | types _ (ty_anomaly _ _) := undefined ; | functions A B t u := rec (tm_state;Γ,,A;B;eta_expand t;eta_expand u) (* ::: (tm_red_state;Γ;tProd A B;t;u) ;*) ; @@ -469,42 +496,32 @@ Equations conv_tm_red : conv_stmt tm_red_state := | pairs A B t u := rec (tm_state;Γ;A;tFst t; tFst u) ;; rec (tm_state;Γ; B[(tFst t)..]; tSnd t; tSnd u) (* ::: (tm_red_state;Γ;tSig A B;t;u) ;*) ; - | refls A x y A' x' A'' x'' := - rec (ty_state;Γ;tt;A';A'') ;; - rec (tm_state;Γ;A';x';x'') + | refls A x y A' x' A'' x'' := ok ; | neutrals _ _ _ := rec (ne_state;Γ;tt;t;u) ;; ok ; - | mismatch _ _ _ := raise (head_mismatch (Some A) t u) ; + | mismatch _ _ _ := raise head_mismatch ; | anomaly _ _ _ := undefined ; }. -Equations to_neutral_diag (t u : term) : option (ne_view1 t × ne_view1 u) := - | t, u with build_nf_view1 t, build_nf_view1 u => +Equations conv_ne : conv_stmt ne_state := + | (Γ;inp; t; t') with (build_ne_view2 t t') := { - | nf_view1_ne te, nf_view1_ne ue => Some (te, ue) - | _ , _ => None - }. - - -Time Equations conv_ne : conv_stmt ne_state := - | (Γ;inp; t; t') with t, t', to_neutral_diag t t' := - { - | _, _, Some (ne_view1_rel n, ne_view1_rel n') with n =? n' := - { | false := raise (variable_mismatch n n') ; - | true with (ctx_access Γ n) := + | ne_rels n n' with n =? n' := + { | false := raise variable_mismatch ; + | true with (ctx_access Γ n) := { | exception e => undefined ; | success d => ret d (* ::: (ne_state;Γ;inp;tRel n; tRel n')*) } } ; - | _, _, Some (ne_view1_dest n (eApp t), ne_view1_dest n' (eApp t')) => + | ne_apps n t n' t' => T ← rec (ne_red_state;Γ;tt;n;n') ;; match T with | tProd A B => rec (tm_state;Γ;A;t;t') ;; ret B[t..] | _ => undefined (** the whnf of the type of an applied neutral must be a Π type!*) end ; - | _, _, Some (ne_view1_dest n (eNatElim P hz hs), ne_view1_dest n' (eNatElim P' hz' hs')) => + | ne_nats n P hz hs n' P' hz' hs' => rn ← rec (ne_red_state;Γ;tt;n;n') ;; match rn with | tNat => @@ -514,7 +531,7 @@ Time Equations conv_ne : conv_stmt ne_state := ret P[n..] | _ => undefined end ; - | _, _, Some (ne_view1_dest n (eEmptyElim P), ne_view1_dest n' (eEmptyElim P')) => + | ne_emptys n P n' P' => rn ← rec (ne_red_state;Γ;tt;n;n') ;; match rn with | tEmpty => @@ -522,87 +539,31 @@ Time Equations conv_ne : conv_stmt ne_state := ret P[n..] | _ => undefined end ; - | _, _, Some (ne_view1_dest n eFst, ne_view1_dest n' eFst) => + | ne_fsts n n' => T ← rec (ne_red_state;Γ;tt;n;n') ;; match T with | tSig A B => ret A | _ => undefined (** the whnf of the type of a projected neutral must be a Σ type!*) end ; - | _, _, Some (ne_view1_dest n eSnd, ne_view1_dest n' eSnd) => + | ne_snds n n' => T ← rec (ne_red_state;Γ;tt;n;n') ;; match T with | tSig A B => ret B[(tFst n)..] | _ => undefined (** the whnf of the type of a projected neutral must be a Σ type!*) - end ; - | _, _, Some (ne_view1_dest n (eIdElim A x P hr y), ne_view1_dest n' (eIdElim A' x' P' hr' y')) => + end ; + | ne_ids A x P hr y n A' x' P' hr' y' n' => T ← rec (ne_red_state;Γ;tt;n;n') ;; match T with | tId _ _ _ => - rec (ty_state;Γ;tt;A;A') ;; - rec (tm_state;Γ;A;x;x') ;; rec (ty_state;Γ,,A,,tId A⟨↑⟩ x⟨↑⟩ (tRel 0);tt;P;P') ;; rec (tm_state;Γ;P[tRefl A x.: x..];hr;hr') ;; - rec (tm_state;Γ;A;y;y') ;; ret P[n .: y..] | _ => undefined end ; - | w, w', _ => raise (destructor_mismatch w w') + | ne_mismatch _ _ => raise destructor_mismatch ; + | ne_anomaly _ _ => undefined }. - -(*Time Equations conv_ne_alt : conv_stmt ne_state := - | (Γ;inp;tRel n;tRel n') - with n =? n' := - { | false := raise (variable_mismatch n n') ; - | true with (ctx_access Γ n) := - { - | error e => undefined ; - | ok d => ret d (* ::: (ne_state;Γ;inp;tRel n; tRel n')*) - } - } ; - | (Γ;inp;tApp n t ; tApp n' t') := - T ← rec (ne_red_state;Γ;tt;n;n') ;; - match T with - | tProd A B => - rec (tm_state;Γ;A;t;t') ;; ret B[t..] - (* (ret (B[t..])) ::: (ne_state;Γ;inp;tApp n t; tApp n' t') *) - | _ => undefined (** the whnf of the type of an applied neutral must be a Π type!*) - end ; - | (Γ;inp;tNatElim P hz hs n;tNatElim P' hz' hs' n') := - rn ← rec (ne_red_state;Γ;tt;n;n') ;; - match rn with - | tNat => - rec (ty_state;(Γ,,tNat);tt;P;P') ;; - rec (tm_state;Γ;P[tZero..];hz;hz') ;; - rec (tm_state;Γ;elimSuccHypTy P;hs;hs') ;; - ret P[n..] - (* ret (P[n..]) ::: (ne_state;Γ;inp;tNatElim P hz hs n;tNatElim P' hz' hs' n') *) - | _ => undefined - end ; - | (Γ;inp;tEmptyElim P n;tEmptyElim P' n') := - rn ← rec (ne_red_state;Γ;tt;n;n') ;; - match rn with - | tEmpty => - rec (ty_state;(Γ,,tEmpty);tt;P;P') ;; - ret P[n..] - (* ret (P[n..]) ::: (ne_state;Γ;inp;tEmptyElim P n;tEmptyElim P' n') *) - | _ => undefined - end ; - | ( Γ; inp ; tFst n; tFst n') := - T ← rec (ne_red_state;Γ;tt;n;n') ;; - match T with - | tSig A B => ret A (* ::: (ne_state;Γ; inp; tFst n; tFst n')*) - | _ => undefined (** the whnf of the type of a projected neutral must be a Σ type!*) - end ; - | ( Γ; inp ; tSnd n; tSnd n') := - T ← rec (ne_red_state;Γ;tt;n;n') ;; - match T with - | tSig A B => ret B[(tFst n)..] - (* ret (B[(tFst n)..]) ::: (ne_state;Γ; inp; tSnd n; tSnd n') *) - | _ => undefined (** the whnf of the type of a projected neutral must be a Σ type!*) - end ; - | (Γ;_;n;n') := raise (destructor_mismatch n n'). *) - Equations conv_ne_red : conv_stmt ne_red_state := | (Γ;inp;t;u) := Ainf ← rec (ne_state;Γ;tt;t;u) ;;[M] @@ -610,7 +571,7 @@ Equations conv_ne_red : conv_stmt ne_red_state := ret (M:=M) r. -Equations conv : ∇(x : conv_full_dom), [Sing wh_red]⇒[exn errors] cstate_output x.π1 := +Equations _conv : ∇(x : conv_full_dom), [Sing wh_red]⇒[exn errors] cstate_output x.π1 := | (ty_state; Γ ; inp ; T; V) := conv_ty (Γ; inp; T; V); | (ty_red_state; Γ ; inp ; T; V) := conv_ty_red (Γ; inp; T; V); | (tm_state; Γ ; inp ; T; V) := conv_tm (Γ; inp; T; V); @@ -618,13 +579,21 @@ Equations conv : ∇(x : conv_full_dom), [Sing wh_red]⇒[exn errors] cstate_out | (ne_state; Γ ; inp ; T; V) := conv_ne (Γ; inp; T; V); | (ne_red_state; Γ ; inp ; T; V) := conv_ne_red (Γ; inp; T; V). -End Conversion. + #[local] Instance: PFun _conv := pfun_gen _ _ _conv. + Equations tconv : (context × term × term) ⇀ exn errors unit := + tconv (Γ,T,V) := call _conv (ty_state;Γ;tt;T;V). -#[export] Instance: PFun conv := pfun_gen _ _ conv. +End Conversion. + +#[export] Instance: PFun tconv := pfun_gen _ _ tconv. Section Typing. +Variable conv : (context × term × term) ⇀ exn errors unit. + +#[local] Instance: PFun conv := pfun_gen _ _ conv. + Variant typing_state : Type := | inf_state (** inference *) | check_state (** checking *) @@ -664,7 +633,7 @@ Equations typing_wf_ty : typing_stmt wf_ty_state := { | ty_view1_ty (eSort s) := ok ; | ty_view1_ty (eProd A B) := - rA ← rec (wf_ty_state;Γ;tt;A) ;; + rec (wf_ty_state;Γ;tt;A) ;;[M] rec (wf_ty_state;Γ,,A;tt;B) ; | ty_view1_ty (eNat) := ok ; | ty_view1_ty (eEmpty) := ok ; @@ -688,7 +657,7 @@ Equations typing_wf_ty : typing_stmt wf_ty_state := | (Γ;_;t) with t := { | tRel n with (ctx_access Γ n) := { - | exception _ := raise (variable_not_in_context n Γ) ; + | exception _ := raise variable_not_in_context ; | success d := ret d } ; | tSort s := raise type_error ; @@ -803,7 +772,7 @@ Equations typing_wf_ty : typing_stmt wf_ty_state := Equations typing_check : typing_stmt check_state := | (Γ;T;t) := T' ← rec (inf_state;Γ;tt;t) ;;[M] - ext_call (I:=ϕ) (mkRight conv) (ty_state;Γ;tt;T';T). + ext_call (I:=ϕ) (mkRight conv) (Γ,T',T). Equations typing : ∇ (x : typing_full_dom), [ϕ]⇒[exn errors] tstate_output x.π1 := | (wf_ty_state; Γ; inp; T) := typing_wf_ty (Γ;inp;T) @@ -813,14 +782,20 @@ Equations typing_wf_ty : typing_stmt wf_ty_state := End Typing. -#[export] Instance: PFun typing := pfun_gen _ _ typing. +#[export] Instance: forall conv : (context × term × term) ⇀ exn errors unit, PFun (typing conv). +Proof. + intros conv. + eapply pfun_gen, callablePropsDuo. +Defined. Section CtxTyping. - Equations check_ctx : ∇ (Γ : context), [Sing typing]⇒[exn errors] unit := +Variable conv : (context × term × term) ⇀ exn errors unit. + + Equations check_ctx : ∇ (Γ : context), [Sing (typing conv)]⇒[exn errors] unit := check_ctx ε := ret tt ; check_ctx (Γ,,A) := rec Γ ;;[combined_orec (exn _) _ _ _] - call_single typing (wf_ty_state;Γ;tt;A). + call_single (typing conv) (wf_ty_state;Γ;tt;A). -End CtxTyping. +End CtxTyping. \ No newline at end of file diff --git a/theories/Decidability/NegativeSoundness.v b/theories/Decidability/NegativeSoundness.v new file mode 100644 index 00000000..97dd3161 --- /dev/null +++ b/theories/Decidability/NegativeSoundness.v @@ -0,0 +1,526 @@ +(** * LogRel.Decidability.NegativeSoundness: implementation failure implies negation of typing. *) +From Coq Require Import Nat Lia Arith. +From Equations Require Import Equations. +From LogRel Require Import Syntax.All GenericTyping DeclarativeTyping AlgorithmicTyping. +From LogRel.TypingProperties Require Import PropertiesDefinition DeclarativeProperties SubstConsequences TypeConstructorsInj NeutralConvProperties. +From LogRel.Algorithmic Require Import BundledAlgorithmicTyping AlgorithmicConvProperties AlgorithmicTypingProperties. +From LogRel Require Import Utils. + +From LogRel.Decidability Require Import Functions Soundness Completeness. +From PartialFun Require Import Monad PartialFun MonadExn. + +Set Universe Polymorphism. +Set Printing Primitive Projection Parameters. + +Import DeclarativeTypingProperties. + +Lemma ty_mismatch_hd_view Γ T V (tT : isType T) (tV : isType V) : + build_nf_ty_view2 T V = ty_mismatch T V -> + type_hd_view Γ tT tV = False. +Proof. + destruct tT, tV ; cbn ; try reflexivity. + all: simp build_nf_ty_view2 ; cbn. + 1-6: congruence. + do 2 (unshelve erewrite whne_ty_view1 ; tea) ; cbn. + congruence. +Qed. + +Lemma univ_mismatch_hd_view Γ s T V (tT : isType T) (tV : isType V) : + build_nf_view3 (tSort s) T V = types s (ty_mismatch T V) -> + univ_hd_view Γ tT tV = False. +Proof. + destruct tT, tV ; cbn ; try reflexivity. + all: simp build_nf_view3 build_nf_ty_view2 ; cbn. + 1-5: intros [=]. + do 2 (unshelve erewrite whne_ty_view1 ; tea) ; cbn. + discriminate. +Qed. + +Lemma zip_can t s : ~ isCanonical (zip1 t s). +Proof. + destruct s ; cbn. + all: now intros c ; inversion c. +Qed. + +Lemma mismatch_hd_view Γ A t u (tA : isType A) : + whnf t -> whnf u -> + build_nf_view3 A t u = mismatch A t u -> + (∑ (nft : isNat t) (nfu : isNat u), A = tNat × nat_hd_view Γ nft nfu = False) + + (∑ (nft : isId t) (nfu : isId u) A' x y, A = tId A' x y × id_hd_view Γ A' x y nft nfu = False). +Proof. + intros wt wu. + destruct tA ; cbn. + all: simp build_nf_view3 build_nf_ty_view2 ; cbn. + all: try solve [intros [=]]. + - destruct (build_nf_view1 t), (build_nf_view1 u) ; cbn. + all: try solve [intros [=]]. + all: destruct n ; cbn ; try solve [intros [=]]. + all: destruct n0 ; cbn ; try solve [intros [=]]. + all: unshelve (intros _ ; left ; do 2 eexists). + all: try solve [constructor]. + 1-8: econstructor ; eapply not_can_whne ; tea ; solve [now apply zip_can | intros c ; inversion c]. + all: now cbn. + + - destruct (build_nf_view1 t), (build_nf_view1 u) ; cbn. + all: solve [intros [=]]. + + - destruct (build_nf_view1 t), (build_nf_view1 u) ; cbn. + all: try solve [intros [=]]. + all: destruct n ; cbn ; try solve [intros [=]]. + all: (intros _ ; right ; do 5 eexists). + all: split ; [reflexivity|..]. + Unshelve. + all: try solve [constructor]. + 5-8: econstructor ; eapply not_can_whne ; tea ; solve [now apply zip_can | intros c ; inversion c]. + all: now cbn. + + - unshelve erewrite whne_ty_view1 ; tea ; cbn. + destruct (build_nf_view1 t) ; cbn ; try solve [intros [=]]. + destruct (build_nf_view1 u) ; cbn ; solve [intros [=]]. + +Qed. + +Lemma prod_tm_inj `{TermConstructorsInj (ta := de)} Γ A B A' B' : + [Γ |-[de] tProd A B ≅ tProd A' B' : U] -> + [Γ |-[de] A' ≅ A : U] × [Γ,,A' |-[de] B ≅ B' : U]. +Proof. + unshelve eintros ?%univ_conv_inj. + 1-2: now econstructor. + now cbn in *. +Qed. + +Lemma sig_tm_inj `{TermConstructorsInj (ta := de)} Γ A B A' B' : + [Γ |-[de] tSig A B ≅ tSig A' B' : U] -> + [Γ |-[de] A ≅ A' : U] × [Γ,,A |-[de] B ≅ B' : U]. +Proof. + unshelve eintros ?%univ_conv_inj. + 1-2: now econstructor. + now cbn in *. +Qed. + +Lemma id_tm_inj `{TermConstructorsInj (ta := de)} Γ A x y A' x' y' : + [Γ |-[de] tId A x y ≅ tId A' x' y' : U] -> + [× [Γ |-[de] A ≅ A' : U], [Γ |-[de] x ≅ x' : A] & [Γ |-[de] y ≅ y' : A]]. +Proof. + unshelve eintros ?%univ_conv_inj. + 1-2: now econstructor. + now cbn in *. +Qed. + +Import AlgorithmicTypingProperties. + +Section ConvSoundNeg. + Context `{!TypingSubst (ta := de)} + `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} + `{!TermConstructorsInj (ta := de)} `{!ConvNeutralConvPos (ta := de)}. + + #[universes(polymorphic)]Definition conv_sound_type + (x : conv_full_dom) + (r : conv_full_cod x) : Type := + match x, r with + | (ty_state;Γ;_;T;V), (exception _) => ~ [Γ |-[de] T ≅ V] + | (ty_red_state;Γ;_;T;V), (exception _) => ~ [Γ |-[de] T ≅ V] + | (tm_state;Γ;A;t;u), (exception _) => ~ [Γ |-[de] t ≅ u : A] + | (tm_red_state;Γ;A;t;u), (exception _) => ~ [Γ |-[de] t ≅ u : A] + | (ne_state;Γ;_;m;n), (exception _) => ~ ∑ T, [Γ |-[de] m ~ n : T] + | (ne_red_state;Γ;_;m;n), (exception _) => ~ ∑ T, ([Γ |-[de] m ~ n : T] × whnf T) + | _, success _ => True + end. + + #[universes(polymorphic)]Definition conv_sound_pre + (x : conv_full_dom) : Type := + match x with + | (ty_state;Γ;_;T;V) => [Γ |-[de] T] × [Γ |-[de] V] + | (ty_red_state;Γ;_;T;V) => [× whnf T, whnf V & [Γ |-[de] T] × [Γ |-[de] V]] + | (tm_state;Γ;A;t;u) => [Γ |-[de] t : A] × [Γ |-[de] u : A] + | (tm_red_state;Γ;A;t;u) => [× whnf A, whnf t, whnf u & [Γ |-[de] t : A] × [Γ |-[de] u : A]] + | (ne_state;Γ;_;m;n) => (whne m × whne n) × (well_typed (ta := de) Γ m × well_typed (ta := de) Γ n) + | (ne_red_state;Γ;_;m;n) => (whne m × whne n) × (well_typed (ta := de) Γ m × well_typed (ta := de) Γ n) + end. + + + Lemma _implem_conv_neg_sound : + funrect _conv conv_sound_pre conv_sound_type. + Proof. + intros x pre. + funelim (_conv x) ; cbn in pre |- *. + + 6: simp conv_ne_red ; cbn. + 5: simp conv_ne ; destruct (build_ne_view2 _ _) eqn:e ; cbn ; try easy. + 4: simp conv_tm_red ; destruct (build_nf_view3 _ _ _) as [??? [] | | | | | | | | ] eqn:e ; + cbn ; try easy. + 3: simp conv_tm ; cbn. + 2: simp conv_ty_red ; cbn ; destruct (build_nf_ty_view2 _ _) eqn:e ; cbn. + 1: simp conv_ty ; cbn. + all: try easy. + + - intros T' []%red_sound V' []%red_sound. + eapply typeConvRed_prem2 in pre as [[] Hpost2]%dup ; tea. + split ; [split|..] ; tea. + intros [|] _ Hnty ; cbn in *. + 1: easy. + intros Hty. + eapply Hnty. + etransitivity. + 2: etransitivity ; tea. + 1: symmetry. + all: eapply RedConvTyC, subject_reduction_type ; eauto. + all: boundary. + + - destruct pre as [_ _ [pre [[]]%typePiCongAlg_prem0%dup]%dup]. + split ; [easy|..]. + intros [|] Hty ? ; cbn. + 2: now intros []%prod_ty_inj. + eapply implem_conv_graph, algo_conv_sound in Hty ; cbn in * ; tea. + eapply dup in pre as [pre ?%typePiCongAlg_prem1] ; tea. + split ; [easy|..]. + intros [|] _ Hty' ; [easy|..]. + intros []%prod_ty_inj. + eapply Hty', stability1 ; eassumption. + + - destruct pre as [_ _ [pre [[]]%typeSigCongAlg_prem0%dup]%dup]. + split ; [easy|..]. + intros [|] Hty ? ; cbn in *. + 2: now intros []%sig_ty_inj. + eapply implem_conv_graph, algo_conv_sound in Hty ; tea. + eapply dup in pre as [pre ?%typeSigCongAlg_prem1] ; tea. + split ; [easy|..]. + intros [|] ? Hty' ; [easy|..]. + now intros []%sig_ty_inj. + + - destruct pre as [_ _ [pre [[]]%typeIdCongAlg_prem0%dup]%dup]. + split ; [easy|..]. + intros [|] Hty ? ; cbn. + 2: now intros [? _]%id_ty_inj. + eapply implem_conv_graph, algo_conv_sound in Hty ; tea. + eapply dup in pre as [pre [[]]%typeIdCongAlg_prem1%dup] ; tea. + split ; [easy|..]. + intros [|] Hty' ? ; cbn in *. + 2: now intros []%id_ty_inj. + eapply implem_conv_graph, algo_conv_sound in Hty' ; tea. + eapply dup in pre as [pre ?%typeIdCongAlg_prem2] ; tea. + split ; [easy|..]. + intros [|] ? Hty'' ; cbn in * ; [easy|..]. + now intros []%id_ty_inj. + + - eapply ty_view2_neutral_can in e as []. + destruct pre as [?%not_can_whne ?%not_can_whne pre] ; tea. + eapply dup in pre as [pre [[]]%typeNeuConvAlg_prem2%dup] ; tea. + split ; [now split|..]. + intros [|] _ Hty ; cbn in * ; [easy|..]. + unshelve eintros Hty'%ty_conv_inj. + 1-2: now econstructor. + cbn in Hty'. + unshelve eapply conv_neu_conv_p in Hty' ; eauto. + gen_typing. + + - destruct pre as [wt wu [Ht Hu]]. + eapply type_isType in Ht, Hu ; tea. + unshelve eapply ty_mismatch_hd_view in e ; tea. + unshelve eintros H_view%ty_conv_inj ; tea. + rewrite e in H_view. + eassumption. + + - intros ? []%red_sound ? []%red_sound ? []%red_sound. + eapply termConvRed_prem3 in pre as [[] Hpost3]%dup ; tea. + split ; [split|..] ; tea. + intros [|] _ Hnty ; cbn in * ; [easy|..]. + intros Hty. + eapply Hnty. + eapply TermConv ; refold. + 2: eapply RedConvTyC, subject_reduction_type ; eauto ; boundary. + etransitivity. + 2: etransitivity ; [eassumption|..]. + 1: symmetry. + all: eapply RedConvTeC, subject_reduction ; [..|eassumption]. + all: boundary. + + - destruct s. + destruct pre as [??? [pre [[]]%termPiCongAlg_prem0%dup]%dup]. + split ; [easy|..]. + intros [|] Hty ? ; cbn in *. + 2:now intros []%prod_tm_inj. + eapply implem_conv_graph, algo_conv_sound in Hty ; tea. + eapply dup in pre as [pre ?%termPiCongAlg_prem1] ; tea. + split ; [easy|..]. + intros [|] ? Hty' ; [easy|..]. + intros []%prod_tm_inj. + eapply Hty', stability1 ; tea. + now econstructor. + + - destruct s. + destruct pre as [??? [pre [[]]%termSigCongAlg_prem0%dup]%dup]. + split ; [easy|..]. + intros [|] Hty ? ; cbn in *. + 2:now intros []%sig_tm_inj. + eapply implem_conv_graph, algo_conv_sound in Hty ; tea. + eapply dup in pre as [pre ?%termSigCongAlg_prem1] ; tea. + split ; [easy|..]. + intros [|] ? Hty' ; [easy|..]. + now intros []%sig_tm_inj. + + - destruct s. + destruct pre as [??? [pre [[]]%termIdCongAlg_prem0%dup]%dup]. + split ; [easy|..]. + intros [|] Hty ? ; cbn in *. + 2:now intros []%id_tm_inj. + eapply implem_conv_graph, algo_conv_sound in Hty ; tea. + eapply dup in pre as [pre [? []]%termIdCongAlg_prem1%dup] ; tea. + split ; [easy|..]. + intros [|] Hty'%implem_conv_graph ? ; cbn in *. + 2: now intros []%id_tm_inj. + eapply dup in Hty' as [Hty' ?%algo_conv_sound] ; tea. + eapply dup in pre as [pre ?%termIdCongAlg_prem2] ; tea. + split ; [easy|..]. + intros [|] ? Hty'' ; cbn in * ; [easy|..]. + now intros []%id_tm_inj. + + - destruct pre as [??? [pre [[]]%termNeuConvAlg_prem0%dup]%dup] ; tea. + eapply whnf_view3_ty_neutral_can in e as [?%not_can_whne ?%not_can_whne] ; tea. + split ; [now split|..]. + intros [|] ? Hty ; cbn ; [easy|..]. + + destruct s. + unshelve eintros ?%conv_neu_conv_p ; eauto. + gen_typing. + + - destruct s. + destruct pre as [_ wt wu [Ht Hu]]. + eapply wft_term, type_isType in Ht, Hu ; tea. + unshelve eapply univ_mismatch_hd_view in e ; tea. + unshelve eintros H_view%univ_conv_inj ; tea. + rewrite e in H_view. + eassumption. + + - destruct pre as [??? [pre [[]]%termFunConvAlg_prem2%dup]%dup] ; tea. + split ; [easy|..]. + intros [|] ? Hty ; cbn ; [easy|..]. + + intros Hty'. + eapply Hty. + eapply convtm_meta_conv. + 3: reflexivity. + 1: econstructor. + 1: erewrite <- !wk1_ren_on. + 1: eapply convtm_meta_conv. + 1: eapply convtm_wk ; tea. + + boundary. + + cbn ; reflexivity. + + reflexivity. + + eapply convtm_meta_conv. + 1: do 2 econstructor. + 1: boundary. + constructor. + all: now bsimpl. + + bsimpl ; refold. + rewrite scons_eta'. + now bsimpl. + + - destruct pre as [??? [pre [[]]%termSuccCongAlg_prem0%dup]%dup] ; tea. + split ; [easy|..]. + intros [|] ? Hty ; cbn in * ; [easy|..]. + unshelve eintros ?%nat_conv_inj. + 1-2: now constructor. + cbn in *. + eauto. + + - destruct pre as [??? [pre [[]]%termPairConvAlg_prem2%dup]%dup] ; tea. + split ; [easy|..]. + intros [|] ; cbn in *. + + eintros Hpost ? ; tea. + eapply implem_conv_graph, algo_conv_sound in Hpost ; tea. + eapply termPairConvAlg_prem3 in Hpost ; tea. + split ; [easy|..]. + intros [|]. + 1: now econstructor. + intros ? Hnty Hty. + eapply Hnty. + now econstructor. + + intros ? Hnty Hty. + eapply Hnty. + now econstructor. + + - destruct pre as [??? [pre [[]]%termNeuConvAlg_prem0%dup]%dup] ; tea. + eapply whnf_view3_neutrals_can in e as [Wa Wn Wn'] ; tea. + split. + 1: split ; tea ; eauto using not_can_whne. + intros [|] ; cbn ; [easy|..]. + intros ? Hnty Hty. + eapply not_can_whne in Wn, Wn' ; eauto. + eapply Hnty. + exists A. + now eapply conv_neu_conv_p. + + - destruct pre as [w ?? []]. + eapply type_isType in w. + 2: boundary. + unshelve eapply mismatch_hd_view in e as [(?&?&[->])|(?&?&?&?&?&[->])] ; tea. + + unshelve eintros ?%nat_conv_inj ; tea. + now rewrite e in H. + + + unshelve eintros ?%id_conv_inj ; tea. + now rewrite e in H. + + - destruct (Nat.eqb_spec n n') ; cbn. + + destruct pre as [[] [_ [? [? [(?& []) ?]]%termGen']]] ; subst. + erewrite ctx_access_complete ; cbn. + 1: econstructor. + all: eassumption. + + + intros [? (?&[[= ->]])%neuConvGen]. + eauto. + + - destruct pre as [[wn wn'] [pre [[] ]%neuAppCongAlg_prem0%dup]%dup] ; eauto. + inversion wn ; inversion wn' ; subst. + split ; [easy|..]. + intros [|] ; cbn in *. + + intros [Hpost]%implem_conv_graph ; tea ; refold. + eapply algo_conv_sound in Hpost as [Hconv Hfu ?] ; tea. + eapply dup in pre as [pre [[? (?&[? [? [-> Hf]]]&?)%termGen'] _]]. + eapply Hfu, red_compl_prod_r in Hf as (?&?&[red%redty_sound]). + eapply red_whnf in red ; eauto ; subst. + edestruct neuAppCongAlg_prem1 ; eauto. + + cbn. + split ; [eauto|..]. + intros [|] ? ; cbn in * ; [easy|..]. + + intros Hneg [? (?&?&?&?&[[=]])%neuConvGen] ; subst. + apply Hneg. + eapply TermConv ; refold ; tea. + eapply prod_ty_inj, Hfu. + eauto using conv_neu_sound with boundary. + + + intros ? Hneg [? (?&?&?&?&[[=]])%neuConvGen] ; subst. + apply Hneg. + eexists ; split ; eauto. + now constructor. + + - destruct pre as [[wn wn'] [pre [[] ]%neuNatElimCong_prem0%dup]%dup] ; eauto. + inversion wn ; inversion wn' ; subst. + split ; [easy|..]. + intros [|] ; cbn in *. + 2: shelve. + + intros [Hpost]%implem_conv_graph ; tea. + eapply algo_conv_sound in Hpost as [Hconv Hfu ?] ; tea. + eapply dup in pre as [pre [[? (?&[-> ??? Hn]&?)%termGen'] _]]. + eapply Hfu, red_compl_nat_r, redty_sound, red_whnf in Hn ; eauto ; subst. + eapply dup in pre as [pre [ []]%neuNatElimCong_prem1%dup] ; eauto. + cbn. + split ; [easy|..]. + intros [|] ; cbn. + 2: shelve. + + eintros [Hpost1]%implem_conv_graph%algo_conv_sound%dup ; tea ; cbn in *. + eapply neuNatElimCong_prem2, dup in Hpost1 as [Hpost1 []] ; eauto. + split ; [easy|..]. + intros [|] ; cbn. + 2: shelve. + + intros [Hpost2]%implem_conv_graph%algo_conv_sound%dup ; tea. + eapply neuNatElimCong_prem3, dup in Hpost2 as [Hpost2 []] ; eauto. + split ; [easy|..]. + intros [|] ; cbn ; [easy|..]. + + Unshelve. + all: intros ? Hneg [? (?&?&?&?&[[= <- <- <-]])%neuConvGen] ; subst. + all: apply Hneg ; eauto. + eexists ; split ; gen_typing. + + - destruct pre as [[wn wn'] [pre [[] ]%neuEmptyElimCong_prem0%dup]%dup] ; eauto. + inversion wn ; inversion wn' ; subst. + split ; [easy|..]. + intros [|] ; cbn. + 2: shelve. + + intros [Hpost]%implem_conv_graph ; tea. + eapply algo_conv_sound in Hpost as [Hconv Hfu ?] ; tea. + eapply dup in pre as [pre [[? (?&[-> ? Hn]&?)%termGen'] _]]. + eapply Hfu, red_compl_empty_r, redty_sound, red_whnf in Hn ; eauto ; subst. + eapply dup in pre as [pre [ []]%neuEmptyElimCong_prem1%dup] ; eauto. + cbn. + split ; [easy|..]. + intros [|] ; cbn ; [easy|..]. + + Unshelve. + all: intros ? Hneg [? (?&?&[[=]])%neuConvGen] ; subst. + all: apply Hneg ; eauto. + eexists ; split ; gen_typing. + + - destruct pre as [[wn wn'] [pre [[] ]%neuFstCongAlg_prem0%dup]%dup] ; eauto. + inversion wn ; inversion wn' ; subst. + split ; [easy|..]. + intros [|] ; cbn. + + + intros [Hpost]%implem_conv_graph ; tea. + eapply algo_conv_sound in Hpost as [Hconv Hfu ?] ; tea. + eapply dup in pre as [pre [[? (?&(?&?&->&Hp)&?)%termGen'] _]]. + eapply Hfu, red_compl_sig_r in Hp as (?&?&[red%redty_sound]). + eapply red_whnf in red ; eauto ; subst. + now cbn. + + + intros ? Hneg [? (?&?&?&[[= <-]])%neuConvGen]. + eapply Hneg. + eexists ; split ; gen_typing. + + - destruct pre as [[wn wn'] [pre [[] ]%neuSndCongAlg_prem0%dup]%dup] ; eauto. + inversion wn ; inversion wn' ; subst. + split ; [easy|..]. + intros [|] ; cbn. + + + intros [Hpost]%implem_conv_graph ; tea. + eapply algo_conv_sound in Hpost as [Hconv Hfu ?] ; tea. + eapply dup in pre as [pre [[? (?&(?&?&->&Hp)&?)%termGen'] _]]. + eapply Hfu, red_compl_sig_r in Hp as (?&?&[red%redty_sound]). + eapply red_whnf in red ; eauto ; subst. + now cbn. + + + intros ? Hneg [? (?&?&?&[[= <-]])%neuConvGen]. + eapply Hneg. + eexists ; split ; gen_typing. + + - destruct pre as [[wn wn'] [pre [[] ]%neuIdElimCong_prem0%dup]%dup] ; eauto. + inversion wn ; inversion wn' ; subst. + split ; [easy|..]. + intros [|] ; cbn. + 2: shelve. + + intros [Hpost]%implem_conv_graph ; tea. + eapply algo_conv_sound in Hpost as [Hconv Hfu ?] ; tea. + eapply dup in pre as [pre [[? (?&[-> ????? He]&?)%termGen'] _]]. + eapply Hfu, red_compl_id_r in He as (?&?&?&[red%redty_sound]). + eapply red_whnf in red ; eauto ; subst. + eapply dup in pre as [pre [ []]%neuIdElimCong_prem1%dup] ; eauto. + cbn. + split ; [erewrite <- !wk1_ren_on ; easy|..]. + intros [|] ; cbn. + 2: shelve. + + intros []%implem_conv_graph%algo_conv_sound%dup. + 2-3: now erewrite <- !wk1_ren_on. + eapply neuIdElimCong_prem2 in pre ; eauto. + 2: now rewrite !wk1_ren_on. + split ; [easy|..]. + intros [|] ; cbn ; [easy|..]. + + Unshelve. + all: intros ? Hneg [? (?&?&?&?&?&?&[[= <- <- <-]])%neuConvGen] ; subst. + all: apply Hneg ; eauto. + + eexists ; split ; gen_typing. + + now erewrite <- !wk1_ren_on. + + - intros [? ?%neuConvGen]. + destruct t ; cbn in * ; try solve [easy]. + all: prod_hyp_splitter ; subst. + all: simp build_ne_view2 in e ; cbn in *. + all: congruence. + + - split ; [easy|..]. + intros [|] ? Hty ; cbn ; [easy|..]. + intros [? []]. + now eapply Hty. + + Qed. + +End ConvSoundNeg. \ No newline at end of file diff --git a/theories/Decidability/Soundness.v b/theories/Decidability/Soundness.v index 0f3a4fe5..2e4e8ce9 100644 --- a/theories/Decidability/Soundness.v +++ b/theories/Decidability/Soundness.v @@ -1,9 +1,8 @@ (** * LogRel.Decidability.Soundness: the implementations imply the inductive predicates. *) From Coq Require Import Nat Lia Arith. From Equations Require Import Equations. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Context Notations UntypedReduction GenericTyping NormalForms. -From LogRel Require Import AlgorithmicTyping. +From LogRel Require Import Utils Syntax.All GenericTyping AlgorithmicTyping. + From LogRel.Decidability Require Import Functions. From PartialFun Require Import Monad PartialFun MonadExn. @@ -144,11 +143,65 @@ Section CtxAccessCorrect. End CtxAccessCorrect. Ltac funelim_conv := - funelim (conv _); + funelim (_conv _); [ funelim (conv_ty _) | funelim (conv_ty_red _) | funelim (conv_tm _) | funelim (conv_tm_red _) | funelim (conv_ne _) | funelim (conv_ne_red _) ]. +Lemma ty_view1_small_can T n : build_ty_view1 T = ty_view1_small n -> ~ isCanonical T. +Proof. + destruct T ; cbn. + all: inversion 1. + all: inversion 1. +Qed. + +Lemma tm_view1_neutral_can t n : build_nf_view1 t = nf_view1_ne n -> ~ isCanonical t. +Proof. + destruct t ; cbn. + all: inversion 1. + all: inversion 1. +Qed. + +Lemma ty_view2_neutral_can T V : build_nf_ty_view2 T V = ty_neutrals T V -> ~ isCanonical T × ~ isCanonical V. +Proof. + destruct T, V ; cbn. + all: inversion 1. + all: split ; inversion 1. +Qed. + + +Lemma whnf_view3_ty_neutral_can s t u : build_nf_view3 (tSort s) t u = types s (ty_neutrals t u) -> ~ isCanonical t × ~ isCanonical u. +Proof. + destruct t, u ; cbn. + all: inversion 1. + all: split ; inversion 1. +Qed. + +Lemma whnf_view3_neutrals_can A t u : + whnf A -> + build_nf_view3 A t u = neutrals A t u -> + [× isPosType A, ~ isCanonical t & ~ isCanonical u]. +Proof. + intros HA. + simp build_nf_view3. + destruct (build_ty_view1 A) eqn:EA ; cbn. + all: try solve [inversion 1]. + 1: match goal with | |- context [match ?t with | _ => _ end] => destruct t eqn:? ; cbn end ; + try solve [inversion 1]. + all: simp build_nf_view3 ; cbn. + all: destruct (build_nf_view1 t) eqn:? ; cbn. + all: try solve [inversion 1]. + all: repeat ( + match goal with | |- context [match ?t with | _ => _ end] => destruct t eqn:? ; cbn end ; + try solve [inversion 1]). + all: intros _. + all: split ; try solve [now eapply tm_view1_neutral_can]. + all: econstructor. + eapply ty_view1_small_can in EA. + destruct HA ; try easy. + all: exfalso ; apply EA ; now constructor. +Qed. + Section ConversionSound. @@ -158,16 +211,16 @@ Section ConversionSound. match x, r with | _, (exception _) => True | (ty_state;Γ;_;T;V), (success _) => [Γ |-[al] T ≅ V] - | (ty_red_state;Γ;_;T;V), (success _) => [Γ |-[al] T ≅h V] + | (ty_red_state;Γ;_;T;V), (success _) => whnf T -> whnf V -> [Γ |-[al] T ≅h V] | (tm_state;Γ;A;t;u), (success _) => [Γ |-[al] t ≅ u : A] | (tm_red_state;Γ;A;t;u), (success _) => whnf A -> whnf t -> whnf u -> [Γ |-[al] t ≅h u : A] - | (ne_state;Γ;_;m;n), (success T) => [Γ |-[al] m ~ n ▹ T] - | (ne_red_state;Γ;_;m;n), (success T) => [Γ |-[al] m ~h n ▹ T] × whnf T + | (ne_state;Γ;_;m;n), (success T) => whne m -> whne n -> [Γ |-[al] m ~ n ▹ T] + | (ne_red_state;Γ;_;m;n), (success T) => whne m -> whne n -> [Γ |-[al] m ~h n ▹ T] × whnf T end. Lemma _implem_conv_sound : - funrect conv (fun _ => True) conv_sound_type. + funrect _conv (fun _ => True) conv_sound_type. Proof. intros x _. funelim_conv ; cbn. @@ -180,14 +233,17 @@ Section ConversionSound. | |- context [match ?t with | _ => _ end] => destruct t ; cbn ; try easy | s : sort |- _ => destruct s | H : graph wh_red _ _ |- _ => eapply red_sound in H as [] - | H : (_;_;_;_) = (_;_;_;_) |- _ => injection H; clear H; intros; subst + | H : (_;_;_;_) = (_;_;_;_) |- _ => injection H; clear H; intros; subst + | H : (build_nf_ty_view2 _ _ = ty_neutrals _ _) |- _ => + eapply ty_view2_neutral_can in H as [?%not_can_whne ?%not_can_whne] ; tea + | H : (build_nf_view3 (tSort _) _ _ = types _ (ty_neutrals _ _)) |- _ => + eapply whnf_view3_ty_neutral_can in H as [?%not_can_whne ?%not_can_whne] ; tea + | H : (build_nf_view3 _ _ _ = neutrals _ _ _) |- _ => + eapply whnf_view3_neutrals_can in H as [? ?%not_can_whne ?%not_can_whne] ; tea end). + all: repeat match goal with | H : whne (_ _) |- _ => inversion_clear H end. all: try solve [now econstructor]. - - econstructor ; tea. - now econstructor. - - econstructor ; tea. - destruct H ; simp build_nf_view3 build_ty_view1 in Heq ; try solve [inversion Heq]. - all: try now econstructor. + - econstructor ; eauto. econstructor. - econstructor; tea; [intuition (auto with *)| now rewrite 2!Weakening.wk1_ren_on]. - eapply convne_meta_conv. 2: reflexivity. @@ -196,11 +252,14 @@ Section ConversionSound. + f_equal. symmetry. now eapply Nat.eqb_eq. - - split; tea. now econstructor. + - split; tea. econstructor ; eauto. Qed. - Corollary implem_conv_sound x r : - graph conv x r -> + Arguments conv_full_cod _ /. + Arguments conv_cod _/. + + Corollary implem_conv_graph x r : + graph _conv x r -> conv_sound_type x r. Proof. eapply funrect_graph. @@ -208,23 +267,41 @@ Section ConversionSound. easy. Qed. + Corollary implem_tconv_sound Γ T V : + graph tconv (Γ,T,V) ok -> + [Γ |-[al] T ≅ V]. + Proof. + assert (funrect tconv (fun _ => True) + (fun '(Γ,T,V) r => match r with | success _ => [Γ |-[al] T ≅ V] | _ => True end)) as Hrect. + { + intros ? _. + funelim (tconv _) ; cbn. + intros [] ; cbn ; [|easy]. + eintros ?%funrect_graph. + 2: now apply _implem_conv_sound. + all: now cbn in *. + } + eintros ?%funrect_graph. + 2: eassumption. + all: now cbn in *. + Qed. + End ConversionSound. Ltac funelim_typing := - funelim (typing _); - [ funelim (typing_inf _) | - funelim (typing_check _) | - funelim (typing_inf_red _) | - funelim (typing_wf_ty _) ]. + funelim (typing _ _); + [ funelim (typing_inf _ _) | + funelim (typing_check _ _) | + funelim (typing_inf_red _ _) | + funelim (typing_wf_ty _ _) ]. -Section TypingCorrect. +Section TypingSound. - Lemma ty_view1_small_can T n : build_ty_view1 T = ty_view1_small n -> ~ isCanonical T. - Proof. - destruct T ; cbn. - all: inversion 1. - all: inversion 1. - Qed. + Variable conv : (context × term × term) ⇀ exn errors unit. + + Hypothesis conv_sound : forall Γ T V, + graph conv (Γ,T,V) ok -> + [Γ |-[al] T ≅ V]. #[universes(polymorphic)]Definition typing_sound_type (x : ∑ (c : typing_state) (_ : context) (_ : tstate_input c), term) @@ -237,9 +314,8 @@ Section TypingCorrect. | (check_state;Γ;T;t), (success _) => [Γ |-[al] t ◃ T] end. - Lemma _implem_typing_sound : - funrect typing (fun _ => True) typing_sound_type. + funrect (typing conv) (fun _ => True) typing_sound_type. Proof. intros x _. funelim_typing ; cbn. @@ -259,10 +335,13 @@ Section TypingCorrect. end). all: try now econstructor. econstructor; tea; now rewrite 2!Weakening.wk1_ren_on. + econstructor ; tea. + apply conv_sound. + now match goal with | H : unit |- _ => destruct H end. Qed. Lemma implem_typing_sound x r: - graph typing x r -> + graph (typing conv) x r -> typing_sound_type x r. Proof. eapply funrect_graph. @@ -270,25 +349,21 @@ Section TypingCorrect. easy. Qed. -End TypingCorrect. - -Section CtxTypingSound. - Lemma _check_ctx_sound : - funrect check_ctx (fun _ => True) (fun Γ r => if r then [|- Γ] else True). + funrect (check_ctx conv) (fun _ => True) (fun Γ r => if r then [|- Γ] else True). Proof. intros ? _. - funelim (check_ctx _) ; cbn. + funelim (check_ctx _ _) ; cbn. - now constructor. - split ; [easy|]. intros [|] ; cbn ; try easy. - intros ? [] ?%implem_typing_sound ; cbn in *. + intros ? ? [] ?%implem_typing_sound ; cbn in *. 2: easy. now econstructor. Qed. Lemma check_ctx_sound Γ : - graph check_ctx Γ (success tt) -> + graph (check_ctx conv) Γ ok -> [|-[al] Γ]. Proof. eintros ?%funrect_graph. @@ -296,4 +371,4 @@ Section CtxTypingSound. all: easy. Qed. -End CtxTypingSound. +End TypingSound. \ No newline at end of file diff --git a/theories/Decidability/Termination.v b/theories/Decidability/Termination.v index 795a7a42..8fe2d38d 100644 --- a/theories/Decidability/Termination.v +++ b/theories/Decidability/Termination.v @@ -1,545 +1,491 @@ (** * LogRel.Decidability.Termination: the implementation always terminates on well-typed inputs. *) From Coq Require Import Nat Lia Arith. From Equations Require Import Equations. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Context Notations UntypedReduction DeclarativeTyping DeclarativeInstance GenericTyping NormalForms. -From LogRel Require Import Validity LogicalRelation Fundamental DeclarativeSubst TypeConstructorsInj AlgorithmicTyping BundledAlgorithmicTyping Normalisation AlgorithmicConvProperties AlgorithmicTypingProperties. +From LogRel Require Import Syntax.All DeclarativeTyping GenericTyping AlgorithmicTyping. +From LogRel.TypingProperties Require Import DeclarativeProperties PropertiesDefinition SubstConsequences TypeConstructorsInj NeutralConvProperties. +From LogRel.Algorithmic Require Import BundledAlgorithmicTyping AlgorithmicConvProperties AlgorithmicTypingProperties. +From LogRel Require Import Utils. + From LogRel.Decidability Require Import Functions Soundness Completeness. -From PartialFun Require Import Monad PartialFun. +From PartialFun Require Import Monad PartialFun MonadExn. Set Universe Polymorphism. -Import DeclarativeTypingProperties. +Import DeclarativeTypingProperties AlgorithmicTypingData. Section ConversionTerminates. + Context + `{!TypingSubst (ta := de)} + `{!TypeReductionComplete (ta := de)} + `{!TypeConstructorsInj (ta := de)} + `{!ConvComplete (ta := de) (ta' := al)} + `{!Normalisation (ta := de)}. Let PTyEq (Γ : context) (A B : term) := forall v B', - [Γ |-[de] B'] -> - domain conv (ty_state;Γ;v;A;B'). + [Γ |-[de] A] × [Γ |-[de] B'] -> + domain _conv (ty_state;Γ;v;A;B'). Let PTyRedEq (Γ : context) (A B : term) := forall v B', isType B' -> - [Γ |-[de] B'] -> - domain conv (ty_red_state;Γ;v;A;B'). + [Γ |-[de] A] × [Γ |-[de] B'] -> + domain _conv (ty_red_state;Γ;v;A;B'). Let PNeEq (Γ : context) (A t u : term) := forall v u', whne u' -> - well_typed (ta := de) Γ u' -> - domain conv (ne_state;Γ;v;t;u'). + well_typed (ta := de) Γ t × well_typed (ta := de) Γ u' -> + domain _conv (ne_state;Γ;v;t;u'). Let PNeRedEq (Γ : context) (A t u : term) := forall v u', whne u' -> - well_typed (ta := de) Γ u' -> - domain conv (ne_red_state;Γ;v;t;u'). + well_typed (ta := de) Γ t × well_typed (ta := de) Γ u' -> + domain _conv (ne_red_state;Γ;v;t;u'). Let PTmEq (Γ : context) (A t u : term) := forall u', - [Γ |-[de] u' : A] -> - domain conv (tm_state;Γ;A;t;u'). + [Γ |-[de] t : A] × [Γ |-[de] u' : A] -> + domain _conv (tm_state;Γ;A;t;u'). Let PTmRedEq (Γ : context) (A t u : term) := forall u', whnf u' -> - [Γ |-[de] u' : A] -> - domain conv (tm_red_state;Γ;A;t;u'). + [Γ |-[de] t : A] × [Γ |-[de] u' : A] -> + domain _conv (tm_red_state;Γ;A;t;u'). Theorem _conv_terminates : - BundledConvInductionConcl PTyEq PTyRedEq PNeEq PNeRedEq PTmEq PTmRedEq. + AlgoConvInductionConcl PTyEq PTyRedEq PNeEq PNeRedEq PTmEq PTmRedEq. Proof. subst PTyEq PTyRedEq PNeEq PNeRedEq PTmEq PTmRedEq. - apply BundledConvInduction. - - intros * ?? HA' [IH] **. + apply AlgoConvInduction. + + - intros * ?? HA IHA * [? Hconcl]%dup. apply compute_domain. - simp conv conv_ty. + simp _conv conv_ty. cbn. split. - 1: eapply wh_red_complete ; now exists istype. - intros A''; split. - 1: eapply wh_red_complete ; now exists istype. - intros B'' ; split. - 2: intros x; destruct x; cbn; easy. - assert [Γ |- B'']. - { - eapply boundary_red_ty_r, subject_reduction_type. - 2: now eapply red_sound. - eassumption. - } - replace A'' with A'. - 1: apply (IH tt B''). - + eapply type_isType ; tea. - now eapply red_sound. - + eassumption. - + eapply whred_det ; tea. - 1: now eapply algo_conv_wh in HA' as [] ; gen_typing. - all: now eapply red_sound. - - intros * ? [IHA] ? [IHB] ? []%prod_ty_inv []%prod_ty_inv ? B' wB' HtyB'. - apply compute_domain. - simp conv conv_ty_red. - destruct wB' as [|A'' B''| | | | |? wB']. - all: simp build_nf_ty_view2 ; cbn ; try easy. - 2: now rewrite (whne_ty_view1 wB') ; cbn. - apply prod_ty_inv in HtyB' as []. + now eapply wh_red_complete ; [exists istype|eapply ty_norm]. + intros A'' []%red_sound. split. - 2: intros [] ; cbn ; [|easy]. - 2: intros Hconv%implem_conv_sound%algo_conv_sound ; tea ; split . - + now apply (IHA tt A''). - + apply (IHB tt B''). - now eapply stability1. - + intros []; cbn; easy. - - intros * ??? ? ? wB' ?. + 1: now eapply wh_red_complete ; [exists istype|eapply ty_norm]. + intros B'' []%red_sound. + replace A'' with A' + by (eapply whred_det ; tea ; eapply algo_conv_wh in HA as [] ; gen_typing). + + eapply typeConvRed_prem2, IHA in Hconcl as [] ; eauto. + 2: now eapply type_isType. + split ; [now eexists|..]. + now intros [] ; cbn. + + - intros * ???? * wB' [Hconcl]%dup. apply compute_domain. - simp conv conv_ty_red. + simp _conv conv_ty_red. destruct wB'. all: simp build_nf_ty_view2 ; cbn ; try easy. - match goal with H : whne _ |- _ => now rewrite (whne_ty_view1 H) ; cbn end. - - intros * ??? ? ? wB' ?. + 2: now unshelve erewrite (whne_ty_view1 _) ; cbn. + + eapply typePiCongAlg_prem0 in Hconcl as [Hpre0 []]%dup. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros Hpost0%implem_conv_graph%algo_conv_sound ; eauto. + eapply typePiCongAlg_prem1 in Hpost0 ; eauto. + + - intros * wB' ?. apply compute_domain. - simp conv conv_ty_red. + simp _conv conv_ty_red. destruct wB'. all: simp build_nf_ty_view2 ; cbn ; try easy. - match goal with H : whne _ |- _ => now rewrite (whne_ty_view1 H) ; cbn end. - - intros * ??? ? ? wB' ?. + now unshelve erewrite (whne_ty_view1 _) ; cbn. + + - intros * wB' ?. apply compute_domain. - simp conv conv_ty_red. + simp _conv conv_ty_red. destruct wB'. all: simp build_nf_ty_view2 ; cbn ; try easy. - match goal with H : whne _ |- _ => now rewrite (whne_ty_view1 H) ; cbn end. - - intros * ? [IHA] ? [IHB] ? []%sig_ty_inv []%sig_ty_inv ? B' wB' HtyB'. + now unshelve erewrite (whne_ty_view1 _) ; cbn. + + - intros * wB' ?. apply compute_domain. - simp conv conv_ty_red. - destruct wB' as [| | | | A'' B'' | | ? wB']. + simp _conv conv_ty_red. + destruct wB'. all: simp build_nf_ty_view2 ; cbn ; try easy. - 2: now rewrite (whne_ty_view1 wB') ; cbn. - apply sig_ty_inv in HtyB' as []. - split. - 2: intros x; destruct x ; cbn ; [|easy]. - 2: intros Hconv%implem_conv_sound%algo_conv_sound ; tea ; split. - + now apply (IHA tt A''). - + apply (IHB tt B''). - now eapply stability1. - + intros []; easy. - - intros * ? [ihA] ? [ihx] ? [ihy] ? [? []]%id_ty_inv [? []]%id_ty_inv * wB' htyB'. + now unshelve erewrite (whne_ty_view1 _) ; cbn. + + - intros * ? ? ? ? * wB' [Hconcl]%dup. apply compute_domain. - simp conv conv_ty_red. - destruct wB' as [| | | | |A'' x'' y''| ? wB']. - all: simp build_nf_ty_view2 ; cbn. - 1-5: easy. - 2: now rewrite (whne_ty_view1 wB') ; cbn. - apply id_ty_inv in htyB' as [? []]. - split; cycle -1. - 1: intros []; cbn;[|easy]. - 1: intros HconvA%implem_conv_sound%algo_conv_sound; tea; split; cycle -1. - 1: intros []; cbn;[|easy]. - 1: intros Hconvx%implem_conv_sound%algo_conv_sound; tea. - 1: split; cycle -1. - 1: intros []; cbn;easy. - + apply (ihy y''); now econstructor. - + now econstructor. - + apply (ihx x''); now econstructor. - + now apply (ihA tt A''). - - intros * HM [IHM []] ??? ? ? wB' Hty. + simp _conv conv_ty_red. + destruct wB'. + all: simp build_nf_ty_view2 ; cbn ; try easy. + 2: now unshelve erewrite (whne_ty_view1 _) ; cbn. + + eapply typeSigCongAlg_prem0 in Hconcl as [Hpre0 []]%dup. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros Hpost0%implem_conv_graph%algo_conv_sound ; eauto. + eapply typeSigCongAlg_prem1 in Hpost0 ; eauto. + + - intros * ? ? ? ? ? ? * wB' [Hconcl]%dup. apply compute_domain. - simp conv conv_ty_red. - eapply algo_conv_wh in HM as []. + simp _conv conv_ty_red. destruct wB'. - 1-6: simp build_nf_ty_view2 ; cbn. + all: simp build_nf_ty_view2 ; cbn ; try easy. + 2: now unshelve erewrite (whne_ty_view1 _) ; cbn. + + eapply typeIdCongAlg_prem0 in Hconcl as [Hpre0 []]%dup. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [Hpost0]%implem_conv_graph%algo_conv_sound%dup ; eauto. + eapply typeIdCongAlg_prem1 in Hpost0 as [[]]%dup ; eauto. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros Hpost1%implem_conv_graph%algo_conv_sound ; eauto. + eapply typeIdCongAlg_prem2 in Hpost1 ; eauto. + + - intros * ?? ?? * wB' [Hconcl]%dup. + apply compute_domain. + simp _conv conv_ty_red build_nf_ty_view2. + destruct wB' ; cbn. 1-6: now unshelve erewrite whne_ty_view1 ; cbn. - erewrite whne_ty_view2 ; tea. - split. - 2: intros [|] ; cbn ; easy. - eapply (IHM tt A) ; tea. - apply neutral_ty_inv in Hty; [|tea]. - now exists U. - - intros * ???? ? ? wu' ?. + do 2 (unshelve erewrite whne_ty_view1 ; tea) ; cbn. + + eapply typeNeuConvAlg_prem2 in Hconcl as [Hpre0 []]%dup ; eauto. + now split ; [..| intros []] ; cbn. + + - intros ? n ? ? * wu' [Hconcl]%dup. apply compute_domain. - destruct wu' as [n'| | | | | |]. - all: simp conv conv_ne to_neutral_diag ; cbn ; try easy. - destruct (Nat.eqb_spec n n') ; cbn. + simp _conv conv_ne build_ne_view2 ; cbn. + unshelve erewrite (whne_nf_view1) ; tea ; cbn. + destruct (whne_ne_view1 wu') as [n'|] ; cbn ; try easy. + edestruct (Nat.eqb_spec n n') ; cbn. 2: easy. erewrite ctx_access_complete ; tea. - now econstructor. - - intros ? ???? A B Hm [IHm []] ? [IHt] ??? ? u' wu' Hty. + now cbn. + + - intros * Hm ? ?? * wu' [Hconcl]%dup. apply compute_domain. - destruct wu' as [|m' t'| | | | |]. - all: simp conv conv_ne to_neutral_diag ; cbn; try exact I. - split. - + apply (IHm tt m') ; tea. - destruct Hty as [? (?&(?&?&[])&?)%termGen']. - now eexists. - + destruct Hty as [? (?&(?&?&[??Htym'])&?)%termGen'] ; subst. - intros [T|] ; cbn ; [|easy] ; intros [Hconvm?]%implem_conv_sound. - assert (T = tProd A B) by now eapply algo_conv_det. - subst. - apply algo_conv_sound in Hconvm as [?? Hgenm']. - 2-3: now eexists ; boundary. - apply Hgenm' in Htym' as []%prod_ty_inj. - cbn. - split. - 2: intros [|] ? ; cbn ; easy. - eapply (IHt t'). - gen_typing. - - intros * Hn [IHn] ? [IHP] ? [IHz] ? [IHs] ??? ? u' wu' Hty. + simp _conv conv_ne build_ne_view2 ; cbn. + unshelve erewrite (whne_nf_view1) ; tea ; cbn. + destruct (whne_ne_view1 wu') as [|? []] ; cbn in * ; try easy. + inversion wu' ; subst. + + eapply neuAppCongAlg_prem0 in Hconcl as [Hpre0 []]%dup ; eauto. + split ; [eauto|intros [] ; cbn ; [|easy]]. + + intros [Hpost1]%implem_conv_graph ; eauto. + 1: now eapply algo_conv_wh in Hm as []. + eapply algo_conv_det in Hm ; tea ; subst. + eapply algo_conv_sound, neuAppCongAlg_prem1 in Hpost1 as [[]]%dup ; eauto. + now split ; [eauto | intros [] ; cbn]. + + - intros * Hn ? ?? ?? ?? * wu' [Hconcl]%dup. apply compute_domain. - destruct wu' as [| |P'' hz'' hs'' n''| | | |]. - all: simp conv conv_ne to_neutral_diag ; cbn ; try exact I. - destruct Hty as [? (?&[]&?)%termGen']. - split. - 1: apply (IHn tt n'') ; tea ; now eexists. - intros [T|] ; cbn ; [|easy] ; intros [HconvT ?]%implem_conv_sound. - eapply algo_conv_det in HconvT as ->. - 2: now apply Hn. - cbn. - split. - 1: now apply (IHP tt P''). - intros [|] ; cbn ; [|easy] ; intros HconvP%implem_conv_sound%algo_conv_sound. - 2-3: boundary. - split. - 1:{ - specialize (IHz hz'') ; apply IHz. - econstructor ; tea. - eapply typing_subst1. - 2: now symmetry. - now do 2 econstructor. - } - assert (domain conv (tm_state; Γ; elimSuccHypTy P; hs; hs'')). - { - specialize (IHs hs'') ; apply IHs. - econstructor ; tea. - eapply elimSuccHypTy_conv ; tea. - now symmetry. - } - intros [|] ; cbn. - 2: now split. - intros ? ; split. - 1: assumption. - now intros [|] ; cbn. - - intros * He [IHe] ? [IHP] ??? ? u' wu' Hty. + simp _conv conv_ne build_ne_view2 ; cbn. + unshelve erewrite (whne_nf_view1) ; tea ; cbn. + destruct (whne_ne_view1 wu') as [|? []] ; cbn in * ; try easy. + inversion wu' ; subst. + + eapply neuNatElimCong_prem0 in Hconcl as [Hpre0 []]%dup ; eauto. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [Hpost1]%implem_conv_graph ; eauto. + 1: now eapply algo_conv_wh in Hn as []. + eapply algo_conv_det in Hn ; tea ; subst. + eapply algo_conv_sound in Hpost1 as [[] [Hpost1]%dup]%dup ; eauto. + eapply neuNatElimCong_prem1 in Hpost1 as [[]]%dup ; eauto. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [Hpost2]%implem_conv_graph%algo_conv_sound%dup ; eauto. + eapply neuNatElimCong_prem2 in Hpost2 as [[]]%dup ; eauto. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [Hpost3]%implem_conv_graph%algo_conv_sound%dup ; eauto. + eapply neuNatElimCong_prem3 in Hpost3 ; eauto. + now split ; [eauto | intros [] ; cbn]. + + - intros * Hn ? ?? * wu' [Hconcl]%dup. apply compute_domain. - destruct wu' as [| | | P'' e'' | | |]. - all: simp conv conv_ne to_neutral_diag ; cbn ; try exact I. - destruct Hty as [? (?&[]&?)%termGen']. - split. - 1: apply (IHe tt e'') ; tea ; now eexists. - intros [T|] ; cbn ; [|easy] ; intros [HconvT ?]%implem_conv_sound. - eapply algo_conv_det in HconvT as ->. - 2: now apply He. - cbn. - split. - 1: now apply (IHP tt P''). - intros [|] ; cbn ; easy. - - intros * h [ih []] ??? ? u' wu' Hty. + simp _conv conv_ne build_ne_view2 ; cbn. + unshelve erewrite (whne_nf_view1) ; tea ; cbn. + destruct (whne_ne_view1 wu') as [|? []] ; cbn in * ; try easy. + inversion wu' ; subst. + + eapply neuEmptyElimCong_prem0 in Hconcl as [Hpre0 []]%dup ; eauto. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [Hpost1]%implem_conv_graph ; eauto. + 1: now eapply algo_conv_wh in Hn as []. + eapply algo_conv_det in Hn ; tea ; subst. + eapply algo_conv_sound in Hpost1 as [[] [Hpost1]%dup]%dup ; eauto. + eapply neuEmptyElimCong_prem1 in Hpost1 ; eauto. + now split ; [eauto | intros [] ; cbn]. + + - intros * Hn ? * wu' [Hconcl]%dup. apply compute_domain. - destruct wu' as [| | | | t | |]. - all: simp conv conv_ne to_neutral_diag ; cbn ; try exact I. - destruct Hty as [? hu'%termGen']; cbn in hu'; prod_hyp_splitter; subst. - split. - 1: apply (ih tt t); tea; now eexists. - intros [T|]; cbn ; [|easy]. - intros [Hconv ?]%implem_conv_sound. - eapply algo_conv_det in Hconv as ->. - 2: now eapply h. + simp _conv conv_ne build_ne_view2 ; cbn. + unshelve erewrite (whne_nf_view1) ; tea ; cbn. + destruct (whne_ne_view1 wu') as [|? []] ; cbn in * ; try easy. + inversion wu' ; subst. + + eapply neuFstCongAlg_prem0 in Hconcl as [Hpre0 []]%dup ; eauto. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [Hpost1]%implem_conv_graph ; eauto. + 1: now eapply algo_conv_wh in Hn as []. + eapply algo_conv_det in Hn ; tea ; subst. now cbn. - - intros * h [ih []] ??? ? u' wu' Hty. + + - intros * Hn ? * wu' [Hconcl]%dup. apply compute_domain. - destruct wu' as [| | | | | t | ]. - all: simp conv conv_ne to_neutral_diag ; cbn ; try exact I. - destruct Hty as [? hu'%termGen']; cbn in hu'; prod_hyp_splitter; subst. - split. - 1: apply (ih tt t); tea; now eexists. - intros [T|]; cbn ; [|easy]. - intros [Hconv ?]%implem_conv_sound. - eapply algo_conv_det in Hconv as ->. - 2: now eapply h. + simp _conv conv_ne build_ne_view2 ; cbn. + unshelve erewrite (whne_nf_view1) ; tea ; cbn. + destruct (whne_ne_view1 wu') as [|? []] ; cbn in * ; try easy. + inversion wu' ; subst. + + eapply neuSndCongAlg_prem0 in Hconcl as [Hpre0 []]%dup ; eauto. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [Hpost1]%implem_conv_graph ; eauto. + 1: now eapply algo_conv_wh in Hn as []. + eapply algo_conv_det in Hn ; tea ; subst. now cbn. - - intros * he [ihe []] ? [ihA] ? [ihx] ? [ihP] ? [ihhr] ? [ihy] ??? ?? wu' Hu'. + + - intros * _ * _ * _ * Hn ? ?? ?? ?? * wu' [Hconcl]%dup. apply compute_domain. - destruct wu' as [| | | | | | A0 x0 P0 hr0 y0 e0]. - all: simp conv conv_ne to_neutral_diag ; cbn ; try exact I. - destruct Hu' as [? hu'%termGen']; cbn in hu'; prod_hyp_splitter; subst. - split. - 1: apply (ihe tt e0); tea; now eexists. - intros [T|]; cbn ; [|easy]. - intros [Hconve ?]%implem_conv_sound. - eapply algo_conv_det in Hconve as ->. - 2: now eapply he. - split. - 1: apply (ihA tt A0); tea; now eexists. - intros [|]; cbn ; [|easy]. - intros HconvA%implem_conv_sound%algo_conv_sound. - 2,3: boundary. - split. - 1: apply (ihx x0); try now econstructor. - intros [|]; cbn ; [|easy]. - intros Hconvx%implem_conv_sound%algo_conv_sound. - rewrite <- !(Weakening.wk1_ren_on Γ A). - assert [(Γ,, A),, tId A⟨@Weakening.wk1 Γ A⟩ x⟨@Weakening.wk1 Γ A⟩ (tRel 0) |-[ de ] P0]. - 1:{ - eapply stability; tea; symmetry; eapply idElimMotiveCtxConv; tea. - 1: now eapply ctx_refl. - 1,2: eapply idElimMotiveCtx; tea; boundary. - } - split. - 1: apply (ihP tt P0); tea. - 2: boundary. - 2: econstructor; tea; now symmetry. - intros [|]; cbn; [|easy]. - intros HconvP%implem_conv_sound%algo_conv_sound; tea. - 2: boundary. - assert [Γ |-[ de ] hr0 : P[tRefl A x .: x..]]. - 1:{ - econstructor; tea; symmetry. - eapply typing_subst2; tea. - cbn; rewrite 2!Weakening.wk1_ren_on, 2!shift_subst_eq. - now econstructor. - } - split. - 1: apply (ihhr hr0); tea. - intros [|]; cbn; [|easy]. - intros Hconvhr%implem_conv_sound%algo_conv_sound; tea. - 2: boundary. - split. - 1: apply (ihy y0); try now econstructor. - intros [|]; cbn; easy. - - intros * ? [IHm] ?? ??? ? u' wu' Hty. + simp _conv conv_ne build_ne_view2 ; cbn. + unshelve erewrite (whne_nf_view1) ; tea ; cbn. + destruct (whne_ne_view1 wu') as [|? []] ; cbn in * ; try easy. + inversion wu' ; subst. + + eapply neuIdElimCong_prem0 in Hconcl as [Hpre0 []]%dup ; eauto. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [Hpost1]%implem_conv_graph ; eauto. + 1: now eapply algo_conv_wh in Hn as []. + eapply algo_conv_det in Hn ; tea ; subst. + eapply algo_conv_sound in Hpost1 as [[] [Hpost1]%dup]%dup ; eauto. + eapply neuIdElimCong_prem1 in Hpost1 as [[]]%dup ; eauto. + repeat erewrite <- wk1_ren_on. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [Hpost2]%implem_conv_graph%algo_conv_sound%dup ; eauto. + eapply neuIdElimCong_prem2 in Hpost2 as [[]]%dup ; eauto. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros ?%implem_conv_graph%algo_conv_sound ; eauto. + + - intros * Hm ? ? ? * wu' [Hconcl []]%dup. apply compute_domain. - simp conv conv_ne_red ; cbn. - split. - 2: intros [T|] ; cbn ; [|easy] ; intros []%implem_conv_sound%algo_conv_sound ; tea. - 2: split ; [|easy]. - + now apply (IHm tt u'). - + eapply wh_red_complete. - exists istype. - boundary. - - intros * ??? Hconv [IHt'] ??? u' Hty. + simp _conv conv_ne_red ; cbn. + + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [Hpost0 []]%implem_conv_graph%algo_conv_sound%dup ; eauto. + 2: now eapply algo_conv_wh in Hm as []. + split ; [..|easy]. + eapply wh_red_complete ; [exists istype|eapply ty_norm] ; boundary. + + - intros * ??? []%algo_conv_wh IH * [Hconcl []]%dup. apply compute_domain. - simp conv conv_tm ; cbn. + simp _conv conv_tm ; cbn. + split. - 2: intros A'' [redA]%red_sound ; split. - 3: intros t'' []%red_sound ; split. - 4: intros u'' [redu]%red_sound ; split. - + eapply wh_red_complete. - exists istype. - boundary. - + eapply wh_red_complete. - now eexists (isterm _). - + eapply wh_red_complete. - now eexists (isterm _). - + assert (A'' = A'). - { - eapply whred_det ; tea. - apply algo_conv_wh in Hconv as []. - gen_typing. - } - assert (t'' = t'). - { - eapply whred_det ; tea. - now apply algo_conv_wh in Hconv as []. - } - subst. - eapply (IHt' u'') ; tea. - eapply subject_reduction in redu ; tea. - econstructor. - 1: boundary. - eapply subject_reduction_type in redA as [] ; refold ; tea. - now boundary. - + intros x; destruct x; cbn; easy. - - intros * ? [IHA] ? [IHB] ??? u' wu' Hty. + 1: eapply wh_red_complete ; [exists istype|eapply ty_norm] ; boundary. + intros A'' []%red_sound. + split. + 1: now eapply wh_red_complete ; [eexists (isterm _)|eapply tm_norm]. + intros t'' []%red_sound. + split. + 1: now eapply wh_red_complete ; [eexists (isterm _)|eapply tm_norm]. + intros u'' []%red_sound. + + replace A'' with A' in * by (now eapply whred_det ; gen_typing). + replace t'' with t' in * by (eapply whred_det ; eassumption). + + eapply termConvRed_prem3 in Hconcl ; eauto. + now split ; [..| intros [] ; cbn]. + + - intros * ?? ?? * wu' [Hconcl []]%dup. apply compute_domain. - simp conv conv_tm_red build_nf_view3 build_nf_ty_view2. + simp _conv conv_tm_red build_nf_view3 build_nf_ty_view2. eapply Uterm_isType in wu' ; tea. - destruct wu' as [ | A'' B'' | | | | | ? wu'] ; cycle -1. - 1: rewrite (whne_ty_view1 wu'). - all: cbn ; try exact I. - eapply termGen' in Hty as (?&[]&?) ; subst. - split. - 2: intros [|] ; cbn ; [|easy] ; intros ?%implem_conv_sound%algo_conv_sound. - 3-4: boundary. - 2: split. - + now apply (IHA A''). - + apply (IHB B''). - eapply stability1 ; tea. - 1-2: boundary. - now constructor. - + intros []; now cbn. - - intros * ??? u' wu' Hty. + destruct wu' ; cbn ; try exact I. + 2: now unshelve erewrite (whne_ty_view1 _) ; cbn. + + eapply termPiCongAlg_prem0 in Hconcl as [Hpre0 []]%dup. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros Hpost0%implem_conv_graph%algo_conv_sound ; eauto. + eapply termPiCongAlg_prem1 in Hpost0 ; eauto. + + - intros * wu' [Hconcl []]%dup. apply compute_domain. - simp conv conv_tm_red build_nf_view3 build_nf_ty_view2. + simp _conv conv_tm_red build_nf_view3 build_nf_ty_view2. eapply Uterm_isType in wu' ; tea. - destruct wu' as [ | | | | | | ? wu'] ; cycle -1. - 1: rewrite (whne_ty_view1 wu'). - all: now cbn. - - intros * ??? u' wu' Hty. + destruct wu' ; cbn ; try exact I. + now unshelve erewrite (whne_ty_view1 _) ; cbn. + + - intros * wu' [Hconcl []]%dup. apply compute_domain. - simp conv conv_tm_red build_nf_view3 build_nf_ty_view2. + simp _conv conv_tm_red build_nf_view3 build_nf_ty_view2. eapply nat_isNat in wu' ; tea. - destruct wu' as [ | | ? wu'] ; cycle -1. - 1: rewrite (whne_nf_view1 wu'). - all: now cbn. - - intros * ? [IHt] ??? u' wu' Hty. + destruct wu' ; cbn ; try exact I. + now unshelve erewrite (whne_nf_view1 _) ; cbn. + + - intros * ?? * wu' [Hconcl []]%dup. apply compute_domain. - simp conv conv_tm_red build_nf_view3 build_nf_ty_view2. + simp _conv conv_tm_red build_nf_view3 build_nf_ty_view2. eapply nat_isNat in wu' ; tea. - destruct wu' as [ | u' | ? wu'] ; cycle -1. - 1: rewrite (whne_nf_view1 wu'). - all: cbn ; try easy. - split. - 2: now intros [|] ; cbn. - eapply (IHt u'). - now apply termGen' in Hty as (?&[]&?). - - intros * ??? u' wu' Hty. + destruct wu' ; cbn ; try exact I. + 2: now unshelve erewrite (whne_nf_view1 _) ; cbn. + + eapply termSuccCongAlg_prem0 in Hconcl ; eauto. + + - intros * wu' [Hconcl []]%dup. apply compute_domain. - simp conv conv_tm_red build_nf_view3 build_nf_ty_view2. + simp _conv conv_tm_red build_nf_view3 build_nf_ty_view2. eapply Uterm_isType in wu' ; tea. - destruct wu' as [ | | | | | | ? wu'] ; cycle -1. - 1: rewrite (whne_ty_view1 wu'). - all: now cbn. - - intros * ?? ? [IHf] ??? u' wu' Hty. + destruct wu' ; cbn ; try exact I. + now unshelve erewrite (whne_ty_view1 _) ; cbn. + + - intros * ?? ?? ? wu' [Hconcl]%dup. apply compute_domain. - simp conv conv_tm_red build_nf_view3 ; cbn. - split. - 2: intros x; destruct x; now cbn. - specialize (IHf (eta_expand u')). - apply IHf. - now eapply typing_eta'. - - intros * ? [IHA] ? [IHB] ??? u' wu' Hty. + simp _conv conv_tm_red build_nf_view3 ; cbn. + + now eapply termFunConvAlg_prem2 in Hconcl. + + - intros * ?? ?? * wu' [Hconcl []]%dup. apply compute_domain. - simp conv conv_tm_red build_nf_view3 build_nf_ty_view2. + simp _conv conv_tm_red build_nf_view3 build_nf_ty_view2. eapply Uterm_isType in wu' ; tea. - destruct wu' as [ | | | | A'' B'' | | ? wu'] ; cycle -1. - 1: rewrite (whne_ty_view1 wu'). - all: cbn ; try easy. - eapply termGen' in Hty as (?&[]&?) ; subst. - split. - 2: intros [|] ; cbn ; [|easy] ; intros ?%implem_conv_sound%algo_conv_sound. - 3-4: boundary. - 2: split. - + now apply (IHA A''). - + apply (IHB B''). - eapply stability1 ; tea. - 1-2: boundary. - now constructor. - + intros []; now cbn. - - intros * ?? ? [ihFst] ? [ihSnd] ??? u' wu' Hty. + destruct wu' ; cbn ; try exact I. + 2: now unshelve erewrite (whne_ty_view1 _) ; cbn. + + eapply termSigCongAlg_prem0 in Hconcl as [Hpre0 []]%dup. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros Hpost0%implem_conv_graph%algo_conv_sound ; eauto. + eapply termSigCongAlg_prem1 in Hpost0 ; eauto. + + - intros * ?? ?? ?? * wu' [Hconcl []]%dup. apply compute_domain. - simp conv conv_tm_red build_nf_view3 build_nf_ty_view2. - econstructor. - 1: apply (ihFst (tFst u')); now econstructor. - intros [T|]; cbn; [|easy]. - intros ?%implem_conv_sound%algo_conv_sound. - 2,3: now econstructor. - split; [|intros x; destruct x; now cbn]. - apply (ihSnd (tSnd u')). - eapply wfTermConv; refold; [now econstructor|]. - symmetry. eapply typing_subst1; tea. - apply boundary in Hty as []%sig_ty_inv. - now apply TypeRefl. - - intros * ? [ihA] ? [ihx] ? [ihy] ? [? [[->]]]%termGen' [? [[->]]]%termGen' ? wu' Hu'. + simp _conv conv_tm_red build_nf_view3. + + eapply termPairConvAlg_prem2 in Hconcl as [Hpre2 []]%dup ; tea. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [Hpost2]%implem_conv_graph%algo_conv_sound%dup ; eauto. + eapply termPairConvAlg_prem3 in Hpost2 ; eauto. + + - intros * ?? ?? ?? ? wu' [Hconcl []]%dup. apply compute_domain. - simp conv conv_tm_red build_nf_view3 build_nf_ty_view2 . + simp _conv conv_tm_red build_nf_view3 build_nf_ty_view2. eapply Uterm_isType in wu' ; tea. - destruct wu' as [ | | | | | A'' x'' y'' | ? wu'] ; cycle -1. - 1: rewrite (whne_ty_view1 wu'). - all: cbn ; try easy. - pose proof Hu' as [? [[->]]]%termGen'. - split. - 1: apply (ihA A''); tea. - intros [|]; cbn; [|easy]. - intros HconvA%implem_conv_sound%algo_conv_sound; tea. - assert [Γ |- A'' ≅ A] by (symmetry; now econstructor). - split. - 1: apply (ihx x''); now econstructor. - intros [|]; cbn; [|easy]. - intros Hconvx%implem_conv_sound%algo_conv_sound; tea. - 2: now econstructor. - split; [|easy]. - apply (ihy y''); now econstructor. - - intros * ? [ihA] ? [ihx] ? [? [[->]]]%termGen' [? [[->]]]%termGen' ? wu' Hu'. + destruct wu' ; cbn ; try exact I. + 2: now unshelve erewrite (whne_ty_view1 _) ; cbn. + + eapply termIdCongAlg_prem0 in Hconcl as [Hpre0 []]%dup. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [Hpost0]%implem_conv_graph%algo_conv_sound%dup ; eauto. + eapply termIdCongAlg_prem1 in Hpost0 as [[]]%dup ; eauto. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros Hpost1%implem_conv_graph%algo_conv_sound ; eauto. + eapply termIdCongAlg_prem2 in Hpost1 ; eauto. + + - intros * _ * _ * wu' [Hconcl []]%dup. apply compute_domain. - simp conv conv_tm_red build_nf_view3 build_nf_ty_view2. - eapply id_isId in wu' as [wu' | [A0 [x0 ->]] ]; tea. - 1: rewrite (whne_nf_view1 wu'); now cbn. - pose proof Hu' as [? [[->]]]%termGen'. - cbn; split. - 1: eapply (ihA tt A0); tea. - intros [|]; cbn; [|easy]. - intros HconvA%implem_conv_sound%algo_conv_sound; tea. - split; [| easy]. - eapply ihx; econstructor; tea; now symmetry. - - intros * Hm [IHm []] Hpos ??? u' wu' Hu'. + simp _conv conv_tm_red build_nf_view3 build_nf_ty_view2. + eapply id_isId in wu' ; tea. + destruct wu' ; cbn ; eauto. + now unshelve erewrite (whne_nf_view1 _) ; cbn. + + - intros * Hm IH Hpos ? wu' [Hconcl []]%dup. apply compute_domain. - simp conv conv_tm_red build_nf_view3. + simp _conv conv_tm_red build_nf_view3. eapply algo_conv_wh in Hm as []. destruct Hpos as [[]| | | |]. - + cbn. - simp build_nf_ty_view2. + + eapply Uterm_isType in wu' ; tea. + cbn ; simp build_nf_ty_view2. + unshelve erewrite whne_ty_view1 ; tea. + destruct wu' ; try solve [cbn ; easy]. unshelve erewrite whne_ty_view1 ; tea. cbn. - eapply Uterm_isType in wu' ; tea. - destruct wu' as [| | | | | | u' wu'] ; cbn ; try easy. - rewrite (whne_ty_view1 wu'). - cbn. - split. - 2: now intros [] ; cbn. - eapply (IHm tt u') ; tea. - now eexists. - + cbn. + split ; [..|now intros [] ; cbn]. + eapply IH ; tea. + split ; now eexists. + + eapply nat_isNat in wu' ; tea. + cbn ; simp build_nf_view3. unshelve erewrite whne_nf_view1 ; tea. - cbn. - eapply nat_isNat in wu' ; tea. - inversion wu' as [| | u'' wu'' ] ; subst ; clear wu'. - all: cbn ; try easy. - rewrite (whne_nf_view1 wu''). - cbn. - split. - 2: now intros [] ; cbn. - eapply (IHm tt u') ; tea. - now eexists. - + cbn. + destruct wu' ; try solve [cbn ; easy]. unshelve erewrite whne_nf_view1 ; tea. cbn. - eapply empty_isEmpty in wu' ; tea. - rewrite (whne_nf_view1 wu'). - cbn. - split. - 2: now intros [] ; cbn. - apply (IHm tt u') ; tea. - now eexists. - + cbn. + split ; [..|now intros [] ; cbn]. + eapply IH ; tea. + split ; now eexists. + + eapply empty_isEmpty in wu' ; tea. + cbn ; simp build_nf_view3. + unshelve erewrite whne_nf_view1 ; tea. unshelve erewrite whne_nf_view1 ; tea. cbn. - eapply id_isId in wu' as [wu'| [? [? ->]]] ; cbn; try easy. - rewrite (whne_nf_view1 wu'). - cbn. - split. - 2: now intros [] ; cbn. - apply (IHm tt u') ; tea. - now eexists. - + unshelve erewrite whne_ty_view1 ; tea. + split ; [..|now intros [] ; cbn]. + eapply IH ; tea. + split ; now eexists. + + eapply id_isId in wu' ; tea. + cbn ; simp build_nf_view3. + unshelve erewrite whne_nf_view1 ; tea. + destruct wu' ; try solve [cbn ; easy]. + unshelve erewrite whne_nf_view1 ; tea. cbn. - eapply neutral_isNeutral in wu' ; tea. - split. - 2: now intros [] ; cbn. - apply (IHm tt u') ; tea. - now eexists. + split ; [..|now intros [] ; cbn]. + eapply IH ; tea. + split ; now eexists. + + eapply neutral_isNeutral in wu' ; tea. + unshelve erewrite whne_ty_view1 ; tea. + cbn ; simp build_nf_view3. + do 2 (unshelve erewrite whne_nf_view1 ; tea) ; cbn. + split ; [..|now intros [] ; cbn]. + eapply IH ; tea. + split ; now eexists. Qed. - Corollary conv_terminates Γ A A' : + Corollary tconv_terminates Γ A A' : [Γ |-[de] A] -> [Γ |-[de] A'] -> - forall v, - domain conv (ty_state;Γ;v;A;A'). + domain tconv (Γ,A,A'). Proof. intros. - eapply _conv_terminates ; tea. - split. - 4: eapply algo_conv_complete. - 4: econstructor. - all: boundary. + assert (domain _conv (ty_state; Γ; tt; A; A')) as []. + { + eapply _conv_terminates ; eauto. + eapply ty_conv_compl. + econstructor. + boundary. + } + eexists. + unfold graph. + simp tconv. + econstructor ; cbn in * ; tea. + now constructor. Qed. End ConversionTerminates. Section TypingTerminates. + Context `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} + `{!Normalisation (ta := de)}. + + Import AlgorithmicTypingData. + + Variable conv : (context × term × term) ⇀ exn errors unit. + + Hypothesis conv_sound : forall Γ T V, + graph conv (Γ,T,V) ok -> + [Γ |-[al] T ≅ V]. + + Hypothesis conv_terminates : forall Γ A A', + [Γ |-[de] A] -> + [Γ |-[de] A'] -> + domain conv (Γ,A,A'). + Definition lt_state (s s' : typing_state) := match s, s' with | inf_state, inf_state => False @@ -551,7 +497,7 @@ Section TypingTerminates. Lemma well_founded_lt_state : well_founded lt_state. Proof. intros []. - all: repeat (constructor ; intros [] ; cbn ; try easy). + all: do 3 (constructor ; intros [] ; cbn ; try easy). Qed. #[local]Definition R_aux := lexprod term typing_state term_subterm lt_state. @@ -587,7 +533,7 @@ Definition wf_input (s : typing_state) Γ : tstate_input s -> Type := Theorem typing_terminates (s : typing_state) (Γ : context) (v : tstate_input s) (t : term) : [|-[de] Γ] -> wf_input s Γ v -> - domain typing (s;Γ;v;t). + domain (typing conv) (s;Γ;v;t). Proof. intros HΓ Hv. set (x := (s;Γ;v;t)). @@ -738,7 +684,7 @@ Proof. 1: assert [Γ0 |-[ de ] P[tRefl A x .: x..]]. 1:{ eapply typing_subst2; tea; cbn. - rewrite 2!Weakening.wk1_ren_on, 2!shift_subst_eq. + rewrite 2!Weakening.wk1_ren_on, 2!shift_one_eq. now econstructor. } 1: split; cycle -1. @@ -767,8 +713,9 @@ Proof. split. 2: easy. eapply wh_red_complete. - exists istype. - now boundary. + 1: exists istype. + 2: eapply ty_norm. + all: now boundary. - split. 1:{ apply IH ; cbn ; try easy. diff --git a/theories/Decidability/UntypedCompleteness.v b/theories/Decidability/UntypedCompleteness.v new file mode 100644 index 00000000..55b40019 --- /dev/null +++ b/theories/Decidability/UntypedCompleteness.v @@ -0,0 +1,378 @@ +(** * LogRel.Decidability.UntypedCompleteness: the inductive predicates imply the implementation answer positively. *) +From Coq Require Import Nat Lia Arith. +From Equations Require Import Equations. +From LogRel Require Import Utils Syntax.All DeclarativeTyping GenericTyping AlgorithmicTyping. +From LogRel.TypingProperties Require Import DeclarativeProperties PropertiesDefinition SubstConsequences TypeConstructorsInj NeutralConvProperties. +From LogRel.Algorithmic Require Import BundledAlgorithmicTyping AlgorithmicConvProperties AlgorithmicTypingProperties UntypedAlgorithmicConversion. +From LogRel.Decidability Require Import Functions UntypedFunctions Soundness UntypedSoundness Completeness. +From PartialFun Require Import Monad PartialFun MonadExn. + +Set Universe Polymorphism. + +Import DeclarativeTypingProperties AlgorithmicTypingData. + +Section ConversionComplete. + Context + `{!TypingSubst (ta := de)} + `{!TypeConstructorsInj (ta := de)} + `{!TypeReductionComplete (ta := de)} + `{!ConvComplete (ta := de) (ta' := al)} + `{!Normalisation (ta := de)}. + (* We are using normalisation, because we need soundness of untyped conversion, + which is currently obtained by going through typed algo conversion, but the + implication untyped algo -> typed algo relies on normalisation. + If we proved soundness of untyped algorithmic conversion directly, we would + only need completeness. *) + +Let PEq (t u : term) := + (forall Γ, [Γ |-[de] t] × [Γ |-[de] u] -> graph _uconv (tm_state,t,u) ok) × + (forall Γ A, [Γ |-[de] t : A] × [Γ |-[de] u : A] -> graph _uconv (tm_state,t,u) ok). + +Let PRedEq (t u : term) := + (forall Γ, [Γ |-[de] t] × [Γ |-[de] u] -> graph _uconv (tm_red_state,t,u) ok) × + (forall Γ A, + [Γ |-[de] t : A] × [Γ |-[de] u : A] -> graph _uconv (tm_red_state,t,u) ok). + +Let PNeEq (t u : term) := + forall Γ, well_typed Γ t × well_typed Γ u -> + graph _uconv (ne_state,t,u) ok. + +Ltac split_tm := + split ; + [ intros * [Hz%type_isType Hz'%type_isType] ; + [solve [inversion Hz ; inv_whne | inversion Hz' ; inv_whne] | ..] ; now constructor + |..]. + +Lemma uconv_complete : + UAlgoConvInductionConcl PEq PRedEq PNeEq. +Proof. + subst PEq PRedEq PNeEq. + unfold UAlgoConvInductionConcl. + apply UAlgoConvInduction. + + - intros * Ht Hu []%algo_uconv_wh [Hty Htm]. + split. + all: intros * [Hconcl []]%dup. + all: unfold graph. + all: simp _uconv uconv_tm ; cbn. + all: repeat (match goal with |- orec_graph _ _ _ => patch_rec_ret ; econstructor end) ; cbn. + 1-2: now eapply wh_red_complete_whnf_ty ; eauto. + 2-3: now eapply wh_red_complete_whnf_tm ; eauto. + * eapply typeConvRed_prem2 in Hconcl ; eauto. + now eapply Hty. + * eapply termConvRed_prem3 in Hconcl ; eauto. + 2: reflexivity. + now eapply Htm. + + - split. + all: intros. + all: unfold graph. + all: simp _uconv uconv_tm_red ; cbn. + all: econstructor. + + - intros * ? [IHA_ty IHA_tm] ? [IHB_ty IHB_tm]. + split. + + + intros ? [Hconcl]%dup. + unfold graph. + simp _uconv uconv_tm_red ; cbn. + + eapply typePiCongAlg_prem0 in Hconcl as [Hpre0 []]%dup. + econstructor ; [now eapply IHA_ty|..] ; cbn. + eapply implem_uconv_graph, uconv_sound in IHA_ty as [Hpost0%algo_conv_sound _]; tea. + eapply typePiCongAlg_prem1 in Hpost0 ; eauto. + patch_rec_ret ; econstructor ; [now eapply IHB_ty|..]. + now constructor. + + + intros * [(?&[->]& _)%termGen' (?&[->]& _)%termGen']. + unfold graph. + simp _uconv uconv_tm_red ; cbn. + + assert ([Γ |-[ de ] tProd A B : U] × [Γ |-[ de ] tProd A' B' : U]) as + [[Hpre0 []]%termPiCongAlg_prem0%dup]%dup. + { + split ; now econstructor. + } + + econstructor ; [now eapply IHA_tm|..] ; cbn. + eapply implem_uconv_graph, uconv_sound in IHA_tm as [_ Hpost0%algo_conv_sound]; tea. + eapply termPiCongAlg_prem1 in Hpost0 ; eauto. + patch_rec_ret ; econstructor ; [now eapply IHB_tm|..]. + now constructor. + + - split. + all: intros. + all: unfold graph. + all: simp _uconv uconv_tm_red build_nf_view2 ; cbn. + all: now constructor. + + - split. + all: intros. + all: unfold graph. + all: simp _uconv uconv_tm_red build_nf_view2 ; cbn. + all: now constructor. + + - intros * ? [_ IH_tm]. + split_tm. + + intros * [(?&[->]&?)%termGen' (?&[->]&?)%termGen']. + unfold graph. + simp _uconv uconv_tm_red build_nf_view2 ; cbn. + + assert ([Γ |-[ de ] tSucc t : tNat] × [Γ |-[ de ] tSucc t' : tNat]) as ?%termSuccCongAlg_prem0. + { + split ; now econstructor. + } + + patch_rec_ret ; econstructor ; [now eapply IH_tm|..]. + now constructor. + + - split. + all: intros. + all: unfold graph. + all: simp _uconv uconv_tm_red build_nf_view2 ; cbn. + all: now constructor. + + - intros * ? [_ IH_tm]. + split_tm. + + intros * Hconcl. + unfold graph. + simp _uconv uconv_tm_red build_nf_view2 ; cbn. + + eapply LamCongUAlg_prem0 in Hconcl as (?&?&[]); tea. + patch_rec_ret ; econstructor ; [now eapply IH_tm|..]. + now constructor. + + - intros * ? ? [_ IH_tm]. + split_tm. + + intros * [Hconcl]%dup. + unfold graph. + simp _uconv uconv_tm_red build_nf_view2. + unshelve erewrite whne_nf_view1 ; tea ; cbn. + eapply LamNeUAlg_prem0 in Hconcl as (?&?&[]); tea. + patch_rec_ret ; econstructor ; [now eapply IH_tm|..]. + now constructor. + + - intros * ? ? [_ IH_tm]. + split_tm. + + intros * [Hconcl]%dup. + unfold graph. + simp _uconv uconv_tm_red build_nf_view2. + unshelve erewrite whne_nf_view1 ; tea ; cbn. + eapply NeLamUAlg_prem0 in Hconcl as (?&?&[]); tea. + patch_rec_ret ; econstructor ; [now eapply IH_tm|..]. + now constructor. + + - intros * ? [IHA_ty IHA_tm] ? [IHB_ty IHB_tm]. + split. + + + intros ? [Hconcl]%dup. + unfold graph. + simp _uconv uconv_tm_red ; cbn. + + eapply typeSigCongAlg_prem0 in Hconcl as [Hpre0 []]%dup. + econstructor ; [now eapply IHA_ty|..] ; cbn. + eapply implem_uconv_graph, uconv_sound in IHA_ty as [Hpost0%algo_conv_sound _]; tea. + eapply typeSigCongAlg_prem1 in Hpost0 ; eauto. + patch_rec_ret ; econstructor ; [now eapply IHB_ty|..]. + now constructor. + + + + intros * [(?&[->]& _)%termGen' (?&[->]& _)%termGen']. + unfold graph. + simp _uconv uconv_tm_red ; cbn. + + assert ([Γ |-[ de ] tSig A B : U] × [Γ |-[ de ] tSig A' B' : U]) as + [[Hpre0 []]%termSigCongAlg_prem0%dup]%dup. + { + split ; now econstructor. + } + + econstructor ; [now eapply IHA_tm|..] ; cbn. + eapply implem_uconv_graph, uconv_sound in IHA_tm as [_ Hpost0%algo_conv_sound]; tea. + eapply termSigCongAlg_prem1 in Hpost0 ; eauto. + patch_rec_ret ; econstructor ; [now eapply IHB_tm|..]. + now constructor. + + - intros * ? [_ IHp] ? [_ IHq]. + split_tm. + intros * [Hconcl [[Hty]%dup]]%dup. + unfold graph. + simp _uconv uconv_tm_red build_nf_view2 ; cbn. + + eapply PairCongUAlg_prem0 in Hconcl as (?&?&[? [Hpre0 []]%dup]) ; tea. + econstructor ; [now eapply IHp|..] ; cbn. + eapply implem_uconv_graph, uconv_sound in IHp as [_ Hpost0%algo_conv_sound]; tea. + eapply PairCongUAlg_prem1 in Hpost0 ; eauto. + patch_rec_ret ; econstructor ; [now eapply IHq|..]. + now constructor. + + - intros * ? ? [_ IHp] ? [_ IHq]. + split_tm. + intros * [Hconcl [[Hty]%dup]]%dup. + unfold graph. + simp _uconv uconv_tm_red build_nf_view2 ; cbn. + unshelve erewrite whne_nf_view1 ; tea ; cbn. + eapply PairNeUAlg_prem0 in Hconcl as (?&?&[? [Hpre0 []]%dup]) ; tea. + econstructor ; [now eapply IHp|..] ; cbn. + eapply implem_uconv_graph, uconv_sound in IHp as [_ Hpost0%algo_conv_sound]; tea. + eapply PairNeUAlg_prem1 in Hpost0 ; eauto. + patch_rec_ret ; econstructor ; [now eapply IHq|..]. + now constructor. + + - intros * ? ? [_ IHp] ? [_ IHq]. + split_tm. + intros * [Hconcl [[Hty]%dup]]%dup. + unfold graph. + simp _uconv uconv_tm_red build_nf_view2 ; cbn. + unshelve erewrite whne_nf_view1 ; tea ; cbn. + eapply NePairUAlg_prem0 in Hconcl as (?&?&[? [Hpre0 []]%dup]) ; tea. + econstructor ; [now eapply IHp|..] ; cbn. + eapply implem_uconv_graph, uconv_sound in IHp as [_ Hpost0%algo_conv_sound]; tea. + eapply NePairUAlg_prem1 in Hpost0 ; eauto. + patch_rec_ret ; econstructor ; [now eapply IHq|..]. + now constructor. + + - intros * ? [IHA_ty IHA_tm] ? [_ IHx] ? [_ IHy]. + split. + + + intros ? [Hconcl]%dup. + unfold graph. + simp _uconv uconv_tm_red build_nf_view2 ; cbn. + eapply typeIdCongAlg_prem0 in Hconcl as [Hpre0 []]%dup. + econstructor ; [now eapply IHA_ty|..] ; cbn. + eapply implem_uconv_graph, uconv_sound in IHA_ty as [[Hpost0]%algo_conv_sound%dup _]; tea. + eapply typeIdCongAlg_prem1 in Hpost0 as [Hpre1 []]%dup ; eauto. + econstructor ; [now eapply IHx|..] ; cbn. + eapply implem_uconv_graph, uconv_sound in IHx as [_ Hpost1%algo_conv_sound]; tea. + eapply typeIdCongAlg_prem2 in Hpost1 as [Hpre2 []]%dup ; eauto. + patch_rec_ret ; econstructor ; [now eapply IHy|..] ; cbn. + now econstructor. + + + intros * [(?&[->]& _)%termGen' (?&[->]& _)%termGen']. + unfold graph. + simp _uconv uconv_tm_red ; cbn. + + assert ([Γ |-[ de ] tId A x y : U] × [Γ |-[ de ] tId A' x' y' : U]) as + [[Hpre0 []]%termIdCongAlg_prem0%dup]%dup. + { + split ; now econstructor. + } + + econstructor ; [now eapply IHA_tm|..] ; cbn. + eapply implem_uconv_graph, uconv_sound in IHA_tm as [_ [Hpost0]%algo_conv_sound%dup]; tea. + eapply termIdCongAlg_prem1 in Hpost0 as [Hpre1 []]%dup ; eauto. + econstructor ; [now eapply IHx|..] ; cbn. + eapply implem_uconv_graph, uconv_sound in IHx as [_ Hpost1%algo_conv_sound]; tea. + eapply termIdCongAlg_prem2 in Hpost1 as [Hpre2 []]%dup ; eauto. + patch_rec_ret ; econstructor ; [now eapply IHy|..] ; cbn. + now econstructor. + + - intros *. + split_tm. + intros. + unfold graph. + simp _uconv uconv_tm_red build_nf_view2 ; cbn. + econstructor. + + - intros * []%algo_uconv_wh IH. + split. + + + intros ? Hconcl. + unfold graph. + simp _uconv uconv_tm_red build_nf_view2. + repeat (unshelve erewrite ! whne_nf_view1 ; tea ; cbn). + eapply typeNeuConvAlg_prem2 in Hconcl ; tea. + patch_rec_ret ; econstructor ; [now eapply IH|..] ; cbn. + now econstructor. + + + intros ? ? Hconcl. + unfold graph. + simp _uconv uconv_tm_red build_nf_view2. + repeat (unshelve erewrite ! whne_nf_view1 ; tea ; cbn). + eapply termNeuConvAlg_prem0 in Hconcl ; tea. + patch_rec_ret ; econstructor ; [now eapply IH|..] ; cbn. + now econstructor. + + - intros. + unfold graph. + simp _uconv uconv_ne ; cbn. + rewrite Nat.eqb_refl ; cbn. + now econstructor. + + - intros * ? IHm ? [_ IHt] ? [Hconcl]%dup. + unfold graph. + simp _uconv uconv_ne ; cbn. + eapply neuAppCongAlg_prem0 in Hconcl as [Hpre0 []]%dup ; eauto. + econstructor ; [now eapply IHm|..] ; cbn. + eapply implem_uconv_graph, uconv_sound in IHm as [? Hpost0] ; tea. + eapply AppCongUAlg_bridge in Hpost0 as (?&?&[? [Hpre1 []]%dup]); eauto. + eapply neuAppCongAlg_prem1 in Hpre1 as [Hpre1 []]%dup ; eauto. + patch_rec_ret ; econstructor ; [now eapply IHt|..] ; cbn. + now constructor. + + - intros * ? IH ? [IHP] ? [_ IHz] ? [_ IHs] ? [Hconcl]%dup. + unfold graph. + simp _uconv uconv_ne ; cbn. + eapply neuNatElimCong_prem0 in Hconcl as [Hpre0 []]%dup ; eauto. + econstructor ; [now eapply IH|..] ; cbn. + eapply implem_uconv_graph, uconv_sound in IH as [? Hpost0] ; tea. + eapply NatElimCongUAlg_bridge in Hpost0 as [? [Hpost0]%dup]; eauto. + eapply neuNatElimCong_prem1 in Hpost0 as [Hpre1 []]%dup ; eauto. + econstructor ; [now eapply IHP|..] ; cbn. + eapply implem_uconv_graph, uconv_sound in IHP as [Hpos1 _] ; tea. + eapply algo_conv_sound in Hpos1 as [Hpos1]%dup ; eauto. + eapply neuNatElimCong_prem2 in Hpos1 as [Hpre2 []]%dup ; eauto. + econstructor ; [now eapply IHz|..] ; cbn. + eapply implem_uconv_graph, uconv_sound in IHz as [_ Hpos2] ; tea. + eapply algo_conv_sound in Hpos2 as [Hpos2]%dup ; eauto. + eapply neuNatElimCong_prem3 in Hpos2 as [Hpre3 []]%dup ; eauto. + patch_rec_ret ; econstructor ; [now eapply IHs|..] ; cbn. + now constructor. + + - intros * ? IH ? [IHP] ? [Hconcl]%dup. + unfold graph. + simp _uconv uconv_ne ; cbn. + eapply neuEmptyElimCong_prem0 in Hconcl as [Hpre0 []]%dup ; eauto. + econstructor ; [now eapply IH|..] ; cbn. + eapply implem_uconv_graph, uconv_sound in IH as [? Hpost0] ; tea. + eapply EmptyElimCongUAlg_bridge in Hpost0 as [? [Hpost0]%dup]; eauto. + eapply neuEmptyElimCong_prem1 in Hpost0 as [Hpre1 []]%dup ; eauto. + patch_rec_ret ; econstructor ; [now eapply IHP|..] ; cbn. + now constructor. + + - intros * ? IH ? [Hconcl]%dup. + unfold graph. + simp _uconv uconv_ne ; cbn. + eapply neuFstCongAlg_prem0 in Hconcl as [Hpre0 []]%dup ; eauto. + patch_rec_ret ; econstructor ; [now eapply IH|..] ; cbn. + now constructor. + + - intros * ? IH ? [Hconcl]%dup. + unfold graph. + simp _uconv uconv_ne ; cbn. + eapply neuSndCongAlg_prem0 in Hconcl as [Hpre0 []]%dup ; eauto. + patch_rec_ret ; econstructor ; [now eapply IH|..] ; cbn. + now constructor. + + - intros * ? IH ? [IHP] ? [_ IHe] ? [Hconcl]%dup. + unfold graph. + simp _uconv uconv_ne ; cbn. + eapply neuIdElimCong_prem0 in Hconcl as [Hpre0 []]%dup ; eauto. + econstructor ; [now eapply IH|..] ; cbn. + eapply implem_uconv_graph, uconv_sound in IH as [? Hpost0] ; tea. + eapply IdElimCongUAlg_bridge in Hpost0 as (?&?&?&[? [Hpost0]%dup]); eauto. + eapply neuIdElimCong_prem1 in Hpost0 as [Hpre1 []]%dup ; eauto. + econstructor ; [now eapply IHP|..] ; cbn. + eapply implem_uconv_graph, uconv_sound in IHP as [Hpos1 _] ; tea. + eapply algo_conv_sound in Hpos1 as [Hpos1]%dup ; eauto. + eapply neuIdElimCong_prem2 in Hpos1 as [Hpre2 []]%dup ; eauto. + patch_rec_ret ; econstructor ; [now eapply IHe|..] ; cbn. + now constructor. + +Qed. + +End ConversionComplete. \ No newline at end of file diff --git a/theories/Decidability/UntypedFunctions.v b/theories/Decidability/UntypedFunctions.v new file mode 100644 index 00000000..37bb37b5 --- /dev/null +++ b/theories/Decidability/UntypedFunctions.v @@ -0,0 +1,244 @@ +(** * LogRel.Decidability.UnytpedFunctions: implementation of untyped conversion. *) +From Coq Require Import Nat Lia. +From Equations Require Import Equations. +From PartialFun Require Import Monad PartialFun MonadExn. +From LogRel Require Import Utils BasicAst AutoSubst.Extra Context. +From LogRel.Decidability Require Import Functions. + +Import MonadNotations. +Set Universe Polymorphism. + +Inductive nf_view2 : term -> term -> Type := +| sorts (s1 s2 : sort) : nf_view2 (tSort s1) (tSort s2) +| prods (A A' B B' : term) : + nf_view2 (tProd A B) (tProd A' B') +| nats : nf_view2 tNat tNat +| emptys : nf_view2 tEmpty tEmpty +| sigs (A A' B B' : term) : nf_view2 (tSig A B) (tSig A' B') +| ids A A' x x' y y' : nf_view2 (tId A x y) (tId A' x' y') +| lams A A' t t' : nf_view2 (tLambda A t) (tLambda A' t') +| lam_ne A t n' : nf_view2 (tLambda A t) n' +| ne_lam n A' t' : nf_view2 n (tLambda A' t') +| zeros : nf_view2 tZero tZero +| succs t t' : nf_view2 (tSucc t) (tSucc t') +| pairs A A' B B' t t' u u' : + nf_view2 (tPair A B t u) (tPair A' B' t' u') +| pair_ne A B t u n' : + nf_view2 (tPair A B t u) n' +| ne_pair n A' B' t' u' : + nf_view2 n (tPair A' B' t' u') +| refls A A' x x' : nf_view2 (tRefl A x) (tRefl A' x') +| neutrals (n n' : term) : nf_view2 n n' +| mismatch (t u : term) : nf_view2 t u +| anomaly (t u : term) : nf_view2 t u. + +Equations build_nf_view2 (t t' : term) : nf_view2 t t' := + build_nf_view2 t t' with (build_nf_view1 t) := { + | nf_view1_type (eSort s) with (build_nf_view1 t') := { + | nf_view1_type (eSort s') := sorts s s' ; + | nf_view1_type _ := mismatch _ _ ; + | nf_view1_ne _ := mismatch _ _ ; + | _ := anomaly _ _ } ; + | nf_view1_type (eProd A B) with (build_nf_view1 t') := { + | nf_view1_type (eProd A' B') := prods A A' B B' ; + | nf_view1_type _ := mismatch _ _ ; + | nf_view1_ne _ := mismatch _ _ ; + | _ := anomaly _ _ } ; + | nf_view1_type eNat with (build_nf_view1 t') := { + | nf_view1_type eNat := nats ; + | nf_view1_type _ := mismatch _ _ ; + | nf_view1_ne _ := mismatch _ _ ; + | _ := anomaly _ _ } ; + | nf_view1_type eEmpty with (build_nf_view1 t') := { + | nf_view1_type eEmpty := emptys ; + | nf_view1_type _ := mismatch _ _ ; + | nf_view1_ne _ := mismatch _ _ ; + | _ := anomaly _ _ } ; + | nf_view1_type (eSig A B) with (build_nf_view1 t') := { + | nf_view1_type (eSig A' B') := sigs A A' B B' ; + | nf_view1_type _ := mismatch _ _ ; + | nf_view1_ne _ := mismatch _ _ ; + | _ := anomaly _ _ } ; + | nf_view1_type (eId A x y) with (build_nf_view1 t') := { + | nf_view1_type (eId A' x' y') := ids A A' x x' y y' ; + | nf_view1_type _ := mismatch _ _ ; + | nf_view1_ne _ := mismatch _ _ ; + | _ := anomaly _ _ } ; + | nf_view1_fun A t with (build_nf_view1 t') := { + | nf_view1_fun A' t' := lams A A' t t' ; + | nf_view1_ne _ := lam_ne A t _ ; + | _ := anomaly _ _ } ; + | nf_view1_nat eZero with (build_nf_view1 t') := { + | nf_view1_nat eZero := zeros ; + | nf_view1_nat (eSucc _) := mismatch _ _ ; + | nf_view1_ne _ := mismatch _ _ ; + | _ := anomaly _ _ } ; + | nf_view1_nat (eSucc u) with (build_nf_view1 t') := { + | nf_view1_nat (eSucc u') := succs u u' ; + | nf_view1_nat eZero := mismatch _ _ ; + | nf_view1_ne _ := mismatch _ _ ; + | _ := anomaly _ _ } ; + | nf_view1_sig A B t u with (build_nf_view1 t') := { + | nf_view1_sig A' B' t' u' := pairs A A' B B' t t' u u' ; + | nf_view1_ne _ := pair_ne A B t u _ ; + | _ := anomaly _ _ } ; + | nf_view1_id A x with (build_nf_view1 t') := { + | nf_view1_id A' x' := refls A A' x x' ; + | nf_view1_ne _ := mismatch _ _ ; + | _ := anomaly _ _ } ; + | nf_view1_ne _ with (build_nf_view1 t') := { + | nf_view1_type _ := mismatch _ _ ; + | nf_view1_fun A' t' := ne_lam _ A' t' ; + | nf_view1_nat _ := mismatch _ _ ; + | nf_view1_sig A' B' t' u' := ne_pair _ A' B' t' u' ; + | nf_view1_id _ _ := mismatch _ _ ; + | nf_view1_ne _ := neutrals _ _ ; + } + }. + + Variant uconv_state : Type := + | tm_state (** Conversion of arbitrary terms *) + | tm_red_state (** Comparison of terms if weak-head normal forms *) + | ne_state. (** Comparison of neutrals *) + +Section Conversion. + +Definition uconv_dom := uconv_state × term × term. +Definition uconv_cod (_ : uconv_dom) := exn errors unit. + +#[local] +Notation M0 := (orec (Sing wh_red) (uconv_dom) (uconv_cod)). +#[local] +Notation M := (combined_orec (exn errors) (Sing wh_red) uconv_dom uconv_cod). + +(* Equations uconv_ty : + (term × term) -> M unit := + | (T,V) := + T' ← call_single wh_red T ;;[M0] + V' ← call_single wh_red V ;;[M0] + id <*> rec (ty_red_state,T',V'). + +Equations uconv_ty_red : + (term × term) -> M unit := + | (T,T') with (build_nf_ty_view2 T T') := + { + | ty_sorts s s' := ret (eq_sort s s') ; + | ty_prods A A' B B' := + rec (ty_state,A,A') ;; + rec (ty_state,B,B') ; + | ty_nats := ok ; + | ty_emptys := ok ; + | ty_sigs A A' B B' := + rec (ty_state,A,A') ;; + rec (ty_state,B,B') ; + | ty_neutrals _ _ := + rec (ne_state,T,T') ; + | ty_ids A A' x x' y y' := + rec (ty_state,A,A') ;; + rec (tm_state,x,x') ;; + rec (tm_state,y,y') ; + | ty_mismatch _ _ := raise (head_mismatch None T T') ; + | ty_anomaly _ _ := undefined ; + }. *) + +Equations uconv_tm : (term × term) -> M unit := + | (t,u) := + t' ← call_single wh_red t ;;[M0] + u' ← call_single wh_red u ;;[M0] + rec (tm_red_state,t',u'). + +Equations uconv_tm_red : (term × term) -> M unit := + | (t,t') with (build_nf_view2 t t') := + { + | sorts s s' := + ret (eq_sort s s') ; + | prods A A' B B' := + rec (tm_state,A,A') ;; + rec (tm_state,B,B') ; + | nats := ok ; + | emptys := ok ; + | sigs A A' B B' := + rec (tm_state,A,A') ;; + rec (tm_state,B,B') ; + | ids A A' x x' y y' := + rec (tm_state,A,A') ;; + rec (tm_state,x,x') ;; + rec (tm_state,y,y') ; + | lams _ _ t t' := + rec (tm_state,t,t') ; + | lam_ne _ t t' := + rec (tm_state,t,eta_expand t') ; + | ne_lam t _ t' := + rec (tm_state,eta_expand t,t') ; + | zeros := ok ; + | succs t t' := + rec (tm_state,t,t') ; + | pairs _ _ _ _ t t' u u' := + rec (tm_state,t,t') ;; + rec (tm_state,u,u') ; + | pair_ne _ _ t u t' := + rec (tm_state,t,tFst t') ;; + rec (tm_state,u,tSnd t') ; + | ne_pair t _ _ t' u' := + rec (tm_state,tFst t, t') ;; + rec (tm_state,tSnd t,u') ; + | refls A A' x x' := + ok ; + | neutrals _ _ := + rec (ne_state,t,t') ; + | mismatch _ _ := raise head_mismatch ; + | anomaly _ _ := undefined ; + }. + +Equations uconv_ne : (term × term) -> M unit := + uconv_ne (t,t') with build_ne_view2 t t' := + { + | ne_rels n n' with n =? n' := + { | false := raise variable_mismatch ; + | true := ok ; + } ; + + | ne_apps n t n' t' := + rec (ne_state,n,n') ;; + rec (tm_state,t,t') ; + + | ne_nats n P hz hs n' P' hz' hs' := + rec (ne_state,n,n') ;; + rec (tm_state,P,P') ;; + rec (tm_state,hz,hz') ;; + rec (tm_state,hs,hs') + + | ne_emptys n P n' P' := + rec (ne_state,n,n') ;; + rec (tm_state,P,P') + + | ne_fsts n n' := + rec (ne_state,n,n') + + | ne_snds n n' := + rec (ne_state,n,n') + + | ne_ids A x P hr y n A' x' P' hr' y' n' := + rec (ne_state,n,n') ;; + rec (tm_state,P,P') ;; + rec (tm_state,hr,hr') ; + + | ne_mismatch _ _ => raise destructor_mismatch ; + | ne_anomaly _ _ => undefined +}. + +Equations _uconv : ∇ _ : uconv_state × term × term, [Sing wh_red]⇒[exn errors] unit := + (* | (ty_state,ts) := uconv_ty ts; + | (ty_red_state,ts) := uconv_ty_red ts ; *) + | (tm_state,ts) := uconv_tm ts ; + | (tm_red_state,ts) := uconv_tm_red ts; + | (ne_state,ts) := uconv_ne ts. + + #[local] Instance: PFun _uconv := pfun_gen _ _ _uconv. + + Equations uconv : (context × term × term) ⇀ exn errors unit := + uconv (Γ,T,V) := call _uconv (tm_state,T,V). + +End Conversion. + +#[export] Instance: PFun uconv := pfun_gen _ _ uconv. \ No newline at end of file diff --git a/theories/Decidability/UntypedSoundness.v b/theories/Decidability/UntypedSoundness.v new file mode 100644 index 00000000..811460dd --- /dev/null +++ b/theories/Decidability/UntypedSoundness.v @@ -0,0 +1,79 @@ +(** * LogRel.Decidability.Soundness: the implementations imply the inductive predicates. *) +From Coq Require Import Nat Lia Arith. +From Equations Require Import Equations. +From LogRel Require Import Utils Syntax.All GenericTyping AlgorithmicTyping UntypedAlgorithmicConversion. +From LogRel.Decidability Require Import Functions UntypedFunctions Soundness. +From PartialFun Require Import Monad PartialFun MonadExn. + +Import AlgorithmicTypingData. + +Set Universe Polymorphism. + +Section ConversionSound. + + #[universes(polymorphic)]Definition uconv_sound_type + (x : uconv_state × term × term) + (r : exn errors unit) : Type := + match x, r with + | _, (exception _) => True + | (tm_state,t,u), (success _) => [t ≅ u] + | (tm_red_state,t,u), (success _) => + whnf t -> whnf u -> [t ≅h u] + | (ne_state,m,n), (success _) => [m ~ n] + end. + + Lemma _implem_uconv_sound : + funrect _uconv (fun _ => True) uconv_sound_type. + Proof. + intros x _. + funelim (_uconv _); + [ funelim (uconv_tm _) | funelim (uconv_tm_red _) | funelim (uconv_ne _) ]. + all: intros ; cbn ; try easy ; cbn. + all: repeat ( + match goal with + | |- True * _ => split ; [easy|..] + | |- forall x : exn _ _, _ => intros [|] ; [..|easy] ; cbn + | |- _ -> _ => cbn ; intros ? + | |- context [match ?t with | _ => _ end] => destruct t ; cbn ; try easy + | s : sort |- _ => destruct s + | H : graph wh_red _ _ |- _ => eapply red_sound in H as [] + | H : (_,_,_) = (_,_,_) |- _ => injection H; clear H; intros; subst + end). + all: try solve [now econstructor]. + 1-4: econstructor ; eauto. + 1-4: match goal with | H : whnf ?t |- whne ?t => + now destruct H ; simp build_nf_view3 build_ty_view1 in Heq ; try solve [inversion Heq] + end. + eapply Nat.eqb_eq in Heq as ->. + now constructor. + Qed. + + Corollary implem_uconv_graph x r : + graph _uconv x r -> + uconv_sound_type x r. + Proof. + eapply funrect_graph. + 1: now apply _implem_uconv_sound. + easy. + Qed. + + Corollary implem_uconv_sound Γ T V : + graph uconv (Γ,T,V) ok -> + [T ≅ V]. + Proof. + assert (funrect uconv (fun _ => True) + (fun '(Γ,T,V) r => match r with | success _ => [T ≅ V] | _ => True end)) as Hrect. + { + intros ? _. + funelim (uconv _) ; cbn. + intros [] ; cbn ; [|easy]. + eintros ?%funrect_graph. + 2: now apply _implem_uconv_sound. + all: now cbn in *. + } + eintros ?%funrect_graph. + 2: eassumption. + all: now cbn in *. + Qed. + +End ConversionSound. \ No newline at end of file diff --git a/theories/Decidability/UntypedTermination.v b/theories/Decidability/UntypedTermination.v new file mode 100644 index 00000000..e3f01263 --- /dev/null +++ b/theories/Decidability/UntypedTermination.v @@ -0,0 +1,1002 @@ +(** * LogRel.Decidability.UntypedTermination: the implementation always terminates on well-typed inputs. *) +From Coq Require Import Nat Lia Arith. +From Equations Require Import Equations. +From LogRel.AutoSubst Require Import core unscoped Ast Extra. +From LogRel Require Import BasicAst Context Notations UntypedReduction Weakening DeclarativeTyping DeclarativeInstance GenericTyping NormalForms. +From LogRel Require Import Validity LogicalRelation Fundamental DeclarativeSubst TypeConstructorsInj AlgorithmicTyping BundledAlgorithmicTyping Normalisation AlgorithmicConvProperties AlgorithmicTypingProperties. +From LogRel Require Import UntypedAlgorithmicConversion. +From LogRel Require Import Utils. (* at the end, to get the right easy tactic… *) +From LogRel.Decidability Require Import Functions UntypedFunctions Soundness UntypedSoundness Completeness UntypedCompleteness. +From PartialFun Require Import Monad PartialFun MonadExn. + +Import DeclarativeTypingProperties AlgorithmicTypingData. + +Set Universe Polymorphism. + + +Lemma uconv_sound_decl : + UAlgoConvInductionConcl + (fun t u => + (forall Γ, [Γ |-[de] t] × [Γ |-[de] u] -> [Γ |-[de] t ≅ u]) × + (forall Γ A, [Γ |-[de] t : A] × [Γ |-[de] u : A] -> [Γ |-[de] t ≅ u : A])) + + (fun t u => + (forall Γ, [Γ |-[de] t] × [Γ |-[de] u] -> [Γ |-[de] t ≅ u]) × + (forall Γ A, isType A -> [Γ |-[de] t : A] × [Γ |-[de] u : A] -> [Γ |-[de] t ≅ u : A])) + + (fun t u => + forall Γ, well_typed Γ t × well_typed Γ u -> + ∑ A'', [Γ |-[de] t ≅ u : A'']). +Proof. + split ; [..|split]. + all: intros t u Hconv. + 1-2: split. + - intros * []. + eapply uconv_sound in Hconv as [?%algo_conv_sound _]; eauto. + - intros * []. + eapply uconv_sound in Hconv as [_ ?%algo_conv_sound]; eauto. + - intros * []. + eapply uconv_sound in Hconv as [?%algo_conv_sound _]; eauto. + - intros * ? []. + eapply uconv_sound in Hconv as [_ ?%algo_conv_sound]; eauto. + - intros * []. + eapply uconv_sound in Hconv as [? []%algo_conv_sound] ; eauto. +Qed. + +Section GraphInversion. + + Context {I} `{CT : CallTypes I} `{!CallableProps CT} {A B} (f : ∇ (x : A), I ⇒ B x). + + Definition orec_graph' + {a} (o : orec I A B (B a)) (b : B a) : Prop := + match o with + | _ret x => x = b + | _rec x κ => exists v, orec_graph f (f x) v /\ orec_graph f (κ v) b + | _call i x κ => exists v, cp_graph i x v /\ orec_graph f (κ v) b + | undefined => False + end. + + Definition orec_graph_from {a} {o : orec I A B (B a)} {b} + (e : orec_graph f o b) : orec_graph' o b := + match e with + | ret_graph _ _ => eq_refl + | rec_graph _ _ _ v _ h h' => + ex_intro _ v (conj h h') + | call_graph _ _ _ _ v _ h h' => + ex_intro _ v (conj h h') + end. + + Import EqNotations. + + Definition orec_graph_to {a} {o : orec I A B (B a)} {b} : + orec_graph' o b -> orec_graph f o b := + match o with + | _ret x => fun e => rew e in ret_graph _ _ + | _rec x κ => fun '(ex_intro _ v (conj h h')) => + rec_graph _ _ _ v _ h h' + | _call i x κ => fun '(ex_intro _ v (conj h h')) => + call_graph _ _ _ _ v _ h h' + | undefined => fun f => False_rect _ f + end. + + Lemma orec_graph_equiv {a} {o : orec I A B (B a)} {b} : + orec_graph f o b <-> orec_graph' o b. + Proof. + split. + - apply orec_graph_from. + - apply orec_graph_to. + Qed. + +End GraphInversion. + +Section AlgoStr. + + Definition dest_entry_rename (ρ : nat -> nat) (d : dest_entry) : dest_entry := + match d with + | eEmptyElim P => eEmptyElim P⟨upRen_term_term ρ⟩ + | eNatElim P hs hz => eNatElim P⟨upRen_term_term ρ⟩ hs⟨ρ⟩ hz⟨ρ⟩ + | eApp u => eApp u⟨ρ⟩ + | eFst => eFst + | eSnd => eSnd + | eIdElim A x P hr y => eIdElim A⟨ρ⟩ x⟨ρ⟩ P⟨upRen_term_term (upRen_term_term ρ)⟩ hr⟨ρ⟩ y⟨ρ⟩ + end. + + Lemma map_eq_cons [A B : Type] (f : A -> B) (l : list A) [l' : list B] [b : B] : + list_map f l = (b :: l')%list -> + ∑ (a : A) (tl : list A), + [× l = (a :: tl)%list , f a = b & list_map f tl = l']. + Proof. + intros e. + destruct l ; cbn in * ; inversion e ; subst ; clear e. + do 2 eexists ; split ; reflexivity. + Qed. + + Lemma zip_rename ρ t π : (zip t π)⟨ρ⟩ = zip t⟨ρ⟩ (list_map (dest_entry_rename ρ) π). + Proof. + induction π as [|[]] in t |- * ; cbn. + 1: reflexivity. + all: now erewrite IHπ. + Qed. + + Lemma red_stack_str : + funrect wh_red_stack (fun _ => True) + (fun '(t,π) u => forall (ρ : nat -> nat) t' π', + t = t'⟨ρ⟩ -> π = List.map (dest_entry_rename ρ) π' -> ∑ u', graph wh_red_stack (t',π') u' × u = u'⟨ρ⟩). + Proof. + intros ? _ ; cbn. + funelim (wh_red_stack _) ; cbn ; try easy. + - destruct t1 ; cbn. + all: intros ? [] ? [=] ->%eq_sym%List.map_eq_nil ; subst. + all: eexists ; split ; [unfold graph ; simp wh_red_stack ; now econstructor|..]. + all: now bsimpl. + + - intros ? [] ? [=] ->%eq_sym%List.map_eq_nil ; subst. + eexists ; split. + 1: unfold graph ; simp wh_red_stack ; econstructor. + reflexivity. + + - split ; [easy|..]. + intros * IH ? [] ? [=] ([]&?&[? [=]])%eq_sym%map_eq_cons ; subst. + edestruct IH as [? []]. + 2: reflexivity. + 2:{ + subst. + eexists ; split ; [..|reflexivity]. + unfold graph ; simp wh_red_stack. + patch_rec_ret ; econstructor. + 2: now constructor. + eassumption. + } + now bsimpl. + + - intros ? [] ? [=] ? ; subst. + eexists ; split. + 1: unfold graph ; simp wh_red_stack ; econstructor. + now rewrite zip_rename. + + - destruct n0 ; cbn. + all: intros ? [] ? [=] ->%eq_sym%List.map_eq_nil ; subst. + all: eexists ; split ; [unfold graph ; simp wh_red_stack ; now econstructor|..]. + all: now bsimpl. + + - split ; [easy|..]. + intros * IH ? [] ? [=] ([]&?&[? [=]])%eq_sym%map_eq_cons ; subst. + edestruct IH as [? []]. + 2: reflexivity. + 2:{ + subst. + eexists ; split ; [..|reflexivity]. + unfold graph ; simp wh_red_stack. + patch_rec_ret ; econstructor. + 2: now constructor. + eassumption. + } + now bsimpl. + + - split ; [easy|..]. + intros * IH ? [] ? [=] ([]&?&[? [=]])%eq_sym%map_eq_cons ; subst. + edestruct IH as [? []]. + 1: reflexivity. + 2:{ + subst. + eexists ; split ; [..|reflexivity]. + unfold graph ; simp wh_red_stack. + patch_rec_ret ; econstructor. + 2: now constructor. + eassumption. + } + now bsimpl. + + - intros ? [] ? [=] ->%eq_sym%List.map_eq_nil ; subst. + eexists ; split ; [unfold graph ; simp wh_red_stack ; now econstructor|..]. + now bsimpl. + + - split ; [easy|..]. + intros * IH ? [] ? [=] ([]&?&[? [=]])%eq_sym%map_eq_cons ; subst. + edestruct IH as [? []]. + 1: reflexivity. + 2:{ + subst. + eexists ; split ; [..|reflexivity]. + unfold graph ; simp wh_red_stack. + patch_rec_ret ; econstructor. + 2: now constructor. + eassumption. + } + now bsimpl. + + - split ; [easy|..]. + intros * IH ? [] ? [=] ([]&?&[? [=]])%eq_sym%map_eq_cons ; subst. + edestruct IH as [? []]. + 1: reflexivity. + 2:{ + subst. + eexists ; split ; [..|reflexivity]. + unfold graph ; simp wh_red_stack. + patch_rec_ret ; econstructor. + 2: now constructor. + eassumption. + } + now bsimpl. + + - intros ? [] ? [=] ->%eq_sym%List.map_eq_nil ; subst. + eexists ; split ; [unfold graph ; simp wh_red_stack ; now econstructor|..]. + now bsimpl. + + - split ; [easy|..]. + intros * IH ? [] ? [=] ([]&?&[? [=]])%eq_sym%map_eq_cons ; subst. + edestruct IH as [? []]. + 1: reflexivity. + 2:{ + subst. + eexists ; split ; [..|reflexivity]. + unfold graph ; simp wh_red_stack. + patch_rec_ret ; econstructor. + 2: now constructor. + eassumption. + } + now bsimpl. + + - split ; [easy|..]. + destruct s. + all: intros * IH ? [] ? [=] ? ; subst. + all: edestruct IH as [? []] ; [reflexivity|..] ; [shelve|..]. + all: subst. + all: eexists ; split ; [..|reflexivity]. + all: unfold graph ; simp wh_red_stack ; cbn. + all: patch_rec_ret ; econstructor ; [..|now constructor]. + all: eassumption. + Unshelve. + all: reflexivity. + Qed. + + Corollary _wh_red_str : + funrect wh_red (fun _ => True) (fun t u => forall (ρ : nat -> nat) t', + t = t'⟨ρ⟩ -> ∑ u', graph wh_red t' u' × u = u'⟨ρ⟩). + Proof. + intros ? _. + cbn ; intros ? H ρ t' ->. + eapply funrect_graph in H. + 2: apply red_stack_str. + 2: easy. + edestruct (H ρ t' nil) as [? []]. + 1-2: reflexivity. + eexists ; split ; tea. + unfold graph. + econstructor ; cbn ; tea. + now constructor. + Qed. + + Lemma wh_red_str (ρ : nat -> nat) t v : + graph wh_red t⟨ρ⟩ v -> + ∑ v', v = v'⟨ρ⟩ × graph wh_red t v'. + Proof. + intros g. + eapply funrect_graph in g. + 2: apply _wh_red_str. + 2: easy. + cbn in g. + edestruct g as [? []]. + 1: reflexivity. + now easy. + Qed. + + Lemma up_inj ρ : ssrfun.injective ρ -> ssrfun.injective (upRen_term_term ρ). + Proof. + intros H x y e. + destruct x,y ; cbn in * ; try congruence. + easy. + Qed. + + Definition ncan_ne_view1 {N} (w : ~ isCanonical N) : ne_view1 N. + Proof. + destruct N. + all: try solve [destruct w ; econstructor]. + - now constructor. + - eapply (ne_view1_dest _ (eApp _)). + - eapply (ne_view1_dest _ (eNatElim _ _ _)). + - eapply (ne_view1_dest _ (eEmptyElim _)). + - eapply (ne_view1_dest _ eFst). + - eapply (ne_view1_dest _ eSnd). + - eapply (ne_view1_dest _ (eIdElim _ _ _ _ _)). + Defined. + + Lemma ncan_nf_view1 {N} (w : ~ isCanonical N) : build_nf_view1 N = nf_view1_ne (ncan_ne_view1 w). + Proof. + destruct N ; cbn ; try reflexivity. + all: destruct w ; econstructor. + Qed. + + Lemma nf_view2_neutral_can t t' : + build_nf_view2 t t' = neutrals t t' -> + ~ isCanonical t /\ ~ isCanonical t'. + Proof. + intros Heq. + simp build_nf_view2 in Heq. + destruct (build_nf_view1 t) as [? [] | | ? [] | | | ] eqn:Heqt ; cbn in Heq. + all: destruct (build_nf_view1 t') as [? [] | | ? [] | | | ] eqn:Heqt' ; cbn in Heq. + all: try solve [congruence]. + split. + all: now eapply tm_view1_neutral_can. + Qed. + + Definition nf_view2_rename (ρ : nat -> nat) {t t' : term} (v : nf_view2 t t') : nf_view2 t⟨ρ⟩ t'⟨ρ⟩ := + match v in nf_view2 x x' return nf_view2 x⟨ρ⟩ x'⟨ρ⟩ with + | sorts s s' => sorts s s' + | prods A A' B B' => prods A⟨ρ⟩ A'⟨ρ⟩ B⟨upRen_term_term ρ⟩ B'⟨upRen_term_term ρ⟩ + | nats => nats + | emptys => emptys + | sigs A A' B B' => sigs A⟨ρ⟩ A'⟨ρ⟩ B⟨upRen_term_term ρ⟩ B'⟨upRen_term_term ρ⟩ + | ids A A' x x' y y' => ids A⟨ρ⟩ A'⟨ρ⟩ x⟨ρ⟩ x'⟨ρ⟩ y⟨ρ⟩ y'⟨ρ⟩ + | lams A A' t t' => lams A⟨ρ⟩ A'⟨ρ⟩ t⟨upRen_term_term ρ⟩ t'⟨upRen_term_term ρ⟩ + | lam_ne A t n' => lam_ne A⟨ρ⟩ t⟨upRen_term_term ρ⟩ n'⟨ρ⟩ + | ne_lam n A' t' => ne_lam n⟨ρ⟩ A'⟨ρ⟩ t'⟨upRen_term_term ρ⟩ + | zeros => zeros + | succs t t' => succs t⟨ρ⟩ t'⟨ρ⟩ + | pairs A A' B B' t t' u u' => pairs A⟨ρ⟩ A'⟨ρ⟩ B⟨upRen_term_term ρ⟩ B'⟨upRen_term_term ρ⟩ t⟨ρ⟩ t'⟨ρ⟩ u⟨ρ⟩ u'⟨ρ⟩ + | pair_ne A B t u n' => pair_ne A⟨ρ⟩ B⟨upRen_term_term ρ⟩ t⟨ρ⟩ u⟨ρ⟩ n'⟨ρ⟩ + | ne_pair n A' B' t' u' => ne_pair n⟨ρ⟩ A'⟨ρ⟩ B'⟨upRen_term_term ρ⟩ t'⟨ρ⟩ u'⟨ρ⟩ + | refls A A' x x' => refls A⟨ρ⟩ A'⟨ρ⟩ x⟨ρ⟩ x'⟨ρ⟩ + | neutrals n n' => neutrals n⟨ρ⟩ n'⟨ρ⟩ + | mismatch t u => mismatch t⟨ρ⟩ u⟨ρ⟩ + | anomaly t u => anomaly t⟨ρ⟩ u⟨ρ⟩ + end. + + Lemma build_nf_view2_rename ρ t t' : build_nf_view2 t⟨ρ⟩ t'⟨ρ⟩ = nf_view2_rename ρ (build_nf_view2 t t'). + Proof. + destruct t, t' ; reflexivity. + Qed. + + Definition ne_view2_rename (ρ : nat -> nat) {t t' : term} (v : ne_view2 t t') : ne_view2 t⟨ρ⟩ t'⟨ρ⟩ := + match v in ne_view2 x x' return ne_view2 x⟨ρ⟩ x'⟨ρ⟩ with + | ne_rels n n' => ne_rels (ρ n) (ρ n') + | ne_apps f u f' u' => ne_apps f⟨ρ⟩ u⟨ρ⟩ f'⟨ρ⟩ u'⟨ρ⟩ + | ne_nats n P hz hs n' P' hz' hs' => ne_nats + n⟨ρ⟩ P⟨upRen_term_term ρ⟩ hz⟨ρ⟩ hs⟨ρ⟩ + n'⟨ρ⟩ P'⟨upRen_term_term ρ⟩ hz'⟨ρ⟩ hs'⟨ρ⟩ + | ne_emptys n P n' P' => ne_emptys n⟨ρ⟩ P⟨upRen_term_term ρ⟩ n'⟨ρ⟩ P'⟨upRen_term_term ρ⟩ + | ne_fsts p p' => ne_fsts p⟨ρ⟩ p'⟨ρ⟩ + | ne_snds p p' => ne_snds p⟨ρ⟩ p'⟨ρ⟩ + | ne_ids A x P hr y e A' x' P' hr' y' e' => ne_ids + A⟨ρ⟩ x⟨ρ⟩ P⟨upRen_term_term (upRen_term_term ρ)⟩ hr⟨ρ⟩ y⟨ρ⟩ e⟨ρ⟩ + A'⟨ρ⟩ x'⟨ρ⟩ P'⟨upRen_term_term (upRen_term_term ρ)⟩ hr'⟨ρ⟩ y'⟨ρ⟩ e'⟨ρ⟩ + | ne_mismatch t u => ne_mismatch t⟨ρ⟩ u⟨ρ⟩ + | ne_anomaly t u => ne_anomaly t⟨ρ⟩ u⟨ρ⟩ + end. + + Lemma build_ne_view2_rename ρ t t' : build_ne_view2 t⟨ρ⟩ t'⟨ρ⟩ = ne_view2_rename ρ (build_ne_view2 t t'). + Proof. + destruct t, t' ; reflexivity. + Qed. + + #[local] Ltac crush := + repeat match goal with + | |- context [build_nf_view1 _] => erewrite ncan_nf_view1 ; cbn + | |- forall (_ : exn _ _), _ => intros [] ; cbn + | |- ?t = ?t'⟨_⟩ -> _ => + intros _eq ; subst t + + (destruct t' ; cbn in _eq ; try solve [congruence] ; inversion _eq ; subst ; clear _eq) + | |- forall _ : _, _ => intros ? + | |- True => trivial + | |- True * _ => split ; [trivial|..] + | |- graph _uconv (_, _, _) _ => unfold graph ; simp _uconv uconv_tm_red uconv_ne build_nf_view2 ; cbn + | H : _ |- orec_graph ?f (?f ?t) ?r => simple eapply H ; [..|reflexivity|reflexivity] + | |- orec_graph _ _ _ => cbn ; patch_rec_ret ; econstructor + | |- ssrfun.injective (upRen_term_term _) => apply up_inj + | |- ssrfun.injective _ => assumption + end. + + Lemma _uconv_str : + funrect _uconv (fun _ => True) + (fun '(s,t,u) r => forall (ρ : nat -> nat) t' u', ssrfun.injective ρ -> + t = t'⟨ρ⟩ -> u = u'⟨ρ⟩ -> graph _uconv (s,t',u') r). + Proof. + intros ? _ ; cbn. + funelim (_uconv _) ; cbn. + + - funelim (uconv_tm _) ; cbn. + intros ? red ? red'. + split ; [easy|..]. + intros ? IH ** ; subst. + unfold graph ; simp _uconv uconv_tm ; cbn. + eapply wh_red_str in red as [? [->]], red' as [? [->]]. + econstructor. + 1: eassumption. + econstructor. + 1: eassumption. + patch_rec_ret. + econstructor ; [..|econstructor]. + now eapply IH. + + - funelim (uconv_tm_red _) ; cbn. + all: match goal with | _ : _ = _ |- _ => shelve | _ => idtac end. + all: solve [crush]. + Unshelve. + + + crush. + all: eapply H ; [now eapply up_inj | reflexivity|..]. + all: now asimpl. + + + crush. + all: eapply H ; [now eapply up_inj |idtac|reflexivity]. + all: now asimpl. + + + crush. + + + crush. + + + crush. + + + intros. + subst. + rewrite build_nf_view2_rename in Heq. + unfold graph ; simp _uconv uconv_tm_red. + destruct (build_nf_view2 _ _) ; cbn in * ; try solve [congruence]. + now constructor. + + + easy. + + - funelim (uconv_ne _) ; cbn. + 1-6,8: solve [crush]. + + + intros. + subst. + rewrite build_ne_view2_rename in Heq. + unfold graph ; simp _uconv uconv_ne. + destruct (build_ne_view2 _ _) ; cbn in * ; try solve [congruence]. + now constructor. + + + crush. + eapply Nat.eqb_eq in Heq ; subst. + match goal with | H : ssrfun.injective _ |- _ => apply H in Heq end. + subst. + rewrite Nat.eqb_refl ; cbn. + now constructor. + + crush. + eapply Nat.eqb_neq in Heq. + rewrite (proj2 (Nat.eqb_neq _ _)) ; cbn ; auto. + now constructor. + + Unshelve. + all: try solve [apply nf_view2_neutral_can in Heq as [] ; now eintros ?%isCanonical_ren]. + all: match goal with + | |- ~ isCanonical ?t => remember t⟨ρ⟩ as t' in * ; eintros ?%isCanonical_ren + end. + all: solve [simp build_nf_view2 in Heq ; + destruct (build_nf_view1 t') as [? [] | | ? [] | | | ] eqn:Heq' ; subst ; cbn in * ; + congruence + (now eapply tm_view1_neutral_can)]. + + Qed. + +End AlgoStr. + +Lemma uconv_expand_ne_eta n n' : + whne n -> + whne n' -> + domain _uconv (tm_state, eta_expand n, eta_expand n') -> + domain _uconv (ne_state, n, n'). +Proof. + intros w w' [v g]. + unfold graph in g. + simp _uconv uconv_tm in g ; cbn in g. + apply (orec_graph_call_inv _uconv) in g as [? [red g]] ; cbn in *. + eapply red_sound in red as [<-%red_whne _]. + 2: now constructor ; apply whne_ren. + apply (orec_graph_call_inv _uconv) in g as [? [red g]] ; cbn in *. + eapply red_sound in red as [<-%red_whne _]. + 2: now constructor ; apply whne_ren. + apply (orec_graph_rec_inv _uconv) in g as [? [g _]] ; cbn in *. + simp _uconv uconv_tm_red in g. + apply (orec_graph_rec_inv _uconv) in g as [? [g _]] ; cbn in *. + simp _uconv uconv_ne to_neutral_diag in g ; cbn in *. + apply (orec_graph_rec_inv _uconv) in g as [r [g _]] ; cbn in *. + eapply uconv_wk in g. + - now eexists. + - intros ??. + auto. +Qed. + +Lemma uconv_expand_ne_fst n n' : + whne n -> + whne n' -> + domain _uconv (tm_state, tFst n, tFst n') -> + domain _uconv (ne_state, n, n'). + Proof. + intros w w' [v g]. + unfold graph in g. + simp _uconv uconv_tm in g ; cbn in g. + apply (orec_graph_call_inv _uconv) in g as [? [red g]] ; cbn in *. + eapply red_sound in red as [<-%red_whne _]. + 2: now constructor. + apply (orec_graph_call_inv _uconv) in g as [? [red g]] ; cbn in *. + eapply red_sound in red as [<-%red_whne _]. + 2: now constructor. + apply (orec_graph_rec_inv _uconv) in g as [? [g _]] ; cbn in *. + simp _uconv uconv_tm_red in g. + apply (orec_graph_rec_inv _uconv) in g as [? [g _]] ; cbn in *. + simp _uconv uconv_ne to_neutral_diag in g ; cbn in *. + apply (orec_graph_rec_inv _uconv) in g as [r [g _]] ; cbn in *. + now eexists. +Qed. + +Lemma uconv_expand Γ A t t' B u u': + [Γ |- t : A] -> + [t ⤳* t'] -> + [Γ |- u : B] -> + [u ⤳* u'] -> + domain _uconv (tm_state, t, u) -> + domain _uconv (tm_state, t', u'). + Proof. + intros ? [red ?]%dup ? [red' ?]%dup [v g] ; refold. + unfold graph in g. + simp _uconv uconv_tm in g ; cbn in g. + apply (orec_graph_call_inv _uconv) in g as [? [[? w]%red_sound g]] ; cbn in *. + apply (orec_graph_call_inv _uconv) in g as [? [[? w']%red_sound g]] ; cbn in *. + apply (orec_graph_rec_inv _uconv) in g as [? [g _]] ; cbn in *. + eapply whred_red_det in red, red' ; cycle -1 ; tea. + apply compute_domain. + simp _uconv uconv_tm ; cbn. + split. + 1:{ + eexists ; cbn. + eapply wh_red_complete_whnf_tm ; tea. + now eapply subject_reduction_raw. + } + intros ? [ ]%red_sound. + eapply whred_det in red ; tea ; subst. + split. + 1:{ + eexists ; cbn. + eapply wh_red_complete_whnf_tm ; tea. + now eapply subject_reduction_raw. + } + intros ? [ ]%red_sound. + eapply whred_det in red' ; tea ; subst. + split. + 2: easy. + now eexists. +Qed. + +Import DeclarativeTypingProperties. + +Section ConversionTerminates. + + +Let PTyEq (Γ : context) (A B : term) := + forall B', + [Γ |-[de] A] × [Γ |-[de] B'] -> + domain _uconv (tm_state,A,B'). +Let PTyRedEq (Γ : context) (A B : term) := + forall B', + isType B' -> + [Γ |-[de] A] × [Γ |-[de] B'] -> + domain _uconv (tm_red_state,A,B'). +Let PNeEq (Γ : context) (A t u : term) := + forall u', + whne u' -> + well_typed (ta := de) Γ t × well_typed (ta := de) Γ u' -> + domain _uconv (ne_state,t,u'). +Let PTmEq (Γ : context) (A t u : term) := + forall u', + [Γ |-[de] t : A] × [Γ |-[de] u' : A] -> + domain _uconv (tm_state,t,u'). +Let PTmRedEq (Γ : context) (A t u : term) := + forall u', + whnf u' -> + [Γ |-[de] t : A] × [Γ |-[de] u' : A] -> + domain _uconv (tm_red_state,t,u'). + +Ltac split_tm := + split ; + [ intros * ? [Hz%type_isType Hz'%type_isType] ; + [solve [inversion Hz ; inv_whne | inversion Hz' ; inv_whne] | ..] ; solve [ now constructor | now apply isType_whnf] + |..]. + +Theorem _uconv_terminates : + AlgoConvInductionConcl PTyEq PTyRedEq PNeEq PNeEq PTmEq PTmRedEq. +Proof. + subst PTyEq PTyRedEq PNeEq PTmEq PTmRedEq. + apply AlgoConvInduction. + + - intros * ?? HA IHA * [? Hconcl]%dup. + apply compute_domain. + simp _conv conv_ty. + cbn. + split. + 1: eapply wh_red_complete ; now exists istype. + intros A'' []%red_sound. + split. + 1: eapply wh_red_complete ; now exists istype. + intros B'' []%red_sound. + replace A'' with A' + by (eapply whred_det ; tea ; eapply algo_conv_wh in HA as [] ; gen_typing). + + eapply typeConvRed_prem2, IHA in Hconcl as [] ; eauto. + 2: now eapply type_isType. + split ; [now eexists|..]. + now intros [] ; cbn. + + - intros * ???? * wB' [Hconcl]%dup. + apply compute_domain. + simp _uconv uconv_tm_red. + destruct wB'. + all: simp build_nf_view2 ; cbn ; try easy. + 2: now unshelve erewrite whne_nf_view1 ; cbn. + + eapply typePiCongAlg_prem0 in Hconcl as [Hpre0 []]%dup. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [Hpost0 _]%implem_uconv_graph%uconv_sound_decl ; eauto. + eapply typePiCongAlg_prem1 in Hpost0 ; eauto. + + - intros * wB' ?. + apply compute_domain. + simp _uconv uconv_tm_red. + destruct wB'. + all: simp build_nf_view2 ; cbn ; try easy. + now unshelve erewrite whne_nf_view1 ; cbn. + + - intros * wB' ?. + apply compute_domain. + simp _uconv uconv_tm_red. + destruct wB'. + all: simp build_nf_view2 ; cbn ; try easy. + now unshelve erewrite whne_nf_view1 ; cbn. + + - intros * wB' ?. + apply compute_domain. + simp _uconv uconv_tm_red. + destruct wB'. + all: simp build_nf_view2 ; cbn ; try easy. + now unshelve erewrite whne_nf_view1 ; cbn. + + - intros * ? ? ? ? * wB' [Hconcl]%dup. + apply compute_domain. + simp _uconv uconv_tm_red. + destruct wB'. + all: simp build_nf_view2 ; cbn ; try easy. + 2: now unshelve erewrite whne_nf_view1 ; cbn. + + eapply typeSigCongAlg_prem0 in Hconcl as [Hpre0 []]%dup. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [Hpost0 _]%implem_uconv_graph%uconv_sound_decl ; eauto. + eapply typeSigCongAlg_prem1 in Hpost0 ; eauto. + + - intros * ? ? ? ? ? ? * wB' [Hconcl]%dup. + apply compute_domain. + simp _uconv uconv_tm_red. + destruct wB'. + all: simp build_nf_view2 ; cbn ; try easy. + 2: now unshelve erewrite whne_nf_view1 ; cbn. + + eapply typeIdCongAlg_prem0 in Hconcl as [Hpre0 []]%dup. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [[Hpost0]%dup _]%implem_uconv_graph%uconv_sound_decl ; eauto. + eapply typeIdCongAlg_prem1 in Hpost0 as [[] Hpre1]%dup ; eauto. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [_ Hpost1]%implem_uconv_graph%uconv_sound_decl ; eauto. + eapply typeIdCongAlg_prem2 in Hpost1 ; eauto. + + - intros * ?? ?? * wB' [Hconcl]%dup. + apply compute_domain. + simp _uconv uconv_tm_red build_nf_view2. + destruct wB' ; cbn. + 1-6: now unshelve erewrite whne_nf_view1 ; cbn. + do 2 (unshelve erewrite whne_nf_view1 ; tea ; cbn). + + eapply typeNeuConvAlg_prem2 in Hconcl as [Hpre0 []]%dup ; eauto. + + - intros ? n ? ? * wu' [Hconcl]%dup. + apply compute_domain. + destruct wu' as [n'| | | | | |]. + all: simp _uconv uconv_ne to_neutral_diag ; cbn ; try easy. + now destruct (Nat.eqb_spec n n') ; cbn. + + - intros * Hm ? ?? * wu' [Hconcl]%dup. + apply compute_domain. + destruct wu'. + all: simp _uconv uconv_ne to_neutral_diag ; cbn; try exact I. + + eapply neuAppCongAlg_prem0 in Hconcl as [Hpre0 []]%dup ; eauto. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + inversion Hm as [????? Hm'] ; refold ; subst. + eintros [? Hpost1]%implem_uconv_graph%uconv_sound ; eauto. + eapply algo_conv_det in Hm' ; tea ; subst. + eapply neuConvRed in Hpost1 ; refold ; tea. + eapply algo_conv_sound, neuAppCongAlg_prem1 in Hpost1 ; eauto. + + - intros * Hn ? ?? ?? ?? * wu' [Hconcl]%dup. + apply compute_domain. + destruct wu'. + all: simp _uconv uconv_ne to_neutral_diag ; cbn; try exact I. + + eapply neuNatElimCong_prem0 in Hconcl as [Hpre0 []]%dup ; eauto. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + inversion Hn as [????? Hm'] ; refold ; subst. + eintros [? Hpost1]%implem_uconv_graph%uconv_sound ; eauto. + eapply algo_conv_det in Hm' ; tea ; subst. + eapply neuConvRed in Hpost1 ; refold ; tea. + eapply algo_conv_sound in Hpost1 as [[] [Hpost1]%dup]%dup ; eauto. + eapply neuNatElimCong_prem1 in Hpost1 as [[]]%dup ; eauto. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [[Hpost2]%dup _]%implem_uconv_graph%uconv_sound_decl ; eauto. + eapply neuNatElimCong_prem2 in Hpost2 as [[]]%dup ; eauto. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [_ [Hpost3]%dup]%implem_uconv_graph%uconv_sound_decl ; eauto. + eapply neuNatElimCong_prem3 in Hpost3 ; eauto. + + - intros * Hn ? ?? * wu' [Hconcl]%dup. + apply compute_domain. + destruct wu'. + all: simp _uconv uconv_ne to_neutral_diag ; cbn; try exact I. + + eapply neuEmptyElimCong_prem0 in Hconcl as [Hpre0 []]%dup ; eauto. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + inversion Hn as [????? Hm'] ; refold ; subst. + eintros [? Hpost1]%implem_uconv_graph%uconv_sound ; eauto. + eapply algo_conv_det in Hm' ; tea ; subst. + eapply neuConvRed in Hpost1 ; refold ; tea. + eapply algo_conv_sound in Hpost1 as [[] [Hpost1]%dup]%dup ; eauto. + eapply neuEmptyElimCong_prem1 in Hpost1 ; eauto. + + - intros * Hn ? * wu' [Hconcl]%dup. + apply compute_domain. + destruct wu'. + all: simp _uconv uconv_ne to_neutral_diag ; cbn; try exact I. + + eapply neuFstCongAlg_prem0 in Hconcl ; eauto. + + - intros * Hn ? * wu' [Hconcl]%dup. + apply compute_domain. + destruct wu'. + all: simp _uconv uconv_ne to_neutral_diag ; cbn; try exact I. + + eapply neuSndCongAlg_prem0 in Hconcl ; eauto. + + - intros * _ * _ * _ * He ?? ?? ?? * wu' [Hconcl]%dup. + apply compute_domain. + destruct wu'. + all: simp _uconv uconv_ne to_neutral_diag ; cbn; try exact I. + + eapply neuIdElimCong_prem0 in Hconcl as [Hpre0 []]%dup ; eauto. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + inversion He as [????? He'] ; refold ; subst. + eintros [? Hpost1]%implem_uconv_graph%uconv_sound ; eauto. + eapply algo_conv_det in He' ; tea ; subst. + eapply neuConvRed in Hpost1 ; refold ; tea. + eapply algo_conv_sound in Hpost1 as [[] [Hpost1]%dup]%dup ; eauto. + eapply neuIdElimCong_prem1 in Hpost1 as [[]]%dup ; eauto. + repeat erewrite <- wk1_ren_on. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [[Hpost2]%dup _]%implem_uconv_graph%uconv_sound_decl ; eauto. + eapply neuIdElimCong_prem2 in Hpost2 ; eauto. + + - eauto. + + - intros * ??? []%algo_conv_wh IH * [Hconcl []]%dup. + apply compute_domain. + simp _uconv uconv_tm ; cbn. + + split. + 1: eapply wh_red_complete ; now eexists (isterm _). + intros t'' []%red_sound. + split. + 1: eapply wh_red_complete ; now eexists (isterm _). + intros u'' []%red_sound. + + replace t'' with t' in * by (eapply whred_det ; eassumption). + + eapply termConvRed_prem3 in Hconcl ; eauto. + + - intros * ?? ?? * wu' [Hconcl []]%dup. + apply compute_domain. + simp _uconv uconv_tm_red build_nf_view2. + eapply Uterm_isType in wu' ; tea. + destruct wu' ; cbn ; try exact I. + 2: now unshelve erewrite whne_nf_view1 ; cbn. + + eapply termPiCongAlg_prem0 in Hconcl as [Hpre0 []]%dup. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [_ Hpost0]%implem_uconv_graph%uconv_sound_decl ; eauto. + eapply termPiCongAlg_prem1 in Hpost0 ; eauto. + + - intros * wu' [Hconcl []]%dup. + apply compute_domain. + simp _uconv uconv_tm_red build_nf_view2. + eapply Uterm_isType in wu' ; tea. + destruct wu' ; cbn ; try exact I. + now unshelve erewrite whne_nf_view1 ; cbn. + + - intros * wu' [Hconcl []]%dup. + apply compute_domain. + simp _uconv uconv_tm_red build_nf_view2. + eapply nat_isNat in wu' ; tea. + destruct wu' ; cbn ; try exact I. + now unshelve erewrite whne_nf_view1 ; cbn. + + - intros * ?? * wu' [Hconcl []]%dup. + apply compute_domain. + simp _uconv uconv_tm_red build_nf_view2. + eapply nat_isNat in wu' ; tea. + destruct wu' ; cbn ; try exact I. + 2: now unshelve erewrite whne_nf_view1 ; cbn. + + eapply termSuccCongAlg_prem0 in Hconcl ; eauto. + + - intros * wu' [Hconcl []]%dup. + apply compute_domain. + simp _uconv uconv_tm_red build_nf_view2. + eapply Uterm_isType in wu' ; tea. + destruct wu' ; cbn ; try exact I. + now unshelve erewrite whne_nf_view1 ; cbn. + + - intros * w _ ? IH ? w' [Hconcl []]%dup. + apply compute_domain. + simp _uconv uconv_tm_red build_nf_view2 ; cbn. + eapply fun_isFun in w, w' ; eauto. + destruct w, w'. + + + eapply LamCongUAlg_prem0 in Hconcl as (?&?&[[=<-<-]]). + 2: now constructor. + cbn ; split ; [..|easy]. + eapply uconv_expand ; [..|eapply IH ; split] ; eauto. + all: try solve [now eapply typing_eta']. + 2: reflexivity. + now eapply redalg_one_step, eta_expand_beta. + + + eapply LamNeUAlg_prem0 in Hconcl as (?&?&[[=<-<-]]). + 2: now constructor. + cbn. + unshelve (erewrite whne_nf_view1) ; tea ; cbn. + split ; [..|easy]. + eapply uconv_expand ; [..|eapply IH ; split] ; eauto. + all: try solve [now eapply typing_eta']. + * eapply redalg_one_step, eta_expand_beta. + * reflexivity. + + + eapply NeLamUAlg_prem0 in Hconcl as (?&?&[[=<-<-]]). + 2: now constructor. + cbn. + unshelve (erewrite whne_nf_view1) ; tea ; cbn. + split ; [..|easy]. + eapply IH ; split ; eauto. + + + unshelve erewrite whne_nf_view1 ; tea ; cbn. + unshelve erewrite whne_nf_view1 ; tea ; cbn. + split ; [..|easy]. + apply uconv_expand_ne_eta ; tea. + eapply IH. + split. + all: now eapply typing_eta'. + + - intros * ?? ?? * wu' [Hconcl []]%dup. + apply compute_domain. + simp _uconv uconv_tm_red build_nf_view2. + eapply Uterm_isType in wu' ; tea. + destruct wu' ; cbn ; try exact I. + 2: now unshelve erewrite whne_nf_view1 ; cbn. + + eapply termSigCongAlg_prem0 in Hconcl as [Hpre0 []]%dup. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [_ Hpost0]%implem_uconv_graph%uconv_sound_decl ; eauto. + eapply termSigCongAlg_prem1 in Hpost0 ; eauto. + + - intros ? t u A'' B'' w _ ? IHf ? IHs * w' [Hconcl []]%dup. + apply compute_domain. + simp _uconv uconv_tm_red build_nf_view2 ; cbn. + eapply sig_isPair in w, w' ; tea. + destruct w, w'. + + + cbn. + eapply PairCongUAlg_prem0 in Hconcl as (?&?&[[=<-<-] [[]]%dup]). + 2: now constructor. + cbn. + split. + 1:{ + eapply uconv_expand, IHf ; try reflexivity ; [..|split] ; eauto. + 2: eapply redalg_one_step ; econstructor. + all: now econstructor. + } + + intros [] ; cbn ; [|easy]. + intros [_ Hpost1]%implem_uconv_graph%uconv_sound_decl ; eauto. + eapply PairCongUAlg_prem1 in Hpost1 as [] ; eauto. + split ; [..|easy]. + eapply uconv_expand, IHs ; try reflexivity ; [..|split] ; eauto. + 2: eapply redalg_one_step ; econstructor. + all: now econstructor. + + + cbn. + eapply PairNeUAlg_prem0 in Hconcl as (?&?&[[=<-<-] [[]]%dup]). + 2: now constructor. + unshelve erewrite whne_nf_view1 ; tea ; cbn. + split. + 1:{ + eapply uconv_expand, IHf ; try reflexivity ; [..|split] ; eauto. + 2: eapply redalg_one_step ; econstructor. + all: now econstructor. + } + + intros [] ; cbn ; [|easy]. + intros [_ Hpost1]%implem_uconv_graph%uconv_sound_decl ; eauto. + eapply PairNeUAlg_prem1 in Hpost1 as [] ; eauto. + split ; [..|easy]. + eapply uconv_expand, IHs ; try reflexivity ; [..|split] ; eauto. + 2: eapply redalg_one_step ; econstructor. + all: now econstructor. + + + cbn. + eapply NePairUAlg_prem0 in Hconcl as (?&?&[[=<-<-] [[]]%dup]). + 2: now constructor. + unshelve erewrite whne_nf_view1 ; tea ; cbn. + split. + 1: now eapply uconv_expand, IHf ; try reflexivity ; [..|split]. + + intros [] ; cbn ; [|easy]. + intros [_ Hpost1]%implem_uconv_graph%uconv_sound_decl ; eauto. + eapply NePairUAlg_prem1 in Hpost1 as [] ; eauto. + + + cbn. + do 2 (unshelve erewrite whne_nf_view1 ; tea ; cbn). + split ; [..|easy]. + eapply uconv_expand_ne_fst ; tea. + apply IHf. + split ; now econstructor. + + - intros * ?? ?? ?? ? wu' [Hconcl []]%dup. + apply compute_domain. + simp _uconv uconv_tm_red build_nf_view2. + eapply Uterm_isType in wu' ; tea. + destruct wu' ; cbn ; try exact I. + 2: now unshelve erewrite whne_nf_view1 ; cbn. + + eapply termIdCongAlg_prem0 in Hconcl as [Hpre0 []]%dup. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [_ [Hpost0]%dup]%implem_uconv_graph%uconv_sound_decl ; eauto. + eapply termIdCongAlg_prem1 in Hpost0 as [[]]%dup ; eauto. + split ; [eauto | intros [] ; cbn ; [|easy]]. + + intros [_ Hpost1]%implem_uconv_graph%uconv_sound_decl ; eauto. + eapply termIdCongAlg_prem2 in Hpost1 ; eauto. + + - intros * _ * _ * wu' [Hconcl []]%dup. + apply compute_domain. + simp _uconv uconv_tm_red build_nf_view2. + eapply id_isId in wu' ; tea. + destruct wu' as [|(?&?&->)] ; cbn ; try exact I. + now unshelve erewrite whne_nf_view1 ; cbn. + + - intros * []%algo_conv_wh IH Hpos ? wu' [Hconcl [? Hty]]%dup. + apply compute_domain. + simp _uconv uconv_tm_red build_nf_view2. + unshelve erewrite whne_nf_view1 ; tea ; cbn. + destruct wu' ; cbn ; try easy. + + eapply termGen' in Hty as (?&[? [->]]&Hconv). + eapply red_compl_prod_l' in Hconv as (?&?&[->]). + 2: gen_typing. + inversion Hpos. + inv_whne. + + eapply termGen' in Hty as (?&[->]&Hconv). + eapply conv_sig_l in Hconv as (?&?&[->]). + 2: gen_typing. + inversion Hpos. + inv_whne. + + unshelve erewrite whne_nf_view1 ; tea ; cbn. + split ; [..|easy]. + eapply IH ; tea. + split ; now eexists. + +Qed. \ No newline at end of file diff --git a/theories/DeclarativeSubst.v b/theories/DeclarativeSubst.v deleted file mode 100644 index 51df620d..00000000 --- a/theories/DeclarativeSubst.v +++ /dev/null @@ -1,309 +0,0 @@ -(** * LogRel.DeclarativeSubst: stability of declarative typing by substitution. *) -From Coq Require Import CRelationClasses. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening UntypedReduction - GenericTyping DeclarativeTyping DeclarativeInstance. -From LogRel Require Import LogicalRelation Validity Fundamental. -From LogRel.LogicalRelation Require Import Induction Escape Irrelevance Transitivity. -From LogRel.Substitution Require Import Properties Irrelevance. - -(** Currently, this is obtained as a consequence of the fundamental lemma. -However, it could be alternatively proven much earlier, by a direct induction. *) - -Set Printing Primitive Projection Parameters. - -Import DeclarativeTypingProperties. - -Lemma typing_subst : WfDeclInductionConcl - (fun _ => True) - (fun Γ A => forall Δ σ, [|- Δ] -> [Δ |-s σ : Γ] -> [Δ |- A[σ]]) - (fun Γ A t => forall Δ σ, [|- Δ] -> [Δ |-s σ : Γ] -> [Δ |- t[σ] : A[σ]]) - (fun Γ A B => forall Δ σ σ', [|- Δ] -> [Δ |-s σ ≅ σ' : Γ] -> [Δ |- A[σ] ≅ B[σ']]) - (fun Γ A t u => forall Δ σ σ', [|- Δ] -> [Δ |-s σ ≅ σ' : Γ] -> [Δ |- t[σ] ≅ u[σ'] : A[σ]]). -Proof. - unshelve (repeat split ; [shelve|..]). - - intros Γ ? Ht * HΔ Hσ. - unshelve eapply Fundamental_subst in Hσ as []. - 1,3: boundary. - apply Fundamental in Ht as [VΓ [VA _]]. - unshelve eapply escape, VA ; tea. - unshelve eapply irrelevanceSubst ; eassumption. - - intros * Ht * HΔ Hσ. - unshelve eapply Fundamental_subst in Hσ as []. - 1,3: boundary. - apply Fundamental in Ht as [VΓ [VA] [Vt]]. - unshelve eapply escapeTerm, Vt ; tea. - unshelve eapply irrelevanceSubst ; eassumption. - - intros * Ht * HΔ Hσ. - unshelve eapply Fundamental_subst_conv in Hσ as []. - 1,3: boundary. - apply Fundamental in Ht as [VΓ VA ? Vconv] ; cbn in *. - unshelve eapply escapeEq. - 2: unshelve eapply VA ; tea ; irrValid. - cbn. - unshelve eapply transEq. - 4: now apply Vconv. - 2-3: unshelve eapply VB ; tea. - eapply urefl; now eapply irrelevanceSubstEq. - - intros * Ht * HΔ Hσ. - unshelve eapply Fundamental_subst_conv in Hσ as []. - 1,3: boundary. - apply Fundamental in Ht as [VΓ VA Vtu] ; cbn in *. - unshelve eapply escapeEqTerm. - 2: now unshelve eapply VA ; tea ; irrValid. - cbn. unshelve eapply Vtu. -Qed. - - -Section MoreSubst. - - Lemma ctx_refl Γ : - [|- Γ] -> - [|- Γ ≅ Γ]. - Proof. - induction 1. - all: constructor; tea. - now econstructor. - Qed. - - Lemma subst_wk (Γ Δ Δ' : context) (ρ : Δ' ≤ Δ) σ : - [|- Δ'] -> - [Δ |-s σ : Γ] -> - [Δ' |-s σ⟨ρ⟩ : Γ]. - Proof. - intros ?. - induction 1 as [|σ Γ A]. - 1: now econstructor. - econstructor. - - asimpl ; cbn in * ; asimpl. - eassumption. - - asimpl ; cbn in * ; asimpl. - unfold funcomp. - eapply typing_meta_conv. - 1: eapply typing_wk ; eassumption. - asimpl. - reflexivity. - Qed. - - Corollary well_subst_up (Γ Δ : context) A σ : - [Δ |- A] -> - [Δ |-s σ : Γ] -> - [Δ ,, A |-s σ⟨↑⟩ : Γ]. - Proof. - intros HA Hσ. - eapply subst_wk with (ρ := wk_step A wk_id) in Hσ. - - eapply well_subst_ext ; [|eassumption]. - bsimpl. - now reflexivity. - - econstructor. - all: gen_typing. - Qed. - - Lemma id_subst (Γ : context) : - [|- Γ] -> - [Γ |-s tRel : Γ]. - Proof. - induction 1. - all: econstructor. - - eapply well_subst_ext. - 2: now eapply well_subst_up. - now asimpl. - - eapply typing_meta_conv. - 1: now do 2 econstructor. - cbn ; now renamify. - Qed. - - Lemma subst_refl (Γ Δ : context) σ : - [Γ |-s σ : Δ] -> - [Γ |-s σ ≅ σ : Δ]. - Proof. - induction 1. - all: econstructor ; tea. - now eapply TermRefl. - Qed. - - Theorem typing_subst1 Γ T : - (forall (t : term), [Γ |- t : T] -> - forall (A : term), [Γ,, T |- A] -> [Γ |- A[t..]]) × - (forall (t : term), [Γ |- t : T] -> - forall (A u : term), [Γ,, T |- u : A] -> [Γ |- u[t..] : A[t..]]) × - (forall (t t' : term), [Γ |- t ≅ t' : T] -> - forall (A B : term), [Γ,, T |- A ≅ B] -> [Γ |- A[t..] ≅ B[t'..]]) × - (forall (t t' : term), [Γ |- t ≅ t' : T] -> - forall (A u v : term), [Γ,, T |- u ≅ v : A] -> [Γ |- u[t..] ≅ v[t'..] : A[t..]]). - Proof. - repeat match goal with |- _ × _ => split end. - all: intros * Ht * Hty. - all: assert ([|- Γ]) by gen_typing. - all: assert ([Γ |-s tRel : Γ]) as Hsubst by now eapply id_subst. - 3-4: apply subst_refl in Hsubst. - all: eapply typing_subst ; tea. - all: econstructor ; cbn ; refold ; now asimpl. - Qed. - - Theorem typing_substmap1 Γ T : - (forall (t : term), [Γ ,, T |- t : T⟨↑⟩] -> - forall (A : term), [Γ,, T |- A] -> - [Γ,, T |- A[t]⇑]) × - (forall (t : term), [Γ ,, T |- t : T⟨↑⟩] -> - forall (A u : term), [Γ,, T |- u : A] -> - [Γ,, T |- u[t]⇑ : A[t]⇑]) × - (forall (t t' : term), [Γ ,, T |- t ≅ t' : T⟨↑⟩] -> - forall (A B : term), [Γ,, T |- A ≅ B] -> - [Γ,, T |- A[t]⇑ ≅ B[t']⇑]) × - (forall (t t' : term), [Γ ,, T |- t ≅ t' : T⟨↑⟩] -> - forall (A u v : term), [Γ,, T |- u ≅ v : A] -> - [Γ,, T |- u[t]⇑ ≅ v[t']⇑ : A[t]⇑]). - Proof. - repeat match goal with |- _ × _ => split end. - all: intros * Ht * Hty. - all: assert ([|- Γ,, T] × [|- Γ]) as [] by (split; repeat boundary). - all : assert (Hsubst : [Γ ,, T |-s ↑ >> tRel : Γ]) - by (change (?x >> ?y) with y⟨x⟩; eapply well_subst_up; [boundary| now eapply id_subst]). - 3-4: apply subst_refl in Hsubst. - all: eapply typing_subst ; tea. - all: econstructor ; cbn ; refold; bsimpl; try rewrite <- rinstInst'_term; tea. - Qed. - - Lemma conv_well_subst1 (Γ : context) A A' : - [Γ |- A] -> - [Γ |- A'] -> - [Γ |- A ≅ A'] -> - [Γ,, A |-s tRel : Γ,, A']. - Proof. - intros HA HA' Hconv. - econstructor. - - change (↑ >> tRel) with (tRel⟨↑⟩). - eapply well_subst_up ; tea. - now eapply id_subst ; gen_typing. - - refold. - eapply wfTermConv. - 1: constructor; [gen_typing|now econstructor]. - rewrite <- rinstInst'_term; do 2 erewrite <- wk1_ren_on; eapply typing_wk; tea. - gen_typing. - Qed. - - Theorem stability1 (Γ : context) A A' : - [Γ |- A] -> - [Γ |- A'] -> - [Γ |- A ≅ A'] -> - (forall (T : term), [Γ,, A' |-[de] T] -> [Γ,, A |-[de] T]) - × (forall (T t : term), [Γ,, A' |-[ de ] t : T] -> [Γ,, A |-[de] t : T]) - × (forall (T T' : term), [Γ,, A' |-[ de ] T ≅ T'] -> [Γ,, A |-[de] T ≅ T']) - × (forall (T t u : term), - [Γ,, A' |-[ de ] t ≅ u : T] -> [Γ,, A |-[de] t ≅ u : T]). - Proof. - intros * ? ? Hconv. - eapply (conv_well_subst1 _) in Hconv ; tea. - pose proof (Hconv' := Hconv). - apply subst_refl in Hconv'. - assert [|- Γ,, A] by gen_typing. - repeat match goal with |- _ × _ => split end. - all: intros * Hty. - all: eapply typing_subst in Hty ; tea. - all: repeat (rewrite idSubst_term in Hty ; [..|reflexivity]). - all: eassumption. - Qed. - -End MoreSubst. - -Lemma elimSuccHypTy_ty Γ P : - [|- Γ] -> - [Γ,, tNat |- P] -> - [Γ |-[ de ] elimSuccHypTy P]. -Proof. - intros HΓ HP. - unfold elimSuccHypTy. - econstructor. - 1: now econstructor. - eapply wft_simple_arr. - 1: now eapply HP. - eapply typing_subst. - - now eapply HP. - - boundary. - - econstructor. - + bsimpl. - eapply well_subst_ext. - 2: eapply well_subst_up. - 3: eapply id_subst ; tea. - 2: now econstructor. - now bsimpl. - + cbn. - econstructor. - eapply typing_meta_conv. - 1: now do 2 econstructor ; tea ; econstructor. - reflexivity. -Qed. - -Lemma elimSuccHypTy_conv Γ P P' : - [|- Γ] -> - [Γ,, tNat |- P] -> - [Γ,, tNat |- P ≅ P' ] -> - [Γ |- elimSuccHypTy P ≅ elimSuccHypTy P']. -Proof. - intros. - unfold elimSuccHypTy. - constructor. - 2: constructor. - 1-2: now constructor. - eapply convty_simple_arr; tea. - eapply typing_substmap1; tea. - do 2 constructor; refine (wfVar _ (in_here _ _)). - constructor; boundary. -Qed. - -Lemma conv_well_subst (Γ Δ : context) : - [|- Γ] -> - [ |- Γ ≅ Δ] -> - [Γ |-s tRel : Δ]. -Proof. - intros HΓ. - induction 1 as [| * ? HA] in HΓ |- *. - - now econstructor. - - assert [Γ |- A] by now inversion HΓ. - assert [|- Γ] by now inversion HΓ. - econstructor ; tea. - + eapply well_subst_ext, well_subst_up ; eauto. - reflexivity. - + eapply wfTermConv. - 1: econstructor; [gen_typing| now econstructor]. - rewrite <- rinstInst'_term; do 2 erewrite <- wk1_ren_on. - now eapply typing_wk. -Qed. - -(* Stability and symmetry with redundant hypothesis on the well-formed contexts *) - -Section Stability0. - - Let PCon (Γ : context) := True. - Let PTy (Γ : context) (A : term) := forall Δ, - [|-Δ] -> [|- Δ ≅ Γ] -> [Δ |- A]. - Let PTm (Γ : context) (A t : term) := forall Δ, - [|-Δ] -> [|- Δ ≅ Γ] -> [Δ |- t : A]. - Let PTyEq (Γ : context) (A B : term) := forall Δ, - [|-Δ] -> [|- Δ ≅ Γ] -> [Δ |- A ≅ B]. - Let PTmEq (Γ : context) (A t u : term) := forall Δ, - [|-Δ] -> [|- Δ ≅ Γ] -> [Δ |- t ≅ u : A]. - - Theorem stability0 : WfDeclInductionConcl PCon PTy PTm PTyEq PTmEq. - Proof. - red; prod_splitter; intros Γ * Hty; red. - 1: easy. - all: intros ?? Hconv; eapply (conv_well_subst _) in Hconv ; tea. - all: pose proof (Hconv' := Hconv); apply subst_refl in Hconv'. - all: eapply typing_subst in Hty; tea. - all: repeat (rewrite idSubst_term in Hty ; [..|reflexivity]). - all: eassumption. - Qed. - - Definition convCtxSym0 {Γ Δ} : [|- Δ] -> [|-Γ] -> [|- Δ ≅ Γ] -> [|- Γ ≅ Δ]. - Proof. - induction 3. - all: constructor; inversion H; inversion H0; subst; refold. - 1: now eauto. - eapply stability0 ; tea. - 1: now symmetry. - now eauto. - Qed. - -End Stability0. \ No newline at end of file diff --git a/theories/DeclarativeTyping.v b/theories/DeclarativeTyping.v index a8f9309b..030626ef 100644 --- a/theories/DeclarativeTyping.v +++ b/theories/DeclarativeTyping.v @@ -1,8 +1,7 @@ (** * LogRel.DeclarativeTyping: specification of conversion and typing, in a declarative fashion. *) From Coq Require Import ssreflect. From smpl Require Import Smpl. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening UntypedReduction. +From LogRel Require Import Utils Syntax.All. Set Primitive Projections. @@ -316,12 +315,69 @@ Section Definitions. Notation "[ Γ |- t ⤳* t' ∈ A ]" := (RedClosureDecl Γ A t t'). - Record ConvNeuConvDecl (Γ : context) (A : term) (t u : term) := { +(** ** Declarative neutral conversion *) + +(** We have two notions of "convertible neutrals". The first is relatively weak, and says only that + the two terms are neutral and are convertible (wrt. standard conversion). The good side is that + it can be shown to satisfy the interface of generic typing already. The bad side is that it does not + give us strong enough inversion principles. *) + + Record WeakDeclNeutralConversion (Γ : context) (A : term) (t u : term) := { convnedecl_whne_l : whne t; convnedecl_whne_r : whne u; convnedecl_conv : [ Γ |- t ≅ u : A ]; }. +(** The second, much stronger notion compares neutrals only "structurally". + In particular, it does *not* embed transitivity. + The price is that at this stage we cannot show that it is transitive, yet – we need injectivity of + type constructors for that. So we defer that until that later point. *) + + Inductive DeclNeutralConversion (Γ : context) : term -> term -> term -> Type := + + | neuConvRel T n : [|- Γ] -> in_ctx Γ n T -> [Γ |- tRel n ~ tRel n : T] + + | neuConvApp A B n n' a a' : + [Γ |- n ~ n' : tProd A B] -> + [Γ |- a ≅ a' : A] -> + [Γ |- tApp n a ~ tApp n' a' : B[a..]] + + | neuConvNat {P P' hz hz' hs hs' n n'} : + [Γ |- n ~ n' : tNat] -> + [Γ ,, tNat |- P ≅ P'] -> + [Γ |- hz ≅ hz' : P[tZero..]] -> + [Γ |- hs ≅ hs' : elimSuccHypTy P] -> + [Γ |- tNatElim P hz hs n ~ tNatElim P' hz' hs' n' : P[n..]] + + | neuConvEmpty {P P' e e'} : + [Γ ,, tEmpty |- P ≅ P'] -> + [Γ |- e ~ e' : tEmpty] -> + [Γ |- tEmptyElim P e ~ tEmptyElim P' e' : P[e..]] + + | neuConvFst {A B p p'} : + [Γ |- p ~ p' : tSig A B] -> + [Γ |- tFst p ~ tFst p' : A] + + | neuConvSnd {A B p p'} : + [Γ |- p ~ p' : tSig A B] -> + [Γ |- tSnd p ~ tSnd p' : B[(tFst p)..]] + + | neuConvId {A A' x x' P P' hr hr' y y' e e'} : + [Γ |- A ≅ A'] -> + [Γ |- x ≅ x' : A] -> + [Γ ,, A ,, tId A⟨@wk1 Γ A⟩ x⟨@wk1 Γ A⟩ (tRel 0) |- P ≅ P'] -> + [Γ |- hr ≅ hr' : P[tRefl A x .: x..]] -> + [Γ |- y ≅ y' : A] -> + [Γ |- e ~ e' : tId A x y] -> + [Γ |- tIdElim A x P hr y e ~ tIdElim A' x' P' hr' y' e' : P[e .: y..]] + + | neuConvConv {A B n n'} : + [Γ |- n ~ n' : A] -> + [Γ |- A ≅ B] -> + [Γ |- n ~ n' : B] + + where "[ Γ |- m ~ n : A ]" := (DeclNeutralConversion Γ A m n). + End Definitions. Definition TermRedClosure Γ A t u := RedClosureDecl Γ (isterm A) t u. @@ -341,14 +397,12 @@ Module DeclarativeTypingData. #[export] Instance WfContext_Decl : WfContext de := WfContextDecl. #[export] Instance WfType_Decl : WfType de := WfTypeDecl. - #[export] Instance Typing_Decl : Inferring de := TypingDecl. - #[export] Instance Inferring_Decl : Typing de := TypingDecl. - #[export] Instance InferringRed_Decl : InferringRed de := TypingDecl. + #[export] Instance Typing_Decl : Typing de := TypingDecl. #[export] Instance ConvType_Decl : ConvType de := ConvTypeDecl. #[export] Instance ConvTerm_Decl : ConvTerm de := ConvTermDecl. - #[export] Instance ConvNeuConv_Decl : ConvNeuConv de := ConvNeuConvDecl. #[export] Instance RedType_Decl : RedType de := TypeRedClosure. #[export] Instance RedTerm_Decl : RedTerm de := TermRedClosure. + #[export] Instance ConvNeuConv_Decl : ConvNeuConv de := DeclNeutralConversion. Ltac fold_decl := change WfContextDecl with (wf_context (ta := de)) in * ; @@ -357,12 +411,23 @@ Module DeclarativeTypingData. change ConvTypeDecl with (conv_type (ta := de)) in * ; change ConvTermDecl with (conv_term (ta := de)) in * ; change TypeRedClosure with (red_ty (ta := de)) in *; - change TermRedClosure with (red_tm (ta := de)) in *. + change TermRedClosure with (red_tm (ta := de)) in *; + change DeclNeutralConversion with (conv_neu_ty (ta := de)) in *. Smpl Add fold_decl : refold. End DeclarativeTypingData. +Module WeakDeclarativeTypingData. + + Import DeclarativeTypingData. + #[export] Remove Hints DeclNeutralConversion : typeclass_instances. + #[export] Instance ConvNeuConv_WeakDecl : ConvNeuConv de := WeakDeclNeutralConversion. + +End WeakDeclarativeTypingData. + +Import DeclarativeTypingData. + (** ** Induction principles *) (** We use Scheme to generate mutual induction principle. Sadly, Scheme uses @@ -373,7 +438,6 @@ principle. We also use Ltac to generate the conclusion of the mutual induction proof, to alleviate the user from the need to write it down every time: they only need write the predicates to be proven. *) Section InductionPrinciples. - Import DeclarativeTypingData. Scheme Minimality for WfContextDecl Sort Type with @@ -421,22 +485,94 @@ End InductionPrinciples. Arguments WfDeclInductionConcl PCon PTy PTm PTyEq PTmEq : rename. -(** Typed reduction implies untyped reduction *) -Section TypeErasure. - Import DeclarativeTypingData. +(** ** Generation *) + +(** The generation lemma (the name comes from the PTS literature), gives a +stronger inversion principle on typing derivations, that give direct access +to the last non-conversion rule, and bundle together all conversions. + +Note that because we do not yet know that [Γ |- t : T] implies [Γ |- T], +we cannot use reflexivity in the case where the last rule was not a conversion +one, and we get the slightly clumsy disjunction of either an equality or a +conversion proof. We get a better version of generation later on, once we have +this implication. *) + +Definition termGenData (Γ : context) (t T : term) : Type := + match t with + | tRel n => ∑ decl, [× T = decl, [|- Γ]& in_ctx Γ n decl] + | tProd A B => [× T = U, [Γ |- A : U] & [Γ,, A |- B : U]] + | tLambda A t => ∑ B, [× T = tProd A B, [Γ |- A] & [Γ,, A |- t : B]] + | tApp f a => ∑ A B, [× T = B[a..], [Γ |- f : tProd A B] & [Γ |- a : A]] + | tSort _ => False + | tNat => T = U + | tZero => T = tNat + | tSucc n => T = tNat × [Γ |- n : tNat] + | tNatElim P hz hs n => + [× T = P[n..], [Γ,, tNat |- P], [Γ |- hz : P[tZero..]], [Γ |- hs : elimSuccHypTy P] & [Γ |- n : tNat]] + | tEmpty => T = U + | tEmptyElim P e => + [× T = P[e..], [Γ,, tEmpty |- P] & [Γ |- e : tEmpty]] + | tSig A B => [× T = U, [Γ |- A : U] & [Γ ,, A |- B : U]] + | tPair A B a b => + [× T = tSig A B, [Γ |- A], [Γ,, A |- B], [Γ |- a : A] & [Γ |- b : B[a..]]] + | tFst p => ∑ A B, T = A × [Γ |- p : tSig A B] + | tSnd p => ∑ A B, T = B[(tFst p)..] × [Γ |- p : tSig A B] + | tId A x y => [× T = U, [Γ |- A : U], [Γ |- x : A] & [Γ |- y : A]] + | tRefl A x => [× T = tId A x x, [Γ |- A] & [Γ |- x : A]] + | tIdElim A x P hr y e => + [× T = P[e .: y..], [Γ |- A], [Γ |- x : A], [Γ,, A,, tId A⟨@wk1 Γ A⟩ x⟨@wk1 Γ A⟩ (tRel 0) |- P], [Γ |- hr : P[tRefl A x .: x..]], [Γ |- y : A] & [Γ |- e : tId A x y]] + end. + +(* Use `termGen` from later on instead after this file. *) +Lemma _termGen Γ t A : + [Γ |- t : A] -> + ∑ A', (termGenData Γ t A') × ((A' = A) + [Γ |- A' ≅ A]). +Proof. + induction 1. + all: try (eexists ; split ; [..|left ; reflexivity] ; cbn ; by_prod_splitter). + + destruct IHTypingDecl as [? [? [-> | ]]]. + * prod_splitter; tea; now right. + * prod_splitter; tea; right; now eapply TypeTrans. +Qed. + +Lemma prod_ty_inv Γ A B : + [Γ |- tProd A B] -> + [Γ |- A] × [Γ,, A |- B]. +Proof. + intros Hty. + inversion Hty ; subst ; refold. + - easy. + - eapply _termGen in H as (?&[]&_) ; subst. + split ; now econstructor. +Qed. -Lemma redtmdecl_red Γ t u A : - [Γ |- t ⤳* u : A] -> - [t ⤳* u]. +Lemma sig_ty_inv Γ A B : + [Γ |- tSig A B] -> + [Γ |- A] × [Γ,, A |- B]. Proof. -apply reddecl_red. + intros Hty. + inversion Hty ; subst ; refold. + - easy. + - eapply _termGen in H as (?&[]&_) ; subst. + split ; now econstructor. Qed. -Lemma redtydecl_red Γ A B : - [Γ |- A ⤳* B] -> - [A ⤳* B]. +Lemma id_ty_inv Γ A x y : + [Γ |- tId A x y] -> + [× [Γ |- A], [Γ |- x : A] & [Γ |- y : A]]. Proof. -apply reddecl_red. + intros Hty. + inversion Hty ; subst ; refold. + - easy. + - eapply _termGen in H as (?&[]&_) ; subst. + split ; try easy ; now econstructor. Qed. -End TypeErasure. +Lemma neutral_ty_inv Γ A : + [Γ |- A] -> whne A -> [Γ |- A : U]. +Proof. + intros Hty Hne. + inversion Hty ; subst ; refold. + 1-6: inversion Hne. + easy. +Qed. \ No newline at end of file diff --git a/theories/Fundamental.v b/theories/Fundamental.v index e1657361..aff66e82 100644 --- a/theories/Fundamental.v +++ b/theories/Fundamental.v @@ -1,10 +1,8 @@ (** * LogRel.Fundamental: declarative typing implies the logical relation for any generic instance. *) -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening - DeclarativeTyping GenericTyping LogicalRelation Validity. +From LogRel Require Import Utils Syntax.All GenericTyping DeclarativeTyping LogicalRelation. From LogRel.LogicalRelation Require Import Escape Irrelevance Reflexivity Transitivity Universe Weakening Neutral Induction NormalRed. -From LogRel.Substitution Require Import Irrelevance Properties Conversion Reflexivity SingleSubst Escape. -From LogRel.Substitution.Introductions Require Import Application Universe Pi Lambda Var Nat Empty SimpleArr Sigma Id. +From LogRel.Validity Require Import Validity Irrelevance Properties Conversion Reflexivity SingleSubst Escape. +From LogRel.Validity.Introductions Require Import Application Universe Pi Lambda Var Nat Empty SimpleArr Sigma Id. Set Primitive Projections. Set Universe Polymorphism. diff --git a/theories/GenericTyping.v b/theories/GenericTyping.v index 1d94f460..bee55df0 100644 --- a/theories/GenericTyping.v +++ b/theories/GenericTyping.v @@ -1,7 +1,6 @@ (** * LogRel.GenericTyping: the generic interface of typing used to build the logical relation. *) From Coq Require Import CRelationClasses ssrbool. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening UntypedReduction. +From LogRel Require Import Utils Syntax.All. (** In order to factor the work, the logical relation is defined over a generic notion of typing (and conversion), @@ -399,7 +398,7 @@ Section GenericTyping. Class ConvNeuProperties := { - convneu_equiv {Γ A} :: PER (conv_neu_conv Γ A) ; + convneu_equiv {Γ A} :: PER (conv_neu_ty Γ A) ; convneu_conv {Γ t u A A'} : [Γ |- t ~ u : A] -> [Γ |- A ≅ A'] -> [Γ |- t ~ u : A'] ; convneu_wk {Γ Δ t u A} (ρ : Δ ≤ Γ) : [|- Δ ] -> [Γ |- t ~ u : A] -> [Δ |- t⟨ρ⟩ ~ u⟨ρ⟩ : A⟨ρ⟩] ; @@ -570,7 +569,7 @@ Class GenericTypingProperties `(ta : tag) #[export] Hint Resolve wft_wk wft_U wft_prod wft_sig wft_Id | 2 : gen_typing. #[export] Hint Resolve ty_wk ty_var ty_prod ty_lam ty_app ty_nat ty_empty ty_zero ty_succ ty_natElim ty_emptyElim ty_sig ty_pair ty_fst ty_snd ty_Id ty_refl ty_IdElim| 2 : gen_typing. #[export] Hint Resolve convty_wk convty_uni convty_prod convty_sig convty_Id | 2 : gen_typing. -#[export] Hint Resolve convtm_wk convtm_prod convtm_eta convtm_nat convtm_empty convtm_zero convtm_succ convtm_eta_sig convtm_Id convtm_refl | 2 : gen_typing. +#[export] Hint Resolve convtm_wk convtm_prod convtm_sig convtm_eta convtm_nat convtm_empty convtm_zero convtm_succ convtm_eta_sig convtm_Id convtm_refl | 2 : gen_typing. #[export] Hint Resolve convneu_wk convneu_var convneu_app convneu_natElim convneu_emptyElim convneu_fst convneu_snd convneu_IdElim | 2 : gen_typing. #[export] Hint Resolve redty_ty_src redtm_ty_src | 2 : gen_typing. (* Priority 4 *) @@ -1155,7 +1154,6 @@ Section GenericConsequences. fold ren_term. bsimpl; rewrite scons_eta'; now asimpl. Qed. - Lemma lambda_cong {Γ A A' B B' t t'} : [Γ |- A] -> [Γ |- A'] -> diff --git a/theories/LogicalRelation.v b/theories/LogicalRelation.v index 6f013640..eb877005 100644 --- a/theories/LogicalRelation.v +++ b/theories/LogicalRelation.v @@ -1,7 +1,6 @@ (** * LogRel.LogicalRelation: Definition of the logical relation *) From Coq Require Import CRelationClasses. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening GenericTyping. +From LogRel Require Import Utils Syntax.All GenericTyping. Set Primitive Projections. Set Universe Polymorphism. @@ -1312,14 +1311,4 @@ Ltac unfold_id_outTy := Notation "[ Γ ||-Id< l > A ]" := (IdRedTy Γ l A) (at level 0, Γ, l, A at level 50). Notation "[ Γ ||-Id< l > A ≅ B | RA ]" := (IdRedTyEq (Γ:=Γ) (l:=l) (A:=A) RA B) (at level 0, Γ, l, A, B, RA at level 50). Notation "[ Γ ||-Id< l > t : A | RA ]" := (IdRedTmEq (Γ:=Γ) (l:=l) (A:=A) RA t t) (at level 0, Γ, l, t, A, RA at level 50). -Notation "[ Γ ||-Id< l > t ≅ u : A | RA ]" := (IdRedTmEq (Γ:=Γ) (l:=l) (A:=A) RA t u) (at level 0, Γ, l, t, u, A, RA at level 50). - - - - - - - - - - +Notation "[ Γ ||-Id< l > t ≅ u : A | RA ]" := (IdRedTmEq (Γ:=Γ) (l:=l) (A:=A) RA t u) (at level 0, Γ, l, t, u, A, RA at level 50). \ No newline at end of file diff --git a/theories/LogicalRelation/Application.v b/theories/LogicalRelation/Application.v index 2cf3d22a..af800be4 100644 --- a/theories/LogicalRelation/Application.v +++ b/theories/LogicalRelation/Application.v @@ -1,6 +1,4 @@ - -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening GenericTyping LogicalRelation. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Induction Escape Irrelevance Reflexivity Weakening Neutral Transitivity Reduction NormalRed. Set Universe Polymorphism. diff --git a/theories/LogicalRelation/EqRedRight.v b/theories/LogicalRelation/EqRedRight.v index c4a7abde..8e5bb22f 100644 --- a/theories/LogicalRelation/EqRedRight.v +++ b/theories/LogicalRelation/EqRedRight.v @@ -1,7 +1,6 @@ (** * LogRel.EqRedRight: Reducibility of the rhs of a reducible conversion between types. *) From Coq Require Import CRelationClasses. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms UntypedReduction Weakening GenericTyping LogicalRelation. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Induction Reflexivity Escape Irrelevance Weakening Transitivity Neutral. Set Universe Polymorphism. diff --git a/theories/LogicalRelation/Escape.v b/theories/LogicalRelation/Escape.v index af5cc20f..cbb04385 100644 --- a/theories/LogicalRelation/Escape.v +++ b/theories/LogicalRelation/Escape.v @@ -1,7 +1,6 @@ (** * LogRel.LogicalRelation.Escape: the logical relation implies conversion/typing. *) From Coq Require Import CRelationClasses. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms GenericTyping LogicalRelation. +From LogRel Require Import Utils Syntax.All LogicalRelation GenericTyping. From LogRel.LogicalRelation Require Import Induction. Set Universe Polymorphism. diff --git a/theories/LogicalRelation/Id.v b/theories/LogicalRelation/Id.v index 375b3d68..0a80c824 100644 --- a/theories/LogicalRelation/Id.v +++ b/theories/LogicalRelation/Id.v @@ -1,5 +1,4 @@ -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Notations Utils BasicAst Context NormalForms Weakening GenericTyping LogicalRelation. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Induction Escape Irrelevance Weakening Neutral Reflexivity NormalRed Reduction Transitivity Universe EqRedRight. Set Universe Polymorphism. diff --git a/theories/LogicalRelation/Induction.v b/theories/LogicalRelation/Induction.v index 40831514..bc6ed98a 100644 --- a/theories/LogicalRelation/Induction.v +++ b/theories/LogicalRelation/Induction.v @@ -1,7 +1,5 @@ (** * LogRel.LogicalRelation.Induction: good induction principles for the logical relation. *) -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening UntypedReduction -GenericTyping LogicalRelation. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. Set Universe Polymorphism. diff --git a/theories/LogicalRelation/InstKripke.v b/theories/LogicalRelation/InstKripke.v index d823af15..ede13be9 100644 --- a/theories/LogicalRelation/InstKripke.v +++ b/theories/LogicalRelation/InstKripke.v @@ -1,8 +1,7 @@ (** * LogRel.LogicalRelation.InstKripke: combinators to instantiate Kripke-style quantifications *) -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening - GenericTyping LogicalRelation. -From LogRel.LogicalRelation Require Import Induction Escape Reflexivity Neutral Weakening Irrelevance Application Reduction Transitivity NormalRed EqRedRight. +From Coq Require Import CRelationClasses. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. +From LogRel.LogicalRelation Require Import Induction Escape Reflexivity Neutral Weakening Irrelevance Application Reduction Transitivity NormalRed EqRedRight. Set Universe Polymorphism. Set Printing Primitive Projection Parameters. diff --git a/theories/LogicalRelation/Irrelevance.v b/theories/LogicalRelation/Irrelevance.v index 4e6a578c..ea71b42e 100644 --- a/theories/LogicalRelation/Irrelevance.v +++ b/theories/LogicalRelation/Irrelevance.v @@ -1,7 +1,6 @@ (** * LogRel.LogicalRelation.Irrelevance: symmetry and irrelevance of the logical relation. *) From Coq Require Import CRelationClasses. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Notations Utils BasicAst Context NormalForms Weakening GenericTyping LogicalRelation. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Induction ShapeView Reflexivity Escape. Set Universe Polymorphism. diff --git a/theories/LogicalRelation/Neutral.v b/theories/LogicalRelation/Neutral.v index 97995d9a..918c5c8b 100644 --- a/theories/LogicalRelation/Neutral.v +++ b/theories/LogicalRelation/Neutral.v @@ -1,8 +1,5 @@ -(** * LogRel.Neutral: Reducibility of neutral types and terms. *) -From Coq Require Import CRelationClasses. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms UntypedReduction Weakening GenericTyping LogicalRelation. -From LogRel.LogicalRelation Require Import Induction Reflexivity Escape Irrelevance Transitivity. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. +From LogRel.LogicalRelation Require Import Induction Reflexivity Irrelevance Escape Transitivity. Set Universe Polymorphism. diff --git a/theories/LogicalRelation/NormalRed.v b/theories/LogicalRelation/NormalRed.v index 782a419b..d9267045 100644 --- a/theories/LogicalRelation/NormalRed.v +++ b/theories/LogicalRelation/NormalRed.v @@ -1,7 +1,5 @@ - From Coq Require Import CRelationClasses. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms UntypedReduction Weakening GenericTyping LogicalRelation. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Induction Irrelevance Escape Reflexivity Weakening Neutral Transitivity Reduction EqRedRight. Set Universe Polymorphism. @@ -178,7 +176,7 @@ Ltac normRedΠ id := enough [_ ||-<_> t ≅ u : _ | LRPi' id] by irrelevance end. -(* Normalizes a term reducible at a Π type *) +(* Normalizes a term reducible at a Σ type *) Ltac normRedΣin X := let g := type of X in @@ -195,4 +193,4 @@ Ltac normRedΣin X := let X' := fresh X in rename X into X' ; assert (X : [_ ||-<_> t ≅ u : _ | LRSig' (normRedΣ0 (invLRΣ R))]) by irrelevance; clear X' - end. + end. \ No newline at end of file diff --git a/theories/LogicalRelation/Reduction.v b/theories/LogicalRelation/Reduction.v index c1294c1c..518e7442 100644 --- a/theories/LogicalRelation/Reduction.v +++ b/theories/LogicalRelation/Reduction.v @@ -1,7 +1,5 @@ -From Coq.Classes Require Import CRelationClasses. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Notations Utils BasicAst Context NormalForms UntypedReduction Weakening GenericTyping LogicalRelation. -From LogRel.LogicalRelation Require Import Induction Reflexivity Universe Escape Irrelevance Transitivity. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. +From LogRel.LogicalRelation Require Import Induction Reflexivity Escape Irrelevance Transitivity. Set Universe Polymorphism. diff --git a/theories/LogicalRelation/Reflexivity.v b/theories/LogicalRelation/Reflexivity.v index 45ac10b6..d72e5003 100644 --- a/theories/LogicalRelation/Reflexivity.v +++ b/theories/LogicalRelation/Reflexivity.v @@ -1,6 +1,5 @@ (** * LogRel.LogicalRelation.Reflexivity: reflexivity of the logical relation. *) -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening GenericTyping LogicalRelation. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Induction Escape. Set Universe Polymorphism. diff --git a/theories/LogicalRelation/ShapeView.v b/theories/LogicalRelation/ShapeView.v index 3b97008b..9171e25a 100644 --- a/theories/LogicalRelation/ShapeView.v +++ b/theories/LogicalRelation/ShapeView.v @@ -1,6 +1,5 @@ (** * LogRel.LogicalRelation.ShapeView: relating reducibility witnesses of reducibly convertible types.*) -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Context Notations NormalForms UntypedReduction GenericTyping LogicalRelation. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Induction Reflexivity. Set Universe Polymorphism. diff --git a/theories/LogicalRelation/SimpleArr.v b/theories/LogicalRelation/SimpleArr.v index 2873b349..0e1a7853 100644 --- a/theories/LogicalRelation/SimpleArr.v +++ b/theories/LogicalRelation/SimpleArr.v @@ -1,6 +1,5 @@ -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Notations Utils BasicAst Context NormalForms Weakening GenericTyping LogicalRelation. -From LogRel.LogicalRelation Require Import Induction Escape Irrelevance Weakening Neutral Escape Reflexivity NormalRed Reduction Transitivity Application InstKripke. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. +From LogRel.LogicalRelation Require Import Induction Irrelevance Weakening Neutral Escape Reflexivity NormalRed Reduction Transitivity Application. Set Universe Polymorphism. Set Printing Primitive Projection Parameters. diff --git a/theories/LogicalRelation/Transitivity.v b/theories/LogicalRelation/Transitivity.v index 788f0a8e..ba23e30b 100644 --- a/theories/LogicalRelation/Transitivity.v +++ b/theories/LogicalRelation/Transitivity.v @@ -1,6 +1,5 @@ From Coq Require Import CRelationClasses. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Notations Utils BasicAst Context NormalForms Weakening GenericTyping LogicalRelation. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Induction ShapeView Reflexivity Irrelevance. Set Universe Polymorphism. diff --git a/theories/LogicalRelation/Universe.v b/theories/LogicalRelation/Universe.v index e6db9598..d37061d1 100644 --- a/theories/LogicalRelation/Universe.v +++ b/theories/LogicalRelation/Universe.v @@ -1,5 +1,4 @@ -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening GenericTyping LogicalRelation. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Induction Escape Irrelevance. Set Universe Polymorphism. diff --git a/theories/LogicalRelation/Weakening.v b/theories/LogicalRelation/Weakening.v index 45f5c09e..4e9e4dc7 100644 --- a/theories/LogicalRelation/Weakening.v +++ b/theories/LogicalRelation/Weakening.v @@ -1,6 +1,5 @@ From Coq Require Import ssrbool. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Notations Utils BasicAst Context NormalForms Weakening GenericTyping LogicalRelation. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Induction Irrelevance Transitivity Escape. Set Universe Polymorphism. diff --git a/theories/NormalForms.v b/theories/NormalForms.v deleted file mode 100644 index c12eff72..00000000 --- a/theories/NormalForms.v +++ /dev/null @@ -1,189 +0,0 @@ -(** * LogRel.NormalForms: definition of normal and neutral forms, and properties. *) -From Coq Require Import ssrbool. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Context. - -(** ** Weak-head normal forms and neutrals. *) - -Inductive whnf : term -> Type := - | whnf_tSort {s} : whnf (tSort s) - | whnf_tProd {A B} : whnf (tProd A B) - | whnf_tLambda {A t} : whnf (tLambda A t) - | whnf_tNat : whnf tNat - | whnf_tZero : whnf tZero - | whnf_tSucc {n} : whnf (tSucc n) - | whnf_tEmpty : whnf tEmpty - | whnf_tSig {A B} : whnf (tSig A B) - | whnf_tPair {A B a b} : whnf (tPair A B a b) - | whnf_tId {A x y} : whnf (tId A x y) - | whnf_tRefl {A x} : whnf (tRefl A x) - | whnf_whne {n} : whne n -> whnf n -with whne : term -> Type := - | whne_tRel {v} : whne (tRel v) - | whne_tApp {n t} : whne n -> whne (tApp n t) - | whne_tNatElim {P hz hs n} : whne n -> whne (tNatElim P hz hs n) - | whne_tEmptyElim {P e} : whne e -> whne (tEmptyElim P e) - | whne_tFst {p} : whne p -> whne (tFst p) - | whne_tSnd {p} : whne p -> whne (tSnd p) - | whne_tIdElim {A x P hr y e} : whne e -> whne (tIdElim A x P hr y e). - -#[global] Hint Constructors whne whnf : gen_typing. - -Ltac inv_whne := - repeat lazymatch goal with - | H : whne _ |- _ => - try solve [inversion H] ; block H - end; unblock. - -Lemma neSort s : whne (tSort s) -> False. -Proof. - inversion 1. -Qed. - -Lemma nePi A B : whne (tProd A B) -> False. -Proof. - inversion 1. -Qed. - -Lemma neLambda A t : whne (tLambda A t) -> False. -Proof. - inversion 1. -Qed. - -#[global] Hint Resolve neSort nePi neLambda : gen_typing. - -(** ** Restricted classes of normal forms *) - -Inductive isType : term -> Type := - | UnivType {s} : isType (tSort s) - | ProdType { A B} : isType (tProd A B) - | NatType : isType tNat - | EmptyType : isType tEmpty - | SigType {A B} : isType (tSig A B) - | IdType {A x y} : isType (tId A x y) - | NeType {A} : whne A -> isType A. - -Inductive isPosType : term -> Type := - | UnivPos {s} : isPosType (tSort s) - | NatPos : isPosType tNat - | EmptyPos : isPosType tEmpty - | IdPos {A x y} : isPosType (tId A x y) - | NePos {A} : whne A -> isPosType A. - -Inductive isFun : term -> Type := - | LamFun {A t} : isFun (tLambda A t) - | NeFun {f} : whne f -> isFun f. - -Inductive isNat : term -> Type := - | ZeroNat : isNat tZero - | SuccNat {t} : isNat (tSucc t) - | NeNat {n} : whne n -> isNat n. - -Inductive isPair : term -> Type := - | PairPair {A B a b} : isPair (tPair A B a b) - | NePair {p} : whne p -> isPair p. - -Definition isPosType_isType t (i : isPosType t) : isType t. -Proof. destruct i; now constructor. Defined. - -Coercion isPosType_isType : isPosType >-> isType. - -Definition isType_whnf t (i : isType t) : whnf t. -Proof. destruct i; now constructor. Defined. - -Coercion isType_whnf : isType >-> whnf. - -Definition isFun_whnf t (i : isFun t) : whnf t. -Proof. destruct i; now constructor. Defined. - -Coercion isFun_whnf : isFun >-> whnf. - -Definition isPair_whnf t (i : isPair t) : whnf t. -Proof. destruct i; now constructor. Defined. - -Coercion isPair_whnf : isPair >-> whnf. - -Definition isNat_whnf t (i : isNat t) : whnf t := - match i with - | ZeroNat => whnf_tZero - | SuccNat => whnf_tSucc - | NeNat n => whnf_whne n - end. - -#[global] Hint Resolve isPosType_isType isType_whnf isFun_whnf isNat_whnf isPair_whnf : gen_typing. -#[global] Hint Constructors isPosType isType isFun isNat : gen_typing. - -(** ** Canonical forms *) - -Inductive isCanonical : term -> Type := - | can_tSort {s} : isCanonical (tSort s) - | can_tProd {A B} : isCanonical (tProd A B) - | can_tLambda {A t} : isCanonical (tLambda A t) - | can_tNat : isCanonical tNat - | can_tZero : isCanonical tZero - | can_tSucc {n} : isCanonical (tSucc n) - | can_tEmpty : isCanonical tEmpty - | can_tSig {A B} : isCanonical (tSig A B) - | can_tPair {A B a b}: isCanonical (tPair A B a b) - | can_tId {A x y}: isCanonical (tId A x y) - | can_tRefl {A x}: isCanonical (tRefl A x). - -#[global] Hint Constructors isCanonical : gen_typing. - -(** ** Normal and neutral forms are stable by renaming *) - -Section RenWhnf. - - Variable (ρ : nat -> nat). - - Lemma whne_ren t : whne t -> whne (t⟨ρ⟩). - Proof. - induction 1 ; cbn. - all: now econstructor. - Qed. - - Lemma whnf_ren t : whnf t -> whnf (t⟨ρ⟩). - Proof. - induction 1 ; cbn. - all: econstructor. - now eapply whne_ren. - Qed. - - Lemma isType_ren A : isType A -> isType (A⟨ρ⟩). - Proof. - induction 1 ; cbn. - all: econstructor. - now eapply whne_ren. - Qed. - - Lemma isPosType_ren A : isPosType A -> isPosType (A⟨ρ⟩). - Proof. - destruct 1 ; cbn. - all: econstructor. - now eapply whne_ren. - Qed. - - Lemma isFun_ren f : isFun f -> isFun (f⟨ρ⟩). - Proof. - induction 1 ; cbn. - all: econstructor. - now eapply whne_ren. - Qed. - - Lemma isPair_ren f : isPair f -> isPair (f⟨ρ⟩). - Proof. - induction 1 ; cbn. - all: econstructor. - now eapply whne_ren. - Qed. - - Lemma isCanonical_ren t : isCanonical t <~> isCanonical (t⟨ρ⟩). - Proof. - split. - all: destruct t ; cbn ; inversion 1. - all: now econstructor. - Qed. - -End RenWhnf. - -#[global] Hint Resolve whne_ren whnf_ren isType_ren isPosType_ren isFun_ren isCanonical_ren : gen_typing. diff --git a/theories/Normalisation.v b/theories/Normalisation.v deleted file mode 100644 index 34667ba2..00000000 --- a/theories/Normalisation.v +++ /dev/null @@ -1,216 +0,0 @@ -(** * LogRel.Normalisation: well-typed terms always reduce to a normal form. *) -From Coq Require Import CRelationClasses. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening UntypedReduction - GenericTyping DeclarativeTyping DeclarativeInstance. -From LogRel Require Import LogicalRelation Validity Fundamental. -From LogRel.LogicalRelation Require Import Escape Neutral Induction ShapeView Reflexivity. -From LogRel.Substitution Require Import Escape Poly. - -Record WN (t : term) := { - wn_val : term; - wn_red : [ t ⤳* wn_val ]; - wn_whnf : whnf wn_val; -}. - -Lemma WN_wk : forall t (ρ : nat -> nat), WN t -> WN t⟨ρ⟩. -Proof. -intros * [r]. -exists r⟨ρ⟩. -+ now apply credalg_wk. -+ now apply whnf_ren. -Qed. - -Lemma WN_exp : forall t u, [t ⤳* u] -> WN u -> WN t. -Proof. -intros t u ? [r]. -exists r; tea. -now etransitivity. -Qed. - -Lemma WN_whnf : forall t, whnf t -> WN t. -Proof. -intros; exists t; tea. -reflexivity. -Qed. - -Lemma WN_isFun : forall t, isFun t -> WN t. -Proof. -intros t []; apply WN_whnf; now constructor. -Qed. - -Lemma WN_isPair : forall t, isPair t -> WN t. -Proof. -intros t []; apply WN_whnf; now constructor. -Qed. - -Module Nf. - -Definition nf : tag. -Proof. -constructor. -Qed. - -#[export] Instance WfContextNf : WfContext nf := fun Γ => True. -#[export] Instance WfTypeNf : WfType nf := fun Γ A => True. -#[export] Instance TypingNf : Typing nf := fun Γ A t => True. -#[export] Instance ConvTypeNf : ConvType nf := fun Γ A B => WN A × WN B. -#[export] Instance ConvTermNf : ConvTerm nf := fun Γ A t u => WN t × WN u. -#[export] Instance ConvNeuConvNf : ConvNeuConv nf := fun Γ A m n => whne m × whne n. -#[export] Instance RedTypeNf : RedType nf := fun Γ A B => [A ⤳* B]. -#[export] Instance RedTermNf : RedTerm nf := fun Γ A t u => [t ⤳* u]. - -#[export, refine] Instance WfCtxDeclProperties : WfContextProperties (ta := nf) := {}. -Proof. -all: try constructor. -Qed. - -#[export, refine] Instance WfTypeDeclProperties : WfTypeProperties (ta := nf) := {}. -Proof. -all: try constructor. -Qed. - -#[export, refine] Instance TypingDeclProperties : TypingProperties (ta := nf) := {}. -Proof. -all: try constructor. -Qed. - -#[export, refine] Instance ConvTypeDeclProperties : ConvTypeProperties (ta := nf) := {}. -Proof. -all: try (intros; split; apply WN_whnf; now constructor). -+ intros * []; now split. -+ intros; split. - - intros t u []; now split. - - intros t u v [] []; now split. -+ intros * ? []; split; now apply WN_wk. -+ intros * ? ? []; split; now eapply WN_exp. -Qed. - -#[export, refine] Instance ConvTermDeclProperties : ConvTermProperties (ta := nf) := {}. -Proof. -all: try (intros; split; apply WN_whnf; now constructor). -+ intros; split. - - intros t u []; now split. - - intros t u v [] []; now split. -+ intros * [] ?; now split. -+ intros * ? []; split; now apply WN_wk. -+ intros * ? ? ? ? ? ? []; split; now eapply WN_exp. -+ intros * ? []; split; now apply WN_whnf, whnf_whne. -+ intros * ? ? ? Hf ? Hg []; split. - - apply WN_isFun; destruct Hf as [|? []]; now constructor. - - apply WN_isFun; destruct Hg as [|? []]; now constructor. -+ intros * ? ? ? Hp ? Hp' ?; split; apply WN_isPair. - - destruct Hp as [|? []]; now constructor. - - destruct Hp' as [|? []]; now constructor. -Qed. - -#[export, refine] Instance ConvNeuDeclProperties : ConvNeuProperties (ta := nf) := {}. -Proof. -+ intros; split. - - intros t u []; now split. - - intros t u v [] []; now split. -+ intros * [] ?; now split. -+ intros * ? []; split; now apply whne_ren. -+ intros * []; assumption. -+ intros; split; constructor. -+ intros * [] ?; split; now constructor. -+ intros * ? ? ? []; split; now constructor. -+ intros * ? []; split; now constructor. -+ intros * []; split; now constructor. -+ intros * []; split; now constructor. -+ intros * ??????? []; split; now constructor. -Qed. - -#[export, refine] Instance RedTermDeclProperties : RedTermProperties (ta := nf) := {}. -Proof. -all: try now (intros; apply redalg_one_step; constructor). -+ intros; now apply credalg_wk. -+ intros; eassumption. -+ now constructor. -+ intros; now apply redalg_app. -+ intros; now apply redalg_natElim. -+ intros; now apply redalg_natEmpty. -+ intros; now apply redalg_fst. -+ intros; now apply redalg_snd. -+ intros; now eapply redalg_idElim. -+ intros; assumption. -+ intros; reflexivity. -Qed. - -#[export, refine] Instance RedTypeDeclProperties : RedTypeProperties (ta := nf) := {}. -Proof. -all: try now intros; eassumption. -+ intros; now apply credalg_wk. -+ constructor. -+ intros; reflexivity. -Qed. - -#[export] Instance DeclarativeTypingProperties : GenericTypingProperties nf _ _ _ _ _ _ _ _ _ _ := {}. - -End Nf. - -Section Normalisation. - - Import Nf. - - Theorem typing_nf : WfDeclInductionConcl - (fun _ => True) - (fun Γ A => True) - (fun Γ A t => True) - (fun Γ A B => WN A × WN B) - (fun Γ A t u => WN t × WN u). - Proof. - red. - prod_splitter. - all: intros * H%Fundamental. - - constructor. - - constructor. - - constructor. - - destruct H as [? ? ? H]. - apply escapeEq in H as []; now split. - - destruct H as [? ? H]. - apply escapeTmEq in H as []; now split. - Qed. - - Import DeclarativeTypingData. - - Corollary normalisation {Γ A t} : [Γ |-[de] t : A] -> WN t. - Proof. now intros ?%TermRefl%typing_nf. Qed. - - Corollary type_normalisation {Γ A} : [Γ |-[de] A] -> WN A. - Proof. now intros ?%TypeRefl%typing_nf. Qed. - -End Normalisation. - -Import DeclarativeTypingProperties. - -Record cored t t' : Prop := { _ : [t' ⤳ t] }. - -Theorem typing_SN Γ t : - well_formed Γ t -> - Acc cored t. -Proof. - intros [[] Hty]. - all: first [apply TypeRefl in Hty|apply TermRefl in Hty]. - all: eapply typing_nf in Hty as [? _]. - all: pose proof w as [wh red]. - all: induction red. - - econstructor. - intros t' [red]. - exfalso. - eapply whnf_nored ; tea. - - econstructor. - intros t'' [red']. - eapply ored_det in red' as <-; [|exact o]. - apply IHred; tea. - eapply WN_exp; [tea|]; now apply WN_whnf. - - econstructor. - intros t' [red]. - exfalso. - now eapply whnf_nored. - - econstructor. - intros t'' [red']. - eapply ored_det in red' as <-; [|exact o]. - apply IHred; tea. - eapply WN_exp; [tea|]; now apply WN_whnf. -Qed. \ No newline at end of file diff --git a/theories/Positivity.agda b/theories/Positivity.agda deleted file mode 100644 index 1c51f9cd..00000000 --- a/theories/Positivity.agda +++ /dev/null @@ -1,4 +0,0 @@ -record Foo (x : Set -> Set) : Set where - -data Bar : Set -> Set where - bar : Bar (Foo Bar) diff --git a/theories/Syntax/All.v b/theories/Syntax/All.v new file mode 100644 index 00000000..004ddb81 --- /dev/null +++ b/theories/Syntax/All.v @@ -0,0 +1,2 @@ +From LogRel Require Export AutoSubst.Extra. +From LogRel.Syntax Require Export BasicAst Context Notations NormalForms Weakening UntypedReduction. \ No newline at end of file diff --git a/theories/BasicAst.v b/theories/Syntax/BasicAst.v similarity index 68% rename from theories/BasicAst.v rename to theories/Syntax/BasicAst.v index 63071316..f9521baa 100644 --- a/theories/BasicAst.v +++ b/theories/Syntax/BasicAst.v @@ -1,6 +1,4 @@ (** * LogRel.BasicAst: definitions preceding those of the AST of terms: sorts, binder annotations… *) -From Coq Require Import String Bool. -From LogRel.AutoSubst Require Import core unscoped. Inductive sort : Set := | set : sort. diff --git a/theories/Context.v b/theories/Syntax/Context.v similarity index 90% rename from theories/Context.v rename to theories/Syntax/Context.v index b52f44b3..20c86e85 100644 --- a/theories/Context.v +++ b/theories/Syntax/Context.v @@ -1,7 +1,6 @@ (** * LogRel.Context: definition of contexts and operations on them.*) From Coq Require Import ssreflect Morphisms Setoid. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst. +From LogRel Require Import Utils BasicAst AutoSubst.Extra. Set Primitive Projections. diff --git a/theories/Syntax/NormalForms.v b/theories/Syntax/NormalForms.v new file mode 100644 index 00000000..018cfe05 --- /dev/null +++ b/theories/Syntax/NormalForms.v @@ -0,0 +1,321 @@ +(** * LogRel.NormalForms: definition of normal and neutral forms, and properties. *) +From Coq Require Import ssrbool. +From Equations Require Import Equations. (* for depelim *) +From LogRel Require Import AutoSubst.Extra Utils. +From LogRel.Syntax Require Import BasicAst Context. + +(** ** Weak-head normal forms and neutrals. *) + +Inductive whnf : term -> Type := + | whnf_tSort {s} : whnf (tSort s) + | whnf_tProd {A B} : whnf (tProd A B) + | whnf_tLambda {A t} : whnf (tLambda A t) + | whnf_tNat : whnf tNat + | whnf_tZero : whnf tZero + | whnf_tSucc {n} : whnf (tSucc n) + | whnf_tEmpty : whnf tEmpty + | whnf_tSig {A B} : whnf (tSig A B) + | whnf_tPair {A B a b} : whnf (tPair A B a b) + | whnf_tId {A x y} : whnf (tId A x y) + | whnf_tRefl {A x} : whnf (tRefl A x) + | whnf_whne {n} : whne n -> whnf n +with whne : term -> Type := + | whne_tRel {v} : whne (tRel v) + | whne_tApp {n t} : whne n -> whne (tApp n t) + | whne_tNatElim {P hz hs n} : whne n -> whne (tNatElim P hz hs n) + | whne_tEmptyElim {P e} : whne e -> whne (tEmptyElim P e) + | whne_tFst {p} : whne p -> whne (tFst p) + | whne_tSnd {p} : whne p -> whne (tSnd p) + | whne_tIdElim {A x P hr y e} : whne e -> whne (tIdElim A x P hr y e). + +#[global] Hint Constructors whne whnf : gen_typing. + +Ltac inv_whne := + repeat lazymatch goal with + | H : whne _ |- _ => + try solve [inversion H] ; block H + end; unblock. + +Lemma neSort s : whne (tSort s) -> False. +Proof. + inversion 1. +Qed. + +Lemma nePi A B : whne (tProd A B) -> False. +Proof. + inversion 1. +Qed. + +Lemma neLambda A t : whne (tLambda A t) -> False. +Proof. + inversion 1. +Qed. + +#[global] Hint Resolve neSort nePi neLambda : gen_typing. + +(** ** Restricted classes of normal forms *) + +Inductive isType : term -> Type := + | UnivType {s} : isType (tSort s) + | ProdType { A B} : isType (tProd A B) + | NatType : isType tNat + | EmptyType : isType tEmpty + | SigType {A B} : isType (tSig A B) + | IdType {A x y} : isType (tId A x y) + | NeType {A} : whne A -> isType A. + +Inductive isPosType : term -> Type := + | UnivPos {s} : isPosType (tSort s) + | NatPos : isPosType tNat + | EmptyPos : isPosType tEmpty + | IdPos {A x y} : isPosType (tId A x y) + | NePos {A} : whne A -> isPosType A. + +Inductive isFun : term -> Type := + | LamFun {A t} : isFun (tLambda A t) + | NeFun {f} : whne f -> isFun f. + +Inductive isNat : term -> Type := + | ZeroNat : isNat tZero + | SuccNat {t} : isNat (tSucc t) + | NeNat {n} : whne n -> isNat n. + +Inductive isPair : term -> Type := + | PairPair {A B a b} : isPair (tPair A B a b) + | NePair {p} : whne p -> isPair p. + +Inductive isId : term -> Type := + | ReflId {A a} : isId (tRefl A a) + | NeId {n} : whne n -> isId n. + +Definition isPosType_isType t (i : isPosType t) : isType t. +Proof. destruct i; now constructor. Defined. + +Coercion isPosType_isType : isPosType >-> isType. + +Definition isType_whnf t (i : isType t) : whnf t. +Proof. destruct i; now constructor. Defined. + +Coercion isType_whnf : isType >-> whnf. + +Definition isFun_whnf t (i : isFun t) : whnf t. +Proof. destruct i; now constructor. Defined. + +Coercion isFun_whnf : isFun >-> whnf. + +Definition isPair_whnf t (i : isPair t) : whnf t. +Proof. destruct i; now constructor. Defined. + +Coercion isPair_whnf : isPair >-> whnf. + +Definition isNat_whnf t (i : isNat t) : whnf t := + match i with + | ZeroNat => whnf_tZero + | SuccNat => whnf_tSucc + | NeNat n => whnf_whne n + end. + +Definition isId_whnf t (i : isId t) : whnf t := + match i with + | ReflId => whnf_tRefl + | NeId n => whnf_whne n + end. + +#[global] Hint Resolve isPosType_isType isType_whnf isFun_whnf isNat_whnf isPair_whnf isId_whnf : gen_typing. +#[global] Hint Constructors isPosType isType isFun isNat isId : gen_typing. + +Equations Derive Signature for isNat. + +Lemma isNat_zero (n : isNat tZero) : n = ZeroNat. +Proof. + depelim n. + 1: easy. + inversion w. +Qed. + +Lemma isNat_succ t (n : isNat (tSucc t)) : n = SuccNat. +Proof. + depelim n. + 1: easy. + inversion w. +Qed. + +Lemma isNat_ne t (n : isNat t) : whne t -> ∑ w, n = NeNat w. +Proof. + intros w. + depelim n. + 1-2: now inversion w. + now eexists. +Qed. + +Derive Signature for isId. + +Lemma isId_refl A a (n : isId (tRefl A a)) : n = ReflId. +Proof. + depelim n. + 1: reflexivity. + inversion w ; cbn ; easy. +Qed. + +Lemma isId_ne t (n : isId t) : whne t -> ∑ w, n = NeId w. +Proof. + intros w. + dependent inversion n ; subst. + 1: inversion w. + now eexists. +Qed. + +(** ** Canonical forms *) + +Inductive isCanonical : term -> Type := + | can_tSort {s} : isCanonical (tSort s) + | can_tProd {A B} : isCanonical (tProd A B) + | can_tLambda {A t} : isCanonical (tLambda A t) + | can_tNat : isCanonical tNat + | can_tZero : isCanonical tZero + | can_tSucc {n} : isCanonical (tSucc n) + | can_tEmpty : isCanonical tEmpty + | can_tSig {A B} : isCanonical (tSig A B) + | can_tPair {A B a b}: isCanonical (tPair A B a b) + | can_tId {A x y}: isCanonical (tId A x y) + | can_tRefl {A x}: isCanonical (tRefl A x). + +#[global] Hint Constructors isCanonical : gen_typing. + +Lemma can_whne_exclusive t : isCanonical t -> whne t -> False. +Proof. + intros Hcan Hne. + inversion Hcan ; subst ; inversion Hne. +Qed. + +Lemma whnf_can_whne t : whnf t -> isCanonical t + whne t. +Proof. + intros []. + all: try solve [left ; now constructor | now right]. +Qed. + +Lemma not_can_whne t : whnf t -> ~ isCanonical t -> whne t. +Proof. + intros []%whnf_can_whne ; eauto. + now intros []. +Qed. + +Lemma not_whne_can t : whnf t -> ~ whne t -> isCanonical t. +Proof. + intros []%whnf_can_whne ; eauto. + now intros []. +Qed. + +(** ** Normal and neutral forms are stable by renaming *) + +Section RenWhnf. + + #[local] Ltac push_renaming := + repeat match goal with + | eq : _ = ?t⟨_⟩ |- _ => + destruct t ; cbn in * ; try solve [congruence] ; + inversion eq ; subst ; clear eq + end. + + Variable (ρ : nat -> nat). + + Lemma whne_ren t : whne (t⟨ρ⟩) <~> whne t. + Proof. + split. + - remember t⟨ρ⟩ as t'. + intros Hne. + induction Hne in t, Heqt' |- * ; cbn. + all: push_renaming ; econstructor ; eauto. + - induction 1 ; cbn. + all: now econstructor. + Qed. + + Lemma whnf_ren t : whnf (t⟨ρ⟩) <~> whnf t. + Proof. + split. + - remember t⟨ρ⟩ as t'. + intros Hnf. + induction Hnf in t, Heqt' |- * ; cbn. + all: push_renaming ; econstructor ; eauto. + all: now eapply whne_ren ; cbn. + - induction 1 ; cbn. + all: econstructor. + now eapply whne_ren. + Qed. + + Lemma isType_ren A : isType (A⟨ρ⟩) <~> isType A. + Proof. + split. + - remember A⟨ρ⟩ as A'. + intros Hty. + induction Hty in A, HeqA' |- * ; cbn. + all: push_renaming ; econstructor ; eauto. + all: now eapply whne_ren ; cbn. + - induction 1 ; cbn. + all: econstructor. + now eapply whne_ren. + Qed. + + Lemma isPosType_ren A : isPosType (A⟨ρ⟩) <~> isPosType A. + Proof. + split. + - remember A⟨ρ⟩ as A'. + intros Hty. + induction Hty in A, HeqA' |- * ; cbn. + all: push_renaming ; econstructor ; eauto. + all: now eapply whne_ren ; cbn. + - induction 1 ; cbn. + all: econstructor. + now eapply whne_ren. + Qed. + + Lemma isFun_ren f : isFun (f⟨ρ⟩) <~> isFun f. + Proof. + split. + - remember f⟨ρ⟩ as f'. + intros Hfun. + induction Hfun in f, Heqf' |- * ; cbn. + all: push_renaming ; econstructor ; eauto. + all: now eapply whne_ren ; cbn. + - induction 1 ; cbn. + all: econstructor. + now eapply whne_ren. + Qed. + + + Lemma isPair_ren p : isPair (p⟨ρ⟩) <~> isPair p. + Proof. + split. + - remember p⟨ρ⟩ as p'. + intros Hpair. + induction Hpair in p, Heqp' |- * ; cbn. + all: push_renaming ; econstructor ; eauto. + all: now eapply whne_ren ; cbn. + - induction 1 ; cbn. + all: econstructor. + now eapply whne_ren. + Qed. + + Lemma isId_ren p : isId (p⟨ρ⟩) <~> isId p. + Proof. + split. + - remember p⟨ρ⟩ as p'. + intros Hid. + induction Hid in p, Heqp' |- * ; cbn. + all: push_renaming ; econstructor ; eauto. + all: now eapply whne_ren ; cbn. + - induction 1 ; cbn. + all: econstructor. + now eapply whne_ren. + Qed. + + Lemma isCanonical_ren t : isCanonical (t⟨ρ⟩) <~> isCanonical t. + Proof. + split. + all: destruct t ; cbn ; inversion 1. + all: now econstructor. + Qed. + +End RenWhnf. + +#[global] Hint Resolve whne_ren whnf_ren isType_ren isPosType_ren isFun_ren isId_ren isCanonical_ren : gen_typing. \ No newline at end of file diff --git a/theories/Notations.v b/theories/Syntax/Notations.v similarity index 96% rename from theories/Notations.v rename to theories/Syntax/Notations.v index 46bfc97c..8a60d495 100644 --- a/theories/Notations.v +++ b/theories/Syntax/Notations.v @@ -1,5 +1,6 @@ (** * LogRel.Notations: notations for conversion, typing and the logical relations. *) -From LogRel Require Import Utils BasicAst Context. +From LogRel Require Import Utils. +From LogRel.Syntax Require Import BasicAst Context. From LogRel.AutoSubst Require Import Ast. (** We have several families of definitions. We discriminate them by using an opaque tag as a phantom type. @@ -33,7 +34,7 @@ Class ConvTerm (ta : tag) := conv_term : context -> term -> term -> term -> Set. Class ConvTermRed (ta : tag) := conv_term_red : context -> term -> term -> term -> Set. Class ConvNeu (ta : tag) := conv_neu : context -> term -> term -> term -> Set. Class ConvNeuRed (ta : tag) := conv_neu_red : context -> term -> term -> term -> Set. -Class ConvNeuConv (ta : tag) := conv_neu_conv : context -> term -> term -> term -> Set. +Class ConvNeuConv (ta : tag) := conv_neu_ty : context -> term -> term -> term -> Set. (** The context Γ is well-formed *) Notation "[ |- Γ ]" := (wf_context Γ) @@ -93,11 +94,21 @@ Notation "[ Γ |-[ ta ] n ~ n' ▹ A ]" := (conv_neu (ta := ta) Γ A n n') Notation "[ Γ |- n '~h' n' ▹ A ]" := (conv_neu_red Γ A n n') (at level 0, Γ, n, n', A at level 50, only parsing) : typing_scope. Notation "[ Γ |-[ ta ] n '~h' n' ▹ A ]" := (conv_neu_red (ta := ta) Γ A n n') (at level 0, ta, Γ, n, n', A at level 50) : typing_scope. (** Neutral n and n' are convertible in Γ at type A *) -Notation "[ Γ |- n ~ n' : A ]" := (conv_neu_conv Γ A n n') +Notation "[ Γ |- n ~ n' : A ]" := (conv_neu_ty Γ A n n') (at level 0, Γ, n, n', A at level 50, only parsing) : typing_scope. -Notation "[ Γ |-[ ta ] n ~ n' : A ]" := (conv_neu_conv (ta := ta) Γ A n n') +Notation "[ Γ |-[ ta ] n ~ n' : A ]" := (conv_neu_ty (ta := ta) Γ A n n') (at level 0, ta, Γ, n, n', A at level 50) : typing_scope. +(** ** Untyped Conversion *) + +(** Types/terms t and u are convertible *) +Reserved Notation "[ t ≅ u ]" (at level 0, t, u at level 50). +(** Types/terms in whnf t and u are convertible *) +Reserved Notation "[ t '≅h' u ]" (at level 0, t, u at level 50). +(** Neutrals n and n' are convertible *) +Reserved Notation "[ n ~ n' ]" (at level 0, n, n' at level 50). + + (** ** Reductions *) Class RedType (ta : tag) := red_ty : context -> term -> term -> Set. Class OneStepRedTerm (ta : tag) := osred_tm : context -> term -> term -> term -> Set. diff --git a/theories/Syntax/Sections.v b/theories/Syntax/Sections.v new file mode 100644 index 00000000..e7bb548d --- /dev/null +++ b/theories/Syntax/Sections.v @@ -0,0 +1,82 @@ +From Coq Require Import Nat Morphisms. +From LogRel Require Import Utils AutoSubst.Extra. +From LogRel.Syntax Require Import Weakening. + +Arguments id {_} _/. +Arguments Datatypes.id {_} _/. +Arguments funcomp {X Y Z}%_type_scope (g f)%_function_scope _/. + +Record section {A B : Type} {f : A -> B} := + { sec_fun :> B -> A ; sec_ok : f >> sec_fun =1 id }. + +Arguments section {_ _} _. + +Lemma section_inj {A B} (f : A -> B) (x x' : A) : + section f -> + f x = f x' -> + x = x'. +Proof. + intros [? sec] ? ; red in sec ; cbn in *. + rewrite <- (sec x), <- (sec x'). + now f_equal. +Qed. + +Lemma section_id {A : Type} : section (@id A). +Proof. + exists id. + reflexivity. +Qed. + +Lemma section_compose {A B C : Type} (f : A -> B) (g : B -> C) : + section f -> section g -> section (f >> g). +Proof. + intros [f' Hf] [g' Hg]. + exists (g' >> f'). + intros ?. + red in Hf, Hg ; cbn in *. + now rewrite Hg, Hf. +Qed. + +Lemma section_S : section S. +Proof. + exists pred. + reflexivity. +Qed. + +Lemma section_up f : section f -> section (up_ren f). +Proof. + intros [f' Hf]. + exists (up_ren f'). + intros [] ; cbn. + 1: reflexivity. + red in Hf ; cbn in *. + now rewrite Hf. +Qed. + +Theorem section_wk {Γ Δ} (ρ : Γ ≤ Δ) : section ρ. +Proof. + destruct ρ as [ρ Hρ]. + induction Hρ ; cbn in *. + - apply section_id. + - apply section_compose ; tea. + apply section_S. + - now apply section_up. +Defined. + +Notation "ρ ⁻¹" := (section_wk ρ) (at level 80). + +#[global] Instance Ren1_sec {Y Z : Type} {f : nat -> nat} `(ren : Ren1 (nat -> nat) Y Z) : + (Ren1 (section f) Y Z) := fun s t => t⟨s.(sec_fun)⟩. + +Arguments Ren1_sec {_ _ _} _ _/. + +Lemma wk_section {Γ Δ} (ρ : Γ ≤ Δ) (t : term) : + t⟨ρ⟩⟨ρ⁻¹⟩ = t. +Proof. + asimpl. + etransitivity. + 2: apply rinstId'_term. + eapply extRen_term. + cbn. + apply (ρ⁻¹). +Qed. \ No newline at end of file diff --git a/theories/TermNotations.v b/theories/Syntax/TermNotations.v similarity index 97% rename from theories/TermNotations.v rename to theories/Syntax/TermNotations.v index 4d751a66..0d9e289e 100644 --- a/theories/TermNotations.v +++ b/theories/Syntax/TermNotations.v @@ -1,6 +1,6 @@ -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils Notations BasicAst Context. +From LogRel Require Import Utils AutoSubst.Extra. +From LogRel.Syntax Require Import Notations BasicAst Context. (** Custom notation for contexts *) Declare Custom Entry mlttctx. diff --git a/theories/UntypedReduction.v b/theories/Syntax/UntypedReduction.v similarity index 68% rename from theories/UntypedReduction.v rename to theories/Syntax/UntypedReduction.v index 7aacc6ad..069ec4de 100644 --- a/theories/UntypedReduction.v +++ b/theories/Syntax/UntypedReduction.v @@ -1,7 +1,7 @@ (** * LogRel.UntypedReduction: untyped reduction, used to define algorithmic typing.*) From Coq Require Import CRelationClasses. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening. +From LogRel Require Import Utils AutoSubst.Extra. +From LogRel.Syntax Require Import BasicAst Notations Context NormalForms Weakening. (** ** Reductions *) @@ -64,6 +64,12 @@ Inductive RedClosureAlg : term -> term -> Type := now econstructor. Qed. +(** *** Co-reduction *) +(** The symmetric of reduction, in Prop. The well-founded relation on which the reduction + machine operates. *) + +Record cored t t' : Prop := { _ : [t' ⤳ t] }. + (** ** Properties *) (** *** Weak-head normal forms do not reduce *) @@ -186,7 +192,7 @@ Lemma oredalg_wk (ρ : nat -> nat) (t u : term) : Proof. intros Hred. induction Hred in ρ |- *. - 2-5,6-12: cbn; asimpl; now econstructor. + 2-12: cbn; asimpl; now econstructor. - cbn ; asimpl. evar (t' : term). replace (subst_term _ t) with t'. @@ -195,6 +201,22 @@ Proof. now asimpl. Qed. +Lemma oredalg_str (Γ Δ : context) (ρ : Δ ≤ Γ) (t u : term) : + [t⟨ρ⟩ ⤳ u] -> + ∑ u', u = u'⟨ρ⟩ × [t ⤳ u']. +Proof. + intros Hred. + remember t⟨ρ⟩ as t' eqn:eqt in *. + induction Hred in t, eqt |- *. + all: repeat match goal with + | eq : _ = ?t⟨_⟩ |- _ => + destruct t ; cbn in * ; try solve [congruence] ; + inversion eq ; subst ; clear eq + end. + all: try (edestruct IHHred as [? [->]]; [reflexivity|..]). + all: eexists ; split ; cycle -1 ; [now econstructor | now bsimpl]. +Qed. + Lemma credalg_wk (ρ : nat -> nat) (t u : term) : [t ⤳* u] -> [t⟨ρ⟩ ⤳* u⟨ρ⟩]. @@ -202,6 +224,22 @@ Proof. induction 1 ; econstructor ; eauto using oredalg_wk. Qed. +Lemma credalg_str (Γ Δ : context) (ρ : Δ ≤ Γ) (t u : term) : + [t⟨ρ⟩ ⤳* u] -> + ∑ u', u = u'⟨ρ⟩ × [t ⤳* u']. +Proof. + intros Hred. + remember t⟨ρ⟩ as t' eqn:eqt in *. + induction Hred in t, eqt |- *. + - eexists ; split ; tea. + now constructor. + - subst. + eapply oredalg_str in o as [? [-> ]]. + edestruct IHHred as [? [->]]; [reflexivity|..]. + eexists ; split ; [reflexivity|..]. + now econstructor. +Qed. + (** Derived rules *) Lemma redalg_app {t t' u} : [t ⤳* t'] -> [tApp t u ⤳* tApp t' u]. @@ -247,4 +285,71 @@ Proof. Qed. Lemma redalg_one_step {t t'} : [t ⤳ t'] -> [t ⤳* t']. -Proof. intros; econstructor;[tea|reflexivity]. Qed. \ No newline at end of file +Proof. intros; econstructor;[tea|reflexivity]. Qed. + +Lemma eta_expand_beta {A t} : [(eta_expand (tLambda A t)) ⤳ t]. +Proof. + cbn. + evar (t' : term). + replace t with t' at 2 ; subst t'. + 1: econstructor. + substify. + asimpl. + rewrite scons_eta'. + now asimpl. +Qed. + +Lemma eta_expand_beta_inv {A t t'} : + [tApp (tLambda A t)⟨↑⟩ (tRel 0) ⤳* t'] -> + whnf t' -> + [t ⤳* t']. +Proof. + intros red nf. + inversion red ; subst ; clear red. + - exfalso. + inversion nf ; subst ; clear nf. + inversion H ; subst ; clear H. + inversion H1 ; subst ; clear H1. + - inversion H ; subst. + 2: now inversion H4. + refold. + replace (_[_]) with t in H0. + 1: now assumption. + bsimpl. + rewrite scons_eta'. + now bsimpl. +Qed. + + +Lemma eta_expand_fst_inv {A B t u t'} : + [tFst (tPair A B t u) ⤳* t'] -> + whnf t' -> + [t ⤳* t']. +Proof. + intros red nf. + inversion red ; subst ; clear red. + - exfalso. + inversion nf ; subst ; clear nf. + inversion H ; subst ; clear H. + inversion H1 ; subst ; clear H1. + - inversion H ; subst. + 1: now inversion H2. + eassumption. +Qed. + + +Lemma eta_expand_snd_inv {A B t u u'} : + [tSnd (tPair A B t u) ⤳* u'] -> + whnf u' -> + [u ⤳* u']. +Proof. + intros red nf. + inversion red ; subst ; clear red. + - exfalso. + inversion nf ; subst ; clear nf. + inversion H ; subst ; clear H. + inversion H1 ; subst ; clear H1. + - inversion H ; subst. + 1: now inversion H2. + eassumption. +Qed. \ No newline at end of file diff --git a/theories/Weakening.v b/theories/Syntax/Weakening.v similarity index 87% rename from theories/Weakening.v rename to theories/Syntax/Weakening.v index af037e03..36248d5a 100644 --- a/theories/Weakening.v +++ b/theories/Syntax/Weakening.v @@ -1,7 +1,7 @@ (** * LogRel.Weakening: definition of well-formed weakenings, and some properties. *) From Coq Require Import Lia ssrbool. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms. +From LogRel Require Import Utils AutoSubst.Extra. +From LogRel.Syntax Require Import BasicAst Notations Context NormalForms. (** ** Raw weakenings *) @@ -39,6 +39,14 @@ Qed. Coercion wk_to_ren : weakening >-> Funclass. + +(** ** Instance: how to rename by a well-formed weakening. *) + +#[global] Instance Ren1_wk {Y Z : Type} `(ren : Ren1 (nat -> nat) Y Z) : +(Ren1 weakening Y Z) := fun ρ t => t⟨wk_to_ren ρ⟩. + +Arguments Ren1_wk {_ _ _} _ _/. + Fixpoint wk_compose (ρ ρ' : weakening) : weakening := match ρ, ρ' with | _wk_empty , _ => ρ' @@ -77,7 +85,7 @@ Inductive well_weakening : weakening -> context -> context -> Type := | well_step {Γ Δ : context} (A : term) (ρ : weakening) : well_weakening ρ Γ Δ -> well_weakening (_wk_step ρ) (Γ,, A) Δ | well_up {Γ Δ : context} (A : term) (ρ : weakening) : - well_weakening ρ Γ Δ -> well_weakening (_wk_up ρ) (Γ,, ren_term ρ A) (Δ,, A). + well_weakening ρ Γ Δ -> well_weakening (_wk_up ρ) (Γ,, A⟨ρ⟩) (Δ,, A). Lemma well_wk_id (Γ : context) : well_weakening (_wk_id Γ) Γ Γ. Proof. @@ -101,9 +109,9 @@ Proof. - econstructor. auto. - inversion H' as [| | ? ? A' ν']; subst ; clear H'. 1: now econstructor ; auto. - asimpl. - replace (ren_term (ν' >> ν) A') with (ren_term (wk_compose ν ν') A') - by now rewrite wk_compose_compose. + asimpl ; refold. + erewrite extRen_term ; refold. + 2: symmetry ; now apply wk_compose_compose. econstructor ; auto. Qed. @@ -115,16 +123,12 @@ Notation "Γ ≤ Δ" := (wk_well_wk Γ Δ). #[global] Hint Resolve well_wk : core. -(** ** Instances: how to rename by a weakening. *) - -#[global] Instance Ren1_wk {Y Z : Type} `(ren : Ren1 (nat -> nat) Y Z) : - (Ren1 weakening Y Z) := fun ρ t => t⟨wk_to_ren ρ⟩. +(** ** Instance: how to rename by a well-formed weakening. *) #[global] Instance Ren1_well_wk {Y Z : Type} `{Ren1 (nat -> nat) Y Z} {Γ Δ : context} : (Ren1 (Γ ≤ Δ) Y Z) := fun ρ t => t⟨wk_to_ren ρ.(wk)⟩. -Arguments Ren1_wk {_ _ _} _ _/. Arguments Ren1_well_wk {_ _ _ _ _} _ _/. Ltac fold_wk_ren := @@ -197,29 +201,6 @@ Proof. intros; cbn; now asimpl. Qed. -(** ** Weakenings play well with context access *) - -Lemma in_ctx_wk (Γ Δ : context) n decl (ρ : Δ ≤ Γ) : - in_ctx Γ n decl -> - in_ctx Δ (ρ n) (ren_term ρ decl). -Proof. - intros Hdecl. - destruct ρ as [ρ wfρ] ; cbn. - induction wfρ in n, decl, Hdecl |- *. - - cbn; now asimpl. - - cbn. - replace (ren_term (ρ >> S) decl) with (decl⟨ρ⟩⟨↑⟩) by now asimpl. - now econstructor. - - destruct n ; cbn. - + cbn. - inversion Hdecl ; subst ; clear Hdecl. - replace (ren_term _ A⟨↑⟩) with (A⟨ρ⟩⟨↑⟩) by now asimpl. - now constructor. - + inversion Hdecl ; subst ; cbn in *. - replace (ren_term _ (ren_term ↑ d)) with (d⟨ρ⟩⟨↑⟩) by now asimpl. - now econstructor. -Qed. - Section RenWlWhnf. Context {Γ Δ} (ρ : Δ ≤ Γ). @@ -256,6 +237,7 @@ Section RenWlWhnf. Lemma isCanonical_ren_wl t : isCanonical t <~> isCanonical (t⟨ρ⟩). Proof. + symmetry. apply isCanonical_ren. Qed. @@ -300,6 +282,54 @@ Ltac bsimpl := check_no_evars; Ren1_subst, Ren1_wk, Ren1_well_wk in *; bsimpl'; minimize. + +(** ** Weakenings play well with context access *) + +Lemma in_ctx_wk (Γ Δ : context) n decl (ρ : Δ ≤ Γ) : +in_ctx Γ n decl -> +in_ctx Δ (ρ n) (decl⟨ρ⟩). +Proof. +intros Hdecl. +destruct ρ as [ρ wfρ] ; cbn in *. +induction wfρ in n, decl, Hdecl |- *. +- inversion Hdecl. +- cbn. + replace (decl⟨_⟩) with (decl⟨ρ⟩⟨↑⟩) by now asimpl. + now econstructor. +- destruct n ; cbn. + + inversion Hdecl ; subst ; clear Hdecl. + replace (A⟨↑⟩⟨_⟩) with (A⟨ρ⟩⟨↑⟩) by now asimpl. + now constructor. + + inversion Hdecl ; subst ; cbn in * ; refold. + replace (d⟨_⟩⟨_⟩) with (d⟨ρ⟩⟨↑⟩) by now asimpl. + now econstructor. +Qed. + +Lemma in_ctx_str (Γ Δ : context) n decl (ρ : Δ ≤ Γ) : +in_ctx Δ (ρ n) decl -> +∑ decl', decl = decl'⟨ρ⟩ × in_ctx Γ n decl'. +Proof. +intros Hdecl. +destruct ρ as [ρ wfρ] ; cbn in *. +induction wfρ in n, decl, Hdecl |- *. +- inversion Hdecl. +- cbn in *. +inversion Hdecl ; subst. +edestruct IHwfρ as [? []]; tea ; subst. +eexists ; split ; tea. +now bsimpl. +- destruct n ; cbn in *. ++ inversion Hdecl ; subst ; clear Hdecl. + eexists ; split. + 2: now constructor. + now bsimpl. ++ inversion Hdecl ; subst ; clear Hdecl ; cbn in *. + edestruct IHwfρ as [? []]; tea ; subst. + eexists ; split. + 2: now econstructor. + now bsimpl. +Qed. + (** Lemmas for easier rewriting *) Lemma subst_ren_wk_up {Γ Δ P A n} (ρ : Γ ≤ Δ): P[n..]⟨ρ⟩ = P⟨wk_up A ρ⟩[n⟨ρ⟩..]. @@ -397,6 +427,8 @@ Lemma wk_comp_assoc {Γ Δ Ξ ζ} (ρ : Δ ≤ Γ) (ρ' : Ξ ≤ Δ) (ρ'' : ζ (ρ'' ∘w ρ') ∘w ρ =1 ρ'' ∘w (ρ' ∘w ρ). Proof. now bsimpl. Qed. - Lemma wk1_irr {Γ Γ' A A' t} : t⟨@wk1 Γ A⟩ = t⟨@wk1 Γ' A'⟩. -Proof. intros; now rewrite 2!wk1_ren_on. Qed. \ No newline at end of file +Proof. intros; now rewrite 2!wk1_ren_on. Qed. + +Lemma var0_wk1_id {Γ A t} : t[tRel 0 .: @wk1 Γ A >> tRel] = t. +Proof. bsimpl. rewrite scons_eta'. now asimpl. Qed. \ No newline at end of file diff --git a/theories/TypeConstructorsInj.v b/theories/TypeConstructorsInj.v deleted file mode 100644 index d4a8fef9..00000000 --- a/theories/TypeConstructorsInj.v +++ /dev/null @@ -1,907 +0,0 @@ -(** * LogRel.TypeConstructorsInj: injectivity and no-confusion of type constructors, and many consequences, including subject reduction. *) -From Coq Require Import CRelationClasses. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening UntypedReduction - GenericTyping DeclarativeTyping DeclarativeInstance. -From LogRel Require Import LogicalRelation Validity Fundamental DeclarativeSubst. -From LogRel.LogicalRelation Require Import Escape Irrelevance Neutral Induction NormalRed. -From LogRel.Substitution Require Import Escape Poly Reflexivity. - -Set Printing Primitive Projection Parameters. - -Import DeclarativeTypingProperties. - -Section TypeConstructors. - - Definition type_hd_view (Γ : context) {T T' : term} (nfT : isType T) (nfT' : isType T') : Type := - match nfT, nfT' with - | @UnivType s, @UnivType s' => s = s' - | @ProdType A B, @ProdType A' B' => [Γ |- A' ≅ A] × [Γ,, A' |- B ≅ B'] - | NatType, NatType => True - | EmptyType, EmptyType => True - | NeType _, NeType _ => [Γ |- T ≅ T' : U] - | @SigType A B, @SigType A' B' => [Γ |- A' ≅ A] × [Γ,, A' |- B ≅ B'] - | @IdType A x y, @IdType A' x' y' => [× [Γ |- A' ≅ A], [Γ |- x ≅ x' : A] & [Γ |- y ≅ y' : A]] - | _, _ => False - end. - - Lemma red_ty_complete : forall (Γ : context) (T T' : term), - isType T -> - [Γ |- T ≅ T'] -> - ∑ T'', [Γ |- T' ⤳* T''] × isType T''. - Proof. - intros * tyT Hconv. - eapply Fundamental in Hconv as [HΓ HT HT' Hconv]. - eapply reducibleTyEq in Hconv. - set (HTred := reducibleTy _ HT) in *. - clearbody HTred. - clear HT. - destruct HTred as [[] lr] ; cbn in *. - destruct lr. - all: destruct Hconv; eexists; split; [lazymatch goal with H : [_ |- _ :⤳*: _] |- _ => apply H end|]; constructor. - eapply convneu_whne; now symmetry. - Qed. - - Lemma ty_conv_inj : forall (Γ : context) (T T' : term) (nfT : isType T) (nfT' : isType T'), - [Γ |- T ≅ T'] -> - type_hd_view Γ nfT nfT'. - Proof. - intros * Hconv. - eapply Fundamental in Hconv as [HΓ HT HT' Hconv]. - eapply reducibleTyEq in Hconv. - set (HTred := reducibleTy _ HT) in *. - clearbody HTred. - clear HT. - eapply reducibleTy in HT'. - revert nfT T' nfT' HΓ HT' Hconv. - revert HTred. - generalize (eq_refl : one = one). - generalize one at 1 3; intros l eql HTred; revert eql. - pattern l, Γ, T, HTred; apply LR_rect_TyUr; clear l Γ T HTred. - all: intros ? Γ T. - - intros [] -> nfT T' nfT' HΓ HT' []. - assert (T' = U) as HeqT' by (eapply redtywf_whnf ; gen_typing); subst. - assert (T = U) as HeqU by (eapply redtywf_whnf ; gen_typing). - destruct nfT ; inversion HeqU ; subst. - 2: now exfalso ; gen_typing. - clear HeqU. - Set Printing All. - remember U as T eqn:HeqU in nfT' |- * at 2. - destruct nfT'; inversion HeqU ; subst. - 2: now exfalso ; gen_typing. - now reflexivity. - - intros [nT ? ne] -> nfT T' nfT' HΓ HT' [nT' ? ne']; cbn in *. - assert (T = nT) as <- by - (apply red_whnf ; gen_typing). - assert (T' = nT') as <- by - (apply red_whnf ; gen_typing). - destruct nfT. - 1-6: apply convneu_whne in ne; inversion ne. - destruct nfT'. - 1-6: symmetry in ne'; apply convneu_whne in ne'; inversion ne'. - cbn. gen_typing. - - intros [dom cod red] _ _ -> nfT T' nfT' HΓ HT'[dom' cod' red']; cbn in *. - assert (T = tProd dom cod) as HeqT by (apply red_whnf ; gen_typing). - assert (T' = tProd dom' cod') as HeqT' by (apply red_whnf ; gen_typing). - destruct nfT; cycle -1. - 1: subst ; exfalso ; gen_typing. - all: try congruence. - destruct nfT'; cycle -1. - 1: subst ; exfalso ; gen_typing. - all: try congruence. - inversion HeqT ; inversion HeqT' ; subst ; clear HeqT HeqT'; cbn. - destruct (polyRedEqId (normRedΠ0 (invLRΠ HT')) (PolyRedEqSym _ polyRed0)). - split; now escape. - - intros [] -> nfT T' nfT' HΓ HT' []. - assert (T' = tNat) as HeqT' by (eapply redtywf_whnf ; gen_typing). - assert (T = tNat) as HeqT by (eapply redtywf_whnf ; gen_typing). - destruct nfT; inversion HeqT. - + destruct nfT'; inversion HeqT'. - * constructor. - * exfalso; subst; inversion w. - + exfalso; subst; inversion w. - - intros [] -> nfT T' nfT' HΓ HT' []. - assert (T' = tEmpty) as HeqT' by (eapply redtywf_whnf ; gen_typing). - assert (T = tEmpty) as HeqT by (eapply redtywf_whnf ; gen_typing). - destruct nfT; inversion HeqT. - + destruct nfT'; inversion HeqT'. - * econstructor. - * exfalso; subst; inversion w. - + exfalso; subst; inversion w. - - intros [dom cod red] _ _ -> nfT T' nfT' HΓ HT' [dom' cod' red']. - assert (T = tSig dom cod) as HeqT by (apply red_whnf ; gen_typing). - assert (T' = tSig dom' cod') as HeqT' by (apply red_whnf ; gen_typing). - destruct nfT; cycle -1. - 1: subst; inv_whne. - all: try congruence. - destruct nfT'; cycle -1. - 1: subst; inv_whne. - all: try congruence. - inversion HeqT ; inversion HeqT' ; subst ; clear HeqT HeqT'; cbn. - destruct (polyRedEqId (normRedΣ0 (invLRΣ HT')) (PolyRedEqSym _ polyRed0)). - split; now escape. - - intros [??? ty] _ _ -> nfT T' nfT' HΓ HT' [??? ty']; cbn in *. - assert (T = ty) as HeqT by (apply red_whnf; gen_typing). - assert (T' = ty') as HeqT' by (apply red_whnf; gen_typing). - destruct nfT; cycle -1; [subst; inv_whne|..]; unfold ty in *; try congruence. - destruct nfT'; cycle -1; [subst; inv_whne|..]; unfold ty' in *; try congruence. - cbn; inversion HeqT; inversion HeqT'; subst; escape; now split. - Qed. - - Corollary red_ty_compl_univ_l Γ T : - [Γ |- U ≅ T] -> - [Γ |- T ⤳* U]. - Proof. - intros HT. - pose proof HT as HT'. - unshelve eapply red_ty_complete in HT' as (T''&[? nfT]). - 2: econstructor. - enough (T'' = U) as -> by easy. - assert [Γ |- U ≅ T''] as Hconv by - (etransitivity ; [eassumption|now eapply RedConvTyC]). - unshelve eapply ty_conv_inj in Hconv. - 1: econstructor. - 1: eassumption. - now destruct nfT, Hconv. - Qed. - - Corollary red_ty_compl_univ_r Γ T : - [Γ |- T ≅ U] -> - [Γ |- T ⤳* U]. - Proof. - intros. - eapply red_ty_compl_univ_l. - now symmetry. - Qed. - - Corollary red_ty_compl_nat_l Γ T : - [Γ |- tNat ≅ T] -> - [Γ |- T ⤳* tNat]. - Proof. - intros HT. - pose proof HT as HT'. - unshelve eapply red_ty_complete in HT' as (T''&[? nfT]). - 2: econstructor. - enough (T'' = tNat) as -> by easy. - assert [Γ |- tNat ≅ T''] as Hconv by - (etransitivity ; [eassumption|now eapply RedConvTyC]). - unshelve eapply ty_conv_inj in Hconv. - 1: econstructor. - 1: eassumption. - now destruct nfT, Hconv. - Qed. - - Corollary red_ty_compl_nat_r Γ T : - [Γ |- T ≅ tNat] -> - [Γ |- T ⤳* tNat]. - Proof. - intros. - eapply red_ty_compl_nat_l. - now symmetry. - Qed. - - Corollary red_ty_compl_empty_l Γ T : - [Γ |- tEmpty ≅ T] -> - [Γ |- T ⤳* tEmpty]. - Proof. - intros HT. - pose proof HT as HT'. - unshelve eapply red_ty_complete in HT' as (T''&[? nfT]). - 2: econstructor. - enough (T'' = tEmpty) as -> by easy. - assert [Γ |- tEmpty ≅ T''] as Hconv by - (etransitivity ; [eassumption|now eapply RedConvTyC]). - unshelve eapply ty_conv_inj in Hconv. - 1: econstructor. - 1: eassumption. - now destruct nfT, Hconv. - Qed. - - Corollary red_ty_compl_empty_r Γ T : - [Γ |- T ≅ tEmpty] -> - [Γ |- T ⤳* tEmpty]. - Proof. - intros. - eapply red_ty_compl_empty_l. - now symmetry. - Qed. - - Corollary red_ty_compl_prod_l Γ A B T : - [Γ |- tProd A B ≅ T] -> - ∑ A' B', [× [Γ |- T ⤳* tProd A' B'], [Γ |- A' ≅ A] & [Γ,, A' |- B ≅ B']]. - Proof. - intros HT. - pose proof HT as HT'. - unshelve eapply red_ty_complete in HT as (T''&[? nfT]). - 2: econstructor. - assert [Γ |- tProd A B ≅ T''] as Hconv by - (etransitivity ; [eassumption|now eapply RedConvTyC]). - unshelve eapply ty_conv_inj in Hconv. - 1: constructor. - 1: assumption. - destruct nfT, Hconv. - do 2 eexists ; split. - all: eassumption. - Qed. - - Corollary prod_ty_inj Γ A B A' B' : - [Γ |- tProd A B ≅ tProd A' B'] -> - [Γ |- A' ≅ A] × [Γ,, A' |- B ≅ B']. - Proof. - intros Hty. - unshelve eapply ty_conv_inj in Hty. - 1-2: constructor. - now eassumption. - Qed. - - Corollary red_ty_compl_sig_l Γ A B T : - [Γ |- tSig A B ≅ T] -> - ∑ A' B', [× [Γ |- T ⤳* tSig A' B'], [Γ |- A' ≅ A] & [Γ,, A' |- B ≅ B']]. - Proof. - intros HT. - pose proof HT as HT'. - unshelve eapply red_ty_complete in HT as (T''&[? nfT]). - 2: econstructor. - assert [Γ |- tSig A B ≅ T''] as Hconv by - (etransitivity ; [eassumption|now eapply RedConvTyC]). - unshelve eapply ty_conv_inj in Hconv. - 1: constructor. - 1: assumption. - destruct nfT, Hconv. - do 2 eexists ; split. - all: eassumption. - Qed. - - Corollary red_ty_compl_sig_r Γ A B T : - [Γ |- T ≅ tSig A B] -> - ∑ A' B', [× [Γ |- T ⤳* tSig A' B'], [Γ |- A' ≅ A] & [Γ,, A' |- B ≅ B']]. - Proof. - intros; eapply red_ty_compl_sig_l; now symmetry. - Qed. - - Corollary sig_ty_inj Γ A B A' B' : - [Γ |- tSig A B ≅ tSig A' B'] -> - [Γ |- A' ≅ A] × [Γ,, A' |- B ≅ B']. - Proof. - intros Hty. - unshelve eapply ty_conv_inj in Hty. - 1-2: constructor. - now eassumption. - Qed. - - Corollary red_ty_compl_id_l Γ A x y T : - [Γ |- tId A x y ≅ T] -> - ∑ A' x' y', [× [Γ |- T ⤳* tId A' x' y'], [Γ |- A' ≅ A], [Γ |- x ≅ x' : A] & [Γ |- y ≅ y' : A]]. - Proof. - intros HT. - pose proof HT as HT'. - unshelve eapply red_ty_complete in HT as (T''&[? nfT]). - 2: econstructor. - assert [Γ |- tId A x y ≅ T''] as Hconv by - (etransitivity ; [eassumption|now eapply RedConvTyC]). - unshelve eapply ty_conv_inj in Hconv. - 1: constructor. - 1: assumption. - destruct nfT, Hconv. - do 3 eexists ; split; eassumption. - Qed. - - Corollary red_ty_compl_id_r Γ A x y T : - [Γ |- T ≅ tId A x y] -> - ∑ A' x' y', [× [Γ |- T ⤳* tId A' x' y'], [Γ |- A' ≅ A], [Γ |- x ≅ x' : A] & [Γ |- y ≅ y' : A]]. - Proof. - intros; eapply red_ty_compl_id_l; now symmetry. - Qed. - - Corollary id_ty_inj {Γ A A' x x' y y'} : - [Γ |- tId A x y ≅ tId A' x' y'] -> - [× [Γ |- A' ≅ A], [Γ |- x ≅ x' : A] & [Γ |- y ≅ y' : A]]. - Proof. - intros Hty. - unshelve eapply ty_conv_inj in Hty. - 1-2: constructor. - now eassumption. - Qed. - -End TypeConstructors. - -Section Boundary. - - Lemma in_ctx_wf Γ n decl : - [|- Γ] -> - in_ctx Γ n decl -> - [Γ |- decl]. - Proof. - intros HΓ Hin. - induction Hin. - - inversion HΓ ; subst ; cbn in * ; refold. - renToWk. - now apply typing_wk. - - inversion HΓ ; subst ; cbn in * ; refold. - renToWk. - now eapply typing_wk. - Qed. - - Lemma scons2_well_subst {Γ A B} : - (forall a b, [Γ |- a : A] -> [Γ |- b : B[a..]] -> [Γ |-s (b .: a ..) : (Γ ,, A),, B]) - × (forall a a' b b', [Γ |- a ≅ a' : A] -> [Γ |- b ≅ b' : B[a..]] -> [Γ |-s (b .: a..) ≅ (b' .: a'..) : (Γ ,, A),, B]). - Proof. - assert (h : forall (a : term) σ, ↑ >> (a .: σ) =1 σ) by reflexivity. - assert (h' : forall a σ t, t[↑ >> (a .: σ)] = t[σ]) by (intros; now setoid_rewrite h). - split; intros; econstructor. - - asimpl; econstructor. - 2: cbn; rewrite h'; now asimpl. - asimpl; eapply id_subst; gen_typing. - - cbn; now rewrite h'. - - asimpl; econstructor. - 2: cbn; rewrite h'; now asimpl. - asimpl; eapply subst_refl; eapply id_subst; gen_typing. - - cbn; now rewrite h'. - Qed. - - Lemma typing_subst2 {Γ A B} : - [|- Γ] -> - (forall P a b, [Γ |- a : A] -> [Γ |- b : B[a..]] -> [Γ,, A,, B |- P] -> [Γ |- P[b .: a ..]]) - × (forall P P' a a' b b', [Γ |- a ≅ a' : A] -> [Γ |- b ≅ b' : B[a..]] -> [Γ,, A ,, B |- P ≅ P'] -> [Γ |- P[b .: a..] ≅ P'[b' .: a'..]]). - Proof. - intros;split; intros; eapply typing_subst; tea; now eapply scons2_well_subst. - Qed. - - Lemma shift_subst_eq t a : t⟨↑⟩[a..] = t. - Proof. now asimpl. Qed. - - Lemma idElimMotiveCtx {Γ A x} : - [Γ |- A] -> - [Γ |- x : A] -> - [|- (Γ,, A),, tId A⟨@wk1 Γ A⟩ x⟨@wk1 Γ A⟩ (tRel 0)]. - Proof. - intros; assert [|- Γ] by boundary. - assert [|- Γ,, A] by now econstructor. - econstructor; tea. - econstructor. - 1: now eapply wft_wk. - 1: eapply ty_wk; tea; econstructor; tea. - rewrite wk1_ren_on; now eapply ty_var0. - Qed. - - Lemma idElimMotiveCtxConv {Γ Γ' A A' x x'} : - [|- Γ ≅ Γ'] -> - [Γ |- A ≅ A'] -> - [Γ |- x ≅ x' : A] -> - [ |- (Γ,, A),, tId A⟨@wk1 Γ A⟩ x⟨@wk1 Γ A⟩ (tRel 0)] -> - [ |- (Γ',, A'),, tId A'⟨@wk1 Γ' A'⟩ x'⟨@wk1 Γ' A'⟩ (tRel 0)] -> - [ |- (Γ',, A'),, tId A'⟨@wk1 Γ' A'⟩ x'⟨@wk1 Γ' A'⟩ (tRel 0) ≅ (Γ,, A),, tId A⟨@wk1 Γ A⟩ x⟨@wk1 Γ A⟩ (tRel 0)]. - Proof. - intros. - assert [|- Γ] by boundary. - assert [Γ |- A] by boundary. - eapply convCtxSym0; tea. - econstructor. - 1: econstructor; tea; now eapply ctx_refl. - erewrite (wk1_irr (t:=A')), (wk1_irr (t:=x')); econstructor. - 1,2: eapply typing_wk; tea; gen_typing. - rewrite wk1_ren_on; eapply TermRefl; now eapply ty_var0. - Qed. - - Let PCon (Γ : context) := True. - Let PTy (Γ : context) (A : term) := True. - Let PTm (Γ : context) (A t : term) := [Γ |- A]. - Let PTyEq (Γ : context) (A B : term) := [Γ |- A] × [Γ |- B]. - Let PTmEq (Γ : context) (A t u : term) := [× [Γ |- A], [Γ |- t : A] & [Γ |- u : A]]. - - Lemma boundary : WfDeclInductionConcl PCon PTy PTm PTyEq PTmEq. - Proof. - subst PCon PTy PTm PTyEq PTmEq. - red; prod_splitter; try now constructor. - - intros Γ A t H; apply Fundamental in H as [? VA _]. - now eapply escapeTy. - - intros Γ A B H; apply Fundamental in H as [? VA VB _]; split. - + now eapply escapeTy. - + now eapply escapeTy. - - intros Γ A t u H; apply Fundamental in H as [? VA Vtu]. - pose proof (ureflValidTm Vtu). - prod_splitter. - + now eapply escapeTy. - + now eapply escapeTm. - + now eapply escapeTm. - Qed. - -End Boundary. - -Corollary boundary_tm Γ A t : [Γ |- t : A] -> [Γ |- A]. -Proof. - now intros ?%boundary. -Qed. - -Corollary boundary_ty_conv_l Γ A B : [Γ |- A ≅ B] -> [Γ |- A]. -Proof. - now intros ?%boundary. -Qed. - -Corollary boundary_ty_conv_r Γ A B : [Γ |- A ≅ B] -> [Γ |- B]. -Proof. - now intros ?%boundary. -Qed. - -Corollary boundary_red_ty_r Γ A B : [Γ |- A ⤳* B] -> [Γ |- B]. -Proof. - now intros ?%RedConvTyC%boundary. -Qed. - -Corollary boundary_tm_conv_l Γ A t u : [Γ |- t ≅ u : A] -> [Γ |- t : A]. -Proof. - now intros []%boundary. -Qed. - -Corollary boundary_tm_conv_r Γ A t u : [Γ |- t ≅ u : A] -> [Γ |- u : A]. -Proof. - now intros []%boundary. -Qed. - -Corollary boundary_tm_conv_ty Γ A t u : [Γ |- t ≅ u : A] -> [Γ |- A]. -Proof. - now intros []%boundary. -Qed. - -Corollary boundary_red_tm_r Γ A t u : [Γ |- t ⤳* u : A] -> [Γ |- u : A]. -Proof. - now intros []%RedConvTeC%boundary. -Qed. - -Corollary boundary_red_tm_ty Γ A t u : [Γ |- t ⤳* u : A] -> [Γ |- A]. -Proof. - now intros []%RedConvTeC%boundary. -Qed. - -#[export] Hint Resolve - boundary_tm boundary_ty_conv_l boundary_ty_conv_r - boundary_tm_conv_l boundary_tm_conv_r boundary_tm_conv_ty - boundary_red_tm_l boundary_red_tm_r boundary_red_tm_ty - boundary_red_ty_r : boundary. - -Lemma boundary_ctx_conv_l (Γ Δ : context) : - [ |- Γ ≅ Δ] -> - [|- Γ]. -Proof. - destruct 1. - all: econstructor ; boundary. -Qed. - -#[export] Hint Resolve boundary_ctx_conv_l : boundary. - -Corollary conv_ctx_refl_l (Γ Δ : context) : -[ |- Γ ≅ Δ] -> -[|- Γ ≅ Γ]. -Proof. - intros. - eapply ctx_refl ; boundary. -Qed. - -Corollary red_ty_compl_prod_r Γ A B T : - [Γ |- T ≅ tProd A B] -> - ∑ A' B', [× [Γ |- T ⤳* tProd A' B'], [Γ |- A ≅ A'] & [Γ,, A |- B' ≅ B]]. -Proof. - intros HT. - symmetry in HT. - eapply red_ty_compl_prod_l in HT as (?&?&[HA ? HB]). - do 2 eexists ; split ; tea. - 1: now symmetry. - symmetry. - eapply stability1 ; tea. - 1-2: now boundary. - now symmetry. -Qed. - -Section Stability. - - Lemma conv_well_subst (Γ Δ : context) : - [ |- Γ ≅ Δ] -> - [Γ |-s tRel : Δ]. - Proof. - intros; eapply conv_well_subst; tea; boundary. - Qed. - - Let PCon (Γ : context) := True. - Let PTy (Γ : context) (A : term) := forall Δ, - [|- Δ ≅ Γ] -> [Δ |- A]. - Let PTm (Γ : context) (A t : term) := forall Δ, - [|- Δ ≅ Γ] -> [Δ |- t : A]. - Let PTyEq (Γ : context) (A B : term) := forall Δ, - [|- Δ ≅ Γ] -> [Δ |- A ≅ B]. - Let PTmEq (Γ : context) (A t u : term) := forall Δ, - [|- Δ ≅ Γ] -> [Δ |- t ≅ u : A]. - - Theorem stability : WfDeclInductionConcl PCon PTy PTm PTyEq PTmEq. - Proof. - red; prod_splitter; intros; red;intros; eapply stability0; tea; boundary. - Qed. - - - #[global] Instance ConvCtxSym : Symmetric ConvCtx. - Proof. - intros Γ Δ. - induction 1. - all: constructor ; tea. - eapply stability ; tea. - now symmetry. - Qed. - - Corollary conv_ctx_refl_r (Γ Δ : context) : - [ |- Γ ≅ Δ] -> - [|- Δ ≅ Δ]. - Proof. - intros H. - symmetry in H. - now eapply ctx_refl ; boundary. - Qed. - - #[global] Instance ConvCtxTrans : Transitive ConvCtx. - Proof. - intros Γ1 Γ2 Γ3 H1 H2. - induction H1 in Γ3, H2 |- *. - all: inversion H2 ; subst ; clear H2. - all: constructor. - 1: eauto. - etransitivity ; tea. - now eapply stability. - Qed. - -End Stability. - -(** ** Generation *) - -(** The generation lemma (the name comes from the PTS literature), gives a -stronger inversion principle on typing derivations, that give direct access -to the last non-conversion rule, and bundle together all conversions. - -Note that because we do not yet know that [Γ |- t : T] implies [Γ |- T], -we cannot use reflexivity in the case where the last rule was not a conversion -one, and we get the slightly clumsy disjunction of either an equality or a -conversion proof. We get a better version of generation later on, once we have -this implication. *) - -Definition termGenData (Γ : context) (t T : term) : Type := - match t with - | tRel n => ∑ decl, [× T = decl, [|- Γ]& in_ctx Γ n decl] - | tProd A B => [× T = U, [Γ |- A : U] & [Γ,, A |- B : U]] - | tLambda A t => ∑ B, [× T = tProd A B, [Γ |- A] & [Γ,, A |- t : B]] - | tApp f a => ∑ A B, [× T = B[a..], [Γ |- f : tProd A B] & [Γ |- a : A]] - | tSort _ => False - | tNat => T = U - | tZero => T = tNat - | tSucc n => T = tNat × [Γ |- n : tNat] - | tNatElim P hz hs n => - [× T = P[n..], [Γ,, tNat |- P], [Γ |- hz : P[tZero..]], [Γ |- hs : elimSuccHypTy P] & [Γ |- n : tNat]] - | tEmpty => T = U - | tEmptyElim P e => - [× T = P[e..], [Γ,, tEmpty |- P] & [Γ |- e : tEmpty]] - | tSig A B => [× T = U, [Γ |- A : U] & [Γ ,, A |- B : U]] - | tPair A B a b => - [× T = tSig A B, [Γ |- A], [Γ,, A |- B], [Γ |- a : A] & [Γ |- b : B[a..]]] - | tFst p => ∑ A B, T = A × [Γ |- p : tSig A B] - | tSnd p => ∑ A B, T = B[(tFst p)..] × [Γ |- p : tSig A B] - | tId A x y => [× T = U, [Γ |- A : U], [Γ |- x : A] & [Γ |- y : A]] - | tRefl A x => [× T = tId A x x, [Γ |- A] & [Γ |- x : A]] - | tIdElim A x P hr y e => - [× T = P[e .: y..], [Γ |- A], [Γ |- x : A], [Γ,, A,, tId A⟨@wk1 Γ A⟩ x⟨@wk1 Γ A⟩ (tRel 0) |- P], [Γ |- hr : P[tRefl A x .: x..]], [Γ |- y : A] & [Γ |- e : tId A x y]] - end. - -Lemma termGen Γ t A : - [Γ |- t : A] -> - ∑ A', (termGenData Γ t A') × ((A' = A) + [Γ |- A' ≅ A]). -Proof. - induction 1. - all: try (eexists ; split ; [..|left ; reflexivity] ; cbn ; by_prod_splitter). - + destruct IHTypingDecl as [? [? [-> | ]]]. - * prod_splitter; tea; now right. - * prod_splitter; tea; right; now eapply TypeTrans. -Qed. - -Lemma neutral_ty_inv Γ A : - [Γ |- A] -> whne A -> [Γ |- A : U]. -Proof. - intros Hty Hne. - unshelve eapply TypeRefl, ty_conv_inj in Hty. - - now constructor. - - now constructor. - - cbn in *. - apply Fundamental in Hty; destruct Hty. - now eapply escapeTm. -Qed. - -Lemma prod_ty_inv Γ A B : - [Γ |- tProd A B] -> - [Γ |- A] × [Γ,, A |- B]. -Proof. - intros Hty. - apply TypeRefl, prod_ty_inj in Hty as [HA HB]. - split; boundary. -Qed. - -Lemma sig_ty_inv Γ A B : - [Γ |- tSig A B] -> - [Γ |- A] × [Γ,, A |- B]. -Proof. - intros Hty. - apply TypeRefl, sig_ty_inj in Hty as [HA HB]. - split; boundary. -Qed. - -Lemma id_ty_inv Γ A x y : - [Γ |- tId A x y] -> - [Γ |- A] × [Γ |- x : A] × [Γ |- y : A]. -Proof. - intros Hty. - apply TypeRefl, id_ty_inj in Hty as [HA HB]. - prod_splitter; boundary. -Qed. - -Lemma termGen' Γ t A : -[Γ |- t : A] -> -∑ A', (termGenData Γ t A') × [Γ |- A' ≅ A]. -Proof. -intros * H. -destruct (termGen _ _ _ H) as [? [? [->|]]]. -2: now eexists. -eexists ; split ; tea. -econstructor. -boundary. -Qed. - -Lemma typing_eta' (Γ : context) A B f : - [Γ |- f : tProd A B] -> - [Γ,, A |- eta_expand f : B]. -Proof. - intros Hf. - eapply typing_eta ; tea. - - eapply prod_ty_inv. - boundary. - - eapply prod_ty_inv. - boundary. -Qed. - -Theorem subject_reduction_one Γ A t t' : - [Γ |- t : A] -> - [t ⤳ t'] -> - [Γ |- t ≅ t' : A]. -Proof. - intros Hty Hred. - induction Hred in Hty, A |- *. - - apply termGen' in Hty as (?&((?&?&[-> Hty])&Heq)). - apply termGen' in Hty as (?&((?&[->])&Heq')). - eapply prod_ty_inj in Heq' as [? HeqB]. - econstructor. - 1: econstructor ; gen_typing. - etransitivity ; tea. - eapply typing_subst1 ; tea. - now econstructor. - - apply termGen' in Hty as (?&((?&?&[->])&Heq)). - econstructor ; tea. - econstructor. - + now eapply IHHred. - + now econstructor. - - apply termGen' in Hty as [?[[->]?]]. - econstructor; tea. - econstructor. - 1-3: now econstructor. - now eapply IHHred. - - apply termGen' in Hty as [?[[->]?]]. - now do 2 econstructor. - - apply termGen' in Hty as [?[[-> ???(?&[->]&?)%termGen']?]]. - now do 2 econstructor. - - apply termGen' in Hty as [?[[->]?]]. - econstructor ; tea. - econstructor. - 1: now econstructor. - now eapply IHHred. - - apply termGen' in Hty as [? [[?[?[->]]]]]. - eapply TermConv; tea ; refold. - now econstructor. - - apply termGen' in Hty as [?[[?[?[-> h]]]]]. - apply termGen' in h as [?[[->] u]]. - destruct (sig_ty_inj _ _ _ _ _ u). - eapply TermConv; refold. - 2: etransitivity;[|tea]; now symmetry. - econstructor; tea. - - apply termGen' in Hty as [? [[?[?[->]]]]]. - eapply TermConv; tea ; refold. - now econstructor. - - apply termGen' in Hty as [?[[?[?[-> h]]]]]. - apply termGen' in h as [?[[->] u]]. - destruct (sig_ty_inj _ _ _ _ _ u). - assert [Γ |- B[(tFst (tPair A0 B a b))..] ≅ A]. - 1:{ etransitivity; tea. eapply typing_subst1; tea. - eapply TermConv; refold. 2: now symmetry. - eapply TermRefl; refold; gen_typing. - } - eapply TermConv; tea; refold. - now econstructor. - - apply termGen' in Hty as [? [[-> ????? h]]]. - apply termGen' in h as [? [[->] h']]. - pose proof h' as []%id_ty_inj. - econstructor; tea. - econstructor; tea. - 1: now econstructor. - + eapply TermConv; refold; [etransitivity; tea|]; now symmetry. - + eapply TermConv; refold; now symmetry. - - apply termGen' in Hty as [? [[-> ????? h]]]. - econstructor; tea; econstructor; tea. - all: now first [eapply TypeRefl |eapply TermRefl| eauto]. - Qed. - - - Theorem subject_reduction_one_type Γ A A' : - [Γ |- A] -> - [A ⤳ A'] -> - [Γ |- A ≅ A']. -Proof. - intros Hty Hred. - destruct Hred. - all: inversion Hty ; subst ; clear Hty ; refold. - all: econstructor. - all: eapply subject_reduction_one ; tea. - all: now econstructor. -Qed. - -Theorem subject_reduction Γ t t' A : - [Γ |- t : A] -> - [t ⤳* t'] -> - [Γ |- t ⤳* t' : A]. -Proof. - intros Hty Hr; split ; refold. - - assumption. - - assumption. - - induction Hr. - + now constructor. - + eapply subject_reduction_one in o ; tea. - etransitivity ; tea. - eapply IHHr. - now boundary. -Qed. - -Theorem subject_reduction_type Γ A A' : -[Γ |- A] -> -[A ⤳* A'] -> -[Γ |- A ⤳* A']. -Proof. - intros Hty Hr; split; refold. - - assumption. - - assumption. - - induction Hr. - + now constructor. - + eapply subject_reduction_one_type in o ; tea. - etransitivity ; tea. - eapply IHHr. - now boundary. -Qed. - -Corollary conv_red_l Γ A A' A'' : [Γ |-[de] A' ≅ A''] -> [A' ⤳* A] -> [Γ |-[de] A ≅ A'']. -Proof. - intros Hconv **. - etransitivity ; tea. - symmetry. - eapply RedConvTyC, subject_reduction_type ; tea. - boundary. -Qed. - -Lemma Uterm_isType Γ A : - [Γ |-[de] A : U] -> - whnf A -> - isType A. -Proof. - intros Hty Hwh. - destruct Hwh. - all: try solve [now econstructor]. - all: exfalso. - all: eapply termGen' in Hty ; cbn in *. - all: prod_hyp_splitter ; try easy. - all: subst. - all: - match goal with - H : [_ |-[de] _ ≅ U] |- _ => unshelve eapply ty_conv_inj in H as Hconv - end. - all: try now econstructor. - all: try now cbn in Hconv. -Qed. - -Lemma type_isType Γ A : - [Γ |-[de] A] -> - whnf A -> - isType A. -Proof. - intros [] ; refold; cycle -1. - 1: intros; now eapply Uterm_isType. - all: econstructor. -Qed. - -Lemma fun_isFun Γ A B t: - [Γ |-[de] t : tProd A B] -> - whnf t -> - isFun t. -Proof. - intros Hty Hwh. - destruct Hwh. - all: try now econstructor. - all: eapply termGen' in Hty ; cbn in *. - all: exfalso. - all: prod_hyp_splitter ; try easy. - all: subst. - all: - match goal with - H : [_ |-[de] _ ≅ tProd _ _] |- _ => unshelve eapply ty_conv_inj in H as Hconv - end. - all: try now econstructor. - all: now cbn in Hconv. -Qed. - -Lemma nat_isNat Γ t: - [Γ |-[de] t : tNat] -> - whnf t -> - isNat t. -Proof. - intros Hty Hwh. - destruct Hwh. - all: try now econstructor. - all: eapply termGen' in Hty ; cbn in *. - all: exfalso. - all: prod_hyp_splitter ; try easy. - all: subst. - all: - match goal with - H : [_ |-[de] _ ≅ tNat] |- _ => unshelve eapply ty_conv_inj in H as Hconv - end. - all: try now econstructor. - all: now cbn in Hconv. -Qed. - -Lemma empty_isEmpty Γ t: - [Γ |-[de] t : tEmpty] -> - whnf t -> - whne t. -Proof. - intros Hty Hwh. - destruct Hwh ; try easy. - all: eapply termGen' in Hty ; cbn in *. - all: exfalso. - all: prod_hyp_splitter ; try easy. - all: subst. - all: - match goal with - H : [_ |-[de] _ ≅ tEmpty] |- _ => unshelve eapply ty_conv_inj in H as Hconv - end. - all: try now econstructor. - all: now cbn in Hconv. -Qed. - -Lemma id_isId Γ t {A x y} : - [Γ |-[de] t : tId A x y] -> - whnf t -> - whne t + ∑ A' x', t = tRefl A' x'. -Proof. - intros Hty wh; destruct wh; try easy. - all: eapply termGen' in Hty; cbn in *; exfalso. - all: prod_hyp_splitter ; try easy; subst. - all: - match goal with - H : [_ |-[de] _ ≅ tId _ _ _] |- _ => unshelve eapply ty_conv_inj in H as Hconv - end; try econstructor. - all: now cbn in Hconv. -Qed. - - -Lemma neutral_isNeutral Γ A t : - [Γ |-[de] t : A] -> - whne A -> - whnf t -> - whne t. -Proof. - intros (?&Hgen&Hconv)%termGen' HwA Hwh. - set (iA := NeType HwA). - destruct Hwh ; cbn in * ; try easy. - all: exfalso. - all: prod_hyp_splitter. - all: subst. - all: unshelve eapply ty_conv_inj in Hconv ; tea. - all: try now econstructor. - all: now cbn in Hconv. -Qed. \ No newline at end of file diff --git a/theories/TypeUniqueness.v b/theories/TypeUniqueness.v deleted file mode 100644 index c24605cd..00000000 --- a/theories/TypeUniqueness.v +++ /dev/null @@ -1,59 +0,0 @@ -(** * LogRel.TypeUniqueness: all types for a term are convertible. *) -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening UntypedReduction - GenericTyping DeclarativeTyping DeclarativeInstance AlgorithmicTyping - BundledAlgorithmicTyping AlgorithmicTypingProperties. - -Import DeclarativeTypingProperties AlgorithmicTypingData BundledTypingData AlgorithmicTypingProperties. - -Section AlgorithmicUnique. - - Lemma algo_typing_unique : AlgoTypingInductionConcl - (fun Γ A => True) - (fun Γ A t => forall A', [Γ |-[al] t ▹ A'] -> A' = A) - (fun Γ A t => forall A', [Γ |-[al] t ▹h A'] -> ∑ A'', [A'' ⤳* A] × [A'' ⤳* A']) - (fun Γ A t => True). - Proof. - apply AlgoTypingInduction. - all: try easy. - all: try solve [intros ** ; match goal with H : context [al] |- _ => now inversion H end]. - - intros * ? * Hty'. - inversion Hty' ; subst. - now eapply in_ctx_inj. - - intros * _ _ _ IHt ? Hty'. - inversion Hty' ; subst ; refold. - now erewrite <- IHt. - - intros * _ IHf _ _ ? Hty'. - inversion Hty' ; subst ; refold. - eapply IHf in H3 as [? [Hred Hred']]. - eapply whred_det in Hred ; tea. - 2-3: gen_typing. - now inversion Hred. - - intros * ? ih ? hty. - inversion hty; subst; refold. - edestruct ih as [? [r r']]; tea. - unshelve epose (e := whred_det _ _ _ _ _ r r'); try constructor. - now injection e. - - intros * ? ih ? hty. - inversion hty; subst; refold. - edestruct ih as [? [r r']]; tea. - unshelve epose (e := whred_det _ _ _ _ _ r r'); try constructor. - injection e; clear e; intros; now subst. - - intros * _ IHt ? ? Hty'. - inversion Hty' ; subst ; refold. - eapply IHt in H0 as ->. - now eexists. - Qed. - -End AlgorithmicUnique. - -Corollary typing_unique Γ T T' t : - [Γ |-[de] t : T] -> - [Γ |-[de] t : T'] -> - [Γ |-[de] T ≅ T']. -Proof. - intros [_ Ti Hty]%algo_typing_complete [_ Ti' Hty']%algo_typing_complete. - eapply algo_typing_unique in Hty ; tea ; subst. - etransitivity ; tea. - now symmetry. -Qed. \ No newline at end of file diff --git a/theories/DeclarativeInstance.v b/theories/TypingProperties/DeclarativeProperties.v similarity index 96% rename from theories/DeclarativeInstance.v rename to theories/TypingProperties/DeclarativeProperties.v index f63a6fa5..22fb0a77 100644 --- a/theories/DeclarativeInstance.v +++ b/theories/TypingProperties/DeclarativeProperties.v @@ -1,7 +1,6 @@ -(** * LogRel.DeclarativeInstance: proof that declarative typing is an instance of generic typing. *) +(** * LogRel.DeclarativeProperties: basic properties of declarative typing, showing it is an instance of generic typing. *) From Coq Require Import CRelationClasses. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms UntypedReduction Weakening GenericTyping DeclarativeTyping. +From LogRel Require Import Utils Syntax.All GenericTyping DeclarativeTyping. Import DeclarativeTypingData. @@ -21,8 +20,6 @@ Section TypingWk. Let PTmEq (Γ : context) (A t u : term) := forall Δ (ρ : Δ ≤ Γ), [|- Δ ] -> [Δ |- t⟨ρ⟩ ≅ u⟨ρ⟩ : A⟨ρ⟩]. - - Theorem typing_wk : WfDeclInductionConcl PCon PTy PTm PTyEq PTmEq. Proof. subst PCon PTy PTm PTyEq PTmEq. @@ -82,7 +79,7 @@ Section TypingWk. * eapply ihP; econstructor; tea; now econstructor. * eapply typing_meta_conv. 1: now eapply ihhz. - now erewrite subst_ren_wk_up. + now bsimpl. * rewrite wk_elimSuccHypTy. now eapply ihhs. * now eapply ihn. @@ -196,7 +193,7 @@ Section TypingWk. * eapply convtm_meta_conv. 1: now eapply ihhz. 2: reflexivity. - now erewrite subst_ren_wk_up. + now bsimpl. * rewrite wk_elimSuccHypTy. now eapply ihhs. * now eapply ihn. @@ -206,7 +203,7 @@ Section TypingWk. * eapply ihP; constructor; tea; now constructor. * eapply typing_meta_conv. 1: now eapply ihhz. - now erewrite subst_ren_wk_up. + now bsimpl. * rewrite wk_elimSuccHypTy. now eapply ihhs. - intros * ? ihP ? ihhz ? ihhs ? ihn **. @@ -215,7 +212,7 @@ Section TypingWk. * eapply ihP; constructor; tea; now constructor. * eapply typing_meta_conv. 1: now eapply ihhz. - now erewrite subst_ren_wk_up. + now bsimpl. * rewrite wk_elimSuccHypTy. now eapply ihhs. * now eapply ihn. @@ -366,6 +363,28 @@ End Boundaries. boundary_red_tm_l boundary_red_ty_l : boundary. + +(** ** Typed reduction implies untyped reduction *) + +Section TypeErasure. + Import DeclarativeTypingData. + +Lemma redtmdecl_red Γ t u A : + [Γ |- t ⤳* u : A] -> + [t ⤳* u]. +Proof. +apply reddecl_red. +Qed. + +Lemma redtydecl_red Γ A B : + [Γ |- A ⤳* B] -> + [A ⤳* B]. +Proof. +apply reddecl_red. +Qed. + +End TypeErasure. + (** ** Inclusion of the various reductions in conversion *) Definition RedConvC {Γ} {t u : term} {K} : @@ -444,7 +463,7 @@ Qed. #[export] Instance RedTermTrans Γ A : Transitive (red_tm Γ A). Proof. - intros t u r [] []; split. + intros t u r [] []; split. + assumption. + now etransitivity. + now eapply TermTrans. @@ -452,7 +471,7 @@ Qed. #[export] Instance RedTypeTrans Γ : Transitive (red_ty Γ). Proof. - intros t u r [] []; split. + intros t u r [] []; split. + assumption. + now etransitivity. + now eapply TypeTrans. @@ -460,9 +479,11 @@ Qed. (** ** Bundling the properties together in an instance *) -Module DeclarativeTypingProperties. +Module WeakDeclarativeTypingProperties. Export DeclarativeTypingData. + Import WeakDeclarativeTypingData. + #[export, refine] Instance WfCtxDeclProperties : WfContextProperties (ta := de) := {}. Proof. 1-2: now constructor. @@ -645,4 +666,4 @@ Module DeclarativeTypingProperties. #[export] Instance DeclarativeTypingProperties : GenericTypingProperties de _ _ _ _ _ _ _ _ _ _ := {}. -End DeclarativeTypingProperties. +End WeakDeclarativeTypingProperties. \ No newline at end of file diff --git a/theories/TypingProperties/LogRelConsequences.v b/theories/TypingProperties/LogRelConsequences.v new file mode 100644 index 00000000..e6df5606 --- /dev/null +++ b/theories/TypingProperties/LogRelConsequences.v @@ -0,0 +1,901 @@ +(** * LogRel.LogRelConsequences: the properties from PropertiesDefinition are consequences of the logical relation. *) +From LogRel Require Import Utils Syntax.All GenericTyping DeclarativeTyping. +From LogRel.TypingProperties Require Import PropertiesDefinition DeclarativeProperties SubstConsequences TypeConstructorsInj NeutralConvProperties NormalisationConsequences. + +From LogRel Require Import LogicalRelation Fundamental. +From LogRel.LogicalRelation Require Import Escape Irrelevance Transitivity Neutral Induction NormalRed. +From LogRel.Validity Require Import Validity Escape Poly Irrelevance. + +(** ** Stability of typing under substitution *) + +(** A priori, we could obtain this by a painful inductive argument, but things are quite a bit easier this way. *) + +Import DeclarativeTypingData. + +Section Subst. + +Import WeakDeclarativeTypingProperties WeakDeclarativeTypingData. + + Lemma _typing_subst : WfDeclInductionConcl + (fun _ => True) + (fun Γ A => forall Δ σ, [|- Δ] -> [Δ |-s σ : Γ] -> [Δ |- A[σ]]) + (fun Γ A t => forall Δ σ, [|- Δ] -> [Δ |-s σ : Γ] -> [Δ |- t[σ] : A[σ]]) + (fun Γ A B => forall Δ σ σ', [|- Δ] -> [Δ |-s σ ≅ σ' : Γ] -> [Δ |- A[σ] ≅ B[σ']]) + (fun Γ A t u => forall Δ σ σ', [|- Δ] -> [Δ |-s σ ≅ σ' : Γ] -> [Δ |- t[σ] ≅ u[σ'] : A[σ]]). + Proof. + unshelve (repeat split ; [shelve|..]). + - intros Γ ? Ht * HΔ Hσ. + unshelve eapply Fundamental_subst in Hσ as []. + 1,3: boundary. + apply Fundamental in Ht as [VΓ [VA _]]. + unshelve eapply escape, VA ; tea. + unshelve eapply irrelevanceSubst ; eassumption. + - intros * Ht * HΔ Hσ. + unshelve eapply Fundamental_subst in Hσ as []. + 1,3: boundary. + apply Fundamental in Ht as [VΓ [VA] [Vt]]. + unshelve eapply escapeTerm, Vt ; tea. + unshelve eapply irrelevanceSubst ; eassumption. + - intros * Ht * HΔ Hσ. + unshelve eapply Fundamental_subst_conv in Hσ as []. + 1,3: boundary. + apply Fundamental in Ht as [VΓ VA ? Vconv] ; cbn in *. + unshelve eapply LogicalRelation.Escape.escapeEq. + 2: unshelve eapply VA ; tea ; irrValid. + cbn. + eapply irrelevanceTyEq. + eassumption. + - intros * Ht * HΔ Hσ. + unshelve eapply Fundamental_subst_conv in Hσ as []. + 1,3: boundary. + apply Fundamental in Ht as [VΓ VA Vtu] ; cbn in *. + unshelve eapply escapeEqTerm. + 2: now unshelve eapply VA ; tea ; irrValid. + cbn. + eapply irrelevanceTmEq. + eassumption. + Qed. + +End Subst. + +#[local, refine] Instance TypingSubstLogRel : TypingSubst (ta := de) := {}. + Proof. + all: intros ; now eapply _typing_subst. + Qed. + +(** ** Injectivity of type constructors *) + +Section TypeConstructors. + + Import WeakDeclarativeTypingProperties WeakDeclarativeTypingData. + + Lemma _red_ty_complete_l (Γ : context) (T T' : term) : + isType T -> + [Γ |- T ≅ T'] -> + ∑ T'', [Γ |- T' ⤳* T''] × isType T''. + Proof. + intros * tyT Hconv. + eapply Fundamental in Hconv as [HΓ HT HT' Hconv]. + eapply reducibleTyEq in Hconv. + set (HTred := reducibleTy _ HT) in *. + clearbody HTred. + clear HT. + destruct HTred as [[] lr] ; cbn in *. + destruct lr. + all: destruct Hconv; eexists; split; [lazymatch goal with H : [_ |- _ :⤳*: _] |- _ => apply H end|]; constructor. + eapply convneu_whne; now symmetry. + Qed. + + Lemma _red_ty_complete_r (Γ : context) (T T' : term) : + isType T' -> + [Γ |- T ≅ T'] -> + ∑ T'', [Γ |- T ⤳* T''] × isType T''. + Proof. + intros ? Hconv. + symmetry in Hconv. + now eapply _red_ty_complete_l in Hconv. + Qed. + + + Lemma _ty_conv_inj : forall (Γ : context) (T T' : term) (nfT : isType T) (nfT' : isType T'), + [Γ |- T ≅ T'] -> + type_hd_view Γ nfT nfT'. + Proof. + intros * Hconv. + eapply Fundamental in Hconv as [HΓ HT HT' Hconv]. + eapply reducibleTyEq in Hconv. + set (HTred := reducibleTy _ HT) in *. + clearbody HTred. + clear HT. + eapply reducibleTy in HT'. + revert nfT T' nfT' HΓ HT' Hconv. + revert HTred. + generalize (eq_refl : one = one). + generalize one at 1 3; intros l eql HTred; revert eql. + pattern l, Γ, T, HTred; apply LR_rect_TyUr; clear l Γ T HTred. + all: intros ? Γ T. + - intros [] -> nfT T' nfT' HΓ HT' []. + assert (T' = U) as HeqT' by (eapply redtywf_whnf ; gen_typing); subst. + assert (T = U) as HeqU by (eapply redtywf_whnf ; gen_typing). + destruct nfT ; inversion HeqU ; subst. + 2: now exfalso ; gen_typing. + clear HeqU. + remember U as T eqn:HeqU in nfT' |- * at 2. + destruct nfT'; inversion HeqU ; subst. + 2: now exfalso ; gen_typing. + now reflexivity. + - intros [nT ? ne] -> nfT T' nfT' HΓ HT' [nT' ? ne']; cbn in *. + assert (T = nT) as <- by + (apply red_whnf ; gen_typing). + assert (T' = nT') as <- by + (apply red_whnf ; gen_typing). + destruct nfT. + 1-6: apply convneu_whne in ne; inversion ne. + destruct nfT'. + 1-6: symmetry in ne'; apply convneu_whne in ne'; inversion ne'. + cbn. gen_typing. + - intros [dom cod red] _ _ -> nfT T' nfT' HΓ HT'[dom' cod' red']; cbn in *. + assert (T = tProd dom cod) as HeqT by (apply red_whnf ; gen_typing). + assert (T' = tProd dom' cod') as HeqT' by (apply red_whnf ; gen_typing). + destruct nfT; cycle -1. + 1: subst ; exfalso ; gen_typing. + all: try congruence. + destruct nfT'; cycle -1. + 1: subst ; exfalso ; gen_typing. + all: try congruence. + inversion HeqT ; inversion HeqT' ; subst ; clear HeqT HeqT'; cbn. + destruct (polyRedEqId (normRedΠ0 (invLRΠ HT')) (PolyRedEqSym _ polyRed0)). + split; now escape. + - intros [] -> nfT T' nfT' HΓ HT' []. + assert (T' = tNat) as HeqT' by (eapply redtywf_whnf ; gen_typing). + assert (T = tNat) as HeqT by (eapply redtywf_whnf ; gen_typing). + destruct nfT; inversion HeqT. + + destruct nfT'; inversion HeqT'. + * constructor. + * exfalso; subst; inversion w. + + exfalso; subst; inversion w. + - intros [] -> nfT T' nfT' HΓ HT' []. + assert (T' = tEmpty) as HeqT' by (eapply redtywf_whnf ; gen_typing). + assert (T = tEmpty) as HeqT by (eapply redtywf_whnf ; gen_typing). + destruct nfT; inversion HeqT. + + destruct nfT'; inversion HeqT'. + * econstructor. + * exfalso; subst; inversion w. + + exfalso; subst; inversion w. + - intros [dom cod red] _ _ -> nfT T' nfT' HΓ HT' [dom' cod' red'] ; cbn in *. + assert (T = tSig dom cod) as HeqT by (apply red_whnf ; gen_typing). + assert (T' = tSig dom' cod') as HeqT' by (apply red_whnf ; gen_typing). + destruct nfT; cycle -1. + 1: subst; inv_whne. + all: try congruence. + destruct nfT'; cycle -1. + 1: subst; inv_whne. + all: try congruence. + inversion HeqT ; inversion HeqT' ; subst ; clear HeqT HeqT'; cbn. + eapply polyRedEqId in polyRed0 as []. + split ; now escape. + - intros [??? ty] _ _ -> nfT T' nfT' HΓ HT' [??? ty']; cbn in *. + assert (T = ty) as HeqT by (apply red_whnf; gen_typing). + assert (T' = ty') as HeqT' by (apply red_whnf; gen_typing). + destruct nfT; cycle -1; [subst; inv_whne|..]; unfold ty in *; try congruence. + destruct nfT'; cycle -1; [subst; inv_whne|..]; unfold ty' in *; try congruence. + cbn; inversion HeqT; inversion HeqT'; subst; escape; now split. + Qed. + +End TypeConstructors. + +#[local, refine] Instance RedCompleteLogRel : TypeReductionComplete (ta := de) := {}. +Proof. + all: intros ; eauto using _red_ty_complete_l, _red_ty_complete_r. + Qed. + +#[local, refine] Instance TypeConstructorsInjLogRel : TypeConstructorsInj (ta := de) := {}. +Proof. + intros. + now apply _ty_conv_inj. +Qed. + +(** ** Injectivity of term constructors *) + +Section TermConstructors. + + Import DeclarativeTypingProperties DeclarativeTypingData. + + Lemma escapeEqzero {Γ A B} (lr : [Γ ||-< zero > A]) : + [Γ |- A : U] -> + [Γ |- B : U] -> + [ Γ ||-< zero > A ≅ B | lr ] -> + [Γ |- A ≅ B : U]. + Proof. + remember zero as l eqn:e. + revert e B. + pattern l, Γ, A, lr ; eapply Induction.LR_rect_TyUr. + all: clear. + + intros ??? [? lt] -> **. + inversion lt. + + intros ??? [] -> ??? []. + cbn in *. + eapply convtm_exp. + 1-2: eapply subject_reduction ; gen_typing. + all: try solve [boundary|gen_typing]. + + + intros ??? [dom cod] * IHdom IHcod -> ??? [dom' cod' ??? [shpRed posRed]] ; cbn in *. + assert [Γ |- A ⤳* tProd dom cod : U]. + { + eapply subject_reduction ; gen_typing. + } + assert [Γ |- tProd dom cod : U] as [? [? [[-> ??] _]]%termGen']%dup + by boundary. + assert [Γ |- B ⤳* tProd dom' cod' : U]. + { + eapply subject_reduction ; gen_typing. + } + assert [Γ |- tProd dom' cod' : U] as [? [? [[-> ??] _]]%termGen']%dup + by boundary. + eapply convtm_exp ; tea. + 1-2: repeat econstructor ; boundary. + + assert [Γ |-[de] dom ≅ dom' : U]. + { + erewrite <- (wk_id_ren_on Γ dom). + unshelve eapply IHdom ; eauto. + - boundary. + - now rewrite wk_id_ren_on. + - erewrite <- (wk_id_ren_on Γ dom'). + eapply shpRed. + } + + assert [Γ,, dom |-[ de ] cod ≅ cod' : U]. + { + unshelve epose proof (IHcod _ _ _ _ _ (Neutral.var0 _ _ _)) as IHcod'. + 1: eapply wk1. + 3: rewrite wk1_ren_on ; reflexivity. + 1: econstructor ; [boundary|..]. + 1-2: now econstructor. + cbn in *. + replace cod[_] with cod in IHcod'. + 2:{ + clear. + bsimpl. + rewrite scons_eta'. + now bsimpl. + } + eapply IHcod' ; eauto. + 1: eapply stability1 ; tea. + unshelve epose proof (posRed _ _ _ _ _ (Neutral.var0 _ _ _)) as posRed'. + 1: eapply wk1. + 3: rewrite wk1_ren_on ; reflexivity. + 1: econstructor ; [boundary|..]. + 1-2: now econstructor. + cbn in *. + replace cod'[_] with cod' in posRed'. + 2:{ + clear. + bsimpl. + rewrite scons_eta'. + now bsimpl. + } + Irrelevance.irrelevance. + } + + now constructor. + + + intros ??? [] -> ??? []. + eapply convtm_exp. + 1-2: eapply subject_reduction ; gen_typing. + all: try solve [boundary|gen_typing]. + + + intros ??? [] -> ??? []. + eapply convtm_exp. + 1-2: eapply subject_reduction ; gen_typing. + all: try solve [boundary|gen_typing]. + + + + intros ??? [dom cod] * IHdom IHcod -> ??? [dom' cod' ??? [shpRed posRed]] ; cbn in *. + assert [Γ |- A ⤳* tSig dom cod : U]. + { + eapply subject_reduction ; gen_typing. + } + assert [Γ |- tSig dom cod : U] as [? [? [[-> ??] _]]%termGen']%dup + by boundary. + assert [Γ |- B ⤳* tSig dom' cod' : U]. + { + eapply subject_reduction ; gen_typing. + } + assert [Γ |- tSig dom' cod' : U] as [? [? [[-> ??] _]]%termGen']%dup + by boundary. + eapply convtm_exp ; tea. + 1-2: repeat econstructor ; boundary. + + assert [Γ |-[de] dom ≅ dom' : U]. + { + erewrite <- (wk_id_ren_on Γ dom). + unshelve eapply IHdom ; eauto. + - boundary. + - now rewrite wk_id_ren_on. + - erewrite <- (wk_id_ren_on Γ dom'). + eapply shpRed. + } + + assert [Γ,, dom |-[ de ] cod ≅ cod' : U]. + { + unshelve epose proof (IHcod _ _ _ _ _ (Neutral.var0 _ _ _)) as IHcod'. + 1: eapply wk1. + 3: rewrite wk1_ren_on ; reflexivity. + 1: econstructor ; [boundary|..]. + 1-2: now econstructor. + cbn in *. + replace cod[_] with cod in IHcod'. + 2:{ + clear. + bsimpl. + rewrite scons_eta'. + now bsimpl. + } + eapply IHcod' ; eauto. + 1: eapply stability1 ; tea. + unshelve epose proof (posRed _ _ _ _ _ (Neutral.var0 _ _ _)) as posRed'. + 1: eapply wk1. + 3: rewrite wk1_ren_on ; reflexivity. + 1: econstructor ; [boundary|..]. + 1-2: now econstructor. + cbn in *. + replace cod'[_] with cod' in posRed'. + 2:{ + clear. + bsimpl. + rewrite scons_eta'. + now bsimpl. + } + Irrelevance.irrelevance. + } + + now constructor. + + + intros ??? [T x y outTy ?] IH ? -> ??? [T' x' y' outTy' ? eq']; cbn in *. + subst outTy outTy' ; cbn in *. + assert [Γ |- A ⤳* tId T x y : U]. + { + eapply subject_reduction ; gen_typing. + } + assert [Γ |- tId T x y : U] as [? [? [[-> ??] _]]%termGen']%dup + by boundary. + assert [Γ |- B ⤳* tId T' x' y' : U]. + { + eapply subject_reduction ; gen_typing. + } + assert [Γ |- tId T' x' y' : U] as [? [? [[-> ??] _]]%termGen']%dup + by boundary. + cbv in eq' ; refold. + eapply convtm_exp ; tea. + 1-2: repeat econstructor ; boundary. + econstructor ; tea. + * now eapply IH. + * now Escape.escape. + * now Escape.escape. + + Qed. + + Theorem _univ_conv_inj : forall (Γ : context) (T T' : term) (nfT : isType T) (nfT' : isType T'), + [Γ |-[de] T ≅ T' : U] -> + univ_hd_view Γ nfT nfT' × (whne T -> [Γ |-[de] T ~ T' : U]). + Proof. + intros * Hconv. + assert [Γ |- T : U] as HT by boundary. + assert [Γ |- T' : U] as HT' by boundary. + eapply Fundamental in Hconv as [HΓ HU Hconv]. + eapply reducibleTmEq in Hconv. + set (HUred := reducibleTy _ HU) in *. + clearbody HUred. + clear HU. + assert (HTred : [Γ ||-< zero > T]) by now eapply Universe.UnivEq. + unshelve eapply Universe.UnivEqEq in Hconv ; tea. + clear HUred HΓ. + revert HTred nfT T' nfT' Hconv HT HT'. + generalize (eq_refl : zero = zero). + generalize zero at 1 3 ; intros l eql HT; revert eql. + + pattern l, Γ, T, HT ; apply Induction.LR_rect_TyUr; clear l Γ T HT. + all: intros ? Γ T. + + - intros [? lt] -> **. + now inversion lt. + + - intros [nT ? ne] -> nfT T' nfT' [nT' ? ne'] HT HT' ; cbn in *. + assert (T = nT) as <- by + (apply red_whnf ; gen_typing). + assert (T' = nT') as <- by + (apply red_whnf ; gen_typing). + destruct nfT. + 1-6: apply convneu_whne in ne; inversion ne. + destruct nfT'. + 1-6: symmetry in ne'; apply convneu_whne in ne'; inversion ne'. + cbn. + split ; gen_typing. + + - intros [dom cod red] _ _ -> nfT T' nfT' [dom' cod' red'] HT HT' ; cbn in *. + assert (T = tProd dom cod) as HeqT by (apply red_whnf ; gen_typing). + assert (T' = tProd dom' cod') as HeqT' by (apply red_whnf ; gen_typing). + destruct nfT; cycle -1. + 1: subst ; exfalso ; gen_typing. + all: try congruence. + split ; [..|intros Hne ; now inversion Hne]. + destruct nfT'; cycle -1. + 1: subst ; exfalso ; gen_typing. + all: try congruence. + inversion HeqT ; inversion HeqT' ; subst ; clear HeqT HeqT'; cbn. + edestruct (Poly.polyRedEqId _ polyRed0) ; cbn in *. + eapply termGen' in HT as [? [[]]]. + eapply termGen' in HT' as [? [[]]]. + assert [Γ |- dom' ≅ dom : U] by + (symmetry ; now eapply escapeEqzero). + split ; tea. + eapply stability1. + 1: now constructor. + eapply escapeEqzero ; tea. + eapply stability1 ; tea. + + - intros [] -> nfT T' nfT' [] ??. + assert (T' = tNat) as HeqT' by (eapply redtywf_whnf ; gen_typing). + assert (T = tNat) as HeqT by (eapply redtywf_whnf ; gen_typing). + destruct nfT; inversion HeqT. + 1: destruct nfT'; inversion HeqT'. + 2-3: exfalso; subst; inversion w. + split ; [..|intros Hne ; now inversion Hne]. + now cbn. + + - intros [] -> nfT T' nfT' [] ??. + assert (T' = tEmpty) as HeqT' by (eapply redtywf_whnf ; gen_typing). + assert (T = tEmpty) as HeqT by (eapply redtywf_whnf ; gen_typing). + destruct nfT; inversion HeqT. + 1: destruct nfT'; inversion HeqT'. + 2-3: exfalso; subst; inversion w. + split ; [..|intros Hne ; now inversion Hne]. + now cbn. + + - intros [dom cod red] _ _ -> nfT T' nfT' [dom' cod' red'] ?? ; cbn in *. + assert (T = tSig dom cod) as HeqT by (apply red_whnf ; gen_typing). + assert (T' = tSig dom' cod') as HeqT' by (apply red_whnf ; gen_typing). + destruct nfT; cycle -1. + 1: subst; inv_whne. + all: try congruence. + split ; [..|intros Hne ; now inversion Hne]. + destruct nfT'; cycle -1. + 1: subst; inv_whne. + all: try congruence. + inversion HeqT ; inversion HeqT' ; subst ; clear HeqT HeqT'; cbn. + eapply Poly.polyRedEqId in polyRed0 as []. + eapply termGen' in HT as [? [[]]]. + eapply termGen' in HT' as [? [[]]]. + assert [Γ |- dom ≅ dom' : U] by now eapply escapeEqzero. + split ; tea. + eapply escapeEqzero ; tea. + eapply stability1 ; tea. + all: boundary. + + - intros [??? ty] _ _ -> nfT T' nfT' [??? ty'] ?? ; cbn in *. + assert (T = ty) as HeqT by (apply red_whnf; gen_typing). + assert (T' = ty') as HeqT' by (apply red_whnf; gen_typing). + destruct nfT; cycle -1; [subst; inv_whne|..]; unfold ty in *; try congruence. + destruct nfT'; cycle -1; [subst; inv_whne|..]; unfold ty' in *; try congruence. + cbn; inversion HeqT; inversion HeqT'; subst ; clear HeqT HeqT' ; cbn in *. + eapply termGen' in HT as [? [[]]]. + eapply termGen' in HT' as [? [[]]]. + split ; [..|intros Hne ; now inversion Hne]. + split. + 2-3: now Escape.escape. + now eapply escapeEqzero. + Qed. + + Lemma _nat_conv_inj : forall (Γ : context) (t t' : term) (nft : isNat t) (nft' : isNat t'), + [Γ |-[de] t ≅ t' : tNat] -> + nat_hd_view Γ nft nft' × (whne t -> [Γ |-[de] t ~ t' : tNat]). + Proof. + intros * Hconv. + eapply Fundamental in Hconv as [HΓ Hnat Hconv]. + eapply Escape.reducibleTmEq in Hconv. + unshelve eapply Irrelevance.LRTmEqIrrelevant' in Hconv ; try reflexivity. + 2: now eapply Nat.natRed, Properties.soundCtx. + 1: exact one. + clear Hnat. + cbn in *. + set (nRed := {| NatRedTy.red := redtywf_refl (wft_term (ty_nat (Properties.soundCtx HΓ))) |}) in *. + clearbody nRed. + + revert nft nft'. + pattern t, t', Hconv. + unshelve eapply NatRedTmEq.NatRedTmEq_mut_rect ; clear t t' Hconv. + + - exact (fun n n' _ => forall (nft : isNat n) (nft' : isNat n'), + nat_hd_view Γ nft nft' × (whne n -> [Γ |-[de] n ~ n' : tNat])). + + - cbn. + intros t u t' u' [_ redt%redtm_sound] [_ redu%redtm_sound] ? _ IH Ht Hu. + eapply red_whnf in redt as ->, redu as ->. + 2-3: gen_typing. + eauto. + + - cbn. + intros nft nft'. + rewrite (isNat_zero nft), (isNat_zero nft') ; cbn. + split ; [easy|..]. + intros Hne ; now inversion Hne. + + - cbn. + intros ?? [] _ nft nft'. + rewrite (isNat_succ _ nft), (isNat_succ _ nft') ; cbn. + split ; [..|intros Hne ; now inversion Hne]. + eapply convtm_exp ; gen_typing. + + - cbn. + intros ?? [] nft nft' ; refold. + epose proof (isNat_ne _ nft) as [? ->]. + 1: now eapply conv_neu_ne in conv. + epose proof (isNat_ne _ nft') as [? ->]. + 1: now eapply conv_neu_ne in conv. + cbn. + split ; gen_typing. + + Qed. + + + Lemma _id_conv_inj : forall (Γ : context) (A x y t t' : term) (nft : isId t) (nft' : isId t'), + [Γ |-[de] t ≅ t' : tId A x y] -> + id_hd_view Γ A x y nft nft' × (whne t -> [Γ |-[de] t ~ t' : tId A x y]). + Proof. + intros * Hconv. + eapply Fundamental in Hconv as [HΓ Hid Hconv]. + eapply Escape.reducibleTmEq in Hconv. + set (HTred := Escape.reducibleTy _ Hid) in *. + clearbody HTred. + clear Hid. + unshelve eapply Irrelevance.LRTmEqIrrelevant' in Hconv ; try reflexivity. + 1: exact one. + 1: now eapply LRId', Induction.invLRId. + cbn in *. + clear - Hconv. + + destruct Hconv as [u u' ? ? _ p] ; cbn in *. + assert (t = u) as <- by (eapply red_whnf ; gen_typing). + assert (t' = u') as <- by (eapply red_whnf ; gen_typing). + destruct p as [? | ? ? []] ; cbn in *. + + - Escape.escape. + rewrite (isId_refl _ _ nft), (isId_refl _ _ nft') ; cbn. + split ; [..|intros Hne ; now inversion Hne]. + split. + + etransitivity ; eauto. + now symmetry. + + econstructor ; eauto. + etransitivity ; eauto. + now symmetry. + + - edestruct (isId_ne ne) as [? ->] ; [now eapply conv_neu_ne in conv |..]. + edestruct (isId_ne ne') as [? ->] ; [now eapply conv_neu_ne in conv |..]. + cbn. + unfold IdRedTyPack.outTy in conv ; cbn in *. + destruct (Id.IdRedTy_inv (Induction.invLRId HTred)) as [eA ex ey]. + rewrite <- eA, <- ex, <- ey in conv. + split ; gen_typing. + + Qed. + +End TermConstructors. + +#[local, refine] Instance TermConstructorsInjLogRel : TermConstructorsInj (ta := de) := {}. +Proof. + - intros. now eapply _univ_conv_inj. + - intros. now eapply _nat_conv_inj. + - intros. now eapply _id_conv_inj. +Qed. + +(** ** Inversion of conversion of neutrals *) + +Section NeutralConv. + + Import DeclarativeTypingProperties DeclarativeTypingData. + + Lemma _empty_conv_inj (Γ : context) (t t' : term) : + whne t -> whne t' -> + [Γ |-[de] t ≅ t' : tEmpty] -> + [Γ |-[de] t ~ t' : tEmpty]. + Proof. + intros * wt wt' Hconv. + eapply Fundamental in Hconv as [HΓ Hemp Hconv]. + eapply Escape.reducibleTmEq in Hconv. + unshelve eapply Irrelevance.LRTmEqIrrelevant' in Hconv ; try reflexivity. + 2: now eapply Empty.emptyRed, Properties.soundCtx. + 1: exact one. + clear Hemp. + cbn in *. + set (nRed := {| EmptyRedTy.red := redtywf_refl (wft_term (ty_empty (Properties.soundCtx HΓ))) |}) in *. + clearbody nRed. + + destruct Hconv as [?? ?? redL redR ? Hp]. + inversion Hp as [?? []]; subst. + erewrite red_whnf. + 2: eapply redtm_sound, redR. + 2: now econstructor. + erewrite (red_whnf t). + 2: eapply redtm_sound, redL. + 2: now econstructor. + + assumption. + + Qed. + + Lemma _neu_conv_inj (Γ : context) (A t t' : term) : + whne A -> whne t -> whne t' -> + [Γ |-[de] t ≅ t' : A] -> + [Γ |-[de] t ~ t' : A]. + Proof. + intros * wA wt wt' Hconv. + eapply Fundamental in Hconv as [HΓ Hne Hconv]. + eapply Escape.reducibleTmEq in Hconv. + unshelve eapply Irrelevance.LRTmEqIrrelevant' in Hconv ; try reflexivity. + 1: exact one. + 1:{ + eapply Neutral.neu. + 2: eapply conv_neu_refl, neutral_ty_inv ; tea. + all: now eapply Escape.escapeTy. + } + cbn in *. + + destruct Hconv as [?? redL redR ?] ; cbn in *. + erewrite red_whnf. + 2: eapply redtm_sound, redR. + 2: now econstructor. + erewrite (red_whnf t). + 2: eapply redtm_sound, redL. + 2: now econstructor. + + assumption. + + Qed. + +End NeutralConv. + +#[local, refine] Instance ConvNeutralConvPosLogRel : ConvNeutralConvPos (ta := de) := {}. +Proof. + intros * ?? [] Hconv. + - destruct s. + eapply _univ_conv_inj ; gen_typing. + - eapply _nat_conv_inj ; gen_typing. + - eapply _empty_conv_inj ; gen_typing. + - eapply _id_conv_inj ; gen_typing. + - eapply _neu_conv_inj ; gen_typing. +Qed. + +(** ** Completeness *) + +Section Completeness. + + Context `{ta : tag} + `{!WfContext ta} `{!WfType ta} `{!Typing ta} + `{!ConvType ta} `{!ConvTerm ta} `{!ConvNeuConv ta} + `{!RedType ta} `{!RedTerm ta} + `{!GenericTypingProperties ta _ _ _ _ _ _ _ _ _ _}. + + #[local, refine] Instance ConvCompleteLogRel : ConvComplete (ta := de) (ta' := ta) := {}. + Proof. + - now intros * [HΓ ? _ ?%(escapeEq (ta := ta))]%Fundamental. + - now intros * [HΓ ? ?%(escapeTmEq (ta := ta)) ]%Fundamental. + Qed. + + #[local, refine] Instance TypingCompleteLogRel : TypingComplete (ta := de) (ta' := ta) := {}. + Proof. + - now intros * [HΓ ?%(escapeTy (ta := ta))]%Fundamental. + - now intros * [_ _ ?%escapeTm]%(Fundamental (ta := ta)). + Qed. + +End Completeness. + +(** ** Weak-head normalisation *) + +Section Normalisation. + + Lemma norm_wk : forall t (ρ : nat -> nat), normalising t -> normalising t⟨ρ⟩. + Proof. + intros * [r]. + exists r⟨ρ⟩. + + now apply credalg_wk. + + now apply whnf_ren. + Qed. + + Lemma norm_exp : forall t u, [t ⤳* u] -> normalising u -> normalising t. + Proof. + intros t u ? [r]. + exists r; tea. + now etransitivity. + Qed. + + Lemma norm_whnf : forall t, whnf t -> normalising t. + Proof. + intros; exists t; tea. + reflexivity. + Qed. + + Lemma norm_isFun : forall t, isFun t -> normalising t. + Proof. + intros t []; apply norm_whnf; now constructor. + Qed. + + Lemma norm_isPair : forall t, isPair t -> normalising t. + Proof. + intros t []; apply norm_whnf; now constructor. + Qed. + + Let nf : tag := mkTag. + + #[local] Instance WfContextNf : WfContext nf := fun Γ => True. + #[local] Instance WfTypeNf : WfType nf := fun Γ A => True. + #[local] Instance TypingNf : Typing nf := fun Γ A t => True. + #[local] Instance ConvTypeNf : ConvType nf := fun Γ A B => normalising A × normalising B. + #[local] Instance ConvTermNf : ConvTerm nf := fun Γ A t u => normalising t × normalising u. + #[local] Instance ConvNeuConvNf : ConvNeuConv nf := fun Γ A m n => whne m × whne n. + #[local] Instance RedTypeNf : RedType nf := fun Γ A B => [A ⤳* B]. + #[local] Instance RedTermNf : RedTerm nf := fun Γ A t u => [t ⤳* u]. + + #[local, refine] Instance WfCtxNfProperties : WfContextProperties (ta := nf) := {}. + Proof. + all: try constructor. + Qed. + + #[local, refine] Instance WfTypeNfProperties : WfTypeProperties (ta := nf) := {}. + Proof. + all: try constructor. + Qed. + + #[local, refine] Instance TypingNfProperties : TypingProperties (ta := nf) := {}. + Proof. + all: try constructor. + Qed. + + #[local, refine] Instance ConvTypeNfProperties : ConvTypeProperties (ta := nf) := {}. + Proof. + all: try (intros; split; apply norm_whnf; now constructor). + + intros * []; now split. + + intros; split. + - intros t u []; now split. + - intros t u v [] []; now split. + + intros * ? []; split; now apply norm_wk. + + intros * ? ? []; split; now eapply norm_exp. + Qed. + + #[local, refine] Instance ConvTermNfProperties : ConvTermProperties (ta := nf) := {}. + Proof. + all: try (intros; split; apply norm_whnf; now constructor). + + intros; split. + - intros t u []; now split. + - intros t u v [] []; now split. + + intros * [] ?; now split. + + intros * ? []; split; now apply norm_wk. + + intros * ? ? ? ? ? ? []; split; now eapply norm_exp. + + intros * ? []; split; now apply norm_whnf, whnf_whne. + + intros * ? ? ? Hf ? Hg []; split. + - apply norm_isFun; destruct Hf as [|? []]; now constructor. + - apply norm_isFun; destruct Hg as [|? []]; now constructor. + + intros * ? ? ? Hp ? Hp' ?; split; apply norm_isPair. + - destruct Hp as [|? []]; now constructor. + - destruct Hp' as [|? []]; now constructor. + Qed. + + #[local, refine] Instance ConvNeuNfProperties : ConvNeuProperties (ta := nf) := {}. + Proof. + + intros; split. + - intros t u []; now split. + - intros t u v [] []; now split. + + intros * [] ?; now split. + + intros * ? []; split; now apply whne_ren. + + intros * []; assumption. + + intros; split; constructor. + + intros * [] ?; split; now constructor. + + intros * ? ? ? []; split; now constructor. + + intros * ? []; split; now constructor. + + intros * []; split; now constructor. + + intros * []; split; now constructor. + + intros * ??????? []; split; now constructor. + Qed. + + #[local, refine] Instance RedTermNfProperties : RedTermProperties (ta := nf) := {}. + Proof. + all: try now (intros; apply redalg_one_step; constructor). + + intros; now apply credalg_wk. + + intros; eassumption. + + now constructor. + + intros; now apply redalg_app. + + intros; now apply redalg_natElim. + + intros; now apply redalg_natEmpty. + + intros; now apply redalg_fst. + + intros; now apply redalg_snd. + + intros; now eapply redalg_idElim. + + intros; assumption. + + intros; reflexivity. + Qed. + + #[local, refine] Instance RedTypeNfProperties : RedTypeProperties (ta := nf) := {}. + Proof. + all: try now intros; eassumption. + + intros; now apply credalg_wk. + + constructor. + + intros; reflexivity. + Qed. + + #[local] Instance DeclarativeTypingProperties : GenericTypingProperties nf _ _ _ _ _ _ _ _ _ _ := {}. + + Corollary _tm_norm {Γ A t} : [Γ |-[de] t : A] -> normalising t. + Proof. + intros [?? H]%TermRefl%Fundamental. + eapply (escapeTmEq (ta := nf)) in H as []. + assumption. + Qed. + + Corollary _ty_norm {Γ A} : [Γ |-[de] A] -> normalising A. + Proof. + intros [??? H]%TypeRefl%Fundamental. + eapply (escapeEq (ta := nf)) in H as []. + assumption. + Qed. + +End Normalisation. + +#[local, refine] Instance NormalisationLogRel : Normalisation (ta := de) := {}. + Proof. + all: intros ; eauto using _tm_norm, _ty_norm. + Qed. + +(** ** Canonicity **) + +(** Every closed natural number is a numeral, i.e. an iteration of [tSucc] on [tZero]. *) + +Section NatCanonicityInduction. + + Import WeakDeclarativeTypingProperties WeakDeclarativeTypingData. + + Let numeral : nat -> term := fun n => Nat.iter n tSucc tZero. + + #[local] Coercion numeral : nat >-> term. + + #[local] Lemma red_nat_empty : [ε ||-Nat tNat]. + Proof. + repeat econstructor. + Qed. + + Lemma nat_red_empty_ind : + (forall t u, [ε ||-Nat t ≅ u : tNat | red_nat_empty] -> + ∑ n : nat, [ε |- t ≅ n : tNat]) × + (forall t u, NatPropEq red_nat_empty t u -> ∑ n : nat, [ε |- t ≅ n : tNat]). + Proof. + apply NatRedEqInduction. + - intros * [? []] ? ? _ [n] ; refold. + exists n. + now etransitivity. + - exists 0 ; cbn. + now repeat constructor. + - intros ? ? _ [n]. + exists (S n) ; simpl. + now econstructor. + - intros ? ? [? ? []]. + exfalso. + now eapply no_neutral_empty_ctx. + Qed. + + Lemma _nat_canonicity {t} : [ε |- t : tNat] -> + ∑ n : nat, [ε |- t ≅ n : tNat]. + Proof. + intros Ht. + assert [LRNat_ one red_nat_empty | ε ||- t : tNat] as ?%nat_red_empty_ind. + { + apply Fundamental in Ht as [?? Vt%reducibleTmEq]. + irrelevance. + } + now assumption. + Qed. + + +End NatCanonicityInduction. + +#[local, refine] Instance NatCanonicityLogRel : NatCanonicity (ta := de) := {}. +Proof. + auto using _nat_canonicity. +Qed. \ No newline at end of file diff --git a/theories/TypingProperties/NeutralConvProperties.v b/theories/TypingProperties/NeutralConvProperties.v new file mode 100644 index 00000000..3ffbbfd0 --- /dev/null +++ b/theories/TypingProperties/NeutralConvProperties.v @@ -0,0 +1,497 @@ +(** * LogRel.NeutralConvProperties: properties of declarative neutral conversion, using type constructor injectivity. *) +From Coq Require Import CRelationClasses. +From LogRel Require Import Utils Syntax.All GenericTyping DeclarativeTyping. +From LogRel.TypingProperties Require Import PropertiesDefinition DeclarativeProperties SubstConsequences TypeConstructorsInj. + +Set Printing Primitive Projection Parameters. + +Import DeclarativeTypingData. + +(** ** Properties of neutral conversion *) + +(** Note that some of these properties require injectivity of type constructors, which we need the above +instance to prove! *) + +Section NeuConvProperties. + Context `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)}. + + Lemma conv_neu_wk Γ Δ (ρ : Δ ≤ Γ) A m n : + [|- Δ] -> + [Γ |- m ~ n : A] -> + [Δ |- m⟨ρ⟩ ~ n ⟨ρ⟩ : A⟨ρ⟩]. + Proof. + intros HΔ. + induction 1 ; eauto. + - econstructor ; eauto. + now eapply in_ctx_wk. + - cbn in * ; eapply convne_meta_conv. + 3: reflexivity. + 1: econstructor ; eauto. + 2: now bsimpl. + now eapply typing_wk. + + - erewrite (subst_ren_wk_up (A := tNat)). + econstructor ; eauto. + + erewrite <- !(wk_up_ren_on _ _ _ tNat). + eapply typing_wk ; eauto. + econstructor ; cbn ; eauto. + now econstructor. + + eapply convtm_meta_conv. + 1: eapply typing_wk ; eauto. + all: now bsimpl. + + eapply convtm_meta_conv. + 1: eapply typing_wk ; eauto. + all: unfold elimSuccHypTy ; now bsimpl. + + - erewrite subst_ren_wk_up. + econstructor ; eauto. + erewrite <- !(wk_up_ren_on _ _ _ tEmpty). + eapply typing_wk ; eauto. + econstructor ; cbn ; eauto. + now econstructor. + + - now econstructor. + + - cbn in * ; eapply convne_meta_conv. + 1: now econstructor. + all: now bsimpl. + + - rewrite <- ! wk_idElim. + assert [|- Δ ,, A⟨ρ⟩] by (constructor; tea; eapply typing_wk ; boundary). + cbn in * ; eapply convne_meta_conv. + 1: econstructor ; eauto. + all: try solve [now eapply typing_wk]. + + rewrite 2!(wk_up_wk1 ρ). + eapply typing_wk ; eauto. + change (up_ren ρ) with (wk_up A ρ :> nat -> nat). + econstructor ; tea ; econstructor. + * rewrite <- wk_up_wk1, wk_step_wk1; eapply typing_wk ; boundary. + * rewrite <- 2!wk_up_wk1, 2!wk_step_wk1; now eapply typing_wk ; boundary. + * rewrite <- wk_up_wk1, wk1_ren_on; cbn; constructor; tea; constructor. + + eapply convtm_meta_conv. + 1: now eapply typing_wk. + 2: reflexivity. + now bsimpl. + + now bsimpl. + + now bsimpl. + + - econstructor ; eauto. + now eapply typing_wk. + + Qed. + + Lemma conv_neu_sound Γ A m n : + [Γ |- m ~ n : A] -> + [Γ |- m ≅ n : A]. + Proof. + induction 1 ; econstructor ; eauto. + - now econstructor. + - boundary. + - boundary. + Qed. + + Lemma boundary_neu_conv_l Γ A m n : + [Γ |- m ~ n : A] -> + [Γ |- m : A]. + Proof. + intros ?%conv_neu_sound. + boundary. + Qed. + + Lemma boundary_neu_conv_r Γ A m n : + [Γ |- m ~ n : A] -> + [Γ |- n : A]. + Proof. + intros ?%conv_neu_sound. + boundary. + Qed. + + Lemma boundary_neu_conv_ty Γ A m n : + [Γ |- m ~ n : A] -> + [Γ |- A]. + Proof. + intros ?%conv_neu_sound. + boundary. + Qed. + + Lemma conv_neu_ne Γ A m n : + [Γ |- m ~ n : A] -> + whne m × whne n. + Proof. + induction 1 ; eauto ; split ; econstructor ; now prod_hyp_splitter. + Qed. + + Definition neuGenData (Γ : context) (T t t' : term) : Type := + match t with + | tRel n => ∑ decl, [× t' = tRel n, [|- Γ], in_ctx Γ n decl & [Γ |- decl ≅ T]] + | tApp f a => ∑ A B f' a', + [× t' = tApp f' a', [Γ |- f ~ f' : tProd A B], [Γ |- a ≅ a' : A] & [Γ |- B[a..] ≅ T]] + | tNatElim P hz hs n => ∑ P' hz' hs' n', + [× t' = tNatElim P' hz' hs' n', + [Γ,, tNat |- P ≅ P'], [Γ |- hz ≅ hz' : P[tZero..]], [Γ |- hs ≅ hs' : elimSuccHypTy P], + [Γ |- n ~ n' : tNat] & [Γ |- P[n..] ≅ T]] + | tEmptyElim P e => ∑ P' e', + [× t' = tEmptyElim P' e', [Γ,, tEmpty |- P ≅ P'], [Γ |- e ~ e' : tEmpty] & [Γ |- P[e..] ≅ T]] + | tFst p => ∑ A B p', [× t' = tFst p', [Γ |- p ~ p' : tSig A B] & [Γ |- A ≅ T]] + | tSnd p => ∑ A B p', [× t' = tSnd p', [Γ |- p ~ p' : tSig A B] & [Γ |- B[(tFst p)..] ≅ T ]] + | tIdElim A x P hr y e => ∑ A' x' P' hr' y' e', + [× t' = tIdElim A' x' P' hr' y' e', + [Γ |- A ≅ A'], [Γ |- x ≅ x' : A], [Γ,, A,, tId A⟨@wk1 Γ A⟩ x⟨@wk1 Γ A⟩ (tRel 0) |- P ≅ P'], + [Γ |- hr ≅ hr' : P[tRefl A x .: x..]], [Γ |- y ≅ y' : A], [Γ |- e ~ e' : tId A x y] + & [Γ |- P[e .: y..] ≅ T]] + | _ => False + end. + + Lemma neuConvGen Γ T t t' : + [Γ |- t ~ t' : T] -> + neuGenData Γ T t t'. + Proof. + induction 1 ; cbn ; repeat esplit ; eauto. + - econstructor. + now eapply in_ctx_wf. + - econstructor. + eapply typing_subst1. + 1: boundary. + eapply prod_ty_inv. + eauto using conv_neu_sound with boundary. + - econstructor. + eapply typing_subst1. + all: eauto using conv_neu_sound with boundary. + - econstructor. + eapply typing_subst1. + all: eauto using conv_neu_sound with boundary. + - econstructor. + eapply sig_ty_inv. + eauto using conv_neu_sound with boundary. + - econstructor. + eapply typing_subst1. + 1: econstructor. + 2: eapply sig_ty_inv. + all: eauto using conv_neu_sound with boundary. + - econstructor. + eapply typing_subst2 ; last first. + + boundary. + + cbn. + eapply typing_meta_conv. + 1: eauto using conv_neu_sound with boundary. + now bsimpl. + + boundary. + + boundary. + - destruct n ; cbn in * ; eauto. + all: prod_hyp_splitter ; subst. + all: repeat esplit ; eauto. + all: now eapply TypeTrans. + Qed. + + Lemma conv_neu_refl Γ A n : + whne n -> + [Γ |- n : A] -> + [Γ |- n ~ n : A]. + Proof. + intros wn Hty. + induction wn in A, Hty |- *. + all: eapply termGen' in Hty ; cbn in * ; prod_hyp_splitter ; subst. + all: eapply neuConvConv ; tea. + all: econstructor ; eauto. + all: now econstructor. + Qed. + + Lemma conv_neu_sym Γ A m n : + [Γ |- m ~ n : A] -> + [Γ |- n ~ m : A]. + Proof. + induction 1 ; cbn in * ; refold. + + - now econstructor. + + - assert [Γ |- a' ≅ a : A] by now eapply TermSym. + econstructor. + 1: econstructor ; eauto. + eapply typing_subst1 ; eauto. + constructor. + eapply prod_ty_inv. + eauto using conv_neu_sound with boundary. + + - econstructor. + 1: econstructor ; eauto. + + now eapply TypeSym. + + econstructor. + 1: now eapply TermSym. + eapply typing_subst1 ; tea. + do 2 constructor. + boundary. + + eapply TermConv ; refold. + 1: now eapply TermSym. + eapply elimSuccHypTy_conv ; boundary. + + eapply TypeSym, typing_subst1 ; eauto using conv_neu_sound. + + - econstructor. + 1: econstructor ; eauto. + + now eapply TypeSym. + + eapply TypeSym, typing_subst1 ; eauto using conv_neu_sound. + + - now econstructor. + + - econstructor. + 1: econstructor ; eauto. + eapply typing_subst1. + + econstructor. + eapply TermSym. + now eapply conv_neu_sound. + + econstructor. + eapply sig_ty_inv. + eauto using conv_neu_sound with boundary. + + - assert [Γ |- A' ≅ A] by now eapply TypeSym. + assert [Γ |- x' ≅ x : A'] by + (econstructor ; tea ; now eapply TermSym). + assert [|- Γ,, A'] by (econstructor ; now boundary). + econstructor. + 1: econstructor ; eauto with boundary. + + eapply TypeSym. + eapply stability ; eauto. + econstructor. + 1: econstructor ; eauto using ctx_refl with boundary. + econstructor. + * erewrite (wk1_irr (A := A)). + now eapply typing_wk. + * erewrite (wk1_irr (A := A)). + now eapply typing_wk. + * do 2 econstructor ; eauto. + rewrite wk1_ren_on. + now econstructor. + + econstructor. + 1: now eapply TermSym. + eapply typing_subst2 ; eauto with boundary. + econstructor ; cbn in *. + 1: now econstructor. + replace (tId _[_] _[_] _) with (tId A x x) by now bsimpl. + do 2 econstructor ; boundary. + + econstructor ; tea. + now econstructor. + + econstructor ; tea. + now econstructor. + + eapply TypeSym ; refold. + eapply typing_subst2 ; eauto with boundary. + cbn. + eapply convtm_meta_conv ; eauto using conv_neu_sound. + now bsimpl. + + - econstructor ; eauto. + + Qed. + + Lemma conv_neu_typing Γ T T' n n' : + [Γ |- n ~ n' : T] -> + [Γ |- n' : T'] -> + [Γ |- T ≅ T']. + Proof. + intros Hconv Hty. + induction Hconv in T', Hty |- *. + + - eapply termGen' in Hty as [? [[]]]. + prod_hyp_splitter ; subst. + eapply in_ctx_inj in i ; [..|eassumption] ; subst. + assumption. + + - eapply termGen' in Hty as [? [(?&?&[-> []%IHHconv%prod_ty_inj])]]. + eapply TypeTrans ; tea. + eapply typing_subst1. + 2: eassumption. + econstructor ; eauto. + now eapply TypeSym. + + - eapply termGen' in Hty as [? [[->]]]. + eapply TypeTrans ; tea. + eapply typing_subst1 ; tea. + now eapply conv_neu_sound. + + - eapply termGen' in Hty as [? [[->]]]. + eapply TypeTrans ; tea. + eapply typing_subst1 ; tea. + now eapply conv_neu_sound. + + - eapply termGen' in Hty as [? [(?&?&[-> []%IHHconv%sig_ty_inj])]]. + now eapply TypeTrans. + + - eapply termGen' in Hty as [? [(?&?&[-> []%IHHconv%sig_ty_inj])]]. + eapply TypeTrans ; tea. + eapply typing_subst1. + 2: eassumption. + econstructor ; eauto. + now eapply conv_neu_sound. + + - eapply termGen' in Hty as [? [[->]]] ; refold. + eapply TypeTrans ; tea. + eapply typing_subst2 ; tea. + 1: boundary. + cbn. + eapply convtm_meta_conv. + 1: now eapply conv_neu_sound. + all: now bsimpl. + + - eapply TypeTrans ; refold ; eauto. + now eapply TypeSym. + + Qed. + + + Lemma conv_neu_trans Γ A n1 n2 n3 : + [Γ |- n1 ~ n2 : A] -> + [Γ |- n2 ~ n3 : A] -> + [Γ |- n1 ~ n3 : A]. + Proof. + intros H H'. + induction H in n3, H' |- *. + 1-7: eapply neuConvGen in H' ; cbn in * ; refold ; prod_hyp_splitter ; subst. + - now econstructor. + - eapply conv_neu_typing in H. + 2: clear H ; eauto using conv_neu_sound with boundary. + econstructor ; eauto. + + eapply IHDeclNeutralConversion. + econstructor ; eauto. + now apply TypeSym. + + eapply TermTrans ; eauto. + econstructor ; tea. + now eapply prod_ty_inj in H. + - econstructor ; eauto. + + now eapply TypeTrans. + + eapply TermTrans ; tea. + econstructor ; tea. + eapply TypeSym, typing_subst1 ; tea. + do 2 econstructor ; boundary. + + eapply TermTrans ; tea. + econstructor ; tea. + eapply TypeSym, elimSuccHypTy_conv ; tea. + all: boundary. + - econstructor ; eauto. + now eapply TypeTrans. + - econstructor ; eauto. + eapply IHDeclNeutralConversion. + econstructor ; tea. + eapply TypeSym, conv_neu_typing ; tea. + eauto using conv_neu_sound with boundary. + - econstructor ; eauto. + eapply IHDeclNeutralConversion. + econstructor ; tea. + eapply TypeSym, conv_neu_typing ; tea. + eauto using conv_neu_sound with boundary. + - assert [|- Γ,, A ≅ Γ ,, A'] by + (constructor ; eauto using ctx_refl with boundary). + econstructor ; eauto. + + now eapply TypeTrans. + + eapply TermTrans ; tea. + econstructor ; tea. + now eapply TypeSym. + + eapply TypeTrans ; tea. + eapply stability ; tea. + econstructor ; tea. + econstructor ; tea. + * erewrite (wk1_irr (A := A')). + eapply typing_wk ; boundary. + * erewrite (wk1_irr (A := A')). + eapply typing_wk ; boundary. + * do 2 econstructor ; eauto. + 1: boundary. + rewrite wk1_ren_on. + now econstructor. + + eapply TermTrans ; tea ; refold. + econstructor ; tea. + eapply typing_subst2 ; eauto ; cycle -1. + * now apply TypeSym. + * boundary. + * now apply TermSym. + * cbn. + eapply TermSym ; refold. + replace (tId _ _ _) with (tId A x x') by now bsimpl. + econstructor. + 1: now econstructor. + constructor ; tea. + all: now constructor ; boundary. + + eapply TermTrans ; eauto ; refold. + econstructor ; tea. + now apply TypeSym. + + eapply IHDeclNeutralConversion ; eauto. + econstructor ; tea. + eapply TypeSym. + now econstructor. + - econstructor ; eauto. + eapply IHDeclNeutralConversion. + econstructor ; eauto. + now eapply TypeSym. + Qed. + +End NeuConvProperties. + +#[export] Hint Resolve boundary_neu_conv_l boundary_neu_conv_r boundary_neu_conv_ty : boundary. + +Module DeclarativeTypingProperties. + Export DeclarativeTypingData. + + Import WeakDeclarativeTypingProperties. + + #[export] Existing Instance WfCtxDeclProperties. + #[export] Existing Instance WfTypeDeclProperties. + #[export] Existing Instance TypingDeclProperties. + #[export] Existing Instance ConvTypeDeclProperties. + #[export] Existing Instance RedTermDeclProperties. + #[export] Existing Instance RedTypeDeclProperties. + + #[export, refine] Instance ConvTermDeclProperties + `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} + : ConvTermProperties (ta := de) := {}. + Proof. + 4,7,11: shelve. + all: gen_typing. + Unshelve. + - intros. + apply conv_neu_sound. + assumption. + - intros * ??? Hf ? Hg **. + eapply (convtm_eta (ConvNeuConv0 := WeakDeclarativeTypingData.ConvNeuConv_WeakDecl)) ; eauto. + + inversion Hf ; subst. + all: constructor ; eauto. + split. + 1-2: now eapply conv_neu_ne. + now eapply conv_neu_sound. + + inversion Hg ; subst. + all: constructor ; eauto. + split. + 1-2: now eapply conv_neu_ne. + now eapply conv_neu_sound. + - intros * ??? Hp ? Hp' **. + eapply (convtm_eta_sig (ConvNeuConv0 := WeakDeclarativeTypingData.ConvNeuConv_WeakDecl)) ; eauto. + + inversion Hp ; subst. + all: constructor ; eauto. + split. + 1-2: now eapply conv_neu_ne. + now eapply conv_neu_sound. + + inversion Hp' ; subst. + all: constructor ; eauto. + split. + 1-2: now eapply conv_neu_ne. + now eapply conv_neu_sound. + Qed. + + #[export, refine] Instance ConvNeuDeclProperties + `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} : + ConvNeuProperties (ta := de) := {}. + Proof. + all: try solve [now econstructor]. + - split; red. + + eauto using conv_neu_sym. + + eauto using conv_neu_trans. + - intros. + eauto using conv_neu_wk. + - now intros * ?%conv_neu_ne. + - intros * H. + eapply termGen' in H as [? [[? [->]]]]. + eapply neuConvConv ; tea. + now econstructor. + Qed. + + #[export] Instance DeclarativeTypingProperties + `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} : + GenericTypingProperties de _ _ _ _ _ _ _ _ _ _ := {}. + +End DeclarativeTypingProperties. \ No newline at end of file diff --git a/theories/TypingProperties/NormalisationConsequences.v b/theories/TypingProperties/NormalisationConsequences.v new file mode 100644 index 00000000..4e0f1431 --- /dev/null +++ b/theories/TypingProperties/NormalisationConsequences.v @@ -0,0 +1,74 @@ +(** * LogRel.NormalisationConsequences: direct consequences of normalisation. *) +From Coq Require Import CRelationClasses. +From LogRel Require Import Utils Syntax.All GenericTyping DeclarativeTyping PropertiesDefinition SubstConsequences TypeConstructorsInj. + +Import DeclarativeTypingData. + +(** ** Well-foundedness of reduction *) + +Theorem typing_acc_cored Γ t `{!Normalisation (ta := de)} : + well_formed Γ t -> + Acc cored t. +Proof. + intros [[] Hty]. + all: first [ + apply ty_norm in Hty as [wh red] | + apply tm_norm in Hty as [wh red]]. + all: induction red. + - econstructor. + intros t' [red]. + exfalso. + eapply whnf_nored ; tea. + - econstructor. + intros t'' [red']. + eapply ored_det in red' as <-; [|exact o]. + apply IHred; tea. + - econstructor. + intros t' [red]. + exfalso. + now eapply whnf_nored. + - econstructor. + intros t'' [red']. + eapply ored_det in red' as <-; [|exact o]. + apply IHred; tea. +Qed. + +(** ** Consistency *) +(** There are no closed proofs of false, i.e. no closed inhabitants of the empty type.*) + +Section Consistency. + Context `{!TypingSubst (ta := de)} + `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)} + `{!Normalisation (ta := de)}. + + + Lemma no_neutral_empty_ctx {A t} : whne t -> [ε |-[de] t : A] -> False. + Proof. + intros wh; induction wh in A |- *. + - intros [? [[? [?? h]]]]%termGen'; inversion h. + - intros [? [[? [? []]]]]%termGen'; eauto. + - intros [? [[? []]]]%termGen'; eauto. + - intros [? [[? []]]]%termGen'; eauto. + - intros [? [[? [? []]]]]%termGen'; eauto. + - intros [? [[? [? []]]]]%termGen'; eauto. + - intros [? [[?]]]%termGen'; eauto. + Qed. + + Lemma wty_norm {Γ t A} : [Γ |- t : A] -> + ∑ wh, [× whnf wh, [Γ |- t ⤳* wh : A]& [Γ |- wh : A]]. + Proof. + intros wtyt. + pose proof (tm_norm wtyt) as [wh red]. + pose proof (h := subject_reduction _ _ _ _ wtyt red). + assert [Γ |- wh : A] by (destruct h; boundary). + now eexists. + Qed. + + Lemma consistency {t} : [ε |- t : tEmpty] -> False. + Proof. + intros [wh []]%wty_norm; refold. + eapply no_neutral_empty_ctx; tea. + eapply empty_isEmpty; tea. + Qed. + +End Consistency. \ No newline at end of file diff --git a/theories/TypingProperties/PropertiesDefinition.v b/theories/TypingProperties/PropertiesDefinition.v new file mode 100644 index 00000000..798dfac2 --- /dev/null +++ b/theories/TypingProperties/PropertiesDefinition.v @@ -0,0 +1,198 @@ +(** * LogRel.PropertiesDefinition: the high-level, abstract properties of conversion and typing, that we obtain as consequences of the logical relation. *) +From Coq Require Import CRelationClasses ssrbool. +From LogRel Require Import Utils Syntax.All GenericTyping. + +Section Properties. + + Context `{ta : tag} + `{!WfContext ta} `{!WfType ta} `{!Typing ta} `{!ConvType ta} `{!ConvTerm ta} `{!ConvNeuConv ta} + `{!RedType ta} `{!RedTerm ta}. + + + (** Typing is stable by substitution *) + Class TypingSubst := + { + ty_subst {Γ Δ σ A} : + [|- Δ] -> [Δ |-s σ : Γ] -> + [Γ |- A] -> [Δ |- A[σ]]; + tm_subst {Γ Δ σ A t} : + [|- Δ] -> [Δ |-s σ : Γ] -> + [Γ |- t : A] -> [Δ |- t[σ] : A[σ]]; + ty_conv_subst {Γ Δ σ σ' A B} : + [|- Δ] -> [Δ |-s σ ≅ σ' : Γ] -> + [Γ |- A ≅ B] -> [Δ |- A[σ] ≅ B[σ']]; + tm_conv_subst {Γ Δ σ σ' A t u} : + [|- Δ] -> [Δ |-s σ ≅ σ' : Γ] -> + [Γ |- t ≅ u : A] -> [Δ |- t[σ] ≅ u[σ'] : A[σ]] ; + }. + + Class Strengthening := + { + ty_str {Γ Δ A} (ρ : Γ ≤ Δ) : + [|- Δ] -> + [Γ |- A⟨ρ⟩] -> [Δ |- A]; + tm_str {Γ Δ A t} (ρ : Γ ≤ Δ) : + [|- Δ] -> + [Γ |- t⟨ρ⟩ : A⟨ρ⟩] -> [Δ |- t : A]; + ty_conv_str {Γ Δ A B} (ρ : Γ ≤ Δ) : + [|- Δ] -> + [Γ |- A⟨ρ⟩ ≅ B⟨ρ⟩] -> [Δ |- A ≅ B]; + tm_conv_str {Γ Δ A t u} (ρ : Γ ≤ Δ) : + [|- Δ] -> + [Γ |- t⟨ρ⟩ ≅ u⟨ρ⟩ : A⟨ρ⟩] -> [Δ |- t ≅ u : A] ; + }. + + (** Reduction is complete for type conversion: if a + type is convertible to a whnf, then it also reduces + to a whnf. *) + Class TypeReductionComplete := + { + red_ty_complete_l (Γ : context) (T T' : term) : + isType T -> + [Γ |- T ≅ T'] -> + ∑ T'', [Γ |- T' ⤳* T''] × isType T'' ; + + red_ty_complete_r (Γ : context) (T T' : term) : + isType T' -> + [Γ |- T ≅ T'] -> + ∑ T'', [Γ |- T ⤳* T''] × isType T'' ; + }. + + Definition type_hd_view (Γ : context) {T T' : term} + (nfT : isType T) (nfT' : isType T') : Type := + + match nfT, nfT' with + | @UnivType s, @UnivType s' => s = s' + | @ProdType A B, @ProdType A' B' => [Γ |- A' ≅ A] × [Γ,, A' |- B ≅ B'] + | NatType, NatType => True + | EmptyType, EmptyType => True + | NeType _, NeType _ => [Γ |- T ≅ T' : U] + | @SigType A B, @SigType A' B' => [Γ |- A ≅ A'] × [Γ,, A |- B ≅ B'] + | @IdType A x y, @IdType A' x' y' => [× [Γ |- A ≅ A'], [Γ |- x ≅ x' : A] & [Γ |- y ≅ y' : A]] + | _, _ => False + end. + + (** Type constructors injectivity/no-confusion: two + convertible whnf types must be the same head constructor, + with convertible arguments. *) + + Class TypeConstructorsInj := + { + ty_conv_inj (Γ : context) (T T' : term) + (nfT : isType T) (nfT' : isType T') : + [Γ |- T ≅ T'] -> + type_hd_view Γ nfT nfT' + }. + + (** Similar notions for term constructors at positive types. *) + + Definition univ_hd_view (Γ : context) {T T' : term} (nfT : isType T) (nfT' : isType T') : Type := + match nfT, nfT' with + | @UnivType s, @UnivType s' => False + | @ProdType A B, @ProdType A' B' => [Γ |- A' ≅ A : U] × [Γ,, A' |- B ≅ B' : U] + | NatType, NatType => True + | EmptyType, EmptyType => True + | NeType _, NeType _ => [Γ |- T ≅ T' : U] + | @SigType A B, @SigType A' B' => [Γ |- A ≅ A' : U] × [Γ,, A |- B ≅ B' : U] + | @IdType A x y, @IdType A' x' y' => [× [Γ |- A ≅ A' : U], [Γ |- x ≅ x' : A] & [Γ |- y ≅ y' : A]] + | _, _ => False + end. + + Definition nat_hd_view (Γ : context) {t t' : term} (nft : isNat t) (nft' : isNat t') : Type := + match nft, nft' with + | ZeroNat, ZeroNat => True + | @SuccNat u, @SuccNat u' => [Γ |- u ≅ u' : tNat] + | NeNat _, NeNat _ => [Γ |- t ≅ t' : tNat ] + | _, _ => False + end. + + Definition id_hd_view (Γ : context) (A x x' : term) {t t' : term} (nft : isId t) (nft' : isId t') : Type := + match nft, nft' with + | @ReflId A a, @ReflId A' a' => [Γ |- A ≅ A'] × [Γ |- a ≅ a' : A] + | NeId _, NeId _ => [Γ |- t ≅ t' : tId A x x'] + | _, _ => False + end. + + Class TermConstructorsInj := + { + univ_conv_inj (Γ : context) (T T' : term) + (nfT : isType T) (nfT' : isType T') : + [Γ |- T ≅ T' : U] -> + univ_hd_view Γ nfT nfT' ; + + nat_conv_inj (Γ : context) (t t' : term) + (nft : isNat t) (nft' : isNat t') : + [Γ |- t ≅ t' : tNat] -> + nat_hd_view Γ nft nft' ; + + (* empty_conv_inj (Γ : context) (t t' : term) : + whne t -> whne t' -> + [Γ |- t ≅ t' : tEmpty] -> + [Γ |- t ~ t' : tEmpty] ; *) + + id_conv_inj (Γ : context) (A x y t t' : term) + (nft : isId t) (nft' : isId t') : + [Γ |- t ≅ t' : tId A x y] -> + id_hd_view Γ A x y nft nft' ; + + (* neu_conv_inj (Γ : context) (A t t' : term) : + whne A -> whne t -> whne t' -> + [Γ |- t ≅ t' : A] -> + [Γ |- t ~ t' : A] *) + }. + + Class ConvNeutralConvPos := + { + conv_neu_conv_p Γ T n n' : + whne n -> whne n' -> isPosType T -> + [Γ |- n ≅ n' : T] -> + [Γ |- n ~ n' : T] + }. + + Class ConvNeutralConv := + { + conv_neu_conv Γ T n n' : + whne n -> whne n' -> + [Γ |- n ≅ n' : T] -> + [Γ |- n ~ n' : T] + }. + + (** ** Normalisation *) + + Record normalising (t : term) := { + norm_val : term; + norm_red : [ t ⤳* norm_val ]; + norm_whnf : whnf norm_val; + }. + + Class Normalisation := + { + tm_norm {Γ A t} : [Γ |- t : A] -> normalising t ; + ty_norm {Γ A} : [Γ |- A] -> normalising A ; + }. + + (** ** Canonicity for natural numbers *) + + Class NatCanonicity := + { + nat_canonicity {t} : [ε |- t : tNat] -> + ∑ n : nat, [ε |- t ≅ Nat.iter n tSucc tZero : tNat] + }. + + Context `{ta' : tag} + `{!WfContext ta'} `{!WfType ta'} `{!Typing ta'} `{!ConvType ta'} `{!ConvTerm ta'} `{!ConvNeuConv ta'} + `{!RedType ta'} `{!RedTerm ta'}. + + (** ** Completeness (of typing `ta'` with respect to typing `ta`). *) + + Class ConvComplete := { + ty_conv_compl Γ A A' : [Γ |-[ta] A ≅ A'] -> [Γ |-[ta'] A ≅ A'] ; + tm_conv_compl Γ A t t' : [Γ |-[ta] t ≅ t' : A] -> [Γ |-[ta'] t ≅ t' : A] ; + }. + + Class TypingComplete := { + ty_compl Γ A : [Γ |-[ta] A] -> [Γ |-[ta'] A] ; + tm_compl Γ A t : [Γ |-[ta] t : A] -> [Γ |-[ta'] t : A] ; + }. + +End Properties. \ No newline at end of file diff --git a/theories/TypingProperties/SubstConsequences.v b/theories/TypingProperties/SubstConsequences.v new file mode 100644 index 00000000..207cf286 --- /dev/null +++ b/theories/TypingProperties/SubstConsequences.v @@ -0,0 +1,803 @@ +(** * LogRel.SubstConsequences: consequences of stability by substitution. *) +From Coq Require Import CRelationClasses. +From LogRel Require Import Utils Syntax.All DeclarativeTyping GenericTyping. +From LogRel.TypingProperties Require Import DeclarativeProperties PropertiesDefinition. + +(** Many lemmas in this file, prefixed by an underscore, have extraneous premises, which we cannot remove directly because of circular dependencies. The "correct" version is the one without underscore. *) + +Set Printing Primitive Projection Parameters. + +Import WeakDeclarativeTypingProperties. + +Section MoreSubst. + + Context `{!TypingSubst (ta := de)}. + + Lemma ctx_refl Γ : + [|- Γ] -> + [|- Γ ≅ Γ]. + Proof. + induction 1. + all: constructor; tea. + now econstructor. + Qed. + + Lemma subst_wk (Γ Δ Δ' : context) (ρ : Δ' ≤ Δ) σ : + [|- Δ'] -> + [Δ |-s σ : Γ] -> + [Δ' |-s σ⟨ρ⟩ : Γ]. + Proof. + intros ?. + induction 1 as [|σ Γ A]. + 1: now econstructor. + econstructor. + - asimpl ; cbn in * ; asimpl. + eassumption. + - asimpl ; cbn in * ; asimpl. + unfold funcomp. + eapply typing_meta_conv. + 1: eapply typing_wk ; eassumption. + asimpl. + reflexivity. + Qed. + + Corollary well_subst_up (Γ Δ : context) A σ : + [Δ |- A] -> + [Δ |-s σ : Γ] -> + [Δ ,, A |-s σ⟨↑⟩ : Γ]. + Proof. + intros HA Hσ. + eapply subst_wk with (ρ := wk_step A wk_id) in Hσ. + - eapply well_subst_ext ; [|eassumption]. + bsimpl. + now reflexivity. + - econstructor. + all: gen_typing. + Qed. + + Lemma id_subst (Γ : context) : + [|- Γ] -> + [Γ |-s tRel : Γ]. + Proof. + induction 1. + all: econstructor. + - eapply well_subst_ext. + 2: now eapply well_subst_up. + now asimpl. + - eapply typing_meta_conv. + 1: now do 2 econstructor. + cbn ; now renamify. + Qed. + + Lemma subst_refl (Γ Δ : context) σ : + [Γ |-s σ : Δ] -> + [Γ |-s σ ≅ σ : Δ]. + Proof. + induction 1. + all: econstructor ; tea. + now eapply TermRefl. + Qed. + + Theorem typing_subst1 Γ T : + (forall (t : term), [Γ |- t : T] -> + forall (A : term), [Γ,, T |- A] -> [Γ |- A[t..]]) × + (forall (t : term), [Γ |- t : T] -> + forall (A u : term), [Γ,, T |- u : A] -> [Γ |- u[t..] : A[t..]]) × + (forall (t t' : term), [Γ |- t ≅ t' : T] -> + forall (A B : term), [Γ,, T |- A ≅ B] -> [Γ |- A[t..] ≅ B[t'..]]) × + (forall (t t' : term), [Γ |- t ≅ t' : T] -> + forall (A u v : term), [Γ,, T |- u ≅ v : A] -> [Γ |- u[t..] ≅ v[t'..] : A[t..]]). + Proof. + repeat match goal with |- _ × _ => split end. + all: intros * Ht * Hty. + all: assert ([|- Γ]) by gen_typing. + all: assert ([Γ |-s tRel : Γ]) as Hsubst by now eapply id_subst. + 3-4: apply subst_refl in Hsubst. + all: first [eapply ty_subst| eapply tm_subst | eapply ty_conv_subst | eapply tm_conv_subst] ; tea. + all: econstructor ; cbn ; refold ; now asimpl. + Qed. + + Theorem typing_substmap1 Γ T : + (forall (t : term), [Γ ,, T |- t : T⟨↑⟩] -> + forall (A : term), [Γ,, T |- A] -> + [Γ,, T |- A[t]⇑]) × + (forall (t : term), [Γ ,, T |- t : T⟨↑⟩] -> + forall (A u : term), [Γ,, T |- u : A] -> + [Γ,, T |- u[t]⇑ : A[t]⇑]) × + (forall (t t' : term), [Γ ,, T |- t ≅ t' : T⟨↑⟩] -> + forall (A B : term), [Γ,, T |- A ≅ B] -> + [Γ,, T |- A[t]⇑ ≅ B[t']⇑]) × + (forall (t t' : term), [Γ ,, T |- t ≅ t' : T⟨↑⟩] -> + forall (A u v : term), [Γ,, T |- u ≅ v : A] -> + [Γ,, T |- u[t]⇑ ≅ v[t']⇑ : A[t]⇑]). + Proof. + repeat match goal with |- _ × _ => split end. + all: intros * Ht * Hty. + all: assert ([|- Γ,, T] × [|- Γ]) as [] by (split; repeat boundary). + all : assert (Hsubst : [Γ ,, T |-s ↑ >> tRel : Γ]) + by (change (?x >> ?y) with y⟨x⟩; eapply well_subst_up; [boundary| now eapply id_subst]). + 3-4: apply subst_refl in Hsubst. + all: first [eapply ty_subst| eapply tm_subst | eapply ty_conv_subst | eapply tm_conv_subst] ; tea. + all: econstructor ; cbn ; refold; bsimpl; try rewrite <- rinstInst'_term; tea. + Qed. + + Lemma scons2_well_subst {Γ A B} : + (forall a b, [Γ |- a : A] -> [Γ |- b : B[a..]] -> [Γ |-s (b .: a ..) : (Γ ,, A),, B]) + × (forall a a' b b', [Γ |- a ≅ a' : A] -> [Γ |- b ≅ b' : B[a..]] -> [Γ |-s (b .: a..) ≅ (b' .: a'..) : (Γ ,, A),, B]). + Proof. + assert (h : forall (a : term) σ, ↑ >> (a .: σ) =1 σ) by reflexivity. + assert (h' : forall a σ t, t[↑ >> (a .: σ)] = t[σ]) by (intros; now setoid_rewrite h). + split; intros; econstructor. + - asimpl; econstructor. + 2: cbn; rewrite h'; now asimpl. + asimpl; eapply id_subst; gen_typing. + - cbn; now rewrite h'. + - asimpl; econstructor. + 2: cbn; rewrite h'; now asimpl. + asimpl; eapply subst_refl; eapply id_subst; gen_typing. + - cbn; now rewrite h'. + Qed. + + Lemma typing_subst2 {Γ A B} : + [|- Γ] -> + (forall P a b, [Γ |- a : A] -> [Γ |- b : B[a..]] -> [Γ,, A,, B |- P] -> [Γ |- P[b .: a ..]]) + × (forall P P' a a' b b', [Γ |- a ≅ a' : A] -> [Γ |- b ≅ b' : B[a..]] -> [Γ,, A ,, B |- P ≅ P'] -> [Γ |- P[b .: a..] ≅ P'[b' .: a'..]]). + Proof. + intros;split; intros. + 1: eapply ty_subst ; tea. + 2: eapply ty_conv_subst ; tea. + all: now eapply scons2_well_subst. + Qed. + + Lemma conv_well_subst1 (Γ : context) A A' : + [Γ |- A] -> + [Γ |- A'] -> + [Γ |- A ≅ A'] -> + [Γ,, A |-s tRel : Γ,, A']. + Proof. + intros HA HA' Hconv. + econstructor. + - change (↑ >> tRel) with (tRel⟨↑⟩). + eapply well_subst_up ; tea. + now eapply id_subst ; gen_typing. + - refold. + eapply wfTermConv. + 1: constructor; [gen_typing|now econstructor]. + rewrite <- rinstInst'_term; do 2 erewrite <- wk1_ren_on; eapply typing_wk; tea. + gen_typing. + Qed. + + Theorem _stability1 (Γ : context) A A' : + [Γ |- A] -> + [Γ |- A'] -> + [Γ |- A ≅ A'] -> + (forall (T : term), [Γ,, A' |-[de] T] -> [Γ,, A |-[de] T]) + × (forall (T t : term), [Γ,, A' |-[ de ] t : T] -> [Γ,, A |-[de] t : T]) + × (forall (T T' : term), [Γ,, A' |-[ de ] T ≅ T'] -> [Γ,, A |-[de] T ≅ T']) + × (forall (T t u : term), + [Γ,, A' |-[ de ] t ≅ u : T] -> [Γ,, A |-[de] t ≅ u : T]). + Proof. + intros * ? ? Hconv. + eapply (conv_well_subst1 _) in Hconv ; tea. + pose proof (Hconv' := Hconv). + apply subst_refl in Hconv'. + assert [|- Γ,, A] by gen_typing. + repeat match goal with |- _ × _ => split end. + all: intros * Hty. + 4: eapply tm_conv_subst in Hty. + 3: eapply ty_conv_subst in Hty. + 2: eapply tm_subst in Hty. + 1: eapply ty_subst in Hty. + all: repeat (rewrite idSubst_term in Hty ; [..|reflexivity]). + all: eassumption. + Qed. + + Lemma _conv_well_subst (Γ Δ : context) : + [|- Γ] -> + [ |- Γ ≅ Δ] -> + [Γ |-s tRel : Δ]. + Proof. + intros HΓ. + induction 1 as [| * ? HA] in HΓ |- *. + - now econstructor. + - assert [Γ |- A] by now inversion HΓ. + assert [|- Γ] by now inversion HΓ. + econstructor ; tea. + + eapply well_subst_ext, well_subst_up ; eauto. + reflexivity. + + eapply wfTermConv. + 1: econstructor; [gen_typing| now econstructor]. + rewrite <- rinstInst'_term; do 2 erewrite <- wk1_ren_on. + now eapply typing_wk. + Qed. + +End MoreSubst. + +(** Stability and symmetry with redundant hypothesis on the well-formed contexts *) + +Section Stability. + + Context `{!TypingSubst (ta := de)}. + + Let PCon (Γ : context) := True. + Let PTy (Γ : context) (A : term) := forall Δ, + [|-Δ] -> [|- Δ ≅ Γ] -> [Δ |- A]. + Let PTm (Γ : context) (A t : term) := forall Δ, + [|-Δ] -> [|- Δ ≅ Γ] -> [Δ |- t : A]. + Let PTyEq (Γ : context) (A B : term) := forall Δ, + [|-Δ] -> [|- Δ ≅ Γ] -> [Δ |- A ≅ B]. + Let PTmEq (Γ : context) (A t u : term) := forall Δ, + [|-Δ] -> [|- Δ ≅ Γ] -> [Δ |- t ≅ u : A]. + + Theorem _stability : WfDeclInductionConcl PCon PTy PTm PTyEq PTmEq. + Proof. + red; prod_splitter; intros Γ * Hty; red. + 1: easy. + all: intros ?? Hconv; eapply (_conv_well_subst _) in Hconv ; tea. + all: pose proof (Hconv' := Hconv); apply subst_refl in Hconv'. + 4: eapply tm_conv_subst in Hty. + 3: eapply ty_conv_subst in Hty. + 2: eapply tm_subst in Hty. + 1: eapply ty_subst in Hty. + all: tea. + all: repeat (rewrite idSubst_term in Hty ; [..|reflexivity]). + all: eassumption. + Qed. + + Definition _convCtxSym {Γ Δ} : [|- Δ] -> [|- Γ] -> [|- Δ ≅ Γ] -> [|- Γ ≅ Δ]. + Proof. + induction 3. + all: constructor; inversion H; inversion H0; subst; refold. + 1: now eauto. + eapply _stability ; tea. + 1: now symmetry. + now eauto. + Qed. + +End Stability. + +Section ElimSuccHyp. + + Context `{!TypingSubst (ta := de)}. + + Lemma elimSuccHypTy_ty Γ P : + [|- Γ] -> + [Γ,, tNat |- P] -> + [Γ |-[ de ] elimSuccHypTy P]. + Proof. + intros HΓ HP. + unfold elimSuccHypTy. + econstructor. + 1: now econstructor. + eapply wft_simple_arr. + 1: now eapply HP. + eapply ty_subst ; eauto. + 1: boundary. + econstructor. + - bsimpl. + eapply well_subst_ext. + 2: eapply well_subst_up. + 3: eapply id_subst ; tea. + 2: now econstructor. + now bsimpl. + - cbn. + econstructor. + eapply typing_meta_conv. + 1: now do 2 econstructor ; tea ; econstructor. + reflexivity. + Qed. + + Lemma elimSuccHypTy_conv Γ P P' : + [|- Γ] -> + [Γ,, tNat |- P] -> + [Γ,, tNat |- P ≅ P' ] -> + [Γ |- elimSuccHypTy P ≅ elimSuccHypTy P']. + Proof. + intros. + unfold elimSuccHypTy. + constructor. + 2: constructor. + 1-2: now constructor. + eapply convty_simple_arr; tea. + eapply typing_substmap1; tea. + do 2 constructor; refine (wfVar _ (in_here _ _)). + constructor; boundary. + Qed. + +End ElimSuccHyp. + + +(** *** Typing lemmas *) +(** Weak versions necessary to prove the boundary lemmas. Stronger versions follow. *) + +Lemma idElimMotiveCtx {Γ A x} : +[Γ |- A] -> +[Γ |- x : A] -> +[|- (Γ,, A),, tId A⟨@wk1 Γ A⟩ x⟨@wk1 Γ A⟩ (tRel 0)]. +Proof. + intros; assert [|- Γ] by boundary. + assert [|- Γ,, A] by now econstructor. + econstructor; tea. + econstructor. + 1: now eapply wft_wk. + 1: eapply ty_wk; tea; econstructor; tea. + rewrite wk1_ren_on; now eapply ty_var0. +Qed. + +Lemma _idElimMotiveCtxConv `{!TypingSubst (ta := de)} {Γ Γ' A A' x x'} : +[|- Γ ≅ Γ'] -> +[Γ |- A ≅ A'] -> +[Γ |- x ≅ x' : A] -> +[ |- (Γ,, A),, tId A⟨@wk1 Γ A⟩ x⟨@wk1 Γ A⟩ (tRel 0)] -> +[ |- (Γ',, A'),, tId A'⟨@wk1 Γ' A'⟩ x'⟨@wk1 Γ' A'⟩ (tRel 0)] -> +[ |- (Γ',, A'),, tId A'⟨@wk1 Γ' A'⟩ x'⟨@wk1 Γ' A'⟩ (tRel 0) ≅ (Γ,, A),, tId A⟨@wk1 Γ A⟩ x⟨@wk1 Γ A⟩ (tRel 0)]. +Proof. + intros. + assert [|- Γ] by boundary. + assert [Γ |- A] by boundary. + assert [Γ' |- A'] by boundary. + eapply _convCtxSym ; tea. + econstructor. + 1: econstructor; tea; now eapply ctx_refl. + erewrite (wk1_irr (t:=A')), (wk1_irr (t:=x')) ; econstructor. + 1,2: eapply typing_wk; tea; gen_typing. + rewrite wk1_ren_on; eapply TermRefl; now eapply ty_var0. +Qed. + +Section Boundary. + Context `{!TypingSubst (ta := de)}. + + Lemma in_ctx_wf Γ n decl : + [|- Γ] -> + in_ctx Γ n decl -> + [Γ |- decl]. + Proof. + intros HΓ Hin. + induction Hin. + - inversion HΓ ; subst ; cbn in * ; refold. + renToWk. + now apply typing_wk. + - inversion HΓ ; subst ; cbn in * ; refold. + renToWk. + now eapply typing_wk. + Qed. + + Lemma boundary : WfDeclInductionConcl + (fun _ => True) (fun _ _ => True) + (fun Γ A t => [Γ |- A]) + (fun Γ A B => [Γ |- A] × [Γ |- B]) + (fun Γ A t u => [× [Γ |- A], [Γ |- t : A] & [Γ |- u : A]]). + Proof. + apply WfDeclInduction. + all: try easy. + - intros. + now eapply in_ctx_wf. + - intros. + now econstructor. + - intros. + now eapply typing_subst1, prod_ty_inv. + - intros; gen_typing. + - intros; gen_typing. + - intros. + now eapply typing_subst1. + - intros; gen_typing. + - intros. + now eapply typing_subst1. + - intros; gen_typing. + - intros. now eapply sig_ty_inv. + - intros. + eapply typing_subst1. + + now econstructor. + + now eapply sig_ty_inv. + - intros; now econstructor. + - intros; eapply typing_subst2; tea. + 1: gen_typing. + cbn; now rewrite 2!wk1_ren_on, 2!shift_one_eq. + - intros * ? _ ? [] ? []. + split. + all: constructor ; tea. + eapply _stability1. + 3: now symmetry. + all: eassumption. + - intros * ? _ ? [] ? []; split. + 1: gen_typing. + constructor; tea. + eapply _stability1. + 3: now symmetry. + all: tea. + - intros; prod_hyp_splitter; split; econstructor; tea; now eapply wfTermConv. + - intros * ? []. + split. + all: now econstructor. + - intros. + split. + + now eapply typing_subst1. + + econstructor ; tea. + now econstructor. + + now eapply typing_subst1. + - intros * ? _ ? [] ? []. + split. + + easy. + + now econstructor. + + econstructor ; tea. + eapply _stability1. + 4: eassumption. + all: econstructor ; tea. + now symmetry. + - intros * ? [] ? []. + split. + + eapply typing_subst1. + 1: eassumption. + now eapply prod_ty_inv. + + now econstructor. + + econstructor. + 1: now econstructor. + eapply typing_subst1. + 1: now symmetry. + econstructor. + now eapply prod_ty_inv. + - intros * ? _ ? [] ? [] ? []. + split. + all: econstructor ; tea. + + econstructor ; tea. + eapply _stability1 ; [..|eassumption] ; eauto. + now symmetry. + + symmetry. + econstructor ; eauto. + now econstructor. + + econstructor ; tea. + eapply _stability1 ; [..|eassumption] ; eauto. + now symmetry. + + symmetry. + econstructor ; eauto. + now econstructor. + - intros * ? ? ; split ; eauto. + econstructor. + 1: now eapply prod_ty_inv. + eapply typing_eta ; tea. + all: now eapply prod_ty_inv. + - intros * ? [] ; split ; gen_typing. + - intros * ? [] ? [] ? [] ? []; split. + + now eapply typing_subst1. + + gen_typing. + + eapply ty_conv. + assert [Γ |-[de] tNat ≅ tNat] by now constructor. + 1: eapply ty_natElim; tea; eapply ty_conv; tea. + * eapply typing_subst1; tea; do 2 constructor; boundary. + * eapply elimSuccHypTy_conv ; tea. + now boundary. + * symmetry; now eapply typing_subst1. + - intros **; split; tea. + eapply ty_natElim; tea; constructor; boundary. + - intros **. + assert [Γ |- tSucc n : tNat] by now constructor. + assert [Γ |- P[(tSucc n)..]] by now eapply typing_subst1. + split; tea. + 2: eapply ty_simple_app. + 1,5: now eapply ty_natElim. + 2: tea. + 1: now eapply typing_subst1. + replace (arr _ _) with (arr P P[tSucc (tRel 0)]⇑)[n..] by now bsimpl. + eapply ty_app; tea. + - intros * ? [] ? []; split. + + now eapply typing_subst1. + + gen_typing. + + eapply ty_conv. + assert [Γ |-[de] tEmpty ≅ tEmpty] by now constructor. + 1: eapply ty_emptyElim; tea; eapply ty_conv; tea. + * symmetry; now eapply typing_subst1. + - intros * ??? [] ? []; split; tea. + 1: gen_typing. + constructor; tea. + eapply _stability1. + 3: symmetry; gen_typing. + all: gen_typing. + - intros ** ; prod_hyp_splitter. + split. + all: econstructor ; eauto. + + econstructor ; tea. + * eapply _stability1 ; [..|eassumption] ; eauto. + now symmetry. + * now econstructor. + * econstructor ; tea. + eapply typing_subst1 ; tea. + now econstructor. + + symmetry. + econstructor ; eauto. + + econstructor ; tea. + * eapply _stability1 ; [..|eassumption] ; eauto. + now symmetry. + * now econstructor. + * econstructor ; tea. + eapply typing_subst1 ; tea. + + symmetry. + econstructor ; eauto. + - intros. + split ; eauto. + econstructor. + 1-2: now eapply sig_ty_inv. + all: now econstructor. + - intros * ? []; split; tea. + 1: now eapply sig_ty_inv. + all: gen_typing. + - intros * ? _ ? _ ????; split; tea. + now do 2 econstructor. + - intros * ? []; split; tea. + 1: eapply typing_subst1; [gen_typing| now eapply sig_ty_inv]. + 1: gen_typing. + econstructor. 1: now econstructor. + symmetry; eapply typing_subst1. + 1: now eapply TermFstCong. + econstructor; now eapply sig_ty_inv. + - intros * ? _ ? _ ????. + assert [Γ |- tFst (tPair A B a b) : A] by now do 2 econstructor. + assert [Γ |- tFst (tPair A B a b) ≅ a : A] by now econstructor. + split. + + eapply typing_subst1; tea. + + now do 2 econstructor. + + econstructor; tea. + symmetry; eapply typing_subst1; tea. + now econstructor. + - intros; prod_hyp_splitter; split; tea; econstructor; tea. + all: eapply wfTermConv; tea; now econstructor. + - intros; prod_hyp_splitter; split. + all: econstructor; tea. + 1: econstructor; tea; now eapply wfTermConv. + symmetry; now econstructor. + - intros; prod_hyp_splitter. + assert [|- Γ] by gen_typing. + assert [|- Γ,, A'] by now econstructor. + split. + 1: eapply typing_subst2; tea; cbn; now rewrite 2!wk1_ren_on, 2!shift_one_eq. + 1: now econstructor. + econstructor. + 1: econstructor; tea; try eapply wfTermConv; refold; tea. + + eapply _stability ; tea. + 2: eapply _idElimMotiveCtxConv; tea; try now boundary + eapply ctx_refl. + 1,2: eapply idElimMotiveCtx; tea; now eapply wfTermConv. + + eapply typing_subst2; tea. + cbn; rewrite 2!wk1_ren_on, 2!shift_one_eq. + now econstructor. + + now econstructor. + + symmetry; eapply typing_subst2; tea. + cbn; rewrite 2!wk1_ren_on, 2!shift_one_eq; tea. + - intros; prod_hyp_splitter. + assert [|- Γ] by gen_typing. + assert [Γ |- tRefl A' z : tId A x y]. + 1:{ + econstructor. + 1: econstructor; tea; now econstructor. + symmetry; econstructor; tea; etransitivity; tea; now symmetry. + } + split; tea. + + eapply typing_subst2; tea. + cbn; now rewrite 2!wk1_ren_on, 2!shift_one_eq. + + econstructor; tea. + + econstructor; tea. + eapply typing_subst2; tea. + 2: now econstructor. + cbn; rewrite 2!wk1_ren_on, 2!shift_one_eq. + now econstructor. + - intros * ? [] ? []. + split ; gen_typing. + - intros * ? []. + split; gen_typing. + - intros * ?[]?[]. + split; gen_typing. + Qed. + + Corollary boundary_tm Γ A t : [Γ |- t : A] -> [Γ |- A]. + Proof. + now intros ?%boundary. + Qed. + + Corollary boundary_ty_conv_l Γ A B : [Γ |- A ≅ B] -> [Γ |- A]. + Proof. + now intros ?%boundary. + Qed. + + Corollary boundary_ty_conv_r Γ A B : [Γ |- A ≅ B] -> [Γ |- B]. + Proof. + now intros ?%boundary. + Qed. + + Corollary boundary_red_ty_r Γ A B : [Γ |- A ⤳* B] -> [Γ |- B]. + Proof. + now intros ?%RedConvTyC%boundary. + Qed. + + Corollary boundary_tm_conv_l Γ A t u : [Γ |- t ≅ u : A] -> [Γ |- t : A]. + Proof. + now intros []%boundary. + Qed. + + Corollary boundary_tm_conv_r Γ A t u : [Γ |- t ≅ u : A] -> [Γ |- u : A]. + Proof. + now intros []%boundary. + Qed. + + Corollary boundary_tm_conv_ty Γ A t u : [Γ |- t ≅ u : A] -> [Γ |- A]. + Proof. + now intros []%boundary. + Qed. + + Corollary boundary_red_tm_r Γ A t u : [Γ |- t ⤳* u : A] -> [Γ |- u : A]. + Proof. + now intros []%RedConvTeC%boundary. + Qed. + + Corollary boundary_red_tm_ty Γ A t u : [Γ |- t ⤳* u : A] -> [Γ |- A]. + Proof. + now intros []%RedConvTeC%boundary. + Qed. + +End Boundary. + +#[export] Hint Resolve +boundary_tm boundary_ty_conv_l boundary_ty_conv_r +boundary_tm_conv_l boundary_tm_conv_r boundary_tm_conv_ty +boundary_red_tm_l boundary_red_tm_r boundary_red_tm_ty +boundary_red_ty_r : boundary. + +Lemma boundary_ctx_conv_l `{!TypingSubst (ta := de)} (Γ Δ : context) : + [ |- Γ ≅ Δ] -> + [|- Γ]. +Proof. + destruct 1. + all: econstructor ; boundary. +Qed. + +#[export] Hint Resolve boundary_ctx_conv_l : boundary. + +Corollary conv_ctx_refl_l `{!TypingSubst (ta := de)} (Γ Δ : context) : +[ |- Γ ≅ Δ] -> +[|- Γ ≅ Γ]. +Proof. + intros. + eapply ctx_refl ; boundary. +Qed. + +Section Stability. + Context `{!TypingSubst (ta := de)}. + + Lemma conv_well_subst (Γ Δ : context) : + [ |- Γ ≅ Δ] -> + [Γ |-s tRel : Δ]. + Proof. + intros; eapply _conv_well_subst; tea; boundary. + Qed. + + Let PCon (Γ : context) := True. + Let PTy (Γ : context) (A : term) := forall Δ, + [|- Δ ≅ Γ] -> [Δ |- A]. + Let PTm (Γ : context) (A t : term) := forall Δ, + [|- Δ ≅ Γ] -> [Δ |- t : A]. + Let PTyEq (Γ : context) (A B : term) := forall Δ, + [|- Δ ≅ Γ] -> [Δ |- A ≅ B]. + Let PTmEq (Γ : context) (A t u : term) := forall Δ, + [|- Δ ≅ Γ] -> [Δ |- t ≅ u : A]. + + Theorem stability : WfDeclInductionConcl PCon PTy PTm PTyEq PTmEq. + Proof. + red; prod_splitter; intros; red;intros; eapply _stability; tea; boundary. + Qed. + + + #[global] Instance ConvCtxSym : Symmetric ConvCtx. + Proof. + intros Γ Δ. + induction 1. + all: constructor ; tea. + eapply stability ; tea. + now symmetry. + Qed. + + Corollary conv_ctx_refl_r (Γ Δ : context) : + [ |- Γ ≅ Δ] -> + [|- Δ ≅ Δ]. + Proof. + intros H. + symmetry in H. + now eapply ctx_refl ; boundary. + Qed. + + #[global] Instance ConvCtxTrans : Transitive ConvCtx. + Proof. + intros Γ1 Γ2 Γ3 H1 H2. + induction H1 in Γ3, H2 |- *. + all: inversion H2 ; subst ; clear H2. + all: constructor. + 1: eauto. + etransitivity ; tea. + now eapply stability. + Qed. + +End Stability. + +Section TypingStronger. + Context `{!TypingSubst (ta := de)}. + + Theorem stability1 (Γ : context) A A' : + [Γ |- A ≅ A'] -> + (forall (T : term), [Γ,, A' |-[de] T] -> [Γ,, A |-[de] T]) + × (forall (T t : term), [Γ,, A' |-[ de ] t : T] -> [Γ,, A |-[de] t : T]) + × (forall (T T' : term), [Γ,, A' |-[ de ] T ≅ T'] -> [Γ,, A |-[de] T ≅ T']) + × (forall (T t u : term), + [Γ,, A' |-[ de ] t ≅ u : T] -> [Γ,, A |-[de] t ≅ u : T]). + Proof. + intros. + apply _stability1 ; tea. + all: boundary. + Qed. + + + Lemma idElimMotiveCtxConv {Γ Γ' A A' x x'} : + [|- Γ ≅ Γ'] -> + [Γ |- A ≅ A'] -> + [Γ |- x ≅ x' : A] -> + [ |- (Γ',, A'),, tId A'⟨@wk1 Γ' A'⟩ x'⟨@wk1 Γ' A'⟩ (tRel 0) ≅ (Γ,, A),, tId A⟨@wk1 Γ A⟩ x⟨@wk1 Γ A⟩ (tRel 0)]. + Proof. + intros. + assert [|- Γ] by boundary. + assert [Γ |- A] by boundary. + assert [Γ' |- A']. + { + eapply stability. + 2: now symmetry. + now boundary. + } + apply _idElimMotiveCtxConv ; eauto. + - constructor. + 1: constructor ; boundary. + constructor. + + eapply typing_wk. + 2: constructor. + all: boundary. + + eapply typing_wk. + 2: constructor. + all: boundary. + + rewrite wk1_ren_on. + do 2 constructor. + all: boundary. + - constructor. + 1: econstructor ; boundary. + constructor. + + eapply typing_wk. + 2: constructor. + all: boundary. + + eapply typing_wk. + 2: econstructor ; boundary. + eapply stability. + 2: now symmetry. + econstructor ; tea. + boundary. + + rewrite wk1_ren_on. + do 2 constructor. + all: boundary. + Qed. + + Lemma termGen' Γ t A : + [Γ |- t : A] -> + ∑ A', (termGenData Γ t A') × [Γ |- A' ≅ A]. + Proof. + intros * H. + destruct (_termGen _ _ _ H) as [? [? [->|]]]. + 2: now eexists. + eexists ; split ; tea. + econstructor. + boundary. + Qed. + + Lemma typing_eta' (Γ : context) A B f : + [Γ |- f : tProd A B] -> + [Γ,, A |- eta_expand f : B]. + Proof. + intros Hf. + eapply typing_eta ; tea. + - eapply prod_ty_inv. + boundary. + - eapply prod_ty_inv. + boundary. + Qed. + +End TypingStronger. \ No newline at end of file diff --git a/theories/TypingProperties/TypeConstructorsInj.v b/theories/TypingProperties/TypeConstructorsInj.v new file mode 100644 index 00000000..5d8aec93 --- /dev/null +++ b/theories/TypingProperties/TypeConstructorsInj.v @@ -0,0 +1,666 @@ +(** * LogRel.TypeConstructorsInj: injectivity and no-confusion of type constructors, and many consequences, including subject reduction. *) +From Coq Require Import CRelationClasses. +From LogRel Require Import Utils Syntax.All DeclarativeTyping GenericTyping. +From LogRel.TypingProperties Require Import DeclarativeProperties PropertiesDefinition SubstConsequences. + +Set Printing Primitive Projection Parameters. + +Import WeakDeclarativeTypingProperties. + +(** ** Direct consequences of type constructors injectivity *) +(** Various specialized and easy-to-use versions of the general theorem. *) + +Section TypeConstructors. + Context `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)}. + + Corollary conv_univ_l Γ T : + isType T -> + [Γ |- U ≅ T] -> + T = U. + Proof. + unshelve eintros nfT [? Hconv%ty_conv_inj]%dup. + 1-2: now gen_typing. + now destruct nfT, Hconv. + Qed. + + Corollary red_compl_univ_l Γ T : + [Γ |- U ≅ T] -> + [Γ |- T ⤳* U]. + Proof. + intros [? [T' []]%red_ty_complete_l]%dup. + 2: now gen_typing. + enough (T' = U) as -> by easy. + eapply conv_univ_l ; eauto. + etransitivity ; [eassumption|now eapply RedConvTyC]. + Qed. + + Corollary conv_univ_r Γ T : + isType T -> + [Γ |- T ≅ U ] -> + T = U. + Proof. + intros. + eapply conv_univ_l ; eauto. + now symmetry. + Qed. + + Corollary red_compl_univ_r Γ T : + [Γ |- T ≅ U] -> + [Γ |- T ⤳* U]. + Proof. + intros. + eapply red_compl_univ_l. + now symmetry. + Qed. + + Corollary conv_nat_l Γ T : + isType T -> + [Γ |- tNat ≅ T] -> + T = tNat. + Proof. + unshelve eintros nfT [? Hconv%ty_conv_inj]%dup. + 1-2: now gen_typing. + now destruct nfT, Hconv. + Qed. + + Corollary red_compl_nat_l Γ T : + [Γ |- tNat ≅ T] -> + [Γ |- T ⤳* tNat]. + Proof. + intros [? [T' []]%red_ty_complete_l]%dup. + 2: now gen_typing. + enough (T' = tNat) as -> by easy. + eapply conv_nat_l ; eauto. + etransitivity ; [eassumption|now eapply RedConvTyC]. + Qed. + + Corollary conv_nat_r Γ T : + isType T -> + [Γ |- T ≅ tNat] -> + T = tNat. + Proof. + intros. + eapply conv_nat_l ; eauto. + now symmetry. + Qed. + + Corollary red_compl_nat_r Γ T : + [Γ |- T ≅ tNat] -> + [Γ |- T ⤳* tNat]. + Proof. + intros. + eapply red_compl_nat_l. + now symmetry. + Qed. + + Corollary conv_empty_l Γ T : + isType T -> + [Γ |- tEmpty ≅ T] -> + T = tEmpty. + Proof. + unshelve eintros nfT [? Hconv%ty_conv_inj]%dup. + 1-2: now gen_typing. + now destruct nfT, Hconv. + Qed. + + Corollary red_compl_empty_l Γ T : + [Γ |- tEmpty ≅ T] -> + [Γ |- T ⤳* tEmpty]. + Proof. + intros [? [T' []]%red_ty_complete_l]%dup. + 2: now gen_typing. + enough (T' = tEmpty) as -> by easy. + eapply conv_empty_l ; eauto. + etransitivity ; [eassumption|now eapply RedConvTyC]. + Qed. + + Corollary conv_empty_r Γ T : + isType T -> + [Γ |- T ≅ tEmpty] -> + T = tEmpty. + Proof. + intros. + eapply conv_empty_l ; eauto. + now symmetry. + Qed. + + Corollary red_compl_empty_r Γ T : + [Γ |- T ≅ tEmpty] -> + [Γ |- T ⤳* tEmpty]. + Proof. + intros. + eapply red_compl_empty_l. + now symmetry. + Qed. + + Corollary prod_ty_inj Γ A B A' B' : + [Γ |- tProd A B ≅ tProd A' B'] -> + [Γ |- A' ≅ A] × [Γ,, A' |- B ≅ B']. + Proof. + intros Hty. + unshelve eapply ty_conv_inj in Hty. + 1-2: constructor. + now eassumption. + Qed. + + Corollary conv_prod_l Γ A B T : + isType T -> + [Γ |- tProd A B ≅ T] -> + ∑ A' B', [× T = tProd A' B', [Γ |- A' ≅ A] & [Γ,, A' |- B ≅ B']]. + Proof. + unshelve eintros nfT [? Hconv%ty_conv_inj]%dup. + 1-2: now gen_typing. + destruct nfT, Hconv. + eauto. + Qed. + + Corollary red_compl_prod_l Γ A B T : + [Γ |- tProd A B ≅ T] -> + ∑ A' B', [× [Γ |- T ⤳* tProd A' B'], [Γ |- A' ≅ A] & [Γ,, A' |- B ≅ B']]. + Proof. + intros [? [T' [? nfT]]%red_ty_complete_l]%dup. + 2: now gen_typing. + assert [Γ |- tProd A B ≅ T'] as Hconv by + (etransitivity ; [eassumption|now eapply RedConvTyC]). + unshelve eapply ty_conv_inj in Hconv. + 1-2: now gen_typing. + destruct nfT, Hconv. + do 2 eexists ; split. + all: eassumption. + Qed. + + Corollary conv_prod_r Γ A B T : + isType T -> + [Γ |- T ≅ tProd A B] -> + ∑ A' B', [× T = tProd A' B', [Γ |- A ≅ A'] & [Γ,, A |- B' ≅ B]]. + Proof. + unshelve eintros nfT [? Hconv%ty_conv_inj]%dup. + 1-2: now gen_typing. + destruct nfT, Hconv. + eauto. + Qed. + + Corollary red_compl_prod_r Γ A B T : + [Γ |- T ≅ tProd A B] -> + ∑ A' B', [× [Γ |- T ⤳* tProd A' B'], [Γ |- A ≅ A'] & [Γ,, A |- B' ≅ B]]. + Proof. + intros [? [T' [? nfT]]%red_ty_complete_r]%dup. + 2: now gen_typing. + assert [Γ |- T' ≅ tProd A B] as Hconv by + (etransitivity ; [now eapply TypeSym, RedConvTyC|eassumption]). + unshelve eapply ty_conv_inj in Hconv. + 1-2: now gen_typing. + destruct nfT, Hconv. + do 2 eexists ; split. + all: eassumption. + Qed. + + Corollary sig_ty_inj Γ A B A' B' : + [Γ |- tSig A B ≅ tSig A' B'] -> + [Γ |- A ≅ A'] × [Γ,, A |- B ≅ B']. + Proof. + intros Hty. + unshelve eapply ty_conv_inj in Hty. + 1-2: constructor. + now eassumption. + Qed. + + Corollary conv_sig_l Γ A B T : + isType T -> + [Γ |- tSig A B ≅ T] -> + ∑ A' B', [× T = tSig A' B', [Γ |- A ≅ A'] & [Γ,, A |- B ≅ B']]. + Proof. + unshelve eintros nfT [? Hconv%ty_conv_inj]%dup. + 1-2: now gen_typing. + destruct nfT, Hconv. + eauto. + Qed. + + Corollary red_compl_sig_l Γ A B T : + [Γ |- tSig A B ≅ T] -> + ∑ A' B', [× [Γ |- T ⤳* tSig A' B'], [Γ |- A ≅ A'] & [Γ,, A |- B ≅ B']]. + Proof. + intros [? [T' [? nfT]]%red_ty_complete_l]%dup. + 2: now gen_typing. + assert [Γ |- tSig A B ≅ T'] as Hconv by + (etransitivity ; [eassumption|now eapply RedConvTyC]). + unshelve eapply ty_conv_inj in Hconv. + 1-2: now gen_typing. + destruct nfT, Hconv. + do 2 eexists ; split. + all: eassumption. + Qed. + + Corollary conv_sig_r Γ A B T : + isType T -> + [Γ |- T ≅ tSig A B] -> + ∑ A' B', [× T = tSig A' B', [Γ |- A' ≅ A] & [Γ,, A' |- B' ≅ B]]. + Proof. + unshelve eintros nfT [? Hconv%ty_conv_inj]%dup. + 1-2: now gen_typing. + destruct nfT, Hconv. + eauto. + Qed. + + Corollary red_compl_sig_r Γ A B T : + [Γ |- T ≅ tSig A B] -> + ∑ A' B', [× [Γ |- T ⤳* tSig A' B'], [Γ |- A' ≅ A] & [Γ,, A' |- B' ≅ B]]. + Proof. + intros [? [T' [? nfT]]%red_ty_complete_r]%dup. + 2: now gen_typing. + assert [Γ |- T' ≅ tSig A B] as Hconv by + (etransitivity ; [now eapply TypeSym, RedConvTyC|eassumption]). + unshelve eapply ty_conv_inj in Hconv. + 1-2: now gen_typing. + destruct nfT, Hconv. + do 2 eexists ; split. + all: eassumption. + Qed. + + Corollary id_ty_inj {Γ A A' x x' y y'} : + [Γ |- tId A x y ≅ tId A' x' y'] -> + [× [Γ |- A ≅ A'], [Γ |- x ≅ x' : A] & [Γ |- y ≅ y' : A]]. + Proof. + intros Hty. + unshelve eapply ty_conv_inj in Hty. + 1-2: constructor. + now eassumption. + Qed. + + Corollary conv_id_l Γ A x y T : + isType T -> + [Γ |- tId A x y ≅ T] -> + ∑ A' x' y', [× T = tId A' x' y', [Γ |- A ≅ A'], [Γ |- x ≅ x' : A] & [Γ |- y ≅ y' : A]]. + Proof. + unshelve eintros nfT [? Hconv%ty_conv_inj]%dup. + 1-2: now gen_typing. + destruct nfT, Hconv. + repeat esplit ; eauto. + Qed. + + Corollary red_compl_id_l Γ A x y T : + [Γ |- tId A x y ≅ T] -> + ∑ A' x' y', [× [Γ |- T ⤳* tId A' x' y'], [Γ |- A ≅ A'], [Γ |- x ≅ x' : A] & [Γ |- y ≅ y' : A]]. + Proof. + intros [? [T' [? nfT]]%red_ty_complete_l]%dup. + 2: now gen_typing. + assert [Γ |- tId A x y ≅ T'] as Hconv by + (etransitivity ; [eassumption|now eapply RedConvTyC]). + unshelve eapply ty_conv_inj in Hconv. + 1-2: now gen_typing. + destruct nfT, Hconv. + do 3 eexists ; split. + all: eassumption. + Qed. + + Corollary conv_id_r Γ A x y T : + isType T -> + [Γ |- T ≅ tId A x y] -> + ∑ A' x' y', [× T = tId A' x' y', [Γ |- A' ≅ A], [Γ |- x' ≅ x : A] & [Γ |- y' ≅ y : A]]. + Proof. + intros ? Hconv. + symmetry in Hconv. + eapply conv_id_l in Hconv as (?&?&?&[->]) ; eauto. + do 3 eexists ; now split. + Qed. + + Corollary red_compl_id_r Γ A x y T : + [Γ |- T ≅ tId A x y] -> + ∑ A' x' y', [× [Γ |- T ⤳* tId A' x' y'], [Γ |- A' ≅ A], [Γ |- x' ≅ x : A] & [Γ |- y' ≅ y : A]]. + Proof. + intros hconv. + symmetry in hconv. + eapply red_compl_id_l in hconv as (?&?&?&[]). + do 3 eexists ; now split. + Qed. + +End TypeConstructors. + + +(** ** Subject reduction *) + +Section SubjectReduction. + + Context `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)}. + + Theorem subject_reduction_one Γ A t t' : + [Γ |- t : A] -> + [t ⤳ t'] -> + [Γ |- t ≅ t' : A]. + Proof. + intros Hty Hred. + induction Hred in Hty, A |- *. + - apply termGen' in Hty as (?&((?&?&[-> Hty])&Heq)). + apply termGen' in Hty as (?&((?&[->])&Heq')). + eapply prod_ty_inj in Heq' as [? HeqB]. + econstructor. + 1: econstructor ; gen_typing. + etransitivity ; tea. + eapply typing_subst1 ; tea. + now econstructor. + - apply termGen' in Hty as (?&((?&?&[->])&Heq)). + econstructor ; tea. + econstructor. + + now eapply IHHred. + + now econstructor. + - apply termGen' in Hty as [?[[->]?]]. + econstructor; tea. + econstructor. + 1-3: now econstructor. + now eapply IHHred. + - apply termGen' in Hty as [?[[->]?]]. + now do 2 econstructor. + - apply termGen' in Hty as [?[[-> ???(?&[->]&?)%termGen']?]]. + now do 2 econstructor. + - apply termGen' in Hty as [?[[->]?]]. + econstructor ; tea. + econstructor. + 1: now econstructor. + now eapply IHHred. + - apply termGen' in Hty as [? [[?[?[->]]]]]. + eapply TermConv; tea ; refold. + now econstructor. + - apply termGen' in Hty as [?[[?[?[-> h]]]]]. + apply termGen' in h as [?[[->] u]]. + destruct (sig_ty_inj _ _ _ _ _ u). + eapply TermConv; refold. + 1: econstructor ; tea. + now etransitivity. + - apply termGen' in Hty as [? [[?[?[->]]]]]. + eapply TermConv; tea ; refold. + now econstructor. + - apply termGen' in Hty as [?[[?[?[-> h]]]]]. + apply termGen' in h as [?[[->] u]]. + destruct (sig_ty_inj _ _ _ _ _ u). + assert [Γ |- B[(tFst (tPair A0 B a b))..] ≅ A]. + 1:{ etransitivity; tea. eapply typing_subst1; tea. + eapply TermConv; refold. 2: now symmetry. + eapply TermRefl; refold; gen_typing. + } + eapply TermConv; tea; refold. + now econstructor. + - apply termGen' in Hty as [? [[-> ????? h]]]. + apply termGen' in h as [? [[->] h']]. + pose proof h' as []%id_ty_inj. + econstructor; tea. + econstructor; tea. + + now econstructor. + + now econstructor. + + eapply TermConv; refold; [etransitivity; tea|]; now symmetry. + + eapply TermConv; refold; now symmetry. + - apply termGen' in Hty as [? [[-> ????? h]]]. + econstructor; tea; econstructor; tea. + all: now first [eapply TypeRefl |eapply TermRefl| eauto]. + Qed. + + Theorem subject_reduction_one_type Γ A A' : + [Γ |- A] -> + [A ⤳ A'] -> + [Γ |- A ≅ A']. + Proof. + intros Hty Hred. + destruct Hred. + all: inversion Hty ; subst ; clear Hty ; refold. + all: econstructor. + all: eapply subject_reduction_one ; tea. + all: now econstructor. + Qed. + + Theorem subject_reduction Γ t t' A : + [Γ |- t : A] -> + [t ⤳* t'] -> + [Γ |- t ⤳* t' : A]. + Proof. + intros Hty Hr; split ; refold. + - assumption. + - assumption. + - induction Hr. + + now constructor. + + eapply subject_reduction_one in o ; tea. + etransitivity ; tea. + eapply IHHr. + now boundary. + Qed. + + Theorem subject_reduction_type Γ A A' : + [Γ |- A] -> + [A ⤳* A'] -> + [Γ |- A ⤳* A']. + Proof. + intros Hty Hr; split; refold. + - assumption. + - assumption. + - induction Hr. + + now constructor. + + eapply subject_reduction_one_type in o ; tea. + etransitivity ; tea. + eapply IHHr. + now boundary. + Qed. + + Corollary subject_reduction_raw Γ t t' A : + [t ⤳* t'] -> + [Γ |-[de] t : A] -> + [Γ |-[de] t' : A]. + Proof. + eintros Hty ?%subject_reduction ; tea. + boundary. + Qed. + + Corollary subject_reduction_raw_ty Γ A A' : + [A ⤳* A'] -> + [Γ |-[de] A] -> + [Γ |-[de] A']. + Proof. + eintros Hty ?%subject_reduction_type ; tea. + boundary. + Qed. + + Corollary conv_red_l Γ A A' A'' : [Γ |-[de] A' ≅ A''] -> [A' ⤳* A] -> [Γ |-[de] A ≅ A'']. + Proof. + intros Hconv **. + etransitivity ; tea. + symmetry. + eapply RedConvTyC, subject_reduction_type ; tea. + boundary. + Qed. + +End SubjectReduction. + +(** ** Classification of weak-head normal forms *) + +(** Characterizes the possible weak-head normal forms at a given type. *) + +Section WhClassification. + Context `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)}. + + + Lemma Uterm_isType Γ A : + [Γ |-[de] A : U] -> + whnf A -> + isType A. + Proof. + intros Hty Hwh. + destruct Hwh. + all: try solve [now econstructor]. + all: exfalso. + all: eapply termGen' in Hty ; cbn in *. + all: prod_hyp_splitter ; try easy. + all: subst. + all: + match goal with + H : [_ |-[de] _ ≅ U] |- _ => unshelve eapply ty_conv_inj in H as Hconv + end. + all: try now econstructor. + all: try now cbn in Hconv. + Qed. + + Lemma type_isType Γ A : + [Γ |-[de] A] -> + whnf A -> + isType A. + Proof. + intros [] ; refold; cycle -1. + 1: intros; now eapply Uterm_isType. + all: econstructor. + Qed. + + Lemma fun_isFun Γ A B t: + [Γ |-[de] t : tProd A B] -> + whnf t -> + isFun t. + Proof. + intros Hty Hwh. + destruct Hwh. + all: try now econstructor. + all: eapply termGen' in Hty ; cbn in *. + all: exfalso. + all: prod_hyp_splitter ; try easy. + all: subst. + all: + match goal with + H : [_ |-[de] _ ≅ tProd _ _] |- _ => unshelve eapply ty_conv_inj in H as Hconv + end. + all: try now econstructor. + all: now cbn in Hconv. + Qed. + + Lemma sig_isPair Γ A B t: + [Γ |-[de] t : tSig A B] -> + whnf t -> + isPair t. + Proof. + intros Hty Hwh. + destruct Hwh. + all: try now econstructor. + all: eapply termGen' in Hty ; cbn in *. + all: exfalso. + all: prod_hyp_splitter ; try easy. + all: subst. + all: + match goal with + H : [_ |-[de] _ ≅ tSig _ _] |- _ => unshelve eapply ty_conv_inj in H as Hconv + end. + all: try now econstructor. + all: now cbn in Hconv. + Qed. + + Lemma nat_isNat Γ t: + [Γ |-[de] t : tNat] -> + whnf t -> + isNat t. + Proof. + intros Hty Hwh. + destruct Hwh. + all: try now econstructor. + all: eapply termGen' in Hty ; cbn in *. + all: exfalso. + all: prod_hyp_splitter ; try easy. + all: subst. + all: + match goal with + H : [_ |-[de] _ ≅ tNat] |- _ => unshelve eapply ty_conv_inj in H as Hconv + end. + all: try now econstructor. + all: now cbn in Hconv. + Qed. + + Lemma empty_isEmpty Γ t: + [Γ |-[de] t : tEmpty] -> + whnf t -> + whne t. + Proof. + intros Hty Hwh. + destruct Hwh ; try easy. + all: eapply termGen' in Hty ; cbn in *. + all: exfalso. + all: prod_hyp_splitter ; try easy. + all: subst. + all: + match goal with + H : [_ |-[de] _ ≅ tEmpty] |- _ => unshelve eapply ty_conv_inj in H as Hconv + end. + all: try now econstructor. + all: now cbn in Hconv. + Qed. + + Lemma id_isId Γ t {A x y} : + [Γ |-[de] t : tId A x y] -> + whnf t -> + isId t. + Proof. + intros Hty wh; destruct wh. + all: try now econstructor. + all: eapply termGen' in Hty; cbn in *. + all: exfalso. + all: prod_hyp_splitter ; try easy; subst. + all: + match goal with + H : [_ |-[de] _ ≅ tId _ _ _] |- _ => unshelve eapply ty_conv_inj in H as Hconv + end; try econstructor. + all: now cbn in Hconv. + Qed. + + Lemma neutral_isNeutral Γ A t : + [Γ |-[de] t : A] -> + whne A -> + whnf t -> + whne t. + Proof. + intros (?&Hgen&Hconv)%termGen' HwA Hwh. + set (iA := NeType HwA). + destruct Hwh ; cbn in * ; try easy. + all: exfalso. + all: prod_hyp_splitter. + all: subst. + all: unshelve eapply ty_conv_inj in Hconv ; tea. + all: try now econstructor. + all: now cbn in Hconv. + Qed. + + Lemma isType_ty Γ T t : + [Γ |-[de] t : T] -> + isType t -> + isCanonical t -> + [Γ |-[de] U ≅ T]. + Proof. + intros Hty HisT Hcan. + all: inversion HisT ; subst ; clear HisT ; cycle -1. + 1: now edestruct can_whne_exclusive. + all: eapply termGen' in Hty as (?&[]&?); subst. + all: eassumption. + Qed. + +End WhClassification. + +Lemma idElimConv {Γ A x P hr y e A' x' P' hr' e' y' T A'' x'' y''} + `{!TypingSubst (ta := de)} `{!TypeReductionComplete (ta := de)} `{!TypeConstructorsInj (ta := de)}: + well_typed (ta := de) Γ (tIdElim A x P hr y e) -> + well_typed (ta := de) Γ (tIdElim A' x' P' hr' y' e') -> + (forall T', [Γ |-[de] e : T'] -> [Γ |-[de] T ≅ T']) -> + (forall T', [Γ |-[de] e' : T'] -> [Γ |-[de] T ≅ T']) -> + [Γ |-[de] T ≅ tId A'' x'' y''] -> + whnf T -> + ∑ AT xT yT, + [× T = tId AT xT yT, + [Γ |-[de] A ≅ A'], [Γ |-[de] A ≅ AT], [Γ |-[de] A ≅ A''], + [Γ |-[de] x ≅ x' : A], [Γ |-[de] x ≅ xT : A], [Γ |-[de] x ≅ x'' : A], + [Γ |-[de] y ≅ y' : A], [Γ |-[de] y ≅ yT : A] & [Γ |-[de] y ≅ y'' : A]]. +Proof. + intros [? [? [[-> ????? he]]]%termGen'] [? [? [[-> ????? he']]]%termGen'] hty hty' htyconv ?. + specialize (hty _ he) as (?&?&?&[-> ])%conv_id_r. + 2: now eapply type_isType ; boundary. + specialize (hty' _ he') as []%id_ty_inj ; tea. + eapply id_ty_inj in htyconv as []. + do 3 eexists ; split. + 1: reflexivity. + - etransitivity ; now symmetry. + - now symmetry. + - etransitivity ; now symmetry. + - etransitivity ; symmetry ; tea ; symmetry ; now econstructor. + - now symmetry. + - etransitivity ; symmetry ; tea ; symmetry ; now econstructor. + - etransitivity ; symmetry ; tea ; symmetry ; now econstructor. + - now symmetry. + - etransitivity ; symmetry ; tea ; symmetry ; now econstructor. +Qed. \ No newline at end of file diff --git a/theories/UntypedValues.v b/theories/UntypedValues.v deleted file mode 100644 index 2dd05a2c..00000000 --- a/theories/UntypedValues.v +++ /dev/null @@ -1,147 +0,0 @@ -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms UntypedReduction. - -Unset Elimination Schemes. - -Inductive snf (r : term) : Type := - | snf_tSort {s} : [ r ⤳* tSort s ] -> snf r - | snf_tProd {A B} : [ r ⤳* tProd A B ] -> snf A -> snf B -> snf r - | snf_tLambda {A t} : [ r ⤳* tLambda A t ] -> snf A -> snf t -> snf r - | snf_tNat : [ r ⤳* tNat ] -> snf r - | snf_tZero : [ r ⤳* tZero ] -> snf r - | snf_tSucc {n} : [ r ⤳* tSucc n ] -> snf n -> snf r - | snf_tEmpty : [ r ⤳* tEmpty ] -> snf r - | snf_tSig {A B} : [r ⤳* tSig A B] -> snf A -> snf B -> snf r - | snf_tPair {A B a b} : [r ⤳* tPair A B a b] -> snf A -> snf B -> snf a -> snf b -> snf r - | snf_sne {n} : [ r ⤳* n ] -> sne n -> snf r -with sne (r : term) : Type := - | sne_tRel {v} : r = tRel v -> sne r - | sne_tApp {n t} : r = tApp n t -> sne n -> snf t -> sne r - | sne_tNatElim {P hz hs n} : r = tNatElim P hz hs n -> snf P -> snf hz -> snf hs -> sne n -> sne r - | sne_tEmptyElim {P e} : r = tEmptyElim P e -> snf P -> sne e -> sne r - | sne_tFst {p} : r = tFst p -> sne p -> sne r - | sne_tSnd {p} : r = tSnd p -> sne p -> sne r -. - -Set Elimination Schemes. - -Scheme - Induction for snf Sort Type with - Induction for sne Sort Type. - -Definition snf_rec - (P : forall r : term, snf r -> Set) - (Q : forall r : term, sne r -> Set) := snf_rect P Q. - -Definition snf_ind - (P : forall r : term, snf r -> Prop) - (Q : forall r : term, sne r -> Prop) := snf_rect P Q. - -Definition sne_rec - (P : forall r : term, snf r -> Set) - (Q : forall r : term, sne r -> Set) := sne_rect P Q. - -Definition sne_ind - (P : forall r : term, snf r -> Prop) - (Q : forall r : term, sne r -> Prop) := sne_rect P Q. - -(* A&Y: add as many ps as you added new constructors for snf and sne in total *) -Definition snf_sne_rect P Q p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 p13 p14 p15 p16 := - pair - (snf_rect P Q p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 p13 p14 p15 p16) - (sne_rect P Q p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 p13 p14 p15 p16). - -Lemma sne_whne : forall (t : term), sne t -> whne t. -Proof. -apply sne_rect with (P := fun _ _ => True); intros; subst; constructor; assumption. -Qed. - -Lemma snf_red : forall t u, [ t ⤳* u ] -> snf u -> snf t. -Proof. -intros t u Hr Hu; destruct Hu. -+ eapply snf_tSort. - transitivity u; eassumption. -+ eapply snf_tProd. - - transitivity u; eassumption. - - assumption. - - assumption. -+ eapply snf_tLambda. - - transitivity u; eassumption. - - assumption. - - assumption. -+ eapply snf_tNat; transitivity u; eassumption. -+ eapply snf_tZero. - transitivity u; eassumption. -+ eapply snf_tSucc. - - transitivity u; eassumption. - - assumption. -+ eapply snf_tEmpty; transitivity u; eassumption. -+ eapply snf_tSig. - 1: transitivity u; eassumption. - all: tea. -+ eapply snf_tPair. - 1: transitivity u; eassumption. - all: tea. -+ eapply snf_sne. - - transitivity u; eassumption. - - eassumption. -Qed. - -Section RenSnf. - - Lemma snf_sne_ren : - prod (forall t, snf t -> forall ρ, snf (t⟨ρ⟩)) (forall t, sne t -> forall ρ, sne (t⟨ρ⟩)). - Proof. - apply snf_sne_rect. - + intros r s Hr ρ. - apply credalg_wk with (ρ := ρ) in Hr. - eapply snf_tSort; eassumption. - + intros r A B Hr HA IHA HB IHB ρ. - apply credalg_wk with (ρ := ρ) in Hr. - eapply snf_tProd; eauto. - + intros r A t Hr HA IHA Ht IHt ρ. - apply credalg_wk with (ρ := ρ) in Hr. - eapply snf_tLambda; eauto. - + intros r Hr ρ. - apply credalg_wk with (ρ := ρ) in Hr. - eapply snf_tNat; eassumption. - + intros r Hr ρ. - apply credalg_wk with (ρ := ρ) in Hr. - eapply snf_tZero; eauto. - + intros r t Hr Ht IHt ρ. - apply credalg_wk with (ρ := ρ) in Hr. - eapply snf_tSucc; eauto. - + intros r Hr ρ. - apply credalg_wk with (ρ := ρ) in Hr. - eapply snf_tEmpty; eassumption. - + intros r A B Hr ???? ρ. - apply credalg_wk with (ρ := ρ) in Hr. - eapply snf_tSig; eauto. - + intros r ???? Hr ???????? ρ. - apply credalg_wk with (ρ := ρ) in Hr. - eapply snf_tPair; eauto. - + intros r n Hr Hn IHn ρ. - apply credalg_wk with (ρ := ρ) in Hr. - eapply snf_sne; eauto. - + intros r v -> ρ; econstructor; reflexivity. - + intros r n t -> Hn IHn Ht IHt ρ. - cbn; eapply sne_tApp; eauto. - + intros r P hz hs n -> HP IHP Hhz IHhz Hhs IHhs Hn IHn ρ; cbn. - eapply sne_tNatElim; eauto. - + intros. subst. cbn. - eapply sne_tEmptyElim; eauto. - + intros r ? -> ???; cbn; eapply sne_tFst; eauto. - + intros r ? -> ???; cbn; eapply sne_tSnd; eauto. - Qed. - - Lemma sne_ren ρ t : sne t -> sne (t⟨ρ⟩). - Proof. - intros; apply snf_sne_ren; assumption. - Qed. - - Lemma snf_ren ρ t : snf t -> snf (t⟨ρ⟩). - Proof. - intros; apply snf_sne_ren; assumption. - Qed. - -End RenSnf. diff --git a/theories/Utils.v b/theories/Utils.v index a2473a62..405648cc 100644 --- a/theories/Utils.v +++ b/theories/Utils.v @@ -2,7 +2,6 @@ From Coq Require Import Morphisms List CRelationClasses. From Coq Require Import ssrbool. From smpl Require Import Smpl. -From LogRel.AutoSubst Require Import core unscoped Ast. Set Universe Polymorphism. Set Polymorphic Inductive Cumulativity. @@ -24,6 +23,9 @@ standard library. **) Notation "~ x" := (notT x) : type_scope. #[export] Set Warnings "notation-overridden". + +#[global]Hint Unfold notT: core. + (** ** Polymorphic and cumulative redefinitions from the standard library. *) #[universes(polymorphic)] @@ -135,8 +137,11 @@ End ReflexiveTransitiveClosure. (** ** Tactics *) +(* To use in intro patterns, similar to SSReflects' /dup view *) +Definition dup {A : Type} : A -> A × A := fun x => (x,x). + Ltac tea := try eassumption. -Ltac easy ::= solve [intuition eauto 3 with core crelations]. +#[global] Ltac easy ::= solve [intuition eauto 3 with core crelations]. Ltac prod_splitter := repeat match goal with @@ -192,7 +197,7 @@ Create HintDb boundary. #[global] Hint Constants Opaque : boundary. #[global] Hint Variables Transparent : boundary. -Ltac boundary := solve[eauto 3 with boundary]. +Ltac boundary := solve[eauto 3 with boundary typeclass_instances]. (** Tactics used to create good induction principles using Scheme *) @@ -250,4 +255,8 @@ Definition Block (A : Type) := A. Ltac block H := let T := type of H in (change T with (Block T) in H). -Ltac unblock := unfold Block in *. \ No newline at end of file +Ltac unblock := unfold Block in *. + +(** To get warnings whenever needed *) + +#[deprecated(note="Fix me!")]Axiom fixme : False. \ No newline at end of file diff --git a/theories/Substitution/Conversion.v b/theories/Validity/Conversion.v similarity index 97% rename from theories/Substitution/Conversion.v rename to theories/Validity/Conversion.v index 5babfbe2..85459105 100644 --- a/theories/Substitution/Conversion.v +++ b/theories/Validity/Conversion.v @@ -1,8 +1,6 @@ -From Coq Require Import CRelationClasses. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening GenericTyping LogicalRelation Validity. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Irrelevance Escape Reflexivity Weakening Neutral. -From LogRel.Substitution Require Import Irrelevance Properties Reflexivity. +From LogRel.Validity Require Import Validity Properties Irrelevance Reflexivity. Set Universe Polymorphism. diff --git a/theories/Substitution/Escape.v b/theories/Validity/Escape.v similarity index 88% rename from theories/Substitution/Escape.v rename to theories/Validity/Escape.v index b6a65593..25c2aee8 100644 --- a/theories/Substitution/Escape.v +++ b/theories/Validity/Escape.v @@ -1,8 +1,6 @@ - -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening GenericTyping LogicalRelation Validity. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Irrelevance Escape Reflexivity Weakening Neutral. -From LogRel.Substitution Require Import Irrelevance Properties. +From LogRel.Validity Require Import Validity Irrelevance Properties. Set Universe Polymorphism. diff --git a/theories/Substitution/Introductions/Application.v b/theories/Validity/Introductions/Application.v similarity index 81% rename from theories/Substitution/Introductions/Application.v rename to theories/Validity/Introductions/Application.v index e89aa877..4f212b7a 100644 --- a/theories/Substitution/Introductions/Application.v +++ b/theories/Validity/Introductions/Application.v @@ -1,7 +1,6 @@ -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening GenericTyping LogicalRelation Validity. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Induction Irrelevance Escape Reflexivity Weakening Neutral Transitivity Reduction Application. -From LogRel.Substitution Require Import Irrelevance Properties Conversion SingleSubst Reflexivity. +From LogRel.Validity Require Import Validity Irrelevance Properties Conversion SingleSubst Reflexivity. Set Universe Polymorphism. diff --git a/theories/Substitution/Introductions/Empty.v b/theories/Validity/Introductions/Empty.v similarity index 89% rename from theories/Substitution/Introductions/Empty.v rename to theories/Validity/Introductions/Empty.v index dd0d3547..42afcec7 100644 --- a/theories/Substitution/Introductions/Empty.v +++ b/theories/Validity/Introductions/Empty.v @@ -1,9 +1,7 @@ From Coq Require Import CRelationClasses. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening GenericTyping LogicalRelation Validity. -From LogRel.LogicalRelation Require Import Induction Escape Irrelevance Reflexivity Irrelevance Weakening Neutral Transitivity Reduction Application Universe EqRedRight SimpleArr. -From LogRel.Substitution Require Import Irrelevance Properties Conversion SingleSubst Reflexivity Reduction. -From LogRel.Substitution.Introductions Require Import Universe Pi SimpleArr Var Application. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. +From LogRel.LogicalRelation Require Import Induction Escape Irrelevance Reflexivity Irrelevance Weakening Neutral Transitivity Reduction Application Universe EqRedRight SimpleArr. +From LogRel.Validity Require Import Validity Irrelevance Properties Conversion SingleSubst Reflexivity Reduction Universe Pi SimpleArr Var Application. Set Universe Polymorphism. diff --git a/theories/Substitution/Introductions/Id.v b/theories/Validity/Introductions/Id.v similarity index 96% rename from theories/Substitution/Introductions/Id.v rename to theories/Validity/Introductions/Id.v index d7d574f1..fc8e5d62 100644 --- a/theories/Substitution/Introductions/Id.v +++ b/theories/Validity/Introductions/Id.v @@ -1,9 +1,6 @@ -From Coq Require Import ssrbool CRelationClasses. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening GenericTyping LogicalRelation Validity. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Induction Escape Reflexivity Irrelevance Weakening Neutral Transitivity Reduction Application Universe Id EqRedRight NormalRed InstKripke. -From LogRel.Substitution Require Import Irrelevance Properties Conversion SingleSubst Reflexivity Reduction. -From LogRel.Substitution.Introductions Require Import Universe Var Poly. +From LogRel.Validity Require Import Validity Irrelevance Properties Conversion SingleSubst Reflexivity Reduction Universe Var Poly. Set Universe Polymorphism. Set Printing Primitive Projection Parameters. diff --git a/theories/Substitution/Introductions/Lambda.v b/theories/Validity/Introductions/Lambda.v similarity index 97% rename from theories/Substitution/Introductions/Lambda.v rename to theories/Validity/Introductions/Lambda.v index ee052c0e..3ef74142 100644 --- a/theories/Substitution/Introductions/Lambda.v +++ b/theories/Validity/Introductions/Lambda.v @@ -1,9 +1,6 @@ -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening - GenericTyping LogicalRelation Validity. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Induction Escape Reflexivity Neutral Weakening Irrelevance Application Reduction Transitivity NormalRed EqRedRight InstKripke. -From LogRel.Substitution Require Import Irrelevance Properties SingleSubst Reflexivity Conversion Reduction. -From LogRel.Substitution.Introductions Require Import Pi Application Var. +From LogRel.Validity Require Import Validity Irrelevance Properties SingleSubst Reflexivity Conversion Reduction Pi Application Var. Set Universe Polymorphism. Set Printing Primitive Projection Parameters. diff --git a/theories/Substitution/Introductions/Nat.v b/theories/Validity/Introductions/Nat.v similarity index 97% rename from theories/Substitution/Introductions/Nat.v rename to theories/Validity/Introductions/Nat.v index 7c116760..2feab573 100644 --- a/theories/Substitution/Introductions/Nat.v +++ b/theories/Validity/Introductions/Nat.v @@ -1,8 +1,6 @@ -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening GenericTyping LogicalRelation Validity. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Induction Escape Irrelevance Reflexivity Irrelevance Weakening Neutral Transitivity Reduction Application Universe EqRedRight SimpleArr. -From LogRel.Substitution Require Import Irrelevance Properties Conversion SingleSubst Reflexivity Reduction. -From LogRel.Substitution.Introductions Require Import Universe Pi SimpleArr Var Application. +From LogRel.Validity Require Import Validity Irrelevance Properties Conversion SingleSubst Reflexivity Reduction Universe Pi SimpleArr Var Application. Set Universe Polymorphism. diff --git a/theories/Substitution/Introductions/Pi.v b/theories/Validity/Introductions/Pi.v similarity index 95% rename from theories/Substitution/Introductions/Pi.v rename to theories/Validity/Introductions/Pi.v index 6ca9b45e..206e3a12 100644 --- a/theories/Substitution/Introductions/Pi.v +++ b/theories/Validity/Introductions/Pi.v @@ -1,10 +1,7 @@ From Coq Require Import ssrbool. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening - GenericTyping LogicalRelation Validity. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Escape Reflexivity Neutral Weakening Irrelevance Induction NormalRed EqRedRight. -From LogRel.Substitution Require Import Irrelevance Properties SingleSubst Reflexivity. -From LogRel.Substitution.Introductions Require Import Universe Poly. +From LogRel.Validity Require Import Validity Irrelevance Properties SingleSubst Reflexivity Universe Poly. Set Universe Polymorphism. diff --git a/theories/Substitution/Introductions/Poly.v b/theories/Validity/Introductions/Poly.v similarity index 95% rename from theories/Substitution/Introductions/Poly.v rename to theories/Validity/Introductions/Poly.v index 8592cc0a..f32b33d1 100644 --- a/theories/Substitution/Introductions/Poly.v +++ b/theories/Validity/Introductions/Poly.v @@ -1,10 +1,7 @@ From Coq Require Import ssrbool. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening - GenericTyping LogicalRelation Validity. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Escape Reflexivity Neutral Weakening Irrelevance Transitivity EqRedRight InstKripke. -From LogRel.Substitution Require Import Irrelevance Properties Reflexivity. -From LogRel.Substitution.Introductions Require Import Universe. +From LogRel.Validity Require Import Validity Irrelevance Properties Reflexivity Universe. Set Universe Polymorphism. diff --git a/theories/Substitution/Introductions/Sigma.v b/theories/Validity/Introductions/Sigma.v similarity index 98% rename from theories/Substitution/Introductions/Sigma.v rename to theories/Validity/Introductions/Sigma.v index cefc9c9a..e860c78d 100644 --- a/theories/Substitution/Introductions/Sigma.v +++ b/theories/Validity/Introductions/Sigma.v @@ -1,9 +1,7 @@ From Coq Require Import ssrbool CRelationClasses. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening GenericTyping LogicalRelation Validity. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Induction Escape Reflexivity Irrelevance Weakening Neutral Transitivity Reduction Application Universe EqRedRight SimpleArr NormalRed InstKripke. -From LogRel.Substitution Require Import Irrelevance Properties Conversion SingleSubst Reflexivity Reduction. -From LogRel.Substitution.Introductions Require Import Universe Poly. +From LogRel.Validity Require Import Validity Irrelevance Properties Conversion SingleSubst Reflexivity Reduction Universe Poly. Set Universe Polymorphism. diff --git a/theories/Substitution/Introductions/SimpleArr.v b/theories/Validity/Introductions/SimpleArr.v similarity index 82% rename from theories/Substitution/Introductions/SimpleArr.v rename to theories/Validity/Introductions/SimpleArr.v index 7d15ded9..1e87fbca 100644 --- a/theories/Substitution/Introductions/SimpleArr.v +++ b/theories/Validity/Introductions/SimpleArr.v @@ -1,9 +1,6 @@ -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening - GenericTyping LogicalRelation Validity. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Escape Reflexivity Neutral Weakening Irrelevance. -From LogRel.Substitution Require Import Irrelevance Properties Conversion Reflexivity. -From LogRel.Substitution.Introductions Require Import Universe Pi Application Lambda Var. +From LogRel.Validity Require Import Validity Irrelevance Properties Pi Application Lambda Var. Set Universe Polymorphism. diff --git a/theories/Substitution/Introductions/Universe.v b/theories/Validity/Introductions/Universe.v similarity index 78% rename from theories/Substitution/Introductions/Universe.v rename to theories/Validity/Introductions/Universe.v index 5d65d073..9c0f9be2 100644 --- a/theories/Substitution/Introductions/Universe.v +++ b/theories/Validity/Introductions/Universe.v @@ -1,7 +1,6 @@ -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening GenericTyping LogicalRelation Validity. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Induction Irrelevance Escape Reflexivity Weakening Neutral Transitivity Reduction Universe. -From LogRel.Substitution Require Import Irrelevance Properties Conversion Reflexivity. +From LogRel.Validity Require Import Validity Irrelevance Properties Conversion Reflexivity. Set Universe Polymorphism. diff --git a/theories/Substitution/Introductions/Var.v b/theories/Validity/Introductions/Var.v similarity index 86% rename from theories/Substitution/Introductions/Var.v rename to theories/Validity/Introductions/Var.v index 34d9784e..d9818d3d 100644 --- a/theories/Substitution/Introductions/Var.v +++ b/theories/Validity/Introductions/Var.v @@ -1,9 +1,7 @@ (** * LogRel.Introductions.Var : Validity of variables. *) -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening - GenericTyping LogicalRelation Validity. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Escape Irrelevance Reflexivity Transitivity Universe Weakening Neutral Induction NormalRed. -From LogRel.Substitution Require Import Irrelevance Properties Conversion Reflexivity SingleSubst Escape. +From LogRel.Validity Require Import Validity Irrelevance Properties Conversion Reflexivity SingleSubst Escape. Set Universe Polymorphism. Set Printing Primitive Projection Parameters. diff --git a/theories/Substitution/Irrelevance.v b/theories/Validity/Irrelevance.v similarity index 96% rename from theories/Substitution/Irrelevance.v rename to theories/Validity/Irrelevance.v index 22037000..5603a280 100644 --- a/theories/Substitution/Irrelevance.v +++ b/theories/Validity/Irrelevance.v @@ -1,8 +1,7 @@ - From Coq Require Import CRelationClasses. -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening GenericTyping LogicalRelation Validity. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Irrelevance Reflexivity Transitivity. +From LogRel.Validity Require Import Validity. Set Universe Polymorphism. @@ -26,14 +25,14 @@ Proof. all: irrelevanceCum. Qed. -Fail Fail Constraint u1 < v1. -Fail Fail Constraint v1 < u1. -Fail Fail Constraint u2 < v2. -Fail Fail Constraint v2 < u2. -Fail Fail Constraint u3 < v3. -Fail Fail Constraint v3 < u3. -Fail Fail Constraint u4 < v4. -Fail Fail Constraint v4 < u4. +Succeed Constraint u1 < v1. +Succeed Constraint v1 < u1. +Succeed Constraint u2 < v2. +Succeed Constraint v2 < u2. +Succeed Constraint u3 < v3. +Succeed Constraint v3 < u3. +Succeed Constraint u4 < v4. +Succeed Constraint v4 < u4. End VRIrrelevant. diff --git a/theories/Substitution/Properties.v b/theories/Validity/Properties.v similarity index 97% rename from theories/Substitution/Properties.v rename to theories/Validity/Properties.v index 686691a3..3e6230ae 100644 --- a/theories/Substitution/Properties.v +++ b/theories/Validity/Properties.v @@ -1,7 +1,6 @@ -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening GenericTyping LogicalRelation Validity. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Irrelevance Escape Reflexivity Weakening Neutral Induction. -From LogRel.Substitution Require Import Irrelevance. +From LogRel.Validity Require Import Validity Irrelevance. Set Universe Polymorphism. diff --git a/theories/Substitution/Reduction.v b/theories/Validity/Reduction.v similarity index 75% rename from theories/Substitution/Reduction.v rename to theories/Validity/Reduction.v index ad76c838..a447ff38 100644 --- a/theories/Substitution/Reduction.v +++ b/theories/Validity/Reduction.v @@ -1,6 +1,6 @@ -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening GenericTyping LogicalRelation Validity. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Irrelevance Escape Reflexivity Weakening Neutral Reduction Transitivity. +From LogRel.Validity Require Import Validity. Set Universe Polymorphism. diff --git a/theories/Substitution/Reflexivity.v b/theories/Validity/Reflexivity.v similarity index 86% rename from theories/Substitution/Reflexivity.v rename to theories/Validity/Reflexivity.v index 2a264030..80bd46f8 100644 --- a/theories/Substitution/Reflexivity.v +++ b/theories/Validity/Reflexivity.v @@ -1,7 +1,6 @@ -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening GenericTyping LogicalRelation Validity. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Irrelevance EqRedRight. -From LogRel.Substitution Require Import Irrelevance Properties. +From LogRel.Validity Require Import Validity Irrelevance Properties. Set Universe Polymorphism. diff --git a/theories/Substitution/SingleSubst.v b/theories/Validity/SingleSubst.v similarity index 97% rename from theories/Substitution/SingleSubst.v rename to theories/Validity/SingleSubst.v index 732b6ad4..5c6c23b1 100644 --- a/theories/Substitution/SingleSubst.v +++ b/theories/Validity/SingleSubst.v @@ -1,7 +1,6 @@ -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening GenericTyping LogicalRelation Validity. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation. From LogRel.LogicalRelation Require Import Induction Irrelevance Escape Reflexivity Weakening Neutral Transitivity NormalRed. -From LogRel.Substitution Require Import Irrelevance Properties Conversion Reflexivity. +From LogRel.Validity Require Import Validity Irrelevance Properties Conversion Reflexivity. Set Universe Polymorphism. diff --git a/theories/Validity.v b/theories/Validity/Validity.v similarity index 98% rename from theories/Validity.v rename to theories/Validity/Validity.v index 0e1b6e93..13d1cccd 100644 --- a/theories/Validity.v +++ b/theories/Validity/Validity.v @@ -1,5 +1,4 @@ -From LogRel.AutoSubst Require Import core unscoped Ast Extra. -From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening GenericTyping LogicalRelation EqRedRight. +From LogRel Require Import Utils Syntax.All GenericTyping LogicalRelation EqRedRight. Set Primitive Projections. Set Universe Polymorphism.