|
|
From stdpp Require Import gmap base relations.
|
|
|
From iris Require Import prelude.
|
|
|
From semantics.lib Require Export debruijn.
|
|
|
From semantics.ts.systemf Require Import lang notation types bigstep tactics.
|
|
|
|
|
|
(** * Church encodings *)
|
|
|
Implicit Types
|
|
|
(Δ : nat)
|
|
|
(Γ : typing_context)
|
|
|
(v : val)
|
|
|
(α : var)
|
|
|
(e : expr)
|
|
|
(A : type).
|
|
|
|
|
|
Definition empty_type : type := ∀: #0.
|
|
|
|
|
|
(** *** Unit *)
|
|
|
Definition unit_type : type := ∀: #0 → #0.
|
|
|
Definition unit_inh : val := Λ, λ: "x", "x".
|
|
|
|
|
|
Lemma unit_wf n : type_wf n unit_type.
|
|
|
Proof. solve_typing. Qed.
|
|
|
Lemma unit_inh_typed n Γ : TY n; Γ ⊢ unit_inh : unit_type.
|
|
|
Proof. solve_typing. Qed.
|
|
|
|
|
|
(** *** Bool *)
|
|
|
Definition bool_type : type := ∀: #0 → #0 → #0.
|
|
|
Definition bool_true : val := Λ, λ: "t" "f", "t".
|
|
|
Definition bool_false : val := Λ, λ: "t" "f", "f".
|
|
|
Definition bool_if e e1 e2 : expr := (e <> (λ: <>, e1)%E (λ: <>, e2)%E) unit_inh.
|
|
|
|
|
|
Lemma bool_true_typed n Γ : TY n; Γ ⊢ bool_true : bool_type.
|
|
|
Proof. solve_typing. Qed.
|
|
|
Lemma bool_false_typed n Γ: TY n; Γ ⊢ bool_false : bool_type.
|
|
|
Proof. solve_typing. Qed.
|
|
|
|
|
|
Lemma bool_if_typed n Γ e e1 e2 A :
|
|
|
type_wf n A →
|
|
|
TY n; Γ ⊢ e1 : A →
|
|
|
TY n; Γ ⊢ e2 : A →
|
|
|
TY n; Γ ⊢ e : bool_type →
|
|
|
TY n; Γ ⊢ bool_if e e1 e2 : A.
|
|
|
Proof.
|
|
|
intros. solve_typing.
|
|
|
apply unit_wf.
|
|
|
all: solve_typing.
|
|
|
Qed.
|
|
|
|
|
|
Lemma bool_if_true_red e1 e2 v :
|
|
|
is_closed [] e1 →
|
|
|
big_step e1 v →
|
|
|
big_step (bool_if bool_true e1 e2)%E v.
|
|
|
Proof.
|
|
|
intros. bs_step_det.
|
|
|
Qed.
|
|
|
|
|
|
Lemma bool_if_false_red e1 e2 v :
|
|
|
is_closed [] e2 →
|
|
|
big_step e2 v →
|
|
|
big_step (bool_if bool_false e1 e2)%E v.
|
|
|
Proof.
|
|
|
intros. bs_step_det.
|
|
|
Qed.
|
|
|
|
|
|
(** *** Product types *)
|
|
|
(* Using De Bruijn indices, we need to be a bit careful:
|
|
|
The binder introduced by [∀:] should not be visible in [A] and [B].
|
|
|
Therefore, we need to shift [A] and [B] up by one, using the renaming substitution [ren].
|
|
|
*)
|
|
|
Definition product_type (A B : type) : type := ∀: (A.[ren (+1)] → B.[ren (+1)] → #0) → #0.
|
|
|
Definition pair_val (v1 v2 : val) : val := Λ, λ: "p", "p" v1 v2.
|
|
|
Definition pair_expr (e1 e2 : expr) : expr :=
|
|
|
let: "x2" := e2 in
|
|
|
let: "x1" := e1 in
|
|
|
Λ, λ: "p", "p" "x1" "x2".
|
|
|
Definition proj1_expr (e : expr) : expr := e <> (λ: "x" "y", "x")%E.
|
|
|
Definition proj2_expr (e : expr) : expr := e <> (λ: "x" "y", "y")%E.
|
|
|
|
|
|
Lemma proj1_red v1 v2 :
|
|
|
is_closed [] v1 →
|
|
|
is_closed [] v2 →
|
|
|
big_step (proj1_expr (pair_val v1 v2)) v1.
|
|
|
Proof.
|
|
|
intros. bs_step_det.
|
|
|
rewrite subst_is_closed_nil; last done.
|
|
|
bs_step_det.
|
|
|
Qed.
|
|
|
Lemma proj2_red v1 v2 :
|
|
|
is_closed [] v1 →
|
|
|
is_closed [] v2 →
|
|
|
big_step (proj2_expr (pair_val v1 v2)) v2.
|
|
|
Proof.
|
|
|
intros. bs_steps_det.
|
|
|
Qed.
|
|
|
|
|
|
Lemma pair_red e1 e2 v1 v2 :
|
|
|
is_closed [] v2 →
|
|
|
is_closed [] e1 →
|
|
|
big_step e1 v1 →
|
|
|
big_step e2 v2 →
|
|
|
big_step (pair_expr e1 e2) (pair_val v1 v2).
|
|
|
Proof.
|
|
|
intros. bs_steps_det.
|
|
|
Qed.
|
|
|
|
|
|
Lemma proj1_typed n Γ e A B :
|
|
|
type_wf n A →
|
|
|
type_wf n B →
|
|
|
TY n; Γ ⊢ e : product_type A B →
|
|
|
TY n; Γ ⊢ proj1_expr e : A.
|
|
|
Proof.
|
|
|
intros. solve_typing.
|
|
|
Qed.
|
|
|
|
|
|
Lemma proj2_typed n Γ e A B :
|
|
|
type_wf n A →
|
|
|
type_wf n B →
|
|
|
TY n; Γ ⊢ e : product_type A B →
|
|
|
TY n; Γ ⊢ proj2_expr e : B.
|
|
|
Proof.
|
|
|
intros. solve_typing.
|
|
|
Qed.
|
|
|
|
|
|
(** We need to assume that x2 is not bound by Γ.
|
|
|
This is a bit annoying, as it puts a restriction on the context in which this typing rule
|
|
|
can be used.
|
|
|
Alternatively, we could parameterize the encoding of [pair_expr] by a name to use,
|
|
|
so that we can always choose a name for it that does not conflict with Γ.
|
|
|
*)
|
|
|
Lemma pair_expr_typed n Γ e1 e2 A B :
|
|
|
Γ !! "x2" = None →
|
|
|
type_wf n A →
|
|
|
type_wf n B →
|
|
|
TY n; Γ ⊢ e1 : A →
|
|
|
TY n; Γ ⊢ e2 : B →
|
|
|
TY n; Γ ⊢ pair_expr e1 e2 : product_type A B.
|
|
|
Proof.
|
|
|
intros.
|
|
|
solve_typing.
|
|
|
eapply typed_weakening; [done | | lia]. apply insert_subseteq. done.
|
|
|
Qed.
|
|
|
|
|
|
|
|
|
(** *** Church numerals *)
|
|
|
Definition nat_type : type := ∀: #0 → (#0 → #0) → #0.
|
|
|
Definition zero_val : val := Λ, λ: "z" "s", "z".
|
|
|
Definition num_val (n : nat) : val := Λ, λ: "z" "s", Nat.iter n (App "s") "z".
|
|
|
Definition succ_val : val := λ: "n", Λ, λ: "z" "s", "s" ("n" <> "z" "s").
|
|
|
Definition iter_val : val := λ: "n" "z" "s", "n" <> "z" "s".
|
|
|
|
|
|
Lemma zero_typed Γ n : TY n; Γ ⊢ zero_val : nat_type.
|
|
|
Proof. solve_typing. Qed.
|
|
|
|
|
|
Lemma num_typed Γ n m : TY n; Γ ⊢ num_val m : nat_type.
|
|
|
Proof.
|
|
|
solve_typing.
|
|
|
induction m as [ | m IH]; simpl.
|
|
|
- solve_typing.
|
|
|
- solve_typing.
|
|
|
Qed.
|
|
|
|
|
|
Lemma succ_typed Γ n :
|
|
|
TY n; Γ ⊢ succ_val : (nat_type → nat_type).
|
|
|
Proof.
|
|
|
solve_typing.
|
|
|
Qed.
|
|
|
|
|
|
Lemma iter_typed n Γ C :
|
|
|
type_wf n C →
|
|
|
TY n; Γ ⊢ iter_val : (nat_type → C → (C → C) → C).
|
|
|
Proof.
|
|
|
intros. solve_typing.
|
|
|
Qed.
|