Require Import Coq.omega.Omega.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.Morphisms.
Require Import logic.
Require Import natural.
Require Import integer.
Require Import Z_nonzero.
Require Import rational.

Delimit Scope real_scope with real.
Open Scope real_scope.

Notation "'SQ0'" := (fun n => Q0).
Notation "'SQ1'" := (fun n => Q1).

Definition Cauchy (a: nat -> rational): Prop :=
forall (epsilon: rational), epsilon >Q Q0 ->
  exists (N: nat), forall (n m: nat), n > N -> m > N -> Q_abs (a n -Q a m) <Q epsilon.

Definition real: Type := {r: nat -> rational | Cauchy r}.

Definition Bounded (a: nat -> rational): Prop :=
  exists (M: rational), M >Q Q0 /\ forall (n: nat), Q_abs (a n) <=Q M.

Theorem R_Cauchy__Bounded: forall a: nat -> rational, Cauchy a -> Bounded a.
Proof. intros a ca. unfold Cauchy in ca. unfold Bounded.
  destruct (ca Q1) as [N]. easy.
  exists (Q_max (Q_seq_max (fun n => Q_abs (a n)) N) (Q_abs (a (S N)) +Q Q1)).
  assert (forall p q: rational, Q_max p q >=Q q).
    intros. unfold Q_max. remember (Q_leb p q) as b; destruct b; symmetry in Heqb.
    easy. rewrite Q_leb_false__gt in Heqb. now apply Q_gt_ge_subrel.
  assert (forall p q: rational, Q_max p q >=Q p).
    intros. unfold Q_max. remember (Q_leb p q) as b; destruct b; symmetry in Heqb.
    rewrite Q_leb_true__le in Heqb. easy. easy.
  split. assert (Q1 >Q Q0) by easy.
  assert (forall p q r: rational, p >=Q q -> q >Q r -> p >Q r).
    intros. now rewrite <- H3.
  apply (H3 _ (Q_abs (a (S N)) +Q Q1)). apply H0.
  assert (Q_abs (a (S N)) >=Q Q0). rewrite <- Q_abs__nonneg. easy.
  rewrite <- H4. easy.
  intros. pose proof (N_trichotomy n N). destruct H2.
    rewrite <- H1. remember (fun n0 : nat => Q_abs (a n0)) as b.
    assert (Q_abs (a n) =Q= b n). rewrite Heqb. reflexivity. rewrite H3.
    apply Q_seq_max_ge. omega.
  destruct H2.
    rewrite <- H1. remember (fun n0 : nat => Q_abs (a n0)) as b.
    assert (Q_abs (a n) =Q= b n). rewrite Heqb. reflexivity. rewrite H3.
    apply Q_seq_max_ge. omega.

  rewrite <- H0.
  assert ((a n -Q a (S N)) +Q (a (S N)) =Q= a n).
    unfold Q_minus. rewrite Q_1. rewrite (Q_2 _ (a (S N))).
    assert (a (S N) -Q a (S N) =Q= Q0) by apply Q_4. unfold Q_minus in H3.
    rewrite H3. apply Q_3.
  rewrite <- H3. rewrite Q_triangle_ineq.
  rewrite Q_2.
  assert (Q_abs (a n -Q a (S N)) <Q Q1).
    apply H. apply H2. omega.
  assert (forall x y z: rational, y >Q z -> x +Q y >Q x +Q z).
    intros. repeat rewrite (Q_2 x). apply Q_12. apply H5.
  apply Q_gt_ge_subrel. apply H5. apply H. apply H2. omega.
Defined.

Definition R_eq_0 (a: nat -> rational): Prop :=
forall (epsilon: rational), epsilon >Q Q0 ->
  exists (N: nat), forall (n: nat), n > N -> Q_abs (a n) <Q epsilon.

Definition R_eq_0_real (a: real): Prop :=
forall (epsilon: rational), epsilon >Q Q0 ->
  exists (N: nat), forall (n: nat), n > N -> Q_abs (proj1_sig a n) <Q epsilon.

