Require Import Lib.
Require Import Relation_Definitions Setoid.

Module Expressions.

  Require Export Heyting.
  Export HeytingTerms.
  Export HeytingProps.

(* Expressions, as defined in Kanckos section 5.1 *)
Inductive expr : Set :=
| E0 : expr
| E1 : expr
| Eω : expr
| EX : Φ -> nat -> expr (* TODO: Phil: A in Φ and i in ℕ instead? *)
| Eplus : expr -> expr -> expr
| Epair : expr -> expr -> expr.

Notation "( e1 , e2 )" := (Epair e1 e2).
Notation "e1 # e2"     := (Eplus e1 e2) (at level 50, left associativity).

Inductive eeq : expr -> expr -> Prop :=
| eeq_refl  : forall f,     eeq f f                            (* text *)
| eeq_pluss : forall f g,   eeq (f # g) (g # f)                (* 3 *)
| eeq_plust : forall f g h, eeq ((f # g) # h) (f # (g # h))    (* 3 *)
| eeq_id1   : forall f,     eeq (f # E0) f                     (* 5 *)
| eeq_id2   : forall f g,   eeq (f # g) f -> eeq g E0          (* 5 *)
| eeq_pr0   : forall f,     eeq (E0, f) f                      (* 12 *)
| eeq_pair1 : forall f g h, eeq (f, (g # h)) ((f, g) # (f, h)) (* 8 *)
| eeq_pair2 : forall f g h, eeq (f, (g, h)) ((f # g), h)       (* 13 *)
| eeq_symm  : forall f g,   eeq f g -> eeq g f                 (* ADDED *)
| eeq_trans : forall f g h, eeq f g -> eeq g h -> eeq f h      (* ADDED *)
.

Notation "e1 == e2" := (eeq e1 e2) (at level 70).

(* Additional axioms required for rewriting tactics. *)
Axiom plus_compat : forall f1 f2, f1 == f2 ->
                    forall g1 g2, g1 == g2 ->
                    f1 # g1 == f2 # g2.
Axiom pair_compat : forall f1 f2, f1 == f2 ->
                    forall g1 g2, g1 == g2 ->
                    (f1, g1) == (f2, g2).

(* this is blatantly copied without understanding from
   https://coq.inria.fr/refman/Reference-Manual029.html *)
Add Parametric Relation : expr eeq
    reflexivity proved by eeq_refl
    symmetry proved by eeq_symm
    transitivity proved by eeq_trans
  as eeq_rel.

Add Parametric Morphism : Eplus with
signature eeq ==> eeq ==> eeq as eplus_mor.
Proof.
  exact plus_compat.
Qed.

Add Parametric Morphism : Epair with
signature eeq ==> eeq ==> eeq as epair_mor.
Proof.
  exact pair_compat.
Qed.

Inductive elt : expr -> expr -> Prop :=
| elt_01    : elt E0 E1                                        (* 6 *)
| elt_1ω    : elt E1 Eω                                        (* 6 *)
| elt_trans : forall f g h, elt f g -> elt g h -> elt f h      (* 1 *)
| elt_plus  : forall f g h, elt f g -> elt (f # h) (g # h)     (* 4 *)
| elt_lim   : forall f g, elt f Eω -> elt g Eω
                          -> elt (f # g) Eω                    (* 7 *)
| elt_pair1 : forall f g h, elt f g -> elt (h, f) (h, g)       (* 10 *)
| elt_pair2 : forall f g h, elt f g -> elt E0 h
                            -> elt (f, h) (g, h)               (* 11 *)
.

Notation "e1 ≺ e2"  := (elt e1 e2) (at level 70).

(* Axiom 2: if f ≺ g then ¬(f == g), doesn't fit in inductive definitions *)
Axiom elt_neq : forall f g: expr, f ≺ g -> ~(f == g).

(* does this make any difference? should/can I declare it as a partial order? *)
Add Parametric Relation : expr elt
    transitivity proved by elt_trans
  as elt_rel.

Inductive ele : expr -> expr -> Prop :=
| ele_lt    : forall f g, f ≺ g -> ele f g                     (* text *)
| ele_eq    : forall f g, f == g -> ele f g                    (* text *)
| ele_0     : forall f, ele E0 f                               (* 6 *)
| ele_pair  : forall f g h c, g ≺ c -> h ≺ c
                              -> ele ((g, f) # (h, f)) (c, f)  (* 9 *)
.

Notation "e1 ≼ e2"  := (ele e1 e2) (at level 70).

(* A basic theorem that should expose the need for axioms that are left
   implicit in the paper. (Question: is there an easier way here?!) *)
Theorem ele_eq_lt : forall f g : expr, f ≼ g -> f == g \/ f ≺ g.
admit. Qed.
(* Proof.
  intros f g H.
  induction H as [f g | f g | f | f g h c].
  Case "f ≺ g". right. apply H.
  Case "f == g". left. apply H.
  Case "0 ≼ f". induction f. (* originally I thought I could just destruct f *)
  SCase "f == 0". left. reflexivity.
  SCase "f == 1". right. apply elt_01.
  SCase "f == ω". right. apply elt_trans with (E1). apply elt_01. apply elt_1ω.
  (* For the next subcases, ;: I want to substitute E0 for f1 and f2
   * but don't know how to get that from eeq. *)
  SCase "f == f1 + f2". inversion IHf1.
  inversion IHf2.
  SSCase "f == 0 + 0". left. rewrite <- H. rewrite <- H0. rewrite eeq_id1.
    reflexivity.
  SSCase "f == 0 + <0". right.
    (* PROBLEM: can't rewrite, replace wants = not == *)
    (* maybe need to declare properties of ≺ similar to morphisms # and (,) *)
    replace (f1) with (E0). replace (E0 # f2) with (f2 # E0).
    replace (f2 # E0) with f2. apply H0.
    (* just admitting all the replacements *)
    admit. admit. admit.
  (* TODO the rest - presently just admitted *)
  inversion IHf2.
  SSCase "f == >0 + 0". right. admit. SSCase "f == <0 + <0". right. admit.
  SCase "f == (f1, f2)". inversion IHf1.
  inversion IHf2.
  SSCase "f == (0, 0)". left. admit. SSCase "f == (0, <0)". right. admit.
  inversion IHf2.
  SSCase "f == (>0, 0)". right. admit. SSCase "f == (<0, <0)". right. admit.
  Case "(g, f) # (h, f)". admit.
Qed. *)

Theorem elt_eeq_trans : forall f g h: expr, f ≺ g -> g == h -> f ≺ h.
Proof.
Admitted. (* TODO *)

Theorem eeq_elt_trans : forall f g h: expr, f == g -> g ≺ h -> f ≺ h.
Proof.
Admitted. (* TODO *)

Theorem ele_trans : forall f g h: expr, f ≼ g -> g ≼ h -> f ≼ h.
Proof.
  intros f g h Hfg Hgh.
  apply ele_eq_lt in Hfg. apply ele_eq_lt in Hgh.
  inversion Hfg. inversion Hgh.
  Case "f == g == h".
    apply ele_eq. apply eeq_trans with (g). apply H. apply H0.
  Case "f == g ≺ h".
    (* BASED ON TODO *)
    apply ele_lt. apply eeq_elt_trans with (g). apply H. apply H0.
  inversion Hgh.
  Case "f ≺ g == h".
    (* BASED ON TODO *)
    apply ele_lt. apply elt_eeq_trans with (g). apply H. apply H0.
  Case "f ≺ g ≺ h". apply ele_lt. apply elt_trans with (g). apply H. apply H0.
Qed.

(* A theorem stated at the end of section 5.1. Not sure about its use, but
 * but it's a good start at using these axioms. *)

Theorem th51 : forall f g h,
                 E0 ≺ f -> E0 ≺ h -> (f, g) # h ≺ (f, g # h).
Proof.
  intros f g h H1 H2.
  (* TODO make the rewriting rules work. *)
  (* rewrite eeq_pair1. *)
Abort.

(* 5.2 Vectors *)
Definition Vect := list expr. (* 0 -> n *)

(* point-wise vector addition on page 5 *)
Fixpoint vect_add (l r : Vect) : Vect :=
  match l,r with
    | nil, r => r
    | l, nil => l
    | cons x l', cons y r' => cons (Eplus x y) (vect_add l' r')
  end.

(* access vector l at index i *)
Fixpoint vect_at (l : Vect) (i : nat): expr :=
  match l with
    | cons h t => match i with
                    | S i' => vect_at t i'
                    | O => h
                  end
    | nil => E0
  end.

(* vector of variables, page 5 *)

Fixpoint level φ :=
  match φ with
    | bot        => 0
    | top        => 0
    | teq _ _    => 0
    | Disj φ₁ φ₂ => max (level φ₁) (level φ₂)
    | Conj φ₁ φ₂ => max (level φ₁) (level φ₂)
    | Imp φ₁ φ₂  => max (S (level φ₁)) (level φ₂)
    | Ex _ φ'    => level φ'
    | All _ φ'   => level φ'
  end.

Fixpoint vect_x_rev (A: Φ) (n: nat): Vect :=
  match n with
    | 0 => cons (EX A 0) nil
    | S n' => cons (EX A n) (vect_x_rev A n')
  end.
Definition vect_x (A: Φ): Vect := rev (vect_x_rev A (level A)).

Inductive expr_has_var: expr -> Prop :=
| x_has_var: forall A i, expr_has_var (EX A i)
| plus_has_var_l: forall f g, expr_has_var f -> expr_has_var (Eplus f g)
| plus_has_var_r: forall f g, expr_has_var g -> expr_has_var (Eplus f g)
| pair_has_var_l: forall f g, expr_has_var f -> expr_has_var (Epair f g)
| pair_has_var_r: forall f g, expr_has_var g -> expr_has_var (Epair f g).

(* Definition 5.3 *)
Inductive expr_class: expr -> nat -> Prop :=
| expr_class_no_x: forall h i, ~ (expr_has_var h) -> expr_class h i
| expr_class_form: forall A i, expr_class (EX A i) i
| expr_class_plus: forall f g i, expr_class f i -> expr_class g i -> expr_class (Eplus f g) i
| expr_class_pair: forall f g i, expr_class f (S i) -> expr_class g i -> expr_class (Epair f g) i.

(* Definition of ℂ right below 5.3 *)
Fixpoint well_classed_from (i: nat) (hs: Vect): Prop :=
  match hs with
    | nil => True
    | cons h hs' => expr_class h i /\ well_classed_from (S i) hs'
  end.

Definition well_classed (hs: Vect): Prop := well_classed_from 0 hs.

(* 5.4 box operation *)
Fixpoint box (fs gs: Vect): Vect :=
  match fs, gs with
    | nil, gs => gs
    | fs, nil => fs
    | cons f fs', cons g gs' =>
      match box fs' gs' with
        | nil                => cons (Eplus f g) nil
        | (cons h hs') as hs => cons (Epair h (Eplus f g)) hs
      end
  end.

(* TODO 5.5 delta operation *)

(* vector restriction *)
Fixpoint restrict_vector (fs: Vect) (n: nat): Vect :=
  match fs with
    | nil => nil
    | cons f fs' => match n with
                      | 0 => nil
                      | S n' => cons f (restrict_vector fs' n')
                    end
  end.

(* vector assignment *)
Definition vect_add_1 (fs: Vect): Vect := map (fun f => Eplus f E1) fs.
Fixpoint assign (d: deriv): Vect. admit.
(*
match d with
(* 1 *)
| asm A => vect_x A
(* 2 *)
| teq _ _ => cons E0 nil
(* 3 *)
| arith_imp p _ => assign p
(* 4 *)
| intro_conj A B => Eplus (assign A) (assign B) (* TODO: wtf is `TR`? *)
(* 5 *)
| elim_conj_l AB => vect_add_1 (assign AB)
| elim_conj_r AB => vect_add_1 (assign AB)
(* 6 *)
| intro_disj_l A => vect_add_1 (assign A)
| intro_disj_r B => vect_add_1 (assign B)
(* 7 TODO A, B? *)
| elim_disj AB AC BC =>
  box (assign AB) (vect_add (delta A (assign AC)) (delta B (assign BC)))
(* 8 *)
| intro_imp AB => delta A (assign AB) (* TODO A? *)
(* 9 *)
| elim_imp AB A => box (assign AB) (assign A)
(* 10 *)
| intro_all A' _ => assign A'
(* 11 *)
| elim_all A => vect_add_1 (assign A)
(* 12 *)
| intro_ex A' => assign A'
(* 13 TODO A'? *)
| elim_ex A AC => box (assign A) (delta A' (assign AC))
(* 14 *)
| elim_bot bot => vect_add_1 (assign bot)
(* 15 WTF *)
.
end.
*)

End Expressions.


Require Import ZArith.
Require Import ZPolS.
Require Import PolSBase.
Require Import PolFBase.
Require Import PolAux.
Require Import PolAuxList.
Require Import ZSignTac.

Definition Zfactor :=
  factor Z Zplus Zmult Z.opp 0%Z 1%Z is_Z1 is_Z0 is_Zpos is_Zdiv Z.div Zgcd.

Definition Zfactor_minus :=
  factor_sub Z Zplus Zmult Z.opp 0%Z 1%Z is_Z1 is_Z0 is_Zpos is_Zdiv Z.div Zgcd.

Definition Zget_delta :=
  get_delta Z Zplus Zmult Z.opp 0%Z 1%Z is_Z1 is_Z0 is_Zpos is_Zdiv Z.div Zgcd.

Ltac Zfactor_term term1 term2 :=
  let term := constr:(Zminus term1 term2) in
  let rfv := FV ZCst Zplus Zmult Zminus Z.opp term (@nil Z) in
  let fv := Trev rfv in
  let expr1 := mkPolexpr Z ZCst Zplus Zmult Zminus Z.opp term1 fv in
  let expr2 := mkPolexpr Z ZCst Zplus Zmult Zminus Z.opp term2 fv in
  let re := (eval vm_compute in (Zfactor_minus (PEsub expr1 expr2))) in
  let factor := match re with (PEmul ?X1 _) => X1 end in
  let expr3 := match re with (PEmul _ (PEsub ?X1 _)) => X1 end in
  let expr4 := match re with (PEmul _ (PEsub _ ?X1 )) => X1 end in
  let re1' :=
      (eval
         unfold
         Zconvert_back, convert_back, pos_nth, jump,
       hd, tl in (Zconvert_back (PEmul factor expr3) fv))
  in
  let re1'' := (eval lazy beta in re1') in
  let re2' :=
      (eval
         unfold
         Zconvert_back, convert_back, pos_nth, jump,
       hd, tl in (Zconvert_back (PEmul factor expr4) fv))
  in
  let re2'' := (eval lazy beta in re2') in
  replace2_tac term1 term2 re1'' re2''; [idtac | ring | ring].

Ltac zpolf :=
  try match goal with
      | |- (?X1 = ?X2)%Z => Zfactor_term X1 X2
      | |- (?X1 <> ?X2)%Z => Zfactor_term X1 X2
      | |- Z.lt ?X1 ?X2 => Zfactor_term X1 X2
      | |- Z.gt ?X1 ?X2 => Zfactor_term X1 X2
      | |- Z.le ?X1 ?X2 => Zfactor_term X1 X2
      | |- Z.ge ?X1 ?X2 => Zfactor_term X1 X2
      | _ => fail end;
  try zsign_tac; try repeat (rewrite Zmult_1_l || rewrite Zmult_1_r).

Ltac hyp_zpolf H :=
  progress
    (generalize H;
     try match type of H with
         | (?X1 = ?X2)%Z => Zfactor_term X1 X2
         | (?X1 <> ?X2)%Z => Zfactor_term X1 X2
         | Z.lt ?X1 ?X2 => Zfactor_term X1 X2
         | Z.gt ?X1 ?X2 => Zfactor_term X1 X2
         | Z.le ?X1 ?X2 => Zfactor_term X1 X2
         | Z.ge ?X1 ?X2 => Zfactor_term X1 X2
         | _ => fail end);
  clear H; intros H;
  try hyp_zsign_tac H; try repeat rewrite Zmult_1_l.


(** * カリーハワード対応とCoqのあいだ - Show Proof で学ぶ Coq のしくみ -

Coq はカリーハワード対応を利用して
証明をプログラムによって表現しているというのはよく知られています。

カリーハワード対応というのは、
命題と型、証明とプログラムが同じ構造になっているという話です。

しかし、Coq の proof editing mode で証明をしていると、
証明項（プログラムのことですが、あまりプログラムとしては意識しないので証明項と呼びましょう）
がどのようなものか意識することは少ないのではないでしょうか。

たとえば、intros H がなにをする（どんな証明項を構築する）のか
わかるでしょうか。

ここでは Coq のいろいろなコマンドがなにをするものなのか、また、
それをどうやって調べるのか説明します。

*)

(**

- 自動証明
  - % auto % # auto #
- 証明項を直接指定する
  - % exact % # exact #
  - refine
- 関数抽象を構築する
  - % intro % # intro #
  - % move=> % # move=> # (SSReflect)
  - % Section % # Section #
- 関数適用とその引数部分を構築する
  - % revert % # revert #
  - % generalize % # generalize #
  - % move:% # move: # (SSReflect)
- 関数適用とその関数部分を構築する
  - % apply % # apply #
- let 式を構築する
  - % pose, set % # pose, set #
  - % specialize % # specialize #
  - have @var (SSReflect)
- eq_refl で等式を証明する
  - % reflexivity % # reflexivity #
- eq_ind_r で等式による書き換えを行う
  - % rewrite % # rewrite #
  - % rewrite % # rewrite # (SSReflect)
- match 式を構築する
  - % destruct % # destruct #
  - % case % # case # (SSReflect)
- simpl change unfold fold pattern
- clear rename move_after
- 数学的帰納法を適用する
  - % induction % # induction #
  - elim (SSReflect)
- f_equal
  congr (SSReflect)
- assert
  have (SSReflect)
- wlog (SSReflect)
  suff (SSReflect)
- replace
- unlock
- injection case_eq
- now
- discriminate
- assumption
- contradiction
- inversion
- subst

*)

(**
URL:
% https://akr.github.io/coq-curry-howard/curry_howard.html %
# https://akr.github.io/coq-curry-howard/curry_howard.html #

リポジトリ:
% https://github.com/akr/coq-curry-howard %
# https://github.com/akr/coq-curry-howard #
*)


Require Import List.
Import ListNotations.

(** *Bibliothèque standard *)

Print nat.
Locate "+".
Print Nat.add.
Locate "*".
Print Nat.mul.

Print list.
Locate "++".
Print app.

Print True.

Print False.

Print or.
Locate "\/".

Print and.
Locate "/\".

Print not.
Locate "~".

(** *Logique : le tiers exclu *)

(* Axiomes possibles pour la logique classique *)

Definition tiersExclu : Prop := forall P : Prop, P \/ ~P.
Definition involutionNegation : Prop := forall P : Prop, ~~P -> P.
Definition implicationMaterielle : Prop := forall P Q : Prop, (P -> Q) -> (~P \/ Q).
Definition reciproqueContraposition : Prop := forall P Q : Prop, (~Q -> ~P) -> (P -> Q).
(* Indication pour la suite : si besoin, utiliser la tactique "unfold" pour déplier
   la définition d'une des propositions précédentes. *)

(* Réciproques valides *)

(*
  Indication :
  - la négation *~P* est définie comme *P -> False*.
 *)
Proposition reciproqueInvolutionNegation :
  forall P : Prop, P -> ~~P.
Proof.
  intros P H non.
  apply non.
  apply H.
Qed.

(*
  Indication :
  - décomposer la disjonction en hypothèse,
  - lorsque les hypothèses entrainent une contradiction,
  utiliser la tactique exfalso.
 *)
Proposition reciproqueImplicationMaterielle :
  forall P Q : Prop, (~P \/ Q) -> P -> Q.
Proof.
 intros P Q H_ou.
  case H_ou.
  - intros H2 p.
    exfalso.
    apply H2.
    apply p.
  - intros H1 H2.
    apply H1.
Qed.

Proposition contraposition :
  forall P Q : Prop, (P -> Q) -> (~Q -> ~P).
Proof.
  intros P Q H H0 H1.
  apply H0.
  apply H.
  exact H1.
Qed.

(* Equivalence des axiomes *)

(*
  Indication :
  - décomposer le tiers exclu appliqué à la proposition.
 *)
Proposition tiersExcluVersInvolutionNegation :
  tiersExclu -> involutionNegation.
Proof.
  intros H_ou.
  intros P.
  case (H_ou P).
  - intros xP H2.
    exact xP.
  - intros H2.
  intros H3.
  exfalso.
  apply H3.
  exact H2.
Qed.
(*
  Indication :
  - appliquer l'involution de la négation à (P \/ ~P),
  - utiliser le fait que (~(P \/ ~P)) entraine ~P,
  - utiliser les tactiques "left" et "right" pour prouver une disjonction.
 *)
Proposition involutionNegationVersTiersExclu :
  involutionNegation -> tiersExclu.
Proof.
    intros InvolutionNegation P.
    apply(InvolutionNegation (P \/ ~ P)).
    intro H_nega_ou_non.
    apply H_nega_ou_non.
    right.
    intro p'.
    apply H_nega_ou_non.
    left.
    exact p'.
Qed.

(*
  Indication :
  - décomposer la preuve de la disjonction (P \/ ~P) obtenue en appliquant
  le lemme involutionNegationVersTiersExclu à la proposition P.
 *)
Proposition involutionNegationVersImplicationMaterielle :
  involutionNegation -> implicationMaterielle.
Proof.
 intros H1 P Q.
  intros H2.
  apply involutionNegationVersTiersExclu in H1.
  case (H1 P).
  - intros P'.
    right.
    apply H2.
    exact P'.
  - intros H3.
    left.
    exact H3.
Qed.
Check or_comm.
(*
  Indication :
  - utiliser la proposition or_comm exprimant la commutativité de la disjonction (or).
 *)
Proposition implicationMaterielleVersTiersExclu :
  implicationMaterielle -> tiersExclu.
Proof.
  intros H1 P1.
  apply or_comm.
  apply H1.
  intro P2.
  exact P2.
  apply P2.
Qed.
(*
  Indication :
  - utiliser deux propositions déjà montrées.
 *)
Proposition implicationMaterielleVersInvolutionNegation :
  implicationMaterielle -> involutionNegation.
Proof.
  unfold implicationMaterielle.
  unfold involutionNegation.
  intro h.
  apply tiersExcluVersInvolutionNegation.
  apply implicationMaterielleVersTiersExclu.
  exact h.
Defined.
(*
  Indication :
  - utiliser l'involution de la négation.
 *)
Proposition implicationMaterielleVersReciproqueContraposition :
  implicationMaterielle -> reciproqueContraposition.
Proof.
  intros IM P Q.
  intros n_q_n_p p.
  apply implicationMaterielleVersInvolutionNegation.
  assumption.
  intro n_q.
  apply n_q_n_p.
  apply  n_q.
  exact p.
Qed.

(*
  Indication :
  - appliquer la réciproque de la contraposition à True et P.
 *)
Proposition reciproqueContrapositionVersInvolutionNegation :
  reciproqueContraposition -> involutionNegation.
Proof.
  unfold reciproqueContraposition.
  unfold involutionNegation.
  intros.
  apply (H True P)
  intros P' H'.
  apply H0.
  exact P'.
  exact I
Admitted.

(** *Définitions inductives - La croissance de listes *)

Inductive EstCroissante : list nat -> Prop :=
| videCroissante : EstCroissante []
| singletonCroissante : forall a, EstCroissante [a]
| consConsCroissante :
    forall a b l, (a <= b)
             -> EstCroissante (b :: l) -> EstCroissante( a :: b :: l).

(*
  --------- [precVide]
  Prec m []

  (t : nat)  (r : list nat)  (m <= t)
  ----------------------------------- [precCons]
  Prec m (t :: r)
 *)
Inductive Prec(m : nat) : list nat -> Prop :=
|precVide : Prec m []
|precCons : forall t r, (m<=t) -> Prec m(t::r).

(* à compléter

----------------- [videCroissante2]

(t: nat) (r: list nat) (precCons t r) /\ EstCroissante2
--------------------------------------------------------- [consCroissante2]
EstCroissante2(t::r)
 *)

Inductive EstCroissante2 : list nat -> Prop :=
|videCroissante2: EstCroissante2 []
|consCroissante2 : forall (t:nat) (r: list nat), (Prec t r) /\ EstCroissante2 r -> EstCroissante2(t::r).

(*
  Indication :
  - procéder par induction sur la preuve de (EstCroissante2 l) ;
  dans le cas d'une liste non vide, décomposer par cas la preuve
  du prédicat Prec.
 *)
Proposition adequation_estCroissante2 : forall l,
    EstCroissante2 l -> EstCroissante l.
Proof.
  intros.
  induction H as [| t r h h2 h3 ].
  - apply videCroissante.
  - case h as [| t2 r2 h1].
    + apply singletonCroissante.
    + apply consConsCroissante.
  exact h1.
  exact h3.
Defined.

(*
  Indication :
  - procéder par induction sur la preuve de (EstCroissante l).
 *)
Proposition completude_estCroissante2 : forall l,
    EstCroissante l -> EstCroissante2 l.
Proof.
  intros.
  induction H.
  - exact videCroissante2.
  - apply consCroissante2.
    + exact (precVide a).
    + exact videCroissante2.
  - apply consCroissante2.
    + apply precCons.
      exact H.
    + exact IHEstCroissante.
Defined.

(** *Définitions inductives - Facteurs d'une liste *)

Proposition associativite_concatenation :
  forall T : Type,
  forall l1 l2 l3 : list T,
    l1 ++ (l2 ++ l3) = (l1 ++ l2) ++ l3.
Proof.
  intros T l1 l2 l3.
  induction l1 as [|pn].
  - simpl. reflexivity.
  - cbn.
    rewrite <- IHl1.
    reflexivity.
Qed.

(* à compléter
  Prefixe k l
------------------ [facteurPrefixe]
  Facteur k l

Facteur k l
-------------------------------- [facteurInterne]
Facteur k a::l
 *)

Inductive Facteur{A : Type}(k : list A) : list A -> Prop :=
| facteurPrefixe : forall l, Facteur k (k++l)
| facteurInterne : forall l1 l2, Facteur k l2 -> Facteur k (l1++l2).

(*
  Indication :
  - procéder par induction sur la preuve de *Facteur k l*,
  - pour prouver l'existence, utiliser la tactique "exists w", où w est le terme
  montrant l'existence.
 *)
Lemma adequation_Facteur :
  forall A, forall k l : list A, Facteur k l -> exists k' k'', k' ++ k ++ k'' = l.
Proof.
  intros A k l H.
  induction H.
  - exists nil.
    exists l.
    cbn.
    reflexivity.
  - case IHFacteur as [k' eg].
    exists ( l1 ++ k' ).
    cbn.
    case eg as [k'' egg].
    exists k''.
    case egg.
    simpl.
    rewrite <- associativite_concatenation.
    reflexivity.
Qed.

(*
  Indication :
  - utiliser directement les constructeurs de Facteur.
 *)
Lemma completude_Facteur :
  forall A, forall k' k k'' l : list A, k' ++ k ++ k'' = l -> Facteur k l.
Proof.
  intros A k' k k'' l HSomme.
  induction HSomme.
  apply facteurInterne.
  apply facteurPrefixe.
Qed.

(** *Entiers naturels - Des fonctions et des propositions utiles *)

(* Addition et ordre *)

Lemma neutraliteDroite_addition :
  forall n : nat, n = n + 0.
Proof.
  intros n.
  induction n.
  - simpl.
    reflexivity.
  - simpl.
    case IHn.
    reflexivity.
Qed.

Lemma sommeSuccesseurs :
  forall n m : nat,
    S n + S m = S (S (n + m)).
Proof.
  intros n m.
  induction n.
  - simpl.
    reflexivity.
  - simpl.
    case IHn.
    reflexivity.
Qed.

(*
  Indication :
  - procéder par induction sur la preuve de (n2 <= n3).
 *)
Proposition transitivite_le :
  forall n1 n2 n3, n1 <= n2 -> n2 <= n3 -> n1 <= n3.
Proof.
  intros n1 n2 n3 H0 H1.
  case H1.
  - apply H0.
  - intros.
    apply le_S.
    rewrite H0.
    apply H.
Qed.

Proposition zeroMin_le :
  forall n, 0 <= n.
Proof.
  intro n.
  induction n.
  - apply le_n.
  - apply le_S.
    apply IHn.
Qed.

Lemma successeurCroissant_le :
  forall m n, m <= n -> S m <= S n.
Proof.
intros n m H.
    induction H as [|pn HR].
    apply le_n.
    apply le_S.
    apply IHHR.
Qed.

(*
  Indication :
  - procéder par induction sur m,
  - utiliser successeurCroissant_le.
 *)
Lemma compatibiliteAdditionGauche_le :
  forall m n1 n2, n1 <= n2 -> (m + n1) <= (m + n2).
Proof.
  intros m n1 n2 H.
  induction m.
  - simpl.
    apply H.
  - simpl.
    apply successeurCroissant_le.
    apply IHm.
Qed.

(*
  Indication :
  - procéder par induction sur la preuve de (m1 <= m2),
  - utiliser compatibiliteAdditionGauche_le.
 *)
Proposition compatibiliteAddition_le :
  forall m1 m2 n1 n2, m1 <= m2 -> n1 <= n2 -> (m1 + n1) <= (m2 + n2).
Proof.
  intros m1 m2 n1 n2 H0 H1.
  induction H0.
  - cbn.
    apply compatibiliteAdditionGauche_le.
    apply H1.
  - simpl.
    apply le_S.
    apply IHle.
Qed.

(*
  Indication :
  - utiliser compatibiliteAddition_le.
 *)
Proposition compatibiliteAddition_zeroMinDroite_le :
  forall m1 m2 n, m1 <= m2 -> m1 <= (m2 + n).
Proof.
  intros m1 m2 n H.
  case n.
  - rewrite <- neutraliteDroite_addition.
    apply H.
  - intros.
  Admitted.

(* Maximum et puissance *)

Fixpoint max(m n : nat) : nat.
  exact (Nat.max m n). (* à modifier *)
Defined.

(*
  Indication :
  - procéder par induction sur m, avec une hypothèse de récurrence
  quantifiée universellement sur n.
 *)
Proposition commutativite_max :
  forall m n, max m n = max n m.
Proof.
  intros m.
  induction m.
  - intros n.
    case n.
    + cbn.
      reflexivity.
    + cbn.
      reflexivity.
  - intros n.
    Admitted.

Proposition idempotence_max :
  forall n, n = max n n.
Proof.
  intros n.
  case n.
  - simpl.
    reflexivity.
  - intro m.
    cbn.
Admitted.

(*
  Indication :
  - procéder par induction sur m, avec une hypothèse de récurrence
  quantifiée universellement sur n.
 *)
Proposition majorantGauche_max :
  forall m n, m <= max m n.
Proof.
  intros m.
  induction m.
  - intro n.
    simpl.
    apply zeroMin_le.
  - intro n.
Admitted.

(*
  Indication :
  - utiliser la commutativité.
 *)
Proposition majorantDroite_max :
  forall m n, n <= max m n.
Proof.
  intros m n.
  rewrite commutativite_max.
  apply majorantGauche_max.
Qed.

Fixpoint puissance(m n : nat) : nat.
  exact (Nat.pow m n). (* à modifier *)
Defined.

(*
  Indication :
  - procéder par induction sur la preuve de (n1 <= n2).
 *)
Proposition croissance_puissance :
  forall (m n1 n2 : nat),
    n1 <= n2 -> puissance (S m) n1 <= puissance (S m) n2.
Proof.
  intros n1 n2 m H.
  induction H.
  - reflexivity.
  -
  Admitted.

(** *Arbres binaires - Un encadrement de la taille    *)

(* à compléter

-------  [arbreVide]
vide : Arbre T

t: T, g : Arbre T, d: Arbre t
-----------------------  [arbreCons]
cons t g d : Arbre T
*)

Inductive Arbre(T : Type) : Type :=
  |arbreVide : Arbre T
  |arbreCons : T -> (Arbre T) -> (Arbre T) -> (Arbre T)
.

Proposition principeInductif_Arbre :
  forall (T : Type) (P : Arbre T -> Prop),
    (* à compléter *)
    forall (a : Arbre T), P a.
Proof.
  intros T P H.
Admitted.

Fixpoint hauteur{T : Type}(a : Arbre T) : nat.
  exact 0. (* à modifier *)
Defined.

Fixpoint taille{T : Type}(a : Arbre T) : nat.
  exact 0. (* à modifier *)
Defined.

Definition unArbre : Arbre nat.
Admitted.

Example hauteurArbre : hauteur (unArbre) = 3.
Admitted.

Example tailleArbre : taille (unArbre) = 5.
Admitted.

(*
  Indication :
  - procéder par induction sur l'arbre,
  - utiliser les propositions démontrées sur les entiers naturels.
 *)
Proposition majorationTaille_Arbre :
  forall T : Type,
  forall a : Arbre T,
    S (taille a) <= (puissance 2 (hauteur a)).
Proof.
Admitted.

(*
  Indication :
  - décomposer la preuve de (inhabited T) en hypothèse
  pour obtenir un élément de T,
  - procéder par induction sur n,
  - utiliser les propositions démontrées sur les entiers naturels,
  - pour prouver une conjonction, utiliser "split".
 *)
Print inhabited.
Proposition majorationOptimaleTaille_Arbre :
  forall T : Type,
    inhabited T ->
    forall n : nat,
    exists a : Arbre T,
      hauteur a = n
      /\
      S (taille a) = (puissance 2 (hauteur a)).
Proof.
Admitted.


(** 1 optional exercise attempted and 1 completed *)

(** Exercise 1 (dist_not_exists) *)
Theorem dist_not_exists : forall (X:Type) (P : X -> Prop),
  (forall x, P x) -> ~ (exists x, ~ P x).
Proof.
  intros. unfold not. intros. inversion H0.
    apply H1. apply H.
Qed.

(** Exercise 2 (dist_exists_or) *)
Theorem dist_exists_or : forall (X:Type) (P Q : X -> Prop),
  (exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
Proof.
  intros. split. intros. inversion H. inversion H0.
  Case "L".
    left. exists witness. apply H1.
    right. exists witness. apply H1.
  Case "R".
   intros. inversion H.
     inversion H0. exists witness. left. apply H1.
     inversion H0. exists witness. right. apply H1.
Qed.

(** Exercise 3 (override_shadow') *)
Theorem override_shadow' : forall (X:Type) x1 x2 k1 k2 (f : nat->X),
  (override' (override' f k1 x2) k1 x1) k2 = (override' f k1 x1) k2.
Proof.
  intros.
  unfold override'.
  destruct (eq_nat_dec k1 k2).
    reflexivity.
    reflexivity.
Qed.

(** Exercise 4 (all_forallb) *)
Inductive all {X : Type} (P : X -> Prop) : list X -> Prop :=
  | a_nil : all P []
  | a_cons h t : P h -> all P t -> all P (h :: t).

Fixpoint forallb {X : Type} (test : X → bool) (l : list X) : bool :=
  match l with
    | [] ⇒ true
    | x :: l' ⇒ andb (test x) (forallb test l')
  end.

Theorem forallb_spec :
  forall X (test : X -> bool) (l : list X),
    forallb test l = true <-> all (fun x => test x = true) l.
Proof.
  intros. split. intros. induction l as [|h t].
    Case "1".
      apply a_nil.
    Case "2".
      apply a_cons.
      simpl in H.
      destruct (test h). reflexivity. apply H.
      apply IHt. simpl in H.
      destruct (test h). apply H. inversion H.
   Case "3".
    intros.
    induction H.
      reflexivity.
      simpl. rewrite H. simpl. apply IHall.
Qed.

(** Exercise 5 (nostutter) *)
Inductive nostutter:  list nat -> Prop :=
  ns_nil : nostutter []
| ns_one : forall x, nostutter [x]
| ns_two : forall x y l, x <> y -> nostutter (y :: l) -> nostutter (x :: (y :: l)).
Example test_nostutter_1:      nostutter [3;1;4;1;5;6].
  Proof. repeat constructor; apply beq_nat_false; auto. Qed.

Example test_nostutter_2:  nostutter [].
  Proof. repeat constructor; apply beq_nat_false; auto. Qed.

Example test_nostutter_3:  nostutter [5].
  Proof. repeat constructor; apply beq_nat_false; auto. Qed.

Example test_nostutter_4:      not (nostutter [3;1;1;4]).
  Proof. intro.
  repeat match goal with
    h: nostutter _ |- _ => inversion h; clear h; subst
  end.
  contradiction H1; auto. Qed.

(Exercise 6 (optional (not_exists_dist) )*)
Theorem not_exists_dist :
  excluded_middle ->
  forall (X:Type) (P : X -> Prop),
    ~ (exists x, ~ P x) -> (forall x, P x).
Proof.
  unfold excluded_middle. intros HEM X P. unfold not. intros HNE x.
  assert (P x \/ ~ P x). apply HEM.
  inversion H.
    apply H0.
    apply ex_falso_quodlibet. apply HNE. unfold not in H0. exists x. apply H0.
Qed.


Require Import List Logic Nat Arith Bool Omega Classical.
Require Import Compare_dec EqNat Decidable ListDec FinFun.
Require Fin.
Import ListNotations.
From Block
Require Import lib definitions.

Definition Ramsey_of {X : Type} (r s : nat) (H_r : r > 0) (H_s : s > 0) (rk : nat) (d : X) :=
  forall l : list X, length l = rk ->
                forall f : X -> X -> bool,
                (exists bl : list X, length bl = r /\ subseq bl l /\
                               forall i j : nat, i < j < r ->
                                          f (nth i bl d) (nth j bl d) = true)
                \/ (exists bl : list X, length bl = s /\ subseq bl l /\
                                  forall i j : nat, i < j < s ->
                                             f (nth i bl d) (nth j bl d) = false).

Definition Ramsey_of_prop {X : Type} (r s : nat) (H_r : r > 0) (H_s : s > 0) (rk : nat) (d : X) :=
  forall l : list X, length l = rk ->
                forall P : X -> X -> Prop,
                (exists bl : list X, length bl = r /\ subseq bl l /\
                               forall i j : nat, i < j < r ->
                                          P (nth i bl d) (nth j bl d))
                \/ (exists bl : list X, length bl = s /\ subseq bl l /\
                                  forall i j : nat, i < j < s ->
                                             ~ P (nth i bl d) (nth j bl d)).

Lemma one : 1 > 0. Proof. omega. Qed.

Theorem Ramsey_of_one {X : Type} :
  forall (k : nat) (H_k : k > 0) (d : X),
    Ramsey_of 1 k one H_k 1 d /\
    Ramsey_of k 1 H_k one 1 d.
Proof.
  intros k H_k d; split; red; repeat split; try omega; intros l H_l f.
  - left. exists l. split. assumption.
    split. apply subseq_refl. intros. omega.
  - right. exists l. split. assumption.
    split. apply subseq_refl. intros. omega.
Qed.

Theorem Ramsey_of_one_prop {X : Type} :
  forall (k : nat) (H_k : k > 0) (d : X),
    Ramsey_of_prop 1 k one H_k 1 d /\
    Ramsey_of_prop k 1 H_k one 1 d.
Proof.
  intros k H_k d; split; red; repeat split; try omega; intros l H_l f.
  - left. exists l. split. assumption.
    split. apply subseq_refl. intros. omega.
  - right. exists l. split. assumption.
    split. apply subseq_refl. intros. omega.
Qed.

Theorem Ramsey_inductive_step {X : Type} :
  forall (r s : nat) (H_r : r > 0) (H_s : s > 0) (d : X),
  exists rk : nat,
    Ramsey_of r s H_r H_s rk d.
Proof.
  intros r s.
  remember (r + s) as k.
  revert r s Heqk.
  induction k as [|k IHk] using strong_induction; intros.
  - symmetry in Heqk; apply plus_is_O in Heqk.
    destruct Heqk; subst. inversion H_r.
  - destruct r as [|r]. inversion H_r.
    destruct s as [|s]. inversion H_s.
    destruct r as [|r].
    (* Pseudo base case, when r = 1 *)
    exists 1.
    apply (Ramsey_of_one (S s) H_s d).
    (* Pseudo base case, when s = 1 *)
    destruct s as [|s].
    exists 1.
    apply (Ramsey_of_one (S (S r)) H_r d).
    (* Finally, everything is big enough *)
    destruct k. omega. destruct k. omega.
    (* Both (S r) and (S s) are greater than or equal to 1,
       and therefore (S (S k)) is greater than or equal to two *)
    (* Reminder : r = S r, s = S s, k = S (S k) *)
    spec IHk (S k).
    spec IHk. omega.
    assert (IHk_copy := IHk).
    spec IHk (S r) (S (S s)).
    spec IHk_copy (S (S r)) (S s).
    spec IHk. omega. spec IHk_copy. omega.
    assert (H_pre1 : S r > 0) by omega.
    spec IHk H_pre1 H_s.
    spec IHk_copy H_r.
    assert (H_pre2 : S s > 0) by omega.
    spec IHk_copy H_pre2.
    spec IHk d. spec IHk_copy d.
    destruct IHk as [rk1 IHk1].
    destruct IHk_copy as [rk2 IHk2].
    exists (rk1 + rk2); red; intros l H_l f.
    red in IHk1, IHk2.
    destruct l as [|v l_rest].
    (* Inversioning the base case list *)
    + unfold length in H_l. symmetry in H_l.
      apply plus_is_O in H_l. destruct H_l; subst.
      spec IHk1 ([] : list X).
      spec IHk1. reflexivity.
      spec IHk1 f. destruct IHk1;
      destruct H as [bl_absurd [absurd_length [absurd_subseq _]]];
      assert (bl_absurd = []) by (apply (subseq_nil_nil); assumption);
      subst; simpl in absurd_length; inversion absurd_length.
    + (* Now we have a pivot vertex *)
      remember (filter (fun n => f v n) l_rest) as M.
      remember (filter (fun n => negb (f v n)) l_rest) as N.
      assert (length M + length N = length l_rest).
      { subst; apply filter_length. }
      simpl in H_l.
      assert (length M >= rk1 \/ length N >= rk2) by omega.
      destruct H0 as [red | blue].
      * (* In the case that M has a red K_(S s) *)
        clear IHk2.
        assert (H_get := get_subseq M rk1 red).
        assert (H_trans : subseq M l_rest) by (subst M; apply (filter_subseq_correct')).
        destruct H_get as [red_list [H_red_length H_red_subseq]].
        spec IHk1 red_list H_red_length f.
        destruct IHk1 as [left | right].
        ** destruct left as [bl [bl_length [bl_subseq bl_color]]].
           left. exists (v :: bl). repeat split.
           simpl; omega. apply subseq_hm.
           do 2 (eapply subseq_trans; eauto).
           (* Boom! *)
           intros.
           destruct j.
           omega. destruct i.
           (* When we're looking at the head, i.e. v *)
           { simpl. subst M.
             assert (subseq bl (filter (fun n => f v n) l_rest)).
             eapply subseq_trans; eauto.
             apply subseq_incl in H1. spec H1 (nth j bl d).
             spec H1. apply nth_In. omega.
             apply filter_In in H1. destruct H1 as [_ goal].
             exact goal. }
           spec bl_color i j.
           spec bl_color. omega.
           simpl. assumption.
        ** destruct right as [bl [bl_length [bl_subseq bl_color]]].
           right. exists bl. repeat split.
           assumption. apply subseq_hn.
           do 2 (eapply subseq_trans; eauto).
           assumption.
      * (* In the case that N has a blue K_r *)
        clear IHk1.
        assert (H_get := get_subseq N rk2 blue).
        assert (H_trans : subseq N l_rest) by (subst N; apply (filter_subseq_correct')).
        destruct H_get as [blue_list [H_blue_length H_blue_subseq]].
        spec IHk2 blue_list H_blue_length f.
        destruct IHk2 as [left | right].
        ** destruct left as [bl [bl_length [bl_subseq bl_color]]].
           left. exists bl. repeat split.
           assumption. apply subseq_hn.
           do 2 (eapply subseq_trans; eauto).
           assumption.
        ** destruct right as [bl [bl_length [bl_subseq bl_color]]].
           right. exists (v :: bl). repeat split.
           simpl; omega. apply subseq_hm.
           do 2 (eapply subseq_trans; eauto).
           (* Boom! *)
           intros.
           destruct j.
           omega. destruct i. simpl. subst M.
           { simpl. subst N.
             assert (subseq bl (filter (fun n => negb (f v n)) l_rest)).
             eapply subseq_trans; eauto.
             apply subseq_incl in H1. spec H1 (nth j bl d).
             spec H1. apply nth_In. omega.
             apply filter_In in H1. destruct H1 as [_ goal].
             apply negb_true_iff in goal. exact goal. }
           spec bl_color i j.
           spec bl_color. omega.
           simpl. assumption.
Qed.

Print Assumptions Ramsey_inductive_step.
(* This requires no additional axioms *)

(* Ramsey in Prop *)
Lemma filterprop_vanilla : forall X (P : X -> Prop) (L : list X),
    exists L',
      forall x, In x L' <-> (In x L /\ P x).
Proof.
  induction L. exists nil. split. inversion 1. intros [? _]. inversion H.
  destruct IHL as [L' ?]. destruct (classic (P a)).
  exists (a :: L'). split; intros. destruct H1. split. left. assumption. subst. assumption.
  split. right. apply H in H1. destruct H1. assumption.
  apply H in H1. destruct H1. assumption.
  destruct H1. destruct H1. left. assumption.
  right. apply H. split; assumption.
  exists L'. split; intros.
  apply H in H1. destruct H1. split. right. assumption. assumption.
  apply H. destruct H1. destruct H1. subst. contradiction.
  split; assumption.
Qed.

Lemma filterprop_armed : forall X (P : X -> Prop) (L : list X),
    forall (Q : list X -> Prop)
      (f : list X -> list X)
      (H_correct : forall l : list X, Q (f l) /\ (forall w, In w (f l) <-> In w l)),
    exists L', Q L' /\
          forall x, In x L' <-> (In x L /\ P x).
Proof.
  intros.
  destruct (filterprop_vanilla X P L) as [L_vanilla about_L_vanilla].
  exists (f L_vanilla).
  spec H_correct L_vanilla.
  destruct H_correct.
  split. assumption.
  intro; split; intro. apply about_L_vanilla.
  apply H0. assumption. apply about_L_vanilla in H1.
  spec H0 x. apply H0. assumption.
Qed.

Lemma filterprop_vanilla_dep : forall X (D : X -> Prop) (P : {x | D x} -> Prop) (L : list {x | D x}),
    exists L', (* sublist L' L /\ *)
      forall x, In x L' <-> (In x L /\ P x).
Proof.
  induction L. exists nil. split. inversion 1. intros [? _]. inversion H.
  destruct IHL as [L' ?]. destruct (classic (P a)).
  exists (a :: L'). split; intros. destruct H1. split. left. assumption. subst. assumption.
  split. right. apply H in H1. destruct H1. assumption.
  apply H in H1. destruct H1. assumption.
  destruct H1. destruct H1. left. assumption.
  right. apply H. split; assumption.
  exists L'. split; intros.
  apply H in H1. destruct H1. split. right. assumption. assumption.
  apply H. destruct H1. destruct H1. subst. contradiction.
  split; assumption.
Qed.

Theorem filterprop_subseq_both :
   forall (X : Type) (P : X -> Prop) (L : list X),
   exists L' L'': list X, length L' + length L'' = length L /\
                     subseq L' L /\ subseq L'' L /\
                     (forall x : X, In x L' <-> In x L /\ P x) /\
                     (forall x : X, In x L'' <-> In x L /\ ~ P x).
Proof.
  induction L as [|hd tl IHL].
  + exists nil, nil. repeat split.
    apply subseq_nil.
    apply subseq_nil.
    inversion H.
    inversion H.
    intros [absurd _]; inversion absurd.
    inversion H.
    inversion H.
    intros [absurd _]; inversion absurd.
  + destruct IHL as [L' [L'' [H_length [H_subseq' [H_subseq'' [H_in1 H_in2]]]]]].
    destruct (classic (P hd)).
    * exists (hd :: L'), L''. repeat split.
      simpl; omega.
      now apply subseq_hm.
      now apply subseq_hn.
      destruct H0 as [H_eq | H_tl].
      subst. apply in_eq.
      apply H_in1 in H_tl. destruct H_tl as [goal _].
      right; assumption.
      destruct H0 as [H_eq | H_tl].
      subst; assumption.
      apply H_in1 in H_tl. destruct H_tl as [_ goal]; assumption.
      intro. destruct H0 as [[H_eq | H_tl] H_P].
      subst. apply in_eq.
      right. apply H_in1. split; assumption.
      apply H_in2 in H0. destruct H0 as [goal _]; right; assumption.
      apply H_in2 in H0; destruct H0 as [_ goal]; assumption.
      intros [H_in H_notP]. apply H_in2.
      destruct H_in as [H_eq | H_tl].
      subst. contradiction.
      split; assumption.
    * exists L', (hd :: L''). repeat split.
      simpl; omega.
      now apply subseq_hn.
      now apply subseq_hm.
      apply H_in1 in H0.
      destruct H0 as [goal _]; right; assumption.
      apply H_in1 in H0. destruct H0 as [_ goal]; assumption.
      intros [H_in H_P].
      destruct H_in as [H_eq | H_tl].
      subst. contradiction.
      apply H_in1. split; assumption.
      destruct H0 as [H_eq | H_tl].
      subst. apply in_eq. apply H_in2 in H_tl.
      destruct H_tl as [goal _]; right; assumption.
      destruct H0 as [H_eq | H_tl].
      subst. assumption.
      apply H_in2 in H_tl.
      destruct H_tl as [_ goal]; assumption.
      intros [H_in H_notP]. destruct H_in as [H_eq | H_tl].
      subst. apply in_eq. right. apply H_in2.
      tauto.
Qed.

Theorem Ramsey_inductive_step_prop {X : Type} :
  forall (r s : nat) (H_r : r > 0) (H_s : s > 0) (d : X),
  exists rk : nat,
    Ramsey_of_prop r s H_r H_s rk d.
Proof.
  intros r s.
  remember (r + s) as k.
  revert r s Heqk.
  induction k as [|k IHk] using strong_induction; intros.
  - symmetry in Heqk; apply plus_is_O in Heqk.
    destruct Heqk; subst. inversion H_r.
  - destruct r as [|r]. inversion H_r.
    destruct s as [|s]. inversion H_s.
    destruct r as [|r].
    (* Pseudo base case, when r = 1 *)
    exists 1.
    apply (Ramsey_of_one_prop (S s) H_s d).
    (* Pseudo base case, when s = 1 *)
    destruct s as [|s].
    exists 1.
    apply (Ramsey_of_one_prop (S (S r)) H_r d).
    (* Finally, everything is big enough *)
    destruct k. omega. destruct k. omega.
    (* Both (S r) and (S s) are greater than or equal to 1,
       and therefore (S (S k)) is greater than or equal to two *)
    (* Reminder : r = S r, s = S s, k = S (S k) *)
    spec IHk (S k).
    spec IHk. omega.
    assert (IHk_copy := IHk).
    spec IHk (S r) (S (S s)).
    spec IHk_copy (S (S r)) (S s).
    spec IHk. omega. spec IHk_copy. omega.
    assert (H_pre1 : S r > 0) by omega.
    spec IHk H_pre1 H_s.
    spec IHk_copy H_r.
    assert (H_pre2 : S s > 0) by omega.
    spec IHk_copy H_pre2.
    spec IHk d. spec IHk_copy d.
    destruct IHk as [rk1 IHk1].
    destruct IHk_copy as [rk2 IHk2].
    exists (rk1 + rk2); red; intros l H_l f.
    red in IHk1, IHk2.
    destruct l as [|v l_rest].
    (* Inversioning the base case list *)
    + unfold length in H_l. symmetry in H_l.
      apply plus_is_O in H_l. destruct H_l; subst.
      spec IHk1 ([] : list X).
      spec IHk1. reflexivity.
      spec IHk1 f. destruct IHk1;
      destruct H as [bl_absurd [absurd_length [absurd_subseq _]]];
      assert (bl_absurd = []) by (apply (subseq_nil_nil); assumption);
      subst; simpl in absurd_length; inversion absurd_length.
    + (* Now we have a pivot vertex *)
      assert (H_list := filterprop_subseq_both _ (f v) l_rest).
      destruct H_list as [M [N [MN_length [M_subseq [N_subseq [H_trans H_trans']]]]]].
      simpl in H_l.
      assert (length M >= rk1 \/ length N >= rk2) by omega.
      destruct H as [red | blue].
      * (* In the case that M has a red K_(S s) *)
        clear IHk2.
        assert (H_get := get_subseq M rk1 red).
        destruct H_get as [red_list [H_red_length H_red_subseq]].
        spec IHk1 red_list H_red_length f.
        destruct IHk1 as [left | right].
        ** destruct left as [bl [bl_length [bl_subseq bl_color]]].
           left. exists (v :: bl). repeat split.
           simpl; omega. apply subseq_hm.
           do 2 (eapply subseq_trans; eauto).
           (* Boom! *)
           intros.
           destruct j.
           omega. destruct i.
           (* When we're looking at the head, i.e. v *)
           { simpl. apply H_trans.
             apply subseq_incl in H_red_subseq.
             spec H_red_subseq (nth j bl d).
             apply H_red_subseq.
             apply subseq_incl in bl_subseq.
             spec bl_subseq (nth j bl d).
             apply bl_subseq. apply nth_In. omega. }
           spec bl_color i j.
           spec bl_color. omega.
           simpl. assumption.
        ** destruct right as [bl [bl_length [bl_subseq bl_color]]].
           right. exists bl. repeat split.
           assumption. apply subseq_hn.
           do 2 (eapply subseq_trans; eauto).
           assumption.
      * (* In the case that N has a blue K_r *)
        clear IHk1.
        assert (H_get := get_subseq N rk2 blue).
        destruct H_get as [blue_list [H_blue_length H_blue_subseq]].
        spec IHk2 blue_list H_blue_length f.
        destruct IHk2 as [left | right].
        ** destruct left as [bl [bl_length [bl_subseq bl_color]]].
           left. exists bl. repeat split.
           assumption. apply subseq_hn.
           do 2 (eapply subseq_trans; eauto).
           assumption.
        ** destruct right as [bl [bl_length [bl_subseq bl_color]]].
           right. exists (v :: bl). repeat split.
           simpl; omega. apply subseq_hm.
           do 2 (eapply subseq_trans; eauto).
           (* Boom! *)
           intros.
           destruct j.
           omega. destruct i. simpl.
           { simpl.
             apply H_trans'.
             apply subseq_incl in H_blue_subseq.
             spec H_blue_subseq (nth j bl d).
             apply H_blue_subseq.
             apply subseq_incl in bl_subseq.
             spec bl_subseq (nth j bl d).
             apply bl_subseq. apply nth_In. omega. }
           spec bl_color i j.
           spec bl_color. omega.
           simpl. assumption.
Qed.

Theorem Ramsey_single :
  forall (k : nat),
    k > 0 ->
    exists rk : nat, rk >= k /\
              forall l : list nat, length l = rk ->
                            forall f : nat -> nat -> bool,
                              (exists bl : list nat, length bl = k /\ subseq bl l /\
                                              forall i j : nat, i < j < k ->
                                                         f (nth i bl d) (nth j bl d) = true)
                              \/ (exists bl : list nat, length bl = k /\ subseq bl l /\
                                                forall i j : nat, i < j < k ->
                                                           f (nth i bl d) (nth j bl d) = false).
Proof.
  intros k H_gt_zero.
  assert (H_one := @Ramsey_of_one nat).
  assert (H_step := @Ramsey_inductive_step nat).
  spec H_one k H_gt_zero d.
  specialize (H_step k k H_gt_zero H_gt_zero d).
  destruct k. inversion H_gt_zero.
  destruct k.
  destruct H_one as [rk H_one].
  exists 1.
  split. omega.
  exact H_one. destruct H_step as [rk H_step].
  assert (rk >= S (S k) \/ rk < S (S k)) by omega.
  destruct H as [yes | no].
  exists rk. split.
  assumption. assumption.
  exists rk. clear H_one.
  red in H_step.
  spec H_step (iota 0 rk). spec H_step.
  apply length_iota. spec H_step (fun i j : nat => true).
  destruct H_step. destruct H.
  destruct H. destruct H0.
  apply short_subseq_inversion in H0. inversion H0.
  rewrite H. rewrite length_iota. assumption.
  destruct H. destruct H.
  destruct H0. apply short_subseq_inversion in H0.
  inversion H0. rewrite H. rewrite length_iota; assumption.
Qed.

Theorem Ramsey_single_prop :
  forall (k : nat),
    k > 0 ->
    exists rk : nat, rk >= k /\
              forall l : list nat, length l = rk ->
                            forall f : nat -> nat -> Prop,
                              (exists bl : list nat, length bl = k /\ subseq bl l /\
                                              forall i j : nat, i < j < k ->
                                                         f (nth i bl d) (nth j bl d))
                              \/ (exists bl : list nat, length bl = k /\ subseq bl l /\
                                                forall i j : nat, i < j < k ->
                                                           ~ f (nth i bl d) (nth j bl d)).
Proof.
  intros k H_gt_zero.
  assert (H_one := @Ramsey_of_one_prop nat).
  assert (H_step := @Ramsey_inductive_step_prop nat).
  spec H_one k H_gt_zero d.
  specialize (H_step k k H_gt_zero H_gt_zero d).
  destruct k. inversion H_gt_zero.
  destruct k. exists 1.
  split. omega.
  destruct H_one. assumption.
  destruct H_step as [rk H_step].
  assert (rk >= S (S k) \/ rk < S (S k)) by omega.
  destruct H as [yes | no].
  exists rk. split.
  assumption. assumption.
  exists rk. clear H_one.
  red in H_step.
  spec H_step (iota 0 rk). spec H_step.
  apply length_iota. spec H_step (fun i j : nat => True).
  destruct H_step. destruct H.
  destruct H. destruct H0.
  apply short_subseq_inversion in H0. inversion H0.
  rewrite H. rewrite length_iota. assumption.
  destruct H. destruct H.
  destruct H0. apply short_subseq_inversion in H0.
  inversion H0. rewrite H. rewrite length_iota; assumption.
Qed.

Theorem Theorem_of_Ramsey_duo :
  forall (k : block_pumping_constant),
    exists rk : block_pumping_constant, rk >= k /\
      forall w : word,
      forall bps : breakpoint_set rk w,
      forall (P : nat -> nat -> Prop)
        (f : nat -> nat -> bool)
        (H : forall i j, (f i j = true <-> P i j) /\
                    (f i j = false <-> ~ P i j)),
        exists bps' : breakpoint_set k w,
          sublist bps' bps /\
          ((forall bp1 bp2 : breakpoint bps',
              bp1 < bp2 -> (P bp1 bp2))
          \/  (forall bp1 bp2 : breakpoint bps',
                 bp1 < bp2 -> ~ (P bp1 bp2))).
Proof.
  intro k.
  assert (H_ramsey := Ramsey_single k).
  destruct k as [k about_k]; unfold p_predicate in about_k.
  spec H_ramsey. simpl; omega.
  destruct H_ramsey as [rk [rk_fact H_ramsey]].
  simpl in rk_fact.
  assert (about_rk : rk >= 2). omega.
  exists (exist p_predicate rk about_rk).
  split. simpl. assumption.
  intros w bps P f f_correct.
  destruct bps as [bps [bps_length [bps_incr bps_last]]].
  simpl in *.
  spec H_ramsey bps bps_length f.
  destruct H_ramsey as [yes | no].
  - destruct yes as [bps_yes [bps_yes_length [bps_yes_subseq yes]]].
    assert (breakpoint_set_predicate bps_yes w (exist _ k about_k)).
    { repeat split. simpl. assumption.
      now apply (subseq_incr bps).
      assert (H_trans := about_subseq_last bps_yes bps d).
      spec H_trans. rewrite bps_yes_length; omega.
      spec H_trans. rewrite bps_length; omega.
      spec H_trans. assumption.
      spec H_trans. exact bps_yes_subseq.
      now apply (le_trans (last bps_yes d) (last bps d) (length w)). }
      exists (exist _ bps_yes H); simpl in *.
      split.
      apply subseq_incl in bps_yes_subseq.
      assumption.
      left. intros.
      destruct bp1 as [bp1 about_bp1];
        destruct bp2 as [bp2 about_bp2];
        unfold breakpoint_predicate in *.
      simpl in *.
      apply (In_nth _ _ d) in about_bp1.
      apply (In_nth _ _ d) in about_bp2.
      destruct about_bp1 as [i [i_pos i_eq]].
      destruct about_bp2 as [j [j_pos j_eq]].
      spec yes i j. spec yes.
      rewrite bps_yes_length in i_pos, j_pos.
      split.
     eapply increasing_nth_lt.
     destruct H as [_ [bps_yes_incr bps_yes_last]].
     exact bps_yes_incr. rewrite bps_yes_length; assumption.
     rewrite bps_yes_length; assumption.
     rewrite i_eq, j_eq.  assumption. assumption.
     spec f_correct (nth i bps_yes d) (nth j bps_yes d).
     rewrite <- i_eq. rewrite <- j_eq.
    destruct f_correct as [f_correct _].
    apply f_correct. assumption.
  - destruct no as [bps_no [bps_no_length [bps_no_subseq no]]].
    assert (breakpoint_set_predicate bps_no w (exist _ k about_k)).
    { repeat split. simpl. assumption.
      now apply (subseq_incr bps).
      assert (H_trans := about_subseq_last bps_no bps d).
      spec H_trans. rewrite bps_no_length; omega.
      spec H_trans. rewrite bps_length; omega.
      spec H_trans. assumption.
      spec H_trans. exact bps_no_subseq.
      now apply (le_trans (last bps_no d) (last bps d) (length w)). }
    exists (exist _ bps_no H); simpl in *.
    split.
    apply subseq_incl in bps_no_subseq.
    assumption.
    right. intros.
    destruct bp1 as [bp1 about_bp1];
      destruct bp2 as [bp2 about_bp2];
      unfold breakpoint_predicate in *.
    simpl in *.
    apply (In_nth _ _ d) in about_bp1.
    apply (In_nth _ _ d) in about_bp2.
    destruct about_bp1 as [i [i_pos i_eq]].
    destruct about_bp2 as [j [j_pos j_eq]].
    spec no i j. spec no.
    rewrite bps_no_length in i_pos, j_pos.
    split.
    eapply increasing_nth_lt.
    destruct H as [_ [bps_no_incr bps_no_last]].
    exact bps_no_incr. rewrite bps_no_length; assumption.
    rewrite bps_no_length; assumption.
    rewrite i_eq, j_eq.  assumption. assumption.
    spec f_correct (nth i bps_no d) (nth j bps_no d).
    rewrite <- i_eq. rewrite <- j_eq.
    destruct f_correct as [_ f_correct].
    apply f_correct. assumption.
Qed.

Theorem Theorem_of_Ramsey_duo_prop :
  forall (k : block_pumping_constant),
    exists rk : block_pumping_constant, rk >= k /\
      forall w : word,
      forall bps : breakpoint_set rk w,
      forall (P : nat -> nat -> Prop),
        exists bps' : breakpoint_set k w,
          sublist bps' bps /\
          ((forall bp1 bp2 : breakpoint bps',
              bp1 < bp2 -> (P bp1 bp2))
          \/  (forall bp1 bp2 : breakpoint bps',
                 bp1 < bp2 -> ~ (P bp1 bp2))).
Proof.
  intro k.
  assert (H_ramsey := Ramsey_single_prop k).
  destruct k as [k about_k]; unfold p_predicate in about_k.
  spec H_ramsey. simpl; omega.
  destruct H_ramsey as [rk [rk_fact H_ramsey]].
  simpl in rk_fact.
  assert (about_rk : rk >= 2). omega.
  exists (exist p_predicate rk about_rk).
  split. simpl. assumption.
  intros w bps P.
  destruct bps as [bps [bps_length [bps_incr bps_last]]].
  simpl in *.
  spec H_ramsey bps bps_length P.
  destruct H_ramsey as [yes | no].
  - destruct yes as [bps_yes [bps_yes_length [bps_yes_subseq yes]]].
    assert (breakpoint_set_predicate bps_yes w (exist _ k about_k)).
    { repeat split. simpl. assumption.
      now apply (subseq_incr bps).
      assert (H_trans := about_subseq_last bps_yes bps d).
      spec H_trans. rewrite bps_yes_length; omega.
      spec H_trans. rewrite bps_length; omega.
      spec H_trans. assumption.
      spec H_trans. exact bps_yes_subseq.
      now apply (le_trans (last bps_yes d) (last bps d) (length w)). }
      exists (exist _ bps_yes H); simpl in *.
      split.
      apply subseq_incl in bps_yes_subseq.
      assumption.
      left. intros.
      destruct bp1 as [bp1 about_bp1];
        destruct bp2 as [bp2 about_bp2];
        unfold breakpoint_predicate in *.
      simpl in *.
      apply (In_nth _ _ d) in about_bp1.
      apply (In_nth _ _ d) in about_bp2.
      destruct about_bp1 as [i [i_pos i_eq]].
      destruct about_bp2 as [j [j_pos j_eq]].
      spec yes i j. spec yes.
      rewrite bps_yes_length in i_pos, j_pos.
      split.
     eapply increasing_nth_lt.
     destruct H as [_ [bps_yes_incr bps_yes_last]].
     exact bps_yes_incr. rewrite bps_yes_length; assumption.
     rewrite bps_yes_length; assumption.
     rewrite i_eq, j_eq.  assumption. assumption.
     rewrite <- i_eq. rewrite <- j_eq.
     apply yes.
  - destruct no as [bps_no [bps_no_length [bps_no_subseq no]]].
    assert (breakpoint_set_predicate bps_no w (exist _ k about_k)).
    { repeat split. simpl. assumption.
      now apply (subseq_incr bps).
      assert (H_trans := about_subseq_last bps_no bps d).
      spec H_trans. rewrite bps_no_length; omega.
      spec H_trans. rewrite bps_length; omega.
      spec H_trans. assumption.
      spec H_trans. exact bps_no_subseq.
      now apply (le_trans (last bps_no d) (last bps d) (length w)). }
    exists (exist _ bps_no H); simpl in *.
    split.
    apply subseq_incl in bps_no_subseq.
    assumption.
    right. intros.
    destruct bp1 as [bp1 about_bp1];
      destruct bp2 as [bp2 about_bp2];
      unfold breakpoint_predicate in *.
    simpl in *.
    apply (In_nth _ _ d) in about_bp1.
    apply (In_nth _ _ d) in about_bp2.
    destruct about_bp1 as [i [i_pos i_eq]].
    destruct about_bp2 as [j [j_pos j_eq]].
    spec no i j. spec no.
    rewrite bps_no_length in i_pos, j_pos.
    split.
    eapply increasing_nth_lt.
    destruct H as [_ [bps_no_incr bps_no_last]].
    exact bps_no_incr. rewrite bps_no_length; assumption.
    rewrite bps_no_length; assumption.
    rewrite i_eq, j_eq.  assumption. assumption.
    rewrite <- i_eq. rewrite <- j_eq.
    apply no.
Qed.


(** * 6.822 Formal Reasoning About Programs, Spring 2020 - Pset 2 *)

(*
Author: Samuel Gruetter <gruetter@mit.edu>

This PSet will introduce you to one of the major applications of formal reasoning
about programs: proving that an optimized program behaves the same as a simple program.

Imagine you're writing a program which needs a some function F. You know how to implement
F naively, but as you run your program, you notice that it spends a lot of time in
the function F. You find a library which claims to provide a very efficient implementation
of F, but looking at its source code, you don't really understand why this code should
calculate F, and you've seen some bug reports against previous versions of the library,
so you can't really know whether this library implements F correctly.
Since you care a lot about writing a correct program, you finally decide to keep using
your naive slow implementation.
Formal reasoning about programs to the rescue! If the authors of the library want to
increase the user's trust in their library, they can include the naive but simple-to-
understand version of F in their library as well, and write a proof that for all possible
inputs, the optimized version of F returns the same value as the simple version of F.
If that proof is in a machine-checkable format (e.g. in a Coq file), the library users do
not need to understand the implementation of the optimized F, nor the body of the proof,
but can still use the optimized F and be sure that it does the same as the simple
implementation, as long as they trust the proof checker.

In this PSet, we will put you in the role of the library author who writes a naive
version of F, an optimized implementation of F, and a proof that the two of them behave
the same.
*)

Require Import Coq.NArith.NArith. Open Scope N_scope.
Require Import Coq.Lists.List. Import ListNotations.
Require Import Coq.micromega.Lia.
Require Import Frap.Frap.
Require Import Pset2Sig.
(* Set Default Goal Selector "!". *)

(* Each of the exercises below is worth some number of points.
   If you just want to enjoy the proof hacking without getting distracted by points,
   feel free to ignore these points. On the other hand, if you want to know how
   many points each exercise earns you, you can find the points in Pset2Sig.v. *)

(* Recursive functions *)
(* ******************* *)

(* We will need some recursive functions in this PSet. Defining recursive functions in Coq can be
   a bit tricky, because Coq only accepts recursive functions for which it believes that they always
   terminate.
   For natural numbers represented as "nat", and for data structures like the abstract syntax trees
   we saw in class, recursive functions can usually be defined using "Fixpoint", because each
   recursive call is with an argument which is a subterm of the original argument, which is required
   for Coq to be convinced that the recursive function terminates.
   In this pset, however, we will use the binary representation of natural numbers, which is
   called "N" in Coq. If we wanted to use a Fixpoint and call it with, e.g. the binary number
   11001101, we could only make recursive calls with 1001101.
   What we want in this Pset, however, is to make recursive calls with the one less than the argument,
   i.e. with 11001100 in this example.
   For this kind of recursion, which does not follow the structure of the data, we use the
   following pattern: *)

Definition fact: N -> N :=
  recurse by cases
  | 0 => 1
  | n + 1 => (n + 1) * recurse
  end.

(* This pattern can only define functions recursing over a natural number with base case 0, and
   one recursive case where the recursive call is for one less than the argument.
   The above function implements factorial, i.e. "fact n = 1 * 2 * ... * n".
   In the recursive case, you can use the word "recurse" to refer to the result of the recursive
   call. *)

(* Let's compute the first few values of fact: *)
Compute fact 0.
Compute fact 1.
Compute fact 2.
Compute fact 3.
Compute fact 4.

(* Aside: If you don't like the above Notation and want to see the real definition, you can do this:
Close Scope N_recursion_scope.
Print fact.
*)

(* Instead of writing "(fact x)" all the time, it's more convenient to just write "x!",
   so we make a Notation for this: *)
Local Notation "x !" := (fact x) (at level 12, format "x !").
(* Exercise: Define a simple exponentiation function in the same style,
   so that "exp base n" equals "base^n". *)

(*
Definition flip {A B C} (f : A -> B -> C) x y := f y x.
Definition exp: N -> N -> N :=
    flip (recurse by cases
    | 0 => (fun x => 1)
    | cheese + 1 => fun x => x * recurse x
    end).
*)
Definition exp: N -> N -> N :=
  fun x =>
    recurse by cases
    | 0 => 1
    | _ + 1 => x * recurse
    end.

(* Once you define "exp", you can replace "Admitted." below by "Proof. equality. Qed." *)
Lemma test_exp_2_3: exp 2 3 = 8. Proof. equality. Qed.
Lemma test_exp_3_2: exp 3 2 = 9. Proof. equality. Qed.
Lemma test_exp_4_1: exp 4 1 = 4. Proof. equality. Qed.
Lemma test_exp_5_0: exp 5 0 = 1. Proof. equality. Qed.
Lemma test_exp_1_3: exp 1 3 = 1. Proof. equality. Qed.

(* Here's another recursive function defined in the same style to apply a function f to
   a range of values:
   "seq f len start" computes the list [f start; f (start+1); ... f (start+len-1)] *)
Definition seq(f: N -> N): N -> N -> list N :=
  recurse by cases
  | 0 => fun start => []
  | n + 1 => fun start => f start :: recurse (start + 1)
  end.

Compute (seq (fun x => x * x) 4 0).

(* "ith i l" returns the i-th element of the list l.
   To understand the recursion, note that "ith i" returns a function which takes a list and,
   depending on whether i was 0 or not, returns the head of the list or the (i-1)-th element
   of the tail.
   If the index is out of bounds, it returns the default value 0. *)
Definition ith: N -> list N -> N :=
  recurse by cases
  | 0 => fun (l: list N) => match l with
                            | h :: t => h
                            | nil => 0
                            end
  | i + 1 => fun (l: list N) => match l with
                                | h :: t => recurse t
                                | nil => 0
                                end
  end.

(* The standard library already contains a function called "length": *)
Check length.
(* However, it returns a "nat", i.e., the representation of natural numbers using O and S,
   which is very inefficient: To represent the number n, it needs roughly c*n bytes of RAM,
   where c is some constant, whereas "N", the binary representation of natural numbers,
   only used c*log(n) bytes of RAM.
   Therefore, we redefine our own length function which returns an N: *)
Fixpoint len(l: list N): N :=
  match l with
  | [] => 0
  | h :: t => 1 + len t
  end.
(* Note that since the recursion follows the structure of the data (the list) here,
   we use Fixpoint instead of "recurse by cases". *)

(* Here's a simple lemma: If we tell "seq" to return a list of length "count", it indeed does: *)
Lemma seq_len: forall f count start, len (seq f count start) = count.
Proof.
  induct count; simplify.
  - (* base case: count = 0 *)
    equality.
  - (* recursive case: assuming the statement holds for some "count", show that it
       also holds for "count + 1".
       This goal contains "seq f (count + 1) start", so we know that we're in the
       recursive case of "seq", so we'd like to replace "seq f (count + 1) start"
       by the recursive case we wrote in its definition.
       Unfortunately, neither "unfold seq" nor "simplify" can do this, but the
       tactic "unfold_recurse F k", where F is the function in question, and k
       its argument, does the job: *)
    unfold_recurse (seq f) count.
    (* And here's a hint you'll need later: Sometimes, your goal won't exactly contain
       (seq f (count + 1) start), but maybe (seq f someOtherExpression start), but you
       still know that someOtherExpression is strictly greater than 0.
       In such cases, if you want to use "unfold_recurse", you first have to run

       replace someOtherExpression with (someOtherExpression - 1 + 1) by linear_arithmetic.

       Note that if someOtherExpression could be 0, this won't work, because subtraction
       on natural numbers in Coq returns 0 if the result is negative, so "0 - 1 + 1"
       equals 1 in Coq's natural numbers, and linear_arithmetic can't prove "0 = 1"
       for you! *)

    simplify. rewrite IHcount. linear_arithmetic.
Qed.

(* An here's another general hint: You don't always need induction.
   Some lemmas in this pset can be solved using induction, but don't actually require it,
   and are simpler to solve if you don't use induction, so before doing induction,
   try to think where/if you would need an inductive hypothesis. *)

Compute ith 2 (seq (fun x => x * x) 4 0).
Compute (fun x => x * x)(0 + 2).
Compute (fun x => x *x)(1) :: seq (fun x => x*x) 3 (1+1).
Compute seq (fun x => x *x) 3 1.
(* (i=1, count =2, start 2).*)

Compute ith (1 + 1) (seq (fun x => x *x) (2 + 1) 2) = (fun x => x *x) (2 + (1 + 1)).
Compute ith (1 + 1) ((fun x => x *x) 2 :: seq (fun x => x *x) 2 (2 + 1)) = ith 1 (seq (fun x => x *x) 2 (2 + 1)).
(* Exercise: Prove that the i-th element of seq has the value we'd expect. *)

Lemma first_element: forall l a, ith 0 (a::l) = a.
Proof.
  simplify.
  equality.
Qed.

Lemma j: forall  i a l, i < len l -> ith (i + 1) (a :: l) = ith i (l).
induct i.
simplify.
equality.
simplify.
unfold_recurse (ith) (i+1).
equality.
Qed.

Lemma a: forall f count i start, i < count -> ith (i + 1) (f start :: seq f count (start + 1)) = ith i (seq f count (start + 1)).
Proof.
 induct i.
  simplify.
  equality.
  simplify.
  apply j.
  rewrite  seq_len.
  assumption.
Qed.
Lemma seq_spec: forall f count i start, i < count -> ith i (seq f count start) = f (start + i).
Proof.
  induct count; simplify.
  apply N.nlt_0_r in H.
  equality.
  induct i.
  unfold_recurse (seq f) (count).
  simplify.
   f_equal. linear_arithmetic.

   assert(H2: (i + 1 < count + 1) <-> i < count).
   linear_arithmetic.
   apply H2 in H.
   unfold_recurse (seq f) (count).
   rewrite a.

   rewrite   IHcount.
   f_equal.
   linear_arithmetic.
   assumption.
   assumption.
Qed.

Lemma concat: forall a l, len(a :: l) = 1 + len(l).
Proof.
  induct l; simplify; equality.
Qed.

Lemma empty: forall l, len l <= 0 -> l = [].
Proof.
  induct l.
  simplify.
  equality.
  rewrite concat.
  intros.
  cases l.
  simplify.
  linear_arithmetic.
  linear_arithmetic.
Qed.
(* Exercise: Prove that if the index is out of bounds, "ith" returns 0. *)
Lemma ith_out_of_bounds_0: forall i l, len l <= i -> ith i l = 0.
Proof.
induct i.
intros.
apply empty in H.
simplify.
rewrite H.
equality.
simplify.
induct l.
simplify.
unfold_recurse (ith) (i).
equality.
rewrite concat in H.

assert(H2: (1 + len l <= i + 1) -> len l <= i).
simplify.
linear_arithmetic.
apply H2 in H.

apply IHi in H.
unfold_recurse (ith) (i).
assumption.
Qed.
(* Binomial coefficients *)
(* ********************* *)

(* You might remember binomial coefficients from you math classes, which appear in many combinatorics
   problems, and form the coefficients of the expansion of the polynomial (x + y)^n.
   In math notation, they are defined as follows:

      / n \        n!
      |   |  = ---------
      \ k /    (n-k)! k!

   We can transcribe this to Coq as follows: *)

Definition C(n k: N): N := n! / ((n - k)! * k!).

(* If we want to know how many ways there are to pick 2 items out of 4 items, we can compute this in Coq: *)
Compute C 4 2.

(* And here are the coefficients of the expansion of (x + y)^3: *)
Compute [C 3 0; C 3 1; C 3 2; C 3 3].

(* For larger numbers, however, this way of computing C becomes quite slow: If I do

Compute C 1000 100.

   it takes about 2 seconds on my computer. You can measure the time by putting "Time" in front of any command:

Time Compute C 1000 100.

   In the fraction defining C, there are many factors which appear both in the numerator and in the
   denominator, so it seems that we should be able to cancel these out and write a more efficient
   implementation of C. Here is one candidate: *)

Definition bcoeff(n: N): N -> N :=
  recurse by cases
  | 0 => 1
  | k + 1 => recurse * (n - k) / (k + 1)
  end.

(* Now if we do

Time Compute bcoeff 1000 100.

   it only takes about 0.02 seconds on my computer, so we got a 100x speed improvement, yay!
   But how do we know whether it's correct?
   We could do some quick tests: *)

Compute [bcoeff 3 0; bcoeff 3 1; bcoeff 3 2; bcoeff 3 3].

(* This test produces the same values as for C, but we want to be sure that bcoeff will *always* produce
   the same values as C, so let's prove it, i.e. let's show that

   forall n k, k <= n -> bcoeff n k = C n k

   We will do so further below, but we first need a few helper lemmas and techniques:

   Many arithmetic goals in this Pset are linear, i.e. we there are only multiplications by
   constants, but no multiplications of two variables.
   For these linear arithmetic goals, the linear_arithmetic tactic works just fine, but for
   some non-linear goals which will appear in this Pset, you can try the tactic "nia"
   (which stands for "non-linear integer arithmetic"), but it does not always work, so
   sometimes you will have to search for appropriate lemmas to apply manually.
   For instance, to prove the following: *)
Goal forall n m, n <> 0 -> m <> 0 -> n * m <> 0.
Proof.
  simplify.
  (* you could use the "Search" command with a pattern: *)
  Search (_ * _ <> 0).
  (* which outputs the name of a handy lemma we can apply: *)
  apply N.neq_mul_0.
  split; assumption.
  (* (note that in this case "nia" would have worked as well, but in any case, it's good to know
     the "Search" command. *)
Qed.

(* Here's another example of how to use the "Search" command:
   Suppose you have the goal *)
Goal forall n, n <> 0 -> n / n = 1.
Proof.
  simplify.
  (* If we do "Search (_ / _)" we get a very long list, but if we do *)
  Search (?x / ?x).
  (* we force the two numbers on both sides of the / to be the same, and we only get the lemma we need: *)
  apply N.div_same.
  assumption.
Qed.

(* Now we're ready to prove a few simple facts: *)

Lemma peal_fact: forall n, (n + 1)! = n! * (n+1).
Proof.
  simplify.
  unfold_recurse (fact) (n).
  apply N.mul_comm.
Qed.

Lemma fact_nonzero: forall n, n! <> 0.
Proof.
  induct n; simplify; try(equality).
  rewrite peal_fact.
  Search (_ * _ <> 0).
  apply N.neq_mul_0.
  split.
  apply IHn.
  linear_arithmetic.
Qed.

Lemma Cn0: forall n, C n 0 = 1.
Proof.
  induct n.
  compute.
  equality.
  Print C.
  unfold C.
  Search (?x - 0 = ?x).
  rewrite N.sub_0_r.
  assert(0! = 1).
  compute.
  equality.
  rewrite H.
  rewrite N.mul_1_r.
  apply N.div_same.
  apply fact_nonzero.
Qed.

Lemma Cnn: forall n, C n n = 1.
Proof.
  induct n.
  compute.
  equality.
  unfold C.
  simplify.
  Search (?x - ?x = 0).
  rewrite N.sub_diag.
  assert(0! = 1).
  compute.
  equality.
  rewrite H.
  Search (1 * ?x = ?x).
  rewrite N.mul_1_l.
  apply N.div_same.
  apply fact_nonzero.
Qed.
(* It's somewhat surprising that in the definition of C(n, k),

      n!
  -----------
  (n - k)! k!

  the denominator always divides the numerator.
  The following lemma proves it. Note that "(a | b)" means "a divides b".
  We provide the solution for you, so that you can step through it and use it as a
  source of useful strategies you can apply in the exercises below.
  Make sure to step through it and to understand each proof step! *)
Lemma C_is_integer: forall n k, k <= n ->
    (((n - k)! * k!) | n!).
Proof.
  induct n.
  - simplify.
    replace k with 0 by linear_arithmetic.
    simplify.
(* How can we prove that 1 divides 1? Probably it follows immediately from the definition of
   divisibility, so let's try to unfold it:

    unfold "|".

   Unfortunately that fails (reported at https://github.com/coq/coq/issues/11420), but we can do

    Locate "|".

   The output of this command shows us all notations involving "|", and the last one (N.divide) is the one
   we want. So we just unfold that one: *)
    unfold N.divide.
    exists 1. equality.
  - simplify. unfold N.divide in *.
    assert (k = 0 \/ k = n + 1 \/ 1 <= k <= n) as C by linear_arithmetic. cases C.
    + subst.
      replace (n + 1 - 0) with (n + 1) by linear_arithmetic.
      replace (0!) with 1 by equality.
      exists 1.
      linear_arithmetic.
    + subst.
      replace (n + 1 - (n + 1)) with 0 by linear_arithmetic.
      replace (0!) with 1 by equality.
      exists 1. linear_arithmetic.
    + pose proof (IHn k) as IH1.
      assert (k <= n) as A by linear_arithmetic. specialize (IH1 A). invert IH1.
      pose proof (IHn (k - 1)) as IH2.
      assert (k - 1 <= n) as B by linear_arithmetic. specialize (IH2 B). invert IH2.
      replace (n - (k - 1)) with (n - k + 1) in H1 by linear_arithmetic.
      unfold_recurse fact n.
      replace (k!) with ((k - 1 + 1)!) in *.
      2: { f_equal. linear_arithmetic. }
      unfold_recurse fact (k - 1).
      replace (k - 1 + 1) with k in * by linear_arithmetic.
      apply N.mul_cancel_r with (p := n - k + 1) in H0. 2: linear_arithmetic.
      apply N.mul_cancel_r with (p := k) in H1. 2: linear_arithmetic.
      assert (forall l1 r1 l2 r2, l1 = r1 -> l2 = r2 -> l1 + l2 = r1 + r2) as E. {
        simplify. linear_arithmetic.
      }
      specialize E with (1 := H0) (2 := H1).
      replace (n! * (n - k + 1) + n! * k) with ((n + 1) * n!) in E by nia.
      rewrite E.
      replace (n + 1 - k) with (n - k + 1) by linear_arithmetic.
      unfold_recurse fact (n - k).
      remember ((n - k)!) as F1.
      remember ((k - 1)!) as F2.
      remember (n - k + 1) as F3.
      remember k as F4.
      exists (x + x0).
      nia.
Qed.

(* Now we're ready to prove correctness of our optimized implementation bcoeff.
   Since this is not a class about math, we're providing a paper proof of each proof step
   of the inductive case:

  C(n, k + 1)

             n!
= -----------------------
  (n - (k + 1))! (k + 1)!

             n!
= -----------------------
  (n - k - 1)! k! (k + 1)

         n! (n - k)
= -------------------------------
  (n - k - 1)! (n - k) k! (k + 1)

               n! (n - k)
= ---------------------------------------
  (n - k - 1)! (n - k - 1 + 1) k! (k + 1)

          n! (n - k)
= ---------------------------
  (n - k - 1 + 1)! k! (k + 1)

      n! (n - k)
= -------------------
  (n - k)! k! (k + 1)

  n! (n - k)
= ----------- / (k + 1)
  (n - k)! k!

      n!
= ----------- * (n - k) / (k + 1)
  (n - k)! k!

= C(n, k) * (n - k) / (k + 1)

= bcoeff(n, k) * (n - k) / (k + 1)

= bcoeff(n, k + 1)

Your task is to translate this proof into Coq!

Potentially useful hint:
Note that multiplication and division have the same operator priority, and both are left-associative, so
   "a / b * c / d" is "((a / b) * c) / d", NOT "(a / b) * (c / d)"

Here we go: *)
Lemma bcoeff_correct: forall n k, k <= n -> bcoeff n k = C n k.
Proof.
  induct k.
  simplify.
  rewrite Cn0.
  equality.

  simplify.
  symmetry.
  unfold C.

  rewrite peal_fact.
  Search ((?c * _ )/ (?c * _)).
  (* N.div_mul_cancel_l. *)
  assert (H2 : (n-k) * (n!) / ((n-k) * ((n - (k + 1))! * (k! * (k + 1)))) = (n! / ((n - (k + 1))! * (k! * (k + 1)))) ).
  assert (H3: (n - k) <> 0).
  linear_arithmetic.
  rewrite  N.div_mul_cancel_l with (c:= (n - k)).
  equality.
  Search (_ * _ <> 0).
  apply N.neq_mul_0.
  split.
  apply fact_nonzero with (n:= (n - (k + 1))).
  apply N.neq_mul_0.
  split.
  apply fact_nonzero.
  linear_arithmetic.
  assumption.
  rewrite <- H2.

  assert((n - k) * (n - (k + 1))! = (n - k)!).
  assert( n - (k + 1) = n - k - 1) by linear_arithmetic.
  rewrite H0.
  replace (n - k)  with ((n - k - 1 + 1))  by linear_arithmetic.
  replace (n - k - 1 + 1 - 1) with (n- k - 1) by linear_arithmetic.
  symmetry.
  Search (?a * ?b = ?b * ?a).
  rewrite <- N.mul_comm.
  apply  peal_fact with (n := (n - k - 1)).
  rewrite N.mul_comm.
  replace ((n - k) * ((n - (k + 1))! * (k! * (k + 1)))) with ((n - k) * (n - (k + 1))! * (k! * (k + 1))) by linear_arithmetic.
  rewrite H0.
  replace ((n - k)! * (k! * (k + 1))) with ((n - k)! * k! * (k + 1)) by linear_arithmetic.
  replace ((n - k)! * k! * (k + 1))with (((n - k)! * k!) * (k + 1)) by linear_arithmetic.
  rewrite N.mul_comm.

  assert (H3: ((n - k) * n! / ((n - k)! * k! * (k + 1))) = ((n - k) * n! / ((n - k)! * k!) / (k + 1))).
  rewrite <-  N.div_div.
  equality.
  apply N.neq_mul_0;split;apply fact_nonzero.
  linear_arithmetic.
  rewrite H3.

rewrite N.divide_div_mul_exact with (c:= (n - k)) (a:= n!) (b:=((n - k)! * k!)).
replace  ((n! / ((n - k)! * k!))) with (C n k) by equality.
rewrite N.mul_comm.
rewrite <- IHk.
unfold_recurse (bcoeff n) (k).
equality.
linear_arithmetic.
apply N.neq_mul_0;split;apply fact_nonzero.
apply C_is_integer.
linear_arithmetic.
Qed.

(* All binomial coefficients for a given n *)
(* *************************************** *)

(* In some applications, we need to know all binomal coefficients C(n,k) for a fixed n.
   For instance, if we want to symbolically evaluate (x + y)^4, the result is

   C(4,0)*x^4 + C(4,1)*x^3*y + C(4,2)*x^2*y^2 + C(4,3)*x*y^3 + C(4,4)*y^4

   The simplest way to compute such lists would be to just use the C we defined above: *)

Definition all_coeffs_slow1(n: N): list N :=
  (recurse by cases
   | 0 => [1]
   | k + 1 => C n (k + 1) :: recurse
   end) n.

Compute C 4 2.
Compute all_coeffs_slow1 0.
Compute all_coeffs_slow1 1.
Compute all_coeffs_slow1 2.
Compute all_coeffs_slow1 3.
Compute all_coeffs_slow1 4.
Compute all_coeffs_slow1 5.
Compute all_coeffs_slow1 15.
(* However, this is not very efficient:

Time Compute all_coeffs_slow1 100.

takes 0.8s on my machine *)

(* We could use our more efficient bcoeff from above: *)
Definition all_coeffs_slow2(n: N): list N :=
  (recurse by cases
   | 0 => [1]
   | k + 1 => bcoeff n (k + 1) :: recurse
   end) n.

Compute all_coeffs_slow2 5.
Compute all_coeffs_slow2 15.
(* This is faster:

   Time Compute all_coeffs_slow2 100.

takes 0.2s on my machine and

  Time Compute all_coeffs_slow2 200.

takes 1.7 s on my machine.

But we can do even better by using Pascal's triangle:

      1
     1 1
    1 2 1
   1 3 3 1
  1 4 6 4 1

You can observe that the i-th row of this triangle is the result of "all_coeffs_slow1 i",
and that each value not at the boundary of the triangle is the sum of the values to
its upper left and its upper right. For instance, the 6 in the last row is the sum of the
two 3s above it.
More formally, we can state this as follows: *)
Definition Pascal's_rule: Prop := forall n k,
    1 <= k <= n ->
    C (n+1) k = C n (k - 1) + C n k.
(* Note that the above is only a definition which gives a name to this proposition,
   but not a lemma.
   We don't ask you to prove it, but it's a fun optional exercise, have a look at the
   end of this file if you're interested! *)

(* The following function takes in a line of Pascal's triangle and computes the line below it: *)
Definition nextLine(l: list N): list N :=
  1 :: seq (fun k => ith (k - 1) l + ith k l) (len l) 1.

Compute nextLine [1; 3; 3; 1].
Compute nextLine (nextLine [1; 3; 3; 1]).

(* This allows us to define a faster all_coeffs function: *)
Definition all_coeffs_fast: N -> list N :=
  recurse by cases
  | 0 => [1]
  | n + 1 => nextLine recurse
  end.

(* Time Compute all_coeffs_fast 200. takes 0.35s on my computer *)

Lemma helper_len: forall a l, len(a::l) = 1 + len l.
induct l; simplify; equality.
Qed.

Lemma length_all_coeffs: forall n, len(all_coeffs_fast(n)) = n + 1.

induct n.
simplify.
linear_arithmetic.
simplify.
unfold_recurse all_coeffs_fast n.
unfold nextLine.
rewrite helper_len.
rewrite seq_len.
rewrite IHn.
linear_arithmetic.
Qed.

Hint Rewrite Cnn.
Hint Rewrite length_all_coeffs.
Hint Rewrite helper_len.
Hint Rewrite seq_len.
Ltac hammer:= repeat (simplify; try linear_arithmetic; simplify; try equality; simplify).

(* Exercise: Let's prove that all_coeffs_fast is correct.
   Note that you can assume Pascal's rule to prove this. *)
Lemma all_coeffs_fast_correct:
  Pascal's_rule ->
  forall n k,
    k <= n ->
    ith k (all_coeffs_fast n) = C n k.
Proof.
induct n.
simplify.
cases k.
equality.
linear_arithmetic.

simplify.
unfold_recurse all_coeffs_fast n.
unfold nextLine.

induct k.
rewrite first_element.
rewrite Cn0.
equality.

clear IHk.
assert(k <= n) by linear_arithmetic.

rewrite j; hammer.
rewrite seq_spec; hammer.
replace (1 + k - 1) with k  by linear_arithmetic.
replace (1 + k) with (k + 1) by linear_arithmetic.
rewrite IHn; hammer.
unfold Pascal's_rule in H.
assert (k < n \/ k = n) by linear_arithmetic.
cases H2.
rewrite IHn; hammer.
rewrite H; hammer.
replace (k + 1 - 1) with k  by linear_arithmetic.
equality.
rewrite ith_out_of_bounds_0; hammer.
rewrite H2; hammer.
Qed.

(* ----- THIS IS THE END OF PSET2 ----- All exercises below this line are optional. *)
(* Optional exercise: Let's prove that Pascal's rule holds.
   On paper, this can be proved as follows, but feel free to ignore this if you want
   the full challenge!

   C(n, k-1) + C(n, k)

           n!                 n!
= --------------------- + -----------
  (n - k + 1)! (k - 1)!   (n - k)! k!

              n!                          n!
= ----------------------------- + -------------------
  (n - k)! (n - k + 1) (k - 1)!   (n - k)! k (k - 1)!

               n! k                          n! (n - k + 1)
= ------------------------------- + -------------------------------
  (n - k)! (n - k + 1) (k - 1)! k   (n - k)! k (k - 1)! (n - k + 1)

         n! (k + n - k + 1)
= -------------------------------
  (n - k)! (n - k + 1) (k - 1)! k

    (n + 1)!
= ---------------
  (n - k + 1)! k!

= C(n+1, k)
*)
Lemma Pascal's_rule_holds: Pascal's_rule.
Proof.
  unfold Pascal's_rule.

  (* Note: Proving
       a     b     a+b
      --- + --- =  ---
       c     c      c
     is a bit trickier than you might expect, because we're using integer division here.
     So, for instance,
      1     3                                                              1+3
     --- + ---   equals 0 + 1 in round-down integer division, which is not ---
      2     2                                                               2
     To make sure this rule holds, we must also require that c and b both divide a: *)
  assert (forall a b c, c <> 0 -> (c | a) -> (c | b) -> a / c + b / c = (a + b) / c)
    as add_fractions. {
    clear.
    simplify.
    unfold N.divide in *. invert H0. invert H1.
    rewrite N.div_mul by assumption.
    rewrite N.div_mul by assumption.
    replace (x * c + x0 * c) with ((x + x0) * c) by nia.
    rewrite N.div_mul by assumption.
    reflexivity.
  }

Admitted.

(* Optional exercise:
   all_coeffs_fast is still not as fast as it could be, because nextLine uses ith
   to access the elements of the previous line, and each invocation of ith takes
   linear time in i.
   It would be more efficient to implement nextLine as a recursive function
   which iterates through the previous line just once and computes the next line
   on the fly.
   Define such a nextLine' function, and then use it to define all_coeffs_faster,
   observe how it's even faster than all_coeffs_fast, and finally, prove that
   it's correct. *)

Definition nextLine'(l: list N): list N. Admitted.

Definition all_coeffs_faster: N -> list N. Admitted.

Lemma all_coeffs_faster_correct: forall n k,
    k <= n ->
    ith k (all_coeffs_faster n) = C n k.
Proof.
Admitted.


Require Import Coq.Relations.Relations.

Section SubsetDef.

Context `{U : Type}.

(*Definition 1.3*)
Definition subset (A : U -> Prop) (B : U -> Prop) :=
  forall x, A x -> B x.
Definition nonempty (A : U -> Prop) :=
  exists x, A x.

End SubsetDef.

Notation "A ⊂ B" := (subset A B) (at level 50) : subset_scope.
Notation "A == B" := (subset A B /\ subset B A) (at level 50) : subset_scope.

Section OrderDef.

Context `{U : Type}.

(*Definition 1.5*)
Class Order : Type :=
  {
    ord : relation U;
    O_prop1 : forall x y,
      (ord x y /\ ~(x = y) /\ ~(ord y x)) \/
      (~(ord x y) /\ x = y /\ ~(ord y x)) \/
      (~(ord x y) /\ ~(x = y) /\ ord y x);
    O_prop2 : forall x y z, ord x y -> ord y z -> ord x z;
  }.

End OrderDef.

Notation "x < y" := (ord x y) : ord_scope.
Notation "x < y < z" := ((ord x y) /\ (ord y z)) : ord_scope.
Notation "x ≤ y" := (ord x y \/ x = y) (at level 50) : ord_scope.

Section OrderBounds.

Variable U : Type.

Open Scope ord_scope.

Definition order_trich_contr : forall (O: @Order U) x y,
  x ≤ y /\ y < x -> False.
Proof.
  intros.
  destruct H.
  destruct (O_prop1 x y).
  apply H1 in H0. apply H0.
  destruct H1.
  apply H1 in H0. apply H0.
  destruct H.
  apply H1 in H. apply H.
  apply H1 in H. apply H.
Qed.

Definition order_trich_split : forall (O: @Order U) x y,
  x ≤ y \/ y < x.
Proof.
  intros.
  destruct (O_prop1 x y).
  left. left. apply H.
  destruct H.
  left. right. apply H.
  right. apply H.
Qed.

(*Definition 1.6*)

(*Definition 1.7*)
Definition upper_bound (O : Order) (E : U -> Prop) (beta : U) :=
  forall x, E x -> x ≤ beta.

Definition lower_bound (O : Order) (E : U -> Prop) (beta : U) :=
  forall x, E x -> beta ≤ x.

(*Definition 1.8*)
Definition least_upper_bound (O : Order) (E : U -> Prop) (alpha : U) :=
  upper_bound O E alpha /\
  (forall gamma, gamma < alpha -> ~(upper_bound O E gamma)).

Definition greatest_lower_bound (O : Order) (E : U -> Prop) (alpha : U) :=
  lower_bound O E alpha /\
  (forall gamma, alpha < gamma -> ~(lower_bound O E gamma)).

(* Definition 1.10 *)
(*<sup> is the a supreme function that assigns a supreme to sets.
  In other words, "lub_prop O sup" holds if sup works as expected.
  One could argue that sup needs to be defined only for sets that
  are nonempty and bounded above. However, this complicates a lot
  the typing.
*)
Definition lub_property (O : Order)
  (sup : (U -> Prop) -> U) : Prop :=
  forall (E : U -> Prop)
  (x_E : U) (beta_E : U),
  E x_E -> upper_bound O E beta_E ->
  least_upper_bound O E (sup E).

Definition glb_property (O : Order)
  (inf : (U -> Prop) -> U) : Prop :=
  forall (E : U -> Prop)
  (x_E : U) (beta_E : U),
  E x_E -> lower_bound O E beta_E ->
  greatest_lower_bound O E (inf E).

(*Theorem 1.11*)
Theorem Th_1_11 (O : Order) (sup : (U -> Prop) -> U) (B : U -> Prop)
  (x_B : U) (beta_B : U) :
  lub_property O sup -> B x_B -> lower_bound O B beta_B ->
  let L := fun x => (lower_bound O B x) in
    exists alpha, least_upper_bound O L alpha /\ greatest_lower_bound O B alpha.
Proof.
  intros.
  exists (sup L).
  assert (least_upper_bound O L (sup L)).
  { apply (H _ beta_B x_B).
    - unfold L. intros x H2. apply H1. apply H2.
    - intros x H2. apply H2. apply H0. }
  split.
  - apply H2.
  - split.
    + intros x H3. destruct (O_prop1 (sup L) x) as [H4 | [H4 | H4]].
      * left. apply H4.
      * right. apply H4.
      * destruct H2.
        assert False. unfold not in H5.
        apply (H5 x). apply H4.
        intros y H6. apply H6. apply H3.
        contradiction.
    + intros gamma H3 H4.
      destruct H2.
      assert (~(L gamma)).
      { intros H6. destruct (O_prop1 (sup L) gamma) as [H7 | [H7 | H7]].
        - destruct (H2 gamma H6) as [H8 | H8].
          * apply H7 in H8. apply H8.
          * destruct H7 as [H9 [H10 H11]]. apply H10. symmetry. apply H8.
        - apply H7 in H3. apply H3.
        - apply H7 in H3. apply H3. }
      * apply H6 in H4. apply H4.
Qed.

Close Scope ord_scope.

End OrderBounds.


From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path.
From Coq Require Import Eqdep.

(*************************************************************)
(************ Some useful facts about sequences **************)
(*************************************************************)

Fixpoint remove_elem (xs : seq (nat * nat * seq nat)) e :=
  match xs with
  | x :: xs => if x == e then xs else x :: (remove_elem xs e)
  | [::] => [::]
  end.

Lemma remove_elem_all xs p e :
  all p xs -> all p (remove_elem xs e).
Proof.
elim:xs=>//x xs Hi/=/andP[H1 H2].
by case B: (x==e)=>//=; rewrite H1 (Hi H2).
Qed.

Lemma remove_elem_in xs e :
  if e \in xs
  then perm_eq (e :: (remove_elem xs e)) xs = true
  else (remove_elem xs e) = xs.
Proof.
elim: xs=>//x xs Hi.
rewrite inE; case: ifP=>/=; last first.
- case/negbT/norP=>/negbTE; rewrite eq_sym=>->/negbTE Z.
  by rewrite Z in Hi; rewrite Hi.
case/orP.
- by move/eqP=>Z; subst e; rewrite eqxx; apply: perm_refl.
move=>Z; rewrite Z in Hi; case: ifP=>X.
- by move/eqP: X=>?; subst e; apply: perm_refl.
rewrite -cat1s -[x::_]cat1s-[x::xs]cat0s -[x::xs]cat1s.
apply/permPl.
move: (perm_catCA [::e] [::x] (remove_elem xs e))=>/permPl H1.
rewrite !cat1s in H1.
rewrite  -(perm_cons x (e :: remove_elem xs e) xs) in Hi.
rewrite !cat1s !cat0s; apply/permPl.
by apply: (perm_trans H1 Hi).
Qed.


(*
  This is exercises for <Software Foundations> CH8.
  Author : Brethland, Late 2019.
*)

Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Export Coq.Strings.String.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Lists.List.
Require Import Unicode.Utf8.
Require Import Setoid.

Definition beq_string x y :=   if string_dec x y then true else false.

Theorem beq_string_refl : ∀ s, true = beq_string s s.
Proof.
  intros s. unfold beq_string. destruct (string_dec s s) as [|Hs].
  - reflexivity.
  - destruct Hs. reflexivity.
Qed.

Theorem beq_string_true_iff : ∀ x y : string,   beq_string x y = true ↔ x = y.
Proof.
  intros x y.
  unfold beq_string.
  destruct (string_dec x y) as [|Hs].
  - subst. split. auto. auto.
  - split.
    + intros contra. inversion contra.
    + intros H. destruct Hs. auto.
Qed.

Theorem beq_string_false_iff : ∀ x y : string,   beq_string x y = false   ↔ x ≠ y.
Proof.
  intros x y. rewrite <- beq_string_true_iff.
  rewrite not_true_iff_false. reflexivity.
Qed.

Theorem false_beq_string : ∀ x y : string, x ≠ y → beq_string x y = false.
Proof.
  intros x y. rewrite beq_string_false_iff.
  intros H. apply H.
Qed.

Definition total_map (A:Type) := string → A.

Definition t_empty {A:Type} (v : A) : total_map A :=   (fun _ => v).

Definition t_update {A:Type} (m : total_map A) (x : string) (v : A) :=
  fun x' => if beq_string x x' then v else m x'.

Notation "'_' '!->' v" := (t_empty v)
  (at level 100, right associativity).
Notation "x '!->' v ';' m" := (t_update m x v)
                              (at level 100, v at next level, right associativity).

Axiom functional_extensionality : ∀ {X Y: Type} {f g : X → Y}, (∀ (x:X), f x = g x) → f = g.

Lemma t_apply_empty: ∀ (A:Type) (x: string) (v: A), (_ !-> v) x = v.
Proof.
  intros.
  unfold t_empty. auto.
Qed.

Lemma t_update_eq : ∀(A : Type) (m : total_map A) x v,
    (x !-> v ; m) x = v.
Proof.
  intros. unfold t_update. rewrite <- beq_string_refl.
  auto.
Qed.

Theorem t_update_neq : ∀(A : Type) (m : total_map A) x1 x2 v,
    x1 ≠ x2 →
    (x1 !-> v ; m) x2 = m x2.
Proof.
  intros.
  unfold t_update. apply beq_string_false_iff in H.
  rewrite H. auto.
Qed.

Lemma t_update_shadow : ∀(A : Type) (m : total_map A) x v1 v2,
    (x !-> v2 ; x !-> v1 ; m) = (x !-> v2 ; m).
Proof.
  intros.
  apply functional_extensionality.
  intros. unfold t_update.
  destruct (beq_string x x0) eqn:HE.
  - auto.
  - auto.
Qed.

Lemma beq_stringP : ∀ x y, reflect (x = y) (beq_string x y).
Proof.
  intros. destruct (beq_string x y) eqn:HS.
  - apply ReflectT. apply beq_string_true_iff. auto.
  - apply ReflectF. apply beq_string_false_iff. auto.
Qed.

Theorem t_update_same : ∀(A : Type) (m : total_map A) x,
    (x !-> m x ; m) = m.
Proof.
  intros. apply functional_extensionality.
  intros. unfold t_update.
  destruct (beq_stringP x x0).
  - rewrite e. auto.
  - auto.
Qed.

Theorem t_update_permute : ∀(A : Type) (m : total_map A)
                                  v1 v2 x1 x2,
    x2 ≠ x1 →
    (x1 !-> v1 ; x2 !-> v2 ; m)
    =
    (x2 !-> v2 ; x1 !-> v1 ; m).
Proof.
  intros.
  apply functional_extensionality.
  intros. unfold t_update.
  destruct (beq_stringP x1 x).
  - destruct (beq_stringP x2 x).
    + rewrite e,e0 in H. unfold not in H.
      destruct H. auto.
    + auto.
  - destruct (beq_stringP x2 x).
    + auto.
    + auto.
Qed.

Definition partial_map (A : Type) := total_map (option A).
Definition empty {A : Type} : partial_map A :=
  t_empty None.
Definition update {A : Type} (m : partial_map A)
           (x : string) (v : A) :=
  (x !-> Some v ; m).

Notation "x '⊢>' v ';' m" := (update m x v)
  (at level 100, v at next level, right associativity).
Notation "x '⊢>' v" := (update empty x v)
  (at level 100).


Require Export Coq.Sets.Multiset.
Require Export Pig.Schema.

Inductive relation (s: schema_ty) : Type :=
| Relation: multiset (support s) -> relation s.

Definition relation_data (s: schema_ty) (r: relation s) : multiset (support s) :=
  match r with
  | Relation _ mset => mset
  end.

Definition relation_eq (s: schema_ty) (r1 r2: relation s) : Prop :=
  meq (relation_data s r1) (relation_data s r2).

Definition relation_multiplicity (s: schema_ty) (r: relation s) (tup: support s) :=
  multiplicity (relation_data s r) tup.

(* TODO *)
(* Definition relation_proj (s: schema_ty) (r: relation s) (c: col) := ??? *)

(* An example schema with just one column: a nat column: *)

Example nat_schema : schema_ty := ( CTyNat *** ).
Example nat_tuple : support nat_schema := 1.
Example empty_nat_relation : relation nat_schema :=
  Relation nat_schema (EmptyBag nat).

(* Can be used to generate various example singleton relations for various
   schema using the `SingletonBag` definition. *)
Example singleton_relation (s: schema_ty) :=
  (SingletonBag (support_eq s) (support_eq_dec s)).

(* TODO: Finish this example. *)
(*
Example singleton_nat_relation : relation nat_schema :=
  Relation nat_schema (singleton_relation nat_schema 5).
Example singleton_nat_relation' : relation nat_schema :=
  Relation nat_schema (Bag (fun (n: nat) => match n with
                                            | 5 => 1
                                            | _ => 0
                                            end)).
Lemma two_singletons_are_eq : relation_eq nat_schema singleton_nat_relation singleton_nat_relation'.
  unfold relation_eq. simpl.
  unfold meq. simpl.
  intro. induction a.
  - (* a = O *) admit.
  - (* a = S a *) admit.
Admitted.
*)

(* An example schema with just one column: a bag (of nat): *)
Example bag_schema := (CTyBag (CTyNat ***) ***).
Example bag_tuple : support bag_schema := EmptyBag nat.
Example bag_relation : relation bag_schema := Relation bag_schema (EmptyBag (multiset nat)).

(* An example schema with two cols: nat and bag of nat. *)
Example nat_bag_schema : schema_ty := CTyNat *** CTyBag (CTyNat ***) ***.
Example nat_bag_tuple : support nat_bag_schema :=  (1, (EmptyBag nat)).
Example nat_bag_relation : relation nat_bag_schema := Relation nat_bag_schema (EmptyBag (nat * (multiset nat))).


(* Practica 1 *)

Section P1.
Variables A B C:Prop.

(*Ej 3.1 *)
Theorem e31: A->A->A.
Proof.
intros.
exact H.
Qed.

(*Ej 3.1 b *)
Theorem e31b: A->A->A.
Proof.
intros.
exact H0.
Qed.

(* Ej 3.2 *)
Theorem e32: (A->B->C)->A->(A->C)->B->C.
Proof.
intros.
apply H;assumption.
Qed.

(* Ej 3.2b *)
Theorem e32b: (A->B->C)->A->(A->C)->B->C.
Proof.
intros.
exact (H H0 H2).
Qed.

(* Ej 4.1 *)
Theorem e41: A -> ~~A.
Proof.
unfold not.
intros.
exact (H0 H).
Qed.

(* Ej 4.2 *)
Theorem e42: A -> B -> (A /\ B).
Proof.
intros.
split;assumption.
Qed.

(* Ej 4.3 *)
Theorem e43: (A->B->C) -> (A/\B->C).
Proof.
intros.
elim H0.
assumption.
Qed.

(* Ej 4.4 *)
Theorem e44: A->(A\/B).
Proof.
left.
assumption.
Qed.

(* Ej 4.5 *)
Theorem e45: B->(A\/B).
Proof.
right.
assumption.
Qed.

(* Ej 4.6 *)
Theorem e46: (A \/ B) -> (B \/ A).
Proof.
intro.
elim H; intro; [right | left]; assumption.
Qed.

(* Ej 4.7 *)
Theorem e47: (A->C)->(B->C)->A\/B->C.
Proof.
intros.
elim H1; assumption.
Qed.

(* Ej 4.8 *)
Theorem e48: False->A.
Proof.
intro.
elim H.
Qed.

(* Ej 6.1 *)
Theorem e61: (A\/B) -> ~(~A/\~B).
Proof.
unfold not.
intros.
elim H0.
intros.
elim H; assumption.
Qed.

(* Ej 6.2 *)
Theorem e62: A\/B <-> B\/A.
Proof.
split; intro; elim H;
intro; [right | left | right | left]; assumption.
Qed.

(* Ej 6.3 *)
Theorem e63: A\/B -> ((A->B)->B).
Proof.
intros.
elim H; intro; [exact (H0 H1) | assumption].
Qed.

End P1.

Section Logica_Clasica.
Variables A B C: Prop.

Require Import Classical.
Check classic.

(* Ej 8.1 *)
Theorem e81: ~~A->A.
Proof.
intro.
elim (classic A); intro; [ | elim H]; assumption.
Qed.

(* Ej 8.2 *)
Theorem e82: (A->B)\/(B ->A).
Proof.
elim (classic A); intro.
  right.
  intro.
  assumption.

  left.
  intro.
  elim H.
  assumption.
Qed.

(* Ej 8.3 *)
Theorem e83: ~(A/\B)-> ~A \/ ~B.
Proof.
unfold not.
intro.
elim (classic A); intro.
  right.
  intro.
  apply H.
  split; assumption.

  left.
  intro.
  elim H0.
  assumption.
Qed.

End Logica_Clasica.

Section ejercicio11.

(* Ej 11 *)
(* Definiciones *)
Variable PF:Prop. (*el paciente tiene fiebre*)
Variable PA:Prop. (*el paciente tiene piel amarillenta*)
Variable PH:Prop. (*el paciente tiene hepatitis*)
Variable PR:Prop. (*el paciente tiene rubeola*)

Hypothesis Regla1: PF \/ PA -> PH \/ PR.
Hypothesis Regla2: PR -> PF.
Hypothesis Regla3: PH /\ ~PR -> PA.

Theorem ej11: (~PA /\ PF) -> PR.
Proof.
intro.
elim H.
intros.
elim (classic PR); intro.
  assumption.

  elim Regla1; [intro; elim H0; apply Regla3; split | intro | left]; assumption.
Qed.

End ejercicio11.


(** **** Exercise: (basic_induction)  *)
(** Prove os seguintes teoremas. Será necessário
    buscar por resultados previamente provados. *)

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

Theorem plus_n_Sm : forall n m : nat,
  S (n + m) = n + (S m).
Proof.
  intros. Print Nat.add. induction n.
  - Print Nat.add. simpl. reflexivity.
  - simpl. rewrite IHn. reflexivity.
Qed.

Theorem plus_comm : forall n m : nat,
  n + m = m + n.
Proof.
  intros. induction n.
  - simpl. rewrite <- plus_n_O. reflexivity.
  - simpl. rewrite IHn. rewrite plus_n_Sm. reflexivity.
Qed.

Theorem plus_assoc : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  intros. induction n.
  - simpl. reflexivity.
  - simpl. rewrite <- IHn. reflexivity.
Qed.

(** **** Exercise: (mult_comm)  *)
(** Use [assert] para ajudar na prova. Não é
    necessário usar indução. *)

Theorem plus_swap : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  intros.
  rewrite plus_assoc. rewrite plus_assoc.
  assert(H: n + m = m + n).
  { rewrite plus_comm. reflexivity. }
  rewrite H. reflexivity.
Qed.

Theorem mult_comm : forall m n : nat,
  m * n = n * m.
Proof.
  intros n m. induction n.
  - simpl. rewrite <- mult_n_O. reflexivity.
  - Search mult. rewrite <- mult_n_Sm. simpl. rewrite plus_comm. rewrite IHn. reflexivity.
Qed.