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


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.


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


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2018 Sylvie Boldo
#<br />#
Copyright (C) 2010-2018 Guillaume Melquiond

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

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Remainder of the division and square root are in the FLX format *)

Require Import Psatz.
Require Import Core Operations Relative Sterbenz Mult_error.

Section Fprop_divsqrt_error.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable prec : Z.

Lemma generic_format_plus_prec :
  forall fexp, (forall e, (fexp e <= e - prec)%Z) ->
  forall x y (fx fy: float beta),
  (x = F2R fx)%R -> (y = F2R fy)%R -> (Rabs (x+y) < bpow (prec+Fexp fx))%R ->
  (Rabs (x+y) < bpow (prec+Fexp fy))%R ->
  generic_format beta fexp (x+y)%R.
Proof.
intros fexp Hfexp x y fx fy Hx Hy H1 H2.
case (Req_dec (x+y) 0); intros H.
rewrite H; apply generic_format_0.
rewrite Hx, Hy, <- F2R_plus.
apply generic_format_F2R.
intros _.
change (F2R _) with (F2R (Fplus fx fy)).
apply Z.le_trans with (Z.min (Fexp fx) (Fexp fy)).
rewrite F2R_plus, <- Hx, <- Hy.
unfold cexp.
apply Z.le_trans with (1:=Hfexp _).
apply Zplus_le_reg_l with prec; ring_simplify.
apply mag_le_bpow with (1 := H).
now apply Z.min_case.
rewrite <- Fexp_Fplus.
apply Z.le_refl.
Qed.

Context { prec_gt_0_ : Prec_gt_0 prec }.

Notation format := (generic_format beta (FLX_exp prec)).
Notation cexp := (cexp beta (FLX_exp prec)).

Variable choice : Z -> bool.

(** Remainder of the division in FLX *)
Theorem div_error_FLX :
  forall rnd { Zrnd : Valid_rnd rnd } x y,
  format x -> format y ->
  format (x - round beta (FLX_exp prec) rnd (x/y) * y)%R.
Proof with auto with typeclass_instances.
intros rnd Zrnd x y Hx Hy.
destruct (Req_dec y 0) as [Zy|Zy].
now rewrite Zy, Rmult_0_r, Rminus_0_r.
destruct (Req_dec (round beta (FLX_exp prec) rnd (x/y)) 0) as [Hr|Hr].
rewrite Hr; ring_simplify (x-0*y)%R; assumption.
assert (Zx: x <> R0).
contradict Hr.
rewrite Hr.
unfold Rdiv.
now rewrite Rmult_0_l, round_0.
destruct (canonical_generic_format _ _ x Hx) as (fx,(Hx1,Hx2)).
destruct (canonical_generic_format _ _ y Hy) as (fy,(Hy1,Hy2)).
destruct (canonical_generic_format beta (FLX_exp prec) (round beta (FLX_exp prec) rnd (x / y))) as (fr,(Hr1,Hr2)).
apply generic_format_round...
unfold Rminus; apply generic_format_plus_prec with fx (Fopp (Fmult fr fy)); trivial.
intros e; apply Z.le_refl.
now rewrite F2R_opp, F2R_mult, <- Hr1, <- Hy1.
(* *)
destruct (relative_error_FLX_ex beta prec (prec_gt_0 prec) rnd (x / y)%R) as (eps,(Heps1,Heps2)).
rewrite Heps2.
rewrite <- Rabs_Ropp.
replace (-(x + - (x / y * (1 + eps) * y)))%R with (x * eps)%R by now field.
rewrite Rabs_mult.
apply Rlt_le_trans with (Rabs x * 1)%R.
apply Rmult_lt_compat_l.
now apply Rabs_pos_lt.
apply Rlt_le_trans with (1 := Heps1).
change 1%R with (bpow 0).
apply bpow_le.
generalize (prec_gt_0 prec).
clear ; omega.
rewrite Rmult_1_r.
rewrite Hx2, <- Hx1.
unfold cexp.
destruct (mag beta x) as (ex, Hex).
simpl.
specialize (Hex Zx).
apply Rlt_le.
apply Rlt_le_trans with (1 := proj2 Hex).
apply bpow_le.
unfold FLX_exp.
ring_simplify.
apply Z.le_refl.
(* *)
replace (Fexp (Fopp (Fmult fr fy))) with (Fexp fr + Fexp fy)%Z.
2: unfold Fopp, Fmult; destruct fr; destruct fy; now simpl.
replace (x + - (round beta (FLX_exp prec) rnd (x / y) * y))%R with
  (y * (-(round beta (FLX_exp prec) rnd (x / y) - x/y)))%R.
2: field; assumption.
rewrite Rabs_mult.
apply Rlt_le_trans with (Rabs y * bpow (Fexp fr))%R.
apply Rmult_lt_compat_l.
now apply Rabs_pos_lt.
rewrite Rabs_Ropp.
replace (bpow (Fexp fr)) with (ulp beta (FLX_exp prec) (F2R fr)).
rewrite <- Hr1.
apply error_lt_ulp_round...
apply Rmult_integral_contrapositive_currified; try apply Rinv_neq_0_compat; assumption.
rewrite ulp_neq_0.
2: now rewrite <- Hr1.
apply f_equal.
now rewrite Hr2, <- Hr1.
replace (prec+(Fexp fr+Fexp fy))%Z with ((prec+Fexp fy)+Fexp fr)%Z by ring.
rewrite bpow_plus.
apply Rmult_le_compat_r.
apply bpow_ge_0.
rewrite Hy2, <- Hy1 ; unfold cexp, FLX_exp.
ring_simplify (prec + (mag beta y - prec))%Z.
destruct (mag beta y); simpl.
left; now apply a.
Qed.

(** Remainder of the square in FLX (with p>1) and rounding to nearest *)
Variable Hp1 : Z.lt 1 prec.

Theorem sqrt_error_FLX_N :
  forall x, format x ->
  format (x - Rsqr (round beta (FLX_exp prec) (Znearest choice) (sqrt x)))%R.
