(* -------------------------------------------------------------------- *)
Require Import ssreflect ssrbool List.
Require Import Coq.Lists.List.
Require Import Coq.Arith.PeanoNat.

Set Implicit Arguments.

Axiom todo : forall {A}, A.
Ltac todo := by apply: todo.

(* ==================================================================== *)
(* This template contains incomplete definitions that you have to       *)
(* fill. We always used the keyword `Definition` for all of them but    *)
(* you are free to change for a `Fixpoint` or an `Inductive`.           *)
(*                                                                      *)
(* If needed, it is perfectly fine to add intermediate definitions and  *)
(* local lemmas.                                                        *)

(* ==================================================================== *)
(* In this project, we are going to develop and prove correct an        *)
(* algorithm for deciding the membership of a word w.r.t. a given       *)
(* regular language - all these terms are going to be defined below     *)

(* This project lies in the domain of *formal languages*. The study     *)
(* of formal languages is a branch of theoretical computer science and  *)
(* is about that is interested in the purely syntactical aspects of     *)
(* of languages and as applications in different domains, ranging from  *)
(* the definition of  the grammar of programming languages to the field *)
(* of automated translation.                                            *)

(* As with natural languages, we first need to fix an alphabet. In our  *)
(* case, we are simply going to declare a type `A : Type` - i.e. we     *)
(* will use the same alphabet for all the formal languages we are going *)
(* to study. Inhabitants of `A` are called `letters`.                   *)

Parameter (A : Type).

(* -------------------------------------------------------------------- *)
(* A `word` is then simply a finite sequence of letters of `A`. We      *)
(* denote by A* the set of words over `A`. In Coq, we are going to      *)
(* represent words as lists whose elements are inhabitants of `A`. This *)
(* naturally leads to the following definition:                         *)

Notation word := (list A).

