(* Exercise 29 *)

Require Import BenB.

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

Theorem exercise_029 : (forall y, (exists x, (P y -> Q x)) -> (P y -> exists x, Q x)).
Proof.
all_i a.
imp_i a1.
imp_i a2.
exi_e (exists x:D, P a -> Q x) b a3.
hyp a1.
exi_i b.
imp_e (P a).
hyp a3.
hyp a2.
Qed.


Require Import SetoidClass SetoidCat Monoid Algebra.SetoidCat.NatUtils.

Section NatMonoid.

  Open Scope nat_scope.

  Lemma nat_plus_associativity : forall a b c, a + b + c = a + (b + c).
  Proof.
    intros. induction a. reflexivity.
    simpl. congruence.
  Qed.

  Instance nat_Monoid : @Monoid nat natS.
  Proof.
    exists (0) (plusS).
    intros. reflexivity.
    intros. rewrite plus_n_O. reflexivity.
    intros. apply nat_plus_associativity.
  Defined.

End NatMonoid.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.

(* Why3 assumption *)
Definition even (n:Z): Prop := exists k:Z, (n = (2%Z * k)%Z).

(* Why3 assumption *)
Definition odd (n:Z): Prop := exists k:Z, (n = ((2%Z * k)%Z + 1%Z)%Z).

Lemma even_is_Zeven :
  forall n, even n <-> Zeven n.
Proof.
intros n.
refine (conj _ (Zeven_ex n)).
intros (k,H).
rewrite H.
apply Zeven_2p.
Qed.

Lemma odd_is_Zodd :
  forall n, odd n <-> Zodd n.
Proof.
intros n.
refine (conj _ (Zodd_ex n)).
intros (k,H).
rewrite H.
apply Zodd_2p_plus_1.
Qed.

(* Why3 goal *)
Lemma even_or_odd : forall (n:Z), (even n) \/ (odd n).
Proof.
intros n.
destruct (Zeven_odd_dec n).
left.
now apply <- even_is_Zeven.
right.
now apply <- odd_is_Zodd.
Qed.

(* Why3 goal *)
Lemma even_not_odd : forall (n:Z), (even n) -> ~ (odd n).
Proof.
intros n H1 H2.
apply (Zeven_not_Zodd n).
now apply -> even_is_Zeven.
now apply -> odd_is_Zodd.
Qed.

(* Why3 goal *)
Lemma odd_not_even : forall (n:Z), (odd n) -> ~ (even n).
Proof.
intros n H1.
contradict H1.
now apply even_not_odd.
Qed.

(* Why3 goal *)
Lemma even_odd : forall (n:Z), (even n) -> (odd (n + 1%Z)%Z).
Proof.
intros n H.
apply <- odd_is_Zodd.
apply Zeven_plus_Zodd.
now apply -> even_is_Zeven.
easy.
Qed.

(* Why3 goal *)
Lemma odd_even : forall (n:Z), (odd n) -> (even (n + 1%Z)%Z).
Proof.
intros n H.
apply <- even_is_Zeven.
apply Zodd_plus_Zodd.
now apply -> odd_is_Zodd.
easy.
Qed.

(* Why3 goal *)
Lemma even_even : forall (n:Z), (even n) -> (even (n + 2%Z)%Z).
Proof.
intros n H.
apply <- even_is_Zeven.
apply Zeven_plus_Zeven.
now apply -> even_is_Zeven.
easy.
Qed.

(* Why3 goal *)
Lemma odd_odd : forall (n:Z), (odd n) -> (odd (n + 2%Z)%Z).
Proof.
intros n H.
apply <- odd_is_Zodd.
apply Zodd_plus_Zeven.
now apply -> odd_is_Zodd.
easy.
Qed.

(* Why3 goal *)
Lemma even_2k : forall (k:Z), (even (2%Z * k)%Z).
Proof.
intros k.
now exists k.
Qed.

(* Why3 goal *)
Lemma odd_2k1 : forall (k:Z), (odd ((2%Z * k)%Z + 1%Z)%Z).
Proof.
intros k.
now exists k.
Qed.


Require Import Omega.
Require Import prelims.
Require Import repeater.
Require Import increasing_expanding.
Require Import inverse.
Require Import countdown.

(*
===================================================================================
*************** SECTION 6: INVERSE HYPEROPS, DIVISION, LOG AND LOG* ***************
===================================================================================
 *)

(*
 * We use countdown to implement an inverse tower for the Hyperoperation.
 * Interestingly, the 2nd, 3rd and 4th levels of this tower correspond to
 * divcision, logc base b and log* base b, which are not defined in the
 * Coq Standard Library.
 *
 * Our definitions, which use countdown, offer enough versatility and
 * flexibility to substantiate easy and direct proof for a vast range
 * of facts about these functions.
 *)

(* ****** INVERSE-HYPEROP TOWER ****** *)

Fixpoint inv_hyperop a n b :=
  match n with
  | 0 => b - 1
  | S n' =>
    countdown_to (inv_hyperop a n') (hyperop_init a n') b
  end.

(* Handy results to transform goals involving inv_hyperop *)
Theorem inv_hyperop_recursion :
  forall n a,
    inv_hyperop a (S n) = countdown_to (inv_hyperop a n) (hyperop_init a n).
Proof. trivial. Qed.

(* Several results about first few levels of inv_hyperop.
   Used to prove correctness of divcision and logc later on. *)

Theorem inv_hyperop_0_contract_strict :
  forall a k, contract_strict_above k (inv_hyperop a 0).
Proof. intro a. split; intro n; simpl; omega. Qed.

Theorem inv_hyperop_1 :
  forall a b, inv_hyperop a 1 b = b - a.
Proof.
  intros a b. rewrite inv_hyperop_recursion. remember (b - a) as m.
  generalize dependent b. induction m.
  - intros b Hb. apply countdown_recursion.
    1: apply inv_hyperop_0_contract_strict.
       unfold hyperop_init; omega.
  - intros b Hb. remember (m + a) as n. rewrite <- (IHm n) by omega.
    replace n with (inv_hyperop a 0 b)
        by (simpl; unfold hyperop_init; omega).
    apply countdown_recursion.
    1: apply inv_hyperop_0_contract_strict.
    unfold hyperop_init; omega.
Qed.

Corollary inv_hyperop_1_repeat :
  forall a k m, repeat (inv_hyperop a 1) k m = m - k * a.
Proof.
  intros a k m. induction k; [simpl; omega|].
  remember (inv_hyperop a 1) as f. simpl.
  rewrite IHk, Heqf, inv_hyperop_1; omega.
Qed.

(*
 * Main theorem of this section.
 * Establishes the correctness of the inverse hyperoperations'
 * definition given in inv_hyperop.v
 *)
Theorem inv_hyperop_correct :
  forall a n, 2 <= a -> upp_inv_rel (inv_hyperop a n) (hyperop a n).
Proof.
  intros a n Ha.
  assert (forall m, repeatable_from (hyperop_init a m) (hyperop a m)).
  { induction m.
    1: rewrite repeatable_simpl; split; simpl;
      try split; try intros u v; omega.
    destruct m; try destruct m.
    1, 3: try replace (hyperop a (S (S (S m)))) with
            (repeater_from (hyperop a (S (S m)))
               (hyperop_init a (S (S m)))) by trivial;
      apply repeater_repeatable; simpl; try omega; assumption.
    rewrite repeatable_simpl. split; [|simpl; omega].
    intros u v. repeat rewrite hyperop_2. intros.
    apply (mult_lt_compat_r _ _ _ H). omega.
  }
  induction n.
  1: simpl. intros u v. omega.
  destruct (H n) as [_ Hn].
  apply countdown_repeater_upp_inverse; assumption.
Qed.

(* ****** DIVISION AND LOGARITHM ********************************* *)

(* Computes ceiling of b / a *)
Definition divc a b := inv_hyperop a 2 b.

Theorem divc_correct :
  forall a b m, 1 <= a -> divc a b <= m <-> b <= m * a.
Proof.
  intros a b m Ha. destruct a; [omega|].
  unfold divc. rewrite inv_hyperop_recursion.
  rewrite countdown_repeat
      by (split; intro n; rewrite inv_hyperop_1; omega).
  rewrite inv_hyperop_1_repeat. unfold hyperop_init. omega.
Qed.

(* Computes ceiling of logc_a(b) *)
Definition logc a b := inv_hyperop a 3 b.

Theorem logc_correct :
  forall a b m, 2 <= a -> logc a b <= m <-> b <= a ^ m.
Proof.
  intros a b m Ha.
  unfold logc. rewrite <- hyperop_3.
  apply inv_hyperop_correct; trivial.
Qed.

(* Computes log*_a(b).
   Its correctness has already been established in inv_hyperop_correct *)
Definition logstar a b := inv_hyperop a 4 b.


From mathcomp Require Import all_ssreflect.

(** Elements *)

Definition elements {A} (f : _ -> A) n :=
  let l := iota 0 n.+1 in zip l (map f l).

(** Triangular number *)
Definition delta n := (n.+1 * n)./2.

Compute elements delta 10.

(** Hints : halfD half_bit_double *)
Lemma deltaS n : delta n.+1 = delta n + n.+1.
Admitted.

(** Hints   big_ord_recr big_ord_recl big_ord0 *)
Lemma deltaE n : delta n = \sum_(i < n.+1) i.
Admitted.

(* Hints half_leq *)
Lemma leq_delta m n : m <= n -> delta m <= delta n.
Admitted.

(** Hints sqrnD *)
Lemma delta_square n : (8 * delta n).+1 = n.*2.+1 ^ 2.
Admitted.

(**  Triangular root *)
Definition troot n :=
 let l := iota 0 n.+2 in
 (find (fun x => n < delta x) l).-1.

Compute elements troot 10.

Lemma troot_gt0 n : 0 < n -> 0 < troot n.
Admitted.

(** Hints before_find find_size size_iota nth_iota *)
Lemma leq_delta_root m : delta (troot m) <= m.
Admitted.

(** Hints hasP mem_iota half_bit_double half_leq nth_find nth_iota *)
Lemma ltn_delta_root m : m < delta (troot m).+1.
Admitted.

Lemma leq_root_delta m n : (n <= troot m) = (delta n <= m).
Admitted.

Lemma leq_troot m n : m <= n -> troot m <= troot n.
Admitted.

Lemma trootE m n : (troot m == n) = (delta n <= m < delta n.+1).
Admitted.

Lemma troot_deltaK n : troot (delta n) = n.
Admitted.

(**  The modulo for triangular numbers *)
Definition tmod n := n - delta (troot n).

Lemma tmod_delta n : tmod (delta n) = 0.
Admitted.

Lemma tmodE n : n = delta (troot n) + tmod n.
Admitted.

Lemma leq_tmod_troot n : tmod n <= troot n.
Admitted.

Lemma ltn_troot m n : troot m < troot n -> m < n.
Admitted.

Lemma leq_tmod m n : troot m = troot n -> (tmod m <= tmod n) = (m <= n).
Admitted.

Lemma leq_troot_mod m n :
   m <= n =
   ((troot m < troot n) || ((troot m == troot n) && (tmod m <= tmod n))).
Admitted.

(** Fermat Numbers *)

Definition fermat n := (2 ^ (2 ^ n)).+1.

Compute elements (prime \o fermat) 4.

(** Hints : subn_sqr subnBA odd_double_half *)
Lemma dvd_exp_odd a k :  0 < a -> odd k -> a.+1 %| (a ^ k).+1.
Admitted.

(** Hints: logn_gt0 mem_primes dvdn2 *)
Lemma odd_log_eq0 n : 0 < n -> logn 2 n = 0 -> odd n.
Admitted.

(** Hints pfactor_dvdnn logn_div pfactorK *)
Lemma odd_div_log n : 0 < n -> odd (n %/ 2 ^ logn 2 n).
Admitted.

(** Hints divnK pfactor_dvdnn prime_nt_dvdP prime_nt_dvdP *)
Lemma prime_2expS m : 0 < m -> prime (2 ^ m).+1 -> m = 2 ^ logn 2 m.
Admitted.

(** Hints odd_exp neq_ltn expn_gt0 *)
Lemma odd_fermat n : odd (fermat n).
Admitted.

(** Hint subn_sqr *)
Lemma dvdn_exp2m1 a k : a.+1 %| (a ^ (2 ^ k.+1)).-1.
Admitted.

Lemma fermat_gt1 n : 1 < fermat n.
Admitted.

(** Hints subnK expnD expnM *)
Lemma dvdn_fermat m n : m < n -> fermat m %| (fermat n).-2.
Admitted.

(** Hints gcdnMDl coprimen2 *)
Lemma coprime_fermat m n : m < n -> coprime (fermat m) (fermat n).
Admitted.


Module prop.

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

  Lemma three_isB : isB 3.
  Proof.
    apply b_3.
  Qed.

  Lemma five_isB : isB 5.
  Proof.
    apply b_5.
  Qed.

  Theorem eight_isB : isB 8.
  Proof.
    apply b_sum with (n:=3) (m:=5).
    apply b_3. apply b_5.
  Qed.

  Theorem beautiful_plus_eight: forall n, isB n -> isB (8+n).
  Proof.
    intros n H.
    apply b_sum.
    apply eight_isB.
    apply H.
  Qed.

  Theorem b_timesm: forall n m: nat, isB n -> isB (m*n).
  Proof.
    intros n m H.
    induction m.
    simpl. apply b_0.
    simpl.
    apply b_sum.
    apply H.
    apply IHm.
  Qed.

  Inductive gor : nat -> Prop :=
  | g_0 : gor 0
  | g_3: forall n, gor n -> gor (3+n)
  | g_5: forall n, gor n -> gor (5+n).

  Lemma gb : forall n, gor n -> isB n.
  Proof.
    intros n H.
    induction H.
    apply b_0. apply b_sum. apply b_3. apply IHgor.
    apply b_sum. apply b_5. apply IHgor.
  Qed.

  Lemma gs : forall n m:nat, gor n -> gor m -> gor (n+m).
  Proof.
    intros n m H H0.
    induction H.
    apply H0.
    apply g_3. apply IHgor.
    apply g_5. apply IHgor.
  Qed.

  Theorem bg: forall n:nat, isB n -> gor n.
  Proof.
    intros n H.
    induction H.
    apply g_0. apply g_3. apply g_0. apply g_5. apply g_0.
    apply gs. apply IHisB1. apply IHisB2.
  Qed.

  Theorem andb : forall n m, isB n -> isB m -> isB n /\ isB m.
  Proof.
    intros n m H H0.
    apply conj. apply H. apply H0. (* We can just use auto here! *)
  Qed.

  (* This theorem cannot be proven in Coq. I think! *)
  Theorem impor: forall P Q: Prop, P -> Q -> ~ P \/ Q.
    intros P Q H.
    apply or_intror with (A:=Q) in H.
    apply or_comm in H.
    admit.
  Qed.

