Require Import Coq.Bool.Bool.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Coq.nsatz.Nsatz.
Require Import Coq.micromega.Lia.
Require Import Crypto.Arithmetic.UniformWeight.
Require Import Crypto.Arithmetic.Saturated.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Arithmetic.WordByWordMontgomery.

Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.ZUtil.Notations.
Require Import Crypto.Arithmetic.Partition.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.TruncatingShiftl.
Require Import Crypto.Util.ZUtil.Modulo.
Require Import Crypto.Util.ZUtil.Testbit.
Require Import Crypto.Util.ZUtil.Shift.
Require Import Crypto.Util.ZUtil.Div.
Require Import Crypto.Util.ZUtil.Lor.
Require Import Crypto.Util.ZUtil.Land.
Require Import Crypto.Util.ZUtil.ArithmeticShiftr.
Require Import Crypto.Util.ZUtil.TwosComplement.
Require Import Crypto.Util.ZUtil.SignBit.
Require Import Crypto.Util.ZUtil.Pow.

Import Positional.
Import ListNotations.
Import Definitions.

(** An implementation of the divsteps2 algorithm from "Fast constant-time gcd computation and modular inversion."
   by D. J. Bernstein et al. See the file inversion-c/readme.txt for generation of C-code.
   For a C-implementation using this generated code to implement modular inversion, see inversion-c/test-inversion.c. **)

Local Coercion Z.of_nat : nat >-> Z.

Local Open Scope Z_scope.

(************* *)
(**Definitions *)
(************* *)

(*Evaluation function for multi-limb integers in twos complement *)
Definition eval_twos_complement machine_wordsize n f :=
  dlet eval_f := eval (uweight machine_wordsize) n f in
        Z.twos_complement (machine_wordsize * Z.of_nat n) eval_f.

(*Saturated addition of multi-limb integers *)
Local Definition sat_add machine_wordsize n f g :=
  fst (Rows.add (uweight machine_wordsize) n f g).

(*Saturated (logical) right shift *)
Definition sat_shiftr machine_wordsize n f :=
  (map
    (fun i =>
       Z.lor (Z.shiftr (nth_default 0 f i) 1)
             (Z.truncating_shiftl machine_wordsize
                           (nth_default 0 f (S i))
                           (machine_wordsize - 1)))
    (seq 0 (n - 1))) ++ [(nth_default 0 f (n - 1)) >> 1].

(* arithmetic right shift of saturated multi-limb integers *)
Definition sat_arithmetic_shiftr1 machine_wordsize n f :=
  (map
     (fun i =>
        ((nth_default 0 f i) >> 1) |' (Z.truncating_shiftl machine_wordsize
                                                    (nth_default 0 f (i + 1))
                                                    (machine_wordsize - 1)))
     (seq 0 (n - 1)))
    ++ [Z.arithmetic_shiftr1 machine_wordsize (nth_default 0 f (n - 1))].

(* Multi-limb parity check *)
Definition sat_mod2 f :=
  nth_default 0 f 0 mod 2.

Definition sat_one n := cons 1 (zeros (n - 1)).

Definition sat_opp machine_wordsize n f :=
  sat_add machine_wordsize n
          (sat_one n)
          (map (fun i => Z.lnot_modulo i (2^machine_wordsize)) f).

Definition sat_zero n :=
  zeros n.

(*********************************************************************** *)
(**Section for small independent lemmas which do not fit anywhere else   *)
(*********************************************************************** *)

Lemma eval_bound machine_wordsize n f
      (mw0 : 0 < machine_wordsize)
      (Hz : forall z, In z f -> 0 <= z < 2^machine_wordsize)
      (Hf : length f = n) :
  0 <= eval (uweight machine_wordsize) n f < 2 ^ (machine_wordsize * n).
Proof.
  generalize dependent n; induction f; intros; subst; simpl in *.
  - rewrite eval0, Z.mul_0_r, Z.pow_0_r; lia.
  - rewrite eval_cons, uweight_eval_shift, uweight_0, uweight_eq_alt' by lia.
    assert (0 <= 2 ^ machine_wordsize) by (apply Z.pow_nonneg; lia).
    specialize (IHf (fun z H => Hz z (or_intror H)) (length f) eq_refl).
    specialize (Hz a (or_introl eq_refl)).
    split; ring_simplify; rewrite Z.mul_1_r.
    + nia.
    + replace (machine_wordsize * Z.pos (Pos.of_succ_nat (length f))) with
        (machine_wordsize + machine_wordsize * Z.of_nat (length f)) by nia.
      rewrite Z.pow_add_r; nia. Qed.

(****************************************************************************** *)
(**Section for lemma relating to bitwise operations and the Z.testbits function *)
(****************************************************************************** *)

Lemma eval_testbit machine_wordsize n f m
      (Hz : forall z, In z f -> 0 <= z < 2^machine_wordsize)
      (mw0 : 0 < machine_wordsize)
      (Hf : length f = n)
      (Hm : 0 <= m) :
  Z.testbit (eval (uweight machine_wordsize) n f) m =
  Z.testbit (nth_default 0 f (Z.abs_nat (m / machine_wordsize))) (m mod machine_wordsize).
Proof.
  generalize dependent n. generalize dependent m. induction f; intros; simpl in *; subst.
  - rewrite ListUtil.nth_default_nil, eval0, !Z.testbit_0_l; reflexivity.
  - rewrite eval_cons, uweight_eval_shift
      by (specialize (Hz a (or_introl eq_refl)); lia).
    rewrite uweight_0, uweight_eq_alt', Z.mul_1_l, Z.mul_1_r, Z.mul_comm, <- Z.shiftl_mul_pow2, Shift.Z.testbit_add_shiftl_full
      by (specialize (Hz a (or_introl eq_refl)); lia).
    destruct (m <? machine_wordsize) eqn:E.
    + rewrite Z.ltb_lt in E; rewrite Z.div_small by lia.
      rewrite ListUtil.nth_default_cons, Z.mod_small by lia. reflexivity.
    + rewrite Z.ltb_ge in E; rewrite IHf; try lia.
      replace (Z.abs_nat (m / machine_wordsize)) with
          (S (Z.abs_nat ((m - machine_wordsize) / machine_wordsize))).
      rewrite ListUtil.nth_default_cons_S, PullPush.Z.sub_mod_r, Z_mod_same_full, Z.sub_0_r; reflexivity.
      rewrite <- Zabs2Nat.inj_succ_abs, Z.abs_eq.
      replace machine_wordsize with (1 * machine_wordsize) at 1 by ring.
      rewrite Div.Z.div_sub, Z.sub_1_r, Z.succ_pred; lia.
      apply Div.Z.div_nonneg; lia.
      intros; specialize (Hz z); tauto. Qed.

(**************************************************** *)
(**Functional correctness of multi-limb logical shift *)
(**************************************************** *)

Lemma eval_sat_shiftr machine_wordsize n f
      (mw0 : 0 < machine_wordsize)
      (Hf : length f = n)
      (Hz : forall z, In z f -> 0 <= z < 2^machine_wordsize) :
  eval (uweight machine_wordsize) n (sat_shiftr machine_wordsize n f) =
  eval (uweight machine_wordsize) n f >> 1.
Proof.
  generalize dependent n. induction f; intros; subst.
  - unfold sat_shiftr; simpl; rewrite eval0; reflexivity.
  - unfold sat_shiftr; simpl.
    rewrite eval_cons, uweight_eval_shift by lia.
    destruct f; simpl in *.
    + rewrite
        eval_cons, uweight_0, eval0, ListUtil.nth_default_cons, uweight_eq_alt',
        Z.mul_0_r, !Z.add_0_r, !Z.mul_1_l; reflexivity.
    + rewrite eval_cons, uweight_eval_shift;
        try (rewrite ?length_snoc, ?map_length, ?seq_length; lia).
      replace ((map _ _) ++ _) with (sat_shiftr machine_wordsize (S (length f)) (z :: f)).
      * rewrite IHf; try (intros; try apply Hz; tauto).
        rewrite uweight_0, ListUtil.nth_default_cons_S, uweight_eq_alt'.
        rewrite !ListUtil.nth_default_cons, !Z.mul_1_l, !Z.mul_1_r.
        rewrite <- !Z.div2_spec, !Z.div2_div, Z.div2_split by lia.
        rewrite eval_cons at 2 by reflexivity.
        rewrite uweight_eval_shift, uweight_0, uweight_eq_alt, Z.pow_1_r by lia.
        rewrite PullPush.Z.add_mod_r, PullPush.Z.mul_mod_l.
        replace 2 with (2 ^ 1) at 7 by trivial.
        rewrite Modulo.Z.mod_same_pow, Z.mul_0_l by lia. ring_simplify.
        rewrite Z.mul_1_l, Z.add_0_r, Z.truncating_shiftl_mod by lia. rewrite Z.lor_add; try ring.
        destruct (Z.odd z) eqn:E; rewrite Zmod_odd, E.
        ** specialize (Hz a (or_introl eq_refl)).
           rewrite Z.mul_1_r, Z.land_div2; rewrite ?Z.sub_simpl_r; lia.
        ** now rewrite Z.mul_0_r, Z.land_0_r.
      * unfold sat_shiftr. replace (S (length f) - 1)%nat with (length f) by lia.
        apply f_equal2.
        ** apply map_seq_ext; intros; [|lia].
           rewrite Nat.sub_0_r, Nat.add_1_r.
           rewrite !(ListUtil.nth_default_cons_S _ a); reflexivity.
        ** now rewrite ListUtil.nth_default_cons_S. Qed.

(*********************************************************************************** *)
(**Section for properties of the multi-limb addtion including functional correctness *)
(*********************************************************************************** *)

Lemma eval_sat_add machine_wordsize n f g (mw0 : 0 < machine_wordsize) (Hf : length f = n) (Hg : length g = n) :
  eval (uweight machine_wordsize) n (sat_add machine_wordsize n f g) =
  (eval (uweight machine_wordsize) n f + eval (uweight machine_wordsize) n g) mod (2^(machine_wordsize * n)).
Proof.
  unfold sat_add.
  rewrite Rows.add_partitions;
    rewrite ?eval_partition; try assumption; try apply (uwprops machine_wordsize mw0).
  rewrite uweight_eq_alt'; reflexivity. Qed.

Lemma length_sat_add machine_wordsize n f g
      (mw0 : 0 < machine_wordsize)
      (Hf : length f = n)
      (Hg : length g = n) :
  length (sat_add machine_wordsize n f g) = n.
Proof.
  unfold sat_add, Rows.add.
  autorewrite with distr_length. reflexivity.
  apply (uwprops machine_wordsize mw0).
  intros row H; destruct H as [|[H|[]]]; subst; auto. Qed.

#[global]
Hint Rewrite length_sat_add : length_distr.

Lemma sat_add_bounds machine_wordsize n f g
      (mw0 : 0 < machine_wordsize)
      (Hf : length f = n)
      (Hg : length g = n) :
  forall z, In z (sat_add machine_wordsize n f g) -> 0 <= z < 2 ^ machine_wordsize.
Proof.
  pose proof uwprops machine_wordsize mw0.
  intros z Hin; unfold sat_add in *; rewrite Rows.add_partitions in *; auto.
  unfold Partition.partition in Hin. apply ListAux.in_map_inv in Hin.
  destruct Hin as [a [Hin]].
  rewrite H0, !uweight_eq_alt by lia. split.
  - apply Z.div_le_lower_bound;
      ring_simplify; try apply Z.mod_pos_bound;
        apply Z.pow_pos_nonneg; try apply Z.pow_pos_nonneg; lia.
  - apply Z.div_lt_upper_bound.
    apply Z.pow_pos_nonneg; try apply Z.pow_pos_nonneg; lia.
    replace ((_ ^ _) ^ _ * _) with ((2 ^ machine_wordsize) ^ Z.of_nat (S a)).
    apply Z.mod_pos_bound; apply Z.pow_pos_nonneg; try apply Z.pow_pos_nonneg; lia.
    rewrite Z.mul_comm, Pow.Z.pow_mul_base;
    try (replace (Z.of_nat (S a)) with ((Z.of_nat a + 1)) by lia; lia). Qed.

(********************************************************* *)
(**Section on properties of sat_mod2 including correctness *)
(********************************************************* *)

Lemma sat_mod2_cons a f : sat_mod2 (a :: f) = a mod 2.
Proof. unfold sat_mod2. now rewrite ListUtil.nth_default_cons. Qed.

Lemma eval_sat_mod2 machine_wordsize n f
      (Hf : length f = n)
      (Hmw : 0 < machine_wordsize) :
  (eval (uweight machine_wordsize) n f) mod 2 = sat_mod2 f.
Proof.
  generalize dependent Hf. generalize dependent n.
  induction f; intros; simpl in *; subst.
  - unfold sat_mod2. rewrite eval0; reflexivity.
  - rewrite eval_cons by trivial. rewrite uweight_eval_shift by lia.
    rewrite <- Zplus_mod_idemp_r, <- Zmult_mod_idemp_r, IHf by reflexivity.
    unfold uweight, ModOps.weight; simpl.
    rewrite Z.mul_0_r, Z.mul_1_r, !Zdiv_1_r, !Z.opp_involutive, !Z.pow_0_r, Z.mul_1_l.
    rewrite <- Zmult_mod_idemp_l, PullPush.Z.mod_pow_full, Z_mod_same_full, Z.pow_0_l by assumption.
    rewrite Zmod_0_l, Z.add_0_r; reflexivity. Qed.

(*********************************************************************** *)
(**Section for properties of sat_arithmetic_shiftr1 including correctness *)
(*********************************************************************** *)

