(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(** * PrimeLib.v : Extension to the library of Coq about integers *)

Require Import CCMisc.
Require Export Znumtheory.
Require Import Arith Even Div2.
Require Import Arith.Euclid.

(** Zdivide *)

Lemma Zle_lt : forall a, a <> 0 -> 0 <= a -> 0 < a.
Proof.
 intros; omega.
Qed.

Lemma Zdivide_Zdiv_eq_full : forall a b,
 a <> 0 -> (a | b) -> b = a * (b / a).
Proof.
 intros.
 apply Z_div_exact_full_2; trivial.
 destruct H0; rewrite H0.
 apply Z_div_exact_full_1.
 rewrite Z_div_mult_full; trivial.
 rewrite Zmult_comm; trivial.
Qed.

Lemma bezout_identity : forall a b,
 Zis_gcd a b 1 ->
 exists x, exists y, x * a + y * b = 1.
Proof.
 intros.
 apply Zis_gcd_bezout in H; inversion H as [u' v].
 exists u'; exists v; trivial.
Qed.

Lemma not_prime_divide_prime : forall n,
 1 < n -> ~ prime n -> exists p, prime p /\ (p | n) /\ 1 < p < n.
Proof.
 intros n Hn; generalize Hn.
 pattern n; apply Z_lt_induction.
 clear n Hn; intros n Rec H H1.
 case (not_prime_divide n); auto.
 intros n1 [ [H3 H4] H5].
 case (prime_dec n1); intros H6.
 exists n1; split; trivial.
 split; [ | split]; trivial.
 apply Rec in H6; trivial; try omega.
 elim H6; intros n0 [Hp [Hpn1 Hlt] ].
 exists n0; split; auto with zarith.
 split.
 apply Zdivide_trans with n1; trivial.
 auto with zarith.
 auto with zarith.
Qed.

Lemma lt_minus_one_divide_prime : forall n,
 n < -1 -> exists p, prime p /\ (p | n).
Proof.
 intros n Hn.
 case (prime_dec (-n)); intro Hprime.
 exists (- n); split; trivial.
 apply Zdivide_opp_l; apply Zdivide_refl.
 elim (@not_prime_divide_prime (-n)); trivial; try omega.
 intros p' [Hp' [ Hdiv' Hlt ] ].
 exists p'; split; trivial.
 apply Zdivide_opp_r_rev; trivial.
Qed.

Lemma Zdivide_prime : forall n,
 n <> -1 -> n <> 0 -> n <> 1 -> ~ prime n -> exists p, prime p /\ (p | n).
Proof.
 intros n Hnm1 Hn0 Hn1 Hpn.
 case (Z_lt_dec n 0); intro.
 apply lt_minus_one_divide_prime; omega.
 destruct (not_prime_divide_prime n); trivial.
 omega.
 destruct H as [H1 [ H2 H3] ].
 exists x.
 split; trivial.
Qed.

Lemma Zdivide_lt_rel_prime : forall a b,
 (forall p, prime p -> (p | b) ->  -p < a < p) ->
 a <> 0 ->
 Zis_gcd a b 1.
Proof.
 intros a b Hp Ha.
 assert (Hpos:= Zgcd_is_pos a b).
 destruct (Z_dec a 0) as [ [ H3 | H4] | H5].

 assert (H0: (Zgcd a b | -a)) by (apply Zdivide_opp_r; case (Zgcd_is_gcd a b); auto).
 assert (H1: (Zgcd a b | -b)) by (apply Zdivide_opp_r; case (Zgcd_is_gcd a b); auto).
 apply Zdivide_le in H0; try omega.
 case (prime_dec (Zgcd a b)); intros Hz.
 apply Hp in Hz.
 elimtype False; omega.
 apply Zdivide_opp_r_rev; trivial.
 elim (Z_eq_dec (Zgcd a b) 0); intros Hz0.
 apply Zgcd_inv_0_l in Hz0.
 elimtype False; omega.
 elim (Z_eq_dec (Zgcd a b) 1); intros Hz1.
 rewrite <- Hz1; apply Zgcd_is_gcd.
 apply Zdivide_prime in Hz; trivial; try omega.
 elim Hz; intros p2 [Hp2 Hdiv2]; clear Hz.
 apply Zdivide_opp_r_rev in H1.
 apply Hp in Hp2; trivial.
 apply Zdivide_le in Hdiv2; try omega.
 elimtype False; omega.
 apply Zdivide_trans with (Zgcd a b); trivial.

 assert (H0: (Zgcd a b | a)) by (case (Zgcd_is_gcd a b); auto).
 assert (H1: (Zgcd a b | b)) by (case (Zgcd_is_gcd a b); auto).
 apply Zdivide_le in H0; try omega.
 case (prime_dec (Zgcd a b)); intros Hz.
 apply Hp in Hz; trivial.
 elimtype False; omega.
 elim (Z_eq_dec (Zgcd a b) 0); intros Hz0.
 apply Zgcd_inv_0_l in Hz0.
 elimtype False; omega.
 elim (Z_eq_dec (Zgcd a b) 1); intros Hz1.
 rewrite <- Hz1; apply Zgcd_is_gcd.
 apply Zdivide_prime in Hz; trivial; try omega.
 elim Hz; intros p2 [Hp2 Hdiv2]; clear Hz.
 assert (Hb := Zdivide_trans p2 (Zgcd a b) b Hdiv2 H1).
 apply Hp in Hp2; trivial.
 apply Zdivide_le in Hdiv2; try omega.
 elimtype False; omega.

 elimtype False; omega.
Qed.

(** Zmult *)

Lemma Zmult_neq_0 : forall x y, x <> 0 -> y <> 0 -> x * y <> 0.
Proof.
 firstorder using Zmult_integral.
Qed.

(** Zdiv *)

Lemma Zdiv_pos : forall a b : Z, 0 <= b -> 0 <= a -> 0 <= a / b.
Proof.
 intros.
 case (Z_eq_dec b 0); intro Hb.
 rewrite Hb, Zdiv_0_r; apply Zle_refl.
 apply Z_div_pos; omega.
Qed.

Lemma Zdiv_neq_0 : forall a b, 0 < b <= a -> a / b <> 0.
Proof.
 intros.
 generalize (Zdiv_le_lower_bound a b 1).
 intros Hlt Heq; rewrite Heq in Hlt; apply Hlt; try omega; trivial.
Qed.

(** Zpower *)

Lemma Zmod_power : forall a b n, (a mod b) ^ n mod b = a ^ n mod b.
Proof.
 destruct n; [trivial | | trivial].
 simpl; repeat rewrite Zpower_pos_nat.
 induction (nat_of_P p).
 trivial.
 unfold Zpower_nat in *; simpl.
 rewrite Zmult_mod_idemp_l, Zmult_mod, IHn, <- Zmult_mod; trivial.
Qed.

Lemma Zmult_power_distr : forall a b n, (a * b) ^ n = a ^ n * b ^ n.
Proof.
 destruct n; trivial.
 simpl; repeat rewrite Zpower_pos_nat.
 induction (nat_of_P p).
 trivial.
 unfold Zpower_nat in *; simpl.
 rewrite IHn; ring.
Qed.

Lemma Zpower_0 : forall n, 0 < n -> 0 ^ n = 0.
Proof.
 intros; destruct n.
 auto with zarith.
 simpl; rewrite Zpower_pos_nat.
 rewrite Zpos_eq_Z_of_nat_o_nat_of_P in H.
 induction (nat_of_P p).
 simpl in H; auto with zarith.
 trivial.
 auto with zarith.
Qed.

Lemma Zpower_1 : forall n, 0 <= n -> 1 ^ n = 1.
Proof.
 intros; destruct n.
 trivial.
 simpl; rewrite Zpower_pos_nat.
 induction (nat_of_P p).
 trivial.
 change (S n) with (1 + n)%nat.
 unfold Zpower_nat in *.
 rewrite iter_nat_plus, IHn; trivial.
 elim H; trivial.
Qed.

Lemma Zpower_pow_nat : forall (a b:Z),
 0 <= a ->
 0 <= b ->
 Z_of_nat (Zabs_nat a ^ Zabs_nat b) = a ^ b.
Proof.
 destruct b; intros; [trivial | simpl | elim H0; trivial].
 rewrite Zpower_pos_nat.
 clear H0; induction (nat_of_P p).
 trivial.
 simpl; rewrite inj_mult, IHn, inj_Zabs_nat, Zabs_eq; trivial.
Qed.

(** Zgcd *)

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

Lemma Zgcd_div_l : forall a b, (Zgcd a b | a).
Proof.
 intros a b; destruct (Zgcd_is_gcd a b); trivial.
Qed.

Lemma Zgcd_div_r : forall a b, (Zgcd a b | b).
Proof.
 intros a b; rewrite Zgcd_sym.
 apply Zgcd_div_l.
Qed.

Lemma Zgcd_0_r : forall a, Zgcd 0 a = Zabs a.
Proof.
 intro; simpl; trivial.
Qed.

Lemma Zgcd_0_l : forall a, Zgcd a 0 = Zabs a.
Proof.
 intros; rewrite Zgcd_sym; simpl; trivial.
Qed.

Lemma Zgcd_neq_0 : forall a b, a <> 0 -> b <> 0 -> Zgcd a b <> 0.
Proof.
 intros a b Ha Hb Heq.
 apply Zgcd_inv_0_l in Heq.
 subst a; elim Ha; trivial.
Qed.

Lemma Zgcd_assoc : forall a b c, Zgcd a (Zgcd b c) = Zgcd (Zgcd a b) c.
Proof.
 intros.
 apply Zis_gcd_gcd.
 apply Zgcd_is_pos.
 constructor;
 eauto using Zdivide_Zgcd, Zdivide_trans, Zgcd_div_l, Zgcd_div_r.
Qed.

Lemma Zis_gcd_prime : forall p n,
 prime p -> n <> 0 -> -p < n < p -> Zis_gcd n p 1.
Proof.
 intros.
 case (Z_lt_dec n 0); intro Hdec.
 apply Zis_gcd_minus.
 apply bezout_rel_prime.
 apply rel_prime_bezout.
 apply rel_prime_sym.
 apply rel_prime_le_prime; trivial.
 omega.

 apply bezout_rel_prime.
 apply rel_prime_bezout.
 apply rel_prime_le_prime; trivial.
 omega.
Qed.

(** Zabs *)

Lemma Zabs_div : forall a, (a | Zabs a).
Proof.
 intros a; case a; simpl.
 apply Zdivide_0.
 intro; apply Zdivide_refl.
 intro; rewrite <- Zopp_neg.
 apply Zdivide_opp_r.
 apply Zdivide_refl.
Qed.

Lemma Zabs_div_inv : forall a, (Zabs a | a).
Proof.
 intros.
 apply Zdivide_Zabs_inv_l.
 apply Zdivide_refl.
Qed.

Lemma Zabs_nat_Zabs : forall a, Zabs_nat (Zabs a) = Zabs_nat a.
Proof.
 intro a; case a; simpl; trivial.
Qed.

Lemma Zabs_neq_0 : forall x, x <> 0 -> Zabs x <> 0.
Proof.
 intro x; case x; intros.
 elim H; trivial.
 simpl; trivial.
 simpl.
 intro Heq; rewrite <- Zopp_neg in Heq.
 rewrite <- Heq in H.
 elim H; omega.
Qed.

Lemma Zabs_0_inv : forall n,
 Zabs n = 0%Z -> n = 0%Z.
Proof.
 intros; destruct n; simpl; trivial.
 rewrite <- H; discriminate.
Qed.

(** Zlcm *)

Definition Zlcm a b := Zabs (a * b) / Zgcd a b.

Lemma Zlcm_gcd : forall a b, Zabs (a * b) = Zgcd a b * Zlcm a b.
Proof.
 intros; unfold Zlcm.
 case (Z_eq_dec (Zgcd a b) 0); intro H.
 rewrite H; simpl.
 apply Zgcd_inv_0_l in H.
 rewrite H; trivial.
 apply Zdivide_Zdiv_eq_full; [ trivial | ].
 apply Zdivide_trans with (a * b).
 apply Zdivide_mult_l; apply Zgcd_div_l.
 apply Zabs_div.
Qed.

Lemma Zlcm_sym : forall a b, Zlcm a b = Zlcm b a.
Proof.
 intros; unfold Zlcm.
 rewrite Zgcd_sym, Zmult_comm; trivial.
Qed.

Lemma Zlcm_div_mult : forall a b, (Zlcm a b | a * b).
Proof.
 intros a b.
 apply Zdivide_trans with (Zabs (a * b)).
 rewrite Zlcm_gcd.
 apply Zdivide_factor_l.
 apply Zabs_div_inv.
Qed.

Lemma Zis_gcd_lcm : forall n a b,
 Zis_gcd n a 1 ->
 Zis_gcd n b 1 ->
 Zis_gcd n (Zlcm a b) 1.
Proof.
 intros n a b Ha Hb.
 apply Zis_gcd_gcd in Ha; try omega.
 apply Zis_gcd_gcd in Hb; try omega.
 destruct (Zgcd_1_rel_prime n a) as [Hrp_a _].
 destruct (Zgcd_1_rel_prime n b) as [Hrp_b _].
 apply Hrp_a in Ha.
 apply Hrp_b in Hb.
 clear Hrp_a Hrp_b.
 assert (Hab := rel_prime_mult n a b Ha Hb).

 apply rel_prime_sym.
 apply rel_prime_div with (a * b); trivial.
 apply rel_prime_sym; trivial.
 apply Zlcm_div_mult.
Qed.

Lemma Zdivide_lt_rel_prime_lcm : forall n a b,
 (forall p, prime p -> (p | a) -> -p < n < p) ->
 (forall p, prime p -> (p | b) -> -p < n < p) ->
 n <> 0 ->
 Zis_gcd n (Zlcm a b) 1.
Proof.
 intros n a b Hpa Hpb Hn.
 assert (Ha := Zdivide_lt_rel_prime n a Hpa Hn).
 assert (Hb := Zdivide_lt_rel_prime n b Hpb Hn).
 apply Zis_gcd_lcm; trivial.
Qed.

Lemma Zlcm_div_l : forall a b, (a | Zlcm a b).
Proof.
 intros; unfold Zlcm.
 case (Z_eq_dec (Zgcd a b) 0); intro Hgcd.
 rewrite Hgcd, Zdiv_0_r; apply Zdivide_0.

 apply Zdivide_Zabs_l.
 apply Zdivide_intro with (Zabs b / Zgcd a b).
 rewrite Zabs_Zmult, (Zmult_comm _ (Zabs a)).
 apply Zdivide_Zdiv_eq_2.
 generalize (Zgcd_is_pos a b); omega.
 apply Zdivide_trans with b; [apply Zgcd_div_r | apply Zabs_div].
Qed.

Lemma Zlcm_div_r : forall a b, (b | Zlcm a b).
Proof.
 intros.
 rewrite Zlcm_sym.
 apply Zlcm_div_l.
Qed.

Lemma Zlcm_is_pos : forall a b, 0 <= Zlcm a b.
Proof.
 intros; unfold Zlcm.
 apply Zdiv_pos.
 apply Zgcd_is_pos.
 apply Zabs_pos.
Qed.

Lemma Zlcm_neq_0 : forall a b, a <> 0 -> b <> 0 -> Zlcm a b <> 0.
Proof.
 intros; unfold Zlcm.

 assert (H1:0 < Zgcd a b).
 generalize (Zgcd_is_pos a b) (Zgcd_neq_0 a b); omega.

 assert (H2:0 < Zabs (a * b)).
 generalize (Zabs_pos (a * b)) (Zabs_neq_0 (a * b)) (Zmult_neq_0 a b); omega.

 apply Zdiv_neq_0; split.
 trivial.
 apply Zdivide_le.
 apply Zlt_le_weak; trivial.
 trivial.
 rewrite Zabs_Zmult.
 apply Zdivide_mult_l.
 apply Zdivide_trans with a.
 apply Zgcd_div_l.
 apply Zabs_div.
Qed.

Lemma Zdivide_lcm_prime :
 forall p a b, prime p -> (p | Zlcm a b) -> (p | a) \/ (p | b).
Proof.
 intros p a b Hp Hdiv.
 apply (prime_mult p Hp).
 apply Zdivide_trans with (Zabs (a * b)).
 rewrite Zlcm_gcd.
 apply Zdivide_mult_r; trivial.
 apply Zabs_div_inv.
Qed.

(** Smallest prime divisor *)

Definition primeb (a:Z) : bool := if prime_dec a then true else false.

Lemma primeb_spec : forall a, primeb a = true <-> prime a.
Proof.
 unfold primeb; intro a; split; case (prime_dec a).
 trivial.
 intros; discriminate.
 trivial.
 intuition.
Qed.

Definition Zdivideb (a b:Z) : bool := if Zdivide_dec a b then true else false.

Lemma Zdivideb_spec : forall a b, Zdivideb a b = true <-> Zdivide a b.
Proof.
 unfold Zdivideb; intro a; split; case (Zdivide_dec a b).
 trivial.
 intros; discriminate.
 trivial.
 intuition.
Qed.

Definition smallest_prime_divisor (a:Z) :=
 match filter (fun b => primeb (Z_of_nat b) && Zdivideb (Z_of_nat b) a)
              (seq 2 (Zabs_nat a))
 with
  | nil    => 1 + a
  | p :: _ => Z_of_nat p
 end.

Lemma smallest_prime_divisor_spec : forall (a:Z),
 1 < a ->
 let p := smallest_prime_divisor a in
  prime p /\
  (p | a) /\
  forall p', prime p' -> (p' | a) -> p <= p'.
Proof.
 intro a; unfold smallest_prime_divisor.
 case_eq (filter
  (fun b => primeb (Z_of_nat b) && Zdivideb (Z_of_nat b) a) (seq 2 (Zabs_nat a))).

 (* No smallest prime divisor, absurd *)
 intros Heq Hlt.
 case (prime_dec a); intro Ha.

  (* If [a] is prime, [a] must be in the list *)
  assert (Hin:In (Zabs_nat a) nil).
   rewrite <- Heq, filter_In; split.
   apply le_In_seq; split; [ | omega].
   change 2%nat with (Zabs_nat 2).
   apply Zabs_nat_le; omega.
   rewrite inj_Zabs_nat.
   rewrite Zabs_eq; [ | omega].
   apply andb_true_intro; split.
    apply <- primeb_spec; trivial.
    apply <- Zdivideb_spec; apply Zdivide_refl.
  inversion Hin.

  (* If [a] is composite, it has a prime divisor that must be in the list *)
  apply (not_prime_divide_prime a Hlt) in Ha.
  destruct Ha as [p [H0 [H1 H2] ] ].
  assert (Hin:In (Zabs_nat p) nil).
   rewrite <- Heq, filter_In; split.
   apply le_In_seq; split.
   change 2%nat with (Zabs_nat 2).
   apply Zabs_nat_le; omega.
   assert (H3:0 <= p <= a) by omega.
   apply Zabs_nat_le in H3; omega.
   rewrite inj_Zabs_nat.
   rewrite Zabs_eq; [ | omega].
   apply andb_true_intro; split.
    apply <- primeb_spec; trivial.
    apply <- Zdivideb_spec; trivial.
  inversion Hin.

 (* [p] is the smallest prime divisor *)
 intros p l Heq Hlt.
 assert (Hin:In p (p::l)) by intuition.
 rewrite <- Heq, filter_In, andb_true_iff in Hin.
 destruct Hin as [_ [H0 H1] ].
 split; [ | split].
  apply -> primeb_spec; trivial.
  apply -> Zdivideb_spec; trivial.

  (* Any other prime divisor [p'] has to be in the list *)
  intros p' H2 H3.
  assert (H4:=prime_ge_2 _ H2).
  assert (H5:p' <= a) by (apply Zdivide_le; [omega | omega | trivial]).
  assert (Hin:In (Zabs_nat p') (p::l)).
  rewrite <- Heq, filter_In; split.
  apply le_In_seq; split.
   change 2%nat with (Zabs_nat 2).
   apply Zabs_nat_le; omega.
   assert (H6:0 <= p' <= a) by omega.
   apply Zabs_nat_le in H6; omega.
   rewrite inj_Zabs_nat.
   rewrite Zabs_eq; [ | omega].
   apply andb_true_intro; split.
    apply <- primeb_spec; trivial.
    apply <- Zdivideb_spec; trivial.
  induction Hin.
  rewrite H, inj_Zabs_nat, Zabs_eq; omega.

  (* Since [p'] is in the list and the list is ordered, [p <= p'] *)
  assert (Hs:sort lt (p :: l)).
   rewrite <- Heq.
   apply sorted_filter.
   unfold transitive; intros; eauto with arith.
   apply sorted_seq.

  replace p' with (Zabs p') by (apply Zabs_eq; omega).
  rewrite <- inj_Zabs_nat; apply inj_le.

  apply sort_inv in Hs; destruct Hs as [Hs Hl].
  clear -H Hs Hl; induction l.
  inversion H.
  induction H.
  apply lelistA_inv in Hl; intuition.

  apply (IHl H).
  apply sort_inv in Hs; intuition.
  apply lelistA_inv in Hl.
  apply sort_inv in Hs; intuition.
  clear -Hl H1.
  induction l; constructor.
  apply lelistA_inv in H1; omega.
Qed.

(** Extended Euclidean Algorithm *)

Ltac Z_eq_dec_tac x :=
 let H := fresh "H" in
  case (Z_dec 0 x); intro H; [ elim H; clear H; intro H | ].

Inductive Euclid : Z -> Z -> Z -> Z -> Z -> Prop :=
| EuclidEq: forall a,
             0 < a ->
             Euclid a a 1 0 a
| EuclidGt: forall a b u v d,
             0 <= b < a ->
             Euclid (a - b) b u v d ->
             Euclid a b u (v - u) d
| EuclidLt: forall a b u v d,
             Euclid a b u v d ->
             Euclid b a v u d.

Hint Constructors Euclid.

Lemma Euclid_bezout : forall a b u v d,
 Euclid a b u v d -> u * a + v * b = d.
Proof.
 induction 1; try rewrite <- IHEuclid; ring.
Qed.

Lemma Euclid_gcd : forall a b u v d,
 Euclid a b u v d -> Zis_gcd a b d.
Proof.
 induction 1; auto with zarith.
 apply Zis_gcd_refl.
 apply Zis_gcd_for_euclid with 1; rewrite Zmult_1_l; auto.
 apply Zis_gcd_sym; auto.
Qed.

Lemma Euclid_bound : forall a b u v d,
 Euclid a b u v d -> Zabs u <= Zabs b /\ Zabs v <= Zabs a.
Proof.
 induction 1; auto with zarith.
 repeat rewrite Zabs_eq; auto with zarith.
 split; intuition.
 apply Zle_trans with (Zabs u + Zabs v).
 replace (v - u) with ((-u) + v); try ring.
 rewrite <- (Zabs_Zopp u).
 apply Zabs_triangle.
 rewrite (Zabs_eq a) in * |- *; auto with zarith.
 rewrite (Zabs_eq b) in * |- *; auto with zarith.
 rewrite (Zabs_eq (a - b)) in * |- *; auto with zarith.
Qed.

(** Chinese Remainder Theorem *)

Lemma chinese : forall m n a b,
 rel_prime m n -> {x:Z | x mod m = a mod m /\ x mod n = b mod n}.
Proof.
 intros m n a b Hmn.
 destruct (euclid m n) as [u v d H1 H2].
 exists (a * (d * v * n) + b * (d * u * m)).
 destruct (Zis_gcd_unique _ _ _ _ Hmn H2) as [H | H].
 rewrite <- H in *.
 rewrite Zmult_1_l, Zmult_1_l.
 split.
 rewrite Zmult_assoc, Zmult_assoc.
 rewrite Z_mod_plus_full.
 rewrite <- Zmult_assoc.
 cutrewrite (v*n = 1 - u*m); [ | omega].
 cutrewrite (a*(1-u*m) = a + (-a*u*m)); [ | ring].
 apply Z_mod_plus_full.
 rewrite Zplus_comm, Zmult_assoc, Zmult_assoc, Z_mod_plus_full, <- Zmult_assoc.
 cutrewrite (u*m = 1 - v*n); [ | omega].
 cutrewrite (b*(1-v*n) = b + (-b*v*n)); [ | ring ].
 apply Z_mod_plus_full.
 cut (d=-1); [ | omega ].
 clear H; intro H.
 rewrite H in *.
 cutrewrite (-1 * u = -u);[ | trivial].
 cutrewrite (-1 * v = -v);[ | trivial].
 split.
 rewrite Zmult_assoc, Zmult_assoc, Z_mod_plus_full, <- Zmult_assoc.
 cutrewrite (-v*n = 1 - -u*m).
 cutrewrite (a*(1- -u*m) = a + (a * u *m));[ | ring ].
 apply Z_mod_plus_full.
 transitivity (- (v*n)); [ring | ].
 transitivity (1 + u*m); [omega | ring ].
 rewrite Zplus_comm, Zmult_assoc, Zmult_assoc, Z_mod_plus_full, <- Zmult_assoc.
 cutrewrite (-u*m = 1 - -v*n).
 cutrewrite (b*(1- -v*n) = b + b*v*n);[ | ring].
 apply Z_mod_plus_full.
 transitivity (- (u*m)); [ ring | ].
 transitivity (1 + v*n); [ omega | ring].
Qed.

(* The algorithm, assuming [0 < b <= a] *)
Definition euclid : forall a b,
 0 < b <= a ->
 {uvd: Z * Z * Z | let (uv,d) := uvd in let (u,v) := uv in Euclid a b u v d /\ 0 <= d}.
 intros a b Hab; generalize b Hab; pattern a.
 apply Zlt_0_rec; [ | omega]; clear a b Hab; intros a Hrec Ha b Hb.

 case (Z_eq_dec a b); intros Hab.
 exists (1, 0, a); subst; intuition.

 case (Z_le_gt_dec (a - b) b); intros Habb.
 assert (HH:0 <= b < a) by auto with zarith.
 assert (HH1:0 < a - b <= b) by auto with zarith.
 destruct (Hrec _ HH _ HH1) as (((u,v),d), Hd).
 exists (v, u - v, d); intuition.

 assert (HH:0 <= a - b < a) by auto with zarith.
 assert (HH1:0 < b <= a - b) by auto with zarith.
 destruct (Hrec _ HH _ HH1) as (((u,v),d), Hd).
 exists (u, v - u, d); intuition.
Defined.

(* The general algorithm *)
Definition eeuclid (a b: Z) : Z * Z * Z.
 intros a b.
 Z_eq_dec_tac a.
 Z_eq_dec_tac b.

 case (Z_le_gt_dec b a); intro Hab.
 destruct (euclid a b) as [((u,v),d) [H1 H2] ]; [auto with zarith | exact (u,v,d)].
 destruct (euclid b a) as [((u,v),d) [H1 H2] ]; [auto with zarith | exact (v,u,d)].

 case (Z_le_gt_dec (-b) a); intro Hab.
 destruct (euclid a (-b)) as [((u,v),d) [H1 H2] ]; [auto with zarith | exact (u,-v,d)].
 destruct (euclid (-b) a) as [((u,v),d) [H1 H2] ]; [auto with zarith | exact (v,-u,d)].

 exact (1, 0, a).

 Z_eq_dec_tac b.
 case (Z_le_gt_dec (-a) b); intro Hab.
 destruct (euclid b (-a)) as [((u,v),d) [H1 H2] ]; [auto with zarith | exact (-v,u,d)].
 destruct (euclid (-a) b) as [((u,v),d) [H1 H2] ]; [auto with zarith | exact (-u,v,d)].

 case (Z_le_gt_dec (-b) (-a)); intro Hab.
 destruct (euclid (-a) (-b)) as [((u,v),d) [H1 H2] ]; [auto with zarith | exact (-u,-v,d)].
 destruct (euclid (-b) (-a)) as [((u,v),d) [H1 H2] ]; [auto with zarith | exact (-v,-u,d)].

 exact (-1, 0, -a).

 Z_eq_dec_tac b.
 exact (0, 1, b).
 exact (0, -1, -b).
 exact (0, 0, 0).
Defined.

Lemma eeuclid_spec : forall (a b u v d:Z),
 eeuclid a b = (u, v, d) ->
 u * a + v * b = d /\ Zis_gcd a b d /\ 0 <= d.
Proof.
 intros a b u v d; unfold eeuclid.
 Z_eq_dec_tac a.
 Z_eq_dec_tac b; simpl.

 case (Z_le_gt_dec b a); intro Hab;
 match goal with
  |- context [euclid ?a ?b ?H] =>
      let H1 := fresh "H" in
       destruct (euclid a b H) as [((u',v'),d') [H1 ?] ]; simpl;
       injection 1; intros; subst; split
 end.
 apply Euclid_bezout; trivial.
 apply Euclid_gcd in H1; auto.
 apply Euclid_bezout in H1; rewrite Zplus_comm; trivial.
 apply Euclid_gcd in H1; apply Zis_gcd_sym in H1; auto.

 case (Z_le_gt_dec (-b) a); intro Hab;
 match goal with
  |- context [euclid ?a ?b ?H] =>
      let H1 := fresh "H" in
       destruct (euclid a b H) as [((u',v'),d') [H1 ?] ]; simpl;
       injection 1; intros; subst; split
 end.
 apply Euclid_bezout in H1; rewrite <- H1; ring.
 apply Euclid_gcd in H1; apply Zis_gcd_minus in H1; apply Zis_gcd_sym in H1; auto.
 apply Euclid_bezout in H1; rewrite <- H1; ring.
 apply Euclid_gcd in H1; apply Zis_gcd_sym in H1; apply Zis_gcd_minus in H1;
  apply Zis_gcd_sym in H1; auto.

 intro H1; injection H1; clear H1; intros; subst; auto with zarith.

 Z_eq_dec_tac b; simpl.
 case (Z_le_gt_dec (-a) b); intro Hab;
 match goal with
  |- context [euclid ?a ?b ?H] =>
      let H1 := fresh "H" in
       destruct (euclid a b H) as [((u',v'),d') [H1 ?] ]; simpl;
       injection 1; intros; subst; split
 end.
 apply Euclid_bezout in H1; rewrite <- H1; ring.
 apply Euclid_gcd in H1; apply Zis_gcd_minus in H1; auto.
 apply Euclid_bezout in H1; rewrite <- H1; ring.
 apply Euclid_gcd in H1; apply Zis_gcd_sym in H1; apply Zis_gcd_minus in H1; auto.

 case (Z_le_gt_dec (-b) (-a)); intro Hab;
 match goal with
  |- context [euclid ?a ?b ?H] =>
      let H1 := fresh "H" in
       destruct (euclid a b H) as [((u',v'),d') [H1 ?] ]; simpl;
       injection 1; intros; subst; split
 end.
 apply Euclid_bezout in H1; rewrite <- H1; ring.
 apply Euclid_gcd in H1; apply Zis_gcd_minus in H1; apply Zis_gcd_minus in H1; auto.

 apply Euclid_bezout in H1; rewrite <- H1; ring.
 apply Euclid_gcd in H1; apply Zis_gcd_minus in H1; apply Zis_gcd_minus in H1;
  apply Zis_gcd_sym in H1; auto.

 intro H1; injection H1; clear H1; intros; subst; auto with zarith.

 Z_eq_dec_tac b; intro H1; injection H1; clear H1; intros; subst; auto with zarith.
Qed.

Lemma euclid_bound : forall a b (H:0 < b <= a),
 match euclid a b H with
 | exist (u,v,d) He => Zabs u <= Zabs b /\ Zabs v <= Zabs a
 end.
Proof.
 intros a b H.
 generalize (let uvd := proj1_sig (euclid a b H) in
  Euclid_bound a b (fst (fst uvd)) (snd (fst uvd)) (snd uvd)).
 destruct (euclid a b H) as [((u,v),d) [H1 H2]]; auto.
Qed.

Lemma eeuclid_bound : forall (a b n:Z),
 Zabs a <= n ->
 Zabs b <= n ->
 Zabs (fst (fst (eeuclid a b))) <= n /\
 Zabs (snd (fst (eeuclid a b))) <= n.
Proof.
 intros a b n Ha Hb; unfold eeuclid.
 Z_eq_dec_tac a.
 Z_eq_dec_tac b; simpl.

 case (Z_le_gt_dec b a); intro Hab;
 match goal with
  |- context [euclid ?a ?b ?H] =>
     assert (H1:=euclid_bound a b H);
     destruct (euclid a b H) as [((u,v),d) [? ?] ]; simpl;
     auto with zarith
 end.

 case (Z_le_gt_dec (-b) a); intro Hab;
 match goal with
  |- context [euclid ?a ?b ?H] =>
     assert (H1:=euclid_bound a b H);
     destruct (euclid a b H) as [((u,v),d) [? ?] ]; simpl
 end.
 rewrite Zabs_Zopp.
 rewrite (Zabs_eq (-b)) in H1; rewrite Zabs_non_eq in Hb; auto with zarith.
 rewrite Zabs_Zopp.
 rewrite (Zabs_eq (-b)) in H1; rewrite Zabs_non_eq in Hb; auto with zarith.

 rewrite Zabs_eq in Ha; auto with zarith.

 Z_eq_dec_tac b; simpl.
 case (Z_le_gt_dec (-a) b); intro Hab;
 match goal with
  |- context [euclid ?a ?b ?H] =>
     assert (H1:=euclid_bound a b H);
     destruct (euclid a b H) as [((u,v),d) [? ?] ]; simpl
 end.
 rewrite Zabs_Zopp.
 rewrite (Zabs_eq (-a)) in H1; rewrite Zabs_non_eq in Ha; auto with zarith.
 rewrite Zabs_Zopp.
 rewrite (Zabs_eq (-a)) in H1; rewrite Zabs_non_eq in Ha; auto with zarith.

 case (Z_le_gt_dec (-b) (-a)); intro Hab;
 match goal with
  |- context [euclid ?a ?b ?H] =>
     assert (H1:=euclid_bound a b H);
     destruct (euclid a b H) as [((u,v),d) [? ?] ]; simpl
 end.
 rewrite Zabs_Zopp, Zabs_Zopp.
 rewrite (Zabs_eq (-a)) in H1; rewrite Zabs_non_eq in Ha;
 rewrite (Zabs_eq (-b)) in H1; rewrite Zabs_non_eq in Hb; auto with zarith.
 rewrite Zabs_Zopp, Zabs_Zopp.
 rewrite (Zabs_eq (-a)) in H1; rewrite Zabs_non_eq in Ha;
 rewrite (Zabs_eq (-b)) in H1; rewrite Zabs_non_eq in Hb; auto with zarith.

 rewrite Zabs_non_eq in Ha; auto with zarith.

 Z_eq_dec_tac b; simpl.
 rewrite Zabs_eq in Hb; auto with zarith.
 rewrite Zabs_non_eq in Hb; auto with zarith.
 rewrite Zabs_eq in Ha; auto with zarith.
Qed.

Lemma even_of_Zeven : forall x, 0 <= x -> even (Zabs_nat x) -> Zeven x.
Proof.
 intros x Hx H.
 destruct (even_2n (Zabs_nat x) H) as [d Hd].
 rewrite <- Zabs_eq, <- inj_Zabs_nat, Hd.
 unfold double.
 cutrewrite (d + d = 2 * d)%nat.
 rewrite inj_mult.
 change (Zeven (2 * Z_of_nat d)).
 apply Zeven_2p.
 omega.
 trivial.
Qed.

Lemma Zeven_of_even : forall x, Zeven (Z_of_nat x) -> even x.
Proof.
 intros x H.
 destruct (Zeven_ex (Z_of_nat x) H) as [d Hd].
 rewrite <- Zabs_nat_Z_of_nat, Hd, Zabs_nat_mult.
 change (even (2 * Zabs_nat d)).
 auto with arith.
Qed.

Lemma Zeven_minus : forall x y, Zeven x -> Zeven y -> Zeven (x - y).
Proof.
 intros x y Hx Hy.
 destruct (Zeven_ex x Hx) as [x' Hx'].
 destruct (Zeven_ex y Hy) as [y' Hy'].
 subst.
 cutrewrite (2 * x' - 2 * y' = 2 * (x' - y')).
 apply Zeven_2p.
 omega.
Qed.

Lemma rel_prime_minus_1 : forall x, rel_prime (-1) x.
Proof.
 intro x.
 apply bezout_rel_prime.
 apply Zis_gcd_bezout.
 apply Zis_gcd_minus.
 simpl.
 apply Zis_gcd_1.
Qed.

Lemma Zpower_nat_Zpower x m : Zpower x (Z_of_nat m) = Zpower_nat x m.
Proof.
 intros; unfold Zpower_nat; induction m.
 simpl; trivial.
 cutrewrite (x ^ Z_of_nat (S m) = x * x ^ Z_of_nat m).
 simpl; rewrite <- IHm; trivial.
 cutrewrite (S m = m + 1)%nat;[ | ring].
 rewrite inj_plus, Zpower_exp; simpl.
 unfold Zpower_pos; simpl.
 ring.
 generalize (Zle_0_nat m); omega.
 omega.
Qed.

Lemma Zdiv2_S_double : forall a, a>=0 -> Zdiv2 (Zsucc (2 * a)) = a.
Proof.
 destruct a.
 reflexivity.
 reflexivity.
 intro H.
 contradict H.
 auto.
Qed.

Lemma Zdiv_Zdiv2 a : a >= 0 -> Zdiv2 a = Zdiv a 2.
Proof.
 intros a Ha.
 destruct (Zeven_odd_dec a) as [H1 | H1].

 apply Zeven_div2 in H1.
 rewrite H1 at 2.
 rewrite Zmult_comm.
 rewrite Z_div_mult_full; trivial.
 omega.

 destruct (Zodd_ex _ H1).
 rewrite H.
 cutrewrite (2 * x + 1 = Zsucc (2 * x)).
 rewrite <- (Zdiv_unique (Zsucc (2 * x)) 2 x 1).
 rewrite Zdiv2_S_double.
 trivial.
 omega.
 omega.
 auto.
 auto.
Qed.

Lemma Zlt_is_not_lt_bool: forall n m : Z, n >= m <-> Zlt_bool n m = false.
Proof.
 intros; split; intros.
 apply not_true_is_false.
 intro Heq.
 apply Zlt_is_lt_bool in Heq.
 omega.
 generalize (Zlt_cases n m).
 rewrite H.
 trivial.
Qed.

Lemma Zle_is_not_le_bool: forall n m : Z, n > m <-> Zle_bool n m = false.
Proof.
 intros; split; intros.
 apply not_true_is_false.
 intro Heq.
 apply Zle_is_le_bool in Heq.
 omega.
 generalize (Zle_cases n m).
 rewrite H.
 trivial.
Qed.

Lemma Zle_lt_2 a b : a <= b -> a <> b -> a < b.
Proof.
 intros; omega.
Qed.

Lemma Zmod_ex a b c (W : b <> 0) : a mod b = c -> a = b * (a / b) + c.
Proof.
 intros.
 rewrite <- H.
 apply Z_div_mod_eq_full; trivial.
Qed.

Lemma Zopp_Zminus x : - x = (-1) * x.
Proof.
 intros; ring.
Qed.

Lemma Zdiv2_small : forall a n: Z,
 0 < Zdiv2 a -> Zdiv2 a < n < a -> a - n <= Zdiv2 a.
Proof.
 intros.
 destruct (Zeven_odd_dec a) as [H1 | H1].
 apply Zeven_div2 in H1; omega.
 destruct (Zodd_ex _ H1).
 assert (Zdiv2 a = x).
 rewrite H2.
 cutrewrite (2 * x + 1 = Zsucc (2 * x)).
 rewrite Zdiv2_S_double.
 trivial.
 omega.
 unfold Zsucc; trivial.
 omega.
Qed.

Lemma Zdiv2_small_mod a n (W : Zodd a) (W' : a >= 0) (W'' : n mod a <> 0) :
 - n mod a <= Zdiv2 a -> Zdiv2 a < n mod a.
Proof.
 intros.
 rewrite Z_mod_nz_opp_full in H.
 apply Zlt_0_minus_lt.
 apply Zle_left in H.
 ring_simplify in H.
 apply Zle_lt_trans with (Zdiv2 a - a + n mod a); trivial.
 cutrewrite (Zdiv2 a - a + n mod a =  n mod a + ( Zdiv2 a - a )); [ | ring ].
 cutrewrite (n mod a - Zdiv2 a = n mod a + - Zdiv2 a).
 apply Zplus_lt_compat_l.
 apply Zlt_0_minus_lt.
 rewrite (Zodd_div2 a) at 3.
 ring_simplify.
 omega.
 trivial.
 trivial.
 ring.
 trivial.
Qed.

Lemma Zdiv2_small_mod_bis a n (W : Zodd a) (W' : a >= 0) (W'' : n mod a <> 0):
 - n mod a < Zdiv2 a -> Zdiv2 a < n mod a.
Proof.
 intros.
 rewrite Z_mod_nz_opp_full in H.
 apply Zlt_0_minus_lt.
 apply Zlt_left in H.
 ring_simplify in H.
 apply Zle_lt_trans with ( Zdiv2 a - a + n mod a - 1); trivial.
 cutrewrite (Zdiv2 a - a + n mod a - 1 = n mod a + ( Zdiv2 a - a - 1 )); [ | ring ].
 cutrewrite (n mod a - Zdiv2 a = n mod a + - Zdiv2 a).
 apply Zplus_lt_compat_l.
 apply Zlt_0_minus_lt.
 rewrite (Zodd_div2 a) at 3.
 ring_simplify.
 omega.
 trivial.
 trivial.
 ring.
 trivial.
Qed.

Lemma Zdiv2_small_mod_bis_rev a n (W : Zodd a) (W' : a >= 0) (W'' : n mod a <> 0) :
 - n mod a > Zdiv2 a -> Zdiv2 a >= n mod a.
Proof.
 intros.
 rewrite Z_mod_nz_opp_full in H.
 apply Zle_ge.
 apply Zgt_lt in H.
 apply Zle_0_minus_le.
 apply Zlt_left in H.
 ring_simplify in H.
 apply Zle_trans with ( a - n mod a - Zdiv2 a - 1); trivial.
 apply Zle_0_minus_le.
 rewrite (Zodd_div2 a) at 3.
 ring_simplify.
 omega.
 trivial.
 trivial.
 trivial.
Qed.

Lemma Zeven_mod n : n mod 2 = 0 -> Zeven n.
Proof.
 intros.
 apply Zmod_divide in H.
 inversion H; subst.
 rewrite Zmult_comm.
 apply Zeven_2p.
 omega.
Qed.

Lemma Zmod_opp_diff_0 n m : n mod m <> 0 -> - n mod m <> 0.
Proof.
 intros.
 intro Heq; apply H; clear H.
 apply Z_mod_zero_opp_full in Heq.
 rewrite Zopp_involutive in Heq.
 trivial.
Qed.

Lemma Zmod_pos x n (W : 0 < n): 0 <= x mod n.
Proof.
 intros; generalize (Z_mod_lt x n); omega.
Qed.

Lemma Zmod_bound x n (W : 0 < n): x mod n < n.
Proof.
 intros; generalize (Z_mod_lt x n); omega.
Qed.

Lemma not_Zle_lt: forall n m : Z, ~ n <= m -> m < n.
Proof.
 intros; omega.
Qed.

Lemma not_Zlt_le: forall n m : Z, ~ n < m -> m <= n.
Proof.
 intros; omega.
Qed.

Lemma mod_mult_0 : forall p a b : Z,
 prime p -> (a * b) mod p = 0 -> a mod p = 0 \/ b mod p = 0.
Proof.
 intros.
 apply Zmod_divide_minus in H0.
 rewrite Zminus_0_r in H0.
 apply prime_mult in H0; [ | trivial].
 destruct H0; apply Zdivide_mod in H0; auto.
 apply prime_ge_2 in H; omega.
Qed.

(** Multiplicative inverse modulo *)

Definition Zinv_mod (a q:Z) :=
 let (p,_) := eeuclid a q in let (u,_) := p in u mod q.

Lemma Zinv_mod_spec : forall (a q:Z),
 1 < q -> Zis_gcd a q 1 -> (a * Zinv_mod a q) mod q = 1.
Proof.
 intros a q Hlt H; unfold Zinv_mod.
 generalize (eeuclid_spec a q).
 destruct (eeuclid a q) as ((u, v), d).
 intro H0; destruct (H0 u v d (refl_equal _)) as [Heq [Hgcd Hle] ].
 destruct (Zis_gcd_unique a q d 1 Hgcd H); [ | exfalso; omega].
 rewrite Zmult_mod_idemp_r.
 rewrite <- (Z_mod_plus_full _ v), Zmult_comm, Heq, H1, Zmod_1_l; trivial.
Qed.

Lemma Zinv_mod_bound : forall (a q:Z),
 0 < q -> 0 <= Zinv_mod a q < q.
Proof.
 intros a q Hlt; unfold Zinv_mod.
 destruct (eeuclid a q) as ((u, v), d).
 split; [apply Zmod_pos | apply Z_mod_lt]; omega.
Qed.

(** nmod *)

Definition nmod a b := Zabs_nat (Zmod (Z_of_nat a) (Z_of_nat b)).

Close Scope Z_scope.

Infix "mod" := nmod.

Lemma mod_unique: forall a b p r,
 0 <= r < b ->
 a = b * p + r -> r = a mod b.
Proof.
 intros; unfold nmod.
 apply inj_eq_rev.
 rewrite inj_Zabs_nat, Zabs_eq.
 apply Zmod_unique with (Z_of_nat p).
 omega.
 rewrite <- inj_mult, <- inj_plus; apply inj_eq; trivial.
 apply Zmod_pos; omega.
Qed.

Lemma mod_0_l: forall a, 0 mod a = 0.
Proof.
 destruct a; simpl; auto.
Qed.

Lemma mod_0_r: forall a, a mod 0 = 0.
Proof.
 destruct a; simpl; auto.
Qed.

Lemma mod_1_l: forall a, 1 < a -> 1 mod a = 1.
Proof.
 intros; symmetry; apply mod_unique with 0; auto with zarith.
Qed.

Lemma mod_1_r: forall a, a mod 1 = 0.
Proof.
 intros; symmetry; apply mod_unique with a; auto with zarith.
Qed.

Lemma mod_same : forall a, a mod a = 0.
Proof.
 intros.
 destruct (zerop a) as [H | H].
 rewrite H, mod_0_r; trivial.
 symmetry; apply mod_unique with 1; omega.
Qed.

Lemma mod_mult : forall a b,
 (a * b) mod b = 0.
Proof.
 intros.
 destruct (zerop b) as [H | H].
 rewrite H, mod_0_r; trivial.
 symmetry; apply mod_unique with a.
 auto with arith.
 rewrite mult_comm, plus_0_r; trivial.
Qed.

Lemma mod_small : forall a n,
 0 <= a < n -> a mod n = a.
Proof.
 intros; symmetry; apply mod_unique with 0; auto with zarith.
Qed.

Lemma mult_mod : forall a b n,
 (a * b) mod n = a mod n * (b mod n) mod n.
Proof.
 intros.
 destruct (zerop n) as [H | H].
 subst; rewrite mod_0_r, mod_0_r; trivial.
 unfold nmod.
 rewrite inj_mult, Zmult_mod.
 rewrite <- Zabs_nat_mult, inj_Zabs_nat, Zabs_eq; trivial.
 apply Zmult_le_0_compat; apply Zmod_pos; omega.
Qed.

Lemma mult_mod_idemp_r : forall a b n,
 (b * (a mod n)) mod n = (b * a) mod n.
Proof.
 intros; unfold nmod.
 destruct (zerop n) as [H | H].
 rewrite H, Zmod_0_r, Zmod_0_r; trivial.
 rewrite inj_mult, inj_Zabs_nat, Zabs_eq.
 rewrite Zmult_mod_idemp_r, inj_mult; trivial.
 apply Zmod_pos; omega.
Qed.

Lemma mod_lt : forall a b,
 0 < b ->  0 <= a mod b < b.
Proof.
 intros; unfold nmod.
 split.
 apply inj_le_rev.
 rewrite inj_Zabs_nat, Zabs_eq; apply Zmod_pos; omega.
 apply inj_lt_rev.
 rewrite inj_Zabs_nat, Zabs_eq.
 apply Zmod_bound.
 omega.
 apply Zmod_pos; omega.
Qed.

Lemma mod_mod : forall a p,
 a mod p mod p = a mod p.
Proof.
 intros; destruct (zerop p) as [H | H].
 subst; rewrite mod_0_r, mod_0_r; trivial.
 rewrite mod_small; trivial.
 apply mod_lt; trivial.
Qed.

Lemma mod_plus : forall a b n, (a + b) mod n = ((a mod n) + (b mod n)) mod n.
Proof.
 intros; destruct (zerop n) as [Hn | Hn].
 subst; rewrite mod_0_r; rewrite mod_0_r; trivial.
 destruct (quotient _ Hn a) as (qa, (ra,(H1a,H2a))); rewrite mult_comm in H1a.
 destruct (quotient _ Hn b) as (qb, (rb,(H1b,H2b))); rewrite mult_comm in H1b.
 destruct (quotient _ Hn (ra + rb)) as (qr, (r,(H1r,H2r))); rewrite mult_comm in H1r.
 rewrite <-(mod_unique a n qa ra), <-(mod_unique b n qb rb); auto with arith.
 rewrite <-(mod_unique (ra + rb) n qr r); auto with arith.
 symmetry; apply mod_unique with (qa + qb + qr).
 auto with arith.
 subst; transitivity (n * qa + n * qb + (ra + rb)); [ ring | ].
 rewrite H1r; ring.
 Qed.

Definition inv_mod (q a:nat) := Zabs_nat (Zinv_mod (Z_of_nat a) (Z_of_nat q)).

Lemma inv_mod_prime : forall a p,
 prime (Z_of_nat p) ->
 0 < a < p ->
 (a * inv_mod p a) mod p = 1.
Proof.
 intros.
 unfold inv_mod, nmod.
 rewrite inj_mult, inj_Zabs_nat, Zabs_eq.
 rewrite Zinv_mod_spec; trivial.
 apply prime_ge_2 in H; omega.
 apply Zis_gcd_prime; trivial; omega.

 unfold Zinv_mod.
 destruct (eeuclid (Z_of_nat a) (Z_of_nat p)).
 destruct p0.
 apply Zmod_pos.
 apply prime_ge_2 in H; omega.
Qed.

Lemma inv_mod_neq_0 : forall a p,
 (1 < Z_of_nat p)%Z ->
 Zis_gcd (Z_of_nat a) (Z_of_nat p) 1 ->
 0 < a ->
 inv_mod p a <> 0.
Proof.
 unfold inv_mod; intros a p Hp Hgcd Hlt Heq.
 generalize (Zinv_mod_spec _ _ Hp Hgcd).
 change 0 with (Zabs_nat (Z_of_nat 0)) in Heq.
 apply inj_eq in Heq.
 simpl in Heq; rewrite inj_Zabs_nat in Heq.
 apply Zabs_0_inv in Heq.
 rewrite Heq, Zmult_0_r, Zmod_0_l; intro; discriminate.
Qed.

Lemma inv_mod_bound: forall n p,
  0 < p  ->
  inv_mod p n < p.
Proof.
  unfold inv_mod; intros.
  rewrite <-(Zabs_nat_Z_of_nat p); apply Zabs_nat_lt.
  rewrite Zabs_nat_Z_of_nat; apply Zinv_mod_bound.
  apply (inj_lt 0 p H).
Qed.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Category.
Require Export Category.Theory.Isomorphism.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Class Functor {C D : Category} := {
fobj : C -> D;
fmap {x y : C} (f : x ~> y) : fobj x ~> fobj y;

fmap_respects :> ∀ x y, Proper (equiv ==> equiv) (@fmap x y);

fmap_id {x : C} : fmap (@id C x) ≈ id;
fmap_comp {x y z : C} (f : y ~> z) (g : x ~> y) :
fmap (f ∘ g) ≈ fmap f ∘ fmap g
}.

Bind Scope functor_scope with Functor.
Delimit Scope functor_type_scope with functor_type.
Delimit Scope functor_scope with functor.
Open Scope functor_type_scope.
Open Scope functor_scope.

Coercion fobj : Functor >-> Funclass.

Notation "C ⟶ D" := (@Functor C%category D%category)
(at level 90, right associativity) : functor_type_scope.

Arguments fmap
{C%category D%category Functor%functor x%object y%object} f%morphism.

Infix "<$>" := fmap
(at level 29, left associativity, only parsing) : morphism_scope.
Infix "<$[ F ]>" := (@fmap _ _ F%functor _ _)
(at level 29, left associativity, only parsing) : morphism_scope.
Notation "x <$ m" := (fmap (Basics.const x) m)
(at level 29, left associativity, only parsing) : morphism_scope.
Notation "x <&> f" := (fmap f x)
(at level 29, left associativity, only parsing) : morphism_scope.

Notation "fobj[ F ]" := (@fobj _ _ F%functor)
(at level 9, format "fobj[ F ]") : object_scope.
Notation "fmap[ F ]" := (@fmap _ _ F%functor _ _)
(at level 9, format "fmap[ F ]") : morphism_scope.

Hint Rewrite @fmap_id : categories.

Program Instance Functor_Setoid {C D : Category} : Setoid (C ⟶ D) := {
equiv := fun F G =>

{ iso : ∀ x : C, F x ≅ G x
& ∀ (x y : C) (f : x ~> y),
fmap[F] f ≈ from (iso y) ∘ fmap[G] f ∘ to (iso x) }
}.
Next Obligation.
equivalence.
- isomorphism.
+ exact (from (x0 x1)).
+ exact (to (x0 x1)).
+ apply iso_from_to.
+ apply iso_to_from.
- simpl.
rewrite e.
rewrite !comp_assoc.
rewrite iso_to_from, id_left.
rewrite <- comp_assoc.
rewrite iso_to_from, id_right.
reflexivity.
- isomorphism.
+ apply (to (x0 x2) ∘ to (x1 x2)).
+ apply (from (x1 x2) ∘ from (x0 x2)).
+ rewrite <- !comp_assoc.
rewrite (comp_assoc (x1 x2)).
rewrite iso_to_from, id_left.
apply iso_to_from.
+ rewrite <- !comp_assoc.
rewrite (comp_assoc (x0 x2)⁻¹).
rewrite iso_from_to, id_left.
apply iso_from_to.
- simpl.
rewrite !comp_assoc.
rewrite <- (comp_assoc _ (x0 y0)⁻¹).
rewrite <- (comp_assoc _ ((x0 y0)⁻¹ ∘ _)).
rewrite <- e.
apply e0.
Qed.

Ltac constructive :=
simpl;
match goal with
[ |- { iso : ?I & ?F } ] =>
given (iso : I); [ intros; isomorphism; simpl; intros
| exists iso; intros ]
end.

Program Instance fmap_iso `(F : C ⟶ D) :
Proper (Isomorphism ==> Isomorphism) F.
Next Obligation.
proper.
refine {| to   := fmap[F] (to X)
; from := fmap (from X) |}.
rewrite <- fmap_comp.
rewrite iso_to_from; cat.
rewrite <- fmap_comp.
rewrite iso_from_to; cat.
Defined.

Instance fobj_respects `(F : C ⟶ D) :
Proper (equiv ==> equiv) (@fobj C D F) := @fmap_iso C D F.

Ltac functor := unshelve (refine {| fobj := _; fmap := _ |}; simpl; intros).

Program Definition Id {C : Category} : C ⟶ C := {|
fobj := fun x => x;
fmap := fun _ _ f => f
|}.

Arguments Id {C} /.

Notation "Id[ C ]" := (@Id C) (at level 9, format "Id[ C ]") : functor_scope.

Program Definition Compose
{C : Category} {D : Category} {E : Category}
(F : D ⟶ E) (G : C ⟶ D) : C ⟶ E := {|
fobj := fun x => fobj (fobj x);
fmap := fun _ _ f => fmap (fmap f)
|}.
Next Obligation. proper; rewrites; reflexivity. Qed.
Next Obligation. intros; rewrite !fmap_comp; reflexivity. Qed.

Hint Unfold Compose.

Notation "F ◯ G" := (Compose F%functor G%functor)
(at level 40, left associativity) : category_scope.

Program Instance Compose_respects {C D E : Category} :
Proper (equiv ==> equiv ==> equiv) (@Compose C D E).
Next Obligation.
proper.
- isomorphism; simpl; intros.
+ exact (fmap (to (x1 x3)) ∘ to (x2 (x0 x3))).
+ exact (from (x2 (x0 x3)) ∘ fmap (from (x1 x3))).
+ rewrite <- !comp_assoc.
rewrite (comp_assoc (x2 (x0 x3))).
rewrite iso_to_from, id_left.
rewrite <- fmap_comp.
rewrite iso_to_from; cat.
+ rewrite <- !comp_assoc.
rewrite (comp_assoc (fmap _)).
rewrite <- fmap_comp.
rewrite iso_from_to, fmap_id, id_left.
rewrite iso_from_to; cat.
- simpl.
rewrite e0, e.
rewrite <- !comp_assoc.
rewrite (comp_assoc (fmap _)).
rewrite <- fmap_comp.
rewrite (comp_assoc (fmap _)).
rewrite <- fmap_comp.
rewrite !comp_assoc.
reflexivity.
Qed.

Class Full `(F : C ⟶ D) := {
prefmap {x y} (g : F x ~> F y) : x ~> y;

prefmap_respects {x y} : Proper (equiv ==> equiv) (@prefmap x y);

prefmap_id : ∀ x, @prefmap x x id ≈ id;
prefmap_comp : ∀ x y z (f : F y ~> F z) (g : F x ~> F y),
prefmap (f ∘ g) ≈ prefmap f ∘ prefmap g;

fmap_sur {x y} (g : F x ~> F y) : fmap[F] (prefmap g) ≈ g
}.

Class Faithful `(F : C ⟶ D) := {
fmap_inj {x y} (f g : x ~> y) : fmap[F] f ≈ fmap[F] g -> f ≈ g
}.

Lemma FullyFaithful `(F : C ⟶ D) `{@Full _ _ F} `{@Faithful _ _ F} :
∀ x y, F x ≅ F y -> x ≅ y.
Proof. hammer_hook "Functor" "Functor.FullyFaithful".
intros.
construct.
+ apply prefmap, X.
+ apply prefmap, X.
+ abstract
(simpl;
rewrite <- prefmap_comp;
destruct H;
rewrite iso_to_from;
apply prefmap_id).
+ abstract
(simpl;
rewrite <- prefmap_comp;
destruct H;
rewrite iso_from_to;
apply prefmap_id).
Defined.

Definition FAlgebra `(F : C ⟶ C) (a : C) := F a ~> a.

Definition FCoalgebra `(F : C ⟶ C) (a : C) := a ~> F a.

Definition FGDialgebra `(F : C ⟶ C) `(G : C ⟶ C) (a : C) := F a ~> G a.


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import syntax_ott
               rules_inf
               Subtyping_inversion.

(* TypedReduce *)
Lemma TypedReduce_toplike :
  forall A, topLike A ->
            forall (v v1 v2: value), TypedReduce v A v1 -> TypedReduce v A v2 -> v1 = v2.
Proof.
  intros A Typ.
  induction Typ;
    introv Red1 Red2.
  - inverts* Red1; try solve [inverts* H1].
    inverts* Red2; try solve [inverts* H2].
  - inversion Red1; subst;
      try solve [invert* H1].
    inversion Red2; subst;
      try solve [invert* H1].
    forwards: IHTyp1 H2 H3.
    forwards: IHTyp2 H4 H6.
    subst*.
Qed.

(* topLike *)
Lemma toplike_not_ord: forall A,
    topLike A -> ord A -> False.
Proof.
  intros A H H0.
  induction H;
  inversion H0.
Qed.

Lemma toplike_super_top: forall A,
    topLike A <-> sub t_top A.
Proof.
  intro A.
  split.
  - intro H.
    induction H.
    + apply sub_reflexivity.
    + apply~ S_andr.
  - intro H.
    induction A;
      try solve [inverts* H].
Qed.

Lemma toplike_sub: forall A B,
    topLike A -> sub A B -> topLike B.
Proof.
  intros A B H H0.
  apply toplike_super_top in H.
  apply toplike_super_top.
  auto_sub.
Qed.

Lemma toplike_decidable : forall A,
    topLike A \/ ~topLike A.
Proof.
  induction A.
  - right.
    unfold not.
    intros H.
    inversion H.
  - left*.
  - right.
    unfold not.
    intros H.
    inversion H.
  - destruct IHA1.
    + destruct IHA2.
      * left*.
      * right.
        unfold not.
        intros H1.
        inverts H1.
        auto.
    + right.
      unfold not.
      intros H0.
      inverts H0.
      auto.
Qed.

(* disjoint *)

Lemma disjoint_eqv: forall A B,
    disjointSpec A B <-> disjoint A B.
Proof.
  intros A B.
  unfold disjointSpec.
  split.
  - gen B.
    induction A;
      introv H;
      induction B;
      try solve [constructor*].
    + (* int int *)
      assert (~topLike t_int). {
        unfold not.
        intro F.
        inversion F.
      }
      forwards: (H t_int); auto_sub.
      contradiction.
    + (* arr arr *)
      exfalso.
      assert (topLike (t_arrow (t_and A1 B1) t_top)). {
        apply H;
        constructor*;
        [apply S_andl1 | apply S_andl2];
        auto_sub.
      }
      inversion H0.
  - intros H C S1 S2.
    apply toplike_super_top.
    gen B C.
    induction* A;
      intros B H;
      [ induction* B | induction* B | skip ];
      intros C S1 S2;
      try solve [inverts H].
    + (* int arr *)
      induction* C;
        inverts S1;
        inverts* S2.
    + (* int and *)
      induction* C;
      inverts H;
      inverts* S1;
      try solve [
        inverts S2;
        [ forwards*: IHB1 |
          forwards*: IHB2 ]
          ].
      assert (T1 : sub (t_and B1 B2) C1) by auto_sub.
      forwards*: IHC1 T1.
      assert (T2 : sub (t_and B1 B2) C2) by auto_sub.
      forwards*: IHC2 T2.
    + (* arr int *)
      induction* C;
        inverts S1;
        inverts* S2.
    + (* arr and *)
      induction* C;
      inverts* H;
      inverts* S1.
      *
        inverts S2;
        forwards*: IHB1.
      *
      assert (T1 : sub (t_and B1 B2) C1) by auto_sub.
      forwards*: IHC1 T1.
      assert (T2 : sub (t_and B1 B2) C2) by auto_sub.
      forwards*: IHC2 T2.
Qed.

Lemma disjoint_domain_type: forall A B C B',
    disjointSpec (t_arrow B C) A -> disjointSpec (t_arrow B' C) A.
Proof.
  intros A B C B' H.
  apply disjoint_eqv in H.
  apply disjoint_eqv.
  induction* A;
    invert* H.
Qed.

Lemma disjoint_and: forall A B C,
    disjointSpec (t_and B C) A <-> disjointSpec B A /\ disjointSpec C A.
Proof.
  split;
  intro H.
  - apply disjoint_eqv in H.
    split;
      apply disjoint_eqv;
      induction A;
      invert* H.
  - destruct H.
    apply disjoint_eqv in H.
    apply disjoint_eqv in H0.
    apply disjoint_eqv.
    induction* A.
Qed.

Lemma disjoint_symmetric: forall A B,
    disjointSpec A B -> disjointSpec B A.
Proof.
  intros A B H.
  unfold disjointSpec in H.
  unfold disjointSpec.
  intros C H0 H1.
  forwards*: H.
Qed.

(* principal types for values*)
Fixpoint principal_type (v:value) : typ :=
  match v with
  | v_top => t_top
  | (v_topv _) => t_top
  | (v_lit i5) => t_int
  | (v_absv e A B) => t_arrow A B
  | (v_merge v1 v2) => t_and (principal_type v1) (principal_type v2)
  end.

Lemma principal_type_disjoint: forall v A B,
    Vtyping v A -> disjointSpec A B -> disjointSpec (principal_type v) B.
Proof.
  intros v A B. gen A B.
  induction v;
    intros C D Typ Dis;
    inverts* Typ;
    simple.
  - forwards*: disjoint_domain_type.
  - apply disjoint_and in Dis.
    lets [DA DB]: Dis.
    forwards Dv1: IHv1 H1 DA.
    forwards Dv2: IHv2 H2 DB.
    apply~ disjoint_and.
Qed.

Lemma principal_types_disjoint: forall v1 A v2 B,
    Vtyping v1 A -> Vtyping v2 B -> disjointSpec A B -> disjointSpec (principal_type v1) (principal_type v2).
Proof.
  intros v1 A v2 B Typ1 Typ2 Dis.
  forwards* D1: principal_type_disjoint Typ1 Dis.
  apply disjoint_symmetric in D1.
  forwards* D2: principal_type_disjoint Typ2 D1.
  apply~ disjoint_symmetric.
Qed.

Lemma absv_typing_principal : forall A B D e,
    Vtyping (v_absv e A D) B -> Vtyping (v_absv e A D) (t_arrow A D).
Proof.
  intros A B D e H.
  inverts H.
  eapply Vtyp_absv.
  apply H3.
  auto.
  auto_sub.
Qed.

Lemma principal_type_checks: forall v A,
    Vtyping v A -> Vtyping v (principal_type v).
Proof.
  intros v A. gen A.
  induction v;
    intros C Typ;
    simple;
    try solve [constructor*].
  - inverts* Typ.
  - forwards*: absv_typing_principal.
  - inverts Typ.
    constructor*.
Qed.

Lemma principal_type_sub: forall v A,
    Vtyping v A -> sub (principal_type v) A.
Proof.
  intros v A H.
  induction H;
    simple;
    try solve [auto_sub].
  - apply~ S_arr.
    auto_sub.
  - assert (S1: sub (t_and (principal_type v1) (principal_type v2)) A) by constructor*.
    assert (S2: sub (t_and (principal_type v1) (principal_type v2)) B) by constructor*.
    forwards*: S_andr S1 S2.
Qed.

(* it requires Top<:Top->Top *)
(* changes. abs doesn't have unique type now *)
Lemma TypedReduce_sub: forall v v' A,
    TypedReduce v A v' -> sub (principal_type v) A.
Proof.
  introv Red.
  induction Red;
    simple;
    try solve [inverts* Typ];
    try solve [auto_sub].
Qed.

Lemma disjoint_val_consistent: forall A B v1 v2,
    disjointSpec A B -> Vtyping v1 A -> Vtyping v2 B -> consistencySpec v1 v2.
Proof.
  intros A B v1 v2 Dis Typ1 Typ2.
  introv Ord Red1 Red2.
  forwards* Sub1': TypedReduce_sub Red1.
  forwards* Sub2': TypedReduce_sub Red2.
  forwards* Dis': principal_types_disjoint Typ1 Typ2.
  assert (Top: topLike A0). {
    unfold disjointSpec in Dis'.
    apply Dis'; assumption.
  }
  exfalso.
  forwards*: toplike_not_ord Top Ord.
Qed.


(** Libraries. *)
Require Import UNIVERSE.
Require Import String.
Require Import CoqlibC.
Require Import LinkingC Smallstep.
(** newly added **)
Require Import BehaviorsC Sem.

Module program_relation.

  Record t :=
    mk
      { rel :> program -> program -> Prop;
        horizontal : forall
            p0_src p1_src p0_tgt p1_tgt
            (REL0: rel p0_src p0_tgt)
            (REL1: rel p1_src p1_tgt),
            rel (p0_src ++ p1_src) (p0_tgt ++ p1_tgt);
        adequacy : forall p_src p_tgt (REL: rel p_src p_tgt),
            improves (sem p_src) (sem p_tgt);
        empty : rel [] [];
      }.

End program_relation.
Hint Resolve program_relation.horizontal.
Hint Resolve program_relation.adequacy.
Hint Resolve program_relation.empty.
Coercion program_relation.rel : program_relation.t >-> Funclass.

Section RUSC.

  Variable R : program_relation.t -> Prop.

  Definition relate_R (p_src p_tgt: program) :=
    forall r (RELIN: R r), r p_src p_tgt.

  Definition self_related (p: program) := relate_R p p.

  Lemma empty_self_related: self_related [].
  Proof. ii. eauto. Qed.

  Lemma self_related_horizontal (p0 p1: program)
        (SELF0: self_related p0)
        (SELF1: self_related p1):
      self_related (p0 ++ p1).
  Proof. ii. eauto. Qed.

  Definition rusc (p_src p_tgt: program):=
    forall (ctx0 ctx1: program)
           (SELF0: self_related ctx0)
           (SELF1: self_related ctx1),
      improves (sem (ctx0 ++ p_src ++ ctx1))
               (sem (ctx0 ++ p_tgt ++ ctx1)).

  Global Program Instance rusc_PreOrder: RelationClasses.PreOrder rusc.
  Next Obligation. unfold rusc, Reflexive. i. refl. Qed.
  (* Vertical Compositionality *)
  Next Obligation. unfold rusc, Transitive. i. etrans; eauto. Qed.

  Lemma rusc_incl (p_src p_tgt: program) (r: program_relation.t)
        (REL: r p_src p_tgt)
        (RELIN: R r):
      rusc p_src p_tgt.
  Proof. unfold rusc. i. eapply program_relation.adequacy. eauto. Qed.

  Lemma rusc_adequacy_left_ctx ctx (p_src p_tgt: program)
        (RUSC: rusc p_src p_tgt)
        (SELF: self_related ctx):
      improves (sem (ctx ++ p_src))
               (sem (ctx ++ p_tgt)).
  Proof.
    specialize (RUSC ctx []).
    rewrite app_nil_r in *. rewrite app_nil_r in *.
    eapply RUSC; eauto. eapply empty_self_related.
  Qed.

  Lemma rusc_adequacy_right_ctx ctx (p_src p_tgt: program)
        (RUSC: rusc p_src p_tgt)
        (SELF: self_related ctx):
      improves (sem (p_src ++ ctx))
               (sem (p_tgt ++ ctx)).
  Proof.
    specialize (RUSC [] ctx).
    eapply RUSC; eauto. eapply empty_self_related.
  Qed.

  Lemma rusc_adequacy (p_src p_tgt: program)
        (RUSC: rusc p_src p_tgt):
      improves (sem p_src) (sem p_tgt).
  Proof.
    specialize (RUSC [] []). ss.
    rewrite app_nil_r in *. rewrite app_nil_r in *.
    eapply RUSC; eapply empty_self_related.
  Qed.

  Lemma rusc_horizontal (p0_src p1_src p0_tgt p1_tgt: program)
        (RUSC0: rusc p0_src p0_tgt)
        (RUSC1: rusc p1_src p1_tgt)
        (SELFSRC0: self_related p0_src)
        (SELFSRC1: self_related p1_src)
        (SELFTGT0: self_related p0_tgt)
        (SELFTGT1: self_related p1_tgt):
      rusc (p0_src ++ p1_src) (p0_tgt ++ p1_tgt).
  Proof.
    unfold rusc in *. i. erewrite <- app_assoc. erewrite <- app_assoc.
    transitivity (sem (ctx0 ++ p0_tgt ++ p1_src ++ ctx1)); eauto.
    { eapply RUSC0; eauto. eapply self_related_horizontal; eauto. }
    rewrite app_assoc. replace (ctx0 ++ p0_tgt ++ p1_tgt ++ ctx1)
                         with ((ctx0 ++ p0_tgt) ++ p1_tgt ++ ctx1); eauto.
    { eapply RUSC1; eauto. eapply self_related_horizontal; eauto. }
    rewrite <- app_assoc; auto.
  Qed.

  Lemma rusc_vertical (p0 p1 p2: program)
        (RUSC0: rusc p0 p1)
        (RUSC1: rusc p1 p2):
      rusc p0 p2.
  Proof. unfold rusc in *. i. etrans; eauto. Qed.

End RUSC.
Hint Resolve self_related_horizontal.
Hint Resolve empty_self_related.

Lemma self_related_mon R0 R1
      (LE: R0 <1= R1):
    self_related R1 <1= self_related R0.
Proof. ii. eauto. Qed.
Hint Resolve self_related_mon.

Lemma rusc_mon R0 R1
      (LE: R0 <1= R1):
    rusc R0 <2= rusc R1.
Proof.
  intros p_src p_tgt RU ctx0 ctx1. i.
  eapply RU; eauto; eapply self_related_mon; eauto.
Qed.
Hint Resolve rusc_mon.


(* "LXM: Better Splittable Pseudorandom Number Generators (and Almost as Fast)"
   Guy L. Steele Jr. and Sebastiano Vigna, OOPSLA 2021. *)
(* Also at https://github.com/ocaml/ocaml/pull/10742/ *)

Require Import Rupicola.Lib.Api.
Require Import Rupicola.Lib.Arrays.
Require Import Rupicola.Lib.WordNotations.
From bedrock2 Require Import BasicC64Semantics.

Coercion co_word_of_Z := word.of_Z (word := word).
#[export] Hint Unfold co_word_of_Z : compiler_side_conditions.

Definition M : word :=
  word.of_Z 0xd1342543de82ef95.

Definition rotl (x: word) (k: Z) :=
  (x <<w word.of_Z k) |w (x >>w word.of_Z (64 - k)).

Definition lxm_next (a s: word) (x: list word) :=
  let/n x0 := ListArray.get x 0 in
  let/n z := s +w x0 in

  let/n z := (z ^w (z >>w 32)) *w 0xdaba0b6eb09322e3 in
  let/n z := (z ^w (z >>w 32)) *w 0xdaba0b6eb09322e3 in
  let/n z := (z ^w (z >>w 32)) in

  let/n s := s *w M +w a in

  let/n q0 := ListArray.get x 0 in
  let/n q1 := ListArray.get x 1 in
  let/n q1 := q1 ^w q0 in
  let/n q0 := rotl q0 24 in
  let/n q0 := q0 ^w q1 ^w (q1 <<w 16) in
  let/n q1 := rotl q1 37 in
  let/n x := ListArray.put x 0 q0 in
  let/n x := ListArray.put x 1 q1 in

  \< s, z, x \>.

Implicit Type R : mem -> Prop.
#[global]
Instance spec_of_lxm_next : spec_of "lxm_next" :=
  fnspec! "lxm_next" a s xptr / x R ~> s' z,
  { requires tr mem :=
      (sizedlistarray_value AccessWord 2%nat xptr x ⋆ R) mem;
    ensures tr' mem' :=
      let '\<sn, zn, xn\> := lxm_next a s x in
      tr = tr' /\
      (sizedlistarray_value AccessWord 2 xptr xn ⋆ R) mem' /\
      s' = sn /\ z = zn  }.

Import SizedListArrayCompiler.
#[local] Hint Unfold rotl : compiler_cleanup.
#[local] Hint Extern 10 => lia : compiler_side_conditions.

Derive lxm_next_br2fn SuchThat
       (defn! "lxm_next"("a", "s", "x") ~> "s", "z" { lxm_next_br2fn },
        implements lxm_next)
       As lxm_next_br2fn_ok.
Proof.
  compile.
Qed.

Definition lxm_next_cbytes := Eval vm_compute in
  list_byte_of_string (ToCString.c_module [("dummy_main_for_static",([],[],cmd.skip)); ("lxm_next",lxm_next_br2fn)]).


(** This file defines the module type of literals. *)
Require Import Containers.Sets Containers.SetListInstance.
Require Export Quote Ergo Containers.OrderedType SetoidList.

(* AVL by default *)
Existing Instance SetAVLInstance.SetAVL_FSet.

(** * The module type [LITERAL] *)
Module Type LITERAL.
  (** Literals must be an extension of the module type [OrderedType]
     because they will be used in finite sets and finite maps. *)
  Parameter t : Type.
  Declare Instance t_OT : OrderedType t.

  (** Special literals for true and false *)
  Parameter ltrue : t.
  Parameter lfalse : t.

  (** Literals can be negated with the function [mk_not]. There are several
     axioms that this function must verify in order to be suitable: it must
     be a morphism for literal equality [eq], it shall be involutive,
     and no literal shall be equal to its negation. *)
  Parameter mk_not : t -> t.

  Axiom mk_not_tf : (mk_not ltrue) === lfalse.
  Declare Instance mk_not_m : Proper (_eq ==> _eq) mk_not.
  Axiom mk_not_compat : forall l l', l === l' <-> (mk_not l) === (mk_not l').
  Axiom mk_not_invol : forall l, (mk_not (mk_not l)) === l.
  Axiom mk_not_fix : forall l, l === (mk_not l) -> False.

  (** Interpretation in an environment *)
  Parameter interp : varmaps -> t -> Prop.
  Axiom interp_mk_not : forall v l, ~~ (interp v l <-> ~ interp v (mk_not l)).

  (** The module also brings sets and sets of sets of literals.
     We use two different instantiation of sets of literals here, namely
     [LSet] and [Clause]. Although they are of course observationally
     equivalent, the reason we make that distinction is because they
     represent different objects and are used in different places. Having
     different names ensures better maintenance and less confusion.

     [LSet] will be used to build partial assignments, ie. sets of literals
     that are considered to be true. [Clause], as its name suggests, will
     be used to represent clauses, ie. a disjunction of literals.
     [CSet], the module of sets of such clauses, will represent their
     conjunctions, and therefore CNF formulas.
     *)
  Notation lset := (@set t t_OT (@SetAVLInstance.SetAVL_FSet t t_OT)).
  Notation clause := (@set t t_OT (@SetListInstance.SetList_FSet t t_OT)).

  Definition clause_OT : OrderedType clause := SOT_as_OT.
  Existing Instance clause_OT.
  Notation cset := (@set clause clause_OT
    (@SetListInstance.SetList_FSet clause clause_OT)).

  (** Expansion of proxy-literals is a distinctive feature of our
     formalization. It allows literals to represent arbitrary formulas
     and be unfolded on the fly. Literals thus come with an [expand]
     function that returns a CNF of literals (encoded as a list of lists).
     This function shall be a morphism for literal equality.
     *)
  Parameter expand : t -> list (list t).

  Axiom expand_compat :
    forall l l', l === l' -> eqlistA (eqlistA _eq) (expand l) (expand l').

  (** We need some sort of size in order to ensure that expansion
     is a well-founded process, ie. that literals that arise from an
     [expand] are smaller in some sense than the original literal.
     [size] is a morphism, is always positive and is not affected
     by negation.
     *)
  Parameter size : t -> nat.
  Declare Instance size_m : Proper (_eq ==> @eq nat) size.
  Axiom size_pos : forall l, size l > 0.
  Axiom size_mk_not : forall l, size (mk_not l) = size l.

  Fixpoint lsize (l : list t) :=
    match l with
      | nil => O
      | a::q => size a + lsize q
    end.
  Fixpoint llsize (ll : list (list t)) :=
    match ll with
      | nil => O
      | C::qq => lsize C + llsize qq
    end.
  Axiom size_expand :
    forall l, llsize (expand l) < size l.

  (** Finally, there are properties that are not necessary for the
     formalization and correctness proof of the decision procedure,
     but that are required for the completeness proof. They allow
     the completion of a partial well-formed assignment in a total model.

     In particular, it constraints some properties of proxy-literals and the
     interaction between [expand] and [mk_not]. Again, this is not needed for
     the soundness proof.
     *)
  Parameter is_proxy : t -> bool.
  Axiom is_proxy_mk_not : forall l, is_proxy l = is_proxy (mk_not l).
  Declare Instance is_proxy_m : Proper (_eq ==> @eq bool) is_proxy.
  Axiom is_proxy_nil : forall l, is_proxy l = false -> expand l = nil.
  Axiom is_proxy_true : is_proxy ltrue = false.

  Section ExpandNot.
    Variable f : t -> Prop.

    Let fl :=
      (fix l_interp c :=
        match c with
          | nil => False
          | l::q => f l \/ l_interp q
        end).
    Let fll :=
      (fix ll_interp ll :=
        match ll with
          | nil => True
          | c::q => fl c /\ ll_interp q
        end).

    Axiom expand_mk_not :
      forall (H_m : forall l l', l === l' -> (f l <-> f l')),
      forall l, is_proxy l = true ->
        (forall k c, List.In c (expand l) -> List.In k c ->
          ~~(f k <-> ~f (mk_not k))) ->
        ~~(fll (expand l) <-> ~fll (expand (mk_not l))).
  End ExpandNot.
End LITERAL.


Require Import notations.
Import ListNotations.
Local Open Scope list_scope.

Section listlist.
(* Le type inductif listlist permet de construire des listes de listes.
   Le constructeur lnil permet de définir la listlist qui ne contient aucune listes.
   La listlist [ [] ] n'est donc pas vide car elle contient une liste (meme si cette liste est vide).
   Le constructeur lcons concatene une liste à une listlist.
   Chaque liste peut être vue comme une colonne dans un tableau non homogene. *)
Inductive listlist (A:Type) : Type :=
  | lnil : listlist A
  | lcons : list A -> listlist A -> listlist A.

Implicit Arguments lnil [A].
Implicit Arguments lcons [A].

(* Permet de récupérer la n ième colonne d'une [listlist]  *)
Fixpoint get_col {A:Type}(m:listlist A)(n:nat): list A :=
  match m, n with
  | lnil, _ => nil
  | lcons l m', 0 => l
  | lcons l m', S n' => get_col m' n'
  end.

Notation "'{ }" := lnil.
Notation "'{ x , .. , y }" := (lcons x .. (lcons y lnil) ..).

Print lcons.
Open Scope list_scope.
Definition mylistlist := lcons [1,2] lnil.
Eval compute in mylistlist.
Eval compute in '{[7,8,9],[1,2,3]}.


Require Import Coq.Strings.String.
Require Import GDTC.
Require Import CaseStudy.Names.
Require Import CaseStudy.Arith.
Require Import CaseStudy.Bool.

Open Scope string_scope.

Section Type_Test_Section.
  (* Type Testing, of course. *)
  Definition D := AType :+: BType.

  Global Instance Container_D : Container D :=
    PolynomialContainer D.

  Definition tex1 : DType D := tnat D. (* Nat *)
  Definition tex2 : DType D := tbool D. (* Bool *)

  Eval compute in ("Evaluating 'tnat == tnat' as an 'TNat.").
  Eval compute in (eq_DType D tex1 tex1).
  Eval compute in ("Evaluating 'tbool == tbool' as an 'TBool.").
  Eval compute in (eq_DType D tex2 tex2).
  Eval compute in ("Evaluating 'tbool == tnat' as an 'TBool.").
  Eval compute in (eq_DType D tex2 tex1).

End Type_Test_Section.

Section Test_Section.

  Definition E := Arith :+: Bool.
  Let Exp := Fix E.

  Global Instance Container_E : Container E.
    eauto with typeclass_instances.
  Defined.

  Definition ex_1 : Exp :=
    (add E (lit _ 1) (lit _ 2)).
  Definition ex_2 : Exp :=
    (add E (lit _ 5) (lit _ 0)).
  Definition ex_3 : Exp :=
    (cond E (blit _ true) ex_1 ex_2).
  Definition ex_4 : Exp :=
    (cond E (blit _ false) ex_1 ex_2).

  Definition test_typeof e :=
    match (typeof D E e) with
      | Some t1 => DTypePrint _ t1
      | None => "Type Error!"
    end.

  Eval compute in ("The type of '1 + 2' should be tnat.").
  Eval compute in (test_typeof ex_1).
  Eval compute in ("The type of '145 + 2346' should be tnat.").
  Eval compute in (test_typeof ex_2).
  Eval compute in ("The type of 'true' should be tbool.").
  Eval compute in (test_typeof (blit E true)).
  Eval compute in ("The type of 'if true then (1 + 2) else (5 + 0)' should be tnat.").
  Eval compute in (test_typeof ex_3).
  Eval compute in ("The type of 'if false then (1 + 2) else (5 + 0)' should be tnat.").
  Eval compute in (test_typeof ex_4).

  Eval compute in (ExpPrint E ex_1).
  Eval compute in (ExpPrint E ex_2).
  Eval compute in (ExpPrint E ex_3).
  Eval compute in (ExpPrint E ex_4).

  Definition V := StuckValue :+: BotValue :+: NatValue :+: BoolValue.

  Instance Container_V : Container V.
    eauto with typeclass_instances.
  Defined.

  Eval compute in ("Evaluating '1 + 2'").
  Eval compute in (ValuePrint V (eval V E ex_1 nil)).
  Eval compute in ("Evaluating '5 + 0'").
  Eval compute in (ValuePrint V (eval V E ex_2 nil)).
  Eval compute in ("Evaluating 'if true then (1 + 2) else (5 + 0)'").
  Eval compute in (ValuePrint V (eval V E ex_3 nil)).
  Eval compute in ("Evaluating 'if false then (1 + 2) else (5 + 0)'").
  Eval compute in (ValuePrint V (eval V E ex_4 nil)).

  Definition WFV := (WFValue_Bot D V) ::+:: (WFValue_VI D V) ::+:: (WFValue_VB D V).

  Global Instance Container_WFV : IContainer WFV.
    eauto with typeclass_instances.
  Defined.

  Instance typeof_alg : forall T, FAlgebra TypeofName T (typeofR D) E.
    intros; eauto 200 with typeclass_instances.
  Defined.

  Instance eval_alg : forall T, FAlgebra EvalName T (evalR V) E.
    eauto 500 with typeclass_instances.
  Defined.

  Lemma soundness : forall (e : Exp),
    forall T, typeof D E e = Some T ->
      WFValueC D V WFV (eval V E e nil) T.
  Proof.
    intro; apply eval_Soundness; eauto 150 with typeclass_instances.
  Qed.

  Eval compute in ("Type Soundness for Arith :+: Bool Proven!").

End Test_Section.


From fae_gtlc_mu.cast_calculus Require Export types.
From fae_gtlc_mu.backtranslation Require Import cast_help.universe.
From fae_gtlc_mu.stlc_mu Require Export types.
From fae_gtlc_mu Require Export prelude.

(* This file defines the backtranslation on types (fig 6 and equation 1 in paper) *)

Reserved Notation "<< τ >>" (at level 4, τ at next level).
Fixpoint backtranslate_type (τ : cast_calculus.types.type) : type :=
  match τ with
  (* uninteresting cases *)
  | cast_calculus.types.TUnit => TUnit
  | cast_calculus.types.TProd τ1 τ2 => TProd <<τ1>> <<τ2>>
  | cast_calculus.types.TSum τ1 τ2 => TSum <<τ1>> <<τ2>>
  | cast_calculus.types.TArrow τ1 τ2 => TArrow <<τ1>> <<τ2>>
  | cast_calculus.types.TRec τ => TRec <<τ>>
  | cast_calculus.types.TVar x => TVar x
  (* interesting case *)
  | cast_calculus.types.TUnknown => Universe
  end where "<< e >>" := (backtranslate_type e).


Require Export Lia.

Lemma nat_plus_comm : forall x y, x + y = y + x.
Proof.
  intros; nia.
Qed.

Lemma nat_plus_assoc : forall x y z, x + (y + z) = x + y + z.
Proof.
  intros; nia.
Qed.

Lemma nat_mul_comm : forall x y, x * y = y * x.
Proof.
  intros; nia.
Qed.

Lemma nat_mul_assoc : forall x y z, x * (y * z) = x * y * z.
Proof.
  intros; nia.
Qed.

Lemma nat_dist_front : forall x y z, x * (y + z) = x * y + x * z.
Proof.
  intros; nia.
Qed.

Lemma nat_dist_back : forall x y z, (x + y) * z = x * z + y * z.
Proof.
  intros; nia.
Qed.

Ltac inv H := inversion H; subst; clear H.
Ltac refl := try reflexivity.


Require Export Classical.
Require Import ClassicalChoice.
Require Export Relation_Definitions.
Require Import Relation_Definitions_Implicit.
Require Export Ensembles.
Require Import EnsemblesImplicit.
Require Import ProofIrrelevance.
Require Import InverseImage.
Require Export EnsemblesSpec.
Require Import Quotients.

Section ZL'.

Variable T:Type.
Variable R:relation T.
Hypothesis ord:order R.
Definition chain (S: Ensemble T) : Prop :=
  forall x y:T, In S x -> In S y -> (R x y \/ R y x).
Definition maximal (x:T) : Prop :=
  forall y:T, R x y -> x = y.
Variable chain_sup: forall S: Ensemble T, chain S ->
  { x:T | (forall y:T, In S y -> R y x) /\
    (forall z:T, (forall y:T, In S y -> R y z) -> R x z) }.
Variable inflation: forall x:T,
  { y:T | R x y /\ x <> y /\ forall z:T, R x z -> R z y ->
                                     z = x \/ z = y }.

Inductive tower : Ensemble T :=
  | sup_intro: forall (S: Ensemble T), Included S tower ->
      forall c:chain S,
      In tower (proj1_sig (chain_sup S c))
  | inflation_intro: forall x:T, In tower x ->
      In tower (proj1_sig (inflation x)).

Lemma tower_is_chain: chain tower.
Proof.
unfold chain.
intros.
revert x H.
induction H0.
- intros.
  case (classic (forall y:T, In S y -> R y x)).
  + right.
    now apply (proj2_sig (chain_sup S c)).
  + intro.
    left.
    apply not_all_ex_not in H2.
    destruct H2.
    apply imply_to_and in H2.
    destruct H2.
    apply (ord_trans ord) with x0.
    * pose proof (H0 x0 H2 x H1).
      tauto.
    * now apply (proj2_sig (chain_sup S c)).
- pose proof (proj2_sig (inflation x)).
  destruct H0, H1.
  remember (proj1_sig (inflation x)) as x'.
  assert (forall y:T, In tower y -> R y x \/ R x' y).
  + intros.
    induction H3.
    * case (classic (forall x0:T, In S x0 -> R x0 x)); trivial.
      left.
      now apply (proj2_sig (chain_sup S c)).
      right.
      apply not_all_ex_not in H5.
      destruct H5.
      apply imply_to_and in H5.
      destruct H5.
      apply (ord_trans ord) with x0.
      ** pose proof (H4 x0).
         tauto.
      ** now apply (proj2_sig (chain_sup S c)).
    * assert (In tower x').
      rewrite Heqx'.
      now apply inflation_intro.
      destruct IHtower0.
      ** assert (In tower (proj1_sig (inflation x0))) by now apply inflation_intro.
         case (IHtower (proj1_sig (inflation x0)) H6);
         [ now left | ].
         intro.
         pose proof (proj2_sig (inflation x0)).
         simpl in H8.
         assert (x = x0 \/ x = proj1_sig (inflation x0)) by now apply H8.
         case H9.
         *** right.
             rewrite Heqx', H10.
             apply (ord_refl ord).
         *** left.
             rewrite H10.
             apply (ord_refl ord).
      ** right.
         now apply (ord_trans ord) with x0, (proj2_sig (inflation x0)).
  + intros.
    case (H3 x0 H4).
    * left.
      now apply (ord_trans ord) with x.
    * now right.
Qed.

(* can now show the given hypotheses are contradictory *)
Lemma ZL': False.
Proof.
pose proof (proj2_sig (chain_sup tower tower_is_chain)).
simpl in H.
remember (proj1_sig (chain_sup tower tower_is_chain)) as x0.
assert (In tower x0).
rewrite Heqx0.
constructor 1.
auto with sets.

pose (x' := proj1_sig (inflation x0)).
assert (In tower x') by now constructor 2.

pose proof (proj2_sig (inflation x0)).
destruct H2, H3.
contradict H3.
apply (ord_antisym ord); trivial.
destruct H.
now apply H.
Qed.

End ZL'.

Arguments chain {T}.
Arguments maximal {T}.

Require Export EnsemblesSpec.

Section ZL.

(* get rid of the need for a sup function and immediate successors *)

Variable T:Type.
Variable R:relation T.
Hypothesis ord: order R.
Hypothesis ub_of_chain: forall S:Ensemble T, chain R S ->
  exists x:T, forall y:T, In S y -> R y x.

Definition chains := {S:Ensemble T | chain R S}.
Definition chains_ord := (fun S1 S2:chains =>
  Included (proj1_sig S1) (proj1_sig S2)).

Lemma chains_order: order chains_ord.
Proof.
constructor.
- unfold reflexive, chains_ord.
  auto with sets.
- unfold transitive, chains_ord.
  auto with sets.
- intros [?] [?] ? ?.
  apply subset_eq_compat.
  auto with sets.
Qed.

Definition chains_sup_def : forall F: Ensemble chains,
  chain chains_ord F -> chains.
refine (fun F H => exist _ [ x:T | exists S:chains, In F S /\
                             In (proj1_sig S) x ] _).
red; intros.
destruct H0, H1, H0, H1.
pose proof (H x0 x1).
destruct x0, x1, H0, H1.
apply H2 in H0; trivial.
destruct H0;
  apply c0 + apply c;
  trivial;
  now apply H0.
Defined.

Lemma chains_sup_correct (F : Ensemble chains) (P : chain chains_ord F) :
  let U := chains_sup_def F P in
    (forall S:chains, In F S -> chains_ord S U) /\
    (forall T:chains, (forall S:chains, In F S -> chains_ord S T) ->
      chains_ord U T).
Proof.
intros.
unfold chains_ord, Included, U.
split;
  intros.
- constructor.
  now exists S.
- destruct H0 as [[x0 [? H1]]].
  now apply H in H1.
Qed.

Definition chains_sup (F:Ensemble chains) (P:chain chains_ord F) :=
  let U := chains_sup_def F P in
  exist (fun U:chains =>
    (forall S:chains, In F S -> chains_ord S U) /\
    (forall T:chains, (forall S:chains, In F S -> chains_ord S T) ->
      chains_ord U T))
  (chains_sup_def F P) (chains_sup_correct F P).

Lemma chains_ord_exists (x : chains) :
  (forall x:T, exists y:T, R x y /\ x <> y) ->
  exists y : chains, chains_ord x y /\ x <> y /\ (forall z : chains, chains_ord x z -> chains_ord z y -> z = x \/ z = y).
Proof.
intro H3.
destruct x,
  (ub_of_chain x c),
  (H3 x0).
pose (x' := Add x x1).
assert (chain R x').
- red.
  intros.
  case H1.
  + case H2;
      intros.
    * now apply c.
    * destruct H4.
      left.
      apply ord_trans with x0;
        now apply H + destruct H0.
  + intros x3 [].
    destruct H2 as [? | ? []].
    * right.
      apply ord_trans with x0;
        now apply H + destruct H0.
    * left.
      now apply ord_refl.
- exists (exist _ x' H1).
  unfold chains_ord.
  repeat split;
    intros.
  + now constructor.
  + intuition.
    injection H2.
    intro.
    assert (In x x1) by
      (rewrite H0; now constructor 2).
    contradict H5.
    now apply (ord_antisym ord), H.
  + destruct z, (classic (In x2 x1));
    [ right | left ];
      apply subset_eq_compat, Extensionality_Ensembles;
      split; trivial;
      red; intros.
    * case H6; trivial.
      now intros ? [].
    * assert (In x' x3) by now apply H4.
      inversion H7; trivial.
      now destruct H8.
Qed.

Theorem ZornsLemma: exists x:T, maximal R x.
Proof.
pose proof (ZL' chains chains_ord chains_order chains_sup).

apply NNPP.
unfold maximal.
pose proof chains_ord_exists.
dintuition.
assert (forall x:T, exists y:T, R x y /\ x <> y).
- assert (forall x:T, ~ forall y:T, R x y -> x = y)
    by now apply not_ex_all_not.
  assert (forall x:T, exists y:T, ~ (R x y -> x = y)) as H3
    by (intro; now apply not_all_ex_not).
  intro.
  destruct (H3 x) as [x0 H4].
  exists x0.
  now apply imply_to_and.
- assert (forall x:chains, exists y:chains,
    chains_ord x y /\ x <> y /\ forall z:chains, chains_ord x z ->
    chains_ord z y -> z = x \/ z = y) by intuition.
  apply choice in H3.
  destruct H3 as [f].
  apply H.
  intro.
  exists (f x).
  apply H3.
Qed.

End ZL.

Arguments ZornsLemma {T}.

Section ZL_preorder.

Variable T:Type.
Variable R:relation T.
Hypothesis Rpreord: preorder R.
Hypothesis ub_of_chain: forall S:Ensemble T, chain R S ->
  exists x:T, forall y:T, In S y -> R y x.

Definition premaximal (x:T) : Prop :=
  forall y:T, R x y -> R y x.

Local Definition Requiv (x y:T) := R x y /\ R y x.

Local Lemma equivalence_Requiv : equivalence Requiv.
Proof.
constructor.
- intro.
  split; now apply preord_refl.
- intros x y z [H0 H1] [H2 H3].
  split; now apply preord_trans with y.
- intros x y [H1 H2].
  now split.
Qed.

Lemma ZornsLemmaForPreorders: exists x:T, premaximal x.
Proof.
pose (Requiv (x y:T) := R x y /\ R y x).
pose equivalence_Requiv as H.
pose (Rquo := quotient Requiv).
let Hnew:=fresh"_H" in
  unshelve refine (let Hnew:=_ in
     let inducedR := induced_function2arg R H H Hnew in
     let inducedR_prop := induced_function2arg_correct R H H Hnew in _).
- intros.
  assert (True_rect (R a1 b1) = True_rect (R a2 b2)).
  + apply Extensionality_Ensembles; split; red; intros.
    * destruct x.
      red in H2.
      simpl in H2.
      red; simpl.
      apply preord_trans with a1; trivial.
      ** apply H0.
      ** apply preord_trans with b1; trivial.
         apply H1.
    * destruct x.
      red in H2; simpl in H2.
      red; simpl.
      apply preord_trans with a2; trivial.
      ** apply H0.
      ** apply preord_trans with b2; trivial.
         apply H1.
  + now assert (True_rect (R a1 b1) I = True_rect (R a2 b2) I) by now rewrite H2.
- clearbody inducedR_prop.
  fold inducedR in inducedR_prop.
  assert (exists x:Rquo, maximal inducedR x).
  + apply ZornsLemma.
    * constructor.
      red; intros xbar.
      ** destruct (quotient_projection_surjective xbar) as [x []].
         rewrite inducedR_prop.
         now apply preord_refl.
      ** red; intros xbar ybar zbar ? ?.
         destruct (quotient_projection_surjective xbar) as [x].
         destruct (quotient_projection_surjective ybar) as [y].
         destruct (quotient_projection_surjective zbar) as [z].
         subst.
         rewrite inducedR_prop in *.
         now apply preord_trans with y.
      ** red; intros xbar ybar ? ?.
         destruct (quotient_projection_surjective xbar) as [x].
         destruct (quotient_projection_surjective ybar) as [y].
         subst.
         rewrite inducedR_prop in H0, H1.
         unfold quotient_projection.
         apply subset_eq_compat, R_impl_equality_of_equiv_class; trivial.
         now split.
    * intros Sbar ?.
      pose (S := inverse_image (quotient_projection _) Sbar).
      unshelve refine (let H1:=ub_of_chain S _ in _).
      ** red; intros.
         pose proof (H0 (quotient_projection _ x) (quotient_projection _ y)).
         rewrite 2 inducedR_prop in H3.
         destruct H1, H2.
         now apply H3.
      ** destruct H1.
         exists (quotient_projection _ x).
         intros ybar ?.
         destruct (quotient_projection_surjective ybar) as [y].
         destruct H3.
         rewrite inducedR_prop.
         apply H1.
         now constructor.
    + destruct H0 as [xbar],
               (quotient_projection_surjective xbar) as [x], H1.
      exists x.
      red; intros.
      red in H0.
      unshelve refine (let H2:=H0 (quotient_projection Requiv y) _ in _).
      * now rewrite inducedR_prop.
      * unfold quotient_projection in H2.
        injection H2; intros.
        assert (In (equiv_class Requiv x) y).
        ** rewrite H3.
           constructor.
           now apply equiv_refl.
        ** now destruct H4 as [[? ?]].
Qed.

End ZL_preorder.

Arguments premaximal {T}.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e256m2e224p2e192p2e96m1_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


(** * The schemes
      This file contains the defintion of schemes (polymorphic types) [schm] and
      some auxiliary definitions.
    *)

Set Implicit Arguments.

Require Import SimpleTypes.
Require Import Arith.Arith_base List Omega.
Require Import Wellfounded.Lexicographic_Product.
Require Import Relation_Operators.
Require Import Coq.Setoids.Setoid.
Require Import LibTactics.

Require Import LibTactics.

(** * Schemes *)

Inductive schm : Type :=
| sc_var : id -> schm
| sc_con : id -> schm
| sc_gen : id -> schm
| sc_arrow : schm -> schm -> schm.

(** * It converts a simple type into a scheme  *)

Fixpoint ty_to_schm (tau : ty) : schm :=
  match tau with
  | var n => sc_var n
  | con n => sc_con n
  | arrow t1 t2 => sc_arrow (ty_to_schm t1) (ty_to_schm t2)
  end.

(** * Free variables of schemes *)

Fixpoint FV_schm (sigma : schm) : list id :=
  match sigma with
  | sc_var i => i::nil
  | sc_arrow l r => (FV_schm l) ++ (FV_schm r)
  | _ => nil
  end.

Fixpoint max_gen_vars (sigma : schm) : nat :=
  match sigma with
  | sc_con _ => 0
  | sc_var _ => 0
  | sc_gen i => S i
  | sc_arrow s1 s2 => max (max_gen_vars s1) (max_gen_vars s2)
  end.

Fixpoint max_vars_schm (sigma : schm) : nat :=
  match sigma with
  | sc_con _ => 0
  | sc_var i => i
  | sc_gen _ => 0
  | sc_arrow s1 s2 => max (max_vars_schm s1) (max_vars_schm s2)
  end.


Require Omega.

Ltac termination_by_omega :=
  Coq.Program.Tactics.program_simpl;
  simpl;Omega.omega.

Fixpoint set_size {a} (s : Set_ a) : nat :=
  match s with
  | Tip => 0
  | Bin _ _ s1 s2 => 1 + set_size s1 + set_size s2
  end.

Require Import GHC.Err.

Instance Set_Default {a} : Default (Set_ a) :=
  Build_Default _ Tip.
Instance MergeSetDefault {a} : Default (MergeSet a) :=
  Build_Default _ (Mk_MergeSet default).


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

(************************************************************************)
(*   This file has been modified for the purposes of the HoTT library.  *)
(************************************************************************)

Set Implicit Arguments.

Require Import Basics.Logic.

Global Set Universe Polymorphism.
Global Set Asymmetric Patterns.
Global Set Primitive Projections.
Global Set Nonrecursive Elimination Schemes.
Local Unset Elimination Schemes.

Local Set Polymorphic Inductive Cumulativity.

(** [option A] is the extension of [A] with an extra element [None] *)

Inductive option (A : Type) : Type :=
  | Some : A -> option A
  | None : option A.

Scheme option_rect := Induction for option Sort Type.

Arguments Some {A} a.
Arguments None {A}.

Register option as core.option.type.

(** [sum A B], written [A + B], is the disjoint sum of [A] and [B] *)

Inductive sum (A B : Type) : Type :=
  | inl : A -> sum A B
  | inr : B -> sum A B.

Scheme sum_rect := Induction for sum Sort Type.

Notation "x + y" := (sum x y) : type_scope.

Arguments inl {A B} _ , [A] B _.
Arguments inr {A B} _ , A [B] _.

(* A notation for coproduct that's less overloaded than [+] *)
Notation "x |_| y" := (sum x y) (only parsing) : type_scope.

(** [prod A B], written [A * B], is the product of [A] and [B];
    the pair [pair A B a b] of [a] and [b] is abbreviated [(a,b)] *)

Record prod (A B : Type) := pair { fst : A ; snd : B }.

Scheme prod_rect := Induction for prod Sort Type.

Arguments pair {A B} _ _.
Arguments fst {A B} _ / .
Arguments snd {A B} _ / .

Add Printing Let prod.

Notation "x * y" := (prod x y) : type_scope.
Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
Notation "A /\ B" := (prod A B) (only parsing) : type_scope.
Notation and := prod (only parsing).
Notation conj := pair (only parsing).

#[export] Hint Resolve pair inl inr : core.

Definition prod_curry (A B C : Type) (f : A -> B -> C)
  (p : prod A B) : C := f (fst p) (snd p).

(** [iff A B], written [A <-> B], expresses the equivalence of [A] and [B] *)

Definition iff (A B : Type) := prod (A -> B) (B -> A).

Notation "A <-> B" := (iff A B) : type_scope.

(** Another way of interpreting booleans as propositions *)

(* Definition is_true b := b = true. *)

(** Polymorphic lists and some operations *)

Inductive list (A : Type) : Type :=
 | nil : list A
 | cons : A -> list A -> list A.

Scheme list_rect := Induction for list Sort Type.

Arguments nil {A}.
Declare Scope list_scope.
Infix "::" := cons : list_scope.
Delimit Scope list_scope with list.
Bind Scope list_scope with list.

Local Open Scope list_scope.
(** Concatenation of two lists *)

Definition app (A : Type) : list A -> list A -> list A :=
  fix app l m :=
  match l with
   | nil => m
   | a :: l1 => a :: app l1 m
  end.

Infix "++" := app : list_scope.


(************************************************************************)
(*  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        *)
(************************************************************************)

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

Require Export Rbase.
Comments "Lemmas used by the tactic Fourier".

Open Scope R_scope.

Lemma Rfourier_lt : forall x1 y1 a:R, x1 < y1 -> 0 < a -> a * x1 < a * y1.
intros; apply Rmult_lt_compat_l; assumption.
Qed.

Lemma Rfourier_le : forall x1 y1 a:R, x1 <= y1 -> 0 < a -> a * x1 <= a * y1.
red in |- *.
intros.
case H; auto with real.
Qed.

Lemma Rfourier_lt_lt :
 forall x1 y1 x2 y2 a:R,
   x1 < y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2.
intros x1 y1 x2 y2 a H H0 H1; try assumption.
apply Rplus_lt_compat.
try exact H.
apply Rfourier_lt.
try exact H0.
try exact H1.
Qed.

Lemma Rfourier_lt_le :
 forall x1 y1 x2 y2 a:R,
   x1 < y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2.
intros x1 y1 x2 y2 a H H0 H1; try assumption.
case H0; intros.
apply Rplus_lt_compat.
try exact H.
apply Rfourier_lt; auto with real.
rewrite H2.
rewrite (Rplus_comm y1 (a * y2)).
rewrite (Rplus_comm x1 (a * y2)).
apply Rplus_lt_compat_l.
try exact H.
Qed.

Lemma Rfourier_le_lt :
 forall x1 y1 x2 y2 a:R,
   x1 <= y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2.
intros x1 y1 x2 y2 a H H0 H1; try assumption.
case H; intros.
apply Rfourier_lt_le; auto with real.
rewrite H2.
apply Rplus_lt_compat_l.
apply Rfourier_lt; auto with real.
Qed.

Lemma Rfourier_le_le :
 forall x1 y1 x2 y2 a:R,
   x1 <= y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 <= y1 + a * y2.
intros x1 y1 x2 y2 a H H0 H1; try assumption.
case H0; intros.
red in |- *.
left; try assumption.
apply Rfourier_le_lt; auto with real.
rewrite H2.
case H; intros.
red in |- *.
left; try assumption.
rewrite (Rplus_comm x1 (a * y2)).
rewrite (Rplus_comm y1 (a * y2)).
apply Rplus_lt_compat_l.
try exact H3.
rewrite H3.
red in |- *.
right; try assumption.
auto with real.
Qed.

Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x.
intros x H; try assumption.
rewrite Rplus_comm.
apply Rle_lt_0_plus_1.
red in |- *; auto with real.
Qed.

Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y.
intros x y H H0; try assumption.
replace 0 with (x * 0).
apply Rmult_lt_compat_l; auto with real.
ring.
Qed.

Lemma Rlt_zero_1 : 0 < 1.
exact Rlt_0_1.
Qed.

Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x.
intros x H; try assumption.
case H; intros.
red in |- *.
left; try assumption.
apply Rlt_zero_pos_plus1; auto with real.
rewrite <- H0.
replace (1 + 0) with 1.
red in |- *; left.
exact Rlt_zero_1.
ring.
Qed.

Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y.
intros x y H H0; try assumption.
case H; intros.
red in |- *; left.
apply Rlt_mult_inv_pos; auto with real.
rewrite <- H1.
red in |- *; right; ring.
Qed.

Lemma Rle_zero_1 : 0 <= 1.
red in |- *; left.
exact Rlt_zero_1.
Qed.

Lemma Rle_not_lt : forall n d:R, 0 <= n * / d -> ~ 0 < - n * / d.
intros n d H; red in |- *; intros H0; try exact H0.
generalize (Rgt_not_le 0 (n * / d)).
intros H1; elim H1; try assumption.
replace (n * / d) with (- - (n * / d)).
replace 0 with (- -0).
replace (- (n * / d)) with (- n * / d).
replace (-0) with 0.
red in |- *.
apply Ropp_gt_lt_contravar.
red in |- *.
exact H0.
ring.
ring.
ring.
ring.
Qed.

Lemma Rnot_lt0 : forall x:R, ~ 0 < 0 * x.
intros x; try assumption.
replace (0 * x) with 0.
apply Rlt_irrefl.
ring.
Qed.

Lemma Rlt_not_le_frac_opp : forall n d:R, 0 < n * / d -> ~ 0 <= - n * / d.
intros n d H; try assumption.
apply Rgt_not_le.
replace 0 with (-0).
replace (- n * / d) with (- (n * / d)).
apply Ropp_lt_gt_contravar.
try exact H.
ring.
ring.
Qed.

Lemma Rnot_lt_lt : forall x y:R, ~ 0 < y - x -> ~ x < y.
unfold not in |- *; intros.
apply H.
apply Rplus_lt_reg_r with x.
replace (x + 0) with x.
replace (x + (y - x)) with y.
try exact H0.
ring.
ring.
Qed.

Lemma Rnot_le_le : forall x y:R, ~ 0 <= y - x -> ~ x <= y.
unfold not in |- *; intros.
apply H.
case H0; intros.
left.
apply Rplus_lt_reg_r with x.
replace (x + 0) with x.
replace (x + (y - x)) with y.
try exact H1.
ring.
ring.
right.
rewrite H1; ring.
Qed.

Lemma Rfourier_gt_to_lt : forall x y:R, y > x -> x < y.
unfold Rgt in |- *; intros; assumption.
Qed.

Lemma Rfourier_ge_to_le : forall x y:R, y >= x -> x <= y.
intros x y; exact (Rge_le y x).
Qed.

Lemma Rfourier_eqLR_to_le : forall x y:R, x = y -> x <= y.
exact Req_le.
Qed.

Lemma Rfourier_eqRL_to_le : forall x y:R, y = x -> x <= y.
exact Req_le_sym.
Qed.

Lemma Rfourier_not_ge_lt : forall x y:R, (x >= y -> False) -> x < y.
exact Rnot_ge_lt.
Qed.

Lemma Rfourier_not_gt_le : forall x y:R, (x > y -> False) -> x <= y.
exact Rnot_gt_le.
Qed.

Lemma Rfourier_not_le_gt : forall x y:R, (x <= y -> False) -> x > y.
exact Rnot_le_lt.
Qed.

Lemma Rfourier_not_lt_ge : forall x y:R, (x < y -> False) -> x >= y.
exact Rnot_lt_ge.
Qed.


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

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

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

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

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

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

Theorem theorem0 : forall (x : natural), eq (plus x (Succ x)) (Succ (plus x x)).
Proof.
induction x.
  - simpl. rewrite IHx. f_equal.
    rewrite lem.
    lfind. Admitted.