From iVM Require Import Init.

Unset Suggest Proof Using.

Local Open Scope Z.
Local Open Scope vector.

Notation Bits := Bvector.

Arguments Bsign {_} _.

(** ** Helpers *)

Proposition mul_nonneg (x y : Z) : 0 <= x -> 0 <= y -> 0 <= x * y.
Proof.
  intros Hx Hy.
  rewrite <- (Z2N.id _ Hx).
  rewrite <- (Z2N.id _ Hy).
  rewrite <- N2Z.inj_mul.
  apply N2Z.is_nonneg.
Qed.

Lemma div_neg z x (Hx: 0 < x) : z / x < 0 <-> z < 0.
Proof.
  split.
  - intros H. apply Znot_ge_lt. intros Hz. contradict H.
    apply Zle_not_lt, Z.ge_le, Z_div_ge0; lia.
  - intros Hz. apply Znot_ge_lt. intros H.
    set (H1 := Z.mul_div_le z x Hx).
    set (H2 := mul_nonneg x (z/ x)).
    lia.
Qed.

(** *** Powers of two

We focus on [2^n] for natural numbers n. Using [Z.shiftl] would be more
efficient, but we mainly use [2^n] for specification purposes (not
computations). *)

Lemma pow2_equation_0 : 2^0 = 1.
Proof. reflexivity. Qed.

Lemma pow2_equation_1 : 2 ^ 0%nat = 1.
Proof. simpl. exact pow2_equation_0. Qed.

Lemma pow2_equation_2 n : 2^(S n) = 2 * (2^n).
Proof.
  rewrite nat_N_Z, nat_N_Z, Nat2Z.inj_succ, Z.pow_succ_r.
  - reflexivity.
  - apply Nat2Z.is_nonneg.
Qed.

Hint Rewrite
     pow2_equation_0
     pow2_equation_1
     pow2_equation_2 : pow2.

Lemma pow2_pos (n: nat) : 0 < 2^n.
Proof.
  rewrite nat_N_Z.
  apply Z.pow_pos_nonneg, Nat2Z.is_nonneg; lia.
Qed.

Corollary pow2_nonneg (n: nat) : 0 <= 2^n.
Proof. apply Z.lt_le_incl, pow2_pos. Qed.

Corollary pow2_nonzero (n: nat) : 2^n <> 0.
Proof. apply Z.neq_sym, Z.lt_neq, pow2_pos. Qed.

Corollary pow2_div_zero (z: Z) (n: nat) : z / 2^n = 0 <-> 0 <= z < 2^n.
Proof.
  transitivity (0 <= z < 2 ^ n \/ 2 ^ n < z <= 0).
  - apply Z.div_small_iff, pow2_nonzero.
  - set (H := pow2_nonneg n). lia.
Qed.

Proposition pow2_action (m n: nat) : 2%Z^(m + n)%nat = 2%Z^m * 2%Z^n.
Proof.
  repeat rewrite nat_N_Z.
  rewrite Nat2Z.inj_add.
  apply Zpower_exp; apply Z.le_ge; apply Nat2Z.is_nonneg.
Qed.

(** *** Congruence modulo [2^n] *)

Section cong_section.

  Context (n: nat).

  Definition cong := irel (fun (z:Z) => z mod 2^n) eq.

  #[global] Instance cong_equivalence : Equivalence cong.
  Proof.
    apply irel_equivalence.
    typeclasses eauto.
  Qed.

  Proposition eq_cong z z' : z = z' -> cong z z'.
  Proof. apply eq_subrelation. Qed.

  #[global] Instance cong_add_proper : Proper (cong ==> cong ==> cong) Z.add.
  Proof.
    intros x x' Hx y y' Hy. unfold cong, irel in *.
    setoid_rewrite Z.add_mod; [ | apply pow2_nonzero ..].
    f_equal. f_equal; assumption.
  Qed.

  Corollary cong_eq x y : cong x y <-> cong (x - y) 0.
  Proof.
    split; intros H.
    - transitivity (x + (-y)).
      + apply eq_cong. lia.
      + setoid_rewrite H. apply eq_cong. lia.
    - transitivity ((x - y) + y).
      + apply eq_cong. lia.
      + setoid_rewrite H.  apply eq_cong. lia.
  Qed.

  #[global] Instance cong_mul_proper : Proper (cong ==> cong ==> cong) Z.mul.
  Proof.
    intros x x' Hx y y' Hy. unfold cong, irel in *.
    setoid_rewrite Z.mul_mod; [ | apply pow2_nonzero ..].
    f_equal. f_equal; assumption.
  Qed.

  (** Essentially just transitivity and symmetry. *)
  #[global] Instance cong_cong_proper : Proper (cong ==> cong ==> iff) cong.
  Proof. typeclasses eauto. Qed.

  Proposition cong_mod (z: Z) (m: nat) (Hm: m >= n) : cong (z mod 2^m) z.
  Proof.
    unfold cong, irel.
    by_lia (m = n + (m - n))%nat as H.
    rewrite H at 1.
    rewrite pow2_action.
    rewrite <- Znumtheory.Zmod_div_mod.
    - reflexivity.
    - apply pow2_pos.
    - apply Z.mul_pos_pos; apply pow2_pos.
    - auto with zarith.
  Qed.

  Corollary cong_zero k : cong (k * 2^n) 0.
  Proof.
    transitivity ((k * 2^n) mod 2^n).
    - symmetry. apply cong_mod. lia.
    - apply eq_cong. apply Z_mod_mult.
  Qed.

End cong_section.

(** *** Double and div2

Converting to/from bits we use [Z.double] and [Z.div2] for efficiency. *)

Proposition div2_double z : Z.div2 (Z.double z) = z.
Proof.
  rewrite Z.div2_div, Z.double_spec, Z.mul_comm, Z_div_mult;
    auto with zarith.
Qed.

Proposition div2_double1 z : Z.div2 (Z.double z + 1) = z.
Proof.
  rewrite Z.div2_div, Z.double_spec, Z.mul_comm, Z_div_plus_full_l;
    auto with zarith.
Qed.

Corollary div2_double2 z b : Z.div2 (Z.double z + Z.b2z b) = z.
Proof.
  destruct b; simpl.
  - apply div2_double1.
  - rewrite Z.add_0_r. apply div2_double.
Qed.

Lemma odd_double {z b} : Z.odd (Z.double z + Z.b2z b) = b.
Proof.
  rewrite Z.add_comm, Z.odd_add_mul_2.
  destruct b; reflexivity.
Qed.

Proposition double_neg z h : Z.double z + Z.b2z h < 0 <-> z < 0.
Proof.
  rewrite Z.double_spec.
  destruct h; simpl Z.b2z; lia.
Qed.

Proposition div2_odd (z: Z) : z = Z.double (Z.div2 z) + Z.b2z (Z.odd z).
Proof.
  rewrite Z.double_spec.
  apply Z.div2_odd.
Qed.

Proposition div2_reflects_lt x y : Z.div2 x < Z.div2 y -> x < y.
Proof.
  intros H.
  setoid_rewrite Z.div2_odd.
  do 2 destruct (Z.odd _); simpl Z.b2z; lia.
Qed.

Lemma div2_double_connection x y (Hx: 0 <= x) (Hy: 0 <= y) : Z.div2 x < y <-> x < Z.double y.
Proof.
  setoid_rewrite (div2_odd x) at 2.
  split.
  - intros H. apply div2_reflects_lt. rewrite div2_double2, div2_double. exact H.
  - setoid_rewrite Z.double_spec.
    rewrite Z.div2_div.
    destruct (Z.odd x); simpl Z.b2z; lia.
Qed.

(** ** To bits and back *)

(** *** Cleave *)