Proof with auto with typeclass_instances.
intros x Hx.
destruct (total_order_T x 0) as [[Hxz|Hxz]|Hxz].
unfold sqrt.
destruct (Rcase_abs x).
rewrite round_0...
unfold Rsqr.
now rewrite Rmult_0_l, Rminus_0_r.
elim (Rlt_irrefl 0).
now apply Rgt_ge_trans with x.
rewrite Hxz, sqrt_0, round_0...
unfold Rsqr.
rewrite Rmult_0_l, Rminus_0_r.
apply generic_format_0.
case (Req_dec (round beta (FLX_exp prec) (Znearest choice) (sqrt x)) 0); intros Hr.
rewrite Hr; unfold Rsqr; ring_simplify (x-0*0)%R; assumption.
destruct (canonical_generic_format _ _ x Hx) as (fx,(Hx1,Hx2)).
destruct (canonical_generic_format beta (FLX_exp prec) (round beta (FLX_exp prec) (Znearest choice) (sqrt x))) as (fr,(Hr1,Hr2)).
apply generic_format_round...
unfold Rminus; apply generic_format_plus_prec with fx (Fopp (Fmult fr fr)); trivial.
intros e; apply Z.le_refl.
unfold Rsqr; now rewrite F2R_opp,F2R_mult, <- Hr1.
(* *)
apply Rle_lt_trans with x.
apply Rabs_minus_le.
apply Rle_0_sqr.
destruct (relative_error_N_FLX_ex beta prec (prec_gt_0 prec) choice (sqrt x)) as (eps,(Heps1,Heps2)).
rewrite Heps2.
rewrite Rsqr_mult, Rsqr_sqrt, Rmult_comm. 2: now apply Rlt_le.
apply Rmult_le_compat_r.
now apply Rlt_le.
apply Rle_trans with (5²/4²)%R.
rewrite <- Rsqr_div.
apply Rsqr_le_abs_1.
apply Rle_trans with (1 := Rabs_triang _ _).
rewrite Rabs_R1.
apply Rplus_le_reg_l with (-1)%R.
replace (-1 + (1 + Rabs eps))%R with (Rabs eps) by ring.
apply Rle_trans with (1 := Heps1).
rewrite Rabs_pos_eq.
apply Rmult_le_reg_l with 2%R.
now apply IZR_lt.
rewrite <- Rmult_assoc, Rinv_r, Rmult_1_l.
apply Rle_trans with (bpow (-1)).
apply bpow_le.
omega.
replace (2 * (-1 + 5 / 4))%R with (/2)%R by field.
apply Rinv_le.
now apply IZR_lt.
apply IZR_le.
unfold Zpower_pos. simpl.
rewrite Zmult_1_r.
apply Zle_bool_imp_le.
apply beta.
now apply IZR_neq.
unfold Rdiv.
apply Rmult_le_pos.
now apply IZR_le.
apply Rlt_le.
apply Rinv_0_lt_compat.
now apply IZR_lt.
now apply IZR_neq.
unfold Rsqr.
replace (5 * 5 / (4 * 4))%R with (25 * /16)%R by field.
apply Rmult_le_reg_r with 16%R.
now apply IZR_lt.
rewrite Rmult_assoc, Rinv_l, Rmult_1_r.
now apply (IZR_le _ 32).
now apply IZR_neq.
rewrite Hx2, <- Hx1; unfold cexp, FLX_exp.
ring_simplify (prec + (mag beta x - prec))%Z.
destruct (mag beta x); simpl.
rewrite <- (Rabs_right x).
apply a.
now apply Rgt_not_eq.
now apply Rgt_ge.
(* *)
replace (Fexp (Fopp (Fmult fr fr))) with (Fexp fr + Fexp fr)%Z.
2: unfold Fopp, Fmult; destruct fr; now simpl.
rewrite Hr1.
replace (x + - Rsqr (F2R fr))%R with (-((F2R fr - sqrt x)*(F2R fr + sqrt x)))%R.
2: rewrite <- (sqrt_sqrt x) at 3; auto.
2: unfold Rsqr; ring.
rewrite Rabs_Ropp, Rabs_mult.
apply Rle_lt_trans with ((/2*bpow (Fexp fr))* Rabs (F2R fr + sqrt x))%R.
apply Rmult_le_compat_r.
apply Rabs_pos.
apply Rle_trans with (/2*ulp beta  (FLX_exp prec) (F2R fr))%R.
rewrite <- Hr1.
apply error_le_half_ulp_round...
right; rewrite ulp_neq_0.
2: now rewrite <- Hr1.
apply f_equal.
rewrite Hr2, <- Hr1; trivial.
rewrite Rmult_assoc, Rmult_comm.
replace (prec+(Fexp fr+Fexp fr))%Z with (Fexp fr + (prec+Fexp fr))%Z by ring.
rewrite bpow_plus, Rmult_assoc.
apply Rmult_lt_compat_l.
apply bpow_gt_0.
apply Rmult_lt_reg_l with (1 := Rlt_0_2).
apply Rle_lt_trans with (Rabs (F2R fr + sqrt x)).
right; field.
apply Rle_lt_trans with (1:=Rabs_triang _ _).
(* . *)
assert (Rabs (F2R fr) < bpow (prec + Fexp fr))%R.
rewrite Hr2.
unfold cexp, FLX_exp.
ring_simplify (prec + (mag beta (F2R fr) - prec))%Z.
destruct (mag beta (F2R fr)); simpl.
apply a.
rewrite <- Hr1; auto.
(* . *)
apply Rlt_le_trans with (bpow (prec + Fexp fr)+ Rabs (sqrt x))%R.
now apply Rplus_lt_compat_r.
(* . *)
replace (2 * bpow (prec + Fexp fr))%R with (bpow (prec + Fexp fr) + bpow (prec + Fexp fr))%R by ring.
apply Rplus_le_compat_l.
assert (sqrt x <> 0)%R.
apply Rgt_not_eq.
now apply sqrt_lt_R0.
destruct (mag beta (sqrt x)) as (es,Es).
specialize (Es H0).
apply Rle_trans with (bpow es).
now apply Rlt_le.
apply bpow_le.
case (Zle_or_lt es (prec + Fexp fr)) ; trivial.
intros H1.
absurd (Rabs (F2R fr) < bpow (es - 1))%R.
apply Rle_not_lt.
rewrite <- Hr1.
apply abs_round_ge_generic...
apply generic_format_bpow.
unfold FLX_exp; omega.
apply Es.
apply Rlt_le_trans with (1:=H).
apply bpow_le.
omega.
now apply Rlt_le.
Qed.

Lemma sqrt_error_N_FLX_aux1 x (Fx : format x) (Px : (0 < x)%R) :
  exists (mu : R) (e : Z), (format mu /\ x = mu * bpow (2 * e) :> R
                            /\ 1 <= mu < bpow 2)%R.
