Lecture notes 20210524 Lambda Calculus 2

Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import PL.RTClosure.
Require Import PL.Lambda.
Local Open Scope Z.
Local Open Scope string.
Import LambdaIB.

Review

Syntax of Lambda expressions: function applications and function abstractions.
Call-by-value evaluation: simplifying function part first, then simplifying argument, and applying beta-reduction in the end.

Executable Operational Semantics


Definition is_base_halting (t: tm): bool :=
  match t with
  | app (con (op_const Oplus)) (con (int_const _)) ⇒ true
  | app (con (op_const Ominus)) (con (int_const _)) ⇒ true
  | app (con (op_const Omult)) (con (int_const _)) ⇒ true
  | app (con (op_const Oeq)) (con (int_const _)) ⇒ true
  | app (con (op_const Ole)) (con (int_const _)) ⇒ true
  | app (con (op_const Oand)) (con (bool_const _)) ⇒ true
  | app (con (op_const Oifthenelse)) (con (bool_const _)) ⇒ true
  | app
      (app (con (op_const Oifthenelse)) (con (bool_const _))) _ ⇒ true
  | _ ⇒ false
  end.
Definition is_base_pending (t: tm): bool :=
  match t with
  | app (con (op_const Oplus)) (con (int_const _)) ⇒ true
  | app (con (op_const Ominus)) (con (int_const _)) ⇒ true
  | app (con (op_const Omult)) (con (int_const _)) ⇒ true
  | app (con (op_const Oeq)) (con (int_const _)) ⇒ true
  | app (con (op_const Ole)) (con (int_const _)) ⇒ true
  | app (con (op_const Oand)) (con (bool_const true)) ⇒ true
  | _ ⇒ false
  end.
Definition is_halting (t: tm): bool :=
  match t with
  | abs _ _ ⇒ true
  | con _ ⇒ true
  | _ ⇒ is_base_halting t
  end.
Definition is_pending (t: tm): bool :=
  match t with
  | abs _ _ ⇒ true
  | con _ ⇒ true
  | _ ⇒ is_base_pending t
  end.
Definition base_next_state (t: tm): option tm :=
  match t with
  | app (app Oplus (con (int_const n1))) (con (int_const n2)) ⇒
      Some (con (int_const (n1 + n2)))
  | app (app Ominus (con (int_const n1))) (con (int_const n2)) ⇒
      Some (con (int_const (n1 - n2)))
  | app (app Omult (con (int_const n1))) (con (int_const n2)) ⇒
      Some (con (int_const (n1 * n2)))
  | app (app Oeq (con (int_const n1))) (con (int_const n2)) ⇒
      if Z.eq_dec n1 n2
      then Some (con (bool_const true))
      else Some (con (bool_const false))
  | app (app Ole (con (int_const n1))) (con (int_const n2)) ⇒
      if Z_le_gt_dec n1 n2
      then Some (con (bool_const true))
      else Some (con (bool_const false))
  | app Onot (con (bool_const b)) ⇒
      Some (con (bool_const (negb b)))
  | app (app Oand (con (bool_const true))) (con (bool_const b)) ⇒
      Some (con (bool_const b))
  | app (app Oand (con (bool_const false))) _ ⇒
      Some (con (bool_const false))
  | app (app (app Oifthenelse (con (bool_const true))) t1) _ ⇒
      Some t1
  | app (app (app Oifthenelse (con (bool_const false))) _) t2 ⇒
      Some t2
  | _ ⇒ None
  end.
Definition beta_next_state (t: tm): option tm :=
  match t with
  | app (abs x t1) t2 ⇒ Some (t1 [x ⟼ t2])
  | _ ⇒ None
  end.
Definition core_next_state (t: tm): option tm :=
  match beta_next_state t, base_next_state t with
  | Some t', _ ⇒ Some t'
  | _, Some t' ⇒ Some t'
  | _, _ ⇒ None
  end.
Fixpoint next_state (t: tm): option tm :=
  match t with
  | app t1 t2 ⇒
      match next_state t1 with
      | Some t1' ⇒ Some (app t1' t2)
      | None ⇒ if is_pending t1
                then match next_state t2 with
                     | Some t2' ⇒ Some (app t1 t2')
                     | None ⇒ if is_halting t2
                               then core_next_state t
                               else None
                     end
                else base_next_state t
      end
  | _ ⇒ None
  end.
Ltac case_analysis_and_discriminiate H :=
  match type of H with
  | match ?t with _ ⇒ _ end = _ ⇒
      destruct t;
      match type of H with
      | false = true ⇒ discriminate H
      | None = Some _ ⇒ discriminate H
      | Some _ = Some _ ⇒ injection H as H
      | _ ⇒ idtac
      end
  end.
Lemma is_base_halting_sound: ∀t,
  is_base_halting t = true ->
  tm_base_halt t.
Proof.
  intros.
  unfold is_base_halting in H.
  repeat case_analysis_and_discriminiate H; constructor.
Qed.
Lemma is_base_pending_sound: ∀t,
  is_base_pending t = true ->
  tm_base_pend t.
