(** * Tutoriel 3 - Isomorphisme de Curry-Howard et ses conséquences *)

(** La correspondance de Curry-Howard identifie :
      - une formule A avec un type de données, et
      - une preuve (dérivation formelle) avec un objet
        (du lambda calcul) de type A.

    Autrement dit, les types sont vus comme des propositions,
    et les programmes comme des preuves *)

(** Une preuve d'une implication par exemple est une fonction,
    une preuve d'une conjonction est un couple,
    appliquer la règle du modus-ponens se matérialise par
    l'application d'une fonction à un argument. *)

(** Cet objet du lambda calcul est appelé terme de preuve.
    Il représente un arbre de preuve.
    Lorsque l'on écrit un script de preuve (une suite de tactiques)
    on construit peu à peu le terme de preuve.
    Le Qed final vérifie que ce terme représente bien une preuve de
    la formule de départ. Comment ? En vérifiant que son type est
    bien celui de la formule.
    Vous verrez cela de manière plus théorique plus tard. *)

(** L'objet de ce TP est de découvrir ce mécanisme.

    Si [toto] est un théorème ou n'importe quel objet de Coq,
    la commande [Check toto] permet d'obtenir le type de toto.

    Pour afficher sa valeur on utilisera la commande [Print toto].

    Attention : La définition d’une constante à l’aide du système
                de tactiques (invoqué par Theorem , etc.) est opaque
                par défaut; il n’est donc pas possible de consulter sa
                valeur. Pour que la définition soit transparente, il
                suffit de remplacer [Qed] par [Defined] à la fin de
                la preuve. *)

(** ** Exercice 1 - Première observation *)

(** Prouvez la proposition [forall A : Prop, A -> A] et
    affichez sa preuve. *)

