Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.orders MathClasses.theory.strong_setoids.

Lemma le_flip `{Le A} `{!TotalRelation (≤)} x y : ¬y ≤ x → x ≤ y.
Proof. firstorder. Qed.

Section partial_order.
  Context `{PartialOrder A}.

  Instance: Setoid A := po_setoid.

  Lemma eq_le x y : x = y → x ≤ y.
  Proof. intros E. now rewrite E. Qed.

  Lemma eq_le_flip x y : x = y → y ≤ x.
  Proof. intros E. now rewrite E. Qed.

  Lemma not_le_ne x y : ¬x ≤ y → x ≠ y.
  Proof. intros E1 E2. destruct E1. now rewrite E2. Qed.

  Lemma eq_iff_le x y : x = y ↔ x ≤ y ∧ y ≤ x.
  Proof. split; intros E. now rewrite E. now apply (antisymmetry (≤) x y). Qed.
End partial_order.

Section strict_order.
  Context `{StrictSetoidOrder A}.

  Instance: Setoid A := strict_setoid_order_setoid.

  Lemma lt_flip x y : x < y → ¬y < x.
  Proof.
    intros E1 E2.
    apply (irreflexivity (<) x).
    now transitivity y.
  Qed.

  Lemma lt_antisym x y : ¬(x < y < x).
  Proof.
    intros [E1 E2].
    now destruct (lt_flip x y).
  Qed.

  Lemma lt_ne x y : x < y → x ≠ y.
  Proof. unfold PropHolds. intros E1 E2. rewrite E2 in E1. now destruct (irreflexivity (<) y). Qed.

  Lemma lt_ne_flip x y : x < y → y ≠ x.
  Proof. intro. now apply not_symmetry, lt_ne. Qed.

  Lemma eq_not_lt x y : x = y → ¬x < y.
  Proof. intros E. rewrite E. now apply (irreflexivity (<)). Qed.
End strict_order.

Section pseudo_order.
  Context `{PseudoOrder A}.

  Instance: StrongSetoid A := pseudo_order_setoid.

  Lemma apart_total_lt x y : x ≶ y → x < y ∨ y < x.
  Proof. intros. now apply apart_iff_total_lt. Qed.

  Lemma pseudo_order_lt_apart x y : x < y → x ≶ y.
  Proof. intros. apply apart_iff_total_lt. tauto. Qed.

  Lemma pseudo_order_lt_apart_flip x y : x < y → y ≶ x.
  Proof. intros. apply apart_iff_total_lt. tauto. Qed.

  Lemma not_lt_apart_lt_flip x y : ¬x < y → x ≶ y → y < x.
  Proof. rewrite apart_iff_total_lt. intuition. Qed.

  Lemma pseudo_order_cotrans_twice x₁ y₁ x₂ y₂ : x₁ < y₁ → x₂ < y₂ ∨ x₁ < x₂ ∨ y₂ < y₁.
  Proof.
    intros E1.
    destruct (cotransitive E1 x₂) as [E2|E2]; try tauto.
    destruct (cotransitive E2 y₂); try tauto.
  Qed.

  Lemma pseudo_order_lt_ext x₁ y₁ x₂ y₂ : x₁ < y₁ → x₂ < y₂ ∨ x₁ ≶ x₂ ∨ y₂ ≶ y₁.
  Proof.
    intros E.
    destruct (pseudo_order_cotrans_twice x₁ y₁ x₂ y₂ E) as [?|[?|?]]; auto using pseudo_order_lt_apart.
  Qed.

  Instance: Proper ((=) ==> (=) ==> iff) (<).
  Proof.
    assert (∀ x₁ y₁ x₂ y₂, x₁ < y₁ → x₁ = x₂ → y₁ = y₂ → x₂ < y₂) as P.
     intros x₁ y₁ x₂ y₂ E Ex Ey.
     destruct (pseudo_order_lt_ext x₁ y₁ x₂ y₂ E) as [?|[?|?]]; try tauto.
      contradict Ex. now apply apart_ne.
     contradict Ey. now apply not_symmetry, apart_ne.
    split; intros; eapply P; eauto; now symmetry.
  Qed.

  Global Instance: StrictSetoidOrder (_ : Lt A).
  Proof.
    repeat (split; try apply _).
     intros x E.
     destruct (pseudo_order_antisym x x); tauto.
    intros x y z E1 E2.
    destruct (cotransitive E1 z); trivial.
    destruct (pseudo_order_antisym y z); tauto.
  Qed.

  Global Instance: Transitive (complement (<)).
  Proof.
    intros x y z.
    intros E1 E2 E3.
    destruct (cotransitive E3 y); contradiction.
  Qed.

  Global Instance: AntiSymmetric (complement (<)).
  Proof. intros x y. rewrite <-tight_apart, apart_iff_total_lt. intuition. Qed.

  Lemma ne_total_lt `{!TrivialApart A} x y : x ≠ y → x < y ∨ y < x.
  Proof. rewrite <-trivial_apart. now apply apart_total_lt. Qed.

  Global Instance lt_trichotomy `{!TrivialApart A} `{∀ x y, Decision (x = y)} : Trichotomy (<).
  Proof.
    intros x y.
    destruct (decide (x = y)) as [?|?]; try tauto.
    destruct (ne_total_lt x y); tauto.
  Qed.
End pseudo_order.

Section full_partial_order.
  Context `{FullPartialOrder A}.

  Instance: StrongSetoid A := strict_po_setoid.

  (* Duplicate of strong_setoids.apart_ne. This is useful because a
    StrongSetoid is not defined as a substructure of a FullPartialOrder *)
  Instance strict_po_apart_ne x y : PropHolds (x ≶ y) → PropHolds (x ≠ y).
  Proof. intros. apply _. Qed.

  Global Instance apart_proper: Proper ((=) ==> (=) ==> iff) (≶).
  Proof. apply _. Qed.

  Global Instance: StrictSetoidOrder (<).
  Proof.
    split; try apply _.
     intros x1 y1 E1 x2 y2 E2.
     rewrite ?lt_iff_le_apart.
     now rewrite E1, E2.
    split; try apply _.
    intros x. red. rewrite lt_iff_le_apart. intros [_ ?].
    now destruct (irreflexivity (≶) x).
  Qed.

  Lemma lt_le x y : PropHolds (x < y) → PropHolds (x ≤ y).
  Proof. intro. now apply lt_iff_le_apart. Qed.

  Lemma not_le_not_lt x y : ¬x ≤ y → ¬x < y.
  Proof. firstorder using lt_le. Qed.

  Lemma lt_apart x y : x < y → x ≶ y.
  Proof. intro. now apply lt_iff_le_apart. Qed.

  Lemma lt_apart_flip x y : x < y → y ≶ x.
  Proof. intro. now apply symmetry, lt_iff_le_apart. Qed.

  Lemma le_not_lt_flip x y : y ≤ x → ¬x < y.
  Proof.
    rewrite lt_iff_le_apart.
    intros E1 [E2a E2b].
    contradict E2b. setoid_replace x with y.
     now apply (irreflexivity _).
    now apply (antisymmetry (≤)).
  Qed.

  Lemma lt_not_le_flip x y : y < x → ¬x ≤ y.
  Proof.
    intros E1 E2.
    now destruct (le_not_lt_flip y x).
  Qed.

  Lemma lt_le_trans x y z : x < y → y ≤ z → x < z.
  Proof.
    rewrite !lt_iff_le_apart.
    intros [E1a E1b] E2.
    split.
     now transitivity y.
    destruct (cotransitive E1b z) as [E3 | E3]; trivial.
    apply lt_apart. symmetry in E3.
    transitivity y; rewrite lt_iff_le_apart; tauto.
  Qed.

  Lemma le_lt_trans x y z : x ≤ y → y < z → x < z.
  Proof.
    rewrite !lt_iff_le_apart.
    intros E2 [E1a E1b].
    split.
     now transitivity y.
    destruct (cotransitive E1b x) as [E3 | E3]; trivial.
    apply lt_apart. symmetry in E3.
    transitivity y; rewrite lt_iff_le_apart; tauto.
  Qed.

  Lemma lt_iff_le_ne `{!TrivialApart A} x y : x < y ↔ x ≤ y ∧ x ≠ y.
  Proof. rewrite <-trivial_apart. now apply lt_iff_le_apart. Qed.

  Lemma le_equiv_lt `{!TrivialApart A} `{∀ x y, Decision (x = y)} x y : x ≤ y → x = y ∨ x < y.
  Proof.
    intros. destruct (decide (x = y)); try tauto.
    right. rewrite lt_iff_le_ne; tauto.
  Qed.

  Program Instance dec_from_lt_dec `{!TrivialApart A} `{∀ x y, Decision (x ≤ y)} :
     ∀ x y, Decision (x = y) := λ x y,
    match decide_rel (≤) x y with
    | left E1 => match decide_rel (≤) y x with
       | left E2 => left _
       | right E2 => right _
       end
     | right E1 => right _
     end.
  Next Obligation. now apply (antisymmetry (≤)). Qed.
  Next Obligation. apply not_symmetry. now apply not_le_ne. Qed.
  Next Obligation. now apply not_le_ne. Qed.

  Definition lt_dec_slow `{!TrivialApart A} `{∀ x y, Decision (x ≤ y)} :
    ∀ x y, Decision (x < y).
  Proof.
    intros x y.
    destruct (decide (x ≤ y)).
     destruct (decide (x = y)).
      right. now apply eq_not_lt.
     left. apply lt_iff_le_ne; intuition.
    right. now apply not_le_not_lt.
  Defined.
End full_partial_order.

