Require Import List.
Require Import Bedrock.Word Coq.micromega.Psatz.

Require Import NArith NArithRing.
Local Open Scope N_scope.

Lemma natToWordToN : (* FIXME this is a simplified copy of the same lemma in Bedrock.IL *)
  forall n m,
    (N_of_nat m < Npow2 n)%N ->
    wordToN (natToWord n m) = N_of_nat m.
  intros; rewrite wordToN_nat, wordToNat_natToWord_idempotent by assumption.
  reflexivity.
Qed.

Lemma wordToN_combine:
  forall sz1 sz2 (w1: word sz1) (w2: word sz2), wordToN (combine w1 w2) = wordToN w1 + Npow2 sz1 * wordToN w2.
Proof.
  induction w1; simpl; intros.
  - destruct (wordToN w2); reflexivity.
  - rewrite IHw1; destruct b, (wordToN w1), (Npow2 n), (wordToN w2); reflexivity.
Qed.

Lemma Npow2_gt_zero:
  forall sz : nat, 0 < Npow2 sz.
Proof.
  induction sz; try reflexivity.
  apply N.mul_pos_pos; auto || reflexivity.
Qed.

Lemma Npow2_ge_one:
  forall sz : nat, 1 <= Npow2 sz.
Proof.
  intros.
  apply N.lt_succ_r.
  rewrite <- N.add_1_l.
  apply N.lt_sub_lt_add_l.
  apply Npow2_gt_zero.
Qed.

Lemma wordToN_wzero {sz} :
  wordToN (wzero sz) = 0%N.
Proof.
  intros; unfold wzero; rewrite natToWordToN.
  - reflexivity.
  - apply Npow2_gt_zero.
Qed.

