Require Export ZArith.
Require Export List.
Require Export Arith.
Require Export ZArithRing.

(* Exercise 5.1, too simple *)

(* Exercise 5.2 *)
Theorem all_perm : forall (A: Type) (P: A -> A -> Prop), (forall x y: A, P x y) -> forall x y: A, P y x.
Proof.
  intros A P Hp x y; apply (Hp y x).
Qed.

Print all_perm.

Theorem resolution :
  forall (A:Type) (P Q R S: A -> Prop), (forall a:A, Q a -> R a -> S a) -> (forall b:A, P b -> Q b) -> (forall c:A, P c -> R c -> S c).
Proof.
  intros A P Q R S Hqrs Hpq c Hp Hr.
  apply Hqrs; [apply Hpq | idtac]; assumption.
Qed.

(* Exercise 5.3 *)

Theorem modus_ponens : forall P Q:Prop, P -> (P -> Q) -> Q.
Proof.
  intros P Q p Hp; apply Hp; assumption.
Qed.

Lemma ex_5_3_1 : ~False.
Proof.
  intros Hf. elim Hf.
Qed.

(* double negation elimination *)
Lemma ex_5_3_2 : forall P: Prop, ~~~P -> ~P.
Proof.
  intros P Hp Cp. unfold not in Hp.
  apply Hp. intros Hp0. apply Hp0.
  assumption.
Qed.

(* did not use elim *)
Lemma ex_5_3_3 : forall P Q: Prop, (P -> Q) -> ~Q -> ~P.
Proof.
  intros P Q Hpq Cp Hq.
  apply Cp; apply Hpq; assumption.
Qed.

(* for some reason i cannot use the absurd thm *)
Lemma ex_5_3_4 : forall P Q R: Prop, (P -> Q) -> (P -> ~Q) -> P -> R.
Proof.
  unfold not; intros P Q R Hpq Hpnq Hp.
  elim Hpnq; [assumption | apply Hpq; assumption].
Qed.

(* Exercise 5.4 *)

(* Definition dyslexic_contrap : forall P Q: Prop, (P -> Q) -> (~P -> ~Q). *)

Theorem dys_imp_f :
  (forall P Q: Prop, (P -> Q) -> (Q -> P)) -> False.
Proof.
  intros Hd; apply (Hd False True);
    [intros C; elim C | apply I].
Qed.

Theorem dys_contrap_f :
  (forall P Q: Prop, (P -> Q) -> (~P -> ~Q)) -> False.
Proof.
  intros Hc; apply (Hc False True);
    try (intros C; elim C); apply I.
Qed.

(* Exercise 5.5 *)

Theorem ex_5_5 : forall (A: Set) (a b c d: A), a=c \/ b=c \/ c=c \/ d=c.
Proof.
  intros A a b c d;
    right; right; left; reflexivity.
Qed.

(* Exercise 5.6 *)

Lemma ex_5_6_1 :
  forall A B C: Prop, A /\ (B /\ C) -> (A /\ B) /\ C.
Proof.
  intros A B C H.
  destruct H as [Ha [Hb Hc]];
  repeat split; assumption.
Qed.

Lemma ex_5_6_2 :
  forall A B C D: Prop, (A -> B) /\ (C -> D) /\ A /\ C -> B /\ D.
Proof.
  intros A B C D [Hab [Hcd [Ha Hc]]]; split;
    [apply Hab | apply Hcd]; assumption.
Qed.

Lemma ex_5_6_3 :
  forall A: Prop, ~(A /\ ~A).
Proof.
  intros A [C1 C2]; apply C2; assumption.
Qed.

Lemma ex_5_6_4 :
  forall A B C: Prop, A \/ (B \/ C) -> (A \/ B) \/ C.
Proof.
  intros A B C [Ha | [Hb | Hc]];
    [ left; left | left; right | right ];
    assumption.
Qed.

Lemma ex_5_6_5 :
  forall A: Prop, ~~(A \/ ~A).
Proof.
  unfold not;
    intros A C; apply C; right; intros Ha;
      apply C; left; assumption.
Qed.

Lemma ex_5_6_6 :
  forall A B: Prop, (A \/ B) /\ ~A -> B.
Proof.
  intros A B [[Ha | Hb] Ca];
    [elim Ca | idtac ]; assumption.
Qed.

(* Exercise 5.7 *)

Definition peirce := forall P Q: Prop, ((P -> Q) -> P) -> P.
Definition classic := forall P: Prop, ~~P -> P.
Definition excluded_middle := forall P: Prop, P \/ ~P.
Definition de_morgan_not_and_not := forall P Q: Prop, ~(~P /\ ~Q) -> P \/ Q.
Definition implies_to_or := forall P Q: Prop, (P -> Q) -> (~P \/ Q).

Lemma ex_5_7_1:
  peirce -> classic.
Proof.
  unfold peirce, classic, not; intros H P Hp.
  apply (H P False). intros H0; elim Hp; assumption.
Qed.

Lemma ex_5_7_2:
  classic -> excluded_middle.
Proof.
  unfold classic, excluded_middle; intros H P;
    apply H; intros H0.
  absurd P.
  - intros Hp; apply H0; now left.
  - apply H; intros Cp; apply H0; now right.
Qed.

Lemma ex_5_7_3:
  excluded_middle -> de_morgan_not_and_not.
Proof.
  unfold excluded_middle, de_morgan_not_and_not.
  intros H P Q Hpq.
  destruct (H P) as [Hp | Cp];
    destruct (H Q) as [Hq | Cq];
    [ left | left | right | elim Hpq; split ];
    assumption.
Qed.

Lemma pp: forall P: Prop, P -> P.
Proof.
  (intros P Hp; assumption). Qed.

Lemma ex_5_7_4':
  de_morgan_not_and_not -> classic.
Proof.
  unfold de_morgan_not_and_not, classic.
  intros H P Cp.
  apply or_ind with (A:=P) (B:=P);
    [apply pp | apply pp | idtac].
  apply H; intros [Hc _].
  apply Cp; assumption.
Qed.

Lemma ex_5_7_4:
  de_morgan_not_and_not -> implies_to_or.
Proof.
  unfold de_morgan_not_and_not, implies_to_or;
    intros Hm P Q Hpq.
  apply Hm; intros [Cp Cq].
  apply Cq. apply Hpq.
  apply ex_5_7_4';
    [intros | idtac]; assumption.
Qed.

Lemma ex_5_7_5:
  implies_to_or -> peirce.
Proof.
  unfold implies_to_or, peirce;
    intros Hpq P Q H.
  assert (Hc: ~P \/ P) by (apply Hpq; now intros Hp).
  destruct Hc.
  - apply H; intros Hp; elim (H0 Hp).
  - assumption.
Qed.

(* Exercise 5.9 *)

Section Ex_5_9.
  Variable A:Set.
  Variables P Q: A -> Prop.

  Theorem ex_5_9_1:
    (exists x: A, P x \/ Q x) -> (ex P) \/ (ex Q).
  Proof.
    intros H; elim H; clear H; intros x [H | H];
      [left | right]; now exists x.
  Qed.

  Theorem ex_5_9_2:
    (ex P) \/ (ex Q) -> exists x: A, P x \/ Q x.
  Proof.
    intros [H | H];
      elim H; clear H; intros x H;
    exists x; [left | right]; assumption.
  Qed.

  Theorem ex_5_9_3:
    (exists x: A, (forall R: A -> Prop, R x)) -> 2 = 3.
  Proof.
    intros H; elim H; clear H; intros a Hr.
    elim (Hr (fun _ => False)).
  Qed.

  Theorem ex_5_9_4:
    (forall x:A, P x) -> ~(exists y: A, ~ P y).
  Proof.
    intros H Hy; elim Hy; clear Hy; intros y Hy.
    elim (Hy (H y)).
  Qed.

End Ex_5_9.

(* Exercise 5.10 *)

Theorem plus_permute2:
  forall n m p: nat, n + m + p = n + p + m.
Proof.
  intros n m p.
  rewrite <- plus_assoc.
  pattern (m + p).
  rewrite plus_comm.
  rewrite plus_assoc.
  reflexivity.
Qed.

(* Exercise 5.11 *)

Theorem eq_trans:
  forall (A: Type) (x y z: A), x = y -> y = z -> x = z.
Proof.
  intros A x y z Hxy Hyz.
  apply eq_ind with (x:=y);
    assumption.
  Restart.
  intros A x y z Hxy Hyz.
  rewrite Hxy, Hyz.
  reflexivity.
Qed.

Module Impredicative.
  Definition mTrue : Prop := forall P: Prop, P -> P.
  Definition mFalse : Prop := forall P: Prop, P.

  Theorem mFalse_ind : forall P: Prop, mFalse -> P.
  Proof. intros P Hf; apply Hf. Qed.

  (* Exercise 5.12 *)

  Theorem myI : mTrue.
  Proof (fun P p => p).

  Theorem mFalse_ind' : forall P: Prop, mFalse -> P.
  Proof (fun P Hf => Hf P).

  (* Exercise 5.13 *)
  Definition mNot (P: Prop): Prop := P -> mFalse.

  Lemma ex_5_3_1 : mNot mFalse.
  Proof.
    unfold mNot, mFalse.
    intros Hf P. apply Hf.
  Qed.

End Impredicative.
Export Impredicative.

Section leibniz.
  Set Implicit Arguments.
  Unset Strict Implicit.
  Variable A: Set.

  Definition leibniz (a b: A): Prop := forall P: A -> Prop, P a -> P b.

  Require Import Relations.

  Theorem leibniz_sym : symmetric A leibniz.
  Proof.
    unfold symmetric.
    intros x y H.
    now apply H.
  Qed.

  (* Exercise 5.14 *)
  Theorem leibniz_refl: reflexive A leibniz.
  Proof. easy. Qed.

  Theorem leibniz_trans: transitive A leibniz.
  Proof.
    unfold transitive; intros x y z Hxy Hyz;
      apply Hyz; apply Hxy.
  Qed.

  Theorem leibniz_quiv: equiv A leibniz.
  Proof.
    unfold equiv; split;
      [apply leibniz_refl | split;
                            [apply leibniz_trans | apply leibniz_sym]].
  Qed.

  Theorem leibniz_least_reflexive:
    forall R: relation A, reflexive A R -> inclusion A leibniz R.
  Proof.
    intros R Hrefl x y Hl;
      apply Hl; apply Hrefl.
  Qed.

  Theorem leibniz_eq: forall a b: A, leibniz a b -> a = b.
  Proof.
    intros a b Hl;
      apply Hl; reflexivity.
  Qed.

  Theorem eq_leibniz: forall a b: A, a = b -> leibniz a b.
  Proof.
    intros a b He;
      rewrite He; apply leibniz_refl.
  Qed.

  Theorem leibniz_ind:
    forall (x: A) (P: A -> Prop), P x -> forall y: A, leibniz x y -> P y.
  Proof.
    intros x P Hp y Hl;
      now apply Hl.
  Qed.

  Definition mAnd (P Q: Prop) := forall R: Prop, (P -> Q -> R) -> R.
  Definition mOr  (P Q: Prop) := forall R: Prop, (P -> R) -> (Q -> R) -> R.
  Definition mEx  (A: Set) (P: A -> Prop) := forall R: Prop, (forall x: A, P x -> R) -> R.

  (* Exercise 5.15 *)
  Section ex_5_15.
    Variables P Q R: Prop.
    Variable  PA : A -> Prop.

    Theorem ex_5_15_1: mAnd P Q -> P.
    Proof.
      intros H; apply H; now intros P' Q'.
    Qed.

    Theorem ex_5_15_2: mAnd P Q -> Q.
    Proof.
      intros H; apply H; now intros P' Q'.
    Qed.

    Theorem ex_5_15_3: (P -> Q -> R) -> mAnd P Q -> R.
    Proof.
      intros Hpqr H;
        apply H; apply Hpqr.
    Qed.

    Theorem ex_5_15_4: P -> mOr P Q.
    Proof.
      intros P' p Hp Hq;
        now apply Hp.
    Qed.

    Theorem ex_5_15_5: Q -> mOr P Q.
    Proof.
      intros Q' p Hp Hq;
        now apply Hq.
    Qed.

    Theorem ex_5_15_6: (P -> R) -> (Q -> R) -> mOr P Q -> R.
    Proof.
      intros Hpr Hqr Hpq;
        apply Hpq; [apply Hpr | apply Hqr].
    Qed.

    Theorem ex_5_15_7: mOr P mFalse -> P.
    Proof.
      intros Hor; apply Hor;
        [trivial | apply mFalse_ind].
    Qed.

    Theorem ex_5_15_8: mOr P Q -> mOr Q P.
    Proof.
      intros Hor P' Hqr Hpr.
      apply Hor; assumption.
    Qed.

    Theorem ex_5_15_9: forall a: A, PA a -> mEx PA.
    Proof.
      intros a H R0 He.
      now apply (He a).
    Qed.

    Theorem ex_5_15_10:
      mNot (mEx PA) -> forall a: A, mNot (PA a).
    Proof.
      intros H a Hpa;
        unfold mNot, mEx in *.
      apply H; clear H; intros R0 Hr.
      now apply (Hr a).
    Qed.
  End ex_5_15.

  Definition mLe (n p: nat) :=
    forall P: nat -> Prop, P n -> (forall q: nat, P q -> P (S q)) -> P p.

  (* Exercise 5.16 *)

  Lemma my_le_n: forall n: nat, mLe n n.
  Proof.
    now intros n P Hn Hq.
  Qed.

  Lemma my_le_S:
    forall n p: nat, mLe n p -> mLe n (S p).
  Proof.
    intros n p Hnp P Hrefl Hind.
    apply Hnp.
    - apply Hind; assumption.
    - intros q; apply (Hind (S q)).
  Qed.

  Lemma my_le_le: forall n p: nat, mLe n p -> n <= p.
  Proof.
    unfold mLe; intros n p Hle.
    apply Hle;
      [apply le_refl | apply le_S].
  Qed.

Unset Implicit Arguments.
End leibniz.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Lia Permutation.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import list_focus utils_tac.

Set Implicit Arguments.

Create HintDb length_db.

Tactic Notation "rew" "length" := autorewrite with length_db.
Tactic Notation "rew" "length" "in" hyp(H) := autorewrite with length_db in H.

Infix "~p" := (@Permutation _) (at level 70).

Section In_t.

  Variable (X : Type).

  Fixpoint In_t (x : X) l : Type :=
    match l with
      | nil  => False
      | y::l => ((y = x) + In_t x l)%type
    end.

  Fact In_t_In x l : In_t x l -> In x l.
  Proof. induction l; simpl; tauto. Qed.

  Fact In_In_t x l (P : Prop) : (In_t x l -> P) -> In x l -> P.
  Proof.
    induction l as [ | y l IHl ].
    + intros _ [].
    + intros H1 [ -> | H2 ].
      * apply H1; simpl; auto.
      * apply IHl; auto.
        intros; apply H1; simpl; auto.
  Qed.

