(** * DeltaList : lists of natural numbers with constrained differences *)

Require Import Arith Omega Wf_nat List.
Import ListNotations.
Set Implicit Arguments.

(** * Increasing lists *)

(** [Delta p l] means that consecutives values in the list [l]
    have differences of at least [p]. *)

Inductive Delta (p:nat) : list nat -> Prop :=
  | Dnil : Delta p []
  | Done n : Delta p [n]
  | Dcons n m l : m+p <= n -> Delta p (n::l) -> Delta p (m::n::l).
Hint Constructors Delta.

(** In particular:
    - [Delta 0 l] means that [l] is increasing
    - [Delta 1 l] means that [l] is stricly increasing
    - [Delta 2 l] implies in addition that no consecutive
      numbers can occur in [l].
*)

Lemma Delta_alt p x l :
 Delta p (x::l) <-> Delta p l /\ (forall y, In y l -> x+p <= y).
Proof.
 split.
 - revert x. induction l as [|a l IH].
   + intros x _. split. constructor. inversion 1.
   + intros x. inversion 1; subst. split; trivial.
     intros y [Hy|Hy]. now subst.
     apply (IH a) in Hy; auto. omega.
 - intros (H,H').
   destruct l; constructor; trivial. apply H'. now left.
Qed.

Lemma Delta_inv p x l : Delta p (x::l) -> Delta p l.
Proof.
 rewrite Delta_alt. intuition.
Qed.

Lemma Delta_more l p p' : p <= p' -> Delta p' l -> Delta p l.
Proof.
 induction 2; constructor; auto; omega.
Qed.

Lemma Delta_21 l : Delta 2 l -> Delta 1 l.
Proof.
 apply Delta_more; auto.
Qed.

Lemma Delta_nz p k l : 0<k -> Delta p (k::l) -> ~In 0 (k::l).
Proof.
 intros H H' [X|X]. omega.
 apply Delta_alt in H'. apply H' in X. omega.
Qed.
Hint Resolve Delta_21 Delta_inv Delta_nz.

Lemma Delta_low_hd p k k' l :
 k'<=k -> Delta p (k::l) -> Delta p (k'::l).