Lemma wordToN_extend sz sz' :
  forall (w: word sz), wordToN (combine w (wzero sz')) = wordToN w.
Proof.
  intros; rewrite (wordToN_combine sz sz').
  rewrite wordToN_wzero; ring.
Qed.

Lemma N_le_succ_plus_1 : forall n m : N, (n + 1 <= m)%N <-> (n < m)%N.
Proof.
  intros; rewrite N.add_1_r.
  apply N.le_succ_l.
Qed.

Lemma N_lt_double_lt:
  forall p p' : N,
    (p < p')%N ->
    (2 * p < 2 * p')%N.
Proof.
  intros; apply N.mul_lt_mono_pos_l; eauto; reflexivity.
Qed.

Lemma N_le_double:
  forall p : N,
    (p <= 2 * p)%N.
Proof.
  intros; replace (2 * p)%N with (p + p)%N by ring.
  replace p with (0 + p)%N at 1 by ring.
  rewrite <- N.add_le_mono_r.
  apply N.le_0_l.
Qed.

Lemma N_lt_double:
  forall p : N,
    (0 < p)%N ->
    (p < 2 * p)%N.
Proof.
  intros; replace (2 * p)%N with (p + p)%N by ring.
  replace p with (0 + p)%N at 1 by ring.
  rewrite <- N.add_lt_mono_r.
  assumption.
Qed.

Lemma wordToN_bound {size} (w: Word.word size):
  (wordToN w < Npow2 size)%N.
Proof.
  Opaque N.mul.
  induction size.
  - rewrite (shatter_word_0 w); reflexivity.
  - destruct (shatter_word_S w) as (b & [ w' ? ]); subst.
    destruct b; simpl.
    rewrite <- N.add_1_r.
    auto using N.double_above.
    auto using N_lt_double_lt, N.double_above.
Qed.

Lemma NToWord_wordToN {sz} :
  forall (w: word sz), NToWord _ (wordToN w) = w.
Proof.
  intros; rewrite NToWord_nat, wordToN_nat, Nat2N.id, natToWord_wordToNat;
    reflexivity.
Qed.

Lemma wordToN_wones :
  forall sz, wordToN (wones sz) = Npow2 sz - 1.
Proof.
  induction sz.
  - reflexivity.
  - simpl; rewrite IHsz.
    pose proof (Npow2_ge_one sz); lia.
Qed.

Lemma wordToN_wnot:
  forall (n : nat) (w : word n), wordToN (wnot w) = Npow2 n - 1 - wordToN w.
Proof.
  destruct n; intros.
  - shatter_word w; reflexivity.
  - destruct (shatter_word_S w) as (b & [ w' ? ]); subst.
    revert b; induction w'.
    + destruct b; reflexivity.
    + intros; simpl in *;
        rewrite IHw';
        destruct b0; simpl; [ lia | ];
          destruct b; pose proof (wordToN_bound w'); lia.
Qed.

Lemma wplus_wnot_1:
  forall (n : nat) (w : word n), wordToN w + (Npow2 n - 1 - wordToN w) = Npow2 n - 1.
Proof.
  intros; pose proof (wordToN_bound (size := n) w); lia.
Qed.

Lemma wplus_wnot {sz}:
  forall w, wplus w (wnot w) = wones sz.
Proof.
  unfold wplus, wordBin; intros.
  rewrite wordToN_wnot, wplus_wnot_1, <- wordToN_wones, NToWord_wordToN;
    reflexivity.
Qed.

Definition W16 := Word.word 16.
Definition lo8 (w: W16) : word 8 := @split1 8 8 w.
Definition hi8 (w: W16) : word 8 := @split2 8 8 w.

Lemma wnot_involutive {sz} :
  forall (w: word sz),
    wnot (wnot w) = w.
Proof.
  induction w.
  - reflexivity.
  - simpl.
    rewrite IHw, Bool.negb_involutive; reflexivity.
Qed.

Lemma wnot_inj {sz} :
  forall w1 w2: word sz,
    wnot w1 = wnot w2 ->
    w1 = w2.
Proof.
  intros w1 w2 H.
  apply (f_equal (@wnot _)) in H.
  rewrite !wnot_involutive in H; assumption.
Qed.

Lemma wmsb_wzero {sz} :
  wmsb (wzero (S sz)) true = false.
Proof.
  induction sz; eauto.
Qed.

Lemma wmsb_wones {sz} :
  wmsb (wones sz) true = true.
Proof.
  induction sz; eauto.
Qed.

Fixpoint waddmsb {sz} (w: word sz) msb : word (S sz) :=
  match w with
  | WO => WS msb WO
  | WS b sz w' => WS b (waddmsb w' msb)
  end.

Lemma wmsb_waddmsb:
  forall (sz : nat) (w : word sz) (b b' : bool), wmsb (waddmsb w b) b' = b.
Proof.
  induction w; simpl; intros; try rewrite IHw; reflexivity.
Qed.

Lemma wnot_waddmsb {sz} :
  forall b (w: word sz), (wnot (waddmsb w b)) = waddmsb (wnot w) (negb b).
Proof.
  induction w; simpl; congruence.
Qed.

Lemma wordToN_waddmsb:
  forall b (sz : nat) (w : word sz), wordToN (waddmsb w b) = wordToN w + (if b then Npow2 sz else 0).
Proof.
  induction w;
    repeat match goal with
           | _ => ring
           | _ => reflexivity
           | _ => progress simpl
           | _ => rewrite <- !N.add_1_r
           | [ H: bool |- _ ] => destruct H
           | [ H: _ |- _ ] => rewrite H
           end.
Qed.

Lemma wnot_wones_wzero :
  forall sz, wnot (wones sz) = wzero sz.
Proof.
  induction sz; simpl; try rewrite IHsz; reflexivity.
Qed.

Lemma wnot_wzero_wones :
  forall sz, wnot (wzero sz) = wones sz.
Proof.
  intros; rewrite <- wnot_wones_wzero.
  apply wnot_involutive.
Qed.

Lemma wmsb_wnot':
  forall (n : nat) (w : word n) (b : bool), wmsb (wnot w) (negb b) = negb (wmsb w b).
Proof.
  induction w; simpl; intros.
  * reflexivity.
  * rewrite IHw; reflexivity.
Qed.

Lemma wmsb_wnot:
  forall (n : nat) (w : word (S n)), wmsb (wnot w) true = negb (wmsb w true).
Proof.
  intros; destruct (shatter_word_S w) as (b & [ w' ? ]); subst.
  simpl; apply wmsb_wnot'.
Qed.

Lemma wordToN_NToWord_idempotent:
  forall (sz : nat) (p : N),
    p < Npow2 sz ->
    wordToN (NToWord sz p) = p.
Proof.
  intros; rewrite NToWord_nat.
  rewrite natToWordToN; rewrite N2Nat.id; auto.
Qed.

Lemma wordToN_posToWord :
  forall (sz : nat) (p : positive),
    Npos p < Npow2 sz ->
    wordToN (posToWord sz p) = Npos p.
Proof.
  intros; rewrite <- (wordToN_NToWord_idempotent sz (Npos p)); auto.
Qed.

Require Import ZArith ZArithRing.
Local Open Scope Z_scope.

Fixpoint count from n :=
  match n with
  | O => nil
  | S x => from :: (count (from + 1) x)
  end.

Infix "+^+" := combine (at level 50).

Definition OneCToZ {sz} (w : word sz) : Z :=
  if wmsb w true then
    (* Negative *)
    match wordToN (wnot w) with
      | N0 => 0%Z
      | Npos x => Zneg x
    end
  else
    (* Positive *)
    match wordToN w with
      | N0 => 0%Z
      | Npos x => Zpos x
    end.

Require Import Program.

Definition normalizeZ p z :=
  let offset := Z.of_N (Npow2 p - 1) in
  let modulus := Z.of_N (Npow2 (S p) - 1) in
  (Z.modulo (z + offset) modulus) - offset.

(*Compute (List.map (normalizeZ 3) (count (-40) 40)). *)

Definition ZToOneC {sz} (z: Z) : word sz :=
  match sz with
  | O => WO
  | S sz' => match (normalizeZ sz' z) with
            | Z0 => wones (S sz')
            | Zpos x => waddmsb (posToWord sz' x) false
            | Zneg x => wnot (waddmsb (posToWord sz' x) false)
            end
  end.

(* Compute (@ZToOneC 4 8). *)

Lemma gt_minus_one_ge_zero :
  forall z, -1 < z <-> 0 <= z.
Proof.
  intros; omega.
Qed.

Hint Rewrite Z.lt_sub_lt_add_l : normalizeZ.
Hint Rewrite Z.lt_sub_lt_add_r : normalizeZ.
Hint Rewrite <- Z.lt_add_lt_sub_l : normalizeZ.
Hint Rewrite <- Z.lt_add_lt_sub_r : normalizeZ.
Hint Rewrite @gt_minus_one_ge_zero : normalizeZ.

Require Import Coq.micromega.Psatz.

Notation OneC_InRange p z := ((- Z.of_N (Npow2 p)) < z < Z.of_N (Npow2 p)).

Lemma normalizeZ_range :
  forall p z, OneC_InRange p (normalizeZ p z).
Proof.
  split;
    repeat match goal with
           | _ => progress intros
           | _ => progress unfold normalizeZ
           | _ => progress ring_simplify
           | _ => progress autorewrite with normalizeZ
           | _ => progress rewrite ?N2Z.inj_mul, ?N2Z.inj_sub by eauto using Npow2_ge_one
           | _ => simpl (Z.of_N _)
           end.
  - apply Z_mod_lt.
    pose proof (Npow2_ge_one p); lia.
  - rewrite Z.lt_add_lt_sub_r.
    apply Z_mod_lt.
    pose proof (Npow2_ge_one p); lia.
Qed.

Lemma normalizeZ_rangeN :
  forall p z,
    match normalizeZ p z with
    | Z0 => True
    | Zpos x => (Npos x < Npow2 p)%N
    | Zneg x => (Npos x < Npow2 p)%N
    end.
Proof.
  intros; destruct (normalizeZ_range p z).
  destruct (normalizeZ _ _); lia.
Qed.

Lemma weqb_correct {sz} :
  forall w1 w2: word sz,
    Word.weqb w1 w2 = false -> w1 <> w2.
Proof.
  red; intros ??? Heq.
  rewrite <- weqb_true_iff in Heq.
  congruence.
Qed.

Definition weqdec {sz} :
  forall w1 w2: word sz,
    { w1 = w2 } + { w1 <> w2 }.
Proof.
  intros; destruct (Word.weqb w1 w2) eqn:?.
  apply weqb_sound in Heqb; auto.
  apply weqb_correct in Heqb; auto.
Defined.

Definition OneC_plus {sz} (w1 w2: word sz) :=
  if weqdec w1 (wzero sz) then
    w2
  else if weqdec w2 (wzero sz) then
         w1
       else
         @ZToOneC sz (OneCToZ w1 + OneCToZ w2).

Infix "^1+" := (OneC_plus) (at level 50, left associativity) : oneC_scope.
Local Open Scope oneC_scope.

Ltac destruct_eqdec :=
  repeat match goal with
         | [  |- context[if (weqdec ?a (wzero ?sz)) then _ else _] ] =>
           lazymatch a with
           | context[if _ then _ else _] => fail
           (* | context[Z.add] => fail *)
           | _ => destruct (weqdec a (wzero sz)); subst
           end
         end.

Lemma OneC_plus_comm {sz}:
  forall (w1 w2: word sz),
    w1 ^1+ w2 = w2 ^1+ w1.
Proof.
  unfold OneC_plus; intros; rewrite Z.add_comm.
  destruct_eqdec; congruence.
Qed.

Lemma OneCToZ_wzero:
  forall sz : nat, OneCToZ (wzero sz) = 0.
Proof.
  unfold OneCToZ.
  destruct sz; [reflexivity|].
  rewrite wmsb_wzero, wordToN_wzero.
  reflexivity.
Qed.

Lemma OneCToZ_wones:
  forall sz : nat, OneCToZ (wones sz) = 0.
Proof.
  unfold OneCToZ.
  destruct sz; [reflexivity|].
  rewrite wmsb_wones, wnot_wones_wzero, wordToN_wzero.
  reflexivity.
Qed.

Lemma OneCToZ_ZToOneC {sz}:
  forall z, OneCToZ (@ZToOneC sz z) = match sz with
                                 | O => 0
                                 | S sz => normalizeZ sz z
                                 end.
Proof.
  unfold ZToOneC; destruct sz; intros.
  - reflexivity.
  - pose proof (normalizeZ_rangeN sz z);
      destruct (normalizeZ _ _) eqn:? ;
      repeat match goal with
             | _ => solve [auto]
             | _ => solve [apply OneCToZ_wones]
             | _ => progress simpl
             | _ => progress unfold OneCToZ
             | _ => progress rewrite ?wmsb_waddmsb, ?wnot_waddmsb, ?wordToN_waddmsb
             | _ => progress rewrite ?N.add_0_r, ?wordToN_posToWord, ?wnot_involutive
             end.
Qed.

Lemma normalizeZ_add_1 :
  forall z z1 z2,
    (z1 + ((z2 + (z - 1)) mod (2 * z - 1) - (z - 1)) + (z - 1)) mod (2 * z - 1) =
    (z1 + z2 + (z - 1)) mod (2 * z - 1).
Proof.
  intros.
  replace (z1 + ((z2 + (z - 1)) mod (2 * z - 1) - (z - 1)) + (z - 1))
  with (z1 + (z2 + (z - 1)) mod (2 * z - 1)) by ring.
  rewrite Zplus_mod, Zmod_mod, <- Zplus_mod.
  f_equal; ring.
Qed.

Lemma normalizeZ_add_normalizeZ_r {sz} :
  forall z1 z2,
    normalizeZ sz (z1 + (normalizeZ sz z2)) =
    normalizeZ sz (z1 + z2).
Proof.
  unfold normalizeZ; intros;
    repeat match goal with
           | _ => progress rewrite ?N2Z.inj_mul, ?N2Z.inj_sub by eauto using Npow2_ge_one
           | _ => progress (simpl (Z.of_N _); simpl (Npow2 _))
           | _ => set (Z.of_N _)
           end.
  f_equal; apply normalizeZ_add_1.
Qed.

Lemma normalizeZ_add_normalizeZ_l {sz} :
  forall z1 z2,
    normalizeZ sz ((normalizeZ sz z2) + z1) =
    normalizeZ sz (z1 + z2).
Proof.
  intros; rewrite Z.add_comm; apply normalizeZ_add_normalizeZ_r.
Qed.

Lemma wzero_S {sz} :
  wzero (S sz) = (wzero sz)~0.
Proof.
  rewrite <- natToWord_wordToNat at 1.
  rewrite <- natToWord_wordToNat.
  f_equal.
Qed.

Lemma wones_not_wzero {sz}:
  wones (S sz) <> wzero (S sz).
Proof.
  rewrite <- wnot_wones_wzero; discriminate.
Qed.

Lemma whd_waddmsb {sz}:
  forall b (w: word (S sz)),
    whd (waddmsb w b) = whd w.
Proof.
  intros;
    destruct (shatter_word_S w) as (? & [ ? ? ]);
    subst; reflexivity.
Qed.

Fixpoint wcountones {sz} (w: word sz) : nat :=
  match w with
  | WO => 0
  | WS x n w' => (if Bool.eqb x true then 1 else 0) + wcountones w'
  end%nat.

Lemma wcountones_wzero {sz} :
  wcountones (wzero sz) = 0%nat.
Proof.
  rewrite <- wzero'_def.
  induction sz; simpl; congruence.
Qed.

Lemma wcountones_waddmsb {sz} :
  forall (w: word sz) b,
    wcountones (waddmsb w b) =
    wcountones (WS b w).
Proof.
  induction w; simpl in *; intros.
  - reflexivity.
  - specialize (IHw b0).
    destruct b; destruct b0; simpl in *; rewrite IHw; reflexivity.
Qed.

Lemma wcountones_zero {sz} :
  forall w: word sz,
    wcountones w = 0%nat ->
    w = wzero _.
Proof.
  induction w.
  - reflexivity.
  - destruct b; simpl; intros; try discriminate.
    rewrite IHw by assumption.
    apply wzero_S.
Qed.

Lemma ZToOneC_nonzero {sz} :
  forall z: Z,
    ZToOneC z <> wzero (S (S sz)).
Proof.
  red; intros.
  unfold ZToOneC in *.
  pose proof (normalizeZ_rangeN (S sz) z);
    destruct (normalizeZ _ _) in *;
    match goal with
    | _ => eapply wones_not_wzero; eassumption
    | [ H: _ = wzero _ |- _ ] =>
      rewrite ?wnot_waddmsb in H;
        apply (f_equal (@wcountones _)) in H;
        rewrite wcountones_wzero, wcountones_waddmsb in H;
        simpl in H
    end.
  - apply wcountones_zero in H;
      apply (f_equal (@wordToN _)) in H;
      rewrite wordToN_posToWord, wordToN_wzero in H by assumption;
      discriminate.
  - discriminate.
Qed.

Lemma OneC_plus_assoc {sz}:
  forall (w1 w2 w3: word sz),
    w1 ^1+ (w2 ^1+ w3) = (w1 ^1+ w2) ^1+ w3.
Proof.
  unfold OneC_plus; destruct sz; intros.
  - setoid_rewrite shatter_word_0; reflexivity.
  - destruct_eqdec; try congruence;
      try match goal with
          | [ H: ZToOneC _ = (wzero _) |- _ ] =>
            destruct sz; [ | exfalso; eapply ZToOneC_nonzero; eassumption]
          end;
      change (wzero 1) with (WO~0) in *;
      repeat match goal with
             | [ w: word 1 |- _ ] => shatter_word w
             | [ b: bool |- _ ] => destruct b; try congruence
             end.

    rewrite !OneCToZ_ZToOneC; unfold ZToOneC.
    rewrite ?normalizeZ_add_normalizeZ_l, ?normalizeZ_add_normalizeZ_r.
    replace (OneCToZ w3 + (OneCToZ w1 + OneCToZ w2)) with (OneCToZ w1 + (OneCToZ w2 + OneCToZ w3)) by ring.
    reflexivity.
Qed.

Lemma OneCToZ_wnot_neg:
  forall (sz : nat) (w : word sz), OneCToZ (wnot w) = - OneCToZ w.
Proof.
  destruct w.
  + reflexivity.
  + unfold OneCToZ.
    rewrite wmsb_wnot.
    destruct (wmsb _ _);
      repeat match goal with
             | _ => reflexivity
             | _ => progress simpl
             | _ => progress rewrite ?Bool.negb_involutive, ?wnot_involutive
             | [  |- context[if ?t then ?a else ?b] ] =>
               destruct (if t then a else b)
             end.
Qed.

Lemma normalizeZ_zero:
  forall sz : nat, normalizeZ sz 0 = 0.
Proof.
  unfold normalizeZ; intros; simpl.
  rewrite Z.mod_small.
  - ring.
  - pose proof (Npow2_ge_one sz); lia.
Qed.

Lemma ZToOneC_zero:
  forall sz : nat, ZToOneC 0 = wones sz.
Proof.
  destruct sz.
  - reflexivity.
  - unfold ZToOneC.
    rewrite normalizeZ_zero; reflexivity.
Qed.

Lemma OneC_plus_wnot {sz}:
  forall w, w ^1+ (wnot w) = wones sz.
Proof.
  unfold OneC_plus; intros.
  rewrite OneCToZ_wnot_neg.
  replace (_ + _) with 0 by ring.
  destruct_eqdec; try congruence.
  - apply wnot_wzero_wones.
  - apply wnot_inj. rewrite wnot_wones_wzero; assumption.
  - apply ZToOneC_zero.
Qed.

Definition add_bytes_into_checksum (b_hi b_lo: word 8) (checksum: W16) :=
  let w16 := combine b_lo b_hi in
  checksum ^1+ w16.

Fixpoint checksum bytes : W16 :=
  match bytes with
  | nil => wzero _
  | x :: nil => add_bytes_into_checksum x (wzero _) (wzero _)
  | x :: y :: t => add_bytes_into_checksum x y (checksum t)
  end.

Fixpoint make_pairs {A} (ls: list A) zero :=
  match ls with
  | nil => nil
  | x :: nil => [(x, zero)]
  | x :: y :: t => (x, y) :: (make_pairs t zero)
  end.

Definition checksum' byte_pairs : W16 :=
  fold_right (fun p chk => add_bytes_into_checksum (fst p) (snd p) chk) (wzero _) byte_pairs.

Lemma checksum_checksum' :
  forall bytes,
    checksum bytes = checksum' (make_pairs bytes (wzero _)).
Proof.
  fix IH 1.
  destruct bytes.
  - reflexivity.
  - destruct bytes.
    + reflexivity.
    + simpl; rewrite IH; reflexivity.
Qed.

Require Import Permutation.

Lemma add_bytes_into_checksum_swap:
  forall (chk : W16) (b11 b12 b21 b22 : word 8),
    add_bytes_into_checksum b22 b21 (add_bytes_into_checksum b12 b11 chk) =
    add_bytes_into_checksum b12 b11 (add_bytes_into_checksum b22 b21 chk).
Proof.
  unfold add_bytes_into_checksum.
  intros; rewrite <- !OneC_plus_assoc.
  rewrite (OneC_plus_comm (combine b11 b12)).
  reflexivity.
Qed.

Lemma checksum'_permutation :
  forall bs1 bs2,
    Permutation bs1 bs2 ->
    checksum' bs1 = checksum' bs2.
Proof.
  induction 1.
  - reflexivity.
  - simpl; rewrite IHPermutation; reflexivity.
  - simpl. rewrite add_bytes_into_checksum_swap; reflexivity.
  - etransitivity; eauto.
Qed.

Lemma checksum'_app :
  forall bs1 bs2,
    checksum' (bs1 ++ bs2) = checksum' (bs2 ++ bs1).
Proof.
  intros; apply checksum'_permutation, Permutation_app_comm.
Qed.

Lemma make_pairs_app {A} :
  forall bs1,
    (exists x, length bs1 = 2 * x)%nat ->
    (forall bs2 z, @make_pairs A (bs1 ++ bs2) z = make_pairs bs1 z ++ make_pairs bs2 z).
Proof.
  fix IH 1.
  destruct bs1; simpl.
  - reflexivity.
  - destruct bs1; simpl; intros Hex *; destruct Hex as [x ?].
    + (* Absurd case *) omega.
    + f_equal; rewrite IH.
      * reflexivity.
      * exists (pred x); omega.
Qed.

Lemma checksum_app :
  forall bs1 bs2,
    (exists x, length bs1 = 2 * x)%nat ->
    (exists x, length bs2 = 2 * x)%nat ->
    checksum (bs1 ++ bs2) = checksum (bs2 ++ bs1).
Proof.
  intros; rewrite !checksum_checksum'.
  rewrite !make_pairs_app by assumption.
  apply checksum'_app.
Qed.

Lemma checksum_correct :
  forall bytes,
    let chk := checksum bytes in
    let neg := wnot chk in
    checksum ((hi8 neg) :: (lo8 neg) :: bytes) = wones _.
Proof.
  repeat match goal with
         | _ => progress intros
         | _ => progress unfold lo8, hi8, add_bytes_into_checksum
         | _ => progress (unfold checksum; fold checksum)
         | _ => rewrite combine_split
         | [ H := _ |- _ ] => unfold H in *; clear H
         | _ => eauto using OneC_plus_wnot
         end.
Qed.

Lemma normalizeZ_noop :
  forall p z, OneC_InRange p z -> normalizeZ p z = z.
Proof.
  intros * (? & ?).
  unfold normalizeZ; intros;
    repeat match goal with
           | _ => progress rewrite ?N2Z.inj_mul, ?N2Z.inj_sub by eauto using Npow2_ge_one
           | _ => progress (simpl (Z.of_N _); simpl (Npow2 _))
           end; set (Z.of_N _) in *.
  rewrite Z.mod_small by lia.
  ring.
Qed.

Lemma WS_match_eq_refl {sz sz'} :
  forall b (w: word sz) (w': word sz') (eql: sz = sz') (eqlS: S sz = S sz'),
    w = match eql in _ = y return (word y -> word sz) with
        | eq_refl => fun x: word sz => x
        end w' ->
    WS b w = match eqlS in _ = y return (word y -> word (S sz)) with
             | eq_refl => fun x: word (S sz) => x
             end (WS b w').
Proof.
  intros.
  destruct eql; subst.
  rewrite (UIP_nat _ _ eqlS eq_refl).
  reflexivity.
Qed.

Lemma wmsb_combine {sz} :
  forall (w : word (S sz)) b,
  exists w' : word sz,
    w = match eq_sym (NPeano.Nat.add_1_r sz) in (_ = y) return (word y -> word (S sz)) with
        | eq_refl => fun w' => w'
        end (w' +^+ WS (wmsb w b) WO).
Proof.
  induction sz; intros;
    destruct (shatter_word_S w) as (b' & [ w' ? ]); subst.
  - exists WO; pose proof (shatter_word_0 w'); subst; simpl.
    rewrite (UIP_nat _ _ (NPeano.Nat.add_1_r 0) eq_refl); reflexivity.
  - specialize (IHsz w' b'); destruct IHsz as (w'' & Heq).
    simpl.
    exists (WS b' w'').
    change (WS b' w'' +^+ WS (wmsb w' b') WO) with (WS b' (w'' +^+ WS (wmsb w' b') WO)).
    eapply WS_match_eq_refl.
    rewrite Heq at 1.
    reflexivity.
Qed.

Lemma normalizeZ_OneCToZ {sz} :
  forall w: word (S sz), normalizeZ sz (OneCToZ w) = (OneCToZ w).
Proof.
  intros.
  apply normalizeZ_noop.
  unfold OneCToZ.
  pose proof (Npow2_ge_one sz).
  destruct (wmsb _ _) eqn:Heqb; destruct (wordToN _) eqn:Heqn;
    repeat match goal with
           | _ => lia
           | [ H: wordToN (wnot ?w) = _, Heqb: wmsb ?w _ = _ |- _ ] =>
             apply (f_equal negb) in Heqb; rewrite <- (wmsb_wnot' (S sz) w true) in Heqb; simpl in Heqb
           | [ H: wmsb ?w ?b = _ |- _ ] =>
             let w' := fresh in
             let Heqw := fresh in
             destruct (wmsb_combine w b) as (w' & Heqw);
               rewrite Heqw in Heqn;
               rewrite <- (NPeano.Nat.add_1_r sz) in *;
               simpl in Heqn;
               clear Heqw;
               rewrite wordToN_combine in Heqn;
               pose proof (wordToN_bound w');
               simpl in Heqn; rewrite Heqb in Heqn; simpl in Heqn
           end.
Qed.

Lemma NToWord_zero {sz} :
  NToWord sz 0 = wzero sz.
Proof.
  rewrite NToWord_nat; simpl; reflexivity.
Qed.

Lemma wordToN_wzero' {sz} :
  forall w: word sz,
    wordToN w = 0%N ->
    w = wzero _.
Proof.
  intros.
  apply (f_equal (@NToWord sz)) in H.
  rewrite NToWord_wordToN, NToWord_zero in H.
  assumption.
Qed.

Lemma wordToN_NToWord :
  forall sz w, exists k, (wordToN (NToWord sz w) = w - k * Npow2 sz /\ k * Npow2 sz <= w)%N.
Proof.
  intros.
  destruct (wordToNat_natToWord sz (N.to_nat w)) as [ w' (Heq & side_condition) ].
  exists (N.of_nat w').
  rewrite NToWord_nat.
  rewrite wordToN_nat.
  split.
  - apply N2Nat.inj.
    rewrite Nat2N.id, N2Nat.inj_sub, N2Nat.inj_mul, Nat2N.id, Npow2_nat.
    assumption.
  - unfold N.le. rewrite N2Nat.inj_compare.
    rewrite <- nat_compare_le.
    rewrite N2Nat.inj_mul, Nat2N.id, Npow2_nat.
    assumption.
Qed.

Lemma waddmsb_NToWord {sz} :
  forall n,
    (n < Npow2 sz)%N ->
    waddmsb (NToWord sz n) false = (NToWord (S sz) n).
Proof.
  intros.
  apply wordToN_inj.
  rewrite wordToN_waddmsb; ring_simplify.
  rewrite !wordToN_NToWord_idempotent; simpl; lia.
Qed.

Lemma wordToN_bound_wmsb_false:
  forall (sz : nat) (w : word (S sz)) b,
    wmsb w b = false ->
    (wordToN w < Npow2 sz)%N.
Proof.
  induction sz.
  - intros; shatter_word w; simpl in *; subst; reflexivity.
  - intros * Heq; destruct (shatter_word_S w) as (b' & [ w' ? ]); subst; simpl in *.
    specialize (IHsz w' b' Heq).
    destruct b'; lia.
Qed.

Lemma ZToOneC_OneCToZ:
  forall (sz : nat) (w : word sz),
    w <> wzero _ ->
    ZToOneC (OneCToZ w) = w.
Proof.
  unfold ZToOneC.
  destruct sz; intros.
  - rewrite shatter_word_0; reflexivity.
  - rewrite normalizeZ_OneCToZ.
    unfold OneCToZ.
    destruct (wmsb _ _) eqn:Heqb; destruct (wordToN _) eqn:Heqn.
    + apply wordToN_wzero' in Heqn.
      apply wnot_inj.
      rewrite wnot_wones_wzero.
      auto.
    + apply wnot_inj; rewrite wnot_involutive.
      change (posToWord sz p) with (NToWord sz (N.pos p)).
      rewrite <- Heqn, waddmsb_NToWord, NToWord_wordToN.
      * reflexivity.
      * eapply wordToN_bound_wmsb_false.
        rewrite wmsb_wnot, Heqb; reflexivity.
    + apply wordToN_wzero' in Heqn.
      congruence.
    + change (posToWord sz p) with (NToWord sz (N.pos p)).
      rewrite <- Heqn.
      rewrite waddmsb_NToWord, NToWord_wordToN.
      * reflexivity.
      * eapply wordToN_bound_wmsb_false; eassumption.
Qed.

Lemma OneC_plus_wones {sz} :
  forall w,
    w <> (wzero sz) ->
    OneC_plus (wones sz) w = w.
Proof.
  unfold OneC_plus; intros.
  pose proof (@wones_not_wzero sz).
  destruct (weqdec (wones _) _), (weqdec w (wzero sz));
    try congruence.
  rewrite OneCToZ_wones; simpl.
  rewrite ZToOneC_OneCToZ; auto.
Qed.

Lemma split1_wzero:
  forall sz sz' : nat, split1 sz sz' (wzero (sz + sz')) = wzero sz.
Proof.
  intros; rewrite <- !wzero'_def.
  induction sz.
  - reflexivity.
  - simpl; f_equal; congruence.
Qed.

Lemma split2_wzero:
  forall sz sz' : nat, split2 sz sz' (wzero (sz + sz')) = wzero sz'.
Proof.
  intros; rewrite <- !wzero'_def.
  induction sz.
  - reflexivity.
  - simpl; f_equal; congruence.
Qed.

Lemma wzero_combine {sz sz'} :
  forall (w0: word sz) (w1: word sz'),
    combine w0 w1 = wzero _ ->
    w0 = wzero _ /\ w1 = wzero _.
Proof.
  intros * H.
  pose proof (f_equal (@split1 sz sz') H).
  pose proof (f_equal (@split2 sz sz') H).
  rewrite split1_combine, split1_wzero in H0.
  rewrite split2_combine, split2_wzero in H1.
  intuition.
Qed.

Lemma OneC_plus_wones_wzero {sz} :
  wones sz ^1+ wzero sz = wones sz.
Proof.
  unfold OneC_plus.
  pose proof (@wones_not_wzero sz);
    repeat match goal with
           | [  |- context[weqdec ?a ?b] ] => destruct (weqdec a b)
           end; congruence.
Qed.

Lemma combine_inj {sz sz'}:
  forall w00 w01 w10 w11,
    @combine sz w01 sz' w00 = combine w11 w10 ->
    w00 = w10 /\ w01 = w11.
Proof.
  intros * Heq; split;
    [ apply (f_equal (@split2 sz sz')) in Heq
    | apply (f_equal (@split1 sz sz')) in Heq];
    rewrite ?split1_combine, ?split2_combine in *;
    assumption.
Qed.

Lemma add_bytes_into_checksum_inj_l:
  forall (y00 y01 y10 y11 : word 8) chk,
    (y00 <> wzero _ \/ y01 <> wzero _) ->
    (y10 <> wzero _ \/ y11 <> wzero _) ->
    add_bytes_into_checksum y00 y01 chk =
    add_bytes_into_checksum y10 y11 chk ->
    y00 = y10 /\ y01 = y11.
Proof.
  unfold add_bytes_into_checksum; intros * nonz0 nonz1 H.
  apply (f_equal (fun x => (wnot chk) ^1+ x)) in H.
  rewrite !(OneC_plus_assoc (wnot chk)), !(OneC_plus_comm (wnot chk)), !OneC_plus_wnot in H.
  repeat lazymatch goal with
         | [ H: context[wones _ ^1+ ?w] |- _ ] =>
           let heq := fresh "heq" in
           let hneq := fresh "hneq" in
           destruct (weqdec w (wzero _)) as [ heq | hneq ];
             [ rewrite heq in H; setoid_rewrite OneC_plus_wones_wzero in H |
               setoid_rewrite (OneC_plus_wones w hneq) in H ]
         | [ H: _ +^+ _ = wzero _ |- _ ] => apply wzero_combine in H; destruct H; subst
         end;
    try solve [split; reflexivity];
    try solve [match goal with
               | [ H: _ \/ _ |- _ ] => destruct H; try congruence
               end].
  apply combine_inj. eassumption.
Qed.

Lemma checksum'_somewhat_injective :
  forall x y0 y1 z,
    fst y0 <> wzero 8 \/ snd y0 <> wzero 8 ->
    fst y1 <> wzero 8 \/ snd y1 <> wzero 8 ->
    checksum' (x ++ y0 :: z) = checksum' (x ++ y1 :: z) ->
    y0 = y1.
Proof.
  intros * ? ? H.
  rewrite !(checksum'_app _ (_ :: _)), <- !app_comm_cons in H.
  simpl in H; apply add_bytes_into_checksum_inj_l in H; try assumption.
  destruct y0, y1, H; simpl in *; congruence.
Qed.

Lemma wplus_three {sz} :
  forall w1 w2 w3: word sz,
    w1 ^+ w2 ^+ w3 =
    NToWord sz (wordToN w1 + wordToN w2 + wordToN w3)%N.
Proof.
  intros.
  rewrite !wordToN_nat, !NToWord_nat, !N2Nat.inj_add, !Nat2N.id.
  repeat rewrite wplus_alt; unfold wplusN, wordBinN.
  repeat match goal with
         | [ H: _ = _ |- _ ] => rewrite H; clear H
         | [ |- context[wordToNat (natToWord ?sz ?w)] ] =>
           destruct (wordToNat_natToWord sz w) as [? [? ?]]
         end.
  replace (wordToNat w1 + wordToNat w2 - x * pow2 sz + wordToNat w3)%nat
  with (wordToNat w1 + wordToNat w2 + wordToNat w3 - x * pow2 sz)%nat by omega.
  apply drop_sub; omega.
Qed.

Definition OneC_plus_wplus sz :=
  forall w1 w2: word sz,
    OneC_plus w1 w2 =
    w1 ^+ w2 ^+ split2 _ _ (zext w1 sz ^+ zext w2 sz).

Fixpoint EnumerateWords sz : list (word sz) :=
  match sz with
  | O => [WO]
  | S sz' =>
    let wds := EnumerateWords sz' in
    map (@WS true sz') wds ++ map (@WS false sz') wds
  end.

Lemma Enumerate_exhaustive {sz} :
  forall w: word sz, In w (EnumerateWords sz).
Proof.
  induction w.
  - simpl; tauto.
  - simpl; rewrite in_app_iff.
    destruct b; [left|right];
      rewrite in_map_iff;
      exists w; tauto.
Qed.

Lemma brute_force_works {sz} :
  forall (P: word sz -> bool),
    (forallb P (EnumerateWords sz) = true) ->
    (forall w, P w = true).
Proof.
  intros * H w.
  rewrite forallb_forall in H.
  pose proof (@Enumerate_exhaustive sz).
  eauto.
Qed.

Lemma brute_force_works' {sz} :
  forall (P: word sz -> Prop)
    (P': word sz -> bool),
    (forall w, P' w = true -> P w) ->
    (forallb P' (EnumerateWords sz) = true) ->
    (forall w, P w).
Proof.
  intros * correctB forallB w.
  apply correctB; revert w.
  apply brute_force_works; assumption.
Qed.

Ltac OneC_plus_wplus_t :=
  red; intros; rewrite <- weqb_true_iff;
  repeat lazymatch goal with
         | [ w: word _ |- _ ] => revert w; apply brute_force_works
         end.

(*Lemma brute_force8 :
  OneC_plus_wplus 8.
Proof.
  OneC_plus_wplus_t.
  Time vm_compute.
  reflexivity.
Time Qed. *)


Require Export Undecidability.Synthetic.Definitions Lia.
Require Import Undecidability.Shared.Dec.
Require Import Setoid Morphisms.

Definition discrete X := decidable (fun '(x,y) => x = y :> X).

(* Facts on reflects *)

Lemma reflects_not b P :
  reflects b P -> reflects (negb b) (~P).
Proof.
  unfold reflects.
  destruct b; cbn; intuition congruence.
Qed.

Lemma reflects_conj {b1 b2 P1 P2} :
  reflects b1 P1  -> reflects b2 P2 -> reflects (b1 && b2) (P1 /\ P2).
Proof.
  unfold reflects.
  destruct b1, b2; cbn; firstorder congruence.
Qed.

Lemma reflects_disj {b1 b2 P1 P2} :
  reflects b1 P1  -> reflects b2 P2 -> reflects (b1 || b2) (P1 \/ P2).
Proof.
  unfold reflects.
  destruct b1, b2; cbn; firstorder congruence.
Qed.

Lemma reflects_prv b (P : Prop) : (b = true -> P) -> (b = false -> ~ P) -> reflects b P.
Proof.
  intros H1 H2.
  destruct b; cbn; firstorder.
Qed.

(* Type-theoretic characterisations *)

Lemma dec_decidable' X p :
  (forall x : X, dec (p x)) -> { f : _ | forall x, p x <-> f x = true}.
Proof.
  intros d. exists (fun x => if d x then true else false). intros x. destruct (d x); firstorder congruence.
Qed.

Lemma decidable_iff X p :
  decidable p <-> inhabited (forall x : X, dec (p x)).
Proof.
  split.
  - intros [f H]. econstructor. intros x. specialize (H x). destruct (f x); firstorder congruence.
  - intros [d]. eapply dec_decidable' in d as [f]. now exists f.
Qed.

Lemma decidable_iff' X p :
  {f | decider f p} -> (forall x : X, dec (p x)).
Proof.
  intros [f H]. intros x. specialize (H x). destruct (f x); firstorder congruence.
Qed.

(* Closure properties of decidability *)

Lemma discrete_iff X :
  discrete X <-> inhabited (eq_dec X).
Proof.
  split.
  - intros [D] % decidable_iff. econstructor. intros x y; destruct (D (x,y)); firstorder.
  - intros [d]. eapply decidable_iff. econstructor. intros (x,y). eapply d.
Qed.

Lemma dec_compl X p :
  decidable p -> decidable (fun x : X => ~ p x).
Proof.
  intros [f H]. exists (fun x => negb (f x)).
  intros x. eapply reflects_not, H.
Qed.

Lemma dec_compl' X p :
  decidable (fun x : X => ~ ~ p x) -> decidable (fun x : X => ~ p x).
Proof.
  intros [f H]. exists (fun x => negb (f x)).
  intros x. specialize (H x). apply reflects_not in H.
  unfold reflects in *. tauto.
Qed.

Lemma dec_conj X p q :
  decidable p -> decidable q -> decidable (fun x : X => p x /\ q x).
Proof.
  intros [f] [g]. exists (fun x => andb (f x) (g x)).
  intros x. eapply reflects_conj; eauto.
Qed.

Lemma dec_disj X p q :
  decidable p -> decidable q -> decidable (fun x : X => p x \/ q x).
Proof.
  intros [f] [g]. exists (fun x => orb (f x) (g x)).
  intros x. eapply reflects_disj; eauto.
Qed.

(* Proper lemmas *)

#[global]
Instance Proper_decides {X} :
  Proper (pointwise_relation X (@eq bool) ==> pointwise_relation X iff ==> iff ) (@decider X).
Proof.
  intros f g H1 p q H2. red in H1, H2.
  unfold decider, reflects.
  split; intros H x.
  - now rewrite <- H2, H, H1.
  - now rewrite H2, H, H1.
Qed.

#[global]
Instance Proper_decidable {X} :
  Proper (pointwise_relation X iff ==> iff) (@decidable X).
Proof.
  intros p q H2.
  split; intros [f H]; exists f.
  - now rewrite <- H2.
  - now rewrite H2.
Qed.

(* Closure properties of discreteness *)

Lemma discrete_bool : discrete bool.
Proof.
  eapply discrete_iff. econstructor. unfold dec. decide equality.
Qed.

Lemma discrete_nat : discrete nat.
Proof.
  eapply discrete_iff. econstructor. unfold dec. decide equality.
Qed.

Lemma discrete_prod X Y : discrete X -> discrete Y -> discrete (X * Y).
Proof.
  intros [d1] % discrete_iff [d2] % discrete_iff.
  eapply discrete_iff. econstructor. unfold dec. decide equality.
  all: solve [apply d1|apply d2].
Qed.

Lemma discrete_sum X Y : discrete X -> discrete Y -> discrete (X + Y).
Proof.
  intros [d1] % discrete_iff [d2] % discrete_iff.
  eapply discrete_iff. econstructor. unfold dec. decide equality.
  all: solve [apply d1|apply d2].
Qed.

Lemma discrete_option X : discrete X -> discrete (option X).
Proof.
  intros [d1] % discrete_iff. eapply discrete_iff.
  econstructor. unfold dec. decide equality.
  apply d1.
Qed.

Lemma discrete_list X : discrete X -> discrete (list X).
Proof.
  intros [d1] % discrete_iff. eapply discrete_iff.
  econstructor. unfold dec. decide equality.
  apply d1.
Qed.


From mathcomp Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import eqtype ssrnat seq bigop choice.
From ipcssr Require Import prelude.

Inductive tree A := TNode of A & seq (tree A).
Arguments TNode [A].

Section Tree.
Context {A : Type}.

(* a leaf is a node with an empty list *)
Definition lf a : tree A := TNode a [::].

Lemma tree_ind' (P : tree A -> Prop) :
  (forall a l, all_prop P l -> P (TNode a l)) ->
  forall t, P t.
Proof.
move=> indu; fix H 1.
elim => a l; apply indu.
by elim: l.
Qed.

Lemma tree_rec' (P : tree A -> Type) :
  (forall a l, all_type P l -> P (TNode a l)) ->
  forall t, P t.
Proof.
move=>indu; fix H 1.
elim => a l; apply: indu.
by elim: l.
Qed.

(*
Fixpoint height (t : tree A) : nat :=
  let: TNode _ l := t in (\max_(i <- map height l) i).+1.
*)

Definition root (t : tree A) : A :=
  let: TNode w _ := t in w.

Definition children_of_node (t : tree A) : seq (tree A) :=
  let: TNode _ l := t in l.

End Tree.

Section EncodeDecodeTree.
Variable A : Type.

Fixpoint encode_tree (t : tree A) : GenTree.tree A :=
  match t with
  | TNode a [::] => GenTree.Leaf a
  | TNode a l => GenTree.Node O(*dummy*) (GenTree.Leaf a :: map encode_tree l)
  end.

Fixpoint decode_tree (t : GenTree.tree A) : option (tree A) :=
  match t with
  | GenTree.Leaf a => Some (TNode a [::])
  | GenTree.Node _ (GenTree.Leaf h :: l) => Some (TNode h (pmap decode_tree l))
  | GenTree.Node _ _ => None
  end.

Lemma pcancel_tree : pcancel encode_tree decode_tree.
Proof.
elim/(@tree_ind' A) => a [//|b s /= [-> H2 /=]]; congr (Some (TNode _ (_ :: _))).
elim: s H2 => // c s IH /= [-> K2 /=]; by rewrite IH.
Qed.

End EncodeDecodeTree.

Definition tree_eqMixin (A : eqType) := PcanEqMixin (@pcancel_tree A).
Canonical tree_eqType (A : eqType) := Eval hnf in EqType _ (@tree_eqMixin A).

(* we formulate the rest of the theory with decidable equality for convenience *)
(* this is because we only use it for Kripke trees whose elements are *)
(* sets (AVL-maps) of atoms, which implies dec. eq. *)
Section TreeEq.
Context {A : eqType}.

Fixpoint mem_tree (t : tree A) : pred A :=
  let: TNode x l := t in
  fun a => (a == x) || has (mem_tree^~ a) l.

Definition tree_eqclass := tree A.
Identity Coercion tree_of_eqclass : tree_eqclass >-> tree.
Coercion pred_of_tree (t : tree_eqclass) : {pred A} := mem_tree t.

Canonical tree_predType := PredType (pred_of_tree : tree A -> pred A).
(* The line below makes mem_tree a canonical instance of topred. *)
Canonical mem_tree_predType := PredType mem_tree.

Lemma in_tnode a t ts : (t \in TNode a ts) = (t == a) || has (fun q => t \in q) ts.
Proof. by []. Qed.

(* successor *)

Fixpoint successor (t1 t2 : tree A) : bool :=
  (t1 == t2) || has (successor t1) (children_of_node t2).

Lemma successor_refl : reflexive successor.
Proof. by case=>/= a ts; rewrite eqxx. Qed.

Lemma successor_trans : transitive successor.
Proof.
move=>t2 t1; elim/(@tree_ind' A)=>a3 ts3 /= IH H1.
case/orP=>[/eqP E2|]; first by rewrite E2 in H1.
case/hasP=>z Hz Pz; apply/orP; right; apply/hasP; exists z=>//.
by move: H1 Pz; apply: (all_prop_mem IH).
Qed.

Lemma successorP t1 t2 :
  reflect (t1 = t2 \/ exists2 t, t \in children_of_node t2 & successor t1 t)
          (successor t1 t2).
Proof.
apply: (iffP idP).
- by case: t2=>/=a2 ts2; case/orP=>[/eqP->|/hasP H]; [left | right].
case=>[->|[t Ht St]]; first by exact: successor_refl.
by case: t2 Ht=>/= a ts2 Ht; apply/orP; right; apply/hasP; exists t.
Qed.

(* never used? *)
Lemma successor_ind (P : tree A -> Prop) :
  (forall a, P (lf a)) ->
  (forall t0 t1, successor t0 t1 -> P t0 -> P t1) ->
  forall t, P t.
Proof.
move=>Pl Pc t.
apply: tree_ind'=>a [_ |h ts /= [Ph Pts]]; first by apply: Pl.
by apply: (Pc h)=>//=; rewrite successor_refl orbT.
Qed.

Lemma successor_subset (t t0 : tree A) :
  successor t t0 -> {subset t <= t0}.
Proof.
elim/(@tree_ind' A): t0=>a0 ts0 /= IH.
case/orP=>[/eqP->|] //; case/hasP=>/= z Hz Sz.
have H: {subset t <= z} by apply: (all_prop_mem IH).
move=>q /H Hq; rewrite in_tnode /=.
by apply/orP; right; apply/hasP; exists z.
Qed.

(* monotone *)

Context {I : Type}.

Fixpoint Is_Monotone_Tree (P : A -> I -> bool) (t : tree A) : Prop :=
  let: TNode x l := t in
  all_prop (fun t => (forall i, P x i ==> P (root t) i)
                  /\ Is_Monotone_Tree P t) l.

Lemma successor_is_monotone_tree {P} (t t0 : tree A) :
  successor t0 t -> Is_Monotone_Tree P t -> Is_Monotone_Tree P t0.
Proof.
elim/(@tree_ind' A): t=>a ts /= IH.
case/orP=>[/eqP->|] //; case/hasP=>/= z Hz Sz H.
apply: (all_prop_mem IH z) =>{t0 Sz IH}//.
by case: (all_prop_mem H _ Hz).
Qed.

Definition Is_Monotone (P : A -> I -> bool) (t : tree A) : Prop :=
  forall t0 t1 : tree A,
  successor t1 t0 -> successor t0 t ->
  forall i : I, P (root t0) i ==> P (root t1) i.

Lemma successor_is_monotone {P} (t t0 : tree A) :
  successor t0 t -> Is_Monotone P t -> Is_Monotone P t0.
Proof.
move=>S0; rewrite /Is_Monotone => H t1 t2 S21 S10.
by apply: H=>//; apply/successor_trans/S0.
Qed.

Lemma is_monotone_tree_is_monotone {P} t :
  Is_Monotone_Tree P t -> Is_Monotone P t.
Proof.
rewrite /Is_Monotone=>H t0 t1 S10 S0 i.
move: (successor_is_monotone_tree _ _ S0 H)=>{S0 H}.
elim/(@tree_ind' A): t0 S10=>a0 ts0 /= IH.
case/orP=>[/eqP-> _|] //=; case/hasP=>/= z Hz Sz H.
case: (all_prop_mem H _ Hz)=>Hi Hmz.
apply: (implyb_trans (y:=P (root z) i))=>//.
by apply: (all_prop_mem IH).
Qed.

End TreeEq.


(** * Finite types *)

(* [fin n : Type] is a type with [n] inhabitants. It is isomorphic to
   [Coq.Vector.Fin.t] from the standard library, but we found this formulation
   easier to reason about. *)

(* In this compiler, we use [fin n] as the type of "block labels" in [Asm]
   programs (program locations that can be jumped to). In an earlier version, labels
   could be any type, but this restriction makes [Asm] programs easier to introspect
   for defining optimizations (though the current development doesn't make use of it).
  *)

(* The instances at the end derive categorical operations for the subcategories of
   [Fun] and [ktree] on finite types (instead of arbitrary types). *)

(* begin hide *)
From Coq Require Import
     Arith
     Lia.

From ITree Require Import
     ITree
     ITreeFacts
     Basics.Category
     Basics.CategorySub.
(* end hide *)

(* Type with [n] inhabitants. *)
Definition fin (n : nat) : Type := { x : nat | x < n }.

(* Hide proof terms. *)
(* N.B.: [x < n] unfolds to [S x < n], which is why we don't make the first
   field more precise. *)
Notation fi' i := (exist (fun j : nat => _) i _).

Program Definition f0 {n} : fin (S n) := fi' 0.
Next Obligation. lia. Defined.

Lemma unique_fin : forall n (i j : fin n),
    proj1_sig i = proj1_sig j -> i = j.
Proof.
  intros ? [] [] w. simpl in w; destruct w. f_equal; apply le_unique.
Qed.

Lemma unique_f0 : forall (a : fin 1), a = f0.
Proof.
  destruct a. apply unique_fin; simpl. lia.
Qed.

Program Definition fS {n} : fin n -> fin (S n) :=
  fun i => fi' (S (proj1_sig i)).
Next Obligation.
  destruct i; simpl; lia.
Defined.

Lemma fin_0 {A} : fin 0 -> A.
Proof.
  intros [].
  apply PeanoNat.Nat.nlt_0_r in l.
  contradiction.
Qed.

Instance FinInitial {E} : Initial (sub (ktree E) fin) 0 := fun _ => fin_0.

Lemma split_fin_helper:
  forall n m x : nat, x < n + m -> ~ x < n -> x - n < m.
Proof.
  intros n m x l n0.
  lia.
Defined.

Program Definition split_fin_sum (n m : nat)
  : fin (n + m) -> (fin n) + (fin m) := fun x =>
    match lt_dec (proj1_sig x) n with
    | left _ => inl (fi' (proj1_sig x))
    | right _ => inr (fi' (proj1_sig x - n))
    end.
Next Obligation.
  apply split_fin_helper. eapply proj2_sig. assumption.
Defined.

Program Definition L {n} (m : nat) (a : fin n) : fin (n + m) := _.
Next Obligation.
  destruct a.
  exists x. apply PeanoNat.Nat.lt_lt_add_r.  assumption.
Defined.

Program Definition R {m} (n:nat) (a:fin m) : fin (n + m) := _.
Next Obligation.
  destruct a.
  exists (n + x). lia.
Defined.

Lemma R_0_a : forall (n:nat) (a : fin n), R 0 a = a.
Proof.
  intros; destruct a; apply unique_fin; reflexivity.
Qed.

Lemma R_1_a : forall (n:nat) (a : fin n), R 1 a = fS a.
Proof.
  intros; destruct a; apply unique_fin; reflexivity.
Qed.

Lemma split_fin_sum_0_a : forall m (a : fin (0 + m)),
    (@split_fin_sum 0 m a) = inr a.
Proof.
  intros.
  unfold split_fin_sum, split_fin_sum_obligation_1.
  destruct (Compare_dec.lt_dec _ 0) as [H | H].
  - inversion H.
  - f_equal. destruct a; apply unique_fin. simpl; lia.
Qed.

Lemma split_fin_sum_FS_inr :
  (@split_fin_sum (S O) (S O) (fS f0) = inr f0).
Proof.
  cbn; f_equal; apply unique_f0.
Qed.

Lemma split_fin_sum_f1_inl :
  (@split_fin_sum 1 1 (@f0 1)) = inl f0.
Proof.
  cbn; f_equal; apply unique_f0.
Qed.

Lemma L_1_f1 : (L 1 (@f0 0)) = f0.
Proof.
  apply unique_fin; reflexivity.
Qed.

Lemma split_fin_sum_L_L_f1 :
  (@split_fin_sum _ _ (L 1 (L 1 (@f0 0)))) = inl f0.
Proof.
  cbn; f_equal; apply unique_fin; reflexivity.
Qed.

Lemma split_fin_sum_R_2 : split_fin_sum 2 1 (R 2 (@f0 0)) = inr f0.
Proof.
  cbn; f_equal; apply unique_fin; reflexivity.
Qed.

Lemma split_fin_sum_R n m (x : fin m) : split_fin_sum n m (R n x) = inr x.
Proof.
  destruct x; simpl. unfold split_fin_sum; simpl.
  destruct lt_dec.
  - exfalso. lia.
  - f_equal. apply unique_fin; simpl; lia.
Qed.

Lemma split_fin_sum_L n m (x : fin n) : split_fin_sum n m (L m x) = inl x.
Proof.
  destruct x; simpl. unfold split_fin_sum; simpl.
  destruct lt_dec.
  - f_equal. apply unique_fin; simpl; lia.
  - exfalso. lia.
Qed.

Definition merge_fin_sum (n m: nat) : fin n + fin m -> fin (n + m) :=
  fun v =>
    match v with
    | inl v => L m v
    | inr v => R n v
    end.

Lemma merge_fin_sum_inr : (merge_fin_sum 1 1 (inr f0)) = (fS f0).
Proof.
  apply unique_fin; reflexivity.
Qed.

Lemma merge_fin_sum_inl_1 f : (merge_fin_sum 1 1 (inl f)) = f0.
Proof.
  rewrite (unique_f0 f); apply unique_fin; reflexivity.
Qed.

Lemma merge_split:
  forall (n m : nat) (a : fin (n + m)), merge_fin_sum n m (split_fin_sum n m a) = a.
Proof.
  intros n m []. unfold split_fin_sum; simpl.
  destruct (lt_dec x n); apply unique_fin; simpl; reflexivity + lia.
Qed.

Lemma split_merge:
  forall (n m : nat) (a : fin n + fin m), split_fin_sum n m (merge_fin_sum n m a) = a.
Proof.
  intros n m [[] | []]; unfold split_fin_sum; simpl; destruct lt_dec; simpl;
    try (f_equal; apply unique_fin; simpl; reflexivity + lia);
    try contradiction + exfalso; lia.
Qed.

Instance ToBifunctor_ktree_fin {E} : ToBifunctor (ktree E) fin sum Nat.add :=
  fun n m y => Ret (split_fin_sum n m y).

Instance FromBifunctor_ktree_fin {E} : FromBifunctor (ktree E) fin sum Nat.add :=
  fun n m y => Ret (merge_fin_sum n m y).

Instance IsoBif_ktree_fin {E}
  : forall a b, Iso (ktree E) (a := fin (Nat.add a b)) to_bif from_bif.
Proof.
  unfold to_bif, ToBifunctor_ktree_fin, from_bif, FromBifunctor_ktree_fin.
  constructor; intros x.
  - unfold cat, Cat_sub, Cat_Kleisli. cbn. rewrite bind_ret_l.
    apply eqit_Ret, merge_split.
  - unfold cat, Cat_sub, Cat_Kleisli. cbn. rewrite bind_ret_l.
    apply eqit_Ret, split_merge.
Qed.

Instance ToBifunctor_Fun_fin : ToBifunctor Fun fin sum Nat.add :=
  fun n m y => split_fin_sum n m y.

Instance FromBifunctor_Fun_fin : FromBifunctor Fun fin sum Nat.add :=
  fun n m y => merge_fin_sum n m y.

Instance IsoBif_Fun_fin
  : forall a b, Iso Fun (a := fin (Nat.add a b)) to_bif from_bif.
Proof.
  constructor; intros x.
  - apply merge_split.
  - apply split_merge.
Qed.

Instance InitialObject_ktree_fin {E} : InitialObject (sub (ktree E) fin) 0.
Proof.
  intros n f x; apply fin_0; auto.
Qed.


Require Import Basics.
Require Import Types.Universe.
Require Import Spaces.Pos.
Require Import Spaces.Int.Core.
Require Import Spaces.Int.Spec.
Require Import Spaces.Int.Equiv.

Local Open Scope positive_scope.
Local Open Scope int_scope.

(** ** Exponentiation of loops *)

Definition loopexp_pos {A : Type} {x : A} (p : x = x) (n : Pos) : (x = x).
Proof.
  revert n.
  srapply pos_peano_ind.
  + exact p.
  + intros n q.
    exact (q @ p).
Defined.

Definition loopexp {A : Type} {x : A} (p : x = x) (z : Int) : (x = x)
  := match z with
       | neg n => loopexp_pos p^ n
       | zero => 1
       | pos n => loopexp_pos p n
     end.

Lemma loopexp_pos_inv {A : Type} {x : A} (p : x = x) (n : Pos)
  : loopexp_pos p^ n = (loopexp_pos p n)^.
Proof.
  revert n.
  srapply pos_peano_ind; cbn; trivial.
  unfold loopexp_pos.
  intros n q.
  rewrite 2 pos_peano_ind_beta_pos_succ, q.
  refine ((inv_pp _ _)^ @ _).
  apply ap.
  clear q.
  revert n.
  srapply pos_peano_ind; cbn; trivial.
  intros n q.
  by rewrite pos_peano_ind_beta_pos_succ, concat_p_pp, q.
Qed.

Definition ap_loopexp_pos {A B} (f : A -> B) {x : A} (p : x = x) (n : Pos)
  : ap f (loopexp_pos p n) = loopexp_pos (ap f p) n.
Proof.
  revert n.
  srapply pos_peano_ind; cbn; trivial.
  unfold loopexp_pos.
  intros n q.
  rewrite 2 pos_peano_ind_beta_pos_succ.
  by rewrite ap_pp, q.
Qed.

Definition ap_loopexp {A B} (f : A -> B) {x : A} (p : x = x) (z : Int)
: ap f (loopexp p z) = loopexp (ap f p) z.
Proof.
  destruct z as [n| |n]; trivial.
  + cbn.
    rewrite loopexp_pos_inv, ap_V, loopexp_pos_inv.
    apply ap.
    apply ap_loopexp_pos.
  + apply ap_loopexp_pos.
Qed.

Lemma int_add_succ_l a b : int_succ a + b = int_succ (a + b).
Proof.
  rewrite <- int_add_assoc, (int_add_comm 1 b).
  apply int_add_assoc.
Qed.

Lemma int_add_succ_r a b : a + int_succ b = int_succ (a + b).
Proof.
  apply int_add_assoc.
Qed.

Lemma int_add_pred_l a b : int_pred a + b = int_pred (a + b).
Proof.
  rewrite <- int_add_assoc, (int_add_comm (-1) b).
  apply int_add_assoc.
Qed.

Lemma int_add_pred_r a b : a + int_pred b = int_pred (a + b).
Proof.
  apply int_add_assoc.
Qed.

Lemma loopexp_pos_concat {A : Type} {x : A} (p : x = x) (a : Pos)
  : loopexp_pos p a @ p = p @ loopexp_pos p a.
Proof.
  induction a as [|a aH] using pos_peano_ind; trivial.
  unfold loopexp_pos.
  rewrite pos_peano_ind_beta_pos_succ.
  change ((loopexp_pos p a @ p) @ p = p @ (loopexp_pos p a @ p)).
  by rewrite concat_p_pp, aH.
Qed.

Lemma loopexp_pos_add {A : Type} {x : A} (p : x = x) (a b : Pos)
  : loopexp_pos p (a + b)%pos = loopexp_pos p a @ loopexp_pos p b.
Proof.
  revert a b.
  induction a as [|a aH] using pos_peano_ind;
  induction b as [|b bH] using pos_peano_ind;
  trivial.
  + rewrite pos_add_1_l in *.
    unfold loopexp_pos.
    rewrite pos_peano_ind_beta_pos_succ.
    change (loopexp_pos p (pos_succ b) @ p
      = p @ loopexp_pos p (pos_succ b)).
    rewrite bH; cbn.
    by rewrite concat_pp_p, loopexp_pos_concat.
  + rewrite pos_add_1_r in *.
    unfold loopexp_pos.
    by rewrite pos_peano_ind_beta_pos_succ.
  + rewrite pos_add_succ_l.
    unfold loopexp_pos.
    rewrite 2 pos_peano_ind_beta_pos_succ.
    change (loopexp_pos p (a + pos_succ b)%pos @ p
      = (loopexp_pos p a @ p) @ loopexp_pos p (pos_succ b)).
    by rewrite aH, 2 concat_pp_p, loopexp_pos_concat.
Qed.

Lemma loopexp_int_pos_sub_l {A : Type} {x : A} (p : x = x) (a b : Pos)
  : loopexp p (int_pos_sub a b) = loopexp_pos p^ b @ loopexp_pos p a.
Proof.
  symmetry.
  revert a b.
  induction a as [|a aH] using pos_peano_ind;
  induction b as [|b bH] using pos_peano_ind.
  + apply concat_Vp.
  + cbn; rewrite int_pos_sub_succ_r.
    unfold loopexp_pos.
    rewrite pos_peano_ind_beta_pos_succ.
    by rewrite concat_pp_p, concat_Vp, concat_p1.
  + rewrite int_pos_sub_succ_l; cbn.
    unfold loopexp_pos.
    rewrite pos_peano_ind_beta_pos_succ.
    rewrite loopexp_pos_concat.
    by rewrite concat_p_pp, concat_Vp, concat_1p.
  + rewrite int_pos_sub_succ_succ.
    unfold loopexp_pos.
    rewrite 2 pos_peano_ind_beta_pos_succ.
    change ((loopexp_pos p^ b @ p^) @ (loopexp_pos p a @ p)
      = loopexp p (int_pos_sub a b)).
    rewrite (loopexp_pos_concat p).
    rewrite concat_pp_p, (concat_p_pp p^ p).
    rewrite concat_Vp, concat_1p.
    apply aH.
Qed.

Lemma loopexp_int_pos_sub_r {A : Type} {x : A} (p : x = x) (a b : Pos)
  : loopexp p (int_pos_sub a b) = loopexp_pos p a @ loopexp_pos p^ b.
Proof.
  symmetry.
  revert a b.
  induction a as [|a aH] using pos_peano_ind;
  induction b as [|b bH] using pos_peano_ind.
  + apply concat_pV.
  + cbn; rewrite int_pos_sub_succ_r.
    unfold loopexp_pos.
    rewrite pos_peano_ind_beta_pos_succ.
    change (p @ (loopexp_pos p^ b @ p^) = loopexp p (neg b)).
    rewrite loopexp_pos_concat.
    by rewrite concat_p_pp, concat_pV, concat_1p.
  + rewrite int_pos_sub_succ_l; cbn.
    unfold loopexp_pos.
    rewrite pos_peano_ind_beta_pos_succ.
    change ((loopexp_pos p a @ p) @ p^ = loopexp_pos p a).
    by rewrite concat_pp_p, concat_pV, concat_p1.
  + rewrite int_pos_sub_succ_succ.
    unfold loopexp_pos.
    rewrite 2 pos_peano_ind_beta_pos_succ.
    change ((loopexp_pos p a @ p) @ (loopexp_pos p^ b @ p^)
      = loopexp p (int_pos_sub a b)).
    rewrite (loopexp_pos_concat p^).
    rewrite concat_pp_p, (concat_p_pp p p^).
    rewrite concat_pV, concat_1p.
    apply aH.
Qed.

Lemma loopexp_add {A : Type} {x : A} (p : x = x) a b
  : loopexp p (a + b) = loopexp p a @ loopexp p b.
Proof.
  destruct a as [a| |a], b as [b| |b]; trivial;
  try apply loopexp_pos_add; cbn.
  1,6: symmetry; apply concat_p1.
  2,3: symmetry; apply concat_1p.
  1: apply loopexp_int_pos_sub_l.
  apply loopexp_int_pos_sub_r.
Qed.

(** Under univalence, exponentiation of loops corresponds to iteration of autoequivalences. *)

Definition equiv_path_loopexp `{Univalence}
           {A : Type} (p : A = A) (z : Int) (a : A)
  : equiv_path A A (loopexp p z) a = int_iter (equiv_path A A p) z a.
Proof.
  destruct z as [n| |n]; trivial.
  all: induction n as [|n IH]
    using pos_peano_ind; try reflexivity; cbn in *.
  all: unfold loopexp_pos; rewrite pos_peano_ind_beta_pos_succ.
  all: unfold pos_iter; rewrite pos_peano_ind_beta_pos_succ.
  all: refine (transport_pp _ _ _ _ @ _); cbn; apply ap, IH.
Defined.

Definition loopexp_path_universe `{Univalence}
           {A : Type} (f : A <~> A) (z : Int) (a : A)
  : transport idmap (loopexp (path_universe f) z) a
  = int_iter f z a.
Proof.
  revert f. equiv_intro (equiv_path A A) p.
  refine (_ @ equiv_path_loopexp p z a).
  refine (ap (fun q => equiv_path A A (loopexp q z) a) _).
  apply eissect.
Defined.


(** This file contains a proof the hacspec specification of the group addition over the bls12-381 curve
is equivalent to the MontgomeryCurveSpecs gallina specification of the same group addition. **)

Require Import Hacspec.Util.Lib.
Require Import Theory.WordByWordMontgomery.MontgomeryCurveSpecs.
Require Import Crypto.Curves.Weierstrass.Projective.
Require Import Bedrock.Field.bls12prime.
Require Import Coq.ZArith.ZArith.
Require Import bedrock2.Semantics.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Arithmetic.WordByWordMontgomery.
Require Import MontgomeryRingTheory.
Require Import Crypto.Arithmetic.UniformWeight.
Require Import Crypto.Util.Decidable Crypto.Algebra.Field.
Require Import Theory.Fields.FieldsUtil.
Require Import Hacspec.Curve.blsprime.
From Coqprime Require Import GZnZ.
Require Import Hacspec.Curve.Bls.
Require Import Hacspec.Curve.BlsProof.
Require Import Field.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.
Require Import Theory.WordByWordMontgomery.CurveSpecsEquivalence.
Require Import Crypto.Arithmetic.Partition.
Require Import Theory.Fields.QuadraticFieldExtensions.
Require Import Crypto.Algebra.Hierarchy.
Require Import Crypto.Spec.WeierstrassCurve.

Local Open Scope Z_scope.

(*Parameters to be changed: specify prime and import reification from cache.*)
Require Import Bedrock.Examples.felem_copy_64.
Local Definition felem_suffix := felem_copy_64.aff.
Local Notation m := bls12prime.m.

(*Initializing parameters; do not touch*)
Local Notation bw := width.
Local Notation m' := (@WordByWordMontgomery.m' m bw).
Notation n := (WordByWordMontgomery.n m (@width semantics)).
Local Notation eval := (@WordByWordMontgomery.WordByWordMontgomery.eval bw n).
Local Notation valid := (@WordByWordMontgomery.valid bw n m).
Local Notation from_mont := (@WordByWordMontgomery.from_montgomerymod bw n m m').
Local Notation thisword := (@word semantics).
Local Definition valid_words w := valid (List.map (@Interface.word.unsigned width thisword) w).
Local Definition map_words := List.map (@Interface.word.unsigned width thisword).
Local Notation r := (WordByWordMontgomery.r bw).
Local Notation r' := (WordByWordMontgomery.r' m bw).

(*Lemmas of correctness of parameters to be used for montgomery arithmetic.*)
Lemma r'_correct : (2 ^ bw * r') mod m = 1.
Proof. auto with zarith. Qed.

Lemma m'_correct : (m * m') mod 2 ^ bw = -1 mod 2 ^ bw.
Proof. auto with zarith. Qed.

Lemma bw_big : 0 < bw.
Proof. cbv; auto. Qed.

Lemma m_big : 1 < m.
Proof. cbv; auto. Qed.

Lemma n_nz : n <> 0%nat.
Proof. cbv; discriminate. Qed.

Lemma m_small : m < (2 ^ bw) ^ Z.of_nat n.
Proof. cbv; auto. Qed.

Lemma m_big' : 1 < m.
Proof. cbv; auto. Qed.

Lemma n_small : Z.of_nat n < 2 ^ bw.
Proof. cbv. auto. Qed.

Section G1Equiv.

    Local Notation a := (0 mod m).
    Local Notation b := (4 mod m).

    Local Notation three_b := (3 * b mod m).
    Local Notation uw := (uweight bw).
    Notation three_b_list := (MontgomeryCurveSpecs.three_b_list bw n three_b).

    Lemma a_small : a = a mod m.
    Proof. auto. Qed.

    Lemma b_small : b = b mod m.
    Proof. auto. Qed.

    Lemma three_b_small : three_b = three_b mod m.
    Proof. auto. Qed.

    (** G1 Equivalence section **)

    Local Notation BLS12_add_Gallina_spec :=
        (BLS12_add_Gallina_spec m bw n m' a three_b).

    Local Infix "*'" := (my_mul m) (at level 40).
    Local Infix "+'" := (my_add m) (at level 50).
    Local Infix "-'" := (my_sub m) (at level 50).

    Local Infix "*m" := (mul m) (at level 40).
    Local Infix "+m" := (add m) (at level 50).
    Local Infix "-m" := (sub m) (at level 50).

    Local Notation fp_a := (mkznz m a a_small).
    Local Notation fp_b := (mkznz m b b_small).
    Local Notation fc_field := (ZpZfc m blsprime).

    Lemma three_small : 3 < m.
    Proof. reflexivity. Qed.

    Local Notation char_ge_3 := (Char_geq_p m (N.succ_pos N.two) three_small).

    Local Notation fp_dec := (fp_dec m).

    Local Notation fp_3_b := (mkznz m three_b three_b_small).

    Lemma three_b_correct : three_b = b + b + b.
    Proof. auto. Qed.

    Lemma fp_3_b_correct : fp_3_b = fp_b +m fp_b +m fp_b.
    Proof. apply zirr; reflexivity. Qed.

    Lemma discriminant_nonzero: id(((mkznz m _ (modz m 4)) *m fp_a *m fp_a *m fp_a +m (mkznz m _ (modz m 27)) *m fp_b *m fp_b) <> (zero m)).
    Proof. unfold zero, add. cbn. congruence. Qed.

    Lemma twenty1_small : 21 < m.
    Proof. reflexivity. Qed.

    Local Notation char_ge_21 := (Char_geq_p m 21%positive twenty1_small).

    (* Notation for fiat-crypto specifications/lemmas *)
    Local Notation fc_proj_point := (@Projective.point (znz m) (@eq (znz m)) (zero m) (add m) (mul m) fp_a fp_b).
    Local Notation fc_proj_add := (@Projective.add (znz m) (@eq (znz m)) (zero m) (one m) (opp m) (add m) (sub m) (mul m) (inv m) (div m) fp_a fp_b fc_field char_ge_3 fp_dec fp_3_b fp_3_b_correct discriminant_nonzero char_ge_21).
    Local Notation fc_proj_eq := (@Projective.eq (znz m) (@eq (znz m)) (zero m) (add m) (mul m) fp_a fp_b fp_dec).

    Local Notation to_affine := (@Projective.to_affine (znz m) (@eq (znz m)) (zero m) (one m) (opp m) (add m) (sub m) (mul m) (inv m) (div m) fp_a fp_b fc_field fp_dec).
    Local Notation to_affine_add := (@Projective.to_affine_add (znz m) (@eq (znz m)) (zero m) (one m) (opp m) (add m) (sub m) (mul m) (inv m) (div m) fp_a fp_b fc_field char_ge_3 fp_dec fp_3_b fp_3_b_correct discriminant_nonzero char_ge_21).
    Local Notation not_exceptional := (@Projective.not_exceptional (znz m) (@eq (znz m)) (zero m) (one m) (opp m) (add m) (sub m) (mul m) (inv m) (div m) fp_a fp_b fc_field char_ge_3 fp_dec).

    Local Infix "?=?" := g1_eq (at level 70).
    Local Notation of_affine := (@Projective.of_affine (znz m) (@eq (znz m)) (zero m) (one m) (opp m) (add m) (sub m) (mul m) (inv m) (div m) fp_a fp_b fc_field fp_dec ).
    Local Notation fc_eq_iff_Weq := (@Projective.eq_iff_Weq (znz m) (@eq (znz m)) (zero m) (one m) (opp m) (add m) (sub m) (mul m) (inv m) (div m) fp_a fp_b fc_field fp_dec).

    Local Notation fc_aff_point := (@WeierstrassCurve.W.point (znz m) (@eq (znz m)) (add m) (mul m) fp_a fp_b).
    Local Notation fc_aff_eq := (@WeierstrassCurve.W.eq (znz m) (@eq (znz m)) (add m) (mul m) fp_a fp_b).
    Local Notation fc_aff_add := (@WeierstrassCurve.W.add (znz m) (@eq (znz m)) (zero m) (one m) (opp m) (add m) (sub m) (mul m) (inv m) (div m) fc_field fp_dec char_ge_3 fp_a fp_b).

    Local Notation to_fc_point_from_mont := (to_fc_point_from_mont m bw n m' a b three_b a_small b_small three_b_small three_b_correct).

    Definition BLS_gallina_fiat_crypto_equiv' := (gallina_fiat_crypto_equiv' m bw n m' a b three_b a_small b_small three_b_small three_b_correct bw_big n_nz m_small m_big twenty1_small blsprime discriminant_nonzero).
    Local Notation gallina_spec_from_fc_point := (gallina_spec_from_fc_point m bw n m' a b three_b a_small b_small).

    Definition BLS_gallina_fiat_crypto_equiv'' :=
        (gallina_fiat_crypto_equiv'' m bw n r' m' a b three_b a_small b_small three_b_small three_b_correct r'_correct m'_correct bw_big n_nz m_small m_big twenty1_small blsprime discriminant_nonzero).

    Definition to_hacspec_point (X1 Y1 Z1 : list Z) on_curve : g1 := g1_from_fc (to_affine (to_fc_point_from_mont X1 Y1 Z1 on_curve)).

    Add Field hs_fp_field: fp_field_theory.

    Lemma preserves_on_curve : forall p, g1_on_curve (g1_from_fc p).
    Proof. intros [[[] | []]]; cbn; auto.  rewrite y. field.
    Qed.

    Lemma g1_fc_eq: forall x y :fc_aff_point, g1_from_fc x ?=? g1_from_fc y <-> fc_aff_eq x y.
    Proof.
        intros [[[] | []]] [[[] | []]]; unfold "?=?", fc_aff_eq; cbn; easy.
    Qed.

    Lemma same_field_opp : forall x, Lib.nat_mod_neg x = opp m x.
    Proof. intros. reflexivity. Qed.

    Lemma dec_same: forall X x y (a b: X), (if (g1_dec x y) then a else b) = if (fp_dec x y) then a else b.
    Proof. intros. destruct (g1_dec x y); destruct (fp_dec x y); try reflexivity; try contradiction.
    Qed.

    Lemma same_fc_add: forall x y, fc_aff_eq (g1_fc_add x y) (fc_aff_add x y).
    Proof. intros [[[] | []]] [[[] | []]]; unfold g1_fc_add; unfold fc_aff_add; unfold fc_aff_eq; cbn; auto.
    unfold dec. do 2 rewrite dec_same. rewrite same_field_opp. destruct (fp_dec n n1); destruct (fp_dec n2 (opp m n0));
        try trivial; split; reflexivity.
    Qed.

    Lemma fc_aff_eq_refl: forall x, fc_aff_eq x x.
    Proof. intros [[[]| []]]; cbn; auto.
    Qed.

    Lemma fc_aff_eq_symm: forall x y, fc_aff_eq x y -> fc_aff_eq y x.
    Proof. intros [[[] | []]] [[[] | []]]; unfold fc_aff_eq; cbn; intros []; auto.
    Qed.

    Lemma fc_aff_eq_trans: forall x y z, fc_aff_eq x y -> fc_aff_eq y z -> fc_aff_eq x z.
    Proof.  intros [[[] | []]] [[[] | []]] [[[] | []]]; unfold fc_aff_eq; cbn; intros [] []; subst; auto.
    Qed.

    Add Relation fc_aff_point fc_aff_eq
        reflexivity proved by fc_aff_eq_refl
        symmetry proved by fc_aff_eq_symm
        transitivity proved by fc_aff_eq_trans
        as fc_aff_rel.

    Lemma fc_aff_eq_sig: forall x y, proj1_sig x = proj1_sig y -> fc_aff_eq x y.
    Proof. intros [[[] | []]] [[[] | []]]; cbn; intros H; inversion H; auto.
    Qed.

    Lemma fc_aff_add_compat: forall x y, fc_aff_eq (fc_aff_add x y) (fc_aff_add (g1_to_fc (g1_from_fc x) (preserves_on_curve _)) (g1_to_fc (g1_from_fc y) (preserves_on_curve _))).
    Proof. intros [[[] | []]] [[[] | []]]; apply fc_aff_eq_sig; cbn; reflexivity.
    Qed.

    (* Gallina to hacspec equivalence *)
    Theorem gallina_hacspec_equiv : forall X1 Y1 Z1 X2 Y2 Z2 outx outy outz on_curve1 on_curve2 on_curve_out (except: not_exceptional (to_fc_point_from_mont _ _ _ on_curve1) (to_fc_point_from_mont _ _ _ on_curve2)),
        (BLS12_add_Gallina_spec X1 Y1 Z1 X2 Y2 Z2 outx outy outz ->
        (to_hacspec_point outx outy outz on_curve_out ?=? g1add (to_hacspec_point X1 Y1 Z1 on_curve1) (to_hacspec_point X2 Y2 Z2 on_curve2))).
    Proof. intros. apply (BLS_gallina_fiat_crypto_equiv' _ _ _ _ _ _ _ _ _ on_curve1 on_curve2 on_curve_out except) in H.
        unfold to_hacspec_point. unshelve rewrite g1_addition_equal; try apply preserves_on_curve.
        apply g1_fc_eq. rewrite same_fc_add. rewrite <- fc_aff_add_compat. rewrite <- (to_affine_add _ _ except).
        apply fc_eq_iff_Weq. apply H.
    Qed.

    (* Hacspec to gallina equivalence *)
    Theorem gallina_hacspec_equiv' : forall p1 p2 pout (except : not_exceptional p1 p2),
        g1_from_fc (to_affine pout) ?=? g1add (g1_from_fc (to_affine p1)) (g1_from_fc (to_affine p2)) ->
        exists pout', fc_proj_eq pout pout' /\ gallina_spec_from_fc_point p1 p2 pout'.
    Proof.
        intros. assert (fc_proj_eq pout (fc_proj_add p1 p2 except)).
        { apply fc_eq_iff_Weq. rewrite (to_affine_add). apply g1_fc_eq. rewrite H.
        rewrite (g1_addition_equal _ _ (preserves_on_curve _) (preserves_on_curve _)). apply g1_fc_eq. rewrite same_fc_add. rewrite <- fc_aff_add_compat. reflexivity. }
        apply (BLS_gallina_fiat_crypto_equiv'' _ _ _ except) in H0. apply H0.
    Qed.

End G1Equiv.

Section G2Equiv.
    (** G2 Equivalence section **)

    Local Open Scope Z_scope.

    (* Some notation and definitions*)
    Local Notation ar := (0 mod m).
    Local Notation ai := (0 mod m).
    Local Notation br := (4 mod m).
    Local Notation bi := (4 mod m).

    (*Initializing parameters; do not touch*)
    Local Notation three_br := (3 * br mod m).
    Local Notation three_bi := (3 * bi mod m).
    Local Notation uw := (uweight 64).
    Definition three_br_list := (Partition.partition uw 6 (three_br)).
    Definition three_bi_list := (Partition.partition uw 6 three_bi).

    Lemma ar_small : ar = ar mod m.
    Proof. auto. Qed.

    Lemma ai_small : ai = ai mod m.
    Proof. auto. Qed.

    Lemma br_small : br = br mod m.
    Proof. auto. Qed.

    Lemma bi_small : bi = bi mod m.
    Proof. auto. Qed.

    Lemma three_br_small : three_br = three_br mod m.
    Proof. auto. Qed.

    Lemma three_bi_small : three_bi = three_bi mod m.
    Proof. auto. Qed.

    Lemma three_br_correct : three_br = br + br + br.
    Proof. auto. Qed.

    Lemma three_bi_correct : three_bi = bi + bi + bi.
    Proof. auto. Qed.

    (* Some Notation *)
    Local Notation BLS12_G2_add_Gallina_spec :=
        (@BLS12_G2_add_Gallina_spec m bw n m' 0 0 three_br three_bi).

    Local Infix "*m" := (mul m) (at level 40).
    Local Infix "+m" := (add m) (at level 50).
    Local Infix "-m" := (sub m) (at level 50).

    Local Infix "*m2" := (mulp2 m) (at level 40).
    Local Infix "+m2" := (addp2 m) (at level 50).
    Local Infix "-m2" := (subp2 m) (at level 50).

    Local Notation Fp2 := (znz m * znz m)%type.
    Local Notation fp2_a := (mkznz m ar ar_small, mkznz m ai ai_small).
    Local Notation fp2_b := (mkznz m br br_small, mkznz m bi bi_small).
    Local Notation fp2_3_b := (mkznz m three_br three_br_small, mkznz m three_bi three_bi_small).

    Lemma m_odd: 2 < m.
    Proof. reflexivity. Qed.

    Lemma m_mod3: m mod 4 =? 3 = true.
    Proof. reflexivity. Qed.

    Lemma m_mod: m mod 4 = 3.
    Proof. auto. Qed.

    Local Notation FFp2 := ((@FFp2 m) blsprime m_odd m_mod3).

    Local Notation fc_p2_field := (Fp2fc m blsprime m_odd m_mod3).
    Local Notation fp2_char_ge_3 := (Char_Fp2_geq_p m blsprime 3 three_small).
    Local Notation fp2_char_ge_21 := (Char_Fp2_geq_p m blsprime 21 twenty1_small).

    Local Notation fc_fp2_dec := (fc_fp2_dec m).

    Lemma mul_zero_r: forall x, mul m x (zero m) = zero m.
    Proof. intros []. unfold mul. cbn. rewrite Z.mul_0_r. reflexivity.
    Qed.

    Lemma fp2_discriminant_nonzero: id(((mkznz m _ (modz m 4), zero m) *m2 fp2_a *m2 fp2_a *m2 fp2_a +m2 (mkznz m _ (modz m 27), zero m) *m2 fp2_b *m2 fp2_b) <> (zerop2 m)).
    Proof.  unfold id, zerop2, addp2, mulp2, fst, snd.
        intros c. apply pair_equal_spec in c. destruct c.  repeat rewrite mul_zero_r in H0. discriminate H0.
    Qed.

    Local Notation fp2_3_b_correct := (fp2_3_b_correct m br bi three_br three_bi br_small bi_small three_br_small three_bi_small three_br_correct three_bi_correct).

    Local Notation fc_proj_p2_point := (@Projective.point Fp2 eq (zerop2 m) (addp2 m) (mulp2 m) fp2_a fp2_b).
    Local Notation fc_proj_p2_add :=  (@Projective.add Fp2 eq (zerop2 m) (onep2 m) (oppp2 m) (addp2 m) (subp2 m) (mulp2 m) (invp2 m) (divp2 m) fp2_a fp2_b fc_p2_field fp2_char_ge_3 fc_fp2_dec fp2_3_b fp2_3_b_correct fp2_discriminant_nonzero fp2_char_ge_21).
    Local Notation fc_proj_p2_eq := (@Projective.eq Fp2 eq (zerop2 m) (addp2 m) (mulp2 m) fp2_a fp2_b fc_fp2_dec).

    (* Proof of equivalence between gallina and fiat*)
    Definition BLS_gallina_fiat_crypto_p2_equiv' :=  (gallina_fiat_crypto_p2_equiv' m bw n m' ar ai br bi three_br three_bi ar_small ai_small br_small bi_small three_br_small three_br_small three_br_correct three_bi_correct
        bw_big n_nz m_small m_big m_mod blsprime m_odd twenty1_small fp2_discriminant_nonzero).

    Definition BLS_gallina_fiat_crypto_p2_equiv'' := (gallina_fiat_crypto_p2_equiv'' m bw n r' m' ar ai br bi three_br three_bi ar_small ai_small br_small bi_small three_br_small three_br_small three_br_correct three_bi_correct
        r'_correct m'_correct bw_big n_nz m_small m_big m_mod blsprime m_odd twenty1_small fp2_discriminant_nonzero).

    (* Some more notation *)
    Local Notation to_affine_p2 := (@Projective.to_affine (Fp2) (@eq Fp2) (zerop2 m) (onep2 m) (oppp2 m) (addp2 m) (subp2 m) (mulp2 m) (invp2 m) (divp2 m) fp2_a fp2_b fc_p2_field fc_fp2_dec).
    Local Notation to_affine_p2' := (@Projective.to_affine (fp2) (@eq fp2) (fp2zero) (fp2one) (fp2neg) (fp2add) (fp2sub) (fp2mul) (fp2inv) (fp2div) fp2zero g2_b fc_p2_field g2_dec).

    Local Notation g2_fc_point := (@W.point fp2 eq fp2add fp2mul fp2zero g2_b).

    Local Notation fc_aff_p2_point := (@WeierstrassCurve.W.point (Fp2) (@eq (Fp2)) (addp2 m) (mulp2 m) fp2_a fp2_b).
    Local Notation fc_aff_p2_eq := (@WeierstrassCurve.W.eq (Fp2) (@eq (Fp2)) (addp2 m) (mulp2 m) fp2_a fp2_b).
    Local Notation fc_aff_p2_add := (@WeierstrassCurve.W.add (Fp2) (@eq (Fp2)) (zerop2 m) (onep2 m) (oppp2 m) (addp2 m) (subp2 m) (mulp2 m) (invp2 m) (divp2 m) fc_p2_field fc_fp2_dec fp2_char_ge_3 fp2_a fp2_b).

    Local Notation to_affine_p2_add := (@Projective.to_affine_add (Fp2) (@eq Fp2) (zerop2 m) (onep2 m) (oppp2 m) (addp2 m) (subp2 m) (mulp2 m) (invp2 m) (divp2 m) fp2_a fp2_b fc_p2_field fp2_char_ge_3 fc_fp2_dec fp2_3_b fp2_3_b_correct fp2_discriminant_nonzero fp2_char_ge_21).

    Local Notation fc_p2_eq_iff_Weq := (@Projective.eq_iff_Weq (Fp2) (@eq Fp2) (zerop2 m) (onep2 m) (oppp2 m) (addp2 m) (subp2 m) (mulp2 m) (invp2 m) (divp2 m) fp2_a fp2_b fc_p2_field fc_fp2_dec).

    Local Notation to_fc_p2_point_from_mont := (to_fc_p2_point_from_mont m bw n m' ar ai br bi three_br three_bi ar_small ai_small br_small bi_small
        three_br_small three_bi_small three_br_correct three_bi_correct).

    Local Notation fc_field := (FZpZ m blsprime).
    Add Field FZpZ2 : fc_field.

    Local Infix "?=2?" := g2_eq (at level 70).

    Local Notation not_exceptional := (@Projective.not_exceptional (Fp2) (@eq (Fp2)) (zerop2 m) (onep2 m) (oppp2 m) (addp2 m) (subp2 m) (mulp2 m) (invp2 m) (divp2 m) fp2_a fp2_b fc_p2_field fp2_char_ge_3 fc_fp2_dec).
    Local Notation gallina_G2_spec_from_fc_point := (@gallina_G2_spec_from_fc_point m bw n m' ar ai br bi three_br three_bi ar_small ai_small br_small bi_small).

    (* Proofs that the extension fields are equivalent*)
    Lemma Quad_neg_one : Quad_non_res m = opp m (one m).
    Proof. reflexivity. Qed.

    Lemma same_p2_mul : forall x y, x *%2 y = x *m2 y.
    Proof. intros [] []. unfold "*%2", "*m2", "*%", "-%", "+%". rewrite Quad_neg_one. cbn.
        apply pair_equal_spec. split; auto. field_simplify (f *m f1 +m (opp m (one m) *m f0) *m f2). reflexivity.
    Qed.

    Lemma same_p2_add : forall x y, x +%2 y = x +m2 y.
    Proof. intros [] []. auto. Qed.

    Lemma same_p2_dec : forall A x y (a b: A), (if g2_dec x y then a else b) = (if fc_fp2_dec x y then a else b).
    Proof. intros. destruct (g2_dec x y), (fc_fp2_dec x y); easy. Qed.

    Lemma same_field_add: forall x y, x +% y  = x +m y.
    Proof. intros. reflexivity. Qed.

    Lemma same_field_sub: forall x y, x -% y  = x -m y.
    Proof. intros. reflexivity. Qed.

    Lemma same_field_mul: forall x y, @nat_mod_mul 4002409555221667393417789825735904156556882819939007885332058136124031650490837864442687629129015664037894272559787 x y  = x *m y.
    Proof. intros. reflexivity. Qed.

    Lemma same_field_inv: forall x, nat_mod_inv x = inv m x.
    Proof. intros. reflexivity. Qed.

    Lemma same_field_zero: @nat_mod_zero 4002409555221667393417789825735904156556882819939007885332058136124031650490837864442687629129015664037894272559787 = zero m.
    Proof. reflexivity. Qed.

    Lemma neg_one : mkznz _ 4002409555221667393417789825735904156556882819939007885332058136124031650490837864442687629129015664037894272559786
        (modz 4002409555221667393417789825735904156556882819939007885332058136124031650490837864442687629129015664037894272559787 (-1))
        = opp m (one m).
    Proof. reflexivity. Qed.

    Hint Rewrite same_field_add same_field_sub same_field_mul same_field_inv same_field_opp same_field_zero : fp_field_same.

    Add Field fp_field: (FZpZ m blsprime).

    (* Inverse is the main different field extension function *)
    Lemma same_p2_inv : forall x, fp2inv x = invp2 m x.
    Proof. intros []. unfold fp2inv, invp2, fst, snd. rewrite Quad_neg_one. autorewrite with fp_field_same.
    rewrite (same_field_mul f f), (same_field_mul f0 f0), (same_field_mul f0 (inv m _)).
    destruct (val m f =? 0) eqn:E.
        - apply Z.eqb_eq in E. apply (Zerop_iff _ m_odd) in E. rewrite E.
            apply pair_equal_spec; split.
            + reflexivity.
            + destruct (val m f0 =? 0) eqn:E0.
                * apply Z.eqb_eq in E0. apply (Zerop_iff _ m_odd) in E0. rewrite E0. reflexivity.
                * apply Z.eqb_neq in E0. field. split; intros c; try discriminate. apply (Zerop_iff _ m_odd) in c. contradiction.
        - apply Z.eqb_neq in E.
        apply pair_equal_spec; split; field; split; try (intros c; apply (Zerop_iff _ m_odd) in c; contradiction);
            rewrite neg_one; intros c; assert (f *m f +m f0 *m f0 = zero m) by (rewrite <- c; field);
              apply helper1 in H as []; apply (Zerop_iff _ m_odd) in H; contradiction.
    Qed.

    Lemma same_p2_div : forall x y, fp2div x y = divp2 m x y.
    Proof. intros. unfold fp2div, divp2. rewrite same_p2_mul, same_p2_inv. reflexivity.
    Qed.

    Lemma same_p2_opp : forall x, fp2neg x = oppp2 m x.
    Proof. intros []. reflexivity. Qed.

    Lemma same_p2_sub : forall x y, fp2sub x y = subp2 m x y.
    Proof. intros [] []. unfold "-%2", "-m2". rewrite same_p2_opp. cbn.
    apply pair_equal_spec; split; rewrite same_field_add; field. Qed.

    Lemma same_p2_zero : fp2zero = zerop2 m.
    Proof. auto. Qed.

    Lemma same_p2_one : fp2one = onep2 m.
    Proof. auto. Qed.

    Lemma fp2_a_is_zero : ({| val := 0; inZnZ := ar_small |}, {| val := 0; inZnZ := ai_small |}) = zerop2 m.
    Proof. apply pair_equal_spec; split; apply zirr; reflexivity. Qed.

    Hint Rewrite same_p2_mul same_p2_add same_p2_div same_p2_dec same_p2_zero same_p2_one same_p2_opp same_p2_sub : same_p2.

    (* Translation from fiat-crypto points over QuadraticFieldExtensions fp2 to fiat-crypto points over hacspec fp2. Neccesary since the extension fields have been defined differently. *)
    Program Definition to_hacspec_aff_p2 (x : fc_aff_p2_point) : g2_fc_point :=
    match W.coordinates x return Fp2 * Fp2 + unit with
        | inr tt => inr tt
        | inl (x, y) => inl (x, y)
    end.
    Opaque fp2mul.
    Next Obligation.
    destruct x as [[[]|[]]]; cbn; auto. repeat rewrite same_p2_add. repeat rewrite same_p2_mul. apply y.
    Transparent fp2mul.
    Qed.

    (* Translation from Bedrock G2 point to hacspec G2 point through fiat-crypto*)
    Definition to_hacspec_p2_point (X1 Y1 Z1 : (list Z * list Z)) on_curve := g2_from_fc (to_hacspec_aff_p2 (to_affine_p2 (to_fc_p2_point_from_mont X1 Y1 Z1 on_curve))).

    (* Some helper lemmas to go from g2 points to fiat-crypto points over QuadraticFieldExtensions fp2 *)
    Lemma g2_fc_eq: forall x y , g2_from_fc (to_hacspec_aff_p2 x) ?=2? g2_from_fc (to_hacspec_aff_p2 y) <-> fc_aff_p2_eq x y.
    Proof.
        intros [[[] | []]] [[[] | []]]; unfold "?=2?", to_hacspec_aff_p2, fc_aff_p2_eq; cbn; split; auto.
        - intros [_ [-> ->]]; auto.
        - intros []; discriminate.
        - intros [].
        - intros; discriminate.
    Qed.

    Lemma g2_preserves_on_curve : forall p, g2_on_curve (g2_from_fc p).
    Proof. intros [[[] | []]]; cbn; auto.  rewrite y. field. Qed.

    Lemma g2_addition_equal' : forall p q, (g2add (g2_from_fc (to_hacspec_aff_p2 p)) (g2_from_fc (to_hacspec_aff_p2 q))) ?=2? (g2_from_fc (to_hacspec_aff_p2 (fc_aff_p2_add p q))).
    Proof. intros [[[] | []]] [[[] | []]]; [| cbn; auto | cbn; auto | cbn; auto].
     unshelve rewrite g2_addition_equal; try apply g2_preserves_on_curve.
     Opaque fp2add.
     cbn. unfold to_hacspec_aff_p2, g2_from_fc, g2_to_fc. cbn. unfold dec, to_hacspec_aff_p2.
      autorewrite with same_p2. rewrite fp2_a_is_zero.
      destruct (fc_fp2_dec p p1), (fc_fp2_dec p2 (oppp2 m p0)); reflexivity.
    Qed.

    Lemma fc_aff_p2_eq_refl: forall x, fc_aff_p2_eq x x.
    Proof. intros [[[]| []]]; cbn; auto.
    Qed.

    Lemma fc_aff_p2_eq_symm: forall x y, fc_aff_p2_eq x y -> fc_aff_p2_eq y x.
    Proof. intros [[[] | []]] [[[] | []]]; unfold fc_aff_p2_eq; cbn; intros []; auto.
    Qed.

    Lemma fc_aff_p2_eq_trans: forall x y z, fc_aff_p2_eq x y -> fc_aff_p2_eq y z -> fc_aff_p2_eq x z.
    Proof.  intros [[[] | []]] [[[] | []]] [[[] | []]]; unfold fc_aff_p2_eq; cbn; intros [] []; subst; auto.
    Qed.

    Add Relation fc_aff_p2_point fc_aff_p2_eq
        reflexivity proved by fc_aff_p2_eq_refl
        symmetry proved by fc_aff_p2_eq_symm
        transitivity proved by fc_aff_p2_eq_trans
        as fc_aff_p2_rel.

    (* Gallina to hacspec equivalence *)
    Theorem gallina_hacspec_p2_equiv : forall X1 Y1 Z1 X2 Y2 Z2 outx outy outz on_curve1 on_curve2 on_curve_out (except: not_exceptional (to_fc_p2_point_from_mont _ _ _ on_curve1) (to_fc_p2_point_from_mont _ _ _ on_curve2)),
        (BLS12_G2_add_Gallina_spec X1 Y1 Z1 X2 Y2 Z2 outx outy outz ->
        (to_hacspec_p2_point outx outy outz on_curve_out ?=2? g2add (to_hacspec_p2_point X1 Y1 Z1 on_curve1) (to_hacspec_p2_point X2 Y2 Z2 on_curve2))).
    Proof. intros. apply (BLS_gallina_fiat_crypto_p2_equiv' _ _ _ _ _ _ _ _ _ on_curve1 on_curve2 on_curve_out except) in H.
        unfold to_hacspec_p2_point. rewrite (g2_addition_equal').
        apply g2_fc_eq.  rewrite <- (to_affine_p2_add _ _ except).
        apply fc_p2_eq_iff_Weq. apply H.
    Qed.

    (* Hacspec to gallina equivalence *)
    Theorem gallina_hacspec_p2_equiv' : forall p1 p2 pout (except : not_exceptional p1 p2),
        g2_from_fc (to_hacspec_aff_p2 (to_affine_p2 pout)) ?=2? g2add (g2_from_fc (to_hacspec_aff_p2 (to_affine_p2 p1))) (g2_from_fc (to_hacspec_aff_p2 (to_affine_p2 p2))) ->
        exists pout', fc_proj_p2_eq pout pout' /\ gallina_G2_spec_from_fc_point p1 p2 pout'.
    Proof.
        intros. assert (fc_proj_p2_eq pout (fc_proj_p2_add p1 p2 except)).
        { apply fc_p2_eq_iff_Weq. rewrite (to_affine_p2_add). apply g2_fc_eq. rewrite H.
        rewrite g2_addition_equal'. reflexivity. }
        apply (BLS_gallina_fiat_crypto_p2_equiv'' _ _ _ except) in H0. apply H0.
    Qed.

End G2Equiv.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export logic.
Definition lemma__parallelsymmetric : forall A B C D, (euclidean__defs.Par A B C D) -> (euclidean__defs.Par C D A B).
Proof.
intro A.
intro B.
intro C.
intro D.
intro H.
assert (exists a b c d m, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B a) /\ ((euclidean__axioms.Col A B b) /\ ((euclidean__axioms.neq a b) /\ ((euclidean__axioms.Col C D c) /\ ((euclidean__axioms.Col C D d) /\ ((euclidean__axioms.neq c d) /\ ((~(euclidean__defs.Meet A B C D)) /\ ((euclidean__axioms.BetS a m d) /\ (euclidean__axioms.BetS c m b))))))))))) as H0 by exact H.
destruct H0 as [a H1].
destruct H1 as [b H2].
destruct H2 as [c H3].
destruct H3 as [d H4].
destruct H4 as [m H5].
destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
assert (* Cut *) (~(euclidean__defs.Meet C D A B)) as H26.
- intro H26.
assert (exists P, (euclidean__axioms.neq C D) /\ ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.Col C D P) /\ (euclidean__axioms.Col A B P)))) as H27 by exact H26.
destruct H27 as [P H28].
destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
assert (* Cut *) (euclidean__defs.Meet A B C D) as H35.
-- exists P.
split.
--- exact H31.
--- split.
---- exact H29.
---- split.
----- exact H34.
----- exact H33.
-- apply (@H22 H35).
- assert (* Cut *) (euclidean__defs.Par C D A B) as H27.
-- exists c.
exists d.
exists a.
exists b.
exists m.
split.
--- exact H8.
--- split.
---- exact H6.
---- split.
----- exact H16.
----- split.
------ exact H18.
------ split.
------- exact H20.
------- split.
-------- exact H10.
-------- split.
--------- exact H12.
--------- split.
---------- exact H14.
---------- split.
----------- exact H26.
----------- split.
------------ exact H25.
------------ exact H24.
-- exact H27.
Qed.