End In_t.

Section length.

  Variable X : Type.

  Implicit Type l : list X.

  Fact length_nil : length (@nil X) = 0.
  Proof. auto. Qed.

  Fact length_cons x l : length (x::l) = S (length l).
  Proof. auto. Qed.

End length.

Global Hint Rewrite length_nil length_cons app_length map_length rev_length : length_db.

Section list_an.

  Fixpoint list_an a n :=
    match n with
      | 0   => nil
      | S n => a::list_an (S a) n
    end.

  Fact list_an_S a n : list_an a (S n) = a::list_an (S a) n.
  Proof. auto. Qed.

  Fact list_an_plus a n m : list_an a (n+m) = list_an a n ++ list_an (n+a) m.
  Proof.
    revert a; induction n; intros a; simpl; auto.
    rewrite IHn; do 3 f_equal; lia.
  Qed.

  Fact list_an_length a n : length (list_an a n) = n.
  Proof.
    revert a; induction n; intro; simpl; f_equal; auto.
  Qed.

  Fact list_an_spec a n m : In m (list_an a n) <-> a <= m < a+n.
  Proof.
    revert a; induction n as [ | n IHn ]; simpl; intros a; [ | rewrite IHn ]; lia.
  Qed.

  Fact map_S_list_an a n : map S (list_an a n) = list_an (S a) n.
  Proof. revert a; induction n; simpl; intro; f_equal; auto. Qed.

  Fact list_an_app_inv a n l r : list_an a n = l++r -> l = list_an a (length l) /\ r = list_an (a+length l) (length r).
  Proof.
    revert a l r; induction n as [ | n IHn ]; intros a l r; simpl.
    + destruct l; destruct r; intros; auto; discriminate.
    + destruct l as [ | x l ]; simpl; intros H1.
      * split; auto.
        rewrite <- H1; simpl; rewrite Nat.add_0_r, list_an_length; auto.
      * injection H1; clear H1; intros H1 H0.
        apply IHn in H1; destruct H1; split; f_equal; auto.
        rewrite H1 at 1; f_equal; lia.
  Qed.

  Fact list_an_duplicate_inv a n l x m y r :
        list_an a n = l++x::m++y::r -> a <= x /\ x < y < a+n.
  Proof.
    intros H.
    generalize H; intros H1.
    apply f_equal with (f := @length _) in H1.
    rewrite list_an_length in H1.
    apply list_an_app_inv in H; simpl in H.
    destruct H as (E1 & H); injection H; clear H; intros H E2.
    symmetry in H; apply list_an_app_inv in H; simpl in H.
    destruct H as (E3 & H); injection H; clear H; intros E4 E5.
    do 2 (rewrite app_length in H1; simpl in H1).
    lia.
  Qed.

End list_an.

Global Hint Rewrite list_an_length : length_db.

Definition list_fun_inv X (l : list X) (x : X) : { f : nat -> X | l = map f (list_an 0 (length l)) }.
Proof.
  induction l as [ | y l IHl ].
  + exists (fun _ => x); auto.
  + destruct IHl as (f & Hf).
    exists (fun i => match i with 0 => y | S i => f i end); simpl.
    f_equal.
    rewrite Hf, <- map_S_list_an, map_length, list_an_length, map_map; auto.
Qed.

Fact list_upper_bound (l : list nat) : { m | forall x, In x l -> x < m }.
Proof.
  induction l as [ | x l (m & Hm) ].
  + exists 0; simpl; tauto.
  + exists (1+x+m); intros y [ [] | H ]; simpl; try lia.
    generalize (Hm _ H); intros; lia.
Qed.

Section list_injective.

  Variable X : Type.

  Definition list_injective (ll : list X) :=  forall l a m b r, ll = l ++ a :: m ++ b :: r -> a <> b.

  Fact in_list_injective_0 : list_injective nil.
  Proof. intros [] ? ? ? ? ?; discriminate. Qed.

  Fact in_list_injective_1 x ll : ~ In x ll -> list_injective ll -> list_injective (x::ll).
  Proof.
    intros H1 H2 l a m b r H3.
    destruct l as [ | u l ].
    inversion H3; subst.
    destruct m as [ | v m ].
    contradict H1; subst; simpl; auto.
    contradict H1; subst; simpl; right; apply in_or_app; right; left; auto.
    inversion H3; subst.
    apply (H2 l _ m _ r); auto.
  Qed.

  Fact list_injective_inv x ll : list_injective (x::ll) -> ~ In x ll /\ list_injective ll.
  Proof.
    split.
    intros H1; apply in_split in H1; destruct H1 as (l & r & ?); subst.
    apply (H nil x l x r); auto.
    intros l a m b r ?; apply (H (x::l) a m b r); subst; solve list eq.
  Qed.

  Variable P : list X -> Type.

  Hypothesis (HP0 : P nil).
  Hypothesis (HP1 : forall x l, ~ In x l -> P l -> P (x::l)).

  Theorem list_injective_rect l : list_injective l -> P l.
  Proof using HP0 HP1.
    induction l as [ [ | x l ] IHl ] using (measure_rect (@length _)).
    intro; apply HP0.
    intros; apply HP1.
    apply list_injective_inv, H.
    apply IHl; simpl; auto.
    apply list_injective_inv with (1 := H).
  Qed.

End list_injective.

Fact list_injective_map X Y (f : X -> Y) ll :
       (forall x y, f x = f y -> x = y) -> list_injective ll -> list_injective (map f ll).
Proof.
  intros Hf.
  induction 1 as [ | x l Hl IHl ] using list_injective_rect.
  apply in_list_injective_0.
  simpl; apply in_list_injective_1; auto.
  contradict Hl.
  apply in_map_iff in Hl.
  destruct Hl as (y & Hl & ?).
  apply Hf in Hl; subst; auto.
Qed.

Fact list_app_head_not_nil X (u v : list X) : u <> nil -> v <> u++v.
Proof.
  intros H; contradict H.
  destruct u as [ | a u ]; auto; exfalso.
  apply f_equal with (f := @length _) in H.
  revert H; simpl; rewrite app_length; intros; lia.
Qed.

Section iter.

  Variable (X : Type) (f : X -> X).

  Fixpoint iter x n :=
    match n with
      | 0   => x
      | S n => iter (f x) n
    end.

  Fact iter_plus x a b : iter x (a+b) = iter (iter x a) b.
  Proof. revert x; induction a; intros x; simpl; auto. Qed.

  Fact iter_swap x n : iter (f x) n = f (iter x n).
  Proof.
    change (iter (f x) n) with (iter x (1+n)).
    rewrite Nat.add_comm, iter_plus; auto.
  Qed.

  Fact iter_S x n : iter x (S n) = f (iter x n).
  Proof. apply iter_swap. Qed.

End iter.

Fixpoint list_repeat X (x : X) n :=
  match n with
    | 0   => nil
    | S n => x::list_repeat x n
  end.

Fact list_repeat_plus X x a b : @list_repeat X x (a+b) = list_repeat x a ++ list_repeat x b.
Proof. induction a; simpl; f_equal; auto. Qed.

Fact list_repeat_length X x n : length (@list_repeat X x n) = n.
Proof. induction n; simpl; f_equal; auto. Qed.

Fact In_list_repeat X (x y : X) n : In y (list_repeat x n) -> x = y /\ 0 < n.
Proof.
  induction n; simpl; intros [].
  split; auto; lia.
  split; try lia; apply IHn; auto.
Qed.

Fact map_list_repeat X Y f x n : @map X Y f (list_repeat x n) = list_repeat (f x) n.
Proof. induction n; simpl; f_equal; auto. Qed.

Fact map_cst_repeat X Y (y : Y) ll : map (fun _ : X => y) ll = list_repeat y (length ll).
Proof. induction ll; simpl; f_equal; auto. Qed.

Fact map_cst_snoc X Y (y : Y) ll mm : y :: map (fun _ : X => y) ll++mm = map (fun _ => y) ll ++ y::mm.
Proof. induction ll; simpl; f_equal; auto. Qed.

Fact map_cst_rev  X Y (y : Y) ll : map (fun _ : X => y) (rev ll) = map (fun _ => y) ll.
Proof. do 2 rewrite map_cst_repeat; rewrite rev_length; auto. Qed.

Fact In_perm X (x : X) l : In x l -> exists m, x::m ~p l.
Proof.
  intros H; apply in_split in H.
  destruct H as (m & k & ?); subst.
  exists (m++k).
  apply Permutation_cons_app; auto.
Qed.

Fact list_app_eq_inv X (l1 l2 r1 r2 : list X) :
       l1++r1 = l2++r2 -> { m | l1++m = l2 /\ r1 = m++r2 }
                        + { m | l2++m = l1 /\ r2 = m++r1 }.
Proof.
  revert l2 r1 r2; induction l1 as [ | x l1 IH ].
  intros; left; exists l2; auto.
  intros [ | y l2 ] r1 r2; simpl; intros H.
  right; exists (x::l1); auto.
  inversion H.
  destruct (IH l2 r1 r2) as [ (m & Hm) | (m & Hm) ]; auto;
    [ left | right ]; exists m; split; f_equal; tauto.
Qed.

Fact list_app_cons_eq_inv X (l1 l2 r1 r2 : list X) x :
       l1++r1 = l2++x::r2 -> { m | l1++m = l2 /\ r1 = m++x::r2 }
                           + { m | l2++x::m = l1 /\ r2 = m++r1 }.
Proof.
  intros H.
  apply list_app_eq_inv in H.
  destruct H as [ H | (m & H1 & H2) ]; auto.
  destruct m as [ | y m ].
  left; exists nil; simpl in *; split; auto.
  revert H1; do 2 rewrite <- app_nil_end; auto.
  inversion H2; subst.
  right; exists m; auto.
Qed.

Fact list_cons_app_cons_eq_inv X (l2 r1 r2 : list X) x y :
       x::r1 = l2++y::r2 -> (l2 = nil /\ x = y /\ r1 = r2)
                          + { m | l2 = x::m /\ r1 = m++y::r2 }.
Proof.
  intros H.
  destruct l2 as [ | z m ]; simpl in H.
  + left; inversion H; auto.
  + right; exists m; inversion H; auto.
Qed.

Fact list_app_inj X (l1 l2 r1 r2 : list X) : length l1 = length l2 -> l1++r1 = l2++r2 -> l1 = l2 /\ r1 = r2.
Proof.
  revert l2; induction l1 as [ | x l1 IH ]; intros [ | y l2 ]; try discriminate.
  simpl; auto.
  intros H1 H2; inversion H1; inversion H2.
  apply IH in H4; auto.
  split; f_equal; tauto.
Qed.

Fact list_split_length X (ll : list X) k : k <= length ll -> { l : _ & { r | ll = l++r /\ length l = k } }.
Proof.
  revert k; induction ll as [ | x ll IHll ]; intros k.
  exists nil, nil; split; simpl in * |- *; auto; lia.
  destruct k as [ | k ]; intros Hk.
  exists nil, (x::ll); simpl; split; auto.
  destruct (IHll k) as (l & r & H1 & H2).
  simpl in Hk; lia.
  exists (x::l), r; split; simpl; auto; f_equal; auto.
Qed.

Fact list_pick X (ll : list X) k : k < length ll -> { x : _ & { l : _ & { r | ll = l++x::r /\ length l = k } } }.
Proof.
  revert k; induction ll as [ | x ll IHll ]; intros k.
  simpl; lia.
  destruct k as [ | k ]; intros H.
  exists x, nil, ll; simpl; auto.
  simpl in H.
  destruct IHll with (k := k) as (y & l & r & ? & ?); try lia.
  exists y, (x::l), r; subst; simpl; split; auto.
Qed.

Fact list_split_middle X l1 (x1 : X) r1 l2 x2 r2 :
       ~ In x1 l2 -> ~ In x2 l1 -> l1++x1::r1 = l2++x2::r2 -> l1 = l2 /\ x1 = x2 /\ r1 = r2.
Proof.
  intros H1 H2 H.
  apply list_app_eq_inv in H.
  destruct H as [ (m & H3 & H4) | (m & H3 & H4) ]; destruct m.
  inversion H4; subst; rewrite <- app_nil_end; auto.
  inversion H4; subst; destruct H1; apply in_or_app; right; left; auto.
  inversion H4; subst; rewrite <- app_nil_end; auto.
  inversion H4; subst; destruct H2; apply in_or_app; right; left; auto.
Qed.