Proof.
set (e := ((mag beta x - 1) / 2)%Z).
set (mu := (x * bpow (-2 * e)%Z)%R).
assert (Hbe : (bpow (-2 * e) * bpow (2 * e) = 1)%R).
{ now rewrite <- bpow_plus; case e; simpl; [reflexivity| |]; intro p;
    rewrite Z.pos_sub_diag. }
assert (Fmu : format mu); [now apply mult_bpow_exact_FLX|].
exists mu, e; split; [exact Fmu|split; [|split]].
{ set (e2 := (2 * e)%Z); simpl; unfold mu; rewrite Rmult_assoc.
  now unfold e2; rewrite Hbe, Rmult_1_r. }
{ apply (Rmult_le_reg_r (bpow (2 * e))).
  { apply bpow_gt_0. }
  rewrite Rmult_1_l; set (e2 := (2 * e)%Z); simpl; unfold mu.
  unfold e2; rewrite Rmult_assoc, Hbe, Rmult_1_r.
  apply (Rle_trans _ (bpow (mag beta x - 1))).
  { now apply bpow_le; unfold e; apply Z_mult_div_ge. }
  set (l := mag _ _); rewrite <- (Rabs_pos_eq _ (Rlt_le _ _ Px)).
  unfold l; apply bpow_mag_le.
  intro Hx; revert Px; rewrite Hx; apply Rlt_irrefl. }
simpl; unfold mu; change (IZR _) with (bpow 2).
apply (Rmult_lt_reg_r (bpow (2 * e))); [now apply bpow_gt_0|].
rewrite Rmult_assoc, Hbe, Rmult_1_r.
apply (Rlt_le_trans _ (bpow (mag beta x))).
{ rewrite <- (Rabs_pos_eq _ (Rlt_le _ _ Px)) at 1; apply bpow_mag_gt. }
rewrite <- bpow_plus; apply bpow_le; unfold e; set (mxm1 := (_ - 1)%Z).
replace (_ * _)%Z with (2 * (mxm1 / 2) + mxm1 mod 2 - mxm1 mod 2)%Z by ring.
rewrite <- Z.div_mod; [|now simpl].
apply (Zplus_le_reg_r _ _ (mxm1 mod 2 - mag beta x)%Z).
unfold mxm1; destruct (Z.mod_bound_or (mag beta x - 1) 2); omega.
Qed.

Notation u_ro := (u_ro beta prec).

Lemma sqrt_error_N_FLX_aux2 x (Fx : format x) :
  (1 <= x)%R ->
  (x = 1 :> R \/ x = 1 + 2 * u_ro :> R \/ 1 + 4 * u_ro <= x)%R.
Proof.
intro HxGe1.
assert (Pu_ro : (0 <= u_ro)%R); [apply Rmult_le_pos; [lra|apply bpow_ge_0]|].
destruct (Rle_or_lt x 1) as [HxLe1|HxGt1]; [now left; apply Rle_antisym|right].
assert (F1 : format 1); [now apply generic_format_FLX_1|].
assert (H2eps : (2 * u_ro = bpow (-prec + 1))%R).
{ unfold u_ro; rewrite bpow_plus; field. }
assert (HmuGe1p2eps : (1 + 2 * u_ro <= x)%R).
{ rewrite H2eps, <- succ_FLX_1.
  now apply succ_le_lt; [now apply FLX_exp_valid| | |]. }
destruct (Rle_or_lt x (1 + 2 * u_ro)) as [HxLe1p2eps|HxGt1p2eps];
  [now left; apply Rle_antisym|right].
assert (Hulp1p2eps : (ulp beta (FLX_exp prec) (1 + 2 * u_ro) = 2 * u_ro)%R).
{ destruct (ulp_succ_pos _ _ _ F1 Rlt_0_1) as [Hsucc|Hsucc].
  { now rewrite H2eps, <- succ_FLX_1, <- ulp_FLX_1. }
  exfalso; revert Hsucc; apply Rlt_not_eq.
  rewrite succ_FLX_1, mag_1, bpow_1, <- H2eps; simpl.
  apply (Rlt_le_trans _ 2); [apply Rplus_lt_compat_l|].
  { unfold u_ro; rewrite <-Rmult_assoc, Rinv_r, Rmult_1_l; [|lra].
    change R1 with (bpow 0); apply bpow_lt; omega. }
  apply IZR_le, Zle_bool_imp_le, radix_prop. }
assert (Hsucc1p2eps :
          (succ beta (FLX_exp prec) (1 + 2 * u_ro) = 1 + 4 * u_ro)%R).
{ unfold succ; rewrite Rle_bool_true; [rewrite Hulp1p2eps; ring|].
  apply Rplus_le_le_0_compat; lra. }
rewrite <- Hsucc1p2eps.
apply succ_le_lt; [now apply FLX_exp_valid| |exact Fx|now simpl].
rewrite H2eps, <- succ_FLX_1.
now apply generic_format_succ; [apply FLX_exp_valid|].
Qed.

Lemma sqrt_error_N_FLX_aux3 :
  (u_ro / sqrt (1 + 4 * u_ro) <= 1 - 1 / sqrt (1 + 2 * u_ro))%R.
Proof.
assert (Pu_ro : (0 <= u_ro)%R); [apply Rmult_le_pos; [lra|apply bpow_ge_0]|].
unfold Rdiv; apply (Rplus_le_reg_r (/ sqrt (1 + 2 * u_ro))); ring_simplify.
apply (Rmult_le_reg_r (sqrt (1 + 4 * u_ro) * sqrt (1 + 2 * u_ro))).
{ apply Rmult_lt_0_compat; apply sqrt_lt_R0; lra. }
field_simplify; [|split; apply Rgt_not_eq, Rlt_gt, sqrt_lt_R0; lra].
try unfold Rdiv; rewrite ?Rinv_1, ?Rmult_1_r.
apply Rsqr_incr_0_var; [|now apply Rmult_le_pos; apply sqrt_pos].
rewrite <-sqrt_mult; [|lra|lra].
rewrite Rsqr_sqrt; [|apply Rmult_le_pos; lra].
unfold Rsqr; ring_simplify; unfold pow; rewrite !Rmult_1_r.
rewrite !sqrt_def; [|lra|lra].
apply (Rplus_le_reg_r (-u_ro * u_ro - 1 -4 * u_ro - 2 * u_ro ^ 3)).
ring_simplify; apply Rsqr_incr_0_var.
{ unfold Rsqr; ring_simplify.
  unfold pow; rewrite !Rmult_1_r, !sqrt_def; [|lra|lra].
  apply (Rplus_le_reg_r (-32 * u_ro ^ 4 - 24 * u_ro ^ 3 - 4 * u_ro ^ 2)).
  ring_simplify.
  replace (_ + _)%R
    with (((4 * u_ro ^ 2 - 28 * u_ro + 9) * u_ro + 4) * u_ro ^ 3)%R by ring.
  apply Rmult_le_pos; [|now apply pow_le].
  assert (Heps_le_half : (u_ro <= 1 / 2)%R).
  { unfold u_ro, Rdiv; rewrite Rmult_comm; apply Rmult_le_compat_r; [lra|].
    change 1%R with (bpow 0); apply bpow_le; omega. }
  apply (Rle_trans _ (-8 * u_ro + 4)); [lra|].
  apply Rplus_le_compat_r, Rmult_le_compat_r; [apply Pu_ro|].
  now assert (H : (0 <= u_ro ^ 2)%R); [apply pow2_ge_0|lra]. }