Proof.
  intros.
  unfold is_base_pending in H.
  repeat case_analysis_and_discriminiate H; constructor.
Qed.
Lemma is_halting_sound: ∀t,
  is_halting t = true ->
  tm_halt t.
Proof.
  intros.
  unfold is_halting in H.
  repeat case_analysis_and_discriminiate H; try constructor.
  + apply is_base_halting_sound in H; auto.
  + apply is_base_halting_sound in H; auto.
Qed.
Lemma is_pending_sound: ∀t,
  is_pending t = true ->
  tm_pend t.
Proof.
  intros.
  unfold is_pending in H.
  repeat case_analysis_and_discriminiate H; try constructor.
  + apply is_base_pending_sound in H; auto.
  + apply is_base_pending_sound in H; auto.
Qed.
Lemma base_next_state_sound: ∀t t',
  base_next_state t = Some t' ->
  base_step t t'.
Proof.
  intros.
  unfold base_next_state in H.
  repeat case_analysis_and_discriminiate H; try (subst; constructor).
  + reflexivity.
  + tauto.
  + tauto.
  + tauto.
Qed.
Lemma beta_next_state_sound: ∀t1 t2 t',
  tm_halt t2 ->
  beta_next_state (app t1 t2) = Some t' ->
  step (app t1 t2) t'.
Proof.
  intros.
  unfold beta_next_state in H0.
  repeat case_analysis_and_discriminiate H0.
  subst.
  apply S_beta, H.
Qed.
Lemma core_next_state_sound: ∀t1 t2 t',
  tm_halt t2 ->
  core_next_state (app t1 t2) = Some t' ->
  step (app t1 t2) t'.
Proof.
  intros.
  unfold core_next_state in H0.
  destruct (beta_next_state (app t1 t2)) eqn:?H.
  + injection H0 as H0; subst t'.
    apply beta_next_state_sound; tauto.
  + destruct (base_next_state (app t1 t2)) eqn:?H; [| discriminate H0].
    injection H0 as H0; subst t'.
    apply base_next_state_sound in H2.
    apply S_base; tauto.
Qed.
Arguments base_next_state: simpl never.
Arguments beta_next_state: simpl never.
Arguments core_next_state: simpl never.
Lemma next_state_sound: ∀t t',
  next_state t = Some t' ->
  step t t'.
Proof.
  intros.
  revert t' H; induction t; intros; simpl in H;
    [discriminate H | | discriminate H | discriminate H].
  destruct (next_state t1) eqn:?H in H.
  {
    apply IHt1 in H0.
    injection H as H; subst t'.
    apply S_app1, H0.
  }
  destruct (is_pending t1) eqn:?H in H.
  2: {
    apply base_next_state_sound in H.
    apply S_base, H.
  }
  apply is_pending_sound in H1.
  destruct (next_state t2) eqn:?H in H.
  {
    apply IHt2 in H2.
    injection H as H; subst t'.
    apply S_app2; tauto.
  }
  destruct (is_halting t2) eqn:?H in H.
  {
    apply is_halting_sound in H3.
    apply core_next_state_sound; tauto.
  }
  {
    discriminate H.
  }
Qed.
Example DITT_result_2:
  clos_refl_trans step
    (app (app do_it_three_times square) 2)
    256.
Proof.
  etransitivity_1n.
  { apply next_state_sound. reflexivity. }
  simpl subst.
  etransitivity_1n.
  { apply next_state_sound. reflexivity. }
  simpl subst.
  etransitivity_1n.
  { apply next_state_sound. reflexivity. }
  simpl subst.
  etransitivity_1n.
  { apply next_state_sound. reflexivity. }
  simpl Z.mul.
  etransitivity_1n.
  { apply next_state_sound. reflexivity. }
  simpl subst.
  etransitivity_1n.
  { apply next_state_sound. reflexivity. }
  simpl Z.mul.
  etransitivity_1n.
  { apply next_state_sound. reflexivity. }
  simpl subst.
  etransitivity_1n.
  { apply next_state_sound. reflexivity. }
  simpl Z.mul.
  reflexivity.
Qed.
Example DITT_result_3:
  clos_refl_trans step
    (app (app do_it_three_times (app do_it_three_times add_one)) 0)
    9.
Proof.
  repeat
    (etransitivity_1n; [apply next_state_sound; reflexivity | try simpl subst]).
  reflexivity.
Qed.
Example DITT_result_4:
  clos_refl_trans step
    (app (app (app do_it_three_times do_it_three_times) add_one) 0)
    27.
Proof.
  repeat
    (etransitivity_1n; [apply next_state_sound; reflexivity | try simpl subst]).
  reflexivity.
Qed.

Typing


Inductive ty : Type :=
  | TBool : ty
  | TInt : ty
  | TArrow : ty -> ty -> ty.
Notation "T1 ~> T2" := (TArrow T1 T2) (right associativity, at level 30).
Definition context := string -> option ty.
Definition empty_context: context := fun _ ⇒ None.
Definition context_update (Gamma : context) (x : string) (T : ty) :=
  fun x' ⇒ if string_dec x x' then Some T else Gamma x'.
