Require Import List ZArith Znumtheory Int31 Cyclic31.

(* We are going to implement modular arithmetic with
   montgomery reduction
*)

Definition number := list int31.

Definition nhead (n : number) :=
  match n with cons i _ => i | _ => 0%int31 end.

Definition ntail (n : number) : number :=
  match n with cons _ t => t | _ => @nil _ end.

Open Scope int31_scope.

Fixpoint positive_aux_to_num (p : positive) (i j : int31) : number :=
  match p with
  | xH    => (i + j) :: nil
  | xO p1 =>
    let i1 := 2 * i in
    match i1 ?= 0 with
    | Gt => positive_aux_to_num  p1 i1 j
    | _  =>  j :: positive_aux_to_num  p1 1 0
    end
  | xI p1 =>
    let i1 := 2 * i in
    let j1 := i + j in
    match i1 ?= 0 with
    | Gt => positive_aux_to_num  p1 i1 j1
    | _  =>  j1 :: positive_aux_to_num  p1 1 0
    end
  end.

Definition positive_to_num (p : positive) : number :=
  positive_aux_to_num p 1 0.

Definition Z_to_num z :=
  match z with
  | Zpos p => positive_to_num p
  | _      => nil
  end.

Eval vm_compute in
  positive_to_num 31415926535897932384626433.

Eval vm_compute in
  positive_to_num 2147483648.

Local Definition wB := (2^ Z_of_nat size)%Z.
Definition mphi (n : number) :=
  fold_right (fun i r => phi i + wB * r )%Z 0%Z n.

Notation "[ a ]" := (mphi a).

Eval vm_compute in
  [positive_to_num 31415926535897932384626433].

Lemma phi_nil : [nil] = 0%Z.
Proof. auto. Qed.

Lemma phi_cons a l : ([a::l] = phi a + wB * [l])%Z.
Proof. auto. Qed.

Lemma phi_head_tail n : [n] = [nhead n :: ntail n].
Proof. unfold nhead, ntail; case n; auto. Qed.

Ltac nrom :=
 repeat rewrite phi_nil;
 repeat rewrite phi_cons;
 try change (phi 0) with 0%Z;
 try change (phi 1) with 1%Z;
 try change (phi 2) with 2%Z;
 try change (phi Tn) with (wB - 1)%Z;
 try change (2^ Z_of_nat size)%Z with wB.

Lemma Zpower_nat_0 x : Zpower_nat x 0 = 1%Z.
Proof. auto. Qed.

Lemma Zpower_nat_S x n : Zpower_nat x (S n) =  (x * Zpower_nat x n)%Z.
Proof. auto. Qed.

Lemma Zpower_nat_pos u n : (0 < u -> 0  < Zpower_nat u n)%Z.
Proof.
intros Hu.
induction n. reflexivity.
rewrite Zpower_nat_S.
apply Zmult_lt_0_compat; assumption.
Qed.

Lemma Zpower_base_pos n : (0  < Zpower_nat wB n)%Z.
Proof. apply Zpower_nat_pos; auto with zarith; red; auto. Qed.

Lemma Zpower_nat_le_compat u n m :
  (0 < u)%Z -> (n <= m)%nat -> (Zpower_nat u n  <= Zpower_nat u m)%Z.
Proof.
intros Hu; generalize m; clear m; induction n as [ | n Hrec]; auto with zarith.
intros [ | m]; repeat rewrite Zpower_nat_S; try rewrite Zpower_nat_0; auto with zarith.
intros _; change 1%Z with (1 * 1)%Z; apply Zmult_le_compat; auto with zarith.
generalize (Zpower_nat_pos _ m Hu); auto with zarith.
intros [ | m]; repeat rewrite Zpower_nat_S; try rewrite Zpower_nat_0; auto with zarith.
Qed.

Lemma Zpower_nat_lt_compat u n m :
  (1 < u)%Z -> (n < m)%nat -> (Zpower_nat u n  < Zpower_nat u m)%Z.
Proof.
intros Hu; generalize m; clear m; induction n as [ | n Hrec]; auto with zarith.
intros [ | m]; repeat rewrite Zpower_nat_S; try rewrite Zpower_nat_0; auto with zarith.
intros _; apply Z.lt_le_trans with (u * 1)%Z; auto with zarith.
assert (Hv: (0 < u)%Z); auto with zarith.
generalize (Zpower_nat_pos _ m Hv); auto with zarith.
intros [ | m]; repeat rewrite Zpower_nat_S; try rewrite Zpower_nat_0; auto with zarith.
intros HH.
apply Zmult_lt_compat_l; auto with zarith.
Qed.

Lemma Zpower_nat_le_reg u n m :
  (1 < u)%Z -> (Zpower_nat u n  <= Zpower_nat u m)%Z -> (n <= m)%nat .
Proof.
intros Hu; generalize m; clear m; induction n as [ | n Hrec]; auto with zarith.
intros [ | m]; repeat rewrite Zpower_nat_S; try rewrite Zpower_nat_0.
intros Hv; contradict Hv; apply Zlt_not_le.
apply Z.lt_le_trans with (u * 1)%Z; auto with zarith.
assert (HH: (0 < u)%Z); auto with zarith.
assert (HH1:= Zpower_nat_pos u n HH); auto with zarith.
intros Hv; assert (n <= m)%nat; auto with arith.
apply Hrec; apply Zmult_le_reg_r with u; auto with zarith;
  repeat rewrite <- (Zmult_comm u); auto.
Qed.

Lemma Zpower_nat_lt_reg u n m :
  (1 < u)%Z -> (Zpower_nat u n  < Zpower_nat u m)%Z -> (n < m)%nat .
Proof.
intros Hu; generalize m; clear m; induction n as [ | n Hrec]; auto with zarith.
intros [ | m]; repeat rewrite Zpower_nat_S; try rewrite Zpower_nat_0; auto with zarith.
intros [ | m]; repeat rewrite Zpower_nat_S; try rewrite Zpower_nat_0; auto with zarith.
intros Hv; contradict Hv; apply Zle_not_lt.
apply Z.le_trans with (u * 1)%Z; auto with zarith.
assert (HH: (0 < u)%Z); auto with zarith.
assert (HH1:= Zpower_nat_pos u n HH); auto with zarith.
intros Hv; assert (n < m)%nat; auto with arith.
apply Hrec; apply Zmult_lt_reg_r with u; auto with zarith;
  repeat rewrite <- (Zmult_comm u); auto.
Qed.

Lemma positive_phi p : [positive_to_num p] = Zpos p.
Proof.
assert (Hi0: (forall i n, phi i = Zpower_nat 2 n ->
              match 2 * i ?= 0 with
              | Eq => n = 30%nat
              | Lt => False
              | Gt => phi (2 * i) = Zpower_nat 2 (S n)
              end)).
intros i n Hi.
  assert (n < 31)%nat.
  case (phi_bounded i); nrom; rewrite Hi; intros Hi1 Hi2.
  apply Zpower_nat_lt_reg with 2%Z; auto with zarith.
assert (HH1: (0 < 2)%Z); auto with zarith.
assert (HH2 := Zpower_nat_pos _ (S n) HH1).
rewrite spec_compare; case Z.compare_spec.
rewrite spec_mul; nrom.
rewrite Hi, <- Zpower_nat_S; auto with zarith.
assert (H30 : (n <= 30)%nat) by auto with arith.
apply Nat.lt_eq_cases in H30; case H30; auto with zarith; intros HH3.
rewrite Zmod_small; auto with zarith.
split; auto with zarith.
change wB with (Zpower_nat 2 31); apply Zpower_nat_lt_compat; auto with zarith.
intros HH; contradict HH.
case (phi_bounded (2 * i)); nrom; auto with zarith.
rewrite spec_mul; nrom; rewrite Hi, <- Zpower_nat_S; auto with zarith.
assert (H30 : (n <= 30)%nat) by auto with arith.
apply Nat.lt_eq_cases in H30; case H30; auto with zarith; intros HH3.
rewrite Zmod_small; nrom; auto with zarith.
split; auto with zarith.
change wB with (Zpower_nat 2 31); apply Zpower_nat_lt_compat; auto with zarith.
rewrite HH3, Z_mod_same; auto with zarith.
apply Z.lt_gt; auto with zarith.
assert (Hij: (forall i j n, phi i = Zpower_nat 2 n -> phi j < phi i ->
             phi (i + j) = phi i + phi j)%Z).
intros i j n Hi Hj.
  rewrite spec_add, Zmod_small; auto; nrom.
  case (phi_bounded i); case (phi_bounded j); nrom; intros H1j H2j H1i H2i;
   split; auto with zarith.
  assert (n < 31)%nat.
  apply Zpower_nat_lt_reg with 2%Z; auto with zarith.
  rewrite <- Hi; auto with zarith.
  apply Z.lt_le_trans with (Zpower_nat 2 (S n)).
  rewrite Zpower_nat_S, <-Hi; auto with zarith.
  change wB with (Zpower_nat 2 31).
  apply Zpower_nat_le_compat; auto with zarith.
assert (H: forall p1 i j n, phi i = Zpower_nat 2 n -> (phi j < phi i ->
   mphi (positive_aux_to_num p1 i j) = Zpos p1 * phi i + phi j)%Z).
induction p1 as [p1 Hrec| p1 Hrec| ]; simpl positive_aux_to_num; intros i j n Hi Hj.
generalize (Hi0 i n Hi); rewrite spec_compare; case Z.compare_spec; nrom.
intros Hphi Hn; rewrite (Hij i j n), Hi, Hn; auto with zarith.
rewrite (Hrec 1 0 0%nat); nrom; auto with zarith.
rewrite Zpos_xI; change wB with (2 * Zpower_nat 2 30)%Z; ring.
generalize (phi_bounded (2 * i)); auto with zarith.
intros HH H2i; rewrite (Hrec _ _ (S n)); auto with zarith.
rewrite Zpos_xI, H2i, (Hij i j n), Hi, Zpower_nat_S by auto with zarith.
ring.
rewrite (Hij i j n), H2i, Zpower_nat_S, <- Hi; auto with zarith.
generalize (Hi0 i n Hi); rewrite spec_compare; case Z.compare_spec; nrom.
intros HH Hn; rewrite Hi, Hn; auto with zarith.
rewrite (Hrec 1 0 0%nat); nrom; auto with zarith.
rewrite Zpos_xO; change wB with (2 * Zpower_nat 2 30)%Z; ring.
generalize (phi_bounded (2 * i)); auto with zarith.
intros HH H2i; rewrite (Hrec _ _ (S n)); auto with zarith.
rewrite Zpos_xO, H2i, Hi, Zpower_nat_S by auto with zarith.
ring.
case (phi_bounded i); intros Hi1 H2.
rewrite H2i, Zpower_nat_S, <- Hi; auto with zarith.
rewrite phi_cons, (Hij i j n); nrom; auto with zarith.
unfold positive_to_num.
rewrite (H _ _ _ 0%nat); [|auto with zarith|].
nrom; ring.
nrom; auto with zarith.
Qed.

Lemma phi_pos n : (0 <= [n])%Z.
Proof.
induction n as [ | a n Hrec]; nrom; auto with zarith.
case (phi_bounded a); intros Ha1 Ha2; auto with zarith.
apply Z.add_nonneg_nonneg; auto with zarith.
apply Z.mul_nonneg_nonneg; auto with zarith.
apply Z.pow_nonneg; auto with zarith.
Qed.

Lemma num_phi z :  (0 <= z)%Z -> [Z_to_num z] = z.
Proof.
destruct z as [|p|p]; intros Hp. auto with zarith.
apply positive_phi.
contradict Hp; auto with zarith.
Qed.

Lemma add_cp a b :
  match (a + b) ?= a with
  | Lt => (phi (a + b) = phi a + phi b - wB)%Z
  | _  => (phi (a + b) = phi a + phi b)%Z
  end.
