(* proving nat and list are hSets *)

Set Universe Polymorphism.
Set Nested Proofs Allowed.

Require Import Utf8.
Require Import h4c funext.

Definition hott_2_3_10 {A B x y} :
    ∀ (f : A → B) (P : B → Type) (p : x = y) (u : P (f x)),
    transport (composite f P) p u = transport P (ap f p) u
 := λ f P p u,
    match p with
    | eq_refl _ => eq_refl (transport P (ap f (eq_refl x)) u)
    end.

(* proof nat is hset *)

Fixpoint nat_code m n : Type :=
  match (m, n) with
  | (0, 0) => True
  | (S m, 0) => False
  | (0, S n) => False
  | (S m, S n) => nat_code m n
  end.

Fixpoint nat_r n : nat_code n n :=
  match n with
  | 0 => I
  | S m => nat_r m
  end.

Definition nat_encode (m n : nat) : m = n → nat_code m n :=
  λ p, transport (nat_code m) p (nat_r m).

Definition nat_decode (m n : nat) : nat_code m n → m = n.
Proof.
revert m n.
fix IHn 1.
intros m n p.
destruct m.
 destruct n; [ reflexivity | refine (match p with end) ].

 destruct n; [ refine (match p with end) | simpl in p ].
 apply ap, IHn, p.
Defined.

Theorem nat_decode_encode {m n} : ∀ p, nat_decode m n (nat_encode m n p) = p.
Proof.
intros p.
destruct p; simpl; unfold id; simpl.
induction m; [ reflexivity | simpl ].
apply (ap (ap S)) in IHm; assumption.
Defined.

Theorem nat_encode_decode {m n} : ∀ c, nat_encode m n (nat_decode m n c) = c.
Proof.
intros c.
revert n c; induction m; intros.
 simpl in c.
 destruct n, c; reflexivity.

 simpl in c.
 destruct n; [ refine (match c with end) | simpl ].
 unfold nat_encode.
 rewrite <- (hott_2_3_10 S (nat_code (S m)) (nat_decode m n c)).
 apply IHm.
Defined.

Theorem equiv_eq_nat_code : ∀ m n, equivalence (m = n) (nat_code m n).
Proof.
intros.
exists (nat_encode m n); apply qinv_isequiv.
exists (nat_decode m n).
unfold composite, homotopy, id; simpl.
split; intros p; [ apply nat_encode_decode | apply nat_decode_encode ].
Defined.

Require Import Arith.

Definition nat_code_equiv_1_or_0 m n :
  (equivalence (nat_code m n) True) + (equivalence (nat_code m n) False).
Proof.
destruct (eq_nat_dec m n) as [H1| H1].
 left; subst m.
 exists (λ c, I); apply qinv_isequiv.
 exists (λ _, nat_r n).
 unfold composite, homotopy, id; simpl.
 split; [ intros u; destruct u; reflexivity | intros c ].
 induction n; [ destruct c; reflexivity | apply IHn ].

 right.
 exists (λ c, H1 (nat_decode m n c)); apply qinv_isequiv.
 exists (λ p : False, match p with end).
 unfold composite, homotopy, id.
 split; [ intros p; destruct p | ].
 intros c; destruct (H1 (nat_decode m n c)).
Defined.

Definition isSet_nat : isSet nat.
Proof.
intros m n p q.
pose proof equiv_eq_nat_code m n as r.
pose proof nat_code_equiv_1_or_0 m n as s.
destruct s as [s| s].
 eapply equiv_compose in s; [ | apply r ].
 destruct s as (f, ((g, Hg), (h, Hh))).
 unfold composite, homotopy, id in Hg, Hh.
 pose proof Hh p as Hp.
 pose proof Hh q as Hq.
 destruct (f p), (f q).
 subst p q; reflexivity.

 eapply equiv_compose in s; [ | apply r ].
 destruct s as (f, ((g, Hg), (h, Hh))).
 exfalso; apply f, p.
Defined.

(* proof bool is hset *)