(** En Coq, la fonction qui a x de type T associe e
   (en OCaml function x → e) se note fun (x : T) => e.
   Son type est un produit dépendant, noté en Coq,
   [forall (x : T), U(x)] où U(x)est le type de e.

   Dans le cas où U(x) = U ne dépend pas de la variable x : T ,
   le produit (non) dépendant s’abrège en T -> U et on retrouve le
   type d'une fonction à la Ocaml. *)

(** ** Exercice 2 - Premiers termes de preuve *)

Variables A B C : Prop. (* On introduit ainsi 3 propositions
                           logiques. *)

(** A RETENIR : Une preuve de [A → B] est une fonction qui a toute
                preuve de A associe une preuve de B. *)

(** Prouver les propriétés suivantes et grâce à la commande
    [Print] regarder les termes de preuve.

      1. A -> A
      2. (A -> B) -> (B -> C) -> A -> C
      3. A -> B -> A
      4. (A -> B -> C) -> (A -> B) -> A -> C
      5. Essayer de construire directement le terme de preuve
        (sans utiliser de tactique) de la formule [A -> B -> B].
        Pour vérifier que c'est bien la preuve, utiliser la tactique
        [exact] suivie de ce terme dans la preuve.

           Theorem ex2.5 : A -> B -> B.
           exact (le terme).
           Defined.
*)

(** ** Exercice 3 - Retour sur la négation *)

(** On rappelle que [~A] est une abréviation pour [A -> False]. *)

(** Prouver les formules suivantes (en utilisant des tactiques).
    A l'aide de Print, regardez les termes de preuve.
       1. A -> ~~A
       2. (A -> B) -> (~B -> ~A) *)

(** Indication :
      Pour éliminer la proposition [False], on pourra utiliser
      la constante prédéfinie (ex falso quod libet) :
        false_ind : forall P : Prop, False -> P *)

(** ** Exercice 4 - Retour sur la conjonction *)

(** À l’aide des constantes prédéfinies
    and : Prop -> Prop -> Prop (* Sucre : A /\ B := and A B *)
    conj : forall A B : Prop, A -> B -> A /\ B.
    proj1 : forall A B : Prop, A /\ B -> A.
    proj2 : forall A B : Prop, A /\ B -> B.
    donnez des termes de preuve des propositions suivantes :
      1. A /\ B -> B /\ A
      2. (A /\ B) /\ C -> A /\ (B /\ C)
      3. (A -> B) /\ (A -> C) -> (A -> B /\ C)
      4. (A -> B /\ C) → (A -> B) /\ (A -> C)

    Vous commencerez par faire les preuves à l'aide des tactiques. *)

(** ** Exercice 5 - Retour sur la disjonction *)

(** À l’aide des constantes prédéfinies
    or : Prop -> Prop -> Prop (* Sucre : A \/ B := or A B *)
    or_introl : forall A B : Prop, A -> A \/ B
    or_intror : forall A B : Prop, B -> A \/ B
    or_ind : forall A B P : Prop, (A -> P) -> (B -> P) -> A \/ B -> P,
    donnez des termes de preuve des propositions suivantes :
      1. A \/ B -> B \/ A
      2. (A \/ B) \/ C -> A \/ (B \/ C)
      3. (A \/ B -> C) <-> (A -> C) /\ (B -> C)
      4. ~~ (A \/ ~A)

    Vous commencerez par faire les preuves à l'aide des tactiques. *)

(** Merci à Catherine Dubois. *)


From Coq Require Import Init.Nat.

Inductive Fin: nat -> Type :=
| Inherit: forall n, (Fin n) -> Fin (S n)
| Cur: forall n, Fin (S n).

(* Fin0: *)

(* Fin1: *)
Check (Cur 0).

(* Fin2: *)
Check (Cur 1).
Check (Inherit 1 (Cur 0)).

(* Fin3 *)
Check (Cur 2).
Check (Inherit 2 (Cur 1)).
Check (Inherit 2 (Inherit 1 (Cur 0))).

(* dependent function *)
Fixpoint fmax (a : nat) :=
  match a with
  | 0 => Cur 0
  | S a => Inherit (S a) (fmax a)
  end.

Check (fmax 3).
Check (fmax 4).

Inductive Product (A B:Type) : Type :=
  Pr : A -> B -> Product A B.

Check (Pr nat nat 1 2).

Check prod_ind.

(* Product Type *)
Definition indProduct (A B: Type) (C: Product A B -> Type)
           (g : forall (a: A) (b: B), C (Pr A B a b)):
  forall p : Product A B, C p :=
  fun p => match p with Pr _ _ a b => g a b end.

Definition recProduct (A B: Type) (C: Type) (g : A -> B -> C) : Product A B -> C :=
  indProduct A B (fun _ => C) g.

Definition pr1 (A B : Type) : Product A B -> A :=
  recProduct A B A (fun a b => a).

Definition pr2 (A B : Type) : Product A B -> B :=
  recProduct A B B (fun a b => b).

Definition uniq (A B: Type) (p: Product A B) : Pr A B (pr1 A B p) (pr2 A B p) = p.
Proof.
  induction p.
  reflexivity.
Qed.

Check (pr1 nat unit (Pr nat unit 1 tt)).
Check (pr2 nat unit (Pr nat unit 1 tt)).
Check (uniq nat unit (Pr nat unit 1 tt)).

(* dependent pair *)

Inductive Sigma (A: Type) (B: A -> Type):=
| Sig : forall a: A, (B a) -> Sigma A B.

Check Sig.

Inductive FinPlus: nat -> Type :=
| InheritPlus: forall n, (FinPlus n) -> FinPlus (S n)
| CurPlus: forall n, FinPlus n.

Fixpoint fPlusMax (a : nat) :=
  match a with
  | 0 => CurPlus 0
  | S a => InheritPlus (a) (fPlusMax a)
  end.

Check (Sig nat FinPlus 1 (fPlusMax 1)).

Definition indSigma (A: Type) (B: A -> Type) (C: Sigma A B -> Type) (g : forall (a: A) (b: B a), C (Sig A B a b)): forall p : Sigma A B, C p :=
  fun p => match p with Sig _ _ a b => g a b end.

Definition recSigma (A: Type) (B: A -> Type) (C: Type) (g: forall a: A, B a -> C): forall p: Sigma A B, C :=
  indSigma A B (fun _ => C) g.

Definition sig1 (A : Type) (B: A -> Type): Sigma A B -> A :=
  recSigma A B A (fun a b => a).

Definition sig2 (A : Type) (B: A -> Type): forall p: Sigma A B, B (sig1 A B p) :=
  indSigma A B (fun p => B (sig1 A B p)) (fun _ b => b).

Definition ac (A B: Type) (R: forall (a: A) (b: B), Type) (g: forall (x: A) , Sigma B (fun y => R x y)) : Sigma (A -> B) (fun f => forall x: A, R x (f x)):=
  Sig (A -> B) (fun f => forall x: A, R x (f x)) (fun x => sig1 B (fun y => R x y) (g x)) (fun x => sig2 B (fun y => R x y) (g x)).

Definition magma : Type := Sigma Type (fun A => A -> A -> A).

Definition fstm (m : magma) : Type := sig1 _ _ m.
Definition sndm (m : magma) : (let A := fstm m in A -> A -> A) := sig2 _ _ m.

(* Magma *)
Definition nat_first : magma := Sig Type (fun A => A -> A -> A) nat (fun a _ => a).
Definition nat_snd : magma := Sig Type (fun A => A -> A -> A) nat (fun _ b => b).

Definition PointedMagma: Type := Sigma Type (fun A => Product (A -> A -> A) A).

Definition nat_add: PointedMagma := Sig Type (fun A => Product (A -> A -> A) A) nat (Pr _ _ (fun a b => a + b) 0).

(* coproduct type *)

Inductive Coproduct (A B: Type): Type :=
|Inl: A -> Coproduct A B
|Inr: B -> Coproduct A B.

Check (Inl nat bool 3).

Definition indCoproduct (A B: Type) (C: Coproduct A B -> Type) (g0: forall a: A, C (Inl A B a)) (g1: forall b: B, C(Inr A B b)): forall c: Coproduct A B, C c :=
  fun c => match c with | Inl _ _ a => g0 a | Inr _ _ b => g1 b end.

Definition recCoproduct (A B C:Type) (g0: A -> C) (g1: B -> C): Coproduct A B -> C :=
  indCoproduct A B (fun _ => C) g0 g1.

(* empty type *)
Inductive Empty: Type :=.
Definition indEmpty (C : Empty -> Type) (z: Empty): C z :=
  match z with end.

(* unit type *)
Inductive Unit: Type := tt : Unit.
Definition indUnit (C : Unit -> Type) (g: forall u: Unit, C(u)) : forall x: Unit, C(x) := g.
Print Unit_ind.

(* boolean type *)
Definition Boolean : Type := Coproduct Unit Unit.
Definition b0 : Boolean := Inl Unit Unit tt.
Definition b1 : Boolean := Inr Unit Unit tt.
Definition indBoolean (C: Boolean -> Type) (g0: forall a: Unit, C (Inl Unit Unit a)) (g1: forall b: Unit, C (Inr Unit Unit b)): forall b: Boolean, C b :=
  indCoproduct Unit Unit C g0 g1.

Definition recBoolean (C: Type) (g0: C) (g1: C): Boolean -> C :=
  indBoolean (fun _ => C) (fun _ => g0) (fun _ => g1).

Definition CoproductByBoolean (A B: Type): Type := Sigma Boolean (fun x: Boolean => recBoolean Type A B x).
Definition InlByBoolean (A B: Type) (a: A) : CoproductByBoolean A B :=
  Sig Boolean (fun x: Boolean => recBoolean Type A B x) b0 a.
Definition InrByBoolean (A B: Type) (b: B) : CoproductByBoolean A B :=
  Sig Boolean (fun x: Boolean => recBoolean Type A B x) b1 b.

Definition ProductByBoolean (A B: Type): Type :=
  (forall x: Boolean, recBoolean Type A B x).

Definition PrByBoolean (A B: Type) (a: A) (b : B)
  : ProductByBoolean A B :=
  indBoolean (fun x => recBoolean Type A B x) (fun _ => a) (fun _ => b).

Definition RecProduct C A B (g : (A -> B -> C)) (p : ProductByBoolean A B) : C :=
  g (p b0) (p b1).

Definition Pr1ByBoolean (A B: Type) (p: ProductByBoolean A B): A := p b0.
Definition Pr2ByBoolean (A B: Type) (p: ProductByBoolean A B): B := p b1.

Require Import FunctionalExtensionality.

Theorem pr1_rec : forall A B,
    Pr1ByBoolean A B = RecProduct A A B (fun a _ => a).
Proof.
  intros A B.
  extensionality p.
  unfold Pr1ByBoolean.
  unfold RecProduct.
  reflexivity.
Qed.

Theorem pr2_rec : forall A B,
    Pr2ByBoolean A B = RecProduct B A B (fun _ b => b).
Proof.
  intros A B.
  extensionality p.
  reflexivity.
Qed.

(* nat type *)

Inductive Natural : Type :=
| n0: Natural
| nsucc: forall n: Natural, Natural.

(* work around, as coq fixpoint functions require the first arg to be a structurally snaller one. *)
Definition indNatural (C: Natural -> Type) (g0: C n0) (g1: (forall n: Natural, C n -> C (nsucc n))): forall n: Natural, C n :=
  fix aux (n: Natural) : C n :=
    match n with | n0 => g0 | nsucc n' => g1 n' (aux n') end.

Definition recNatural (C: Type) (g0: C) (g1: Natural -> C -> C): Natural -> C :=
  indNatural (fun _ => C) g0 g1.

Definition addNatural: Natural -> Natural -> Natural :=
  recNatural (Natural -> Natural) (fun b => b) (fun _ f b => nsucc (f b)).

Definition addProperty0 : forall n, addNatural n0 n = n := fun _ => eq_refl.
Definition addProperty1 : forall n m, addNatural (nsucc m) n = nsucc (addNatural m n) := fun _ _ => eq_refl.

Definition doubleNatural: Natural -> Natural:=
  recNatural Natural n0 (fun _ n => nsucc (nsucc n)).

Definition assoc0: forall j k: Natural, addNatural n0 (addNatural j k) = addNatural (addNatural n0 j) k :=
  fun _ _ => eq_refl.

Definition ap (A B: Type) (f: A -> B) (x y: A) : x = y -> f x = f y.
Proof.
  intros.
  rewrite H.
  reflexivity.
Qed.

Print ap.

Definition apSucc (a b: Natural) : a = b -> nsucc a = nsucc b :=
  ap Natural Natural nsucc a b.

Definition assocs (i : Natural) (h: forall j k: Natural, addNatural i (addNatural j k) = addNatural (addNatural i j) k) : (forall j k: Natural, addNatural (nsucc i) (addNatural j k) = addNatural (addNatural (nsucc i) j) k) :=
  fun j k => apSucc (addNatural i (addNatural j k)) (addNatural (addNatural i j) k) (h j k).

Definition assoc: forall i, forall j k, addNatural i (addNatural j k) = addNatural (addNatural i j) k :=
  indNatural (fun i => forall j k, addNatural i (addNatural j k) = addNatural (addNatural i j) k) assoc0 assocs.

(* propositions as types *)

Definition LogicTrue : Type := Unit.
Definition LogicFalse : Type := Empty.
Definition LogicAnd : Type -> Type -> Type := Product.
Definition LogicOr : Type -> Type -> Type := Coproduct.
Definition LogicIf : Type -> Type -> Type := fun A B => A -> B.
Definition LogicIff : Type -> Type -> Type := fun A B => Product (LogicIf A B) (LogicIf B A).
Definition LogicNot : Type -> Type := fun A => LogicIf A LogicFalse.

Definition PropExample (A B: Type): LogicIf (LogicAnd (LogicNot A) (LogicNot B)) (LogicNot (Coproduct A B)) :=
  indProduct (LogicNot A) (LogicNot B) (fun _ => (LogicNot (Coproduct A B)))
             (fun notA notB => indCoproduct A B (fun _ => LogicFalse)(fun a => match notA a with end) (fun b => match notB b with end)).

Print PropExample.

Definition LogicExists := Sigma.

Definition PropExample2 (A: Type) (P: A -> Type) (Q: A -> Type): (forall x: A, Product (P x) (Q x)) -> (Product (forall x: A, P x) (forall x: A, Q x)) :=
  fun pre => Pr (forall x: A, P x) (forall x: A, Q x)
             (fun x => recProduct (P x) (Q x) (P x) (fun x _ => x) (pre x))
             (fun x => recProduct (P x) (Q x) (Q x) (fun _ y => y) (pre x)).

Definition LessThanEq (n m: Natural): Type := Sigma Natural (fun k => addNatural n k = m).

Print LessThanEq.

Definition LessThan (n m: Natural) : Type := Product (LessThanEq n m) (LogicNot (n = m)).
Check LessThan.

Definition LteExample : LessThanEq n0 n0 :=
  Sig Natural (fun k => addNatural n0 k = n0) n0 eq_refl.

Lemma zero_is_not_one: (LogicNot (n0 = (nsucc n0))).
Proof.
  unfold LogicNot.
  unfold LogicIf.
  intros.
  inversion H.
Qed.

Print zero_is_not_one.

Definition LtExample : LessThan n0 (nsucc n0) :=
  Pr _ _ (Sig Natural (fun k => addNatural n0 k = (nsucc n0)) (nsucc n0) eq_refl) zero_is_not_one.

Definition Semigroup: Type := Sigma Type (fun A => Sigma (A -> A -> A) (fun m => forall x y z: A, m x (m y z) = m (m x y) z)).

Lemma assocNatural: forall x y z : Natural, addNatural x (addNatural y z) = addNatural (addNatural x y) z.
Proof.
  intro x.
  induction x; intros.
  + reflexivity.
  + simpl. rewrite (IHx y z). reflexivity.
Qed.

Definition SemigroupExample: Semigroup :=
  Sig Type (fun A => Sigma (A -> A -> A) (fun m => forall x y z: A, m x (m y z) = m (m x y) z)) Natural
      (Sig (Natural -> Natural -> Natural) (fun m => forall x y z: Natural, m x (m y z) = m (m x y) z) addNatural assocNatural).

Print SemigroupExample.

(* identity type. *)
Inductive Identity (A: Type): A -> A -> Type :=
| idRefl: forall a: A, Identity A a a.

(* path induction *)
(* induction rule *)
Definition indId (A: Type) (C: forall x y: A, Identity A x y -> Type) (f: forall x: A, C x x (idRefl A x)) : forall x y: A, forall p: Identity A x y, C x y p :=
  fun _ _ p => match p in (Identity _ x' y') return C x' y' p with
            | idRefl _ a => f a
            end.

(* indiscernibility of identils *)
(* rewrite rule *)

Definition idRewrite (A: Type) (C: A -> Type): forall a b: A, forall p: Identity A a b, (C a) -> (C b) :=
  fun _ _ p => match p in Identity _ a b return C a -> C b with
            | idRefl _ _ => fun x => x
            end.

Definition idRewrite' (A: Type) (C: A -> Type): forall a b: A, forall p: Identity A a b, (C a) -> (C b) :=
  indId A (fun x y _ => C x -> C y) (fun _ => fun x => x).

(* base path induction *)

Definition baseIndId (A: Type) (a: A) (C: forall x: A, Identity A a x -> Type) (c: C a (idRefl A a)) : forall x: A, forall p: Identity A a x, C x p :=
  fun x p =>
    (fun _ p => match p in Identity _ a x return forall C': forall x: A, Identity A a x -> Type, forall c: C' a (idRefl A a), C' x p with
             | idRefl _ _ => fun _ p => p
             end) x p C c.

(* baseInd is equivalent with ind *)

Definition baseIndId' (A: Type) (a: A) (C: forall x: A, Identity A a x -> Type) (c: C a (idRefl A a)) (x: A) (p: Identity A a x) : C x p :=
  (indId A (fun a x p => forall C': forall x: A, Identity A a x -> Type, forall c' : C' a (idRefl A a), C' x p) (fun _ _ p => p)) a x p C c.

Definition indId' (A: Type) (C: forall x y: A, Identity A x y -> Type) (f: forall x: A, C x x (idRefl A x)) : forall x y: A, forall p: Identity A x y, C x y p :=
  fun x => baseIndId A x (fun y => C x y) (f x).

(* disequality *)
Definition disequal (A: Type) := forall x y: A, LogicNot (Identity A x y).

(* Exercises *)

(* 1.1 *)
Definition composite {A B C: Type} (g: B -> C) (f: A -> B) : A -> C := fun x => g (f x).

Definition compositeRule {A B C D: Type} (f: A -> B) (g: B -> C) (h: C -> D) : Identity (A -> D) (composite h (composite g f)) (composite (composite h g) f) := idRefl (A -> D) (fun x => h (g (f x))).

(* 1.2 *)

Definition recProduct' (A B: Type) (C: Type) (g : A -> B -> C) : Product A B -> C :=
  fun p => g (pr1 A B p) (pr2 A B p).

Definition recSigma' (A: Type) (B: A -> Type) (C: Type) (g: forall a: A, B a -> C): forall p: Sigma A B, C :=
  fun p => g (sig1 A B p) (sig2 A B p).

(* 1.3 *)

Definition indProduct' (A B: Type) (C: Product A B -> Type) (g : forall (a: A) (b: B), C (Pr A B a b)): forall p : Product A B, C p :=
  fun p => eq_rect (Pr A B (pr1 A B p) (pr2 A B p)) C (g (pr1 A B p) (pr2 A B p)) p (uniq A B p).

Definition sigmaUniq (A: Type)  (B: A -> Type) (p: Sigma A B) : Sig A B (sig1 A B p) (sig2 A B p) = p.
Proof.
  induction p.
  reflexivity.
Qed.

Definition indSigma' (A: Type) (B: A -> Type) (C: Sigma A B -> Type) (g : forall (a: A) (b: B a), C (Sig A B a b)): forall p : Sigma A B, C p :=
  fun p => eq_rect (Sig A B (sig1 A B p) (sig2 A B p)) C (g (sig1 A B p) (sig2 A B p)) p (sigmaUniq A B p).

(* 1.4 *)

Definition iter (C: Type) (c0: C) (cs: C -> C) (n: Natural): C :=
  (fix aux (n: Natural) : C :=
     match n with
     | n0 => c0
     | nsucc n' => cs (aux n')
     end) n.

Definition recNatural' (C: Type) (g0: C) (g1: Natural -> C -> C): Natural -> C :=
  fun n => pr2 _ _ (iter (Product Natural C) (Pr _ _ n0 g0) (fun p => Pr _ _ (nsucc (pr1 _ _ p)) (g1 (pr1 _ _ p) (pr2 _ _ p))) n).

Definition recEqrec (C: Type) (g0: C) (g1: Natural -> C -> C) (n: Natural): recNatural C g0 g1 n = recNatural' C g0 g1 n.
Proof.
  intros.
  induction n.
  + reflexivity.
  + simpl.
    rewrite IHn.
    unfold recNatural'.
    simpl.
    clear IHn.
    assert (forall n, n = (pr1 Natural C
                          (iter (Product Natural C) (Pr Natural C n0 g0)
                                (fun p : Product Natural C => Pr Natural C (nsucc (pr1 Natural C p)) (g1 (pr1 Natural C p) (pr2 Natural C p))) n))).
  - clear n.
    intros.
    induction n.
    * reflexivity.
    * simpl.
      rewrite <- IHn.
      reflexivity.
  - rewrite <- (H n).
    reflexivity.
Qed.

(* 1.5 *)

Definition CoproductByRec2 (A B: Type) : Type := Sigma Boolean (fun b => recBoolean Type A B b).

Definition indCoproductByRec2 (A B: Type) (C: CoproductByRec2 A B -> Type) (p1: forall a: A, C (Sig _ _ b0 a)) (p2: forall b: B, C (Sig _ _ b1 b)): forall c: CoproductByRec2 A B, C c :=
  indSigma _ _ C (fun b x =>
                    indBoolean (fun b => forall x, C (Sig Boolean (fun b => recBoolean Type A B b) b x))
                               (fun u x => Unit_rect (fun u => C (Sig Boolean (fun x : Boolean => recBoolean Type A B x) (Inl Unit Unit u) x)) (p1 x) u)
                               (fun u x => Unit_rect (fun u => C (Sig Boolean (fun x : Boolean => recBoolean Type A B x) (Inr Unit Unit u) x)) (p2 x) u)
                               b x
                 ).

Definition Ex_1_5 (A B: Type) (C: CoproductByRec2 A B -> Type) (p1: forall a: A, C (Sig _ _ b0 a)) (p2: forall b: B, C (Sig _ _ b1 b)) : forall a: A, indCoproductByRec2 A B C p1 p2 (Sig _ _ b0 a) = p1 a := fun _ => eq_refl.

Definition Ex_1_5' (A B: Type) (C: CoproductByRec2 A B -> Type) (p1: forall a: A, C (Sig _ _ b0 a)) (p2: forall b: B, C (Sig _ _ b1 b)) : forall b: B, indCoproductByRec2 A B C p1 p2 (Sig _ _ b1 b) = p2 b := fun _ => eq_refl.

(* 1.6 *)

Definition ProductByRec2 (A B: Type) : Type :=
  forall b: Boolean, recBoolean Type A B b.

Definition PrByRec2 (A B: Type) (x: A) (y: B)
  : ProductByRec2 A B :=
  indBoolean (fun b => recBoolean Type A B b)
             (fun _ => x)
             (fun _ => y).

From Coq Require Import Logic.FunctionalExtensionality.

Definition Lemma1_6 (A B: Type): forall p: ProductByRec2 A B, PrByRec2 A B (p b0) (p b1) = p :=
  fun p => functional_extensionality_dep
          (PrByRec2 A B (p b0) (p b1))
          p
          (fun bo => indBoolean (fun bo => (PrByRec2 A B (p b0) (p b1)) bo = p bo)
                             (Unit_rect (fun u => PrByRec2 A B (p b0) (p b1) (Inl Unit Unit u) = p (Inl Unit Unit u))
                                        eq_refl
                             )
                             (Unit_rect (fun u => PrByRec2 A B (p b0) (p b1) (Inr Unit Unit u) = p (Inr Unit Unit u))
                                        eq_refl
                             )
                             bo).

Definition indProductByRec2 (A B: Type) (C: ProductByRec2 A B -> Type) (p: forall a: A, forall b: B, C (PrByRec2 A B a b)) : forall c: ProductByRec2 A B, C c :=
  fun c => @eq_rect (ProductByRec2 A B) (PrByRec2 A B (c b0) (c b1)) C (p (c b0) (c b1)) c (Lemma1_6 A B c).

(* Sorry Pedrotst, I can not compile this part of code. *)

(* Lemma indProductByRec2LemmaEq (A B: Type) *)
(*            (C: (recBoolean Type A B) -> Type) : *)
(*   (forall a b bo, C (PrByRec2 A B a b bo)) = *)
(*   (forall c a b, ProductByRec c a b). *)

From Coq Require Import Logic.Eqdep.

(* Axiom eq_rect_eq : *)
(*   forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. *)

Definition Eq1_6 (A B: Type) (C: ProductByRec2 A B -> Type) (g: forall a: A, forall b: B, C (PrByRec2 A B a b)) (a: A) (b: B): indProductByRec2 A B C g (PrByRec2 A B a b) = g a b.
Proof.
  unfold indProductByRec2.
  unfold Lemma1_6.
  rewrite <- eq_rect_eq.
  reflexivity.
Qed.


Require Import Arith.
Require Import FunctionalExtensionality.
Require Import ProofIrrelevance.

Structure partial_order :=
  mk_partial_order {
      po_set     : Type ;
      po_le      : po_set -> po_set -> Prop ;
      po_refl    : forall a, po_le a a ;
      po_antisym : forall a b,
                     po_le a b ->
                     po_le b a ->
                     a = b ;
      po_trans   : forall a b c,
                     po_le a b ->
                     po_le b c ->
                     po_le a c
  }.

Notation "x << y" := (po_le _ x y) (at level 35).

Definition subset (A : Type) := A -> Prop.

Definition po_upper_bound po (S : subset (po_set po)) (bound : po_set po) :=
  forall x, S x -> x << bound.

Definition po_least_upper_bound po (S : subset (po_set po)) (lub : po_set po) :=
  po_upper_bound po S lub /\
  forall bound, po_upper_bound po S bound -> lub << bound.

Lemma po_lub_unique : forall po S lub1 lub2,
                        po_least_upper_bound po S lub1 ->
                        po_least_upper_bound po S lub2 ->
                        lub1 = lub2.
Proof.
  intros po S lub1 lub2 lub1_prop lub2_prop.
  apply po_antisym.
  apply lub1_prop.
  apply lub2_prop.
  apply lub2_prop.
  apply lub1_prop.
Qed.

Definition po_monotonic A B (f : po_set A -> po_set B) :=
  forall x y, x << y -> f x << f y.

Definition f_ap (A B : Type) (f : A -> B) (S : subset A) : subset B :=
  fun b : B => exists a : A, S a /\ f a = b.

Notation "f !! S" := (f_ap _ _ f S) (at level 35).

(**
 **   \/ (f !! S)  <<  f (\/ S)
 **)
Lemma lub_f_vs_f_lub :
  forall A B f,
    po_monotonic A B f ->
    forall (S : subset (po_set A)),
      forall lubA lubB,
        po_least_upper_bound A S lubA ->
        po_least_upper_bound B (f !! S) lubB ->
        lubB << f lubA.
Proof.
  intros A B f f_monotonic S lubA lubB lubA_prop lubB_prop.
  unfold po_least_upper_bound in lubB_prop.
  destruct lubB_prop as (lubB_upper, lubB_least).
  apply lubB_least.
  unfold po_upper_bound.
  intros x x_in_fS.
  unfold f_ap in x_in_fS.
  elim x_in_fS.
  intros y y_prop.
  destruct y_prop as (y_in_S, x_eq_fy).
  replace x with (f y).
  apply f_monotonic.
  unfold po_least_upper_bound in lubA_prop.
  destruct lubA_prop as (lubA_upper, lubA_least).
  apply lubA_upper.
  assumption.
Qed.

(** Filters **)

Definition po_filter po (F : subset (po_set po)) :=
   forall a b, F a -> F b ->
               exists c,
                 F c
                 /\ a << c
                 /\ b << c.

Definition singleton (A : Type) (S : subset A) :=
  forall x y, S x -> S y -> x = y.

Lemma filter_singleton : forall po S, singleton (po_set po) S -> po_filter po S.
Proof.
  unfold po_filter.
  intros po S S_singleton a b a_in_S b_in_S.
  exists a.
  split.
  assumption.
  split.
  apply po_refl.
  replace b with a.
  apply po_refl.
  apply S_singleton.
  assumption.
  assumption.
Qed.

Structure domain :=
  mk_domain {
      d_po        : partial_order ;
      d_bot       : po_set d_po ;
      d_bot_prop  : forall x, d_bot << x ;
      d_lub       : forall F, po_filter d_po F -> po_set d_po ;
      d_lub_prop  : forall F (F_filter : po_filter d_po F),
                        po_least_upper_bound d_po F (d_lub F F_filter)
  }.

Definition stream_le po I (f : I -> po_set po) (g : I -> po_set po) :=
  forall x, f x << g x.

Lemma stream_refl : forall po I f, stream_le po I f f.
Proof.
  intros.
  unfold stream_le.
  intro.
  apply po_refl.
Qed.

Lemma stream_antisym :
  forall po I f g,
    stream_le po I f g ->
    stream_le po I g f ->
    f = g.
Proof.
  intros po I f g f_le_g g_le_f.
  apply functional_extensionality.
  intro.
  apply po_antisym.
  apply f_le_g.
  apply g_le_f.
Qed.

Lemma stream_trans :
  forall po I f g h,
    stream_le po I f g ->
    stream_le po I g h ->
    stream_le po I f h.
Proof.
  intros po I f g h f_le_g g_le_h.
  unfold stream_le.
  intro.
  apply po_trans with (g x).
  apply f_le_g.
  apply g_le_h.
Qed.

Definition stream po I :=
  mk_partial_order
      (I -> po_set po)
      (stream_le po I)
      (stream_refl po I)
      (stream_antisym po I)
      (stream_trans po I).

Definition stream_bot (D : domain) I : po_set (stream (d_po D) I) :=
  fun _ => d_bot D.

Lemma stream_bot_prop (D : domain) I :
  forall f : po_set (stream (d_po D) I), stream_bot D I << f.
Proof.
  intro f.
  simpl; unfold stream_le.
  intro x.
  unfold stream_bot.
  apply d_bot_prop.
Qed.

Lemma stream_lub_inner_prop
      (D : domain) I
      (F : subset (po_set (stream (d_po D) I)))
      (F_filter : po_filter (stream (d_po D) I) F)
      (x : I) :
      po_filter (d_po D) (fun y => exists f, F f /\ f x = y).
Proof.
  unfold po_filter.
  intros a b a_shape b_shape.
  elim a_shape.
    intro f.
    intro a_shape2.
    destruct a_shape2 as (f_in_F, fx_eq_a).
  elim b_shape.
    intro g.
    intro b_shape2.
    destruct b_shape2 as (g_in_F, gx_eq_b).
  assert (exists h, F h /\ f << h /\ g << h) as exists_h.
    unfold po_filter in F_filter.
    apply F_filter.
    assumption.
    assumption.
  elim exists_h.
  intro hh.
  intro hh_prop.
  destruct hh_prop as (hh_in_F, fg_le_hh).
  destruct fg_le_hh as (f_le_hh, g_le_hh).
  exists (hh x).
  split.
    exists hh.
    split.
    assumption.
    reflexivity.
    replace a with (f x).
    replace b with (g x).
    split.
    apply f_le_hh.
    apply g_le_hh.
Qed.

Definition stream_lub (D : domain) I
                      (F : subset (po_set (stream (d_po D) I)))
                      (F_filter : po_filter (stream (d_po D) I) F)
                      : po_set (stream (d_po D) I)
                      :=
  fun x : I =>
    d_lub D
          (fun y => exists f, F f /\ f x = y)
          (stream_lub_inner_prop D I F F_filter x).

Lemma stream_lub_prop
      (D : domain) I
      (F : subset (po_set (stream (d_po D) I)))
      (F_filter : po_filter (stream (d_po D) I) F) :
        po_least_upper_bound (stream (d_po D) I) F (stream_lub D I F F_filter).
Proof.
  split.
  (* upper *)
  unfold po_upper_bound.
  intro f.
  intro f_in_F.
  simpl.
  unfold stream_le.
  intro x.
  unfold stream_lub.
  apply d_lub_prop.
  exists f.
  split.
  assumption.
  reflexivity.
  (* least *)
  intros f_bound f_bound_upper_bound.
  simpl.
  unfold stream_le.
  intro x.
  apply d_lub_prop.
  unfold po_upper_bound.
  intro y.
  intro y_shape.
  elim y_shape.
  intro f.
  intro f_prop.
  destruct f_prop as (f_in_F, fx_eq_y).
  replace y with (f x).
  apply f_bound_upper_bound.
  assumption.
Qed.

Definition stream_domain (D : domain) I :=
    mk_domain
      (stream (d_po D) I)
      (stream_bot D I)
      (stream_bot_prop D I)
      (stream_lub D I)
      (stream_lub_prop D I).

(** Continuous functions **)

Definition d_set D := po_set (d_po D).
Definition d_monotonic D E (f : d_set D -> d_set E) := po_monotonic (d_po D) (d_po E) f.
Definition d_filter D (F : subset (d_set D)) := po_filter (d_po D) F.
Definition d_least_upper_bound D S lub := po_least_upper_bound (d_po D) S lub.

Definition d_continuous D E f (f_monotonic : d_monotonic D E f) :=
  forall F (F_filter : d_filter D F),
    forall lubD, d_least_upper_bound D F lubD ->
      forall lubE, d_least_upper_bound E (fun x => exists y, F y /\ f y = x) lubE ->
        lubE = f lubD.

Definition d_function_space (D E : domain) :=
  { f : d_set D -> d_set E |
    { f_monotonic : d_monotonic D E f & d_continuous D E f f_monotonic }
  }.

Notation "D =>> E" := (d_function_space D E) (at level 35).

Definition d_function_ap D E (f : D =>> E) (x : d_set D) := proj1_sig f x.

Notation "f $ x" := (d_function_ap _ _ f x) (at level 25).

Definition d_function_le D E (f g : D =>> E) := forall x, f $ x << g $ x.

Lemma d_function_le_refl D E (f : D =>> E) : d_function_le D E f f.
Proof.
  intro.
  apply po_refl.
Qed.

Lemma d_functional_extensionality :
  forall D E (f g : D =>> E),
    (forall x, f $ x = g $ x) -> f = g.
Proof.
  intros D E f g fx_eq_gx.
  case_eq f. intros f_function f_continuous f_shape.
  case_eq g. intros g_function g_continuous g_shape.
  cut (f_function = g_function); [ intro H; destruct H | ].
  cut (f_continuous = g_continuous); [ intro H; destruct H | ].
  reflexivity.
  apply proof_irrelevance.
  rewrite f_shape in fx_eq_gx.
  rewrite g_shape in fx_eq_gx.
  simpl in fx_eq_gx.
  apply functional_extensionality.
  assumption.
Qed.

Lemma d_le_extensional :
  forall D E (f g : D =>> E) x, d_function_le D E f g -> f $ x << g $ x.
Proof.
  intros D E f g x H.
  unfold d_function_le in H.
  specialize H with x.
  assumption.
Qed.

Lemma d_function_le_antisym D E (f g : D =>> E) :
  d_function_le D E f g ->
  d_function_le D E g f ->
  f = g.
Proof.
  unfold d_function_le.
  intros f_le_g g_le_f.
  apply d_functional_extensionality.
  intro x.
  apply po_antisym.
  specialize f_le_g with x.
  assumption.
  specialize g_le_f with x.
  assumption.
Qed.

Lemma d_function_le_trans D E (f g h : D =>> E) :
  d_function_le D E f g ->
  d_function_le D E g h ->
  d_function_le D E f h.
Proof.
  intros f_le_g g_le_h.
  unfold d_function_le in *.
  intro x.
  specialize f_le_g with x.
  specialize g_le_h with x.
  apply po_trans with (g $ x).
  assumption.
  assumption.
Qed.

Definition d_function_space_partial_order (D E : domain) : partial_order :=
  mk_partial_order
    (d_function_space D E)
    (d_function_le D E)
    (d_function_le_refl D E)
    (d_function_le_antisym D E)
    (d_function_le_trans D E).

Definition d_function_domain_bot_function D E : d_set D -> d_set E :=
  fun _ : d_set D => d_bot E.

Lemma d_function_domain_bot_monotonic D E :
  d_monotonic D E (d_function_domain_bot_function D E).
Proof.
  unfold d_monotonic.
  unfold po_monotonic.
  intros x y x_le_y.
  apply po_refl.
Qed.

Lemma d_function_domain_bot_continuous D E :
  d_continuous D E
               (d_function_domain_bot_function D E)
               (d_function_domain_bot_monotonic D E).
Proof.
  unfold d_continuous.
  intros F F_filter lubD lubD_lub lubE lubE_lub.
  unfold d_function_domain_bot_function.
  apply po_lub_unique
   with (S :=
         fun x : po_set (d_po E) =>
           exists y : d_set D,
             F y /\ d_function_domain_bot_function D E y = x).
  apply lubE_lub.
  unfold po_least_upper_bound.
  split.
    (* bot is upper bound *)
    unfold po_upper_bound.
    intros x x_prop.
    elim x_prop.
    intros y x_shape.
    destruct x_shape as (Fy, dom_bot_func_y_eq_x).
    rewrite <- dom_bot_func_y_eq_x.
    unfold d_function_domain_bot_function.
    apply po_refl.
    (* bot is least upper bound *)
    intros.
    apply d_bot_prop.
Qed.

Definition d_function_domain_bot D E : po_set (d_function_space_partial_order D E).
  exists (d_function_domain_bot_function D E).
  exists (d_function_domain_bot_monotonic D E).
  apply d_function_domain_bot_continuous.
Defined.

Lemma d_function_domain_bot_apply :
  forall D E x,
    d_function_domain_bot D E $ x = d_bot E.
Proof.
  intros.
  unfold d_function_ap.
  unfold d_function_domain_bot.
  unfold proj1_sig.
  reflexivity.
Qed.

Lemma d_function_domain_bot_prop D E :
  forall f : po_set (d_function_space_partial_order D E),
    d_function_domain_bot D E << f.
Proof.
  intros.
  simpl.
  unfold d_function_le.
  intros.
  rewrite d_function_domain_bot_apply.
  apply d_bot_prop.
Qed.

Lemma d_function_domain_lub_function_filter :
  forall D E F (F_filter : po_filter (d_function_space_partial_order D E) F) x,
    po_filter (d_po E) (fun y : d_set E => exists f, F f /\ f $ x = y).
Proof.
  intros D E F F_filter x.
  unfold po_filter.
  intros y1 y2.
  intros y1_prop y2_prop.
  elim y1_prop; intros f1 y1_shape.
  elim y2_prop; intros f2 y2_shape.
  destruct y1_shape as (f1_in_F, f1_x_eq_y1).
  destruct y2_shape as (f2_in_F, f2_x_eq_y2).
  assert (exists g, F g /\ f1 << g /\ f2 << g) as exists_g.
    apply F_filter.
    assumption.
    assumption.
  elim exists_g; intros g g_prop.
  exists (g $ x).
  split.
    exists g.
    split.
    apply g_prop.
    reflexivity.
    replace y1 with (f1 $ x).
    replace y2 with (f2 $ x).
    destruct g_prop as (g_in_F, (f1_le_g, f2_le_g)).

    split.
       apply d_le_extensional; assumption.
       apply d_le_extensional; assumption.
Qed.

Definition d_function_domain_lub_function
           D E F (F_filter : po_filter (d_function_space_partial_order D E) F) :
           d_set D -> d_set E :=
  fun x : d_set D =>
    d_lub E
          (fun y : d_set E => exists f, F f /\ f $ x = y)
          (d_function_domain_lub_function_filter D E F F_filter x).

Lemma d_functional_monotonic :
  forall D E (f : D =>> E), d_monotonic D E (proj1_sig f).
Proof.
  intros D E f.
  case f.
  simpl.
  intros f_function f_shape.
  destruct f_shape.
  assumption.
Qed.

Lemma d_functional_continuous :
  forall D E (f : D =>> E), d_continuous D E
                                         (proj1_sig f)
                                         (d_functional_monotonic D E f).
Proof.
  intros D E f.
  case f.
  simpl.
  intros f_function f_prop.
  destruct f_prop.
  assumption.
Qed.

Lemma d_function_domain_lub_monotonic
           D E F (F_filter : po_filter (d_function_space_partial_order D E) F) :
             d_monotonic D E (d_function_domain_lub_function D E F F_filter).
Proof.
  unfold d_monotonic.
  unfold po_monotonic.
  intros x y x_le_y.
  unfold d_function_domain_lub_function.
  simpl.
  apply d_lub_prop.
  unfold po_upper_bound.
  intros fx fx_prop.
  elim fx_prop. intros f fx_shape.
  destruct fx_shape as (f_in_F, f_ap_x_eq_fx).
  apply po_trans with (f $ y).
  rewrite <- f_ap_x_eq_fx.
  assert (d_monotonic D E (proj1_sig f)) as f_monotonic.
    apply d_functional_monotonic.
  apply f_monotonic.
  assumption.
  apply d_lub_prop.
  exists f.
  split.
  assumption.
  reflexivity.
Qed.

Lemma d_functional_preserves_filter :
  forall D E (f : D =>> E) F, d_filter D F -> d_filter E (proj1_sig f !! F).
Proof.
  intros D E f F F_filter.
  unfold d_filter.
  unfold po_filter.
  intros a b a_prop b_prop.
  unfold f_ap in a_prop.
  unfold f_ap in b_prop.
  elim a_prop.
  intros a_pre a_shape.
  elim b_prop.
  intros b_pre b_shape.
  destruct a_shape as (a_pre_in_F, a_eq_f_a_pre).
  destruct b_shape as (b_pre_in_F, b_eq_f_b_pre).
  assert (exists c_pre, F c_pre /\ a_pre << c_pre /\ b_pre << c_pre)
      as exists_c_pre.
    apply F_filter.
    assumption.
    assumption.
  elim exists_c_pre.
  intros c_pre c_pre_shape.
  destruct c_pre_shape as (c_pre_in_F, (a_pre_le_c_pre, b_pre_le_c_pre)).
  exists (proj1_sig f c_pre).
  assert (d_monotonic D E (proj1_sig f)) as f_monotonic.
    apply d_functional_monotonic.
  split.
    unfold f_ap.
    exists c_pre.
    split. assumption. reflexivity.
    split.
    rewrite <- a_eq_f_a_pre.
    apply f_monotonic.
    assumption.
    rewrite <- b_eq_f_b_pre.
    apply f_monotonic.
    assumption.
Qed.

Lemma d_function_domain_lub_continuous
           D E F (F_filter : po_filter (d_function_space_partial_order D E) F) :
             d_continuous D E
                          (d_function_domain_lub_function D E F F_filter)
                          (d_function_domain_lub_monotonic D E F F_filter).
Proof.
  unfold d_continuous.
  intros G G_filter lubD lubD_lub lubE lubE_lub.
  apply po_lub_unique
   with (S := fun x : d_set E =>
                exists y : d_set D,
                  G y /\ d_function_domain_lub_function D E F F_filter y = x).
  assumption.
  unfold po_least_upper_bound.
  split.
  (* upper bound *)
  unfold po_upper_bound.
  intros lub_fx lub_fx_prop.
  elim lub_fx_prop.
  intros x lub_fx_shape.
  destruct lub_fx_shape as (x_in_G, lub_f_ap_x_eq_lub_fx).
  rewrite <- lub_f_ap_x_eq_lub_fx.
  apply d_lub_prop.
  unfold po_upper_bound.
  intros f_ap_x f_ap_x_prop.
  elim f_ap_x_prop.
  intros f f_ap_x_shape.
  destruct f_ap_x_shape as (f_in_F, f_x_eq_f_ap_x).
  rewrite <- f_x_eq_f_ap_x.
  apply po_trans with (f $ lubD).
  assert (d_monotonic D E (proj1_sig f)) as f_monotonic.
    apply d_functional_monotonic.
  apply f_monotonic.
  apply lubD_lub.
  assumption.
  apply d_lub_prop.
  exists f.
  split.
  assumption.
  reflexivity.
  (* least *)
  intros z z_prop.
  apply d_lub_prop.
  unfold po_upper_bound.
  intros flubD flubD_prop.
  elim flubD_prop.
  intros f f_shape.
  destruct f_shape as (f_in_F, f_lubD_eq_flubD).
  rewrite <- f_lubD_eq_flubD.
  (* using the fact that f is continuous *)
  assert (d_continuous D E (proj1_sig f) (d_functional_monotonic D E f))
      as f_continuous.
    apply d_functional_continuous.
  unfold d_continuous in f_continuous.
  unfold d_function_ap.
  rewrite <- f_continuous
     with (F := G)
          (lubE := d_lub E
                     (proj1_sig f !! G)
                     (d_functional_preserves_filter D E f G G_filter)).
    (* (1) *)
    apply d_lub_prop.
      unfold po_upper_bound.
      intros fx fx_in_fG.
      unfold f_ap in fx_in_fG.
      elim fx_in_fG.
      intros x fx_shape.
      destruct fx_shape as (x_in_G, fx_eq_f_x).
      rewrite <- fx_eq_f_x.
      apply po_trans
       with (d_lub E
                   (fun y => exists f, F f /\ f $ x = y)
                   (d_function_domain_lub_function_filter D E F F_filter x)).
      (* trans1 *)
        apply d_lub_prop.
        exists f.
        split.
        assumption.
        unfold d_function_ap.
        reflexivity.
      (* trans2 *)
        apply z_prop.
        exists x.
        split.
        assumption.
        unfold d_function_domain_lub_function.
        reflexivity.
    (* (2) *)
    assumption.
    (* (3) *)
    assumption.
    (* (4) *)
    unfold f_ap.
    apply d_lub_prop.
Qed.

Definition d_function_domain_lub
             D E F (F_filter : po_filter (d_function_space_partial_order D E) F) :
             po_set (d_function_space_partial_order D E).
  exists (d_function_domain_lub_function D E F F_filter).
  exists (d_function_domain_lub_monotonic D E F F_filter).
  apply (d_function_domain_lub_continuous D E F F_filter).
Defined.

Definition d_function_domain_lub_prop
             D E F (F_filter : po_filter (d_function_space_partial_order D E) F) :
             po_least_upper_bound (d_function_space_partial_order D E)
                                  F (d_function_domain_lub D E F F_filter).
  unfold po_least_upper_bound.
  split.
  (* upper *)
    unfold po_upper_bound.
    intros f f_in_F.
    simpl.
    unfold d_function_le.
    intro.
    simpl.
    unfold d_function_domain_lub_function.
    apply d_lub_prop.
    exists f.
    split.
    assumption.
    reflexivity.
  (* least *)
    intros g g_upper_bound.
    simpl.
    unfold d_function_le.
    intro x.
    simpl.
    unfold d_function_domain_lub_function.
    apply d_lub_prop.
    unfold po_upper_bound.
    intro fx.
    intro fx_prop.
    elim fx_prop.
    intros f fx_shape.
    destruct fx_shape as (f_in_F, f_x_eq_fx).
    rewrite <- f_x_eq_fx.
    apply d_le_extensional.
    apply g_upper_bound.
    assumption.
Defined.

Definition d_function_domain (D E : domain) :=
  mk_domain
    (d_function_space_partial_order D E)
    (d_function_domain_bot D E)
    (d_function_domain_bot_prop D E)
    (d_function_domain_lub D E)
    (d_function_domain_lub_prop D E).


Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Import ListNotations.

Module AExp.

Inductive aexp : Type :=
| ANum: nat -> aexp
| APlus: aexp -> aexp -> aexp
| AMinus: aexp -> aexp -> aexp
| AMult: aexp -> aexp -> aexp.

Inductive bexp : Type :=
| BTrue : bexp
| BFalse : bexp
| BEq : aexp -> aexp -> bexp
| BLe : aexp -> aexp -> bexp
| BNot : bexp -> bexp
| BAnd : bexp -> bexp -> bexp.

Fixpoint aeval (a: aexp) : nat :=
  match a with
  | ANum n => n
  | APlus l r => (aeval l) + (aeval r)
  | AMinus l r => (aeval l) - (aeval r)
  | AMult l r => (aeval l) * (aeval r)
  end.

Fixpoint beval (b: bexp) : bool :=
  match b with
  | BTrue => true
  | BFalse => false
  | BEq l r => beq_nat (aeval l) (aeval r)
  | BLe l r => leb (aeval l) (aeval r)
  | BNot b' => negb (beval b')
  | BAnd l r => andb (beval l) (beval r)
  end.

Fixpoint optimize_0plus (a: aexp) : aexp :=
  match a with
  | ANum n => ANum n
  | APlus (ANum 0) r => (optimize_0plus r)
  | APlus l r => APlus (optimize_0plus l) (optimize_0plus r)
  | AMinus l r => AMinus (optimize_0plus l) (optimize_0plus r)
  | AMult l r => AMult (optimize_0plus l) (optimize_0plus r)
  end.

Fixpoint optimize_0plus_b (b : bexp) : bexp :=
  match b with
  | BEq l r => BEq (optimize_0plus l) (optimize_0plus r)
  | BLe l r => BLe (optimize_0plus l) (optimize_0plus r)
  | BNot b' => BNot (optimize_0plus_b b')
  | BAnd l r => BAnd (optimize_0plus_b l) (optimize_0plus_b r)
  | _ => b
  end.

Theorem optimize_0plus_sound: forall a,
  aeval (optimize_0plus a) = aeval a.
Proof.
  intros.
  induction a.
  - reflexivity.
  - destruct a1.
    + destruct n.
      * simpl. apply IHa2.
      * simpl. rewrite IHa2. reflexivity.
    + simpl. simpl in IHa1.
      rewrite IHa1. rewrite IHa2.
      reflexivity.
    + simpl. simpl in IHa1.
      rewrite IHa1. rewrite IHa2.
      reflexivity.
    + simpl. simpl in IHa1.
      rewrite IHa1. rewrite IHa2.
      reflexivity.
  - simpl.
    rewrite IHa1. rewrite IHa2.
    reflexivity.
  - simpl.
    rewrite IHa1. rewrite IHa2.
    reflexivity.
Qed.

Theorem optimize_0plus_b_sound : forall b,
  beval (optimize_0plus_b b) = beval b.
Proof.
  intros.
  induction b;
    try (simpl; reflexivity);
    try (simpl; repeat rewrite optimize_0plus_sound; reflexivity).
  - simpl. rewrite IHb. reflexivity.
  - simpl. rewrite IHb1. rewrite IHb2. reflexivity.
Qed.


From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=  Nil : lst |  Cons : natural -> lst -> lst.

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

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

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma qreva_rev : forall (x y : lst), qreva x y = append (rev x) y.
Proof.
   induction x.
   - reflexivity.
   - intros. simpl. rewrite IHx. rewrite append_assoc. simpl. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (qreva (qreva x y) Nil) (append (rev y) x).
Proof.
   induction x.
   - intros. simpl. rewrite qreva_rev. reflexivity.
   - intros. simpl. rewrite IHx. simpl. rewrite append_assoc. simpl. reflexivity.
Qed.


Set Implicit Arguments.

Section vectors.

Variable (A : Set).

Fixpoint vec (n : nat) : Set :=
  match n with
  | 0    => unit
  | S m  => (A*(vec m))%type
  end.

Definition vhead (n : nat)(v : vec (S n)) : A :=
  match v with
  |(a,w) => a
  end.

Definition vtail (n : nat)(v : vec (S n)) : vec n :=
  match v with
  |(a,w) => w
  end.

Fixpoint const_vec (n : nat) (a : A) : vec n :=
  match n with
    0   => tt
  | S m => (a,const_vec m a)
  end.

Inductive empty : Type := .

Definition emptyf : empty -> A.
  intro.
  destruct H.
Qed.

Fixpoint fin (n : nat) : Set :=
  match n with
    0   => empty
  | S n => (unit + fin n)%type
  end.

(*

Fixpoint rm_nth_vec (n : nat) : forall (m : nat), vec (n + S m) -> vec (n + m) :=
  match n as n return (forall m : nat, vec (n + S m) -> vec (n + m)) with
    0   => vtail
  | S n => fun m v => ((vhead v),(rm_nth_vec n m (vtail v)))
  end.

*)

Fixpoint item_at (n : nat) : fin n -> vec n -> A :=
  match n as n return fin n -> vec n -> A with
  |0   => fun i v => emptyf i
  |S m => fun i v => match i with
                     |inl tt => vhead v
                     |inr j  => item_at m j (vtail v)
                     end
  end.

Lemma vec_ext : forall (n : nat)(v w : vec n),
  (forall i : fin n, item_at n i v = item_at n i w) -> v = w.
Proof.
  induction n.
  intros.
  destruct v,w; reflexivity.
  intros.
  destruct v as [b v'], w as [c w'].
  assert (b = c).
  transitivity (item_at (S n) (inl tt) (b,v')).
  simpl; reflexivity.
  rewrite H.
  simpl; reflexivity.
  assert (v' = w').
  apply IHn.
  intro i.
  transitivity (item_at (S n) (inr i) (b , v')).
  simpl; reflexivity.
  rewrite H.
  simpl; reflexivity.
  rewrite H0, H1; reflexivity.
Qed.

Lemma const_vec_constant : forall (n : nat)(i : fin n)(a : A),
  item_at n i (const_vec n a) = a.
Proof.
  intros.
  induction n.
  destruct i.
  destruct i.
  destruct u.
  simpl; reflexivity.
  apply IHn.
Qed.

End vectors.

(* Notation borrowed from Coq.Lists.List *)

Notation " [ ] " := (tt : vec 0).
Notation " [ x ] " := ((x,tt) : vec 1).
Notation " [ x , .. , y ] " := (pair x .. (pair y tt) ..).

Fixpoint vec_ap (A B : Set) (n : nat) : vec (A -> B) n -> A -> vec B n :=
  match n as n return vec (A -> B) n -> A -> vec B n with
    0   => fun _ _ => (tt : vec B 0)
  | S m => fun fs a => ( ((vhead fs) a) , (vec_ap B m (vtail fs) a) )
  end.

Lemma vec_ap_lemma : forall (A B : Set)(n : nat)(i : fin n)(fs : vec (A -> B) n)(a : A),
  item_at B n i (vec_ap B n fs a) = (item_at (A -> B) n i fs) a.
Proof.
  intros A B.
  induction n.
  intro i; destruct i.
  intros.
  destruct fs as [f1 fs'].
  destruct i.
  destruct u.
  simpl.
  reflexivity.
  simpl.
  apply IHn.
Qed.

Lemma vec_ap_vtail_comm : forall (A B : Set)(n : nat)(fs : vec (A -> B) (S n))(a : A),
  vec_ap B n (vtail fs) a = vtail (vec_ap B (S n) fs a).
Proof.
  intros.
  auto.
Qed.

Fixpoint to_vec(n : nat)(A : Set) : (fin n -> A) -> vec A n :=
  match n as n return (fin n -> A) -> vec A n with
  |0     => fun f => (tt : vec A 0)
  |(S m) => fun f => ( f (inl tt) , to_vec m (fun j => f (inr j)) )
  end.

Lemma to_vec_correct : forall (n : nat)(A : Set)(f : fin n -> A)(i : fin n),
   item_at A n i (to_vec n f) = f i.
Proof.
  intro n.
  induction n.
  intros.
  destruct i.
  intros.
  destruct i.
  destruct u.
  simpl.
  reflexivity.
  simpl.
  rewrite IHn.
  reflexivity.
Qed.


Module Ex2_7.

Require Import Arith.

(* Problem 6 *)

Goal forall x y, x < y -> x + 10 < y + 10.
Proof.
  intros.
  SearchAbout (_ + _ < _ + _).
  apply plus_lt_compat_r.
  apply H.
Qed.

(* Problem 7 *)
Goal forall P Q : nat -> Prop, P 0 -> (forall x, P x -> Q x) -> Q 0.
Proof.
  intros.
  apply (H0 0).
  apply H.
Qed.

Goal forall P : nat -> Prop, P 2 -> (exists y, P (1 + y)).
Proof.
  intros.
  exists 1.
  apply H.
Qed.

Goal forall P : nat -> Prop, (forall n m, P n -> P m) -> (exists p, P p) -> forall q, P q.
Proof.
  intros.
  destruct H0.
  apply (H x q).
  apply H0.
Qed.

End Ex2_7.

Module Ex2_8.
Require Import Arith.

Goal forall m n : nat, (n * 10) + m = (10 * n) + m.
Proof.
  intros.
  apply NPeano.Nat.add_cancel_r.
  apply mult_comm.
Qed.

End Ex2_8.

Module Ex2_9.

Require Import Arith.

Goal forall n m p q : nat, (n + m) + (p + q) = (n + p) + (m + q).
Proof.
  intros.
  SearchAbout (_+(_+_)).
  rewrite plus_assoc.
  rewrite plus_assoc.
  SearchAbout (_+_=_+_).
  apply NPeano.Nat.add_cancel_r.
  rewrite <- plus_assoc.
  rewrite <- plus_assoc.
  apply NPeano.Nat.add_cancel_l.
  apply plus_comm.
Qed.

Goal forall n m : nat, (n + m) * (n + m) = n * n + m * m + 2 * n * m.
Proof.
  intros.
  SearchAbout ((_+_)*_).
  rewrite NPeano.Nat.mul_add_distr_r.
  rewrite NPeano.Nat.mul_add_distr_l.
  rewrite NPeano.Nat.mul_add_distr_l.
  rewrite <- plus_assoc.
  rewrite <- plus_assoc.
  apply NPeano.Nat.add_cancel_l.
  rewrite plus_assoc.
  rewrite plus_comm.
  apply NPeano.Nat.add_cancel_l.
  simpl.
  SearchAbout (_ + 0).
  rewrite plus_0_r.
  rewrite mult_comm.
  rewrite mult_comm.
  SearchAbout ((_+_)*_).
  rewrite mult_plus_distr_r.
  reflexivity.
Qed.

End Ex2_9.


(** * Prop: Propositions and Evidence *)

Require Export MoreCoq.

(** In previous chapters, we have seen many examples of factual
    claims (_propositions_) and ways of presenting evidence of their
    truth (_proofs_).  In particular, we have worked extensively with
    _equality propositions_ of the form [e1 = e2], with
    implications ([P -> Q]), and with quantified propositions
    ([forall x, P]).

    This chapter will take us on a first tour of the
    propositional (logical) side of Coq.
    In particular, we will expand our repertoire of primitive
    propositions to include _user-defined_ propositions, not just
    equality propositions (which are more-or-less "built in" to Coq).
*)

(* ##################################################### *)
(** * Inductively Defined Propositions *)

(**  As a running example, let's
    define a simple property of natural numbers -- we'll call it
    "[beautiful]." *)

(** Informally, a number is [beautiful] if it is [0], [3], [5], or the
    sum of two [beautiful] numbers.

    More pedantically, we can define [beautiful] numbers by giving four
    rules:

       - Rule [b_0]: The number [0] is [beautiful].
       - Rule [b_3]: The number [3] is [beautiful].
       - Rule [b_5]: The number [5] is [beautiful].
       - Rule [b_sum]: If [n] and [m] are both [beautiful], then so is
         their sum. *)

(** We will see many definitions like this one during the rest
    of the course, and for purposes of informal discussions, it is
    helpful to have a lightweight notation that makes them easy to
    read and write.  _Inference rules_ are one such notation: *)
(**
                              -----------                               (b_0)
                              beautiful 0

                              ------------                              (b_3)
                              beautiful 3

                              ------------                              (b_5)
                              beautiful 5

                       beautiful n     beautiful m
                       ---------------------------                      (b_sum)
                              beautiful (n+m)
*)

(** Each of the textual rules above is reformatted here as an
    inference rule; the intended reading is that, if the _premises_
    above the line all hold, then the _conclusion_ below the line
    follows.  For example, the rule [b_sum] says that, if [n] and [m]
    are both [beautiful] numbers, then it follows that [n+m] is
    [beautiful] too.  If a rule has no premises above the line, then
    its conclusion hold unconditionally.

    These rules _define_ the property [beautiful].  That is, if we
    want to convince someone that some particular number is [beautiful],
    our argument must be based on these rules.  For a simple example,
    suppose we claim that the number [5] is [beautiful].  To support
    this claim, we just need to point out that rule [b_5] says so.
    Or, if we want to claim that [8] is [beautiful], we can support our
    claim by first observing that [3] and [5] are both [beautiful] (by
    rules [b_3] and [b_5]) and then pointing out that their sum, [8],
    is therefore [beautiful] by rule [b_sum].  This argument can be
    expressed graphically with the following _proof tree_: *)
(**
         ----------- (b_3)   ----------- (b_5)
         beautiful 3         beautiful 5
         ------------------------------- (b_sum)
                   beautiful 8
    Of course, there are other ways of using these rules to argue that
    [8] is [beautiful], for instance:
         ----------- (b_5)   ----------- (b_3)
         beautiful 5         beautiful 3
         ------------------------------- (b_sum)
                   beautiful 8
*)

(** **** Exercise: 1 star (varieties_of_beauty) *)
(** How many different ways are there to show that [8] is [beautiful]? *)

(* there are infinite number of different ways of showing that [8] is [beautiful].

   Because [0] is beautiful, and we can insert the proof tree:

                ----------- (b_0)
                 beautiful 0

   into any existing proof tree of beautiful by changing one of the subtree:

               pred X
            -------------- (rule X)
              beautiful X

   into:

           pred X
        -------------- (rule X)  ------------ (b_0)
          beautiful X            beautiful 0
        -------------------------------------------- (b_sum)
                        beautiful X

   Therefore the proofs for [beautiful 8] can be infinite.
*)
(** [] *)

(** In Coq, we can express the definition of [beautiful] as
    follows: *)

Inductive beautiful : nat -> Prop :=
  b_0   : beautiful 0
| b_3   : beautiful 3
| b_5   : beautiful 5
| b_sum : forall n m, beautiful n -> beautiful m -> beautiful (n+m).

(** The first line declares that [beautiful] is a proposition -- or,
    more formally, a family of propositions "indexed by" natural
    numbers.  (That is, for each number [n], the claim that "[n] is
    [beautiful]" is a proposition.)  Such a family of propositions is
    often called a _property_ of numbers.  Each of the remaining lines
    embodies one of the rules for [beautiful] numbers.

    The rules introduced this way have the same status as proven
    theorems; that is, they are true axiomatically.
    So we can use Coq's [apply] tactic with the rule names to prove
    that particular numbers are [beautiful].  *)

Theorem three_is_beautiful: beautiful 3.
Proof.
   (* This simply follows from the rule [b_3]. *)
   apply b_3.
Qed.

Theorem eight_is_beautiful: beautiful 8.
Proof.
   (* First we use the rule [b_sum], telling Coq how to
      instantiate [n] and [m]. *)
   apply b_sum with (n:=3) (m:=5).
   (* To solve the subgoals generated by [b_sum], we must provide
      evidence of [beautiful 3] and [beautiful 5]. Fortunately we
      have rules for both. *)
   apply b_3.
   apply b_5.
Qed.

(** As you would expect, we can also prove theorems that have
hypotheses about [beautiful]. *)

Theorem beautiful_plus_eight: forall n, beautiful n -> beautiful (8+n).
Proof.
  intros n B.
  apply b_sum with (n:=8) (m:=n).
  apply eight_is_beautiful.
  apply B.
Qed.

(** **** Exercise: 2 stars (b_timesm) *)
Theorem b_timesm: forall n m, beautiful n -> beautiful (m*n).
Proof.
  intros n m B. induction m as [|m'].
  Case "m = 0". apply b_0.
  Case "m = S m'". assert (S m' * n = n + m' * n). reflexivity.
    rewrite H. apply b_sum with (n:=n) (m:=m'*n).
    apply B. apply IHm'.
Qed.
(** [] *)

(* ####################################################### *)
(** ** Induction Over Evidence *)

(** Besides _constructing_ evidence that numbers are beautiful, we can
    also _reason about_ such evidence. *)

(** The fact that we introduced [beautiful] with an [Inductive]
    declaration tells Coq not only that the constructors [b_0], [b_3],
    [b_5] and [b_sum] are ways to build evidence, but also that these
    two constructors are the _only_ ways to build evidence that
    numbers are beautiful. *)

(** In other words, if someone gives us evidence [E] for the assertion
    [beautiful n], then we know that [E] must have one of four shapes:

      - [E] is [b_0] (and [n] is [O]),
      - [E] is [b_3] (and [n] is [3]),
      - [E] is [b_5] (and [n] is [5]), or
      - [E] is [b_sum n1 n2 E1 E2] (and [n] is [n1+n2], where [E1] is
        evidence that [n1] is beautiful and [E2] is evidence that [n2]
        is beautiful). *)

(** This permits us to _analyze_ any hypothesis of the form [beautiful
    n] to see how it was constructed, using the tactics we already
    know.  In particular, we can use the [induction] tactic that we
    have already seen for reasoning about inductively defined _data_
    to reason about inductively defined _evidence_.

    To illustrate this, let's define another property of numbers: *)

Inductive gorgeous : nat -> Prop :=
  g_0 : gorgeous 0
| g_plus3 : forall n, gorgeous n -> gorgeous (3+n)
| g_plus5 : forall n, gorgeous n -> gorgeous (5+n).

(** **** Exercise: 1 star (gorgeous_tree) *)
(** Write out the definition of [gorgeous] numbers using inference rule
    notation.

  ---------- (g_0)
  gorgeous 0

  forall n. gorgeous n
  -------------------- (g_plus3)
  gorgeous (3+n)

  forall n. gorgeous n
  -------------------- (g_plus5)
  gorgeous (5+n)

[]
*)

(** **** Exercise: 1 star (gorgeous_plus13) *)
Theorem gorgeous_plus13: forall n,
  gorgeous n -> gorgeous (13+n).
Proof.
  intros n G. assert (13 + n = 3 + (5 + (5 + n))). reflexivity.
  rewrite H. apply g_plus3. apply g_plus5. apply g_plus5.
  apply G.
Qed.
(** [] *)

(** It seems intuitively obvious that, although [gorgeous] and
    [beautiful] are presented using slightly different rules, they are
    actually the same property in the sense that they are true of the
    same numbers.  Indeed, we can prove this. *)

Theorem gorgeous__beautiful : forall n,
  gorgeous n -> beautiful n.
Proof.
   intros n H.
   induction H as [|n'|n'].
   Case "g_0".
       apply b_0.
   Case "g_plus3".
       apply b_sum. apply b_3.
       apply IHgorgeous.
   Case "g_plus5".
       apply b_sum. apply b_5. apply IHgorgeous.
Qed.

(** Notice that the argument proceeds by induction on the _evidence_ [H]! *)

(** Let's see what happens if we try to prove this by induction on [n]
   instead of induction on the evidence [H]. *)

Theorem gorgeous__beautiful_FAILED : forall n,
  gorgeous n -> beautiful n.
Proof.
   intros. induction n as [| n'].
   Case "n = 0". apply b_0.
   Case "n = S n'". (* We are stuck! *)
Abort.

(** The problem here is that doing induction on [n] doesn't yield a
    useful induction hypothesis. Knowing how the property we are
    interested in behaves on the predecessor of [n] doesn't help us
    prove that it holds for [n]. Instead, we would like to be able to
    have induction hypotheses that mention other numbers, such as [n -
    3] and [n - 5]. This is given precisely by the shape of the
    constructors for [gorgeous]. *)

(** **** Exercise: 2 stars (gorgeous_sum) *)
Theorem gorgeous_sum : forall n m,
  gorgeous n -> gorgeous m -> gorgeous (n + m).
Proof.
  intros n m Hn Hm. induction Hn as [|n'|n'].
  Case "g_0". apply Hm.
  Case "g_plus3". apply g_plus3. apply IHHn.
  Case "g_plus5". apply g_plus5. apply IHHn.
Qed.
(** [] *)

(** **** Exercise: 3 stars, advanced (beautiful__gorgeous) *)
Theorem beautiful__gorgeous : forall n, beautiful n -> gorgeous n.
Proof.
  intros n Bn. induction Bn as [ | | |n' m'].
  Case "b_0". apply g_0.
  Case "b_3". apply g_plus3. apply g_0.
  Case "b_5". apply g_plus5. apply g_0.
  Case "b_sum". apply gorgeous_sum.
    apply IHBn1. apply IHBn2.
Qed.
(** [] *)

(** **** Exercise: 3 stars, optional (g_times2) *)
(** Prove the [g_times2] theorem below without using [gorgeous__beautiful].
    You might find the following helper lemma useful. *)

Lemma helper_g_times2 : forall x y z, x + (z + y)= z + x + y.
Proof.
  intros x y z. rewrite plus_assoc.
  assert (x + z = z + x). apply plus_comm. rewrite H.
  reflexivity.
Qed.

Theorem g_times2: forall n, gorgeous n -> gorgeous (2*n).
Proof.
   intros n H. simpl.
   induction H.
   Case "g_0". apply g_0.
   Case "g_plus3".
     assert (gorgeous (3+n)) as H3n. apply g_plus3. apply H.
     apply gorgeous_sum with (n:=3+n).
     apply H3n. apply gorgeous_sum with (n:=3+n). apply H3n. apply g_0.
   Case "g_plus5".
     assert (gorgeous (5+n)) as H5n. apply g_plus5. apply H.
     apply gorgeous_sum with (n:=5+n).
     apply H5n. apply gorgeous_sum with (n:=5+n). apply H5n. apply g_0.
Qed.
(** [] *)

(* ####################################################### *)
(** ** From Boolean Functions to Propositions *)

(** In chapter [Basics] we defined a _function_ [evenb] that tests a
    number for evenness, yielding [true] if so.  We can use this
    function to define the _proposition_ that some number [n] is
    even: *)

Definition even (n:nat) : Prop :=
  evenb n = true.

(** That is, we can define "[n] is even" to mean "the function [evenb]
    returns [true] when applied to [n]."

    Note that here we have given a name
    to a proposition using a [Definition], just as we have
    given names to expressions of other sorts. This isn't a fundamentally
    new kind of proposition;  it is still just an equality. *)

(** Another alternative is to define the concept of evenness
    directly.  Instead of going via the [evenb] function ("a number is
    even if a certain computation yields [true]"), we can say what the
    concept of evenness means by giving two different ways of
    presenting _evidence_ that a number is even. *)

Inductive ev : nat -> Prop :=
  | ev_0 : ev O
  | ev_SS : forall n:nat, ev n -> ev (S (S n)).

(** This definition says that there are two ways to give
    evidence that a number [m] is even.  First, [0] is even, and
    [ev_0] is evidence for this.  Second, if [m = S (S n)] for some
    [n] and we can give evidence [e] that [n] is even, then [m] is
    also even, and [ev_SS n e] is the evidence. *)

(** **** Exercise: 1 star (double_even) *)

Theorem double_even : forall n,
  ev (double n).
Proof.
  intros n. induction n as [|n'].
  Case "n = 0". simpl. apply ev_0.
  Case "n = S n'". simpl. apply ev_SS. apply IHn'.
Qed.
(** [] *)

(** *** Discussion: Computational vs. Inductive Definitions *)

(** We have seen that the proposition "[n] is even" can be
    phrased in two different ways -- indirectly, via a boolean testing
    function [evenb], or directly, by inductively describing what
    constitutes evidence for evenness.  These two ways of defining
    evenness are about equally easy to state and work with.  Which we
    choose is basically a question of taste.

    However, for many other properties of interest, the direct
    inductive definition is preferable, since writing a testing
    function may be awkward or even impossible.

    One such property is [beautiful].  This is a perfectly sensible
    definition of a set of numbers, but we cannot translate its
    definition directly into a Coq Fixpoint (or into a recursive
    function in any other common programming language).  We might be
    able to find a clever way of testing this property using a
    [Fixpoint] (indeed, it is not too hard to find one in this case),
    but in general this could require arbitrarily deep thinking.  In
    fact, if the property we are interested in is uncomputable, then
    we cannot define it as a [Fixpoint] no matter how hard we try,
    because Coq requires that all [Fixpoint]s correspond to
    terminating computations.

    On the other hand, writing an inductive definition of what it
    means to give evidence for the property [beautiful] is
    straightforward. *)

(** **** Exercise: 1 star (ev__even) *)
(** Here is a proof that the inductive definition of evenness implies
    the computational one. *)

Theorem ev__even : forall n,
  ev n -> even n.
Proof.
  intros n E. induction E as [| n' E'].
  Case "E = ev_0".
    unfold even. reflexivity.
  Case "E = ev_SS n' E'".
    unfold even. apply IHE'.
Qed.

(** Could this proof also be carried out by induction on [n] instead
    of [E]?  If not, why not? *)
(* cannot proof by induction on [n]. As mentioned before that
   inductive definition does not construct [n]s which can be computed.
*)
(** [] *)

(** The induction principle for inductively defined propositions does
    not follow quite the same form as that of inductively defined
    sets.  For now, you can take the intuitive view that induction on
    evidence [ev n] is similar to induction on [n], but restricts our
    attention to only those numbers for which evidence [ev n] could be
    generated.  We'll look at the induction principle of [ev] in more
    depth below, to explain what's really going on. *)

(** **** Exercise: 1 star (l_fails) *)
(** The following proof attempt will not succeed.
     Theorem l : forall n,
       ev n.
     Proof.
       intros n. induction n.
         Case "O". simpl. apply ev_0.
         Case "S".
           ...
   Intuitively, we expect the proof to fail because not every
   number is even. However, what exactly causes the proof to fail?

   In order to prove [ev n], either [n = 0] or
   there's a prove for [ev n'] where [n = S (S n')].
   and the inductive hypothesis is not useful in this case.
*)
(** [] *)

(** **** Exercise: 2 stars (ev_sum) *)
(** Here's another exercise requiring induction. *)

Theorem ev_sum : forall n m,
   ev n -> ev m -> ev (n+m).
Proof.
  intros n m En Em. induction En as [|n' En'].
  Case "ev_0". simpl. apply Em.
  Case "ev_SS n' En'". simpl. apply ev_SS. apply IHEn'.
Qed.
(** [] *)

(* ####################################################### *)
(** ** [Inversion] on Evidence *)

(** Another situation where we want to analyze evidence for evenness
    is when proving that, if [n] is even, then [pred (pred n))] is
    too.  In this case, we don't need to do an inductive proof.  The
    right tactic turns out to be [inversion].  *)

Theorem ev_minus2: forall n,
  ev n -> ev (pred (pred n)).
Proof.
  intros n E.
  inversion E as [| n' E'].
  Case "E = ev_0". simpl. apply ev_0.
  Case "E = ev_SS n' E'". simpl. apply E'.  Qed.
(* p.s. it turns out "inversion" can be used here and nothing will be changed
   so this example might be a little bit confusing...
*)

(** **** Exercise: 1 star, optional (ev_minus2_n) *)
(** What happens if we try to use [destruct] on [n] instead of [inversion] on [E]? *)

(* works when [n = 0]. but will have no clue to proceed
   when workings with [n = S n'].
*)
(** [] *)

(** Another example, in which [inversion] helps narrow down to
the relevant cases. *)

Theorem SSev__even : forall n,
  ev (S (S n)) -> ev n.
Proof.
  intros n E.
  inversion E as [| n' E'].
  apply E'. Qed.

(** These uses of [inversion] may seem a bit mysterious at first.
    Until now, we've only used [inversion] on equality
    propositions, to utilize injectivity of constructors or to
    discriminate between different constructors.  But we see here
    that [inversion] can also be applied to analyzing evidence
    for inductively defined propositions.

    (You might also expect that [destruct] would be a more suitable
    tactic to use here. Indeed, it is possible to use [destruct], but
    it often throws away useful information, and the [eqn:] qualifier
    doesn't help much in this case.)

    Here's how [inversion] works in general.  Suppose the name
    [I] refers to an assumption [P] in the current context, where
    [P] has been defined by an [Inductive] declaration.  Then,
    for each of the constructors of [P], [inversion I] generates
    a subgoal in which [I] has been replaced by the exact,
    specific conditions under which this constructor could have
    been used to prove [P].  Some of these subgoals will be
    self-contradictory; [inversion] throws these away.  The ones
    that are left represent the cases that must be proved to
    establish the original goal.

    In this particular case, the [inversion] analyzed the construction
    [ev (S (S n))], determined that this could only have been
    constructed using [ev_SS], and generated a new subgoal with the
    arguments of that constructor as new hypotheses.  (It also
    produced an auxiliary equality, which happens to be useless here.)
    We'll begin exploring this more general behavior of inversion in
    what follows. *)

(** **** Exercise: 1 star (inversion_practice) *)
Theorem SSSSev__even : forall n,
  ev (S (S (S (S n)))) -> ev n.
Proof.
  intros n E. inversion E as [| n' E'].
  apply SSev__even. apply E'.
Qed.
(** The [inversion] tactic can also be used to derive goals by showing
    the absurdity of a hypothesis. *)

Theorem even5_nonsense :
  ev 5 -> 2 + 2 = 9.
Proof.
  intros E. inversion E. inversion H0. inversion H2.
Qed.
(** [] *)

(** **** Exercise: 3 stars, advanced (ev_ev__ev) *)
(** Finding the appropriate thing to do induction on is a
    bit tricky here: *)

Theorem ev_ev__ev : forall n m,
  ev (n+m) -> ev n -> ev m.
Proof.
  intros n m E En. induction En as [|n' En'].
  Case "ev_0". simpl in E. apply E.
  Case "ev_SS n' En'". apply IHEn'.
    simpl in E. inversion E. apply H0.
Qed.
(** [] *)

(** **** Exercise: 3 stars, optional (ev_plus_plus) *)
(** Here's an exercise that just requires applying existing lemmas.  No
    induction or even case analysis is needed, but some of the rewriting
    may be tedious. *)

Theorem ev_plus_plus : forall n m p,
  ev (n+m) -> ev (n+p) -> ev (m+p).
Proof.
  intros n m p Enm Enp.
  apply ev_ev__ev with (n:=(n+m)).
  rewrite plus_assoc. rewrite <- (plus_assoc n m m).
  rewrite (plus_comm n (m+m)). rewrite <- (plus_assoc (m+m) n p).
  apply ev_sum. rewrite <- double_plus. apply double_even.
  apply Enp. apply Enm.
Qed.
(** [] *)

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

(** **** Exercise: 4 stars (palindromes) *)
(** A palindrome is a sequence that reads the same backwards as
    forwards.

    - Define an inductive proposition [pal] on [list X] that
      captures what it means to be a palindrome. (Hint: You'll need
      three cases.  Your definition should be based on the structure
      of the list; just having a single constructor
    c : forall l, l = rev l -> pal l
      may seem obvious, but will not work very well.)

    - Prove that
       forall l, pal (l ++ rev l).
    - Prove that
       forall l, pal l -> l = rev l.
*)

Inductive pal {X:Type} : list X -> Prop :=
  | pal_nil : pal []
  | pal_single : forall x:X, pal [x]
  | pal_lr : forall (x:X) (sub : list X), pal sub -> pal (x :: snoc sub x).

Theorem pal_concat_id_rev : forall {X : Type} (l : list X),
  pal (l ++ rev l).
Proof.
  intros X l. induction l.
  Case "l = nil". simpl. apply pal_nil.
  Case "l = x:l'". simpl. rewrite <- snoc_with_append. apply pal_lr.
  apply IHl.
Qed.

Theorem pal_id_is_rev : forall {X : Type} (l : list X),
  pal l -> l = rev l.
Proof.
  intros X l H. induction H. reflexivity. reflexivity.
  simpl. rewrite rev_snoc. simpl. rewrite <- IHpal. reflexivity.
Qed.

(** **** Exercise: 5 stars, optional (palindrome_converse) *)
(** Using your definition of [pal] from the previous exercise, prove
    that
     forall l, l = rev l -> pal l.
*)

Fixpoint list_head {X : Type} (l : list X) : option X :=
  match l with
  | [] => None
  | h :: t => Some h
  end.

Definition list_last {X : Type} (l : list X) : option X :=
  list_head (rev l).

Theorem palindrome_head_last : forall (X : Type) (l : list X),
  l = rev l -> list_head l = list_last l.
Proof.
  intros X l Hl. unfold list_last. rewrite <- Hl. reflexivity.
Qed.

Fixpoint list_tail {X : Type} (l : list X) : option (list X) :=
  match l with
  | [] => None
  | h :: t => Some t
  end.

Definition list_init {X : Type} (l : list X) : option (list X) :=
  match list_tail (rev l) with
  | None => None
  | Some l' => Some (rev l')
  end.

Lemma palindrome_rev_hd_lt : forall {X : Type} (l : list X),
  l = rev l -> list_head l = list_last l.
Proof.
  intros X l Hri. induction l. reflexivity.
  simpl. unfold list_last. rewrite Hri. rewrite rev_involutive. reflexivity.
Qed.

Lemma pal_aux :
  forall (X:Type) (l : list X) (x : X),
    (l = rev l -> pal l) -> l = rev l -> pal (x :: snoc l x).
Proof.
  intros X l x Hrev HInd. apply pal_lr. apply Hrev. apply HInd.
Qed.

(*
Inductive tril (X : Type) : Type :=
  | tril_nil : tril X
  | tril_single : X -> tril X
  | tril_sub : X -> tril X -> X -> tril X.

Fixpoint tril_to_list (X : Type) (l : list X) : tril X :=
  match l with
    | [] => tril_nil X
    | (h::t) =>
      match t with
        | [] => tril_single X h
        | t2 => match list_init t2 with
                  | None => tril_nil X
                  | Some sub => match list_last t2 with
                                 | None => tril_nil
                                 | Some y => tril_sub X (tril_to_list X sub) y
                                end
                end
      end
  end.
 *)

Theorem palindrome_converse : forall (X : Type) (l : list X),
  l = rev l -> pal l.
Proof.
  intros X l eq1. induction l.
Abort.
(** [] *)

(** **** Exercise: 4 stars, advanced (subsequence) *)
(** A list is a _subsequence_ of another list if all of the elements
    in the first list occur in the same order in the second list,
    possibly with some extra elements in between. For example,
    [1,2,3]
    is a subsequence of each of the lists
    [1,2,3]
    [1,1,1,2,2,3]
    [1,2,7,3]
    [5,6,1,9,9,2,7,3,8]
    but it is _not_ a subsequence of any of the lists
    [1,2]
    [1,3]
    [5,6,2,1,7,3,8]

    - Define an inductive proposition [subseq] on [list nat] that
      captures what it means to be a subsequence. (Hint: You'll need
      three cases.)

    - Prove that subsequence is reflexive, that is, any list is a
      subsequence of itself.

    - Prove that for any lists [l1], [l2], and [l3], if [l1] is a
      subsequence of [l2], then [l1] is also a subsequence of [l2 ++
      l3].

    - (Optional, harder) Prove that subsequence is transitive -- that
      is, if [l1] is a subsequence of [l2] and [l2] is a subsequence
      of [l3], then [l1] is a subsequence of [l3].  Hint: choose your
      induction carefully!
 *)
Inductive subseq : list nat -> list nat -> Prop :=
  subseq_nil_any : forall ys, subseq nil ys
| subseq_h1_h2 : forall xs ys a, subseq xs ys -> subseq (a::xs) (a::ys)
| subseq_h1_any : forall xs ys a, subseq xs ys -> subseq xs (a::ys).

Theorem subseq_reflexive :
  forall xs,
    subseq xs xs.
Proof.
  intros xs. induction xs.
  Case "nil nil". apply subseq_nil_any.
  Case "h1 h2". apply subseq_h1_h2. apply IHxs.
Qed.

(*
Lemma cons_list_app_rev:
  forall (X : Type) (a : X) (xs : list X),
    a :: (rev xs) = [a] ++ (rev xs).
Proof.
  intros. induction xs.
  reflexivity. simpl. rewrite <- rev_cons. reflexivity.
Qed.

Lemma cons_list_app:
  forall (X : Type) (a : X) (xs : list X),
    a :: xs = [a] ++ xs.
Proof.
  intros. assert (xs = (rev (rev xs))). rewrite rev_involutive. reflexivity.
  rewrite H. apply cons_list_app_rev.
Qed.

Lemma cons_app:
  forall (X : Type) (a : X) (xs ys : list X),
    (a :: xs) ++ ys = a :: xs ++ ys.
Proof.
  intros. apply cons_list_app.
Qed.

Theorem subseq_append_one :
  forall l1 l2 a,
    subseq l1 l2 -> subseq l1 (l2 ++ [a]).
Proof.
  intros. induction H. apply subseq_nil_any.
  rewrite cons_app. apply subseq_h1_h2. apply IHsubseq.
  apply subseq_h1_any. apply IHsubseq.
Qed.*)

Theorem subseq_append:
  forall l1 l2 l3,
    subseq l1 l2 -> subseq l1 (l2 ++ l3).
Proof.
  intros l1 l2 l3 H1. induction H1.
  Case "nil any". apply subseq_nil_any.
  Case "h1 h2". apply subseq_h1_h2. apply IHsubseq.
  Case "h1 any". apply subseq_h1_any. apply IHsubseq.
Qed.
(** [] *)

Theorem subseq_transitive:
  forall l1 l2 l3,
    subseq l1 l2 -> subseq l2 l3 -> subseq l1 l3.
Proof.
  intros l1 l2 l3.
Abort.

(** **** Exercise: 2 stars, optional (R_provability) *)
(** Suppose we give Coq the following definition:
    Inductive R : nat -> list nat -> Prop :=
      | c1 : R 0 []
      | c2 : forall n l, R n l -> R (S n) (n :: l)
      | c3 : forall n l, R (S n) l -> R n l.
    Which of the following propositions are provable?

    - [R 2 [1,0]]
    - [R 1 [1,2,1,0]]
    - [R 6 [3,2,1,0]]
*)
Inductive R : nat -> list nat -> Prop :=
  | c1 : R 0 []
  | c2 : forall n l, R n l -> R (S n) (n :: l)
  | c3 : forall n l, R (S n) l -> R n l.

Theorem r_provable1: R 2 [1;0].
Proof. apply c2,c2,c1. Qed.

Theorem r_provable2: R 1 [1;2;1;0].
Proof. apply c3,c2,c3,c3,c2,r_provable1. Qed.

(* the third one is not provable. since whenever "n" increases,
   the list gets longer, therefore "n" is less or equal to the list length.
 *)
Theorem r_n_le_len:
  forall n l,
    R n l -> n <= length l.
Proof.
  intros. induction H. reflexivity.
  simpl. apply Le.le_n_S. apply IHR.
  apply Le.le_Sn_le. apply IHR.
Qed.
(** [] *)

(* $Date: 2013-07-01 18:48:47 -0400 (Mon, 01 Jul 2013) $ *)


Require Export Unions.

Definition FamUnion (X : set) (F : set → set) : set := Union (Repl F X).

Lemma FamUnion_I : ∀ X F x y, x ∈ X → y ∈ (F x) → y ∈ (FamUnion X F).
Proof.
  intros. compute.
  apply Union_I with (Y := F x). auto.
  apply Repl_I. auto.
Qed.

Hint Resolve FamUnion_I.

Lemma FamUnion_E : ∀ X F y, y ∈ (FamUnion X F) → ∃ x, x ∈ X ∧ y ∈ (F x ).
Proof.
  intros. compute in H.
  apply Union_E in H. destruct H. inv H.
  apply Repl_E in H1. destruct H1. inv H.
  exists x0. split; auto.
Qed.

Hint Resolve FamUnion_E.

(* Properties of the union over families of indexed sets.

   1. ∪ x∈∅ Fx = ∅
   2. (∀x ∈ X, Fx ∈ 2) −→ (∃x ∈ X, Fx = 1) −→ ∪ x∈X Fx = 1
   3. inhset X −→ (∀x ∈ X, Fx = C) −→ ∪ x∈X Fx = C
   4. (∀x ∈ X, Fx = ∅) −→ ∪ x∈X Fx = ∅
   5. (∀x ∈ X, Fx ∈ 2) −→ ∪ x∈X Fx ∈ 2
*)


(** * Rel: Properties of Relations *)

(** This short (and optional) chapter develops some basic definitions
    and a few theorems about binary relations in Coq.  The key
    definitions are repeated where they are actually used (in the
    \CHAPV2{Smallstep} chapter of _Programming Language Foundations_),
    so readers who are already comfortable with these ideas can safely
    skim or skip this chapter.  However, relations are also a good
    source of exercises for developing facility with Coq's basic
    reasoning facilities, so it may be useful to look at this material
    just after the [IndProp] chapter. *)

Set Warnings "-notation-overridden,-parsing".
Require Export IndProp.

(* ################################################################# *)
(** * Relations *)

(** A binary _relation_ on a set [X] is a family of propositions
    parameterized by two elements of [X] -- i.e., a proposition about
    pairs of elements of [X].  *)

Definition relation (X: Type) := X -> X -> Prop.

(** Confusingly, the Coq standard library hijacks the generic term
    "relation" for this specific instance of the idea. To maintain
    consistency with the library, we will do the same.  So, henceforth
    the Coq identifier [relation] will always refer to a binary
    relation between some set and itself, whereas the English word
    "relation" can refer either to the specific Coq concept or the
    more general concept of a relation between any number of possibly
    different sets.  The context of the discussion should always make
    clear which is meant. *)

(** An example relation on [nat] is [le], the less-than-or-equal-to
    relation, which we usually write [n1 <= n2]. *)

Print le.
(* ====> Inductive le (n : nat) : nat -> Prop :=
             le_n : n <= n
           | le_S : forall m : nat, n <= m -> n <= S m *)
Check le : nat -> nat -> Prop.
Check le : relation nat.

(* Inductive le' (n m : nat) : Prop := *)
(*   | le_n_ : le' n n *)
(*   | le_S_ : le' n m -> le' n (S m). *)

(** (Why did we write it this way instead of starting with [Inductive
    le : relation nat...]?  Because we wanted to put the first [nat]
    to the left of the [:], which makes Coq generate a somewhat nicer
    induction principle for reasoning about [<=].) *)

(* ################################################################# *)
(** * Basic Properties *)

(** As anyone knows who has taken an undergraduate discrete math
    course, there is a lot to be said about relations in general,
    including ways of classifying relations (as reflexive, transitive,
    etc.), theorems that can be proved generically about certain sorts
    of relations, constructions that build one relation from another,
    etc.  For example... *)

(* ----------------------------------------------------------------- *)
(** *** Partial Functions *)

(** A relation [R] on a set [X] is a _partial function_ if, for every
    [x], there is at most one [y] such that [R x y] -- i.e., [R x y1]
    and [R x y2] together imply [y1 = y2]. *)

Definition partial_function {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

(** For example, the [next_nat] relation defined earlier is a partial
    function. *)

Print next_nat.
(* ====> Inductive next_nat (n : nat) : nat -> Prop :=
           nn : next_nat n (S n) *)
Check next_nat : relation nat.

Theorem next_nat_partial_function :
   partial_function next_nat.
Proof.
  unfold partial_function.
  intros x y1 y2 H1 H2.
  inversion H1. inversion H2.
  reflexivity.  Qed.

(** However, the [<=] relation on numbers is not a partial
    function.  (Assume, for a contradiction, that [<=] is a partial
    function.  But then, since [0 <= 0] and [0 <= 1], it follows that
    [0 = 1].  This is nonsense, so our assumption was
    contradictory.) *)

Theorem le_not_a_partial_function :
  ~ (partial_function le).
Proof.
  unfold not. unfold partial_function. intros Hc.
  assert (0 = 1) as Nonsense. {
    apply Hc with (x := 0).
    - apply le_n.
    - apply le_S. apply le_n. }
  inversion Nonsense. Qed.

(** **** Exercise: 2 stars, optional (total_relation_not_partial)  *)
(** Show that the [total_relation] defined in earlier is not a partial
    function. *)
Theorem all_eq_total : ~ (partial_function all_eq).
Proof.
  unfold not. unfold partial_function. intros.
  assert (0 = 1) as Nope. {
    apply H with (x := 0).
    - apply eq. reflexivity.
    - apply neqM. apply le_S. apply le_n.
  } inversion Nope. Qed.

(** [] *)

(** **** Exercise: 2 stars, optional (empty_relation_partial)  *)
(** Show that the [empty_relation] that we defined earlier is a
    partial function. *)

(* DISUCSS THIS IN MEETING. HOW DO YOU ACTUALLY DEFINE AN EMPTY RELATION *)
Theorem never_eq : partial_function never_eq.
Proof.
  unfold partial_function. intros. inversion H. inversion H0. reflexivity. Qed.

(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Reflexive Relations *)

(** A _reflexive_ relation on a set [X] is one for which every element
    of [X] is related to itself. *)

Definition reflexive {X: Type} (R: relation X) :=
  forall a : X, R a a.

Theorem le_reflexive :
  reflexive le.
Proof.
  unfold reflexive. intros n. apply le_n.  Qed.

(* ----------------------------------------------------------------- *)
(** *** Transitive Relations *)

(** A relation [R] is _transitive_ if [R a c] holds whenever [R a b]
    and [R b c] do. *)

Definition transitive {X: Type} (R: relation X) :=
  forall a b c : X, (R a b) -> (R b c) -> (R a c).

Theorem le_trans :
  transitive le.
Proof.
  intros n m o Hnm Hmo.
  induction Hmo.
  - (* le_n *) apply Hnm.
  - (* le_S *) apply le_S. apply IHHmo.  Qed.

Theorem lt_trans:
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  apply le_S in Hnm.
  apply le_trans with (a := (S n)) (b := (S m)) (c := o).
  apply Hnm.
  apply Hmo. Qed.

(** **** Exercise: 2 stars, optional (le_trans_hard_way)  *)
(** We can also prove [lt_trans] more laboriously by induction,
    without using [le_trans].  Do this.*)

Theorem lt_trans' :
  transitive lt.
Proof.
  (* Prove this by induction on evidence that [m] is less than [o]. *)
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction Hmo as [| m' Hm'o].
  -  apply le_S in Hnm. apply Hnm.
  -  apply le_S in IHHm'o. apply IHHm'o.
Qed.
(** [] *)

(** **** Exercise: 2 stars, optional (lt_trans'')  *)
(** Prove the same thing again by induction on [o]. *)

Theorem lt_trans'' :
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction o as [| o'].
  - inversion Hmo.
  - induction Hmo as [].
    + apply le_S. apply Hnm.
    + apply le_S. apply IHHmo.
Qed.

(** [] *)

(** The transitivity of [le], in turn, can be used to prove some facts
    that will be useful later (e.g., for the proof of antisymmetry
    below)... *)

Theorem le_Sn_le : forall n m, S n <= m -> n <= m.
Proof.
  intros n m H. apply le_trans with (S n).
  - apply le_S. apply le_n.
  - apply H.
Qed.

(** **** Exercise: 1 star, optional (le_S_n)  *)
Theorem le_S_n : forall n m,
  (S n <= S m) -> (n <= m).
Proof.
  intros. inversion H. trivial. apply le_Sn_le. apply H1. Qed.

(** [] *)

(** **** Exercise: 2 stars, optional (le_Sn_n_inf)  *)
(** Provide an informal proof of the following theorem:

    Theorem: For every [n], [~ (S n <= n)]

    A formal proof of this is an optional exercise below, but try
    writing an informal proof without doing the formal proof first.

    Proof: *)
    (* induction on n, the base case follows from the definition of <=*)
    (* The inductive case, when n = S n', follows equally as trivially *)
    (* FILL IN HERE *)
(** [] *)

(** **** Exercise: 1 star, optional (le_Sn_n)  *)
Theorem le_Sn_n : forall n,
  ~ (S n <= n).
Proof.
  intros. unfold not. intros.
  induction n as [].
  - inversion H.
  - apply IHn. apply le_S_n. apply H. Qed.
(** [] *)

(** Reflexivity and transitivity are the main concepts we'll need for
    later chapters, but, for a bit of additional practice working with
    relations in Coq, let's look at a few other common ones... *)

(* ----------------------------------------------------------------- *)
(** *** Symmetric and Antisymmetric Relations *)

(** A relation [R] is _symmetric_ if [R a b] implies [R b a]. *)

Definition symmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a).

(** **** Exercise: 2 stars, optional (le_not_symmetric)  *)
Theorem le_not_symmetric :
  ~ (symmetric le).
Proof.
  unfold not. unfold symmetric. intros.
  assert (1 <= 0) as Nope. {
    apply H. apply le_S, le_n.
  } inversion Nope. Qed.

(** [] *)

(** A relation [R] is _antisymmetric_ if [R a b] and [R b a] together
    imply [a = b] -- that is, if the only "cycles" in [R] are trivial
    ones. *)

Definition antisymmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a) -> a = b.

(** **** Exercise: 2 stars, optional (le_antisymmetric)  *)
Lemma Sn_le_n_false: forall n : nat, (S n) <= n -> False.
  Proof.
    intros.  induction n as [].
    - inversion H.
    - apply IHn. apply le_Sn_n in H. inversion H.
  Qed.

  (* WHY CANT WE FORWARD PROVE WITH LE_TRANS IN THE HYPOTHESIS??? *)
Theorem le_antisymmetric :
  antisymmetric le.
Proof.
  unfold antisymmetric. intros. destruct H as [].
  - trivial.
  - assert (S m <= m) as Hn. {
      apply le_trans with (S m). trivial. apply le_trans with a. apply H0. apply H.
    } apply Sn_le_n_false in Hn. inversion Hn.
Qed.

(** [] *)

(** **** Exercise: 2 stars, optional (le_step)  *)
Theorem le_step : forall n m p,
  n < m ->
  m <= S p ->
  n <= p.
Proof.
  intros. unfold lt in H. apply le_S_n. apply le_trans with m.
  - apply H.
  - apply H0.
Qed.

(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Equivalence Relations *)

(** A relation is an _equivalence_ if it's reflexive, symmetric, and
    transitive.  *)

Definition equivalence {X:Type} (R: relation X) :=
  (reflexive R) /\ (symmetric R) /\ (transitive R).

(* ----------------------------------------------------------------- *)
(** *** Partial Orders and Preorders *)

(** A relation is a _partial order_ when it's reflexive,
    _anti_-symmetric, and transitive.  In the Coq standard library
    it's called just "order" for short. *)

Definition order {X:Type} (R: relation X) :=
  (reflexive R) /\ (antisymmetric R) /\ (transitive R).

(** A preorder is almost like a partial order, but doesn't have to be
    antisymmetric. *)

Definition preorder {X:Type} (R: relation X) :=
  (reflexive R) /\ (transitive R).

Theorem le_order :
  order le.
Proof.
  unfold order. split.
    - (* refl *) apply le_reflexive.
    - split.
      + (* antisym *) apply le_antisymmetric.
      + (* transitive. *) apply le_trans.  Qed.

(* ################################################################# *)
(** * Reflexive, Transitive Closure *)

(** The _reflexive, transitive closure_ of a relation [R] is the
    smallest relation that contains [R] and that is both reflexive and
    transitive.  Formally, it is defined like this in the Relations
    module of the Coq standard library: *)

Inductive clos_refl_trans {A: Type} (R: relation A) : relation A :=
    | rt_step : forall x y, R x y -> clos_refl_trans R x y
    | rt_refl : forall x, clos_refl_trans R x x
    | rt_trans : forall x y z,
          clos_refl_trans R x y ->
          clos_refl_trans R y z ->
          clos_refl_trans R x z.

(** For example, the reflexive and transitive closure of the
    [next_nat] relation coincides with the [le] relation. *)

Theorem next_nat_closure_is_le : forall n m,
  (n <= m) <-> ((clos_refl_trans next_nat) n m).
Proof.
  intros n m. split.
  - (* -> *)
    intro H. induction H.
    + (* le_n *) apply rt_refl.
    + (* le_S *)
      apply rt_trans with m. apply IHle. apply rt_step.
      apply nn.
  - (* <- *)
    intro H. induction H.
    + (* rt_step *) inversion H. apply le_S. apply le_n.
    + (* rt_refl *) apply le_n.
    + (* rt_trans *)
      apply le_trans with y.
      apply IHclos_refl_trans1.
      apply IHclos_refl_trans2. Qed.

(** The above definition of reflexive, transitive closure is natural:
    it says, explicitly, that the reflexive and transitive closure of
    [R] is the least relation that includes [R] and that is closed
    under rules of reflexivity and transitivity.  But it turns out
    that this definition is not very convenient for doing proofs,
    since the "nondeterminism" of the [rt_trans] rule can sometimes
    lead to tricky inductions.  Here is a more useful definition: *)

Inductive clos_refl_trans_1n {A : Type}
                             (R : relation A) (x : A)
                             : A -> Prop :=
  | rt1n_refl : clos_refl_trans_1n R x x
  | rt1n_trans (y z : A) :
      R x y -> clos_refl_trans_1n R y z ->
      clos_refl_trans_1n R x z.

(** Our new definition of reflexive, transitive closure "bundles"
    the [rt_step] and [rt_trans] rules into the single rule step.
    The left-hand premise of this step is a single use of [R],
    leading to a much simpler induction principle.

    Before we go on, we should check that the two definitions do
    indeed define the same relation...

    First, we prove two lemmas showing that [clos_refl_trans_1n] mimics
    the behavior of the two "missing" [clos_refl_trans]
    constructors.  *)

Lemma rsc_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> clos_refl_trans_1n R x y.
Proof.
  intros X R x y H.
  apply rt1n_trans with y. apply H. apply rt1n_refl.   Qed.

(** **** Exercise: 2 stars, optional (rsc_trans)  *)
Lemma rsc_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      clos_refl_trans_1n R x y  ->
      clos_refl_trans_1n R y z ->
      clos_refl_trans_1n R x z.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Then we use these facts to prove that the two definitions of
    reflexive, transitive closure do indeed define the same
    relation. *)

(** **** Exercise: 3 stars, optional (rtc_rsc_coincide)  *)
Theorem rtc_rsc_coincide :
         forall (X:Type) (R: relation X) (x y : X),
  clos_refl_trans R x y <-> clos_refl_trans_1n R x y.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)