Proof.
case (phi_bounded a); nrom; intros Ha1 Ha2.
case (phi_bounded b); nrom; intros Hb1 Hb2.
case (phi_bounded (a + b)); nrom; intros Hab1 Hab2.
assert (H2ab: (phi a + phi b < 2 * wB)%Z); auto with zarith.
case (Zle_or_lt wB (phi a + phi b)); intros H1ab.
assert (He: (phi(a + b) = phi a + phi b - wB)%Z).
rewrite <- (fun x y => Zmod_small (x - y) wB); auto with zarith.
rewrite Zminus_mod, Z_mod_same_full, Zminus_0_r, Zmod_mod, <- spec_add; auto.
rewrite spec_compare; case Z.compare_spec; nrom; intros Hc; auto with zarith.
assert (He: (phi(a + b) = phi a + phi b)%Z).
rewrite spec_add, Zmod_small; auto with zarith.
rewrite spec_compare; case Z.compare_spec; nrom; intros Hc; auto with zarith.
Qed.

Lemma add1_cp a :
  match (1 + a) ?= 0 with
  | Eq => (phi a = wB - 1)%Z
  | _ => (phi (1 + a) = 1 + phi a)%Z
  end.
Proof.
case (phi_bounded a);
case (phi_bounded (1 + a));
  generalize (add_cp 1 a); rewrite spec_compare; case Z.compare_spec;
  rewrite spec_compare; case Z.compare_spec; nrom; auto with zarith.
Qed.

Lemma add2_cp a b :
  match (1 + (a + b)) ?= a with
  | Gt  => (phi (1 + (a + b)) = phi a + phi b + 1)%Z
  | _ => (phi (1 + (a + b)) = phi a + phi b + 1 - wB)%Z
  end.
Proof.
case (phi_bounded a); nrom; intros Ha1 Ha2.
case (phi_bounded b); nrom; intros Hb1 Hb2.
case (phi_bounded (a + b)); nrom; intros Hab1 Hab2.
case (phi_bounded (1 + (a + b))); nrom; intros H1ab1 H1ab2.
generalize (add_cp 1 (a + b)) (add_cp a b);
 do 2 (rewrite spec_compare; case Z.compare_spec); nrom; intros H1 H2;
  lazy zeta; rewrite spec_compare; case Z.compare_spec; nrom; auto with zarith.
Qed.

Fixpoint incr_num (n: number): number :=
  match n with
  | nil => 1 :: nil
  | a::n1 => let c :=  1 + a in
             match c ?= 0 with
             | Eq => 0 :: incr_num n1
             | _  => c :: n1
             end
  end.

Notation "a .+1" := (incr_num a) (at level 0).

Lemma incr_correct n : ([n.+1] = [n] + 1)%Z.
Proof.
induction n as [ | a n Hrec]; nrom; auto.
unfold incr_num; fold incr_num.
generalize (add1_cp a); rewrite spec_compare; case Z.compare_spec; nrom;
  intros HH H; rewrite H; try rewrite Hrec; try ring.
Qed.

Fixpoint add_num (n1 n2 : number) :=
  match n1 with
  | nil => n2
  | a :: n3 => match n2 with
             | nil => n1
             | b :: n4 => let c := a + b in
                          match c ?= a with
                          | Lt => c :: add1_num n3 n4
                          | _  => c :: add_num n3 n4
                          end
             end
  end
with add1_num (n1 n2 : number) :=
  match n1 with
  | nil => incr_num n2
  | a :: n3 => match n2 with
               | nil => incr_num n1
               | b :: n4 => let c := (1 + (a + b)) in
                            match c ?= a with
                            | Gt  => c :: add_num n3 n4
                            | _   => c :: add1_num n3 n4
                            end
               end
  end.

Notation "a + b" := (add_num a b).
Notation "a +1 b" := (add1_num a b) (at level 40).

Lemma add_add1_correct m n :
  [m + n] = ([m] + [n])%Z /\ [m +1 n] = ([m] + [n] + 1)%Z.
Proof.
generalize n; clear n.
induction m as [ | a m Hrec]; nrom; auto.
intros n; simpl; rewrite incr_correct; auto.
intros n; destruct n as [ | b n].
  unfold add_num; fold add_num;
  unfold add1_num; fold add1_num;
  rewrite incr_correct; auto with zarith.
split.
change ((a :: m) + (b :: n)) with
                      (let c :=  (a + b)%int31 in
                        match c ?= a with
                        | Lt => c::add1_num m n
                        | _  => c::add_num m n
                        end).
lazy zeta; generalize (add_cp a b); rewrite spec_compare; case Z.compare_spec;
  nrom; intros HH H; case (Hrec n); intros H1 H2;
  try rewrite H; try rewrite H1; try rewrite H2; ring.
change ((a :: m) +1 (b :: n)) with
                      (let c :=  (1 + (a + b))%int31 in
                        match c ?= a with
                        | Gt => c::add_num m n
                        | _  => c::add1_num m n
                        end).
lazy zeta;  generalize (add2_cp a b); rewrite spec_compare; case Z.compare_spec;
 nrom; intros HH H1; case (Hrec n); intros Hr1 Hr2;
 rewrite H1; (rewrite Hr1 || rewrite Hr2); ring.
Qed.

Lemma add_correct m n : [m + n] = ([m] + [n])%Z.
Proof. case (add_add1_correct m n); auto. Qed.

Lemma add1_correct m n : [m +1 n] = ([m] + [n] + 1)%Z.
Proof. case (add_add1_correct m n); auto. Qed.

Fixpoint zerop_num (n: number) :=
  match n with
  | nil => true
  | a::n1 => match a ?= 0 with
             | Eq => zerop_num n1
             | _  => false
             end
  end.

Lemma zerop_correct n :
  if zerop_num n then [n] = 0%Z else [n] <> 0%Z.
Proof.
induction n as [ | a n Hrec].
simpl; auto.
case (phi_bounded a); nrom; intros Ha1 Ha2.
unfold zerop_num; fold zerop_num.
rewrite spec_compare; case Z.compare_spec; nrom. 2: auto with zarith.
generalize Hrec; case zerop_num.
intros H1 H2; rewrite H1, H2; ring.
intros H1 H2; rewrite H2.
rewrite Zplus_0_l; intros HH; case (Zmult_integral _ _ HH);
  auto with zarith.
generalize (phi_pos n); intros H1 H2 H3.
enough (0 < phi a + wB * [n])%Z by auto with zarith.
apply Z.lt_le_trans with (phi a). auto with zarith.
assert (0 <= wB * [n])%Z; auto with zarith.
Qed.

Fixpoint cpr_num (n1 n2: number) res :=
  match n1 with
  | nil => if zerop_num n2 then res else Lt
  | a :: n3 => match n2 with
             | nil => if zerop_num n1 then res else Gt
             | b :: n4 => let res1 :=
                          match a ?= b with
                          | Eq => res
                          | v  => v
                          end in cpr_num n3 n4 res1
             end
  end.

Lemma base_lexi_order a b n1 n2 wB :
  (0 <= a < wB -> 0 <= b < wB ->
   match a + wB * n1 ?= b + wB * n2 with
   | Eq => a = b /\ n1 = n2
   | Lt => n1 < n2 \/ (n1 = n2 /\ a < b)
   | Gt => n2 < n1 \/ (n1 = n2 /\ b < a)
   end)%Z.
Proof.
intros (Ha1, Ha2) (Hb1, Hb2).
case Z.compare_spec; intros HH.
case (Zle_or_lt n1 n2); intros H1.
case (Zle_lt_or_eq _ _ H1); clear H1; intros H1; auto.
assert (HH1: (wB + wB * (n2 - n1 -1) = (a - b))%Z).
replace a with ((a + wB * n1) - wB * n1)%Z by ring.
rewrite HH; ring.
assert (Hu: (0 <= wB * (n2 - n1 - 1))%Z); auto with zarith.
split; auto.
replace a with ((a + wB * n1) - wB * n1)%Z by ring.
rewrite HH, H1; ring.
assert (wB + wB * (n1 - n2 -1) = (b - a))%Z.
replace b with ((b + wB * n2) - wB * n2)%Z by ring.
rewrite <-HH; ring.
assert (Hu: (0 <= wB * (n1 - n2 - 1))%Z); auto with zarith.
case (Zle_or_lt n2 n1); intros H1; auto.
case (Zle_lt_or_eq _ _ H1); clear H1; intros H1; auto.
assert (0 <= wB * (n1 - n2 - 1))%Z by auto with zarith.
enough (wB + wB * (n1 - n2 -1) < (b - a))%Z by auto with zarith.
repeat rewrite Zmult_minus_distr_l; rewrite Zmult_1_r; auto with zarith.
rewrite H1 in HH; auto with zarith.
case (Zle_or_lt n1 n2); intros H1; auto.
case (Zle_lt_or_eq _ _ H1); clear H1; intros H1; auto.
assert (0 <= wB * (n2 - n1 - 1))%Z by auto with zarith.
enough (wB + wB * (n2 - n1 -1) < (a - b))%Z by auto with zarith.
repeat rewrite Zmult_minus_distr_l; rewrite Zmult_1_r; auto with zarith.
rewrite H1 in HH; auto with zarith.
Qed.

Lemma cpr_correct n1 n2 res :
  match ([n1] ?= [n2])%Z with
  | Lt => cpr_num n1 n2 res = Lt
  | Gt => cpr_num n1 n2 res = Gt
  | Eq => cpr_num n1 n2 res = res
  end.
Proof.
generalize n2 res; clear n2 res.
induction n1 as [ | a n1 Hrec].
intros n2 res; simpl cpr_num; nrom.
generalize (phi_pos n2); case Z.compare_spec; auto with zarith;
  generalize (zerop_correct n2); case zerop_num; auto with zarith;
  intros H1 H2 H3; contradict H1; auto with zarith.
intros [ | b n2].
intros res; unfold cpr_num.
generalize (phi_pos (a::n1)); case Z.compare_spec; auto with zarith;
  generalize (zerop_correct (a::n1)); case zerop_num; auto with zarith;
  nrom; intros H1 H2 H3; contradict H1; auto with zarith.
intros res; unfold cpr_num; fold cpr_num.
set (v := (match a ?= b with Eq => res | _ => a ?= b end)).
generalize (base_lexi_order _ _ [n1] [n2] _
                    (phi_bounded a) (phi_bounded b)); nrom;
  case Z.compare.
intros (HH, HH0).
unfold v; rewrite spec_compare; case Z.compare_spec; nrom; intros HH2;
  try (contradict HH2; auto with zarith; fail).
generalize (Hrec n2 res); case Z.compare_spec; auto;
 intros HH3; contradict HH3; auto with zarith.
intros [HH2 | (HH2, HH3)].
generalize (Hrec n2 v); rewrite HH2; unfold v;
  rewrite spec_compare; case Z.compare_spec; auto.
generalize (Hrec n2 v); rewrite HH2; unfold v.
rewrite Z.compare_refl.
rewrite spec_compare; case Z.compare_spec; auto with zarith
 ; intros HH; contradict HH; auto with zarith.
intros [HH2 | (HH2, HH3)].
generalize (Hrec n2 v); case Z.compare_spec; auto with zarith.
intros HH; contradict HH2; auto with zarith.
intros HH; contradict HH2; auto with zarith.
unfold v; rewrite spec_compare; case Z.compare_spec; auto.
generalize (Hrec n2 v); rewrite HH2, Z.compare_refl.
unfold v; rewrite spec_compare; case Z.compare_spec; auto.
intros HH4; contradict HH3; auto with zarith.
intros HH4; contradict HH3; auto with zarith.
Qed.