Notation "x '⟼' T ';' Gamma" := (context_update Gamma x T)
  (at level 100, T at next level, right associativity).
Inductive op_type: op -> ty -> Prop :=
  | OT_plus: op_type Oplus (TInt ~> TInt ~> TInt)
  | OT_minus: op_type Ominus (TInt ~> TInt ~> TInt)
  | OT_mult: op_type Omult (TInt ~> TInt ~> TInt)
  | OT_eq: op_type Oeq (TInt ~> TInt ~> TBool)
  | OT_le: op_type Ole (TInt ~> TInt ~> TBool)
  | OT_not: op_type Onot (TBool ~> TBool)
  | OT_and: op_type Oand (TBool ~> TBool ~> TBool)
  | OT_if: ∀T, op_type Oifthenelse (TBool ~> T ~> T ~> T)
.
Inductive const_type: constant -> ty -> Prop :=
  | CT_int: ∀n, const_type (int_const n) TInt
  | CT_bool: ∀b, const_type (bool_const b) TBool
  | CT_op: ∀o T, op_type o T -> const_type (op_const o) T
.
Inductive has_type: context -> tm -> ty -> Prop :=
  | T_var : ∀Gamma x T,
      Gamma x = Some T ->
      has_type Gamma (var x) T
  | T_abs : ∀Gamma x T11 T12 t12,
      has_type (x ⟼ T11 ; Gamma) t12 T12 ->
      has_type Gamma (abs x t12) (T11 ~> T12)
  | T_app : ∀T11 T12 Gamma t1 t2,
      has_type Gamma t1 (T11 ~> T12) ->
      has_type Gamma t2 T11 ->
      has_type Gamma (app t1 t2) T12
  | T_con : ∀T Gamma c,
      const_type c T ->
      has_type Gamma (con c) T
.
Notation "Gamma '|-' t '∈' T" := (has_type Gamma t T) (at level 40).

Proving Types


Example type_of_one_plus_one: empty_context |- app (app Oplus 1) 1 \in TInt.
Proof.
  eapply T_app.
  + eapply T_app.
    - apply T_con.
      apply CT_op.
      apply OT_plus.
    - constructor.
      constructor.
  + constructor.
    constructor.
Qed.
Example type_of_add_one: empty_context |- add_one \in (TInt ~> TInt).
Proof.
  unfold add_one.
  apply T_abs.
  eapply T_app.
  + eapply T_app.
    - constructor.
      constructor.
      constructor.
    - constructor.
      unfold context_update; simpl.
      reflexivity.
  + constructor.
    constructor.
Qed.
Example type_of_do_it_three_times: ∀T,
  empty_context |- do_it_three_times \in ((T ~> T) ~> (T ~> T)).
Proof.
  intros.
  unfold do_it_three_times.
  apply T_abs.
  apply T_abs.
  eapply T_app.
  {
    constructor.
    unfold context_update; simpl.
    reflexivity.
  }
  eapply T_app.
  {
    constructor.
    unfold context_update; simpl.
    reflexivity.
  }
  eapply T_app.
  {
    constructor.
    unfold context_update; simpl.
    reflexivity.
  }
  {
    constructor.
    unfold context_update; simpl.
    reflexivity.
  }
Qed.

Proving From Types In Assumptions


Example result_type_of_Oplus: ∀Gamma t1 t2 T,
  Gamma |- app (app Oplus t1) t2 \in T ->
  T = TInt.
Proof.
  intros.
  inversion H; subst.
  inversion H3; subst.
  inversion H4; subst.
  inversion H2; subst.
  inversion H1; subst.
  reflexivity.
Qed.
Ltac base_deduce_types_from_head H :=
  match type of H with
  | const_type (int_const _) _ ⇒
    inversion H
  | const_type (bool_const _) _ ⇒
    inversion H
  | const_type (op_const _) _ ⇒
    let H1 := fresh "H" in
    inversion H as [| | ? ? H1]; subst;
    base_deduce_types_from_head H1;
    clear H1
  | op_type _ _ ⇒
    inversion H; subst
  | _ ⇒ idtac
  end.
Ltac deduce_types_from_head H :=
  match type of H with
  | _ |- app _ _ \in _ ⇒
    let H1 := fresh "H" in
    let H2 := fresh "H" in
    inversion H as [| | ? ? ? ? ? H1 H2 | ]; subst;
    deduce_types_from_head H1;
    clear H1
  | _ |- con _ \in _ ⇒
    let H1 := fresh "H" in
    inversion H as [| | | ? ? ? H1 ]; subst;
    base_deduce_types_from_head H1;
    clear H1
  | _ ⇒ idtac
  end.
Example result_type_of_Oplus_again: ∀Gamma t1 t2 T,
  Gamma |- app (app Oplus t1) t2 \in T ->
  T = TInt.
Proof.
  intros.
  deduce_types_from_head H.
  reflexivity.
Qed.
Example result_type_of_Ominus_wrong: ∀Gamma t,
  Gamma |- app Ominus t \in TBool ->
  False.
Proof.
  intros.
  deduce_types_from_head H.
Qed.
(* 2021-05-17 20:13 *)