End prop.


(* Listes *)

Inductive liste : Type :=
| nil : liste
| C : nat -> liste -> liste.

(* Question 13 *)
(* Définition de la fonction longueur *)
Fixpoint longueur (l: liste ) : nat :=
  match l with
  | nil => 0
  | C a l => 1 + longueur l
  end.

(* Question 14 *)
(* Définition de la fonction concat *)

Fixpoint concat (l r: liste ) : liste  :=
  match l with
  | nil => r
  | C a l => C a (concat l r)
  end.

Compute  (concat  (C 2 nil) (C 3 nil)).

(* Question 15 *)

Theorem long (l m : liste) : longueur(concat l m) = longueur l + longueur m.
Proof.
induction l.
reflexivity.
simpl.
rewrite IHl.
reflexivity.
Qed.

(* Question 16 *)
(* Définition de la fonction ajoutqueue *)
Fixpoint ajoutqueue (a:nat) (l:liste ) : liste  :=
  match l with
  | nil => C a nil
  | C a l => C a (ajoutqueue a l)
  end.

(* Question 17 *)
Theorem lgajout (x : nat) (l : liste) : longueur(ajoutqueue x l) = 1 + longueur l.
Proof.
Admitted.


From mathcomp
  Require Import ssreflect ssrnat.

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

Section Logic.

Lemma contrap : forall A B : Prop, (A -> B) -> (~B -> ~A).
Proof.
rewrite /not.
move => A0 B0 AtoB notB.
by move /AtoB.
Qed.

Variables A B C : Prop.

Lemma AndOrDistL : (A /\ C) \/ (B /\ C) <-> (A \/ B) /\ C.
Proof.
rewrite /iff.
apply: conj.
-case.
 +case=> AisTrue CisTrue.
  by apply: conj; [apply: or_introl | ].
 +case=> BisTrue CisTrue.
  by apply: conj; [apply: or_intror | ].
-case=> AorBisTrue CisTrue.
 case: AorBisTrue => [AisTrue | BisTrue].
 +by apply: or_introl.
 +by apply: or_intror.
Qed.

Lemma JDM (T : Type) (P : T -> Prop) :
  ~(exists (x : T), P x) <-> forall x, ~(P x).
Proof.
apply: conj => Hyp.
-move=> x0 HPx0.
 apply: Hyp.
 by apply: (ex_intro P x0).
-by case.
Qed.

Hypothesis ExMidLaw : forall P : Prop, P \/ ~P.

Lemma notnotEq (P : Prop) : ~ ~ P -> P.
Proof.
move=> HnotnotP.
-case: (ExMidLaw (~ P)).
 +by move /HnotnotP.
 +by case: (ExMidLaw P).
Qed.

End Logic.


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