Definition cp_num n1 n2 := cpr_num n1 n2 Eq.

Inductive CpSpec (i j : number) : comparison -> Prop :=
    CpSpecEq : [i] = [j] -> CpSpec i j Eq
  | CpSpecLt : ([i] < [j])%Z -> CpSpec i j Lt
  | CpSpecGt : ([j] < [i])%Z -> CpSpec i j Gt.

Lemma cp_spec i j : CpSpec i j (cp_num i j).
Proof.
generalize (cpr_correct i j Eq).
unfold cp_num; case Z.compare_spec; intros H1 H2; rewrite H2;
  constructor; auto.
Qed.

Fixpoint eq_num (n1 n2: number) :=
  match n1 with
  | nil     => zerop_num n2
  | a :: n3 => match n2 with
             | nil     => zerop_num n1
             | b :: n4 => match a ?= b with
                          | Eq => eq_num n3 n4
                          | _  => false
                        end
             end
  end.

Lemma eq_correct n1 n2 :
  if eq_num n1 n2 then [n1] = [n2]%Z else [n1] <> [n2]%Z.
Proof.
generalize n2; clear n2.
induction n1 as [ | a n1 Hrec].
intros n2; generalize (zerop_correct n2); simpl; case zerop_num; auto.
case (phi_bounded a); nrom; intros Ha1 Ha2.
intros [ |b n2]; unfold eq_num; fold eq_num; nrom.
generalize (zerop_correct (a::n1)); simpl; case zerop_num; auto.
rewrite spec_compare; case Z.compare_spec; nrom; intros H1;
  try (
    intros HH;
     generalize (base_lexi_order _ _ [n1] [n2] _
                      (phi_bounded a) (phi_bounded b)); nrom;
    rewrite HH, Z.compare_refl; intros (H3,H4); contradict H1; auto with zarith).
generalize (Hrec n2); case eq_num; intros H2.
apply Zcompare_Eq_eq;
  generalize (base_lexi_order _ _ [n1] [n2] _
                    (phi_bounded a) (phi_bounded b)); nrom;
  case Z.compare; auto.
intros [H3 | (H3, H4)]; contradict H3; auto with zarith.
intros [H3 | (H3, H4)]; contradict H3; auto with zarith.
intros HH;
  generalize (base_lexi_order _ _ [n1] [n2] _
                    (phi_bounded a) (phi_bounded b)); nrom;
  rewrite HH, Z.compare_refl; intros (H3,H4); case H2; auto.
Qed.

Fixpoint decr_num (n: number): number :=
  match n with
  | nil     => 1 :: nil
  | a :: n1 => match a ?= 0 with
             | Eq => Tn :: decr_num n1
             | _  => (a - 1) :: n1
             end
  end.

Notation "a .-1" := (decr_num a) (at level 0).

Lemma decr_correct n : (0 < [n])%Z -> ([n.-1] = [n] - 1)%Z.
Proof.
induction n as [ | a n Hrec]; nrom. auto with zarith.
unfold decr_num; fold decr_num.
case (phi_bounded a); nrom; intros Ha1 Ha2.
rewrite spec_compare; case Z.compare_spec;
  nrom; try rewrite spec_Bm1; nrom. 2: auto with zarith.
intros H1 H2; rewrite H1 in H2 |- *; rewrite Hrec;
 auto with zarith; try ring.
apply Zmult_lt_0_reg_r with wB; auto with zarith.
rewrite Zmult_comm; auto with zarith.
intros H1 H2.
rewrite spec_sub; nrom.
rewrite Zmod_small; auto with zarith.
Qed.

Fixpoint sub_num (n1 n2 : number) :=
  match n1 with
  | nil     => nil
  | a :: n3 => match n2 with
             | nil     => n1
             | b :: n4 => let c := a - b in
                          match c ?= a with
                          | Gt => c :: sub1_num n3 n4
                          | _  => c :: sub_num n3 n4
                          end
             end
  end
with sub1_num (n1 n2 : number) :=
  match n1 with
  | nil     => nil
  | a :: n3 => match n2 with
               | nil     => decr_num n1
               | b :: n4 => let c := (a - (1 + b)) in
                            match c ?= a with
                            | Lt  => c :: sub_num n3 n4
                            | _   => c :: sub1_num n3 n4
                            end
               end
  end.

Notation "a - b" := (sub_num a b).
Notation "a -1 b" := (sub1_num a b) (at level 40).

Lemma sub_cp a b :
  match (a - b) ?= a with
  | Gt => (phi (a - b) = phi a - phi b + wB)%Z
  | _  => (phi (a - b) = phi a - phi b)%Z
  end.
Proof.
case (phi_bounded a); nrom; intros Ha1 Ha2.
case (phi_bounded b); nrom; intros Hb1 Hb2.
case (phi_bounded (a - b)); nrom; intros Hab1 Hab2.
assert (H1ab: (phi a - phi b < wB)%Z); auto with zarith.
case (Zle_or_lt 0 (phi a - phi b)); intros Hab.
assert (He: (phi(a - b) = phi a - phi b)%Z).
rewrite spec_sub, Zmod_small; auto with zarith.
rewrite spec_compare; case Z.compare_spec; intros Hc;
  auto with zarith.
assert (He: (phi(a - b) = phi a - phi b + wB)%Z).
rewrite <- (fun x y => Zmod_small (x + y) wB); auto with zarith.
rewrite Zplus_mod, Z_mod_same_full, Zplus_0_r, Zmod_mod, <- spec_sub; auto.
rewrite spec_compare; case Z.compare_spec; intros Hc;
  auto with zarith.
Qed.

Lemma sub1_cp a b :
  match (a - (1 + b)) ?= a with
  | Lt => (phi (a - (1 + b)) = phi a - (1 + phi b))%Z
  | _  => (phi (a - (1 + b)) = phi a - (1 + phi b) + wB)%Z
  end.
Proof.
case (phi_bounded a); nrom; intros Ha1 Ha2.
case (phi_bounded b); nrom; intros Hb1 Hb2.
case (phi_bounded (1 + b)); nrom; intros H1b1 H1b2.
case (phi_bounded (a - (1 + b))); nrom; intros Hab1 Hab2.
case (Zle_lt_or_eq (1 + phi b) wB); auto with zarith; intros Hb3;
  try(
  rewrite spec_compare; case Z.compare_spec; intros Hc;
  auto with zarith;
  generalize Hc; rewrite spec_sub, spec_add; nrom;
  rewrite Hb3, Z_mod_same_full, Zminus_0_r, Zmod_small; auto with zarith).
assert (H1b: phi (1 + b) = (phi b + 1)%Z).
  rewrite spec_add, Zmod_small; nrom; auto with zarith.
assert (H1ab: (phi a - phi (1 + b) < wB)%Z); auto with zarith.
case (Zle_or_lt 0 (phi a - phi (1 + b))); intros Hab.
assert (He: (phi(a - (1 + b)) = phi a - phi b - 1)%Z).
rewrite spec_sub, Zmod_small; nrom; auto with zarith.
rewrite spec_compare; case Z.compare_spec; intros Hc;
  auto with zarith.
assert (He: (phi(a - (1 + b)) = phi a - phi b - 1 + wB)%Z).
rewrite <- (fun x y => Zmod_small (x + y) wB); auto with zarith.
rewrite Zplus_mod, Z_mod_same_full, Zplus_0_r, Zmod_mod; auto with zarith.
rewrite spec_sub, H1b; nrom;
  apply f_equal2 with (f := Z.modulo); auto with zarith.
rewrite spec_compare; case Z.compare_spec; intros Hc;
  auto with zarith.
Qed.

Lemma sub_sub1_correct m n :
   (([n] <= [m])%Z -> [m - n] = ([m] - [n])%Z)
/\ ([n] <  [m] -> [m -1 n] = [m] - (1 + [n]))%Z.
Proof.
generalize n; clear n.
induction m as [ | a m Hrec]; nrom; auto.
intros n; induction n as [ | b n Hrec];
  unfold sub_num, sub1_num; fold sub_num;
  fold sub1_num; nrom; auto with zarith.
generalize (phi_pos (b::n)); nrom; auto with zarith.
intros n; destruct n as [ | b n];
  unfold sub_num, sub1_num; fold sub_num;
  fold sub1_num; nrom; auto with zarith.
split; intros H1; auto with zarith.
rewrite decr_correct; auto with zarith.
split; intros H1.
case (Hrec n); intros H2 H3.
assert (H4: ([n] <= [m])%Z).
  generalize (base_lexi_order _ _ [n] [m] _ (phi_bounded b) (phi_bounded a));
  nrom;
  case (Zle_lt_or_eq _ _ H1); intros H4.
    red in H4; rewrite H4; auto with zarith.
  rewrite H4, Z.compare_refl; auto with zarith.
generalize (sub_cp a b); rewrite spec_compare; case Z.compare_spec; nrom; intros HH0 HH1;
  rewrite HH1; try rewrite H2; auto; try ring.
rewrite H3; try ring.
case (Zle_lt_or_eq _ _ H4); intros H5; auto.
rewrite H5 in H1 |- *.
generalize (base_lexi_order _ _ [m] [m] _ (phi_bounded b) (phi_bounded a));
nrom.
assert (H6: (phi a < phi b)%Z).
case (Zle_or_lt (phi b) (phi a)); intros H6; auto.
generalize HH1; rewrite spec_sub; nrom.
  case (phi_bounded a); nrom; intros Ha1 Ha2;
  case (phi_bounded b); nrom; intros Hb1 Hb2;
    rewrite Zmod_small; auto with zarith.
case (Zle_lt_or_eq _ _ H1); intros H7.
red in H7; rewrite H7; auto with zarith.
rewrite H7, Z.compare_refl; auto with zarith.
generalize (base_lexi_order _ _ [n] [m] _ (phi_bounded b) (phi_bounded a)); nrom.
red in H1; rewrite H1.
intros [H2 | (H2, H3)].
case (Hrec n); intros H3 H4.
generalize (sub1_cp a b); rewrite spec_compare; case Z.compare_spec; nrom; intros HH0 HH1;
  rewrite HH1; try rewrite H3; try rewrite H4;
  auto with zarith; try ring.
assert (Ha: (phi (a - (1 + b)) < phi a)%Z).
  case (phi_bounded a); nrom; intros H1a H2a.
  case (phi_bounded b); nrom; intros H1b _.
  rewrite spec_sub, Zmod_small; nrom; auto with zarith;
  rewrite spec_add, Zmod_small; nrom; auto with zarith.
rewrite spec_compare; case Z.compare_spec; auto with zarith.
intros _; case (Hrec n); intros H4 _; nrom.
rewrite H4; auto with zarith.
case (phi_bounded a); nrom; intros H1a H2a;
  case (phi_bounded b); nrom; intros H1b _;
  rewrite spec_sub, Zmod_small; nrom; auto with zarith;
  rewrite spec_add, Zmod_small; nrom; auto with zarith;
  try ring.
Qed.

Lemma sub_correct m n :
  ([n] <= [m])%Z -> [m - n] = ([m] - [n])%Z.
Proof. intros H; case (sub_sub1_correct m n); auto with zarith. Qed.

Lemma sub1_correct m n :
  ([n] < [m])%Z -> [m -1 n] = ([m] - [n] - 1)%Z.
Proof. intros H; case (sub_sub1_correct m n); auto with zarith. Qed.

Definition add_mod p m n :=
  let res := m + n in
  match cp_num res p with
  | Lt => res
  | _  => res - p
  end.

Lemma add_mod_correct p m n :
  (0 <= [m] < [p] -> 0 <= [n] < [p] ->
       [add_mod p m n] = ([m] + [n]) mod [p])%Z.
Proof.
intros H1 H2; unfold add_mod.
case cp_spec; rewrite add_correct; intros H3;
  try rewrite sub_correct; try rewrite add_correct; auto with zarith.