assert (H : (u_ro ^ 3 <= u_ro ^ 2)%R).
{ unfold pow; rewrite <-!Rmult_assoc, Rmult_1_r.
  apply Rmult_le_compat_l; [now apply Rmult_le_pos; apply Pu_ro|].
  now apply Rlt_le, u_ro_lt_1. }
now assert (H' : (0 <= u_ro ^ 2)%R); [apply pow2_ge_0|lra].
Qed.

Lemma om1ds1p2u_ro_pos : (0 <= 1 - 1 / sqrt (1 + 2 * u_ro))%R.
Proof.
unfold Rdiv; rewrite Rmult_1_l, <-Rinv_1 at 1.
apply Rle_0_minus, Rinv_le; [lra|].
rewrite <- sqrt_1 at 1; apply sqrt_le_1_alt.
assert (H := u_ro_pos beta prec); lra.
Qed.

Lemma om1ds1p2u_ro_le_u_rod1pu_ro :
  (1 - 1 / sqrt (1 + 2 * u_ro) <= u_ro / (1 + u_ro))%R.
Proof.
assert (Pu_ro := u_ro_pos beta prec).
apply (Rmult_le_reg_r (sqrt (1 + 2 * u_ro) * (1 + u_ro))).
{ apply Rmult_lt_0_compat; [apply sqrt_lt_R0|]; lra. }
field_simplify; [|lra|intro H; apply sqrt_eq_0 in H; lra].
try unfold Rdiv; unfold Rminus; rewrite ?Rinv_1, ?Rmult_1_r, !Rplus_assoc.
rewrite <-(Rplus_0_r (sqrt _ * _)) at 2; apply Rplus_le_compat_l.
apply (Rplus_le_reg_r (1 + u_ro)); ring_simplify.
rewrite <-(sqrt_square (_ + 1)); [|lra]; apply sqrt_le_1_alt.
assert (H : (0 <= u_ro * u_ro)%R); [apply Rmult_le_pos|]; lra.
Qed.

Lemma s1p2u_rom1_pos : (0 <= sqrt (1 + 2 * u_ro) - 1)%R.
apply (Rplus_le_reg_r 1); ring_simplify.
rewrite <-sqrt_1 at 1; apply sqrt_le_1_alt.
assert (H := u_ro_pos beta prec); lra.
Qed.

Theorem sqrt_error_N_FLX x (Fx : format x) :
  (Rabs (round beta (FLX_exp prec) (Znearest choice) (sqrt x) - sqrt x)
   <= (1 - 1 / sqrt (1 + 2 * u_ro)) * Rabs (sqrt x))%R.
Proof.
assert (Peps := u_ro_pos beta prec).
assert (Peps' : (0 < u_ro)%R).
{ unfold u_ro; apply Rmult_lt_0_compat; [lra|apply bpow_gt_0]. }
assert (Pb := om1ds1p2u_ro_pos).
assert (Pb' := s1p2u_rom1_pos).
destruct (Rle_or_lt x 0) as [Nx|Px].
{ rewrite (sqrt_neg _ Nx), round_0, Rabs_R0, Rmult_0_r; [|apply valid_rnd_N].
  now unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0; right. }
destruct (sqrt_error_N_FLX_aux1 _ Fx Px)
  as (mu, (e, (Fmu, (Hmu, (HmuGe1, HmuLtsqradix))))).
pose (t := sqrt x).
set (rt := round _ _ _ _).
assert (Ht : (t = sqrt mu * bpow e)%R).
{ unfold t; rewrite Hmu, sqrt_mult_alt; [|now apply (Rle_trans _ _ _ Rle_0_1)].
  now rewrite sqrt_bpow. }
destruct (sqrt_error_N_FLX_aux2 _ Fmu HmuGe1) as [Hmu'|[Hmu'|Hmu']].
{ unfold rt; fold t; rewrite Ht, Hmu', sqrt_1, Rmult_1_l.
  rewrite round_generic; [|now apply valid_rnd_N|].
  { rewrite Rminus_diag_eq, Rabs_R0; [|now simpl].
    now apply Rmult_le_pos; [|apply Rabs_pos]. }
  apply generic_format_bpow'; [now apply FLX_exp_valid|].
  unfold FLX_exp; omega. }
{ assert (Hsqrtmu : (1 <= sqrt mu < 1 + u_ro)%R); [rewrite Hmu'; split|].
  { rewrite <- sqrt_1 at 1; apply sqrt_le_1_alt; lra. }
  { rewrite <- sqrt_square; [|lra]; apply sqrt_lt_1_alt; split; [lra|].
    ring_simplify; assert (0 < u_ro ^ 2)%R; [apply pow_lt|]; lra. }
  assert (Fbpowe : generic_format beta (FLX_exp prec) (bpow e)).
  { apply generic_format_bpow; unfold FLX_exp; omega. }
  assert (Hrt : rt = bpow e :> R).
  { unfold rt; fold t; rewrite Ht; simpl; apply Rle_antisym.
    { apply round_N_le_midp; [now apply FLX_exp_valid|exact Fbpowe|].
      apply (Rlt_le_trans _ ((1 + u_ro) * bpow e)).
      { now apply Rmult_lt_compat_r; [apply bpow_gt_0|]. }
      unfold succ; rewrite Rle_bool_true; [|now apply bpow_ge_0].
      rewrite ulp_bpow; unfold FLX_exp.
      unfold Z.sub, u_ro; rewrite !bpow_plus; right; field. }
    apply round_ge_generic;
      [now apply FLX_exp_valid|now apply valid_rnd_N|exact Fbpowe|].
    rewrite <- (Rmult_1_l (bpow _)) at 1.
    now apply Rmult_le_compat_r; [apply bpow_ge_0|]. }
  fold t; rewrite Hrt, Ht, Hmu', <-(Rabs_pos_eq _ Pb), <-Rabs_mult.
  rewrite Rabs_minus_sym; right; f_equal; field; lra. }
assert (Hsqrtmu : (1 + u_ro < sqrt mu)%R).
{ apply (Rlt_le_trans _ (sqrt (1 + 4 * u_ro))); [|now apply sqrt_le_1_alt].
  assert (P1peps : (0 <= 1 + u_ro)%R)
    by now apply Rplus_le_le_0_compat; [lra|apply Peps].
  rewrite <- (sqrt_square (1 + u_ro)); [|lra].
  apply sqrt_lt_1_alt; split; [now apply Rmult_le_pos|].
  apply (Rplus_lt_reg_r (-1 - 2 * u_ro)); ring_simplify; simpl.
  rewrite Rmult_1_r; apply Rmult_lt_compat_r; [apply Peps'|].
  now apply (Rlt_le_trans _ 1); [apply u_ro_lt_1|lra]. }
assert (Hulpt : (ulp beta (FLX_exp prec) t = 2 * u_ro * bpow e)%R).
{ unfold ulp; rewrite Req_bool_false; [|apply Rgt_not_eq, Rlt_gt].
  { unfold u_ro; rewrite <-Rmult_assoc, Rinv_r, Rmult_1_l, <-bpow_plus; [|lra].
    f_equal; unfold cexp, FLX_exp.
    assert (Hmagt : (mag beta t = 1 + e :> Z)%Z).
    { apply mag_unique.
      unfold t; rewrite (Rabs_pos_eq _ (Rlt_le _ _ (sqrt_lt_R0 _ Px))).
      fold t; split.
      { rewrite Ht; replace (_ - _)%Z with e by ring.
        rewrite <- (Rmult_1_l (bpow _)) at 1; apply Rmult_le_compat_r.
        { apply bpow_ge_0. }
        now rewrite <- sqrt_1; apply sqrt_le_1_alt. }
      rewrite bpow_plus, bpow_1, Ht; simpl.
      apply Rmult_lt_compat_r; [now apply bpow_gt_0|].
      rewrite <- sqrt_square.
      { apply sqrt_lt_1_alt; split; [lra|].
        apply (Rlt_le_trans _ _ _ HmuLtsqradix); right.
        now unfold bpow, Z.pow_pos; simpl; rewrite Zmult_1_r, mult_IZR. }
      apply IZR_le, (Z.le_trans _ 2), Zle_bool_imp_le, radix_prop; omega. }
    rewrite Hmagt; ring. }
  rewrite Ht; apply Rmult_lt_0_compat; [|now apply bpow_gt_0].
  now apply (Rlt_le_trans _ 1); [lra|rewrite <- sqrt_1; apply sqrt_le_1_alt]. }
assert (Pt : (0 < t)%R).
{ rewrite Ht; apply Rmult_lt_0_compat; [lra|apply bpow_gt_0]. }
assert (H : (Rabs ((rt - sqrt x) / sqrt x)
             <= 1 - 1 / sqrt (1 + 2 * u_ro))%R).
{ unfold Rdiv; rewrite Rabs_mult, (Rabs_pos_eq (/ _));
    [|now left; apply Rinv_0_lt_compat].
  apply (Rle_trans _ ((u_ro * bpow e) / t)).
  { unfold Rdiv; apply Rmult_le_compat_r; [now left; apply Rinv_0_lt_compat|].
    apply (Rle_trans _ _ _ (error_le_half_ulp _ _ _ _)).
    fold t; rewrite Hulpt; right; field. }
  apply (Rle_trans _ (u_ro / sqrt (1 + 4 * u_ro))).
  { apply (Rle_trans _ (u_ro * bpow e / (sqrt (1 + 4 * u_ro) * bpow e))).
    { unfold Rdiv; apply Rmult_le_compat_l;
        [now apply Rmult_le_pos; [apply Peps|apply bpow_ge_0]|].
      apply Rinv_le.
      { apply Rmult_lt_0_compat; [apply sqrt_lt_R0; lra|apply bpow_gt_0]. }
      now rewrite Ht; apply Rmult_le_compat_r;
        [apply bpow_ge_0|apply sqrt_le_1_alt]. }
    right; field; split; apply Rgt_not_eq, Rlt_gt;
      [apply sqrt_lt_R0; lra|apply bpow_gt_0]. }
  apply sqrt_error_N_FLX_aux3. }
revert H; unfold Rdiv; rewrite Rabs_mult, Rabs_Rinv; [|fold t; lra]; intro H.
apply (Rmult_le_reg_r (/ Rabs (sqrt x)));
  [apply Rinv_0_lt_compat, Rabs_pos_lt; fold t; lra|].
apply (Rle_trans _ _ _ H); right; field; split; [apply Rabs_no_R0;fold t|]; lra.
Qed.

Theorem sqrt_error_N_FLX_ex x (Fx : format x) :
  exists eps,
  (Rabs eps <= 1 - 1 / sqrt (1 + 2 * u_ro))%R /\
  round beta (FLX_exp prec) (Znearest choice) (sqrt x)
  = (sqrt x * (1 + eps))%R.
Proof.
now apply relative_error_le_conversion;
  [apply valid_rnd_N|apply om1ds1p2u_ro_pos|apply sqrt_error_N_FLX].
Qed.

Lemma sqrt_error_N_round_ex_derive :
  forall x rx,
  (exists eps,
   (Rabs eps <= 1 - 1 / sqrt (1 + 2 * u_ro))%R /\ rx = (x * (1 + eps))%R) ->
  exists eps,
  (Rabs eps <= sqrt (1 + 2 * u_ro) - 1)%R /\ x = (rx * (1 + eps))%R.
Proof.
intros x rx (d, (Bd, Hd)).
assert (H := Rabs_le_inv _ _ Bd).
assert (H' := om1ds1p2u_ro_le_u_rod1pu_ro).
assert (H'' := u_rod1pu_ro_le_u_ro beta prec).
assert (H''' := u_ro_lt_1 beta prec prec_gt_0_).
assert (Hpos := s1p2u_rom1_pos).
destruct (Req_dec rx 0) as [Zfx|Nzfx].
{ exists 0%R; split; [now rewrite Rabs_R0|].
  rewrite Rplus_0_r, Rmult_1_r, Zfx; rewrite Zfx in Hd.
  destruct (Rmult_integral _ _ (sym_eq Hd)); lra. }
destruct (Req_dec x 0) as [Zx|Nzx].
{ now exfalso; revert Hd; rewrite Zx; rewrite Rmult_0_l. }
set (d' := ((x - rx) / rx)%R).
assert (Hd' : (Rabs d' <= sqrt (1 + 2 * u_ro) - 1)%R).
{ unfold d'; rewrite Hd.
  replace (_ / _)%R with (- d / (1 + d))%R; [|now field; split; lra].
  unfold Rdiv; rewrite Rabs_mult, Rabs_Ropp.
  rewrite (Rabs_pos_eq (/ _)); [|apply Rlt_le, Rinv_0_lt_compat; lra].
  apply (Rmult_le_reg_r (1 + d)); [lra|].
  rewrite Rmult_assoc, Rinv_l, Rmult_1_r; [|lra].
  apply (Rle_trans _ _ _ Bd).
  apply (Rle_trans _ ((sqrt (1 + 2 * u_ro) - 1) * (1/sqrt (1 + 2 * u_ro))));
    [right; field|apply Rmult_le_compat_l]; lra. }
now exists d'; split; [exact Hd'|]; unfold d'; field.
Qed.

(** sqrt(1 + 2 u_ro) - 1 <= u_ro *)
Theorem sqrt_error_N_FLX_round_ex :
  forall x,
  format x ->
  exists eps,
  (Rabs eps <= sqrt (1 + 2 * u_ro) - 1)%R /\
  sqrt x = (round beta (FLX_exp prec) (Znearest choice) (sqrt x) * (1 + eps))%R.
Proof.
now intros x Fx; apply sqrt_error_N_round_ex_derive, sqrt_error_N_FLX_ex.
Qed.

Variable emin : Z.
Hypothesis Hemin : (emin <= 2 * (1 - prec))%Z.

Theorem sqrt_error_N_FLT_ex :
  forall x,
  generic_format beta (FLT_exp emin prec) x ->
  exists eps,
  (Rabs eps <= 1 - 1 / sqrt (1 + 2 * u_ro))%R /\
  round beta (FLT_exp emin prec) (Znearest choice) (sqrt x)
  = (sqrt x * (1 + eps))%R.
Proof.
intros x Fx.
assert (Heps := u_ro_pos).
assert (Pb := om1ds1p2u_ro_pos).
destruct (Rle_or_lt x 0) as [Nx|Px].
{ exists 0%R; split; [now rewrite Rabs_R0|].
  now rewrite (sqrt_neg x Nx), round_0, Rmult_0_l; [|apply valid_rnd_N]. }
assert (Fx' := generic_format_FLX_FLT _ _ _ _ Fx).
destruct (sqrt_error_N_FLX_ex _ Fx') as (d, (Bd, Hd)).
exists d; split; [exact Bd|]; rewrite <-Hd; apply round_FLT_FLX.
apply (Rle_trans _ (bpow (emin / 2)%Z)).
{ apply bpow_le, Z.div_le_lower_bound; lia. }
apply (Rle_trans _ _ _ (sqrt_bpow_ge _ _)).
rewrite Rabs_pos_eq; [|now apply sqrt_pos]; apply sqrt_le_1_alt.
revert Fx; apply generic_format_ge_bpow; [|exact Px].
intro e; unfold FLT_exp; apply Z.le_max_r.
Qed.

(** sqrt(1 + 2 u_ro) - 1 <= u_ro *)
Theorem sqrt_error_N_FLT_round_ex :
  forall x,
  generic_format beta (FLT_exp emin prec) x ->
  exists eps,
  (Rabs eps <= sqrt (1 + 2 * u_ro) - 1)%R /\
  sqrt x
  = (round beta (FLT_exp emin prec) (Znearest choice) (sqrt x) * (1 + eps))%R.
Proof.
now intros x Fx; apply sqrt_error_N_round_ex_derive, sqrt_error_N_FLT_ex.
Qed.

End Fprop_divsqrt_error.

Section format_REM_aux.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.
Context { monotone_exp : Monotone_exp fexp }.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Notation format := (generic_format beta fexp).

Lemma format_REM_aux:
  forall x y : R,
  format x -> format y -> (0 <= x)%R -> (0 < y)%R ->
  ((0 < x/y < /2)%R -> rnd (x/y) = 0%Z) ->
  format (x - IZR (rnd (x/y))*y).
Proof with auto with typeclass_instances.
intros x y Fx Fy Hx Hy rnd_small.
pose (n:=rnd (x / y)).
assert (Hn:(IZR n = round beta (FIX_exp 0) rnd (x/y))%R).
unfold round, FIX_exp, cexp, scaled_mantissa, F2R; simpl.
now rewrite 2!Rmult_1_r.
assert (H:(0 <= n)%Z).
apply le_IZR; rewrite Hn; simpl.
apply Rle_trans with (round beta (FIX_exp 0) rnd 0).
right; apply sym_eq, round_0...
apply round_le...
apply Fourier_util.Rle_mult_inv_pos; assumption.
case (Zle_lt_or_eq 0 n); try exact H.
clear H; intros H.
case (Zle_lt_or_eq 1 n).
omega.
clear H; intros H.
set (ex := cexp beta fexp x).
set (ey := cexp beta fexp y).
set (mx := Ztrunc (scaled_mantissa beta fexp x)).
set (my := Ztrunc (scaled_mantissa beta fexp y)).
case (Zle_or_lt ey ex); intros Hexy.
(* ey <= ex *)
assert (H0:(x-IZR n *y = F2R (Float beta (mx*beta^(ex-ey) - n*my) ey))%R).
unfold Rminus; rewrite Rplus_comm.
replace (IZR n) with (F2R (Float beta n 0)).
rewrite Fx, Fy.
fold mx my ex ey.
rewrite <- F2R_mult.
rewrite <- F2R_opp.
rewrite <- F2R_plus.
unfold Fplus. simpl.
rewrite Zle_imp_le_bool with (1 := Hexy).
f_equal; f_equal; ring.
unfold F2R; simpl; ring.
fold n; rewrite H0.
apply generic_format_F2R.
rewrite <- H0; intros H3.
apply monotone_exp.
apply mag_le_abs.
rewrite H0; apply F2R_neq_0; easy.
apply Rmult_le_reg_l with (/Rabs y)%R.
apply Rinv_0_lt_compat.
apply Rabs_pos_lt.
now apply Rgt_not_eq.
rewrite Rinv_l.
2: apply Rgt_not_eq, Rabs_pos_lt.
2: now apply Rgt_not_eq.
rewrite <- Rabs_Rinv.
2: now apply Rgt_not_eq.
rewrite <- Rabs_mult.
replace (/y * (x - IZR n *y))%R with (-(IZR n - x/y))%R.
rewrite Rabs_Ropp.
rewrite Hn.
apply Rle_trans with (1:= error_le_ulp beta (FIX_exp 0) _ _).
rewrite ulp_FIX.
simpl; apply Rle_refl.
field.
now apply Rgt_not_eq.
(* ex < ey: impossible as 1 < n *)
absurd (1 < n)%Z; try easy.
apply Zle_not_lt.
apply le_IZR; simpl; rewrite Hn.
apply round_le_generic...
apply generic_format_FIX.
exists (Float beta 1 0); try easy.
unfold F2R; simpl; ring.
apply Rmult_le_reg_r with y; try easy.
unfold Rdiv; rewrite Rmult_assoc.
rewrite Rinv_l, Rmult_1_r, Rmult_1_l.
2: now apply Rgt_not_eq.
assert (mag beta x < mag beta y)%Z.
case (Zle_or_lt (mag beta y) (mag beta x)); try easy.
intros J; apply monotone_exp in J; clear -J Hexy.
unfold ex, ey, cexp in Hexy; omega.
left; apply lt_mag with beta; easy.
(* n = 1 -> Sterbenz + rnd_small *)
intros Hn'; fold n; rewrite <- Hn'.
rewrite Rmult_1_l.
case Hx; intros Hx'.
assert (J:(0 < x/y)%R).
apply Fourier_util.Rlt_mult_inv_pos; assumption.
apply sterbenz...
assert (H0:(Rabs (1  - x/y) < 1)%R).
rewrite Hn', Hn.
apply Rlt_le_trans with (ulp beta (FIX_exp 0) (round beta (FIX_exp 0) rnd (x / y)))%R.
apply error_lt_ulp_round...
now apply Rgt_not_eq.
rewrite ulp_FIX.
rewrite <- Hn, <- Hn'.
apply Rle_refl.
apply Rabs_lt_inv in H0.
split; apply Rmult_le_reg_l with (/y)%R; try now apply Rinv_0_lt_compat.
unfold Rdiv; rewrite <- Rmult_assoc.
rewrite Rinv_l.
2: now apply Rgt_not_eq.
rewrite Rmult_1_l, Rmult_comm; fold (x/y)%R.
case (Rle_or_lt (/2) (x/y)); try easy.
intros K.
elim Zlt_not_le with (1 := H).
apply Zeq_le.
apply rnd_small.
now split.
apply Ropp_le_cancel; apply Rplus_le_reg_l with 1%R.
apply Rle_trans with (1-x/y)%R.
2: right; unfold Rdiv; ring.
left; apply Rle_lt_trans with (2:=proj1 H0).
right; field.
now apply Rgt_not_eq.
rewrite <- Hx', Rminus_0_l.
now apply generic_format_opp.
(* n = 0 *)
clear H; intros H; fold n; rewrite <- H.
now rewrite Rmult_0_l, Rminus_0_r.
Qed.

End format_REM_aux.

Section format_REM.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.
Context { monotone_exp : Monotone_exp fexp }.

Notation format := (generic_format beta fexp).

Theorem format_REM :
  forall rnd : R -> Z, Valid_rnd rnd ->
  forall x y : R,
  ((Rabs (x/y) < /2)%R -> rnd (x/y)%R = 0%Z) ->
  format x -> format y ->
  format (x - IZR (rnd (x/y)%R) * y).
Proof with auto with typeclass_instances.
(* assume 0 < y *)
assert (H: forall rnd : R -> Z, Valid_rnd rnd ->
  forall x y : R,
  ((Rabs (x/y) < /2)%R -> rnd (x/y)%R = 0%Z) ->
  format x -> format y -> (0 < y)%R ->
  format (x - IZR (rnd (x/y)%R) * y)).
intros rnd valid_rnd x y Hrnd Fx Fy Hy.
case (Rle_or_lt 0 x); intros Hx.
apply format_REM_aux; try easy.
intros K.
apply Hrnd.
rewrite Rabs_pos_eq.
apply K.
apply Rlt_le, K.
replace (x - IZR (rnd (x/y)) * y)%R with
   (- (-x - IZR (Zrnd_opp rnd (-x/y)) * y))%R.
apply generic_format_opp.
apply format_REM_aux; try easy...
now apply generic_format_opp.
apply Ropp_le_cancel; rewrite Ropp_0, Ropp_involutive; now left.
replace (- x / y)%R with (- (x/y))%R by (unfold Rdiv; ring).
intros K.
unfold Zrnd_opp.
rewrite Ropp_involutive, Hrnd.
easy.
rewrite Rabs_left.
apply K.
apply Ropp_lt_cancel.
now rewrite Ropp_0.
unfold Zrnd_opp.
replace (- (- x / y))%R with (x / y)%R by (unfold Rdiv; ring).
rewrite opp_IZR.
ring.
(* *)
intros rnd valid_rnd x y Hrnd Fx Fy.
case (Rle_or_lt 0 y); intros Hy.
destruct Hy as [Hy|Hy].
now apply H.
now rewrite <- Hy, Rmult_0_r, Rminus_0_r.
replace (IZR (rnd (x/y)) * y)%R with
  (IZR ((Zrnd_opp rnd) ((x / -y))) * -y)%R.
apply H; try easy...
replace (x / - y)%R with (- (x/y))%R.
intros K.
unfold Zrnd_opp.
rewrite Ropp_involutive, Hrnd.
easy.
now rewrite <- Rabs_Ropp.
field; now apply Rlt_not_eq.
now apply generic_format_opp.
apply Ropp_lt_cancel; now rewrite Ropp_0, Ropp_involutive.
unfold Zrnd_opp.
replace (- (x / - y))%R with (x/y)%R.
rewrite opp_IZR.
ring.
field; now apply Rlt_not_eq.
Qed.

Theorem format_REM_ZR:
  forall x y : R,
  format x -> format y ->
  format (x - IZR (Ztrunc (x/y)) * y).
Proof with auto with typeclass_instances.
intros x y Fx Fy.
apply format_REM; try easy...
intros K.
apply Z.abs_0_iff.
rewrite <- Ztrunc_abs.
rewrite Ztrunc_floor by apply Rabs_pos.
apply Zle_antisym.
replace 0%Z with (Zfloor (/2)).
apply Zfloor_le.
now apply Rlt_le.
apply Zfloor_imp.
simpl ; lra.
apply Zfloor_lub.
apply Rabs_pos.
Qed.

Theorem format_REM_N :
  forall choice,
  forall x y : R,
  format x -> format y ->
  format (x - IZR (Znearest choice (x/y)) * y).
Proof with auto with typeclass_instances.
intros choice x y Fx Fy.
apply format_REM; try easy...
intros K.
apply Znearest_imp.
now rewrite Rminus_0_r.
Qed.

End format_REM.


Require Import isla.isla.
Require Import isla.aarch64.aarch64.
Require Export isla.instructions.binary_search.a4.

Lemma a4_spec `{!islaG Σ} `{!threadG} pc:
  instr pc (Some a4) -∗
  instr_body pc (stp_uninit_spec pc "R24" "R23" "SP_EL2" (16) false).
Proof.
  iStartProof.
  repeat liAStep; liShow.
  Unshelve. all: prepare_sidecond.
  all: bv_solve.
Qed.

Definition a4_spec_inst `{!islaG Σ} `{!threadG} pc :=
  entails_to_simplify_hyp 0 (a4_spec pc).
Global Existing Instance a4_spec_inst.


Require Import isla.isla.
Require Import isla.aarch64.aarch64.
Require Export isla.instructions.binary_search.a8.

Lemma a8_spec `{!islaG Σ} `{!threadG} pc:
  instr pc (Some a8) -∗
  instr_body pc (stp_uninit_spec pc "R22" "R21" "SP_EL2" (32) false).
Proof.
  iStartProof.
  repeat liAStep; liShow.
  Unshelve. all: prepare_sidecond.
  all: bv_solve.
Qed.

Definition a8_spec_inst `{!islaG Σ} `{!threadG} pc :=
  entails_to_simplify_hyp 0 (a8_spec pc).
Global Existing Instance a8_spec_inst.


Set Implicit Arguments.

Require Import Coq.Logic.ProofIrrelevance.
Require Import Coq.Structures.Equalities.
Require Import PArith.BinPos.
Require Import NArith.BinNat.
Local Open Scope N_scope.

Module Type WORD <: MiniDecidableType.

  (** Opaque representation of the word *)
  Parameter t : Type.

  (** bit-width *)
  Parameter width : positive.

  Parameter eq_dec : forall (m n : t), { m = n } + { m <> n }.

  Parameter zero : t.

End WORD.

(** Supress generating _rec and _rect for words defined below. *)
Unset Elimination Schemes.

Module Type WIDTH.

  Parameter width : positive.

End WIDTH.

Module Type MAKEWORD.

  Local Open Scope N_scope.

  Parameter width : positive.

  Inductive Word : Type :=
  | Mk : forall (v : N), v < 2 ^ N.pos width -> Word.

  Definition t := Word.

End MAKEWORD.

Module MakeWord (Width : WIDTH).

  Local Open Scope N_scope.

  Definition width := Width.width.

  Inductive Word : Type :=
  | Mk : forall (v : N), v < 2 ^ N.pos width -> Word.

  Definition t := Word.

  Definition zero : t := @Mk 0 eq_refl.

End MakeWord.

Module Width8 <: WIDTH.

  Definition width := 8 %positive.

End Width8.

Module Width12 <: WIDTH.

  Definition width := 12 %positive.

End Width12.

Module Width16 <: WIDTH.

  Definition width := 16 %positive.

End Width16.

Module Width32 <: WIDTH.

  Definition width := 32 %positive.

End Width32.

Module Width48 <: WIDTH.

  Definition width := 48 %positive.

End Width48.

Module Width64 <: WIDTH.

  Definition width := 64 %positive.

End Width64.

(** Semantically, this module is equivalent to:

      Module Word8 := MakeWord (Width8).

    However, the more elaborate definition below allows us to extract
    words of different widths to different OCaml types. *)
Module Word8 <: WORD.

  Module M := MakeWord (Width8).
  Include M.
  Parameter eq_dec : forall (m n : t), { m = n } + { m <> n }.

End Word8.

Module Word12 <: WORD.

  Module M := MakeWord (Width12).
  Include M.
  Parameter eq_dec : forall (m n : t), { m = n } + { m <> n }.

End Word12.

Module Word16 <: WORD.

  Module M := MakeWord (Width16).

  Include M.
  Parameter eq_dec : forall (m n : t), { m = n } + { m <> n }.

  Definition to_nat (w : Word) : nat :=
    match w with
      | Mk n _ => N.to_nat n
    end.

  Definition max_value : t := @Mk 65535 eq_refl.

  (* TODO(arjun): broken now for simplicity *)
  Axiom pred : Word -> Word.

End Word16.

Module Word32 <: WORD.

  Module M := MakeWord (Width32).
  Include M.
  Parameter eq_dec : forall (m n : t), { m = n } + { m <> n }.
End Word32.

Module Word48 <: WORD.

  Module M := MakeWord (Width48).
  Include M.
  Parameter eq_dec : forall (m n : t), { m = n } + { m <> n }.

End Word48.

Module Word64 <: WORD.

  Module M := MakeWord (Width64).
  Include M.
  Parameter eq_dec : forall (m n : t), { m = n } + { m <> n }.

End Word64.

Extract Constant Word16.pred => "(fun n -> if n = 0 then 0 else n - 1)". (* TODO: really fix this (JNF) *)
Extract Constant Word16.max_value => "65535".

Extract Inductive Word8.Word => "int" [ "" ].
Extract Inductive Word12.Word => "int" [ "" ].
Extract Inductive Word16.Word => "int" [ "" ].
Extract Inductive Word32.Word => "int32" [ "" ].
Extract Inductive Word48.Word => "int64" [ "" ].
Extract Inductive Word64.Word => "int64" [ "" ].

Extract Constant Word8.eq_dec => "(=)".
Extract Constant Word12.eq_dec => "(=)".
Extract Constant Word16.eq_dec => "(=)".
Extract Constant Word32.eq_dec => "(=)".
Extract Constant Word48.eq_dec => "(=)".
Extract Constant Word64.eq_dec => "(=)".

Extract Constant Word8.zero => "0".
Extract Constant Word12.zero => "0".
Extract Constant Word16.zero => "0".
Extract Constant Word32.zero => "Int32.zero".
Extract Constant Word48.zero => "Int64.zero".
Extract Constant Word64.zero => "Int64.zero".

Extract Constant Word16.to_nat => "(fun x -> x)".