Lemma R_cons: forall a b: real, Cauchy (fun n => (proj1_sig a n -Q proj1_sig b n)).
  intros. destruct a as [a ca], b as [b cb]. unfold Cauchy. simpl.
  unfold Cauchy in ca, cb.
  intros epsilon Heps.
  pose proof (Q_cons_pos_div_QN2 epsilon Heps) as Heps2.
  pose proof (ca (epsilon /Q QN2) Heps2) as Ha; destruct Ha as [Na].
  pose proof (cb (epsilon /Q QN2) Heps2) as Hb; destruct Hb as [Nb].
  exists (max Na Nb). intros n m Hn' Hm'.
  pose proof (N_gt_max _ _ _ Hn') as Hn; destruct Hn as [Hna Hnb].
  pose proof (N_gt_max _ _ _ Hm') as Hm; destruct Hm as [Hma Hmb].
  clear Hn' Hm' Heps Heps2 ca cb.
  assert (Q_abs (a n -Q a m) +Q Q_abs (b n -Q b m) <Q epsilon).
    rewrite <- (Q_double_half epsilon).
    apply (Q_cons_lt_plus _ _ _ _ (H n m Hna Hma) (H0 n m Hnb Hmb)).
  assert (Q_abs (a n -Q b n -Q (a m -Q b m)) <=Q Q_abs (a n -Q a m) +Q Q_abs (b n -Q b m)).
    assert (a n -Q b n -Q (a m -Q b m) =Q= (a n -Q a m) -Q (b n -Q b m)).
      unfold Q_minus. rewrite Q_mult_neg_distr.
      assert (forall q: rational, -Q -Q q =Q= q). destruct q as [[q1 q2] [[q3 q4] q5]]; simpl.
        repeat rewrite (mult_comm q3), (mult_comm q4). omega.
      unfold Q_minus. rewrite H2. repeat rewrite <- Q_1.
      rewrite (Q_1 (a n)). rewrite (Q_2 (-Q b n)). rewrite Q_mult_neg_distr.
      unfold Q_minus. rewrite H2. repeat rewrite Q_1. reflexivity.
    rewrite H2. unfold Q_minus. rewrite <- (Q_cons_abs_neg (b n +Q -Q b m)).
    rewrite Q_triangle_ineq. easy.
  rewrite H2. apply H1.
Defined.

Definition R_eq (a b: real): Prop := R_eq_0 (fun n => (proj1_sig a n -Q proj1_sig b n)).

Notation "p =R= q" := (R_eq p q) (at level 70): type_scope.
Notation "p <R> q" := (~ p =R= q) (at level 70): type_scope.

Theorem R_refl: Reflexive R_eq.
Proof.
  (* reflexivity *) unfold Reflexive. intros.
  unfold R_eq, R_eq_0.
  intros. exists 0%nat. intros.
  assert (Q_abs (proj1_sig x n -Q proj1_sig x n) =Q= Q0). rewrite Q_4. reflexivity.
  rewrite H1. apply H.
Defined.

Theorem R_symm: Symmetric R_eq.
Proof.
  (* symmetricity *) unfold Symmetric.
  unfold R_eq, R_eq_0.
  intros. destruct x as [x Hx], y as [y Hy]; simpl. simpl in H.
  assert (forall n: nat, Q_abs (x n -Q y n) =Q= Q_abs (y n -Q x n)).
    intros.
    assert (x n -Q y n =Q= -Q (y n -Q x n)).
      rewrite <- Q_7_2. unfold Q_minus. rewrite Q_9_0.
      rewrite Q_7_2. rewrite (Q_2 (-Q y n)). rewrite Q_7_2.
      assert (forall p: rational, -Q -Q p =Q= p).
        destruct p, i. unfold Q_neg, Z_neg. reflexivity.
      rewrite H1. reflexivity.
    rewrite H1. rewrite Q_cons_abs_neg. reflexivity.
  pose proof (H epsilon H0). destruct H2. exists x0. intros. rewrite <- H1.
  apply H2. apply H3.
Defined.

Theorem R_tran: Transitive R_eq.
Proof.
  unfold Transitive.
  unfold R_eq, R_eq_0.
  intros x y z H H0 epsilon H1'.
  destruct x as [x cx], y as [y cy], z as [z cz]; simpl. simpl in H, H0, H1'.
  assert (epsilon /Q QN2 >Q Q0).
    destruct epsilon. unfold QN2. simpl. rewrite Z_nonzero_mult_compat. simpl.
    simpl in H1'. rewrite Z_7 in H1'. rewrite Z_7_0 in H1'.
    rewrite Z_7_0. repeat rewrite Z_7. rewrite <- Z_5. apply Z_cons_pos_double. apply H1'.

  pose proof (H (epsilon /Q QN2) H1) as Hx.
  pose proof (H0 (epsilon /Q QN2) H1) as Hy.
  destruct Hx as [Nx], Hy as [Ny].
  exists (max Nx Ny).
  assert (forall n a b: nat, n > Init.Nat.max a b -> n > a /\ n > b).
    induction n. intros. inversion H4.
    destruct a; destruct b; try (intros; simpl; omega); simpl; try omega.
    assert (forall p q: nat, S p > S q <-> p > q) by (intros; omega).
    repeat rewrite H4. apply IHn.
  intros. apply H4 in H5. destruct H5. apply H2 in H5. apply H3 in H6.

  assert (x n -Q z n =Q= (x n -Q y n) +Q (y n -Q z n)).
    unfold Q_minus. rewrite <- Q_1. rewrite (Q_1 (x n) (-Q y n)).
    rewrite (Q_2 _ (y n)). assert ((y n) -Q (y n) =Q= Q0) by apply Q_4.
    unfold Q_minus in H7. rewrite H7. rewrite Q_3. reflexivity.
  rewrite H7.
  assert (epsilon >Q Q_abs (x n -Q y n) +Q Q_abs (y n -Q z n))
    by (rewrite <- Q_double_half; apply (Q_cons_lt_plus _ _ _ _ H5 H6)).
  rewrite Q_triangle_ineq. apply H8.
Defined.

Add Parametric Relation:
  real R_eq
  reflexivity proved by R_refl
  symmetry proved by R_symm
  transitivity proved by R_tran
  as R.

Definition R_plus (a b: real): real.
  exists (fun n => (proj1_sig a n +Q proj1_sig b n)).
  destruct a as [a ca], b as [b cb].
  unfold Cauchy; simpl.
  unfold Cauchy in ca, cb.
  intros epsilon Heps.
  pose proof (Q_cons_pos_div_QN2 epsilon Heps) as Heps2.
  pose proof (ca (epsilon /Q QN2) Heps2) as Ha; destruct Ha as [Na].
  pose proof (cb (epsilon /Q QN2) Heps2) as Hb; destruct Hb as [Nb].
  exists (max Na Nb). intros n m Hn' Hm'.
  pose proof (N_gt_max _ _ _ Hn') as Hn; destruct Hn as [Hna Hnb].
  pose proof (N_gt_max _ _ _ Hm') as Hm; destruct Hm as [Hma Hmb].
  clear Hn' Hm' Heps Heps2 ca cb.
  assert (Q_abs (a n -Q a m) +Q Q_abs (b n -Q b m) <Q epsilon).
    rewrite <- (Q_double_half epsilon).
    apply (Q_cons_lt_plus _ _ _ _ (H n m Hna Hma) (H0 n m Hnb Hmb)).
  assert (Q_abs (a n +Q b n -Q (a m +Q b m)) <=Q Q_abs (a n -Q a m) +Q Q_abs (b n -Q b m)).
    unfold Q_minus. rewrite Q_mult_neg_distr. rewrite Q_1. unfold Q_minus. rewrite <- (Q_1 (b n)).
    rewrite (Q_2 (b n)). rewrite Q_1. rewrite <- Q_1. rewrite Q_triangle_ineq. easy.
  rewrite H2. apply H1.
Defined.

Add Morphism R_plus with signature R_eq ==> R_eq ==> R_eq as R_plus_morph.
Proof. (* well-definedness of R_plus *)
  intros. unfold R_plus, R_eq, R_eq_0. unfold R_eq, R_eq_0 in H, H0. simpl.
  destruct x as [x cx], y as [y cy], x0 as [x0 cx0], y0 as [y0 cy0].
  simpl. simpl in H, H0.

  intros epsilon H1'.
  assert (epsilon /Q QN2 >Q Q0).
    destruct epsilon. unfold QN2. simpl. rewrite Z_nonzero_mult_compat. simpl.
    simpl in H1'. rewrite Z_7 in H1'. rewrite Z_7_0 in H1'.
    rewrite Z_7_0. repeat rewrite Z_7. rewrite <- Z_5. apply Z_cons_pos_double. apply H1'.

  pose proof (H (epsilon /Q QN2) H1) as Hx.
  pose proof (H0 (epsilon /Q QN2) H1) as Hy.
  destruct Hx as [Nx], Hy as [Ny].
  exists (max Nx Ny).
  assert (forall n a b: nat, n > Init.Nat.max a b -> n > a /\ n > b).
    induction n. intros. inversion H4.
    destruct a; destruct b; try (intros; simpl; omega); simpl; try omega.
    assert (forall p q: nat, S p > S q <-> p > q) by (intros; omega).
    repeat rewrite H4. apply IHn.
  intros. apply H4 in H5. destruct H5. apply H2 in H5. apply H3 in H6.

  assert (x n +Q x0 n -Q (y n +Q y0 n) =Q= (x n -Q y n) +Q (x0 n -Q y0 n)).
    unfold Q_minus. rewrite Q_1. rewrite Q_mult_neg_distr. unfold Q_minus.
    rewrite <- (Q_1 (x0 n)). rewrite (Q_2 (x0 n)). repeat rewrite <- Q_1.
    reflexivity.
  rewrite H7.

  assert (epsilon >Q Q_abs (x n -Q y n) +Q Q_abs ((x0 n -Q y0 n)))
    by (rewrite <- Q_double_half; apply (Q_cons_lt_plus _ _ _ _ H5 H6)).
  rewrite Q_triangle_ineq. apply H8.
Defined.

Notation "p '+' q" := (R_plus p q) (at level 50, left associativity) : real_scope.
Notation "p '+R' q" := (R_plus p q) (at level 50, left associativity) : type_scope.

(** negation of a real number: q |-> -q *)
Definition R_neg (a: real): real.
  exists (fun n => -Q proj1_sig a n).
  destruct a as [a ca].
  unfold Cauchy; simpl.
  unfold Cauchy in ca.
  intros epsilon Heps.
  pose proof (ca epsilon Heps) as Ha; destruct Ha as [Na].
  exists Na. intros n m Hn Hm.
  clear Heps ca. rewrite <- Q_mult_neg_distr.
  rewrite Q_cons_abs_neg. apply (H n m Hn Hm).
Defined.

Add Morphism R_neg with signature R_eq ==> R_eq as R_neg_morph.
Proof. (* well-definedness of R_neg *)
  intros. unfold R_neg, R_eq, R_eq_0. unfold R_eq, R_eq_0 in H. simpl.
  destruct x as [x cx], y as [y cy].
  simpl. simpl in H. intros epsilon Heqs.
  destruct (H epsilon Heqs) as [N]. exists N. intros.
  rewrite <- Q_mult_neg_distr. rewrite Q_cons_abs_neg. apply (H0 n H1).
Defined.

Notation "'-' q" := (R_neg q) (at level 35, right associativity) : real_scope.
Notation "'-R' q" := (R_neg q) (at level 35, right associativity) : type_scope.

(** subtraction *)

Definition R_minus (a b: real) := a + -b.

Add Morphism R_minus with signature R_eq ==> R_eq ==> R_eq as R_minus_morph.
Proof. (* well-definedness of Z_minus *)
  unfold R_minus. intros. now rewrite H, H0.
Defined.

Notation "p '-' q" := (R_minus p q) (at level 50, left associativity) : real_scope.
Notation "p '-R' q" := (R_minus p q) (at level 50, left associativity) : type_scope.

(** multiplication *)
Definition R_mult (a b: real): real.
  exists (fun n => proj1_sig a n *Q proj1_sig b n).
  destruct a as [a ca'], b as [b cb'].
  pose proof (R_Cauchy__Bounded a ca') as ba.
  pose proof (R_Cauchy__Bounded b cb') as bb.
  unfold Cauchy; simpl.
  unfold Cauchy in ca', cb'.
  intros epsilon Heps.

  unfold Bounded in ba, bb.
  destruct ba as [MA1 [ba1 ba2]], bb as [MB1 [bb1 bb2]].
  assert (MAN: MA1 <Q> Q0). rewrite Q_10_2. left. apply ba1. rewrite Q_nonzero__iff in MAN.
  assert (MBN: MB1 <Q> Q0). rewrite Q_10_2. left. apply bb1. rewrite Q_nonzero__iff in MBN.
  remember (exist (fun q: rational => Q_numerator q <Z> Z0) MA1 MAN) as MA.
  remember (exist (fun q: rational => Q_numerator q <Z> Z0) MB1 MBN) as MB.
  assert (Hepsa: epsilon /Q Q_nonzero_mult QN2 MB >Q Q0). admit.
  assert (Hepsb: epsilon /Q Q_nonzero_mult QN2 MA >Q Q0). admit.

  pose proof (ca' (epsilon /Q (Q_nonzero_mult QN2 MB)) Hepsa).
  pose proof (cb' (epsilon /Q (Q_nonzero_mult QN2 MA)) Hepsb).
  destruct H as [Na Ha]. destruct H0 as [Nb Hb].
  exists (max Na Nb). intros.

  assert (a n *Q b n -Q a m *Q b m =Q= (a n *Q b n -Q a n *Q b m) +Q (a n *Q b m -Q a m *Q b m)).
    unfold Q_minus. repeat rewrite Q_1. rewrite <- (Q_1 _ (a n *Q b m)), (Q_2 _ (a n *Q b m)).
    assert (forall q: rational, q -Q q =Q= Q0) by apply Q_4. unfold Q_minus in H1. rewrite H1.
    rewrite (Q_2 Q0). rewrite Q_3. reflexivity.
  rewrite H1.
  rewrite Q_triangle_ineq.
  unfold Q_minus. rewrite <- Q_mult_neg_0, <- Q_mult_neg. rewrite <- Q_9_0, <- Q_9.
  repeat rewrite Q_cons_abs_mult.

  apply N_gt_max in H; destruct H as [nNa nNb].
  apply N_gt_max in H0; destruct H0 as [mNa mNb].
  pose proof (Ha n m nNa mNa) as Ha'.
  pose proof (Hb n m nNb mNb) as Hb'.

  (* b and MA *)
  assert (Q_abs (a n) *Q Q_abs (b n +Q -Q b m) <Q epsilon /Q QN2).
    assert (MA1 =Q= (proj1_sig QN2 *Q MA1) /Q QN2).
      rewrite (Q_6 _ MA1). rewrite Q_5. rewrite <- Q_nonzero_mult_compat.
      rewrite Q_8_0. symmetry. apply Q_7.
    assert (epsilon /Q QN2 =Q= epsilon /Q Q_nonzero_mult QN2 MA *Q MA1).
      rewrite H. rewrite Q_5. rewrite <- (Q_5 _ (proj1_sig QN2 *Q MA1)).
      rewrite (Q_6 _ (proj1_sig QN2 *Q MA1)).
      assert (proj1_sig MA =Q= MA1). rewrite HeqMA. reflexivity.
      rewrite <- H0. rewrite <- Q_nonzero_mult_compat.
      rewrite <- Q_nonzero_mult_compat. rewrite Q_8_0.
      rewrite (Q_6 Q1). rewrite Q_7. reflexivity.
    rewrite H0. rewrite (Q_6 _ MA1). apply Q_cons_lt_mult_nonneg_0.
    apply Q_abs__nonneg. apply Q_abs__nonneg. apply ba1. apply ba2.
    apply (Hb n m nNb mNb).
  (* a and MB *)
  assert (Q_abs (b m) *Q Q_abs (a n +Q -Q a m) <Q epsilon /Q QN2).
    assert (MB1 =Q= (proj1_sig QN2 *Q MB1) /Q QN2).
      rewrite (Q_6 _ MB1). rewrite Q_5. rewrite <- Q_nonzero_mult_compat.
      rewrite Q_8_0. symmetry. apply Q_7.
    assert (epsilon /Q QN2 =Q= epsilon /Q Q_nonzero_mult QN2 MB *Q MB1).
      rewrite H0. rewrite Q_5. rewrite <- (Q_5 _ (proj1_sig QN2 *Q MB1)).
      rewrite (Q_6 _ (proj1_sig QN2 *Q MB1)).
      assert (proj1_sig MB =Q= MB1). rewrite HeqMB. reflexivity.
      rewrite <- H2. rewrite <- Q_nonzero_mult_compat.
      rewrite <- Q_nonzero_mult_compat. rewrite Q_8_0.
      rewrite (Q_6 Q1). rewrite Q_7. reflexivity.
    rewrite H2. rewrite (Q_6 _ MB1). apply Q_cons_lt_mult_nonneg_0.
    apply Q_abs__nonneg. apply Q_abs__nonneg. apply bb1. apply bb2.
    apply (Ha n m nNa mNa).

  rewrite <- Q_double_half. apply Q_cons_lt_plus. apply H. rewrite (Q_6 _ (Q_abs (b m))). apply H0.

Admitted.

Add Morphism R_mult with signature R_eq ==> R_eq ==> R_eq as R_mult_morph.
Proof. Admitted.
Notation "p '*' q" := (R_mult p q) (at level 40, left associativity) : real_scope.
Notation "p '*R' q" := (R_mult p q) (at level 40, left associativity) : type_scope.

Definition R_nonzero: Type := {q : real | ~ R_eq_0 (proj1_sig q)}.

(** reciprocal of a real number: q |-> -q *)
Definition R_recip (q: R_nonzero): R_nonzero.
Admitted.

Definition R_nonzero_eq (p q: R_nonzero): Prop := (proj1_sig p) =R= (proj1_sig q).

Add Morphism R_recip with signature R_nonzero_eq ==> R_nonzero_eq as R_recip_morph.
Proof. (* well-definedness of R_recip *)
Admitted.

Theorem R_nonzero_refl: Reflexive R_nonzero_eq.
Proof.
  (* reflexivity *) unfold Reflexive.
Admitted.

Theorem R_nonzero_symm: Symmetric R_nonzero_eq.
Proof.
  (* symmetricity *) unfold Symmetric.
Admitted.

Theorem R_nonzero_tran: Transitive R_nonzero_eq.
Proof.
  unfold Transitive.
Admitted.

Add Parametric Relation:
  R_nonzero R_nonzero_eq
  reflexivity proved by R_nonzero_refl
  symmetry proved by R_nonzero_symm
  transitivity proved by R_nonzero_tran
  as R_nz.

Definition R_nonzero_mult (p q: R_nonzero): R_nonzero.
  exists ((proj1_sig p) * (proj1_sig q)).
Admitted.

Lemma R_nonzero__R_injective:
  forall p q: R_nonzero, proj1_sig p =R= proj1_sig q -> R_nonzero_eq p q.
Proof.
  intros [x1 i1] [x2 i2]; simpl; intros e. unfold Q_nonzero_eq. simpl. apply e.
Defined.

Definition R_nonzero_1: R_nonzero.
Admitted.

Notation "'/' q" := (R_recip q) (at level 35, right associativity) : real_scope.
Notation "'/R' q" := (R_recip q) (at level 35, right associativity) : type_scope.

Theorem R_1: forall p q r: real, p + q + r =R= p + (q + r).
Proof. Admitted.

(** NOT YET MODIFIED **)

Theorem Q_2: forall p q: real, p + q =Q= q + p.
Proof. Admitted.

Theorem Q_3: forall q: real, q + 0 =Q= q.
Proof. Admitted.

Theorem Q_4: forall q: real, q + -q =Q= 0.
Proof. Admitted.

Theorem Q_5: forall p q r: real, p * q * r =Q= p * (q * r).
Proof. Admitted.

Theorem Q_6: forall p q: real, p * q =Q= q * p.
Proof. Admitted.

Theorem Q_7: forall q: real, q * 1 =Q= q.
Proof. Admitted.

Ltac one:= repeat rewrite mult_1_r.

Theorem Q_8: forall q: Q_nonzero, Q_nonzero_eq (Q_nonzero_mult q (/q)) (Q_nonzero_1).
Proof. Admitted.

Theorem Q_9: forall p q r: real, p * (q + r) =Q= p * q + p * r.
Proof. Admitted.

Add Parametric Morphism: Q_le with signature Q_eq ==> Q_eq ==> iff as Q_le_morph.
Proof.
  intros [[ix lx] rx] [[iy ly] ry] Hxy [[iz lz] rz] [[iw lw] rw] Hzw.
  unfold Q_le, Z_pos__Z, Z_mult. zero. simpl.
  unfold Q_eq, Z_pos__Z, Z_mult in Hxy, Hzw. zero_in Hxy; zero_in Hzw. simpl in Hxy, Hzw.
  rewrite (N_cons_le_mult_pos (proj1_sig ry) (ix * proj1_sig rz + lz * proj1_sig rx)).
  repeat rewrite mult_plus_distr_l; repeat rewrite mult_assoc. rewrite (mult_comm _ ix).
  rewrite (N_cons_le_plus (proj1_sig rx * ly * proj1_sig rz) (ix * proj1_sig ry * proj1_sig rz + proj1_sig ry * lz * proj1_sig rx)).
  rewrite plus_assoc. rewrite (plus_comm (proj1_sig rx * ly * proj1_sig rz)).
  rewrite <- mult_plus_distr_r. rewrite Hxy. rewrite mult_plus_distr_r.
  rewrite plus_assoc. rewrite (plus_comm _ (proj1_sig ry * lx * proj1_sig rz)).
  rewrite (mult_comm _ lx).
  rewrite <- (plus_assoc (lx * proj1_sig ry * proj1_sig rz)).
  rewrite <- (N_cons_le_plus (lx * proj1_sig ry * proj1_sig rz)).

  rewrite (N_cons_le_mult_pos (proj1_sig rz) (iy * proj1_sig rw + lw * proj1_sig ry)).
  repeat rewrite mult_plus_distr_l; repeat rewrite mult_assoc.
  rewrite (N_cons_le_plus (iz * proj1_sig rw * proj1_sig ry) (proj1_sig rz * iy * proj1_sig rw + proj1_sig rz * lw * proj1_sig ry)).
  rewrite (plus_comm (iz * proj1_sig rw * proj1_sig ry)), <- plus_assoc. rewrite <- mult_plus_distr_r.
  rewrite (plus_comm (proj1_sig rz * lw)). rewrite Hzw. rewrite mult_plus_distr_r.
  rewrite (plus_comm (lz * proj1_sig rw * proj1_sig ry)).
  repeat rewrite plus_assoc.
  repeat rewrite (plus_comm _ (proj1_sig rz * iw * proj1_sig ry)).
  repeat rewrite <- plus_assoc.
  rewrite <- (N_cons_le_plus (proj1_sig rz * iw * proj1_sig ry)).

  repeat rewrite (mult_comm _ (proj1_sig rx)), <- (mult_assoc (proj1_sig rx)).
  repeat rewrite <- (mult_plus_distr_l (proj1_sig rx)).
  rewrite <- (N_cons_le_mult_pos (proj1_sig rx)).

  repeat rewrite (mult_comm _ (proj1_sig rw)).
  repeat rewrite <- (mult_assoc (proj1_sig rw)).
  repeat rewrite <- mult_plus_distr_l.
  rewrite <- (N_cons_le_mult_pos (proj1_sig rw)).
  repeat rewrite (mult_comm (proj1_sig ry)), (mult_comm (proj1_sig rz)).
  rewrite (plus_comm (iz * proj1_sig ry)). reflexivity.

  destruct rw. simpl. unfold gt. rewrite <- N_ltb_true__lt. apply i.
  destruct rx. simpl. unfold gt. rewrite <- N_ltb_true__lt. apply i.
  destruct rz. simpl. unfold gt. rewrite <- N_ltb_true__lt. apply i.
  destruct ry. simpl. unfold gt. rewrite <- N_ltb_true__lt. apply i.
Defined.

Notation "z '<=Q' w" := (Q_le z w) (at level 70, no associativity) : type_scope.
Notation "z '<Q' w" := (~ Q_le w z) (at level 70, no associativity) : type_scope.
Notation "z '>=Q' w" := (Q_le w z) (at level 70, no associativity) : type_scope.
Notation "z '>Q' w" := (~ Q_le z w) (at level 70, no associativity) : type_scope.

Theorem Q_le_refl: subrelation Q_le Q_le.
Proof. unfold subrelation. destruct x, y. unfold Q_le. intros. apply H. Defined.

Lemma Q_le_iff_neg: forall x: real, x <=Q 0 <-> Q_numerator x <=Z Z0.
Proof. destruct x.
  unfold Q_le. simpl. rewrite Z_7. reflexivity.
Defined.

Lemma Q_le_iff_pos: forall x: real, x >=Q 0 <-> Q_numerator x >=Z Z0.
Proof. destruct x.
  unfold Q_le. unfold Z_pos__Z.
  assert (proj1_sig ZP1 = 1%nat) by reflexivity. rewrite H.
  assert (Z0 *Z (proj1_sig z, 0) =Z= Z0) by reflexivity. rewrite H0.
  assert (Q_numerator (i // z) =Z= i) by reflexivity. rewrite H1.
  rewrite Z_7. reflexivity.
Defined.

Lemma Q_eq_iff: forall x: real, x =Q= 0 <-> Q_numerator x =Z= Z0.
Proof. destruct x.
  unfold Q_eq. unfold Z_pos__Z.
  assert (proj1_sig ZP1 = 1%nat) by reflexivity. rewrite H.
  assert ((proj1_sig z, 0) *Z Z0 =Z= Z0) by reflexivity. rewrite H0.
  assert (Q_numerator (i // z) =Z= i) by reflexivity. rewrite H1.
  rewrite Z_7. reflexivity.
Defined.

Lemma Q_neg_diff__lt: forall x y: real, x - y <Q 0 <-> x <Q y.
Proof. intros. destruct x, y.
  assert (forall t: integer, Z0 *Z t =Z= Z0). destruct t. zero.
  assert (forall a b: integer, a +Z -Z b =Z= a -Z b).
         destruct a, b. unfold Z_neg, Z_plus, Z_minus. reflexivity.
  assert (forall a b: integer, -Z a *Z b =Z= -Z (a *Z b)).
         destruct a, b. unfold Z_neg, Z_mult, Z_eq. omega.
  unfold Q_le, Z_pos__Z, Q_minus, Q_neg, Q_plus.
  repeat rewrite H. rewrite Z_8_0.
  repeat rewrite H1. rewrite H0. unfold Z_minus. rewrite Z_neg_diff__lt.
  repeat rewrite Z_5. simpl. zero. one. easy.
Defined.
Lemma Q_no_diff__eq: forall x y: real, x - y =Q= 0 <-> x =Q= y.
Proof. intros. destruct x, y. unfold Q_le, Z_pos__Z, Q_minus, Q_neg, Q_plus, Q_eq.
  assert (forall t: integer, t *Z Z0 =Z= Z0). destruct t. zero.
  assert (forall a b: integer, -Z a *Z b =Z= -Z (a *Z b)).
         destruct a, b. unfold Z_neg, Z_mult, Z_eq. omega.
  rewrite Z_7. rewrite H, H0. rewrite Z_no_diff__eq. rewrite (Z_6 _ i0).
  easy.
Defined.
Lemma Q_pos_diff__gt: forall x y: real, x - y >Q 0 <-> x >Q y.
Proof. intros. destruct x, y.
  assert (forall t: integer, Z0 *Z t =Z= Z0). destruct t. zero.
  assert (forall a b: integer, -Z a *Z b =Z= -Z (a *Z b)).
         destruct a, b. unfold Z_neg, Z_mult, Z_eq. omega.
  unfold Q_le, Z_pos__Z, Q_minus, Q_neg, Q_plus.
  repeat rewrite H. rewrite Z_8_0.
  repeat rewrite H1. rewrite H0, H0. rewrite Z_pos_diff__gt.
  repeat rewrite Z_5. simpl. zero. one. easy.
Defined.
Lemma Q_10_0: forall x: real,
    (  x <Q 0 /\ ~ x =Q= 0 /\ ~ x >Q 0) \/
    (~ x <Q 0 /\   x =Q= 0 /\ ~ x >Q 0) \/
    (~ x <Q 0 /\ ~ x =Q= 0 /\   x >Q 0).
Proof.
  intros [ix rx]. repeat rewrite Q_le_iff_neg; repeat rewrite Q_le_iff_pos; repeat rewrite Q_eq_iff.
  assert (Q_numerator (ix // rx) =Z= ix) by reflexivity. rewrite H.
  apply Z_10.
Defined.

(** trichotomy *)
Theorem Q_10: forall x y: real,
  (  x <Q y /\ ~ x =Q= y /\ ~ x >Q y) \/
  (~ x <Q y /\   x =Q= y /\ ~ x >Q y) \/
  (~ x <Q y /\ ~ x =Q= y /\   x >Q y).
Proof.
  intros. rewrite <- Q_neg_diff__lt. rewrite <- Q_no_diff__eq. rewrite <- (Q_pos_diff__gt x y).
  apply Q_10_0.
Defined.

(** trichotomy *)
Corollary Q_10_1: forall x y: real, x <Q y \/ x =Q= y \/ x >Q y.
Proof.
  intros.
  pose proof (Q_10 x y).
  destruct H; destruct H.
  - left. apply H.
  - destruct H. destruct H0. right. left. apply H0.
  - destruct H. destruct H0. right. right. apply H1.
Defined.

(** transitivity *)
Theorem Q_11: forall x y z: real, x <Q y -> y <Q z -> x <Q z.
Proof. intros x y z. rewrite <- (Q_neg_diff__lt x y). rewrite <- (Q_neg_diff__lt x z). rewrite <- (Q_neg_diff__lt y z).
  assert (forall a b: real, a <Q 0 -> b <Q 0 -> a + b <Q 0).
  { destruct a, b. repeat rewrite Q_le_iff_pos. unfold Q_plus. unfold Q_numerator.
    destruct i, i0. unfold Z_pos__Z, Z_mult. zero. simpl.
    rewrite (N_cons_le_mult_pos (proj1_sig z1) n0 n).
    rewrite (N_cons_le_mult_pos (proj1_sig z0) n2 n1).
    rewrite (mult_comm _ n), (mult_comm _ n0), (mult_comm _ n1), (mult_comm _ n2).
    repeat rewrite N_nle__gt.
    assert (forall k l m n: nat, k > l -> m > n -> k + m > l + n).
    intros. omega.
    apply H.
    destruct z0. unfold gt. rewrite <- N_ltb_true__lt. apply i.
    destruct z1. unfold gt. rewrite <- N_ltb_true__lt. apply i. }
  assert ((x - y) + (y - z) =Q= x - z).
  { destruct x, y, z. unfold Q_minus, Q_neg.
    rewrite Q_1. rewrite <- (Q_1 (-Z i0 // z1)).
    assert (- (i0 // z1) + (i0 // z1) =Q= 0).
    rewrite Q_2. apply Q_4.
    unfold Q_neg in H0.
    rewrite H0.
    assert (forall q: real, 0 + q =Q= q).
    destruct q as [q q']. unfold Q_plus.
    assert (forall z: integer, Z0 +Z z =Z= z).
    destruct z2. simpl. omega.
    unfold Q_eq. rewrite H1. rewrite Z_7. unfold Z_pos__Z. rewrite Z_pos_mult_compat.
    rewrite Z_6. assert ((Z_pos__N ZP1 * Z_pos__N q')%nat = proj1_sig q') by zero.
    rewrite H2. reflexivity.
    rewrite H1. reflexivity. }
  intros. rewrite <- H0. apply (H (x - y) (y - z)). apply H1. apply H2. Defined.

(** addition preserves the order *)
Theorem Q_12: forall x y z: real, x <Q y -> x + z <Q y + z.
Proof. intros x y z. rewrite <- Q_pos_diff__gt. destruct x, y, z. simpl.
  rewrite Z_7.
  assert (forall a b: integer, a +Z -Z b =Z= a -Z b).
         destruct a, b. unfold Z_neg, Z_plus, Z_minus. reflexivity.
  assert (forall a b: integer, -Z a *Z b =Z= -Z (a *Z b)).
         destruct a, b. unfold Z_neg, Z_mult, Z_eq. omega.
  rewrite H0, H. unfold Z_minus.
  rewrite Z_pos_diff__gt.
  assert (forall j k: Z_pos, Z_pos__Z (Z_pos_mult j k) =Z= Z_pos__Z j *Z Z_pos__Z k).
  intros; unfold Z_pos__Z, Z_mult. rewrite Z_pos_mult_compat. zero.
  repeat rewrite H1. repeat rewrite <- Z_5. intros.
  apply Z_13.
  repeat rewrite Z_8_0.
  rewrite Z_5. rewrite (Z_6 (Z_pos__Z z)). rewrite <- Z_5.
  apply (Z_13 _ _ (Z_pos__Z z)) in H2.
  apply (Z_12 _ _ (i1 *Z Z_pos__Z z1 *Z Z_pos__Z z0)) in H2.
  repeat rewrite (Z_5 _ _ (Z_pos__Z z1)).
  rewrite (Z_6 (Z_pos__Z z) (Z_pos__Z z1)), (Z_6 (Z_pos__Z z0) (Z_pos__Z z1)).
  repeat rewrite <- Z_5.
  apply H2.
  destruct z. simpl. unfold is_true in i2. rewrite N_ltb_true__lt in i2. omega.
  destruct z. simpl. unfold is_true in i2. rewrite N_ltb_true__lt in i2. omega.
Defined.

Theorem Q_13: forall p q r: real, p <Q q -> r >Q 0 -> p * r <Q q * r.
Proof. intros p q r H H'. destruct p as [np dp], q as [nq dq], r as [nr dr].
  simpl. unfold Z_pos__Z. repeat rewrite Z_pos_mult_compat.
  assert (forall a b: nat, (a * b, 0) =Z= (a, 0) *Z (b, 0)) by (intros; simpl; omega).
  repeat rewrite H0. repeat rewrite Z_5. repeat rewrite (Z_6 nr).
  repeat rewrite (Z_5 _ _ nr). rewrite <- (Z_5 nq), <- (Z_5 np).
  apply Z_13.
  simpl in H. unfold Z_pos__Z in H. apply H.
  simpl in H'. unfold Z_pos__Z in H'. simpl in H'. rewrite Z_7 in H'.
  assert (Z0 =Z= Z0 *Z nr) by (destruct nr; simpl; omega).
  rewrite H1. apply Z_13. simpl. destruct dr. simpl. unfold is_true in i.
  rewrite N_ltb_true__lt in i. omega. apply H'.
Defined.

Theorem Q_14: 0 <Q> 1.
Proof. simpl. easy. Defined.

Theorem Q_15: forall q: real, - q =Q= (-Z Q_numerator q // Q_denominator q).
Proof. intros. destruct q. simpl. destruct i. simpl. zero. simpl.
  rewrite plus_comm. rewrite (mult_comm _ n), (mult_comm _ n0). reflexivity.
Defined.


From Coq Require Import Nat.
From Coq Require Import Program.Equality.

Module Stlc.

  (** Use the same reified type for the whole development *)
  Inductive type : Type :=
  | TNum: type
  | TArrow : type -> type -> type.

  Declare Custom Entry stlc_ty.
  Notation "<{{ e }}>" := e (e custom stlc_ty at level 99).
  Notation "( x )" := x (in custom stlc_ty, x at level 99).
  Notation "x" := x (in custom stlc_ty at level 0, x constr at level 0).
  Notation "S -> T" := (TArrow S T) (in custom stlc_ty at level 2, right associativity).
  Notation "'Num'" := TNum (in custom stlc_ty at level 0).

  Fixpoint typeDenote (t : type) : Set :=
    match t with
    | <{{ Num }}> => nat
    | <{{ t1 -> t2 }}> => typeDenote t1 -> typeDenote t2
    end.

  Section vars.
    Variable var : type -> Type.

    Inductive Term: type -> Type :=
    | NUM: nat -> Term <{{ Num }}>
    | APP: forall a b, Term <{{ a -> b }}> -> Term a -> Term b
    | VAR: forall a, var a -> Term a
    | LAM: forall a b, (var a -> Term b) -> Term <{{ a ->  b }}>.
  End vars.

  Arguments VAR [var a].
  Arguments NUM {var}.
  Arguments APP [var a b].
  Arguments LAM [var a b].
  (** Maximally insert types in class *)

  Declare Custom Entry stlc.

  Notation "<{ e }>" := e (e custom stlc at level 99).
  Notation "( x )" := x (in custom stlc, x at level 99).
  Notation "x" := x (in custom stlc at level 0, x constr at level 0).
  Notation "x y" := (APP x y) (in custom stlc at level 2, left associativity).
  Notation "\ x , y" :=
    (LAM (fun x => y)) (in custom stlc at level 90,
                        x constr,
                        y custom stlc at level 80,
                        left associativity).
  Notation "\_ , y" :=
    (LAM (fun _ => y)) (in custom stlc at level 90,
                        y custom stlc at level 80,
                        left associativity).
  Definition NUM_coerce(n: nat): Term typeDenote <{{ Num }}> := NUM n.
  Coercion NUM_coerce: nat >-> Term.
  Notation "# n" := (VAR n) (in custom stlc at level 0).
  Notation "{ x }" := x (in custom stlc at level 1, x constr).

  Fixpoint termDenote {t: type} (e : Term typeDenote t) {struct e} : typeDenote t :=
    match e in (Term _ t) return (typeDenote t) with
    | VAR v => v
    | NUM f => f
    | APP e1 e2 => (termDenote e1) (termDenote e2)
    | LAM e' => fun x => termDenote (e' x)
    end.

  (* Normalization via reify/reflect Danvy et al. *)
  Class Nbe (t: type) := {
    reify: typeDenote t -> Term typeDenote t;
    reflect: Term typeDenote t -> typeDenote t
                        }.

  Instance Nbe_lam {a b: type} `{Nbe a} `{Nbe b}: Nbe <{{ a -> b }}> := {
    reify v :=
      LAM (fun x => reify (v (reflect (VAR x))));
    reflect e :=
      fun x => reflect (APP e (reify x))
                                                                      }.
  Instance Nbe_int : Nbe <{{ Num }}> := {
    reify v := NUM v;
    reflect v := termDenote v;
                                       }.

  Fixpoint resolver(t: type): Nbe t :=
    match t with
    | <{{ Num }}> => Nbe_int
    | <{{ a -> b }}> => Nbe_lam
    end.

  Arguments Nbe {t}.
  Arguments Nbe_lam [a b].

  Definition normalize {t: type} (e: Term typeDenote t): Term typeDenote t :=
    @reify t (resolver t) (@reflect t (resolver t) e).

  Compute normalize <{ 1 }>.

  Compute normalize <{ \ x, (\ y, # y) 1 }>.

  Inductive fof: type -> Prop :=
  | fo_num: fof <{{ Num }}>
  | fof_num: forall a,
      fof <{{ a }}> ->
      fof <{{ Num -> a }}>.

  Inductive value: forall {t: type}, Term typeDenote t -> Prop :=
  | Value_var: forall x, @value <{{ Num }}> (@VAR typeDenote <{{ Num }}> x)
  | Value_const: forall (x: nat), @value <{{ Num }}> (NUM x).

  Inductive hnff: forall (t: type), Term typeDenote t -> Prop :=
  | HNF_num_ar: forall a f,
      (forall (arg: typeDenote <{{ Num }}>), hnff <{{ a }}> (f arg)) ->
      hnff <{{ Num -> a }}> (LAM f)
  | HNF_num: forall e,
      value e ->
      hnff <{{ Num }}> e.

  Hint Constructors hnff: core.
  Hint Constructors value: core.
  Hint Constructors fof: core.

  Theorem normalize_correct: forall (t: type) (e: Term typeDenote t),
      fof t  ->
      hnff t (normalize e).
  Proof with eauto.
    intros; induction H; dependent destruction e; cbn...
  Defined.

End Stlc.


Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Classes.RelationClasses.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Tactics.Consider.
Require Import ExtLib.Tactics.Injection.

Set Implicit Arguments.
Set Strict Implicit.

Section Eqpair.
  Context {T U} (rT : relation T) (rU : relation U).

  Inductive Eqpair : relation (T * U) :=
  | Eqpair_both : forall a b c d, rT a b -> rU c d -> Eqpair (a,c) (b,d).

  Global Instance Reflexive_Eqpair {RrT : Reflexive rT} {RrU : Reflexive rU}
  : Reflexive Eqpair.
  Proof. red. destruct x. constructor; reflexivity. Qed.

  Global Instance Symmetric_Eqpair {RrT : Symmetric rT} {RrU : Symmetric rU}
  : Symmetric Eqpair.
  Proof. red. inversion 1; constructor; symmetry; assumption. Qed.

  Global Instance Transitive_Eqpair {RrT : Transitive rT} {RrU : Transitive rU}
  : Transitive Eqpair.
  Proof. red. inversion 1; inversion 1; constructor; etransitivity; eauto. Qed.

  Global Instance Injective_Eqpair a b c d : Injective (Eqpair (a,b) (c,d)).
  refine {| result := rT a c /\ rU b d |}.
  abstract (inversion 1; auto).
  Defined.
End Eqpair.

Section PairWF.
  Variables T U : Type.
  Variable RT : T -> T -> Prop.
  Variable RU : U -> U -> Prop.

  Inductive R_pair : T * U -> T * U -> Prop :=
  | L : forall l l' r r',
    RT l l' -> R_pair (l,r) (l',r')
  | R : forall l r r',
    RU r r' -> R_pair (l,r) (l,r').

  Hypothesis wf_RT : well_founded RT.
  Hypothesis wf_RU : well_founded RU.

  Theorem wf_R_pair : well_founded R_pair.
  Proof.
    red. intro x.
    destruct x. generalize dependent u.
    apply (well_founded_ind wf_RT (fun t => forall u : U, Acc R_pair (t, u))) .
    do 2 intro.

    apply (well_founded_ind wf_RU (fun u => Acc R_pair (x,u))). intros.
    constructor. destruct y.
    remember (t0,u). remember (x,x0). inversion 1; subst;
    inversion H4; inversion H3; clear H4 H3; subst; eauto.
  Defined.
End PairWF.

Section PairParam.
  Variable T : Type.
  Variable eqT : T -> T -> Prop.
  Variable U : Type.
  Variable eqU : U -> U -> Prop.

  Variable EDT : RelDec eqT.
  Variable EDU : RelDec eqU.

  Global Instance RelDec_equ_pair : RelDec (fun x y => eqT (fst x) (fst y) /\ eqU (snd x) (snd y)) :=
  { rel_dec := fun x y =>
    if rel_dec (fst x) (fst y) then
      rel_dec (snd x) (snd y)
    else false }.

  Variable EDCT : RelDec_Correct EDT.
  Variable EDCU : RelDec_Correct EDU.

  Global Instance RelDec_Correct_equ_pair : RelDec_Correct RelDec_equ_pair.
  Proof.
    constructor; destruct x; destruct y; split; simpl in *; intros;
      repeat match goal with
               | [ H : context [ rel_dec ?X ?Y ] |- _ ] =>
                 consider (rel_dec X Y); intros; subst
               | [ |- context [ rel_dec ?X ?Y ] ] =>
                 consider (rel_dec X Y); intros; subst
             end; intuition.
  Qed.
End PairParam.

Section PairEq.
  Variable T : Type.
  Variable U : Type.

  Variable EDT : RelDec (@eq T).
  Variable EDU : RelDec (@eq U).

  (** Specialization for equality **)
  Global Instance RelDec_eq_pair : RelDec (@eq (T * U)) :=
  { rel_dec := fun x y =>
    if rel_dec (fst x) (fst y) then
      rel_dec (snd x) (snd y)
    else false }.

  Variable EDCT : RelDec_Correct EDT.
  Variable EDCU : RelDec_Correct EDU.

  Global Instance RelDec_Correct_eq_pair : RelDec_Correct RelDec_eq_pair.
  Proof.
    constructor; destruct x; destruct y; split; simpl in *; intros;
      repeat match goal with
               | [ H : context [ rel_dec ?X ?Y ] |- _ ] =>
                 consider (rel_dec X Y); intros; subst
               | [ |- context [ rel_dec ?X ?Y ] ] =>
                 consider (rel_dec X Y); intros; subst
             end; congruence.
  Qed.
End PairEq.

Global Instance Injective_pair T U (a :T) (b:U) c d : Injective ((a,b) = (c,d)).
refine {| result := a = c /\ b = d |}.
Proof. abstract (inversion 1; intuition). Defined.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq tuple div fintype.

(* Reasoning about finite types without indexed type families.
   Inspired by this James' post:

https://homes.cs.washington.edu/~jrw12/dep-destruct.html

Check for [REM]s in the code below for some ideas and insights.

Some main ideas so far:

* Using inductive type families with parameters and explicit
  equalities instead of indices; this leads to proof obligations with
  different proofs of an equality, which, ideally, shoudl be
  discharged via the Streicher K axiom;

* Since nat has decidable equality, we can don't need the full-blown K
  axiom, and cen get away with ssreflect's eq_axiomK lemma. The proof
  of this lemma is by building a simple discriminator on the two
  possible constructors or reflect (x = y) (x == y).
  (akin to https://syntaxexclamation.wordpress.com/2013/12/04/1-%E2%89%A0-0/)
*)

(* [REM] Working with indexed type families is painful, as they hide
   the equalities. Instead, I reformulate the finite type definition
   from James' post making the equalities explicit. *)
Inductive Fin (n : nat) : Set :=
  F1 m of n = m.+1
| FS m of n = m.+1 & Fin m.

Definition f21 : Fin 2 := F1 2 _ (erefl _).
Definition f22 : Fin 2 := FS 2 1 (erefl _) (F1 1 _ (erefl _)).

Definition cardinality (n : nat) (A : Type) : Prop :=
  exists (f : A -> Fin n) (g : Fin n -> A),
    (forall x, g (f x) = x) /\
    (forall y, f (g y) = y).

Definition bool_to_Fin_2 (x : bool) : Fin 2 :=
  if x then f22 else f21.

Definition Fin_2_to_bool (y : Fin 2) : bool :=
  match y with
  | F1 _ _ => false
  | FS _ _ _ => true
  end.

Require Import Program.

Lemma fin1_eq (f1 f2 : Fin 1) : f1 = f2.
case: f1=>m E; case: (E)=>Z; subst m; last by case.
case: f2=> m' E'; case: (E')=>Z; subst m'; last by case.
(* [REM] Since equpality for nat is decidable, we don't need the
         full-blown K axiom to equate equality proofs. *)
move: (eq_axiomK E) (eq_axiomK E')=>//= Z1 Z2.
by subst E E'.
Qed.

Theorem bool_cardinality_2 :
  cardinality 2 bool.
Proof.
exists bool_to_Fin_2, Fin_2_to_bool; split; [by case|move=>y].
case: y=>m E/=; case: (E)=>Z; subst m.
- by rewrite /f21; move: (eq_axiomK E)=>//= Z; subst E.
move=> f. move: (eq_axiomK E)=>/=Z; subst E.
by move: (fin1_eq f ((F1 1 0 (erefl 1))))=>Z; subst f.
Qed.

(* [REM] Note to self: check how [subst] and [rewrite] tactics work,
   i.e., how exactly do they employ equality proofs. *)

(* Okay, now how to do the same with an indexed type family *)

(* TODO: Try something complicatd. Dominique suggested to implement a
   per-family ordereing on fins. *)

(* An indexed family for the finite type *)
Inductive Fin' : nat -> Set :=
  F1' : forall n : nat, Fin' (n.+1)
| FS' : forall n : nat, Fin' n -> Fin' (n.+1).

(* [Q] How to get from definition Fin' to the definition Fin with
   explicit equalities? *)

(* Goal forall f1 f2 : Fin' 1, f1 = f2. *)
(* move=> f1 f2. *)
(* dependent inversion f1. *)
(* (* FAIL *) *)

(* Some experiments with converting equalities. *)
Inductive type : Type :=  Nat : type | Func : type -> type -> type.

Lemma ty_eq_dec :
  forall x y : type, {x = y} + {x <> y}.
Proof.
decide equality.
Qed.

Definition typeEq : rel type :=
  fun x y =>
    match ty_eq_dec x y with
    | left _ => true
    | right _ => false
    end.

Lemma typeP: Equality.axiom typeEq.
Proof.
by move=>x y; rewrite /typeEq; case: (ty_eq_dec x y)=>H;
   [constructor 1 | constructor 2].
Qed.


Require Import Coq.Strings.Ascii Coq.Strings.String Coq.Lists.List.
Require Import Coq.QArith.QArith_base.
Require Import Coq.ZArith.ZArith.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.OptionList.
Require Import Crypto.Util.Strings.ParseArithmetic.
Require Import Crypto.Util.Notations.
Import ListNotations.
Local Open Scope option_scope.
Local Open Scope list_scope.
Local Open Scope char_scope.
Local Open Scope string_scope.
Local Open Scope Z_scope.

Local Open Scope parse_scope.

(** From the Python:
<<
# given a string representing one term or "tap" in a prime, returns a pair of
# integers representing the weight and coefficient of that tap
#    "2 ^ y" -> [1, y]
#    "x * 2 ^ y" -> [x, y]
#    "x * y" -> [x*y,0]
#    "x" -> [x,0]
def parse_term(t) :
    if "*" not in t and "^" not in t:
        return [int(t),0]

    if "*" in t:
        if len(t.split("*")) > 2: # this occurs when e.g. [w - x * y] has been turned into [w + -1 * x * y]
            a1,a2,b = t.split("*")
            a = int(a1) * int(a2)
        else:
            a,b = t.split("*")
        if "^" not in b:
            return [int(a) * int(b),0]
    else:
        a,b = (1,t)

    b,e = b.split("^")
    if int(b) != 2:
        raise NonBase2Exception("Could not parse term, power with base other than 2: %s" %t)
    return [int(a),int(e)]
>> *)

(** given an expression representing one term or "tap" in a prime,
    returns a pair of integers representing the coefficient and weight
    of that tap:
    * "2 ^ y" -> Some (2^y, 1)
    * "x * 2 ^ y" -> Some (2^y, x)
    * "x * y" -> Some (1,x*y)
    * "x" -> Some (1,x)
    *)
Fixpoint parse_term_of_Qexpr (v : Qexpr) : option (Z * Z)
  := match v with
     | Qvar x => match x with end
     | Qv x => q <- Q_to_Z_strict x; Some (1, q)
     | Qeopp a => v <- parse_term_of_Qexpr a; Some (fst v, -snd v)
     | Qeadd a b => None
     | Qesub a b => None
     | Qemul a b => b <- parse_term_of_Qexpr b;
                      a <- eval_Qexpr_strict a;
                      a <- Q_to_Z_strict a;
                      Some (fst b, a * snd b)
     | Qediv a b => None
     | Qepow b e => v <- eval_Qexpr_strict v; v <- Q_to_Z_strict v; Some (v, 1)
     end%option.

Fixpoint Qexpr_to_add_list (v : Qexpr) : list Qexpr
  := match v with
     | Qeadd a b => Qexpr_to_add_list a ++ Qexpr_to_add_list b
     | Qesub a b => Qexpr_to_add_list a ++ [Qeopp b]
     | v => [v]
     end.

(** Given a Qexpr which is a sequence of additions and subtractions,
    we return the value of the first component, and a list of the taps
    for the negation of the other components *)
Definition parse_prime_and_taps_of_Qexpr (v : Qexpr) : option (Z * list (Z * Z))
  := match Qexpr_to_add_list v with
     | nil => None
     | cons p taps
       => taps <- Option.List.lift (List.map (fun v => parse_term_of_Qexpr (Qeopp v)) taps);
            p <- eval_Qexpr_strict p;
            p <- Q_to_Z_strict p;
            Some (p, taps)
     end.

Definition parseZ_arith_to_taps (s : string) : option (Z * list (Z * Z))
  := v <- parseQexpr_arith s; parse_prime_and_taps_of_Qexpr v.

Local Coercion QArith_base.inject_Z : Z >-> Q.
Local Example parse_v25519 : parse_prime_and_taps_of_Qexpr (2^255 - 19) = Some (2^255, [(1,19)]) := eq_refl.
Local Example parse_25519 : parseZ_arith_to_taps "2^255 - 19" = Some (2^255, [(1,19)]) := eq_refl.
Local Example parse_p521 : parseZ_arith_to_taps "2^521 - 1" = Some (2^521, [(1,1)]) := eq_refl.
Local Example parse_p448 : parseZ_arith_to_taps "2^448 - 2^224 - 1" = Some (2^448, [(2^224,1); (1,1)]) := eq_refl.
Local Example parse_p256 : parseZ_arith_to_taps "2^256 - 2^224 + 2^192 + 2^96 - 1" = Some (2^256, [(2^224,1); (2^192,-1); (2^96,-1); (1,1)]) := eq_refl.
Local Example parse_p434 : parseZ_arith_to_taps "2^216 * 3^137 - 1" = Some (2^216 * 3^137, [(1,1)]) := eq_refl.


(** * Euclid's Elements

  Book III
*)

Require Export GeoCoq.Tarski_dev.Annexes.tangency.
Require Export GeoCoq.Tarski_dev.Annexes.inscribed_angle.

Section Book_3.

Context `{TE:Tarski_2D}.

(** * Proposition 1
To find the center of a given circle.
        *)

(** We do not formalize this proposition,
    because in our formalization circles are given by
    their center and one point on the circle. *)

(** * Proposition 2
If on the circumference of a circle two points are taken at random, the straight line joining the points will fall within the circle.
        *)

Lemma prop_2 : forall O P U V X,
 X <> U -> X <> V ->
 Bet U X V ->
 OnCircle U O P ->
 OnCircle V O P ->
 InCircleS X O P.
Proof.
intros O P U V X; intros.
apply bet_inc2__incs with U V; Circle.
Qed.

(** * Proposition 3
If in a circle a straight line passing through the center bisects a straight line not passing through the center, it also cuts it at right angles; and if it cut it at right angles, it also bisects it.
        *)

Lemma prop_3_1 : forall O P A B X,
 O <> X -> A <> B ->
 OnCircle A O P ->
 OnCircle B O P ->
 Midpoint X A B ->
 Perp O X A B.
Proof.
exact mid_onc2__perp.
Qed.

Lemma prop_3_2 : forall O P A B X,
 O<>X -> A<>B ->
 Col A B X ->
 OnCircle A O P ->
 OnCircle B O P ->
 Perp O X A B ->
 Midpoint X A B.
Proof.
exact col_onc2_perp__mid.
Qed.

(** * Proposition 4
If in a circle two straight lines cut one another which are not through the center, they do not bisect one another.
        *)

Lemma prop_4 : forall O P A B C D X, B <> C -> A <> B ->
 OnCircle A O P ->
 OnCircle B O P ->
 OnCircle C O P ->
 OnCircle D O P ->
 Midpoint X A C ->
 Midpoint X B D ->
 X = O.
Proof.
exact mid2_onc4__eq.
Qed.

(** * Proposition 5
If two circles cut one another, they will not have the same center.
        *)

Lemma prop_5 :  forall A B C D,
 InterCC A B C D ->
 A <> C.
Proof.
exact intercc__neq.
Qed.

(** * Proposition 6
If two circles touch one another, they will not have the same center.
        *)

Lemma prop_6: forall A B C D,
 A <> B ->
 TangentCC A B C D ->
 A <> C.
Proof.
exact tangentcc__neq.
Qed.

(** * Proposition 9
If a point is taken within a circle, and more than two equal straight lines fall from the point on the circle, the point taken is the center of the circle.
       *)

Lemma prop_9 : forall O P X A B C, A <> B -> A <> C -> B <> C ->
  OnCircle A O P ->
  OnCircle B O P ->
  OnCircle C O P ->
  Cong X A X B ->
  Cong X A X C ->
  X = O.
Proof.
exact cong2_onc3__eq.
Qed.

(** * Proposition 11
If two circles touch one another internally, and their centers are taken, the straight line joining their centers, being produced, will fall on the point of contact of the circles.
       *)

(** * Proposition 12
If two circles touch one another externally, the straight line joining their centers will pass through the point of contact.
       *)

(** In our formalization we do not need to distinguish between
    the two kinds of tangency. *)

Lemma prop_11_12 : forall A B C D X,
 TangentCC A B C D ->
 OnCircle X A B ->
 OnCircle X C D ->
 Col X A C.
Proof.
exact TangentCC_Col.
Qed.

(** * Proposition 18
If a straight line touches a circle, and a straight line is joined from the center to the point of contact, the straight line so joined will be perpendicular to the tangent.
*)

Lemma prop_18 :
forall A B O P T,
 O <> P ->
 TangentAt A B O P T ->
 Perp A B O T.
Proof.
exact tangentat_perp.
Qed.

End Book_3.


Require Import Utf8.
Require Import List.
Require Import PeanoNat.

Fixpoint get {A : Type} (i : nat) (l : list A): option A :=
  match l, i with
  | x :: _ , O    => Some x
  | _ :: xs, S i' => get i' xs
  | _      , _    => None
  end.

Fixpoint delete {A : Type} (i : nat) (G : list A) :=
  match i, G with
  | _   , nil   => nil
  | O   , x::xs => xs
  | S i', x::xs => x :: delete i' xs
  end.

Fixpoint insert {A : Type} (i : nat) (a : A) (G : list A) :=
  match i, G with
  | _   , nil   => a::nil
  | O   , xs    => a::xs
  | S i', x::xs => x::insert i' a xs
  end.

Fixpoint list_replace {A : Type} (i : nat) (a : A) (G : list A) :=
  match i, G with
  | _   , nil   => nil
  | O   , x::xs => a::xs
  | S i', x::xs => x::list_replace i' a xs
  end.

Lemma get_nil : forall A n (T: A),
  ~(get n nil = Some T).
Proof.
  unfold not; intros.
  destruct n; simpl in *; discriminate.
Qed.

Lemma get_length : forall A (G : list A) n x,
  get n G = Some x -> n < length G.
Proof.
  intros.
  generalize dependent x.
  generalize dependent n.
  induction G; intros; simpl in *.
  - destruct n; simpl in *; discriminate.
  - destruct n; simpl in *. apply Nat.lt_0_succ.
    rewrite <- Nat.succ_lt_mono. apply IHG with x; auto.
Qed.

Lemma delete_rewind : ∀ {A : Type} (Γ : list A) (t : A) i,
  t :: delete i Γ = delete (S i) (t :: Γ).
Proof.
  auto.
Qed.

Lemma insert_rewind : ∀ {A : Type} (Γ : list A) (t : A) i T1 T2,
  T1 :: insert i T2 Γ = insert (S i) T2 (T1 :: Γ).
Proof.
  auto.
Qed.

Lemma delete_lt : forall {A : Type} (Γ : list A) T i n,
  get i Γ = Some T →
  i < n →
  get i (delete n Γ) = Some T.
Proof with eauto.
  intros.
  generalize dependent i. generalize dependent n.
  induction Γ; intros...
  - apply get_length in H. apply Nat.nlt_0_r in H. exfalso...
  - destruct i.
    + simpl in H. simpl. destruct n.
      * apply Nat.nlt_0_r in H0. exfalso...
      * auto.
    + simpl. destruct n.
      * apply Nat.nlt_0_r in H0. exfalso...
      * simpl in *. apply IHΓ... rewrite Nat.succ_lt_mono...
Qed.

Lemma delete_gt : ∀ {A : Type} (Γ : list A) T i n,
  get (S n) Γ = Some T →
  i < S n →
  get n (delete i Γ) = Some T.
Proof with eauto.
  intros.
  generalize dependent i. generalize dependent n.
  induction Γ; intros...
  - inversion H.
  - destruct i; simpl.
    + inversion H...
    + destruct n.
      * inversion H0. inversion H2.
      * simpl. apply IHΓ... rewrite Nat.succ_lt_mono...
Qed.

Lemma insert_shift : ∀ {A : Type} (G : list A) i j t T,
  j <= i →
  get i G = Some T →
  get (S i) (insert j t G) = Some T.
Proof.
  intros.
  generalize dependent i. generalize dependent j.
  induction G; intros.
  - destruct j; simpl; auto.
  - simpl. destruct j; simpl; auto.
    destruct i. inversion H.
    assert (get (S i) (a :: G) = get i G). auto.
    apply IHG. apply Nat.succ_le_mono; auto. simpl in H0; auto.
Qed.

Lemma insert_noshift : ∀ {A : Type} (G : list A) i j t T,
  j < i →
  get j G = Some T →
  get j (insert i t G) = Some T.
Proof with eauto.
  intros.
  generalize dependent j.
  generalize dependent G.
  induction i; intros...
  - inversion H.
  - destruct G. apply get_nil in H0. exfalso...
    simpl. destruct j; simpl in *...
    + apply IHi; try apply Nat.succ_lt_mono...
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


From Coq Require Import List.

Require Export init.

Import EqNotations.

(* Universe definition. *)

Inductive kind : Type :=
  | Ty : kind
  | F  : kind -> kind -> kind.

Fixpoint decodeKind (k : kind) : Type :=
  match k with
  | Ty => Type
  | F k1 k2 => decodeKind k1 -> decodeKind k2
  end.

(* Constants that are indexed by kinds. *)
Inductive const : kind -> Type :=
  | Nat : const Ty
  | Unit : const Ty
  | Sum : const (F Ty (F Ty Ty))
  | Prod : const (F Ty (F Ty Ty)).

Fixpoint decodeConst (k : kind) (c : const k) : decodeKind k :=
  match c in const k return decodeKind k with
  | Nat => nat
  | Unit => unit
  | Sum => sum
  | Prod => prod
  end.

(* Context for kinds. *)
Definition ctx : Type := list kind.

(* type variables *)
Inductive tyvar : ctx -> kind -> Type :=
  | Vz : forall G k, tyvar (k :: G) k
  | Vs : forall G k k', tyvar G k -> tyvar (k' :: G) k.

(* case for dependent destruction on tyvar,
   needed for proof of 'nlookup' in generic.v *)
Lemma tvcase :
  forall G k k' (P : tyvar (k' :: G) k -> Type),
  (forall (pf : k=k'), P (rew [fun x:kind => tyvar (x :: G) k] pf in Vz)) ->
  (forall x, P (Vs x)) ->
  forall x, P x.
  Proof.
    intros.
    refine
    (match x as x' in tyvar (k0 :: G0) k1
    return forall (pk' : k0 = k') (pk : k1 = k) (pg : G0 = G),
    rew [fun x : kind => tyvar (x :: _) k] pk' in
    rew [fun x' : kind => tyvar (_ :: _) x'] pk in
    rew [fun g : ctx => tyvar (_ :: g) _] pg in
    x' = x
    -> P x
    with
    | Vz => _
    | Vs _ => _
    end eq_refl eq_refl eq_refl eq_refl).
    - intros. subst. apply X.
    - intros. subst. simpl. apply (X0 t).
  Defined.

(* Datatype for representing types. *)
Inductive typ : ctx -> kind -> Type :=
  | Var : forall G k, tyvar G k -> typ G k
  | Lam : forall G k1 k2, typ (k1 :: G) k2 -> typ G (F k1 k2)
  | App : forall G k1 k2, typ G (F k1 k2) -> typ G k1 -> typ G k2
  | Con : forall G k, const k -> typ G k.

(* Type in an empty context *)
Definition ty : kind -> Type :=
  typ nil.

(* Environment for kinds. *)
Inductive env : list kind -> Type :=
  | enil : env nil
  | econs : forall k G, decodeKind k -> env G -> env (k :: G).

Definition envtl (k : kind) (G : ctx) (en : env (k :: G)) : env G :=
  match en with
  | econs _ G' => G'
  end.

(* lookup a type from env *)
Fixpoint slookup (k : kind) (G : ctx) (tv : tyvar G k) : env G -> decodeKind k :=
  match tv in tyvar G k return env G -> decodeKind k with
  | Vz => fun env =>
                 match env in env G with
                 | econs v G => v
                 end
  | Vs x => fun env => slookup x (envtl env)
  end.

Fixpoint decodeType (k : kind) (G : ctx) (t : typ G k) : env G -> decodeKind k :=
  match t in typ G k return env G -> decodeKind k with
  | Var x => fun e =>
                   slookup x e
  | Lam t1 => fun e =>
                      fun y => decodeType t1 (econs y e)
  | App t1 t2 => fun e =>
                         (decodeType t1 e) (decodeType t2 e)
  | Con c => fun e =>
                   decodeConst c
  end.

(* decode a closed type *)
Definition decodeClosed (k : kind)
  : ty k -> decodeKind k :=
  fun t => decodeType t enil.


(**
Projeto em Coq da disciplina de Tópicos Avançados em Engenharia de Software do CIn/UFPE
Objetivo: provar corretude do Algoritmo RSA
Autores: Emmanuel Carreira Alves
         Lucas Geraldo Cilento
*)

Require Import Notations Logic Datatypes.
Require Import Logic.
Require Import Coq.Init.Nat.
Local Open Scope nat_scope.
Require Setoid.
Require Import PeanoNat Le Gt Minus Bool Lt.

Set Implicit Arguments.
Open Scope list_scope.
Module ListNotations.
Notation "[ ]" := nil (format "[ ]") : list_scope.
Notation "[ x ]" := (cons x nil) : list_scope.
Notation "[ x ; y ; .. ; z ]" := (cons x (cons y .. (cons z nil) ..)) : list_scope.
End ListNotations.

Import ListNotations.
Require Import NZAxioms NZMulOrder Bool NAxioms NSub NParity NZPow.
Require Import ZArith_base.
Require Import ZArithRing.
Require Import Zcomplements.
Require Import Zdiv.
Require Import Wf_nat.
Require Import Omega.

Fixpoint verificaCoPrimos (n1 n2: nat) : bool :=
   match gcd n1 n2 with
     | 1 => true
     | _ => false
     end.

Fixpoint criaListaNumericaSemZero (n: nat): list nat :=
  match n with
  | O => nil
  | S n' => S n' :: criaListaNumericaSemZero n'
  end.

Fixpoint verificaListaCoPrimos (n : nat) (l : list nat) : list bool :=
  match l with
  | nil => nil
  | h :: t =>  verificaCoPrimos n h ::  verificaListaCoPrimos n t
  end.

Fixpoint fold_bool (l:list bool) : bool :=
  match l with
    | nil => true
    | h :: t => h && fold_bool t
  end.

Fixpoint filter_bool (l:list bool) (b: bool) : list bool :=
  match l with
  | nil => nil
  | h :: t => match eqb h b with
              | true => h :: filter_bool t b
              | false => filter_bool t b
              end
  end.

Fixpoint verificaPrimo (n: nat) : bool :=
  match n with
  | O => false
  | 1 => false
  | _ => fold_bool  (verificaListaCoPrimos n (criaListaNumericaSemZero (sqrt n)))
  end.

Fixpoint totiente (n : nat)  : nat :=
  length(filter_bool(verificaListaCoPrimos n (criaListaNumericaSemZero (n - 1))) true).

Fixpoint determinaE (n index : nat) : nat :=
  match  index with
  | O => O
  | 1 => O
  | S n' => match verificaCoPrimos n (S n') with
            | true => S n'
            | false => determinaE n n'
            end
   end.

Definition constroiChavePublica (n : nat) : nat*nat :=
  (n,determinaE (totiente n) (sqrt n)).

Definition divisao (n m q r : nat) : Prop := r < m /\ n = q * m + r.

Definition encriptaNumero (m n e: nat): nat := (m ^ e) mod n.

Definition decriptaNumero (c n d: nat): nat := (c ^ d) mod n.

Definition divide x y := exists z, y = z * x.

Notation "( x | y )" := (divide x y) (at level 0) : nat_scope.


From Undecidability.L.Tactics Require Export LClos.
Require Import FunInd.
Open Scope LClos.

(* *** Closure calculus interpreter *)

Definition CompBeta s t :=
  match s,t with
    |CompClos (lam ls) A,CompClos (lam lt) B => Some (CompClos ls (CompClos (lam lt) B::A))
    |_,_ => None
  end.

Definition CompAppCount j u v :=
  match u,v with
    (l,u),(k,v) => (j+(l+k),CompApp u v)
  end.

Fixpoint CompSeval n (u: nat * Comp) : nat * Comp:=
  match n with
      S n =>
      match u with
        | (l,CompApp s t) =>
          match CompBeta s t with
            | Some u => CompSeval n (S l,u)
            | None => CompSeval n (CompAppCount l (CompSeval n (0,s)) (CompSeval n (0,t)))
          end
        | (l,CompClos (app s t) A) => CompSeval n (l,(CompClos s A) (CompClos t A))
        | (l,CompClos (var x) A) => (l,nth x A (CompVar x))
        | u => u
      end
    | _ => u
  end.

Lemma CompBeta_validComp s t u: validComp s -> validComp t -> CompBeta s t = Some u -> validComp u.
Proof with repeat (auto || congruence || subst || simpl in * || intuition).
  intros vs vt eq. inv vs; inv vt... destruct s0... destruct s,s0... inv eq. repeat constructor... inv H1...
Qed.
(*
Lemma CompBeta_lamComp s t u: CompBeta s t = Some u -> (lamComp s /\ lamComp t).
Proof with repeat (auto || congruence || subst || simpl in.
  unfold CompBeta. intros equ. destruct s,t... destruct s... destruct s... destruct s,s0...
Qed.

Lemma CompBeta_lamComp2 s t: CompBeta s t = None -> (~lamComp s \/ ~lamComp t).
Proof with repeat inv_validComp;try (intros ?;repeat inv_validComp).
  unfold CompBeta. intros equ. destruct s,t;try now left... right... destruct s. left... left... destruct s0... right... right... congruence.
Qed.
*)
Lemma CompSeval_validComp s k n: validComp s -> validComp (snd (CompSeval n (k,s))).
Proof with repeat (apply validCompApp ||apply validCompClos || eauto || congruence || subst || simpl in * || intuition).
  revert s k. induction n; intros s k vs... inv vs...
  case_eq (CompBeta s0 t);intros...
  -apply CompBeta_validComp in H1...
  -assert (IHn1 := IHn s0 0 H). assert (IHn2 := IHn t 0 H0).
   unfold snd in *. do 2 destruct ((CompSeval n (_,_)))...
  -destruct s0...
Qed.

Hint Resolve CompSeval_validComp : core.

Lemma CompBeta_sound s t u: CompBeta s t = Some u -> s t >[(1)] u.
Proof with repeat (auto || congruence || subst || simpl in * || intuition).
  intros eq. destruct s,t... destruct s... destruct s... destruct s... destruct s0... inv eq. repeat constructor...
Qed.

Functional Scheme CompSeval_ind := Induction for CompSeval Sort Prop.

Lemma CompSeval_sound' n s l : let (k,t) := CompSeval n (l,s) in k >= l /\ s >[(k-l)] t.
Proof with (repeat inv_validComp;repeat (constructor || intuition|| subst ; eauto using star || rewrite Nat.sub_diag||cbn in *)).
  pose (p:= (l,s)).
  change (let (k, t) := CompSeval n p in k >= fst p /\ (snd p) >[(k-(fst p))] t).
  generalize p. clear l s p. intros p.
  functional induction (CompSeval n p); intros;cbn...
  -apply CompBeta_sound in e2. destruct (CompSeval _ _);split... eapply CPow_trans;try  eassumption. lia.
  -repeat destruct (CompSeval _ _)... eapply CPow_trans...
  -repeat destruct (CompSeval _ _)... eapply CPow_trans...
Qed.

Lemma CompSeval_sound (n k:nat) s t : CompSeval n (0,s) = (k,t) -> s >[(k)] t.
Proof.
  specialize (CompSeval_sound' n s 0). destruct _;intros.
  inv H0. rewrite <- minus_n_O in H. tauto.
Qed.


(* NIZK Proof System - Field Fp = Z/pZ defintion and properties by Rémi Bazin *)

Load utils.

(* Primery group order *)
Variable p : nat.

Hypothesis p_prime : Is_prime p.

Lemma p_big : 2 <= p.
Proof.
  pose (p_prime := p_prime).
  unfold Is_prime in p_prime.
  inversion p_prime.
  exact H.
Qed.

Lemma p_is_not_null : p <> 0.
Proof.
  intro H.
  pose (p_big := p_big).
  rewrite H in p_big.
  pose (wrong := le_Sn_0 1 p_big).
  case wrong.
Qed.

(* Definition of Fp and its main elements *)
Inductive Fp : Set := | ConstrFp : forall x:nat, (x<p -> Fp).

Delimit Scope Fp_scope with Fp.

Definition Fp_0 : Fp :=
  ConstrFp 0 (le_trans 1 2 p (le_S 1 1 (le_n 1)) p_big).
Definition Fp_1 : Fp := ConstrFp 1 p_big.

Definition Fp_from_nat (n:nat) : Fp :=
  ConstrFp (n mod p) (Nat.mod_upper_bound n p p_is_not_null).

Definition addFp (a b:Fp) : Fp :=
  match a with | ConstrFp v_a p_a =>
    match b with | ConstrFp v_b p_b =>
      ConstrFp ((v_a + v_b) mod p) (Nat.mod_upper_bound (v_a + v_b) p p_is_not_null)
    end
  end
.
Infix "+" := addFp : Fp_scope.

Definition succFp (a:Fp) : Fp := addFp a Fp_1.

Definition multFp (a b:Fp) : Fp :=
  match a with | ConstrFp v_a p_a =>
    match b with | ConstrFp v_b p_b =>
      ConstrFp ((v_a * v_b) mod p) (Nat.mod_upper_bound (v_a * v_b) p p_is_not_null)
    end
  end
.
Infix "*" := multFp : Fp_scope.

(* Mathematical structure properties *)
Remark Fp_equality : forall (n1 n2:nat) (p1:n1<p) (p2:n2<p), n1=n2 -> ConstrFp n1 p1 = ConstrFp n2 p2.
Proof. (* Thanks to Cyprien Mangin for this proof! *)
  intros.
  subst.
  f_equal.
  apply le_unique.
Qed.

Remark Fp_equality2 : forall (n1 n2:nat), Fp_from_nat n1=Fp_from_nat n2 -> n1 mod p=n2 mod p.
Proof.
  intros.
  unfold Fp_from_nat in H.
  inversion H.
  reflexivity.
Qed.

Theorem Fp_0_well_formed : Is_zero Fp addFp Fp_0.
Proof.
  unfold Is_zero, Fp_0, addFp.
  intros.
  destruct a.
  rewrite (plus_O_n x).
  assert (part1 : (x mod p) = x).
    exact (Nat.mod_small x p l).
  exact (Fp_equality (x mod p) x (Nat.mod_upper_bound x p p_is_not_null) l part1).
Qed.

Theorem Fp_associative : Is_associative Fp addFp.
Proof.
  unfold Is_associative.
  intros.
  case a, b, c.
  unfold addFp.
  assert (subg : (x + (x0 + x1) mod p) mod p = ((x + x0) mod p + x1) mod p).
  rewrite (Nat.add_mod_idemp_r x (x0 + x1) p p_is_not_null).
  rewrite (Nat.add_mod_idemp_l (x + x0) x1 p p_is_not_null).
  rewrite (plus_assoc x x0 x1).
  reflexivity.
  exact (Fp_equality _ _ _ _ subg).
Qed.

Theorem Fp_commutative : Is_commutative Fp addFp.
Proof.
  unfold Is_commutative.
  intros.
  case a, b.
  unfold addFp.
  assert (subg : (x + x0) mod p = (x0 + x) mod p).
  rewrite (plus_comm x x0).
  reflexivity.
  exact (Fp_equality _ _ _ _ subg).
Qed.

Theorem Fp_has_inverse : Has_inverse Fp addFp Fp_0.
Proof.
  unfold Has_inverse.
  refine (conj Fp_0_well_formed _).
  intros.
  case a.
  intros.
  refine (ex_intro _ (ConstrFp ((p-x) mod p) (Nat.mod_upper_bound _ p p_is_not_null)) _).
  unfold Fp_0, addFp.
  assert (subg : (x + (p - x) mod p) mod p = 0).
  rewrite (Nat.add_mod_idemp_r x (p-x) p p_is_not_null).
  rewrite <- (le_plus_minus x p (le_S_n x p (le_S (S x) p l))).
  exact (Nat.mod_same p p_is_not_null).
  exact (Fp_equality _ _ _ _ subg).
Qed.

Lemma repeated_addition_Fp : forall (x:nat) (l:x<p) (k m:nat),
    repeat_fn k Fp (fun x0 : Fp => addFp x0 (ConstrFp x l)) (Fp_from_nat m)
    = Fp_from_nat (k * x + m).
Proof.
  intros x l k.
  elim k.
    (* Case k=0 *)
    rewrite (mult_0_l x).
    intro.
    rewrite (plus_O_n m).
    unfold repeat_fn, Fp_0, Fp_from_nat.
    reflexivity.
    (* Case k --> k+1 *)
    intros.
    assert (subg : repeat_fn n Fp (fun x0 : Fp => addFp x0 (ConstrFp x l))
      (addFp (Fp_from_nat m) (ConstrFp x l))
      = Fp_from_nat (S n * x + m)).
    assert (left : addFp (Fp_from_nat m) (ConstrFp x l) = Fp_from_nat (x+m)).
    unfold Fp_from_nat, addFp.
    assert (tmp : (m mod p + x) mod p = (x + m) mod p).
    rewrite (Nat.add_mod_idemp_l m x p p_is_not_null).
    rewrite (plus_comm x m).
    reflexivity.
    exact (Fp_equality _ _ _ _ tmp).
    assert (right : (S n) * x + m = n * x + (x+m)).
    rewrite (mult_succ_l n x).
    rewrite (plus_assoc (n*x) x m).
    reflexivity.
    rewrite left.
    rewrite right.
    exact (H (x+m)).
    unfold repeat_fn.
    exact subg.
Qed.

Theorem Fp_order_atmost_p : Order_atmost_p Fp addFp Fp_0 p.
Proof.
  unfold Order_atmost_p.
  refine (conj Fp_0_well_formed _).
  intros.
  case a.
  intros.
  pose (result := repeated_addition_Fp x l p O).
  rewrite <- (plus_n_O (p*x)) in result.
  assert (subg1 : Fp_from_nat (x * p) = Fp_0).
  unfold Fp_from_nat, Fp_0.
  assert (subg2 : (x*p) mod p=0).
  rewrite (Nat.mod_mul x p p_is_not_null).
  reflexivity.
  exact (Fp_equality _ _ _ _ subg2).
  assert (subg3 : Fp_from_nat O = Fp_0).
  unfold Fp_from_nat, Fp_0.
  assert (subg4 : 0 mod p = 0).
  rewrite (Nat.mod_0_l p p_is_not_null).
  reflexivity.
  exact (Fp_equality _ _ _ _ subg4).
  rewrite (mult_comm p x) in result.
  rewrite subg1 in result.
  rewrite subg3 in result.
  exact result.
Qed.

Theorem Fp_order_atleast_p : Order_atleast_p Fp addFp Fp_0 p.
Proof.
  unfold Order_atleast_p.
  refine (conj Fp_0_well_formed _).
  intros.
  destruct a.
  assert (fp0 : Fp_0 = Fp_from_nat O).
  unfold Fp_0, Fp_from_nat.
  exact (Fp_equality _ _ _ _ (eq_sym (Nat.mod_0_l p p_is_not_null))).
  rewrite fp0.
  intros.
  rewrite (repeated_addition_Fp x l k O).
  unfold Fp_from_nat.
  intro wrong.
  inversion wrong.
  rewrite (Nat.mod_0_l p p_is_not_null) in H2.
  rewrite <- (plus_n_O (k*x)) in H2.
  pose (equiv := Nat.mod_divides (k*x) p p_is_not_null).
  inversion equiv.
  pose (H4 := H1 H2).
  inversion H4.
  pose (Hk := (proj2 p_prime) k H).
  assert (subg : O <> x).
  intro Hfalse.
  unfold Fp_0 in H0.
  case (H0 (Fp_equality _ _ _ _ (eq_sym Hfalse))).
  pose (Hx := (proj2 p_prime) x (conj (neq_0_lt x subg) l)).
  pose (gcdeq := gcd_mult k x p (proj1 H) (neq_0_lt x subg) (neq_0_lt p (not_eq_sym p_is_not_null))).
  rewrite H5, Hk, Hx in gcdeq.
  simpl in gcdeq.
  rewrite (Nat.gcd_comm (p*x0) p) in gcdeq.
  rewrite (Nat.gcd_mul_diag_l p x0 (le_0_n p)) in gcdeq.
  pose (wrong2 := le_trans 2 p 1 (proj1 p_prime) gcdeq).
  case (le_Sn_n 1 wrong2).
Qed.

Fixpoint Fp_lst_increasing (n:nat) : list Fp :=
  match n with
    | O => nil
    | S m => cons (Fp_from_nat m) (Fp_lst_increasing m)
  end
.

Lemma eq_dec_Fp : forall x y : Fp, {x = y} + {x <> y}.
Proof.
  intros.
  destruct x.
  destruct y.
  case (eq_nat_dec x x0).
  intro.
  exact (left (Fp_equality x x0 l l0 e)).
  intro xneq.
  assert (subg : ConstrFp x l <> ConstrFp x0 l0).
  intro Hwrong.
  inversion Hwrong.
  case (xneq H0).
  exact (right subg).
Qed.

Theorem Fp_card : Has_card Fp p.
Proof.
  unfold Has_card.
  refine (conj _ _).
  (* Part 1: Cardinal at least p *)
  refine (ex_intro _ (Fp_lst_increasing p) _).
  refine (conj _ _).
    (* Correct list length *)
    elim p.
    unfold Fp_lst_increasing, length.
    reflexivity.
    intros.
    assert (subg : S (length (Fp_lst_increasing n)) = S n).
    rewrite H.
    reflexivity.
    unfold Fp_lst_increasing, length.
    exact subg.
    (* No duplicates *)
    assert (mainsubg : forall i:nat, i<=p -> NoDup (Fp_lst_increasing i)).
    intro.
    elim i.
    intro useless.
    unfold Fp_lst_increasing.
    constructor.
    intros n recc.
    assert (subg : S n <= p -> NoDup (cons (Fp_from_nat n) (Fp_lst_increasing n))).
    assert (subg2 : S n <= p -> ~ In (Fp_from_nat n) (Fp_lst_increasing n)).
    elim n.
    intro useless.
    unfold Fp_lst_increasing.
    simpl.
    intro.
    case H.
    intros.
    assert (subg : ~ In (Fp_from_nat (S n0)) (cons (Fp_from_nat n0) (Fp_lst_increasing n0))).
    intro.
    destruct H1.
    unfold Fp_from_nat in H1.
    inversion H1.
    pose (H4 := mod_S n0 p (proj1 p_prime)).
    destruct H4.
    rewrite H2 in H3.
    case (n_Sn (n0 mod p) H3).
    rewrite H2 in H3.
    pose (H4 := proj1 (Nat.mod_divides n0 p p_is_not_null) H3).
    destruct H4.
    rewrite H4 in H2.
    rewrite <- (plus_O_n (S (p * x))) in H2.
    rewrite <- (plus_Snm_nSm O (p*x)) in H2.
    rewrite (mult_comm p x) in H2.
    rewrite (Nat.mod_add 1 x p p_is_not_null) in H2.
    rewrite (Nat.mod_small 1 p (proj1 p_prime)) in H2.
    discriminate H2.
    assert (myind : forall k:nat, k<=n0 -> ~In (Fp_from_nat (S n0)) (Fp_lst_increasing k)).
    intro.
    elim k.
    intro useless.
    unfold Fp_lst_increasing.
    exact (in_nil (a:=Fp_from_nat (S n0))).
    intros.
    assert (subg3 : ~ ((Fp_from_nat n1=Fp_from_nat (S n0)) \/
      (In (Fp_from_nat (S n0)) (Fp_lst_increasing n1)))).
    intro wrong1.
    destruct wrong1.
    pose (H5 := Fp_equality2 n1 (S n0) H4).
    rewrite (Nat.mod_small (S n0) p H0) in H5.
    rewrite (Nat.mod_small n1 p (le_trans (S n1) n0 p H3
      (le_Sn_le n0 p (le_Sn_le (S n0) p H0)):S n1<=p)) in H5.
    rewrite H5 in H3.
    case (le_Sn_n (S n0) (le_S (S (S n0)) n0 H3)).
    case (H2 (le_Sn_le n1 n0 H3) H4).
    unfold Fp_lst_increasing, In.
    exact subg3.
    case (myind n0 (le_n n0) H1).
    unfold Fp_lst_increasing.
    exact subg.
    intro cond.
    exact (NoDup_cons (A:=Fp) (Fp_from_nat n) (l:=Fp_lst_increasing n)
      (subg2 cond) (recc (le_Sn_le n p cond))).
    unfold Fp_lst_increasing.
    exact subg.
    exact (mainsubg p (le_n p)).
  (* Part 2: Cardinal at most p *)
  assert (subg : forall k:nat, k<=p -> ~(exists l:list Fp, length l > k /\ NoDup l /\
    (forall e:nat, e<p -> e>=k -> ~ In (Fp_from_nat e) l))).
  intro.
  elim k.
  intros useless abs1.
  destruct abs1.
  destruct H.
  destruct H0.
  destruct x.
  unfold length in H.
  case (lt_irrefl O H).
  destruct f.
  pose (wrong := H1 x0 l (le_0_n x0)).
  unfold In in wrong.
  assert (obv : ConstrFp x0 l = Fp_from_nat x0).
  unfold Fp_from_nat.
  exact (Fp_equality x0 (x0 mod p) l (Nat.mod_upper_bound x0 p p_is_not_null)
    (eq_sym (Nat.mod_small x0 p l))).
  case (wrong (or_introl obv)).
  intros n Hrec Hs Hwrong.
  pose (Hrecs := Hrec (le_Sn_le n p Hs)).
  assert (subg3 : exists l : list Fp,
           length l > n /\
           NoDup l /\
           (forall e : nat, e < p -> e >= n -> ~ In (Fp_from_nat e) l)).
  destruct Hwrong.
  refine (ex_intro _ (remove eq_dec_Fp (Fp_from_nat n) x) _).
  decompose record H.
  case (nodup_rm Fp x (Fp_from_nat n) eq_dec_Fp H2).
  intro nnotinx.
  rewrite (notin_rm Fp x (Fp_from_nat n) eq_dec_Fp nnotinx).
  refine (conj (le_Sn_le (S n) (length x) H0) (conj H2 _)).
  intro e.
  case (eq_nat_dec e n).
  intros.
  rewrite e0.
  exact nnotinx.
  intros.
  case (le_lt_or_eq n e H4).
  exact (H3 e H1).
  intro Hwrong.
  case (n0 (eq_sym Hwrong)).
  intro ninxconj.
  decompose record ninxconj.
  rewrite H8.
  clear H8.
  refine (conj _ (conj _ _)).
  pose (lcmp := app_length x0 (Fp_from_nat n :: x1)).
  rewrite <- H5 in lcmp.
  unfold length in lcmp at 3.
  fold (length x1) in lcmp.
  rewrite <- (plus_n_Sm (length x0) (length x1)) in lcmp.
  rewrite <- (app_length x0 x1) in lcmp.
  rewrite lcmp in H0.
  exact (gt_S_n _ _ H0).
  rewrite H5 in H2.
  exact (NoDup_remove_1 x0 x1 (Fp_from_nat n) H2).
  intro e.
  case (eq_nat_dec e n).
  intros.
  rewrite e0.
  intro Hwrong.
  case (in_app_or x0 x1 (Fp_from_nat n) Hwrong).
  exact H4.
  exact H6.
  intros.
  case (le_lt_or_eq n e H8).
  intros H9 Hwrong1.
  rewrite H5 in H3.
  case (in_app_or x0 x1 (Fp_from_nat e) Hwrong1).
  intro Hwrong2.
  case (H3 e H7 H9 (in_or_app x0 (Fp_from_nat n :: x1) (Fp_from_nat e) (or_introl Hwrong2))).
  intro Hwrong2.
  assert (Hwrong3 : In (Fp_from_nat e) ((Fp_from_nat n)::x1)).
  unfold In.
  exact (or_intror Hwrong2).
  case (H3 e H7 H9 (in_or_app x0 (Fp_from_nat n :: x1) (Fp_from_nat e) (or_intror Hwrong3))).
  intro Hwrong.
  case (n0 (eq_sym Hwrong)).
  case (Hrecs subg3).
  pose (test := subg p (le_n p)).
  intro.
  assert (subg2 : exists l : list Fp,
          length l > p /\
          NoDup l /\
          (forall e : nat, e < p -> e >= p -> ~ In (Fp_from_nat e) l)).
  destruct H.
  destruct H.
  refine (ex_intro _ x _).
  refine (conj _ (conj _ _)).
  exact H.
  exact H0.
  intros.
  unfold ge in H2.
  case (le_not_lt p e H2 H1).
  case (test subg2).
Qed.

Theorem Fp_well_formed : Is_Fp_isomorphic Fp addFp p.
Proof.
  unfold Is_Fp_isomorphic.
  refine (ex_intro _ Fp_0 _).
  refine (conj _ (conj _ (conj _ (conj _ (conj _ (conj _ (conj _ _))))))).
  exact Fp_associative.
  exact Fp_commutative.
  exact Fp_0_well_formed.
  exact Fp_has_inverse.
  exact p_prime.
  exact Fp_order_atmost_p.
  exact Fp_order_atleast_p.
  exact Fp_card.
Qed.

(* Utility properties inspired from the nat library *)
Open Scope Fp_scope.

Lemma Fp_plus_n_O : forall n, n = n+Fp_0.
Proof.
  intro.
  case n.
  intros.
  unfold Fp_0, addFp.
  assert (subg : x = (x+0) mod p).
  rewrite <- (plus_n_O x).
  exact (eq_sym (Nat.mod_small x p l)).
  exact (Fp_equality _ _ _ _ subg).
Qed.

Lemma Fp_plus_O_n : forall n, Fp_0+n = n.
Proof.
  intro.
  case n.
  intros.
  unfold Fp_0, addFp.
  assert (subg : (0+x) mod p = x).
  rewrite (plus_O_n x).
  exact (Nat.mod_small x p l).
  exact (Fp_equality _ _ _ _ subg).
Qed.

Lemma Fp_plus_comm : forall n m, n+m = m+n.
Proof.
  intros.
  case n, m.
  unfold addFp.
  assert (subg : (x+x0) mod p = (x0+x) mod p).
  rewrite (plus_comm x x0).
  reflexivity.
  exact (Fp_equality _ _ _ _ subg).
Qed.

Lemma Fp_plus_assoc : forall n m p, n+(m+p) = n+m+p.
Proof.
  intros.
  case n, m, p0.
  unfold addFp.
  assert (subg : (x + (x0 + x1) mod p) mod p = ((x + x0) mod p + x1) mod p).
  rewrite (Nat.add_mod_idemp_r x (x0+x1) p p_is_not_null).
  rewrite (Nat.add_mod_idemp_l (x+x0) x1 p p_is_not_null).
  rewrite (plus_assoc x x0 x1).
  reflexivity.
  exact (Fp_equality _ _ _ _ subg).
Qed.

Lemma Fp_plus_permute : forall n m p, n + (m + p) = m + (n + p).
Proof.
  intros.
  case n, m, p0.
  unfold addFp.
  refine (Fp_equality _ _ _ _ _).
  rewrite (Nat.add_mod_idemp_r x (x0+x1) p p_is_not_null).
  rewrite (Nat.add_mod_idemp_r x0 (x+x1) p p_is_not_null).
  rewrite (plus_permute x x0 x1).
  reflexivity.
Qed.

Lemma Fp_plus_assoc_reverse : forall n m p, n + m + p = n + (m + p).
Proof.
  intros.
  case n, m, p0.
  unfold addFp.
  refine (Fp_equality _ _ _ _ _).
  rewrite (Nat.add_mod_idemp_r x (x0+x1) p p_is_not_null).
  rewrite (Nat.add_mod_idemp_l (x+x0) x1 p p_is_not_null).
  rewrite (plus_assoc x x0 x1).
  reflexivity.
Qed.

Lemma Fp_plus_reg_l : forall n m p, p + n = p + m -> n = m.
Proof.
  admit.
Qed.

Lemma Fp_n_Sn : forall n, n <> n + Fp_1.
Proof.
  intro.
  destruct n.
  unfold Fp_1, addFp.
  intro wrong.
  inversion wrong.
  pose (tmp := mod_S x p (proj1 p_prime)).
  rewrite (plus_n_O (S x)) in tmp.
  rewrite (plus_Snm_nSm x O) in tmp.
  destruct tmp.
  rewrite H in H0.
  rewrite (Nat.mod_small x p l) in H0.
  case (n_Sn x H0).
  pose (tmp := proj1 (Nat.mod_divides (x+1) p p_is_not_null) H).
  destruct tmp.
  case_eq x0.
  intro wrong2.
  rewrite wrong2 in H1.
  rewrite (mult_0_r p) in H1.
  discriminate (proj2 (plus_is_O x 1 H1)).
  intros.
  case_eq n.
  admit.
  intros.
  rewrite H2 in H1.
  rewrite (mult_succ_r p n) in H1.
  rewrite H3 in H1.
  rewrite (mult_succ_r p n0) in H1.
  pose (l2 := l).
  unfold lt in l2.
  rewrite (plus_n_O (S x)) in l2.
  rewrite (plus_Snm_nSm x O) in l2.
  rewrite H1 in l2.
  rewrite (plus_comm (p * n0 + p) p) in l2.
  rewrite (plus_n_O p) in l2 at 4.
  pose (l3 := le_trans (p*n0+p) O (p*n0) (plus_le_reg_l (p*n0+p) O p l2) (le_0_n (p*n0))).
  rewrite (plus_n_O (p*n0)) in l3 at 2.
  pose (l4 := le_n_0_eq p (plus_le_reg_l p O (p*n0) l3)).
  case (p_is_not_null (eq_sym l4)).
Qed.

Lemma Fp_plus_le_reg_l : forall n m p, p + n <= p + m -> n <= m.
Proof.
  admit.
Qed.

Lemma Fp_plus_le_reg_l : forall n m p, p + n <= p + m -> n <= m.
Proof.
  admit.
Qed.

Lemma Fp_plus_le_reg_l : forall n m p, p + n <= p + m -> n <= m.
Proof.
  admit.
Qed.

Lemma Fp_plus_le_reg_l : forall n m p, p + n <= p + m -> n <= m.
Proof.
  admit.
Qed.

Lemma Fp_plus_le_reg_l : forall n m p, p + n <= p + m -> n <= m.
Proof.
  admit.
Qed.

Lemma Fp_plus_le_reg_l : forall n m p, p + n <= p + m -> n <= m.
Proof.
  admit.
Qed.

Close Scope Fp_scope.


Require Export Crypto.Spec.ModularArithmetic.
Require Export Crypto.Arithmetic.ModularArithmeticTheorems.
Require Export Coq.setoid_ring.Ring_theory Coq.setoid_ring.Field_theory Coq.setoid_ring.Field_tac.

Require Import Coq.nsatz.Nsatz.
Require Import Crypto.Arithmetic.ModularArithmeticPre.
Require Import Crypto.Util.NumTheoryUtil.
Require Import Coq.Classes.Morphisms Coq.Setoids.Setoid.
Require Import Coq.ZArith.BinInt Coq.NArith.BinNat Coq.ZArith.ZArith Coq.ZArith.Znumtheory Coq.NArith.NArith. (* import Zdiv before Znumtheory *)
Require Import Coq.Logic.Eqdep_dec.
Require Import Crypto.Util.NumTheoryUtil Crypto.Util.ZUtil.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Decidable.
Require Export Crypto.Util.FixCoqMistakes.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Crypto.Algebra.Hierarchy Crypto.Algebra.Field.

Existing Class prime.
Local Open Scope F_scope.

Module F.
  Section Field.
    Context (q:positive) {prime_q:prime q}.
    Lemma inv_spec : F.inv 0%F = (0%F : F q)
                     /\ (prime q -> forall x : F q, x <> 0%F -> (F.inv x * x)%F = 1%F).
    Proof using Type. change (@F.inv q) with (proj1_sig (@F.inv_with_spec q)); destruct (@F.inv_with_spec q); eauto. Qed.

    Lemma inv_0 : F.inv 0%F = F.of_Z q 0. Proof using Type. destruct inv_spec; auto. Qed.
    Lemma inv_nonzero (x:F q) : (x <> 0 -> F.inv x * x%F = 1)%F. Proof using Type*. destruct inv_spec; auto. Qed.

    Global Instance field_modulo : @Algebra.Hierarchy.field (F q) Logic.eq 0%F 1%F F.opp F.add F.sub F.mul F.inv F.div.
    Proof using Type*.
      repeat match goal with
             | _ => solve [ solve_proper
                          | apply F.commutative_ring_modulo
                          | apply inv_nonzero
                          | cbv [F.zero F.one not]; pose proof prime_ge_2 q prime_q;
                            rewrite F.eq_to_Z_iff, !F.to_Z_of_Z, !Zmod_small; omega ]
             | _ => split
             end.
    Qed.
  End Field.

  Section NumberThoery.
    Context {q:positive} {prime_q:prime q} {two_lt_q: 2 < q}.

    (* TODO: move to PrimeFieldTheorems *)
    Lemma to_Z_1 : @F.to_Z q 1 = 1%Z.
    Proof using two_lt_q. simpl. rewrite Zmod_small; omega. Qed.

    Lemma Fq_inv_fermat (x:F q) : F.inv x = x ^ Z.to_N (q - 2)%Z.
    Proof using Type*.
      destruct (dec (x = 0%F)) as [?|Hnz].
      { subst x; rewrite inv_0, F.pow_0_l; trivial.
        change (0%N) with (Z.to_N 0%Z); rewrite Z2N.inj_iff; omega. }
      erewrite <-Algebra.Field.inv_unique; try reflexivity.
      rewrite F.eq_to_Z_iff, F.to_Z_mul, F.to_Z_pow, Z2N.id, to_Z_1 by omega.
      apply (fermat_inv q _ (F.to_Z x)); rewrite F.mod_to_Z; eapply F.to_Z_nonzero; trivial.
    Qed.

    Lemma euler_criterion (a : F q) (a_nonzero : a <> 0) :
      (a ^ (Z.to_N (q / 2)) = 1) <-> (exists b, b*b = a).
    Proof using Type*.
      pose proof F.to_Z_nonzero_range a; pose proof (odd_as_div q).
      specialize_by (destruct (Z.prime_odd_or_2 _ prime_q); try omega; trivial).
      rewrite F.eq_to_Z_iff, !F.to_Z_pow, !to_Z_1, !Z2N.id by omega.
      rewrite F.square_iff, <-(euler_criterion (q/2)) by (trivial || omega); reflexivity.
    Qed.

    Global Instance Decidable_square : forall (x:F q), Decidable (exists y, y*y = x).
    Proof.
      intro x; destruct (dec (x = 0)).
      { left. abstract (exists 0; subst; apply Ring.mul_0_l). }
      { eapply Decidable_iff_to_impl; [eapply euler_criterion; assumption | exact _]. }
    Defined.
  End NumberThoery.

  Section SquareRootsPrime3Mod4.
    Context {q:positive} {prime_q: prime q} {q_3mod4 : q mod 4 = 3}.

    Add Field _field2 : (Algebra.Field.field_theory_for_stdlib_tactic(T:=F q))
                          (morphism (F.ring_morph q),
                           constants [F.is_constant],
                           div (F.morph_div_theory q),
                           power_tac (F.power_theory q) [F.is_pow_constant]).

    Definition sqrt_3mod4 (a : F q) : F q := a ^ Z.to_N (q / 4 + 1).

    Global Instance Proper_sqrt_3mod4 : Proper (eq ==> eq ) sqrt_3mod4.
    Proof using Type. repeat intro; subst; reflexivity. Qed.

    Lemma two_lt_q_3mod4 : 2 < q.
    Proof using Type*.
      pose proof (prime_ge_2 q _) as two_le_q.
      destruct (Zle_lt_or_eq _ _ two_le_q) as [H|H]; [exact H|].
      rewrite <-H in q_3mod4; discriminate.
    Qed.
    Local Hint Resolve two_lt_q_3mod4.

    Lemma sqrt_3mod4_correct (x:F q) :
      ((exists y, y*y = x) <-> (sqrt_3mod4 x)*(sqrt_3mod4 x) = x)%F.
    Proof using Type*.
      cbv [sqrt_3mod4]; intros.
      destruct (F.eq_dec x 0);
      repeat match goal with
             | |- _ => progress subst
             | |- _ => progress rewrite ?F.pow_0_l, <-?F.pow_add_r
             | |- _ => progress rewrite <-?Z2N.inj_0, <-?Z2N.inj_add by zero_bounds
             | |- _ => rewrite <-@euler_criterion by auto
             | |- ?x ^ (?f _) = ?a <-> ?x ^ (?f _) = ?a => do 3 f_equiv; [ ]
             | |- _ => rewrite !Zmod_odd in *; repeat (break_match; break_match_hyps); omega
             | |- _ => rewrite Z.rem_mul_r in * by omega
             | |- (exists x, _) <-> ?B => assert B by field; solve [intuition eauto]
             | |- (?x ^ Z.to_N ?a = 1) <-> _ =>
               transitivity (x ^ Z.to_N a * x ^ Z.to_N 1 = x);
                 [ rewrite F.pow_1_r, Algebra.Field.mul_cancel_l_iff by auto; reflexivity | ]
             | |- (_ <> _)%N => rewrite Z2N.inj_iff by zero_bounds
             | |- (?a <> 0)%Z => assert (0 < a) by zero_bounds; omega
             | |- (_ = _)%Z => replace 4 with (2 * 2)%Z in * by ring;
                                 rewrite <-Z.div_div by zero_bounds;
                                 rewrite Z.add_diag, Z.mul_add_distr_l, Z.mul_div_eq by omega
             end.
    Qed.
  End SquareRootsPrime3Mod4.

  Section SquareRootsPrime5Mod8.
    Context {q:positive} {prime_q: prime q} {q_5mod8 : q mod 8 = 5}.
    Local Open Scope F_scope.
    Add Field _field3 : (Algebra.Field.field_theory_for_stdlib_tactic(T:=F q))
                          (morphism (F.ring_morph q),
                           constants [F.is_constant],
                           div (F.morph_div_theory q),
                           power_tac (F.power_theory q) [F.is_pow_constant]).

    (* Any nonsquare element raised to (q-1)/4 (real implementations use 2 ^ ((q-1)/4) )
       would work for sqrt_minus1 *)
    Context (sqrt_minus1 : F q) (sqrt_minus1_valid : sqrt_minus1 * sqrt_minus1 = F.opp 1).

    Lemma two_lt_q_5mod8 : 2 < q.
    Proof using prime_q q_5mod8.
      pose proof (prime_ge_2 q _) as two_le_q.
      destruct (Zle_lt_or_eq _ _ two_le_q) as [H|H]; [exact H|].
      rewrite <-H in *. discriminate.
    Qed.
    Local Hint Resolve two_lt_q_5mod8.

    Definition sqrt_5mod8 (a : F q) : F q :=
      let b := a ^ Z.to_N (q / 8 + 1) in
      if dec (b ^ 2 = a)
      then b
      else sqrt_minus1 * b.

    Global Instance Proper_sqrt_5mod8 : Proper (eq ==> eq ) sqrt_5mod8.
    Proof using Type. repeat intro; subst; reflexivity. Qed.

    Lemma eq_b4_a2 (x : F q) (Hex:exists y, y*y = x) :
      ((x ^ Z.to_N (q / 8 + 1)) ^ 2) ^ 2 = x ^ 2.
    Proof using prime_q q_5mod8.
      pose proof two_lt_q_5mod8.
      assert (0 <= q/8)%Z by (apply Z.div_le_lower_bound; rewrite ?Z.mul_0_r; omega).
      assert (Z.to_N (q / 8 + 1) <> 0%N) by
          (intro Hbad; change (0%N) with (Z.to_N 0%Z) in Hbad; rewrite Z2N.inj_iff in Hbad; omega).
      destruct (dec (x = 0)); [subst; rewrite !F.pow_0_l by (trivial || lazy_decide); reflexivity|].
      rewrite !F.pow_pow_l.

      replace (Z.to_N (q / 8 + 1) * (2*2))%N with (Z.to_N (q / 2 + 2))%N.
      Focus 2. { (* this is a boring but gnarly proof :/ *)
        change (2*2)%N with (Z.to_N 4).
        rewrite <- Z2N.inj_mul by zero_bounds.
        apply Z2N.inj_iff; try zero_bounds.
        rewrite <- Z.mul_cancel_l with (p := 2) by omega.
        ring_simplify.
        rewrite Z.mul_div_eq by omega.
        rewrite Z.mul_div_eq by omega.
        rewrite (Zmod_div_mod 2 8 q) by
            (try omega; apply Zmod_divide; omega || auto).
        rewrite q_5mod8.
        replace (5 mod 2)%Z with 1%Z by auto.
        ring.
      } Unfocus.

      rewrite Z2N.inj_add, F.pow_add_r by zero_bounds.
      replace (x ^ Z.to_N (q / 2)) with (F.of_Z q 1) by
          (symmetry; apply @euler_criterion; eauto).
      change (Z.to_N 2) with 2%N; ring.
    Qed.

    Lemma mul_square_sqrt_minus1 : forall x, sqrt_minus1 * x * (sqrt_minus1 * x) = F.opp (x * x).
    Proof using prime_q sqrt_minus1_valid.
      intros x.
      transitivity (F.opp 1 * (x * x)); [ | field].
      rewrite <-sqrt_minus1_valid.
      field.
    Qed.

    Lemma eq_b4_a2_iff (x : F q) : x <> 0 ->
      ((exists y, y*y = x) <-> ((x ^ Z.to_N (q / 8 + 1)) ^ 2) ^ 2 = x ^ 2).
    Proof using Type*.
      split; try apply eq_b4_a2.
      intro Hyy.
      rewrite !@F.pow_2_r in *.
      destruct (Field.only_two_square_roots_choice _ x (x * x) Hyy eq_refl); clear Hyy;
        [ eexists; eassumption | ].
      match goal with H : ?a * ?a = F.opp _ |- _ => exists (sqrt_minus1 * a);
        rewrite mul_square_sqrt_minus1; rewrite H end.
      field.
    Qed.

    Lemma sqrt_5mod8_correct : forall x,
      ((exists y, y*y = x) <-> (sqrt_5mod8 x)*(sqrt_5mod8 x) = x).
    Proof using Type*.
      cbv [sqrt_5mod8]; intros x.
      destruct (F.eq_dec x 0).
      {
        repeat match goal with
             | |- _ => progress subst
             | |- _ => progress rewrite ?F.pow_0_l
             | |- (_ <> _)%N => rewrite <-Z2N.inj_0, Z2N.inj_iff by zero_bounds
             | |- (?a <> 0)%Z => assert (0 < a) by zero_bounds; omega
             | |- _ => congruence
             end.
        break_match;
          match goal with |- _ <-> ?G => assert G by field end; intuition eauto.
      } {
        rewrite eq_b4_a2_iff by auto.
        rewrite !@F.pow_2_r in *.
        break_match.
        intuition (f_equal; eauto).
        split; intro A. {
          destruct (Field.only_two_square_roots_choice _ x (x * x) A eq_refl) as [B | B];
            clear A; try congruence.
          rewrite mul_square_sqrt_minus1, B; field.
        } {
          rewrite mul_square_sqrt_minus1 in A.
          transitivity (F.opp x * F.opp x); [ | field ].
          f_equal; rewrite <-A at 3; field.
        }
      }
    Qed.
  End SquareRootsPrime5Mod8.

  Module Iso.
    Section IsomorphicRings.
      Context {q:positive} {prime_q:prime q} {two_lt_q:2 < Z.pos q}.
      Context
        {H : Type} {eq : H -> H -> Prop} {zero one : H}
        {opp : H -> H} {add sub mul : H -> H -> H}
        {phi : F q -> H} {phi' : H -> F q}
        {phi'_phi : forall A : F q, Logic.eq (phi' (phi A)) A}
        {phi'_iff : forall a b : H, iff (Logic.eq (phi' a) (phi' b)) (eq a b)}
        {phi'_zero : Logic.eq (phi' zero) F.zero} {phi'_one : Logic.eq (phi' one) F.one}
        {phi'_opp : forall a : H, Logic.eq (phi' (opp a)) (F.opp (phi' a))}
        {phi'_add : forall a b : H, Logic.eq (phi' (add a b)) (F.add (phi' a) (phi' b))}
        {phi'_sub : forall a b : H, Logic.eq (phi' (sub a b)) (F.sub (phi' a) (phi' b))}
        {phi'_mul : forall a b : H, Logic.eq (phi' (mul a b)) (F.mul (phi' a) (phi' b))}.
      (* TODO: revive this once we figure out how to spec the pow impl
      Definition inv (x:H) := pow x (NtoP (Z.to_N (q - 2)%Z)).
      Definition div x y := mul (inv y) x.

      Lemma ring :
        @Algebra.Hierarchy.ring H eq zero one opp add sub mul
        /\ @Ring.is_homomorphism (F q) Logic.eq F.one F.add F.mul H eq one add mul phi
        /\ @Ring.is_homomorphism H eq one add mul (F q) Logic.eq F.one F.add F.mul phi'.
      Proof using phi'_add phi'_iff phi'_mul phi'_one phi'_opp phi'_phi phi'_sub phi'_zero. eapply @Ring.ring_by_isomorphism; assumption || exact _. Qed.
      Local Instance _iso_ring : Algebra.Hierarchy.ring := proj1 ring.
      Local Instance _iso_hom1 : Ring.is_homomorphism := proj1 (proj2 ring).
      Local Instance _iso_hom2 : Ring.is_homomorphism := proj2 (proj2 ring).

      Let inv_proof : forall a : H, phi' (inv a) = F.inv (phi' a).
      Proof.
        intros.
        cbv [inv]. rewrite (Fq_inv_fermat(q:=q)(two_lt_q:=two_lt_q)).
        rewrite <-Z_nat_N at 1 2.
        rewrite (ScalarMult.homomorphism_scalarmult(phi:=phi')(MUL_is_scalarmult:=pow_is_scalarmult)(mul_is_scalarmult:=F.pow_is_scalarmult)).
        reflexivity.
        assumption.
      Qed.

      Let div_proof : forall a b : H, phi' (mul (inv b) a) = phi' a / phi' b.
      Proof.
        intros.
        rewrite phi'_mul, inv_proof, Algebra.Hierarchy.field_div_definition, Algebra.Hierarchy.commutative.
        reflexivity.
      Qed.

      Lemma field_and_iso :
        @Algebra.Hierarchy.field H eq zero one opp add sub mul inv div
        /\ @Ring.is_homomorphism (F q) Logic.eq F.one F.add F.mul H eq one add mul phi
        /\ @Ring.is_homomorphism H eq one add mul (F q) Logic.eq F.one F.add F.mul phi'.
      Proof using Type*. eapply @Field.field_and_homomorphism_from_redundant_representation;
               assumption || exact _ || exact inv_proof || exact div_proof. Qed.
      *)
    End IsomorphicRings.
  End Iso.
End F.


Require Import Sequences.
Require Import CoList.
Require Import TypeDecl.

Module DefinednessMod (TD : TypeDecl).
Import TD.

Definition CoList := CoList (A :=  A).

Inductive defined_upto: nat -> CoList-> Prop :=
|all_upto_0 : forall s,  defined_upto 0 s
|snil_upto_1 :   defined_upto 1 snil
|scons_upto_S : forall n s a,  defined_upto n s -> defined_upto (S n)(scons a s).

Lemma defined_upto_mono : forall s1 s2 n,defined_upto n s1 -> les s1 s2 -> defined_upto n s2.
Proof.
intros s1 s2 n Hd.
revert s2.
induction Hd; intros s2 Hle.
*
  constructor.
*
  inversion Hle; subst.
  constructor 2.
*
  inversion Hle ; subst.
  constructor.
  apply IHHd; auto.
Qed.

Lemma defined_upto_lts_mono : forall s1 s2 n,defined_upto n s1 -> lts s1 s2 -> defined_upto (S n)  s2.
Proof.
intros s1 s2 n Hd.
revert s2.
induction Hd; intros s2 Hle.
*
  inversion Hle; subst.
  +
    destruct s2; [exfalso ; apply H; auto|   constructor| do 2 constructor].
   +
     do 2 constructor.
*
   inversion Hle.
 *
   inversion Hle; subst.
   constructor.
   apply IHHd  ; auto.
Qed.

Section Functional.

Variable T : Type.

Variable D : T  -> Prop.

Definition lef (f1 f2 : T -> CoList) := forall s,  les (f1 s) (f2 s).

Variable  F : (T -> CoList) -> T -> CoList.
Hypothesis F_mono :  forall f1 f2, lef f1 f2-> lef (F f1)(F f2).

Fixpoint _f (n : nat)(t : T) : CoList:=
  match n with
  | 0 =>  bot
  | S m =>  F ( _f m) t
end.

Definition _f_seq (t: T) :  Seq (A := CoList) :=
    (fun n => _f n t).

Lemma  _f_seq_mono :  forall n s, les ((_f_seq s) n) ((_f_seq s) (S n)).
Proof.
intros n  s.
unfold _f_seq.
revert s.
induction n.
*
  intro s.
  constructor.
*
  apply F_mono.
  intro s.
  apply IHn.
Qed.

Lemma  _f_seq_mono_gen :
  forall n n' s, n <= n' -> les ((_f_seq s) n) ((_f_seq s) n').
Proof.
intros n  n' s Hle.
induction Hle.
*
  apply les_refl.
*
  eapply les_trans ; eauto.
  apply _f_seq_mono.
Qed.

End Functional.

End DefinednessMod.

Module Type FunctionalMod(TD: TypeDecl).

Import TD.
Module DTD :=  (DefinednessMod TD).
Export DTD.

Parameter T : Type.
Parameter  D : T  -> Prop.

Parameter F : (T-> CoList) ->  T-> CoList.

Axiom F_mono : forall f1 f2, lef T f1 f2-> lef T  (F f1)(F f2).

Axiom F_prod  :
  forall t, D t ->   (exists n,  sdefined (F (_f T F n)  t))  \/ forall m,  exists n, m <= n /\ lts (_f T F n  t) (_f  T F (S n) t).

End FunctionalMod.


(** * Commutativity *)

From Coq Require Import
  Classes.Morphisms.
From DEZ Require Export
  Init.

(** ** Commutative Elements of a Form *)

Class IsCommElemsForm (A B : Type) (X : A -> A -> Prop)
  (s : B -> B -> A) (a b : B) : Prop :=
  comm_elems_form : X (s a b) (s b a).

(** ** Commutative Form *)

Class IsCommForm (A B : Type) (X : A -> A -> Prop)
  (s : B -> B -> A) : Prop :=
  comm_form (a b : B) : X (s a b) (s b a).

Section Context.

Context (A B : Type) (X : A -> A -> Prop)
  (s : B -> B -> A).

(** Commutative forms are forms with commutative elements. *)

#[export] Instance comm_form_is_comm_elems_form
  `{!IsCommForm X s} (a b : B) : IsCommElemsForm X s a b.
Proof. apply comm_form. Qed.

#[local] Instance comm_elems_form_is_comm_form
  `{!forall a b : B, IsCommElemsForm X s a b} : IsCommForm X s.
Proof. intros a b. apply comm_elems_form. Qed.

End Context.

(** ** Commutative Elements of a Binary Operation *)

Class IsCommElemsBinOp (A : Type) (X : A -> A -> Prop)
  (k : A -> A -> A) (x y : A) : Prop :=
  comm_elems_bin_op : X (k x y) (k y x).

(** ** Commutative Binary Operation *)

(** This has the same shape as [Z.mul_comm]. *)

Class IsCommBinOp (A : Type) (X : A -> A -> Prop)
  (k : A -> A -> A) : Prop :=
  comm_bin_op (x y : A) : X (k x y) (k y x).

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (k : A -> A -> A).

(** Commutative binary operations
    are binary operations with commutative elements. *)

#[export] Instance comm_bin_op_is_comm_elems_bin_op
  `{!IsCommBinOp X k} (x y : A) : IsCommElemsBinOp X k x y.
Proof. apply comm_bin_op. Qed.

#[local] Instance comm_elems_bin_op_is_comm_bin_op
  `{!forall x y : A, IsCommElemsBinOp X k x y} : IsCommBinOp X k.
Proof. intros x y. apply comm_elems_bin_op. Qed.

End Context.

(** ** Coherent Unary Functions *)

Class IsCommUnFns (A B0 B1 C : Type) (X : C -> C -> Prop)
  (f : A -> B0) (g : A -> B1) (h : B1 -> C) (i : B0 -> C) : Prop :=
  comm_un_fns (x : A) : X (h (g x)) (i (f x)).

(** ** Commutative Unary Operations *)

Class IsCommUnOps (A : Type) (X : A -> A -> Prop)
  (f g : A -> A) : Prop :=
  comm_un_ops (x : A) : X (f (g x)) (g (f x)).

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (f g : A -> A).

(** Commutativity of unary operations
    is a special case of their commutativity as unary functions. *)

#[export] Instance comm_un_ops_is_comm_un_fns
  `{!IsCommUnOps X f g} : IsCommUnFns X f g f g.
Proof. auto. Qed.

#[local] Instance comm_un_fns_is_comm_un_ops
  `{!IsCommUnFns X f g f g} : IsCommUnOps X f g.
Proof. auto. Qed.

End Context.

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (f g : A -> A).

(** Commutative unary operations are commutative elements
    of the endofunction monoid. *)

#[export] Instance comm_un_ops_is_comm_elems_bin_op_compose
  `{!IsCommUnOps X f g} : IsCommElemsBinOp (pointwise_relation _ X) _o_ f g.
Proof. intros x. unfold compose. apply comm_un_ops. Qed.

#[local] Instance comm_elems_bin_op_compose_is_comm_un_ops
  `{!IsCommElemsBinOp (pointwise_relation _ X) _o_ f g} : IsCommUnOps X f g.
Proof.
  intros x.
  change (f (g x)) with ((f o g) x).
  change (g (f x)) with ((g o f) x).
  pose proof comm_elems_bin_op x as a.
  apply a.
Qed.

End Context.

(** ** Binary Functions Left-Commuting over Unary Functions *)

Class IsCommBinFnsL (A0 A1 B0 B1 C : Type) (X : C -> C -> Prop)
  (k : A0 -> A1 -> B1) (f : A0 -> B0)
  (m : B0 -> A1 -> C) (g : B1 -> C) : Prop :=
  comm_bin_fns_l (x : A0) (y : A1) : X (m (f x) y) (g (k x y)).

(** ** Binary Functions Right-Commuting over Unary Functions *)

Class IsCommBinFnsR (A0 A1 B0 B1 C : Type) (X : C -> C -> Prop)
  (k : A0 -> A1 -> B0) (f : A1 -> B1)
  (m : A0 -> B1 -> C) (g : B0 -> C) : Prop :=
  comm_bin_fns_r (x : A0) (y : A1) : X (m x (f y)) (g (k x y)).

Section Context.

Context (A0 A1 B0 B1 C : Type) (X : C -> C -> Prop)
  (k : A0 -> A1 -> B1) (f : A0 -> B0) (m : B0 -> A1 -> C) (g : B1 -> C).

(** Left-commutativity of binary functions over unary functions
    is a special case of the right-commutativity of their flipped versions. *)

#[local] Instance comm_bin_fns_l_is_comm_bin_fns_r_flip
  `{!IsCommBinFnsL X k f m g} : IsCommBinFnsR X (flip k) f (flip m) g.
Proof. intros y x. unfold flip in *. eauto. Qed.

#[local] Instance comm_bin_fns_r_flip_is_comm_bin_fns_l
  `{!IsCommBinFnsR X (flip k) f (flip m) g} : IsCommBinFnsL X k f m g.
Proof. intros x y. unfold flip in *. eauto. Qed.

End Context.

(** ** Right Action Left-Commuting over a Unary Function *)

Class IsCommActRL (A B : Type) (X : B -> B -> Prop)
  (ar : B -> A -> B) (f : B -> B) : Prop :=
  comm_act_r_l (a : B) (x : A) : X (ar (f a) x) (f (ar a x)).

Section Context.

Context (A B : Type) (X : B -> B -> Prop)
  (f : B -> B) (ar : B -> A -> B).

(** Left-commutativity of a right action over a unary function
    is a special case of its left-commutativity
    as a binary function over a unary function. *)

#[export] Instance comm_act_r_l_is_comm_bin_fns_l
  `{!IsCommActRL X ar f} : IsCommBinFnsL X ar f ar f.
Proof. auto. Qed.

#[local] Instance comm_bin_fns_l_is_comm_act_r_l
  `{!IsCommBinFnsL X ar f ar f} : IsCommActRL X ar f.
Proof. auto. Qed.

End Context.

(** ** Left Action Right-Commuting over a Unary Function *)

Class IsCommActLR (A B : Type) (X : B -> B -> Prop)
  (al : A -> B -> B) (f : B -> B) : Prop :=
  comm_act_l_r (x : A) (a : B) : X (al x (f a)) (f (al x a)).

Section Context.

Context (A B : Type) (X : B -> B -> Prop)
  (f : B -> B) (al : A -> B -> B).

(** Right-commutativity of a left action over a unary function
    is a special case of its right-commutativity
    as a binary function over a unary function. *)

#[export] Instance comm_act_l_r_is_comm_bin_fns_r
  `{!IsCommActLR X al f} : IsCommBinFnsR X al f al f.
Proof. auto. Qed.

#[local] Instance comm_bin_fns_r_is_comm_act_l_r
  `{!IsCommBinFnsR X al f al f} : IsCommActLR X al f.
Proof. auto. Qed.

End Context.

(** ** Binary Operation Left-Commuting over a Unary Operation *)

(** This has the same shape as [Z.mul_opp_l]. *)

Class IsCommL (A : Type) (X : A -> A -> Prop)
  (k : A -> A -> A) (f : A -> A) : Prop :=
  comm_l (x y : A) : X (k (f x) y) (f (k x y)).

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (k : A -> A -> A) (f : A -> A).

(** Left-commutativity of a binary operation over a unary operation
    is a special case of its left-commutativity
    as a binary function over a unary function. *)

#[export] Instance comm_l_is_comm_bin_fns_l
  `{!IsCommL X k f} : IsCommBinFnsL X k f k f.
Proof. auto. Qed.

#[local] Instance comm_bin_fns_l_is_comm_l
  `{!IsCommBinFnsL X k f k f} : IsCommL X k f.
Proof. auto. Qed.

(** Left-commutativity of a binary operation over a unary operation
    is a special case of the commutativity
    of its flipped partial application over the unary operation. *)

#[export] Instance comm_l_is_comm_un_ops_flip
  `{!IsCommL X k f} (x : A) : IsCommUnOps X (flip k x) f.
Proof. intros y. unfold flip. apply comm_l. Qed.

#[local] Instance comm_un_ops_flip_is_comm_l
  `{!forall x : A, IsCommUnOps X (flip k x) f} : IsCommL X k f.
Proof.
  intros x y.
  change (k x y) with (flip k y x).
  change (k (f x) y) with (flip k y (f x)).
  apply comm_un_ops.
Qed.

End Context.

(** ** Binary Operation Right-Commuting over a Unary Operation *)

(** This has the same shape as [Z.mul_opp_r]. *)

Class IsCommR (A : Type) (X : A -> A -> Prop)
  (k : A -> A -> A) (f : A -> A) : Prop :=
  comm_r (x y : A) : X (k x (f y)) (f (k x y)).

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (k : A -> A -> A) (f : A -> A).

(** Right-commutativity of a binary operation over a unary operation
    is a special case of its right-commutativity
    as a binary function over a unary function. *)

#[export] Instance comm_r_is_comm_bin_fns_r
  `{!IsCommR X k f} : IsCommBinFnsR X k f k f.
Proof. auto. Qed.

#[local] Instance comm_bin_fns_r_is_comm_r
  `{!IsCommBinFnsR X k f k f} : IsCommR X k f.
Proof. auto. Qed.

(** Right-commutativity of a binary operation over a unary operation
    is a special case of the commutativity
    of its partial application over the unary operation. *)

#[export] Instance comm_r_is_comm_un_ops
  `{!IsCommR X k f} (x : A) : IsCommUnOps X (k x) f.
Proof. intros y. apply comm_r. Qed.

#[local] Instance comm_un_ops_is_comm_r
  `{!forall x : A, IsCommUnOps X (k x) f} : IsCommR X k f.
Proof. intros x y. apply comm_un_ops. Qed.

End Context.

(** ** Commutative Binary Operation over a Unary Operation *)

Class IsComm (A : Type) (X : A -> A -> Prop)
  (k : A -> A -> A) (f : A -> A) : Prop := {
  comm_is_comm_l :> IsCommL X k f;
  comm_is_comm_r :> IsCommR X k f;
}.