(** ** Euclidian division and Bezout's identity *)

Require Import List Arith Omega Permutation.

Require Import utils_tac utils_list.

Set Implicit Arguments.

Section Euclid.

  Definition euclid n d : d <> 0 -> { q : nat & { r | n = q*d+r /\ r < d } }.
  Proof.
    intros Hd.
    induction on n as IHn with measure n.
    destruct (le_lt_dec d n) as [ H | H ].
    + destruct (IHn (n-d)) as (q & r & H1 & H2).
      * omega.
      * exists (S q), r; split; auto; simpl; omega.
    + exists 0, n; split; auto; simpl; omega.
  Qed.

End Euclid.

Definition arem n d q j := j <= d /\ (n = 2*q*d+j \/ q <> 0 /\ n = 2*q*d-j).

Fact division_by_even n d : d <> 0 -> { q : nat & { j | arem n d q j } }.
Proof.
  intros Hd.
  destruct (@euclid n (2*d)) as (q & r & H1 & H2); try omega.
  destruct (le_lt_dec r d) as [ Hr | Hr ].
  + exists q, r; split; auto; left.
    rewrite H1; ring.
  + exists (S q), (2*d-r); split; try omega; right.
    split; try omega.
    rewrite H1.
    replace (2*(S q)*d) with (q*(2*d) + 2 * d) by ring.
    omega.
Qed.

Fact own_multiple x p : x = p*x -> x = 0 \/ p = 1.
Proof.
  destruct x as [ | x ].
  + left; trivial.
  + right.
    destruct p as [ | [ | p ] ].
    - simpl in H; discriminate.
    - trivial.
    - exfalso; revert H.
      do 2 (rewrite mult_comm; simpl).
      generalize (p*x); intros; omega.
Qed.

Fact mult_is_one p q : p*q = 1 -> p = 1 /\ q = 1.
Proof.
  destruct p as [ | [ | p ] ].
  + simpl; discriminate.
  + simpl; omega.
  + rewrite mult_comm.
    destruct q as [ | [ | q ] ].
    - simpl; discriminate.
    - simpl; omega.
    - simpl; discriminate.
Qed.

Definition divides n k := exists p, k = p*n.

Section divides.

  Infix "div" := divides (at level 70, no associativity).

  Fact divides_refl x : x div x.
  Proof. exists 1; simpl; omega. Qed.

  Fact divides_anti x y : x div y -> y div x -> x = y.
  Proof.
    intros (p & H1) (q & H2).
    rewrite H1, mult_assoc in H2.
    apply own_multiple in H2.
    destruct H2 as [ H2 | H2 ].
    + subst; rewrite mult_comm; auto.
    + apply mult_is_one in H2; destruct H2; subst; omega.
  Qed.

  Fact divides_trans x y z : x div y -> y div z -> x div z.
  Proof.
    intros (p & H1) (q & H2).
    exists (q*p); rewrite <- mult_assoc, <- H1; auto.
  Qed.

  Fact divides_0 p : p div 0.
  Proof. exists 0; auto. Qed.

  Fact divides_0_inv p : 0 div p -> p = 0.
  Proof. intros (?&?); subst; rewrite Nat.mul_0_r; auto. Qed.

  Fact divides_1 p : 1 div p.
  Proof. exists p; rewrite mult_comm; simpl; auto. Qed.

  Fact divides_1_inv p : p div 1 -> p = 1.
  Proof.
    intros (q & Hq).
    apply mult_is_one with q; auto.
  Qed.

  Fact divides_2_inv p : p div 2 -> p = 1 \/ p = 2.
  Proof.
    intros ([ | k ] & Hk); try discriminate.
    destruct p as [ | [ | [|] ] ]; try omega.
    rewrite mult_comm in Hk; simpl in Hk.
    contradict Hk; generalize (n*S k); intros; omega.
  Qed.

  Fact divides_mult p q k : p div q -> p div k*q.
  Proof.
    intros (r & ?); subst.
    exists (k*r); rewrite mult_assoc; auto.
  Qed.

  Fact divides_mult_r p q k : p div q -> p div q*k.
  Proof.
    rewrite mult_comm; apply divides_mult; auto.
  Qed.

  Fact divides_mult_compat a b c d : a div b -> c div d -> a*c div b*d.
  Proof.
    intros (u & ?) (v & ?); exists (u*v); subst.
    repeat rewrite mult_assoc; f_equal.
    repeat rewrite <- mult_assoc; f_equal.
    apply mult_comm.
  Qed.

  Fact divides_minus p q1 q2 : p div q1 -> p div q2 -> p div q1 - q2.
  Proof.
    intros (s1 & H1) (s2 & H2).
    exists (s1 - s2).
    rewrite Nat.mul_sub_distr_r; omega.
  Qed.

  Fact divides_plus p q1 q2 : p div q1 -> p div q2 -> p div q1+q2.
  Proof.
    intros (s1 & H1) (s2 & H2).
    exists (s1 + s2).
    rewrite Nat.mul_add_distr_r; omega.
  Qed.

  Fact divides_plus_inv p q1 q2 : p div q1 -> p div q1+q2 -> p div q2.
  Proof.
     intros H1 H2.
     replace q2 with (q1+q2-q1) by omega.
     apply divides_minus; auto.
  Qed.

  Fact divides_le p q : q <> 0 -> p div q -> p <= q.
  Proof.
    intros H (k & Hk); subst.
    destruct k.
    + destruct H; auto.
    + simpl; generalize (k*p); intros; omega.
  Qed.

  Fact divides_mult_inv k p q : k <> 0 -> k*p div k*q -> p div q.
  Proof.
    intros H (n & Hn); exists n.
    apply Nat.mul_cancel_r with (1 := H).
    rewrite mult_comm, Hn; ring.
  Qed.

  Lemma divides_fact m p : 1 < p <= m -> p div fact m.
  Proof.
    intros (H1 & H2); induction H2.
    + destruct p; cbn. omega. unfold divides. exists (fact p). ring.
    + cbn. eauto using divides_plus, divides_mult.
  Qed.

  Lemma divides_mult_inv_l p q r : p * q div r -> p div r /\ q div r.
  Proof.
    intros []; split; subst.
    - exists (x * q); ring.
    - exists (x * p); ring.
  Qed.

End divides.

Section gcd_lcm.

  Infix "div" := divides (at level 70, no associativity).

  Hint Resolve divides_0 divides_refl divides_mult divides_1.

  Definition is_gcd p q r := r div p /\ r div q /\ forall k, k div p -> k div q -> k div r.
  Definition is_lcm p q r := p div r /\ q div r /\ forall k, p div k -> q div k -> r div k.

  Fact is_gcd_sym p q r : is_gcd p q r -> is_gcd q p r.
  Proof. intros (? & ? & ?); repeat split; auto. Qed.

  Fact is_gcd_0l p : is_gcd 0 p p.
  Proof. repeat split; auto. Qed.

  Fact is_gcd_0r p : is_gcd p 0 p.
  Proof. repeat split; auto. Qed.

  Fact is_gcd_1l p : is_gcd 1 p 1.
  Proof. repeat split; auto. Qed.

  Fact is_gcd_1r p : is_gcd p 1 1.
  Proof. repeat split; auto. Qed.

  Fact is_gcd_modulus p q k r : p div k -> k <= q -> is_gcd p q r -> is_gcd p (q-k) r.
  Proof.
    intros (n & Hn) Hq (H1 & H2 & H3); subst.
    split; auto.
    split.
    + apply divides_minus; auto.
    + intros k H4 H5.
      apply H3; auto.
      replace q with (q - n*p + n*p) by omega.
      apply divides_plus; auto.
  Qed.

  Fact is_gcd_minus p q r : p <= q -> is_gcd p q r -> is_gcd p (q-p) r.
  Proof. intros H1; apply is_gcd_modulus; auto. Qed.

  Hint Resolve divides_plus.

  Fact is_gcd_moduplus p q k r : p div k -> is_gcd p q r -> is_gcd p (q+k) r.
  Proof.
    intros (n & Hn) (H1 & H2 & H3); subst.
    repeat (split; auto).
    intros k H4 H5.
    apply H3; auto.
    rewrite plus_comm in H5.
    apply divides_plus_inv with (2 := H5); auto.
  Qed.

  Fact is_gcd_plus p q r : is_gcd p q r -> is_gcd p (q+p) r.
  Proof. apply is_gcd_moduplus; auto. Qed.

  Fact is_gcd_mult p q r n : is_gcd p (n*p+q) r <-> is_gcd p q r.
  Proof.
    split.
    + replace q with ((n*p+q)-n*p) at 2 by omega.
      apply is_gcd_modulus; auto; omega.
    + rewrite plus_comm; apply is_gcd_moduplus; auto.
  Qed.

  Fact is_gcd_div p q : p div q -> is_gcd p q p.
  Proof. intros (?&?); subst; split; auto. Qed.

  Fact is_gcd_refl p : is_gcd p p p.
  Proof. split; auto. Qed.

  Fact is_gcd_fun p q r1 r2 : is_gcd p q r1 -> is_gcd p q r2 -> r1 = r2.
  Proof. intros (?&?&?) (?&?&?); apply divides_anti; auto. Qed.

  Fact is_lcm_0l p : is_lcm 0 p 0.
  Proof. repeat split; auto. Qed.

  Fact is_lcm_0r p : is_lcm p 0 0.
  Proof. repeat split; auto. Qed.

  Fact is_lcm_sym p q r : is_lcm p q r -> is_lcm q p r.
  Proof. intros (?&?&?); repeat split; auto. Qed.

  Fact is_lcm_fun p q r1 r2 : is_lcm p q r1 -> is_lcm p q r2 -> r1 = r2.
  Proof. intros (?&?&?) (?&?&?); apply divides_anti; auto. Qed.

End gcd_lcm.

Section bezout.

  Infix "div" := divides (at level 70, no associativity).

  Hint Resolve is_gcd_0l is_gcd_0r is_lcm_0l is_lcm_0r divides_refl divides_mult divides_0 is_gcd_minus.

  Section bezout_rel_prime.

    Let bezout_rec p q : 0 < p < q -> is_gcd p q 1 -> exists a b, a*p+b*q = 1+p*q /\ a <= q /\ b <= p.
    Proof.
      revert p.
      induction on q as IHq with measure q; intros p (Hp & Hq) H.
      destruct (@euclid q p) as (n & r & H1 & H2); try omega.
      destruct (eq_nat_dec r 0) as [ Hr | Hr ].
      { subst r; rewrite plus_comm in H1; simpl in H1.
        assert (is_gcd p q p) as H3.
        { apply is_gcd_div; subst; auto. }
        rewrite (is_gcd_fun H3 H) in *.
        exists 1, 1; simpl; omega. }
      destruct (IHq _ Hq r) as (a & b & H3 & H4 & H5); try omega.
      { replace r with (q-n*p) by omega.
        apply is_gcd_sym, is_gcd_modulus; auto; omega. }
      exists (b+n*p-n*a), a.
      split; [ | split ]; auto.
      + rewrite H1, Nat.mul_sub_distr_r, (mult_comm _ p).
        do 3 rewrite Nat.mul_add_distr_l.
        rewrite (plus_comm _ (p*r)), (plus_assoc 1), (mult_comm p r), <- H3.
        rewrite (mult_comm n a), (mult_comm p b), mult_assoc, mult_assoc.
        assert (a*n*p <= p*n*p) as H6.
        { repeat (apply mult_le_compat; auto). }
        revert H6; generalize (b*p) (a*r) (a*n*p) (p*n*p); intros; omega.
      + rewrite H1; generalize (n*p) (n*a); intros; omega.
    Qed.

    Lemma bezout_nc p q : is_gcd p q 1 -> exists a b, a*p+b*q = 1+p*q.
    Proof.
      intros H.
      destruct (eq_nat_dec p 0) as [ | Hp ].
      { subst; rewrite (is_gcd_fun (is_gcd_0l _) H); exists 0, 1; auto. }
      destruct (eq_nat_dec q 0) as [ | Hq ].
      { subst; rewrite (is_gcd_fun (is_gcd_0r _) H); exists 1, 0; auto. }
      destruct (lt_eq_lt_dec p q) as [ [ H1 | H1 ] | H1 ].
      + destruct bezout_rec with (2 := H)
          as (a & b & H2 & _); try omega.
        exists a, b; auto.
      + subst; rewrite (is_gcd_fun (is_gcd_refl _) H); exists 1, 1; auto.
      + destruct bezout_rec with (2 := is_gcd_sym H)
          as (a & b & H2 & _); try omega.
        exists b, a; rewrite (mult_comm p q); omega.
    Qed.

    Hint Resolve divides_1.

    Lemma bezout_sc p q a b m : a*p+b*q = 1 + m -> p div m \/ q div m -> is_gcd p q 1.
    Proof.
      intros H1 H2; do 2 (split; auto).
      intros k H4 H5.
      apply divides_plus_inv with m.
      +  destruct H2 as [ H2 | H2 ];
         apply divides_trans with (2 := H2); auto.
      + rewrite plus_comm, <- H1.
        apply divides_plus; auto.
    Qed.

  End bezout_rel_prime.

  (* We need the simple form of Bezout above to show this *)

  Fact is_rel_prime_div p q k : is_gcd p q 1 -> p div q*k -> p div k.
  Proof.
    intros H1 (u & H2); subst.
    destruct bezout_nc with (1 := H1) as (a & b & H3).
    replace k with (k*(1+p*q) - k*p*q).
    + apply divides_minus.
      - rewrite <- H3, Nat.mul_add_distr_l.
        apply divides_plus.
        * rewrite mult_assoc; auto.
        * rewrite (mult_comm b), mult_assoc, (mult_comm k), H2.
          rewrite mult_comm, mult_assoc; auto.
      - rewrite mult_comm, mult_assoc; auto.
    + rewrite Nat.mul_add_distr_l, mult_assoc.
      generalize (k*p*q); intros; omega.
  Qed.

  Fact is_rel_prime_div_r p q k : is_gcd p q 1 -> p div k*q -> p div k.
  Proof. rewrite mult_comm; apply is_rel_prime_div. Qed.

  Fact is_rel_prime_lcm p q : is_gcd p q 1 -> is_lcm p q (p*q).
  Proof.
    intros H.
    repeat (split; auto).
    rewrite mult_comm; auto.
    intros k (u & ?) (v & ?); subst.
    rewrite (mult_comm u).
    apply divides_mult_compat; auto.
    apply is_gcd_sym in H.
    apply is_rel_prime_div with (1 := H) (k := u).
    rewrite mult_comm, H1; auto.
  Qed.

  Hint Resolve divides_1 divides_mult_compat is_gcd_refl.

  Fact is_gcd_0 p q : is_gcd p q 0 -> p = 0 /\ q = 0.
  Proof.
    intros ((a & Ha) & (b & Hb) & H).
    subst; do 2 rewrite mult_0_r; auto.
  Qed.

  Fact is_gcd_rel_prime p q g : is_gcd p q g -> exists a b, p = a*g /\ q = b*g /\ is_gcd a b 1.
  Proof.
    destruct (eq_nat_dec g 0) as [ H0 | H0 ].
    * intros H; subst.
      apply is_gcd_0 in H; destruct H; subst.
      exists 1, 1 ; simpl; auto.
    * intros ((a & Ha) & (b & Hb) & H).
      exists a, b; repeat (split; auto).
      intros k H1 H2.
      destruct (H (k*g)) as (d & Hd); subst.
      + do 2 rewrite (mult_comm _ g); auto.
      + do 2 rewrite (mult_comm _ g); auto.
      + rewrite mult_assoc in Hd.
        replace g with (1*g) in Hd at 1 by (simpl; omega).
        apply Nat.mul_cancel_r in Hd; auto.
        symmetry in Hd.
        apply mult_is_one in Hd.
        destruct Hd; subst; auto.
  Qed.

  Fact is_lcm_mult p q l k : is_lcm p q l -> is_lcm (k*p) (k*q) (k*l).
  Proof.
    intros (H1 & H2 & H3); repeat (split; auto).
    intros r (a & Ha) (b & Hb).
    destruct (eq_nat_dec k 0) as [ Hk | Hk ].
    + subst; simpl; auto.
    + assert (a*p = b*q) as H4.
      { rewrite <- Nat.mul_cancel_r with (1 := Hk).
        do 2 rewrite <- mult_assoc, (mult_comm _ k).
        rewrite <- Hb; auto. }
      rewrite Ha, mult_assoc, (mult_comm _ k), <- mult_assoc.
      apply divides_mult_compat; auto.
      apply H3; auto.
      rewrite H4; auto.
  Qed.

  Theorem is_gcd_lcm_mult p q g l : is_gcd p q g -> is_lcm p q l -> p*q = g*l.
  Proof.
    destruct (eq_nat_dec g 0) as [ H0 | H0 ]; intros H1.
    * subst; apply is_gcd_0 in H1.
      destruct H1; subst; simpl; auto.
    * destruct is_gcd_rel_prime with (1 := H1)
        as (u & v & Hu & Hv & H2).
      intros H3.
      rewrite Hu, Hv, (mult_comm u), <- mult_assoc; f_equal.
      rewrite (mult_comm u), (mult_comm v), <- mult_assoc, (mult_comm v).
      apply is_lcm_fun with (2 := H3).
      subst; rewrite (mult_comm u), (mult_comm v).
      apply is_lcm_mult, is_rel_prime_lcm; auto.
  Qed.

  Theorem is_gcd_mult_lcm p q g l : g <> 0 -> is_gcd p q g -> g*l = p*q -> is_lcm p q l.
  Proof.
    intros H0 H1 H2.
    destruct is_gcd_rel_prime with (1 := H1)
        as (u & v & Hu & Hv & H3).
    rewrite Hu, Hv, (mult_comm u), (mult_comm v).
    replace l with (g*(u*v)).
    + apply is_lcm_mult, is_rel_prime_lcm; auto.
    + rewrite <- Nat.mul_cancel_r with (1 := H0).
      rewrite (mult_comm l), H2, Hu, Hv,
              (mult_comm u g), mult_assoc, mult_assoc; auto.
  Qed.

  (*  if   1) p <= q
           2) p = u*g
           3) gcd p q = g
           4) lcm p q = l
      then A) gcd p (q-p) = g
           B) lcm p (q-p) = l-u*p *)

  Lemma is_lcm_minus p q g l u : p <= q -> p = u*g -> is_gcd p q g -> is_lcm p q l -> is_lcm p (q-p) (l-u*p).
  Proof.
    destruct (eq_nat_dec g 0) as [ H0 | H0 ].
    + intros _ _ H1 H2.
      subst; apply is_gcd_0 in H1.
      destruct H1; subst; simpl.
      rewrite mult_0_r, Nat.sub_0_r; auto.
    + intros H1 H2 H3 H4.
      apply is_gcd_mult_lcm with (1 := H0).
      * apply is_gcd_minus; auto.
      * do 2 rewrite Nat.mul_sub_distr_l.
        rewrite <- (is_gcd_lcm_mult H3 H4).
        f_equal.
        rewrite H2 at 2.
        rewrite mult_assoc, (mult_comm g); auto.
  Qed.

  (*  if   1) p <= q
           2) p = u*g
           3) gcd p q = g
           4) lcm p q = l
      then A) gcd p (q-k*p) = g
           B) lcm p (q-p) = l-k*u*p *)

  Lemma is_lcm_modulus k p q g l u : k*p <= q -> p = u*g -> is_gcd p q g -> is_lcm p q l -> is_lcm p (q-k*p) (l-k*u*p).
  Proof.
    rewrite <- mult_assoc.
    intros H1 H2 H3 H4. revert H1.
    induction k as [ | k IHk ]; intros H1.
    + simpl; do 2 rewrite Nat.sub_0_r; auto.
    + replace (q - S k*p) with (q -k*p -p) by (simpl; omega).
      replace (l - S k*(u*p)) with (l - k*(u*p) - u*p).
      - apply is_lcm_minus with (g := g); auto.
        * simpl in H1; omega.
        * apply is_gcd_modulus; auto.
          simpl in H1; omega.
        * apply IHk; simpl in H1; omega.
      - simpl; generalize (u*p) (k*(u*p)); intros; omega.
  Qed.

  (*  if   1) p <= q
           2) p = u*g
           3) gcd p q = g
           4) lcm p q = l
      then A) gcd p (q+p) = g
           B) lcm p (q+p) = l+u*p *)

  Lemma is_lcm_plus p q g l u : p = u*g -> is_gcd p q g -> is_lcm p q l -> is_lcm p (q+p) (l+u*p).
  Proof.
    destruct (eq_nat_dec g 0) as [ H0 | H0 ].
    + intros _ H1 H2.
      subst; apply is_gcd_0 in H1.
      destruct H1; subst; simpl.
      rewrite mult_0_r, Nat.add_0_r; auto.
    + intros H2 H3 H4.
      apply is_gcd_mult_lcm with (1 := H0).
      * apply is_gcd_plus; auto.
      * do 2 rewrite Nat.mul_add_distr_l.
        rewrite <- (is_gcd_lcm_mult H3 H4).
        f_equal.
        rewrite H2 at 2.
        rewrite mult_assoc, (mult_comm g); auto.
  Qed.

  Lemma is_lcm_moduplus k p q g l u : p = u*g -> is_gcd p q g -> is_lcm p q l -> is_lcm p (q+k*p) (l+k*u*p).
  Proof.
    rewrite <- mult_assoc.
    intros H2 H3 H4.
    induction k as [ | k IHk ].
    + simpl; do 2 rewrite Nat.add_0_r; auto.
    + replace (q + S k*p) with (q +k*p +p) by (simpl; omega).
      replace (l + S k*(u*p)) with (l + k*(u*p) + u*p) by (simpl; omega).
      apply is_lcm_plus with (g := g); auto.
      apply is_gcd_moduplus; auto.
  Qed.

  Section bezout_generalized.

    Let bezout_rec p q : 0 < p < q
                      -> { a : nat
                       & { b : nat
                       & { g : nat
                       & { l : nat
                       & { u : nat
                       & { v : nat
                         | a*p+b*q = g + l
                        /\ is_gcd p q g
                        /\ is_lcm p q l
                        /\ p = u*g
                        /\ q = v*g
                        /\ a <= v
                        /\ b <= u } } } } } }.
    Proof.
      revert p; induction q as [ q IHq ] using (@measure_rect _ (fun n => n)); intros p (Hp & Hq).
      destruct (@euclid q p) as (k & r & H1 & H2); try omega.
      destruct (eq_nat_dec r 0) as [ Hr | Hr ].
      + exists 1, 1, p, (k*p), 1, k.
        rewrite plus_comm in H1; simpl in H1.
        subst; repeat split; simpl; auto.
        destruct k; omega.
      + destruct (IHq _ Hq r) as (a & b & g & l & u & v & H3 & H4 & H5 & H6 & H7 & H8 & H9); try omega.
        exists (b+k*v-k*a), a, g, (l+k*v*p), v, (k*v+u).
        apply is_gcd_sym in H4.
        apply is_lcm_sym in H5.
        rewrite plus_comm in H1.
        assert (g <> 0) as Hg.
        { intro; subst g; apply is_gcd_0, proj1 in H4; omega. }
        split.
        { rewrite H1, plus_assoc, Nat.mul_add_distr_l, <- H3.
          rewrite Nat.mul_sub_distr_r, Nat.mul_add_distr_r.
          rewrite mult_assoc, (mult_comm a k).
          assert (k*a*p <= k*v*p) as G.
          { repeat (apply mult_le_compat; auto). }
          revert G; generalize (b*p) (a*r) (k*a*p) (k*v*p); intros; omega. }
        split.
        { rewrite H1; apply is_gcd_moduplus; auto. }
        split.
        { rewrite H1; apply is_lcm_moduplus with g; auto. }
        split; auto.
        split.
        { rewrite H1, H6, H7, Nat.mul_add_distr_r, mult_assoc; omega. }
        split; auto.
        { rewrite (plus_comm _ u), <- Nat.add_sub_assoc.
          +  apply plus_le_compat; auto.
             generalize (k*v) (k*a); intros; omega.
          + apply mult_le_compat; auto. }
    Qed.

    Hint Resolve is_gcd_sym is_lcm_sym.

    Definition bezout_generalized p q : { a : nat
                                      & { b : nat
                                      & { g : nat
                                      & { l : nat
                                        | a*p+b*q = g + l
                                       /\ is_gcd p q g
                                       /\ is_lcm p q l } } } }.
    Proof.
      destruct (eq_nat_dec p 0) as [ | Hp ].
      { subst; exists 0, 1, q, 0; repeat (split; auto). }
      destruct (eq_nat_dec q 0) as [ | Hq ].
      { subst; exists 1, 0, p, 0; repeat (split; auto). }
      destruct (lt_eq_lt_dec p q) as [ [ H1 | H1 ] | H1 ].
      + destruct (@bezout_rec p q)
          as (a & b & g & l & _ & _ & ? & ? & ? & _); try omega.
        exists a, b, g, l; auto.
      + subst q; exists 1, 1, p, p.
        repeat split; auto; omega.
      + destruct (@bezout_rec q p)
          as (a & b & g & l & _ & _ & ? & ? & ? & _); try omega.
        exists b, a, g, l; repeat (split; auto); omega.
    Qed.

  End bezout_generalized.

  Section gcd_lcm.

    Let gcd_full p q : sig (is_gcd p q).
    Proof.
      destruct (bezout_generalized p q) as (_ & _ & g & _ & _ & ? & _).
      exists g; auto.
    Qed.

    Definition gcd p q := proj1_sig (gcd_full p q).
    Fact gcd_spec p q : is_gcd p q (gcd p q).
    Proof. apply (proj2_sig _). Qed.

    Let lcm_full p q : sig (is_lcm p q).
    Proof.
      destruct (bezout_generalized p q) as (_ & _ & _ & l & _ & _ & ?).
      exists l; auto.
    Qed.

    Definition lcm p q := proj1_sig (lcm_full p q).
    Fact lcm_spec p q : is_lcm p q (lcm p q).
    Proof. apply (proj2_sig _). Qed.

  End gcd_lcm.

