(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*   Assia.Mahboubi@inria.fr, Laurence.Rideau@inria.fr       *)
(*  Laurent.Thery@inria.fr Yves.Bertot Frederique.Guilhot    *)
(*  &all    Inria, 2006                                      *)
(*************************************************************)

Require Export Reals.
Require Export Field.
Require Export Fourier.
Open Scope R_scope.
Hint Resolve fact_neq_0 prod_neq_R0 :real.

Ltac RReplace a b := replace a with b; [idtac | ring || auto with real].

Ltac NReplace a b := replace a with b; [idtac | omega || auto with arith].

Axiom gt_div2 : forall alp, alp > 0 ->  (alp * / 2 > 0).

Axiom lt_div2 : forall alp, alp > 0 ->  (alp * / 2 < alp).
(**)

Inductive Rstar_point : R ->  Prop :=
  Rstar_point_intro: forall (x : R), x <> 0 -> x + 1 <> 0 ->  Rstar_point x .

Lemma continuity_pol_0_point:
 forall n a g,
 (forall (X : R),
  X <> 0 -> X + 1 <> 0 ->  g X = X * sum_f_R0 (fun (i : nat) => a i * X ^ i) n) ->
  limit1_in g Rstar_point 0 0.
induction n; intros.
assert (forall (X : R), X <> 0 -> X + 1 <> 0 ->  g X = X * a 0%nat).
intros.
rewrite (H X); auto; simpl.
ring.
unfold limit1_in, limit_in.
simpl.
unfold R_dist; intros.
elim (Req_dec (a 0%nat) 0); intros.
exists eps.
split; [try assumption | idtac].
intros.
elim H3; [intros H4 H5; (try clear H3); (try exact H4)].
rewrite (H0 x); auto.
rewrite H2.
RReplace (x * 0 - 0) 0.
rewrite Rabs_R0.
auto with real.
elim H4; auto.
elim H4; auto.
assert (0 < Rabs (/ a 0%nat)).
apply Rabs_pos_lt; auto with real.
exists (eps * Rabs (/ a 0%nat)).
split; [try assumption | idtac].
apply Rmult_gt_0_compat; auto with real.
intros.
elim H4; [intros H5 H6; (try clear H4); (try exact H5)].
rewrite (H0 x); auto.
RReplace (x * a 0%nat - 0) (x * a 0%nat).
rewrite Rabs_mult.
RReplace eps ((eps * Rabs (/ a 0%nat)) * Rabs (a 0%nat)).
apply Rmult_lt_compat_r; auto with real.
apply Rabs_pos_lt; auto with real.
RReplace x (x - 0); auto.
rewrite Rabs_Rinv; auto.
field.
apply Rabs_no_R0; auto.
elim H5; auto.
elim H5; auto.
assert
 (forall (X : R),
  X <> 0 ->
  X + 1 <> 0 ->
   g X =
   X *
   (sum_f_R0 (fun (i : nat) => a i * X ^ i) 0 +
    sum_f_R0 (fun (i : nat) => a (1 + i)%nat * X ^ (1 + i)) (S n - 1))).
intros.
rewrite <- (tech2 (fun (i : nat) => a i * X ^ i) 0%nat (S n)); auto with arith.
assert
 (forall (X : R),
  X <> 0 ->
  X + 1 <> 0 ->
   g X =
   X * a 0%nat + X * (X * sum_f_R0 (fun (i : nat) => a (1 + i)%nat * X ^ i) n)).
intros.
rewrite H0; auto.
simpl.
NReplace (n - 0)%nat n; auto.
rewrite scal_sum.
assert
 (sum_f_R0 (fun (i : nat) => a (S i) * (X * X ^ i)) n =
  sum_f_R0 (fun (i : nat) => (a (S i) * X ^ i) * X) n).
apply sum_eq; intros.
ring.
rewrite H3.
ring.
pose (f:=
 fun (X : R) => X * sum_f_R0 (fun (i : nat) => a (1 + i)%nat * X ^ i) n).
assert (limit1_in f Rstar_point 0 0).
intros.
unfold f; apply (IHn (fun (i : nat) => a (1 + i)%nat)).
auto.
assert (forall (X : R), X <> 0 -> X + 1 <> 0 ->  g X = X * a 0%nat + X * f X).
unfold f; auto.
assert
 (forall (eps : R),
  eps > 0 -> forall (x : R), Rstar_point x /\ Rabs x < eps ->  (Rabs x < eps)).
intros.
elim H5; [intros H6 H7; (try clear H5); (try exact H7)].
generalize H2; unfold limit1_in, limit_in.
simpl; unfold R_dist; intros.
elim (Req_dec (a 0%nat) 0); intros.
assert (forall (X : R), X <> 0 -> X + 1 <> 0 ->  g X = X * f X).
intros.
rewrite (H3 X); auto.
rewrite H7.
ring.
elim H5 with ( eps := eps ); [intros alp H10; (try exact H10) | auto].
elim H10; [intros H9 H11; (try clear H10); (try exact H9)].
exists (Rmin alp (/ 2)).
split; [auto | intros x; intros].
apply Rmin_Rgt_r; auto.
split; auto with real.
fourier.
elim H10; [intros H12 H13; (try clear H10); (try exact H12)].
RReplace (g x - 0) (g x).
rewrite (H8 x).
rewrite Rabs_mult.
assert (Rabs x < 1).
assert (Rmin alp (/ 2) < 1).
assert (Rmin alp (/ 2) <= / 2).
apply Rmin_r; auto.
fourier.
RReplace x (x - 0).
fourier.
assert (Rabs (f x) < eps).
RReplace (f x) (f x - 0).
apply H11.
split; [try assumption | idtac].
assert (Rmin alp (/ 2) <= alp).
apply Rmin_l; auto.
fourier.
elim (Req_dec (f x) 0); intros.
rewrite H15.
rewrite Rabs_R0.
RReplace (Rabs x * 0) 0; auto.
RReplace eps (1 * eps).
apply Rmult_gt_0_lt_compat; auto.
assert (0 < Rabs (f x)).
apply Rabs_pos_lt; auto with real.
fourier.
fourier.
elim H12; auto.
elim H12; auto.
assert (0 < Rabs (a 0%nat)).
apply Rabs_pos_lt; auto with real.
elim H5 with ( eps := Rabs (a 0%nat) ); [intros alp H10; (try exact H10) | auto].
elim H10; [intros H9 H11; (try clear H10); (try exact H9)].
assert (/ (2 * Rabs (a 0%nat)) > 0).
assert (2 * Rabs (a 0%nat) > 0).
fourier.
assert (0 < / (2 * Rabs (a 0%nat))).
apply Rinv_0_lt_compat; auto with real.
fourier.
exists (Rmin alp (eps * / (2 * Rabs (a 0%nat)))).
split; [auto | intros x; intros].
apply Rmin_Rgt_r; auto.
split; auto with real.
apply Rmult_gt_0_compat; auto.
RReplace (g x - 0) (g x).
elim H12; [intros H13 H14; (try clear H12); (try exact H13)].
rewrite (H3 x); auto.
RReplace (x * a 0%nat + x * f x) (x * (a 0%nat + f x)).
rewrite Rabs_mult.
assert (Rabs x < eps * / (2 * Rabs (a 0%nat))).
assert (Rmin alp (eps * / (2 * Rabs (a 0%nat))) <= eps * / (2 * Rabs (a 0%nat))).
apply Rmin_r; auto.
RReplace x (x - 0).
fourier.
assert (Rabs (a 0%nat + f x) < 2 * Rabs (a 0%nat)).
RReplace (f x) (f x - 0).
assert (Rabs (a 0%nat + (f x - 0)) <= Rabs (a 0%nat) + Rabs (f x - 0)).
apply Rabs_triang.
assert (Rabs (f x - 0) < Rabs (a 0%nat)).
apply H11.
split; [try assumption | idtac].
assert (Rmin alp (eps * / (2 * Rabs (a 0%nat))) <= alp).
apply Rmin_l; auto.
fourier.
RReplace (2 * Rabs (a 0%nat)) (Rabs (a 0%nat) + Rabs (a 0%nat)).
fourier.
elim (Req_dec (a 0%nat + f x) 0); intros.
rewrite H16.
rewrite Rabs_R0.
RReplace (Rabs x * 0) 0; auto.
RReplace eps ((eps * / (2 * Rabs (a 0%nat))) * (2 * Rabs (a 0%nat))).
apply Rmult_gt_0_lt_compat; auto.
assert (0 < Rabs (a 0%nat + f x)).
apply Rabs_pos_lt; auto with real.
fourier.
apply Rmult_gt_0_compat; auto.
field; auto.
assert (0 < 2).
fourier.
auto with real.
elim H13; auto.
elim H13; auto.
Qed.

Axiom deux : 2 <> 0.

Lemma limit_0_somme_point:
 forall (a : R) (f g : R ->  R),
 (forall X, X <> 0 -> X + 1 <> 0 ->  f X = a + g X) ->
 limit1_in g Rstar_point 0 0 ->  limit1_in f Rstar_point a 0.
unfold limit1_in, limit_in.
simpl.
unfold R_dist; intros.
elim H0 with ( eps := eps );
 [intros alp H2; (try clear H0); (try exact H2) | idtac].
exists alp.
split; [try assumption | idtac].
elim H2; [intros H0 H3; (try clear H2); (try exact H0)].
intros.
rewrite (H x); auto.
RReplace ((a + g x) - a) (g x - 0).
elim H2; [intros H3 H4; (try clear H2); (try exact H4)].
apply (H4 x); auto.
elim H0; [intros H3 H4; (try clear H0); (try exact H3)].
elim H3; auto.
elim H0; [intros H3 H4; (try clear H0); (try exact H3)].
elim H3; auto.
auto.
Qed.

Lemma limit_0_point:
 forall (f : R ->  R),
 (forall X, X <> 0 -> X + 1 <> 0 ->  f X = 0) ->  limit1_in f Rstar_point 0 0.
unfold limit1_in, limit_in; intros.
simpl.
unfold R_dist; intros.
exists eps.
split; [try assumption | idtac].
intros.
RReplace (f x - 0) 0.
rewrite Rabs_R0.
auto with real.
elim H1; [intros H2 H3; (try clear H1)].
rewrite (H x); auto.
elim H2; auto.
elim H2; auto.
Qed.

Lemma unicite_limit_0_point_somme:
 forall (a : R) (f g : R ->  R),
 (forall (X : R), X <> 0 -> X + 1 <> 0 ->  f X = a + g X) ->
 (forall (X : R), X <> 0 -> X + 1 <> 0 ->  f X = 0) ->
 limit1_in g Rstar_point 0 0 ->  a = 0.
intros.
apply (single_limit f Rstar_point a 0 0).
unfold adhDa; intros.
assert (alp * / 2 > 0).
apply gt_div2; auto.
unfold R_dist; intros.
exists (alp * / 2).
split; [try assumption | idtac].
apply Rstar_point_intro; auto.
auto with real.
assert (alp * / 2 + 1 > 0).
fourier.
auto with real.
RReplace (alp * / 2 - 0) (alp * / 2).
rewrite Rabs_right; auto with real.
apply lt_div2; auto.
fourier.
apply limit_0_somme_point with g; auto.
apply limit_0_point; auto.
Qed.

Axiom pow_eq_R0 : forall (n : nat) (a : R), a ^ S n = 0 ->  a = 0.

Theorem polynome_nul_point:
 forall (n : nat) (a : nat ->  R),
 (forall X, X + 1 <> 0 ->  sum_f_R0 (fun (i : nat) => a i * X ^ i) n = 0) ->
 forall j, (j <= n)%nat ->  a j = 0.
intros n a H.
assert (forall (m j : nat), (m <= n)%nat -> (j <= m)%nat ->  a j = 0).
induction m; intros.
NReplace j 0%nat; auto.
rewrite <- (H 0); auto with real.
generalize H H0 H1.
clear H H0 H1.
elim n.
simpl; intros.
ring.
intros m; intros.
rewrite (tech2 (fun (i : nat) => a i * 0 ^ i) 0%nat (S m)); auto with arith.
simpl.
NReplace (m - 0)%nat m.
assert (sum_f_R0 (fun (i : nat) => a (S i) * (0 * 0 ^ i)) m = 0).
apply sum_eq_R0; intros.
ring.
rewrite H3; ring.
elim (le_gt_dec j m); intros.
apply IHm; auto with arith.
NReplace j (S m).
assert
 (forall (X : R),
  X + 1 <> 0 ->
   sum_f_R0 (fun (i : nat) => a i * X ^ i) m +
   sum_f_R0 (fun (i : nat) => a (S m + i)%nat * X ^ (S m + i)) (n - S m) = 0).
intros.
rewrite <- (H X); auto.
rewrite (tech2 (fun (i : nat) => a i * X ^ i) m%nat n); auto with arith.
assert
 (forall (X : R), X + 1 <> 0 ->  sum_f_R0 (fun (i : nat) => a i * X ^ i) m = 0).
