Some examples on church encodings

_CoqProject

@@ -41,6 +41,7 @@ theories/type_systems/systemf/notation.v
 theories/type_systems/systemf/types.v
 theories/type_systems/systemf/tactics.v
 theories/type_systems/systemf/bigstep.v
+theories/type_systems/systemf/church_encodings.v
 theories/type_systems/systemf/parallel_subst.v
 theories/type_systems/systemf/logrel.v
 theories/type_systems/systemf/free_theorems.v

theories/type_systems/systemf/church_encodings.v

@@ -0,0 +1,173 @@
+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.