(** * Study of the class of weakly monotonic functions (Lemma 2.3) *)

Require Export Monotonic.
Set Implicit Arguments.

Section Global.

  Variable A: Type.

  Section A.

    Variables X Y: Type.
    Variable TX: reduction_t A X.
    Variable TY: reduction_t A Y.

    (** weak monotonicity entails monotonicity *)
    Lemma monotonic_wmonotonic: forall F, monotonic TX TY F -> wmonotonic TX TY F.
    Proof.
      intros F HF; split; auto.
      apply (mon_m HF).
      intros R HR; apply (mon_t HF HR); auto.
      intros R S HR HS HRS HRS'; apply (mon_a HF); auto.
      intro l; destruct l; auto.
      apply evolve_incl with R; auto.
    Qed.

    (** transitive, reflexive closure respects weak monotonicity *)
    Lemma star_wmon: wmonotonic TX TX (star (X:=X)).
    Proof.
      split.
      intros R S H x y XY; induction XY as [ x | w x y XW WY IH ]; auto; apply S_star with w; auto.
      intros R HR; unfold simulation_t, evolve_t, evolve_1.
      apply diagram_reverse; apply diagram_incl with (Weak TX (T _)) (Weak TX (T _)); auto; apply diagram_reverse.
      apply diagram_star; apply diagram_incl with R R; auto; apply weak_strong_t; exact HR.
      intros R S HR HS HRS HRS' a; unfold evolve_1.
      apply diagram_reverse; apply diagram_incl with (Weak TX (L a)) (Weak TX (L a)); auto; apply diagram_reverse.
      intros x x' y Hxx' xRy; cgen Hxx'; cgen x'; induction xRy as [ x | w x y xRw wRy IH ]; intros x' Hxx'.
      exists x'; auto.
      destruct Hxx' as [ x1 Hxx1 Hx1x' ]; destruct Hx1x' as [ x2 Hx1x2 Hx2x' ].
      destruct (weak_strong_t HR _ Hxx1 xRw) as [ w1 Hww1 x1Rw1 ].
      destruct (HRS _ _ _ _ Hx1x2 x1Rw1) as [ w2 Hw1w2 x2Rw2 ].
      destruct (weak_strong_t HS _ Hx2x' x2Rw2) as [ w' Hw2w' x'Rw' ].
      elim IH with w'.
      intros y' Hyy' w'Ry'; exists y'; auto; apply S_star with w'; auto.
      apply taus_weak with w1; auto; apply weak_taus with w2; auto.
    Qed.

    Variables F G: function X Y.
    Hypothesis HF: wmonotonic TX TY F.
    Hypothesis HG: wmonotonic TX TY G.

    (** Composition respects weak monotonicity *)
    Lemma Comp_wmon: wmonotonic TX TY (Comp G F).
    Proof.
      unfold Comp; split.
      intros R S HRS; apply (wmon_m HG); apply (wmon_m HF); exact HRS.
      intros R HR; exact (wmon_t HG (wmon_t HF HR)).
      intros R S HR HS HRS HRS'; apply (wmon_a HG).
      apply (wmon_t HF HR).
      apply (wmon_t HF HS).
      exact (wmon_a HF HR HS HRS HRS').
      apply (wmon_m HF HRS').
    Qed.

    (** Binary union respects weak monotonicity *)
    Lemma Union2_wmon: wmonotonic TX TY (Union2 F G).
    Proof.
      unfold Union2; split.
      intros R S HRS x y H; destruct H; [ left; apply (wmon_m HF HRS) | right; apply (wmon_m HG HRS) ]; auto.
      intros R HR x x' y Hxx' xRy; celim xRy; intro xRy;
	[ destruct (wmon_t HF HR _ _ _ Hxx' xRy) as [ y' ]
        | destruct (wmon_t HG HR _ _ _ Hxx' xRy) as [ y' ] ];
	exists y'; auto; [ left | right ]; auto.
      intros R S HR HS HRS HRS' a x x' y Hxx' xRy; celim xRy; intro xRy;
	[ destruct (wmon_a HF HR HS HRS HRS' _ _ _ _ Hxx' xRy) as [ y' ]
        | destruct (wmon_a HG HR HS HRS HRS' _ _ _ _ Hxx' xRy) as [ y' ] ];
	exists y'; auto; [ left | right ]; auto.
    Qed.

    Section Union.

      Variable I: Type.
      Variable H: I -> function X Y.
      Hypothesis HH: forall i, wmonotonic TX TY (H i).

      (** Union respects weak monotonicity *)
      Lemma Union_wmon: wmonotonic TX TY (Union H).
      Proof.
	unfold Union; split.
	intros R S HRS x y K; destruct K as [ i ]; exists i; apply (wmon_m (HH i) HRS); auto.
	intros R HR x x' y Hxx' xRy; destruct xRy as [ i xRy ];
	  destruct (wmon_t (HH i) HR _ _ _ Hxx' xRy) as [ y' ];
	    exists y'; auto; exists i; auto.
	intros R S HR HS HRS HRS' a x x' y Hxx' xRy; destruct xRy as [ i xRy ];
	  destruct (wmon_a (HH i) HR HS HRS HRS' _ _ _ _ Hxx' xRy) as [ y' ];
	    exists y'; auto; exists i; auto.
      Qed.

    End Union.

  End A.

  Section B.

    Variables X Y: Type.
    Variable TX: reduction_t A X.
    Variable TY: reduction_t A Y.

    Variables F G: function X Y.
    Hypothesis HF: wmonotonic TX TY F.
    Hypothesis HG: wmonotonic TX TY G.

    (** Iteration respects weak monotonicity *)
    Lemma UExp_wmon: forall n, wmonotonic TX TY (fun R => UExp F R n).
    Proof.
      intro n; induction n as [ | n IH ].
      apply (monotonic_wmonotonic (identity_mon TX TY)).
      simpl; fold (Union2 (fun R => UExp F R n) (fun R => F (UExp F R n))).
      apply Union2_wmon; auto.
      fold (Comp F (fun R => UExp F R n)).
      apply Comp_wmon; auto.
    Qed.
    Lemma UIter_wmon: wmonotonic TX TY (UIter F).
    Proof.
      unfold UIter.
      change (fun R => union (UExp F R)) with (Union (fun n => (fun R => UExp F R n))).
      apply Union_wmon; intro i; apply UExp_wmon.
    Qed.

  End B.

  Section C.

    Variables X Y: Type.
    Variable TX: reduction_t A X.
    Variable TY: reduction_t A Y.

    Variables F G: function X X.
    Hypothesis HF: wmonotonic TX TX F.
    Hypothesis HG: wmonotonic TX TX G.

    (** Chaining respects weak monotonicity *)
    Lemma Chaining_wmon: wmonotonic TX TX (Chain F G).
    Proof.
      unfold Chain; split.
      intros R S HRS x y H; destruct H as [ w H1 H2 ]; exists w;
	[ apply (wmon_m HF HRS) | apply (wmon_m HG HRS) ]; auto.
      intros R HR x x' y Hxx' xRy; destruct xRy as [ w xRw wRy ].
      destruct (wmon_t HF HR _ _ _ Hxx' xRw) as [ w' Hww' x'Rw' ].
      destruct (weak_strong_t (wmon_t HG HR) _ Hww' wRy) as [ y' Hyy' x'Ry' ].
      exists y'; auto; exists w'; auto.
      intros R S HR HS HRS HRS' a x x' y Hxx' xRy; destruct xRy as [ w xRw wRy ].
      destruct (wmon_a HF HR HS HRS HRS' _ _ _ _ Hxx' xRw) as [ w' Hww' x'Rw' ].
      destruct Hww' as [ w1 Hww1 Hw1w' ]; destruct Hw1w' as [ w2 Hw1w2 Hw2w' ].
      destruct (weak_strong_t (wmon_t HG HR) _ Hww1 wRy) as [ y1 Hyy1 w1Ry1 ].
      destruct (wmon_a HG HR HS HRS HRS' _ _ _ _ Hw1w2 w1Ry1) as [ y2 Hy1y2 w2Ry2 ].
      destruct (weak_strong_t (wmon_t HG HS) _ Hw2w' w2Ry2) as [ y' Hy2y' w'Ry' ].
      exists y'.
      apply taus_weak with y1; auto; apply weak_taus with y2; auto.
      exists w'; auto.
    Qed.

    (* on doit faire le lemme suivant directement, pour pouvoir utiliser des transitions différentes *)
    Variable L: relation Y.
    Hypothesis HL: simulation TY TY L.

    (** The following lemma is not a consequence of the previous one, for typing reasons *)
    Lemma chaing_l_wmon: wmonotonic TY TX (chaining_l L).
    Proof.
      split.
      intros R S HRS x y H; destruct H as [ w ]; exists w; auto.
      intros R HR x x' y Hxx' xRy; destruct xRy as [ w xRw wRy ].
      destruct (HL Hxx' xRw) as [ w' Hww' x'Rw' ].
      destruct (weak_strong_t HR _ Hww' wRy) as [ y' Hyy' x'Ry' ].
      exists y'; auto; exists w'; auto.
      intros R S HR HS HRS HRS' a x x' y Hxx' xRy; destruct xRy as [ w xRw wRy ].
      destruct (HL Hxx' xRw) as [ w' Hww' x'Rw' ].
      destruct Hww' as [ w1 Hww1 Hw1w' ]; destruct Hw1w' as [ w2 Hw1w2 Hw2w' ].
      destruct (weak_strong_t HR _ Hww1 wRy) as [ y1 Hyy1 w1Ry1 ].
      destruct (HRS _ _ _ _ Hw1w2 w1Ry1) as [ y2 Hy1y2 w2Ry2 ].
      destruct (weak_strong_t HS _ Hw2w' w2Ry2) as [ y' Hy2y' w'Ry' ].
      exists y'.
      apply taus_weak with y1; auto; apply weak_taus with y2; auto.
      exists w'; auto.
    Qed.

  End C.

End Global.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                             Infinite_lists.v                             *)
(****************************************************************************)

Require Export Lists_of_lists.
Require Export Dependent_lists_Compl.

Set Implicit Arguments.
Unset Strict Implicit.

Section Infinite_List.

  Variable A B : Set.

  CoInductive Stream : Set :=
      S_cons : A -> Stream -> Stream.

  Definition S_head (l : Stream) : A := match l with
                                        | S_cons a _ => a
                                        end.

  Definition S_tail (l : Stream) : Stream :=
    match l with
    | S_cons _ tl => tl
    end.

  CoInductive EqS : Stream -> Stream -> Prop :=
      eqS :
        forall l l' : Stream,
        S_head l = S_head l' -> EqS (S_tail l) (S_tail l') -> EqS l l'.

End Infinite_List.

(* Some mappings on Streams **)

CoFixpoint S_map (A B : Set) (f : A -> B) (s : Stream A) :
 Stream B := S_cons (f (S_head s)) (S_map f (S_tail s)).

CoFixpoint S_map2 (A B C : Set) (f : A -> B -> C) (l1 : Stream A)
 (l2 : Stream B) : Stream C :=
  S_cons (f (S_head l1) (S_head l2)) (S_map2 f (S_tail l1) (S_tail l2)).

CoFixpoint S_map3 (A B C D : Set) (f : A -> B -> C -> D)
 (l1 : Stream A) (l2 : Stream B) (l3 : Stream C) :
 Stream D :=
  S_cons (f (S_head l1) (S_head l2) (S_head l3))
    (S_map3 f (S_tail l1) (S_tail l2) (S_tail l3)).

CoFixpoint S_map4 (A B C D E : Set) (f : A -> B -> C -> D -> E)
 (l1 : Stream A) (l2 : Stream B) (l3 : Stream C) (l4 : Stream D) :
 Stream E :=
  S_cons (f (S_head l1) (S_head l2) (S_head l3) (S_head l4))
    (S_map4 f (S_tail l1) (S_tail l2) (S_tail l3) (S_tail l4)).

(** Infinite lists which all elements are the same **)

CoFixpoint all_same (A : Set) (v : A) : Stream A := S_cons v (all_same v).

(** A stream of 0 **)

Definition zeros : Stream nat := all_same 0.

(** A stream of false and a stream of true values **)

Definition sig_false : Stream bool := all_same false.

Definition sig_true : Stream bool := all_same true.

(** All heads of a dlist of streams **)
Definition hds (A : Set) := d_map (S_head (A:=A)).

(** All tails of a dlist of streams **)
Definition tls (A : Set) := d_map (S_tail (A:=A)).

(** All heads of a stream of dlist **)

Definition S_hds (A : Set) (n : nat) := S_map (d_Head (A:=A) (n:=n)).

(** All tails of a stream of dlist **)

Definition S_tls (A : Set) (n : nat) := S_map (d_tl (A:=A) (n:=n)).

(** Applies a function g to an infinite dlist taking all heads, **)
(** heads of tail... (g h0 h1...hn) **)

CoFixpoint MAP_g (A B : Set) (n : nat) (g : d_list A n -> B)
 (l : d_list (Stream A) n) : Stream B := S_cons (g (hds l)) (MAP_g g (tls l)).

(** Applies a function g to each element of heads, heads of tail... **)
(** ((g h0).(g h1).....(g hn)) **)

CoFixpoint MAP_map_g (A B : Set) (n m : nat) (g : d_list A n -> B)
 (l : d_list (Stream (d_list A n)) m) : Stream (d_list B m) :=
  S_cons (d_map g (hds l)) (MAP_map_g g (tls l)).

(** Transforms a dlist of streams in a stream of dlists **)

CoFixpoint dlist_to_Stream (A : Set) (n : nat) (l : d_list (Stream A) n) :
 Stream (d_list A n) := S_cons (hds l) (dlist_to_Stream (tls l)).

(** Transforms a stream of dlists in a dlist of streams **)

Fixpoint Stream_to_dlist (A : Set) (n : nat) {struct n} :
 Stream (d_list A n) -> d_list (Stream A) n :=
  match n return (Stream (d_list A n) -> d_list (Stream A) n) with
  | O => fun _ : Stream (d_list A 0) => d_nil (Stream A)
  | S p =>
      fun s : Stream (d_list A (S p)) =>
      d_cons (S_hds s) (Stream_to_dlist (S_tls s))
  end.

(** Transforms a dlist of dlists of streams in a dlist of streams of dlists **)

Definition dmap_dlist_to_Stream (A : Set) (n : nat) :=
  d_map (dlist_to_Stream (A:=A) (n:=n)).

(** Transforms a dlist of streams of dlists in a dlist of dlist of streams **)

Definition dmap_Stream_to_dlist (A : Set) (n : nat) :=
  d_map (Stream_to_dlist (A:=A) (n:=n)).

Lemma EqS_trans :
 forall (A : Set) (s1 s2 s3 : Stream A), EqS s1 s2 -> EqS s2 s3 -> EqS s1 s3.
Proof.
cofix u.
intros.
apply eqS.
transitivity (S_head s2).
case H.
intros.
assumption.
case H0.
intros.
assumption.
apply (u A (S_tail s1) (S_tail s2) (S_tail s3)).
case H.
intros.
assumption.
case H0.
intros.
assumption.
Qed.

Lemma EqS_reflex : forall (A : Set) (s : Stream A), EqS s s.
Proof.
cofix u.
intros.
apply eqS.
trivial.
apply u.
Qed.

Lemma EqS_sym : forall (A : Set) (s s' : Stream A), EqS s s' -> EqS s' s.
Proof.
cofix u.
intros.
case H.
intros.
apply eqS.
symmetry  in |- *.
assumption.
apply u.
assumption.
Qed.

Lemma S_map_id :
 forall (A : Set) (id : A -> A) (s : Stream A),
 (forall a : A, id a = a) -> EqS s (S_map id s).
Proof.
cofix S_map_id.
intros A id s H.
apply eqS; simpl in |- *; auto.
Qed.

Lemma S_map_f :
 forall (A B : Set) (f : A -> B) (s s' : Stream A),
 EqS s s' -> EqS (S_map f s) (S_map f s').
Proof.
cofix S_map_f.
intros A B f s s' H.
inversion_clear H.
apply eqS; simpl in |- *.
elim H0; auto.
auto.
Qed.

(** Definition of an equality for dlists of streams **)

Inductive eq_dlist_of_Stream (A : Set) :
forall n : nat, d_list (Stream A) n -> d_list (Stream A) n -> Prop :=
  | eq4_LSO : forall l l' : d_list (Stream A) 0, eq_dlist_of_Stream l l'
  | eq4_LS1 :
      forall (n : nat) (l l' : d_list (Stream A) (S n)),
      EqS (d_Head l) (d_Head l') ->
      eq_dlist_of_Stream (d_tl l) (d_tl l') -> eq_dlist_of_Stream l l'.

(** Tools over streams of dlists **)

(** Returns a stream containing all the ith elements **)

Definition S_Nth (A : Set) (i n : nat) (H : 0 < i)
  (H' : i <= n) := S_map (nth (A:=A) (i:=i) (n:=n) H H').

(** Returns a stream containing all the specified segments **)

Definition S_Seg (A : Set) (n m k : nat) (H : 0 < n)
  (H' : m <= k) (H'' : n <= m) :=
  S_map (seg (A:=A) (n:=n) (m:=m) (k:=k) H H' H'').

(** Returns a stream containing the dlists with the ith element removed **)

Definition S_Remove_i (A : Set) (n i : nat) (H : 0 < i)
  (H' : i <= n) := S_map (Remove_i (A:=A) (i:=i) H (n:=n) H').

(** Returns a stream containing the dlists flattened **)

Definition S_Unfold_List (A : Set) (n m : nat) :=
  S_map (Unfold_List (A:=A) (n:=n) (m:=m)).

(** Returns a stream containing the dlists structured **)

Definition S_Fold_List (A : Set) (n m : nat) :=
  S_map (Fold_List (A:=A) (n:=n) (m:=m)).

(** Returns a stream containing all the nth elements of the sublists **)

Definition S_list_of_nth (A : Set) (i n m : nat) (H : 0 < i)
  (H' : i <= n) := S_map (list_of_nth (A:=A) (i:=i) (n:=n) H H' (n0:=m)).

(** Returns a stream containing all the specified segments of the sublists **)

Definition S_list_of_seg (A : Set) (n m k p : nat)
  (H : 0 < n) (H' : m <= k) (H'' : n <= m) :=
  S_map (list_of_seg (A:=A) (n:=n) (m:=m) (k:=k) H H' H'' (n0:=p)).

(** Tools over streams of products **)

Definition fstS {A B : Set} : prod A B -> A := fst.
Definition sndS {A B : Set} : prod A B -> B := snd.

Notation S_Fst := (S_map (fstS (B:=_))) (only parsing).
Notation S_Snd := (S_map (sndS (B:=_))) (only parsing).

Definition S_Snd_of_3 (A B C : Set) (s : Stream (A * (B * C))) :=
  S_map fstS (S_map sndS s).
Definition S_Thd_of_3 (A B C : Set) (s : Stream (A * (B * C))) :=
  S_map sndS (S_map sndS s).
Definition S_Snd_of_4 (A B C D : Set) (s : Stream (A * (B * (C * D)))) :=
  S_map fstS (S_map sndS s).
Definition S_Thd_of_4 (A B C D : Set) (s : Stream (A * (B * (C * D)))) :=
  S_map fstS (S_map sndS (S_map sndS s)).
Definition S_Fth_of_4 (A B C D : Set) (s : Stream (A * (B * (C * D)))) :=
  S_map sndS (S_map sndS (S_map sndS s)).

Lemma EqS_S_Thd_of_3 :
 forall (A B C : Set) (s s' : Stream (A * (B * C))),
 EqS s s' -> EqS (S_Thd_of_3 s) (S_Thd_of_3 s').
Proof.
cofix EqS_S_Thd_of_3.
intros.
inversion_clear H.
apply eqS; simpl in |- *.
rewrite H0; auto.
unfold S_Thd_of_3 in EqS_S_Thd_of_3; auto.
Qed.

Lemma EqS_S_Snd_of_3 :
 forall (A B C : Set) (s s' : Stream (A * (B * C))),
 EqS s s' -> EqS (S_Snd_of_3 s) (S_Snd_of_3 s').
Proof.
cofix EqS_S_Snd_of_3.
intros.
inversion_clear H.
apply eqS; simpl in |- *.
rewrite H0; auto.
unfold S_Snd_of_3 in EqS_S_Snd_of_3; auto.
Qed.

CoFixpoint Compact (A B : Set) (s1 : Stream A) (s2 : Stream B) :
 Stream (A * B) :=
  S_cons (S_head s1, S_head s2) (Compact (S_tail s1) (S_tail s2)).

CoFixpoint S_Fst_pdt (A B : Set) (s : Stream (A * B)) :
 Stream A := S_cons (fst (S_head s)) (S_Fst_pdt (S_tail s)).

CoFixpoint S_Snd_pdt (A B : Set) (s : Stream (A * B)) :
 Stream B := S_cons (snd (S_head s)) (S_Snd_pdt (S_tail s)).

Definition UnCompact (A B : Set) (s : Stream (A * B)) :
  Stream A * Stream B := (S_Fst_pdt s, S_Snd_pdt s).

Definition S_Two_Fst (A B C : Set) (s : Stream (A * (B * C))) :
  Stream (A * B) := Compact (S_Fst_pdt s) (S_Fst_pdt (S_Snd_pdt s)).

Lemma EqS_Compact :
 forall (A B : Set) (s1 s1' : Stream A) (s2 s2' : Stream B),
 EqS s1 s1' -> EqS s2 s2' -> EqS (Compact s1 s2) (Compact s1' s2').
Proof.
cofix EqS_Compact.
intros A B s1 s1' s2 s2' H1 H2.
inversion_clear H1; inversion_clear H2.
apply eqS; simpl in |- *.
elim H; elim H1; auto.
apply EqS_Compact; auto.
Qed.

Lemma Fst_Compact :
 forall (A B : Set) (s1 : Stream A) (s2 : Stream B),
 EqS (S_map fstS (Compact s1 s2)) s1.
Proof.
cofix Fst_Compact.
intros A B s1 s2.
apply eqS; simpl in |- *; auto.
Qed.

Lemma Snd_Compact :
 forall (A B : Set) (s1 : Stream A) (s2 : Stream B),
 EqS (S_map sndS (Compact s1 s2)) s2.
Proof.
cofix Snd_Compact.
intros A B s1 s2.
apply eqS; simpl in |- *; auto.
Qed.

Lemma S_Snd_of_3_Compact :
 forall (A B C : Set) (s1 : Stream A) (s2 : Stream B) (s3 : Stream C),
 EqS (S_Snd_of_3 (Compact s1 (Compact s2 s3))) s2.
Proof.
cofix S_Snd_of_3_Compact.
intros A B C s1 s2 s3.
apply eqS; simpl in |- *; auto.
unfold S_Snd_of_3 in S_Snd_of_3_Compact; auto.
Qed.

Lemma S_Thd_of_3_Compact :
 forall (A B C : Set) (s1 : Stream A) (s2 : Stream B) (s3 : Stream C),
 EqS (S_Thd_of_3 (Compact s1 (Compact s2 s3))) s3.
Proof.
cofix S_Thd_of_3_Compact.
intros A B C s1 s2 s3.
apply eqS; simpl in |- *; auto.
unfold S_Thd_of_3 in S_Thd_of_3_Compact; auto.
Qed.

(** Some convenient lemmas to avoid a complete simplication (with Simpl) **)
(** during proofs **)

Lemma S_tail_S_map :
 forall (A B : Set) (f : A -> B) (s : Stream A),
 S_tail (S_map f s) = S_map f (S_tail s).
Proof.
auto.
Qed.

Lemma S_head_S_map :
 forall (A B : Set) (f : A -> B) (s : Stream A),
 S_head (S_map f s) = f (S_head s).
Proof.
auto.
Qed.

Lemma S_tail_dlist_to_Stream :
 forall (A : Set) (n : nat) (l : d_list (Stream A) n),
 S_tail (dlist_to_Stream l) = dlist_to_Stream (tls l).
Proof.
auto.
Qed.

Lemma S_tail_Compact :
 forall (A B : Set) (s1 : Stream A) (s2 : Stream B),
 S_tail (Compact s1 s2) = Compact (S_tail s1) (S_tail s2).
Proof.
auto.
Qed.

Lemma S_head_Compact :
 forall (A B : Set) (s1 : Stream A) (s2 : Stream B),
 S_head (Compact s1 s2) = (S_head s1, S_head s2).
Proof.
auto.
Qed.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Properties of logical connectives and functions                         *
**************************************************************************)

Set Implicit Arguments.
Require Extraction.
Require Import LibTactics.
Require Export LibAxioms LibEqual.
Generalizable Variables A B P.

(* ********************************************************************** *)
(** * Inhabited types *)

(* ---------------------------------------------------------------------- *)
(** ** Typeclass for describing inhabited types *)

(** The proposition [Inhab A] captures the fact that the type [A] is
    inhabited (i.e., there exists at least one value of type [A]). *)

Class Inhab (A:Type) : Prop :=
  { inhabited : (exists (x:A), True) }.

(** Extension of the definition of [=>>] *)

Ltac intro_nondeps_aux_special_intro G ::=
  match G with
  | (Inhab _) => idtac
  end.

(* ---------------------------------------------------------------------- *)
(** ** Arbitrary values for inhabited types *)

(** The value [arbitrary] can be used as a dummy value at any place
    where a value of an inhabited type is expected. *)

Definition arbitrary `{Inhab A} : A :=
  proj1_sig (@indefinite_description A _ inhabited).

Extract Constant arbitrary => "(raise Not_found)".

(* ---------------------------------------------------------------------- *)
(** ** Inhabited types *)

(** Proving a type to be inhabited *)

Lemma prove_Inhab : forall (A:Type), A -> Inhab A.
Proof using. intros A x. constructor. exists x. auto. Qed.

(** Arrows are inhabited if their codomain is inhabited. *)

Instance arrow_inhab : forall A B {I:Inhab B},
  Inhab (A -> B).
Proof using. intros. apply (prove_Inhab (fun _ => arbitrary)). Qed.

(* ********************************************************************** *)
(** * Non-constructive conditionals *)

(* ---------------------------------------------------------------------- *)
(** ** Excluded middle *)

(** Every proposition is either [True] or [False]. *)

Lemma classic : forall (P : Prop), P \/ ~ P.
Proof using.
  intros.
  set (B1 := fun b => b = true \/ P).
  set (B2 := fun b => b = false \/ P).
  asserts H1: (ex B1). exists true. left~.
  asserts H2: (ex B2). exists false. left~.
  sets i1: (indefinite_description H1).
  sets i2: (indefinite_description H2).
  destruct (proj2_sig i1) as [HA|]; [|auto].
  destruct (proj2_sig i2) as [HB|]; [|auto].
  right. intros HP. asserts EB: (B1 = B2).
    apply prop_ext_1. intros b. split; intros _; right; auto.
  subst i1 i2. destruct EB.
  rewrite (proof_irrelevance H2 H1) in HB. congruence.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Strong excluded middle *)

(** From classical logic and indefinite description, we can prove
    the strong (or informative) excluded middle, which allows Coq
    definitions to make a case analysis on the truth value of any
    proposition. *)

Lemma classicT : forall (P : Prop), {P} + {~ P}.
Proof using.
  intros. pose (select := fun (b:bool) => if b then P else ~P).
  cuts (M,HP): { b:bool | select b }.
    destruct M. left~. right~.
  apply indefinite_description.
  destruct (classic P). exists~ true. exists~ false.
Qed.

(** Simplification lemmas *)

Lemma classicT_left : forall (P : Prop) (H:P),
   classicT P = left _ H.
Proof using. intros. destruct (classicT P). fequals. false~. Qed.

Lemma classicT_right : forall (P : Prop) (H:~P),
   classicT P = right _ H.
Proof using. intros. destruct (classicT P). false~. fequals. Qed.

(* ---------------------------------------------------------------------- *)
(** ** If-then-else on propositions *)

(** The expression [If P then v1 else v2] can be used to build
    a conditional that depends on a proposition [P]. *)

Notation "'If' P 'then' v1 'else' v2" :=
  (if (classicT P) then v1 else v2)
  (at level 200, right associativity) : type_scope.

(** Lemmas to simplify If-then-else statement *)

Lemma If_l : forall (A:Type) (P:Prop) (x y : A),
  P -> (If P then x else y) = x.
Proof using. intros. case_if*. Qed.

Lemma If_r : forall (A:Type) (P:Prop) (x y : A),
  ~ P -> (If P then x else y) = y.
Proof using. intros. case_if*. Qed.

(** A lemma to prove an equality between two If-then-else *)

Lemma If_eq : forall (A : Type) (P P' : Prop) (x x' y y' : A),
  (P <-> P') -> (P -> x = x') -> (~P -> y = y') ->
  (If P then x else y) = (If P' then x' else y').
Proof using. intros. do 2 case_if; autos*. Qed.

(** A simpler version of the above lemma *)

Lemma If_eq_simple : forall (A:Type) (P P':Prop) (x x' y y' : A),
  (P <-> P') -> (x = x') -> (y = y') ->
  (If P then x else y) = (If P' then x' else y').
Proof using. intros. subst. asserts_rewrite (P = P'). apply~ prop_ext. auto. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Consequences of classical logic *)

(** Propositional completeness (degeneracy) *)

Lemma prop_degeneracy : forall (P : Prop),
   P = True \/ P = False.
Proof using.
  intros. destruct (classic P).
    left. apply* prop_ext.
    right. apply* prop_ext.
Qed.

(** Independence of general premises *)

Lemma indep_general_premises :
  forall `{Inhab A} (P : A -> Prop) (Q : Prop),
  (Q -> exists x, P x) -> (exists x, Q -> P x).
Proof using.
  introv I M. destruct (classic Q).
  destruct* (M H).
  exists arbitrary. auto_false.
Qed.

(** Small drinker's paradox *)

Lemma small_drinker_paradox : forall `{Inhab A} (P : A -> Prop),
  exists x, (exists x, P x) -> P x.
Proof using.
  intros A I P. destruct (classic (exists x, P x)).
  destruct H. exists x. auto.
  exists arbitrary. auto_false.
Qed.

(** The tactic [tautotest] helps performing case analysis on
    the propositions that are given to it as parameters. *)

Ltac tautotest_case P :=
  match type of P with
  | Prop => destruct (prop_degeneracy P)
  | bool => destruct P
  end.

Ltac tautotest_post :=
  subst; try solve [ intuition auto_false ].

Tactic Notation "tautotest" constr(P1) :=
  tautotest_case P1; tautotest_post.
Tactic Notation "tautotest" constr(P1) constr(P2) :=
  tautotest_case P1; tautotest_case P2; tautotest_post.
Tactic Notation "tautotest" constr(P1) constr(P2) constr(P3) :=
  tautotest_case P1; tautotest_case P2; tautotest_case P3; tautotest_post.

(* ********************************************************************** *)
(** * Additional logic connectives *)

(* ---------------------------------------------------------------------- *)
(** ** Definition of Xor on propositions *)

(* TODO: should be defined simply as P <> Q *)

Definition Xor (P Q : Prop) :=
  (P /\ ~ Q) \/ (~ P /\ Q).

Hint Unfold Xor.

Notation "P '\+/' Q" := (Xor P Q)
  (at level 76, right associativity) : Logic_scope.

Open Scope Logic_scope.

(* ********************************************************************** *)
(** * Properties of logical combinators *)

Section CombinatorsProp.
Implicit Types P Q : Prop.

(* TODO: simplify the proofs using tautotest or rew_classic *)

(* ---------------------------------------------------------------------- *)
(** ** Properties of true and false propositions *)

(** Recall that the lemma [prop_ext] asserts that two equivalent
    propositions are equal, i.e. [(P <-> Q) -> (P = Q)]. *)

(** Provable propositions are equal to [True], and contradictory
    propositions are equal to [False] *)

Lemma is_True : forall P, P -> P = True.
Proof using. intros. extens*. Qed.

Lemma is_False : forall P, ~ P -> P = False.
Proof using. intros. extens*. Qed.

Lemma is_True_inv : forall P, P = True -> P.
Proof using. introv H. rewrite~ H. Qed.

Lemma is_False_inv : forall P, P = False -> ~P.
Proof using. introv H. rewrite~ H. Qed.

(** True is not False *)

Lemma True_neq_False : True <> False.
Proof using. intros K. rewrite~ <- K. Qed.

(** Proving two propositions not equal *)

Lemma prop_neq_l : forall P Q,
  (P <-> ~ Q) -> P <> Q.
Proof using. intros. tautotest P Q. Qed.

Lemma prop_neq_r : forall P Q,
  (~ P <-> Q) -> P <> Q.
Proof using. intros. tautotest P Q. Qed.

Lemma prop_neq_l_inv : forall P Q,
  P <> Q -> (P <-> ~ Q).
Proof using. intros. tautotest P Q. Qed.

Lemma prop_neq_r_inv : forall P Q,
  P <> Q -> (~ P <-> Q).
Proof using. intros. tautotest P Q. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Double negation and contrapose *)

(** Double negation *)

Lemma not_not_elim : forall P,
  ~ ~ P -> P.
Proof using. intros. tautotest P. Qed.

Lemma not_not_intro : forall P,
  P -> ~ ~ P.
Proof using. auto. Qed.

(** Contrapose *)

Lemma contrapose_elim : forall P Q,
  (~ Q -> ~ P) -> (P -> Q).
Proof using. intros. tautotest P Q. Qed.

Lemma contrapose_intro : forall P Q,
  (Q -> P) -> (~ P -> ~ Q).
Proof using. intros. tautotest P Q. Qed.

(** Negation cancel *)

Lemma not_cancel : forall P Q,
  ((~P) = (~Q)) -> (P = Q).
Proof using. introv H. extens. iff; apply not_not_elim. rewrite~ <- H. rewrite~ H. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Peirce rule and similar *)

(** Peirce's result: proving a fact by assuming its negation *)

Lemma assume_not : forall P,
  (~ P -> P) -> P.
Proof using. intros. tautotest P. Qed.

(** Proving a disjunction, assuming the negation of the other branch *)

Lemma classic_left : forall P Q,
  (~ Q -> P) -> P \/ Q.
Proof using. intros. tautotest P Q. Qed.

Lemma classic_right : forall P Q,
  (~ P -> Q) -> P \/ Q.
Proof using. intros. tautotest P Q. Qed.

(** Same, but in forward style *)

Lemma case_classic_l : forall P Q,
  P \/ Q -> (P \/ (~ P /\ Q)).
Proof using. intros. tautotest P Q. Qed.

Lemma case_classic_r : forall P Q,
  P \/ Q -> (Q \/ (P /\ ~ Q)).
Proof using. intros. tautotest P Q. Qed.

End CombinatorsProp.

Hint Resolve is_True is_False True_neq_False.

(* ---------------------------------------------------------------------- *)
(** ** Properties of logical equivalence *)

Section EquivalenceProp.
Implicit Types P Q R : Prop.

(** Introduction *)

Lemma iff_intro : forall P Q : Prop,
  (P -> Q) -> (Q -> P) -> (P <-> Q).
Proof using. intros. tautotest P Q. Qed.

(** Reflexivity *)

Lemma iff_refl : forall P,
  P <-> P.
Proof using. intros. tautotest P. Qed.

(** Symmetry *)

Lemma iff_sym : forall P Q,
  (P <-> Q) -> (Q <-> P).
Proof using. intros. tautotest P Q. Qed.

(** Transitivity *)

Lemma iff_trans : forall P Q R,
  (P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof using. intros. tautotest P Q R. Qed.

(** First projection *)

Lemma iff_1 : forall P Q,
  (P <-> Q) -> P -> Q.
Proof using. intros. tautotest P Q. Qed.

(** Second projection *)

Lemma iff_2 : forall P Q,
  (P <-> Q) -> Q -> P.
Proof using. intros. tautotest P Q. Qed.

(** Contrapose of the first projection *)

Lemma iff_neg_1 : forall P Q,
  (P <-> Q) -> ~ P -> ~ Q.
Proof using. intros. tautotest P Q. Qed.

(** Contrapose of the second projection *)

Lemma iff_neg_2 : forall P Q,
  (P <-> Q) -> ~ Q -> ~ P.
Proof using. intros. tautotest P Q. Qed.

(** Negation can change side of an equivalence *)

Lemma iff_not_swap : forall P Q,
  ((~ P) <-> Q) = (P <-> (~ Q)).
Proof using. intros. extens. tautotest P Q. Qed.

(** Negation can be cancelled on both sides *)

Lemma iff_not_cancel : forall P Q,
  ((~ P) <-> (~Q)) = (P <-> Q).
Proof using. intros. extens. tautotest P Q. Qed.

End EquivalenceProp.

(* ********************************************************************** *)
(** * Simplification of logical expressions by rewriting *)

Section Simpl.
Implicit Types P Q : Prop.

(* ---------------------------------------------------------------------- *)
(** ** Simplification of equality *)

Lemma prop_eq_True : forall P, (P = True) = P.
Proof using. intros. apply* prop_ext. iff H. rewrite~ H. auto. Qed.

Lemma prop_eq_False : forall P, (P = False) = (~ P).
Proof using. intros. apply* prop_ext. iff H. rewrite~ H. auto. Qed.

Lemma prop_eq_to_iff : forall P Q, (P = Q) = (P <-> Q).
Proof using. intros. extens. iff. subst*. apply~ prop_ext. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Simplification of conjunction and disjunction *)

Lemma and_True_l : forall P, (True /\ P) = P.
Proof using. intros. apply* prop_ext. Qed.

Lemma and_True_r : forall P, (P /\ True) = P.
Proof using. intros. apply* prop_ext. Qed.

Lemma and_False_l : forall P, (False /\ P) = False.
Proof using. intros. apply* prop_ext. Qed.

Lemma and_False_r : forall P, (P /\ False) = False.
Proof using. intros. apply* prop_ext. Qed.

Lemma or_True_l : forall P, (True \/ P) = True.
Proof using. intros. apply* prop_ext. Qed.

Lemma or_True_r : forall P, (P \/ True) = True.
Proof using. intros. apply* prop_ext. Qed.

Lemma or_False_l : forall P, (False \/ P) = P.
Proof using. intros. apply* prop_ext. Qed.

Lemma or_False_r : forall P, (P \/ False) = P.
Proof using. intros. apply* prop_ext. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Distribution of negation *)

Lemma not_True : (~ True) = False.
Proof using. intros. apply* prop_ext. Qed.

Lemma not_False : (~ False) = True.
Proof using. intros. apply* prop_ext. Qed.

Lemma not_not : forall P, (~ ~ P) = P.
Proof using. intros. apply prop_ext. tautotest P. Qed.

Lemma not_and : forall P Q, (~ (P /\ Q)) = (~ P \/ ~ Q).
Proof using. intros. apply prop_ext. tautotest P Q. Qed.

Lemma not_or : forall P Q, (~ (P \/ Q)) = (~ P /\ ~ Q).
Proof using. intros. apply prop_ext. tautotest P Q. Qed.

Lemma not_impl : forall P Q, (~ (P -> Q)) = (P /\ ~ Q).
Proof using. intros. apply prop_ext. tautotest P Q. Qed.

Lemma not_or_nots : forall P Q, (~ (~ P \/ ~ Q)) = (P /\ Q).
Proof using. intros. apply prop_ext. tautotest P Q. Qed.

Lemma not_and_nots : forall P Q, (~ (~ P /\ ~ Q)) = (P \/ Q).
Proof using. intros. apply prop_ext. tautotest P Q. Qed.

End Simpl.

Section ClassicQuantifiers.
Variables (A : Type).
Implicit Types P : A -> Prop.

(** Three auxiliary facts *)

Lemma exists_from_not : forall P,
  ~ (forall x, ~ P x) -> (exists x, P x).
Proof using. intros. apply* not_not_elim. Qed.

Lemma forall_from_not : forall P,
  ~ (exists x, ~ P x) -> (forall x, P x).
Proof using. intros. apply* not_not_elim. Qed.

Lemma not_not_pred_1 : forall A (P:A->Prop),
  P = (fun x => ~ ~ (P x)).
Proof using. intros. extens. intros. rewrite* not_not. Qed.

(** Rewriting rules for quantifiers *)

Lemma not_forall : forall P,
  (~ (forall x, P x)) = (exists x, ~ P x).
Proof using.
  extens. iff.
  apply exists_from_not. rewrite~ (not_not_pred_1 P) in H.
  intros M. destruct H as [x Cx]. eauto.
Qed.

Lemma not_exists : forall P,
  (~ (exists x, P x)) = (forall x, ~ P x).
Proof using.
  intros. apply not_cancel. rewrite not_forall.
  rewrite not_not. set (P':=P) at 1. rewrite~ (not_not_pred_1 P').
Qed.

Lemma not_forall_not : forall P,
  (~ (forall x, ~ P x)) = (exists x, P x).
Proof using.
  intros. rewrite not_forall.
   set (P':=P) at 2. rewrite~ (not_not_pred_1 P').
Qed.

Lemma not_exists_not : forall P,
  (~ (exists x, ~ P x)) = (forall x, P x).
Proof using.
  intros. rewrite not_exists.
   set (P':=P) at 2. rewrite~ (not_not_pred_1 P').
Qed.

End ClassicQuantifiers.

(* ---------------------------------------------------------------------- *)
(** ** Tactic for simplifying expressions *)

(** The tactic [rew_logic] can be used to automatically
    simplify logical expressions. Syntax [rew_logic in H]
    and [rew_logic in *] are also available. *)

  (* Note: not_impl needs to have higher priority than not_forall *)
Hint Rewrite not_not not_and not_or not_impl not_True not_False
  not_forall_not not_exists_not not_forall not_exists not_impl
  prop_eq_True prop_eq_False prop_eq_to_iff
  and_True_l and_True_r and_False_l and_False_r
  or_True_l or_True_r or_False_l or_False_r not_False not_True
  : rew_logic.

Tactic Notation "rew_logic" :=
  autorewrite with rew_logic.
Tactic Notation "rew_logic" "in" hyp(H) :=
  autorewrite with rew_logic in H.
Tactic Notation "rew_logic" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_logic).
  (* autorewrite with rew_logic in *. *)

Tactic Notation "rew_logic" "~" :=
  rew_logic; auto_tilde.
Tactic Notation "rew_logic" "~" "in" hyp(H) :=
  rew_logic in H; auto_tilde.
Tactic Notation "rew_logic" "~" "in" "*" :=
  rew_logic in *; auto_tilde.

Tactic Notation "rew_logic" "*" :=
  rew_logic; auto_star.
Tactic Notation "rew_logic" "*" "in" hyp(H) :=
  rew_logic in H; auto_star.
Tactic Notation "rew_logic" "*" "in" "*" :=
  rew_logic in *; auto_star.

(** The tactic [rew_logic'] is similar except that it only
    tries to apply the most frequently useful rules, in order
    to run faster. *)

Hint Rewrite not_not not_and not_or not_True not_False : rew_logic'.

Tactic Notation "rew_logic'" :=
  autorewrite with rew_logic'.
Tactic Notation "rew_logic'" "in" hyp(H) :=
  autorewrite with rew_logic' in H.
Tactic Notation "rew_logic'" "in" "*" :=
  autorewrite with rew_logic' in *.

Tactic Notation "rew_logic'" "~" :=
  rew_logic'; auto_tilde.
Tactic Notation "rew_logic'" "~" "in" hyp(H) :=
  rew_logic' in H; auto_tilde.
Tactic Notation "rew_logic'" "~" "in" "*" :=
  rew_logic' in *; auto_tilde.

Tactic Notation "rew_logic'" "*" :=
  rew_logic'; auto_star.
Tactic Notation "rew_logic'" "*" "in" hyp(H) :=
  rew_logic' in H; auto_star.
Tactic Notation "rew_logic'" "*" "in" "*" :=
  rew_logic' in *; auto_star.

(** The tactic [tests: P] can be used to tests whether the proposition [P]
    is true or not. If [P] is an equality, it is substituted. Use the
    tactic [tests_nosubst: P] to disable the automated substitution.
    Use the tactic [tests_basic: P] to moreover disable simplification
    of logical expressions.
    To name the resulting hypotheses use [tests I: P], or [tests I1 I2: P]
    to assign different names to both sides.
    (In LibReflect, the tactic is extended so that [P] can be a boolean.) *)

Ltac tests_ssum_base E H1 H2 :=
  destruct E as [H1|H2].

Ltac tests_prop_base E H1 H2 :=
  tests_ssum_base (classicT E) H1 H2.

Ltac tests_dispatch E H1 H2 :=
  match type of E with
  | Prop => tests_prop_base E H1 H2
  | {_}+{_} => tests_ssum_base E H1 H2
  end.

Ltac tests_post H introstac :=
  tryfalse; rew_logic in H; revert H;
  introstac tt; tryfalse.

Ltac tests_post_subst H I :=
  tests_post H ltac:(fun _ => first [ intro_subst_hyp | intros I ]).

Ltac tests_post_nosubst H I :=
  tests_post H ltac:(fun _ => intros I).

Ltac tests_base E I1 I2 tests_post :=
  let H1 := fresh "TEMP" in
  let H2 := fresh "TEMP" in
  tests_dispatch E H1 H2;
    [ tests_post H1 I1
    | tests_post H2 I2 ].

Tactic Notation "tests" simple_intropattern(I1) simple_intropattern(I2) ":" constr(E) :=
  tests_base E I1 I2 ltac:(tests_post_subst).
Tactic Notation "tests" simple_intropattern(I) ":" constr(E) :=
  tests I I: E.
Tactic Notation "tests" ":" constr(E) :=
  let I := fresh "C" in tests I: E.
Tactic Notation "tests" "~" ":" constr(E) :=
  tests: E; auto_tilde.
Tactic Notation "tests" "*" ":" constr(E) :=
  tests: E; auto_star.

Tactic Notation "tests_nosubst" simple_intropattern(I1) simple_intropattern(I2) ":" constr(E) :=
  tests_base E I1 I2 ltac:(tests_post_nosubst).
Tactic Notation "tests_nosubst" simple_intropattern(I) ":" constr(E) :=
  tests_nosubst I I: E.
Tactic Notation "tests_nosubst" ":" constr(E) :=
  let I := fresh "C" in tests I: E.
Tactic Notation "tests_nosubst" "~" ":" constr(E) :=
  tests: E; auto_tilde.
Tactic Notation "tests_nosubst" "*" ":" constr(E) :=
  tests: E; auto_star.

Tactic Notation "tests_basic" simple_intropattern(I1) simple_intropattern(I2) ":" constr(E) :=
  tests_dispatch E I1 I2.
Tactic Notation "tests_basic" simple_intropattern(I1) ":" constr(E) :=
  tests_basic I1 I1: E.
Tactic Notation "tests_basic" ":" constr(E) :=
  let C := fresh "C" in tests_basic C: E.

(* ---------------------------------------------------------------------- *)
(** ** Tactic [absurds] *)

(** [absurds as H], or simply [absurd] adds the negation of the goal
    as hypothesis. *)

Ltac absurds_post H :=
  rew_logic in H.

Ltac absurds_core H :=
  let N := fresh "TEMP" in apply not_not_elim;
  intros N; absurds_post N; generalize N; intros H.

Tactic Notation "absurds" "as" simple_intropattern(H) :=
  absurds_core H.
Tactic Notation "absurds" :=
  let H := fresh "H" in absurds as H.

(** [absurds_nosimpl as H], or simply [absurd_nosimpl] is like
    [absurd] but does not perform any simplification of the negation. *)

Ltac absurds_nosimpl_core H :=
  apply not_not_elim; intros H.

Tactic Notation "absurds_nosimpl" "as" simple_intropattern(H) :=
  absurds_nosimpl_core H.
Tactic Notation "absurds_nosimpl" :=
  let H := fresh "H" in absurds_nosimpl as H.

(* ********************************************************************** *)
(** * Predicate combinators, comparison and compatibility *)

(* ---------------------------------------------------------------------- *)
(** ** Definition of predicate combinators *)

Definition pred_true {A : Type} :=
  fun _:A => True.

Definition pred_false {A : Type} :=
  fun _:A => False.

Definition pred_not (A : Type) (P : A -> Prop) :=
  fun x => ~ (P x).

Definition pred_and (A : Type) (P Q : A -> Prop) :=
  fun x => P x /\ Q x.

Definition pred_or (A : Type) (P Q : A -> Prop) :=
  fun x => P x \/ Q x.

Definition pred_impl (A : Type) (P Q : A -> Prop) :=
  fun x => P x -> Q x.

Hint Unfold pred_true pred_false.

(* ---------------------------------------------------------------------- *)
(** ** Properties of combinators *)

(* Todo: reformulate using [pred_all] and [pred_and] *)

Lemma pred_conj_forall_distrib : forall A (P Q: A->Prop),
  ((forall x, P x) /\ (forall x, Q x)) = (forall x, P x /\ Q x).
Proof using. intros. apply prop_ext. iff H. autos*. split; intros x; apply* (H x). Qed.

(* ---------------------------------------------------------------------- *)
(** ** Order on predicates *)

Definition pred_le (A : Type) (P Q : A -> Prop) :=
  forall x, P x -> Q x.

(* TODO: can it be reformulated using [refl] and still serve as hint? *)
Lemma pred_le_refl : forall A (P : A -> Prop),
  pred_le P P.
Proof using. unfolds~ pred_le. Qed.

(* TODO: reformulate the two lemmas using [trans] *)
Lemma pred_le_trans : forall A (Q P R : A -> Prop),
  pred_le P Q -> pred_le Q R -> pred_le P R.
Proof using. unfolds~ pred_le. Qed.

Lemma pred_le_antisym : forall A (P Q : A -> Prop), (* antisym (@pred_le A). *)
  pred_le P Q -> pred_le Q P -> P = Q.
Proof using. intros_all. applys* prop_ext_1. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Compatibility of a predicate with an equivalence relation *)

(** A predicate is compatible with an equivalence relation [E]
    iff it is either true or false on each equivalence class. *)

Definition pred_compatible A (E:A->A->Prop) (Q:A->Prop) :=
  forall x y, Q x -> E y x -> Q y.

(* ********************************************************************** *)
(** * Existentials *)

(* ---------------------------------------------------------------------- *)
(** ** A shorthand for [ex_intro] with more implicit arguments *)

Definition ex_intro' A (x:A) (P:A->Prop) (H:P x) :=
  @ex_intro A P x H.

Arguments ex_intro' [A] _ {P H}.

(* ---------------------------------------------------------------------- *)
(** * Properties of unique existentials *)

(** Alternative definition of uniqueness (copied from LibPrelude) *)
(* TODO: add comments *)

Definition unique_st (A : Type) (P : A -> Prop) (x : A) :=
  P x /\ forall y, P y -> y = x.

Hint Unfold unique_st.

Definition ex_unique (A : Type) (P : A -> Prop) :=
  ex (unique_st P).

Notation "'exists' ! x , P" := (ex_unique (fun x => P))
  (at level 200, x ident, right associativity,
    format "'[' 'exists' !  '/  ' x ,  '/  ' P ']'") : type_scope.
Notation "'exists' ! x : A , P" :=
  (ex_unique (fun x:A => P))
  (at level 200, x ident, right associativity,
    format "'[' 'exists' !  '/  ' x  :  A ,  '/  ' P ']'") : type_scope.

Definition at_most_one (A : Type) (P : A -> Prop) :=
  forall x y, P x -> P y -> x = y.

Section UniqueProp.
Variables (A : Type) (P : A -> Prop).

Lemma ex_unique_to_ex : ex_unique P -> ex P.
Proof using. introv [x [H U]]. eauto. Qed.

Lemma ex_unique_to_at_most_one :
  ex_unique P -> at_most_one P.
Proof using.
  introv [a [H U]] Px Py. apply (eq_trans a).
  auto. rewrite~ <- (U y).
Qed.

Lemma ex_unique_from_ex_at_most_one :
  ex P -> at_most_one P -> ex_unique P.
Proof using. introv [x Px] H. exists x. split~. Qed.

End UniqueProp.

Definition at_most_one_upto (A : Type) (E : A -> A -> Prop) (P : A -> Prop) :=
  forall x y, P x -> P y -> E x y.

(* ********************************************************************** *)
(** * Conjunctions *)

(* ---------------------------------------------------------------------- *)
(** ** Changing the order of branches *)

Lemma conj_swap: forall (P Q: Prop), P -> Q -> Q /\ P.
Proof using. autos*. Qed.

Lemma conj_dup_r : forall P Q : Prop,
  Q -> (Q -> P) -> P /\ Q.
Proof using. autos*. Qed.

Lemma conj_dup_l : forall P Q : Prop,
  P -> (P -> Q) -> P /\ Q.
Proof using. autos*. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Parallel strengthening of a conjunction *)

Lemma conj_strengthen_2 : forall (Q1 Q2 P1 P2 : Prop),
  (Q1 -> P1) -> (Q2 -> P2) ->
  (Q1 /\ Q2) -> (P1 /\ P2).
Proof using. autos*. Qed.

Lemma conj_strengthen_3 : forall (Q1 Q2 Q3 P1 P2 P3 : Prop),
  (Q1 -> P1) -> (Q2 -> P2) -> (Q3 -> P3) ->
  (Q1 /\ Q2 /\ Q3) -> (P1 /\ P2 /\ P3).
Proof using. autos*. Qed.

Lemma conj_strengthen_4 : forall (Q1 Q2 Q3 Q4 P1 P2 P3 P4 : Prop),
  (Q1 -> P1) -> (Q2 -> P2) -> (Q3 -> P3) -> (Q4 -> P4) ->
  (Q1 /\ Q2 /\ Q3 /\ Q4) -> (P1 /\ P2 /\ P3 /\ P4).
Proof using. autos*. Qed.

Lemma conj_strengthen_5 : forall (Q1 Q2 Q3 Q4 Q5 P1 P2 P3 P4 P5 : Prop),
  (Q1 -> P1) -> (Q2 -> P2) -> (Q3 -> P3) -> (Q4 -> P4) -> (Q5 -> P5) ->
  (Q1 /\ Q2 /\ Q3 /\ Q4 /\ Q5) -> (P1 /\ P2 /\ P3 /\ P4 /\ P5).
Proof using. autos*. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Projections of lemmas concluding on a conjunction *)

Section ProjLemma.
Variables (A1 : Type).
Variables (A2 : forall (x1 : A1), Type).
Variables (A3 : forall (x1 : A1) (x2 : A2 x1), Type).
Variables (A4 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2), Type).
Variables (A5 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3), Type).
Variables (A6 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4), Type).
Variables (A7 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4) (x6 : A6 x5), Type).
Variables (A8 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4) (x6 : A6 x5) (x7 : A7 x6), Type).
Variables (A9 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4) (x6 : A6 x5) (x7 : A7 x6) (x8 : A8 x7), Type).
Variables (A10 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4) (x6 : A6 x5) (x7 : A7 x6) (x8 : A8 x7) (x9 : A9 x8), Type).
Variables (A11 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4) (x6 : A6 x5) (x7 : A7 x6) (x8 : A8 x7) (x9 : A9 x8) (x10 : A10 x9), Type).

Lemma proj_lemma_1 : forall (P Q : forall (x1:A1), Prop),
  (forall x1, P x1 /\ Q x1) ->
  (forall x1, P x1) /\
  (forall x1, Q x1).
Proof using. introv H. split; intros; forwards*: H. Qed.

Lemma proj_lemma_2 : forall (P Q : forall (x1:A1) (x2:A2 x1), Prop),
  (forall x1 x2, P x1 x2 /\ Q x1 x2) ->
  (forall x1 x2, P x1 x2) /\
  (forall x1 x2, Q x1 x2).
Proof using. introv H. split; intros; forwards*: H. Qed.

Lemma proj_lemma_3 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2), Prop),
  (forall x1 x2 x3, P x1 x2 x3 /\ Q x1 x2 x3) ->
  (forall x1 x2 x3, P x1 x2 x3) /\
  (forall x1 x2 x3, Q x1 x2 x3).
Proof using. introv H. split; intros; forwards*: H. Qed.

Lemma proj_lemma_4 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3), Prop),
  (forall x1 x2 x3 x4, P x1 x2 x3 x4 /\ Q x1 x2 x3 x4) ->
  (forall x1 x2 x3 x4, P x1 x2 x3 x4) /\
  (forall x1 x2 x3 x4, Q x1 x2 x3 x4).
Proof using. introv H. split; intros; forwards*: H. Qed.

Lemma proj_lemma_5 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4), Prop),
  (forall x1 x2 x3 x4 x5, P x1 x2 x3 x4 x5 /\ Q x1 x2 x3 x4 x5) ->
  (forall x1 x2 x3 x4 x5, P x1 x2 x3 x4 x5) /\
  (forall x1 x2 x3 x4 x5, Q x1 x2 x3 x4 x5).
Proof using. introv H. split; intros; forwards*: H. Qed.

Lemma proj_lemma_6 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4) (x6:A6 x5), Prop),
  (forall x1 x2 x3 x4 x5 x6, P x1 x2 x3 x4 x5 x6 /\ Q x1 x2 x3 x4 x5 x6) ->
  (forall x1 x2 x3 x4 x5 x6, P x1 x2 x3 x4 x5 x6) /\
  (forall x1 x2 x3 x4 x5 x6, Q x1 x2 x3 x4 x5 x6).
Proof using. introv H. split; intros; forwards*: H. Qed.

(* Commented out for efficiency of compilation

Lemma proj_lemma_7 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4) (x6:A6 x5) (x7:A7 x6), Prop),
  (forall x1 x2 x3 x4 x5 x6 x7, P x1 x2 x3 x4 x5 x6 x7 /\ Q x1 x2 x3 x4 x5 x6 x7) ->
  (forall x1 x2 x3 x4 x5 x6 x7, P x1 x2 x3 x4 x5 x6 x7) /\
  (forall x1 x2 x3 x4 x5 x6 x7, Q x1 x2 x3 x4 x5 x6 x7).
Proof using. introv H. split; intros; forwards*: H. Qed.

Lemma proj_lemma_8 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4) (x6:A6 x5) (x7:A7 x6) (x8:A8 x7), Prop),
  (forall x1 x2 x3 x4 x5 x6 x7 x8, P x1 x2 x3 x4 x5 x6 x7 x8 /\ Q x1 x2 x3 x4 x5 x6 x7 x8) ->
  (forall x1 x2 x3 x4 x5 x6 x7 x8, P x1 x2 x3 x4 x5 x6 x7 x8) /\
  (forall x1 x2 x3 x4 x5 x6 x7 x8, Q x1 x2 x3 x4 x5 x6 x7 x8).
Proof using. introv H. split; intros; forwards*: H. Qed.

Lemma proj_lemma_9 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4) (x6:A6 x5) (x7:A7 x6) (x8:A8 x7) (x9:A9 x8), Prop),
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9, P x1 x2 x3 x4 x5 x6 x7 x8 x9 /\ Q x1 x2 x3 x4 x5 x6 x7 x8 x9) ->
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9, P x1 x2 x3 x4 x5 x6 x7 x8 x9) /\
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9, Q x1 x2 x3 x4 x5 x6 x7 x8 x9).
Proof using. introv H. split; intros; forwards*: H. Qed.

Lemma proj_lemma_10 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4) (x6:A6 x5) (x7:A7 x6) (x8:A8 x7) (x9:A9 x8) (x10:A10 x9), Prop),
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10, P x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 /\ Q x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) ->
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10, P x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) /\
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10, Q x1 x2 x3 x4 x5 x6 x7 x8 x9 x10).
Proof using. introv H. split; intros; forwards*: H. Qed.

Lemma proj_lemma_11 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4) (x6:A6 x5) (x7:A7 x6) (x8:A8 x7) (x9:A9 x8) (x10:A10 x9) (x11:A11 x10), Prop),
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11, P x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 /\ Q x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) ->
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11, P x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) /\
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11, Q x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11).
Proof using. introv H. split; intros; forwards*: H. Qed.

*)

End ProjLemma.

Arguments proj_lemma_1 [A1 P Q].
Arguments proj_lemma_2 [A1 A2 P Q].
Arguments proj_lemma_3 [A1 A2 A3 P Q].
Arguments proj_lemma_4 [A1 A2 A3 A4 P Q].
Arguments proj_lemma_5 [A1 A2 A3 A4 A5 P Q].
Arguments proj_lemma_6 [A1 A2 A3 A4 A5 A6 P Q].
(* Commented out for efficiency of compilation
Arguments proj_lemma_7 [A1 A2 A3 A4 A5 A6 A7 P Q].
Arguments proj_lemma_8 [A1 A2 A3 A4 A5 A6 A7 A8 P Q].
Arguments proj_lemma_9 [A1 A2 A3 A4 A5 A6 A7 A8 A9 P Q].
Arguments proj_lemma_10 [A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 P Q].
Arguments proj_lemma_11 [A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 P Q].
*)


(** * StlcProp: Properties of STLC *)

Require Import SfLib.
Require Import Maps.
Require Import Types.
Require Import Stlc.
Require Import Smallstep.

Module STLCProp.
Import STLC.

(** In this chapter, we develop the fundamental theory of the Simply
    Typed Lambda Calculus -- in particular, the type safety
    theorem. *)

(* ###################################################################### *)
(** * Canonical Forms *)

Lemma canonical_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 canonical_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 x0. exists t0.  auto.
Qed.

(* ###################################################################### *)
(** * Progress *)

(** As before, the _progress_ theorem tells us that closed, well-typed
    terms are not stuck: either a well-typed term is a value, or it
    can take an evaluation step.  The proof is a relatively
    straightforward extension of the progress proof we saw in the
    [Types] chapter. *)

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

(** _Proof_: by induction on the derivation of [|- t \in T].

    - The last rule of the derivation cannot be [T_Var], since a
      variable is never well typed in an empty context.

    - The [T_True], [T_False], and [T_Abs] cases are trivial, since in
      each of these cases we know immediately that [t] is a value.

    - If the last rule of the derivation was [T_App], then [t = t1
      t2], and we know that [t1] and [t2] are also well typed in the
      empty context; in particular, there exists a type [T2] such that
      [|- t1 \in T2 -> T] and [|- t2 \in T2].  By the induction
      hypothesis, either [t1] is a value or it can take an evaluation
      step.

        - If [t1] is a value, we now consider [t2], which by the other
          induction hypothesis must also either be a value or take an
          evaluation step.

            - Suppose [t2] is a value.  Since [t1] is a value with an
              arrow type, it must be a lambda abstraction; hence [t1
              t2] can take a step by [ST_AppAbs].

            - Otherwise, [t2] can take a step, and hence so can [t1
              t2] by [ST_App2].

        - If [t1] can take a step, then so can [t1 t2] by [ST_App1].

    - If the last rule of the derivation was [T_If], then [t = if t1
      then t2 else t3], where [t1] has type [Bool].  By the IH, [t1]
      either is a value or takes a step.

        - If [t1] is a value, then since it has type [Bool] it must be
          either [true] or [false].  If it is [true], then [t] steps
          to [t2]; otherwise it steps to [t3].

        - Otherwise, [t1] takes a step, and therefore so does [t] (by
          [ST_If]).
*)

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

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

  - (* T_If *)
    right. destruct IHHt1...

    + (* t1 is a value *)
      destruct (canonical_forms_bool t1); subst; eauto.

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

(** **** Exercise: 3 stars, optional (progress_from_term_ind)  *)
(** Show that progress can also be proved by induction on terms
    instead of induction on typing derivations. *)

Theorem progress' : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.
Proof.
  intros t.
  induction t; intros T Ht; auto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################################### *)
(** * Preservation *)

(** The other half of the type soundness property is the preservation
    of types during reduction.  For this, we need to develop some
    technical machinery for reasoning about variables and
    substitution.  Working from top to bottom (the high-level property
    we are actually interested in to the lowest-level technical lemmas
    that are needed by various cases of the more interesting proofs),
    the story goes like this:

      - The _preservation theorem_ is proved by induction on a typing
        derivation, pretty much as we did in the [Types] chapter.  The
        one case that is significantly different is the one for the
        [ST_AppAbs] rule, which is defined using the substitution
        operation.  To see that this step preserves typing, we need to
        know that the substitution itself does.  So we prove a...

      - _substitution lemma_, stating that substituting a (closed)
        term [s] for a variable [x] in a term [t] preserves the type
        of [t].  The proof goes by induction on the form of [t] and
        requires looking at all the different cases in the definition
        of substitition.  This time, the tricky cases are the ones for
        variables and for function abstractions.  In both cases, we
        discover that we need to take a term [s] that has been shown
        to be well-typed in some context [Gamma] and consider the same
        term [s] in a slightly different context [Gamma'].  For this
        we prove a...

      - _context invariance_ lemma, showing that typing is preserved
        under "inessential changes" to the context [Gamma] -- in
        particular, changes that do not affect any of the free
        variables of the term.  For this, we need a careful definition
        of

      - the _free variables_ of a term -- i.e., the variables occuring
        in the term that are not in the scope of a function
        abstraction that binds them.
*)

(* ###################################################################### *)
(** ** Free Occurrences *)

(** A variable [x] _appears free in_ a term _t_ if [t] contains some
    occurrence of [x] that is not under an abstraction labeled [x].  For example:
      - [y] appears free, but [x] does not, in [\x:T->U. x y]
      - both [x] and [y] appear free in [(\x:T->U. x y) x]
      - no variables appear free in [\x:T->U. \y:T. x y]  *)

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs : forall x y T11 t12,
      y <> x  ->
      appears_free_in x t12 ->
      appears_free_in x (tabs y T11 t12)
  | afi_if1 : forall x t1 t2 t3,
      appears_free_in x t1 ->
      appears_free_in x (tif t1 t2 t3)
  | afi_if2 : forall x t1 t2 t3,
      appears_free_in x t2 ->
      appears_free_in x (tif t1 t2 t3)
  | afi_if3 : forall x t1 t2 t3,
      appears_free_in x t3 ->
      appears_free_in x (tif t1 t2 t3).

Hint Constructors appears_free_in.

(** A term in which no variables appear free is said to be _closed_. *)

Definition closed (t:tm) :=
  forall x, ~ appears_free_in x t.

(* ###################################################################### *)
(** ** Substitution *)

(** We first need a technical lemma connecting free variables and
    typing contexts.  If a variable [x] appears free in a term [t],
    and if we know [t] is well typed in context [Gamma], then it must
    be the case that [Gamma] assigns a type to [x]. *)

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   Gamma |- t \in T ->
   exists T', Gamma x = Some T'.

(** _Proof_: We show, by induction on the proof that [x] appears free
      in [t], that, for all contexts [Gamma], if [t] is well typed
      under [Gamma], then [Gamma] assigns some type to [x].

      - If the last rule used was [afi_var], then [t = x], and from
        the assumption that [t] is well typed under [Gamma] we have
        immediately that [Gamma] assigns a type to [x].

      - If the last rule used was [afi_app1], then [t = t1 t2] and [x]
        appears free in [t1].  Since [t] is well typed under [Gamma],
        we can see from the typing rules that [t1] must also be, and
        the IH then tells us that [Gamma] assigns [x] a type.

      - Almost all the other cases are similar: [x] appears free in a
        subterm of [t], and since [t] is well typed under [Gamma], we
        know the subterm of [t] in which [x] appears is well typed
        under [Gamma] as well, and the IH gives us exactly the
        conclusion we want.

      - The only remaining case is [afi_abs].  In this case [t =
        \y:T11.t12], and [x] appears free in [t12]; we also know that
        [x] is different from [y].  The difference from the previous
        cases is that whereas [t] is well typed under [Gamma], its
        body [t12] is well typed under [(Gamma, y:T11)], so the IH
        allows us to conclude that [x] is assigned some type by the
        extended context [(Gamma, y:T11)].  To conclude that [Gamma]
        assigns a type to [x], we appeal to lemma [update_neq], noting
        that [x] and [y] are different variables. *)

Proof.
  intros x t T Gamma H H0. generalize dependent Gamma.
  generalize dependent T.
  induction H;
         intros; try solve [inversion H0; eauto].
  - (* afi_abs *)
    inversion H1; subst.
    apply IHappears_free_in in H7.
    rewrite update_neq in H7; assumption.
Qed.

(** Next, we'll need the fact that any term [t] which is well typed in
    the empty context is closed -- that is, it has no free variables. *)

(** **** Exercise: 2 stars, optional (typable_empty__closed)  *)
Corollary typable_empty__closed : forall t T,
    empty |- t \in T  ->
    closed t.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Sometimes, when we have a proof [Gamma |- t : T], we will need to
    replace [Gamma] by a different context [Gamma'].  When is it safe
    to do this?  Intuitively, it must at least be the case that
    [Gamma'] assigns the same types as [Gamma] to all the variables
    that appear free in [t]. In fact, this is the only condition that
    is needed. *)

Lemma context_invariance : forall Gamma Gamma' t T,
     Gamma |- t \in T  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     Gamma' |- t \in T.

(** _Proof_: By induction on the derivation of [Gamma |- t \in T].

      - If the last rule in the derivation was [T_Var], then [t = x]
        and [Gamma x = T].  By assumption, [Gamma' x = T] as well, and
        hence [Gamma' |- t \in T] by [T_Var].

      - If the last rule was [T_Abs], then [t = \y:T11. t12], with [T
        = T11 -> T12] and [Gamma, y:T11 |- t12 \in T12].  The induction
        hypothesis is that for any context [Gamma''], if [Gamma,
        y:T11] and [Gamma''] assign the same types to all the free
        variables in [t12], then [t12] has type [T12] under [Gamma''].
        Let [Gamma'] be a context which agrees with [Gamma] on the
        free variables in [t]; we must show [Gamma' |- \y:T11. t12 \in
        T11 -> T12].

        By [T_Abs], it suffices to show that [Gamma', y:T11 |- t12 \in
        T12].  By the IH (setting [Gamma'' = Gamma', y:T11]), it
        suffices to show that [Gamma, y:T11] and [Gamma', y:T11] agree
        on all the variables that appear free in [t12].

        Any variable occurring free in [t12] must either be [y], or
        some other variable.  [Gamma, y:T11] and [Gamma', y:T11]
        clearly agree on [y].  Otherwise, we note that any variable
        other than [y] which occurs free in [t12] also occurs free in
        [t = \y:T11. t12], and by assumption [Gamma] and [Gamma']
        agree on all such variables, and hence so do [Gamma, y:T11]
        and [Gamma', y:T11].

      - If the last rule was [T_App], then [t = t1 t2], with [Gamma |-
        t1 \in T2 -> T] and [Gamma |- t2 \in T2].  One induction
        hypothesis states that for all contexts [Gamma'], if [Gamma']
        agrees with [Gamma] on the free variables in [t1], then [t1]
        has type [T2 -> T] under [Gamma']; there is a similar IH for
        [t2].  We must show that [t1 t2] also has type [T] under
        [Gamma'], given the assumption that [Gamma'] agrees with
        [Gamma] on all the free variables in [t1 t2].  By [T_App], it
        suffices to show that [t1] and [t2] each have the same type
        under [Gamma'] as under [Gamma].  However, we note that all
        free variables in [t1] are also free in [t1 t2], and similarly
        for free variables in [t2]; hence the desired result follows
        by the two IHs.
*)

Proof with eauto.
  intros.
  generalize dependent Gamma'.
  induction H; intros; auto.
  - (* T_Var *)
    apply T_Var. rewrite <- H0...
  - (* T_Abs *)
    apply T_Abs.
    apply IHhas_type. intros x1 Hafi.
    (* the only tricky step... the [Gamma'] we use to
       instantiate is [update Gamma x T11] *)
    unfold update. unfold t_update. destruct (beq_id x0 x1) eqn: Hx0x1...
    rewrite beq_id_false_iff in Hx0x1. auto.
  - (* T_App *)
    apply T_App with T11...
Qed.

(** Now we come to the conceptual heart of the proof that reduction
    preserves types -- namely, the observation that _substitution_
    preserves types.

    Formally, the so-called _Substitution Lemma_ says this: suppose we
    have a term [t] with a free variable [x], and suppose we've been
    able to assign a type [T] to [t] under the assumption that [x] has
    some type [U].  Also, suppose that we have some other term [v] and
    that we've shown that [v] has type [U].  Then, since [v] satisfies
    the assumption we made about [x] when typing [t], we should be
    able to substitute [v] for each of the occurrences of [x] in [t]
    and obtain a new term that still has type [T]. *)

(** _Lemma_: If [Gamma,x:U |- t \in T] and [|- v \in U], then [Gamma |-
    [x:=v]t \in T]. *)

Lemma substitution_preserves_typing : forall Gamma x U t v T,
     update Gamma x U |- t \in T ->
     empty |- v \in U   ->
     Gamma |- [x:=v]t \in T.

(** One technical subtlety in the statement of the lemma is that we
    assign [v] the type [U] in the _empty_ context -- in other words,
    we assume [v] is closed.  This assumption considerably simplifies
    the [T_Abs] case of the proof (compared to assuming [Gamma |- v \in
    U], which would be the other reasonable assumption at this point)
    because the context invariance lemma then tells us that [v] has
    type [U] in any context at all -- we don't have to worry about
    free variables in [v] clashing with the variable being introduced
    into the context by [T_Abs].

    _Proof_: We prove, by induction on [t], that, for all [T] and
    [Gamma], if [Gamma,x:U |- t \in T] and [|- v \in U], then [Gamma |-
    [x:=v]t \in T].

      - If [t] is a variable, there are two cases to consider, depending
        on whether [t] is [x] or some other variable.

          - If [t = x], then from the fact that [Gamma, x:U |- x \in T] we
            conclude that [U = T].  We must show that [[x:=v]x = v] has
            type [T] under [Gamma], given the assumption that [v] has
            type [U = T] under the empty context.  This follows from
            context invariance: if a closed term has type [T] in the
            empty context, it has that type in any context.

          - If [t] is some variable [y] that is not equal to [x], then
            we need only note that [y] has the same type under [Gamma,
            x:U] as under [Gamma].

      - If [t] is an abstraction [\y:T11. t12], then the IH tells us,
        for all [Gamma'] and [T'], that if [Gamma',x:U |- t12 \in T']
        and [|- v \in U], then [Gamma' |- [x:=v]t12 \in T'].

        The substitution in the conclusion behaves differently,
        depending on whether [x] and [y] are the same variable name.

        First, suppose [x = y].  Then, by the definition of
        substitution, [[x:=v]t = t], so we just need to show [Gamma |-
        t \in T].  But we know [Gamma,x:U |- t : T], and since the
        variable [y] does not appear free in [\y:T11. t12], the
        context invariance lemma yields [Gamma |- t \in T].

        Second, suppose [x <> y].  We know [Gamma,x:U,y:T11 |- t12 \in
        T12] by inversion of the typing relation, and [Gamma,y:T11,x:U
        |- t12 \in T12] follows from this by the context invariance
        lemma, so the IH applies, giving us [Gamma,y:T11 |- [x:=v]t12 \in
        T12].  By [T_Abs], [Gamma |- \y:T11. [x:=v]t12 \in T11->T12], and
        by the definition of substitution (noting that [x <> y]),
        [Gamma |- \y:T11. [x:=v]t12 \in T11->T12] as required.

      - If [t] is an application [t1 t2], the result follows
        straightforwardly from the definition of substitution and the
        induction hypotheses.

      - The remaining cases are similar to the application case.

    Another technical note: This proof is a rare case where an
    induction on terms, rather than typing derivations, yields a
    simpler argument.  The reason for this is that the assumption
    [update Gamma x U |- t \in T] is not completely generic, in
    the sense that one of the "slots" in the typing relation -- namely
    the context -- is not just a variable, and this means that Coq's
    native induction tactic does not give us the induction hypothesis
    that we want.  It is possible to work around this, but the needed
    generalization is a little tricky.  The term [t], on the other
    hand, _is_ completely generic. *)

Proof with eauto.
  intros Gamma x U t v T Ht Ht'.
  generalize dependent Gamma. generalize dependent T.
  induction t; intros T Gamma H;
    (* in each case, we'll want to get at the derivation of H *)
    inversion H; subst; simpl...
  - (* tvar *)
    rename i into y. destruct (beq_idP x y) as [Hxy|Hxy].
    + (* x=y *)
      subst.
      rewrite update_eq in H2.
      inversion H2; subst. clear H2.
                  eapply context_invariance... intros x Hcontra.
      destruct (free_in_context _ _ T empty Hcontra) as [T' HT']...
      inversion HT'.
    + (* x<>y *)
      apply T_Var. rewrite update_neq in H2...
  - (* tabs *)
    rename i into y. apply T_Abs.
    destruct (beq_idP x y) as [Hxy | Hxy].
    + (* x=y *)
      subst.
      eapply context_invariance...
      intros x Hafi. unfold update, t_update.
      destruct (beq_id y x) eqn: Hyx...
    + (* x<>y *)
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold update, t_update.
      destruct (beq_idP y z) as [Hyz | Hyz]; subst; trivial.
      rewrite <- beq_id_false_iff in Hxy.
      rewrite Hxy...
Qed.

(** The substitution lemma can be viewed as a kind of "commutation"
    property.  Intuitively, it says that substitution and typing can
    be done in either order: we can either assign types to the terms
    [t] and [v] separately (under suitable contexts) and then combine
    them using substitution, or we can substitute first and then
    assign a type to [ [x:=v] t ] -- the result is the same either
    way. *)

(* ###################################################################### *)
(** ** Main Theorem *)

(** We now have the tools we need to prove preservation: if a closed
    term [t] has type [T], and takes an evaluation step to [t'], then [t']
    is also a closed term with type [T].  In other words, the small-step
    evaluation relation preserves types.
*)

Theorem preservation : forall t t' T,
     empty |- t \in T  ->
     t ==> t'  ->
     empty |- t' \in T.

(** _Proof_: by induction on the derivation of [|- t \in T].

    - We can immediately rule out [T_Var], [T_Abs], [T_True], and
      [T_False] as the final rules in the derivation, since in each of
      these cases [t] cannot take a step.

    - If the last rule in the derivation was [T_App], then [t = t1
      t2].  There are three cases to consider, one for each rule that
      could have been used to show that [t1 t2] takes a step to [t'].

        - If [t1 t2] takes a step by [ST_App1], with [t1] stepping to
          [t1'], then by the IH [t1'] has the same type as [t1], and
          hence [t1' t2] has the same type as [t1 t2].

        - The [ST_App2] case is similar.

        - If [t1 t2] takes a step by [ST_AppAbs], then [t1 =
          \x:T11.t12] and [t1 t2] steps to [[x:=t2]t12]; the
          desired result now follows from the fact that substitution
          preserves types.

    - If the last rule in the derivation was [T_If], then [t = if t1
      then t2 else t3], and there are again three cases depending on
      how [t] steps.

        - If [t] steps to [t2] or [t3], the result is immediate, since
          [t2] and [t3] have the same type as [t].

        - Otherwise, [t] steps by [ST_If], and the desired conclusion
          follows directly from the induction hypothesis.
*)

Proof with eauto.
  remember (@empty ty) as Gamma.
  intros t t' T HT. generalize dependent t'.
  induction HT;
       intros t' HE; subst Gamma; subst;
       try solve [inversion HE; subst; auto].
  - (* T_App *)
    inversion HE; subst...
    (* Most of the cases are immediate by induction,
       and [eauto] takes care of them *)
    + (* ST_AppAbs *)
      apply substitution_preserves_typing with T11...
      inversion HT1...
Qed.

(** **** Exercise: 2 stars, recommended (subject_expansion_stlc)  *)
(** An exercise in the [Types] chapter asked about the subject
    expansion property for the simple language of arithmetic and
    boolean expressions.  Does this property hold for STLC?  That is,
    is it always the case that, if [t ==> t'] and [has_type t' T],
    then [empty |- t \in T]?  If so, prove it.  If not, give a
    counter-example not involving conditionals.

    Lemma subj_expansion_false : exists t t' T,
      empty |- t' \in T  ->
      t ==> t'           ->
      ~(empty |- t \in T).

    False. let [t = (\x. true) t']
    then t steps down to true, but note t' is not well typed but true is in Bool.

*)

(* ###################################################################### *)
(** * Type Soundness *)

(** **** Exercise: 2 stars, optional (type_soundness)  *)

(** Put progress and preservation together and show that a well-typed
    term can _never_ reach a stuck state.  *)

Definition stuck (t:tm) : Prop :=
  (normal_form step) t /\ ~ value t.

Corollary soundness : forall t t' T,
  empty |- t \in T ->
  t ==>* t' ->
  ~(stuck t').
Proof.
  intros t t' T Hhas_type Hmulti. unfold stuck.
  intros [Hnf Hnot_val]. unfold normal_form in Hnf.
  induction Hmulti.
  (* FILL IN HERE *) Admitted.

(* ###################################################################### *)
(** * Uniqueness of Types *)

(** **** Exercise: 3 stars (types_unique)  *)
(** Another pleasant property of the STLC is that types aer
    unique: a given term (in a given context) has at most one
    type. *)
(** Formalize this statement and prove it. *)
Theorem types_unique : forall Gamma t T1 T2,
  Gamma |- t \in T1  ->
  Gamma |- t \in T2 ->
  T1 = T2.
Proof.
  intros Gamma t T1 T2 H1. generalize dependent T2.
  induction H1; intros T2 H2.
    (* var *)
    + inversion H2; subst; clear H2. admit. (* todo: finish this Some *)
    + inversion H2; subst. apply IHhas_type in H6. subst. reflexivity.
    + admit. (* todo: trivial on paper but not here ?? *)
    + inversion H2; subst. reflexivity.
    + inversion H2; subst. reflexivity.
    + inversion H2; subst. apply IHhas_type2 in H6. assumption.
Qed.

(** [] *)

(* ###################################################################### *)
(** * Additional Exercises *)

(** **** Exercise: 1 star (progress_preservation_statement)  *)
(** Without peeking, write down the progress and preservation
    theorems for the simply typed lambda-calculus.

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

    preservation:  forall t t' T
                       Empty |- t \in T -> t ==> t' -> Empty |- t' \in T.

 *)

(** [] *)

(** **** Exercise: 2 stars (stlc_variation1)  *)
(** Suppose we add a new term [zap] with the following reduction rule:
                         ---------                  (ST_Zap)
                         t ==> zap
    and the following typing rule:
                      ----------------               (T_Zap)
                      Gamma |- zap : T

    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]
         Broken. Since some term t can either step to some t'/= zap or zap.
         ie, let [t = if true then true else false], steps to true and zap.

      - Progress
         Broken. Since zap does cannot step to any other term under [==>]
         but by definition, zap is not a [value].

      - Preservation
         true.

*)

(** **** Exercise: 2 stars (stlc_variation2)  *)
(** Suppose instead that we add a new term [foo] with the following reduction rules:
                       -----------------                (ST_Foo1)
                       (\x:A. x) ==> foo

                         ------------                   (ST_Foo2)
                         foo ==> true
    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]
           remains true. since any non applied lambda abstraction can only step to [true].

      - Progress

          Preserved. Since lambda abstractions now step to foo,
          which by [ST_Foo2] can step to true, by definition a value.

      - Preservation
          Broken. Note the lambda abstraction above [t = (\x:A. x)] need not be type
          [Bool], but [t] can eventually step to true which is in Bool.

[]

*)

(** **** Exercise: 2 stars (stlc_variation3)  *)
(** Suppose instead that we remove the rule [ST_App1] from the [step]
    relation. Which of the following properties of the STLC remain
    true in the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]
          Preserved.

      - Progress
         Broken. Since we can now construct
                 t1 t2 :=  ((\x : Bool -> Bool. x) (\x : Bool. true))   (false)

         which does not step to any term but is also not a value.

         Note [t1 t2] would step to
                  (\x : Bool. true) false
         under [ST_App1] and then step to false under [ST_AppAbs].

      - Preservation
           preserved.

[]
*)

(** **** Exercise: 2 stars, optional (stlc_variation4)  *)
(** Suppose instead that we add the following new rule to the reduction relation:
            ----------------------------------        (ST_FunnyIfTrue)
            (if true then t1 else t2) ==> true
    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

*)

(** **** Exercise: 2 stars, optional (stlc_variation5)  *)
(** Suppose instead that we add the following new rule to the typing relation:
                 Gamma |- t1 \in Bool->Bool->Bool
                     Gamma |- t2 \in Bool
                 ------------------------------          (T_FunnyApp)
                    Gamma |- t1 t2 \in Bool
    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

*)

(** **** Exercise: 2 stars, optional (stlc_variation6)  *)
(** Suppose instead that we add the following new rule to the typing relation:
                     Gamma |- t1 \in Bool
                     Gamma |- t2 \in Bool
                    ---------------------               (T_FunnyApp')
                    Gamma |- t1 t2 \in Bool
    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

*)

(** **** Exercise: 2 stars, optional (stlc_variation7)  *)
(** Suppose we add the following new rule to the typing
    relation of the STLC:
                         ------------------- (T_FunnyAbs)
                         |- \x:Bool.t \in Bool
    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

[]
*)

End STLCProp.

(* ###################################################################### *)
(* ###################################################################### *)
(** ** Exercise: STLC with Arithmetic *)

(** To see how the STLC might function as the core of a real
    programming language, let's extend it with a concrete base
    type of numbers and some constants and primitive
    operators. *)

Module STLCArith.

(** To types, we add a base type of natural numbers (and remove
    booleans, for brevity) *)

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

(** To terms, we add natural number constants, along with
    successor, predecessor, multiplication, and zero-testing... *)

Inductive tm : Type :=
  | tvar  : id -> tm
  | tapp  : tm -> tm -> tm
  | tabs  : id -> ty -> tm -> tm
  | tnat  : nat -> tm
  | tsucc : tm -> tm
  | tpred : tm -> tm
  | tmult : tm -> tm -> tm
  | tif0  : tm -> tm -> tm -> tm.

(** **** Exercise: 4 stars (stlc_arith)  *)
(** Finish formalizing the definition and properties of the STLC extended
    with arithmetic.  Specifically:

    - Copy the whole development of STLC that we went through above (from
      the definition of values through the Progress theorem), and
      paste it into the file at this point.

    - Extend the definitions of the [subst] operation and the [step]
      relation to include appropriate clauses for the arithmetic operators.

    - Extend the proofs of all the properties (up to [soundness]) of
      the original STLC to deal with the new syntactic forms.  Make
      sure Coq accepts the whole file. *)

(* specifiy value *)
Inductive value : tm -> Prop :=
  | v_abs  : forall x T t,
      value (tabs x T t)
  | v_nat  : forall n,
      value (tnat n).

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

(* substitution  as fixpoint [ x := s] t *)
Fixpoint subst (x : id) (s t : tm) : tm :=
  match t with
  | tvar x'         => if beq_id x x' then s else t
  | tapp t1 t2      => tapp ([x := s] t1) ([x:= s] t2)
  | tabs x' T t'    => tabs x' T (if beq_id x x' then t' else [x := s] t')
  | tnat _          => t
  | tsucc t'        => tsucc ([x := s] t')
  | tpred t'        => tpred ([x := s] t')
  | tmult t1 t2     => tmult ([x := s] t1) ([x := s] t2)
  | tif0 t1 t2 t3   => tif0 ([x := s] t1) ([x := s] t2) ([x := s] t3)
  end
where "'[' x ':=' s ']' t" := (subst x s t).

(* substitution as relation [x := s ] t *)
Inductive substi (s : tm) (x : id) : tm -> tm -> Prop :=

  | s_var1 : substi s x (tvar x) s

  | s_var2 : forall y,
     x <> y -> substi s x (tvar y) (tvar y)

  | s_abs1 : forall t T,
     substi s x (tabs x T t) (tabs x T t)

  | s_abs2 : forall y t t' T,
     x <> y            ->
     substi s x t t'   ->
     substi s x (tabs y T t) (tabs y T t')

  | s_app : forall t1 t2 t1' t2',
     substi s x t1 t1'  ->
     substi s x t2 t2'  ->
     substi s x (tapp t1 t2) (tapp t1' t2')

  | t_succ : forall t t',
     substi s x t t'    ->
     substi s x (tsucc t) (tsucc t')

  | t_pred : forall t t',
     substi s x t t'    ->
     substi s x (tpred t) (tpred t')

  | t_mult : forall t1 t2 t1' t2',
     substi s x t1 t1'    ->
     substi s x t2 t2'    ->
     substi s x (tmult t1 t2) (tmult t1' t2')

  | t_if : forall t1 t2 t1' t2' t3 t3',
     substi s x t1 t1'    ->
     substi s x t2 t2'    ->
     substi s x t3 t3'    ->
     substi s x (tif0 t1 t2 t3) (tif0 t1' t2' t3').

Hint Constructors substi.

(* reduction under step *)
Inductive step : tm -> tm -> Prop :=

  | ST_AppAbs : forall x T t v,
     value v ->
     tapp (tabs x T t) v ==> subst x v t

  | ST_App1 : forall t1 t1' t2,
     t1 ==> t1' ->
     tapp t1 t2 ==> tapp t1' t2

  | ST_App2 : forall v t t',
     value v ->
     tapp v t  ==> tapp v t'

  | ST_Succ1 : forall t t',
     t ==> t' ->
     tsucc t ==> tsucc t'

  | ST_Succ2 : forall t n,
     t = (tnat n) ->
     tsucc t ==> tnat (S n)

  | ST_Pred1 : forall t t',
     t ==> t' ->
     tpred t ==> tpred t'

  | ST_Pred2 : forall t,
     t = (tnat 0) ->
     tpred t  ==> tnat 0

  | ST_Pred3 : forall t n,
     t = (tnat (S n))  ->
     tpred t  ==> tnat n

  | ST_Mult1 : forall t1 t2 n m,
     t1 = (tnat n) ->
     t2 = (tnat m) ->
     tmult t1 t2 ==> tnat (n * m)

  | ST_Mult2 : forall t1 t1' t2,
     t1 ==> t1'   ->
     tmult t1 t2 ==> tmult t1' t2

  | ST_Mult3 : forall t2 t2' n,
     t2 ==> t2'   ->
     tmult (tnat n) t2 ==> tmult (tnat n) t2'

  | ST_IfZero : forall t1 t2,
     tif0 (tnat 0) t1 t2 ==> t1

  | ST_IfNot : forall n t1 t2,
     tif0 (tnat (S n)) t1 t2  ==> t2

  | ST_If : forall t1 t1' t2 t3,
     t1 ==> t1' ->
     tif0 t1 t2 t3 ==> tif0 t1' t2 t3

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

Hint Constructors step.

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

(* Typing relation *)

Definition context := partial_map ty.

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_Nat : forall Gamma n,
      Gamma |- (tnat n) \in TNat

  | T_Succ : forall Gamma t,
      Gamma |- t \in TNat ->
      Gamma |- (tsucc t) \in TNat

  | T_Pred : forall Gamma t,
      Gamma |- t \in TNat ->
      Gamma |- (tpred t) \in TNat

  | T_Mult : forall Gamma t1 t2,
      Gamma |- t1 \in TNat ->
      Gamma |- t2 \in TNat ->
      Gamma |- (tmult t1 t2) \in TNat

  | T_If   : forall Gamma t1 t2 t3 T,
      Gamma |- t1 \in TNat ->
      Gamma |- t2 \in T    ->
      Gamma |- t3 \in T    ->
      Gamma |- (tif0 t1 t2 t3) \in T

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

(* Progress *)
(* note: not neccesary to finish this on time *)
Theorem Progress : forall t T,
   empty |- t \in T ->
   value t \/ exists t', t ==> t'.
Proof with eauto.
  intros t T H. induction H.
    + (* var x *)         exfalso. admit. (* todo: what to do with this *)
    + (* lambda *)        left. apply v_abs.
    + (* application *)   right. destruct IHhas_type1; subst.
        (* t1 is a value *)
        - inversion H1; subst.
          (* t1 is lambda abstraction *)
            * destruct IHhas_type2; subst.
                (* t2 is a value *)
                exists ([ x := t2] t). apply ST_AppAbs. assumption.
                (* t2 takes a step *)
                inversion H2; subst. exists (tapp (tabs x T t) x0).
                apply ST_App2. assumption.
          (* t1 is a tnat n *)
            * inversion H; subst.
        (* t1 takes a step *)
        - inversion H1; subst. exists (tapp x t2). apply ST_App1. assumption.
    + (* nat *) left. apply v_nat.
    + (* succ  *) right. destruct IHhas_type.
        - (* t is a value *) inversion H0; subst.
             * (* t is lambda *) inversion H.
             * (* t is nat *) exists (tnat (S n)). apply ST_Succ2. reflexivity.
        - (* t steps *) inversion H0; subst.
          exists (tsucc x). apply ST_Succ1. assumption.
    + (* pred *) right. destruct IHhas_type.
       - (* t is a value *) inversion H0; subst.
             * inversion H.
             * destruct n. exists (tnat 0). apply ST_Pred2. reflexivity.
               exists (tnat n). apply ST_Pred3. reflexivity.
      - (* t steps *) inversion H0; subst.
                      exists (tpred x). apply ST_Pred1. assumption.

    + (* mult *) right. destruct IHhas_type1.
         - (* t1 is value *) destruct IHhas_type2.
             * inversion H1; subst. inversion H.
               inversion H2; subst. inversion H0.
               exists (tnat (n * n0)). apply ST_Mult1. reflexivity. reflexivity.
             * inversion H1; subst. inversion H.
               inversion H2; subst. exists (tmult (tnat n) x).
               apply ST_Mult3. assumption.
         - (* t1 steps *) inversion H1; subst. exists (tmult x t2).
                          apply ST_Mult2. assumption.
   + (* if *) right. destruct IHhas_type1.
        - (* t1 value *) inversion H2; subst. inversion H.
                         destruct n; subst. exists t2. apply ST_IfZero.
                         exists t3. apply ST_IfNot.
        - (* t1 steps *) inversion H2; subst. exists (tif0 x t2 t3).
                         apply ST_If. assumption.
Qed.

(* free variable *)
Inductive appears_free_in : id -> tm -> Prop :=

  | afi_var : forall x,
      appears_free_in x (tvar x)

  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)

  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)

  | afi_abs : forall x y T11 t12,
      y <> x  ->
      appears_free_in x t12 ->
      appears_free_in x (tabs y T11 t12)

  | afi_succ: forall x t1,
       appears_free_in x t1 ->
       appears_free_in x (tsucc t1)

  | afi_pred: forall x t1,
       appears_free_in x t1 ->
       appears_free_in x (tpred t1)

  | afi_if1 : forall x t1 t2 t3,
      appears_free_in x t1 ->
      appears_free_in x (tif0 t1 t2 t3)

  | afi_if2 : forall x t1 t2 t3,
      appears_free_in x t2 ->
      appears_free_in x (tif0 t1 t2 t3)

  | afi_if3 : forall x t1 t2 t3,
      appears_free_in x t3 ->
      appears_free_in x (tif0 t1 t2 t3).

Hint Constructors appears_free_in.

(** A term in which no variables appear free is said to be _closed_. *)

Definition closed (t:tm) :=
  forall x, ~ appears_free_in x t.

(* ###################################################################### *)
(** ** Substitution *)

(** We first need a technical lemma connecting free variables and
    typing contexts.  If a variable [x] appears free in a term [t],
    and if we know [t] is well typed in context [Gamma], then it must
    be the case that [Gamma] assigns a type to [x]. *)

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   Gamma |- t \in T ->
   exists T', Gamma x = Some T'.
Proof.
  intros x t T Gamma H H0. generalize dependent Gamma.
  generalize dependent T.
  induction H;
         intros; try solve [inversion H0; eauto].
  - (* afi_abs *)
    inversion H1; subst.
    apply IHappears_free_in in H7.
    rewrite update_neq in H7; assumption.
Qed.

(** Next, we'll need the fact that any term [t] which is well typed in
    the empty context is closed -- that is, it has no free variables. *)

Corollary typable_empty__closed : forall t T,
    empty |- t \in T  ->
    closed t.
Proof. Admitted.

(** Sometimes, when we have a proof [Gamma |- t : T], we will need to
    replace [Gamma] by a different context [Gamma'].  When is it safe
    to do this?  Intuitively, it must at least be the case that
    [Gamma'] assigns the same types as [Gamma] to all the variables
    that appear free in [t]. In fact, this is the only condition that
    is needed. *)

Lemma context_invariance : forall Gamma Gamma' t T,
     Gamma |- t \in T  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     Gamma' |- t \in T.
Proof with eauto.
  intros.
  generalize dependent Gamma'.
  induction H; intros; auto.
  - (* T_Var *)
    apply T_Var. rewrite <- H0...
  - (* T_Abs *)
    apply T_Abs.
    apply IHhas_type. intros x1 Hafi.
    (* the only tricky step... the [Gamma'] we use to
       instantiate is [update Gamma x T11] *)
    unfold update. unfold t_update. destruct (beq_id x x1) eqn: Hxx1...
    rewrite beq_id_false_iff in Hxx1. auto.
  - (* T_App *)
    apply T_App with T11...
  - admit.
  - admit.
  - admit.
  - admit.
  - admit.
Qed.

Lemma substitution_preserves_typing : forall Gamma x U t v T,
     update Gamma x U |- t \in T ->
     empty |- v \in U   ->
     Gamma |- [x:=v]t \in T.

Proof with eauto.
  intros Gamma x U t v T Ht Ht'.
  generalize dependent Gamma. generalize dependent T.
  induction t; intros T Gamma H;
    (* in each case, we'll want to get at the derivation of H *)
    inversion H; subst; simpl...
  - (* tvar *)
    rename i into y. destruct (beq_idP x y) as [Hxy|Hxy].
    + (* x=y *)
      subst.
      rewrite update_eq in H2.
      inversion H2; subst. clear H2.
                  eapply context_invariance... intros x Hcontra.
      destruct (free_in_context _ _ T empty Hcontra) as [T' HT']...
      inversion HT'.
    + (* x<>y *)
      apply T_Var. rewrite update_neq in H2...
  - (* tabs *)
    rename i into y. apply T_Abs.
    destruct (beq_idP x y) as [Hxy | Hxy].
    + (* x=y *)
      subst.
      eapply context_invariance...
      intros x Hafi. unfold update, t_update.
      destruct (beq_id y x) eqn: Hyx...
    + (* x<>y *)
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold update, t_update.
      destruct (beq_idP y z) as [Hyz | Hyz]; subst; trivial.
      rewrite <- beq_id_false_iff in Hxy.
      rewrite Hxy...
Qed.

(* ###################################################################### *)
(** ** Main Theorem for preservation *)

(** We now have the tools we need to prove preservation: if a closed
    term [t] has type [T], and takes an evaluation step to [t'], then [t']
    is also a closed term with type [T].  In other words, the small-step
    evaluation relation preserves types.
*)

Theorem preservation : forall t t' T,
     empty |- t \in T  ->
     t ==> t'  ->
     empty |- t' \in T.
Proof. Admitted.

(** [] *)

End STLCArith.

(** $Date: 2016-02-17 17:39:13 -0500 (Wed, 17 Feb 2016) $ *)