Theorem isSet_bool : isSet bool.
Proof.
intros x y p q.
destruct x, y; try discriminate p.
 refine (match p with eq_refl _ => _ end).
 refine (match q with eq_refl _ => _ end).
 reflexivity.

 refine (match p with eq_refl _ => _ end).
 refine (match q with eq_refl _ => _ end).
 reflexivity.
Defined.

(* proof unit is hset *)

Theorem isSet_unit : isSet unit.
Proof.
intros x y p q.
destruct x, y.
refine (match p with eq_refl _ => _ end).
refine (match q with eq_refl _ => _ end).
easy.
Defined.

(* proof list is hset *)

Require Import List.
Import List.ListNotations.

Fixpoint list_code {A} (la lb : list A) : Type :=
  match (la, lb) with
  | ([], []) => True
  | (_ :: _, []) => False
  | ([], _ :: _) => False
  | (a :: la, b :: lb) => ((a = b) * list_code la lb)
  end.

Fixpoint list_r {A} (l : list A) : list_code l l :=
  match l with
  | [] => I
  | a :: l => (eq_refl, list_r l)
  end.

Definition list_encode {A} (la lb : list A) :
    la = lb → list_code la lb :=
  λ p, transport (list_code la) p (list_r la).

Definition list_decode {A} (la lb : list A) :
  list_code la lb → la = lb.
Proof.
revert la lb.
fix IHn 1.
intros la lb lc.
destruct la as [| a la]; [ now destruct lb | ].
destruct lb as [| b lb]; [ easy | ].
destruct lc as (p, lc).
destruct p.
specialize (IHn la lb lc) as H1.
now destruct H1.
Defined.

Theorem list_decode_encode {A} {la lb : list A} :
  ∀ lc, list_decode la lb (list_encode la lb lc) = lc.
Proof.
intros lc.
destruct lc; simpl; unfold id; simpl.
induction la; [ reflexivity | simpl ].
now rewrite IHla.
Defined.

Theorem list_encode_decode {A} {la lb : list A} :
  ∀ lc, list_encode la lb (list_decode la lb lc) = lc.
Proof.
intros.
revert lb lc.
induction la as [| a la]; intros. {
  destruct lb; [ now destruct lc | easy ].
}
destruct lb as [| b lb]; [ easy | ].
cbn in lc.
destruct lc as (p, lc).
destruct p.
specialize (IHla lb lc) as H1; simpl.
remember (list_decode la lb lc) as d eqn:Hd.
destruct d; cbn.
rewrite <- H1.
now unfold id.
Defined.

Theorem equiv_eq_list_code {A} : ∀ la lb : list A,
  equivalence (la = lb) (list_code la lb).
Proof.
intros.
exists (list_encode la lb); apply qinv_isequiv.
exists (list_decode la lb).
unfold composite, homotopy, id; simpl.
split; intros p; [ apply list_encode_decode | apply list_decode_encode ].
Defined.

Tactic Notation "transparent" "assert" "(" ident(H) ":" lconstr(type) ")" :=
  unshelve (refine (let H := (_ : type) in _)).

Definition list_code_equiv_1_or_0 {A}
    (eq_dec : ∀ a b : A, {a = b} + {a ≠ b}) :
  isSet A → ∀ (la lb : list A),
  equivalence (list_code la lb) True + equivalence (list_code la lb) False.