(* -------------------------------------------------------------------- *)
(* You can get an overview of the List library at the following URL:    *)
(* https://coq.inria.fr/distrib/current/stdlib/Coq.Lists.List.html      *)

(* -------------------------------------------------------------------- *)
(* In this setting, a `language` is simply a subset of A*. Assuming     *)
(* that `x` & `y` are letters of A, we can define the following         *)
(* languages:                                                           *)
(*                                                                      *)
(*  - the empty language: `L = ∅`;                                      *)
(*                                                                      *)
(*  - the language that contains only the empty word ε (i.e. the only   *)
(*    (word of length 0): L = {ε}`;                                     *)
(*                                                                      *)
(*  - the language that contains all the words solely composed of the   *)
(*    letter `x`: L = { ε, x, xx, xxx, ... } = { xⁿ | n ∈ ℕ } (here,    *)
(*    xⁿ stands for the word x…x, where x is repeated n times);         *)
(*                                                                      *)
(*  - the language that contains all the words of the form xⁿyⁿ:        *)
(*    L = { xⁿyⁿ | n ∈ ℕ };                                             *)
(*                                                                      *)
(*  - if we assume that A contains the letter '[' & ']', we can         *)
(*    define the language of well-balanced words for '[' & ']':         *)
(*    L = { w ∈ { [, ] }* | s.t. P(w) && Q(w) }, where                  *)
(*      - P(w) = any prefix of w contain no more ]'s then ['s           *)
(*      - Q(w) = the number of ['s and ]'s of w are equal.              *)

(* --------------------------------------------------------------------      *)
(* We can also combine languages to form other languages. For example,       *)
(* if L and G are languages, we can define:                                  *)
(*                                                                           *)
(*  - the union of L & G            L ∪ G                                    *)
(*  - the concatenation of L & G    { w1 · w2 | w1 ∈ L, w2 ∈ G }             *)
(*  - the intersection of L & G     L ∩ G                                    *)
(*  - the complement of L           A* \ L                                   *)
(*  - the Kleene closure of L       L* = { w_1 ... w_n | n \in ℕ, w_i ∈ L }  *)
(*  - the mirror of L               rev(L) = { rev(w) | w ∈ L }              *)

(* -------------------------------------------------------------------- *)
(* To define languages in Coq, we need a way to represent subsets       *)
(* of A*, i.e. subsets of the set of `word`'s. To that end, we are      *)
(* going to represent a set using its indicator function. (We remind    *)
(* that, given a subset F of an ambient set E, the indicator function   *)
(* of F is the function f_E from E to { ⊤, ⊥ } s.t.                     *)
(*                                                                      *)
(*                     f_E(x) = ⊤ iff x ∈ E                             *)

(* In Coq, the codomain of its indicator function is going to be a      *)
(* proposition: given a function `F : E -> Prop`, we say that x belongs *)
(* to `x` iff `f x` holds.                                              *)

Notation language := (word -> Prop).

(* -------------------------------------------------------------------- *)
(* From now use, we assume that L, G, H denote languages, x, y denote   *)
(* letters and that and w denotes a word.                               *)

Implicit Types (L G H : language) (x y : A) (w : word).

(* -------------------------------------------------------------------- *)
(* From there, we can define the following languages                    *)

(* The empty language: no words belong to it.                           *)
(* (its indicator function always return `False`)                       *)
Definition lang0 : language :=
  fun w => False.

(* The language that only contains the empty word.                      *)
Definition lang1 : language :=
  fun w => w = nil.

(* Q1. We now ask you to define the following languages                 *)

(*  Given a word `w0`, the language that only contains the word `w0`.   *)
Definition langW w0 : language :=
  fun w => w = w0.

(* Given a sequence `ws` of words, the language that contains all the   *)
(* the words `ws` and only these words.                                 *)
Definition langF (ws : list word) : language :=
  fun w => In w ws.

(* Given a letter `x`, the language that only contains the letter `x`   *)
(* seen as a word of length 1.                                          *)
Definition langA x : language :=
  fun w =>
    match w with
    | cons a nil => a = x
    | _ => False
    end.

(* The union of the two languages `L` and `G`.                          *)
Definition langU L G : language :=
  fun w => L w \/ G w.

(* The intersection of the two languages `L` and `G`.                   *)
Definition langI L G : language :=
  fun w => L w /\ G w.

(* The concatenation of the two languages `L` and `G`.                  *)
Definition langS L G : language :=
  fun w => exists w1 w2, w = w1 ++ w2 /\ L w1 /\ G w2.

Fixpoint Ln L n : language :=
match n with
|0 => lang1
|S n => langS L (Ln L n)
end.

(* (* The Kleene closure of the language `L`                               *)
Definition langK L : language :=
  fun w => exists n, Ln L n w. *)

Inductive langK L : language :=
|Knil : langK L nil
|Kself w : L w -> langK L w
|Kconcat w1 w2 : langK L w1 -> langK L w2 -> langK L (w1 ++ w2).

Definition langK_2 L : language :=
fun w => exists n, Ln L n w.
(*
Fixpoint langKn L : language:=
fun w => w = nil \/ exists w1 w2, w1 <> nil /\ L w1 /\ langKn L w2 /\ w = w1 ++ w2.
*)

(* The mirror of the language `L` (You can use the `rev`, that reversed *)
(* a list, from the standard library. *)
Definition langM L : language :=
  fun w => L (rev w).

(* -------------------------------------------------------------------- *)
(* Given two languages, we will consider `L` & `G` equal iff they       *)
(* contain the same words:                                              *)

Definition eqL L G := forall w, L w <-> G w.

Infix "=L" := eqL (at level 90).

(* Q2. Prove the following equivalences:                                *)
(* Helpful lemmas: *)

Lemma eqL_A (L G H:language): (L =L G) /\ (G =L H) -> (L =L H).
Proof.
intros. move: H0 => [LG GH].
split;intro.
apply GH. apply LG. done.
apply LG. apply GH. done.
Qed.

Lemma eqL_R L G : (L =L G) -> (G =L L).
Proof.
intros.
split.
apply H.
apply H.
Qed.

(* Q2. Prove the following equivalances:                                *)

Lemma concat0L L : langS lang0 L =L lang0.
Proof.
split.
+ move => [w1 [w2 [eq [false l]]]].
  contradiction.
+ contradiction.
Qed.

Lemma concatL0 L : langS L lang0 =L lang0.
Proof.
unfold langS.
unfold lang0.
split.
+ move => [w1 [w2 [eq [l false]]]]. contradiction.
+ contradiction.
Qed.

Lemma concat1L L : langS lang1 L =L L.
Proof.
split.
+ move => [w1 [w2 [eq [wnil lw2]]]].
  rewrite wnil in eq.
  simpl in eq.
  rewrite eq.
  apply lw2.
+ exists nil. exists w. done.
Qed.

Lemma concatL1 L : langS L lang1 =L L.
Proof.
unfold langS; unfold lang1.
split.
+ move => [w1 [w2 [eq [lw1 wnil]]]].
  rewrite wnil in eq.
  rewrite app_nil_r in eq.
  rewrite eq.
  done.
+ move => Lw.
  exists w. exists nil.
  split.
  - rewrite app_nil_r. done.
  - done.
Qed.

Lemma concatA L G H : langS (langS L G) H =L langS L (langS G H).
Proof.
unfold langS.
split.
+ move => [w1 [w2 [eq1 [[w3 [w4 [eq2 [lw3 gw4] hw2]]]]]]].
  exists w3. exists (w4 ++ w2).
  split.
  - rewrite eq1. rewrite eq2. symmetry. apply app_assoc.
  - split.
    * apply lw3.
    * exists w4. exists w2. done.
+ move => [w1 [w2 [eq1 [lw1 [w3 [w4 [eq2 [gw3 hw4]]]]]]]].
  exists (w1 ++ w3). exists w4.
  split.
  - rewrite eq1. rewrite eq2. apply app_assoc.
  - split.
    * exists w1. exists w3. done.
    * apply hw4.
Qed.

Lemma unionC L G : langU L G =L langU G L.
Proof.
unfold langU.
split; move => [lw | gw].
+ right. done.
+ left. done.
+ right. done.
+ left. done.
Qed.

Lemma interC L G : langI L G =L langI G L.
Proof.
unfold langI.
split; move => [lw gw]; done.
Qed.

Lemma langKK L : langK (langK L) =L langK L.
Proof.
split; move => L1.
+ induction L1.
  - apply Knil.
  - apply H.
  - apply Kconcat.
    * apply IHL1_1.
    * apply IHL1_2.
+ induction L1.
  - apply Knil.
  - apply Kself. apply Kself. apply H.
  - apply Kconcat.
    * apply IHL1_1.
    * apply IHL1_2.
Qed.

(* Note that, since languages are represented as indicator functions    *)
(* over `Prop`, we cannot assess that `L =L G` implies `L = G`.         *)

(* ==================================================================== *)
(*                          REGULAR LANGUAGES                           *)

(* We are now interested in a subclass of languages called "regular     *)
(* languages": a language `L` is said to be regular iff one of the      *)
(* following holds:                                                     *)
(*                                                                      *)
(*  - L = ∅ or L = {ε} or L = {x} for some x ∈ A ;                      *)
(*  - L = L1 ∪ L2 for L1, L2 regular languages ;                        *)
(*  - L = L1 · L2 for L1, L2 regular languages ;                        *)
(*  - L = G* for G a regular language.                                  *)

(* This kind of inductive definitions can be encoded in Coq using       *)
(* an inductive predicate `regular : language -> Prop` s.t.             *)
(*                                                                      *)
(*             L is regular iff `regular L` holds                       *)

(* Q3. complete the following definition of the predicate `regular`:    *)

Inductive regular : language -> Prop :=
  (* Any language equivalent to a regular language is regular *)
| REq L G of regular L & G =L L : regular G

  (* The empty language is regular *)
| REmpty : regular lang0
  (* The empty word is regular*)
| REword : regular lang1
  (* The language with a single word *)
| ROne  : forall w0, regular (langW w0)
  (* The Union of two languages *)
| RUnion L G of regular L & regular G : regular (langU L G)
  (* The Concatenation of two languages *)
| RConc L G of regular L & regular G : regular (langS L G)
  (* The Kleene closure of a regular language *)
| RKleene L of regular L : regular (langK L)
.

(* -------------------------------------------------------------------- *)
(* Q4. prove that `langW w` is regular.                                 *)
Lemma regularW w : regular (langW w).
Proof. todo. Qed.

(* -------------------------------------------------------------------- *)
(* Q5. prove that `langM L` is regular, given that L is regular.        *)
Lemma regularM L : regular L -> regular (langM L).
Proof. todo. Qed.

(* ==================================================================== *)
(*                        REGULAR EXPRESSIONS                           *)

(* Related to regular languages is the notion of regular expressions.   *)
(* A regular expression is a formal, syntactic expression that can      *)
(* latter be interpreted as a regular language. Regular expressions are *)
(* pervasive in computer science, e.g. for searching for some text in   *)
(* a file, as it is possible with the `grep` command line tool.         *)
(*                                                                      *)
(* For instance, the command:                                           *)
(*                                                                      *)
(*    grep -E 'ab*a' foo.txt                                            *)
(*                                                                      *)
(* is going to print all the lines of `foo.txt` that contains a word    *)
(* of the form ab⋯ba (where the letter b can be repeated 0, 1 or more   *)
(* time. I.e., grep is going to find all the lines of `foo.txt` that    *)
(* contains a word that belongs in the formal language:                 *)
(*                                                                      *)
(*    L = { abⁿa | n ∈ ℕ }                                              *)
(*                                                                      *)
(* If you need to convince yourself that L is regular, note that:       *)
(*                                                                      *)
(*    L = { a } ∪ { b }* ∪ { a }                                        *)
(*                                                                      *)
(* In some sense, a regular expression is just a compact way to         *)
(* represent a regular language, and its definition is going to be      *)
(* close to the one of regular languages.                               *)
(*                                                                      *)
(* A regular expression is either:                                      *)
(*                                                                      *)
(*  - the constant ∅ or the constant ε or one letter from A             *)
(*  - the disjunction r1 | r2 of two regular expressions                *)
(*  - the concatenation r1 · r2 of two regular expressions              *)
(*  - the Kleene r* of some regular expression                          *)

(* We can represent regular expressions as a inductive type in Coq.     *)

(* Q6. complete the following definition:                               *)

Inductive regexp : Type :=
| RE_Empty : regexp
| RE_Void  : regexp
| RE_Atom  : A -> regexp

  (* TO BE COMPLETED *)
.

Implicit Types (r : regexp).

(* We now have to formally related regular expressions to regular       *)
(* languages. For that purpose, we are going to interpret a regular     *)
(* expression as a languages. If r is a regular expression, then we     *)
(* denote by language [r] as follows:                                   *)
(*                                                                      *)
(*   - [∅]       = ∅                                                    *)
(*   - [ε]       = ε                                                    *)
(*   - [a]       = { a } for a ∈ A                                      *)
(*   - [r₁ ∪ r₂] = [r₁] ∪ [r₂]                                          *)
(*   - [r₁ · r₂] = [r₁] · [r₂]                                          *)
(*   - [r*]      = [r]*                                                 *)

(* Q7. implement the Coq counterpart of the above definition:           *)

Fixpoint interp (r : regexp) {struct r} : language :=
  match r with
  | _ => todo
  end.

(* Q8. show that the interpretation of a regular expression is a        *)
(*     regular language:                                                *)

Lemma regular_regexp r : regular (interp r).
Proof. todo. Qed.

(* Q9. show that any regular language can be interpreted as a           *)
(*     regular expression:                                              *)

Lemma regexp_regular L : regular L -> exists r, L =L interp r.
Proof. todo. Qed.

(* Of course, it may happen that two regular expressions represent      *)
(* the same language: r1 ~ r2 iff [r1] = [r2].                          *)

(* Q10. write a binary predicate eqR : regexp -> regexp -> Prop s.t.    *)
(*      eqR r1 r2 iff r1 and r2 are equivalent regexp.                  *)

Definition eqR (r1 r2 : regexp) : Prop := todo.

Infix "~" := eqR (at level 90).

(* Q11. state and prove the following regexp equivalence:               *)
(*           (a|b)* ~ ( a*b* )*                                         *)

(* ==================================================================== *)
(*                          REGEXP MATCHING                             *)

(* We now want to write a algorithm for deciding if a given word `w`    *)
(* matches a regular expression `r`, i.e. for deciding wether `w ∈ [r]` *)
(*                                                                      *)
(* For that purpose, we are going to use Brzozowski's derivatives.      *)
(*                                                                      *)
(* The idea of the algorithm is the following:                          *)
(*                                                                      *)
(* Given a letter `x` and an regular expression `r`, the Brzozowski's   *)
(* derivatives of `x` w.r.t. `r` is a regular expression x⁻¹·r s.t.     *)
(*                                                                      *)
(*    x · w ∈ [r] ⇔ w ∈ [x⁻¹·r]                                         *)
(*                                                                      *)
(* Assuming that we can compute a Brzozowski's derivative for any       *)
(* letter `x` and regular expression `r`, one can check that a word `w` *)
(* matches a regexp `r` as follows:                                     *)
(*                                                                      *)
(*   - if w = x · w' for some letter x and word w', we recursively      *)
(*     check that `w` matches `x⁻¹·r`; otherwise                        *)
(*   - if w = ε, then we directly check that [r] contains the empty     *)
(*     word - a property that is deciable.                              *)

(* Q12. write a nullity test `contains0` : regexp -> bool s.t.          *)
(*                                                                      *)
(*      ∀ r, contains0 r ⇔ ε ∈ [e]                                      *)

Definition contains0 (r : regexp) : bool := todo.

(* Q13. prove that your definition of `contains0` is correct:           *)

Lemma contains0_ok r : contains0 r <-> interp r nil.
Proof. todo. Qed.

(* We give below the definition of the Brzozowski's derivative:         *)
(*                                                                      *)
(*   - x⁻¹ · x         = ε                                              *)
(*   - x⁻¹ · y         = ∅ if x ≠ y                                     *)
(*   - x⁻¹ · ε         = ∅                                              *)
(*   - x⁻¹ · ∅         = ∅                                              *)
(*   - x⁻¹ · (r₁ | r₂) = (x⁻¹ · r₁) | (x⁻¹ · r₂)                        *)
(*   - x⁻¹ · (r₁ · r₂) = (x⁻¹ · r₁) · r₂ | E(r₁) · (x⁻¹ · r₂)           *)
(*   - x⁻¹ · r*        = (x⁻¹ · r) · r*                                 *)
(*                                                                      *)
(* where E(r) = ε if ε ∈ [r] & E(r) = ∅ otherwise.                      *)

(* Q14. write a function `Brzozowski` that computes a Brzozowski's      *)
(*      derivative as defined above.                                    *)
(*                                                                      *)
(* For that purpose, you may need to have a decidable equality over     *)
(* `A`. The parameter `Aeq` along with the axioms `Aeq_dec` give        *)
(* you such a decidable equality.                                       *)

Parameter Aeq : A -> A -> bool.

(* Here, `Aeq x y` has to be read as `Aeq x y = true`                   *)
Axiom Aeq_dec : forall (x y : A), Aeq x y <-> x = y.

Definition Brzozowski (x : A) (r : regexp) : regexp := todo.

(* Q15. write a function `rmatch` s.t. `rmatch r w` checks wether a     *)
(*      word `w` matches a given regular expression `r`.                *)

Definition rmatch (r : regexp) (w : word) : bool := todo.

(* Q16. show that the `Brzozowski` function is correct.                 *)

Lemma Brzozowski_correct (x : A) (w : word) (r : regexp) :
  interp (Brzozowski x r) w -> interp r (x :: w).
Proof. todo. Qed.

(* Q17. show that `rmatch` is correct.                                  *)

Lemma rmatch_correct (r : regexp) (w : word):
  rmatch r w -> interp r w.
Proof. todo. Qed.

(* Q18. (HARD - OPTIONAL) show that `rmatch` is complete.               *)

Lemma rmatch_complete (r : regexp) (w : word):
  interp r w -> rmatch r w.
Proof. todo. Qed.


Set Implicit Arguments.

Require Import Coq.Lists.ListSet.
Require Import Coq.Lists.List.
Require Import Coq.Bool.Bool.
Require Import Coq.funind.Recdef. (* Required by Function *)
Require Import Coq.Arith.Wf_nat. (* Required implicitly by measure obligations *)

Require Aniceto.Pair.
Require Coq.Structures.OrderedType.

Section LISTS.

Variable A:Type.
Variable eq_dec : forall (v1 v2:A), {v1 = v2} + {v1 <> v2}.
Variable f : A -> bool.

Lemma in_cons_neq:
  forall {A:Type} (x y:A) l,
  In x (y :: l) ->
  x <> y ->
  In x l.
Proof.
  intros.
  inversion H.
  contradiction H0.
  auto.
  assumption.
Qed.

Lemma filter_length:
  forall l,
  length (filter f l) <= length l.
Proof.
  intros.
  induction l.
  - auto.
  - simpl.
    destruct (f a); simpl; auto with *.
Qed.

Lemma filter_inv:
  forall l,
  {l = filter f l} + {length l > length (filter f l)}.
Proof.
  intros.
  induction l.
  - left.
    auto.
  - destruct IHl.
    + simpl.
      rewrite <- e in *; clear e.
      destruct (f a).
      * left.
        auto.
      * right.
        auto with *.
    + simpl.
      destruct (f a);(
        right;
        simpl;
        auto with *
      ).
Qed.

Lemma filter_incl:
  forall l,
  incl (filter f l) l.
Proof.
  intros.
  unfold incl.
  intros.
  rewrite filter_In in H.
  intuition.
Qed.

Lemma filter_in:
  forall x l,
  In x (filter f l) ->
  In x l.
Proof.
  intros.
  assert (f_i := filter_incl l).
  unfold incl in f_i.
  auto.
Qed.

Lemma filter_refl:
  forall l,
  filter f l = l ->
  incl l (filter f l).
Proof.
  intros.
  induction l.
  - simpl.
    unfold incl.
    intros.
    inversion H0.
  - simpl in *.
    destruct (f a); (
      rewrite H;
      apply incl_refl).
Qed.

Lemma filter_forallb:
  forall l,
  filter f l = l <->
  forallb f l = true.
Proof.
  intros.
  split.
  - intros.
    induction l.
    + auto.
    + assert (Hfa : f a = true).
      assert (Ha : In a (filter f (a :: l))).
      rewrite H.
      apply in_eq.
      rewrite filter_In in Ha.
      intuition.
      simpl in *.
      destruct (f a).
      * inversion H.
        rewrite H1.
        auto.
      * inversion Hfa. (*absurd *)
  - intros. induction l.
    auto.
    simpl in *.
    rewrite Bool.andb_true_iff in H.
    destruct H as (Hl, Hr).
    apply IHl in Hr.
    destruct (f a).
    + rewrite Hr. trivial.
    + inversion Hl.
Qed.

  Lemma filter_nil_to_forallb:
    forall l,
    filter f l = nil ->
    forallb (fun x : A => negb (f x)) l = true.
  Proof.
    induction l; intros; auto.
    simpl in *.
    destruct (f a); simpl in *.
    - inversion H.
    - auto.
  Qed.

  Lemma filter_nil_to_forall:
    forall l,
    filter f l = nil ->
    forall x,
    List.In x l ->
    f x = false.
  Proof.
    intros.
    apply filter_nil_to_forallb in H.
    rewrite forallb_forall in H.
    apply H in H0.
    apply negb_true_iff in H0.
    assumption.
  Qed.

  Lemma forallb_to_filter_nil:
    forall l,
    forallb (fun x => negb (f x)) l = true ->
    filter f l = @nil A.
  Proof.
    induction l; intros; auto.
    simpl in *.
    destruct (f a); simpl in *.
    - inversion H.
    - auto.
  Qed.

  Lemma forall_to_filter_nil:
    forall l,
    (forall x, List.In x l -> f x = false) ->
    filter f l = nil.
  Proof.
    intros.
    assert (forallb (fun x => negb (f x)) l = true). {
      rewrite forallb_forall.
      intros.
      apply H in H0.
      apply negb_true_iff in H0.
      assumption.
    }
    auto using forallb_to_filter_nil.
  Qed.

  Lemma filter_forallb_false:
    forall l,
    filter f l = nil <->
    forallb (fun x => negb (f x)) l = true.
  Proof.
    split; auto using filter_nil_to_forallb, forallb_to_filter_nil.
  Qed.

  Lemma filter_forall_false:
    forall l,
    filter f l = nil <->
    (forall x, List.In x l -> f x = false).
  Proof.
    split; eauto using filter_nil_to_forall, forall_to_filter_nil.
  Qed.

  Lemma notin_contract:
    forall (x y:A) l,
    ~ In x (y :: l) ->
    ~ In x l.
  Proof.
    intros.
    intuition.
  Qed.

  Lemma filter_notin_to_false:
    forall l (x:A),
    In x l ->
    ~ In x (filter f l) ->
    f x = false.
  Proof.
    induction l; intros.
    - inversion H.
    - simpl in *.
      destruct H. {
        subst.
        destruct (f x). {
          contradiction H0.
          auto using in_eq.
        }
        trivial.
      }
      destruct (f a). {
        apply notin_contract in H0.
        auto.
      }
      auto.
  Qed.

  Lemma filter_in_to_true:
    forall l (x:A),
    In x l ->
    In x (filter f l) ->
    f x = true.
  Proof.
    induction l; intros.
    - inversion H.
    - simpl in *.
      destruct H. {
        subst.
        remember (f x).
        destruct b; auto.
        assert (In x l) by auto using filter_in.
        assert (Hx: f x = true) by eauto.
        rewrite Hx in Heqb.
        inversion Heqb.
      }
      remember (f a).
      destruct b. {
        destruct H0; subst; auto.
      }
      auto.
  Qed.

  Lemma filter_false_to_notin:
    forall l (x:A),
    In x l ->
    f x = false ->
    ~ In x (filter f l).
  Proof.
    intros.
    induction l. {
      inversion H.
    }
    inversion H; subst. {
      simpl.
      rewrite H0.
      intuition.
      assert (incl (filter f l) l). {
        auto using filter_incl.
      }
      unfold incl in *.
      assert (Hx := H1).
      apply H2 in H1.
      apply (IHl H1 Hx).
    }
    simpl.
    apply IHl in H1; clear IHl.
    remember (f a).
    destruct b. {
      intuition.
      inversion H2. {
        subst.
        rewrite H0 in Heqb.
        inversion Heqb.
      }
      auto.
    }
    auto.
  Qed.

  Lemma filter_true_to_in:
    forall l (x:A),
    In x l ->
    f x = true ->
    In x (filter f l).
  Proof.
    intros l.
    induction l; intros. {
      inversion H.
    }
    simpl.
    remember (f a).
    symmetry in Heqb.
    destruct H.
    - destruct b. {
        subst; eauto using in_eq.
      }
      subst.
      rewrite H0 in Heqb.
      inversion Heqb.
    - destruct b; eauto using in_cons.
  Qed.

Lemma existsb_inv:
  forall {B:Type} (a:B) l g,
  existsb g (a :: l) = true ->
  g a = false ->
  existsb g l = true.
Proof.
  intros.
  simpl in H.
  rewrite H0 in H.
  auto.
Qed.

Lemma forallb_existsb:
  forall l,
  forallb f l = negb (existsb (fun x => negb (f x)) l).
Proof.
  intros.
  induction l.
  - auto.
  - simpl.
    rewrite negb_orb.
    rewrite negb_involutive.
    rewrite <- IHl.
    auto.
Qed.

Lemma Forall_forallb:
  forall l,
  Forall (fun x => Is_true (f x)) l <->
  forallb f l = true.
Proof.
  split.
  + intro.
    rewrite forallb_forall.
    intros.
    rewrite Forall_forall in H.
    auto using Is_true_eq_true.
  + intros.
    rewrite forallb_forall in H.
    rewrite Forall_forall.
    intros.
    auto using Is_true_eq_left.
Qed.

  Lemma existsb_Exists:
    forall {A:Type} f (l:list A),
    existsb f l = true ->
    Exists (fun x => f x = true) l.
  Proof.
    intros.
    rewrite existsb_exists in *.
    rewrite Exists_exists.
    assumption.
  Qed.

End LISTS.

Arguments filter_inv : default implicits.

Section FEEDBACK.
Variable A:Type.
Variable eq_dec : forall (v1 v2:A), {v1 = v2} + {v1 <> v2}.
Variable f : list A -> A -> bool.

Function feedback_filter (l:list A) {measure length l} :=
  let fl := filter (f l) l in
  if list_eq_dec eq_dec l fl then l
  else feedback_filter fl.
Proof.
  intros.
  destruct (filter_inv (f l) l).
  - contradiction anonymous.
  - auto.
Defined.

Lemma feedback_filter_incl:
  forall l,
  incl (feedback_filter l) l.
Proof.
  intros.
  elim l using feedback_filter_rec.
  - auto using incl_refl.
  - intros. clear l. rename l0 into l.
    remember (filter (f l) l) as l'.
    assert (Hx : incl l' l). {
      rewrite Heql'.
      apply filter_incl.
    }
    eauto using incl_tran.
Qed.

Lemma feedback_filter_simpl:
  forall l,
  filter (f l) l = l ->
  feedback_filter l = l.
Proof.
  intros.
  rewrite feedback_filter_equation.
  destruct (list_eq_dec eq_dec l (filter (f l) l)).
  - auto.
  - contradiction n.
    auto.
Qed.

Let if_list_eq_dec_eq:
  forall {B:Type} l (a b:B),
  (if list_eq_dec eq_dec l l then a else b) = a.
Proof.
  intros.
  destruct (list_eq_dec eq_dec l l); (
    try (contradiction n); auto
  ).
Qed.

Let if_list_eq_filter_forallb:
  forall {B:Type} l (a b:B),
  (if list_eq_dec eq_dec l (filter (f l) l) then a else b)
  = (if forallb (f l) l then a else b).
Proof.
  intros.
  remember (filter (f l) l) as fl.
  symmetry in Heqfl.
  remember (forallb (f l) l) as flb.
  symmetry in Heqflb.
  destruct flb.
  - rewrite <- filter_forallb in Heqflb.
    rewrite Heqfl in Heqflb.
    rewrite Heqflb.
    apply if_list_eq_dec_eq.
  - destruct (list_eq_dec eq_dec l fl).
    + rewrite <- e in Heqfl.
      rewrite filter_forallb in Heqfl.
      rewrite Heqfl in Heqflb.
      inversion Heqflb.
    + auto.
Qed.

Let feedback_filter_equation2:
  forall l : list A,
  feedback_filter l =
  (if forallb (f l) l
  then l
  else feedback_filter (filter (f l) l)).
Proof.
  intros.
  rewrite feedback_filter_equation.
  rewrite if_list_eq_filter_forallb.
  auto.
Qed.

Lemma feedback_filter_prop:
  forall l fl,
  feedback_filter l = fl <->
  (Forall (fun x=>Is_true (f l x)) l /\ fl = l)
  \/
  (exists x, In x l /\ Is_true (negb (f l x)) /\ fl = feedback_filter (filter (f l) l)).
Proof.
  intros.
  split.
  - intros.
    rewrite feedback_filter_equation2 in H.
    remember (forallb (f l) l) as flb.
    symmetry in Heqflb.
    destruct flb.
    + rewrite forallb_forall in Heqflb.
      left.
      rewrite Forall_forall.
      intuition.
      auto using Is_true_eq_left.
    + right.
      rewrite forallb_existsb in Heqflb.
      rewrite negb_false_iff in Heqflb.
      rewrite existsb_exists in Heqflb.
      destruct Heqflb as (x, (x_in, flx)).
      exists x.
      apply Is_true_eq_left in flx.
      intuition.
   - intros.
     rewrite feedback_filter_equation2.
     destruct H as [(H1,H2)|(x, (H1, (H2, H3)))].
     + apply Forall_forallb in H1.
       rewrite H1.
       auto.
     + rewrite <- H3.
       remember (forallb (f l) l) as c.
       symmetry in Heqc.
       destruct c.
       * rewrite forallb_forall in Heqc.
         apply Heqc in H1.
         apply Is_true_eq_true in H2.
         rewrite negb_true_iff in H2.
         rewrite H1 in H2.
         inversion H2.
       * auto.
Qed.

Lemma feedback_filter_in_f:
  forall x l,
  In x (feedback_filter l) -> f (feedback_filter l) x = true.
Proof.
  intros.
  functional induction (feedback_filter l); auto.
  assert (Hf := _x).
  symmetry in Hf.
  rewrite filter_forallb in Hf.
  rewrite forallb_forall in Hf.
  auto.
Qed.

Lemma feedback_filter_in:
  forall x l,
  In x (feedback_filter l) ->
  In x l.
Proof.
  intros.
  assert (Hx := feedback_filter_incl l).
  unfold incl in Hx.
  apply Hx; assumption.
Qed.
End FEEDBACK.

Section PARTITION.
Variable A : Type.
Variable f : A -> bool.

Lemma partition_iff_1 :
  forall x l,
  (In x (fst (partition f l)) <-> In x l /\ f x = true).
Proof.
  intros.
  split.
  - intros.
    induction l.
    simpl in *.
    inversion H.
    simpl in H.
    remember (f a) as fa.
    symmetry in Heqfa.
    remember (partition f l) as pf.
    symmetry in Heqpf.
    destruct pf as (pfl, pfr).
    destruct fa.
    + simpl in *.
      destruct H.
      * subst.
        intuition.
      * apply IHl in H; clear IHl.
        destruct H.
        intuition.
    + simpl in *.
      apply IHl in H; clear IHl.
      destruct H.
      intuition.
 - intros.
   destruct H.
   induction l.
   auto.
   simpl in *.
   remember (f a).
   destruct H, b.
   + subst.
     remember (partition f l).
     destruct p.
     simpl.
     auto.
   + subst.
     rewrite H0 in Heqb.
     inversion Heqb.
   + remember (partition f l).
     destruct p.
     simpl in *.
     apply IHl in H.
     intuition.
   + apply IHl in H.
     remember (partition f l).
     destruct p.
     auto.
Qed.

Lemma partition_iff_2 :
  forall x l,
  (In x (snd (partition f l)) <-> In x l /\ f x = false).
Proof.
  intros.
  split.
  - intros.
    induction l.
    simpl in *.
    inversion H.
    simpl in H.
    remember (f a) as fa.
    symmetry in Heqfa.
    remember (partition f l) as pf.
    symmetry in Heqpf.
    destruct pf as (pfl, pfr).
    destruct fa.
    + simpl in *.
      apply IHl in H; clear IHl.
      destruct H.
      intuition.
    + simpl in *.
      destruct H.
      * subst.
        intuition.
      * apply IHl in H; clear IHl.
        destruct H.
        intuition.
 - intros.
   destruct H.
   induction l.
   auto.
   simpl in *.
   remember (f a).
   destruct H, b.
   + subst.
     rewrite H0 in Heqb.
     inversion Heqb.
   + subst.
     remember (partition f l).
     destruct p.
     simpl.
     auto.
   + remember (partition f l).
     destruct p.
     simpl in *.
     auto.
   + apply IHl in H.
     remember (partition f l).
     destruct p.
     simpl in *.
     auto with *.
Qed.

Lemma partition_in :
  forall x l,
  In x l ->
  {In x (fst (partition f l)) /\ f x = true} +
  {In x (snd (partition f l)) /\ f x = false}.
Proof.
  intros.
  remember (f x).
  symmetry in Heqb.
  destruct b.
  - left.
    intuition.
    apply partition_iff_1.
    auto.
  - right.
    intuition.
    apply partition_iff_2.
    auto.
Qed.

Lemma partition_length:
  forall l,
  length (snd (partition f l)) <= length l.
Proof.
  intros.
  induction l.
  auto.
  simpl.
  remember (partition f l) as p.
  symmetry in Heqp.
  destruct p as (pl, pr).
  simpl in *.
  remember (f a) as fa.
  destruct fa; simpl; auto with *.
Qed.

End PARTITION.

Lemma split_in_r:
  forall {L R:Type} (r:R) (lst:list (L * R)),
  In r (snd (split lst)) ->
  exists (l:L), In (l, r) lst.
Proof.
  intros.
  induction lst.
  inversion H.
  destruct a.
  simpl in *.
  remember (split lst).
  destruct p as (ll, lr).
  simpl in *.
  destruct H.
  - subst.
    eauto.
  - apply IHlst in H.
    destruct H as (l', Hin).
    eauto.
Qed.

Lemma split_in_l:
  forall {L R:Type} (l:L) (lst:list (L * R)),
  In l (fst (split lst)) ->
  exists (r:R), In (l, r) lst.
Proof.
  intros.
  induction lst.
  inversion H.
  destruct a.
  simpl in *.
  remember (split lst).
  destruct p as (ll, lr).
  simpl in *.
  destruct H.
  - subst.
    exists r.
    intuition.
  - apply IHlst in H.
    destruct H as (r', Hin).
    exists r'.
    intuition.
Qed.

Fixpoint split_alt {A:Type} {B:Type} (l:list (A*B) %type) : (list A * list B) % type:=
  match l with
    | nil => (nil, nil)
    | (x, y) :: l => (x :: (fst (split_alt l)), y :: (snd (split_alt l)))
  end.

Lemma split_alt_spec:
  forall {A:Type} {B:Type} (l:list (A*B) %type),
  split l = split_alt l.
Proof.
  intros.
  induction l.
  - auto.
  - simpl. intuition.
    rewrite IHl.
    remember (split_alt l) as l'.
    destruct l' as (lhs, rhs).
    auto.
Qed.

Lemma in_fst_split:
  forall {A:Type} {B:Type} (l:list (A*B)%type) (lhs:A),
  List.In lhs (fst (split l)) ->
  exists rhs, List.In (lhs, rhs) l.
Proof.
  intros.
  induction l.
  { inversion H. (* absurd *) }
  destruct a.
  rewrite split_alt_spec in H.
  simpl in H.
  destruct H.
  + subst.
    eauto using in_eq.
  + rewrite <- split_alt_spec in H.
    apply IHl in H; clear IHl.
    destruct H as (r, Hin).
    eauto using in_cons.
Qed.

Lemma in_snd_split:
  forall {A:Type} {B:Type} (l:list (A*B)%type) (rhs:B),
  List.In rhs (snd (split l)) ->
  exists (lhs:A), List.In (lhs, rhs) l.
Proof.
  intros.
  induction l.
  { inversion H. (* absurd *) }
  destruct a.
  rewrite split_alt_spec in H.
  simpl in H.
  destruct H.
  + subst.
    exists a.
    apply in_eq.
  + rewrite <- split_alt_spec in H.
    apply IHl in H; clear IHl.
    destruct H as (r, Hin).
    exists r.
    apply in_cons; assumption.
Qed.

Require Import Coq.Lists.SetoidList.

Section INA_IN.
  Let ina_to_in:
    forall {A:Type} (P: A -> A -> Prop) (P_eq: forall x y, P x y <-> x = y) (a:A) l,
    InA P a l ->
    List.In a l.
  Proof.
    intros. induction l.
    + inversion H.
    + inversion H; subst; clear H.
      * apply P_eq in H1.
        subst.
        apply in_eq.
      * auto using in_cons.
  Qed.

  Let in_to_ina:
    forall {A:Type} (P: A -> A -> Prop) (P_eq: forall x y, P x y <-> x = y) (a:A) l,
    List.In a l ->
    InA P a l.
  Proof.
    intros. induction l.
    + inversion H.
    + inversion H; subst; clear H.
      * apply InA_cons_hd.
        rewrite P_eq; auto.
      * auto using InA_cons_tl.
  Qed.

  Lemma ina_in_iff:
    forall {A:Type} (P: A -> A -> Prop) (P_eq: forall x y, P x y <-> x = y) (a:A) l,
    InA P a l <-> List.In a l.
  Proof.
    intros.
    split; eauto using ina_to_in, in_to_ina.
  Qed.

End INA_IN.

Section NODUPA_NODUP.
  Let nodupa_to_nodup:
    forall {A:Type} (P: A -> A -> Prop) (P_eq: forall x y, P x y <-> x = y) l,
    NoDupA P l ->
    NoDup l.
  Proof.
    intros.
    induction l.
    - apply NoDup_nil.
    - apply NoDup_cons.
      + intuition.
        inversion H; clear H; subst.
        rewrite ina_in_iff in H3.
        contradiction H0.
        assumption.
      + inversion H; clear H; subst.
        auto.
  Qed.

  Let nodup_to_nodupa:
    forall {A:Type} (P: A -> A -> Prop) (P_eq: forall x y, P x y <-> x = y) l,
    NoDup l ->
    NoDupA P l.
  Proof.
    intros.
    induction l.
    - apply NoDupA_nil.
    - inversion H; clear H; subst.
      apply IHl in H3; clear IHl.
      apply NoDupA_cons; auto.
      intuition.
      rewrite ina_in_iff in H; auto.
  Qed.

  Lemma nodupa_nodup_iff:
    forall {A:Type} (P: A -> A -> Prop) (P_eq: forall x y, P x y <-> x = y) l,
    NoDupA P l <-> NoDup l.
  Proof.
    intros.
    split; eauto using nodupa_to_nodup, nodup_to_nodupa.
  Qed.
End NODUPA_NODUP.

Section InA.
  Lemma ina_map:
    forall {A:Type} {B:Type} (eq_a:A->A->Prop) (eq_b:B->B->Prop) f a l,
    (forall a1 a2, eq_b (f a1) (f a2) -> eq_a a1 a2) ->
    InA (eq_b) (f a) (map f l) ->
    InA (eq_a) a l.
  Proof.
    intros.
    intuition.
    induction l; simpl; inversion H0; subst.
    - rewrite InA_altdef.
      rewrite Exists_exists.
      exists a0.
      intuition.
    - auto using InA_cons.
  Qed.
End InA.
Section NoDupA.
  Lemma nodupa_map:
    forall {A:Type} {B:Type} (f:A -> B) (eq_key_a:A -> A -> Prop) (eq_key_b: B -> B -> Prop) l,
    (forall a1 a2, eq_key_b (f a1) (f a2) -> eq_key_a a1 a2) ->
    NoDupA eq_key_a l ->
    NoDupA eq_key_b (map f l).
  Proof.
    induction l; intros; simpl; auto.
    inversion H0.
    subst.
    apply NoDupA_cons; auto.
    intuition.
    eapply ina_map in H1; eauto.
  Qed.
End NoDupA.

Arguments filter_incl : default implicits.
Arguments feedback_filter : default implicits.
Arguments feedback_filter_equation : default implicits.

Section FindProps.

Variable A: Type.
Variable f: A -> bool.

Lemma find_some_impl_existsb:
  forall l x,
  find f l = Some x -> existsb f l = true.
Proof.
  intros.
  induction l; simpl in *.
  { inversion H. }
  destruct (f a); auto.
Qed.

Lemma existsb_impl_find_some:
  forall l,
  existsb f l = true ->
  exists x, find f l = Some x.
Proof.
  intros.
  induction l.
  { inversion H. }
  simpl in *.
  destruct (f a); eauto.
Qed.

Lemma find_existsb_spec_true:
  forall l,
  (exists x, find f l = Some x) <-> existsb f l = true.
Proof.
  intros.
  split.
  - intros.
    destruct H.
    eauto using find_some_impl_existsb.
  - apply existsb_impl_find_some.
Qed.

Lemma find_none_impl_existsb:
  forall l,
  find f l = None -> existsb f l = false.
Proof.
  intros.
  induction l.
  { auto. }
  simpl in *.
  destruct (f a).
  - inversion H.
  - auto.
Qed.

Lemma existsb_false_impl_find:
  forall l,
  existsb f l = false ->
  find f l = None.
Proof.
  intros.
  induction l.
  { auto. }
  simpl in *.
  destruct (f a).
  - inversion H.
  - auto.
Qed.

Lemma find_existsb_spec_false:
  forall l,
  find f l = None <-> existsb f l = false.
Proof.
  split.
  - apply find_none_impl_existsb.
  - apply existsb_false_impl_find.
Qed.

Lemma find_inv_eq:
  forall x l,
  f x = true ->
  find f (x :: l) = Some x.
Proof.
  intros.
  simpl.
  rewrite H.
  trivial.
Qed.

Lemma existsb_forallb:
  forall l,
  existsb f l = negb (forallb (fun x : A => negb (f x)) l).
Proof.
  intros.
  induction l.
  - auto.
  - simpl.
    destruct (f a); auto.
Qed.

Lemma find_none_incl:
  forall x l,
  find f (x::l) = None ->
  find f l = None.
Proof.
  intros.
  rewrite find_existsb_spec_false in *.
  rewrite existsb_forallb in *.
  rewrite negb_false_iff in *.
  apply Forall_forallb.
  apply Forall_forallb in H.
  inversion H; auto.
Qed.

Lemma find_some_spec:
  forall x l,
  find f l = Some x ->
  In x l /\ f x = true.
Proof.
  intros.
  induction l.
  { inversion H. }
  simpl in H.
  remember (f a).
  destruct b.
  - inversion H.
    subst.
    split; auto using in_eq.
  - apply IHl in H.
    destruct H.
    split; auto.
    auto using in_cons.
Qed.

End FindProps.

Set Implicit Arguments.

Section Sum.
  Variable A: Type.
  Variable weight: A -> nat.
  Let aux := (fun (n:nat) (a:A) => n + weight a).
  Definition summation (l:list A) : nat := fold_left aux l 0.

  Let fold_left_aux_lift:
    forall l n,
    fold_left aux l n = n + fold_left aux l 0.
  Proof.
    intros l.
    induction l.
    { intros; auto. }
    intros.
    simpl.
    assert (rw1 : aux n a = n + weight a) by auto.
    rewrite rw1.
    assert (rw2 : aux 0 a = weight a) by auto.
    rewrite rw2.
    assert (rw3 := IHl (n+ weight a)).
    rewrite rw3.
    assert (rw4 := IHl (weight a)).
    rewrite rw4.
    auto with *.
  Qed.

  Lemma summation_rw_cons:
    forall l x,
    summation (x::l) = weight x + summation l.
  Proof.
    intros l.
    induction l.
    - intros.
      auto.
    - assert (Hx := IHl a).
      intros.
      rewrite Hx.
      unfold summation.
      simpl.
      assert (rw : aux 0 x = weight x) by auto.
      rewrite rw.
      assert (rw2 : aux (weight x) a = weight x + weight a) by auto.
      rewrite rw2.
      rewrite fold_left_aux_lift.
      auto with *.
  Qed.

  Lemma summation_rw_app:
    forall l1 l2,
    summation (l1 ++ l2) = summation l1 + summation l2.
  Proof.
    intros l1.
    induction l1.
    { intros; auto. }
    intros.
    simpl.
    rewrite summation_rw_cons.
    rewrite summation_rw_cons.
    rewrite IHl1.
    auto with *.
  Qed.
End Sum.

Section OMap.
  Set Implicit Arguments.
  (** Defines an optional map function. *)
  Variable A:Type.

  Variable B:Type.

  Variable f : A -> option B.

  Definition omap l :=
    flat_map
    (fun x =>
      match f x with
      | Some x => cons x nil
      | None => nil
      end)
    l.

  Lemma in_omap_1:
    forall l x y,
    In x l ->
    f x = Some y ->
    In y (omap l).
  Proof.
    intros.
    unfold omap.
    rewrite in_flat_map.
    exists x.
    intuition.
    rewrite H0.
    auto using in_eq.
  Qed.

  Lemma in_omap_2:
    forall l y,
    In y (omap l) ->
    exists x, (In x l /\ f x = Some y).
  Proof.
    unfold omap.
    intros.
    rewrite in_flat_map in *.
    destruct H as (x, (Hin1, Hin2)).
    remember (f x).
    destruct o.
    - inversion Hin2.
      + subst.
        eauto.
      + inversion H.
    - inversion Hin2.
  Qed.

End OMap.

Section Remove.

  Lemma remove_length_lt:
    forall {A:Type} eq_dec l (x:A),
    length (remove eq_dec x l) <= length l.
  Proof.
    intros.
    induction l.
    - auto.
    - simpl.
      destruct (eq_dec _ _).
      + intuition.
      + simpl.
        intuition.
  Qed.

  Lemma remove_in_length_lt:
    forall {A:Type} eq_dec l (x:A),
    In x l ->
    length (remove eq_dec x l) < length l.
  Proof.
    induction l; intros.
    - inversion H.
    - simpl.
      destruct (eq_dec x a).
      + assert (length (remove eq_dec x l) <= length l) by eauto using remove_length_lt.
        intuition.
      + simpl.
        destruct H.
        * contradiction n; auto.
        * intuition.
  Qed.

  Lemma remove_incl:
    forall {A} eq_dec l (x:A),
    incl (remove eq_dec x l) l.
  Proof.
    unfold incl.
    intros.
    induction l.
    - inversion H.
    - simpl in *.
      destruct (eq_dec x a0).
      + intuition.
      + destruct H.
        * intuition.
        * eauto.
  Qed.

  Lemma remove_in:
    forall {A} eq_dec l (x y:A),
    In x (remove eq_dec y l) ->
    In x l.
  Proof.
    intros.
    induction l; auto.
    simpl in *.
    destruct (eq_dec _ _).
    - subst. auto.
    - destruct H; subst; auto.
  Qed.

  Lemma remove_in_neq:
    forall {A:Type} eq_dec l x,
    List.In x l ->
    forall (y:A),
    y <> x ->
    List.In x (remove eq_dec y l).
  Proof.
    intros.
    induction l.
    - inversion H.
    - simpl in *.
      destruct (eq_dec _ _).
      + subst.
        destruct H.
        * contradiction.
        * auto.
      + destruct H.
        * subst.
          auto using in_eq.
        * auto using in_cons.
  Qed.

  Lemma no_dup_remove:
    forall {A:Type} (l:list A),
    NoDup l ->
    forall (x:A) eq_dec,
    NoDup (remove eq_dec x l).
  Proof.
    induction l; intros; auto.
    inversion H; subst; clear H.
    simpl.
    destruct (eq_dec x a).
    - eauto.
    - apply NoDup_cons.
      + unfold not; intros.
        contradiction H2.
        eauto using remove_in.
      + eauto.
  Qed.

End Remove.

Section Incl.
  Variable A:Type.
Lemma incl_nil_nil:
  @incl A nil nil.
Proof.
  unfold incl.
  intros.
  inversion H.
Qed.

  Lemma incl_rw_nil:
    forall {A:Type} (l:list A),
    incl l nil ->
    l = nil.
  Proof.
    unfold incl.
    intros.
    destruct l; auto.
    assert (X: List.In a (a::l)) by auto using in_eq.
    apply H in X.
    inversion X.
  Qed.

Variable eq_dec : forall (v1 v2:A), {v1 = v2} + {v1 <> v2}.

Lemma incl_cons_eq:
  forall (a:A) l1 l2,
  In a l2 ->
  incl l1 (a :: l2) ->
  incl l1 l2.
Proof.
  intros.
  unfold incl.
  intros.
  destruct (eq_dec a a0).
  - subst; assumption.
  - unfold incl in H0.
    assert (H' := H0 a0); clear H0.
    apply H' in H1.
    inversion H1.
    subst. assumption.
    assumption.
Qed.

Lemma incl_absurd:
  forall (a:A) l,
  incl (a :: l) nil -> False.
Proof.
  intros.
  unfold incl in H.
  assert (Hx : In a (a::l)).
  apply in_eq.
  apply H in Hx.
  inversion Hx.
Qed.

Lemma incl_nil_any:
  forall (l:list A),
  incl nil l.
Proof.
  intros.
  unfold incl.
  intros.
  inversion H.
Qed.

Lemma incl_strengthten:
  forall (a:A) l1 l2,
  incl (a :: l1) l2 ->
  incl l1 l2.
Proof.
  intros.
  unfold incl in *.
  intros.
  assert (H1 := H a0).
  apply in_cons with (a:=a) in H0.
  apply H1 in H0; assumption.
Qed.

Lemma incl_cons_in:
  forall (a:A) l1 l2,
  incl (a :: l1) l2 ->
  In a l2.
Proof.
  intros.
  unfold incl in *.
  assert (Ha := H a).
  apply Ha.
  apply in_eq.
Qed.

Lemma incl_remove_1:
  forall l1 ll (a:A) lr,
  incl l1 (ll ++ a :: lr) ->
  ~ In a l1 ->
  incl l1 (ll ++ lr).
Proof.
  intros.
  unfold incl.
  intros.
  destruct (eq_dec a0 a).
  - subst; contradiction H0.
  - unfold incl in H.
    apply H in H1.
    rewrite in_app_iff in *.
    destruct H1.
    * auto.
    * inversion H1.
      intuition.
      symmetry in H2; apply n in H2; inversion H2. (* absurd *)
      auto.
Qed.

  Lemma incl_cons_cons:
    forall {A:Type} l l',
    incl l l' ->
    forall (x:A),
    incl (x :: l) (x :: l').
  Proof.
    intros.
    eauto using incl_cons, in_eq, incl_tl.
  Qed.

End Incl.

Section NoDup.

Variable A:Type.
Variable eq_dec : forall (v1 v2:A), {v1 = v2} + {v1 <> v2}.

Lemma NoDup_remove_3:
  forall (A : Type) (l l' : list A) (a : A),
  NoDup (l ++ a :: l') -> ~ In a l.
Proof.
  intros.
  induction l.
  - intuition.
  - simpl in *.
    intuition.
    subst.
    + inversion H.
      subst.
      rewrite in_app_iff in H2.
      intuition.
    + apply IHl.
      * inversion H.
        assumption.
      * assumption.
Qed.

Lemma NoDup_app:
  forall (A : Type) (l l' : list A),
  NoDup (l ++ l') ->
  NoDup l /\ NoDup l'.
Proof.
  intros.
  induction l.
  - simpl in H.
    intuition.
    apply NoDup_nil.
  - simpl in *.
    inversion H.
    subst.
    apply IHl in H3.
    clear IHl.
    destruct H3.
    intuition.
    apply NoDup_cons.
    + intuition.
    + assumption.
Qed.

Lemma NoDup_rewrite:
  forall (A : Type) (l l' : list A) (a : A),
  NoDup (l ++ a :: l') ->
  NoDup (a :: (l ++ l')).
Proof.
  intros.
  assert (Hx := H).
  apply NoDup_remove_1 in H.
  apply NoDup_remove_2 in Hx.
  apply NoDup_cons; repeat auto.
Qed.

  Lemma no_dup_cons_nil:
    forall {A:Type} (x:A),
    NoDup (x :: nil).
  Proof.
    intros.
    apply NoDup_cons.
    - intuition.
    - auto using NoDup_nil.
  Qed.

End NoDup.

Section Length.

Variable A:Type.
Variable eq_dec : forall (v1 v2:A), {v1 = v2} + {v1 <> v2}.

Lemma length_app:
  forall l (a:A) r,
  length (l ++ a :: r) = length (a :: (l ++ r)).
Proof.
  intros.
  induction l.
  - auto.
  - simpl in *.
    rewrite IHl.
    auto.
Qed.

Lemma no_dup_length_le:
  forall (l1:list A) l2,
  NoDup l1 ->
  NoDup l2 ->
  incl l1 l2 ->
  length l1 <= length l2.
Proof.
  intros.
  generalize H0; clear H0.
  generalize H1; clear H1.
  generalize l2.
  induction l1.
  - intros. auto with *.
  - intros.
    assert (In a l0).
    unfold incl in H1.
    apply H1.
    apply in_eq.
    apply in_split in H2.
    destruct H2 as (ll, (lr, Heq)).
    rewrite Heq.
    assert (length l1 <= length (ll ++ lr)).
    apply IHl1.
    + inversion H.
      assumption.
    + subst.
      apply incl_strengthten in H1.
      apply incl_remove_1 in H1; repeat auto.
      inversion H.
      assumption.
    + subst.
      apply NoDup_remove_1 with (a:=a);
      assumption.
    + rewrite length_app.
      simpl.
      apply Le.le_n_S.
      assumption.
Qed.
End Length.

Section Map.

  Lemma map_neq_nil:
    forall {A:Type} {B:Type} (l:list A) (f:A->B),
    l <> nil ->
    map f l <> nil.
  Proof.
    intuition.
    destruct l.
    - auto.
    - inversion H0.
  Qed.

End Map.

Section In.
  Lemma in_incl:
    forall {A:Type} (x:A) l l',
    incl l' l ->
    List.In x l' ->
    List.In x l.
  Proof.
    intros.
    unfold incl in *; auto.
  Qed.
End In.

Section App.
  Lemma in_app_split:
    forall {A} l (x:A),
    List.In x l ->
    exists l1 l2, l = l1 ++ (x :: l2).
  Proof.
    induction l; intros. {
      inversion H.
    }
    inversion H; subst; clear H. {
      exists nil; exists l.
      auto.
    }
    apply IHl in H0.
    destruct H0 as (l1, (l2, R)).
    subst.
    exists (a::l1).
    exists l2.
    auto.
  Qed.
End App.

Section Flip.
  Import Aniceto.Pair.

  Lemma in_map_flip_1:
    forall {A:Type} es (x y:A),
    List.In (x, y) (map flip es) ->
    List.In (y, x) es.
  Proof.
    intros.
    rewrite in_map_iff in *.
    destruct H as ((y',x'),(Hx,?)).
    simpl in *; inversion Hx; subst.
    assumption.
  Qed.

  Lemma in_map_flip_2:
    forall {A:Type} es (x y:A),
    List.In (x, y) es ->
    List.In (y, x) (map flip es).
  Proof.
    intros.
    rewrite in_map_iff in *.
    exists (x,y).
    auto.
  Qed.

  Lemma in_map_flip_iff:
    forall {A:Type} es (x y:A),
    List.In (x, y) (map flip es) <->
    List.In (y, x) es.
  Proof.
    intros.
    split; auto using in_map_flip_1, in_map_flip_2.
  Qed.

  Lemma map_flip_rw:
    forall {A:Type} {B:Type} (l:list (A*B)),
    map (@flip B A) (map (@flip A B) l) = l.
  Proof.
    induction l; intros; auto.
    simpl.
    rewrite flip_rw in *.
    rewrite IHl.
    trivial.
  Qed.

End Flip.

Section FindNotIn.
  Import Coq.Structures.OrderedType.

  Variable A:Type.

  Variable zero: A.
  Variable next: A -> A.
  Variable Lt : A -> A -> Prop.
  Variable lt_trans:
    forall x y z,
    Lt x y ->
    Lt y z ->
    Lt x z.
  Variable lt_irrefl:
    forall x,
    ~ Lt x x.

  Variable lt_comparable:
    forall x y, Compare Lt eq x y.

  Variable zero_is_smallest:
    forall x, ~ Lt x zero.

  Variable lt_next:
    forall x,
    Lt x (next x).

  Definition Supremum x := Forall (fun y : A => Lt y x).

  Let supremum_replace:
    forall l x z,
    Supremum x l ->
    Lt x z ->
    Supremum z l.
  Proof.
    unfold Supremum.
    intros.
    induction l. {
      auto using Forall_nil.
    }
    inversion H.
    eauto using Forall_cons.
  Qed.

  Let supremum_nil:
    forall x,
    Supremum x nil.
  Proof.
    unfold Supremum; auto.
  Qed.

  Let supremum_cons:
    forall x y l,
    Supremum x l ->
    Lt y x ->
    Supremum x (y :: l).
  Proof.
    unfold Supremum; auto using Forall_cons.
  Qed.

  Let supremum_cons_any:
    forall x l,
    Supremum x l ->
    forall z, exists w, Supremum w (z :: l).
  Proof.
    intros.
    destruct (lt_comparable x z); subst; eauto.
  Qed.

  Fixpoint supremum l :=
  match l with
  | nil => zero
  | z :: l =>
    match lt_comparable (supremum l) z with
    | LT _ => next z
    | EQ _ => next (supremum l)
    | GT _ => supremum l
    end
  end.

  Lemma supremum_spec:
    forall l,
    Supremum (supremum l) l.
  Proof.
    induction l; intros. {
      apply supremum_nil.
    }
    simpl.
    destruct (lt_comparable (supremum l) a).
    - assert (Supremum a l) by eauto.
      assert (Supremum (next a) l) by eauto.
      auto using supremum_cons.
    - subst.
      assert (Supremum (next (supremum l)) l) by eauto.
      auto.
    - auto.
  Qed.

  Lemma supremum_not_in:
    forall x l,
    Supremum x l ->
    ~ List.In x l.
  Proof.
    intros.
    unfold not; intros.
    induction l. {
      inversion H0.
    }
    destruct H0.
    - subst.
      inversion H; clear H.
      apply lt_irrefl in H2; auto.
    - inversion H; auto.
  Qed.

  Theorem find_not_in:
    forall l,
    ~ List.In (supremum l) l.
  Proof.
    intros.
    auto using supremum_spec, supremum_not_in.
  Qed.

End FindNotIn.

Section Partition.

  Lemma existsb_Forall:
    forall {A:Type} l (f:A->bool),
    existsb f l = false ->
    Forall (fun x => f x = false) l.
  Proof.
    intros.
    rewrite existsb_forallb in H.
    apply Bool.negb_false_iff in H.
    apply Forall_forallb in H.
    rewrite Forall_forall in *.
    intros.
    apply H in H0.
    apply Bool.Is_true_eq_true in H0.
    apply Bool.negb_true_iff in H0.
    assumption.
  Qed.

  (** Find a pivot according to a predicate [f] such that
      the predicate is false for a portion of the list. *)

  Lemma partition_snd:
    forall {A:Type} l f,
    Exists (fun x => f x = true) l ->
    (exists l1 l2 (x:A),
    l = l1 ++ x :: l2 /\
    f x = true /\
    List.Forall (fun y => f y = false) l2).
  Proof.
    induction l as [|y]; intros. {
      apply Exists_nil in H; contradiction.
    }
    inversion H; subst; clear H. {
      remember (existsb f l);
      symmetry in Heqb; destruct b. {
        apply existsb_Exists in Heqb.
        apply IHl in Heqb.
        destruct Heqb as (l1, (l2, (x, (?,(Hx,Hy))))).
        subst; clear IHl.
        exists (y::l1).
        exists l2.
        exists x.
        auto.
      }
      apply existsb_Forall in Heqb.
      exists nil.
      exists l.
      exists y.
      auto.
    }
    apply IHl in H1.
    destruct H1 as (l1, (l2, (x, (?,(Hx,Hy))))).
    subst; clear IHl.
    exists (y::l1).
    exists l2.
    exists x.
    auto.
  Qed.

  Lemma partition_fst:
    forall {A:Type} l f,
    Exists (fun x => f x = true) l ->
    (exists l1 l2 (x:A),
    l = l1 ++ x :: l2 /\
    f x = true /\
    List.Forall (fun y => f y = false) l1).
  Proof.
    induction l as [|y]; intros. {
      apply Exists_nil in H; contradiction.
    }
    inversion H; subst; clear H. {
      exists nil.
      simpl.
      eauto.
    }
    remember (f y).
    symmetry in Heqb; destruct b. {
      exists nil.
      simpl.
      eauto.
    }
    eapply IHl in H1; clear IHl.
    destruct H1 as (l1,(l2,(x,(?,(Hx,Hy))))).
    subst.
    exists (y::l1).
    simpl.
    exists l2.
    exists x.
    repeat split; auto using Forall_cons.
  Qed.

End Partition.

Section TailRecursiveMap.
  Import ListNotations.

  Variable A:Type.
  Variable B:Type.
  Variable f: A -> B.

  (**
   Tail recursive reverse, which is useful for performance sake.
   *)

  Definition rev_tr {A} (l:list A) := rev_append l nil.

  Lemma rev_tr_rw:
    forall {A} (l:list A),
    rev_tr l = rev l.
  Proof.
    intros.
    unfold rev_tr.
    rewrite rev_alt.
    trivial.
  Qed.

  (** Similar to List.rev_append this is the tail-recursive map application
    with an accumulator. *)

  Fixpoint tail_map (l:list A) a : list B := match l with
  | nil => a
  | h :: t => tail_map t (f h :: a)
  end.

  Lemma tail_map_rw:
    forall x l,
    tail_map x l = rev (map f x) ++ l.
  Proof.
    induction x; intros; simpl. {
      auto using app_nil_end.
    }
    rewrite IHx.
    rewrite <- app_assoc.
    rewrite <- app_comm_cons.
    simpl.
    trivial.
  Qed.

  (** Tail-recursive List.map equivalent. *)

  Definition map_tr l := rev_tr (tail_map l nil).

  Lemma map_tr_rw:
    forall l,
    map_tr l = map f l.
  Proof.
    intros.
    unfold map_tr.
    rewrite tail_map_rw.
    rewrite <- app_nil_end.
    rewrite rev_tr_rw.
    auto using rev_involutive.
  Qed.

  Fixpoint concat_append l a : list A :=
  match l with
  | nil => a
  | x::l => concat_append l (rev_append x a)
  end.

  Lemma concat_append_rw:
    forall l a,
    concat_append l a = rev (concat l) ++ a.
  Proof.
    induction l; intros; simpl; auto using app_nil_end.
    rewrite rev_append_rev.
    rewrite IHl, rev_app_distr.
    rewrite app_assoc.
    trivial.
  Qed.

  (** Tail-recursive [concat] *)

  Definition concat_tr l := rev_tr (concat_append l nil).

  Lemma concat_tr_rw:
    forall l,
    concat_tr l = concat l.
  Proof.
    intros; unfold concat_tr; simpl.
    rewrite rev_tr_rw in *.
    rewrite concat_append_rw.
    rewrite <- rev_involutive.
    rewrite <- app_nil_end.
    trivial.
  Qed.

End TailRecursiveMap.

Section TailRecursiveFlatMap.
  Import ListNotations.

  Variable A:Type.
  Variable B:Type.
  Variable f: A -> list B.

  (** Tail-recursive [flat_map]. *)

  Definition flat_map_tr l := concat_tr (map_tr f l).

  Lemma flat_map_tr_rw:
    forall l,
    flat_map_tr l = flat_map f l.
  Proof.
    intros.
    unfold flat_map_tr.
    rewrite concat_tr_rw, map_tr_rw, flat_map_concat_map.
    trivial.
  Qed.

End TailRecursiveFlatMap.

Section SplitTailRecursive.
  Import ListNotations.
  Variable A:Type.
  Variable B:Type.
  Fixpoint split_tail l a b : (list A * list B) :=
  match l with
  | [] => (a, b)
  | (x, y) :: l => split_tail l (x::a) (y::b)
  end.

  Lemma split_tail_rw:
    forall (l:list (A*B)) (a:list A) (b:list B),
    split_tail l a b = let (la, lb) := split l in (rev la ++ a, rev lb ++ b).
  Proof.
    induction l; intros; simpl; auto using app_nil_end.
    destruct a as (a1, b1); simpl.
    rewrite IHl.
    remember (split l) as m.
    destruct m as (la, lb).
    simpl.
    repeat rewrite app_assoc_reverse.
    simpl.
    trivial.
  Qed.

  Definition split_tr l := split_tail (rev l) [] [].

  Lemma split_app:
    forall (a:list (A*B)) b,
    let (la, lb) := split (a ++ b) in
    let (la1, lb1) := split a in
    let (la2, lb2) := split b in
    (la, lb) = (la1 ++ la2, lb1 ++ lb2).
  Proof.
    induction a; intros; simpl. {
      remember (split b) as l.
      destruct l as (l1, l2).
      trivial.
    }
    destruct a as (x,y).
    remember (split (a0++b)) as m.
    destruct m as (l1, l2).
    remember (split a0) as m.
    destruct m as (x1, y1).
    remember (split b) as m.
    destruct m as (x2, y2).
    simpl.
    assert (Hx := IHa b).
    rewrite <- Heqm in Hx.
    rewrite <- Heqm1 in Hx.
    inversion Hx; subst.
    trivial.
  Qed.

  Lemma split_rev:
    forall (l:list (A*B)),
    let (x, y) := split (rev l) in
    let (a, b) := split l in
    (rev a, rev b) = (x, y).
  Proof.
    induction l; intros; simpl; auto.
    assert (Hx := split_app (rev l) [a]).
    remember (split (rev l ++ [a])) as m.
    destruct m as (l1, l2).
    destruct a as (a1, b1).
    simpl in *.
    remember (split l) as m.
    destruct m as (l3, l4); simpl.
    remember (split (rev l)) as m.
    destruct m as (l5, l6).
    inversion Hx; subst.
    inversion IHl; subst.
    trivial.
  Qed.

  Lemma split_tr_rw:
    forall l,
    split_tr l = split l.
  Proof.
    intros.
    unfold split_tr.
    rewrite split_tail_rw.
    remember (split (rev l)) as m.
    destruct m as (la, lb).
    repeat rewrite <- app_nil_end.
    assert (Hx := split_rev l).
    rewrite <- Heqm in *.
    remember (split l) as m.
    destruct m as (l1, l2).
    inversion Hx; subst.
    repeat rewrite rev_involutive.
    trivial.
  Qed.

End SplitTailRecursive.

Section AppTailRecursive.
  Import ListNotations.
  Variable A:Type.

  Definition app_tr (a:list A) b := rev_append (rev a) b.

  Lemma app_tr_rw:
    forall a b,
    app_tr a b = app a b.
  Proof.
    induction a; intros; simpl; auto.
    unfold app_tr.
    rewrite rev_append_rev.
    rewrite rev_involutive.
    simpl.
    trivial.
  Qed.

End AppTailRecursive.


Require Import Iron.Language.SystemF2Data.Type.
Require Import Iron.Language.SystemF2Data.Exp.Lit.

(********************************************************************)
(* Primive operatos. *)
Inductive prim : Type :=
 (* Add two naturals. *)
 | PAdd    : prim

 (* Check whether a natural is zero. *)
 | PIsZero : prim.

(* Primitive operator definition.
   We keep the types of primops separate from the main typing judgement
   to make it easy to add new ones. *)
Inductive defprim : Type :=
 | DefPrim
   :  list ty    (* Types of the arguments. *)
   -> ty         (* Type  of the returned value. *)
   -> defprim.

(* Define the types of primops. *)
Fixpoint primDef (p : prim) : defprim :=
 match p with
 | PAdd      => DefPrim (TCon TyConNat :: TCon TyConNat :: nil) (TCon TyConNat)
 | PIsZero   => DefPrim (TCon TyConNat :: nil)                  (TCon TyConBool)
 end.

(********************************************************************)
(* The types of all primops are closed. *)
Lemma prim_types_closed
 :   forall p ts t
 ,   primDef p = DefPrim ts t
 ->  Forall closedT ts
  /\ closedT t.
Proof.
 intro.
 destruct p; snorm;
  try (solve [inverts H; nope]);
  try (solve [inverts H; eauto]).

 + inverts H.
   inverts H0. eauto.
   inverts H.  eauto.
   nope.

 + inverts H.
   inverts H0. eauto.
   inverts H.
Qed.
Hint Resolve prim_types_closed.

Lemma prim_types_closed_args
 :  forall p ts t
 ,  primDef p = DefPrim ts t
 -> Forall closedT ts.
Proof.
 intros. eapply prim_types_closed in H; rip.
Qed.
Hint Resolve prim_types_closed_args.

Lemma prim_types_closed_result
 :  forall p ts t
 ,  primDef p = DefPrim ts t
 -> closedT t.
Proof.
 intros. eapply prim_types_closed in H; rip.
Qed.
Hint Resolve prim_types_closed_result.


(** * RecordSub: Subtyping with Records *)

(** In this chapter, we combine two significant extensions of the pure
    STLC -- records (from chapter [Records]) and subtyping (from
    chapter [Sub]) -- and explore their interactions.  Most of the
    concepts have already been discussed in those chapters, so the
    presentation here is somewhat terse.  We just comment where things
    are nonstandard. *)

Require Import SF.SfLib.
Require Import SF.Maps.
Require Import SF.MoreStlc.

(* ###################################################### *)
(** * Core Definitions *)

(* ################################### *)
(** *** Syntax *)

Inductive ty : Type :=
  (* proper types *)
  | TTop   : ty
  | TBase  : id -> ty
  | TArrow : ty -> ty -> ty
  (* record types *)
  | TRNil : ty
  | TRCons : id -> ty -> ty -> ty.

Inductive tm : Type :=
  (* proper terms *)
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | tproj : tm -> id -> tm
  (* record terms *)
  | trnil :  tm
  | trcons : id -> tm -> tm -> tm.

(* ################################### *)
(** *** Well-Formedness *)

(** The syntax of terms and types is a bit too loose, in the sense
    that it admits things like a record type whose final "tail" is
    [Top] or some arrow type rather than [Nil].  To avoid such cases,
    it is useful to assume that all the record types and terms that we
    see will obey some simple well-formedness conditions.

    [An interesting technical question is whether the basic properties
    of the system -- progress and preservation -- remain true if we
    drop these conditions.  I believe they do, and I would encourage
    motivated readers to try to check this by dropping the conditions
    from the definitions of typing and subtyping and adjusting the
    proofs in the rest of the chapter accordingly.  This is not a
    trivial exercise (or I'd have done it!), but it should not involve
    changing the basic structure of the proofs.  If someone does do
    it, please let me know. --BCP 5/16.] *)

Inductive record_ty : ty -> Prop :=
  | RTnil :
        record_ty TRNil
  | RTcons : forall i T1 T2,
        record_ty (TRCons i T1 T2).

Inductive record_tm : tm -> Prop :=
  | rtnil :
        record_tm trnil
  | rtcons : forall i t1 t2,
        record_tm (trcons i t1 t2).

Inductive well_formed_ty : ty -> Prop :=
  | wfTTop :
        well_formed_ty TTop
  | wfTBase : forall i,
        well_formed_ty (TBase i)
  | wfTArrow : forall T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        well_formed_ty (TArrow T1 T2)
  | wfTRNil :
        well_formed_ty TRNil
  | wfTRCons : forall i T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        record_ty T2 ->
        well_formed_ty (TRCons i T1 T2).

Hint Constructors record_ty record_tm well_formed_ty.

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

(** Substitution and reduction are as before. *)

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar y => if beq_id x y then s else t
  | tabs y T t1 =>  tabs y T (if beq_id x y then t1
                             else (subst x s t1))
  | tapp t1 t2 => tapp (subst x s t1) (subst x s t2)
  | tproj t1 i => tproj (subst x s t1) i
  | trnil => trnil
  | trcons i t1 tr2 => trcons i (subst x s t1) (subst x s tr2)
  end.

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

(* ################################### *)
(** *** Reduction *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_rnil : value trnil
  | v_rcons : forall i v vr,
      value v ->
      value vr ->
      value (trcons i v vr).

Hint Constructors value.

Fixpoint Tlookup (i:id) (Tr:ty) : option ty :=
  match Tr with
  | TRCons i' T Tr' =>
      if beq_id i i' then Some T else Tlookup i Tr'
  | _ => None
  end.

Fixpoint tlookup (i:id) (tr:tm) : option tm :=
  match tr with
  | trcons i' t tr' =>
      if beq_id i i' then Some t else tlookup i tr'
  | _ => None
  end.

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

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         (tapp t1 t2) ==> (tapp t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         (tapp v1 t2) ==> (tapp v1  t2')
  | ST_Proj1 : forall tr tr' i,
        tr ==> tr' ->
        (tproj tr i) ==> (tproj tr' i)
  | ST_ProjRcd : forall tr i vi,
        value tr ->
        tlookup i tr = Some vi    ->
       (tproj tr i) ==> vi
  | ST_Rcd_Head : forall i t1 t1' tr2,
        t1 ==> t1' ->
        (trcons i t1 tr2) ==> (trcons i t1' tr2)
  | ST_Rcd_Tail : forall i v1 tr2 tr2',
        value v1 ->
        tr2 ==> tr2' ->
        (trcons i v1 tr2) ==> (trcons i v1 tr2')

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

Hint Constructors step.

(* ###################################################################### *)
(** * Subtyping *)

(** Now we come to the interesting part, where the features we've
    added start to interact.  We begin by defining the subtyping
    relation and developing some of its important technical
    properties. *)

(* ################################### *)
(** ** Definition *)

(** The definition of subtyping is essentially just what we sketched
    in the discussion of record subtyping in chapter [Sub], but we
    need to add well-formedness side conditions to some of the rules.
    Also, we replace the "n-ary" width, depth, and permutation
    subtyping rules by binary rules that deal with just the first
    field. *)

Reserved Notation "T '<:' U" (at level 40).

Inductive subtype : ty -> ty -> Prop :=
  (* Subtyping between proper types *)
  | S_Refl : forall T,
    well_formed_ty T ->
    T <: T
  | S_Trans : forall S U T,
    S <: U ->
    U <: T ->
    S <: T
  | S_Top : forall S,
    well_formed_ty S ->
    S <: TTop
  | S_Arrow : forall S1 S2 T1 T2,
    T1 <: S1 ->
    S2 <: T2 ->
    TArrow S1 S2 <: TArrow T1 T2
  (* Subtyping between record types *)
  | S_RcdWidth : forall i T1 T2,
    well_formed_ty (TRCons i T1 T2) ->
    TRCons i T1 T2 <: TRNil
  | S_RcdDepth : forall i S1 T1 Sr2 Tr2,
    S1 <: T1 ->
    Sr2 <: Tr2 ->
    record_ty Sr2 ->
    record_ty Tr2 ->
    TRCons i S1 Sr2 <: TRCons i T1 Tr2
  | S_RcdPerm : forall i1 i2 T1 T2 Tr3,
    well_formed_ty (TRCons i1 T1 (TRCons i2 T2 Tr3)) ->
    i1 <> i2 ->
       TRCons i1 T1 (TRCons i2 T2 Tr3)
    <: TRCons i2 T2 (TRCons i1 T1 Tr3)

where "T '<:' U" := (subtype T U).

Hint Constructors subtype.

(* ############################################### *)
(** ** Examples *)

Module Examples.

Notation x := (Id 0).
Notation y := (Id 1).
Notation z := (Id 2).
Notation j := (Id 3).
Notation k := (Id 4).
Notation i := (Id 5).
Notation A := (TBase (Id 6)).
Notation B := (TBase (Id 7)).
Notation C := (TBase (Id 8)).

Definition TRcd_j  :=
  (TRCons j (TArrow B B) TRNil).     (* {j:B->B} *)
Definition TRcd_kj :=
  TRCons k (TArrow A A) TRcd_j.      (* {k:C->C,j:B->B} *)

Example subtyping_example_0 :
  subtype (TArrow C TRcd_kj)
          (TArrow C TRNil).
(* C->{k:A->A,j:B->B} <: C->{} *)
Proof.
  apply S_Arrow.
    apply S_Refl. auto.
    unfold TRcd_kj, TRcd_j. apply S_RcdWidth; auto.
Qed.

(** The following facts are mostly easy to prove in Coq.  To get full
    benefit, make sure you also understand how to prove them on
    paper! *)

(** **** Exercise: 2 stars  *)
Example subtyping_example_1 :
  subtype TRcd_kj TRcd_j.
(* {k:A->A,j:B->B} <: {j:B->B} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star  *)
Example subtyping_example_2 :
  subtype (TArrow TTop TRcd_kj)
          (TArrow (TArrow C C) TRcd_j).
(* Top->{k:A->A,j:B->B} <: (C->C)->{j:B->B} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star  *)
Example subtyping_example_3 :
  subtype (TArrow TRNil (TRCons j A TRNil))
          (TArrow (TRCons k B TRNil) TRNil).
(* {}->{j:A} <: {k:B}->{} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars  *)
Example subtyping_example_4 :
  subtype (TRCons x A (TRCons y B (TRCons z C TRNil)))
          (TRCons z C (TRCons y B (TRCons x A TRNil))).
(* {x:A,y:B,z:C} <: {z:C,y:B,x:A} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

End Examples.

(* ###################################################################### *)
(** ** Properties of Subtyping *)

(** *** Well-Formedness *)

(** To get started proving things about subtyping, we need a couple of
    technical lemmas that intuitively (1) allow us to extract the
    well-formedness assumptions embedded in subtyping derivations
    and (2) record the fact that fields of well-formed record types
    are themselves well-formed types.  *)

Lemma subtype__wf : forall S T,
  subtype S T ->
  well_formed_ty T /\ well_formed_ty S.
Proof with eauto.
  intros S T Hsub.
  induction Hsub;
    intros; try (destruct IHHsub1; destruct IHHsub2)...
  - (* S_RcdPerm *)
    split... inversion H. subst. inversion H5...  Qed.

Lemma wf_rcd_lookup : forall i T Ti,
  well_formed_ty T ->
  Tlookup i T = Some Ti ->
  well_formed_ty Ti.
Proof with eauto.
  intros i T.
  induction T; intros; try solve by inversion.
  - (* TRCons *)
    inversion H. subst. unfold Tlookup in H0.
    destruct (beq_id i i0)...  inversion H0; subst...  Qed.

(** *** Field Lookup *)

(** The record matching lemmas get a little more complicated in the
    presence of subtyping, for two reasons.  First, record types no
    longer necessarily describe the exact structure of the
    corresponding terms.  And second, reasoning by induction on typing
    derivations becomes harder in general, because typing is no longer
    syntax directed. *)

Lemma rcd_types_match : forall S T i Ti,
  subtype S T ->
  Tlookup i T = Some Ti ->
  exists Si, Tlookup i S = Some Si /\ subtype Si Ti.
Proof with (eauto using wf_rcd_lookup).
  intros S T i Ti Hsub Hget. generalize dependent Ti.
  induction Hsub; intros Ti Hget;
    try solve by inversion.
  - (* S_Refl *)
    exists Ti...
  - (* S_Trans *)
    destruct (IHHsub2 Ti) as [Ui Hui]... destruct Hui.
    destruct (IHHsub1 Ui) as [Si Hsi]... destruct Hsi.
    exists Si...
  - (* S_RcdDepth *)
    rename i0 into k.
    unfold Tlookup. unfold Tlookup in Hget.
    destruct (beq_id i k)...
    + (* i = k -- we're looking up the first field *)
      inversion Hget. subst. exists S1...
  - (* S_RcdPerm *)
    exists Ti. split.
    + (* lookup *)
      unfold Tlookup. unfold Tlookup in Hget.
      destruct (beq_idP i i1)...
      * (* i = i1 -- we're looking up the first field *)
        destruct (beq_idP i i2)...
        (* i = i2 -- contradictory *)
        destruct H0.
        subst...
    + (* subtype *)
      inversion H. subst. inversion H5. subst...  Qed.

(** **** Exercise: 3 stars (rcd_types_match_informal)  *)
(** Write a careful informal proof of the [rcd_types_match]
    lemma. *)

(* FILL IN HERE *)
(** [] *)

(** *** Inversion Lemmas *)

(** **** Exercise: 3 stars, optional (sub_inversion_arrow)  *)
Lemma sub_inversion_arrow : forall U V1 V2,
     subtype U (TArrow V1 V2) ->
     exists U1, exists U2,
       (U=(TArrow U1 U2)) /\ (subtype V1 U1) /\ (subtype U2 V2).
Proof with eauto.
  intros U V1 V2 Hs.
  remember (TArrow V1 V2) as V.
  generalize dependent V2. generalize dependent V1.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################################### *)
(** * Typing *)

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 ->
      well_formed_ty T ->
      Gamma |- tvar x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      well_formed_ty T11 ->
      update Gamma x T11 |- t12 \in T12 ->
      Gamma |- tabs x T11 t12 \in TArrow T11 T12
  | T_App : forall T1 T2 Gamma t1 t2,
      Gamma |- t1 \in TArrow T1 T2 ->
      Gamma |- t2 \in T1 ->
      Gamma |- tapp t1 t2 \in T2
  | T_Proj : forall Gamma i t T Ti,
      Gamma |- t \in T ->
      Tlookup i T = Some Ti ->
      Gamma |- tproj t i \in Ti
  (* Subsumption *)
  | T_Sub : forall Gamma t S T,
      Gamma |- t \in S ->
      subtype S T ->
      Gamma |- t \in T
  (* Rules for record terms *)
  | T_RNil : forall Gamma,
      Gamma |- trnil \in TRNil
  | T_RCons : forall Gamma i t T tr Tr,
      Gamma |- t \in T ->
      Gamma |- tr \in Tr ->
      record_ty Tr ->
      record_tm tr ->
      Gamma |- trcons i t tr \in TRCons i T Tr

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

Hint Constructors has_type.

(* ############################################### *)
(** ** Typing Examples *)

Module Examples2.
Import Examples.

(** **** Exercise: 1 star  *)
Definition trcd_kj :=
  (trcons k (tabs z A (tvar z))
           (trcons j (tabs z B (tvar z))
                      trnil)).

Example typing_example_0 :
  has_type empty
           (trcons k (tabs z A (tvar z))
                     (trcons j (tabs z B (tvar z))
                               trnil))
           TRcd_kj.
(* empty |- {k=(\z:A.z), j=(\z:B.z)} : {k:A->A,j:B->B} *)
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars  *)
Example typing_example_1 :
  has_type empty
           (tapp (tabs x TRcd_j (tproj (tvar x) j))
                   (trcd_kj))
           (TArrow B B).
(* empty |- (\x:{k:A->A,j:B->B}. x.j)
              {k=(\z:A.z), j=(\z:B.z)}
         : B->B *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional  *)
Example typing_example_2 :
  has_type empty
           (tapp (tabs z (TArrow (TArrow C C) TRcd_j)
                           (tproj (tapp (tvar z)
                                            (tabs x C (tvar x)))
                                    j))
                   (tabs z (TArrow C C) trcd_kj))
           (TArrow B B).
(* empty |- (\z:(C->C)->{j:B->B}. (z (\x:C.x)).j)
              (\z:C->C. {k=(\z:A.z), j=(\z:B.z)})
           : B->B *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

End Examples2.

(* ###################################################################### *)
(** ** Properties of Typing *)

(** *** Well-Formedness *)

Lemma has_type__wf : forall Gamma t T,
  has_type Gamma t T -> well_formed_ty T.
Proof with eauto.
  intros Gamma t T Htyp.
  induction Htyp...
  - (* T_App *)
    inversion IHHtyp1...
  - (* T_Proj *)
    eapply wf_rcd_lookup...
  - (* T_Sub *)
    apply subtype__wf in H.
    destruct H...
Qed.

Lemma step_preserves_record_tm : forall tr tr',
  record_tm tr ->
  tr ==> tr' ->
  record_tm tr'.
Proof.
  intros tr tr' Hrt Hstp.
  inversion Hrt; subst; inversion Hstp; subst; eauto.
Qed.

(** *** Field Lookup *)

Lemma lookup_field_in_value : forall v T i Ti,
  value v ->
  has_type empty v T ->
  Tlookup i T = Some Ti ->
  exists vi, tlookup i v = Some vi /\ has_type empty vi Ti.
Proof with eauto.
  remember empty as Gamma.
  intros t T i Ti Hval Htyp. revert Ti HeqGamma Hval.
  induction Htyp; intros; subst; try solve by inversion.
  - (* T_Sub *)
    apply (rcd_types_match S) in H0...
    destruct H0 as [Si [HgetSi Hsub]].
    destruct (IHHtyp Si) as [vi [Hget Htyvi]]...
  - (* T_RCons *)
    simpl in H0. simpl. simpl in H1.
    destruct (beq_id i i0).
    + (* i is first *)
      inversion H1. subst. exists t...
    + (* i in tail *)
      destruct (IHHtyp2 Ti) as [vi [get Htyvi]]...
      inversion Hval...  Qed.

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

(** **** Exercise: 3 stars (canonical_forms_of_arrow_types)  *)
Lemma canonical_forms_of_arrow_types : forall Gamma s T1 T2,
     has_type Gamma s (TArrow T1 T2) ->
     value s ->
     exists x, exists S1, exists s2,
        s = tabs x S1 s2.
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

Theorem progress : forall t T,
     has_type empty t T ->
     value t \/ exists t', t ==> t'.
Proof with eauto.
  intros t T Ht.
  remember empty as Gamma.
  revert HeqGamma.
  induction Ht;
    intros HeqGamma; subst...
  - (* T_Var *)
    inversion H.
  - (* T_App *)
    right.
    destruct IHHt1; subst...
    + (* t1 is a value *)
      destruct IHHt2; subst...
      * (* t2 is a value *)
        destruct (canonical_forms_of_arrow_types empty t1 T1 T2)
          as [x [S1 [t12 Heqt1]]]...
        subst. exists ([x:=t2]t12)...
      * (* t2 steps *)
        destruct H0 as [t2' Hstp]. exists (tapp t1 t2')...
    + (* t1 steps *)
      destruct H as [t1' Hstp]. exists (tapp t1' t2)...
  - (* T_Proj *)
    right. destruct IHHt...
    + (* rcd is value *)
      destruct (lookup_field_in_value t T i Ti)
        as [t' [Hget Ht']]...
    + (* rcd_steps *)
      destruct H0 as [t' Hstp]. exists (tproj t' i)...
  - (* T_RCons *)
    destruct IHHt1...
    + (* head is a value *)
      destruct IHHt2...
      * (* tail steps *)
        right. destruct H2 as [tr' Hstp].
        exists (trcons i t tr')...
    + (* head steps *)
      right. destruct H1 as [t' Hstp].
      exists (trcons i t' tr)...  Qed.

(** _Theorem_ : For any term [t] and type [T], if [empty |- t : T]
    then [t] is a value or [t ==> t'] for some term [t'].

    _Proof_: Let [t] and [T] be given such that [empty |- t : T].  We
    proceed by induction on the given typing derivation.

      - The cases where the last step in the typing derivation is
        [T_Abs] or [T_RNil] are immediate because abstractions and
        [{}] are always values.  The case for [T_Var] is vacuous
        because variables cannot be typed in the empty context.

      - If the last step in the typing derivation is by [T_App], then
        there are terms [t1] [t2] and types [T1] [T2] such that [t =
        t1 t2], [T = T2], [empty |- t1 : T1 -> T2] and [empty |- t2 :
        T1].

        The induction hypotheses for these typing derivations yield
        that [t1] is a value or steps, and that [t2] is a value or
        steps.

        - Suppose [t1 ==> t1'] for some term [t1'].  Then [t1 t2 ==>
          t1' t2] by [ST_App1].

        - Otherwise [t1] is a value.

          - Suppose [t2 ==> t2'] for some term [t2'].  Then [t1 t2 ==>
            t1 t2'] by rule [ST_App2] because [t1] is a value.

          - Otherwise, [t2] is a value.  By Lemma
            [canonical_forms_for_arrow_types], [t1 = \x:S1.s2] for
            some [x], [S1], and [s2].  But then [(\x:S1.s2) t2 ==>
            [x:=t2]s2] by [ST_AppAbs], since [t2] is a value.

      - If the last step of the derivation is by [T_Proj], then there
        are a term [tr], a type [Tr], and a label [i] such that [t =
        tr.i], [empty |- tr : Tr], and [Tlookup i Tr = Some T].

        By the IH, either [tr] is a value or it steps.  If [tr ==>
        tr'] for some term [tr'], then [tr.i ==> tr'.i] by rule
        [ST_Proj1].

        If [tr] is a value, then Lemma [lookup_field_in_value] yields
        that there is a term [ti] such that [tlookup i tr = Some ti].
        It follows that [tr.i ==> ti] by rule [ST_ProjRcd].

      - If the final step of the derivation is by [T_Sub], then there
        is a type [S] such that [S <: T] and [empty |- t : S].  The
        desired result is exactly the induction hypothesis for the
        typing subderivation.

      - If the final step of the derivation is by [T_RCons], then
        there exist some terms [t1] [tr], types [T1 Tr] and a label
        [t] such that [t = {i=t1, tr}], [T = {i:T1, Tr}], [record_tm
        tr], [record_tm Tr], [empty |- t1 : T1] and [empty |- tr :
        Tr].

        The induction hypotheses for these typing derivations yield
        that [t1] is a value or steps, and that [tr] is a value or
        steps.  We consider each case:

        - Suppose [t1 ==> t1'] for some term [t1'].  Then [{i=t1, tr}
          ==> {i=t1', tr}] by rule [ST_Rcd_Head].

        - Otherwise [t1] is a value.

          - Suppose [tr ==> tr'] for some term [tr'].  Then [{i=t1,
            tr} ==> {i=t1, tr'}] by rule [ST_Rcd_Tail], since [t1] is
            a value.

          - Otherwise, [tr] is also a value.  So, [{i=t1, tr}] is a
            value by [v_rcons]. *)

(* ########################################## *)
(** *** Inversion Lemmas *)

Lemma typing_inversion_var : forall Gamma x T,
  has_type Gamma (tvar x) T ->
  exists S,
    Gamma x = Some S /\ subtype S T.
Proof with eauto.
  intros Gamma x T Hty.
  remember (tvar x) as t.
  induction Hty; intros;
    inversion Heqt; subst; try solve by inversion.
  - (* T_Var *)
    exists T...
  - (* T_Sub *)
    destruct IHHty as [U [Hctx HsubU]]... Qed.

Lemma typing_inversion_app : forall Gamma t1 t2 T2,
  has_type Gamma (tapp t1 t2) T2 ->
  exists T1,
    has_type Gamma t1 (TArrow T1 T2) /\
    has_type Gamma t2 T1.
Proof with eauto.
  intros Gamma t1 t2 T2 Hty.
  remember (tapp t1 t2) as t.
  induction Hty; intros;
    inversion Heqt; subst; try solve by inversion.
  - (* T_App *)
    exists T1...
  - (* T_Sub *)
    destruct IHHty as [U1 [Hty1 Hty2]]...
    assert (Hwf := has_type__wf _ _ _ Hty2).
    exists U1...  Qed.

Lemma typing_inversion_abs : forall Gamma x S1 t2 T,
     has_type Gamma (tabs x S1 t2) T ->
     (exists S2, subtype (TArrow S1 S2) T
              /\ has_type (update Gamma x S1) t2 S2).
Proof with eauto.
  intros Gamma x S1 t2 T H.
  remember (tabs x S1 t2) as t.
  induction H;
    inversion Heqt; subst; intros; try solve by inversion.
  - (* T_Abs *)
    assert (Hwf := has_type__wf _ _ _ H0).
    exists T12...
  - (* T_Sub *)
    destruct IHhas_type as [S2 [Hsub Hty]]...
    Qed.

Lemma typing_inversion_proj : forall Gamma i t1 Ti,
  has_type Gamma (tproj t1 i) Ti ->
  exists T, exists Si,
    Tlookup i T = Some Si /\ subtype Si Ti /\ has_type Gamma t1 T.
Proof with eauto.
  intros Gamma i t1 Ti H.
  remember (tproj t1 i) as t.
  induction H;
    inversion Heqt; subst; intros; try solve by inversion.
  - (* T_Proj *)
    assert (well_formed_ty Ti) as Hwf.
    { (* pf of assertion *)
      apply (wf_rcd_lookup i T Ti)...
      apply has_type__wf in H... }
    exists T. exists Ti...
  - (* T_Sub *)
    destruct IHhas_type as [U [Ui [Hget [Hsub Hty]]]]...
    exists U. exists Ui...  Qed.

Lemma typing_inversion_rcons : forall Gamma i ti tr T,
  has_type Gamma (trcons i ti tr) T ->
  exists Si, exists Sr,
    subtype (TRCons i Si Sr) T /\ has_type Gamma ti Si /\
    record_tm tr /\ has_type Gamma tr Sr.
Proof with eauto.
  intros Gamma i ti tr T Hty.
  remember (trcons i ti tr) as t.
  induction Hty;
    inversion Heqt; subst...
  - (* T_Sub *)
    apply IHHty in H0.
    destruct H0 as [Ri [Rr [HsubRS [HtypRi HtypRr]]]].
    exists Ri. exists Rr...
  - (* T_RCons *)
    assert (well_formed_ty (TRCons i T Tr)) as Hwf.
    { (* pf of assertion *)
      apply has_type__wf in Hty1.
      apply has_type__wf in Hty2... }
    exists T. exists Tr...  Qed.

Lemma abs_arrow : forall x S1 s2 T1 T2,
  has_type empty (tabs x S1 s2) (TArrow T1 T2) ->
     subtype T1 S1
  /\ has_type (update empty x S1) s2 T2.
Proof with eauto.
  intros x S1 s2 T1 T2 Hty.
  apply typing_inversion_abs in Hty.
  destruct Hty as [S2 [Hsub Hty]].
  apply sub_inversion_arrow in Hsub.
  destruct Hsub as [U1 [U2 [Heq [Hsub1 Hsub2]]]].
  inversion Heq; subst...  Qed.

(* ########################################## *)
(** *** Context Invariance *)

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_proj : forall x t i,
      appears_free_in x t ->
      appears_free_in x (tproj t i)
  | afi_rhead : forall x i t tr,
      appears_free_in x t ->
      appears_free_in x (trcons i t tr)
  | afi_rtail : forall x i t tr,
      appears_free_in x tr ->
      appears_free_in x (trcons i t tr).

Hint Constructors appears_free_in.

Lemma context_invariance : forall Gamma Gamma' t S,
     has_type Gamma t S  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x)  ->
     has_type Gamma' t S.
Proof with eauto.
  intros. generalize dependent Gamma'.
  induction H;
    intros Gamma' Heqv...
  - (* T_Var *)
    apply T_Var... rewrite <- Heqv...
  - (* T_Abs *)
    apply T_Abs... apply IHhas_type. intros x0 Hafi.
    unfold update, t_update. destruct (beq_idP x x0)...
  - (* T_App *)
    apply T_App with T1...
  - (* T_RCons *)
    apply T_RCons...  Qed.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   has_type Gamma t T ->
   exists T', Gamma x = Some T'.
Proof with eauto.
  intros x t T Gamma Hafi Htyp.
  induction Htyp; subst; inversion Hafi; subst...
  - (* T_Abs *)
    destruct (IHHtyp H5) as [T Hctx]. exists T.
    unfold update, t_update in Hctx.
    rewrite false_beq_id in Hctx...  Qed.

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

Lemma substitution_preserves_typing : forall Gamma x U v t S,
     has_type (update Gamma x U) t S  ->
     has_type empty v U   ->
     has_type Gamma ([x:=v]t) S.
Proof with eauto.
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent S. generalize dependent Gamma.
  induction t; intros; simpl.
  - (* tvar *)
    rename i into y.
    destruct (typing_inversion_var _ _ _ Htypt) as [T [Hctx Hsub]].
    unfold update, t_update in Hctx.
    destruct (beq_idP x y)...
    + (* x=y *)
      subst.
      inversion Hctx; subst. clear Hctx.
      apply context_invariance with empty...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra) as [T' HT']...
      inversion HT'.
    + (* x<>y *)
      destruct (subtype__wf _ _ Hsub)...
  - (* tapp *)
    destruct (typing_inversion_app _ _ _ _ Htypt)
      as [T1 [Htypt1 Htypt2]].
    eapply T_App...
  - (* tabs *)
    rename i into y. rename t into T1.
    destruct (typing_inversion_abs _ _ _ _ _ Htypt)
      as [T2 [Hsub Htypt2]].
    destruct (subtype__wf _ _ Hsub) as [Hwf1 Hwf2].
    inversion Hwf2. subst.
    apply T_Sub with (TArrow T1 T2)... apply T_Abs...
    destruct (beq_idP x y).
    + (* x=y *)
      eapply context_invariance...
      subst.
      intros x Hafi. unfold update, t_update.
      destruct (beq_id y x)...
    + (* x<>y *)
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold update, t_update.
      destruct (beq_idP y z)...
      subst.  rewrite false_beq_id...
  - (* tproj *)
    destruct (typing_inversion_proj _ _ _ _ Htypt)
      as [T [Ti [Hget [Hsub Htypt1]]]]...
  - (* trnil *)
    eapply context_invariance...
    intros y Hcontra. inversion Hcontra.
  - (* trcons *)
    destruct (typing_inversion_rcons _ _ _ _ _ Htypt) as
      [Ti [Tr [Hsub [HtypTi [Hrcdt2 HtypTr]]]]].
    apply T_Sub with (TRCons i Ti Tr)...
    apply T_RCons...
    + (* record_ty Tr *)
      apply subtype__wf in Hsub. destruct Hsub. inversion H0...
    + (* record_tm ([x:=v]t2) *)
      inversion Hrcdt2; subst; simpl...  Qed.

Theorem preservation : forall t t' T,
     has_type empty t T  ->
     t ==> t'  ->
     has_type empty t' T.
Proof with eauto.
  intros t t' T HT.
  remember empty as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  induction HT;
    intros t' HeqGamma HE; subst; inversion HE; subst...
  - (* T_App *)
    inversion HE; subst...
    + (* ST_AppAbs *)
      destruct (abs_arrow _ _ _ _ _ HT1) as [HA1 HA2].
      apply substitution_preserves_typing with T...
  - (* T_Proj *)
    destruct (lookup_field_in_value _ _ _ _ H2 HT H)
      as [vi [Hget Hty]].
    rewrite H4 in Hget. inversion Hget. subst...
  - (* T_RCons *)
    eauto using step_preserves_record_tm.  Qed.

(** _Theorem_: If [t], [t'] are terms and [T] is a type such that
     [empty |- t : T] and [t ==> t'], then [empty |- t' : T].

    _Proof_: Let [t] and [T] be given such that [empty |- t : T].  We go
     by induction on the structure of this typing derivation, leaving
     [t'] general.  Cases [T_Abs] and [T_RNil] are vacuous because
     abstractions and [{}] don't step.  Case [T_Var] is vacuous as well,
     since the context is empty.

     - If the final step of the derivation is by [T_App], then there
       are terms [t1] [t2] and types [T1] [T2] such that [t = t1 t2],
       [T = T2], [empty |- t1 : T1 -> T2] and [empty |- t2 : T1].

       By inspection of the definition of the step relation, there are
       three ways [t1 t2] can step.  Cases [ST_App1] and [ST_App2]
       follow immediately by the induction hypotheses for the typing
       subderivations and a use of [T_App].

       Suppose instead [t1 t2] steps by [ST_AppAbs].  Then
       [t1 = \x:S.t12] for some type [S] and term [t12], and
       [t' = [x:=t2]t12].

       By Lemma [abs_arrow], we have [T1 <: S] and [x:S1 |- s2 : T2].
       It then follows by lemma [substitution_preserves_typing] that
       [empty |- [x:=t2] t12 : T2] as desired.

     - If the final step of the derivation is by [T_Proj], then there
       is a term [tr], type [Tr] and label [i] such that [t = tr.i],
       [empty |- tr : Tr], and [Tlookup i Tr = Some T].

       The IH for the typing derivation gives us that, for any term
       [tr'], if [tr ==> tr'] then [empty |- tr' Tr].  Inspection of
       the definition of the step relation reveals that there are two
       ways a projection can step.  Case [ST_Proj1] follows
       immediately by the IH.

       Instead suppose [tr.i] steps by [ST_ProjRcd].  Then [tr] is a
       value and there is some term [vi] such that
       [tlookup i tr = Some vi] and [t' = vi].  But by lemma
       [lookup_field_in_value], [empty |- vi : Ti] as desired.

     - If the final step of the derivation is by [T_Sub], then there
       is a type [S] such that [S <: T] and [empty |- t : S].  The
       result is immediate by the induction hypothesis for the typing
       subderivation and an application of [T_Sub].

     - If the final step of the derivation is by [T_RCons], then there
       exist some terms [t1] [tr], types [T1 Tr] and a label [t] such
       that [t = {i=t1, tr}], [T = {i:T1, Tr}], [record_tm tr],
       [record_tm Tr], [empty |- t1 : T1] and [empty |- tr : Tr].

       By the definition of the step relation, [t] must have stepped
       by [ST_Rcd_Head] or [ST_Rcd_Tail].  In the first case, the
       result follows by the IH for [t1]'s typing derivation and
       [T_RCons].  In the second case, the result follows by the IH
       for [tr]'s typing derivation, [T_RCons], and a use of the
       [step_preserves_record_tm] lemma. *)

(** $Date: 2016-05-27 14:19:30 -0400 (Fri, 27 May 2016) $ *)