Lemma eval_sat_arithmetic_shiftr1 machine_wordsize n f
      (mw0 : 0 < machine_wordsize)
      (Hz : forall z, In z f -> 0 <= z < 2^machine_wordsize)
      (Hf : length f = n) :
  eval (uweight machine_wordsize) n (sat_arithmetic_shiftr1 machine_wordsize n f) =
  Z.arithmetic_shiftr1 (machine_wordsize * n) (eval (uweight machine_wordsize) n f).
Proof.
  generalize dependent n.
  induction f as [|z f IHf]; intros; subst.
  - rewrite !eval0; reflexivity.
  - destruct f.
    + cbn; rewrite uweight_0, !Z.mul_1_r, !Z.mul_1_l, !Z.add_0_r; reflexivity.
    + unfold sat_arithmetic_shiftr1; simpl.
      rewrite eval_cons, !uweight_eval_shift by (autorewrite with distr_length; try reflexivity; lia).
      replace (map _ _ ++ _) with (sat_arithmetic_shiftr1 machine_wordsize (S (length f)) (z0 :: f)).
      rewrite IHf; try reflexivity.

      unfold Z.arithmetic_shiftr1.
      rewrite !Z.land_pow2_testbit, !eval_testbit; try tauto; try nia; simpl.
      replace (Z.abs_nat ((machine_wordsize * Z.pos (Pos.succ (Pos.of_succ_nat (length f))) - 1) / machine_wordsize)) with
          (S (Z.abs_nat ((machine_wordsize * Z.pos (Pos.of_succ_nat (length f)) - 1) / machine_wordsize))).
      rewrite !ListUtil.nth_default_cons_S, !ListUtil.nth_default_cons by lia.

      unfold Z.sub.
      rewrite !Modulo.Z.mod_add_l', uweight_0, uweight_eq_alt', !Z.mul_1_l, Z.mul_1_r, Z.truncating_shiftl_mod by lia.
      destruct (Z.testbit
      (nth_default 0 (z0 :: f)
         (Z.abs_nat
            ((machine_wordsize * Z.pos (Pos.of_succ_nat (length f)) + - (1)) /
             machine_wordsize)))
      ((- (1)) mod machine_wordsize)) eqn:E.
      * rewrite <- !Z.div2_spec, !Z.div2_div, !Z.lor_add; ring_simplify.
        rewrite (eval_cons _ (S _)), uweight_eval_shift by (try reflexivity; lia).
        rewrite uweight_0, uweight_eq_alt', !Z.mul_1_l, Z.mul_1_r, Z.div2_split, <- Z.pow_add_r by nia.
        rewrite eval_sat_mod2 by (try reflexivity; lia). unfold sat_mod2.
        rewrite ListUtil.nth_default_cons.
        replace (machine_wordsize + (_ + _)) with
            (machine_wordsize * Z.pos (Pos.succ (Pos.of_succ_nat (length f))) + - (1)) by lia; ring.

        rewrite Z.land_comm, Z.land_pow2_small; [lia|].
        split.
        apply Div.Z.div_nonneg; try lia.
           assert (0 <= eval (uweight machine_wordsize) (S (S (length f))) (z :: z0 :: f)).
           { apply eval_bound; try lia. intros; apply Hz; simpl; tauto. reflexivity. }
           specialize (Hz z (or_introl eq_refl)); nia.
        apply Div.Z.div_lt_upper_bound'; [lia|].
           rewrite Z.mul_comm, Pow.Z.pow_mul_base by nia.
        simpl; rewrite <- Z.add_assoc, Z.add_0_r.
        apply eval_bound; try lia; tauto.

        rewrite Z.land_comm, Z.land_pow2_small; [lia|].
        split.
        apply Div.Z.div_nonneg; [|lia].
        apply eval_bound; [lia| |]. intros; apply Hz; simpl; tauto. reflexivity.

        apply Div.Z.div_lt_upper_bound'; try lia.
        rewrite Z.mul_comm, Pow.Z.pow_mul_base by nia. rewrite <- Z.add_assoc, Z.add_0_r.
        apply eval_bound; try assumption. intros; apply Hz; simpl; tauto. reflexivity.

        rewrite Zmod_odd.
        specialize (Hz z (or_introl eq_refl)).
        destruct (Z.odd z0).
        ** rewrite Z.mul_1_r, Z.land_pow2_small; [reflexivity|]. split.
           apply Div.Z.div_nonneg; lia.
           apply Div.Z.div_lt_upper_bound'; [lia|].
           rewrite Z.mul_comm, Pow.Z.pow_mul_base, Z.sub_simpl_r; lia.
        ** rewrite Z.mul_0_r, Z.land_0_r; reflexivity.
      * rewrite !Z.lor_0_l, (eval_cons _ (S _)), uweight_eval_shift
          by (try reflexivity; lia).
        rewrite uweight_0, uweight_eq_alt', Z.mul_1_l, Z.mul_1_r.
        rewrite <- !Z.div2_spec, !Z.div2_div, Z.div2_split by lia.
        rewrite eval_sat_mod2, sat_mod2_cons, Z.lor_add;
          [reflexivity| |reflexivity|lia].
        rewrite Zmod_odd. specialize (Hz z (or_introl eq_refl)).
        destruct (Z.odd z0).
        ** rewrite Z.mul_1_r, Z.land_pow2_small; try lia.
           split.
           apply Div.Z.div_nonneg; lia.
           apply Div.Z.div_lt_upper_bound'; [lia|].
           rewrite Z.mul_comm, Pow.Z.pow_mul_base, Z.sub_simpl_r; lia.
        ** rewrite Z.mul_0_r, Z.land_0_r; reflexivity.
      * rewrite <- Zabs2Nat.inj_succ.
        apply f_equal.
        rewrite <- Z.add_1_r.
        unfold Z.sub.
        rewrite !Div.Z.div_add_l'; lia.
        set (x := Pos.of_succ_nat (length f)).
        set (a := machine_wordsize). apply Div.Z.div_nonneg; nia.
      * intros; apply Hz; simpl in *; tauto.
      * intros; apply Hz; simpl in *; tauto.
      * unfold sat_arithmetic_shiftr1.
        replace (S (length f) - 1)%nat with (length f) by lia.
        rewrite ListUtil.nth_default_cons_S.
        apply f_equal2; [|reflexivity].
        apply map_seq_ext; [|lia].
        intros; simpl; rewrite !Nat.add_1_r, !(ListUtil.nth_default_cons_S _ z); reflexivity. Qed.

(************************************ *)
(**Properties of sat_one and sat_zero *)
(************************************ *)

Lemma length_sat_one n (Hn : (0 < n)%nat) :
  length (sat_one n) = n.
Proof. unfold sat_one; simpl; rewrite length_zeros; lia. Qed.

#[global]
Hint Rewrite length_sat_one : distr_length.

Lemma eval_sat_one n machine_wordsize
      (Hn : (0 < n)%nat)
      (Hmw : 0 <= machine_wordsize) :
  eval (uweight machine_wordsize) n (sat_one n) = 1.
Proof. unfold sat_one. destruct n. lia.
       rewrite eval_cons, uweight_eval_shift, uweight_0, uweight_1 by (try rewrite length_zeros; lia).
       replace (S n - 1)%nat with n by lia. rewrite eval_zeros; lia. Qed.

Lemma length_sat_zero n :
  length (sat_zero n) = n.
Proof. auto with distr_length. Qed.

Lemma eval_sat_zero machine_wordsize n (mw : 0 < machine_wordsize):
  eval (uweight machine_wordsize) n (sat_zero n) = 0.
Proof. apply eval_zeros. Qed.

(******************************************************** *)
(**Properties of sat_opp including functional correctness *)
(******************************************************** *)

Lemma length_sat_opp machine_wordsize n f
      (mw0 : 0 < machine_wordsize)
      (Hn : (0 < n)%nat)
      (Hf : length f = n) :
  length (sat_opp machine_wordsize n f) = n.
Proof. unfold sat_opp; rewrite length_sat_add; auto with distr_length. Qed.

#[global]
Hint Rewrite length_sat_opp : distr_length.

Lemma eval_sat_opp machine_wordsize n f
      (mw0 : 0 < machine_wordsize)
      (Hn : (0 < n)%nat)
      (Hz : forall z, In z f -> 0 <= z < 2^machine_wordsize)
      (Hf : length f = n) :
  eval (uweight machine_wordsize) n (sat_opp machine_wordsize n f) =
  (- eval (uweight machine_wordsize) n f) mod (2^(machine_wordsize * n)).
Proof.
  assert (2 ^ machine_wordsize <> 0) by (apply Z.pow_nonzero; lia).
  assert (2 ^ (machine_wordsize * Z.of_nat (length f)) <> 0) by (apply Z.pow_nonzero; nia).

  symmetry. unfold sat_opp.
  rewrite eval_sat_add by distr_length.
  generalize dependent n. induction f; intros.
  - simpl in *; rewrite <- Hf; rewrite eval0; rewrite !Zmod_0_l; reflexivity.
  - simpl in *. subst.
    assert (2 ^ (machine_wordsize * Z.of_nat (length f)) <> 0) by (apply Z.pow_nonzero; nia).

    rewrite !eval_cons, uweight_0, !uweight_eval_shift, uweight_eq_alt' by distr_length.
    rewrite !Z.mul_1_l, !Z.mul_1_r, Z.opp_add_distr, Zopp_mult_distr_r, <- Z.add_mod_idemp_r by distr_length.
    symmetry. rewrite Z.add_assoc, <- Z.add_mod_idemp_r; try (rewrite Zpos_P_of_succ_nat in H0; rewrite Nat2Z.inj_succ; assumption).
    replace (2 ^ (machine_wordsize * Z.of_nat (S (length f)))) with
        ((2 ^ machine_wordsize) * (2 ^ (machine_wordsize * Z.of_nat (length f)))).
    rewrite !Z.mul_mod_distr_l by lia.
    unfold Z.lnot_modulo. rewrite Lnot.Z.lnot_equiv. unfold Z.pred.
    destruct (length f) eqn:E.
    + rewrite !eval0.
      rewrite !Z.mul_0_r, !Z.mul_1_r, !Z.add_0_r.
      replace (-a + -1) with (- (a + 1)) by ring.
      rewrite eval_sat_one.
      rewrite Z.mod_opp_small.
      replace (1 + (2 ^ machine_wordsize - (a + 1))) with
          (-a + 2 ^ machine_wordsize) by ring.
      rewrite <- Z.add_mod_idemp_r.
      rewrite Z_mod_same_full. rewrite Z.add_0_r. reflexivity.
      apply Z.pow_nonzero. lia. lia.
      specialize (Hz a (or_introl eq_refl)). lia. lia. lia.
    + rewrite IHf by (try (intros; apply Hz; right; assumption); lia).
      rewrite !eval_sat_one in * by lia.
      rewrite <- Z.mul_mod_distr_l, Z.add_mod_idemp_r by nia.
      symmetry.
      rewrite <- Z.mul_mod_distr_l, Z.add_mod_idemp_r, Z.mul_add_distr_l, Z.mul_1_r by nia.
      replace (-a + -1) with (- (a + 1)) by ring.
      rewrite Z.mod_opp_small.
      unfold Z.lnot_modulo.
      rewrite Z.add_assoc.
      replace (1 + (2 ^ machine_wordsize - (a + 1))) with
          (- a + 2 ^ machine_wordsize) by ring.
      reflexivity.
      specialize (Hz a (or_introl eq_refl)); lia.
    + rewrite <- Z.pow_add_r; try apply f_equal; nia. Qed.

Lemma sat_opp_mod2 machine_wordsize n f
      (mw0 : 0 < machine_wordsize)
      (Hn : (0 < n)%nat)
      (Hf : length f = n)
      (Hz : forall z, In z f -> 0 <= z < 2^machine_wordsize) :
  sat_mod2 (sat_opp machine_wordsize n f) = sat_mod2 f.
Proof.
  rewrite <- !(eval_sat_mod2 machine_wordsize n) by distr_length.
  rewrite eval_sat_opp; auto.
  set (x := eval (uweight machine_wordsize) n f).
  destruct f.
  - subst. reflexivity.
  - rewrite <- (Znumtheory.Zmod_div_mod _ (2 ^ (machine_wordsize * Z.of_nat n))).
    rewrite <- Z.opp_mod2; reflexivity. lia. apply Z.pow_pos_nonneg; nia.
    apply Zpow_facts.Zpower_divide. simpl in *. nia. Qed.

(*********************************** *)
(**Properties of twos_complement_opp *)
(*********************************** *)

Lemma twos_complement_opp_bound m a (Hm : 0 <= m) :
  0 <= Z.twos_complement_opp m a < 2 ^ m.
Proof. unfold Z.twos_complement_opp; apply Z.mod_pos_bound.
       apply Z.pow_pos_nonneg; lia. Qed.

Lemma twos_complement_opp_correct m a :
  (Z.twos_complement_opp m a) = - a mod 2 ^ m.
Proof. unfold Z.twos_complement_opp, Z.lnot_modulo, Z.lnot.
       rewrite Zplus_mod_idemp_l, <- Z.sub_1_r; apply f_equal2; lia. Qed.

Lemma twos_complement_zopp a m
      (Hm : 0 < m) (corner_case : Z.twos_complement m a <> - 2 ^ (m - 1)) :
  Z.twos_complement m (- a) = - Z.twos_complement m a.
Proof.
  pose proof Z.twos_complement_bounds a m Hm.
  apply Z.twos_complement_spec; [lia|split]; [|lia].
  rewrite (PullPush.Z.opp_mod_mod (Z.twos_complement _ _)), Z.twos_complement_mod' by lia;
    apply PullPush.Z.opp_mod_mod. Qed.