Proof.
intros HA *.
revert lb.
induction la as [| a la]; intros. {
  destruct lb as [| b lb]. {
    left; cbn.
    unfold equivalence, isequiv, homotopy, composite, id.
    exists id; unfold id.
    now split; exists id; unfold id.
  }
  right; cbn.
  unfold equivalence, isequiv, homotopy, composite, id.
  exists id; unfold id.
  now split; exists id; unfold id.
}
destruct lb as [| b lb]. {
  right; cbn.
  unfold equivalence, isequiv, homotopy, composite, id.
  exists id; unfold id.
  now split; exists id; unfold id.
}
cbn.
specialize (IHla lb) as H1.
unfold equivalence in H1 |-*.
destruct (eq_dec a b) as [p| p]. 2: {
  right.
  exists (λ X, match p (fst X) with end).
  apply qinv_isequiv.
  exists (λ H : False, match H with end).
  unfold homotopy, composite, id.
  split; [ now intros | ].
  now intros (q, Hq).
}
destruct H1 as [H1| H1].
-left.
 transparent assert (f : (a = b) * list_code la lb → True). {
   intros (q, Hq).
   apply (projT1 H1), Hq.
 }
 exists f; subst f; cbn.
 apply qinv_isequiv.
 unfold qinv.
 specialize (projT2 H1) as H2; cbn in H2.
 apply isequiv_qinv in H2; unfold qinv in H2.
 unfold homotopy, composite, id in H2.
 destruct H2 as (g & Hg1 & Hg2).
 transparent assert (g' : True → (a = b) * list_code la lb). {
   intros H.
   split; [ apply p | apply g, H ].
 }
 exists g'; subst g'.
 unfold homotopy, composite, id; cbn.
 split. {
   intros H.
   now destruct (projT1 H1 (g H)), H.
 }
 intros (i, Hi).
 move i before p.
 destruct (HA _ _ p i).
 apply f_equal, Hg2.
-right.
 transparent assert (f : (a = b) * list_code la lb → False). {
   intros (q, Hq).
   apply (projT1 H1), Hq.
 }
 exists f; subst f; cbn.
 apply qinv_isequiv.
 unfold qinv.
 specialize (projT2 H1) as H2; cbn in H2.
 apply isequiv_qinv in H2; unfold qinv in H2.
 unfold homotopy, composite, id in H2.
 destruct H2 as (g & Hg1 & Hg2).
 transparent assert (g' : False → (a = b) * list_code la lb). {
   now intros H.
 }
 exists g'; subst g'.
 unfold homotopy, composite, id; cbn.
 split; [ now intros H | ].
 intros (i, Hi).
 destruct (projT1 H1 Hi).
Defined.

Definition isSet_list {A} : (∀ a b : A, {a = b} + {a ≠ b}) →
  isSet A → isSet (list A).
Proof.
intros eq_dec HA la lb p q.
specialize (equiv_eq_list_code la lb) as r.
specialize (list_code_equiv_1_or_0 eq_dec HA la lb) as s.
destruct s as [s| s].
-eapply equiv_compose in s; [ | apply r ].
 destruct s as (f, ((g, Hg), (h, Hh))).
 unfold composite, homotopy, id in Hg, Hh.
 pose proof Hh p as Hp.
 pose proof Hh q as Hq.
 destruct (f p), (f q).
 subst p q; reflexivity.
-eapply equiv_compose in s; [ | apply r ].
 destruct s as (f, ((g, Hg), (h, Hh))).
 exfalso; apply f, p.
Defined.


Require Export P02.

(** **** Exercise: 4 stars (hoare_asgn_wrong)  *)
(** The assignment rule looks backward to almost everyone the first
    time they see it.  If it still seems backward to you, it may help
    to think a little about alternative "forward" rules.  Here is a
    seemingly natural one:
      ------------------------------ (hoare_asgn_wrong)
      {{ True }} X ::= a {{ X = a }}
    Give a counterexample showing that this rule is incorrect
    (informally). Hint: The rule universally quantifies over the
    arithmetic expression [a], and your counterexample needs to
    exhibit an [a] for which the rule doesn't work. *)

Theorem hoare_asgn_wrong:
  exists a, ~ {{ fun st => True }} X ::= a {{ fun st => st X = aeval st a}}.
Proof.
  remember (update empty_state X 1) as st.
  remember (APlus (AId X) (ANum 1)) as Xnext.
  remember (update st X (aeval st Xnext)) as st'.
  exists  Xnext.
  unfold not. intros.
  unfold hoare_triple in H.
  pose proof H st st'; clear H.
  assert (st' X = aeval st' Xnext -> False).
   rewrite Heqst'; rewrite Heqst; rewrite HeqXnext. simpl. unfold update. rewrite eq_id. intro. inversion H.
  apply H. apply H0. rewrite Heqst'. apply E_Ass. reflexivity.
  reflexivity. Qed.


(* ********************************************** *)
(* Types and Semantics for Programming Languages  *)
(* ********************************************** *)

(* Place an X in front of the appropriate statement *)
(* [ ]  I have done Problems 1 and 2 *)
(* [ ]  I have done Problems 1 and 3 *)

Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Import ListNotations.
Require Export Maps.
Require Export SfLib.

(* ********************************************** *)
(* Problem 1 *)
(* ********************************************** *)

Inductive last {X} : list X -> X -> Prop :=
  | Last_End :  forall x,
      last (x::nil) x
  | Last_Step : forall x xs y,
     last xs y ->
     last (x::xs) y.

Theorem last_app: forall (X:Type) (x:X) (xs: list X),
  last xs x -> exists xs', xs = (xs')++[x].
