diff --git a/src/Pyrosome/Gluing/Dtt/Eqns.v b/src/Pyrosome/Gluing/Dtt/Eqns.v index 70a01fe3..1cc1820e 100644 --- a/src/Pyrosome/Gluing/Dtt/Eqns.v +++ b/src/Pyrosome/Gluing/Dtt/Eqns.v @@ -886,3 +886,97 @@ Proof. cong_step "app_irr" [a1; f1; B1; F1; lF1; rF1; G1] [a2; f2; B2; F2; lF2; rF2; G2]. Qed. + +(* ================================================================== *) +(* ott_id_cong *) +(* *) +(* The Id fragment's entries. This file and Wf.v predated the fragment *) +(* and mentioned [oIdEq] nowhere, so every consumer was rolling its own *) +(* on demand; these are the shared ones. *) +(* *) +(* THE INDEX SPELLINGS ARE NOT UNIFORM ACROSS THE FRAGMENT, and they *) +(* were determined by experiment, not by reading the rules. This is *) +(* design.md section 9b's mismatch again -- [infer_rule] re-extracts *) +(* each conclusion sort with [mk_weight], whose tie-breaks depend on the *) +(* rule's own right-hand side -- so: *) +(* *) +(* "Id", "Id subst", "Id-Nat-00" stored at iEl rel L1 *) +(* "Id-Nat-0S", "-S0", "-SS" stored at iCode L0 (= sCode) *) +(* *) +(* i.e. the three rules whose right-hand side is a Pi-shaped code got *) +(* one spelling and the three whose right-hand side is [Empty] or an *) +(* [Id] got the other. Do not "tidy" these into a single form; they are *) +(* what the compiled language actually stores. *) +(* ================================================================== *) + +(* NB the [next0] BRIDGE that turns [Wf.wf_IdEq]'s [iota L1] spelling into + the [sCode] one is NOT here, and cannot be: it needs both a [wf_] + lemma and this file's congruences, and Wf.v and Eqns.v are SIBLINGS + over Syntax.v -- neither imports the other. It lives in the first file + that imports both ([wft_c0] / [wf_IdEq_c] in Rz.v today) and should + move into whatever bridge file replaces NfTyping.v. *) + +Lemma IdEq_cong G1 G2 l1 l2 A1 A2 B1 B2 t1 t2 u1 u2 + : eq_term ott_dtt [] sEnv G1 G2 -> + eq_term ott_dtt [] sLvl l1 l2 -> + eq_term ott_dtt [] (sCode G2 oRel l2) A1 A2 -> + eq_term ott_dtt [] (sCode G2 oRel l2) B1 B2 -> + eq_term ott_dtt [] (sElt G2 oRel l2 A2) t1 t2 -> + eq_term ott_dtt [] (sElt G2 oRel l2 B2) u1 u2 -> + eq_term ott_dtt [] (sExp G2 (iEl oRel oL1) (oU G2 oIrr oL0)) + (oIdEq G1 l1 A1 B1 t1 u1) (oIdEq G2 l2 A2 B2 t2 u2). +Proof. intros; cong_step "Id" [u1;t1;B1;A1;l1;G1] [u2;t2;B2;A2;l2;G2]. Qed. + +(* ---- the substitution commutation ---- *) + +Lemma eq_Id_subst G G' g l A B t u + : wf_term ott_dtt [] G sEnv -> + wf_term ott_dtt [] G' sEnv -> + wf_term ott_dtt [] g (sSub G G') -> + wf_term ott_dtt [] l sLvl -> + wf_term ott_dtt [] A (sCode G' oRel l) -> + wf_term ott_dtt [] B (sCode G' oRel l) -> + wf_term ott_dtt [] t (sElt G' oRel l A) -> + wf_term ott_dtt [] u (sElt G' oRel l B) -> + eq_term ott_dtt [] (sExp G (iEl oRel oL1) (oU G oIrr oL0)) + (oExpSubst G G' g (iEl oRel oL1) (oU G' oIrr oL0) (oIdEq G' l A B t u)) + (oIdEq G l (oExpSubst G G' g (iCode l) (oU G' oRel l) A) + (oExpSubst G G' g (iCode l) (oU G' oRel l) B) + (oExpSubst G G' g (iEl oRel l) (oEl G' oRel l A) t) + (oExpSubst G G' g (iEl oRel l) (oEl G' oRel l B) u)). +Proof. intros; estep "Id subst". Qed. + +(* ---- the Nat computation family (design.md section 12b) ---- + + Together with the clash rules these leave an [Id] at [Nat] stuck + exactly when an ENDPOINT is neutral, which is what keeps the fragment + from adding any normal form beyond neutrals. *) + +Lemma eq_Id_Nat_00 G + : wf_term ott_dtt [] G sEnv -> + eq_term ott_dtt [] (sExp G (iEl oRel oL1) (oU G oIrr oL0)) + (oIdEq G oL0 (oNat G) (oNat G) (oZero G) (oZero G)) (oUnit G). +Proof. intros; estep "Id-Nat-00". Qed. + +Lemma eq_Id_Nat_0S G t + : wf_term ott_dtt [] G sEnv -> + wf_term ott_dtt [] t (sElt G oRel oL0 (oNat G)) -> + eq_term ott_dtt [] (sCode G oIrr oL0) + (oIdEq G oL0 (oNat G) (oNat G) (oZero G) (oSuc G t)) (oEmpty G). +Proof. intros; estep "Id-Nat-0S". Qed. + +Lemma eq_Id_Nat_S0 G t + : wf_term ott_dtt [] G sEnv -> + wf_term ott_dtt [] t (sElt G oRel oL0 (oNat G)) -> + eq_term ott_dtt [] (sCode G oIrr oL0) + (oIdEq G oL0 (oNat G) (oNat G) (oSuc G t) (oZero G)) (oEmpty G). +Proof. intros; estep "Id-Nat-S0". Qed. + +Lemma eq_Id_Nat_SS G m n + : wf_term ott_dtt [] G sEnv -> + wf_term ott_dtt [] m (sElt G oRel oL0 (oNat G)) -> + wf_term ott_dtt [] n (sElt G oRel oL0 (oNat G)) -> + eq_term ott_dtt [] (sCode G oIrr oL0) + (oIdEq G oL0 (oNat G) (oNat G) (oSuc G m) (oSuc G n)) + (oIdEq G oL0 (oNat G) (oNat G) m n). +Proof. intros; estep "Id-Nat-SS". Qed. diff --git a/src/Pyrosome/Gluing/Dtt/Inj.v b/src/Pyrosome/Gluing/Dtt/Inj.v deleted file mode 100644 index 747af65c..00000000 --- a/src/Pyrosome/Gluing/Dtt/Inj.v +++ /dev/null @@ -1,490 +0,0 @@ -Set Implicit Arguments. - -From coqutil Require Import Datatypes.String. -From Stdlib Require Import Lists.List. -Import ListNotations. -Open Scope string. -Open Scope list. -From Utils Require Import Utils. -From Pyrosome Require Import Theory.Core. -Require Import Pyrosome.Gluing.Dtt.Syntax Pyrosome.Gluing.Dtt.NormalForms - Pyrosome.Gluing.Dtt.NfTyping Pyrosome.Gluing.Dtt.Rigid - Pyrosome.Gluing.Dtt.RigidOk. -Import Core.Notations. - -(* ===================================================================== - DTT NORMALIZATION, LAYER 0.5c: CODE RIGIDITY, ASSEMBLED. - - The three theorems Layer 0.5 exports: - - NfCode_inj : normal codes are determined by provable equality - TyOk_inj : normal types are determined by provable equality - EnvOk_inj : normal environments are determined by provable equality - - src/Pyrosome/Gluing/Dtt/Rigid.v + src/Pyrosome/Gluing/Dtt/RigidOk.v - supply the semantic input, in exactly the form these theorems want: - [rigid_env]/[rigid_ty]/[rigid_code] read a provable equation as a - COMMON interpretation of the two sides, e.g. - - Req_code G e1 e2 := exists E n, IEnv G E /\ ICode E e1 n /\ ICode E e2 n. - - So injectivity is stated over the model's own relations [ICode]/[ITy]/ - [IEnv] -- two normal objects with the SAME interpretation at the SAME - [renv] are syntactically equal -- and the export is then two lines, - with nothing to construct. In particular there is no second erasure - system, no totality lemma, and no index alignment: the model has - already chosen the [renv], and both sides are already interpreted at - it. - - The only thing in the argument that is not routine is the variable - case: [VarT] (NormalForms.v) NAMES the normal representative of a - weakened type and pins it only by an [eq_term] premise, so the - index-[k+1] variable term CONTAINS the named representative of the - index-[k] one, and injectivity on variables is uniqueness of that - naming. That is settled by - - THE UNIVERSE OBSERVATION. The named type a code variable carries is - always a UNIVERSE -- a code variable's type is [oU G r l] and nothing - else. And at a universe, uniqueness of the naming is - UNCONDITIONAL: a normal type over [G] whose weakening is provably - equal to [oU (oExt G j B) r l] is syntactically [oU G r l], with the - SAME [r] and [l]. There is no recursion at all. - - So the file is linear: - - 1. Inversions for the interpretation relations of Rigid.v. - 2. [TyOk_ITy_U] -- a normal type interpreted as a universe IS one. - 3. [WknU_shape] -- uniqueness of the naming, at a universe. - 4. Variables: their interpretation is a de Bruijn index - ([VarT_ICode_var]), and a weakened one is a successor over the - tail of the [renv] ([ICode_wkn_var]). - 5. [VarTU_I_inj] / [NfCode_I_inj] / [TyOk_I_inj] / [EnvOk_I_inj] -- - injectivity, by induction on the de Bruijn index, on the - interpreted code, and on the [renv] respectively. - 6. The three exported theorems, plus the info-general - [TyOk_inj_gen] of which [TyOk_inj] is the corollary. - - Zero axioms, zero admits. - ===================================================================== *) - -Local Notation eqt := (eq_term ott_dtt []). - -(* ===================================================================== - 1. Inversions for [IEnv] / [ITy] / [ICode] / [ISub]. - - All of them are one [inversion] away; stating them keeps every proof - below free of generated hypothesis names. The [IEnv] pair is inverted - on the shape of the [renv], the rest on the shape of the SUBJECT term. - ===================================================================== *) - -Lemma IEnv_nil_inv G : IEnv G [] -> G = oEmp. -Proof. inversion 1; reflexivity. Qed. - -Lemma IEnv_cons_inv G T E - : IEnv G (T :: E) -> exists G0 i A, G = oExt G0 i A /\ IEnv G0 E /\ ITy E A T. -Proof. inversion 1; subst; eauto 10. Qed. - -Lemma ITy_U_inv E G r l T - : ITy E (oU G r l) T -> - exists br bl, T = rt_U br bl /\ IEnv G E /\ ErRel r br /\ ErLvl l bl. -Proof. inversion 1; subst; eauto 10. Qed. - -Lemma ITy_El_inv E G r l c T - : ITy E (oEl G r l c) T -> - exists br bl n, T = rt_El br bl n /\ IEnv G E - /\ ErRel r br /\ ErLvl l bl /\ ICode E c n. -Proof. inversion 1; subst; eauto 10. Qed. - -Lemma ITy_subst_inv E G G' g i A T - : ITy E (oTySubst G G' g i A) T -> - exists E' s T0, - IEnv G E /\ IEnv G' E' /\ ISub E E' g s /\ ITy E' A T0 - /\ T = tsub s T0. -Proof. inversion 1; subst; eauto 10. Qed. - -Lemma ISub_wkn_inv E E' G i A s - : ISub E E' (oWkn G i A) s -> - exists T, E = T :: E' /\ IEnv G E' /\ ITy E' A T /\ s = rshift. -Proof. inversion 1; subst; eauto 10. Qed. - -Lemma ICode_hd_inv E G i A n : ICode E (oHd G i A) n -> n = rc_var 0. -Proof. inversion 1; subst; reflexivity. Qed. - -(* NB the image here is [csub s n0], NOT a constructor pattern: the - [icode_subst] clause applies the interpreted substitution. That is why - the shape of a variable's interpretation needs section 4 rather than an - inversion. *) -Lemma ICode_subst_inv E G G' g i A v n - : ICode E (oExpSubst G G' g i A v) n -> - exists E' s n0, ISub E E' g s /\ ICode E' v n0 /\ n = csub s n0. -Proof. inversion 1; subst; eauto 10. Qed. - -Lemma ICode_nat_inv E G0 n : ICode E (oNat G0) n -> n = rc_nat. -Proof. inversion 1; subst; reflexivity. Qed. - -Lemma ICode_empty_inv E G0 n : ICode E (oEmpty G0) n -> n = rc_empty. -Proof. inversion 1; subst; reflexivity. Qed. - -Lemma ICode_pi_rel_inv E G0 rF lF lG F B n - : ICode E (oPiRel G0 rF lF lG F B) n -> - exists brF blF nF nB, - n = rc_pi true brF blF nF nB /\ ErRel rF brF /\ ErLvl lF blF - /\ ICode E F nF /\ ICode (rt_El brF blF nF :: E) B nB. -Proof. inversion 1; subst; eauto 20. Qed. - -Lemma ICode_pi_irr_inv E G0 rF lF F B n - : ICode E (oPiIrr G0 rF lF F B) n -> - exists brF blF nF nB, - n = rc_pi false brF blF nF nB /\ ErRel rF brF /\ ErLvl lF blF - /\ ICode E F nF /\ ICode (rt_El brF blF nF :: E) B nB. -Proof. inversion 1; subst; eauto 20. Qed. - -(* ===================================================================== - 2. A normal type whose interpretation is a universe IS a universe. - ===================================================================== *) - -Lemma TyOk_ITy_U E G i A br bl - : TyOk G i A -> ITy E A (rt_U br bl) -> - exists r l, A = oU G r l /\ ErRel r br /\ ErLvl l bl. -Proof. - intros Hty HI; inversion Hty; subst. - - apply ITy_U_inv in HI. - destruct HI as [br0 [bl0 [Heq [_ [Hr Hl]]]]]. - injection Heq as -> ->. - eauto 10. - - apply ITy_El_inv in HI. - destruct HI as [br0 [bl0 [n0 [Heq _]]]]; discriminate Heq. -Qed. - -(* ===================================================================== - 3. [WknU_shape]: uniqueness of the naming, at a universe. - - Given a normal type [A] over [G] whose weakening to [oExt G j B] is - provably equal to the universe [oU (oExt G j B) r l], [A] is [oU G r l] - -- the SAME [r] and [l]. Unconditional: no induction, no appeal to - type injectivity at any environment. - - This is the whole of what the variable case needs, because the only - variables a CODE can contain are universe-typed. - ===================================================================== *) - -Lemma WknU_shape G j B i A r l - : TyOk G i A -> - eqt (sTy (oExt G j B) i) - (oTySubst (oExt G j B) G (oWkn G j B) i A) - (oU (oExt G j B) r l) -> - A = oU G r l. -Proof. - intros Hty Heq. - destruct (rigid_ty Heq) as [Ex [Tx [HEx [Hsub Hu]]]]. - apply ITy_U_inv in Hu. - destruct Hu as [br [bl [HTx [_ [Hr Hl]]]]]; subst Tx. - apply ITy_subst_inv in Hsub. - destruct Hsub as [E' [s [T0 [_ [HG' [Hs [HT0 HTeq]]]]]]]. - apply ISub_wkn_inv in Hs. - destruct Hs as [T [HEeq [HGE [HTB Hsr]]]]; subst s. - destruct T0 as [ br0 bl0 | br0 bl0 n0 ]; cbn in HTeq; [ | discriminate ]. - injection HTeq as -> ->. - destruct (TyOk_ITy_U Hty HT0) as [r0 [l0 [-> [Hr0 Hl0]]]]. - pose proof (ErRel_inj Hr0 Hr) as ->. - pose proof (ErLvl_inj Hl0 Hl) as ->. - reflexivity. -Qed. - -(* ===================================================================== - 4. Variables interpret to de Bruijn indices. - - [ICode]'s [icode_subst] clause produces [csub s n0], which is not a - constructor pattern, so the shape of a variable's interpretation is not - read off by inversion alone -- it needs the induction below. These two - lemmas are the whole of that cost. - ===================================================================== *) - -Lemma VarT_ICode_var G i A x (H : VarT G i A x) - : forall E n, ICode E x n -> exists k, n = rc_var k. -Proof. - induction H; intros E n HI. - - apply ICode_hd_inv in HI; eauto. - - apply ICode_subst_inv in HI. - destruct HI as [E' [s [n0 [Hs [Hn0 ->]]]]]. - apply ISub_wkn_inv in Hs; destruct Hs as [T [-> [_ [_ ->]]]]. - destruct (IHVarT _ _ Hn0) as [k ->]. - exists (S k); reflexivity. -Qed. - -(* The subject of a [VarT] is an [oHd] or a [wkn]-substituted variable. *) -Lemma VarT_shape G i A x : VarT G i A x -> - (exists G0 i0 A0, x = oHd G0 i0 A0) - \/ (exists G0 j B i0 A0 y, - x = oExpSubst (oExt G0 j B) G0 (oWkn G0 j B) i0 A0 y). -Proof. destruct 1; [ left | right ]; eauto 10. Qed. - -(* A weakened variable interprets to a SUCCESSOR, over the tail of [E]. *) -Lemma ICode_wkn_var G0 j B i0 A0 y E k - : VarT G0 i0 A0 y -> - ICode E (oExpSubst (oExt G0 j B) G0 (oWkn G0 j B) i0 A0 y) (rc_var k) -> - exists k0 E0 T, k = S k0 /\ E = T :: E0 /\ ICode E0 y (rc_var k0). -Proof. - intros Hv Hi. - apply ICode_subst_inv in Hi. - destruct Hi as [E' [s [n0 [Hs [Hn0 Heq]]]]]. - apply ISub_wkn_inv in Hs; destruct Hs as [T [HE [_ [_ ->]]]]. - destruct (VarT_ICode_var Hv Hn0) as [k0 ->]. - cbn in Heq; safe_invert Heq. - exists k0, E', T; repeat split; assumption. -Qed. - -(* ===================================================================== - 5. Injectivity, over the interpretation relations. - - Order: variables first (induction on the de Bruijn INDEX), then codes - (induction on the interpreted code), then types (one case analysis) and - environments (induction on the [renv]). - ===================================================================== *) - -(* Variables, at a universe type. That is the only form the code-level - theorem needs -- a code variable's type is [oU G r l], whose [r] and - [l] the statement of [NfCode_I_inj] fixes -- and it is the form whose - naming is settled by [WknU_shape]. - - Index 0 is settled by the ambient environment's own syntax; index k+1 - is where [WknU_shape] is spent. *) -Theorem VarTU_I_inj : - forall k E G r l x1 x2, - VarT G (iCode l) (oU G r l) x1 -> VarT G (iCode l) (oU G r l) x2 -> - ICode E x1 (rc_var k) -> ICode E x2 (rc_var k) -> x1 = x2. -Proof. - induction k; intros E G r l x1 x2 Hv1 Hv2 Hi1 Hi2; - destruct (VarT_shape Hv1) as [ [Ga [ia [Aa ->]]] - | [Ga [ja [Ba [ia [Aa [ya ->]]]]]] ]; - destruct (VarT_shape Hv2) as [ [Gb [ib [Ab ->]]] - | [Gb [jb [Bb [ib [Ab [yb ->]]]]]] ]. - - (* 0: hd / hd -- the ambient environment determines the head *) - apply VarT_hd_inv in Hv1; destruct Hv1 as [-> _]. - apply VarT_hd_inv in Hv2; destruct Hv2 as [Heq _]. - unfold oExt in Heq; safe_invert Heq; reflexivity. - - (* 0: hd / wkn -- a weakening never interprets to index 0 *) - apply VarT_wkn_inv in Hv2; destruct Hv2 as [_ [_ [Hin2 _]]]. - destruct (ICode_wkn_var Hin2 Hi2) as [? [? [? [Habs _]]]]; discriminate. - - apply VarT_wkn_inv in Hv1; destruct Hv1 as [_ [_ [Hin1 _]]]. - destruct (ICode_wkn_var Hin1 Hi1) as [? [? [? [Habs _]]]]; discriminate. - - apply VarT_wkn_inv in Hv1; destruct Hv1 as [_ [_ [Hin1 _]]]. - destruct (ICode_wkn_var Hin1 Hi1) as [? [? [? [Habs _]]]]; discriminate. - - (* S k: hd / hd -- [hd] never interprets to a successor *) - apply ICode_hd_inv in Hi1; discriminate. - - apply ICode_hd_inv in Hi1; discriminate. - - apply ICode_hd_inv in Hi2; discriminate. - - (* S k: wkn / wkn -- the named types are universes by [WknU_shape], - and the inner variables agree by the induction hypothesis *) - apply VarT_wkn_inv in Hv1; destruct Hv1 as [HGa [Hia [Hin1 [_ Heq1]]]]. - apply VarT_wkn_inv in Hv2; destruct Hv2 as [HGb [Hib [Hin2 [_ Heq2]]]]. - subst G; unfold oExt in HGb; safe_invert HGb. - subst. - pose proof (WknU_shape (VarT_TyOk Hin1) Heq1) as ->. - pose proof (WknU_shape (VarT_TyOk Hin2) Heq2) as ->. - f_equal. - destruct (ICode_wkn_var Hin1 Hi1) as [ka [Ea [Ta [Hka [HEa Ha]]]]]. - subst E. - destruct (ICode_wkn_var Hin2 Hi2) as [kb [Eb [Tb [Hkb [HEb Hb]]]]]. - safe_invert HEb; safe_invert Hka; safe_invert Hkb. - eapply IHk; eassumption. -Qed. - -(* A canonical code never interprets to a variable's index. *) -Ltac kill_var Hi := - match goal with - | Hv : VarT _ _ _ _ |- _ => - let k := fresh in let Habs := fresh in - destruct (VarT_ICode_var Hv Hi) as [k Habs]; discriminate - end. - -(* Codes. The [Pi] clauses need nothing about variables: the domain's - relevance and level are recovered from the interpretation by - [ErRel_inj]/[ErLvl_inj] (the design point of Rigid.v section 0), after - which the two extended [renv]s are literally the same and the induction - hypotheses apply. *) -Theorem NfCode_I_inj : - forall n E G r l c1 c2, - NfCode G r l c1 -> NfCode G r l c2 -> - ICode E c1 n -> ICode E c2 n -> c1 = c2. -Proof. - induction n as [ k | | | b brF blF nF IHF nB IHB ]; - intros E G r l c1 c2 Hc1 Hc2 Hi1 Hi2. - - (* rc_var *) - destruct Hc1; try (apply ICode_nat_inv in Hi1; discriminate); - try (apply ICode_empty_inv in Hi1; discriminate); - try (apply ICode_pi_rel_inv in Hi1; - destruct Hi1 as [? [? [? [? [Habs _]]]]]; discriminate); - try (apply ICode_pi_irr_inv in Hi1; - destruct Hi1 as [? [? [? [? [Habs _]]]]]; discriminate). - destruct Hc2; try (apply ICode_nat_inv in Hi2; discriminate); - try (apply ICode_empty_inv in Hi2; discriminate); - try (apply ICode_pi_rel_inv in Hi2; - destruct Hi2 as [? [? [? [? [Habs _]]]]]; discriminate); - try (apply ICode_pi_irr_inv in Hi2; - destruct Hi2 as [? [? [? [? [Habs _]]]]]; discriminate). - eapply VarTU_I_inj; eassumption. - - (* rc_nat *) - destruct Hc1; try (apply ICode_empty_inv in Hi1; discriminate); - try (apply ICode_pi_rel_inv in Hi1; - destruct Hi1 as [? [? [? [? [Habs _]]]]]; discriminate); - try (apply ICode_pi_irr_inv in Hi1; - destruct Hi1 as [? [? [? [? [Habs _]]]]]; discriminate); - try (kill_var Hi1). - destruct Hc2; try (apply ICode_empty_inv in Hi2; discriminate); - try (apply ICode_pi_rel_inv in Hi2; - destruct Hi2 as [? [? [? [? [Habs _]]]]]; discriminate); - try (apply ICode_pi_irr_inv in Hi2; - destruct Hi2 as [? [? [? [? [Habs _]]]]]; discriminate); - try (kill_var Hi2). - reflexivity. - - (* rc_empty *) - destruct Hc1; try (apply ICode_nat_inv in Hi1; discriminate); - try (apply ICode_pi_rel_inv in Hi1; - destruct Hi1 as [? [? [? [? [Habs _]]]]]; discriminate); - try (apply ICode_pi_irr_inv in Hi1; - destruct Hi1 as [? [? [? [? [Habs _]]]]]; discriminate); - try (kill_var Hi1). - destruct Hc2; try (apply ICode_nat_inv in Hi2; discriminate); - try (apply ICode_pi_rel_inv in Hi2; - destruct Hi2 as [? [? [? [? [Habs _]]]]]; discriminate); - try (apply ICode_pi_irr_inv in Hi2; - destruct Hi2 as [? [? [? [? [Habs _]]]]]; discriminate); - try (kill_var Hi2). - reflexivity. - - (* rc_pi *) - destruct Hc1; try (apply ICode_nat_inv in Hi1; discriminate); - try (apply ICode_empty_inv in Hi1; discriminate); - try (kill_var Hi1). - + (* pi_rel *) - destruct Hc2; try (apply ICode_nat_inv in Hi2; discriminate); - try (apply ICode_empty_inv in Hi2; discriminate); - try (kill_var Hi2). - * apply ICode_pi_rel_inv in Hi1. - destruct Hi1 as [br1 [bl1 [n1 [m1 [Heq1 [Hr1 [Hl1 [HF1 HB1]]]]]]]]. - apply ICode_pi_rel_inv in Hi2. - destruct Hi2 as [br2 [bl2 [n2 [m2 [Heq2 [Hr2 [Hl2 [HF2 HB2]]]]]]]]. - safe_invert Heq1; safe_invert Heq2. - pose proof (ErRel_inj Hr1 Hr2) as ->. - pose proof (ErLvl_inj Hl1 Hl2) as ->. - pose proof (IHF _ _ _ _ _ _ Hc1_1 Hc2_1 HF1 HF2) as ->. - pose proof (IHB _ _ _ _ _ _ Hc1_2 Hc2_2 HB1 HB2) as ->. - reflexivity. - * apply ICode_pi_rel_inv in Hi1. - destruct Hi1 as [? [? [? [? [Heq1 _]]]]]. - apply ICode_pi_irr_inv in Hi2. - destruct Hi2 as [? [? [? [? [Heq2 _]]]]]. - rewrite Heq1 in Heq2; discriminate. - + (* pi_irr *) - destruct Hc2; try (apply ICode_nat_inv in Hi2; discriminate); - try (apply ICode_empty_inv in Hi2; discriminate); - try (kill_var Hi2). - * apply ICode_pi_irr_inv in Hi1. - destruct Hi1 as [? [? [? [? [Heq1 _]]]]]. - apply ICode_pi_rel_inv in Hi2. - destruct Hi2 as [? [? [? [? [Heq2 _]]]]]. - rewrite Heq1 in Heq2; discriminate. - * apply ICode_pi_irr_inv in Hi1. - destruct Hi1 as [br1 [bl1 [n1 [m1 [Heq1 [Hr1 [Hl1 [HF1 HB1]]]]]]]]. - apply ICode_pi_irr_inv in Hi2. - destruct Hi2 as [br2 [bl2 [n2 [m2 [Heq2 [Hr2 [Hl2 [HF2 HB2]]]]]]]]. - safe_invert Heq1; safe_invert Heq2. - pose proof (ErRel_inj Hr1 Hr2) as ->. - pose proof (ErLvl_inj Hl1 Hl2) as ->. - pose proof (IHF _ _ _ _ _ _ Hc1_1 Hc2_1 HF1 HF2) as ->. - pose proof (IHB _ _ _ _ _ _ Hc1_2 Hc2_2 HB1 HB2) as ->. - reflexivity. -Qed. - -(* Types. Also concludes that the two info indices agree, which - [EnvOk_I_inj] needs. *) -Theorem TyOk_I_inj E G i1 A1 i2 A2 T - : TyOk G i1 A1 -> TyOk G i2 A2 -> ITy E A1 T -> ITy E A2 T -> - i1 = i2 /\ A1 = A2. -Proof. - intros Ht1 Ht2 Hi1 Hi2. - destruct Ht1 as [ G r1 l1 | G r1 l1 c1 ]; - destruct Ht2 as [ G r2 l2 | G r2 l2 c2 ]. - - apply ITy_U_inv in Hi1; destruct Hi1 as [br1 [bl1 [-> [_ [Hr1 Hl1]]]]]. - apply ITy_U_inv in Hi2; destruct Hi2 as [br2 [bl2 [Heq [_ [Hr2 Hl2]]]]]. - safe_invert Heq. - pose proof (ErRel_inj Hr1 Hr2) as ->. - pose proof (ErLvl_inj Hl1 Hl2) as ->. - split; reflexivity. - - apply ITy_U_inv in Hi1; destruct Hi1 as [? [? [-> _]]]. - apply ITy_El_inv in Hi2; destruct Hi2 as [? [? [? [Heq _]]]]; discriminate. - - apply ITy_U_inv in Hi2; destruct Hi2 as [? [? [-> _]]]. - apply ITy_El_inv in Hi1; destruct Hi1 as [? [? [? [Heq _]]]]; discriminate. - - apply ITy_El_inv in Hi1; - destruct Hi1 as [br1 [bl1 [n1 [-> [_ [Hr1 [Hl1 Hc1]]]]]]]. - apply ITy_El_inv in Hi2; - destruct Hi2 as [br2 [bl2 [n2 [Heq [_ [Hr2 [Hl2 Hc2]]]]]]]. - safe_invert Heq. - pose proof (ErRel_inj Hr1 Hr2) as ->. - pose proof (ErLvl_inj Hl1 Hl2) as ->. - pose proof (NfCode_I_inj H H0 Hc1 Hc2) as ->. - split; reflexivity. -Qed. - -Theorem EnvOk_I_inj : - forall E G1 G2, EnvOk G1 -> EnvOk G2 -> IEnv G1 E -> IEnv G2 E -> G1 = G2. -Proof. - induction E as [ | T E IHE ]; intros G1 G2 H1 H2 Hi1 Hi2. - - apply IEnv_nil_inv in Hi1; apply IEnv_nil_inv in Hi2; subst; reflexivity. - - apply IEnv_cons_inv in Hi1; - destruct Hi1 as [Ga [ia [Aa [-> [HEa HTa]]]]]. - apply IEnv_cons_inv in Hi2; - destruct Hi2 as [Gb [ib [Ab [-> [HEb HTb]]]]]. - apply EnvOk_ext_inv in H1; destruct H1 as [HOa HTya]. - apply EnvOk_ext_inv in H2; destruct H2 as [HOb HTyb]. - pose proof (IHE _ _ HOa HOb HEa HEb) as ->. - destruct (TyOk_I_inj HTya HTyb HTa HTb) as [-> ->]. - reflexivity. -Qed. - -(* ===================================================================== - 6. The exported theorems. - - Each is: read the equation through the rigid model, which hands back a - COMMON interpretation of the two sides at a common [renv]; then apply - section 5. Nothing is constructed. - ===================================================================== *) - -Theorem NfCode_inj G r l c1 c2 : - NfCode G r l c1 -> NfCode G r l c2 -> - eq_term ott_dtt [] (sCode G r l) c1 c2 -> c1 = c2. -Proof. - intros Hc1 Hc2 Heq. - destruct (rigid_code Heq) as [E [n [_ [HI1 HI2]]]]. - eapply NfCode_I_inj; eassumption. -Qed. - -(* The INFO-GENERAL form: the sort [j] at which the equation is read is - unrelated to the infos [i1]/[i2] the two normal types are pinned at. - [rceq_term] at a [ty] sort is [Req_ty G A1 A2], which does not mention - the info at all, and the interpretation pins the infos anyway -- so - there is nothing extra to do. src/Pyrosome/Gluing/Dtt/LogRelFun.v needs - this form; the info-fixed [TyOk_inj] below is its corollary. *) -Theorem TyOk_inj_gen G j i1 A1 i2 A2 - : TyOk G i1 A1 -> TyOk G i2 A2 -> - eq_term ott_dtt [] (sTy G j) A1 A2 -> i1 = i2 /\ A1 = A2. -Proof. - intros Ht1 Ht2 Heq. - destruct (rigid_ty Heq) as [E [T [_ [HI1 HI2]]]]. - eapply TyOk_I_inj; eassumption. -Qed. - -Theorem TyOk_inj G i A1 A2 : - TyOk G i A1 -> TyOk G i A2 -> eq_term ott_dtt [] (sTy G i) A1 A2 -> A1 = A2. -Proof. - intros Ht1 Ht2 Heq. - destruct (TyOk_inj_gen Ht1 Ht2 Heq) as [_ ?]; assumption. -Qed. - -Theorem EnvOk_inj G1 G2 : - EnvOk G1 -> EnvOk G2 -> eq_term ott_dtt [] sEnv G1 G2 -> G1 = G2. -Proof. - intros H1 H2 Heq. - destruct (rigid_env Heq) as [E [HI1 HI2]]. - eapply EnvOk_I_inj; eassumption. -Qed. diff --git a/src/Pyrosome/Gluing/Dtt/Inst.v b/src/Pyrosome/Gluing/Dtt/Inst.v new file mode 100644 index 00000000..b4d3e5b6 --- /dev/null +++ b/src/Pyrosome/Gluing/Dtt/Inst.v @@ -0,0 +1,764 @@ +Set Implicit Arguments. + +From coqutil Require Import Datatypes.String. +From Stdlib Require Import Lists.List. +Import ListNotations. +Open Scope string. +Open Scope list. +From Utils Require Import Utils. +From Pyrosome Require Import Theory.Core. +Require Import Pyrosome.Gluing.Dtt.Syntax. +(* [Require EXPORT]: everything downstream of the instantiation layer wants the + value judgements and (through Values.v) the weakening block as well. *) +Require Export Pyrosome.Gluing.Dtt.Values. +Import Core.Notations. + +(* ===================================================================== + INSTANTIATION OF VALUES -- THE SUBSTITUTION HALF OF [Nrm]. + + WHY THIS IS NOT A SECOND COPY OF WkRel.v. Weakening never creates a + redex; it only shifts, which is why WkRel.v is purely structural and + why it was cheap (design.md section 14f). Instantiation substitutes a + VALUE for a variable, and a value in a neutral's head position turns + that neutral into a redex. So this relation must EVALUATE: it is not + a sibling of the weakening block but a fragment of the normalizer + (design.md section 14k). + + WHERE, EXACTLY, IT EVALUATES. Only two places, and both are visible + as a non-structural premise below: + + - [insttm_app_rel] hands its instantiated head to [AppV]. When the + head was the variable being substituted and the substituted value + is a [lam_rel], [AppV] fires beta; otherwise the application stays + neutral. + - [insttm_id] hands its four instantiated arguments to [IdV]. An + [Id] value is a STUCK [Id] (Values.v's [necode_id_*]), and + instantiation can unstick it: when the stuck endpoint is the + de Bruijn-0 variable at [El _ rel L0 (Nat _)], substituting [zero] + or [suc n] fires "Id-Nat-00"/"-0S"/"-S0"/"-SS". + + Everything else -- [Nat], [Empty], [Pi_rel], [Pi_irr], [zero], [suc], + [*], [lam_rel], [Emptyrec], and code VARIABLES -- is structural. A + code variable's type is a universe, and the de Bruijn-0 variable of + [oExtC G rF lF F] has type [El _ rF lF F[wkn]], an [El]; so a code + variable is NEVER the one being substituted and always merely strips. + For the same reason an [Id] stuck on a neutral CODE stays stuck. + + THE FIVE JUDGEMENTS (design.md section 14k's own count): + + InstTy D G g i A A' types + InstTm D G g e e' codes AND elements, in ONE judgement + InstVar D G g x x' variables + AppV G rF lF lG F B f a r the value of an application (beta) + IdV G l A B t u c the section-12b Id computation table + + The first three mirror WkRel.v exactly, including the reason codes and + elements share a judgement (their head symbols are pairwise disjoint, + which turns determinism into a discrimination argument) and the reason + [InstTm] carries no type index (every annotation a value carries is + already stored in the subject). + + ONE DIFFERENCE FROM WkRel.v WORTH NOTING: [InstVar] needs no type index + at all, so there is no analogue of WkRel.v's fourth judgement [VarTy]. + [VarTy] was forced there because [wkvar_wkn] EMITS + [exp_subst wkn i A x], whose annotation [A] the relation would + otherwise never pin. No clause here emits a new annotation: + [instvar_snoc_hd] returns the substituted value, [instvar_snoc_wkn] + returns a recursive result, and [instvar_cmp] returns a WEAKENING of + one, computed by the already-closed [WkTm]. + + THE DEPENDENCY ON WkRel IS REAL AND ONE-WAY. [instvar_cmp] is the + single place it appears, and it is not removable. Trace the + de Bruijn-1 variable through one lift: the lifted substitution is + [oLiftW D G g i A A'], i.e. [], so a shifted variable + [y] goes to [y[cmp (wkn) g]] = [(y[g])[wkn]] -- and [y[g]] is in + general the SUBSTITUTED VALUE, not a variable, so weakening it is a + [WkTm] call and not something the emitted syntax already contains. + (An earlier note expected the [oCmp _ (oWkn _) g] inside [oLiftW] to + make this unnecessary. It does not: that spelling supplies the + weakening SUBSTITUTION, but the thing being weakened is a value, and + only [WkTm] computes the value of a weakened value.) Nothing runs the + other way: no clause of WkRel.v mentions instantiation, exactly because + weakening creates no redex. + ===================================================================== *) + +(* ------------------------------------------------------------------ *) +(* Vocabulary *) +(* ------------------------------------------------------------------ *) + +(* The weakening out of, and the de Bruijn-0 variable of, a context + extended by the type named by a code -- the [oExtC] of Syntax.v. *) +Definition oWknC (G rF lF F : term) : term := + oWkn G (iEl rF lF) (oEl G rF lF F). +Definition oHdC (G rF lF F : term) : term := + oHd G (iEl rF lF) (oEl G rF lF F). + +(* The lift of [g : sub D G] under a binder whose code is [F] over [G] and + [F'] over [D]. It is WkRel.v's [oLiftW] at the [El] info, and that is + not a coincidence: the shape is fixed by the compiled substitution + commutations (Syntax.v's [oLift]), so weakening and instantiation lift + the same way. Note it is a [snoc] whose tail is a [cmp] with a [wkn] -- + which is exactly the two shapes [InstVar] dispatches on. *) +Definition oLiftC (D G g rF lF F F' : term) : term := + oLiftW D G g (iEl rF lF) (oEl G rF lF F) (oEl D rF lF F'). + +Section WithInstC. + + (* Values.v's last parameter, threaded through. [instC G rF lF F a lG B] + is the value of [B[]], used only as the type index of an + [app_rel] neutral. It is exactly what [InstTm] below computes, so the + two are destined to be identified -- but not here: Values.v is + upstream of this file (its judgements are premises of [IdV]), so the + identification is a job for whatever file replaces the [instC] + parameter by an [InstTm] premise, in the same way [wkTy] was replaced + by a [WkTy] premise. *) + Context (instC : term -> term -> term -> term -> term -> term -> term -> term). + +(* ------------------------------------------------------------------ *) +(* Three refutations, from Values.v's shape lemmas *) +(* *) +(* These are the disjointness half of the tables below. [NeCode_not_nat] *) +(* and [NeCode_not_pi_rel] (Values.v) separate a STUCK [Id] from a *) +(* computing one at the CODE level; these three do the same at the *) +(* ELEMENT level -- they are what stops a neutral endpoint from also *) +(* matching [zero]/[suc], and a neutral function from also matching a *) +(* [lam_rel]. *) +(* ------------------------------------------------------------------ *) + +Ltac ne_shape_discriminate H := + apply ValNe_shape in H; + repeat match goal with + | Hd : _ \/ _ |- _ => destruct Hd + | Hd : exists _, _ |- _ => destruct Hd + end; + discriminate. + +Lemma ValNe_not_zero G i A G0 + : ValNe instC G i A (oZero G0) -> False. +Proof. intro H; ne_shape_discriminate H. Qed. + +Lemma ValNe_not_suc G i A G0 n + : ValNe instC G i A (oSuc G0 n) -> False. +Proof. intro H; ne_shape_discriminate H. Qed. + +Lemma ValNe_not_lam_rel G i A G0 rF lF lG F B t + : ValNe instC G i A (oLamRel G0 rF lF lG F B t) -> False. +Proof. intro H; ne_shape_discriminate H. Qed. + +(* ================================================================== *) +(* The block *) +(* ================================================================== *) + +Inductive InstTy : term -> term -> term -> term -> term -> term -> Prop := +| instty_U : forall D G g r l, + InstTy D G g (iCode l) (oU G r l) (oU D r l) +| instty_El : forall D G g r l c c', + InstTm D G g c c' -> + InstTy D G g (iEl r l) (oEl G r l c) (oEl D r l c') + +(* [InstTm D G g e e'] : [e], a value over [G], has value [e'] over [D] + after the substitution [g : sub D G]. Head-directed on [e] except at + the two variable clauses, which are head-directed too -- see the note + on [wktm_var_hd]/[wktm_var_wkn] in WkRel.v for why the single-clause + version is unsound for [inversion]. *) +with InstTm : term -> term -> term -> term -> term -> Prop := +(* ---- codes: structural ---- *) +| insttm_nat : forall D G g, InstTm D G g (oNat G) (oNat D) +| insttm_empty : forall D G g, InstTm D G g (oEmpty G) (oEmpty D) +| insttm_pi_rel : forall D G g rF lF lG F B F' B', + InstTm D G g F F' -> + InstTm (oExtC D rF lF F') (oExtC G rF lF F) (oLiftC D G g rF lF F F') B B' -> + InstTm D G g (oPiRel G rF lF lG F B) (oPiRel D rF lF lG F' B') +| insttm_pi_irr : forall D G g rF lF F B F' B', + InstTm D G g F F' -> + InstTm (oExtC D rF lF F') (oExtC G rF lF F) (oLiftC D G g rF lF F F') B B' -> + InstTm D G g (oPiIrr G rF lF F B) (oPiIrr D rF lF F' B') +(* THE ONE CODE CLAUSE THAT EVALUATES. A value [Id] is a stuck one, and + instantiating its arguments can unstick it; [IdV] is the whole of + design.md section 12b's computation table. *) +| insttm_id : forall D G g l A B t u A' B' t' u' c, + InstTm D G g A A' -> InstTm D G g B B' -> + InstTm D G g t t' -> InstTm D G g u u' -> + IdV D l A' B' t' u' c -> + InstTm D G g (oIdEq G l A B t u) c +(* ---- elements ---- *) +| insttm_zero : forall D G g, InstTm D G g (oZero G) (oZero D) +| insttm_suc : forall D G g n n', + InstTm D G g n n' -> InstTm D G g (oSuc G n) (oSuc D n') +(* The entire irrelevant fragment, in one clause: [*] instantiates to + [*]. This is what makes every irrelevant clause of the block free. *) +| insttm_star : forall D G g, InstTm D G g oStar oStar +| insttm_lam_rel : forall D G g rF lF lG F B t F' B' t', + InstTm D G g F F' -> + InstTm (oExtC D rF lF F') (oExtC G rF lF F) (oLiftC D G g rF lF F F') B B' -> + InstTm (oExtC D rF lF F') (oExtC G rF lF F) (oLiftC D G g rF lF F F') t t' -> + InstTm D G g (oLamRel G rF lF lG F B t) (oLamRel D rF lF lG F' B' t') +(* THE OTHER CLAUSE THAT EVALUATES: the head may become a [lam_rel]. *) +| insttm_app_rel : forall D G g rF lF lG F B f a F' B' f' a' r, + InstTm D G g F F' -> + InstTm (oExtC D rF lF F') (oExtC G rF lF F) (oLiftC D G g rF lF F F') B B' -> + InstTm D G g f f' -> InstTm D G g a a' -> + AppV D rF lF lG F' B' f' a' r -> + InstTm D G g (oAppRel G rF lF lG F B f a) r +(* [Emptyrec] has no computation rule -- [Empty] has no constructors -- so + it is structural even though it is an eliminator. Its argument is the + literal [oStar] of [valne_emptyrec]. *) +| insttm_emptyrec : forall D G g rA lA A A', + InstTm D G g A A' -> + InstTm D G g (oEmptyrec G rA lA A oStar) (oEmptyrec D rA lA A' oStar) +(* ---- variables ---- *) +| insttm_var_hd : forall D G g G0 i0 A0 x', + InstVar D G g (oHd G0 i0 A0) x' -> + InstTm D G g (oHd G0 i0 A0) x' +| insttm_var_wkn : forall D G g G0 j B i0 A0 y x', + InstVar D G g (oExpSubst (oExt G0 j B) G0 (oWkn G0 j B) i0 A0 y) x' -> + InstTm D G g (oExpSubst (oExt G0 j B) G0 (oWkn G0 j B) i0 A0 y) x' + +(* [InstVar D G g x x'] : the variable [x] of [G] has value [x'] over [D] + after [g]. DISPATCH IS ON [g] FIRST, then on [x] -- the mirror image of + [WkVar], and the reason [instvar_id]'s unconstrained subject is harmless + (the clause is pinned by [g = oId G], which no other clause's [g] + matches). + + No type index: see the header. The three substitution shapes are + exactly those reachable from [oInst] by lifting -- [oId] at the bottom, + [oSnoc] for the substitution itself and for every lift of it, and + [oCmp _ (oWkn _) _] for the tail a lift introduces. *) +with InstVar : term -> term -> term -> term -> term -> Prop := +| instvar_id : forall G i A x, + VarTy G i A x -> InstVar G G (oId G) x x +| instvar_snoc_hd : forall D G i A g0 v, + InstVar D (oExt G i A) (oSnoc D G i A g0 v) (oHd G i A) v +| instvar_snoc_wkn : forall D G i A g0 v i0 A0 y y', + InstVar D G g0 y y' -> + InstVar D (oExt G i A) (oSnoc D G i A g0 v) + (oExpSubst (oExt G i A) G (oWkn G i A) i0 A0 y) y' +(* THE [WkTm] CALL, and the only one in the block. [x[cmp w g0]] is + [(x[g0])[w]], and [x[g0]] is in general a substituted VALUE. *) +| instvar_cmp : forall D D0 G w g0 x x0 x', + InstVar D0 G g0 x x0 -> + WkTm D D0 w x0 x' -> + InstVar D G (oCmp D D0 G w g0) x x' + +(* [AppV G rF lF lG F B f a r] : applying the value [f] (at + [El G rel lG (Pi_rel G rF lF lG F B)]) to the value [a] gives [r]. + + TWO CLAUSES, and the asymmetry between them is worth stating. At a + [Pi_rel] type eta leaves no neutral VALUE ([Val_pi_rel_shape]), so + [appv_beta] is the only case that can arise when [f] came from + normalizing a term at that type. But [valne_app_rel]'s own head + premise is a [ValNe], not a [Val] -- a variable of [Pi] type is neutral + without being a value there -- so an application whose head survives + instantiation as a neutral is real, and [appv_ne] is what keeps + [insttm_app_rel] from getting stuck on it. *) +with AppV : term -> term -> term -> term -> term -> term -> term -> term + -> term -> Prop := +| appv_beta : forall G rF lF lG F B t a r, + InstTm G (oExtC G rF lF F) (oInst G rF lF F a) t r -> + AppV G rF lF lG F B (oLamRel G rF lF lG F B t) a r +| appv_ne : forall G rF lF lG F B f a, + ValNe instC G (iEl oRel lG) (oEl G oRel lG (oPiRel G rF lF lG F B)) f -> + AppV G rF lF lG F B f a (oAppRel G rF lF lG F B f a) + +(* ================================================================== *) +(* [IdV] -- THE Id COMPUTATION TABLE (design.md section 12b) *) +(* ================================================================== *) + +(* [IdV G l A B t u c] : the value of [Id G l A B t u], for value codes + [A],[B] at [U G rel l] and values [t],[u] at [El A],[El B], is the + value code [c] at [U G irr L0]. + + THE ANALYSIS IS 3 x 3 IN THE CODES and, at [Nat]/[Nat], 3 x 3 IN THE + ENDPOINTS. That is exactly what Values.v's [ValCode_rel_shape] and + [Val_nat_shape] say, and the table below is written against them: + + A, B | value + ---------------+------------------------------------------------- + neutral, _ | STUCK idv_ne_l + _, neutral | STUCK idv_ne_r + Nat, Pi_rel | Empty idv_nat_pi + Pi_rel, Nat | Empty idv_pi_nat + Pi_rel, Pi_rel | (rF1,lF1) <> (rF2,lF2): Empty, four clause + | (rF1,lF1) = (rF2,lF2): FUNEXT, two clauses (rel/irr) + Nat, Nat | t, u | value + | zero, zero | Unit idv_nat_00 + | zero, suc | Empty idv_nat_0S + | suc, zero | Empty idv_nat_S0 + | suc, suc | recurse idv_nat_SS + | neutral, _ | STUCK idv_nat_ne_l + | _, neutral | STUCK idv_nat_ne_r + + ALL FOUR STUCK CLAUSES EMIT THE SAME TERM, [oIdEq G l A B t u], so the + overlaps among them are free: two stuck derivations agree without any + argument. What determinism needs is that a stuck clause never overlaps + a COMPUTING one, and that is precisely what Values.v's [NeCode_not_nat] + / [NeCode_not_pi_rel] and this file's [ValNe_not_zero] / + [ValNe_not_suc] supply. + + THE FOUR CLASH CLAUSES ARE A PARTITION AS THE LANGUAGE HAS THEM. + IdComp.v's own comment says the four "overlap, which is harmless"; read + off the compiled rules they do not. "Id-Pi-Pi-rel-irr" and + "-irr-rel" pin the two relevances to the DISTINCT literals [rel]/[irr], + while "-L0-L1" and "-L1-L0" SHARE one relevance metavariable [rF] and + pin the two levels to distinct literals. So relevance-mismatch and + level-mismatch are mutually exclusive, and the four transcribe directly + as a partition of "(rF1,lF1) differs from (rF2,lF2)" -- no + restructuring was needed. *) +with IdV : term -> term -> term -> term -> term -> term -> term -> Prop := +(* ---- stuck on a neutral CODE ---- *) +| idv_ne_l : forall G l A B t u, + NeCode instC G oRel l A -> + IdV G l A B t u (oIdEq G l A B t u) +| idv_ne_r : forall G l A B t u, + NeCode instC G oRel l B -> + IdV G l A B t u (oIdEq G l A B t u) +(* ---- Nat against Nat: dispatch on the ENDPOINTS ---- *) +| idv_nat_00 : forall G, + IdV G oL0 (oNat G) (oNat G) (oZero G) (oZero G) (oUnit G) +| idv_nat_0S : forall G n, + IdV G oL0 (oNat G) (oNat G) (oZero G) (oSuc G n) (oEmpty G) +| idv_nat_S0 : forall G m, + IdV G oL0 (oNat G) (oNat G) (oSuc G m) (oZero G) (oEmpty G) +| idv_nat_SS : forall G m n c, + IdV G oL0 (oNat G) (oNat G) m n c -> + IdV G oL0 (oNat G) (oNat G) (oSuc G m) (oSuc G n) c +| idv_nat_ne_l : forall G t u, + ValNe instC G (iEl oRel oL0) (oEl G oRel oL0 (oNat G)) t -> + IdV G oL0 (oNat G) (oNat G) t u (oIdEq G oL0 (oNat G) (oNat G) t u) +| idv_nat_ne_r : forall G t u, + ValNe instC G (iEl oRel oL0) (oEl G oRel oL0 (oNat G)) u -> + IdV G oL0 (oNat G) (oNat G) t u (oIdEq G oL0 (oNat G) (oNat G) t u) +(* ---- the heads differ: TYPE-DIRECTED, endpoints arbitrary ---- + Both rules are stated at [l = L0], and that is forced rather than a + restriction: [Nat] is a code at [L0] only, and an [Id]'s two codes + share a level, so the [Pi_rel]'s own [lG] is [L0] too. *) +| idv_nat_pi : forall G rF lF F B t u, + IdV G oL0 (oNat G) (oPiRel G rF lF oL0 F B) t u (oEmpty G) +| idv_pi_nat : forall G rF lF F B t u, + IdV G oL0 (oPiRel G rF lF oL0 F B) (oNat G) t u (oEmpty G) +(* ---- two Pi_rels with MISMATCHED domain indices ---- *) +| idv_pi_pi_rel_irr : forall G l lF1 lF2 F1 B1 F2 B2 t u, + IdV G l (oPiRel G oRel lF1 l F1 B1) (oPiRel G oIrr lF2 l F2 B2) t u + (oEmpty G) +| idv_pi_pi_irr_rel : forall G l lF1 lF2 F1 B1 F2 B2 t u, + IdV G l (oPiRel G oIrr lF1 l F1 B1) (oPiRel G oRel lF2 l F2 B2) t u + (oEmpty G) +| idv_pi_pi_L0_L1 : forall G l rF F1 B1 F2 B2 t u, + IdV G l (oPiRel G rF oL0 l F1 B1) (oPiRel G rF oL1 l F2 B2) t u + (oEmpty G) +| idv_pi_pi_L1_L0 : forall G l rF F1 B1 F2 B2 t u, + IdV G l (oPiRel G rF oL1 l F1 B1) (oPiRel G rF oL0 l F2 B2) t u + (oEmpty G) + +(* ---- two Pi_rels with MATCHING domain indices: FUNCTION EXTENSIONALITY. + + THE ENDPOINTS ARE LAMBDAS, NOT NEUTRALS. [Val_pi_rel_shape] is what + licenses writing them as [oLamRel]s: at a [Pi_rel] type eta leaves no + neutral alternative, and that asymmetry against [Nat] -- where the + neutral case is real and gets its own two clauses above -- is the whole + reason this clause can be written at all. + + RELEVANT DOMAIN, three binders (IdFunextDefs.v's [id_pi_pi_rel_rule]): + + Id (Pi rel lF l F1 B1) (Pi rel lF l F2 B2) f g + = Pi_irr rel lF F1 (Pi_irr rel lF F2[w1] + (Pi_irr irr L0 (Id F1[w21] F2[w21] a1[w2] a2) + (Id B1[] B2[] (f[w3G]. a1z) (g[w3G]. a2z)))) + + with contexts X1 = G.F1, Y = X1.F2[w1], Z = Y.(that middle Id). Every + piece of the right-hand side is named by a premise below rather than + written out, because the VALUE of a weakened code is not its explicit + substitution: [WkTm] computes [Nat G] |-> [Nat X1], not + [Nat G [w1]]. Only the [Pi_irr] skeleton is literal. + + The middle binder's domain is a RECURSIVE [IdV] (premise [HP]); the + body is another ([Hbody]); and the two applications go through [AppV], + which fires beta because the weakened endpoints are still lambdas. The + codomain instances [cod1]/[cod2] are the rule's [B1[]] + factored as weaken-then-instantiate: [B1z] is [B1] weakened under its + own binder along [w3G], and [InstTm] then substitutes [a1z] for the + de Bruijn-0 variable. That factoring is what keeps [InstTm]'s + substitution argument in the shape its own clauses dispatch on. *) +| idv_funext_rel : + forall G l lF F1 B1 F2 B2 tf tg + F2w F1s F2s a1w P F1z F2z a1z a2z B1z B2z fz gz r1 r2 cod1 cod2 bodyv, + (* --- binder 1 : a1 : El F1, in X1 = oExtC G rel lF F1 --- *) + WkTm (oExtC G oRel lF F1) G (oWknC G oRel lF F1) F2 F2w -> + (* --- binder 2 : a2 : El F2w, in Y = oExtC X1 rel lF F2w --- *) + WkTm (oExtC (oExtC G oRel lF F1) oRel lF F2w) G + (oCmp (oExtC (oExtC G oRel lF F1) oRel lF F2w) + (oExtC G oRel lF F1) G + (oWknC (oExtC G oRel lF F1) oRel lF F2w) + (oWknC G oRel lF F1)) + F1 F1s -> + WkTm (oExtC (oExtC G oRel lF F1) oRel lF F2w) G + (oCmp (oExtC (oExtC G oRel lF F1) oRel lF F2w) + (oExtC G oRel lF F1) G + (oWknC (oExtC G oRel lF F1) oRel lF F2w) + (oWknC G oRel lF F1)) + F2 F2s -> + WkTm (oExtC (oExtC G oRel lF F1) oRel lF F2w) (oExtC G oRel lF F1) + (oWknC (oExtC G oRel lF F1) oRel lF F2w) + (oHdC G oRel lF F1) a1w -> + (* --- binder 3 : p : Id F1s F2s a1w a2, in Z = oExtC Y irr L0 P --- *) + IdV (oExtC (oExtC G oRel lF F1) oRel lF F2w) lF F1s F2s a1w + (oHdC (oExtC G oRel lF F1) oRel lF F2w) P -> + (* --- everything transported from G / Y to Z --- *) + WkTm (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) G + (oCmp (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + (oExtC (oExtC G oRel lF F1) oRel lF F2w) G + (oWknC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + (oCmp (oExtC (oExtC G oRel lF F1) oRel lF F2w) + (oExtC G oRel lF F1) G + (oWknC (oExtC G oRel lF F1) oRel lF F2w) + (oWknC G oRel lF F1))) + F1 F1z -> + WkTm (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) G + (oCmp (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + (oExtC (oExtC G oRel lF F1) oRel lF F2w) G + (oWknC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + (oCmp (oExtC (oExtC G oRel lF F1) oRel lF F2w) + (oExtC G oRel lF F1) G + (oWknC (oExtC G oRel lF F1) oRel lF F2w) + (oWknC G oRel lF F1))) + F2 F2z -> + WkTm (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + (oExtC (oExtC G oRel lF F1) oRel lF F2w) + (oWknC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + a1w a1z -> + WkTm (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + (oExtC (oExtC G oRel lF F1) oRel lF F2w) + (oWknC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + (oHdC (oExtC G oRel lF F1) oRel lF F2w) a2z -> + (* --- the two codomain codes, weakened UNDER their own binder --- *) + WkTm (oExtC (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + oRel lF F1z) + (oExtC G oRel lF F1) + (oLiftC (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) G + (oCmp (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + (oExtC (oExtC G oRel lF F1) oRel lF F2w) G + (oWknC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + (oCmp (oExtC (oExtC G oRel lF F1) oRel lF F2w) + (oExtC G oRel lF F1) G + (oWknC (oExtC G oRel lF F1) oRel lF F2w) + (oWknC G oRel lF F1))) + oRel lF F1 F1z) + B1 B1z -> + WkTm (oExtC (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + oRel lF F2z) + (oExtC G oRel lF F2) + (oLiftC (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) G + (oCmp (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + (oExtC (oExtC G oRel lF F1) oRel lF F2w) G + (oWknC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + (oCmp (oExtC (oExtC G oRel lF F1) oRel lF F2w) + (oExtC G oRel lF F1) G + (oWknC (oExtC G oRel lF F1) oRel lF F2w) + (oWknC G oRel lF F1))) + oRel lF F2 F2z) + B2 B2z -> + (* --- the two endpoints, weakened to Z (still lambdas) --- *) + WkTm (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) G + (oCmp (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + (oExtC (oExtC G oRel lF F1) oRel lF F2w) G + (oWknC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + (oCmp (oExtC (oExtC G oRel lF F1) oRel lF F2w) + (oExtC G oRel lF F1) G + (oWknC (oExtC G oRel lF F1) oRel lF F2w) + (oWknC G oRel lF F1))) + (oLamRel G oRel lF l F1 B1 tf) fz -> + WkTm (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) G + (oCmp (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + (oExtC (oExtC G oRel lF F1) oRel lF F2w) G + (oWknC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + (oCmp (oExtC (oExtC G oRel lF F1) oRel lF F2w) + (oExtC G oRel lF F1) G + (oWknC (oExtC G oRel lF F1) oRel lF F2w) + (oWknC G oRel lF F1))) + (oLamRel G oRel lF l F2 B2 tg) gz -> + (* --- the two applications (beta) --- *) + AppV (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + oRel lF l F1z B1z fz a1z r1 -> + AppV (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + oRel lF l F2z B2z gz a2z r2 -> + (* --- the two codomain instances --- *) + InstTm (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + (oExtC (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + oRel lF F1z) + (oInst (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + oRel lF F1z a1z) + B1z cod1 -> + InstTm (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + (oExtC (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + oRel lF F2z) + (oInst (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + oRel lF F2z a2z) + B2z cod2 -> + (* --- and the body --- *) + IdV (oExtC (oExtC (oExtC G oRel lF F1) oRel lF F2w) oIrr oL0 P) + l cod1 cod2 r1 r2 bodyv -> + IdV G l (oPiRel G oRel lF l F1 B1) (oPiRel G oRel lF l F2 B2) + (oLamRel G oRel lF l F1 B1 tf) (oLamRel G oRel lF l F2 B2 tg) + (oPiIrr G oRel lF F1 + (oPiIrr (oExtC G oRel lF F1) oRel lF F2w + (oPiIrr (oExtC (oExtC G oRel lF F1) oRel lF F2w) + oIrr oL0 P bodyv))) + +(* ---- IRRELEVANT DOMAIN, two binders (IdFunextDefs.v's + [id_pi_pi_irr_rule]). There is no domain-equality premise: a relevant + result cannot depend on an irrelevant argument except through + [Emptyrec], so the pair of arguments needs no proof relating them. + + AND THE TWO BOUND VARIABLES ARE [*]. This is the one place the value + layer visibly departs from the rule as written. The rule's [a1w] and + [a2] are variables at an IRRELEVANT [El], where the only value is + [oStar] (Values.v's [Val_irr_star]); so the arguments of the two + applications, and the two codomain instantiations, take [oStar]. The + choice is not merely licensed but immaterial: a value over + [oExtC G irr lF F1] cannot mention that context's de Bruijn-0 variable + at all, since every position it could occupy is itself irrelevant and + therefore already [*]. (Contrast the relevant clause above, where + [a1w]/[a1z]/[a2z] are genuine variables and only the middle binder's + [p] -- which is never used -- collapses.) *) +| idv_funext_irr : + forall G l lF F1 B1 F2 B2 tf tg + F2w F1s F2s B1y B2y fy gy r1 r2 cod1 cod2 bodyv, + WkTm (oExtC G oIrr lF F1) G (oWknC G oIrr lF F1) F2 F2w -> + WkTm (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) G + (oCmp (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) + (oExtC G oIrr lF F1) G + (oWknC (oExtC G oIrr lF F1) oIrr lF F2w) + (oWknC G oIrr lF F1)) + F1 F1s -> + WkTm (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) G + (oCmp (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) + (oExtC G oIrr lF F1) G + (oWknC (oExtC G oIrr lF F1) oIrr lF F2w) + (oWknC G oIrr lF F1)) + F2 F2s -> + WkTm (oExtC (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) oIrr lF F1s) + (oExtC G oIrr lF F1) + (oLiftC (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) G + (oCmp (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) + (oExtC G oIrr lF F1) G + (oWknC (oExtC G oIrr lF F1) oIrr lF F2w) + (oWknC G oIrr lF F1)) + oIrr lF F1 F1s) + B1 B1y -> + WkTm (oExtC (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) oIrr lF F2s) + (oExtC G oIrr lF F2) + (oLiftC (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) G + (oCmp (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) + (oExtC G oIrr lF F1) G + (oWknC (oExtC G oIrr lF F1) oIrr lF F2w) + (oWknC G oIrr lF F1)) + oIrr lF F2 F2s) + B2 B2y -> + WkTm (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) G + (oCmp (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) + (oExtC G oIrr lF F1) G + (oWknC (oExtC G oIrr lF F1) oIrr lF F2w) + (oWknC G oIrr lF F1)) + (oLamRel G oIrr lF l F1 B1 tf) fy -> + WkTm (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) G + (oCmp (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) + (oExtC G oIrr lF F1) G + (oWknC (oExtC G oIrr lF F1) oIrr lF F2w) + (oWknC G oIrr lF F1)) + (oLamRel G oIrr lF l F2 B2 tg) gy -> + AppV (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) oIrr lF l F1s B1y fy oStar r1 -> + AppV (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) oIrr lF l F2s B2y gy oStar r2 -> + InstTm (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) + (oExtC (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) oIrr lF F1s) + (oInst (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) oIrr lF F1s oStar) + B1y cod1 -> + InstTm (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) + (oExtC (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) oIrr lF F2s) + (oInst (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) oIrr lF F2s oStar) + B2y cod2 -> + IdV (oExtC (oExtC G oIrr lF F1) oIrr lF F2w) l cod1 cod2 r1 r2 bodyv -> + IdV G l (oPiRel G oIrr lF l F1 B1) (oPiRel G oIrr lF l F2 B2) + (oLamRel G oIrr lF l F1 B1 tf) (oLamRel G oIrr lF l F2 B2 tg) + (oPiIrr G oIrr lF F1 + (oPiIrr (oExtC G oIrr lF F1) oIrr lF F2w bodyv)). + +Scheme InstTy_min := Minimality for InstTy Sort Prop + with InstTm_min := Minimality for InstTm Sort Prop + with InstVar_min := Minimality for InstVar Sort Prop + with AppV_min := Minimality for AppV Sort Prop + with IdV_min := Minimality for IdV Sort Prop. + +Combined Scheme Inst_mutind from + InstTy_min, InstTm_min, InstVar_min, AppV_min, IdV_min. + +(* ================================================================== *) +(* DETERMINISM -- design.md section 13b's property (D) *) +(* ================================================================== *) + +(* The argument is the one WkRel.v's [Wk_det] runs, with two additions. + (1) The [WkTm] premises carry no induction hypothesis -- WkRel is a + CLOSED block below this one -- so they are discharged by [WkTm_det] + explicitly rather than by an IH. (2) The tables have clauses that + agree on their subject's head and are separated only by a neutrality + premise; those are killed by the five refutation lemmas + ([NeCode_not_nat], [NeCode_not_pi_rel], [ValNe_not_zero], + [ValNe_not_suc], [ValNe_not_lam_rel]). + + TOTALITY IS NOT ATTEMPTED and does not belong here: it is design.md + section 13b's property (T), it is what the model proves, and it is + where the lexicographic measure that this relational presentation + avoids comes back (section 14k). *) + +Theorem Inst_det : + (forall D G g i A A', InstTy D G g i A A' -> + forall A2, InstTy D G g i A A2 -> A' = A2) + /\ (forall D G g e e', InstTm D G g e e' -> + forall e2, InstTm D G g e e2 -> e' = e2) + /\ (forall D G g x x', InstVar D G g x x' -> + forall x2, InstVar D G g x x2 -> x' = x2) + /\ (forall G rF lF lG F B f a r, AppV G rF lF lG F B f a r -> + forall r2, AppV G rF lF lG F B f a r2 -> r = r2) + /\ (forall G l A B t u c, IdV G l A B t u c -> + forall c2, IdV G l A B t u c2 -> c = c2). +Proof. + apply Inst_mutind; intros; + (* (1) Drop the clause's OWN premises, so that the second derivation's + premises are the only ones an induction hypothesis can consume. *) + repeat match goal with + | Hp : InstTy ?D ?G ?g ?i ?A ?X, + _ : forall z, InstTy ?D ?G ?g ?i ?A z -> ?X = z |- _ => clear Hp + | Hp : InstTm ?D ?G ?g ?e ?X, + _ : forall z, InstTm ?D ?G ?g ?e z -> ?X = z |- _ => clear Hp + | Hp : InstVar ?D ?G ?g ?x ?X, + _ : forall z, InstVar ?D ?G ?g ?x z -> ?X = z |- _ => clear Hp + | Hp : AppV ?G ?rF ?lF ?lG ?F ?B ?f ?a ?X, + _ : forall z, AppV ?G ?rF ?lF ?lG ?F ?B ?f ?a z -> ?X = z |- _ => clear Hp + | Hp : IdV ?G ?l ?A ?B ?t ?u ?X, + _ : forall z, IdV ?G ?l ?A ?B ?t ?u z -> ?X = z |- _ => clear Hp + end; + (* (2) Invert the second derivation. Every judgement is head-directed + -- in the subject for [InstTy]/[InstTm], in the substitution and + then the subject for [InstVar], in the function for [AppV], and in + the two codes and then the endpoints for [IdV]. *) + match goal with + | H : InstTy _ _ _ _ _ ?X |- _ = ?X => inversion H; subst + | H : InstTm _ _ _ _ ?X |- _ = ?X => inversion H; subst + | H : InstVar _ _ _ _ ?X |- _ = ?X => inversion H; subst + | H : AppV _ _ _ _ _ _ _ _ ?X |- _ = ?X => inversion H; subst + | H : IdV _ _ _ _ _ _ ?X |- _ = ?X => inversion H; subst + end; + (* (3) Kill the clause pairs that agree on the head and are separated + only by neutrality. *) + try match goal with + | H : NeCode _ _ _ _ (oNat _) |- _ => destruct (NeCode_not_nat H) + | H : NeCode _ _ _ _ (oPiRel _ _ _ _ _ _) |- _ => + destruct (NeCode_not_pi_rel H) + | H : ValNe _ _ _ _ (oZero _) |- _ => destruct (ValNe_not_zero H) + | H : ValNe _ _ _ _ (oSuc _ _) |- _ => destruct (ValNe_not_suc H) + | H : ValNe _ _ _ _ (oLamRel _ _ _ _ _ _ _) |- _ => + destruct (ValNe_not_lam_rel H) + end; + (* (4) Feed the surviving premises to the induction hypotheses, and the + [WkTm] ones to [WkTm_det]. *) + repeat first + [ match goal with + | IH : forall z, InstTy ?D ?G ?g ?i ?A z -> _, + H : InstTy ?D ?G ?g ?i ?A _ |- _ => specialize (IH _ H); subst + | IH : forall z, InstTm ?D ?G ?g ?e z -> _, + H : InstTm ?D ?G ?g ?e _ |- _ => specialize (IH _ H); subst + | IH : forall z, InstVar ?D ?G ?g ?x z -> _, + H : InstVar ?D ?G ?g ?x _ |- _ => specialize (IH _ H); subst + | IH : forall z, AppV ?G ?rF ?lF ?lG ?F ?B ?f ?a z -> _, + H : AppV ?G ?rF ?lF ?lG ?F ?B ?f ?a _ |- _ => specialize (IH _ H); subst + | IH : forall z, IdV ?G ?l ?A ?B ?t ?u z -> _, + H : IdV ?G ?l ?A ?B ?t ?u _ |- _ => specialize (IH _ H); subst + end + | match goal with + | H1 : WkTm ?D ?G ?w ?e ?X, H2 : WkTm ?D ?G ?w ?e ?Y |- _ => + assert_fails (constr_eq X Y); + let Heq := fresh "Hwk" in + pose proof (WkTm_det H1 H2) as Heq; subst + end ]; + auto. +Qed. + +(* ================================================================== *) +(* THE TABLE IS COMPLETE -- the shape analysis its clauses cover *) +(* ================================================================== *) + +(* Determinism does NOT witness completeness: a table with a case missing + is still deterministic, and the omission would surface only much later, + as an unprovable totality obligation. These two lemmas close that gap + at the only place it is open, by exhibiting the case analysis the + clauses were written against and showing it is exhaustive. The third + axis -- the endpoints at [Nat]/[Nat] -- needs nothing new: it is + Values.v's [Val_nat_shape] verbatim, three-way into [zero] / [suc] / + neutral, matched by [idv_nat_00] / [idv_nat_0S] / [idv_nat_S0] / + [idv_nat_SS] / [idv_nat_ne_l] / [idv_nat_ne_r]. *) + +Local Ltac pick := split; [ reflexivity | ]. + +(* AXIS 1: the two codes, six ways. This is [ValCode_rel_shape] squared, + and the six disjuncts are, in order, [idv_ne_l], [idv_ne_r], the + [Nat]/[Nat] block, [idv_nat_pi], [idv_pi_nat], and the [Pi_rel] block. + Note the [l = oL0] that comes free with every [Nat]: it is why + [idv_nat_pi] and [idv_pi_nat] can pin the [Pi_rel]'s own [lG] to [L0] + without loss, matching "Id-Nat-Pi"/"Id-Pi-Nat" as compiled. *) +Lemma IdV_code_cases G l A B + : ValCode instC G oRel l A -> ValCode instC G oRel l B -> + NeCode instC G oRel l A + \/ NeCode instC G oRel l B + \/ (l = oL0 /\ A = oNat G /\ B = oNat G) + \/ (l = oL0 /\ A = oNat G + /\ exists rF lF F0 B0, B = oPiRel G rF lF oL0 F0 B0) + \/ (l = oL0 /\ B = oNat G + /\ exists rF lF F0 B0, A = oPiRel G rF lF oL0 F0 B0) + \/ (exists rF1 lF1 F1 B1' rF2 lF2 F2 B2', + A = oPiRel G rF1 lF1 l F1 B1' + /\ B = oPiRel G rF2 lF2 l F2 B2'). +Proof. + intros HA HB. + destruct (ValCode_rel_shape HA) + as [[HlA HA']|[[rF1 [lF1 [F1 [B1' HA']]]]|HneA]]; [ | | now left ]. + - subst. + destruct (ValCode_rel_shape HB) + as [[HlB HB']|[[rF2 [lF2 [F2 [B2' HB']]]]|HneB]]; [ | | now right; left ]. + + subst. do 2 right; left; pick; pick; reflexivity. + + subst. do 3 right; left; pick; pick. + exists rF2, lF2, F2, B2'; reflexivity. + - destruct (ValCode_rel_shape HB) + as [[HlB HB']|[[rF2 [lF2 [F2 [B2' HB']]]]|HneB]]; [ | | now right; left ]. + + subst. do 4 right; left; pick; pick. + exists rF1, lF1, F1, B1'; reflexivity. + + subst. do 5 right. + exists rF1, lF1, F1, B1', rF2, lF2, F2, B2'; pick; reflexivity. +Qed. + +(* AXIS 2: two [Pi_rel]s, five ways in their DOMAIN INDICES. The four + clash clauses plus funext, and the reason no restructuring of the + language's rules was needed: they already partition. [RelNf]/[LvlNf] + are what make the enumeration finite -- [relevance] and [lvl] are rigid + two-constructor sorts (Syntax.v). *) +Lemma IdV_pi_index_cases rF1 lF1 rF2 lF2 + : RelNf rF1 -> LvlNf lF1 -> RelNf rF2 -> LvlNf lF2 -> + (rF1 = oRel /\ rF2 = oIrr) (* idv_pi_pi_rel_irr *) + \/ (rF1 = oIrr /\ rF2 = oRel) (* idv_pi_pi_irr_rel *) + \/ (rF1 = rF2 /\ lF1 = oL0 /\ lF2 = oL1) (* idv_pi_pi_L0_L1 *) + \/ (rF1 = rF2 /\ lF1 = oL1 /\ lF2 = oL0) (* idv_pi_pi_L1_L0 *) + \/ (rF1 = rF2 /\ lF1 = lF2). (* the two funexts *) +Proof. + intros [] [] [] []; + first [ solve [ left; repeat split; reflexivity ] + | solve [ right; left; repeat split; reflexivity ] + | solve [ do 2 right; left; repeat split; reflexivity ] + | solve [ do 3 right; left; repeat split; reflexivity ] + | solve [ do 4 right; repeat split; reflexivity ] ]. +Qed. + +Definition InstTy_det := proj1 Inst_det. +Definition InstTm_det := proj1 (proj2 Inst_det). +Definition InstVar_det := proj1 (proj2 (proj2 Inst_det)). +Definition AppV_det := proj1 (proj2 (proj2 (proj2 Inst_det))). +Definition IdV_det := proj2 (proj2 (proj2 (proj2 Inst_det))). + +End WithInstC. diff --git a/src/Pyrosome/Gluing/Dtt/NormalForms.v b/src/Pyrosome/Gluing/Dtt/NormalForms.v index 817cb434..326c6b7f 100644 --- a/src/Pyrosome/Gluing/Dtt/NormalForms.v +++ b/src/Pyrosome/Gluing/Dtt/NormalForms.v @@ -69,6 +69,23 @@ Import Core.Notations. Local Notation eqt := (eq_term ott_dtt []). +(* ------------------------------------------------------------------ *) +(* The type an [Idcong] concludes at *) +(* ------------------------------------------------------------------ *) + +(* [Idcong A B b t u e] concludes at the Id between the two instantiations + of its body: Id (B[]) (B[]) (b[]) (b[]). + Spelled EXACTLY as the compiled rule stores it (read off the elaborated + language, not the surface notation): the codomain code travels at the + info [iCode lB] and the body at [iEl oRel lB]. *) +Definition oIdcongTy (G l lB A B b t u : term) : term := + let X := oExtC G oRel l A in + oIdEq G lB + (oExpSubst G X (oInst G oRel l A t) (iCode lB) (oU X oRel lB) B) + (oExpSubst G X (oInst G oRel l A u) (iCode lB) (oU X oRel lB) B) + (oExpSubst G X (oInst G oRel l A t) (iEl oRel lB) (oEl X oRel lB B) b) + (oExpSubst G X (oInst G oRel l A u) (iEl oRel lB) (oEl X oRel lB B) b). + Inductive EnvOk : term -> Prop := | envok_emp : EnvOk oEmp | envok_ext : forall G i A, EnvOk G -> TyOk G i A -> EnvOk (oExt G i A) @@ -104,8 +121,49 @@ with NfCode : term -> term -> term -> term -> Prop := NfCode G rF lF F -> NfCode (oExtC G rF lF F) oIrr oL0 B -> NfCode G oIrr oL0 (oPiIrr G rF lF F B) -| nfcode_var : forall G r l c, - VarT G (iCode l) (oU G r l) c -> NfCode G r l c +| nfcode_ne : forall G r l c, + NeCode G r l c -> NfCode G r l c + +(* [NeCode G r l c] : [c] is a NEUTRAL code -- a code that no computation + rule of [ott_dtt] can reduce. Before the Id fragment this was exactly + "a variable", and [NfCode] had [nfcode_var] instead; [Id] adds a second + way for a code to be stuck, so the notion is broken out. + + The clauses are the complete stuck analysis of section 12b of + Gluing/Dtt/design.md. An [Id] reduces as soon as both of its codes are + canonical: distinct heads clash to [Empty], two [Pi_rel]s go to funext + or (on mismatched domain indices) to [Empty], and two [Nat]s dispatch on + the endpoints. So it is stuck exactly when a CODE is neutral, or when + both codes are [Nat] and an ENDPOINT is neutral. *) +with NeCode : term -> term -> term -> term -> Prop := +| necode_var : forall G r l c, + VarT G (iCode l) (oU G r l) c -> NeCode G r l c + +(* Stuck on a neutral code. Note the indices: [Id] lands at [irr, L0], + while its two code arguments are RELEVANT, and the only neutral code at + a relevant index is a variable -- so these clauses do not recurse into + further [Id]s. *) +| necode_id_l : forall G l A B t u, + NeCode G oRel l A -> NfCode G oRel l B -> + NfET G (iEl oRel l) (oEl G oRel l A) t -> + NfET G (iEl oRel l) (oEl G oRel l B) u -> + NeCode G oIrr oL0 (oIdEq G l A B t u) +| necode_id_r : forall G l A B t u, + NfCode G oRel l A -> NeCode G oRel l B -> + NfET G (iEl oRel l) (oEl G oRel l A) t -> + NfET G (iEl oRel l) (oEl G oRel l B) u -> + NeCode G oIrr oL0 (oIdEq G l A B t u) + +(* Stuck on a neutral endpoint, both codes being [Nat]. No other pair of + canonical codes can be stuck. *) +| necode_id_nat_l : forall G t u, + NeET G (iEl oRel oL0) (oEl G oRel oL0 (oNat G)) t -> + NfET G (iEl oRel oL0) (oEl G oRel oL0 (oNat G)) u -> + NeCode G oIrr oL0 (oIdEq G oL0 (oNat G) (oNat G) t u) +| necode_id_nat_r : forall G t u, + NfET G (iEl oRel oL0) (oEl G oRel oL0 (oNat G)) t -> + NeET G (iEl oRel oL0) (oEl G oRel oL0 (oNat G)) u -> + NeCode G oIrr oL0 (oIdEq G oL0 (oNat G) (oNat G) t u) (* [VarT G i A x] : [x] is an object-level variable of the normal type [A]. The meta-context is empty, so object-level variables are [hd] and its @@ -156,6 +214,35 @@ with NeET : term -> term -> term -> term -> Prop := NfCode G rA lA A -> NeET G (iEl oIrr oL0) (oEl G oIrr oL0 (oEmpty G)) e -> NeET G (iEl rA lA) (oEl G rA lA A) (oEmptyrec G rA lA A e) +(* [Idcong] is neutral UNCONDITIONALLY -- there is no premise on the shape + of its body [b]. That is what makes reification at an Id type work; see + section 12d of design.md. The alternative (neutral only when [b] is + neutral, with a structural recursion supplying the normal form + otherwise) does not close: at a [lam_rel] body the reduced type needs a + congruence in TWO variables at once, which the single-binder [Idcong] + cannot express and which cannot be assembled from two one-variable + congruences without a cast. Being unconditionally neutral, its normal + form is instead whatever its TYPE dictates, and the existing + type-directed machinery supplies it: at a [Pi_irr] (the unit + proposition, or a funext Pi) it eta-expands by proof irrelevance and the + body [Idcong ... . a1 . a2 . p] is [app_irr] of a neutral, hence neutral + again at the smaller inner Id; at [Empty] or a stuck Id, neutrals are + already normal. + As with [app_rel], the normal representative [C] of the conclusion type + is supplied at the construction site -- here it is the normal form of + the Id code, computed by the same structural recursion as + [NfCode_subst], extended with the Id computation table. *) +| neet_idcong : forall G l lB A B b t u e C, + NfCode G oRel l A -> + NfCode (oExtC G oRel l A) oRel lB B -> + NfET (oExtC G oRel l A) (iEl oRel lB) (oEl (oExtC G oRel l A) oRel lB B) b -> + NfET G (iEl oRel l) (oEl G oRel l A) t -> + NfET G (iEl oRel l) (oEl G oRel l A) u -> + NfET G (iEl oIrr oL0) (oEl G oIrr oL0 (oIdEq G l A A t u)) e -> + TyOk G (iEl oIrr oL0) C -> + eqt (sTy G (iEl oIrr oL0)) + (oEl G oIrr oL0 (oIdcongTy G l lB A B b t u)) C -> + NeET G (iEl oIrr oL0) C (oIdcong G l lB A B b t u e) (* [NfET G i A e] : [e] is an ETA-LONG normal term of the normal type [A]. The clauses are dispatched by [A]'s head, and the dispatch is exhaustive @@ -181,8 +268,13 @@ with NfET : term -> term -> term -> term -> Prop := | nfet_ne_empty : forall G e, NeET G (iEl oIrr oL0) (oEl G oIrr oL0 (oEmpty G)) e -> NfET G (iEl oIrr oL0) (oEl G oIrr oL0 (oEmpty G)) e -| nfet_ne_var : forall G r l c e, - VarT G (iCode l) (oU G r l) c -> +(* At a type named by a NEUTRAL code, every normal is neutral. Before the + Id fragment "neutral code" meant "variable" and this clause was + [nfet_ne_var]; it now dispatches on [NeCode], which additionally covers + a stuck [Id]. This is the ONLY place the Id fragment touches [NfET] -- + the extension adds no normal form except neutrals. *) +| nfet_ne : forall G r l c e, + NeCode G r l c -> NeET G (iEl r l) (oEl G r l c) e -> NfET G (iEl r l) (oEl G r l c) e | nfet_lam_rel : forall G rF lF lG F B t, @@ -203,12 +295,60 @@ with NfET : term -> term -> term -> term -> Prop := Scheme EnvOk_min := Minimality for EnvOk Sort Prop with TyOk_min := Minimality for TyOk Sort Prop with NfCode_min := Minimality for NfCode Sort Prop + with NeCode_min := Minimality for NeCode Sort Prop with VarT_min := Minimality for VarT Sort Prop with NeET_min := Minimality for NeET Sort Prop with NfET_min := Minimality for NfET Sort Prop. +(* SEVEN conjuncts now, not six: every consumer of [Nf_mutind] + (NfTyping.v, NfWk.v, LogRelCore.v) gains an [NeCode] case. *) Combined Scheme Nf_mutind from - EnvOk_min, TyOk_min, NfCode_min, VarT_min, NeET_min, NfET_min. + EnvOk_min, TyOk_min, NfCode_min, NeCode_min, VarT_min, NeET_min, NfET_min. + +(* ------------------------------------------------------------------ *) +(* Syntactic shape lemmas *) +(* *) +(* RESCUED from src/Pyrosome/Gluing/Dtt/Inj.v (deleted with the rest of *) +(* Layer 0.5; design.md section 12e). [VarT_shape] was the ONLY lemma *) +(* in that file with no dependence on the rigid model of Rigid.v -- the *) +(* other twenty-odd are stated over [ICode]/[ITy]/[IEnv]/[ISub] and go *) +(* with them. It lives here rather than in NfTyping.v because it is *) +(* pure case analysis on [VarT] and needs neither Wf.v nor Eqns.v. *) +(* ------------------------------------------------------------------ *) + +(* The subject of a [VarT] is an [oHd] or a [wkn]-substituted variable. + (Was Inj.v:216.) *) +Lemma VarT_shape G i A x : VarT G i A x -> + (exists G0 i0 A0, x = oHd G0 i0 A0) + \/ (exists G0 j B i0 A0 y, + x = oExpSubst (oExt G0 j B) G0 (oWkn G0 j B) i0 A0 y). +Proof. destruct 1; [ left | right ]; eauto 10. Qed. + +(* The [NeET] analogue: a neutral is a variable, an application, an + [Emptyrec] or an [Idcong]. (New; the old development never needed it + because Layer 0.5 did the corresponding work semantically.) *) +Lemma NeET_shape G i A e : NeET G i A e -> + (exists G0 i0 A0, e = oHd G0 i0 A0) + \/ (exists G0 j B i0 A0 y, + e = oExpSubst (oExt G0 j B) G0 (oWkn G0 j B) i0 A0 y) + \/ (exists G0 rF lF lG F B f a, e = oAppRel G0 rF lF lG F B f a) + \/ (exists G0 rF lF F B f a, e = oAppIrr G0 rF lF F B f a) + \/ (exists G0 rA lA A0 e0, e = oEmptyrec G0 rA lA A0 e0) + \/ (exists G0 l lB A0 B b t u e0, e = oIdcong G0 l lB A0 B b t u e0). +Proof. + destruct 1. + - destruct (VarT_shape H) as [ H0 | H0 ]; [ left | right; left ]; exact H0. + - right; right; left; eauto 10. + - right; right; right; left; eauto 10. + - right; right; right; right; left; eauto 10. + - right; right; right; right; right; eauto 20. +Qed. + +(* A neutral code is a variable or a stuck [Id]. *) +Lemma NeCode_shape G r l c : NeCode G r l c -> + VarT G (iCode l) (oU G r l) c + \/ (exists l0 A B t u, c = oIdEq G l0 A B t u). +Proof. destruct 1; [ left | right .. ]; eauto 10. Qed. (* ------------------------------------------------------------------ *) (* Weakenings *) @@ -284,13 +424,22 @@ Proof. intros [n [Hn Heq]]; exists n; split; [ apply nfet_ne_empty | ]; assumption. Qed. +Lemma HasNe_HasNf_ne G r l c e + : NeCode G r l c -> + HasNe G (iEl r l) (oEl G r l c) e -> + HasNf G (iEl r l) (oEl G r l c) e. +Proof. + intros Hc [n [Hn Heq]]; exists n; split; + [ eapply nfet_ne; eassumption | assumption ]. +Qed. + +(* The old name, kept as a derived form: a code variable is a neutral code. *) Lemma HasNe_HasNf_var G r l c e : VarT G (iCode l) (oU G r l) c -> HasNe G (iEl r l) (oEl G r l c) e -> HasNf G (iEl r l) (oEl G r l c) e. Proof. - intros Hc [n [Hn Heq]]; exists n; split; - [ eapply nfet_ne_var; eassumption | assumption ]. + intro; apply HasNe_HasNf_ne; apply necode_var; assumption. Qed. (* There is deliberately NO [HasNe_HasNf] at a [Pi_rel] OR a [Pi_irr] type. diff --git a/src/Pyrosome/Gluing/Dtt/Rigid.v b/src/Pyrosome/Gluing/Dtt/Rigid.v deleted file mode 100644 index a0abb4e0..00000000 --- a/src/Pyrosome/Gluing/Dtt/Rigid.v +++ /dev/null @@ -1,2076 +0,0 @@ -Set Implicit Arguments. - -From coqutil Require Import Datatypes.String. -From Stdlib Require Import Lists.List. -Import ListNotations. -Open Scope string. -Open Scope list. -From Utils Require Import Utils. -From Pyrosome Require Import Theory.Core. -From Pyrosome.Gluing Require Import CutTModel Eval CutModelSound. -Require Import Pyrosome.Gluing.Dtt.Syntax Pyrosome.Gluing.Dtt.NormalForms. -Import Core.Notations. - -(* ===================================================================== - DTT NORMALIZATION, LAYER 0.5b: THE RIGID MODEL, the semantic half of - code rigidity. - - A second, much smaller [CutTModel] over [ott_dtt] with the empty - meta-context. It interprets ONLY the sigma-fragment (environments, - substitutions, types and codes) and is trivial everywhere else. Its - whole point is design section 2: - - no eliminator of [ott_dtt] has a universe as its result type, - - so no equation of the theory can ever rewrite a CODE: beta and eta live - at [El]-sorts and are discharged by [exact I]. The obligations that - carry content are exactly the sigma ones. - - The semantic domain is the first-order de Bruijn domain of section 0 - ([rcode]/[rty]/[renv]) plus rigid substitutions - - rsub := nat -> rcode - - with the usual sigma operations. A substitution [g : sub G G'] is read - as a map from the slots of the CODOMAIN environment [G'] to codes over - [G]. Slots whose type is not a universe carry no code; they are filled - with the junk value [rc_nat] and are EXCLUDED from the model's notion of - equality of substitutions ([subeq] below quantifies only over universe - slots). That exclusion is forced: [snoc_wkn_hd] identifies - [] with [id], and at a non-universe slot the two sides carry - different junk. - - Interpretation is by four mutually inductive relations over ARBITRARY - syntax ([IEnv]/[ITy]/[ICode]/[ISub]); they cover the sigma formers - ([ty_subst], [exp_subst], [id], [wkn], [cmp], [snoc], [forget], [emp], - [ext], [hd]) as well as [U]/[El]/[Nat]/[Empty]/[Pi_rel]/[Pi_irr]. - - Injectivity is NOT here. It is stated and proved directly over these - four relations, in src/Pyrosome/Gluing/Dtt/Inj.v; this file stops at - the ten [CutTModel_ok] obligations, which - src/Pyrosome/Gluing/Dtt/RigidOk.v assembles into [rigid_sound] and its - four sort-specific readings. - - Sections: 0 the domain; 1 rigid substitutions and their sigma laws; - 2 "universe-like" types ([USkel]); 3 scoping ([cwf]/[twf]/[swf] and - [subeq]); 4 the interpretation relations; 5 their functionality; 6 the - model itself; 7 the structural obligations; 8 the rule obligations. - ===================================================================== *) - -Local Notation eqt := (eq_term ott_dtt []). - -(* ===================================================================== - 0. The semantic domain: first-order de Bruijn codes and types. - - The domain the interpretation lands in, and the erasure of the two - rigid index sorts. This is all that survived of the separate - [Dtt/Erase.v]: the erasure RELATIONS that file also carried duplicated - the interpretation relations of section 4, and injectivity is now - proved directly over the latter (src/Pyrosome/Gluing/Dtt/Inj.v). - - DESIGN POINT: [rc_pi] RECORDS THE DOMAIN'S RELEVANCE AND LEVEL. - - [oPiRel G rF lF lG F B] carries [rF] and [lF] as SUBTERMS, so - injectivity has to recover them from the interpretation. They cannot - be recovered from the interpreted domain [nF]: when [F] is a variable, - its relevance and level are those of its NAMED type, which the - interpretation does not see and which the environment pins down only up - to provable equality. So [rc_pi] carries them: - - rc_pi (pi-relevance) (domain-relevance) (domain-level) - (domain-code) (codomain-code) - - This costs nothing semantically -- [rt_El brF blF nF] is exactly the - entry the binder pushes onto the environment, so the two bits are - already present in [renv] -- and it is what lets the [Pi] clauses of - [NfCode_I_inj] go through with no assumption about variables at all. - The Pi's own level [lG] is NOT recorded: it is the level index of the - judgement, which the statement fixes. - ===================================================================== *) - -(* A normal code with all index arguments dropped. [rc_var] carries a de - Bruijn INDEX (0 = the most recently bound variable). For [rc_pi] the - three bools are, in order: [true] for [Pi_rel] and [false] for - [Pi_irr]; the domain's relevance; the domain's level. *) -Inductive rcode : Type := -| rc_var : nat -> rcode -| rc_nat : rcode -| rc_empty : rcode -| rc_pi : bool -> bool -> bool -> rcode -> rcode -> rcode. - -(* A normal type: a universe [U r l], or an [El] of a normal code. In - both cases the first [bool] is the relevance ([true] = [rel]) and the - second the level ([true] = [L1]). *) -Inductive rty : Type := -| rt_U : bool -> bool -> rty -| rt_El : bool -> bool -> rcode -> rty. - -(* MOST-RECENT-FIRST, matching [ott]'s [ext]: the head of the list is the - interpretation of the type bound by the innermost [ext]. *) -Definition renv := list rty. - -(* [relevance] and [lvl] have two closed constructors each and no - equations, so their interpretation is a bijection onto [bool]. *) - -Inductive ErRel : term -> bool -> Prop := -| errel_rel : ErRel oRel true -| errel_irr : ErRel oIrr false. - -Inductive ErLvl : term -> bool -> Prop := -| erlvl_L0 : ErLvl oL0 false -| erlvl_L1 : ErLvl oL1 true. - -Lemma ErRel_fun r b1 b2 : ErRel r b1 -> ErRel r b2 -> b1 = b2. -Proof. intros H1 H2; destruct H1; inversion H2; reflexivity. Qed. - -Lemma ErLvl_fun l b1 b2 : ErLvl l b1 -> ErLvl l b2 -> b1 = b2. -Proof. intros H1 H2; destruct H1; inversion H2; reflexivity. Qed. - -Lemma ErRel_inj r1 r2 b : ErRel r1 b -> ErRel r2 b -> r1 = r2. -Proof. intros H1 H2; destruct H1; inversion H2; reflexivity. Qed. - -Lemma ErLvl_inj l1 l2 b : ErLvl l1 b -> ErLvl l2 b -> l1 = l2. -Proof. intros H1 H2; destruct H1; inversion H2; reflexivity. Qed. - -(* ===================================================================== - 1. Rigid substitutions and their calculus. - - Substitutions are total functions [nat -> rcode]. Totality is what - makes [csub rid c = c] and [csub s (csub t c) = csub (rcmp s t) c] - unconditional; the scoping information that a finite representation - would carry is recovered separately by [cwf] (section 3), which is - needed only to compare two substitutions that agree on the universe - slots. - ===================================================================== *) - -Definition rsub := nat -> rcode. - -Definition upren (f : nat -> nat) : nat -> nat := - fun k => match k with 0 => 0 | S k' => S (f k') end. - -Fixpoint cren (f : nat -> nat) (c : rcode) : rcode := - match c with - | rc_var k => rc_var (f k) - | rc_nat => rc_nat - | rc_empty => rc_empty - | rc_pi b br bl F B => rc_pi b br bl (cren f F) (cren (upren f) B) - end. - -Definition up (s : rsub) : rsub := - fun k => match k with 0 => rc_var 0 | S k' => cren S (s k') end. - -Fixpoint csub (s : rsub) (c : rcode) : rcode := - match c with - | rc_var k => s k - | rc_nat => rc_nat - | rc_empty => rc_empty - | rc_pi b br bl F B => rc_pi b br bl (csub s F) (csub (up s) B) - end. - -Definition tsub (s : rsub) (T : rty) : rty := - match T with - | rt_U br bl => rt_U br bl - | rt_El br bl n => rt_El br bl (csub s n) - end. - -Definition rid : rsub := fun k => rc_var k. -Definition rshift : rsub := fun k => rc_var (S k). -Definition rcmp (s t : rsub) : rsub := fun k => csub s (t k). -Definition rsnoc (c : rcode) (s : rsub) : rsub := - fun k => match k with 0 => c | S k' => s k' end. -Definition rforget : rsub := fun _ => rc_nat. - -(* ---- the sigma laws, all unconditional ---- *) - -Lemma cren_ext c : forall f g, (forall k, f k = g k) -> cren f c = cren g c. -Proof. - induction c as [ k | | | b br bl F IHF B IHB ]; intros f g H; cbn; - try reflexivity. - - rewrite H; reflexivity. - - f_equal; [ apply IHF; assumption | ]. - apply IHB; intros [|k]; cbn; [ reflexivity | rewrite H; reflexivity ]. -Qed. - -Lemma csub_ext c : forall s t, (forall k, s k = t k) -> csub s c = csub t c. -Proof. - induction c as [ k | | | b br bl F IHF B IHB ]; intros s t H; cbn; - try reflexivity. - - apply H. - - f_equal; [ apply IHF; assumption | ]. - apply IHB; intros [|k]; cbn; [ reflexivity | rewrite H; reflexivity ]. -Qed. - -Lemma cren_cren c : forall f g, cren f (cren g c) = cren (fun k => f (g k)) c. -Proof. - induction c as [ k | | | b br bl F IHF B IHB ]; intros f g; cbn; - try reflexivity. - f_equal; [ apply IHF | ]. - rewrite IHB; apply cren_ext; intros [|k]; cbn; reflexivity. -Qed. - -Lemma csub_cren c : forall s f, csub s (cren f c) = csub (fun k => s (f k)) c. -Proof. - induction c as [ k | | | b br bl F IHF B IHB ]; intros s f; cbn; - try reflexivity. - f_equal; [ apply IHF | ]. - rewrite IHB; apply csub_ext; intros [|k]; cbn; reflexivity. -Qed. - -Lemma cren_csub c : forall f s, cren f (csub s c) = csub (fun k => cren f (s k)) c. -Proof. - induction c as [ k | | | b br bl F IHF B IHB ]; intros f s; cbn; - try reflexivity. - f_equal; [ apply IHF | ]. - rewrite IHB; apply csub_ext; intros [|k]; cbn; [ reflexivity | ]. - rewrite !cren_cren; apply cren_ext; intros j; cbn; reflexivity. -Qed. - -Lemma csub_comp c : forall s t, csub s (csub t c) = csub (rcmp s t) c. -Proof. - induction c as [ k | | | b br bl F IHF B IHB ]; intros s t; cbn; - try reflexivity. - f_equal; [ apply IHF | ]. - rewrite IHB; apply csub_ext; intros [|k]; cbn; [ reflexivity | ]. - unfold rcmp; cbn. - rewrite csub_cren, cren_csub; apply csub_ext; intros j; cbn; reflexivity. -Qed. - -Lemma csub_id c : csub rid c = c. -Proof. - induction c as [ k | | | b br bl F IHF B IHB ]; cbn; try reflexivity. - f_equal; [ assumption | ]. - rewrite <- IHB at 2. - apply csub_ext; intros [|k]; cbn; reflexivity. -Qed. - -Lemma cren_as_csub c : forall f, cren f c = csub (fun k => rc_var (f k)) c. -Proof. - induction c as [ k | | | b br bl F IHF B IHB ]; intros f; cbn; - try reflexivity. - f_equal; [ apply IHF | ]. - rewrite IHB; apply csub_ext; intros [|k]; cbn; reflexivity. -Qed. - -Lemma csub_rshift c : csub rshift c = cren S c. -Proof. rewrite cren_as_csub; apply csub_ext; reflexivity. Qed. - -Lemma tsub_id T : tsub rid T = T. -Proof. destruct T; cbn; [ reflexivity | rewrite csub_id; reflexivity ]. Qed. - -Lemma tsub_comp s t T : tsub s (tsub t T) = tsub (rcmp s t) T. -Proof. destruct T; cbn; [ reflexivity | rewrite csub_comp; reflexivity ]. Qed. - -(* ===================================================================== - 2. "Universe-like" types. - - With the empty meta-context, a type is built from [U], [El] and - [ty_subst] alone, so U-ness is decided structurally. That the two - sides of a provable type equation agree on [USkel] is a corollary of - the [ty] row of the model ([ITy_USkel], section 5). - ===================================================================== *) - -Fixpoint USkel (A : term) : bool := - match A with - | con nm l => - if eqb nm "U" then true - else if eqb nm "ty_subst" - then match l with A0 :: _ => USkel A0 | _ => false end - else false - | _ => false - end. - -Lemma USkel_U G r l : USkel (oU G r l) = true. -Proof. reflexivity. Qed. - -Lemma USkel_El G r l e : USkel (oEl G r l e) = false. -Proof. reflexivity. Qed. - -Lemma USkel_subst G G' g i A : USkel (oTySubst G G' g i A) = USkel A. -Proof. reflexivity. Qed. - -(* ===================================================================== - 3. Scoping: which de Bruijn slots a code may mention. - - A code over an environment [E] may only mention slots whose type is a - UNIVERSE -- a variable of an [El]-type is not a code. [cwf] records - exactly that, and it is what lets two substitutions that agree on the - universe slots ([subeq]) act identically on codes. - ===================================================================== *) - -Definition isU (T : rty) : bool := - match T with rt_U _ _ => true | rt_El _ _ _ => false end. - -Definition isUat (E : renv) (k : nat) : bool := - match nth_error E k with Some T => isU T | None => false end. - -Fixpoint cwf (E : renv) (c : rcode) : Prop := - match c with - | rc_var k => isUat E k = true - | rc_nat => True - | rc_empty => True - | rc_pi b br bl F B => cwf E F /\ cwf (rt_El br bl F :: E) B - end. - -Definition twf (E : renv) (T : rty) : Prop := - match T with rt_U _ _ => True | rt_El _ _ n => cwf E n end. - -Definition swf (E E' : renv) (s : rsub) : Prop := - forall k, isUat E' k = true -> cwf E (s k). - -Definition subeq (E' : renv) (s1 s2 : rsub) : Prop := - forall k, isUat E' k = true -> s1 k = s2 k. - -Lemma isUat_cons_S T E k : isUat (T :: E) (S k) = isUat E k. -Proof. reflexivity. Qed. - -Lemma isUat_El_0 br bl n E : isUat (rt_El br bl n :: E) 0 = false. -Proof. reflexivity. Qed. - -(* [cwf] only ever looks at the U-ness of the slots, so replacing an - [rt_El] entry by another [rt_El] entry is invisible to it. *) -Lemma cwf_isU_ext c : forall E1 E2, - (forall k, isUat E1 k = isUat E2 k) -> cwf E1 c -> cwf E2 c. -Proof. - induction c as [ k | | | b br bl F IHF B IHB ]; - intros E1 E2 Hext H; cbn in *; try exact I. - - rewrite <- Hext; exact H. - - destruct H as [HF HB]; split. - + eapply IHF; eassumption. - + eapply IHB; [ | exact HB ]. - intros [|k]; cbn; [ reflexivity | apply Hext ]. -Qed. - -Lemma cwf_El_irrel c E br bl n1 n2 : - cwf (rt_El br bl n1 :: E) c -> cwf (rt_El br bl n2 :: E) c. -Proof. - apply cwf_isU_ext; intros [|k]; reflexivity. -Qed. - -Lemma cren_cwf c : forall E1 E2 f, - (forall k, isUat E1 k = true -> isUat E2 (f k) = true) -> - cwf E1 c -> cwf E2 (cren f c). -Proof. - induction c as [ k | | | b br bl F IHF B IHB ]; - intros E1 E2 f Hf H; cbn in *; try exact I. - - apply Hf; assumption. - - destruct H as [HF HB]; split. - + eapply IHF; eassumption. - + eapply IHB; [ | exact HB ]. - intros [|k]; cbn; [ discriminate | apply Hf ]. -Qed. - -Lemma cwf_shift c T E : cwf E c -> cwf (T :: E) (cren S c). -Proof. - intro H; eapply cren_cwf; [ | exact H ]. - intros k Hk; rewrite isUat_cons_S; exact Hk. -Qed. - -Lemma swf_up E E' s br bl F : - swf E E' s -> swf (rt_El br bl (csub s F) :: E) (rt_El br bl F :: E') (up s). -Proof. - intros H [|k] Hk; cbn in Hk; [ discriminate | ]. - cbn; apply cwf_shift; apply H; exact Hk. -Qed. - -Lemma cwf_csub c : forall E E' s, swf E E' s -> cwf E' c -> cwf E (csub s c). -Proof. - induction c as [ k | | | b br bl F IHF B IHB ]; - intros E E' s Hs H; cbn in *; try exact I. - - apply Hs; assumption. - - destruct H as [HF HB]; split. - + eapply IHF; eassumption. - + eapply IHB; [ apply swf_up; exact Hs | exact HB ]. -Qed. - -Lemma twf_tsub T E E' s : swf E E' s -> twf E' T -> twf E (tsub s T). -Proof. - destruct T; cbn; intros; [ exact I | eapply cwf_csub; eassumption ]. -Qed. - -Lemma subeq_up E' s1 s2 br bl F : - subeq E' s1 s2 -> subeq (rt_El br bl F :: E') (up s1) (up s2). -Proof. - intros H [|k] Hk; cbn in Hk; [ discriminate | ]. - cbn; f_equal; apply H; exact Hk. -Qed. - -Lemma csub_ext_wf c : forall E' s1 s2, - cwf E' c -> subeq E' s1 s2 -> csub s1 c = csub s2 c. -Proof. - induction c as [ k | | | b br bl F IHF B IHB ]; - intros E' s1 s2 Hwf Heq; cbn in *; try reflexivity. - - apply Heq; assumption. - - destruct Hwf as [HF HB]; f_equal. - + eapply IHF; eassumption. - + eapply IHB; [ exact HB | apply subeq_up; exact Heq ]. -Qed. - -Lemma tsub_ext_wf T E' s1 s2 : - twf E' T -> subeq E' s1 s2 -> tsub s1 T = tsub s2 T. -Proof. - destruct T; cbn; intros; [ reflexivity | ]. - f_equal; eapply csub_ext_wf; eassumption. -Qed. - -(* ===================================================================== - 4. The interpretation relations. - - Defined over ARBITRARY syntax of the four relevant sorts (not only over - normal forms): the model's congruence obligations conclude about the - raw term formers, so the relations have to cover the sigma formers too. - - Every clause pins the [renv] index to the term's own syntactic - environment through an [IEnv] premise. That is what makes the indices - FUNCTIONAL (section 5) -- and functionality of the indices is in turn - what lets [rceq_term] at the [ty]/[exp]/[sub] sorts existentially - quantify them. - ===================================================================== *) - -Inductive IEnv : term -> renv -> Prop := -| ienv_emp : IEnv oEmp [] -| ienv_ext : forall G i A E T, - IEnv G E -> ITy E A T -> IEnv (oExt G i A) (T :: E) - -with ITy : renv -> term -> rty -> Prop := -| ity_U : forall E G r l br bl, - IEnv G E -> ErRel r br -> ErLvl l bl -> - ITy E (oU G r l) (rt_U br bl) -| ity_El : forall E G r l c br bl n, - IEnv G E -> ErRel r br -> ErLvl l bl -> ICode E c n -> - ITy E (oEl G r l c) (rt_El br bl n) -| ity_subst : forall E E' G G' g i A T s, - IEnv G E -> IEnv G' E' -> ISub E E' g s -> ITy E' A T -> - ITy E (oTySubst G G' g i A) (tsub s T) - -with ICode : renv -> term -> rcode -> Prop := -| icode_nat : forall E G, IEnv G E -> ICode E (oNat G) rc_nat -| icode_empty : forall E G, IEnv G E -> ICode E (oEmpty G) rc_empty -| icode_pi_rel : forall E G rF lF lG F B brF blF nF nB, - IEnv G E -> ErRel rF brF -> ErLvl lF blF -> - ICode E F nF -> - ICode (rt_El brF blF nF :: E) B nB -> - ICode E (oPiRel G rF lF lG F B) (rc_pi true brF blF nF nB) -| icode_pi_irr : forall E G rF lF F B brF blF nF nB, - IEnv G E -> ErRel rF brF -> ErLvl lF blF -> - ICode E F nF -> - ICode (rt_El brF blF nF :: E) B nB -> - ICode E (oPiIrr G rF lF F B) (rc_pi false brF blF nF nB) -| icode_hd : forall E G i A br bl, - IEnv G E -> ITy E A (rt_U br bl) -> - ICode (rt_U br bl :: E) (oHd G i A) (rc_var 0) -| icode_subst : forall E E' G G' g i A v s n, - IEnv G E -> IEnv G' E' -> ISub E E' g s -> ICode E' v n -> - ICode E (oExpSubst G G' g i A v) (csub s n) - -with ISub : renv -> renv -> term -> rsub -> Prop := -| isub_id : forall E G, IEnv G E -> ISub E E (oId G) rid -| isub_forget : forall E G, IEnv G E -> ISub E [] (oForget G) rforget -| isub_wkn : forall E G i A T, - IEnv G E -> ITy E A T -> ISub (T :: E) E (oWkn G i A) rshift -| isub_cmp : forall E1 E2 E3 G1 G2 G3 f g sf sg, - IEnv G1 E1 -> IEnv G2 E2 -> IEnv G3 E3 -> - ISub E1 E2 f sf -> ISub E2 E3 g sg -> - ISub E1 E3 (oCmp G1 G2 G3 f g) (rcmp sf sg) -| isub_snoc_U : forall E E' G G' i A g v s br bl n, - IEnv G E -> IEnv G' E' -> ISub E E' g s -> - ITy E' A (rt_U br bl) -> ICode E v n -> - ISub E (rt_U br bl :: E') (oSnoc G G' i A g v) (rsnoc n s) -| isub_snoc_El : forall E E' G G' i A g v s br bl n, - IEnv G E -> IEnv G' E' -> ISub E E' g s -> - ITy E' A (rt_El br bl n) -> - ISub E (rt_El br bl n :: E') (oSnoc G G' i A g v) (rsnoc rc_nat s). - -Scheme IEnv_min := Minimality for IEnv Sort Prop - with ITy_min := Minimality for ITy Sort Prop - with ICode_min := Minimality for ICode Sort Prop - with ISub_min := Minimality for ISub Sort Prop. - -Combined Scheme I_mutind from IEnv_min, ITy_min, ICode_min, ISub_min. - -(* The environment extension a binder makes. *) -Lemma IEnv_extC E G rF lF F brF blF nF : - IEnv G E -> ErRel rF brF -> ErLvl lF blF -> ICode E F nF -> - IEnv (oExtC G rF lF F) (rt_El brF blF nF :: E). -Proof. - intros; unfold oExtC; econstructor; [ eassumption | ]. - econstructor; eassumption. -Qed. - -(* ===================================================================== - 5. Functionality, scoping and the [USkel] invariant. - ===================================================================== *) - -Lemma I_fun : - (forall G E1, IEnv G E1 -> forall E2, IEnv G E2 -> E1 = E2) - /\ (forall E1 A T1, ITy E1 A T1 -> forall E2 T2, ITy E2 A T2 -> - E1 = E2 /\ T1 = T2) - /\ (forall E1 c n1, ICode E1 c n1 -> forall E2 n2, ICode E2 c n2 -> - E1 = E2 /\ n1 = n2) - /\ (forall E1 E1' g s1, ISub E1 E1' g s1 -> forall E2 E2' s2, - ISub E2 E2' g s2 -> E1 = E2 /\ E1' = E2' /\ s1 = s2). -Proof. - apply I_mutind. - (* ienv_emp *) - - intros E2 H; inversion H; reflexivity. - (* ienv_ext *) - - intros G i A E T HE IHE HT IHT E2 H; inversion H; subst. - f_equal; [ eapply IHT; eassumption | apply IHE; assumption ]. - (* ity_U *) - - intros E G r l br bl HE IHE Hr Hl E2 T2 H; inversion H; subst. - split; [ apply IHE; assumption | ]. - f_equal; [ eapply ErRel_fun | eapply ErLvl_fun ]; eassumption. - (* ity_El *) - - intros E G r l c br bl n HE IHE Hr Hl Hc IHc E2 T2 H; inversion H; subst. - destruct (IHc _ _ ltac:(eassumption)) as [? ?]; subst. - split; [ reflexivity | ]. - f_equal; [ eapply ErRel_fun | eapply ErLvl_fun ]; eassumption. - (* ity_subst *) - - intros E E' G G' g i A T s HE IHE HE' IHE' Hs IHs HT IHT E2 T2 H; - inversion H; subst. - destruct (IHs _ _ _ ltac:(eassumption)) as [? [? ?]]; subst. - destruct (IHT _ _ ltac:(eassumption)) as [? ?]; subst. - split; reflexivity. - (* icode_nat *) - - intros E G HE IHE E2 n2 H; inversion H; subst. - split; [ apply IHE; assumption | reflexivity ]. - (* icode_empty *) - - intros E G HE IHE E2 n2 H; inversion H; subst. - split; [ apply IHE; assumption | reflexivity ]. - (* icode_pi_rel *) - - intros E G rF lF lG F B brF blF nF nB HE IHE Hr Hl HF IHF HB IHB E2 n2 H; - inversion H; subst. - destruct (IHF _ _ ltac:(eassumption)) as [? ?]; subst. - pose proof (ErRel_fun Hr ltac:(eassumption)) as ?; subst. - pose proof (ErLvl_fun Hl ltac:(eassumption)) as ?; subst. - destruct (IHB _ _ ltac:(eassumption)) as [? ?]; subst. - split; reflexivity. - (* icode_pi_irr *) - - intros E G rF lF F B brF blF nF nB HE IHE Hr Hl HF IHF HB IHB E2 n2 H; - inversion H; subst. - destruct (IHF _ _ ltac:(eassumption)) as [? ?]; subst. - pose proof (ErRel_fun Hr ltac:(eassumption)) as ?; subst. - pose proof (ErLvl_fun Hl ltac:(eassumption)) as ?; subst. - destruct (IHB _ _ ltac:(eassumption)) as [? ?]; subst. - split; reflexivity. - (* icode_hd *) - - intros E G i A br bl HE IHE HT IHT E2 n2 H; inversion H; subst. - destruct (IHT _ _ ltac:(eassumption)) as [? Heq]; subst. - injection Heq as ? ?; subst. - split; reflexivity. - (* icode_subst *) - - intros E E' G G' g i A v s n HE IHE HE' IHE' Hs IHs Hv IHv E2 n2 H; - inversion H; subst. - destruct (IHs _ _ _ ltac:(eassumption)) as [? [? ?]]; subst. - destruct (IHv _ _ ltac:(eassumption)) as [? ?]; subst. - split; reflexivity. - (* isub_id *) - - intros E G HE IHE E2 E2' s2 H; inversion H; subst. - pose proof (IHE _ ltac:(eassumption)) as ?; subst. - repeat split. - (* isub_forget *) - - intros E G HE IHE E2 E2' s2 H; inversion H; subst. - pose proof (IHE _ ltac:(eassumption)) as ?; subst. - repeat split. - (* isub_wkn *) - - intros E G i A T HE IHE HT IHT E2 E2' s2 H; inversion H; subst. - destruct (IHT _ _ ltac:(eassumption)) as [? ?]; subst. - repeat split. - (* isub_cmp *) - - intros E1 E2 E3 G1 G2 G3 f g sf sg H1 IH1 H2 IH2 H3 IH3 Hf IHf Hg IHg - Ea Eb s2 H; inversion H; subst. - destruct (IHf _ _ _ ltac:(eassumption)) as [? [? ?]]; subst. - destruct (IHg _ _ _ ltac:(eassumption)) as [? [? ?]]; subst. - repeat split. - (* isub_snoc_U *) - - intros E E' G G' i A g v s br bl n HE IHE HE' IHE' Hs IHs HT IHT Hv IHv - Ea Eb s2 H; inversion H; subst. - + destruct (IHs _ _ _ ltac:(eassumption)) as [? [? ?]]; subst. - destruct (IHT _ _ ltac:(eassumption)) as [? Heq]; subst. - destruct (IHv _ _ ltac:(eassumption)) as [? ?]; subst. - injection Heq as ? ?; subst. - repeat split. - + destruct (IHT _ _ ltac:(eassumption)) as [? Heq]; discriminate Heq. - (* isub_snoc_El *) - - intros E E' G G' i A g v s br bl n HE IHE HE' IHE' Hs IHs HT IHT - Ea Eb s2 H; inversion H; subst. - + destruct (IHT _ _ ltac:(eassumption)) as [? Heq]; discriminate Heq. - + destruct (IHs _ _ _ ltac:(eassumption)) as [? [? ?]]; subst. - destruct (IHT _ _ ltac:(eassumption)) as [? Heq]; subst. - injection Heq as ? ? ?; subst. - repeat split. -Qed. - -Definition IEnv_fun := proj1 I_fun. -Definition ITy_fun := proj1 (proj2 I_fun). -Definition ICode_fun := proj1 (proj2 (proj2 I_fun)). -Definition ISub_fun := proj2 (proj2 (proj2 I_fun)). - -Lemma isU_tsub s T : isU (tsub s T) = isU T. -Proof. destruct T; reflexivity. Qed. - -Lemma I_wf : - (forall G E, IEnv G E -> True) - /\ (forall E A T, ITy E A T -> twf E T) - /\ (forall E c n, ICode E c n -> cwf E n) - /\ (forall E E' g s, ISub E E' g s -> swf E E' s). -Proof. - apply I_mutind; try (intros; exact I). - (* ity_El *) - - intros; cbn; assumption. - (* ity_subst *) - - intros E E' G G' g i A T s HE _ HE' _ Hs IHs HT IHT. - eapply twf_tsub; eassumption. - (* icode_pi_rel *) - - intros E G rF lF lG F B brF blF nF nB HE _ Hr Hl HF IHF HB IHB. - cbn; split; assumption. - (* icode_pi_irr *) - - intros E G rF lF F B brF blF nF nB HE _ Hr Hl HF IHF HB IHB. - cbn; split; assumption. - (* icode_hd *) - - intros; cbn; reflexivity. - (* icode_subst *) - - intros E E' G G' g i A v s n HE _ HE' _ Hs IHs Hv IHv. - eapply cwf_csub; eassumption. - (* isub_id *) - - intros E G HE _ k Hk; cbn; exact Hk. - (* isub_forget *) - - intros E G HE _ k Hk; unfold isUat in Hk; destruct k; discriminate. - (* isub_wkn *) - - intros E G i A T HE _ HT _ k Hk; cbn; rewrite isUat_cons_S; exact Hk. - (* isub_cmp *) - - intros E1 E2 E3 G1 G2 G3 f g sf sg H1 _ H2 _ H3 _ Hf IHf Hg IHg k Hk. - unfold rcmp; eapply cwf_csub; [ exact IHf | apply IHg; exact Hk ]. - (* isub_snoc_U *) - - intros E E' G G' i A g v s br bl n HE _ HE' _ Hs IHs HT _ Hv IHv [|k] Hk. - + exact IHv. - + apply IHs; exact Hk. - (* isub_snoc_El *) - - intros E E' G G' i A g v s br bl n HE _ HE' _ Hs IHs HT _ [|k] Hk. - + cbn in Hk; discriminate. - + apply IHs; exact Hk. -Qed. - -Definition ITy_twf := proj1 (proj2 I_wf). -Definition ICode_cwf := proj1 (proj2 (proj2 I_wf)). -Definition ISub_swf := proj2 (proj2 (proj2 I_wf)). - -(* U-ness of a type is read off its interpretation, so it is stable under - provable equality: that is what makes the [exp] row of [rceq_term] - well defined. *) -Lemma ITy_USkel E A T : ITy E A T -> USkel A = isU T. -Proof. - induction 1; cbn; try reflexivity. - rewrite isU_tsub; exact IHITy. -Qed. - -(* ===================================================================== - 6. The model. - ===================================================================== *) - -Definition Req_env (G1 G2 : term) : Prop := exists E, IEnv G1 E /\ IEnv G2 E. - -Definition Req_ty (G A1 A2 : term) : Prop := - exists E T, IEnv G E /\ ITy E A1 T /\ ITy E A2 T. - -Definition Req_code (G e1 e2 : term) : Prop := - exists E n, IEnv G E /\ ICode E e1 n /\ ICode E e2 n. - -Definition Req_sub (G G' g1 g2 : term) : Prop := - exists E E' s1 s2, - IEnv G E /\ IEnv G' E' - /\ ISub E E' g1 s1 /\ ISub E E' g2 s2 /\ subeq E' s1 s2. - -Definition rceq_term (t : sort) (e1 e2 : term) : Prop := - match t with - | scon nm [] => - if eqb nm "relevance" then exists b, ErRel e1 b /\ ErRel e2 b - else if eqb nm "lvl" then exists b, ErLvl e1 b /\ ErLvl e2 b - else if eqb nm "tlvl" then ntlvl e1 = ntlvl e2 - else if eqb nm "tyinfo" then ninfo e1 = ninfo e2 - else if eqb nm "env" then Req_env e1 e2 - else True - | scon nm [x; y] => - if eqb nm "sub" then Req_sub y x e1 e2 - else if eqb nm "ty" then Req_ty y e1 e2 - else True - | scon nm [A; i; G] => - if eqb nm "exp" then (if USkel A then Req_code G e1 e2 else True) - else True - | _ => True - end. - -Definition rceq_sort (t1 t2 : sort) : Prop := - forall e1 e2, rceq_term t1 e1 e2 <-> rceq_term t2 e1 e2. - -Definition RigCM : CutTModel := {| ceq_sort := rceq_sort; ceq_term := rceq_term |}. - -(* ---- clause readings (all by conversion) ---- *) - -Lemma rceq_rel_eq r1 r2 - : rceq_term sRelevance r1 r2 = exists b, ErRel r1 b /\ ErRel r2 b. -Proof. reflexivity. Qed. - -Lemma rceq_lvl_eq l1 l2 - : rceq_term sLvl l1 l2 = exists b, ErLvl l1 b /\ ErLvl l2 b. -Proof. reflexivity. Qed. - -Lemma rceq_tlvl_eq n1 n2 : rceq_term sTlvl n1 n2 = (ntlvl n1 = ntlvl n2). -Proof. reflexivity. Qed. - -Lemma rceq_info_eq i1 i2 : rceq_term sInfo i1 i2 = (ninfo i1 = ninfo i2). -Proof. reflexivity. Qed. - -Lemma rceq_ltl_eq a b p1 p2 : rceq_term (sLtl a b) p1 p2 = True. -Proof. reflexivity. Qed. - -Lemma rceq_env_eq G1 G2 : rceq_term sEnv G1 G2 = Req_env G1 G2. -Proof. reflexivity. Qed. - -Lemma rceq_sub_eq G G' g1 g2 : rceq_term (sSub G G') g1 g2 = Req_sub G G' g1 g2. -Proof. reflexivity. Qed. - -Lemma rceq_ty_eq G i A1 A2 : rceq_term (sTy G i) A1 A2 = Req_ty G A1 A2. -Proof. reflexivity. Qed. - -Lemma rceq_exp_eq G i A e1 e2 - : rceq_term (sExp G i A) e1 e2 - = (if USkel A then Req_code G e1 e2 else True). -Proof. reflexivity. Qed. - -(* ===================================================================== - 7. The structural obligations of [CutTModel_ok]. - - [cterm_conv], [csort_trans], [csort_sym] are immediate because - [rceq_sort] IS the bidirectional transfer of [rceq_term]; [csort_by] is - vacuous ([ott_dtt] has no sort equations); [cterm_var] is vacuous (the - meta-context is empty, openness being object-level). - ===================================================================== *) - -Lemma Req_env_sym G1 G2 : Req_env G1 G2 -> Req_env G2 G1. -Proof. intros [E [H1 H2]]; exists E; split; assumption. Qed. - -Lemma Req_env_trans G1 G12 G2 - : Req_env G1 G12 -> Req_env G12 G2 -> Req_env G1 G2. -Proof. - intros [E [H1 H2]] [E' [H3 H4]]. - pose proof (IEnv_fun H2 H3) as Heq; subst. - eexists; split; eassumption. -Qed. - -Lemma Req_ty_sym G A1 A2 : Req_ty G A1 A2 -> Req_ty G A2 A1. -Proof. intros [E [T [H1 [H2 H3]]]]; exists E, T; repeat split; assumption. Qed. - -Lemma Req_ty_trans G A1 A12 A2 - : Req_ty G A1 A12 -> Req_ty G A12 A2 -> Req_ty G A1 A2. -Proof. - intros [E [T [H1 [H2 H3]]]] [E' [T' [H4 [H5 H6]]]]. - destruct (ITy_fun H3 H5) as [? ?]; subst. - exists E', T'; repeat split; assumption. -Qed. - -Lemma Req_code_sym G e1 e2 : Req_code G e1 e2 -> Req_code G e2 e1. -Proof. intros [E [n [H1 [H2 H3]]]]; exists E, n; repeat split; assumption. Qed. - -Lemma Req_code_trans G e1 e12 e2 - : Req_code G e1 e12 -> Req_code G e12 e2 -> Req_code G e1 e2. -Proof. - intros [E [n [H1 [H2 H3]]]] [E' [n' [H4 [H5 H6]]]]. - destruct (ICode_fun H3 H5) as [? ?]; subst. - exists E', n'; repeat split; assumption. -Qed. - -Lemma Req_sub_sym G G' g1 g2 : Req_sub G G' g1 g2 -> Req_sub G G' g2 g1. -Proof. - intros [E [E' [s1 [s2 [H1 [H2 [H3 [H4 H5]]]]]]]]. - exists E, E', s2, s1; repeat split; try assumption. - intros k Hk; symmetry; apply H5; assumption. -Qed. - -Lemma Req_sub_trans G G' g1 g12 g2 - : Req_sub G G' g1 g12 -> Req_sub G G' g12 g2 -> Req_sub G G' g1 g2. -Proof. - intros [E [E' [s1 [s12 [H1 [H2 [H3 [H4 H5]]]]]]]]. - intros [Ea [Eb [s12' [s2 [K1 [K2 [K3 [K4 K5]]]]]]]]. - destruct (ISub_fun H4 K3) as [? [? ?]]; subst. - exists Ea, Eb, s1, s2; repeat split; try assumption. - intros k Hk; rewrite H5 by assumption; apply K5; assumption. -Qed. - -(* The case analysis every sort-generic obligation needs: the four - argument-list shapes [rceq_term] distinguishes, and then the name - tests. *) -Ltac rcases t := - let nm := fresh "nm" in - let l := fresh "l" in - destruct t as [nm l]; - destruct l as [ | ?x [ | ?y [ | ?z [ | ?w ?l ] ] ] ]; - cbn [rceq_term]; - repeat match goal with - | [ |- context [ if eqb nm ?s then _ else _ ] ] => destruct (eqb nm s) - end. - -Lemma term_sym_obligation t e1 e2 : rceq_term t e1 e2 -> rceq_term t e2 e1. -Proof. - rcases t; intro H; - try exact I; - try (destruct H as [b [H1 H2]]; exists b; split; assumption); - try (symmetry; exact H); - try (apply Req_env_sym; exact H); - try (apply Req_sub_sym; exact H); - try (apply Req_ty_sym; exact H). - (* exp *) - all: try (destruct (USkel x); [ apply Req_code_sym; exact H | exact I ]). -Qed. - -Lemma term_trans_obligation t e1 e12 e2 - : rceq_term t e1 e12 -> rceq_term t e12 e2 -> rceq_term t e1 e2. -Proof. - rcases t; intros H K; - try exact I; - try (destruct H as [b [H1 H2]]; destruct K as [b' [K1 K2]]; - pose proof (ErRel_fun H2 K1) as ?; subst; exists b'; - split; assumption); - try (destruct H as [b [H1 H2]]; destruct K as [b' [K1 K2]]; - pose proof (ErLvl_fun H2 K1) as ?; subst; exists b'; - split; assumption); - try (etransitivity; eassumption); - try (eapply Req_env_trans; eassumption); - try (eapply Req_sub_trans; eassumption); - try (eapply Req_ty_trans; eassumption). - all: try (destruct (USkel x); [ eapply Req_code_trans; eassumption | exact I ]). -Qed. - -Lemma term_conv_obligation t1 t2 e1 e2 - : rceq_sort t1 t2 -> rceq_term t1 e1 e2 -> rceq_term t2 e1 e2. -Proof. intros Ht H; apply Ht; exact H. Qed. - -Lemma sort_trans_obligation t1 t12 t2 - : rceq_sort t1 t12 -> rceq_sort t12 t2 -> rceq_sort t1 t2. -Proof. - intros H K e1 e2; split; intro X. - - apply K; apply H; exact X. - - apply H; apply K; exact X. -Qed. - -Lemma sort_sym_obligation t1 t2 : rceq_sort t1 t2 -> rceq_sort t2 t1. -Proof. intros H e1 e2; split; intro X; apply H; exact X. Qed. - -Lemma var_obligation - : forall n t, In (n, t) (@nil (string * sort)) -> rceq_term t (var n) (var n). -Proof. intros n t H; destruct H. Qed. - -(* ===================================================================== - 8. The rule obligations. - - [ott_dtt] is a closed 69-element list, so [In] is a concrete - disjunction; [vm_compute] pins it before destructing, exactly as - Gluing/Stlc/ModelCong.v does (left unreduced each rule instance is - prohibitively slow). - ===================================================================== *) - -Ltac nrm := - repeat match goal with - | [ H : rceq_term ?t ?a ?b |- _ ] => - let t' := eval vm_compute in t in - let a' := eval vm_compute in a in - let b' := eval vm_compute in b in - tryif (constr_eq t t'; constr_eq a a'; constr_eq b b') - then fail - else change_no_check (rceq_term t' a' b') in H - | [ |- rceq_term ?t ?a ?b ] => - let t' := eval vm_compute in t in - let a' := eval vm_compute in a in - let b' := eval vm_compute in b in - tryif (constr_eq t t'; constr_eq a a'; constr_eq b b') - then fail - else change_no_check (rceq_term t' a' b') - end. - -Ltac decomp := - match goal with - | [ Hin : In _ ott_dtt |- _ ] => - vm_compute in Hin; - repeat (destruct Hin as [Hin|Hin]); try discriminate; - inversion Hin; subst; clear Hin - end; - repeat match goal with - | [ H : ceq_args (_::_) _ _ |- _ ] => inversion H; subst; clear H - | [ H : ceq_args [] _ _ |- _ ] => inversion H; subst; clear H - end; - cbn [ceq_term ceq_sort RigCM] in *; nrm. - -(* [csort_by] is vacuous: [ott_dtt] has no sort equations at all. *) -Lemma sort_by_obligation - : forall c' name t1 t2 s1 s2, - In (name, sort_eq_rule c' t1 t2) ott_dtt -> - ceq_args (CM := RigCM) c' s1 s2 -> - rceq_sort t1[/with_names_from c' s1/] t2[/with_names_from c' s2/]. -Proof. - intros c' name t1 t2 s1 s2 Hin Hargs. - vm_compute in Hin; repeat (destruct Hin as [Hin|Hin]); - first [ discriminate | destruct Hin ]. -Qed. - -(* ---- introduction / elimination for each clause (all by conversion) ---- *) - -Lemma rceq_rel_i r1 r2 : (exists b, ErRel r1 b /\ ErRel r2 b) -> rceq_term sRelevance r1 r2. -Proof. exact (fun x => x). Qed. -Lemma rceq_rel_e r1 r2 : rceq_term sRelevance r1 r2 -> exists b, ErRel r1 b /\ ErRel r2 b. -Proof. exact (fun x => x). Qed. -Lemma rceq_lvl_i l1 l2 : (exists b, ErLvl l1 b /\ ErLvl l2 b) -> rceq_term sLvl l1 l2. -Proof. exact (fun x => x). Qed. -Lemma rceq_lvl_e l1 l2 : rceq_term sLvl l1 l2 -> exists b, ErLvl l1 b /\ ErLvl l2 b. -Proof. exact (fun x => x). Qed. -Lemma rceq_tlvl_i n1 n2 : ntlvl n1 = ntlvl n2 -> rceq_term sTlvl n1 n2. -Proof. exact (fun x => x). Qed. -Lemma rceq_tlvl_e n1 n2 : rceq_term sTlvl n1 n2 -> ntlvl n1 = ntlvl n2. -Proof. exact (fun x => x). Qed. -Lemma rceq_info_i i1 i2 : ninfo i1 = ninfo i2 -> rceq_term sInfo i1 i2. -Proof. exact (fun x => x). Qed. -Lemma rceq_info_e i1 i2 : rceq_term sInfo i1 i2 -> ninfo i1 = ninfo i2. -Proof. exact (fun x => x). Qed. -Lemma rceq_env_i G1 G2 : Req_env G1 G2 -> rceq_term sEnv G1 G2. -Proof. exact (fun x => x). Qed. -Lemma rceq_env_e G1 G2 : rceq_term sEnv G1 G2 -> Req_env G1 G2. -Proof. exact (fun x => x). Qed. -Lemma rceq_sub_i G G' g1 g2 : Req_sub G G' g1 g2 -> rceq_term (sSub G G') g1 g2. -Proof. exact (fun x => x). Qed. -Lemma rceq_sub_e G G' g1 g2 : rceq_term (sSub G G') g1 g2 -> Req_sub G G' g1 g2. -Proof. exact (fun x => x). Qed. -Lemma rceq_ty_i G i A1 A2 : Req_ty G A1 A2 -> rceq_term (sTy G i) A1 A2. -Proof. exact (fun x => x). Qed. -Lemma rceq_ty_e G i A1 A2 : rceq_term (sTy G i) A1 A2 -> Req_ty G A1 A2. -Proof. exact (fun x => x). Qed. - -Lemma rceq_exp_i G i A e1 e2 - : (USkel A = true -> Req_code G e1 e2) -> rceq_term (sExp G i A) e1 e2. -Proof. - intro H; change (if USkel A then Req_code G e1 e2 else True). - destruct (USkel A) eqn:Hu; [ apply H; reflexivity | exact I ]. -Qed. - -Lemma rceq_exp_e G i A e1 e2 - : USkel A = true -> rceq_term (sExp G i A) e1 e2 -> Req_code G e1 e2. -Proof. - intros Hu H; change (if USkel A then Req_code G e1 e2 else True) in H. - rewrite Hu in H; exact H. -Qed. - -Lemma rceq_code_i G r l e1 e2 : Req_code G e1 e2 -> rceq_term (sCode G r l) e1 e2. -Proof. exact (fun x => x). Qed. -Lemma rceq_code_e G r l e1 e2 : rceq_term (sCode G r l) e1 e2 -> Req_code G e1 e2. -Proof. exact (fun x => x). Qed. - -(* ---- transfer along a provable equality of environments ---- *) - -Lemma Req_env_transfer G1 G2 : Req_env G1 G2 -> forall E, IEnv G1 E -> IEnv G2 E. -Proof. - intros [E0 [H1 H2]] E H; pose proof (IEnv_fun H H1) as ?; subst; assumption. -Qed. - -Lemma Req_code_transfer G1 G2 e1 e2 - : Req_env G1 G2 -> Req_code G1 e1 e2 -> Req_code G2 e1 e2. -Proof. - intros HG [E [n [H1 [H2 H3]]]]; exists E, n; repeat split; try assumption. - eapply Req_env_transfer; eassumption. -Qed. - -Lemma Req_ty_transfer G1 G2 A1 A2 - : Req_env G1 G2 -> Req_ty G1 A1 A2 -> Req_ty G2 A1 A2. -Proof. - intros HG [E [T [H1 [H2 H3]]]]; exists E, T; repeat split; try assumption. - eapply Req_env_transfer; eassumption. -Qed. - -Lemma Req_sub_transfer G1 G2 G1' G2' g1 g2 - : Req_env G1 G2 -> Req_env G1' G2' -> Req_sub G1 G1' g1 g2 -> Req_sub G2 G2' g1 g2. -Proof. - intros HG HG' [E [E' [s1 [s2 [H1 [H2 [H3 [H4 H5]]]]]]]]. - exists E, E', s1, s2; repeat split; try assumption; - eapply Req_env_transfer; eassumption. -Qed. - -(* ---- [csort_cong]: the 9 sort rules ---- *) - -Lemma sort_cong_refl t : rceq_sort t t. -Proof. intros e1 e2; split; exact (fun x => x). Qed. - -Lemma sort_cong_ltl a1 a2 b1 b2 : rceq_sort (sLtl a1 b1) (sLtl a2 b2). -Proof. intros e1 e2; split; intros _; exact I. Qed. - -Lemma sort_cong_ty G1 G2 i1 i2 - : Req_env G1 G2 -> rceq_sort (sTy G1 i1) (sTy G2 i2). -Proof. - intros HG u v; split; intro H; apply rceq_ty_i; - eapply Req_ty_transfer; try (apply rceq_ty_e in H; exact H). - - exact HG. - - apply Req_env_sym; exact HG. -Qed. - -Lemma sort_cong_sub G1 G2 G1' G2' - : Req_env G1 G2 -> Req_env G1' G2' -> rceq_sort (sSub G1 G1') (sSub G2 G2'). -Proof. - intros HG HG' u v; split; intro H; apply rceq_sub_i; - eapply Req_sub_transfer; try (apply rceq_sub_e in H; exact H). - - exact HG. - - exact HG'. - - apply Req_env_sym; exact HG. - - apply Req_env_sym; exact HG'. -Qed. - -Lemma sort_cong_exp G1 G2 i1 i2 A1 A2 - : Req_env G1 G2 -> Req_ty G2 A1 A2 -> - rceq_sort (sExp G1 i1 A1) (sExp G2 i2 A2). -Proof. - intros HG HA u v. - destruct HA as [E [T [HE [H1 H2]]]]. - pose proof (ITy_USkel H1) as Hu1; pose proof (ITy_USkel H2) as Hu2. - split; intro H; apply rceq_exp_i; intro Hs. - - eapply Req_code_transfer; [ exact HG | ]. - eapply rceq_exp_e; [ | exact H ]; rewrite Hu1, <- Hu2; exact Hs. - - eapply Req_code_transfer; [ apply Req_env_sym; exact HG | ]. - eapply rceq_exp_e; [ | exact H ]; rewrite Hu2, <- Hu1; exact Hs. -Qed. - -Lemma sort_cong_obligation - : forall c' name args s1 s2, - In (name, sort_rule c' args) ott_dtt -> - ceq_args (CM := RigCM) c' s1 s2 -> - rceq_sort (scon name s1) (scon name s2). -Proof. - intros c' name args s1 s2 Hin Hargs. - decomp. - - (* exp *) - apply sort_cong_exp; - [ apply rceq_env_e; assumption | eapply rceq_ty_e; eassumption ]. - - (* ty *) apply sort_cong_ty; apply rceq_env_e; assumption. - - (* sub *) apply sort_cong_sub; apply rceq_env_e; assumption. - - (* env *) apply sort_cong_refl. - - (* tyinfo *) apply sort_cong_refl. - - (* tlvl *) apply sort_cong_refl. - - (* ltl *) apply sort_cong_ltl. - - (* lvl *) apply sort_cong_refl. - - (* relevance *) apply sort_cong_refl. -Qed. - -(* ---- smart constructors for the four [Req_*] relations ---- *) - -Lemma Req_env_mk G1 G2 E : IEnv G1 E -> IEnv G2 E -> Req_env G1 G2. -Proof. intros; exists E; split; assumption. Qed. - -Lemma Req_ty_mk G A1 A2 E T - : IEnv G E -> ITy E A1 T -> ITy E A2 T -> Req_ty G A1 A2. -Proof. intros; exists E, T; repeat split; assumption. Qed. - -Lemma Req_code_mk G e1 e2 E n - : IEnv G E -> ICode E e1 n -> ICode E e2 n -> Req_code G e1 e2. -Proof. intros; exists E, n; repeat split; assumption. Qed. - -Lemma Req_sub_mk G G' g1 g2 E E' s1 s2 - : IEnv G E -> IEnv G' E' -> ISub E E' g1 s1 -> ISub E E' g2 s2 -> - subeq E' s1 s2 -> Req_sub G G' g1 g2. -Proof. intros; exists E, E', s1, s2; repeat split; assumption. Qed. - -(* ---- [cterm_cong]: the 32 term rules ---- - - Only the 24 whose conclusion sort is not an [El] carry content; the - other 8 ([zero], [suc], [Emptyrec], [lam_rel], [lam_irr], [app_rel], - [app_irr], [L0 Req_ty G2 A1 A2 -> Req_env (oExt G1 i1 A1) (oExt G2 i2 A2). -Proof. - intros HG [E [T [HE [H1 H2]]]]. - eapply Req_env_mk with (E := T :: E); econstructor; try eassumption. - eapply Req_env_transfer; [ apply Req_env_sym; exact HG | exact HE ]. -Qed. - -Lemma cong_id G1 G2 : Req_env G1 G2 -> Req_sub G2 G2 (oId G1) (oId G2). -Proof. - intros [E [H1 H2]]. - eapply Req_sub_mk with (E := E) (E' := E) (s1 := rid) (s2 := rid). - - exact H2. - - exact H2. - - constructor; exact H1. - - constructor; exact H2. - - intros k Hk; reflexivity. -Qed. - -Lemma cong_forget G1 G2 - : Req_env G1 G2 -> Req_sub G2 oEmp (oForget G1) (oForget G2). -Proof. - intros [E [H1 H2]]. - eapply Req_sub_mk with (E := E) (E' := @nil rty) - (s1 := rforget) (s2 := rforget). - - exact H2. - - constructor. - - constructor; exact H1. - - constructor; exact H2. - - intros k Hk; reflexivity. -Qed. - -Lemma cong_cmp X1 Y1 X2 Y2 X3 Y3 f1 f2 g1 g2 - : Req_env X1 Y1 -> Req_env X2 Y2 -> Req_env X3 Y3 -> - Req_sub Y1 Y2 f1 f2 -> Req_sub Y2 Y3 g1 g2 -> - Req_sub Y1 Y3 (oCmp X1 X2 X3 f1 g1) (oCmp Y1 Y2 Y3 f2 g2). -Proof. - intros H1 H2 H3 - [E1 [E2 [sf1 [sf2 [K1 [K2 [K3 [K4 K5]]]]]]]] - [E2' [E3 [sg1 [sg2 [L1 [L2 [L3 [L4 L5]]]]]]]]. - pose proof (IEnv_fun L1 K2) as HE; subst E2'. - eapply Req_sub_mk with (E := E1) (E' := E3) - (s1 := rcmp sf1 sg1) (s2 := rcmp sf2 sg2). - - exact K1. - - exact L2. - - econstructor; - [ eapply Req_env_transfer; [ apply Req_env_sym; exact H1 | exact K1 ] - | eapply Req_env_transfer; [ apply Req_env_sym; exact H2 | exact K2 ] - | eapply Req_env_transfer; [ apply Req_env_sym; exact H3 | exact L2 ] - | exact K3 | exact L3 ]. - - econstructor; [ exact K1 | exact K2 | exact L2 | exact K4 | exact L4 ]. - - intros k Hk; unfold rcmp. - rewrite (L5 k Hk). - eapply csub_ext_wf; [ | exact K5 ]. - eapply (ISub_swf L4); exact Hk. -Qed. - -Lemma cong_wkn G1 G2 i1 i2 A1 A2 - : Req_env G1 G2 -> Req_ty G2 A1 A2 -> - Req_sub (oExt G2 i2 A2) G2 (oWkn G1 i1 A1) (oWkn G2 i2 A2). -Proof. - intros HG [E [T [HE [H1 H2]]]]. - eapply Req_sub_mk with (E := T :: E) (E' := E) (s1 := rshift) (s2 := rshift). - - econstructor; [ exact HE | exact H2 ]. - - exact HE. - - econstructor; - [ eapply Req_env_transfer; [ apply Req_env_sym; exact HG | exact HE ] - | exact H1 ]. - - econstructor; [ exact HE | exact H2 ]. - - intros k Hk; reflexivity. -Qed. - -Lemma cong_snoc G1 G2 G1' G2' i1 i2 A1 A2 g1 g2 v1 v2 - : Req_env G1 G2 -> Req_env G1' G2' -> Req_ty G2' A1 A2 -> - Req_sub G2 G2' g1 g2 -> - (USkel A2 = true -> Req_code G2 v1 v2) -> - Req_sub G2 (oExt G2' i2 A2) - (oSnoc G1 G1' i1 A1 g1 v1) (oSnoc G2 G2' i2 A2 g2 v2). -Proof. - intros HG HG' [E' [T [HE' [HA1 HA2]]]] - [Ea [Eb [s1 [s2 [K1 [K2 [K3 [K4 K5]]]]]]]] Hv. - pose proof (IEnv_fun K2 HE') as HEb; subst Eb. - pose proof (Req_env_transfer (Req_env_sym HG) K1) as HG1. - pose proof (Req_env_transfer (Req_env_sym HG') HE') as HG1'. - destruct T as [ br bl | br bl nc ]. - - (* universe slot: the value is a code *) - destruct (Hv (ITy_USkel HA2)) as [Ec [n [M1 [M2 M3]]]]. - pose proof (IEnv_fun M1 K1) as HEc; subst Ec. - eapply Req_sub_mk with (E := Ea) (E' := rt_U br bl :: E') - (s1 := rsnoc n s1) (s2 := rsnoc n s2). - + exact K1. - + econstructor; [ exact HE' | exact HA2 ]. - + eapply isub_snoc_U; - [ exact HG1 | exact HG1' | exact K3 | exact HA1 | exact M2 ]. - + eapply isub_snoc_U; - [ exact K1 | exact HE' | exact K4 | exact HA2 | exact M3 ]. - + intros [|k] Hk; [ reflexivity | apply K5; exact Hk ]. - - (* non-universe slot: both sides carry the same junk *) - eapply Req_sub_mk with (E := Ea) (E' := rt_El br bl nc :: E') - (s1 := rsnoc rc_nat s1) (s2 := rsnoc rc_nat s2). - + exact K1. - + econstructor; [ exact HE' | exact HA2 ]. - + eapply isub_snoc_El; [ exact HG1 | exact HG1' | exact K3 | exact HA1 ]. - + eapply isub_snoc_El; [ exact K1 | exact HE' | exact K4 | exact HA2 ]. - + intros [|k] Hk; [ reflexivity | apply K5; exact Hk ]. -Qed. - -Lemma cong_hd G1 G2 i1 i2 A1 A2 - : Req_env G1 G2 -> Req_ty G2 A1 A2 -> USkel A2 = true -> - Req_code (oExt G2 i2 A2) (oHd G1 i1 A1) (oHd G2 i2 A2). -Proof. - intros HG [E [T [HE [H1 H2]]]] Hu. - rewrite (ITy_USkel H2) in Hu. - destruct T as [ br bl | br bl nc ]; [ | discriminate ]. - eapply Req_code_mk with (E := rt_U br bl :: E) (n := rc_var 0). - - econstructor; [ exact HE | exact H2 ]. - - econstructor; - [ eapply Req_env_transfer; [ apply Req_env_sym; exact HG | exact HE ] - | exact H1 ]. - - econstructor; [ exact HE | exact H2 ]. -Qed. - -Lemma cong_ty_subst G1 G2 G1' G2' g1 g2 i1 i2 A1 A2 - : Req_env G1 G2 -> Req_env G1' G2' -> Req_sub G2 G2' g1 g2 -> - Req_ty G2' A1 A2 -> - Req_ty G2 (oTySubst G1 G1' g1 i1 A1) (oTySubst G2 G2' g2 i2 A2). -Proof. - intros HG HG' [Ea [Eb [s1 [s2 [K1 [K2 [K3 [K4 K5]]]]]]]] - [E' [T [HE' [H1 H2]]]]. - pose proof (IEnv_fun K2 HE') as HEb; subst Eb. - assert (tsub s1 T = tsub s2 T) as Hts - by (eapply tsub_ext_wf; [ eapply ITy_twf; exact H1 | exact K5 ]). - eapply Req_ty_mk with (E := Ea) (T := tsub s2 T). - - exact K1. - - rewrite <- Hts. - econstructor; - [ eapply Req_env_transfer; [ apply Req_env_sym; exact HG | exact K1 ] - | eapply Req_env_transfer; [ apply Req_env_sym; exact HG' | exact HE' ] - | exact K3 | exact H1 ]. - - econstructor; [ exact K1 | exact HE' | exact K4 | exact H2 ]. -Qed. - -Lemma cong_exp_subst G1 G2 G1' G2' g1 g2 i1 i2 A1 A2 v1 v2 - : Req_env G1 G2 -> Req_env G1' G2' -> Req_sub G2 G2' g1 g2 -> - Req_code G2' v1 v2 -> - Req_code G2 (oExpSubst G1 G1' g1 i1 A1 v1) (oExpSubst G2 G2' g2 i2 A2 v2). -Proof. - intros HG HG' [Ea [Eb [s1 [s2 [K1 [K2 [K3 [K4 K5]]]]]]]] [Ec [n [M1 [M2 M3]]]]. - pose proof (IEnv_fun M1 K2) as HEc; subst Ec. - assert (csub s1 n = csub s2 n) as Hcs - by (eapply csub_ext_wf; [ eapply ICode_cwf; exact M2 | exact K5 ]). - eapply Req_code_mk with (E := Ea) (n := csub s2 n). - - exact K1. - - rewrite <- Hcs. - econstructor; - [ eapply Req_env_transfer; [ apply Req_env_sym; exact HG | exact K1 ] - | eapply Req_env_transfer; [ apply Req_env_sym; exact HG' | exact K2 ] - | exact K3 | exact M2 ]. - - econstructor; [ exact K1 | exact K2 | exact K4 | exact M3 ]. -Qed. - -Lemma cong_U G1 G2 r1 r2 l1 l2 - : Req_env G1 G2 -> (exists b, ErRel r1 b /\ ErRel r2 b) -> - (exists b, ErLvl l1 b /\ ErLvl l2 b) -> - Req_ty G2 (oU G1 r1 l1) (oU G2 r2 l2). -Proof. - intros [E [HE1 HE2]] [br [Hr1 Hr2]] [bl [Hl1 Hl2]]. - eapply Req_ty_mk with (E := E) (T := rt_U br bl). - - exact HE2. - - econstructor; [ exact HE1 | exact Hr1 | exact Hl1 ]. - - econstructor; [ exact HE2 | exact Hr2 | exact Hl2 ]. -Qed. - -Lemma cong_El G1 G2 r1 r2 l1 l2 c1 c2 - : Req_env G1 G2 -> (exists b, ErRel r1 b /\ ErRel r2 b) -> - (exists b, ErLvl l1 b /\ ErLvl l2 b) -> Req_code G2 c1 c2 -> - Req_ty G2 (oEl G1 r1 l1 c1) (oEl G2 r2 l2 c2). -Proof. - intros HG [br [Hr1 Hr2]] [bl [Hl1 Hl2]] [E [n [HE [Hc1 Hc2]]]]. - eapply Req_ty_mk with (E := E) (T := rt_El br bl n). - - exact HE. - - econstructor; - [ eapply Req_env_transfer; [ apply Req_env_sym; exact HG | exact HE ] - | exact Hr1 | exact Hl1 | exact Hc1 ]. - - econstructor; [ exact HE | exact Hr2 | exact Hl2 | exact Hc2 ]. -Qed. - -Lemma cong_Nat G1 G2 : Req_env G1 G2 -> Req_code G2 (oNat G1) (oNat G2). -Proof. - intros [E [H1 H2]]; eapply Req_code_mk with (E := E) (n := rc_nat); - [ exact H2 | econstructor; exact H1 | econstructor; exact H2 ]. -Qed. - -Lemma cong_Empty G1 G2 : Req_env G1 G2 -> Req_code G2 (oEmpty G1) (oEmpty G2). -Proof. - intros [E [H1 H2]]; eapply Req_code_mk with (E := E) (n := rc_empty); - [ exact H2 | econstructor; exact H1 | econstructor; exact H2 ]. -Qed. - -Lemma cong_Pi_rel G1 G2 rF1 rF2 lF1 lF2 lG1 lG2 F1 F2 B1 B2 - : Req_env G1 G2 -> (exists b, ErRel rF1 b /\ ErRel rF2 b) -> - (exists b, ErLvl lF1 b /\ ErLvl lF2 b) -> - Req_code G2 F1 F2 -> Req_code (oExtC G2 rF2 lF2 F2) B1 B2 -> - Req_code G2 (oPiRel G1 rF1 lF1 lG1 F1 B1) (oPiRel G2 rF2 lF2 lG2 F2 B2). -Proof. - intros HG [br [Hr1 Hr2]] [bl [Hl1 Hl2]] [E [nF [HE [HF1 HF2]]]] - [E2 [nB [HE2 [HB1 HB2]]]]. - assert (IEnv (oExtC G2 rF2 lF2 F2) (rt_El br bl nF :: E)) as HX - by (eapply IEnv_extC; eassumption). - pose proof (IEnv_fun HE2 HX) as HE2eq; subst E2. - eapply Req_code_mk with (E := E) (n := rc_pi true br bl nF nB). - - exact HE. - - econstructor; - [ eapply Req_env_transfer; [ apply Req_env_sym; exact HG | exact HE ] - | exact Hr1 | exact Hl1 | exact HF1 | exact HB1 ]. - - econstructor; [ exact HE | exact Hr2 | exact Hl2 | exact HF2 | exact HB2 ]. -Qed. - -Lemma cong_Pi_irr G1 G2 rF1 rF2 lF1 lF2 F1 F2 B1 B2 - : Req_env G1 G2 -> (exists b, ErRel rF1 b /\ ErRel rF2 b) -> - (exists b, ErLvl lF1 b /\ ErLvl lF2 b) -> - Req_code G2 F1 F2 -> Req_code (oExtC G2 rF2 lF2 F2) B1 B2 -> - Req_code G2 (oPiIrr G1 rF1 lF1 F1 B1) (oPiIrr G2 rF2 lF2 F2 B2). -Proof. - intros HG [br [Hr1 Hr2]] [bl [Hl1 Hl2]] [E [nF [HE [HF1 HF2]]]] - [E2 [nB [HE2 [HB1 HB2]]]]. - assert (IEnv (oExtC G2 rF2 lF2 F2) (rt_El br bl nF :: E)) as HX - by (eapply IEnv_extC; eassumption). - pose proof (IEnv_fun HE2 HX) as HE2eq; subst E2. - eapply Req_code_mk with (E := E) (n := rc_pi false br bl nF nB). - - exact HE. - - econstructor; - [ eapply Req_env_transfer; [ apply Req_env_sym; exact HG | exact HE ] - | exact Hr1 | exact Hl1 | exact HF1 | exact HB1 ]. - - econstructor; [ exact HE | exact Hr2 | exact Hl2 | exact HF2 | exact HB2 ]. -Qed. - -Lemma cong_info r1 r2 n1 n2 - : (exists b, ErRel r1 b /\ ErRel r2 b) -> ntlvl n1 = ntlvl n2 -> - ninfo (oInfo r1 n1) = ninfo (oInfo r2 n2). -Proof. - intros [b [H1 H2]] Hn. - pose proof (ErRel_inj H1 H2) as Hrr; subst. - rewrite !ninfo_oInfo, Hn; reflexivity. -Qed. - -Lemma cong_next l1 l2 - : (exists b, ErLvl l1 b /\ ErLvl l2 b) -> ntlvl (oNext l1) = ntlvl (oNext l2). -Proof. - intros [b [H1 H2]]; pose proof (ErLvl_inj H1 H2) as Hll; subst; reflexivity. -Qed. - -Lemma cong_iota l1 l2 - : (exists b, ErLvl l1 b /\ ErLvl l2 b) -> ntlvl (oIota l1) = ntlvl (oIota l2). -Proof. - intros [b [H1 H2]]; pose proof (ErLvl_inj H1 H2) as Hll; subst; reflexivity. -Qed. - -Lemma rceq_exp_e' G i A e1 e2 - : rceq_term (sExp G i A) e1 e2 -> USkel A = true -> Req_code G e1 e2. -Proof. - intros H Hu; change (if USkel A then Req_code G e1 e2 else True) in H. - rewrite Hu in H; exact H. -Qed. - -Lemma cong_obligation - : forall c' name args t s1 s2, - In (name, term_rule c' args t) ott_dtt -> - ceq_args (CM := RigCM) c' s1 s2 -> - rceq_term t[/with_names_from c' s2/] (con name s1) (con name s2). -Proof. - intros c' name args t s1 s2 Hin Hargs. - decomp; try exact I. - - (* Pi_irr *) - apply rceq_exp_i; intros _; apply cong_Pi_irr; - solve [ apply rceq_env_e; eassumption - | apply rceq_rel_e; eassumption - | apply rceq_lvl_e; eassumption - | eapply rceq_exp_e'; [ eassumption | reflexivity ] ]. - - (* Pi_rel *) - apply rceq_exp_i; intros _; apply cong_Pi_rel; - solve [ apply rceq_env_e; eassumption - | apply rceq_rel_e; eassumption - | apply rceq_lvl_e; eassumption - | eapply rceq_exp_e'; [ eassumption | reflexivity ] ]. - - (* Empty *) - apply rceq_exp_i; intros _; apply cong_Empty; apply rceq_env_e; eassumption. - - (* Nat *) - apply rceq_exp_i; intros _; apply cong_Nat; apply rceq_env_e; eassumption. - - (* El *) - apply rceq_ty_i; apply cong_El; - solve [ apply rceq_env_e; eassumption - | apply rceq_rel_e; eassumption - | apply rceq_lvl_e; eassumption - | eapply rceq_exp_e'; [ eassumption | reflexivity ] ]. - - (* U *) - apply rceq_ty_i; apply cong_U; - solve [ apply rceq_env_e; eassumption - | apply rceq_rel_e; eassumption - | apply rceq_lvl_e; eassumption ]. - - (* hd *) - apply rceq_exp_i; intro Hu; apply cong_hd; - solve [ apply rceq_env_e; eassumption - | eapply rceq_ty_e; eassumption - | exact Hu ]. - - (* wkn *) - apply rceq_sub_i; apply cong_wkn; - solve [ apply rceq_env_e; eassumption - | eapply rceq_ty_e; eassumption ]. - - (* snoc *) - apply rceq_sub_i; apply cong_snoc; - solve [ apply rceq_env_e; eassumption - | eapply rceq_ty_e; eassumption - | apply rceq_sub_e; eassumption - | (intro Hu; eapply rceq_exp_e'; [ eassumption | exact Hu ]) ]. - - (* ext *) - apply rceq_env_i; apply cong_ext; - solve [ apply rceq_env_e; eassumption | eapply rceq_ty_e; eassumption ]. - - (* forget *) - apply rceq_sub_i; apply cong_forget; apply rceq_env_e; eassumption. - - (* emp *) apply rceq_env_i; apply cong_emp. - - (* exp_subst *) - apply rceq_exp_i; intro Hu; apply cong_exp_subst; - solve [ apply rceq_env_e; eassumption - | apply rceq_sub_e; eassumption - | eapply rceq_exp_e'; [ eassumption | exact Hu ] ]. - - (* ty_subst *) - apply rceq_ty_i; apply cong_ty_subst; - solve [ apply rceq_env_e; eassumption - | apply rceq_sub_e; eassumption - | eapply rceq_ty_e; eassumption ]. - - (* cmp *) - apply rceq_sub_i; apply cong_cmp; - solve [ apply rceq_env_e; eassumption | apply rceq_sub_e; eassumption ]. - - (* id *) - apply rceq_sub_i; apply cong_id; apply rceq_env_e; eassumption. - - (* info *) - apply rceq_info_i; apply cong_info; - solve [ apply rceq_rel_e; eassumption | apply rceq_tlvl_e; eassumption ]. - - (* next *) - apply rceq_tlvl_i; apply cong_next; apply rceq_lvl_e; eassumption. - - (* inf *) apply rceq_tlvl_i; reflexivity. - - (* iota *) - apply rceq_tlvl_i; apply cong_iota; apply rceq_lvl_e; eassumption. - - (* L1 *) apply rceq_lvl_i; exists true; split; constructor. - - (* L0 *) apply rceq_lvl_i; exists false; split; constructor. - - (* irr *) apply rceq_rel_i; exists false; split; constructor. - - (* rel *) apply rceq_rel_i; exists true; split; constructor. -Qed. - -(* ---- [cterm_by]: the 28 equations ---- - - 7 of them live at an [El]-sort and are [exact I]: both beta rules, eta, - [lam_rel subst], [zero subst], [suc subst] and [ltl_irr]. That is the - whole content of design section 2 -- no equation of the theory can - rewrite a code -- and it survived contact with the obligations - unchanged. The remaining 21 are the sigma laws, the four [X subst] - commutations, and the two [tlvl] equations. *) - -(* The lifting of a substitution under a binder, as the object theory - spells it ([Syntax.oLift]), interprets as [rc_nat .: (shift o s)] -- - the head slot is an [El] slot, so its junk value is invisible to - [subeq], which is exactly why it may differ from [up]'s [rc_var 0]. *) -(* The substituted domain code that [oLift] (and the [Pi] commutations) - name; it is exactly [oLift]'s own [Fg]. *) -Definition oCodeSub (G G' g rF lF F : term) : term := - oExpSubst G G' g (iCode lF) (oU G' rF lF) F. - -Lemma ISub_oLift Y1 Y2 g rF lF F E E2 s br bl nF - : IEnv Y1 E -> IEnv Y2 E2 -> ISub E E2 g s -> - ErRel rF br -> ErLvl lF bl -> ICode E2 F nF -> ICode E (oCodeSub Y1 Y2 g rF lF F) (csub s nF) -> - ISub (rt_El br bl (csub s nF) :: E) (rt_El br bl nF :: E2) - (oLift Y1 Y2 g rF lF F) (rsnoc rc_nat (rcmp rshift s)). -Proof. - intros HE HE2 Hs Hr Hl HF HFg. - assert (ITy E (oEl Y1 rF lF (oCodeSub Y1 Y2 g rF lF F)) - (rt_El br bl (csub s nF))) as HTy - by (econstructor; eassumption). - assert (IEnv (oExtC Y1 rF lF (oCodeSub Y1 Y2 g rF lF F)) - (rt_El br bl (csub s nF) :: E)) as HEF - by (unfold oExtC; econstructor; eassumption). - unfold oLift. - eapply isub_snoc_El. - - exact HEF. - - exact HE2. - - econstructor; [ exact HEF | exact HE | exact HE2 | | exact Hs ]. - econstructor; [ exact HE | exact HTy ]. - - econstructor; eassumption. -Qed. - -Lemma subeq_lift E2 s1 s2 br bl nF - : subeq E2 s1 s2 -> - subeq (rt_El br bl nF :: E2) (up s1) (rsnoc rc_nat (rcmp rshift s2)). -Proof. - intros H [|k] Hk; [ cbn in Hk; discriminate | ]. - unfold up, rsnoc, rcmp; rewrite csub_rshift, (H k Hk); reflexivity. -Qed. - -Lemma by_id_left X1 Y1 X2 Y2 g1 g2 - : Req_env X1 Y1 -> Req_env X2 Y2 -> Req_sub Y1 Y2 g1 g2 -> - Req_sub Y1 Y2 (oCmp X1 X1 X2 (oId X1) g1) g2. -Proof. - intros H1 H2 [E [E' [s1 [s2 [K1 [K2 [K3 [K4 K5]]]]]]]]. - pose proof (Req_env_transfer (Req_env_sym H1) K1) as HX1. - pose proof (Req_env_transfer (Req_env_sym H2) K2) as HX2. - eapply Req_sub_mk with (E := E) (E' := E') (s1 := rcmp rid s1) (s2 := s2). - - exact K1. - - exact K2. - - econstructor; - [ exact HX1 | exact HX1 | exact HX2 | constructor; exact HX1 | exact K3 ]. - - exact K4. - - intros k Hk; unfold rcmp; rewrite csub_id; apply K5; exact Hk. -Qed. - -Lemma by_id_right X1 Y1 X2 Y2 g1 g2 - : Req_env X1 Y1 -> Req_env X2 Y2 -> Req_sub Y1 Y2 g1 g2 -> - Req_sub Y1 Y2 (oCmp X1 X2 X2 g1 (oId X2)) g2. -Proof. - intros H1 H2 [E [E' [s1 [s2 [K1 [K2 [K3 [K4 K5]]]]]]]]. - pose proof (Req_env_transfer (Req_env_sym H1) K1) as HX1. - pose proof (Req_env_transfer (Req_env_sym H2) K2) as HX2. - eapply Req_sub_mk with (E := E) (E' := E') (s1 := rcmp s1 rid) (s2 := s2). - - exact K1. - - exact K2. - - econstructor; - [ exact HX1 | exact HX2 | exact HX2 | exact K3 | constructor; exact HX2 ]. - - exact K4. - - intros k Hk; unfold rcmp, rid; cbn; apply K5; exact Hk. -Qed. - -Lemma subeq_cmp E2 E3 sf1 sf2 sg1 sg2 - : swf E2 E3 sg2 -> subeq E2 sf1 sf2 -> subeq E3 sg1 sg2 -> - subeq E3 (rcmp sf1 sg1) (rcmp sf2 sg2). -Proof. - intros Hw Hf Hg k Hk; unfold rcmp. - rewrite (Hg k Hk). - eapply csub_ext_wf; [ apply Hw; exact Hk | exact Hf ]. -Qed. - -Lemma by_cmp_assoc X1 Y1 X2 Y2 X3 Y3 X4 Y4 f1 f2 g1 g2 h1 h2 - : Req_env X1 Y1 -> Req_env X2 Y2 -> Req_env X3 Y3 -> Req_env X4 Y4 -> - Req_sub Y1 Y2 f1 f2 -> Req_sub Y2 Y3 g1 g2 -> Req_sub Y3 Y4 h1 h2 -> - Req_sub Y1 Y4 (oCmp X1 X2 X4 f1 (oCmp X2 X3 X4 g1 h1)) - (oCmp Y1 Y3 Y4 (oCmp Y1 Y2 Y3 f2 g2) h2). -Proof. - intros H1 H2 H3 H4 - [E1 [E2 [sf1 [sf2 [K1 [K2 [K3 [K4 K5]]]]]]]] - [E2a [E3 [sg1 [sg2 [L1 [L2 [L3 [L4 L5]]]]]]]] - [E3a [E4 [sh1 [sh2 [M1 [M2 [M3 [M4 M5]]]]]]]]. - pose proof (IEnv_fun L1 K2) as Ha; subst E2a. - pose proof (IEnv_fun M1 L2) as Hb; subst E3a. - pose proof (Req_env_transfer (Req_env_sym H1) K1) as HX1. - pose proof (Req_env_transfer (Req_env_sym H2) K2) as HX2. - pose proof (Req_env_transfer (Req_env_sym H3) L2) as HX3. - pose proof (Req_env_transfer (Req_env_sym H4) M2) as HX4. - eapply Req_sub_mk with (E := E1) (E' := E4) - (s1 := rcmp sf1 (rcmp sg1 sh1)) - (s2 := rcmp (rcmp sf2 sg2) sh2). - - exact K1. - - exact M2. - - econstructor; [ exact HX1 | exact HX2 | exact HX4 | exact K3 | ]. - econstructor; [ exact HX2 | exact HX3 | exact HX4 | exact L3 | exact M3 ]. - - econstructor; [ exact K1 | exact L2 | exact M2 | | exact M4 ]. - econstructor; [ exact K1 | exact K2 | exact L2 | exact K4 | exact L4 ]. - - intros k Hk. - change (rcmp sf1 (rcmp sg1 sh1) k) with (csub sf1 (csub sg1 (sh1 k))). - rewrite csub_comp. - change (rcmp (rcmp sf2 sg2) sh2 k) with (csub (rcmp sf2 sg2) (sh2 k)). - rewrite (M5 k Hk). - eapply csub_ext_wf; [ eapply (ISub_swf M4); exact Hk | ]. - eapply subeq_cmp; [ eapply ISub_swf; exact L4 | exact K5 | exact L5 ]. -Qed. - -Lemma by_cmp_forget X1 Y1 X2 Y2 f1 f2 - : Req_env X1 Y1 -> Req_env X2 Y2 -> Req_sub Y1 Y2 f1 f2 -> - Req_sub Y1 oEmp (oCmp X1 X2 oEmp f1 (oForget X2)) (oForget Y1). -Proof. - intros H1 H2 [E [E' [s1 [s2 [K1 [K2 [K3 [K4 K5]]]]]]]]. - pose proof (Req_env_transfer (Req_env_sym H1) K1) as HX1. - pose proof (Req_env_transfer (Req_env_sym H2) K2) as HX2. - eapply Req_sub_mk with (E := E) (E' := @nil rty) - (s1 := rcmp s1 rforget) (s2 := rforget). - - exact K1. - - constructor. - - econstructor; - [ exact HX1 | exact HX2 | constructor | exact K3 | constructor; exact HX2 ]. - - constructor; exact K1. - - intros k Hk; cbn in Hk; unfold isUat in Hk; - destruct k; cbn in Hk; discriminate. -Qed. - -Lemma by_id_emp_forget : Req_sub oEmp oEmp (oId oEmp) (oForget oEmp). -Proof. - eapply Req_sub_mk with (E := @nil rty) (E' := @nil rty) - (s1 := rid) (s2 := rforget). - - constructor. - - constructor. - - constructor; constructor. - - constructor; constructor. - - intros k Hk; unfold isUat in Hk; destruct k; cbn in Hk; discriminate. -Qed. - -Lemma by_wkn_snoc X1 Y1 X2 Y2 i1 A1 A2 g1 g2 v1 v2 - : Req_env X1 Y1 -> Req_env X2 Y2 -> Req_ty Y2 A1 A2 -> Req_sub Y1 Y2 g1 g2 -> - (USkel A2 = true -> Req_code Y1 v1 v2) -> - Req_sub Y1 Y2 - (oCmp X1 (oExt X2 i1 A1) X2 (oSnoc X1 X2 i1 A1 g1 v1) (oWkn X2 i1 A1)) g2. -Proof. - intros H1 H2 [E2 [T [HE2 [HA1 HA2]]]] - [E [E2a [s1 [s2 [K1 [K2 [K3 [K4 K5]]]]]]]] Hv. - pose proof (IEnv_fun K2 HE2) as Ha; subst E2a. - pose proof (Req_env_transfer (Req_env_sym H1) K1) as HX1. - pose proof (Req_env_transfer (Req_env_sym H2) HE2) as HX2. - assert (IEnv (oExt X2 i1 A1) (T :: E2)) as HXE - by (econstructor; [ exact HX2 | exact HA1 ]). - destruct T as [ br bl | br bl nc ]. - - destruct (Hv (ITy_USkel HA2)) as [Ec [n [M1 [M2 M3]]]]. - pose proof (IEnv_fun M1 K1) as Hb; subst Ec. - eapply Req_sub_mk with (E := E) (E' := E2) - (s1 := rcmp (rsnoc n s1) rshift) (s2 := s2). - + exact K1. - + exact HE2. - + econstructor; [ exact HX1 | exact HXE | exact HX2 | | ]. - * eapply isub_snoc_U; - [ exact HX1 | exact HX2 | exact K3 | exact HA1 | exact M2 ]. - * econstructor; [ exact HX2 | exact HA1 ]. - + exact K4. - + intros k Hk; unfold rcmp, rshift, rsnoc; cbn; apply K5; exact Hk. - - eapply Req_sub_mk with (E := E) (E' := E2) - (s1 := rcmp (rsnoc rc_nat s1) rshift) (s2 := s2). - + exact K1. - + exact HE2. - + econstructor; [ exact HX1 | exact HXE | exact HX2 | | ]. - * eapply isub_snoc_El; - [ exact HX1 | exact HX2 | exact K3 | exact HA1 ]. - * econstructor; [ exact HX2 | exact HA1 ]. - + exact K4. - + intros k Hk; unfold rcmp, rshift, rsnoc; cbn; apply K5; exact Hk. -Qed. - -Lemma by_snoc_hd X1 Y1 X2 Y2 i1 A1 A2 g1 g2 v1 v2 - : Req_env X1 Y1 -> Req_env X2 Y2 -> Req_ty Y2 A1 A2 -> Req_sub Y1 Y2 g1 g2 -> - Req_code Y1 v1 v2 -> USkel A2 = true -> - Req_code Y1 - (oExpSubst X1 (oExt X2 i1 A1) (oSnoc X1 X2 i1 A1 g1 v1) i1 - (oTySubst (oExt X2 i1 A1) X2 (oWkn X2 i1 A1) i1 A1) (oHd X2 i1 A1)) - v2. -Proof. - intros H1 H2 [E2 [T [HE2 [HA1 HA2]]]] - [E [E2a [s1 [s2 [K1 [K2 [K3 [K4 K5]]]]]]]] [Ec [n [M1 [M2 M3]]]] Hu. - pose proof (IEnv_fun K2 HE2) as Ha; subst E2a. - pose proof (IEnv_fun M1 K1) as Hb; subst Ec. - pose proof (Req_env_transfer (Req_env_sym H1) K1) as HX1. - pose proof (Req_env_transfer (Req_env_sym H2) HE2) as HX2. - rewrite (ITy_USkel HA2) in Hu. - destruct T as [ br bl | br bl nc ]; [ | discriminate ]. - assert (IEnv (oExt X2 i1 A1) (rt_U br bl :: E2)) as HXE - by (econstructor; [ exact HX2 | exact HA1 ]). - eapply Req_code_mk with (E := E) (n := n). - - exact K1. - - change n with (csub (rsnoc n s1) (rc_var 0)). - econstructor; [ exact HX1 | exact HXE | | ]. - + eapply isub_snoc_U; - [ exact HX1 | exact HX2 | exact K3 | exact HA1 | exact M2 ]. - + econstructor; [ exact HX2 | exact HA1 ]. - - exact M3. -Qed. - -Lemma by_cmp_snoc X1 Y1 X2 Y2 X3 Y3 i1 i2 A1 A2 f1 f2 g1 g2 v1 v2 - : Req_env X1 Y1 -> Req_env X2 Y2 -> Req_env X3 Y3 -> - Req_ty Y3 A1 A2 -> Req_sub Y1 Y2 f1 f2 -> Req_sub Y2 Y3 g1 g2 -> - (USkel A2 = true -> Req_code Y2 v1 v2) -> - Req_sub Y1 (oExt Y3 i2 A2) - (oCmp X1 X2 (oExt X3 i1 A1) f1 (oSnoc X2 X3 i1 A1 g1 v1)) - (oSnoc Y1 Y3 i2 A2 (oCmp Y1 Y2 Y3 f2 g2) - (oExpSubst Y1 Y2 f2 i2 (oTySubst Y2 Y3 g2 i2 A2) v2)). -Proof. - intros H1 H2 H3 [E3 [T [HE3 [HA1 HA2]]]] - [E1 [E2 [sf1 [sf2 [K1 [K2 [K3 [K4 K5]]]]]]]] - [E2a [E3a [sg1 [sg2 [L1 [L2 [L3 [L4 L5]]]]]]]] Hv. - pose proof (IEnv_fun L1 K2) as Ha; subst E2a. - pose proof (IEnv_fun L2 HE3) as Hb; subst E3a. - pose proof (Req_env_transfer (Req_env_sym H1) K1) as HX1. - pose proof (Req_env_transfer (Req_env_sym H2) K2) as HX2. - pose proof (Req_env_transfer (Req_env_sym H3) HE3) as HX3. - destruct T as [ br bl | br bl nc ]. - - destruct (Hv (ITy_USkel HA2)) as [Ec [n [M1 [M2 M3]]]]. - pose proof (IEnv_fun M1 K2) as Hc; subst Ec. - eapply Req_sub_mk with (E := E1) (E' := rt_U br bl :: E3) - (s1 := rcmp sf1 (rsnoc n sg1)) - (s2 := rsnoc (csub sf2 n) (rcmp sf2 sg2)). - + exact K1. - + econstructor; [ exact HE3 | exact HA2 ]. - + econstructor; [ exact HX1 | exact HX2 | | exact K3 | ]. - * econstructor; [ exact HX3 | exact HA1 ]. - * eapply isub_snoc_U; - [ exact HX2 | exact HX3 | exact L3 | exact HA1 | exact M2 ]. - + eapply isub_snoc_U. - * exact K1. - * exact HE3. - * econstructor; [ exact K1 | exact K2 | exact HE3 | exact K4 | exact L4 ]. - * exact HA2. - * econstructor; [ exact K1 | exact K2 | exact K4 | exact M3 ]. - + intros [|k] Hk. - * unfold rcmp, rsnoc; cbn. - eapply csub_ext_wf; [ eapply ICode_cwf; exact M2 | exact K5 ]. - * unfold rcmp, rsnoc; cbn. - rewrite (L5 k Hk). - eapply csub_ext_wf; [ eapply (ISub_swf L4); exact Hk | exact K5 ]. - - eapply Req_sub_mk with (E := E1) (E' := rt_El br bl nc :: E3) - (s1 := rcmp sf1 (rsnoc rc_nat sg1)) - (s2 := rsnoc rc_nat (rcmp sf2 sg2)). - + exact K1. - + econstructor; [ exact HE3 | exact HA2 ]. - + econstructor; [ exact HX1 | exact HX2 | | exact K3 | ]. - * econstructor; [ exact HX3 | exact HA1 ]. - * eapply isub_snoc_El; [ exact HX2 | exact HX3 | exact L3 | exact HA1 ]. - + eapply isub_snoc_El. - * exact K1. - * exact HE3. - * econstructor; [ exact K1 | exact K2 | exact HE3 | exact K4 | exact L4 ]. - * exact HA2. - + intros [|k] Hk; [ cbn in Hk; discriminate | ]. - unfold rcmp, rsnoc; cbn. - rewrite (L5 k Hk). - eapply csub_ext_wf; [ eapply (ISub_swf L4); exact Hk | exact K5 ]. -Qed. - -Lemma by_snoc_wkn_hd X1 Y1 i1 A1 i2 A2 - : Req_env X1 Y1 -> Req_ty Y1 A1 A2 -> - Req_sub (oExt Y1 i2 A2) (oExt Y1 i2 A2) - (oSnoc (oExt X1 i1 A1) X1 i1 A1 (oWkn X1 i1 A1) (oHd X1 i1 A1)) - (oId (oExt Y1 i2 A2)). -Proof. - intros H1 [E [T [HE [HA1 HA2]]]]. - pose proof (Req_env_transfer (Req_env_sym H1) HE) as HX1. - assert (IEnv (oExt X1 i1 A1) (T :: E)) as HXE - by (econstructor; [ exact HX1 | exact HA1 ]). - assert (IEnv (oExt Y1 i2 A2) (T :: E)) as HYE - by (econstructor; [ exact HE | exact HA2 ]). - destruct T as [ br bl | br bl nc ]. - - eapply Req_sub_mk with (E := rt_U br bl :: E) (E' := rt_U br bl :: E) - (s1 := rsnoc (rc_var 0) rshift) (s2 := rid). - + exact HYE. - + exact HYE. - + eapply isub_snoc_U. - * exact HXE. - * exact HX1. - * econstructor; [ exact HX1 | exact HA1 ]. - * exact HA1. - * econstructor; [ exact HX1 | exact HA1 ]. - + constructor; exact HYE. - + intros [|k] Hk; reflexivity. - - eapply Req_sub_mk with (E := rt_El br bl nc :: E) (E' := rt_El br bl nc :: E) - (s1 := rsnoc rc_nat rshift) (s2 := rid). - + exact HYE. - + exact HYE. - + eapply isub_snoc_El. - * exact HXE. - * exact HX1. - * econstructor; [ exact HX1 | exact HA1 ]. - * exact HA1. - + constructor; exact HYE. - + intros [|k] Hk; [ cbn in Hk; discriminate | reflexivity ]. -Qed. - -Lemma by_ty_subst_id X1 Y1 i1 A1 A2 - : Req_env X1 Y1 -> Req_ty Y1 A1 A2 -> - Req_ty Y1 (oTySubst X1 X1 (oId X1) i1 A1) A2. -Proof. - intros H1 [E [T [HE [HA1 HA2]]]]. - pose proof (Req_env_transfer (Req_env_sym H1) HE) as HX1. - eapply Req_ty_mk with (E := E) (T := T). - - exact HE. - - rewrite <- (tsub_id T) at 1. - econstructor; [ exact HX1 | exact HX1 | constructor; exact HX1 | exact HA1 ]. - - exact HA2. -Qed. - -Lemma by_exp_subst_id X1 Y1 i1 A1 v1 v2 - : Req_env X1 Y1 -> Req_code Y1 v1 v2 -> - Req_code Y1 (oExpSubst X1 X1 (oId X1) i1 A1 v1) v2. -Proof. - intros H1 [E [n [HE [Hv1 Hv2]]]]. - pose proof (Req_env_transfer (Req_env_sym H1) HE) as HX1. - eapply Req_code_mk with (E := E) (n := n). - - exact HE. - - rewrite <- (csub_id n) at 1. - econstructor; [ exact HX1 | exact HX1 | constructor; exact HX1 | exact Hv1 ]. - - exact Hv2. -Qed. - -Lemma by_ty_subst_cmp X1 Y1 X2 Y2 X3 Y3 f1 f2 g1 g2 i1 i2 A1 A2 - : Req_env X1 Y1 -> Req_env X2 Y2 -> Req_env X3 Y3 -> - Req_sub Y1 Y2 f1 f2 -> Req_sub Y2 Y3 g1 g2 -> Req_ty Y3 A1 A2 -> - Req_ty Y1 (oTySubst X1 X2 f1 i1 (oTySubst X2 X3 g1 i1 A1)) - (oTySubst Y1 Y3 (oCmp Y1 Y2 Y3 f2 g2) i2 A2). -Proof. - intros H1 H2 H3 - [E1 [E2 [sf1 [sf2 [K1 [K2 [K3 [K4 K5]]]]]]]] - [E2a [E3 [sg1 [sg2 [L1 [L2 [L3 [L4 L5]]]]]]]] - [E3a [T [HE3 [HA1 HA2]]]]. - pose proof (IEnv_fun L1 K2) as Ha; subst E2a. - pose proof (IEnv_fun L2 HE3) as Hb; subst E3a. - pose proof (Req_env_transfer (Req_env_sym H1) K1) as HX1. - pose proof (Req_env_transfer (Req_env_sym H2) K2) as HX2. - pose proof (Req_env_transfer (Req_env_sym H3) HE3) as HX3. - assert (tsub sf1 (tsub sg1 T) = tsub (rcmp sf2 sg2) T) as Heq. - { assert (tsub sg1 T = tsub sg2 T) as Hg - by (eapply tsub_ext_wf; [ eapply ITy_twf; exact HA1 | exact L5 ]). - rewrite Hg. - assert (tsub sf1 (tsub sg2 T) = tsub sf2 (tsub sg2 T)) as Hf. - { eapply tsub_ext_wf; [ | exact K5 ]. - eapply twf_tsub; [ eapply ISub_swf; exact L4 | eapply ITy_twf; exact HA2 ]. } - rewrite Hf; apply tsub_comp. } - eapply Req_ty_mk with (E := E1) (T := tsub (rcmp sf2 sg2) T). - - exact K1. - - rewrite <- Heq. - econstructor; [ exact HX1 | exact HX2 | exact K3 | ]. - econstructor; [ exact HX2 | exact HX3 | exact L3 | exact HA1 ]. - - econstructor; [ exact K1 | exact HE3 | | exact HA2 ]. - econstructor; [ exact K1 | exact K2 | exact HE3 | exact K4 | exact L4 ]. -Qed. - -Lemma by_exp_subst_cmp X1 Y1 X2 Y2 X3 Y3 f1 f2 g1 g2 i1 i2 A1 A3 A4 v1 v2 - : Req_env X1 Y1 -> Req_env X2 Y2 -> Req_env X3 Y3 -> - Req_sub Y1 Y2 f1 f2 -> Req_sub Y2 Y3 g1 g2 -> Req_code Y3 v1 v2 -> - Req_code Y1 - (oExpSubst X1 X2 f1 i1 A1 (oExpSubst X2 X3 g1 i1 A3 v1)) - (oExpSubst Y1 Y3 (oCmp Y1 Y2 Y3 f2 g2) i2 A4 v2). -Proof. - intros H1 H2 H3 - [E1 [E2 [sf1 [sf2 [K1 [K2 [K3 [K4 K5]]]]]]]] - [E2a [E3 [sg1 [sg2 [L1 [L2 [L3 [L4 L5]]]]]]]] - [E3a [n [HE3 [Hv1 Hv2]]]]. - pose proof (IEnv_fun L1 K2) as Ha; subst E2a. - pose proof (IEnv_fun L2 HE3) as Hb; subst E3a. - pose proof (Req_env_transfer (Req_env_sym H1) K1) as HX1. - pose proof (Req_env_transfer (Req_env_sym H2) K2) as HX2. - pose proof (Req_env_transfer (Req_env_sym H3) HE3) as HX3. - assert (csub sf1 (csub sg1 n) = csub (rcmp sf2 sg2) n) as Heq. - { assert (csub sg1 n = csub sg2 n) as Hg - by (eapply csub_ext_wf; [ eapply ICode_cwf; exact Hv1 | exact L5 ]). - rewrite Hg. - assert (csub sf1 (csub sg2 n) = csub sf2 (csub sg2 n)) as Hf. - { eapply csub_ext_wf; [ | exact K5 ]. - eapply cwf_csub; [ eapply ISub_swf; exact L4 | eapply ICode_cwf; exact Hv2 ]. } - rewrite Hf; apply csub_comp. } - eapply Req_code_mk with (E := E1) (n := csub (rcmp sf2 sg2) n). - - exact K1. - - rewrite <- Heq. - econstructor; [ exact HX1 | exact HX2 | exact K3 | ]. - econstructor; [ exact HX2 | exact HX3 | exact L3 | exact Hv1 ]. - - econstructor; [ exact K1 | exact HE3 | | exact Hv2 ]. - econstructor; [ exact K1 | exact K2 | exact HE3 | exact K4 | exact L4 ]. -Qed. - -Lemma by_U_subst X1 Y1 X2 Y2 g1 g2 i1 r1 r2 l1 l2 - : Req_env X1 Y1 -> Req_env X2 Y2 -> Req_sub Y1 Y2 g1 g2 -> - (exists b, ErRel r1 b /\ ErRel r2 b) -> - (exists b, ErLvl l1 b /\ ErLvl l2 b) -> - Req_ty Y1 (oTySubst X1 X2 g1 i1 (oU X2 r1 l1)) (oU Y1 r2 l2). -Proof. - intros H1 H2 [E [E2 [s1 [s2 [K1 [K2 [K3 [K4 K5]]]]]]]] - [br [Hr1 Hr2]] [bl [Hl1 Hl2]]. - pose proof (Req_env_transfer (Req_env_sym H1) K1) as HX1. - pose proof (Req_env_transfer (Req_env_sym H2) K2) as HX2. - eapply Req_ty_mk with (E := E) (T := rt_U br bl). - - exact K1. - - change (rt_U br bl) with (tsub s1 (rt_U br bl)). - econstructor; [ exact HX1 | exact HX2 | exact K3 | ]. - econstructor; [ exact HX2 | exact Hr1 | exact Hl1 ]. - - econstructor; [ exact K1 | exact Hr2 | exact Hl2 ]. -Qed. - -Lemma by_El_subst X1 Y1 X2 Y2 g1 g2 i1 i3 r1 r2 l1 l2 c1 c2 - : Req_env X1 Y1 -> Req_env X2 Y2 -> Req_sub Y1 Y2 g1 g2 -> - (exists b, ErRel r1 b /\ ErRel r2 b) -> - (exists b, ErLvl l1 b /\ ErLvl l2 b) -> - Req_code Y2 c1 c2 -> - Req_ty Y1 (oTySubst X1 X2 g1 i1 (oEl X2 r1 l1 c1)) - (oEl Y1 r2 l2 (oExpSubst Y1 Y2 g2 i3 (oU Y2 r2 l2) c2)). -Proof. - intros H1 H2 [E [E2 [s1 [s2 [K1 [K2 [K3 [K4 K5]]]]]]]] - [br [Hr1 Hr2]] [bl [Hl1 Hl2]] [E2a [n [HE2 [Hc1 Hc2]]]]. - pose proof (IEnv_fun HE2 K2) as Ha; subst E2a. - pose proof (Req_env_transfer (Req_env_sym H1) K1) as HX1. - pose proof (Req_env_transfer (Req_env_sym H2) K2) as HX2. - assert (csub s1 n = csub s2 n) as Heq - by (eapply csub_ext_wf; [ eapply ICode_cwf; exact Hc1 | exact K5 ]). - eapply Req_ty_mk with (E := E) (T := rt_El br bl (csub s2 n)). - - exact K1. - - rewrite <- Heq. - change (rt_El br bl (csub s1 n)) with (tsub s1 (rt_El br bl n)). - econstructor; [ exact HX1 | exact HX2 | exact K3 | ]. - econstructor; [ exact HX2 | exact Hr1 | exact Hl1 | exact Hc1 ]. - - econstructor; [ exact K1 | exact Hr2 | exact Hl2 | ]. - econstructor; [ exact K1 | exact K2 | exact K4 | exact Hc2 ]. -Qed. - -Lemma by_Nat_subst X1 Y1 X2 Y2 g1 g2 i1 A1 - : Req_env X1 Y1 -> Req_env X2 Y2 -> Req_sub Y1 Y2 g1 g2 -> - Req_code Y1 (oExpSubst X1 X2 g1 i1 A1 (oNat X2)) (oNat Y1). -Proof. - intros H1 H2 [E [E2 [s1 [s2 [K1 [K2 [K3 [K4 K5]]]]]]]]. - pose proof (Req_env_transfer (Req_env_sym H1) K1) as HX1. - pose proof (Req_env_transfer (Req_env_sym H2) K2) as HX2. - eapply Req_code_mk with (E := E) (n := rc_nat). - - exact K1. - - change rc_nat with (csub s1 rc_nat). - econstructor; [ exact HX1 | exact HX2 | exact K3 | ]. - econstructor; exact HX2. - - econstructor; exact K1. -Qed. - -Lemma by_Empty_subst X1 Y1 X2 Y2 g1 g2 i1 A1 - : Req_env X1 Y1 -> Req_env X2 Y2 -> Req_sub Y1 Y2 g1 g2 -> - Req_code Y1 (oExpSubst X1 X2 g1 i1 A1 (oEmpty X2)) (oEmpty Y1). -Proof. - intros H1 H2 [E [E2 [s1 [s2 [K1 [K2 [K3 [K4 K5]]]]]]]]. - pose proof (Req_env_transfer (Req_env_sym H1) K1) as HX1. - pose proof (Req_env_transfer (Req_env_sym H2) K2) as HX2. - eapply Req_code_mk with (E := E) (n := rc_empty). - - exact K1. - - change rc_empty with (csub s1 rc_empty). - econstructor; [ exact HX1 | exact HX2 | exact K3 | ]. - econstructor; exact HX2. - - econstructor; exact K1. -Qed. - -(* The two [Pi] commutations. These are the only obligations in which the - theory's own lifting ([oLift]) has to be matched against [csub]'s [up]: - they differ exactly at the head slot, which is an [El] slot, hence - invisible to [subeq]. *) -Lemma by_Pi_irr_subst X1 Y1 X2 Y2 g1 g2 rF1 rF2 lF1 lF2 F1 F2 B1 B2 i1 A1 i3 A3 - : Req_env X1 Y1 -> Req_env X2 Y2 -> Req_sub Y1 Y2 g1 g2 -> - (exists b, ErRel rF1 b /\ ErRel rF2 b) -> - (exists b, ErLvl lF1 b /\ ErLvl lF2 b) -> - Req_code Y2 F1 F2 -> Req_code (oExtC Y2 rF2 lF2 F2) B1 B2 -> - Req_code Y1 - (oExpSubst X1 X2 g1 i1 A1 (oPiIrr X2 rF1 lF1 F1 B1)) - (oPiIrr Y1 rF2 lF2 (oCodeSub Y1 Y2 g2 rF2 lF2 F2) - (oExpSubst (oExtC Y1 rF2 lF2 (oCodeSub Y1 Y2 g2 rF2 lF2 F2)) - (oExtC Y2 rF2 lF2 F2) (oLift Y1 Y2 g2 rF2 lF2 F2) i3 A3 B2)). -Proof. - intros H1 H2 [E [E2 [s1 [s2 [K1 [K2 [K3 [K4 K5]]]]]]]] - [br [Hr1 Hr2]] [bl [Hl1 Hl2]] [E2a [nF [HE2 [HF1 HF2]]]] - [EB [nB [HEB [HB1 HB2]]]]. - pose proof (IEnv_fun HE2 K2) as Ha; subst E2a. - assert (IEnv (oExtC Y2 rF2 lF2 F2) (rt_El br bl nF :: E2)) as HX - by (eapply IEnv_extC; [ exact K2 | exact Hr2 | exact Hl2 | exact HF2 ]). - pose proof (IEnv_fun HEB HX) as Hb; subst EB. - pose proof (Req_env_transfer (Req_env_sym H1) K1) as HX1. - pose proof (Req_env_transfer (Req_env_sym H2) K2) as HX2. - assert (ICode E (oCodeSub Y1 Y2 g2 rF2 lF2 F2) (csub s2 nF)) as HFg - by (unfold oCodeSub; econstructor; - [ exact K1 | exact K2 | exact K4 | exact HF2 ]). - pose proof (ISub_oLift K1 K2 K4 Hr2 Hl2 HF2 HFg) as HL. - assert (IEnv (oExtC Y1 rF2 lF2 (oCodeSub Y1 Y2 g2 rF2 lF2 F2)) - (rt_El br bl (csub s2 nF) :: E)) as HEF - by (eapply IEnv_extC; [ exact K1 | exact Hr2 | exact Hl2 | exact HFg ]). - assert (csub (up s1) nB = csub (rsnoc rc_nat (rcmp rshift s2)) nB) as HeqB - by (eapply csub_ext_wf; - [ eapply ICode_cwf; exact HB1 | apply subeq_lift; exact K5 ]). - assert (csub s1 nF = csub s2 nF) as HeqF - by (eapply csub_ext_wf; [ eapply ICode_cwf; exact HF1 | exact K5 ]). - eapply Req_code_mk with (E := E) - (n := rc_pi false br bl (csub s2 nF) - (csub (rsnoc rc_nat (rcmp rshift s2)) nB)). - - exact K1. - - rewrite <- HeqB, <- HeqF. - change (rc_pi false br bl (csub s1 nF) (csub (up s1) nB)) - with (csub s1 (rc_pi false br bl nF nB)). - econstructor; [ exact HX1 | exact HX2 | exact K3 | ]. - econstructor; - [ exact HX2 | exact Hr1 | exact Hl1 | exact HF1 | exact HB1 ]. - - econstructor; [ exact K1 | exact Hr2 | exact Hl2 | exact HFg | ]. - econstructor; [ exact HEF | exact HX | exact HL | exact HB2 ]. -Qed. - -Lemma by_Pi_rel_subst X1 Y1 X2 Y2 g1 g2 rF1 rF2 lF1 lF2 lG1 lG2 - F1 F2 B1 B2 i1 A1 i3 A3 - : Req_env X1 Y1 -> Req_env X2 Y2 -> Req_sub Y1 Y2 g1 g2 -> - (exists b, ErRel rF1 b /\ ErRel rF2 b) -> - (exists b, ErLvl lF1 b /\ ErLvl lF2 b) -> - Req_code Y2 F1 F2 -> Req_code (oExtC Y2 rF2 lF2 F2) B1 B2 -> - Req_code Y1 - (oExpSubst X1 X2 g1 i1 A1 (oPiRel X2 rF1 lF1 lG1 F1 B1)) - (oPiRel Y1 rF2 lF2 lG2 (oCodeSub Y1 Y2 g2 rF2 lF2 F2) - (oExpSubst (oExtC Y1 rF2 lF2 (oCodeSub Y1 Y2 g2 rF2 lF2 F2)) - (oExtC Y2 rF2 lF2 F2) (oLift Y1 Y2 g2 rF2 lF2 F2) i3 A3 B2)). -Proof. - intros H1 H2 [E [E2 [s1 [s2 [K1 [K2 [K3 [K4 K5]]]]]]]] - [br [Hr1 Hr2]] [bl [Hl1 Hl2]] [E2a [nF [HE2 [HF1 HF2]]]] - [EB [nB [HEB [HB1 HB2]]]]. - pose proof (IEnv_fun HE2 K2) as Ha; subst E2a. - assert (IEnv (oExtC Y2 rF2 lF2 F2) (rt_El br bl nF :: E2)) as HX - by (eapply IEnv_extC; [ exact K2 | exact Hr2 | exact Hl2 | exact HF2 ]). - pose proof (IEnv_fun HEB HX) as Hb; subst EB. - pose proof (Req_env_transfer (Req_env_sym H1) K1) as HX1. - pose proof (Req_env_transfer (Req_env_sym H2) K2) as HX2. - assert (ICode E (oCodeSub Y1 Y2 g2 rF2 lF2 F2) (csub s2 nF)) as HFg - by (unfold oCodeSub; econstructor; - [ exact K1 | exact K2 | exact K4 | exact HF2 ]). - pose proof (ISub_oLift K1 K2 K4 Hr2 Hl2 HF2 HFg) as HL. - assert (IEnv (oExtC Y1 rF2 lF2 (oCodeSub Y1 Y2 g2 rF2 lF2 F2)) - (rt_El br bl (csub s2 nF) :: E)) as HEF - by (eapply IEnv_extC; [ exact K1 | exact Hr2 | exact Hl2 | exact HFg ]). - assert (csub (up s1) nB = csub (rsnoc rc_nat (rcmp rshift s2)) nB) as HeqB - by (eapply csub_ext_wf; - [ eapply ICode_cwf; exact HB1 | apply subeq_lift; exact K5 ]). - assert (csub s1 nF = csub s2 nF) as HeqF - by (eapply csub_ext_wf; [ eapply ICode_cwf; exact HF1 | exact K5 ]). - eapply Req_code_mk with (E := E) - (n := rc_pi true br bl (csub s2 nF) - (csub (rsnoc rc_nat (rcmp rshift s2)) nB)). - - exact K1. - - rewrite <- HeqB, <- HeqF. - change (rc_pi true br bl (csub s1 nF) (csub (up s1) nB)) - with (csub s1 (rc_pi true br bl nF nB)). - econstructor; [ exact HX1 | exact HX2 | exact K3 | ]. - econstructor; - [ exact HX2 | exact Hr1 | exact Hl1 | exact HF1 | exact HB1 ]. - - econstructor; [ exact K1 | exact Hr2 | exact Hl2 | exact HFg | ]. - econstructor; [ exact HEF | exact HX | exact HL | exact HB2 ]. -Qed. - -Ltac use_any := - solve [ apply rceq_env_e; eassumption - | apply rceq_sub_e; eassumption - | eapply rceq_ty_e; eassumption - | apply rceq_rel_e; eassumption - | apply rceq_lvl_e; eassumption - | eapply rceq_exp_e'; [ eassumption | reflexivity ] ]. - -Lemma by_obligation - : forall c' name e1 e2 t s1 s2, - In (name, term_eq_rule c' e1 e2 t) ott_dtt -> - ceq_args (CM := RigCM) c' s1 s2 -> - rceq_term t[/with_names_from c' s2/] - e1[/with_names_from c' s1/] e2[/with_names_from c' s2/]. -Proof. - intros c' name e1 e2 t s1 s2 Hin Hargs. - decomp; try exact I. - - (* Pi_irr subst *) - apply rceq_exp_i; intros _; eapply by_Pi_irr_subst; use_any. - - (* Pi_rel subst *) - apply rceq_exp_i; intros _; eapply by_Pi_rel_subst; use_any. - - (* Empty subst *) - apply rceq_exp_i; intros _; eapply by_Empty_subst; use_any. - - (* Nat subst *) - apply rceq_exp_i; intros _; eapply by_Nat_subst; use_any. - - (* El subst *) - apply rceq_ty_i; eapply by_El_subst; use_any. - - (* U subst *) - apply rceq_ty_i; eapply by_U_subst; use_any. - - (* snoc_wkn_hd *) - apply rceq_sub_i; eapply by_snoc_wkn_hd; use_any. - - (* cmp_snoc *) - apply rceq_sub_i; eapply by_cmp_snoc; - solve [ use_any - | (intro Hu; eapply rceq_exp_e'; [ eassumption | exact Hu ]) ]. - - (* snoc_hd *) - apply rceq_exp_i; intro Hu; eapply by_snoc_hd; - solve [ use_any - | eapply rceq_exp_e'; [ eassumption | exact Hu ] - | exact Hu ]. - - (* wkn_snoc *) - apply rceq_sub_i; eapply by_wkn_snoc; - solve [ use_any - | (intro Hu; eapply rceq_exp_e'; [ eassumption | exact Hu ]) ]. - - (* id_emp_forget *) - apply rceq_sub_i; eapply by_id_emp_forget. - - (* cmp_forget *) - apply rceq_sub_i; eapply by_cmp_forget; use_any. - - (* exp_subst_cmp *) - apply rceq_exp_i; intro Hu; eapply by_exp_subst_cmp; - solve [ use_any | eapply rceq_exp_e'; [ eassumption | exact Hu ] ]. - - (* exp_subst_id *) - apply rceq_exp_i; intro Hu; eapply by_exp_subst_id; - solve [ use_any | eapply rceq_exp_e'; [ eassumption | exact Hu ] ]. - - (* ty_subst_cmp *) - apply rceq_ty_i; eapply by_ty_subst_cmp; use_any. - - (* ty_subst_id *) - apply rceq_ty_i; eapply by_ty_subst_id; use_any. - - (* cmp_assoc *) - apply rceq_sub_i; eapply by_cmp_assoc; use_any. - - (* id_left *) - apply rceq_sub_i; eapply by_id_left; use_any. - - (* id_right *) - apply rceq_sub_i; eapply by_id_right; use_any. - - (* next1 *) apply rceq_tlvl_i; reflexivity. - - (* next0 *) apply rceq_tlvl_i; reflexivity. -Qed. diff --git a/src/Pyrosome/Gluing/Dtt/RigidOk.v b/src/Pyrosome/Gluing/Dtt/RigidOk.v deleted file mode 100644 index 1139a0a1..00000000 --- a/src/Pyrosome/Gluing/Dtt/RigidOk.v +++ /dev/null @@ -1,94 +0,0 @@ -Set Implicit Arguments. - -From coqutil Require Import Datatypes.String. -From Stdlib Require Import Lists.List. -Import ListNotations. -Open Scope string. -Open Scope list. -From Utils Require Import Utils. -From Pyrosome Require Import Theory.Core. -From Pyrosome.Gluing Require Import CutTModel Eval CutModelSound. -Require Import Pyrosome.Gluing.Dtt.Syntax Pyrosome.Gluing.Dtt.NormalForms Pyrosome.Gluing.Dtt.Rigid. -Import Core.Notations. - -(* ===================================================================== - LAYER 0.5b, PART 2: the rigid model is a model, and what that buys. - - src/Pyrosome/Gluing/Dtt/Rigid.v discharges all ten [CutTModel_ok] obligations for - [RigCM] separately. This file assembles them and runs the fundamental - theorem (Gluing/CutModelSound.v), yielding the ONE fact the rigidity - argument needs from the semantic side: - - provably equal terms have equal rigid interpretations. - - Everything downstream of Layer 0.5 consumes only [rigid_sound] and its - four sort-specific corollaries. - ===================================================================== *) - -(* ------------------------------------------------------------------ *) -(* The model is a model *) -(* ------------------------------------------------------------------ *) - -(* Built with [constructor] and ten [exact]s rather than a [{| ... |}] - record literal: elaborating the literal against [CutTModel_ok] - stack-overflows (~44s, then death), while this is instant. The same - trick is needed for the main model's assembly. *) -#[export] Instance RigCM_ok : CutTModel_ok ott_dtt [] (CM := RigCM). -Proof. - constructor. - - exact var_obligation. - - exact cong_obligation. - - exact by_obligation. - - exact term_trans_obligation. - - exact term_sym_obligation. - - exact term_conv_obligation. - - exact sort_cong_obligation. - - exact sort_by_obligation. - - exact sort_trans_obligation. - - exact sort_sym_obligation. -Defined. - -(* ------------------------------------------------------------------ *) -(* The fundamental theorem, specialized *) -(* ------------------------------------------------------------------ *) - -(* [rceq_term] is [Prop]-valued (it is accepted as a [Type]-valued carrier - by cumulativity), so the [inhabited] that CutModelSound hands back is - erasable here. *) -Theorem rigid_sound t e1 e2 - : eq_term ott_dtt [] t e1 e2 -> rceq_term t e1 e2. -Proof. - intro Heq. - destruct (cut_model_inhabited (l := ott_dtt) ott_dtt_wf (c := []) - wf_ctx_nil (CM := RigCM) Heq) as [H]. - exact H. -Qed. - -(* ------------------------------------------------------------------ *) -(* The four readings *) -(* ------------------------------------------------------------------ *) - -Corollary rigid_env G1 G2 - : eq_term ott_dtt [] sEnv G1 G2 -> Req_env G1 G2. -Proof. apply rigid_sound. Qed. - -Corollary rigid_ty G i A1 A2 - : eq_term ott_dtt [] (sTy G i) A1 A2 -> Req_ty G A1 A2. -Proof. apply rigid_sound. Qed. - -Corollary rigid_sub G G' g1 g2 - : eq_term ott_dtt [] (sSub G G') g1 g2 -> Req_sub G G' g1 g2. -Proof. apply rigid_sound. Qed. - -(* At an [exp] sort the model only says anything when the type is - universe-like -- which is exactly the code fragment, and exactly what - rigidity is about. *) -Corollary rigid_code G r l c1 c2 - : eq_term ott_dtt [] (sCode G r l) c1 c2 -> Req_code G c1 c2. -Proof. - intro Heq. - pose proof (rigid_sound Heq) as H. - unfold sCode in H. - rewrite rceq_exp_eq, USkel_U in H. - exact H. -Qed. diff --git a/src/Pyrosome/Gluing/Dtt/Rz.v b/src/Pyrosome/Gluing/Dtt/Rz.v new file mode 100644 index 00000000..e56bb25d --- /dev/null +++ b/src/Pyrosome/Gluing/Dtt/Rz.v @@ -0,0 +1,268 @@ +Set Implicit Arguments. + +From coqutil Require Import Datatypes.String. +From Stdlib Require Import Lists.List. +Import ListNotations. +Open Scope string. +Open Scope list. +From Utils Require Import Utils. +From Pyrosome Require Import Theory.Core. +Require Import Pyrosome.Gluing.Dtt.Syntax Pyrosome.Gluing.Dtt.Wf + Pyrosome.Gluing.Dtt.Eqns Pyrosome.Gluing.Dtt.Values. +Import Core.Notations. + +(* ===================================================================== + Rz: REALIZATION, AND THE TEST THAT THE *-ERASURE IS SOUND. + + Soundness of the value layer cannot be [eqt e v]: [*] is not a term of + [ott_dtt] and has no sort (design.md section 14d). It becomes a + realization relation [Rz G i A v e] -- "the value [v] realizes the term + [e]" -- and the fact the endgame turns on is + + Rz_eqt : Rz G i A v e1 -> Rz G i A v e2 -> eqt (sExp G i A) e1 e2 + + "two terms with the same value are provably equal". That is where + proof irrelevance is spent, and it is the CHEAPEST REFUTATION of the + whole [*] design: if it fails, the erasure is wrong. It needs neither + [Nrm] nor the weakening layer, so it is proved here, first. + + IT GOES THROUGH. [Rz_eqt] below is [Qed], axiom-free. + + WHY THIS IS NOT A LOCAL CONCERN (design.md section 14e). [*] is + reachable from a CODE by a chain of entirely well-typed steps: a code + can be an [Id], [Id]'s endpoints are relevant ELEMENTS, a relevant + element can be an [Emptyrec] or an [app_rel] at an irrelevant domain, + and both carry [*]. Section 14a's counterexample is one instance. + [rz_id] is in the block below precisely so that this chain is exercised + and not assumed away. + + SCOPE, stated honestly. Every TYPE argument is held fixed between the + value and the term: [rz_emptyrec] varies only the erased argument, and + [rz_id] only the two endpoints. That is not a hidden assumption about + the theory, it is a restriction on which pairs this relation relates, + and it is what keeps the relation single-sorted -- letting a type + argument vary makes the conclusion's SORT vary with it, which needs a + realization relation on types as well. [app_rel] is left out of the + block for exactly that reason (its conclusion sort mentions its + argument), and is covered instead by the standalone + [app_rel_star_eqt] below. Both erasable positions of (E2) are + therefore discharged; what is deferred is only their propagation + through varying type indices. + ===================================================================== *) + +Local Notation wft := (wf_term ott_dtt []). +Local Notation eqt := (eq_term ott_dtt []). + +Ltac er := solve [ apply eq_term_refl; wfa ]. + +(* [wf_IdEq], [IdEq_cong], [eq_Id_subst] and the [Id-Nat-*] family were + written here first and have MOVED UPSTREAM into Wf.v and Eqns.v, where + they belong -- both files predated the Id fragment and mentioned + [oIdEq] nowhere. See the [ott_id_cong] section at the end of Eqns.v, + in particular its note that the fragment's index spellings are NOT + uniform. + + The [next0] BRIDGE stays here, because it cannot go upstream: it needs + a [wf_] lemma AND a congruence, and Wf.v and Eqns.v are siblings over + Syntax.v with neither importing the other. This file is currently the + first that imports both. *) + +Lemma wft_c0 G c + : wft G sEnv -> + wft c (sExp G (oInfo oRel (oIota oL1)) (oU G oIrr oL0)) -> + wft c (sCode G oIrr oL0). +Proof. + intros HG Hc; eapply wf_term_conv; [ exact Hc | ]. + unfold sCode, iCode; apply sExp_cong. + - apply eq_term_refl; exact HG. + - apply Info_cong; [ apply Rel_cong | apply eq_term_sym; apply eq_next0 ]. + - apply eq_term_refl; apply wf_U; auto using wf_Irr, wf_L0. +Qed. + +(* [Wf.wf_IdEq] in the [sCode] spelling. *) +Lemma wf_IdEq_c G l A B t u + : wft G sEnv -> wft l sLvl -> + wft A (sCode G oRel l) -> wft B (sCode G oRel l) -> + wft t (sElt G oRel l A) -> wft u (sElt G oRel l B) -> + wft (oIdEq G l A B t u) (sCode G oIrr oL0). +Proof. intros; apply wft_c0; [ assumption | apply wf_IdEq; assumption ]. Qed. + +(* ================================================================== *) +(* The two erasable positions of (E2), discharged directly *) +(* ================================================================== *) + +(* POSITION 2, and this is design.md section 14a VERBATIM: the two + [Emptyrec]s it exhibits -- distinct terms, both normal at the same + RELEVANT type -- are provably equal. Under the old [NfET] they were a + counterexample to injectivity; under the [*]-collapse they have the + same value, and this lemma is why that is sound. *) +Theorem emptyrec_star_eqt G rA lA A e1 e2 + : wft G sEnv -> wft rA sRelevance -> wft lA sLvl -> + wft A (sCode G rA lA) -> + wft e1 (sElt G oIrr oL0 (oEmpty G)) -> + wft e2 (sElt G oIrr oL0 (oEmpty G)) -> + eqt (sElt G rA lA A) (oEmptyrec G rA lA A e1) (oEmptyrec G rA lA A e2). +Proof. + intros HG HrA HlA HA He1 He2. + apply Emptyrec_cong; try er. + apply eq_proof_irr; auto using wf_L0. + apply wft_c0; [ exact HG | apply wf_Empty; exact HG ]. +Qed. + +(* POSITION 1: two [app_rel]s at an IRRELEVANT domain differing only in + the argument. Kept out of the [Rz] block because its conclusion SORT + mentions the argument. *) +Theorem app_rel_star_eqt G lF lG F B f a1 a2 + : wft G sEnv -> wft lF sLvl -> wft lG sLvl -> + wft F (sCode G oIrr lF) -> + wft B (sCode (oExtC G oIrr lF F) oRel lG) -> + wft f (sElt G oRel lG (oPiRel G oIrr lF lG F B)) -> + wft a1 (sElt G oIrr lF F) -> wft a2 (sElt G oIrr lF F) -> + eqt (sAppRelConcl G oIrr lF lG F B a2) + (oAppRel G oIrr lF lG F B f a1) (oAppRel G oIrr lF lG F B f a2). +Proof. + intros HG HlF HlG HF HB Hf Ha1 Ha2. + apply AppRel_cong; try er. + apply eq_proof_irr; assumption. +Qed. + +(* ================================================================== *) +(* The relation *) +(* ================================================================== *) + +(* CONVERSION-FREE BY DESIGN. A [rz_conv] clause inside the inductive + would appear on BOTH sides of [Rz_eqt], and the case where the first + derivation is a leaf and the second a conversion has no induction + hypothesis to appeal to -- the recursion there is on the SECOND + derivation. Taking the conversion closure afterwards ([RzE] below) + makes [Rz_eqt] a plain induction on the first derivation with + [inversion] on the second, and [RzE_eqt] three lines of transitivity. + + Every clause carries the well-typedness of its TERM side, which is + what [rz_star] needs of the OTHER derivation ([Rz_wf]) in order to + spend proof irrelevance. *) +Inductive Rz : term -> term -> term -> term -> term -> Prop := +(* The whole irrelevant fragment: [*] realizes EVERY well-typed term at + an irrelevant [El]. Its only premise is well-typedness, because that + is all "proof irrelevance" asks for. *) +| rz_star : forall G l c e, + wft G sEnv -> wft l sLvl -> wft c (sCode G oIrr l) -> + wft e (sElt G oIrr l c) -> + Rz G (iEl oIrr l) (oEl G oIrr l c) oStar e +(* ---- leaves ---- *) +| rz_nat : forall G, + wft G sEnv -> Rz G (iCode oL0) (oU G oRel oL0) (oNat G) (oNat G) +| rz_empty : forall G, + wft G sEnv -> + Rz G (iEl oRel oL1) (oU G oIrr oL0) (oEmpty G) (oEmpty G) +| rz_zero : forall G, + wft G sEnv -> + Rz G (iEl oRel oL0) (oEl G oRel oL0 (oNat G)) (oZero G) (oZero G) +(* ---- propagation ---- *) +| rz_suc : forall G n ne, + wft G sEnv -> + wft (oSuc G ne) (sElt G oRel oL0 (oNat G)) -> + Rz G (iEl oRel oL0) (oEl G oRel oL0 (oNat G)) n ne -> + Rz G (iEl oRel oL0) (oEl G oRel oL0 (oNat G)) (oSuc G n) (oSuc G ne) +(* ERASABLE POSITION 2 *) +| rz_emptyrec : forall G rA lA A e, + wft G sEnv -> wft rA sRelevance -> wft lA sLvl -> + wft A (sCode G rA lA) -> + wft e (sElt G oIrr oL0 (oEmpty G)) -> + Rz G (iEl rA lA) (oEl G rA lA A) + (oEmptyrec G rA lA A oStar) (oEmptyrec G rA lA A e) +(* THE CHAIN OF SECTION 14e: a CODE whose element subterms may contain + [*]. Without this clause the whole point would be assumed away. *) +| rz_id : forall G l A B t u te ue, + wft G sEnv -> wft l sLvl -> + wft A (sCode G oRel l) -> wft B (sCode G oRel l) -> + wft te (sElt G oRel l A) -> wft ue (sElt G oRel l B) -> + Rz G (iEl oRel l) (oEl G oRel l A) t te -> + Rz G (iEl oRel l) (oEl G oRel l B) u ue -> + Rz G (iEl oRel oL1) (oU G oIrr oL0) + (oIdEq G l A B t u) (oIdEq G l A B te ue). + +(* Each clause carries it, so this is a case analysis. *) +Lemma Rz_wf G i A v e : Rz G i A v e -> wft e (sExp G i A). +Proof. + destruct 1. + - assumption. + - apply wf_Nat; assumption. + - apply wf_Empty; assumption. + - apply wf_Zero; assumption. + - assumption. + - apply wf_Emptyrec; assumption. + - apply wf_IdEq; assumption. +Qed. + +(* ================================================================== *) +(* THE TEST *) +(* ================================================================== *) + +Theorem Rz_eqt G i A v e1 e2 + : Rz G i A v e1 -> Rz G i A v e2 -> eqt (sExp G i A) e1 e2. +Proof. + intros H1; revert e2; + induction H1 as + [ G l c e HG Hl Hc He + | G HG + | G HG + | G HG + | G n ne HG Hne Hn IHn + | G rA lA A e HG HrA HlA HA He + | G l A B t u te ue HG Hl HA HB Hte Hue Ht IHt Hu IHu ]; + intros eR HR. + (* ---- [*]: PROOF IRRELEVANCE IS SPENT HERE, and nowhere else. *) + - apply eq_proof_irr; try assumption. + exact (Rz_wf HR). + (* ---- leaves: only the clause with the same value head can fire ---- *) + - inversion HR; subst; er. + - inversion HR; subst; er. + - inversion HR; subst; er. + (* ---- suc ---- *) + - inversion HR; subst. + apply Suc_cong; [ er | ]. + apply IHn; assumption. + (* ---- Emptyrec: erasable position 2 ---- *) + - inversion HR; subst. + apply emptyrec_star_eqt; assumption. + (* ---- Id: the section-14e chain ---- *) + - inversion HR; subst. + apply IdEq_cong; try er. + + apply IHt; assumption. + + apply IHu; assumption. +Qed. + +(* ================================================================== *) +(* The conversion closure -- what the layer above actually uses *) +(* ================================================================== *) + +(* [RzE G i A v e] : [v] realizes SOME term provably equal to [e]. This + is the form that is stable under the theory's equations, which is what + the 28 sigma-equations need. *) +Definition RzE (G i A v e : term) : Prop := + exists e0, Rz G i A v e0 /\ eqt (sExp G i A) e e0. + +Lemma RzE_intro G i A v e : Rz G i A v e -> RzE G i A v e. +Proof. + intro H; exists e; split; + [ exact H | apply eq_term_refl; exact (Rz_wf H) ]. +Qed. + +Lemma RzE_conv G i A v e e' + : RzE G i A v e -> eqt (sExp G i A) e' e -> RzE G i A v e'. +Proof. + intros [e0 [H Heq]] Heq'; exists e0; split; + [ exact H | eapply eq_term_trans; eassumption ]. +Qed. + +(* [Rz_eqt] survives the closure, which is the statement the endgame + consumes. *) +Theorem RzE_eqt G i A v e1 e2 + : RzE G i A v e1 -> RzE G i A v e2 -> eqt (sExp G i A) e1 e2. +Proof. + intros [n1 [H1 Hq1]] [n2 [H2 Hq2]]. + eapply eq_term_trans; [ exact Hq1 | ]. + eapply eq_term_trans; [ exact (Rz_eqt H1 H2) | ]. + apply eq_term_sym; exact Hq2. +Qed. diff --git a/src/Pyrosome/Gluing/Dtt/Syntax.v b/src/Pyrosome/Gluing/Dtt/Syntax.v index d397ea24..78f4cb26 100644 --- a/src/Pyrosome/Gluing/Dtt/Syntax.v +++ b/src/Pyrosome/Gluing/Dtt/Syntax.v @@ -7,9 +7,9 @@ Open Scope string. Open Scope list. From Utils Require Import Utils. From Pyrosome Require Import Theory.Core Tools.ComputeWf Tools.Matches - Tools.EGraph.ComputeWf. + Tools.Resolution Tools.EGraph.ComputeWf. From Pyrosome.Lang Require Import Subst. -From Pyrosome.Lang.OTT Require Import Base Nat Pi SubstCommute ProofIrr. +From Pyrosome.Lang.OTT Require Import Base Nat Pi SubstCommute ProofIrr IdCore IdCong. Import Core.Notations. (* ===================================================================== @@ -79,11 +79,34 @@ Notation lang := (@Rule.lang string). (* The language *) (* ------------------------------------------------------------------ *) +(* [ott_id_cong] is PREPENDED, and that is forced, not cosmetic: [infer_rule] + re-extracts every rule's conclusion sort with [TypeInference.mk_weight], + whose tie-breaks depend on the AMBIENT language (see the "next0" spelling + discussion in design.md section 9b). Inserting the Id fragment anywhere it + would be in scope while an earlier fragment elaborates can silently flip an + existing rule between [next L0] and [iota L1], which invalidates the shapes + baked into Eqns.v / Wf.v / Model*.v. Adding it at the front leaves every + pre-existing rule byte-identical. *) Definition ott_dtt : lang := Eval vm_compute in - (ott_proofirr_el ++ ott_subst_commute ++ ott_pi ++ ott_nat ++ ott_base ++ subst_ott ++ ott_info). - + (ott_id_cong ++ ott_proofirr_el ++ ott_subst_commute ++ ott_pi ++ ott_nat ++ ott_base + ++ subst_ott ++ ott_info). + +(* COMPOSITIONAL, not [compute_wf_lang]. Re-running the e-graph wf checker + over the whole language costs time proportional to (number of rules) x + (cost of checking a rule against its prefix), and the Id fragment makes + the second factor much worse: adding a function-extensionality rule to a + rule's prefix was measured at a >3.5x blowup on the very next check. + Every fragment already carries its own [wf_lang_ext] lemma, so there is + nothing to recompute -- [prove_by_lang_db] assembles them from the + [wf_lang_db] hints in about a second. The [replace] is what lets it see + [ott_dtt] (a [vm_compute]d flat list) as the concatenation the hints are + stated about. *) Lemma ott_dtt_wf : wf_lang ott_dtt. -Proof. compute_wf_lang. Qed. +Proof. + replace ott_dtt with (ott_id_cong ++ ott_id_base) + by (vm_compute; reflexivity). + prove_by_lang_db. +Qed. (* ------------------------------------------------------------------ *) (* Sorts *) @@ -154,6 +177,27 @@ Definition oAppRel (G rF lF lG F B f a : term) : term := Definition oAppIrr (G rF lF F B f a : term) : term := con "app_irr" [a; f; B; F; lF; rF; G]. +(* --- ott_id_cong --- *) +(* [Id G l A B t u] : the heterogeneous equality of [t : El A] and [u : El B], + for RELEVANT codes A,B of the common level [l]. It is a code at + [U G irr L0], and -- like [Empty] and [Pi_irr], and unlike [Nat] -- it is + elaborated at the info [iEl oRel oL1] rather than the [iCode oL0] the rule + was written with; the two are equal by "next0". + + NOTE the name: [oId] is already taken, by the identity SUBSTITUTION + [con "id" [G]] of subst_ott. The object-language constructor here is + [con "Id" ...] -- a different string -- so only the Gallina abbreviation + needs to differ. *) +Definition oIdEq (G l A B t u : term) : term := con "Id" [u; t; B; A; l; G]. + +(* [Idcong G l lB A B b t u e] : the congruence of the one-hole context [b] + along [e : Id A A t u]. The ONLY proof former of the fragment (it + generalizes reflexivity), and it carries no equations at all -- proof + irrelevance proves every one, including its substitution commutation. + See design.md section 12. *) +Definition oIdcong (G l lB A B b t u e : term) : term := + con "Idcong" [e; u; t; b; B; lB; A; l; G]. + (* ------------------------------------------------------------------ *) (* Derived abbreviations that recur in the rules' conclusion sorts *) (* ------------------------------------------------------------------ *) @@ -178,6 +222,12 @@ Definition oExtC (G rF lF F : term) : term := Definition oInst (G rF lF F a : term) : term := oSnoc G G (iEl rF lF) (oEl G rF lF F) (oId G) a. +(* The unit proposition: what "Id-Nat-00" reduces to, and the only closed + inhabited code at [U _ irr L0]. Written out because the Id computation + table names it. *) +Definition oUnit (G : term) : term := + oPiIrr G oIrr oL0 (oEmpty G) (oEmpty (oExtC G oIrr oL0 (oEmpty G))). + (* [app_rel]'s conclusion sort, verbatim from the compiled rule (with the argument [a] left abstract). *) Definition sAppRelConcl (G rF lF lG F B a : term) : sort := diff --git a/src/Pyrosome/Gluing/Dtt/Values.v b/src/Pyrosome/Gluing/Dtt/Values.v new file mode 100644 index 00000000..06c9838c --- /dev/null +++ b/src/Pyrosome/Gluing/Dtt/Values.v @@ -0,0 +1,536 @@ +Set Implicit Arguments. + +From coqutil Require Import Datatypes.String. +From Stdlib Require Import Lists.List. +Import ListNotations. +Open Scope string. +Open Scope list. +From Utils Require Import Utils. +From Pyrosome Require Import Theory.Core. +(* [Require EXPORT]: [oStar] and the weakening relation live in WkRel.v + (see the note there on why the dependency runs this way), and everything + downstream of Values.v wants both. *) +Require Import Pyrosome.Gluing.Dtt.Syntax. +Require Export Pyrosome.Gluing.Dtt.WkRel. +Import Core.Notations. + +(* ===================================================================== + DTT NORMALIZATION, LAYER 1 (REVISED): *-COLLAPSED VALUES. + + This file replaces the judgements of src/Pyrosome/Gluing/Dtt/NormalForms.v + ([EnvOk]/[TyOk]/[NfCode]/[NeCode]/[VarT]/[NeET]/[NfET]) with the value + predicates of design.md sections 13 and 14. Two things change, and both are + forced by the Id fragment: + + (1) THE IRRELEVANT FRAGMENT HAS ONE VALUE, [*]. Reification is + type-directed and every type class is justified by one equation of + [ott_dtt]: [Pi_rel] by "Pi_rel eta", and EVERY irrelevant type by + "proof irrelevance", which reifies to the single token [oStar]. + Proof irrelevance is the eta rule of the irrelevant fragment. + REDUCTION never dispatches on relevance; only reification does, + exactly as it already dispatches on [Nat] vs [Pi_rel]. + + This is what makes [Val_inj] (provably-equal *-collapsed values are + syntactically equal) TRUE where [NfET_inj] was FALSE: design.md + section 14a exhibits two distinct [Emptyrec]s over provably-equal + irrelevant arguments, both [NfET] at the same relevant type. Here + both are the SAME term, [Emptyrec G rA lA A *]. + + (2) NAMED REPRESENTATIVES BECOME COMPUTED ONES. Where NormalForms.v wrote + + ... -> TyOk (oExt G i A) i A' -> eqt ... A' -> VarT (oExt G i A) i A' ... + + i.e. "A' is SOME normal type provably equal to A[wkn]", this file + writes the COMPUTED representative [wkTy G i A A]. Likewise + [neet_app_rel]'s named [C] becomes [oEl G oRel lG (instC ...)]. + That is design.md section 4b's declined alternative, now mandatory: + with an [eq_term]-named representative the judgements are not + functional, and Layer 0.5 -- which used to supply uniqueness of the + naming -- is refutable once [Id] is in the language (section 12e). + + [wkTy] and [instC] are SECTION PARAMETERS here. Their definitions are + the subject of the weakening/instantiation layer; see the T3 note at + the end of this file and WIP-scratch WkVal for the state of play. + Nothing in this file depends on how they are defined -- only the + clauses that name a representative mention them, and they mention them + only in an index position. + + THE GRAMMAR (design.md section 14b): + + Vcode ::= var | Nat | Empty | Pi_rel rF lF lG Vcode Vcode + | Pi_irr rF lF Vcode Vcode + | Id l Vcode Vcode Vel Vel (STUCK only) + Vty ::= U D r l | El D r l Vcode + Vel ::= (at El _ irr _) * + | (at El _ rel L0 Nat) zero | suc Vel | Vne + | (at El _ rel lG Pi_rel) lam_rel ... Vel + | (at El _ rel l Vcode-neutral) Vne + Vne ::= var | app_rel rF lF lG Vcode Vcode Vne Vel + | Emptyrec rA lA Vcode * + + Relative to NormalForms.v: [nfet_ne_empty], [nfet_lam_irr], + [neet_app_irr] and [neet_idcong] are GONE (all subsumed by [*] -- an + [Idcong] is a proof, and the value of a proof is [*]), and with them + [oIdcongTy]; one clause [val_irr] replaces them all. The five [NeCode] + clauses are kept verbatim, with [NfET] premises becoming [Val] premises: + they are the complete stuck-analysis for [Id] (design.md section 12b) and + they are correct. + ===================================================================== *) + +Local Notation eqt := (eq_term ott_dtt []). + +Section WithReps. + + (* THE [wkTy] PARAMETER IS GONE. It named the value form of a weakened + type, and a variable's type is always a weakened one; it is now the + relation [WkRel.WkTy], whose determinism ([WkRel.Wk_det]) is what makes + the naming functional. That is decision (a) of WkVal.v's trailer, + discharged: relation plus determinism, not a Gallina [Fixpoint], which + the guard checker refuses on this syntax. + + [instC] survives, and is the last parameter. It is the value form of + [B[]], for [B] a value code at level [lG] over [oExtC G rF lF F] + and [a] a value at [El G rF lF F]; it is used ONLY as the type index of + an [app_rel] neutral. It retires the same way [wkTy] just did, into + the instantiation relation, once that block exists. *) + Context (instC : term -> term -> term -> term -> term -> term -> term -> term). + +(* ------------------------------------------------------------------ *) +(* The mutual block *) +(* ------------------------------------------------------------------ *) + +Inductive ValEnv : term -> Prop := +| valenv_emp : ValEnv oEmp +| valenv_ext : forall G i A, ValEnv G -> ValTy G i A -> ValEnv (oExt G i A) + +(* [ValTy G i A] : [A] is a value type of sort [ty G i]. The info index is + determined by the type: [iCode l] for a universe, [iEl r l] for an [El]. + Infos are NOT normalized here (the language is not uniform about which + side of "next0" it lands on -- [Nat] elaborates at [info rel (next L0)] + but [Empty] at [info rel (iota L1)]), so each canonical form is pinned to + the info its own former uses. *) +with ValTy : term -> term -> term -> Prop := +| valty_U : forall G r l, + ValEnv G -> RelNf r -> LvlNf l -> ValTy G (iCode l) (oU G r l) +| valty_El : forall G r l c, + ValCode G r l c -> ValTy G (iEl r l) (oEl G r l c) + +(* [ValCode G r l c] : [c] is a value code, i.e. a value at [U G r l]. + Codes are NOT collapsed even at [r = irr]: [U G irr l] is the type of + irrelevant CODES, and it is not itself proof-irrelevant -- proof + irrelevance is an [El]-sorted rule. This is what keeps [ValCode_inj] + meaningful, and it is why the [Id] fragment (whose codes contain relevant + ELEMENTS) forces the element layer to be injective too. *) +with ValCode : term -> term -> term -> term -> Prop := +| valcode_nat : forall G, + ValEnv G -> ValCode G oRel oL0 (oNat G) +| valcode_empty : forall G, + ValEnv G -> ValCode G oIrr oL0 (oEmpty G) +| valcode_pi_rel : forall G rF lF lG F B, + RelNf rF -> LvlNf lF -> LvlNf lG -> + ValCode G rF lF F -> + ValCode (oExtC G rF lF F) oRel lG B -> + ValCode G oRel lG (oPiRel G rF lF lG F B) +| valcode_pi_irr : forall G rF lF F B, + RelNf rF -> LvlNf lF -> + ValCode G rF lF F -> + ValCode (oExtC G rF lF F) oIrr oL0 B -> + ValCode G oIrr oL0 (oPiIrr G rF lF F B) +| valcode_ne : forall G r l c, + NeCode G r l c -> ValCode G r l c + +(* [NeCode G r l c] : a code no computation rule of [ott_dtt] can reduce. + Before the Id fragment this was exactly "a variable"; [Id] adds a second + way for a code to be stuck. + + These five clauses are the complete stuck analysis of design.md section + 12b, KEPT VERBATIM from NormalForms.v (only the element premises change, + from [NfET] to [Val]). An [Id] reduces as soon as both of its codes are + canonical: distinct heads clash to [Empty], two [Pi_rel]s go to funext or + (on mismatched domain indices) to [Empty], and two [Nat]s dispatch on the + endpoints. So it is stuck exactly when a CODE is neutral, or when both + codes are [Nat] and an ENDPOINT is neutral. + + Note the indices: [Id] lands at [irr, L0] while its two code arguments are + RELEVANT, and the only neutral code at a relevant index is a variable -- + so [necode_id_l]/[necode_id_r] do not recurse into further [Id]s. *) +with NeCode : term -> term -> term -> term -> Prop := +| necode_var : forall G r l c, + ValVar G (iCode l) (oU G r l) c -> NeCode G r l c +| necode_id_l : forall G l A B t u, + NeCode G oRel l A -> ValCode G oRel l B -> + Val G (iEl oRel l) (oEl G oRel l A) t -> + Val G (iEl oRel l) (oEl G oRel l B) u -> + NeCode G oIrr oL0 (oIdEq G l A B t u) +| necode_id_r : forall G l A B t u, + ValCode G oRel l A -> NeCode G oRel l B -> + Val G (iEl oRel l) (oEl G oRel l A) t -> + Val G (iEl oRel l) (oEl G oRel l B) u -> + NeCode G oIrr oL0 (oIdEq G l A B t u) +| necode_id_nat_l : forall G t u, + ValNe G (iEl oRel oL0) (oEl G oRel oL0 (oNat G)) t -> + Val G (iEl oRel oL0) (oEl G oRel oL0 (oNat G)) u -> + NeCode G oIrr oL0 (oIdEq G oL0 (oNat G) (oNat G) t u) +| necode_id_nat_r : forall G t u, + Val G (iEl oRel oL0) (oEl G oRel oL0 (oNat G)) t -> + ValNe G (iEl oRel oL0) (oEl G oRel oL0 (oNat G)) u -> + NeCode G oIrr oL0 (oIdEq G oL0 (oNat G) (oNat G) t u) + +(* [ValVar G i A x] : [x] is an object-level variable of the value type [A]. + The meta-context is empty, so object-level variables are [hd] and its + [wkn]-shifts. + + THE FUNCTIONAL POINT. NormalForms.v's [vart_hd]/[vart_wkn] took the + representative [A'] as an EXTRA ARGUMENT pinned by an [eq_term] premise + -- "SOME normal type provably equal to [A[wkn]]". Here it is pinned by + [WkRel.WkTy], which is DETERMINISTIC ([WkRel.Wk_det]), so [A'] is THE + weakening and not merely one of them. The distinction is the whole of + design.md section 13's turn to functional content. + + Note also that the type ANNOTATION carried by the term itself is exactly + the premise's index [A], so the term is determined by [x] and the binding + alone -- no choice is made anywhere. + + These two clauses are [WkRel.VarTy]'s two clauses plus the value-hood + side conditions; [ValVar_VarTy] below is the erasure. *) +with ValVar : term -> term -> term -> term -> Prop := +| valvar_hd : forall G i A A', + ValEnv G -> ValTy G i A -> + WkTy (oExt G i A) G (oWkn G i A) i A A' -> + ValVar (oExt G i A) i A' (oHd G i A) +| valvar_wkn : forall G i A x j B A', + ValVar G i A x -> ValTy G j B -> + WkTy (oExt G j B) G (oWkn G j B) i A A' -> + ValVar (oExt G j B) i A' + (oExpSubst (oExt G j B) G (oWkn G j B) i A x) + +(* [ValNe G i A e] : [e] is neutral at the value type [A]. No conversion + clause: the representative of an eliminator's result type is COMPUTED at + the construction site. + + The two clauses that used to exist for the irrelevant fragment + ([neet_app_irr], [neet_idcong]) are gone: both conclude at an irrelevant + [El], where the only value is [*]. + + The erasable positions of design.md section 14c (E2) are visible here and + nowhere else. (E2) says that the ONLY irrelevant-typed subterms sitting in + relevant positions are [app_rel]'s [a] when [rF = irr], and [Emptyrec]'s + [e]; this was checked mechanically over the compiled language, Id fragment + included. The first is handled by [valne_app_rel]'s premise + [Val G (iEl rF lF) ... a], which at [rF = oIrr] forces [a = oStar] by + [val_irr] (see [Val_irr_star] below). The second is handled by writing + [oStar] LITERALLY in [valne_emptyrec]. *) +with ValNe : term -> term -> term -> term -> Prop := +| valne_var : forall G i A x, + ValVar G i A x -> ValNe G i A x +| valne_app_rel : forall G rF lF lG F B f a, + ValCode G rF lF F -> + ValCode (oExtC G rF lF F) oRel lG B -> + ValNe G (iEl oRel lG) (oEl G oRel lG (oPiRel G rF lF lG F B)) f -> + Val G (iEl rF lF) (oEl G rF lF F) a -> + ValNe G (iEl oRel lG) (oEl G oRel lG (instC G rF lF F a lG B)) + (oAppRel G rF lF lG F B f a) +| valne_emptyrec : forall G rA lA A, + ValCode G rA lA A -> + ValNe G (iEl rA lA) (oEl G rA lA A) (oEmptyrec G rA lA A oStar) + +(* [Val G i A v] : [v] is the value of type [A]. Dispatched by [A]'s head, + exhaustively over [ValTy]: + + A = U G r l -> a value code + A = El G irr l c, ANY c -> * <-- proof irr + A = El G rel L0 (Nat G) -> zero | suc | neutral + A = El G rel lG (Pi_rel ...) -> lam_rel ONLY <-- eta + A = El G rel l c, c neutral -> neutral + + [Empty] and [Pi_irr] no longer appear: they are irrelevant codes, so they + are covered -- with [Id] and every irrelevant neutral -- by the single + clause [val_irr]. That is (E1) (design.md section 14c), proved as + [ValCode_irr_shape] below. *) +with Val : term -> term -> term -> term -> Prop := +| val_code : forall G r l c, + ValCode G r l c -> Val G (iCode l) (oU G r l) c +| val_irr : forall G l c, + ValCode G oIrr l c -> Val G (iEl oIrr l) (oEl G oIrr l c) oStar +| val_zero : forall G, + ValEnv G -> Val G (iEl oRel oL0) (oEl G oRel oL0 (oNat G)) (oZero G) +| val_suc : forall G n, + Val G (iEl oRel oL0) (oEl G oRel oL0 (oNat G)) n -> + Val G (iEl oRel oL0) (oEl G oRel oL0 (oNat G)) (oSuc G n) +| val_ne_nat : forall G e, + ValNe G (iEl oRel oL0) (oEl G oRel oL0 (oNat G)) e -> + Val G (iEl oRel oL0) (oEl G oRel oL0 (oNat G)) e +| val_ne : forall G l c e, + NeCode G oRel l c -> + ValNe G (iEl oRel l) (oEl G oRel l c) e -> + Val G (iEl oRel l) (oEl G oRel l c) e +| val_lam_rel : forall G rF lF lG F B t, + RelNf rF -> LvlNf lF -> LvlNf lG -> + ValCode G rF lF F -> + ValCode (oExtC G rF lF F) oRel lG B -> + Val (oExtC G rF lF F) (iEl oRel lG) (oEl (oExtC G rF lF F) oRel lG B) t -> + Val G (iEl oRel lG) (oEl G oRel lG (oPiRel G rF lF lG F B)) + (oLamRel G rF lF lG F B t). + +Scheme ValEnv_min := Minimality for ValEnv Sort Prop + with ValTy_min := Minimality for ValTy Sort Prop + with ValCode_min := Minimality for ValCode Sort Prop + with NeCode_min := Minimality for NeCode Sort Prop + with ValVar_min := Minimality for ValVar Sort Prop + with ValNe_min := Minimality for ValNe Sort Prop + with Val_min := Minimality for Val Sort Prop. + +Combined Scheme Val_mutind from + ValEnv_min, ValTy_min, ValCode_min, NeCode_min, ValVar_min, ValNe_min, + Val_min. + +(* ------------------------------------------------------------------ *) +(* (E1) and the *-collapse *) +(* ------------------------------------------------------------------ *) + +(* (E1), design.md section 14c: [El G irr l c] covers exactly [Empty], + [Pi_irr], [Id] and irrelevant neutral codes -- [Nat] and [Pi_rel] being + the only relevant canonical codes. [Id] and the irrelevant variables are + the two [NeCode] cases, so the disjunction has three arms. *) +Lemma ValCode_irr_shape G l c + : ValCode G oIrr l c -> + (l = oL0 /\ c = oEmpty G) + \/ (exists rF lF F B, l = oL0 /\ c = oPiIrr G rF lF F B) + \/ NeCode G oIrr l c. +Proof. + (* [inversion] discharges [valcode_nat] and [valcode_pi_rel] itself: + their relevance index is [oRel = con "rel" []], and [oIrr] is a + different [con], so the two are separated by [discriminate]. *) + inversion 1; subst; eauto 10. +Qed. + +(* The *-collapse itself: at an irrelevant [El] there is exactly one value, + and it is [*]. This is the whole content of design.md section 14b, and it + is what makes [Val_inj] provable where [NfET_inj] was false. *) +Lemma Val_irr_star G l c v + : Val G (iEl oIrr l) (oEl G oIrr l c) v -> v = oStar. +Proof. + inversion 1; subst; try reflexivity; exfalso; discriminate. +Qed. + +(* The converse: [*] IS a value at every irrelevant [El] of a value code. + Together with [Val_irr_star] this says the irrelevant fragment's value set + is the singleton [{*}]. *) +Lemma Val_irr_intro G l c + : ValCode G oIrr l c -> Val G (iEl oIrr l) (oEl G oIrr l c) oStar. +Proof. apply val_irr. Qed. + +(* (E2) in the form the value layer uses it: an [app_rel] at an IRRELEVANT + domain has [*] as its argument. (E2) proper -- "the only irrelevant-typed + subterms in relevant positions are [app_rel]'s [a] and [Emptyrec]'s [e]" -- + is a statement about the compiled language, not about these judgements; it + was checked mechanically (design.md section 14c) and is what licenses the + grammar above. What is left to check here is that the grammar really does + collapse both positions, and it does: [Emptyrec]'s argument is the literal + [oStar] of [valne_emptyrec], and [app_rel]'s is this lemma. *) +Lemma ValNe_app_rel_irr_arg G lF lG F B f a + : ValNe G (iEl oRel lG) (oEl G oRel lG (instC G oIrr lF F a lG B)) + (oAppRel G oIrr lF lG F B f a) -> + ValCode G oIrr lF F -> + a = oStar. +Proof. + intros H HF; inversion H; subst; + (* [valne_emptyrec] is discharged by [inversion] itself; what is left is + [valne_var] (a variable is not an [app_rel]) and the real case. *) + [ exfalso; match goal with Hv : ValVar _ _ _ _ |- _ => inversion Hv end + | eapply Val_irr_star; eassumption ]. +Qed. + +(* ------------------------------------------------------------------ *) +(* Syntactic shape lemmas *) +(* *) +(* RESCUED from src/Pyrosome/Gluing/Dtt/Inj.v (which is deleted with the *) +(* rest of Layer 0.5, design.md section 12e). [VarT_shape] was the only *) +(* lemma in that file with no dependence on the rigid model; the rest is *) +(* stated over [ICode]/[ITy]/[IEnv] and goes with them. *) +(* ------------------------------------------------------------------ *) + +(* The subject of a [ValVar] is an [oHd] or a [wkn]-substituted variable. + (Inj.v:216, [VarT_shape], transposed to [ValVar].) *) +Lemma ValVar_shape G i A x : ValVar G i A x -> + (exists G0 i0 A0, x = oHd G0 i0 A0) + \/ (exists G0 j B i0 A0 y, + x = oExpSubst (oExt G0 j B) G0 (oWkn G0 j B) i0 A0 y). +Proof. destruct 1; [ left | right ]; eauto 10. Qed. + +(* A value variable is a variable, forgetting value-hood. This is the + bridge that lets the weakening layer's [VarTy]-indexed facts be used on + [ValVar]-indexed ones. *) +Lemma ValVar_VarTy G i A x : ValVar G i A x -> VarTy G i A x. +Proof. + induction 1; + [ eapply varty_hd; eassumption | eapply varty_wkn; eassumption ]. +Qed. + +(* Hence a value variable's type is determined by its context and itself -- + [WkRel.Wk_det]'s fourth conjunct, transported. *) +Lemma ValVar_type_unique G i1 A1 i2 A2 x + : ValVar G i1 A1 x -> ValVar G i2 A2 x -> i1 = i2 /\ A1 = A2. +Proof. + intros H1 H2; + exact (VarTy_det (ValVar_VarTy H1) (ValVar_VarTy H2)). +Qed. + +(* The same, one level up: a [ValNe] is a variable, an [app_rel] or an + [Emptyrec]. (The [NeET_shape]-like helper the old development never + needed, because [NeET] had four more clauses.) *) +Lemma ValNe_shape G i A e : ValNe G i A e -> + (exists G0 i0 A0, e = oHd G0 i0 A0) + \/ (exists G0 j B i0 A0 y, + e = oExpSubst (oExt G0 j B) G0 (oWkn G0 j B) i0 A0 y) + \/ (exists G0 rF lF lG F B f a, e = oAppRel G0 rF lF lG F B f a) + \/ (exists G0 rA lA A0, e = oEmptyrec G0 rA lA A0 oStar). +Proof. + destruct 1. + - destruct (ValVar_shape H) as [ H0 | H0 ]; [ left | right; left ]; exact H0. + - right; right; left; eauto 10. + - right; right; right; eauto 10. +Qed. + +(* A neutral code is a variable or a stuck [Id]. *) +Lemma NeCode_shape G r l c : NeCode G r l c -> + ValVar G (iCode l) (oU G r l) c + \/ (exists l0 A B t u, c = oIdEq G l0 A B t u). +Proof. destruct 1; [ left | right .. ]; eauto 10. Qed. + +(* ------------------------------------------------------------------ *) +(* CASE-COMPLETENESS FOR THE Id COMPUTATION TABLE (design.md 12b) *) +(* *) +(* The table has a dozen clauses and is the part of the development *) +(* most likely to contain a transcription error -- and an omitted case *) +(* there does not fail to typecheck, it fails much later as a stuck *) +(* determinism proof. These four lemmas are the table's case analysis, *) +(* stated over HEAD SYMBOLS and proved once, so that writing the table *) +(* against them turns an omission into a missing case rather than a *) +(* silent gap. *) +(* *) +(* Together they say the analysis is 3 x 3 in the codes (Nat, Pi_rel, *) +(* neutral) and, at Nat, 3 x 3 in the endpoints (zero, suc, neutral). *) +(* DISJOINTNESS is then immediate and needs no lemma: the shapes are *) +(* pairwise distinct [con] heads. *) +(* ------------------------------------------------------------------ *) + +(* The head analysis of a neutral code. [NeCode_shape] leaves a [ValVar], + which is not yet a head; this pushes through to one. *) +Lemma NeCode_head G r l c : NeCode G r l c -> + (exists G0 i0 A0, c = oHd G0 i0 A0) + \/ (exists G0 j B i0 A0 y, + c = oExpSubst (oExt G0 j B) G0 (oWkn G0 j B) i0 A0 y) + \/ (exists G0 l0 A B t u, c = oIdEq G0 l0 A B t u). +Proof. + intro H; destruct (NeCode_shape H) as [ Hv | Hid ]. + - destruct (ValVar_shape Hv) as [ H0 | H0 ]; [ left | right; left ]; exact H0. + - right; right; destruct Hid as [l0 [A [B [t [u ->]]]]]; eauto 10. +Qed. + +(* Hence a neutral code is never a canonical one. This is what refutes + the [val_ne] case in the two shape lemmas below, and it is the only + place the argument is not a bare [discriminate]. *) +Lemma NeCode_not_nat G r l : NeCode G r l (oNat G) -> False. +Proof. + intro H; destruct (NeCode_head H) as [ [?[?[? Hc]]] + | [ [?[?[?[?[?[? Hc]]]]]] + | [?[?[?[?[?[? Hc]]]]]] ] ]; + discriminate Hc. +Qed. + +Lemma NeCode_not_pi_rel G r l rF lF lG F B + : NeCode G r l (oPiRel G rF lF lG F B) -> False. +Proof. + intro H; destruct (NeCode_head H) as [ [?[?[? Hc]]] + | [ [?[?[?[?[?[? Hc]]]]]] + | [?[?[?[?[?[? Hc]]]]]] ] ]; + discriminate Hc. +Qed. + +(* (1) THE RELEVANT CANONICAL CODES ARE EXACTLY [Nat] AND [Pi_rel]. + This is what bounds the table's outer analysis at 3 x 3, and it is the + dual of [ValCode_irr_shape] above. *) +Lemma ValCode_rel_shape G l c + : ValCode G oRel l c -> + (l = oL0 /\ c = oNat G) + \/ (exists rF lF F B, c = oPiRel G rF lF l F B) + \/ NeCode G oRel l c. +Proof. inversion 1; subst; eauto 10. Qed. + +(* (2) THE VALUES AT [Nat] ARE EXACTLY [zero], [suc] AND THE NEUTRALS. + This bounds the inner analysis, the one the [Id-Nat-*] rules dispatch + on. *) +Lemma Val_nat_shape G v + : Val G (iEl oRel oL0) (oEl G oRel oL0 (oNat G)) v -> + v = oZero G + \/ (exists n, v = oSuc G n + /\ Val G (iEl oRel oL0) (oEl G oRel oL0 (oNat G)) n) + \/ ValNe G (iEl oRel oL0) (oEl G oRel oL0 (oNat G)) v. +Proof. + (* the [val_ne] case is ABSORBED by the neutral disjunct rather than + refuted -- a neutral at [Nat] is exactly the third alternative. + [NeCode_not_nat] is kept anyway: it is half of the table's + disjointness, and the [Pi_rel] lemma below genuinely needs its twin. *) + inversion 1; subst; eauto 10; + exfalso; eapply NeCode_not_nat; eassumption. +Qed. + +(* (3) AT A [Pi_rel] TYPE THE ONLY VALUE IS A [lam_rel] -- eta. The + funext clause of the table needs this to know that its two endpoints + are lambdas and not neutrals. *) +Lemma Val_pi_rel_shape G rF lF lG F B v + : Val G (iEl oRel lG) (oEl G oRel lG (oPiRel G rF lF lG F B)) v -> + exists t, v = oLamRel G rF lF lG F B t + /\ Val (oExtC G rF lF F) (iEl oRel lG) + (oEl (oExtC G rF lF F) oRel lG B) t. +Proof. + (* [val_ne] must be REFUTED here, not absorbed: at a [Pi_rel] type eta + leaves no neutral alternative for it to land in. *) + inversion 1; subst; eauto 10; + exfalso; eapply NeCode_not_pi_rel; eassumption. +Qed. + +End WithReps. + +(* ===================================================================== + WHAT IS LEFT PARAMETRIC, AND WHY. + + [instC] is the last parameter. It is needed only as the type index of + [valne_app_rel]: an application's result type is [B[]], and the + value layer must name THE instantiation. + + IT DOES NOT RETIRE THE WAY [wkTy] JUST DID, and the difference is not + one of degree. WEAKENING NEVER CREATES A REDEX -- it only shifts -- so + WkRel.v is purely structural, which is why it was cheap. + INSTANTIATION SUBSTITUTES A VALUE FOR A VARIABLE, and a value in a + neutral's head position turns that neutral into a redex. So the + instantiation relation must EVALUATE, and it is therefore not a sibling + of the weakening relation but a fragment of the normalizer itself. + + Where exactly, in this grammar. Substituting the element [a] into a + value CODE [B] over [oExtC G rF lF F] is structural at [Nat], [Empty], + [Pi_rel], [Pi_irr] and at code VARIABLES -- a code variable's type is a + universe, and the de Bruijn-0 variable of [oExtC G rF lF F] has type + [El _ rF lF F[wkn]], which is an [El], so a code variable is NEVER the + one being substituted and always merely strips. Likewise an [Id] stuck + on a neutral CODE stays stuck, for the same reason. The one place it + breaks is [necode_id_nat_l]/[_r]: there the stuck endpoint is an + ELEMENT at [El _ rel L0 (Nat _)], it CAN be the de Bruijn-0 variable + (when [F] is [Nat]), and substituting [zero] or [suc n] for it fires + "Id-Nat-00"/"-0S"/"-SS". Symmetrically, an endpoint [app_rel … f a] + whose head [f] is the 0-variable becomes a beta-redex when a [lam_rel] + is substituted. + + This is design.md section 14d confirmed from the substitution side, and + it is exactly what the Id fragment costs: NfWk.v:3139's [NfCode_csubst] + -- "the code grammar is a free algebra closed under substitution + STRUCTURALLY", NormalForms.v:66 -- was true only because pre-Id codes + contain no elements. + + So the instantiation block needs the semantic operations as well as the + substitution ones: an application judgement (beta) and an Id judgement + (the whole section-12b computation table). Estimated at five or six + mutual judgements, i.e. the factorization survives; the growth is in + CLAUSES, not in judgements. + ===================================================================== *) diff --git a/src/Pyrosome/Gluing/Dtt/Wf.v b/src/Pyrosome/Gluing/Dtt/Wf.v index 0c4bf8c4..07e7fda0 100644 --- a/src/Pyrosome/Gluing/Dtt/Wf.v +++ b/src/Pyrosome/Gluing/Dtt/Wf.v @@ -354,6 +354,34 @@ Lemma wf_AppIrr G rF lF F B f a wft (oAppIrr G rF lF F B f a) (sAppIrrConcl G rF lF F B a). Proof. intros; wf_by "app_irr". Qed. +(* ------------------------------------------------------------------ *) +(* ott_id_cong *) +(* ------------------------------------------------------------------ *) + +(* TRAP, the same one as [Empty] and [Pi_irr] above: [Id] is a code for an + IRRELEVANT L0 type, but the elaborator left its info as + [rel (iota L1)], NOT as [iCode L0 = rel (next L0)]. So this conclusion + is deliberately NOT written as [sCode G oIrr oL0]; [Eqns.wf_IdEq_c] is + the [next0]-converted form, and it is the one later layers want. *) +Lemma wf_IdEq G l A B t u + : wft G sEnv -> + wft l sLvl -> + wft A (sCode G oRel l) -> + wft B (sCode G oRel l) -> + wft t (sElt G oRel l A) -> + wft u (sElt G oRel l B) -> + wft (oIdEq G l A B t u) (sExp G (iEl oRel oL1) (oU G oIrr oL0)). +Proof. intros; wf_by "Id". Qed. + +(* [wf_Idcong] is deliberately ABSENT. Its conclusion sort is the [Id] + between the two instantiations of the congruence's body, and the + spelling the elaborator stored for it has not been pinned down (the + obvious reading, [oIdcongTy] as NormalForms.v writes it, does not + unify). Nothing needs it yet: under the *-collapse an [Idcong] is a + proof, so its value is [*] and the value layer never inspects it + (design.md section 14b supersedes 12d on exactly this point). Pin it + when something first asks. *) + (* ------------------------------------------------------------------ *) (* Sort inversion *) (* ------------------------------------------------------------------ *) @@ -455,6 +483,7 @@ Proof. intro H; apply wf_sort_ltl_inv; eapply wft_wf_sort; exact H. Qed. wf_U wf_El wf_Nat wf_Zero wf_Suc wf_Empty wf_Emptyrec wf_PiRel wf_PiIrr wf_LamRel wf_LamIrr wf_AppRel wf_AppIrr + wf_IdEq : dtt_wf. (* The sort-formation rules, so that [wf_sort] goals are discharged too. diff --git a/src/Pyrosome/Gluing/Dtt/WkRel.v b/src/Pyrosome/Gluing/Dtt/WkRel.v new file mode 100644 index 00000000..dee8ab9a --- /dev/null +++ b/src/Pyrosome/Gluing/Dtt/WkRel.v @@ -0,0 +1,309 @@ +Set Implicit Arguments. + +From coqutil Require Import Datatypes.String. +From Stdlib Require Import Lists.List. +Import ListNotations. +Open Scope string. +Open Scope list. +From Utils Require Import Utils. +From Pyrosome Require Import Theory.Core. +Require Import Pyrosome.Gluing.Dtt.Syntax. +Import Core.Notations. + +(* ===================================================================== + WEAKENING OF VALUES, AS A DETERMINISTIC MUTUAL RELATION. + + T3 established that weakening cannot be a Gallina [Fixpoint] on the + annotated syntax: the recursion on the weakening [w] and the recursion + on the subject call each other and neither argument decreases + (WkVal.v's header quotes the guard checker). The decreasing structure + is the DERIVATION, so this file recurses on derivations natively -- + design.md section 13b's own notion of "functional", where determinism + (its property (D)) is a THEOREM rather than a definitional accident. + + THE FACTORIZATION THAT MAKES THIS SMALL. The obvious reading of + "relational" is one enormous block containing the value judgements AND + their weakening (13 inductives, ~56 clauses), because [Values.v]'s + [valvar_hd] needs the weakened type as its index. That is not + necessary. The weakening relation NEVER MENTIONS THE VALUE + JUDGEMENTS -- it is syntax-directed on [w] and on the subject -- so it + is a self-contained block that can be defined FIRST and used by + [Values.v] as a premise. Three judgements suffice: + + WkTy D G w i A A' types + WkTm D G w e e' codes AND elements, in ONE judgement + WkVar D G w i A A' x x' variables + + [WkTm] needs no type index: every annotation a weakened code or + element carries is already stored in the subject. Only VARIABLES + introduce a new annotation -- the type of the inner variable in the + smaller context -- which is why they, and only they, are typed. + That observation is what collapses 13 inductives to 3. + + CODES AND ELEMENTS SHARE ONE JUDGEMENT because their head symbols are + pairwise distinct ([Nat]/[Empty]/[Pi_rel]/[Pi_irr]/[Id] against + [zero]/[suc]/[*]/[lam_rel]/[app_rel]/[Emptyrec]/[hd]/[exp_subst]), so + nothing is lost and determinism becomes a head-symbol argument. This + is also what makes the code/element mutual recursion that design.md + section 14d calls "the real structural cost of [Id]" completely + painless: [wktm_id] weakens an [Id]'s two codes and its two ELEMENT + endpoints with the same relation, in one clause. + + The *-collapse is what keeps the element half short: there is no + [lam_irr], no [app_irr] and no [Idcong] clause, because those all live + at irrelevant [El]s where the only value is [*], and [*] weakens to + [*] ([wktm_star]). + ===================================================================== *) + +(* ------------------------------------------------------------------ *) +(* The one value of the irrelevant fragment *) +(* *) +(* [oStar] LIVES HERE, not in Values.v, because the dependency runs the *) +(* other way: [Values.v]'s variable clauses need [WkTy] to name the *) +(* weakened type of a variable, so Values.v imports this file. Both *) +(* files need [*] -- this one for [wktm_star] and [wktm_emptyrec] -- so *) +(* it is defined at the bottom of the stack and re-exported upward. *) +(* ------------------------------------------------------------------ *) + +(* [*] is DELIBERATELY NOT A FORMER OF [ott_dtt]. It is not a term of the + object theory at all, and it must not be: if it were, [Val_inj] would + have to distinguish it from the terms it collapses. The consequence is + that soundness of the value layer cannot be [eqt e v] -- [*] has no + sort -- and becomes the realization relation [Rz] of Rz.v, whose + [rz_star] clause discharges it by proof irrelevance. *) +Definition oStar : term := con "*" []. + +Lemma oStar_not_a_former nm args : oStar = con nm args -> nm = "*" /\ args = []. +Proof. unfold oStar; intro H; injection H; auto. Qed. + +(* The lifted weakening, verbatim from NfWk.v:141. (WkVal.v has its own + copy; this file deliberately does not depend on WkVal.v, which drags in + Wf.v and Eqns.v for its equational hypotheses.) *) +Definition oLiftW (D G w i A A' : term) : term := + oSnoc (oExt D i A') G i A (oCmp (oExt D i A') D G (oWkn D i A') w) + (oHd D i A'). + +(* ================================================================== *) +(* The block *) +(* ================================================================== *) + +(* A FOURTH judgement, [VarTy], is forced, and finding out why was the + informative part of writing this file. The first draft had a purely + syntactic [IsVar] side condition on the two clauses that dispatch on + [w] alone, and left the variable's type [A] otherwise unconstrained. + Determinism of [WkTm] is then FALSE: [wkvar_wkn] emits + [exp_subst wkn i A x], whose annotation is [A], so the output depends + on a type the relation never pinned down. [VarTy G i A x] -- "[x] is a + variable whose value type in [G] is [A]" -- pins it, and it is exactly + [Values.v]'s [ValVar] minus the value-hood side conditions, which is + where [Values.v]'s [wkTy] parameter goes when this is wired up. *) + +Inductive WkTy : term -> term -> term -> term -> term -> term -> Prop := +| wkty_U : forall D G w r l, + WkTy D G w (iCode l) (oU G r l) (oU D r l) +| wkty_El : forall D G w r l c c', + WkTm D G w c c' -> + WkTy D G w (iEl r l) (oEl G r l c) (oEl D r l c') + +with WkTm : term -> term -> term -> term -> term -> Prop := +(* ---- codes ---- *) +| wktm_nat : forall D G w, WkTm D G w (oNat G) (oNat D) +| wktm_empty : forall D G w, WkTm D G w (oEmpty G) (oEmpty D) +| wktm_pi_rel : forall D G w rF lF lG F B F' B', + WkTm D G w F F' -> + WkTm (oExtC D rF lF F') (oExtC G rF lF F) + (oLiftW D G w (iEl rF lF) (oEl G rF lF F) (oEl D rF lF F')) B B' -> + WkTm D G w (oPiRel G rF lF lG F B) (oPiRel D rF lF lG F' B') +| wktm_pi_irr : forall D G w rF lF F B F' B', + WkTm D G w F F' -> + WkTm (oExtC D rF lF F') (oExtC G rF lF F) + (oLiftW D G w (iEl rF lF) (oEl G rF lF F) (oEl D rF lF F')) B B' -> + WkTm D G w (oPiIrr G rF lF F B) (oPiIrr D rF lF F' B') +(* THE STUCK-[Id] CLAUSE, and the whole of the code/element mutual + recursion. [A] and [B] are codes, [t] and [u] are ELEMENTS, and one + judgement weakens all four. *) +| wktm_id : forall D G w l A B t u A' B' t' u', + WkTm D G w A A' -> WkTm D G w B B' -> + WkTm D G w t t' -> WkTm D G w u u' -> + WkTm D G w (oIdEq G l A B t u) (oIdEq D l A' B' t' u') +(* ---- elements ---- *) +| wktm_zero : forall D G w, WkTm D G w (oZero G) (oZero D) +| wktm_suc : forall D G w n n', + WkTm D G w n n' -> WkTm D G w (oSuc G n) (oSuc D n') +(* The entire irrelevant fragment, in one clause. *) +| wktm_star : forall D G w, WkTm D G w oStar oStar +| wktm_lam_rel : forall D G w rF lF lG F B t F' B' t', + WkTm D G w F F' -> + WkTm (oExtC D rF lF F') (oExtC G rF lF F) + (oLiftW D G w (iEl rF lF) (oEl G rF lF F) (oEl D rF lF F')) B B' -> + WkTm (oExtC D rF lF F') (oExtC G rF lF F) + (oLiftW D G w (iEl rF lF) (oEl G rF lF F) (oEl D rF lF F')) t t' -> + WkTm D G w (oLamRel G rF lF lG F B t) (oLamRel D rF lF lG F' B' t') +| wktm_app_rel : forall D G w rF lF lG F B f a F' B' f' a', + WkTm D G w F F' -> + WkTm (oExtC D rF lF F') (oExtC G rF lF F) + (oLiftW D G w (iEl rF lF) (oEl G rF lF F) (oEl D rF lF F')) B B' -> + WkTm D G w f f' -> WkTm D G w a a' -> + WkTm D G w (oAppRel G rF lF lG F B f a) (oAppRel D rF lF lG F' B' f' a') +(* [Emptyrec]'s argument is [*] on both sides: it is (E2)'s second + erasable position, and the value grammar writes it literally. *) +| wktm_emptyrec : forall D G w rA lA A A', + WkTm D G w A A' -> + WkTm D G w (oEmptyrec G rA lA A oStar) (oEmptyrec D rA lA A' oStar) +(* ---- variables ---- + + SPLIT ON THE HEAD SYMBOL, not left as one clause over an unconstrained + subject. A single [wktm_var : WkVar … x x' -> WkTm D G w x x'] is + syntactically overlapping with EVERY other clause, since [x] is a bare + variable of the inductive, so [inversion] on [WkTm D G w (oNat G) e2] + spawns a bogus [WkVar] subcase for each of the twelve. Splitting on + [oHd] / [oExpSubst] makes the whole judgement head-directed, which is + what turns determinism into a discrimination argument. *) +| wktm_var_hd : forall D G w i A A' G0 i0 A0 x', + WkVar D G w i A A' (oHd G0 i0 A0) x' -> + WkTm D G w (oHd G0 i0 A0) x' +| wktm_var_wkn : forall D G w i A A' G0 j B i0 A0 y x', + WkVar D G w i A A' + (oExpSubst (oExt G0 j B) G0 (oWkn G0 j B) i0 A0 y) x' -> + WkTm D G w (oExpSubst (oExt G0 j B) G0 (oWkn G0 j B) i0 A0 y) x' + +(* [WkVar D G w i A A' x x'] : [x], a variable of value type [A] over [G], + weakens along [w] to [x'] of value type [A'] over [D]. The five + clauses are the four constructors of NormalForms.v's [Wk] class, with + the lifted one split on the shape of [x] -- under a lift [hd] goes to + [hd] and a weakened variable goes one level down. This is exactly the + dispatch that cannot be a [Fixpoint]. *) +with WkVar : term -> term -> term -> term -> term -> term -> term -> term + -> Prop := +| wkvar_id : forall G i A x, + VarTy G i A x -> WkVar G G (oId G) i A A x x +| wkvar_wkn : forall G j B i A A' x, + VarTy G i A x -> + WkTy (oExt G j B) G (oWkn G j B) i A A' -> + WkVar (oExt G j B) G (oWkn G j B) i A A' x + (oExpSubst (oExt G j B) G (oWkn G j B) i A x) +| wkvar_cmp : forall D0 j B G w0 i A A0 A' x x0, + WkVar D0 G w0 i A A0 x x0 -> + WkTy (oExt D0 j B) D0 (oWkn D0 j B) i A0 A' -> + WkVar (oExt D0 j B) G + (oCmp (oExt D0 j B) D0 G (oWkn D0 j B) w0) i A A' x + (oExpSubst (oExt D0 j B) D0 (oWkn D0 j B) i A0 x0) +| wkvar_lift_hd : forall D0 G0 w0 i0 A0 A0' A A', + WkTy D0 G0 w0 i0 A0 A0' -> + WkTy (oExt G0 i0 A0) G0 (oWkn G0 i0 A0) i0 A0 A -> + WkTy (oExt D0 i0 A0') D0 (oWkn D0 i0 A0') i0 A0' A' -> + WkVar (oExt D0 i0 A0') (oExt G0 i0 A0) (oLiftW D0 G0 w0 i0 A0 A0') + i0 A A' (oHd G0 i0 A0) (oHd D0 i0 A0') +| wkvar_lift_wkn : forall D0 G0 w0 i0 A0 A0' i Ay Ay' y y' A A', + WkVar D0 G0 w0 i Ay Ay' y y' -> + WkTy (oExt G0 i0 A0) G0 (oWkn G0 i0 A0) i Ay A -> + WkTy (oExt D0 i0 A0') D0 (oWkn D0 i0 A0') i Ay' A' -> + WkVar (oExt D0 i0 A0') (oExt G0 i0 A0) (oLiftW D0 G0 w0 i0 A0 A0') + i A A' + (oExpSubst (oExt G0 i0 A0) G0 (oWkn G0 i0 A0) i Ay y) + (oExpSubst (oExt D0 i0 A0') D0 (oWkn D0 i0 A0') i Ay' y') + +(* [VarTy G i A x] : [x] is a variable whose value type in [G] is [A]. + A variable's type is always a weakened one, which is why this needs + [WkTy] and hence belongs in the block. *) +with VarTy : term -> term -> term -> term -> Prop := +| varty_hd : forall G i A0 A, + WkTy (oExt G i A0) G (oWkn G i A0) i A0 A -> + VarTy (oExt G i A0) i A (oHd G i A0) +| varty_wkn : forall G j B i A A' x, + VarTy G i A x -> + WkTy (oExt G j B) G (oWkn G j B) i A A' -> + VarTy (oExt G j B) i A' (oExpSubst (oExt G j B) G (oWkn G j B) i A x). + +Scheme WkTy_min := Minimality for WkTy Sort Prop + with WkTm_min := Minimality for WkTm Sort Prop + with WkVar_min := Minimality for WkVar Sort Prop + with VarTy_min := Minimality for VarTy Sort Prop. + +Combined Scheme Wk_mutind from WkTy_min, WkTm_min, WkVar_min, VarTy_min. + +(* ================================================================== *) +(* DETERMINISM -- design.md section 13b's property (D) *) +(* ================================================================== *) + +(* The whole argument is head symbols: no two clauses of [WkTm] can fire + on the same subject, and no two clauses of [WkVar] on the same [w] and + subject. [inversion] does the discrimination and the induction + hypotheses do the rest. *) +(* NOTE THE STRENGTHENED [WkVar] CONJUNCT: it concludes [i = i2] and + [A = A2] as well, i.e. a variable's INPUT type is determined by its + context and the variable itself. That is not a bonus, it is what + breaks the circularity. [WkTm]'s two variable clauses quantify [i] and + [A] existentially, so [WkTm] determinism needs variable-type uniqueness; + proving it as a separate theorem needs [WkTy] determinism, which needs + [WkTm] determinism. Folding it into the same induction closes the + loop, because at every [WkVar] clause the required uniqueness comes + from an induction hypothesis of a SUB-derivation ([VarTy] at + [wkvar_id]/[wkvar_wkn], [WkVar] at [wkvar_cmp]/[wkvar_lift_wkn], and + [WkTy] at [wkvar_lift_hd]). *) +Theorem Wk_det : + (forall D G w i A A', WkTy D G w i A A' -> + forall A2, WkTy D G w i A A2 -> A' = A2) + /\ (forall D G w e e', WkTm D G w e e' -> + forall e2, WkTm D G w e e2 -> e' = e2) + /\ (forall D G w i A A' x x', WkVar D G w i A A' x x' -> + forall i2 A2 A2' x2, WkVar D G w i2 A2 A2' x x2 -> + i = i2 /\ A = A2 /\ A' = A2' /\ x' = x2) + /\ (forall G i A x, VarTy G i A x -> + forall i2 A2, VarTy G i2 A2 x -> i = i2 /\ A = A2). +Proof. + apply Wk_mutind; intros; + (* (1) Drop the clause's OWN premises. Each is paired with an + induction hypothesis and would otherwise be matched by it, yielding + a trivial equation and consuming the hypothesis before the second + derivation's premise can use it. *) + repeat match goal with + | Hp : WkTy ?D ?G ?w ?i ?A ?X, + _ : forall z, WkTy ?D ?G ?w ?i ?A z -> ?X = z |- _ => clear Hp + | Hp : WkTm ?D ?G ?w ?e ?X, + _ : forall z, WkTm ?D ?G ?w ?e z -> ?X = z |- _ => clear Hp + | Hp : WkVar ?D ?G ?w _ _ _ ?x _, + _ : forall a b c d, WkVar ?D ?G ?w a b c ?x d -> _ |- _ => clear Hp + | Hp : VarTy ?G _ _ ?x, + _ : forall a b, VarTy ?G a b ?x -> _ |- _ => clear Hp + end; + (* (2) Invert the second derivation. Every judgement is head-directed + -- in the subject for [WkTy]/[WkTm]/[VarTy], in the weakening and + then the subject for [WkVar] -- so all but one clause dies here. *) + match goal with + | H : WkTy _ _ _ _ _ ?X |- _ = ?X => inversion H; subst + | H : WkTm _ _ _ _ ?X |- _ = ?X => inversion H; subst + | H : WkVar _ _ _ ?I ?A ?B ?x ?Y + |- _ = ?I /\ _ = ?A /\ _ = ?B /\ _ = ?Y => inversion H; subst + | H : VarTy _ ?I ?A ?x |- _ = ?I /\ _ = ?A => inversion H; subst + end; + (* (3) Feed the surviving premises to the induction hypotheses. *) + repeat match goal with + | IH : forall z, WkTy ?D ?G ?w ?i ?A z -> _, + H : WkTy ?D ?G ?w ?i ?A _ |- _ => specialize (IH _ H); subst + | IH : forall z, WkTm ?D ?G ?w ?e z -> _, + H : WkTm ?D ?G ?w ?e _ |- _ => specialize (IH _ H); subst + | IH : forall a b c d, WkVar ?D ?G ?w a b c ?x d -> _, + H : WkVar ?D ?G ?w _ _ _ ?x _ |- _ => + specialize (IH _ _ _ _ H); destruct IH as [? [? [? ?]]]; subst + | IH : forall a b, VarTy ?G a b ?x -> _, + H : VarTy ?G _ _ ?x |- _ => + specialize (IH _ _ H); destruct IH as [? ?]; subst + end; + repeat split; auto. +Qed. + +Definition WkTy_det := proj1 Wk_det. +Definition WkTm_det := proj1 (proj2 Wk_det). +Definition WkVar_det := proj1 (proj2 (proj2 Wk_det)). +Definition VarTy_det := proj2 (proj2 (proj2 Wk_det)). + +(* A weakening derivation knows its subject is a variable of the type it + claims. (Used when wiring [Values.v]'s [ValVar] onto [VarTy].) *) +Lemma WkVar_VarTy D G w i A A' x x' + : WkVar D G w i A A' x x' -> VarTy G i A x. +Proof. + induction 1; try assumption. + - eapply varty_hd; eassumption. + - eapply varty_wkn; eassumption. +Qed. diff --git a/src/Pyrosome/Gluing/Dtt/WkVal.v b/src/Pyrosome/Gluing/Dtt/WkVal.v new file mode 100644 index 00000000..5e7c045d --- /dev/null +++ b/src/Pyrosome/Gluing/Dtt/WkVal.v @@ -0,0 +1,328 @@ +Set Implicit Arguments. + +From coqutil Require Import Datatypes.String. +From Stdlib Require Import Lists.List. +Import ListNotations. +Open Scope string. +Open Scope list. +From Utils Require Import Utils. +From Pyrosome Require Import Theory.Core. +Require Import Pyrosome.Gluing.Dtt.Syntax Pyrosome.Gluing.Dtt.Wf + Pyrosome.Gluing.Dtt.Eqns Pyrosome.Gluing.Dtt.NormalForms. +Import Core.Notations. + +(* ===================================================================== + T3: FUNCTIONAL WEAKENING OF CODE VALUES -- THE REPRESENTATION EXPERIMENT. + + The question this file answers is design.md's: can the value layer's + weakening be a FUNCTION on the ANNOTATED syntax, or do the annotations + force the de Bruijn detour? + + ANSWER, in two halves. + + (+) FOR THE CANONICAL CODE GRAMMAR THE ANNOTATIONS LINE UP EXACTLY. + [wkV] below is an ordinary [Fixpoint] on the code, with the + weakening [w] as a varying (non-recursive) parameter; it is + accepted, it computes the right thing, and [wkV_sound] -- + "[wkV] preserves [NfCode] and realizes [exp_subst w]" -- is proved + here by the very induction NfWk.v's [Nf_wk_str] already runs, with + [exists c'] replaced by the computed [wkV ... c]. The three + equational lemmas it needs ([eq_El_wk], [eq_pi_rel_wk], + [eq_pi_irr_wk], plus [Wk_liftC]) are the ones NfWk.v already + proves, and they slot in WITHOUT ANY RESHAPING: [wkV]'s [F'] is + literally [eq_pi_rel_wk]'s [F'], and [Wk_liftC] hands back the + weakening at exactly [oExtC D rF lF F'], which is the context the + recursive call is made in. NOTHING about the annotations fights. + + (-) AT VARIABLES IT DOES NOT WORK, AND THE OBSTRUCTION IS PRECISELY THE + TYPE ANNOTATION. Under a LIFTED weakening the value of [x[w]] is + not [exp_subst w x]: [hd] goes to [hd] and [exp_subst wkn y] to + [exp_subst wkn (y[w'])]. So the variable case must recurse on the + SHAPE OF [w]. The term that recursion builds carries a type + annotation -- the type of the inner variable in the smaller + context -- and that annotation is itself a weakened TYPE, so it has + to be computed by [wkV]. A recursion on [w] calling a recursion on + [c] calling a recursion on [w]: no single argument decreases, and + the guard checker says so in as many words: + + Recursive call to wkVar has principal argument equal to + "w" instead of a subterm of "c". + + The genuinely decreasing structure is the DERIVATION, which is what + [Nf_wk_str] recurses on and what a [Prop]-valued value judgement + cannot be eliminated into [term] over. + + So this file carries the NEUTRAL case as a HYPOTHESIS [wkne] + + [wkne_sound] (a section [Context], not an axiom) and proves everything + else. Two remarks on that hypothesis, so it is not mistaken for a + fudge: + + * on the VARIABLE half of [NeCode] it is exactly the [exists c'] + statement NfWk.v's [Nf_wk_str] discharges at [nfcode_var] + (:1551-1558, via the 340-line [vart_hd_wk_gen]/[vart_wkn_wk_gen]), + so a witness demonstrably exists -- what is missing is a Gallina + FUNCTION realizing it, which is the whole of the open question; + + * on the STUCK-[Id] half ([necode_id_l/r], [necode_id_nat_l/r]) it is + genuinely new: those clauses did not exist when NfWk.v was written, + and weakening them needs the "Id subst" rule plus ELEMENT-level + weakening (an [Id]'s endpoints are terms), i.e. the mutual + recursion between code and element normalization that design.md + section 14d calls the real structural cost of [Id]. + ===================================================================== *) + +Local Notation wft := (wf_term ott_dtt []). +Local Notation eqt := (eq_term ott_dtt []). + +(* The lifted weakening, verbatim from NfWk.v:141. *) +Definition oLiftW (D G w i A A' : term) : term := + oSnoc (oExt D i A') G i A (oCmp (oExt D i A') D G (oWkn D i A') w) + (oHd D i A'). + +Section WithNeutrals. + + (* The one hole. [wkne D G w r l c] is meant to be the value of [c[w]] + for [c] a NEUTRAL code -- a variable, or a stuck [Id] ([NeCode_shape]). + See the header for why it cannot be defined by + structural recursion on the annotated syntax. *) + Context (wkne : term -> term -> term -> term -> term -> term -> term). + + Context + (wkne_sound : + forall G r l c, NeCode G r l c -> + forall D w, Wk D G w -> EnvOk D -> + NfCode D r l (wkne D G w r l c) + /\ eqt (sCode D r l) + (oExpSubst D G w (iCode l) (oU G r l) c) (wkne D G w r l c)). + + (* The three weakening equations of NfWk.v, taken as hypotheses because + NfWk.v itself does not currently compile (the Id fragment changed the + arity of [Nf_mutind] and added the [NeCode] judgement, so everything + from [Nf_wk_str] on is being rewritten). Each statement below is + COPIED VERBATIM from the corresponding [Lemma] in NfWk.v, which proves + it: [eq_El_wk] at :896, [Wk_liftC] at :909, [eq_pi_rel_wk] at :995, + [eq_pi_irr_wk] at :1023, [eq_Nat_subst'] at :590 (specialized), and + [eq_Empty_subst] from Eqns.v (specialized). *) + Context + (eq_nat_wk : + forall D G w, Wk D G w -> EnvOk D -> EnvOk G -> + eqt (sCode D oRel oL0) + (oExpSubst D G w (iCode oL0) (oU G oRel oL0) (oNat G)) (oNat D)) + (eq_empty_wk : + forall D G w, Wk D G w -> EnvOk D -> EnvOk G -> + eqt (sCode D oIrr oL0) + (oExpSubst D G w (iCode oL0) (oU G oIrr oL0) (oEmpty G)) + (oEmpty D)) + (Wk_liftC : + forall D G w rF lF F F', + Wk D G w -> EnvOk D -> NfCode G rF lF F -> NfCode D rF lF F' -> + eqt (sCode D rF lF) (oCodeSubst D G w rF lF F) F' -> + Wk (oExtC D rF lF F') (oExtC G rF lF F) + (oLiftW D G w (iEl rF lF) (oEl G rF lF F) (oEl D rF lF F')) + /\ EnvOk (oExtC D rF lF F') + /\ eqt (sTy D (iEl rF lF)) + (oTySubst D G w (iEl rF lF) (oEl G rF lF F)) + (oEl D rF lF F')) + (eq_pi_rel_wk : + forall D G w rF lF lG F B F' B', + Wk D G w -> EnvOk D -> + NfCode G rF lF F -> NfCode (oExtC G rF lF F) oRel lG B -> + NfCode D rF lF F' -> NfCode (oExtC D rF lF F') oRel lG B' -> + eqt (sCode D rF lF) + (oExpSubst D G w (iCode lF) (oU G rF lF) F) F' -> + eqt (sCode (oExtC D rF lF F') oRel lG) + (oExpSubst (oExtC D rF lF F') (oExtC G rF lF F) + (oLiftW D G w (iEl rF lF) (oEl G rF lF F) (oEl D rF lF F')) + (iCode lG) (oU (oExtC G rF lF F) oRel lG) B) B' -> + eqt (sCode D oRel lG) + (oExpSubst D G w (iCode lG) (oU G oRel lG) (oPiRel G rF lF lG F B)) + (oPiRel D rF lF lG F' B')) + (eq_pi_irr_wk : + forall D G w rF lF F B F' B', + Wk D G w -> EnvOk D -> + NfCode G rF lF F -> NfCode (oExtC G rF lF F) oIrr oL0 B -> + NfCode D rF lF F' -> NfCode (oExtC D rF lF F') oIrr oL0 B' -> + eqt (sCode D rF lF) + (oExpSubst D G w (iCode lF) (oU G rF lF) F) F' -> + eqt (sCode (oExtC D rF lF F') oIrr oL0) + (oExpSubst (oExtC D rF lF F') (oExtC G rF lF F) + (oLiftW D G w (iEl rF lF) (oEl G rF lF F) (oEl D rF lF F')) + (iCode oL0) (oU (oExtC G rF lF F) oIrr oL0) B) B' -> + eqt (sCode D oIrr oL0) + (oExpSubst D G w (iCode oL0) (oU G oIrr oL0) (oPiIrr G rF lF F B)) + (oPiIrr D rF lF F' B')). + +(* ------------------------------------------------------------------ *) +(* The function *) +(* ------------------------------------------------------------------ *) + +(* Matched on the ARGUMENT-LIST SHAPE first and only then on the head + symbol (via [eqb], not a literal string pattern), the idiom of + Syntax.v's [ntlvl]: it keeps the case analyses below to a fixed, small + number of [destruct]s. Note [oPiRel] has six arguments and so does + [oExpSubst] and [oIdEq]; the [eqb] guard is what separates them, and + everything it does not claim goes to [wkne]. + + STRUCTURAL ON THE CODE, with [D]/[G]/[w] varying: at a binder the + recursive call is made in the EXTENDED context with the LIFTED + weakening, which is bigger than [w] -- fine, since only [c] is the + recursive argument. *) +Fixpoint wkV (D G w r l c : term) {struct c} : term := + match c with + | con nm [_] => + if eqb nm "Nat" then oNat D + else if eqb nm "Empty" then oEmpty D + else wkne D G w r l c + | con nm [B; F; lG; lF; rF; _] => + if eqb nm "Pi_rel" + then let F' := wkV D G w rF lF F in + oPiRel D rF lF lG F' + (wkV (oExtC D rF lF F') (oExtC G rF lF F) + (oLiftW D G w (iEl rF lF) (oEl G rF lF F) (oEl D rF lF F')) + oRel lG B) + else wkne D G w r l c + | con nm [B; F; lF; rF; _] => + if eqb nm "Pi_irr" + then let F' := wkV D G w rF lF F in + oPiIrr D rF lF F' + (wkV (oExtC D rF lF F') (oExtC G rF lF F) + (oLiftW D G w (iEl rF lF) (oEl G rF lF F) (oEl D rF lF F')) + oIrr oL0 B) + else wkne D G w r l c + | _ => wkne D G w r l c + end. + +(* The four computation rules, as equations. Each is [reflexivity]: the + [eqb] guards reduce, and the annotations the recursive calls are made + at are exactly the ones the judgements demand. *) + +Lemma wkV_nat D G w r l : wkV D G w r l (oNat G) = oNat D. +Proof. reflexivity. Qed. + +Lemma wkV_empty D G w r l : wkV D G w r l (oEmpty G) = oEmpty D. +Proof. reflexivity. Qed. + +Lemma wkV_pi_rel D G w r l rF lF lG F B + : wkV D G w r l (oPiRel G rF lF lG F B) + = let F' := wkV D G w rF lF F in + oPiRel D rF lF lG F' + (wkV (oExtC D rF lF F') (oExtC G rF lF F) + (oLiftW D G w (iEl rF lF) (oEl G rF lF F) (oEl D rF lF F')) + oRel lG B). +Proof. reflexivity. Qed. + +Lemma wkV_pi_irr D G w r l rF lF F B + : wkV D G w r l (oPiIrr G rF lF F B) + = let F' := wkV D G w rF lF F in + oPiIrr D rF lF F' + (wkV (oExtC D rF lF F') (oExtC G rF lF F) + (oLiftW D G w (iEl rF lF) (oEl G rF lF F) (oEl D rF lF F')) + oIrr oL0 B). +Proof. reflexivity. Qed. + +(* ------------------------------------------------------------------ *) +(* Soundness *) +(* ------------------------------------------------------------------ *) + +(* THE T3 THEOREM. Compare NfWk.v's [Nf_wk_str], [NfCode] conjunct: + + forall G r l c, NfCode G r l c -> forall D w, Wk D G w -> + exists c', NfCode D r l c' + /\ eqt (sCode D r l) (exp_subst w c) c' + + The only change is that [c'] is [wkV D G w r l c], and the proof is the + same four cases with [destruct (IH ...) as [c' [Hc' Heq]]] replaced by + the IH read at the computed value. In particular [Wk_liftC] is applied + at [F' := wkV D G w rF lF F] and hands back a weakening whose codomain + is [oExtC D rF lF F'] -- the exact context the second recursive call is + typed in. That is the alignment the experiment was about. *) +Theorem wkV_sound + : forall G r l c, NfCode G r l c -> + forall D w, Wk D G w -> EnvOk D -> + NfCode D r l (wkV D G w r l c) + /\ eqt (sCode D r l) + (oExpSubst D G w (iCode l) (oU G r l) c) (wkV D G w r l c). +Proof. + induction 1 as [ G HG | G HG + | G rF lF lG F B HrF HlF HlG HF IHF HB IHB + | G rF lF F B HrF HlF HF IHF HB IHB + | G r l c Hne ]; + intros D w HW HD. + (* ---- Nat ---- *) + - rewrite wkV_nat; split; + [ apply nfcode_nat; exact HD | apply eq_nat_wk; assumption ]. + (* ---- Empty ---- *) + - rewrite wkV_empty; split; + [ apply nfcode_empty; exact HD | apply eq_empty_wk; assumption ]. + (* ---- Pi_rel ---- *) + - rewrite wkV_pi_rel; cbn zeta. + destruct (IHF D w HW HD) as [HF' HeqF]. + destruct (Wk_liftC HW HD HF HF' HeqF) as [HW2 [HD2 _]]. + destruct (IHB _ _ HW2 HD2) as [HB' HeqB]. + split; + [ apply nfcode_pi_rel; assumption + | apply eq_pi_rel_wk; assumption ]. + (* ---- Pi_irr ---- *) + - rewrite wkV_pi_irr; cbn zeta. + destruct (IHF D w HW HD) as [HF' HeqF]. + destruct (Wk_liftC HW HD HF HF' HeqF) as [HW2 [HD2 _]]. + destruct (IHB _ _ HW2 HD2) as [HB' HeqB]. + split; + [ apply nfcode_pi_irr; assumption + | apply eq_pi_irr_wk; assumption ]. + (* ---- neutral: THE HOLE ---- *) + - destruct (NeCode_shape Hne) as [ Hv | [l0 [A [B [t [u ->]]]]] ]. + + (* a code variable. [wkV] falls through to [wkne] on [oHd] (three + arguments) and on [oExpSubst] (six, with head [exp_subst]), so + the goal is literally [wkne_sound]. *) + destruct (VarT_shape Hv) as [ [G0 [i0 [A0 ->]]] + | [G0 [j [B [i0 [A0 [y ->]]]]]] ]; + cbn [wkV]; apply wkne_sound; assumption. + + (* a stuck [Id]: six arguments, head [Id], so again [wkne]. *) + cbn [wkV]; apply wkne_sound; assumption. +Qed. + +End WithNeutrals. + +(* ===================================================================== + WHAT THIS SETTLES, AND WHAT IT DOES NOT. + + SETTLED (the positive half). On the canonical code grammar the + annotated representation is fine. [wkV] is a plain [Fixpoint]; its + soundness is NfWk.v's induction with the existential replaced by the + computed value; the [F']/[B'] slots of [eq_pi_rel_wk] / [eq_pi_irr_wk] + and the context [oExtC D rF lF F'] handed back by [Wk_liftC] line up + with the recursive calls with no reshaping at all. No annotation had + to be massaged, and no lemma had to be restated. + + OPEN (the negative half). [wkne] cannot be defined. See the header: + the recursion on the weakening and the recursion on the code call each + other, and Rocq's guard checker rejects the pair. Three exits, in + increasing order of cost: + + (a) MAKE WEAKENING A DETERMINISTIC RELATION, mutually with the value + judgements, and prove functionality (design.md section 13b's + property (D)) instead of getting it definitionally. Costs a + determinism proof by the same mutual induction; keeps every line + of Values.v and this file. Note the design's own [Nrm] is + already of this shape -- "a deterministic big-step [Nrm e n]" + with (D) as a THEOREM -- so this is not a new concession. + + (b) DE BRUIJN VALUES + ONE READBACK, the fallback design.md names. + Weakening becomes a shift and the annotation problem evaporates + because de Bruijn values carry no annotations. Rigid.v's + [rcode]/[rty]/[renv] (with [cren]/[csub]/[rshift] and their + sigma laws, all proved) is a working template for the domain. + Costs a readback and its soundness. + + (c) INDEX VARIABLE VALUES BY A DE BRUIJN DEPTH inside the annotated + syntax, so the annotation is derivable from the depth and the + context. A hybrid; not obviously cheaper than (a). + + RESOLVED: (a). See src/Pyrosome/Gluing/Dtt/WkRel.v, which carries the + relation, its determinism, and -- the thing this file could not reach + at all -- the stuck-[Id] and element clauses. [wkV] and [wkV_sound] + are kept here because they remain the record of what IS definitional: + on the canonical code grammar the annotated representation needs no + relational detour, and that is why (b) was not necessary. + ===================================================================== *) diff --git a/src/Pyrosome/Gluing/Dtt/design.md b/src/Pyrosome/Gluing/Dtt/design.md index 9fd9c76d..92569f60 100644 --- a/src/Pyrosome/Gluing/Dtt/design.md +++ b/src/Pyrosome/Gluing/Dtt/design.md @@ -660,3 +660,532 @@ parallel proof development safe is exactly what manufactures this duplication. B consolidation pass. Net: 29 files → 28, 25 228 lines → 23 111, no `Admitted` and no `Axiom` at any point. + +--- + +## 12. The Id extension (in progress) + +`ott_dtt` is being extended with the heterogeneous, observational identity type. The fragment +is `src/Pyrosome/Lang/OTT/IdCong.v` (`ott_id_cong`), **prepended**: + +``` +ott_dtt := ott_id_cong ++ ott_proofirr_el ++ ott_subst_commute ++ ott_pi ++ ott_nat + ++ ott_base ++ subst_ott ++ ott_info +``` + +Prepending is not a style choice. `infer_rule` re-extracts each rule's conclusion sort with +`mk_weight`, whose tie-breaks depend on the *ambient* language (§9b), so inserting the fragment +anywhere it is in scope while an earlier fragment elaborates can silently flip an existing rule +between `next L0` and `iota L1` and invalidate a large amount of `Eqns.v`/`Wf.v`/`Model*.v`. + +### 12a. What is in the fragment + +Two term rules and thirteen equations. + +* `Id G l A B t u : U G irr L0`, with `A B : U G rel l`, `t : El A`, `u : El B` — *heterogeneous*, + and restricted to **relevant** codes. There is no `Id` between irrelevant codes and none is + wanted: proof irrelevance already equates all their inhabitants. +* `Idcong A B b t u e : Id (B[t]) (B[u]) (b[t]) (b[u])`, from `e : Id A A t u` and a body + `b : El B` in `ext G (El A)`. **The only proof former.** +* `Id subst`, and the computation rules of §12b. + +**No `Idrefl`.** `Idcong` strictly generalizes it: for a body that ignores the bound variable, +`Idcong Nat C[wkn] c[wkn] zero zero triv : Id C C c c`, where `triv` inhabits `Id ℕ ℕ 0 0`, which +`Id-Nat-00` reduces to the unit proposition. + +**No equations for `Idcong` at all** — not its substitution commutation, not the rules that push +it under a constructor. Every one of them equates two inhabitants of a code at `U _ irr _`, so +`ott_proofirr_el` proves it outright; they are *derived* in `Eqns.v`. This is the one place the +§9a lesson ("a former with no substitution commutation is stuck under an explicit substitution, +and normal forms are not stable under weakening") does **not** apply, because irrelevance +supplies the equation that the missing rule would have. + +### 12b. The computation rules, and why `Id` never survives a closed environment + +The design constraint is: *the extension adds no normal form except neutrals*. Equivalently, an +`Id` code whose arguments are all canonical must reduce. Since `Id`'s type arguments are relevant +codes at a common level, the normal codes it can see are `Nat`, `Pi_rel …` and neutrals, so the +case analysis is finite: + +| A, B | rule(s) | +|---|---| +| `ℕ`, `ℕ`, endpoints canonical | `Id-Nat-00` → unit, `Id-Nat-0S`/`Id-Nat-S0` → `Empty`, `Id-Nat-SS` → recurse | +| `ℕ` vs `Pi_rel` | `Id-Nat-Pi` / `Id-Pi-Nat` → `Empty` (type-directed: endpoints arbitrary) | +| `Pi_rel`, `Pi_rel`, domain indices differ | 4 clash rules → `Empty` (they PARTITION -- see §14l) | +| `Pi_rel`, `Pi_rel`, domain indices agree | function extensionality, §12c | +| either code neutral, or `ℕ`/`ℕ` with a neutral endpoint | **stuck — the new neutral code** | + +### 12c. Function extensionality is heterogeneous, and the domain-equality premise is not optional + +``` +Id (Π_{rF,lF} F1 B1) (Π_{rF,lF} F2 B2) f g + ↝ Π_irr (a1 : F1). Π_irr (a2 : F2). Π_irr (p : Id F1 F2 a1 a2). + Id (B1[a1]) (B2[a2]) (f·a1) (g·a2) (rF = rel) + ↝ Π_irr (a1 : F1). Π_irr (a2 : F2). + Id (B1[a1]) (B2[a2]) (f·a1) (g·a2) (rF = irr) +``` + +Quantifying over a *pair* of arguments plus a proof that they are equal is what lets the rule be +stated without a **cast**, and that matters: `Cast`'s `u0` is a code whose `El` is a universe, +which breaks the code grammar §2 rests on (§9's warning). The heterogeneous `Id` pays for itself +here. + +The `p` premise is **required for consistency** at relevant domains, not a refinement. Dropping it +gives `Id (Π ℕ ℕ) (Π ℕ ℕ) f g ↝ Π(a1)Π(a2). Id ℕ ℕ (f·a1) (g·a2)`; instantiate with `f = g = id` +and it inhabits `Id ℕ ℕ a1 a2` for arbitrary `a1,a2`, hence `Id ℕ ℕ 0 1 = Empty`. At *irrelevant* +domains the premise is genuinely unnecessary — a relevant result cannot depend on an irrelevant +argument except through `Emptyrec` — so the two-binder form is used there, which is why the two +cases are separate rules. + +### 12d. `Idcong` is an UNCONDITIONAL neutral, and that is what makes reification work + +> **SUPERSEDED by §14.** Under the `*`-erasure of §14 an `Idcong` is simply a proof, +> its normal form is `*`, and none of the machinery below is needed. The reasoning +> here is still the correct account of why a *body*-conditional neutral does not +> work, which is why it is kept. + +The first design had `Idcong A B b t u e` neutral only when `b` is neutral, with a structural +recursion on `b` supplying the normal form otherwise. That recursion does not close. At +`b = lam_rel F' B'' s` the reduced type is the triple-`Π_irr` above, and its body needs a proof of +`Id (B''[t,a1]) (B''[u,a2]) (s[t,a1]) (s[u,a2])` — a congruence in **two** variables at once, +which the single-binder `Idcong` cannot express and which cannot be assembled from two +single-variable congruences (the intermediate point would have to be `a1` transported along +`F'[t] ~ F'[u]`, i.e. a cast). + +Making `Idcong` neutral *unconditionally* dissolves this. Its normal form is then whatever its +**type** dictates, and the type-directed machinery already in place does all the work: + +* type reduces to a `Π_irr` (the unit proposition, or a funext Π) → not normal there, so it + η-expands by proof irrelevance to `lam_irr … (Idcong … · a1 · a2 · p)`, and the body is + `app_irr` applied to a neutral, hence **again a neutral**, at the smaller inner `Id`; +* type reduces to `Empty` → neutrals are normal there; +* type is a stuck `Id` → neutrals are normal there. + +So "push the congruence under each term former of the shared context" is realised by the *type* +computing under that former, with the proof following it. The pushing equations +(`Idcong … (suc n) … = Idcong … n …`, `Idcong … hd … = e`, `Idcong` of a closed body = reflexivity) +remain true and are derived in `Eqns.v`, but no case of the normalization proof has to be +organised around them. + +Note this makes normal forms at `El _ irr _` non-unique — `Idcong A A[wkn] hd t u e` and `e` are +both normal at the same stuck `Id`. That is already true of the language (§6(a): at `Pi_irr` *any* +normal inhabitant of the codomain will do) and it is harmless, because uniqueness is only ever +needed for **codes**, and a proof never occurs inside a code: `Id`'s element arguments sit at +relevant types. + +### 12e. What it costs: code rigidity, and the replacement + +`Id` is a code whose arguments include element terms, and its ℕ rules dispatch on those elements. +Layer 0.5's rigid model has `rceq_term = True` at every non-universe-like `exp` sort +(`Rigid.v:697`, `USkel (El _) = false` at `:285`) — which is exactly what let it discharge β, η and +proof irrelevance with `exact I` — so it must erase `t,u`, and then + +* `Id-Nat-00` forces `rc_id rc_nat rc_nat = rc_pi … rc_empty rc_empty`, and +* `Id-Nat-0S` forces `rc_id rc_nat rc_nat = rc_empty`, + +which `ICode`'s functionality (`Rigid.v:507`) makes contradictory. The two obligations are not +merely unproved, they are **refutable**. Giving the model real information about elements makes it +responsible for β and η, i.e. turns Layer 0.5 into a second normalization proof. This is §9's +`Cast` kill-switch arriving through `Id`. + +**Decision: retire Layer 0.5 and make the logical relation two-sided.** `RTy`'s candidate becomes a +binary relation; the universe clause relates two codes that share a normal representative, so +`NfCode_inj` / `TyOk_inj` / `EnvOk_inj` become *corollaries of the fundamental theorem* rather than +inputs to it. `Rigid.v`, `RigidOk.v` and `Inj.v` are deleted. The ~30 consumers listed in §4 — +`RTy_fun_of_inj` (`LogRelBasics.v:475`), `RTy_fun_eq` (`LogRelFun.v:60`), `RTmN_intro` +(`LogRelFun.v:77`, the sole constructor of `RTmN`), `TyOk_pin`/`NfCode_pin` and their 11 call sites +in `NfWk.v`, and the 20 inside `RTyEx_str` — are re-derived from the PER. + +This is the third time the development has hit this wall (§3, §4b, here); §4b's "computed normal +representatives" alternative was considered again and declined for the same reason as before, plus +the new one that it does not by itself supply non-confusion. + +--- + +## 13. Normalization becomes FUNCTIONAL (the Id extension forces it) + +**Decision.** The development's normalization content is existential — "`e` is provably equal to +SOME normal form" (`HasNf`, §6). That is deliberate: it is what makes the 28 σ-equations cheap and +what `Ceq.v` is organised around. It is also the reason `NfCode_inj`/`TyOk_inj` had to be earned +separately, by the rigid model of §4. Once `Id` is in the language that separate route is gone +(§12e), and no re-formulation of the *existential* content recovers it. So the content becomes +FUNCTIONAL: a deterministic big-step `Nrm e n`. + +### 13a. Why nothing cheaper works + +Four routes were tried and each is refuted, not merely unproved: + +| route | refutation | +|---|---| +| two-sided (PER) logical relation | the universe clause gives "`c1`,`c2` share a normal representative `c0`"; concluding `c1 = c2` still needs `NfCode_inj`. Stating the clause structurally (heads match, subparts related) only relocates the same fact: its `Nat` clause hypothesis is `c1 ≡ Nat`, and refuting that for a normal `c1 = Pi_rel …` *is* non-confusion | +| elements into the rigid model | the model must validate η, so its value domain needs `rval -> rval` — not strictly positive. Closures validate β but not η (NbE recovers η at readback, which is exactly the half that cannot be skipped here) | +| weaken the rigid model to relevant codes, make irrelevant candidates extensional | dies at `cong_AppIrr`, `ModelPi.v:3572-3574`. Its only supply is the Kripke `Hiff` at `:3463`; with an extensional `P` the goal becomes (via `eq_proof_irr` + `RTy_cand_eq`, `C` being irrelevant) "`Pc D id ag` is inhabited", which is refutable — `rty_empty` at `oEmp` has an empty candidate. Closing it needs `NfET_csubst`, which `NfWk.v` deliberately lacks and whose proof *is* a Kripke relation at the Pi type | +| drop the ℕ-endpoint Id rules | does not help: stuck `Id ℕ ℕ 0 0` and `Id ℕ ℕ 0 (S 0)` are distinct normal codes, so injectivity still needs element information | + +The through-line: **any `Id` that can get stuck forces the model to tell normal element forms +apart**, and `Id` can always get stuck, since deciding otherwise decides equality of arbitrary +terms. That is normalization strength. This is exactly §9's `Cast` warning, arriving via `Id`. + +An earlier session reached the same negative result independently, from the decidability side +(branch `dtt-decidability`, commit 829dca47): *any logical-relation content stable under `eqt` — +which the σ-equations need — cannot pin a syntactic representative without already knowing +canonicity.* At `rty2_nat` escape reduces to `NfET n1/n2/n`, `eqt n1 n`, `eqt n2 n` ⊢ `n1 = n2`, +an instance of the goal at a leaf with no induction hypothesis. + +### 13b. The shape of the fix + +> **CORRECTED by §14.** `NfET_inj` as stated below is FALSE — see §14a for the +> counterexample. The target is `Val_inj` over `*`-collapsed values. (D)/(I)/(T)/(C) +> survive unchanged; only the theorem they compose into changes. + +From the same prior work, `NfET_inj` decomposes into four properties of `Nrm`: + +* **(D) determinism** — `Nrm e n1 -> Nrm e n2 -> n1 = n2`; syntactic. +* **(I) idempotence on normals** — `NfET n -> Nrm n n`; syntactic. +* **(T) totality** — every well-typed term has an `Nrm`; this is what the existing model already + proves. +* **(C) completeness** — `eq_term e1 e2 -> Nrm e1 n1 -> Nrm e2 n2 -> n1 = n2`. + +and `NfET_inj = (I) twice + (C)`. (D) and (I) are what break the circle that the existential +content could not. + +Two consequences the old architecture avoided and this one must pay: a deterministic big-step +`Nrm` is on the critical path *as a definition*, and σ-confluence becomes REQUIRED — the +σ-equations must preserve `Nrm`-values. One wrinkle: `NfET` normal forms *contain* explicit +substitutions (a `vart_wkn` variable is literally `oExpSubst … (oWkn …) … x`), so `Nrm` must not +push substitutions into variable positions. + +### 13c. `Nrm` IS UNIFORM — the irrelevant side is not special-cased + +The governing principle, and the reason the irrelevant fragment is expected to be tractable: + +> **Irrelevant terms reduce exactly like relevant ones, and the reductions are justified by proof +> irrelevance.** + +`Nrm` does not dispatch on relevance. It reduces a term at a proof-irrelevant type by the same +structural rules it uses at a relevant one; where a step is not justified by a syntactic equation +of `ott_dtt`, `ott_proofirr_el` (`eq_proof_irr`) justifies it. This is what dissolves the +`NfET_csubst` obstruction that killed the extensional-candidate route: closure under substitution +becomes a property of the *function*, proved once and uniformly, rather than something the +Kripke candidate has to carry at each irrelevant type. + +It also fits §12d: `Idcong` is an unconditional neutral, so `Nrm` on an `Idcong` normalises its +arguments and its TYPE, and the type-directed machinery (η at `Pi_irr`, proof irrelevance) does +the rest — the congruence's "pushing under each former" is realised by the type computing, with +the proof following. + +### 13d. Reusable scaffolding + +Branch `dtt-decidability` (829dca47) has three compiling scaffolds, recovered: + +* `DecEqTerm.v` — `dec_eq_term` FULLY PROVED and axiom-free, with `nf`, its soundness, and + `NfET_inj` as *parameters of the term*, not axioms. Part B turns a Prop-level "some fuel + suffices" into a total computable `nf` via `ConstructiveEpsilon`, closed under the global + context — so `Ceq.v`'s Prop-only discipline is **not** a barrier to computability and no + Type-level refactor of the witness layer is needed. +* `RTy2Spike.v` — the binary-candidate `RTy2` is positivity-ACCEPTED (`Pd`/`Pc` are constructor + parameters, so the negative occurrence §3 rejected does not arise). +* `NfETInjSkel.v` — `NfET_inj`/`NeET_inj` `Qed` by one mutual induction over `Nf_mutind`, resting + on exactly 10 named admits: 3 non-confusion, 5 injectivity, 2 hard (`NeET_app_{rel,irr}_confusion`). + +--- + +## 14. `*`-erasure: the irrelevant fragment has ONE normal form + +### 14a. `NfET_inj` is false, and it always was + +``` +G := ext (ext emp iE (El emp irr L0 (Empty emp))) iE (El G1 irr L0 (Empty G1)) (iE := iEl irr L0) +x1 := hd … : VarT G iE (El G irr L0 (Empty G)) +x0 := exp_subst … (wkn …) … (hd …) : VarT G iE (El G irr L0 (Empty G)) +n1 := Emptyrec G rel L0 (Nat G) x0 n2 := Emptyrec G rel L0 (Nat G) x1 +``` + +Both are `NfET G (iEl rel L0) (oEl G rel L0 (oNat G))`, and `eqt n1 n2` holds by `Emptyrec_cong` +plus `eq_proof_irr` — yet `n1 ≠ n2`. `Emptyrec`'s motive relevance is a metavariable in the +compiled rule (`Lang/OTT/Nat.v:105`), so this is not an edge case. + +This predates `Id`. It never bit because the old development only needed `NfCode_inj`, and pre-`Id` +codes contain no element terms. Once `Id` is in, codes contain relevant elements, relevant elements +contain irrelevant subterms, and `NfCode_inj` inherits the falsity. + +### 14b. The fix, which is §13c taken to its endpoint + +Reification is **type-directed**, and each type class has its own rule, each justified by one +equation of the theory. Proof irrelevance is simply the η rule of the irrelevant types: + +| normal type | reifies to | justified by | +|---|---|---| +| `U D r l` | the normal code | — | +| `El D rel L0 (Nat D)` | `zero` / `suc v` / neutral | — | +| `El D rel lG (Pi_rel …)` | `lam_rel … t` | `"Pi_rel eta"` | +| `El D rel l ĉ`, `ĉ` neutral | the neutral | — | +| **`El D irr l ĉ`, ANY `ĉ`** | **`*`** | **`"proof irrelevance"`** | + +The *reduction* rules never dispatch on relevance — only reification does, exactly as it already +dispatches on `Nat` vs `Pi_rel`. `Val_inj` over `*`-collapsed values is then TRUE, and +`NfCode_inj`/`TyOk_inj`/`EnvOk_inj` are its specialisations at `U`/`ty`/`env`, which are relevant. + +### 14c. (E1) and (E2), the two facts this rests on — (E2) VERIFIED + +**(E1)** `El G irr l c` covers exactly `Empty`, `Pi_irr`, `Id` and irrelevant neutral codes, since +`Nat` and `Pi_rel` are the only relevant canonical codes. So the whole `Id`/`Idcong`/`Pi_irr`/ +`Empty` *element* fragment collapses to `*`. + +**(E2)** Every irrelevant-typed subterm occurring in a *relevant* position is erasable. **Checked +mechanically** over the compiled language, Id fragment included, by classifying every `term_rule`'s +argument sorts against its conclusion (counting a relevance METAVARIABLE as possibly-irrelevant — +counting only constant `irr` under-reports and falsely confirms). The complete answer: + +``` +Idcong concl irr args [e] -- whole term erases +app_irr concl irr args [a; f] -- whole term erases +lam_irr concl irr args [t] -- whole term erases +app_rel concl REL args [a] <-- erasable position 1 +Emptyrec concl rA (var) args [e] <-- erasable position 2 +``` + +Exactly the two positions predicted, and no others. `Id`'s endpoints do not appear: they are pinned +at relevant codes `A B : U G rel l`. + +### 14d. What this deletes + +`NfET` loses `nfet_ne_empty` and `nfet_lam_irr`; `NeET` loses `neet_app_irr` and `neet_idcong`; +`RTy` loses `rty_empty` and `rty_pi_irr` for one trivial `rty_irr`; `ModelPi.v` loses its entire +irrelevant half; `ModelProofIrr.v` becomes three lines. The `Id` fragment costs the normalizer +exactly ONE clause — the code-level computation table — plus one structural observation: code +normalization is no longer a plain structural induction (§2) but is mutually recursive with +term-level normalization, because `Id-Nat-*` inspects endpoints and funext recurses through +`AppV`. That is the real structural cost of `Id`. + +Soundness cannot be `eqt e v`, since `*` is not a term of `ott_dtt`; it becomes a realization +relation `Rz`, with `Rz_eqt` discharging `*` by proof irrelevance. + +### 14e. CORRECTION: `Rz` is on the critical path, not a late concern + +§14d ends by noting that soundness becomes a realization relation `Rz` rather than `eqt`, because +`*` is not a term of `ott_dtt`. It reads as if that bites only the ELEMENT layer. It does not, and +the difference matters for build order: + +> **A CODE can contain `*`.** `Id`'s endpoints are relevant elements; a relevant element can be +> `app_rel … a` with `rF = irr`, whose argument is `*`; and `Emptyrec G rA lA A *` is a normal +> element at a RELEVANT type — which is §14a's own counterexample. + +So there is no `eqt`-shaped soundness statement for weakening at ANY layer, codes included, until +`Rz` exists. `WkVal.v`'s `wkV_sound` is `eqt`-shaped only because its `wkV` is code-only and never +enters an `Id` or an `app_rel`. **`Rz` must be built before any soundness conjunct in the value +layer.** + +### 14f. What the weakening block actually cost (measured, not estimated) + +Four mutual judgements — `WkTy` / `WkTm` / `WkVar` / `VarTy` — not the thirteen a naive reading of +"weaken codes, types, elements and neutrals simultaneously" suggests. Three structural facts did +the shrinking: + +* **The weakening relation never mentions the value judgements.** It is syntax-directed on the + weakening and the subject, so it is self-contained and is defined BEFORE `Values.v`, which + consumes it as a premise. +* **Codes and elements share one judgement.** Their head symbols are pairwise disjoint + (`Nat`/`Empty`/`Pi_rel`/`Pi_irr`/`Id` against `zero`/`suc`/`*`/`lam_rel`/`app_rel`/`Emptyrec`/ + `hd`/`exp_subst`), so merging them costs nothing and turns determinism into a discrimination + argument. `WkTm` needs no type index at all: every annotation a weakened code or element carries + is already stored in the subject. Only VARIABLES introduce one. +* **§14d overstated the cost of `Id`.** The stuck-`Id` half is ONE clause, weakening two codes and + two element endpoints with the same relation. The `*`-collapse is what makes it free: there is no + `lam_irr`, `app_irr` or `Idcong` clause, because those live at irrelevant `El`s where the only + value is `*`, and `*` weakens to `*` in one line. + +Two obstructions that are worth not rediscovering: + +* **`VarTy` is forced.** With a purely syntactic `IsVar` side condition, `WkTm` determinism is + FALSE: `wkvar_wkn` emits `exp_subst wkn i A x`, whose annotation `A` the relation never pinned, + so the output depends on an unconstrained input. `VarTy G i A x` pins it, and it is exactly + `Values.v`'s `ValVar` minus the value-hood premises. The resulting circularity (`WkTm` det needs + variable-type uniqueness needs `WkTy` det needs `WkTm` det) is closed by strengthening the + `WkVar` conjunct to conclude `i = i2 /\ A = A2`, making every use an IH of a sub-derivation. +* **A single `wktm_var` clause is unsound for `inversion`** — a bare-variable subject overlaps + every other clause syntactically, so inverting at a known head spawns a bogus `WkVar` subcase per + clause. Splitting into `wktm_var_hd` / `wktm_var_wkn` keeps the judgement head-directed. + +### 14g. `Rz_eqt` — the erasure survives its own refutation test + +```coq +Rz_eqt : Rz G i A v e1 -> Rz G i A v e2 -> eqt (sExp G i A) e1 e2 +``` + +`Qed`, 0 new axioms. It needs neither `Nrm` nor the weakening layer, and it goes entirely through +`Eqns.v`. + +**§14a's counterexample is now the theorem that vindicates the design.** `emptyrec_star_eqt` says +the two `Emptyrec`s that refuted `NfET_inj` — differing only in their irrelevant argument, at a +RELEVANT type — are provably equal, by `Emptyrec_cong` + `eq_proof_irr`. The fact that killed the +existential design is exactly the fact the `*`-collapse needs. `app_rel_star_eqt` is the same at an +irrelevant domain. Proof irrelevance is spent in exactly one place, `rz_star`, whose only premise +is well-typedness of `e`. + +`rz_id` is in the block deliberately: by §14e the chain is code → `Id` → relevant element → +`Emptyrec`/`app_rel` → `*`, so `Rz` must carry a code whose element subterms contain `*`, or the +phenomenon is assumed away rather than handled. + +Three things to carry forward: + +* **`Rz` must be conversion-FREE, with the closure taken afterwards.** A `rz_conv` clause inside + the inductive appears on BOTH sides of `Rz_eqt`, and the case "first derivation is a leaf, second + is a conversion" has no induction hypothesis available — the recursion there is on the second + derivation. Define `Rz` conv-free and `RzE v e := exists e0, Rz v e0 /\ eqt e e0` on top; then + `Rz_eqt` is a plain induction and `RzE_eqt` is three lines. This is the same failure shape as + §14f's `wktm_var` overlap: **a clause whose subject is an unconstrained variable defeats + `inversion`**, and the fix is always to make the judgement head-directed and take the closure + outside. +* **`Eqns.v` and `Wf.v` have NO `Id` support** — zero occurrences of `oIdEq`/`oIdcong`; both predate + the fragment. `wf_IdEq` and `IdEq_cong` currently live at the top of `Rz.v` and belong upstream. + The fragment is cheap to support (one `wf_by "Id"`, one `cong_step "Id"`, first try) — it simply + has not been done, and more of these will be needed. +* **Scope limit, stated plainly.** Every TYPE argument is held fixed between value and term + (`rz_emptyrec` varies only the erased argument, `rz_id` only the endpoints). That is a restriction + on which pairs `Rz` relates, not a hidden assumption. Letting a type argument vary makes the + conclusion's SORT vary, which needs a realization relation on TYPES — `app_rel` is outside the + block for exactly that reason and is covered by a standalone lemma. So the deferred work is not + the erasure's soundness, which is settled, but its propagation through varying type indices. + +### 14h. Two things about supporting the Id fragment in Wf.v / Eqns.v + +**The fragment's index spellings are NOT uniform, and the tie-break is per-rule.** This is §9b once +more, but sharper than that section suggests: `infer_rule` re-extracts each conclusion sort with +`mk_weight`, and the winner depends on the rule's OWN right-hand side, so sibling rules of one +fragment disagree: + +``` +"Id", "Id subst", "Id-Nat-00" stored at iEl rel L1 +"Id-Nat-0S" / "-S0" / "-SS" stored at iCode L0 (= sCode) +``` + +The three whose RHS is a Pi-shaped code got one spelling; the three whose RHS is `Empty` or an `Id` +got the other. This was found by experiment after two failed attempts that assumed uniformity. +**Do not "tidy" these into a single form** — they are what the compiled language stores, and the +instinct on reading this section is exactly to normalise them. + +**The `next0` bridge cannot live upstream.** `wft_c0` ("an irrelevant-L0 code typed at the +`iota L1` spelling is typed at the `next L0` one") needs both a `wf_` lemma and a congruence, but +`Wf.v` and `Eqns.v` are SIBLINGS over `Syntax.v` — neither imports the other. So any consumer +needing the code-sort spelling must be a file importing both. It sits in `Rz.v` today, which is the +wrong home; it belongs in whatever bridge file replaces `NfTyping.v`. + +**`wf_Idcong` / `Idcong_cong` are deliberately absent.** `Idcong`'s stored conclusion sort is not +the obvious one (`NormalForms.v`'s `oIdcongTy`, written against the rule as authored, does not +unify), and pinning it costs a print-and-probe cycle. Nothing needs them: under the `*`-collapse an +`Idcong` is a proof, its value is `*`, and the value layer never inspects it — §14b supersedes §12d +exactly here. Pin them when something first asks. + +### 14i. NEGATIVE RESULT: generated injectivity does not speed up the wf-check + +Tried and abandoned. Recorded so it is not retried, because the idea is a natural one and the +plumbing gap that suggests it is real. + +**The gap is real.** `compute_wf_rule` (`Tools/EGraph/ComputeWf.v:653`) hard-codes +`inj_rules := empty_inj_rules`, so `cong_subgoals` (`Tools/EGraph/Defs.v:862`) can never fire — it +looks the head up in the table and always misses — and `egraph_reducing_cong` falls back to +re-saturating the WHOLE equation up to `red_fuel := 100` times. Meanwhile `gen_fundep_schemas` +exists but is plumbed only into type INFERENCE (`elab_rule_auto`, `Tools/Interactive.v:74`), never +into the check. + +**The bridge works.** The two formats differ: `gen_fundep_schemas` yields +`(name, (shared, concl))`, while `cong_subgoals` wants `(name, [alternatives])` with each +alternative the list of positions to recurse into — which is exactly `concl`, GROUPED BY NAME (one +operator can carry several schemas, e.g. left and right cancellation, which is why it is a list). +Against the funext prefix this generates **40 schemas over 30 operators**, including every former +the rule is built from: `exp_subst`, `ty_subst`, `El`, `U`, `Pi_rel`, `Pi_irr`, `app_rel`, `snoc`, +`cmp`, `wkn`, `hd`, `ext`, `Id`. Generation costs ~3.5 min and is cacheable as a `Definition`. + +**It does not help.** With that table, `id_pi_pi_rel_rule` ran past 1h35m against a measured +1h55m baseline for the same rule at the same prefix, with no sign of finishing — killed. Two +reasons, and together they explain why a richer table would not have helped either: + +* the top-level goal is `Id … = Pi_irr …`, whose heads DIFFER, so there is nothing for + `cong_subgoals` to decompose at the top no matter how complete the table is; +* the cost is not in the top-level congruence at all but inside `egraph_reducing_cong`'s + `red_fuel` saturate/extract rounds, which injectivity does not touch. + +An earlier attempt with a hand-written table for `Id` alone failed the same way, which at the time +looked like insufficient coverage. It was not: coverage was never the problem. + +**What DID work, for the record, is decomposition of the LANGUAGE rather than of the goal** — +splitting the fragment so each rule is checked against the smallest prefix it needs (§14j). + +### 14j. What DID work: split the language, not the goal + +`compute_wf_rule` checks each rule against its PREFIX, and its cost grows sharply with that prefix. +So the lever is to give each rule the smallest prefix it needs, by authoring the fragment in +several extensions and concatenating them — `Core.lang_ext_monotonicity` (`Theory/Core.v:1681`) +lifts a rule verified against a small prefix to its position in the assembled language, and +`wf_rule_lang_monotonicity` (`:553`) is the per-rule version. Both already existed. + +Measured, same machine, same rule set: + +``` +BEFORE, one Derive, rules sequenced + whole fragment > 4 h, killed, never finished + +AFTER, five files + IdCore.v Id, Id subst 35 s + IdComp.v Idcong + 10 computation rules 3.5 min + IdFunextDefs.v the two funext rule DEFINITIONS only 1.3 s + IdFunextIrr.v 2-binder funext ⎫ SIBLINGS over the ~12 min + IdFunextRel.v 3-binder funext ⎭ same base ~2 h (the irreducible cost) + IdCong.v assembly, three monotonicity lifts 10 s + Syntax.v 89-rule ott_dtt + compositional wf 12 s +``` + +Three separate effects, each worth stating because each was a surprise: + +1. **A funext rule in a prefix is poison.** The same 2-binder rule cost ~4 min with no funext ahead + of it and >16 min with one. Making the two funext rules SIBLINGS over a common base — neither in + the other's prefix — is what recovers it. They are independent; only the authoring order made + them a chain. +2. **The split also dissolves the elaboration constraint.** Rules cannot simply be REORDERED to get + a smaller prefix: with a funext rule in scope, `infer_rule` re-elaborates `Id-Nat-00` to a + DIFFERENT rule (measured: the inferred rules compare unequal, inference costs 5.6x more) — the + `next L0` <-> `iota L1` flip of §9b. But siblings over a COMMON base each elaborate exactly as + they did before, so the constraint and the optimisation stop competing. +3. **Put rule DEFINITIONS in their own file.** `IdFunextDefs.v` costs 1.3 s and lets anything import + a pre-elaborated rule without triggering its check — which is what makes probing a slow rule + possible at all, and what lets a stand-in be swapped for a running proof. + +And separately, `ott_dtt_wf` should be COMPOSITIONAL (`prove_by_lang_db` over the fragments' +`wf_lang_ext` lemmas), never `compute_wf_lang`: re-checking 89 rules took >15 min and growing, +against 12 s for the assembly. + +### 14k. Instantiation is not a sibling of weakening — it is a fragment of `Nrm` + +**Weakening never creates a redex; it only shifts.** That is why `WkRel.v` is purely structural and +why it was cheap (§14f). **Instantiation substitutes a VALUE for a variable, and a value in a +neutral's head position turns that neutral into a redex.** So the instantiation relation must +EVALUATE. It is not a sibling of the weakening block; it is the substitution half of `Nrm`. + +The break is located precisely, and it is small: + +* Substituting an element into a value CODE is structural at `Nat`, `Empty`, `Pi_rel`, `Pi_irr` — + and, less obviously, at code VARIABLES. A code variable's type is a universe, but the + de Bruijn-0 variable of `oExtC G rF lF F` has type `El _ rF lF F[wkn]`, an `El`. So a code + variable is never the one being substituted; it always merely strips. For the same reason an + `Id` stuck on a neutral CODE stays stuck. +* It breaks in **exactly one place**: `necode_id_nat_l`/`_r`. There the stuck endpoint is an + ELEMENT at `El _ rel L0 (Nat _)`, it CAN be the 0-variable (when `F` is `Nat`), and substituting + `zero` or `suc n` fires `Id-Nat-00`/`-0S`/`-SS`. Symmetrically an endpoint `app_rel … f a` whose + head `f` is the 0-variable becomes a β-redex under a `lam_rel`. + +This is §14d confirmed from the substitution side, and it says exactly what `Id` costs. +`NfWk.v:3139`'s `NfCode_csubst` — "the code grammar is a free algebra closed under substitution +STRUCTURALLY" (`NormalForms.v:66`) — held only because pre-`Id` codes contain no elements. +`NfWk.v:61` records that its one difficulty was a relevance-injectivity detail, not evaluation. +That is the whole difference. + +**Judgement count: the §14f factorization survives.** `InstTy`/`InstTm`/`InstVar` mirroring +`WkRel`, plus an application judgement (β) and an `Id` judgement (the §12b table) — five or six. +The growth is in CLAUSES, not judgements: the `Id` table alone is ~12. + +**On the lexicographic measure §14d predicted: it is RELOCATED, not avoided.** As a relation there +is no termination obligation, exactly as in T3 — but the measure is what a TOTALITY proof needs, +and totality is §13b's (T). The mutual relation buys definability without a termination argument +and defers the same debt to the same place. Worth stating that way rather than claiming the measure +went away. diff --git a/src/Pyrosome/Lang/OTT/Cast.v b/src/Pyrosome/Lang/OTT/Cast.v index 7b862cd0..458d5d10 100644 --- a/src/Pyrosome/Lang/OTT/Cast.v +++ b/src/Pyrosome/Lang/OTT/Cast.v @@ -73,7 +73,7 @@ Proof. "B" : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] "r" #"L0"), "e" : #"exp" "G" (#"info" #"irr" (#"iota" #"L0")) (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] - (#"Id" ["G" := "G"] ["l" := #"L1"] (#"u0" ["G" := "G"] "r") "A" "B")), + (#"Id" ["G" := "G"] ["l" := #"L1"] (#"u0" ["G" := "G"] "r") (#"u0" ["G" := "G"] "r") "A" "B")), "t" : #"exp" "G" (#"info" "r" (#"iota" #"L0")) (#"El" "A") ----------------------------------------------- #"cast" "A" "B" "e" "t" : #"exp" "G" (#"info" "r" (#"iota" #"L0")) (#"El" "B") @@ -84,7 +84,7 @@ Proof. elab_rule {[r "G" : #"env", "e" : #"exp" "G" (#"info" #"irr" (#"iota" #"L0")) (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] - (#"Id" ["G" := "G"] ["l" := #"L1"] (#"u0" ["G" := "G"] #"rel") + (#"Id" ["G" := "G"] ["l" := #"L1"] (#"u0" ["G" := "G"] #"rel") (#"u0" ["G" := "G"] #"rel") (#"Nat" ["G" := "G"]) (#"Nat" ["G" := "G"]))) ----------------------------------------------- ("cast-Nat-zero") #"cast" ["r" := #"rel"] (#"Nat" ["G" := "G"]) (#"Nat" ["G" := "G"]) "e" #"zero" = #"zero" @@ -94,7 +94,7 @@ Proof. elab_rule {[r "G" : #"env", "e" : #"exp" "G" (#"info" #"irr" (#"iota" #"L0")) (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] - (#"Id" ["G" := "G"] ["l" := #"L1"] (#"u0" ["G" := "G"] #"rel") + (#"Id" ["G" := "G"] ["l" := #"L1"] (#"u0" ["G" := "G"] #"rel") (#"u0" ["G" := "G"] #"rel") (#"Nat" ["G" := "G"]) (#"Nat" ["G" := "G"]))), "n" : #"exp" "G" (#"info" #"rel" (#"iota" #"L0")) (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := #"L0"] (#"Nat" ["G" := "G"])) ----------------------------------------------- ("cast-Nat-suc") @@ -112,7 +112,7 @@ Proof. #"castrefl" "A" "t" : #"exp" "G" (#"info" #"irr" (#"iota" #"L0")) (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] - (#"Id" ["G" := "G"] ["l" := #"L0"] "A" "t" + (#"Id" ["G" := "G"] ["l" := #"L0"] "A" "A" "t" (#"cast" ["r" := #"rel"] "A" "A" (#"Idrefl" ["G" := "G"] ["l" := #"L1"] (#"u0" ["G" := "G"] #"rel") "A") "t"))) ]}%prerule diff --git a/src/Pyrosome/Lang/OTT/Computations.v b/src/Pyrosome/Lang/OTT/Computations.v index 61aad199..fd6d5e0c 100644 --- a/src/Pyrosome/Lang/OTT/Computations.v +++ b/src/Pyrosome/Lang/OTT/Computations.v @@ -32,6 +32,49 @@ Import PreRule.Notations. (* First: confirm the concatenated base is provable by the wf db. *) (* ====================================================================== *) +(* Id-Π — function extensionality (Typed.agda:231-240), homogeneous form. + Two functions f,g : Π F B are equal iff they agree pointwise: + Id (Π F B) (Π F B) f g ↝ Π(a:F). Id B B (f·a) (g·a) [a proof-irr Π] + The inner equality is on the CODOMAIN (rel), so no constraint on the domain + relevance rF and no cast is needed. Pre-elaborated (all implicit env/subst + args explicit) and added with push_rule, exactly like Pi.v's `Pi_rel eta`, + because the deeply-nested binder+application body defeats elab_rule's + inference. The application body reuses the eta rule's wkF/liftB/app_rel + spelling (so app_rel … : El B by the same conversion). *) +Definition id_pi_funext_rule : string * rule := + let iF : term := {{e #"info" "rF" (#"iota" "lF") }} in + let elF : term := {{e #"El" "G" "rF" "lF" "F" }} in + let gext : term := {{e #"ext" "G" {iF} {elF} }} in + let wkn_g : term := {{e #"wkn" "G" {iF} {elF} }} in + let wkF : term := {{e #"exp_subst" {gext} "G" {wkn_g} (#"info" #"rel" (#"next" "lF")) (#"U" "G" "rF" "lF") "F" }} in + let elwkF : term := {{e #"El" {gext} "rF" "lF" {wkF} }} in + let extnew : term := {{e #"ext" {gext} {iF} {elwkF} }} in + let underwkn : term := {{e #"snoc" {extnew} "G" {iF} {elF} + (#"cmp" {extnew} {gext} "G" (#"wkn" {gext} {iF} {elwkF}) {wkn_g}) + (#"hd" {gext} {iF} {elwkF}) }} in + let liftB : term := {{e #"exp_subst" {extnew} {gext} {underwkn} (#"info" #"rel" (#"next" "lG")) (#"U" {gext} #"rel" "lG") "B" }} in + let piFB : term := {{e #"Pi_rel" "G" "rF" "lF" "lG" "F" "B" }} in + let elpi : term := {{e #"El" "G" #"rel" "lG" {piFB} }} in + let wkf : term := {{e #"exp_subst" {gext} "G" {wkn_g} (#"info" #"rel" (#"iota" "lG")) {elpi} "f" }} in + let wkg : term := {{e #"exp_subst" {gext} "G" {wkn_g} (#"info" #"rel" (#"iota" "lG")) {elpi} "g" }} in + let hd_a : term := {{e #"hd" "G" {iF} {elF} }} in + let appf : term := {{e #"app_rel" {gext} "rF" "lF" "lG" {wkF} {liftB} {wkf} {hd_a} }} in + let appg : term := {{e #"app_rel" {gext} "rF" "lF" "lG" {wkF} {liftB} {wkg} {hd_a} }} in + let bodyId : term := {{e #"Id" {gext} "lG" "B" "B" {appf} {appg} }} in + ("Id-Pi", + term_eq_rule + [("g", {{s #"exp" "G" (#"info" #"rel" (#"iota" "lG")) {elpi} }}); + ("f", {{s #"exp" "G" (#"info" #"rel" (#"iota" "lG")) {elpi} }}); + ("B", {{s #"exp" {gext} (#"info" #"rel" (#"next" "lG")) (#"U" {gext} #"rel" "lG") }}); + ("F", {{s #"exp" "G" (#"info" #"rel" (#"next" "lF")) (#"U" "G" "rF" "lF") }}); + ("lG", {{s #"lvl" }}); + ("lF", {{s #"lvl" }}); + ("rF", {{s #"relevance" }}); + ("G", {{s #"env" }})] + {{e #"Id" "G" "lG" {piFB} {piFB} "f" "g" }} + {{e #"Pi_irr" "G" "rF" "lF" "F" {bodyId} }} + {{s #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" "G" #"irr" #"L0") }}). + Derive ott_comp in (wf_lang_ext (ott_id ++ ott_pi ++ ott_nat ++ ott_base ++ subst_ott ++ ott_info) ott_comp) as ott_comp_wf. @@ -42,21 +85,53 @@ Proof. (Agda Typed.agda Id-ℕ-00.) *) elab_rule {[r "G" : #"env" ----------------------------------------------- ("Id-Nat-00") - #"Id" ["G" := "G"] ["l" := #"L0"] (#"Nat" ["G" := "G"]) #"zero" #"zero" + #"Id" ["G" := "G"] ["l" := #"L0"] (#"Nat" ["G" := "G"]) (#"Nat" ["G" := "G"]) #"zero" #"zero" = #"Pi_irr" #"irr" #"L0" (#"Empty" ["G" := "G"]) (#"Empty" ["G" := #"ext" "G" (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] (#"Empty" ["G" := "G"]))]) : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") ]}%prerule (pi_injectivity ++ id_injectivity ++ nat_injectivity ++ ott_base_injectivity ++ ott_info_injectivity ++ subst_ott_injectivity). - (* NOTE: the cross-former conversions Id-Π (Typed.agda:231-240), cast-Π - (:300-312) and Id-U-ΠΠ (:251-261) are DEFERRED. Id-Π was attempted here - (LHS Id (Pi_rel A B) t u; RHS Pi_irr with codomain Id B of the pointwise - applications wk1 t · v0 / wk1 u · v0): the e-graph pipeline does not finish - in practical time (killed at 500s) — the same compute_wf_rule/infer_rule - wall hit by transp, on deeply-nested binder + substitution + application - terms. cast-Π and Id-U-ΠΠ are strictly harder and additionally need Idsym - (built from the deferred transp). These need a faster wf/inference path. *) + (* Head clash ℕ vs Π at level ⁰: heterogeneous Id between codes with distinct + head constructors reduces to the empty proposition (OTT "clash" rule). + Both codes sit at level ⁰, so the Π result level lG is fixed to L0. *) + elab_rule {[r "G" : #"env", "rF" : #"relevance", "lF" : #"lvl", + "F" : #"exp" "G" (#"info" #"rel" (#"next" "lF")) (#"U" ["G" := "G"] "rF" "lF"), + "B" : #"exp" (#"ext" "G" (#"El" "F")) (#"info" #"rel" (#"next" #"L0")) + (#"U" ["G" := #"ext" "G" (#"El" "F")] #"rel" #"L0"), + "t" : #"exp" "G" (#"info" #"rel" (#"iota" #"L0")) (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := #"L0"] (#"Nat" ["G" := "G"])), + "u" : #"exp" "G" (#"info" #"rel" (#"iota" #"L0")) + (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := #"L0"] (#"Pi_rel" ["G" := "G"] "rF" "lF" #"L0" "F" "B")) + ----------------------------------------------- ("Id-Nat-Pi") + #"Id" ["G" := "G"] ["l" := #"L0"] (#"Nat" ["G" := "G"]) (#"Pi_rel" ["G" := "G"] "rF" "lF" #"L0" "F" "B") "t" "u" + = #"Empty" ["G" := "G"] + : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") + ]}%prerule + (pi_injectivity ++ id_injectivity ++ nat_injectivity ++ ott_base_injectivity ++ ott_info_injectivity ++ subst_ott_injectivity). + elab_rule {[r "G" : #"env", "rF" : #"relevance", "lF" : #"lvl", + "F" : #"exp" "G" (#"info" #"rel" (#"next" "lF")) (#"U" ["G" := "G"] "rF" "lF"), + "B" : #"exp" (#"ext" "G" (#"El" "F")) (#"info" #"rel" (#"next" #"L0")) + (#"U" ["G" := #"ext" "G" (#"El" "F")] #"rel" #"L0"), + "t" : #"exp" "G" (#"info" #"rel" (#"iota" #"L0")) + (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := #"L0"] (#"Pi_rel" ["G" := "G"] "rF" "lF" #"L0" "F" "B")), + "u" : #"exp" "G" (#"info" #"rel" (#"iota" #"L0")) (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := #"L0"] (#"Nat" ["G" := "G"])) + ----------------------------------------------- ("Id-Pi-Nat") + #"Id" ["G" := "G"] ["l" := #"L0"] (#"Pi_rel" ["G" := "G"] "rF" "lF" #"L0" "F" "B") (#"Nat" ["G" := "G"]) "t" "u" + = #"Empty" ["G" := "G"] + : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") + ]}%prerule + (pi_injectivity ++ id_injectivity ++ nat_injectivity ++ ott_base_injectivity ++ ott_info_injectivity ++ subst_ott_injectivity). + + (* Id-Π — homogeneous function extensionality (see id_pi_funext_rule above). *) + push_rule id_pi_funext_rule. + + (* The fully HETEROGENEOUS funext Id (Π F1 B1)(Π F2 B2) f g with DISTINCT + domains F1≠F2 is still open here: its pointwise clause quantifies over the + domain equality Id F1 F2 a1 a2, which (since Id needs its type args at a + common level/relevance) only typechecks when the domains match, else it must + cast a1 across F1~F2 — needing the domain equality as a hypothesis, i.e. the + universe rule Id-U-ΠΠ (:251-261, see IdUniv.v). cast-Π (:300-312) is the + matching computation for that cast. *) apply wf_lang_nil. Unshelve. diff --git a/src/Pyrosome/Lang/OTT/Id.v b/src/Pyrosome/Lang/OTT/Id.v index ffc82510..2d9a5dc5 100644 --- a/src/Pyrosome/Lang/OTT/Id.v +++ b/src/Pyrosome/Lang/OTT/Id.v @@ -69,15 +69,19 @@ Ltac wfstep := (* ====================================================================== *) (* Identity types (Agda Typed.agda:101-108, 109-116). *) -(* Id A t u : SProp (A a proof-relevant code in U_{!,l}; t,u : El A) *) -(* Idrefl A t : Id A t t *) +(* Id A B t u : SProp (A,B proof-relevant codes in U_{!,l}; *) +(* t : El A, u : El B — heterogeneous equality) *) +(* Idrefl A t : Id A A t t *) (* transp : transport along a proof-irrelevant predicate *) (* Plus the first-order ℕ-computation rules for Id (Typed.agda:241-250). *) (* ====================================================================== *) Definition id_injectivity := - [("Id", ["u"; "t"; "A"; "l"; "G"]); - ("Idrefl", ["t"; "A"; "l"; "G"])]. + [("Id", ["u"; "t"; "B"; "A"; "l"; "G"]); + ("Idrefl", ["t"; "A"; "l"; "G"]); + ("transp", ["s"; "e"; "u"; "t"; "P"; "A"; "l"; "G"]); + ("Idsym", ["e"; "u"; "t"; "B"; "A"; "l"; "G"]); + ("Idcong", ["e"; "u"; "t"; "b"; "B"; "lB"; "A"; "l"; "G"])]. Derive ott_id in (wf_lang_ext (ott_nat ++ ott_base ++ subst_ott ++ ott_info) ott_id) @@ -85,34 +89,36 @@ Derive ott_id Proof. setup_lang_interactive. - (* Id A t u : a code in SProp. *) + (* Id A B t u : a code in SProp. (heterogeneous: t : El A, u : El B) *) elab_rule {[r "G" : #"env", "l" : #"lvl", "A" : #"exp" "G" (#"info" #"rel" (#"next" "l")) (#"U" ["G" := "G"] #"rel" "l"), + "B" : #"exp" "G" (#"info" #"rel" (#"next" "l")) (#"U" ["G" := "G"] #"rel" "l"), "t" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) (#"El" "A"), - "u" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) (#"El" "A") + "u" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) (#"El" "B") ----------------------------------------------- - #"Id" "A" "t" "u" : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") + #"Id" "A" "B" "t" "u" : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") ]}%prerule (id_injectivity ++ ott_base_injectivity ++ ott_info_injectivity ++ subst_ott_injectivity). elab_rule {[r "G" : #"env", "G'" : #"env", "g" : #"sub" "G" "G'", "l" : #"lvl", "A" : #"exp" "G'" (#"info" #"rel" (#"next" "l")) (#"U" ["G" := "G'"] #"rel" "l"), + "B" : #"exp" "G'" (#"info" #"rel" (#"next" "l")) (#"U" ["G" := "G'"] #"rel" "l"), "t" : #"exp" "G'" (#"info" #"rel" (#"iota" "l")) (#"El" "A"), - "u" : #"exp" "G'" (#"info" #"rel" (#"iota" "l")) (#"El" "A") + "u" : #"exp" "G'" (#"info" #"rel" (#"iota" "l")) (#"El" "B") ----------------------------------------------- ("Id subst") - #"exp_subst" "g" (#"Id" "A" "t" "u") - = #"Id" (#"exp_subst" "g" "A") (#"exp_subst" "g" "t") (#"exp_subst" "g" "u") + #"exp_subst" "g" (#"Id" "A" "B" "t" "u") + = #"Id" (#"exp_subst" "g" "A") (#"exp_subst" "g" "B") (#"exp_subst" "g" "t") (#"exp_subst" "g" "u") : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") ]}%prerule (id_injectivity ++ ott_base_injectivity ++ ott_info_injectivity ++ subst_ott_injectivity). - (* Idrefl A t : Id A t t (a proof, lives in SProp). *) + (* Idrefl A t : Id A A t t (a proof, lives in SProp). *) elab_rule {[r "G" : #"env", "l" : #"lvl", "A" : #"exp" "G" (#"info" #"rel" (#"next" "l")) (#"U" ["G" := "G"] #"rel" "l"), "t" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) (#"El" "A") ----------------------------------------------- #"Idrefl" "A" "t" : #"exp" "G" (#"info" #"irr" (#"iota" #"L0")) - (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] (#"Id" ["G" := "G"] ["l" := "l"] "A" "t" "t")) + (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] (#"Id" ["G" := "G"] ["l" := "l"] "A" "A" "t" "t")) ]}%prerule (id_injectivity ++ ott_base_injectivity ++ ott_info_injectivity ++ subst_ott_injectivity). @@ -122,7 +128,7 @@ Proof. elab_rule {[r "G" : #"env", "t" : #"exp" "G" (#"info" #"rel" (#"iota" #"L0")) (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := #"L0"] (#"Nat" ["G" := "G"])) ----------------------------------------------- ("Id-Nat-0S") - #"Id" ["G" := "G"] ["l" := #"L0"] (#"Nat" ["G" := "G"]) #"zero" (#"suc" "t") + #"Id" ["G" := "G"] ["l" := #"L0"] (#"Nat" ["G" := "G"]) (#"Nat" ["G" := "G"]) #"zero" (#"suc" "t") = #"Empty" ["G" := "G"] : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") ]}%prerule @@ -130,7 +136,7 @@ Proof. elab_rule {[r "G" : #"env", "t" : #"exp" "G" (#"info" #"rel" (#"iota" #"L0")) (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := #"L0"] (#"Nat" ["G" := "G"])) ----------------------------------------------- ("Id-Nat-S0") - #"Id" ["G" := "G"] ["l" := #"L0"] (#"Nat" ["G" := "G"]) (#"suc" "t") #"zero" + #"Id" ["G" := "G"] ["l" := #"L0"] (#"Nat" ["G" := "G"]) (#"Nat" ["G" := "G"]) (#"suc" "t") #"zero" = #"Empty" ["G" := "G"] : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") ]}%prerule @@ -139,25 +145,174 @@ Proof. "m" : #"exp" "G" (#"info" #"rel" (#"iota" #"L0")) (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := #"L0"] (#"Nat" ["G" := "G"])), "n" : #"exp" "G" (#"info" #"rel" (#"iota" #"L0")) (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := #"L0"] (#"Nat" ["G" := "G"])) ----------------------------------------------- ("Id-Nat-SS") - #"Id" ["G" := "G"] ["l" := #"L0"] (#"Nat" ["G" := "G"]) (#"suc" "m") (#"suc" "n") - = #"Id" ["G" := "G"] ["l" := #"L0"] (#"Nat" ["G" := "G"]) "m" "n" + #"Id" ["G" := "G"] ["l" := #"L0"] (#"Nat" ["G" := "G"]) (#"Nat" ["G" := "G"]) (#"suc" "m") (#"suc" "n") + = #"Id" ["G" := "G"] ["l" := #"L0"] (#"Nat" ["G" := "G"]) (#"Nat" ["G" := "G"]) "m" "n" : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") ]}%prerule (id_injectivity ++ nat_injectivity ++ ott_base_injectivity ++ ott_info_injectivity ++ subst_ott_injectivity). - (* transp (Typed.agda:109-116): DEFERRED — correct proof, but OOMs here. - The structural prover (wfstep, above) fully proves transp's wf_rule: - push_rule_no_compute [:| ]%rule. - 1:{ apply wf_lang_nil. } apply wf_term_rule. all: repeat wfstep. - Unshelve. all: try (vm_compute;reflexivity). all: try (repeat wfstep). all: shelve. - wfstep decomposes to leaves with NO solve_wf_ctx: tries the compact noconv - check (compute_noconv_term_wf) first, falls back to wf_sort_by/wf_args_cons2/ - wf_term_by'/wf_term_conv, and discharges the snoc-id ty_subst_id conversion - via by_reduction (0 remaining goals — verified). Memory: even with - noconv-first the proof peaks at 6.93GB RSS (rocqworker OOM-killed; box has - 7.6GB total / ~6.9GB available, no swap; adding swap was permission-denied). - So it is ~0.2GB over on THIS machine — lands with a little more RAM/swap. - Its computation is in any case subsumed by proof irrelevance. *) + (* transp (Typed.agda:109-116): transport a proof s : El(P t) along a + proof e : Id A A t u to El(P u). P is a proof-irrelevant predicate + (a code in SProp over El A); the result lives in SProp. *) + elab_rule {[r "G" : #"env", "l" : #"lvl", + "A" : #"exp" "G" (#"info" #"rel" (#"next" "l")) (#"U" ["G" := "G"] #"rel" "l"), + "P" : #"exp" (#"ext" "G" (#"El" "A")) (#"info" #"rel" (#"next" #"L0")) + (#"U" ["G" := #"ext" "G" (#"El" "A")] #"irr" #"L0"), + "t" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) (#"El" "A"), + "u" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) (#"El" "A"), + "e" : #"exp" "G" (#"info" #"irr" (#"iota" #"L0")) + (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] + (#"Id" ["G" := "G"] ["l" := "l"] "A" "A" "t" "u")), + "s" : #"exp" "G" (#"info" #"irr" (#"iota" #"L0")) + (#"El" (#"exp_subst" (#"snoc" #"id" "t") "P")) + ----------------------------------------------- + #"transp" "A" "P" "t" "u" "e" "s" + : #"exp" "G" (#"info" #"irr" (#"iota" #"L0")) + (#"El" (#"exp_subst" (#"snoc" #"id" "u") "P")) + ]}%prerule + (id_injectivity ++ ott_base_injectivity ++ ott_info_injectivity ++ subst_ott_injectivity). + + (* Idsym: symmetry of the heterogeneous equality. A proof e : Id A B t u + yields a proof of the swapped Id B A u t. Lives in SProp, so positing it + as a term former is coherent by proof irrelevance; it is the flip needed to + state the codomain equalities of the structural Π / universe rules. *) + elab_rule {[r "G" : #"env", "l" : #"lvl", + "A" : #"exp" "G" (#"info" #"rel" (#"next" "l")) (#"U" ["G" := "G"] #"rel" "l"), + "B" : #"exp" "G" (#"info" #"rel" (#"next" "l")) (#"U" ["G" := "G"] #"rel" "l"), + "t" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) (#"El" "A"), + "u" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) (#"El" "B"), + "e" : #"exp" "G" (#"info" #"irr" (#"iota" #"L0")) + (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] + (#"Id" ["G" := "G"] ["l" := "l"] "A" "B" "t" "u")) + ----------------------------------------------- + #"Idsym" "A" "B" "t" "u" "e" + : #"exp" "G" (#"info" #"irr" (#"iota" #"L0")) + (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] + (#"Id" ["G" := "G"] ["l" := "l"] "B" "A" "u" "t")) + ]}%prerule + (id_injectivity ++ ott_base_injectivity ++ ott_info_injectivity ++ subst_ott_injectivity). + + (* Idcong: congruence (aka `ap`). Generalizes Idrefl from a CLOSED term to a + term b with one extra variable — b : El B in the extended context + ext G (El A), where the codomain code B may itself depend on the variable. + Given endpoints t,u : El A and a proof e : Id A A t u, produce a proof that + the two instantiations are (heterogeneously) equal: + Id (B[t]) (B[u]) (b[t]) (b[u]). + Idrefl A t is the degenerate case b := hd, B := A weakened (both ignore the + endpoints), whose congruence proof at t = u is Id A A t t. As with + Idsym/transp this is a posited term former, coherent by proof irrelevance + (it lives in SProp); the substituted codomains make the equality + heterogeneous, which is exactly why Id was generalized. *) + elab_rule {[r "G" : #"env", "l" : #"lvl", "lB" : #"lvl", + "A" : #"exp" "G" (#"info" #"rel" (#"next" "l")) (#"U" ["G" := "G"] #"rel" "l"), + "B" : #"exp" (#"ext" "G" (#"El" "A")) (#"info" #"rel" (#"next" "lB")) + (#"U" ["G" := #"ext" "G" (#"El" "A")] #"rel" "lB"), + "b" : #"exp" (#"ext" "G" (#"El" "A")) (#"info" #"rel" (#"iota" "lB")) (#"El" "B"), + "t" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) (#"El" "A"), + "u" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) (#"El" "A"), + "e" : #"exp" "G" (#"info" #"irr" (#"iota" #"L0")) + (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] + (#"Id" ["G" := "G"] ["l" := "l"] "A" "A" "t" "u")) + ----------------------------------------------- + #"Idcong" "A" "B" "b" "t" "u" "e" + : #"exp" "G" (#"info" #"irr" (#"iota" #"L0")) + (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] + (#"Id" ["G" := "G"] ["l" := "lB"] + (#"exp_subst" (#"snoc" #"id" "t") "B") + (#"exp_subst" (#"snoc" #"id" "u") "B") + (#"exp_subst" (#"snoc" #"id" "t") "b") + (#"exp_subst" (#"snoc" #"id" "u") "b"))) + ]}%prerule + (id_injectivity ++ ott_base_injectivity ++ ott_info_injectivity ++ subst_ott_injectivity). + + (* ---- Idcong computation: push under each constructor / neutral (Nat frag) ---- *) + + (* suc: cong of (suc n) is the cong of n, transported across Id-Nat-SS + (which reduces Id ℕ ℕ (suc _) (suc _) to Id ℕ ℕ _ _). Pushes under suc. *) + elab_rule {[r "G" : #"env", "l" : #"lvl", + "A" : #"exp" "G" (#"info" #"rel" (#"next" "l")) (#"U" ["G" := "G"] #"rel" "l"), + "n" : #"exp" (#"ext" "G" (#"El" "A")) (#"info" #"rel" (#"iota" #"L0")) + (#"El" ["G" := #"ext" "G" (#"El" "A")] ["r" := #"rel"] ["l" := #"L0"] + (#"Nat" ["G" := #"ext" "G" (#"El" "A")])), + "t" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) (#"El" "A"), + "u" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) (#"El" "A"), + "e" : #"exp" "G" (#"info" #"irr" (#"iota" #"L0")) + (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] + (#"Id" ["G" := "G"] ["l" := "l"] "A" "A" "t" "u")) + ----------------------------------------------- ("Idcong-suc") + #"Idcong" "A" (#"Nat") (#"suc" "n") "t" "u" "e" + = #"Idcong" "A" (#"Nat") "n" "t" "u" "e" + : #"exp" "G" (#"info" #"irr" (#"iota" #"L0")) + (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] + (#"Id" ["G" := "G"] ["l" := #"L0"] (#"Nat" ["G" := "G"]) (#"Nat" ["G" := "G"]) + (#"exp_subst" (#"snoc" #"id" "t") (#"suc" "n")) + (#"exp_subst" (#"snoc" #"id" "u") (#"suc" "n")))) + ]}%prerule + (id_injectivity ++ nat_injectivity ++ ott_base_injectivity ++ ott_info_injectivity ++ subst_ott_injectivity). + + (* zero: a nullary (constant) constructor; there is nothing under it, so cong + bottoms out at reflexivity. Id ℕ ℕ zero zero further reduces to sUnit + (Id-Nat-00, in Computations.v), of which Idrefl ℕ zero is an inhabitant. *) + elab_rule {[r "G" : #"env", "l" : #"lvl", + "A" : #"exp" "G" (#"info" #"rel" (#"next" "l")) (#"U" ["G" := "G"] #"rel" "l"), + "t" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) (#"El" "A"), + "u" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) (#"El" "A"), + "e" : #"exp" "G" (#"info" #"irr" (#"iota" #"L0")) + (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] + (#"Id" ["G" := "G"] ["l" := "l"] "A" "A" "t" "u")) + ----------------------------------------------- ("Idcong-zero") + #"Idcong" "A" (#"Nat") (#"zero") "t" "u" "e" + = #"Idrefl" (#"Nat" ["G" := "G"]) (#"zero" ["G" := "G"]) + : #"exp" "G" (#"info" #"irr" (#"iota" #"L0")) + (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] + (#"Id" ["G" := "G"] ["l" := #"L0"] (#"Nat" ["G" := "G"]) (#"Nat" ["G" := "G"]) + (#"zero" ["G" := "G"]) (#"zero" ["G" := "G"]))) + ]}%prerule + (id_injectivity ++ nat_injectivity ++ ott_base_injectivity ++ ott_info_injectivity ++ subst_ott_injectivity). + + (* variable (neutral base case): cong of the extra variable itself is the + given proof. Here b := hd, B := A weakened along wkn, so both instances + collapse to the endpoints and Id (B[t]) (B[u]) (hd[t]) (hd[u]) = Id A A t u, + whose proof is e. This is where the structural recursion bottoms out. *) + elab_rule {[r "G" : #"env", "l" : #"lvl", + "A" : #"exp" "G" (#"info" #"rel" (#"next" "l")) (#"U" ["G" := "G"] #"rel" "l"), + "t" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) (#"El" "A"), + "u" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) (#"El" "A"), + "e" : #"exp" "G" (#"info" #"irr" (#"iota" #"L0")) + (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] + (#"Id" ["G" := "G"] ["l" := "l"] "A" "A" "t" "u")) + ----------------------------------------------- ("Idcong-var") + #"Idcong" "A" (#"exp_subst" #"wkn" "A") #"hd" "t" "u" "e" + = "e" + : #"exp" "G" (#"info" #"irr" (#"iota" #"L0")) + (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] + (#"Id" ["G" := "G"] ["l" := "l"] "A" "A" "t" "u")) + ]}%prerule + (id_injectivity ++ nat_injectivity ++ ott_base_injectivity ++ ott_info_injectivity ++ subst_ott_injectivity). + + (* closed subterm (normal form not mentioning the variable): a term weakened + along wkn ignores the extra variable, so both instances are the closed term + c and cong bottoms out at Idrefl C c. This is the general leaf for any + type; the literal zero rule above is the corresponding leaf for the ℕ + recursion (where the closed subterm appears as the bare literal, not wkn·_). *) + elab_rule {[r "G" : #"env", "l" : #"lvl", "lB" : #"lvl", + "A" : #"exp" "G" (#"info" #"rel" (#"next" "l")) (#"U" ["G" := "G"] #"rel" "l"), + "C" : #"exp" "G" (#"info" #"rel" (#"next" "lB")) (#"U" ["G" := "G"] #"rel" "lB"), + "c" : #"exp" "G" (#"info" #"rel" (#"iota" "lB")) (#"El" "C"), + "t" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) (#"El" "A"), + "u" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) (#"El" "A"), + "e" : #"exp" "G" (#"info" #"irr" (#"iota" #"L0")) + (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] + (#"Id" ["G" := "G"] ["l" := "l"] "A" "A" "t" "u")) + ----------------------------------------------- ("Idcong-wkn") + #"Idcong" "A" (#"exp_subst" #"wkn" "C") (#"exp_subst" #"wkn" "c") "t" "u" "e" + = #"Idrefl" "C" "c" + : #"exp" "G" (#"info" #"irr" (#"iota" #"L0")) + (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] + (#"Id" ["G" := "G"] ["l" := "lB"] "C" "C" "c" "c")) + ]}%prerule + (id_injectivity ++ nat_injectivity ++ ott_base_injectivity ++ ott_info_injectivity ++ subst_ott_injectivity). + apply wf_lang_nil. Unshelve. 1:shelve. diff --git a/src/Pyrosome/Lang/OTT/IdComp.v b/src/Pyrosome/Lang/OTT/IdComp.v new file mode 100644 index 00000000..87b052c4 --- /dev/null +++ b/src/Pyrosome/Lang/OTT/IdComp.v @@ -0,0 +1,308 @@ +From coqutil Require Import Datatypes.String. +From Stdlib Require Import Lists.List. +Import ListNotations. +Open Scope string. +Open Scope list. +From Utils Require Import Utils. +From Pyrosome Require Import + Theory.Core Elab.Elab + Elab.PreRule + Tools.ComputeWf + Tools.Matches + Tools.Resolution + Tools.EGraph.TypeInference + Tools.EGraph.ComputeWf + Tools.EGraph.Automation + Tools.Interactive. + +From Pyrosome.Compilers Require Import Parameterizer. + +From Pyrosome.Lang Require Import + Subst SubstEqnGen. +From Pyrosome.Lang.OTT Require Import Base Nat Pi SubstCommute ProofIrr IdCore. + +From Stdlib Require derive.Derive. + +Import Core.Notations. +Import PreRule.Notations. + +(* ======================================================================= *) +(* The heterogeneous observational identity type, for the language the *) +(* normalization proof targets (src/Pyrosome/Gluing/Dtt/). *) +(* *) +(* This is a SEPARATE fragment from Lang/OTT/Id.v. Id.v is the exploratory *) +(* OTT playground (it also carries Idrefl / Idsym / transp and feeds *) +(* Cast.v, Computations.v, IdUniv.v, none of which are in ott_dtt); the *) +(* fragment below is the one added to ott_dtt, and it differs in three *) +(* deliberate ways. *) +(* *) +(* (1) NO Idrefl. [Idcong] strictly generalizes it: taking the congruence *) +(* of a term that ignores the bound variable, i.e. *) +(* Idcong Nat C[wkn] c[wkn] zero zero triv : Id C C c c, *) +(* where [triv] inhabits [Id Nat Nat zero zero], which "Id-Nat-00" *) +(* below reduces to the unit proposition. So reflexivity is DERIVED. *) +(* *) +(* (2) NO equations for Idcong at all -- not the substitution commutation, *) +(* not the computation rules that push it under a constructor. Every *) +(* one of them is an equation between two inhabitants of a code at *) +(* [U _ irr _], so [ott_proofirr_el] proves it outright. They are *) +(* DERIVED in Gluing/Dtt/Eqns.v instead of posited here; the *) +(* normalization proof still rewrites with them exactly as if they *) +(* were rules (that is what makes reification at an Id type a *) +(* structural recursion on the congruence's body). *) +(* *) +(* (3) THE COMPUTATION RULES ARE COMPLETE. An [Id] whose arguments are all *) +(* canonical always reduces; equivalently, in a closed environment an *) +(* Id type never survives, and the only [Id] codes that are normal are *) +(* the NEUTRAL ones (stuck on a neutral endpoint or a neutral code). *) +(* That is what keeps the extension from adding any normal form beyond *) +(* neutrals. *) +(* *) +(* Id is HETEROGENEOUS: [Id A B t u] relates [t : El A] and [u : El B] for *) +(* two codes A,B of a common level, and it is that generality which lets *) +(* the function-extensionality rule below quantify over a pair of arguments *) +(* plus a proof that they are equal, rather than casting one argument *) +(* across a domain equality (which would need [Cast], whose [u0] gives a *) +(* code for a universe and breaks the code grammar the proof rests on). *) +(* ======================================================================= *) + +(* The congruence former and the Id computation table. Derived over + [ott_id_core ++ ott_id_base] -- deliberately WITHOUT the funext rules in + scope, since their presence changes how "Id-Nat-00" elaborates (measured: + the re-inferred rules compare unequal). [ott_id_base], [id_inj_all] and + the injectivity table all come from IdCore. *) + +Derive ott_id_comp + in (wf_lang_ext (ott_id_core ++ ott_id_base) ott_id_comp) + as ott_id_comp_wf. +Proof. + setup_lang_interactive. + (* --------------------------------------------------------------- *) + (* The congruence -- the only proof former, and the generalization *) + (* of reflexivity. *) + (* --------------------------------------------------------------- *) + + (* [Idcong A B b t u e] : from [e : Id A A t u] and a term [b : El B] + with one free variable of type [El A], conclude that the two + instantiations of [b] are (heterogeneously) equal: + Id (B[t]) (B[u]) (b[t]) (b[u]). + The codomain code B may itself mention the variable, which is + exactly why the equality has to be heterogeneous. + + It lives in SProp, so positing it as a term former is coherent by + proof irrelevance, and no computation rule for it is needed: every + equation one would write -- pushing it under [suc], under a [lam], + under a substitution, or bottoming out at the variable ([Idcong] of + [hd] is [e]) or at a closed subterm (reflexivity) -- is an equation + between two inhabitants of the same irrelevant code, hence already + provable. Gluing/Dtt/Eqns.v derives them. *) + elab_rule {[r "G" : #"env", "l" : #"lvl", "lB" : #"lvl", + "A" : #"exp" "G" (#"info" #"rel" (#"next" "l")) (#"U" ["G" := "G"] #"rel" "l"), + "B" : #"exp" (#"ext" "G" (#"El" "A")) (#"info" #"rel" (#"next" "lB")) + (#"U" ["G" := #"ext" "G" (#"El" "A")] #"rel" "lB"), + "b" : #"exp" (#"ext" "G" (#"El" "A")) (#"info" #"rel" (#"iota" "lB")) (#"El" "B"), + "t" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) (#"El" "A"), + "u" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) (#"El" "A"), + "e" : #"exp" "G" (#"info" #"irr" (#"iota" #"L0")) + (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] + (#"Id" ["G" := "G"] ["l" := "l"] "A" "A" "t" "u")) + ----------------------------------------------- + #"Idcong" "A" "B" "b" "t" "u" "e" + : #"exp" "G" (#"info" #"irr" (#"iota" #"L0")) + (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] + (#"Id" ["G" := "G"] ["l" := "lB"] + (#"exp_subst" (#"snoc" #"id" "t") "B") + (#"exp_subst" (#"snoc" #"id" "u") "B") + (#"exp_subst" (#"snoc" #"id" "t") "b") + (#"exp_subst" (#"snoc" #"id" "u") "b"))) + ]}%prerule + id_inj_all. + + (* --------------------------------------------------------------- *) + (* Computation, part 1: both codes are Nat. *) + (* *) + (* The four canonical/canonical cases. Together with the clashes *) + (* below they leave an [Id] at Nat stuck exactly when an ENDPOINT is *) + (* neutral, which is what makes the extension add no normal form *) + (* beyond neutrals. *) + (* --------------------------------------------------------------- *) + + (* 0 = 0 : the unit proposition (Pi_irr Empty Empty). *) + elab_rule {[r "G" : #"env" + ----------------------------------------------- ("Id-Nat-00") + #"Id" ["G" := "G"] ["l" := #"L0"] (#"Nat" ["G" := "G"]) (#"Nat" ["G" := "G"]) #"zero" #"zero" + = #"Pi_irr" #"irr" #"L0" (#"Empty" ["G" := "G"]) + (#"Empty" ["G" := #"ext" "G" (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] (#"Empty" ["G" := "G"]))]) + : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") + ]}%prerule + id_inj_all. + + (* 0 = suc t, suc t = 0 : the constructors are disjoint. *) + elab_rule {[r "G" : #"env", + "t" : #"exp" "G" (#"info" #"rel" (#"iota" #"L0")) (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := #"L0"] (#"Nat" ["G" := "G"])) + ----------------------------------------------- ("Id-Nat-0S") + #"Id" ["G" := "G"] ["l" := #"L0"] (#"Nat" ["G" := "G"]) (#"Nat" ["G" := "G"]) #"zero" (#"suc" "t") + = #"Empty" ["G" := "G"] + : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") + ]}%prerule + id_inj_all. + elab_rule {[r "G" : #"env", + "t" : #"exp" "G" (#"info" #"rel" (#"iota" #"L0")) (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := #"L0"] (#"Nat" ["G" := "G"])) + ----------------------------------------------- ("Id-Nat-S0") + #"Id" ["G" := "G"] ["l" := #"L0"] (#"Nat" ["G" := "G"]) (#"Nat" ["G" := "G"]) (#"suc" "t") #"zero" + = #"Empty" ["G" := "G"] + : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") + ]}%prerule + id_inj_all. + + (* suc is injective. *) + elab_rule {[r "G" : #"env", + "m" : #"exp" "G" (#"info" #"rel" (#"iota" #"L0")) (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := #"L0"] (#"Nat" ["G" := "G"])), + "n" : #"exp" "G" (#"info" #"rel" (#"iota" #"L0")) (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := #"L0"] (#"Nat" ["G" := "G"])) + ----------------------------------------------- ("Id-Nat-SS") + #"Id" ["G" := "G"] ["l" := #"L0"] (#"Nat" ["G" := "G"]) (#"Nat" ["G" := "G"]) (#"suc" "m") (#"suc" "n") + = #"Id" ["G" := "G"] ["l" := #"L0"] (#"Nat" ["G" := "G"]) (#"Nat" ["G" := "G"]) "m" "n" + : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") + ]}%prerule + id_inj_all. + + (* --------------------------------------------------------------- *) + (* Computation, part 2: the two codes have different heads. *) + (* *) + (* Nat against Pi, and Pi against Nat. These are TYPE-DIRECTED -- *) + (* the endpoints t,u are arbitrary -- which is why they cost nothing *) + (* structurally. *) + (* --------------------------------------------------------------- *) + + elab_rule {[r "G" : #"env", "rF" : #"relevance", "lF" : #"lvl", + "F" : #"exp" "G" (#"info" #"rel" (#"next" "lF")) (#"U" ["G" := "G"] "rF" "lF"), + "B" : #"exp" (#"ext" "G" (#"El" "F")) (#"info" #"rel" (#"next" #"L0")) + (#"U" ["G" := #"ext" "G" (#"El" "F")] #"rel" #"L0"), + "t" : #"exp" "G" (#"info" #"rel" (#"iota" #"L0")) (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := #"L0"] (#"Nat" ["G" := "G"])), + "u" : #"exp" "G" (#"info" #"rel" (#"iota" #"L0")) + (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := #"L0"] (#"Pi_rel" ["G" := "G"] "rF" "lF" #"L0" "F" "B")) + ----------------------------------------------- ("Id-Nat-Pi") + #"Id" ["G" := "G"] ["l" := #"L0"] (#"Nat" ["G" := "G"]) (#"Pi_rel" ["G" := "G"] "rF" "lF" #"L0" "F" "B") "t" "u" + = #"Empty" ["G" := "G"] + : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") + ]}%prerule + id_inj_all. + elab_rule {[r "G" : #"env", "rF" : #"relevance", "lF" : #"lvl", + "F" : #"exp" "G" (#"info" #"rel" (#"next" "lF")) (#"U" ["G" := "G"] "rF" "lF"), + "B" : #"exp" (#"ext" "G" (#"El" "F")) (#"info" #"rel" (#"next" #"L0")) + (#"U" ["G" := #"ext" "G" (#"El" "F")] #"rel" #"L0"), + "t" : #"exp" "G" (#"info" #"rel" (#"iota" #"L0")) + (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := #"L0"] (#"Pi_rel" ["G" := "G"] "rF" "lF" #"L0" "F" "B")), + "u" : #"exp" "G" (#"info" #"rel" (#"iota" #"L0")) (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := #"L0"] (#"Nat" ["G" := "G"])) + ----------------------------------------------- ("Id-Pi-Nat") + #"Id" ["G" := "G"] ["l" := #"L0"] (#"Pi_rel" ["G" := "G"] "rF" "lF" #"L0" "F" "B") (#"Nat" ["G" := "G"]) "t" "u" + = #"Empty" ["G" := "G"] + : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") + ]}%prerule + id_inj_all. + + (* --------------------------------------------------------------- *) + (* Computation, part 3: both codes are Pi, but their DOMAIN INDICES *) + (* disagree. *) + (* *) + (* [Pi_rel G rF lF lG F B] records the domain's relevance and level *) + (* in the code, so two Pi codes whose (rF,lF) differ are as distinct *) + (* as a Nat and a Pi: the equality clashes to Empty. Four rules *) + (* cover it -- relevance mismatch either way (levels arbitrary), and *) + (* level mismatch either way (relevance shared). They do NOT overlap -- *) + (* an earlier version of this comment claimed they did, and that was *) + (* wrong. The relevance-mismatch pair pins the two relevances to the *) + (* distinct LITERALS rel/irr, while the level-mismatch pair shares one *) + (* relevance METAVARIABLE rF, so the two families are mutually *) + (* exclusive and the four transcribe directly as a partition. That *) + (* matters downstream: the value layer's Id table needs a partition for *) + (* determinism, and gets one without restructuring. (Kept for the *) + (* record: harmless even if they had overlapped, since all give Empty.) *) + (* is harmless: every one of them gives Empty. The remaining case, *) + (* (rF,lF) shared, is genuine function extensionality, below. *) + (* --------------------------------------------------------------- *) + + elab_rule {[r "G" : #"env", "l" : #"lvl", "lF1" : #"lvl", "lF2" : #"lvl", + "F1" : #"exp" "G" (#"info" #"rel" (#"next" "lF1")) (#"U" ["G" := "G"] #"rel" "lF1"), + "B1" : #"exp" (#"ext" "G" (#"El" "F1")) (#"info" #"rel" (#"next" "l")) + (#"U" ["G" := #"ext" "G" (#"El" "F1")] #"rel" "l"), + "F2" : #"exp" "G" (#"info" #"rel" (#"next" "lF2")) (#"U" ["G" := "G"] #"irr" "lF2"), + "B2" : #"exp" (#"ext" "G" (#"El" "F2")) (#"info" #"rel" (#"next" "l")) + (#"U" ["G" := #"ext" "G" (#"El" "F2")] #"rel" "l"), + "t" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) + (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := "l"] (#"Pi_rel" ["G" := "G"] #"rel" "lF1" "l" "F1" "B1")), + "u" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) + (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := "l"] (#"Pi_rel" ["G" := "G"] #"irr" "lF2" "l" "F2" "B2")) + ----------------------------------------------- ("Id-Pi-Pi-rel-irr") + #"Id" ["G" := "G"] ["l" := "l"] + (#"Pi_rel" ["G" := "G"] #"rel" "lF1" "l" "F1" "B1") + (#"Pi_rel" ["G" := "G"] #"irr" "lF2" "l" "F2" "B2") "t" "u" + = #"Empty" ["G" := "G"] + : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") + ]}%prerule + id_inj_all. + elab_rule {[r "G" : #"env", "l" : #"lvl", "lF1" : #"lvl", "lF2" : #"lvl", + "F1" : #"exp" "G" (#"info" #"rel" (#"next" "lF1")) (#"U" ["G" := "G"] #"irr" "lF1"), + "B1" : #"exp" (#"ext" "G" (#"El" "F1")) (#"info" #"rel" (#"next" "l")) + (#"U" ["G" := #"ext" "G" (#"El" "F1")] #"rel" "l"), + "F2" : #"exp" "G" (#"info" #"rel" (#"next" "lF2")) (#"U" ["G" := "G"] #"rel" "lF2"), + "B2" : #"exp" (#"ext" "G" (#"El" "F2")) (#"info" #"rel" (#"next" "l")) + (#"U" ["G" := #"ext" "G" (#"El" "F2")] #"rel" "l"), + "t" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) + (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := "l"] (#"Pi_rel" ["G" := "G"] #"irr" "lF1" "l" "F1" "B1")), + "u" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) + (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := "l"] (#"Pi_rel" ["G" := "G"] #"rel" "lF2" "l" "F2" "B2")) + ----------------------------------------------- ("Id-Pi-Pi-irr-rel") + #"Id" ["G" := "G"] ["l" := "l"] + (#"Pi_rel" ["G" := "G"] #"irr" "lF1" "l" "F1" "B1") + (#"Pi_rel" ["G" := "G"] #"rel" "lF2" "l" "F2" "B2") "t" "u" + = #"Empty" ["G" := "G"] + : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") + ]}%prerule + id_inj_all. + elab_rule {[r "G" : #"env", "l" : #"lvl", "rF" : #"relevance", + "F1" : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] "rF" #"L0"), + "B1" : #"exp" (#"ext" "G" (#"El" "F1")) (#"info" #"rel" (#"next" "l")) + (#"U" ["G" := #"ext" "G" (#"El" "F1")] #"rel" "l"), + "F2" : #"exp" "G" (#"info" #"rel" (#"next" #"L1")) (#"U" ["G" := "G"] "rF" #"L1"), + "B2" : #"exp" (#"ext" "G" (#"El" "F2")) (#"info" #"rel" (#"next" "l")) + (#"U" ["G" := #"ext" "G" (#"El" "F2")] #"rel" "l"), + "t" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) + (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := "l"] (#"Pi_rel" ["G" := "G"] "rF" #"L0" "l" "F1" "B1")), + "u" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) + (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := "l"] (#"Pi_rel" ["G" := "G"] "rF" #"L1" "l" "F2" "B2")) + ----------------------------------------------- ("Id-Pi-Pi-L0-L1") + #"Id" ["G" := "G"] ["l" := "l"] + (#"Pi_rel" ["G" := "G"] "rF" #"L0" "l" "F1" "B1") + (#"Pi_rel" ["G" := "G"] "rF" #"L1" "l" "F2" "B2") "t" "u" + = #"Empty" ["G" := "G"] + : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") + ]}%prerule + id_inj_all. + elab_rule {[r "G" : #"env", "l" : #"lvl", "rF" : #"relevance", + "F1" : #"exp" "G" (#"info" #"rel" (#"next" #"L1")) (#"U" ["G" := "G"] "rF" #"L1"), + "B1" : #"exp" (#"ext" "G" (#"El" "F1")) (#"info" #"rel" (#"next" "l")) + (#"U" ["G" := #"ext" "G" (#"El" "F1")] #"rel" "l"), + "F2" : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] "rF" #"L0"), + "B2" : #"exp" (#"ext" "G" (#"El" "F2")) (#"info" #"rel" (#"next" "l")) + (#"U" ["G" := #"ext" "G" (#"El" "F2")] #"rel" "l"), + "t" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) + (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := "l"] (#"Pi_rel" ["G" := "G"] "rF" #"L1" "l" "F1" "B1")), + "u" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) + (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := "l"] (#"Pi_rel" ["G" := "G"] "rF" #"L0" "l" "F2" "B2")) + ----------------------------------------------- ("Id-Pi-Pi-L1-L0") + #"Id" ["G" := "G"] ["l" := "l"] + (#"Pi_rel" ["G" := "G"] "rF" #"L1" "l" "F1" "B1") + (#"Pi_rel" ["G" := "G"] "rF" #"L0" "l" "F2" "B2") "t" "u" + = #"Empty" ["G" := "G"] + : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") + ]}%prerule + id_inj_all. + + apply wf_lang_nil. +Unshelve. +1:shelve. +1:vm_compute; reflexivity. +Qed. +#[local] Definition ott_id_comp_entry := lang_entry ott_id_comp_wf. +#[export] Hint Resolve ott_id_comp_entry : wf_lang_db. diff --git a/src/Pyrosome/Lang/OTT/IdCong.v b/src/Pyrosome/Lang/OTT/IdCong.v new file mode 100644 index 00000000..5657955b --- /dev/null +++ b/src/Pyrosome/Lang/OTT/IdCong.v @@ -0,0 +1,105 @@ +From coqutil Require Import Datatypes.String. +From Stdlib Require Import Lists.List. +Import ListNotations. +Open Scope string. +Open Scope list. +From Utils Require Import Utils. +From Pyrosome Require Import + Theory.Core Elab.Elab + Elab.PreRule + Tools.ComputeWf + Tools.Matches + Tools.Resolution + Tools.Interactive. + +From Pyrosome.Lang Require Import + Subst SubstEqnGen. +From Pyrosome.Lang.OTT Require Import + Base Nat Pi SubstCommute ProofIrr IdCore IdComp IdFunextIrr IdFunextRel. + +Import Core.Notations. + +(* ======================================================================= *) +(* The heterogeneous observational identity type: ASSEMBLY. *) +(* *) +(* The fragment is authored in three pieces and concatenated here. The *) +(* split is a PERFORMANCE measure, and the numbers are the justification: *) +(* [compute_wf_rule] checks each rule against its PREFIX, and its cost *) +(* grows sharply with that prefix. The 3-binder function-extensionality *) +(* rule was measured at 1h55m against a two-rule prefix, and had not *) +(* finished after 2h35m against the full one. *) +(* *) +(* IdCore.v ott_id_core Id, Id subst (~35 s) *) +(* IdComp.v ott_id_comp Idcong + the computation rules (~4 min) *) +(* IdFunextDefs.v the two rule DEFINITIONS only (1.3 s) *) +(* IdFunextIrr.v 2-binder funext } SIBLINGS over a common (~12 min) *) +(* IdFunextRel.v 3-binder funext } base, neither in the (~2h13m) *) +(* other's prefix *) +(* IdCong.v ott_id_cong = funext_rel ++ funext_irr ++ comp ++ core *) +(* *) +(* The payoff is not the first build, it is every later one: editing a *) +(* computation rule no longer re-triggers the two-hour funext check. *) +(* *) +(* Two constraints shape the decomposition, and neither is negotiable. *) +(* *) +(* (1) [ott_id_comp] must be derived over a base WITHOUT the funext rules. *) +(* With a funext rule in scope, [infer_rule] re-elaborates "Id-Nat-00" *) +(* to a DIFFERENT rule -- verified directly, the two inferred rules *) +(* compare unequal, and inference costs 5.6x more. That is the *) +(* [next L0] <-> [iota L1] flip Gluing/Dtt/Syntax.v warns about, and it *) +(* would silently invalidate the rule shapes baked into Eqns.v / Wf.v / *) +(* Model*.v. Deriving [ott_id_comp] and [ott_id_funext] over a COMMON *) +(* base keeps each one's elaboration exactly as it is. *) +(* *) +(* (2) Consequently the two extensions are SIBLINGS, not a chain, so one of *) +(* them has to be lifted to its position in the assembled language. *) +(* [Core.lang_ext_monotonicity] does exactly that: a rule verified *) +(* against a smaller prefix stays well-formed against a larger one. *) +(* We lift [ott_id_funext], so [ott_id_comp] keeps the prefix it was *) +(* checked against and only the (already paid for) funext rules move. *) +(* *) +(* Downstream sees exactly what it saw before: [ott_id_cong] together with *) +(* [ott_id_cong_wf : wf_lang_ext ott_id_base ott_id_cong]. *) +(* ======================================================================= *) + +(* Composition of two extensions. [wf_lang_ext lp ((n,r)::l)] demands + [wf_rule (l ++ lp) r], so stacking an extension of [l1 ++ lp] on top of an + extension of [lp] is exactly an associativity shuffle. *) +Lemma wf_lang_ext_compose (lp l1 l2 : lang) + : wf_lang_ext lp l1 -> + wf_lang_ext (l1 ++ lp) l2 -> + wf_lang_ext lp (l2 ++ l1). +Proof. + intros H1 H2; induction H2; basic_goal_prep; auto. + constructor; auto; + rewrite <- app_assoc; assumption. +Qed. + +Definition ott_id_cong := Eval vm_compute in + (ott_id_funext_rel ++ ott_id_funext_irr ++ ott_id_comp ++ ott_id_core). + +Lemma ott_id_cong_wf : wf_lang_ext ott_id_base ott_id_cong. +Proof. + replace ott_id_cong + with (ott_id_funext_rel ++ (ott_id_funext_irr ++ (ott_id_comp ++ ott_id_core))) + by (vm_compute; reflexivity). + (* Each piece was checked against the smallest prefix it needs, and is lifted + into position here. The three lifts are the whole point of the split. *) + apply wf_lang_ext_compose; + [ apply wf_lang_ext_compose; + [ apply wf_lang_ext_compose; + [ exact ott_id_core_wf | exact ott_id_comp_wf ] + | (* funext_irr: checked over core ++ base *) + eapply lang_ext_monotonicity; + [ exact ott_id_funext_irr_wf + | unfold incl; intros; rewrite ?in_app_iff in *; tauto + | apply use_compute_all_fresh; vm_compute; exact I ] ] + | (* funext_rel: also checked over core ++ base, NOT over funext_irr *) + eapply lang_ext_monotonicity; + [ exact ott_id_funext_rel_wf + | unfold incl; intros; rewrite ?in_app_iff in *; tauto + | apply use_compute_all_fresh; vm_compute; exact I ] ]. +Qed. + +#[local] Definition ott_id_cong_entry := lang_entry ott_id_cong_wf. +#[export] Hint Resolve ott_id_cong_entry : wf_lang_db. diff --git a/src/Pyrosome/Lang/OTT/IdCore.v b/src/Pyrosome/Lang/OTT/IdCore.v new file mode 100644 index 00000000..689df323 --- /dev/null +++ b/src/Pyrosome/Lang/OTT/IdCore.v @@ -0,0 +1,149 @@ +From coqutil Require Import Datatypes.String. +From Stdlib Require Import Lists.List. +Import ListNotations. +Open Scope string. +Open Scope list. +From Utils Require Import Utils. +From Pyrosome Require Import + Theory.Core Elab.Elab + Elab.PreRule + Tools.ComputeWf + Tools.Matches + Tools.Resolution + Tools.EGraph.TypeInference + Tools.EGraph.ComputeWf + Tools.EGraph.Automation + Tools.Interactive. + +From Pyrosome.Compilers Require Import Parameterizer. + +From Pyrosome.Lang Require Import + Subst SubstEqnGen. +From Pyrosome.Lang.OTT Require Import Base Nat Pi SubstCommute ProofIrr. + +From Stdlib Require derive.Derive. + +Import Core.Notations. +Import PreRule.Notations. + +(* ======================================================================= *) +(* The heterogeneous observational identity type, for the language the *) +(* normalization proof targets (src/Pyrosome/Gluing/Dtt/). *) +(* *) +(* This is a SEPARATE fragment from Lang/OTT/Id.v. Id.v is the exploratory *) +(* OTT playground (it also carries Idrefl / Idsym / transp and feeds *) +(* Cast.v, Computations.v, IdUniv.v, none of which are in ott_dtt); the *) +(* fragment below is the one added to ott_dtt, and it differs in three *) +(* deliberate ways. *) +(* *) +(* (1) NO Idrefl. [Idcong] strictly generalizes it: taking the congruence *) +(* of a term that ignores the bound variable, i.e. *) +(* Idcong Nat C[wkn] c[wkn] zero zero triv : Id C C c c, *) +(* where [triv] inhabits [Id Nat Nat zero zero], which "Id-Nat-00" *) +(* below reduces to the unit proposition. So reflexivity is DERIVED. *) +(* *) +(* (2) NO equations for Idcong at all -- not the substitution commutation, *) +(* not the computation rules that push it under a constructor. Every *) +(* one of them is an equation between two inhabitants of a code at *) +(* [U _ irr _], so [ott_proofirr_el] proves it outright. They are *) +(* DERIVED in Gluing/Dtt/Eqns.v instead of posited here; the *) +(* normalization proof still rewrites with them exactly as if they *) +(* were rules (that is what makes reification at an Id type a *) +(* structural recursion on the congruence's body). *) +(* *) +(* (3) THE COMPUTATION RULES ARE COMPLETE. An [Id] whose arguments are all *) +(* canonical always reduces; equivalently, in a closed environment an *) +(* Id type never survives, and the only [Id] codes that are normal are *) +(* the NEUTRAL ones (stuck on a neutral endpoint or a neutral code). *) +(* That is what keeps the extension from adding any normal form beyond *) +(* neutrals. *) +(* *) +(* Id is HETEROGENEOUS: [Id A B t u] relates [t : El A] and [u : El B] for *) +(* two codes A,B of a common level, and it is that generality which lets *) +(* the function-extensionality rule below quantify over a pair of arguments *) +(* plus a proof that they are equal, rather than casting one argument *) +(* across a domain equality (which would need [Cast], whose [u0] gives a *) +(* code for a universe and breaks the code grammar the proof rests on). *) +(* ======================================================================= *) + +Definition id_cong_injectivity := + [("Id", ["u"; "t"; "B"; "A"; "l"; "G"]); + ("Idcong", ["e"; "u"; "t"; "b"; "B"; "lB"; "A"; "l"; "G"])]. + +Definition ott_id_base := + ott_proofirr_el ++ ott_subst_commute ++ ott_pi ++ ott_nat ++ ott_base + ++ subst_ott ++ ott_info. + +Definition id_inj_all := + id_cong_injectivity ++ pi_injectivity ++ nat_injectivity + ++ ott_base_injectivity ++ ott_info_injectivity ++ subst_ott_injectivity. + +(* ======================================================================= *) +(* SPLIT INTO FOUR FILES, and the reason is performance. *) +(* *) +(* [compute_wf_rule] checks each rule against its PREFIX, and its cost *) +(* grows sharply with that prefix: the 3-binder funext rule was measured at *) +(* 1h55m against a two-rule prefix and had not finished after 2h35m against *) +(* the full one. Splitting lets each rule be checked against the smallest *) +(* prefix it actually needs, and the pieces are then concatenated, with *) +(* [Core.lang_ext_monotonicity] lifting a rule verified against a small *) +(* prefix to its position in the assembled language. *) +(* *) +(* IdCore.v ott_id_core Id, Id subst (seconds) *) +(* IdComp.v ott_id_comp Idcong + the computation rules (~4 min) *) +(* IdFunext.v ott_id_funext the two funext rules (~2 h) *) +(* IdCong.v ott_id_cong = funext ++ comp ++ core, assembled *) +(* *) +(* The payoff is not the first build, it is every later one: editing a *) +(* computation rule no longer re-triggers the two-hour funext check. *) +(* *) +(* IdComp is derived over [ott_id_core ++ ott_id_base] and NOT over the *) +(* funext rules, which is also forced: with a funext rule in scope, *) +(* [infer_rule] re-elaborates "Id-Nat-00" to a DIFFERENT rule (the *) +(* next L0 <-> iota L1 flip). Deriving the two extensions over a COMMON *) +(* base keeps each one's elaboration exactly as it is today. *) +(* ======================================================================= *) + +Derive ott_id_core + in (wf_lang_ext ott_id_base ott_id_core) + as ott_id_core_wf. +Proof. + setup_lang_interactive. + (* --------------------------------------------------------------- *) + (* The code. *) + (* --------------------------------------------------------------- *) + + (* [Id A B t u] : the heterogeneous equality of [t : El A] and + [u : El B], a code in SProp = U_{%,0}. A and B are proof-RELEVANT + codes at a common level [l]; there is no [Id] between irrelevant + codes, and none is needed -- proof irrelevance already equates all + inhabitants of those. *) + elab_rule {[r "G" : #"env", "l" : #"lvl", + "A" : #"exp" "G" (#"info" #"rel" (#"next" "l")) (#"U" ["G" := "G"] #"rel" "l"), + "B" : #"exp" "G" (#"info" #"rel" (#"next" "l")) (#"U" ["G" := "G"] #"rel" "l"), + "t" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) (#"El" "A"), + "u" : #"exp" "G" (#"info" #"rel" (#"iota" "l")) (#"El" "B") + ----------------------------------------------- + #"Id" "A" "B" "t" "u" : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") + ]}%prerule + id_inj_all. + + elab_rule {[r "G" : #"env", "G'" : #"env", "g" : #"sub" "G" "G'", "l" : #"lvl", + "A" : #"exp" "G'" (#"info" #"rel" (#"next" "l")) (#"U" ["G" := "G'"] #"rel" "l"), + "B" : #"exp" "G'" (#"info" #"rel" (#"next" "l")) (#"U" ["G" := "G'"] #"rel" "l"), + "t" : #"exp" "G'" (#"info" #"rel" (#"iota" "l")) (#"El" "A"), + "u" : #"exp" "G'" (#"info" #"rel" (#"iota" "l")) (#"El" "B") + ----------------------------------------------- ("Id subst") + #"exp_subst" "g" (#"Id" "A" "B" "t" "u") + = #"Id" (#"exp_subst" "g" "A") (#"exp_subst" "g" "B") (#"exp_subst" "g" "t") (#"exp_subst" "g" "u") + : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") + ]}%prerule + id_inj_all. + + apply wf_lang_nil. +Unshelve. +1:shelve. +1:vm_compute; reflexivity. +Qed. +#[local] Definition ott_id_core_entry := lang_entry ott_id_core_wf. +#[export] Hint Resolve ott_id_core_entry : wf_lang_db. diff --git a/src/Pyrosome/Lang/OTT/IdFunextDefs.v b/src/Pyrosome/Lang/OTT/IdFunextDefs.v new file mode 100644 index 00000000..ec7bc7b6 --- /dev/null +++ b/src/Pyrosome/Lang/OTT/IdFunextDefs.v @@ -0,0 +1,262 @@ +From coqutil Require Import Datatypes.String. +From Stdlib Require Import Lists.List. +Import ListNotations. +Open Scope string. +Open Scope list. +From Utils Require Import Utils. +From Pyrosome Require Import + Theory.Core Elab.Elab + Elab.PreRule + Tools.ComputeWf + Tools.Matches + Tools.Resolution + Tools.EGraph.TypeInference + Tools.EGraph.ComputeWf + Tools.EGraph.Automation + Tools.Interactive. + +From Pyrosome.Compilers Require Import Parameterizer. + +From Pyrosome.Lang Require Import + Subst SubstEqnGen. +From Pyrosome.Lang.OTT Require Import Base Nat Pi SubstCommute ProofIrr IdCore. + +From Stdlib Require derive.Derive. + +Import Core.Notations. +Import PreRule.Notations. + +(* ======================================================================= *) +(* The heterogeneous observational identity type, for the language the *) +(* normalization proof targets (src/Pyrosome/Gluing/Dtt/). *) +(* *) +(* This is a SEPARATE fragment from Lang/OTT/Id.v. Id.v is the exploratory *) +(* OTT playground (it also carries Idrefl / Idsym / transp and feeds *) +(* Cast.v, Computations.v, IdUniv.v, none of which are in ott_dtt); the *) +(* fragment below is the one added to ott_dtt, and it differs in three *) +(* deliberate ways. *) +(* *) +(* (1) NO Idrefl. [Idcong] strictly generalizes it: taking the congruence *) +(* of a term that ignores the bound variable, i.e. *) +(* Idcong Nat C[wkn] c[wkn] zero zero triv : Id C C c c, *) +(* where [triv] inhabits [Id Nat Nat zero zero], which "Id-Nat-00" *) +(* below reduces to the unit proposition. So reflexivity is DERIVED. *) +(* *) +(* (2) NO equations for Idcong at all -- not the substitution commutation, *) +(* not the computation rules that push it under a constructor. Every *) +(* one of them is an equation between two inhabitants of a code at *) +(* [U _ irr _], so [ott_proofirr_el] proves it outright. They are *) +(* DERIVED in Gluing/Dtt/Eqns.v instead of posited here; the *) +(* normalization proof still rewrites with them exactly as if they *) +(* were rules (that is what makes reification at an Id type a *) +(* structural recursion on the congruence's body). *) +(* *) +(* (3) THE COMPUTATION RULES ARE COMPLETE. An [Id] whose arguments are all *) +(* canonical always reduces; equivalently, in a closed environment an *) +(* Id type never survives, and the only [Id] codes that are normal are *) +(* the NEUTRAL ones (stuck on a neutral endpoint or a neutral code). *) +(* That is what keeps the extension from adding any normal form beyond *) +(* neutrals. *) +(* *) +(* Id is HETEROGENEOUS: [Id A B t u] relates [t : El A] and [u : El B] for *) +(* two codes A,B of a common level, and it is that generality which lets *) +(* the function-extensionality rule below quantify over a pair of arguments *) +(* plus a proof that they are equal, rather than casting one argument *) +(* across a domain equality (which would need [Cast], whose [u0] gives a *) +(* code for a universe and breaks the code grammar the proof rests on). *) +(* ======================================================================= *) + + +(* DEFINITIONS ONLY -- no Derive, so this file costs seconds. The two rules are + checked in IdFunextRel.v and IdFunextIrr.v, which are SIBLINGS over the same + base: neither rule is in the other's prefix, so neither pays for the other. + Sequencing them in one Derive cost hours -- the irrelevant rule went from + ~4 min to >16 min purely from having the relevant one ahead of it. *) +(* Pre-elaborated function-extensionality rules for ott_id_cong. + To be inserted into src/Pyrosome/Lang/OTT/IdCong.v BEFORE the Derive, + and pushed with `push_rule` inside the Derive block. + + Con argument orders (read off Gluing/Dtt/Syntax.v, authoritative): + ext G i A wkn G i A hd G i A + cmp G1 G2 G3 f g (f : sub G1 G2, g : sub G2 G3) + snoc G G' i A g v (g : sub G G', result : sub G (ext G' i A)) + exp_subst G G' g i A v (A : ty G' i, v : exp G' i A) + El G r l e U G r l + Pi_rel G rF lF lG F B Pi_irr G rF lF F B + app_rel G rF lF lG F B f a + Id G l A B t u +*) + +(* ---------------------------------------------------------------- *) +(* IRRELEVANT domains: two binders, no domain-equality premise. *) +(* *) +(* Id (Pi_rel irr lF l F1 B1) (Pi_rel irr lF l F2 B2) f g *) +(* = Pi_irr irr lF F1 (Pi_irr irr lF F2[w1] *) +(* (Id (B1[a1]) (B2[a2]) (f a1) (g a2))) *) +(* *) +(* Sound WITHOUT the premise because a relevant result cannot depend *) +(* on an irrelevant argument except through Emptyrec. *) +(* ---------------------------------------------------------------- *) +Definition id_pi_pi_irr_rule : string * rule := + let iF : term := {{e #"info" #"irr" (#"iota" "lF") }} in + let nF : term := {{e #"info" #"rel" (#"next" "lF") }} in + let nl : term := {{e #"info" #"rel" (#"next" "l") }} in + let il : term := {{e #"info" #"rel" (#"iota" "l") }} in + let UGF : term := {{e #"U" "G" #"irr" "lF" }} in + let elF1 : term := {{e #"El" "G" #"irr" "lF" "F1" }} in + let elF2 : term := {{e #"El" "G" #"irr" "lF" "F2" }} in + let X1 : term := {{e #"ext" "G" {iF} {elF1} }} in + let X2 : term := {{e #"ext" "G" {iF} {elF2} }} in + let UX1 : term := {{e #"U" {X1} #"rel" "l" }} in + let UX2 : term := {{e #"U" {X2} #"rel" "l" }} in + let pi1 : term := {{e #"Pi_rel" "G" #"irr" "lF" "l" "F1" "B1" }} in + let pi2 : term := {{e #"Pi_rel" "G" #"irr" "lF" "l" "F2" "B2" }} in + let elpi1 : term := {{e #"El" "G" #"rel" "l" {pi1} }} in + let elpi2 : term := {{e #"El" "G" #"rel" "l" {pi2} }} in + (* binder 1: a1 : El F1, living in X1 *) + let w1 : term := {{e #"wkn" "G" {iF} {elF1} }} in + let a1 : term := {{e #"hd" "G" {iF} {elF1} }} in + let F1w : term := {{e #"exp_subst" {X1} "G" {w1} {nF} {UGF} "F1" }} in + let elF1w : term := {{e #"El" {X1} #"irr" "lF" {F1w} }} in + let F2w : term := {{e #"exp_subst" {X1} "G" {w1} {nF} {UGF} "F2" }} in + let elF2w : term := {{e #"El" {X1} #"irr" "lF" {F2w} }} in + (* binder 2: a2 : El F2[w1], living in Y *) + let Y : term := {{e #"ext" {X1} {iF} {elF2w} }} in + let w2 : term := {{e #"wkn" {X1} {iF} {elF2w} }} in + let a2 : term := {{e #"hd" {X1} {iF} {elF2w} }} in + let w21 : term := {{e #"cmp" {Y} {X1} "G" {w2} {w1} }} in + let a1w : term := {{e #"exp_subst" {Y} {X1} {w2} {iF} {elF1w} {a1} }} in + (* the domain codes, weakened all the way to Y *) + let F1s : term := {{e #"exp_subst" {Y} "G" {w21} {nF} {UGF} "F1" }} in + let F2s : term := {{e #"exp_subst" {Y} "G" {w21} {nF} {UGF} "F2" }} in + let elF1s : term := {{e #"El" {Y} #"irr" "lF" {F1s} }} in + let elF2s : term := {{e #"El" {Y} #"irr" "lF" {F2s} }} in + (* the two codomain instances *) + let ins1 : term := {{e #"snoc" {Y} "G" {iF} {elF1} {w21} {a1w} }} in + let ins2 : term := {{e #"snoc" {Y} "G" {iF} {elF2} {w21} {a2} }} in + let cod1 : term := {{e #"exp_subst" {Y} {X1} {ins1} {nl} {UX1} "B1" }} in + let cod2 : term := {{e #"exp_subst" {Y} {X2} {ins2} {nl} {UX2} "B2" }} in + (* the two applications: codomain codes lifted along w21 *) + let YF1 : term := {{e #"ext" {Y} {iF} {elF1s} }} in + let YF2 : term := {{e #"ext" {Y} {iF} {elF2s} }} in + let lift1 : term := {{e #"snoc" {YF1} "G" {iF} {elF1} + (#"cmp" {YF1} {Y} "G" (#"wkn" {Y} {iF} {elF1s}) {w21}) + (#"hd" {Y} {iF} {elF1s}) }} in + let lift2 : term := {{e #"snoc" {YF2} "G" {iF} {elF2} + (#"cmp" {YF2} {Y} "G" (#"wkn" {Y} {iF} {elF2s}) {w21}) + (#"hd" {Y} {iF} {elF2s}) }} in + let lifb1 : term := {{e #"exp_subst" {YF1} {X1} {lift1} {nl} {UX1} "B1" }} in + let lifb2 : term := {{e #"exp_subst" {YF2} {X2} {lift2} {nl} {UX2} "B2" }} in + let fw : term := {{e #"exp_subst" {Y} "G" {w21} {il} {elpi1} "f" }} in + let gw : term := {{e #"exp_subst" {Y} "G" {w21} {il} {elpi2} "g" }} in + let app1 : term := {{e #"app_rel" {Y} #"irr" "lF" "l" {F1s} {lifb1} {fw} {a1w} }} in + let app2 : term := {{e #"app_rel" {Y} #"irr" "lF" "l" {F2s} {lifb2} {gw} {a2} }} in + let body : term := {{e #"Id" {Y} "l" {cod1} {cod2} {app1} {app2} }} in + let inner : term := {{e #"Pi_irr" {X1} #"irr" "lF" {F2w} {body} }} in + ("Id-Pi-Pi-irr", + term_eq_rule + [("g", {{s #"exp" "G" {il} {elpi2} }}); + ("f", {{s #"exp" "G" {il} {elpi1} }}); + ("B2", {{s #"exp" {X2} {nl} {UX2} }}); + ("F2", {{s #"exp" "G" {nF} {UGF} }}); + ("B1", {{s #"exp" {X1} {nl} {UX1} }}); + ("F1", {{s #"exp" "G" {nF} {UGF} }}); + ("l", {{s #"lvl" }}); + ("lF", {{s #"lvl" }}); + ("G", {{s #"env" }})] + {{e #"Id" "G" "l" {pi1} {pi2} "f" "g" }} + {{e #"Pi_irr" "G" #"irr" "lF" "F1" {inner} }} + {{s #"exp" "G" (#"info" #"rel" (#"iota" #"L1")) (#"U" "G" #"irr" #"L0") }}). + +(* ---------------------------------------------------------------- *) +(* RELEVANT domains: three binders, with the domain-equality premise. *) +(* *) +(* Id (Pi_rel rel lF l F1 B1) (Pi_rel rel lF l F2 B2) f g *) +(* = Pi_irr rel lF F1 (Pi_irr rel lF F2[w1] *) +(* (Pi_irr irr L0 (Id F1 F2 a1 a2) *) +(* (Id (B1[a1]) (B2[a2]) (f a1) (g a2)))) *) +(* ---------------------------------------------------------------- *) +Definition id_pi_pi_rel_rule : string * rule := + let iF : term := {{e #"info" #"rel" (#"iota" "lF") }} in + let iP : term := {{e #"info" #"irr" (#"iota" #"L0") }} in + let nF : term := {{e #"info" #"rel" (#"next" "lF") }} in + let nl : term := {{e #"info" #"rel" (#"next" "l") }} in + let il : term := {{e #"info" #"rel" (#"iota" "l") }} in + let n0 : term := {{e #"info" #"rel" (#"iota" #"L1") }} in + let UGF : term := {{e #"U" "G" #"rel" "lF" }} in + let elF1 : term := {{e #"El" "G" #"rel" "lF" "F1" }} in + let elF2 : term := {{e #"El" "G" #"rel" "lF" "F2" }} in + let X1 : term := {{e #"ext" "G" {iF} {elF1} }} in + let X2 : term := {{e #"ext" "G" {iF} {elF2} }} in + let UX1 : term := {{e #"U" {X1} #"rel" "l" }} in + let UX2 : term := {{e #"U" {X2} #"rel" "l" }} in + let pi1 : term := {{e #"Pi_rel" "G" #"rel" "lF" "l" "F1" "B1" }} in + let pi2 : term := {{e #"Pi_rel" "G" #"rel" "lF" "l" "F2" "B2" }} in + let elpi1 : term := {{e #"El" "G" #"rel" "l" {pi1} }} in + let elpi2 : term := {{e #"El" "G" #"rel" "l" {pi2} }} in + (* binder 1: a1 : El F1, in X1 *) + let w1 : term := {{e #"wkn" "G" {iF} {elF1} }} in + let a1 : term := {{e #"hd" "G" {iF} {elF1} }} in + let F1w : term := {{e #"exp_subst" {X1} "G" {w1} {nF} {UGF} "F1" }} in + let elF1w : term := {{e #"El" {X1} #"rel" "lF" {F1w} }} in + let F2w : term := {{e #"exp_subst" {X1} "G" {w1} {nF} {UGF} "F2" }} in + let elF2w : term := {{e #"El" {X1} #"rel" "lF" {F2w} }} in + (* binder 2: a2 : El F2[w1], in Y *) + let Y : term := {{e #"ext" {X1} {iF} {elF2w} }} in + let w2 : term := {{e #"wkn" {X1} {iF} {elF2w} }} in + let a2 : term := {{e #"hd" {X1} {iF} {elF2w} }} in + let w21 : term := {{e #"cmp" {Y} {X1} "G" {w2} {w1} }} in + let a1w : term := {{e #"exp_subst" {Y} {X1} {w2} {iF} {elF1w} {a1} }} in + let F1s : term := {{e #"exp_subst" {Y} "G" {w21} {nF} {UGF} "F1" }} in + let F2s : term := {{e #"exp_subst" {Y} "G" {w21} {nF} {UGF} "F2" }} in + (* binder 3: p : Id F1 F2 a1 a2, in Z *) + let ieq : term := {{e #"Id" {Y} "lF" {F1s} {F2s} {a1w} {a2} }} in + let elieq : term := {{e #"El" {Y} #"irr" #"L0" {ieq} }} in + let Z : term := {{e #"ext" {Y} {iP} {elieq} }} in + let w3 : term := {{e #"wkn" {Y} {iP} {elieq} }} in + let w3G : term := {{e #"cmp" {Z} {Y} "G" {w3} {w21} }} in + (* everything transported from Y to Z *) + let a1z : term := {{e #"exp_subst" {Z} {Y} {w3} {iF} (#"El" {Y} #"rel" "lF" {F1s}) {a1w} }} in + let a2z : term := {{e #"exp_subst" {Z} {Y} {w3} {iF} (#"El" {Y} #"rel" "lF" {F2s}) {a2} }} in + let F1z : term := {{e #"exp_subst" {Z} "G" {w3G} {nF} {UGF} "F1" }} in + let F2z : term := {{e #"exp_subst" {Z} "G" {w3G} {nF} {UGF} "F2" }} in + let elF1z : term := {{e #"El" {Z} #"rel" "lF" {F1z} }} in + let elF2z : term := {{e #"El" {Z} #"rel" "lF" {F2z} }} in + (* the two codomain instances, in Z *) + let ins1 : term := {{e #"snoc" {Z} "G" {iF} {elF1} {w3G} {a1z} }} in + let ins2 : term := {{e #"snoc" {Z} "G" {iF} {elF2} {w3G} {a2z} }} in + let cod1 : term := {{e #"exp_subst" {Z} {X1} {ins1} {nl} {UX1} "B1" }} in + let cod2 : term := {{e #"exp_subst" {Z} {X2} {ins2} {nl} {UX2} "B2" }} in + (* the two applications, in Z *) + let ZF1 : term := {{e #"ext" {Z} {iF} {elF1z} }} in + let ZF2 : term := {{e #"ext" {Z} {iF} {elF2z} }} in + let lift1 : term := {{e #"snoc" {ZF1} "G" {iF} {elF1} + (#"cmp" {ZF1} {Z} "G" (#"wkn" {Z} {iF} {elF1z}) {w3G}) + (#"hd" {Z} {iF} {elF1z}) }} in + let lift2 : term := {{e #"snoc" {ZF2} "G" {iF} {elF2} + (#"cmp" {ZF2} {Z} "G" (#"wkn" {Z} {iF} {elF2z}) {w3G}) + (#"hd" {Z} {iF} {elF2z}) }} in + let lifb1 : term := {{e #"exp_subst" {ZF1} {X1} {lift1} {nl} {UX1} "B1" }} in + let lifb2 : term := {{e #"exp_subst" {ZF2} {X2} {lift2} {nl} {UX2} "B2" }} in + let fz : term := {{e #"exp_subst" {Z} "G" {w3G} {il} {elpi1} "f" }} in + let gz : term := {{e #"exp_subst" {Z} "G" {w3G} {il} {elpi2} "g" }} in + let app1 : term := {{e #"app_rel" {Z} #"rel" "lF" "l" {F1z} {lifb1} {fz} {a1z} }} in + let app2 : term := {{e #"app_rel" {Z} #"rel" "lF" "l" {F2z} {lifb2} {gz} {a2z} }} in + let body : term := {{e #"Id" {Z} "l" {cod1} {cod2} {app1} {app2} }} in + let mid : term := {{e #"Pi_irr" {Y} #"irr" #"L0" {ieq} {body} }} in + let inner : term := {{e #"Pi_irr" {X1} #"rel" "lF" {F2w} {mid} }} in + ("Id-Pi-Pi-rel", + term_eq_rule + [("g", {{s #"exp" "G" {il} {elpi2} }}); + ("f", {{s #"exp" "G" {il} {elpi1} }}); + ("B2", {{s #"exp" {X2} {nl} {UX2} }}); + ("F2", {{s #"exp" "G" {nF} {UGF} }}); + ("B1", {{s #"exp" {X1} {nl} {UX1} }}); + ("F1", {{s #"exp" "G" {nF} {UGF} }}); + ("l", {{s #"lvl" }}); + ("lF", {{s #"lvl" }}); + ("G", {{s #"env" }})] + {{e #"Id" "G" "l" {pi1} {pi2} "f" "g" }} + {{e #"Pi_irr" "G" #"rel" "lF" "F1" {inner} }} + {{s #"exp" "G" {n0} (#"U" "G" #"irr" #"L0") }}). + diff --git a/src/Pyrosome/Lang/OTT/IdFunextIrr.v b/src/Pyrosome/Lang/OTT/IdFunextIrr.v new file mode 100644 index 00000000..f1bb22dd --- /dev/null +++ b/src/Pyrosome/Lang/OTT/IdFunextIrr.v @@ -0,0 +1,86 @@ +From coqutil Require Import Datatypes.String. +From Stdlib Require Import Lists.List. +Import ListNotations. +Open Scope string. +Open Scope list. +From Utils Require Import Utils. +From Pyrosome Require Import + Theory.Core Elab.Elab + Elab.PreRule + Tools.ComputeWf + Tools.Matches + Tools.Resolution + Tools.EGraph.TypeInference + Tools.EGraph.ComputeWf + Tools.EGraph.Automation + Tools.Interactive. + +From Pyrosome.Compilers Require Import Parameterizer. + +From Pyrosome.Lang Require Import + Subst SubstEqnGen. +From Pyrosome.Lang.OTT Require Import Base Nat Pi SubstCommute ProofIrr IdCore IdFunextDefs. + +From Stdlib Require derive.Derive. + +Import Core.Notations. +Import PreRule.Notations. + +(* ======================================================================= *) +(* The heterogeneous observational identity type, for the language the *) +(* normalization proof targets (src/Pyrosome/Gluing/Dtt/). *) +(* *) +(* This is a SEPARATE fragment from Lang/OTT/Id.v. Id.v is the exploratory *) +(* OTT playground (it also carries Idrefl / Idsym / transp and feeds *) +(* Cast.v, Computations.v, IdUniv.v, none of which are in ott_dtt); the *) +(* fragment below is the one added to ott_dtt, and it differs in three *) +(* deliberate ways. *) +(* *) +(* (1) NO Idrefl. [Idcong] strictly generalizes it: taking the congruence *) +(* of a term that ignores the bound variable, i.e. *) +(* Idcong Nat C[wkn] c[wkn] zero zero triv : Id C C c c, *) +(* where [triv] inhabits [Id Nat Nat zero zero], which "Id-Nat-00" *) +(* below reduces to the unit proposition. So reflexivity is DERIVED. *) +(* *) +(* (2) NO equations for Idcong at all -- not the substitution commutation, *) +(* not the computation rules that push it under a constructor. Every *) +(* one of them is an equation between two inhabitants of a code at *) +(* [U _ irr _], so [ott_proofirr_el] proves it outright. They are *) +(* DERIVED in Gluing/Dtt/Eqns.v instead of posited here; the *) +(* normalization proof still rewrites with them exactly as if they *) +(* were rules (that is what makes reification at an Id type a *) +(* structural recursion on the congruence's body). *) +(* *) +(* (3) THE COMPUTATION RULES ARE COMPLETE. An [Id] whose arguments are all *) +(* canonical always reduces; equivalently, in a closed environment an *) +(* Id type never survives, and the only [Id] codes that are normal are *) +(* the NEUTRAL ones (stuck on a neutral endpoint or a neutral code). *) +(* That is what keeps the extension from adding any normal form beyond *) +(* neutrals. *) +(* *) +(* Id is HETEROGENEOUS: [Id A B t u] relates [t : El A] and [u : El B] for *) +(* two codes A,B of a common level, and it is that generality which lets *) +(* the function-extensionality rule below quantify over a pair of arguments *) +(* plus a proof that they are equal, rather than casting one argument *) +(* across a domain equality (which would need [Cast], whose [u0] gives a *) +(* code for a universe and breaks the code grammar the proof rests on). *) +(* ======================================================================= *) + + +(* The 2-binder (irrelevant-domain) funext rule. Sibling of IdFunextRel.v. *) + +Derive ott_id_funext_irr + in (wf_lang_ext (ott_id_core ++ ott_id_base) ott_id_funext_irr) + as ott_id_funext_irr_wf. +Proof. + setup_lang_interactive. + push_rule id_pi_pi_irr_rule. + + apply wf_lang_nil. +Unshelve. +1:shelve. +1:vm_compute; reflexivity. +Qed. + +#[local] Definition ott_id_funext_irr_entry := lang_entry ott_id_funext_irr_wf. +#[export] Hint Resolve ott_id_funext_irr_entry : wf_lang_db. diff --git a/src/Pyrosome/Lang/OTT/IdFunextRel.v b/src/Pyrosome/Lang/OTT/IdFunextRel.v new file mode 100644 index 00000000..ac8763a4 --- /dev/null +++ b/src/Pyrosome/Lang/OTT/IdFunextRel.v @@ -0,0 +1,89 @@ +From coqutil Require Import Datatypes.String. +From Stdlib Require Import Lists.List. +Import ListNotations. +Open Scope string. +Open Scope list. +From Utils Require Import Utils. +From Pyrosome Require Import + Theory.Core Elab.Elab + Elab.PreRule + Tools.ComputeWf + Tools.Matches + Tools.Resolution + Tools.EGraph.TypeInference + Tools.EGraph.ComputeWf + Tools.EGraph.Automation + Tools.Interactive. + +From Pyrosome.Compilers Require Import Parameterizer. + +From Pyrosome.Lang Require Import + Subst SubstEqnGen. +From Pyrosome.Lang.OTT Require Import Base Nat Pi SubstCommute ProofIrr IdCore IdFunextDefs. + +From Stdlib Require derive.Derive. + +Import Core.Notations. +Import PreRule.Notations. + +(* ======================================================================= *) +(* The heterogeneous observational identity type, for the language the *) +(* normalization proof targets (src/Pyrosome/Gluing/Dtt/). *) +(* *) +(* This is a SEPARATE fragment from Lang/OTT/Id.v. Id.v is the exploratory *) +(* OTT playground (it also carries Idrefl / Idsym / transp and feeds *) +(* Cast.v, Computations.v, IdUniv.v, none of which are in ott_dtt); the *) +(* fragment below is the one added to ott_dtt, and it differs in three *) +(* deliberate ways. *) +(* *) +(* (1) NO Idrefl. [Idcong] strictly generalizes it: taking the congruence *) +(* of a term that ignores the bound variable, i.e. *) +(* Idcong Nat C[wkn] c[wkn] zero zero triv : Id C C c c, *) +(* where [triv] inhabits [Id Nat Nat zero zero], which "Id-Nat-00" *) +(* below reduces to the unit proposition. So reflexivity is DERIVED. *) +(* *) +(* (2) NO equations for Idcong at all -- not the substitution commutation, *) +(* not the computation rules that push it under a constructor. Every *) +(* one of them is an equation between two inhabitants of a code at *) +(* [U _ irr _], so [ott_proofirr_el] proves it outright. They are *) +(* DERIVED in Gluing/Dtt/Eqns.v instead of posited here; the *) +(* normalization proof still rewrites with them exactly as if they *) +(* were rules (that is what makes reification at an Id type a *) +(* structural recursion on the congruence's body). *) +(* *) +(* (3) THE COMPUTATION RULES ARE COMPLETE. An [Id] whose arguments are all *) +(* canonical always reduces; equivalently, in a closed environment an *) +(* Id type never survives, and the only [Id] codes that are normal are *) +(* the NEUTRAL ones (stuck on a neutral endpoint or a neutral code). *) +(* That is what keeps the extension from adding any normal form beyond *) +(* neutrals. *) +(* *) +(* Id is HETEROGENEOUS: [Id A B t u] relates [t : El A] and [u : El B] for *) +(* two codes A,B of a common level, and it is that generality which lets *) +(* the function-extensionality rule below quantify over a pair of arguments *) +(* plus a proof that they are equal, rather than casting one argument *) +(* across a domain equality (which would need [Cast], whose [u0] gives a *) +(* code for a universe and breaks the code grammar the proof rests on). *) +(* ======================================================================= *) + + +(* The 3-binder (relevant-domain) funext rule, checked against the SMALLEST + prefix it needs: {Id, Id subst} ++ base. It does not see the irrelevant + funext rule; both are lifted into position by [Core.lang_ext_monotonicity] + in IdCong.v. *) + +Derive ott_id_funext_rel + in (wf_lang_ext (ott_id_core ++ ott_id_base) ott_id_funext_rel) + as ott_id_funext_rel_wf. +Proof. + setup_lang_interactive. + push_rule id_pi_pi_rel_rule. + + apply wf_lang_nil. +Unshelve. +1:shelve. +1:vm_compute; reflexivity. +Qed. + +#[local] Definition ott_id_funext_rel_entry := lang_entry ott_id_funext_rel_wf. +#[export] Hint Resolve ott_id_funext_rel_entry : wf_lang_db. diff --git a/src/Pyrosome/Lang/OTT/IdUniv.v b/src/Pyrosome/Lang/OTT/IdUniv.v new file mode 100644 index 00000000..3895dcef --- /dev/null +++ b/src/Pyrosome/Lang/OTT/IdUniv.v @@ -0,0 +1,202 @@ +From coqutil Require Import Datatypes.String. +From Stdlib Require Import Lists.List. +Import ListNotations. +Open Scope string. +Open Scope list. +From Utils Require Import Utils. +From Pyrosome Require Import + Theory.Core Elab.Elab + Elab.PreRule + Tools.ComputeWf + Tools.Matches + Tools.Resolution + Tools.EGraph.TypeInference + Tools.EGraph.ComputeWf + Tools.EGraph.Automation + Tools.Interactive. + +From Pyrosome.Compilers Require Import Parameterizer. + +From Pyrosome.Lang Require Import + Subst SubstEqnGen. +From Pyrosome.Lang.OTT Require Import Base Nat Pi Sigma Id Cast. + +From Stdlib Require derive.Derive. + +Import Core.Notations. +Import PreRule.Notations. + +(* ====================================================================== *) +(* Universe / type-equality layer for the heterogeneous Id. *) +(* *) +(* Here A = B = (u0 rel) : U_{!,1}, so the "elements" t,u : El(u0 rel) = *) +(* U_{!,⁰} are themselves level-⁰ type CODES. Id (u0 rel)(u0 rel) A B is *) +(* thus the observational TYPE equality A ~ B (Pujet–Tabareau TTobs), *) +(* computing structurally on the heads of A,B: *) +(* ℕ ~ ℕ ↝ sUnit *) +(* ℕ ~ Π / Π ~ ℕ ↝ Empty (head clash) *) +(* Π ~ Π ↝ Σ(...) (structural — DEFERRED, below) *) +(* Plus the head clash between the universe code (u0) and Π at level ¹. *) +(* ====================================================================== *) + +(* Id-U-Π-Π — the structural universe rule (Typed.agda:251-261): the type + equality of two Π codes at level ⁰ is a Σ of the domain equality and the + pointwise codomain equality. Cast-based single-binder form (Pujet–Tabareau): + Id_U (Π F1 B1) (Π F2 B2) + ↝ Σ (ef : Id_U F1 F2). + Π (a2 : F2). Id_U (B1[cast F2 F1 (Idsym ef) a2]) (B2[a2]) + The argument a2 : F2 is cast CONTRAVARIANTLY to F1 (via Idsym ef) to index B1, + so this needs exactly the transp/Idsym/cast machinery now in place. Domains + are relevant at level ⁰ (forced by Id_U F1 F2 typechecking). Pre-elaborated + + push_rule (like Pi.v's `Pi_rel eta` and the funext rule). *) +Definition id_u_pi_pi_rule : string * rule := + let iN0 : term := {{e #"info" #"rel" (#"next" #"L0") }} in + let iI0 : term := {{e #"info" #"rel" (#"iota" #"L0") }} in + let uG : term := {{e #"U" "G" #"rel" #"L0" }} in + let uGirr : term := {{e #"U" "G" #"irr" #"L0" }} in + let u0r : term := {{e #"u0" "G" #"rel" }} in + let pi1 : term := {{e #"Pi_rel" "G" #"rel" #"L0" #"L0" "F1" "B1" }} in + let pi2 : term := {{e #"Pi_rel" "G" #"rel" #"L0" #"L0" "F2" "B2" }} in + let idF : term := {{e #"Id" "G" #"L1" {u0r} {u0r} "F1" "F2" }} in + let iSig : term := {{e #"info" #"irr" (#"iota" #"L0") }} in + let elIdF : term := {{e #"El" "G" #"irr" #"L0" {idF} }} in + let Gs : term := {{e #"ext" "G" {iSig} {elIdF} }} in + let wS : term := {{e #"wkn" "G" {iSig} {elIdF} }} in + let F1s : term := {{e #"exp_subst" {Gs} "G" {wS} {iN0} {uG} "F1" }} in + let F2s : term := {{e #"exp_subst" {Gs} "G" {wS} {iN0} {uG} "F2" }} in + let idFs : term := {{e #"exp_subst" {Gs} "G" {wS} {iN0} {uGirr} {idF} }} in + let elIdFs : term := {{e #"El" {Gs} #"irr" #"L0" {idFs} }} in + let elF2s : term := {{e #"El" {Gs} #"rel" #"L0" {F2s} }} in + let Gs2 : term := {{e #"ext" {Gs} {iI0} {elF2s} }} in + let wS2 : term := {{e #"wkn" {Gs} {iI0} {elF2s} }} in + let a2 : term := {{e #"hd" {Gs} {iI0} {elF2s} }} in + let ef : term := {{e #"hd" "G" {iSig} {elIdF} }} in + let ef2 : term := {{e #"exp_subst" {Gs2} {Gs} {wS2} {iSig} {elIdFs} {ef} }} in + let uGs : term := {{e #"U" {Gs} #"rel" #"L0" }} in + let F1s2 : term := {{e #"exp_subst" {Gs2} {Gs} {wS2} {iN0} {uGs} {F1s} }} in + let F2s2 : term := {{e #"exp_subst" {Gs2} {Gs} {wS2} {iN0} {uGs} {F2s} }} in + let u0r2 : term := {{e #"u0" {Gs2} #"rel" }} in + let symE : term := {{e #"Idsym" {Gs2} #"L1" {u0r2} {u0r2} {F1s2} {F2s2} {ef2} }} in + let cst : term := {{e #"cast" {Gs2} #"rel" {F2s2} {F1s2} {symE} {a2} }} in + let w : term := {{e #"cmp" {Gs2} {Gs} "G" {wS2} {wS} }} in + let elF1 : term := {{e #"El" "G" #"rel" #"L0" "F1" }} in + let elF2 : term := {{e #"El" "G" #"rel" #"L0" "F2" }} in + let extF1 : term := {{e #"ext" "G" {iI0} {elF1} }} in + let extF2 : term := {{e #"ext" "G" {iI0} {elF2} }} in + let uExtF1 : term := {{e #"U" {extF1} #"rel" #"L0" }} in + let uExtF2 : term := {{e #"U" {extF2} #"rel" #"L0" }} in + let snoc1 : term := {{e #"snoc" {Gs2} "G" {iI0} {elF1} {w} {cst} }} in + let snoc2 : term := {{e #"snoc" {Gs2} "G" {iI0} {elF2} {w} {a2} }} in + let bod1 : term := {{e #"exp_subst" {Gs2} {extF1} {snoc1} {iN0} {uExtF1} "B1" }} in + let bod2 : term := {{e #"exp_subst" {Gs2} {extF2} {snoc2} {iN0} {uExtF2} "B2" }} in + let body : term := {{e #"Id" {Gs2} #"L1" {u0r2} {u0r2} {bod1} {bod2} }} in + let cod : term := {{e #"Pi_irr" {Gs} #"rel" #"L0" {F2s} {body} }} in + ("Id-U-Pi-Pi", + term_eq_rule + [("B2", {{s #"exp" {extF2} {iN0} {uExtF2} }}); + ("F2", {{s #"exp" "G" {iN0} {uG} }}); + ("B1", {{s #"exp" {extF1} {iN0} {uExtF1} }}); + ("F1", {{s #"exp" "G" {iN0} {uG} }}); + ("G", {{s #"env" }})] + {{e #"Id" "G" #"L1" {u0r} {u0r} {pi1} {pi2} }} + {{e #"Sig" "G" {idF} {cod} }} + {{s #"exp" "G" {iN0} {uGirr} }}). + +Derive ott_id_univ + in (wf_lang_ext (ott_cast ++ ott_id ++ ott_pi ++ ott_sigma ++ ott_nat + ++ ott_base ++ subst_ott ++ ott_info) ott_id_univ) + as ott_id_univ_wf. +Proof. + setup_lang_interactive. + + (* ℕ ~ ℕ ↝ sUnit = (Π sEmpty ▹ sEmpty). *) + elab_rule {[r "G" : #"env" + ----------------------------------------------- ("Id-U-Nat-Nat") + #"Id" ["G" := "G"] ["l" := #"L1"] (#"u0" ["G" := "G"] #"rel") (#"u0" ["G" := "G"] #"rel") + (#"Nat" ["G" := "G"]) (#"Nat" ["G" := "G"]) + = #"Pi_irr" #"irr" #"L0" (#"Empty" ["G" := "G"]) + (#"Empty" ["G" := #"ext" "G" (#"El" ["G" := "G"] ["r" := #"irr"] ["l" := #"L0"] (#"Empty" ["G" := "G"]))]) + : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") + ]}%prerule + (cast_injectivity ++ pi_injectivity ++ id_injectivity ++ nat_injectivity + ++ sigma_injectivity ++ ott_base_injectivity ++ ott_info_injectivity ++ subst_ott_injectivity). + + (* ℕ ~ Π ↝ Empty (type-level head clash at level ⁰). *) + elab_rule {[r "G" : #"env", "rF" : #"relevance", "lF" : #"lvl", + "F" : #"exp" "G" (#"info" #"rel" (#"next" "lF")) (#"U" ["G" := "G"] "rF" "lF"), + "B" : #"exp" (#"ext" "G" (#"El" "F")) (#"info" #"rel" (#"next" #"L0")) + (#"U" ["G" := #"ext" "G" (#"El" "F")] #"rel" #"L0") + ----------------------------------------------- ("Id-U-Nat-Pi") + #"Id" ["G" := "G"] ["l" := #"L1"] (#"u0" ["G" := "G"] #"rel") (#"u0" ["G" := "G"] #"rel") + (#"Nat" ["G" := "G"]) (#"Pi_rel" ["G" := "G"] "rF" "lF" #"L0" "F" "B") + = #"Empty" ["G" := "G"] + : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") + ]}%prerule + (cast_injectivity ++ pi_injectivity ++ id_injectivity ++ nat_injectivity + ++ sigma_injectivity ++ ott_base_injectivity ++ ott_info_injectivity ++ subst_ott_injectivity). + (* Π ~ ℕ ↝ Empty. *) + elab_rule {[r "G" : #"env", "rF" : #"relevance", "lF" : #"lvl", + "F" : #"exp" "G" (#"info" #"rel" (#"next" "lF")) (#"U" ["G" := "G"] "rF" "lF"), + "B" : #"exp" (#"ext" "G" (#"El" "F")) (#"info" #"rel" (#"next" #"L0")) + (#"U" ["G" := #"ext" "G" (#"El" "F")] #"rel" #"L0") + ----------------------------------------------- ("Id-U-Pi-Nat") + #"Id" ["G" := "G"] ["l" := #"L1"] (#"u0" ["G" := "G"] #"rel") (#"u0" ["G" := "G"] #"rel") + (#"Pi_rel" ["G" := "G"] "rF" "lF" #"L0" "F" "B") (#"Nat" ["G" := "G"]) + = #"Empty" ["G" := "G"] + : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") + ]}%prerule + (cast_injectivity ++ pi_injectivity ++ id_injectivity ++ nat_injectivity + ++ sigma_injectivity ++ ott_base_injectivity ++ ott_info_injectivity ++ subst_ott_injectivity). + + (* Head clash between the universe code (u0) and Π at level ¹. + A = u0 r : U_{!,1}, B = Π at result level ¹; distinct heads ↝ Empty. *) + elab_rule {[r "G" : #"env", "r" : #"relevance", "rF" : #"relevance", "lF" : #"lvl", + "F" : #"exp" "G" (#"info" #"rel" (#"next" "lF")) (#"U" ["G" := "G"] "rF" "lF"), + "B" : #"exp" (#"ext" "G" (#"El" "F")) (#"info" #"rel" (#"next" #"L1")) + (#"U" ["G" := #"ext" "G" (#"El" "F")] #"rel" #"L1"), + "t" : #"exp" "G" (#"info" #"rel" (#"iota" #"L1")) + (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := #"L1"] (#"u0" ["G" := "G"] "r")), + "u" : #"exp" "G" (#"info" #"rel" (#"iota" #"L1")) + (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := #"L1"] (#"Pi_rel" ["G" := "G"] "rF" "lF" #"L1" "F" "B")) + ----------------------------------------------- ("Id-u0-Pi") + #"Id" ["G" := "G"] ["l" := #"L1"] (#"u0" ["G" := "G"] "r") (#"Pi_rel" ["G" := "G"] "rF" "lF" #"L1" "F" "B") "t" "u" + = #"Empty" ["G" := "G"] + : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") + ]}%prerule + (cast_injectivity ++ pi_injectivity ++ id_injectivity ++ nat_injectivity + ++ sigma_injectivity ++ ott_base_injectivity ++ ott_info_injectivity ++ subst_ott_injectivity). + elab_rule {[r "G" : #"env", "r" : #"relevance", "rF" : #"relevance", "lF" : #"lvl", + "F" : #"exp" "G" (#"info" #"rel" (#"next" "lF")) (#"U" ["G" := "G"] "rF" "lF"), + "B" : #"exp" (#"ext" "G" (#"El" "F")) (#"info" #"rel" (#"next" #"L1")) + (#"U" ["G" := #"ext" "G" (#"El" "F")] #"rel" #"L1"), + "t" : #"exp" "G" (#"info" #"rel" (#"iota" #"L1")) + (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := #"L1"] (#"Pi_rel" ["G" := "G"] "rF" "lF" #"L1" "F" "B")), + "u" : #"exp" "G" (#"info" #"rel" (#"iota" #"L1")) + (#"El" ["G" := "G"] ["r" := #"rel"] ["l" := #"L1"] (#"u0" ["G" := "G"] "r")) + ----------------------------------------------- ("Id-Pi-u0") + #"Id" ["G" := "G"] ["l" := #"L1"] (#"Pi_rel" ["G" := "G"] "rF" "lF" #"L1" "F" "B") (#"u0" ["G" := "G"] "r") "t" "u" + = #"Empty" ["G" := "G"] + : #"exp" "G" (#"info" #"rel" (#"next" #"L0")) (#"U" ["G" := "G"] #"irr" #"L0") + ]}%prerule + (cast_injectivity ++ pi_injectivity ++ id_injectivity ++ nat_injectivity + ++ sigma_injectivity ++ ott_base_injectivity ++ ott_info_injectivity ++ subst_ott_injectivity). + + (* Π ~ Π at the universe (Id-U-ΠΠ, Typed.agda:251-261): the term is fully + authored — see id_u_pi_pi_rule above — but its wf-CHECK is DEFERRED. + Unlike transp/Idsym/funext (which the perf improvements brought under budget, + peaking <0.8GB in seconds/minutes), pushing this rule runs the compute_wf_rule + e-graph saturation for >25min without terminating (memory stays flat ~0.77GB, + so it is a SATURATION-time wall, not OOM). It is the deepest term in the + development: a Σ whose codomain casts its argument CONTRAVARIANTLY across the + domain equality (cast + Idsym + double codomain instantiation under two + binders). To land it, uncomment the push_rule below once the e-graph + wf-check is faster (or run it with a very large time budget). *) + (* push_rule id_u_pi_pi_rule. *) + + apply wf_lang_nil. +Unshelve. +1:shelve. +1:vm_compute; reflexivity. +Qed. +#[local] Definition ott_id_univ_entry := lang_entry ott_id_univ_wf. +#[export] Hint Resolve ott_id_univ_entry : wf_lang_db.