diff --git a/_CoqProject b/_CoqProject
index ac2d6e360d330c2ea131ffae358fd7ddb35e5ce9..8643da2a798a665cbcdfadd74fab45c4452ab44d 100644
--- a/_CoqProject
+++ b/_CoqProject
@@ -1,5 +1,5 @@
-Q theories/lib semantics.lib
--Q theories/program_logics semantics.pl
+-Q theories/program_logics semantics.pl
-Q theories/type_systems semantics.ts
# We sometimes want to locally override notation, and there is no good way to do that with scopes.
-arg -w -arg -notation-overridden
@@ -28,11 +28,11 @@ theories/type_systems/stlc_extended/lang.v
theories/type_systems/stlc_extended/notation.v
theories/type_systems/stlc_extended/types.v
theories/type_systems/stlc_extended/bigstep.v
+theories/type_systems/stlc_extended/ctxstep.v
theories/type_systems/stlc_extended/parallel_subst.v
theories/type_systems/stlc_extended/logrel.v
-
# System F
theories/type_systems/systemf/lang.v
theories/type_systems/systemf/notation.v
@@ -45,7 +45,7 @@ theories/type_systems/systemf/logrel.v
theories/type_systems/systemf/free_theorems.v
theories/type_systems/systemf/binary_logrel.v
theories/type_systems/systemf/existential_invariants.v
-
+theories/type_systems/systemf/church_encodings_faithful.v
# SystemF-Mu
theories/type_systems/systemf_mu/lang.v
@@ -88,6 +88,8 @@ theories/program_logics/heap_lang/primitive_laws_nolater.v
theories/program_logics/hoare_lib.v
theories/program_logics/hoare.v
theories/program_logics/ipm.v
+theories/program_logics/ipm_persistency.v
+theories/program_logics/later_playground.v
theories/program_logics/later_loeb.v
theories/program_logics/invariant_lib.v
@@ -103,7 +105,8 @@ theories/program_logics/logrel/ghost_state.v
# resources
theories/program_logics/ra_lib.v
-theories/program_logics/resource_algebras.v
+theories/program_logics/resource_algebras_1.v
+#theories/program_logics/resource_algebras_2.v
theories/program_logics/fupd.v
@@ -126,3 +129,16 @@ theories/program_logics/concurrent_logrel/syntactic.v
theories/program_logics/concurrent_logrel/logrel.v
theories/program_logics/concurrent_logrel/adequacy.v
+
+# By removing the # below, you can add the exercise sheets to make
+# <comment-out>
+theories/type_systems/warmup/warmup.v
+theories/type_systems/stlc/exercises01.v
+theories/type_systems/stlc/exercises02.v
+theories/type_systems/stlc/cbn_logrel.v
+theories/type_systems/systemf/exercises03.v
+theories/type_systems/systemf/exercises04.v
+theories/type_systems/systemf/exercises05.v
+theories/type_systems/systemf_mu/exercises06.v
+theories/type_systems/systemf_mu_state/exercises07.v
+# </comment-out>
diff --git a/theories/program_logics/concurrency.v b/theories/program_logics/concurrency.v
index cd29c13d1edca07ae2177f2e930c5b7e0202b026..a1c1b9cbde619e66b29ce15aee7c098550046920 100644
--- a/theories/program_logics/concurrency.v
+++ b/theories/program_logics/concurrency.v
@@ -14,17 +14,17 @@ From iris.prelude Require Import options.
You can ignore the κs (it relates to another feature, prophecy variables, that we are not going to get into in this course).
(it corresponds to the notion of "base steps" →_b in the lecture notes)
*)
-(*Check prim_step.*)
+Check prim_step.
(** [step] lifts this reduction to thread pools. *)
-(*Check step.*)
+Check step.
-(*Check ForkS.*)
+Check ForkS.
(** In Iris's HeapLang, CAS is encoded in terms of another primitive: CmpXchg, namely, "compare and exchange".
The difference to CAS is that it returns not only a Boolean flag (indicating success or failure), but rather
a pair that also contains the old/current value.
*)
-(*Print CAS.*)
-(*Check CmpXchgS.*)
+Print CAS.
+Check CmpXchgS.
Global Notation "{{ P } } e {{ Φ } }" := (□(P%I -∗ WP e {{ Φ%I }}))%I
(at level 20, P, e, Φ at level 200,
@@ -35,9 +35,9 @@ Global Notation "{{ P } } e {{ v , Q } }" := (□ (P%I -∗ WP e {{ v, Q%I }}))%
format "{{ P } } e {{ v , Q } }") : stdpp_scope.
(** Weakest Precondition Rules *)
-(*Check wp_cmpxchg_fail.*)
-(*Check wp_cmpxchg_suc.*)
-(*Check wp_fork.*)
+Check wp_cmpxchg_fail.
+Check wp_cmpxchg_suc.
+Check wp_fork.
Definition assert (e : expr) : expr :=
if: e then #() else #0 #0.
@@ -230,8 +230,9 @@ Section with_lock.
(P -∗ WP c #() {{ v, P ∗ Φ v }}) -∗
WP with_lock l c {{ Φ }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
End with_lock.
(** Exclusive Ghost Token *)
@@ -264,7 +265,7 @@ Section excl_spin_lock.
Context `{heapGS Σ} `{lockG Σ}.
Definition is_excl_lock (v : val) (γ : gname) (P : iProp Σ) : iProp Σ :=
- is_lock v P (* TODO *)
+ is_lock v P (* TODO *)
.
Instance is_excl_lock_pers v γ P : Persistent (is_excl_lock v γ P).
@@ -273,26 +274,30 @@ Section excl_spin_lock.
Lemma newlock_spec' P :
⊢ {{ P }} newlock #() {{ v, ∃ γ, is_excl_lock v γ P }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma acquire_spec' v γ P :
⊢ {{ is_excl_lock v γ P }} acquire v {{ w, ⌜w = #()⌝ ∗ locked γ ∗ P }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma release_spec' v γ P :
⊢ {{ is_excl_lock v γ P ∗ locked γ ∗ P }} release v {{ w, True }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma really_exclusive v γ P :
⊢ {{ is_excl_lock v γ P ∗ locked γ }} assert (!v = #true) {{ _, True }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
End excl_spin_lock.
@@ -318,8 +323,9 @@ Section para_comp.
WP e2 #() {{ _, Q2 }} -∗
WP comp e1 e2 {{ _, Q1 ∗ Q2 }}.
Proof using Type*.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
End para_comp.
Definition inc_counter : val :=
@@ -352,8 +358,9 @@ Section counter.
Lemma parallel_counter_spec :
⊢ {{ True }} parallel_counter {{ v, ⌜v = #2⌝ }}.
Proof using Type*.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
End counter.
(** Exercise: Mutex *)
@@ -368,7 +375,8 @@ Section mutex.
Notation "l '↦:' P" := (∃ v : val, l ↦ v ∗ P v)%I (at level 40) : stdpp_scope.
Definition is_mutex (v : val) (P : val → iProp Σ) : iProp Σ :=
- True
+
+ True
.
Instance is_mutex_pers v P : Persistent (is_mutex v P).
Proof. apply _. Qed.
@@ -376,16 +384,18 @@ Section mutex.
Lemma mkmutex_spec P (v : val) :
⊢ {{ P v }} mkmutex v {{ v, is_mutex v P }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma acquire_mutex_spec P (v : val) :
⊢ {{ is_mutex v P }}
acquire_mutex v
{{ w, ∃ (l : loc) (rl : val), ⌜w = (#l, rl)%V⌝ ∗ l ↦: P ∗ {{ l ↦: P }} rl #() {{ _, True }} }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
End mutex.
(** Exercise: Channels *)
@@ -504,18 +514,21 @@ Section channel_spec.
Lemma newchan_spec :
⊢ {{ True }} newchan #() {{ v, is_channel v }}.
Proof using Type*.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma send_spec v d :
⊢ {{ is_channel v ∗ Pc d }} send v d {{ v, ⌜v = #()⌝ }}.
Proof using Pers.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma receive_spec v :
⊢ {{ is_channel v }} receive v {{ d, Pc d }}.
Proof using Pers.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
End channel_spec.
diff --git a/theories/program_logics/hoare.v b/theories/program_logics/hoare.v
index 700af1430cc34e5982aaa1d09fa471e66f2b5931..b355491fe67b6f08b89e06901edf852f559c14d1 100644
--- a/theories/program_logics/hoare.v
+++ b/theories/program_logics/hoare.v
@@ -10,71 +10,79 @@ Implicit Types
(e: expr)
(v: val).
+
(** * Hoare logic *)
(** Entailment rules *)
-(*Check ent_equiv.*)
-(*Check ent_refl.*)
-(*Check ent_trans.*)
-(* NOTE: True = ⌜True⌝ *)
-(* NOTE: False = ⌜False⌝ *)
-(*Check ent_prove_pure.*)
-(*Check ent_assume_pure.*)
-(*Check ent_and_elim_r.*)
-(*Check ent_and_elim_l.*)
-(*Check ent_and_intro.*)
-(*Check ent_or_introl.*)
-(*Check ent_or_intror.*)
-(*Check ent_or_elim.*)
-(*Check ent_all_intro.*)
-(*Check ent_all_elim.*)
-(*Check ent_exist_intro.*)
-(*Check ent_exist_elim.*)
+Check ent_equiv.
+Check ent_refl.
+Check ent_trans.
+(* NOTE: True = ⌜True⌝ *)
+(* NOTE: False = ⌜False⌝ *)
+Check ent_prove_pure.
+Check ent_assume_pure.
+Check ent_and_elim_r.
+Check ent_and_elim_l.
+Check ent_and_intro.
+Check ent_or_introl.
+Check ent_or_intror.
+Check ent_or_elim.
+Check ent_all_intro.
+Check ent_all_elim.
+Check ent_exist_intro.
+Check ent_exist_elim.
(** Derived entailment rules *)
Lemma ent_weakening P Q R :
(P ⊢ R) →
P ∧ Q ⊢ R.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma ent_true P :
P ⊢ True.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma ent_false P :
False ⊢ P.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma ent_and_comm P Q :
P ∧ Q ⊢ Q ∧ P.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma ent_or_comm P Q :
P ∨ Q ⊢ Q ∨ P.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma ent_all_comm {X} (Φ : X → X → iProp) :
(∀ x y, Φ x y) ⊢ (∀ y x, Φ x y).
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma ent_exist_comm {X} (Φ : X → X → iProp) :
(∃ x y, Φ x y) ⊢ (∃ y x, Φ x y).
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
(** Derived Hoare rules *)
Lemma hoare_con_pre P Q Φ e:
(P ⊢ Q) →
@@ -114,9 +122,10 @@ Lemma hoare_rec P Φ f x e v:
({{ P }} subst' x v (subst' f (rec: f x := e) e) {{Φ}}) →
{{ P }} (rec: f x := e)%V v {{Φ}}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma hoare_let P Φ x e v:
({{ P }} subst' x v e {{Φ}}) →
{{ P }} let: x := v in e {{Φ}}.
@@ -131,52 +140,58 @@ Qed.
Lemma hoare_eq_num (n m: Z):
{{ ⌜n = m⌝ }} #n = #m {{ u, ⌜u = #true⌝ }}.
-Proof.
- (* FIXME: exercise *)
-Admitted.
-
-Lemma hoare_neq_num (n m: Z):
- {{ ⌜n ≠ m⌝ }} #n = #m {{ u, ⌜u = #false⌝ }}.
Proof.
eapply hoare_pure; first reflexivity.
- intros Hneq. eapply hoare_pure_step.
- { apply pure_step_neq. done. }
+ intros ->. eapply hoare_pure_step.
+ { apply pure_step_eq. done. }
apply hoare_value_con.
by apply ent_prove_pure.
Qed.
+Lemma hoare_neq_num (n m: Z):
+ {{ ⌜n ≠ m⌝ }} #n = #m {{ u, ⌜u = #false⌝ }}.
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+
Lemma hoare_sub (z1 z2: Z):
{{ True }} #z1 - #z2 {{ v, ⌜v = #(z1 - z2)⌝ }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma hoare_add (z1 z2: Z):
{{ True }} #z1 + #z2 {{ v, ⌜v = #(z1 + z2)⌝ }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma hoare_if_false P e1 e2 Φ:
{{ P }} e2 {{ Φ }} →
({{ P }} if: #false then e1 else e2 {{ Φ }}).
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma hoare_if_true P e1 e2 Φ:
{{ P }} e1 {{ Φ }} →
({{ P }} if: #true then e1 else e2 {{ Φ }}).
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma hoare_pure_pre φ Φ e:
{{ ⌜φ⌝ }} e {{ Φ }} ↔ (φ → {{ True }} e {{ Φ }}).
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
(** Example: Fibonacci *)
Definition fib: val :=
rec: "fib" "n" :=
@@ -187,15 +202,17 @@ Definition fib: val :=
Lemma fib_zero:
{{ True }} fib #0 {{ v, ⌜v = #0⌝ }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma fib_one:
{{ True }} fib #1 {{ v, ⌜v = #1⌝ }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma fib_succ (z n m: Z):
{{ True }} fib #(z - 1)%Z {{ v, ⌜v = #n⌝ }} →
{{ True }} fib #(z - 2)%Z {{ v, ⌜v = #m⌝ }} →
@@ -231,9 +248,10 @@ Lemma fib_succ_oldschool (z n m: Z):
{{ True }} fib #(z - 2)%Z {{ v, ⌜v = #m⌝ }} →
{{ ⌜z > 1⌝%Z }} fib #z {{ v, ⌜v = #(n + m)⌝ }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Fixpoint Fib (n: nat) :=
match n with
| 0 => 0
@@ -397,41 +415,7 @@ Definition fac : val :=
if: "n" = #0 then #1
else "n" * "fac" ("n" - #1).
-Lemma fac_zero :
- {{ True }} fac #0 {{ v, ⌜v = #1⌝ }}.
-Proof.
- unfold fac. apply hoare_rec. simpl.
- eapply hoare_pure_steps.
- { econstructor 2.
- { eapply pure_step_fill with (K := [IfCtx _ _]). by apply pure_step_eq. }
- simpl. econstructor 2. { apply pure_step_if_true. }
- reflexivity.
- }
- eapply hoare_value_con. by apply ent_prove_pure.
-Qed.
-Lemma fac_succ (n m : Z) :
- {{ True }} fac #(n - 1) {{ v, ⌜v = #m⌝ }} →
- {{ ⌜(n > 0)%Z⌝ }} fac #n {{ v, ⌜v = #(n * m)⌝ }}.
-Proof.
- intros Hs. unfold fac. apply hoare_rec. simpl.
- apply hoare_pure_pre. intros Hn.
- eapply hoare_pure_steps.
- { econstructor 2.
- { eapply pure_step_fill with (K := [IfCtx _ _]).
- apply pure_step_neq. lia. }
- simpl. econstructor 2. { apply pure_step_if_false. }
- fold fac. econstructor 2.
- { eapply pure_step_fill with (K := [AppRCtx _; BinOpRCtx _ _]).
- apply pure_step_sub.
- }
- simpl. reflexivity.
- }
- eapply hoare_bind with (K := [BinOpRCtx _ _]). { apply Hs. }
- intros v. apply hoare_pure_pre. intros ->.
- simpl. eapply hoare_pure_step. { apply pure_step_mul. }
- eapply hoare_value_con. by apply ent_prove_pure.
-Qed.
Fixpoint Fac (n : nat) :=
match n with
@@ -441,9 +425,10 @@ Fixpoint Fac (n : nat) :=
Lemma fac_computes_Fac (n : nat) :
{{ True }} fac #n {{ v, ⌜v = #(Fac n)⌝ }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
(** * Separation Logic *)
(*Check ent_sep_weaken.*)
(*Check ent_sep_true.*)
@@ -453,22 +438,24 @@ Admitted.
(*Check ent_pointsto_sep.*)
(*Check ent_exists_sep.*)
-(* Note: the separating conjunction can be typed with `\sep` *)
+(* Note: The separating conjunction can usually be typed with \ast or \sep *)
Lemma ent_pointsto_disj l l' v w :
l ↦ v ∗ l' ↦ w ⊢ ⌜l ≠ l'⌝.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma ent_sep_exists {X} (Φ : X → iProp) P :
(∃ x : X, Φ x ∗ P) ⊣⊢ (∃ x : X, Φ x) ∗ P.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
(** ** Example: Chains *)
Fixpoint chain_pre n l r : iProp :=
match n with
@@ -480,27 +467,31 @@ Definition chain l r : iProp := ∃ n, ⌜n > 0⌝ ∗ chain_pre n l r.
Lemma chain_single (l r : loc) :
l ↦ #r ⊢ chain l r.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma chain_cons (l r t : loc) :
l ↦ #r ∗ chain r t ⊢ chain l t.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma chain_trans (l r t : loc) :
chain l r ∗ chain r t ⊢ chain l t.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma chain_sep_false (l r t : loc) :
chain l r ∗ chain l t ⊢ False.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Definition cycle l := chain l l.
Lemma chain_cycle l r :
chain l r ∗ chain r l ⊢ cycle l.
@@ -544,9 +535,10 @@ Lemma hoare_assert P e :
{{ P }} e {{ v, ⌜v = #true⌝ }} →
{{ P }} assert e {{ v, ⌜v = #()⌝ }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma frame_example (f : val) :
(∀ l l' : loc, {{ l ↦ #0 }} f #l #l' {{ _, l ↦ #42 }}) →
{{ True }}
@@ -602,11 +594,12 @@ Definition swap : val :=
Lemma swap_correct (l r: loc) (v w: val):
{{ l ↦ v ∗ r ↦ w }} swap #l #r {{ _, l ↦ w ∗ r ↦ v }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
(** ** Case study: lists *)
Fixpoint is_ll (xs : list val) (v : val) : iProp :=
match xs with
@@ -716,26 +709,28 @@ Qed.
Lemma new_ll_correct :
{{ True }} new_ll #() {{ v, is_ll [] v }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma cons_ll_correct (v x : val) xs :
{{ is_ll xs v }} cons_ll x v {{ u, is_ll (x :: xs) u }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma head_ll_correct (v x : val) xs :
{{ is_ll (x :: xs) v }} head_ll v {{ w, ⌜w = x⌝ }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
Lemma tail_ll_correct v x xs :
{{ is_ll (x :: xs) v }} tail_ll v {{ w, is_ll xs w }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
@@ -743,11 +738,11 @@ Admitted.
Lemma len_ll_correct v xs :
{{ is_ll xs v }} len_ll v {{ w, ⌜w = #(length xs)⌝ ∗ is_ll xs v }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
-(** Exercise: Prove your strengthened specification for [tail]. *)
+(** Exercise: State and prove a strengthened specification for [tail]. *)
Lemma tail_ll_strengthened v x xs :
{{ is_ll (x :: xs) v }} tail_ll v {{ w, False (* FIXME *) }}.
Proof.
diff --git a/theories/program_logics/ipm.v b/theories/program_logics/ipm.v
index dd650c2ce3527d7c871043cdb009f87f8bda3047..90b7b3956b828d85f0c360d51054a138a630c585 100644
--- a/theories/program_logics/ipm.v
+++ b/theories/program_logics/ipm.v
@@ -7,8 +7,8 @@ From semantics.pl.program_logic Require Import notation.
(** ** Magic is in the air *)
Import hoare.
-(*Check ent_wand_intro.*)
-(*Check ent_wand_elim.*)
+Check ent_wand_intro.
+Check ent_wand_elim.
Section primitive.
Implicit Types (P Q R: iProp).
@@ -22,27 +22,32 @@ Proof.
- apply ent_wand_intro. apply ent_or_intror.
Qed.
+(** Exercise 1 *)
+
Lemma ent_carry_res P Q :
P ⊢ Q -∗ P ∗ Q.
Proof.
- (* don't use the IPM *)
- (* FIXME: exercise *)
+(* don't use the IPM *)
+ (* TODO: exercise *)
Admitted.
+
Lemma ent_comm_premise P Q R :
(Q -∗ P -∗ R) ⊢ P -∗ Q -∗ R.
Proof.
- (* don't use the IPM *)
- (* FIXME: exercise *)
+(* don't use the IPM *)
+ (* TODO: exercise *)
Admitted.
+
Lemma ent_sep_or_disj2 P Q R :
(P ∨ R) ∗ (Q ∨ R) ⊢ (P ∗ Q) ∨ R.
Proof.
- (* don't use the IPM *)
- (* FIXME: exercise *)
+(* don't use the IPM *)
+ (* TODO: exercise *)
Admitted.
+
End primitive.
(** ** Using the IPM *)
@@ -243,53 +248,61 @@ Abort.
Section without_ipm.
(** Prove the following entailments without using the IPM. *)
+ (** Exercise 2 *)
+
Lemma ent_lem1 P Q :
True ⊢ P -∗ Q -∗ P ∗ Q.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma ent_lem2 P Q :
P ∗ (P -∗ Q) ⊢ Q.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma ent_lem3 P Q R :
(P ∨ Q) ⊢ R -∗ (P ∗ R) ∨ (Q ∗ R).
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
End without_ipm.
Lemma ent_lem1_ipm P Q :
True ⊢ P -∗ Q -∗ P ∗ Q.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma ent_lem2_ipm P Q :
P ∗ (P -∗ Q) ⊢ Q.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma ent_lem3_ipm P Q R :
(P ∨ Q) ⊢ R -∗ (P ∗ R) ∨ (Q ∗ R).
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
(** Weakest precondition rules *)
-(*Check ent_wp_value.*)
-(*Check ent_wp_wand.*)
-(*Check ent_wp_bind.*)
-(*Check ent_wp_pure_step.*)
-(*Check ent_wp_new.*)
-(*Check ent_wp_load.*)
-(*Check ent_wp_store.*)
+Check ent_wp_value.
+Check ent_wp_wand.
+Check ent_wp_bind.
+Check ent_wp_pure_step.
+Check ent_wp_new.
+Check ent_wp_load.
+Check ent_wp_store.
Lemma ent_wp_pure_steps e e' Φ :
rtc pure_step e e' →
@@ -300,39 +313,50 @@ Proof.
iApply ent_wp_pure_step; first done. by iApply "IH".
Qed.
-(*Print hoare.*)
+Print hoare.
+
+(** Exercise 3 *)
(** We can re-derive the Hoare rules from the weakest pre rules. *)
Lemma hoare_frame' P R Φ e :
{{ P }} e {{ Φ }} →
{{ P ∗ R }} e {{ v, Φ v ∗ R }}.
Proof.
- (* don't use the IPM *)
- (* FIXME: exercise *)
+(* don't use the IPM *)
+ (* TODO: exercise *)
Admitted.
+
+(** Exercise 4 *)
+
Lemma hoare_load l v :
{{ l ↦ v }} !#l {{ w, ⌜w = v⌝ ∗ l ↦ v }}.
Proof.
- (* don't use the IPM *)
- (* FIXME: exercise *)
+(* don't use the IPM *)
+ (* TODO: exercise *)
Admitted.
+
Lemma hoare_store l (v w : val) :
{{ l ↦ v }} #l <- w {{ _, l ↦ w }}.
Proof.
- (* don't use the IPM *)
- (* FIXME: exercise *)
+(* don't use the IPM *)
+ (* TODO: exercise *)
Admitted.
+
Lemma hoare_new (v : val) :
{{ True }} ref v {{ w, ∃ l : loc, ⌜w = #l⌝ ∗ l ↦ v }}.
Proof.
- (* don't use the IPM *)
- (* FIXME: exercise *)
+(* don't use the IPM *)
+ (* TODO: exercise *)
Admitted.
+
+
+(** Exercise 5 *)
+
(** Linked lists using the IPM *)
Fixpoint is_ll (xs : list val) (v : val) : iProp :=
match xs with
@@ -393,267 +417,40 @@ Qed.
Lemma new_ll_correct :
{{ True }} new_ll #() {{ v, is_ll [] v }}.
Proof.
- (* don't use the IPM *)
- (* FIXME: exercise *)
+(* don't use the IPM *)
+ (* TODO: exercise *)
Admitted.
+
Lemma cons_ll_correct (v x : val) xs :
{{ is_ll xs v }} cons_ll x v {{ u, is_ll (x :: xs) u }}.
Proof.
- (* don't use the IPM *)
- (* FIXME: exercise *)
+(* don't use the IPM *)
+ (* TODO: exercise *)
Admitted.
+
Lemma head_ll_correct (v x : val) xs :
{{ is_ll (x :: xs) v }} head_ll v {{ w, ⌜w = x⌝ }}.
Proof.
- (* don't use the IPM *)
- (* FIXME: exercise *)
+(* don't use the IPM *)
+ (* TODO: exercise *)
Admitted.
+
Lemma tail_ll_correct v x xs :
{{ is_ll (x :: xs) v }} tail_ll v {{ w, is_ll xs w }}.
Proof.
- (* don't use the IPM *)
- (* FIXME: exercise *)
+(* don't use the IPM *)
+ (* TODO: exercise *)
Admitted.
+
Lemma len_ll_correct v xs :
{{ is_ll xs v }} len_ll v {{ w, ⌜w = #(length xs)⌝ ∗ is_ll xs v }}.
Proof.
- (* don't use the IPM *)
- (* FIXME: exercise *)
-Admitted.
-
-
-(** ** Persistency *)
-(*Check ent_pers_dup.*)
-(*Check ent_pers_elim.*)
-(*Check ent_pers_mono.*)
-(*Check ent_pers_pure.*)
-(*Check ent_pers_and_sep.*)
-(*Check ent_pers_idemp.*)
-(*Check ent_pers_all.*)
-(*Check ent_pers_exists.*)
-
-Lemma ent_pers_dup' P :
- □ P ⊢ (□ P) ∗ (□ P).
-Proof.
- (* don't use the IPM *)
- (* FIXME: exercise *)
+(* don't use the IPM *)
+ (* TODO: exercise *)
Admitted.
-(** Hoare triples, internalized *)
-Definition hoare (P : iProp) (e : expr) (Φ : val → iProp) : iProp :=
- □ (P -∗ WP e {{ Φ }}).
-
-Global Notation "{{ P } } e {{ Φ } }" := (hoare P%I e%E Φ%I)
- (at level 20, P, e, Φ at level 200,
- format "{{ P } } e {{ Φ } }") : stdpp_scope.
-
-Global Notation "{{ P } } e {{ v , Q } }" := (hoare P%I e%E (λ v, Q)%I)
- (at level 20, P, e, Q at level 200,
- format "{{ P } } e {{ v , Q } }") : stdpp_scope.
-
-(** Example: *)
-Lemma double_int f :
- {{ True }} f #() {{ v, ∃ z : Z, ⌜v = #z⌝ }} ⊢ {{ True }} f #() + f #() {{ v, ∃ z : Z, ⌜v = #z⌝ }}.
-Proof.
- iIntros "#Hf !> _".
- Restart.
- (* alternative: *)
- iIntros "#Hf". iModIntro. iIntros "_".
-Abort.
-
-(** We can rederive the previous rules for external Hoare triples. *)
-Section hoare_external.
- Definition hoare_ext (P : iProp) (e : expr) (Φ : val → iProp) : Prop :=
- True ⊢ {{ P }} e {{ Φ }}.
-
- Notation "{{ P } } e {{ Φ } '}e'" := (hoare_ext P%I e%E Φ%I)
- (at level 20, P, e, Φ at level 200,
- format "{{ P } } e {{ Φ } }e") : stdpp_scope.
-
- Notation "{{ P } } e {{ v , Q } '}e'" := (hoare_ext P%I e%E (λ v, Q)%I)
- (at level 20, P, e, Q at level 200,
- format "{{ P } } e {{ v , Q } }e") : stdpp_scope.
-
- Lemma hoare_ext_value v Φ:
- {{ Φ v }} v {{ Φ }}e.
- Proof.
- (* FIXME: exercise *)
- Admitted.
-
- Lemma hoare_ext_con P Q Φ Ψ e:
- (P ⊢ Q) →
- (∀ v, Ψ v ⊢ Φ v) →
- {{ Q }} e {{ Ψ }}e →
- {{ P }} e {{ Φ }}e.
- Proof.
- (* FIXME: exercise *)
- Admitted.
-
- Lemma hoare_ext_bind K P Φ Ψ e:
- {{ P }} e {{ Ψ }}e →
- (∀ v, {{ Ψ v }} fill K (Val v) {{ Φ }}e) →
- {{ P }} (fill K e) {{ Φ }}e.
- Proof.
- (* FIXME: exercise *)
- Admitted.
-
- Lemma hoare_ext_pure P φ Φ e:
- (P ⊢ ⌜φ⌝) →
- (φ → {{ P }} e {{ Φ }}e) →
- {{ P }} e {{ Φ }}e.
- Proof.
- (* FIXME: exercise *)
- Admitted.
-
- Lemma hoare_ext_exist_pre {X} (Φ : X → _) Ψ e :
- (∀ x : X, {{ Φ x }} e {{ Ψ }}e) →
- {{ ∃ x : X, Φ x }} e {{ Ψ }}e.
- Proof.
- (* FIXME: exercise *)
- Admitted.
-
- Lemma hoare_ext_pure_step P Ψ e1 e2 :
- pure_step e1 e2 →
- {{ P }} e2 {{ Ψ }}e →
- {{ P }} e1 {{ Ψ }}e.
- Proof.
- (* FIXME: exercise *)
- Admitted.
-
- Lemma hoare_ext_new v :
- {{ True }} ref (Val v) {{ w, ∃ l : loc, ⌜w = #l⌝ ∗ l ↦ v }}e.
- Proof.
- (* FIXME: exercise *)
- Admitted.
-
- Lemma hoare_ext_load l v:
- {{ l ↦ v }} ! #l {{ w, ⌜w = v⌝ ∗ l ↦ v }}e.
- Proof.
- (* FIXME: exercise *)
- Admitted.
-
- Lemma hoare_ext_store l (v w: val):
- {{ l ↦ v }} #l <- w {{ _, l ↦ w }}e.
- Proof.
- (* FIXME: exercise *)
- Admitted.
-
- Lemma hoare_ext_frame P F Φ e:
- {{ P }} e {{ Φ }}e →
- {{ P ∗ F }} e {{ v, Φ v ∗ F }}e.
- Proof.
- (* FIXME: exercise *)
- Admitted.
-End hoare_external.
-
-(** ** Invariants *)
-(*Check ent_inv_pers.*)
-(*Check ent_inv_alloc.*)
-
-(* The following rule is more comvenient to use *)
-(*Check inv_alloc.*)
-
-(** We require a sidecondition here, namely that [F] is "timeless". All propositions we have seen up to now are in fact timeless.
- We will see propositions that do not satisfy this requirement and which need a stronger rule for invariants soon.
-*)
-(*Check ent_inv_open.*)
-(*Check inv_open.*)
-
-
-(** MyMutBit *)
-Definition MyMutBit : expr :=
- let: "x" := ref #0 in
- (λ: "y", "x" <- #1 - !"x",
- λ: "y", #0 < !"x").
-
-Definition MutBit v : iProp :=
- {{ True }} (Fst v) #() {{ w, ⌜w = #()⌝ }} ∗
- {{ True }} (Snd v) #() {{ w, ⌜w = #true⌝ ∨ ⌜w = #false⌝}}.
-
-Definition mutbitN := nroot .@ "mutbit".
-Lemma MyMutBit_proof :
- ⊢ {{ True }} MyMutBit {{ v, MutBit v }}.
-Proof.
- iIntros "!> _". unfold MyMutBit. wp_alloc l as "Hl". wp_pures.
- iApply (inv_alloc mutbitN (l ↦ #0 ∨ l ↦ #1) with "[Hl]").
- { eauto with iFrame. }
- iIntros "#HInv".
- iApply wp_value. unfold MutBit. iSplit.
- - iIntros "!>_". wp_pures.
- iApply (inv_open with "HInv"); first set_solver.
- iIntros "[Hl | Hl]".
- + wp_load. wp_store. iApply wp_value. eauto with iFrame.
- + wp_load. wp_store. iApply wp_value. eauto with iFrame.
- - iIntros "!> _". wp_pures.
- iApply (inv_open with "HInv"); first set_solver.
- iIntros "[Hl | Hl]".
- + wp_load. wp_pures. iApply wp_value. eauto with iFrame.
- + wp_load. wp_pures. iApply wp_value. eauto with iFrame.
-Qed.
-
-(** Exercise: Abstract integers *)
-Notation "'assert' e" := (if: e%E then #() else #0 #0)%E (at level 40) : expr_scope.
-Definition MyInt : expr :=
- λ: "z",
- let: "x" := ref (if: #0 < "z" then (#0, "z") else (-"z", #0)) in
- ((λ: "y", let: "xv" := !"x" in assert (#0 ≤ Fst "xv");; assert (#0 ≤ Snd "xv");; Snd "xv" - Fst "xv"),
- (λ: "y", let: "xv" := !"x" in "x" <- (Snd "xv", Fst "xv"))).
-
-Definition FlipInt v : iProp :=
- {{ True }} (Fst v) #() {{ w, ∃ z : Z, ⌜w = #z⌝ }} ∗
- {{ True }} (Snd v) #() {{ w, ⌜w = #()⌝ }}.
-
-Definition flipintN := nroot .@ "flipint".
-Lemma MyInt_proof (z : Z) :
- ⊢ {{ True }} MyInt #z {{ v, FlipInt v }}.
-Proof.
- (* FIXME: exercise *)
-Admitted.
-
-(** Exercise: Magic Wands for Accessors *)
-Definition lookup_ll : val :=
- rec: "lookup" "l" "i" :=
- match: "l" with
- NONE => NONE
- | SOME "l" =>
- if: "i" = #0 then SOME "l"
- else
- let: "lv" := !"l" in
- "lookup" (Snd "lv") ("i" - #1)
- end.
-
-(**
- The lookup [!!!] is stdpp's [lookup_total] that, in contrast to [lookup],
- does not return an [option], but rather a default value.
- (It computes well using Coq's reduction tactics.)
- *)
-Lemma lookup_ll_correct xs lv (n : nat) :
- ⊢ {{ is_ll xs lv ∗ ⌜n < length xs⌝ }}
- lookup_ll lv #n
- {{ v, ∃ (l : loc) next, ⌜v = SOMEV #l⌝ ∗ l ↦ (xs !!! n, next) ∗ (∀ w', l ↦ (w', next) -∗ is_ll (<[n := w']> xs) lv) }}.
-Proof.
- (* FIXME: exercise *)
-Admitted.
-
-(* A derived version that does not wrap the result in an option value.
- (thus, at the language level, no case analysis on whether the value actually exists is possible)
-*)
-Definition lookup_ll_unsafe : val :=
- λ: "l" "i",
- match: lookup_ll "l" "i" with
- SOME "l" => "l"
- | NONE => NONE
- end.
-Lemma lookup_ll_unsafe_correct xs lv (n : nat) :
- ⊢ {{ is_ll xs lv ∗ ⌜n < length xs⌝ }}
- lookup_ll_unsafe lv #n
- {{ v, ∃ (l : loc) next, ⌜v = #l⌝ ∗ l ↦ (xs !!! n, next) ∗ (∀ w', l ↦ (w', next) -∗ is_ll (<[n := w']> xs) lv) }}.
-Proof.
- (* derive this from [lookup_ll_correct] *)
- (* FIXME: exercise *)
-Admitted.
diff --git a/theories/program_logics/ipm_persistency.v b/theories/program_logics/ipm_persistency.v
new file mode 100644
index 0000000000000000000000000000000000000000..2aa43cc7c1dfb3d65575aad0a64b611149497b3c
--- /dev/null
+++ b/theories/program_logics/ipm_persistency.v
@@ -0,0 +1,194 @@
+From iris.proofmode Require Import tactics.
+From iris.heap_lang Require Import lang primitive_laws notation.
+From iris.base_logic Require Import invariants.
+From semantics.pl.heap_lang Require Import adequacy proofmode primitive_laws_nolater.
+From semantics.pl Require Import hoare_lib ipm.
+From semantics.pl.program_logic Require Import notation.
+Import hoare.
+
+
+Implicit Types
+ (P Q R: iProp)
+ (Φ Ψ : val → iProp)
+.
+
+(** ** Persistency *)
+(*Check ent_pers_dup.*)
+(*Check ent_pers_elim.*)
+(*Check ent_pers_mono.*)
+(*Check ent_pers_pure.*)
+(*Check ent_pers_and_sep.*)
+(*Check ent_pers_idemp.*)
+(*Check ent_pers_all.*)
+(*Check ent_pers_exists.*)
+
+Lemma ent_pers_dup' P :
+ □ P ⊢ (□ P) ∗ (□ P).
+Proof.
+(* don't use the IPM *)
+ (* TODO: exercise *)
+Admitted.
+
+
+
+(** Hoare triples, internalized *)
+Definition hoare (P : iProp) (e : expr) (Φ : val → iProp) : iProp :=
+ □ (P -∗ WP e {{ Φ }}).
+
+Global Notation "{{ P } } e {{ Φ } }" := (hoare P%I e%E Φ%I)
+ (at level 20, P, e, Φ at level 200,
+ format "{{ P } } e {{ Φ } }") : stdpp_scope.
+
+Global Notation "{{ P } } e {{ v , Q } }" := (hoare P%I e%E (λ v, Q)%I)
+ (at level 20, P, e, Q at level 200,
+ format "{{ P } } e {{ v , Q } }") : stdpp_scope.
+
+(** Example: *)
+Lemma double_int f :
+ {{ True }} f #() {{ v, ∃ z : Z, ⌜v = #z⌝ }} ⊢ {{ True }} f #() + f #() {{ v, ∃ z : Z, ⌜v = #z⌝ }}.
+Proof.
+ iIntros "#Hf". unfold hoare. iModIntro. iIntros "_".
+ Restart.
+ (* more concisely: *)
+ iIntros "#Hf !> _".
+
+ (* Let's complete the proof *)
+ wp_bind (f _). iApply wp_wand.
+ { by iApply "Hf". }
+ iIntros (v) "(%z & ->)".
+
+ wp_bind (f _). iApply ent_wp_wand'; first last.
+ { by iApply "Hf". }
+ iIntros (v) "(%z2 & ->)".
+
+ wp_pures. iApply wp_value. eauto.
+Qed.
+
+(** Exercise: Magic Wands for Accessors *)
+Definition lookup_ll : val :=
+ rec: "lookup" "l" "i" :=
+ match: "l" with
+ NONE => NONE
+ | SOME "l" =>
+ if: "i" = #0 then SOME "l"
+ else
+ let: "lv" := !"l" in
+ "lookup" (Snd "lv") ("i" - #1)
+ end.
+
+(**
+ The lookup [!!!] is stdpp's [lookup_total] that, in contrast to [lookup],
+ does not return an [option], but rather a default value.
+ (It computes well using Coq's reduction tactics.)
+ *)
+Lemma lookup_ll_correct xs lv (n : nat) :
+ ⊢ {{ is_ll xs lv ∗ ⌜n < length xs⌝ }}
+ lookup_ll lv #n
+ {{ v, ∃ (l : loc) next, ⌜v = SOMEV #l⌝ ∗ l ↦ (xs !!! n, next) ∗ (∀ w', l ↦ (w', next) -∗ is_ll (<[n := w']> xs) lv) }}.
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+
+(* A derived version that does not wrap the result in an option value.
+ (thus, at the language level, no case analysis on whether the value actually exists is possible)
+*)
+Definition lookup_ll_unsafe : val :=
+ λ: "l" "i",
+ match: lookup_ll "l" "i" with
+ SOME "l" => "l"
+ | NONE => NONE
+ end.
+Lemma lookup_ll_unsafe_correct xs lv (n : nat) :
+ ⊢ {{ is_ll xs lv ∗ ⌜n < length xs⌝ }}
+ lookup_ll_unsafe lv #n
+ {{ v, ∃ (l : loc) next, ⌜v = #l⌝ ∗ l ↦ (xs !!! n, next) ∗ (∀ w', l ↦ (w', next) -∗ is_ll (<[n := w']> xs) lv) }}.
+Proof.
+(* derive this from [lookup_ll_correct] *)
+ (* TODO: exercise *)
+Admitted.
+
+
+(** ** Invariants *)
+(*Check ent_inv_pers.*)
+(*Check ent_inv_alloc.*)
+
+(* The following rule is more comvenient to use *)
+(*Check inv_alloc.*)
+
+(** We require a sidecondition here, namely that [F] is "timeless". All propositions we have seen up to now are in fact timeless.
+ We will see propositions that do not satisfy this requirement and which need a stronger rule for invariants soon.
+*)
+(*Check ent_inv_open.*)
+(*Check inv_open.*)
+
+
+(** MyMutBit *)
+Definition MyMutBit : expr :=
+ let: "x" := ref #0 in
+ (λ: "y", "x" <- #1 - !"x",
+ λ: "y", #0 < !"x").
+
+Definition MutBit v : iProp :=
+ {{ True }} (Fst v) #() {{ w, ⌜w = #()⌝ }} ∗
+ {{ True }} (Snd v) #() {{ w, ⌜w = #true⌝ ∨ ⌜w = #false⌝}}.
+
+Definition mutbitN := nroot .@ "mutbit".
+Lemma MyMutBit_proof :
+ ⊢ {{ True }} MyMutBit {{ v, MutBit v }}.
+Proof.
+ iIntros "!> _". unfold MyMutBit. wp_alloc l as "Hl". wp_pures.
+ iApply (inv_alloc mutbitN (l ↦ #0 ∨ l ↦ #1) with "[Hl]").
+ { eauto with iFrame. }
+ iIntros "#HInv".
+ iApply wp_value. unfold MutBit. iSplit.
+ - iIntros "!>_". wp_pures.
+ iApply (inv_open with "HInv"); first set_solver.
+ iIntros "[Hl | Hl]".
+ + wp_load. wp_store. iApply wp_value. eauto with iFrame.
+ + wp_load. wp_store. iApply wp_value. eauto with iFrame.
+ - iIntros "!> _". wp_pures.
+ iApply (inv_open with "HInv"); first set_solver.
+ iIntros "[Hl | Hl]".
+ + wp_load. wp_pures. iApply wp_value. eauto with iFrame.
+ + wp_load. wp_pures. iApply wp_value. eauto with iFrame.
+Qed.
+
+Notation "'assert' e" := (if: e%E then #() else #0 #0)%E (at level 40) : expr_scope.
+(** Exercise: Counter *)
+
+Definition SafeCounter : expr :=
+ let: "c1" := ref #0 in let: "c2" := ref #0 in
+ ((* inc *) λ: "_", "c1" <- !"c1" + #1;; "c2" <- !"c2" + #1,
+ (* get *) λ: "_", let: "v1" := !"c1" in let: "v2" := !"c2" in assert("v1" = "v2");; "v1").
+
+Definition SafeCounter_safe v : iProp :=
+ {{ True }} (Fst v) #() {{ w, True }} ∗
+ {{ True }} (Snd v) #() {{ w, True }}.
+
+Definition counterN := nroot .@ "counter".
+Lemma SafeCounter_proof :
+ ⊢ {{ True }} SafeCounter {{ v, SafeCounter_safe v }}.
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+
+(** Exercise: Abstract integers *)
+Definition MyInt : expr :=
+ λ: "z",
+ let: "x" := ref (if: #0 < "z" then (#0, "z") else (-"z", #0)) in
+ ((λ: "y", let: "xv" := !"x" in assert (#0 ≤ Fst "xv");; assert (#0 ≤ Snd "xv");; Snd "xv" - Fst "xv"),
+ (λ: "y", let: "xv" := !"x" in "x" <- (Snd "xv", Fst "xv"))).
+
+Definition FlipInt v : iProp :=
+ {{ True }} (Fst v) #() {{ w, ∃ z : Z, ⌜w = #z⌝ }} ∗
+ {{ True }} (Snd v) #() {{ w, ⌜w = #()⌝ }}.
+
+Definition flipintN := nroot .@ "flipint".
+Lemma MyInt_proof (z : Z) :
+ ⊢ {{ True }} MyInt #z {{ v, FlipInt v }}.
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
diff --git a/theories/program_logics/later_loeb.v b/theories/program_logics/later_loeb.v
index a4e09d142816c1e3fa9873cf64f824b32910b281..8e61fd289f6b26eb3ef90cf95ed7af9343216f53 100644
--- a/theories/program_logics/later_loeb.v
+++ b/theories/program_logics/later_loeb.v
@@ -4,157 +4,73 @@ From iris.base_logic Require Import invariants.
From semantics.pl.heap_lang Require Import adequacy proofmode primitive_laws_nolater.
From semantics.pl Require Import hoare_lib.
From semantics.pl.program_logic Require Import notation.
-From semantics.pl Require Import ipm.
+From semantics.pl Require Import ipm ipm_persistency.
(** ** Step-indexing *)
-Import hoare ipm.
+Import hoare ipm_persistency.
Implicit Types
(P Q R: iProp)
(Φ Ψ : val → iProp)
.
-(*Check ent_later_intro.*)
-(*Check ent_later_mono.*)
-(*Check ent_löb.*)
-(*Check ent_later_sep.*)
-(*Check ent_later_exists.*)
-(*Check ent_later_all.*)
-(*Check ent_later_pers.*)
-
-(*Check ent_later_wp_pure_step.*)
-(*Check ent_later_wp_new.*)
-(*Check ent_later_wp_load.*)
-(*Check ent_later_wp_store.*)
-
-(* Exercise: Derive the old rules from the new ones. *)
-Lemma ent_wp_pure_step_old e e' Φ :
- pure_step e e' →
- WP e' {{ Φ }} ⊢ WP e {{ Φ }}.
-Proof.
- (* FIXME: exercise *)
-Admitted.
-Lemma ent_wp_new_old v Φ :
- (∀ l, l ↦ v -∗ Φ #l) ⊢ WP ref v {{ Φ }}.
-Proof.
- (* FIXME: exercise *)
-Admitted.
-Lemma ent_wp_load_old l v Φ :
- l ↦ v ∗ (l ↦ v -∗ Φ v) ⊢ WP !#l {{ Φ }}.
-Proof.
- (* FIXME: exercise *)
-Admitted.
-Lemma ent_wp_store_old l v w Φ :
- l ↦ v ∗ (l ↦ w -∗ Φ #()) ⊢ WP #l <- w {{ Φ }}.
-Proof.
- (* FIXME: exercise *)
-Admitted.
-
-Lemma ent_later_and P Q :
- ▷ (P ∧ Q) ⊣⊢ ▷ P ∧ ▷ Q.
-Proof.
- specialize (ent_later_all (λ b : bool, if b then P else Q)). rewrite !ent_equiv.
- intros [Ha Hb]. split.
- - apply ent_and_intro.
- + etrans; first etrans; [ | apply Ha | ].
- * apply ent_later_mono. apply ent_all_intro. intros []; [apply ent_and_elim_l | apply ent_and_elim_r].
- * etrans; first apply (ent_all_elim true). apply ent_later_mono. done.
- + apply ent_later_mono. apply ent_and_elim_r.
- - etrans; first etrans; [ | apply Hb | ].
- + apply ent_all_intro. intros []; [apply ent_and_elim_l | apply ent_and_elim_r].
- + apply ent_later_mono. apply ent_and_intro.
- * apply (ent_all_elim true).
- * apply (ent_all_elim false).
-Qed.
-
-Lemma ent_later_or P Q :
- ▷ (P ∨ Q) ⊣⊢ ▷ P ∨ ▷ Q.
-Proof.
- specialize (ent_later_exists (λ b : bool, if b then P else Q)). rewrite !ent_equiv.
- intros [Ha Hb]. split.
- - etrans; first etrans; [ | apply Ha | ].
- + apply ent_later_mono. apply ent_or_elim.
- * by apply (ent_exist_intro true).
- * by apply (ent_exist_intro false).
- + apply ent_exist_elim. intros []; [apply ent_or_introl | apply ent_or_intror].
- - etrans; first etrans; [ | apply Hb | ].
- + apply ent_or_elim.
- * by apply (ent_exist_intro true).
- * by apply (ent_exist_intro false).
- + apply ent_later_mono. apply ent_exist_elim.
- intros []; [apply ent_or_introl | apply ent_or_intror].
-Qed.
-
-Lemma ent_all_pers {X} (Φ : X → iProp) :
- □ (∀ x : X, Φ x) ⊢ ∀ x : X, □ Φ x.
-Proof.
- apply ent_all_intro. intros x. apply ent_pers_mono. apply ent_all_elim.
-Qed.
+(** Step-indexing in the IPM *)
-Lemma ent_wp_rec' Φ (Ψ : val → val → iProp) e :
- (⊢ ∀ v, {{ Φ v ∗ (∀ u, {{ Φ u }} (rec: "f" "x" := e) u {{ Ψ u }})}} subst "x" v (subst "f" (rec: "f" "x" := e) e) {{ Ψ v }}) →
- (⊢ ∀ v, {{ Φ v }} (rec: "f" "x" := e) v {{ Ψ v }}).
+Lemma ipm_later_next_1 P Q R `{!Persistent P} :
+ ▷ P -∗ ▷ R -∗ ▷ Q.
Proof.
- intros Ha. apply ent_löb.
- apply ent_all_intro. intros v.
- etrans. { apply ent_later_mono. apply ent_pers_all. }
- rewrite ent_later_pers. etrans; first apply ent_pers_idemp.
- apply ent_pers_mono.
- apply ent_wand_intro. etrans; last apply ent_wp_pure_steps.
- 2: { apply rtc_pure_step_fill with (K := [AppLCtx _]). apply pure_step_val. done. }
- etrans; last apply ent_later_wp_pure_step.
- 2: { apply pure_step_beta. }
- (* strip the later *)
- etrans. { apply ent_sep_split; first done. apply ent_later_intro. }
- rewrite -ent_later_pers. rewrite -ent_later_sep. apply ent_later_mono.
- (* use the assumption / get it into the right shape to use the hypothesis *)
- etrans.
- { apply ent_sep_split; last done. apply ent_all_pers. }
- rewrite ent_sep_comm. etrans; first apply ent_sep_true.
- apply ent_wand_elim.
- etrans; last apply ent_pers_elim.
- etrans; first apply Ha.
- apply (ent_all_elim v).
-Qed.
+ iIntros "#HP HR".
+ (* this is the main tactic for working with laters. This will strip the later
+ * from all the assumptions *)
+ iNext.
+ Undo.
+ (* we can also introduce the modality using an intro pattern: *)
+ iIntros "!>".
+ Restart.
+ iIntros "#HP HR !>".
+Abort.
-(** Step-indexing in the IPM *)
Lemma ipm_later_sep_commuting P Q :
- ▷ (P ∗ Q) -∗ ▷ P ∗ ▷ Q.
+ ▷ (P ∗ Q) ∗-∗ ▷ P ∗ ▷ Q.
Proof.
- (* automatically commutes the later around the separating conjunction *)
- iIntros "(HP & HQ)".
-
- Restart.
- iIntros "($ & $)".
+ iSplit.
+ - (* automatically commutes the later around the separating conjunction *)
+ iIntros "(HP & HQ)".
+
+ Undo.
+ iIntros "($ & $)".
+ - (* conversely, the same thing happens when splitting *)
+ iIntros "(HP & HQ)".
+ Undo.
+ (* framing is also able to commute laters *)
+ iIntros "($ & $)".
Abort.
Lemma ipm_later_exists_commuting (Φ : nat → iProp) :
- ▷ (∃ n : nat, Φ n) -∗ ∃ n : nat, ▷ Φ n.
+ ▷ (∃ n : nat, Φ n) ∗-∗ ∃ n : nat, ▷ Φ n.
Proof.
- (* automatically commutes the later around the existential *)
- (* note: in general, this relies on the type that is existentially quantified over
- to be [Inhabited]. The IPM tactics will fail if an instance for that cannot be found. *)
- iIntros "(%n & Hn)".
+ iSplit.
+ - (* automatically commutes the later around the existential *)
+ (* note: in general, this relies on the type that is existentially quantified over
+ to be [Inhabited]. The IPM tactics will fail if an instance for that cannot be found. *)
+ iIntros "(%n & Hn)". admit.
+ - iIntros "(%n & Hn)".
+ (* similarly, exists also automatically commutes. *)
+ iExists n. iApply "Hn".
Abort.
Lemma ipm_later_or_commuting P Q :
- ▷ (P ∨ Q) -∗ ▷ P ∨ ▷ Q.
+ ▷ (P ∨ Q) ∗-∗ ▷ P ∨ ▷ Q.
Proof.
- (* automatically commutes the later around the or *)
- iIntros "[ HP | HQ ]".
-
- Restart.
- iIntros "[ $ | $ ]".
+ iSplit.
+ - (* automatically commutes the later around the or *)
+ iIntros "[ HP | HQ ]". all: admit.
+ - iIntros "[ HP | HQ ]".
+ + iLeft. iFrame.
+ + iRight. iFrame.
Abort.
-Lemma ipm_later_next_1 P Q R `{!Persistent P} :
- ▷ P -∗ ▷ R -∗ ▷ Q.
-Proof.
- iIntros "#HP HR".
- (* this will strip the later from all the assumptions *)
- iNext.
-Abort.
-(** The recursion lemma from above, proved with the IPM and Löb induction *)
+(** The recursion lemma from later_playground.v, proved with the IPM and Löb induction *)
Lemma ent_wp_rec v Φ (Ψ : val → val → iProp) e :
(∀ v, (Φ v ∗ (∀ u, {{ Φ u }} (rec: "f" "x" := e) u {{ Ψ u }}) ⊢ WP subst "x" v (subst "f" (rec: "f" "x" := e) e) {{ Ψ v }})) →
(Φ v ⊢ WP (rec: "f" "x" := e) v {{ Ψ v }}).
@@ -177,8 +93,9 @@ Section Z.
(∀ v, (Φ v ∗ (∀ u, {{ Φ u }} Z_com u {{ Ψ u }}) ⊢ WP subst "x" v (subst "f" Z_com e) {{ Ψ v }})) →
(Φ v ⊢ WP Z_com v {{ Ψ v }}).
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
End Z.
Notation iPropO := (iPropO adequacy.heapΣ).
@@ -226,19 +143,15 @@ Proof.
iPureIntro. apply pure_step_beta.
Qed.
-Lemma infinite_wp_False' e :
- infinite_exec e ⊢ WP e {{ _, False }}.
-Proof.
- (* FIXME: exercise *)
-Admitted.
Lemma infinite_wp_False e :
infinite_exec e ⊢ WP e {{ _, False }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
(** Diverge using higher-order state *)
Definition diverge_ho : expr :=
let: "d" := ref (λ: "x", "x") in
@@ -266,9 +179,10 @@ Lemma landins_knot_spec (t : val) Φ Ψ :
(∀ f : val, ⊢ {{ (∀ v : val, {{ Φ v }} f v {{ Ψ }}) }} t f {{ g, ∀ v, {{ Φ v }} g v {{ Ψ }} }}) →
⊢ {{ True }} landins_knot t {{ g, ∀ v, {{ Φ v }} g v {{ Ψ }} }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
(** * Impredicative invariants *)
Import impred_invariants.
(* [ent_inv_pers] and [ent_inv_alloc] hold unchanged *)
@@ -459,10 +373,11 @@ Lemma lazyint_two_spec (h1 h2 f : val) n :
(∀ f n, {{ LazyInt f n }} h2 f {{ v, ∃ m : Z, ⌜v = #m⌝ }}) -∗
{{ LazyInt f n }} lazyint_two h1 h2 f {{ v, ∃ m, ⌜v = #m⌝ }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
(** Exercise: derive the invariant rule for timeless propositions *)
Lemma inv_open_timeless N E F `{!Timeless F} e Φ :
↑N ⊆ E →
@@ -470,5 +385,6 @@ Lemma inv_open_timeless N E F `{!Timeless F} e Φ :
(F -∗ WP e @ (E ∖ ↑N) {{ v, ▷ F ∗ Φ v }})%I -∗
WP e @ E {{ Φ }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
diff --git a/theories/program_logics/later_playground.v b/theories/program_logics/later_playground.v
new file mode 100644
index 0000000000000000000000000000000000000000..632890e51e9adf32003e71b559e580b927f606d8
--- /dev/null
+++ b/theories/program_logics/later_playground.v
@@ -0,0 +1,100 @@
+From iris.proofmode Require Import tactics.
+From iris.heap_lang Require Import lang primitive_laws notation.
+From iris.base_logic Require Import invariants.
+From semantics.pl.heap_lang Require Import adequacy proofmode primitive_laws_nolater.
+From semantics.pl Require Import hoare_lib.
+From semantics.pl.program_logic Require Import notation.
+From semantics.pl Require Import ipm ipm_persistency.
+
+(** ** Step-indexing *)
+Import hoare ipm_persistency.
+Implicit Types
+ (P Q R: iProp)
+ (Φ Ψ : val → iProp)
+.
+
+(*Check ent_later_intro.*)
+(*Check ent_later_mono.*)
+(*Check ent_löb.*)
+(*Check ent_later_sep.*)
+(*Check ent_later_exists.*)
+(*Check ent_later_all.*)
+(*Check ent_later_pers.*)
+
+(*Check ent_later_wp_pure_step.*)
+(*Check ent_later_wp_new.*)
+(*Check ent_later_wp_load.*)
+(*Check ent_later_wp_store.*)
+
+(* Exercise: Derive the old rules from the new ones. *)
+Lemma ent_wp_pure_step_old e e' Φ :
+ pure_step e e' →
+ WP e' {{ Φ }} ⊢ WP e {{ Φ }}.
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+Lemma ent_wp_new_old v Φ :
+ (∀ l, l ↦ v -∗ Φ #l) ⊢ WP ref v {{ Φ }}.
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+Lemma ent_wp_load_old l v Φ :
+ l ↦ v ∗ (l ↦ v -∗ Φ v) ⊢ WP !#l {{ Φ }}.
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+Lemma ent_wp_store_old l v w Φ :
+ l ↦ v ∗ (l ↦ w -∗ Φ #()) ⊢ WP #l <- w {{ Φ }}.
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+
+Lemma ent_later_and P Q :
+ ▷ (P ∧ Q) ⊣⊢ ▷ P ∧ ▷ Q.
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+
+Lemma ent_later_or P Q :
+ ▷ (P ∨ Q) ⊣⊢ ▷ P ∨ ▷ Q.
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+
+Lemma ent_all_pers {X} (Φ : X → iProp) :
+ □ (∀ x : X, Φ x) ⊢ ∀ x : X, □ Φ x.
+Proof.
+ apply ent_all_intro. intros x. apply ent_pers_mono. apply ent_all_elim.
+Qed.
+
+Lemma ent_wp_rec' Φ (Ψ : val → val → iProp) e :
+ (⊢ ∀ v, {{ Φ v ∗ (∀ u, {{ Φ u }} (rec: "f" "x" := e) u {{ Ψ u }})}} subst "x" v (subst "f" (rec: "f" "x" := e) e) {{ Ψ v }}) →
+ (⊢ ∀ v, {{ Φ v }} (rec: "f" "x" := e) v {{ Ψ v }}).
+Proof.
+ intros Ha. apply ent_löb.
+ apply ent_all_intro. intros v.
+ etrans. { apply ent_later_mono. apply ent_pers_all. }
+ rewrite ent_later_pers. etrans; first apply ent_pers_idemp.
+ apply ent_pers_mono.
+ apply ent_wand_intro. etrans; last apply ent_wp_pure_steps.
+ 2: { apply rtc_pure_step_fill with (K := [AppLCtx _]). apply pure_step_val. done. }
+ etrans; last apply ent_later_wp_pure_step.
+ 2: { apply pure_step_beta. }
+ (* strip the later *)
+ etrans. { apply ent_sep_split; first done. apply ent_later_intro. }
+ rewrite -ent_later_pers. rewrite -ent_later_sep. apply ent_later_mono.
+ (* use the assumption / get it into the right shape to use the hypothesis *)
+ etrans.
+ { apply ent_sep_split; last done. apply ent_all_pers. }
+ rewrite ent_sep_comm. etrans; first apply ent_sep_true.
+ apply ent_wand_elim.
+ etrans; last apply ent_pers_elim.
+ etrans; first apply Ha.
+ apply (ent_all_elim v).
+Qed.
\ No newline at end of file
diff --git a/theories/program_logics/logrel/ghost_state.v b/theories/program_logics/logrel/ghost_state.v
index 79ab894413a38fcaccf503dbb5e8e28a4d5ba0db..cb2afa4e249384ac1136959cc15ddc8a4d12a576 100644
--- a/theories/program_logics/logrel/ghost_state.v
+++ b/theories/program_logics/logrel/ghost_state.v
@@ -23,27 +23,31 @@ Section derived.
(P -∗ Q) -∗
|==> Q.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma upd_mono P Q :
(P ⊢ Q) →
(|==> P) ⊢ |==> Q.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma upd_trans P :
(|==> |==> P) ⊢ |==> P.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma upd_frame P Q :
P -∗ (|==> Q) -∗ |==> (P ∗ Q).
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
End derived.
(** ** The mono nat ghost theory *)
@@ -72,9 +76,10 @@ Section mono_derived.
n ≤ m →
mono γ n -∗ |==> mono γ m.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
Lemma mono_nat_increase_wp γ n m e Φ :
n ≤ m →
(mono γ m -∗ WP e {{ Φ }}) -∗
@@ -88,8 +93,9 @@ Section mono_derived.
Lemma mono_nat_new_wp e Φ n :
(∀ γ, mono γ n -∗ WP e {{ Φ }}) -∗ WP e {{ Φ }}.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
End mono_derived.
(** ** Updates in the IPM *)
@@ -215,9 +221,10 @@ Section logrel_oneshot.
Lemma code_safe :
TY 0; ∅ ⊨ code : ((TUnit → TUnit) → TUnit).
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
End logrel_oneshot.
(** Exercise: Agreement *)
@@ -246,8 +253,9 @@ Section logrel_ag.
Lemma rec_code_safe :
TY 0 ; ∅ ⊨ rec_code : (((TUnit → TInt) → TBool) → TInt).
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
End logrel_ag.
(** Exercise: Red/blue *)
@@ -279,6 +287,7 @@ Section logrel_redblue.
Lemma mkColourGen_safe :
TY 0; ∅ ⊨ mkColourGen : (∃: ∃: ((TUnit → #0) × (TUnit → #1)) × (#0 → #1 → TUnit)).
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
End logrel_redblue.
diff --git a/theories/program_logics/logrel/logrel.v b/theories/program_logics/logrel/logrel.v
index b413aa4331d2d99997b5afa58c79ef6b713a65f9..62196a70944558ce63e31328f26c68a248034c92 100644
--- a/theories/program_logics/logrel/logrel.v
+++ b/theories/program_logics/logrel/logrel.v
@@ -1,3 +1,4 @@
+
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import lang notation.
From iris.heap_lang Require Import metatheory.
@@ -488,52 +489,52 @@ Lemma compat_pair Δ Γ e1 e2 A B :
TY Δ; Γ ⊨ e2 : B →
TY Δ; Γ ⊨ (e1, e2) : A × B.
Proof.
- (* FIXME exercise *)
-(*Qed.*)
+ (* TODO: exercise *)
Admitted.
+
Lemma compat_fst Δ Γ e A B :
TY Δ; Γ ⊨ e : A × B →
TY Δ; Γ ⊨ Fst e : A.
Proof.
- (* FIXME exercise *)
-(*Qed.*)
+ (* TODO: exercise *)
Admitted.
+
Lemma compat_snd Δ Γ e A B :
TY Δ; Γ ⊨ e : A × B →
TY Δ; Γ ⊨ Snd e : B.
Proof.
- (* FIXME exercise *)
-(*Qed.*)
+ (* TODO: exercise *)
Admitted.
+
Lemma compat_injl Δ Γ e A B :
TY Δ; Γ ⊨ e : A →
TY Δ; Γ ⊨ InjL e : A + B.
Proof.
- (* FIXME exercise *)
-(*Qed.*)
+ (* TODO: exercise *)
Admitted.
+
Lemma compat_injr Δ Γ e A B :
TY Δ; Γ ⊨ e : B →
TY Δ; Γ ⊨ InjR e : A + B.
Proof.
- (* FIXME exercise *)
-(*Qed.*)
+ (* TODO: exercise *)
Admitted.
+
Lemma compat_case Δ Γ e e1 e2 A B C :
TY Δ; Γ ⊨ e : B + C →
TY Δ; Γ ⊨ e1 : (B → A) →
TY Δ; Γ ⊨ e2 : (C → A) →
TY Δ; Γ ⊨ Case e e1 e2 : A.
Proof.
- (* FIXME exercise *)
-(*Qed.*)
+ (* TODO: exercise *)
Admitted.
+
Lemma compat_roll Δ Γ e A :
TY Δ; Γ ⊨ e : (A.[(μ: A)%ty/]) →
TY Δ; Γ ⊨ (roll e) : (μ: A).
diff --git a/theories/program_logics/resource_algebras.v b/theories/program_logics/resource_algebras_1.v
similarity index 57%
rename from theories/program_logics/resource_algebras.v
rename to theories/program_logics/resource_algebras_1.v
index 66fa150c809e70b73db90803cd61c3d45b3fb781..6fcca85e3614c5ea6f0a459ae1f89780b67d71a4 100644
--- a/theories/program_logics/resource_algebras.v
+++ b/theories/program_logics/resource_algebras_1.v
@@ -126,9 +126,10 @@ Lemma lra_update_exclusive {A : lra} (x y : A) :
✓ y →
lra_update x y.
Proof.
- (* FIXME: exercise *)
+ (* TODO: exercise *)
Admitted.
+
(** Relation of update and updateP *)
Lemma lra_update_updateP {A : lra} (x y : A) : lra_update x y ↔ lra_updateP x (y =.).
Proof. split=> Hup z ?; eauto. destruct (Hup z) as (?&<-&?); auto. Qed.
@@ -182,8 +183,7 @@ Section total.
Proof using Type*.
rewrite /core. destruct (lra_total x) as [cx ->]. done.
Qed.
- Lemma lra_core_l x : core x ⋅ (*done. *)
- (*Qed.*)x = x.
+ Lemma lra_core_l x : core x ⋅ x = x.
Proof using Type*.
destruct (lra_total x) as [cx Hcx]. by rewrite /core /= Hcx lra_pcore_l.
Qed.
@@ -331,6 +331,8 @@ Section nat.
Lemma nat_op (x y : nat) : x ⋅ y = (x + y).
Proof. reflexivity. Qed.
+ Lemma nat_unit : ε = 0.
+ Proof. done. Qed.
Lemma nat_included x y : x ≼ y ↔ x ≤ y.
Proof.
@@ -392,74 +394,75 @@ End frac.
(** ** Exercise: (Z, +) *)
Section Z.
- (** FIXME: This is an exercise for you! *)
- Instance Z_unit_instance : Unit Z := 42 (* FIXME *).
- Instance Z_valid_instance : Valid Z := λ x, False (* FIXME *).
- Instance Z_pcore_instance : PCore Z := λ x, None (* FIXME *).
- Instance Z_op_instance : Op Z := λ n m, n (* FIXME *).
+ (** TODO: This is an exercise for you! *)
+ Instance Z_unit_instance : Unit Z := 42 (* TODO *).
+ Instance Z_valid_instance : Valid Z := λ x, False (* TODO *).
+ Instance Z_pcore_instance : PCore Z := λ x, None (* TODO *).
+ Instance Z_op_instance : Op Z := λ n m, n (* TODO *).
- Lemma Z_op (x y : Z) : x ⋅ y = x (* FIXME *).
+ Lemma Z_op (x y : Z) : x ⋅ y = x (* TODO *).
Proof. reflexivity. Qed.
- Lemma Z_included (x y : Z) : x ≼ y ↔ False (* FIXME *).
+ Lemma Z_included (x y : Z) : x ≼ y ↔ False (* TODO *).
Proof.
- (* FIXME *)
- (*Qed.*)
+ (* TODO: exercise *)
Admitted.
+
Lemma Z_lra_mixin : LRAMixin Z.
Proof.
constructor; apply _ || eauto.
- (* FIXME *)
- (*Qed.*)
+ (* TODO: exercise *)
Admitted.
+
+
Canonical Structure ZR : lra := Lra Z Z_lra_mixin.
Lemma Z_ulra_mixin : ULRAMixin Z.
Proof.
- (* FIXME *)
- (*constructor; done. *)
- (*Qed.*)
+ (* TODO: exercise *)
Admitted.
+
+
Canonical Structure ZUR : ulra := Ulra Z Z_lra_mixin Z_ulra_mixin.
- Lemma Z_update (x y : Z) : lra_update x y ↔ False (* FIXME *).
+ Lemma Z_update (x y : Z) : lra_update x y ↔ False (* TODO *).
Proof.
- (* FIXME *)
- (*done. *)
- (*Qed.*)
+ (* TODO: exercise *)
Admitted.
+
End Z.
(** ** Exercise: The (nat, min) RA *)
Record min_nat := MinNat { min_nat_car : nat }.
Add Printing Constructor min_nat.
Section min_nat.
- (* FIXME: This is an exercise for you. Fix the definitions and statements. *)
- Instance min_nat_valid_instance : Valid min_nat := λ x, False (* FIXME *).
- Instance min_nat_pcore_instance : PCore min_nat := λ x, None (* FIXME *).
- Instance min_nat_op_instance : Op min_nat := λ n m, n (* FIXME *).
+ (* TODO: This is an exercise for you. Fix the definitions and statements. *)
+ Instance min_nat_valid_instance : Valid min_nat := λ x, False (* TODO *).
+ Instance min_nat_pcore_instance : PCore min_nat := λ x, None (* TODO *).
+ Instance min_nat_op_instance : Op min_nat := λ n m, n (* TODO *).
- Lemma min_nat_op x y : MinNat x ⋅ MinNat y = MinNat x (* FIXME *).
+ Lemma min_nat_op x y : MinNat x ⋅ MinNat y = MinNat x (* TODO *).
Proof. reflexivity. Qed.
- Lemma min_nat_included (x y : min_nat) : x ≼ y ↔ False (* FIXME *).
+ Lemma min_nat_included (x y : min_nat) : x ≼ y ↔ False (* TODO *).
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
Lemma min_nat_lra_mixin : LRAMixin min_nat.
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
Canonical Structure min_natR : lra := Lra min_nat min_nat_lra_mixin.
- Lemma min_nat_update (x y : min_nat) : lra_update x y ↔ False (* FIXME *).
+ Lemma min_nat_update (x y : min_nat) : lra_update x y ↔ False (* TODO *).
Proof.
- (* FIXME *)
- (*done. *)
- (*Qed.*)
+ (* TODO: exercise *)
Admitted.
+
End min_nat.
(** ** Options *)
@@ -722,95 +725,53 @@ End sum.
(** ** Exercise: products *)
Section prod.
Context {A B : lra}.
- (* FIXME: this is an exercise for you *)
+ (* TODO: this is an exercise for you *)
- Local Instance prod_op_instance : Op (A * B) := λ x y, x (* FIXME *).
+ Local Instance prod_op_instance : Op (A * B) := λ x y, x (* TODO *).
Local Instance prod_pcore_instance : PCore (A * B) := λ x,
- None. (* FIXME *)
- Local Instance prod_valid_instance : Valid (A * B) := λ x, False (* FIXME *).
+ None (* TODO *).
+ Local Instance prod_valid_instance : Valid (A * B) := λ x, False (* TODO *).
- Lemma prod_included (x y : A * B) : x ≼ y ↔ False (* FIXME *).
+ Lemma prod_included (x y : A * B) : x ≼ y ↔ False (* TODO *).
Proof.
- (* FIXME *)
- (*Qed.*)
+ (* TODO: exercise *)
Admitted.
+
(** You may want to state some additional lemmas about the operation of the operations on pairs (a, b) *)
+
+
+
Definition prod_lra_mixin : LRAMixin (A * B).
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
Canonical Structure prodR := Lra (prod A B) prod_lra_mixin.
Lemma pair_exclusive a b :
lra_exclusive a ∨ lra_exclusive b → lra_exclusive (a, b).
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
End prod.
-(* FIXME: if products have a unit, uncomment the following code and fix it*)
+
+(* TODO: if products have a unit, uncomment the following code and fix it*)
(*
Section prod_unit.
Context {A B : ulra}.
- Instance prod_unit_instance : Unit (A * B) := (??) (* FIXME *).
+ Instance prod_unit_instance : Unit (A * B) := (??) (* TODO *).
Lemma prod_ulra_mixin : ULRAMixin (A * B).
Proof.
- (* FIXME *)
+ (* TODO *)
Admitted.
Canonical Structure prodUR := Ulra (prod A B) prod_lra_mixin prod_ulra_mixin.
End prod_unit.
*)
-(** ** Exercise: functions, pointwise *)
-Section functions.
- (* FIXME: this is an exercise for you *)
- Context {A : Type} {B : ulra}.
- Implicit Types (f g : A → B).
-
- (* You may assume functional extensionality.
- (Note that in the Iris version of this RA, FE is not needed, due to a more flexible setup of RAs.) *)
- Import FunctionalExtensionality.
- Notation fext := functional_extensionality.
-
- Local Instance fun_op_instance : Op (A → B) := λ f g, f (* FIXME *).
- Local Instance fun_pcore_instance : PCore (A → B) := λ f, None (* FIXME *).
- Local Instance fun_valid_instance : Valid (A → B) := λ f, False (* FIXME *).
- (* FIXME: uncomment if there's a unit *)
- (*Local Instance fun_unit_instance : Unit (A → B) := λ a, (??) .*)
-
- Lemma fun_included f g :
- f ≼ g → False (* FIXME *).
- Proof.
- (* FIXME *)
- Admitted.
-
- (* You may want to derive additional lemmas about the definition of your operations *)
-
- Lemma fun_lra_mixin : LRAMixin (A → B).
- Proof.
- (** Hint: you may want to use that [B]'s core is total. *)
- (* FIXME *)
- Admitted.
- Canonical Structure funR := Lra (A → B) fun_lra_mixin.
-
- (* FIXME: uncomment if you think that there's a unit *)
- (*
- Lemma fun_ulra_mixin : ULRAMixin (A → B).
- Proof.
- Admitted.
- (*Qed.*)
- Canonical Structure funUR := Ulra (A → B) fun_lra_mixin fun_ulra_mixin.
- *)
-
- Lemma fun_exclusive `{Inhabited A} f :
- (∀ a, lra_exclusive (f a)) → lra_exclusive f.
- Proof.
- (* Hint: you may assume that [A] is inhabited, i.e., there's an [inhabitant] of A that you can use. *)
- (* FIXME *)
- Admitted.
-End functions.
(** ** The Excl(A) RA *)
Inductive excl (A : Type) :=
@@ -1132,29 +1093,33 @@ Section auth.
lra_local_update (a, b) (a', b') →
lra_update (auth_auth a ⋅ auth_frag b) (auth_auth a' ⋅ auth_frag b').
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
Lemma auth_update_auth_auth_frag a a' b' :
lra_local_update (a, ε) (a', b') →
lra_update (auth_auth a) (auth_auth a' ⋅ auth_frag b').
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
Lemma auth_update_auth_auth a a' b' :
lra_local_update (a, ε) (a', b') →
lra_update (auth_auth a) (auth_auth a').
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
Lemma auth_update_auth_frag_auth a b a' :
lra_local_update (a, b) (a', ε) →
lra_update (auth_auth a ⋅ auth_frag b) (auth_auth a').
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
End auth.
Global Arguments authR : clear implicits.
@@ -1227,699 +1192,104 @@ Proof.
apply excl_lra_exclusive.
Qed.
-(** Finite functions *)
-Section fin_fun.
- Context `{Countable K} {A : lra}.
- Implicit Types m : gmap K A.
-
- (** The proofs in this section are quite a mouthful, so we recommend to skip over them.
- They are just here for completeness.
- (The lemma statements are more interesting, though: especially the local updates, which you will need to do some of the exercises below!)
- *)
-
- Local Instance gmap_unit_instance : Unit (gmap K A) := (∅ : gmap K A).
- Local Instance gmap_op_instance : Op (gmap K A) := merge op.
- Local Instance gmap_pcore_instance : PCore (gmap K A) := λ m, Some (omap pcore m).
- Local Instance gmap_valid_instance : Valid (gmap K A) := λ m, ∀ i, ✓ (m !! i).
-
- Lemma gmap_op m1 m2 : m1 ⋅ m2 = merge op m1 m2.
- Proof. done. Qed.
- Lemma lookup_op m1 m2 i : (m1 ⋅ m2) !! i = m1 !! i ⋅ m2 !! i.
- Proof. rewrite lookup_merge. by destruct (m1 !! i), (m2 !! i). Qed.
- Lemma lookup_core m i : core m !! i = core (m !! i).
- Proof. by apply lookup_omap. Qed.
- Lemma gmap_pcore m : pcore m = Some (omap pcore m).
- Proof. done. Qed.
-
- Lemma lookup_included (m1 m2 : gmap K A) : m1 ≼ m2 ↔ ∀ i, m1 !! i ≼ m2 !! i.
- Proof.
- split; [by intros [m Hm] i; exists (m !! i); rewrite -lookup_op Hm|].
- revert m2. induction m1 as [|i x m Hi IH] using map_ind=> m2 Hm.
- { exists m2. by rewrite left_id. }
- destruct (IH (delete i m2)) as [m2' Hm2'].
- { intros j. move: (Hm j); destruct (decide (i = j)) as [->|].
- - intros _. rewrite Hi. apply: ulra_unit_least.
- - rewrite lookup_insert_ne // lookup_delete_ne //. }
- destruct (Hm i) as [my Hi']; simplify_map_eq.
- exists (partial_alter (λ _, my) i m2'). apply map_eq => j.
- destruct (decide (i = j)) as [->|].
- - by rewrite Hi' lookup_op lookup_insert lookup_partial_alter.
- - move : Hm2'. rewrite map_eq_iff. intros Hm2'. move : (Hm2' j).
- by rewrite !lookup_op lookup_delete_ne //
- lookup_insert_ne // lookup_partial_alter_ne.
- Qed.
-
- Lemma gmap_lra_mixin : LRAMixin (gmap K A).
- Proof.
- apply lra_total_mixin.
- - done.
- - intros m1 m2 m3. apply map_eq. intros i. by rewrite !lookup_op assoc.
- - intros m1 m2. apply map_eq. intros i. by rewrite !lookup_op lra_comm.
- - intros m. apply map_eq. intros i. by rewrite lookup_op lookup_core lra_core_l.
- - intros m. apply map_eq. intros i. by rewrite !lookup_core lra_core_idemp.
- - intros m1 m2; rewrite !lookup_included=> Hm i.
- rewrite !lookup_core. by apply lra_core_mono.
- - intros m1 m2 Hm i. apply lra_valid_op_l with (m2 !! i).
- by rewrite -lookup_op.
- Qed.
- Canonical Structure gmapR := Lra (gmap K A) gmap_lra_mixin.
-
- Lemma gmap_ulra_mixin : ULRAMixin (gmap K A).
- Proof.
- split.
- - intros m. apply map_eq. intros i; by rewrite /= lookup_op lookup_empty (left_id_L None _).
- - by intros i; rewrite lookup_empty.
- - rewrite /pcore /gmap_pcore_instance. f_equiv. apply map_eq. intros i. by rewrite lookup_omap lookup_empty.
- Qed.
- Canonical Structure gmapUR := Ulra (gmap K A) gmap_lra_mixin gmap_ulra_mixin.
-
- Lemma lookup_valid_Some m i x : ✓ m → m !! i = Some x → ✓ x.
- Proof. move=> Hm Hi. move:(Hm i). by rewrite Hi. Qed.
-
- Lemma insert_valid m i x : ✓ x → ✓ m → ✓ <[i:=x]>m.
- Proof. by intros ?? j; destruct (decide (i = j)); simplify_map_eq. Qed.
- Lemma singleton_valid i x : ✓ ({[ i := x ]} : gmap K A) ↔ ✓ x.
- Proof.
- split.
- - move=>/(_ i); by simplify_map_eq.
- - intros. apply insert_valid; first done. apply: ulra_unit_valid.
- Qed.
- Lemma delete_valid m i : ✓ m → ✓ (delete i m).
- Proof. intros Hm j; destruct (decide (i = j)); by simplify_map_eq. Qed.
-
- Lemma insert_singleton_op m i x : m !! i = None → <[i:=x]> m = {[ i := x ]} ⋅ m.
- Proof.
- intros Hi; apply map_eq=> j; destruct (decide (i = j)) as [->|].
- - by rewrite lookup_op lookup_insert lookup_singleton Hi right_id_L.
- - by rewrite lookup_op lookup_insert_ne // lookup_singleton_ne // left_id_L.
- Qed.
-
- Lemma singleton_core (i : K) (x : A) cx :
- pcore x = Some cx → core {[ i := x ]} =@{gmap K A} {[ i := cx ]}.
- Proof. apply omap_singleton_Some. Qed.
- Lemma singleton_core_total `{!LraTotal A} (i : K) (x : A) :
- core {[ i := x ]} =@{gmap K A} {[ i := core x ]}.
- Proof. apply singleton_core. apply lra_pcore_core. Qed.
- Lemma singleton_op (i : K) (x y : A) :
- {[ i := x ]} ⋅ {[ i := y ]} =@{gmap K A} {[ i := x ⋅ y ]}.
- Proof. by apply (merge_singleton _ _ _ x y). Qed.
-
- Lemma singleton_included_l m i x :
- {[ i := x ]} ≼ m ↔ ∃ y, m !! i = Some y ∧ Some x ≼ Some y.
- Proof.
- split.
- - move=> [m' ]. rewrite map_eq_iff. intros Heq. specialize (Heq i).
- rewrite lookup_op lookup_singleton in Heq.
- exists (x ⋅? m' !! i). rewrite -Some_op_opM.
- split; first done. apply lra_included_l.
- - intros (y&Hi&[mz Hy]). exists (partial_alter (λ _, mz) i m).
- apply map_eq. intros j; destruct (decide (i = j)) as [->|].
- + by rewrite lookup_op lookup_singleton lookup_partial_alter Hi.
- + by rewrite lookup_op lookup_singleton_ne// lookup_partial_alter_ne// left_id.
- Qed.
- Lemma singleton_included_exclusive_l m i x :
- lra_exclusive x → ✓ m →
- {[ i := x ]} ≼ m ↔ m !! i = Some x.
- Proof.
- intros ? Hm. rewrite singleton_included_l. split.
- - intros (y&?&->%(Some_included_lra_exclusive _)); eauto using lookup_valid_Some.
- - intros ->. exists x. split; first done. reflexivity.
- Qed.
- Lemma singleton_included i x y :
- {[ i := x ]} ≼ ({[ i := y ]} : gmap K A) ↔ x = y ∨ x ≼ y.
- Proof.
- rewrite singleton_included_l. split.
- - intros (y'&Hi&Ha). rewrite lookup_insert in Hi.
- apply Some_included in Ha as (? & [= <-] & ?). naive_solver.
- - intros ?. exists y. rewrite lookup_insert Some_included; eauto.
- Qed.
- Lemma singleton_mono i x y :
- x ≼ y → {[ i := x ]} ≼ ({[ i := y ]} : gmap K A).
- Proof. intros Hincl. apply singleton_included. right. done. Qed.
-
- Lemma insert_op m1 m2 i x y :
- <[i:=x ⋅ y]>(m1 ⋅ m2) = <[i:=x]>m1 ⋅ <[i:=y]>m2.
- Proof. by rewrite (insert_merge (⋅) m1 m2 i (x ⋅ y) x y). Qed.
-
- (** Updates *)
- Lemma insert_updateP (P : A → Prop) (Q : gmap K A → Prop) m i x :
- lra_updateP x P →
- (∀ y, P y → Q (<[i:=y]>m)) →
- lra_updateP (<[i:=x]>m) Q.
- Proof.
- intros Hx%option_updateP' HP; apply lra_total_updateP=> mf Hm.
- destruct (Hx (Some (mf !! i))) as ([y|]&?&?); try done.
- { by generalize (Hm i); rewrite lookup_op; simplify_map_eq. }
- exists (<[i:=y]> m); split; first by auto.
- intros j; move: (Hm j)=>{Hm}; rewrite !lookup_op=>Hm.
- destruct (decide (i = j)); simplify_map_eq/=; auto.
- Qed.
- Lemma insert_updateP' (P : A → Prop) m i x :
- lra_updateP x P → lra_updateP (<[i:=x]>m) (λ m', ∃ y, m' = <[i:=y]>m ∧ P y).
- Proof. eauto using insert_updateP. Qed.
- Lemma insert_update m i x y : lra_update x y → lra_update (<[i:=x]>m) (<[i:=y]>m).
- Proof. rewrite !lra_update_updateP; eauto using insert_updateP with subst. Qed.
-
- Lemma singleton_updateP (P : A → Prop) (Q : gmap K A → Prop) i x :
- lra_updateP x P → (∀ y, P y → Q {[ i := y ]}) → lra_updateP {[ i := x ]} Q.
- Proof. apply insert_updateP. Qed.
- Lemma singleton_updateP' (P : A → Prop) i x :
- lra_updateP x P → lra_updateP {[ i := x ]} (λ m, ∃ y, m = {[ i := y ]} ∧ P y).
- Proof. apply insert_updateP'. Qed.
- Lemma singleton_update i (x y : A) : lra_update x y → lra_update {[ i := x ]} {[ i := y ]}.
- Proof. apply insert_update. Qed.
-
- Lemma delete_update m i : lra_update m (delete i m).
- Proof.
- apply lra_total_update=> mf Hm j; destruct (decide (i = j)); subst.
- - move: (Hm j). rewrite !lookup_op lookup_delete left_id.
- apply lra_valid_op_r.
- - move: (Hm j). by rewrite !lookup_op lookup_delete_ne.
- Qed.
-
- Lemma dom_op m1 m2 : dom (m1 ⋅ m2) = dom m1 ∪ dom m2.
- Proof.
- apply set_eq=> i; rewrite elem_of_union !elem_of_dom.
- unfold is_Some; setoid_rewrite lookup_op.
- destruct (m1 !! i), (m2 !! i); naive_solver.
- Qed.
- Lemma dom_included m1 m2 : m1 ≼ m2 → dom m1 ⊆ dom m2.
- Proof.
- rewrite lookup_included=>Ha i; rewrite !elem_of_dom.
- specialize (Ha i). intros (c & Hc).
- rewrite Hc in Ha. apply Some_included in Ha as (b & -> & _). eauto.
- Qed.
-
- Section freshness.
- Local Set Default Proof Using "Type*".
- Context `{!Infinite K}.
- Lemma alloc_updateP_strong_dep (Q : gmap K A → Prop) (I : K → Prop) m (f : K → A) :
- pred_infinite I →
- (∀ i, m !! i = None → I i → ✓ (f i)) →
- (∀ i, m !! i = None → I i → Q (<[i:=f i]>m)) →
- lra_updateP m Q.
- Proof.
- move=> /(pred_infinite_set I (C:=gset K)) HP ? HQ.
- apply lra_total_updateP. intros mf Hm.
- destruct (HP (dom (m ⋅ mf))) as [i [Hi1 Hi2]].
- assert (m !! i = None).
- { eapply (not_elem_of_dom). revert Hi2.
- rewrite dom_op not_elem_of_union. naive_solver. }
- exists (<[i:=f i]>m); split.
- - by apply HQ.
- - rewrite insert_singleton_op //.
- rewrite -assoc -insert_singleton_op;
- last by eapply (not_elem_of_dom (D:=gset K)).
- apply insert_valid; auto.
- Qed.
- (** This corresponds to the Alloc axiom shown on paper. *)
- Lemma alloc_updateP_strong (Q : gmap K A → Prop) (I : K → Prop) m x :
- pred_infinite I →
- ✓ x → (∀ i, m !! i = None → I i → Q (<[i:=x]>m)) →
- lra_updateP m Q.
- Proof.
- move=> HP ? HQ. eapply (alloc_updateP_strong_dep _ _ _ (λ _, x)); eauto.
- Qed.
- Lemma alloc_updateP (Q : gmap K A → Prop) m x :
- ✓ x → (∀ i, m !! i = None → Q (<[i:=x]>m)) → lra_updateP m Q.
- Proof.
- move=>??.
- eapply (alloc_updateP_strong _ (λ _, True));
- eauto using pred_infinite_True.
- Qed.
- Lemma alloc_updateP_cofinite (Q : gmap K A → Prop) (J : gset K) m x :
- ✓ x → (∀ i, m !! i = None → i ∉ J → Q (<[i:=x]>m)) → lra_updateP m Q.
- Proof.
- eapply alloc_updateP_strong.
- apply (pred_infinite_set (C:=gset K)).
- intros E. exists (fresh (J ∪ E)).
- apply not_elem_of_union, is_fresh.
- Qed.
- End freshness.
-
- Lemma alloc_unit_singleton_updateP (P : A → Prop) (Q : gmap K A → Prop) u i :
- ✓ u → LeftId (=) u (⋅) →
- lra_updateP u P → (∀ y, P y → Q {[ i := y ]}) → lra_updateP ∅ Q.
- Proof.
- intros ?? Hx HQ. apply lra_total_updateP=> gf Hg.
- destruct (Hx (gf !! i)) as (y&?&Hy).
- { move:(Hg i). rewrite !left_id.
- case: (gf !! i)=>[x|]; rewrite /= ?left_id //.
- }
- exists {[ i := y ]}; split; first by auto.
- intros i'; destruct (decide (i' = i)) as [->|].
- - rewrite lookup_op lookup_singleton.
- move:Hy; case: (gf !! i)=>[x|]; rewrite /= ?right_id //.
- - move:(Hg i'). by rewrite !lookup_op lookup_singleton_ne // !left_id.
- Qed.
- Lemma alloc_unit_singleton_updateP' (P: A → Prop) u i :
- ✓ u → LeftId (=) u (⋅) →
- lra_updateP u P → lra_updateP ∅ (λ m, ∃ y, m = {[ i := y ]} ∧ P y).
- Proof. eauto using alloc_unit_singleton_updateP. Qed.
- Lemma alloc_unit_singleton_update (u : A) i (y : A) :
- ✓ u → LeftId (=) u (⋅) → lra_update u y → lra_update (∅:gmap K A) {[ i := y ]}.
- Proof.
- rewrite !lra_update_updateP; eauto using alloc_unit_singleton_updateP with subst.
- Qed.
-
- (** Local updates *)
- Lemma alloc_local_update m1 m2 i x :
- m1 !! i = None → ✓ x → lra_local_update (m1,m2) (<[i:=x]>m1, <[i:=x]>m2).
- Proof.
- intros Hi ?. apply local_update_unital => mf Hmv; simpl in *.
- rewrite map_eq_iff => Hm.
- split; auto using insert_valid.
- apply (map_eq (<[i := x]> m1)). intros j; destruct (decide (i = j)) as [->|].
- - move: (Hm j); rewrite Hi symmetry_iff lookup_op None_op => -[_ Hj].
- by rewrite lookup_op !lookup_insert Hj.
- - rewrite lookup_insert_ne // !lookup_op lookup_insert_ne //.
- rewrite Hm lookup_op //.
- Qed.
-
- Lemma alloc_singleton_local_update m i x :
- m !! i = None → ✓ x → lra_local_update (m,∅) (<[i:=x]>m, {[ i:=x ]}).
- Proof. apply alloc_local_update. Qed.
-
- Lemma insert_local_update m1 m2 i x y x' y' :
- m1 !! i = Some x → m2 !! i = Some y →
- lra_local_update (x, y) (x', y') →
- lra_local_update (m1, m2) (<[i:=x']>m1, <[i:=y']>m2).
- Proof.
- intros Hi1 Hi2 Hup; apply local_update_unital=> mf Hmv. rewrite map_eq_iff => Hm; simpl in *.
- destruct (Hup (mf !! i)) as [? Hx']; simpl in *.
- { move: (Hm i). rewrite lookup_op Hi1 Hi2 Some_op_opM (inj_iff Some).
- intros; split; last done. by eapply lookup_valid_Some.
- }
- split; auto using insert_valid. apply (map_eq (<[i := x']> m1)). intros j.
- destruct (decide (i = j)) as [->|].
- - rewrite lookup_insert lookup_op lookup_insert Some_op_opM. by subst.
- - rewrite lookup_insert_ne // !lookup_op lookup_insert_ne //. rewrite Hm lookup_op//.
- Qed.
-
- Lemma singleton_local_update_any m i y x' y' :
- (∀ x, m !! i = Some x → lra_local_update (x, y) (x', y')) →
- lra_local_update (m, {[ i := y ]}) (<[i:=x']>m, {[ i := y' ]}).
- Proof.
- intros. rewrite /singletonM /map_singleton -(insert_insert ∅ i y' y).
- apply lra_local_update_total_valid =>_ _ /singleton_included_l [x0 [Hlk0 _]].
- eapply insert_local_update; [|eapply lookup_insert|]; eauto.
- Qed.
-
- Lemma singleton_local_update m i x y x' y' :
- m !! i = Some x →
- lra_local_update (x, y) (x', y') →
- lra_local_update (m, {[ i := y ]}) (<[i:=x']>m, {[ i := y' ]}).
- Proof.
- intros Hmi ?. apply singleton_local_update_any.
- intros x2. rewrite Hmi=>[=<-]. done.
- Qed.
-
- Lemma delete_local_update m1 m2 i x :
- lra_exclusive x →
- m2 !! i = Some x → lra_local_update (m1, m2) (delete i m1, delete i m2).
- Proof.
- intros Hexcl Hi. apply local_update_unital=> mf Hmv Hm; simpl in *.
- split; auto using delete_valid.
- rewrite Hm. apply (map_eq (delete i (m2 ⋅ mf))) => j; destruct (decide (i = j)) as [<-|].
- - rewrite lookup_op !lookup_delete left_id symmetry_iff.
- apply eq_None_not_Some=> -[y Hi'].
- move: (Hmv i). rewrite Hm lookup_op Hi Hi' -Some_op. intros []%Hexcl.
- - by rewrite lookup_op !lookup_delete_ne // lookup_op.
- Qed.
-
- Lemma delete_singleton_local_update m i x :
- lra_exclusive x →
- lra_local_update (m, {[ i := x ]}) (delete i m, ∅).
- Proof.
- rewrite -(delete_singleton i x).
- intros ?. by eapply delete_local_update, lookup_singleton.
- Qed.
-End fin_fun.
-Global Arguments gmapUR : clear implicits.
-Global Arguments gmapUR _ {_ _}.
-Global Arguments gmapR : clear implicits.
-Global Arguments gmapR _ {_ _}.
-
-
-
(** ** Lifting to ghost theories *)
(** Iris has a more general mechanism, [cmra], which you will learn more about in a week.
Thus, we need a bit of boilerplate code to adapt the definitions we've setup above to work with Iris.
(Essentially, this defines CMRAs from our notion of LRAs. )
*)
-Canonical Structure max_natO := leibnizO max_nat.
-Canonical Structure maxnatCR : cmra := cmra_of_lra max_nat max_nat_lra_mixin.
-
-Canonical Structure authO A := leibnizO (auth A).
-Canonical Structure authCR (A : ulra) : cmra := cmra_of_lra (auth A) (auth_lra_mixin (A := A)).
-
-Canonical Structure exclO A := leibnizO (excl A).
-Canonical Structure exclCR (A : Type) : cmra := cmra_of_lra (excl A) (excl_lra_mixin (A := A)).
-
-Canonical Structure agreeO A `{Countable A} := leibnizO (agree A).
-Canonical Structure agreeCR (A : Type) `{Countable A} : cmra := cmra_of_lra (agree A) (agree_lra_mixin (A := A)).
-
-Canonical Structure csumO A B := leibnizO (csum A B).
-Canonical Structure csumCR (A B : lra) : cmra := cmra_of_lra (csum A B) (csum_lra_mixin (A := A) (B := B)).
-
-(* Technical note: slightly hacky workaround. There's already a canonical structure declaration for the prod OFE,
- so defining it with Leibniz equality via [leibnizO] will make the [Cmra] smart constructor below fail,
- as it will infer the wrong instance.
- The trick is to just define an alias [prod'] that will not be unfolded by canonical structure inference.
- *)
-Definition prod' A B := prod A B.
-Canonical Structure prodO A B := leibnizO (prod' A B).
-Canonical Structure prodCR (A B : lra) : cmra := cmra_of_lra (prod' A B) (prod_lra_mixin (A := A) (B := B)).
-
-
-(** The following lemmas are useful for deriving ghost theory laws:
- - [own_alloc]
- - [own_op]
- - [own_core_persistent]
-
- - [own_valid]
- - [own_valid_2]
- - [own_valid_3]
-
- - [own_lra_update]
- (This lemma is phrased for our notion of [lra_update]s to directly lift the lemmas we derived above)
-
- - [own_mono]
- - [own_unit]
- *)
-
-(** Defining the ghost theory for MonoNat *)
-
-(** We need this to register the ghost state we setup with Iris. *)
-Class mono_natG Σ :=
- MonoNatG { mono_natG_inG : inG Σ (authCR max_natUR); }.
-#[export] Existing Instance mono_natG_inG.
-Definition mono_natΣ : gFunctors := #[ GFunctor (authCR max_natUR) ].
-Global Instance subG_mono_natΣ Σ : subG mono_natΣ Σ → mono_natG Σ.
-Proof. solve_inG. Qed.
-
-Section mono_nat.
- (** We now assume that the mono_nat ghost state we have just defined is registered with Iris. *)
- Context `{mono_natG Σ}.
-
- Definition mono_nat_own_auth γ n := (own γ (auth_auth (MaxNat n)) ∗ own γ (auth_frag (MaxNat n)))%I.
- Definition mono_nat_own_frag γ n := own γ (auth_frag (MaxNat n)).
-
- Instance mono_nat_own_frag_pers γ n : Persistent (mono_nat_own_frag γ n).
- Proof.
- apply own_core_persistent.
- unfold CoreId. rewrite auth_frag_pcore max_nat_pcore. done.
- Qed.
-
- Lemma mono_make_bound γ n :
- mono_nat_own_auth γ n -∗ mono_nat_own_frag γ n.
- Proof.
- iIntros "[_ $]".
- Qed.
-
- Lemma mono_use_bound γ n m :
- mono_nat_own_auth γ n -∗ mono_nat_own_frag γ m -∗ ⌜n ≥ m⌝.
- Proof.
- iIntros "[Hauth Hfrag1] Hfrag2".
- iDestruct (own_valid_2 with "Hauth Hfrag2") as %Hv.
- iPureIntro. move: Hv.
- rewrite auth_auth_frag_valid.
- rewrite max_nat_included. simpl; lia.
- Qed.
-
- Lemma mono_increase_val γ n :
- mono_nat_own_auth γ n -∗ |==> mono_nat_own_auth γ (S n).
- Proof.
- unfold mono_nat_own_auth. rewrite -!own_op.
- iApply own_lra_update.
- eapply auth_update. apply local_upd_nat_max.
- lia.
- Qed.
-
- Lemma mono_new n :
- ⊢ |==> ∃ γ, mono_nat_own_auth γ n.
- Proof.
- unfold mono_nat_own_auth. setoid_rewrite <-own_op.
- iApply own_alloc. rewrite auth_auth_frag_valid. split.
- - apply max_nat_included. lia.
- - apply max_nat_valid.
- Qed.
-End mono_nat.
-
-(** ** Exercise: Oneshot *)
-Class oneshotG Σ (A : Type) `{Countable A} :=
- OneShotG { oneshotG_inG : inG Σ (csumCR (exclR unit) (agreeR A)); }.
-#[export] Existing Instance oneshotG_inG.
-Definition oneshotΣ A `{Countable A} : gFunctors := #[ GFunctor (csumCR (exclR unit) (agreeR A)) ].
-Global Instance subG_oneshotΣ Σ A `{Countable A} : subG (oneshotΣ A) Σ → oneshotG Σ A.
-Proof. solve_inG. Qed.
-Section oneshot.
- Context {A : Type}.
- Context `{oneshotG Σ A}.
-
- Definition os_pending γ := own γ (Cinl (Excl ())).
- Definition os_shot γ (a : A) := own γ (Cinr (to_agree a)).
-
- Lemma os_pending_alloc :
- ⊢ |==> ∃ γ, os_pending γ.
- Proof.
- (* FIXME *)
- Admitted.
-
- Lemma os_pending_shoot γ a :
- os_pending γ -∗ |==> os_shot γ a.
- Proof.
- (* FIXME *)
- Admitted.
-
- Global Instance os_shot_persistent γ a : Persistent (os_shot γ a).
- Proof.
- (* FIXME *)
- Admitted.
-
- Lemma os_pending_shot_False γ a :
- os_pending γ -∗ os_shot γ a -∗ False.
- Proof.
- (* FIXME *)
- Admitted.
-
- Lemma os_pending_pending_False γ :
- os_pending γ -∗ os_pending γ -∗ False.
- Proof.
- (* FIXME *)
- Admitted.
-
- Lemma os_shot_agree γ a b :
- os_shot γ a -∗ os_shot γ b -∗ ⌜a = b⌝.
- Proof.
- (* FIXME *)
- Admitted.
-
- Global Instance os_shot_timeless γ a : Timeless (os_shot γ a).
- Proof. apply _. Qed.
- Global Instance os_pending_timeless γ : Timeless (os_pending γ).
- Proof. apply _. Qed.
-End oneshot.
-
-(** ** Exercise: Synchronized Ghost State *)
-Class halvesG Σ (A : Type) :=
- HalvesG { halvesG_inG : inG Σ (authCR (optionUR (exclR A))); }.
-#[export] Existing Instance halvesG_inG.
-Definition halvesΣ A : gFunctors := #[ GFunctor (authCR (optionUR (exclR A))) ].
-Global Instance subG_halvesΣ Σ A : subG (halvesΣ A) Σ → halvesG Σ A.
-Proof. solve_inG. Qed.
-Section halves.
- Context {A : Type}.
- Context `{halvesG Σ A}.
-
- Definition gleft γ (a : A) := own γ (auth_auth (Some (Excl a))).
- Definition gright γ (a : A) := own γ (auth_frag (Some (Excl a))).
-
- Lemma ghalves_alloc a :
- ⊢ |==> ∃ γ, gleft γ a ∗ gright γ a.
- Proof.
- (* FIXME *)
- Admitted.
-
- Lemma ghalves_agree γ a b :
- gleft γ a -∗ gright γ b -∗ ⌜a = b⌝.
- Proof.
- (* FIXME *)
- Admitted.
-
- Lemma ghalves_update γ a b c :
- gleft γ a -∗ gright γ b -∗ |==> gleft γ c ∗ gright γ c.
- Proof.
- (* FIXME *)
- Admitted.
-
- Global Instance gleft_timeless γ a : Timeless (gleft γ a).
- Proof. apply _. Qed.
- Global Instance gright_timeless γ a : Timeless (gright γ a).
- Proof. apply _. Qed.
-End halves.
-
-(** ** Exercise: gvar *)
-Class gvarG Σ (A : Type) `{Countable A} := GvarG { gvarG_inG : inG Σ (prodCR fracR (agreeR A)); }.
-#[export] Existing Instance gvarG_inG.
-Definition gvarΣ A `{Countable A} : gFunctors := #[ GFunctor (prodCR fracR (agreeR A)) ].
-Global Instance subG_gvarΣ Σ A `{Countable A} : subG (gvarΣ A) Σ → gvarG Σ A.
-Proof. solve_inG. Qed.
-Section gvar.
- Context {A : Type} `{Countable A}.
- Context `{gvarG Σ A}.
-
- Definition gvar γ (q : frac) (a : A) := own γ ((q, to_agree a) : prodCR _ _).
-
- Lemma gvar_alloc a :
- ⊢ |==> ∃ γ, gvar γ 1 a.
- Proof.
- (* FIXME *)
- Admitted.
-
- Lemma gvar_agree γ q1 q2 a b :
- gvar γ q1 a -∗ gvar γ q2 b -∗ ⌜(q1 + q2 ≤ 1)%Qp⌝ ∗ ⌜a = b⌝.
- Proof.
- (* FIXME *)
- Admitted.
-
-
- Lemma gvar_fractional γ q1 q2 a :
- gvar γ q1 a ∗ gvar γ q2 a ⊣⊢ gvar γ (q1 + q2)%Qp a.
- Proof.
- (* FIXME *)
- Admitted.
-
-
- (* Note: The following instance can make the IPM aware of the fractionality of the [gvar] assertion,
- meaning that it can automatically split and merge (when framing) in some cases.
- See the proof of [gvar_split_halves] as an example.
- *)
- Global Instance gvar_AsFractional γ q b :
- AsFractional (gvar γ q b) (λ q', gvar γ q' b) q.
- Proof.
- split; first done.
- intros ??. by rewrite gvar_fractional.
- Qed.
- Lemma gvar_split_halves γ a :
- gvar γ 1 a -∗ gvar γ (1/2) a ∗ gvar γ (1/2) a.
- Proof.
- iIntros "[H1 H2]". iFrame.
- Qed.
-
- Lemma gvar_update γ a b :
- gvar γ 1 a -∗ |==> gvar γ 1 b.
- Proof.
- (* FIXME *)
- Admitted.
-
- Global Instance gvar_timeless γ q a : Timeless (gvar γ q a).
- Proof. apply _. Qed.
-End gvar.
-
-(** Agreement maps *)
-Definition agmapCR (A B : Type) `{Countable A} `{Countable B} := (authCR (gmapUR A (agreeR B))).
-Class agmapG Σ (A B : Type) `{Countable A} `{Countable B} :=
- AgMapG { agmapG_inG : inG Σ (agmapCR A B); }.
-#[export] Existing Instance agmapG_inG.
-Definition agmapΣ A B `{Countable A} `{Countable B} : gFunctors := #[ GFunctor (agmapCR A B) ].
-Global Instance subG_agmapΣ Σ A B `{Countable A} `{Countable B} : subG (agmapΣ A B) Σ → agmapG Σ A B.
-Proof. solve_inG. Qed.
-Section agmap.
- Context {A B : Type} `{Countable A} `{Countable B}.
- Context `{agmapG Σ A B}.
-
- Definition to_agmap (m : gmap A B) : gmapUR A (agreeR B) := fmap (λ a, to_agree a) m.
-
- Definition agmap_auth γ (m : gmap A B) := own γ (auth_auth (to_agmap m)).
-
- Definition agmap_elem γ (a : A) (b : B) := own γ (auth_frag ({[ a := to_agree b ]})).
-
- Lemma agmap_alloc_empty :
- ⊢ |==> ∃ γ, agmap_auth γ ∅.
- Proof.
- (* FIXME *)
- Admitted.
-
- Lemma agmap_insert γ m a b :
- m !! a = None →
- agmap_auth γ m -∗ |==> agmap_auth γ (<[a := b]> m) ∗ agmap_elem γ a b.
- Proof.
- (* FIXME *)
- Admitted.
-
-
- Lemma agmap_lookup γ m a b :
- agmap_auth γ m -∗ agmap_elem γ a b -∗ ⌜m !! a = Some b⌝.
- Proof.
- (* FIXME *)
- Admitted.
-
-
- Global Instance agmap_elem_persistent γ a b : Persistent (agmap_elem γ a b).
- Proof.
- (* FIXME *)
- Admitted.
-
-
- Global Instance agmap_auth_timeless γ m : Timeless (agmap_auth γ m).
- Proof. apply _. Qed.
- Global Instance agmap_elem_timeless γ a b : Timeless (agmap_elem γ a b).
- Proof. apply _. Qed.
-End agmap.
-
-(** Updateable maps *)
-Definition exmapCR (A B : Type) `{Countable A} := (authCR (gmapUR A (exclR B))).
-Class exmapG Σ (A B : Type) `{Countable A} :=
- ExMapG { exmapG_inG : inG Σ (exmapCR A B); }.
-#[export] Existing Instance exmapG_inG.
-Definition exmapΣ A B `{Countable A} : gFunctors := #[ GFunctor (exmapCR A B) ].
-Global Instance subG_exmapΣ Σ A B `{Countable A} : subG (exmapΣ A B) Σ → exmapG Σ A B.
-Proof. solve_inG. Qed.
-Section exmap.
- Context {A B : Type} `{Countable A}.
- Context `{exmapG Σ A B}.
-
- Definition to_exmap (m : gmap A B) : gmapUR A (exclR B) := fmap (λ a, Excl (A := B) a) m.
-
- Definition exmap_auth γ (m : gmap A B) := own γ (auth_auth (to_exmap m)).
- Definition exmap_elem γ (a : A) (b : B) := own γ (auth_frag ({[ a := Excl b ]})).
-
- Lemma exmap_alloc_empty :
- ⊢ |==> ∃ γ, exmap_auth γ ∅.
- Proof.
- (* FIXME *)
- Admitted.
-
- Lemma exmap_insert γ m a b :
- m !! a = None →
- exmap_auth γ m -∗ |==> exmap_auth γ (<[a := b]> m) ∗ exmap_elem γ a b.
- Proof.
- (* FIXME *)
- Admitted.
-
-
- Lemma exmap_lookup γ m a b :
- exmap_auth γ m -∗ exmap_elem γ a b -∗ ⌜m !! a = Some b⌝.
- Proof.
- (* FIXME *)
- Admitted.
-
- Lemma exmap_update γ m a b c :
- exmap_auth γ m -∗ exmap_elem γ a b -∗ |==> exmap_auth γ (<[a := c]> m) ∗ exmap_elem γ a c.
- Proof.
- (* FIXME *)
- Admitted.
-
- Lemma exmap_delete γ m a b :
- exmap_auth γ m -∗ exmap_elem γ a b -∗ |==> exmap_auth γ (delete a m).
- Proof.
- (* FIXME *)
- Admitted.
-
- Global Instance exmap_auth_timeless γ m : Timeless (exmap_auth γ m).
- Proof. apply _. Qed.
- Global Instance exmap_elem_timeless γ a b : Timeless (exmap_elem γ a b).
- Proof. apply _. Qed.
-End exmap.
+ Canonical Structure max_natO := leibnizO max_nat.
+ Canonical Structure maxnatCR : cmra := cmra_of_lra max_nat max_nat_lra_mixin.
+
+ Canonical Structure authO A := leibnizO (auth A).
+ Canonical Structure authCR (A : ulra) : cmra := cmra_of_lra (auth A) (auth_lra_mixin (A := A)).
+
+ Canonical Structure exclO A := leibnizO (excl A).
+ Canonical Structure exclCR (A : Type) : cmra := cmra_of_lra (excl A) (excl_lra_mixin (A := A)).
+
+ Canonical Structure agreeO A `{Countable A} := leibnizO (agree A).
+ Canonical Structure agreeCR (A : Type) `{Countable A} : cmra := cmra_of_lra (agree A) (agree_lra_mixin (A := A)).
+
+ Canonical Structure csumO A B := leibnizO (csum A B).
+ Canonical Structure csumCR (A B : lra) : cmra := cmra_of_lra (csum A B) (csum_lra_mixin (A := A) (B := B)).
+
+ (* Technical note: slightly hacky workaround. There's already a canonical structure declaration for the prod OFE,
+ so defining it with Leibniz equality via [leibnizO] will make the [Cmra] smart constructor below fail,
+ as it will infer the wrong instance.
+ The trick is to just define an alias [prod'] that will not be unfolded by canonical structure inference.
+ *)
+ Definition prod' A B := prod A B.
+ Canonical Structure prodO A B := leibnizO (prod' A B).
+ Canonical Structure prodCR (A B : lra) : cmra := cmra_of_lra (prod' A B) (prod_lra_mixin (A := A) (B := B)).
+
+
+ (** The following lemmas are useful for deriving ghost theory laws:
+ - [own_alloc]
+ - [own_op]
+ - [own_core_persistent]
+
+ - [own_valid]
+ - [own_valid_2]
+ - [own_valid_3]
+
+ - [own_lra_update]
+ (This lemma is phrased for our notion of [lra_update]s to directly lift the lemmas we derived above)
+
+ - [own_mono]
+ - [own_unit]
+ *)
+
+ (** Defining the ghost theory for MonoNat *)
+
+ (** We need this to register the ghost state we setup with Iris. *)
+ Class mono_natG Σ :=
+ MonoNatG { mono_natG_inG : inG Σ (authCR max_natUR); }.
+ #[export] Existing Instance mono_natG_inG.
+ Definition mono_natΣ : gFunctors := #[ GFunctor (authCR max_natUR) ].
+ Global Instance subG_mono_natΣ Σ : subG mono_natΣ Σ → mono_natG Σ.
+ Proof. solve_inG. Qed.
+
+ Section mono_nat.
+ (** We now assume that the mono_nat ghost state we have just defined is registered with Iris. *)
+ Context `{mono_natG Σ}.
+
+ Definition mono_nat_own_auth γ n := (own γ (auth_auth (MaxNat n)) ∗ own γ (auth_frag (MaxNat n)))%I.
+ Definition mono_nat_own_frag γ n := own γ (auth_frag (MaxNat n)).
+
+ Instance mono_nat_own_frag_pers γ n : Persistent (mono_nat_own_frag γ n).
+ Proof.
+ apply own_core_persistent.
+ unfold CoreId. rewrite auth_frag_pcore max_nat_pcore. done.
+ Qed.
+
+ Lemma mono_make_bound γ n :
+ mono_nat_own_auth γ n -∗ mono_nat_own_auth γ n ∗ mono_nat_own_frag γ n.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+ Lemma mono_use_bound γ n m :
+ mono_nat_own_auth γ n -∗ mono_nat_own_frag γ m -∗ ⌜n ≥ m⌝.
+ Proof.
+ iIntros "[Hauth Hfrag1] Hfrag2".
+ iDestruct (own_valid_2 with "Hauth Hfrag2") as %Hv.
+ iPureIntro. move: Hv.
+ rewrite auth_auth_frag_valid.
+ rewrite max_nat_included. simpl; lia.
+ Qed.
+
+ Lemma mono_increase_val γ n :
+ mono_nat_own_auth γ n -∗ |==> mono_nat_own_auth γ (S n).
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+ Lemma mono_new n :
+ ⊢ |==> ∃ γ, mono_nat_own_auth γ n.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+ End mono_nat.
\ No newline at end of file
diff --git a/theories/program_logics/resource_algebras_2.v b/theories/program_logics/resource_algebras_2.v
new file mode 100644
index 0000000000000000000000000000000000000000..5f3d3b3bd3232746d60fb8cdc03043f8c41aee27
--- /dev/null
+++ b/theories/program_logics/resource_algebras_2.v
@@ -0,0 +1,779 @@
+From iris.proofmode Require Import tactics.
+From iris.heap_lang Require Import lang notation.
+From iris.bi Require Import fractional.
+From semantics.pl.heap_lang Require Import primitive_laws proofmode.
+From Coq.Logic Require FunctionalExtensionality.
+From iris.base_logic Require Import own.
+From semantics.pl Require Import ra_lib resource_algebras_1.
+From iris.prelude Require Import options.
+
+(** ** Lifting to ghost theories *)
+
+(** Iris has a more general mechanism, [cmra], which you will learn more about in a week.
+ Thus, we need a bit of boilerplate code to adapt the definitions we've setup above to work with Iris.
+ (Essentially, this defines CMRAs from our notion of LRAs. )
+ *)
+Canonical Structure max_natO := leibnizO max_nat.
+Canonical Structure maxnatCR : cmra := cmra_of_lra max_nat max_nat_lra_mixin.
+
+Canonical Structure authO A := leibnizO (auth A).
+Canonical Structure authCR (A : ulra) : cmra := cmra_of_lra (auth A) (auth_lra_mixin (A := A)).
+
+Canonical Structure exclO A := leibnizO (excl A).
+Canonical Structure exclCR (A : Type) : cmra := cmra_of_lra (excl A) (excl_lra_mixin (A := A)).
+
+Canonical Structure agreeO A `{Countable A} := leibnizO (agree A).
+Canonical Structure agreeCR (A : Type) `{Countable A} : cmra := cmra_of_lra (agree A) (agree_lra_mixin (A := A)).
+
+Canonical Structure csumO A B := leibnizO (csum A B).
+Canonical Structure csumCR (A B : lra) : cmra := cmra_of_lra (csum A B) (csum_lra_mixin (A := A) (B := B)).
+
+(* Technical note: slightly hacky workaround. There's already a canonical structure declaration for the prod OFE,
+ so defining it with Leibniz equality via [leibnizO] will make the [Cmra] smart constructor below fail,
+ as it will infer the wrong instance.
+ The trick is to just define an alias [prod'] that will not be unfolded by canonical structure inference.
+ *)
+Definition prod' A B := prod A B.
+Canonical Structure prodO A B := leibnizO (prod' A B).
+Canonical Structure prodCR (A B : lra) : cmra := cmra_of_lra (prod' A B) (prod_lra_mixin (A := A) (B := B)).
+
+
+(** The following lemmas are useful for deriving ghost theory laws:
+ - [own_alloc]
+ - [own_op]
+ - [own_core_persistent]
+
+ - [own_valid]
+ - [own_valid_2]
+ - [own_valid_3]
+
+ - [own_lra_update]
+ (This lemma is phrased for our notion of [lra_update]s to directly lift the lemmas we derived above)
+
+ - [own_mono]
+ - [own_unit]
+ *)
+
+(** Defining the ghost theory for MonoNat *)
+
+(** We need this to register the ghost state we setup with Iris. *)
+Class mono_natG Σ :=
+ MonoNatG { mono_natG_inG : inG Σ (authCR max_natUR); }.
+#[export] Existing Instance mono_natG_inG.
+Definition mono_natΣ : gFunctors := #[ GFunctor (authCR max_natUR) ].
+Global Instance subG_mono_natΣ Σ : subG mono_natΣ Σ → mono_natG Σ.
+Proof. solve_inG. Qed.
+
+Section mono_nat.
+ (** We now assume that the mono_nat ghost state we have just defined is registered with Iris. *)
+ Context `{mono_natG Σ}.
+
+ Definition mono_nat_own_auth γ n := (own γ (auth_auth (MaxNat n)) ∗ own γ (auth_frag (MaxNat n)))%I.
+ Definition mono_nat_own_frag γ n := own γ (auth_frag (MaxNat n)).
+
+ Instance mono_nat_own_frag_pers γ n : Persistent (mono_nat_own_frag γ n).
+ Proof.
+ apply own_core_persistent.
+ unfold CoreId. rewrite auth_frag_pcore max_nat_pcore. done.
+ Qed.
+
+ Lemma mono_make_bound γ n :
+ mono_nat_own_auth γ n -∗ mono_nat_own_frag γ n.
+ Proof.
+ iIntros "[_ $]".
+ Qed.
+
+ Lemma mono_use_bound γ n m :
+ mono_nat_own_auth γ n -∗ mono_nat_own_frag γ m -∗ ⌜n ≥ m⌝.
+ Proof.
+ iIntros "[Hauth Hfrag1] Hfrag2".
+ iDestruct (own_valid_2 with "Hauth Hfrag2") as %Hv.
+ iPureIntro. move: Hv.
+ rewrite auth_auth_frag_valid.
+ rewrite max_nat_included. simpl; lia.
+ Qed.
+
+ Lemma mono_increase_val γ n :
+ mono_nat_own_auth γ n -∗ |==> mono_nat_own_auth γ (S n).
+ Proof.
+ unfold mono_nat_own_auth. rewrite -!own_op.
+ iApply own_lra_update.
+ eapply auth_update. apply local_upd_nat_max.
+ lia.
+ Qed.
+
+ Lemma mono_new n :
+ ⊢ |==> ∃ γ, mono_nat_own_auth γ n.
+ Proof.
+ unfold mono_nat_own_auth. setoid_rewrite <-own_op.
+ iApply own_alloc. rewrite auth_auth_frag_valid. split.
+ - apply max_nat_included. lia.
+ - apply max_nat_valid.
+ Qed.
+End mono_nat.
+
+(** ** Exercise: Oneshot *)
+Class oneshotG Σ (A : Type) `{Countable A} :=
+ OneShotG { oneshotG_inG : inG Σ (csumCR (exclR unit) (agreeR A)); }.
+#[export] Existing Instance oneshotG_inG.
+Definition oneshotΣ A `{Countable A} : gFunctors := #[ GFunctor (csumCR (exclR unit) (agreeR A)) ].
+Global Instance subG_oneshotΣ Σ A `{Countable A} : subG (oneshotΣ A) Σ → oneshotG Σ A.
+Proof. solve_inG. Qed.
+Section oneshot.
+ Context {A : Type}.
+ Context `{oneshotG Σ A}.
+
+ Definition os_pending γ := own γ (Cinl (Excl ())).
+ Definition os_shot γ (a : A) := own γ (Cinr (to_agree a)).
+
+ Lemma os_pending_alloc :
+ ⊢ |==> ∃ γ, os_pending γ.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+ Lemma os_pending_shoot γ a :
+ os_pending γ -∗ |==> os_shot γ a.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+ Global Instance os_shot_persistent γ a : Persistent (os_shot γ a).
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+ Lemma os_pending_shot_False γ a :
+ os_pending γ -∗ os_shot γ a -∗ False.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+ Lemma os_pending_pending_False γ :
+ os_pending γ -∗ os_pending γ -∗ False.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+ Lemma os_shot_agree γ a b :
+ os_shot γ a -∗ os_shot γ b -∗ ⌜a = b⌝.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+ Global Instance os_shot_timeless γ a : Timeless (os_shot γ a).
+ Proof. apply _. Qed.
+ Global Instance os_pending_timeless γ : Timeless (os_pending γ).
+ Proof. apply _. Qed.
+End oneshot.
+
+(** ** Exercise: Synchronized Ghost State *)
+Class halvesG Σ (A : Type) :=
+ HalvesG { halvesG_inG : inG Σ (authCR (optionUR (exclR A))); }.
+#[export] Existing Instance halvesG_inG.
+Definition halvesΣ A : gFunctors := #[ GFunctor (authCR (optionUR (exclR A))) ].
+Global Instance subG_halvesΣ Σ A : subG (halvesΣ A) Σ → halvesG Σ A.
+Proof. solve_inG. Qed.
+Section halves.
+ Context {A : Type}.
+ Context `{halvesG Σ A}.
+
+ Definition gleft γ (a : A) := own γ (auth_auth (Some (Excl a))).
+ Definition gright γ (a : A) := own γ (auth_frag (Some (Excl a))).
+
+ Lemma ghalves_alloc a :
+ ⊢ |==> ∃ γ, gleft γ a ∗ gright γ a.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+ Lemma ghalves_agree γ a b :
+ gleft γ a -∗ gright γ b -∗ ⌜a = b⌝.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+ Lemma ghalves_update γ a b c :
+ gleft γ a -∗ gright γ b -∗ |==> gleft γ c ∗ gright γ c.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+ Global Instance gleft_timeless γ a : Timeless (gleft γ a).
+ Proof. apply _. Qed.
+ Global Instance gright_timeless γ a : Timeless (gright γ a).
+ Proof. apply _. Qed.
+End halves.
+
+(** ** Exercise: gvar *)
+Class gvarG Σ (A : Type) `{Countable A} := GvarG { gvarG_inG : inG Σ (prodCR fracR (agreeR A)); }.
+#[export] Existing Instance gvarG_inG.
+Definition gvarΣ A `{Countable A} : gFunctors := #[ GFunctor (prodCR fracR (agreeR A)) ].
+Global Instance subG_gvarΣ Σ A `{Countable A} : subG (gvarΣ A) Σ → gvarG Σ A.
+Proof. solve_inG. Qed.
+Section gvar.
+ Context {A : Type} `{Countable A}.
+ Context `{gvarG Σ A}.
+
+ Definition gvar γ (q : frac) (a : A) := own γ ((q, to_agree a) : prodCR _ _).
+
+ Lemma gvar_alloc a :
+ ⊢ |==> ∃ γ, gvar γ 1 a.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+ Lemma gvar_agree γ q1 q2 a b :
+ gvar γ q1 a -∗ gvar γ q2 b -∗ ⌜(q1 + q2 ≤ 1)%Qp⌝ ∗ ⌜a = b⌝.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+
+ Lemma gvar_fractional γ q1 q2 a :
+ gvar γ q1 a ∗ gvar γ q2 a ⊣⊢ gvar γ (q1 + q2)%Qp a.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+
+ (* Note: The following instance can make the IPM aware of the fractionality of the [gvar] assertion,
+ meaning that it can automatically split and merge (when framing) in some cases.
+ See the proof of [gvar_split_halves] as an example.
+ *)
+ Global Instance gvar_AsFractional γ q b :
+ AsFractional (gvar γ q b) (λ q', gvar γ q' b) q.
+ Proof.
+ split; first done.
+ intros ??. by rewrite gvar_fractional.
+ Qed.
+ Lemma gvar_split_halves γ a :
+ gvar γ 1 a -∗ gvar γ (1/2) a ∗ gvar γ (1/2) a.
+ Proof.
+ iIntros "[H1 H2]". iFrame.
+ Qed.
+
+ Lemma gvar_update γ a b :
+ gvar γ 1 a -∗ |==> gvar γ 1 b.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+ Global Instance gvar_timeless γ q a : Timeless (gvar γ q a).
+ Proof. apply _. Qed.
+End gvar.
+
+(** Finite functions *)
+Section fin_fun.
+ Context `{Countable K} {A : lra}.
+ Implicit Types m : gmap K A.
+
+ (** The proofs in this section are quite a mouthful, so we recommend to skip over them.
+ They are just here for completeness.
+ (The lemma statements are more interesting, though: especially the local updates, which you will need to do some of the exercises below!)
+ *)
+
+ Local Instance gmap_unit_instance : Unit (gmap K A) := (∅ : gmap K A).
+ Local Instance gmap_op_instance : Op (gmap K A) := merge op.
+ Local Instance gmap_pcore_instance : PCore (gmap K A) := λ m, Some (omap pcore m).
+ Local Instance gmap_valid_instance : Valid (gmap K A) := λ m, ∀ i, ✓ (m !! i).
+
+ Lemma gmap_op m1 m2 : m1 ⋅ m2 = merge op m1 m2.
+ Proof. done. Qed.
+ Lemma lookup_op m1 m2 i : (m1 ⋅ m2) !! i = m1 !! i ⋅ m2 !! i.
+ Proof. rewrite lookup_merge. by destruct (m1 !! i), (m2 !! i). Qed.
+ Lemma lookup_core m i : core m !! i = core (m !! i).
+ Proof. by apply lookup_omap. Qed.
+ Lemma gmap_pcore m : pcore m = Some (omap pcore m).
+ Proof. done. Qed.
+
+ Lemma lookup_included (m1 m2 : gmap K A) : m1 ≼ m2 ↔ ∀ i, m1 !! i ≼ m2 !! i.
+ Proof.
+ split; [by intros [m Hm] i; exists (m !! i); rewrite -lookup_op Hm|].
+ revert m2. induction m1 as [|i x m Hi IH] using map_ind=> m2 Hm.
+ { exists m2. by rewrite left_id. }
+ destruct (IH (delete i m2)) as [m2' Hm2'].
+ { intros j. move: (Hm j); destruct (decide (i = j)) as [->|].
+ - intros _. rewrite Hi. apply: ulra_unit_least.
+ - rewrite lookup_insert_ne // lookup_delete_ne //. }
+ destruct (Hm i) as [my Hi']; simplify_map_eq.
+ exists (partial_alter (λ _, my) i m2'). apply map_eq => j.
+ destruct (decide (i = j)) as [->|].
+ - by rewrite Hi' lookup_op lookup_insert lookup_partial_alter.
+ - move : Hm2'. rewrite map_eq_iff. intros Hm2'. move : (Hm2' j).
+ by rewrite !lookup_op lookup_delete_ne //
+ lookup_insert_ne // lookup_partial_alter_ne.
+ Qed.
+
+ Lemma gmap_lra_mixin : LRAMixin (gmap K A).
+ Proof.
+ apply lra_total_mixin.
+ - done.
+ - intros m1 m2 m3. apply map_eq. intros i. by rewrite !lookup_op assoc.
+ - intros m1 m2. apply map_eq. intros i. by rewrite !lookup_op lra_comm.
+ - intros m. apply map_eq. intros i. by rewrite lookup_op lookup_core lra_core_l.
+ - intros m. apply map_eq. intros i. by rewrite !lookup_core lra_core_idemp.
+ - intros m1 m2; rewrite !lookup_included=> Hm i.
+ rewrite !lookup_core. by apply lra_core_mono.
+ - intros m1 m2 Hm i. apply lra_valid_op_l with (m2 !! i).
+ by rewrite -lookup_op.
+ Qed.
+ Canonical Structure gmapR := Lra (gmap K A) gmap_lra_mixin.
+
+ Lemma gmap_ulra_mixin : ULRAMixin (gmap K A).
+ Proof.
+ split.
+ - intros m. apply map_eq. intros i; by rewrite /= lookup_op lookup_empty (left_id_L None _).
+ - by intros i; rewrite lookup_empty.
+ - rewrite /pcore /gmap_pcore_instance. f_equiv. apply map_eq. intros i. by rewrite lookup_omap lookup_empty.
+ Qed.
+ Canonical Structure gmapUR := Ulra (gmap K A) gmap_lra_mixin gmap_ulra_mixin.
+
+ Lemma lookup_valid_Some m i x : ✓ m → m !! i = Some x → ✓ x.
+ Proof. move=> Hm Hi. move:(Hm i). by rewrite Hi. Qed.
+
+ Lemma insert_valid m i x : ✓ x → ✓ m → ✓ <[i:=x]>m.
+ Proof. by intros ?? j; destruct (decide (i = j)); simplify_map_eq. Qed.
+ Lemma singleton_valid i x : ✓ ({[ i := x ]} : gmap K A) ↔ ✓ x.
+ Proof.
+ split.
+ - move=>/(_ i); by simplify_map_eq.
+ - intros. apply insert_valid; first done. apply: ulra_unit_valid.
+ Qed.
+ Lemma delete_valid m i : ✓ m → ✓ (delete i m).
+ Proof. intros Hm j; destruct (decide (i = j)); by simplify_map_eq. Qed.
+
+ Lemma insert_singleton_op m i x : m !! i = None → <[i:=x]> m = {[ i := x ]} ⋅ m.
+ Proof.
+ intros Hi; apply map_eq=> j; destruct (decide (i = j)) as [->|].
+ - by rewrite lookup_op lookup_insert lookup_singleton Hi right_id_L.
+ - by rewrite lookup_op lookup_insert_ne // lookup_singleton_ne // left_id_L.
+ Qed.
+
+ Lemma singleton_core (i : K) (x : A) cx :
+ pcore x = Some cx → core {[ i := x ]} =@{gmap K A} {[ i := cx ]}.
+ Proof. apply omap_singleton_Some. Qed.
+ Lemma singleton_core_total `{!LraTotal A} (i : K) (x : A) :
+ core {[ i := x ]} =@{gmap K A} {[ i := core x ]}.
+ Proof. apply singleton_core. apply lra_pcore_core. Qed.
+ Lemma singleton_op (i : K) (x y : A) :
+ {[ i := x ]} ⋅ {[ i := y ]} =@{gmap K A} {[ i := x ⋅ y ]}.
+ Proof. by apply (merge_singleton _ _ _ x y). Qed.
+
+ Lemma singleton_included_l m i x :
+ {[ i := x ]} ≼ m ↔ ∃ y, m !! i = Some y ∧ Some x ≼ Some y.
+ Proof.
+ split.
+ - move=> [m' ]. rewrite map_eq_iff. intros Heq. specialize (Heq i).
+ rewrite lookup_op lookup_singleton in Heq.
+ exists (x ⋅? m' !! i). rewrite -Some_op_opM.
+ split; first done. apply lra_included_l.
+ - intros (y&Hi&[mz Hy]). exists (partial_alter (λ _, mz) i m).
+ apply map_eq. intros j; destruct (decide (i = j)) as [->|].
+ + by rewrite lookup_op lookup_singleton lookup_partial_alter Hi.
+ + by rewrite lookup_op lookup_singleton_ne// lookup_partial_alter_ne// left_id.
+ Qed.
+ Lemma singleton_included_exclusive_l m i x :
+ lra_exclusive x → ✓ m →
+ {[ i := x ]} ≼ m ↔ m !! i = Some x.
+ Proof.
+ intros ? Hm. rewrite singleton_included_l. split.
+ - intros (y&?&->%(Some_included_lra_exclusive _)); eauto using lookup_valid_Some.
+ - intros ->. exists x. split; first done. reflexivity.
+ Qed.
+ Lemma singleton_included i x y :
+ {[ i := x ]} ≼ ({[ i := y ]} : gmap K A) ↔ x = y ∨ x ≼ y.
+ Proof.
+ rewrite singleton_included_l. split.
+ - intros (y'&Hi&Ha). rewrite lookup_insert in Hi.
+ apply Some_included in Ha as (? & [= <-] & ?). naive_solver.
+ - intros ?. exists y. rewrite lookup_insert Some_included; eauto.
+ Qed.
+ Lemma singleton_mono i x y :
+ x ≼ y → {[ i := x ]} ≼ ({[ i := y ]} : gmap K A).
+ Proof. intros Hincl. apply singleton_included. right. done. Qed.
+
+ Lemma insert_op m1 m2 i x y :
+ <[i:=x ⋅ y]>(m1 ⋅ m2) = <[i:=x]>m1 ⋅ <[i:=y]>m2.
+ Proof. by rewrite (insert_merge (⋅) m1 m2 i (x ⋅ y) x y). Qed.
+
+ (** Updates *)
+ Lemma insert_updateP (P : A → Prop) (Q : gmap K A → Prop) m i x :
+ lra_updateP x P →
+ (∀ y, P y → Q (<[i:=y]>m)) →
+ lra_updateP (<[i:=x]>m) Q.
+ Proof.
+ intros Hx%option_updateP' HP; apply lra_total_updateP=> mf Hm.
+ destruct (Hx (Some (mf !! i))) as ([y|]&?&?); try done.
+ { by generalize (Hm i); rewrite lookup_op; simplify_map_eq. }
+ exists (<[i:=y]> m); split; first by auto.
+ intros j; move: (Hm j)=>{Hm}; rewrite !lookup_op=>Hm.
+ destruct (decide (i = j)); simplify_map_eq/=; auto.
+ Qed.
+ Lemma insert_updateP' (P : A → Prop) m i x :
+ lra_updateP x P → lra_updateP (<[i:=x]>m) (λ m', ∃ y, m' = <[i:=y]>m ∧ P y).
+ Proof. eauto using insert_updateP. Qed.
+ Lemma insert_update m i x y : lra_update x y → lra_update (<[i:=x]>m) (<[i:=y]>m).
+ Proof. rewrite !lra_update_updateP; eauto using insert_updateP with subst. Qed.
+
+ Lemma singleton_updateP (P : A → Prop) (Q : gmap K A → Prop) i x :
+ lra_updateP x P → (∀ y, P y → Q {[ i := y ]}) → lra_updateP {[ i := x ]} Q.
+ Proof. apply insert_updateP. Qed.
+ Lemma singleton_updateP' (P : A → Prop) i x :
+ lra_updateP x P → lra_updateP {[ i := x ]} (λ m, ∃ y, m = {[ i := y ]} ∧ P y).
+ Proof. apply insert_updateP'. Qed.
+ Lemma singleton_update i (x y : A) : lra_update x y → lra_update {[ i := x ]} {[ i := y ]}.
+ Proof. apply insert_update. Qed.
+
+ Lemma delete_update m i : lra_update m (delete i m).
+ Proof.
+ apply lra_total_update=> mf Hm j; destruct (decide (i = j)); subst.
+ - move: (Hm j). rewrite !lookup_op lookup_delete left_id.
+ apply lra_valid_op_r.
+ - move: (Hm j). by rewrite !lookup_op lookup_delete_ne.
+ Qed.
+
+ Lemma dom_op m1 m2 : dom (m1 ⋅ m2) = dom m1 ∪ dom m2.
+ Proof.
+ apply set_eq=> i; rewrite elem_of_union !elem_of_dom.
+ unfold is_Some; setoid_rewrite lookup_op.
+ destruct (m1 !! i), (m2 !! i); naive_solver.
+ Qed.
+ Lemma dom_included m1 m2 : m1 ≼ m2 → dom m1 ⊆ dom m2.
+ Proof.
+ rewrite lookup_included=>Ha i; rewrite !elem_of_dom.
+ specialize (Ha i). intros (c & Hc).
+ rewrite Hc in Ha. apply Some_included in Ha as (b & -> & _). eauto.
+ Qed.
+
+ Section freshness.
+ Local Set Default Proof Using "Type*".
+ Context `{!Infinite K}.
+ Lemma alloc_updateP_strong_dep (Q : gmap K A → Prop) (I : K → Prop) m (f : K → A) :
+ pred_infinite I →
+ (∀ i, m !! i = None → I i → ✓ (f i)) →
+ (∀ i, m !! i = None → I i → Q (<[i:=f i]>m)) →
+ lra_updateP m Q.
+ Proof.
+ move=> /(pred_infinite_set I (C:=gset K)) HP ? HQ.
+ apply lra_total_updateP. intros mf Hm.
+ destruct (HP (dom (m ⋅ mf))) as [i [Hi1 Hi2]].
+ assert (m !! i = None).
+ { eapply (not_elem_of_dom). revert Hi2.
+ rewrite dom_op not_elem_of_union. naive_solver. }
+ exists (<[i:=f i]>m); split.
+ - by apply HQ.
+ - rewrite insert_singleton_op //.
+ rewrite -assoc -insert_singleton_op;
+ last by eapply (not_elem_of_dom (D:=gset K)).
+ apply insert_valid; auto.
+ Qed.
+ (** This corresponds to the Alloc axiom shown on paper. *)
+ Lemma alloc_updateP_strong (Q : gmap K A → Prop) (I : K → Prop) m x :
+ pred_infinite I →
+ ✓ x → (∀ i, m !! i = None → I i → Q (<[i:=x]>m)) →
+ lra_updateP m Q.
+ Proof.
+ move=> HP ? HQ. eapply (alloc_updateP_strong_dep _ _ _ (λ _, x)); eauto.
+ Qed.
+ Lemma alloc_updateP (Q : gmap K A → Prop) m x :
+ ✓ x → (∀ i, m !! i = None → Q (<[i:=x]>m)) → lra_updateP m Q.
+ Proof.
+ move=>??.
+ eapply (alloc_updateP_strong _ (λ _, True));
+ eauto using pred_infinite_True.
+ Qed.
+ Lemma alloc_updateP_cofinite (Q : gmap K A → Prop) (J : gset K) m x :
+ ✓ x → (∀ i, m !! i = None → i ∉ J → Q (<[i:=x]>m)) → lra_updateP m Q.
+ Proof.
+ eapply alloc_updateP_strong.
+ apply (pred_infinite_set (C:=gset K)).
+ intros E. exists (fresh (J ∪ E)).
+ apply not_elem_of_union, is_fresh.
+ Qed.
+ End freshness.
+
+ Lemma alloc_unit_singleton_updateP (P : A → Prop) (Q : gmap K A → Prop) u i :
+ ✓ u → LeftId (=) u (⋅) →
+ lra_updateP u P → (∀ y, P y → Q {[ i := y ]}) → lra_updateP ∅ Q.
+ Proof.
+ intros ?? Hx HQ. apply lra_total_updateP=> gf Hg.
+ destruct (Hx (gf !! i)) as (y&?&Hy).
+ { move:(Hg i). rewrite !left_id.
+ case: (gf !! i)=>[x|]; rewrite /= ?left_id //.
+ }
+ exists {[ i := y ]}; split; first by auto.
+ intros i'; destruct (decide (i' = i)) as [->|].
+ - rewrite lookup_op lookup_singleton.
+ move:Hy; case: (gf !! i)=>[x|]; rewrite /= ?right_id //.
+ - move:(Hg i'). by rewrite !lookup_op lookup_singleton_ne // !left_id.
+ Qed.
+ Lemma alloc_unit_singleton_updateP' (P: A → Prop) u i :
+ ✓ u → LeftId (=) u (⋅) →
+ lra_updateP u P → lra_updateP ∅ (λ m, ∃ y, m = {[ i := y ]} ∧ P y).
+ Proof. eauto using alloc_unit_singleton_updateP. Qed.
+ Lemma alloc_unit_singleton_update (u : A) i (y : A) :
+ ✓ u → LeftId (=) u (⋅) → lra_update u y → lra_update (∅:gmap K A) {[ i := y ]}.
+ Proof.
+ rewrite !lra_update_updateP; eauto using alloc_unit_singleton_updateP with subst.
+ Qed.
+
+ (** Local updates *)
+ Lemma alloc_local_update m1 m2 i x :
+ m1 !! i = None → ✓ x → lra_local_update (m1,m2) (<[i:=x]>m1, <[i:=x]>m2).
+ Proof.
+ intros Hi ?. apply local_update_unital => mf Hmv; simpl in *.
+ rewrite map_eq_iff => Hm.
+ split; auto using insert_valid.
+ apply (map_eq (<[i := x]> m1)). intros j; destruct (decide (i = j)) as [->|].
+ - move: (Hm j); rewrite Hi symmetry_iff lookup_op None_op => -[_ Hj].
+ by rewrite lookup_op !lookup_insert Hj.
+ - rewrite lookup_insert_ne // !lookup_op lookup_insert_ne //.
+ rewrite Hm lookup_op //.
+ Qed.
+
+ Lemma alloc_singleton_local_update m i x :
+ m !! i = None → ✓ x → lra_local_update (m,∅) (<[i:=x]>m, {[ i:=x ]}).
+ Proof. apply alloc_local_update. Qed.
+
+ Lemma insert_local_update m1 m2 i x y x' y' :
+ m1 !! i = Some x → m2 !! i = Some y →
+ lra_local_update (x, y) (x', y') →
+ lra_local_update (m1, m2) (<[i:=x']>m1, <[i:=y']>m2).
+ Proof.
+ intros Hi1 Hi2 Hup; apply local_update_unital=> mf Hmv. rewrite map_eq_iff => Hm; simpl in *.
+ destruct (Hup (mf !! i)) as [? Hx']; simpl in *.
+ { move: (Hm i). rewrite lookup_op Hi1 Hi2 Some_op_opM (inj_iff Some).
+ intros; split; last done. by eapply lookup_valid_Some.
+ }
+ split; auto using insert_valid. apply (map_eq (<[i := x']> m1)). intros j.
+ destruct (decide (i = j)) as [->|].
+ - rewrite lookup_insert lookup_op lookup_insert Some_op_opM. by subst.
+ - rewrite lookup_insert_ne // !lookup_op lookup_insert_ne //. rewrite Hm lookup_op//.
+ Qed.
+
+ Lemma singleton_local_update_any m i y x' y' :
+ (∀ x, m !! i = Some x → lra_local_update (x, y) (x', y')) →
+ lra_local_update (m, {[ i := y ]}) (<[i:=x']>m, {[ i := y' ]}).
+ Proof.
+ intros. rewrite /singletonM /map_singleton -(insert_insert ∅ i y' y).
+ apply lra_local_update_total_valid =>_ _ /singleton_included_l [x0 [Hlk0 _]].
+ eapply insert_local_update; [|eapply lookup_insert|]; eauto.
+ Qed.
+
+ Lemma singleton_local_update m i x y x' y' :
+ m !! i = Some x →
+ lra_local_update (x, y) (x', y') →
+ lra_local_update (m, {[ i := y ]}) (<[i:=x']>m, {[ i := y' ]}).
+ Proof.
+ intros Hmi ?. apply singleton_local_update_any.
+ intros x2. rewrite Hmi=>[=<-]. done.
+ Qed.
+
+ Lemma delete_local_update m1 m2 i x :
+ lra_exclusive x →
+ m2 !! i = Some x → lra_local_update (m1, m2) (delete i m1, delete i m2).
+ Proof.
+ intros Hexcl Hi. apply local_update_unital=> mf Hmv Hm; simpl in *.
+ split; auto using delete_valid.
+ rewrite Hm. apply (map_eq (delete i (m2 ⋅ mf))) => j; destruct (decide (i = j)) as [<-|].
+ - rewrite lookup_op !lookup_delete left_id symmetry_iff.
+ apply eq_None_not_Some=> -[y Hi'].
+ move: (Hmv i). rewrite Hm lookup_op Hi Hi' -Some_op. intros []%Hexcl.
+ - by rewrite lookup_op !lookup_delete_ne // lookup_op.
+ Qed.
+
+ Lemma delete_singleton_local_update m i x :
+ lra_exclusive x →
+ lra_local_update (m, {[ i := x ]}) (delete i m, ∅).
+ Proof.
+ rewrite -(delete_singleton i x).
+ intros ?. by eapply delete_local_update, lookup_singleton.
+ Qed.
+End fin_fun.
+Global Arguments gmapUR : clear implicits.
+Global Arguments gmapUR _ {_ _}.
+Global Arguments gmapR : clear implicits.
+Global Arguments gmapR _ {_ _}.
+
+(** Agreement maps *)
+Definition agmapCR (A B : Type) `{Countable A} `{Countable B} := (authCR (gmapUR A (agreeR B))).
+Class agmapG Σ (A B : Type) `{Countable A} `{Countable B} :=
+ AgMapG { agmapG_inG : inG Σ (agmapCR A B); }.
+#[export] Existing Instance agmapG_inG.
+Definition agmapΣ A B `{Countable A} `{Countable B} : gFunctors := #[ GFunctor (agmapCR A B) ].
+Global Instance subG_agmapΣ Σ A B `{Countable A} `{Countable B} : subG (agmapΣ A B) Σ → agmapG Σ A B.
+Proof. solve_inG. Qed.
+Section agmap.
+ Context {A B : Type} `{Countable A} `{Countable B}.
+ Context `{agmapG Σ A B}.
+
+ Definition to_agmap (m : gmap A B) : gmapUR A (agreeR B) := fmap (λ a, to_agree a) m.
+
+ Definition agmap_auth γ (m : gmap A B) := own γ (auth_auth (to_agmap m)).
+
+ Definition agmap_elem γ (a : A) (b : B) := own γ (auth_frag ({[ a := to_agree b ]})).
+
+ Lemma agmap_alloc_empty :
+ ⊢ |==> ∃ γ, agmap_auth γ ∅.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+ Lemma agmap_insert γ m a b :
+ m !! a = None →
+ agmap_auth γ m -∗ |==> agmap_auth γ (<[a := b]> m) ∗ agmap_elem γ a b.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+
+ Lemma agmap_lookup γ m a b :
+ agmap_auth γ m -∗ agmap_elem γ a b -∗ ⌜m !! a = Some b⌝.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+
+ Global Instance agmap_elem_persistent γ a b : Persistent (agmap_elem γ a b).
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+
+ Global Instance agmap_auth_timeless γ m : Timeless (agmap_auth γ m).
+ Proof. apply _. Qed.
+ Global Instance agmap_elem_timeless γ a b : Timeless (agmap_elem γ a b).
+ Proof. apply _. Qed.
+End agmap.
+
+(** Updateable maps *)
+Definition exmapCR (A B : Type) `{Countable A} := (authCR (gmapUR A (exclR B))).
+Class exmapG Σ (A B : Type) `{Countable A} :=
+ ExMapG { exmapG_inG : inG Σ (exmapCR A B); }.
+#[export] Existing Instance exmapG_inG.
+Definition exmapΣ A B `{Countable A} : gFunctors := #[ GFunctor (exmapCR A B) ].
+Global Instance subG_exmapΣ Σ A B `{Countable A} : subG (exmapΣ A B) Σ → exmapG Σ A B.
+Proof. solve_inG. Qed.
+Section exmap.
+ Context {A B : Type} `{Countable A}.
+ Context `{exmapG Σ A B}.
+
+ Definition to_exmap (m : gmap A B) : gmapUR A (exclR B) := fmap (λ a, Excl (A := B) a) m.
+
+ Definition exmap_auth γ (m : gmap A B) := own γ (auth_auth (to_exmap m)).
+ Definition exmap_elem γ (a : A) (b : B) := own γ (auth_frag ({[ a := Excl b ]})).
+
+ Lemma exmap_alloc_empty :
+ ⊢ |==> ∃ γ, exmap_auth γ ∅.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+ Lemma exmap_insert γ m a b :
+ m !! a = None →
+ exmap_auth γ m -∗ |==> exmap_auth γ (<[a := b]> m) ∗ exmap_elem γ a b.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+
+ Lemma exmap_lookup γ m a b :
+ exmap_auth γ m -∗ exmap_elem γ a b -∗ ⌜m !! a = Some b⌝.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+ Lemma exmap_update γ m a b c :
+ exmap_auth γ m -∗ exmap_elem γ a b -∗ |==> exmap_auth γ (<[a := c]> m) ∗ exmap_elem γ a c.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+ Lemma exmap_delete γ m a b :
+ exmap_auth γ m -∗ exmap_elem γ a b -∗ |==> exmap_auth γ (delete a m).
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+ Global Instance exmap_auth_timeless γ m : Timeless (exmap_auth γ m).
+ Proof. apply _. Qed.
+ Global Instance exmap_elem_timeless γ a b : Timeless (exmap_elem γ a b).
+ Proof. apply _. Qed.
+End exmap.
+
+
+(** ** Exercise: functions, pointwise *)
+Section functions.
+ (* TODO: this is an exercise for you *)
+ Context {A : Type} {B : ulra}.
+ Implicit Types (f g : A → B).
+
+ (* You may assume functional extensionality.
+ (Note that in the Iris version of this RA, FE is not needed, due to a more flexible setup of RAs.) *)
+ Import FunctionalExtensionality.
+ Notation fext := functional_extensionality.
+
+ Local Instance fun_op_instance : Op (A → B) := λ f g, f (* TODO *).
+ Local Instance fun_pcore_instance : PCore (A → B) := λ f, None (* TODO *).
+ Local Instance fun_valid_instance : Valid (A → B) := λ f,False (* TODO *).
+ (* TODO: uncomment if there's a unit *)
+ (*Local Instance fun_unit_instance : Unit (A → B) := λ a, (??) .*)
+
+ Lemma fun_included f g :
+ f ≼ g → False (* TODO *).
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+ (* You may want to derive additional lemmas about the definition of your operations *)
+
+
+ Lemma fun_lra_mixin : LRAMixin (A → B).
+ Proof.
+ (** Hint: you may want to use that [B]'s core is total. *)
+ (* TODO: exercise *)
+ Admitted.
+
+ Canonical Structure funR := Lra (A → B) fun_lra_mixin.
+
+ (* TODO: uncomment if you think that there's a unit *)
+ (*
+ Lemma fun_ulra_mixin : ULRAMixin (A → B).
+ Proof.
+ Admitted.
+ (*Qed.*)
+ Canonical Structure funUR := Ulra (A → B) fun_lra_mixin fun_ulra_mixin.
+ *)
+
+ Lemma fun_exclusive `{Inhabited A} f :
+ (∀ a, lra_exclusive (f a)) → lra_exclusive f.
+ Proof.
+ (* Hint: you may assume that [A] is inhabited, i.e., there's an [inhabitant] of A that you can use. *)
+ (* TODO: exercise *)
+ Admitted.
+
+End functions.
diff --git a/theories/type_systems/stlc/cbn_logrel.v b/theories/type_systems/stlc/cbn_logrel.v
index cb157a4169d0198c957a629fcf37594938b4ca35..a087a6fbe920427b08dbb28f4dd7a2b498b864db 100644
--- a/theories/type_systems/stlc/cbn_logrel.v
+++ b/theories/type_systems/stlc/cbn_logrel.v
@@ -40,69 +40,83 @@ Qed.
-(** ** Definition of the logical relation. *)
-(**
- In Coq, we need to make argument why the logical relation is well-defined precise:
- This holds true in particular for the mutual recursion between the value relation and the expression relation
- (note that the value relation is defined in terms of the expression relation, and vice versa).
- We therefore define a termination measure [mut_measure] that makes sure that for each recursive call, we either
- - decrease the size of the type
- - or switch from the expression case to the value case.
-
- We use the Equations package to define the logical relation, as it's tedious to make the termination
- argument work with Coq's built-in support for recursive functions---but under the hood, the Equations also
- just encodes it as a Coq Fixpoint.
- *)
-Inductive type_case : Set :=
- | expr_case | val_case.
-
-(* The [type_size] function just structurally descends, essentially taking the size of the "type tree". *)
+(* *** Definition of the logical relation. *)
+(* We reuse most of these definitions. *)
+Inductive val_or_expr : Type :=
+| inj_val : val → val_or_expr
+| inj_expr : expr → val_or_expr.
+
+(* Note that we're using a slightly modified termination argument here. *)
Equations type_size (t : type) : nat :=
type_size Int := 1;
type_size (Fun A B) := type_size A + type_size B + 2.
-(* The definition of the expression relation uses the value relation -- therefore, it needs to be larger, and we add [1]. *)
-Equations mut_measure (c : type_case) (t : type) : nat :=
- mut_measure expr_case t := 1 + type_size t;
- mut_measure val_case t := type_size t.
-
-Definition sem_type : Type := val → Prop.
-
-(** The main definition of the logical relation.
- To handle the mutual recursion, both the expression and value relation are handled by one definition, with [type_case] determining the case.
+Equations mut_measure (ve : val_or_expr) (t : type) : nat :=
+ mut_measure (inj_val _) t := type_size t;
+ mut_measure (inj_expr _) t := 1 + type_size t.
- The argument [v] has a type that is determined by the case of the relation (so the whole thing is dependently-typed).
- The [by wf ..] part tells Equations to use [mut_measure] for the well-formedness argument.
- *)
-Equations type_interp (c : type_case) (t : type) (v : match c with val_case => val | expr_case => expr end) : Prop by wf (mut_measure c t) := {
- type_interp val_case Int v =>
+Equations type_interp (ve : val_or_expr) (t : type) : Prop by wf (mut_measure ve t) := {
+ type_interp (inj_val v) Int =>
∃ z : Z, v = z ;
- type_interp val_case (A → B) v =>
+ type_interp (inj_val v) (A → B) =>
∃ x e, v = @LamV x e ∧ closed (x :b: nil) e ∧
∀ e',
- type_interp expr_case A e' →
- type_interp expr_case B (subst' x e' e);
+ type_interp (inj_expr e') A →
+ type_interp (inj_expr (subst' x e' e)) B;
- type_interp expr_case t e =>
- (* NOTE: we now need to explicitly require that expressions here are closed. *)
- ∃ v, big_step e v ∧ closed [] e ∧ type_interp val_case t v
+ type_interp (inj_expr e) t =>
+ (* we now need to explicitly require that expressions here are closed so
+ that we can apply them to lambdas directly. *)
+ ∃ v, big_step e v ∧ closed [] e ∧ type_interp (inj_val v) t
}.
Next Obligation.
- (** [simp] is a tactic provided by [Equations]. It rewrites with the defining equations of the definition.
- [simpl]/[cbn] will NOT unfold definitions made with Equations.
- *)
- repeat simp mut_measure; simp type_size. lia.
+ repeat simp mut_measure; simp type_size; lia.
Qed.
Next Obligation.
simp mut_measure. simp type_size.
destruct A; repeat simp mut_measure; repeat simp type_size; lia.
Qed.
-(** We derive the expression/value relation. *)
-Definition sem_val_rel t v := type_interp val_case t v.
-Definition sem_expr_rel t e := type_interp expr_case t e.
+(* We derive the expression/value relation. *)
+Notation sem_val_rel t v := (type_interp (inj_val v) t).
+Notation sem_expr_rel t e := (type_interp (inj_expr e) t).
+
+Notation 𝒱 t v := (sem_val_rel t v).
+Notation ℰ t v := (sem_expr_rel t v).
+
+
+(* *** Semantic typing of contexts *)
+Implicit Types
+ (θ : gmap string expr).
+
+Inductive sem_context_rel : typing_context → (gmap string expr) → Prop :=
+ | sem_context_rel_empty : sem_context_rel ∅ ∅
+ (* contexts may now contain arbitrary (semantically well-typed) expressions
+ as opposed to just values. *)
+ | sem_context_rel_insert Γ θ e x A :
+ ℰ A e →
+ sem_context_rel Γ θ →
+ sem_context_rel (<[x := A]> Γ) (<[x := e]> θ).
+
+Notation 𝒢 := sem_context_rel.
+
+(* The semantic typing judgement. Note that we require e to be closed under Γ. *)
+Definition sem_typed Γ e A :=
+ closed (elements (dom Γ)) e ∧
+ ∀ θ, 𝒢 Γ θ → ℰ A (subst_map θ e).
+Notation "Γ ⊨ e : A" := (sem_typed Γ e A) (at level 74, e, A at next level).
+
+
+(* We start by proving a couple of helper lemmas that will be useful later. *)
+
+Lemma sem_expr_rel_of_val A v:
+ ℰ A v → 𝒱 A v.
+Proof.
+ simp type_interp.
+ intros (v' & ->%big_step_inv_vals & Hv').
+ apply Hv'.
+Qed.
+
-Notation 𝒱 := sem_val_rel.
-Notation ℰ := sem_expr_rel.
Lemma val_rel_closed v A:
𝒱 A v → closed [] v.
@@ -111,39 +125,29 @@ Proof.
- intros [z ->]. done.
- intros (x & e & -> & Hcl & _). done.
Qed.
-
+Lemma val_inclusion A v:
+ 𝒱 A v → ℰ A v.
+Proof.
+ intros H. simp type_interp. eauto using big_step_vals, val_rel_closed.
+Qed.
Lemma expr_rel_closed e A :
ℰ A e → closed [] e.
Proof.
- simp type_interp. intros (v & ? & ? & _); done.
+ simp type_interp. intros (v & ? & ? & ?). done.
Qed.
-
-Lemma sem_expr_rel_of_val A v:
- ℰ A v → 𝒱 A v.
+Lemma sem_context_rel_closed Γ θ:
+ 𝒢 Γ θ → subst_closed [] θ.
Proof.
- simp type_interp.
- intros (v' & ->%big_step_inv_vals & Hv').
- apply Hv'.
+ induction 1; rewrite /subst_closed.
+ - naive_solver.
+ - intros y e'. rewrite lookup_insert_Some.
+ intros [[-> <-]|[Hne Hlook]].
+ + by eapply expr_rel_closed.
+ + eapply IHsem_context_rel; last done.
Qed.
-(** Interpret a type *)
-Definition interp_type A : sem_type := 𝒱 A.
-
-(** *** Semantic typing of contexts *)
-(** Substitutions map to expressions -- this is so that we can more easily reuse notions like closedness *)
-Implicit Types
- (θ : gmap string expr).
-
-(* NOTE: our context now contains expressions. *)
-Inductive sem_context_rel : typing_context → (gmap string expr) → Prop :=
- | sem_context_rel_empty : sem_context_rel ∅ ∅
- | sem_context_rel_insert Γ θ e x A :
- ℰ A e →
- sem_context_rel Γ θ →
- sem_context_rel (<[x := A]> Γ) (<[x := e]> θ).
-
-Notation 𝒢 := sem_context_rel.
+(* This is essentially an inversion lemma for 𝒢 *)
Lemma sem_context_rel_exprs Γ θ x A :
sem_context_rel Γ θ →
Γ !! x = Some A →
@@ -158,38 +162,23 @@ Proof.
done.
Qed.
-Lemma sem_context_rel_subset Γ θ :
- 𝒢 Γ θ → dom Γ ⊆ dom θ.
+Lemma sem_context_rel_dom Γ θ :
+ 𝒢 Γ θ → dom Γ = dom θ.
Proof.
- intros Hctx. apply elem_of_subseteq. intros x (A & Hlook)%elem_of_dom.
- eapply sem_context_rel_exprs in Hlook as (e & Hlook & He); last done.
- eapply elem_of_dom; eauto.
+ induction 1.
+ - by rewrite !dom_empty.
+ - rewrite !dom_insert. congruence.
Qed.
-Lemma sem_context_rel_closed Γ θ:
- 𝒢 Γ θ → subst_closed [] θ.
-Proof.
- induction 1; rewrite /subst_closed.
- - naive_solver.
- - intros y e'. rewrite lookup_insert_Some.
- intros [[-> <-]|[Hne Hlook]].
- + by eapply expr_rel_closed.
- + eapply IHsem_context_rel; last done.
-Qed.
-(** The semantic typing judgment *)
-Definition sem_typed Γ e A :=
- ∀ θ, 𝒢 Γ θ → ℰ A (subst_map θ e).
-Notation "Γ ⊨ e : A" := (sem_typed Γ e A) (at level 74, e, A at next level).
Lemma termination e A :
(∅ ⊢ e : A)%ty →
∃ v, big_step e v.
Proof.
- (* FIXME: prove this.
- You may want to add suitable intermediate lemmas, just as for the cbv logrel
- seen in the lecture.
- *)
-(*Qed.*)
+ (* You may want to add suitable intermediate lemmas, like we did for the cbv
+ logical relation as seen in the lecture. *)
+ (* TODO: exercise *)
Admitted.
+
diff --git a/theories/type_systems/stlc/exercises01.v b/theories/type_systems/stlc/exercises01.v
index 6b14623ec3eb248e31a99164a1832a185d813950..9268769cacd58e7562511bd693ed6134c5292cb0 100644
--- a/theories/type_systems/stlc/exercises01.v
+++ b/theories/type_systems/stlc/exercises01.v
@@ -2,48 +2,39 @@ From stdpp Require Import gmap base relations tactics.
From iris Require Import prelude.
From semantics.ts.stlc Require Import lang notation.
-
-(* In these exercises, we will use the reflexive, transitive closure
- of relations from the library stdpp defined by:
-
- Inductive rtc {X} (R: X → X → Prop):
- | rtc_refl x : rtc R x x
- | rtc_l x y z :
- R x y →
- rtc R y z →
- rtc R x z.
-
- With the following instruction, we make eauto aware
- of its constructors.
-*)
-#[local] Hint Constructors rtc : core.
-
-
-
(** Exercise 2 (LN Exercise 1): Deterministic Operational Semantics *)
-
Lemma val_no_step e e':
step e e' → is_val e → False.
-Proof. Admitted.
+Proof.
+ by destruct 1.
+Qed.
+(* Note how the above lemma is another way to phrase the statement "values
+ * cannot step" that doesn't need inversion. It can also be used to prove the
+ * phrasing we had to use inversion for in the lecture: *)
+Lemma val_no_step' (v : val) (e : expr) :
+ step v e -> False.
+Proof.
+ intros H. eapply val_no_step; first eassumption.
+ apply is_val_val.
+Qed.
-(** You might find the following tactic useful,
- which derives a contradiction when you have a [step e1 e2] assumption and
- [e1] is a value.
- Example:
- H1: step e e'
- H2: is_val e
- =====================
- ???
+(* You might find the following tactic useful,
+ which derives a contradiction when you have a [step e1 e2] assumption and
+ [e1] is a value.
- Then [val_no_step.] will solve the goal by applying the [val_no_step] lemma.
+ Example:
+ H1: step e e'
+ H2: is_val e
+ =====================
+ ???
- (We neither expect you to understand how exactly the tactic does this nor
- to be able to write such a tactic yourself. Where useful, we will always
- provide you with custom tactics and explain in a comment what they do.)
+ Then [val_no_step.] will solve the goal by applying the [val_no_step] lemma.
-*)
+ (We neither expect you to understand how exactly the tactic does this nor to
+ be able to write such a tactic yourself. Where useful, we will always
+ provide you with custom tactics and explain in a comment what they do.) *)
Ltac val_no_step :=
match goal with
| [H: step ?e1 ?e2 |- _] =>
@@ -52,26 +43,35 @@ Ltac val_no_step :=
Lemma step_det e e' e'':
step e e' → step e e'' → e' = e''.
-Proof. Admitted.
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
(** Exercise 3 (LN Exercise 2): Call-by-name Semantics *)
Inductive cbn_step : expr → expr → Prop :=
| CBNStepBeta x e e' :
- cbn_step (App (Lam x e) e') (subst' x e' e)
- (* | .... *).
+ cbn_step (App (Lam x e) e') (subst' x e' e)
+ (* TODO: add more constructors *)
+.
(* We make the eauto tactic aware of the constructors of cbn_step *)
#[global] Hint Constructors cbn_step : core.
Lemma different_results :
- ∃ (e: expr) (e1 e2: expr), rtc cbn_step e e1 ∧ rtc step e e2 ∧ is_val e1 ∧ is_val e2 ∧ e1 ≠ e2.
-Proof. Admitted.
+ ∃ (e: expr) (e1 e2: expr), rtc cbn_step e e1 ∧ rtc step e e2 ∧ is_val e1 ∧ is_val e2 ∧ e1 ≠ e2.
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
Lemma val_no_cbn_step e e':
cbn_step e e' → is_val e → False.
Proof.
+ (* TODO: exercise *)
Admitted.
+
(* Same tactic as [val_no_step] but for cbn_step.*)
Ltac val_no_cbn_step :=
match goal with
@@ -81,35 +81,165 @@ Ltac val_no_cbn_step :=
Lemma cbn_step_det e e' e'':
cbn_step e e' → cbn_step e e'' → e' = e''.
-Proof. Admitted.
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+
+
+(** Exercise 4 (LN Exercise 3): Reflexive Transitive Closure *)
+Section rtc.
+ Context {X : Type}.
+
+ Inductive rtc (R : X → X → Prop) : X → X → Prop :=
+ | rtc_base x : rtc R x x
+ | rtc_step x y z : R x y → rtc R y z → rtc R x z.
+
+ Lemma rtc_reflexive R : Reflexive (rtc R).
+ Proof.
+ unfold Reflexive.
+ (* TODO: exercise *)
+ Admitted.
+
+ Lemma rtc_transitive R : Transitive (rtc R).
+ Proof.
+ unfold Transitive.
+ (* TODO: exercise *)
+ Admitted.
+
+
+ Lemma rtc_subrel (R: X → X → Prop) (x y : X): R x y → rtc R x y.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+ Section typeclass.
+ (* We can use Coq's typeclass mechanism to enable the use of the [transitivity] and [reflexivity] tactics on our goals.
+ Typeclasses enable easy extensions of existing mechanisms -- in this case, by telling Coq to use the knowledge about our definition of [rtc].
+ *)
+ (* [Transitive] is a typeclass. With [Instance] we provide an instance of it. *)
+ Global Instance rtc_transitive_inst R : Transitive (rtc R).
+ Proof.
+ apply rtc_transitive.
+ Qed.
+ Global Instance rtc_reflexive_inst R : Reflexive (rtc R).
+ Proof.
+ apply rtc_reflexive.
+ Qed.
+ End typeclass.
+End rtc.
+
+(* Let's put this to the test! *)
+Goal rtc step (LitInt 42) (LitInt 42).
+Proof.
+ (* this uses the [rtc_reflexive_inst] instance we registered. *)
+ reflexivity.
+Qed.
+Goal rtc step (LitInt 32 + (LitInt 5 + LitInt 5)%E)%E (LitInt 42).
+Proof.
+ (* this uses the [rtc_transitive_inst] instance we registered. *)
+ etransitivity.
+ + eapply rtc_step; eauto. reflexivity.
+ + eapply rtc_step; eauto. reflexivity.
+Qed.
+
+Section stdpp.
+ (* In fact, [rtc] is so common that it is already provided by the [stdpp] library! *)
+ Import stdpp.relations.
+ Print rtc.
+
+ (* The typeclass instances are also already registered. *)
+ Goal rtc step (LitInt 42) (LitInt 42).
+ Proof. reflexivity. Qed.
+End stdpp.
+
+(* Start by proving these lemmas. Understand why they are useful. *)
+Lemma plus_right e1 e2 e2':
+ rtc step e2 e2' → rtc step (Plus e1 e2) (Plus e1 e2').
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+
+Lemma plus_left e1 e1' n:
+ rtc step e1 e1' → rtc step (Plus e1 (LitInt n)) (Plus e1' (LitInt n)).
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+
+(* The exercise: *)
+Lemma plus_to_consts e1 e2 n m:
+ rtc step e1 (LitInt n) → rtc step e2 (LitInt m) → rtc step (e1 + e2)%E (LitInt (n + m)%Z).
+Proof.
+ (* TODO: exercise *)
+Admitted.
-(** Exercise 4 (LN Exercise 3): Big-step vs small-step semantics *)
+
+(* Now that you have an understanding of how rtc works, we can make eauto aware of it. *)
+#[local] Hint Constructors rtc : core.
+
+(* See its power here: *)
+Lemma plus_right_eauto e1 e2 e2':
+ rtc step e2 e2' → rtc step (Plus e1 e2) (Plus e1 e2').
+Proof.
+ induction 1; eauto.
+Abort.
+
+(** Exercise 5 (LN Exercise 4): Big-step vs small-step semantics *)
+
+
Lemma big_step_steps e v :
big_step e v → rtc step e (of_val v).
-Proof. Admitted.
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+
Lemma steps_big_step e (v: val):
rtc step e v → big_step e v.
-Proof. Admitted.
+Proof.
+ (* Note how there is a coercion (automatic conversion) hidden in the
+ * statement of this lemma: *)
+ Set Printing Coercions.
+ (* It is sometimes very useful to temporarily print coercions if rewrites or
+ * destructs do not behave as expected. *)
+ Unset Printing Coercions.
+ (* TODO: exercise *)
+Admitted.
-(** Exercise 5 (LN Exercise 4): left-to-right evaluation *)
+
+(** Exercise 6 (LN Exercise 5): left-to-right evaluation *)
Inductive ltr_step : expr → expr → Prop := .
#[global] Hint Constructors ltr_step : core.
Lemma different_steps_ltr_step :
- ∃ (e: expr) (e1 e2: expr), ltr_step e e1 ∧ step e e2 ∧ e1 ≠ e2.
+ ∃ (e: expr) (e1 e2: expr), ltr_step e e1 ∧ step e e2 ∧ e1 ≠ e2.
+Proof.
+ (* TODO: exercise *)
Admitted.
+
+
+
Lemma big_step_ltr_steps e v :
big_step e v → rtc ltr_step e (of_val v).
-Proof. Admitted.
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+
+
Lemma ltr_steps_big_step e (v: val):
rtc ltr_step e v → big_step e v.
-Proof. Admitted.
-
+Proof.
+ (* TODO: exercise *)
+Admitted.
diff --git a/theories/type_systems/stlc/exercises02.v b/theories/type_systems/stlc/exercises02.v
index 007c09426b03416f8c9411e493b2b29199ca1e77..a75930839620225267c693157bf0c502a145e74e 100644
--- a/theories/type_systems/stlc/exercises02.v
+++ b/theories/type_systems/stlc/exercises02.v
@@ -4,6 +4,10 @@ From semantics.ts.stlc Require Import lang notation.
From semantics.ts.stlc Require untyped types.
+(** README: Please also download the assigment sheet as a *.pdf from here:
+ https://cms.sic.saarland/semantics_ws2324/materials/
+ It contains additional explanation and excercises. **)
+
(** ** Exercise 1: Prove that the structural and contextual semantics are equivalent. *)
(** You will find it very helpful to separately derive the structural rules of the
structural semantics for the contextual semantics. *)
@@ -11,110 +15,128 @@ From semantics.ts.stlc Require untyped types.
Lemma contextual_step_beta x e e':
is_val e' → contextual_step ((λ: x, e) e') (subst' x e' e).
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
Lemma contextual_step_app_r (e1 e2 e2': expr) :
contextual_step e2 e2' →
contextual_step (e1 e2) (e1 e2').
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
Lemma contextual_step_app_l (e1 e1' e2: expr) :
is_val e2 →
contextual_step e1 e1' →
contextual_step (e1 e2) (e1' e2).
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
Lemma contextual_step_plus_red (n1 n2 n3: Z) :
(n1 + n2)%Z = n3 →
contextual_step (n1 + n2)%E n3.
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
Lemma contextual_step_plus_r e1 e2 e2' :
contextual_step e2 e2' →
contextual_step (Plus e1 e2) (Plus e1 e2').
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
Lemma contextual_step_plus_l e1 e1' e2 :
is_val e2 →
contextual_step e1 e1' →
contextual_step (Plus e1 e2) (Plus e1' e2).
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
+(** We register these lemmas as hints for [eauto]. *)
+#[global]
+Hint Resolve contextual_step_beta contextual_step_app_l contextual_step_app_r contextual_step_plus_red contextual_step_plus_l contextual_step_plus_r : core.
+
Lemma step_contextual_step e1 e2: step e1 e2 → contextual_step e1 e2.
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
(** Now the other direction. *)
(* You may find it helpful to introduce intermediate lemmas. *)
+
Lemma contextual_step_step e1 e2:
contextual_step e1 e2 → step e1 e2.
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
(** ** Exercise 2: Scott encodings *)
Section scott.
- Import semantics.stlc.untyped.
+ (* take a look at untyped.v for usefull lemmas and definitions *)
+ Import semantics.ts.stlc.untyped.
(** Scott encoding of Booleans *)
- Definition true_scott : val := 0 (* FIXME *).
- Definition false_scott : val := 0 (* FIXME *).
+ Definition true_scott : val := 0(* TODO *).
+ Definition false_scott : val := 0(* TODO *).
Lemma true_red (v1 v2 : val) :
closed [] v1 →
closed [] v2 →
rtc step (true_scott v1 v2) v1.
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
Lemma false_red (v1 v2 : val) :
closed [] v1 →
closed [] v2 →
rtc step (false_scott v1 v2) v2.
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
(** Scott encoding of Pairs *)
- Definition pair_scott : val := 0 (* FIXME *) .
+ Definition pair_scott : val := 0(* TODO *).
- Definition fst_scott : val := 0 (* FIXME *).
- Definition snd_scott : val := 0 (* FIXME *).
+ Definition fst_scott : val := 0(* TODO *).
+ Definition snd_scott : val := 0(* TODO *).
Lemma fst_red (v1 v2 : val) :
is_closed [] v1 →
is_closed [] v2 →
rtc step (fst_scott (pair_scott v1 v2)) v1.
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
Lemma snd_red (v1 v2 : val) :
is_closed [] v1 →
is_closed [] v2 →
rtc step (snd_scott (pair_scott v1 v2)) v2.
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
End scott.
-Import semantics.stlc.types.
+Import semantics.ts.stlc.types.
(** ** Exercise 3: type erasure *)
(** Source terms *)
@@ -129,7 +151,7 @@ Inductive src_expr :=
(** The erasure function *)
Fixpoint erase (E: src_expr) : expr :=
- (* FIXME: define erasure *) 0.
+0 (* TODO *).
Reserved Notation "Γ '⊢S' e : A" (at level 74, e, A at next level).
Inductive src_typed : typing_context → src_expr → type → Prop :=
@@ -155,20 +177,35 @@ where "Γ '⊢S' E : A" := (src_typed Γ E%E A%ty) : FType_scope.
Lemma type_erasure_correctness Γ E A:
(Γ ⊢S E : A)%ty → (Γ ⊢ erase E : A)%ty.
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
(** ** Exercise 4: Unique Typing *)
Lemma src_typing_unique Γ E A B:
(Γ ⊢S E : A)%ty → (Γ ⊢S E : B)%ty → A = B.
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
-(** FIXME: Is runtime typing (Curry-style) also unique? Prove it or give a counterexample. *)
+
+(** TODO: Is runtime typing (Curry-style) also unique? Prove it or give a counterexample. *)
+
(** ** Exercise 5: Type Inference *)
+Fixpoint type_eq A B :=
+ match A, B with
+ | Int, Int => true
+ | Fun A B, Fun A' B' => type_eq A A' && type_eq B B'
+ | _, _ => false
+ end.
+
+Lemma type_eq_iff A B: type_eq A B ↔ A = B.
+Proof.
+ induction A in B |-*; destruct B; simpl; naive_solver.
+Qed.
+
Notation ctx := (gmap string type).
Fixpoint infer_type (Γ: ctx) E :=
match E with
@@ -178,10 +215,10 @@ Fixpoint infer_type (Γ: ctx) E :=
| Some B => Some (Fun A B)
| None => None
end
- (* FIXME: complete the definition for the remaining cases *)
- | ELitInt l => None (* FIXME *)
- | EApp E1 E2 => None (* FIXME *)
- | EPlus E1 E2 => None (* FIXME *)
+ (* TODO: complete the definition for the remaining cases *)
+ | ELitInt l => None (* TODO *)
+ | EApp E1 E2 => None (* TODO *)
+ | EPlus E1 E2 => None (* TODO *)
| ELam BAnon A E => None
end.
@@ -189,27 +226,48 @@ Fixpoint infer_type (Γ: ctx) E :=
Lemma infer_type_typing Γ E A:
infer_type Γ E = Some A → (Γ ⊢S E : A)%ty.
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
Lemma typing_infer_type Γ E A:
(Γ ⊢S E : A)%ty → infer_type Γ E = Some A.
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
(** ** Exercise 6: untypable, safe term *)
-Definition ust : expr := 0 (* FIXME *).
-Lemma ust_safe e':
- rtc step ust e' → is_val e' ∨ reducible e'.
-Proof.
- (* FIXME *)
-Admitted.
+(* The exercise asks you to:
+ "Give one example if there is such an expression, otherwise prove their non-existence."
+ So either finish one section or the other.
+*)
-Lemma ust_no_type Γ A:
- ¬ (Γ ⊢ ust : A)%ty.
-Proof.
- (* FIXME *)
-Admitted.
+Section give_example.
+ Definition ust : expr := 0 (* TODO *).
+
+ Lemma ust_safe e':
+ rtc step ust e' → is_val e' ∨ reducible e'.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+
+ Lemma ust_no_type Γ A:
+ ¬ (Γ ⊢ ust : A)%ty.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+End give_example.
+
+Section prove_non_existence.
+ Lemma no_ust :
+ ∀ e, (∀ e', rtc step e e' → is_val e' ∨ reducible e') → ∃ A, (∅ ⊢ e : A)%ty.
+ Proof.
+ (* TODO: exercise *)
+ Admitted.
+
+End prove_non_existence.
\ No newline at end of file
diff --git a/theories/type_systems/stlc/lang.v b/theories/type_systems/stlc/lang.v
index b668d788e58034e18da0a2fdef66a7f7fdd52993..ee27fad26894f812cb1ba209e94cdff7272dc360 100644
--- a/theories/type_systems/stlc/lang.v
+++ b/theories/type_systems/stlc/lang.v
@@ -319,3 +319,22 @@ Qed.
Lemma subst_closed_nil e x es : closed [] e → subst x es e = e.
Proof. intros. apply subst_closed with []; set_solver. Qed.
+
+Lemma val_no_step e e':
+ step e e' → is_val e → False.
+Proof.
+ by destruct 1.
+Qed.
+
+Lemma val_no_step' (v : val) (e : expr) :
+ step (of_val v) e -> False.
+Proof.
+ intros H. eapply (val_no_step _ _ H).
+ apply is_val_val.
+Qed.
+
+Ltac val_no_step :=
+ match goal with
+ | [H: step ?e1 ?e2 |- _] =>
+ solve [exfalso; eapply (val_no_step _ _ H); done]
+ end.
\ No newline at end of file
diff --git a/theories/type_systems/stlc/lecture2.v b/theories/type_systems/stlc/lecture2.v
new file mode 100644
index 0000000000000000000000000000000000000000..0eaa8843a961069f23a1ca57c32aef71963bae3a
--- /dev/null
+++ b/theories/type_systems/stlc/lecture2.v
@@ -0,0 +1,299 @@
+(** * This file was shown during the lecture on 26.10.2023.
+ * It contrains duplicated code that is copy-pasted from e.g. lang.v
+ *)
+
+From stdpp Require Export binders strings.
+From stdpp Require Import options.
+From semantics.lib Require Import maps.
+
+(** * Simply Typed Lambda Calculus *)
+
+(** ** Expressions and values. *)
+(** [Z] is Coq's version of the integers.
+ All the standard operations, like [+], are defined on it.
+
+ The type [binder] is defined as [x ::= BNamed (s: string) | BAnon]
+ where BAnon can be used if we don't want to use the variable in
+ the function.
+*)
+Inductive expr :=
+ (* Base lambda calculus *)
+ | Var (x : string)
+ | Lam (x : binder) (e : expr)
+ | App (e1 e2 : expr)
+ (* Base types and their operations *)
+ | LitInt (n: Z)
+ | Plus (e1 e2 : expr).
+
+Inductive val :=
+ | LitIntV (n: Z)
+ | LamV (x : binder) (e : expr).
+
+(* Injections into expr *)
+Definition of_val (v : val) : expr :=
+ match v with
+ | LitIntV n => LitInt n
+ | LamV x e => Lam x e
+ end.
+
+(* try to make an expr into a val *)
+Definition to_val (e : expr) : option val :=
+ match e with
+ | LitInt n => Some (LitIntV n)
+ | Lam x e => Some (LamV x e)
+ | _ => None
+ end.
+
+Lemma to_of_val v : to_val (of_val v) = Some v.
+Proof.
+ destruct v; simpl; reflexivity.
+Qed.
+
+Lemma of_to_val e v : to_val e = Some v -> of_val v = e.
+Proof.
+ destruct e; simpl; try congruence.
+ all: injection 1 as <-; simpl; reflexivity.
+Qed.
+
+(* Inj is a type class for injective functions.
+ It is defined as:
+ [Inj R S f := ∀ x y, S (f x) (f y) -> R x y]
+*)
+#[export] Instance of_val_inj : Inj (=) (=) of_val.
+Proof. by intros ?? Hv; apply (inj Some); rewrite <-!to_of_val, Hv. Qed.
+
+(* A predicate which holds true whenever an
+ expression is a value. *)
+Definition is_val (e : expr) : Prop :=
+ match e with
+ | LitInt n => True
+ | Lam x e => True
+ | _ => False
+ end.
+Lemma is_val_spec e : is_val e ↔ ∃ v, to_val e = Some v.
+Proof.
+ destruct e; simpl.
+ (* naive_solver is an automation tactic like intuition, firstorder, auto, ...
+ It is provided by the stdpp library. *)
+ all: naive_solver.
+Qed.
+
+Lemma is_val_of_val v : is_val (of_val v).
+Proof.
+ apply is_val_spec. rewrite to_of_val. eauto.
+Qed.
+
+(* A small tactic that simplifies handling values. *)
+Ltac simplify_val :=
+ repeat match goal with
+ | H: to_val (of_val ?v) = ?o |- _ => rewrite to_of_val in H
+ | H: is_val ?e |- _ => destruct (proj1 (is_val_spec e) H) as (? & ?); clear H
+ end.
+
+(* values are values *)
+Lemma is_val_val (v: val): is_val (of_val v).
+Proof.
+ destruct v; simpl; done.
+Qed.
+
+(* we tell eauto to use the lemma is_val_val *)
+#[global]
+Hint Immediate is_val_val : core.
+
+
+(** ** Operational Semantics *)
+
+(** *** Substitution *)
+Fixpoint subst (x : string) (es : expr) (e : expr) : expr :=
+ match e with
+ | LitInt n => LitInt n
+ (* The function [decide] can be used to decide propositions.
+ [decide P] is of type {P} + {¬ P}.
+ It can only be applied to propositions for which, by type class inference,
+ it can be determined that the proposition is decidable. *)
+ | Var y => if decide (x = y) then es else Var y
+ | Lam y e =>
+ Lam y $ if decide (BNamed x = y) then e else subst x es e
+ | App e1 e2 => App (subst x es e1) (subst x es e2)
+ | Plus e1 e2 => Plus (subst x es e1) (subst x es e2)
+ end.
+
+(* We lift substitution to binders. *)
+Definition subst' (mx : binder) (es : expr) : expr -> expr :=
+ match mx with BNamed x => subst x es | BAnon => id end.
+
+
+(** *** Small-Step Semantics *)
+(* We use right-to-left evaluation order,
+ which means in a binary term (e.g., e1 + e2),
+ the left side can only be reduced once the right
+ side is fully evaluated (i.e., is a value). *)
+Inductive step : expr -> expr -> Prop :=
+ | StepBeta x e e' :
+ is_val e' ->
+ step (App (Lam x e) e') (subst' x e' e)
+ | StepAppL e1 e1' e2 :
+ is_val e2 ->
+ step e1 e1' ->
+ step (App e1 e2) (App e1' e2)
+ | StepAppR e1 e2 e2' :
+ step e2 e2' ->
+ step (App e1 e2) (App e1 e2')
+ | StepPlusRed (n1 n2 n3: Z) :
+ (n1 + n2)%Z = n3 ->
+ step (Plus (LitInt n1) (LitInt n2)) (LitInt n3)
+ | StepPlusL e1 e1' e2 :
+ is_val e2 ->
+ step e1 e1' ->
+ step (Plus e1 e2) (Plus e1' e2)
+ | StepPlusR e1 e2 e2' :
+ step e2 e2' ->
+ step (Plus e1 e2) (Plus e1 e2').
+
+(* We make the tactic eauto aware of the constructors of [step].
+ Then it can automatically solve goals where we want to prove a step. *)
+#[global] Hint Constructors step : core.
+
+
+(* A term is reducible, if it can take a step. *)
+Definition reducible (e : expr) :=
+ ∃ e', step e e'.
+
+
+(** *** Big-Step Semantics *)
+Inductive big_step : expr -> val -> Prop :=
+ | bs_lit (n : Z) :
+ big_step (LitInt n) (LitIntV n)
+ | bs_lam (x : binder) (e : expr) :
+ big_step (Lam x e) (LamV x e)
+ | bs_add e1 e2 (z1 z2 : Z) :
+ big_step e1 (LitIntV z1) ->
+ big_step e2 (LitIntV z2) ->
+ big_step (Plus e1 e2) (LitIntV (z1 + z2))%Z
+ | bs_app e1 e2 x e v2 v :
+ big_step e1 (@LamV x e) ->
+ big_step e2 v2 ->
+ big_step (subst' x (of_val v2) e) v ->
+ big_step (App e1 e2) v
+ .
+#[export] Hint Constructors big_step : core.
+
+
+Lemma big_step_vals (v: val): big_step (of_val v) v.
+Proof.
+ induction v; econstructor.
+Qed.
+
+
+
+
+
+
+(*** Inversion ***)
+
+
+
+(* We might want to show the following lemma about small step semantics: *)
+Lemma val_no_step (v : val) (e : expr) :
+ step (of_val v) e -> False.
+Proof.
+ (* destructing doesn't work: the different cases don't have enough information *)
+ destruct 1.
+ - admit.
+ - admit.
+ Restart.
+ remember (of_val v) as e' eqn:Heq.
+ destruct 1.
+ - (* Aha! Coq remembered that we had a value on the left-hand sidde of the
+ step *)
+ destruct v; discriminate.
+ - destruct v; discriminate.
+ - destruct v; discriminate.
+ - destruct v; discriminate.
+ - destruct v; discriminate.
+ - destruct v; discriminate.
+ Restart.
+ (* there's a tactic that does this for us: inversion *)
+ inversion 1.
+ all: destruct v; discriminate.
+Qed.
+
+
+(* The (non-recursive) eliminator for step in Coq *)
+Lemma step_elim (P : expr -> expr -> Prop) :
+ (∀ (x : binder) (e1 e2 : expr), is_val e2 ->
+ P (App (Lam x e1) e2) (subst' x e2 e1))
+ -> (∀ e1 e1' e2 : expr, is_val e2 -> step e1 e1' ->
+ P (App e1 e2) (App e1' e2))
+ -> (∀ e1 e2 e2' : expr, step e2 e2' ->
+ P (App e1 e2) (App e1 e2'))
+ -> (∀ n1 n2 n3 : Z, (n1 + n2)%Z = n3 ->
+ P (Plus (LitInt n1) (LitInt n2)) (LitInt n3))
+ -> (∀ e1 e1' e2 : expr, is_val e2 -> step e1 e1' ->
+ P (Plus e1 e2) (Plus e1' e2))
+ -> (∀ e1 e2 e2' : expr, step e2 e2' -> P (Plus e1 e2) (Plus e1 e2'))
+
+
+ -> ∀ e e' : expr, step e e' -> P e e'.
+Proof.
+ destruct 7; eauto.
+Qed.
+
+
+(* An inversion operator for step in Coq *)
+Lemma step_inversion (P : expr -> expr -> Prop) (e e' : expr) :
+ (∀ (x : binder) (e1 e2 : expr), e = App (Lam x e1) e2 -> e' = subst' x e2 e1 ->
+ is_val e2 ->
+ P (App (Lam x e1) e2) (subst' x e2 e1))
+ -> (∀ e1 e1' e2 : expr, e = App e1 e2 -> e' = App e1' e2 ->
+ is_val e2 -> step e1 e1' ->
+ P (App e1 e2) (App e1' e2))
+ -> (∀ e1 e2 e2' : expr, e = App e1 e2 -> e' = App e1 e2' ->
+ step e2 e2' ->
+ P (App e1 e2) (App e1 e2'))
+ -> (∀ n1 n2 n3 : Z, e = Plus (LitInt n1) (LitInt n2) -> e' = LitInt n3 ->
+ (n1 + n2)%Z = n3 ->
+ P (Plus (LitInt n1) (LitInt n2)) (LitInt n3))
+ -> (∀ e1 e1' e2 : expr, e = Plus e1 e2 -> e' = Plus e1' e2 ->
+ is_val e2 -> step e1 e1' ->
+ P (Plus e1 e2) (Plus e1' e2))
+ -> (∀ e1 e2 e2' : expr, e = Plus e1 e2 -> e' = Plus e1 e2' ->
+ step e2 e2' ->
+ P (Plus e1 e2) (Plus e1 e2'))
+ -> step e e' -> P e e'.
+Proof.
+ intros H1 H2 H3 H4 H5 H6.
+ destruct 1.
+ { eapply H1. all: easy. }
+ { eapply H2. all: easy. }
+ (* All the other cases are similar. *)
+ all: eauto.
+Qed.
+
+
+(* We can use the inversion operator to show that values cannot step. *)
+Lemma val_no_step' (v : val) (e : expr) :
+ step (of_val v) e -> False.
+Proof.
+ intros H. eapply step_inversion. 7: eauto.
+ all: intros; destruct v; discriminate.
+Qed.
+
+
+
+(* The following is another kind of inversion operator, as taught in the ICL lecture. *)
+Definition step_inv (e e' : expr) : step e e' ->
+ (match e with
+ | App e1 e2 =>
+ (∃ x f, e1 = (Lam x f) ∧ e' = subst' x e2 f) ∨
+ (∃ e1', is_val e2 ∧ step e1 e1') ∨
+ (∃ e2', step e2 e2')
+ | Plus e1 e2 =>
+ (∃ n1 n2, e1 = LitInt n1 ∧ e2 = LitInt n2 ∧ LitInt (n1 + n2) = e') ∨
+ (∃ e1', is_val e2 ∧ step e1 e1') ∨
+ (∃ e2', step e2 e2')
+ | _ => False
+ end).
+Proof.
+ intros H. destruct H; naive_solver.
+Qed.
diff --git a/theories/type_systems/stlc/logrel.v b/theories/type_systems/stlc/logrel.v
index 7a9a93dcaec19ab9dff3f8bc1685675e2eedc60d..212c19ce2b2691f1b31ef0451d706cfd182e9a87 100644
--- a/theories/type_systems/stlc/logrel.v
+++ b/theories/type_systems/stlc/logrel.v
@@ -11,53 +11,55 @@ Implicit Types
(A : type).
-(** ** Definition of the logical relation. *)
-(**
- In Coq, we need to make argument why the logical relation is well-defined precise:
- This holds true in particular for the mutual recursion between the value relation and the expression relation
- (note that the value relation is defined in terms of the expression relation, and vice versa).
- We therefore define a termination measure [mut_measure] that makes sure that for each recursive call, we either
- - decrease the size of the type
- - or switch from the expression case to the value case.
-
- We use the Equations package to define the logical relation, as it's tedious to make the termination
- argument work with Coq's built-in support for recursive functions---but under the hood, Equations also
- just encodes it as a Coq Fixpoint.
+(* *** Definition of the logical relation. *)
+(* In Coq, we need to make argument why the logical relation is well-defined
+ precise:
+ In particular, we need to show that the mutual recursion between the value
+ relation and the expression relation, which are defined in terms of each
+ other, terminates. We therefore define a termination measure [mut_measure]
+ that makes sure that for each recursive call, we either decrease the size of
+ the type or switch from the expression case to the value case.
+
+ We use the Equations package to define the logical relation, as it's tedious
+ to make the termination argument work with Coq's built-in support for
+ recursive functions---but under the hood, Equations also just encodes it as
+ a Coq Fixpoint.
*)
-Inductive type_case : Set :=
- | expr_case | val_case.
+Inductive val_or_expr : Type :=
+| inj_val : val → val_or_expr
+| inj_expr : expr → val_or_expr.
-(* The [type_size] function just structurally descends, essentially taking the size of the "type tree". *)
+(* The [type_size] function essentially computes the size of the "type tree". *)
Equations type_size (t : type) : nat :=
type_size Int := 1;
type_size (Fun A B) := type_size A + type_size B + 1.
(* The definition of the expression relation uses the value relation -- therefore, it needs to be larger, and we add [1]. *)
-Equations mut_measure (c : type_case) (t : type) : nat :=
- mut_measure expr_case t := 1 + type_size t;
- mut_measure val_case t := type_size t.
+Equations mut_measure (ve : val_or_expr) (t : type) : nat :=
+ mut_measure (inj_val _) t := type_size t;
+ mut_measure (inj_expr _) t := 1 + type_size t.
-Definition sem_type : Type := val → Prop.
-(** The main definition of the logical relation.
- To handle the mutual recursion, both the expression and value relation are handled by one definition, with [type_case] determining the case.
+(* The main definition of the logical relation.
+ To handle the mutual recursion, both the expression and value relation are
+ handled by one definition, with [val_or_expr] determining the case.
- The argument [v] has a type that is determined by the case of the relation (so the whole thing is dependently-typed).
- The [by wf ..] part tells Equations to use [mut_measure] for the well-formedness argument.
+ The [by wf ..] part tells Equations to use [mut_measure] for the
+ well-formedness argument.
*)
-Equations type_interp (c : type_case) (t : type) (v : match c with val_case => val | expr_case => expr end) : Prop by wf (mut_measure c t) := {
- type_interp val_case Int v =>
+Equations type_interp (ve : val_or_expr) (t : type) : Prop by wf (mut_measure ve t) := {
+ type_interp (inj_val v) Int =>
∃ z : Z, v = z ;
- type_interp val_case (A → B) v =>
+ type_interp (inj_val v) (A → B) =>
∃ x e, v = @LamV x e ∧ closed (x :b: nil) e ∧
∀ v',
- type_interp val_case A v' →
- type_interp expr_case B (subst' x v' e);
+ type_interp (inj_val v') A →
+ type_interp (inj_expr (subst' x v' e)) B;
- type_interp expr_case t e =>
- ∃ v, big_step e v ∧ type_interp val_case t v
+ type_interp (inj_expr e) t =>
+ ∃ v, big_step e v ∧ type_interp (inj_val v) t
}.
Next Obligation.
- (** [simp] is a tactic provided by [Equations]. It rewrites with the defining equations of the definition.
+ (* [simp] is a tactic provided by [Equations]. It rewrites with the defining equations of the definition.
[simpl]/[cbn] will NOT unfold definitions made with Equations.
*)
repeat simp mut_measure; simp type_size; lia.
@@ -67,34 +69,21 @@ Next Obligation.
destruct A; repeat simp mut_measure; repeat simp type_size; lia.
Qed.
-(** We derive the expression/value relation. *)
-Definition sem_val_rel t v := type_interp val_case t v.
-Definition sem_expr_rel t e := type_interp expr_case t e.
+(* We derive the expression/value relation.
+ Note that these are [Notation], not [Definition]: we are not introducing new
+ terms here that have to be unfolded, we are merely introducing a notational
+ short-hand. This means tactics like [simp] can still "see" the underlying
+ [type_interp], which makes proofs a lot more pleasant. *)
+Notation sem_val_rel t v := (type_interp (inj_val v) t).
+Notation sem_expr_rel t e := (type_interp (inj_expr e) t).
-Notation 𝒱 := sem_val_rel.
-Notation ℰ := sem_expr_rel.
+Notation 𝒱 t v := (sem_val_rel t v).
+Notation ℰ t v := (sem_expr_rel t v).
-Lemma val_rel_closed v A:
- 𝒱 A v → closed [] v.
-Proof.
- induction A; simp type_interp.
- - intros [z ->]. done.
- - intros (x & e & -> & Hcl & _). done.
-Qed.
-Lemma sem_expr_rel_of_val A v:
- ℰ A v → 𝒱 A v.
-Proof.
- simp type_interp.
- intros (v' & ->%big_step_inv_vals & Hv').
- apply Hv'.
-Qed.
-
-(** Interpret a type *)
-Definition interp_type A : sem_type := 𝒱 A.
-
-(** *** Semantic typing of contexts *)
-(** Substitutions map to expressions -- this is so that we can more easily reuse notions like closedness *)
+(* *** Semantic typing of contexts *)
+(* Substitutions map to expressions (as opposed to values)) -- this is so that
+ we can more easily reuse notions like closedness *)
Implicit Types
(θ : gmap string expr).
@@ -107,8 +96,54 @@ Inductive sem_context_rel : typing_context → (gmap string expr) → Prop :=
Notation 𝒢 := sem_context_rel.
+(* The semantic typing judgement. Note that we require e to be closed under Γ.
+ This is not strictly required for the semantic soundness proof, but does
+ make it more elegant. *)
+Definition sem_typed Γ e A :=
+ closed (elements (dom Γ)) e ∧
+ ∀ θ, 𝒢 Γ θ → ℰ A (subst_map θ e).
+Notation "Γ ⊨ e : A" := (sem_typed Γ e A) (at level 74, e, A at next level).
+
+
+(* We start by proving a couple of helper lemmas that will be useful later. *)
+
+Lemma sem_expr_rel_of_val A v:
+ ℰ A v → 𝒱 A v.
+Proof.
+ simp type_interp.
+ intros (v' & ->%big_step_inv_vals & Hv').
+ apply Hv'.
+Qed.
+Lemma val_inclusion A v:
+ 𝒱 A v → ℰ A v.
+Proof.
+ intros H. simp type_interp. eauto using big_step_vals.
+Qed.
+
+
+
+Lemma val_rel_closed v A:
+ 𝒱 A v → closed [] v.
+Proof.
+ induction A; simp type_interp.
+ - intros [z ->]. done.
+ - intros (x & e & -> & Hcl & _). done.
+Qed.
+Lemma sem_context_rel_closed Γ θ:
+ 𝒢 Γ θ → subst_closed [] θ.
+Proof.
+ induction 1; rewrite /subst_closed.
+ - naive_solver.
+ - intros y e. rewrite lookup_insert_Some.
+ intros [[-> <-]|[Hne Hlook]].
+ + by eapply val_rel_closed.
+ + eapply IHsem_context_rel; last done.
+Qed.
+
+
+(* This is essentially an inversion lemma for 𝒢 *)
Lemma sem_context_rel_vals Γ θ x A :
- sem_context_rel Γ θ →
+ 𝒢 Γ θ →
Γ !! x = Some A →
∃ e v, θ !! x = Some e ∧ to_val e = Some v ∧ 𝒱 A v.
Proof.
@@ -122,33 +157,19 @@ Proof.
split; first done. done.
Qed.
-Lemma sem_context_rel_subset Γ θ :
- 𝒢 Γ θ → dom Γ ⊆ dom θ.
-Proof.
- intros Hctx. apply elem_of_subseteq. intros x (A & Hlook)%elem_of_dom.
- eapply sem_context_rel_vals in Hlook as (e & v & Hlook & Heq & Hval); last done.
- eapply elem_of_dom; eauto.
-Qed.
-
-Lemma sem_context_rel_closed Γ θ:
- 𝒢 Γ θ → subst_closed [] θ.
+Lemma sem_context_rel_dom Γ θ :
+ 𝒢 Γ θ → dom Γ = dom θ.
Proof.
- induction 1; rewrite /subst_closed.
- - naive_solver.
- - intros y e. rewrite lookup_insert_Some.
- intros [[-> <-]|[Hne Hlook]].
- + by eapply val_rel_closed.
- + eapply IHsem_context_rel; last done.
+ induction 1.
+ - by rewrite !dom_empty.
+ - rewrite !dom_insert. congruence.
Qed.
-(** The semantic typing judgment *)
-Definition sem_typed Γ e A :=
- ∀ θ, 𝒢 Γ θ → ℰ A (subst_map θ e).
-Notation "Γ ⊨ e : A" := (sem_typed Γ e A) (at level 74, e, A at next level).
-(** *** Compatibility lemmas *)
+(* *** Compatibility lemmas *)
Lemma compat_int Γ z : Γ ⊨ (LitInt z) : Int.
Proof.
+ split; first done.
intros θ _. simp type_interp.
exists z. split; simpl.
- constructor.
@@ -159,7 +180,9 @@ Lemma compat_var Γ x A :
Γ !! x = Some A →
Γ ⊨ (Var x) : A.
Proof.
- intros Hx θ Hctx; simpl.
+ intros Hx. split.
+ { eapply bool_decide_pack, elem_of_elements, elem_of_dom_2, Hx. }
+ intros θ Hctx; simpl.
eapply sem_context_rel_vals in Hx as (e & v & He & Heq & Hv); last done.
rewrite He. simp type_interp. exists v. split; last done.
rewrite -(of_to_val _ _ Heq).
@@ -171,7 +194,9 @@ Lemma compat_app Γ e1 e2 A B :
Γ ⊨ e2 : A →
Γ ⊨ (e1 e2) : B.
Proof.
- intros Hfun Harg θ Hctx; simpl.
+ intros [Hfuncl Hfun] [Hargcl Harg]. split.
+ { simpl. eauto. }
+ intros θ Hctx; simpl.
specialize (Hfun _ Hctx). simp type_interp in Hfun. destruct Hfun as (v1 & Hbs1 & Hv1).
simp type_interp in Hv1. destruct Hv1 as (x & e & -> & Hcl & Hv1).
specialize (Harg _ Hctx). simp type_interp in Harg.
@@ -186,34 +211,37 @@ Proof.
Qed.
-(** Lambdas need to be closed by the context *)
-Lemma compat_lam_named Γ x e A B X :
- closed X e →
- (X ⊆ elements (dom (<[x := A]> Γ))) →
+(* Compatibility for [lam] unfortunately needs a very technical helper lemma. *)
+Lemma lam_closed Γ θ (x : string) A e :
+ closed (elements (dom (<[x:=A]> Γ))) e →
+ 𝒢 Γ θ →
+ closed [] (Lam x (subst_map (delete x θ) e)).
+Proof.
+ intros Hcl Hctxt.
+ eapply subst_map_closed'_2.
+ - eapply closed_weaken; first done.
+ rewrite dom_delete dom_insert (sem_context_rel_dom Γ θ) //.
+ (* The [set_solver] tactic is great for solving goals involving set
+ inclusion and union. However, when set difference is involved, it can't
+ always solve the goal -- we need to help it by doing a case distinction on
+ whether the element we are considering is [x] or not. *)
+ intros y. destruct (decide (x = y)); set_solver.
+ - eapply subst_closed_weaken, sem_context_rel_closed; last done.
+ + set_solver.
+ + apply map_delete_subseteq.
+Qed.
+Lemma compat_lam Γ x e A B :
(<[ x := A ]> Γ) ⊨ e : B →
Γ ⊨ (Lam (BNamed x) e) : (A → B).
Proof.
- intros Hcl Hsub Hbody θ Hctxt. simpl.
- simp type_interp.
- assert (body_closed : closed [x] (subst_map (delete x θ) e)).
- { (* this proof is slightly technical, sadly *)
- eapply subst_map_closed'; first done.
- intros y Hel. destruct (decide (x = y)); first subst.
- - rewrite lookup_delete; set_solver.
- - rewrite lookup_delete_ne //=.
- eapply Hsub, elem_of_elements, elem_of_dom in Hel as [C Hlook].
- rewrite lookup_insert_ne //= in Hlook.
- eapply sem_context_rel_vals in Hlook as (e' & v & Hlook' & Hev & Hval); last done.
- rewrite Hlook'. eapply closed_weaken_nil.
- eapply of_to_val in Hev as <-.
- by eapply val_rel_closed.
- }
- exists ((λ: x, subst_map (delete x θ) e))%V.
+ intros [Hbodycl Hbody]. split.
+ { simpl. eapply closed_weaken; first eassumption. set_solver. }
+ intros θ Hctxt. simpl. simp type_interp.
+ eexists.
split; first by eauto.
simp type_interp.
- eexists (BNamed x), _. split; first reflexivity.
- split; first done.
-
+ eexists x, _. split; first reflexivity.
+ split; first by eapply lam_closed.
intros v' Hv'.
specialize (Hbody (<[ x := of_val v']> θ)).
simpl. rewrite subst_subst_map; last by eapply sem_context_rel_closed.
@@ -226,7 +254,9 @@ Lemma compat_add Γ e1 e2 :
Γ ⊨ e2 : Int →
Γ ⊨ (e1 + e2) : Int.
Proof.
- intros He1 He2 θ Hctx. simpl.
+ intros [Hcl1 He1] [Hcl2 He2]. split.
+ { simpl. eauto. }
+ intros θ Hctx.
simp type_interp.
specialize (He1 _ Hctx). specialize (He2 _ Hctx).
simp type_interp in He1. simp type_interp in He2.
@@ -247,11 +277,7 @@ Lemma sem_soundness Γ e A :
Proof.
induction 1 as [ | Γ x e A B Hsyn IH | | | ].
- by apply compat_var.
- - set (X := elements (dom (<[x := A]>Γ))).
- specialize (syn_typed_closed _ _ _ X Hsyn) as Hcl.
- eapply compat_lam_named; last done.
- + apply Hcl. apply elem_of_elements.
- + done.
+ - by apply compat_lam.
- apply compat_int.
- by eapply compat_app.
- by apply compat_add.
@@ -261,7 +287,7 @@ Lemma termination e A :
(∅ ⊢ e : A)%ty →
∃ v, big_step e v.
Proof.
- intros Hsem%sem_soundness.
+ intros [Hsemcl Hsem]%sem_soundness.
specialize (Hsem ∅).
simp type_interp in Hsem.
rewrite subst_map_empty in Hsem.
diff --git a/theories/type_systems/stlc/notation.v b/theories/type_systems/stlc/notation.v
index 4da6e39d40df3f45b500ff150a4f2986bc099fd6..5c5a0950c8dfdbaef62d6bff1346f3e958f2a2fd 100644
--- a/theories/type_systems/stlc/notation.v
+++ b/theories/type_systems/stlc/notation.v
@@ -41,8 +41,9 @@ Notation "λ: x y .. z , e" := (LamV x%binder (Lam y%binder .. (Lam z%binder e%E
format "'[' 'λ:' x y .. z , '/ ' e ']'") : val_scope.
Notation "'let:' x := e1 'in' e2" := (Lam x%binder e2%E e1%E)
- (at level 200, x at level 1, e1, e2 at level 200,
- format "'[' 'let:' x := '[' e1 ']' 'in' '/' e2 ']'") : expr_scope.
+ (only parsing, at level 200, x at level 1, e1, e2 at level 200
+ (*, format "'[' 'let:' x := '[' e1 ']' 'in' '/' e2 ']'" *)
+ ) : expr_scope.
Notation "e1 ;; e2" := (Lam BAnon e2%E e1%E)
(at level 100, e2 at level 200,
format "'[' '[hv' '[' e1 ']' ;; ']' '/' e2 ']'") : expr_scope.
diff --git a/theories/type_systems/stlc/parallel_subst.v b/theories/type_systems/stlc/parallel_subst.v
index ec96c0d1a72cce16b2a86f09b94a879e7e0c054d..013b75a1f80d7c1b8793c5d1c4409009044852c7 100644
--- a/theories/type_systems/stlc/parallel_subst.v
+++ b/theories/type_systems/stlc/parallel_subst.v
@@ -22,6 +22,8 @@ Proof.
destruct x; simpl; [done | by rewrite !delete_empty..].
Qed.
+
+
Lemma subst_map_closed X e xs :
closed X e →
(∀ x : string, x ∈ dom xs → x ∉ X) →
@@ -77,6 +79,13 @@ Proof.
intros Hsub Hclosed2 x e Hl. eapply Hclosed2, map_subseteq_spec; done.
Qed.
+Lemma subst_closed_weaken X Y map1 map2 :
+ Y ⊆ X → map1 ⊆ map2 → subst_closed Y map2 → subst_closed X map1.
+Proof.
+ intros Hsub1 Hsub2 Hclosed2 x e Hl.
+ eapply closed_weaken. 1:eapply Hclosed2, map_subseteq_spec; done. done.
+Qed.
+
(** Lemma about the interaction with "normal" substitution. *)
Lemma subst_subst_map x es map e :
subst_closed [] map →
@@ -165,3 +174,16 @@ Proof.
- auto.
- rewrite !andb_True. intros [H1 H2] Hcl. split; eauto.
Qed.
+
+Lemma subst_map_closed'_2 X Θ e:
+ closed (X ++ (elements (dom Θ))) e ->
+ subst_closed X Θ ->
+ closed X (subst_map Θ e).
+Proof.
+ intros Hcl Hsubst.
+ eapply subst_map_closed'; first eassumption.
+ intros x Hx.
+ destruct (Θ !! x) as [e'|] eqn:Heq.
+ - eauto.
+ - by eapply elem_of_app in Hx as [H|H%elem_of_elements%not_elem_of_dom].
+Qed.
diff --git a/theories/type_systems/stlc_extended/bigstep.v b/theories/type_systems/stlc_extended/bigstep.v
index 76557a32bca587d3f7b22e38229731026fde1ede..372f3d43547615519d0169274e8962f8eecf65f0 100644
--- a/theories/type_systems/stlc_extended/bigstep.v
+++ b/theories/type_systems/stlc_extended/bigstep.v
@@ -1,30 +1,31 @@
From stdpp Require Import gmap base relations.
From iris Require Import prelude.
-From semantics.ts.stlc_extended Require Import lang notation types.
+From semantics.ts.stlc_extended Require Import lang notation.
(** * Big-step semantics *)
Implicit Types
- (Γ : typing_context)
(v : val)
- (e : expr)
- (A : type).
+ (e : expr).
Inductive big_step : expr → val → Prop :=
- | bs_lit (l : base_lit) :
- big_step (Lit l) (LitV l)
+ | bs_lit (n : Z) :
+ big_step (LitInt n) (LitIntV n)
| bs_lam (x : binder) (e : expr) :
big_step (λ: x, e)%E (λ: x, e)%V
+ | bs_add e1 e2 (z1 z2 : Z) :
+ big_step e1 (LitIntV z1) →
+ big_step e2 (LitIntV z2) →
+ big_step (Plus e1 e2) (LitIntV (z1 + z2))%Z
| bs_app e1 e2 x e v2 v :
big_step e1 (LamV x e) →
big_step e2 v2 →
big_step (subst' x (of_val v2) e) v →
big_step (App e1 e2) v
- (* FIXME : extend the big-step semantics *)
+
+(* TODO : extend the big-step semantics *)
.
#[export] Hint Constructors big_step : core.
-#[export] Hint Constructors base_step : core.
-#[export] Hint Constructors contextual_step : core.
Lemma big_step_of_val e v :
e = of_val v →
@@ -32,9 +33,11 @@ Lemma big_step_of_val e v :
Proof.
intros ->.
induction v; simpl; eauto.
- (* FIXME : this should be fixed once you have added the right semantics *)
+
+(* TODO : this should be fixed once you have added the right semantics *)
Admitted.
+
Lemma big_step_val v v' :
big_step (of_val v) v' → v' = v.
Proof.
diff --git a/theories/type_systems/stlc_extended/ctxstep.v b/theories/type_systems/stlc_extended/ctxstep.v
new file mode 100644
index 0000000000000000000000000000000000000000..f2bef44def6ea2a8f73e790534b48b27449fe633
--- /dev/null
+++ b/theories/type_systems/stlc_extended/ctxstep.v
@@ -0,0 +1,180 @@
+From semantics.ts.stlc_extended Require Export lang.
+
+(** The stepping relation *)
+
+Inductive base_step : expr → expr → Prop :=
+ | BetaS x e1 e2 e' :
+ is_val e2 →
+ e' = subst' x e2 e1 →
+ base_step (App (Lam x e1) e2) e'
+ | PlusS e1 e2 (n1 n2 n3 : Z):
+ e1 = (LitInt n1) →
+ e2 = (LitInt n2) →
+ (n1 + n2)%Z = n3 →
+ base_step (Plus e1 e2) (LitInt n3)
+ (* TODO: extend the definition *)
+.
+
+#[export] Hint Constructors base_step : core.
+
+(** We define evaluation contexts *)
+Inductive ectx :=
+ | HoleCtx
+ | AppLCtx (K: ectx) (v2 : val)
+ | AppRCtx (e1 : expr) (K: ectx)
+ | PlusLCtx (K: ectx) (v2 : val)
+ | PlusRCtx (e1 : expr) (K: ectx)
+ (* TODO: extend the definition *)
+.
+
+Fixpoint fill (K : ectx) (e : expr) : expr :=
+ match K with
+ | HoleCtx => e
+ | AppLCtx K v2 => App (fill K e) (of_val v2)
+ | AppRCtx e1 K => App e1 (fill K e)
+ | PlusLCtx K v2 => Plus (fill K e) (of_val v2)
+ | PlusRCtx e1 K => Plus e1 (fill K e)
+ (* TODO: extend the definition *)
+ end.
+
+Fixpoint comp_ectx (K: ectx) (K' : ectx) : ectx :=
+ match K with
+ | HoleCtx => K'
+ | AppLCtx K v2 => AppLCtx (comp_ectx K K') v2
+ | AppRCtx e1 K => AppRCtx e1 (comp_ectx K K')
+ | PlusLCtx K v2 => PlusLCtx (comp_ectx K K') v2
+ | PlusRCtx e1 K => PlusRCtx e1 (comp_ectx K K')
+ (* TODO: extend the definition *)
+ end.
+
+(** Contextual steps *)
+Inductive contextual_step (e1 : expr) (e2 : expr) : Prop :=
+ Ectx_step K e1' e2' :
+ e1 = fill K e1' → e2 = fill K e2' →
+ base_step e1' e2' → contextual_step e1 e2.
+
+#[export] Hint Constructors contextual_step : core.
+
+Definition reducible (e : expr) :=
+ ∃ e', contextual_step e e'.
+
+Definition empty_ectx := HoleCtx.
+
+(** Basic properties about the language *)
+Lemma fill_empty e : fill empty_ectx e = e.
+Proof. done. Qed.
+
+Lemma fill_comp (K1 K2 : ectx) e : fill K1 (fill K2 e) = fill (comp_ectx K1 K2) e.
+Proof. induction K1; simpl; congruence. Qed.
+
+Lemma base_contextual_step e1 e2 :
+ base_step e1 e2 → contextual_step e1 e2.
+Proof. apply Ectx_step with empty_ectx; by rewrite ?fill_empty. Qed.
+
+Lemma fill_contextual_step K e1 e2 :
+ contextual_step e1 e2 → contextual_step (fill K e1) (fill K e2).
+Proof.
+ destruct 1 as [K' e1' e2' -> ->].
+ rewrite !fill_comp. by econstructor.
+Qed.
+
+(** We derive a few lemmas about contextual steps:
+ these essentially provide rules for structural lifting
+ akin to the structural semantics.
+ *)
+Lemma contextual_step_app_l e1 e1' e2:
+ is_val e2 →
+ contextual_step e1 e1' →
+ contextual_step (App e1 e2) (App e1' e2).
+Proof.
+ intros [v <-%of_to_val]%is_val_spec Hcontextual.
+ by eapply (fill_contextual_step (AppLCtx HoleCtx v)).
+Qed.
+
+Lemma contextual_step_app_r e1 e2 e2':
+ contextual_step e2 e2' →
+ contextual_step (App e1 e2) (App e1 e2').
+Proof.
+ intros Hcontextual.
+ by eapply (fill_contextual_step (AppRCtx e1 HoleCtx)).
+Qed.
+
+Lemma contextual_step_plus_l e1 e1' e2:
+ is_val e2 →
+ contextual_step e1 e1' →
+ contextual_step (Plus e1 e2) (Plus e1' e2).
+Proof.
+ intros [v <-%of_to_val]%is_val_spec Hcontextual.
+ by eapply (fill_contextual_step (PlusLCtx HoleCtx v)).
+Qed.
+
+Lemma contextual_step_plus_r e1 e2 e2':
+ contextual_step e2 e2' →
+ contextual_step (Plus e1 e2) (Plus e1 e2').
+Proof.
+ intros Hcontextual.
+ by eapply (fill_contextual_step (PlusRCtx e1 HoleCtx)).
+Qed.
+
+Lemma contextual_step_pair_l e1 e1' e2:
+ is_val e2 →
+ contextual_step e1 e1' →
+ contextual_step (Pair e1 e2) (Pair e1' e2).
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+
+Lemma contextual_step_pair_r e1 e2 e2':
+ contextual_step e2 e2' →
+ contextual_step (Pair e1 e2) (Pair e1 e2').
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+
+Lemma contextual_step_fst e e':
+ contextual_step e e' →
+ contextual_step (Fst e) (Fst e').
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+
+Lemma contextual_step_snd e e':
+ contextual_step e e' →
+ contextual_step (Snd e) (Snd e').
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+
+Lemma contextual_step_injl e e':
+ contextual_step e e' →
+ contextual_step (InjL e) (InjL e').
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+
+Lemma contextual_step_injr e e':
+ contextual_step e e' →
+ contextual_step (InjR e) (InjR e').
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+
+Lemma contextual_step_case e e' e1 e2:
+ contextual_step e e' →
+ contextual_step (Case e e1 e2) (Case e' e1 e2).
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+
+#[global]
+Hint Resolve
+ contextual_step_app_l contextual_step_app_r contextual_step_plus_l contextual_step_plus_r
+ contextual_step_case contextual_step_fst contextual_step_injl contextual_step_injr
+ contextual_step_pair_l contextual_step_pair_r contextual_step_snd : core.
diff --git a/theories/type_systems/stlc_extended/lang.v b/theories/type_systems/stlc_extended/lang.v
index 5f439a7bb803693c1ac78ca9815a4558afae65ee..1f82aefd5714d6ff0441f53774ee2e60b0b00481 100644
--- a/theories/type_systems/stlc_extended/lang.v
+++ b/theories/type_systems/stlc_extended/lang.v
@@ -7,21 +7,14 @@ Declare Scope val_scope.
Delimit Scope expr_scope with E.
Delimit Scope val_scope with V.
-(** Expressions and vals. *)
-Inductive base_lit : Set :=
- | LitInt (n : Z).
-Inductive bin_op : Set :=
- | PlusOp | MinusOp | MultOp (* Arithmetic *)
-.
-
Inductive expr :=
- | Lit (l : base_lit)
(* Base lambda calculus *)
| Var (x : string)
| Lam (x : binder) (e : expr)
| App (e1 e2 : expr)
(* Base types and their operations *)
- | BinOp (op : bin_op) (e1 e2 : expr)
+ | LitInt (n: Z)
+ | Plus (e1 e2 : expr)
(* Products *)
| Pair (e1 e2 : expr)
| Fst (e : expr)
@@ -34,7 +27,7 @@ Inductive expr :=
Bind Scope expr_scope with expr.
Inductive val :=
- | LitV (l : base_lit)
+ | LitIntV (n: Z)
| LamV (x : binder) (e : expr)
| PairV (v1 v2 : val)
| InjLV (v : val)
@@ -45,7 +38,7 @@ Bind Scope val_scope with val.
Fixpoint of_val (v : val) : expr :=
match v with
- | LitV l => Lit l
+ | LitIntV n => LitInt n
| LamV x e => Lam x e
| PairV v1 v2 => Pair (of_val v1) (of_val v2)
| InjLV v => InjL (of_val v)
@@ -54,7 +47,7 @@ Fixpoint of_val (v : val) : expr :=
Fixpoint to_val (e : expr) : option val :=
match e with
- | Lit l => Some $ LitV l
+ | LitInt n => Some $ LitIntV n
| Lam x e => Some (LamV x e)
| Pair e1 e2 =>
to_val e1 ≫= (λ v1, to_val e2 ≫= (λ v2, Some $ PairV v1 v2))
@@ -80,7 +73,7 @@ Proof. by intros ?? Hv; apply (inj Some); rewrite <-!to_of_val, Hv. Qed.
(** structural computational version *)
Fixpoint is_val (e : expr) : Prop :=
match e with
- | Lit l => True
+ | LitInt l => True
| Lam x e => True
| Pair e1 e2 => is_val e1 ∧ is_val e2
| InjL e => is_val e
@@ -89,7 +82,7 @@ Fixpoint is_val (e : expr) : Prop :=
end.
Lemma is_val_spec e : is_val e ↔ ∃ v, to_val e = Some v.
Proof.
- induction e as [ | | ? e IH | e1 IH1 e2 IH2 | ? e1 IH1 e2 IH2 | e1 IH1 e2 IH2 | e IH | e IH | e IH | e IH | e1 IH1 e2 IH2 e3 IH3];
+ induction e as [ | ? e IH | e1 IH1 e2 IH2 | | e1 IH1 e2 IH2 | e1 IH1 e2 IH2 | e IH | e IH | e IH | e IH | e1 IH1 e2 IH2 e3 IH3];
simpl; (split; [ | intros (v & Heq)]); simplify_option_eq; try done; eauto.
- rewrite IH1, IH2. intros [(v1 & ->) (v2 & ->)]. eauto.
- rewrite IH1, IH2. eauto.
@@ -109,25 +102,15 @@ Ltac simplify_val :=
Lemma is_val_of_val v : is_val (of_val v).
Proof. apply is_val_spec. rewrite to_of_val. eauto. Qed.
-(** Literals and our operators have decidable equality:
- this means we can compute whether two of them are equal.
- This is expressed via stdpp's [EqDecision].
- *)
-Global Instance base_lit_eq_dec : EqDecision base_lit.
-Proof. solve_decision. Defined.
-Global Instance bin_op_eq_dec : EqDecision bin_op.
-Proof. solve_decision. Defined.
-
-
(** Substitution *)
Fixpoint subst (x : string) (es : expr) (e : expr) : expr :=
match e with
- | Lit _ => e
+ | LitInt _ => e
| Var y => if decide (x = y) then es else Var y
| Lam y e =>
Lam y $ if decide (BNamed x = y) then e else subst x es e
| App e1 e2 => App (subst x es e1) (subst x es e2)
- | BinOp op e1 e2 => BinOp op (subst x es e1) (subst x es e2)
+ | Plus e1 e2 => Plus (subst x es e1) (subst x es e2)
| Pair e1 e2 => Pair (subst x es e1) (subst x es e2)
| Fst e => Fst (subst x es e)
| Snd e => Snd (subst x es e)
@@ -139,88 +122,15 @@ Fixpoint subst (x : string) (es : expr) (e : expr) : expr :=
Definition subst' (mx : binder) (es : expr) : expr → expr :=
match mx with BNamed x => subst x es | BAnon => id end.
-(** The stepping relation *)
-Definition bin_op_eval_int (op : bin_op) (n1 n2 : Z) : option base_lit :=
- match op with
- | PlusOp => Some $ LitInt (n1 + n2)
- | MinusOp => Some $ LitInt (n1 - n2)
- | MultOp => Some $ LitInt (n1 * n2)
- end%Z.
-
-Definition bin_op_eval (op : bin_op) (v1 v2 : val) : option val :=
- match v1, v2 with
- | LitV (LitInt n1), LitV (LitInt n2) => LitV <$> bin_op_eval_int op n1 n2
- | _, _ => None
- end.
-
-Inductive base_step : expr → expr → Prop :=
- | BetaS x e1 e2 e' :
- is_val e2 →
- e' = subst' x e2 e1 →
- base_step (App (Lam x e1) e2) e'
- (* FIXME: extend the definition *)
-.
-
-(** We define evaluation contexts *)
-Inductive ectx :=
- | HoleCtx
- | AppLCtx (K: ectx) (v2 : val)
- | AppRCtx (e1 : expr) (K: ectx)
- (* FIXME: extend the definition *)
-.
-
-Fixpoint fill (K : ectx) (e : expr) : expr :=
- match K with
- | HoleCtx => e
- | AppLCtx K v2 => App (fill K e) (of_val v2)
- | AppRCtx e1 K => App e1 (fill K e)
- (* FIXME: extend the definition *)
- end.
-
-Fixpoint comp_ectx (K: ectx) (K' : ectx) : ectx :=
- match K with
- | HoleCtx => K'
- | AppLCtx K v2 => AppLCtx (comp_ectx K K') v2
- | AppRCtx e1 K => AppRCtx e1 (comp_ectx K K')
- (* FIXME: extend the definition *)
- end.
-
-(** Contextual steps *)
-Inductive contextual_step (e1 : expr) (e2 : expr) : Prop :=
- Ectx_step K e1' e2' :
- e1 = fill K e1' → e2 = fill K e2' →
- base_step e1' e2' → contextual_step e1 e2.
-
-Definition reducible (e : expr) :=
- ∃ e', contextual_step e e'.
-
-Definition empty_ectx := HoleCtx.
-
-(** Basic properties about the language *)
-Lemma fill_empty e : fill empty_ectx e = e.
-Proof. done. Qed.
-
-Lemma fill_comp (K1 K2 : ectx) e : fill K1 (fill K2 e) = fill (comp_ectx K1 K2) e.
-Proof. induction K1; simpl; congruence. Qed.
-
-Lemma base_contextual_step e1 e2 :
- base_step e1 e2 → contextual_step e1 e2.
-Proof. apply Ectx_step with empty_ectx; by rewrite ?fill_empty. Qed.
-
-Lemma fill_contextual_step K e1 e2 :
- contextual_step e1 e2 → contextual_step (fill K e1) (fill K e2).
-Proof.
- destruct 1 as [K' e1' e2' -> ->].
- rewrite !fill_comp. by econstructor.
-Qed.
+(** Closed terms **)
Fixpoint is_closed (X : list string) (e : expr) : bool :=
match e with
| Var x => bool_decide (x ∈ X)
| Lam x e => is_closed (x :b: X) e
- | Lit _ => true
+ | LitInt _ => true
| Fst e | Snd e | InjL e | InjR e => is_closed X e
- | App e1 e2 | BinOp _ e1 e2 | Pair e1 e2 => is_closed X e1 && is_closed X e2
+ | App e1 e2 | Plus e1 e2 | Pair e1 e2 => is_closed X e1 && is_closed X e2
| Case e0 e1 e2 =>
is_closed X e0 && is_closed X e1 && is_closed X e2
end.
@@ -263,104 +173,3 @@ Lemma subst_is_closed_nil e x es : is_closed [] e → subst x es e = e.
Proof. intros. apply subst_is_closed with []; set_solver. Qed.
Lemma subst'_is_closed_nil e x es : is_closed [] e → subst' x es e = e.
Proof. intros. destruct x as [ | x]. { done. } by apply subst_is_closed_nil. Qed.
-
-(** We derive a few lemmas about contextual steps:
- these essentially provide rules for structural lifting
- akin to the structural semantics.
- *)
-Lemma contextual_step_app_l e1 e1' e2:
- is_val e2 →
- contextual_step e1 e1' →
- contextual_step (App e1 e2) (App e1' e2).
-Proof.
- intros [v <-%of_to_val]%is_val_spec Hcontextual.
- by eapply (fill_contextual_step (AppLCtx HoleCtx v)).
-Qed.
-
-Lemma contextual_step_app_r e1 e2 e2':
- contextual_step e2 e2' →
- contextual_step (App e1 e2) (App e1 e2').
-Proof.
- intros Hcontextual.
- by eapply (fill_contextual_step (AppRCtx e1 HoleCtx)).
-Qed.
-
-Lemma contextual_step_binop_l op e1 e1' e2:
- is_val e2 →
- contextual_step e1 e1' →
- contextual_step (BinOp op e1 e2) (BinOp op e1' e2).
-Proof.
- (* FIXME *)
-(*Qed.*)
-Admitted.
-
-Lemma contextual_step_binop_r op e1 e2 e2':
- contextual_step e2 e2' →
- contextual_step (BinOp op e1 e2) (BinOp op e1 e2').
-Proof.
- (* FIXME *)
-(*Qed.*)
-Admitted.
-
-Lemma contextual_step_pair_l e1 e1' e2:
- is_val e2 →
- contextual_step e1 e1' →
- contextual_step (Pair e1 e2) (Pair e1' e2).
-Proof.
- (* FIXME *)
-(*Qed.*)
-Admitted.
-
-Lemma contextual_step_pair_r e1 e2 e2':
- contextual_step e2 e2' →
- contextual_step (Pair e1 e2) (Pair e1 e2').
-Proof.
- (* FIXME *)
-(*Qed.*)
-Admitted.
-
-Lemma contextual_step_fst e e':
- contextual_step e e' →
- contextual_step (Fst e) (Fst e').
-Proof.
- (* FIXME *)
-(*Qed.*)
-Admitted.
-
-Lemma contextual_step_snd e e':
- contextual_step e e' →
- contextual_step (Snd e) (Snd e').
-Proof.
- (* FIXME *)
-(*Qed.*)
-Admitted.
-
-Lemma contextual_step_injl e e':
- contextual_step e e' →
- contextual_step (InjL e) (InjL e').
-Proof.
- (* FIXME *)
-(*Qed.*)
-Admitted.
-
-Lemma contextual_step_injr e e':
- contextual_step e e' →
- contextual_step (InjR e) (InjR e').
-Proof.
- (* FIXME *)
-(*Qed.*)
-Admitted.
-
-Lemma contextual_step_case e e' e1 e2:
- contextual_step e e' →
- contextual_step (Case e e1 e2) (Case e' e1 e2).
-Proof.
- (* FIXME *)
-(*Qed.*)
-Admitted.
-
-#[global]
-Hint Resolve
- contextual_step_app_l contextual_step_app_r contextual_step_binop_l contextual_step_binop_r
- contextual_step_case contextual_step_fst contextual_step_injl contextual_step_injr
- contextual_step_pair_l contextual_step_pair_r contextual_step_snd : core.
diff --git a/theories/type_systems/stlc_extended/logrel.v b/theories/type_systems/stlc_extended/logrel.v
index 6e9d9a44d1f28951881621ac8ad8819e46d62b3d..7a3b32e53334398324e9483f6bd1afc1f4ee9351 100644
--- a/theories/type_systems/stlc_extended/logrel.v
+++ b/theories/type_systems/stlc_extended/logrel.v
@@ -1,8 +1,11 @@
From stdpp Require Import gmap base relations.
From iris Require Import prelude.
From semantics.ts.stlc_extended Require Import lang notation parallel_subst types bigstep.
+From semantics.ts.stlc_extended Require Import lang notation parallel_subst types bigstep.
From Equations Require Export Equations.
+
+
(** * Logical relation for the extended STLC *)
Implicit Types
@@ -11,110 +14,69 @@ Implicit Types
(e : expr)
(A : type).
-(** ** Definition of the logrel *)
-(**
- In Coq, we need to make argument why the logical relation is well-defined precise:
- This holds true in particular for the mutual recursion between the value relation and the expression relation.
- We therefore define a termination measure [mut_measure] that makes sure that for each recursive call, we either
- - decrease the size of the type
- - or switch from the expression case to the value case.
- We use the Equations package to define the logical relation, as it's tedious to make the termination
- argument work with Coq's built-in support for recursive functions.
- *)
-Inductive type_case : Set :=
- | expr_case | val_case.
+(* *** Definition of the logical relation. *)
+
+Inductive val_or_expr : Type :=
+| inj_val : val → val_or_expr
+| inj_expr : expr → val_or_expr.
Equations type_size (A : type) : nat :=
type_size Int := 1;
type_size (A → B) := type_size A + type_size B + 1;
type_size (A × B) := type_size A + type_size B + 1;
- type_size (A + B) := max (type_size A) (type_size B) + 1
-.
-
-Equations mut_measure (c : type_case) A : nat :=
- mut_measure expr_case A := 1 + type_size A;
- mut_measure val_case A := type_size A.
+ type_size (A + B) := max (type_size A) (type_size B) + 1.
+Equations mut_measure (ve : val_or_expr) (t : type) : nat :=
+ mut_measure (inj_val _) t := type_size t;
+ mut_measure (inj_expr _) t := 1 + type_size t.
-(** A semantic type consists of a value-predicate and a proof of closedness *)
-Record sem_type := mk_ST {
- sem_type_car :> val → Prop;
- sem_type_closed_val v : sem_type_car v → is_closed [] (of_val v);
- }.
-Implicit Types
- (τ : sem_type)
-.
-
-(** The logical relation *)
-Equations type_interp (c : type_case) (t : type) (v : match c with val_case => val | expr_case => expr end) : Prop by wf (mut_measure c t) := {
- type_interp val_case Int v=>
+Equations type_interp (ve : val_or_expr) (t : type) : Prop by wf (mut_measure ve t) := {
+ type_interp (inj_val v) Int =>
∃ z : Z, v = #z ;
- type_interp val_case (A × B) v =>
- (* FIXME *)
- False ;
- type_interp val_case (A + B) v =>
- (* FIXME *)
+ type_interp (inj_val v) (A × B) =>
+ (* TODO: add type interpretation *)
+ False;
+ type_interp (inj_val v) (A + B) =>
+ (* TODO: add type interpretation *)
False;
- type_interp val_case (A → B) v =>
- ∃ x e, v = LamV x e ∧ is_closed (x :b: nil) e ∧
+ type_interp (inj_val v) (A → B) =>
+ ∃ x e, v = @LamV x e ∧ closed (x :b: nil) e ∧
∀ v',
- type_interp val_case A v' →
- type_interp expr_case B (subst' x (of_val v') e);
+ type_interp (inj_val v') A →
+ type_interp (inj_expr (subst' x v' e)) B;
- type_interp expr_case t e =>
- ∃ v, big_step e v ∧ type_interp val_case t v
+ type_interp (inj_expr e) t =>
+ ∃ v, big_step e v ∧ type_interp (inj_val v) t
}.
-Next Obligation. repeat simp mut_measure; simp type_size; lia. Qed.
+Next Obligation.
+ repeat simp mut_measure; simp type_size; lia.
+Qed.
Next Obligation.
simp mut_measure. simp type_size.
destruct A; repeat simp mut_measure; repeat simp type_size; lia.
Qed.
-(* FIXME: after you have properly extended the definition of the logrel,
- you may want to uncomment this to solve the side conditions for well-formedness
- spawned by Equations. *)
-(*Next Obligation. repeat simp mut_measure; simp type_size; lia. Qed.*)
-(*Next Obligation. repeat simp mut_measure; simp type_size; lia. Qed.*)
-(*Next Obligation. repeat simp mut_measure; simp type_size; lia. Qed.*)
-(*Next Obligation. repeat simp mut_measure; simp type_size; lia. Qed.*)
-
-(** Value relation and expression relation *)
-Definition sem_val_rel A v := type_interp val_case A v.
-Definition sem_expr_rel A e := type_interp expr_case A e.
-
-Notation 𝒱 := sem_val_rel.
-Notation ℰ := sem_expr_rel.
-
-Lemma sem_expr_rel_of_val A v :
- ℰ A (of_val v) → 𝒱 A v.
-Proof.
- simp type_interp.
- intros (v' & ->%big_step_val & Hv').
- apply Hv'.
-Qed.
+(* Uncomment the following once you have amended the type interpretation to
+ solve the new obligations: *)
+(*
+Next Obligation. repeat simp mut_measure; simp type_size; lia. Qed.
+Next Obligation. repeat simp mut_measure; simp type_size; lia. Qed.
+Next Obligation. repeat simp mut_measure; simp type_size; lia. Qed.
+Next Obligation. repeat simp mut_measure; simp type_size; lia. Qed.
+*)
-Lemma val_rel_is_closed v A:
- 𝒱 A v → is_closed [] (of_val v).
-Proof.
- induction A as [ | | A IH1 B IH2 | A IH1 B IH2] in v |-*; simp type_interp.
- - intros [z ->]. done.
- - intros (x & e & -> & ? & _). done.
- - (* FIXME *) admit.
- - (* FIXME *) admit.
-(*Qed.*)
-Admitted.
-(** Interpret a syntactic type *)
-Program Definition interp_type A : sem_type := {|
- sem_type_car := 𝒱 A;
-|}.
-Next Obligation. by eapply val_rel_is_closed. Qed.
+Notation sem_val_rel t v := (type_interp (inj_val v) t).
+Notation sem_expr_rel t e := (type_interp (inj_expr e) t).
+
+Notation 𝒱 t v := (sem_val_rel t v).
+Notation ℰ t v := (sem_expr_rel t v).
-(* Semantic typing of contexts *)
+
+(* *** Semantic typing of contexts *)
Implicit Types
(θ : gmap string expr).
-(** Context relation *)
Inductive sem_context_rel : typing_context → (gmap string expr) → Prop :=
| sem_context_rel_empty : sem_context_rel ∅ ∅
| sem_context_rel_insert Γ θ v x A :
@@ -124,8 +86,53 @@ Inductive sem_context_rel : typing_context → (gmap string expr) → Prop :=
Notation 𝒢 := sem_context_rel.
-Lemma sem_context_rel_vals {Γ θ x A} :
- sem_context_rel Γ θ →
+Definition sem_typed Γ e A :=
+ closed (elements (dom Γ)) e ∧
+ ∀ θ, 𝒢 Γ θ → ℰ A (subst_map θ e).
+Notation "Γ ⊨ e : A" := (sem_typed Γ e A) (at level 74, e, A at next level).
+
+
+(* We start by proving a couple of helper lemmas that will be useful later. *)
+
+Lemma sem_expr_rel_of_val A v:
+ ℰ A v → 𝒱 A v.
+Proof.
+ simp type_interp.
+ intros (v' & ->%big_step_val & Hv').
+ apply Hv'.
+Qed.
+Lemma val_inclusion A v:
+ 𝒱 A v → ℰ A v.
+Proof.
+ intros H. simp type_interp. eauto using big_step_of_val.
+Qed.
+
+
+
+Lemma val_rel_closed v A:
+ 𝒱 A v → closed [] v.
+Proof.
+ induction A in v |-*; simp type_interp.
+ - intros [z ->]. done.
+ - intros (x & e & -> & Hcl & _). done.
+ (* TODO: exercise *)
+Admitted.
+
+Lemma sem_context_rel_closed Γ θ:
+ 𝒢 Γ θ → subst_closed [] θ.
+Proof.
+ induction 1; rewrite /subst_closed.
+ - naive_solver.
+ - intros y e. rewrite lookup_insert_Some.
+ intros [[-> <-]|[Hne Hlook]].
+ + by eapply val_rel_closed.
+ + eapply IHsem_context_rel; last done.
+Qed.
+
+
+(* This is essentially an inversion lemma for 𝒢 *)
+Lemma sem_context_rel_vals Γ θ x A :
+ 𝒢 Γ θ →
Γ !! x = Some A →
∃ e v, θ !! x = Some e ∧ to_val e = Some v ∧ 𝒱 A v.
Proof.
@@ -139,44 +146,33 @@ Proof.
split; first done. done.
Qed.
-Lemma sem_context_rel_subset Γ θ :
- 𝒢 Γ θ → dom Γ ⊆ dom θ.
+Lemma sem_context_rel_dom Γ θ :
+ 𝒢 Γ θ → dom Γ = dom θ.
Proof.
- intros Hctx. apply elem_of_subseteq. intros x (A & Hlook)%elem_of_dom.
- eapply sem_context_rel_vals in Hlook as (e & v & Hlook & Heq & Hval); last done.
- eapply elem_of_dom; eauto.
+ induction 1.
+ - by rewrite !dom_empty.
+ - rewrite !dom_insert. congruence.
Qed.
-Lemma sem_context_rel_closed Γ θ:
- 𝒢 Γ θ → subst_is_closed [] θ.
-Proof.
- induction 1 as [ | Γ θ v x A Hv Hctx IH]; rewrite /subst_is_closed.
- - naive_solver.
- - intros y e. rewrite lookup_insert_Some.
- intros [[-> <-]|[Hne Hlook]].
- + by eapply val_rel_is_closed.
- + eapply IH; last done.
-Qed.
-
-(** Semantic typing judgment *)
-Definition sem_typed Γ e A :=
- ∀ θ, 𝒢 Γ θ → ℰ A (subst_map θ e).
-Notation "Γ ⊨ e : A" := (sem_typed Γ e A) (at level 74, e, A at next level).
-(** ** Compatibility lemmas *)
-Lemma compat_int Γ z : Γ ⊨ (Lit $ LitInt z) : Int.
+(* *** Compatibility lemmas *)
+Lemma compat_int Γ z : Γ ⊨ (LitInt z) : Int.
Proof.
+ split; first done.
intros θ _. simp type_interp.
- exists #z. split. { simpl. constructor. }
- simp type_interp. eauto.
+ exists #z. split; simpl.
+ - constructor.
+ - simp type_interp. eauto.
Qed.
Lemma compat_var Γ x A :
Γ !! x = Some A →
Γ ⊨ (Var x) : A.
Proof.
- intros Hx θ Hctx; simpl.
- specialize (sem_context_rel_vals Hctx Hx) as (e & v & He & Heq & Hv).
+ intros Hx. split.
+ { eapply bool_decide_pack, elem_of_elements, elem_of_dom_2, Hx. }
+ intros θ Hctx; simpl.
+ eapply sem_context_rel_vals in Hx as (e & v & He & Heq & Hv); last done.
rewrite He. simp type_interp. exists v. split; last done.
rewrite -(of_to_val _ _ Heq).
by apply big_step_of_val.
@@ -187,12 +183,13 @@ Lemma compat_app Γ e1 e2 A B :
Γ ⊨ e2 : A →
Γ ⊨ (e1 e2) : B.
Proof.
- intros Hfun Harg θ Hctx; simpl.
-
+ intros [Hfuncl Hfun] [Hargcl Harg]. split.
+ { unfold closed. simpl. eauto. }
+ intros θ Hctx; simpl.
specialize (Hfun _ Hctx). simp type_interp in Hfun. destruct Hfun as (v1 & Hbs1 & Hv1).
- simp type_interp in Hv1. destruct Hv1 as (x & e & -> & Hv1).
+ simp type_interp in Hv1. destruct Hv1 as (x & e & -> & Hcl & Hv1).
specialize (Harg _ Hctx). simp type_interp in Harg.
- destruct Harg as (v2 & Hbs2 & Hv2).
+ destruct Harg as (v2 & Hbs2 & Hv2).
apply Hv1 in Hv2.
simp type_interp in Hv2. destruct Hv2 as (v & Hbsv & Hv).
@@ -202,78 +199,66 @@ Proof.
eauto.
Qed.
-(** Lambdas need to be closed by the context *)
-Lemma compat_lam_named Γ x e A B X :
- closed X e →
- (∀ y, y ∈ X → y ∈ dom (<[x := A]> Γ)) →
+
+(* Compatibility for [lam] unfortunately needs a very technical helper lemma. *)
+Lemma lam_closed Γ θ (x : string) A e :
+ closed (elements (dom (<[x:=A]> Γ))) e →
+ 𝒢 Γ θ →
+ closed [] (Lam x (subst_map (delete x θ) e)).
+Proof.
+ intros Hcl Hctxt.
+ eapply subst_map_closed'_2.
+ - eapply is_closed_weaken; first done.
+ rewrite dom_delete dom_insert (sem_context_rel_dom Γ θ) //.
+ intros y. destruct (decide (x = y)); set_solver.
+ - eapply subst_closed_weaken, sem_context_rel_closed; last done.
+ + set_solver.
+ + apply map_delete_subseteq.
+Qed.
+Lemma compat_lam Γ x e A B :
(<[ x := A ]> Γ) ⊨ e : B →
Γ ⊨ (Lam (BNamed x) e) : (A → B).
Proof.
- intros Hcl Hsub Hbody θ Hctxt. simpl.
- simp type_interp.
-
- exists ((λ: x, subst_map (delete x θ) e))%V.
+ intros [Hbodycl Hbody]. split.
+ { unfold closed in *. cbn in *. eapply is_closed_weaken; first eassumption.
+ set_solver. }
+ intros θ Hctxt. simpl. simp type_interp.
+ eexists.
split; first by eauto.
simp type_interp.
- eexists (BNamed x), _. split_and!; first reflexivity.
- { eapply closed_subst_weaken; [ | | apply Hcl].
- - eapply subst_is_closed_subseteq; last by eapply sem_context_rel_closed.
- apply map_delete_subseteq.
- - intros y Hy%Hsub Hn. apply elem_of_list_singleton.
- apply not_elem_of_dom in Hn. apply elem_of_dom in Hy.
- destruct (decide (x = y)) as [<- | Hneq]; first done.
- rewrite lookup_delete_ne in Hn; last done.
- rewrite lookup_insert_ne in Hy; last done.
- apply sem_context_rel_subset in Hctxt.
- move: Hctxt. rewrite elem_of_subseteq.
- move : Hn Hy. rewrite -elem_of_dom -not_elem_of_dom.
- naive_solver.
- }
-
+ eexists x, _. split; first reflexivity.
+ split; first by eapply lam_closed.
intros v' Hv'.
specialize (Hbody (<[ x := of_val v']> θ)).
- simpl. rewrite subst_subst_map.
- 2: { by eapply sem_context_rel_closed. }
+ simpl. rewrite subst_subst_map; last by eapply sem_context_rel_closed.
apply Hbody.
apply sem_context_rel_insert; done.
Qed.
-
-Lemma compat_lam_anon Γ e A B X :
- closed X e →
- (∀ y, y ∈ X → y ∈ dom Γ) →
+Lemma compat_lam_anon Γ e A B :
Γ ⊨ e : B →
Γ ⊨ (Lam BAnon e) : (A → B).
Proof.
- intros Hcl Hsub Hbody θ Hctxt. simpl.
- simp type_interp.
-
- exists (λ: <>, subst_map θ e)%V.
+ intros [Hbodycl Hbody]. split; first done.
+ intros θ Hctxt. simpl. simp type_interp.
+ eexists.
split; first by eauto.
simp type_interp.
- eexists BAnon, _. split_and!; first reflexivity.
- { simpl.
- eapply closed_subst_weaken; [ | | apply Hcl].
- - by eapply sem_context_rel_closed.
- - intros y Hy%Hsub Hn.
- apply not_elem_of_dom in Hn. apply elem_of_dom in Hy.
- apply sem_context_rel_subset in Hctxt.
- move: Hctxt. rewrite elem_of_subseteq.
- move : Hn Hy. rewrite -elem_of_dom -not_elem_of_dom.
- naive_solver.
- }
-
- intros v' Hv'.
- specialize (Hbody θ).
- simpl. apply Hbody; done.
+ eexists _, _. split; first reflexivity.
+ split.
+ { simpl. eapply subst_map_closed'_2; simpl.
+ - by erewrite <-sem_context_rel_dom.
+ - by eapply sem_context_rel_closed. }
+ naive_solver.
Qed.
-Lemma compat_int_binop Γ op e1 e2 :
- bin_op_typed op Int Int Int →
+Lemma compat_add Γ e1 e2 :
Γ ⊨ e1 : Int →
Γ ⊨ e2 : Int →
- Γ ⊨ (BinOp op e1 e2) : Int.
+ Γ ⊨ (e1 + e2) : Int.
Proof.
- intros Hop He1 He2 θ Hctx. simpl.
+ intros [Hcl1 He1] [Hcl2 He2]. split.
+ { unfold closed in *. naive_solver. }
+ intros θ Hctx.
simp type_interp.
specialize (He1 _ Hctx). specialize (He2 _ Hctx).
simp type_interp in He1. simp type_interp in He2.
@@ -283,28 +268,40 @@ Proof.
simp type_interp in Hv1, Hv2.
destruct Hv1 as (z1 & ->). destruct Hv2 as (z2 & ->).
- inversion Hop; subst op.
+ exists #(z1 + z2). split.
+ - constructor; done.
+ - exists (z1 + z2)%Z. done.
+
Qed.
-(* FIXME : add the necessary compatibility lemmas *)
+
+
Lemma sem_soundness Γ e A :
- Γ ⊢ e : A →
+ (Γ ⊢ e : A)%ty →
Γ ⊨ e : A.
Proof.
- induction 1 as [ | Γ x e A B Hsyn IH | Γ e A B Hsyn IH| | ].
+ induction 1.
- by apply compat_var.
- - set (X := elements (dom (<[x := A]>Γ))).
- specialize (syn_typed_closed _ _ _ X Hsyn) as Hcl.
- eapply compat_lam_named; last done.
- + apply Hcl. apply elem_of_elements.
- + intros ??. by apply elem_of_elements.
- - set (X := elements (dom Γ)).
- specialize (syn_typed_closed _ _ _ X Hsyn) as Hcl.
- eapply compat_lam_anon; last done.
- + apply Hcl. apply elem_of_elements.
- + intros ??. by apply elem_of_elements.
+ - by apply compat_lam.
+ - by apply compat_lam_anon.
- apply compat_int.
- by eapply compat_app.
- (* FIXME : extend according to your new typing rules. *)
+ - by apply compat_add.
+ (* add compatibility lemmas for the new rules here. *)
+ (* TODO: exercise *)
+Admitted.
+
+
+Lemma termination e A :
+ (∅ ⊢ e : A)%ty →
+ ∃ v, big_step e v.
+Proof.
+ intros [Hsemcl Hsem]%sem_soundness.
+ specialize (Hsem ∅).
+ simp type_interp in Hsem.
+ rewrite subst_map_empty in Hsem.
+ destruct Hsem as (v & Hbs & _); last eauto.
+ constructor.
Qed.
+
diff --git a/theories/type_systems/stlc_extended/notation.v b/theories/type_systems/stlc_extended/notation.v
index 2d8e7dece6c74277c7fa669e29b4c93798da7fc4..4499df292aaaf01ebedc89067d1637efc3097a92 100644
--- a/theories/type_systems/stlc_extended/notation.v
+++ b/theories/type_systems/stlc_extended/notation.v
@@ -4,7 +4,6 @@ Set Default Proof Using "Type".
(** Coercions to make programs easier to type. *)
Coercion of_val : val >-> expr.
-Coercion LitInt : Z >-> base_lit.
Coercion App : expr >-> Funclass.
Coercion Var : string >-> expr.
@@ -15,8 +14,8 @@ Notation Match e0 x1 e1 x2 e2 := (Case e0 (Lam x1 e1) (Lam x2 e2)) (only parsing
(* No scope for the values, does not conflict and scope is often not inferred
properly. *)
-Notation "# l" := (LitV l%Z%V%stdpp) (at level 8, format "# l").
-Notation "# l" := (Lit l%Z%E%stdpp) (at level 8, format "# l") : expr_scope.
+Notation "# l" := (LitIntV l%Z%V%stdpp) (at level 8, format "# l").
+Notation "# l" := (LitInt l%Z%E%stdpp) (at level 8, format "# l") : expr_scope.
(** Syntax inspired by Coq/Ocaml. Constructions with higher precedence come
first. *)
@@ -31,9 +30,7 @@ Notation "'match:' e0 'with' 'InjR' x1 => e1 | 'InjL' x2 => e2 'end'" :=
(Match e0 x2%binder e2 x1%binder e1)
(e0, x1, e1, x2, e2 at level 200, only parsing) : expr_scope.
-Notation "e1 + e2" := (BinOp PlusOp e1%E e2%E) : expr_scope.
-Notation "e1 - e2" := (BinOp MinusOp e1%E e2%E) : expr_scope.
-Notation "e1 * e2" := (BinOp MultOp e1%E e2%E) : expr_scope.
+Notation "e1 + e2" := (Plus e1%E e2%E) : expr_scope.
(*Notation "~ e" := (UnOp NegOp e%E) (at level 75, right associativity) : expr_scope.*)
diff --git a/theories/type_systems/stlc_extended/parallel_subst.v b/theories/type_systems/stlc_extended/parallel_subst.v
index 536ade1d482accbc1d9eeb2c552a65458f512c67..d980b4c3712ddf2f5e339967995f78bb890ca932 100644
--- a/theories/type_systems/stlc_extended/parallel_subst.v
+++ b/theories/type_systems/stlc_extended/parallel_subst.v
@@ -5,11 +5,11 @@ From semantics.lib Require Import maps.
Fixpoint subst_map (xs : gmap string expr) (e : expr) : expr :=
match e with
- | Lit l => Lit l
+ | LitInt n => LitInt n
| Var y => match xs !! y with Some es => es | _ => Var y end
| App e1 e2 => App (subst_map xs e1) (subst_map xs e2)
| Lam x e => Lam x (subst_map (binder_delete x xs) e)
- | BinOp op e1 e2 => BinOp op (subst_map xs e1) (subst_map xs e2)
+ | Plus e1 e2 => Plus (subst_map xs e1) (subst_map xs e2)
| Pair e1 e2 => Pair (subst_map xs e1) (subst_map xs e2)
| Fst e => Fst (subst_map xs e)
| Snd e => Snd (subst_map xs e)
@@ -18,23 +18,23 @@ Fixpoint subst_map (xs : gmap string expr) (e : expr) : expr :=
| Case e e1 e2 => Case (subst_map xs e) (subst_map xs e1) (subst_map xs e2)
end.
+
Lemma subst_map_empty e :
subst_map ∅ e = e.
Proof.
induction e; simpl; f_equal; eauto.
- all: destruct x; simpl; [done | by rewrite !delete_empty..].
+ destruct x; simpl; [done | by rewrite !delete_empty..].
Qed.
-Lemma subst_map_is_closed X e xs :
- is_closed X e →
+
+
+Lemma subst_map_closed X e xs :
+ closed X e →
(∀ x : string, x ∈ dom xs → x ∉ X) →
subst_map xs e = e.
Proof.
intros Hclosed Hd.
induction e in xs, X, Hd, Hclosed |-*; simpl in *;try done.
- all: repeat match goal with
- | H : Is_true (_ && _) |- _ => apply andb_True in H as [ ? ? ]
- end.
{ (* Var *)
apply bool_decide_spec in Hclosed.
assert (xs !! x = None) as ->; last done.
@@ -50,41 +50,52 @@ Proof.
intros [Hnx%Hd Hneq]. rewrite elem_of_cons. intros [? | ?]; done.
}
(* all other cases *)
+ all: unfold closed in *; simpl in *.
+ all: repeat match goal with
+ | H : Is_true (_ && _) |- _ => apply andb_True in H as [ ? ? ]
+ end.
all: repeat match goal with
| H : ∀ _ _, _ → _ → subst_map _ _ = _ |- _ => erewrite H; clear H
- end; done.
+ end; try done.
Qed.
-Lemma subst_map_subst map x (e e' : expr) :
- is_closed [] e' →
+Lemma subst_map_subst map x (e e': expr) :
+ closed [] e' →
subst_map map (subst x e' e) = subst_map (<[x:=e']>map) e.
Proof.
- intros He'.
- revert x map; induction e; intros xx map; simpl;
- try (f_equal; eauto).
+ intros He'; induction e as [y|y e IH | | | | | | | | | ]in map|-*; simpl; try (f_equal; eauto).
- case_decide.
+ simplify_eq/=. rewrite lookup_insert.
- rewrite (subst_map_is_closed []); [done | apply He' | ].
+ rewrite (subst_map_closed []); [done | apply He' | ].
intros ? ?. apply not_elem_of_nil.
+ rewrite lookup_insert_ne; done.
- - destruct x; simpl; first done.
+ - destruct y; simpl; first done.
+ case_decide.
* simplify_eq/=. by rewrite delete_insert_delete.
* rewrite delete_insert_ne; last by congruence. done.
Qed.
-Definition subst_is_closed (X : list string) (map : gmap string expr) :=
+(** We lift the notion of closedness [closed] to substitution maps. *)
+Definition subst_closed (X : list string) (map : gmap string expr) :=
∀ x e, map !! x = Some e → closed X e.
-Lemma subst_is_closed_subseteq X map1 map2 :
- map1 ⊆ map2 → subst_is_closed X map2 → subst_is_closed X map1.
+Lemma subst_closed_subseteq X map1 map2 :
+ map1 ⊆ map2 → subst_closed X map2 → subst_closed X map1.
Proof.
intros Hsub Hclosed2 x e Hl. eapply Hclosed2, map_subseteq_spec; done.
Qed.
+Lemma subst_closed_weaken X Y map1 map2 :
+ Y ⊆ X → map1 ⊆ map2 → subst_closed Y map2 → subst_closed X map1.
+Proof.
+ intros Hsub1 Hsub2 Hclosed2 x e Hl.
+ eapply is_closed_weaken. 1:eapply Hclosed2, map_subseteq_spec; done. done.
+Qed.
+
+(** Lemma about the interaction with "normal" substitution. *)
Lemma subst_subst_map x es map e :
- subst_is_closed [] map →
+ subst_closed [] map →
subst x es (subst_map (delete x map) e) =
- subst_map (<[x:=es]>map) e.
+ subst_map (<[x:=es]> map) e.
Proof.
revert map es x; induction e; intros map v0 xx Hclosed; simpl;
try (f_equal; eauto).
@@ -100,12 +111,12 @@ Proof.
case_decide.
+ simplify_eq. rewrite delete_idemp delete_insert_delete. done.
+ rewrite delete_insert_ne //; last congruence. rewrite delete_commute. apply IHe.
- eapply subst_is_closed_subseteq; last done.
+ eapply subst_closed_subseteq; last done.
apply map_delete_subseteq.
Qed.
Lemma subst'_subst_map b (es : expr) map e :
- subst_is_closed [] map →
+ subst_closed [] map →
subst' b es (subst_map (binder_delete b map) e) =
subst_map (binder_insert b es map) e.
Proof.
@@ -114,15 +125,12 @@ Proof.
Qed.
Lemma closed_subst_weaken e map X Y :
- subst_is_closed [] map →
+ subst_closed [] map →
(∀ x, x ∈ X → x ∉ dom map → x ∈ Y) →
closed X e →
closed Y (subst_map map e).
Proof.
- induction e in X, Y, map |-*; rewrite /closed; simpl; intros Hmclosed Hsub Hcl; first done.
- all: repeat match goal with
- | H : Is_true (_ && _) |- _ => apply andb_True in H as [ ? ? ]
- end.
+ induction e in X, Y, map |-*; simpl; intros Hmclosed Hsub Hcl.
{ (* vars *)
destruct (map !! x) as [es | ] eqn:Heq.
+ apply is_closed_weaken_nil. by eapply Hmclosed.
@@ -131,7 +139,7 @@ Proof.
}
{ (* lambdas *)
eapply IHe; last done.
- + eapply subst_is_closed_subseteq; last done.
+ + eapply subst_closed_subseteq; last done.
destruct x; first done. apply map_delete_subseteq.
+ intros y. destruct x as [ | x]; first by apply Hsub.
rewrite !elem_of_cons. intros [-> | Hy] Hn; first by left.
@@ -139,8 +147,47 @@ Proof.
right. eapply Hsub; first done. set_solver.
}
(* all other cases *)
+ all: unfold closed in *; simpl in *.
+ all: repeat match goal with
+ | H : Is_true (_ && _) |- _ => apply andb_True in H as [ ? ? ]
+ end.
all: repeat match goal with
| |- Is_true (_ && _) => apply andb_True; split
end.
- all: naive_solver.
+ all: try naive_solver.
+Qed.
+
+
+Lemma subst_map_closed' X Y Θ e:
+ closed Y e →
+ (∀ x, x ∈ Y → if Θ !! x is (Some e') then closed X e' else x ∈ X) →
+ closed X (subst_map Θ e).
+Proof.
+ induction e in X, Θ, Y |-*; simpl.
+ { intros Hel%bool_decide_unpack Hcl.
+ eapply Hcl in Hel.
+ destruct (Θ !! x); first done.
+ simpl. by eapply bool_decide_pack. }
+ { intros Hcl Hcl'. destruct x as [|x]; simpl; first naive_solver.
+ eapply IHe; first done.
+ intros y [|]%elem_of_cons.
+ + subst. rewrite lookup_delete. set_solver.
+ + destruct (decide (x = y)); first by subst; rewrite lookup_delete; set_solver.
+ rewrite lookup_delete_ne //=. eapply Hcl' in H.
+ destruct lookup; last set_solver.
+ eapply is_closed_weaken; eauto with set_solver. }
+ all: unfold closed; simpl; naive_solver.
+Qed.
+
+Lemma subst_map_closed'_2 X Θ e:
+ closed (X ++ (elements (dom Θ))) e ->
+ subst_closed X Θ ->
+ closed X (subst_map Θ e).
+Proof.
+ intros Hcl Hsubst.
+ eapply subst_map_closed'; first eassumption.
+ intros x Hx.
+ destruct (Θ !! x) as [e'|] eqn:Heq.
+ - eauto.
+ - by eapply elem_of_app in Hx as [H|H%elem_of_elements%not_elem_of_dom].
Qed.
diff --git a/theories/type_systems/stlc_extended/types.v b/theories/type_systems/stlc_extended/types.v
index 54cb29e3d98bb6e889be5be544449050f407edce..51317d57b659fa7342619436aa3cf200545e29a4 100644
--- a/theories/type_systems/stlc_extended/types.v
+++ b/theories/type_systems/stlc_extended/types.v
@@ -1,7 +1,7 @@
From stdpp Require Import base relations.
From iris Require Import prelude.
From semantics.lib Require Import maps.
-From semantics.ts.stlc_extended Require Import lang notation.
+From semantics.ts.stlc_extended Require Import lang notation ctxstep.
(** ** Syntactic typing *)
Inductive type : Type :=
@@ -28,11 +28,6 @@ Notation "(+)" := Sum (only parsing) : FType_scope.
Reserved Notation "Γ ⊢ e : A" (at level 74, e, A at next level).
-Inductive bin_op_typed : bin_op → type → type → type → Prop :=
- (* FIXME: add the typing rules for binary operators here *)
-.
-#[export] Hint Constructors bin_op_typed : core.
-
Inductive syn_typed : typing_context → expr → type → Prop :=
| typed_var Γ x A :
Γ !! x = Some A →
@@ -43,12 +38,16 @@ Inductive syn_typed : typing_context → expr → type → Prop :=
| typed_lam_anon Γ e A B :
Γ ⊢ e : B →
Γ ⊢ (Lam BAnon e) : (A → B)
- | typed_int Γ z : Γ ⊢ (Lit $ LitInt z) : Int
+ | typed_int Γ z : Γ ⊢ (LitInt z) : Int
| typed_app Γ e1 e2 A B :
Γ ⊢ e1 : (A → B) →
Γ ⊢ e2 : A →
Γ ⊢ (e1 e2)%E : B
- (* FIXME: provide the new typing rules *)
+ | typed_add Γ e1 e2 :
+ Γ ⊢ e1 : Int →
+ Γ ⊢ e2 : Int →
+ Γ ⊢ e1 + e2 : Int
+ (* TODO: provide the new typing rules *)
where "Γ ⊢ e : A" := (syn_typed Γ e%E A%ty).
#[export] Hint Constructors syn_typed : core.
@@ -61,8 +60,8 @@ Lemma syn_typed_closed Γ e A X :
(∀ x, x ∈ dom Γ → x ∈ X) →
is_closed X e.
Proof.
- (* FIXME: you will need to add the new cases to the intro pattern *)
- induction 1 as [ | ?????? IH | | | ] in X |-*; simpl; intros Hx; try done.
+ (* TODO: you will need to add the new cases, i.e. "|"'s to the intro pattern. The proof then should go through *)
+ induction 1 as [ | ?????? IH | | | | ] in X |-*; simpl; intros Hx; try done.
{ (* var *) apply bool_decide_pack, Hx. apply elem_of_dom; eauto. }
{ (* lam *) apply IH.
intros y. rewrite elem_of_dom lookup_insert_is_Some.
@@ -82,8 +81,8 @@ Lemma typed_weakening Γ Δ e A:
Γ ⊆ Δ →
Δ ⊢ e : A.
Proof.
- (* FIXME: you will need to add the new cases to the intro pattern *)
- induction 1 as [| Γ x e A B Htyp IH | | | ] in Δ |-*; intros Hsub; eauto.
+ (* TODO: here you will need to add the new cases to the intro pattern as well. The proof then should go through *)
+ induction 1 as [| Γ x e A B Htyp IH | | | | ] in Δ |-*; intros Hsub; eauto.
- (* var *) econstructor. by eapply lookup_weaken.
- (* lam *) econstructor. eapply IH; eauto. by eapply insert_mono.
Qed.
@@ -107,17 +106,22 @@ Lemma app_inversion Γ e1 e2 B:
∃ A, Γ ⊢ e1 : (A → B) ∧ Γ ⊢ e2 : A.
Proof. inversion 1; subst; eauto. Qed.
-(* FIXME: add inversion lemmas for the new typing rules.
+Lemma plus_inversion Γ e1 e2 B:
+ Γ ⊢ e1 + e2 : B →
+ B = Int ∧ Γ ⊢ e1 : Int ∧ Γ ⊢ e2 : Int.
+Proof. inversion 1; subst; eauto. Qed.
+
+(* TODO: add inversion lemmas for the new typing rules.
They will be very useful for the proofs below!
*)
+
Lemma typed_substitutivity e e' Γ (x: string) A B :
∅ ⊢ e' : A →
(<[x := A]> Γ) ⊢ e : B →
Γ ⊢ lang.subst x e' e : B.
Proof.
- intros He'. revert B Γ; induction e as [| y | y | | | | | | | | ]; intros B Γ; simpl.
- - inversion 1; subst; auto.
+ intros He'. revert B Γ; induction e as [y | y | | | | | | | | | ]; intros B Γ; simpl.
- intros Hp % var_inversion.
destruct (decide (x = y)).
+ subst. rewrite lookup_insert in Hp. injection Hp as ->.
@@ -134,14 +138,14 @@ Proof.
+ injection Heq as [= ->]. by rewrite insert_insert in Hty.
+ rewrite insert_commute in Hty; last naive_solver. eauto.
- intros (C & Hty1 & Hty2) % app_inversion. eauto.
- - (* FIXME *) admit.
- - (* FIXME *) admit.
- - (* FIXME *) admit.
- - (* FIXME *) admit.
- - (* FIXME *) admit.
- - (* FIXME *) admit.
- - (* FIXME *) admit.
-(*Qed.*)
+ - inversion 1; subst; auto.
+ - intros (-> & Hty1 & Hty2)%plus_inversion; eauto.
+ - (* TODO *) admit.
+ - (* TODO *) admit.
+ - (* TODO *) admit.
+ - (* TODO *) admit.
+ - (* TODO *) admit.
+ - (* TODO *) admit.
Admitted.
(** Canonical values *)
@@ -161,15 +165,15 @@ Proof.
inversion 1; simpl; naive_solver.
Qed.
-(* FIXME: add canonical forms lemmas for the new types *)
+(* TODO: add canonical forms lemmas for the new types *)
(** Progress *)
Lemma typed_progress e A:
∅ ⊢ e : A → is_val e ∨ reducible e.
Proof.
remember ∅ as Γ.
- (* FIXME: you will need to extend the intro pattern *)
- induction 1 as [| | | | Γ e1 e2 A B Hty IH1 _ IH2 ].
+ (* TODO: you will need to extend the intro pattern *)
+ induction 1 as [| | | | Γ e1 e2 A B Hty IH1 _ IH2 | Γ e1 e2 Hty1 IH1 Hty2 IH2].
- subst. naive_solver.
- left. done.
- left. done.
@@ -183,8 +187,15 @@ Proof.
eexists. eauto.
+ right. destruct H2 as [e2' H2].
eexists. eauto.
- (* FIXME: prove the new cases *)
-(*Qed.*)
+ - (* plus *)
+ destruct (IH2 HeqΓ) as [H2|H2]; [destruct (IH1 HeqΓ) as [H1|H1]|].
+ + right. eapply canonical_values_int in Hty1 as [n1 ->]; last done.
+ eapply canonical_values_int in Hty2 as [n2 ->]; last done.
+ subst. eexists; eapply base_contextual_step. eauto.
+ + right. destruct H1 as [e1' Hstep]. eexists. eauto.
+ + right. destruct H2 as [e2' H2]. eexists. eauto.
+
+(* FIXME: prove the new cases *)
Admitted.
Definition ectx_typing (K: ectx) (A B: type) :=
@@ -219,8 +230,9 @@ Proof.
eapply lam_inversion in H1 as (C & D & Heq & Hty).
injection Heq as -> ->.
eapply typed_substitutivity; eauto.
- (* FIXME: extend this for the new cases *)
-(*Qed.*)
+ - eapply plus_inversion in Hty as (-> & Hty1 & Hty2). constructor.
+
+(* TODO: extend this for the new cases *)
Admitted.
Lemma typed_preservation e e' A:
diff --git a/theories/type_systems/systemf/binary_logrel.v b/theories/type_systems/systemf/binary_logrel.v
index 01d568a1dc31da1717bc880bfb5209f4b111903f..33787fa9bb86f3d791d8134589ae9f60097c86c5 100644
--- a/theories/type_systems/systemf/binary_logrel.v
+++ b/theories/type_systems/systemf/binary_logrel.v
@@ -28,9 +28,13 @@ Implicit Types
We use the Equations package to define the logical relation, as it's tedious to make the termination
argument work with Coq's built-in support for recursive functions.
*)
-Inductive type_case : Set :=
- | expr_case | val_case.
+Inductive val_or_expr : Type :=
+| inj_val : val → val → val_or_expr
+| inj_expr : expr → expr → val_or_expr.
+(* The [type_size] function essentially computes the size of the "type tree". *)
+(* Note that we have added some additional primitives to make our (still
+ simple) language more expressive. *)
Equations type_size (A : type) : nat :=
type_size Int := 1;
type_size Bool := 1;
@@ -40,12 +44,12 @@ Equations type_size (A : type) : nat :=
type_size (∀: A) := type_size A + 2;
type_size (∃: A) := type_size A + 2;
type_size (A × B) := type_size A + type_size B + 1;
- type_size (A + B) := max (type_size A) (type_size B) + 1
-.
+ type_size (A + B) := max (type_size A) (type_size B) + 1.
-Equations mut_measure (c : type_case) A : nat :=
- mut_measure expr_case A := 1 + type_size A;
- mut_measure val_case A := type_size A.
+(* The definition of the expression relation uses the value relation -- therefore, it needs to be larger, and we add [1]. *)
+Equations mut_measure (ve : val_or_expr) (t : type) : nat :=
+ mut_measure (inj_val _ _) t := type_size t;
+ mut_measure (inj_expr _ _) t := 1 + type_size t.
(** A semantic type consists of a value-relation and a proof of closedness *)
Record sem_type := mk_ST {
@@ -74,37 +78,37 @@ Implicit Types
.
(** The logical relation *)
-Equations type_interp (c : type_case) (t : type) δ (v : match c with val_case => val | expr_case => expr end) (w : match c with val_case => val | expr_case => expr end) : Prop by wf (mut_measure c t) := {
- type_interp val_case Int δ v w =>
+Equations type_interp (c : val_or_expr) (t : type) δ : Prop by wf (mut_measure c t) := {
+ type_interp (inj_val v w) Int δ =>
∃ z : Z, v = #z ∧ w = #z;
- type_interp val_case Bool δ v w =>
+ type_interp (inj_val v w) Bool δ =>
∃ b : bool, v = #b ∧ w = #b;
- type_interp val_case Unit δ v w =>
+ type_interp (inj_val v w) Unit δ =>
v = #LitUnit ∧ w = #LitUnit ;
- type_interp val_case (A × B) δ v w =>
- ∃ v1 v2 w1 w2 : val, v = (v1, v2)%V ∧ w = (w1, w2)%V ∧ type_interp val_case A δ v1 w1 ∧ type_interp val_case B δ v2 w2;
- type_interp val_case (A + B) δ v w =>
- (∃ v' w' : val, v = InjLV v' ∧ w = InjLV w' ∧ type_interp val_case A δ v' w') ∨
- (∃ v' w' : val, v = InjRV v' ∧ w = InjRV w' ∧ type_interp val_case B δ v' w');
- type_interp val_case (A → B) δ v w =>
+ type_interp (inj_val v w) (A × B) δ =>
+ ∃ v1 v2 w1 w2 : val, v = (v1, v2)%V ∧ w = (w1, w2)%V ∧ type_interp (inj_val v1 w1) A δ ∧ type_interp (inj_val v2 w2) B δ;
+ type_interp (inj_val v w) (A + B) δ =>
+ (∃ v' w' : val, v = InjLV v' ∧ w = InjLV w' ∧ type_interp (inj_val v' w') A δ) ∨
+ (∃ v' w' : val, v = InjRV v' ∧ w = InjRV w' ∧ type_interp (inj_val v' w') B δ);
+ type_interp (inj_val v w) (A → B) δ =>
∃ x y e1 e2, v = LamV x e1 ∧ w = LamV y e2 ∧ is_closed (x :b: nil) e1 ∧ is_closed (y :b: nil) e2 ∧
∀ v' w',
- type_interp val_case A δ v' w' →
- type_interp expr_case B δ (subst' x (of_val v') e1) (subst' y (of_val w') e2);
+ type_interp (inj_val v' w') A δ →
+ type_interp (inj_expr (subst' x (of_val v') e1) (subst' y (of_val w') e2)) B δ;
(** Type variable case *)
- type_interp val_case (#α) δ v w =>
+ type_interp (inj_val v w) (#α) δ =>
(δ α).(sem_type_car) v w;
(** ∀ case *)
- type_interp val_case (∀: A) δ v w =>
+ type_interp (inj_val v w) (∀: A) δ =>
∃ e1 e2, v = TLamV e1 ∧ w = TLamV e2 ∧ is_closed [] e1 ∧ is_closed [] e2 ∧
- ∀ τ, type_interp expr_case A (τ .: δ) e1 e2;
+ ∀ τ, type_interp (inj_expr e1 e2) A (τ .: δ);
(** ∃ case *)
- type_interp val_case (∃: A) δ v w =>
+ type_interp (inj_val v w) (∃: A) δ =>
∃ v' w', v = PackV v' ∧ w = PackV w' ∧
- ∃ τ : sem_type, type_interp val_case A (τ .: δ) v' w';
+ ∃ τ : sem_type, type_interp (inj_val v' w') A (τ .: δ);
- type_interp expr_case t δ e1 e2 =>
- ∃ v1 v2, big_step e1 v1 ∧ big_step e2 v2 ∧ type_interp val_case t δ v1 v2
+ type_interp (inj_expr e1 e2) t δ =>
+ ∃ v1 v2, big_step e1 v1 ∧ big_step e2 v2 ∧ type_interp (inj_val v1 v2) t δ
}.
Next Obligation. repeat simp mut_measure; simp type_size; lia. Qed.
Next Obligation. repeat simp mut_measure; simp type_size; lia. Qed.
@@ -119,19 +123,12 @@ Next Obligation. repeat simp mut_measure; simp type_size; lia. Qed.
Next Obligation. repeat simp mut_measure; simp type_size; lia. Qed.
(** Value relation and expression relation *)
-Definition sem_val_rel A δ v1 v2 := type_interp val_case A δ v1 v2.
-Definition sem_expr_rel A δ e1 e2 := type_interp expr_case A δ e1 e2.
+Notation sem_val_rel A δ v w := (type_interp (inj_val v w) A δ).
+Notation sem_expr_rel A δ e1 e2 := (type_interp (inj_expr e1 e2) A δ).
-Notation 𝒱 := sem_val_rel.
-Notation ℰ := sem_expr_rel.
+Notation 𝒱 A δ v w := (sem_val_rel A δ v w).
+Notation ℰ A δ e1 e2 := (sem_expr_rel A δ e1 e2).
-Lemma sem_expr_rel_of_val A δ v w :
- ℰ A δ (of_val v) (of_val w) → 𝒱 A δ v w.
-Proof.
- simp type_interp.
- intros (v' & w' & ->%big_step_val & ->%big_step_val & Hv').
- apply Hv'.
-Qed.
Lemma val_rel_is_closed v w δ A:
𝒱 A δ v w → is_closed [] (of_val v) ∧ is_closed [] (of_val w).
@@ -150,7 +147,7 @@ Qed.
(** Interpret a syntactic type *)
Program Definition interp_type A δ : sem_type := {|
- sem_type_car := 𝒱 A δ;
+ sem_type_car := fun v w => 𝒱 A δ v w;
|}.
Next Obligation. by eapply val_rel_is_closed. Qed.
@@ -168,6 +165,20 @@ Inductive sem_context_rel (δ : tyvar_interp) : typing_context → (gmap string
Notation 𝒢 := sem_context_rel.
+(** Semantic typing judgment *)
+Definition sem_typed Δ Γ e1 e2 A :=
+ is_closed (elements (dom Γ)) e1 ∧ is_closed (elements (dom Γ)) e2 ∧
+ ∀ θ1 θ2 δ, 𝒢 δ Γ θ1 θ2 → ℰ A δ (subst_map θ1 e1) (subst_map θ2 e2).
+Notation "'TY' Δ ; Γ ⊨ e1 ≈ e2 : A" := (sem_typed Δ Γ e1 e2 A) (at level 74, e1, e2, A at next level).
+
+Lemma sem_expr_rel_of_val A δ v w :
+ ℰ A δ (of_val v) (of_val w) → 𝒱 A δ v w.
+Proof.
+ simp type_interp.
+ intros (v' & w' & ->%big_step_val & ->%big_step_val & Hv').
+ apply Hv'.
+Qed.
+
Lemma sem_context_rel_vals {δ Γ θ1 θ2 x A} :
sem_context_rel δ Γ θ1 θ2 →
Γ !! x = Some A →
@@ -197,6 +208,7 @@ Proof.
all: eapply elem_of_dom; eauto.
Qed.
+
Lemma sem_context_rel_closed δ Γ θ1 θ2:
𝒢 δ Γ θ1 θ2 → subst_is_closed [] θ1 ∧ subst_is_closed [] θ2.
Proof.
@@ -209,11 +221,14 @@ Proof.
+ eapply val_rel_is_closed in Hv. naive_solver.
+ eapply IH2; last done.
Qed.
+Lemma sem_context_rel_dom δ Γ θ1 θ2 :
+ 𝒢 δ Γ θ1 θ2 → dom Γ = dom θ1 /\ dom Γ = dom θ2.
+Proof.
+ induction 1.
+ - by rewrite !dom_empty.
+ - rewrite !dom_insert. set_solver.
+Qed.
-(** Semantic typing judgment *)
-Definition sem_typed Δ Γ e1 e2 A :=
- ∀ θ1 θ2 δ, 𝒢 δ Γ θ1 θ2 → ℰ A δ (subst_map θ1 e1) (subst_map θ2 e2).
-Notation "'TY' Δ ; Γ ⊨ e1 ≈ e2 : A" := (sem_typed Δ Γ e1 e2 A) (at level 74, e1, e2, A at next level).
Section boring_lemmas.
(** The lemmas in this section are all quite boring and expected statements,
@@ -344,6 +359,7 @@ End boring_lemmas.
Lemma compat_int Δ Γ z : TY Δ; Γ ⊨ (Lit $ LitInt z) ≈ (Lit $ LitInt z) : Int.
Proof.
+ do 2 (split; first done).
intros θ1 θ2 δ _. simp type_interp.
exists #z, #z.
split; first by constructor.
@@ -353,6 +369,7 @@ Qed.
Lemma compat_bool Δ Γ b : TY Δ; Γ ⊨ (Lit $ LitBool b) ≈ (Lit $ LitBool b) : Bool.
Proof.
+ do 2 (split; first done).
intros θ1 θ2 δ _. simp type_interp.
exists #b, #b.
split; first by constructor.
@@ -362,6 +379,7 @@ Qed.
Lemma compat_unit Δ Γ : TY Δ; Γ ⊨ (Lit $ LitUnit) ≈ (Lit $ LitUnit) : Unit.
Proof.
+ do 2 (split; first done).
intros θ1 θ2 δ _. simp type_interp.
exists #LitUnit, #LitUnit.
split; first by constructor.
@@ -372,14 +390,23 @@ Qed.
Lemma compat_var Δ Γ x A :
Γ !! x = Some A →
TY Δ; Γ ⊨ (Var x) ≈ (Var x) : A.
-Proof. Admitted.
+Proof.
+ intros Hx.
+ do 2 (split; first eapply bool_decide_pack, elem_of_elements, elem_of_dom_2, Hx).
+ intros θ1 θ2 δ Hctx; simpl.
+
+ (* TODO: exercise *)
+Admitted.
+
Lemma compat_app Δ Γ e1 e1' e2 e2' A B :
TY Δ; Γ ⊨ e1 ≈ e1': (A → B) →
TY Δ; Γ ⊨ e2 ≈ e2' : A →
TY Δ; Γ ⊨ (e1 e2) ≈ (e1' e2') : B.
Proof.
- intros Hfun Harg θ1 θ2 δ Hctx; simpl.
+ intros (Hfuncl & Hfuncl' & Hfun) (Hargcl & Hargcl' & Harg).
+ do 2 (split; first naive_solver).
+ intros θ1 θ2 δ Hctx; simpl.
specialize (Hfun _ _ _ Hctx). simp type_interp in Hfun. destruct Hfun as (v1 & v2 & Hbs1 & Hbs2 & Hv12).
simp type_interp in Hv12. destruct Hv12 as (x & y & e1'' & e2'' & -> & -> & ? & ? & Hv12).
@@ -395,85 +422,61 @@ Proof.
Qed.
-Lemma is_closed_subst_map_delete X Γ (x: string) θ A e:
- closed X e →
+
+(* Compatibility for [lam] unfortunately needs a very technical helper lemma. *)
+Lemma lam_closed Γ θ (x : string) A e :
+ dom Γ = dom θ →
subst_is_closed [] θ →
- dom Γ ⊆ dom θ →
- (∀ y : string, y ∈ X → y ∈ dom (<[x:=A]> Γ)) →
- is_closed (x :b: []) (subst_map (delete x θ) e).
+ closed (elements (dom (<[x:=A]> Γ))) e →
+ closed [] (Lam x (subst_map (delete x θ) e)).
Proof.
- intros He Hθ Hdom1 Hdom2.
- eapply closed_subst_weaken; [ | | apply He].
- - eapply subst_is_closed_subseteq; last done.
+ intros Hdom Hsubstcl Hcl.
+ eapply subst_map_closed.
+ - eapply is_closed_weaken; first done.
+ rewrite dom_delete dom_insert Hdom //.
+ intros y. destruct (decide (x = y)); set_solver.
+ - intros x' e' Hx.
+ eapply (is_closed_weaken []); last set_solver.
+ eapply Hsubstcl.
+ eapply map_subseteq_spec; last done.
apply map_delete_subseteq.
- - intros y Hy%Hdom2 Hn. apply elem_of_list_singleton.
- apply not_elem_of_dom in Hn. apply elem_of_dom in Hy.
- destruct (decide (x = y)) as [<- | Hneq]; first done.
- rewrite lookup_delete_ne in Hn; last done.
- rewrite lookup_insert_ne in Hy; last done.
- move: Hdom1. rewrite elem_of_subseteq.
- move : Hn Hy. rewrite -elem_of_dom -not_elem_of_dom.
- naive_solver.
Qed.
-
-
(** Lambdas need to be closed by the context *)
-Lemma compat_lam_named Δ Γ x e1 e2 A B X :
- closed X e1 →
- closed X e2 →
- (∀ y, y ∈ X → y ∈ dom (<[x := A]> Γ)) →
+Lemma compat_lam_named Δ Γ x e1 e2 A B :
TY Δ; (<[ x := A ]> Γ) ⊨ e1 ≈ e2 : B →
TY Δ; Γ ⊨ (Lam (BNamed x) e1) ≈ (Lam (BNamed x) e2): (A → B).
Proof.
- intros Hcl1 Hcl2 Hsub Hbody θ1 θ2 δ Hctxt. simpl.
+ intros (Hbodycl & Hbodycl' & Hbody).
+ do 2 (split; first (simpl; eapply is_closed_weaken; set_solver)).
+ intros θ1 θ2 δ Hctx. simpl.
simp type_interp.
exists ((λ: x, subst_map (delete x θ1) e1))%V, ((λ: x, subst_map (delete x θ2) e2))%V.
split; first by eauto.
split; first by eauto.
simp type_interp.
- eexists (BNamed x), (BNamed x), _, _. split_and!; try reflexivity.
- - eapply is_closed_subst_map_delete; eauto.
- + eapply sem_context_rel_closed in Hctxt; naive_solver.
- + eapply sem_context_rel_subset in Hctxt; naive_solver.
- - eapply is_closed_subst_map_delete; eauto.
- + eapply sem_context_rel_closed in Hctxt; naive_solver.
- + eapply sem_context_rel_subset in Hctxt; naive_solver.
- - intros v' w' Hvw'.
- specialize (Hbody (<[ x := of_val v']> θ1) (<[ x := of_val w']> θ2)).
- simpl. generalize Hctxt=>Hctxt'.
- eapply sem_context_rel_closed in Hctxt' as Hclosed.
- rewrite !subst_subst_map; [|naive_solver..].
- apply Hbody. apply sem_context_rel_insert; done.
-Qed.
-
-Lemma is_closed_subst_map X Γ θ e:
- closed X e →
- subst_is_closed [] θ →
- dom Γ ⊆ dom θ →
- (∀ y, y ∈ X → y ∈ dom Γ) →
- is_closed [] (subst_map θ e).
-Proof.
- intros He Hθ Hdom1 Hdom2.
- eapply closed_subst_weaken; [ | | apply He].
- - eapply subst_is_closed_subseteq; done.
- - intros y Hy%Hdom2 Hn.
- apply not_elem_of_dom in Hn. apply elem_of_dom in Hy.
- move: Hdom1. rewrite elem_of_subseteq.
- move : Hn Hy. rewrite -elem_of_dom -not_elem_of_dom.
- naive_solver.
+ opose proof* sem_context_rel_dom as []; first done.
+ opose proof* sem_context_rel_closed as []; first done.
+ eexists (BNamed x), (BNamed x), _, _. split_and!.
+ 1-2: reflexivity.
+ 1-2: eapply lam_closed; eauto.
+ intros v' w' Hvw'.
+ specialize (Hbody (<[ x := of_val v']> θ1) (<[ x := of_val w']> θ2)).
+ simpl. generalize Hctx=>Hctx'.
+ eapply sem_context_rel_closed in Hctx' as Hclosed.
+ rewrite !subst_subst_map; [|naive_solver..].
+ apply Hbody. apply sem_context_rel_insert; done.
Qed.
-Lemma compat_lam_anon Δ Γ e1 e2 A B X :
- closed X e1 →
- closed X e2 →
- (∀ y, y ∈ X → y ∈ dom Γ) →
+Lemma compat_lam_anon Δ Γ e1 e2 A B :
TY Δ; Γ ⊨ e1 ≈ e2 : B →
TY Δ; Γ ⊨ (Lam BAnon e1) ≈ (Lam BAnon e2) : (A → B).
Proof.
- intros Hcl1 Hcl2 Hsub Hbody θ1 θ2 δ Hctxt. simpl.
+ intros (Hbodycl & Hbodycl' & Hbody).
+ do 2 (split; first done).
+ intros θ1 θ2 δ Hctx. simpl.
simp type_interp.
exists (λ: <>, subst_map θ1 e1)%V, (λ: <>, subst_map θ2 e2)%V.
@@ -481,12 +484,14 @@ Proof.
split; first by eauto.
simp type_interp.
eexists BAnon, BAnon, _, _. split_and!; try reflexivity.
- - eapply is_closed_subst_map; eauto.
- + eapply sem_context_rel_closed in Hctxt; naive_solver.
- + eapply sem_context_rel_subset in Hctxt; naive_solver.
- - eapply is_closed_subst_map; eauto.
- + eapply sem_context_rel_closed in Hctxt; naive_solver.
- + eapply sem_context_rel_subset in Hctxt; naive_solver.
+ - simpl. eapply subst_map_closed; simpl.
+ + replace (dom θ1) with (dom Γ); first done.
+ eapply sem_context_rel_dom in Hctx. naive_solver.
+ + apply sem_context_rel_closed in Hctx. naive_solver.
+ - simpl. eapply subst_map_closed; simpl.
+ + replace (dom θ2) with (dom Γ); first done.
+ eapply sem_context_rel_dom in Hctx. naive_solver.
+ + apply sem_context_rel_closed in Hctx. naive_solver.
- intros v' w' Hvw'.
specialize (Hbody θ1 θ2).
simpl. apply Hbody; done.
@@ -498,7 +503,9 @@ Lemma compat_int_binop Δ Γ op e1 e1' e2 e2' :
TY Δ; Γ ⊨ e2 ≈ e2' : Int →
TY Δ; Γ ⊨ (BinOp op e1 e2) ≈ (BinOp op e1' e2') : Int.
Proof.
- intros Hop He1 He2 θ1 θ2 δ Hctx. simpl.
+ intros Hop (He1cl & He1cl' & He1) (He2cl & He2cl' & He2).
+ do 2 (split; first naive_solver).
+ intros θ1 θ2 δ Hctx. simpl.
simp type_interp.
specialize (He1 _ _ _ Hctx). specialize (He2 _ _ _ Hctx).
simp type_interp in He1. simp type_interp in He2.
@@ -530,7 +537,10 @@ Lemma compat_int_bool_binop Δ Γ op e1 e1' e2 e2' :
TY Δ; Γ ⊨ e2 ≈ e2' : Int →
TY Δ; Γ ⊨ (BinOp op e1 e2) ≈ (BinOp op e1' e2') : Bool.
Proof.
- intros Hop He1 He2 θ1 θ2 δ Hctx. simpl.
+ intros Hop (He1cl & He1cl' & He1) (He2cl & He2cl' & He2).
+ do 2 (split; first naive_solver).
+ intros θ1 θ2 δ Hctx. simpl.
+
simp type_interp.
specialize (He1 _ _ _ Hctx). specialize (He2 _ _ _ Hctx).
simp type_interp in He1. simp type_interp in He2.
@@ -561,7 +571,10 @@ Lemma compat_unop Δ Γ op A B e e' :
TY Δ; Γ ⊨ e ≈ e' : A →
TY Δ; Γ ⊨ (UnOp op e) ≈ (UnOp op e') : B.
Proof.
- intros Hop He θ1 θ2 δ Hctx. simpl.
+ intros Hop (Hecl & Hecl' & He).
+ do 2 (split; first naive_solver).
+ intros θ1 θ2 δ Hctx. simpl.
+
simp type_interp. specialize (He _ _ _ Hctx).
simp type_interp in He.
@@ -580,14 +593,14 @@ Proof.
Qed.
-Lemma compat_tlam Δ Γ e1 e2 A X :
- closed X e1 →
- closed X e2 →
- (∀ y, y ∈ X → y ∈ dom Γ) →
+Lemma compat_tlam Δ Γ e1 e2 A :
TY S Δ; (⤉ Γ) ⊨ e1 ≈ e2 : A →
TY Δ; Γ ⊨ (Λ, e1) ≈ (Λ, e2) : (∀: A).
Proof.
- intros Hcl1 Hcl2 Hsub He θ1 θ2 δ Hctx. simpl.
+ intros (Hcl & Hcl' & He).
+ do 2 (split; first (simpl; by erewrite <-dom_fmap)).
+
+ intros θ1 θ2 δ Hctx. simpl.
simp type_interp.
exists (Λ, subst_map θ1 e1)%V, (Λ, subst_map θ2 e2)%V.
split; first constructor.
@@ -595,12 +608,16 @@ Proof.
simp type_interp.
eexists _, _. split_and!; try done.
- - eapply is_closed_subst_map; eauto.
- + eapply sem_context_rel_closed in Hctx; naive_solver.
- + eapply sem_context_rel_subset in Hctx; naive_solver.
- - eapply is_closed_subst_map; eauto.
- + eapply sem_context_rel_closed in Hctx; naive_solver.
- + eapply sem_context_rel_subset in Hctx; naive_solver.
+ - simpl. eapply subst_map_closed; simpl.
+ + replace (dom θ1) with (dom Γ).
+ * by erewrite <-dom_fmap.
+ * apply sem_context_rel_dom in Hctx. naive_solver.
+ + apply sem_context_rel_closed in Hctx. naive_solver.
+ - simpl. eapply subst_map_closed; simpl.
+ + replace (dom θ2) with (dom Γ).
+ * by erewrite <-dom_fmap.
+ * apply sem_context_rel_dom in Hctx. naive_solver.
+ + apply sem_context_rel_closed in Hctx. naive_solver.
- intros τ. eapply He.
by eapply sem_context_rel_cons.
Qed.
@@ -609,21 +626,45 @@ Lemma compat_tapp Δ Γ e e' A B :
type_wf Δ B →
TY Δ; Γ ⊨ e ≈ e' : (∀: A) →
TY Δ; Γ ⊨ (e <>) ≈ (e' <>) : (A.[B/]).
-Proof. Admitted.
+Proof.
+ intros Hwf (Hecl & Hecl' & He).
+ do 2 (split; first naive_solver).
+ intros θ1 θ2 δ Hctx. simpl.
+
+ (* TODO: exercise *)
+Admitted.
+
Lemma compat_pack Δ Γ e e' n A B :
type_wf n B →
type_wf (S n) A →
TY n; Γ ⊨ e ≈ e': A.[B/] →
TY n; Γ ⊨ (pack e) ≈ (pack e') : (∃: A).
-Proof. Admitted.
+Proof.
+ intros Hwf Hwf' (Hecl & Hecl' & He).
+ do 2 (split; first naive_solver).
+ intros θ1 θ2 δ Hctx. simpl.
+
+ (* TODO: exercise *)
+Admitted.
+
Lemma compat_unpack n Γ A B e1 e1' e2 e2' x :
type_wf n B →
TY n; Γ ⊨ e1 ≈ e2 : (∃: A) →
TY S n; <[x:=A]> (⤉Γ) ⊨ e1' ≈ e2' : B.[ren (+1)] →
TY n; Γ ⊨ (unpack e1 as BNamed x in e1') ≈ (unpack e2 as BNamed x in e2') : B.
-Proof. Admitted.
+Proof.
+ intros Hwf (Hecl & Hecl' & He) (He'cl & He'cl' & He').
+ split. { simpl. apply andb_True. split; first done.
+ eapply is_closed_weaken; set_solver. }
+ split. { simpl. apply andb_True. split; first done.
+ eapply is_closed_weaken; set_solver. }
+ intros θ1 θ2 δ Hctx. simpl.
+
+ (* TODO: exercise *)
+Admitted.
+
Lemma compat_if n Γ e0 e0' e1 e1' e2 e2' A :
TY n; Γ ⊨ e0 ≈ e0' : Bool →
@@ -631,8 +672,11 @@ Lemma compat_if n Γ e0 e0' e1 e1' e2 e2' A :
TY n; Γ ⊨ e2 ≈ e2' : A →
TY n; Γ ⊨ (if: e0 then e1 else e2) ≈ (if: e0' then e1' else e2') : A.
Proof.
- intros He0 He1 He2 θ1 θ2 δ Hctx. simpl.
+ intros (He0cl & He0cl' & He0) (He1cl & He1cl' & He1) (He2cl & He2cl' & He2).
+ do 2 (split; first naive_solver).
+ intros θ1 θ2 δ Hctx. simpl.
simp type_interp.
+
specialize (He0 _ _ _ Hctx). simp type_interp in He0.
specialize (He1 _ _ _ Hctx). simp type_interp in He1.
specialize (He2 _ _ _ Hctx). simp type_interp in He2.
@@ -652,8 +696,11 @@ Lemma compat_pair Δ Γ e1 e1' e2 e2' A B :
TY Δ; Γ ⊨ e2 ≈ e2' : B →
TY Δ; Γ ⊨ (e1, e2) ≈ (e1', e2') : A × B.
Proof.
- intros He1 He2 θ1 θ2 δ Hctx. simpl.
+ intros (He1cl & He1cl' & He1) (He2cl & He2cl' & He2).
+ do 2 (split; first naive_solver).
+ intros θ1 θ2 δ Hctx. simpl.
simp type_interp.
+
specialize (He1 _ _ _ Hctx). specialize (He2 _ _ _ Hctx).
simp type_interp in He1. simp type_interp in He2.
@@ -669,7 +716,9 @@ Lemma compat_fst Δ Γ e e' A B :
TY Δ; Γ ⊨ e ≈ e' : A × B →
TY Δ; Γ ⊨ Fst e ≈ Fst e' : A.
Proof.
- intros He θ1 θ2 δ Hctx. simpl.
+ intros (Hecl & Hecl' & He).
+ do 2 (split; first naive_solver).
+ intros θ1 θ2 δ Hctx. simpl.
simp type_interp.
specialize (He _ _ _ Hctx). simp type_interp in He.
@@ -684,7 +733,9 @@ Lemma compat_snd Δ Γ e e' A B :
TY Δ; Γ ⊨ e ≈ e' : A × B →
TY Δ; Γ ⊨ Snd e ≈ Snd e' : B.
Proof.
- intros He θ1 θ2 δ Hctx. simpl.
+ intros (Hecl & Hecl' & He).
+ do 2 (split; first naive_solver).
+ intros θ1 θ2 δ Hctx. simpl.
simp type_interp.
specialize (He _ _ _ Hctx). simp type_interp in He.
@@ -699,7 +750,9 @@ Lemma compat_injl Δ Γ e e' A B :
TY Δ; Γ ⊨ e ≈ e' : A →
TY Δ; Γ ⊨ InjL e ≈ InjL e' : A + B.
Proof.
- intros He θ1 θ2 δ Hctx. simpl.
+ intros (Hecl & Hecl' & He).
+ do 2 (split; first naive_solver).
+ intros θ1 θ2 δ Hctx. simpl.
simp type_interp.
specialize (He _ _ _ Hctx). simp type_interp in He.
@@ -715,7 +768,9 @@ Lemma compat_injr Δ Γ e e' A B :
TY Δ; Γ ⊨ e ≈ e' : B →
TY Δ; Γ ⊨ InjR e ≈ InjR e' : A + B.
Proof.
- intros He θ1 θ2 δ Hctx. simpl.
+ intros (Hecl & Hecl' & He).
+ do 2 (split; first naive_solver).
+ intros θ1 θ2 δ Hctx. simpl.
simp type_interp.
specialize (He _ _ _ Hctx). simp type_interp in He.
@@ -733,8 +788,11 @@ Lemma compat_case Δ Γ e e' e1 e1' e2 e2' A B C :
TY Δ; Γ ⊨ e2 ≈ e2' : (C → A) →
TY Δ; Γ ⊨ Case e e1 e2 ≈ Case e' e1' e2' : A.
Proof.
- intros He0 He1 He2 θ1 θ2 δ Hctx. simpl.
+ intros (He0cl & He0cl' & He0) (He1cl & He1cl' & He1) (He2cl & He2cl' & He2).
+ do 2 (split; first naive_solver).
+ intros θ1 θ2 δ Hctx. simpl.
simp type_interp.
+
specialize (He0 _ _ _ Hctx). simp type_interp in He0.
specialize (He1 _ _ _ Hctx). simp type_interp in He1.
specialize (He2 _ _ _ Hctx). simp type_interp in He2.
@@ -744,10 +802,10 @@ Proof.
destruct He2 as (v2 & w2 & Hb2 & Hb2' & Hv2).
destruct Hv0 as [(v' & w' & -> & -> & Hv)|(v' & w' & -> & -> & Hv)].
- - simp type_interp in Hv1. destruct Hv1 as (x & y & e'' & e''' & -> & -> & Cl1 & Cl2 & Hv1).
+ - simp type_interp in Hv1. destruct Hv1 as (x & y & e'' & e''' & -> & -> & Cl & Cl' & Hv1).
apply Hv1 in Hv. simp type_interp in Hv. destruct Hv as (v & w & Hb''' & Hb'''' & Hv'').
eexists _, _. split_and!; eauto using big_step, big_step_of_val.
- - simp type_interp in Hv2. destruct Hv2 as (x & y & e'' & e''' & -> & -> & Cl1 & Cl2 & Hv2).
+ - simp type_interp in Hv2. destruct Hv2 as (x & y & e'' & e''' & -> & -> & Cl & Cl' & Hv2).
apply Hv2 in Hv. simp type_interp in Hv. destruct Hv as (v & w & Hb''' & Hb'''' & Hv'').
eexists _, _. split_and!; eauto using big_step, big_step_of_val.
Qed.
@@ -771,26 +829,7 @@ Lemma sem_soundness Δ Γ e A :
TY Δ; Γ ⊢ e : A →
TY Δ; Γ ⊨ e ≈ e : A.
Proof.
- induction 1 as [ | Δ Γ x e A B Hsyn IH | Δ Γ e A B Hsyn IH| Δ Γ e A Hsyn IH| | | | | | | | | n Γ e1 e2 op A B C Hop ? ? ? ? | | | | | | | ]; eauto.
- - set (X := elements (dom (<[x := A]>Γ))).
- specialize (syn_typed_closed _ _ _ _ X Hsyn) as Hcl.
- eapply compat_lam_named; last done.
- + apply Hcl. apply elem_of_elements.
- + apply Hcl. apply elem_of_elements.
- + intros ??. by apply elem_of_elements.
- - set (X := elements (dom Γ)).
- specialize (syn_typed_closed _ _ _ _ X Hsyn) as Hcl.
- eapply compat_lam_anon; last done.
- + apply Hcl. apply elem_of_elements.
- + apply Hcl. apply elem_of_elements.
- + intros ??. by apply elem_of_elements.
- - set (X := elements (dom Γ)).
- specialize (syn_typed_closed _ _ _ _ X Hsyn) as Hcl.
- eapply compat_tlam; last done.
- + apply Hcl. rewrite dom_fmap. apply elem_of_elements.
- + apply Hcl. rewrite dom_fmap. apply elem_of_elements.
- + intros ??. by apply elem_of_elements.
- - inversion Hop; subst; eauto.
+ induction 1 as [ | Δ Γ x e A B Hsyn IH | Δ Γ e A B Hsyn IH| Δ Γ e A Hsyn IH| | | | | | | | | n Γ e1 e2 op A B C [] ? ? ? ? | | | | | | | ]; eauto.
Qed.
@@ -1016,20 +1055,8 @@ Lemma sem_typed_congruence Δ Δ' Γ Γ' e1 e2 C A B :
Proof.
intros ???.
induction 1; simpl; eauto using sem_soundness.
- - eapply compat_tlam; last eauto.
- + eapply pctx_typed_fill_closed; eauto.
- + eapply pctx_typed_fill_closed; eauto.
- + intros y. by rewrite elem_of_elements dom_fmap.
- inversion H2; subst; eauto using sem_soundness.
- inversion H2; subst; eauto using sem_soundness.
- - eapply compat_lam_named; last eauto.
- + eapply pctx_typed_fill_closed; eauto.
- + eapply pctx_typed_fill_closed; eauto.
- + intros y. by rewrite elem_of_elements.
- - eapply compat_lam_anon; last eauto.
- + eapply pctx_typed_fill_closed; eauto.
- + eapply pctx_typed_fill_closed; eauto.
- + intros y. by rewrite elem_of_elements.
Qed.
Lemma adequacy δ e1 e2: ℰ Int δ e1 e2 → ∃ n, big_step e1 n ∧ big_step e2 n.
@@ -1049,7 +1076,7 @@ Lemma sem_typing_ctx_equiv Δ Γ e1 e2 A :
closed (elements (dom Γ)) e2 →
TY Δ; Γ ⊨ e1 ≈ e2 : A → ctx_equiv Δ Γ e1 e2 A.
Proof.
- intros Hsem ? ? C Hty. eapply sem_typed_congruence in Hty; last done.
+ intros Hcl Hcl' Hsem C Hty. eapply sem_typed_congruence in Hty as (Htycl & Htycl' & Hty); last done.
all: try done.
opose proof* (Hty ∅ ∅ δ_any) as He; first constructor.
revert He. rewrite !subst_map_empty.
diff --git a/theories/type_systems/systemf/church_encodings_faithful.v b/theories/type_systems/systemf/church_encodings_faithful.v
new file mode 100644
index 0000000000000000000000000000000000000000..d28a947df307e63229f536e7502eb0a17c2120f0
--- /dev/null
+++ b/theories/type_systems/systemf/church_encodings_faithful.v
@@ -0,0 +1,273 @@
+From stdpp Require Import gmap base relations.
+From iris Require Import prelude.
+From semantics.lib Require Export facts.
+From semantics.ts.systemf Require Import lang notation parallel_subst types bigstep tactics binary_logrel.
+From semantics.ts.systemf Require church_encodings.
+
+Import church_encodings.
+
+
+(* we first prove some helpful lemmas *)
+
+Lemma big_step_bind e v w K:
+ big_step e v → big_step (fill K v) w → big_step (fill K e) w.
+Proof.
+ intros Hbs; induction K in w |-*; simpl.
+ { intros ->%big_step_val. done. }
+ all: inversion 1; subst; by econstructor; eauto.
+Qed.
+
+Lemma big_step_bind_inv e w K:
+ big_step (fill K e) w → ∃ v, big_step e v ∧ big_step (fill K v) w.
+Proof.
+ induction K in w |-*; simpl.
+ { intros ?; eexists _; split; first done. by eapply big_step_of_val. }
+ all: inversion 1; subst; edestruct IHK as [? [? ?]]; eauto.
+Qed.
+
+
+Lemma big_step_det e v w:
+ big_step e v → big_step e w → v = w.
+Proof.
+ induction 1 in w |-*; inversion 1; subst; eauto 2.
+ all: naive_solver.
+Qed.
+
+
+Lemma closure_under_reduction e1 e2 v1 v2 δ A:
+ big_step e1 v1 →
+ big_step e2 v2 →
+ 𝒱 A δ v1 v2 →
+ ℰ A δ e1 e2.
+Proof. simp type_interp. eauto. Qed.
+
+
+Lemma closure_under_partial_reduction e1 e2 v1 v2 K1 K2 δ A:
+ big_step e1 v1 →
+ big_step e2 v2 →
+ ℰ A δ (fill K1 v1) (fill K2 v2) →
+ ℰ A δ (fill K1 e1) (fill K2 e2).
+Proof.
+ simp type_interp. intros Hbs1 Hbs2 (v3 & v4 & Hbs3 & Hbs4 & Hty).
+ eexists _, _. eauto using big_step_bind.
+Qed.
+
+
+Lemma closure_under_expansion e1 e2 v1 v2 K1 K2 δ A:
+ big_step e1 v1 →
+ big_step e2 v2 →
+ ℰ A δ (fill K1 e1) (fill K2 e2) →
+ ℰ A δ (fill K1 v1) (fill K2 v2).
+Proof.
+ simp type_interp. intros Hbs1 Hbs2 (v3 & v4 & Hbs3 & Hbs4 & Hty).
+ eapply big_step_bind_inv in Hbs3 as [? [Hr1 Hbs3]].
+ eapply big_step_bind_inv in Hbs4 as [? [Hr2 Hbs4]].
+ eapply big_step_det in Hr1; last apply Hbs1.
+ eapply big_step_det in Hr2; last apply Hbs2.
+ subst. eauto.
+Qed.
+
+Lemma tforall_expand (v1 v2 v3 v4 : val) δ A:
+ (∀ τ, ℰ A (τ.:δ) (v1 <>) (v2 <>)) →
+ 𝒱 (∀: A) δ v1 v3 →
+ 𝒱 (∀: A) δ v2 v4 →
+ 𝒱 (∀: A) δ v1 v2.
+Proof.
+ simp type_interp.
+ intros Hty (e1 & e2 & -> & -> & Hc1 & Hc2 & Hty2) (e3 & e4 & -> & -> & Hc3 & Hc4 & Hty3).
+ eexists _, _. split_and!; eauto. intros τ. specialize (Hty τ).
+ revert Hty. simp type_interp.
+ intros (v1 & v2 & Hbs1 & Hbs2 & Hty).
+ inversion Hbs1; subst. inversion Hbs2; subst. inversion H0; subst. inversion H2; subst.
+ eexists _, _. split_and!; done.
+Qed.
+
+Lemma tforall_reduce v1 v2 δ A τ:
+ 𝒱 (∀: A) δ v1 v2 →
+ ℰ A (τ.:δ) (v1 <>) (v2 <>).
+Proof.
+ simp type_interp. intros (? & ? & -> & -> & ? & ? & Hty).
+ specialize (Hty τ). revert Hty.
+ simp type_interp. intros (? & ? & ? & ? & Hval).
+ eexists _, _. split_and!; eauto using big_step.
+Qed.
+
+
+Lemma fun_expand (e1 e2 e3 e4 : expr) δ A B:
+ (∀ v w, 𝒱 A δ v w → ℰ B δ (e1 v) (e2 w)) →
+ ℰ (A → B) δ e1 e3 →
+ ℰ (A → B) δ e4 e2 →
+ ℰ (A → B) δ e1 e2.
+Proof.
+ simp type_interp.
+ intros Hty (v1 & v3 & Hbs1 & Hbs3 & Hty13) (v2 & v4 & Hbs2 & Hbs4 & Hty24).
+ simp type_interp in Hty13. simp type_interp in Hty24.
+ destruct Hty13 as (x1 & x3 & e1' & e3' & -> & -> & Hc1 & Hc3 & _),
+ Hty24 as (x2 & x4 & e2' & e4' & -> & -> & Hc2 & Hc4 & _).
+ eexists _, _. split_and!; eauto. simp type_interp.
+ eexists _, _, _, _. split_and!; eauto.
+
+ intros v' w' Hty'. specialize (Hty _ _ Hty').
+ simp type_interp. simp type_interp in Hty.
+ destruct Hty as (v1 & v2 & Hbs1' & Hbs2' & Hval).
+ eexists _, _. split_and!; last done.
+ - eapply big_step_bind_inv with (K := AppLCtx HoleCtx v') in Hbs1' as [u1 [Hu1 Hu2]].
+ eapply big_step_det in Hu1; last by apply Hbs1.
+ subst u1. simpl in Hu2. inversion Hu2; subst. eapply big_step_val in H2. inversion H1; subst.
+ done.
+ - eapply big_step_bind_inv with (K := AppLCtx HoleCtx w') in Hbs2' as [u1 [Hu1 Hu2]].
+ eapply big_step_det in Hu1; last by apply Hbs4.
+ subst u1. simpl in Hu2. inversion Hu2; subst. eapply big_step_val in H2. inversion H1; subst.
+ done.
+Qed.
+
+
+Lemma fun_reduce e1 e2 δ A B:
+ ℰ (A → B) δ e1 e2 →
+ (∀ v w, 𝒱 A δ v w → ℰ B δ (e1 v) (e2 w)).
+Proof.
+ simp type_interp. intros (? & ? & Hbs1 & Hbs2 & Hty) v w Hval.
+ simp type_interp in Hty. destruct Hty as (? & ? & e1' & e3' & -> & -> & ? & ? & Hrest).
+ specialize (Hrest _ _ Hval).
+ simp type_interp in Hrest.
+ destruct Hrest as (v' & w' & ? & ? & Hval').
+ simp type_interp. eexists _, _; split_and!; eauto using big_step, big_step_of_val.
+Qed.
+
+
+Lemma bind e1 e2 K1 K2 δ δ' A B:
+ ℰ A δ e1 e2 →
+ (∀ v w, 𝒱 A δ v w → ℰ B δ' (fill K1 v) (fill K2 w)) →
+ ℰ B δ' (fill K1 e1) (fill K2 e2).
+Proof.
+ simp type_interp. intros (v & w & Hbs1 & Hbs2 & Hty) Hcont.
+ specialize (Hcont v w Hty). simp type_interp in Hcont.
+ destruct Hcont as (v' & w' & Hbs1' & Hbs2' & Hcont).
+ eexists _, _. split_and!; eauto using big_step_bind.
+Qed.
+
+(* faithfulness of bool *)
+
+Definition eta_bool (e: expr) : expr :=
+ e <> bool_true bool_false.
+
+
+Lemma bool_type_full (v w f g : val) δ :
+ closed [] v →
+ closed [] w →
+ type_interp (inj_val f g) bool_type δ →
+ ∃ b, (b = v ∨ b = w) ∧ (big_step (f <> v w) b ∧ big_step (g <> v w) b).
+Proof.
+ intros Hc1 Hc2.
+ rewrite /bool_type. simp type_interp.
+ intros (e1 & e2 & -> & -> & Hcl1 & Hcl2 & Hty).
+ specialize_sem_type Hty with (λ u1 u2, (u1 = u2 ∧ u2 = v) ∨ (u1 = u2 ∧ u2 = w)) as B.
+ { intros u1 u2 [[-> ->]|[-> ->]]; split; done. }
+ simp type_interp in Hty. destruct Hty as (u3 & u4 & Hbs1 & Hbs2 & Hu34).
+ simp type_interp in Hu34. destruct Hu34 as (x1 & x1' & e3 & e3' & -> & -> & ? & ? & Hty).
+ opose proof* (Hty v v) as Hty; first simp type_interp; simpl; eauto.
+
+ simp type_interp in Hty. destruct Hty as (u5 & u6 & Hbs3 & Hbs4 & Hu56).
+ simp type_interp in Hu56. destruct Hu56 as (x2 & x2' & e4 & e4' & -> & -> & ? & ? & Hty).
+ opose proof* (Hty w w) as Hty; first simp type_interp; simpl; eauto.
+
+ simp type_interp in Hty. destruct Hty as (u7 & u8 & Hbs5 & Hbs6 & Hu78).
+ simp type_interp in Hu78. simpl in Hu78. destruct Hu78 as [[-> ->] | [-> ->]].
+ - exists v. split; first naive_solver.
+ split; repeat econstructor; eauto using big_step_of_val.
+ - exists w. split; first naive_solver.
+ split; repeat econstructor; eauto using big_step_of_val.
+Qed.
+
+
+Lemma bool_true_sem_bool δ: 𝒱 bool_type δ bool_true bool_true.
+Proof.
+ assert (TY 0; ∅ ⊢ bool_true: bool_type) as Hty by solve_typing.
+ eapply sem_soundness in Hty as (Htycl1 & Htycl2 & Hty).
+ opose proof* (Hty ∅ ∅ δ) as Hty; first constructor.
+ by eapply sem_expr_rel_of_val.
+Qed.
+
+Lemma bool_false_sem_bool δ: 𝒱 bool_type δ bool_false bool_false.
+Proof.
+ assert (TY 0; ∅ ⊢ bool_false: bool_type) as Hty by solve_typing.
+ eapply sem_soundness in Hty as (Htycl1 & Htycl2 & Hty).
+ opose proof* (Hty ∅ ∅ δ) as Hty; first constructor.
+ by eapply sem_expr_rel_of_val.
+Qed.
+
+
+Lemma bool_faithful Δ Γ e:
+ TY Δ; Γ ⊢ e: bool_type → ctx_equiv Δ Γ e (eta_bool e) bool_type.
+Proof.
+ intros Hty. eapply soundness_wrt_ctx_equiv; [solve_typing..].
+ split_and!. 1-2: apply syn_typed_closed in Hty; naive_solver.
+ intros θ1 θ2 δ Hctx. eapply sem_soundness in Hty as (Htycl1 & Htycl2 & Hty).
+ specialize (Hty θ1 θ2 δ Hctx). simp type_interp in Hty.
+ replace (subst_map θ2 (eta_bool e)) with (eta_bool (subst_map θ2 e)); last first.
+ { simpl; rewrite lookup_delete_ne //= !lookup_delete //. }
+ destruct Hty as (v1 & v2 & Hbs1 & Hbs2 & Hty).
+ eapply closure_under_partial_reduction with (K1 := HoleCtx) (K2:= (AppLCtx (AppLCtx (TAppCtx HoleCtx) bool_true) bool_false)); eauto.
+ simpl; change (v2 <> _ _)%E with (eta_bool v2). clear Hctx Hbs1 Hbs2.
+
+
+ generalize Hty=> Hfull.
+ eapply (bool_type_full bool_true bool_false) in Hfull; [|done..].
+ destruct Hfull as (b & Hopt & Hv1b & Hv2b).
+ eapply closure_under_reduction; eauto using big_step_of_val.
+
+ assert (𝒱 bool_type δ b b) as Hb.
+ { destruct Hopt; subst; eauto using bool_true_sem_bool, bool_false_sem_bool. }
+
+ eapply tforall_expand; eauto.
+
+ intros R. generalize Hty=>Hty'.
+
+ (* we have to evaluate these assumptions along the way *)
+ rewrite /bool_type in Hb, Hty'.
+ eapply tforall_reduce with (τ := R) in Hb.
+ eapply tforall_reduce with (τ := R) in Hty'.
+
+ eapply fun_expand; eauto.
+ intros a1 a2 Ha12.
+ eapply fun_reduce in Hb; last done.
+ eapply fun_reduce in Hty'; last done.
+
+ eapply fun_expand; eauto.
+ intros b1 b2 Hb12.
+ simp type_interp in Ha12; simpl in Ha12.
+ simp type_interp in Hb12; simpl in Hb12.
+ clear Hb Hty'.
+
+ eapply closure_under_expansion with
+ (K1:= (AppLCtx (AppLCtx (TAppCtx HoleCtx) a1) b1))
+ (K2:= (AppLCtx (AppLCtx (TAppCtx HoleCtx) a2) b2));
+ [by eapply big_step_of_val | eapply Hv2b|]; cbn [fill].
+
+ pose_sem_type (λ v w, (v = a1 ∧ w = bool_true) ∨ (v = b1 ∧ w = bool_false)) as τ.
+ { apply sem_type_closed_val in Ha12, Hb12. naive_solver. }
+
+ eapply bind with
+ (K1 := HoleCtx)
+ (K2 := AppLCtx (AppLCtx (TAppCtx HoleCtx) a2) b2)
+ (A := (#0)%ty)
+ (δ := τ.:δ).
+ { eapply fun_reduce.
+ eapply fun_reduce.
+ eapply tforall_reduce.
+ exact Hty.
+ - simp type_interp. simpl. auto.
+ - simp type_interp. simpl. auto. }
+ simpl. intros v w Hty'. simp type_interp in Hty'. simpl in Hty'.
+ destruct Hty' as [[-> ->]|[-> ->]].
+ - simp type_interp. exists a1, a2. split_and!.
+ + by apply big_step_of_val.
+ + simpl. bs_step_det.
+ rewrite subst_is_closed_nil; first by apply big_step_of_val.
+ apply sem_type_closed_val in Ha12. naive_solver.
+ + simp type_interp.
+ - simp type_interp. exists b1, b2. split_and!.
+ + by apply big_step_of_val.
+ + simpl. bs_step_det. by apply big_step_of_val.
+ + simp type_interp.
+Qed.
diff --git a/theories/type_systems/systemf/exercises03.v b/theories/type_systems/systemf/exercises03.v
index ef04b8e87c3e2f5b67247494c1f56f21adcb682e..13725fb34ddd079f05fdb33a057923ca0fc177ac 100644
--- a/theories/type_systems/systemf/exercises03.v
+++ b/theories/type_systems/systemf/exercises03.v
@@ -5,36 +5,52 @@ From semantics.ts.systemf Require Import lang notation types tactics.
(** Exercise 3 (LN Exercise 22): Universal Fun *)
Definition fun_comp : val :=
- #0 (* FIXME *).
+ #0 (* TODO *).
Definition fun_comp_type : type :=
- Int (* FIXME *).
+ #0 (* TODO *).
Lemma fun_comp_typed :
TY 0; ∅ ⊢ fun_comp : fun_comp_type.
-Proof. solve_typing. Qed.
+Proof.
+ (* should be solved by solve_typing. *)
+ (* TODO: exercise *)
+Admitted.
+
Definition swap_args : val :=
- #0 (* FIXME *).
+ #0 (* TODO *).
Definition swap_args_type : type :=
- Int (* FIXME *).
+ #0 (* TODO *).
Lemma swap_args_typed :
TY 0; ∅ ⊢ swap_args : swap_args_type.
-Proof. solve_typing. Qed.
+Proof.
+ (* should be solved by solve_typing. *)
+ (* TODO: exercise *)
+Admitted.
+
Definition lift_prod : val :=
- #0 (* FIXME *).
+ #0 (* TODO *).
Definition lift_prod_type : type :=
- Int (* FIXME *).
+ #0 (* TODO *).
Lemma lift_prod_typed :
TY 0; ∅ ⊢ lift_prod : lift_prod_type.
-Proof. solve_typing. Qed.
+Proof.
+ (* should be solved by solve_typing. *)
+ (* TODO: exercise *)
+Admitted.
+
Definition lift_sum : val :=
- #0 (* FIXME *).
+ #0 (* TODO *).
Definition lift_sum_type : type :=
- Int (* FIXME *).
+ #0 (* TODO *).
Lemma lift_sum_typed :
TY 0; ∅ ⊢ lift_sum : lift_sum_type.
-Proof. solve_typing. Qed.
+Proof.
+ (* should be solved by solve_typing. *)
+ (* TODO: exercise *)
+Admitted.
+
(** Exercise 5 (LN Exercise 18): Named to De Bruijn *)
Inductive ptype : Type :=
@@ -58,58 +74,27 @@ Notation "∃: x , τ" :=
(at level 100, τ at level 200) : PType_scope.
Fixpoint debruijn (m: gmap string nat) (A: ptype) : option type :=
- None (* FIXME *).
+ None (* FIXME *).
(* Example *)
Goal debruijn ∅ (∀: "x", ∀: "y", "x" → "y")%pty = Some (∀: ∀: #1 → #0)%ty.
Proof.
- (*reflexivity.*)
-(*Qed.*)
+ (* Should be solved by reflexivity. *)
+ (* TODO: exercise *)
Admitted.
+
Goal debruijn ∅ (∀: "x", "x" → ∀: "y", "y")%pty = Some (∀: #0 → ∀: #0)%ty.
Proof.
- (*reflexivity.*)
-(*Qed.*)
+ (* Should be solved by reflexivity. *)
+ (* TODO: exercise *)
Admitted.
+
Goal debruijn ∅ (∀: "x", "x" → ∀: "y", "x")%pty = Some (∀: #0 → ∀: #1)%ty.
Proof.
- (*reflexivity.*)
-(*Qed.*)
+ (* Should be solved by reflexivity. *)
+ (* TODO: exercise *)
Admitted.
-(** Exercise 7 (LN Exercise 19): De Bruijn Terms *)
-Module dbterm.
- (** Your type of expressions only needs to encompass the operations of our base lambda calculus. *)
- Inductive expr :=
- | Lit (l : base_lit)
- | Var (n : nat)
- | Lam (e : expr)
- | Plus (e1 e2 : expr)
- | App (e1 e2 : expr)
- .
-
- (** Formalize substitutions and renamings as functions. *)
- Definition subt := nat → expr.
- Definition rent := nat → nat.
-
- Implicit Types
- (σ : subt)
- (δ : rent)
- (n x : nat)
- (e : expr).
-
- Fixpoint subst σ e :=
- (* FIXME *) e.
-
- Compute (subst
- (λ n, match n with
- | 0 => Lit (LitInt 42)
- | 1 => Var 0
- | _ => Var n
- end)
- (Lam (Plus (Plus (Var 2) (Var 1)) (Var 0)))).
- (*FIXME: should produce [Lam (Plus (Plus (Var 1) (Lit 42%Z)) (Var 0))] *)
-
-End dbterm.
+
diff --git a/theories/type_systems/systemf/exercises04.v b/theories/type_systems/systemf/exercises04.v
index 7b450fd08321d93d2be1381247c16710d4fe7f3f..df39922e43398336fcdf8ea64d5e730fe6eed481 100644
--- a/theories/type_systems/systemf/exercises04.v
+++ b/theories/type_systems/systemf/exercises04.v
@@ -2,10 +2,54 @@ From stdpp Require Import gmap base relations.
From iris Require Import prelude.
From semantics.ts.systemf Require Import lang notation parallel_subst types logrel tactics.
+(** Exercise 1 (LN Exercise 19): De Bruijn Terms *)
+Module dbterm.
+ (** Your type of expressions only needs to encompass the operations of our base lambda calculus. *)
+ Inductive expr :=
+ | Lit (l : base_lit)
+ | Var (n : nat)
+ | Lam (e : expr)
+ | Plus (e1 e2 : expr)
+ | App (e1 e2 : expr)
+ .
+
+ (** Formalize substitutions and renamings as functions. *)
+ Definition subt := nat → expr.
+ Definition rent := nat → nat.
+
+ Implicit Types
+ (σ : subt)
+ (δ : rent)
+ (n x : nat)
+ (e : expr).
+
+ Fixpoint subst σ e :=
+ (* FIXME *) e.
+
+
+
+ Goal (subst
+ (λ n, match n with
+ | 0 => Lit (LitInt 42)
+ | 1 => Var 0
+ | _ => Var n
+ end)
+ (Lam (Plus (Plus (Var 2) (Var 1)) (Var 0)))) =
+ Lam (Plus (Plus (Var 1) (Lit 42%Z)) (Var 0)).
+ Proof.
+ cbn.
+ (* Should be by reflexivity. *)
+ (* TODO: exercise *)
+ Admitted.
+
+
+End dbterm.
+
Section church_encodings.
- (** Exercise 1 (LN Exercise 24): Church encoding, sum types *)
+ (** Exercise 2 (LN Exercise 24): Church encoding, sum types *)
(* a) Define your encoding *)
Definition sum_type (A B : type) : type := #0 (* FIXME *).
+
(* b) Implement inj1, inj2, case *)
Definition injl_val (v : val) : val := #0 (* FIXME *).
@@ -14,8 +58,8 @@ Section church_encodings.
Definition injr_expr (e : expr) : expr := #0 (* FIXME *).
(* You may want to use the variables x1, x2 for the match arms to fit the typing statements below. *)
- Definition match_expr (e : expr) (e1 e2 : expr) : expr :=
- #0 (* FIXME *).
+ Definition match_expr (e : expr) (e1 e2 : expr) : expr := #0. (* FIXME *)
+
(* c) Reduction behavior *)
(* Some lemmas about substitutions might be useful. Look near the end of the lang.v file! *)
@@ -26,10 +70,10 @@ Section church_encodings.
big_step (subst' "x1" vl e1) v' →
big_step (match_expr e e1 e2) v'.
Proof.
- (* FIXME *)
- (*Qed.*)
+ (* TODO: exercise *)
Admitted.
+
Lemma match_expr_red_injr e e1 e2 (vl v' : val) :
is_closed [] vl →
big_step e (injr_val vl) →
@@ -37,26 +81,29 @@ Section church_encodings.
big_step (match_expr e e1 e2) v'.
Proof.
intros. bs_step_det.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
Lemma injr_expr_red e v :
big_step e v →
big_step (injr_expr e) (injr_val v).
Proof.
intros. bs_step_det.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
Lemma injl_expr_red e v :
big_step e v →
big_step (injl_expr e) (injl_val v).
Proof.
intros. bs_step_det.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
(* d) Typing rules *)
Lemma sum_injl_typed n Γ (e : expr) A B :
type_wf n B →
@@ -65,9 +112,10 @@ Section church_encodings.
TY n; Γ ⊢ injl_expr e : sum_type A B.
Proof.
intros. solve_typing.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
Lemma sum_injr_typed n Γ e A B :
type_wf n B →
type_wf n A →
@@ -75,9 +123,10 @@ Section church_encodings.
TY n; Γ ⊢ injr_expr e : sum_type A B.
Proof.
intros. solve_typing.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
Lemma sum_match_typed n Γ A B C e e1 e2 :
type_wf n A →
type_wf n B →
@@ -88,27 +137,32 @@ Section church_encodings.
TY n; Γ ⊢ match_expr e e1 e2 : C.
Proof.
intros. solve_typing.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
- (** Exercise 2 (LN Exercise 25): church encoding, list types *)
+
+
+ (** Exercise 3 (LN Exercise 25): church encoding, list types *)
+
+ (* a) translate the type of lists into De Bruijn. *)
Definition list_type (A : type) : type := #0 (* FIXME *).
+
- (* a) Implement nil and cons. *)
+ (* b) Implement nil and cons. *)
Definition nil_val : val := #0 (* FIXME *).
Definition cons_val (v1 v2 : val) : val := #0 (* FIXME *).
- Definition cons_expr (e1 e2 : expr) : expr :=
- #0 (* FIXME *).
+ Definition cons_expr (e1 e2 : expr) : expr := #0 (* FIXME *).
- (* b) Define typing rules and prove them *)
+ (* c) Define typing rules and prove them *)
Lemma nil_typed n Γ A :
type_wf n A →
TY n; Γ ⊢ nil_val : list_type A.
Proof.
intros. solve_typing.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
Lemma cons_typed n Γ (e1 e2 : expr) A :
type_wf n A →
TY n; Γ ⊢ e2 : list_type A →
@@ -116,32 +170,37 @@ Section church_encodings.
TY n; Γ ⊢ cons_expr e1 e2 : list_type A.
Proof.
intros. repeat solve_typing.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
- (* c) Define a function head of type list A → A + 1 *)
- Definition head_expr : val := #0 (* FIXME *).
+
+ (* d) Define a function head of type list A → A + 1 *)
+ Definition head : val := #0 (* FIXME *).
+
Lemma head_typed n Γ A :
type_wf n A →
- TY n; Γ ⊢ head_expr : (list_type A → (A + Unit)).
+ TY n; Γ ⊢ head: (list_type A → (A + Unit)).
Proof.
intros. solve_typing.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
- (* d) Define a function [tail] of type list A → list A *)
- Definition tail_val : val :=
- #0 (* FIXME *).
+
+ (* e) Define a function [tail] of type list A → list A *)
+
+ Definition tail : val := #0 (* FIXME *).
+
Lemma tail_typed n Γ A :
type_wf n A →
- TY n; Γ ⊢ tail_val : (list_type A → list_type A).
+ TY n; Γ ⊢ tail: (list_type A → list_type A).
Proof.
intros. repeat solve_typing.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
End church_encodings.
Section free_theorems.
@@ -151,44 +210,52 @@ Section free_theorems.
Lemma free_thm_1 :
∀ f : val,
TY 0; ∅ ⊢ f : (∀: ∀: #1 → #0 → #1 × #0) →
- True. (* FIXME: state your free theorem *)
+ True (* FIXME state your theorem *).
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
(* b) State a free theorem for the type ∀ α, β. α × β → α *)
Lemma free_thm_2 :
∀ f : val,
TY 0; ∅ ⊢ f : (∀: ∀: #1 × #0 → #1) →
- True. (* FIXME: state your free theorem *)
+ True (* FIXME state your theorem *).
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
(* c) State a free theorem for the type ∀ α, β. α → β *)
Lemma free_thm_3 :
∀ f : val,
TY 0; ∅ ⊢ f : (∀: ∀: #1 → #0) →
- True (* FIXME *).
+ True (* FIXME state your theorem *).
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
- (** Exercise 5 (LN Exercise 28): Fre Theorems II *)
+
+ (** Exercise 5 (LN Exercise 28): Free Theorems II *)
Lemma free_theorem_either :
∀ f : val,
TY 0; ∅ ⊢ f : (∀: #0 → #0 → #0) →
∀ (v1 v2 : val), is_closed [] v1 → is_closed [] v2 →
big_step (f <> v1 v2) v1 ∨ big_step (f <> v1 v2) v2.
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
(** Exercise 6 (LN Exercise 29): Free Theorems III *)
- (* Hint: you might want to use the fact that our reduction is deterministic.
- However, if you do so, be sure to state this fact formally and prove it.
- *)
+ (* Hint: you might want to use the fact that our reduction is deterministic. *)
+ Lemma big_step_det e v1 v2 :
+ big_step e v1 → big_step e v2 → v1 = v2.
+ Proof.
+ induction 1 in v2 |-*; inversion 1; subst; eauto 2.
+ all: naive_solver.
+ Qed.
Lemma free_theorems_magic :
∀ (A A1 A2 : type) (f g : val),
@@ -199,13 +266,14 @@ Section free_theorems.
∀ v, big_step (f <> g) v →
∃ (v1 v2 : val), big_step (g v1 v2) v.
Proof.
- (* TODO *)
(* Hint: you may find the following lemmas useful:
- [sem_val_rel_cons]
- [type_wf_closed]
- [val_rel_is_closed]
- [big_step_preserve_closed]
*)
- Abort.
+ (* TODO: exercise *)
+ Admitted.
+
End free_theorems.
diff --git a/theories/type_systems/systemf/exercises05.v b/theories/type_systems/systemf/exercises05.v
index 3b157274ea19d0ca4be5206f3ea63ec01fade8b8..b5b241564d003f03675ef1ac39120597de991f01 100644
--- a/theories/type_systems/systemf/exercises05.v
+++ b/theories/type_systems/systemf/exercises05.v
@@ -47,34 +47,33 @@ Section existential.
TY n; <[x := A]> (<[f := (A → B)%ty]> Γ) ⊢ e : B →
TY n; Γ ⊢ (fix: f x := e) : (A → B)).
- Definition ISET : type :=
- #0. (* FIXME: your definition *)
+ Definition ISET : type :=#0. (* TODO: your definition *)
(* We represent sets as functions of type ((Int → Bool) × Int × Int),
storing the mapping, the minimum value, and the maximum value. *)
+
- Definition iset : val :=
- #0. (* FIXME: your definition *)
-
+ Definition iset : val :=#0. (* TODO: your definition *)
Lemma iset_typed n Γ : TY n; Γ ⊢ iset : ISET.
Proof.
- (* FIXME *)
- (*Qed.*)
+ (* HINT: use repeated solve_typing with an explicit apply fix_typing inbetween *)
+ (* TODO: exercise *)
Admitted.
- Definition ISETE : type :=
- #0 (* FIXME *).
- Definition add_equality : val :=
- #0. (* FIXME *)
+ Definition ISETE : type :=#0. (* TODO: your definition *)
+
+ Definition add_equality : val :=#0. (* TODO: your definition *)
Lemma add_equality_typed n Γ : TY n; Γ ⊢ add_equality : (ISET → ISETE)%ty.
Proof.
repeat solve_typing.
- (*Qed.*)
+ (* Qed. *)
+ (* TODO: exercise *)
Admitted.
+
End existential.
Section ex4.
@@ -99,21 +98,21 @@ Context (even_dec : val).
Context (even_dec_typed : ∀ n Γ, TY n; Γ ⊢ even_dec : (Int → Bool)).
(* a) Change [even_impl] to [even_impl_instrumented] such that [toint] asserts evenness of the argument before returned.
-You may use the [assert] expression.
+You may use the [assert] expression defined in existential_invariants.v.
*)
-Definition even_impl_instrumented : val :=
- #0. (* FIXME *)
+Definition even_impl_instrumented : val :=#0. (* TODO: your definition *)
(* b) Prove that [even_impl_instrumented] is safe. You may assume that even works as intended,
but be sure to state this here. *)
+
Lemma even_impl_instrumented_safe δ:
𝒱 even_type δ even_impl_instrumented.
Proof.
- (* FIXME *)
-(*Qed.*)
+ (* TODO: exercise *)
Admitted.
+
End ex4.
(** ** Exercise 5 (LN Exercise 31): Abstract sums *)
@@ -134,10 +133,13 @@ Definition sum_ex_impl : val :=
Lemma sum_ex_safe A B δ:
𝒱 (sum_ex_type A B) δ sum_ex_impl.
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
End ex5.
+(** For Exercise 6 and 7, see binary_logrel.v *)
+
(** ** Exercise 8 (LN Exercise 35): Contextual equivalence *)
Section ex8.
Import binary_logrel.
@@ -160,7 +162,8 @@ Qed.
Lemma sum_ex_impl_equiv n Γ A B :
ctx_equiv n Γ sum_ex_impl' sum_ex_impl (sum_ex_type A B).
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
End ex8.
diff --git a/theories/type_systems/systemf/free_theorems.v b/theories/type_systems/systemf/free_theorems.v
index 1164aa4489199cc936324723e89aced261e5bdf7..a649148e81df987337eab7023c8da42687301a10 100644
--- a/theories/type_systems/systemf/free_theorems.v
+++ b/theories/type_systems/systemf/free_theorems.v
@@ -15,7 +15,7 @@ Implicit Types
Lemma not_every_type_inhabited : ¬ ∃ e, TY 0; ∅ ⊢ e : (∀: #0).
Proof.
- intros (e & Hty%sem_soundness).
+ intros (e & [Htycl Hty]%sem_soundness).
specialize (Hty ∅ δ_any). simp type_interp in Hty.
destruct Hty as (v & Hb & Hv).
{ constructor. }
@@ -32,7 +32,7 @@ Lemma all_identity :
TY 0; ∅ ⊢ e : (∀: #0 → #0) →
∀ v, is_closed [] v → big_step (e <> (of_val v)) v.
Proof.
- intros e Hty%sem_soundness v0 Hcl_v0.
+ intros e [Htycl Hty]%sem_soundness v0 Hcl_v0.
specialize (Hty ∅ δ_any). simp type_interp in Hty.
destruct Hty as (v & Hb & Hv).
{ constructor. }
diff --git a/theories/type_systems/systemf/logrel.v b/theories/type_systems/systemf/logrel.v
index 0fdffae31ef675fe5a369b519f6f917f255dcd15..a8757cfeba95165a018d503bc884296b14f05352 100644
--- a/theories/type_systems/systemf/logrel.v
+++ b/theories/type_systems/systemf/logrel.v
@@ -15,20 +15,27 @@ Implicit Types
(e : expr)
(A : type).
-(** ** Definition of the logrel *)
-(**
- In Coq, we need to make argument why the logical relation is well-defined precise:
- This holds true in particular for the mutual recursion between the value relation and the expression relation.
- We therefore define a termination measure [mut_measure] that makes sure that for each recursive call, we either
- - decrease the size of the type
- - or switch from the expression case to the value case.
-
- We use the Equations package to define the logical relation, as it's tedious to make the termination
- argument work with Coq's built-in support for recursive functions.
+(* *** Definition of the logical relation. *)
+(* In Coq, we need to make argument why the logical relation is well-defined
+ precise:
+ In particular, we need to show that the mutual recursion between the value
+ relation and the expression relation, which are defined in terms of each
+ other, terminates. We therefore define a termination measure [mut_measure]
+ that makes sure that for each recursive call, we either decrease the size of
+ the type or switch from the expression case to the value case.
+
+ We use the Equations package to define the logical relation, as it's tedious
+ to make the termination argument work with Coq's built-in support for
+ recursive functions---but under the hood, Equations also just encodes it as
+ a Coq Fixpoint.
*)
-Inductive type_case : Set :=
- | expr_case | val_case.
+Inductive val_or_expr : Type :=
+| inj_val : val → val_or_expr
+| inj_expr : expr → val_or_expr.
+(* The [type_size] function essentially computes the size of the "type tree". *)
+(* Note that we have added some additional primitives to make our (still
+ simple) language more expressive. *)
Equations type_size (A : type) : nat :=
type_size Int := 1;
type_size Bool := 1;
@@ -38,12 +45,11 @@ Equations type_size (A : type) : nat :=
type_size (∀: A) := type_size A + 2;
type_size (∃: A) := type_size A + 2;
type_size (A × B) := type_size A + type_size B + 1;
- type_size (A + B) := max (type_size A) (type_size B) + 1
-.
-
-Equations mut_measure (c : type_case) A : nat :=
- mut_measure expr_case A := 1 + type_size A;
- mut_measure val_case A := type_size A.
+ type_size (A + B) := max (type_size A) (type_size B) + 1.
+(* The definition of the expression relation uses the value relation -- therefore, it needs to be larger, and we add [1]. *)
+Equations mut_measure (ve : val_or_expr) (t : type) : nat :=
+ mut_measure (inj_val _) t := type_size t;
+ mut_measure (inj_expr _) t := 1 + type_size t.
(** A semantic type consists of a value-predicate and a proof of closedness *)
Record sem_type := mk_ST {
@@ -68,41 +74,40 @@ Tactic Notation "specialize_sem_type" constr(S) "with" uconstr(P) "as" ident(N)
Definition tyvar_interp := nat → sem_type.
Implicit Types
(δ : tyvar_interp)
- (τ : sem_type)
-.
+ (τ : sem_type).
(** The logical relation *)
-Equations type_interp (c : type_case) (t : type) δ (v : match c with val_case => val | expr_case => expr end) : Prop by wf (mut_measure c t) := {
- type_interp val_case Int δ v=>
+Equations type_interp (c : val_or_expr) (t : type) δ : Prop by wf (mut_measure c t) := {
+ type_interp (inj_val v) Int δ =>
∃ z : Z, v = #z ;
- type_interp val_case Bool δ v =>
+ type_interp (inj_val v) Bool δ =>
∃ b : bool, v = #b ;
- type_interp val_case Unit δ v =>
+ type_interp (inj_val v) Unit δ =>
v = #LitUnit ;
- type_interp val_case (A × B) δ v =>
- ∃ v1 v2 : val, v = (v1, v2)%V ∧ type_interp val_case A δ v1 ∧ type_interp val_case B δ v2;
- type_interp val_case (A + B) δ v =>
- (∃ v' : val, v = InjLV v' ∧ type_interp val_case A δ v') ∨
- (∃ v' : val, v = InjRV v' ∧ type_interp val_case B δ v');
- type_interp val_case (A → B) δ v =>
+ type_interp (inj_val v) (A × B) δ =>
+ ∃ v1 v2 : val, v = (v1, v2)%V ∧ type_interp (inj_val v1) A δ ∧ type_interp (inj_val v2) B δ;
+ type_interp (inj_val v) (A + B) δ =>
+ (∃ v' : val, v = InjLV v' ∧ type_interp (inj_val v') A δ) ∨
+ (∃ v' : val, v = InjRV v' ∧ type_interp (inj_val v') B δ);
+ type_interp (inj_val v) (A → B) δ =>
∃ x e, v = LamV x e ∧ is_closed (x :b: nil) e ∧
∀ v',
- type_interp val_case A δ v' →
- type_interp expr_case B δ (subst' x (of_val v') e);
+ type_interp (inj_val v') A δ →
+ type_interp (inj_expr (subst' x (of_val v') e)) B δ;
(** Type variable case *)
- type_interp val_case (#α) δ v =>
+ type_interp (inj_val v) (#α) δ =>
(δ α).(sem_type_car) v;
(** ∀ case *)
- type_interp val_case (∀: A) δ v =>
+ type_interp (inj_val v) (∀: A) δ =>
∃ e, v = TLamV e ∧ is_closed [] e ∧
- ∀ τ, type_interp expr_case A (τ .: δ) e;
+ ∀ τ, type_interp (inj_expr e) A (τ .: δ);
(** ∃ case *)
- type_interp val_case (∃: A) δ v =>
+ type_interp (inj_val v) (∃: A) δ =>
∃ v', v = PackV v' ∧
- ∃ τ : sem_type, type_interp val_case A (τ .: δ) v';
+ ∃ τ : sem_type, type_interp (inj_val v') A (τ .: δ);
- type_interp expr_case t δ e =>
- ∃ v, big_step e v ∧ type_interp val_case t δ v
+ type_interp (inj_expr e) t δ =>
+ ∃ v, big_step e v ∧ type_interp (inj_val v) t δ
}.
Next Obligation. repeat simp mut_measure; simp type_size; lia. Qed.
Next Obligation. repeat simp mut_measure; simp type_size; lia. Qed.
@@ -117,57 +122,87 @@ Next Obligation. repeat simp mut_measure; simp type_size; lia. Qed.
Next Obligation. repeat simp mut_measure; simp type_size; lia. Qed.
(** Value relation and expression relation *)
-Definition sem_val_rel A δ v := type_interp val_case A δ v.
-Definition sem_expr_rel A δ e := type_interp expr_case A δ e.
+Notation sem_val_rel A δ v := (type_interp (inj_val v) A δ).
+Notation sem_expr_rel A δ e := (type_interp (inj_expr e) A δ).
-Notation 𝒱 := sem_val_rel.
-Notation ℰ := sem_expr_rel.
+Notation 𝒱 A δ v := (sem_val_rel A δ v).
+Notation ℰ A δ v := (sem_expr_rel A δ v).
-Lemma sem_expr_rel_of_val A δ v :
- ℰ A δ (of_val v) → 𝒱 A δ v.
-Proof.
- simp type_interp.
- intros (v' & ->%big_step_val & Hv').
- apply Hv'.
-Qed.
-Lemma val_rel_is_closed v δ A:
+(* *** Semantic typing of contexts *)
+Implicit Types
+ (θ : gmap string expr).
+Inductive sem_context_rel (δ : tyvar_interp) : typing_context → (gmap string expr) → Prop :=
+ | sem_context_rel_empty : sem_context_rel δ ∅ ∅
+ | sem_context_rel_insert Γ θ v x A :
+ 𝒱 A δ v →
+ sem_context_rel δ Γ θ →
+ sem_context_rel δ (<[x := A]> Γ) (<[x := of_val v]> θ).
+
+Notation 𝒢 := sem_context_rel.
+
+
+
+(* Semantic typing judgement *)
+Definition sem_typed Δ Γ e A :=
+ is_closed (elements (dom Γ)) e ∧
+ ∀ θ δ, 𝒢 δ Γ θ → ℰ A δ (subst_map θ e).
+Notation "'TY' Δ ; Γ ⊨ e : A" := (sem_typed Δ Γ e A) (at level 74, e, A at next level).
+
+
+Lemma val_rel_closed v δ A:
𝒱 A δ v → is_closed [] (of_val v).
Proof.
induction A as [ | | | | | A IHA | | A IH1 B IH2 | A IH1 B IH2] in v, δ |-*; simp type_interp.
- - by eapply sem_type_closed_val.
+ - eapply sem_type_closed_val.
- intros [z ->]. done.
- intros [b ->]. done.
- intros ->. done.
- intros (e & -> & ? & _). done.
- intros (v' & -> & (τ & Hinterp)). simpl. by eapply IHA.
- intros (x & e & -> & ? & _). done.
- - intros (v1 & v2 & -> & ? & ?). simpl; apply andb_True; split; eauto.
+ - intros (v1 & v2 & -> & ? & ?). simpl. apply andb_True. eauto.
- intros [(v' & -> & ?) | (v' & -> & ?)]; simpl; eauto.
Qed.
(** Interpret a syntactic type *)
Program Definition interp_type A δ : sem_type := {|
- sem_type_car := 𝒱 A δ;
+ sem_type_car := fun v => 𝒱 A δ v;
|}.
-Next Obligation. by eapply val_rel_is_closed. Qed.
+Next Obligation. by eapply val_rel_closed. Qed.
-(* Semantic typing of contexts *)
-Implicit Types
- (θ : gmap string expr).
-(** Context relation *)
-Inductive sem_context_rel (δ : tyvar_interp) : typing_context → (gmap string expr) → Prop :=
- | sem_context_rel_empty : sem_context_rel δ ∅ ∅
- | sem_context_rel_insert Γ θ v x A :
- 𝒱 A δ v →
- sem_context_rel δ Γ θ →
- sem_context_rel δ (<[x := A]> Γ) (<[x := of_val v]> θ).
+(* We start by proving a couple of helper lemmas that will be useful later. *)
-Notation 𝒢 := sem_context_rel.
+Lemma sem_expr_rel_of_val A δ v :
+ ℰ A δ (of_val v) → 𝒱 A δ v.
+Proof.
+ simp type_interp.
+ intros (v' & ->%big_step_val & Hv').
+ apply Hv'.
+Qed.
+Lemma val_inclusion A δ v:
+ 𝒱 A δ v → ℰ A δ v.
+Proof.
+ intros H. simp type_interp. eauto using big_step_of_val.
+Qed.
-Lemma sem_context_rel_vals {δ Γ θ x A} :
- sem_context_rel δ Γ θ →
+
+Lemma sem_context_rel_closed δ Γ θ:
+ 𝒢 δ Γ θ → subst_is_closed [] θ.
+Proof.
+ induction 1.
+ - done.
+ - intros y e. rewrite lookup_insert_Some.
+ intros [[-> <-]|[Hne Hlook]].
+ + by eapply val_rel_closed.
+ + eapply IHsem_context_rel; last done.
+Qed.
+
+
+(* This is essentially an inversion lemma for 𝒢 *)
+Lemma sem_context_rel_vals δ Γ θ x A :
+ 𝒢 δ Γ θ →
Γ !! x = Some A →
∃ e v, θ !! x = Some e ∧ to_val e = Some v ∧ 𝒱 A δ v.
Proof.
@@ -181,34 +216,19 @@ Proof.
split; first done. done.
Qed.
-Lemma sem_context_rel_subset δ Γ θ :
- 𝒢 δ Γ θ → dom Γ ⊆ dom θ.
-Proof.
- intros Hctx. apply elem_of_subseteq. intros x (A & Hlook)%elem_of_dom.
- eapply sem_context_rel_vals in Hlook as (e & v & Hlook & Heq & Hval); last done.
- eapply elem_of_dom; eauto.
-Qed.
-
-Lemma sem_context_rel_closed δ Γ θ:
- 𝒢 δ Γ θ → subst_is_closed [] θ.
+Lemma sem_context_rel_dom δ Γ θ :
+ 𝒢 δ Γ θ → dom Γ = dom θ.
Proof.
- induction 1 as [ | Γ θ v x A Hv Hctx IH]; rewrite /subst_is_closed.
- - naive_solver.
- - intros y e. rewrite lookup_insert_Some.
- intros [[-> <-]|[Hne Hlook]].
- + by eapply val_rel_is_closed.
- + eapply IH; last done.
+ induction 1.
+ - by rewrite !dom_empty.
+ - rewrite !dom_insert. congruence.
Qed.
-(** Semantic typing judgment *)
-Definition sem_typed Δ Γ e A :=
- ∀ θ δ, 𝒢 δ Γ θ → ℰ A δ (subst_map θ e).
-Notation "'TY' Δ ; Γ ⊨ e : A" := (sem_typed Δ Γ e A) (at level 74, e, A at next level).
Section boring_lemmas.
(** The lemmas in this section are all quite boring and expected statements,
but are quite technical to prove due to De Bruijn binders.
- We encourage to skip over the proofs of these lemmas.
+ We encourage you to skip over the proofs of these lemmas.
*)
Lemma sem_val_rel_ext B δ δ' v :
@@ -319,6 +339,7 @@ End boring_lemmas.
Lemma compat_int Δ Γ z : TY Δ; Γ ⊨ (Lit $ LitInt z) : Int.
Proof.
+ split; first done.
intros θ δ _. simp type_interp.
exists #z. split. { simpl. constructor. }
simp type_interp. eauto.
@@ -326,6 +347,7 @@ Qed.
Lemma compat_bool Δ Γ b : TY Δ; Γ ⊨ (Lit $ LitBool b) : Bool.
Proof.
+ split; first done.
intros θ δ _. simp type_interp.
exists #b. split. { simpl. constructor. }
simp type_interp. eauto.
@@ -333,6 +355,7 @@ Qed.
Lemma compat_unit Δ Γ : TY Δ; Γ ⊨ (Lit $ LitUnit) : Unit.
Proof.
+ split; first done.
intros θ δ _. simp type_interp.
exists #LitUnit. split. { simpl. constructor. }
simp type_interp. eauto.
@@ -342,8 +365,10 @@ Lemma compat_var Δ Γ x A :
Γ !! x = Some A →
TY Δ; Γ ⊨ (Var x) : A.
Proof.
- intros Hx θ δ Hctx; simpl.
- specialize (sem_context_rel_vals Hctx Hx) as (e & v & He & Heq & Hv).
+ intros Hx. split.
+ { eapply bool_decide_pack, elem_of_elements, elem_of_dom_2, Hx. }
+ intros θ δ Hctx; simpl.
+ eapply sem_context_rel_vals in Hx as (e & v & He & Heq & Hv); last done.
rewrite He. simp type_interp. exists v. split; last done.
rewrite -(of_to_val _ _ Heq).
by apply big_step_of_val.
@@ -354,7 +379,9 @@ Lemma compat_app Δ Γ e1 e2 A B :
TY Δ; Γ ⊨ e2 : A →
TY Δ; Γ ⊨ (e1 e2) : B.
Proof.
- intros Hfun Harg θ δ Hctx; simpl.
+ intros [Hfuncl Hfun] [Hargcl Harg]. split.
+ { simpl. eauto. }
+ intros θ δ Hctx; simpl.
specialize (Hfun _ _ Hctx). simp type_interp in Hfun. destruct Hfun as (v1 & Hbs1 & Hv1).
simp type_interp in Hv1. destruct Hv1 as (x & e & -> & Hv1).
@@ -369,68 +396,57 @@ Proof.
eauto.
Qed.
-(** Lambdas need to be closed by the context *)
-Lemma compat_lam_named Δ Γ x e A B X :
- closed X e →
- (∀ y, y ∈ X → y ∈ dom (<[x := A]> Γ)) →
+(* Compatibility for [lam] unfortunately needs a very technical helper lemma. *)
+Lemma lam_closed δ Γ θ (x : string) A e :
+ closed (elements (dom (<[x:=A]> Γ))) e →
+ 𝒢 δ Γ θ →
+ closed [] (Lam x (subst_map (delete x θ) e)).
+Proof.
+ intros Hcl Hctxt.
+ eapply subst_map_closed.
+ - eapply is_closed_weaken; first done.
+ rewrite dom_delete dom_insert (sem_context_rel_dom δ Γ θ) //.
+ intros y. destruct (decide (x = y)); set_solver.
+ - intros x' e' Hx.
+ eapply (is_closed_weaken []); last set_solver.
+ eapply sem_context_rel_closed; first eassumption.
+ eapply map_subseteq_spec; last done.
+ apply map_delete_subseteq.
+Qed.
+Lemma compat_lam Δ Γ x e A B :
TY Δ; (<[ x := A ]> Γ) ⊨ e : B →
TY Δ; Γ ⊨ (Lam (BNamed x) e) : (A → B).
Proof.
- intros Hcl Hsub Hbody θ δ Hctxt. simpl.
- simp type_interp.
-
- exists ((λ: x, subst_map (delete x θ) e))%V.
+ intros [Hbodycl Hbody]. split.
+ { simpl. eapply is_closed_weaken; first eassumption. set_solver. }
+ intros θ Hctxt. simpl. simp type_interp.
+ eexists.
split; first by eauto.
simp type_interp.
- eexists (BNamed x), _. split_and!; first reflexivity.
- { eapply closed_subst_weaken; [ | | apply Hcl].
- - eapply subst_is_closed_subseteq; last by eapply sem_context_rel_closed.
- apply map_delete_subseteq.
- - intros y Hy%Hsub Hn. apply elem_of_list_singleton.
- apply not_elem_of_dom in Hn. apply elem_of_dom in Hy.
- destruct (decide (x = y)) as [<- | Hneq]; first done.
- rewrite lookup_delete_ne in Hn; last done.
- rewrite lookup_insert_ne in Hy; last done.
- apply sem_context_rel_subset in Hctxt.
- move: Hctxt. rewrite elem_of_subseteq.
- move : Hn Hy. rewrite -elem_of_dom -not_elem_of_dom.
- naive_solver.
- }
-
+ eexists _, _. split; first reflexivity.
+ split; first by eapply lam_closed.
intros v' Hv'.
specialize (Hbody (<[ x := of_val v']> θ)).
- simpl. rewrite subst_subst_map.
- 2: { by eapply sem_context_rel_closed. }
- apply Hbody. apply sem_context_rel_insert; done.
+ simpl. rewrite subst_subst_map; last by eapply sem_context_rel_closed.
+ apply Hbody.
+ apply sem_context_rel_insert; done.
Qed.
-Lemma compat_lam_anon Δ Γ e A B X :
- closed X e →
- (∀ y, y ∈ X → y ∈ dom Γ) →
+Lemma compat_lam_anon Δ Γ e A B :
TY Δ; Γ ⊨ e : B →
TY Δ; Γ ⊨ (Lam BAnon e) : (A → B).
Proof.
- intros Hcl Hsub Hbody θ δ Hctxt. simpl.
- simp type_interp.
-
- exists (λ: <>, subst_map θ e)%V.
+ intros [Hbodycl Hbody]. split; first done.
+ intros θ Hctxt. simpl. simp type_interp.
+ eexists.
split; first by eauto.
simp type_interp.
- eexists BAnon, _. split_and!; first reflexivity.
- { simpl.
- eapply closed_subst_weaken; [ | | apply Hcl].
- - by eapply sem_context_rel_closed.
- - intros y Hy%Hsub Hn.
- apply not_elem_of_dom in Hn. apply elem_of_dom in Hy.
- apply sem_context_rel_subset in Hctxt.
- move: Hctxt. rewrite elem_of_subseteq.
- move : Hn Hy. rewrite -elem_of_dom -not_elem_of_dom.
- naive_solver.
- }
-
- intros v' Hv'.
- specialize (Hbody θ).
- simpl. apply Hbody; done.
+ eexists _, _. split; first reflexivity.
+ split.
+ { simpl. eapply subst_map_closed; simpl.
+ - by erewrite <-sem_context_rel_dom.
+ - by eapply sem_context_rel_closed. }
+ naive_solver.
Qed.
Lemma compat_int_binop Δ Γ op e1 e2 :
@@ -439,7 +455,10 @@ Lemma compat_int_binop Δ Γ op e1 e2 :
TY Δ; Γ ⊨ e2 : Int →
TY Δ; Γ ⊨ (BinOp op e1 e2) : Int.
Proof.
- intros Hop He1 He2 θ δ Hctx. simpl.
+ intros Hop [He1cl He1] [He2cl He2].
+ split; first naive_solver.
+
+ intros θ δ Hctx. simpl.
simp type_interp.
specialize (He1 _ _ Hctx). specialize (He2 _ _ Hctx).
simp type_interp in He1. simp type_interp in He2.
@@ -467,7 +486,10 @@ Lemma compat_int_bool_binop Δ Γ op e1 e2 :
TY Δ; Γ ⊨ e2 : Int →
TY Δ; Γ ⊨ (BinOp op e1 e2) : Bool.
Proof.
- intros Hop He1 He2 θ δ Hctx. simpl.
+ intros Hop [He1cl He1] [He2cl He2].
+ split; first naive_solver.
+
+ intros θ δ Hctx. simpl.
simp type_interp.
specialize (He1 _ _ Hctx). specialize (He2 _ _ Hctx).
simp type_interp in He1. simp type_interp in He2.
@@ -494,7 +516,9 @@ Lemma compat_unop Δ Γ op A B e :
TY Δ; Γ ⊨ e : A →
TY Δ; Γ ⊨ (UnOp op e) : B.
Proof.
- intros Hop He θ δ Hctx. simpl.
+ intros Hop [Hecl He].
+ split; first naive_solver.
+ intros θ δ Hctx. simpl.
simp type_interp. specialize (He _ _ Hctx).
simp type_interp in He.
@@ -510,28 +534,23 @@ Proof.
+ by eexists _.
Qed.
-Lemma compat_tlam Δ Γ e A X :
- closed X e →
- (∀ y, y ∈ X → y ∈ dom Γ) →
+Lemma compat_tlam Δ Γ e A :
TY S Δ; (⤉ Γ) ⊨ e : A →
TY Δ; Γ ⊨ (Λ, e) : (∀: A).
Proof.
- intros Hcl Hsub He θ δ Hctx. simpl.
+ intros [Hecl He]. split.
+ { simpl. by erewrite <-dom_fmap. }
+ intros θ δ Hctx. simpl.
simp type_interp.
exists (Λ, subst_map θ e)%V.
split; first constructor.
simp type_interp.
eexists _. split_and!; first done.
- { eapply closed_subst_weaken; [ | | apply Hcl].
- - by eapply sem_context_rel_closed.
- - intros y Hy%Hsub Hn. exfalso.
- apply not_elem_of_dom in Hn. apply elem_of_dom in Hy.
- apply sem_context_rel_subset in Hctx.
- move: Hctx. rewrite elem_of_subseteq.
- move : Hn Hy. rewrite -elem_of_dom -not_elem_of_dom.
- naive_solver.
- }
+ { simpl. eapply subst_map_closed; simpl.
+ - erewrite <-sem_context_rel_dom; last eassumption.
+ by erewrite <-dom_fmap.
+ - by eapply sem_context_rel_closed. }
intros τ. eapply He.
by eapply sem_context_rel_cons.
Qed.
@@ -541,9 +560,9 @@ Lemma compat_tapp Δ Γ e A B :
TY Δ; Γ ⊨ e : (∀: A) →
TY Δ; Γ ⊨ (e <>) : (A.[B/]).
Proof.
- (* TODO: exercise for you *)
+ (* TODO: exercise *)
Admitted.
-(*Qed.*)
+
Lemma compat_pack Δ Γ e n A B :
type_wf n B →
@@ -551,27 +570,31 @@ Lemma compat_pack Δ Γ e n A B :
TY n; Γ ⊨ e : A.[B/] →
TY n; Γ ⊨ (pack e) : (∃: A).
Proof.
- (* TODO: this will be an exercise for you soon. *)
-(*Qed.*)
+ (* This will be an exercise for you next week :) *)
+ (* TODO: exercise *)
Admitted.
+
Lemma compat_unpack n Γ A B e e' x :
type_wf n B →
TY n; Γ ⊨ e : (∃: A) →
TY S n; <[x:=A]> (⤉Γ) ⊨ e' : B.[ren (+1)] →
TY n; Γ ⊨ (unpack e as BNamed x in e') : B.
Proof.
- (* TODO: this will be an exercise for you soon *)
-(*Qed.*)
+ (* This will be an exercise for you next week :) *)
+ (* TODO: exercise *)
Admitted.
+
Lemma compat_if n Γ e0 e1 e2 A :
TY n; Γ ⊨ e0 : Bool →
TY n; Γ ⊨ e1 : A →
TY n; Γ ⊨ e2 : A →
TY n; Γ ⊨ (if: e0 then e1 else e2) : A.
Proof.
- intros He0 He1 He2 θ δ Hctx. simpl.
+ intros [He0cl He0] [He1cl He1] [He2cl He2].
+ split; first naive_solver.
+ intros θ δ Hctx. simpl.
simp type_interp.
specialize (He0 _ _ Hctx). simp type_interp in He0.
specialize (He1 _ _ Hctx). simp type_interp in He1.
@@ -591,7 +614,9 @@ Lemma compat_pair Δ Γ e1 e2 A B :
TY Δ; Γ ⊨ e2 : B →
TY Δ; Γ ⊨ (e1, e2) : A × B.
Proof.
- intros He1 He2 θ δ Hctx. simpl.
+ intros [He1cl He1] [He2cl He2].
+ split; first naive_solver.
+ intros θ δ Hctx. simpl.
simp type_interp.
specialize (He1 _ _ Hctx). simp type_interp in He1.
destruct He1 as (v1 & Hb1 & Hv1).
@@ -605,7 +630,8 @@ Lemma compat_fst Δ Γ e A B :
TY Δ; Γ ⊨ e : A × B →
TY Δ; Γ ⊨ Fst e : A.
Proof.
- intros He θ δ Hctx. simpl.
+ intros [Hecl He]. split; first naive_solver.
+ intros θ δ Hctx. simpl.
simp type_interp.
specialize (He _ _ Hctx). simp type_interp in He.
destruct He as (v & Hb & Hv).
@@ -617,7 +643,8 @@ Lemma compat_snd Δ Γ e A B :
TY Δ; Γ ⊨ e : A × B →
TY Δ; Γ ⊨ Snd e : B.
Proof.
- intros He θ δ Hctx. simpl.
+ intros [Hecl He]. split; first naive_solver.
+ intros θ δ Hctx. simpl.
simp type_interp.
specialize (He _ _ Hctx). simp type_interp in He.
destruct He as (v & Hb & Hv).
@@ -629,7 +656,8 @@ Lemma compat_injl Δ Γ e A B :
TY Δ; Γ ⊨ e : A →
TY Δ; Γ ⊨ InjL e : A + B.
Proof.
- intros He θ δ Hctx. simpl.
+ intros [Hecl He]. split; first naive_solver.
+ intros θ δ Hctx. simpl.
simp type_interp.
specialize (He _ _ Hctx). simp type_interp in He.
destruct He as (v & Hb & Hv).
@@ -641,7 +669,8 @@ Lemma compat_injr Δ Γ e A B :
TY Δ; Γ ⊨ e : B →
TY Δ; Γ ⊨ InjR e : A + B.
Proof.
- intros He θ δ Hctx. simpl.
+ intros [Hecl He]. split; first naive_solver.
+ intros θ δ Hctx. simpl.
simp type_interp.
specialize (He _ _ Hctx). simp type_interp in He.
destruct He as (v & Hb & Hv).
@@ -655,7 +684,9 @@ Lemma compat_case Δ Γ e e1 e2 A B C :
TY Δ; Γ ⊨ e2 : (C → A) →
TY Δ; Γ ⊨ Case e e1 e2 : A.
Proof.
- intros He He1 He2 θ δ Hctx. simpl.
+ intros [Hecl He] [He1cl He1] [He2cl He2].
+ split; first naive_solver.
+ intros θ δ Hctx. simpl.
simp type_interp.
specialize (He _ _ Hctx). simp type_interp in He.
destruct He as (v & Hb & Hv).
@@ -680,23 +711,11 @@ Lemma sem_soundness Δ Γ e A :
TY Δ; Γ ⊢ e : A →
TY Δ; Γ ⊨ e : A.
Proof.
- induction 1 as [ | Δ Γ x e A B Hsyn IH | Δ Γ e A B Hsyn IH| Δ Γ e A Hsyn IH| | | | | | | | | n Γ e1 e2 op A B C Hop ? ? ? ? | | | | | | | ].
+ induction 1 as [ | | | | | | | | | | | | n Γ e1 e2 op A B C Hop ? ? ? ? | | | | | | | ].
- by apply compat_var.
- - set (X := elements (dom (<[x := A]>Γ))).
- specialize (syn_typed_closed _ _ _ _ X Hsyn) as Hcl.
- eapply compat_lam_named; last done.
- + apply Hcl. apply elem_of_elements.
- + intros ??. by apply elem_of_elements.
- - set (X := elements (dom Γ)).
- specialize (syn_typed_closed _ _ _ _ X Hsyn) as Hcl.
- eapply compat_lam_anon; last done.
- + apply Hcl. apply elem_of_elements.
- + intros ??. by apply elem_of_elements.
- - set (X := elements (dom Γ)).
- specialize (syn_typed_closed _ _ _ _ X Hsyn) as Hcl.
- eapply compat_tlam; last done.
- + apply Hcl. rewrite dom_fmap. apply elem_of_elements.
- + intros ??. by apply elem_of_elements.
+ - by apply compat_lam.
+ - by apply compat_lam_anon.
+ - by apply compat_tlam.
- apply compat_tapp; done.
- eapply compat_pack; done.
- eapply compat_unpack; done.
@@ -725,7 +744,7 @@ Lemma termination e A :
(TY 0; ∅ ⊢ e : A)%ty →
∃ v, big_step e v.
Proof.
- intros Hsem%sem_soundness.
+ intros [Hsemcl Hsem]%sem_soundness.
specialize (Hsem ∅ δ_any).
simp type_interp in Hsem.
rewrite subst_map_empty in Hsem.
diff --git a/theories/type_systems/systemf/notation.v b/theories/type_systems/systemf/notation.v
index 563b1117605872195167064bf036ddb65669ae9e..83c22302bb496ddddc4060d2dcc8812b6e189eee 100644
--- a/theories/type_systems/systemf/notation.v
+++ b/theories/type_systems/systemf/notation.v
@@ -61,8 +61,7 @@ Notation "λ: x y .. z , e" := (LamV x%binder (Lam y%binder .. (Lam z%binder e%E
format "'[' 'λ:' x y .. z , '/ ' e ']'") : val_scope.
Notation "'let:' x := e1 'in' e2" := (Lam x%binder e2%E e1%E)
- (at level 200, x at level 1, e1, e2 at level 200,
- format "'[' 'let:' x := '[' e1 ']' 'in' '/' e2 ']'") : expr_scope.
+ (only parsing, at level 200, x at level 1, e1, e2 at level 200) : expr_scope.
Notation "e1 ;; e2" := (Lam BAnon e2%E e1%E)
(at level 100, e2 at level 200,
format "'[' '[hv' '[' e1 ']' ;; ']' '/' e2 ']'") : expr_scope.
diff --git a/theories/type_systems/systemf/parallel_subst.v b/theories/type_systems/systemf/parallel_subst.v
index 8f8987b7bf9578c50f508d5a9c2fbfd0ed962ec6..29ad195d0c30f66fab970bfb3f31b63134a7dc07 100644
--- a/theories/type_systems/systemf/parallel_subst.v
+++ b/theories/type_systems/systemf/parallel_subst.v
@@ -178,3 +178,51 @@ Proof.
end.
all: naive_solver.
Qed.
+
+Lemma subst_map_closed' X Y Θ e:
+ is_closed Y e →
+ (∀ x, x ∈ Y → if Θ !! x is (Some e') then closed X e' else x ∈ X) →
+ is_closed X (subst_map Θ e).
+Proof.
+ induction e in X, Θ, Y |-*; simpl.
+ 2: {
+ intros Hel%bool_decide_unpack Hcl.
+ eapply Hcl in Hel.
+ destruct (Θ !! x); first done.
+ simpl. by eapply bool_decide_pack. }
+ 2: {
+ intros Hcl Hcl'. destruct x as [|x]; simpl; first naive_solver.
+ eapply IHe; first done.
+ intros y [|]%elem_of_cons.
+ + subst. rewrite lookup_delete. set_solver.
+ + destruct (decide (x = y)); first by subst; rewrite lookup_delete; set_solver.
+ rewrite lookup_delete_ne //=. eapply Hcl' in H.
+ destruct lookup; last set_solver.
+ eapply is_closed_weaken; eauto with set_solver. }
+ 9: {
+ intros [Hcl1 Hcl2]%andb_True H.
+ apply andb_True. split; first eauto.
+ destruct x as [|x]; simpl; first naive_solver.
+ eapply IHe2; first done.
+ intros y [|H0]%elem_of_cons.
+ + subst. rewrite lookup_delete. set_solver.
+ + destruct (decide (x = y)); first by subst; rewrite lookup_delete; set_solver.
+ rewrite lookup_delete_ne //=. eapply H in H0.
+ destruct lookup; last set_solver.
+ eapply is_closed_weaken; eauto with set_solver.
+ }
+ all: try naive_solver.
+Qed.
+
+Lemma subst_map_closed X θ e:
+ is_closed (X ++ (elements (dom θ))) e ->
+ subst_is_closed X θ ->
+ is_closed X (subst_map θ e).
+Proof.
+ intros Hcl Hsubst.
+ eapply subst_map_closed'; first eassumption.
+ intros x Hx.
+ destruct (θ !! x) as [e'|] eqn:Heq.
+ - eauto.
+ - by eapply elem_of_app in Hx as [H|H%elem_of_elements%not_elem_of_dom].
+Qed.
diff --git a/theories/type_systems/systemf/types.v b/theories/type_systems/systemf/types.v
index d6ffb7e7deaa270d47b91da15851afc0f28e2008..a8c46fd2eb95db0dfaf05509e76e84fd5239c16a 100644
--- a/theories/type_systems/systemf/types.v
+++ b/theories/type_systems/systemf/types.v
@@ -613,10 +613,10 @@ Proof.
eexists. eapply base_contextual_step. eapply TBetaS.
+ destruct H1 as [e' H1]. eexists. eauto.
- (* pack *)
- (* FIXME this will be an exercise for you soon :) *)
+ (* TODO this will be an exercise for you soon :) *)
admit.
- (* unpack *)
- (* FIXME this will be an exercise for you soon :) *)
+ (* TODO this will be an exercise for you soon :) *)
admit.
- (* int *)left. done.
- (* bool*) left. done.
@@ -804,7 +804,7 @@ Proof.
eapply type_lam_inversion in Hty as (A & Heq & Hty).
injection Heq as ->. by eapply typed_subst_type_closed.
- (* unpack *)
- (* FIXME: this will be an exercise for you soon :) *)
+ (* TODO: this will be an exercise for you soon :) *)
admit.
- (* unop *)
eapply unop_inversion in Hty as (A1 & Hop & Hty).
diff --git a/theories/type_systems/systemf_mu/exercises06.v b/theories/type_systems/systemf_mu/exercises06.v
index b74b43bbab276f6d75431b90e18104dcac5df813..4bf529ea8cfacaaa4b2ff1882dc856746c62d2dd 100644
--- a/theories/type_systems/systemf_mu/exercises06.v
+++ b/theories/type_systems/systemf_mu/exercises06.v
@@ -27,11 +27,10 @@ Section recursion_combinator.
(** You may find an auxiliary definition [rec_body] helpful *)
Definition rec_body (t: expr) : expr :=
- (* FIXME *)
- roll (λ: f x, #0).
+ roll (λ: f x, #0). (* TODO *)
Definition Rec (t: expr): val :=
- λ: x, rec_body t. (* FIXME *)
+ λ: x, rec_body t. (* TODO *)
Lemma closed_rec_body t :
is_closed [] t → is_closed [] (rec_body t).
@@ -43,6 +42,8 @@ Section recursion_combinator.
is_val (Rec t).
Proof. done. Qed.
+
+
Lemma Rec_red (t e: expr):
is_val e →
is_val t →
@@ -50,9 +51,10 @@ Section recursion_combinator.
is_closed [] t →
rtc contextual_step ((Rec t) e) (t (Rec t) e).
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
Lemma rec_body_typing n Γ (A B: type) t :
Γ !! x = None →
Γ !! f = None →
@@ -61,9 +63,10 @@ Section recursion_combinator.
TY n; Γ ⊢ t : ((A → B) → (A → B)) →
TY n; Γ ⊢ rec_body t : (μ: #0 → rename (+1) A → rename (+1) B).
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
Lemma Rec_typing n Γ A B t:
type_wf n A →
type_wf n B →
@@ -72,9 +75,10 @@ Section recursion_combinator.
TY n; Γ ⊢ t : ((A → B) → (A → B)) →
TY n; Γ ⊢ (Rec t) : (A → B).
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
End recursion_combinator.
Definition Fix (f x: string) (e: expr) : val := (Rec f x (Lam f%string (Lam x%string e))).
@@ -107,9 +111,10 @@ Lemma fix_red (f x: string) (e e': expr):
f ≠ x →
rtc contextual_step ((fix: f x := e) e')%V (sub x e' (sub f (fix: f x := e)%V e)).
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
Lemma fix_typing n Γ (f x: string) (A B: type) (e: expr):
type_wf n A →
type_wf n B →
@@ -117,57 +122,63 @@ Lemma fix_typing n Γ (f x: string) (A B: type) (e: expr):
TY n; <[x := A]> (<[f := (A → B)%ty]> Γ) ⊢ e : B →
TY n; Γ ⊢ (fix: f x := e) : (A → B).
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
(** ** Exercise 1: Encode arithmetic expressions *)
-Definition aexpr : type := #0 (* FIXME *).
+Definition aexpr : type := #0 (* TODO *).
-Definition num_val (v : val) : val := #0 (* FIXME *).
-Definition num_expr (e : expr) : expr := #0 (* FIXME *).
+Definition num_val (v : val) : val := #0 (* TODO *).
+Definition num_expr (e : expr) : expr := #0 (* TODO *).
-Definition plus_val (v1 v2 : val) : val := #0 (* FIXME *).
-Definition plus_expr (e1 e2 : expr) : expr := #0 (* FIXME *).
+Definition plus_val (v1 v2 : val) : val := #0 (* TODO *).
+Definition plus_expr (e1 e2 : expr) : expr := #0 (* TODO *).
-Definition mul_val (v1 v2 : val) : val := #0 (* FIXME *).
-Definition mul_expr (e1 e2 : expr) : expr := #0 (* FIXME *).
+Definition mul_val (v1 v2 : val) : val := #0 (* TODO *).
+Definition mul_expr (e1 e2 : expr) : expr := #0 (* TODO *).
Lemma num_expr_typed n Γ e :
TY n; Γ ⊢ e : Int →
TY n; Γ ⊢ num_expr e : aexpr.
Proof.
intros. solve_typing.
- (* FIXME *)
-(*Qed.*)
+ (* TODO: exercise *)
Admitted.
+
+
Lemma plus_expr_typed n Γ e1 e2 :
TY n; Γ ⊢ e1 : aexpr →
TY n; Γ ⊢ e2 : aexpr →
TY n; Γ ⊢ plus_expr e1 e2 : aexpr.
Proof.
(*intros; solve_typing.*)
-(*Qed.*)
+ (* TODO: exercise *)
Admitted.
+
+
Lemma mul_expr_typed n Γ e1 e2 :
TY n; Γ ⊢ e1 : aexpr →
TY n; Γ ⊢ e2 : aexpr →
TY n; Γ ⊢ mul_expr e1 e2 : aexpr.
Proof.
(*intros; solve_typing.*)
-(*Qed.*)
+ (* TODO: exercise *)
Admitted.
+
Definition eval_aexpr : val :=
- #0 (* FIXME *).
+ #0. (* TODO *)
+
Lemma eval_aexpr_typed Γ n :
TY n; Γ ⊢ eval_aexpr : (aexpr → Int).
Proof.
-(*Qed.*)
-(* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
(** Exercise 3: Lists *)
Definition list_t (A : type) : type :=
@@ -177,12 +188,15 @@ Definition list_t (A : type) : type :=
.
Definition mylist_impl : val :=
- #0 (* FIXME *)
+ #0 (* TODO *)
.
+
+
Lemma mylist_impl_sem_typed A :
type_wf 0 A →
∀ k, 𝒱 (list_t A) δ_any k mylist_impl.
Proof.
- (* FIXME *)
+ (* TODO: exercise *)
Admitted.
+
diff --git a/theories/type_systems/systemf_mu/logrel.v b/theories/type_systems/systemf_mu/logrel.v
index 80924af43086767e54cd15982640cfe87a50bc40..5e4e7ac8c63e4811018936c39d81bec1c156b08c 100644
--- a/theories/type_systems/systemf_mu/logrel.v
+++ b/theories/type_systems/systemf_mu/logrel.v
@@ -20,7 +20,7 @@ Implicit Types
a proof of closedness, and a proof of downwards-closure wrt step-indices. *)
Record sem_type := mk_ST {
sem_type_car :> nat → val → Prop;
- sem_type_closed_val k v : sem_type_car k v → is_closed [] (of_val v);
+ sem_type_closed_val k v : sem_type_car k v → is_closed [] v;
sem_type_mono : ∀ k k' v, sem_type_car k v → k' ≤ k → sem_type_car k' v
}.
@@ -72,15 +72,17 @@ Definition type_lt := ltof type type_size.
#[local] Instance type_lt_wf : WellFounded type_lt.
Proof. apply well_founded_ltof. Qed.
-Inductive type_case : Set :=
- | expr_case | val_case.
-Definition type_case_size (c : type_case) : nat :=
- match c with | expr_case => 1 | val_case => 0 end.
-Definition type_case_lt := ltof type_case type_case_size.
-#[local] Instance type_case_lt_wf : WellFounded type_case_lt.
+Inductive val_or_expr : Type :=
+| inj_val : val → val_or_expr
+| inj_expr : expr → val_or_expr.
+
+Definition val_or_expr_size (ve : val_or_expr) : nat :=
+ match ve with | inj_val _ => 0 | inj_expr _ => 1 end.
+Definition val_or_expr_lt := ltof val_or_expr val_or_expr_size.
+#[local] Instance val_or_expr_lt_wf : WellFounded val_or_expr_lt.
Proof. apply well_founded_ltof. Qed.
-Definition term_rel := Subterm.lexprod nat (type * type_case) lt (Subterm.lexprod type type_case type_lt type_case_lt).
+Definition term_rel := Subterm.lexprod nat (type * val_or_expr) lt (Subterm.lexprod type val_or_expr type_lt val_or_expr_lt).
#[local] Instance term_rel_wf : WellFounded term_rel. apply _. Qed.
(** *** The logical relation *)
@@ -88,44 +90,42 @@ Definition term_rel := Subterm.lexprod nat (type * type_case) lt (Subterm.lexpro
fundamentally requires decreasing the step-index, we also need to convince Equations that this definition is well-formed!
We do this by providing a well-founded termination relation [term_rel] that decreases for each recursive call.
*)
-Equations type_interp (c : type_case) (t : type) δ (k : nat) (v : match c with val_case => val | expr_case => expr end) : Prop
- by wf (k, (t, c)) term_rel := {
+Equations type_interp (ve : val_or_expr) (t : type) δ (k : nat) : Prop
+ by wf (k, (t, ve)) term_rel := {
- type_interp val_case Int δ k v =>
+ type_interp (inj_val v) Int δ k =>
∃ z : Z, v = #z ;
- type_interp val_case Bool δ k v =>
+ type_interp (inj_val v) Bool δ k =>
∃ b : bool, v = #b ;
- type_interp val_case Unit δ k v =>
+ type_interp (inj_val v) Unit δ k =>
v = #LitUnit ;
- type_interp val_case (A × B) δ k v =>
- ∃ v1 v2 : val, v = (v1, v2)%V ∧ type_interp val_case A δ k v1 ∧ type_interp val_case B δ k v2;
- type_interp val_case (A + B) δ k v =>
- (∃ v' : val, v = InjLV v' ∧ type_interp val_case A δ k v') ∨
- (∃ v' : val, v = InjRV v' ∧ type_interp val_case B δ k v');
+ type_interp (inj_val v) (A × B) δ k =>
+ ∃ v1 v2 : val, v = (v1, v2)%V ∧ type_interp (inj_val v1) A δ k ∧ type_interp (inj_val v2) B δ k;
+ type_interp (inj_val v) (A + B) δ k =>
+ (∃ v' : val, v = InjLV v' ∧ type_interp (inj_val v') A δ k) ∨
+ (∃ v' : val, v = InjRV v' ∧ type_interp (inj_val v') B δ k);
- type_interp val_case (A → B) δ k v =>
+ type_interp (inj_val v) (A → B) δ k =>
∃ x e, v = LamV x e ∧ is_closed (x :b: nil) e ∧
(* We write ∀ (H:k' ≤ k), .. instead of k' ≤ k → .. due to a longstanding Coq quirk, see
- https://coq.zulipchat.com/#narrow/stream/237977-Coq-users/topic/.60Program.60.20and.20variable.20names/near/404824378 *)
+ https://coq.zulipchat.com/#narrow/stream/237977-Coq-users/topic/.60Program.60.20and.20variable.20names/near/404824378 *)
∀ v' k' (H:k' ≤ k),
- type_interp val_case A δ k' v' →
- type_interp expr_case B δ k' (subst' x (of_val v') e);
- type_interp val_case (#α) δ k v =>
+ type_interp (inj_val v') A δ k' →
+ type_interp (inj_expr (subst' x (of_val v') e)) B δ k' ;
+ type_interp (inj_val v) (#α) δ k =>
(δ α).(sem_type_car) k v;
- type_interp val_case (∀: A) δ k v =>
+ type_interp (inj_val v) (∀: A) δ k =>
∃ e, v = TLamV e ∧ is_closed [] e ∧
- ∀ τ, type_interp expr_case A (τ .: δ) k e;
- type_interp val_case (∃: A) δ k v =>
+ ∀ τ, type_interp (inj_expr e) A (τ .: δ) k;
+ type_interp (inj_val v) (∃: A) δ k =>
∃ v', v = PackV v' ∧
- ∃ τ : sem_type, type_interp val_case A (τ .: δ) k v';
+ ∃ τ : sem_type, type_interp (inj_val v') A (τ .: δ) k;
(** Recursive type case *)
- (** By requiring k' < k, we implicitly encode that k > 0
- *)
- type_interp val_case (μ: A) δ k v =>
- ∃ v', v = (roll v')%V ∧ is_closed [] v' ∧ ∀ k' (H:k' < k), type_interp val_case (A.[μ: A/]%ty) δ k' v';
+ type_interp (inj_val v) (μ: A) δ k =>
+ ∃ v', v = (roll v')%V ∧ is_closed [] v' ∧ ∀ k' (H:k' < k), type_interp (inj_val v') (A.[μ: A/]%ty) δ k';
- type_interp expr_case t δ k e =>
- ∀ e' n, n < k → red_nsteps n e e' → ∃ v, to_val e' = Some v ∧ type_interp val_case t δ (k - n) v
+ type_interp (inj_expr e) t δ k =>
+ ∀ e' n, n < k → red_nsteps n e e' → ∃ v, to_val e' = Some v ∧ type_interp (inj_val v) t δ (k - n)
}.
(** Proving that the arguments are decreasing for recursive calls is a bit more messy now, but it's mostly systematic.
@@ -139,31 +139,31 @@ Ltac dsimpl :=
| |- term_rel (?k1, _) (?k2, _) =>
(* use [lia] to decide where to go *)
destruct (decide (k1 < k2)) as [ ? | ?]; [left; lia | assert (k1 = k2) as -> by lia; right]
- | |- Subterm.lexprod type type_case _ _ (?t, _) (?t, _) =>
+ | |- Subterm.lexprod type val_or_expr _ _ (?t, _) (?t, _) =>
(* type is not decreasing, go right *)
right
- | |- Subterm.lexprod type type_case _ _ (_, ?a) (_, ?a) =>
+ | |- Subterm.lexprod type val_or_expr _ _ (_, ?a) (_, ?a) =>
(* type case is not decreasing, go left *)
left
| |- term_rel (_, _) (_, _) =>
(* branch non-deterministically and try to solve the remaining goal *)
first [left; solve [dsimpl] | right; solve [dsimpl]]
- | |- Subterm.lexprod type type_case _ _ _ _ =>
+ | |- Subterm.lexprod type val_or_expr _ _ _ _ =>
(* branch non-deterministically *)
first [left; solve [dsimpl] | right; solve [dsimpl]]
| _ =>
- (* try to solve a leaf, i.e. a [type_lt], [type_case_lt] or [lt] goal *)
- unfold type_case_lt, type_lt, ltof; simp type_size; simpl; try lia
+ (* try to solve a leaf, i.e. a [type_lt], [val_or_expr_lt] or [lt] goal *)
+ unfold val_or_expr_lt, type_lt, ltof; simp type_size; simpl; try lia
end.
(** The tactic solves all of Equations' obligations for showing that the argument decreases. *)
Solve Obligations with (intros; dsimpl).
(** *** Value relation and expression relation *)
-Definition sem_val_rel A δ k v := type_interp val_case A δ k v.
-Definition sem_expr_rel A δ k e := type_interp expr_case A δ k e.
+Notation sem_val_rel A δ k v := (type_interp (inj_val v) A δ k).
+Notation sem_expr_rel A δ k e := (type_interp (inj_expr e) A δ k).
-Notation 𝒱 := (type_interp val_case).
-Notation ℰ := (type_interp expr_case).
+Notation 𝒱 A δ k v := (sem_val_rel A δ k v).
+Notation ℰ A δ k v := (sem_expr_rel A δ k v).
Lemma val_rel_is_closed v δ k A:
𝒱 A δ k v → is_closed [] (of_val v).
@@ -227,26 +227,26 @@ Qed.
We can use the inductive hypothesis whenever either the type or the step-index decreases, or we switch from
the expression case to the value case.
*)
-Lemma type_interp_mono : ∀ '(k, (A, c)) δ k' x, k' ≤ k → type_interp c A δ k x → type_interp c A δ k' x.
+Lemma type_interp_mono : ∀ '(k, (A, ve)) δ k', k' ≤ k → type_interp ve A δ k → type_interp ve A δ k'.
Proof.
eapply (well_founded_ind (R := term_rel) term_rel_wf).
- intros (k & A & []) IH δ k'.
+ intros (k & A & []) IH δ k'; first last.
{ (* expression rel *)
- intros e Hk He. simp type_interp in He. simp type_interp. intros e' n Hn Hred.
+ intros Hk He. simp type_interp in He. simp type_interp. intros e' n Hn Hred.
destruct (He e' n ltac:(lia) Hred) as (v & Hval & Hv).
exists v. split; first done.
- eapply (IH (k-n, (A, val_case))); [ | lia | done].
+ eapply (IH (k-n, (A, inj_val v))); [ | lia | done].
(* show that the induction is decreasing *)
dsimpl.
}
- intros v Hk Hv.
+ intros Hk Hv.
destruct A as [x | | | | A | A | A B | A B | A B | A ]; simp type_interp; simp type_interp in Hv.
- (* var case *)
by eapply sem_type_mono.
- (* universal case *)
destruct Hv as (e & -> & ? & Hv).
exists e. split_and!; [done.. | ]. intros τ.
- eapply (IH (k, (A, expr_case))); [ dsimpl | done | done].
+ eapply (IH (k, (A, inj_expr e))); [ dsimpl | done | done].
- (* existential case *)
destruct Hv as (v' & -> & (τ & Hv)). exists v'. split; first done.
exists τ. eapply (IH (k, (A, _))); [ dsimpl | done..].
@@ -270,14 +270,14 @@ Qed.
(** We can now derive the two desired lemmas *)
Lemma val_rel_mono A δ k k' v : k' ≤ k → 𝒱 A δ k v → 𝒱 A δ k' v.
-Proof. apply (type_interp_mono (k, (A, val_case))). Qed.
+Proof. apply (type_interp_mono (k, (A, inj_val v))). Qed.
Lemma expr_rel_mono A δ k k' e : k' ≤ k → ℰ A δ k e → ℰ A δ k' e.
-Proof. apply (type_interp_mono (k, (A, expr_case))). Qed.
+Proof. apply (type_interp_mono (k, (A, inj_expr e))). Qed.
(** Interpret a syntactic type *)
Program Definition interp_type A δ : sem_type := {|
- sem_type_car := 𝒱 A δ;
+ sem_type_car := fun k v => 𝒱 A δ k v;
|}.
Next Obligation. by eapply val_rel_is_closed. Qed.
Next Obligation. by eapply val_rel_mono. Qed.
@@ -296,6 +296,14 @@ Inductive sem_context_rel (δ : tyvar_interp) (k : nat) : typing_context → (gm
Notation 𝒢 := sem_context_rel.
+
+(** *** Semantic typing judgment *)
+Definition sem_typed Δ Γ e A :=
+ is_closed (elements (dom Γ)) e ∧
+ ∀ θ δ k, 𝒢 δ k Γ θ → ℰ A δ k (subst_map θ e).
+Notation "'TY' Δ ; Γ ⊨ e : A" := (sem_typed Δ Γ e A) (at level 74, e, A at next level).
+
+
Lemma sem_context_rel_vals {δ k Γ θ x A} :
sem_context_rel δ k Γ θ →
Γ !! x = Some A →
@@ -311,12 +319,12 @@ Proof.
split; first done. done.
Qed.
-Lemma sem_context_rel_subset δ k Γ θ :
- 𝒢 δ k Γ θ → dom Γ ⊆ dom θ.
+Lemma sem_context_rel_dom δ k Γ θ :
+ 𝒢 δ k Γ θ → dom Γ = dom θ.
Proof.
- intros Hctx. apply elem_of_subseteq. intros x (A & Hlook)%elem_of_dom.
- eapply sem_context_rel_vals in Hlook as (e & v & Hlook & Heq & Hval); last done.
- eapply elem_of_dom; eauto.
+ induction 1.
+ - by rewrite !dom_empty.
+ - rewrite !dom_insert. congruence.
Qed.
Lemma sem_context_rel_dom_eq δ k Γ θ :
@@ -346,11 +354,6 @@ Proof.
- apply IH.
Qed.
-(** *** Semantic typing judgment *)
-Definition sem_typed Δ Γ e A :=
- ∀ θ δ k, 𝒢 δ k Γ θ → ℰ A δ k (subst_map θ e).
-Notation "'TY' Δ ; Γ ⊨ e : A" := (sem_typed Δ Γ e A) (at level 74, e, A at next level).
-
Section boring_lemmas.
(** The lemmas in this section are all quite boring and expected statements,
but are quite technical to prove due to De Bruijn binders.
@@ -358,21 +361,21 @@ Section boring_lemmas.
*)
Lemma type_interp_ext :
- ∀ '(k, (B, c)), ∀ δ δ' x,
+ ∀ '(k, (B, ve)), ∀ δ δ',
(∀ n k v, δ n k v ↔ δ' n k v) →
- type_interp c B δ k x ↔ type_interp c B δ' k x.
+ type_interp ve B δ k ↔ type_interp ve B δ' k.
Proof.
eapply (well_founded_ind (R := term_rel) term_rel_wf).
- intros (k & A & []) IH δ δ'.
+ intros (k & A & [v|e]) IH δ δ'; first last.
{ (* expression rel *)
- intros e Hd. simp type_interp. eapply forall_proper; intros e'.
+ intros Hd. simp type_interp. eapply forall_proper; intros e'.
eapply forall_proper; intros n. eapply if_iff; first done.
eapply if_iff; first done. f_equiv. intros v. f_equiv.
- eapply (IH ((k - n), (A, val_case))); last done.
+ eapply (IH ((k - n), (A, inj_val v))); last done.
(* show that the induction is decreasing *)
dsimpl.
}
- intros v Hd. destruct A as [x | | | | A | A | A B | A B | A B | A ]; simp type_interp; eauto.
+ intros Hd. destruct A as [x | | | | A | A | A B | A B | A B | A ]; simp type_interp; eauto.
- f_equiv; intros e. f_equiv. f_equiv.
eapply forall_proper; intros τ.
eapply (IH (_, (_, _))); first dsimpl.
@@ -388,7 +391,7 @@ Section boring_lemmas.
- f_equiv. intros ?. f_equiv. intros ?.
f_equiv. f_equiv; by eapply (IH (_, (_, _))); first dsimpl.
- f_equiv; f_equiv; intros ?; f_equiv; by eapply (IH (_, (_, _))); first dsimpl.
- - f_equiv; intros ?. f_equiv. f_equiv.
+ - f_equiv; intros ?. f_equiv. f_equiv.
eapply forall_proper; intros ?.
eapply forall_proper; intros ?.
by eapply (IH (_, (_, _))); first dsimpl.
@@ -396,19 +399,19 @@ Section boring_lemmas.
Lemma type_interp_move_ren :
- ∀ '(k, (B, c)), ∀ δ σ x, type_interp c B (λ n, δ (σ n)) k x ↔ type_interp c (rename σ B) δ k x.
+ ∀ '(k, (B, ve)), ∀ δ σ, type_interp ve B (λ n, δ (σ n)) k ↔ type_interp ve (rename σ B) δ k.
Proof.
eapply (well_founded_ind (R := term_rel) term_rel_wf).
- intros (k & A & []) IH δ σ.
+ intros (k & A & [v|e]) IH δ σ; first last.
{ (* expression rel *)
- intros e. simp type_interp. eapply forall_proper; intros e'.
+ simp type_interp. eapply forall_proper; intros e'.
eapply forall_proper; intros n. eapply if_iff; first done.
eapply if_iff; first done. f_equiv. intros v. f_equiv.
eapply (IH (_, (_, _))).
(* show that the induction is decreasing *)
dsimpl.
}
- intros v. destruct A as [x | | | | A | A | A B | A B | A B | A ]; simpl; simp type_interp; eauto.
+ destruct A as [x | | | | A | A | A B | A B | A B | A ]; simpl; simp type_interp; eauto.
- f_equiv; intros e. f_equiv. f_equiv.
eapply forall_proper; intros τ.
etransitivity; last eapply (IH (_, (_, _))); last dsimpl.
@@ -436,19 +439,19 @@ Section boring_lemmas.
Lemma type_interp_move_subst :
- ∀ '(k, (B, c)), ∀ δ σ x, type_interp c B (λ n, interp_type (σ n) δ) k x ↔ type_interp c (B.[σ]) δ k x.
+ ∀ '(k, (B, ve)), ∀ δ σ, type_interp ve B (λ n, interp_type (σ n) δ) k ↔ type_interp ve (B.[σ]) δ k.
Proof.
eapply (well_founded_ind (R := term_rel) term_rel_wf).
- intros (k & A & []) IH δ σ.
+ intros (k & A & [v|e]) IH δ σ; first last.
{ (* expression rel *)
- intros e. simp type_interp. eapply forall_proper; intros e'.
+ simp type_interp. eapply forall_proper; intros e'.
eapply forall_proper; intros n. eapply if_iff; first done.
eapply if_iff; first done. f_equiv. intros v. f_equiv.
eapply (IH (_, (_, _))).
(* show that the induction is decreasing *)
dsimpl.
}
- intros v. destruct A as [x | | | | A | A | A B | A B | A B | A ]; simpl; simp type_interp; eauto.
+ destruct A as [x | | | | A | A | A B | A B | A B | A ]; simpl; simp type_interp; eauto.
- f_equiv; intros e. f_equiv. f_equiv.
eapply forall_proper; intros τ.
etransitivity; last eapply (IH (_, (_, _))); last dsimpl.
@@ -569,6 +572,7 @@ Qed.
Lemma compat_int Δ Γ z : TY Δ; Γ ⊨ (Lit $ LitInt z) : Int.
Proof.
+ split; first done.
intros θ δ k _.
eapply (sem_val_expr_rel _ _ _ #z).
simp type_interp. eauto.
@@ -576,22 +580,25 @@ Qed.
Lemma compat_bool Δ Γ b : TY Δ; Γ ⊨ (Lit $ LitBool b) : Bool.
Proof.
+ split; first done.
intros θ δ k _.
eapply (sem_val_expr_rel _ _ _ #b). simp type_interp. eauto.
Qed.
Lemma compat_unit Δ Γ : TY Δ; Γ ⊨ (Lit $ LitUnit) : Unit.
Proof.
+ split; first done.
intros θ δ k _.
- eapply (sem_val_expr_rel _ _ _ #LitUnit).
- simp type_interp. eauto.
+ eapply (sem_val_expr_rel _ _ _ #LitUnit). simp type_interp. eauto.
Qed.
Lemma compat_var Δ Γ x A :
Γ !! x = Some A →
TY Δ; Γ ⊨ (Var x) : A.
Proof.
- intros Hx θ δ k Hctx; simpl.
+ intros Hx. split.
+ { eapply bool_decide_pack, elem_of_elements, elem_of_dom_2, Hx. }
+ intros θ δ k Hctx; simpl.
specialize (sem_context_rel_vals Hctx Hx) as (e & v & He & Heq & Hv).
rewrite He. simp type_interp.
rewrite -(of_to_val _ _ Heq).
@@ -605,7 +612,9 @@ Lemma compat_app Δ Γ e1 e2 A B :
TY Δ; Γ ⊨ e2 : A →
TY Δ; Γ ⊨ (e1 e2) : B.
Proof.
- intros Hfun Harg θ δ k Hctx; simpl.
+ intros [Hfuncl Hfun] [Hargcl Harg]. split.
+ { simpl. eauto. }
+ intros θ δ k Hctx; simpl.
specialize (Hfun _ _ _ Hctx).
specialize (Harg _ _ _ Hctx).
@@ -627,7 +636,7 @@ Qed.
Lemma is_closed_subst_map_delete X Γ (x: string) θ A e:
closed X e →
subst_is_closed [] θ →
- dom Γ ⊆ dom θ →
+ dom Γ = dom θ →
(∀ y : string, y ∈ X → y ∈ dom (<[x:=A]> Γ)) →
is_closed (x :b: []) (subst_map (delete x θ) e).
Proof.
@@ -640,25 +649,25 @@ Proof.
destruct (decide (x = y)) as [<- | Hneq]; first done.
rewrite lookup_delete_ne in Hn; last done.
rewrite lookup_insert_ne in Hy; last done.
- move: Hdom1. rewrite elem_of_subseteq.
move : Hn Hy. rewrite -elem_of_dom -not_elem_of_dom.
- naive_solver.
+ rewrite Hdom1. done.
Qed.
(** Lambdas need to be closed by the context *)
-Lemma compat_lam_named Δ Γ x e A B X :
- closed X e →
- (∀ y, y ∈ X → y ∈ dom (<[x := A]> Γ)) →
+Lemma compat_lam_named Δ Γ x e A B :
TY Δ; (<[ x := A ]> Γ) ⊨ e : B →
TY Δ; Γ ⊨ (Lam (BNamed x) e) : (A → B).
Proof.
- intros Hcl Hsub Hbody θ δ k Hctxt. simpl.
+ intros [Hbodycl Hbody]. split.
+ { simpl. eapply is_closed_weaken; first eassumption. set_solver. }
+ intros θ δ k Hctxt. simpl.
eapply (sem_val_expr_rel _ _ _ (LamV x _)).
simp type_interp.
eexists (BNamed x), _. split_and!; [done| | ].
{ eapply is_closed_subst_map_delete; eauto.
+ eapply sem_context_rel_closed in Hctxt. naive_solver.
- + eapply sem_context_rel_subset in Hctxt; naive_solver.
+ + by eapply sem_context_rel_dom.
+ + apply elem_of_elements.
}
intros v' k' Hk' Hv'.
@@ -673,7 +682,7 @@ Qed.
Lemma is_closed_subst_map_anon X Γ θ e:
closed X e →
subst_is_closed [] θ →
- dom Γ ⊆ dom θ →
+ dom Γ = dom θ →
(∀ y, y ∈ X → y ∈ dom Γ) →
is_closed [] (subst_map θ e).
Proof.
@@ -682,24 +691,23 @@ Proof.
- eapply subst_is_closed_subseteq; done.
- intros y Hy%Hdom2 Hn.
apply not_elem_of_dom in Hn. apply elem_of_dom in Hy.
- move: Hdom1. rewrite elem_of_subseteq.
move : Hn Hy. rewrite -elem_of_dom -not_elem_of_dom.
- naive_solver.
+ rewrite Hdom1. done.
Qed.
-Lemma compat_lam_anon Δ Γ e A B X :
- closed X e →
- (∀ y, y ∈ X → y ∈ dom Γ) →
+Lemma compat_lam_anon Δ Γ e A B :
TY Δ; Γ ⊨ e : B →
TY Δ; Γ ⊨ (Lam BAnon e) : (A → B).
Proof.
- intros Hcl Hsub Hbody θ δ k Hctxt. simpl.
+ intros [Hbodycl Hbody]. split; first done.
+ intros θ δ k Hctxt. simpl.
eapply (sem_val_expr_rel _ _ _ (LamV BAnon _)).
simp type_interp.
eexists BAnon, _. split_and!; [done| | ].
{ eapply is_closed_subst_map_anon; eauto.
+ eapply sem_context_rel_closed in Hctxt. naive_solver.
- + eapply sem_context_rel_subset in Hctxt; naive_solver.
+ + by eapply sem_context_rel_dom.
+ + apply elem_of_elements.
}
intros v' k' Hk' Hv'.
@@ -713,7 +721,10 @@ Lemma compat_int_binop Δ Γ op e1 e2 :
TY Δ; Γ ⊨ e2 : Int →
TY Δ; Γ ⊨ (BinOp op e1 e2) : Int.
Proof.
- intros Hop He1 He2 θ δ k Hctx. simpl.
+ intros Hop [He1cl He1] [He2cl He2].
+ split; first naive_solver.
+
+ intros θ δ k Hctx. simpl.
specialize (He1 _ _ _ Hctx).
specialize (He2 _ _ _ Hctx).
@@ -741,7 +752,10 @@ Lemma compat_int_bool_binop Δ Γ op e1 e2 :
TY Δ; Γ ⊨ e2 : Int →
TY Δ; Γ ⊨ (BinOp op e1 e2) : Bool.
Proof.
- intros Hop He1 He2 θ δ k Hctx. simpl.
+ intros Hop [He1cl He1] [He2cl He2].
+ split; first naive_solver.
+
+ intros θ δ k Hctx. simpl.
specialize (He1 _ _ _ Hctx).
specialize (He2 _ _ _ Hctx).
@@ -768,7 +782,10 @@ Lemma compat_unop Δ Γ op A B e :
TY Δ; Γ ⊨ e : A →
TY Δ; Γ ⊨ (UnOp op e) : B.
Proof.
- intros Hop He θ δ k Hctx. simpl.
+ intros Hop [Hecl He].
+ split; first naive_solver.
+
+ intros θ δ k Hctx. simpl.
specialize (He _ _ _ Hctx).
eapply (bind [UnOpCtx _]); first done.
@@ -783,13 +800,14 @@ Proof.
all: simp type_interp; eauto.
Qed.
-Lemma compat_tlam Δ Γ e A X :
- closed X e →
- (∀ y, y ∈ X → y ∈ dom Γ) →
+Lemma compat_tlam Δ Γ e A :
TY S Δ; (⤉ Γ) ⊨ e : A →
TY Δ; Γ ⊨ (Λ, e) : (∀: A).
Proof.
- intros Hcl Hsub He θ δ k Hctx. simpl.
+ intros [Hecl He]. split.
+ { simpl. by erewrite <-dom_fmap. }
+
+ intros θ δ k Hctx. simpl.
simp type_interp.
intros e' n Hn Hred. eapply nsteps_val_inv' in Hred as [ -> ->]; last done.
eexists; split; first done.
@@ -797,7 +815,8 @@ Proof.
eexists _. split_and!; [ done | | ].
{ eapply is_closed_subst_map_anon; eauto.
+ eapply sem_context_rel_closed in Hctx; naive_solver.
- + eapply sem_context_rel_subset in Hctx; naive_solver.
+ + by eapply sem_context_rel_dom.
+ + rewrite dom_fmap. apply elem_of_elements.
}
intros τ. eapply He.
@@ -809,8 +828,10 @@ Lemma compat_tapp Δ Γ e A B :
TY Δ; Γ ⊨ e : (∀: A) →
TY Δ; Γ ⊨ (e <>) : (A.[B/]).
Proof.
- intros Hwf He θ δ k Hctx. simpl.
+ intros Hwf [Hecl He].
+ split; first naive_solver.
+ intros θ δ k Hctx. simpl.
specialize (He _ _ _ Hctx).
eapply (bind [TAppCtx]); first done.
intros j v Hj Hv.
@@ -832,7 +853,10 @@ Lemma compat_pack Δ Γ e n A B :
TY n; Γ ⊨ e : A.[B/] →
TY n; Γ ⊨ (pack e) : (∃: A).
Proof.
- intros Hwf Hwf' He θ δ k Hctx. simpl.
+ intros Hwf1 Hwf2 [Hecl He].
+ split; first naive_solver.
+
+ intros θ δ k Hctx. simpl.
specialize (He _ _ _ Hctx).
eapply (bind [PackCtx]); first done.
@@ -849,7 +873,9 @@ Lemma compat_unpack n Γ A B e e' x :
TY S n; <[x:=A]> (⤉Γ) ⊨ e' : B.[ren (+1)] →
TY n; Γ ⊨ (unpack e as BNamed x in e') : B.
Proof.
- intros Hwf He He' θ δ k Hctx. simpl.
+ intros Hwf [Hecl He] [He'cl He']. split.
+ { simpl. apply andb_True. split; first done. eapply is_closed_weaken; first eassumption. set_solver. }
+ intros θ δ k Hctx. simpl.
specialize (He _ _ _ Hctx).
eapply (bind [UnpackCtx _ _]); first done.
@@ -876,7 +902,10 @@ Lemma compat_if n Γ e0 e1 e2 A :
TY n; Γ ⊨ e2 : A →
TY n; Γ ⊨ (if: e0 then e1 else e2) : A.
Proof.
- intros He0 He1 He2 θ δ k Hctx. simpl.
+ intros [He0cl He0] [He1cl He1] [He2cl He2].
+ split; first naive_solver.
+
+ intros θ δ k Hctx. simpl.
specialize (He0 _ _ _ Hctx).
specialize (He1 _ _ _ Hctx).
specialize (He2 _ _ _ Hctx).
@@ -900,7 +929,10 @@ Lemma compat_pair Δ Γ e1 e2 A B :
TY Δ; Γ ⊨ e2 : B →
TY Δ; Γ ⊨ (e1, e2) : A × B.
Proof.
- intros He1 He2 θ δ k Hctx. simpl.
+ intros [He1cl He1] [He2cl He2].
+ split; first naive_solver.
+
+ intros θ δ k Hctx. simpl.
specialize (He1 _ _ _ Hctx).
specialize (He2 _ _ _ Hctx).
@@ -921,7 +953,9 @@ Lemma compat_fst Δ Γ e A B :
TY Δ; Γ ⊨ e : A × B →
TY Δ; Γ ⊨ Fst e : A.
Proof.
- intros He θ δ k Hctx.
+ intros [Hecl He]. split; first naive_solver.
+
+ intros θ δ k Hctx.
specialize (He _ _ _ Hctx).
simpl. eapply (bind [FstCtx]); first done.
intros j v Hj Hv.
@@ -936,7 +970,9 @@ Lemma compat_snd Δ Γ e A B :
TY Δ; Γ ⊨ e : A × B →
TY Δ; Γ ⊨ Snd e : B.
Proof.
- intros He θ δ k Hctx.
+ intros [Hecl He]. split; first naive_solver.
+
+ intros θ δ k Hctx.
specialize (He _ _ _ Hctx).
simpl. eapply (bind [SndCtx]); first done.
intros j v Hj Hv.
@@ -951,33 +987,35 @@ Lemma compat_injl Δ Γ e A B :
TY Δ; Γ ⊨ e : A →
TY Δ; Γ ⊨ InjL e : A + B.
Proof.
- (* FIXME: exercise for you *)
-(*Qed.*)
+ (* TODO: exercise *)
Admitted.
+
Lemma compat_injr Δ Γ e A B :
TY Δ; Γ ⊨ e : B →
TY Δ; Γ ⊨ InjR e : A + B.
Proof.
- (* FIXME: exercise for you *)
-(*Qed.*)
+ (* TODO: exercise *)
Admitted.
+
Lemma compat_case Δ Γ e e1 e2 A B C :
TY Δ; Γ ⊨ e : B + C →
TY Δ; Γ ⊨ e1 : (B → A) →
TY Δ; Γ ⊨ e2 : (C → A) →
TY Δ; Γ ⊨ Case e e1 e2 : A.
Proof.
- (* FIXME: exercise for you *)
-(*Qed.*)
+ (* TODO: exercise *)
Admitted.
+
Lemma compat_roll n Γ e A :
TY n; Γ ⊨ e : (A.[(μ: A)%ty/]) →
TY n; Γ ⊨ (roll e) : (μ: A).
Proof.
- intros He θ δ k Hctx. simpl.
+ intros [Hecl He]. split; first naive_solver.
+
+ intros θ δ k Hctx. simpl.
specialize (He _ _ _ Hctx).
eapply (bind [RollCtx]); first done.
@@ -994,7 +1032,9 @@ Lemma compat_unroll n Γ e A :
TY n; Γ ⊨ e : (μ: A) →
TY n; Γ ⊨ (unroll e) : (A.[(μ: A)%ty/]).
Proof.
- intros He θ δ k Hctx. simpl.
+ intros [Hecl He]. split; first naive_solver.
+
+ intros θ δ k Hctx. simpl.
specialize (He _ _ _ Hctx).
eapply (bind [UnrollCtx]); first done.
@@ -1012,26 +1052,7 @@ Lemma sem_soundness Δ Γ e A :
TY Δ; Γ ⊢ e : A →
TY Δ; Γ ⊨ e : A.
Proof.
- induction 1 as [ | Δ Γ x e A B Hsyn IH | Δ Γ e A B Hsyn IH| Δ Γ e A Hsyn IH| | | | | | | | | n Γ e1 e2 op A B C Hop ? ? ? ? | | | | | | | | | ]; eauto.
- - (* lambda *)
- set (X := elements (dom (<[x := A]>Γ))).
- specialize (syn_typed_closed _ _ _ _ X Hsyn) as Hcl.
- eapply compat_lam_named; last done.
- + apply Hcl. apply elem_of_elements.
- + intros ??. by apply elem_of_elements.
- - (* lambda anon *)
- set (X := elements (dom Γ)).
- specialize (syn_typed_closed _ _ _ _ X Hsyn) as Hcl.
- eapply compat_lam_anon; last done.
- + apply Hcl. apply elem_of_elements.
- + intros ??. by apply elem_of_elements.
- - (* tlam *)
- set (X := elements (dom Γ)).
- specialize (syn_typed_closed _ _ _ _ X Hsyn) as Hcl.
- eapply compat_tlam; last done.
- + apply Hcl. rewrite dom_fmap. apply elem_of_elements.
- + intros ??. by apply elem_of_elements.
- - (* binop *) inversion Hop; subst; eauto.
+ induction 1 as [ | Δ Γ x e A B Hsyn IH | Δ Γ e A B Hsyn IH| Δ Γ e A Hsyn IH| | | | | | | | | n Γ e1 e2 op A B C [] ? ? ? ? | | | | | | | | | ]; eauto.
Qed.
@@ -1047,7 +1068,7 @@ Lemma type_safety e A :
TY 0; ∅ ⊢ e : A →
safe e.
Proof.
- intros He%sem_soundness e' n Hred.
+ intros [Hecl He]%sem_soundness e' n Hred.
specialize (He ∅ δ_any (S n)). simp type_interp in He.
rewrite subst_map_empty in He.
edestruct (He ) as (v & Hv & _); [ | | eassumption | ].
diff --git a/theories/type_systems/systemf_mu/pure.v b/theories/type_systems/systemf_mu/pure.v
index 22414374c2a34bf8a83c2aa84ab10190ebfecf3c..d7c942affb1314017f9b758d8bea11af8b6abb7c 100644
--- a/theories/type_systems/systemf_mu/pure.v
+++ b/theories/type_systems/systemf_mu/pure.v
@@ -7,10 +7,10 @@ Lemma contextual_ectx_step_case K e e' :
contextual_step (fill K e) e' →
(∃ e'', e' = fill K e'' ∧ contextual_step e e'') ∨ is_val e.
Proof.
- (* FIXME: exercise for you :) *)
-(*Qed.*)
+ (* TODO: exercise *)
Admitted.
+
(** ** Deterministic reduction *)
Record det_step (e1 e2 : expr) := {
@@ -162,10 +162,11 @@ Lemma red_nsteps_fill K k e e' :
red_nsteps j e e'' ∧
red_nsteps (k - j) (fill K e'') e'.
Proof.
- (* FIXME: this is an exercise :) *)
+ (* TODO: exercise *)
Admitted.
+
(** Additionally useful stepping lemmas *)
Lemma app_step_r (e1 e2 e2': expr) :
contextual_step e2 e2' → contextual_step (e1 e2) (e1 e2').
diff --git a/theories/type_systems/systemf_mu/types.v b/theories/type_systems/systemf_mu/types.v
index eaca72d9afbf83e92b19ec9b6ca1b0c56c347b10..46c6842b50f519aa71ef1d56a8197cee3459907e 100644
--- a/theories/type_systems/systemf_mu/types.v
+++ b/theories/type_systems/systemf_mu/types.v
@@ -843,12 +843,18 @@ Proof.
+ destruct H1 as [e' H1]. eexists.
eapply (fill_contextual_step [CaseCtx e1 e2]). done.
- (* roll *)
- (* FIXME: exercise *)
- admit.
+ destruct (IH HeqΓ Heqn) as [Hval|Hred].
+ + by left.
+ + right. destruct Hred as [e' Hred].
+ eexists. eapply (fill_contextual_step [RollCtx]). done.
- (* unroll *)
- (* FIXME: exercise *)
- admit.
-Admitted.
+ destruct (IH HeqΓ Heqn) as [Hval|Hred].
+ + eapply canonical_values_rec in Hty as (e' & -> & Hval'); last done.
+ right. eexists. eapply base_contextual_step. by econstructor.
+ + right. destruct Hred as [e' Hred].
+ eexists. eapply (fill_contextual_step [UnrollCtx]). done.
+Qed.
+
Definition ectx_item_typing (K: ectx_item) (A B: type) :=
∀ e, TY 0; ∅ ⊢ e : A → TY 0; ∅ ⊢ (fill_item K e) : B.
@@ -1024,8 +1030,9 @@ Proof.
- eapply case_inversion in Hty as (B & C & (? & ? & [= <- <-] & Hty & ?)%injr_inversion & ? & ?).
eauto.
- (* unroll *)
- (* FIXME: exercise *)
-Admitted.
+ eapply unroll_inversion in Hty as (B & -> & Hty).
+ eapply roll_inversion in Hty as (C & Heq & Hty). injection Heq as ->. done.
+Qed.
Lemma typed_preservation e e' A:
TY 0; ∅ ⊢ e : A →
diff --git a/theories/type_systems/systemf_mu/z_combinator.v b/theories/type_systems/systemf_mu/z_combinator.v
index 962d4837c536c6f06d684f096bb7adc8fe20e3eb..4a712110b49ccece9326d8e2db68f18db09f4b30 100644
--- a/theories/type_systems/systemf_mu/z_combinator.v
+++ b/theories/type_systems/systemf_mu/z_combinator.v
@@ -12,7 +12,7 @@ Proof.
{ apply (sem_expr_rel_of_val _ _ _ (LamV x e)). lia. }
intros _. simp type_interp.
eexists _, _; split_and!; [done | done | ].
- intros v' kd Hlt _. assert (kd = 0) as -> by lia.
+ intros v' k Hlt _. assert (k = 0) as -> by lia.
(* NOTE: this crucially uses that the expression relation at zero is trivial *)
apply sem_expr_rel_zero_trivial.
Qed.
@@ -30,14 +30,19 @@ Lemma Z_safe n (Γ : typing_context) (A B : type) :
TY n; (<["f" := (A → B)%ty]> (<["x" := A]> Γ)) ⊨ e : B →
TY n; Γ ⊨ Z : (A → B).
Proof.
- intros ?? Hcl He θ δ k Hctx.
+ intros ?? Hcl He.
+ split.
+ { simpl. repeat split_and; try naive_solver.
+ all: eapply is_closed_weaken; [eassumption|set_solver]. }
+
+ intros θ δ k Hctx.
simpl.
rewrite lookup_delete_ne; last done. rewrite !lookup_delete.
rewrite delete_idemp.
rewrite (delete_commute _ "x" "f").
rewrite delete_idemp.
set (θ' := (delete (M := gmap.gmap _ _) "f" (delete "x" (M := gmap.gmap _ _) θ))).
- specialize (sem_context_rel_dom_eq _ _ _ _ Hctx) as Hdom.
+ specialize (sem_context_rel_dom _ _ _ _ Hctx) as Hdom.
assert (is_closed ["x"; "f"; "f"; "x"] (subst_map θ' e)).
{ (* boring, ignore this *)
apply is_closed_subst_map.
@@ -45,7 +50,6 @@ Proof.
eapply (subst_is_closed_subseteq _ _ θ); last by eapply sem_context_rel_closed.
subst θ'. etrans; eapply delete_subseteq.
- eapply is_closed_weaken; first done.
- apply sem_context_rel_subset in Hctx.
simplify_list_subseteq.
subst θ'.
apply stdpp.sets.elem_of_subseteq.
@@ -104,7 +108,7 @@ Proof.
apply (sem_context_rel_insert _ _ _ _ (LamV _ _)).
{ eapply sem_expr_rel_lambda_val; first by simplify_closed.
destruct k.
- { simpl. replace (k'') with 0 by lia. apply sem_expr_rel_zero_trivial. }
+ { simpl. replace k'' with 0 by lia. apply sem_expr_rel_zero_trivial. }
eapply IH. lia.
eapply sem_context_rel_mono; last done. lia.
}
@@ -124,7 +128,12 @@ Lemma Z_safe' (A B : type) (s : val) :
TY 0; ∅ ⊨ s : ((A → B) → A → B) →
TY 0; ∅ ⊨ (Fix s) : (A → B).
Proof.
- intros Hcl HF θ δ k Hctx.
+ intros Hcl HF.
+ split.
+ { simpl. split_and; last done.
+ eapply is_closed_weaken; [eassumption|set_solver]. }
+
+ intros θ δ k Hctx.
simpl.
rewrite !lookup_delete.
rewrite (delete_commute _ "x" "y").
@@ -139,7 +148,7 @@ Proof.
apply (sem_val_expr_rel _ _ _ (LamV _ _)).
simp type_interp. eexists _, _. split_and!; [done |simplify_closed | ].
- intros v' k' Hk'' Hv'. simpl.
+ intros v' k' Hk' Hv'. simpl.
eapply semantic_app; first last.
{ apply sem_val_expr_rel. done. }
simpl. rewrite subst_is_closed_nil; last done.
@@ -166,8 +175,7 @@ Proof.
simp type_interp in Hv2.
destruct Hv2 as (x & e & -> & ? & Hv2).
eapply expr_det_steps_closure. { do_det_step. econstructor. }
- eapply (Hv2 (LamV _ _)).
- { lia. }
+ eapply (Hv2 (LamV _ _)); first lia.
simp type_interp. eexists _, _. split_and!; [done |simplify_closed | ].
intros v' k'4 Hk'4 Hv'. simpl.
@@ -185,7 +193,7 @@ Proof.
eapply val_rel_mono; last done. lia.
}
destruct k0 as [ | k0]; last (eapply IH; lia).
- replace k'4 with 0 by lia.
+ simpl. replace k'4 with 0 by lia.
eapply sem_expr_rel_zero_trivial.
Qed.
diff --git a/theories/type_systems/systemf_mu_state/exercises07.v b/theories/type_systems/systemf_mu_state/exercises07.v
index 1ba385f263b6e3511bbeffa36b5c759a3d4da83d..59c2d195a101c5dcbc56a238deff83769a175db9 100644
--- a/theories/type_systems/systemf_mu_state/exercises07.v
+++ b/theories/type_systems/systemf_mu_state/exercises07.v
@@ -69,21 +69,19 @@ Definition list_t (A : type) : type :=
Definition mystack : val :=
(* define your stack implementation, assuming "lc" is a list implementation *)
- λ: "lc",
- #0 (* FIXME *).
+ λ: "lc", #0. (* FIXME *)
+
Definition make_mystack : val :=
Λ, λ: "lc",
unpack "lc" as "lc" in
- #0 (* FIXME *).
+ #0. (* FIXME *)
Lemma make_mystack_typed Σ n Γ :
TY Σ; n; Γ ⊢ make_mystack : (∀: list_t #0 → stack_t #0).
Proof.
repeat solve_typing_fast.
- (* FIXME *)
Admitted.
-(*Qed.*)
(** Exercise 2 (LN Exercise 46): Obfuscated code *)
@@ -112,46 +110,18 @@ Lemma obf_expr_eval :
∃ h', rtc contextual_step (obf_expr, ∅) (of_val #0 (* FIXME: what is the result? *), h').
Proof.
eexists. unfold obf_expr.
- (*FIXME *)
+ (* TODO: exercise *)
Admitted.
-(*Qed.*)
-(** Exercise 3 (LN Exercise 47): Diverging term *)
-
-Definition diverge : val :=
- #0. (* FIXME *)
-Lemma diverge_typed Σ n Γ :
- TY Σ; n; Γ ⊢ diverge : (Int → Int).
-Proof.
- repeat solve_typing_fast.
- (* FIXME *)
-Admitted.
-(*Qed.*)
(** Exercise 4 (LN Exercise 48): Fibonacci *)
-Definition fibonacci : val :=
- #0 (* FIXME *)
-.
-Lemma fibonacci_typed Σ n Γ :
- TY Σ; n; Γ ⊢ fibonacci : (Int → Int).
-Proof.
- repeat solve_typing_fast.
- (*FIXME *)
-Admitted.
-(*Qed.*)
-
-(** Exercise 5 (LN Exercise 49): Counter with Reset *)
-Definition make_counter : val :=
- #0 (* FIXME *)
-.
-
-Lemma make_counter_typed Σ n Γ :
- TY Σ; n; Γ ⊢ make_counter : (Unit → (Unit → Int) × (Unit → Unit)).
+Definition fibonacci : val := #0. (* FIXME *)
+
+Lemma fibonacci_typed Σ n Γ :
+ TY Σ; n; Γ ⊢ fibonacci : (Int → Int).
Proof.
repeat solve_typing_fast.
- (* FIXME *)
Admitted.
-(*Qed.*)
diff --git a/theories/type_systems/systemf_mu_state/logrel.v b/theories/type_systems/systemf_mu_state/logrel.v
index 7703886a705211e4eb3ba3caf3e1cc66cb14ee14..52e02863ae39fe3f433500850aea2bd46d306646 100644
--- a/theories/type_systems/systemf_mu_state/logrel.v
+++ b/theories/type_systems/systemf_mu_state/logrel.v
@@ -495,11 +495,12 @@ Equations type_interp (c : type_case) (t : type) δ (k : nat) (W : world) (v : m
type_interp val_case (A → B) δ k W v =>
∃ x e, v = LamV x e ∧ is_closed (x :b: nil) e ∧
- (* We write ∀ (H:k' ≤ k), .. instead of k' ≤ k → .. due to a longstanding Coq quirk, see
- https://coq.zulipchat.com/#narrow/stream/237977-Coq-users/topic/.60Program.60.20and.20variable.20names/near/404824378 *)
- ∀ v' k' W' (Hk' : k' ≤ k), W' ⊒ W →
- type_interp val_case A δ k' W' v' →
- type_interp expr_case B δ k' W' (subst' x (of_val v') e);
+ (* Slightly weird formulation: for down-closure, we want to quantify over all k' ≤ k --
+ but with that formulation, the termination checker will not be able to see that k' will really be smaller!
+ Thus, we quantify over the difference kd and subtract *)
+ ∀ v' kd W', W' ⊒ W →
+ type_interp val_case A δ (k - kd) W' v' →
+ type_interp expr_case B δ (k - kd) W' (subst' x (of_val v') e);
type_interp val_case (#α) δ k W v =>
(δ α).(sem_type_car) k W v;
type_interp val_case (∀: A) δ k W v =>
@@ -508,10 +509,13 @@ Equations type_interp (c : type_case) (t : type) δ (k : nat) (W : world) (v : m
type_interp val_case (∃: A) δ k W v =>
∃ v', v = PackV v' ∧
∃ τ : sem_type, type_interp val_case A (τ .: δ) k W v';
- (** By requiring k' < k, we implicitly encode that k > 0
+ (** Defined with two cases: ordinarily, we might require [k > 0] in the body as a guard for the recursive call,
+ but this does not count as a proper guard for termination for Coq -- therefore we handle the 0-case separately.
*)
- type_interp val_case (μ: A) δ k W v =>
- ∃ v', v = (roll v')%V ∧ is_closed [] v' ∧ ∀ k' (H : k' < k), type_interp val_case (A.[μ: A/]%ty) δ k' W v';
+ type_interp val_case (μ: A) δ (S k) W v =>
+ ∃ v', v = (roll v')%V ∧ is_closed [] v' ∧ ∀ kd, type_interp val_case (A.[μ: A/]%ty) δ (k - kd) W v';
+ type_interp val_case (μ: A) δ 0 W v =>
+ ∃ v', v = (roll v')%V ∧ is_closed [] v';
(** The reference case *)
type_interp val_case (Ref a) δ k W v =>
∃ (l : loc), v = LitV $ LitLoc l ∧ ∃ i INV, W !! i = Some INV ∧
@@ -572,7 +576,9 @@ Proof.
- intros (x & e & -> & ? & _). done.
- intros (v1 & v2 & -> & ? & ?). simpl; apply andb_True; split; eauto.
- intros [(v' & -> & ?) | (v' & -> & ?)]; simpl; eauto.
- - intros (v' & -> & ? & Ha); done.
+ - destruct k; simp type_interp.
+ + intros (v' & -> & ?); done.
+ + intros (v' & -> & ? & Ha); done.
- intros (l & -> & _). done.
Qed.
@@ -603,12 +609,14 @@ Proof.
exists τ. eapply (IH (k, (A, _))); [ dsimpl | done..].
- (* fun case *)
destruct Hv as (x & e & -> & ? & Hv). exists x, e. split_and!; [done..| ].
- intros v' k'' W' Hk'' Hv' Hincl.
+ intros v' kd W' Hv' Hincl.
(* slightly tricky due to the contravariant recursive occurrence *)
- specialize (Hv v' k'').
- eapply (IH (k'', (B, expr_case))); [ | lia | eapply Hv; [lia|done..] ].
- destruct (decide (k'' < k)) as [ ? | ?]; first (left; lia).
- replace k'' with k by lia. dsimpl.
+ set (kd' := k - k').
+ specialize (Hv v' (kd + kd')).
+ replace (k - (kd + kd')) with (k' - kd) in Hv by lia.
+ eapply (IH (k' - kd, (B, expr_case))); [ | lia | by eapply Hv].
+ destruct (decide (k' - kd < k)) as [ ? | ?]; first (left; lia).
+ assert (k' - kd = k) as -> by lia. dsimpl.
- (* pair case *)
destruct Hv as (v1 & v2 & -> & Hv1 & Hv2).
exists v1, v2. split_and!; first done.
@@ -618,11 +626,16 @@ Proof.
all: exists v'; split; first done.
all: eapply (IH (k, (_, _))); [ dsimpl | done..].
- (* rec case *)
+ destruct k; simp type_interp in Hv.
+ { assert (k' = 0) as -> by lia. simp type_interp. }
destruct Hv as (v' & -> & ? & Hv).
+ destruct k' as [ | k']; simp type_interp.
+ { eauto. }
exists v'. split_and!; [ done.. | ].
- intros k'' Hk'.
+ intros kd.
(* here we crucially use that we can decrease the index *)
- eapply (IH (k'', (A.[(μ: A)%ty/], val_case))); [left | | apply Hv]; lia.
+ eapply (IH (k - kd, (A.[(μ: A)%ty/], val_case))); [ | lia | done].
+ left. lia.
Qed.
(** We can now derive the two desired lemmas *)
@@ -658,13 +671,12 @@ Proof.
exists τ. eapply (IH (k, (A, _))); [ dsimpl | done..].
- (* fun case *)
destruct Hv as (x & e & -> & ? & Hv). exists x, e. split_and!; [done..| ].
- intros v' k' W'' Hk' Hincl Hv'.
- specialize (Hv v' k' W'').
- eapply (IH (k', (B, expr_case))); [ dsimpl | | eapply Hv].
+ intros v' kd W'' Hincl Hv'.
+ specialize (Hv v' kd W'').
+ eapply (IH (k - kd, (B, expr_case))); [ dsimpl | | eapply Hv].
+ done.
- + lia.
+ etrans; done.
- + eapply (IH (k', (A, val_case))); last done; last done. dsimpl.
+ + eapply (IH (k -kd, (A, val_case))); last done; last done. dsimpl.
- (* pair case *)
destruct Hv as (v1 & v2 & -> & Hv1 & Hv2).
exists v1, v2. split_and!; first done.
@@ -674,11 +686,15 @@ Proof.
all: exists v'; split; first done.
all: eapply (IH (k, (_, _))); [ dsimpl | done..].
- (* rec case *)
+ destruct k; simp type_interp in Hv.
+ { simp type_interp. }
destruct Hv as (v' & -> & ? & Hv).
+ simp type_interp.
exists v'. split_and!; [ done.. | ].
- intros k' Hk'.
+ intros kd.
(* here we crucially use that we can decrease the index *)
- eapply (IH (k', (A.[(μ: A)%ty/], val_case))); [left | done | apply Hv]; lia.
+ eapply (IH (k - kd, (A.[(μ: A)%ty/], val_case))); [ | done | done].
+ left. lia.
- (* loc case *)
destruct Hv as (l & -> & (i & INV & Hlook & Heq)).
exists l. split; first done.
@@ -840,19 +856,19 @@ Section boring_lemmas.
intros [|m] ?; simpl; eauto.
- f_equiv. intros ?. f_equiv. intros ?.
f_equiv. f_equiv. eapply forall_proper. intros ?.
- eapply forall_proper. intros k'.
- eapply forall_proper. intros W'.
eapply forall_proper. intros ?.
+ eapply forall_proper. intros W'.
eapply if_iff'; intros.
eapply if_iff; (eapply (IH (_, (_, _))); first dsimpl).
all: intros; eapply Hd; etrans; done.
- f_equiv. intros ?. f_equiv. intros ?.
f_equiv. f_equiv; by eapply (IH (_, (_, _))); first dsimpl.
- f_equiv; f_equiv; intros ?; f_equiv; by eapply (IH (_, (_, _))); first dsimpl.
- - f_equiv; intros ?. f_equiv. f_equiv.
- eapply forall_proper; intros k'.
- eapply forall_proper; intros ?.
- by eapply (IH (_, (_, _))); first dsimpl.
+ - destruct k; simp type_interp.
+ + done.
+ + f_equiv; intros ?. f_equiv. f_equiv.
+ eapply forall_proper; intros ?.
+ by eapply (IH (_, (_, _))); first dsimpl.
Qed.
Lemma type_interp_move_ren :
@@ -884,15 +900,17 @@ Section boring_lemmas.
intros [|m] ?; simpl; eauto.
- f_equiv. intros ?. f_equiv. intros ?.
f_equiv. f_equiv. eapply forall_proper. intros ?.
- do 3 (eapply forall_proper; intros ?).
+ eapply forall_proper. intros ?. eapply forall_proper. intros ?.
eapply if_iff; first done. eapply if_iff; by eapply (IH (_, (_, _))); first dsimpl.
- f_equiv. intros ?. f_equiv. intros ?.
f_equiv. f_equiv; by eapply (IH (_, (_, _))); first dsimpl.
- f_equiv; f_equiv; intros ?; f_equiv; by eapply (IH (_, (_, _))); first dsimpl.
- - f_equiv; intros ?. f_equiv. f_equiv.
- do 2 (eapply forall_proper; intros ?).
- etransitivity; first eapply (IH (_, (_, _))); first dsimpl.
- asimpl. done.
+ - destruct k; simp type_interp.
+ + done.
+ + f_equiv; intros ?. f_equiv. f_equiv.
+ eapply forall_proper; intros ?.
+ etransitivity; first eapply (IH (_, (_, _))); first dsimpl.
+ asimpl. done.
Qed.
Lemma type_interp_move_subst :
@@ -932,15 +950,18 @@ Section boring_lemmas.
done.
- f_equiv. intros ?. f_equiv. intros ?.
f_equiv. f_equiv. eapply forall_proper. intros ?.
- do 3 (eapply forall_proper; intros ?).
- eapply if_iff; first done. eapply if_iff; by eapply (IH (_, (_, _))); first dsimpl.
+ eapply forall_proper. intros ?. eapply forall_proper. intros W'.
+ eapply if_iff; first done.
+ eapply if_iff; by eapply (IH (_, (_, _))); first dsimpl.
- f_equiv. intros ?. f_equiv. intros ?.
f_equiv. f_equiv; by eapply (IH (_, (_, _))); first dsimpl.
- f_equiv; f_equiv; intros ?; f_equiv; by eapply (IH (_, (_, _))); first dsimpl.
- - f_equiv; intros ?. f_equiv. f_equiv.
- do 2 (eapply forall_proper; intros ?).
- etransitivity; first eapply (IH (_, (_, _))); first dsimpl.
- asimpl. done.
+ - destruct k; simp type_interp.
+ + done.
+ + f_equiv; intros ?. f_equiv. f_equiv.
+ eapply forall_proper; intros ?.
+ etransitivity; first eapply (IH (_, (_, _))); first dsimpl.
+ asimpl. done.
Qed.
@@ -1082,10 +1103,11 @@ Proof.
intros j' f W'' Hj' HW' Hf.
simp type_interp in Hf. destruct Hf as (x & e & -> & Hcl & Hf).
- specialize (Hf v j').
+ specialize (Hf v 0).
+ replace (j' - 0) with j' in Hf by lia.
eapply expr_det_step_closure.
{ eapply det_step_beta. apply is_val_of_val. }
- eapply expr_rel_mono_idx; last apply Hf; [ lia | lia | reflexivity | ].
+ eapply expr_rel_mono_idx; last apply Hf; [lia | reflexivity | ].
eapply val_rel_mono; last done; [lia | done].
Qed.
@@ -1126,8 +1148,8 @@ Proof.
+ eapply sem_context_rel_subset in Hctxt; naive_solver.
}
- intros v' k' W' Hk' Hv' Hincl.
- specialize (Hbody (<[ x := of_val v']> θ) δ k' W').
+ intros v' kd W' Hv' Hincl.
+ specialize (Hbody (<[ x := of_val v']> θ) δ (k - kd) W').
simpl. rewrite subst_subst_map.
2: { by eapply sem_context_rel_closed. }
apply Hbody.
@@ -1167,8 +1189,8 @@ Proof.
+ eapply sem_context_rel_subset in Hctxt; naive_solver.
}
- intros v' k' W' Hk' Hv' Hincl.
- apply (Hbody θ δ k' W').
+ intros v' kd W' Hv' Hincl.
+ apply (Hbody θ δ (k - kd) W').
eapply sem_context_rel_mono; [ | done..]. lia.
Qed.
@@ -1456,7 +1478,7 @@ Proof.
intros j' v W'' Hj' HW' Hv. simpl.
simp type_interp in Hv. destruct Hv as (x & e' & -> & ? & Hv).
eapply expr_det_step_closure. { apply det_step_beta. apply is_val_of_val. }
- apply Hv; [lia | done | ]. eapply val_rel_mono; last done; [lia | done].
+ apply Hv; first done. eapply val_rel_mono; last done; [lia | done].
- simpl. eapply expr_det_step_closure.
{ apply det_step_caser. apply is_val_of_val. }
eapply (bind [AppLCtx _]).
@@ -1464,7 +1486,7 @@ Proof.
intros j' v W'' Hj' HW' Hv. simpl.
simp type_interp in Hv. destruct Hv as (x & e' & -> & ? & Hv).
eapply expr_det_step_closure. { apply det_step_beta. apply is_val_of_val. }
- apply Hv; [lia | done | ]. eapply val_rel_mono; last done; [lia | done].
+ apply Hv; first done. eapply val_rel_mono; last done; [lia | done].
Qed.
Lemma compat_roll n Γ e A :
@@ -1479,9 +1501,9 @@ Proof.
eapply (sem_val_expr_rel _ _ _ _ (RollV v)).
specialize (val_rel_is_closed _ _ _ _ _ Hv) as ?.
- simp type_interp.
+ destruct j as [ | j]; simp type_interp; first by eauto.
exists v. split_and!; [done.. | ].
- intros k' Hk'. eapply val_rel_mono_idx; last done. lia.
+ intros kd. eapply val_rel_mono_idx; last done. lia.
Qed.
Lemma compat_unroll n Γ e A :
@@ -1493,12 +1515,11 @@ Proof.
eapply (bind [UnrollCtx]); first done.
intros j v W' Hj HW Hv.
+ destruct j as [ | j]; first by apply sem_expr_rel_zero_trivial.
simp type_interp in Hv. destruct Hv as (v' & -> & ? & Hv).
eapply expr_det_step_closure.
{ simpl. apply det_step_unroll. apply is_val_of_val. }
- destruct j as [|j].
- + apply sem_expr_rel_zero_trivial.
- + eapply sem_val_expr_rel, Hv. lia.
+ eapply sem_val_expr_rel. apply Hv.
Qed.
@@ -1590,10 +1611,22 @@ Lemma compat_new Δ Γ e a :
TY Δ; Γ ⊨ e : a →
TY Δ; Γ ⊨ new e : (Ref a).
Proof.
- (* FIXME: exercise for you *)
- (* you may find the lemma [wsat_init_heap] above helpful. *)
-(*Qed.*)
-Admitted.
+ intros He θ δ k W Hctx.
+ eapply (bind [NewCtx]). { eapply He; done. }
+ intros j v W' Hj Hext Hv.
+ simp type_interp.
+
+ intros e' σ σ' W'' n Hext' Hsat' Hn Hred.
+ eapply new_nsteps_inv in Hred as [-> Hstep]; last apply to_of_val.
+ eapply new_step_inv in Hstep as (l & -> & -> & ?); last apply to_of_val.
+ exists #l, ((λ σ', ∃ v, σ' = <[ l := v ]> ∅ ∧ TY 0; ∅ ⊢ (of_val v) : a) :: W'').
+ split_and!; [done | eapply suffix_cons_l; reflexivity | .. ].
+ { apply wsat_init_heap; [ done.. | ].
+ by eapply syn_fo_typed_val.
+ }
+ simp type_interp.
+ exists l. split; first done. eexists 0, _. split; done.
+Qed.
Lemma compat_load Δ Γ e a :
TY Δ; Γ ⊨ e : Ref a →
@@ -1629,43 +1662,10 @@ Lemma compat_store Δ Γ e1 e2 a :
TY Δ; Γ ⊨ e2 : a →
TY Δ; Γ ⊨ (e1 <- e2) : Unit.
Proof.
- intros He1 He2 θ δ k W Hctx. simpl.
- eapply (bind [StoreRCtx _]). { eapply He2; done. }
- intros j v W' Hj Hext Hv2.
-
- eapply (bind [StoreLCtx _]).
- { eapply expr_rel_mono; last eapply He1; done. }
- intros j' v' W'' Hj' Hext' Hv1.
- simp type_interp in Hv1.
- destruct Hv1 as (l & -> & (i & INV & Hlook & ->)).
-
- simp type_interp.
- intros e' σ σ' W''' n Hext'' Hsat' Hn.
- specialize (wsat_lookup W'' _ i _ ltac:(by eapply wsat_wext) Hlook) as (? & Hincl & (vm & -> & ?)).
+ (* you may find the lemmas [wsat_lookup, wsat_update] above helpful. *)
+ (* TODO: exercise *)
+Admitted.
- intros [(-> & -> & -> & Hirred) | [-> Hstep]]%store_nsteps_inv.
- { exfalso; apply Hirred.
- exists (Lit LitUnit), (<[l := v]> σ). apply base_contextual_step.
- econstructor. 2: by rewrite to_of_val.
- eapply lookup_weaken; last done. apply lookup_insert.
- }
- apply store_step_inv in Hstep.
- destruct Hstep as (? & v' & [= <-] & Hl & -> & ->).
- eexists _, _. split_and!; [reflexivity | reflexivity | | ].
- 2: { simp type_interp. done. }
-
- (* restore the invariant *)
- destruct Hext'' as (Pre & ->).
- eapply (wsat_update _ _ (length Pre + i) _ _ ); [ done | ..].
- { rewrite lookup_app_r; last lia.
- replace (length Pre + i - length Pre) with i by lia.
- done.
- }
- intros σ' (v'' & -> & _). split.
- { apply lookup_insert_is_Some. by left. }
- exists v. rewrite insert_insert. split; first done.
- eapply syn_fo_typed_val; done.
-Qed.
Local Hint Resolve compat_var compat_lam_named compat_lam_anon compat_tlam compat_int compat_bool compat_unit compat_if compat_app compat_tapp compat_pack compat_unpack compat_int_binop compat_int_bool_binop compat_unop compat_pair compat_fst compat_snd compat_injl compat_injr compat_case compat_roll compat_unroll compat_new compat_store compat_load: core.
@@ -1733,6 +1733,6 @@ Proof.
simp type_interp in Hf. destruct Hf as (x & e & -> & Hcl & Hf).
eapply expr_det_step_closure.
{ apply det_step_beta. apply is_val_of_val. }
- apply Hf; [lia | done | ].
+ apply Hf; first done.
eapply val_rel_mono; [ | done..]. lia.
Qed.
diff --git a/theories/type_systems/systemf_mu_state/mutbit.v b/theories/type_systems/systemf_mu_state/mutbit.v
index fe7937e0804323f4f8a860875dd0270abd7e63ad..1899ecf40916a242434f803420136b614404562b 100644
--- a/theories/type_systems/systemf_mu_state/mutbit.v
+++ b/theories/type_systems/systemf_mu_state/mutbit.v
@@ -53,7 +53,7 @@ Proof.
simp type_interp. eexists _, _. split; first done. split.
- (* flip *)
simp type_interp. eexists _, _. split; first done. split; first done.
- intros v1 k1' W3 Hk1' Hincl2 Hv1. simpl.
+ intros v1 kd1 W3 Hincl2 Hv1. simpl.
simp type_interp. intros e3 h3 h4 W4 n3 Hincl3 Hsat3 ? Hred.
eapply (red_nsteps_fill [BinOpLCtx _ (LitV _);IfCtx _ _; IfCtx _ _; AppRCtx _]) in Hred as (n4 & e4 & h5 & ? & Hred_load & Hred).
eapply (load_nsteps_inv' _ _ _ _ _ _ (λ v, v = #0 ∨ v = #1)) in Hred_load; [ | done | ].
@@ -101,7 +101,7 @@ Proof.
all: rewrite insert_insert; subst INV; simpl; eauto.
- (* get *)
simp type_interp. eexists _, _. split; first done. split; first done.
- intros v1 k'1 W3 Hk'1 Hincl2 Hv1. simpl.
+ intros v1 kd1 W3 Hincl2 Hv1. simpl.
simp type_interp. intros e3 h3 h4 W4 n3 Hincl3 Hsat3 ? Hred.
eapply (red_nsteps_fill [BinOpLCtx _ (LitV _);IfCtx _ _; IfCtx _ _; AppRCtx _]) in Hred as (n4 & e4 & h5 & ? & Hred_load & Hred).
eapply (load_nsteps_inv' _ _ _ _ _ _ (λ v, v = #0 ∨ v = #1)) in Hred_load; [ | done | ].
diff --git a/theories/type_systems/systemf_mu_state/types.v b/theories/type_systems/systemf_mu_state/types.v
index 3f737074561b55fdd2111fa91f915ba13d603125..0b020edca41206e2fac1204b5877fc018b3dd314 100644
--- a/theories/type_systems/systemf_mu_state/types.v
+++ b/theories/type_systems/systemf_mu_state/types.v
@@ -1246,15 +1246,14 @@ Proof.
eapply unroll_inversion in Hty as (B & -> & Hty).
eapply roll_inversion in Hty as (C & Heq & Hty). injection Heq as ->. done.
- (* new *)
- (* FIXME: exercise *)
+ (* TODO: exercise *)
admit.
- (* load *)
- (* FIXME exercise *)
+ (* TODO: exercise *)
admit.
- (* store *)
- (* FIXME exercise *)
+ (* TODO: exercise *)
admit.
-(*Qed.*)
Admitted.
Lemma typed_preservation Σ e e' h h' A:
diff --git a/theories/type_systems/warmup/sheet0.v b/theories/type_systems/warmup/sheet0.v
deleted file mode 100644
index 11f0cc9819c2e2d35707a43f70628f063c730048..0000000000000000000000000000000000000000
--- a/theories/type_systems/warmup/sheet0.v
+++ /dev/null
@@ -1,253 +0,0 @@
-(* Throughout the course, we will be using the [stdpp] library to provide
- some useful and common features.
- We will introduce you to its features as we need them.
- *)
- From stdpp Require Import base tactics numbers strings.
- From stdpp Require relations.
- From semantics.lib Require Import maps.
-
- (** * Exercise sheet 0 *)
-
-(* We are using Coq's notion of integers, [Z].
- All the standard operations, like [+] and [*], are defined on it.
-*)
-Inductive expr :=
- | Const (z : Z)
- | Plus (e1 e2 : expr)
- | Mul (e1 e2 : expr).
-
- (** Exercise 1: Arithmetics *)
- Fixpoint expr_eval (e : expr) : Z :=
- (* TODO: write the function *)
- 0.
-
- Lemma expr_eval_test: expr_eval (Plus (Const (-4)) (Const 5)) = 1%Z.
- Proof.
- (* Should be solved by: simpl. lia. *)
- Admitted.
-
- Lemma plus_eval_comm e1 e2 :
- expr_eval (Plus e1 e2) = expr_eval (Plus e2 e1).
- Proof. Admitted.
- Lemma plus_syntax_not_comm :
- Plus (Const 0) (Const 1) ≠ Plus (Const 1) (Const 0).
- Proof. Admitted.
-
- (** Exercise 2: Arithmetics Structural Semantics *)
-
- Inductive step : expr → expr → Prop :=
- | step_plus_l e1 e2 e2' :
- step e2 e2' → step (Plus e1 e2) (Plus e1 e2')
- | step_plus_r e1 e1' z2 :
- step e1 e1' → step (Plus e1 (Const z2)) (Plus e1' (Const z2))
- | step_plus z1 z2 :
- step (Plus (Const z1) (Const z2)) (Const (z1 + z2))
- | step_mul_l e1 e2 e2' :
- step e2 e2' → step (Mul e1 e2) (Mul e1 e2')
- | step_mul_r e1 e1' z2 :
- step e1 e1' → step (Mul e1 (Const z2)) (Mul e1' (Const z2))
- | step_mul z1 z2 :
- step (Mul (Const z1) (Const z2)) (Const (z1 * z2))
- .
- #[export] Hint Constructors step : core.
-
- Lemma no_step_const z e' :
- step (Const z) e' → False.
- Proof.
- Admitted.
-
- Lemma step_deterministic e e' e'' :
- step e e' → step e e'' → e' = e''.
- Proof.
- intros Hstep1 Hstep2.
- induction Hstep1 as [ ??? H IH | ??? H IH | | ??? H IH | ??? H IH | ] in e'', Hstep2 |-*.
- { inversion Hstep2; subst.
- + f_equal. by apply IH.
- + exfalso; by eapply no_step_const.
- + exfalso; by eapply no_step_const.
- }
- { inversion Hstep2; subst.
- + exfalso; by eapply no_step_const.
- + f_equal. by apply IH.
- + exfalso; by eapply no_step_const.
- }
- (* you get the idea, let's apply some automation... *)
- (* [naive_solver] is a clever automation tactic by [stdpp] that can solve many simple things. *)
- all: inversion Hstep2; subst; first [ try exfalso; by eapply no_step_const | naive_solver].
- Qed.
-
- (** Now let's define some notation to make it look nice! *)
- (* We declare a so-called notation scope, so that we can still use the nice notations for addition on natural numbers [nat] and integers [Z]. *)
- Declare Scope expr.
- Delimit Scope expr with E.
- Notation "e1 + e2" := (Plus e1%E e2%E) : expr.
- Notation "e1 * e2" := (Mul e1%E e2%E) : expr.
-
- (* We can use our nice notation to write expressions!
- (note the [%E] to tell Coq to parse this as an arithmetical expression with the
- notations we just defined).
- *)
- Check (Const 5 + Const 5)%E.
- (* The notation also still works for [Z] and [nat]: *)
- Check (5 + 5)%Z.
- Check (5 + 5).
-
- (** Exercise 3: Reflexive-transitive closure *)
- Section rtc.
- Context {X : Type}.
-
- Inductive rtc (R : X → X → Prop) : X → X → Prop :=
- | rtc_base x : rtc R x x
- | rtc_step x y z : R x y → rtc R y z → rtc R x z.
-
- Lemma rtc_reflexive R : Reflexive (rtc R).
- Proof. unfold Reflexive. Admitted.
- Lemma rtc_transitive R : Transitive (rtc R).
- Proof. unfold Transitive. Admitted.
-
- Lemma rtc_subrel (R: X → X → Prop) (x y : X): R x y → rtc R x y.
- Proof. Admitted.
-
- Section typeclass.
- (* We can use Coq's typeclass mechanism to enable the use of the [transitivity] and [reflexivity] tactics on our goals.
- Typeclasses enable easy extensions of existing mechanisms -- in this case, by telling Coq to use the knowledge about our definition of [rtc].
- *)
- (* [Transitive] is a typeclass. With [Instance] we provide an instance of it. *)
- Global Instance rtc_transitive_inst R : Transitive (rtc R).
- Proof.
- apply rtc_transitive.
- Qed.
- Global Instance rtc_reflexive_inst R : Reflexive (rtc R).
- Proof.
- apply rtc_reflexive.
- Qed.
- End typeclass.
-End rtc.
-
-(* Let's put this to the test! *)
-Goal rtc step (Const 42) (Const 42).
-Proof.
- (* this uses the [rtc_reflexive_inst] instance we registered. *)
- reflexivity.
-Qed.
-Goal rtc step (Const 42 * (Const 5 + Const 5)%E)%E (Const 420).
-Proof.
- (* this uses the [rtc_transitive_inst] instance we registered. *)
- etransitivity.
- + eapply rtc_step; eauto. reflexivity.
- + eapply rtc_step; eauto. reflexivity.
-Qed.
-
-Section stdpp.
- (* In fact, [rtc] is so common that it is already provided by the [stdpp] library! *)
- Import stdpp.relations.
- Print rtc.
-
- (* The typeclass instances are also already registered. *)
- Goal rtc step (Const 42) (Const 42).
- Proof. reflexivity. Qed.
-
-End stdpp.
-
-(* Prove the following lemmas. *)
-Lemma plus_right e1 e2 e2':
- rtc step e2 e2' → rtc step (Plus e1 e2) (Plus e1 e2').
-Proof. Admitted.
-
-Lemma plus_left e1 e1' n:
- rtc step e1 e1' → rtc step (Plus e1 (Const n)) (Plus e1' (Const n)).
-Proof. Admitted.
-
-Lemma plus_to_consts e1 e2 n m:
- rtc step e1 (Const n) → rtc step e2 (Const m) → rtc step (e1 + e2)%E (Const (n + m)%Z).
-Proof. Admitted.
-
-
-(** Exercise 4: Open arithmetical expressions *)
-
-(* Finally, we introduce variables into our arithmetic expressions.
- Variables are of Coq's [string] type.
-*)
-Inductive expr' :=
- | Var (x: string)
- | Const' (z : Z)
- | Plus' (e1 e2 : expr')
- | Mul' (e1 e2 : expr').
-
-(* We call an expression closed under the list X,
- if it only contains variables in X *)
-Fixpoint is_closed (X: list string) (e: expr') : bool :=
- match e with
- | Var x => bool_decide (x ∈ X)
- | Const' z => true
- | Plus' e1 e2 => is_closed X e1 && is_closed X e2
- | Mul' e1 e2 => is_closed X e1 && is_closed X e2
- end.
-
-Definition closed X e := is_closed X e = true.
-
-
-(* Some examples of closed terms. *)
-Lemma example_no_vars_closed:
- closed [] (Plus' (Const' 3) (Const' 5)).
-Proof.
- (* [done] is an automation tactic provided by [stdpp] to solve simple goals. *)
- unfold closed. simpl. done.
-Qed.
-
-Lemma example_some_vars_closed:
- closed ["x"; "y"] (Plus' (Var "x") (Var "y")).
-Proof.
- unfold closed. simpl. done.
-Qed.
-
-Lemma example_not_closed:
- ¬ closed ["x"] (Plus' (Var "x") (Var "y")).
-Proof.
- unfold closed. simpl. done.
-Qed.
-
-Lemma closed_mono X Y e:
- X ⊆ Y → closed X e → closed Y e.
-Proof.
- unfold closed. intros Hsub; induction e; simpl.
- - (* bool_decide is an stdpp function, which can be used to decide simple decidable propositions.
- Make a search for it to find the right lemmas to complete this subgoal. *)
- admit.
- - done.
- - (* Locate the notation for && by typing: Locate "&&". Then search for the right lemmas.*)
- admit.
- - admit.
-Admitted.
-
-(* we define a substitution operation on open expressions *)
-Fixpoint subst (e: expr') (x: string) (e': expr') : expr' :=
- match e with
- | Var y => if (bool_decide (x = y)) then e' else Var y
- | Const' z => Const' z
- | Plus' e1 e2 => Plus' (subst e1 x e') (subst e2 x e')
- | Mul' e1 e2 => Mul' (subst e1 x e') (subst e2 x e')
- end.
-
-Lemma subst_closed e e' x X:
- closed X e → ¬ (x ∈ X) → subst e x e' = e.
-Proof. Admitted.
-
-
-(* To evaluate an arithmetic expression, we define an evaluation function [expr_eval], which maps them to integers.
- Since our expressions contain variables, we pass a finite map as the argument, which is used to look up variables.
- The type of finite maps that we use is called [gmap].
-*)
-Fixpoint expr_eval' (m: gmap string Z) (e : expr') : Z :=
- match e with
- | Var x => default 0%Z (m !! x) (* this is the lookup operation on gmaps *)
- | Const' z => z
- | Plus' e1 e2 => (expr_eval' m e1) + (expr_eval' m e2)
- | Mul' e1 e2 => (expr_eval' m e1) * (expr_eval' m e2)
- end.
-
-(* Prove the following lemma which explains how substitution interacts with evaluation *)
-Lemma eval_subst_extend (m: gmap string Z) e x e':
- expr_eval' m (subst e x e') = expr_eval' (<[x := expr_eval' m e']> m) e.
-Proof. Admitted.
-
diff --git a/theories/type_systems/warmup/warmup.v b/theories/type_systems/warmup/warmup.v
new file mode 100644
index 0000000000000000000000000000000000000000..3f4f68bfae253601d5a1891a16c2045d631f0af4
--- /dev/null
+++ b/theories/type_systems/warmup/warmup.v
@@ -0,0 +1,154 @@
+(* Throughout the course, we will be using the [stdpp] library to provide
+ some useful and common features.
+ We will introduce you to its features as we need them.
+ *)
+From stdpp Require Import base tactics numbers strings.
+From stdpp Require relations.
+From semantics.lib Require Import maps.
+
+(** * Exercise sheet 0 *)
+
+(* We are using Coq's notion of integers, [Z].
+ All the standard operations, like [+] and [*], are defined on it.
+ *)
+Inductive expr :=
+ | Const (z : Z)
+ | Plus (e1 e2 : expr)
+ | Mul (e1 e2 : expr).
+
+(** Exercise 1: Arithmetics *)
+Fixpoint expr_eval (e : expr) : Z :=
+ (* TODO: write the function *)
+ 0.
+
+(** Now let's define some notation to make it look nice! *)
+(* We declare a so-called notation scope, so that we can still use the nice notations for addition on natural numbers [nat] and integers [Z]. *)
+Declare Scope expr.
+Delimit Scope expr with E.
+Notation "e1 + e2" := (Plus e1%Z e2%Z) : expr.
+Notation "e1 * e2" := (Mul e1%Z e2%Z) : expr.
+
+ (* We can use our nice notation to write expressions!
+ (note the [%E] to tell Coq to parse this as an arithmetical expression with the
+ notations we just defined).
+ *)
+ Check (Const 5 + Const 5)%E.
+ (* The notation also still works for [Z] and [nat]: *)
+ Check (5 + 5)%Z.
+ Check (5 + 5).
+
+ (* As an exercise, rephrase the following lemmas using the newly defined notation *)
+
+Lemma expr_eval_test: expr_eval (Plus (Const (-4)) (Const 5)) = 1%Z.
+Proof.
+ (* should be solved by: simpl. lia. *)
+ (* TODO: exercise *)
+Admitted.
+
+
+Lemma plus_eval_comm e1 e2 :
+ expr_eval (Plus e1 e2) = expr_eval (Plus e2 e1).
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+Lemma plus_syntax_not_comm :
+ Plus (Const 0) (Const 1) ≠ Plus (Const 1) (Const 0).
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+
+(** Exercise 2: Open arithmetical expressions *)
+
+(* Finally, we introduce variables into our arithmetic expressions.
+ Variables are of Coq's [string] type.
+ *)
+Inductive expr' :=
+ | Var (x: string)
+ | Const' (z : Z)
+ | Plus' (e1 e2 : expr')
+ | Mul' (e1 e2 : expr').
+
+(* We call an expression closed under the list X,
+ if it only contains variables in X *)
+Fixpoint is_closed (X: list string) (e: expr') : bool :=
+ match e with
+ | Var x => bool_decide (x ∈ X)
+ | Const' z => true
+ | Plus' e1 e2 => is_closed X e1 && is_closed X e2
+ | Mul' e1 e2 => is_closed X e1 && is_closed X e2
+ end.
+
+Definition closed X e := is_closed X e = true.
+
+
+(* Some examples of closed terms. *)
+Lemma example_no_vars_closed:
+ closed [] (Plus' (Const' 3) (Const' 5)).
+Proof.
+ unfold closed. simpl. done.
+Qed.
+
+
+Lemma example_some_vars_closed:
+ closed ["x"; "y"] (Plus' (Var "x") (Var "y")).
+Proof.
+ unfold closed. simpl. done.
+Qed.
+
+Lemma example_not_closed:
+ ¬ closed ["x"] (Plus' (Var "x") (Var "y")).
+Proof.
+ unfold closed. simpl. done.
+Qed.
+
+Lemma closed_mono X Y e:
+ X ⊆ Y → closed X e → closed Y e.
+Proof.
+ unfold closed. intros Hsub; induction e as [ x | z | e1 IHe1 e2 IHe2 | e1 IHe1 e2 IHe2]; simpl.
+ - (* bool_decide is an stdpp function, which can be used to decide simple decidable propositions.
+ Make a search for it to find the right lemmas to complete this subgoal. *)
+ (* Search bool_decide. *)
+ admit.
+ - done.
+ - (* Locate the notation for && by typing: Locate "&&". Then search for the right lemmas.*)
+ admit.
+ - admit.
+Admitted.
+
+(* we define a substitution operation on open expressions *)
+Fixpoint subst (e: expr') (x: string) (e': expr') : expr' :=
+ match e with
+ | Var y => if (bool_decide (x = y)) then e' else Var y
+ | Const' z => Const' z
+ | Plus' e1 e2 => Plus' (subst e1 x e') (subst e2 x e')
+ | Mul' e1 e2 => Mul' (subst e1 x e') (subst e2 x e')
+ end.
+
+Lemma subst_closed e e' x X:
+ closed X e → ¬ (x ∈ X) → subst e x e' = e.
+Proof.
+ (* TODO: exercise *)
+Admitted.
+
+
+(* To evaluate an arithmetic expression, we define an evaluation function [expr_eval], which maps them to integers.
+ Since our expressions contain variables, we pass a finite map as the argument, which is used to look up variables.
+ The type of finite maps that we use is called [gmap].
+ *)
+Fixpoint expr_eval' (m: gmap string Z) (e : expr') : Z :=
+ match e with
+ | Var x => default 0%Z (m !! x) (* this is the lookup operation on gmaps *)
+ | Const' z => z
+ | Plus' e1 e2 => (expr_eval' m e1) + (expr_eval' m e2)
+ | Mul' e1 e2 => (expr_eval' m e1) * (expr_eval' m e2)
+ end.
+
+(* Prove the following lemma which explains how substitution interacts with evaluation *)
+Lemma eval_subst_extend (m: gmap string Z) e x e':
+ expr_eval' m (subst e x e') = expr_eval' (<[x := expr_eval' m e']> m) e.
+Proof.
+ (* TODO: exercise *)
+Admitted.
+