(* Due to bug #2528 *)
#[global]
Hint Extern 5 (PropHolds (_ ≠ _)) => eapply @strict_po_apart_ne :  typeclass_instances.
#[global]
Hint Extern 10 (PropHolds (_ ≤ _)) => eapply @lt_le : typeclass_instances.
#[global]
Hint Extern 20 (Decision (_ < _)) => eapply @lt_dec_slow : typeclass_instances.

Section full_pseudo_order.
  Context `{FullPseudoOrder A}.

  Instance: StrongSetoid A := pseudo_order_setoid.

  Lemma not_lt_le_flip x y : ¬y < x → x ≤ y.
  Proof. intros. now apply le_iff_not_lt_flip. Qed.

  Instance: PartialOrder (≤).
  Proof.
    split; try apply _.
      intros ? ? E1 ? ? E2.
      now rewrite !le_iff_not_lt_flip, E1, E2.
     split.
      intros x. apply not_lt_le_flip, (irreflexivity (<)).
     intros x y z.
     rewrite !le_iff_not_lt_flip.
     intros. change (complement (<) z x).
     now transitivity y.
    intros x y.
    rewrite !le_iff_not_lt_flip.
    intros E1 E2.
    now apply (antisymmetry (complement (<))).
  Qed.

  Global Instance: FullPartialOrder (_ : Le A) (_ : Lt A).
  Proof.
    split; try apply _.
    intros x y. rewrite !le_iff_not_lt_flip. split.
     intros E. split.
      now apply lt_flip.
     now apply pseudo_order_lt_apart.
    intros [? E].
    now apply not_lt_apart_lt_flip.
  Qed.

  Global Instance: ∀ x y, Stable (x ≤ y).
  Proof.
    intros x y. unfold Stable, DN.
    rewrite !le_iff_not_lt_flip. tauto.
  Qed.

  Lemma le_or_lt `{!TrivialApart A} `{∀ x y, Decision (x = y)} x y : x ≤ y ∨ y < x.
  Proof.
    destruct (trichotomy (<) x y) as [|[|]]; try tauto.
     left. now apply lt_le.
    left. now apply eq_le_flip.
  Qed.

  Global Instance le_total `{!TrivialApart A} `{∀ x y, Decision (x = y)} : TotalOrder (≤).
  Proof. split; try apply _. intros x y. destruct (le_or_lt x y). tauto. right. now apply lt_le. Qed.

  Lemma not_le_lt_flip `{!TrivialApart A} `{∀ x y, Decision (x = y)} x y : ¬y ≤ x → x < y.
  Proof. intros. destruct (le_or_lt y x); intuition. Qed.

  Existing Instance dec_from_lt_dec.

  Program Definition lt_dec `{!TrivialApart A} `{∀ x y, Decision (x ≤ y)} :
      ∀ x y, Decision (x < y) := λ x y,
    match decide_rel (≤) y x with
    | left E => right _
    | right E => left _
    end.
  Next Obligation. now apply le_not_lt_flip. Qed.
  Next Obligation. now apply not_le_lt_flip. Qed.
End full_pseudo_order.

#[global]
Hint Extern 8 (Decision (_ < _)) => eapply @lt_dec : typeclass_instances.
(*
The following instances would be tempting, but turn out to be a bad idea.

Hint Extern 10 (PropHolds (_ ≠ _)) => eapply @le_ne : typeclass_instances.
Hint Extern 10 (PropHolds (_ ≠ _)) => eapply @le_ne_flip : typeclass_instances.

It will then loop like:

semirings.lt_0_1 → lt_ne_flip → ...
*)

Section dec_strict_setoid_order.
  Context `{StrictSetoidOrder A} `{Apart A} `{!TrivialApart A} `{∀ x y, Decision (x = y)}.

  Instance: Setoid A := strict_setoid_order_setoid.
  Instance: StrongSetoid A := dec_strong_setoid.

  Context `{!Trichotomy (<)}.

  Instance dec_strict_pseudo_order: PseudoOrder (<).
  Proof.
    split; try apply _.
      intros x y [??]. destruct (lt_antisym x y); tauto.
     intros x y Exy z.
     destruct (trichotomy (<) x z) as [? | [Exz | Exz]]; try tauto.
      right. now rewrite <-Exz.
     right. now transitivity x.
    intros x y. rewrite trivial_apart. split.
     destruct (trichotomy (<) x y); intuition.
    intros [?|?]. now apply lt_ne. now apply lt_ne_flip.
  Qed.
End dec_strict_setoid_order.

Section dec_partial_order.
  Context `{PartialOrder A} `{∀ x y, Decision (x = y)}.

  Instance: Setoid A := po_setoid.
  Definition dec_lt: Lt A := λ x y, x ≤ y ∧ x ≠ y.

  Context `{Alt : Lt A} (lt_correct : ∀ x y, x < y ↔ x ≤ y ∧ x ≠ y).

  Instance dec_order: StrictSetoidOrder (<).
  Proof.
    split; try apply _.
     intros ? ? E1 ? ? E2.
     now rewrite !lt_correct, E1, E2.
    split; try apply _.
     intros x. red. rewrite lt_correct. now intros [_ []].
    intros x y z. rewrite !lt_correct. intros [E1a E1b] [E2a E2b].
    split.
     now transitivity y.
    intros E3. destruct E2b.
    apply (antisymmetry (≤)); trivial.
    now rewrite <-E3.
  Qed.

  Context `{Apart A} `{!TrivialApart A}.

  Instance: StrongSetoid A := dec_strong_setoid.

  Instance dec_full_partial_order: FullPartialOrder (≤) (<).
  Proof.
  constructor; try typeclasses eauto.
  setoid_rewrite trivial_apart; apply lt_correct.
  Qed.

  Context `{!TotalRelation (≤)}.

  Instance: Trichotomy (<).
  Proof.
    intros x y. rewrite !lt_correct.
    destruct (decide (x = y)); try tauto.
    destruct (total (≤) x y); intuition.
  Qed.

  Instance dec_pseudo_order: PseudoOrder (<).
  Proof dec_strict_pseudo_order.

  Instance dec_full_pseudo_order: FullPseudoOrder (≤) (<).
  Proof.
    split; try apply _.
    intros x y. rewrite lt_correct. split.
     intros ? [? []]. now apply (antisymmetry (≤)).
    intros E1.
    destruct (total (≤) x y); trivial.
    destruct (decide (x = y)) as [E2|E2].
     now rewrite E2.
    intuition.
  Qed.
End dec_partial_order.


Set Implicit Arguments.

Require Import List Omega Arith_base.
Require Import LibTactics.

Inductive ty : Type :=
  | var : nat -> ty
  | con : nat -> ty
  | app : ty -> ty -> ty.

Definition eq_ty_dec : forall (t t' : ty) , {t = t'} + {t <> t'}.
   pose eq_nat_dec.
   decide equality.
Defined.

Inductive leq_ty : ty -> ty -> Prop :=
  | leq_var : forall n t, leq_ty (var n) t
  | leq_con : forall n, leq_ty (con n) (con n)
  | leq_app : forall l l' r r', leq_ty l l' -> leq_ty r r' -> leq_ty (app l r) (app l' r').

Hint Constructors leq_ty.

Remark leq_ty_refl : forall t, leq_ty t t.
Proof.
  induction t ; auto.
Qed.

Remark leq_ty_trans : forall t t', leq_ty t t' -> forall t'', leq_ty t' t'' -> leq_ty t t''.
Proof.
  induction 1 ; intros ; auto ;
     match goal with
       | [H : leq_ty (app _ _) _ |- _] => inverts* H
       | [|- _] => idtac
     end.
Qed.

Hint Resolve leq_ty_refl leq_ty_trans.

Fixpoint fv (t : ty) : list nat :=
  match t with
    | var n => n :: nil
    | con n => nil
    | app l r => fv l ++ fv r
  end.

Definition max_list : forall (l : list nat), {n | forall n', In n' l -> n > n'}.
  refine (fix max_list (l : list nat) : {n | forall n', In n' l -> n > n'} :=
            match l with
              | nil => exist _ 0 _
              | x :: l' =>
                match max_list l' with
                  exist x' _ =>
                    match le_gt_dec x x' with
                      | left _ => exist _ (S x') _
                      | right _ => exist _ (S x) _
                    end
                end
            end) ; clear max_list  ; simpl in * ; intuition ;
                   try (match goal with
                          | [H : context[In _ _ -> _],
                             H1 : In _ _ |- _] => apply H in H1 ; try omega
                        end).
Defined.

Definition gen_list := list (ty * ty * nat)%type.

Definition lookup_phi : forall (t  t' : ty) (l : gen_list), {n | In (t,t',n) l} + {~ exists n, In (t,t',n) l}.
  refine (fix lookup_phi (t t' : ty)(l : gen_list) : {n | In (t,t',n) l} + {~ exists n, In (t,t',n) l} :=
            match l with
              | nil => inright _ _
              | (a,b,c) :: l' =>
                match eq_ty_dec t a, eq_ty_dec t' b with
                   | left _ , left _ => inleft _ (exist _ c _)
                   | _ , _           =>
                     match lookup_phi t t' l' with
                       | inleft (exist x _) => inleft _ (exist _ x _)
                       | inright _ => inright _ _
                     end
                end
            end) ; clear lookup_phi ; simpl in * ; intuition ; substs* ;
                   repeat
                       (match goal with
                         | [H : ex _ |- _] =>
                            let v := fresh "v" in destruct H as [v H]
                         | [H : _ = _ |- _] => inverts* H
                        end ; intuition) ; jauto.
Defined.

Definition least_gen (t t' t1 : ty) :=
  leq_ty t1 t /\ leq_ty t1 t' /\ forall u, leq_ty u t /\ leq_ty u t' -> leq_ty u t1.

Remark least_gen_refl : forall t, least_gen t t t.
Proof.
  induction t ; unfold least_gen in * ; intuition ; auto.
Qed.

Hint Resolve least_gen_refl.

Definition lgen_aux : forall (t t' : ty) (l : gen_list) (m : nat), {p | least_gen t t' (@fst ty (gen_list * nat) p)}.
  refine (fix lgen_aux (t t' : ty) (l : gen_list) (m : nat) : {p | least_gen t t' (@fst ty (gen_list * nat) p)} :=
      match t,t' with
        | con n, con n' =>
          match eq_nat_dec n n' with
            | left _ => exist _ (con n, (l, m)) _
            | right _ =>
                match lookup_phi t t' l with
                  | inleft (exist x _) => exist _ (var x, (l,m)) _
                  | inright _ => exist _ (var m, ((con n, con n',m) :: l, S m)) _
                end
          end
        | app f r, app f' r' =>
          match lgen_aux f f' l m with
            | exist v _ =>
              match lgen_aux r r' (fst (snd v)) (snd (snd v)) with
                | exist v' _ => exist _ (app (fst v) (fst v'), (fst (snd v') , snd (snd v'))) _
              end
          end
        | a, b =>
            match lookup_phi a b l with
               | inleft (exist x _) => exist _ (var x, (l,m)) _
               | inright _ => exist _ (var m, ((a, b, m) :: l, S m)) _
            end
      end)
   ; clear lgen_aux ; unfold least_gen in * ; simpl in * ; intuition ; substs ; eauto ;
     try repeat
         (match goal with
             | [H : leq_ty ?u (con ?n), H0 : leq_ty ?u (con ?n') |- _] => inverts* H ; inverts* H0 ; try contradiction
             | [H : leq_ty ?u (con _), H0 : leq_ty ?u (app _ _) |- _] => inverts* H ; inverts* H0
             | [H : (?n = ?n) -> False |- _] => elim H ; auto
             | [v : (ty * (gen_list * nat))%type |- _] => let va := fresh "va" in
                                                          let vb := fresh "vb" in
                                                          destruct v as [v [va vb]] ; simpl in *
             | [H : leq_ty ?u (app _ _), H' : leq_ty ?u (app _ _) |- _ ] =>
                   inverts* H6 ; inverts* H7 ; eauto
          end).
Defined.

Definition lgen (t t' : ty) : {t1 | least_gen t t' t1}.
   destruct (max_list (fv t ++ fv t')) as [v H].
   destruct (lgen_aux t t' nil v) as [[t1 [phi m]] Ht1].
   simpl in *. exists* t1.
Defined.

Fixpoint least_gen_list (t : ty) (l : list ty) : Prop :=
  match l with
    | nil => True
    | x :: l' => exists t', least_gen_list t' l' /\ least_gen x t' t
  end.

Definition lcg : forall (l : list ty), {t | least_gen_list t l} + {l = nil}.
   refine (fix lcg (l : list ty) : {t | least_gen_list t l} + {l = nil} :=
              match l return {t | least_gen_list t l} + {l = nil} with
                | nil => inright _ _
                | x :: l' =>
                    match lcg l' with
                      | inright _ => inleft _ (exist _ x _)
                      | inleft (exist y _)  =>
                          match lgen x y with
                            exist z _ => inleft _ (exist _ z _)
                          end
                    end
              end
          ) ; clear lcg ; repeat (unfold least_gen in * ; substs ; simpl in * ; intuition) ;
              try eexists ; splits ; eauto ; tauto.
Defined.


Require Export Basics.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Theorem andb_true_elim1 : forall b c : bool,
  andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true". (* <----- here *)
    reflexivity.
  Case "b = false". (* <---- and here *)
    rewrite <- H.
    reflexivity.
Qed.

Theorem mult_0_plus' : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.
  assert (H: 0 + n = n).
    Case "Proof of assertion". reflexivity.
  rewrite -> H.
  reflexivity.
Qed.

Lemma plus_help: forall n m: nat,
  S (n + m) = n + S m.
Proof.
  intros n m.
  induction n as [| n].
  Case "n = 0".
    simpl.
    reflexivity.
  Case "n = S n".
    simpl.
    rewrite -> IHn.
    reflexivity.
Qed.

Theorem plus_comm : forall n m : nat,
  n + m = m + n.
Proof.
  intros n m.
  induction n as [| n].
  Case "n = 0".
    simpl.
    rewrite <- plus_n_O.
    reflexivity.
  Case "n = S n".
    simpl.
    rewrite -> IHn.
    rewrite -> plus_help.
    reflexivity.
Qed.

Theorem plus_rearrange_firsttry : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  assert (H: n + m = m + n).
    Case "Proof of assertion".
    rewrite -> plus_comm.
    reflexivity.
  rewrite -> H.
  reflexivity.
Qed.

Theorem plus_n_O_secondtry : forall n:nat,
  n = n + 0.
Proof.
  intros n.
  induction n as [| n'].
  - reflexivity.
  - simpl.
    rewrite <- IHn'.
    reflexivity.
Qed.

Theorem minus_diag : forall n,
  minus n n = 0.
Proof.
  intros n.
  induction n as [| n'].
  - reflexivity.
  - simpl.
    rewrite -> IHn'.
    reflexivity.
Qed.


C02W82DBHV2R:~ i847419$ coqtop
Welcome to Coq 8.8.0 (April 2018)

Coq < Require Import Classical.

Coq < Theorem exp007 : (forall P Q : Prop, ((P /\ Q) /\ ~Q) -> ~P).
1 subgoal

  ============================
  forall P Q : Prop, (P /\ Q) /\ ~ Q -> ~ P

exp007 < intros.
1 subgoal

  P, Q : Prop
  H : (P /\ Q) /\ ~ Q
  ============================
  ~ P

exp007 < destruct H.
1 subgoal

  P, Q : Prop
  H : P /\ Q
  H0 : ~ Q
  ============================
  ~ P

exp007 < tauto.
No more subgoals.

exp007 < Qed.
exp007 is defined


(** * Poly: Polymorphism and Higher-Order Functions *)

(* REMINDER: Please do not put solutions to the exercises in
   publicly accessible places.  Thank you!! *)

Require Export Lists.

(* ###################################################### *)
(** * Polymorphism *)

(** In this chapter we continue our development of basic
    concepts of functional programming.  The critical new ideas are
    _polymorphism_ (abstracting functions over the types of the data
    they manipulate) and _higher-order functions_ (treating functions
    as data).  We begin with polymorphism. *)

(* ###################################################### *)
(** ** Polymorphic Lists *)

(** For the last couple of chapters, we've been working just
    with lists of numbers.  Obviously, interesting programs also need
    to be able to manipulate lists with elements from other types --
    lists of strings, lists of booleans, lists of lists, etc.  We
    _could_ just define a new inductive datatype for each of these,
    for example... *)

Inductive boollist : Type :=
  | bool_nil : boollist
  | bool_cons : bool -> boollist -> boollist.

(** ... but this would quickly become tedious, partly because we
    have to make up different constructor names for each datatype, but
    mostly because we would also need to define new versions of all
    our list manipulating functions ([length], [rev], etc.)  for each
    new datatype definition. *)

(** To avoid all this repetition, Coq supports _polymorphic_
    inductive type definitions.  For example, here is a _polymorphic
    list_ datatype. *)

Inductive list (X:Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.

Check list.
Check list bool.
(** This is exactly like the definition of [natlist] from the
    previous chapter, except that the [nat] argument to the [cons]
    constructor has been replaced by an arbitrary type [X], a binding
    for [X] has been added to the header, and the occurrences of
    [natlist] in the types of the constructors have been replaced by
    [list X].  (We can re-use the constructor names [nil] and [cons]
    because the earlier definition of [natlist] was inside of a
    [Module] definition that is now out of scope.)

    What sort of thing is [list] itself?  One good way to think
    about it is that [list] is a _function_ from [Type]s to
    [Inductive] definitions; or, to put it another way, [list] is a
    function from [Type]s to [Type]s.  For any particular type [X],
    the type [list X] is an [Inductive]ly defined set of lists whose
    elements are things of type [X]. *)

(** With this definition, when we use the constructors [nil] and
    [cons] to build lists, we need to tell Coq the type of the
    elements in the lists we are building -- that is, [nil] and [cons]
    are now _polymorphic constructors_.  Observe the types of these
    constructors: *)

Check nil.
(* ===> nil : forall X : Type, list X *)
Check nil nat.

Check nil bool.

Check cons.
(* ===> cons : forall X : Type, X -> list X -> list X *)

(** (Side note on notation: In .v files, the "forall" quantifier is
    spelled out in letters.  In the generated HTML files, [forall] is
    usually typeset as the usual mathematical "upside down A," but
    you'll see the spelled-out "forall" in a few places, as in the
    above comments.  This is just a quirk of typesetting: there is no
    difference in meaning.) *)

(** The "[forall X]" in these types can be read as an additional
    argument to the constructors that determines the expected types of
    the arguments that follow.  When [nil] and [cons] are used, these
    arguments are supplied in the same way as the others.  For
    example, the list containing [2] and [1] is written like this: *)

Check (cons nat 2 (cons nat 1 (nil nat))).
Check (cons bool true (cons bool false (nil bool))).

(** (We've written [nil] and [cons] explicitly here because we haven't
    yet defined the [ [] ] and [::] notations for the new version of
    lists.  We'll do that in a bit.) *)

(** We can now go back and make polymorphic versions of all the
    list-processing functions that we wrote before.  Here is [repeat],
    for example: *)

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.

Compute (repeat bool false 2).
Compute (repeat nat 3 2).

Compute (repeat (list nat) ( cons nat 1 (cons nat 3 (nil nat)) ) 2).

(** As with [nil] and [cons], we can use [repeat] by applying it
    first to a type and then to its list argument: *)

Example test_repeat1 :
  repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
Proof. reflexivity.  Qed.

(** To use [repeat] to build other kinds of lists, we simply
    instantiate it with an appropriate type parameter: *)

Example test_repeat2 :
  repeat bool false 1 = cons bool false (nil bool).
Proof. reflexivity.  Qed.

Module MumbleGrumble.

(** **** Exercise: 2 stars (mumble_grumble)  *)
(** Consider the following two inductively defined types. *)

Inductive mumble : Type :=
  | a : mumble
  | b : mumble -> nat -> mumble
  | c : mumble.

Inductive grumble (X:Type) : Type :=
  | d : mumble -> grumble X
  | e : X -> grumble X.

(** Which of the following are well-typed elements of [grumble X] for
    some type [X]?
      - [d (b a 5)]
      - [d mumble (b a 5)]
      - [d bool (b a 5)]
      - [e bool true]
      - [e mumble (b c 0)]
      - [e bool (b c 0)]
      - [c]
(* FILL IN HERE *)
*)
(** [] *)

End MumbleGrumble.

(* ###################################################### *)
(** *** Type Annotation Inference *)

(** Let's write the definition of [repeat] again, but this time we
    won't specify the types of any of the arguments. Will Coq still
    accept it? *)

Fixpoint repeat' X x count : list X :=
  match count with
  | 0        => nil X
  | S count' => cons X x (repeat' X x count')
  end.

(** Indeed it will.  Let's see what type Coq has assigned to [repeat']: *)

Check repeat'.
(* ===> forall X : Type, X -> nat -> list X *)
Check repeat.
(* ===> forall X : Type, X -> nat -> list X *)

(** It has exactly the same type type as [repeat].  Coq was able
    to use _type inference_ to deduce what the types of [X], [x], and
    [count] must be, based on how they are used.  For example, since
    [X] is used as an argument to [cons], it must be a [Type], since
    [cons] expects a [Type] as its first argument; matching [count]
    with [0] and [S] means it must be a [nat]; and so on.

    This powerful facility means we don't always have to write
    explicit type annotations everywhere, although explicit type
    annotations are still quite useful as documentation and sanity
    checks, so we will continue to use them most of the time.  You
    should try to find a balance in your own code between too many
    type annotations (which can clutter and distract) and too
    few (which forces readers to perform type inference in their heads
    in order to understand your code). *)

(* ###################################################### *)
(** *** Type Argument Synthesis *)

(** To we use a polymorphic function, we need to pass it one or
    more types in addition to its other arguments.  For example, the
    recursive call in the body of the [repeat] function above must
    pass along the type [X].  But since the second argument to
    [repeat] is an element of [X], it seems entirely obvious that the
    first argument can only be [X] -- why should we have to write it
    explicitly?

    Fortunately, Coq permits us to avoid this kind of redundancy.  In
    place of any type argument we can write the "implicit argument"
    [_], which can be read as "Please try to figure out for yourself
    what belongs here."  More precisely, when Coq encounters a [_], it
    will attempt to _unify_ all locally available information -- the
    type of the function being applied, the types of the other
    arguments, and the type expected by the context in which the
    application appears -- to determine what concrete type should
    replace the [_].

    This may sound similar to type annotation inference -- indeed, the
    two procedures rely on the same underlying mechanisms.  Instead of
    simply omitting the types of some arguments to a function, like

      repeat' X x count : list X :=

    we can also replace the types with [_]

      repeat' (X : _) (x : _) (count : _) : list X :=

    to tell Coq to attempt to infer the missing information.

    Using implicit arguments, the [count] function can be written
    like this: *)

Fixpoint repeat'' X x count : list X :=
  match count with
  | 0        => nil _
  | S count' => cons _ x (repeat'' _ x count')
  end.

(** In this instance, we don't save much by writing [_] instead of
    [X].  But in many cases the difference in both keystrokes and
    readability is nontrivial.  For example, suppose we want to write
    down a list containing the numbers [1], [2], and [3].  Instead of
    writing this... *)

Definition list123 :=
  cons nat 1 (cons nat 2 (cons nat 3 (nil nat))).

(** ...we can use argument synthesis to write this: *)

Definition list123' :=
  cons _ 1 (cons _ 2 (cons _ 3 (nil _))).

(* ###################################################### *)
(** *** Implicit Arguments *)

(** We can go further and even avoid writing [_]'s in most cases by
    telling Coq _always_ to infer the type argument(s) of a given
    function.  The [Arguments] directive specifies the name of the
    function (or constructor) and then lists its argument names, with
    curly braces around any arguments to be treated as implicit.  (If
    some arguments of a definition don't have a name, as is often the
    case for constructors, they can be marked with a wildcard pattern
    [_].) *)

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

(** Now, we don't have to supply type arguments at all: *)

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).

(** Alternatively, we can declare an argument to be implicit
    when defining the function itself, by surrounding it in curly
    braces.  For example: *)

Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0        => nil
  | S count' => cons x (repeat''' x count')
  end.

(** (Note that we didn't even have to provide a type argument to the
    recursive call to [repeat''']; indeed, it would be invalid to
    provide one!)

    We will use the latter style whenever possible, but we will
    continue to use use explicit [Argument] declarations for
    [Inductive] constructors.  The reason for this is that marking the
    parameter of an inductive type as implicit causes it to become
    implicit for the type itself, not just for its constructors.  For
    instance, consider the following alternative definition of the
    [list] type: *)

Inductive list' {X:Type} : Type :=
  | nil' : list'
  | cons' : X -> list' -> list'.

(** Because [X] is declared as implicit for the _entire_ inductive
    definition including [list'] itself, we now have to write just
    [list'] whether we are talking about lists of numbers or booleans
    or anything else, rather than [list' nat] or [list' bool] or
    whatever; this is a step too far. *)

(** Let's finish by re-implementing a few other standard list
    functions on our new polymorphic lists... *)

Fixpoint app {X : Type} (l1 l2 : list X)
             : (list X) :=
  match l1 with
  | nil      => l2
  | cons h t => cons h (app t l2)
  end.

Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil      => nil
  | cons h t => app (rev t) (cons h nil)
  end.

Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.

Example test_rev1 :
  rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).
Proof. reflexivity.  Qed.

Example test_rev2:
  rev (cons true nil) = cons true nil.
Proof. reflexivity.  Qed.

Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof. reflexivity.  Qed.

(** One small problem with declaring arguments [Implicit] is
    that, occasionally, Coq does not have enough local information to
    determine a type argument; in such cases, we need to tell Coq that
    we want to give the argument explicitly just this time.  For
    example, suppose we write this: *)

Fail Definition mynil := nil.

(** (The [Fail] qualifier that appears before [Definition] can be
    used with _any_ command, and is used to ensure that that command
    indeed fails when executed. If the command does fail, Coq prints
    the corresponding error message, but continues processing the rest
    of the file.)

    Here, Coq gives us an error because it doesn't know what type
    argument to supply to [nil].  We can help it by providing an
    explicit type declaration (so that Coq has more information
    available when it gets to the "application" of [nil]): *)

Definition mynil : list nat := nil.

(** Alternatively, we can force the implicit arguments to be explicit by
   prefixing the function name with [@]. *)

Check @nil.

Definition mynil' := @nil nat.

(** Using argument synthesis and implicit arguments, we can
    define convenient notation for lists, as before.  Since we have
    made the constructor type arguments implicit, Coq will know to
    automatically infer these when we use the notations. *)

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

(** Now lists can be written just the way we'd hope: *)

Definition list123''' := [1; 2; 3].

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

(** **** Exercise: 2 stars, optional (poly_exercises)  *)
(** Here are a few simple exercises, just like ones in the [Lists]
    chapter, for practice with polymorphism.  Complete the proofs below. *)

Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
Proof. intros X l. induction l as [| t h IHh].
 - reflexivity.
 - simpl. rewrite IHh; reflexivity.
Qed.

Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof. (* FILL IN HERE *)
  intros A l m n. induction l as [| h t IHt].
  - reflexivity.
  - simpl. rewrite IHt. reflexivity.
Qed.

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  (* FILL IN HERE *)
  intros X l1 l2. induction l1 as [| h t IHt].
  - reflexivity.
  - simpl. rewrite IHt. reflexivity.
Qed.

(** [] *)

(** **** Exercise: 2 stars, optional (more_poly_exercises)  *)
(** Here are some slightly more interesting ones... *)

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  (* FILL IN HERE *)
 intros X l1 l2. induction l1 as [| h t IHt].
  - simpl. rewrite app_nil_r. reflexivity.
  - simpl. rewrite IHt. rewrite app_assoc. reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  (* FILL IN HERE *)
  intros X l. induction l as [| h t IHt].
  - reflexivity.
  - simpl. rewrite rev_app_distr. rewrite IHt. reflexivity.
Qed.

(** [] *)

(* ###################################################### *)
(** ** Polymorphic Pairs *)

(** Following the same pattern, the type definition we gave in
    the last chapter for pairs of numbers can be generalized to
    _polymorphic pairs_, often called _products_: *)

Inductive prod (X Y : Type) : Type :=
| pair : X -> Y -> prod X Y.

Arguments pair {X} {Y} _ _.

(** As with lists, we make the type arguments implicit and define the
    familiar concrete notation. *)

Notation "( x , y )" := (pair x y).

(** We can also use the [Notation] mechanism to define the standard
    notation for product _types_: *)

Notation "X * Y" := (prod X Y) : type_scope.

(** (The annotation [: type_scope] tells Coq that this abbreviation
    should only be used when parsing types.  This avoids a clash with
    the multiplication symbol.) *)

(** It is easy at first to get [(x,y)] and [X*Y] confused.
    Remember that [(x,y)] is a _value_ built from two other values,
    while [X*Y] is a _type_ built from two other types.  If [x] has
    type [X] and [y] has type [Y], then [(x,y)] has type [X*Y]. *)

(** The first and second projection functions now look pretty
    much as they would in any functional programming language. *)

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) => x
  end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

(** The following function takes two lists and combines them
    into a list of pairs.  In other functional languages, it is often
    called [zip]; we call it [combine] for consistency with Coq's
    standard library. *)

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
           : list (X*Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x, y) :: (combine tx ty)
  end.

(** **** Exercise: 1 star, optional (combine_checks)  *)
(** Try answering the following questions on paper and
    checking your answers in coq:
    - What is the type of [combine] (i.e., what does [Check
      @combine] print?)
    - What does

        Compute (combine [1;2] [false;false;true;true]).

      print?   [] *)

Check @combine.
Compute (combine [1;2] [false;false;true;true]).

(** **** Exercise: 2 stars, recommended (\split)  *)
(** The function [split] is the right inverse of [combine]: it takes a
    list of pairs and returns a pair of lists.  In many functional
    languages, it is called [unzip].

    Uncomment the material below and fill in the definition of
    [split].  Make sure it passes the given unit test. *)

Fixpoint  {X Y : Type} (l : list (X*Y))
               : (list X) * (list Y) :=
(* FILL IN HERE *)
  match l with
  | nil => (nil, nil)
  | (x, y) :: t => (x :: fst (split t), y :: snd (split t))
  end.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof.
(* FILL IN HERE *)
reflexivity.
Qed.
(** [] *)

(* ###################################################### *)
(** ** Polymorphic Options *)

(** One last polymorphic type for now: _polymorphic options_,
    which generalize [natoption] from the previous chapter: *)

Inductive option (X:Type) : Type :=
  | Some : X -> option X
  | None : option X.

Arguments Some {X} _.
Arguments None {X}.

(** We can now rewrite the [nth_error] function so that it works
    with any type of lists. *)

Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | [] => None
  | a :: l' => if beq_nat n O then Some a else nth_error l' (pred n)
  end.

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.
Example test_nth_error2 : nth_error [[1];[2]] 1 = Some [2].
Proof. reflexivity. Qed.
Example test_nth_error3 : nth_error [true] 2 = None.
Proof. reflexivity. Qed.

(** **** Exercise: 1 star, optional (hd_error_poly)  *)
(** Complete the definition of a polymorphic version of the
    [hd_error] function from the last chapter. Be sure that it
    passes the unit tests below. *)

Definition hd_error {X : Type} (l : list X) : option X :=
  (* FILL IN HERE *)
  match l with
  | nil => None
  | h :: t => Some h
  end.

(** Once again, to force the implicit arguments to be explicit,
    we can use [@] before the name of the function. *)

Check @hd_error.

Example test_hd_error1 : hd_error [1;2] = Some 1.
 (* FILL IN HERE *)
Proof. reflexivity. Qed.
Example test_hd_error2 : hd_error  [[1];[2]]  = Some [1].
 (* FILL IN HERE *)
Proof. reflexivity. Qed.
(** [] *)

(* ###################################################### *)
(** * Functions as Data *)

(** Like many other modern programming languages -- including
    all functional languages (ML, Haskell, Scheme, Scala, Clojure,
    etc.) -- Coq treats functions as first-class citizens, allowing
    them to be passed as arguments to other functions, returned as
    results, stored in data structures, etc.*)

(* ###################################################### *)
(** ** Higher-Order Functions *)

(** Functions that manipulate other functions are often called
    _higher-order_ functions.  Here's a simple one: *)

Definition doit3times {X:Type} (f:X->X) (n:X) : X :=
  f (f (f n)).

(** The argument [f] here is itself a function (from [X] to
    [X]); the body of [doit3times] applies [f] three times to some
    value [n]. *)

Check @doit3times.
(* ===> doit3times : forall X : Type, (X -> X) -> X -> X *)

Definition minustwo (n : nat) : nat :=
  match n with
    | O => O
    | S O => O
    | S (S n') => n'
  end.
Print minustwo.

Example test_doit3times: doit3times minustwo 9 = 3.
Proof. reflexivity.  Qed.

Example test_doit3times': doit3times negb true = false.
Proof. reflexivity.  Qed.

(* ###################################################### *)
(** ** Filter *)

(** Here is a more useful higher-order function, taking a list
    of [X]s and a _predicate_ on [X] (a function from [X] to [bool])
    and "filtering" the list, returning a new list containing just
    those elements for which the predicate returns [true]. *)

Fixpoint filter {X:Type} (test: X->bool) (l:list X)
                : (list X) :=
  match l with
  | []     => []
  | h :: t => if test h then h :: (filter test t)
                        else       filter test t
  end.

(** For example, if we apply [filter] to the predicate [evenb]
    and a list of numbers [l], it returns a list containing just the
    even members of [l]. *)

Example test_filter1: filter evenb [1;2;3;4] = [2;4].
Proof. reflexivity.  Qed.

Definition length_is_1 {X : Type} (l : list X) : bool :=
  beq_nat (length l) 1.

Example test_filter2:
    filter length_is_1
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity.  Qed.

(** We can use [filter] to give a concise version of the
    [countoddmembers] function from the [Lists] chapter. *)
Definition oddb (n:nat) : bool   :=   negb (evenb n).

Definition countoddmembers' (l:list nat) : nat :=
  length (filter oddb l).

Example test_countoddmembers'1:   countoddmembers' [1;0;3;1;4;5] = 4.
Proof. reflexivity.  Qed.
Example test_countoddmembers'2:   countoddmembers' [0;2;4] = 0.
Proof. reflexivity.  Qed.
Example test_countoddmembers'3:   countoddmembers' nil = 0.
Proof. reflexivity.  Qed.

(* ###################################################### *)
(** ** Anonymous Functions *)

(** It is arguably a little sad, in the example just above, to
    be forced to define the function [length_is_1] and give it a name
    just to be able to pass it as an argument to [filter], since we
    will probably never use it again.  Moreover, this is not an
    isolated example: when using higher-order functions, we often want
    to pass as arguments "one-off" functions that we will never use
    again; having to give each of these functions a name would be
    tedious.

    Fortunately, there is a better way.  We can construct a function
    "on the fly" without declaring it at the top level or giving it a
    name. *)

Example test_anon_fun':
  doit3times (fun n => n * n) 2 = 256.
Proof. reflexivity.  Qed.

(** The expression [(fun n => n * n)] can be read as "the function
    that, given a number [n], yields [n * n]." *)

(** Here is the [filter] example, rewritten to use an anonymous
    function. *)

Example test_filter2':
    filter (fun l => beq_nat (length l) 1)
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity.  Qed.

(** **** Exercise: 2 stars (filter_even_gt7)  *)
(** Use [filter] (instead of [Fixpoint]) to write a Coq function
    [filter_even_gt7] that takes a list of natural numbers as input
    and returns a list of just those that are even and greater than
    7. *)
SearchAbout leb.
Definition filter_even_gt7 (l : list nat) : list nat :=
  (* FILL IN HERE *)
  filter (fun n => andb (evenb n) (leb 7 n)) l.

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
 (* FILL IN HERE *)
Proof. reflexivity.  Qed.

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
 (* FILL IN HERE *)
Proof. reflexivity.  Qed.

(** [] *)

(** **** Exercise: 3 stars (partition)  *)
(** Use [filter] to write a Coq function [partition]:

      partition : forall X : Type,
                  (X -> bool) -> list X -> list X * list X

   Given a set [X], a test function of type [X -> bool] and a [list
   X], [partition] should return a pair of lists.  The first member of
   the pair is the sublist of the original list containing the
   elements that satisfy the test, and the second is the sublist
   containing those that fail the test.  The order of elements in the
   two sublists should be the same as their order in the original
   list. *)

Definition partition {X : Type}
                     (test : X -> bool)
                     (l : list X)
                   : list X * list X :=
(* FILL IN HERE *)
  (filter test l, filter (fun a => negb (test a)) l).

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
(* FILL IN HERE *)
Proof. reflexivity. Qed.

Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
(* FILL IN HERE *)
Proof. reflexivity. Qed.
(** [] *)

(* ###################################################### *)
(** ** Map *)

(** Another handy higher-order function is called [map]. *)

Fixpoint map {X Y:Type} (f:X->Y) (l:list X) : (list Y) :=
  match l with
  | []     => []
  | h :: t => (f h) :: (map f t)
  end.

(** It takes a function [f] and a list [ l = [n1, n2, n3, ...] ]
    and returns the list [ [f n1, f n2, f n3,...] ], where [f] has
    been applied to each element of [l] in turn.  For example: *)

Example test_map1: map (fun x => plus 3 x) [2;0;2] = [5;3;5].
Proof. reflexivity.  Qed.

(** The element types of the input and output lists need not be
    the same, since [map] takes _two_ type arguments, [X] and [Y]; it
    can thus be applied to a list of numbers and a function from
    numbers to booleans to yield a list of booleans: *)

Example test_map2:
  map oddb [2;1;2;5] = [false;true;false;true].
Proof. reflexivity.  Qed.

(** It can even be applied to a list of numbers and
    a function from numbers to _lists_ of booleans to
    yield a _list of lists_ of booleans: *)

Example test_map3:
    map (fun n => [evenb n;oddb n]) [2;1;2;5]
  = [[true;false];[false;true];[true;false];[false;true]].
Proof. reflexivity.  Qed.

(** *** Exercises *)

(** **** Exercise: 3 stars (map_rev)  *)
(** Show that [map] and [rev] commute.  You may need to define an
    auxiliary lemma. *)

Lemma map_distr : forall (X Y : Type) (f : X -> Y) (l1 l2 : list X),
  map f (l1 ++ l2) = (map f l1) ++ (map f l2).
Proof. intros X Y f l1 l2. induction l1 as [| h t IHt].
  - reflexivity.
  - simpl. rewrite IHt. reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  (* FILL IN HERE *)
  intros X Y f l. induction l as [| h t IHt].
 - reflexivity.
 - simpl. rewrite <- IHt. rewrite map_distr. reflexivity.
Qed.

(** [] *)

(** **** Exercise: 2 stars, recommended (flat_map)  *)
(** The function [map] maps a [list X] to a [list Y] using a function
    of type [X -> Y].  We can define a similar function, [flat_map],
    which maps a [list X] to a [list Y] using a function [f] of type
    [X -> list Y].  Your definition should work by 'flattening' the
    results of [f], like so:

        flat_map (fun n => [n;n+1;n+2]) [1;5;10]
      = [1; 2; 3; 5; 6; 7; 10; 11; 12].

*)

Fixpoint flat_map {X Y:Type} (f:X -> list Y) (l:list X)
                   : (list Y) :=
  (* FILL IN HERE *)

  match l with
  | nil => nil
  | h :: t =>  (f h) ++ (flat_map f t)
  end.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
 (* FILL IN HERE *)
Proof. reflexivity. Qed.
(** [] *)

(** Lists are not the only inductive type that we can write a
    [map] function for.  Here is the definition of [map] for the
    [option] type: *)

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X)
                      : option Y :=
  match xo with
    | None => None
    | Some x => Some (f x)
  end.

(** **** Exercise: 2 stars, optional (implicit_args)  *)
(** The definitions and uses of [filter] and [map] use implicit
    arguments in many places.  Replace the curly braces around the
    implicit arguments with parentheses, and then fill in explicit
    type parameters where necessary and use Coq to check that you've
    done so correctly.  (This exercise is not to be turned in; it is
    probably easiest to do it on a _copy_ of this file that you can
    throw away afterwards.)  [] *)

(* ###################################################### *)
(** ** Fold *)

(** An even more powerful higher-order function is called
    [fold].  This function is the inspiration for the "[reduce]"
    operation that lies at the heart of Google's map/reduce
    distributed programming framework. *)

Fixpoint fold {X Y:Type} (f: X->Y->Y) (l:list X) (b:Y)
                         : Y :=
  match l with
  | nil => b
  | h :: t => f h (fold f t b)
  end.

(** Intuitively, the behavior of the [fold] operation is to
    insert a given binary operator [f] between every pair of elements
    in a given list.  For example, [ fold plus [1;2;3;4] ] intuitively
    means [1+2+3+4].  To make this precise, we also need a "starting
    element" that serves as the initial second input to [f].  So, for
    example,

       fold plus [1;2;3;4] 0

    yields

       1 + (2 + (3 + (4 + 0))).

    Some more examples: *)

Check (fold andb).
(* ===> fold andb : list bool -> bool -> bool *)

Example fold_example1 :
  fold mult [1;2;3;4] 1 = 24.
Proof. reflexivity. Qed.

Example fold_example2 :
  fold andb [true;true;false;true] true = false.
Proof. reflexivity. Qed.

Example fold_example3 :
  fold app  [[1];[];[2;3];[4]] [] = [1;2;3;4].
Proof. reflexivity. Qed.

(** **** Exercise: 1 star, advanced (fold_types_different)  *)
(** Observe that the type of [fold] is parameterized by _two_ type
    variables, [X] and [Y], and the parameter [f] is a binary operator
    that takes an [X] and a [Y] and returns a [Y].  Can you think of a
    situation where it would be useful for [X] and [Y] to be
    different? *)

(* ###################################################### *)
(** ** Functions That Construct Functions *)

(** Most of the higher-order functions we have talked about so
    far take functions as arguments.  Let's look at some examples that
    involve _returning_ functions as the results of other functions.
    To begin, here is a function that takes a value [x] (drawn from
    some type [X]) and returns a function from [nat] to [X] that
    yields [x] whenever it is called, ignoring its [nat] argument. *)

Definition constfun {X: Type} (x: X) : nat->X :=
  fun (k:nat) => x.

Definition ftrue := constfun true.

Example constfun_example1 : ftrue 0 = true.
Proof. reflexivity. Qed.

Example constfun_example2 : (constfun 5) 99 = 5.
Proof. reflexivity. Qed.

(** In fact, the multiple-argument functions we have already
    seen are also examples of passing functions as data.  To see why,
    recall the type of [plus]. *)

Check plus.
(* ==> nat -> nat -> nat *)

(** Each [->] in this expression is actually a _binary_ operator
    on types.  This operator is _right-associative_, so the type of
    [plus] is really a shorthand for [nat -> (nat -> nat)] -- i.e., it
    can be read as saying that "[plus] is a one-argument function that
    takes a [nat] and returns a one-argument function that takes
    another [nat] and returns a [nat]."  In the examples above, we
    have always applied [plus] to both of its arguments at once, but
    if we like we can supply just the first.  This is called _partial
    application_. *)

Definition plus3 := plus 3.
Check plus3.

Example test_plus3 :    plus3 4 = 7.
Proof. reflexivity.  Qed.
Example test_plus3' :   doit3times plus3 0 = 9.
Proof. reflexivity.  Qed.
Example test_plus3'' :  doit3times (plus 3) 0 = 9.
Proof. reflexivity.  Qed.

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

Module Exercises.

(** **** Exercise: 2 stars (fold_length)  *)
(** Many common functions on lists can be implemented in terms of
   [fold].  For example, here is an alternative definition of [length]: *)

Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.

Example test_fold_length1 : fold_length [4;7;0] = 3.
Proof. reflexivity. Qed.

(** Prove the correctness of [fold_length]. *)

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
(* FILL IN HERE *)
Proof. intros X l. induction l as [| h t IHt].
  - unfold fold_length. reflexivity.
  - unfold fold_length. simpl. unfold fold_length in IHt. rewrite IHt. reflexivity.
Qed.
(** [] *)

(** **** Exercise: 3 stars (fold_map)  *)
(** We can also define [map] in terms of [fold].  Finish [fold_map]
    below. *)

Definition fold_map {X Y:Type} (f : X -> Y) (l : list X) : list Y :=
(* FILL IN HERE *)
  fold (fun n => app [f n]) l nil.

(** Write down a theorem [fold_map_correct] in Coq stating that
   [fold_map] is correct, and prove it. *)

(* FILL IN HERE *)

Theorem fold_map_correct : forall X Y (f : X -> Y) (l : list X),
  fold_map f l = map f l.
Proof. intros X Y f l. induction l as [| h t IHt].
  - reflexivity.
  - unfold fold_map. simpl. rewrite <- IHt. unfold fold_map.
    unfold app. reflexivity.
Qed.

(** [] *)

(** **** Exercise: 2 stars, advanced (currying)  *)
(** In Coq, a function [f : A -> B -> C] really has the type [A
    -> (B -> C)].  That is, if you give [f] a value of type [A], it
    will give you function [f' : B -> C].  If you then give [f'] a
    value of type [B], it will return a value of type [C].  This
    allows for partial application, as in [plus3].  Processing a list
    of arguments with functions that return functions is called
    _currying_, in honor of the logician Haskell Curry.

    Conversely, we can reinterpret the type [A -> B -> C] as [(A *
    B) -> C].  This is called _uncurrying_.  With an uncurried binary
    function, both arguments must be given at once as a pair; there is
    no partial application. *)

(** We can define currying as follows: *)

Definition prod_curry {X Y Z : Type}
  (f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y).

(** As an exercise, define its inverse, [prod_uncurry].  Then prove
    the theorems below to show that the two are inverses. *)

Definition prod_uncurry {X Y Z : Type}
  (f : X -> Y -> Z) (p : X * Y) : Z :=
  (* FILL IN HERE *)
  f (fst p) (snd p).

(** As a trivial example of the usefulness of currying, we can use it
    to shorten one of the examples that we saw above: *)

Example test_map2: map (fun x => plus 3 x) [2;0;2] = [5;3;5].
Proof. reflexivity.  Qed.

(** Thought exercise: before running the following commands, can you
    calculate the types of [prod_curry] and [prod_uncurry]? *)

Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry : forall (X Y Z : Type)
                        (f : X -> Y -> Z)
                        x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
  (* FILL IN HERE *)
  intros X Y Z f x y. unfold prod_curry. unfold prod_uncurry. reflexivity.
Qed.

Lemma surjective_pairing : forall (X Y : Type) (p : X * Y),
  (fst p, snd p) = p.
Proof. destruct p as [p1 p2]. reflexivity. Qed.

Theorem curry_uncurry : forall (X Y Z : Type)
                        (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
  (* FILL IN HERE *)
  intros X Y Z f p. unfold prod_uncurry. unfold prod_curry.
  rewrite surjective_pairing. reflexivity.
Qed.
(** [] *)

(** **** Exercise: 2 stars, advanced (nth_error_informal)  *)
(** Recall the definition of the [nth_error] function:

   Fixpoint nth_error {X : Type} (l : list X) (n : nat) : option X :=
     match l with
     | [] => None
     | a :: l' => if beq_nat n O then Some a else nth_error l' (pred n)
     end.

   Write an informal proof of the following theorem:

   forall X n l, length l = n -> @nth_error X l n = None

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

(** **** Exercise: 4 stars, advanced (church_numerals)  *)
(** This exercise explores an alternative way of defining natural
    numbers, using the so-called _Church numerals_, named after
    mathematician Alonzo Church.  We can represent a natural number
    [n] as a function that takes a function [f] as a parameter and
    returns [f] iterated [n] times. *)

Module Church.
Definition nat := forall X : Type, (X -> X) -> X -> X.

(** Let's see how to write some numbers with this notation. Iterating
    a function once should be the same as just applying it.  Thus: *)

Definition one : nat :=
  fun (X : Type) (f : X -> X) (x : X) => f x.

(** Similarly, [two] should apply [f] twice to its argument: *)

Definition two : nat :=
  fun (X : Type) (f : X -> X) (x : X) => f (f x).

(** Defining [zero] is somewhat trickier: how can we "apply a function
    zero times"?  The answer is actually simple: just return the
    argument untouched. *)

Definition zero : nat :=
  fun (X : Type) (f : X -> X) (x : X) => x.

(** More generally, a number [n] can be written as [fun X f x => f (f
    ... (f x) ...)], with [n] occurrences of [f].  Notice in
    particular how the [doit3times] function we've defined previously
    is actually just the Church representation of [3]. *)

Definition three : nat := @doit3times.

(** Complete the definitions of the following functions. Make sure
    that the corresponding unit tests pass by proving them with
    [reflexivity]. *)

(** Successor of a natural number: *)

Definition succ (n : nat) : nat :=
  fun (X : Type) (f : X -> X) (x : X) => f (n _ f x).
  (* FILL IN HERE *)

Example succ_1 : succ zero = one.
Proof. (* FILL IN HERE *)
  unfold zero. unfold succ. unfold one. reflexivity.
Qed.

Example succ_2 : succ one = two.
Proof. (* FILL IN HERE *)
  unfold one; unfold succ; unfold two. reflexivity.
Qed.

Example succ_3 : succ two = three.
Proof. (* FILL IN HERE *)
  unfold two; unfold succ; unfold three. reflexivity.
Qed.

(** Addition of two natural numbers: *)

Definition plus (n m : nat) : nat :=
  (* FILL IN HERE *)
  fun (X : Type) (f : X -> X) (x : X) => n X f (m X f x).

Example plus_1 : plus zero one = one.
Proof. (* FILL IN HERE *)
  unfold plus; unfold zero; unfold one. reflexivity.
Qed.

Example plus_2 : plus two three = plus three two.
Proof. (* FILL IN HERE *)
  unfold plus; unfold two; unfold three;
  unfold doit3times. reflexivity.
Qed.

Example plus_3 :
  plus (plus two two) three = plus one (plus three three).
Proof. (* FILL IN HERE *)
  unfold plus; unfold two; unfold three; unfold one;
  unfold doit3times. reflexivity.
Qed.

(** Multiplication: *)

Definition mult (n m : nat) : nat :=
  (* FILL IN HERE *)
  fun (X : Type) (f : X -> X) => n X (m X f).

Example mult_1 : mult one one = one.
Proof. (* FILL IN HERE *)
  unfold mult; unfold one. reflexivity.
Qed.

Example mult_2 : mult zero (plus three three) = zero.
Proof. (* FILL IN HERE *)
  unfold mult; unfold zero; unfold plus; unfold three; unfold doit3times.
  reflexivity.
Qed.

Example mult_3 : mult two three = plus three three.
Proof. (* FILL IN HERE *)
  unfold mult; unfold two; unfold three; unfold doit3times; unfold plus.
  reflexivity.
Qed.

(** Exponentiation: *)

(** (_Hint_: Polymorphism plays a crucial role here.  However,
    choosing the right type to iterate over can be tricky.  If you hit
    a "Universe inconsistency" error, try iterating over a different
    type: [nat] itself is usually problematic.) *)

Definition exp (n m : nat) : nat :=
  (* FILL IN HERE *)
  fun (X : Type) => m _ (n _).

Example exp_1 : exp two two = plus two two.
Proof. (* FILL IN HERE *)
  unfold exp; unfold two; unfold plus; reflexivity.
Qed.

Example exp_2 : exp three two = plus (mult two (mult two two)) one.
Proof. (* FILL IN HERE *)
  unfold exp; unfold three; unfold doit3times; unfold plus; unfold mult;
  unfold two; unfold one; reflexivity.
Qed.

Example exp_3 : exp three zero = one.
Proof. (* FILL IN HERE *)
  unfold exp; unfold three; unfold doit3times; unfold zero; unfold one; reflexivity.
Qed.

End Church.
(** [] *)

End Exercises.

(** $Date: 2016-05-26 16:17:19 -0400 (Thu, 26 May 2016) $ *)


(*
Require Import MyUtils.
Require Import Atom.
Require Import List.
Require Import Metatheory.
*)

(*
Require Import Atom.
Require Import Metatheory.
*)
Require Import List.
Require Import Atom.

Notation "[]" := nil.
Notation "[ a ]" := (cons a nil).
Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..).
Infix "::" := cons.

Definition type_context := list nat.

Fixpoint type_lower (tc :type_context) : type_context :=
  match tc with
    | [] => []
    | n::t => match n with
                | 0 => type_lower t
                | S n' => n'::(type_lower t)
              end
  end.

(* typing derivations carry their terms with them *)
Inductive type : type_context -> Type :=
| type_top : type []
| type_var : forall n, type [n]
| type_arrow : forall L M, type L -> type M -> type (L++M)
| type_all : forall L, type L -> type (type_lower L)
| type_fp : forall L, type L -> type (type_lower L).
Implicit Arguments type_arrow [L M].
Implicit Arguments type_all [L].
Implicit Arguments type_fp [L].
Coercion type_var : nat >-> type.

Inductive post_type : Type :=
| post_type_top : post_type
| post_type_bvar

Inductive type_eq : forall C C', type C -> type C' -> Prop :=
| type_eq_top : type_eq [] [] type_top type_top
| type_eq_var : forall n n', type_eq [n] [n'] (type_var n) (type_var n')
| type_eq_arrow : forall L M A B L' M' A' B',
  type_eq L L' A A' ->
  type_eq M M' B B' ->
  type_eq (L++M) (L'++M') (type_arrow A B) (type_arrow A' B')
| type_eq_all : forall L L' A A',
  type_eq L L' A A' ->
  type_eq (type_lower L) (type_lower L') (type_all A) (type_all A')
| type_eq_fp : forall L L' A A',
  type_eq L L' A A' ->
  type_eq (type_lower L) (type_lower L') (type_fp A) (type_fp A').

Import Arith.
Check eq_nat_dec.
Definition remove_nat (n:nat) (l:list nat) := remove eq_nat_dec n l.
Hint Unfold remove_nat.
Notation "L // k" := (remove_nat k L) (at level 62).

Lemma cons_distr : forall a L k, (a :: L // k) = ([a] // k) ++ L // k.
Proof.
  intros. unfold remove_nat.
  case_eq (a===k). intros. rewrite e. simpl.
  case_eq (k===k). unfold app. auto.
  intros. simpl. rewrite H0. auto.
  intros. simpl.
  case_eq (k===a). intros. simpl. auto.
  intros. simpl. rewrite H0. auto.
Defined.

Lemma append_distr : forall L M k, (L // k) ++ (M // k) = (L ++ M // k).
Proof.
  induction L. simpl. auto.
  intros.
  rewrite <- app_comm_cons.
  rewrite cons_distr. simpl.
  case_eq (k===a). intros. simpl. apply IHL.
  intros. simpl. rewrite H. simpl. f_equal. apply IHL.
Defined.

Lemma lower_open : forall L k, type_lower (L // (S k)) = type_lower L // k.
Proof.
  intros. induction L. simpl. auto.
  simpl. destruct a. simpl. auto.
  simpl. case_eq (k===a).
  intros. simpl. auto.
  intros. simpl. f_equal. auto.
Defined.

Lemma lower_zero : forall L, type_lower (L // 0) = type_lower L.
Proof.
  intros. induction L. simpl. auto.
  simpl. destruct a. auto. simpl. f_equal. auto.
Defined.

Definition type_open_rec (TC:type_context) (k : nat) (u : type []) (T : type TC) : type (TC//k).
Proof.
  refine
    (fix type_open_rec (TC:type_context) (k : nat) (u : type []) (T : type TC) {struct T} : type (TC//k) :=
      match T in type M return type (M//k) with
        | type_top => type_top
        | type_fvar x => type_fvar x
        | type_bvar i =>
          match k === i with
            | left Hl => _
            | right Hr => _
          end
        | type_arrow L M T1 T2 => _
        | type_prod L M T1 T2 => _
        | type_sum L M T1 T2 => _
        | type_all L T' => _
        | type_fp L T' => _
      end).
  (* bvar *)
  subst ; unfold remove_nat ; unfold remove ;
    case_eq (i===i) ; intros ; auto ; intros ; absurd (i=i) ; auto.
  unfold remove_nat ; unfold remove ;
    case_eq (i===k) ; intros ; auto. rewrite e. destruct (k===k). auto.
  rewrite e in Hr. cut (k=k). intros. apply Hr in H0. inversion H0. auto.
    case_eq (k===i) ; intros. auto.
    apply type_bvar.
  (* arrow *)
    rewrite <- append_distr.
    eapply type_arrow ; apply type_open_rec ; auto.
  (* prod *)
    rewrite <- append_distr.
    eapply type_prod ; apply type_open_rec ; auto.
  (* sum *)
    rewrite <- append_distr.
    eapply type_sum ; apply type_open_rec ; auto.
  (* all *)
    rewrite <- lower_open.
    eapply type_all. apply type_open_rec. auto. auto.
  (* fp *)
    rewrite <- lower_open.
    eapply type_all. apply type_open_rec. auto. auto.
Defined.
Implicit Arguments type_open_rec [TC].

Print type_open_rec.
Print eq_rec.

(*
Definition lower_roll TC : type (type_lower TC // 0) ->  type (type_lower TC).
Proof.
  intros. rewrite <- lower_zero. auto.
*)

Definition type_open : type [0] -> type [] -> type [].
Proof.
  intros A u. apply (type_open_rec 0 u A).
Defined.

Inductive typ : Type :=
| typ_base : forall L, type L -> typ.

Definition context := list (nat * typ)%type.

Fixpoint lower (c : context) : context :=
  match c with
    | [] => []
    | (n,T)::t => match n with
                    | 0 => lower t
                    | S n' => (n',T)::(lower t)
                  end
  end.

Inductive term : forall TC, context -> type TC -> Type :=
| unit : term [] [] type_top
| fvar : forall TC A, atom -> term TC [] A
| bvar : forall TC (A :type TC) n, term TC [(n,(typ_base TC A))] A
| abs : forall TC1 TC2 A B L,
  term TC2 L B ->
  term (TC1++TC2) (lower L) (type_arrow A B)
| fp : forall TC L A, term TC L A -> term TC L A
| app : forall TC1 TC2 L1 L2 A B,
  term (TC1++TC2) L1 (type_arrow A B) ->
  term TC1 L2 A ->
  term TC2 (L1++L2) B
| splt : forall TC1 TC2 TC3 L1 L2 A B C,
  term (TC1++TC2) L1 (type_prod A B) ->
  term (TC1++TC2++TC3) L2 (type_arrow A (type_arrow B C)) ->
  term TC3 (L1++L2) C
| prod : forall TC1 TC2 L1 L2 A B,
  term TC1 L1 A ->
  term TC2 L2 B ->
  term (TC1++TC2) (L1++L2) (type_prod A B)
| inl : forall TC1 TC2 L A B,
  term TC1 L A ->
  term (TC1++TC2) L (type_sum A B)
| inr : forall TC1 TC2 L A B,
  term TC2 L B ->
  term (TC1++TC2) L (type_sum A B)
| cas : forall TC1 TC2 TC3 L1 L2 L3 A B C,
  term (TC1++TC2) L1 (type_sum A B) ->
  term (TC1++TC3) L2 (type_arrow A C) ->
  term (TC2++TC3) L3 (type_arrow B C) ->
  term ((TC1++TC2)++TC3) (L1++L2++L3) (type_arrow (type_sum A B) C)
(* type folding/unfolding isomorphism *)
| unroll : forall A L,
  term (type_lower [0]) L (type_fp A) ->
  term [] L (type_open A (type_fp A))
| roll : forall A L,
  term [] L (type_open A (type_fp A)) ->
  term (type_lower [0]) L (type_fp A)
(* type abstraction and application *)
| abst : forall TC L A,
  term (type_lower TC) L (type_all A)
| appt : forall L A,
  term (type_lower [0]) L (type_all A) ->
  forall (B : type []),
    term [] L (type_open A B).

(*
Implicit Arguments fvar [TC].
Implicit Arguments bvar [TC].
Implicit Arguments abs [TC1 TC2 L B].
Implicit Arguments
Implicit Arguments fp [TC L A].
Implicit Arguments app [TC1 TC2 L1 L2 A B].
Implicit Arguments splt [TC1 TC2 TC3 L1 L2 A B C].
Implicit Arguments prod [TC1 TC2 L1 L2 A B].
Implicit Arguments inl [TC1 L A].
Implicit Arguments inr [TC2 L B].
Implicit Arguments cas [TC1 TC2 TC3 L1 L2 L3 A B C].
Implicit Arguments unroll [A L].
Implicit Arguments roll [A L].
*)
Notation "'T" := type_top (at level 60).
Infix "||" := type_sum.
Infix "**" := type_prod (at level 60).
Infix "-->" := type_arrow (at level 61).
Notation "'All E" := (type_all E) (at level 62).
Notation "'Rec E" := (type_fp E) (at level 62).

Definition Nat := 'Rec ('T || 0) : type [].
Definition List := 'All ('Rec ('T || (1 ** 0))) : type [].

Definition term_eq_dec : forall T L A (t t' : term T L A), {t = t'} + {t <> t'}.
Proof.
  destruct t.
  simpl.
  induction t. intros.
  induction t ; induction t'.
  decide equality. auto with arith. auto using eq_atom_dec.
Defined.

Eval compute in (3 + 5).

Fixpoint fv (t:term) :=
  match t with
    | bvar n => {}
    | fvar a => singleton a
    | abs t' => fv t'
    | fp t' => fv t'
    | app m n => (fv m) `union` (fv n)
    | proj1 t' => fv t'
    | proj2 t' => fv t'
    | prod m n => (fv m) `union` (fv n)
    | inl l => fv l
    | inr r => fv r
    | unit => {}
    | cas x l r => (fv x) `union` (fv l) `union` (fv r)
  end.

Fixpoint subst (z : atom) (u : term) (e : term) {struct e} : term :=
  match e with
    | bvar i => bvar i
    | fvar v => if v == z then u else (fvar v)
    | proj1 t' => proj1 (subst z u t')
    | proj2 t' => proj2 (subst z u t')
    | abs e1 => abs (subst z u e1)
    | app e1 e2 => app (subst z u e1) (subst z u e2)
    | prod e1 e2 => prod (subst z u e1) (subst z u e2)
    | inl l => inl (subst z u l)
    | inr r => inr (subst z u r)
    | cas e e1 e2 =>
      cas (subst z u e) (subst z u e1) (subst z u e2)
    | fp e1 => fp (subst z u e1)
    | unit => unit
  end.

Notation "[ z ~> u ] e" := (subst z u e) (at level 68).

(* replace a bvar with a term *)
Fixpoint open_rec (k : nat) (u : term) (e : term) {struct e} : term :=
  match e with
    | bvar i => if k === i then u else (bvar i)
    | fvar x => fvar x
    | abs e1 => abs (open_rec (S k) u e1)
    | fp e => fp (open_rec (S k) u e)
    | app e1 e2 => app (open_rec k u e1) (open_rec k u e2)
    | proj1 t => proj1 (open_rec k u t)
    | proj2 t => proj2 (open_rec k u t)
    | prod a b => prod (open_rec k u a) (open_rec k u b)
    | inl l => inl (open_rec k u l)
    | inr r => inr (open_rec k u r)
    | cas e e1 e2 =>
      cas (open_rec k u e)
      (open_rec (S k) u e1)
      (open_rec (S k) u e2)
    | unit => unit
  end.

Notation "{ k ~> u } t" := (open_rec k u t) (at level 67).

(* opening that just replaces an outermost abstraction *)
Definition open e u := open_rec 0 u e.

Definition open_times n e u :=
  match n with
    | 0 => e
    | S n' => open_rec n' u e
  end.

(* local closure: well formedness wrt lambda abstraction *)
Inductive lc : term -> Prop :=
| lc_fvar : forall x, lc (fvar x)
| lc_abs : forall L e,
  (forall x:atom, x `notin` L -> lc (open e (fvar x))) ->
  lc (abs e)
| lc_app : forall e1 e2,
  lc e1 ->
  lc e2 ->
  lc (app e1 e2)
| lc_unit : lc unit
| lc_fp : forall L e,
  (forall x:atom, x `notin` L -> lc (open e (fvar x))) ->
  lc (fp e)
| lc_proj1 : forall e,
  lc e ->
  lc (proj1 e)
| lc_proj2 : forall e,
  lc e ->
  lc (proj2 e)
| lc_prod : forall e1 e2, lc e1 -> lc e2 -> lc (prod e1 e2)
| lc_inl : forall e, lc e -> lc (inl e)
| lc_inr : forall e, lc e -> lc (inr e)
| lc_cas : forall L e e1 e2,
  lc e ->
  (forall x:atom, x `notin` L -> lc (open e1 (fvar x))) ->
  (forall x:atom, x `notin` L -> lc (open e2 (fvar x))) ->
  lc (cas e e1 e2).
Hint Constructors lc.

Lemma open_lc_diff : forall e j v i u,
  i <> j ->
  {j ~> v} e = {i ~> u} ({j ~> v} e) ->
  e = {i ~> u} e.
Proof.
  induction e ; intros j v i u Hdiff ; try ( intros ; simpl in * ; f_equal ; intros ; inversion H ; eauto ; fail).
  (* bvar *)
  simpl in *. case (j === n) ; case (i === n) ; intros ; auto with arith ; try congruence. subst. simpl in H.
  case_eq (n===n). intros. rewrite H0 in H. auto. intros. congruence.
Defined.

Lemma open_lc : forall k u e, lc e -> e = {k ~> u} e.
Proof.
  intros.  generalize dependent k.
  induction H ; simpl ; try (intros ; f_equal ; intuition)
    ; pick fresh x for L ; intros ;
      apply open_lc_diff with (i := S k) (j := 0) (u := u) (v := (fvar x)) ; auto ;
        unfold open in H0 ; eauto ; firstorder.
Defined.

Lemma subst_open_rec : forall e1 e2 u x k,
  lc u ->[x ~> u] ({k ~> e2} e1) = {k ~> [x ~> u] e2} ([x ~> u] e1).
Proof.
  induction e1; intros e2 u x k Hlc; try (simpl in *; f_equal; auto ; fail).
  (* bvar *)
  simpl ; case (k === n) ; intros ; auto.
  (* fvar *)
  simpl ; case (a == x) ; intros ; eapply open_lc ; auto.
Defined.

Lemma subst_open_var : forall (x y : atom) u e,
  y <> x ->
  lc u ->
  open ([x ~> u] e) y = [x ~> u] (open e y).
Proof.
  intros x y u e Neq H.
  unfold open.
  rewrite subst_open_rec with (e2 := y).
  simpl.
  destruct (y == x).
    Case "y=x".
    destruct Neq. auto.
    Case "y<>x".
    auto.
  auto.
Qed.

Ltac pick_fresh Y :=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
    set (Y := (A `union` B)).

Lemma subst_lc : forall (x : atom) u e,
  lc e ->
  lc u ->
  lc ([x ~> u] e).
Proof.
  intros x u e He Hu.
  induction He ; try (simpl in * ; f_equal ; eauto ; intuition ; fail).
  Case "lc_var".
   simpl.
   destruct (x0 == x).
     auto.
     auto.
  Case "lc_abs".
   simpl.
    apply lc_abs with (L := L `union` singleton x).
    intros x0 Fr.
    rewrite subst_open_var. auto. auto. auto.
  Case "lc_fp".
   simpl.
    apply lc_fp with (L := L `union` singleton x).
    intros x0 Fr.
    rewrite subst_open_var. auto. auto. auto.
  Case "lc_cas".
   simpl.
    apply lc_cas with (L := L `union` singleton x) ; auto.
    (* inl *)
    intros x0 Fr.
    rewrite subst_open_var. auto. auto. auto.
    (* inr *)
    intros x0 Fr.
    rewrite subst_open_var. auto. auto. auto.
Defined.

(* single step operational semantics *)
Inductive eval : term -> term -> Prop :=
| eval_beta : forall e1 e2,
  lc (abs e1) ->
  lc e2 ->
  eval (app (abs e1) e2) (open e1 e2)
| eval_fp : forall e1,
  lc (fp e1) ->
  eval (fp e1) (open e1 (fp e1))
| eval_proj1 : forall e1 e2,
  lc e1 ->
  lc e2 ->
  eval (proj1 (prod e1 e2)) e1
| eval_proj2 : forall e1 e2,
  lc e1 ->
  lc e2 ->
  eval (proj2 (prod e1 e2)) e2
| eval_cas_1 : forall e e1 e2,
  lc (inl e) ->
  lc (abs e1) ->
  lc (abs e2) ->
  eval (cas (inl e) e1 e2) (open e1 e)
| eval_cas_2 : forall e e1 e2,
  lc (inr e) ->
  lc (abs e1) ->
  lc (abs e2) ->
  eval (cas (inr e) e1 e2) (open e2 e)
(* experiments / atomic evaluation contexts ala Felleisen *)
| eval_proj1_exp : forall e e',
  eval e e' ->
  eval (proj1 e) (proj1 e')
| eval_proj2_exp : forall e e',
  eval e e' ->
  eval (proj2 e) (proj2 e')
| eval_app_exp : forall e1 e1' e2,
  lc e2 ->
  eval e1 e1' ->
  eval (app e1 e2) (app e1' e2)
| eval_cas_exp : forall e e' e1 e2,
  lc (abs e1) ->
  lc (abs e2) ->
  eval e e' ->
  eval (cas e e1 e2) (cas e' e1 e2).

Hint Constructors eval.

Lemma subst_fresh : forall (x : atom) e u,
  x `notin` fv e -> [x ~> u] e = e.
Proof.
  intros x e u H.
  induction e ; try (simpl in * ; f_equal ; auto ; auto).
  Case "fvar".
   simpl.
   destruct (a == x).
    Case "a=x".
      subst. simpl fv in H. decideFSet.
    Case "a<>x".
      auto.
Qed.

Lemma subst_intro : forall (x : atom) u e,
  x `notin` (fv e) ->
  lc u ->
  open e u = [x ~> u](open e x).
Proof.
  intros x u e H J.
  unfold open.
  rewrite subst_open_rec; auto.
  simpl.
  destruct (x == x).
  Case "x = x".
    rewrite subst_fresh; auto.
  Case "x <> x".
    destruct n; auto.
Qed.

Lemma open_abs : forall e u,
  lc (abs e) ->
  lc u ->
  lc (open e u).
Proof with auto using subst_lc.
  intros e u H J.
  inversion H; subst.
  pick fresh y for (L `union` (fv e)).
  rewrite (subst_intro y). eauto using subst_lc. eauto. eauto.
Qed.

Lemma open_fp : forall e u,
  lc (fp e) ->
  lc u ->
  lc (open e u).
Proof with auto using subst_lc.
  intros e u H J.
  inversion H; subst.
  pick fresh y for (L `union` (fv e)).
  rewrite (subst_intro y). eauto using subst_lc. eauto. eauto.
Defined.

Lemma eval_regular : forall e1 e2,
  eval e1 e2 -> lc e1 /\ lc e2.
Proof.
  intros e1 e2 H ; induction H; intuition ; auto using open_abs, open_fp.
  (* inl *)
  apply lc_cas with (L:= (fv e1)) ; auto ;
    intros ; apply open_abs ; auto.
  apply open_abs ; auto ; inversion H ; auto.
  (* inr *)
  apply lc_cas with (L:= (fv e2)) ; auto ;
    intros ; apply open_abs ; auto.
  apply open_abs ; auto ; inversion H ; auto.
  (* cas context *)
  apply lc_cas with (L:= (fv (cas e e1 e2))) ; auto ;
  intros ; apply open_abs ; auto ; f_equal ;
    try (apply open_abs ; auto ; inversion H ; auto).
  apply lc_cas with (L:= (fv (cas e e1 e2))) ; auto ;
  intros ; apply open_abs ; auto ; f_equal ;
    try (apply open_abs ; auto ; inversion H ; auto).
Qed.

(* reduction relation *)
Inductive reduces : term -> Prop :=
| reduces_base :
  forall a, (exists b, eval a b) -> reduces a.

(* multi-step reduction relation *)
Inductive multistep : term -> term -> Prop :=
| multistep_refl : forall a, multistep a a
| multistep_eval : forall a b, eval a b -> multistep a b.

Inductive evaluates : term -> term -> Prop :=
| evaluates_base : forall a b, multistep a b -> ~(reduces b) -> evaluates a b.

Inductive converges : term -> Prop :=
| converges_base : forall a, (exists b, evaluates a b) -> converges a.

Inductive diverges : term -> Prop :=
| diverges_base : forall a, (forall b, multistep a b -> reduces b) -> diverges a.

Hint Constructors evaluates multistep converges diverges.

Lemma diverges_imp_not_converge : forall a, diverges a -> ~(converges a).
Proof.
  intros a H.
  (* -> *)
  inversion H. subst.
  unfold not. intros HC. inversion HC. subst. inversion H1. inversion H2. subst.
  unfold not in H4. apply H4. apply H0. auto.
Defined.

Lemma converges_imp_not_diverge : forall a, converges a -> ~(diverges a).
Proof.
  intros.
  inversion H. subst. inversion H0. inversion H1. subst.
  unfold not. intros Hd. apply H3. inversion Hd. subst. apply H4 in H2. auto.
Defined.

(* omega diverges, for fun *)
Lemma omega_diverges : diverges (fp 0).
Proof.
  intros. constructor. intros. inversion H. subst.
  (* ->* refl *)
  constructor. exists (open 0 (fp 0)). apply eval_fp.
  apply lc_fp with (L := {}). intros. compute. apply lc_fvar.
  subst.
  (* ->* eval *)
  constructor.
  inversion H0. subst. compute in *.
  exists (fp 0). auto.
Defined.

(* this formulation of diverges is much easier to work with *)
CoInductive diverges' : term -> Prop :=
| diverges'_base : forall x, (exists y, eval x y -> diverges' y) -> diverges' x.

Lemma omega_diverges' : diverges' (fp 0).
Proof.
  refine (cofix div : diverges' (fp 0) := _).
  constructor. exists (open 0 (fp 0)). intros. compute in *. auto.
Defined.

Inductive value : term -> Prop :=
| value_fv : forall a, value (fvar a)
| value_abs : forall t, lc (abs t) -> value (abs t)
| value_unit : value unit
| value_prod : forall t1 t2, lc (prod t1 t2) -> value (prod t1 t2)
| value_inl : forall t, lc (inl t) -> value (inl t)
| value_inr : forall t, lc (inr t) -> value (inr t).

Hint Constructors value.

Lemma value_not_reduces : forall t, value t -> ~ (reduces t).
Proof.
  induction t ; intros Hv ; inversion Hv ; unfold not ; intros Hr ; inversion Hr as [x He] ;
    subst ; inversion He as [x H] ; inversion H.
Defined.

Lemma reduces_not_value : forall t, reduces t -> ~ value t.
Proof.
  induction t ; intros Hr ; inversion Hr as [x He] ; subst ; unfold not ; intros Hv ; inversion Hv;
    subst ; inversion He as [x H] ; inversion H.
Defined.

Lemma value_or_reduces : forall t, lc t -> reduces t \/ value t.
Proof.
  intros. induction t ; try (right ; auto ; fail) ; try (left ; auto ; fail).
  inversion H. left. constructor. exists (open t (fp t)). auto.
  left. inversion H. apply IHt1 in H2. apply IHt2 in H3.
  inversion H2. constructor. inversion H4. inversion H5.
  exists (app x t2). apply eval_app_exp. inversion H ; auto. auto.
  subst. inversion H4. subst.
Defined.

Inductive active : term -> Prop :=
| active_prod : forall t1 t2, lc (prod t1 t2) -> active (prod t1 t2)
| active_inl : forall t, lc (inl t) -> active (inl t)
| active_inr : forall t, lc (inr t) -> active (inr t).

Inductive passive : term -> Prop :=
| passive_unit : passive unit
| passive_abs : forall t, lc (abs t) -> passive (abs t)
| passive_fp : forall t, lc (fp t) -> passive (fp t).

Inductive label : Set :=
| label_fvar : forall (b : atom), label
| label_fst
| label_snd
| label_inl
| label_inr
| label_fp
| label_app : forall (b : term), label.

(* we need an arbitrary divergent term of active type *)
Definition inf := inl (fp (inl 0)).

(* create a transition system for our functional programs *)
Inductive trans : term -> label -> term -> Prop :=
| trans_fvar : forall (x : atom), trans x (label_fvar x) x
| trans_fst : forall t1 t2, lc (prod t1 t2) -> trans (prod t1 t2) label_fst t1
| trans_snd : forall t1 t2, lc (prod t1 t2) -> trans (prod t1 t2) label_snd t2
| trans_inl : forall t, lc (inl t) -> trans (inl t) label_inl t
| trans_inr : forall t, lc (inr t) -> trans (inr t) label_inr t
(* | trans_fp : forall t, lc (fp t) -> trans (fp t) label_fp  (open t (fp t)) *)
| trans_app : forall t1 t2, lc (abs t1) -> lc t2 -> trans (abs t1) (label_app t2) (app (abs t1) t2)
| trans_next : forall t1 t2 t3 l, eval t1 t2 -> trans t2 l t3 -> trans t1 l t3.

Hint Constructors trans.

Ltac lc_solve :=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
    match goal with
      | |- lc (fp _) =>
        eapply lc_fp with (L:=(A `union` B)) ; intros ; compute ; try lc_solve
      | |- lc (abs _) =>
        eapply lc_abs with (L:=(A `union` B)) ; intros ; compute ; try lc_solve
      | |- lc (cas _ _ _) =>
        eapply lc_cas with (L:=(A `union` B)) ; intros ; compute ; try lc_solve
      | |- lc (fvar _) =>
        apply lc_fvar ; try lc_solve
      | |- lc (inl _) =>
        apply lc_inl ; try lc_solve
      | |- lc (inr _) =>
        apply lc_inr ; try lc_solve
      | |- lc unit =>
        apply lc_unit ; try lc_solve
      | |- lc (prod _ _) =>
        apply lc_prod ; try lc_solve
      | |- lc (app _ _) =>
            apply lc_app ; try lc_solve
      | |- lc (proj1 _) =>
        apply lc_proj1 ; try lc_solve
      | |- lc (proj2 _) =>
        apply lc_proj2 ; try lc_solve
    end.

(* terms remain locally closed by undergoing a transition *)
Lemma trans_regular : forall t1 t2 l, trans t1 l t2 -> lc t1 /\ lc t2.
Proof.
  intros t1 t2 l H. induction H ; subst ; try (split ; auto ; inversion H ; subst ; auto ; fail ).
  (* fp *)
(*  split. auto. apply open_fp. auto. auto. *)
  (* next *)
  split. intros. auto. inversion IHtrans. auto.
  apply eval_regular in H ; inversion H ; auto. inversion IHtrans. auto.
Defined.
Hint Resolve trans_regular.

CoInductive simulates : term -> term -> Prop :=
| simulates_base : forall a b,
  (forall a' l,
    trans a l a' ->
    (exists b', trans b l b' /\ simulates a' b')) ->
  simulates a b.

CoInductive bisimulates : term -> term -> Prop :=
| bisimulates_base : forall a b,
  (forall a' l,
    trans a l a' ->
    (exists b', trans b l b' /\ bisimulates a' b')) ->
  (forall b' l,
    trans b l b' ->
    (exists a', trans a l a' /\ bisimulates a' b')) ->
  bisimulates a b.

Lemma bisimulation_impl_simulation_right : forall a b, bisimulates a b -> simulates a b.
Proof.
  refine
    (cofix bisim (a b : term) (Hb : bisimulates a b) : simulates a b :=
      _).
  inversion Hb. subst. eapply simulates_base.
  intros. apply H in H1. inversion H1. inversion H2.
  exists x. split. auto. apply bisim. auto.
Defined.

Lemma bisimulation_impl_simulation_left : forall a b, bisimulates a b -> simulates b a.
Proof.
  refine
    (cofix bisim (a b : term) (Hb : bisimulates a b) : simulates b a :=
      _).
  inversion Hb. subst. eapply simulates_base.
  intros. apply H0 in H1. inversion H1. inversion H2.
  exists x. split. auto. apply bisim. auto.
Defined.

Ltac trans_prove_lc :=
  match goal with
    | H : trans ?x _ _ |- lc ?x => apply trans_regular in H ; inversion H ; auto
    | H : trans _ _ ?x |- lc ?x => apply trans_regular in H ; inversion H ; auto
  end.

Lemma bisimulation_refl : forall a, lc a -> bisimulates a a.
Proof.
  refine
    (cofix bisim (a : term) (H: lc a) : bisimulates a a := _) ;
  eapply bisimulates_base.

  intros. exists a'. split ; auto. apply bisim ; trans_prove_lc.

  intros. exists b'. split ; auto. apply bisim ; trans_prove_lc.
Defined.

Lemma bisimulation_symm : forall a b, lc a -> lc b -> bisimulates a b -> bisimulates b a.
Proof.
  refine
    (cofix bisim (a b:term) (Ha : lc a) (Hb : lc b) (Hbi : bisimulates a b) : bisimulates b a :=
      _).
  apply bisimulates_base.

  (* left *)
  intros.
  inversion Hbi. subst. cut (trans b l a') ; intros ; auto.
  apply H1 in H ; subst. inversion H. inversion H3.
  exists x. split ; auto. apply bisim ; try trans_prove_lc ; auto.

  (* right *)
  intros.
  inversion Hbi. subst. cut (trans a l b') ; intros ; auto.
  apply H0 in H ; subst. inversion H. inversion H3.
  exists x. split ; auto. apply bisim ; try trans_prove_lc ; auto.
Defined.

Lemma bisimulation_trans : forall a b c, lc a -> lc b -> lc c -> bisimulates a b -> bisimulates b c -> bisimulates a c.
Proof.
  refine
    (cofix bisim (a b c:term) (Ha : lc a) (Hb : lc b) (Hc : lc c) (Hbi_ab  : bisimulates a b) (Hbi_bc : bisimulates b c) : bisimulates a c := _)
    ; apply bisimulates_base.
  intros.
  inversion Hbi_ab ; inversion Hbi_bc ; subst.
  cut (trans a l a') ; intros ; auto.
  apply H0 in H2. inversion H2. inversion H3.
  cut (trans b l x) ; intros ; auto.
  apply H4 in H8. inversion H8. inversion H9.
  exists x0. split ; auto. eapply bisim with (b:=x) ; try trans_prove_lc ; auto.

  intros.
  inversion Hbi_ab ; inversion Hbi_bc ; subst.
  cut (trans c l b') ; intros ; auto.
  apply H5 in H2. inversion H2. inversion H3.
  cut (trans b l x) ; intros ; auto.
  apply H1 in H8. inversion H8. inversion H9.
  exists x0. split ; auto. eapply bisim with (b:=x) ; try trans_prove_lc ; auto.
Defined.

Ltac remove_trans_false :=
  match goal with
    | H : trans ?a ?l ?b, H0 : trans ?a' ?l' ?b' |- _ =>
      inversion H ; clear H ; inversion H0 ; clear H0 ; subst ; try congruence ; auto
    | H : eval (fvar ?a) ?b |- _ => inversion H ; clear H
    | H : eval (inl ?a) ?b |- _ => inversion H ; clear H
    | H : eval (inr ?a) ?b |- _ => inversion H ; clear H
    | H : eval (prod ?a ?b) ?c |- _ => inversion H ; clear H
  end.

Lemma testing : forall x y, x < y -> x <= y.
Proof.
  intros. inversion H ; subst.
  auto with arith. inversion H0. subst. auto. auto with arith.
Defined.

Lemma lc_abs_z : forall n, lc (abs (bvar n)) -> n = 0.
Proof.
  intros. destruct n. inversion H ; subst ; reflexivity.
  inversion H. compute in H1. subst.
  pick fresh x for L. apply (H1 x) in Fr. inversion Fr.
Defined.

Lemma lc_fp_z : forall n, lc (fp (bvar n)) -> n = 0.
Proof.
  intros. destruct n. inversion H. subst ; reflexivity.
  inversion H. compute in H1. subst.
  pick fresh x for L. apply (H1 x) in Fr. inversion Fr.
Defined.

Lemma eval_imp_bisimulation : forall a b, eval a b -> bisimulates a b.
Proof.
  refine (cofix bisim (a b : term) (Heval : eval a b) : bisimulates a b := _) ; apply bisimulates_base.

  intros.

  generalize dependent b. generalize dependent a.
  induction a; intros ; inversion Heval ; subst.
  induction a. apply lc_fp_z in H1. subst. compute in *. inversion Heval. subst.
  inversion H. subst.

  intros.
  inversion H. subst ; inversion Heval ; subst. subst.
  inversion Heval. subst. inversion Heval. subst.
  inversion Heval. subst. inversion Heval. subst.
  exists (app (abs b) t2). split. induction a. inversion H0. inversion Heval.
    apply IHa.
    apply lc_abs_z in H0.
  induction e1. apply lc_abs_z in H2.subst. compute in *. apply trans_app ; auto.
  inversion
  inversion H2. subst.
Defined.

Lemma simulation_pair_imp_bisimulation : forall a b, simulates a b -> simulates b a -> bisimulates a b.
Proof.
  refine
    (cofix bisim (a b : term) (Hsima : simulates a b) (Hsimb : simulates b a) : bisimulates a b := _).
  dependent inversion Hsima.

_).
  intros.
  (* left *)
  inversion Hsima. subst.

  apply H0 in H. inversion H. inversion H1.
  exists x. split ; auto.
  inversion Hsimb. subst. apply H4 in H2. inversion H2. inversion H5.

Ltac show_trans_exists :=
  match goal with
    | Heval : eval ?s ?t, Htrans : trans ?t _ ?a |- _ =>
      exists a ; split ; try (eapply trans_next ; eauto)
  end.

Definition tnil := inl unit.
Definition tcons := (fun a b => (inr (prod a b))).
(*
letrec map =
% f . % l .
  case l of
    | nil => nil
    | cons a b => (cons (@ f a) (@ (@ map f) b))
*)
Definition map := fp (abs (abs (cas 0 tnil (tcons (app 2 (proj1 0)) (app (app 3 2) (proj2 0)))))).
(*
letrec iterate =
% f . % k .
  cons k (@ (@ iterate f) (@ f k))
*)
Definition iterate := fp (abs (abs (tcons 0 (app (app 2 1) (app 1 0))))).

(* automates local closure proofs for terms *)
Lemma map_lc : lc map.
Proof.
  unfold map.
  lc_solve.
Defined.

Lemma iterate_lc : lc iterate.
Proof.
  unfold iterate.
  lc_solve.
Defined.

Lemma left_hand_iterate : forall f x, lc f -> lc x -> lc (app (app map f) (app (app iterate f) x)).
Proof.
  intros. lc_solve ; auto using map_lc, iterate_lc.
Defined.

Lemma iterate_proof : forall f x, lc f -> lc x -> bisimulates (app (app map f) (app (app iterate f) x))
                                                              (app (app iterate f) (app f x)).
Proof.
  refine (cofix bisim (f x : term) (Hlcf : lc f) (Hlcx : lc x)
    : bisimulates (app (app map f) (app (app iterate f) x)) (app (app iterate f) (app f x)) := _).
  constructor.
  (* left *)
  intros.
  exists (tcons (app f x) (app (app iterate f) (app f x))).
  split. eapply trans_next with (t2:=(tcons (app f x) (app (app iterate f) (app f x)))).
  beta
  cut
    (eval
      (fp
        (abs
          (abs (tcons 0%nat (app (app 2%nat 1%nat) (app 1%nat 0%nat))))))
      (open
        (abs
          (abs (tcons 0%nat (app (app 2%nat 1%nat) (app 1%nat 0%nat)))))
        (fp
          (abs
            (abs (tcons 0%nat (app (app 2%nat 1%nat) (app 1%nat 0%nat)))))))) ; intros.
  intros.
  inversion H0. subst.

Definition.

(*
Lemma eval_imp_bisimulates : forall a b, eval a b -> bisimulates b a.
  refine (cofix bisim (a b : term) (Heval : eval a b) : bisimulates b a := _).
  apply bisimulates_base.
  (* easy to show the left half of simulation *)
  intros ; try show_trans_exists ; try (apply bisimulation_refl ; prove_lc).
  (* right half *)
  intros.
Defined.
*)

(* behavioural equivalence relation *)
CoInductive b_eq : term -> term -> Prop :=
| b_eq_base :
  forall a b b',

(* hard to prove...
Lemma value_is_eval : forall t, value t <-> exists b, evaluates b t.
Proof.
  intros t ; split.
  (* -> *)
  intros Hv. exists t. apply evaluates_base. apply multistep_refl.
  unfold not. intros Hr. inversion Hv ; subst ; inversion Hr as [x He] ; subst ;
    inversion He as [x Hes] ;
      inversion Hes.
  (* <- *)
  intros He. inversion He. inversion H. subst.
  induction t. inversion H0. subst.
  inversion He. inversion H2. subst. inversion H3. subst.
  inversion H0. subst.
*)

Fixpoint raise (t : term) :=
  match t with
    | unit => unit
    | fp t' => fp (raise t')
    | fvar s => fvar s
    | bvar n => bvar (S n)
    | abs t' => abs (raise t')
    | app m n => app (raise m) (raise n)
    | prod e1 e2 => prod (raise e1) (raise e2)
    | proj1 e => proj1 (raise e)
    | proj2 e => proj2 (raise e)
    | inl e => inl (raise e)
    | inr e => inr (raise e)
    | cas e e1 e2 => cas (raise e) (raise e1) (raise e2)
  end.

(* case distributivity *)
Fixpoint case_dist (t : term) : term :=
  match t with
    | cas (cas e e1 e2) f1 f2 =>
      cas e
      (cas e1 (raise (case_dist f1)) (raise (case_dist f2)))
      (cas e2 (raise (case_dist f1)) (raise (case_dist f2)))
    | unit => unit
    | fp t' => fp (case_dist t')
    | fvar s => fvar s
    | bvar n => bvar (S n)
    | abs t' => abs (case_dist t')
    | app m n => app (case_dist m) (case_dist n)
    | prod e1 e2 => prod (case_dist e1) (case_dist e2)
    | proj1 e => proj1 (case_dist e)
    | proj2 e => proj2 (case_dist e)
    | inl e => inl (case_dist e)
    | inr e => inr (case_dist e)
    | cas e e1 e2 => cas (case_dist e) (case_dist e1) (case_dist e2)
  end.

(* eval_big : big step operational semantics

------
e => e

e => e' e' -> e''
-----------------
     e => e''

*)

(* eval_coind : big step coinductive operational semantics *)

CoInductive diverges : term -> Prop :=
| diverges_app_1 : forall e e', diverges e -> diverges (app e e')
| diverges_app_2 : forall e1 e2 e2', eval_big e e' -> diverges
| diverges_cas : forall e e1 e2, diverges e -> diverges (cas e e1 e2)
| diverges

Notation "`case` t `of` { A | B }" := (cas t A B).

(* nat := 1 + nat *)
Definition Zero := inl unit.
Definition Succ := (fun x => inr x).
(* bool := 1 + 1 *)
Definition T := inl unit.
Definition F := inr unit.

(* Nat = 1 + Nat *)
Definition One := Succ Zero.
Definition Two := Succ One.
Definition Three := Succ Two.
Definition add := (fp (abs (abs (abs (cas 2 (abs 2) (abs (Succ (app (app 3 0) 2)))))))).

Ltac lc_abs_run :=
  let L := fresh "L" in
    intros ; compute ; pick fresh x for L.

Ltac prove_lc :=
  match goal with
    | |- lc (fp ?x) => apply lc_fp
    | |- lc (abs ?x) => lc_abs_run ; intros ; compute
    | |- lc (cas ?x ?y ?z) => apply lc_cas
    | |- lc (inr ?x) => apply lc_inr
    | |- lc (inl ?x) => apply lc_inl
    | |- lc ?x => auto
  end.

Lemma add_lc : lc add.
Proof.
  unfold add.
  repeat prove_lc.
Defined.

Lemma eval_add : eval (app (app add One) Two) Three.
Proof.
  compute.


(** * CLatticeLemma.v : some lemmas about complete lattice. *)

From Babel Require Import TerminalDogma
                          ExtraDogma.Extensionality
                          SetFacility.

From Babel Require Export POrder DerivedPOrder.

From Babel Require Import Ranko.POrderCharacter.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(*###############################################################*)
(** complete lattice of monotonic functions *)

Module MonoFunCLattice.

Import FunPointwiseOrder.CanonicalStruct.

Definition join_op (C : poset) (D : clattice) (F : 𝒫([C ↦ᵐ D])) : [C ↦ᵐ D].
Proof.
    set f := fun c => ⊔ᶜˡ { f c, f | f ∈ F }.
    refine (MonotonicFun f _).

    porder_level.
    rewrite /f //=. porder_level.
    apply (CLattice.join_prop (CLattice.class D)) => //=. porder_level.

    (* Set Printing All. *)
    apply (@poset_trans _ _ (x0 y) _).
    by apply MonotonicFun.class.

    porder_level.
Defined.

Definition clattice_join_essence (C : poset) (D : clattice):
    CLattice.join_essence_of [C ↦ᵐ D].
Proof.
    refine (@CLattice.JoinEssence _ (@join_op C D) _) => //=.
    porder_level.
Defined.

Definition AUX_clattice_type (C : poset) (D : clattice) :=
    CLattice [C ↦ᵐ D] (CLattice.join_essence_to_mixin
                            (clattice_join_essence C D)).

Definition lattice_mixin (C : poset) (D : clattice) :
    Lattice.mixin_of (Poset.class [C ↦ᵐ D]) :=
    Lattice.class [lattice of AUX_clattice_type C D].

Canonical lattice_type (C : poset) (D : clattice) :=
    Lattice [C ↦ᵐ D] (lattice_mixin C D).

Definition clattice_mixin (C : poset) (D : clattice) :
    CLattice.mixin_of (Lattice.class [C ↦ᵐ D]) :=
    CLattice.class [clattice of AUX_clattice_type C D].

Canonical clattice_type (C : poset) (D : clattice) :=
    CLattice [C ↦ᵐ D] (clattice_mixin C D).

Canonical cpo_type (C : poset) (D : clattice) : cpo :=
    CPO [C ↦ᵐ D] (CPO.class [cpo of [clattice of [C ↦ᵐ D]]]).

Module Exports.

Canonical lattice_type.
Canonical clattice_type.
Canonical cpo_type.

End Exports.

End MonoFunCLattice.

Export MonoFunCLattice.Exports.