End bezout.

Require Import Extraction.
Extraction Inline measure_rect.

Check bezout_generalized.
Print Assumptions bezout_generalized.

Section division.

  Fact div_full q p : { n : nat & { r | q = n*p+r /\ (p <> 0 -> r < p) } }.
  Proof.
    case_eq p.
    + intro; exists 0, q; subst; split; auto; intros []; auto.
    + intros k H; destruct (@euclid q p) as (n & r & H1 & H2); try omega.
      exists n, r; rewrite <- H; split; auto.
  Qed.

  Definition div q p := projT1 (div_full q p).
  Definition rem q p := proj1_sig (projT2 (div_full q p)).

  Fact div_rem_spec1 q p : q = div q p * p + rem q p.
  Proof. apply (proj2_sig (projT2 (div_full q p))). Qed.

  Fact div_rem_spec2 q p : p <> 0 -> rem q p < p.
  Proof. apply (proj2_sig (projT2 (div_full q p))). Qed.

  Fact rem_0 q : rem q 0 = q.
  Proof.
    generalize (div_rem_spec1 q 0).
    rewrite mult_comm; auto.
  Qed.

  Fact div_rem_uniq p n1 r1 n2 r2 :
        p <> 0 -> n1*p + r1 = n2*p + r2 -> r1 < p -> r2 < p -> n1 = n2 /\ r1 = r2.
  Proof.
    intros H1 H2 H3 H4.
    assert (n1 = n2) as E.
    destruct (lt_eq_lt_dec n1 n2) as [ [ H | ] | H ]; auto.
    + replace n2 with (n2-n1 + n1) in H2 by omega.
      rewrite Nat.mul_add_distr_r in H2.
      assert (1*p <= (n2-n1)*p) as H5.
      { apply mult_le_compat; omega. }
      simpl in H5; omega.
    + replace n1 with (n1-n2 + n2) in H2 by omega.
      rewrite Nat.mul_add_distr_r in H2.
      assert (1*p <= (n1-n2)*p) as H5.
      { apply mult_le_compat; omega. }
      simpl in H5; omega.
    + subst; omega.
  Qed.

  Fact div_prop q p n r : q = n*p+r -> r < p -> div q p = n.
  Proof.
    intros H1 H2.
    apply (@div_rem_uniq p _ (rem q p) n r); auto.
    + omega.
    + rewrite <- H1; symmetry; apply div_rem_spec1.
    + apply div_rem_spec2; omega.
  Qed.

  Fact rem_prop q p n r : q = n*p+r -> r < p -> rem q p = r.
  Proof.
    intros H1 H2.
    apply (@div_rem_uniq p (div q p) _ n r); auto.
    + omega.
    + rewrite <- H1; symmetry; apply div_rem_spec1.
    + apply div_rem_spec2; omega.
  Qed.

  Fact rem_idem q p : q < p -> rem q p = q.
  Proof. apply rem_prop with 0; auto. Qed.

  Fact is_gcd_rem p n a : is_gcd p n a <-> is_gcd p (rem n p) a.
  Proof.
    rewrite (div_rem_spec1 n p) at 1; apply is_gcd_mult.
  Qed.

  Fact rem_erase q n p r : q = n*p+r -> rem q p = rem r p.
  Proof.
    destruct (eq_nat_dec p 0) as [ | Hp ]; subst.
    + rewrite mult_comm, rem_0, rem_0; auto.
    + destruct (div_full r p) as (m & r' & H1 & H2).
      specialize (H2 Hp).
      rewrite rem_prop with r p m r'; auto.
      intros; apply rem_prop with (n+m); auto.
      rewrite Nat.mul_add_distr_r; omega.
  Qed.

  Fact divides_div q p : divides p q -> q = div q p * p.
  Proof.
    intros (k & Hk).
    destruct (eq_nat_dec p 0) as [ Hp | Hp ].
    + subst; do 2 (rewrite mult_comm; simpl); auto.
    + rewrite (@div_prop q p k 0); omega.
  Qed.

  Fact divides_rem_eq q p : divides p q <-> rem q p = 0.
  Proof.
    destruct (eq_nat_dec p 0) as [ Hp | Hp ].
    * subst; rewrite rem_0; split.
      + apply divides_0_inv.
      + intros; subst; apply divides_0.
    * split.
      + intros (n & Hn).
        apply rem_prop with n; omega.
      + intros H.
        generalize (div_rem_spec1 q p).
        exists (div q p); omega.
  Qed.

  Fact rem_of_0 p : rem 0 p = 0.
  Proof.
    destruct p.
    + apply rem_0.
    + apply rem_prop with 0; omega.
  Qed.

  Hint Resolve divides_0_inv.

  Fact divides_dec q p : { k | q = k*p } + { ~ divides p q }.
  Proof.
    destruct (eq_nat_dec p 0) as [ Hp | Hp ].
    + destruct (eq_nat_dec q 0) as [ Hq | Hq ].
      * left; subst; exists 1; auto.
      * right; contradict Hq; subst; auto.
    + destruct (@euclid q p Hp) as (n & [ | r ] & H1 & H2).
      * left; exists n; subst; rewrite plus_comm; auto.
      * right; intros (m & Hm).
        rewrite <- Nat.add_0_r in Hm.
        rewrite Hm in H1.
        destruct (div_rem_uniq _ _ Hp H1); omega.
  Qed.

End division.

Section rem.

  Variable (p : nat) (Hp : p <> 0).

  Fact rem_plus_rem a b : rem (a+rem b p) p = rem (a+b) p.
  Proof.
    rewrite (div_rem_spec1 b p) at 2.
    rewrite plus_assoc.
    symmetry; apply rem_erase with (div (b) p); ring.
  Qed.

  Fact rem_mult_rem a b : rem (a*rem b p) p = rem (a*b) p.
  Proof.
    rewrite (div_rem_spec1 b p) at 2.
    rewrite Nat.mul_add_distr_l, mult_assoc.
    symmetry; apply rem_erase with (a*div b p); auto.
  Qed.

  Fact rem_diag : rem p p = 0.
  Proof. apply rem_prop with 1; omega. Qed.

  Fact rem_lt a : a < p -> rem a p = a.
  Proof. apply rem_prop with 0; omega. Qed.

  Fact rem_plus a b : rem (a+b) p = rem (rem a p + rem b p) p.
  Proof.
    rewrite (div_rem_spec1 a p) at 1.
    rewrite (div_rem_spec1 b p) at 1.
    apply rem_erase with (div a p + div b p).
    ring.
  Qed.

  Fact rem_scal k a : rem (k*a) p = rem (k*rem a p) p.
  Proof.
    rewrite (div_rem_spec1 a p) at 1.
    rewrite Nat.mul_add_distr_l.
    apply rem_erase with (k*div a p).
    ring.
  Qed.

  Fact rem_plus_div a b : divides p b -> rem a p = rem (a+b) p.
  Proof.
    intros (n & Hn); subst.
    rewrite <- rem_plus_rem.
    f_equal.
    rewrite <- rem_mult_rem, rem_diag, Nat.mul_0_r, rem_of_0; omega.
  Qed.

  Fact div_eq_0 n : n < p -> div n p = 0.
  Proof. intros; apply div_prop with n; omega. Qed.

  Fact div_of_0 : div 0 p = 0.
  Proof. apply div_eq_0; omega. Qed.

  Fact div_ge_1 n : p <= n -> 1 <= div n p.
  Proof.
    intros H2.
    rewrite (div_rem_spec1 n p) in H2.
    generalize (div_rem_spec2 n Hp); intros H3.
    destruct (div n p); omega.
  Qed.

End rem.

Fact div_by_p_lt p n : 2 <= p -> n <> 0 -> div n p < n.
Proof.
  intros H1 H2.
  rewrite (div_rem_spec1 n p) at 2.
  replace p with (2+(p-2)) at 3 by omega.
  rewrite Nat.mul_add_distr_l.
  generalize (div n p*(p-2)); intros x.
  destruct (le_lt_dec p n) as [ Hp | Hp ].
  + apply div_ge_1 in Hp; omega.
  + rewrite rem_lt; omega.
Qed.

Section rem_2.

  Fact rem_2_is_0_or_1 x : rem x 2 = 0 \/ rem x 2 = 1.
  Proof. generalize (rem x 2) (@div_rem_spec2 x 2); intros; omega. Qed.

  Fact rem_2_mult x y : rem (x*y) 2 = 1 <-> rem x 2 = 1 /\ rem y 2 = 1.
  Proof.
    generalize (rem_2_is_0_or_1 x) (rem_2_is_0_or_1 y).
    do 2 rewrite <- rem_mult_rem, mult_comm.
    intros [ H1 | H1 ] [ H2 | H2 ]; rewrite H1, H2; simpl; rewrite rem_lt; omega.
  Qed.

  Fact rem_2_fix_0 : rem 0 2 = 0.
  Proof. apply rem_lt; omega. Qed.

  Fact rem_2_fix_1 n : rem (2*n) 2 = 0.
  Proof. apply divides_rem_eq; exists n; ring. Qed.

  Fact rem_2_fix_2 n : rem (1+2*n) 2 = 1.
  Proof.
    rewrite <- rem_plus_rem,rem_2_fix_1, rem_lt; omega.
  Qed.

  Fact rem_2_lt n : rem n 2 < 2.
  Proof. apply div_rem_spec2; omega. Qed.

  Fact div_2_fix_0 : div 0 2 = 0.
  Proof. apply div_of_0; omega. Qed.

  Fact div_2_fix_1 n : div (2*n) 2 = n.
  Proof. apply div_prop with 0; omega. Qed.

  Fact div_2_fix_2 n : div (1+2*n) 2 = n.
  Proof. apply div_prop with 1; omega. Qed.

  Fact euclid_2_div n : n = rem n 2 + 2*div n 2 /\ (rem n 2 = 0 \/ rem n 2 = 1).
  Proof.
    generalize (div_rem_spec1 n 2) (@div_rem_spec2 n 2); intros; omega.
  Qed.

  Fact euclid_2 n : exists q, n = 2*q \/ n = 1+2*q.
  Proof.
    exists (div n 2).
    generalize (div_rem_spec1 n 2) (@div_rem_spec2 n 2); intros; omega.
  Qed.

End rem_2.

Local Hint Resolve divides_mult divides_mult_r divides_refl.

Theorem CRT u v a b : u <> 0 -> v <> 0 -> is_gcd u v 1 -> exists w, rem w u = rem a u /\ rem w v = rem b v /\ 2 < w.
Proof.
  intros Hu Hv H.
  destruct bezout_nc with (1 := H) as (x & y & H1).
  assert (rem (x*u) v = rem 1 v) as H2.
  { rewrite rem_plus_div with (a := 1) (b := u*v); auto.
    rewrite <- H1; apply rem_plus_div; auto. }
  assert (rem (y*v) u = rem 1 u) as H3.
  { rewrite rem_plus_div with (a := 1) (b := u*v); auto.
    rewrite <- H1, plus_comm.
    apply rem_plus_div; auto. }
  exists (3*(u*v)+a*(y*v)+b*(x*u)).
  split; [ | split ].
  + rewrite <- rem_plus_rem, (mult_assoc b).
    rewrite rem_scal with (k := b*x), rem_diag; auto.
    rewrite Nat.mul_0_r, rem_of_0, Nat.add_0_r.
    rewrite <- rem_plus_rem, rem_scal, H3, <- rem_scal, Nat.mul_1_r.
    rewrite rem_plus_rem, plus_comm.
    symmetry; apply rem_plus_div; auto.
  + rewrite <- plus_assoc, (plus_comm (a*_)), plus_assoc.
    rewrite <- rem_plus_rem, (mult_assoc a).
    rewrite rem_scal with (k := a*y), rem_diag; auto.
    rewrite Nat.mul_0_r, rem_of_0, Nat.add_0_r.
    rewrite <- rem_plus_rem, rem_scal, H2, <- rem_scal, Nat.mul_1_r.
    rewrite rem_plus_rem, plus_comm.
    symmetry; apply rem_plus_div; auto.
  + apply lt_le_trans with (3*1); try omega.
    do 2 apply le_trans with (2 := le_plus_l _ _).
    apply mult_le_compat_l.
    assert (u*v <> 0) as H4.
    { intros G; apply mult_is_O in G; omega. }
    revert H4; generalize (u*v); intros; omega.
Qed.


Section Lab3Task1.
Variable D : Set.
Theorem Lab3Task1a : forall A B : D -> Prop,
(forall x, A x -> B x) -> ((forall x, A x) -> (forall x, B x)).
Proof.
(* to be completed *)
intros.
apply H.
apply H0.
Qed.

Theorem Lab3Task1b : forall A B : D -> Prop,
(forall x, A x -> B x) -> ((exists x, A x) -> (exists x, B x)).
Proof.
(* to be completed *)
intros.
destruct H0.
apply H in H0.
exists x.
assumption.
Qed.

Variable d:D. (* D is not empty *)
Theorem Lab3Task1c : forall A B : D -> Prop,
(forall x, A x -> B x) -> ((forall x, A x) -> (exists x, B x)).
Proof.
intros.
exists d.
apply H.
apply H0.
Qed.

Section Lab3Task2.
Require Import Arith.

Fixpoint sumOdd (n : nat) : nat :=
match n with
| 0 => 0
| S n => (sumOdd n) + (2*n + 1)
end.
Theorem sumOdds : forall n : nat, sumOdd n = n*n.

Proof.
induction n.
reflexivity.
change (sumOdd(S n)) with (sumOdd(n) + (2*n +1)).
ring_simplify.
rewrite IHn.
reflexivity.
Qed.

Require Import Arith.
Section Task3.
Fixpoint sum2 (n : nat) : nat :=
match n with
| 0 => 0
| S n => (sum2 n) + (n+1)*(n+2)
end.
Theorem sum2formula : forall n : nat, 3 * (sum2 n) = n*(n+1)*(n+2).

Proof.

induction n.
ring_simplify.
reflexivity.
change (sum2 (S n)) with ((sum2 n) + ( n+1)*(n+2)).
ring_simplify.
rewrite IHn.
ring_simplify.
reflexivity.
Qed.

Section Task4.
Fixpoint sum3 (n : nat) : nat :=
match n with
| 0 => n
| S n => (sum3 n) + ((n+1)*(n+1))
end.
Theorem squareSumFormula : forall n : nat, 6 * (sum3 n) = n*(n+1)*(2*n+1).

induction n.
ring_simplify.
reflexivity.

change (sum3(S n)) with ((sum3 n) + ((n+1)*(n+1))).
ring_simplify.
rewrite IHn.
ring_simplify.
reflexivity.
Qed.


(*******************************************************************)
(*  This is part of RelationAlgebra, it is distributed under the   *)
(*    terms of the GNU Lesser General Public License version 3     *)
(*              (see file LICENSE for more details)                *)
(*                                                                 *)
(*  Copyright 2012: Damien Pous. (CNRS, LIP - ENS Lyon, UMR 5668)  *)
(*******************************************************************)

(** * ordinal: finite ordinals, sets of finite ordinals *)

Require Import List.
Require Import common comparisons.

Set Implicit Arguments.

(** * Boolean strict order on natural numbers *)

Fixpoint ltb i j :=
  match i,j with
    | O,S _ => true
    | _,O   => false
    | S i, S j => ltb i j
  end.
Notation "i < j" := (ltb i j = true).
Notation "i <= j" := (ltb j i = false).

Lemma ltb_plus_l i m n: i<m -> i<m+n.
Proof. revert i; induction m; destruct i; simpl; auto; discriminate. Qed.

Lemma ltb_plus_r i m n: i<n -> m+i<m+n.
Proof. revert i; induction m; destruct i; simpl; auto; discriminate. Qed.

Lemma leb_plus_r i n: n <= n+i.
Proof. induction n; simpl. now destruct i. assumption. Qed.

Lemma ltb_minus n m i: i<n+m -> n <= i -> i-n < m.
Proof. revert n. induction i; destruct n; simpl; auto. discriminate. Qed.

Lemma lt_n_1 a: a<1 -> a=0.
Proof. destruct a as [|[|?]]; trivial; discriminate. Qed.

Definition lt_ge_dec i n: {i<n}+{n<=i}.
Proof. case_eq (ltb i n). now left. now right. Defined.

(** * Additional induction schemes for natural numbers *)

Lemma ltb_ind (P: nat -> nat -> Prop)
  (H0: forall n, P (S n) 0)
  (HS: forall n i, P n i -> P (S n) (S i)):
  forall n i, i<n -> P n i.
Proof.
  induction n; intros i Hi. destruct i; discriminate.
  destruct i. apply H0. now apply HS, IHn.
Qed.

Lemma nat_ind_2: forall P: nat -> Prop,
  P 0 -> P 1 -> (forall n, P n -> P ((S (S n)))) -> forall n, P n.
Proof.
  intros P H0 H1 HSS.
  assert (G: forall m, P m /\ P (S m)).
   induction m. split; assumption.
   destruct IHm as [IHm IHSm].
   split. assumption. apply (HSS m), IHm.
  intro n. destruct (G n). assumption.
Qed.

(** * Ordinals *)
(** we use a record rather than a dependent inductive in order to
   - get slightly more efficient computations
   - get simpler proofs
   using a Boolean strict order also simplifies proofs w.r.t. using the lt
   predicate from the standard library *)
Record ord n := Ord {nat_of_ord:> nat; ord_lt: nat_of_ord<n}.
Arguments Ord [_] i _: rename.

(** zero and successor *)
Definition ord0 {n}: ord (S n) := @Ord (S n) 0 eq_refl.
Definition ordS {n} (i: ord n): ord (S n) := @Ord (S n) (S i) (ord_lt i).

(** ** ordinals as a [cmpType] *)
(** we just compare the underlying natural numbers *)
Definition eqb_ord {n} (i j: ord n) := eqb_nat i j.

Lemma eq_ord n (i j: ord n): @eq nat i j -> i=j.
Proof. destruct i; destruct j; simpl; intro. subst. f_equal. apply UIP_cmp. Qed.

Lemma eqb_ord_spec n (i j: ord n): reflect (i=j) (eqb_ord i j).
Proof.
  unfold eqb_ord. case eqb_spec; intro E; constructor.
  apply eq_ord, E. congruence.
Qed.

Definition ord_compare {n} (i j: ord n) := nat_compare i j.
Lemma ord_compare_spec n (i j: ord n): compare_spec (i=j) (ord_compare i j).
Proof.
  unfold ord_compare.
  case cmp_spec; constructor; try apply eq_ord; congruence.
Qed.

Canonical Structure cmp_ord n := mk_cmp _ (@eqb_ord_spec n) _ (@ord_compare_spec n).

(** ** basic properties  *)

(** [ord 0] is empty *)
Lemma ord_0_empty: ord 0 -> False.
Proof. intros [[|?]]; discriminate. Qed.

(** [ord 1] has only one element: 0 *)
Lemma ord0_unique: forall i: ord 1, i=ord0.
Proof.
  intros [[|i] Hi]; apply eq_ord. reflexivity.
  destruct i; discriminate.
Qed.

(** induction scheme for ordinals *)
Lemma ord_ind' (P: forall n, ord n -> Prop)
  (H0: forall n, P (S n) ord0)
  (HS: forall n i, P n i -> P (S n) (ordS i)):
  forall n i, P n i.
Proof.
  induction n. intro i. elim (ord_0_empty i).
  destruct i as [[|i] Hi].
   replace (Ord 0 Hi) with (@ord0 n) by now apply eq_ord. apply H0.
   replace (Ord (S i) Hi) with (ordS (@Ord n i Hi)) by now apply eq_ord. apply HS, IHn.
Qed.

(** ** sequence of all ordinals below [n]  *)
Fixpoint seq n: list (ord n) :=
  match n with
    | 0 => nil
    | S n => cons ord0 (map ordS (seq n))
  end.

(** completeness of the above sequence *)
Lemma in_seq: forall {n} (i: ord n), In i (seq n).
Proof.
  induction i using ord_ind'. now left.
  right. rewrite in_map_iff. eauto.
Qed.

(** ** shifting ans splitting ordinals *)

(** shifting *)
Definition lshift {m n} (i: ord m): ord (m+n) := Ord i (ltb_plus_l _ _ _ (ord_lt i)).
Definition rshift {m n} (i: ord n): ord (m+n) := Ord (m+i) (ltb_plus_r _ _ _ (ord_lt i)).

(** spliting the sequence of all ordinals *)
Lemma seq_cut n m: seq (n+m) = map lshift (seq n) ++ map rshift (seq m).
Proof.
  induction n; simpl.
   rewrite <-(map_id (seq m)) at 1. apply map_ext.
   intros [i Hi]. apply eq_ord. reflexivity.
   rewrite IHn, map_app. f_equal. apply eq_ord. reflexivity.
   rewrite 3map_map. f_equal; apply map_ext; intros [i Hi]; apply eq_ord; reflexivity.
Qed.

(** splitting an ordinal *)
Definition split {n m} (i: ord (n+m)): ord n + ord m :=
  match lt_ge_dec i n with
    | left Hi => inl _ (Ord _ Hi)
    | right Hj => inr _ (Ord _ (ltb_minus _ _ _ (ord_lt i) Hj))
  end.

Inductive split_case n m (i: ord (n+m)): ord n + ord m -> Set :=
  | split_l: forall j: ord n, i=lshift j -> split_case i (inl j)
  | split_r: forall j: ord m, i=rshift j -> split_case i (inr j).

Lemma split_spec n m (i: ord (n+m)): split_case i (split i).
Proof.
  unfold split. case lt_ge_dec; constructor; apply eq_ord; simpl. reflexivity.
  destruct i as [j Hj]. simpl in *. revert n m e Hj.
  induction j; destruct n; simpl; auto. discriminate.
  intros. f_equal. eapply IHj; eassumption.
Qed.

(** basic properties of split and shifting *)
Lemma split_lshift n m i: @split n m (lshift i) = inl i.
Proof.
  case split_spec; intros j E.
  f_equal. apply eq_ord. injection E. congruence.
  exfalso. injection E. clear E. destruct i as [i Hi].
  simpl. intros ->. rewrite leb_plus_r in Hi. discriminate.
Qed.

Lemma split_rshift n m i: @split n m (rshift i) = inr i.
Proof.
  case split_spec; intros j E.
  exfalso. injection E. clear E. destruct j as [j Hj]. simpl. intros <-.
   rewrite leb_plus_r in Hj. discriminate.
  f_equal. apply eq_ord. symmetry. injection E. apply Plus.plus_reg_l.
Qed.

Lemma eqb_ord_lrshift n m i j: eqb_ord (@lshift n m i) (@rshift n m j) = false.
Proof.
  destruct i as [i Hi]; destruct j as [j Hj]. unfold eqb_ord. simpl.
  case eqb_spec; trivial. intro E. rewrite E in Hi. rewrite leb_plus_r in Hi. discriminate.
Qed.

Lemma eqb_ord_rlshift n m i j: eqb_ord (@rshift n m i) (@lshift n m j) = false.
Proof. rewrite eqb_sym. apply eqb_ord_lrshift. Qed.

Lemma eqb_ord_rrshift n m i j: eqb_ord (@rshift n m i) (@rshift n m j) = eqb_ord i j.
Proof.
  destruct i as [i Hi]; destruct j as [j Hj]. unfold eqb_ord. simpl.
  do 2 case eqb_spec; trivial. intros E E'. elim E. eapply Plus.plus_reg_l, E'.
  congruence.
Qed.

Lemma split_ord0 m: @split 1 m ord0 = inl ord0.
Proof. reflexivity. Qed.

Lemma split_ordS m i: @split 1 m (ordS i) = inr i.
Proof.
  case split_spec; intros j Hj.
   rewrite (ord0_unique j) in Hj. discriminate.
  destruct i; destruct j. injection Hj. intros <-. f_equal. now apply eq_ord.
Qed.

(** * Finite sets of ordinals as ordinals *)

(** we encode a finite subset of [ord n] as an element of [ord (2^n)],
   using the coding of the characteristic function of the set as a
   bitvector of length n

   since we need to compute a little bit with these encoded sets, we
   first define the bijection on natural numbers, before encapsulating
   into ordinals. *)
Module set.

(** ** on natural numbers *)

(** [xO' i = 2*i], [xI' i = 2*i+1] *)
Fixpoint xO' i := match i with 0 => 0 | S i => S (S (xO' i)) end.
Fixpoint xI' i := match i with 0 => 1 | S i => S (S (xI' i)) end.