intros.
apply sum_eq_R0; intros.
rewrite IHm; auto with arith.
ring.
assert
 (forall (X : R),
  X + 1 <> 0 ->
   sum_f_R0 (fun (i : nat) => a (S m + i)%nat * X ^ (S m + i)) (n - S m) = 0).
intros.
rewrite <- (H2 X); auto.
rewrite H3; auto.
ring.
assert
 (forall (X : R),
  X + 1 <> 0 ->
   X ^ S m * sum_f_R0 (fun (i : nat) => a (S m + i)%nat * X ^ i) (n - S m) =
   sum_f_R0 (fun (i : nat) => a (S m + i)%nat * X ^ (S m + i)) (n - S m)).
intros.
rewrite scal_sum.
apply sum_eq; intros.
rewrite pow_add.
ring.
assert
 (forall (X : R),
  X + 1 <> 0 ->
   X ^ S m * sum_f_R0 (fun (i : nat) => a (S m + i)%nat * X ^ i) (n - S m) = 0).
intros.
rewrite (H5 X); auto.
assert
 (forall (X : R),
  X + 1 <> 0 ->
   X ^ S m = 0 \/
   sum_f_R0 (fun (i : nat) => a (S m + i)%nat * X ^ i) (n - S m) = 0).
intros.
apply Rmult_integral; auto.
assert
 (forall (X : R),
  X + 1 <> 0 ->
   X = 0 \/ sum_f_R0 (fun (i : nat) => a (S m + i)%nat * X ^ i) (n - S m) = 0).
intros.
elim H7 with ( X := X );
 [intros H9; (try clear H7); (try exact H9) | intros H9; (try clear H7) | auto].
left; (try assumption).
apply pow_eq_R0 with m; auto.
right; auto.
auto.
assert
 (forall (X : R),
  X <> 0 ->
  X + 1 <> 0 ->
   sum_f_R0 (fun (i : nat) => a (S m + i)%nat * X ^ i) (n - S m) = 0).
intros.
elim H8 with ( X := X );
 [intros H11; (try clear H8); auto | intros H11; auto | auto].
intuition.
elim (zerop (n - S m)); intros.
rewrite <- (H9 1); auto with real.
rewrite a0; simpl.
NReplace (S (m + 0))%nat (S m).
ring.
apply deux.
assert
 (forall (X : R),
  X <> 0 ->
  X + 1 <> 0 ->
   sum_f_R0 (fun (i : nat) => a (S m + i)%nat * X ^ i) 0 +
   sum_f_R0
    (fun (i : nat) => a (S m + (1 + i))%nat * X ^ (1 + i)) ((n - S m) - 1) = 0).
intros.
rewrite <- (H9 X); auto.
rewrite (tech2 (fun (i : nat) => a (S m + i)%nat * X ^ i) 0%nat (n - S m));
 auto with arith.
assert
 (forall (X : R),
  X <> 0 ->
  X + 1 <> 0 ->
   a (S m) +
   X * sum_f_R0 (fun (i : nat) => a (S m + (1 + i))%nat * X ^ i) ((n - S m) - 1)
   = 0).
intros.
rewrite <- (H10 X); auto.
simpl.
rewrite scal_sum.
NReplace (S (m + 0)) (S m).
assert
 (sum_f_R0 (fun (i : nat) => (a (S (m + S i)) * X ^ i) * X) ((n - S m) - 1) =
  sum_f_R0 (fun (i : nat) => a (S (m + S i)) * (X * X ^ i)) ((n - S m) - 1)).
apply sum_eq; intros.
ring.
rewrite H13.
ring.
assert (forall (X : R),  a (S m) = 0).
intros.
pose (g:=
 fun (X : R) =>
 X * sum_f_R0 (fun (i : nat) => a (S m + (1 + i))%nat * X ^ i) ((n - S m) - 1)).
pose (f:= fun (X : R) => a (S m) + g X).
apply (unicite_limit_0_point_somme (a (S m)) f g); auto.
apply
 (continuity_pol_0_point
   ((n - S m) - 1) (fun (i : nat) => a (S m + (1 + i))%nat) g); auto.
apply H12; auto with real.
intros.
apply (H0 n); auto with arith.
Qed.

Lemma vector_X_point:
 forall (p : nat) (a b : nat ->  R),
 (forall X,
  X + 1 <> 0 ->
   sum_f_R0 (fun (i : nat) => a i * X ^ i) p =
   sum_f_R0 (fun (i : nat) => b i * X ^ i) p) ->
 forall j, (j <= p)%nat ->  a j = b j.
intros.
assert (a j - b j = 0).
apply (polynome_nul_point p (fun (i : nat) => a i - b i)); auto.
intros.
RReplace 0
         (sum_f_R0 (fun (i : nat) => a i * X ^ i) p -
          sum_f_R0 (fun (i : nat) => b i * X ^ i) p).
rewrite <- minus_sum.
apply sum_eq; intros.
ring.
rewrite H; auto.
ring.
RReplace (b j) (b j + 0).
rewrite <- H1.
ring.
Qed.

Lemma pow_Rmult: forall (x y : R) (n : nat),  (x * y) ^ n = x ^ n * y ^ n.
intros; (induction n; simpl).
auto with real.
RReplace ((x * x ^ n) * (y * y ^ n)) ((x * y) * (x ^ n * y ^ n)).
rewrite <- IHn.
ring.
Qed.
(*Polynomes de Bernstein (l,r)*)
Parameter RBern : nat -> nat -> R -> R -> R ->  R.

Axiom
   RBern_def :
   forall p i l r X,
   (i <= p)%nat ->
   r - l <> 0 ->
    RBern p i l r X =
    C p i * (Rdiv (X - l) (r - l) ^ i * Rdiv (r - X) (r - l) ^ (p - i)).

Definition translation (a : R) (f : R ->  R) := fun (x : R) => f (x - a).

Definition dilatation (a : R) (f : R ->  R) := fun (x : R) => f (x * a).

Definition inverse (n : nat) (f : R ->  R) := fun (x : R) => x ^ n * f (/ x).

Lemma translation_bij:
 forall a f g,
 (forall x,  g x = translation a f x) -> forall x,  f x = translation (- a) g x.
unfold translation; intros.
rewrite H.
RReplace ((x - - a) - a) x; auto.
Qed.

Lemma dilatation_bij:
 forall a f g,
 a <> 0 ->
 (forall x,  g x = dilatation a f x) -> forall x,  f x = dilatation (/ a) g x.
unfold dilatation; intros.
rewrite H0.
RReplace ((x * / a) * a) x; auto.
field; auto.
Qed.

Definition reverse (p : nat) (b : nat ->  R) := fun (i : nat) => b (p - i)%nat.

Lemma sigma_reverse:
 forall (p : nat) (b : nat ->  R),  sum_f_R0 b p = sum_f_R0 (reverse p b) p.
induction p; intros.
simpl; unfold reverse.
NReplace (0 - 0)%nat 0%nat; auto.
rewrite tech5; auto.
rewrite (tech2 (reverse (S p) b) 0 (S p)); auto.
simpl; unfold reverse.
NReplace (S p - 0)%nat (S p)%nat.
NReplace (p - 0)%nat p.
assert (sum_f_R0 b p = sum_f_R0 (fun (i : nat) => b (S p - S i)%nat) p).
rewrite IHp.
apply sum_eq; intros; unfold reverse.
NReplace (S p - S i)%nat (p - i)%nat; auto.
rewrite H; ring.
omega.
Qed.

Lemma inverse_pol:
 forall a f p,
 (forall X,  f X = sum_f_R0 (fun (i : nat) => a i * X ^ i) p) ->
 forall X,
 X <> 0 ->
  sum_f_R0 (fun (i : nat) => a (p - i)%nat * X ^ i) p =
  inverse p (fun (x : R) => f x) X.
unfold inverse; intros.
rewrite H.
rewrite scal_sum.
rewrite sigma_reverse.
apply sum_eq; intros; unfold reverse.
NReplace (p - (p - i))%nat i; auto.
pattern p at 2.
NReplace p ((p - i) + i)%nat.
RReplace ((a i * (/ X) ^ i) * X ^ ((p - i) + i))
         (a i * (X ^ ((p - i) + i) * / X ^ i)); auto.
rewrite <- pow_RN_plus; auto.
rewrite Rinv_pow; auto.
Qed.

Lemma transl_Bern:
 forall (p i : nat) (l r X : R),
 (i <= p)%nat ->
 r - l <> 0 ->
  translation (- l) (fun (x : R) => RBern p i l r x) X =
  C p i * ((X / (r - l)) ^ i * (((r - l) - X) / (r - l)) ^ (p - i)).
unfold translation; intros.
rewrite RBern_def; auto.
RReplace ((X - - l) - l) X.
RReplace (r - (X - - l)) ((r - l) - X); auto.
Qed.

Lemma dilat_transl_Bern:
 forall (p i : nat) (l r X : R),
 (i <= p)%nat ->
 r - l <> 0 ->
  dilatation (r - l) (translation (- l) (fun (x : R) => RBern p i l r x)) X =
  C p i * (X ^ i * (1 - X) ^ (p - i)).
unfold dilatation; intros.
rewrite transl_Bern; auto.
RReplace ((X * (r - l)) / (r - l)) X.
RReplace (((r - l) - X * (r - l)) / (r - l)) (1 - X); auto.
field; auto with real.
field; auto with real.
Qed.

Lemma inverse_dilat_transl_Bern:
 forall (p i : nat) (l r X : R),
 (i <= p)%nat ->
 r - l <> 0 ->
 X <> 0 ->
  inverse
   p (dilatation (r - l) (translation (- l) (fun (x : R) => RBern p i l r x))) X
  = C p (p - i) * (X - 1) ^ (p - i).
unfold inverse; intros.
rewrite dilat_transl_Bern; auto.
pattern p at 1.
NReplace p ((p - i) + i)%nat.
rewrite pow_add.
rewrite <- Rinv_pow; auto.
RReplace ((X ^ (p - i) * X ^ i) * (C p i * (/ X ^ i * (1 - / X) ^ (p - i))))
         ((X ^ i * / X ^ i) * (C p i * (X ^ (p - i) * (1 - / X) ^ (p - i)))).
RReplace (X ^ i * / X ^ i) 1; auto with real.
rewrite <- pow_Rmult.
RReplace (X * (1 - / X)) (X - 1).
rewrite pascal_step1; auto.
ring.
field; auto.
Qed.

Lemma transl_inverse_dilat_transl_Bern:
 forall (p i : nat) (l r X : R),
 (i <= p)%nat ->
 r - l <> 0 ->
 X + 1 <> 0 ->
  translation
   (- 1)
   (inverse
     p (dilatation (r - l) (translation (- l) (fun (x : R) => RBern p i l r x))))
   X = C p (p - i) * X ^ (p - i).
intros.
change
 (inverse
   p (dilatation (r - l) (translation (- l) (fun (x : R) => RBern p i l r x)))
   (X - - 1) = C p (p - i) * X ^ (p - i)).
rewrite inverse_dilat_transl_Bern; auto.
RReplace ((X - - 1) - 1) X; auto.
RReplace (X - - 1) (X + 1); auto.
Qed.

Lemma transl_inverse_dilat_transl_sigma_Bern:
 forall (p : nat) (l r X : R) (b : nat ->  R),
 r - l <> 0 ->
 X + 1 <> 0 ->
  translation
   (- 1)
   (inverse
     p
     (dilatation
       (r - l)
       (translation
         (- l)
         (fun (x : R) => sum_f_R0 (fun (i : nat) => b i * RBern p i l r x) p))))
   X = sum_f_R0 (fun (i : nat) => b i * (C p (p - i) * X ^ (p - i))) p.
unfold translation, inverse, dilatation, translation; intros.
rewrite scal_sum.
apply sum_eq; (intros j; intros).
rewrite <- (transl_inverse_dilat_transl_Bern p j l r X); auto.
unfold translation, inverse, dilatation, translation; ring.
Qed.

Lemma vector_X_point_reverse:
 forall (p : nat) (a b : nat ->  R),
 (forall X,
  X + 1 <> 0 ->
   sum_f_R0 (fun (i : nat) => a (p - i)%nat * X ^ (p - i)%nat) p =
   sum_f_R0 (fun (i : nat) => b (p - i)%nat * X ^ (p - i)%nat) p) ->
 forall j, (j <= p)%nat ->  a (p - j)%nat = b (p - j)%nat.
intros.
apply (vector_X_point p).
intros.
rewrite sigma_reverse.
symmetry.
rewrite sigma_reverse.
unfold reverse.
rewrite (H X); auto.
omega.
Qed.
(* si b0,....,bp sont les coefficients du polynome P dans la base Bern(l,r)
   on peut calculer les coefficients de P dans la base Xi*)