Proof.
  intros.
  induction xs.
  - inversion H.
  - inversion H.
    + exists []. simpl. reflexivity.
    + apply IHxs in H3. destruct H3.
      exists (a::x1). rewrite H3.
      simpl. reflexivity.
Qed.

(* ********************************************** *)
(* Problem 2 *)
(* ********************************************** *)

(* Arithmetic and boolean expressions *)

Definition state := total_map nat.

Definition ble_nat := leb.

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : id -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2  => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (aeval st a1) (aeval st a2)
  | BLe a1 a2   => ble_nat (aeval st a1) (aeval st a2)
  | BNot b1     => negb (beval st b1)
  | BAnd b1 b2  => andb (beval st b1) (beval st b2)
  end.

(* Commands *)

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).

(* Evaluation relation *)

Reserved Notation "c1 '/' st '||' st'" (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      SKIP / st || st
  | E_Ass  : forall st a1 n x,
      aeval st a1 = n ->
      (x ::= a1) / st || (t_update st x n)
  | E_Seq : forall c1 c2 st st' st'',
      c1 / st  || st' ->
      c2 / st' || st'' ->
      (c1 ;; c2) / st || st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      c1 / st || st' ->
      (IFB b THEN c1 ELSE c2 FI) / st || st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      c2 / st || st' ->
      (IFB b THEN c1 ELSE c2 FI) / st || st'
  | E_WhileEnd : forall b st c,
      beval st b = false ->
      (WHILE b DO c END) / st || st
  | E_WhileLoop : forall st st' st'' b c,
      beval st b = true ->
      c / st || st' ->
      (WHILE b DO c END) / st' || st'' ->
      (WHILE b DO c END) / st || st''

  where "c1 '/' st '||' st'" := (ceval c1 st st').

(* Assertions *)

Definition Assertion := state -> Prop.

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Notation "P ->> Q" :=
  (assert_implies P Q) (at level 80) : hoare_spec_scope.
Open Scope hoare_spec_scope.

Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P) (at level 80) : hoare_spec_scope.

(* Hoare triples *)

Definition hoare_triple
           (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
       c / st || st'  ->
       P st  ->
       Q st'.

Notation "{{ P }}  c  {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level)
  : hoare_spec_scope.

(* Assertions *)

Definition bassn b : Assertion :=
  fun st => (beval st b = true).

Lemma bexp_eval_true : forall b st,
  beval st b = true -> (bassn b) st.
Proof.
  intros b st Hbe.
  unfold bassn. assumption.  Qed.

Lemma bexp_eval_false : forall b st,
  beval st b = false -> ~ ((bassn b) st).
Proof.
  intros b st Hbe contra.
  unfold bassn in contra.
  rewrite -> contra in Hbe. inversion Hbe.  Qed.

(* Assignment *)

(*
             ------------------------------ (hoare_asgn)
             {{Q [X |-> a]}} X::=a {{Q}}
*)

Definition assn_sub X a P : Assertion :=
  fun (st : state) =>
    P (t_update st X (aeval st a)).

Notation "P [ X |-> a ]" := (assn_sub X a P) (at level 10).

Theorem hoare_asgn : forall Q X a,
  {{Q [X |-> a]}} (X ::= a) {{Q}}.
Proof.
  unfold hoare_triple.
  intros Q X a st st' HE HQ.
  inversion HE. subst.
  unfold assn_sub in HQ. assumption.  Qed.

(* Consequence *)

(*
                {{P'}} c {{Q'}}
                   P ->> P'
                   Q' ->> Q
         -----------------------------   (hoare_consequence)
                {{P}} c {{Q}}
*)

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q c Hhoare Himp.
  intros st st' Hc HP. apply (Hhoare st st').
  assumption. apply Himp. assumption. Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P Q Q' c Hhoare Himp.
  intros st st' Hc HP.
  apply Himp.
  apply (Hhoare st st').
  assumption. assumption. Qed.

Theorem hoare_consequence : forall (P P' Q Q' : Assertion) c,
  {{P'}} c {{Q'}} ->
  P ->> P' ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q Q' c Hht HPP' HQ'Q.
  apply hoare_consequence_pre with (P' := P').
  apply hoare_consequence_post with (Q' := Q').
  assumption. assumption. assumption.  Qed.

(* Skip *)

(*
             --------------------  (hoare_skip)
             {{ P }} SKIP {{ P }}
*)

Theorem hoare_skip : forall P,
     {{P}} SKIP {{P}}.
Proof.
  intros P st st' H HP. inversion H. subst.
  assumption.  Qed.

(* Sequencing *)

(*
               {{ P }} c1 {{ Q }}
               {{ Q }} c2 {{ R }}
              ---------------------  (hoare_seq)
              {{ P }} c1;;c2 {{ R }}
*)

Theorem hoare_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} ->
     {{P}} c1 {{Q}} ->
     {{P}} c1;;c2 {{R}}.
Proof.
  intros P Q R c1 c2 H1 H2 st st' H12 Pre.
  inversion H12; subst.
  apply (H1 st'0 st'); try assumption.
  apply (H2 st st'0); assumption. Qed.

(* Conditional *)

(*
              {{P /\  b}} c1 {{Q}}
              {{P /\ ~b}} c2 {{Q}}
      ------------------------------------  (hoare_if)
      {{P}} IFB b THEN c1 ELSE c2 FI {{Q}}
*)

Theorem hoare_if : forall P Q b c1 c2,
  {{fun st => P st /\ bassn b st}} c1 {{Q}} ->
  {{fun st => P st /\ ~(bassn b st)}} c2 {{Q}} ->
  {{P}} (IFB b THEN c1 ELSE c2 FI) {{Q}}.
Proof.
  intros P Q b c1 c2 HTrue HFalse st st' HE HP.
  inversion HE; subst.
  + (* "b is true" *)
    apply (HTrue st st').
      assumption.
      split. assumption.
             apply bexp_eval_true. assumption.
  + (* "b is false" *)
    apply (HFalse st st').
      assumption.
      split. assumption.
             apply bexp_eval_false. assumption. Qed.

(* While *)

(*
               {{P /\ b}} c {{P}}
        -----------------------------------  (hoare_while)
        {{P}} WHILE b DO c END {{P /\ ~b}}
    The proposition [P] is called an _invariant_ of the loop.
*)

Lemma hoare_while : forall P b c,
  {{fun st => P st /\ bassn b st}} c {{P}} ->
  {{P}} WHILE b DO c END {{fun st => P st /\ ~ (bassn b st)}}.
Proof.
  intros P b c Hhoare st st' He HP.
  (* Like we've seen before, we need to reason by induction
     on [He], because, in the "keep looping" case, its hypotheses
     talk about the whole loop instead of just [c]. *)
  remember (WHILE b DO c END) as wcom eqn:Heqwcom.
  induction He;
    try (inversion Heqwcom); subst; clear Heqwcom.
  + (* Case "E_WhileEnd" *)
    split. assumption. apply bexp_eval_false. assumption.
  + (* Case "E_WhileLoop" *)
    apply IHHe2. reflexivity.
    apply (Hhoare st st'). assumption.
      split. assumption. apply bexp_eval_true. assumption.
Qed.

(* ********************************************** *)
(* Problem 3 *)
(* ********************************************** *)

(* Types *)

Inductive ty : Type :=
  | TBool  : ty
  | TArrow : ty -> ty -> ty.

(* Terms *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm.

(* Values *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_true :
      value ttrue
  | v_false :
      value tfalse.

Hint Constructors value.

(* Substitution *)

Reserved Notation "'[' x ':=' s ']' t" (at level 20).

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar x' =>
      if beq_id x x' then s else t
  | tabs x' T t1 =>
      tabs x' T (if beq_id x x' then t1 else ([x:=s] t1))
  | tapp t1 t2 =>
      tapp ([x:=s] t1) ([x:=s] t2)
  | ttrue =>
      ttrue
  | tfalse =>
      tfalse
  | tif t1 t2 t3 =>
      tif ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  end

where "'[' x ':=' s ']' t" := (subst x s t).

(* Evaluation relation *)

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         tapp t1 t2 ==> tapp t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         tapp v1 t2 ==> tapp v1  t2'
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)

where "t1 '==>' t2" := (step t1 t2).

Hint Constructors step.

Definition relation a := a -> a -> Prop.

Inductive multi {X:Type} (R: relation X) : relation X :=
  | multi_refl : forall (x : X), multi R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi R y z ->
                    multi R x z.

Notation "t1 '==>*' t2" := (multi step t1 t2) (at level 40).

(* Contexts *)

Definition context := partial_map ty.

(* Typing relation *)

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- tvar x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      update Gamma x T11 |- t12 \in T12 ->
      Gamma |- tabs x T11 t12 \in TArrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 \in TArrow T11 T12 ->
      Gamma |- t2 \in T11 ->
      Gamma |- tapp t1 t2 \in T12
  | T_True : forall Gamma,
       Gamma |- ttrue \in TBool
  | T_False : forall Gamma,
       Gamma |- tfalse \in TBool
  | T_If : forall t1 t2 t3 T Gamma,
       Gamma |- t1 \in TBool ->
       Gamma |- t2 \in T ->
       Gamma |- t3 \in T ->
       Gamma |- tif t1 t2 t3 \in T

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

(* Canonical Forms *)

Lemma cannonical_forms_bool : forall t,
  empty |- t \in TBool ->
  value t ->
  (t = ttrue) \/ (t = tfalse).
Proof.
  intros t HT HVal.
  inversion HVal; intros; subst; try inversion HT; auto.
Qed.

Lemma cannonical_forms_fun : forall t T1 T2,
  empty |- t \in (TArrow T1 T2) ->
  value t ->
  exists x u, t = tabs x T1 u.
Proof.
  intros t T1 T2 HT HVal.
  inversion HVal; intros; subst; try inversion HT; subst; auto.
  exists x. exists t0.  auto.
Qed.

(* Progress, by induction on type derivation *)

Theorem progress : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.

Proof with eauto.
  intros t T Ht.
  remember (@empty ty) as Gamma.
  induction Ht; subst Gamma...
  + (* Case "T_Var" *)
    (* contradictory: variables cannot be typed in an
       empty context *)
    inversion H.

  + (* Case "T_App" *)
    (* [t] = [t1 t2].  Proceed by cases on whether [t1] is a
       value or steps... *)
    right. destruct IHHt1...
    - (* t1 is a value *)
      destruct IHHt2...
      * (* t2 is also a value *)
        assert (exists x0 t0, t1 = tabs x0 T11 t0).
        eapply cannonical_forms_fun; eauto.
        destruct H1 as [x0 [t0 Heq]]. subst.
        exists ([x0:=t2]t0)...

      * (* t2 steps *)
        inversion H0 as [t2' Hstp]. exists (tapp t1 t2')...

    - (* t1 steps *)
      inversion H as [t1' Hstp]. exists (tapp t1' t2)...

  + (* Case "T_If" *)
    right. destruct IHHt1...

    - (* t1 is a value *)
      destruct (cannonical_forms_bool t1); subst; eauto.

    - (* t1 also steps *)
      inversion H as [t1' Hstp]. exists (tif t1' t2 t3)...
Qed.