rewrite H3, Z_mod_same_full; auto with zarith.
rewrite Zmod_small; auto with zarith.
rewrite <-(fun x y => (Zmod_small (x - y) [p])); auto with zarith.
rewrite Zminus_mod, Z_mod_same_full, Zminus_0_r, Zmod_mod; auto.
Qed.

Lemma add_mod_bound p m n :
  (0 <= [m] < [p] -> 0 <= [n] < [p] ->
       0 <= [add_mod p m n] < [p])%Z.
Proof.
intros H1 H2; rewrite add_mod_correct; auto.
apply Z_mod_lt; auto with zarith.
Qed.

Definition sub_mod p m n :=
  match cp_num m n with
  | Lt => (p + m) - n
  | _  => m - n
  end.

Lemma sub_mod_correct p m n :
  (0 <= [m] < [p] -> 0 <= [n] < [p] ->
       [sub_mod p m n] = ([m] - [n]) mod [p])%Z.
Proof.
intros H1 H2; unfold sub_mod.
case cp_spec; intros H3.
rewrite H3, Zminus_diag, Zmod_0_l, sub_correct, H3; auto with zarith.
rewrite sub_correct; rewrite add_correct; auto with zarith.
rewrite <-(fun x y => (Zmod_small (x - y) [p])); auto with zarith.
rewrite Zminus_mod, Zplus_mod, Z_mod_same_full, Zplus_0_l,
        Zmod_mod, <- Zminus_mod; auto.
rewrite Zmod_small, sub_correct; auto with zarith.
Qed.

Lemma sub_mod_bound p m n :
  (0 <= [m] < [p] -> 0 <= [n] < [p] ->
       0 <= [sub_mod p m n] < [p])%Z.
Proof.
intros H1 H2; rewrite sub_mod_correct; auto.
apply Z_mod_lt; auto with zarith.
Qed.

Definition amd (A: Type) (a b c: int31) (f: int31 -> int31 -> A): A :=
match a *c b with
| W0 => f c 0
| WW resh resl =>
    let u := (resl + c)%int31 in
    match u ?= resl with
    | Lt => f u (incr resh)
    | _ => f u resh
    end
end.

Fixpoint amd_num (a b: int31) (n: number): number :=
match n with
| nil => b :: nil
| c::n1 => amd _ a c b
    (fun xl xh =>
       xl :: amd_num a xh n1)
end.

Lemma amd_correct a b n :
  [amd_num a b n] = (phi a * [n] + phi b)%Z.
Proof.
generalize a b; clear a b;
  induction n as [ | c n1 Hrec]; intros a b;
  unfold amd_num; fold amd_num; nrom; nrom.
ring.
unfold amd; generalize (spec_mul_c a c); nrom;
  case (_ *c _); simpl zn2z_to_Z.
intros H1; nrom; rewrite Hrec; nrom.
repeat rewrite Zmult_plus_distr_r; rewrite <- H1.
ring.
intros xh xl Hx; generalize (add_cp xl b); case (_ ?= _);
  intros H1; nrom; rewrite H1, Hrec;
  repeat rewrite Zmult_plus_distr_r; rewrite <- Hx; try ring.
replace (phi (incr xh)) with (phi xh + 1)%Z; try ring.
case (phi_bounded a); nrom; intros H1a H2a.
case (phi_bounded c); nrom; intros H1c H2c.
case (phi_bounded xl); nrom; intros H1xl H2xl.
rewrite phi_incr, Zmod_small; nrom; auto with zarith.
case (phi_bounded xh); nrom; intros H1xh H2xh; split; auto with zarith.
assert (HH: (phi a * phi c <= (wB - 1) * (wB - 1))%Z).
apply Zmult_le_compat; auto with zarith.
replace ((wB - 1) * (wB - 1))%Z with
    (1 + wB * (wB - 2) )%Z in HH;try ring.
rewrite <-Hx, Zmult_comm, Zplus_comm in HH.
assert (HH1: (0 <= 1 < wB)%Z);
  case (phi_bounded 1); nrom; auto with zarith.
generalize (base_lexi_order (phi xl) 1 (phi xh) (wB - 2) wB
             (phi_bounded xl) HH1).
case (Zle_lt_or_eq _ _ HH); intros HH2.
red in HH2; rewrite HH2; auto with zarith.
rewrite HH2, Z.compare_refl; auto with zarith.
Qed.

Definition scal_num (a : int31) (n : number) : number :=
  amd_num a 0 n.

Lemma scal_correct a n :
  [scal_num a n] = (phi a * [n])%Z.
Proof. unfold scal_num; rewrite amd_correct; nrom; ring. Qed.

Fixpoint prod_num (m n : number) : number :=
  match n with
  | nil     => nil
  | a :: n1 => match scal_num a m with
               | nil     => 0 :: prod_num m n1
               | b :: n2 => b :: add_num n2 (prod_num m n1)
               end
  end.

Lemma prod_correct m n : [prod_num m n] = ([m] * [n])%Z.
Proof.
induction n as [ | a n Hrec]; unfold prod_num;
  fold prod_num.
nrom; ring.
generalize (scal_correct a m); case scal_num; nrom.
rewrite Hrec; intros HH.
rewrite Zmult_plus_distr_r, (Zmult_comm [m]), (Zmult_comm [m]),
        <-HH; ring.
intros i l; nrom; intros HH.
rewrite add_correct, Hrec, Zmult_plus_distr_r, Zplus_assoc, HH;
  ring.
Qed.

Fixpoint exp_num (m : number) (n : nat) : number :=
  match n with
  | O    => 1 :: nil
  | S n1 => prod_num m (exp_num m n1)
  end.

Lemma exp_correct m n: [exp_num m n] = Zpower_nat [m] n.
Proof.
induction n as [ | n Hrec]; unfold exp_num; fold exp_num.
nrom; nrom; unfold Zpower_nat; simpl; auto.
change (S n) with (1 + n)%nat; rewrite Zpower_nat_is_exp.
rewrite prod_correct, Hrec; change (Zpower_nat [m] 1) with ([m] * 1)%Z.
ring.
Qed.

Definition shift_num (t : number) : number :=
  match t with nil => nil | a :: t1 => t1 end.

Lemma shift_correct t : [shift_num t] = ([t] / wB)%Z.
Proof.
destruct t as [ | a t]; unfold shift_num; nrom.
rewrite Zdiv_0_l; auto.
case (phi_bounded a); nrom; intros H1a H2a.
rewrite Zmult_comm, Z_div_plus_full; auto with zarith.
rewrite Zdiv_small; auto with zarith.
Qed.

Section Reduce.

Variable M : number.
Variable m' : int31.
Hypothesis Hmm' : (phi (nhead M * m') = wB - 1)%Z.

Lemma M_pos : (0 < [M])%Z.
Proof.
rewrite phi_head_tail.
nrom; case (phi_bounded (nhead M)); nrom; intros H1a H2a.
case (Zle_lt_or_eq _ _ H1a); intros H3a.
assert (Hms := phi_pos (ntail M)).
apply Z.lt_le_trans with (phi (nhead M) + wB * 0)%Z; auto with zarith.
generalize Hmm'; rewrite spec_mul; nrom.
rewrite <-H3a, Zmult_0_l, Zmod_0_l; auto with zarith.
simpl; auto with zarith.
Qed.

