semantics-2023/theories/type_systems/stlc/exercises02.v

From stdpp Require Import gmap base relations tactics.
From iris Require Import prelude.
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. *)


Ltac ectx_step K :=
  eapply (Ectx_step _ _ K); subst; eauto.

Lemma contextual_step_beta x e e':
  is_val e' → contextual_step ((λ: x, e) e') (subst' x e' e).
Proof.
  intro H_val.
  ectx_step HoleCtx.
Qed.


Lemma contextual_step_app_r (e1 e2 e2': expr) :
  contextual_step e2 e2' →
  contextual_step (e1 e2) (e1 e2').
Proof.
  intro H_step.
  inversion H_step.
  induction K eqn:H_K.
  (* I am a smart foxxo >:3 *)
  all: ectx_step (AppRCtx e1 K).
Qed.

Ltac is_val_to_val v H :=
  rewrite (is_val_spec _) in H; destruct H as [v H]; apply of_to_val in H; symmetry in H.

Lemma contextual_step_app_l (e1 e1' e2: expr) :
  is_val e2 →
  contextual_step e1 e1' →
  contextual_step (e1 e2) (e1' e2).
Proof.
  intros H_val H_step.
  is_val_to_val v H_val.
  subst.

  inversion H_step.
  induction K eqn:H_K.
  all: ectx_step (AppLCtx K v).
Qed.

Lemma contextual_step_plus_red (n1 n2 n3: Z) :
  (n1 + n2)%Z = n3 →
  contextual_step (n1 + n2)%E n3.
Proof.
  intro H_plus.
  ectx_step HoleCtx.
Qed.


Lemma contextual_step_plus_r e1 e2 e2' :
  contextual_step e2 e2' →
  contextual_step (Plus e1 e2) (Plus e1 e2').
Proof.
  intro H_step.
  inversion H_step.
  ectx_step (PlusRCtx e1 K).
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.
  intro H_val.
  is_val_to_val v H_val.
  intro H_step.
  inversion H_step.
  ectx_step (PlusLCtx K v).
Qed.


(** 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.

Ltac step_ind H := induction H as [
  name e_λ e_v
  | e_fn e_fn' e_v H_val H_fn_step IH
  | e_fn e_arg e_arg' H_arg_step IH
  | n1 n2 n_sum H_plus
  | e_l e_l' e_r H_val H_l_step IH
  | e_l e_r e_r' H_r_step IH
].

Lemma step_contextual_step e1 e2: step e1 e2 → contextual_step e1 e2.
Proof.
  intro H_step.
  step_ind H_step; eauto.
Qed.


(** 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.
  intro H_cstep.
  inversion H_cstep as [K e1' e2' H_eq1 H_eq2 H_bstep]; subst.
  inversion H_bstep as [
    name body arg H_val H_eq1 H_eq2 H_eq3
    | e1 e2 n1 n2 n_sum H_n1 H_n2 H_sum H_eq1 H_eq2
  ]; subst.
  (*
    Here we do an induction on K, and we let eauto solve it for us.
    In practice, each case of the induction on K can be solved quite easily,
    as the induction hypothesis has us prove a `contextual_step`, for which we have plenty of useful lemmas.
  *)
  all: induction K; unfold fill; eauto.
Qed.



(** ** Exercise 2: Scott encodings *)
Section scott.
  (* take a look at untyped.v for usefull lemmas and definitions *)
  Import semantics.ts.stlc.untyped.

  (** Scott encoding of Booleans *)
  Definition true_scott : val := (λ: "t" "f", "t").
  Definition false_scott : val := (λ: "t" "f", "f").

  (* Lemma steps_beta e_λ e_arg *)
  Ltac rtc_single step_cons := eapply rtc_l; last reflexivity; eapply step_cons; auto.

  Lemma true_red (v1 v2 : val) :
    closed [] v1 →
    closed [] v2 →
    rtc step (true_scott v1 v2) v1.
  Proof.
    intros H_cl1 H_cl2.
    unfold true_scott.
    etransitivity.
    eapply steps_app_l; auto.
    rtc_single StepBeta.
    simpl.
    etransitivity.
    rtc_single StepBeta.
    simpl.
    rewrite subst_closed_nil; auto.
    reflexivity.
  Qed.

  Lemma steps_plus_r (e1 e2 e2': expr) :
    rtc step e2 e2' → rtc step (e1 + e2)%E (e1 + e2')%E.
  Proof.
    induction 1; subst.
    reflexivity.
    etransitivity; last exact IHrtc.
    rtc_single StepPlusR.
  Qed.

  Lemma steps_plus_l (e1 e1' e2: expr) :
    is_val e2 →
    rtc step e1 e1' →
    rtc step (e1 + e2)%E (e1' + e2)%E.
  Proof.
    induction 2; subst.
    reflexivity.
    etransitivity; last exact IHrtc.
    rtc_single StepPlusL.
  Qed.

  Lemma lam_is_val name e_body :
    is_val (Lam name e_body).
  Proof.
    unfold is_val.
    intuition.
  Qed.

  Lemma int_is_val n :
    is_val (LitInt n).
  Proof.
    unfold is_val.
    intuition.
  Qed.

  Hint Resolve lam_is_val int_is_val: core.

  (* TODO: recursively traverse the goal for subst instances? *)
  Ltac auto_subst :=
    (rewrite subst_closed_nil; last assumption) ||
    (unfold subst'; unfold subst; simpl; fold subst).

  (* This is ridiculously powerful, although it only works when you know all the terms *)
  Ltac auto_step :=
    match goal with
      | [ |- rtc step (App ?e_l ?e_v) ?e_target ] =>
        etransitivity;
        first eapply steps_app_r;
        first auto_step;
        simpl;
        etransitivity;
        first eapply steps_app_l;
        first auto;
        first auto_step;
        simpl;
        repeat auto_subst;
        rtc_single StepBeta;
        simpl;
        done
      | [ |- rtc step (of_val ?v) ?e_target ] => reflexivity
      | [ |- rtc step (Lam ?name ?body) ?e_target ] => reflexivity
      | [ |- rtc step (LitInt ?n) ?e_target ] => reflexivity
      | [ |- rtc step (Plus ?e1 ?e2) ?e_target ] =>
        etransitivity;
        first eapply steps_plus_r;
        first auto_step;
        etransitivity;
        first eapply steps_plus_l;
        first auto;
        first auto_step;
        rtc_single StepPlusRed;
        done
      | [ |- rtc step (subst ?var ?thing) ?e_target ] =>
        repeat auto_subst;
        auto_step
    end
  .

  Ltac multi_step :=
    repeat (reflexivity || (
      etransitivity;
      first auto_step;
      first repeat auto_subst
    )).

  Lemma false_red (v1 v2 : val) :
    closed [] v1 →
    closed [] v2 →
    rtc step (false_scott v1 v2) v2.
  Proof.
    intros H_cl1 H_cl2.
    auto_step.
  Qed.


  (** Scott encoding of Pairs *)
  Definition pair_scott : val := (λ: "lhs" "rhs" "f", ("f" "lhs" "rhs")).

  Definition fst_scott : val := (λ: "pair", ("pair" (λ: "lhs" "rhs", "lhs"))).
  Definition snd_scott : val := (λ: "pair", ("pair" (λ: "lhs" "rhs", "rhs"))).

  Lemma fst_red (v1 v2 : val) :
    is_closed [] v1 →
    is_closed [] v2 →
    rtc step (fst_scott (pair_scott v1 v2)) v1.
  Proof.
    intros H_cl1 H_cl2.
    multi_step.
  Qed.

  Lemma snd_red (v1 v2 : val) :
    is_closed [] v1 →
    is_closed [] v2 →
    rtc step (snd_scott (pair_scott v1 v2)) v2.
  Proof.
    intros H_cl1 H_cl2.
    multi_step.
  Qed.
End scott.

Import semantics.ts.stlc.types.

(** ** Exercise 3: type erasure *)
(** Source terms *)
Inductive src_expr :=
| ELitInt (n: Z)
(* Base lambda calculus *)
| EVar (x : string)
| ELam (x : binder) (A: type) (e : src_expr)
| EApp (e1 e2 : src_expr)
(* Base types and their operations *)
| EPlus (e1 e2 : src_expr).

(** The erasure function *)
Fixpoint erase (E: src_expr) : expr :=
  match E with
  | ELitInt n => LitInt n
  | EVar x => Var x
  | ELam x A e => Lam x (erase e)
  | EApp e1 e2 => App (erase e1) (erase e2)
  | EPlus e1 e2 => Plus (erase e1) (erase e2)
  end.

Reserved Notation "Γ '⊢S' e : A" (at level 74, e, A at next level).
Inductive src_typed : typing_context → src_expr → type → Prop :=
| src_typed_var Γ x A :
    Γ !! x = Some A →
    Γ ⊢S (EVar x) : A
| src_typed_lam Γ x E A B :
    (<[ x := A]> Γ) ⊢S E : B →
    Γ ⊢S (ELam (BNamed x) A E) : (A → B)
| src_typed_int Γ z :
    Γ ⊢S (ELitInt z) : Int
| src_typed_app Γ E1 E2 A B :
    Γ ⊢S E1 : (A → B) →
    Γ ⊢S E2 : A →
    Γ ⊢S EApp E1 E2 : B
| src_typed_add Γ E1 E2 :
    Γ ⊢S E1 : Int →
    Γ ⊢S E2 : Int →
    Γ ⊢S EPlus E1 E2 : Int
where "Γ '⊢S' E : A" := (src_typed Γ E%E A%ty) : FType_scope.
#[export] Hint Constructors src_typed : core.

Lemma type_erasure_correctness Γ E A:
  (Γ ⊢S E : A)%ty → (Γ ⊢ erase E : A)%ty.
Proof.
  intro H_styped.
  induction H_styped; unfold erase; eauto.
Qed.


(** ** Exercise 4: Unique Typing *)
Lemma src_typing_unique Γ E A B:
  (Γ ⊢S E : A)%ty → (Γ ⊢S E : B)%ty → A = B.
Proof.
  intro H_typed.
  revert B.
  induction H_typed as [
    Γ x A H_x_ty
    | Γ x e_body A1 A2 H_body_ty IH
    | Γ n
    | Γ e_fn e_arg A1 A2 H_fn_ty H_arg_ty IH
    | Γ e1 e2 H_e1_ty H_e2_ty
  ]; intro B; intro H_typed'.
  all: inversion H_typed' as [
    Γ' y B' H_y_ty
    | Γ' y e_body' B1 B2 H_body_ty'
    | Γ' n'
    | Γ' e_fn' e_arg' B1 B2 H_fn_ty' H_arg_ty'
    | Γ' e3 e4 H_e3_ty H_e4_ty
  ]; subst; try auto.
  - rewrite H_y_ty in H_x_ty; injection H_x_ty.
    intuition.
  - rewrite (IH B2); eauto.
  - remember (H_arg_ty _ H_fn_ty') as H_eq.
    injection H_eq.
    intuition.
Qed.

Lemma syn_typing_not_unique:
  ∃ (Γ: typing_context) (e: expr) (A B: type),
  (Γ ⊢ e: A)%ty ∧ (Γ ⊢ e: B)%ty ∧ A ≠ B.
Proof.
  exists ∅.
  exists (λ: "x", "x")%E.
  exists (Int → Int)%ty.
  exists ((Int → Int) → (Int → Int))%ty.
  repeat split.
  3: discriminate.
  all: apply typed_lam; eauto.
Qed.

(** ** 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
  | EVar x => Γ !! x
  | ELam (BNamed x) A E =>
    match infer_type (<[x := A]> Γ) E with
    | Some B => Some (Fun A B)
    | None => None
    end
  (* TODO: complete the definition for the remaining cases *)
  | ELitInt l => Some (Int) (* TODO *)
  | EApp E1 E2 => match infer_type Γ E1, infer_type Γ E2 with
    | Some (Fun A B), Some A' => (if type_eq A A' then Some B else None)
    | _, _ => None
    end
  | EPlus E1 E2 => match infer_type Γ E1, infer_type Γ E2 with
    | Some Int, Some Int => Some Int
    | _, _ => None
    end
  | ELam BAnon A E => None
  end.

Ltac destruct_match H H_eq :=
  repeat match goal with
  | [H: match ?matcher with _ => _ end = Some _ |- _] =>
    induction matcher eqn:H_eq; try discriminate H
  end.

(** Prove both directions of the correctness theorem. *)
Lemma infer_type_typing Γ E A:
  infer_type Γ E = Some A → (Γ ⊢S E : A)%ty.
Proof.
  revert Γ A.
  induction E; intros Γ B H_infer; inversion H_infer; subst; eauto.
  - destruct_match H0 H_x.
    destruct_match H0 H_eq.
    injection H0; intro H_eq'.
    subst.
    eapply src_typed_lam.
    exact (IHE _ _ H_eq).
  - destruct_match H0 H_E1.
    destruct_match H0 H_a.
    destruct_match H0 H_E2.
    destruct_match H0 H_eq.
    clear IHt1 IHt2.
    apply Is_true_eq_left in H_eq.
    rewrite type_eq_iff in H_eq.
    injection H0; intro H_eq'.
    subst.
    eapply src_typed_app.
    exact (IHE1 _ _ H_E1).
    exact (IHE2 _ _ H_E2).
  - destruct_match H0 H_E1.
    destruct_match H0 H_a.
    destruct_match H0 H_E2.
    rename a0 into b.
    destruct_match H0 H_b.
    injection H0; intro H_eq.
    subst.
    eapply src_typed_add.
    exact (IHE1 _ _ H_E1).
    exact (IHE2 _ _ H_E2).
Qed.


Lemma typing_infer_type Γ E A:
  (Γ ⊢S E : A)%ty → infer_type Γ E = Some A.
Proof.
  intro H_typed.
  induction H_typed; simpl; try eauto.
  - induction (infer_type (<[x := A]> Γ) E) eqn:H1; try discriminate IHH_typed.
    rewrite H1.
    injection IHH_typed; intro H_eq.
    rewrite H_eq.
    intuition.
  - induction (infer_type Γ E1) eqn:H1; try discriminate IHH_typed1.
    injection IHH_typed1; intro H_eq; subst.
    induction (infer_type Γ E2) eqn:H2; try discriminate IHH_typed2.
    injection IHH_typed2; intro H_eq; subst.
    destruct (type_eq A A) eqn:H_AA.
    + reflexivity.
    + (* idk why I struggled so much to manipulate H_AA *)
      assert (A = A) as H_AA_true by reflexivity.
      rewrite <-type_eq_iff in H_AA_true.
      apply Is_true_eq_true in H_AA_true.
      rewrite H_AA_true in H_AA.
      discriminate H_AA.
  - induction (infer_type Γ E1) eqn:H1; try discriminate IHH_typed.
    injection IHH_typed1; intro H_eq; subst.
    induction (infer_type Γ E2) eqn:H2; try discriminate IHH_typed2.
    injection IHH_typed2; intro H_eq; subst.
    + reflexivity.
    + discriminate IHH_typed1.
Qed.



(** ** Exercise 6: untypable, safe term *)

(* 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.
*)

Section give_example.
  Definition omega : expr := (λ: "x", "x" "x").
  (* This is simply binding Ω to a variable, without using it. *)
  Definition ust : expr := ((λ: "x" "y", "y") (λ: "_", omega omega) 1)%E.

  Lemma ust_safe e':
    rtc step ust e' → is_val e' ∨ reducible e'.
  Proof.

    intro H_steps.
    assert (e' = 1 ∨ e' = ((λ: "y", "y") 1)%E ∨ e' = ust).
    {
      refine (rtc_ind_r (λ (e: expr), e = 1 ∨ e = ((λ: "y", "y") 1)%E ∨ e = ust) ust _ _ _ H_steps).
      - right; right; reflexivity.
      - intros y z H_steps' H_step_yz H_y.
        destruct H_y; subst; try val_no_step.
        destruct H; subst.
        + inversion H_step_yz; subst; try val_no_step; simpl.
          left; reflexivity.
        + inversion H_step_yz; subst; try val_no_step; simpl.
          inversion H3; subst; try val_no_step; simpl.
          right; left; reflexivity.
    }
    destruct H as [ H | [ H | H ]].
    - left.
      rewrite H.
      unfold is_val; intuition.
    - right.
      exists 1.
      subst.
      apply StepBeta.
      unfold is_val; intuition.
    - right.
      exists ((λ: "y", "y") 1)%E.
      subst.
      apply StepAppL.
      unfold is_val; intuition.
      apply StepBeta.
      unfold is_val; intuition.
  Qed.

  Lemma rec_type_contra A B:
    (A → B)%ty = A -> False.
  Proof.
    revert B.
    induction A.
    - intros B H_eq.
      discriminate H_eq.
    - intros B H_eq.
      injection H_eq.
      intros H_eqb H_eqA1.
      eapply IHA1.
      exact H_eqA1.
  Qed.

  Lemma ust_no_type Γ A:
    ¬ (Γ ⊢ ust : A)%ty.
  Proof.
    intro H_typed.
    inversion H_typed; subst; rename H2 into H_typed_let_omega.
    inversion H_typed_let_omega; subst; rename H5 into H_typed_lambda_omega.
    inversion H_typed_lambda_omega; subst; rename H5 into H_typed_omega_omega.
    inversion H_typed_omega_omega; subst; rename H6 into H_typed_omega.
    inversion H_typed_omega; subst; rename H6 into H_typed_omega_inner.
    inversion H_typed_omega_inner; subst.
    rename H5 into H_typed_x.
    rename H7 into H_typed_x'.
    inversion H_typed_x; subst; clear H_typed_x; rename H1 into H_typed_x.
    inversion H_typed_x'; subst; clear H_typed_x'; rename H1 into H_typed_x'.
    rewrite lookup_insert in H_typed_x.
    rewrite lookup_insert in H_typed_x'.
    injection H_typed_x; intro H_eq1.
    injection H_typed_x'; intro H_eq2.
    rewrite H_eq1 in H_eq2.
    exact (rec_type_contra _ _ H_eq2).
  Qed.

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.
  Admitted.

End prove_non_existence. *)