|
| 1 | +(* SPDX-License-Identifier: MPL-2.0 *) |
| 2 | +(* SPDX-FileCopyrightText: 2026 Jonathan D.A. Jewell (hyperpolymath) *) |
| 3 | + |
| 4 | +(* |
| 5 | + P2_Stlc.v |
| 6 | + ═════════ |
| 7 | + P-2, GROWN (Wave 1). Adds what the first-order P2_Progress.v lacked: |
| 8 | + **functions, binders, and the substitution lemma**. Full progress + |
| 9 | + preservation for the simply-typed lambda calculus (base type `TUnit` plus |
| 10 | + `→`), call-by-value, named (`nat`) variables. |
| 11 | +
|
| 12 | + Crucially **funext-free**: contexts are compared only on a term's *free* |
| 13 | + variables (`context_invariance`), never by function equality — so the |
| 14 | + development uses NO `functional_extensionality` and `Print Assumptions` stays |
| 15 | + "Closed under the global context". No `Admitted`, no axioms. |
| 16 | +
|
| 17 | + Scope: simply-typed (no QTT/affine quantities yet) — the substructural |
| 18 | + context-splitting discipline on top of this is the next increment. |
| 19 | +
|
| 20 | + `.v` is Coq, not V-lang — see formal/README.adoc and .hypatia-ignore. |
| 21 | +*) |
| 22 | + |
| 23 | +Require Import PeanoNat. |
| 24 | +Require Import ASFormal.Siblings_Stated. |
| 25 | + |
| 26 | +Definition id := nat. |
| 27 | + |
| 28 | +Inductive ty := TUnit | TArrow (A B : ty). |
| 29 | + |
| 30 | +Inductive tm := |
| 31 | +| var (x : id) |
| 32 | +| app (f a : tm) |
| 33 | +| abs (x : id) (A : ty) (b : tm) (* A is the domain type *) |
| 34 | +| tunit. |
| 35 | + |
| 36 | +Inductive value : tm -> Prop := |
| 37 | +| v_abs : forall x A b, value (abs x A b) |
| 38 | +| v_unit : value tunit. |
| 39 | + |
| 40 | +(* Substitution. Only ever applied with a closed value (the beta-redex |
| 41 | + argument), so capture cannot arise — established by the typing lemmas. *) |
| 42 | +Fixpoint subst (x : id) (s t : tm) : tm := |
| 43 | + match t with |
| 44 | + | var y => if Nat.eqb x y then s else var y |
| 45 | + | abs y A b => abs y A (if Nat.eqb x y then b else subst x s b) |
| 46 | + | app f a => app (subst x s f) (subst x s a) |
| 47 | + | tunit => tunit |
| 48 | + end. |
| 49 | + |
| 50 | +Inductive step : tm -> tm -> Prop := |
| 51 | +| ST_AppAbs : forall x A b v, value v -> step (app (abs x A b) v) (subst x v b) |
| 52 | +| ST_App1 : forall f f' a, step f f' -> step (app f a) (app f' a) |
| 53 | +| ST_App2 : forall f a a', value f -> step a a' -> step (app f a) (app f a'). |
| 54 | + |
| 55 | +Definition context := id -> option ty. |
| 56 | +Definition empty : context := fun _ => None. |
| 57 | +Definition extend (G : context) (x : id) (T : ty) : context := |
| 58 | + fun y => if Nat.eqb x y then Some T else G y. |
| 59 | + |
| 60 | +Inductive has_type : context -> tm -> ty -> Prop := |
| 61 | +| T_Var : forall G x T, G x = Some T -> has_type G (var x) T |
| 62 | +| T_Abs : forall G x A B b, has_type (extend G x A) b B -> has_type G (abs x A b) (TArrow A B) |
| 63 | +| T_App : forall G f a A B, has_type G f (TArrow A B) -> has_type G a A -> has_type G (app f a) B |
| 64 | +| T_Unit : forall G, has_type G tunit TUnit. |
| 65 | + |
| 66 | +(* ── free variables, free-in-context ───────────────────────────────────── *) |
| 67 | + |
| 68 | +Inductive afi : id -> tm -> Prop := |
| 69 | +| afi_var : forall x, afi x (var x) |
| 70 | +| afi_app1 : forall x f a, afi x f -> afi x (app f a) |
| 71 | +| afi_app2 : forall x f a, afi x a -> afi x (app f a) |
| 72 | +| afi_abs : forall x y A b, y <> x -> afi x b -> afi x (abs y A b). |
| 73 | + |
| 74 | +#[local] Hint Constructors afi : core. |
| 75 | + |
| 76 | +Lemma free_in_context : forall x t S G, |
| 77 | + afi x t -> has_type G t S -> exists U, G x = Some U. |
| 78 | +Proof. |
| 79 | + intros x t S G Hafi; generalize dependent S; generalize dependent G. |
| 80 | + induction Hafi; intros G S HT; inversion HT; subst. |
| 81 | + - eauto. |
| 82 | + - eapply IHHafi; eauto. |
| 83 | + - eapply IHHafi; eauto. |
| 84 | + - edestruct IHHafi as [U HU]; eauto. |
| 85 | + unfold extend in HU. destruct (Nat.eqb y x) eqn:E. |
| 86 | + + apply Nat.eqb_eq in E; subst y; exfalso; apply H; reflexivity. |
| 87 | + + eauto. |
| 88 | +Qed. |
| 89 | + |
| 90 | +Corollary typable_empty_closed : forall x t S, |
| 91 | + afi x t -> has_type empty t S -> False. |
| 92 | +Proof. |
| 93 | + intros x t S Hafi HT. |
| 94 | + destruct (free_in_context x t S empty Hafi HT) as [U HU]; discriminate HU. |
| 95 | +Qed. |
| 96 | + |
| 97 | +(* ── context invariance (the funext-free substitute for map equality) ──── *) |
| 98 | + |
| 99 | +Lemma context_invariance : forall G G' t S, |
| 100 | + has_type G t S -> |
| 101 | + (forall x, afi x t -> G x = G' x) -> |
| 102 | + has_type G' t S. |
| 103 | +Proof. |
| 104 | + intros G G' t S HT; generalize dependent G'. |
| 105 | + induction HT; intros G' Hf. |
| 106 | + - apply T_Var. rewrite <- (Hf x (afi_var x)). assumption. |
| 107 | + - apply T_Abs. apply IHHT. intros z Hz. unfold extend. |
| 108 | + destruct (Nat.eqb x z) eqn:E; auto. |
| 109 | + apply Hf. apply Nat.eqb_neq in E. auto. |
| 110 | + - eapply T_App; [apply IHHT1 | apply IHHT2]; intros z Hz; apply Hf; auto. |
| 111 | + - apply T_Unit. |
| 112 | +Qed. |
| 113 | + |
| 114 | +(* ── substitution preserves typing ─────────────────────────────────────── *) |
| 115 | + |
| 116 | +Lemma subst_preserves_typing : forall G x U t v S, |
| 117 | + has_type (extend G x U) t S -> |
| 118 | + has_type empty v U -> |
| 119 | + has_type G (subst x v t) S. |
| 120 | +Proof. |
| 121 | + intros G x U t v S Ht Hv; generalize dependent S; generalize dependent G. |
| 122 | + induction t as [ y | f IHf a IHa | y A b IHb | ]; |
| 123 | + intros G S Ht; simpl; inversion Ht; subst. |
| 124 | + - (* var y *) |
| 125 | + unfold extend in H1. destruct (Nat.eqb x y) eqn:E. |
| 126 | + + injection H1 as H1. rewrite <- H1. |
| 127 | + apply (context_invariance empty G); [assumption |]. |
| 128 | + intros z Hz. exfalso; apply (typable_empty_closed z v U Hz Hv). |
| 129 | + + apply T_Var; assumption. |
| 130 | + - (* app f a *) |
| 131 | + eapply T_App; [apply IHf | apply IHa]; eassumption. |
| 132 | + - (* abs y A b *) |
| 133 | + destruct (Nat.eqb x y) eqn:E. |
| 134 | + + apply Nat.eqb_eq in E; subst y. |
| 135 | + apply T_Abs. |
| 136 | + apply (context_invariance (extend (extend G x U) x A) (extend G x A)); |
| 137 | + [assumption |]. |
| 138 | + intros z Hz. unfold extend. destruct (Nat.eqb x z); reflexivity. |
| 139 | + + apply T_Abs. apply IHb. |
| 140 | + apply (context_invariance (extend (extend G x U) y A) |
| 141 | + (extend (extend G y A) x U)); [assumption |]. |
| 142 | + intros z Hz. unfold extend. |
| 143 | + destruct (Nat.eqb y z) eqn:E1; destruct (Nat.eqb x z) eqn:E2; |
| 144 | + try reflexivity. |
| 145 | + exfalso. apply Nat.eqb_neq in E. apply E. |
| 146 | + apply Nat.eqb_eq in E1; apply Nat.eqb_eq in E2. |
| 147 | + rewrite E2, <- E1; reflexivity. |
| 148 | + - (* tunit *) apply T_Unit. |
| 149 | +Qed. |
| 150 | + |
| 151 | +(* ── canonical forms ───────────────────────────────────────────────────── *) |
| 152 | + |
| 153 | +Lemma canon_arrow : forall v A B, |
| 154 | + value v -> has_type empty v (TArrow A B) -> exists x b, v = abs x A b. |
| 155 | +Proof. |
| 156 | + intros v A B Hv HT; destruct Hv. |
| 157 | + - inversion HT; subst; eauto. |
| 158 | + - inversion HT. |
| 159 | +Qed. |
| 160 | + |
| 161 | +(* ── progress ──────────────────────────────────────────────────────────── *) |
| 162 | + |
| 163 | +Theorem progress : forall t S, has_type empty t S -> value t \/ exists t', step t t'. |
| 164 | +Proof. |
| 165 | + intros t S HT; remember empty as G eqn:HG. |
| 166 | + induction HT. |
| 167 | + - subst G; discriminate H. |
| 168 | + - left; apply v_abs. |
| 169 | + - right; subst G. |
| 170 | + destruct IHHT1 as [Hvf | [f' Hf]]; [reflexivity | |]. |
| 171 | + + destruct (canon_arrow _ _ _ Hvf HT1) as [x [b ->]]. |
| 172 | + destruct IHHT2 as [Hva | [a' Ha]]; [reflexivity | |]. |
| 173 | + * eexists; apply ST_AppAbs; assumption. |
| 174 | + * eexists; apply ST_App2; [apply v_abs | eassumption]. |
| 175 | + + eexists; apply ST_App1; eassumption. |
| 176 | + - left; apply v_unit. |
| 177 | +Qed. |
| 178 | + |
| 179 | +(* ── preservation ──────────────────────────────────────────────────────── *) |
| 180 | + |
| 181 | +Theorem preservation : forall t t' S, |
| 182 | + has_type empty t S -> step t t' -> has_type empty t' S. |
| 183 | +Proof. |
| 184 | + intros t t' S HT Hstep; generalize dependent S. |
| 185 | + induction Hstep; intros S HT; inversion HT; subst. |
| 186 | + - (* ST_AppAbs *) |
| 187 | + match goal with H : has_type _ (abs _ _ _) _ |- _ => inversion H; subst end. |
| 188 | + eapply subst_preserves_typing; eassumption. |
| 189 | + - (* ST_App1 *) eapply T_App; [ apply IHHstep; eassumption | eassumption ]. |
| 190 | + - (* ST_App2 *) eapply T_App; [ eassumption | apply IHHstep; eassumption ]. |
| 191 | +Qed. |
| 192 | + |
| 193 | +(* ── discharge the stated obligations (closed-term, ctx:=unit) ──────────── *) |
| 194 | + |
| 195 | +Definition P2_progress_discharged |
| 196 | + : P2_progress tm ty unit tt |
| 197 | + (fun (_ : unit) (t : tm) (T : ty) => has_type empty t T) value step |
| 198 | + := progress. |
| 199 | + |
| 200 | +Definition P2_preservation_discharged |
| 201 | + : P2_preservation tm ty unit |
| 202 | + (fun (_ : unit) (t : tm) (T : ty) => has_type empty t T) step |
| 203 | + := fun (_ : unit) t t' T HT Hs => preservation t t' T HT Hs. |
| 204 | + |
| 205 | +Print Assumptions progress. |
| 206 | +Print Assumptions preservation. |
0 commit comments