Fixpoint reduce_aux_num (n : nat) (t : number)  :=
  match n with
  |    O => t
  | S n1 =>
     match t with
     | nil    => t
     | a :: _ =>
         reduce_aux_num n1
            (shift_num (add_num t (scal_num (a * m') M)))
     end
  end.

Lemma reduce_aux_step a t :
  ((phi a + wB * [t] + phi (a * m') * [M]) / wB * wB =
   phi a + wB * [t] + phi (a * m') * [M])%Z.
Proof.
case (phi_bounded a); nrom; intros H1a H2a.
rewrite (phi_head_tail M); nrom.
set (m := nhead M); set (ms := ntail M).
replace (phi a + wB * [t] + phi (a * m') * (phi m + wB * [ms]))%Z
  with ((phi a + phi (a * m') * phi m) + ([t] +  phi (a * m') * [ms]) * wB)%Z;
  try ring.
rewrite Z_div_plus_full; auto with zarith.
set (v := (phi a + phi (a * m') * phi m)%Z).
assert (HH: (v / wB * wB = v)%Z).
rewrite (Z_div_mod_eq_full v wB); auto with zarith.
rewrite (Zmult_comm wB), Z_div_plus_full_l; auto with zarith.
assert (HH: (v mod wB = 0)%Z); auto with zarith.
unfold v; rewrite spec_mul; nrom.
rewrite Zplus_mod, Zmult_mod, Zmod_mod, <- Zmult_mod, <- Zmult_assoc,
        Zmult_mod.
unfold m.
generalize Hmm'; rewrite spec_mul; nrom; intros HH1; rewrite (Zmult_comm (phi m')), HH1.
rewrite (Zmult_mod (phi a mod wB)), Zmod_mod, <- Zmult_mod, <- Zplus_mod.
replace (phi a + phi a * (wB - 1))%Z with (phi a * wB)%Z; try ring.
rewrite Z_mod_mult; auto.
rewrite Zmult_plus_distr_l, HH, Zdiv_0_l, Zmult_0_l, <-HH,
        Zmult_comm, <- Z_div_mod_eq_full; auto with zarith.
rewrite Zmult_plus_distr_l, HH; unfold v.
nrom; ring.
Qed.

Lemma reduce_aux_correct n t :
  ([reduce_aux_num n t] * (Zpower_nat wB n) mod [M] = [t]  mod [M])%Z.
Proof.
generalize t; clear t.
induction n as [ | n Hrec]; intros t.
assert (HH := phi_pos t).
simpl reduce_aux_num; repeat rewrite Zpower_nat_0;
  repeat rewrite Zmult_1_r; auto.
repeat rewrite Zpower_nat_S.
simpl reduce_aux_num; case t.
nrom; rewrite Zmod_small, Zmult_0_l; auto with zarith.
rewrite Zmult_0_l; auto with zarith.
generalize M_pos; auto with zarith.
intros a t1.
rewrite (Zmult_comm wB), Zmult_assoc, Zmult_mod, Hrec,
        <- Zmult_mod, shift_correct, add_correct, scal_correct.
nrom.
rewrite reduce_aux_step, Zplus_mod, Z_mod_mult, Zplus_0_r, Zmod_mod; auto.
Qed.

Lemma reduce_aux_le n t :
  ([t] < [M] * (Zpower_nat wB n) -> [reduce_aux_num n t] < 2 * [M])%Z .
Proof.
intros Ht.
assert (HH: (exists U, [reduce_aux_num n t] * Zpower_nat wB n = [t] + U * [M]
                    /\ 0 <= U < Zpower_nat wB n)%Z).
generalize t; clear t Ht; induction n as [ | n Hrec]; intros t.
assert (HM := phi_pos M).
simpl reduce_aux_num; repeat rewrite Zpower_nat_0;
  repeat rewrite Zmult_1_r; auto with zarith.
exists 0%Z; auto with zarith.
repeat rewrite Zpower_nat_S.
assert (HH2 := Zpower_base_pos n).
simpl reduce_aux_num; case t; nrom.
exists 0%Z; split. auto with zarith.
split. auto with zarith. apply Zmult_lt_0_compat. 2: assumption.
red; auto.
intros a t1; nrom.
case (Hrec (shift_num (add_num (a :: t1) (scal_num (a * m') M)))).
intros U (H1U, H2U); exists (phi(a * m') + wB * U)%Z; split.
rewrite (Zmult_comm wB), Zmult_assoc, H1U,
         shift_correct, add_correct, scal_correct; nrom.
rewrite Zmult_plus_distr_l, reduce_aux_step; ring.
case (phi_bounded (a * m')); nrom; intros H1am H2am.
split. auto with zarith.
apply Z.lt_le_trans with (wB + wB * U)%Z. auto with zarith.
replace (wB * Zpower_nat wB n)%Z with
        (wB + wB * (Zpower_nat wB n - 1))%Z by ring; auto with zarith.
apply Zmult_gt_0_lt_reg_r with (1 := Z.lt_gt _ _ (Zpower_base_pos n)).
case HH; intros U (H1U, H2U).
rewrite H1U.
assert (U * [M] < [M] * Zpower_nat wB n)%Z.
rewrite Zmult_comm; apply Zmult_gt_0_lt_compat_l.
apply Z.lt_gt; apply M_pos.
auto with zarith.
replace (2 * [M] * Zpower_nat wB n)%Z with
       ([M] * Zpower_nat wB n + [M] * Zpower_nat wB n)%Z; auto with zarith;
  ring.
Qed.

Definition reduce_num (n : nat) (t : number) : number :=
  let res := reduce_aux_num n t in
  match cp_num res M with
  | Lt => res
  | _ => sub_num res M
  end.

Lemma reduce_correct n t :
  ([reduce_num n t] * (Zpower_nat wB n) mod [M] = [t]  mod [M])%Z.
Proof.
assert (H:= M_pos).
assert (HH:= reduce_aux_correct n t).
unfold reduce_num; case cp_spec; intros HH1; auto with zarith;
  rewrite sub_correct, Zmult_minus_distr_r; auto with zarith.
rewrite (Zmult_comm [M]); unfold Zminus.
rewrite Zopp_mult_distr_l, Z_mod_plus; auto with zarith.
rewrite (Zmult_comm [M]); unfold Zminus.
rewrite Zopp_mult_distr_l, Z_mod_plus; auto with zarith.
Qed.

Lemma reduce_bound n t :
  ([t] < [M] * (Zpower_nat wB n) ->
  0 <= [reduce_num n t] < [M])%Z.
Proof.
intros Ht; split.
apply phi_pos.
assert (HH := reduce_aux_le _ _ Ht).
unfold reduce_num; case cp_spec; intros HH1; auto with zarith;
  rewrite sub_correct; auto with zarith.
Qed.

Definition T n := reduce_num n (1%int31::nil).

Lemma Tn_correct n :
  ([T n] * (Zpower_nat wB n) mod [M] = 1 mod[M])%Z.
Proof.
unfold T; rewrite reduce_correct; nrom; nrom.
rewrite Zmult_0_r, Zplus_0_r; auto with zarith.
Qed.

Lemma eq_Tn_correct a b n :
  ((a * Zpower_nat wB n) mod [M] = (b * Zpower_nat wB n) mod [M] ->
    a mod [M] = b mod [M])%Z.
Proof.
intros H.
assert (HH: ((a - b) mod [M] = 0)%Z).
rewrite <- (Zmult_1_r (a - b)), Zmult_mod, <- (Tn_correct n),
        <- Zmult_mod, (Zmult_comm [T n]), Zmult_assoc,
        Zmult_minus_distr_r, Zmult_mod, Zminus_mod, H,
        <- Zminus_mod, <- Zmult_mod, Zminus_diag, Zmult_0_l,
        Zmod_0_l; auto.
replace a with (b + (a - b))%Z; try ring.
rewrite Zplus_mod, HH, Zplus_0_r, Zmod_mod; auto.
Qed.

Fixpoint reduce_amd_aux_num (n : nat) (t1 t2 res : number) {struct n} :=
  match n with
  | O    => add_num res (prod_num t1 t2)
  | S n1 =>
    match t1 with
    |     nil => reduce_aux_num n res
    | a :: t3 =>
      let res1 := add_num res (scal_num a t2) in
      match res1 with
      | nil    => reduce_amd_aux_num n1 t3 t2 nil
      | b :: _ =>
        reduce_amd_aux_num n1 t3 t2
            (shift_num (add_num res1 (scal_num (b * m') M)))
      end
    end
  end.

Lemma reduce_amd_aux_correct n t1 t2 res :
 (([reduce_amd_aux_num n t1 t2 res] * Zpower_nat wB n) mod [M] =
  ([t1] * [t2] + [res]) mod [M])%Z.
Proof.
generalize t1 t2 res; clear t1 t2 res.
induction n as [ |n1 Hrec]; intros t1 t2 res;
   unfold reduce_amd_aux_num; fold reduce_amd_aux_num.
rewrite Zpower_nat_0, Zmult_1_r, add_correct, prod_correct, Zplus_comm; auto.
destruct t1 as [ | a t3]; nrom.
rewrite Zmult_0_l, Zplus_0_l, reduce_aux_correct; auto.
set (v :=  add_num res (scal_num a t2)).
assert (Hv: [v] = ([res] + phi a * [t2])%Z).
unfold v; rewrite add_correct, scal_correct; auto.
generalize Hv; destruct v as [ | b v1]; nrom; clear Hv; intros Hv.
rewrite Zpower_nat_S, (Zmult_comm wB), Zmult_assoc, Zmult_mod, Hrec.
nrom; rewrite Zplus_0_r, <- Zmult_mod.
apply f_equal2 with (f := Z.modulo); auto.
rewrite <- Zminus_0_r, Hv; ring.
rewrite Zpower_nat_S, (Zmult_comm wB), Zmult_assoc, Zmult_mod, Hrec.
rewrite <- Zmult_mod, shift_correct, add_correct, scal_correct; nrom.
rewrite Zmult_plus_distr_l, reduce_aux_step.
rewrite Zplus_assoc, Z_mod_plus_full.
apply f_equal2 with (f := Z.modulo); auto.
rewrite Hv; ring.
Qed.

Lemma reduce_amd_aux_le n t1 t2 res :
  ([t1] < Zpower_nat wB n -> [t2] < [M] ->
  [res] <  2 * [M]  - 1 -> [reduce_amd_aux_num n t1 t2 res] < 2 * [M])%Z.
Proof.
generalize t1 t2 res; clear t1 t2 res.
induction n as [ |n1 Hrec]; intros t1 t2 res;
   unfold reduce_amd_aux_num; fold reduce_amd_aux_num.
rewrite Zpower_nat_0; intros H1t1 Ht2 Hres.
assert (H2t1 := phi_pos t1).
rewrite add_correct, prod_correct.
replace [t1] with 0%Z; auto with zarith.
destruct t1 as [ | a t3].
intros _ Ht2 Hres.
apply reduce_aux_le.
apply Z.lt_le_trans with (1 := Hres).
apply Z.le_trans with (2 * [M])%Z; auto with zarith.
rewrite Zmult_comm.
apply Zmult_le_compat_l.
apply Z.le_trans with wB; try (red; discriminate).
rewrite <- (Zmult_1_r wB) at 1; rewrite Zpower_nat_S.
apply Zmult_le_compat_l.
generalize (Zpower_base_pos n1); auto with zarith.
red; discriminate.
apply Zlt_le_weak; apply M_pos.
nrom; intros Ht3 Ht2 Hres.
set (v :=  add_num res (scal_num a t2)).
assert (Hv: [v] = ([res] + phi a * [t2])%Z).
unfold v; rewrite add_correct, scal_correct; auto.
generalize Hv; destruct v as [ | b v1]; nrom; clear Hv; intros Hv.
apply Hrec; auto with zarith.
apply Zmult_lt_reg_r with wB; auto with zarith; try (red; auto; fail).
repeat rewrite <- (Zmult_comm wB); apply Z.le_lt_trans with (2 := Ht3).
case (phi_bounded a); auto with zarith.
nrom; generalize M_pos; auto with zarith.
apply Hrec; auto with zarith.
apply Zmult_lt_reg_r with wB; auto with zarith; try (red; auto; fail).
repeat rewrite <- (Zmult_comm wB); apply Z.le_lt_trans with (2 := Ht3).
case (phi_bounded a); auto with zarith.
rewrite shift_correct, add_correct, scal_correct; nrom.
rewrite Hv.
apply Zdiv_lt_upper_bound; try (red; auto; fail); auto with zarith.
repeat apply Zplus_le_0_compat; repeat apply Zmult_le_0_compat;
  try apply phi_pos; try (red; discriminate).
case (phi_bounded a); nrom; intros H1a H2a.
case (phi_bounded (b * m')); nrom; intros H1bm H2bm.
apply Z.le_lt_trans with
  (((2 * [M] - 2) + (wB - 1) * ([M] - 1) + (wB - 1) * [M])%Z).
repeat apply Zplus_le_compat; auto with zarith.
apply Zmult_le_compat; auto with zarith.
apply phi_pos.
apply Zmult_le_compat; auto with zarith.
apply Zlt_le_weak; apply M_pos.
ring_simplify; auto with zarith.
Qed.

Definition reduce_mult_num (n: nat) (t1 t2 : number) :=
  let res := reduce_amd_aux_num n t1 t2 nil in
  match cp_num res M with
  | Lt => res
  | _ => sub_num res M
  end.

Lemma reduce_mult_correct n t1 t2 :
 ([reduce_mult_num n t1 t2] * (Zpower_nat wB n) mod [M] =
  ([t1] * [t2])  mod [M])%Z.
Proof.
assert (H:= M_pos).
generalize (reduce_amd_aux_correct n t1 t2 nil).
nrom; rewrite Zplus_0_r; intros HH.
unfold reduce_mult_num; case cp_spec; intros HH1; auto with zarith;
  rewrite sub_correct, Zmult_minus_distr_r; auto with zarith.
rewrite (Zmult_comm [M]); unfold Zminus.
rewrite Zopp_mult_distr_l, Z_mod_plus; auto with zarith.
rewrite (Zmult_comm [M]); unfold Zminus.
rewrite Zopp_mult_distr_l, Z_mod_plus; auto with zarith.
Qed.

Lemma reduce_mult_bound n t1 t2 :
  ([t1] < Zpower_nat wB n -> [t2] < [M] ->
  0 <= [reduce_mult_num n t1 t2] < [M])%Z.
Proof.
intros Ht1 Ht2; split.
apply phi_pos.
assert (Hres: ([nil] < 2 * [M] - 1)%Z).
  nrom; generalize M_pos; auto with zarith.
assert (HH := reduce_amd_aux_le _ _ _ _ Ht1 Ht2 Hres).
unfold reduce_mult_num; case cp_spec; intros HH1; auto with zarith;
  rewrite sub_correct; auto with zarith.
Qed.

Definition r_square n :=
 Z_to_num ((Zpower_nat wB  n * Zpower_nat wB n) mod [M]).

Lemma r_square_lt n : (0 <= [r_square n] < [M])%Z.
Proof.
unfold r_square.
rewrite num_phi; auto with zarith.
apply Z_mod_lt; auto with zarith.
apply Z.lt_gt; apply M_pos.
case (Z_mod_lt (Zpower_nat wB n * Zpower_nat wB n) [M]);
  auto with zarith.
apply Z.lt_gt; apply M_pos.
Qed.

Definition encode n z : number :=
  reduce_mult_num n (Z_to_num (z mod [M])) (r_square n).

Definition decode n m :=  [reduce_num n m].

Variable n : nat.

Hypothesis M_small : ([M] < Zpower_nat wB n)%Z.

Let HF0 := M_pos.
Let HF1:  (0 <= (Zpower_nat wB n * Zpower_nat wB n) mod [M])%Z.
Proof.
case (Z.mod_pos_bound (Zpower_nat wB n * Zpower_nat wB n) [M]); auto with zarith.
Qed.

Lemma reduce_bound_small t :
  (0 <= [t] < [M] -> 0 <= [reduce_num n t] < [M])%Z.
Proof.
intros Ht; apply reduce_bound.
case Ht; intros _ Ht1; apply Z.lt_le_trans with (1 := Ht1).
rewrite <-(Zmult_1_r [M]) at 1.
apply Zmult_le_compat_l; auto with zarith.
Qed.

Hint Resolve reduce_bound_small add_mod_bound sub_mod_bound : core.

Lemma reduce_mult_bound_small t1 t2 :
  (0 <= [t1] < [M] -> 0 <= [t2] < [M] ->
   0 <= [reduce_mult_num n t1 t2] < [M])%Z.
Proof.
intros Ht1 Ht2; apply reduce_mult_bound; auto with zarith.
Qed.

Hint Resolve reduce_mult_bound_small : core.

Lemma encode_correct z :
  (0 <= z < [M] -> [encode n z] = (z * Zpower_nat wB n) mod [M])%Z.
Proof.
intros Hz.
unfold encode; rewrite Zmod_small; auto with zarith.
rewrite <-(Zmod_small _ [M]); auto with zarith.
apply (eq_Tn_correct _ _ n).
rewrite reduce_mult_correct.
unfold r_square.
rewrite !num_phi; auto with zarith.
rewrite Zmult_mod, Zmod_mod, <-Zmult_mod, Zmult_assoc; auto with zarith.
apply reduce_mult_bound_small; auto with zarith.
rewrite num_phi; auto with zarith.
unfold r_square.
rewrite num_phi; auto with zarith.
apply Z_mod_lt; auto with zarith.
Qed.

Lemma encode_bound z :
  (0 <= z < [M] -> 0 <= [encode n z] < [M])%Z.
Proof.
intros Hz.
rewrite encode_correct; auto with zarith.
apply Z_mod_lt; auto with zarith.
Qed.

Hint Resolve encode_bound : core.

Lemma decode_encode p :
  (0 <= p < [M])%Z -> decode n (encode n p) = p.
Proof.
intros Hp.
unfold decode, encode.
assert (F1 : (0 <= [Z_to_num (p mod [M])] < [M])%Z).
  rewrite num_phi; auto with zarith.
  rewrite Zmod_small; auto with zarith.
  case (Z.mod_pos_bound p [M]); auto with zarith.
assert (F2: ([Z_to_num (p mod [M])] < Zpower_nat wB n)%Z).
  apply (Z.lt_trans _ [M]); auto with zarith.
assert (F3: ([r_square n] < [M])%Z).
  case (r_square_lt n); auto.
generalize (reduce_mult_bound _ _ _ F2 F3); intros F4.
rewrite <-(Zmod_small p [M]); auto with zarith.
rewrite <-(Zmod_small _ [M]).
apply (eq_Tn_correct _ _ n).
rewrite reduce_correct.
apply (eq_Tn_correct _ _ n).
rewrite reduce_mult_correct.
unfold r_square.
rewrite !num_phi; auto with zarith.
rewrite Zmod_mod, <-Zmult_mod, Zmult_assoc; auto.
case (Z.mod_pos_bound (Zpower_nat wB n * Zpower_nat wB n) [M]);
  auto with zarith.
case (Z.mod_pos_bound (p mod [M]) [M]); auto with zarith.
case (Z.mod_pos_bound p [M]); auto with zarith.
intros; apply reduce_bound_small.
rewrite Zmod_mod; auto with zarith.
Qed.

Lemma decode_encode_add p1 p2 :
  (0 <= p1 < [M])%Z -> (0 <= p2 < [M])%Z ->
  decode n (add_mod M (encode n p1) (encode n p2)) = ((p1 + p2) mod [M])%Z.
Proof.
intros Hp1 Hp2.
rewrite <-(Zmod_small _ [M]).
apply (eq_Tn_correct _ _ n).
unfold decode; rewrite reduce_correct.
rewrite add_mod_correct; auto with zarith.
rewrite !encode_correct; auto with zarith.
rewrite <-Zplus_mod, Zmod_mod, Zmult_plus_distr_l; auto with zarith.
unfold decode; auto with zarith.
Qed.

Lemma decode_encode_sub p1 p2 :
  (0 <= p1 < [M])%Z -> (0 <= p2 < [M])%Z ->
  decode n (sub_mod M (encode n p1) (encode n p2)) = ((p1 - p2) mod [M])%Z.
Proof.
intros Hp1 Hp2.
rewrite <-(Zmod_small _ [M]).
apply (eq_Tn_correct _ _ n).
unfold decode; rewrite reduce_correct.
rewrite sub_mod_correct; auto with zarith.
rewrite !encode_correct; auto with zarith.
rewrite <-Zminus_mod, Zmod_mod, Zmult_minus_distr_r; auto with zarith.
unfold decode; auto with zarith.
Qed.

Lemma decode_encode_mult p1 p2 :
  (0 <= p1 < [M])%Z -> (0 <= p2 < [M])%Z ->
  decode n (reduce_mult_num n (encode n p1) (encode n p2))
     = ((p1 * p2) mod [M])%Z.
Proof.
intros Hp1 Hp2.
rewrite <-(Zmod_small _ [M]).
apply (eq_Tn_correct _ _ n).
unfold decode; rewrite reduce_correct.
apply (eq_Tn_correct _ _ n).
rewrite reduce_mult_correct.
rewrite !encode_correct by auto with zarith.
rewrite <-Zmult_mod. apply f_equal2 with (f := Z.modulo).
ring.
reflexivity.
unfold decode; auto with zarith.
Qed.

End Reduce.


From Hammer Require Import Hammer.

Require Import ZArith_base.
Require Import ZArithRing.
Require Import Zcomplements.
Require Import Zdiv.
Require Import Wf_nat.

Open Scope Z_scope.

Definition Zdivide_intro a b q (H:b=q*a) : Z.divide a b := ex_intro _ q H.

Lemma Zdivide_opp_r a b : (a | b) -> (a | - b).
Proof. hammer_hook "Znumtheory" "Znumtheory.Zdivide_opp_r".   apply Z.divide_opp_r. Qed.

Lemma Zdivide_opp_r_rev a b : (a | - b) -> (a | b).
Proof. hammer_hook "Znumtheory" "Znumtheory.Zdivide_opp_r_rev".   apply Z.divide_opp_r. Qed.

Lemma Zdivide_opp_l a b : (a | b) -> (- a | b).
Proof. hammer_hook "Znumtheory" "Znumtheory.Zdivide_opp_l".   apply Z.divide_opp_l. Qed.

Lemma Zdivide_opp_l_rev a b : (- a | b) -> (a | b).
Proof. hammer_hook "Znumtheory" "Znumtheory.Zdivide_opp_l_rev".   apply Z.divide_opp_l. Qed.

Theorem Zdivide_Zabs_l a b : (Z.abs a | b) -> (a | b).
Proof. hammer_hook "Znumtheory" "Znumtheory.Zdivide_Zabs_l".   apply Z.divide_abs_l. Qed.

Theorem Zdivide_Zabs_inv_l a b : (a | b) -> (Z.abs a | b).
Proof. hammer_hook "Znumtheory" "Znumtheory.Zdivide_Zabs_inv_l".   apply Z.divide_abs_l. Qed.

Hint Resolve Z.divide_refl Z.divide_1_l Z.divide_0_r: zarith.
Hint Resolve Z.mul_divide_mono_l Z.mul_divide_mono_r: zarith.
Hint Resolve Z.divide_add_r Zdivide_opp_r Zdivide_opp_r_rev Zdivide_opp_l
Zdivide_opp_l_rev Z.divide_sub_r Z.divide_mul_l Z.divide_mul_r
Z.divide_factor_l Z.divide_factor_r: zarith.

Lemma Zmult_one x y : x >= 0 -> x * y = 1 -> x = 1.
Proof. hammer_hook "Znumtheory" "Znumtheory.Zmult_one".
Z.swap_greater. apply Z.eq_mul_1_nonneg.
Qed.

Lemma Zdivide_bounds a b : (a | b) -> b <> 0 -> Z.abs a <= Z.abs b.
Proof. hammer_hook "Znumtheory" "Znumtheory.Zdivide_bounds".
intros H Hb.
rewrite <- Z.divide_abs_l, <- Z.divide_abs_r in H.
apply Z.abs_pos in Hb.
now apply Z.divide_pos_le.
Qed.

Lemma Zmod_divide : forall a b, b<>0 -> a mod b = 0 -> (b | a).
Proof. hammer_hook "Znumtheory" "Znumtheory.Zmod_divide".
apply Z.mod_divide.
Qed.

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

Lemma Zdivide_dec a b : {(a | b)} + {~ (a | b)}.
Proof. hammer_hook "Znumtheory" "Znumtheory.Zdivide_dec".
destruct (Z.eq_dec a 0) as [Ha|Ha].
destruct (Z.eq_dec b 0) as [Hb|Hb].
left; subst; apply Z.divide_0_r.
right. subst. contradict Hb. now apply Z.divide_0_l.
destruct (Z.eq_dec (b mod a) 0).
left. now apply Z.mod_divide.
right. now rewrite <- Z.mod_divide.
Defined.

Theorem Zdivide_Zdiv_eq a b : 0 < a -> (a | b) ->  b = a * (b / a).
Proof. hammer_hook "Znumtheory" "Znumtheory.Zdivide_Zdiv_eq".
intros Ha H.
rewrite (Z.div_mod b a) at 1; auto with zarith.
rewrite Zdivide_mod; auto with zarith.
Qed.

Theorem Zdivide_Zdiv_eq_2 a b c :
0 < a -> (a | b) -> (c * b) / a = c * (b / a).
Proof. hammer_hook "Znumtheory" "Znumtheory.Zdivide_Zdiv_eq_2".
intros. apply Z.divide_div_mul_exact; auto with zarith.
Qed.

Theorem Zdivide_le: forall a b : Z,
0 <= a -> 0 < b -> (a | b) ->  a <= b.
Proof. hammer_hook "Znumtheory" "Znumtheory.Zdivide_le".
intros. now apply Z.divide_pos_le.
Qed.

Theorem Zdivide_Zdiv_lt_pos a b :
1 < a -> 0 < b -> (a | b) ->  0 < b / a < b .
Proof. hammer_hook "Znumtheory" "Znumtheory.Zdivide_Zdiv_lt_pos".
intros H1 H2 H3; split.
apply Z.mul_pos_cancel_l with a; auto with zarith.
rewrite <- Zdivide_Zdiv_eq; auto with zarith.
now apply Z.div_lt.
Qed.

Lemma Zmod_div_mod n m a:
0 < n -> 0 < m -> (n | m) -> a mod n = (a mod m) mod n.
Proof. hammer_hook "Znumtheory" "Znumtheory.Zmod_div_mod".
intros H1 H2 (p,Hp).
rewrite (Z.div_mod a m) at 1; auto with zarith.
rewrite Hp at 1.
rewrite Z.mul_shuffle0, Z.add_comm, Z.mod_add; auto with zarith.
Qed.

Lemma Zmod_divide_minus a b c:
0 < b -> a mod b = c -> (b | a - c).
Proof. hammer_hook "Znumtheory" "Znumtheory.Zmod_divide_minus".
intros H H1. apply Z.mod_divide; auto with zarith.
rewrite Zminus_mod; auto with zarith.
rewrite H1. rewrite <- (Z.mod_small c b) at 1.
rewrite Z.sub_diag, Z.mod_0_l; auto with zarith.
subst. now apply Z.mod_pos_bound.
Qed.

Lemma Zdivide_mod_minus a b c:
0 <= c < b -> (b | a - c) -> a mod b = c.
Proof. hammer_hook "Znumtheory" "Znumtheory.Zdivide_mod_minus".
intros (H1, H2) H3.
assert (0 < b) by Z.order.
replace a with ((a - c) + c); auto with zarith.
rewrite Z.add_mod; auto with zarith.
rewrite (Zdivide_mod (a-c) b); try rewrite Z.add_0_l; auto with zarith.
rewrite Z.mod_mod; try apply Zmod_small; auto with zarith.
Qed.

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

Lemma Zis_gcd_sym : forall a b d, Zis_gcd a b d -> Zis_gcd b a d.
Proof. hammer_hook "Znumtheory" "Znumtheory.Zis_gcd_sym".
induction 1; constructor; intuition.
Qed.

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

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

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

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

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

Lemma Zis_gcd_0_abs a : Zis_gcd 0 a (Z.abs a).
Proof. hammer_hook "Znumtheory" "Znumtheory.Zis_gcd_0_abs".
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. hammer_hook "Znumtheory" "Znumtheory.Zis_gcd_unique".
intros a b c d [Hc1 Hc2 Hc3] [Hd1 Hd2 Hd3].
assert (c|d) by auto.
assert (d|c) by auto.
apply Z.divide_antisym; auto.
Qed.

Lemma Zis_gcd_for_euclid :
forall a b d q:Z, Zis_gcd b (a - q * b) d -> Zis_gcd a b d.
Proof. hammer_hook "Znumtheory" "Znumtheory.Zis_gcd_for_euclid".
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. hammer_hook "Znumtheory" "Znumtheory.Zis_gcd_for_euclid2".
simple induction 1; constructor; intuition.
apply H2; auto.
replace r with (b * q + r - b * q). auto with zarith. ring.
Qed.

Section extended_euclid_algorithm.

Variables a b : Z.

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

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. hammer_hook "Znumtheory" "Znumtheory.euclid_rec".
intros v3 Hv3; generalize Hv3; pattern v3.
apply Zlt_0_rec.
clear v3 Hv3; intros.
destruct (Z_zerop x) as [Heq|Hneq].
apply Euclid_intro with (u := u1) (v := u2) (d := u3).
assumption.
apply H3.
rewrite Heq; 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.
intro eq; pattern u3 at 2; 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.

Lemma euclid : Euclid.
Proof. hammer_hook "Znumtheory" "Znumtheory.euclid".
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. hammer_hook "Znumtheory" "Znumtheory.Zis_gcd_uniqueness_apart_sign".
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 (Z.divide_antisym d d' Hdd' Hd'd).
Qed.

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

Lemma Zis_gcd_bezout : forall a b d:Z, Zis_gcd a b d -> Bezout a b d.
Proof. hammer_hook "Znumtheory" "Znumtheory.Zis_gcd_bezout".
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.

Lemma Zis_gcd_mult :
forall a b c d:Z, Zis_gcd a b d -> Zis_gcd (c * a) (c * b) (c * d).
Proof. hammer_hook "Znumtheory" "Znumtheory.Zis_gcd_mult".
intros a b c d; simple induction 1. constructor; auto with zarith.
intros x Ha Hb.
elim (Zis_gcd_bezout a b d H). intros u v Huv.
elim Ha; intros a' Ha'.
elim Hb; intros b' Hb'.
apply Zdivide_intro with (u * a' + v * b').
rewrite <- Huv.
replace (c * (u * a + v * b)) with (u * (c * a) + v * (c * b)).
rewrite Ha'; rewrite Hb'; ring.
ring.
Qed.

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

Lemma rel_prime_bezout : forall a b:Z, rel_prime a b -> Bezout a b 1.
Proof. hammer_hook "Znumtheory" "Znumtheory.rel_prime_bezout".
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. hammer_hook "Znumtheory" "Znumtheory.bezout_rel_prime".
simple induction 1; constructor; auto with zarith.
intros. rewrite <- H0; auto with zarith.
Qed.

Theorem Gauss : forall a b c:Z, (a | b * c) -> rel_prime a b -> (a | c).
Proof. hammer_hook "Znumtheory" "Znumtheory.Gauss".
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.

Lemma rel_prime_mult :
forall a b c:Z, rel_prime a b -> rel_prime a c -> rel_prime a (b * c).
Proof. hammer_hook "Znumtheory" "Znumtheory.rel_prime_mult".
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. hammer_hook "Znumtheory" "Znumtheory.rel_prime_cross_prod".
intros a b c d; intros.
elim (Z.divide_antisym b d).
split; auto with zarith.
rewrite H4 in H3.
rewrite Z.mul_comm in H3.
apply Z.mul_reg_l with d; auto with zarith.
intros; omega.
apply Gauss with a.
rewrite H3.
auto with zarith.
red; auto with zarith.
apply Gauss with c.
rewrite Z.mul_comm.
rewrite <- H3.
auto with zarith.
red; auto with zarith.
Qed.

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. hammer_hook "Znumtheory" "Znumtheory.Zis_gcd_rel_prime".
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.
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)) as (x',Hx').
exists xa; rewrite Z.mul_assoc; rewrite <- H5; auto.
exists xb; rewrite Z.mul_assoc; rewrite <- H6; auto.
replace g with (1*g) in Hx'; auto with zarith.
do 2 rewrite Z.mul_assoc in Hx'.
apply Z.mul_reg_r in Hx'; trivial.
rewrite Z.mul_1_r in Hx'.
exists x'; auto with zarith.
Qed.

Theorem rel_prime_sym: forall a b, rel_prime a b -> rel_prime b a.
Proof. hammer_hook "Znumtheory" "Znumtheory.rel_prime_sym".
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. hammer_hook "Znumtheory" "Znumtheory.rel_prime_div".
intros p q r H (u, H1); subst.
inversion_clear H as [H1 H2 H3].
red; apply Zis_gcd_intro; try apply Z.divide_1_l.
intros x H4 H5; apply H3; auto.
apply Z.divide_mul_r; auto.
Qed.

Theorem rel_prime_1: forall n, rel_prime 1 n.
Proof. hammer_hook "Znumtheory" "Znumtheory.rel_prime_1".
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. hammer_hook "Znumtheory" "Znumtheory.not_rel_prime_0".
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. hammer_hook "Znumtheory" "Znumtheory.rel_prime_mod".
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. hammer_hook "Znumtheory" "Znumtheory.rel_prime_mod_rev".
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. hammer_hook "Znumtheory" "Znumtheory.Zrel_prime_neq_mod_0".
intros a b H H1 H2.
case (not_rel_prime_0 _ H).
rewrite <- H2.
apply rel_prime_mod; auto with zarith.
Qed.

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

Lemma prime_divisors :
forall p:Z,
prime p -> forall a:Z, (a | p) -> a = -1 \/ a = 1 \/ a = p \/ a = - p.
Proof. hammer_hook "Znumtheory" "Znumtheory.prime_divisors".
destruct 1; intros.
assert
(a = - p \/ - p < a < -1 \/ a = -1 \/ a = 0 \/ a = 1 \/ 1 < a < p \/ a = p).
{ assert (Z.abs a <= Z.abs p) as H2.
apply Zdivide_bounds; [ assumption | omega ].
revert H2.
pattern (Z.abs a); apply Zabs_ind; pattern (Z.abs p); apply Zabs_ind;
intros; omega. }
intuition idtac.

- absurd (rel_prime (- a) p); intuition.
inversion H2.
assert (- a | - a) by auto with zarith.
assert (- a | p) by auto with zarith.
apply H7, Z.divide_1_r in H8; intuition.

- inversion H1. subst a; omega.

- absurd (rel_prime a p); intuition.
inversion H2.
assert (a | a) by auto with zarith.
assert (a | p) by auto with zarith.
apply H7, Z.divide_1_r in H8; intuition.
Qed.

Lemma prime_rel_prime :
forall p:Z, prime p -> forall a:Z, ~ (p | a) -> rel_prime p a.
Proof. hammer_hook "Znumtheory" "Znumtheory.prime_rel_prime".
intros; constructor; intros; auto with zarith.
apply prime_divisors in H1; intuition; subst; auto with zarith.
- absurd (p | a); auto with zarith.
- absurd (p | a); intuition.
Qed.

Hint Resolve prime_rel_prime: zarith.

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

Lemma prime_mult :
forall p:Z, prime p -> forall a b:Z, (p | a * b) -> (p | a) \/ (p | b).
Proof. hammer_hook "Znumtheory" "Znumtheory.prime_mult".
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. hammer_hook "Znumtheory" "Znumtheory.not_prime_0".
intros H1; case (prime_divisors _ H1 2); auto with zarith.
Qed.

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

Lemma prime_2: prime 2.
Proof. hammer_hook "Znumtheory" "Znumtheory.prime_2".
apply prime_intro; auto with zarith.
intros n (H,H'); Z.le_elim H; auto with zarith.
- contradict H'; auto with zarith.
- subst n. constructor; auto with zarith.
Qed.

Theorem prime_3: prime 3.
Proof. hammer_hook "Znumtheory" "Znumtheory.prime_3".
apply prime_intro; auto with zarith.
intros n (H,H'); Z.le_elim H; auto with zarith.
- replace n with 2 by omega.
constructor; auto with zarith.
intros x (q,Hq) (q',Hq').
exists (q' - q). ring_simplify. now rewrite <- Hq, <- Hq'.
- replace n with 1 by trivial.
constructor; auto with zarith.
Qed.

Theorem prime_ge_2 p : prime p ->  2 <= p.
Proof. hammer_hook "Znumtheory" "Znumtheory.prime_ge_2".
intros (Hp,_); auto with zarith.
Qed.

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

Lemma Z_0_1_more x : 0<=x -> x=0 \/ x=1 \/ 1<x.
Proof. hammer_hook "Znumtheory" "Znumtheory.Z_0_1_more".
intros H. Z.le_elim H; auto.
apply Z.le_succ_l in H. change (1 <= x) in H. Z.le_elim H; auto.
Qed.

Theorem prime_alt p : prime' p <-> prime p.
Proof. hammer_hook "Znumtheory" "Znumtheory.prime_alt".
split; intros (Hp,H).
-
constructor; trivial; intros n Hn.
constructor; auto with zarith; intros x Hxn Hxp.
rewrite <- Z.divide_abs_l in Hxn, Hxp |- *.
assert (Hx := Z.abs_nonneg x).
set (y:=Z.abs x) in *; clearbody y; clear x; rename y into x.
destruct (Z_0_1_more x Hx) as [->|[->|Hx']].
+ exfalso. apply Z.divide_0_l in Hxn. omega.
+ now exists 1.
+ elim (H x); auto.
split; trivial.
apply Z.le_lt_trans with n; auto with zarith.
apply Z.divide_pos_le; auto with zarith.
-
constructor; trivial. intros n Hn Hnp.
case (Zis_gcd_unique n p n 1); auto with zarith.
constructor; auto with zarith.
apply H; auto with zarith.
Qed.

Theorem square_not_prime: forall a, ~ prime (a * a).
Proof. hammer_hook "Znumtheory" "Znumtheory.square_not_prime".
intros a Ha.
rewrite <- (Z.abs_square a) in Ha.
assert (H:=Z.abs_nonneg a).
set (b:=Z.abs a) in *; clearbody b; clear a; rename b into a.
rewrite <- prime_alt in Ha; destruct Ha as (Ha,Ha').
assert (H' : 1 < a) by now apply (Z.square_lt_simpl_nonneg 1).
apply (Ha' a).
+ split; trivial.
rewrite <- (Z.mul_1_l a) at 1. apply Z.mul_lt_mono_pos_r; omega.
+ exists a; auto.
Qed.

Theorem prime_div_prime: forall p q,
prime p -> prime q -> (p | q) -> p = q.
Proof. hammer_hook "Znumtheory" "Znumtheory.prime_div_prime".
intros p q H H1 H2;
assert (Hp: 0 < p); try apply Z.lt_le_trans with 2; try apply prime_ge_2; auto with zarith.
assert (Hq: 0 < q); try apply Z.lt_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.

Lemma Zgcd_is_gcd : forall a b, Zis_gcd a b (Z.gcd a b).
Proof. hammer_hook "Znumtheory" "Znumtheory.Zgcd_is_gcd".
constructor.
apply Z.gcd_divide_l.
apply Z.gcd_divide_r.
apply Z.gcd_greatest.
Qed.

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

Theorem Zdivide_Zgcd: forall p q r : Z,
(p | q) -> (p | r) -> (p | Z.gcd q r).
Proof. hammer_hook "Znumtheory" "Znumtheory.Zdivide_Zgcd".
intros. now apply Z.gcd_greatest.
Qed.

Theorem Zis_gcd_gcd: forall a b c : Z,
0 <= c ->  Zis_gcd a b c -> Z.gcd a b = c.
Proof. hammer_hook "Znumtheory" "Znumtheory.Zis_gcd_gcd".
intros a b c H1 H2.
case (Zis_gcd_uniqueness_apart_sign a b c (Z.gcd a b)); auto.
apply Zgcd_is_gcd; auto.
Z.le_elim H1.
- generalize (Z.gcd_nonneg a b); auto with zarith.
- subst. now case (Z.gcd a b).
Qed.

Theorem Zgcd_div_swap0 : forall a b : Z,
0 < Z.gcd a b ->
0 < b ->
(a / Z.gcd a b) * b = a * (b/Z.gcd a b).
Proof. hammer_hook "Znumtheory" "Znumtheory.Zgcd_div_swap0".
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 (Z.gcd a b) b); auto.
repeat rewrite Z.mul_assoc; f_equal.
rewrite Z.mul_comm.
rewrite <- Zdivide_Zdiv_eq; auto.
Qed.

Theorem Zgcd_div_swap : forall a b c : Z,
0 < Z.gcd a b ->
0 < b ->
(c * a) / Z.gcd a b * b = c * a * (b/Z.gcd a b).
Proof. hammer_hook "Znumtheory" "Znumtheory.Zgcd_div_swap".
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 (Z.gcd a b) b); auto.
repeat rewrite Z.mul_assoc; f_equal.
rewrite Zdivide_Zdiv_eq_2; auto.
repeat rewrite <- Z.mul_assoc; f_equal.
rewrite Z.mul_comm.
rewrite <- Zdivide_Zdiv_eq; auto.
Qed.

Lemma Zgcd_ass a b c : Z.gcd (Z.gcd a b) c = Z.gcd a (Z.gcd b c).
Proof. hammer_hook "Znumtheory" "Znumtheory.Zgcd_ass".
symmetry. apply Z.gcd_assoc.
Qed.

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

Definition rel_prime_dec: forall a b,
{ rel_prime a b }+{ ~ rel_prime a b }.
Proof. hammer_hook "Znumtheory" "Znumtheory.rel_prime_dec".
intros a b; case (Z.eq_dec (Z.gcd 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. hammer_hook "Znumtheory" "Znumtheory.prime_dec_aux".
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].
rewrite Z.lt_succ_r in HH2.
Z.le_elim HH2; subst; auto with zarith.
- 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. hammer_hook "Znumtheory" "Znumtheory.prime_dec".
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). Z.le_elim Hn1; auto; subst n.
constructor; 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. hammer_hook "Znumtheory" "Znumtheory.not_prime_divide".
intros p Hp Hp1.
case (prime_dec_aux p p); intros H1.
- elim Hp1; constructor; auto.
intros n (Hn1,Hn2).
Z.le_elim Hn1; auto with zarith.
subst n; constructor; auto with zarith.
- case H1; intros n (Hn1,Hn2).
destruct (Z_0_1_more _ (Z.gcd_nonneg n p)) as [H|[H|H]].
+ exfalso. apply Z.gcd_eq_0_l in H. omega.
+ elim Hn2. red. rewrite <- H. apply Zgcd_is_gcd.
+ exists (Z.gcd n p); split; [ split; auto | apply Z.gcd_divide_r ].
apply Z.le_lt_trans with n; auto with zarith.
apply Z.divide_pos_le; auto with zarith.
apply Z.gcd_divide_l.
Qed.


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

Require Import Relations Setoid SetoidList List Multiset PermutSetoid Permutation.

Set Implicit Arguments.

(** This file is similar to [PermutSetoid], except that the equality used here
    is Coq usual one instead of a setoid equality. In particular, we can then
    prove the equivalence between [List.Permutation] and
    [Permutation.permutation].
*)

Section Perm.

  Variable A : Type.
  Hypothesis eq_dec : forall x y:A, {x=y} + {~ x=y}.

  Notation permutation := (permutation _ eq_dec).
  Notation list_contents := (list_contents _ eq_dec).

  (** we can use [multiplicity] to define [In] and [NoDup]. *)

  Lemma multiplicity_In :
    forall l a, In a l <-> 0 < multiplicity (list_contents l) a.
  Proof.
    intros; split; intro H.
    eapply In_InA, multiplicity_InA in H; eauto with typeclass_instances.
    eapply multiplicity_InA, InA_alt in H as (y & -> & H); eauto with typeclass_instances.
  Qed.

  Lemma multiplicity_In_O :
    forall l a, ~ In a l -> multiplicity (list_contents l) a = 0.
  Proof.
    intros l a; rewrite multiplicity_In;
      destruct (multiplicity (list_contents l) a); auto.
    destruct 1; auto with arith.
  Qed.

  Lemma multiplicity_In_S :
    forall l a, In a l -> multiplicity (list_contents l) a >= 1.
  Proof.
    intros l a; rewrite multiplicity_In; auto.
  Qed.

  Lemma multiplicity_NoDup :
    forall l, NoDup l <-> (forall a, multiplicity (list_contents l) a <= 1).
  Proof.
    induction l.
    simpl.
    split; auto with arith.
    intros; apply NoDup_nil.
    split; simpl.
    inversion_clear 1.
    rewrite IHl in H1.
    intros; destruct (eq_dec a a0) as [H2|H2]; simpl; auto.
    subst a0.
    rewrite multiplicity_In_O; auto.
    intros; constructor.
    rewrite multiplicity_In.
    generalize (H a).
    destruct (eq_dec a a) as [H0|H0].
    destruct (multiplicity (list_contents l) a); auto with arith.
    simpl; inversion 1.
    inversion H3.
    destruct H0; auto.
    rewrite IHl; intros.
    generalize (H a0); auto with arith.
    destruct (eq_dec a a0); simpl; auto with arith.
  Qed.

  Lemma NoDup_permut :
    forall l l', NoDup l -> NoDup l' ->
      (forall x, In x l <-> In x l') -> permutation l l'.
  Proof.
    intros.
    red; unfold meq; intros.
    rewrite multiplicity_NoDup in H, H0.
    generalize (H a) (H0 a) (H1 a); clear H H0 H1.
    do 2 rewrite multiplicity_In.
    destruct 3; omega.
  Qed.

  (** Permutation is compatible with In. *)
  Lemma permut_In_In :
    forall l1 l2 e, permutation l1 l2 -> In e l1 -> In e l2.
  Proof.
    unfold PermutSetoid.permutation, meq; intros l1 l2 e P IN.
    generalize (P e); clear P.
    destruct (In_dec eq_dec e l2) as [H|H]; auto.
    rewrite (multiplicity_In_O _ _ H).
    intros.
    generalize (multiplicity_In_S _ _ IN).
    rewrite H0.
    inversion 1.
  Qed.

  Lemma permut_cons_In :
    forall l1 l2 e, permutation (e :: l1) l2 -> In e l2.
  Proof.
    intros; eapply permut_In_In; eauto.
    red; auto.
  Qed.

  (** Permutation of an empty list. *)
  Lemma permut_nil :
    forall l, permutation l nil -> l = nil.
  Proof.
    intro l; destruct l as [ | e l ]; trivial.
    assert (In e (e::l)) by (red; auto).
    intro Abs; generalize (permut_In_In _ Abs H).
    inversion 1.
  Qed.

  (** When used with [eq], this permutation notion is equivalent to
      the one defined in [List.v]. *)

  Lemma permutation_Permutation :
    forall l l', Permutation l l' <-> permutation l l'.
  Proof.
    split.
    induction 1.
    apply permut_refl.
    apply permut_cons; auto.
    change (permutation (y::x::l) ((x::nil)++y::l)).
    apply permut_add_cons_inside; simpl; apply permut_refl.
    apply permut_trans with l'; auto.
    revert l'.
    induction l.
    intros.
    rewrite (permut_nil (permut_sym H)).
    apply Permutation_refl.
    intros.
    destruct (In_split _ _ (permut_cons_In H)) as (h2,(t2,H1)).
    subst l'.
    apply Permutation_cons_app.
    apply IHl.
    apply permut_remove_hd with a; auto with typeclass_instances.
  Qed.

  (** Permutation for short lists. *)

  Lemma permut_length_1:
    forall a b, permutation (a :: nil) (b :: nil)  -> a=b.
  Proof.
    intros a b; unfold PermutSetoid.permutation, meq; intro P;
      generalize (P b); clear P; simpl.
    destruct (eq_dec b b) as [H|H]; [ | destruct H; auto].
    destruct (eq_dec a b); simpl; auto; intros; discriminate.
  Qed.

  Lemma permut_length_2 :
    forall a1 b1 a2 b2, permutation (a1 :: b1 :: nil) (a2 :: b2 :: nil) ->
      (a1=a2) /\ (b1=b2) \/ (a1=b2) /\ (a2=b1).
  Proof.
    intros a1 b1 a2 b2 P.
    assert (H:=permut_cons_In P).
    inversion_clear H.
    left; split; auto.
    apply permut_length_1.
    red; red; intros.
    generalize (P a); clear P; simpl.
    destruct (eq_dec a1 a) as [H2|H2];
      destruct (eq_dec a2 a) as [H3|H3]; auto.
    destruct H3; transitivity a1; auto.
    destruct H2; transitivity a2; auto.
    right.
    inversion_clear H0; [|inversion H].
    split; auto.
    apply permut_length_1.
    red; red; intros.
    generalize (P a); clear P; simpl.
    destruct (eq_dec a1 a) as [H2|H2];
      destruct (eq_dec b2 a) as [H3|H3]; auto.
    simpl; rewrite <- plus_n_Sm; inversion 1; auto.
    destruct H3; transitivity a1; auto.
    destruct H2; transitivity b2; auto.
  Qed.

  (** Permutation is compatible with length. *)
  Lemma permut_length :
    forall l1 l2, permutation l1 l2 -> length l1 = length l2.
  Proof.
    induction l1; intros l2 H.
    rewrite (permut_nil (permut_sym H)); auto.
    destruct (In_split _ _ (permut_cons_In H)) as (h2,(t2,H1)).
    subst l2.
    rewrite app_length.
    simpl; rewrite <- plus_n_Sm; f_equal.
    rewrite <- app_length.
    apply IHl1.
    apply permut_remove_hd with a; auto with typeclass_instances.
  Qed.

  Variable B : Type.
  Variable eqB_dec : forall x y:B, { x=y }+{ ~x=y }.

  (** Permutation is compatible with map. *)

  Lemma permutation_map :
    forall f l1 l2, permutation l1 l2 ->
      PermutSetoid.permutation _ eqB_dec (map f l1) (map f l2).
  Proof.
    intros f; induction l1.
    intros l2 P; rewrite (permut_nil (permut_sym P)); apply permut_refl.
    intros l2 P.
    simpl.
    destruct (In_split _ _ (permut_cons_In P)) as (h2,(t2,H1)).
    subst l2.
    rewrite map_app.
    simpl.
    apply permut_add_cons_inside.
    rewrite <- map_app.
    apply IHl1; auto.
    apply permut_remove_hd with a; auto with typeclass_instances.
  Qed.

End Perm.