Lemma twos_complement_opp_spec m a
      (Hm : 0 < m) (corner_case : Z.twos_complement m a <> - 2 ^ (m - 1)) :
  Z.twos_complement m (Z.twos_complement_opp m a) = - (Z.twos_complement m a).
Proof. apply Z.twos_complement_spec; [lia|split]; [|pose proof Z.twos_complement_bounds a m Hm; lia].
       rewrite <- twos_complement_zopp, twos_complement_opp_correct, Z.twos_complement_mod', Z.mod_mod by (try apply Z.pow_nonzero; lia). reflexivity. Qed.

(************************* *)
(**Properties of twos_complement_pos *)
(************************* *)

Lemma twos_complement_pos_spec m a
      (mw0 : 0 < m)
      (corner_case : Z.twos_complement m a <> - 2 ^ (m - 1)) : (* note that this has to be true for Z.twos_complement_pos to work *)
  Z.twos_complement_pos m a = Z.b2z (0 <? Z.twos_complement m a).
Proof.
  replace (0 <? Z.twos_complement m a) with (- Z.twos_complement m a <? 0) by
      (destruct (0 <? Z.twos_complement m a) eqn:?; destruct (- Z.twos_complement m a <? 0) eqn:?;
                rewrite ?Z.ltb_lt in *; rewrite ?Z.ltb_ge in *; try reflexivity; lia).
  unfold Z.twos_complement_pos; pose proof twos_complement_opp_bound m a ltac:(lia).
  rewrite <- twos_complement_opp_spec, unfold_Let_In, Z.twos_complement_neg_equiv by lia.
  rewrite Z.sign_bit_testbit, Z.twos_complement_cond_equiv, negb_involutive; lia. Qed.

(********************************************************************* *)
(**Section for interaction between eval_twos_complement and saturated operations *)
(********************************************************************* *)

Lemma eval_twos_complement_sat_arithmetic_shiftr1 machine_wordsize n f
      (mw0 : 0 < machine_wordsize)
      (n0 : (0 < n)%nat)
      (Hz : forall z, In z f -> 0 <= z < 2^machine_wordsize)
      (Hf : length f = n) :
  eval_twos_complement machine_wordsize n (sat_arithmetic_shiftr1 machine_wordsize n f) =
  (eval_twos_complement machine_wordsize n f) / 2.
Proof.
  assert (0 < Z.of_nat n) by lia. unfold eval_twos_complement, Let_In. rewrite eval_sat_arithmetic_shiftr1, Z.arithmetic_shiftr1_spec; auto; [nia|].
  apply eval_bound; auto. Qed.

Lemma eval_twos_complement_sat_add machine_wordsize n f g
      (mw0 : 0 < machine_wordsize)
      (n0 : (0 < n)%nat)
      (Hf : length f = n)
      (Hg : length g = n)
      (overflow_f : - 2 ^ (machine_wordsize * n - 2) <
                    Z.twos_complement (machine_wordsize * n) (eval (uweight machine_wordsize) n f) <
                    2 ^ (machine_wordsize * n - 2))
      (overflow_g : - 2 ^ (machine_wordsize * n - 2) <
                    Z.twos_complement (machine_wordsize * n) (eval (uweight machine_wordsize) n g) <
                    2 ^ (machine_wordsize * n - 2)) :
  eval_twos_complement machine_wordsize n (sat_add machine_wordsize n f g) =
  eval_twos_complement machine_wordsize n f + eval_twos_complement machine_wordsize n g.
Proof. assert (0 < Z.of_nat n) by lia; unfold eval_twos_complement, Let_In.
       rewrite eval_sat_add, <- Z.twos_complement_add_weak, Z.twos_complement_mod; nia. Qed.

Lemma eval_twos_complement_select machine_wordsize n cond f g
      (Hf : length f = n)
      (Hg : length g = n) :
  eval_twos_complement machine_wordsize n (select cond f g) = if dec (cond = 0)
                                                    then (eval_twos_complement machine_wordsize n f)
                                                    else (eval_twos_complement machine_wordsize n g).
Proof. unfold eval_twos_complement; rewrite eval_select; auto; destruct (dec (cond = 0)); auto. Qed.

Lemma eval_twos_complement_sat_opp machine_wordsize n f
      (mw0 : 0 < machine_wordsize)
      (n0 : (0 < n)%nat)
      (Hz : forall z, In z f -> 0 <= z < 2^machine_wordsize)
      (Hf : length f = n)
      (corner_case : eval_twos_complement machine_wordsize n f <> - 2 ^ (machine_wordsize * n - 1)):
  eval_twos_complement machine_wordsize n (sat_opp machine_wordsize n f) =
  - eval_twos_complement machine_wordsize n f.
Proof. assert (0 < Z.of_nat n) by lia; unfold eval_twos_complement, Let_In in *; rewrite eval_sat_opp, Z.twos_complement_mod, twos_complement_zopp; try tauto; nia. Qed.

Lemma eval_twos_complement_sat_zero machine_wordsize n
      (mw0 : 0 < machine_wordsize)
      (n0 : (0 < n)%nat) :
  eval_twos_complement machine_wordsize n (sat_zero n) = 0.
Proof. unfold eval_twos_complement; rewrite eval_sat_zero by lia; apply Z.twos_complement_zero; nia. Qed.

Lemma eval_twos_complement_sat_mod2 machine_wordsize n f
      (mw0 : 0 < machine_wordsize)
      (n0 : (0 < n)%nat)
      (Hf : length f = n) :
  (eval_twos_complement machine_wordsize n f) mod 2 = sat_mod2 f.
Proof. unfold eval_twos_complement, Let_In; rewrite Z.twos_complement_mod2, eval_sat_mod2; nia. Qed.

(** ******************************************************************************* *)
(** This section is for the implementation and correctness of the divstep algorithm *)
(** ******************************************************************************* *)

Import WordByWordMontgomery.
Import Positional.

(* This version does not introduce larger types unnecessarily *)
Definition twos_complement_opp' m a :=
  (fst (Z.add_get_carry_full (2^m) (Z.lnot_modulo a (2 ^ m)) 1)) mod (2 ^ m).

Lemma twos_complement_opp'_spec m a :
  twos_complement_opp' m a = Z.twos_complement_opp m a.
Proof.
  unfold twos_complement_opp', Z.twos_complement_opp.
  destruct (Z_lt_dec m 0).
  - rewrite !Z.pow_neg_r, !Zmod_0_r by assumption. cbn.
    rewrite ?Zmod_0_r. reflexivity.
  - rewrite AddGetCarry.Z.add_get_carry_full_mod.
    rewrite Z.mod_mod; [reflexivity|]. apply Z.pow_nonzero; lia. Qed.

(* This version does not introduce larger types unnecessarily *)
Definition twos_complement_pos' m a :=
  dlet b := twos_complement_opp' m a in (Z.shiftr b (m-1)).
Lemma twos_complement_pos'_spec m a :
  twos_complement_pos' m a = Z.twos_complement_pos m a.
Proof. unfold twos_complement_pos'. rewrite twos_complement_opp'_spec. reflexivity. Qed.