Proof.
 intros Hk. rewrite !Delta_alt. intros (H,H').
 split; trivial. intros y Hy. apply H' in Hy. omega.
Qed.

Lemma Delta_21_S x l : Delta 2 (x::l) -> Delta 1 (S x::l).
Proof.
  intros D. apply Delta_alt in D. destruct D as (D,D').
  apply Delta_alt; split; eauto.
  intros y Hy. apply D' in Hy. omega.
Qed.
Hint Resolve Delta_21_S.

Lemma Delta_map p p' f l :
  (forall x y, x+p <= y -> f x + p' <= f y) ->
  Delta p l -> Delta p' (map f l).
Proof.
 induction 2; constructor; auto.
Qed.

Lemma Delta_pred p l :
 ~In 0 l -> Delta p l -> Delta p (map pred l).
Proof.
 induction 2; simpl in *; constructor; intuition.
Qed.

(* begin hide *)
(* In stdlib's List.v since 8.5: *)
Lemma in_seq len start n :
  In n (seq start len) <-> start <= n < start+len.
Proof.
  revert start. induction len; simpl; intros.
  - rewrite <- plus_n_O. split;[easy|].
    intros (H,H'). apply (Lt.lt_irrefl _ (Lt.le_lt_trans _ _ _ H H')).
  - rewrite IHlen, <- plus_n_Sm; simpl; split.
    * intros [H|H]; subst; intuition auto with arith.
    * intros (H,H'). destruct (Lt.le_lt_or_eq _ _ H); intuition.
Qed.
(* end hide *)

Lemma Delta_seq n k : Delta 1 (seq n k).
Proof.
 revert n. induction k.
 - constructor.
 - intros. simpl. apply Delta_alt. split; auto.
   intros y Hy. rewrite in_seq in Hy. omega.
Qed.

Lemma Delta_app p x l l' :
  Delta p l -> Delta p (x::l') ->
  (forall y, In y l -> y <= x) -> Delta p (l++l').
Proof.
 induction l.
 - intros _ Hl' H. simpl. eauto.
 - intros Hl Hl' H. simpl. apply Delta_alt. split.
   + apply IHl; eauto.
     intros y Hy. apply H. now right.
   + intros y Hy. rewrite in_app_iff in Hy.
     destruct Hy as [Hy|Hy].
     * rewrite Delta_alt in Hl. now apply Hl.
     * assert (a <= x) by (apply H; now left).
       apply Delta_alt in Hl'. apply Hl' in Hy. omega.
Qed.

Lemma Delta_app_inv p l l' :
 Delta p (l++l') ->
 Delta p l /\ Delta p l' /\
 forall x x', In x l -> In x' l' -> x+p <= x'.
Proof.
 induction l; simpl.
 - split. constructor. intuition.
 - rewrite !Delta_alt. intuition.
   subst. apply H1. rewrite in_app_iff. now right.
Qed.

(** * Decreasing lists *)

(** [DeltaRev p l] is [Delta p (rev l)] :
    it considers differences in the reversed order,
    leading to decreasing lists *)

Inductive DeltaRev (p:nat) : list nat -> Prop :=
  | DRnil : DeltaRev p []
  | DRone n : DeltaRev p [n]
  | DRcons n m l : n+p <= m -> DeltaRev p (n::l) -> DeltaRev p (m::n::l).
Hint Constructors DeltaRev.

Lemma DeltaRev_alt p x l :
 DeltaRev p (x::l) <-> DeltaRev p l /\ (forall y, In y l -> y+p <= x).
Proof.
 split.
 - revert x. induction l as [|a l IH].
   + intros x _. split. constructor. inversion 1.
   + intros x. inversion 1; subst. split; trivial.
     intros y [Hy|Hy]. now subst.
     apply (IH a) in Hy; auto. omega.
 - intros (H,H').
   destruct l; constructor; trivial. apply H'. now left.
Qed.

Lemma DeltaRev_app p x l l' :
  DeltaRev p l -> DeltaRev p (x::l') ->
  (forall y, In y l -> x <= y) -> DeltaRev p (l++l').
Proof.
 induction l.
 - intros _ Hl' H. simpl. now rewrite DeltaRev_alt in Hl'.
 - intros Hl Hl' H. simpl. apply DeltaRev_alt. split.
   + apply IHl; auto.
     * now rewrite DeltaRev_alt in Hl.
     * intros y Hy. apply H. now right.
   + intros y Hy. rewrite in_app_iff in Hy.
     destruct Hy as [Hy|Hy].
     * rewrite DeltaRev_alt in Hl. now apply Hl.
     * assert (x <= a) by (apply H; now left).
       apply DeltaRev_alt in Hl'. apply Hl' in Hy. omega.
Qed.

Lemma DeltaRev_app_inv p l l' :
 DeltaRev p (l++l') ->
 DeltaRev p l /\ DeltaRev p l' /\
 forall x x', In x l -> In x' l' -> x'+p <= x.
Proof.
 induction l; simpl.
 - split. constructor. intuition.
 - rewrite !DeltaRev_alt. intuition.
   subst. apply H1. rewrite in_app_iff. now right.
Qed.

Lemma Delta_rev p l : Delta p (rev l) <-> DeltaRev p l.
Proof.
 split.
 - rewrite <- (rev_involutive l) at 2.
   set (l':=rev l); clearbody l'. clear l.
   induction 1.
   + constructor.
   + constructor.
   + simpl in *.
     apply DeltaRev_app with n; auto.
     intros y Hy. apply DeltaRev_app_inv in IHDelta.
     destruct IHDelta as (_ & _ & IH).
     specialize (IH y n).
     rewrite in_app_iff in Hy. simpl in *. intuition.
 - induction 1.
   + constructor.
   + constructor.
   + simpl in *.
     apply Delta_app with n; auto.
     intros y Hy. apply Delta_app_inv in IHDeltaRev.
     destruct IHDeltaRev as (_ & _ & IH).
     specialize (IH y n).
     rewrite in_app_iff in Hy. simpl in *. intuition.
Qed.

Lemma DeltaRev_rev p l : DeltaRev p (rev l) <-> Delta p l.
Proof.
 now rewrite <- Delta_rev, rev_involutive.
Qed.


(**

  * Spécification et Validation de Programmes - Examen Février 2015

Cet examen est un examen sur machine.

_Durée_ : 3 heures

_Documents_ :  tous documents autorisés

L'objectif est de répondre directement dans ce fichier et de
soumettre ce dernier sur le site du master (cf. instructions données
lors de l'examen).   Repérez les mots  "QUESTION"  au fil du texte.

_Important_ : le temps de soumission est compris dans les 3 heures,
 toute soumission tardive est comptée comme copie vide.

Dans les réponses, les [admit]  ou [Admitted]  doivent etre effacés ou commentés sinon aucun point ne sera accordé à la question.   Le sujet est à priori à répondre dans l'ordre
 des questions mais il est possible de laisser un [admit] ou [Admitted] pour passer à la suite
 en supposant la réponse fournie.

La difficulté relative et ressentie par les enseignants pour chaque question est notée de
la façon suivante :

  [+]   question facile
  [++]  question non-triviale mais simple
  [+++] question demandant un peu plus de réflexion
  [++++] question difficile et/ou prenant du temps

*)

Require Import Bool.
Require Import Arith.

(**

* Les Ensembles finis en Coq.

L'objectif de cet examen est de proposer une formalisation de la notion d'ensemble fini (typé) dans le logiciel Coq.

*)

Section Ensembles.

Variable Elem : Set.  (*  le type générique des éléménts des ensembles. *)

(**

* (1) Egalité sur les éléments

La notion d'ensemble est dépendante de la notion d'égalité sur
leurs éléménts. On fera donc l'hypothèse que l'égalité sur les éléments des ensembles est décidable.

*)

Hypothesis Elem_eq_dec: forall a b : Elem, { a = b } + { a <> b }.

(**

Voici quelques définitions et lemmes importants sur cette égalité entre éléments.

*)

Definition elem_eq (a b : Elem) : bool :=
  match Elem_eq_dec a b with
    | left _ => true
    | right _ => false
  end.

Proposition elem_eq_eq:
  forall a b : Elem,
    elem_eq a b = true -> a = b.
Proof.
  intros a b H.
  unfold elem_eq in H.
  destruct (Elem_eq_dec a b) as [Heq | Hneq].
  + (* cas a = b *)
    exact Heq.
  + (* cas a <> b *)
    inversion H. (* contradiction *)
Qed.

(**

 ** QUESTION 1.1 [+] : réflexivité de l'égalité

Complétez la preuve du lemme suivant :

*)

Lemma elem_eq_refl:
  forall a : Elem, elem_eq a a = true.
Proof.
  intro a.
  unfold elem_eq.
  destruct (Elem_eq_dec a a) as [Heq | Hneq].
  + (* cas a = a *)
    reflexivity.
  + (* cas a <> a *)
    unfold not in Hneq.
    assert (HFalse: False).
    {
      apply Hneq.
      reflexivity.
    }
    elim HFalse.
Qed.

(**

 ** QUESTION 1.2 [+]

En déduire une démonstration pour la proposition suivante :

*)

Proposition eq_elem_eq:
  forall a b : Elem,
    a = b -> elem_eq a b = true.
Proof.
  intros a b H.
  subst.
  rewrite elem_eq_refl.
  reflexivity.
Qed.

(**

On se donne des propositions complémentaires pour la négation.

*)

Proposition neq_elem_neq:
  forall a b : Elem,
    a <> b -> elem_eq a b = false.
Proof.
  intros a b Hneq.
  case_eq (elem_eq a b).
  - (* cas Htrue *)
    intro Htrue.
    assert (Heq: a = b).
    { apply elem_eq_eq.
      exact Htrue.
    }
    contradiction.
  - (* cas Hfalse *)
    reflexivity.
Qed.

Proposition elem_neq_neq:
  forall a b : Elem,
    elem_eq a b = false -> a <> b.
Proof.
  intros a b Hfalse.
  unfold not.
  intro Heq.
  rewrite Heq in Hfalse.
  rewrite elem_eq_refl in Hfalse.
  inversion Hfalse.
Qed.

(**

 *  (2) Définition d'ensemble et appartenance

La notion d'ensemble fini proposée est assez naive et définie par
le type suivant.

*)

Inductive Ens : Set :=
| vide : Ens
| elem : Elem -> Ens -> Ens.

(**

On souhaite définir la notion d'appartenance à un ensemble, basée
 sur la définition précédente.

 ** QUESTION 2.1 [+] : appartenance fonctionnelle

La première définition d'appartenance est un prédicat booléen fonctionnel.

Complétez la définition suivante :

*)

Fixpoint appartient (a:Elem) (E:Ens) : bool :=
  match E with
    | vide => false
    | elem e ES => if elem_eq a e then true else appartient a ES
  end.

(**

  ** QUESTION 2.2 [+] : propriété de l'appartenance

Démontrer la propriété suivante (par cas):

*)

Proposition appartient_elem:
  forall a b : Elem, forall E : Ens,
      appartient a E = true -> appartient a (elem b E) = true.
Proof.
  intros a b E H.
  simpl.
  destruct (elem_eq a b).
  +reflexivity.
  +exact H.
   Qed.
(**

On donne maintenant une définition alternative à l'aide
d'un type inductif de nom  Appartient   (avec A majuscule)
et implémentant les règles suivantes :

 - règle : app_debut

    ---------------------------
      Appartient a (elem a E)

 - règle : app_reste

      Appartient a E
    --------------------------
      Appartient a (elem b E)

*)

Inductive Appartient : Elem -> Ens -> Prop :=
| app_debut: forall E : Ens, forall a : Elem, Appartient a (elem a E)
| app_reste: forall E : Ens, forall a b : Elem, Appartient a E
                                                -> Appartient a (elem b E).

(**

  ** QUESTION 2.3 [+]

 Montrer la proposition suivante :

*)

Proposition Appartient_elem:
  forall a b : Elem, forall E : Ens,
      Appartient a E -> Appartient a (elem b E).
Proof.
  intros a b E H.
  apply app_reste.
  exact H.
Qed.

(**

  ** QUESTION 2.4 [+++] : Du récursif à l'inductif

Montrer par induction le lemme suivant :

*)

Lemma appartient_Appartient:
  forall a : Elem, forall E : Ens,
      appartient a E = true -> Appartient a E.
Proof.
  intros a E.
  intros H.
  induction E as [|v ee].
  +inversion H.
  +apply Appartient_elem.
   apply IHee.
   inversion H.
   destruct (elem_eq a v).
  -destruct ee.
   *simpl.
    simpl in H.

Admitted.

(**

  ** QUESTION 2.5 [++] : De l'inductif au récursif

Montrer par induction sur le type inductif Appartient
le lemme suivant :

*)

Lemma Appartient_appartient:
  forall a : Elem, forall E : Ens,
      Appartient a E -> appartient a E = true.
Proof.
  intros a E.
  intros H.
  induction E as [|v ee].
  + inversion H.
  + apply appartient_elem.
    destruct (appartient a ee).
    *trivial.
    *simpl.
Admitted.

(**

 ** QUESTION 2.6 [++]

En utilisant les deux lemmes précédents, déduire de la proposition Appartient_elem (avec A majuscule) une preuve alternative de la proposition appartient_elem  (avec a minuscule).

*)

Proposition appartient_elem':
  forall a b : Elem, forall E : Ens,
      appartient a E = true -> appartient a (elem b E) = true.
Proof.
  intros a b E.
  rewrite Appartient_appartient.
  + intros HT.
    rewrite Appartient_appartient.
    exact HT.
    apply Appartient_elem.
    apply appartient_Appartient.
    simpl.
Admitted. (* <== REMPLACER le Admitted. *)

(**

  * (3)  Union ensembliste

Dans cette partie nous nous intéressons à l'opérateur d'union ensembliste.

Nous donnons la définition fonctionnelle suivante :

*)

Fixpoint union (E F : Ens) : Ens :=
  match E with
    | vide => F
    | elem a E' => elem a (union E' F)
  end.

(**

  ** QUESTION 3.1 [++]

Démontrer le lemme suivant :

*)

Lemma union_Appartient_l:
  forall a : Elem, forall E F : Ens,
      Appartient a E -> Appartient a (union E F).
Proof.
  intros a E F.
  intros H.
  induction E as [|e ee].
  +simpl.
   inversion H.
  +simpl.
   apply Appartient_elem.
   destruct (union ee F).
  -apply IHee.
   inversion H.
Admitted. (* <== REMPLACER LE Admitted. *)

(**

Le lemme complémentaire : union_Appartient_r

qui permet de déduire :

    Appartient a (union E F)

à partir de

    Appartient a F

est plus difficile à démontrer, car l'union effectue la récursion
sur E et non sur F.

Nous passons en mode "calcul"  (en utilisant la définition fonctionnelle
 de appartient) et nous procédons par étapes.

*)

(**

  ** Question 3.2 [++]

Démontrer le lemme suivant par induction sur E :

*)

Proposition union_appartient_elem_r_eq:
  forall a b : Elem, forall E F : Ens,
      a = b
      -> appartient a (union E (elem b F)) = true.
Proof.
  intros a b E F.
  intros H.
  induction E as [|e E'].
  - apply appartient_elem.
    destruct F.
    +simpl.
     admit.
    +apply appartient_elem.
     admit.
  -simpl.
   rewrite IHE'.
   destruct (elem_eq a e).
   +trivial.
   +trivial.
Qed.

(**

  ** Question 3.3 [++]

Démontrer le lemme suivant par induction sur E :

*)

Proposition union_appartient_elem_r:
  forall a b : Elem, forall E F : Ens,
      appartient a (union E F) = true
      -> appartient a (union E (elem b F)) = true.
Proof.
  intros a b E F H.
  induction E as [|e E'].
  +apply appartient_elem.
   simpl.
Admitted. (* <== REMPLACER LE Admitted. *)

(**

  ** QUESTION 3.4 [+++]

En utilisant les deux propositions précédentes, démontrer
par induction sur F la proposition suivante :

*)

Proposition union_appartient_r:
  forall a : Elem, forall E F : Ens,
      appartient a F = true -> appartient a (union E F) = true.
Proof.
  intros a E F.
  induction F as [|f F'].
  +intros H.
   inversion H.
   +
Admitted. (* <== REMPLACER LE Admitted. *)

(**

  ** QUESTION 3.5 [++]

En déduire le lemme suivant :

*)

Lemma union_Appartient_r:
  forall a : Elem, forall E F : Ens,
      Appartient a F -> Appartient a (union E F).
Proof.
Admitted. (* <== REMPLACER LE Admitted. *)

(**

  ** QUESTION 3.6 [++]

Finalement, en déduire le théorème de l'union :

*)

Theorem union_Appartient:
  forall a : Elem, forall E F : Ens,
      Appartient a E \/ Appartient a F
      -> Appartient a (union E F).
Proof.
Admitted. (* <== REMPLACER LE Admitted. *)

(**

  * (4) Elimination des doublons

Dans cette partie, nous souhaitons éliminer les éléments doublons
dans les ensembles.

*)

(**

  ** QUESTION 4.1 [+]

Définir la fonction retirer telle que (retirer a E)
 élimine toutes les occurrences de l'élément a dans l'ensemble E.

*)

Fixpoint retirer (a : Elem) (E : Ens) : Ens :=
  vide.  (* <== REMPLACER vide PAR UNE DEFINITION RECURSIVE. *)

(**

  ** QUESTION 4.2 [++]

Prouver le lemme suivant :

*)

Lemma retirer_present:
  forall a : Elem, forall E : Ens,
      appartient a (retirer a E) = false.
Proof.
Admitted. (* <== REMPLACER LE Admitted. *)

(**

  ** QUESTION 4.3 [++]

Démontrer le lemme suivant :

*)

Lemma Appartient_retirer_elem:
  forall a b : Elem, forall E : Ens,
      b <> a -> Appartient a E ->  Appartient a (retirer b E).
Proof.
Admitted. (* <== REMPLACER LE Admitted. *)

(**

  ** QUESTION 4.4 [+]

Donner une définition de la fonction sans_doublons
telle que (sans_doublons E) retire tous les éléments répétés
 dans E.

*)

Fixpoint sans_doublons (E : Ens) : Ens :=
  vide.  (* <== REMPLACER vide PAR UNE DEFINITION RECURSIVE. *)

(**

  ** QUESTION 4.5 [+++]

En déduire le théorème suivant :

*)

Theorem Appartient_sans_doublons:
  forall a : Elem, forall E : Ens,
      Appartient a E -> Appartient a (sans_doublons E).
Proof.
Admitted. (* <== REMPLACER LE Admitted. *)

(**

  * (5) Différence ensembliste

Dans cette dernière partie on souhaite formaliser l'opérateur de
 différence ensembliste.

*)

(**

  ** Question 5.1 [++]

Définir la fonction difference retournant la
différence entre deux ensembles.

*)

Fixpoint difference (E1 : Ens) (E2 : Ens) : Ens :=
  vide.  (* <== REMPLACER vide PAR UNE DEFINITION RECURSIVE. *)

(**

Notre objectif est de montrer le théorème suivant :

Theorem difference_Appartient:
  forall e : Elem, forall E2 E1 : Ens,
      Appartient e E2
      -> ~ (Appartient e (difference E1 E2)).

Cependant, la preuve est non-triviale et nous allons
réaliser les étapes nécessaires en passant à la fonction
 de calcul appartient (avec a minuscule).

*)

(**

 ** Question 5.2 [+++]

Compléter la preuve du Lemme suivant :

*)

Lemma nappartient_retirer_elem:
  forall a b : Elem, forall E : Ens,
      b <> a -> appartient a E = false ->  appartient a (retirer b E) = false.
Proof.
Admitted. (* <== RETIRER LE Admitted. *)
  (*  <=== DECOMMENTER SINON CELA NE PASSE PAS
  intros a b E Hneq Happ.
  induction E as [|e E'].
  - (* cas E = vide *)
    simpl.
    reflexivity.
  - (* cas E = (elem e E') *)
    simpl.
    case_eq (elem_eq b e).
    + (* cas b = e vrai *)
      intro Htrue.
      apply IHE'.
      admit. (* <== REMPLACER LE admit *)
      (* etc ... *)
    + (* cas b = e faux *)
      intro Hfalse.
      admit. (* <== REMPLACER LE admit *)
      (* etc ... *)
Qed. DECOMMENTER ===> *)

(**

 ** Question 5.3 [+++]

Compléter la preuve du Lemme suivant :

*)

Lemma difference_appartient_aux:
  forall e : Elem, forall E2 E1: Ens,
      appartient e E1 = false
      -> appartient e (difference E1 E2) = false.
Proof.
Admitted. (* <== REMPLACER LE Admitted. *)

(**

 ** Question 5.4 [+++]

En déduire le lemme ci-dessous :

*)

Lemma difference_appartient:
  forall e : Elem, forall E2 E1 : Ens,
    appartient e E2 = true
    -> appartient e (difference E1 E2) = false.
Proof.
Admitted. (* <== REMPLACER LE Admitted. *)

(**

  ** Question 5.5 [++]

En déduire notre théorème principal.

*)

Theorem difference_Appartient:
  forall e : Elem, forall E2 E1 : Ens,
      Appartient e E2
      -> ~ (Appartient e (difference E1 E2)).
Proof.
Admitted. (* <== REMPLACER LE Admitted *)

(**

  * (6) Intersection (réponse libre)  [+++]

Dans cette dernière partie on souhaite formaliser l'opérateur
 d'intersection entre deux ensembles.

En vous inspirant de la partie (3), proposer une formalisation
permettant finalement de démontrer le théorème suivant :

*)

(* A DECOMMENTER  ==>

Theorem intersection_Appartient:
  forall a : Elem, forall E F : Ens,
      Appartient a E /\ Appartient a F
      -> Appartient a (intersection E F).

*)


Theorem plus_O_n : forall n : nat, 0 + n = n.
Proof.
  intro n. reflexivity. Qed.

Theorem plus_1_l : forall n:nat, 1 + n = S n.
Proof.
  intros n. reflexivity. Qed.

Theorem plus_id_example : forall n m:nat,
	n = m -> n + n = m + m.
Proof.
	intros n.
	intros m.
	intros N1.
	rewrite -> N1.
	reflexivity. Qed.

Theorem plus_id_exercise : forall n m o : nat,
	n = m -> m = o -> n + m = m + o.
Proof.
	intros n m o.
	intros M N.
	rewrite M.
	rewrite N.
	reflexivity. Qed.

Theorem mult_0_plus : forall n m : nat,
  	(0 + n) * m = n * m.
Proof.
  	intros n m.
	rewrite -> plus_O_n.
	reflexivity. Qed.

Theorem mult_S_1 : forall n m : nat,
	m = S n ->
	m * (1 + n) = m * m.
Proof.
  	intros n m.
  	intros H.
  	rewrite -> H.
  	reflexivity. Qed.

Fixpoint beq_nat (n m : nat) : bool :=
	match n with
		| O => 		match m with
						| O => true
						| S m' => false
					end
		| S n' => 	match m with
            			| O => false
						| S m' => beq_nat n' m'
					end
	end.

Eval compute in (beq_nat 0 0).
Eval compute in (beq_nat 0 1).

Theorem plus_1_neq_0_firsttry : forall n : nat,
	beq_nat (n + 1) 0 = false.
Proof.
	intros n.
  	destruct n as [| n'].
    reflexivity.
    reflexivity.
Qed.

Theorem zero_nbeq_plus_1 : forall n : nat,
	beq_nat 0 (n + 1) = false.
Proof.
	intros n.
	destruct n as [ | n'].
	reflexivity.
	reflexivity.
Qed.

Definition andb (a b : bool) : bool :=
	match a with
		| true => b
		| false => false
	end.

Definition orb (a b : bool) : bool :=
	match a with
		| false => b
		| true => true
	end.

Theorem andb_false : forall b c : bool,
	c = false ->
	(andb b c) = false.
Proof.
	intros b c.
	intros H.
	rewrite -> H.
	destruct b.
	reflexivity. reflexivity.
Qed.

Theorem andb_true : forall b c : bool,
	c = true ->
	(andb b c) = b.
Proof.
	intros b c.
	intros H.
	rewrite -> H.
	destruct b.
	reflexivity. reflexivity.
Qed.

Theorem orb_true : forall b c : bool,
	c = true ->
	(orb b c) = true.
Proof.
	intros b c.
	intros H.
	rewrite -> H.
	destruct b.
	reflexivity. reflexivity.
Qed.

Theorem orb_false : forall b c : bool,
	c = false ->
	(orb b c) = b.
Proof.
	intros b c.
	intros H.
	rewrite -> H.
	destruct b.
	reflexivity. reflexivity.
Qed.

Theorem andb_eq_true : forall b : bool,
	(andb b true) = (orb b true) ->
	b = true.
Proof.
	intros b.
	destruct b.
		reflexivity.
		simpl.
		intros H.
		rewrite -> H.
		reflexivity.
Qed.

Theorem andb_eq_c_true : forall b c : bool,
	c = true ->
	(andb b c) = (orb b c) ->
	b = true.
Proof.
	intros b c.
	simpl.
	intros H.
	rewrite -> H.
	destruct b.

		reflexivity.

		simpl.
		intros L.
		rewrite -> L.
		reflexivity.
Qed.

Theorem andb_eq_orb :  forall (b c : bool),
  	(andb b c = orb b c) ->
  	b = c.
Proof.
	intros b c.
	destruct b.
	destruct c.
		(* b - true, c - true *)
		reflexivity.

		(* b - true, c - false *)
		simpl.
		intro H.
		rewrite -> H.
		reflexivity.

		(* b - false, c - true *)
		simpl.
		intro H.
		rewrite -> H.
		reflexivity.
Qed.

Theorem identity_fn_applied_twice : forall (f : bool -> bool),
	(forall (x : bool), f x = x) ->
  	forall (b : bool), f (f b) = b.
Proof.
	intros f.
	intros H.
	intros b.

		rewrite -> H.
		rewrite -> H.
		reflexivity.

Qed.


From mathcomp Require Import all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Definition predn n :=
  if n is p.+1 then p else n.

Compute predn 3.
Eval compute in predn.

Definition same_bool b1 b2 :=
  match b1, b2 with
  | true, true => true
  | false, false => true
  | _, _ => false
  end.

Fixpoint eqn m n :=
  match m, n with
  | O, O => true
  | p.+1, q.+1 => eqn p q
  | _, _ => false
  end.

Notation "x == y" := (eqn x y).

Eval compute in subn.

About cons.
Check cons 2 nil.

Eval compute in [seq i.+1 | i <- [:: 1; 2; 3; 4]].

Eval compute in (true, false).1.

Record point : Type :=
  Point { x : nat; y : nat; z : nat }.

Section iterators.

  Variables (T : Type) (A : Type).
  Variables (f : T -> A -> A).

  Implicit Type x : T.

  Fixpoint iter n op x :=
    if n is p.+1 then op (iter p op x) else x.

  Fixpoint foldr a s :=
    if s is y :: ys then f y (foldr a ys) else a.

  Variable init : A.
  Variables x1 x2 : T.
  Eval compute in foldr init [:: x1; x2].

End iterators.

About foldr.

Eval compute in iter 5 predn 7.

Fixpoint add n m :=
  if n is p.+1 then add p m.+1 else m.

Variable n : nat.
Eval simpl in (add n.+1 7).-1.
Eval simpl in (addn n.+1 7).-1.

Eval compute in iota 1 10.
Eval compute in \sum_(1 <= i < 5)(i * 2 - 1).

Locate "<=".

(* Excercises *)

Record triple (A B C : Type) :=
  mk_triple { fst : A; snd : B; thrd : C }.

Notation "( a , b , c )" := (mk_triple a b c).
Notation "p .1T" := (fst p) (at level 2).
Notation "p .2T" := (snd p) (at level 2).
Notation "p .3T" := (thrd p) (at level 2).
Eval compute in (4, 5, 8).1T.
Eval compute in (true, false, 1).2T.
Eval compute in (2, true, false).3T.

Definition add_iter (n m : nat) :=
  iter n S m.

Eval compute in add_iter 5 9.

Definition mult_iter (n m : nat) :=
  iter n (add_iter m) 0.

Eval compute in mult_iter 5 8.

Fixpoint nth {A : Type} (default : A) (xs : seq A) (n : nat) : A :=
  match n, xs with
  | O, (x :: xs') => x
  | m, (x :: xs') => nth default xs' n.-1
  | _, _ => default
  end.

Eval compute in nth 99 [:: 3; 7; 11; 22] 2.
Eval compute in nth 99 [:: 3; 7; 11; 22] 7.

Definition rev {A : Type} (xs : seq A) :=
  if xs is x :: xs' then (rev xs') ++ [:: x] else nil.

Eval compute in rev [:: 1; 2; 3; 4; 5].

Eval cbv delta in [:: 1] ++ [:: 1].

Definition flatten {A : Type} (xs : seq (seq A)) : seq A :=
  foldr cat nil xs.

Eval compute in flatten [:: [:: 1; 2; 3]; [:: 4; 5] ].


Require Export study02.

Module study03.

Inductive list (X:Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.
Check nil. Check cons.
Check (cons nat 2 (cons nat 1 (nil nat))).

Fixpoint length (X:Type) (l:list X) : nat :=
  match l with
  | nil _ => 0
  | cons _ h t => S (length X t)
  end.
Example test_length1:length nat
 (cons nat 2 (cons nat 1 (nil nat)))=2.
Proof. reflexivity. Qed.
Example test_length2 :
    length bool (cons bool true (nil bool)) = 1.
Proof. reflexivity. Qed.

Fixpoint app (X:Type) (l1 l2:list X) : (list X) :=
  match l1 with
  | nil _ => l2
  | cons _ h t => cons X h (app X t l2)
  end.
Definition snoc (X:Type) (l:list X) (v:X) : (list X) :=
  app X l (cons X v (nil X)).
Fixpoint rev (X:Type) (l:list X) : list X :=
  match l with
  | nil _ => nil X
  | cons _ h t => snoc X (rev X t) h
  end.
Example test_rev1 :
    rev nat (cons nat 1 (cons nat 2 (nil nat)))
  = (cons nat 2 (cons nat 1 (nil nat))).
Proof. reflexivity. Qed.
Example test_rev2:
  rev bool (nil bool) = nil bool.
Proof. reflexivity. Qed.

Fixpoint app' X l1 l2 : list X :=
  match l1 with
  | nil _ => l2
  | cons _ h t => cons X h (app' X t l2)
  end.
Check app. Check app'.
Fixpoint length' (X:Type) (l:list X) : nat :=
  match l with
  | nil _ => 0
  | cons _ h t => S (length' _ t)
  end.
Definition list123' := cons _ 1 (cons _ 2 (cons _ 3 (nil _))).

Inductive list' (A:Set) : Set :=(* listの型はSet -> Set *)
  | nil' : list' A
  | cons' : A -> list' A -> list' A.

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

Check @nil.

Definition id {A:Type} (x:A) : A := x.
Definition compose {A B C} (g:B->C)(f:A->B):=
  fun x => g (f x).
Goal forall A, compose id id = id (A := A).
Proof. auto. Qed.

Set Implicit Arguments.
Axiom eq0_le0 : forall (n:nat)(x:n=0),n<=0.
Print Implicit eq0_le0.
Axiom eq0_le0' : forall (n:nat){x:n=0},n<=0.
Print Implicit eq0_le0'.

End study03.
Module ImplicitTest.
Require Import Ascii String.

Inductive llist (X:Type) : Type :=
  | lnil : llist X
  | lcons : X -> llist X -> llist X.
Definition llist' {X:Type}:Type:= llist X.
Definition lnil' {X:Type}:llist X:= lnil X.
Definition lcons' {X:Type}:X->llist X->llist X:= lcons X.
Check (lcons' 2 (lcons' 1 (lnil' ))).
Check (lcons' "a" (lcons' "b" (lnil' ))).
(*Check (lcons 2 (lcons "c" (lnil ))).*)

Fixpoint lapp (X:Type) (l1 l2:llist X) : (llist X) :=
  match l1 with
  | lnil _ => l2
  | lcons _ h t => lcons X h (lapp X t l2)
  end.
Definition lapp' {X:Type} (l1 l2:llist X):(llist X):=lapp X l1 l2.
Fixpoint llength (X:Type) (l:llist X) : nat :=
  match l with
  | lnil _ => 0
  | lcons _ h t => S (llength X t)
  end.
Definition llength' {X:Type} (l:llist X):nat:=llength X l.
Definition lsnoc' {X:Type} (l:llist X) (v:X) : (llist X) :=
  lapp' l (lcons' v (lnil' )).
(*Definition lsnoc' {X:Type} (l:llist X)(v:X):(llist X):=lsnoc X l v.*)
Fixpoint lrev' {X:Type} (l:llist X) : llist X :=
  match l with
  | lnil _  => lnil'
  | lcons _ h t => lsnoc' (lrev' t) h
  end.
(*Definition lrev' {X:Type} (l:llist X) : llist X := lrev X l.*)
Definition list123'' := lcons' 1 (lcons' 2 (lcons' 3 lnil')).
Compute (llength' list123'').
Check lnil'. Check @lnil'.
Notation "x :: y" := (lcons' x y) (at level 60, right associativity).
Notation "[ ]" := lnil'.
Notation "[ x , .. , y ]" := (lcons' x .. (lcons' y []) ..).
Notation "x ++ y" := (lapp' x y) (at level 60, right associativity).

Definition list123''' := [1, 2, 3].
Check list123'''.

Fixpoint lrepeat (X:Type)(n:X)(count:nat):llist X:=
  match count with
  | 0 => lnil X
  | S count' => lcons X n (lrepeat X n count')
  end.
Definition lrepeat' {X:Type}(n:X)(count:nat):llist X:=
  lrepeat X n count.
Example test_lrepeat1:
  lrepeat' true 2 = lcons' true (lcons' true lnil').
Proof. reflexivity. Qed.

Theorem lnil_app : forall X:Type, forall l:llist X,
  lapp' [] l = l.
Proof. reflexivity. Qed.

Theorem lrev_lsnoc : forall X:Type, forall v:X, forall s:llist X,
  lrev' (lsnoc' s v) = v :: (lrev' s).
Proof. induction s. reflexivity. simpl.
assert (H1:s++[v]=lsnoc' s v). reflexivity.
rewrite H1. rewrite IHs. reflexivity. Qed.

Theorem lapp_ass : forall X:Type, forall l1 l2 l3:llist X,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof. induction l1. reflexivity. simpl. intros l2 l3.
rewrite IHl1. reflexivity. Qed.
Theorem lsnoc_with_lapp : forall X:Type, forall l1 l2:llist X,
  forall v:X,  lsnoc' (l1++l2) v = l1 ++ (lsnoc' l2 v).
Proof. intros X l1 l2 v. unfold lsnoc'. rewrite lapp_ass.
reflexivity. Qed.

Inductive lprod (X Y:Type) : Type :=
  lpair : X -> Y -> lprod X Y.
Definition lprod'{X Y:Type}:Type:=lprod X Y.
Definition lpair'{X Y:Type}:X -> Y -> lprod X Y:=lpair X Y.
Notation "( x , y )" := (lpair' x y).
Notation "X ^ Y" := (lprod X Y) : type_scope.
(*type_scope というアノテーションによって，型を解析する際に用いる省略形
であることを明示し，乗法の演算子との衝突を回避する．嘘*)
Locate "*". Locate "^".
Check nat ^ nat.
Check (2,3).
Definition lfst' {X Y:Type} (p:X ^ Y):X:=
  match p with (lpair _ _ x y) => x end.
Definition lsnd' {X Y:Type} (p:X ^ Y):Y:=
  match p with (lpair _ _ x y) => y end.
Compute lfst' (2,3).
Fixpoint lcombine' {X Y:Type}(lx:llist X)(ly:llist Y)
  : llist' :=
  match lx, ly with
  | lnil _ , _  => []
  | _, lnil _ => []
  | lcons _ x tx, lcons _ y ty => (x,y)::(lcombine' tx ty)
  end.
(*Fixpoint lcombine'' (lx:llist')(ly:llist')
  : llist' :=
  match lx, ly with
  | [] , _  => []
  | _, [] => []
  | x::tx, y::ty => (x,y)::(lcombine' tx ty)
  end.*)
Check @lcombine'.
Compute (lcombine' [1,2][false,false,true,true]).
Compute [(1,false),(2,false)].
Example test_lcombine:lcombine'
  [1,2][false,false,true,true]=[(1,false),(2,false)].
Proof. reflexivity. Qed.
Fixpoint lsplit'{X Y:Type} (l:llist (X^Y)) : (llist X) ^ (llist Y) :=
  match l with
  | lnil _ => ([],[])
  | lcons _ (lpair _ _ x y) t => (x::lfst'(lsplit' t),y::lsnd'(lsplit' t))
  end.
Example test_lsplit:
  lsplit' [(1,false),(2,false)] = ([1,2],[false,false]).
Proof. reflexivity. Qed.

Inductive loption (X:Type) : Type :=
  | lSome : X -> loption X
  | lNone : loption X.
Definition loption' {X:Type} : Type := loption X.
Definition lSome' {X:Type} : X -> loption' := lSome X.
Definition lNone' {X:Type} : loption' := lNone X.
Fixpoint lindex' {X:Type} (n:nat) (l:llist X) : loption' :=
  match l with
  | lnil _ => lNone'
  | lcons _ a l' => if beq_nat n 0 then lSome' a else lindex' (pred n) l'
  end.
Example test_lindex1 : lindex' 0 [4,5,6,7] = lSome' 4.
Proof. reflexivity. Qed.
Example test_lindex2 : lindex' 1 [[1],[2]] = lSome' [2].
Proof. reflexivity. Qed.
Example test_lindex3 : lindex' 2 [true] = lNone'.
Proof. reflexivity. Qed.
Definition lhd_opt' {X:Type} (l:llist X) : loption' :=
  lindex' 0 l.
Check @lhd_opt'.
Example test_lhd_opt1 : lhd_opt' [1,2] = lSome' 1.
Proof. reflexivity. Qed.
Example test_lhd_opt2 : lhd_opt' [[1],[2]] = lSome' [1].
Proof. reflexivity. Qed.

Module study03'.

Definition doit3times {X:Type} (f:X->X)(n:X) : X :=
  f (f (f n)).
Check @doit3times.
Definition minustwo (n :nat) : nat :=
  match n with
  | O => O
  | S O => O
  | S (S (n')) => n'
  end.
Example test_doit3times: doit3times minustwo 9 = 3.
Proof. reflexivity. Qed.
Example test_doit3times': doit3times negb true = false.
Proof. reflexivity. Qed.
Check plus.
Definition plus3:= plus 3.
Check plus3.
Example test_plus3 : plus3 4 = 7.
Proof. reflexivity. Qed.
Example test_plus3' : doit3times plus3 0 = 9.
Proof. reflexivity. Qed.
Example test_plus3'' : doit3times (plus 3) 0 = 9.
Proof. reflexivity. Qed.
Definition prod_curry {X Y Z:Type}
  (f:X^Y->Z)(x:X)(y:Y):Z:=f (x,y).
Definition prod_uncurry {X Y Z:Type}
  (f:X->Y->Z)(p:X^Y):Z:=f (lfst' p) (lsnd' p).
Check @prod_curry.
Check @prod_uncurry.
(*Theorem uncurry_curry_mine:forall (X Y Z:Type) (f:X^Y->Z),
  prod_uncurry(prod_curry f)=f.
Proof. intros X Y Z f. unfold prod_curry. unfold prod_uncurry.*)
Theorem uncurry_curry : forall (X Y Z:Type) (f:X->Y->Z) (x:X) (y:Y),
  prod_curry(prod_uncurry f) x y = f x y.
Proof. intros X Y Z f x y. unfold prod_curry. unfold prod_uncurry.
reflexivity. Qed.
Theorem curry_uncurry : forall (X Y Z:Type) (f:(X^Y)->Z) (p:X^Y),
  prod_uncurry(prod_curry f) p = f p.
Proof. unfold prod_uncurry. unfold prod_curry. intros X Y Z f p.
destruct p. reflexivity. Qed.

Fixpoint filter {X:Type} (test:X->bool)(l:llist X) : llist' :=
  match l with
  | lnil _ => []
  | lcons _ h t =>
    if test h then h::(filter test t)
    else filter test t
  end.
Example test_filter1:filter evenb [1,2,3,4]=[2,4].
Proof. reflexivity. Qed.
Definition length_is_1 {X:Type} (l:llist X) : bool :=
  beq_nat (llength' l) 1.
Example test_filter2:
    filter length_is_1
           [ [1, 2], [3], [4], [5,6,7], [], [8] ]
  = [ [3], [4], [8] ].
Proof. reflexivity. Qed.
Definition countoddmembers' (l:llist nat) : nat :=
  llength' (filter NatList.oddb l).
Example test_countoddmembers'1: countoddmembers' [1,0,3,1,4,5] = 4.
Proof. reflexivity. Qed.
Example test_countoddmembers'2: countoddmembers' [0,2,4] = 0.
Proof. reflexivity. Qed.
Example test_countoddmembers'3: countoddmembers' lnil' = 0.
Proof. reflexivity. Qed.
Example test_anon_fun' : doit3times (fun n => n*n) 2 = 256.
Proof. reflexivity. Qed.
Example test_filter2':
    filter (fun l => beq_nat (llength' l) 1)
           [ [1, 2], [3], [4], [5,6,7], [], [8] ]
  = [ [3], [4], [8] ].
Proof. reflexivity. Qed.

Definition filter_even_gt7 (l:llist nat) : llist nat :=
  filter (fun n => andb (NatList.evenb n) (ble_nat 8 n)) l.
Example test_filter_even_gt7_1 :
  filter_even_gt7 [1,2,6,9,10,3,12,8] = [10,12,8].
Proof. reflexivity. Qed.
Example test_filter_even_gt7_2 :
  filter_even_gt7 [5,2,6,19,129] = [].
Proof. reflexivity. Qed.
Definition partition {X:Type} (test:X->bool) (l:llist X)
  : (llist X) ^ (llist X) :=
  ((filter test l) , (filter (fun x => negb (test x)) l)).
Example test_partition1: partition NatList.oddb [1,2,3,4,5] = ([1,3,5], [2,4]).
Proof. reflexivity. Qed.
Example test_partition2: partition (fun x => false) [5,9,0] = ([], [5,9,0]).
Proof. reflexivity. Qed.

Fixpoint map {X Y:Type} (f:X->Y) (l:llist X) : llist' :=
  match l with
  | lnil _ => []
  | lcons _ h t => (f h) :: (map f t)
  end.
Example test_map1: map (plus 3) [2,0,2] = [5,3,5].
Proof. reflexivity. Qed.
Example test_map2: map oddb [2,1,2,5] = [false,true,false,true].
Proof. reflexivity. Qed.
Example test_map3:
    map (fun n => [evenb n,oddb n]) [2,1,2,5]
  = [[true,false],[false,true],[true,false],[false,true]].
Proof. reflexivity. Qed.
Theorem lsnoc_app:forall (X:Type) (l:llist X) (x:X),
  lsnoc' l x = l ++ [x].
Proof. reflexivity. Qed.
Theorem map_app1:forall (X Y:Type) (f:X->Y) (l:llist X) (x:X),
  map f (l++[x]) = (map f l) ++ [f x].
Proof. induction l. reflexivity. intros x0. simpl.
rewrite IHl. reflexivity. Qed.
Theorem map_rev:forall (X Y:Type)(f:X->Y)(l:llist X),
  map f (lrev' l) = lrev' (map f l).
Proof. induction l. reflexivity. simpl.
rewrite <- IHl. rewrite lsnoc_app. rewrite lsnoc_app.
rewrite map_app1. reflexivity. Qed.
Fixpoint flat_map {X Y:Type} (f:X->llist Y)(l:llist X)
  :(llist Y):=
  match l with
  | lnil _ => []
  | lcons _ h t =>
    (f h) ++ (flat_map f t)
  end.
Example test_flat_map1:
  flat_map (fun n => [n,n,n]) [1,5,4]
  = [1, 1, 1, 5, 5, 5, 4, 4, 4].
Proof. reflexivity. Qed.
Definition loption_map {X Y:Type} (f:X->Y)
  (xo:loption X) : loption Y :=
  match xo with
  | lNone _ => lNone'
  | lSome _ x => lSome' (f x)
  end.

Fixpoint fold {X Y:Type} (f:X->Y->Y)(l:llist X)(b:Y):Y:=
  match l with
  | lnil _ => b
  | lcons _ h t => f h (fold f t b)
  end.
Check (fold plus).
Eval simpl in (fold plus [1,2,3,4] 0).
Example fold_example1 : fold mult [1,2,3,4] 1 = 24.
Proof. reflexivity. Qed.
Example fold_example2 : fold andb [true,true,false,true] true = false.
Proof. reflexivity. Qed.
Example fold_example3 : fold lapp' [[1],[],[2,3],[4]] [] = [1,2,3,4].
Proof. reflexivity. Qed.

Definition constfun {X:Type} (x:X) : nat -> X :=
  fun (k:nat) => x.
Definition ftrue := constfun true.
Example constfun_example1 : ftrue 0 = true.
Proof. reflexivity. Qed.
Example constfun_example2 : (constfun 5) 99 = 5.
Proof. reflexivity. Qed.
Definition override {X:Type}(f:nat->X)(k:nat)(x:X)
  : nat->X :=
  fun (k':nat)=>if beq_nat k k' then x else f k'.
Definition fmostlytrue:=override (override ftrue 1 false)
  3 false.
Example override_example1 : fmostlytrue 0 = true.
Proof. reflexivity. Qed.
Example override_example2 : fmostlytrue 1 = false.
Proof. reflexivity. Qed.
Example override_example3 : fmostlytrue 2 = true.
Proof. reflexivity. Qed.
Example override_example4 : fmostlytrue 3 = false.
Proof. reflexivity. Qed.
Theorem override_example : forall (b:bool),
  (override (constfun b) 3 true) 2 = b.
Proof. reflexivity. Qed.
Theorem unfold_example:forall m n,
  3+n=m->plus3 n+1=m+1.
Proof. intros m n H. simpl. rewrite <- H.
reflexivity. Qed.
Theorem override_eq:forall {X:Type} x k(f:nat->X),
  (override f k x) k = x.
Proof. intros X x k f. unfold override.
rewrite beq_refl. reflexivity. Qed.
Theorem override_neq : forall {X:Type}
  x1 x2 k1 k2 (f : nat->X),
  f k1 = x1 ->
  beq_nat k2 k1 = false ->
  (override f k2 x2) k1 = x1.
Proof. intros X x1 x2 k1 k2 f H1 H2.
unfold override. rewrite H2. rewrite H1.
reflexivity. Qed.

Theorem eq_add_S:forall (n m:nat), S n=S m->n=m.
Proof. intros n m eq. inversion eq. reflexivity.
Qed.
Theorem silly4:forall (n m:nat),[n]=[m]->n=m.
Proof. intros n m eq. inversion eq. reflexivity.
Qed.
Theorem silly5:forall (n m o:nat),
  [n,m]=[o,o]->[n]=[m].
Proof. intros n m o eq. inversion eq.
reflexivity. Qed.
Example sillyex1 : forall (X : Type) (x y z : X)
 (l j : llist X),
     x :: y :: l = z :: j ->
     y :: l = x :: j ->
     x = y.
Proof. intros X x y z l j H1 H2.
inversion H1. inversion H2.
rewrite H0. reflexivity. Qed.
Theorem silly6 : forall (n : nat),
     S n = O ->
     2 + 2 = 5.
Proof. intros n H. inversion H. Qed.
Theorem silly7 : forall (n m : nat),
     false = true -> [n] = [m].
Proof. intros n m H. inversion H. Qed.
Example sillyex2 : forall (X : Type) (x y z : X) (l j : llist X),
     x :: y :: l = [] ->
     y :: l = z :: j ->
     x = z.
Proof. intros X x y z l j H1 H2. inversion H1. Qed.

Lemma eq_remove_S:forall n m, n=m->S n=S m.
Proof. intros n m H. inversion H. reflexivity. Qed.
Theorem beq_nat_eq:forall n m,
  true=beq_nat n m->n=m.
Proof. induction n. induction m. reflexivity.
simpl. intros H1. inversion H1. induction m.
simpl. intros H2. inversion H2. simpl.
intros H3. apply eq_remove_S. apply IHn.
apply H3. Qed.
Theorem beq_nat_eq':forall m n,
  beq_nat n m = true -> n = m.
Proof. intros m. induction m. destruct n.
reflexivity. simpl. intros H. inversion H.
destruct n. simpl. intros H. inversion H.
simpl. intros H. apply eq_remove_S.
apply IHm. apply H. Qed.
Theorem length_snoc':forall (X:Type)(v:X)
  (l:llist X)(n:nat),
  llength' l = n -> llength' (lsnoc' l v) = S n.
Proof. induction l. simpl. intros n H. inversion H.
reflexivity. simpl. intros n' H. apply eq_remove_S.
induction n'. inversion H.
assert (H1:l++[v]=lsnoc' l v). reflexivity.
apply IHl. inversion H. reflexivity. Qed.
Theorem length_snoc'':forall (X:Type)(v:X)
  (l:llist X)(n:nat),
  llength' l = n -> llength' (lsnoc' l v) = S n.
Proof. intros X v l. induction l. intros n eq.
rewrite <- eq. reflexivity. intros n eq.
simpl. destruct n. inversion eq.
apply eq_remove_S. apply IHl. inversion eq.
reflexivity. Qed.
Theorem beq_nat_0_l:forall n,
  true=beq_nat 0 n -> 0 = n.
Proof. induction n. reflexivity.
simpl. intros H. inversion H. Qed.
Theorem beq_nat_0_r:forall n,
  true=beq_nat n 0  -> 0 = n.
Proof. induction n. reflexivity.
simpl. intros H. inversion H. Qed.
Theorem double_injective : forall n m,
     double n = double m ->
     n = m.
Proof. induction n. simpl. intros m H.
destruct m. reflexivity. inversion H.
destruct m. simpl. intros H. inversion H.
simpl. intros H. apply eq_remove_S.
apply IHn. inversion H. reflexivity. Qed.

Theorem S_inj:forall (n m:nat) (b:bool),
  beq_nat (S n) (S m) = b ->
  beq_nat n m = b.
Proof. intros n m b H. simpl in H.
apply H. Qed.
Theorem silly3' : forall (n:nat),
(beq_nat n 5 = true -> beq_nat (S (S n)) 7 = true) ->
     true = beq_nat n 5 ->
     true = beq_nat (S (S n)) 7.
Proof. intros n H1 H2. symmetry in H2. apply H1 in H2.
symmetry in H2. apply H2. Qed.
Theorem plus_n_n_injection : forall n m,
  n+n=m+m->n=m.
Proof. induction n. simpl. destruct m. reflexivity.
simpl. intros H. inversion H. induction m as [|m'].
simpl. intros H. inversion H. intros H.
apply eq_remove_S. simpl in H. inversion H.
rewrite plus_comm in H1. symmetry in H1.
 rewrite plus_comm in H1. simpl in H1.
inversion H1. symmetry in H2. apply IHn.
apply H2. Qed.

Definition sillyfun (n : nat) : bool :=
  if beq_nat n 3 then false
  else if beq_nat n 5 then false
  else false.
Theorem sillyfun_false:forall (n:nat),
  sillyfun n = false.
Proof.
  intros n. unfold sillyfun.
  destruct (beq_nat n 3).
  reflexivity. destruct (beq_nat n 5).
  reflexivity. reflexivity.
Qed.
Theorem override_shadow:forall {X:Type} x1 x2 k1 k2
  (f:nat->X),
  (override (override f k1 x2) k1 x1) k2
  = (override f k1 x1) k2.
Proof.
  intros X x1 x2 k1 k2 f.
  unfold override.
  destruct (beq_nat k1 k2).
  reflexivity. reflexivity.
Qed.
Check @lsplit'.
Theorem lcombine_lsplit:forall (X Y:Type)(p:llist (X^Y)),
  lcombine' (lfst' (lsplit' p)) (lsnd' (lsplit' p)) = p.
Proof.
  intros X Y p. induction p.
  reflexivity. destruct x. simpl.
  rewrite IHp. reflexivity.
Qed.
Definition beq_lnil' {X:Type} (l:llist X) : bool :=
  match l with
  | lnil _ => true
  | lcons _ _ _ => false
  end.
Theorem lsplit_lcombine:forall (X Y:Type)(x:llist X)(y:llist Y),
  llength' x = llength' y ->
    lsplit' (lcombine' x y) = (x,y).
Proof.
  induction x. induction y. reflexivity.
  simpl. intros H. inversion H.
  induction y. simpl. intros H. inversion H.
  simpl. intros H. rewrite IHx. reflexivity.
  inversion H. reflexivity.
Qed.

Definition sillyfun1 (n:nat) : bool :=
  if beq_nat n 3 then true
  else if beq_nat n 5 then true
  else false.
Theorem sillyfun1_odd:forall (n:nat),
  sillyfun1 n = true ->
  oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  remember (beq_nat n 3) as e3.
  destruct e3. apply beq_nat_eq in Heqe3.
  rewrite Heqe3. reflexivity.
  remember (beq_nat n 5) as e5. destruct e5.
  apply beq_nat_eq in Heqe5.
  rewrite Heqe5. reflexivity.
  inversion eq.
Qed.
Theorem override_same:forall {X:Type} x1 k1 k2
  (f:nat->X), f k1 = x1 -> (override f k1 x1) k2 = f k2.
Proof.
  intros X x1 k1 k2 f eq.
  remember (beq_nat k1 k2) as keq.
  destruct keq. apply beq_nat_eq in Heqkeq.
  rewrite Heqkeq. unfold override.
  rewrite beq_refl. rewrite <- Heqkeq.
  symmetry in eq. apply eq.
  unfold override. rewrite <- Heqkeq.
  reflexivity.
Qed.
Theorem filter_exercise:forall (X:Type)(test:X->bool)
  (x:X)(l lf:llist X),
  filter test l = x :: lf -> test x = true.
Proof.
  induction l. intros lf H. inversion H.
  remember (test x0) as x0test.
  destruct x0test. simpl.
  rewrite <- Heqx0test. intros lf H.
  inversion H. rewrite <- H1. rewrite Heqx0test.
  reflexivity. simpl. rewrite <- Heqx0test.
  apply IHl.
Qed.

Theorem trans_eq:forall {X:Type} (n m o:X),
  n=m->m=o->n=o.
Proof.
  intros X n m o H1 H2. rewrite H1. rewrite H2. reflexivity.
Qed.
Example trans_eq_example:forall (a b c d e f:nat),
  [a,b]=[c,d]->[c,d]=[e,f]->[a,b]=[e,f].
Proof.
  intros a b c d e f H1 H2.
  apply trans_eq with (m:=[c,d]).
  apply H1. apply H2.
Qed.
Example trans_eq_exercise : forall (n m o p : nat),
     m = (minustwo o) ->
     (n + p) = m ->
     (n + p) = (minustwo o).
Proof.
  intros n m o p eq1 eq2.
  apply trans_eq with m.
  apply eq2. apply eq1.
Qed.
Theorem beq_nat_trans : forall n m p,
  true = beq_nat n m ->
  true = beq_nat m p ->
  true = beq_nat n p.
Proof.
  intros n m p eq1 eq2.
  apply beq_nat_eq in eq1.
  apply beq_nat_eq in eq2.
  rewrite eq1. rewrite eq2.
  symmetry.
  apply beq_refl.
Qed.
Theorem override_permute : forall {X:Type} x1 x2 k1 k2 k3 (f : nat->X),
  false = beq_nat k2 k1 ->
  (override (override f k2 x2) k1 x1) k3 = (override (override f k1 x1) k2 x2) k3.
Proof.
  intros X x1 x2 k1 k2 k3 f eq.
  unfold override.
  remember (beq_nat k1 k3) as k13.
  remember (beq_nat k2 k3) as k23.
  destruct k13. destruct k23.
  apply beq_nat_eq in Heqk23.
  apply beq_nat_eq in Heqk13.
  rewrite Heqk13 in eq.
  rewrite Heqk23 in eq.
  rewrite beq_refl in eq.
  inversion eq. reflexivity.
  reflexivity.
Qed.

Definition fold_length {X : Type} (l : llist X) : nat :=
  fold (fun _ n => S n) l 0.
Example test_fold_length1 : fold_length [4,7,0] = 3.
Proof. reflexivity. Qed.
Theorem fold_length_correct : forall X (l : llist X),
  fold_length l = llength' l.
Proof.
  induction l. reflexivity.
  simpl. rewrite <- IHl. reflexivity.
Qed.
Definition fold_map {X Y:Type} (f : X -> Y) (l : llist X) : llist Y :=
  fold (fun x yl => (f x)::yl) l [].
Theorem fold_map_correct : forall (X Y:Type) (f:X->Y) (l:llist X),
  fold_map f l = map f l.
Proof.
  induction l. reflexivity.
  simpl. rewrite <- IHl. reflexivity.
Qed.

Inductive mumble : Type :=
  | a : mumble
  | b : mumble -> nat -> mumble
  | c : mumble.
Inductive grumble (X:Type) : Type :=
  | d : mumble -> grumble X
  | e : X -> grumble X.

Fixpoint forallb {X:Type} (f:X->bool) (l:llist X) : bool :=
  match l with
  | lnil _ => true
  | lcons _ t h => andb (f t) (forallb f h)
  end.
Example forallb_test1 : forallb oddb [1,3,5,7,9] = true.
Proof. reflexivity. Qed.
Example forallb_test2 : forallb negb [false,false] = true.
Proof. reflexivity. Qed.
Example forallb_test3 : forallb evenb [0,2,4,5] = false.
Proof. reflexivity. Qed.
Example forallb_test4 : forallb (beq_nat 5) [] = true.
Proof. reflexivity. Qed.
Fixpoint existsb {X:Type} (f:X->bool) (l:llist X) : bool :=
  match l with
  | lnil _ => false
  | lcons _ t h => orb (f t) (existsb f h)
  end.
Example existsb_test1 : existsb (beq_nat 5) [0,2,3,6] = false.
Proof. reflexivity. Qed.
Example existsb_test2 : existsb (andb true) [true,true,false] = true.
Proof. reflexivity. Qed.
Example existsb_test3 : existsb oddb [1,0,0,0,0,3] = true.
Proof. reflexivity. Qed.
Example existsb_test4 : existsb evenb [] = false.
Proof. reflexivity. Qed.
Definition existsb' {X:Type} (f:X->bool) (l:llist X) : bool :=
  negb (forallb (fun x => negb (f x)) l).
Theorem existsb_correct : forall (X:Type) (f:X->bool) (l:llist X),
  existsb f l = existsb' f l.
Proof.
  induction l. reflexivity.
  simpl. rewrite IHl. unfold existsb'. simpl.
  remember (f x) as fx.
  destruct fx. reflexivity.
  reflexivity.
Qed.
End study03'.
End ImplicitTest.


Require Import Ashley.Axioms.
Require Import Ashley.Proposition.
Require Import Ashley.PartialOrder.

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

Notation "{ x : A | P }" := (fun x : A => P).

Lemma member_ext :  forall {A} a b, (forall x:A, a x <-> b x) -> a = b.
intros.
apply fun_ext.
intros.
apply prop_ext.
apply H.
Save.

Definition empty {A} := {x:A|False}.
Definition full {A} := {x:A|True}.
Definition singleton {A} p : set A := {x:A|x=p}.
Definition invert {A} p := {x:A|~ p x}.
Definition intersect {A} a b := {x:A|a x /\ b x}.
Definition union {A} a b := {x:A|a x \/ b x}.
Definition subset {A} (p : set A) (q : set A) := forall x, p x -> q x.

Definition superset {A} (p : set A) (q : set A) := subset q p.
Definition powerset {A} (p : set A) := {x:set A|x <= p}.

Definition not_empty {A} (p : set A) : Prop := exists x, p x.
Definition is_full {A} (p : set A) : Prop := forall x, p x.

Definition undisjoint {A} (a:set A) b : Prop := not_empty (intersect a b).
Definition disjoint {A} (a:set A) b : Prop := ~ undisjoint a b.

Lemma all_full : forall A (p : A), full p.
intros.
firstorder.
Save.

Lemma intersect_left_empty: forall A (p:set A), intersect empty p = empty.
intros.
apply member_ext.
firstorder.
Save.

Lemma intersect_right_empty: forall A (p:set A), intersect p empty = empty.
intros.
apply member_ext.
firstorder.
Save.

Lemma intersect_full_full : forall A, intersect (full:set A) full = full.
intros.
apply member_ext.
firstorder.
Save.

Lemma invert_union : forall (A:Type) (p : set A) (q : set A), invert (union p q) = intersect (invert p) (invert q).
intros.
apply member_ext.
firstorder.
Save.

Notation "'all' x : s , P" := (forall x, s x -> P) (at level 20, x at level 99).
Notation "'some' x : s , P" := (exists x, s x /\ P) (at level 20, x at level 99).

Definition Union {A} (p : set (set A)) : set A := {x:A|some s:p, s x}.

Lemma Union0: forall {A}, Union empty = (empty: set A).
intros.
unfold Union.
unfold empty.
apply member_ext.
firstorder.
Save.

Lemma Union1: forall {A} {p: set A}, Union (singleton p) = p.
intros.
apply member_ext.
unfold singleton.
firstorder.
rewrite <- H.
apply H0.
Save.
(*
Lemma UnionP1: forall {A} {pp: set (set A)} {q: set A}, Union (union pp (singleton q)) = union (Union pp) q.
intros.
unfold Union.
unfold union.
unfold singleton.
apply member_ext.
intros.
split.
intros.
destruct H.
destruct H.
firstorder.
exists x0.

left.

unfold some.
*)

Lemma Union2: forall {A} {p: set A} {q: set A}, Union {a : set A | a = p \/ a = q} = union p q.
intros.
unfold Union.
unfold union.
apply member_ext.
split.
intros.
destruct H.
destruct H.
destruct H.
left.
rewrite <- H.
apply H0.
right.
rewrite <- H.
apply H0.
intros.
destruct H.
exists p.
split.
left.
trivial.
apply H.
exists q.
split.
right.
trivial.
apply H.
Save.

Lemma member_powerset : forall A (a:set A) b, (powerset b) a <-> a <= b.
firstorder.
Save.

Definition comap {A} {B} (f : B -> A) (sa : set A): set B := {b:B | sa (f b)}.

Definition map {A} {B} (f : A -> B) (sa : set A): set B := {b:B| some a:sa, (f a = b)}.

Lemma map_union_powerset : forall A (a : set (set A)) (b : set (set A)), a <= b -> (map Union (powerset b)) (Union a).
firstorder.
Save.

Definition pair {A} p q: set A := {x:A|x=p \/ x=q}.

Lemma Union_pair: forall {A} (p q: set A), Union (pair p q) = union p q.
intros.
unfold Union.
unfold union.
unfold pair.
apply member_ext.
intros.
split.
intros.
destruct H.
destruct H.
case H.
intros.
left.
rewrite <- H1.
exact H0.
intros.
right.
rewrite <- H1.
exact H0.
intros.
case H.
intros.
exists p.
split.
left.
trivial.
exact H0.
intros.
exists q.
split.
right.
trivial.
exact H0.
Qed.

Lemma map_pair: forall {A} {B} (f: A -> B) (p q: A), map f (pair p q) = pair (f p) (f q).
intros.
unfold map.
unfold pair.
apply member_ext.
intros.
split.
intros.
destruct H.
destruct H.
case H.
intros.
left.
rewrite <- H0.
rewrite <- H1.
trivial.
intros.
right.
rewrite <- H0.
rewrite <- H1.
trivial.
intros.
case H.
intros.
exists p.
split.
left.
trivial.
rewrite <- H0.
trivial.
intros.
exists q.
split.
right.
trivial.
rewrite <- H0.
trivial.
Qed.

Lemma pair_same: forall {A} (x:A), pair x x = singleton x.
intros.
unfold pair.
unfold singleton.
apply member_ext.
intros.
firstorder.
Qed.


(* software foundation *)

Inductive day : Type :=
  | monday : day
  | tuesday : day
  | wednesday : day
  | thursday : day
  | friday : day
  | saturday : day
  | sunday : day.

Definition next_weekday (d:day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Eval compute in (next_weekday friday).
Eval compute in (next_weekday (next_weekday saturday)).

Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.

Proof.
simpl.
reflexivity.
Qed.

Inductive bool : Type :=
  |true : bool
  |false : bool.

Definition negb (b:bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition andb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Definition orb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => true
  | false => b2
  end.

Example test_orb1 : (orb true false) = true.
Proof. reflexivity. Qed.

Definition nandb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | false => true
  | true =>
    match b2 with
    | false => true
    | true => false
    end
  end.

Example test_nandb1: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb2: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb3: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
  match b1 with
  | false => false
  | true =>
      match b2 with
        |false => false
        |true => match b3 with
          |false => false
          |true => true
          end
        end
  end.

Example test_andb31: (andb3 true true true) = true.
Proof. simpl. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
Proof. simpl. reflexivity. Qed.

Module Playground1.

Inductive nat : Type :=
  | O : nat
  | S : nat -> nat.

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

End Playground1.

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

Check S (S (S (S 0))).

Eval compute in (minustwo 4).

Check S.
Check Playground1.nat.
Check minustwo.

Fixpoint evenb ( n : nat) : bool :=
  match n with
  | 0 => true
  | S 0 => false
  | S (S n') =>  evenb (n')
  end.

Eval compute in evenb (14).

Definition oddb (n : nat) : bool :=
  negb (evenb n).
Eval compute in oddb (13).

Example test_oddb1: (oddb (S O)) = true.
Proof. reflexivity. Qed.
Example test_oddb2: (oddb (S (S (S (S O))))) = false.
Proof. reflexivity. Qed.

(* excer *)

(* Module Playground2.*)

Fixpoint plus (n : nat) (m : nat) : nat :=
  match n with
    | O => m
    | S n' => S (plus n' m)
  end.

Eval compute in (plus (S (S (S O))) (S (S O))).

(* End Playground2. *)

Fixpoint mult (n m : nat) : nat :=
  match n with
  | 0 => 0
  | S n' => plus m (mult n' m)
  end.

Eval compute in (mult 3 4).

Example testMult1 : (mult 5 6) = 30.
Proof. reflexivity. Qed.

Fixpoint minus (n m : nat) : nat :=
  match n, m with
  | 0, _ => 0
  | S _, 0 => n
  | S n', S m' => minus n' m'
  end.

Eval compute in (minus 3 2).

Fixpoint exp (n m : nat) : nat :=
  match n, m with
  | _, 0 => 1
  | 0, _ => 0
  | (S n'), (S m') => (mult n (exp n m'))
  end.

Eval compute in (exp 3 4).

Fixpoint fac (n:nat) : nat :=
  match n with
  | 0 => 0
  | S 0 => 1
  | S n' => (mult n (fac n'))
  end.

Example testfac : (fac 3) = 6.
Proof. reflexivity. Qed.

Example testfac2 : (fac 4) = (mult 12 2).
Proof. reflexivity. Qed.

Notation "x +* y" := (exp x y)
(at level 50, left associativity) : nat_scope.

Check ((0+1) + 1).

Eval compute in ((2+*2) +* 2).

Fixpoint beq_nat (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => beq_nat n' m'
            end
  end.

Fixpoint ble_nat (n m : nat) : bool :=
  match n, m with
  | 0, 0 => true
  | S n', 0 => false
  | 0, S m' => true
  | S n', S m' => (ble_nat n' m')
  end.

Eval compute in (ble_nat 3 3).

Fixpoint blt_nat1 (n m : nat) : bool :=
  match n, m with
  | 0, 0 => false
  | S n', 0 => false
  | 0, S m' => true
  | S n', S m' => (blt_nat1 n' m')
  end.

Example tblt_nat1: (blt_nat1 2 2) = false.
Proof. reflexivity. Qed.
Example tblt_nat2: (blt_nat1 2 4) = true.
Proof. reflexivity. Qed.
Example tblt_nat3: (blt_nat1 4 2) = false.
Proof. reflexivity. Qed.

Theorem plus_id_1 : forall n m : nat,
  n = m ->
  n + m = m + n.

Proof.
  intros n m.
  intros H.
  rewrite -> H.
  reflexivity.
Qed.

Theorem plus_id_exercise : forall n m o : nat,
  n = m -> m = o -> n + m = m + o.

Proof.
  intros n m o.
  intros H.
  intros H1.
  rewrite <- H.
  rewrite <- H1.
  rewrite <- H.
  reflexivity.
Qed.

Theorem plus_0_n : forall n:nat,
  0 + n = n.

Proof.
  intros n.
  simpl.
  reflexivity.
Qed.

Theorem mult_0_plus : forall n m : nat,
  (0 + n) * m = n * m.

Proof.
  intros n m.
  rewrite -> plus_0_n.
  reflexivity.
Qed.

(* comment start 2 *)
Theorem mult_S_1 : forall n m : nat,
  m = S n ->
  m * (1 + n) = m * m.
Proof.
  intros n m.
  simpl.
  intros H.
  rewrite <- H.
  reflexivity.
Qed.

Fixpoint beq_nat1 (n m :nat) : bool :=
  match n, m with
  | 0, 0 => true
  | S n', 0 => false
  | 0, S m' => false
  | S n', S m' => (beq_nat1 n' m')
  end.

Eval compute in (beq_nat1 2 1).

Notation "x + y" := (plus x y)
(at level 50, left associativity) : nat_scope.

Theorem plus_1_neq_0_firsttry : forall n : nat,
  beq_nat1 (n + 1) 0 = false.
Proof.
  intros n.
  destruct n as [| n']. (* vars sep by | *)
  reflexivity.
  reflexivity.
Qed.

Theorem negb_involutive : forall b : bool,
  negb (negb b) = b.
Proof.
  intros b. destruct b.
    reflexivity.
    reflexivity. Qed.

Theorem zero_nbeq_plus_1 : forall n : nat,
  beq_nat 0 (n + 1) = false.
Proof.
  intros n.
  destruct n as [|n'].
  reflexivity.
  reflexivity.
Qed.

(* comment start 2 *)
Theorem identity_fn_applied_twice :
  forall(f : bool -> bool),
  (forall (x : bool), f x = x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros f.
  intros H.
  intros b.
  rewrite -> H.
  rewrite -> H.
  reflexivity.
Qed.

Example or_true_c :
  forall (c:bool),
  (orb true c) = true.

Proof.
  reflexivity.
Qed.

Lemma and_false_c :
  forall (c:bool),
  andb false c = false.

Proof.
  reflexivity.
Qed.

(* comment start 2 *)
Theorem andb_eq_orb :
  forall (b c : bool),
  (andb b c = orb b c) ->
  b = c.
Proof.
  destruct b.
  intros c.
  Focus 1.
  simpl.
  intros.
  rewrite <- H.
  reflexivity.
  intros c.
  rewrite -> and_false_c with c.
  simpl.
  intros h2.
  rewrite -> h2.
  reflexivity.
Qed.

Inductive bnat : Type :=
  | O : bnat (* 0 *)
  | T : bnat->bnat (* xxx0 *)
  | TI : bnat->bnat (* xxxx1 *).

Fixpoint incr (n:bnat) : bnat :=
  match n with
  | O => TI O
  | T n' => TI n'
  | TI n' => T (incr n')
  end.

Example test_bin_incr1:
  (incr O) = (TI O).

Proof. simpl. reflexivity. Qed.

Example test_bin_incr2:
  (incr (TI (TI O)))=(T (T (TI O))).
Proof. reflexivity. Qed.

Example test_bin_incr3:
  (incr (T (TI O)))=(TI (TI O)).
Proof. reflexivity. Qed.

Example test_bin_incr4:
  (incr (TI (T (TI O))))=(T (TI (TI O))).
Proof. reflexivity. Qed.

Example test_bin_incr5:
  (incr (TI (T (TI O))))=(T (TI (TI O))).
Proof. reflexivity. Qed.

Fixpoint lt (n m:nat) : bool :=
  match n, m with
  | 0, S m' => true
  | 0, 0 => false
  | S n', 0 => false
  | S n', S m' => lt n' m'
  end.

Fixpoint decrto1(n:nat) : nat :=
  match n with
  | 3 => 1
  | S n' =>(decrto1 n')
  | _ => 1
  end.

Eval compute in (decrto1 10).
Eval compute in (eq 10 10).

Fixpoint eq1 (n m:nat) : bool :=
  match n, m with
  | 0, 0 => true
  | S n', S m' => eq1 n' m'
  | _, _ => false
  end.

(* ill form
Fixpoint incrto(n:nat) : nat :=
  match n with
  | 10 => 11
  | 0 => 1
  | m' =>(incrto (S m'))
  end.
*)

(*
http://www.cis.upenn.edu/~bcpierce/sf/current/Induction.html#lab38
*)

Require String. Open Scope string_scope.
Ltac move_to_top x :=
  match reverse goal with
  | H : _ |-  _ => try move x after H
  end.

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

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

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

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


Require Import Nat Arith.

Inductive Nat : Type := succ : Nat -> Nat |  zero : Nat.

Inductive Lst : Type := cons : Nat -> Lst -> Lst |  nil : Lst.

Inductive Tree : Type := node : Nat -> Tree -> Tree -> Tree |  leaf : Tree.

Inductive Pair : Type := mkpair : Nat -> Nat -> Pair
with ZLst : Type := zcons : Pair -> ZLst -> ZLst |  znil : ZLst.

Fixpoint plus (plus_arg0 : Nat) (plus_arg1 : Nat) : Nat
           := match plus_arg0, plus_arg1 with
              | zero, n => n
              | succ n, m => succ (plus n m)
              end.

Fixpoint double (double_arg0 : Nat) : Nat
           := match double_arg0 with
              | zero => zero
              | succ n => succ (succ (double n))
              end.

Lemma lem: forall m n, succ (plus m n) = plus m (succ n).
Proof.
   induction m.
   - intros. simpl. rewrite IHm. reflexivity.
   - intros. reflexivity.
Qed.

Theorem theorem0 : forall (x : Nat), eq (double x) (plus x x).
Proof.
   induction x.
   - simpl. f_equal. rewrite IHx. apply lem.
   - reflexivity.
Qed.


Require Import Recdef Nat Lia.

Require Import List.
Import ListNotations.

From Equations Require Import Equations.

Unset Guard Checking.
Function euclid_mod (p q : nat) {struct p} : nat :=
match p with
| 0 => q
| _ => euclid_mod (modulo q p) p
end.
Set Guard Checking.

Compute euclid_mod 0 0.

Inductive euclid_mod_graph : nat -> nat -> nat -> Prop :=
| emg_0 : forall q : nat, euclid_mod_graph 0 q q
| emg_S : forall p q r : nat, euclid_mod_graph (modulo q p) p r -> euclid_mod_graph p q r.

Inductive euclid_mod_graph' : Type :=
| emg_0' : forall q : nat, euclid_mod_graph'
| emg_S' : forall p q r : nat, euclid_mod_graph' -> euclid_mod_graph'.

From Equations Require Import Equations.

(* Equations? euclid_sub (p q : nat) {_ : p <> 0} {_ : q <> 0} : nat by wf (p + q) lt :=
| p, q with (PeanoNat.Nat.compare_spec p q) => {
  | CompLt H => euclid_sub p (q - p)
  | @CompEq H => p
  | CompGt H => euclid_sub (p - q) q }.
Next Obligation. *)

Fixpoint euclid_sub (pq : nat * nat) {Hp : fst pq <> 0} {Hq : snd pq <> 0} {struct pq} : nat.
Proof.
refine (
match Compare_dec.lt_eq_lt_dec (fst pq) (snd pq) with
| inleft (left H) => @euclid_sub (fst pq, snd pq - fst pq) Hp ltac:(cbn; lia)
| inleft (right _) => fst pq
| inright H => @euclid_sub (fst pq - snd pq, snd pq) ltac:(cbn; lia) Hq
end).
Abort.

Function euclid_sub (pq : nat * nat) {Hp : fst pq <> 0} {Hq : snd pq <> 0}
  {measure (fun '(p, q) => p + q) pq} : nat :=
match Compare_dec.lt_eq_lt_dec (fst pq) (snd pq) with
| inleft (left H) => @euclid_sub (fst pq, snd pq - fst pq) Hp ltac:(cbn; lia)
| inleft (right _) => fst pq
| inright H => @euclid_sub (fst pq - snd pq, snd pq) ltac:(cbn; lia) Hq
end.
Proof.
  - intros [p q] **; simpl in *; lia.
  - intros [p q] **; simpl in *; lia.
Defined.


Module Type Typ.
  Parameter Inline(10) T : Type.
End Typ.

Module Type HasBinOperation(Import M : Typ).
  Parameter f : T -> T -> T.
End HasBinOperation.

Module Type Magma <: Typ := Typ <+ HasBinOperation.

Module Type IsAssociative(Import M : Magma).
  Axiom assoc : forall (a b c : T), f (f a b) c = f a (f b c).
End IsAssociative.

Module Type Semigroup <: Magma := Magma <+ IsAssociative.

Module Type HasUnit(Import M : Magma).
  Parameter u : T.
  Axiom ru : forall a : T, (f a u) = a.
  Axiom lu : forall a : T, (f u a) = a.
End HasUnit.

Module Type UnitalMagma <: Magma := Magma <+ HasUnit.

Module Type Monoid <: Semigroup :=  Semigroup <+ HasUnit.

Module MonoidExample : Monoid.
  Definition T := nat.
  Definition f := plus.

  Lemma assoc : forall (a b c : T), f (f a b) c = f a (f b c).
    intros. unfold f. induction a as [| a' IHa].
    { reflexivity. }
    { simpl. apply f_equal, IHa. }
  Qed.

  Definition u := 0.

  Lemma ru : forall a : T, (f a u) = a.
  Proof. intros. unfold f. unfold u. rewrite <- plus_n_O. reflexivity. Qed.

  Lemma lu : forall a : T, (f u a) = a.
  Proof. intros. unfold f, u. reflexivity. Qed.
End MonoidExample.

Module Type HasInverse(Import M : UnitalMagma).
  Parameter inv : T -> T.
  Axiom r_inv : forall a : T, f a (inv a) = u.
  Axiom l_inv : forall a : T, f (inv a) a = u.
End HasInverse.

Module Type IsCommutative(Import M : Magma).
  Axiom comm : forall a b : T, f a b = f b a.
End IsCommutative.

Module Type Group <: Monoid := Monoid <+ HasInverse.

Module Type AbelianGroup <: Group := Group <+ IsCommutative.


Require Import Ensembles.

Record Ring : Type := mkRing {
  number : Type;
  plus : number -> number -> number;
  mult : number -> number -> number;
  zero : number;
  one : number;
  inv : number -> number;
  plus_inv : forall n : number, plus n (inv n) = zero;
  plus_zero : forall n : number, plus n zero = n;
  plus_assoc : forall (a : number) (b : number) (c : number), plus (plus a b) c = plus a (plus b c);
  plus_rev : forall (a : number) (b : number), plus a b = plus b a;
  mult_assoc : forall (a : number) (b : number) (c : number), mult (mult a b) c = mult a (mult b c);
  mult_dist : forall (a : number) (b : number) (c : number), mult a (plus b c) = plus (mult a b) (mult a c);
  mult_rev : forall (a : number) (b : number), mult a b = mult b a;
  mult_one : forall (a : number), mult a one = a;
}.

Set Implicit Arguments.

Arguments plus {r}.
Arguments mult {r}.
Arguments zero {r}.
Arguments one {r}.
Arguments inv {r}.
Arguments plus_inv {r}.
Arguments plus_zero {r}.
Arguments plus_assoc {r}.
Arguments plus_rev {r}.
Arguments mult_assoc {r}.
Arguments mult_dist {r}.
Arguments mult_rev {r}.
Arguments mult_one {r}.

Proposition prop_mult_zero : forall (X : Ring) (x : number X), mult x zero = zero.
Proof.
intros.
assert (mult (plus zero zero) x = mult zero x).
rewrite (plus_zero zero).
reflexivity.
rewrite (mult_rev) in H.
rewrite (mult_dist) in H.
assert (plus (plus (mult x zero) (mult x zero)) (inv (mult x zero)) = plus (mult zero x) (inv (mult zero x))).
rewrite H.
rewrite (mult_rev x zero).
reflexivity.
rewrite (plus_assoc (mult x zero) (mult x zero) (inv (mult x zero))) in H0.
rewrite (plus_inv (mult x zero)) in H0.
rewrite (plus_zero) in H0.
rewrite plus_inv in H0.
trivial.
Qed.

Proposition prop_mult_inv : forall (X : Ring) (x : number X), mult x (inv one) = inv x.
Proof.
intros.
assert (H := prop_mult_zero X x).
rewrite <- (plus_inv one) in H at 1.
rewrite <- (plus_inv x) in H at 1.
rewrite mult_dist in H.
apply (f_equal (fun t => plus (inv x) t)) in H.
rewrite (mult_one) in H.
rewrite <- (plus_assoc) in H.
rewrite (plus_rev (inv x) x) in H.
rewrite plus_inv in H.
rewrite (plus_rev) in H.
rewrite (plus_zero) in H.
rewrite (plus_zero) in H.
trivial.
Qed.

Definition principal_ideal := (fun (X : Ring) (x : number X) => (fun a => exists k : number X, a = mult k x)).

Definition ideal := (fun (X : Ring) (a : Ensemble (number X)) => (forall x y, a x -> a y -> a (plus x y)) /\ (forall x y, a y -> a (mult x y)) /\ Inhabited (number X) a).

Definition unit := (fun (X : Ring) (a : number X) => exists b, mult a b = one).

Arguments principal_ideal {X}.
Arguments ideal {X}.
Arguments unit {X}.

Definition injective := (fun (X : Type) (Y : Type) (F : X -> Y) => forall x y, F x = F y -> x = y).

Definition reverse := (fun (X : Type) (Y : Type) (F : X -> Y) (G : Y -> X) => forall x, F (G x) = x).

Definition mapring_plus : forall (X : Ring) (T:Type) (F : T -> number X) (G : number X -> T),
  T -> T -> T
:= fun X T F G X0 X1 => G (plus (F X0) (F X1)).

Definition mapring_mult : forall (X : Ring) (T:Type) (F : T -> number X) (G : number X -> T),
  T -> T -> T
:= fun X T F G X0 X1 => G (mult (F X0) (F X1)).

Definition mapring_zero : forall (X : Ring) (T:Type) (G : number X -> T),
  T
:= fun X T G => G zero.

Definition mapring_one : forall (X : Ring) (T:Type) (G : number X -> T),
  T
:= fun X T G => G one.

Definition mapring_inv : forall (X : Ring) (T:Type) (F : T -> number X) (G : number X -> T),
  T -> T
:= fun X T F G X0 => G (inv (F X0)).

Arguments mapring_plus {X T}.
Arguments mapring_mult {X T}.
Arguments mapring_zero {X T}.
Arguments mapring_one {X T}.
Arguments mapring_inv {X T}.

Proposition mapring_plus_inv : forall (X : Ring) (T:Type) (F : T -> number X) (G : number X -> T) (rev : reverse F G) (n : T),
  mapring_plus F G n (mapring_inv F G n) = mapring_zero G.
Proof.
intros.
unfold mapring_plus.
unfold mapring_inv.
unfold mapring_zero.
unfold reverse in rev.
rewrite (rev (inv (F n))).
rewrite plus_inv.
reflexivity.
Qed.

Proposition mapring_plus_zero : forall (X : Ring) (T:Type) (F : T -> number X) (G : number X -> T) (rev1 : reverse F G) (rev2 : reverse G F) (n : T),
  mapring_plus F G n (mapring_zero G) = n.
Proof.
intros.
unfold mapring_plus.
unfold mapring_zero.
rewrite (rev1 zero).
rewrite plus_zero.
rewrite rev2.
reflexivity.
Qed.

Proposition mapring_plus_assoc : forall (X : Ring) (T:Type) (F : T -> number X) (G : number X -> T) (rev : reverse F G) (p : T) (q : T) (r : T),
  mapring_plus F G (mapring_plus F G p q) r = mapring_plus F G p (mapring_plus F G q r).
Proof.
intros.
unfold mapring_plus.
rewrite rev.
rewrite rev.
rewrite plus_assoc.
reflexivity.
Qed.

Proposition mapring_plus_rev : forall (X : Ring) (T:Type) (F : T -> number X) (G : number X -> T) (p : T) (q : T),
  mapring_plus F G p q = mapring_plus F G q p.
Proof.
intros.
unfold mapring_plus.
rewrite plus_rev.
reflexivity.
Qed.

Proposition mapring_mult_assoc : forall (X : Ring) (T:Type) (F : T -> number X) (G : number X -> T) (rev : reverse F G) (p : T) (q : T) (r : T),
  mapring_mult F G (mapring_mult F G p q) r = mapring_mult F G p (mapring_mult F G q r).
Proof.
intros.
unfold mapring_mult.
rewrite rev.
rewrite rev.
rewrite mult_assoc.
reflexivity.
Qed.

Proposition mapring_mult_dist : forall (X : Ring) (T:Type) (F : T -> number X) (G : number X -> T) (rev : reverse F G) (p : T) (q : T) (r : T),
  mapring_mult F G p (mapring_plus F G q r) = mapring_plus F G (mapring_mult F G p q) (mapring_mult F G p r).
Proof.
intros.
unfold mapring_mult.
unfold mapring_plus.
rewrite rev.
rewrite rev.
rewrite rev.
rewrite mult_dist.
reflexivity.
Qed.

Proposition mapring_mult_rev : forall (X : Ring) (T:Type) (F : T -> number X) (G : number X -> T) (p : T) (q : T),
  mapring_mult F G p q = mapring_mult F G q p.
Proof.
intros.
unfold mapring_mult.
rewrite mult_rev.
reflexivity.
Qed.

Proposition mapring_mult_one : forall (X : Ring) (T:Type) (F : T -> number X) (G : number X -> T) (rev1 : reverse F G) (rev2 : reverse G F) (n : T),
  mapring_mult F G n (mapring_one G) = n.
Proof.
intros.
unfold mapring_mult.
unfold mapring_one.
rewrite rev1.
rewrite mult_one.
rewrite rev2.
reflexivity.
Qed.

Arguments mapring_plus_inv {X T}.
Arguments mapring_plus_zero {X T}.
Arguments mapring_plus_assoc {X T}.
Arguments mapring_plus_rev {X T}.
Arguments mapring_mult_assoc {X T}.
Arguments mapring_mult_dist {X T}.
Arguments mapring_mult_rev {X T}.
Arguments mapring_mult_one {X T}.

Definition mapring := (fun (X : Ring) (T:Type) (F : T -> number X) (G : number X -> T) (rev1 : reverse F G) (rev2 : reverse G F) =>
  mkRing
  T
  (mapring_plus F G)
  (mapring_mult F G)
  (mapring_zero G)
  (mapring_one G)
  (mapring_inv F G)
  (mapring_plus_inv F G rev1)
  (mapring_plus_zero F G rev1 rev2)
  (mapring_plus_assoc F G rev1)
  (mapring_plus_rev F G)
  (mapring_mult_assoc F G rev1)
  (mapring_mult_dist F G rev1)
  (mapring_mult_rev F G)
  (mapring_mult_one F G rev1 rev2)
).

Definition mapring_wo_rev2 := (fun (X : Ring) (T:Type) (F : T -> number X) (G : number X -> T) (rev1 : reverse F G)
    (p_plus_zero : forall n, mapring_plus F G n (mapring_zero G) = n)
    (p_mult_one : forall n, mapring_mult F G n (mapring_one G) = n) =>
  mkRing
  T
  (mapring_plus F G)
  (mapring_mult F G)
  (mapring_zero G)
  (mapring_one G)
  (mapring_inv F G)
  (mapring_plus_inv F G rev1)
  (p_plus_zero)
  (mapring_plus_assoc F G rev1)
  (mapring_plus_rev F G)
  (mapring_mult_assoc F G rev1)
  (mapring_mult_dist F G rev1)
  (mapring_mult_rev F G)
  (p_mult_one)
).

Proposition principal_ideal_is_ideal : forall (X : Ring) (x : number X), ideal (principal_ideal x).
Proof.
intros.
unfold ideal.
constructor.
intros.
unfold principal_ideal.
unfold principal_ideal in H.
unfold principal_ideal in H0.
destruct H.
destruct H0.
exists (plus x1 x2).
rewrite mult_rev.
rewrite mult_dist.
rewrite H.
rewrite H0.
rewrite (mult_rev x1 x).
rewrite (mult_rev x2 x).
reflexivity.
split.
intros.
unfold principal_ideal in H.
unfold principal_ideal.
destruct H.
exists (mult x0 x1).
rewrite H.
rewrite mult_assoc.
reflexivity.
exists x.
exists one.
rewrite mult_rev.
rewrite mult_one.
trivial.
Qed.

Proposition unit_principal_ideal_full_set : forall {X : Ring} (x : number X), (exists y, mult x y = one) <-> (principal_ideal x) = Full_set (number X).
Proof.
intros.
split.
intros.
apply Extensionality_Ensembles.
unfold Same_set.
unfold Included.
constructor.
intros.
unfold In.
apply Full_intro.
intros.
unfold In.
destruct H.
unfold In in H0.
exists (mult x0 x1).
rewrite (mult_assoc x0 x1 x).
rewrite (mult_rev x1 x).
rewrite H.
rewrite mult_one.
reflexivity.
intros.
assert ((Full_set (number X)) one).
apply Full_intro.
rewrite <- H in H0.
destruct H0.
exists x0.
rewrite mult_rev in H0.
rewrite H0.
reflexivity.
Qed.

Proposition principal_ideal_included : forall (X : Ring) (a :  Ensemble (number X)) (t :  number X), ideal a -> a t -> Included (number X) (principal_ideal t) a.
Proof.
intros.
unfold Included.
intros.
unfold In.
unfold In in H1.
unfold principal_ideal in H1.
destruct H1.
unfold ideal in H.
destruct H.
destruct H2.
assert (H4 := H2 x0 t H0).
rewrite <- H1 in H4.
trivial.
Qed.

Definition field := (fun (X : Ring) => (one : number X) <> zero /\ forall x : number X, x <> zero -> unit x).

Definition homomorphism := (fun (X : Ring) (Y : Ring) (f : number X -> number Y) =>
  (forall (x : number X) (y : number X), f(plus x y) = plus (f x) (f y)) /\
  (forall (x : number X) (y : number X), f(mult x y) = mult (f x) (f y)) /\
  (f(one) = one)
).

Arguments homomorphism {X} {Y}.

Proposition prop_homomorphism_zero : forall (X : Ring) (Y : Ring) (F : number X -> number Y), homomorphism F -> F zero = zero.
Proof.
intros.
unfold homomorphism in H.
destruct H.
destruct H0.
assert (H2 := H1).
rewrite <- (plus_zero one) in H2.
rewrite H in H2.
rewrite H1 in H2.
apply (f_equal (fun t => plus t (inv one))) in H2.
rewrite plus_inv in H2.
rewrite plus_rev in H2.
rewrite <- plus_assoc in H2.
rewrite (plus_rev (inv one) one) in H2.
rewrite plus_inv in H2.
rewrite plus_rev in H2.
rewrite plus_zero in H2.
trivial.
Qed.

Definition kernel := (fun (X : Ring) (Y : Ring) (F : number X -> number Y) => (fun t => F t = zero)).

Arguments kernel {X Y}.

Proposition prop_hom_inv : forall (X : Ring) (Y : Ring) (F : number X -> number Y), homomorphism F -> forall t, inv (F t) = F (inv t).
Proof.
intros.
assert (HHom := H).
unfold homomorphism in H.
destruct H.
destruct H0.
assert (zero = plus (F t) (F (inv t))).
rewrite <- H.
rewrite plus_inv.
rewrite prop_homomorphism_zero.
reflexivity.
apply HHom.
apply (f_equal (fun v => plus v (inv (F t)))) in H2.
rewrite plus_rev in H2.
rewrite plus_zero in H2.
rewrite plus_assoc in H2.
rewrite plus_rev in H2 at 1.
rewrite plus_assoc in H2.
rewrite (plus_rev (inv (F t)) (F t)) in H2.
rewrite plus_inv in H2.
rewrite plus_zero in H2.
trivial.
Qed.

Proposition prop_1_2_a4 : forall (X : Ring) (Y : Ring) (F : number X -> number Y), homomorphism F -> kernel F = Singleton (number X) zero -> injective F.
Proof.
intros.
assert (HHom := H).
unfold injective.
intros.
unfold kernel in H0.
unfold homomorphism in H.
destruct H.
destruct H2.
apply (f_equal (fun t => plus t (inv (F y)))) in H1.
rewrite plus_inv in H1.
rewrite (prop_hom_inv) in H1.
rewrite <- H in H1.
assert (plus x (inv y) = zero).
assert ((fun t : number X => F t = zero) (plus x (inv y))).
trivial.
rewrite H0 in H4.
destruct H4.
reflexivity.
apply (f_equal (fun v => plus v y)) in H4.
rewrite plus_assoc in H4.
rewrite (plus_rev (inv y) y) in H4.
rewrite plus_inv in H4.
rewrite (plus_rev zero y) in H4.
rewrite plus_zero in H4.
rewrite plus_zero in H4.
trivial.
trivial.
Qed.

Definition ring_nonzero := (fun X => exists x : number X, x <> zero).
Definition ring_zero := (fun X => forall x : number X, x = zero).

Require Import Coq.Logic.Classical_Pred_Type.

Proposition no_empty_exists : forall (T : Type) (a : Ensemble T), a <> Empty_set _ -> exists l, a l.
intros.
apply not_all_not_ex.
intro.
apply H.
apply Extensionality_Ensembles.
red.
split.
intro.
intro.
apply False_ind.
apply ((H0 x) H1).
intro.
intro.
destruct H1.
Qed.

Proposition no_empty_no_singleton_element : forall (T : Type) (a : Ensemble T) (k : T), a <> Empty_set _ -> a <> Singleton _ k -> exists l, a l /\ l <> k.
intros.
apply not_all_not_ex.
intro.
assert (exists e, a e).
apply no_empty_exists.
trivial.
destruct H2.
apply H0.
apply Extensionality_Ensembles.
red.
split.
intro.
intro.
assert (H4 := H1 x0).
apply NNPP.
intro.
apply H4.
split.
trivial.
intro.
rewrite H6 in H5.
apply H5.
constructor.
intro.
intro.
rewrite H3 in H1.
case (classic (x = x0)).
intro.
rewrite H4 in H2.
trivial.
intro.
apply False_ind.
apply (H1 x).
auto.
Qed.

Proposition prop_1_2_1 : forall (X : Ring), field X -> forall (a :  Ensemble (number X)), ideal a -> (a = Singleton (number X) zero \/ a = Full_set (number X)).
Proof.
intros.
assert (ide := H0).
unfold ideal in H0.
unfold field in H.
destruct H.
unfold unit in H1.
case (classic (a = Singleton (number X) zero)).
intros.
left.
trivial.
intros.
right.
destruct H0.
destruct H3.
assert (a <> Empty_set _).
intro.
rewrite H5 in H4.
destruct H4.
destruct H4.
assert (H6 := no_empty_no_singleton_element H5 H2).
destruct H6.
destruct H6.
apply Extensionality_Ensembles.
red.
split.
intro.
intro.
constructor.
assert (principal_ideal x = Full_set (number X)).
apply unit_principal_ideal_full_set.
auto.
rewrite <- H8.
apply principal_ideal_included.
trivial.
trivial.
Qed.

Proposition prop_1_2_2 :  forall (X : Ring), (forall a : Ensemble(number X), ideal a -> (a = Singleton (number X) zero \/ a = Full_set (number X))) -> forall (Y : Ring) (F : number X -> number Y), (exists (t : number Y), t <> zero) -> homomorphism F -> injective F.
Proof.
intros.
assert (HomF := H1).
destruct H1.
destruct H2.
destruct H0.
assert (H5 := H (kernel F)).
assert (ideal (kernel F)).
unfold ideal.
constructor.
intros.
unfold kernel.
rewrite H1.
rewrite H4.
rewrite H6.
apply plus_zero.
split.
intros.
unfold kernel.
rewrite H2.
rewrite H4.
apply prop_mult_zero.
exists zero.
apply prop_homomorphism_zero.
apply HomF.
assert (H6 := H5 H4).
case H6.
intro.
apply (prop_1_2_a4).
trivial.
trivial.
unfold injective.
unfold kernel.
intros.
assert (Full_set (number X) one).
apply Full_intro.
rewrite <- H7 in H9.
rewrite H3 in H9.
rewrite <- (mult_one x) in H0.
rewrite H9 in H0.
rewrite prop_mult_zero in H0.
apply False_ind.
apply H0.
reflexivity.
Qed.

Proposition prop_one_eq_zero : forall (X : Ring), (one : number X) = zero -> ring_zero X.
Proof.
intros.
intro.
assert (mult x one = mult x one).
reflexivity.
rewrite H in H0 at 2.
rewrite mult_one in H0.
rewrite prop_mult_zero in H0.
trivial.
Qed.

Proposition prop_ring_zero_nonzero_contradiction : forall (X : Ring), ring_nonzero X -> ring_zero X -> False.
Proof.
intros.
destruct H.
assert (H1 := H0 x).
apply (H H1).
Qed.

Proposition prop_1_2_3 : forall (X : Ring), ring_nonzero X -> (forall (Y : Ring) (F : number X -> number Y), (ring_nonzero Y) -> homomorphism F -> injective F) -> field X.
Proof.
intros.
constructor.
intro.
assert (H2 := prop_one_eq_zero X H1).
apply (prop_ring_zero_nonzero_contradiction H H2).
intros.
unfold unit.
unfold injective in H0.
apply not_all_not_ex.
intro.
apply H1.

assert (H3 := H0 (quotient_ring X (principal_ideal x)) (fun x => mkQuot _ x)).
simpl in H3.
unfold principal_ideal in H3.
unfold ring_nonzero in H3.
unfold quotient_ring in H3.
simpl in H3.
apply H1.
apply H3.
clear H3.
exists (mkQuot _ x).
unfold quotient_zero.
intro.
assert (H4 := f_equal (fun t => deQuot t) H3).
simpl in H4.
contradiction.
unfold homomorphism.
simpl.
split.
intros.
reflexivity.
split.
intros.
reflexivity.
unfold quotient_one.
reflexivity.


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

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

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 plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) : natural
           := match mult_arg0, mult_arg1 with
              | Zero, n => Zero
              | Succ n, m => plus (mult n m) m
              end.

Fixpoint exp (exp_arg0 : natural) (exp_arg1 : natural) : natural
           := match exp_arg0, exp_arg1 with
              | n, Zero => Succ Zero
              | n, Succ m => mult (exp n m) n
              end.

Fixpoint qexp (qexp_arg0 : natural) (qexp_arg1 : natural) (qexp_arg2 : natural) : natural
           := match qexp_arg0, qexp_arg1, qexp_arg2 with
              | n, Zero, m => m
              | n, Succ m, p => qexp n m (mult p n)
              end.
Lemma plus_succ : forall (x y : natural), plus x (Succ y) = Succ (plus x y).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_assoc : forall (x y z : natural), plus (plus x y) z = plus x (plus y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_zero : forall (x : natural), plus x Zero = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_commut : forall (x y : natural), plus x y = plus y x.
Proof.
   intros.
   induction x.
   - rewrite plus_zero. reflexivity.
   - simpl. rewrite plus_succ. rewrite IHx. reflexivity.
Qed.

Lemma mult_zero : forall (x : natural), mult x Zero = Zero.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma mult_succ : forall (x y : natural), plus (mult x y) x = mult x (Succ y).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite plus_succ. rewrite plus_assoc. rewrite (plus_commut y x). rewrite <- plus_assoc. rewrite IHx. rewrite plus_succ. reflexivity.
Qed.

Lemma mult_commut : forall (x y : natural), mult x y = mult y x.
Proof.
   intros.
   induction x.
   - rewrite mult_zero. reflexivity.
   - simpl. rewrite IHx. rewrite mult_succ. reflexivity.
Qed.

Lemma distrib : forall (x y z : natural), mult (plus x y) z = plus (mult x z) (mult y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl.  rewrite IHx.  rewrite plus_assoc. lfind.  rewrite <- plus_assoc.  reflexivity.
Admitted.

Lemma mult_assoc : forall (x y z : natural), mult (mult x y) z = mult x (mult y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite distrib. rewrite IHx. reflexivity.
Qed.

Theorem mult_qexp : forall (x y z a : natural), mult (qexp x y z) a = qexp x y (mult z a).
Proof.
   intros x y.
   induction y.
   - reflexivity.
   - intros. simpl. rewrite IHy. rewrite mult_assoc. rewrite (mult_commut x a).
     rewrite <- mult_assoc. reflexivity.
Qed.

Theorem exp_eq_qexp : forall (x : natural) (y : natural), eq (exp x y) (qexp x y (Succ Zero)).
Proof.
   intros.
   induction y.
   - reflexivity.
   - simpl. rewrite IHy. rewrite mult_qexp. reflexivity.
Qed.


Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.ZArith.BinInt.
Require Import Lia ssreflect.
Open Scope Z_scope.

Definition list_max_Z : list Z -> Z := fold_right Z.max 0.

Lemma list_max_Z_spec : forall l,
  let max_val := list_max_Z l in
  Forall (fun x => x <= max_val) l /\
  (In max_val l \/ max_val = 0).
Proof.
  intros.
  subst max_val.
  split.
  - induction l; [easy|].
    apply Forall_cons.
    + simpl.
      unfold Z.max.
      destruct (a ?= list_max_Z l) eqn:H; [easy| |easy].
      rewrite Z.compare_lt_iff in H.
      lia.
    + simpl.
      unfold Z.max.
      destruct (a ?= list_max_Z l) eqn:H.
      * rewrite Z.compare_eq_iff in H.
        rewrite H.
        exact IHl.
      * exact IHl.
      * rewrite Z.compare_gt_iff in H.
        apply Forall_forall.
        intros.
        rewrite Forall_forall in IHl.
        pose proof (IHl x).
        pose proof (H1 H0).
        pose proof (Z.le_lt_trans _ _ _ H2 H).
        lia.
  - induction l.
    + right. easy.
    + destruct IHl.
      * simpl.
        unfold Z.max.
        destruct (a ?= list_max_Z l).
        -- left. left. reflexivity.
        -- left. right. exact H.
        -- left. left. reflexivity.
      * simpl.
        unfold Z.max.
        destruct (a ?= list_max_Z l) eqn:H0.
        -- right.
            rewrite Z.compare_eq_iff in H0.
            congruence.
        -- right. exact H.
        -- left. left. reflexivity.
  (* Show Proof. *)
Qed.

Lemma list_max_Z_spec2 : forall l,
  let max_val := list_max_Z l in
  Forall (fun x => x <= max_val) l /\
  (In max_val l \/ max_val = 0).
Proof.
  intros.
  subst max_val.
  split.
  - apply Forall_forall.
    intros x I.
    induction l.
    + simpl in I. contradiction.
    + simpl in *.
      destruct I as [-> | J].
      lia.
      pose proof (IHl J).
      lia.
  - induction l.
    simpl.
    right.
    reflexivity.
    simpl in *.
    destruct IHl;
    pose proof (Z.max_spec_le a (list_max_Z l));
    destruct H0 as [[L ->] | [A B]].
    auto.
    auto.
    auto.
    auto.

Abort.

Lemma list_max_Z_spec3 : forall l,
  let max_val := list_max_Z l in
  Forall (fun x => x <= max_val) l /\
  (In max_val l \/ max_val = 0).
Proof.
  move => l /=; split.
  - rewrite Forall_forall => x.
    by elim: l => //= h t IH [-> | /IH]; lia.
  - elim: l => //= [| h t]; first by right.
    by case: (Z.max_spec_le h (list_max_Z t)) => [] [H] -> []; auto.
    (* Show Proof. *)
Qed.

Lemma list_max_Z_spec4 : forall l,
  let max_val := list_max_Z l in
  Forall (fun x => x <= max_val) l /\
  (In max_val l \/ max_val = 0).
Proof.
  move => l /=; split.
  - rewrite Forall_forall => x.
    elim: l => //=.
    move=> h t IH.
    case=> [-> | /IH].
    lia.
    lia.
  - elim: l => //= [| h t]; first by right.
    by case: (Z.max_spec_le h (list_max_Z t)) => [] [H] -> []; auto.
    (* Show Proof. *)
Qed.


From Hammer Require Import Hammer.

Require Import PeanoNat Even.

Local Open Scope nat_scope.

Implicit Type n : nat.

Notation div2 := Nat.div2 (compat "8.4").

Lemma ind_0_1_SS :
forall P:nat -> Prop,
P 0 -> P 1 -> (forall n, P n -> P (S (S n))) -> forall n, P n.
Proof. hammer_hook "Div2" "Div2.ind_0_1_SS".
intros P H0 H1 H2.
fix 1.
destruct n as [|[|n]].
- exact H0.
- exact H1.
- apply H2, ind_0_1_SS.
Qed.

Lemma lt_div2 n : 0 < n -> div2 n < n.
Proof. hammer_hook "Div2" "Div2.lt_div2".   apply Nat.lt_div2. Qed.

Hint Resolve lt_div2: arith.

Lemma even_div2 n : even n -> div2 n = div2 (S n).
Proof. hammer_hook "Div2" "Div2.even_div2".
rewrite Even.even_equiv. intros (p,->).
rewrite Nat.div2_succ_double. apply Nat.div2_double.
Qed.

Lemma odd_div2 n : odd n -> S (div2 n) = div2 (S n).
Proof. hammer_hook "Div2" "Div2.odd_div2".
rewrite Even.odd_equiv. intros (p,->).
rewrite Nat.add_1_r, Nat.div2_succ_double.
simpl. f_equal. symmetry. apply Nat.div2_double.
Qed.

Lemma div2_even n : div2 n = div2 (S n) -> even n.
Proof. hammer_hook "Div2" "Div2.div2_even".
destruct (even_or_odd n) as [Ev|Od]; trivial.
apply odd_div2 in Od. rewrite <- Od. intro Od'.
elim (n_Sn _ Od').
Qed.

Lemma div2_odd n : S (div2 n) = div2 (S n) -> odd n.
Proof. hammer_hook "Div2" "Div2.div2_odd".
destruct (even_or_odd n) as [Ev|Od]; trivial.
apply even_div2 in Ev. rewrite <- Ev. intro Ev'.
symmetry in Ev'. elim (n_Sn _ Ev').
Qed.

Hint Resolve even_div2 div2_even odd_div2 div2_odd: arith.

Lemma even_odd_div2 n :
(even n <-> div2 n = div2 (S n)) /\
(odd n <-> S (div2 n) = div2 (S n)).
Proof. hammer_hook "Div2" "Div2.even_odd_div2".
split; split; auto using div2_odd, div2_even, odd_div2, even_div2.
Qed.

Notation double := Nat.double (compat "8.4").

Hint Unfold double Nat.double: arith.

Lemma double_S n : double (S n) = S (S (double n)).
Proof. hammer_hook "Div2" "Div2.double_S".
apply Nat.add_succ_r.
Qed.

Lemma double_plus n m : double (n + m) = double n + double m.
Proof. hammer_hook "Div2" "Div2.double_plus".
apply Nat.add_shuffle1.
Qed.

Hint Resolve double_S: arith.

Lemma even_odd_double n :
(even n <-> n = double (div2 n)) /\ (odd n <-> n = S (double (div2 n))).
Proof. hammer_hook "Div2" "Div2.even_odd_double".
revert n. fix 1. destruct n as [|[|n]].
-
split; split; auto with arith. inversion 1.
-
split; split; auto with arith. inversion_clear 1. inversion H0.
-
destruct (even_odd_double n) as ((Ev,Ev'),(Od,Od')).
split; split; simpl div2; rewrite ?double_S.
+ inversion_clear 1. inversion_clear H0. auto.
+ injection 1. auto with arith.
+ inversion_clear 1. inversion_clear H0. auto.
+ injection 1. auto with arith.
Qed.

Lemma even_double n : even n -> n = double (div2 n).
Proof. hammer_hook "Div2" "Div2.even_double".  exact (proj1 (proj1 (even_odd_double n))). Qed.

Lemma double_even n : n = double (div2 n) -> even n.
Proof. hammer_hook "Div2" "Div2.double_even".  exact (proj2 (proj1 (even_odd_double n))). Qed.

Lemma odd_double n : odd n -> n = S (double (div2 n)).
Proof. hammer_hook "Div2" "Div2.odd_double".  exact (proj1 (proj2 (even_odd_double n))). Qed.

Lemma double_odd n : n = S (double (div2 n)) -> odd n.
Proof. hammer_hook "Div2" "Div2.double_odd".  exact (proj2 (proj2 (even_odd_double n))). Qed.

Hint Resolve even_double double_even odd_double double_odd: arith.

Lemma even_2n : forall n, even n -> {p : nat | n = double p}.
Proof. hammer_hook "Div2" "Div2.even_2n".
intros n H. exists (div2 n). auto with arith.
Defined.

Lemma odd_S2n : forall n, odd n -> {p : nat | n = S (double p)}.
Proof. hammer_hook "Div2" "Div2.odd_S2n".
intros n H. exists (div2 n). auto with arith.
Defined.

Lemma div2_double n : div2 (2*n) = n.
Proof. hammer_hook "Div2" "Div2.div2_double".   apply Nat.div2_double. Qed.

Lemma div2_double_plus_one n : div2 (S (2*n)) = n.
Proof. hammer_hook "Div2" "Div2.div2_double_plus_one".   apply Nat.div2_succ_double. Qed.


Require Import Arith.

Goal forall x y, x < y -> x + 10 < y + 10.
Proof.
  intros.
  apply plus_lt_compat_r.
  exact H.
Qed.


(* Exercise 76 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

Hypothesis Domain : exists x1 : D, exists x2 : D, exists x3 : D,
  forall x : D, (x = x1 \/ x = x2 \/ x = x3).

Theorem exercise_076 : (forall x : D, exists y : D, P x \/ P y) -> exists x : D, P x.
Proof.
exi_e (exists x1 : D, exists x2 : D, exists x3 : D,
  forall x : D, (x = x1 \/ x = x2 \/ x = x3)) a a1.
  hyp Domain.
exi_e (exists x2 : D, exists x3 : D,
  forall x : D, (x = a \/ x = x2 \/ x = x3)) b a2.
  hyp a1.
exi_e (exists x3 : D,
  forall x : D, (x = a \/ x = b \/ x = x3)) c a3.
  hyp a2.
imp_i a4.
exi_e (exists y:D, P a \/ P y) d a5.
all_e (forall x:D, exists y:D, P x \/ P y) a.
hyp a4.
dis_e (P a \/ P d) a6 a6.
hyp a5.
exi_i a.
hyp a6.
dis_e (d = a \/ d = b \/ d = c) a7 a7.
all_e (forall x : D, x = a \/ x = b \/ x = c) d.
hyp a3.
exi_i d.
hyp a6.
exi_i d.
hyp a6.
Qed.