(** from characteristic functions to natural numbers: accumulate bits
   until a given length [(n)] is reached *)
Fixpoint of_fun' n (f: nat -> bool): nat :=
  match n with
    | 0 => 0
    | S n => if f 0
      then xI' (of_fun' n (fun i => f (S i)))
      else xO' (of_fun' n (fun i => f (S i)))
  end.

(** [od x] returns the pair [(o,y)] s.t. [x = 2*y+o]  *)
Fixpoint od x :=
  match x with
    | O => (false,O)
    | S O => (true,O)
    | S (S x) => let (o,x) := od x in (o,S x)
  end.

(** testing membership: read the [i]th bit, using [od] *)
(** this function is presented in such a strange way to get efficiency:
    the partial application [mem' n x] reduces to the pattern matching function
    that precisely corresponds to the membership function of [x]. For instance,
    [mem' 4 {1,2}] reduces to
    [fun i => match i with 0 | 3 => false | 1 | 2 => true | _ => assert_false end] *)
Fixpoint mem' n x :=
  match n with
    | 0 => fun i => assert_false false
    | S n =>
      let (o,x) := od x in
      let f := mem' n x in
      fun i => match i with O => o | S i => f i end
  end.

(** correctness of [mem'] and [of_fun'] *)
Lemma od_xO i: od (xO' i) = (false,i).
Proof. induction i; simpl. reflexivity. now rewrite IHi. Qed.

Lemma od_xI i: od (xI' i) = (true,i).
Proof. induction i; simpl. reflexivity. now rewrite IHi. Qed.

Lemma mem_of_fun' n: forall f i, i<n -> mem' n (of_fun' n f) i = f i.
Proof.
  induction n; intros f i Hi; simpl. destruct i; discriminate.
  case_eq (f 0); intro H.
   rewrite od_xI. destruct i. congruence. now rewrite IHn.
   rewrite od_xO. destruct i. congruence. now rewrite IHn.
Qed.

(** ** encapsulation into ordinals *)

(** bounds about the various operations *)
Lemma xO_bound: forall n i, i<n -> xO' i < double n.
Proof. now apply ltb_ind. Qed.

Lemma xI_bound: forall n i, i<n -> xI' i < double n.
Proof. now apply ltb_ind. Qed.

Lemma of_fun_bound: forall n f, of_fun' n f < pow2 n.
Proof.
  induction n; intro f. reflexivity.
  simpl. case f.
   now apply xI_bound.
   now apply xO_bound.
Qed.

Lemma od_bound a: forall n, a < double n -> snd (od a) < n.
Proof.
  induction a using nat_ind_2; intros n Hn; simpl.
   destruct n; simpl. discriminate. reflexivity.
   destruct n; simpl. discriminate. reflexivity.
  revert IHa. case od; simpl. intros o a' IH.
  destruct n. discriminate. apply IH, Hn.
Qed.

(** extending a Boolean function on ordinals into a function on natural numbers *)
Definition app' n (f: ord n -> bool) (i: nat) :=
  match lt_ge_dec i n with
    | left H => f (Ord i H)
    | _ => false
  end.

(** encapsulation of the various operations into ordinals *)
Definition xO n (i: ord n): ord (double n) := Ord (xO' i) (xO_bound _ _ (ord_lt i)).
Definition xI n (i: ord n): ord (double n) := Ord (xI' i) (xI_bound _ _ (ord_lt i)).
Definition mem n (x: ord (pow2 n)) (i: ord n) := mem' n x i.
Definition of_fun n (f: ord n -> bool): ord (pow2 n) := Ord (of_fun' n (app' f)) (of_fun_bound _ _).
(** retraction from [ord n -> bool] into [ord (pow2 n)] *)
Lemma mem_of_fun n (f: ord n -> bool) i: mem (of_fun f) i = f i.
Proof.
  unfold mem, of_fun. simpl. rewrite mem_of_fun' by apply ord_lt.
  unfold app'. case lt_ge_dec. intros. f_equal. now apply eq_ord.
  rewrite (ord_lt i). discriminate.
Qed.

(** injectivity of the [od] function *)
Lemma od_inj a b: od a = od b -> a = b.
Proof.
  revert b. induction a using nat_ind_2; intros [|[|b]]; simpl;
   trivial; (try (case od; discriminate)); (try discriminate).
  intro. f_equal. f_equal. apply IHa. revert H.
  case od. case od. congruence.
Qed.

(** extensionality on natural numbers *)
Lemma ext' n: forall a b,
  a<pow2 n -> b<pow2 n -> (forall i, i<n -> mem' n a i = mem' n b i) ->
  a = b.
Proof.
  induction n; simpl; intros a b Ha Hb H.
   rewrite lt_n_1 by assumption. now apply lt_n_1.
   apply od_inj. revert H. generalize (od_bound _ _ Ha), (od_bound _ _ Hb).
   case od. intros oa a' Ha'.
   case od. intros ob b' Hb'.
   intro H. f_equal.
    apply (H 0 eq_refl).
    apply IHn; trivial. intros i Hi. apply (H (S i) Hi).
Qed.

(** extensionality on ordinals (i.e., with [mem_of_fun], mem/of_fun form a bijection) *)
Lemma ext n (a b: ord (pow2 n)): (forall i, mem a i = mem b i) -> a = b.
Proof.
  intro H. apply eq_ord. eapply ext'. apply ord_lt. apply ord_lt.
  intros i Hi. apply (H (Ord i Hi)).
Qed.

(** ** additional lemmas *)

Lemma xO_0 n: xO (@ord0 n) = @ord0 (S (double n)).
Proof. now apply eq_ord. Qed.
Lemma xO_S n (i: ord n): xO (ordS i) = ordS (ordS (xO i)).
Proof. now apply eq_ord. Qed.
Lemma xI_0 n: xI (@ord0 n) = ordS (@ord0 (double n)).
Proof. now apply eq_ord. Qed.
Lemma xI_S n (i: ord n): xI (ordS i) = ordS (ordS (xI i)).
Proof. now apply eq_ord. Qed.

Lemma mem_xO_0 n (f: ord (pow2 n)): @mem (S n) (xO f) ord0 = false.
Proof. unfold mem. simpl. now rewrite od_xO. Qed.
Lemma mem_xO_S n (f: ord (pow2 n)) i: @mem (S n) (xO f) (ordS i) = mem f i.
Proof. unfold mem. simpl. now rewrite od_xO. Qed.
Lemma mem_xI_0 n (f: ord (pow2 n)): @mem (S n) (xI f) ord0 = true.
Proof. unfold mem. simpl. now rewrite od_xI. Qed.
Lemma mem_xI_S n (f: ord (pow2 n)) i: @mem (S n) (xI f) (ordS i) = mem f i.
Proof. unfold mem. simpl. now rewrite od_xI. Qed.

End set.


Require Export Arith.EqNat.

Inductive natlist : Type :=
| nil : natlist
| cons : nat -> natlist -> natlist.

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

Definition new_bob (a:bool)(b:bool):bool := if a then b else false.

Fixpoint beq_natlist (l : natlist) (m : natlist) : bool :=
match l,m with
|[] , [] => true
| _ , [] => false
|[] , _ => false
|h :: t , h'::t' =>  new_bob (beq_nat h h') (beq_natlist t t')
end.

Check new_bob.

Eval compute in (beq_natlist [1;2;3] [4;5;6]).
Eval compute in (beq_natlist [1;1;1] [1;1;1]).

(*SearchAbout beq_nat.*)

Theorem beq_nat_refl : forall n: nat, true = beq_nat n n.
Proof.
intros.
induction n.
simpl. reflexivity.
simpl. rewrite IHn.
simpl. reflexivity.
Qed.

Theorem beq_natlist_refl : forall l:natlist, true = beq_natlist l l.
Proof.
simpl.
induction l.
simpl. reflexivity.
simpl. rewrite <- IHl.
simpl. rewrite <- beq_nat_refl.
simpl. reflexivity.
Qed.

Eval compute in (beq_natlist_refl [1;2;3]).


(* -------------------------Description--------------------------------------

   This file contains formalization of sorting for a list of elements of ordType

 max_in l d        ==> returns the maximum in list l (returns d if l is nil)
 min_in l d        ==> returns the minimum in list l (returns d if l is nil)
 Sorted l         <==> l is sorted according to <=b relation
 put_in a l        ==> put a in correct place in a sorted list l
 sort_i l          ==> sort the list l in increasing order w.r.t <=b comp operator

--------------------------------------------------------------------------- *)

Require Export Lists.List.
Require Export GenReflect SetSpecs OrdType.
Require Export Omega.

Set Implicit Arguments.

Section ListSorting.
  Context { A: ordType }.

  (*-----------max_in and min_in functions on lists with ordType elements ---------------  *)

   Fixpoint max_in (l: list A)(d: A): A:=
    match l with
    |nil => d
    |a::l' => max_of a (max_in l' a)
    end.

   Lemma max_spec (l:list A)(d:A)(a:A): In a l -> (a <b (max_in l d) \/ a = (max_in l d)).
   Proof. { generalize d. induction l.
          { intros d0 H. inversion H. }
          { intros d0 H. simpl.
            assert (H1: a = a0 \/ In a l). auto.
            destruct H1. subst a. eauto.
            assert (H1: a<b max_in l a0 \/ a = max_in l a0). eauto.
            destruct H1. left. apply @max_of_spec4. auto.  rewrite <- H1. eauto. } } Qed.
  Lemma max_in_elim (a:A) (l:list A) (d:A) : In (max_in (a::l) d) (a::l).
     Proof. { revert a. revert d. induction l.
            { simpl. intros; left. eauto. }
            { intros d a0. replace (max_in (a0 :: a :: l) d) with (max_of a0 (max_in (a::l) a0)).
              unfold max_of. match_up a0 (max_in (a::l) a0); eauto.
              simpl;auto. } } Qed.

 Hint Resolve max_spec max_in_elim: core.

   Fixpoint min_in (l: list A)(d: A): A:=
    match l with
    |nil => d
    |a::l' => min_of a (min_in l' a)
    end.

   Lemma min_spec (l:list A)(d:A)(a:A): In a l -> ((min_in l d) <b a \/ (min_in l d)= a).
   Proof. { generalize d. induction l.
          { intros d0 H. inversion H. }
          { intros d0 H. simpl.
            assert (H1: a = a0 \/ In a l). auto.
            destruct H1. subst a. eauto.
            assert (H1: min_in l a0 <b a \/ min_in l a0 = a). eauto.
            destruct H1. left.  auto. rewrite H1. auto. } } Qed.

   Lemma min_in_elim (a:A) (l:list A) (d:A): In (min_in (a::l) d) (a::l).
   Proof.  { revert a. revert d. induction l.
            { simpl. intros; left. eauto. }
            { intros d a0. replace (min_in (a0 :: a :: l) d) with (min_of a0 (min_in (a::l) a0)).
              unfold min_of. match_up a0 (min_in (a::l) a0); eauto.
              simpl;auto. } } Qed.

   Hint Resolve min_spec min_in_elim: core.

   (* ------------- sorting a list of elements with ordType------------------------------*)

  Inductive  Sorted : list A-> Prop:=
  | nil_sorted: Sorted nil
  | cons_sorted (a:A)(l: list A): Sorted l -> (forall x, (In x l -> (a <=b x))) -> Sorted (a::l).

  Lemma Sorted_elim1 (a:A) (b:A) (l: list A): (Sorted (a::b::l)) -> (a <=b b).
  Proof. intro H. inversion H.  eapply H3. eauto. Qed.

   Lemma Sorted_elim2 (a:A) (l:list A):
    Sorted (a::l) ->(forall x, In x (a::l) -> a <=b x).
  Proof. intro H. inversion H. intros. destruct H4. subst x. all: auto. Qed.

  Lemma Sorted_elim2a (a:A) (d:A) (l:list A): (Sorted (a::l)) -> a = (min_in (a::l) d).
  Proof. {
    intro H. inversion H.
    assert (H4: In (min_in (a::l) d) (a::l)). eauto.
    destruct H4. auto.
    apply H3 in H4 as H5. assert (H6: (min_in (a::l) d) <=b a).
    Check min_spec. apply /orP.
    cut (min_in (a :: l) d <b a \/ min_in (a :: l) d = a).
    intro H6; destruct H6. left;auto. right; apply /eqP;auto.
    apply min_spec. eauto.
    move /orP in H5; move /orP in H6.
    destruct H5; destruct H6. absurd (min_in (a :: l) d <b a);eauto.
    move /eqP in H6. auto. all: apply /eqP; eauto using H5.  } Qed.

  Lemma Sorted_elim3 (a:A) (l:list A): (Sorted (a::l)) -> Sorted l.
  Proof. intro H. inversion H;auto. Qed.

  Lemma Sorted_elim4 (a:A) (l:list A): Sorted (a::l) ->(forall x, In x l -> a <=b x).
  Proof. intro H. inversion H. auto. Qed.

  Lemma Sorted_single (a:A) : (Sorted (a::nil)).
  Proof. constructor. constructor. intros;simpl;contradiction. Qed.

  Hint Resolve Sorted_elim1 Sorted_elim2 Sorted_elim2a Sorted_elim3 Sorted_elim4: core.
  Hint Resolve Sorted_single: core.

  Fixpoint put_in (a: A) (l: list A) : list A:=
    match l with
    |nil=> a::nil
    |b::l1 => match comp a b with
             |Lt => a::l
             |Eq => a::l
             |Gt => b::(put_in a l1)
                    end
    end.

  Lemma put_in_intro (a:A) (l: list A): forall x, In x l -> In x (put_in a l).
  Proof. { intros x H. induction l. simpl in H. contradiction. simpl. match_up a a0.
          destruct H. subst x. (eauto).
         eauto. eauto. destruct H. subst x;
         eauto. apply IHl in H as H1;eauto. } Qed.

  Lemma put_in_intro1 (a:A) (l: list A): In a (put_in a l).
  Proof. { induction l. simpl. tauto. simpl. destruct (on_comp a a0). eauto.
         eauto. eauto. } Qed.

  Lemma put_in_elim (a:A) (l: list A): forall x, In x (put_in a l) -> (x=a)\/(In x l).
  Proof. { intros x H. induction l. simpl in H. simpl. destruct H. left. auto. auto.
         simpl in H. match_up a a0.   destruct H. auto. auto. auto.
         destruct H. right;subst x ;auto. apply IHl in H as H2.
         destruct H2. auto. right. auto. } Qed.

  Lemma put_in_correct : forall (a:A) (l: list A), Sorted l -> Sorted (put_in a l).
  Proof. { intros a l. revert a. revert l. induction l.
         { intros a1 H.  simpl. apply Sorted_single. }
         simpl. intros a1 H.  destruct (on_comp a1 a).
         subst a1.
         { constructor. auto. inversion H. intros x H4. destruct H4. subst x.
           apply /orP. right. apply /eqP;auto. auto. }
         { constructor. auto.  intros x H2. destruct H2. subst x.
           apply /orP. left. auto. inversion H. apply H5 in H1 as H6.
           move /orP in H6. apply /orP.
           destruct H6. left;auto. left. move /eqP in H6. subst x. auto. }
         { assert (H1: Sorted l). eapply Sorted_elim3. eauto.
           eapply IHl  with (a:=a1) in H1 as H2. constructor. auto. intros x H3.
           apply put_in_elim in H3.  destruct  H3. subst x. apply /orP.  auto.
           eapply Sorted_elim4 in H as Ha. eauto. auto. } } Qed.

  Hint Resolve put_in_intro put_in_intro1 put_in_elim put_in_correct: core.

  Fixpoint sort_i (l: list A): list A:=
    match l with
    |nil => nil
    |a::l1 => put_in a (sort_i l1)
    end.

  Lemma sort_i_intro (l: list A): forall x, In x l -> In x (sort_i l).
  Proof. { intros x H. induction l. eauto. simpl. destruct H. subst x.
         apply put_in_intro1. auto using put_in_intro. } Qed.

  Lemma sort_i_elim (l: list A): forall x, In x (sort_i l) -> In x l.
  Proof. { intros x H. induction l. simpl in H. contradiction.
         simpl in H. apply put_in_elim in H. destruct H. subst x;eauto.
         eauto. } Qed.

  Lemma sort_i_is_correct (l: list A): Sorted (sort_i l).
  Proof. induction l. simpl. constructor. simpl. auto using put_in_correct. Qed.

  Hint Resolve sort_i_intro sort_i_elim sort_i_is_correct: core.

End ListSorting.

Hint Resolve max_spec max_in_elim: core.
Hint Resolve min_spec min_in_elim: core.

Hint Resolve Sorted_elim1 Sorted_elim2 Sorted_elim2a Sorted_elim3 Sorted_elim4: core.
Hint Resolve Sorted_single: core.

Hint Resolve put_in_intro put_in_intro1 put_in_elim put_in_correct: core.
Hint Resolve sort_i_intro sort_i_elim sort_i_is_correct: core.

 (* Definition l := 12::42::12::11::20::0::3::30::20::0::nil.
 Eval compute in (sort_i l).  *)


Require Export D.

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

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

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


Require Import Nat Arith.

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

Fixpoint tsize (tsize_arg0 : Tree) : nat
           := match tsize_arg0 with
              | leaf => 0
              | node x l r => plus 1 (plus (tsize l) (tsize r))
              end.

Theorem theorem0 : forall (x : Tree), ge (tsize x) 0.
Proof.
   intros.
   induction x.
   - simpl. apply le_O_n.
   - simpl. auto.
Qed.


(* Data and Functions

The proofs of these claims were always the same:
use simpl to simplify both sides of the equation,
then use reflexivity to check that both sides contain identical values.
*)

Inductive bool : Type :=
  | true
  | false.

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.

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

Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

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, b2, b3 with
  | true, true, true => true
  | _, _, _ => false
end.

Example test_andb31: (andb3 true true true) = true.
simpl. reflexivity.
Qed.

Example test_andb32: (andb3 false true true) = false.
simpl. reflexivity.
Qed.

Example test_andb33: (andb3 true false true) = false.
simpl. reflexivity.
Qed.

Example test_andb34: (andb3 true true false) = false.
simpl. reflexivity.
Qed.

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

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

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

Definition oddb (n:nat) : bool := negb (evenb n).

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

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

Fixpoint exp (base power : nat) : nat :=
  match power with
    | O => S O
    | S p => mult base (exp base p)
  end.

(*  factorial(0)  =  1
       factorial(n)  =  n * factorial(n-1)     (if n>0) *)

Fixpoint factorial (n:nat) : nat :=
match n with
| O => S O
| S p => mult n (factorial p)
end.

Compute (factorial 5).

Example test_factorial1: (factorial 3) = 6.
simpl. reflexivity.
Qed.

Example test_factorial2: (factorial 5) = (mult 10 12).
simpl. reflexivity.
Qed.

Fixpoint eqb (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' => eqb n' m'
            end
  end.

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

Fixpoint ltb (n m : nat) : bool :=
  (leb n m) && (negb (eqb n m)).

Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.
Notation "x <=? y" := (leb x y) (at level 70) : nat_scope.

Notation "x <? y" := (ltb x y) (at level 70) : nat_scope.

Example test_ltb1: (ltb 2 2) = false.
simpl. reflexivity.
Qed.

Example test_ltb2: (ltb 2 4) = true.
simpl. reflexivity.
Qed.

Example test_ltb3: (ltb 4 2) = false.
simpl. reflexivity.
Qed.

(* Proof by Simplification *)

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

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

Theorem mult_0_l : forall n:nat, 0 * n = 0.
Proof.
  intros n. reflexivity.
Qed.

(* Proof by Rewriting *)

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

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

(* Proof by Case Analysis

The destruct generates two subgoals, which we must then prove, separately, in order to get Coq to accept the theorem.
The annotation "as [| n']" is called an intro pattern.
*)

Theorem plus_1_neq_0 : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros n. destruct n as [| n'] eqn:E. (* The eqn:E annotation tells destruct to give the name E to this equation.*)
  - reflexivity.
  - reflexivity. Qed.

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
intros b c H.
destruct c eqn: E.
- reflexivity.
- rewrite <- H.
  + destruct b eqn: E2. reflexivity. reflexivity.
Qed.

Theorem andb_true_elim3 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros b c.
  destruct b.
  - destruct c.
    + reflexivity.
    + simpl. intros. assumption.
  - destruct c.
    + simpl. intros. reflexivity.
    + simpl. intros H. assumption.
Qed.

Theorem zero_nbeq_plus_1 : forall n : nat,
  0 =? (n + 1) = false.
Proof.
  intros n.
  destruct n as [|n'] eqn:E.
  - reflexivity.
  - 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 H b.
destruct b.
- rewrite H. rewrite H. reflexivity.
- rewrite H. rewrite H. reflexivity.
Qed.

(* Prove the following theorem.
(Hint: This one can be a bit tricky, depending on how you approach it.
You will probably need both destruct and rewrite,
but destructing everything in sight is not the best way. *)
Theorem andb_eq_orb :
  forall (b c : bool),
  (andb b c = orb b c) ->
  b = c.
Proof.
intros b c.
destruct b.
- simpl. intro. rewrite H. reflexivity.
- simpl. intro. rewrite H. reflexivity.
Qed.

Inductive bin : Type :=
  | Z
  | A (n : bin)
  | B (n : bin).

Fixpoint incr (m:bin) : bin :=
match m with
| Z => B Z
| B z => A (B z)
| A n => A (A n)
end.

Fixpoint bin_to_nat (m:bin): nat :=
match m with
| Z => O
| B z => S (bin_to_nat z)
| A n => S (bin_to_nat n)
end.

Definition bar: nat := 1.


Require Import Coq.Arith.PeanoNat.
Require Import EqNat.
Require Import Arith.

Lemma beq_nat_comm : forall (n m : nat),
  beq_nat n m = beq_nat m n.
Proof.
  intros.
  case_eq (beq_nat n m); intros Hbeq.
    rewrite (beq_nat_true n m Hbeq).
    apply beq_nat_refl.

    case_eq (beq_nat m n); intros Hbeq2.
      rewrite (beq_nat_true m n Hbeq2) in Hbeq.
      rewrite <- beq_nat_refl in Hbeq.
      discriminate.

      reflexivity.
Qed.

Lemma bi_contrapos : forall A B: Prop, (A <-> B) -> (~A <-> ~B).
Proof.
  intros A B; intros A_B.
  unfold iff; apply conj.
    intros not_A; intros pf_B.
    apply not_A.
    apply A_B; exact pf_B.

    intros not_B; intros pf_A.
    apply not_B.
    apply A_B; exact pf_A.
Qed.

Lemma bi_conj : forall A B C D: Prop, ((A <-> C) /\ (B <-> D)) -> ((A /\ B) <-> (C /\ D)).
Proof.
  intros A B C D.
  intros H.
  destruct H as [A_C B_D].
  unfold iff; apply conj.
    intros AandB.
    destruct AandB as [pf_A pf_B].
    apply conj.
      apply A_C; exact pf_A.

      apply B_D; exact pf_B.
    intros CandD.
    destruct CandD as [pf_C pf_D].
    apply conj.
      apply A_C; exact pf_C.

      apply B_D; exact pf_D.
Qed.

Lemma True_conj : forall (A B : Prop), (A <-> (True /\ B)) <-> (A <-> B).
Proof.
  intros.
  split.
    intros.
    split.
      intros.
      destruct H as [H1 H2].
      pose proof (H1 H0).
      apply H.

      intros.
      apply H.
      apply conj.
        exact I.

        exact H0.

    intros.
    split.
      intros.
      apply conj.
        exact I.

        apply H; exact H0.

      intros.
      apply H; apply H0.
Qed.

(* ------------ *)

Lemma arith_minus_exp : forall (i n m : nat),
  n - (m + i) = n - m - i.
Proof.
  induction i.
    intros.
    rewrite <- plus_n_O.
    rewrite Nat.sub_0_r.
    reflexivity.

    intros n m.
    rewrite <- plus_n_Sm.
    rewrite Nat.add_comm.
    rewrite plus_n_Sm.
    rewrite Nat.add_comm.
    rewrite IHi.
(* Search S plus.
    rewrite one_suc.
Search plus "comm".
    rewrite arith_plus_comm with (a := i). *)
    rewrite <- Nat.sub_add_distr.
    rewrite plus_Sn_m. rewrite plus_n_Sm.
    rewrite Nat.sub_add_distr. reflexivity.
Qed.

Lemma leb_plus_r : forall (i n m : nat),
  Nat.leb i n = true -> Nat.leb i (n + m) = true.
Proof.
  intros i' n' m.
  generalize n' i'.
  induction m; intros n i H.
    rewrite plus_0_r.
    exact H.

    specialize (IHm (n + 1) i).
    rewrite <- Nat.add_1_r.
    rewrite Nat.add_comm with (n := m).
    rewrite <- plus_assoc_reverse.
    apply IHm.
    rewrite Nat.add_1_r.
    apply leb_correct. apply le_S.
    apply leb_complete. assumption.
Qed.

Lemma leb_minus_pre : forall (n m : nat),
  Nat.leb n m = true -> Nat.leb (n-1) (m-1) = true.
Proof.
  intros n m Hleb.
  induction n.
    induction m.
      simpl; reflexivity.

      simpl in *; reflexivity.

    induction m.
      simpl in *; discriminate.

      simpl in *.
      do 2 rewrite Nat.sub_0_r.
      assumption.
Qed.

Lemma leb_minus : forall (i n m : nat),
  Nat.leb n m = true -> Nat.leb (n-i) (m-i) = true.
Proof.
  induction i.
    intros.
    do 2 rewrite Nat.sub_0_r; assumption.

    intros n m Hleb.
    rewrite <- Nat.add_1_r.
    rewrite Nat.add_comm.
    do 2 rewrite arith_minus_exp.
    apply IHi.
    apply leb_minus_pre.
    assumption.
Qed.


(* week_37a_sum.v *)
(* dIFP 2014-2015, Q1, Week 37 *)
(* Olivier Danvy <danvy@cs.au.dk> *)

(* ********** *)

(* The goal of this file is to study the sum function:
     sum f n = f 0 + f 1 + ... + f n
*)

(* ********** *)

Require Import Arith Bool.

Require Import unfold_tactic.

(* ********** *)

(* The canonical unfold lemmas
   associated to plus and mult,
   which are predefined:
*)

Lemma unfold_plus_bc :
  forall y : nat,
    0 + y = y.
(* left-hand side in the base case
   =
   the corresponding conditional branch *)
Proof.
  unfold_tactic plus.
Qed.

Lemma unfold_plus_ic :
  forall x' y : nat,
    (S x') + y = S (x' + y).
(* left-hand side in the inductive case
   =
   the corresponding conditional branch *)
Proof.
  unfold_tactic plus.
Qed.

Lemma unfold_mult_bc :
  forall y : nat,
    0 * y = 0.
(* left-hand side in the base case
   =
   the corresponding conditional branch *)
Proof.
  unfold_tactic mult.
Qed.

Lemma unfold_mult_ic :
  forall x' y : nat,
    (S x') * y = y + (x' * y).
(* left-hand side in the inductive case
   =
   the corresponding conditional branch *)
Proof.
  unfold_tactic mult.
Qed.

(* ********** *)

Notation "A === B" := (beq_nat A B) (at level 70, right associativity).

Definition unit_tests_for_sum (sum : (nat -> nat) -> nat -> nat) :=
  (sum (fun n => 0) 0 === 0)
  &&
  (sum (fun n => 0) 1 === 0 + 0)
  &&
  (sum (fun n => 0) 2 === 0 + 0 + 0)
  &&
  (sum (fun n => 1) 0 === 1)
  &&
  (sum (fun n => 1) 1 === 1 + 1)
  &&
  (sum (fun n => 1) 2 === 1 + 1 + 1)
  &&
  (sum (fun n => n) 0 === 0)
  &&
  (sum (fun n => n) 1 === 0 + 1)
  &&
  (sum (fun n => n) 2 === 0 + 1 + 2)
  &&
  (sum (fun n => n * n) 0 === 0 * 0)
  &&
  (sum (fun n => n * n) 1 === 0 * 0 + 1 * 1)
  &&
  (sum (fun n => n * n) 2 === 0 * 0 + 1 * 1 + 2 * 2)
  &&
  (sum (fun n => n * n) 3 === 0 * 0 + 1 * 1 + 2 * 2 + 3 * 3)
  &&
  (sum S 0 === 1)
  &&
  (sum S 1 === 1 + 2)
  &&
  (sum S 2 === 1 + 2 + 3)
  .

(* Exercise: add some more tests to this unit test. *)

(* ********** *)

Definition specification_of_sum (sum : (nat -> nat) -> nat -> nat) :=
  forall f : nat -> nat,
    sum f 0 = f 0
    /\
    forall n' : nat,
      sum f (S n') = sum f n' + f (S n').

(* ********** *)

Theorem there_is_only_one_sum :
  forall sum1 sum2 : (nat -> nat) -> nat -> nat,
    specification_of_sum sum1 ->
    specification_of_sum sum2 ->
    forall (f : nat -> nat)
           (n : nat),
      sum1 f n = sum2 f n.
Proof.
  intros sum1 sum2.
  intros S_sum1 S_sum2.
  intros f n.
  induction n as [ | n' IHn' ].
    unfold specification_of_sum in S_sum1.
    unfold specification_of_sum in S_sum2.
    destruct (S_sum1 f) as [ H_sum1_bc H_sum1_ic].
    destruct (S_sum2 f) as [ H_sum2_bc H_sum2_ic].
    clear S_sum1.
    clear S_sum2.
    rewrite -> H_sum2_bc.
    apply H_sum1_bc.

  unfold specification_of_sum in S_sum1.
  unfold specification_of_sum in S_sum2.
  destruct (S_sum1 f) as [ H_sum1_bc H_sum1_ic].
  destruct (S_sum2 f) as [ H_sum2_bc H_sum2_ic].
  clear S_sum1.
  clear S_sum2.
  rewrite -> (H_sum1_ic n').
  rewrite -> (H_sum2_ic n').
  rewrite -> IHn'.
  reflexivity.
Qed.
(* Replace "Abort." with a proof. *)

(* ********** *)

(* Misc. instances of the sum function: *)

Lemma about_sum_0 :
  forall sum : (nat -> nat) -> nat -> nat,
    specification_of_sum sum ->
    forall n : nat,
      sum (fun i => 0) n = 0.
Proof.
  intros sum S_sum n.
  induction n as [ | n' IHn' ].
    unfold specification_of_sum in S_sum.
    destruct (S_sum (fun _ : nat => 0)) as [ H_sum_bc H_sum_ic ].
    clear S_sum.
    apply H_sum_bc.
  unfold specification_of_sum in S_sum.
  destruct (S_sum (fun _ : nat => 0)) as [ H_sum_bc H_sum_ic ].
  clear S_sum.
  rewrite -> (H_sum_ic n').
  rewrite -> (plus_0_r (sum (fun _ : nat => 0) n')).
  apply IHn'.
Qed.

(* Replace "Abort." with a proof. *)

(* ***** *)

Lemma plus_1_l :
  forall n : nat,
    1 + n = S n.
Proof.
  intro n.
  rewrite -> (unfold_plus_ic 0 n).
  rewrite -> (unfold_plus_bc n).
  reflexivity.
Qed.

Lemma plus_1_r :
  forall n : nat,
    n + 1 = S n.
Proof.
  intro n.
  rewrite -> (plus_comm n 1).
  apply (plus_1_l n).
Qed.

Lemma about_sum_1 :
  forall sum : (nat -> nat) -> nat -> nat,
    specification_of_sum sum ->
    forall n : nat,
      sum (fun i => 1) n = S n.
Proof.
  intros sum S_sum n.
  induction n as [ | n' IHn'].
    unfold specification_of_sum in S_sum.
    destruct (S_sum (fun _ : nat => 1)) as [H_sum_bc H_sum_ic].
    clear S_sum.
    apply H_sum_bc.
  unfold specification_of_sum in S_sum.
  destruct (S_sum (fun _ : nat => 1)) as [_ H_sum_ic].
  clear S_sum.
  rewrite -> (H_sum_ic n').
  rewrite -> IHn'.
  rewrite -> (plus_Sn_m n' 1).
  rewrite -> (plus_1_r n').
  reflexivity.
Qed.

(* Replace "Abort." with a proof. *)

(* ***** *)

Lemma about_sum_identity :
  forall sum : (nat -> nat) -> nat -> nat,
    specification_of_sum sum ->
    forall n : nat,
      2 * sum (fun i => i) n = n * S n.
Proof.
  intros sum S_sum n.
  induction n as [ | n' IHn'].
    unfold specification_of_sum in S_sum.
    destruct (S_sum (fun i : nat => i)) as [H_sum_bc _].
    clear S_sum.
    rewrite -> H_sum_bc.
    rewrite -> (mult_0_r 2).
    rewrite -> (mult_0_l 1).
    reflexivity.
  unfold specification_of_sum in S_sum.
  destruct (S_sum (fun i : nat => i)) as [_ H_sum_ic].
  clear S_sum.
  rewrite -> (H_sum_ic n').
  Check mult_plus_distr_l.
  rewrite -> (mult_plus_distr_l 2 (sum (fun i : nat => i) n') (S n')).
  rewrite -> IHn'.
  Check mult_plus_distr_r.
  rewrite <- (mult_plus_distr_r n' 2 (S n')).
  Check plus_comm.
  rewrite -> (plus_comm n' 2).
  rewrite -> (unfold_plus_ic 1 n').
  rewrite -> (unfold_plus_ic 0 n').
  rewrite -> (plus_0_l n').
  Check mult_comm.
  rewrite -> (mult_comm (S (S n')) (S n')).
  reflexivity.
Qed.

(* ***** *)

Lemma about_sum_even_numbers :
  forall sum : (nat -> nat) -> nat -> nat,
    specification_of_sum sum ->
    forall n : nat,
      sum (fun i => 2 * i) n = n * S n.
Proof.
  intros sum S_sum n.
  induction n as [ | n' IHn'].
    unfold specification_of_sum in S_sum.
    destruct (S_sum (fun i => 2 * i)) as [H_sum_bc _].
    rewrite -> H_sum_bc.
    rewrite -> (mult_0_r 2).
    rewrite -> (mult_0_l 1).
    reflexivity.
  unfold specification_of_sum in S_sum.
  destruct (S_sum (fun i => 2 * i)) as [_ H_sum_ic].
  clear S_sum.
  rewrite -> (H_sum_ic n').
  rewrite -> IHn'.
  Check mult_plus_distr_r.
  rewrite <- (mult_plus_distr_r n' 2 (S n')).
  rewrite -> (plus_comm n' 2).
  rewrite -> (unfold_plus_ic 1 n').
  rewrite -> (unfold_plus_ic 0 n').
  rewrite -> (unfold_plus_bc n').
  rewrite -> (mult_comm (S (S n')) (S n')).
  reflexivity.
Qed.

(* ***** *)

Lemma a_humble_little_lemma :
  forall a b c : nat,
    a + b + b + c = a + 2 * b + c.
Proof.
  intros a b c.
  rewrite -> (unfold_mult_ic 1 b).
  rewrite -> (unfold_mult_ic 0 b).
  rewrite -> (unfold_mult_bc b).
  rewrite -> plus_0_r.
  rewrite -> plus_assoc.
  reflexivity.
Qed.

Lemma binomial_2 :
  forall x y : nat,
    (x + y) * (x + y) = x * x + 2 * x * y + y * y.
Proof.
  intros x y.
  rewrite -> (mult_plus_distr_r x y (x + y)).
  rewrite -> (mult_plus_distr_l x x y).
  rewrite -> (mult_plus_distr_l y x y).
  rewrite -> plus_assoc.
  rewrite <- (mult_assoc 2 x y).
  rewrite (unfold_mult_ic 1 (x * y)).
  rewrite (unfold_mult_ic 0 (x * y)).
  rewrite (unfold_mult_bc (x * y)).
  rewrite -> (plus_0_r (x * y)).
  rewrite -> plus_assoc.
  rewrite -> (mult_comm y x).
  reflexivity.

  Restart.

  intros x y.
  rewrite -> mult_plus_distr_r.
  rewrite -> mult_plus_distr_l.
  rewrite -> mult_plus_distr_l.
  rewrite -> plus_assoc.
  rewrite -> unfold_mult_ic.
  rewrite -> unfold_mult_ic.
  rewrite -> unfold_mult_bc.
  rewrite -> plus_assoc.
  rewrite -> plus_0_r.
  rewrite -> mult_plus_distr_r.
  rewrite -> plus_assoc.
  rewrite -> (mult_comm x y).
  reflexivity.
Qed.

Lemma about_sum_odd_numbers :
  forall sum : (nat -> nat) -> nat -> nat,
    specification_of_sum sum ->
    forall n : nat,
      sum (fun i => S (2 * i)) n = S n * S n.
Proof.
  intros sum S_sum n.
  induction n as [ | n' IHn'].
    unfold specification_of_sum in S_sum.
    destruct (S_sum (fun i : nat => S (2 * i))) as [H_sum_bc _].
    clear S_sum.
    rewrite -> (H_sum_bc).
    rewrite -> (mult_0_r 2).
    rewrite -> (mult_1_r 1).
    reflexivity.
  unfold specification_of_sum in S_sum.
  destruct (S_sum (fun i : nat => S (2 * i))) as [_ H_sum_ic].
  clear S_sum.
  rewrite -> (H_sum_ic n').
  rewrite -> IHn'.
  rewrite -> (unfold_mult_ic 1 (S n')).
  rewrite -> (unfold_mult_ic 0 (S n')).
  rewrite -> (unfold_mult_bc (S n')).
  rewrite -> (plus_0_r (S n')).
  rewrite <- (plus_Sn_m (S n') (S n')).
  rewrite -> (mult_succ_l (S n') (S (S n'))).
  rewrite -> (mult_succ_r (S n') (S n')).
  rewrite -> (plus_comm (S (S n')) (S n')).
  rewrite plus_assoc.
  reflexivity.
Qed.

(* ***** *)

(* From the June exam of dProgSprog 2012-2013: *)

Lemma factor_sum_on_the_left :
  forall sum : (nat -> nat) -> nat -> nat,
    specification_of_sum sum ->
    forall (h : nat -> nat)
           (c k : nat),
      sum (fun x => c * h x) k = c * sum (fun x => h x) k.
Proof.
  intros sum S_sum h c k.
Abort.

(* Replace "Abort." with a proof. *)

Lemma factor_sum_on_the_right :
  forall sum : (nat -> nat) -> nat -> nat,
    specification_of_sum sum ->
    forall (h : nat -> nat)
           (c k : nat),
      sum (fun x => h x * c) k = (sum (fun x => h x) k) * c.
Proof.
Abort.
(* Replace "Abort." with a proof. *)

Theorem June_exam :
  forall sum : (nat -> nat) -> nat -> nat,
    specification_of_sum sum ->
    forall (f g : nat -> nat)
           (m n : nat),
      sum (fun i => sum (fun j => f i * g j) n) m =
      (sum (fun i => f i) m) * (sum (fun j => g j) n).
Proof.
Abort.
(* Replace "Abort." with a proof. *)

(* ********** *)

(* Food for thought:
   is the following specification of sum
   equivalent to the one above?
*)

Definition alt_specification_of_sum (sum : (nat -> nat) -> nat -> nat) :=
  (forall f : nat -> nat,
    sum f 0 = f 0)
  /\
  (forall (f : nat -> nat)
          (n' : nat),
     sum f (S n') = sum f n' + f (S n')).

(* ********** *)

(* A first implementation: *)

Fixpoint sum_ds (f : nat -> nat) (n : nat) : nat :=
  match n with
  | 0 => f 0
  | S n' => sum_ds f n' + f n
  end.

Lemma unfold_sum_ds_bc :
  forall f : nat -> nat,
    sum_ds f 0 = f 0.
(* left-hand side in the base case
   =
   the corresponding conditional branch *)
Proof.
  unfold_tactic sum_ds.
Qed.

Lemma unfold_sum_ds_ic :
  forall (f : nat -> nat)
         (n' : nat),
    sum_ds f (S n') = sum_ds f n' + f (S n').
(* left-hand side in the inductive case
   =
   the corresponding conditional branch *)
Proof.
  unfold_tactic sum_ds.
Qed.

Definition sum_v0 (f : nat -> nat) (n : nat) : nat :=
  sum_ds f n.

Compute unit_tests_for_sum sum_v0.

Theorem sum_v0_satisfies_the_specification_of_sum :
  specification_of_sum sum_v0.
Proof.
  unfold specification_of_sum.
  unfold sum_v0.
  intro f.
  split.
Abort.
(* Replace "Abort." with a proof. *)

(* ********** *)

(* A second implementation: *)

Fixpoint sum_ds' (f : nat -> nat) (n : nat) : nat :=
  match n with
  | 0 => f 0
  | S n' => f n + sum_ds' f n'
  end.

Definition sum_v1 (f : nat -> nat) (n : nat) : nat :=
  sum_ds' f n.

Compute unit_tests_for_sum sum_v1.

Theorem sum_v1_satisfies_the_specification_of_sum :
  specification_of_sum sum_v1.
Proof.
Abort.
(* Replace "Abort." with a proof. *)

(*
   Prove the equivalence of sum_v0 and sum_v1.
*)

Theorem sum_v0_and_sum_v1_are_functionally_equal :
  forall (f : nat -> nat)
         (n : nat),
    sum_v0 f n = sum_v1 f n.
Proof.
Abort.
(* Replace "Abort." with a proof. *)

(* ********** *)

(* A third implementation: *)

Fixpoint sum_acc (f : nat -> nat) (n a : nat) : nat :=
  match n with
  | 0 => f 0 + a
  | S n' => sum_acc f n' (a + f n)
  end.

Definition sum_v2 (f : nat -> nat) (n : nat) : nat :=
  sum_acc f n 0.

(* Does this implementation fit the specification of sum? *)

(* ********** *)

(* A fourth implementation: *)

Fixpoint sum_acc' (f : nat -> nat) (n a : nat) : nat :=
  match n with
  | 0 => f 0 + a
  | S n' => sum_acc f n' (f n + a)
  end.

Definition sum_v3 (f : nat -> nat) (n : nat) : nat :=
  sum_acc' f n 0.

(* Does this implementation fit the specification of sum? *)

(* ********** *)

(* end of week_37a_sum.v *)