Section flat_map.

  Variable (X Y : Type) (f : X -> list Y).

  Fact flat_map_app l1 l2 : flat_map f (l1++l2) = flat_map f l1 ++ flat_map f l2.
  Proof.
    induction l1; simpl; auto; solve list eq; f_equal; auto.
  Qed.

  Fact flat_map_app_inv l r1 y r2 : flat_map f l = r1++y::r2 -> exists l1 m1 x m2 l2, l = l1++x::l2 /\ f x = m1++y::m2
                                                                  /\ r1 = flat_map f l1++m1 /\ r2 = m2++flat_map f l2.
  Proof.
    revert r1 y r2.
    induction l as [ | x l IHl ]; intros r1 y r2 H.
    + destruct r1; discriminate.
    + simpl in H.
      apply list_app_cons_eq_inv in H.
      destruct H as [ (m & Hm1 & Hm2) | (m & Hm1 & Hm2) ].
      - apply IHl in Hm2.
        destruct Hm2 as (l1 & m1 & x' & m2 & l2 & G1 & G2 & G3 & G4); subst.
        exists (x::l1), m1, x', m2, l2; simpl; repeat (split; auto).
        rewrite app_ass; auto.
      - exists nil, r1, x, m, l; auto.
  Qed.

End flat_map.

Fact in_concat_iff X (ll : list (list X)) x : In x (concat ll) <-> exists l, In x l /\ In l ll.
Proof.
  rewrite <- (map_id ll) at 1.
  rewrite <- flat_map_concat_map, in_flat_map.
  firstorder.
Qed.

Fact flat_map_flat_map X Y Z (f : X -> list Y) (g : Y -> list Z) l :
       flat_map g (flat_map f l) = flat_map (fun x => flat_map g (f x)) l.
Proof.
  induction l; simpl; auto.
  rewrite flat_map_app; f_equal; auto.
Qed.

Fact flat_map_single X Y (f : X -> Y) l : flat_map (fun x => f x::nil) l = map f l.
Proof. induction l; simpl; f_equal; auto. Qed.

Section list_in_map.

  Variable (X Y : Type).

  Fixpoint list_in_map l : (forall x, @In X x l -> Y) -> list Y.
  Proof.
    refine (match l with
      | nil  => fun _ => nil
      | x::l => fun f => f x _ :: @list_in_map l _
    end).
    + left; auto.
    + intros y Hy; apply (f y); right; auto.
  Defined.

  Theorem In_list_in_map l f x (Hx : In x l) : In (f x Hx) (list_in_map l f).
  Proof.
    revert f x Hx.
    induction l as [ | x l IHl ]; intros f y Hy.
    + destruct Hy.
    + destruct Hy as [ -> | Hy ].
      * left; auto.
      * right.
        apply (IHl (fun z Hz => f z (or_intror Hz))).
  Qed.

  Theorem In_list_in_map_inv l f y : In y (list_in_map l f) -> exists x Hx, y = f x Hx.
  Proof.
    revert f y; induction l as [ | x l IHl ]; intros f y; simpl; try tauto.
    intros [ H | H ].
    + now exists x, (or_introl eq_refl).
    + destruct IHl with (1 := H) as (z & Hz & E).
      now exists z, (or_intror Hz).
  Qed.

End list_in_map.

Definition prefix X (l ll : list X) := exists r, ll = l++r.

Infix "<p" := (@prefix _) (at level 70, no associativity).

Section prefix. (* as an inductive predicate *)

  Variable X : Type.

  Implicit Types (l ll : list X).

  Fact in_prefix_0 ll : nil <p ll.
  Proof.
    exists ll; auto.
  Qed.

  Fact in_prefix_1 x l ll : l <p ll -> x::l <p x::ll.
  Proof.
    intros (r & ?); subst; exists r; auto.
  Qed.

  Fact prefix_length l m : l <p m -> length l <= length m.
  Proof. intros (? & ?); subst; rew length; lia. Qed.

  Fact prefix_app_lft l r1 r2 : r1 <p r2 -> l++r1 <p l++r2.
  Proof.
    intros (a & ?); subst.
    exists a; rewrite app_ass; auto.
  Qed.

  Fact prefix_inv x y l ll : x::l <p y::ll -> x = y /\ l <p ll.
  Proof.
    intros (r & Hr).
    inversion Hr; split; auto.
    exists r; auto.
  Qed.

  Fact prefix_list_inv l r rr : l++r <p l++rr -> r <p rr.
  Proof.
    induction l as [ | x l IHl ]; simpl; auto.
    intros H; apply prefix_inv, proj2, IHl in H; auto.
  Qed.

  Fact prefix_refl l : l <p l.
  Proof. exists nil; rewrite <- app_nil_end; auto. Qed.

  Fact prefix_trans l1 l2 l3 : l1 <p l2 -> l2 <p l3 -> l1 <p l3.
  Proof. intros (m1 & H1) (m2 & H2); subst; exists (m1++m2); solve list eq. Qed.

  Section prefix_rect.

    Variables (P : list X -> list X -> Type)
              (HP0 : forall ll, P nil ll)
              (HP1 : forall x l ll, l <p ll -> P l ll -> P (x::l) (x::ll)).

    Definition prefix_rect l ll : prefix l ll -> P l ll.
    Proof using HP0 HP1.
      revert l; induction ll as [ | x ll IHll ]; intros l H.

      replace l with (nil : list X).
      apply HP0.
      destruct H as (r & Hr).
      destruct l; auto; discriminate.

      destruct l as [ | y l ].
      apply HP0.
      apply prefix_inv in H.
      destruct H as (? & E); subst y.
      apply HP1; [ | apply IHll ]; trivial.
    Qed.

  End prefix_rect.

  Fact prefix_app_inv l1 l2 r1 r2 : l1++l2 <p r1++r2 -> { l1 <p r1 } + { r1 <p l1 }.
  Proof.
    revert l2 r1 r2; induction l1 as [ | x l1 IH ].
    left; apply in_prefix_0.
    intros l2 [ | y r1 ] r2.
    right; apply in_prefix_0.
    simpl; intros H; apply prefix_inv in H.
    destruct H as (E & H); subst y.
    destruct IH with (1 := H); [ left | right ];
      apply in_prefix_1; auto.
  Qed.

End prefix.

Definition prefix_spec X (l ll : list X) : l <p ll -> { r | ll = l ++ r }.
Proof.
  induction 1 as [ ll | x l ll _ (r & Hr) ] using prefix_rect.
  exists ll; trivial.
  exists r; simpl; f_equal; auto.
Qed.

Fact prefix_app_lft_inv X (l1 l2 m : list X) : l1++l2 <p m -> { m2 | m = l1++m2 /\ l2 <p m2 }.
Proof.
  intros H.
  apply prefix_spec in H.
  destruct H as (r & H).
  exists (l2++r); simpl.
  solve list eq in H; split; auto.
  exists r; auto.
Qed.

Section list_assoc.

  Variables (X Y : Type) (eq_X_dec : eqdec X).

  Fixpoint list_assoc x l : option Y :=
    match l with
      | nil  => None
      | (y,a)::l => if eq_X_dec x y then Some a else list_assoc x l
    end.

  Fact list_assoc_eq x y l x' : x = x' -> list_assoc x' ((x,y)::l) = Some y.
  Proof.
    intros []; simpl.
    destruct (eq_X_dec x x) as [ | [] ]; auto.
  Qed.

  Fact list_assoc_neq x y l x' : x <> x' -> list_assoc x' ((x,y)::l) = list_assoc x' l.
  Proof.
    intros H; simpl.
    destruct (eq_X_dec x' x) as [ | ]; auto.
    destruct H; auto.
  Qed.

  Fact list_assoc_In x l :
    match list_assoc x l with
      | None   => ~ In x (map fst l)
      | Some y => In (x,y) l
    end.
  Proof.
    induction l as  [ | (x',y) l IHl ]; simpl; auto.
    destruct (eq_X_dec x x'); subst; auto.
    destruct (list_assoc x l); auto.
    intros [ ? | ]; subst; tauto.
  Qed.

  Fact In_list_assoc x l : In x (map fst l) -> { y | list_assoc x l = Some y /\ In (x,y) l }.
  Proof.
    intros H.
    generalize (list_assoc_In x l).
    destruct (list_assoc x l) as [ y | ].
    exists y; auto.
    tauto.
  Qed.

  Fact not_In_list_assoc x l : ~ In x (map fst l) -> list_assoc x l = None.
  Proof.
    intros H.
    generalize (list_assoc_In x l).
    destruct (list_assoc x l) as [ y | ]; auto.
    intros H1; contradict H.
    apply in_map_iff.
    exists (x,y); simpl; auto.
  Qed.

  Fact list_assoc_app x ll mm : list_assoc x (ll++mm)
                              = match list_assoc x ll with
                                  | None   => list_assoc x mm
                                  | Some y => Some y
                                end.
  Proof.
    induction ll as [ | (x',?) ]; simpl; auto.
    destruct (eq_X_dec x x'); auto.
  Qed.

End list_assoc.

Section list_first_dec.

  Variable (X : Type) (P : X -> Prop) (Pdec : forall x, { P x } + { ~ P x }).

  Theorem list_choose_dec ll : { l : _ & { x : _ & { r | ll = l++x::r /\ P x /\ forall y, In y l -> ~ P y } } }
                             + { forall x, In x ll -> ~ P x }.
  Proof using Pdec.
    induction ll as [ | a ll IH ];
      [ | destruct (Pdec a) as [ Ha | Ha ]; [ | destruct IH as [ (l & x & r & H1 & H2 & H3) | H ]] ].
    * right; intros _ [].
    * left; exists nil, a, ll; repeat split; auto.
    * left; exists (a::l), x, r; repeat split; subst; auto.
      intros ? [ | ]; subst; auto.
    * right; intros ? [ | ]; subst; auto.
  Qed.

  Theorem list_first_dec a ll : P a -> In a ll -> { l : _ & { x : _ & { r | ll = l++x::r /\ P x /\ forall y, In y l -> ~ P y } } }.
  Proof using Pdec.
    intros H1 H2.
    destruct (list_choose_dec ll) as [ H | H ]; trivial.
    destruct (H _ H2 H1).
  Qed.

End list_first_dec.

Section list_dec.

  Variable (X : Type) (P Q : X -> Prop) (H : forall x, { P x } + { Q x }).

  Theorem list_dec l : { x | In x l /\ P x } + { forall x, In x l -> Q x }.
  Proof using H.
    induction l as [ | x l IHl ].
    + right; intros _ [].
    + destruct (H x) as [ Hx | Hx ].
      1: { left; exists x; simpl; auto. }
      destruct IHl as [ (y & H1 & H2) | H1 ].
      * left; exists y; split; auto; right; auto.
      * right; intros ? [ -> | ? ]; auto.
  Qed.

End list_dec.

Section map.

  Variable (X Y : Type) (f : X -> Y).

  Fact map_cons_inv ll y m : map f ll = y::m -> { x : _ & { l | ll = x::l /\ f x = y /\ map f l = m } }.
  Proof.
    destruct ll as [ | x l ]; try discriminate; simpl.
    intros H; inversion H; subst; exists x, l; auto.
  Qed.

  Fact map_app_inv ll m n : map f ll = m++n -> { l : _  & { r | ll = l++r /\ m = map f l /\ n = map f r } }.
  Proof.
    revert m n; induction ll as [ | x ll IH ]; intros m n H.
    * destruct m; destruct n; try discriminate; exists nil, nil; auto.
    * destruct m as [ | y m ]; simpl in H.
      + exists nil, (x::ll); auto.
      + inversion H; subst y.
        destruct IH with (1 := H2) as (l & r & H3 & H4 & H5); subst.
        exists (x::l), r; auto.
  Qed.

  Fact map_middle_inv ll m y n : map f ll = m++y::n -> { l : _ & { x : _ & { r | ll = l++x::r /\ map f l = m /\ f x = y /\ map f r = n } } }.
  Proof.
    intros H.
    destruct map_app_inv with (1 := H) as (l & r & H1 & H2 & H3).
    symmetry in H3.
    destruct map_cons_inv with (1 := H3) as (x & r' & H4 & H5 & H6); subst.
    exists l, x, r'; auto.
  Qed.

  Fact map_duplicate_inv ll l' y1 m' y2 r' :
            map f ll = l'++y1::m'++y2::r'
       -> { l : _ &
          { x1 : _ &
          { m : _ &
          { x2 : _ &
          { r | l' = map f l /\ y1 = f x1
             /\ m' = map f m /\ y2 = f x2
             /\ r' = map f r /\ ll = l++x1::m++x2::r } } } } }.
  Proof.
    intros H1.
    apply map_middle_inv in H1.
    destruct H1 as (l & x1 & k & H1 & H3 & H4 & H5).
    apply map_middle_inv in H5.
    destruct H5 as (m & x2 & r & -> & H6 & H7 & H8).
    now exists l, x1, m, x2, r.
  Qed.

End map.

Fact Forall2_mono X Y (R S : X -> Y -> Prop) :
         (forall x y, R x y -> S x y) -> forall l m, Forall2 R l m -> Forall2 S l m.
Proof.
  induction 2; constructor; auto.
Qed.

Fact Forall2_nil_inv_l X Y R m : @Forall2 X Y R nil m -> m = nil.
Proof.
  inversion_clear 1; reflexivity.
Qed.

Fact Forall2_nil_inv_r X Y R m : @Forall2 X Y R m nil -> m = nil.
Proof.
  inversion_clear 1; reflexivity.
Qed.

Fact Forall2_cons_inv X Y R x l y m : @Forall2 X Y R (x::l) (y::m) <-> R x y /\ Forall2 R l m.
Proof.
  split.
  inversion_clear 1; auto.
  intros []; constructor; auto.
Qed.

Fact Forall2_app_inv_l X Y R l1 l2 m :
    @Forall2 X Y R (l1++l2) m -> { m1 : _ & { m2 | Forall2 R l1 m1 /\ Forall2 R l2 m2 /\ m = m1++m2 } }.
Proof.
  revert l2 m;
  induction l1 as [ | x l1 IH ]; simpl; intros l2 m H.
  exists nil, m; repeat split; auto.
  destruct m as [ | y m ].
  apply Forall2_nil_inv_r in H; discriminate H.
  apply Forall2_cons_inv in H; destruct H as [ H1 H2 ].
  apply IH in H2.
  destruct H2 as (m1 & m2 & H2 & H3 & H4); subst m.
  exists (y::m1), m2; repeat split; auto.
Qed.

Fact Forall2_app_inv_r X Y R l m1 m2 :
    @Forall2 X Y R l (m1++m2) -> { l1 : _ & { l2 | Forall2 R l1 m1 /\ Forall2 R l2 m2 /\ l = l1++l2 } }.
Proof.
  revert m2 l;
  induction m1 as [ | y m1 IH ]; simpl; intros m2 l H.
  exists nil, l; repeat split; auto.
  destruct l as [ | x l ].
  apply Forall2_nil_inv_l in H; discriminate H.
  apply Forall2_cons_inv in H; destruct H as [ H1 H2 ].
  apply IH in H2.
  destruct H2 as (l1 & l2 & H2 & H3 & H4); subst l.
  exists (x::l1), l2; repeat split; auto.
Qed.

Fact Forall2_cons_inv_l X Y R a ll mm :
      @Forall2 X Y R (a::ll) mm
   -> { b : _ & { mm' | R a b /\ mm = b::mm' /\ Forall2 R ll mm' } }.
Proof.
  intros H.
  apply Forall2_app_inv_l with (l1 := a::nil) (l2 := ll) in H.
  destruct H as (l & mm' & H1 & H2 & H3).
  destruct l as [ | y l ].
  exfalso; inversion H1.
  apply Forall2_cons_inv in H1.
  destruct H1 as [ H1 H4 ].
  apply Forall2_nil_inv_l in H4; subst l.
  exists y, mm'; auto.
Qed.

Fact Forall2_cons_inv_r X Y R b ll mm :
      @Forall2 X Y R ll (b::mm)
   -> { a : _ & { ll' | R a b /\ ll = a::ll' /\ Forall2 R ll' mm } }.
Proof.
  intros H.
  apply Forall2_app_inv_r with (m1 := b::nil) (m2 := mm) in H.
  destruct H as (l & ll' & H1 & H2 & H3).
  destruct l as [ | x l  ].
  exfalso; inversion H1.
  apply Forall2_cons_inv in H1.
  destruct H1 as [ H1 H4 ].
  apply Forall2_nil_inv_r in H4; subst l.
  exists x, ll'; auto.
Qed.

Fact Forall2_map_left X Y Z (R : Y -> X -> Prop) (f : Z -> Y) ll mm : Forall2 R (map f ll) mm <-> Forall2 (fun x y => R (f x) y) ll mm.
Proof.
  split.
  revert mm.
  induction ll; intros [ | y mm ] H; simpl in H; auto; try (inversion H; fail).
  apply Forall2_cons_inv in H; constructor.
  tauto.
  apply IHll; tauto.
  induction 1; constructor; auto.
Qed.

Fact Forall2_map_right X Y Z (R : Y -> X -> Prop) (f : Z -> X) mm ll : Forall2 R mm (map f ll) <-> Forall2 (fun y x => R y (f x)) mm ll.
Proof.
  split.
  revert mm.
  induction ll; intros [ | y mm ] H; simpl in H; auto; try (inversion H; fail).
  apply Forall2_cons_inv in H; constructor.
  tauto.
  apply IHll; tauto.
  induction 1; constructor; auto.
Qed.

Fact Forall2_map_both X Y X' Y' (R : X -> Y -> Prop) (f : X' -> X) (g : Y' -> Y) ll mm : Forall2 R (map f ll) (map g mm) <-> Forall2 (fun x y => R (f x) (g y)) ll mm.
Proof.
  rewrite Forall2_map_left, Forall2_map_right; split; auto.
Qed.

Fact Forall2_Forall X (R : X -> X -> Prop) ll : Forall2 R ll ll <-> Forall (fun x => R x x) ll.
Proof.
  split.
  induction ll as [ | x ll ]; inversion_clear 1; auto.
  induction 1; auto.
Qed.

Fact Forall_app X (P : X -> Prop) ll mm : Forall P (ll++mm) <-> Forall P ll /\ Forall P mm.
Proof.
  repeat rewrite Forall_forall.
  split.
  firstorder.
  1,2: eapply H, in_app_iff; eauto.
  intros (H1 & H2) x Hx.
  apply in_app_or in Hx; firstorder.
Qed.

Fact Forall_cons_inv X (P : X -> Prop) x ll : Forall P (x::ll) <-> P x /\ Forall P ll.
Proof.
  split.
  + inversion 1; auto.
  + constructor; tauto.
Qed.

Fact Forall_rev X (P : X -> Prop) ll : Forall P ll -> Forall P (rev ll).
Proof.
  induction 1 as [ | x ll Hll IH ].
  constructor.
  simpl.
  apply Forall_app; split; auto.
Qed.

Fact Forall_map X Y (f : X -> Y) (P : Y -> Prop) ll : Forall P (map f ll) <-> Forall (fun x => P (f x)) ll.
Proof.
  split.
  + induction ll; simpl; try rewrite Forall_cons_inv; constructor; tauto.
  + induction 1; simpl; constructor; auto.
Qed.

Fact Forall_forall_map X (f : nat -> X) n l (P : X -> Prop) :
           l = map f (list_an 0 n) -> (forall i, i < n -> P (f i)) <-> Forall P l.
Proof.
  intros Hl; rewrite Forall_forall.
  split.
  + intros H x; rewrite Hl, in_map_iff.
    intros (y & ? & H1).
    apply list_an_spec in H1; subst; apply H; lia.
  + intros H x Hx; apply H; rewrite Hl, in_map_iff.
    exists x; split; auto; apply list_an_spec; lia.
Qed.

Fact Forall_impl X (P Q : X -> Prop) ll : (forall x, In x ll -> P x -> Q x) -> Forall P ll -> Forall Q ll.
Proof.
  intros H; induction 1 as [ | x ll Hx Hll IH ]; constructor.
  + apply H; simpl; auto.
  + apply IH; intros ? ?; apply H; simpl; auto.
Qed.

Fact Forall_filter X (P : X -> Prop) (f : X -> bool) ll : Forall P ll -> Forall P (filter f ll).
Proof. induction 1; simpl; auto; destruct (f x); auto. Qed.

Section list_discrim.

  Variable (X : Type) (P Q : X -> Prop) (PQdec : forall x, { P x } + { Q x}).

  Definition list_discrim l : { lP : _ & { lQ | l ~p lP++lQ /\ Forall P lP /\ Forall Q lQ } }.
  Proof using PQdec.
    induction l as [ | x l (lP & lQ & H1 & H2 & H3) ].
    + exists nil, nil; simpl; auto.
    + destruct (PQdec x) as [ H | H ].
      * exists (x::lP), lQ; repeat split; auto; constructor; auto.
      * exists lP, (x::lQ); repeat split; auto.
        apply Permutation_cons_app; auto.
  Qed.

End list_discrim.


(* For the first part of this assignment, I'd like you to construct
   proof terms manually, as we did at the beginning of class, instead
   of using tactics.

   For each Definition provided, please replace the "." with
   ":= <exp>." for some expression of the appropriate type.
*)

Module PSET1_EX1.

  Definition X1 {A B C D:Prop} :
    (B /\ (B -> C /\ D)) -> D :=
      fun H1 => match H1 with
        | conj H2 H3 => match (H3 H2) with
          | conj H4 H5 => H5
        end
      end.

  Definition X2 {A B C:Prop} :
   ~(A \/ B) -> B -> C :=
    fun H1 H2 => match (H1 (or_intror H2)) with
    end.

  Definition X3 {A B C:Prop} :
    A /\ (B \/ C) -> (A /\ B) \/ (A /\ C) :=
      fun H1 =>
        match H1 with
          | conj H2 H3 => match H3 with
            | or_intror H4 => or_intror (conj H2 H4)
            | or_introl H4 => or_introl (conj H2 H4)
          end
        end.

  Locate "_ <-> _".

  (* To solve the following, you'll need to figure out what
     the definition of "<->" is and how to work with it... *)
  Definition X4 {A:Prop} :
    A <-> A :=
      (conj (fun H1 => H1) (fun H1 => H1)).

  Definition swap {A B:Prop} (H1: A <-> B) : (B <-> A) :=
    match H1 with
      | conj H2 H3 => conj H3 H2
    end.

  Definition X5 {A B:Prop} :
    (A <-> B) <-> (B <-> A) :=
      (conj swap swap).

  Definition compose {A B C} (g : B -> C) (f : A -> B) :=
  fun x : A => g (f x).

  Definition X6 {A B C:Prop} :
    (A <-> B) -> (B <-> C) -> (A <-> C) :=
      fun (H1: A <-> B) (H2: B <-> C) =>
        match H1, H2 with
          | conj H3 H4, conj H5 H6 => (conj (compose H5 H3) (compose H4 H6))
        end.

  (* Thought exercise:  *)

  (* This is not provable in Coq without adding an axiom, even
     though in classical logic, we take this for granted:

     P \/ ~P

     Try to prove it and see what goes wrong...  Interestingly,
     this will almost never bite us.
  *)
End PSET1_EX1.

(* Now re-do these using only the following tactics:

   intros, apply, destruct, unfold, split, contradiction, left, right

   Hopefully I haven't left off any that you may need.  In general,
   I don't want you using something such as firstorder or tauto
   that trivially solves the goal.  I want you to perform the basic
   steps.
*)
Module PSET1_EX2.

  Lemma X1 {A B C D:Prop} :
    (B /\ (B -> C /\ D)) -> D.
  Proof.
    intros.
    destruct H.
    apply H0.
    apply H.
  Qed.

  Lemma X2 {A B C:Prop} :
    ~(A \/ B) -> B -> C.
  Proof.
    intros.
    destruct H.
    right.
    apply H0.
  Qed.

  Lemma X3 {A B C:Prop} :
    A /\ (B \/ C) -> (A /\ B) \/ (A /\ C).
  Proof.
    intros.
    destruct H.
    destruct H0.
    left.
    split.
    apply H.
    apply H0.
    right.
    split.
    apply H.
    apply H0.
  Qed.

  Lemma X4 {A:Prop} :
    A <-> A.
  Proof.
    split.
    intros.
    apply H.
    intros.
    apply H.
  Qed.

  Lemma X5 {A B:Prop} :
    (A <-> B) <-> (B <-> A).
  Proof.
    split.
    intros.
    split.
    intros.
    apply H.
    apply H0.
    apply H.
    intros.
    split.
    apply H.
    apply H.
  Qed.

  Lemma X6 {A B C:Prop} :
    (A <-> B) -> (B <-> C) -> (A <-> C).
  Proof.
    intros.
    split.
    intros.
    apply H0.
    apply H.
    apply H1.
    intros.
    apply H.
    apply H0.
    apply H1.
  Qed.

End PSET1_EX2.

(* Here, we're going to exercise the [simpl], [induction] and [rewrite] tactics.
   Replace the [Admitted.]'s with an appropriate proof.
   Don't forget to write "Qed." to terminate your proofs.  It goes
   without saying that you shouldn't just prove these by using a
   library lemma :-)  However, if you get stuck proving one of these, then
   it is sometimes useful to look for one that does solve this, using
   the top-level [SearchAbout] command, and then [Print] the corresponding
   proof.
*)
Module PSET1_EX3.
  Require Import List.
  Require Import Arith.

  Lemma zero_plus_x : forall n, 0 + n = n.
  Proof.
    simpl.
    intros.
    apply eq_refl.
  Qed.

  Lemma x_plus_zero : forall n, n + 0 = n.
  Proof.
    intros.
    auto.
  Qed.

  Lemma map_map : forall {A B C:Type} (f:A->B) (g:B -> C) (xs:list A),
    map g (map f xs) = map (fun x => g (f x)) xs.
  Proof.
    intros.
    induction xs.
    reflexivity.
    simpl.
    rewrite -> IHxs.
    reflexivity.
  Qed.

  Lemma app_assoc : forall {A:Type} (xs ys zs:list A),
    xs ++ (ys ++ zs) = (xs ++ ys) ++ zs.
  Proof.
    intros.
    induction xs.
    simpl.
    reflexivity.
    simpl.
    rewrite <- IHxs.
    reflexivity.
  Qed.

  Lemma map_is_fold : forall {A B} (f:A->B) (xs:list A),
    map f xs = fold_right (fun x y => (f x)::y) nil xs.
  Proof.
    intros.
    induction xs.
    simpl.
    reflexivity.
    simpl.
    rewrite <- IHxs.
    reflexivity.
  Qed.

  Definition list_sum (xs:list nat) : nat := fold_right plus 0 xs.

  Print plus.

  Lemma my_plus_assoc : forall (a b c: nat), a + (b + c) = (a + b) + c.
  Proof.
    intros.
    unfold plus.
    induction a.
    simpl.
    reflexivity.
    rewrite IHa.
    reflexivity.
  Qed.

  Lemma list_sum_app : forall (t1 t2: list nat),
     list_sum (t1 ++ t2) = list_sum t1 + list_sum t2.
  Proof.
    intros.
    induction t1.
    simpl.
    reflexivity.
    simpl.
    rewrite IHt1.
    rewrite my_plus_assoc.
    reflexivity.
  Qed.

  Inductive tree(A:Type) : Type :=
    | Leaf : tree A
    | Node : tree A -> A -> tree A -> tree A.
  Implicit Arguments Leaf [A].
  Implicit Arguments Node [A].

  Fixpoint mirror{A:Type} (t:tree A) : tree A :=
    match t with
      | Leaf => Leaf
      | Node lft v rgt => Node (mirror rgt) v (mirror lft)
    end.

  Lemma mirror_mirror : forall A (t:tree A), mirror (mirror t) = t.
  Proof.
    intros.
    induction t.
    simpl.
    reflexivity.
    simpl.
    rewrite -> IHt1.
    rewrite -> IHt2.
    reflexivity.
  Qed.

  Fixpoint flatten {A:Type} (t:tree A) : list A :=
    match t with
      | Leaf => nil
      | Node lft v rgt => (flatten lft) ++ v::(flatten rgt)
    end.

  Fixpoint tree_sum (t:tree nat) : nat :=
    match t with
      | Leaf => 0
      | Node lft v rgt => (tree_sum lft) + v + (tree_sum rgt)
    end.

  Lemma tree_flatten_sum : forall t, tree_sum t = list_sum (flatten t).
  Proof.
    intros.
    induction t.
    simpl.
    reflexivity.
    simpl.
    rewrite list_sum_app.
    rewrite <- IHt1.
    simpl.
    rewrite <- IHt2.
    rewrite my_plus_assoc.
    reflexivity.
  Qed.

End PSET1_EX3.


Set Implicit Arguments.

From TLC Require Import LibLN.

Require Import DeclDef.

(** Computing free term variables in a term *)

Fixpoint dfv_ee (e : dtrm) {struct e} : vars :=
  match e with
  | dtrm_bvar i       => \{}
  | dtrm_fvar x       => \{x}
  | dtrm_nat i        => \{}
  | dtrm_absann V e1  => (dfv_ee e1)
  | dtrm_abs e1       => (dfv_ee e1)
  | dtrm_app e1 e2    => (dfv_ee e1) \u (dfv_ee e2)
  | dtrm_let e1 e2    => (dfv_ee e1) \u (dfv_ee e2)
  end.

(** Substitution for free term variables in terms. *)

Fixpoint dsubst_ee (z : var) (u : dtrm) (e : dtrm) {struct e} : dtrm :=
  match e with
  | dtrm_bvar i       => dtrm_bvar i
  | dtrm_fvar x       => If x = z then u else (dtrm_fvar x)
  | dtrm_nat i        => dtrm_nat i
  | dtrm_absann V e1  => dtrm_absann V (dsubst_ee z u e1)
  | dtrm_abs e1       => dtrm_abs (dsubst_ee z u e1)
  | dtrm_app e1 e2    => dtrm_app (dsubst_ee z u e1) (dsubst_ee z u e2)
  | dtrm_let e1 e2    => dtrm_let (dsubst_ee z u e1) (dsubst_ee z u e2)
  end.

(** Computing free type variables in a type *)

Fixpoint dfv_tt (T : dtyp) {struct T} : vars :=
  match T with
  | dtyp_nat         => \{}
  | dtyp_unknown     => \{}
  | dtyp_bvar J      => \{}
  | dtyp_fvar X      => \{X}
  | dtyp_arrow T1 T2 => (dfv_tt T1) \u (dfv_tt T2)
  | dtyp_all T1      => (dfv_tt T1)
  end.

(** Substitution for free type variables in types. *)

Fixpoint dsubst_tt (Z : var) (U : dtyp) (T : dtyp) {struct T} : dtyp :=
  match T with
  | dtyp_nat         => dtyp_nat
  | dtyp_unknown     => dtyp_unknown
  | dtyp_bvar J      => dtyp_bvar J
  | dtyp_fvar X      => If X = Z then U else (dtyp_fvar X)
  | dtyp_arrow T1 T2 => dtyp_arrow (dsubst_tt Z U T1) (dsubst_tt Z U T2)
  | dtyp_all T1      => dtyp_all (dsubst_tt Z U T1)
  end.

(** Substitution for free type variables in environment. *)

Definition dsubst_tb (Z : var) (P : dtyp) (b : dbind) : dbind :=
  match b with
  | dbind_tvar => dbind_tvar
  | dbind_typ T => dbind_typ (dsubst_tt Z P T)
  end.

(** Computing free type variables in a env *)

Fixpoint dfv_tt_env (E : denv) {struct E} : vars :=
  match E with
  | nil                      => \{}
  | cons (x, dbind_typ t) E' => dfv_tt t \u dfv_tt_env E'
  | cons (x, dbind_tvar) E'  => dfv_tt_env E'
  end.

(** * Tactics *)

(** Constructors as hints. *)

Hint Constructors dtype dterm dokt dokt dtyp_mono.

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => \{x}) in
  let C := gather_vars_with (fun x : dtrm => dfv_ee x) in
  let D := gather_vars_with (fun x : dtyp => dfv_tt x) in
  let E := gather_vars_with (fun x : denv => dom x) in
  let F := gather_vars_with (fun x : denv => dfv_tt_env x) in
  constr:(A \u B \u C \u D \u E \u F).

(** "pick_fresh x" tactic create a fresh variable with name x *)

Ltac pick_fresh X :=
  let L := gather_vars in (pick_fresh_gen L X).

(** "apply_fresh T as x" is used to apply inductive rule which
   use an universal quantification over a cofinite set *)

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.

Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) :=
  apply_fresh T as x; autos*.

(* ********************************************************************** *)
(** ** Properties of type substitution in type *)

(** Substitution on indices is identity on well-formed terms. *)

Lemma dopen_tt_rec_type_core : forall T j V U i, i <> j ->
  (dopen_tt_rec j V T) = dopen_tt_rec i U (dopen_tt_rec j V T) ->
  T = dopen_tt_rec i U T.
Proof.
  induction T; introv Neq H; simpl in *; inversion H; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma dopen_tt_rec_type : forall T U,
  dtype T -> forall k, T = dopen_tt_rec k U T.
Proof.
  induction 1; intros; simpl; f_equal*.
  pick_fresh X. apply* (@dopen_tt_rec_type_core T2 0 (dtyp_fvar X)).
Qed.

(** Substitution for a fresh name is identity. *)

Lemma dsubst_tt_fresh : forall Z U T,
  Z \notin dfv_tt T -> dsubst_tt Z U T = T.
Proof.
  induction T; simpl; intros; f_equal*.
  case_var*.
Qed.

(** Substitution distributes on the open operation. *)

Lemma dsubst_tt_open_tt_rec : forall T1 T2 X P n, dtype P ->
  dsubst_tt X P (dopen_tt_rec n T2 T1) =
  dopen_tt_rec n (dsubst_tt X P T2) (dsubst_tt X P T1).
Proof.
  introv WP. generalize n.
  induction T1; intros k; simpls; f_equal*.
  case_nat*.
  case_var*. rewrite* <- dopen_tt_rec_type.
Qed.

Lemma dsubst_tt_open_tt : forall T1 T2 X P, dtype P ->
  dsubst_tt X P (dopen_tt T1 T2) =
  dopen_tt (dsubst_tt X P T1) (dsubst_tt X P T2).
Proof.
  unfold dopen_tt. autos* dsubst_tt_open_tt_rec.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma dsubst_tt_open_tt_var : forall X Y U T, Y <> X -> dtype U ->
  (dsubst_tt X U T) dopen_tt_var Y = dsubst_tt X U (T dopen_tt_var Y).
Proof.
  introv Neq Wu. rewrite* dsubst_tt_open_tt.
  simpl. case_var*.
Qed.

(** Opening up a body t with a type u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma dsubst_tt_intro : forall X T2 U,
  X \notin dfv_tt T2 -> dtype U ->
  dopen_tt T2 U = dsubst_tt X U (T2 dopen_tt_var X).
Proof.
  introv Fr Wu. rewrite* dsubst_tt_open_tt.
  rewrite* dsubst_tt_fresh. simpl. case_var*.
Qed.

Lemma dsubst_tt_rec_intro : forall X T2 U k,
  X \notin dfv_tt T2 -> dtype U ->
  dopen_tt_rec k U T2 = dsubst_tt X U (dopen_tt_rec k (dtyp_fvar X) T2).
Proof.
  introv Fr Wu. rewrite* dsubst_tt_open_tt_rec.
  simpls. case_var~.
  rewrite* dsubst_tt_fresh.
Qed.

Lemma dopen_tt_rec_type_commu : forall e j v u i, i <> j ->
  dtype v -> dtype u ->
  dopen_tt_rec j v (dopen_tt_rec i u e) = dopen_tt_rec i u (dopen_tt_rec j v e).
Proof.
  induction e; introv Neq tv tu; simpl in *; auto.
  f_equal*.
  case_nat*. case_nat*. simpls. case_nat*.
  symmetry. apply~ dopen_tt_rec_type.
  case_nat*.
  simpls. case_nat*.
  apply~ dopen_tt_rec_type.
  simpls. case_nat*. case_nat*.
  f_equal*.
Qed.

(** substitute a mono type with a mono type gives back mono type **)

Lemma dsubst_mono: forall U u z,
    dtyp_mono U ->
    dtyp_mono u ->
    dtyp_mono (dsubst_tt z u U).
Proof.
  introv mu me. inductions mu; simpls; auto.
  case_var*.
Qed.

Lemma dtyp_mono_dtype: forall A,
    dtyp_mono A ->
    dtype A.
Proof.
  introv mn. inductions mn; auto.
Qed.

(** Substitutions preserve local closure. *)

Lemma dsubst_tt_type : forall T Z P,
  dtype T -> dtype P -> dtype (dsubst_tt Z P T).
Proof.
  induction 1; intros; simpl; auto.
  case_var*.
  apply_fresh* dtype_all as X. rewrite* dsubst_tt_open_tt_var.
Qed.

(* ********************************************************************** *)
(** ** Properties of term substitution in terms *)

Lemma dopen_ee_rec_term_core : forall e j v u i, i <> j ->
  dopen_ee_rec j v e = dopen_ee_rec i u (dopen_ee_rec j v e) ->
  e = dopen_ee_rec i u e.
Proof.
  induction e; introv Neq H; simpl in *; inversion H; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma dopen_ee_rec_term : forall u e,
  dterm e -> forall k, e = dopen_ee_rec k u e.
Proof.
  induction 1; intros; simpl; f_equal*.
  unfolds dopen_ee. pick_fresh x.
   apply* (@dopen_ee_rec_term_core e1 0 (dtrm_fvar x)).
  unfolds dopen_ee. pick_fresh x.
   apply* (@dopen_ee_rec_term_core e1 0 (dtrm_fvar x)).
  unfolds dopen_ee. pick_fresh x.
   apply* (@dopen_ee_rec_term_core e2 0 (dtrm_fvar x)).
Qed.

(** Substitution for a fresh name is identity. *)

Lemma dsubst_ee_fresh : forall x u e,
  x \notin dfv_ee e -> dsubst_ee x u e = e.
Proof.
  induction e; simpl; intros; f_equal*.
  case_var*.
Qed.

(** Substitution distributes on the open operation. *)

Lemma dsubst_ee_open_ee : forall t1 t2 u x, dterm u ->
  dsubst_ee x u (dopen_ee t1 t2) =
  dopen_ee (dsubst_ee x u t1) (dsubst_ee x u t2).
Proof.
  intros. unfold dopen_ee. generalize 0.
  induction t1; intros; simpls; f_equal*.
  case_nat*.
  case_var*. rewrite* <- dopen_ee_rec_term.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma dsubst_ee_open_ee_var : forall x y u e, y <> x -> dterm u ->
  (dsubst_ee x u e) dopen_ee_var y = dsubst_ee x u (e dopen_ee_var y).
Proof.
  introv Neq Wu. rewrite* dsubst_ee_open_ee.
  simpl. case_var*.
Qed.

(** Opening up a body t with a type u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma dsubst_ee_intro : forall x u e,
  x \notin dfv_ee e -> dterm u ->
  dopen_ee e u = dsubst_ee x u (e dopen_ee_var x).
Proof.
  introv Fr Wu. rewrite* dsubst_ee_open_ee.
  rewrite* dsubst_ee_fresh. simpl. case_var*.
Qed.

(** Substitutions preserve local closure. *)

Lemma dsubst_ee_term : forall e1 Z e2,
  dterm e1 -> dterm e2 -> dterm (dsubst_ee Z e2 e1).
Proof.
  induction 1; intros; simpl; auto.
  case_var*.
  apply_fresh* dterm_absann as y. rewrite* dsubst_ee_open_ee_var.
  apply_fresh* dterm_abs as y. rewrite* dsubst_ee_open_ee_var.
  apply_fresh* dterm_let as y. rewrite* dsubst_ee_open_ee_var.
Qed.

Lemma dterm_subst : forall t z u,
    dterm t ->
    dterm (dsubst_ee z (dtrm_fvar u) t)
.
Proof.
  introv typt.
  apply* dsubst_ee_term.
Qed.

Lemma dterm_rename : forall x y S,
  dterm (S dopen_ee_var x) ->
  x \notin dfv_ee S ->
  y \notin dfv_ee S ->
  dterm (S dopen_ee_var y).
Proof.
  introv Typx Frx Fry.
  tests: (x = y). subst*.
  rewrite~ (@dsubst_ee_intro x).
  apply~ dterm_subst.
Qed.

Hint Resolve dsubst_tt_type dsubst_ee_term.

(** Open_var with fresh names is an injective operation *)

Lemma dopen_ee_rec_inj : forall x t1 t2 k,
  x \notin (dfv_ee t1) -> x \notin (dfv_ee t2) ->
  (dopen_ee_rec k (dtrm_fvar x) t1 = dopen_ee_rec k (dtrm_fvar x) t2) -> (t1 = t2).
Proof.
  intros x t1.
  induction t1; intros t2 k; destruct t2; simpl; intros; inversion H1;
  try solve [ f_equal*
  | do 2 try case_nat; inversions* H1; try notin_false ].
Qed.

Lemma dopen_tt_rec_inj : forall x t1 t2 k,
  x \notin (dfv_tt t1) -> x \notin (dfv_tt t2) ->
  (dopen_tt_rec k (dtyp_fvar x) t1 = dopen_tt_rec k (dtyp_fvar x) t2) -> (t1 = t2).
Proof.
  intros x t1.
  induction t1; intros t2 k; destruct t2; simpl; intros; inversion H1;
  try solve [ f_equal*
  | do 2 try case_nat; inversions* H1; try notin_false ].
Qed.

Hint Resolve dopen_ee_rec_inj dopen_tt_rec_inj.

(** More properties about free variables *)

Lemma notin_subst: forall x A B,
    x \notin dfv_tt A ->
    x \notin dfv_tt (dsubst_tt x A B).
Proof.
  introv neq. inductions B; simpls~.
  case_var~.
  simpls~.
Qed.

Lemma dnotin_fv_tt_subst_inv: forall V z x U,
    z \notin dfv_tt U ->
    z \notin dfv_tt V ->
    z <> x ->
    z \notin dfv_tt (dsubst_tt x U V).
Proof.
  induction V; introv notinu notinv neq; simpls~.
  case_var~.
Qed.

Hint Resolve dnotin_fv_tt_subst_inv.

(* ********************************************************************** *)
(** ** Free Variables *)

Lemma din_open_tt_rec: forall x T k U,
    x \in dfv_tt T ->
    x \in dfv_tt (dopen_tt_rec k U T).
Proof.
  intros. gen x k U. induction T; simpls~; intros.
  rewrite in_union in *.
  destruct H.
  left. apply* IHT1.
  right. apply* IHT2.
  case_nat~.
  rewrite in_empty in H. false~.
Qed.

Lemma din_open_tt_var: forall x T y,
    x \in dfv_tt T ->
    x \in dfv_tt (T dopen_tt_var y).
Proof.
  intros. unfolds dopen_tt. apply* din_open_tt_rec.
Qed.

Lemma dnotin_fv_tt_open : forall Y X T,
  X \notin dfv_tt (T dopen_tt_var Y) ->
  X \notin dfv_tt T.
Proof.
 introv. unfold dopen_tt. generalize 0.
 induction T; simpl; intros k Fr; auto.
 specializes IHT1 k. specializes IHT2 k. auto.
 specializes IHT (S k). auto.
Qed.

Lemma dnotin_fv_tt_dopen : forall Y X T,
  X \notin dfv_tt (dopen_tt T Y) ->
  X \notin dfv_tt T.
Proof.
 introv. unfold dopen_tt. generalize 0.
 induction T; simpl; intros k Fr; auto.
 specializes IHT1 k. specializes IHT2 k. auto.
 specializes IHT (S k). auto.
Qed.

Lemma dnotin_fv_tt_open_inv : forall X T U k,
  X \notin dfv_tt T ->
  X \notin dfv_tt U ->
  X \notin dfv_tt (dopen_tt_rec k U T).
Proof.
  introv notint notinu. gen k.
  inductions T; introv; simpls~.
  case_nat*.
Qed.

Lemma  dfv_tt_env_push_typ_inv: forall G x v,
  dfv_tt_env (G & x ~: v) = dfv_tt v \u dfv_tt_env G.
Proof.
  introv.
  rewrite <- cons_to_push.
  simpls~.
Qed.

Lemma  dfv_tt_env_push_tvar_inv: forall G x,
  dfv_tt_env (G & x ~tvar) = dfv_tt_env G.
Proof.
  introv.
  rewrite <- cons_to_push.
  simpls~.
Qed.

Lemma dnotin_fv_tt_env_bind_inv: forall E x T y,
    binds y (dbind_typ T) E ->
    x \notin dfv_tt_env E ->
    x \notin dfv_tt T.
Proof.
  induction E using env_ind; introv bd hy.
  false* binds_empty_inv.
  apply binds_push_inv in bd.
  destruct bd as [[v1 v2]| [v3 v4]].
  subst. rewrite dfv_tt_env_push_typ_inv in hy. autos*.
  apply* IHE.
  destruct v.
  rewrite dfv_tt_env_push_tvar_inv in hy; auto.
  rewrite dfv_tt_env_push_typ_inv in hy; auto.
Qed.

(* ********************************************************************** *)
(** * Relations between well-formed environment and types well-formed
  in environments *)

Lemma dtype_open : forall U T2,
  dtype (dtyp_all T2) ->
  dtype U ->
  dtype (dopen_tt T2 U).
Proof.
  introv WA WU. inversions WA. pick_fresh X.
  rewrite* (@dsubst_tt_intro X).
Qed.

(** If an environment is well-formed, then it does not contain duplicated keys. *)

Lemma dok_from_okt : forall E,
  dokt E -> ok E.
Proof.
  induction 1; auto.
Qed.

Hint Extern 1 (ok _) => apply dok_from_okt.

Lemma dokt_push_inv : forall E x T,
  dokt (E & x ~ T) -> dokt E /\  x # E.
Proof.
  introv O. inverts O.
    false* empty_push_inv.
    lets (?&M&?): (eq_push_inv H). subst. auto.
    lets (?&M&?): (eq_push_inv H). subst. auto.
Qed.

Lemma dokt_push_typ_inv : forall E x T,
  dokt (E & x ~ dbind_typ T) -> dwft E T.
Proof.
  introv O. inverts O.
    false* empty_push_inv.
    lets (?&M&?): (eq_push_inv H). subst. false H.
    lets (?&M&?): (eq_push_inv H). subst. inversions~ M.
Qed.

Lemma dwft_ok: forall E t,
    dwft E t ->
    ok E.
Proof.
  introv wf. inductions wf; simpls~.
  pick_fresh y.
  forwards ~ : H0 y.
Qed.

Lemma dwft_dtype: forall E t,
    dwft E t ->
    dtype t.
Proof.
  introv wf. inductions wf; simpls~.
  apply_fresh dtype_all as x.
  apply* H0.
Qed.

Hint Resolve dwft_ok dwft_dtype.

Hint Extern 1 (ok ?E) =>
  match goal with
  | H: dwft _ _ |- _ => apply (dwft_ok H)
  end.

Hint Extern 1 (dtype ?E) =>
  match goal with
  | H: dwft _ _ |- _ => apply (dwft_dtype H)
  end.

Hint Constructors dwft.
Lemma dwft_weakening : forall F x U E v,
    dwft (E & F) U ->
    ok (E & x ~ v & F) ->
    dwft (E & x ~ v & F) U.
Proof.
  introv wf okt. gen v.
  inductions wf; introv okt; auto.
  apply~ dwft_var.
  apply~ binds_weaken.

  apply_fresh dwft_all as x.
  rewrite <- concat_assoc.
  apply~ H0.
  rewrite~ concat_assoc.
  rewrite~ concat_assoc.
Qed.

Lemma dwft_push : forall x U E v,
    dwft E U ->
    ok (E & x ~ v) ->
    dwft (E & x ~ v) U.
Proof.
  intros.
  apply_empty~ dwft_weakening.
Qed.

Lemma dwft_strengthen : forall F E x A v,
    dwft (E & x ~ v & F) A ->
    x \notin dfv_tt A ->
    dwft (E & F) A.
Proof.
  introv wf1 notin.
  inductions wf1; try(constructor~); simpls~.

  apply binds_remove in H0; auto.
  apply~ IHwf1_1.
  apply~ IHwf1_2.

  apply_fresh dwft_all as x.
  rewrite <- concat_assoc.
  apply~ H0.
  rewrite~ concat_assoc.
  apply~ dnotin_fv_tt_open_inv.
  simpls~.
Qed.

Lemma dwft_weaken : forall G T E F,
  dwft (E & G) T ->
  ok (E & F & G) ->
  dwft (E & F & G) T.
Proof.
  intros. gen_eq K: (E & G). gen E F G.
  induction H; intros; subst; eauto.
  (* case: var *)
  apply* dwft_var. apply* binds_weaken.
  (* case: all *)
  apply_fresh* dwft_all as Y. apply_ih_bind* H0.
Qed.

Lemma dwft_strengthen_push : forall E x A v,
    dwft (E & x ~ v) A ->
    x \notin dfv_tt A ->
    dwft (E) A.
Proof.
  intros.
  apply_empty* dwft_strengthen.
Qed.

Lemma dwft_strengthen_typ : forall F E x A v,
    dwft (E & x ~: v & F) A ->
    dwft (E & F) A.
Proof.
  introv wf1.
  inductions wf1; try(constructor~); simpls~.

  tests : (x = x0).
  apply binds_middle_eq_inv in H0; auto.
  inversions H0.
  apply binds_remove in H0; auto.
  apply~ IHwf1_1.
  apply~ IHwf1_2.

  apply_fresh dwft_all as x.
  rewrite <- concat_assoc.
  apply~ H0.
  rewrite~ concat_assoc.
Qed.

Lemma dwft_subst_tb : forall F E T P x,
  dwft (E & x ~tvar & F) T ->
  dwft E P ->
  ok (E & map (dsubst_tb x P) F) ->
  dwft (E & map (dsubst_tb x P) F) (dsubst_tt x P T).
Proof.
  introv WT WP. gen_eq G: (E & x ~tvar & F). gen F.
  induction WT; intros F EQ Ok; subst; simpl dsubst_tt; auto.
  case_var*.
    apply_empty* dwft_weaken.
    destruct (binds_concat_inv H0) as [?|[? ?]].
      apply* dwft_var.
       apply~ binds_concat_right.
       assert (dbind_tvar = dsubst_tb x P dbind_tvar).
       reflexivity. rewrite H2.
       apply~ binds_map.
      destruct (binds_push_inv H2) as [[? ?]|[? ?]].
        subst. false~.
        apply* dwft_var.
  apply_fresh* dwft_all as Y.
   rewrite* dsubst_tt_open_tt_var.
   assert (dbind_tvar = dsubst_tb x P dbind_tvar). reflexivity.
   rewrite H1.
   apply_ih_map_bind* H0.
Qed.

Lemma dokt_strengthen_typ : forall F E x v,
    dokt (E & x ~: v & F) ->
    dokt (E & F).
Proof.
  induction F using env_ind; rew_env_concat; introv Ok.
  rewrite concat_empty_r in *.
  apply dokt_push_inv in Ok; destructs~ Ok.
  rewrite concat_assoc in *.
  destruct v.
  constructor~.
  forwards ~ [? ?] : dokt_push_inv Ok.
  apply* IHF.
  apply dok_from_okt in Ok.
  forwards~ [? ?] : ok_push_inv Ok.
  forwards ~ : dokt_push_typ_inv Ok.
  forwards ~ [? ?] : dokt_push_inv Ok.
  constructor~.
  apply* IHF.
  apply* dwft_strengthen_typ.
Qed.

Lemma dwft_rename : forall E F z u A,
    dwft (E & z ~tvar & F) A ->
    dokt (E & u ~tvar & F) ->
    dwft (E & u ~tvar & F) (dsubst_tt z (dtyp_fvar u) A).
Proof.
  introv wf okt.
  inductions wf; simpls; auto.
  case_var~.
  apply~ dwft_var.
  apply~ binds_middle_eq.
  lets: dok_from_okt okt.
  lets ~ : ok_middle_inv_r H1.

  apply* dwft_var.
  forwards ~ : binds_remove H0.
  apply~ binds_weaken.

  apply_fresh dwft_all as x.
  forwards ~ : H0 x E (F & x ~tvar) z.
  rewrite~ concat_assoc.
  rewrite~ concat_assoc.
  rewrite concat_assoc in H1; auto.
  rewrite <- dsubst_tt_open_tt_var in H1; auto.
Qed.

(** Extraction from a typing assumption in a well-formed environments *)

Lemma dwft_from_env_has_typ : forall x U E,
  dokt E -> binds x (dbind_typ U) E -> dwft E U.
Proof.
  induction E using env_ind; intros Ok B.
  false* binds_empty_inv.
  inversions Ok.
    false (empty_push_inv H0).
    destruct (eq_push_inv H) as [? [? ?]]. subst. clear H.
    apply~ dwft_push.
    apply* IHE.
    destruct (binds_push_inv B) as [[? ?]|[? ?]]. false H2. auto.

    destruct (eq_push_inv H) as [? [? ?]]. subst. clear H.
     destruct (binds_push_inv B) as [[? ?]|[? ?]]. inversions H3.
    apply~ dwft_push.
    apply~ dwft_push.
Qed.

(** Extraction from a well-formed environment *)

Lemma dwft_from_okt_typ : forall x T E,
  dokt (E & x ~ dbind_typ T) -> dwft E T.
Proof.
  intros. inversions* H.
  false (empty_push_inv H1).
  destruct (eq_push_inv H0) as [? [? ?]]. false~ H3.
  destruct (eq_push_inv H0) as [? [? ?]].
  inversion~ H4. subst~.
Qed.

Lemma dokt_subst_tb : forall F E x T,
  dokt (E & x ~tvar & F) ->
  dwft E T ->
  dokt (E & map (dsubst_tb x T) F).
Proof.
 introv O W. induction F using env_ind.
  rewrite map_empty. rewrite concat_empty_r in *.
  lets*: (dokt_push_inv O).
  rewrite map_push. rewrite concat_assoc in *.
  lets (?&?): (dokt_push_inv O).
  destruct v.
  simpls*.
  applys~ dokt_typ. applys* dwft_subst_tb.
  apply* dwft_from_okt_typ.
Qed.

Lemma dwft_open_inv: forall E k T U P,
    dwft E U ->
    dwft E P ->
    dwft E (dopen_tt_rec k U T) ->
    dwft E (dopen_tt_rec k P T).
Proof.
  introv wf1 wf2 wfh.
  inductions wfh.

  destruct T;  simpls~; try(solve[inversion x]).
  case_nat* .

  destruct T;  simpls~; try(solve[inversion x]).
  case_nat* .

  destruct T;  simpls~; try(solve[inversion x]).
  case_nat* .
  inversions x.
  apply~ dwft_var.

  destruct T;  simpls~; try(solve[inversion x]).
  inversions x.
  apply~ dwft_arrow. apply IHwfh1 with U; auto.
  apply IHwfh2 with U; auto.
  case_nat*.

  destruct T;  simpls~; try(solve[inversion x]).
  case_nat* .
  inversions x.
  apply_fresh dwft_all as x.
  unfold dopen_tt.
  rewrite~ dopen_tt_rec_type_commu.
  apply H0 with U; auto.
  apply~ dwft_push.
  apply~ dwft_push.
  unfold dopen_tt.
  rewrite~ dopen_tt_rec_type_commu.
Qed.

Lemma dwft_open_inv_all: forall E T U,
    dwft E U ->
    dwft E (dopen_tt T U) ->
    dwft E (dtyp_all T).
Proof.
  introv wf1 wf2. unfolds dopen_tt.
  apply_fresh dwft_all as x.
  apply dwft_open_inv with U; auto.
  apply~ dwft_push.
  apply~ dwft_push.
Qed.

Lemma dwft_open: forall E T U,
    dwft E U ->
    dwft E (dtyp_all T) ->
    dwft E (dopen_tt T U).
Proof.
  introv wf1 wf2.
  inversions wf2.
  pick_fresh x.
  forwards ~ : H1 x.
  apply dwft_strengthen_push with x dbind_tvar; auto.
  unfolds dopen_tt.
  apply dwft_open_inv with (dtyp_fvar x); auto.
  apply~ dwft_push.
  apply~ dnotin_fv_tt_open_inv.
Qed.

Lemma dwft_notin_env: forall E A y,
    dwft E A ->
    y \notin dom E ->
    y \notin dfv_tt A.
Proof.
  introv wf notin. inductions wf; simpls~.
  apply~ notin_singleton. introv veq. subst~.
  false binds_fresh_inv H0 notin0.
  pick_fresh x.
  forwards~ : H0 x.
  apply* dnotin_fv_tt_dopen.
Qed.

(** Automation *)

Hint Resolve dwft_from_okt_typ.
Hint Immediate dwft_from_env_has_typ.
Hint Resolve dokt_subst_tb dwft_weaken.
Hint Immediate dokt_strengthen_typ.
Hint Resolve dwft_subst_tb.

(** If an environment is well-formed, then its left part is also well-formed. *)

Lemma dokt_concat_left_inv: forall E F,
    dokt (E & F) -> dokt E.
Proof.
  induction F using env_ind; introv okt; auto.
  clean_empty okt; auto.
  rewrite concat_assoc in okt.
  lets [? ?]: dokt_push_inv okt. apply* IHF.
Qed.

(* ********************************************************************** *)
(** * Properties of Closeness *)

(** Abstracting a term name out of a term *)

Fixpoint dclose_ee_rec (k : nat) (z : var) (t : dtrm) {struct t} : dtrm :=
  match t with
  | dtrm_bvar i        => dtrm_bvar i
  | dtrm_fvar x        => If x = z then (dtrm_bvar k) else (dtrm_fvar x)
  | dtrm_nat  i        => dtrm_nat i
  | dtrm_absann t1 t2  => dtrm_absann t1 (dclose_ee_rec (S k) z t2)
  | dtrm_abs t         => dtrm_abs (dclose_ee_rec (S k) z t)
  | dtrm_app t1 t2     => dtrm_app (dclose_ee_rec k z t1) (dclose_ee_rec k z t2)
  | dtrm_let t1 t2     => dtrm_let (dclose_ee_rec k z t1) (dclose_ee_rec (S k) z t2)
  end.

Definition dclose_ee z t := dclose_ee_rec 0 z t.

(** Close var commutes with open with some freshness conditions,
  this is used in the proofs of [close_ee_open] *)

Lemma dclose_ee_rec_open : forall x y z t1 i j,
  i <> j -> y <> x -> y \notin (dfv_ee t1) ->
    (dopen_ee_rec i (dtrm_fvar y) (dopen_ee_rec j (dtrm_fvar z) (dclose_ee_rec j x t1)))
  = (dopen_ee_rec j (dtrm_fvar z) (dclose_ee_rec j x (dopen_ee_rec i  (dtrm_fvar y) t1) )).
Proof.
  induction t1; simpl; intros; try solve [ f_equal* ].
  do 2 (case_nat; simpl); try solve [ case_var* | case_nat* ].
  case_var*. simpl. case_nat*.
Qed.

(** Close var removes fresh var *)

Lemma dclose_ee_fresh : forall x t,
  x \notin dfv_ee (dclose_ee x t).
Proof.
  introv. unfold dclose_ee. generalize 0.
  induction t; intros k; simpls; notin_simpl; auto.
  case_var; simple*.
Qed.

(** Close var is the right inverse of open_var *)

Lemma dclose_ee_open : forall x t,
  dterm t -> t = (dclose_ee x t) dopen_ee_var x.
Proof.
  introv W. unfold dclose_ee, dopen_ee. generalize 0.
  induction W; intros k; simpls; f_equal*.
  case_var*. simpl. case_nat*.
  let L := gather_vars in match goal with |- _ = ?t =>
    destruct (var_fresh (L \u dfv_ee t)) as [y Fr] end.
  apply* (@dopen_ee_rec_inj y).
  unfolds dopen_ee. rewrite* dclose_ee_rec_open.
  let L := gather_vars in match goal with |- _ = ?t =>
    destruct (var_fresh (L \u dfv_ee t)) as [y Fr] end.
  apply* (@dopen_ee_rec_inj y).
  unfolds dopen_ee. rewrite* dclose_ee_rec_open.
  let L := gather_vars in match goal with |- _ = ?t =>
    destruct (var_fresh (L \u dfv_ee t)) as [y Fr] end.
  apply* (@dopen_ee_rec_inj y).
  unfolds dopen_ee. rewrite* dclose_ee_rec_open.
Qed.

(** Abstracting a type name out of a type *)

Fixpoint dclose_tt_rec (k : nat) (z : var) (t : dtyp) {struct t} : dtyp :=
  match t with
  | dtyp_bvar i        => dtyp_bvar i
  | dtyp_unknown       => dtyp_unknown
  | dtyp_fvar x        => If x = z then (dtyp_bvar k) else (dtyp_fvar x)
  | dtyp_nat           => dtyp_nat
  | dtyp_arrow t1 t2   => dtyp_arrow (dclose_tt_rec k z t1) (dclose_tt_rec k z t2)
  | dtyp_all t1        => dtyp_all (dclose_tt_rec (S k) z t1)
  end.

Definition dclose_tt z t := dclose_tt_rec 0 z t.

(** Close var commutes with open with some freshness conditions *)

Lemma dclose_tt_rec_open : forall x y z t1 i j,
  i <> j -> y <> x -> y \notin (dfv_tt t1) ->
    (dopen_tt_rec i (dtyp_fvar y) (dopen_tt_rec j (dtyp_fvar z) (dclose_tt_rec j x t1)))
  = (dopen_tt_rec j (dtyp_fvar z) (dclose_tt_rec j x (dopen_tt_rec i  (dtyp_fvar y) t1) )).
Proof.
  induction t1; simpl; intros; try solve [ f_equal* ].
  do 2 (case_nat; simpl); try solve [ case_var* | case_nat* ].
  case_var*. simpl. case_nat*.
Qed.

(** Close var removes fresh var *)

Lemma dclose_tt_fresh_rec : forall x t k,
  x \notin dfv_tt (dclose_tt_rec k x t).
Proof.
  introv. unfold dclose_tt. gen k.
  induction t; intros k; simpls; notin_simpl; auto.
  case_var; simple*.
Qed.

Lemma dclose_tt_fresh : forall x t,
  x \notin dfv_tt (dclose_tt x t).
Proof.
  unfold dclose_tt.  introv.
  apply dclose_tt_fresh_rec.
Qed.

Hint Resolve dclose_tt_fresh_rec dclose_tt_fresh.

(** Close var is the right inverse of open_var *)

Lemma dclose_tt_open : forall x t k,
  dtype t -> t = dopen_tt_rec k (dtyp_fvar x) (dclose_tt_rec k x t).
Proof.
  introv W. unfold dclose_tt, dopen_tt. gen k.
  induction W; intros k; simpls; f_equal*.
  case_var*. simpl. case_nat*.
  let L := gather_vars in match goal with |- _ = ?t =>
    destruct (var_fresh (L \u dfv_tt t)) as [y Fr] end.
  apply* (@dopen_tt_rec_inj y).
  unfolds dopen_tt. rewrite* dclose_tt_rec_open.
Qed.

Lemma dclose_tt_open_var : forall x t,
  dtype t -> t = dopen_tt (dclose_tt x t) (dtyp_fvar x).
Proof.
  intros. unfolds dopen_tt.
  apply* dclose_tt_open.
Qed.

Lemma dopen_tt_close_fresh : forall y A,
    y \notin dfv_tt A ->
    dclose_tt y (A dopen_tt_var y) = A.
Proof.
  unfolds dopen_tt. unfolds dclose_tt.
  generalize 0. introv. gen n.
  inductions A; introv neq; simpls~;f_equal~.
  case_nat~. simpls~. case_var~.
  case_var~.
Qed.

Hint Resolve dclose_tt_rec_open.
Hint Resolve dclose_tt_open.

(* close does not introduce new free vairables *)

Lemma dnotin_fv_tt_close_inv: forall S x y k,
    x \notin dfv_tt S ->
    x \notin dfv_tt (dclose_tt_rec k y S).
Proof.
  induction S; introv notin; simpls~.
  case_var~. simpls~.
Qed.

Lemma dclose_tt_in_inv : forall x t k y,
        x <> y ->
        x \in dfv_tt (dclose_tt_rec k y t) ->
        x \in dfv_tt t.
Proof.
  introv. unfold dclose_tt. gen k.
  induction t; intros; simpls; notin_simpl; auto.
  rewrite in_union in *. destruct H0. left. apply* IHt1. right. apply* IHt2.
  case_var; simple*.
  simpls. rewrite in_empty in H0. false~.
  apply* IHt.
Qed.

Hint Resolve dnotin_fv_tt_close_inv
.

(** open a closed one is substitution *)

Lemma dclose_tt_open_subst: forall S k x y,
    dtype S ->
    dopen_tt_rec k (dtyp_fvar y) (dclose_tt_rec k x S) = dsubst_tt x (dtyp_fvar y) S.
Proof.
  introv ty. gen k. induction ty; introv; simpls; auto.
  case_var~. simpls. case_nat~.
  rewrite* IHty1. rewrite* IHty2.

  pick_fresh z.
  specializes H0 z (S k).

  rewrite dsubst_tt_open_tt in H0; auto.
  simpls. case_var.

  unfolds dopen_tt.
  unfolds dopen_tt.
  rewrite <- dclose_tt_rec_open in H0; auto.
  apply dopen_tt_rec_inj in H0; auto.
  rewrite~ H0.
  apply dnotin_fv_tt_open_inv; simpls~.
  apply dnotin_fv_tt_subst_inv; simpls~.
Qed.

Hint Resolve dclose_tt_open_subst.

(* ********************************************************************** *)
(** ** Number of All *)

Fixpoint num_of_all (t: dtyp) : nat :=
  match t with
      | dtyp_nat => 0
      | dtyp_unknown => 0
      | dtyp_fvar x => 0
      | dtyp_bvar x => 0
      | dtyp_arrow n1 n2 => (num_of_all n1) + (num_of_all n2)
      | dtyp_all n => 1 + (num_of_all n)
  end.

Lemma num_of_all_mono: forall U,
    dtyp_mono U ->
    num_of_all U = 0.
Proof.
  induction U; introv mn; simpls~.
  inversion~ mn; subst~. rewrite~ IHU1.
  inversion mn.
Qed.

Lemma num_of_all_open_rec_mono: forall S U k,
    dtyp_mono U ->
    num_of_all (dopen_tt_rec k U S) = num_of_all S.
Proof.
  induction S; introv mn; simpls~.
  case_nat~. apply~ num_of_all_mono.
Qed.

Lemma num_of_all_open_mono: forall S U,
    dtyp_mono U ->
    num_of_all (dopen_tt S U) = num_of_all S.
Proof.
  intros. apply* num_of_all_open_rec_mono.
Qed.

Lemma num_of_all_open_rec_unknown: forall S k,
    num_of_all (dopen_tt_rec k dtyp_unknown S) = num_of_all S.
Proof.
  induction S; introv; simpls~.
  case_nat~.
Qed.

Lemma num_of_all_open_unknown: forall S,
    num_of_all (dopen_tt S dtyp_unknown) = num_of_all S.
Proof.
  intros. apply* num_of_all_open_rec_unknown.
Qed.

(* ********************************************************************** *)
(** ** Dtyp Len *)

Fixpoint dtyp_len (t: dtyp) : nat :=
  match t with
  | dtyp_nat => 1
  | dtyp_unknown => 1
  | dtyp_fvar _ => 1
  | dtyp_bvar _ => 1
  | dtyp_arrow t1 t2 =>
      1 + dtyp_len t1 + dtyp_len t2
  | dtyp_all t1 =>
    1 + dtyp_len t1
  end.

Lemma dtyp_len_open_tt_fvar: forall S U k,
    dtyp_len (dopen_tt_rec k (dtyp_fvar U) S) = dtyp_len S.
Proof.
  induction S; introv; simpls~.
  case_nat~.
Qed.

Lemma dtyp_len_open_tt_unknown: forall S k,
    dtyp_len (dopen_tt_rec k dtyp_unknown S) = dtyp_len S.
Proof.
  induction S; introv; simpls~.
  case_nat~.
Qed.

(* ********************************************************************** *)
(** ** Regularity of relations *)

Lemma dsub_regular : forall E A B,
  dsub E A B -> dokt E /\ dwft E A /\ dwft E B.
Proof.
  introv sub.
  inductions sub; try(solve[splits~]).
  destructs~ IHsub1.
  destructs~ IHsub2.

  destructs~ IHsub.
  splits~.
  apply dwft_open_inv_all with tau; auto.

  splits~.
  pick_fresh y. forwards ~ : H0 y.
  destructs H1.
  apply* dokt_concat_left_inv.
  pick_fresh y. forwards ~ : H0 y.
  destructs H1.
  apply* dwft_strengthen_push.

  apply_fresh dwft_all as x.
  forwards ~ : H0 x.
  destructs~ H1.
Qed.

Lemma dconsub_regular : forall E A B,
  dconsub E A B -> dokt E /\ dwft E A /\ dwft E B.
Proof.
  introv sub. inductions sub; auto.
  destructs IHsub1. destructs IHsub2.
  splits~.

  destructs IHsub.
  splits~.
  apply dwft_open_inv_all with tau; auto.

  splits~.
  pick_fresh y. forwards ~ [? [? ?]]: H0 y.
    apply* dokt_concat_left_inv.
  pick_fresh y. forwards ~ [? [? ?]]: H0 y.
    apply* dwft_strengthen_push.
  apply_fresh dwft_all as x.
    forwards ~ [? [? ?]] : H0 x.
Qed.

Lemma dmatch_regular : forall A A1 A2 E,
    dwft E A ->
    dmatch E A A1 A2 ->
    dwft E A1 /\ dwft E A2.
Proof.
  introv wf mat. inductions mat.
  apply~ IHmat.
  inversions wf.
  pick_fresh y.
  apply dwft_strengthen_push with y (dbind_tvar); auto.
  apply dwft_open_inv with (dtyp_fvar y); auto.
  apply~ dwft_push.
  apply~ H3.
  apply~ dnotin_fv_tt_open_inv.

  inversions wf. splits~.
  splits~.
Qed.

Lemma dmatch_regular_inv : forall A A1 A2 E,
    dmatch E A A1 A2 ->
    dwft E A1 -> dwft E A2 ->
    dwft E A.
Proof.
  introv mat wfa1 wfa2. inductions mat; auto.
  apply_fresh dwft_all as x.
  apply dwft_open_inv with tau; auto.
  apply~ dwft_push.
  apply~ dwft_push.
Qed.

Lemma dmatch_regular_dtype : forall A A1 A2 E,
    dmatch E A A1 A2 ->
    dtype A ->
    dtype A1 /\ dtype A2.
Proof.
  introv mat wf. inductions mat.
  apply~ IHmat.
  apply* dtype_open.
  inversions~ wf.
  splits~.
Qed.

Lemma dtyping_regular : forall E e T,
  dtyping E e T -> dokt E /\ dterm e /\ dwft E T.
Proof.
  induction 1; try(solve[auto;splits~]).
  splits~. apply* dwft_from_env_has_typ.
  splits~.
    pick_fresh y. specializes H1 y. destructs~ H1.
      forwards*: dokt_push_inv.
    apply_fresh dterm_absann as y.
      pick_fresh y. specializes H1 y. destructs~ H1.
        specializes H1 y. destructs~ H1.
    apply~ dwft_arrow.
      pick_fresh y. specializes H1 y. destructs~ H1.
      apply* dokt_push_typ_inv.
      pick_fresh y. specializes H1 y. destructs~ H1.
      apply* dwft_strengthen_push.

  destructs IHdtyping1.
  destructs IHdtyping2.
  forwards ~ [? ?] : dmatch_regular H0.

  splits~.
    pick_fresh y. specializes H1 y. destructs~ H1.
      forwards*: dokt_push_inv.
    apply_fresh dterm_abs as y.
      specializes H1 y. destructs~ H1.
    apply~ dwft_arrow.
      pick_fresh y. specializes H1 y. destructs~ H1.
      apply* dokt_push_typ_inv.
      pick_fresh y. specializes H1 y. destructs~ H1.
      apply* dwft_strengthen_push.

  splits~.
    pick_fresh y. specializes H0 y. destructs~ H0.
      forwards*: dokt_push_inv.
    pick_fresh y. specializes H0 y. destructs~ H0.
    apply_fresh dwft_all as y.
      specializes H0 y. destructs~ H0.

  destructs IHdtyping.
  splits~.
    apply_fresh dterm_let as y.
    pick_fresh y. specializes H1 y. destructs~ H1.
    specializes H1 y. destructs~ H1.
    pick_fresh y. specializes H1 y. destructs~ H1.
      apply* dwft_strengthen_push.
Qed.

(** Automation *)

Hint Extern 1 (dokt ?E) =>
  match goal with
  | H: dsub _ _ _ |- _ => apply (proj31 (dsub_regular H))
  | H: dconsub _ _ _ |- _ => apply (proj31 (dconsub_regular H))
  | H: dtyping _ _ _ |- _ => apply (proj31 (dtyping_regular H))
  end.

Hint Extern 1 (dterm ?E) =>
  match goal with
  | H: dtyping _ _ _ |- _ => apply (proj32 (dtyping_regular H))
  end.

Hint Extern 1 (dwft ?E ?t) =>
  match goal with
  | H: dsub _ _ _ |- _ => apply (proj32 (dsub_regular H))
  | H: dsub _ _ _ |- _ => apply (proj33 (dsub_regular H))
  | H: dconsub _ _ _ |- _ => apply (proj32 (dconsub_regular H))
  | H: dconsub _ _ _ |- _ => apply (proj33 (dconsub_regular H))
  | H: dmatch _ _ _ _ |- _ => apply (proj21 (dmatch_regular H))
  | H: dmatch _ _ _ _ |- _ => apply (proj22 (dmatch_regular H))
  | H: dtyping _ _ _ |- _ => apply (proj33 (dtyping_regular H))
  end.


Require Import Braun.common.util Braun.common.le_util Braun.common.same_structure.
Require Import Braun.common.log Braun.common.big_oh Braun.common.pow.
Require Import Braun.monad.monad Braun.arith.plus.
Require Import Program Div2 Omega Even.

Inductive Fib : nat -> nat -> Prop :=
| F_0 :
  Fib 0 0
| F_1 :
  Fib 1 1
| F_n :
  forall n a b,
    Fib n a ->
    Fib (S n) b  ->
    Fib (S (S n)) (a + b).
Hint Constructors Fib.

Fixpoint fib n :=
  match n with
    | 0 => 0
    | S n' =>
      match n' with
        | 0 => 1
        | S n'' => fib n''  + fib n'
      end
  end.

Lemma Fib_fib:
  forall n, Fib n (fib n).
Proof.
  apply (well_founded_induction lt_wf).
  intros n IH.
  destruct n as [|n].
  eauto.
  destruct n as [|n].
  eauto.
  replace (fib (S (S n))) with (fib n + fib (S n));auto.
Defined.

Lemma fib_SS : forall n, fib (S (S n)) = fib (S n) + fib n.
Proof.
  intros; unfold fib; rewrite plus_comm; auto.
Qed.

Lemma fib_monotone : forall (n : nat) (m : nat), m <= n -> fib m <= fib n.
Proof.
  intros n m LE.
  destruct LE.
  auto.
  remember (S m0) as n.
  assert (m < n) as LT; [omega|].
  clear LE Heqn.
  apply (well_founded_induction lt_wf
                                (fun (n : nat) =>
                                   forall (m : nat), m < n -> fib m <= fib n)); auto.
  clear m m0 n LT.
  intros x0 H m H0.
  destruct x0 as [|n'].
  inversion H0.
  destruct n' as [|n''].
  inversion H0; [compute; omega|inversion H2].
  rewrite fib_SS.
  destruct m as [|m'].
  replace (fib 0) with 0; [|compute;auto].
  apply le_0_n.
  destruct m' as [|m''].
  apply le_plus_trans.
  destruct n'' as [|n''']; [|apply H]; try omega.
  destruct n'' as [|n''']; [intuition|].
  apply le_plus_trans.
  inversion H0; auto.
Qed.

Lemma fib_nonneg : forall n, 0 < fib (S n).
Proof.
  induction n;[simpl|rewrite fib_SS]; omega.
Qed.

Lemma fib_lower_bound :
  forall n,
    pow 2 (div2 (S n)) <= 2 * fib (S n).
Proof.
  apply (well_founded_ind
           lt_wf
           (fun n => pow 2 (div2 (S n)) <= 2 * fib (S n))).
  intros n IND.
  destruct n;[simpl;auto|].
  destruct n;[simpl;auto|].
  replace (div2 (S (S (S n)))) with (S (div2 (S n)));[|unfold div2;auto].
  unfold pow; fold pow.
  apply (le_trans (2 * pow 2 (div2 (S n)))
                  (2 * (2 * fib (S n)))).
  apply mult_le_compat; auto.

  clear IND.
  apply mult_le_compat; auto.
  replace (fib (S (S (S n)))) with (fib (S (S n)) + fib (S n));[|simpl fib;omega].
  unfold mult.
  rewrite plus_0_r.
  apply plus_le_compat;auto.
  apply fib_monotone; auto.
Qed.

Lemma fib_lower_bound2 :
  forall n, 6 <= n ->
            pow 2 (div2 n) <= fib n.
Proof.
  apply (well_founded_ind
           lt_wf
           (fun n => 6 <= n -> pow 2 (div2 n) <= fib n)).
  intros.
  destruct x; inversion H0;[compute;auto|].
  clear H0 H1 m.
  destruct x; inversion H2;[compute;omega|].
  clear m H2 H0.
  replace (div2 (S (S x))) with (S (div2 x));[|unfold div2; auto].
  unfold pow; fold pow.
  apply (le_trans (2 * pow 2 (div2 x))
                  (2 * fib x)).
  apply mult_le_compat; auto.
  replace (fib (S (S x))) with (fib (S x) + fib x);[|simpl fib; omega].
  unfold mult.
  rewrite plus_0_r.
  apply plus_le_compat; auto.
  apply fib_monotone; auto.
Qed.

Lemma fib_log_lower_bound :
  forall n,
    (div2 n) <= cl_log (fib ((S (S n)))).
Proof.
  intros.
  destruct n.
  simpl;omega.
  rewrite fib_SS.
  apply (le_trans ((div2 (S n)))
                  (cl_log (fib (S n) + fib (S n)))).
  replace (fib (S n) + fib (S n)) with (2*fib (S n));[|omega].
  apply (le_trans  ((div2 (S n)))
                   (cl_log ( pow 2 (div2 (S n))))).
  rewrite pow2_log.
  auto.
  apply cl_log_monotone.
  apply fib_lower_bound.
  apply cl_log_monotone.
  apply plus_le_compat; auto.
  apply fib_monotone.
  auto.
Qed.

Theorem fib_big_omega_2_to_the_div2_n :
  big_omega fib (fun n => pow 2 (div2 n)).
Proof.
  apply big_oh_rev.
  exists 1, 2.
  intros n LT.
  destruct n. intuition.
  apply fib_lower_bound.
Qed.

Lemma fib_upper_bound :
  forall n,
    fib n <= pow 2 n.
Proof.
  apply (well_founded_ind
           lt_wf
           (fun n => fib n <= pow 2 n)).
  intros n IND.
  destruct n. simpl. auto.
  destruct n. simpl. auto.
  replace (fib (S (S n))) with (fib (S n) + fib n);[|unfold fib; omega].
  replace (pow 2 (S (S n))) with (2 * pow 2 (S n));[|unfold pow; omega].
  unfold mult; rewrite plus_0_r.
  apply (le_trans (fib (S n) + fib n)
                  (pow 2 (S n) + pow 2 n)).
  apply plus_le_compat; apply IND; auto.
  apply plus_le_compat; auto.
  apply pow2_monotone; auto.
Qed.

Lemma fib_log_upper_bound :
  forall n,
    cl_log (fib n) <= n+1.
Proof.
  intros.
  apply (le_trans (cl_log (fib n))
                  (cl_log (pow 2 n))).
  apply cl_log_monotone.
  apply fib_upper_bound.
  rewrite pow2_log.
  omega.
Qed.

Theorem fib_big_oh_2_to_the_n :
  big_oh fib (fun n => pow 2 n).
Proof.
  exists 0, 1.
  intros n _.
  rewrite mult_1_l.
  apply fib_upper_bound.
Qed.

Lemma mle_2_and_3 : forall a b, 3 * a < 2 * b -> 3 * (b + a) < 2 * (b + a + b).
Proof.
  intros.
  simpl. intuition.
Qed.

Lemma fib_S : forall (n : nat), n > 3 -> 3 * fib n < 2 * (fib (S n)).
Proof.
  apply (well_founded_induction lt_wf
                                (fun (n : nat) =>
                                   n > 3 -> 3 * fib n < 2 * (fib (S n)))).
  intros n IH g2.
  destruct n as [|n]; [compute; auto|].
  destruct n as [|n]; [inversion g2 as [|q G qq]; inversion G|].
  rewrite fib_SS.
  destruct n as [|n]; [compute; auto|].
  destruct n as [|n]; [inversion g2 as [|q1 G q2]; inversion G; omega|].
  destruct n as [|n]; [compute; auto|].
  destruct n as [|n]; [compute; auto|].
  replace (fib (S (S (S (S (S (S (S n))))))))
  with (fib (S (S (S (S (S n))))) + fib (S (S (S (S n)))) + fib (S (S (S (S (S n)))))).
  apply mle_2_and_3.
  apply IH; auto.
  omega.
  remember (fib (S (S (S (S (S n)))))) as a.
  remember (fib (S (S (S (S n))))) as b.
  rewrite fib_SS.
  rewrite <- Heqa.
  rewrite fib_SS.
  auto.
Qed.
Hint Resolve fib_S.

Lemma fib_log_div2 : forall (n : nat),
                       n > 16 -> 3 * fib (cl_log (div2 n)) < 2 * fib (cl_log n).
Proof.
  intros n g16.
  unfold_sub cl_log (cl_log n).
  do 16 (destruct n as [|n]; [inversion g16; try omega|]).
  fold_sub cl_log.
  unfold div2. fold div2.
  apply fib_S.
  unfold gt.
  apply lt_le_trans with (m := cl_log 8); [compute; auto|].
  apply cl_log_monotone.
  intuition.
Admitted.

Hint Resolve fib_log_div2.

Lemma fib_sum_less_than_fib_product:
  forall n,
    n >= 4 ->
    fib n + fib n <= fib n * fib n.
Proof.
  intros n LE.
  destruct n;[intuition|].
  destruct n;[intuition|].
  destruct n;[intuition|].
  destruct n;[intuition|].
  clear LE.
  apply (well_founded_ind
           lt_wf
           (fun n => fib (S (S (S (S n)))) + fib (S (S (S (S n)))) <=
                     fib (S (S (S (S n)))) * fib (S (S (S (S n)))))).
  clear n; intros n IND.
  destruct n.
  compute; omega.
  destruct n.
  compute; omega.

  replace (fib (S (S (S (S (S (S n)))))))
  with (fib (S (S (S (S (S n))))) + (fib (S (S (S (S n))))));[|unfold fib;omega].
  replace ((fib (S (S (S (S (S n))))) + fib (S (S (S (S n))))) +
           (fib (S (S (S (S (S n))))) + fib (S (S (S (S n))))))
  with ((fib (S (S (S (S n)))) + fib (S (S (S (S n))))) +
        (fib (S (S (S (S (S n))))) + fib (S (S (S (S (S n)))))));[|omega].
  apply (le_trans ((fib (S (S (S (S n)))) + fib (S (S (S (S n))))) +
                   (fib (S (S (S (S (S n))))) + fib (S (S (S (S (S n)))))))
                  ((fib (S (S (S (S n)))) * fib (S (S (S (S n))))) +
                   (fib (S (S (S (S (S n))))) * fib (S (S (S (S (S n)))))))).
  apply plus_le_compat; apply IND; auto.
  rewrite mult_plus_distr_r.
  repeat (rewrite mult_plus_distr_l).
  remember (fib (S (S (S (S n)))) * fib (S (S (S (S n))))) as i.
  remember (fib (S (S (S (S (S n))))) * fib (S (S (S (S (S n)))))) as j.
  replace (j + fib (S (S (S (S (S n))))) * fib (S (S (S (S n)))) +
           (fib (S (S (S (S n)))) * fib (S (S (S (S (S n))))) + i))
  with (i + j +
        (fib (S (S (S (S (S n))))) * fib (S (S (S (S n)))) +
         fib (S (S (S (S n)))) * fib (S (S (S (S (S n)))))));[|omega].
  apply le_plus_trans.
  omega.
Qed.

Lemma cl_log_big_oh_double :
  big_oh (fun n => cl_log (2 * fib n)) (fun n => cl_log (fib n)).
Proof.
  apply (big_oh_trans (fun n => cl_log (2 * fib n))
                      (fun n => (cl_log (fib n * fib n)))).
  exists 4, 1.
  intros n LE.
  rewrite mult_1_l.
  apply cl_log_monotone.
  replace (2 * fib n) with (fib n + fib n);[|simpl mult;omega].
  apply fib_sum_less_than_fib_product.
  omega.

  exists 0, 4.
  intros n _.
  apply cl_log_square_four.
Qed.


(* http://study-func-prog.blogspot.jp/2012/04/coq-group-on-setoid.html *)
Require Import Relation_Definitions Setoid Morphisms.
Require Import Arith Omega.

Inductive Z' : Set :=
| mkZ' : nat -> nat -> Z'.

Definition eq'(z1 z2:Z') : Prop :=
  match z1, z2 with
  | (mkZ' p1 n1), (mkZ' p2 n2) => (p1 + n2 = p2 + n1)
                                    end.

Definition minus'(z:Z') :=
  match z with
  | mkZ' a b => mkZ' b a
                     end.
Definition plus'(z1 z2:Z') :=
  match z1, z2 with
  | (mkZ' a1 b1), (mkZ' a2 b2) => (mkZ' (a1+a2) (b1+b2))
                                    end.

Lemma refl_eq' : reflexive _ eq'.
Proof.
  unfold reflexive.
  intro.
  destruct x as [a b].
  unfold eq'.
  omega.
Qed.

Lemma sym_eq' : symmetric _ eq'.
Proof.
  unfold symmetric.
  intros.
  destruct x.
  destruct y.
  unfold eq'.
  unfold eq' in H.
  omega.
Qed.

Lemma trans_eq' : transitive _ eq'.
Proof.
  unfold transitive.
  intros.
  destruct x.
  destruct y.
  destruct z.
  unfold eq' in *.
  omega.
Qed.

Add Parametric Relation : Z' eq'
    reflexivity proved by refl_eq'
    symmetry proved by sym_eq'
                         transitivity proved by trans_eq' as Z'_setoid.

Add Parametric Morphism :
  minus' with signature (eq' ==> eq') as minus'_mor.
Proof.
  intros.
  destruct x.
  destruct y.
  unfold minus'.
  unfold eq' in *.
  omega.
Qed.

Add Parametric Morphism :
  plus' with signature (eq' ==> eq' ==> eq') as plus'_mor.
Proof.
  intros.
  destruct x.
  destruct y.
  destruct x0.
  destruct y0.
  unfold plus'.
  unfold eq' in *.
  omega.
Qed.

Class Group {S:Set}(eq:S->S->Prop)
      (e:S)(inv:S->S)(op:S->S->S) := {
                                      equiv : Equivalence eq;
                                      equiv_dec : forall x y:S, {eq x y} + {~(eq x y)};
                                      inv_mor : forall x y:S, eq x y -> eq (inv x) (inv y);
                                      op_mor : forall x1 y1 x2 y2:S, eq x1 y1 -> eq x2 y2 ->
                                                                     eq (op x1 x2) (op y1 y2);
                                      op_assoc : forall x y z:S, eq (op (op x y) z) (op x (op y z));
                                      left_unit : forall x:S, eq (op e x) x;
                                      right_unit : forall x:S, eq (op x e) x;
                                      left_inv : forall x:S, eq (op (inv x) x) e;
                                      right_inv : forall x:S, eq (op x (inv x)) e}.

Instance Z'_group : Group eq' (mkZ' O O) minus' plus'.
Proof.
  apply Build_Group.
  apply Z'_setoid.
  intros.
  destruct x.
  destruct y.
  unfold eq'.
  eapply eq_nat_dec.
  intros.
  destruct x.
  destruct y.
  unfold minus'.
  unfold eq' in *.
  omega.
  intros.
  destruct x1.
  destruct x2.
  destruct y1.
  destruct y2.
  unfold plus'.
  unfold eq' in *.
  omega.
  intros.
  destruct x.
  destruct y.
  destruct z.
  unfold plus'.
  unfold eq'.
  omega.
  intros.
  destruct x.
  unfold plus'.
  unfold eq'.
  omega.
  intros.
  destruct x.
  unfold plus'.
  unfold eq'.
  omega.
  intros.
  destruct x.
  unfold minus'.
  unfold plus'.
  unfold eq'.
  omega.
  intros.
  destruct x.
  unfold minus'.
  unfold plus'.
  unfold eq'.
  omega.
Defined.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint even (even_arg0 : natural) : bool
           := match even_arg0 with
              | Zero => true
              | Succ n => negb (even n)
              end.

Lemma lem: forall m n, even (plus m n) = negb (even (plus m (Succ n))).
Proof.
induction m.
  - intros. simpl. rewrite <- IHm. reflexivity.
  - intros. simpl. unfold negb. destruct (even n). reflexivity. reflexivity.
Qed.

Lemma lem2: forall n, plus n Zero = n.
Proof.
induction n.
  - simpl. rewrite IHn. reflexivity.
  - reflexivity.
Qed.

(* An alternaturale proof strategy is to prove that plus is commutative as a helper lemma,
and then this theorem can be proven without induction. *)

Theorem theorem0 : forall (x : natural) (y : natural), eq (even (plus x y)) (even (plus y x)).
Proof.
induction x.
- intros. simpl. rewrite IHx. rewrite lem. unfold negb.
  destruct (even (plus y (Succ x))). reflexivity. reflexivity.
- intros.  simpl. lfind.  reflexivity.
Admitted.