Theorem calcul_correct:
 forall (p : nat) (l r : R) (b a : nat ->  R),
 r - l <> 0 ->
 (forall X,
  X + 1 <> 0 ->
   translation
    (- 1)
    (inverse
      p
      (dilatation
        (r - l)
        (translation
          (- l)
          (fun (x : R) => sum_f_R0 (fun (i : nat) => b i * RBern p i l r x) p))))
    X = sum_f_R0 (fun (i : nat) => a i * X ^ i) p) ->
 forall j, (j <= p)%nat ->  a (p - j)%nat = C p j * b j.
intros.
assert (C p j * b j = C p (p - j) * b (p - (p - j))%nat).
NReplace (p - (p - j))%nat j.
rewrite <- pascal_step1; auto.
rewrite H2.
pose (c:= fun (i : nat) => C p i * b (p - i)%nat).
RReplace (C p (p - j) * b (p - (p - j))%nat) (c (p - j)%nat).
apply vector_X_point_reverse; auto.
intros.
unfold c.
assert
 (sum_f_R0
   (fun (i : nat) => (C p (p - i) * b (p - (p - i))%nat) * X ^ (p - i)) p =
  sum_f_R0 (fun (i : nat) => b i * (C p (p - i) * X ^ (p - i))) p).
apply sum_eq; intros.
NReplace (p - (p - i))%nat i.
ring.
rewrite H4.
rewrite <- (transl_inverse_dilat_transl_sigma_Bern p l r X b); auto.
rewrite (H0 X); auto.
symmetry.
rewrite sigma_reverse.
unfold reverse; auto.
Qed.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^213 - 3
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 7%nat;
    base := 32;
    bitwidth := 32;
    s := 2^213;
    c := [(1, 3)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


(** * DSL benchmark: Bitify *)

(** ** Num2Bits *)

(* print_endline (generate_lemmas num2bits (typecheck_circuit d_empty num2bits));; *)

Lemma Num2Bits_obligation0: forall (n : nat) (_in : F) (v : Z), True -> True -> ((v = 0%nat) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation1: forall (n : nat) (_in : F) (v : Z), True -> True -> (((0%nat <= v) /\ (v = n)) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation2: forall (n : nat) (_in : F) (v : Z), True -> True -> (((0%nat <= v) /\ (v < n)) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation3: forall (n : nat) (_in : F) (i : nat) (v : (list F)), True -> (i < n) -> Forall (fun x0 => True) v -> True -> (((length v) = i) -> ((length v) = i)).
Proof. Admitted.

Lemma Num2Bits_obligation4: forall (n : nat) (_in : F) (i : nat) (x : (list F)) (star : F) (v : F), True -> (i < n) -> Forall (fun x1 => True) x -> ((length x) = i) -> True -> True -> ((v = star) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation5: forall (n : nat) (_in : F) (i : nat) (x : (list F)) (star : F) (v : (list F)), True -> (i < n) -> Forall (fun x2 => True) x -> ((length x) = i) -> True -> Forall (fun x3 => True) v -> True -> ((((length v) = i) /\ (v = x)) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation6: forall (n : nat) (_in : F) (i : nat) (x : (list F)) (star : F) (v : F), True -> (i < n) -> Forall (fun x4 => True) x -> ((length x) = i) -> True -> True -> (True -> True).
Proof. Admitted.

Lemma Num2Bits_obligation7: forall (n : nat) (_in : F) (i : nat) (x : (list F)) (star : F) (v : (list F)), True -> (i < n) -> Forall (fun x5 => True) x -> ((length x) = i) -> True -> Forall (fun x6 => True) v -> True -> ((v = (star :: x)) -> ((length v) = (i + 1%nat)%nat)).
Proof. Admitted.

Lemma Num2Bits_obligation8: forall (n : nat) (_in : F) (i : nat) (x : (list F)) (star : F) (v : F), True -> (i < n) -> Forall (fun x7 => True) x -> ((length x) = i) -> True -> True -> (True -> True).
Proof. Admitted.

Lemma Num2Bits_obligation9: forall (n : nat) (_in : F), True -> (((length v) = 0%nat) -> ((length v) = 0%nat)).
Proof. Admitted.

Lemma Num2Bits_obligation10: forall (n : nat) (_in : F) (out : (list F)) (v : Z), True -> Forall (fun x8 => True) out -> ((length out) = n) -> True -> ((v = 0%nat) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation11: forall (n : nat) (_in : F) (out : (list F)) (v : Z), True -> Forall (fun x9 => True) out -> ((length out) = n) -> True -> (((0%nat <= v) /\ (v = n)) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation12: forall (n : nat) (_in : F) (out : (list F)) (v : Z), True -> Forall (fun x10 => True) out -> ((length out) = n) -> True -> (((0%nat <= v) /\ (v < n)) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation13: forall (n : nat) (_in : F) (out : (list F)) (i : nat) (v : F), True -> Forall (fun x11 => True) out -> ((length out) = n) -> (i < n) -> True -> ((v = (as_le_f (out[:i]))) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation14: forall (n : nat) (_in : F) (out : (list F)) (i : nat) (v : F), True -> Forall (fun x12 => True) out -> ((length out) = n) -> (i < n) -> True -> ((v = (2%F ^ i)%F) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation15: forall (n : nat) (_in : F) (out : (list F)) (i : nat) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (v : F), True -> Forall (fun x13 => True) out -> ((length out) = n) -> (i < n) -> match lc1_e2 with (x14,x15) => (x14 = (as_le_f (out[:i]))) end -> match lc1_e2 with (x14,x15) => (x15 = (2%F ^ i)%F) end -> match lc1_e2 with (x14,x15) => True end -> (lc1 = (as_le_f (out[:i]))) -> (e2 = (2%F ^ i)%F) -> True -> (((v = (as_le_f (out[:i]))) /\ (v = lc1)) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation16: forall (n : nat) (_in : F) (out : (list F)) (i : nat) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (v : F), True -> Forall (fun x16 => True) out -> ((length out) = n) -> (i < n) -> match lc1_e2 with (x17,x18) => (x17 = (as_le_f (out[:i]))) end -> match lc1_e2 with (x17,x18) => (x18 = (2%F ^ i)%F) end -> match lc1_e2 with (x17,x18) => True end -> (lc1 = (as_le_f (out[:i]))) -> (e2 = (2%F ^ i)%F) -> True -> ((v = (out!i)) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation17: forall (n : nat) (_in : F) (out : (list F)) (i : nat) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (v : F), True -> Forall (fun x19 => True) out -> ((length out) = n) -> (i < n) -> match lc1_e2 with (x20,x21) => (x20 = (as_le_f (out[:i]))) end -> match lc1_e2 with (x20,x21) => (x21 = (2%F ^ i)%F) end -> match lc1_e2 with (x20,x21) => True end -> (lc1 = (as_le_f (out[:i]))) -> (e2 = (2%F ^ i)%F) -> True -> (((v = (2%F ^ i)%F) /\ (v = e2)) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation18: forall (n : nat) (_in : F) (out : (list F)) (i : nat) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (v : F), True -> Forall (fun x22 => True) out -> ((length out) = n) -> (i < n) -> match lc1_e2 with (x23,x24) => (x23 = (as_le_f (out[:i]))) end -> match lc1_e2 with (x23,x24) => (x24 = (2%F ^ i)%F) end -> match lc1_e2 with (x23,x24) => True end -> (lc1 = (as_le_f (out[:i]))) -> (e2 = (2%F ^ i)%F) -> True -> ((v = ((out!i) * e2)%F) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation19: forall (n : nat) (_in : F) (out : (list F)) (i : nat) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (v : F), True -> Forall (fun x25 => True) out -> ((length out) = n) -> (i < n) -> match lc1_e2 with (x26,x27) => (x26 = (as_le_f (out[:i]))) end -> match lc1_e2 with (x26,x27) => (x27 = (2%F ^ i)%F) end -> match lc1_e2 with (x26,x27) => True end -> (lc1 = (as_le_f (out[:i]))) -> (e2 = (2%F ^ i)%F) -> True -> (((v = (2%F ^ i)%F) /\ (v = e2)) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation20: forall (n : nat) (_in : F) (out : (list F)) (i : nat) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (v : F), True -> Forall (fun x28 => True) out -> ((length out) = n) -> (i < n) -> match lc1_e2 with (x29,x30) => (x29 = (as_le_f (out[:i]))) end -> match lc1_e2 with (x29,x30) => (x30 = (2%F ^ i)%F) end -> match lc1_e2 with (x29,x30) => True end -> (lc1 = (as_le_f (out[:i]))) -> (e2 = (2%F ^ i)%F) -> True -> (((v = (2%F ^ i)%F) /\ (v = e2)) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation21: forall (n : nat) (_in : F) (out : (list F)) (i : nat) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (v : F * F), True -> Forall (fun x31 => True) out -> ((length out) = n) -> (i < n) -> match lc1_e2 with (x32,x33) => (x32 = (as_le_f (out[:i]))) end -> match lc1_e2 with (x32,x33) => (x33 = (2%F ^ i)%F) end -> match lc1_e2 with (x32,x33) => True end -> (lc1 = (as_le_f (out[:i]))) -> (e2 = (2%F ^ i)%F) -> match v with (x34,x35) => (x34 = (lc1 + ((out!i) * e2)%F)%F) end -> match v with (x34,x35) => (x35 = (e2 + e2)%F) end -> match v with (x34,x35) => True end -> (True -> True).
Proof. Admitted.

Lemma Num2Bits_obligation22: forall (n : nat) (_in : F) (out : (list F)) (i : nat) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (v : F), True -> Forall (fun x36 => True) out -> ((length out) = n) -> (i < n) -> match lc1_e2 with (x37,x38) => (x37 = (as_le_f (out[:i]))) end -> match lc1_e2 with (x37,x38) => (x38 = (2%F ^ i)%F) end -> match lc1_e2 with (x37,x38) => True end -> (lc1 = (as_le_f (out[:i]))) -> (e2 = (2%F ^ i)%F) -> True -> ((v = (lc1 + ((out!i) * e2)%F)%F) -> (v = (as_le_f (out[:(i + 1%nat)%nat])))).
Proof. Admitted.

Lemma Num2Bits_obligation23: forall (n : nat) (_in : F) (out : (list F)) (i : nat) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (v : F), True -> Forall (fun x39 => True) out -> ((length out) = n) -> (i < n) -> match lc1_e2 with (x40,x41) => (x40 = (as_le_f (out[:i]))) end -> match lc1_e2 with (x40,x41) => (x41 = (2%F ^ i)%F) end -> match lc1_e2 with (x40,x41) => True end -> (lc1 = (as_le_f (out[:i]))) -> (e2 = (2%F ^ i)%F) -> True -> ((v = (e2 + e2)%F) -> (v = (2%F ^ (i + 1%nat)%nat)%F)).
Proof. Admitted.

Lemma Num2Bits_obligation24: forall (n : nat) (_in : F) (out : (list F)) (v : F), True -> Forall (fun x42 => True) out -> ((length out) = n) -> True -> ((v = 0%F) -> (v = (as_le_f (out[:0%nat])))).
Proof. Admitted.

Lemma Num2Bits_obligation25: forall (n : nat) (_in : F) (out : (list F)) (v : F), True -> Forall (fun x43 => True) out -> ((length out) = n) -> True -> ((v = 1%F) -> (v = (2%F ^ 0%nat)%F)).
Proof. Admitted.

Lemma Num2Bits_obligation26: forall (n : nat) (_in : F) (out : (list F)) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (u0 : unit) (v : Z), True -> Forall (fun x44 => True) out -> ((length out) = n) -> match lc1_e2 with (x45,x46) => (x45 = (as_le_f (out[:n]))) end -> match lc1_e2 with (x45,x46) => (x46 = (2%F ^ n)%F) end -> match lc1_e2 with (x45,x46) => True end -> (lc1 = (as_le_f (out[:n]))) -> (e2 = (2%F ^ n)%F) -> (_in = lc1) -> True -> ((v = 0%nat) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation27: forall (n : nat) (_in : F) (out : (list F)) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (u0 : unit) (v : Z), True -> Forall (fun x47 => True) out -> ((length out) = n) -> match lc1_e2 with (x48,x49) => (x48 = (as_le_f (out[:n]))) end -> match lc1_e2 with (x48,x49) => (x49 = (2%F ^ n)%F) end -> match lc1_e2 with (x48,x49) => True end -> (lc1 = (as_le_f (out[:n]))) -> (e2 = (2%F ^ n)%F) -> (_in = lc1) -> True -> (((0%nat <= v) /\ (v = n)) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation28: forall (n : nat) (_in : F) (out : (list F)) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (u0 : unit) (v : Z), True -> Forall (fun x50 => True) out -> ((length out) = n) -> match lc1_e2 with (x51,x52) => (x51 = (as_le_f (out[:n]))) end -> match lc1_e2 with (x51,x52) => (x52 = (2%F ^ n)%F) end -> match lc1_e2 with (x51,x52) => True end -> (lc1 = (as_le_f (out[:n]))) -> (e2 = (2%F ^ n)%F) -> (_in = lc1) -> True -> (((0%nat <= v) /\ (v < n)) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation29: forall (n : nat) (_in : F) (out : (list F)) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (u0 : unit) (i : nat) (v : unit), True -> Forall (fun x53 => True) out -> ((length out) = n) -> match lc1_e2 with (x54,x55) => (x54 = (as_le_f (out[:n]))) end -> match lc1_e2 with (x54,x55) => (x55 = (2%F ^ n)%F) end -> match lc1_e2 with (x54,x55) => True end -> (lc1 = (as_le_f (out[:n]))) -> (e2 = (2%F ^ n)%F) -> (_in = lc1) -> (i < n) -> True -> ((forall (j:nat), 0%nat <= j < i -> (((out!j) = 0%F) \/ ((out!j) = 1%F))) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation30: forall (n : nat) (_in : F) (out : (list F)) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (u0 : unit) (i : nat) (u : unit) (v : F), True -> Forall (fun x56 => True) out -> ((length out) = n) -> match lc1_e2 with (x57,x58) => (x57 = (as_le_f (out[:n]))) end -> match lc1_e2 with (x57,x58) => (x58 = (2%F ^ n)%F) end -> match lc1_e2 with (x57,x58) => True end -> (lc1 = (as_le_f (out[:n]))) -> (e2 = (2%F ^ n)%F) -> (_in = lc1) -> (i < n) -> (forall (j:nat), 0%nat <= j < i -> (((out!j) = 0%F) \/ ((out!j) = 1%F))) -> True -> ((v = (out!i)) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation31: forall (n : nat) (_in : F) (out : (list F)) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (u0 : unit) (i : nat) (u : unit) (v : F), True -> Forall (fun x59 => True) out -> ((length out) = n) -> match lc1_e2 with (x60,x61) => (x60 = (as_le_f (out[:n]))) end -> match lc1_e2 with (x60,x61) => (x61 = (2%F ^ n)%F) end -> match lc1_e2 with (x60,x61) => True end -> (lc1 = (as_le_f (out[:n]))) -> (e2 = (2%F ^ n)%F) -> (_in = lc1) -> (i < n) -> (forall (j:nat), 0%nat <= j < i -> (((out!j) = 0%F) \/ ((out!j) = 1%F))) -> True -> ((v = (out!i)) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation32: forall (n : nat) (_in : F) (out : (list F)) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (u0 : unit) (i : nat) (u : unit) (v : F), True -> Forall (fun x62 => True) out -> ((length out) = n) -> match lc1_e2 with (x63,x64) => (x63 = (as_le_f (out[:n]))) end -> match lc1_e2 with (x63,x64) => (x64 = (2%F ^ n)%F) end -> match lc1_e2 with (x63,x64) => True end -> (lc1 = (as_le_f (out[:n]))) -> (e2 = (2%F ^ n)%F) -> (_in = lc1) -> (i < n) -> (forall (j:nat), 0%nat <= j < i -> (((out!j) = 0%F) \/ ((out!j) = 1%F))) -> True -> ((v = 1%F) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation33: forall (n : nat) (_in : F) (out : (list F)) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (u0 : unit) (i : nat) (u : unit) (v : F), True -> Forall (fun x65 => True) out -> ((length out) = n) -> match lc1_e2 with (x66,x67) => (x66 = (as_le_f (out[:n]))) end -> match lc1_e2 with (x66,x67) => (x67 = (2%F ^ n)%F) end -> match lc1_e2 with (x66,x67) => True end -> (lc1 = (as_le_f (out[:n]))) -> (e2 = (2%F ^ n)%F) -> (_in = lc1) -> (i < n) -> (forall (j:nat), 0%nat <= j < i -> (((out!j) = 0%F) \/ ((out!j) = 1%F))) -> True -> ((v = ((out!i) - 1%F)%F) -> True).
Proof. Admitted.

Lemma Num2Bits_obligation34: forall (n : nat) (_in : F) (out : (list F)) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (u0 : unit) (i : nat) (u : unit) (v : unit), True -> Forall (fun x68 => True) out -> ((length out) = n) -> match lc1_e2 with (x69,x70) => (x69 = (as_le_f (out[:n]))) end -> match lc1_e2 with (x69,x70) => (x70 = (2%F ^ n)%F) end -> match lc1_e2 with (x69,x70) => True end -> (lc1 = (as_le_f (out[:n]))) -> (e2 = (2%F ^ n)%F) -> (_in = lc1) -> (i < n) -> (forall (j:nat), 0%nat <= j < i -> (((out!j) = 0%F) \/ ((out!j) = 1%F))) -> True -> ((((out!i) * ((out!i) - 1%F)%F)%F = 0%F) -> (forall (j:nat), 0%nat <= j < (i + 1%nat)%nat -> (((out!j) = 0%F) \/ ((out!j) = 1%F)))).
Proof. Admitted.

Lemma Num2Bits_obligation35: forall (n : nat) (_in : F) (out : (list F)) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (u0 : unit) (v : unit), True -> Forall (fun x71 => True) out -> ((length out) = n) -> match lc1_e2 with (x72,x73) => (x72 = (as_le_f (out[:n]))) end -> match lc1_e2 with (x72,x73) => (x73 = (2%F ^ n)%F) end -> match lc1_e2 with (x72,x73) => True end -> (lc1 = (as_le_f (out[:n]))) -> (e2 = (2%F ^ n)%F) -> (_in = lc1) -> True -> (True -> (forall (j:nat), 0%nat <= j < 0%nat -> (((out!j) = 0%F) \/ ((out!j) = 1%F)))).
Proof. Admitted.

Lemma Num2Bits_obligation36: forall (n : nat) (_in : F) (out : (list F)) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (u0 : unit) (u : unit) (v : (list F)), True -> Forall (fun x74 => True) out -> ((length out) = n) -> match lc1_e2 with (x75,x76) => (x75 = (as_le_f (out[:n]))) end -> match lc1_e2 with (x75,x76) => (x76 = (2%F ^ n)%F) end -> match lc1_e2 with (x75,x76) => True end -> (lc1 = (as_le_f (out[:n]))) -> (e2 = (2%F ^ n)%F) -> (_in = lc1) -> (forall (j:nat), 0%nat <= j < n -> (((out!j) = 0%F) \/ ((out!j) = 1%F))) -> Forall (fun x77 => True) v -> True -> ((((length v) = n) /\ (v = out)) -> (((as_le_f v) = _in) /\ (forall (i0:nat), 0%nat <= i0 < (length v) -> (((v!i0) = 0%F) \/ ((v!i0) = 1%F))))).
Proof. Admitted.

(** ** Bits2Num *)

(* print_endline (generate_lemmas bits2num (typecheck_circuit d_empty bits2num));; *)

Lemma Bits2Num_obligation0: forall (n : nat) (_in : (list F)) (v : Z), Forall (fun x78 => ((x78 = 0%F) \/ (x78 = 1%F))) _in -> ((length _in) = n) -> True -> ((v = 0%nat) -> True).
Proof. Admitted.

Lemma Bits2Num_obligation1: forall (n : nat) (_in : (list F)) (v : Z), Forall (fun x79 => ((x79 = 0%F) \/ (x79 = 1%F))) _in -> ((length _in) = n) -> True -> (((0%nat <= v) /\ (v = n)) -> True).
Proof. Admitted.

Lemma Bits2Num_obligation2: forall (n : nat) (_in : (list F)) (v : Z), Forall (fun x80 => ((x80 = 0%F) \/ (x80 = 1%F))) _in -> ((length _in) = n) -> True -> (((0%nat <= v) /\ (v < n)) -> True).
Proof. Admitted.

Lemma Bits2Num_obligation3: forall (n : nat) (_in : (list F)) (i : nat) (v : F), Forall (fun x81 => ((x81 = 0%F) \/ (x81 = 1%F))) _in -> ((length _in) = n) -> (i < n) -> True -> ((v = (as_le_f (_in[:i]))) -> True).
Proof. Admitted.

Lemma Bits2Num_obligation4: forall (n : nat) (_in : (list F)) (i : nat) (v : F), Forall (fun x82 => ((x82 = 0%F) \/ (x82 = 1%F))) _in -> ((length _in) = n) -> (i < n) -> True -> ((v = (2%F ^ i)%F) -> True).
Proof. Admitted.

Lemma Bits2Num_obligation5: forall (n : nat) (_in : (list F)) (i : nat) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (v : F), Forall (fun x83 => ((x83 = 0%F) \/ (x83 = 1%F))) _in -> ((length _in) = n) -> (i < n) -> match lc1_e2 with (x84,x85) => (x84 = (as_le_f (_in[:i]))) end -> match lc1_e2 with (x84,x85) => (x85 = (2%F ^ i)%F) end -> match lc1_e2 with (x84,x85) => True end -> (lc1 = (as_le_f (_in[:i]))) -> (e2 = (2%F ^ i)%F) -> True -> (((v = (as_le_f (_in[:i]))) /\ (v = lc1)) -> True).
Proof. Admitted.

Lemma Bits2Num_obligation6: forall (n : nat) (_in : (list F)) (i : nat) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (v : F), Forall (fun x86 => ((x86 = 0%F) \/ (x86 = 1%F))) _in -> ((length _in) = n) -> (i < n) -> match lc1_e2 with (x87,x88) => (x87 = (as_le_f (_in[:i]))) end -> match lc1_e2 with (x87,x88) => (x88 = (2%F ^ i)%F) end -> match lc1_e2 with (x87,x88) => True end -> (lc1 = (as_le_f (_in[:i]))) -> (e2 = (2%F ^ i)%F) -> True -> ((v = (_in!i)) -> True).
Proof. Admitted.

Lemma Bits2Num_obligation7: forall (n : nat) (_in : (list F)) (i : nat) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (v : F), Forall (fun x89 => ((x89 = 0%F) \/ (x89 = 1%F))) _in -> ((length _in) = n) -> (i < n) -> match lc1_e2 with (x90,x91) => (x90 = (as_le_f (_in[:i]))) end -> match lc1_e2 with (x90,x91) => (x91 = (2%F ^ i)%F) end -> match lc1_e2 with (x90,x91) => True end -> (lc1 = (as_le_f (_in[:i]))) -> (e2 = (2%F ^ i)%F) -> True -> (((v = (2%F ^ i)%F) /\ (v = e2)) -> True).
Proof. Admitted.

Lemma Bits2Num_obligation8: forall (n : nat) (_in : (list F)) (i : nat) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (v : F), Forall (fun x92 => ((x92 = 0%F) \/ (x92 = 1%F))) _in -> ((length _in) = n) -> (i < n) -> match lc1_e2 with (x93,x94) => (x93 = (as_le_f (_in[:i]))) end -> match lc1_e2 with (x93,x94) => (x94 = (2%F ^ i)%F) end -> match lc1_e2 with (x93,x94) => True end -> (lc1 = (as_le_f (_in[:i]))) -> (e2 = (2%F ^ i)%F) -> True -> ((v = ((_in!i) * e2)%F) -> True).
Proof. Admitted.

Lemma Bits2Num_obligation9: forall (n : nat) (_in : (list F)) (i : nat) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (v : F), Forall (fun x95 => ((x95 = 0%F) \/ (x95 = 1%F))) _in -> ((length _in) = n) -> (i < n) -> match lc1_e2 with (x96,x97) => (x96 = (as_le_f (_in[:i]))) end -> match lc1_e2 with (x96,x97) => (x97 = (2%F ^ i)%F) end -> match lc1_e2 with (x96,x97) => True end -> (lc1 = (as_le_f (_in[:i]))) -> (e2 = (2%F ^ i)%F) -> True -> (((v = (2%F ^ i)%F) /\ (v = e2)) -> True).
Proof. Admitted.

Lemma Bits2Num_obligation10: forall (n : nat) (_in : (list F)) (i : nat) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (v : F), Forall (fun x98 => ((x98 = 0%F) \/ (x98 = 1%F))) _in -> ((length _in) = n) -> (i < n) -> match lc1_e2 with (x99,x100) => (x99 = (as_le_f (_in[:i]))) end -> match lc1_e2 with (x99,x100) => (x100 = (2%F ^ i)%F) end -> match lc1_e2 with (x99,x100) => True end -> (lc1 = (as_le_f (_in[:i]))) -> (e2 = (2%F ^ i)%F) -> True -> (((v = (2%F ^ i)%F) /\ (v = e2)) -> True).
Proof. Admitted.

Lemma Bits2Num_obligation11: forall (n : nat) (_in : (list F)) (i : nat) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (v : F * F), Forall (fun x101 => ((x101 = 0%F) \/ (x101 = 1%F))) _in -> ((length _in) = n) -> (i < n) -> match lc1_e2 with (x102,x103) => (x102 = (as_le_f (_in[:i]))) end -> match lc1_e2 with (x102,x103) => (x103 = (2%F ^ i)%F) end -> match lc1_e2 with (x102,x103) => True end -> (lc1 = (as_le_f (_in[:i]))) -> (e2 = (2%F ^ i)%F) -> match v with (x104,x105) => (x104 = (lc1 + ((_in!i) * e2)%F)%F) end -> match v with (x104,x105) => (x105 = (e2 + e2)%F) end -> match v with (x104,x105) => True end -> (True -> True).
Proof. Admitted.

Lemma Bits2Num_obligation12: forall (n : nat) (_in : (list F)) (i : nat) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (v : F), Forall (fun x106 => ((x106 = 0%F) \/ (x106 = 1%F))) _in -> ((length _in) = n) -> (i < n) -> match lc1_e2 with (x107,x108) => (x107 = (as_le_f (_in[:i]))) end -> match lc1_e2 with (x107,x108) => (x108 = (2%F ^ i)%F) end -> match lc1_e2 with (x107,x108) => True end -> (lc1 = (as_le_f (_in[:i]))) -> (e2 = (2%F ^ i)%F) -> True -> ((v = (lc1 + ((_in!i) * e2)%F)%F) -> (v = (as_le_f (_in[:(i + 1%nat)%nat])))).
Proof. Admitted.

Lemma Bits2Num_obligation13: forall (n : nat) (_in : (list F)) (i : nat) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (v : F), Forall (fun x109 => ((x109 = 0%F) \/ (x109 = 1%F))) _in -> ((length _in) = n) -> (i < n) -> match lc1_e2 with (x110,x111) => (x110 = (as_le_f (_in[:i]))) end -> match lc1_e2 with (x110,x111) => (x111 = (2%F ^ i)%F) end -> match lc1_e2 with (x110,x111) => True end -> (lc1 = (as_le_f (_in[:i]))) -> (e2 = (2%F ^ i)%F) -> True -> ((v = (e2 + e2)%F) -> (v = (2%F ^ (i + 1%nat)%nat)%F)).
Proof. Admitted.

Lemma Bits2Num_obligation14: forall (n : nat) (_in : (list F)) (v : F), Forall (fun x112 => ((x112 = 0%F) \/ (x112 = 1%F))) _in -> ((length _in) = n) -> True -> ((v = 0%F) -> (v = (as_le_f (_in[:0%nat])))).
Proof. Admitted.

Lemma Bits2Num_obligation15: forall (n : nat) (_in : (list F)) (v : F), Forall (fun x113 => ((x113 = 0%F) \/ (x113 = 1%F))) _in -> ((length _in) = n) -> True -> ((v = 1%F) -> (v = (2%F ^ 0%nat)%F)).
Proof. Admitted.

Lemma Bits2Num_obligation16: forall (n : nat) (_in : (list F)) (lc1_e2 : F * F) (lc1 : F) (e2 : F) (v : F), Forall (fun x114 => ((x114 = 0%F) \/ (x114 = 1%F))) _in -> ((length _in) = n) -> match lc1_e2 with (x115,x116) => (x115 = (as_le_f (_in[:n]))) end -> match lc1_e2 with (x115,x116) => (x116 = (2%F ^ n)%F) end -> match lc1_e2 with (x115,x116) => True end -> (lc1 = (as_le_f (_in[:n]))) -> (e2 = (2%F ^ n)%F) -> True -> (((v = (as_le_f (_in[:n]))) /\ (v = lc1)) -> (v = (as_le_f _in))).
Proof. Admitted.


From isla Require Import opsem.

Definition a30 : isla_trace :=
  Smt (DeclareConst 0%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "PC" [] (RegVal_Base (Val_Symbolic 0%Z)) Mk_annot :t:
  Smt (DefineConst 1%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 0%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DeclareConst 13%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "x10" [] (RegVal_Base (Val_Symbolic 13%Z)) Mk_annot :t:
  Smt (DefineConst 14%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 13%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x0%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "x20" [] (RegVal_Base (Val_Symbolic 14%Z)) Mk_annot :t:
  WriteReg "PC" [] (RegVal_Base (Val_Symbolic 1%Z)) Mk_annot :t:
  tnil
.


Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.

Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.
Require Import TypeTheory.TypeCat.TypeCat.
Require Import TypeTheory.TypeCat.General.
Require Import TypeTheory.TypeCat.Structure.
Require Import TypeTheory.Initiality.Syntax.
Require Import TypeTheory.Initiality.SyntaxLemmas.
Require Import TypeTheory.Initiality.Typing.
Require Import TypeTheory.Initiality.TypingLemmas.
Require Import TypeTheory.Initiality.SyntacticCategory.

Section Universe_Structure.

  Local Definition basetype_struct_syntactic_typecat :
    basetype_struct syntactic_typecat.
  Proof.
    use tpair.
    + intros ΓΓ.
      apply setquotpr.
      exists U_expr.
      intros Γ.
      apply hinhpr, derive_U.
    + simpl; intros ΓΓ ΔΔ.
      use setquotunivprop'. { intros; apply isasetsetquot. } intros f.
      apply iscompsetquotpr; cbn.
      intros Δ.
      apply hinhpr, derive_tyeq_refl, derive_U.
  Defined.

  Local Definition deptype_struct_syntactic_typecat :
    deptype_struct _ basetype_struct_syntactic_typecat.
  Proof.
    use tpair.
    - cbn.
      intros ΓΓ [t ht].
      apply (take_context_representative ΓΓ). { admit. } intros Γ.
      revert t ht; use setquotunivprop'. { admit. } simpl; intros f hf.
      use setquotpr.
      use tpair.
      + apply El_expr.
        admit. (* How to turn a tm into a tm_expr? *)
      + simpl.
        admit.
    - admit.
  Admitted. (* [deptype_struct_syntactic_typecat]: reasonably self-contained, probably needs a little more infrastructure on syntactic cat *)

  Local Definition univ :
    universe_struct syntactic_typecat
    := (basetype_struct_syntactic_typecat,,deptype_struct_syntactic_typecat).

End Universe_Structure.

Section Pi_Structure.

  Local Definition pi_form_struct_syntactic_typecat :
    pi_form_struct syntactic_typecat.
  Admitted. (* [pi_form_struct_syntactic_typecat]: reasonably self-contained, probably needs a little more infrastructure on syntactic cat *)

  Local Definition pi_intro_struct_syntactic_typecat :
    pi_intro_struct _ pi_form_struct_syntactic_typecat.
  Admitted. (* [pi_intro_struct_syntactic_typecat]: depends on [pi_form_…], thereafter reasonably self-contained *)

  Local Definition pi_app_struct_syntactic_typecat :
    pi_app_struct _ pi_form_struct_syntactic_typecat.
  Admitted. (* [pi_app_struct_syntactic_typecat]: depends on [pi_form_…], thereafter reasonably self-contained *)

  Local Definition pi_comp_struct_syntactic_typecat :
    pi_comp_struct syntactic_typecat pi_intro_struct_syntactic_typecat
                                     pi_app_struct_syntactic_typecat.
  Admitted. (* [pi_comp_struct_syntactic_typecat]: depends on [pi_intro_…] and [pi_app_…], thereafter reasonably self-contained *)

  Local Definition pi : pi_struct syntactic_typecat
    := (pi_form_struct_syntactic_typecat,,
       (pi_intro_struct_syntactic_typecat,,pi_app_struct_syntactic_typecat),,
        pi_comp_struct_syntactic_typecat).

End Pi_Structure.


Require Import Raft.
Require Import RaftRefinementInterface.

Section InLogInAllEntries.

  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition in_log_in_all_entries net :=
    forall h e,
      In e (log (snd (nwState net h))) ->
      exists t,
        In (t, e) (allEntries (fst (nwState net h))).

  Class in_log_in_all_entries_interface : Prop :=
    {
      in_log_in_all_entries_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          in_log_in_all_entries net
    }.
End InLogInAllEntries.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^251 - 9
Base: 22 + 9/11
***)

Definition curve : CurveParameters :=
  {|
    sz := 11%nat;
    base := 22 + 9/11;
    bitwidth := 32;
    s := 2^251;
    c := [(1, 9)];
    carry_chains := Some [seq 0 (pred 11); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e194m33_8limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


(** * Autosubst Header for Unnamed Syntax

Version: December 11, 2019.
 *)

(* Adrian:
 I changed this library a bit to work better with my generated code.
 1. I use nat directly instead of defining fin to be nat and using Some/None as S/O
 2. I removed the "s, sigma" notation for scons because it interacts with dependent function types "forall x, A"*)
From LogRel.AutoSubst Require Import core.
Require Import Setoid Morphisms Relation_Definitions.

Definition ap {X Y} (f : X -> Y) {x y : X} (p : x = y) : f x = f y :=
  match p with eq_refl => eq_refl end.

Definition apc {X Y} {f g : X -> Y} {x y : X} (p : f = g) (q : x = y) : f x = g y :=
  match q with eq_refl => match p with eq_refl => eq_refl end end.

(** ** Primitives of the Sigma Calculus. *)

Definition shift  := S.

Definition var_zero := 0.

Definition id {X} := @Datatypes.id X.

Definition scons {X: Type} (x : X) (xi : nat -> X) :=
  fun n => match n with
        | 0 => x
        | S n => xi n
        end.

#[ export ]
Hint Opaque scons : rewrite.

(** ** Type Class Instances for Notation
Required to make notation work. *)

(** *** Type classes for renamings. *)

Class Ren1 (X1  : Type) (Y Z : Type) :=
  ren1 : X1 -> Y -> Z.

Class Ren2 (X1 X2 : Type) (Y Z : Type) :=
  ren2 : X1 -> X2 -> Y -> Z.

Class Ren3 (X1 X2 X3 : Type) (Y Z : Type) :=
  ren3 : X1 -> X2 -> X3 -> Y -> Z.

Class Ren4 (X1 X2 X3 X4 : Type) (Y Z : Type) :=
  ren4 : X1 -> X2 -> X3 -> X4 -> Y -> Z.

Class Ren5 (X1 X2 X3 X4 X5 : Type) (Y Z : Type) :=
  ren5 : X1 -> X2 -> X3 -> X4 -> X5 -> Y -> Z.

Module RenNotations.
  Notation "s ⟨ xi1 ⟩" := (ren1 xi1 s) (at level 7, left associativity, format "s  ⟨ xi1 ⟩") : subst_scope.

  Notation "s ⟨ xi1 ; xi2 ⟩" := (ren2 xi1 xi2 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ⟩") : subst_scope.

  Notation "s ⟨ xi1 ; xi2 ; xi3 ⟩" := (ren3 xi1 xi2 xi3 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ⟩") : subst_scope.

  Notation "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ⟩" := (ren4  xi1 xi2 xi3 xi4 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ; xi4 ⟩") : subst_scope.

  Notation "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ; xi5 ⟩" := (ren5  xi1 xi2 xi3 xi4 xi5 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ; xi4 ; xi5 ⟩") : subst_scope.

  Notation "⟨ xi ⟩" := (ren1 xi) (at level 1, left associativity, format "⟨ xi ⟩") : fscope.

  Notation "⟨ xi1 ; xi2 ⟩" := (ren2 xi1 xi2) (at level 1, left associativity, format "⟨ xi1 ; xi2 ⟩") : fscope.
End RenNotations.

(** *** Type Classes for Substiution *)

Class Subst1 (X1 : Type) (Y Z: Type) :=
  subst1 : X1 -> Y -> Z.

Class Subst2 (X1 X2 : Type) (Y Z: Type) :=
  subst2 : X1 -> X2 -> Y  -> Z.

Class Subst3 (X1 X2 X3 : Type) (Y Z: Type) :=
  subst3 : X1 -> X2 -> X3 ->  Y  -> Z.

Class Subst4 (X1 X2 X3 X4: Type) (Y Z: Type) :=
  subst4 : X1 -> X2 -> X3 -> X4 -> Y  -> Z.

Class Subst5 (X1 X2 X3 X4 X5 : Type) (Y Z: Type) :=
  subst5 : X1 -> X2 -> X3 -> X4 -> X5  -> Y  -> Z.

Module SubstNotations.
  Notation "s [ sigma ]" := (subst1 sigma s) (at level 7, left associativity, format "s '/' [ sigma ]") : subst_scope.

  Notation "s [ sigma ; tau ]" := (subst2 sigma tau s) (at level 7, left associativity, format "s '/' [ sigma ; '/'  tau ]") : subst_scope.
End SubstNotations.

(** *** Type Class for Variables *)

Class Var X Y :=
  ids : X -> Y.

#[global] Instance idsRen : Var nat nat := id.

(** ** Proofs for the substitution primitives. *)

Arguments funcomp {X Y Z} (g)%fscope (f)%fscope.

Module CombineNotations.
  Notation "f >> g" := (funcomp g f) (at level 50) : fscope.

  Notation "s .: sigma" := (scons s sigma) (at level 55, sigma at next level, right associativity) : subst_scope.

  #[ global ]
  Open Scope fscope.
  #[ global ]
  Open Scope subst_scope.
End CombineNotations.

Import CombineNotations.

(** A generic lifting of a renaming. *)
Definition up_ren (xi : nat -> nat) :=
  0 .: (xi >> S).

(** A generic proof that lifting of renamings composes. *)
Lemma up_ren_ren (xi: nat -> nat) (zeta : nat -> nat) (rho: nat -> nat) (E: forall x, (xi >> zeta) x = rho x) :
  forall x, (up_ren xi >> up_ren zeta) x = up_ren rho x.
Proof.
  intros [|x].
  - reflexivity.
  - unfold up_ren. cbn. unfold funcomp. f_equal. apply E.
Qed.

(** Eta laws. *)
Lemma scons_eta' {T} (f : nat -> T) :
  pointwise_relation _ eq (f var_zero .: (funcomp f shift)) f.
Proof. intros x. destruct x; reflexivity. Qed.

Lemma scons_eta_id' :
  pointwise_relation _ eq (var_zero .: shift) id.
Proof. intros x. destruct x; reflexivity. Qed.

Lemma scons_comp' (T: Type) {U} (s: T) (sigma: nat -> T) (tau: T -> U) :
  pointwise_relation _ eq (funcomp tau (s .: sigma)) ((tau s) .: (funcomp tau sigma)).
Proof. intros x. destruct x; reflexivity. Qed.

(* Morphism for Setoid Rewriting. The only morphism that can be defined statically. *)
#[global] Instance scons_morphism {X: Type} :
  Proper (eq ==> pointwise_relation _ eq ==> pointwise_relation _ eq) (@scons X).
Proof.
  intros ? t -> sigma tau H.
  intros [|x].
  cbn. reflexivity.
  apply H.
Qed.

#[global] Instance scons_morphism2 {X: Type} :
  Proper (eq ==> pointwise_relation _ eq ==> eq ==> eq) (@scons X).
Proof.
  intros ? t -> sigma tau H ? x ->.
  destruct x as [|x].
  cbn. reflexivity.
  apply H.
Qed.

(** ** Generic lifting of an allfv predicate *)
Definition up_allfv (p: nat -> Prop) : nat -> Prop := scons True p.

(** ** Notations for unscoped syntax *)
Module UnscopedNotations.
  Include RenNotations.
  Include SubstNotations.
  Include CombineNotations.

  (* Notation "s , sigma" := (scons s sigma) (at level 60, format "s ,  sigma", right associativity) : subst_scope. *)

  Notation "s '..'" := (scons s ids) (at level 1, format "s ..") : subst_scope.

  Notation "↑" := (shift) : subst_scope.

  #[ global ]
  Open Scope subst_scope.
End UnscopedNotations.

(** ** Tactics for unscoped syntax *)

(** Automatically does a case analysis on a natural number, useful for proofs with context renamings/context morphisms. *)
Tactic Notation "auto_case" tactic(t) :=  (match goal with
                                           | [|- forall (i : nat), _] => intros []; t
                                           end).

(** Generic fsimpl tactic: simplifies the above primitives in a goal. *)
Ltac fsimpl :=
  repeat match goal with
         | [|- context[id >> ?f]] => change (id >> f) with f (* AsimplCompIdL *)
         | [|- context[?f >> id]] => change (f >> id) with f (* AsimplCompIdR *)
         | [|- context [id ?s]] => change (id s) with s
         | [|- context[(?f >> ?g) >> ?h]] => change ((f >> g) >> h) with (f >> (g >> h))
         | [|- context[(?v .: ?g) var_zero]] => change ((v .: g) var_zero) with v
         | [|- context[(?v .: ?g) 0]] => change ((v .: g) 0) with v
         | [|- context[(?v .: ?g) (S ?n)]] => change ((v .: g) (S n)) with (g n)
         | [|- context[?f >> (?x .: ?g)]] => change (f >> (x .: g)) with g (* f should evaluate to shift *)
         | [|- context[var_zero]] =>  change var_zero with 0
         | [|- context[?x2 .: (funcomp ?f shift)]] => change (scons x2 (funcomp f shift)) with (scons (f var_zero) (funcomp f shift)); setoid_rewrite (@scons_eta' _ _ f)
         | [|- context[?f var_zero .: ?g]] => change (scons (f var_zero) g) with (scons (f var_zero) (funcomp f shift)); rewrite scons_eta'
         | [|- _ =  ?h (?f ?s)] => change (h (f s)) with ((f >> h) s)
         | [|-  ?h (?f ?s) = _] => change (h (f s)) with ((f >> h) s)
         (* DONE had to put an underscore as the last argument to scons. This might be an argument against unfolding funcomp *)
         | [|- context[funcomp _ (scons _ _)]] => setoid_rewrite scons_comp'; eta_reduce
         | [|- context[scons var_zero shift]] => setoid_rewrite scons_eta_id'; eta_reduce
                        end.


From isla Require Import opsem.

Definition a18 : isla_trace :=
  Smt (DeclareConst 0%Z (Ty_BitVec 64%N)) Mk_annot :t:
  Assume (AExp_Binop (Eq) (AExp_Unop (Extract 1%N 1%N) (AExp_Val (AVal_Var "PC" []) Mk_annot) Mk_annot) (AExp_Val (AVal_Bits (BV 1%N 0x0%Z)) Mk_annot) Mk_annot) Mk_annot :t:
  ReadReg "PC" [] (RegVal_Base (Val_Symbolic 0%Z)) Mk_annot :t:
  Smt (DefineConst 1%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 0%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DeclareConst 13%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "x12" [] (RegVal_Base (Val_Symbolic 13%Z)) Mk_annot :t:
  Smt (DefineConst 14%Z (Unop (Not) (Binop (Eq) (Val (Val_Symbolic 13%Z) Mk_annot) (Val (Val_Bits (BV 64%N 0x0%Z)) Mk_annot) Mk_annot) Mk_annot)) Mk_annot :t:
  Smt (DefineConst 15%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 0%Z) Mk_annot; Val (Val_Bits (BV 64%N 0xffffffffffffffec%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  tcases [
    Smt (Assert (Val (Val_Symbolic 14%Z) Mk_annot)) Mk_annot :t:
    Smt (DefineConst 16%Z (Unop (Extract 0%N 0%N) (Binop ((Bvarith Bvlshr)) (Val (Val_Symbolic 15%Z) Mk_annot) (Val (Val_Bits (BV 64%N 0x1%Z)) Mk_annot) Mk_annot) Mk_annot)) Mk_annot :t:
    BranchAddress (RegVal_Base (Val_Symbolic 15%Z)) Mk_annot :t:
    WriteReg "PC" [] (RegVal_Base (Val_Symbolic 15%Z)) Mk_annot :t:
    tnil;
    Smt (Assert (Unop (Not) (Val (Val_Symbolic 14%Z) Mk_annot) Mk_annot)) Mk_annot :t:
    WriteReg "PC" [] (RegVal_Base (Val_Symbolic 1%Z)) Mk_annot :t:
    tnil
  ]
.


From Coq Require Import ssrnat seq.
Require Import Coq.Strings.String.

Definition list_pure {a : Type} (x : a) : seq a :=
  [::x].
Definition list_bind {a b : Type} (xs : seq a) (f : a -> seq b) : seq b :=
  List.flat_map f xs.
Definition list_then {a b : Type} (xs : seq a) (ys : seq b) : seq b :=
  list_bind xs (fun _ => ys).
Definition list_guard (b : bool) : seq unit :=
  if b then list_pure tt else [::].
Definition list_fail {a : Type} (s : string) : seq a :=
  [::].

Notation pure  := list_pure.
Infix ">>="    := list_bind (left associativity, at level 90).
Infix ">>"     := list_then (left associativity, at level 90).
Notation guard := list_guard.
Notation fail  := list_fail.

Notation even := Nat.even.


From BF Require Import Base Byte VM.

Record vm := VM {
  tape : list byte;
  ptr : N;
  inputs : list byte;
  outputs : list byte;
}.

Definition set_tape (t : list byte) (v : vm) : vm :=
  let (_, p, i, o) := v in VM t p i o.
Definition set_ptr (p : N) (v : vm) : vm :=
  let (t, _, i, o) := v in VM t p i o.
Definition set_inputs (i : list byte) (v : vm) : vm :=
  let (t, p, _, o) := v in VM t p i o.
Definition set_outputs (o : list byte) (v : vm) : vm :=
  let (t, p, i, _) := v in VM t p i o.

Definition ptr_rel (off : Z) (v : vm) : option N :=
  let i := ((Z.of_N v.(ptr)) + off)%Z in
  match i with
  | Z0 => Some N0
  | Zpos p => Some (Npos p)
  | Zneg _ => None
  end.

Definition move (n : Z) (v : vm) : option vm :=
  match ptr_rel n v with
  | Some p => Some (set_ptr p v)
  | None => None
  end.

Fixpoint list_map_nth {A : Type} (f : A -> A) (default : A) (n : nat) (l : list A) : list A :=
  match n, l with
  | O, [] => [f default]
  | O, h :: l' => f h :: l'
  | S n', [] => default :: list_map_nth f default n' []
  | S n', h :: l' => h :: list_map_nth f default n' l'
  end.

Definition map_cell (f : byte -> byte) (off : Z) (v : vm) : option vm :=
  match ptr_rel off v with
  | Some p => Some (set_tape (list_map_nth f #00 (N.to_nat p) v.(tape)) v)
  | None => None
  end.

Definition cell (v : vm) : byte :=
  nth (N.to_nat v.(ptr)) v.(tape) #00.

Definition cell_at (off : Z) (v : vm) : option byte :=
  match ptr_rel off v with
  | Some p => Some (nth (N.to_nat p) v.(tape) #00)
  | None => None
  end.

Definition set_cell (n : byte) := map_cell (fun _ => n).

Definition add_cell (n : byte) := map_cell (fun c => c + n).

Definition output (off : Z) (v : vm) : option vm :=
  match cell_at off v with
  | Some c => Some (set_outputs (c :: v.(outputs)) v)
  | None => None
  end.

Definition input (off : Z) (v : vm) : option vm :=
  match v.(inputs) with
  | h :: i' => set_cell h off (set_inputs i' v)
  | [] => None
  end.

Definition eq (v1 v2 : vm) : bool :=
  let (t1, p1, o1, i1) := v1 in
  let (t2, p2, o2, i2) := v2 in
  VM.list_byte_eq t1 t2 && (p1 =? p2)%N
    && VM.list_byte_eq o1 o2 && VM.list_byte_eq i1 i2.


(** * Ill-defined instances of Sitpn. *)

Require Import CoqLib.
Require Import sitpn.Sitpn.
Require Import sitpn.SitpnTypes.
Require Import NatSet.
Require Import GlobalTypes.
Require Import GenerateInfos.
Require Import String.
Require Import HexString.

Open Scope string_scope.

Set Implicit Arguments.

Local Notation "[ e ]" := (exist _ e _).

(** ** An [Sitpn] instance with an empty list of transitions. *)

Example sitpn_emp_transs :=
  @BuildSitpn
    [ 0; 1; 2 ]
    [ ]
    (fun p t => None)
    (fun t p => None)
    (fun p => 0)
    (fun t => None)
    [ ]
    [ ]
    [ ]
    (fun t c => zero)
    (fun p a => false)
    (fun t f => false)
    (fun t t' => False).

Definition prio_emp_transs_dec : forall x y : T sitpn_emp_transs, {x >~ y} + {~x >~ y}. auto. Defined.

(** ** An [Sitpn] instance with isolated places. *)

Definition places_iso_pls := [ 0; 1; 2 ].
Definition transs_iso_pls := [ 0; 1; 2 ].
Definition Piso := { p | List.In p places_iso_pls}.
Definition Tiso := { t | List.In t transs_iso_pls}.

(* Input arcs function. Here, place 2 is isolated. *)

Definition pre_iso_pls (p : Piso) (t : Tiso) : option (ArcT * natstar) :=
  match p, t with
  | [0], [0] => Some (basic, onens)
  | [1], [0] => Some (basic, onens)
  | [1], [1] => Some (basic, onens)
  | _, _ => None
  end.

Example sitpn_iso_pls :=
  @BuildSitpn
    places_iso_pls
    transs_iso_pls
    pre_iso_pls
    (fun t p => None)
    (fun p => 0)
    (fun t => None)
    [ ]
    [ ]
    [ ]
    (fun t c => zero)
    (fun p a => false)
    (fun t f => false)
    (fun t t' => False).

Definition prio_iso_pls_dec : forall x y : T sitpn_iso_pls, {x >~ y} + {~x >~ y}. auto. Defined.

Require Import transformation.GenerateHVhdl.

(* Compute (sitpn2hvhdl sitpn_iso_pls prio_iso_pls_dec 0 0 1). *)


Require Import Coq.ZArith.ZArith.
Require Import riscv.Decode.
Require Import riscv.Encode.
Require Import riscv.Utility.
Require Import riscv.util.Tactics.
Require Import riscv.util.div_mod_to_quot_rem.
Require Import riscv.util.prove_Zeq_bitwise.

Local Open Scope bool_scope.
Local Open Scope Z_scope.

Lemma encode_Fence_bitSlice_idemp: forall opcode funct3 z z0 z1 z2 z3,
    bitSlice (encode_Fence opcode z z0 funct3 z1 z2 z3) 0 32 =
              encode_Fence opcode z z0 funct3 z1 z2 z3.
Proof. intros. unfold encode_Fence. prove_Zeq_bitwise. Qed.

Lemma encode_Invalid_bitSlice_idemp: forall z,
     bitSlice (encode_Invalid z) 0 32 = encode_Invalid z.
Proof. intros. unfold encode_Invalid. prove_Zeq_bitwise. Qed.

Lemma encode_I_bitSlice_idemp: forall opcode r r0 funct3 z,
     bitSlice (encode_I opcode r r0 funct3 z) 0 32 = encode_I opcode r r0 funct3 z.
Proof. intros. unfold encode_I. prove_Zeq_bitwise. Qed.

Lemma encode_I_shift_57_bitSlice_idemp: forall opcode r r0 z funct3 funct7,
    bitSlice (encode_I_shift_57 opcode r r0 z funct3 funct7) 0 32 =
              encode_I_shift_57 opcode r r0 z funct3 funct7.
Proof. intros. unfold encode_I_shift_57. prove_Zeq_bitwise. Qed.

Lemma encode_I_shift_66_bitSlice_idemp: forall opcode r r0 z funct3 funct6,
    bitSlice (encode_I_shift_66 opcode r r0 z funct3 funct6) 0 32 =
              encode_I_shift_66 opcode r r0 z funct3 funct6.
Proof. intros. unfold encode_I_shift_66. prove_Zeq_bitwise. Qed.

Lemma encode_I_system_bitSlice_idemp: forall opcode r r0 funct3 z,
    bitSlice (encode_I_system opcode r r0 funct3 z) 0 32 =
              encode_I_system opcode r r0 funct3 z.
Proof. intros. unfold encode_I_system. prove_Zeq_bitwise. Qed.

Lemma encode_R_atomic_bitSlice_idemp: forall opcode r r0 r1 funct3 z funct5,
    bitSlice (encode_R_atomic opcode r r0 r1 funct3 z funct5) 0 32 =
              encode_R_atomic opcode r r0 r1 funct3 z funct5.
Proof. intros. unfold encode_R_atomic. prove_Zeq_bitwise. Qed.

Lemma encode_R_bitSlice_idemp: forall opcode z r r0 funct3 funct7,
    bitSlice (encode_R opcode z r r0 funct3 funct7) 0 32 =
              encode_R opcode z r r0 funct3 funct7.
Proof. intros. unfold encode_R. prove_Zeq_bitwise. Qed.

Lemma encode_SB_bitSlice_idemp: forall opcode r r0 funct3 z,
    bitSlice (encode_SB opcode r r0 funct3 z) 0 32 =
              encode_SB opcode r r0 funct3 z.
Proof. intros. unfold encode_SB. prove_Zeq_bitwise. Qed.

Lemma encode_S_bitSlice_idemp: forall opcode r r0 funct3 z,
    bitSlice (encode_S opcode r r0 funct3 z) 0 32 =
              encode_S opcode r r0 funct3 z.
Proof. intros. unfold encode_S. prove_Zeq_bitwise. Qed.

Lemma encode_UJ_bitSlice_idemp: forall opcode r z,
    bitSlice (encode_UJ opcode r z) 0 32 =
              encode_UJ opcode r z.
Proof. intros. unfold encode_UJ. prove_Zeq_bitwise. Qed.

Lemma encode_U_bitSlice_idemp: forall opcode r z,
    bitSlice (encode_U opcode r z) 0 32 =
              encode_U opcode r z.
Proof. intros. unfold encode_U. prove_Zeq_bitwise. Qed.

Hint Rewrite
  encode_Fence_bitSlice_idemp
  encode_Invalid_bitSlice_idemp
  encode_I_bitSlice_idemp
  encode_I_shift_57_bitSlice_idemp
  encode_I_shift_66_bitSlice_idemp
  encode_I_system_bitSlice_idemp
  encode_R_atomic_bitSlice_idemp
  encode_R_bitSlice_idemp
  encode_SB_bitSlice_idemp
  encode_S_bitSlice_idemp
  encode_UJ_bitSlice_idemp
  encode_U_bitSlice_idemp
: encode_bitSlice_idemp.

Lemma encode_bitSlice_idemp: forall (i: Instruction),
    bitSlice (encode i) 0 32 = encode i.
Proof.
  intros.
  unfold encode.
  repeat autounfold with mappers.
  destruct i as [i|i|i|i|i|i|i|i]; [destruct i..|];
    autorewrite with encode_bitSlice_idemp;
    reflexivity.
Qed.

Lemma encode_range: forall (i: Instruction),
    0 <= encode i < 2 ^ 32.
Proof.
  intros.
  rewrite <- encode_bitSlice_idemp.
  apply bitSlice_range.
  omega.
Qed.


From Coq Require Import ssreflect ssrfun ssrbool.

From stdpp Require Import base tactics sets.

From MatchingLogic.Utils
Require Import
    extralibrary
.

From MatchingLogic
Require Import
    Signature
    Pattern
    Substitution
    Freshness
    ApplicationContext
.

Import Substitution.Notations.

Section lemmas.
  Context {Σ : Signature}.
  Open Scope ml_scope.

  Lemma evar_is_fresh_in_subst_ctx x AC p:
    evar_is_fresh_in x (subst_ctx AC p)
    <-> (evar_is_fresh_in x p /\ x ∉ AC_free_evars AC).
  Proof.
    induction AC.
    - simpl. split; set_solver.
    - simpl. split; intros H.
      + assert (Hfr1: evar_is_fresh_in x (subst_ctx AC p)).
        { eapply evar_is_fresh_in_richer. 2: apply H. cbn. set_solver. }
        assert (Hfr2: evar_is_fresh_in x p0).
        { eapply evar_is_fresh_in_richer. 2: apply H. cbn. set_solver. }
        rewrite -> IHAC in Hfr1.
        split; [apply Hfr1|].
        clear -Hfr1 Hfr2.
        unfold evar_is_fresh_in in Hfr2.
        set_solver.
      + destruct H as [H1 H2].
        rewrite -> evar_is_fresh_in_app.
        split.
        * rewrite -> IHAC. set_solver.
        * unfold evar_is_fresh_in. set_solver.
    - simpl. split; intros H.
      + assert (Hfr1: evar_is_fresh_in x (subst_ctx AC p)).
        { eapply evar_is_fresh_in_richer. 2: apply H. cbn. set_solver. }
        assert (Hfr2: evar_is_fresh_in x p0).
        { eapply evar_is_fresh_in_richer. 2: apply H. cbn. set_solver. }
        rewrite -> IHAC in Hfr1.
        split; [apply Hfr1|].
        clear -Hfr1 Hfr2.
        unfold evar_is_fresh_in in Hfr2.
        set_solver.
      + destruct H as [H1 H2].
        rewrite -> evar_is_fresh_in_app.
        split.
        * unfold evar_is_fresh_in. set_solver.
        * rewrite -> IHAC. set_solver.
  Qed.

  Lemma wf_ex_eq_sctx_eo AC x p:
    well_formed (patt_exists p) = true ->
    well_formed (patt_exists ((subst_ctx AC (p^{evar: 0 ↦ x}))^{{evar: x ↦ 0}})) = true.
  Proof.
    intros Hwf.
    unfold well_formed in Hwf.
    apply andb_prop in Hwf.
    destruct Hwf as [Hwfp Hwfc].
    simpl in Hwfp.
    unfold well_formed.
    apply andb_true_intro.
    split.
    - simpl. apply evar_quantify_positive.
      apply wp_sctx.
      apply wfp_evar_open.
      apply Hwfp.
    - unfold well_formed_closed.
      simpl.
      unfold well_formed_closed in *.
      destruct_and!.
      split_and!; simpl.
      + apply evar_quantify_closed_mu. apply wcmu_sctx.
        apply wfc_mu_aux_body_ex_imp1. simpl in *. assumption.
      + apply evar_quantify_closed_ex. apply wcex_sctx.
        apply wfc_ex_aux_body_ex_imp1. simpl in *. assumption.
  Qed.

  Lemma subst_ctx_bevar_subst AC p q n:
  subst_ctx AC (p^[evar: n ↦ q]) = (subst_ctx AC p)^[evar: n ↦ q].
Proof.
  induction AC.
  - reflexivity.
  - simpl. rewrite IHAC. clear IHAC.
    rewrite [p0^[evar: n ↦ q] ]bevar_subst_not_occur.
    2: { reflexivity. }
    unfold well_formed,well_formed_closed in Prf.
    destruct_and!.
    auto. eapply well_formed_closed_ex_aux_ind. 2: exact H2. lia.
  - simpl. rewrite IHAC. clear IHAC.
    rewrite [p0^[evar: n ↦ q] ]bevar_subst_not_occur.
    2: { reflexivity. }
    unfold well_formed,well_formed_closed in Prf.
    destruct_and!.
    auto. eapply well_formed_closed_ex_aux_ind. 2: exact H2. lia.
Qed.

End lemmas.


Require Import String.

Require Import ZArith.
Require Import Psatz.
Require Import List.
Import ListNotations.

Require Import VeriFFI.library.isomorphism.
Require Import VeriFFI.library.meta.

Ltac eq_refl_match :=
  match goal with
  | [ |- context[match ?x with | eq_refl => _ end] ] => destruct x
  (* | [ _ : context[match ?x with | eq_refl => _ end] |- _] => destruct x *)
  end.

Ltac props x :=
  let P := fresh in
  pose proof x as P;
  hnf in P;
  simpl in P;
  rewrite !P;
  unfold id, eq_rect in *;
  clear P.

(* opaque and transparent *)
Inductive annotated : Type :=
| TYPEPARAM : (forall (A : Type) `{Rep A}, annotated) -> annotated
| OPAQUE : forall (prim_type model_type : Type)
                    `{Isomorphism prim_type model_type},
                    (option (prim_type -> annotated)) ->
                    annotated
| TRANSPARENT : forall (A : Type) `{Rep A}, (option (A -> annotated)) -> annotated.

Theorem Rep_any : forall {A : Type}, Rep A. Admitted.

Fixpoint to_prim_fn_type (r : annotated) : Type :=
  match r with
  | TYPEPARAM f => forall (A : Type), to_prim_fn_type (f A Rep_any)
  | OPAQUE pt mt M o =>
      match o with
      | None => pt
      | Some fp => forall (p : pt), to_prim_fn_type (fp p)
      end
  | TRANSPARENT t R o =>
      match o with
      | None => t
      | Some f => forall (x : t), to_prim_fn_type (f x)
      end
  end.

Fixpoint to_model_fn_type (r : annotated) : Type :=
  match r with
  | TYPEPARAM f => forall (A : Type), to_model_fn_type (f A Rep_any)
  | OPAQUE pt mt M o =>
      match o with
      | None => mt
      | Some fp => forall (m : mt), to_model_fn_type (fp (@to pt mt M m))
      end
  | TRANSPARENT t R o =>
      match o with
      | None => t
      | Some f => forall (x : t), to_model_fn_type (f x)
      end
  end.

Record extern_properties :=
  { type_desc : annotated
  ; prim_fn : to_prim_fn_type type_desc
  ; model_fn : to_model_fn_type type_desc
  ; c_name : string
  }.

Fixpoint model_spec_aux
         (a : annotated)
         (ft : to_prim_fn_type a)
         (mt : to_model_fn_type a) {struct a} : Prop.
destruct a as [f|prim_type model_type M|A R o]; simpl in ft, mt.
* exact (forall (A : Type), model_spec_aux (f A Rep_any) (ft A) (mt A)).
* destruct o as [pf|].
  - refine (forall (x : prim_type), model_spec_aux (pf x) (ft x) _).
    pose (m := mt (@from prim_type model_type M x)).
    rewrite from_to in m.
    exact m.
  - exact (ft = to mt).
* destruct o as [pf|].
  - exact (forall (x : A), model_spec_aux (pf x) (ft x) (mt x)).
  - exact (ft = mt).
Defined.

Definition model_spec (ep : extern_properties) : Prop :=
  model_spec_aux (type_desc ep) (prim_fn ep) (model_fn ep).

Require Import VeriFFI.generator.all.

Obligation Tactic := gen.
MetaCoq Run (gen_for Z).
MetaCoq Run (gen_for nat).
MetaCoq Run (gen_for bool).

Module IntVerification.

Module Type UInt63.
  Axiom t : Type.
  Axiom from_Z : Z -> t.
  Axiom to_Z : t -> Z.
  Axiom add : t -> t -> t.
  Axiom mul : t -> t -> t.
End UInt63.

(* Axiom VSU : Type. *)
(* Axiom int63_vsu : VSU. *)
(* Axiom lift : forall {A : Type}, A -> VSU -> string -> A. *)

Module FM <: UInt63.
  Definition t := {z : Z | 0 <= z < 2^63}%Z.
  Definition from_Z (z : Z) : t.
    exists (Z.modulo z (2^63)).
    apply Z_mod_lt.
    constructor.
  Defined.

  Definition to_Z (z : t) : Z := proj1_sig z.

  Lemma mod63_ok:
    forall z, (0 <= z mod (2^63) < 2^63)%Z.
  Proof.
    intro. apply Z.mod_pos_bound.
    apply Z.pow_pos_nonneg; lia.
   Qed.

  Definition add (x y: t) : t :=
  let '(exist xz x_pf) := x in
  let '(exist yz y_pf) := y in
  let z := ((xz + yz) mod (2^63))%Z in
  exist _ z (mod63_ok _).

  Definition mul (x y: t) : t :=
  let '(exist xz x_pf) := x in
  let '(exist yz y_pf) := y in
  let z := ((xz * yz) mod (2^63))%Z in
  exist _ z (mod63_ok _).

End FM.

Module C : UInt63.
  Axiom t : Type.
  Axiom from_Z : Z -> t.
  Axiom to_Z : t -> Z.
  Axiom add : t -> t -> t.
  Axiom mul : t -> t -> t.
End C.

Module UInt63_Proofs.
  Axiom Isomorphism_t : Isomorphism C.t FM.t.

  Definition from_Z_ep : extern_properties :=
    {| type_desc :=
        @TRANSPARENT Z Rep_Z
           (Some (fun z => @OPAQUE _ _ Isomorphism_t None))
     ; prim_fn := C.from_Z
     ; model_fn := FM.from_Z
     ; c_name := "int63_from_Z"
     |}.

  Definition to_Z_ep : extern_properties :=
    {| type_desc :=
        @OPAQUE _ _ Isomorphism_t
           (Some (fun z => @TRANSPARENT Z Rep_Z None))
     ; prim_fn := C.to_Z
     ; model_fn := FM.to_Z
     ; c_name := "int63_to_Z"
     |}.

  Definition add_ep : extern_properties :=
    {| type_desc :=
          @OPAQUE _ _ Isomorphism_t
            (Some (fun i =>
              @OPAQUE _ _ Isomorphism_t
                (Some (fun i => @OPAQUE _ _ Isomorphism_t None))))
     ; prim_fn := C.add
     ; model_fn := FM.add
     ; c_name := "int63_add"
     |}.

  Definition mul_ep : extern_properties :=
    {| type_desc :=
          @OPAQUE _ _ Isomorphism_t
            (Some (fun i =>
              @OPAQUE _ _ Isomorphism_t
                (Some (fun i => @OPAQUE _ _ Isomorphism_t None))))
     ; prim_fn := C.mul
     ; model_fn := FM.mul
     ; c_name := "int63_mul"
     |}.

  Axiom from_Z_properties : model_spec from_Z_ep.
  Axiom to_Z_properties : model_spec to_Z_ep.
  Axiom add_properties : model_spec add_ep.
  Axiom mul_properties : model_spec mul_ep.

  Lemma seven : C.to_Z (C.add (C.from_Z 3%Z) (C.from_Z 4%Z)) = 7%Z.
  Proof.
    props from_Z_properties.
    props to_Z_properties.
    props add_properties.
    repeat eq_refl_match.
    rewrite !from_to, !to_from.
    unfold FM.to_Z, FM.add, FM.from_Z.
    simpl.
    rewrite Z.mod_small.
    auto.
    lia.
  Qed.

  Lemma add_assoc : forall (x y z : Z),
    C.to_Z (C.add (C.from_Z x) (C.add (C.from_Z y) (C.from_Z z))) =
    C.to_Z (C.add (C.add (C.from_Z x) (C.from_Z y)) (C.from_Z z)).
  Proof.
    intros x y z.
    props from_Z_properties.
    props to_Z_properties.
    props add_properties.
    repeat eq_refl_match.
    rewrite !from_to, !to_from.
    unfold FM.add, FM.from_Z, FM.to_Z.
    simpl.
    rewrite <- !(Z.add_mod y z).
    rewrite <- !(Z.add_mod x y).
    rewrite <- !(Z.add_mod).
    f_equal.
    apply Z.add_assoc.
    all: lia.
  Qed.

  Lemma mul_add_distr_l : forall (x y z : Z),
    C.to_Z (C.mul (C.from_Z x) (C.add (C.from_Z y) (C.from_Z z))) =
    C.to_Z (C.add (C.mul (C.from_Z x) (C.from_Z y)) (C.mul (C.from_Z x) (C.from_Z z))).
  Proof.
    intros x y z.
    props from_Z_properties.
    props to_Z_properties.
    props add_properties.
    props mul_properties.
    repeat eq_refl_match.
    rewrite !from_to, !to_from.
    unfold FM.mul, FM.add, FM.from_Z, FM.to_Z.
    simpl.
    pose (y' := Z.modulo y (Z.pow_pos 2 63)); fold y'.
    pose (z' := Z.modulo z (Z.pow_pos 2 63)); fold z'.
    rewrite <- Zplus_mod.
    rewrite <- Z.mul_add_distr_l.
    rewrite Zmult_mod_idemp_r.
    auto.
  Qed.

  Lemma mul_add_distr_r : forall (x y z : Z),
    C.to_Z (C.mul (C.add (C.from_Z x) (C.from_Z y)) (C.from_Z z)) =
    C.to_Z (C.add (C.mul (C.from_Z x) (C.from_Z z)) (C.mul (C.from_Z y) (C.from_Z z))).
  Proof.
    intros x y z.
    props from_Z_properties.
    props to_Z_properties.
    props add_properties.
    props mul_properties.
    repeat eq_refl_match.
    rewrite !from_to, !to_from.
    unfold FM.mul, FM.add, FM.from_Z, FM.to_Z.
    simpl.
    pose (x' := Z.modulo y (Z.pow_pos 2 63)); fold x'.
    pose (y' := Z.modulo y (Z.pow_pos 2 63)); fold y'.
    pose (z' := Z.modulo z (Z.pow_pos 2 63)); fold z'.
    rewrite <- Zplus_mod.
    rewrite <- Z.mul_add_distr_r.
    rewrite Zmult_mod_idemp_l.
    auto.
  Qed.

End UInt63_Proofs.

End IntVerification.

Module ArrayVerification.

Module Type ArraySetup.
  Axiom t : Type.
  Axiom len: nat.
  Axiom init : t.
End ArraySetup.

Module Type Array (E : ArraySetup).
  Axiom state : Type.
  Definition M (A : Type) : Type := state -> A * state.
  Axiom pure : forall {A}, A -> M A.
  Axiom bind : forall {A B}, M A -> (A -> M B) -> M B.
  Axiom runM : forall {A}, M A -> A.
  Axiom set : nat -> E.t -> M unit.
  Axiom get : nat -> M (option E.t).
End Array.

(* Look at canon.replace_nth, invariants.replace_nth, sepalg_list.replace for lemmas *)
Module FM (E : ArraySetup) <: Array E.
  Definition state := list E.t.
  Definition M (A : Type) : Type := state -> A * state.
  Definition pure {A} (a : A) : M A := fun s => (a, s).
  Definition bind {A B} (m : M A) (f : A -> M B) : M B :=
    fun s => f (fst (m s)) (snd (m s)).
    (* fun s => let '(a, s') := m s in f a s'. *)
  Definition runM {A} (m : M A) : A :=
    fst (m (repeat E.init E.len)).

  Definition set (index : nat) (elt : E.t) : M unit :=
    fun s => (tt, canon.replace_nth index s elt).

  Definition get (index : nat) : M (option E.t) :=
    fun s => (nth_error s index, s).

End FM.

Module C (E : ArraySetup) : Array E.
  Axiom state : Type.
  Definition M (A : Type) : Type := state -> A * state.
  Axiom pure : forall {A}, A -> M A.
  Axiom bind : forall {A B}, M A -> (A -> M B) -> M B.
  Axiom runM : forall {A}, M A -> A.
  Axiom set : nat -> E.t -> M unit.
  Axiom get : nat -> M (option E.t).
End C.

Module Array_Proofs.
  Module E.
    Definition t := bool.
    Definition len := 5.
    Definition init := false.
  End E.
  Module FM := FM E.
  Module C := C E.

  Definition Rep_t : Rep E.t := Rep_bool.

  Axiom Isomorphism_state : Isomorphism C.state FM.state.

  Definition Isomorphism_M
             {A A' : Type} (I : Isomorphism A A')
             : Isomorphism (C.M A) (FM.M A').
  Proof.
    eauto using Isomorphism_fn, Isomorphism_state, Isomorphism_pair.
  Qed.

  Definition pure_ep : extern_properties :=
    {| type_desc :=
        @TYPEPARAM (fun (A : Type) `{Rep_A : Rep A} =>
          @TRANSPARENT A Rep_A (Some (fun arr =>
            @OPAQUE (C.M A) (FM.M A) (Isomorphism_M _) None)))
     ; prim_fn := @C.pure
     ; model_fn := @FM.pure
     ; c_name := "m_pure"
     |}.

  Definition bind_ep : extern_properties :=
    {| type_desc :=
        @TYPEPARAM (fun (A : Type) `{Rep_A : Rep A} =>
          @TYPEPARAM (fun (B : Type) `{Rep_B : Rep B} =>
            @OPAQUE (C.M A) (FM.M A) (Isomorphism_M _) (Some (fun m =>
              @OPAQUE (A -> C.M B) (A -> FM.M B) (Isomorphism_fn _ (Isomorphism_M _)) (Some (fun f =>
                @OPAQUE (C.M B) (FM.M B) (Isomorphism_M _) None))))))
     ; prim_fn := @C.bind
     ; model_fn := @FM.bind
     ; c_name := "m_bind"
     |}.

  Definition runM_ep : extern_properties :=
    {| type_desc :=
        @TYPEPARAM (fun (A : Type) `{Rep_A : Rep A} =>
          @OPAQUE (C.M A) (FM.M A) (Isomorphism_M _)
                  (Some (fun f => @TRANSPARENT A Rep_A None)))
     ; prim_fn := @C.runM
     ; model_fn := @FM.runM
     ; c_name := "m_runM"
     |}.

  Definition set_ep : extern_properties :=
    {| type_desc :=
        @TRANSPARENT nat Rep_nat (Some (fun n =>
          @TRANSPARENT E.t Rep_t (Some (fun a =>
            @OPAQUE (C.M unit) (FM.M unit) (Isomorphism_M _) None))))
     ; prim_fn := @C.set
     ; model_fn := @FM.set
     ; c_name := "array_set"
     |}.

  Definition get_ep : extern_properties :=
    {| type_desc :=
        @TRANSPARENT nat Rep_nat (Some (fun n =>
          @OPAQUE (C.M (option E.t)) (FM.M (option E.t)) (Isomorphism_M _) None))
     ; prim_fn := @C.get
     ; model_fn := @FM.get
     ; c_name := "array_get"
     |}.

  Axiom pure_properties : model_spec pure_ep.
  Axiom bind_properties : model_spec bind_ep.
  Axiom runM_properties : model_spec runM_ep.
  Axiom set_properties : model_spec set_ep.
  Axiom get_properties : model_spec get_ep.

  Ltac prim_rewrites :=
    repeat eq_refl_match;
    rewrite ?from_to, ?to_from.

  Arguments from A B {_}.
  Arguments to A B {_}.

  Lemma set_get :
    forall (n : nat) (bound : n < E.len) (to_set : E.t),
      (C.runM (C.bind (C.set n to_set) (fun _ => C.get n)))
        =
      (C.runM (C.pure (Some to_set))).
  Proof.
    intros n bound to_set.

    props runM_properties.
    prim_rewrites.
    unfold FM.runM.

    props bind_properties.
    props pure_properties.
    unfold FM.bind, FM.pure.
    prim_rewrites.

    props set_properties.
    props get_properties.
    prim_rewrites.

    eapply canon.nth_error_replace_nth.
    apply nth_error_repeat.
    auto.
  Qed.

End Array_Proofs.

End ArrayVerification.