Definition divstep_aux (machine_wordsize : Z) (sat_limbs mont_limbs : nat) (m : Z) (data : Z * (list Z) * (list Z) * (list Z) * (list Z)) :=
  let '(d,f,g,v,r) := data in
  dlet cond := Z.land (twos_complement_pos' machine_wordsize d) (sat_mod2 g) in
  dlet d' := Z.zselect cond d (twos_complement_opp' machine_wordsize d) in
  dlet f' := select cond f g in
  dlet g' := select cond g (sat_opp machine_wordsize sat_limbs f) in
  dlet v' := select cond v r in
  let v'':= addmod machine_wordsize mont_limbs m v' v' in
  dlet r' := select cond r (oppmod machine_wordsize mont_limbs m v) in
  dlet g0 := sat_mod2 g' in
  let d'' := (fst (Z.add_get_carry_full (2^machine_wordsize) d' 1)) in
  dlet f'' := select g0 (sat_zero sat_limbs) f' in
  let g'' := sat_arithmetic_shiftr1 machine_wordsize sat_limbs (sat_add machine_wordsize sat_limbs g' f'') in
  dlet v''' := select g0 (sat_zero mont_limbs) v' in
  let r'' := addmod machine_wordsize mont_limbs m r' v''' in
    (d'',f',g'',v'',r'').

Definition divstep machine_wordsize sat_limbs mont_limbs m d f g v r :=
  divstep_aux machine_wordsize sat_limbs mont_limbs m (d, f, g, v, r).
Definition divstep_safe machine_wordsize n :=
  let sat_limbs := (n + 1)%nat in
  divstep machine_wordsize sat_limbs n.

Definition divstep_spec d f g :=
  if (0 <? d) && Z.odd g
  then (1 - d, g, (g - f) / 2)
  else (1 + d, f, (g + (g mod 2) * f) / 2 ).

Definition divstep_spec2 m d g v r :=
  if (0 <? d) && Z.odd g
  then (2 * r mod m, (r - v) mod m)
  else (2 * v mod m, (r + (g mod 2) * v) mod m).

Definition divstep_spec_full m d f g v r :=
  if (0 <? d) && Z.odd g
  then (1 - d, g, (g - f) / 2, 2 * r mod m, (r - v) mod m)
  else (1 + d, f, (g + (g mod 2) * f) / 2, 2 * v mod m, (r + (g mod 2) * v) mod m).

Lemma divstep_g machine_wordsize sat_limbs mont_limbs m d f g v r
      (mw0 : 0 < machine_wordsize)
      (sat_limbs0 : (0 < sat_limbs)%nat)
      (fodd : Z.odd (eval_twos_complement machine_wordsize sat_limbs f) = true)
      (Hf : length f = sat_limbs)
      (Hg : length g = sat_limbs)
      (corner_case : Z.twos_complement machine_wordsize d <> - 2 ^ (machine_wordsize - 1))
      (overflow_f : - 2 ^ (machine_wordsize * sat_limbs - 2) <
                    eval_twos_complement machine_wordsize sat_limbs f <
                    2 ^ (machine_wordsize * sat_limbs - 2))
      (overflow_g : - 2 ^ (machine_wordsize * sat_limbs - 2) <
                    eval_twos_complement machine_wordsize sat_limbs g <
                    2 ^ (machine_wordsize * sat_limbs - 2))
      (Hf2 : forall z, In z f -> 0 <= z < 2^machine_wordsize)
      (Hg2 : forall z, In z g -> 0 <= z < 2^machine_wordsize) :
  let '(d1,f1,g1,v1,r1) := (divstep machine_wordsize sat_limbs mont_limbs m d f g v r) in
  eval_twos_complement machine_wordsize sat_limbs g1 =
  snd (divstep_spec
         (Z.twos_complement machine_wordsize d)
         (eval_twos_complement machine_wordsize sat_limbs f)
         (eval_twos_complement machine_wordsize sat_limbs g)).
Proof.
  set (bw := machine_wordsize * Z.of_nat sat_limbs) in *.

  simpl.
  assert (0 < Z.of_nat sat_limbs) by lia.
  assert (bw0 : 0 < bw) by nia.
  assert (bw1 : 1 < bw) by (destruct (dec (bw = 1)); rewrite ?e in *; simpl in *; lia).
  assert (2 ^ machine_wordsize = 2 * 2 ^ (machine_wordsize - 1))
    by (rewrite Pow.Z.pow_mul_base, Z.sub_simpl_r; lia).
  assert (0 < 2 ^ bw) by (apply Z.pow_pos_nonneg; lia).
  assert (2 ^ (bw - 2) <= 2 ^ (bw - 1)) by (apply Z.pow_le_mono; lia).

#[global]
  Hint Rewrite length_sat_add length_sat_opp length_select : distr_length.

  rewrite eval_twos_complement_sat_arithmetic_shiftr1; distr_length; autorewrite with distr_length; try nia.
  rewrite eval_twos_complement_sat_add; auto; try (autorewrite with distr_length; lia).
  rewrite !eval_twos_complement_select; auto; try (autorewrite with distr_length; lia).
  rewrite eval_twos_complement_sat_opp; auto; try (autorewrite with distr_length; lia).
  rewrite select_push; try (autorewrite with distr_length; lia).

  rewrite sat_opp_mod2; auto.
  unfold divstep_spec.
  rewrite twos_complement_pos'_spec.
  rewrite twos_complement_pos_spec; auto.
  rewrite <- !(eval_twos_complement_sat_mod2 machine_wordsize sat_limbs); auto.
  rewrite !Zmod_odd; auto.

  set (g' := eval_twos_complement machine_wordsize sat_limbs g) in *.
  set (f' := eval_twos_complement machine_wordsize sat_limbs f) in *.
  assert (corner_case_f : f' <> - 2 ^ (bw - 1)) by
      (replace (- _) with (- (2 * 2 ^ (bw - 2))); rewrite ?Pow.Z.pow_mul_base; ring_simplify (bw - 2 + 1); nia).

  destruct (0 <? Z.twos_complement machine_wordsize d);
    destruct (Z.odd g') eqn:g'_odd; rewrite ?fodd, ?eval_sat_zero; auto.
  - simpl; rewrite Z.add_comm; reflexivity.
  - simpl; rewrite eval_twos_complement_sat_zero; auto.
  - rewrite Z.mul_1_l; simpl; reflexivity.
  - simpl; rewrite eval_twos_complement_sat_zero; auto.
  - replace (_ * _) with bw by reflexivity; lia.
  - rewrite twos_complement_pos'_spec.
    let v := constr:(eval_twos_complement
                       machine_wordsize sat_limbs
                       (select (Z.twos_complement_pos machine_wordsize d &' sat_mod2 g) g (sat_opp machine_wordsize sat_limbs f))) in
    let v' := (eval cbv [eval_twos_complement Let_In] in v) in
    change v' with v.
    rewrite eval_twos_complement_select; try apply length_sat_opp; auto.
    destruct (dec (_)); replace (machine_wordsize * _) with bw by reflexivity;
    try rewrite eval_twos_complement_sat_opp; auto; replace (machine_wordsize * _) with bw by reflexivity; lia.
  - rewrite twos_complement_pos'_spec.
    let v := constr:(eval_twos_complement
                       machine_wordsize sat_limbs
                       (select (sat_mod2 (select (Z.twos_complement_pos machine_wordsize d &' sat_mod2 g) g (sat_opp machine_wordsize sat_limbs f)))
                               (sat_zero sat_limbs) (select (Z.twos_complement_pos machine_wordsize d &' sat_mod2 g) f g))) in
    let v' := (eval cbv [eval_twos_complement Let_In] in v) in
    change v' with v.
    rewrite eval_twos_complement_select; try apply length_sat_zero; try apply length_select; auto.
    destruct (dec (_)); try rewrite eval_twos_complement_sat_zero; try rewrite eval_twos_complement_select;
      replace (machine_wordsize * _) with bw by reflexivity; try lia; destruct (dec (_)); lia.
  - apply sat_add_bounds; repeat (rewrite ?length_sat_opp, ?(length_select sat_limbs), ?length_sat_zero; auto); lia. Qed.

Lemma divstep_d machine_wordsize sat_limbs mont_limbs m d f g v r
      (mw1 : 1 < machine_wordsize)
      (sat_limbs0 : (0 < sat_limbs)%nat)
      (Hg : length g = sat_limbs)
      (overflow_d : - 2 ^ (machine_wordsize - 1) + 1 <
                    Z.twos_complement machine_wordsize d <
                    2 ^ (machine_wordsize - 1) - 1) :
  let '(d1,f1,g1,v1,r1) := (divstep machine_wordsize sat_limbs mont_limbs m d f g v r) in
  Z.twos_complement machine_wordsize d1 =
  fst (fst (divstep_spec (Z.twos_complement machine_wordsize d)
                           (eval_twos_complement machine_wordsize sat_limbs f)
                           (eval_twos_complement machine_wordsize sat_limbs g))).
Proof.
  assert (helper0 : 0 < Z.of_nat sat_limbs) by lia.
  assert (mw0 : 0 < machine_wordsize) by lia.
  assert (helper : 1 < 2 ^ machine_wordsize) by (apply Zpow_facts.Zpower_gt_1; lia).
  assert (helper2 : 1 < 2 ^ (machine_wordsize - 1)) by (apply Zpow_facts.Zpower_gt_1; lia).
  assert (helper3 : 2 ^ machine_wordsize = 2 * 2 ^ (machine_wordsize - 1))
    by (rewrite Pow.Z.pow_mul_base, Z.sub_simpl_r; lia).

  simpl; unfold divstep_spec.
  rewrite AddGetCarry.Z.add_get_carry_full_mod.
  rewrite twos_complement_pos'_spec.
  rewrite twos_complement_opp'_spec.
  rewrite twos_complement_pos_spec, <- (eval_twos_complement_sat_mod2 machine_wordsize sat_limbs), Zmod_odd by nia.
  fold (eval_twos_complement machine_wordsize sat_limbs g); set (g' := eval_twos_complement machine_wordsize sat_limbs g) in *.
  destruct ((0 <? Z.twos_complement machine_wordsize d) && (Z.odd g')) eqn:E.
  - apply andb_prop in E. destruct E; rewrite H, H0. simpl Z.b2z; simpl Z.land; cbv [fst].
    unfold Z.zselect. simpl (if _ =? _ then _ else _).
    rewrite twos_complement_opp_correct, Z.twos_complement_mod, Z.twos_complement_add_full, Z.twos_complement_mod, twos_complement_zopp, Z.twos_complement_one; try lia.
    rewrite Z.twos_complement_mod, twos_complement_zopp, Z.twos_complement_one; lia.
  - apply andb_false_iff in E.
    destruct E; rewrite H;
      unfold Z.zselect; cbv [fst]; simpl (if _ =? _ then _ else _);
        [destruct (Z.odd g') | rewrite Z.land_0_r; simpl (if _ =? _ then _ else _)];
        rewrite Z.twos_complement_mod, Z.twos_complement_add_full, Z.twos_complement_one; rewrite ?Z.twos_complement_one; lia. Qed.

Lemma divstep_f machine_wordsize sat_limbs mont_limbs m d f g v r
      (mw0 : 0 < machine_wordsize)
      (Hf : length f = sat_limbs)
      (Hg : length g = sat_limbs)
      (corner_case : Z.twos_complement machine_wordsize d <> - 2 ^ (machine_wordsize - 1)) :
  let '(d1,f1,g1,v1,r1) := (divstep machine_wordsize sat_limbs mont_limbs m d f g v r) in
  eval_twos_complement machine_wordsize sat_limbs f1 =
  snd (fst (divstep_spec (Z.twos_complement machine_wordsize d)
                           (eval_twos_complement machine_wordsize sat_limbs f)
                           (eval_twos_complement machine_wordsize sat_limbs g))).
Proof.
  destruct sat_limbs. subst.
  unfold eval_twos_complement, Let_In.
  rewrite !eval0; rewrite Z.mul_0_r.
  replace (Z.twos_complement 0 0) with (-1). unfold divstep_spec.
  destruct (0 <? Z.twos_complement machine_wordsize d); reflexivity. reflexivity.

  unfold divstep_spec.
  simpl.

  set (n' := S sat_limbs) in *.
  assert (0 < n')%nat by apply Nat.lt_0_succ.
  rewrite twos_complement_pos'_spec.

  rewrite eval_twos_complement_select, twos_complement_pos_spec, <- (eval_twos_complement_sat_mod2 machine_wordsize n'), Zmod_odd; auto.
  fold (eval_twos_complement machine_wordsize n' g).
  destruct (0 <? Z.twos_complement machine_wordsize d); destruct (Z.odd (eval_twos_complement machine_wordsize n' g));
    try reflexivity; lia. Qed.

Theorem divstep_correct machine_wordsize sat_limbs mont_limbs m d f g v r
        (mw1 : 1 < machine_wordsize)
        (sat_limbs0 : (0 < sat_limbs)%nat)
        (fodd : Z.odd (eval_twos_complement machine_wordsize sat_limbs f) = true)
        (Hf : length f = sat_limbs)
        (Hg : length g = sat_limbs)
        (overflow_d : - 2 ^ (machine_wordsize - 1) + 1 <
                    Z.twos_complement machine_wordsize d <
                    2 ^ (machine_wordsize - 1) - 1)
        (overflow_f : - 2 ^ (machine_wordsize * sat_limbs - 2) <
                      eval_twos_complement machine_wordsize sat_limbs f <
                      2 ^ (machine_wordsize * sat_limbs - 2))
        (overflow_g : - 2 ^ (machine_wordsize * sat_limbs - 2) <
                      eval_twos_complement machine_wordsize sat_limbs g <
                      2 ^ (machine_wordsize * sat_limbs - 2))
        (Hf2 : forall z, In z f -> 0 <= z < 2^machine_wordsize)
        (Hg2 : forall z, In z g -> 0 <= z < 2^machine_wordsize) :
  let '(d1,f1,g1,v1,r1) := (divstep machine_wordsize sat_limbs mont_limbs m d f g v r) in
  (Z.twos_complement machine_wordsize d1,
   eval_twos_complement machine_wordsize sat_limbs f1,
   eval_twos_complement machine_wordsize sat_limbs g1) =
  divstep_spec (Z.twos_complement machine_wordsize d)
               (eval_twos_complement machine_wordsize sat_limbs f)
               (eval_twos_complement machine_wordsize sat_limbs g).
Proof.
  assert (0 < machine_wordsize) by lia. simpl.
  apply injective_projections.
  apply injective_projections.
  rewrite <- (divstep_d _ _ mont_limbs m _ _ _ v r); auto.
  rewrite <- (divstep_f _ _ mont_limbs m _ _ _ v r); auto; lia.
  rewrite <- (divstep_g _ _ mont_limbs m _ _ _ v r); auto; lia. Qed.

Lemma divstep_v machine_wordsize sat_limbs mont_limbs m (r' : Z) m' d f g v r
      (fodd : Z.odd (eval_twos_complement machine_wordsize sat_limbs f) = true)

      (r'_correct : (2 ^ machine_wordsize * r') mod m = 1)
      (m'_correct : (m * m') mod 2 ^ machine_wordsize = -1 mod 2 ^ machine_wordsize)
      (m_big : 1 < m)
      (m_small : m < (2 ^ machine_wordsize) ^ Z.of_nat mont_limbs)
      (Hv2 : valid machine_wordsize mont_limbs m v)
      (Hr2 : valid machine_wordsize mont_limbs m r)
      (mw0 : 0 < machine_wordsize)
      (sat_limbs0 : (0 < sat_limbs)%nat)
      (mont_limbs0 : (0 < mont_limbs)%nat)
      (Hv : length v = mont_limbs)
      (Hr : length r = mont_limbs)
      (Hg : length g = sat_limbs)
      (overflow_d : - 2 ^ (machine_wordsize - 1) + 1 <
                    Z.twos_complement machine_wordsize d <
                    2 ^ (machine_wordsize - 1) - 1) :
  let '(d1,f1,g1,v1,r1) := (divstep machine_wordsize sat_limbs mont_limbs m d f g v r) in
  @WordByWordMontgomery.eval machine_wordsize mont_limbs
                        (from_montgomerymod machine_wordsize mont_limbs m m' v1) mod m =
  fst (divstep_spec2 m (Z.twos_complement machine_wordsize d)
                (eval_twos_complement machine_wordsize sat_limbs g)
                (@WordByWordMontgomery.eval machine_wordsize mont_limbs
                                       (from_montgomerymod machine_wordsize mont_limbs m m' v))
                (@WordByWordMontgomery.eval machine_wordsize mont_limbs
                                       (from_montgomerymod machine_wordsize mont_limbs m m' r))).
Proof.
  assert (sat_limbs <> 0%nat) by lia.
  assert (mont_limbs <> 0%nat) by lia.
  simpl.
  rewrite twos_complement_pos'_spec.

  rewrite twos_complement_pos_spec, <- (eval_twos_complement_sat_mod2 machine_wordsize sat_limbs) by lia.
  rewrite Zmod_odd, (select_eq (uweight machine_wordsize) _ mont_limbs); auto.
  unfold divstep_spec2.
  destruct (0 <? Z.twos_complement machine_wordsize d);
    destruct (Z.odd (eval_twos_complement machine_wordsize sat_limbs g));
    rewrite ?(eval_addmod _ _ _ r'), ?Z.add_diag; auto. Qed.

Lemma nonzero_zero n :
  nonzeromod (sat_zero n) = 0.
Proof. unfold nonzero, sat_zero; induction n; auto. Qed.

Lemma zero_valid machine_wordsize n m
      (mw0 : 0 < machine_wordsize)
      (m0 : 0 < m) :
  valid machine_wordsize n m (sat_zero n).
Proof.
  unfold valid, small, WordByWordMontgomery.eval.
  rewrite eval_sat_zero, partition_0; try split; auto; lia. Qed.

Lemma divstep_r machine_wordsize sat_limbs mont_limbs m (r' : Z) m' d f g v r
      (fodd : Z.odd (eval_twos_complement machine_wordsize sat_limbs f) = true)
      (r'_correct : (2 ^ machine_wordsize * r') mod m = 1)
      (m'_correct : (m * m') mod 2 ^ machine_wordsize = -1 mod 2 ^ machine_wordsize)
      (m_big : 1 < m)
      (m_small : m < (2 ^ machine_wordsize) ^ Z.of_nat mont_limbs)
      (Hv2 : valid machine_wordsize mont_limbs m v)
      (Hr2 : valid machine_wordsize mont_limbs m r)
      (mw0 : 0 < machine_wordsize)
      (sat_limbs0 : (0 < sat_limbs)%nat)
      (mont_limbs0 : (0 < mont_limbs)%nat)
      (Hv : length v = mont_limbs)
      (Hr : length r = mont_limbs)
      (Hf : length f = sat_limbs)
      (Hg : length g = sat_limbs)
      (overflow_d : - 2 ^ (machine_wordsize - 1) + 1 <
                    Z.twos_complement machine_wordsize d <
                    2 ^ (machine_wordsize - 1) - 1)
      (Hf2 : forall z, In z f -> 0 <= z < 2^machine_wordsize) :
  let '(d1,f1,g1,v1,r1) := (divstep machine_wordsize sat_limbs mont_limbs m d f g v r) in
  @WordByWordMontgomery.eval machine_wordsize mont_limbs
                        (from_montgomerymod machine_wordsize mont_limbs m m' r1) mod m =
  snd (divstep_spec2 m (Z.twos_complement machine_wordsize d)
                (eval_twos_complement machine_wordsize sat_limbs g)
                (@WordByWordMontgomery.eval machine_wordsize mont_limbs
                                       (from_montgomerymod machine_wordsize mont_limbs m m' v))
                (@WordByWordMontgomery.eval machine_wordsize mont_limbs
                                       (from_montgomerymod machine_wordsize mont_limbs m m' r))).
Proof.
  assert (sat_limbs0' : (sat_limbs <> 0%nat)) by lia.
  assert (mont_limbs0' : mont_limbs <> 0%nat) by lia.
  unfold divstep_spec2.
  pose proof (oppmod_correct machine_wordsize mont_limbs m r' m' r'_correct m'_correct mw0 m_big (ltac:(lia)) m_small) as H.
  destruct H as [H1 H2].
  assert (zero_valid : valid machine_wordsize mont_limbs m (sat_zero mont_limbs)) by (apply zero_valid; lia).
  pose proof (nonzero_zero mont_limbs) as H3.
  rewrite (nonzeromod_correct machine_wordsize mont_limbs m r' m') in H3
    by (try apply zero_valid; lia).
  cbn -[Z.mul oppmod sat_opp select].
  rewrite select_push; rewrite ?length_sat_opp; auto.
  rewrite sat_opp_mod2; auto.
  rewrite twos_complement_pos'_spec.
  rewrite twos_complement_pos_spec, <- !(eval_twos_complement_sat_mod2 machine_wordsize sat_limbs) by lia.
  rewrite !Zmod_odd, !(select_eq (uweight machine_wordsize) _ mont_limbs), fodd;
    try apply length_select; auto.
  destruct (0 <? Z.twos_complement machine_wordsize d);
    destruct (Z.odd (eval_twos_complement machine_wordsize sat_limbs g)); cbn -[Z.mul oppmod].
  - rewrite (eval_addmod _ _ _ r'); auto.
    rewrite <- Zplus_mod_idemp_l; auto.
    rewrite (eval_oppmod _ _ _ r'); auto.
    rewrite Zplus_mod_idemp_l; auto.
    rewrite Z.add_comm; unfold Z.sub; auto.
  - rewrite (eval_addmod _ _ _ r'); auto.
    rewrite <- Zplus_mod_idemp_r; auto.
    rewrite H3.
    rewrite Z.mul_0_l, Z.add_0_r; auto.
  - rewrite (eval_addmod _ _ _ r'); auto.
    rewrite Z.mul_1_l; auto.
  - rewrite (eval_addmod _ _ _ r'); auto.
    rewrite <- Zplus_mod_idemp_r; auto.
    rewrite H3.
    rewrite Z.mul_0_l, Z.add_0_r; auto.
  - apply length_sat_zero.
  - unfold oppmod, WordByWordMontgomery.opp,
    WordByWordMontgomery.sub, Rows.sub_then_maybe_add, Rows.add.
    destruct (Rows.sub (uweight machine_wordsize) mont_limbs (zeros mont_limbs)) eqn:E.
    destruct (Rows.flatten (uweight machine_wordsize) mont_limbs
                           [l; zselect (2 ^ machine_wordsize - 1) (- z) (Partition.partition (uweight machine_wordsize) mont_limbs m)]) eqn:E2.
    simpl.
    inversion E; subst.
    inversion E2.
    apply Rows.length_sum_rows.
    apply (uwprops machine_wordsize mw0).
    apply Rows.length_sum_rows.
    apply (uwprops machine_wordsize mw0).
    apply length_zeros.
    apply map_length.
    rewrite length_zselect.
    apply length_partition. Qed.

Lemma divstep_spec_divstep_spec_full_d m d f g v r :
  fst (fst (divstep_spec d f g)) = fst (fst (fst (fst (divstep_spec_full m d f g v r)))).
Proof. unfold divstep_spec, divstep_spec_full.
       destruct ((0 <? d) && Z.odd g); reflexivity. Qed.

Lemma divstep_spec_divstep_spec_full_f m d f g v r :
  snd (fst (divstep_spec d f g)) = snd (fst (fst (fst (divstep_spec_full m d f g v r)))).
Proof. unfold divstep_spec, divstep_spec_full.
       destruct ((0 <? d) && Z.odd g); reflexivity. Qed.

Lemma divstep_spec_divstep_spec_full_g m d f g v r :
  snd (divstep_spec d f g) = snd (fst (fst (divstep_spec_full m d f g v r))).
Proof. unfold divstep_spec, divstep_spec_full.
       destruct ((0 <? d) && Z.odd g); reflexivity. Qed.

Lemma divstep_spec2_divstep_spec_full_v m d f g v r :
  fst (divstep_spec2 m d g v r) = snd (fst (divstep_spec_full m d f g v r)).
Proof. unfold divstep_spec2, divstep_spec_full.
       destruct ((0 <? d) && Z.odd g); reflexivity. Qed.

Lemma divstep_spec2_divstep_spec_full_r m d f g v r :
  snd (divstep_spec2 m d g v r) = snd (divstep_spec_full m d f g v r).
Proof. unfold divstep_spec2, divstep_spec_full.
       destruct ((0 <? d) && Z.odd g); reflexivity. Qed.

Theorem divstep_correct_full machine_wordsize sat_limbs mont_limbs m r' m' d f g v r
      (fodd : Z.odd (eval_twos_complement machine_wordsize sat_limbs f) = true)
      (r'_correct : (2 ^ machine_wordsize * r') mod m = 1)
      (m'_correct : (m * m') mod 2 ^ machine_wordsize = -1 mod 2 ^ machine_wordsize)
      (m_big : 1 < m)
      (m_small : m < (2 ^ machine_wordsize) ^ Z.of_nat mont_limbs)
      (mw1 : 1 < machine_wordsize)
      (sat_limbs0 : (0 < sat_limbs)%nat)
      (mont_limbs0 : (0 < mont_limbs)%nat)
      (Hv : length v = mont_limbs)
      (Hr : length r = mont_limbs)
      (Hf : length f = sat_limbs)
      (Hg : length g = sat_limbs)
      (overflow_d : - 2 ^ (machine_wordsize - 1) + 1 <
                    Z.twos_complement machine_wordsize d <
                    2 ^ (machine_wordsize - 1) - 1)
      (overflow_f : - 2 ^ (machine_wordsize * sat_limbs - 2) <
                    eval_twos_complement machine_wordsize sat_limbs f <
                    2 ^ (machine_wordsize * sat_limbs - 2))
      (overflow_g : - 2 ^ (machine_wordsize * sat_limbs - 2) <
                    eval_twos_complement machine_wordsize sat_limbs g <
                    2 ^ (machine_wordsize * sat_limbs - 2))
      (Hf2 : forall z, In z f -> 0 <= z < 2^machine_wordsize)
      (Hg2 : forall z, In z g -> 0 <= z < 2^machine_wordsize)
      (Hv2 : valid machine_wordsize mont_limbs m v)
      (Hr2 : valid machine_wordsize mont_limbs m r) :
  let '(d1,f1,g1,v1,r1) := (divstep machine_wordsize sat_limbs mont_limbs m d f g v r) in
    (Z.twos_complement machine_wordsize d1,
     eval_twos_complement machine_wordsize sat_limbs f1,
     eval_twos_complement machine_wordsize sat_limbs g1,
     @WordByWordMontgomery.eval machine_wordsize mont_limbs (from_montgomerymod machine_wordsize mont_limbs m m' v1) mod m,
     @WordByWordMontgomery.eval machine_wordsize mont_limbs (from_montgomerymod machine_wordsize mont_limbs m m' r1) mod m) =
    divstep_spec_full m (Z.twos_complement machine_wordsize d)
                      (eval_twos_complement machine_wordsize sat_limbs f)
                      (eval_twos_complement machine_wordsize sat_limbs g)
                      (@WordByWordMontgomery.eval machine_wordsize mont_limbs (from_montgomerymod machine_wordsize mont_limbs m m' v))
                      (@WordByWordMontgomery.eval machine_wordsize mont_limbs (from_montgomerymod machine_wordsize mont_limbs m m' r)).
Proof.
  assert (0 < machine_wordsize) by lia.
  repeat apply injective_projections.
  rewrite <- divstep_spec_divstep_spec_full_d, <- (divstep_d _ _ mont_limbs m _ _ _ v r); auto.
  rewrite <- divstep_spec_divstep_spec_full_f, <- (divstep_f _ _ mont_limbs m _ _ _ v r); auto; lia.
  rewrite <- divstep_spec_divstep_spec_full_g, <- (divstep_g _ _ mont_limbs m _ _ _ v r); auto; lia.
  rewrite <- divstep_spec2_divstep_spec_full_v;
    rewrite <- (divstep_v _ _ _ _ r' _ _ f _ _ _); auto.
  rewrite <- divstep_spec2_divstep_spec_full_r;
    rewrite <- (divstep_r _ _ _ _ r' _ _ f _ _ _); auto. Qed.


Set Implicit Arguments.

Require Import List.
Require Import Bvector.
Require Import HMAC_common_defs.
Require Import SHA256.
Require Import HMAC_spec_pad.
Require Import Coq.Program.Basics.
Require Import Coqlib.
Require Import ByteBitRelations.
Require Import sha_padding_lemmas.

Module HMAC_Concat.

Section HMAC.

  Variable c p : nat.
  Definition b := (c + p)%nat.

  (* The compression function *)
  Variable h : Blist -> Blist -> Blist.
  (* The initialization vector is part of the spec of the hash function. *)
  Variable iv : Blist.

  (* splitAndPad concat'ed, normal fold replaced by firstn/splitn manual fold *)

  (* The iteration of the compression function gives a keyed hash function on lists of words. *)
  Definition h_star k (m : Blist) :=
    hash_blocks_bits h k m.
  (* The composition of the keyed hash function with the IV gives a hash function on lists of words. *)
  Definition hash_words := h_star iv.

  Variable splitAndPad : Blist -> Blist.
  Hypothesis splitAndPad_1_1 :
    forall b1 b2,
      splitAndPad b1 = splitAndPad b2 ->
      b1 = b2.

  (* fpad can be a constant *)
  Variable fpad : Blist -> Blist.
  Definition app_fpad (x : Blist) : Blist :=
    x ++ fpad x.

  Definition h_star_pad k x :=
    app_fpad (h_star k x).

  Definition GNMAC k m :=
    let (k_Out, k_In) := splitList c k in
    h k_Out (app_fpad (h_star k_In m)).

  (* The "two-key" version of GHMAC and HMAC. *)
  Definition GHMAC_2K (k : Blist) m :=
    let (k_Out, k_In) := splitList b k in
      let h_in := (hash_words (k_In ++ m)) in
        hash_words (k_Out ++ app_fpad h_in).

  Definition HMAC_2K (k : Blist) (m : Blist) :=
    GHMAC_2K k (splitAndPad m).

  (* opad and ipad are constants defined in the HMAC spec. *)
  Variable opad ipad : Blist.
  Hypothesis opad_ne_ipad : opad <> ipad.

  Definition GHMAC (k : Blist) :=
    GHMAC_2K (BLxor k opad ++ BLxor k ipad).

  Definition HMAC (k : Blist) :=
    HMAC_2K (BLxor k opad ++ BLxor k ipad).

End HMAC.

End HMAC_Concat.

Lemma h_star_eq :
  HMAC_Pad.h_star = HMAC_Concat.h_star.
Proof. reflexivity. Qed.

Lemma block_8 : forall (l : Blist), length l = b -> InBlocks 8 l.
Proof.
  intros l len. apply InBlocks_len. exists 64%nat. apply len.
Qed.

Lemma splitandpad_eq : forall (l m : Blist),
                         length l = b ->
                         sha_splitandpad (l ++ m) = l ++ sha_splitandpad_inc m.
Proof.
  intros l m len.
  unfold sha_splitandpad. unfold sha_splitandpad_inc.
  unfold pad. unfold pad_inc.

  rewrite -> bitsToBytes_app.
  rewrite -> common_lemmas.Zlength_app.
  repeat rewrite -> bytesToBits_app.
  rewrite -> bits_bytes_bits_id.
  rewrite <- app_assoc.
  repeat f_equal.
  unfold b, c, p in *. simpl in *.

  * apply bitsToBytes_len. apply len.
  * apply bitsToBytes_len. apply len.
  * apply bitsToBytes_len. apply len.
  * apply block_8. apply len.
  * apply block_8. apply len.
Qed.

Lemma fpad_eq : forall (l m : Blist),
                  length l = b ->
                  InBlocks 8 m ->
                  sha_splitandpad (l ++ m) = l ++ HMAC_Concat.app_fpad fpad m.
Proof.
  intros l m len len_m.
  unfold HMAC_Concat.app_fpad.
  unfold sha_splitandpad. unfold fpad.
  unfold pad. unfold fpad_inner.

  rewrite -> bitsToBytes_app.
  repeat rewrite -> bytesToBits_app.
  repeat rewrite -> bits_bytes_bits_id.
  rewrite <- app_assoc.
  rewrite -> common_lemmas.Zlength_app.
  repeat f_equal.

  * apply bitsToBytes_len. apply len.
  * apply bitsToBytes_len. apply len.
  * apply bitsToBytes_len. apply len.
  * apply len_m.
  * apply block_8. apply len.
  * apply block_8. apply len.
Qed.

Lemma NPeano_divide_trans a b c: NPeano.divide a b ->
      NPeano.divide b c -> NPeano.divide a c.
Proof. intros. destruct H; destruct H0. subst.
  exists (x0 * x)%nat. apply mult_assoc.
Qed.

Theorem HMAC_concat_pad : forall (k m : Blist) (op ip : Blist),
                            length k = b ->
                            length ip = b ->
                            length op = b ->
  HMAC_Pad.HMAC c p sha_h sha_iv sha_splitandpad op ip k m =
  HMAC_Concat.HMAC c p sha_h sha_iv sha_splitandpad_inc fpad op ip k m.
Proof.
  intros k m op ip len_k len_ip len_op.
  unfold c, p in *. simpl in *.
  unfold HMAC_Pad.HMAC. unfold HMAC_Concat.HMAC.
  unfold HMAC_Pad.HMAC_2K. unfold HMAC_Concat.HMAC_2K.
  unfold HMAC_Pad.GHMAC_2K. unfold HMAC_Concat.GHMAC_2K.

  repeat rewrite -> split_append_id.
  unfold HMAC_Pad.hash_words_padded. unfold compose.
  unfold HMAC_Concat.hash_words.
  unfold HMAC_Pad.hash_words.
  rewrite -> h_star_eq.

  (* show the two inputs to h_star are equal *)
  f_equal.

  rewrite <- splitandpad_eq.
  rewrite <- fpad_eq.           (* wants the InBlocks 8 *)
  reflexivity.

  * apply BLxor_length. apply len_k. apply len_op.
  *
    unfold HMAC_Concat.h_star.
    apply InBlocks_len.
    rewrite hash_blocks_bits_len.
      exists (32%nat).  simpl. omega.
      apply sha_iv_length.
      rewrite splitandpad_eq.
               econstructor.
                 2: reflexivity.
                 apply BLxor_length. apply len_k. apply len_ip.
                 apply sha_splitandpad_inc_InBlocks.
                 apply BLxor_length. apply len_k. apply len_ip.
  * apply BLxor_length. apply len_k. apply len_ip.
  * apply BLxor_length. apply len_k. apply len_op.
  * apply BLxor_length. apply len_k. apply len_ip.
  * apply BLxor_length. apply len_k. apply len_op.
  * apply BLxor_length. apply len_k. apply len_ip.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall P A B C D : Universe, ((wd_ C D /\ (wd_ A B /\ (col_ A C D /\ (col_ B C D /\ col_ P A B)))) -> col_ P C D)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo119:
  prime  73501368737533661->
  prime  4704087594993277409.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      4704087594993277409
      64
      ((73501368737533661,1)::nil)
      100
      0
      20
      100)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D P Q : Universe, ((wd_ A B /\ (wd_ C D /\ (wd_ P Q /\ (col_ A C D /\ col_ B C D)))) -> col_ A B D)).
Proof.
  time tac.
Qed.

End FOFProblem.


From HoTT Require Import TruncType abstract_algebra.
From HoTT Require Import PropResizing.PropResizing.
From HoTT Require Import Spaces.Nat Spaces.Card.

Open Scope type.

(** * Formulation of GCH *)

(* GCH states that for any infinite set X with Y between X and P(X) either Y embeds into X or P(X) embeds into Y. *)

Definition GCH :=
  forall X Y : HSet, infinite X -> InjectsInto X Y -> InjectsInto Y (X -> HProp) -> InjectsInto Y X + InjectsInto (X -> HProp) Y.

(** * GCH is a proposition *)

Lemma Cantor_inj {PR : PropResizing} {FE : Funext} X :
  ~ Injection (X -> HProp) X.
Proof.
  intros [i HI]. pose (p n := Build_HProp (resize_hprop (forall q, i q = n -> ~ q n))).
  enough (Hp : p (i p) <-> ~ p (i p)).
  { apply Hp; apply Hp; intros H; now apply Hp. }
  unfold p at 1. split.
  - intros H. apply equiv_resize_hprop in H. apply H. reflexivity.
  - intros H. apply equiv_resize_hprop. intros q -> % HI. apply H.
Qed.

(* The concluding disjunction of GCH is excluse since otherwise we'd obtain an injection of P(X) into X. *)

Lemma hprop_GCH {PR : PropResizing} {FE : Funext} :
  IsHProp GCH.
Proof.
  repeat (nrapply istrunc_forall; intros).
  apply hprop_allpath. intros [H|H] [H'|H'].
  - enough (H = H') as ->; trivial. apply (InjectsInto a0 a).
  - apply Empty_rec. eapply merely_destruct; try eapply (Cantor_inj a); trivial. now apply InjectsInto_trans with a0.
  - apply Empty_rec. eapply merely_destruct; try eapply (Cantor_inj a); trivial. now apply InjectsInto_trans with a0.
  - enough (H = H') as ->; trivial. apply (InjectsInto (a -> HProp) a0).
Qed.

(** * GCH implies LEM *)

Section LEM.

  Variable X : HSet.
  Variable P : HProp.

  Context {PR : PropResizing}.
  Context {FE : Funext}.

  Definition hpaths (x y : X) :=
    Build_HProp (paths x y).

  Definition sing (p : X -> HProp) :=
    exists x, p = hpaths x.

  Let sings :=
    { p : X -> HProp | sing p \/ (P + ~ P) }.

  (* The main idea is that for a given set X and proposition P, the set sings fits between X and P(X).
     Then CH for X implies that either sings embeds into X (which can be refuted constructively),
     or that P(X) embeds into sings, from which we can extract a proof of P + ~P. *)

  Lemma Cantor_sing (i : (X -> HProp) -> (X -> HProp)) :
    IsInjective i -> exists p, ~ sing (i p).
  Proof.
    intros HI. pose (p n := Build_HProp (resize_hprop (forall q, i q = hpaths n -> ~ q n))).
    exists p. intros [n HN]. enough (Hp : p n <-> ~ p n).
    { apply Hp; apply Hp; intros H; now apply Hp. }
    unfold p at 1. split.
    - intros H. apply equiv_resize_hprop in H. apply H, HN.
    - intros H. apply equiv_resize_hprop. intros q HQ. rewrite <- HN in HQ. now apply HI in HQ as ->.
  Qed.

  Lemma injective_proj1 {Z} (r : Z -> HProp) :
    IsInjective (@proj1 Z r).
  Proof.
    intros [p Hp] [q Hq]; cbn.
    intros ->. unshelve eapply path_sigma; cbn.
    - reflexivity.
    - cbn. apply (r q).
  Qed.

  Lemma inject_sings :
    (P + ~ P) -> Injection (X -> HProp) sings.
  Proof.
    intros HP. unshelve eexists.
    - intros p. exists p. apply tr. now right.
    - intros p q. intros H. change p with ((exist (fun r => sing r \/ (P + ~ P)) p (tr (inr HP))).1).
      rewrite H. cbn. reflexivity.
  Qed.

  Theorem CH_LEM :
    (Injection X sings -> Injection sings (X -> HProp) -> ~ (Injection sings X) -> InjectsInto (X -> HProp) sings)
    -> P \/ ~ P.
  Proof.
    intros ch. eapply merely_destruct; try apply ch.
    - unshelve eexists.
      + intros x. exists (hpaths x). apply tr. left. exists x. reflexivity.
      + intros x y. intros H % pr1_path. cbn in H. change (hpaths x y). now rewrite H.
    - exists (@proj1 _ _). now apply injective_proj1.
    - intros H. assert (HP' : ~ ~ (P + ~ P)).
      { intros HP. apply HP. right. intros p. apply HP. now left. }
      apply HP'. intros HP % inject_sings. clear HP'.
      apply Cantor_inj with X. now eapply (Injection_trans _ _ _ HP).
    - intros [i Hi]. destruct (Cantor_sing (fun p => @proj1 _ _ (i p))) as [p HP].
      + intros x y H % injective_proj1. now apply Hi.
      + destruct (i p) as [q Hq]; cbn in *.
        eapply merely_destruct; try apply Hq.
        intros [H|H]; [destruct (HP H)|now apply tr].
  Qed.

End LEM.

(* We can instantiate the previous lemma with nat to obtain GCH -> LEM. *)

Theorem GCH_LEM {PR : PropResizing} {UA : Univalence} :
  GCH -> (forall P : HProp, P \/ ~ P).
Proof.
  intros gch P. eapply (CH_LEM (Build_HSet nat)); try exact _. intros H1 H2 H3.
  pose (sings := { p : nat -> HProp | sing (Build_HSet nat) p \/ (P + ~ P) }).
  destruct (gch (Build_HSet nat) (Build_HSet sings)) as [H|H].
  - cbn. exists idmap. apply isinj_idmap.
  - apply tr. apply H1.
  - apply tr. apply H2.
  - apply Empty_rec. eapply merely_destruct; try apply H. apply H3.
  - apply H.
Qed.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Category.
Require Import Blech.Monoid.
Require Blech.PointedCategory.

Require Blech.Reflect.

Import CategoryNotations.
Import BishopNotations.
Import MonoidNotations.
Import PointedCategory.PointedNotations.

Open Scope category_scope.
Open Scope bishop_scope.
Open Scope monoid_scope.

#[local]
Obligation Tactic := Reflect.category_simpl.

#[program]
Definition Endo (C: PointedCategory.Category): Monoid := {|
  S := C PointedCategory.pt PointedCategory.pt /~ Mor_Setoid _ _ ;

  e := id _ ;
  app := @compose _ _ _ _ ;
|}.

Module EndoNotations.
  Notation "Λ₊" := Endo.
End EndoNotations.


Require Import Deci Ascii String.

(** * Conversion between dec and string *)

(** Pretty straightforward, which is precisely the point of the
    [dec] datatype. The only catch is that [nil] means ["0"],
    not the empty string, so we don't have a perfect bijection. *)

Definition to_char (d:digit) :=
 match d with
 | D0 => "0"
 | D1 => "1"
 | D2 => "2"
 | D3 => "3"
 | D4 => "4"
 | D5 => "5"
 | D6 => "6"
 | D7 => "7"
 | D8 => "8"
 | D9 => "9"
 end%char.

Fixpoint to_string_rec (dl:dec) :=
 match dl with
 | nil => EmptyString
 | d::dl => String (to_char d) (to_string_rec dl)
 end.

Definition to_string (dl:dec) :=
 match dl with
 | nil => "0"%string
 | _ => to_string_rec dl
 end.

Definition of_char (a:ascii) :=
 match a with
 | "0" => Some D0
 | "1" => Some D1
 | "2" => Some D2
 | "3" => Some D3
 | "4" => Some D4
 | "5" => Some D5
 | "6" => Some D6
 | "7" => Some D7
 | "8" => Some D8
 | "9" => Some D9
 | _ => None
 end%char.

Definition ocons (od:option digit)(ol:option dec) :=
 match od, ol with
 | Some d, Some dl => Some (d::dl)
 | _,_ => None
 end.

Fixpoint of_string_rec s :=
 match s with
 | EmptyString => Some nil
 | String a s => ocons (of_char a) (of_string_rec s)
 end.

Definition of_string s :=
 match s with
 | EmptyString => None
 | _ => of_string_rec s
 end.

(* Compute of_string "123456890123456890123456890123456890". *)

Lemma of_to_char d : of_char (to_char d) = Some d.
Proof.
 now destruct d.
Qed.

Lemma of_to_rec d : of_string_rec (to_string_rec d) = Some d.
Proof.
 induction d; simpl; rewrite ?IHd, ?of_to_char; simpl; auto.
Qed.

Lemma of_to d : d<>nil -> of_string (to_string d) = Some d.
Proof.
 destruct d. now destruct 1. intros _. apply of_to_rec.
Qed.

Lemma of_to_nil : of_string (to_string nil) = Some (D0::nil).
Proof.
 reflexivity.
Qed.

Lemma of_to_gen d :
  of_string (to_string d) = Some d \/
  of_string (to_string d) = Some (D0::d).
Proof.
 destruct d.
 - now right.
 - left. now apply of_to.
Qed.

Lemma to_of_char c d : of_char c = Some d -> to_char d = c.
Proof.
 destruct c as [[|] [|] [|] [|] [|] [|] [|] [|]];
  discriminate || injection 1 as <-; auto.
Qed.

Lemma to_of_rec s d : of_string_rec s = Some d -> to_string_rec d = s.
Proof.
 revert d.
 induction s; simpl.
 - now injection 1 as <-.
 - destruct (of_char a) eqn:Ha; try discriminate.
   destruct (of_string_rec s) eqn:Hs; try discriminate.
   simpl. injection 1 as <-. simpl. f_equal; auto using to_of_char.
Qed.

Lemma of_non_nil s : of_string s <> Some nil.
Proof.
 destruct s.
 - now simpl.
 - simpl.
   now destruct of_char, of_string_rec.
Qed.

Lemma to_of s d : of_string s = Some d -> to_string d = s.
Proof.
 destruct s; try discriminate.
 intros H.
 assert (d<>nil).
 { intros ->. apply (of_non_nil _ H). }
 apply to_of_rec in H.
 now destruct d.
Qed.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Arith.Arith.
Add LoadPath "/Users/jikl/demos/coq/software-foundation-exercise/logic_foundation" as LF.
From LF Require Import Maps.
From LF Require Import Imp.
From PLF Require Import SmallStep.

Hint Constructors multi : db.

Inductive tm : Type :=
| tru : tm
| fls : tm
| test : tm -> tm -> tm -> tm
| zro : tm
| scc : tm -> tm
| prd : tm -> tm
| iszro : tm -> tm.

Inductive bvalue : tm -> Prop :=
| bv_tru : bvalue tru
| bv_fls : bvalue fls.

Inductive nvalue : tm -> Prop :=
| nv_zro : nvalue zro
| nv_scc : forall t, nvalue t -> nvalue (scc t).

Definition value (t : tm) := bvalue t \/ nvalue t.

Hint Constructors bvalue nvalue : db.

Hint Unfold value : db.
Hint Unfold update : db.

Reserved Notation "t1 '-->' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
| ST_TestTru : forall t1 t2, (test tru t1 t2) --> t1
| ST_TestFls : forall t1 t2, (test fls t1 t2) --> t2
| ST_Test : forall t1 t1' t2 t3,
    t1 --> t1' ->
    (test t1 t2 t3) --> (test t1' t2 t3)
| ST_Scc : forall t1 t1',
    t1 --> t1' ->
    (scc t1) --> (scc t1')
| ST_PrdZro : (prd zro) --> zro
| ST_PrdScc : forall t1,
    nvalue t1 ->
    (prd (scc t1)) --> t1
| ST_Prd : forall t1 t1',
    t1 --> t1' ->
    (prd t1) --> (prd t1')
| ST_IszroZro :
    (iszro zro) --> tru
| ST_IszroScc : forall t1,
    nvalue t1 ->
    (iszro (scc t1)) --> fls
| ST_Iszro : forall t1 t1',
    t1 --> t1' ->
    (iszro t1) --> (iszro t1')

where "t1 '-->' t2" := (step t1 t2).

Hint Constructors step : db.

Notation step_normal_form := (normal_form step).

Definition stuck (t : tm) : Prop :=
  step_normal_form t /\ ~ value t.

Hint Unfold stuck : db.

Example some_term_is_stuck :
  exists t, stuck t.
Proof.
  exists (test zro zro zro).
  unfold stuck. split.
  - unfold step_normal_form.
    intro H. destruct H.
    inversion H. inversion H4.
  - intro H. inversion H.
    + inversion H0.
    + inversion H0.
Qed.

Lemma value_is_nf : forall t,
    value t -> step_normal_form t.
Proof.
  intros t H. inversion H.
  - inversion H0.
    + unfold step_normal_form.
      intro H2. destruct H2. inversion H2.
    + unfold step_normal_form.
      intro H2. destruct H2. inversion H2.
  - induction H0.
    + unfold step_normal_form.
      intro H1. destruct H1. inversion H0.
    + unfold step_normal_form.
      intro H1. destruct H1.
      inversion H1. subst.
      assert (Hv : value t).
      { unfold value. right. apply H0. }
      apply IHnvalue in Hv. unfold step_normal_form in Hv.
      apply Hv. eapply ex_intro. apply H3.
Qed.

Theorem step_deterministic :
  deterministic step.
Proof with eauto.
  unfold deterministic.
  intros x y1 y2 Hy1 Hy2.
  generalize dependent y2.
  induction Hy1; intros y2 Hy2;
    inversion Hy2; subst; try reflexivity.
  - inversion H3.
  - inversion H3.
  - inversion Hy1.
  - inversion Hy1.
  - apply IHHy1 in H3. rewrite H3. reflexivity.
  - apply IHHy1 in H0. rewrite H0. reflexivity.
  - inversion H0.
  - inversion H1. subst.
    assert (Hnf: step_normal_form t1).
    { apply value_is_nf. unfold value. right. apply H. }
    unfold step_normal_form in Hnf. unfold not in Hnf.
    exfalso. apply Hnf. eapply ex_intro. apply H2.
  - inversion Hy1.
  - inversion Hy1; subst.
    assert (Hnf: step_normal_form y2).
    { apply value_is_nf. unfold value. right. apply H0. }
    unfold step_normal_form in Hnf. unfold not in Hnf.
    exfalso. apply Hnf. eapply ex_intro. apply H1.
  - apply IHHy1 in H0. rewrite H0. reflexivity.
  - inversion H0.
  - inversion H1; subst.
    assert (Hnf: step_normal_form t1).
    { apply value_is_nf. unfold value. right. apply H. }
    unfold step_normal_form in Hnf. unfold not in Hnf.
    exfalso. apply Hnf. eapply ex_intro. apply H2.
  - inversion Hy1.
  - inversion Hy1; subst.
    assert (Hnf: step_normal_form t0).
    { apply value_is_nf. unfold value. right. apply H0. }
    unfold step_normal_form in Hnf. unfold not in Hnf.
    exfalso. apply Hnf. eapply ex_intro. apply H1.
  - apply IHHy1 in H0. rewrite H0. reflexivity.
Qed.

Inductive ty : Type :=
| Bool : ty | Nat : ty.

Reserved Notation "'|-' t '?' T" (at level 40).

Inductive has_type : tm -> ty -> Prop :=
| T_Tru :
  |- tru ? Bool
| T_Fls :
  |- fls ? Bool
| T_Test : forall t1 t2 t3 T,
    |- t1 ? Bool ->
    |- t2 ? T ->
    |- t3 ? T ->
    |- test t1 t2 t3 ? T
| T_Zro :
  |- zro ? Nat
| T_Scc : forall t1,
  |- t1 ? Nat ->
  |- scc t1 ? Nat
| T_Prd : forall t1,
    |- t1 ? Nat ->
    |- prd t1 ? Nat
| T_Iszro : forall t1,
    |- t1 ? Nat ->
    |- iszro t1 ? Bool
where "'|-' t '?' T" := (has_type t T).

Hint Constructors has_type : db.

Example has_type_1 :
  |- test fls zro (scc zro) ? Nat.
Proof.
  apply T_Test.
  - apply T_Fls.
  - apply T_Zro.
  - apply T_Scc. apply T_Zro.
Qed.

Example has_type_not :
  ~ (|- test fls zro tru ? Bool).
Proof.
  intro H. inversion H. inversion H5.
Qed.

Example scc_has_type_nat__hastype_nat : forall t,
    |- scc t ? Nat ->
    |- t ? Nat.
Proof.
  intros t H. inversion H. apply H1.
Qed.

Lemma bool_canonical : forall t,
    |- t ? Bool -> value t -> bvalue t.
Proof.
  intros t H1 H2.
  inversion H2.
  - assumption.
  - inversion H.
    + rewrite <- H0 in H1. inversion H1.
    + rewrite <- H3 in H1. inversion H1.
Qed.

Lemma nat_canonical : forall t,
    |- t ? Nat -> value t -> nvalue t.
Proof.
  intros t H1 H2.
  inversion H1; subst.
  - inversion H2.
    + inversion H4.
    + apply H4.
  - constructor.
  - inversion H2.
    + inversion H0.
    + apply H0.
  - inversion H2.
    + inversion H0.
    + apply H0.
Qed.

Theorem progress : forall t T,
    |- t ? T ->
       value t \/ exists t', t --> t'.
Proof.
  intros t T H. induction H.
  - left. left. apply bv_tru.
  - left. left. apply bv_fls.
  - right. destruct IHhas_type1.
    + inversion H; subst.
      * eapply ex_intro; constructor.
      * eapply ex_intro; constructor.
      * inversion H2. inversion H6. inversion H6.
      * inversion H2. inversion H4. inversion H4.
    + destruct H2. exists (test x t2 t3).
      apply ST_Test. apply H2.
  - left. right. constructor.
  - destruct IHhas_type.
    + inversion H0.
      * inversion H1; rewrite <- H2 in H; inversion H.
      * inversion H1.
        left. right. apply nv_scc. apply nv_zro.
        left. right. apply nv_scc. apply nv_scc. apply H2.
    + destruct H0. right. exists (scc x).
      apply ST_Scc. apply H0.
  - destruct IHhas_type.
    + inversion H0.
      * inversion H1; rewrite <- H2 in H; inversion H.
      * inversion H1.
        right. exists zro. apply ST_PrdZro.
        right. exists t. apply ST_PrdScc. apply H2.
    + destruct H0. right. exists (prd x). apply ST_Prd. apply H0.
  - destruct IHhas_type.
    + inversion H0.
      * inversion H1; rewrite <- H2 in H; inversion H.
      * inversion H1.
        right. exists tru. apply ST_IszroZro.
        right. exists fls. apply ST_IszroScc. apply H2.
    + destruct H0. right. exists (iszro x). apply ST_Iszro. apply H0.
Qed.

Theorem preservation : forall t t' T,
    |- t ? T ->
    t --> t' ->
    |- t' ? T.
Proof.
  intros t t' T H1 H2.
  generalize dependent t'.
  induction H1.
  - intros t' H2. inversion H2.
  - intros t' H2. inversion H2.
  - intros t' H2. inversion H2; subst.
    + apply H1_0.
    + apply H1_1.
    + apply T_Test.
      * apply IHhas_type1. apply H4.
      * apply H1_0.
      * apply H1_1.
  - intros t' H2. inversion H2.
  - intros t' H2. inversion H2; subst.
    apply T_Scc. apply IHhas_type. apply H0.
  - intros t' H2. inversion H2; subst.
    + apply T_Zro.
    + inversion H1. apply H3.
    + apply T_Prd. apply IHhas_type. apply H0.
  - intros t' H2. inversion H2; subst.
    + apply T_Tru.
    + apply T_Fls.
    + apply T_Iszro. apply IHhas_type. apply H0.
Qed.

Theorem proservation': forall t t' T,
    |- t ? T ->
    t --> t' ->
    |- t' ? T.
Proof with eauto.
  intros t t' T H1 H2.
  generalize dependent T.
  induction H2; intros T H1.
  - inversion H1; subst. apply H5.
  - inversion H1; subst. apply H6.
  - apply T_Test.
    + apply IHstep. inversion H1; subst. apply H4.
    + inversion H1; subst. apply H6.
    + inversion H1; subst. apply H7.
  - inversion H1; subst. apply T_Scc. apply IHstep. apply H0.
  - inversion H1. apply T_Zro.
  - inversion H1; subst. inversion H2. apply H3.
  - inversion H1; subst. apply T_Prd. apply IHstep. apply H0.
  - inversion H1; subst. apply T_Tru.
  - inversion H1; subst. apply T_Fls.
  - inversion H1; subst. apply T_Iszro. apply IHstep. apply H0.
Qed.

Definition multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

Corollary soundness : forall t t' T,
    |- t ? T ->
    t -->* t' ->
    ~(stuck t').
Proof.
  intros t t' T HT P. induction P; intros [R S].
  destruct (progress x T HT); auto.
  apply IHP. apply (preservation x y T HT H).
  unfold stuck. split; auto.
Qed.


Require Import UnivalentParametricity.theories.Basics UnivalentParametricity.theories.StdLib.Basics.
Require Import NatBinDefs ALCTactics.

Require Import BinInt BinNat Nnat.

Require Import Utf8.
Require Export Zdiv.

Require Export DoubleType.

Unset Universe Minimization ToSet.

Definition nat := Datatypes.nat.
Definition S := Datatypes.S.

(* axiomatization of int63 and its operations *)

Require Import Int63.

Definition int63 : Type := int.

Local Open Scope Z_scope.

(* Axiomatization of the equivalence with Z modulo 2^62*)

Require Import BinInt Zpow_facts.

Definition ZwB := { n : Z & 0 <= n < wB }.

Local Open Scope int63_scope.

Lemma to_Z_bounded : forall x, 0 <= to_Z x < wB.
Proof.
 unfold to_Z, wB;induction size;intros.
 simpl;auto with zarith.
 rewrite inj_S;simpl;assert (W:= IHn (x >> 1)).
 rewrite Zpower_Zsucc;auto with zarith.
 destruct (is_even x).
 rewrite Zdouble_mult;auto with zarith.
 rewrite Zdouble_plus_one_mult;auto with zarith.
Qed.

Definition to_ZwB : int63 -> ZwB := fun x => (to_Z x; to_Z_bounded x).

Definition of_ZwB (z:ZwB) : int63 := of_Z z.1.

Lemma to_ZwB_section : forall x, of_ZwB (to_ZwB x) = x.
  unfold of_ZwB, to_ZwB; simpl. intro. rewrite of_to_Z. reflexivity.
Defined.

Definition IsIrr_le_Z (n m : Z) : IsIrr (n <= m)%Z.
Proof.
  apply IsIrr_forall. intro. exact IsIrr_False.
Defined.

Definition IsIrr_lt_Z (n m : Z) : IsIrr (n < m)%Z.
Proof.
  intros x y. unfold Z.lt in *.
  pose (is_hset (n ?= m)%Z Lt (logic_eq_is_eq x) (logic_eq_is_eq y)).
  refine (logic_eq_is_eq_inj x y e).
Defined.

Definition isHProp_leq_Z (n m p : Z): IsIrr (n <= m < p).
Proof.
  apply IsIrr_conj. apply IsIrr_le_Z. apply IsIrr_lt_Z.
Defined.

Definition eqZ_ZwB (x y:ZwB) : x.1 = y.1 -> x = y.
Proof.
  intro e. apply path_sigma_uncurried. unshelve eexists.
  apply isHProp_leq_Z.
Defined.

Definition to_ZwB_retraction : forall x, to_ZwB (of_ZwB x) = x.
  unfold of_ZwB, to_ZwB; destruct x; apply eqZ_ZwB; simpl.
  rewrite of_Z_spec. now rewrite Z.mod_small.
Defined.

Program Definition mod_inj : Z -> ZwB := fun z => (z mod wB; _)%Z.
Next Obligation.
  apply Z.mod_pos_bound. compute. reflexivity.
Defined.

Definition IsEquiv_to_Z_ : IsEquiv to_ZwB := isequiv_adjointify _ of_ZwB to_ZwB_section to_ZwB_retraction.

(* now instrumenting type class resolution *)

Instance IsEquiv_to_Z : IsEquiv to_ZwB := IsEquiv_to_Z_.

Instance equiv_int_ZwB : int63 ≃ ZwB := BuildEquiv _ _ to_ZwB _.

Instance equiv_ZwB_int : ZwB ≃ int63 := Equiv_inverse _.

Instance compat_ZwB_int : ZwB ⋈ int := @Canonical_UR _ _ _.

Instance compat_int_ZwB : int ⋈ ZwB := UR_Type_Inverse _ _ compat_ZwB_int.

Definition compat_eq_int : @eq int63 ≈ @eq ZwB := ltac:(tc).
Definition compat_eq_ZwB : @eq ZwB ≈ @eq int63 := ltac:(tc).

#[export] Hint Extern 0 (eq ZwB _ _ ≃ _) => eapply compat_eq_ZwB : typeclass_instances.
#[export] Hint Extern 0 (eq int _ _ ≃ _) => eapply compat_eq_int : typeclass_instances.
#[export] Hint Extern 0 (eq int63 _ _ ≃ _) => eapply compat_eq_int : typeclass_instances.
#[export] Hint Extern 0 (eq ZwB _ _ ⋈ _) => eapply compat_eq_ZwB : typeclass_instances.
#[export] Hint Extern 0 (eq int _ _ ⋈ _) => eapply compat_eq_int : typeclass_instances.
#[export] Hint Extern 0 (eq int63 _ _ ⋈ _) => eapply compat_eq_int : typeclass_instances.

(* addition on Z modulo 2^63 *)

Program Definition ZwB_add : ZwB -> ZwB -> ZwB :=
  fun n m => ((n.1 + m.1) mod wB ; _)%Z.
Next Obligation.
  now apply Z.mod_pos_bound.
Defined.

Declare Scope ZwB_scope.

Notation "n + m" := (ZwB_add n m) : ZwB_scope.

Local Open Scope ZwB_scope.

Definition ZwB_comm (n m: ZwB) : n + m = m + n.
Proof.
  unfold ZwB_add, ZwB_add_obligation_1. simpl.
  rewrite Z.add_comm; reflexivity.
Defined.

Local Open Scope int63_scope.

(* ompatibility with add *)

Definition compat_add : add ≈ ZwB_add.
  simpl; intros. apply eqZ_ZwB. simpl.
  now rewrite add_spec, H, H0.
Defined.

Definition compat_add' : ZwB_add ≈ add := compat_inverse2 compat_add.

#[export] Hint Extern 0 (add _ _ = _) => eapply compat_add : typeclass_instances.
#[export] Hint Extern 0 (ZwB_add _ _ = _) => eapply compat_add' : typeclass_instances.
#[export] Hint Extern 0 (_ = to_ZwB (add _ _)) => eapply compat_add' : typeclass_instances.

(* now property on 2wB_add can be lifted to add on int *)

Definition add_comm : forall (n m: int), n + m = m + n := ↑ ZwB_comm.

(* multiplication on Z modulo 2^63 *)

Program Definition ZwB_mul : ZwB -> ZwB -> ZwB :=
  fun n m => ((n.1 * m.1) mod wB ; _)%Z.
Next Obligation.
  now apply Z.mod_pos_bound.
Defined.

Notation "n * m" := (ZwB_mul n m) : ZwB_scope.

(* compatibility with mul *)

Definition compat_mul : mul ≈ ZwB_mul.
  simpl; intros. apply eqZ_ZwB. simpl.
  now rewrite mul_spec, H, H0.
Defined.

Definition compat_mul' : ZwB_mul ≈ mul := compat_inverse2 compat_mul.

#[export] Hint Extern 0 (mul _ _ = _) => eapply compat_mul : typeclass_instances.
#[export] Hint Extern 0 (ZwB_mul _ _ = _) => eapply compat_mul' : typeclass_instances.

(* substraction on Z modulo 2^63 *)

Program Definition ZwB_sub : ZwB -> ZwB -> ZwB :=
  fun n m => ((n.1 - m.1) mod wB ; _)%Z.
Next Obligation.
  now apply Z.mod_pos_bound.
Defined.

Notation "n - m" := (ZwB_sub n m) : ZwB_scope.

(* compatibility with sub *)

Definition compat_sub : sub ≈ ZwB_sub.
  simpl; intros. apply eqZ_ZwB. simpl.
  now rewrite sub_spec, H, H0.
Defined.

Definition compat_sub' : ZwB_sub ≈ sub := compat_inverse2 compat_sub.

#[export] Hint Extern 0 (sub _ _ = _) => eapply compat_sub : typeclass_instances.
#[export] Hint Extern 0 (ZwB_sub _ _ = _) => eapply compat_sub' : typeclass_instances.

(* lsl on Z modulo 2^63 *)

Program Definition ZwB_lsl : ZwB -> ZwB -> ZwB :=
  fun n m => ((n.1 * Z.pow 2 m.1) mod wB ; _)%Z.
Next Obligation.
  now apply Z.mod_pos_bound.
Defined.

Notation "n << m" := (ZwB_lsl n m) : ZwB_scope.

Arguments ZwB_lsl : simpl never.

(* compatibility with mul *)

Definition compat_lsl : lsl ≈ ZwB_lsl.
  simpl; intros. apply eqZ_ZwB. simpl.
  now rewrite lsl_spec, H, H0.
Defined.

Definition compat_lsl' : ZwB_lsl ≈ lsl := compat_inverse2 compat_lsl.

#[export] Hint Extern 0 (lsl _ _ = _) => eapply compat_lsl : typeclass_instances.
#[export] Hint Extern 0 (ZwB_lsl _ _ = _) => eapply compat_lsl' : typeclass_instances.
#[export] Hint Extern 0 (_ = to_ZwB (lsl _ _)) => eapply compat_lsl : typeclass_instances.
#[export] Hint Extern 0 (ZwB_lsl _ _ = _) => eapply compat_lsl' : typeclass_instances.

Local Open Scope Z_scope.
Local Open Scope ZwB_scope.

Coercion mod_inj : Z >-> ZwB.

Definition ZwB_lsl_add_distr x y n : (x + y) << n = (x << n) + (y << n).
apply eqZ_ZwB. unfold ZwB_lsl. simpl.
rewrite -> Zmult_mod_idemp_l. rewrite <-Zplus_mod.
eapply ap2; try reflexivity. change_eq_to_Logic_eq; auto with zarith.
Defined.

Local Open Scope int63_scope.

Definition lsl_add_distr : forall x y n, (x + y) << n = (x << n) + (y << n) :=
  ↑ ZwB_lsl_add_distr.

(* Test with polynomials *)

Local Open Scope Z_scope.

Definition poly : Z -> Z :=
  fun n =>  45 + Z.pow n 100 - Z.pow n 99 * 16550.

Goal poly 16550 = 45.
  Time compute. reflexivity.
Defined.

Local Open Scope ZwB_scope.

Fixpoint ZwB_pow z (n:nat) : ZwB := match n with 0%nat => 1 | Datatypes.S n => z * ZwB_pow z n end.

Local Open Scope Z_scope.

Local Open Scope ZwB_scope.

Definition poly_ZwB : ZwB -> ZwB :=
  fun n => 45 + ZwB_pow n 100%nat - ZwB_pow n 99%nat * 16550.

Goal poly_ZwB 16550 = 45.
  Time reflexivity.
Defined.

Fixpoint pow z (n:nat) : int := match n with 0%nat => 1 | Datatypes.S n => z * pow z n end.

Lemma succ_spec x : Z.succ (Z.of_nat x) = Z.pos (Pos.of_succ_nat x).
  destruct x. easy. cbn. apply ap.
  now rewrite Pos.add_1_r.
Defined.

Definition compat_pow : pow ≈ ZwB_pow.
  simpl; intros. destruct H0. apply eqZ_ZwB. induction x0.
  - easy.
  - simpl. rewrite IHx0. simpl. rewrite mul_spec. now rewrite H.
Defined.

Definition compat_pow' : ZwB_pow ≈ pow.
  simpl; intros. destruct H0. apply eqZ_ZwB. induction x0.
  - easy.
  - simpl. rewrite IHx0. simpl. rewrite mul_spec. now rewrite H.
Defined.

#[export] Hint Extern 0 (pow _ _ = _) => eapply compat_pow : typeclass_instances.
#[export] Hint Extern 0 (ZwB_pow _ _ = _) => eapply compat_pow' : typeclass_instances.
#[export] Hint Extern 0 (_ = to_ZwB (pow _ _)) => eapply compat_pow : typeclass_instances.
#[export] Hint Extern 0 (ZwB_pow _ _ = _) => eapply compat_pow' : typeclass_instances.

Opaque pow ZwB_pow.

Goal poly_ZwB 16550 = 45.
  unfold poly_ZwB. Opaque mod_inj. replace_goal. Transparent mod_inj. Time reflexivity.
Defined.


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

(* Why3 assumption *)
Definition unit  := unit.

(* Why3 assumption *)
Inductive list (a:Type) :=
  | Nil : list a
  | Cons : a -> (list a) -> list a.
Set Contextual Implicit.
Implicit Arguments Nil.
Unset Contextual Implicit.
Implicit Arguments Cons.

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint infix_plpl (a:Type)(l1:(list a)) (l2:(list a)) {struct l1}: (list
  a) :=
  match l1 with
  | Nil => l2
  | (Cons x1 r1) => (Cons x1 (infix_plpl r1 l2))
  end.
Unset Implicit Arguments.

Axiom Append_assoc : forall (a:Type), forall (l1:(list a)) (l2:(list a))
  (l3:(list a)), ((infix_plpl l1 (infix_plpl l2
  l3)) = (infix_plpl (infix_plpl l1 l2) l3)).

Axiom Append_l_nil : forall (a:Type), forall (l:(list a)), ((infix_plpl l
  (Nil :(list a))) = l).

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint length (a:Type)(l:(list a)) {struct l}: Z :=
  match l with
  | Nil => 0%Z
  | (Cons _ r) => (1%Z + (length r))%Z
  end.
Unset Implicit Arguments.

Axiom Length_nonnegative : forall (a:Type), forall (l:(list a)),
  (0%Z <= (length l))%Z.

Axiom Length_nil : forall (a:Type), forall (l:(list a)),
  ((length l) = 0%Z) <-> (l = (Nil :(list a))).

Axiom Append_length : forall (a:Type), forall (l1:(list a)) (l2:(list a)),
  ((length (infix_plpl l1 l2)) = ((length l1) + (length l2))%Z).

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint mem (a:Type)(x:a) (l:(list a)) {struct l}: Prop :=
  match l with
  | Nil => False
  | (Cons y r) => (x = y) \/ (mem x r)
  end.
Unset Implicit Arguments.

Axiom mem_append : forall (a:Type), forall (x:a) (l1:(list a)) (l2:(list a)),
  (mem x (infix_plpl l1 l2)) <-> ((mem x l1) \/ (mem x l2)).

Axiom mem_decomp : forall (a:Type), forall (x:a) (l:(list a)), (mem x l) ->
  exists l1:(list a), exists l2:(list a), (l = (infix_plpl l1 (Cons x l2))).

(* Why3 assumption *)
Inductive tree  :=
  | Leaf : tree
  | Node : tree -> tree -> tree .

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint depths(d:Z) (t:tree) {struct t}: (list Z) :=
  match t with
  | Leaf => (Cons d (Nil :(list Z)))
  | (Node l r) => (infix_plpl (depths (d + 1%Z)%Z l) (depths (d + 1%Z)%Z r))
  end.
Unset Implicit Arguments.

Axiom depths_head : forall (t:tree) (d:Z), match (depths d
  t) with
  | (Cons x _) => (d <= x)%Z
  | Nil => False
  end.

Axiom depths_unique : forall (t1:tree) (t2:tree) (d:Z) (s1:(list Z))
  (s2:(list Z)), ((infix_plpl (depths d t1) s1) = (infix_plpl (depths d t2)
  s2)) -> ((t1 = t2) /\ (s1 = s2)).

Axiom depths_prefix : forall (t:tree) (d1:Z) (d2:Z) (s1:(list Z)) (s2:(list
  Z)), ((infix_plpl (depths d1 t) s1) = (infix_plpl (depths d2 t) s2)) ->
  (d1 = d2).

Axiom depths_prefix_simple : forall (t:tree) (d1:Z) (d2:Z), ((depths d1
  t) = (depths d2 t)) -> (d1 = d2).

Axiom depths_subtree : forall (t1:tree) (t2:tree) (d1:Z) (d2:Z) (s1:(list
  Z)), ((infix_plpl (depths d1 t1) s1) = (depths d2 t2)) -> (d2 <= d1)%Z.

Axiom depths_unique2 : forall (t1:tree) (t2:tree) (d1:Z) (d2:Z), ((depths d1
  t1) = (depths d2 t2)) -> ((d1 = d2) /\ (t1 = t2)).

(* Why3 assumption *)
Definition lex(x1:((list Z)* Z)%type) (x2:((list Z)* Z)%type): Prop :=
  match x1 with
  | (s1, d1) =>
      match x2 with
      | (s2, d2) => ((length s1) < (length s2))%Z \/
          (((length s1) = (length s2)) /\ match (s1,
          s2) with
          | ((Cons h1 _), (Cons h2 _)) => ((d2 < d1)%Z /\ (d1 <= h1)%Z) /\
              (h1 = h2)
          | _ => False
          end)
      end
  end.

(* Why3 goal *)
Theorem WP_parameter_harness : ~ forall (t:tree), ~ ((depths 0%Z
  t) = (Cons 1%Z (Cons 3%Z (Cons 3%Z (Cons 2%Z (Nil :(list Z))))))).
(* YOU MAY EDIT THE PROOF BELOW *)
intuition.
apply (H (Node Leaf (Node (Node Leaf Leaf) Leaf))).
reflexivity.
Qed.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

(** Common definitions of real series, based on real sequences definitions. *)

Require Import Reals.
Require Import Rsequence.
Open Local Scope R_scope.
Open Local Scope Rseq_scope.

Implicit Type Un : Rseq.
(** printing ~	~ *)
(** * Convergence of series *)

Definition Rser_cv Un l := Rseq_cv (sum_f_R0 Un) l.

Definition Rser_abs_cv Un l := Rseq_cv (sum_f_R0 (|Un|)) l.

Definition Rser_cv_pos_infty Un := Rseq_cv_pos_infty (sum_f_R0 Un).

Definition Rser_cv_neg_infty Un := Rseq_cv_neg_infty (sum_f_R0 Un).

(** * Bounds *)

Definition Rser_bound_max Un M := forall n, sum_f_R0 Un n <= M.

(*Definition Rser_bound_min Un m := forall n, m <= sum_f_R0 Un n.*)

Definition Rser_bound Un M := forall n, Rabs (sum_f_R0 Un n) <= M.

Definition Rser_abs_bound Un M := forall n, sum_f_R0 (fun k => Rabs (Un k)) n <= M.

(** * Remainders of series *)

Definition Rser_rem (Un : nat -> R) (l : R) (Hcv : Rser_cv Un l) (n : nat) :=  (l - (sum_f_R0 Un n))%R.


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

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.