Equations cleave n (z: Z) : (Bits n) * Z :=
  cleave 0 z := ([], z);
  cleave (S n) z :=
    let (u, z') := cleave n (Z.div2 z) in
    (Z.odd z :: u, z').

Proposition cleave_action m n z :
  cleave (m + n) z = let (u, z') := cleave m z in
                     let (v, z'') := cleave n z' in
                     (u ++ v, z'').
Proof.
  revert z. induction m; intros z; cbn; simp cleave; cbn.
  - destruct (cleave n z); reflexivity.
  - rewrite IHm. clear IHm.
    destruct (cleave m (Z.div2 z)).
    destruct (cleave n z0).
    reflexivity.
Qed.

Lemma snd_cleave n z : snd (cleave n z) = z / 2^n.
Proof.
  revert z; induction n; intros z; simp cleave.
  - cbn. symmetry. apply Z.div_1_r.
  - specialize (IHn (Z.div2 z)).
    destruct (cleave n (Z.div2 z)) as [u z'].
    simpl snd in *.
    simp pow2.
    rewrite Z.div2_div, Z.div_div in IHn.
    + exact IHn.
    + lia.
    + apply pow2_pos.
Qed.

Corollary snd_cleave_neg n z : snd (cleave n z) < 0 <-> z < 0.
Proof.
  rewrite snd_cleave.
  apply div_neg, pow2_pos.
Qed.

(** *** Join *)

Equations join {n} (u: Bits n) (z: Z) : Z :=
  join [] z := z;
  join (h :: u) z := Z.double (join u z) + Z.b2z h.

Proposition join_action {m} (u: Bits m) {n} (v: Bits n) z :
  join u (join v z) = join (u ++ v) z.
Proof.
  induction m.
  - dependent elimination u. reflexivity.
  - dependent elimination u. cbn. simp join. rewrite IHm. reflexivity.
Qed.

Proposition join_diff {n} (u: Bits n) z1 z2 :
  join u z1 - join u z2 = 2^n * (z1 - z2).
Proof.
  induction n; simp pow2.
  - dependent elimination u. simp join.
    lia.
  - dependent elimination u as [Vector.cons (n:=n) h u].
    simp join.
    specialize (IHn u).
    rewrite <- Z.mul_assoc.
    rewrite <- IHn.
    clear IHn.
    setoid_rewrite Z.double_spec.
    destruct h; repeat simpl Z.b2z; lia.
Qed.

Corollary join_via_zero {n} (u: Bits n) z : join u z = 2^n * z + join u 0.
Proof.
  enough (join u z - join u 0 = 2^n * (z - 0)); [lia |].
  apply join_diff.
Qed.

Proposition join_neg {n} (u: Bits n) z : join u z < 0 <-> z < 0.
Proof.
  induction n.
  - dependent elimination u. tauto.
  - dependent elimination u as [Vector.cons (n:=n) h u].
    simp join.
    transitivity (join u z < 0).
    apply double_neg.
    exact (IHn u).
Qed.

Proposition join_zero {n} (u: Bits n) : 0 <= join u 0 < 2^n.
Proof.
  induction n.
  - dependent elimination u. simp join. cbn. lia.
  - dependent elimination u as [Vector.cons (n:=n) h u].
    simp join.
    specialize (IHn u).
    destruct IHn as [H1 H2].
    split.
    + rewrite Z.double_spec. destruct h; simpl Z.b2z; lia.
    + simp pow2. apply div2_reflects_lt.
      rewrite div2_double2, <- Z.double_spec, div2_double.
      exact H2.
Qed.

Corollary join_mod {n} (u: Bits n) z : join u z mod 2^n = join u 0.
Proof.
  symmetry.
  apply (Z.mod_unique_pos _ _ z).
  - apply join_zero.
  - apply join_via_zero.
Qed.

(** *** Bijection *)

Lemma join_cleave n z : uncurry join (cleave n z) = z.
Proof.
  unfold uncurry. revert z.
  induction n; intros z; simp cleave.
  - simp join. reflexivity.
  - specialize (IHn (Z.div2 z)).
    destruct (cleave n (Z.div2 z)).
    simp join. rewrite IHn.
    symmetry.
    apply div2_odd.
Qed.

Lemma cleave_join {n} (u: Bits n) z : cleave n (join u z) = (u, z).
Proof.
  revert z. induction n; intros z.
  - dependent elimination u. simp cleave join. reflexivity.
  - dependent elimination u as [Vector.cons (n:=n) h u].
    simp join cleave.
    rewrite div2_double2.
    rewrite IHn. clear IHn.
    f_equal.
    f_equal.
    apply odd_double.
Qed.

(** *** fromBits and toBits *)

Definition toBits n z := fst (cleave n z).

Definition fromBits {n} (u: Bits n) := join u 0.

Proposition toBits_fromBits {n} (u: Bits n) : toBits n (fromBits u) = u.
Proof.
  unfold fromBits, toBits.
  rewrite cleave_join.
  reflexivity.
Qed.

(* TODO: Standard property of sections. *)
Corollary fromBits_injective {n} (u u': Bits n) :
  fromBits u = fromBits u' -> u = u'.
Proof.
  intros H. setoid_rewrite <- toBits_fromBits.
  f_equal. exact H.
Qed.

Proposition fromBits_toBits_mod {n} z : fromBits (toBits n z) = z mod 2^n.
Proof.
  unfold fromBits, toBits.
  given (join_cleave n z) as Hj.
  destruct (cleave n z) as [u z'] eqn:Hz.
  cbn.
  symmetry.
  rewrite <- Hj.
  apply join_mod.
Qed.

Corollary toBits_congruence (n: nat) z z' :
  toBits n z = toBits n z' <-> z mod 2^n = z' mod 2^n.
Proof.
  split; intro H.
  - setoid_rewrite <- fromBits_toBits_mod.
    f_equal.
    exact H.
  - apply fromBits_injective.
    setoid_rewrite fromBits_toBits_mod.
    exact H.
Qed.

Corollary fromBits_toBits (n: nat) z : 0 <= z < 2^n <-> fromBits (toBits n z) = z.
Proof.
  rewrite fromBits_toBits_mod.
  setoid_rewrite Z.mod_small_iff; [| apply pow2_nonzero].
  split; [ tauto |].
  intros [H|H]; [exact H |].
  exfalso.
  given (pow2_pos n) as HH.
  lia.
Qed.

(* TODO: Remove? *)
Proposition join_spec {n} (u: Bits n) z : join u z = fromBits u + 2^n * z.
Proof.
  unfold fromBits.
  enough (join u z - join u 0 = 2 ^ n * (z - 0)); [lia|].
  apply join_diff.
Qed.

(** *** Via [N] *)

Definition bitsToN {n} (u: Bits n) : N := Z.to_N (fromBits u).

Proposition ofN_bitsToN {n} (u: Bits n) : Z.of_N (bitsToN u) = fromBits u.
Proof.
  unfold bitsToN. rewrite Z2N.id.
  - reflexivity.
  - unfold fromBits. apply join_zero.
Qed.

Corollary toBits_ofN_bitsToN {n} (u: Bits n) : toBits n (Z.of_N (bitsToN u)) = u.
Proof.
  rewrite <- (toBits_fromBits u) at 2.
  f_equal.
  apply ofN_bitsToN.
Qed.

(** *** Signed integers *)

Local Notation signOffset u := (if Bsign u then -1 else 0).

Definition bitsToZ {n} (u: Bits (S n)) : Z := join u (signOffset u).

Definition butSign {n} (u: Bits (S n)) : Bits n.
Proof.
  induction n.
  - exact [].
  - dependent elimination u as [h :: u].
    exact (h :: (IHn u)).
Defined.

Proposition butSign_equation_1 s : butSign [s] = [].
Proof. reflexivity. Qed.

Proposition butSign_equation_2 {n} (u: Bits (S n)) h :
  butSign (h :: u) = h :: butSign u.
Proof. reflexivity. Qed.

Hint Rewrite butSign_equation_1 : butSign.
Hint Rewrite @butSign_equation_2 : butSign.
#[global] Opaque butSign.

Proposition bitsToZ_split {n} (u: Bits (S n)) :
  bitsToZ u = join (butSign u) (signOffset u).
Proof.
  unfold bitsToZ.
  induction n.
  - dependent elimination u as [h :: u].
    dependent elimination u.
    destruct h; reflexivity.
  - dependent elimination u as [h :: u].
    specialize (IHn u).
    simp butSign join.
    cbn.
    f_equal.
    f_equal.
    exact IHn.
Qed.

Corollary bitsToZ_range {n} (u: Bits (S n)):
  -2^n <= bitsToZ u < 2^(S n).
Proof.
  rewrite bitsToZ_split.
  set (H := join_zero (butSign u)).
  simp pow2.
  destruct (Bsign u); [rewrite join_via_zero |]; lia.
Qed.

(** *** Multiplication and addition *)

Local Proposition inj_0 : N.of_nat 0 = 0%N.
Proof. reflexivity. Qed.

Local Proposition inj_1 : N.of_nat 1 = 1%N.
Proof. reflexivity. Qed.

Local Proposition Ninj_1 : Z.of_N 1 = 1%Z.
Proof. reflexivity. Qed.

Hint Rewrite <- N.add_1_l Z.add_1_l : ZZ.

Hint Rewrite
     inj_0 inj_1
     Nnat.Nat2N.inj_add
     Nnat.Nat2N.inj_mul

     N2Z.inj_0 Ninj_1
     N2Z.inj_add
     N2Z.inj_mul

     Z.add_assoc
     Z.add_0_l Z.add_0_r
     Z.add_opp_l Z.add_opp_r

     Z.sub_0_l
     Z.sub_opp_l Z.sub_opp_r
     Z.sub_0_l Z.sub_0_r

     Z.opp_0
     Z.opp_involutive

     Z.mul_assoc
     Z.mul_0_l Z.mul_0_r
     Z.mul_1_l Z.mul_1_r
     Z.mul_opp_l Z.mul_opp_r

     Z.mul_add_distr_l Z.mul_add_distr_r
     Z.mul_sub_distr_l Z.mul_sub_distr_r

     Z.double_spec
     Z.div2_div

     pow2_equation_0
     pow2_equation_1
     pow2_equation_2
  : ZZ.

(** More congruence **)

Proposition toBits_cong n z z' : cong n z z' <-> toBits n z = toBits n z'.
Proof.
  unfold cong, irel.
  rewrite toBits_congruence.
  reflexivity.
Qed.

Instance toBits_proper n : Proper (cong n ==> eq) (toBits n).
Proof.
  intros z z' Hz.
  apply toBits_cong.
  exact Hz.
Qed.

Proposition fromBits_toBits_cong n z : cong n (fromBits (toBits n z)) z.
Proof.
  rewrite fromBits_toBits_mod.
  setoid_rewrite cong_mod.
  - reflexivity.
  - lia.
Qed.

Corollary ofN_bitsToN_toBits_cong n z : cong n (Z.of_N (bitsToN (toBits n z))) z.
Proof.
  rewrite ofN_bitsToN.
  apply fromBits_toBits_cong.
Qed.

(** ** Bytes *)

Notation B8 := (Bits 8).
Notation B16 := (Bits 16).
Notation B32 := (Bits 32).
Notation B64 := (Bits 64).

Definition Bytes n := vector B8 n.

(* It seems Equations is not able to handle these definitions yet,
   even though [dependent elimination] works as expected. *)

Definition bitsToBytes {n} (u: Bits (n * 8)) : Bytes n.
Proof.
  induction n.
  - exact [].
  - simpl in u.
    dependent elimination u as [b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: u].
    exact ([b0; b1; b2; b3; b4; b5; b6; b7] :: IHn u).
Defined.

Proposition bitsToBytes_equation_1 : @bitsToBytes (0 * 8) [] = [].
Proof. reflexivity. Qed.

Proposition bitsToBytes_equation_2 {n} b0 b1 b2 b3 b4 b5 b6 b7 (u: Bits (n * 8)) :
  @bitsToBytes (S n) (b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: u) =
  [b0; b1; b2; b3; b4; b5; b6; b7] :: bitsToBytes u.
Proof. reflexivity. Qed.

Hint Rewrite bitsToBytes_equation_1 @bitsToBytes_equation_2 : bitsToBytes.
#[global] Opaque bitsToBytes.

Definition bytesToBits {n} (u: Bytes n) : Bits (n * 8).
Proof.
  induction n.
  - exact [].
  - dependent elimination u as [ [b0; b1; b2; b3; b4; b5; b6; b7] :: u].
    exact (b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: IHn u).
Defined.

Proposition bytesToBits_equation_1 : bytesToBits [] = [].
Proof. reflexivity. Qed.

Proposition bytesToBits_equation_2 n b0 b1 b2 b3 b4 b5 b6 b7 (u: Bytes n) :
  @bytesToBits (S n) ([b0; b1; b2; b3; b4; b5; b6; b7] :: u) =
  b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: bytesToBits u.
Proof. reflexivity. Qed.

Proposition bytesToBits_equation_3 (u: Bits 8) : bytesToBits [u] = u.
Proof.
  dependent elimination u as [b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: []].
  reflexivity.
Qed.

Hint Rewrite bytesToBits_equation_1 @bytesToBits_equation_2 @bytesToBits_equation_3 : bytesToBits.
#[global] Opaque bytesToBits.

Lemma bitsToBytes_bytesToBits {n} (u: Bytes n) : bitsToBytes (bytesToBits u) = u.
Proof.
  induction n.
  - dependent elimination u; reflexivity.
  - dependent elimination u as [ [b0; b1; b2; b3; b4; b5; b6; b7] :: u].
    simp bytesToBits bitsToBytes. rewrite IHn. reflexivity.
Qed.

Lemma bytesToBits_bitsToBytes {n} (u: Bits (n * 8)) : bytesToBits (bitsToBytes u) = u.
Proof.
  induction n.
  - dependent elimination u; reflexivity.
  - dependent elimination u as [b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: u].
    simp bitsToBytes bytesToBits. rewrite IHn. reflexivity.
Qed.

(***)

Corollary toBits_cong' n z : cong n (Z.of_N (bitsToN (toBits n z))) z.
Proof.
  rewrite ofN_bitsToN, fromBits_toBits_mod.
  apply cong_mod.
  lia.
Qed.

#[export] Hint Opaque cong : rewrite.

Ltac cong_tac :=
  apply toBits_cong;
  rewrite toBits_cong';
  apply eq_cong;
  lia.

Instance cong_toBits_proper n : Proper (cong n ==> eq) (toBits n).
Proof. intros z z' Hz. apply toBits_cong. exact Hz. Qed.

Corollary fromBits_toBits' n (u: Bits n) : toBits n (Z.of_N (bitsToN u)) = u.
Proof. rewrite ofN_bitsToN. apply toBits_fromBits. Qed.

(***)

Corollary bytesToBits_injective {n} {u v: Bytes n} (H: bytesToBits u = bytesToBits v) : u = v.
Proof.
  apply (f_equal bitsToBytes) in H.
  setoid_rewrite bitsToBytes_bytesToBits in H.
  exact H.
Qed.

Corollary bitsToN_injective {n} {u v: Bits n} (H: bitsToN u = bitsToN v) : u = v.
Proof.
  apply (f_equal Z.of_N) in H.
  apply (f_equal (toBits n)) in H.
  setoid_rewrite toBits_ofN_bitsToN in H.
  exact H.
Qed.

Proposition bitsToN_bound {n} (u: Bits n) : (bitsToN u < 2 ^ n)%N.
Proof.
  assert ((2^n)%N = 2^n :> Z) as H; [ now rewrite N2Z.inj_pow | ].
  unfold bitsToN, fromBits.
  apply N2Z.inj_lt.
  rewrite N2Z.inj_pow.
  destruct (join_zero u) as [H0 H64].
  lia.
Qed.

(** ** Bytes to longs *)

(** Cf. [bitsToBytes] *)
Definition bytesToLongs {n} (u: Bytes (n * 8)) : vector B64 n.
Proof.
  induction n.
  - exact [].
  - simpl in u.
    dependent elimination u as [b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: u].
    exact ((b0 ++ b1 ++ b2 ++ b3 ++ b4 ++ b5 ++ b6 ++ b7) :: IHn u).
Defined.

Proposition bytesToLongs_equation_1 : @bytesToLongs (0 * 8) [] = [].
Proof. reflexivity. Qed.

Proposition bytesToLongs_equation_2 {n} b0 b1 b2 b3 b4 b5 b6 b7 (u: Bytes (n * 8)) :
  @bytesToLongs (S n) (b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: u) =
  (b0 ++ b1 ++ b2 ++ b3 ++ b4 ++ b5 ++ b6 ++ b7) :: bytesToLongs u.
Proof. reflexivity. Qed.

Hint Rewrite bytesToLongs_equation_1 @bytesToLongs_equation_2 : bytesToLongs.
#[global] Opaque bytesToLongs.

Proposition bytesToBits_equation_2' {n} b (u: Bytes n) :
  @bytesToBits (S n) (b :: u) = b ++ bytesToBits u.
Proof.
  dependent elimination b as [b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: []].
  simp bytesToBits.
  reflexivity.
Qed.

Proposition bytesToLongs_equation_2' {n} b0 b1 b2 b3 b4 b5 b6 b7 (u: Bytes (n * 8)) :
  @bytesToLongs (S n) (b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: u) =
  (bytesToBits ([b0; b1; b2; b3; b4; b5; b6; b7] : Bytes 8)) :: bytesToLongs u.
Proof.
  (* TODO: Can this be done more elegantly? *)
  simp bytesToLongs.
  repeat rewrite bytesToBits_equation_2'.
  repeat f_equal.
  dependent elimination b7 as [c0 :: c1 :: c2 :: c3 :: c4 :: c5 :: c6 :: c7 :: []].
  reflexivity.
Qed.


(*** Introduction to Computational Logic, Coq part of Assignment 9 ***)

Require Import Arith Lia.

(*** Exercise 9.1 ***)

(* The first 5 exercises are stated for the explicit definition of x <= y. *)

Section LE.

Definition le (x y : nat) : Prop :=
  exists k, x + k = y.

Notation "x <= y" := (le x y).
Notation "x < y" := (le (S x) y).

Definition dec (X : Prop) :=
  {X} + {~ X}.

Lemma origin x :
  0 <= x.
Proof.
  now exists x.
Qed.

Lemma refl x :
  x <= x.
Proof.
  now exists 0.
Qed.

Lemma trans x y z :
  x <= y -> y <= z -> x <= z.
Proof.
  intros [k H1] [l H2].
  exists (k + l). now rewrite plus_assoc, H1.
Qed.

Lemma antisym x y :
  x <= y -> y <= x -> x = y.
Proof.
  intros [k H1] [l H2].
  assert (H: forall m n, m + n = m -> n = 0).
  { intros m n. induction m as [|m IH].
    - now cbn.
    - cbn. intros H%Nat.succ_inj. apply IH, H.
  }
  rewrite <- H1 in H2. rewrite <- plus_assoc in H2. apply H, plus_is_O in H2 as [H2 _].
  now rewrite H2, Nat.add_0_r in H1.
Qed.

Lemma shift x y :
  S x <= S y <-> x <= y.
Proof.
  split.
  - intros [k H]. exists k. cbn. now apply Nat.succ_inj.
  - intros [k H]. exists k. cbn. now rewrite H.
Qed.

Lemma strict x :
  ~ x < x.
Proof.
  intros [k H]. destruct k.
  - cbn in H. rewrite Nat.add_0_r in H. now apply Nat.neq_succ_diag_l in H.
Abort.

Lemma minimum x :
  ~ x < 0.
Proof.
  intros H. destruct H as [k H]. lia.
Qed.

(*** Exercise 9.2 ***)

Lemma add_sub_eq x y :
  x + y - x = y.
Proof.
  induction x as [|x IH]; cbn.
  - apply Nat.sub_0_r.
  - exact IH.
Qed.

Lemma le_add_sub x y :
  x <= y -> x + (y - x) = y.
Proof.
  intros [k H].
  Abort.

(*** Exercise 9.3 ***)

Lemma linearity :
  forall n m, n <= m \/ m <= n.
Proof.
  intros n m. induction n as [|n IH] in m |-*.
  - left. apply origin.
  - destruct m.
    + right. now exists (S n).
    + destruct (IH m) as [[k H1]|[l H2]].
      * left. exists k. cbn. now rewrite H1.
      * right. exists l. cbn. now rewrite H2.
Qed.

Lemma trichotomy :
  forall n m, n < m \/ n = m \/ m < n.
Proof.
  intros n m. specialize (linearity n m) as [[k H1]|[l H2]].
  - left. exists (k - 1). rewrite <- H1.
    Abort.

Lemma not_lt_le x y :
  ~ (y < x) -> x <= y.
Proof.
  (*...*)
Admitted.

Lemma not_lt_eq x y :
  ~ (x < y) -> ~ (y < x) -> x = y.
Proof.
  (*...*)
Admitted.

(*** Exercise 9.4 ***)

Lemma le_iff x y :
  x <= y <-> x - y = 0.
Proof.
  split.
  - intros [k <-]. lia.
  - intros H. exists (y - x). lia.
Qed.

Lemma le_dec x y :
  dec (x <= y).
Proof.
  induction x as [|x IH] in y |-*.
  - left. apply origin.
  - destruct y.
    + right. apply minimum.
    + specialize (IH y) as [H|H].
      * left. destruct H as [k H]. exists k. cbn. now rewrite H.
      * right. contradict H. destruct H as [k H]. cbn in H.
        exists k. now apply Nat.succ_inj.
Qed.

Lemma le_dec' x y :
  dec (x <= y).
Proof.
  destruct (x - y) eqn:H.
  - left. now apply le_iff.
  - right. intros H2. apply le_iff in H2. congruence.
Qed.

Fixpoint le_bool (x y : nat) : bool :=
  match x, y with
  | O, y => true
  | S _, O => false
  | S x, S y => le_bool x y
  end.

Lemma le_bool_spec x y :
  x <= y <-> le_bool x y = true.
Proof.
  split.
  - intros H. destruct (le_bool x y) eqn:H2.
    + reflexivity.
    + rewrite <- H2. destruct x, y.
      * reflexivity.
      * reflexivity.
      * exfalso. now apply (minimum x).
      * destruct H as [k H].
        Abort.

(*** Exercise 9.5 ***)

Lemma nat_dec (x y : nat) :
  dec (x = y).
Proof.
  (*...*)
Admitted.

End LE.

(*** Exercise 9.6 ***)

(* We now switch to the pre-defined x <= y and fully rely on lia. *)

Lemma size_induction X (f : X -> nat) (p : X -> Type) :
  (forall x, (forall y, f y < f x -> p y) -> p x) -> forall x, p x.
Proof.
  (* intros H x. specialize (H x). apply H. *)
  (* intros y H2. induction (f x) as [|fx IH]. *)
  (* - destruct (f y). *)
  (*   +  *)
Admitted.

Lemma complete_induction (p : nat -> Type) :
  (forall x, (forall y, y < x -> p y) -> p x) -> forall x, p x.
Proof.
  apply (size_induction _ (fun x => x)).
Qed.

(*** Exercise 9.7 ***)

Lemma div_mod_unique y a b a' b' :
  b <= y -> b' <= y -> a * S y + b = a' * S y + b' -> a = a' /\ b = b'.
Proof.
  intros H1 H2.
  induction a as [|a IH] in a' |-*; destruct a'; cbn.
  - lia.
  - lia.
  - lia.
  - specialize (IH a'). lia.
Qed.

Lemma le_lt_dec x y :
  {x <= y} + {y < x}.
Proof.
  induction x as [|x IH] in y |-*.
  - left. lia.
  - destruct y as [|y].
    + right. lia.
    + specialize (IH y) as [IH|IH].
      * left. lia.
      * right. lia.
Qed.

Theorem div_mod x y :
  { a & { b & x = a * S y + b /\ b <= y}}.
Proof.
  (*...*)
Admitted.

Definition D (x y : nat) := (*...*) 0.
Definition M (x y : nat) := (*...*) 0.

Lemma DM_spec1 x y :
  x = D x y * S y + M x y.
Proof.
  (*...*)
Admitted.

Lemma DM_spec2 x y :
  M x y <= y.
Proof.
  (*...*)
Admitted.

(*** Exercise 9.8 ***)

Definition divides x y :=
  x <> 0 /\ exists k, y = k * x.

Lemma divides_dec x y :
  dec (divides x y).
Proof.
 (*...*)
Admitted.

Definition cong x y k :=
  (x <= y /\ divides k (y - x)) \/ (y < x /\ divides k (x - y)).

Lemma cong_dec x y k :
  dec (cong x y k).
Proof.
  (*...*)
Admitted.

(*** Exercise 9.10 ***)

Definition spec_exp mu :=
  forall f n, (f (mu f n) = true -> mu f n <= n /\ forall k, k < mu f n -> f k = false)
         /\ (f (mu f n) = false -> mu f n = n /\ forall k, k <= n -> f k = false).

Definition wf X (R : X -> X -> Prop) :=
  forall f, (exists x, f x = true) -> exists x, f x = true /\ forall y, f y = true -> R x y.

Lemma nat_wf mu :
  spec_exp mu -> wf nat (fun x y => x <= y).
Proof.
  (*...*)
Admitted.

(*** Exercise 9.11 ***)

Section S1.
  Variables (f: nat -> bool)
            (mu: nat -> nat)
            (R1: mu 0 = 0)
            (R2: forall n, mu (S n) = if f (mu n) then mu n else S n).

  Goal forall n, if f (mu n)
            then mu n <= n /\ forall k, k < mu n -> f k = false
            else mu n = n /\ forall k, k <= n -> f k = false.
  Proof.
    (*...*)
  Admitted.

  Variables (mu': nat -> nat)
            (R1': mu' 0 = 0)
            (R2': forall n, mu' (S n) = if f (mu' n) then mu' n else S n).

  Goal forall n, mu n = mu' n.
  Proof.
    (*...*)
  Admitted.
End S1.

Section S2.
  Variables (f: nat -> bool) (mu: nat -> nat).
  Variable (R: forall n, if f (mu n)
                    then mu n <= n /\ forall k, k < mu n -> f k = false
                    else mu n = n /\ forall k, k <= n -> f k = false ).

  Goal forall n, mu n <= n.
  Proof.
    (*...*)
  Admitted.

  Goal forall n k, k < mu n -> f k = false.
  Proof.
    (*...*)
  Admitted.

  Goal forall n, mu n < n -> f (mu n) = true.
  Proof.
     (*...*)
  Admitted.
End S2.

Section S3.
    Variables (f: nat -> bool) (mu: nat -> nat).
    Variables (R1: forall n, mu n <= n)
              (R2: forall n k, k < mu n -> f k = false)
              (R3: forall n, mu n < n -> f (mu n) = true).

    Goal mu 0 = 0.
    Proof.
      (*...*)
    Admitted.

    Goal forall n, mu (S n) = if f (mu n) then mu n else S n.
    Proof.
      (*...*)
    Admitted.
End S3.

(*** Exercise 9.12 ***)

Section Challenge.

  Variable D M : nat -> nat -> nat.
  Hypothesis DM1 : forall x y, x = D x y * S y + M x y.
  Hypothesis DM2 : forall x y, M x y <= y.

  Goal forall x y, y < x -> D x y = S (D (x - S y) y).
  Proof.
    (*...*)
  Admitted.

  Goal forall x y, x <= y -> D x y = 0.
  Proof.
    (*...*)
  Admitted.

End Challenge.


(************************************************************************)
(* Copyright 2006 Milad Niqui                                           *)
(* This file is distributed under the terms of the                      *)
(* GNU Lesser General Public License Version 2.1                        *)
(* A copy of the license can be found at                                *)
(*                  <http://www.gnu.org/licenses>                       *)
(************************************************************************)

Require Import digits.

Close Scope Z_scope.

(** We define a function [lb] that returns the #<em>#upper bound#</em># of the
interval obtained by applying the initial segment of length [n] of
[alpha] to the base interval #[#-1,+1#]#.*)

Fixpoint lb (alpha:Reals) (n:nat) {struct n} : Q :=
  match n with
  |   O => (Qopp 1) (* this is because of base interval, and that d(-1)=-1 *)
  | S p => let (d,alpha'):= alpha in let q := lb alpha' p in
           as_Moebius_Q d q
  end.

Lemma lb_S_n:forall n alpha, lb alpha (S n) = as_Moebius_Q (hd alpha) (lb (tl alpha) n).
Proof.
 intros n [d alpha']; trivial.
Defined.

Lemma lb_is_in_base_interval:forall k alpha,  - Qone <= lb alpha k /\ lb alpha k <= Qone.
Proof.
 intro k; induction k; intro alpha.
 (* 0 *)
 split; unfold lb; natq_one; try rewrite <- Z_to_Qopp; apply Z_to_Qle; auto with zarith.
 (* S k *)
 destruct alpha as [[ | | ] alpha']; generalize (IHk alpha'); clear IHk;
 rewrite lb_S_n; unfold hd, tl; set (l':=lb alpha' k); intros [IHk_1 IHk_2].

  (* L *)
  (* TP: Zero <= l'+ 1 *)
  assert (H_l'_one_nonneg: Zero <= l'+1).
  stepr (l'-(Qopp 1)); try ring; apply Qle_Qminus_Zero; auto.
  (* TP: Zero < l'+3 *)
  assert (H_l'_three_pos: Zero < l'+3).
  apply Qle_lt_trans with (l'+1); auto;
  apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring.
  (* TP: Zero <= 2*l'+ 2 *)
  assert (H_2l'_two_nonneg: Zero <= 2*l'+2).
  stepr (2*(l'+1)); [|qZ_numerals; ring]; apply Qle_mult_nonneg_nonneg; auto.
  (* TP: Zero <= l'+ 2 *)
  assert (H_l'_two_nonneg: Zero <= l'+2).
  apply Qle_trans with (l'+1); auto;
  apply Qle_plus_plus; try apply Qle_reflexive; apply Z_to_Qle; apply inj_le; auto.

  rewrite as_Moebius_Q_L; trivial; natZ_numerals.

  split; apply Qmult_resp_Qle_pos_r with (l'+3); auto.
   stepr (l'-1).
    apply Qle_Zero_Qminus;
    stepr (2*l'+2); auto; qnat_S 2; qnat_S 1; qnat_one; ring.
    generalize (l'-1) (l'+3) H_l'_three_pos; intros; field; auto.

   stepl (l'-1).
    apply Qle_Zero_Qminus;
    stepr 4; auto; qnat_S 3; qnat_S 2; qnat_S 1; qnat_one; ring.
    generalize (l'-1) (l'+3) H_l'_three_pos; intros; field; auto.

  (* R *)
  (* TP: Zero <= -l'+ 1 *)
  assert (H_min_l'_one_nonneg: Zero <= -l'+1).
  stepr (1-l'); try ring; apply Qle_Qminus_Zero; auto.
  (* TP: Zero < -l'+3 *)
  assert (H_min_l'_three_pos: Zero < -l'+3).
  apply Qle_lt_trans with ((-l')+1); auto.
  apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring.
  (* TP: Zero <= 2*(-l')+ 2 *)
  assert (H_2_min_l'_two_nonneg: Zero <= 2*(-l')+2).
  stepr (2*(-l'+1)); [|qZ_numerals; ring]; apply Qle_mult_nonneg_nonneg; auto.

  rewrite as_Moebius_Q_R; trivial; natZ_numerals.

  split; apply Qmult_resp_Qle_pos_r with (-l'+3); auto.
   stepr (l'+1).
    apply Qle_Zero_Qminus;
    stepr 4; auto; qnat_S 3; qnat_S 2; qnat_S 1; qnat_one; ring.
    generalize (l'+1) (-l'+3) H_min_l'_three_pos; intros; field; auto.

   stepl (l'+1).
    apply Qle_Zero_Qminus;
    stepr (2*(-l')+2); auto; qnat_S 2; qnat_S 1; qnat_one; ring.
    generalize (l'+1) (-l'+3) H_min_l'_three_pos; intros; field; auto.

  (* M *)
  rewrite as_Moebius_Q_M; natZ_numerals.

  split; apply Qmult_resp_Qle_pos_r with 3; auto;
  [ stepr l' | stepl l'].
  apply Qle_trans with (-Qone); auto; apply Qlt_le_weak; apply Qlt_Zero_Qminus; stepr 2; auto.
  generalize l'; intro; field; auto.
  apply Qle_trans with Qone; auto; apply Qlt_le_weak; apply Qlt_Zero_Qminus; stepr 2; auto.
  generalize l'; intro; field; auto.
Defined.

Lemma lb_is_in_base_interval_low:forall k alpha, - Qone <= lb alpha k.
Proof.
 intros k alpha; elim (lb_is_in_base_interval k alpha); trivial.
Defined.

Lemma lb_is_in_base_interval_up:forall k alpha, lb alpha k <= Qone.
Proof.
 intros k alpha; elim (lb_is_in_base_interval k alpha); trivial.
Defined.

(** This is similar to Lemma 5.7.2.i in the thesis. *)
Lemma thesis_5_7_2i_l:forall (k:nat) alpha, ~(lb alpha k = Qopp 1) -> (-k)/(k+2) <= lb alpha k.
Proof.
 intro k; induction k; intros alpha H_nonzero.

  (* 0 *)
  apply False_ind; apply H_nonzero; trivial.
  (* S k *)
  rewrite lb_S_n;
  rewrite lb_S_n in H_nonzero.
  (* TP: Zero < k + Qone *)
  assert (H_k_one_pos: Zero < k + Qone ).
  natq_S k; natq_zero; apply Z_to_Qlt; apply inj_lt; apply lt_O_Sn.
  (* TP: Zero < k + 2 *)
  assert (H_k_two_pos: Zero < k + 2 ).
  stepr ((k+Qone)+Qone);
  [ natq_S k; natq_S (S k); natq_zero; auto
  | qnat_S 1; qnat_one; ring].
  (* TP: O <= k  *)
  assert (H_k_nonneg:  0 <= k).
  apply Z_to_Qle; apply inj_le; auto with arith.
  (* TP: Qone <= 2 * k + 3*)
  assert (H_2k_3_nonneg:  Qone <= 2 * k + 3).
  apply Qle_Zero_Qminus; stepr (2*(k+1));
  [ apply Qle_mult_nonneg_nonneg; auto
  | qnat_S 2; qnat_S 1; qnat_one; ring
  ].

  destruct alpha as [[ | | ] alpha']; unfold hd,tl; unfold hd,tl in H_nonzero; qnat_one; qnat_S k; set (l':=lb alpha' k).
   (* L *)
   fold l' in H_nonzero.
   case (Q_eq_dec l' (Qopp 1)); intro H_l'.
    (* l' = -1 *)
    apply False_ind; apply H_nonzero; rewrite H_l'; rewrite as_Moebius_Q_L; qZ_numerals; auto.
    (* l' <> -1 *)
    generalize (IHk alpha' H_l'); fold l'; clear IHk; intro IHk.
    (* TP: Zero <= l'+ 1 *)
    assert (H_l'_one_nonneg: Zero <= l'+1).
    stepr (l'-(Qopp 1)); try ring; apply Qle_Qminus_Zero;  unfold l'; apply lb_is_in_base_interval_low.
    (* TP: Zero < l'+3 *)
    assert (H_l'_three_pos: Zero < l'+3).
    apply Qle_lt_trans with (l'+1); auto;
    apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring.

    generalize H_nonzero; clear H_nonzero; rewrite as_Moebius_Q_L; trivial; natZ_numerals; intros H_nonzero.

    apply Qmult_Qdiv_pos_Qle; auto;
    apply Qle_Zero_Qminus;
    stepr (2*(l'*(k+2)-(-k))).
     apply Qle_mult_nonneg_nonneg; auto;
     apply Qle_Qminus_Zero;
     apply Qmult_resp_Qle_pos_r with (Qinv (k+2)).
      apply Qinv_pos; auto.
      rewrite <- Qmult_assoc; rewrite Qmult_Qinv_r; auto.
      stepr l'; trivial; try ring.

     qnat_S 2; qnat_S 1; qnat_one; ring.

   (* R *)
    (* TP: Zero <= -l'+ 1 *)
    assert (H_min_l'_one_nonneg: Zero <= -l'+1).
    stepr (1-l'); try ring; apply Qle_Qminus_Zero; subst l'; apply lb_is_in_base_interval_up.
    (* TP: Zero < -l'+3 *)
    assert (H_min_l'_three_pos: Zero < -l'+3).
    apply Qle_lt_trans with ((-l')+1); auto;
    apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring.
    (* TP: Zero <= l'+ 1 *)
    assert (H_l'_one_nonneg: Zero <= l'+1).
    stepr (l'-(Qopp 1)); try ring; apply Qle_Qminus_Zero; subst l'; apply lb_is_in_base_interval_low.
    (* TP: Zero <= l'+3 *)
    assert (H_l'_three_pos: Zero <= l'+3).
    apply Qlt_le_weak; apply Qle_lt_trans with (l'+1); auto;
    apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring.

    rewrite as_Moebius_Q_R; trivial; natZ_numerals.

    apply Qmult_Qdiv_pos_Qle; auto;
    apply Qle_Zero_Qminus;
    stepr (2*((l'+3)+2*k)).
     apply Qle_mult_nonneg_nonneg; auto.

     qnat_S 2; qnat_S 1; qnat_one; ring.

   (* M *)
   rewrite as_Moebius_Q_M; natZ_numerals;
    (* TP: Zero <= l'+ 1 *)
    assert (H_l'_one_nonneg: Zero <= l'+1).
    stepr (l'-(Qopp 1)); try ring; apply Qle_Qminus_Zero; subst l'; apply lb_is_in_base_interval_low.

   apply Qle_trans with ((-Qone)/3).
    apply Qmult_Qdiv_pos_Qle; auto;
    apply Qle_Zero_Qminus;
    stepr (2*k); auto; qnat_S 2; qnat_S 1; qnat_one; ring.

    apply Qmult_Qdiv_pos_Qle; auto;
    apply Qle_Zero_Qminus;
    stepr (3*(l'+1)).
     apply Qle_mult_nonneg_nonneg; auto.
     qnat_S 2; qnat_S 1; qnat_one; ring.
Defined.

Lemma thesis_5_7_2ii_l:forall (k:nat) alpha, lb alpha k <= (k-1)/(k+1).
Proof.
 intro k; induction k; intros alpha.
  (* 0 *)
  simpl; apply Qle_reflexive.
  (* S k *)
  (* TP: O <= k  *)
  assert (H_k_nonneg:  0 <= k).
  apply Z_to_Qle; apply inj_le; auto with arith.
  (* TP: Zero < 1 + k *)
  assert (H_k_one_pos: Zero < 1 + k ).
  rewrite Qplus_sym; natq_zero; qnat_one; natq_S k; natq_S (S k); auto.
  (* TP: Zero < k + 2 *)
  assert (H_k_two_pos: Zero < k + 2 ).
  natq_zero; qnat_S 1; qnat_one; rewrite Qplus_assoc; natq_S k; natq_S (S k); auto.

  rewrite lb_S_n;
  destruct alpha as [d alpha'];
  destruct d; unfold hd,tl;
  generalize (IHk alpha'); clear IHk; intros IHk;
  qnat_one; qnat_S k; set (l':=lb alpha' k);
  fold l' in IHk.
   (* L *)
   (* TP: Zero <= -l'+ 1 *)
   assert (H_min_l'_one_nonneg: Zero <= -l'+1).
   stepr (1-l'); try ring; apply Qle_Qminus_Zero; unfold l'; apply lb_is_in_base_interval_up.
   (* TP: Zero <= l'+ 1 *)
   assert (H_l'_one_nonneg: Zero <= l'+1).
   stepr (l'-(Qopp 1)); try ring; apply Qle_Qminus_Zero; unfold l'; apply lb_is_in_base_interval_low.
   (* TP: Zero < l'+3 *)
   assert (H_l'_three_pos: Zero < l'+3).
   apply Qle_lt_trans with (l'+1); auto;
   apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring.

   rewrite as_Moebius_Q_L; trivial; natZ_numerals.

   apply Qmult_Qdiv_pos_Qle; auto;
   apply Qle_Zero_Qminus;
   stepr (2*((-l'+1)+2*k)).
    apply Qle_mult_nonneg_nonneg; auto;
    apply Qle_plus_pos_pos; auto.

    qnat_S 2; qnat_S 1; qnat_one; ring.

   (* R *)
   (* TP: Zero <= -l'+ 1 *)
   assert (H_min_l'_one_nonneg: Zero <= -l'+1).
   stepr (1-l'); try ring; apply Qle_Qminus_Zero; unfold l'; apply lb_is_in_base_interval_up.
   (* TP: Zero < -l'+3 *)
   assert (H_min_l'_three_pos: Zero < -l'+3).
   apply Qle_lt_trans with ((-l')+1); auto;
   apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring.
   (* TP: Zero <= l'+ 1 *)
   assert (H_l'_one_nonneg: Zero <= l'+1).
   stepr (l'-(Qopp 1)); try ring; apply Qle_Qminus_Zero; unfold l'; apply lb_is_in_base_interval_low.

   rewrite as_Moebius_Q_R; trivial; natZ_numerals.

   apply Qmult_Qdiv_pos_Qle; auto;
   apply Qle_Zero_Qminus;
   stepr (2*((k-1)-l'*(k+1))).
    apply Qle_mult_nonneg_nonneg; auto;
    apply Qle_Qminus_Zero;
    apply Qmult_resp_Qle_pos_r with (Qinv (k+1)).
      apply Qinv_pos; auto.
      rewrite <- Qmult_assoc; rewrite Qmult_Qinv_r; auto;
      stepl l'; trivial; try ring.

    qnat_S k; qnat_S 2; qnat_S 1; qnat_one; ring.

   (* M *)
   generalize IHk; clear IHk; subst l'.
      destruct k; rewrite as_Moebius_Q_M; natZ_numerals; intro IHk.
   (* k := 0 *)
   unfold lb; stepr Zero; auto.
   (* k := S k *)
   set (l':=lb alpha' (S k));
   fold l' in IHk.
   (* TP: O <= k  *)
   assert (H_pk_nonneg:  0 <= k).
   apply Z_to_Qle; apply inj_le; auto with arith.
   (* TP: Zero <= -l'+ 1 *)
   assert (H_min_l'_one_nonneg: Zero <= -l'+1).
   stepr (1-l'); try ring; apply Qle_Qminus_Zero; unfold l'; apply lb_is_in_base_interval_up.
   (* TP: Zero < -l'+3 *)
   assert (H_min_l'_three_pos: Zero <= -l'+3).
   apply Qle_trans with (-l'+1); auto;
   apply Qle_plus_plus; try apply Qle_reflexive; apply Z_to_Qle; apply inj_le; auto.

   apply Qmult_Qdiv_pos_Qle; auto;
   apply Qle_Zero_Qminus.
   stepr (k*(-l'+3)+3*(-l'+1)).
    apply Qle_plus_pos_pos; apply Qle_mult_nonneg_nonneg; auto.

    qnat_S (S k); qnat_S k; qnat_S 2; qnat_S 1; qnat_one;
    [ ring | natq_S k; natq_S (S k); auto].
Defined.

Lemma lb_nondecreasing_step:forall k alpha, lb alpha k <= lb alpha (S k).
Proof.
 intro k; induction k.
 (* 0 *)
 intro alpha; stepl (Qopp 1); trivial; apply lb_is_in_base_interval_low.
 (* S n *)
 intros [d alpha'];
 rewrite lb_S_n;
 rewrite (lb_S_n (S k) (Cons d alpha')); unfold hd, tl.
 destruct d as [ | | ]; set (l':=lb alpha' (S k)); set (l'':=lb alpha' k);
 generalize (IHk alpha'); clear IHk; intros IHk; fold l' l'' in IHk.

  (* L *)
  (* TP: Zero <= l'+ 1 *)
  assert (H_l'_one_nonneg: Zero <= l'+1).
  stepr (l'-(Qopp 1)); try ring; apply Qle_Qminus_Zero; subst l'; apply lb_is_in_base_interval_low.
  (* TP: Zero < l'+3 *)
  assert (H_l'_three_pos: Zero < l'+3).
  apply Qle_lt_trans with (l'+1); auto;
  apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring.
  (* TP: Zero <= l''+ 1 *)
  assert (H_l''_one_nonneg: Zero <= l''+1).
  stepr (l''-(Qopp 1)); try ring; apply Qle_Qminus_Zero; subst l''; apply lb_is_in_base_interval_low.
  (* TP: Zero < l''+3 *)
  assert (H_l''_three_pos: Zero < l''+3).
  apply Qle_lt_trans with (l''+1); auto;
  apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring.

  repeat rewrite as_Moebius_Q_L; trivial; natZ_numerals.
  (* NB: conjug_Q_L is nondecreasing for -3<= x*)
  apply Qmult_Qdiv_pos_Qle; auto.
  apply Qle_Zero_Qminus.
  stepr (4*(l'-l'')).
   apply Qle_mult_nonneg_nonneg; auto.
   apply Qle_Qminus_Zero; assumption.
   qnat_S 3; qnat_S 2; qnat_S 1; qnat_one; ring.

  (* R *)
  (* TP: Zero <= -l'+ 1 *)
  assert (H_min_l'_one_nonneg: Zero <= -l'+1).
  stepr (1-l'); try ring; apply Qle_Qminus_Zero; subst l'; apply lb_is_in_base_interval_up.
  (* TP: Zero < -l'+3 *)
  assert (H_min_l'_three_pos: Zero < -l'+3).
  apply Qle_lt_trans with ((-l')+1); auto;
  apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring.
  (* TP: Zero <= -l'''+ 1 *)
  assert (H_min_l''_one_nonneg: Zero <= -l''+1).
  stepr (1-l''); try ring; apply Qle_Qminus_Zero; subst l''; apply lb_is_in_base_interval_up.
  (* TP: Zero < -l''+3 *)
  assert (H_min_l''_three_pos: Zero < -l''+3).
  apply Qle_lt_trans with ((-l'')+1); auto;
  apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring.

  repeat rewrite as_Moebius_Q_R; trivial; natZ_numerals.
  (* NB: conjug_Q_R is nondecreasing for x<=3*)
  apply Qmult_Qdiv_pos_Qle; auto.
  apply Qle_Zero_Qminus.
  stepr (4*(l'-l'')).
   apply Qle_mult_nonneg_nonneg; auto.
   apply Qle_Qminus_Zero; assumption.
   qnat_S 3; qnat_S 2; qnat_S 1; qnat_one; ring.

  (* M *)
  do 2 rewrite as_Moebius_Q_M; natZ_numerals.
  (* NB: conjug_Q_M is nondecreasing*)
  apply Qmult_Qdiv_pos_Qle; auto.
  apply Qle_Zero_Qminus.
  stepr (3*(l'-l'')).
   apply Qle_mult_nonneg_nonneg; auto.
   apply Qle_Qminus_Zero; assumption.
   qnat_S 2; qnat_S 1; qnat_one; ring.
Defined.

Lemma lb_nondecreasing_steps:forall n k alpha, lb alpha n <= lb alpha (k+n).
Proof.
 intros [|n] k.
  (* n:=0 *)
  intros; replace (k+0)%nat with k; trivial; apply lb_is_in_base_interval_low.
  (* n:=S n*)
  induction k.
   (* k:=0 *)
   intro alpha; apply Qle_reflexive.
   (* k:=S k *)
   replace (S k +S n)%nat with (S (k+S n))%nat; trivial;
   intros [d alpha'];
   rewrite (lb_S_n n (Cons d alpha')); rewrite lb_S_n;  unfold hd, tl.
   destruct d.
    apply as_Moebius_Q_L_nondecreasing;
    [ apply lb_is_in_base_interval_low
    | apply lb_is_in_base_interval_up
    | apply Qle_trans with (lb alpha' (S n)); trivial; apply lb_nondecreasing_step].
    apply as_Moebius_Q_R_nondecreasing;
    [ apply lb_is_in_base_interval_low
    | apply lb_is_in_base_interval_up
    | apply Qle_trans with (lb alpha' (S n)); trivial; apply lb_nondecreasing_step].
    apply as_Moebius_Q_M_nondecreasing;
    [ apply lb_is_in_base_interval_low
    | apply lb_is_in_base_interval_up
    | apply Qle_trans with (lb alpha' (S n)); trivial; apply lb_nondecreasing_step].
Defined.

Lemma lb_nondecreasing:forall m n alpha, (m<=n)%nat -> lb alpha m <= lb alpha n.
Proof.
 intros m n alpha Hmn.
 replace n with ((n-m)+m)%nat; try omega; apply lb_nondecreasing_steps.
Defined.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

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

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf3 : natural) (z : natural) : natural :=
  plus Zero (plus lf3 z).


Require Import Peano_dec.

Require Import Logic.Class.Eq.

Lemma not_eq_s_n : forall (n:nat), ~ S n = n.
Proof.
    induction n as [|n IH]; intros H.
    - inversion H.
    - injection H. intros H'. apply IH. assumption.
Defined.

(* TODO: issue already has an Eq instance from Ord                              *)
Instance EqNat : Eq nat := { eqDec := eq_nat_dec }.


Require Import ssreflect ssrbool ssrfun ssrnat eqtype seq fintype finfun fingraph  finset.
Require Import automata regexp misc.

Set Implicit Arguments.

Section RE_FA.
  Variable char: finType.
  Definition word:= misc.word char.

  Fixpoint re_to_dfa (r: regular_expression char): dfa char :=
    match r with
    | Void => dfa_void char
    | Eps => dfa_eps char
    | Dot => dfa_dot char
    | Atom a => dfa_char char a
    | Star s => nfa_star (dfa_to_nfa (re_to_dfa s))
    | Plus s t => dfa_disj (re_to_dfa s) (re_to_dfa t)
    | And s t => dfa_conj (re_to_dfa s) (re_to_dfa t)
    | Conc s t => nfa_to_dfa (nfa_conc (dfa_to_nfa (re_to_dfa s)) (dfa_to_nfa (re_to_dfa t)))
    | Not s => dfa_compl (re_to_dfa s)
    end.

  Lemma re_to_dfa_correct r: dfa_lang (re_to_dfa r) =i r.
  Proof.
    elim: r => [].

    move => w. apply/idP/idP. exact: dfa_void_correct.

    exact: dfa_eps_correct.

    move => w.
    rewrite -topredE /= /dot.
    exact: dfa_dot_correct.

    move => a.
    move => w. exact: dfa_char_correct.

    (* Star *)
    move => s IHs.
    move => w.
    rewrite nfa_star_correct.
    apply/starP/starP.
      move => [] vv.
      move => H0 H1.
      exists vv.
      erewrite (eq_all).
          eexact H0.
        move => x /=.
        apply/andP/andP; move => [] H2 H3; split => //.
          rewrite -dfa_to_nfa_correct.
          move: H3. by rewrite -IHs.
        move: H3.
        rewrite -dfa_to_nfa_correct.
        by rewrite -IHs.
      exact H1.
    move => [] vv H1 H2. exists vv => //.
    erewrite eq_all. eexact H1.
    move => x /=.
    apply/andb_id2l => H3.
    by rewrite -IHs -dfa_to_nfa_correct.

    move => s Hs t Ht.
    move => w. rewrite -dfa_disj_correct in_simpl /=.
    by rewrite Ht Hs /=.

    move => s Hs t Ht.
    move => w. rewrite -dfa_conj_correct in_simpl /=.
    by rewrite Hs Ht /=.

    move => s Hs t Ht.
    move => w. rewrite -nfa_to_dfa_correct.
    apply/idP/idP.
    move/nfa_conc_aux1 => [] w1 [] w2 /andP [] /andP [] /eqP H0 H1 H2.
    rewrite -topredE /=.
    apply/concP.
    exists w1. by rewrite -Hs -topredE /= dfa_to_nfa_correct' /nfa_lang /= H1.
    exists w2. rewrite /= in H2. by rewrite -Ht dfa_to_nfa_correct in_simpl H2.
    exact H0.
    move/concP => [] w1. rewrite -Hs => H1 [] w2. rewrite -Ht => H2 ->.
    apply/nfa_conc_aux2.
      move: H1. by rewrite  dfa_to_nfa_correct /nfa_lang /=.
    move: H2. by rewrite dfa_to_nfa_correct /nfa_lang /=.

    move => s H.
    move => w. by rewrite -dfa_compl_correct -topredE /= H.
  Qed.

  Definition re_equiv r s := dfa_equiv (re_to_dfa r) (re_to_dfa s).

  Lemma re_equiv_correct r s: re_equiv r s <-> r =i s.
  Proof.
    rewrite dfa_equiv_correct.
    split => H w.
      move/H: (w). by rewrite !re_to_dfa_correct.
    by rewrite !re_to_dfa_correct.
  Qed.

End RE_FA.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

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

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (lf1 : natural) : natural := mult lf2 lf1.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

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

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (y : natural) (x : natural) : natural :=
  mult y x.


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 half (half_arg0 : Nat) : Nat
           := match half_arg0 with
              | zero => zero
              | succ zero => zero
              | succ (succ n) => succ (half n)
              end.

Fixpoint append (append_arg0 : Lst) (append_arg1 : Lst) : Lst
           := match append_arg0, append_arg1 with
              | nil, x => x
              | cons x y, z => cons x (append y z)
              end.

Fixpoint len (len_arg0 : Lst) : Nat
           := match len_arg0 with
              | nil => zero
              | cons x y => succ (len y)
              end.

Lemma lem3: forall l, append l nil = l.
Proof.
induction l.
  - simpl. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem2: forall l1 l2 n, succ (len (append l1 l2)) = len (append l1 (cons n l2)).
Proof.
induction l1.
- intros. simpl. rewrite <- IHl1. reflexivity.
- intros. reflexivity.
Qed.

Lemma lem: forall l1 l2, len (append l1 l2) = len (append l2 l1).
induction l1.
  - intros. simpl. rewrite IHl1. rewrite <- lem2. reflexivity.
  - intros. simpl. rewrite lem3. reflexivity.
Qed.

Theorem theorem0 : forall (x : Lst) (y : Lst), eq (half (len (append x y))) (half (len (append y x))).
Proof.
intros. f_equal. apply lem.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

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

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (z : natural) (y : natural) : natural := plus z (mult y z).


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

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

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (lf1 : natural) : natural := plus lf1 (Succ y).


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

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

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (x : natural) (y : natural) (lf1 : natural) : natural :=
  plus y (Succ (plus lf1 x)).


(* Exercise 3.2: Using the basic tactics 'assumption', 'intros', and 'apply',
 * prove the following lemmas:
 *)

Variables P Q R T : Prop.

Lemma id_P : P -> P.
Proof.
  intros p.
  assumption.
Qed.

Lemma id_PP : (P -> P) -> (P -> P).
Proof.
  intros H p.
  apply H.
  assumption.
Qed.

Lemma imp_trans : (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros H H' p.
  apply H'.
  apply H.
  assumption.
Qed.

Lemma imp_perm : (P -> Q -> R) -> (Q -> P -> R).
Proof.
  intros H q p.
  apply H.
  apply p.
  apply q.
Qed.

Lemma ignore_Q : (P -> R) -> P -> Q -> R.
Proof.
  intros H p q.
  apply H.
  apply p.
Qed.

Lemma delta_imp : (P -> P -> Q) -> P -> Q.
Proof.
  intros H p.
  apply H.
  apply p.
  apply p.
Qed.

Lemma delta_impR : (P -> Q) -> (P -> P -> Q).
Proof.
  intros H p.
  apply H.
Qed.

Lemma diamond : (P -> Q) -> (P -> R) -> (Q -> R -> T) -> P -> T.
Proof.
  intros H H' H'' p.
  apply H''.
  apply H.
  apply p.
  apply H'.
  apply p.
Qed.

Lemma weak_peirce : ((((P -> Q) -> P) -> P) -> Q) -> Q.
Proof.
  intros H.
  apply H.
  intros H'.
  apply H'.
  intros H''.
  apply H.
  intros H'''.
  apply H''.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: Znumtheory.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import ZArith_base.
Require Import ZArithRing.
Require Import Zcomplements.
Require Import Zdiv.
Require Import Wf_nat.
Open Local Scope Z_scope.

(** This file contains some notions of number theory upon Z numbers:
     - a divisibility predicate [Zdivide]
     - a gcd predicate [gcd]
     - Euclid algorithm [euclid]
     - a relatively prime predicate [rel_prime]
     - a prime predicate [prime]
     - an efficient [Zgcd] function
*)

(** * Divisibility *)

Inductive Zdivide (a b:Z) : Prop :=
    Zdivide_intro : forall q:Z, b = q * a -> Zdivide a b.

(** Syntax for divisibility *)

Notation "( a | b )" := (Zdivide a b) (at level 0) : Z_scope.

(** Results concerning divisibility*)

Lemma Zdivide_refl : forall a:Z, (a | a).
Proof.
  intros; apply Zdivide_intro with 1; ring.
Qed.

Lemma Zone_divide : forall a:Z, (1 | a).
Proof.
  intros; apply Zdivide_intro with a; ring.
Qed.

Lemma Zdivide_0 : forall a:Z, (a | 0).
Proof.
  intros; apply Zdivide_intro with 0; ring.
Qed.

Hint Resolve Zdivide_refl Zone_divide Zdivide_0: zarith.

Lemma Zmult_divide_compat_l : forall a b c:Z, (a | b) -> (c * a | c * b).
Proof.
  simple induction 1; intros; apply Zdivide_intro with q.
  rewrite H0; ring.
Qed.

Lemma Zmult_divide_compat_r : forall a b c:Z, (a | b) -> (a * c | b * c).
Proof.
  intros a b c; rewrite (Zmult_comm a c); rewrite (Zmult_comm b c).
  apply Zmult_divide_compat_l; trivial.
Qed.

Hint Resolve Zmult_divide_compat_l Zmult_divide_compat_r: zarith.

Lemma Zdivide_plus_r : forall a b c:Z, (a | b) -> (a | c) -> (a | b + c).
Proof.
  simple induction 1; intros q Hq; simple induction 1; intros q' Hq'.
  apply Zdivide_intro with (q + q').
  rewrite Hq; rewrite Hq'; ring.
Qed.

Lemma Zdivide_opp_r : forall a b:Z, (a | b) -> (a | - b).
Proof.
  simple induction 1; intros; apply Zdivide_intro with (- q).
  rewrite H0; ring.
Qed.

Lemma Zdivide_opp_r_rev : forall a b:Z, (a | - b) -> (a | b).
Proof.
  intros; replace b with (- - b). apply Zdivide_opp_r; trivial. ring.
Qed.

Lemma Zdivide_opp_l : forall a b:Z, (a | b) -> (- a | b).
Proof.
  simple induction 1; intros; apply Zdivide_intro with (- q).
  rewrite H0; ring.
Qed.

Lemma Zdivide_opp_l_rev : forall a b:Z, (- a | b) -> (a | b).
Proof.
  intros; replace a with (- - a). apply Zdivide_opp_l; trivial. ring.
Qed.

Lemma Zdivide_minus_l : forall a b c:Z, (a | b) -> (a | c) -> (a | b - c).
Proof.
  simple induction 1; intros q Hq; simple induction 1; intros q' Hq'.
  apply Zdivide_intro with (q - q').
  rewrite Hq; rewrite Hq'; ring.
Qed.

Lemma Zdivide_mult_l : forall a b c:Z, (a | b) -> (a | b * c).
Proof.
  simple induction 1; intros q Hq; apply Zdivide_intro with (q * c).
  rewrite Hq; ring.
Qed.

Lemma Zdivide_mult_r : forall a b c:Z, (a | c) -> (a | b * c).
Proof.
  simple induction 1; intros q Hq; apply Zdivide_intro with (q * b).
  rewrite Hq; ring.
Qed.

Lemma Zdivide_factor_r : forall a b:Z, (a | a * b).
Proof.
  intros; apply Zdivide_intro with b; ring.
Qed.

Lemma Zdivide_factor_l : forall a b:Z, (a | b * a).
Proof.
  intros; apply Zdivide_intro with b; ring.
Qed.

Hint Resolve Zdivide_plus_r Zdivide_opp_r Zdivide_opp_r_rev Zdivide_opp_l
  Zdivide_opp_l_rev Zdivide_minus_l Zdivide_mult_l Zdivide_mult_r
  Zdivide_factor_r Zdivide_factor_l: zarith.

(** Auxiliary result. *)

Lemma Zmult_one : forall x y:Z, x >= 0 -> x * y = 1 -> x = 1.
Proof.
  intros x y H H0; destruct (Zmult_1_inversion_l _ _ H0) as [Hpos| Hneg].
  assumption.
  rewrite Hneg in H; simpl in H.
  contradiction (Zle_not_lt 0 (-1)).
    apply Zge_le; assumption.
    apply Zorder.Zlt_neg_0.
Qed.

(** Only [1] and [-1] divide [1]. *)

Lemma Zdivide_1 : forall x:Z, (x | 1) -> x = 1 \/ x = -1.
Proof.
  simple induction 1; intros.
  elim (Z_lt_ge_dec 0 x); [ left | right ].
  apply Zmult_one with q; auto with zarith; rewrite H0; ring.
  assert (- x = 1); auto with zarith.
  apply Zmult_one with (- q); auto with zarith; rewrite H0; ring.
Qed.

(** If [a] divides [b] and [b] divides [a] then [a] is [b] or [-b]. *)

Lemma Zdivide_antisym : forall a b:Z, (a | b) -> (b | a) -> a = b \/ a = - b.
Proof.
  simple induction 1; intros.
  inversion H1.
  rewrite H0 in H2; clear H H1.
  case (Z_zerop a); intro.
  left; rewrite H0; rewrite e; ring.
  assert (Hqq0 : q0 * q = 1).
  apply Zmult_reg_l with a.
  assumption.
  ring_simplify.
  pattern a at 2 in |- *; rewrite H2; ring.
  assert (q | 1).
  rewrite <- Hqq0; auto with zarith.
  elim (Zdivide_1 q H); intros.
  rewrite H1 in H0; left; omega.
  rewrite H1 in H0; right; omega.
Qed.

Theorem Zdivide_trans: forall a b c, (a | b) -> (b | c) ->  (a | c).
Proof.
  intros a b c [d H1] [e H2]; exists (d * e); auto with zarith.
  rewrite H2; rewrite H1; ring.
Qed.

(** If [a] divides [b] and [b<>0] then [|a| <= |b|]. *)

Lemma Zdivide_bounds : forall a b:Z, (a | b) -> b <> 0 -> Zabs a <= Zabs b.
Proof.
  simple induction 1; intros.
  assert (Zabs b = Zabs q * Zabs a).
  subst; apply Zabs_Zmult.
  rewrite H2.
  assert (H3 := Zabs_pos q).
  assert (H4 := Zabs_pos a).
  assert (Zabs q * Zabs a >= 1 * Zabs a); auto with zarith.
  apply Zmult_ge_compat; auto with zarith.
  elim (Z_lt_ge_dec (Zabs q) 1); [ intros | auto with zarith ].
  assert (Zabs q = 0).
  omega.
  assert (q = 0).
  rewrite <- (Zabs_Zsgn q).
  rewrite H5; auto with zarith.
  subst q; omega.
Qed.

(** [Zdivide] can be expressed using [Zmod]. *)

Lemma Zmod_divide : forall a b, b<>0 -> a mod b = 0 -> (b | a).
Proof.
 intros a b NZ EQ.
 apply Zdivide_intro with (a/b).
 rewrite (Z_div_mod_eq_full a b NZ) at 1.
 rewrite EQ; ring.
Qed.

Lemma Zdivide_mod : forall a b, (b | a) -> a mod b = 0.
Proof.
  intros a b (c,->); apply Z_mod_mult.
Qed.

(** [Zdivide] is hence decidable *)

Lemma Zdivide_dec : forall a b:Z, {(a | b)} + {~ (a | b)}.
Proof.
  intros a b; elim (Ztrichotomy_inf a 0).
  (* a<0 *)
  intros H; elim H; intros.
  case (Z_eq_dec (b mod - a) 0).
  left; apply Zdivide_opp_l_rev; apply Zmod_divide; auto with zarith.
  intro H1; right; intro; elim H1; apply Zdivide_mod; auto with zarith.
  (* a=0 *)
  case (Z_eq_dec b 0); intro.
  left; subst; auto with zarith.
  right; subst; intro H0; inversion H0; omega.
  (* a>0 *)
  intro H; case (Z_eq_dec (b mod a) 0).
  left; apply Zmod_divide; auto with zarith.
  intro H1; right; intro; elim H1; apply Zdivide_mod; auto with zarith.
Qed.

Theorem Zdivide_Zdiv_eq: forall a b : Z,
 0 < a -> (a | b) ->  b = a * (b / a).
Proof.
  intros a b Hb Hc.
  pattern b at 1; rewrite (Z_div_mod_eq b a); auto with zarith.
  rewrite (Zdivide_mod b a); auto with zarith.
Qed.

Theorem Zdivide_Zdiv_eq_2: forall a b c : Z,
 0 < a -> (a | b) -> (c * b)/a = c * (b / a).
Proof.
  intros a b c H1 H2.
  inversion H2 as [z Hz].
  rewrite Hz; rewrite Zmult_assoc.
  repeat rewrite Z_div_mult; auto with zarith.
Qed.

Theorem Zdivide_Zabs_l: forall a b, (Zabs a | b) ->  (a | b).
Proof.
  intros a b [x H]; subst b.
  pattern (Zabs a); apply Zabs_intro.
  exists (- x); ring.
  exists x; ring.
Qed.

Theorem Zdivide_Zabs_inv_l: forall a b, (a | b) ->  (Zabs a | b).
Proof.
  intros a b [x H]; subst b.
  pattern (Zabs a); apply Zabs_intro.
  exists (- x);  ring.
  exists x; ring.
Qed.

Theorem Zdivide_le: forall a b : Z,
 0 <= a -> 0 < b -> (a | b) ->  a <= b.
Proof.
  intros a b H1 H2 [q H3]; subst b.
  case (Zle_lt_or_eq 0 a); auto with zarith; intros H3.
  case (Zle_lt_or_eq 0 q); auto with zarith.
  apply (Zmult_le_0_reg_r a); auto with zarith.
  intros H4; apply Zle_trans with (1 * a); auto with zarith.
  intros H4; subst q; omega.
Qed.

Theorem Zdivide_Zdiv_lt_pos: forall a b : Z,
 1 < a -> 0 < b -> (a | b) ->  0 < b / a < b .
Proof.
  intros a b H1 H2 H3; split.
  apply Zmult_lt_reg_r with a; auto with zarith.
  rewrite (Zmult_comm (Zdiv b a)); rewrite <- Zdivide_Zdiv_eq; auto with zarith.
  apply Zmult_lt_reg_r with a; auto with zarith.
  repeat rewrite (fun x => Zmult_comm x a); auto with zarith.
  rewrite <- Zdivide_Zdiv_eq; auto with zarith.
  pattern b at 1; replace b with (1 * b); auto with zarith.
  apply Zmult_lt_compat_r; auto with zarith.
Qed.

Lemma Zmod_div_mod: forall n m a, 0 < n -> 0 < m ->
 (n | m) -> a mod n = (a mod m) mod n.
Proof.
  intros n m a H1 H2 H3.
  pattern a at 1; rewrite (Z_div_mod_eq a m); auto with zarith.
  case H3; intros q Hq; pattern m at 1; rewrite Hq.
  rewrite (Zmult_comm q).
  rewrite Zplus_mod; auto with zarith.
  rewrite <- Zmult_assoc; rewrite Zmult_mod; auto with zarith.
  rewrite Z_mod_same; try rewrite Zmult_0_l; auto with zarith.
  rewrite (Zmod_small 0); auto with zarith.
  rewrite Zplus_0_l; rewrite Zmod_mod; auto with zarith.
Qed.

Lemma Zmod_divide_minus: forall a b c : Z, 0 < b ->
 a mod b = c -> (b | a - c).
Proof.
  intros a b c H H1; apply Zmod_divide; auto with zarith.
  rewrite Zminus_mod; auto with zarith.
  rewrite H1; pattern c at 1; rewrite <- (Zmod_small c b); auto with zarith.
  rewrite Zminus_diag; apply Zmod_small; auto with zarith.
  subst; apply Z_mod_lt; auto with zarith.
Qed.

Lemma Zdivide_mod_minus: forall a b c : Z, 0 <= c < b ->
 (b | a - c) -> a mod b = c.
Proof.
  intros a b c (H1, H2) H3; assert (0 < b); try apply Zle_lt_trans with c; auto.
  replace a with ((a - c) + c); auto with zarith.
  rewrite Zplus_mod; auto with zarith.
  rewrite (Zdivide_mod (a -c) b); try rewrite Zplus_0_l; auto with zarith.
  rewrite Zmod_mod; try apply Zmod_small; auto with zarith.
Qed.

(** * Greatest common divisor (gcd). *)

(** There is no unicity of the gcd; hence we define the predicate [gcd a b d]
     expressing that [d] is a gcd of [a] and [b].
     (We show later that the [gcd] is actually unique if we discard its sign.) *)

Inductive Zis_gcd (a b d:Z) : Prop :=
  Zis_gcd_intro :
  (d | a) ->
  (d | b) -> (forall x:Z, (x | a) -> (x | b) -> (x | d)) -> Zis_gcd a b d.

(** Trivial properties of [gcd] *)

Lemma Zis_gcd_sym : forall a b d:Z, Zis_gcd a b d -> Zis_gcd b a d.
Proof.
  simple induction 1; constructor; intuition.
Qed.

Lemma Zis_gcd_0 : forall a:Z, Zis_gcd a 0 a.
Proof.
  constructor; auto with zarith.
Qed.

Lemma Zis_gcd_1 : forall a, Zis_gcd a 1 1.
Proof.
  constructor; auto with zarith.
Qed.

Lemma Zis_gcd_refl : forall a, Zis_gcd a a a.
Proof.
  constructor; auto with zarith.
Qed.

Lemma Zis_gcd_minus : forall a b d:Z, Zis_gcd a (- b) d -> Zis_gcd b a d.
Proof.
  simple induction 1; constructor; intuition.
Qed.

Lemma Zis_gcd_opp : forall a b d:Z, Zis_gcd a b d -> Zis_gcd b a (- d).
Proof.
  simple induction 1; constructor; intuition.
Qed.

Lemma Zis_gcd_0_abs : forall a:Z, Zis_gcd 0 a (Zabs a).
Proof.
  intros a.
  apply Zabs_ind.
  intros; apply Zis_gcd_sym; apply Zis_gcd_0; auto.
  intros; apply Zis_gcd_opp; apply Zis_gcd_0; auto.
Qed.

Hint Resolve Zis_gcd_sym Zis_gcd_0 Zis_gcd_minus Zis_gcd_opp: zarith.

Theorem Zis_gcd_unique: forall a b c d : Z,
 Zis_gcd a b c -> Zis_gcd a b d ->  c = d \/ c = (- d).
Proof.
intros a b c d H1 H2.
inversion_clear H1 as [Hc1 Hc2 Hc3].
inversion_clear H2 as [Hd1 Hd2 Hd3].
assert (H3: Zdivide c d); auto.
assert (H4: Zdivide d c); auto.
apply Zdivide_antisym; auto.
Qed.

(** * Extended Euclid algorithm. *)

(** Euclid's algorithm to compute the [gcd] mainly relies on
    the following property. *)

Lemma Zis_gcd_for_euclid :
  forall a b d q:Z, Zis_gcd b (a - q * b) d -> Zis_gcd a b d.
Proof.
  simple induction 1; constructor; intuition.
  replace a with (a - q * b + q * b). auto with zarith. ring.
Qed.

Lemma Zis_gcd_for_euclid2 :
  forall b d q r:Z, Zis_gcd r b d -> Zis_gcd b (b * q + r) d.
Proof.
  simple induction 1; constructor; intuition.
  apply H2; auto.
  replace r with (b * q + r - b * q). auto with zarith. ring.
Qed.

(** We implement the extended version of Euclid's algorithm,
    i.e. the one computing Bezout's coefficients as it computes
    the [gcd]. We follow the algorithm given in Knuth's
    "Art of Computer Programming", vol 2, page 325. *)

Section extended_euclid_algorithm.

  Variables a b : Z.

  (** The specification of Euclid's algorithm is the existence of
      [u], [v] and [d] such that [ua+vb=d] and [(gcd a b d)]. *)

  Inductive Euclid : Set :=
    Euclid_intro :
    forall u v d:Z, u * a + v * b = d -> Zis_gcd a b d -> Euclid.

  (** The recursive part of Euclid's algorithm uses well-founded
      recursion of non-negative integers. It maintains 6 integers
      [u1,u2,u3,v1,v2,v3] such that the following invariant holds:
      [u1*a+u2*b=u3] and [v1*a+v2*b=v3] and [gcd(u2,v3)=gcd(a,b)].
      *)

  Lemma euclid_rec :
    forall v3:Z,
      0 <= v3 ->
      forall u1 u2 u3 v1 v2:Z,
	u1 * a + u2 * b = u3 ->
	v1 * a + v2 * b = v3 ->
	(forall d:Z, Zis_gcd u3 v3 d -> Zis_gcd a b d) -> Euclid.
  Proof.
    intros v3 Hv3; generalize Hv3; pattern v3 in |- *.
    apply Zlt_0_rec.
    clear v3 Hv3; intros.
    elim (Z_zerop x); intro.
    apply Euclid_intro with (u := u1) (v := u2) (d := u3).
    assumption.
    apply H3.
    rewrite a0; auto with zarith.
    set (q := u3 / x) in *.
    assert (Hq : 0 <= u3 - q * x < x).
    replace (u3 - q * x) with (u3 mod x).
    apply Z_mod_lt; omega.
    assert (xpos : x > 0). omega.
    generalize (Z_div_mod_eq u3 x xpos).
    unfold q in |- *.
    intro eq; pattern u3 at 2 in |- *; rewrite eq; ring.
    apply (H (u3 - q * x) Hq (proj1 Hq) v1 v2 x (u1 - q * v1) (u2 - q * v2)).
    tauto.
    replace ((u1 - q * v1) * a + (u2 - q * v2) * b) with
      (u1 * a + u2 * b - q * (v1 * a + v2 * b)).
    rewrite H1; rewrite H2; trivial.
    ring.
    intros; apply H3.
    apply Zis_gcd_for_euclid with q; assumption.
    assumption.
  Qed.

  (** We get Euclid's algorithm by applying [euclid_rec] on
      [1,0,a,0,1,b] when [b>=0] and [1,0,a,0,-1,-b] when [b<0]. *)

  Lemma euclid : Euclid.
  Proof.
    case (Z_le_gt_dec 0 b); intro.
    intros;
      apply euclid_rec with
	(u1 := 1) (u2 := 0) (u3 := a) (v1 := 0) (v2 := 1) (v3 := b);
	auto with zarith; ring.
    intros;
      apply euclid_rec with
	(u1 := 1) (u2 := 0) (u3 := a) (v1 := 0) (v2 := -1) (v3 := - b);
	auto with zarith; try ring.
  Qed.

End extended_euclid_algorithm.

Theorem Zis_gcd_uniqueness_apart_sign :
  forall a b d d':Z, Zis_gcd a b d -> Zis_gcd a b d' -> d = d' \/ d = - d'.
Proof.
  simple induction 1.
  intros H1 H2 H3; simple induction 1; intros.
  generalize (H3 d' H4 H5); intro Hd'd.
  generalize (H6 d H1 H2); intro Hdd'.
  exact (Zdivide_antisym d d' Hdd' Hd'd).
Qed.

(** * Bezout's coefficients *)

Inductive Bezout (a b d:Z) : Prop :=
  Bezout_intro : forall u v:Z, u * a + v * b = d -> Bezout a b d.

(** Existence of Bezout's coefficients for the [gcd] of [a] and [b] *)

Lemma Zis_gcd_bezout : forall a b d:Z, Zis_gcd a b d -> Bezout a b d.
Proof.
  intros a b d Hgcd.
  elim (euclid a b); intros u v d0 e g.
  generalize (Zis_gcd_uniqueness_apart_sign a b d d0 Hgcd g).
  intro H; elim H; clear H; intros.
  apply Bezout_intro with u v.
  rewrite H; assumption.
  apply Bezout_intro with (- u) (- v).
  rewrite H; rewrite <- e; ring.
Qed.

(** gcd of [ca] and [cb] is [c gcd(a,b)]. *)

Lemma Zis_gcd_mult :
  forall a b c d:Z, Zis_gcd a b d -> Zis_gcd (c * a) (c * b) (c * d).
Proof.
  intros a b c d; simple induction 1; constructor; intuition.
  elim (Zis_gcd_bezout a b d H). intros.
  elim H3; intros.
  elim H4; intros.
  apply Zdivide_intro with (u * q + v * q0).
  rewrite <- H5.
  replace (c * (u * a + v * b)) with (u * (c * a) + v * (c * b)).
  rewrite H6; rewrite H7; ring.
  ring.
Qed.

(** * Relative primality *)

Definition rel_prime (a b:Z) : Prop := Zis_gcd a b 1.

(** Bezout's theorem: [a] and [b] are relatively prime if and
    only if there exist [u] and [v] such that [ua+vb = 1]. *)

Lemma rel_prime_bezout : forall a b:Z, rel_prime a b -> Bezout a b 1.
Proof.
  intros a b; exact (Zis_gcd_bezout a b 1).
Qed.

Lemma bezout_rel_prime : forall a b:Z, Bezout a b 1 -> rel_prime a b.
Proof.
  simple induction 1; constructor; auto with zarith.
  intros. rewrite <- H0; auto with zarith.
Qed.

(** Gauss's theorem: if [a] divides [bc] and if [a] and [b] are
    relatively prime, then [a] divides [c]. *)

Theorem Gauss : forall a b c:Z, (a | b * c) -> rel_prime a b -> (a | c).
Proof.
  intros. elim (rel_prime_bezout a b H0); intros.
  replace c with (c * 1); [ idtac | ring ].
  rewrite <- H1.
  replace (c * (u * a + v * b)) with (c * u * a + v * (b * c));
    [ eauto with zarith | ring ].
Qed.

(** If [a] is relatively prime to [b] and [c], then it is to [bc] *)

Lemma rel_prime_mult :
  forall a b c:Z, rel_prime a b -> rel_prime a c -> rel_prime a (b * c).
Proof.
  intros a b c Hb Hc.
  elim (rel_prime_bezout a b Hb); intros.
  elim (rel_prime_bezout a c Hc); intros.
  apply bezout_rel_prime.
  apply Bezout_intro with
    (u := u * u0 * a + v0 * c * u + u0 * v * b) (v := v * v0).
  rewrite <- H.
  replace (u * a + v * b) with ((u * a + v * b) * 1); [ idtac | ring ].
  rewrite <- H0.
  ring.
Qed.

Lemma rel_prime_cross_prod :
  forall a b c d:Z,
    rel_prime a b ->
    rel_prime c d -> b > 0 -> d > 0 -> a * d = b * c -> a = c /\ b = d.
Proof.
  intros a b c d; intros.
  elim (Zdivide_antisym b d).
  split; auto with zarith.
  rewrite H4 in H3.
  rewrite Zmult_comm in H3.
  apply Zmult_reg_l with d; auto with zarith.
  intros; omega.
  apply Gauss with a.
  rewrite H3.
  auto with zarith.
  red in |- *; auto with zarith.
  apply Gauss with c.
  rewrite Zmult_comm.
  rewrite <- H3.
  auto with zarith.
  red in |- *; auto with zarith.
Qed.

(** After factorization by a gcd, the original numbers are relatively prime. *)

Lemma Zis_gcd_rel_prime :
  forall a b g:Z,
    b > 0 -> g >= 0 -> Zis_gcd a b g -> rel_prime (a / g) (b / g).
Proof.
  intros a b g; intros.
  assert (g <> 0).
  intro.
  elim H1; intros.
  elim H4; intros.
  rewrite H2 in H6; subst b; omega.
  unfold rel_prime in |- *.
  destruct H1.
  destruct H1 as (a',H1).
  destruct H3 as (b',H3).
  replace (a/g) with a';
    [|rewrite H1; rewrite Z_div_mult; auto with zarith].
  replace (b/g) with b';
    [|rewrite H3; rewrite Z_div_mult; auto with zarith].
  constructor.
  exists a'; auto with zarith.
  exists b'; auto with zarith.
  intros x (xa,H5) (xb,H6).
  destruct (H4 (x*g)).
  exists xa; rewrite Zmult_assoc; rewrite <- H5; auto.
  exists xb; rewrite Zmult_assoc; rewrite <- H6; auto.
  replace g with (1*g) in H7; auto with zarith.
  do 2 rewrite Zmult_assoc in H7.
  generalize (Zmult_reg_r _ _ _ H2 H7); clear H7; intros.
  rewrite Zmult_1_r in H7.
  exists q; auto with zarith.
Qed.

Theorem rel_prime_sym: forall a b, rel_prime a b -> rel_prime b a.
Proof.
  intros a b H; auto with zarith.
  red; apply Zis_gcd_sym; auto with zarith.
Qed.

Theorem rel_prime_div: forall p q r,
 rel_prime p q -> (r | p) -> rel_prime r q.
Proof.
  intros p q r H (u, H1); subst.
  inversion_clear H as [H1 H2 H3].
  red; apply Zis_gcd_intro; try apply Zone_divide.
  intros x H4 H5; apply H3; auto.
  apply Zdivide_mult_r; auto.
Qed.

Theorem rel_prime_1: forall n, rel_prime 1 n.
Proof.
  intros n; red; apply Zis_gcd_intro; auto.
  exists 1; auto with zarith.
  exists n; auto with zarith.
Qed.

Theorem not_rel_prime_0: forall n, 1 < n -> ~ rel_prime 0 n.
Proof.
  intros n H H1; absurd (n = 1 \/ n = -1).
  intros [H2 | H2]; subst; contradict H; auto with zarith.
  case (Zis_gcd_unique  0 n n 1); auto.
  apply Zis_gcd_intro; auto.
  exists 0; auto with zarith.
  exists 1; auto with zarith.
Qed.

Theorem rel_prime_mod: forall p q, 0 < q ->
 rel_prime p q -> rel_prime (p mod q) q.
Proof.
  intros p q H H0.
  assert (H1: Bezout p q 1).
  apply rel_prime_bezout; auto.
  inversion_clear H1 as [q1 r1 H2].
  apply bezout_rel_prime.
  apply Bezout_intro with q1  (r1 + q1 * (p / q)).
  rewrite <- H2.
  pattern p at 3; rewrite (Z_div_mod_eq p q); try ring; auto with zarith.
Qed.

Theorem rel_prime_mod_rev: forall p q, 0 < q ->
 rel_prime (p mod q) q -> rel_prime p q.
Proof.
  intros p q H H0.
  rewrite (Z_div_mod_eq p q); auto with zarith; red.
  apply Zis_gcd_sym; apply Zis_gcd_for_euclid2; auto with zarith.
Qed.

Theorem Zrel_prime_neq_mod_0: forall a b, 1 < b -> rel_prime a b -> a mod b <> 0.
Proof.
  intros a b H H1 H2.
  case (not_rel_prime_0 _ H).
  rewrite <- H2.
  apply rel_prime_mod; auto with zarith.
Qed.

(** * Primality *)

Inductive prime (p:Z) : Prop :=
  prime_intro :
    1 < p -> (forall n:Z, 1 <= n < p -> rel_prime n p) -> prime p.

(** The sole divisors of a prime number [p] are [-1], [1], [p] and [-p]. *)

Lemma prime_divisors :
  forall p:Z,
    prime p -> forall a:Z, (a | p) -> a = -1 \/ a = 1 \/ a = p \/ a = - p.
Proof.
  simple induction 1; intros.
  assert
    (a = - p \/ - p < a < -1 \/ a = -1 \/ a = 0 \/ a = 1 \/ 1 < a < p \/ a = p).
  assert (Zabs a <= Zabs p). apply Zdivide_bounds; [ assumption | omega ].
  generalize H3.
  pattern (Zabs a) in |- *; apply Zabs_ind; pattern (Zabs p) in |- *;
    apply Zabs_ind; intros; omega.
  intuition idtac.
  (* -p < a < -1 *)
  absurd (rel_prime (- a) p); intuition.
  inversion H3.
  assert (- a | - a); auto with zarith.
  assert (- a | p); auto with zarith.
  generalize (H8 (- a) H9 H10); intuition idtac.
  generalize (Zdivide_1 (- a) H11); intuition.
  (* a = 0 *)
  inversion H2. subst a; omega.
  (* 1 < a < p *)
  absurd (rel_prime a p); intuition.
  inversion H3.
  assert (a | a); auto with zarith.
  assert (a | p); auto with zarith.
  generalize (H8 a H9 H10); intuition idtac.
  generalize (Zdivide_1 a H11); intuition.
Qed.

(** A prime number is relatively prime with any number it does not divide *)

Lemma prime_rel_prime :
  forall p:Z, prime p -> forall a:Z, ~ (p | a) -> rel_prime p a.
Proof.
  simple induction 1; intros.
  constructor; intuition.
  elim (prime_divisors p H x H3); intuition; subst; auto with zarith.
  absurd (p | a); auto with zarith.
  absurd (p | a); intuition.
Qed.

Hint Resolve prime_rel_prime: zarith.

(** As a consequence, a prime number is relatively prime with smaller numbers *)

Theorem rel_prime_le_prime:
 forall a p, prime p -> 1 <=  a < p -> rel_prime a p.
Proof.
  intros a p Hp [H1 H2].
  apply rel_prime_sym; apply prime_rel_prime; auto.
  intros [q Hq]; subst a.
  case (Zle_or_lt q 0); intros Hl.
  absurd (q * p <= 0 * p); auto with zarith.
  absurd (1 * p <= q * p); auto with zarith.
Qed.

(** If a prime [p] divides [ab] then it divides either [a] or [b] *)

Lemma prime_mult :
  forall p:Z, prime p -> forall a b:Z, (p | a * b) -> (p | a) \/ (p | b).
Proof.
  intro p; simple induction 1; intros.
  case (Zdivide_dec p a); intuition.
  right; apply Gauss with a; auto with zarith.
Qed.

Lemma not_prime_0: ~ prime 0.
Proof.
  intros H1; case (prime_divisors _ H1 2); auto with zarith.
Qed.

Lemma not_prime_1: ~ prime 1.
Proof.
  intros H1; absurd (1 < 1); auto with zarith.
  inversion H1; auto.
Qed.

Lemma prime_2: prime 2.
Proof.
  apply prime_intro; auto with zarith.
  intros n [H1 H2]; case Zle_lt_or_eq with ( 1 := H1 ); auto with zarith;
   clear H1; intros H1.
  contradict H2; auto with zarith.
  subst n; red; auto with zarith.
  apply Zis_gcd_intro; auto with zarith.
Qed.

Theorem prime_3: prime 3.
Proof.
  apply prime_intro; auto with zarith.
  intros n [H1 H2]; case Zle_lt_or_eq with ( 1 := H1 ); auto with zarith;
   clear H1; intros H1.
  case (Zle_lt_or_eq 2 n); auto with zarith; clear H1; intros H1.
  contradict H2; auto with zarith.
  subst n; red; auto with zarith.
  apply Zis_gcd_intro; auto with zarith.
  intros x [q1 Hq1] [q2 Hq2].
  exists (q2 - q1).
  apply trans_equal with (3 - 2); auto with zarith.
  rewrite Hq1; rewrite Hq2; ring.
  subst n; red; auto with zarith.
  apply Zis_gcd_intro; auto with zarith.
Qed.

Theorem prime_ge_2: forall p, prime p ->  2 <= p.
Proof.
  intros p Hp; inversion Hp; auto with zarith.
Qed.

Definition prime' p := 1<p /\ (forall n, 1<n<p -> ~ (n|p)).

Theorem prime_alt:
 forall p, prime' p <-> prime p.
Proof.
  split; destruct 1; intros.
  (* prime -> prime' *)
  constructor; auto; intros.
  red; apply Zis_gcd_intro; auto with zarith; intros.
  case (Zle_lt_or_eq 0 (Zabs x)); auto with zarith; intros H6.
  case (Zle_lt_or_eq 1 (Zabs x)); auto with zarith; intros H7.
  case (Zle_lt_or_eq (Zabs x) p); auto with zarith.
  apply Zdivide_le; auto with zarith.
  apply Zdivide_Zabs_inv_l; auto.
  intros H8; case (H0 (Zabs x)); auto.
  apply Zdivide_Zabs_inv_l; auto.
  intros H8; subst p; absurd (Zabs x <= n); auto with zarith.
  apply Zdivide_le; auto with zarith.
  apply Zdivide_Zabs_inv_l; auto.
  rewrite H7; pattern (Zabs x); apply Zabs_intro; auto with zarith.
  absurd (0%Z = p); auto with zarith.
  assert (x=0) by (destruct x; simpl in *; now auto).
  subst x; elim H3; intro q; rewrite Zmult_0_r; auto.
  (* prime' -> prime *)
  split; auto; intros.
  intros H2.
  case (Zis_gcd_unique n p n 1); auto with zarith.
  apply Zis_gcd_intro; auto with zarith.
  apply H0; auto with zarith.
Qed.

Theorem square_not_prime: forall a, ~ prime (a * a).
Proof.
  intros a Ha.
  rewrite <- (Zabs_square a) in Ha.
  assert (0 <= Zabs a) by auto with zarith.
  set (b:=Zabs a) in *; clearbody b.
  rewrite <- prime_alt in Ha; destruct Ha.
  case (Zle_lt_or_eq 0 b); auto with zarith; intros Hza1; [ | subst; omega].
  case (Zle_lt_or_eq 1 b); auto with zarith; intros Hza2; [ | subst; omega].
  assert (Hza3 := Zmult_lt_compat_r 1 b b Hza1 Hza2).
  rewrite Zmult_1_l in Hza3.
  elim (H1 _ (conj Hza2 Hza3)).
  exists b; auto.
Qed.

Theorem prime_div_prime: forall p q,
 prime p -> prime q -> (p | q) -> p = q.
Proof.
  intros p q H H1 H2;
  assert (Hp: 0 < p); try apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith.
  assert (Hq: 0 < q); try apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith.
  case prime_divisors with (2 := H2); auto.
  intros H4; contradict Hp; subst; auto with zarith.
  intros [H4| [H4 | H4]]; subst; auto.
  contradict H; auto; apply not_prime_1.
  contradict Hp; auto with zarith.
Qed.

(** We could obtain a [Zgcd] function via Euclid algorithm. But we propose
  here a binary version of [Zgcd], faster and executable within Coq.

   Algorithm:

   gcd 0 b = b
   gcd a 0 = a
   gcd (2a) (2b) = 2(gcd a b)
   gcd (2a+1) (2b) = gcd (2a+1) b
   gcd (2a) (2b+1) = gcd a (2b+1)
   gcd (2a+1) (2b+1) = gcd (b-a) (2*a+1)
                    or gcd (a-b) (2*b+1), depending on whether a<b
*)

Open Scope positive_scope.

Fixpoint Pgcdn (n: nat) (a b : positive) : positive :=
  match n with
    | O => 1
    | S n =>
      match a,b with
	| xH, _ => 1
	| _, xH => 1
	| xO a, xO b => xO (Pgcdn n a b)
	| a, xO b => Pgcdn n a b
	| xO a, b => Pgcdn n a b
	| xI a', xI b' =>
          match Pcompare a' b' Eq with
	    | Eq => a
	    | Lt => Pgcdn  n (b'-a') a
	    | Gt => Pgcdn n (a'-b') b
          end
      end
  end.

Definition Pgcd (a b: positive) := Pgcdn (Psize a + Psize b)%nat a b.

Close Scope positive_scope.

Definition Zgcd (a b : Z) : Z :=
  match a,b with
    | Z0, _ => Zabs b
    | _, Z0 => Zabs a
    | Zpos a, Zpos b => Zpos (Pgcd a b)
    | Zpos a, Zneg b => Zpos (Pgcd a b)
    | Zneg a, Zpos b => Zpos (Pgcd a b)
    | Zneg a, Zneg b => Zpos (Pgcd a b)
  end.

Lemma Zgcd_is_pos : forall a b, 0 <= Zgcd a b.
Proof.
  unfold Zgcd; destruct a; destruct b; auto with zarith.
Qed.

Lemma Zis_gcd_even_odd : forall a b g, Zis_gcd (Zpos a) (Zpos (xI b)) g ->
  Zis_gcd (Zpos (xO a)) (Zpos (xI b)) g.
Proof.
  intros.
  destruct H.
  constructor; auto.
  destruct H as (e,H2); exists (2*e); auto with zarith.
  rewrite Zpos_xO; rewrite H2; ring.
  intros.
  apply H1; auto.
  rewrite Zpos_xO in H2.
  rewrite Zpos_xI in H3.
  apply Gauss with 2; auto.
  apply bezout_rel_prime.
  destruct H3 as (bb, H3).
  apply Bezout_intro with bb (-Zpos b).
  omega.
Qed.

Lemma Pgcdn_correct : forall n a b, (Psize a + Psize b<=n)%nat ->
  Zis_gcd (Zpos a) (Zpos b) (Zpos (Pgcdn n a b)).
Proof.
  intro n; pattern n; apply lt_wf_ind; clear n; intros.
  destruct n.
  simpl.
  destruct a; simpl in *; try inversion H0.
  destruct a.
  destruct b; simpl.
  case_eq (Pcompare a b Eq); intros.
  (* a = xI, b = xI, compare = Eq *)
  rewrite (Pcompare_Eq_eq _ _ H1); apply Zis_gcd_refl.
  (* a = xI, b = xI, compare = Lt *)
  apply Zis_gcd_sym.
  apply Zis_gcd_for_euclid with 1.
  apply Zis_gcd_sym.
  replace (Zpos (xI b) - 1 * Zpos (xI a)) with (Zpos(xO (b - a))).
  apply Zis_gcd_even_odd.
  apply H; auto.
  simpl in *.
  assert (Psize (b-a) <= Psize b)%nat.
  apply Psize_monotone.
  change (Zpos (b-a) < Zpos b).
  rewrite (Zpos_minus_morphism _ _ H1).
  assert (0 < Zpos a) by (compute; auto).
  omega.
  omega.
  rewrite Zpos_xO; do 2 rewrite Zpos_xI.
  rewrite Zpos_minus_morphism; auto.
  omega.
  (* a = xI, b = xI, compare = Gt *)
  apply Zis_gcd_for_euclid with 1.
  replace (Zpos (xI a) - 1 * Zpos (xI b)) with (Zpos(xO (a - b))).
  apply Zis_gcd_sym.
  apply Zis_gcd_even_odd.
  apply H; auto.
  simpl in *.
  assert (Psize (a-b) <= Psize a)%nat.
  apply Psize_monotone.
  change (Zpos (a-b) < Zpos a).
  rewrite (Zpos_minus_morphism b a).
  assert (0 < Zpos b) by (compute; auto).
  omega.
  rewrite ZC4; rewrite H1; auto.
  omega.
  rewrite Zpos_xO; do 2 rewrite Zpos_xI.
  rewrite Zpos_minus_morphism; auto.
  omega.
  rewrite ZC4; rewrite H1; auto.
  (* a = xI, b = xO *)
  apply Zis_gcd_sym.
  apply Zis_gcd_even_odd.
  apply Zis_gcd_sym.
  apply H; auto.
  simpl in *; omega.
  (* a = xI, b = xH *)
  apply Zis_gcd_1.
  destruct b; simpl.
  (* a = xO, b = xI *)
  apply Zis_gcd_even_odd.
  apply H; auto.
  simpl in *; omega.
  (* a = xO, b = xO *)
  rewrite (Zpos_xO a); rewrite (Zpos_xO b); rewrite (Zpos_xO (Pgcdn n a b)).
  apply Zis_gcd_mult.
  apply H; auto.
  simpl in *; omega.
  (* a = xO, b = xH *)
  apply Zis_gcd_1.
  (* a = xH *)
  simpl; apply Zis_gcd_sym; apply Zis_gcd_1.
Qed.

Lemma Pgcd_correct : forall a b, Zis_gcd (Zpos a) (Zpos b) (Zpos (Pgcd a b)).
Proof.
  unfold Pgcd; intros.
  apply Pgcdn_correct; auto.
Qed.

Lemma Zgcd_is_gcd : forall a b, Zis_gcd a b (Zgcd a b).
Proof.
  destruct a.
  intros.
  simpl.
  apply Zis_gcd_0_abs.
  destruct b; simpl.
  apply Zis_gcd_0.
  apply Pgcd_correct.
  apply Zis_gcd_sym.
  apply Zis_gcd_minus; simpl.
  apply Pgcd_correct.
  destruct b; simpl.
  apply Zis_gcd_minus; simpl.
  apply Zis_gcd_sym.
  apply Zis_gcd_0.
  apply Zis_gcd_minus; simpl.
  apply Zis_gcd_sym.
  apply Pgcd_correct.
  apply Zis_gcd_sym.
  apply Zis_gcd_minus; simpl.
  apply Zis_gcd_minus; simpl.
  apply Zis_gcd_sym.
  apply Pgcd_correct.
Qed.

Theorem Zgcd_spec : forall x y : Z, {z : Z | Zis_gcd x y z /\ 0 <= z}.
Proof.
  intros x y; exists (Zgcd x y).
  split; [apply Zgcd_is_gcd  | apply Zgcd_is_pos].
Qed.

Theorem Zdivide_Zgcd: forall p q r : Z,
 (p | q) -> (p | r) -> (p | Zgcd q r).
Proof.
  intros p q r H1 H2.
  assert (H3: (Zis_gcd q r (Zgcd q r))).
  apply Zgcd_is_gcd.
  inversion_clear H3; auto.
Qed.

Theorem Zis_gcd_gcd: forall a b c : Z,
 0 <= c ->  Zis_gcd a b c -> Zgcd a b = c.
Proof.
  intros a b c H1 H2.
  case (Zis_gcd_uniqueness_apart_sign a b c (Zgcd a b)); auto.
  apply Zgcd_is_gcd; auto.
  case Zle_lt_or_eq with (1 := H1); clear H1; intros H1; subst; auto.
  intros H3; subst.
  generalize (Zgcd_is_pos a b); auto with zarith.
  case (Zgcd a b); simpl; auto; intros; discriminate.
Qed.

Theorem Zgcd_inv_0_l: forall x y, Zgcd x y = 0 -> x = 0.
Proof.
  intros x y H.
  assert (F1: Zdivide 0 x).
   rewrite <- H.
   generalize (Zgcd_is_gcd x y); intros HH; inversion HH; auto.
  inversion F1 as [z H1].
  rewrite H1; ring.
Qed.

Theorem Zgcd_inv_0_r: forall x y, Zgcd x y = 0 -> y = 0.
Proof.
  intros x y H.
  assert (F1: Zdivide 0 y).
   rewrite <- H.
   generalize (Zgcd_is_gcd x y); intros HH; inversion HH; auto.
  inversion F1 as [z H1].
  rewrite H1; ring.
Qed.

Theorem Zgcd_div_swap0 : forall a b : Z,
 0 < Zgcd a b ->
 0 < b ->
 (a / Zgcd a b) * b = a * (b/Zgcd a b).
Proof.
  intros a b Hg Hb.
  assert (F := Zgcd_is_gcd a b); inversion F as [F1 F2 F3].
  pattern b at 2; rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto.
  repeat rewrite Zmult_assoc; f_equal.
  rewrite Zmult_comm.
  rewrite <- Zdivide_Zdiv_eq; auto.
Qed.

Theorem Zgcd_div_swap : forall a b c : Z,
 0 < Zgcd a b ->
 0 < b ->
 (c * a) / Zgcd a b * b = c * a * (b/Zgcd a b).
Proof.
  intros a b c Hg Hb.
  assert (F := Zgcd_is_gcd a b); inversion F as [F1 F2 F3].
  pattern b at 2; rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto.
  repeat rewrite Zmult_assoc; f_equal.
  rewrite Zdivide_Zdiv_eq_2; auto.
  repeat rewrite <- Zmult_assoc; f_equal.
  rewrite Zmult_comm.
  rewrite <- Zdivide_Zdiv_eq; auto.
Qed.

Lemma Zgcd_comm : forall a b, Zgcd a b = Zgcd b a.
Proof.
  intros.
  apply Zis_gcd_gcd.
  apply Zgcd_is_pos.
  apply Zis_gcd_sym.
  apply Zgcd_is_gcd.
Qed.

Lemma Zgcd_ass : forall a b c, Zgcd (Zgcd a b) c = Zgcd a (Zgcd b c).
Proof.
  intros.
  apply Zis_gcd_gcd.
  apply Zgcd_is_pos.
  destruct (Zgcd_is_gcd a b).
  destruct (Zgcd_is_gcd b c).
  destruct (Zgcd_is_gcd a (Zgcd b c)).
  constructor; eauto using Zdivide_trans.
Qed.

Lemma Zgcd_Zabs : forall a b, Zgcd (Zabs a) b = Zgcd a b.
Proof.
  destruct a; simpl; auto.
Qed.

Lemma Zgcd_0 : forall a, Zgcd a 0 = Zabs a.
Proof.
  destruct a; simpl; auto.
Qed.

Lemma Zgcd_1 : forall a, Zgcd a 1 = 1.
Proof.
  intros; apply Zis_gcd_gcd; auto with zarith; apply Zis_gcd_1.
Qed.
Hint Resolve Zgcd_0 Zgcd_1 : zarith.

Theorem Zgcd_1_rel_prime : forall a b,
 Zgcd a b = 1 <-> rel_prime a b.
Proof.
  unfold rel_prime; split; intro H.
  rewrite <- H; apply Zgcd_is_gcd.
  case (Zis_gcd_unique a b (Zgcd a b) 1); auto.
  apply Zgcd_is_gcd.
  intros H2; absurd (0 <= Zgcd a b); auto with zarith.
  generalize (Zgcd_is_pos a b); auto with zarith.
Qed.

Definition rel_prime_dec: forall a b,
 { rel_prime a b }+{ ~ rel_prime a b }.
Proof.
  intros a b; case (Z_eq_dec (Zgcd a b) 1); intros H1.
  left; apply -> Zgcd_1_rel_prime; auto.
  right; contradict H1; apply <- Zgcd_1_rel_prime; auto.
Defined.

Definition prime_dec_aux:
 forall p m,
  { forall n, 1 < n < m -> rel_prime n p } +
  { exists n, 1 < n < m  /\ ~ rel_prime n p }.
Proof.
  intros p m.
  case (Z_lt_dec 1 m); intros H1;
   [ | left; intros; exfalso; omega ].
  pattern m; apply natlike_rec; auto with zarith.
  left; intros; exfalso; omega.
  intros x Hx IH; destruct IH as [F|E].
  destruct (rel_prime_dec x p) as [Y|N].
  left; intros n [HH1 HH2].
  case (Zgt_succ_gt_or_eq x n); auto with zarith.
  intros HH3; subst x; auto.
  case (Z_lt_dec 1 x); intros HH1.
  right; exists x; split; auto with zarith.
  left; intros n [HHH1 HHH2]; contradict HHH1; auto with zarith.
  right; destruct E as (n,((H0,H2),H3)); exists n; auto with zarith.
Defined.

Definition prime_dec: forall p, { prime p }+{ ~ prime p }.
Proof.
  intros p; case (Z_lt_dec 1 p); intros H1.
  case (prime_dec_aux p p); intros H2.
  left; apply prime_intro; auto.
  intros n [Hn1 Hn2]; case Zle_lt_or_eq with ( 1 := Hn1 ); auto.
  intros HH; subst n.
  red; apply Zis_gcd_intro; auto with zarith.
  right; intros H3; inversion_clear H3 as [Hp1 Hp2].
  case H2; intros n [Hn1 Hn2]; case Hn2; auto with zarith.
  right; intros H3; inversion_clear H3 as [Hp1 Hp2]; case H1; auto.
Defined.

Theorem not_prime_divide:
 forall p, 1 < p -> ~ prime p -> exists n, 1 < n < p  /\ (n | p).
Proof.
  intros p Hp Hp1.
  case (prime_dec_aux p p); intros H1.
  elim Hp1; constructor; auto.
  intros n [Hn1 Hn2].
  case Zle_lt_or_eq with ( 1 := Hn1 ); auto with zarith.
  intros H2; subst n; red; apply Zis_gcd_intro; auto with zarith.
  case H1; intros n [Hn1 Hn2].
  generalize (Zgcd_is_pos n p); intros Hpos.
  case (Zle_lt_or_eq 0 (Zgcd n p)); auto with zarith; intros H3.
  case (Zle_lt_or_eq 1 (Zgcd n p)); auto with zarith; intros H4.
  exists (Zgcd n p); split; auto.
  split; auto.
  apply Zle_lt_trans with n; auto with zarith.
  generalize (Zgcd_is_gcd n p); intros tmp; inversion_clear tmp as [Hr1 Hr2 Hr3].
  case Hr1; intros q Hq.
  case (Zle_or_lt q 0); auto with zarith; intros Ht.
  absurd (n <= 0 * Zgcd n p) ; auto with zarith.
  pattern n at 1; rewrite Hq; auto with zarith.
  apply Zle_trans with (1 * Zgcd n p); auto with zarith.
  pattern n at 2; rewrite Hq; auto with zarith.
  generalize (Zgcd_is_gcd n p); intros Ht; inversion Ht; auto.
  case Hn2; red.
  rewrite H4; apply Zgcd_is_gcd.
  generalize (Zgcd_is_gcd n p); rewrite <- H3; intros tmp;
  inversion_clear tmp as [Hr1 Hr2 Hr3].
  absurd (n = 0); auto with zarith.
  case Hr1; auto with zarith.
Qed.

(** A Generalized Gcd that also computes Bezout coefficients.
   The algorithm is the same as for Zgcd. *)

Open Scope positive_scope.

Fixpoint Pggcdn (n: nat) (a b : positive) : (positive*(positive*positive)) :=
  match n with
    | O => (1,(a,b))
    | S n =>
      match a,b with
	| xH, b => (1,(1,b))
	| a, xH => (1,(a,1))
	| xO a, xO b =>
           let (g,p) := Pggcdn n a b in
           (xO g,p)
	| a, xO b =>
           let (g,p) := Pggcdn n a b in
           let (aa,bb) := p in
           (g,(aa, xO bb))
	| xO a, b =>
           let (g,p) := Pggcdn n a b in
           let (aa,bb) := p in
           (g,(xO aa, bb))
	| xI a', xI b' =>
           match Pcompare a' b' Eq with
	     | Eq => (a,(1,1))
	     | Lt =>
	        let (g,p) := Pggcdn n (b'-a') a in
	        let (ba,aa) := p in
	        (g,(aa, aa + xO ba))
	     | Gt =>
		let (g,p) := Pggcdn n (a'-b') b in
		let (ab,bb) := p in
		(g,(bb+xO ab, bb))
	   end
      end
  end.

Definition Pggcd (a b: positive) := Pggcdn (Psize a + Psize b)%nat a b.

Open Scope Z_scope.

Definition Zggcd (a b : Z) : Z*(Z*Z) :=
  match a,b with
    | Z0, _ => (Zabs b,(0, Zsgn b))
    | _, Z0 => (Zabs a,(Zsgn a, 0))
    | Zpos a, Zpos b =>
       let (g,p) := Pggcd a b in
       let (aa,bb) := p in
       (Zpos g, (Zpos aa, Zpos bb))
    | Zpos a, Zneg b =>
       let (g,p) := Pggcd a b in
       let (aa,bb) := p in
       (Zpos g, (Zpos aa, Zneg bb))
    | Zneg a, Zpos b =>
       let (g,p) := Pggcd a b in
       let (aa,bb) := p in
       (Zpos g, (Zneg aa, Zpos bb))
    | Zneg a, Zneg b =>
       let (g,p) := Pggcd a b in
       let (aa,bb) := p in
       (Zpos g, (Zneg aa, Zneg bb))
  end.

Lemma Pggcdn_gcdn : forall n a b,
  fst (Pggcdn n a b) = Pgcdn n a b.
Proof.
  induction n.
  simpl; auto.
  destruct a; destruct b; simpl; auto.
  destruct (Pcompare a b Eq); simpl; auto.
  rewrite <- IHn; destruct (Pggcdn n (b-a) (xI a)) as (g,(aa,bb)); simpl; auto.
  rewrite <- IHn; destruct (Pggcdn n (a-b) (xI b)) as (g,(aa,bb)); simpl; auto.
  rewrite <- IHn; destruct (Pggcdn n (xI a) b) as (g,(aa,bb)); simpl; auto.
  rewrite <- IHn; destruct (Pggcdn n a (xI b)) as (g,(aa,bb)); simpl; auto.
  rewrite <- IHn; destruct (Pggcdn n a b) as (g,(aa,bb)); simpl; auto.
Qed.

Lemma Pggcd_gcd : forall a b, fst (Pggcd a b) = Pgcd a b.
Proof.
  intros; exact (Pggcdn_gcdn (Psize a+Psize b)%nat a b).
Qed.

Lemma Zggcd_gcd : forall a b, fst (Zggcd a b) = Zgcd a b.
Proof.
  destruct a; destruct b; simpl; auto; rewrite <- Pggcd_gcd;
    destruct (Pggcd p p0) as (g,(aa,bb)); simpl; auto.
Qed.

Open Scope positive_scope.

Lemma Pggcdn_correct_divisors : forall n a b,
  let (g,p) := Pggcdn n a b in
  let (aa,bb):=p in
  (a=g*aa) /\ (b=g*bb).
Proof.
  induction n.
  simpl; auto.
  destruct a; destruct b; simpl; auto.
  case_eq (Pcompare a b Eq); intros.
  (* Eq *)
  rewrite Pmult_comm; simpl; auto.
  rewrite (Pcompare_Eq_eq _ _ H); auto.
  (* Lt *)
  generalize (IHn (b-a) (xI a)); destruct (Pggcdn n (b-a) (xI a)) as (g,(ba,aa)); simpl.
  intros (H0,H1); split; auto.
  rewrite Pmult_plus_distr_l.
  rewrite Pmult_xO_permute_r.
  rewrite <- H1; rewrite <- H0.
  simpl; f_equal; symmetry.
  apply Pplus_minus; auto.
  rewrite ZC4; rewrite H; auto.
  (* Gt *)
  generalize (IHn (a-b) (xI b)); destruct (Pggcdn n (a-b) (xI b)) as (g,(ab,bb)); simpl.
  intros (H0,H1); split; auto.
  rewrite Pmult_plus_distr_l.
  rewrite Pmult_xO_permute_r.
  rewrite <- H1; rewrite <- H0.
  simpl; f_equal; symmetry.
  apply Pplus_minus; auto.
  (* Then... *)
  generalize (IHn (xI a) b); destruct (Pggcdn n (xI a) b) as (g,(ab,bb)); simpl.
  intros (H0,H1); split; auto.
  rewrite Pmult_xO_permute_r; rewrite H1; auto.
  generalize (IHn a (xI b)); destruct (Pggcdn n a (xI b)) as (g,(ab,bb)); simpl.
  intros (H0,H1); split; auto.
  rewrite Pmult_xO_permute_r; rewrite H0; auto.
  generalize (IHn a b); destruct (Pggcdn n a b) as (g,(ab,bb)); simpl.
  intros (H0,H1); split; subst; auto.
Qed.

Lemma Pggcd_correct_divisors : forall a b,
  let (g,p) := Pggcd a b in
  let (aa,bb):=p in
  (a=g*aa) /\ (b=g*bb).
Proof.
  intros a b; exact (Pggcdn_correct_divisors (Psize a + Psize b)%nat a b).
Qed.

Close Scope positive_scope.

Lemma Zggcd_correct_divisors : forall a b,
  let (g,p) := Zggcd a b in
  let (aa,bb):=p in
  (a=g*aa) /\ (b=g*bb).
Proof.
  destruct a; destruct b; simpl; auto; try solve [rewrite Pmult_comm; simpl; auto];
    generalize (Pggcd_correct_divisors p p0); destruct (Pggcd p p0) as (g,(aa,bb));
      destruct 1; subst; auto.
Qed.

Theorem Zggcd_opp: forall x y,
  Zggcd (-x) y = let (p1,p) := Zggcd x y in
                 let (p2,p3) := p in
                 (p1,(-p2,p3)).
Proof.
intros [|x|x] [|y|y]; unfold Zggcd, Zopp; auto.
case Pggcd; intros p1 (p2, p3); auto.
case Pggcd; intros p1 (p2, p3); auto.
case Pggcd; intros p1 (p2, p3); auto.
case Pggcd; intros p1 (p2, p3); auto.
Qed.