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


Require Import Axioms.

Require Import sepcomp. Import SepComp.
Require Import semantics.
Require Import semantics_lemmas.
Require Import simulations.

Require Import pos.
Require Import stack.
Require Import cast.
Require Import compcert_linking.
Require Import compcert_threads.
Require Import thread_inv.

Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype finfun.
Set Implicit Arguments.

Require Import AST.    (*for typ*)
Require Import Values. (*for val*)
Require Import Globalenvs.
Require Import Memory.
Require Import Integers.

Require Import ZArith.

Module ThreadsSimulate. Section ThreadsSimulate.

Import SM_simulation.

Variables semS semT : Modsem.t.

Variable pS : ThreadPool.t semS.

Variable pT : ThreadPool.t semT.

Import ThreadPool.

Import SM_simulation.

Notation SIM semS semT geS geT := (SM_simulation_inject semS semT geS geT).

Variable sim :
  SIM (Modsem.sem semS) (Modsem.sem semT) (Modsem.ge semS) (Modsem.ge semT).

Variable schedule : nat -> nat.

Variables aggelosS : nat -> PermMap.t.

Lemma threads_safe Z Espec mu c m d tm (z : Z) :
  @ThreadInv.t semS semT c d sim mu m tm ->
  (forall n, safeN (@Concur.semantics semS aggelosS schedule) Espec
               (Modsem.ge semS) n z c m) ->
  (forall n,
   exists aggelosT : nat -> PermMap.t,
     safeN (@Concur.semantics semT aggelosT schedule) Espec
               (Modsem.ge semT) n z d tm).
Proof.
move=> INV SAFE n; move: mu c m d tm z INV SAFE; elim: n.
{ by move=> /= ??????; exists (fun _ => aggelosS 0).
}
{ move=> n IH mu c m d tm z INV SAFE /=.
  move: (SAFE)=> SAFE0.
  move: (SAFE (S n))=> /=.
  case atS : (Concur.at_external _ c)=> [[[ef sg] argsS]|].
  { admit. (*TODO*) }
  { have ->: Concur.at_external schedule d = None.
    { admit. }
    case=> c' []m' []STEP SAFE'.
    inversion STEP; subst.
    { (*step0*)
      move: H0=> step0; move: H=> getS.
      have [U estep0]:
        exists U, effstepN (Modsem.sem semS) (Modsem.ge semS) n0.+1 U
                           c0 m c'0 m'.
      { admit. }
      case: (ThreadInv.krun_inv INV (Ordinal tid0_lt_pf) getS).
      move=> d0 []getT []cd MATCH.
      have [d'0 [tm' [n1 [T [mu' [tstep0 [tcant MATCH']]]]]]]:
        exists d'0 tm' n1 T mu',
          effstepN (Modsem.sem semT) (Modsem.ge semT) n1.+1 T
                   d0 tm d'0 tm'
          /\ cant_step (Modsem.sem semT) d'0
          /\ match_state sim cd mu' c'0 m' d'0 tm'.
      { admit. }
      set (c' := updThread c
                 (Ordinal (n:=num_threads c) (m:=schedule (counter c)) tid0_lt_pf)
                 (Krun c'0)).
      have tid0_lt_pf' : schedule (counter d) < num_threads d.
      { admit. }
      set (d' := updThread d
                 (Ordinal (n:=num_threads d) (m:=schedule (counter d)) tid0_lt_pf')
                 (Krun d'0)).
      have INV': ThreadInv.t c' d' sim mu' m' tm'.
      { admit. }
      have SAFE0': forall n : nat,
        safeN (Concur.semantics aggelosS schedule) Espec (Modsem.ge semS) n z c' m'.
      { admit. }
      case: (IH mu' c' m' d' tm' z INV' SAFE0')=> aggelosT TSAFE.
      exists aggelosT, d', tm'; split; last by [].
      apply Concur.step_congr with d0 n1=> //.
      { admit. (*dependent types*) }
      { by apply: effstepN_corestepN. }
    }
    {
      set (c' := schedNext (updThread c
                  (Ordinal (n:=num_threads c) (m:=schedule (counter c))
                     tid0_lt_pf) (Kstage ef args c0))) in *.
      case: (ThreadInv.krun_inv INV _ H)=> d0 []H' []cd MATCH.
      case: (core_at_external sim cd mu _ _ _ _ MATCH H0)=> inj []args2.
      case=> hfor []at2 H2.
      have tid1_lt_pf: schedule (counter d) < num_threads d.
      { admit. }
      set (d' := schedNext (updThread d
                  (Ordinal (n:=num_threads d) (m:=schedule (counter d))
                     tid1_lt_pf) (Kstage ef args2 d0))) in *.
      set (pubSrc' :=
             (fun b : block =>
                locBlocksSrc mu b && REACH m' (exportedSrc mu args) b)) in *.
      set (pubTgt' :=
             (fun b : block =>
                   locBlocksTgt mu b && REACH tm (exportedTgt mu args2) b)) in *.
      set (nu := replace_locals mu pubSrc' pubTgt').
      case: (H2 pubSrc' pubTgt' erefl erefl nu erefl)=> MATCH' INJ'.
      have INV': ThreadInv.t c' d' sim nu m' tm.
      { admit. }
      have SAFE'': (forall n0 : nat,
                      safeN (Concur.semantics aggelosS schedule) Espec
                            (Modsem.ge semS) n0 z c' m').
      { admit. }
      case: (IH _ _ _ _ _ _ INV' SAFE'')=> aggelosT TSAFE.
      exists aggelosT, d', tm; split=> //.
      apply: Concur.step_stage=> //.
      move: H'. admit. (*dependent type stuff*)
    }
    {
      set (c' := updThread c
                  (Ordinal (n:=num_threads c) (m:=schedule (counter c))
                     tid0_lt_pf) (Krun c'0)) in *.
      case: (ThreadInv.kstage_inv INV _ H)=> d0 []argsT []H' []vinj []at2 []cd MATCH.
      have [b' [delta [inj vinj']]]:
        exists b' delta,
          as_inj mu b = Some (b', delta)
          /\ argsT = [:: Vptr b' (Int.add ofs (Int.repr delta))].
      { admit. }
      rewrite vinj' in H'; move {vinj vinj' argsT}.
      have tid0'_lt_pf: schedule (counter d) < num_threads d.
      { admit. }
      have [d'0 H2']:
        exists d'0,
          after_external (Modsem.sem semT) (Some (Vint Int.zero)) d0 = Some d'0.
      { admit. }
      set (d' := updThread d
                   (Ordinal (n:=num_threads d) (m:=schedule (counter d))
                      tid0'_lt_pf) (Krun d'0)) in *.
      have H0':
        Mem.load Mint32 tm b' (Int.intval (Int.add ofs (Int.repr delta)))
          = Some (Vint Int.one).
      { admit. }
      have [tm'' H1']:
        exists tm'',
          Mem.store Mint32 tm b' (Int.intval (Int.add ofs (Int.repr delta))) (Vint Int.zero)
            = Some tm''.
      { admit. }
      set (pubSrc' :=
             (fun b : block =>
                locBlocksSrc mu b && REACH m' (exportedSrc mu [:: Vptr b ofs]) b)) in *.
      set (pubTgt' :=
             (fun b : block =>
                locBlocksTgt mu b
                && REACH tm
                   (exportedTgt mu [:: Vptr b' (Int.add ofs (Int.repr delta))]) b)) in *.
      set (nu := replace_locals mu pubSrc' pubTgt').
      have [mu' [tm' [pm [H3' inj']]]]:
        exists mu' tm' pm,
          updPermMap tm'' pm = Some tm'
          /\ Mem.inject (as_inj mu') m' tm'.
      { admit. }
      have INV': ThreadInv.t c' d' sim mu' m' tm'.
      { admit. }
      have SAFE'': (forall n0 : nat,
                      safeN (Concur.semantics aggelosS schedule) Espec
                            (Modsem.ge semS) n0 z c' m').
      { admit. }
      case: (IH _ _ _ _ _ _ INV' SAFE'')=> aggelosT TSAFE'.
      set (aggelosT' := fun n => if eq_nat_dec n (counter d) then pm else aggelosT n).
      exists aggelosT', d', tm'; split=> //.
      eapply Concur.step_lock; eauto.
      { admit. (*dependent types stuff*) }
      { by rewrite /aggelosT'; case: (eq_nat_dec _ _). }
      { clear - TSAFE'; rewrite /aggelosT'.
        admit. (*by [counter d' = counter d.+1] and an aux. lemma about
                 safety in concurrent machine, namely:
                  if two angels [x] and [y] are equal at positions [counter d']
                  and greater, then [d'] is safe in [x] iff safe in [y]. *) }
    }
    { admit. (*UNLOCK, symmetric (?)*) }
    { set (c' :=
        schedNext
          (addThread
             (updThread c
                (Ordinal (n:=num_threads c)
                         (m:= schedule (counter c)) tid0_lt_pf)
                (Krun c'0)) (Krun c_new))) in *.
      case: (ThreadInv.kstage_inv INV _ H)=> d0 []argsT []H' []vinj []at2 []cd MATCH.
      have [vf' [arg' [inj [vinj' vinj'']]]]:
        exists vf' arg',
          argsT = (vf' :: arg' :: nil)
          /\ val_inject (as_inj mu) vf vf'
          /\ val_inject (as_inj mu) arg arg'.
      { admit. }
      rewrite inj in H'; move {inj vinj}.
      have tid0'_lt_pf: schedule (counter d) < num_threads d.
      { admit. }
      have [d'0 H2']:
        exists d'0,
          after_external (Modsem.sem semT) (Some (Vint Int.zero)) d0 = Some d'0.
      { admit. }
      have [d_new H0']:
        exists d_new,
          initial_core (Modsem.sem semT) (Modsem.ge semT) vf' [:: arg']
          = Some d_new.
      { admit. }
      set (d' :=
        schedNext
          (addThread
             (updThread d
                (Ordinal (n:=num_threads d)
                         (m:= schedule (counter d)) tid0'_lt_pf)
                (Krun d'0)) (Krun d_new))) in *.
      have INV': ThreadInv.t c' d' sim mu m' tm.
      { admit. }
      have SAFE'': (forall n0 : nat,
                      safeN (Concur.semantics aggelosS schedule) Espec
                            (Modsem.ge semS) n0 z c' m').
      { admit. }
      case: (IH _ _ _ _ _ _ INV' SAFE'')=> aggelosT TSAFE'.
      exists aggelosT, d', tm; split=> //.
      eapply Concur.step_create; eauto.
      { admit. (*dependent types stuff*) }
    }
  }
}
Qed.

End ThreadsSimulate. End ThreadsSimulate.


Require Import ZArith Int63.
Open Scope uint63.
Require Import coqutil.Map.Interface.
Require Import Tries.Canonical.
Import PTree.

Require Utils.ArrayList Utils.TrieMap.
(*
(* positives consed when they should be appended*)
Fixpoint trie_fold' {B A} (f : A -> positive -> B -> A) (acc : A) (m : PTree.tree' B)
         (*TODO: find a better way*)
         (num : positive -> positive) : A :=
  match m with
  | Node001 r => trie_fold' f acc r (fun a => num (xI a))
  | Node010 y => f acc (num xH) y
  | Node011 y r =>
      let acc := f acc (num xH) y in
      trie_fold' f acc r (fun a => num (xI a))
  | Node100 l => trie_fold' f acc l (fun a => num (xO a))
  | Node101 l r =>
      let acc := trie_fold' f acc r (fun a => num (xI a)) in
      trie_fold' f acc l (fun a => num (xO a))
  | Node110 l y =>
      let acc := f acc (num xH) y in
      trie_fold' f acc l (fun a => num (xO a))
  | Node111 l y r =>
      let acc := f acc (num xH) y in
      let acc := trie_fold' f acc r (fun a => num (xI a)) in
      trie_fold' f acc l (fun a => num (xO a))
end.

Definition trie_fold {B A} (f : A -> positive -> B -> A) (acc : A) (m : PTree.t B) : A :=
  match m with
  | Empty => acc
  | Nodes m' => trie_fold' f acc m' id
  end.

 *)

(** PTree operations reimplemented for i63.
    Note that we can't differentiate between 0 and 000 by default,
    so we trim all leading 0s to avoid making each access have depth 64.
 *)

(* Note: this can be expensive for large numbers, should only be called on small ones.
   Invariant: this file only calls it on numbers <= digits
 *)
Local Definition int_to_nat (i : int) := Z.to_nat (Uint63.to_Z i).

Fixpoint get' {A} (p: int) (m: tree' A) (msb : nat) : option A :=
  let q := lsr p 1 in
  match msb, m, is_zero (Int63.land p 1) with
  | O, Node001 _, _ => None
  | O, Node010 x, _ => Some x
  | O, Node011 x _, _ => Some x
  | O, Node100 _, _ => None
  | O, Node101 _ _, _ => None
  | O, Node110 _ x, _ => Some x
  | O, Node111 _ x _, _ => Some x
  | S msb, Node001 _, true => None
  | S msb, Node010 _, true => None
  | S msb, Node011 _ _, true => None
  | S msb, Node100 m', true => get' q m' msb
  | S msb, Node101 m' _, true => get' q m' msb
  | S msb, Node110 m' _, true => get' q m' msb
  | S msb, Node111 m' _ _, true => get' q m' msb
  | S msb, Node001 m', false => get' q m' msb
  | S msb, Node010 _, false => None
  | S msb, Node011 _ m', false => get' q m' msb
  | S msb, Node100 m', false => None
  | S msb, Node101 _ m', false => get' q m' msb
  | S msb, Node110 _ _, false => None
  | S msb, Node111 _ _ m', false => get' q m' msb
  end.

(* TODO: we always use int_to_nat (msb p). Should we implement that directly?
   It would probably be faster.
 *)
Definition msb i := sub digits (head0 i).

Definition get {A} (m : tree A) (p: int) : option A :=
  match m with
  | Empty => None
  | Nodes m' => get' p m' (int_to_nat (msb p))
  end.

Fixpoint set0 {A} (p: int) (x: A) (msb : nat) : tree' A :=
  let q := lsr p 1 in
  match msb, is_zero (Int63.land p 1) with
  | O, _ => Node010 x
  | S msb, true => Node100 (set0 q x msb)
  | S msb, false => Node001 (set0 q x msb)
  end.

Fixpoint set' {A} (p: int) (x: A) (m: tree' A) (msb : nat) : tree' A :=
  let q := lsr p 1 in
match msb, m, is_zero (Int63.land p 1) with
| O, Node001 r, _ => Node011 x r
| O, Node010 _, _ => Node010 x
| O, Node011 _ r, _ => Node011 x r
| O, Node100 l, _ => Node110 l x
| O, Node101 l r, _ => Node111 l x r
| O, Node110 l _, _ => Node110 l x
| O, Node111 l _ r, _ => Node111 l x r
| S msb, Node001 r, true => Node101 (set0 q x msb) r
| S msb, Node010 y, true => Node110 (set0 q x msb) y
| S msb, Node011 y r, true => Node111 (set0 q x msb) y r
| S msb, Node100 l, true => Node100 (set' q x l msb)
| S msb, Node101 l r, true => Node101 (set' q x l msb) r
| S msb, Node110 l y, true => Node110 (set' q x l msb) y
| S msb, Node111 l y r, true => Node111 (set' q x l msb) y r
| S msb, Node001 r, false => Node001 (set' q x r msb)
| S msb, Node010 y, false => Node011 y (set0 q x msb)
| S msb, Node011 y r, false => Node011 y (set' q x r msb)
| S msb, Node100 l, false => Node101 l (set0 q x msb)
| S msb, Node101 l r, false => Node101 l (set' q x r msb)
| S msb, Node110 l y, false => Node111 l y (set0 q x msb)
| S msb, Node111 l y r, false => Node111 l y (set' q x r msb)
end.

Definition set {A} (m: tree A) (p: int) (x: A) : tree A :=
match m with
| Empty => Nodes (set0 p x (int_to_nat (msb p)))
| Nodes m' => Nodes (set' p x m' (int_to_nat (msb p)))
end.

Fixpoint rem' {A} (p: int) (m: tree' A) (msb : nat) : tree A :=
  let q := lsr p 1 in
  match msb, m, is_zero (Int63.land p 1) with
  | O, Node001 r,_ => Nodes m
  | O, Node010 _,_ => Empty
  | O, Node011 _ r,_ => Nodes (Node001 r)
  | O, Node100 l,_ => Nodes m
  | O, Node101 l r,_ => Nodes m
  | O, Node110 l _,_ => Nodes (Node100 l)
  | O, Node111 l _ r,_ => Nodes (Node101 l r)
  | S msb, Node001 r, true => Nodes m
  | S msb, Node010 y, true => Nodes m
  | S msb, Node011 y r, true => Nodes m
  | S msb, Node100 l, true => Node (rem' q l msb) None Empty
  | S msb, Node101 l r, true => Node (rem' q l msb) None (Nodes r)
  | S msb, Node110 l y, true => Node (rem' q l msb) (Some y) Empty
  | S msb, Node111 l y r, true => Node (rem' q l msb) (Some y) (Nodes r)
  | S msb, Node001 r, false => Node Empty None (rem' q r msb)
  | S msb, Node010 y, false => Nodes m
  | S msb, Node011 y r, false => Node Empty (Some y) (rem' q r msb)
  | S msb, Node100 l, false => Nodes m
  | S msb, Node101 l r, false => Node (Nodes l) None (rem' q r msb)
  | S msb, Node110 l y, false => Nodes m
  | S msb, Node111 l y r, false => Node (Nodes l) (Some y) (rem' q r msb)
  end.

(** This use of [Node] causes some run-time overhead, which we eliminate
    by asking Coq to unfold the definition of [Node] in [rem'],
    then simplify the definition.  This is a form of partial evaluation. *)

Definition remove' := Eval cbv [rem' Node] in @rem'.

Definition remove {A} (m: tree A)  (p: int) : tree A :=
match m with
| Empty => Empty
| Nodes m' => remove' _ p m' (int_to_nat (msb p))
end.

(*
Fixpoint msb' (fuel : nat) (i : int) : nat * int :=
  match fuel with
  (* Should never happen? *)
  | 0 => (O, 0)
  | S fuel =>
      let i' := i >> 1 in
      if is_zero i'
      then (O,0)
      else
        let (n,i) := msb' fuel i' in
        (S n, i + 1)
  end.

Definition msb := msb' size.

(* Note: this should not be used outside this module.
   It does not represent an principled transformation.
 (* Note: assumes the input is nonnegative, in which case the function is bijective *)
 *)
Local Definition to_pos (i:int) : positive :=
  (*adding 1 to make sure that 0 gets mapped to a positive. *)
  match to_Z (i + 1) with
  | Zpos p => p
  (*should never happen*)
  | _ => xH
  end.
(*
  TODO: this is a very poor implementation of fold, improve
 *)*)

Section __.

  Context (value : Type).

  Section Fold.
    Context {R : Type} (f : R -> int -> value -> R).

    Fixpoint fold' (acc : R) (m : tree' value) (i : int) : R :=
      (*0 bit ~> left
        1 bit ~> right
       *)
      let i'_l := lsr i 1 in
      let i'_r := Int63.lor i'_l 1 in
      match m with
      | Node001 r => fold' acc r i'_r
      | Node010 v => f acc i v
      | Node011 v r => fold' (f acc i v) r i'_r
      | Node100 l => fold' acc l i'_l
      | Node101 l r => fold' (fold' acc r i'_r) l i'_l
      | Node110 l v => fold' (f acc i v) l i'_l
      | Node111 l v r => fold' (fold' (f acc i v) r i'_r) l i'_l
      end.

    Definition fold (acc : R) (m : tree value) : R :=
      match m with
      | Empty => acc
      | Nodes m' => fold' acc m' 0
      end.

  End Fold.

  Instance map : map.map int value :=
    {|
      map.rep := PTree.t value;
      map.empty := PTree.empty value;
      map.get := get;
      map.put := set;
      map.remove := remove;
      map.fold := @fold;
    |}.

  (* TODO: prove map.ok *)
End __.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

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

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export type_sys_useful.
Require Import dest_close.

Lemma close_type_system_isect {p} :
  forall lib (ts : cts(p))
         T T'
         (eq : per)
         A A' v v' B B' eqa eqb,
    type_system lib ts
    -> defines_only_universes lib ts
    -> computes_to_valc lib T (mkc_isect A v B)
    -> computes_to_valc lib T' (mkc_isect A' v' B')
    -> close lib ts A A' eqa
    -> (forall (a a' : CTerm) (e : eqa a a'),
          close lib ts (substc a v B) (substc a' v' B') (eqb a a' e))
    -> (forall (a a' : CTerm) (e : eqa a a'),
          type_system lib ts ->
          defines_only_universes lib ts ->
          type_sys_props lib (close lib ts) (substc a v B) (substc a' v' B')
                         (eqb a a' e))
    -> (forall t t' : CTerm,
          eq t t' <=> (forall (a a' : CTerm) (e : eqa a a'), eqb a a' e t t'))
    -> per_isect lib (close lib ts) T T' eq
    -> type_sys_props lib (close lib ts) A A' eqa
    -> type_sys_props lib (close lib ts) T T' eq.
Proof.
  introv X X0 c1 c2 X1 clb recb eqiff per IHX1.

  rw @type_sys_props_iff_type_sys_props3.
  prove_type_sys_props3 SCase; intros.

  + SCase "uniquely_valued".
    dclose_lr.

    SSCase "CL_isect".
    allunfold @per_isect; exrepd.
    generalize (eq_term_equals_type_family lib T T3 eqa0 eqa eqb0 eqb (close lib ts) A v B A' v' B' mkc_isect); intro i.
    repeat (autodimp i hyp; try (complete (introv e; eqconstr e; sp))); repnd.

    unfold eq_term_equals; sp.
    rw t0; rw eqiff; split; sp.

    duplicate e as e'; rw <- i0 in e.
    generalize (i1 a a' e' e); intro k.
    rw k; sp.

    duplicate e as e'; rw i0 in e.
    generalize (i1 a a' e e'); intro k.
    rw <- k; sp.

  + SCase "type_symmetric"; repdors; subst; dclose_lr;
    apply CL_isect;
    clear per;
    allunfold @per_isect; exrepd;
    unfold per_isect;
    exists eqa0 eqb0; sp;
    allrw <-; sp.

  + SCase "type_value_respecting"; repdors; subst;
    apply CL_isect; unfold per_isect; exists eqa eqb; sp.

    duplicate c1 as ct.
    apply @cequivc_mkc_isect with (T' := T3) in ct; sp.

    apply @type_family_cequivc
          with
          (A1 := A)
          (v1 := v)
          (B1 := B)
          (A2 := A'0)
          (v2 := v'0)
          (B2 := B'0)
          (A := A')
          (v := v')
          (B := B'); sp.

    duplicate c2 as ct.
    apply @cequivc_mkc_isect with (T' := T3) in ct; sp.

    apply @type_family_cequivc2
          with
          (A1 := A')
          (v1 := v')
          (B1 := B')
          (A2 := A'0)
          (v2 := v'0)
          (B2 := B'0)
          (A := A)
          (v := v)
          (B := B); sp.

  + SCase "term_symmetric".
    unfold term_equality_symmetric; sp.
    onedtsp e pp p0 p1 c t t0 t3 tygs tygt dum.
    apply eqiff; sp.
    assert (eqa a a) as eqaa by (apply t0 with (t2 := a'); auto).
    assert (eqa a' a) as e' by auto.
    assert (eq t1 t2) as eq12 by auto.
    apply eqiff with (a := a') (a' := a) (e := e') in eq12; auto.

    generalize (eq_term_equals_sym_tsp lib (close lib ts) eqa eqb a a' eqaa e0 e'
                                       v B v' B'); intro i.
    autodimp i h; repnd.

    (* Now we prove the equality between the applies *)
    unfold eq_term_equals in i.
    apply i in eq12.
    generalize (recb a a' e0); sp.
    onedtsp X5 X6 X7 X8 X9 X10 X11 X4 tygs1 tygt1 dum1; sp.

  + SCase "term_transitive".
    unfold term_equality_transitive; sp.
    apply eqiff; sp.
    assert (eq t1 t2) as eq12 by auto.
    assert (eq t2 t3) as eq23 by auto.
    apply eqiff with (a := a) (a' := a') (e := e) in eq12; auto.
    apply eqiff with (a := a) (a' := a') (e := e) in eq23; auto.

    onedtsp IHX0 IHX2 IHX3 IHX4 IHX5 IHX6 IHX7 IHX8 tygs tygt dum.

    generalize (recb a a' e); intro tsp.
    unfold type_sys_props in tsp; sp.
    apply tsp6 with (t2 := t2); auto.

  + SCase "term_value_respecting".
    unfold term_equality_respecting; sp.
    apply eqiff; sp.
    assert (eq t t) as eqtt by auto.
    apply eqiff with (a := a) (a' := a') (e := e) in eqtt; auto.

    generalize (recb a a' e); sp.
    onedtsp X5 X6 X7 X8 X9 X10 X11 X4 tygs1 tygt1 dum1; sp.

  + SCase "type_gsymmetric"; repdors; subst; split; sp; dclose_lr;
    apply CL_isect;
    clear per;
    allunfold @per_isect; exrepd.

    (* 1 *)
    generalize (eq_term_equals_type_family
                  lib T T3 eqa0 eqa eqb0 eqb (close lib ts)
                  A v B A' v' B' mkc_isect); intro i.
    repeat (autodimp i hyp; try (complete (introv e; eqconstr e; sp))).
    repnd.

    unfold per_isect.
    exists eqa eqb; sp.

    rw t0; split; intro k; sp.

    duplicate e as e'.
    rw i0 in e.
    generalize (k a a' e); intro j.
    generalize (i1 a a' e e'); intro eqt.
    rw eqt in j; sp.

    duplicate e as e'.
    rw <- i0 in e.
    generalize (k a a' e); intro j.
    generalize (i1 a a' e' e); intro eqt.
    rw <- eqt in j; sp.

    (* 2 *)
    generalize (eq_term_equals_type_family2
                  lib T3 T eqa0 eqa eqb0 eqb (close lib ts)
                  A v B A' v' B' mkc_isect); intro i;
    repeat (autodimp i hyp; try (complete (introv e; eqconstr e; sp)));
    repnd.

    unfold per_isect.
    exists eqa eqb; sp.

    rw t0; split; intro k; sp.

    duplicate e as e'.
    rw i0 in e.
    generalize (k a a' e); intro j.
    generalize (i1 a a' e e'); intro eqt.
    rw eqt in j; sp.

    duplicate e as e'.
    rw <- i0 in e.
    generalize (k a a' e); intro j.
    generalize (i1 a a' e' e); intro eqt.
    rw <- eqt in j; sp.

  + SCase "type_gtransitive"; sp.

  + SCase "type_mtransitive".
    repdors; subst; dclose_lr;
    try (move_term_to_top (per_isect lib (close lib ts) T T4 eq2));
    try (move_term_to_top (per_isect lib (close lib ts) T' T4 eq2)).

    (* 1 *)
    clear per.
    allunfold @per_isect; exrepd.

    generalize (eq_term_equals_type_family2
                  lib T3 T eqa1 eqa eqb1 eqb (close lib ts)
                  A v B A' v' B' mkc_isect); intro i.
    repeat (autodimp i hyp; try (complete (introv e; eqconstr e; sp))).
    repnd.

    generalize (type_family_trans2
                  lib mkc_isect (close lib ts) T3 T T4 eqa eqb eqa0 eqb0 A v B A' v' B'); intro j.
    repeat (autodimp j hyp; try (complete (introv e; eqconstr e; sp))).
    repnd.

    dands; apply CL_isect; unfold per_isect; exists eqa eqb; sp; allrw.

    split; intro pp; sp.

    assert (eqa1 a a') as e' by (rw <- i0; auto).
    generalize (pp a a' e'); intro k.
    generalize (i1 a a' e' e); intro l.
    rw <- l; sp.

    assert (eqa a a') as e' by (rw i0; auto).
    generalize (pp a a' e'); intro k.
    generalize (i1 a a' e e'); intro l.
    rw l; sp.

    split; intro pp; sp.

    assert (eqa0 a a') as e' by (rw <- j0; auto).
    generalize (pp a a' e'); intro k.
    generalize (j1 a a' e e'); intro l.
    rw l; sp.

    assert (eqa a a') as e' by (rw j0; auto).
    generalize (pp a a' e'); intro k.
    generalize (j1 a a' e' e); intro l.
    rw <- l; sp.

    (* 2 *)
    clear per.
    allunfold @per_isect; exrepd.

    generalize (eq_term_equals_type_family2
                  lib T3 T' eqa1 eqa eqb1 eqb (close lib ts)
                  A' v' B' A v B mkc_isect); intro i.
    repeat (autodimp i hyp;
            try (complete (introv e; eqconstr e; sp));
            try (complete (apply type_sys_props_sym; sp))).
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
    intros.
    apply type_sys_props_sym.
    apply type_sys_props_eqb_comm; sp.
    apply tet with (t2 := a'); sp.
    apply tet with (t2 := a); sp.
    repnd.

    generalize (type_family_trans2
                  lib mkc_isect (close lib ts) T3 T' T4 eqa eqb eqa0 eqb0 A' v' B' A v B); intro j.
    repeat (autodimp j hyp;
            try (complete (introv e; eqconstr e; sp));
            try (complete (apply type_sys_props_sym; sp))).
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
    intros.
    apply type_sys_props_sym.
    apply type_sys_props_eqb_comm; sp.
    apply tet with (t2 := a'); sp.
    apply tet with (t2 := a); sp.
    repnd.

    dands; apply CL_isect; unfold per_isect; exists eqa eqb; sp; allrw.

    split; intro pp; sp.

    assert (eqa1 a a') as e' by (rw <- i0; auto).
    generalize (pp a a' e'); intro k.
    generalize (i1 a a' e' e); intro l.
    rw <- l; sp.

    assert (eqa a a') as e' by (rw i0; auto).
    generalize (pp a a' e'); intro k.
    generalize (i1 a a' e e'); intro l.
    rw l; sp.

    split; intro pp; sp.

    assert (eqa0 a a') as e' by (rw <- j0; auto).
    generalize (pp a a' e'); intro k.
    generalize (j1 a a' e e'); intro l.
    rw l; sp.

    assert (eqa a a') as e' by (rw j0; auto).
    generalize (pp a a' e'); intro k.
    generalize (j1 a a' e' e); intro l.
    rw <- l; sp.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj11eqsynthconj5 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus lv0 lv1)).
Admitted.
QuickChick conj11eqsynthconj5.


Require Export ComputableCategory SigTCategory.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section ComputableCategory.
  Variable I : Type.
  Context `(Index2Cat : forall i : I, @SpecializedCategory (@Index2Object i)).

  Local Coercion Index2Cat : I >-> SpecializedCategory.

  Let eq_dec_on_cat `(C : @SpecializedCategory objC) := forall x y : objC, {x = y} + {x <> y}.

  Definition ComputableCategoryDec := @SpecializedCategory_sigT_obj _ (@ComputableCategory _ _ Index2Cat) (fun C => eq_dec_on_cat C).
End ComputableCategory.


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

(***
Modulus : 2^384 - 317
Base: 21 + 1/3
***)

Definition curve : CurveParameters :=
  {|
    sz := 18%nat;
    base := 21 + 1/3;
    bitwidth := 32;
    s := 2^384;
    c := [(1, 317)];
    carry_chains := Some [seq 0 (pred 18); [0; 1]]%nat;

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

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

    mul_code := None;

    square_code := None;

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

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


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

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

Module Export S := PackageSynthesis P.


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

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

Module Export S := PackageSynthesis P.


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

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

Module Export S := PackageSynthesis P.


From Coq Require Import Arith ZArith.
From mathcomp Require Import ssreflect ssrbool ssrnat seq eqtype div.
From Common Require Import Tactics Arch Types SsrOrdered Bits Lists FSets Bools Nats ZAriths Var Store.
From mQhasm Require Import zDSL bvDSL.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Notation wordsize := AMD64.wordsize.

Opaque wordsize.

(** Convert instructions and programs. *)

Definition bv2z_atomic (a : atomic) : zDSL.exp :=
  match a with
  | bvVar v => zDSL.zVar v
  | bvConst c => zConst (toPosZ c)
  end.

Definition bv2z_instr (i : instr) : seq zDSL.instr :=
  match i with
  | bvAssign v a => [:: zAssign v (bv2z_atomic a)]
(*  | bvNeg v a => [:: zAssign v (zUnop zNeg (bv2z_atomic a))] *)
  | bvAdd v a1 a2 => [:: zAssign v (zadd (bv2z_atomic a1) (bv2z_atomic a2))]
  | bvAddC c v a1 a2 =>
    [:: zSplit c v (zadd (bv2z_atomic a1) (bv2z_atomic a2)) wordsize]
  | bvAdc v a1 a2 y =>
    [:: zAssign v (zadd (zadd (bv2z_atomic a1) (bv2z_atomic a2)) (zVar y))]
  | bvAdcC c v a1 a2 y =>
    [:: zSplit c v (zadd (zadd (bv2z_atomic a1) (bv2z_atomic a2)) (zVar y)) wordsize]
  | bvSub v a1 a2 => [:: zAssign v (zsub (bv2z_atomic a1) (bv2z_atomic a2))]
  | bvSubC c v a1 a2 =>
    [:: zSplit c v
        (zsub (bv2z_atomic a1) (bv2z_atomic a2)) wordsize;
       zAssign c (zneg (zVar c))]
  | bvSbb v a1 a2 y =>
    [:: zAssign v (zsub (zsub (bv2z_atomic a1) (bv2z_atomic a2)) (zVar y))]
  | bvSbbC c v a1 a2 y =>
    [:: zSplit c v
        (zsub (zsub (bv2z_atomic a1) (bv2z_atomic a2)) (zVar y)) wordsize;
       zAssign c (zneg (zVar c))]
  | bvMul v a1 a2 => [:: zAssign v (zmul (bv2z_atomic a1) (bv2z_atomic a2))]
  | bvMulf vh vl a1 a2 =>
    [:: zSplit vh vl (zmul (bv2z_atomic a1) (bv2z_atomic a2)) wordsize]
  | bvShl v a n => [:: zAssign v (zmul2p (bv2z_atomic a) (toNat n))]
  | bvSplit vh vl a n => [:: zSplit vh vl (bv2z_atomic a) (toNat n)]
  | bvConcatShl vh vl a1 a2 n =>
    [:: zSplit vh vl
        (zadd (zmul2p (bv2z_atomic a1) wordsize) (bv2z_atomic a2))
        (wordsize - (toNat n))]
  end.

Fixpoint bv2z_program (p : program) : zDSL.program :=
  match p with
  | [::] => [::]
  | hd::tl => (bv2z_instr hd) ++ (bv2z_program tl)
  end.

Definition addB_safe w (bv1 bv2 : BITS w) : bool :=
  ~~ carry_addB bv1 bv2.

Definition adcB_safe w (bv1 bv2 c : BITS w) : bool :=
  ~~ carry_addB bv1 bv2 && ~~ carry_addB (addB bv1 bv2) c.

Definition subB_safe w (bv1 bv2 : BITS w) : bool :=
  ~~ carry_subB bv1 bv2.

Definition sbbB_safe w (bv1 bv2 c : BITS w) : bool :=
  ~~ carry_subB bv1 bv2 && ~~ carry_subB (subB bv1 bv2) c.

Definition mulB_safe w (bv1 bv2 : BITS w) : bool :=
  high w (fullmulB bv1 bv2) == fromNat 0.

Definition shlBn_safe w (bv : BITS w) n : bool :=
  ltB bv (shlBn (@fromNat w 1) (w - n)).

Definition concatshl_safe w (bv : BITS w) n : bool :=
  (n <= w) && ltB bv (shlBn (@fromNat w 1) (w - n)).

Definition bv2z_instr_safe_at (i : instr) (s : bv64DSL.State.t) : bool :=
  match i with
  | bvAssign _ _ => true
(*  | bvNeg _ _ => true *)
  | bvAdd _ a1 a2 => addB_safe (eval_atomic a1 s) (eval_atomic a2 s)
  | bvAddC _ _ _ _ => true
  | bvAdc _ a1 a2 c => adcB_safe (eval_atomic a1 s) (eval_atomic a2 s)
                                 (bv64DSL.State.acc c s)
  | bvAdcC _ _ _ _ _ => true
  | bvSub _ a1 a2 => subB_safe (eval_atomic a1 s) (eval_atomic a2 s)
  | bvSubC _ _ _ _ => true
  | bvSbb _ a1 a2 y => sbbB_safe (eval_atomic a1 s) (eval_atomic a2 s)
                                 (bv64DSL.State.acc y s)
  | bvSbbC _ _ _ _ _ => true
  | bvMul _ a1 a2 => mulB_safe (eval_atomic a1 s) (eval_atomic a2 s)
  | bvMulf _ _ _ _ => true
  | bvShl _ a n => shlBn_safe (eval_atomic a s) (toNat n)
  | bvSplit _ _ _ _ => true
  | bvConcatShl _ _ a1 a2 n => concatshl_safe (eval_atomic a1 s) (toNat n)
  end.

Fixpoint bv2z_program_safe_at p s : bool :=
  match p with
  | [::] => true
  | hd::tl => bv2z_instr_safe_at hd s && bv2z_program_safe_at tl (eval_instr s hd)
  end.

Definition bv2z_program_safe p : Prop :=
  forall s, bv2z_program_safe_at p s.

(** State equivalence. *)

Definition bvz_eq (sb : State.t) (sz : zDSL.State.t) : Prop :=
  forall x, toPosZ (State.acc x sb) = zDSL.State.acc x sz.

Lemma bvz_eq_upd v bv zv sb sz :
  bvz_eq sb sz ->
  toPosZ bv = zv ->
  bvz_eq (State.upd v bv sb) (zDSL.State.upd v zv sz).
Proof.
  move=> Heq Hbv x.
  case Hxv: (x == v).
  - rewrite (State.acc_upd_eq _ _ Hxv) (zDSL.State.acc_upd_eq _ _ Hxv).
    exact: Hbv.
  - move/idP/negP: Hxv => Hxv.
    rewrite (State.acc_upd_neq _ _ Hxv) (zDSL.State.acc_upd_neq _ _ Hxv).
    exact: Heq.
Qed.

Lemma bvz_eq_upd2 vh vl bvh bvl zvh zvl sb sz :
  bvz_eq sb sz ->
  toPosZ bvh = zvh ->
  toPosZ bvl = zvl ->
  bvz_eq (State.upd2 vh bvh vl bvl sb) (zDSL.State.upd2 vh zvh vl zvl sz).
Proof.
  move=> Heq Hbvh Hbvl x.
  case Hxvl: (x == vl).
  - rewrite (State.acc_upd_eq _ _ Hxvl) (zDSL.State.acc_upd_eq _ _ Hxvl).
    exact: Hbvl.
  - move/idP/negP: Hxvl => Hxvl.
    rewrite (State.acc_upd_neq _ _ Hxvl) (zDSL.State.acc_upd_neq _ _ Hxvl).
    case Hxvh: (x == vh).
    + rewrite (State.acc_upd_eq _ _ Hxvh) (zDSL.State.acc_upd_eq _ _ Hxvh).
      exact: Hbvh.
    + move/idP/negP: Hxvh => Hxvh.
      rewrite (State.acc_upd_neq _ _ Hxvh) (zDSL.State.acc_upd_neq _ _ Hxvh).
      exact: Heq.
Qed.

Lemma bvz_eq_upd2_aux c v bvc bvv zvc zvv zvt sb sz :
  bvz_eq sb sz ->
  toPosZ bvc = zvc ->
  toPosZ bvv = zvv ->
  bvz_eq (State.upd2 v bvv c bvc sb)
         (zDSL.State.upd c
                         zvc
                         (zDSL.State.upd2 v zvv c zvt sz)).
Proof.
  move=> Heq Hc Hv x.
  case Hxc: (x == c).
  - rewrite (zDSL.State.acc_upd_eq _ _ Hxc) (State.acc_upd2_eq2 _ _ _ _ Hxc).
    exact: Hc.
  - move/idP/negP: Hxc => Hxc. rewrite (zDSL.State.acc_upd_neq _ _ Hxc).
    case Hxv: (x == v).
    + rewrite (State.acc_upd2_eq1 _ _ _ Hxv Hxc).
      rewrite (zDSL.State.acc_upd2_eq1 _ _ _ Hxv Hxc). exact: Hv.
    + move/idP/negP: Hxv => Hxv.
      rewrite (State.acc_upd2_neq _ _ _ Hxv Hxc).
      rewrite (zDSL.State.acc_upd2_neq _ _ _ Hxv Hxc).
      exact: (Heq x).
Qed.

(** Properties of program conversion. *)

Lemma bvz_eq_eval_atomic a sb sz :
  bvz_eq sb sz ->
  toPosZ (eval_atomic a sb) = (zDSL.eval_exp (bv2z_atomic a) sz).
Proof.
  move=> Heq; case: a => /=.
  - move=> x.
    exact: Heq.
  - reflexivity.
Qed.

Lemma bvz_eq_eval_instr i sb sz :
  bvz_eq sb sz ->
  bv2z_instr_safe_at i sb ->
  bvz_eq (eval_instr sb i) (zDSL.eval_program sz (bv2z_instr i)).
Proof.
  move=> Heq; case: i => /=.
  - (* bvAssign *)
    move=> v a _ x. apply: (bvz_eq_upd _ Heq). exact: bvz_eq_eval_atomic.
  - (* bvAdd *)
    move=> v a1 a2 Hsafe. apply: (bvz_eq_upd _ Heq).
    rewrite -(bvz_eq_eval_atomic a1 Heq) -(bvz_eq_eval_atomic a2 Heq).
    exact: toPosZ_addB_bounded.
  - (* bvAddC *)
    move=> vh vl a1 a2 _ x.
    rewrite -(bvz_eq_eval_atomic a1 Heq) -(bvz_eq_eval_atomic a2 Heq).
    sethave tmp
            (Z.div_eucl (toPosZ (eval_atomic a1 sb) + toPosZ (eval_atomic a2 sb))
                 (2 ^ Z.of_nat wordsize)).
    destruct tmp as [q r] => Hqr.
    apply: (bvz_eq_upd2 _ _ Heq).
    + exact: (toPosZ_addB_zeroExtend_low Hqr).
    + exact: (toPosZ_addB_zeroExtend_high Hqr).
  - (* bvAdc *)
    move=> v a1 a2 c Hsafe. apply: (bvz_eq_upd _ Heq).
    rewrite -(bvz_eq_eval_atomic a1 Heq) -(bvz_eq_eval_atomic a2 Heq) -(Heq c).
    move: Hsafe => /andP [Hsafe1 Hsafe2].
    exact: toPosZ_addB3_bounded.
  - (* bvAdcC *)
    move=> c v a1 a2 a _.
    rewrite -(bvz_eq_eval_atomic a1 Heq) -(bvz_eq_eval_atomic a2 Heq) -(Heq a).
    sethave tmp
            (Z.div_eucl
               (toPosZ (eval_atomic a1 sb) + toPosZ (eval_atomic a2 sb) +
                toPosZ (State.acc a sb)) (2 ^ Z.of_nat wordsize)).
    destruct tmp as [q r] => Hqr.
    apply: (bvz_eq_upd2 _ _ Heq).
    + exact: (toPosZ_addB3_zeroExtend_low Hqr).
    + exact: (toPosZ_addB3_zeroExtend_high Hqr).
  - (* bvSub *)
    move=> v a1 a2 Hsafe.
    apply: (bvz_eq_upd _ Heq).
    rewrite -(bvz_eq_eval_atomic a1 Heq) -(bvz_eq_eval_atomic a2 Heq).
    exact: toPosZ_subB_bounded.
  - (* bvSubC *)
    move=> c v a1 a2 _.
    rewrite -(bvz_eq_eval_atomic a1 Heq) -(bvz_eq_eval_atomic a2 Heq).
    sethave temp (Z.div_eucl
                    (toPosZ (eval_atomic a1 sb) - toPosZ (eval_atomic a2 sb))
                    (2 ^ Z.of_nat wordsize)).
    destruct temp as [q r] => Hqr.
    apply: (bvz_eq_upd2_aux _ _ _ Heq).
    + rewrite (zDSL.State.acc_upd2_eq2 _ _ _ _ (eqxx c)).
      exact: (toPosZ_subB_zeroExtend_high Hqr).
    + exact: (toPosZ_subB_zeroExtend_low Hqr).
  - (* bvSbb *)
    move=> v a1 a2 y Hsafe. apply: (bvz_eq_upd _ Heq).
    rewrite -(bvz_eq_eval_atomic a1 Heq) -(bvz_eq_eval_atomic a2 Heq)
            -(Heq y).
    move: Hsafe => /andP [Hsafe1 Hsafe2].
    exact: toPosZ_subB3_bounded.
  - (* bvSbbC *)
    move=> c v a1 a2 y _.
    rewrite -(bvz_eq_eval_atomic a1 Heq) -(bvz_eq_eval_atomic a2 Heq)
            -(Heq y).
    sethave temp (Z.div_eucl
                    (toPosZ (eval_atomic a1 sb) - toPosZ (eval_atomic a2 sb) -
                     toPosZ (State.acc y sb)) (2 ^ Z.of_nat wordsize)).
    destruct temp as [q r] => Hqr.
    apply: (bvz_eq_upd2_aux _ _ _ Heq).
    + rewrite (zDSL.State.acc_upd2_eq2 _ _ _ _ (eqxx c)).
      exact: (toPosZ_subB3_zeroExtend_high Hqr).
    + exact: (toPosZ_subB3_zeroExtend_low Hqr).
  - (* bvMul *)
    move=> v a1 a2 Hsafe x. apply: (bvz_eq_upd _ Heq).
    rewrite -(bvz_eq_eval_atomic a1 Heq) -(bvz_eq_eval_atomic a2 Heq).
    apply: toPosZ_mulB_bounded. rewrite -fromNat0. apply/eqP.
    exact: Hsafe.
  - (* bvMulf *)
    move=> vh vl a1 a2 _ x.
    rewrite -(bvz_eq_eval_atomic a1 Heq) -(bvz_eq_eval_atomic a2 Heq).
    sethave tmp
            (Z.div_eucl (toPosZ (eval_atomic a1 sb) * toPosZ (eval_atomic a2 sb))
                        (2 ^ Z.of_nat wordsize)).
    destruct tmp as [q r] => Hqr. apply: (bvz_eq_upd2 _ _ Heq).
    + exact: (toPosZ_fullmulB_low Hqr).
    + exact: (toPosZ_fullmulB_high Hqr).
  - (* bvShl *)
    move=> v a n Hsafe. apply: (bvz_eq_upd _ Heq).
    rewrite -(bvz_eq_eval_atomic a Heq). exact: toPosZ_shlBn_bounded.
  - (* bvSplit *)
    move=> vh vl a n _ x. rewrite -(bvz_eq_eval_atomic a Heq).
    sethave tmp (Z.div_eucl (toPosZ (eval_atomic a sb)) (2 ^ Z.of_nat (toNat n))).
    destruct tmp as [q r] => Hqr. apply: (bvz_eq_upd2 _ _ Heq).
    + exact: (toPosZ_shrBn_low Hqr).
    + exact: (toPosZ_shrBn_high Hqr).
  - (* bvConcatShl *)
    move=> vh vl a1 a2 n Hsafe x.
    rewrite -(bvz_eq_eval_atomic a1 Heq) -(bvz_eq_eval_atomic a2 Heq).
    sethave tmp
            (Z.div_eucl
               (toPosZ (eval_atomic a1 sb) *
                2 ^ Z.of_nat wordsize +
                    toPosZ (eval_atomic a2 sb))
               (2 ^ Z.of_nat (wordsize - (toNat n)))).
    destruct tmp as [q r] => Hqr. move/andP: Hsafe => [Hle Hsafe].
    apply: (bvz_eq_upd2 _ _ Heq).
    + exact: (toPosZ_catB_shlBn_low_shrBn Hle Hsafe Hqr).
    + exact: (toPosZ_catB_shlBn_high Hle Hsafe Hqr).
Qed.

Lemma bvz_eq_eval_program p sb sz :
  bvz_eq sb sz ->
  bv2z_program_safe_at p sb ->
  bvz_eq (eval_program sb p) (zDSL.eval_program sz (bv2z_program p)).
Proof.
  elim: p sb sz => /=.
  - move=> sb sz Heq _; exact: Heq.
  - move=> hd tl IH sb sz Heq /andP [Hhd Htl].
    rewrite zDSL.eval_program_concat_step.
    apply: (IH _ _ _ Htl).
    exact: bvz_eq_eval_instr.
Qed.

(** Convert specifications. *)

Definition bv2z_unop (op : unop) : zDSL.unop :=
  match op with
  | bvNegOp => zDSL.zNeg
  end.

Definition bv2z_binop (op : binop) : zDSL.binop :=
  match op with
  | bvAddOp => zDSL.zAdd
  | bvSubOp => zDSL.zSub
  | bvMulOp => zDSL.zMul
  end.

Fixpoint bv2z_eexp (e : eexp) : zDSL.exp :=
  match e with
  | bveVar v => zVar v
  | bveConst c => zConst c
  | bveUnop op e => zUnop (bv2z_unop op) (bv2z_eexp e)
  | bveBinop op e1 e2 => zBinop (bv2z_binop op) (bv2z_eexp e1) (bv2z_eexp e2)
  end.

Fixpoint bv2z_ebexp e : zDSL.bexp :=
  match e with
  | bveTrue => zDSL.zTrue
  | bveEq e1 e2 => zDSL.zEq (bv2z_eexp e1) (bv2z_eexp e2)
  | bveEqMod e1 e2 p => zDSL.zEqMod (bv2z_eexp e1) (bv2z_eexp e2) (bv2z_eexp p)
  | bveAnd e1 e2 => zDSL.zAnd (bv2z_ebexp e1) (bv2z_ebexp e2)
  end.

Definition bv2z_spec_rng s : rspec :=
  {| rspre := rng_bexp (spre s);
     rsprog := sprog s;
     rspost := rng_bexp (spost s) |}.

Definition bv2z_spec_eqn s : zDSL.spec :=
  {| zDSL.spre := bv2z_ebexp (eqn_bexp (spre s));
     zDSL.sprog := bv2z_program (sprog s);
     zDSL.spost := bv2z_ebexp (eqn_bexp (spost s)) |}.

Definition bv2z_spec_safe sp :=
  forall s, eval_rbexp (rng_bexp (spre sp)) s ->
            bv2z_program_safe_at (sprog sp) s.

(** Properties of specification conversion. *)

Lemma bvz_eq_eval_eunop op (v : Z) :
  eval_eunop op v =
  zDSL.eval_unop (bv2z_unop op) v.
Proof.
  case: op; reflexivity.
Qed.

Lemma bvz_eq_eval_ebinop op (v1 v2 : Z) :
  eval_ebinop op v1 v2 =
  zDSL.eval_binop (bv2z_binop op) v1 v2.
Proof.
  case: op; reflexivity.
Qed.

Lemma bvz_eq_eval_eexp (e : eexp) bs zs :
  bvz_eq bs zs ->
  eval_eexp e bs = zDSL.eval_exp (bv2z_eexp e) zs.
Proof.
  elim: e => /=.
  - move=> a Heq. exact: Heq.
  - reflexivity.
  - move=> op e IH Heq. rewrite -(IH Heq). exact: bvz_eq_eval_eunop.
  - move=> op e1 IH1 e2 IH2 Heq. rewrite -(IH1 Heq) -(IH2 Heq).
    exact: bvz_eq_eval_ebinop.
Qed.

Lemma bvz_eq_eval_ebexp1 e bs zs :
  bvz_eq bs zs ->
  eval_ebexp e bs ->
  zDSL.eval_bexp (bv2z_ebexp e) zs.
Proof.
  elim: e => /=.
  - done.
  - move=> e1 e2 Heq Heval.
    rewrite -(bvz_eq_eval_eexp e1 Heq) -(bvz_eq_eval_eexp e2 Heq). exact: Heval.
  - move=> e1 e2 p Heq Heval.
    rewrite -(bvz_eq_eval_eexp e1 Heq) -(bvz_eq_eval_eexp e2 Heq)
            -(bvz_eq_eval_eexp p Heq). exact: Heval.
  - move=> e1 IH1 e2 IH2 Heq [Heval1 Heval2].
    split; [exact: (IH1 Heq Heval1) | exact: (IH2 Heq Heval2)].
Qed.

Lemma bvz_eq_eval_ebexp2 e bs zs :
  bvz_eq bs zs ->
  zDSL.eval_bexp (bv2z_ebexp e) zs ->
  eval_ebexp e bs.
Proof.
  elim: e => /=.
  - done.
  - move=> e1 e2 Heq Heval.
    rewrite (bvz_eq_eval_eexp e1 Heq) (bvz_eq_eval_eexp e2 Heq). exact: Heval.
  - move=> e1 e2 p Heq Heval.
    rewrite (bvz_eq_eval_eexp e1 Heq) (bvz_eq_eval_eexp e2 Heq)
            (bvz_eq_eval_eexp p Heq). exact: Heval.
  - move=> e1 IH1 e2 IH2 Heq [Heval1 Heval2].
    split; [exact: (IH1 Heq Heval1) | exact: (IH2 Heq Heval2)].
Qed.

Lemma eval_bexp_combine e bs zs :
  bvz_eq bs zs ->
  eval_rbexp (rng_bexp e) bs ->
  zDSL.eval_bexp (bv2z_ebexp (eqn_bexp e)) zs ->
  eval_bexp e bs.
Proof.
  move=> Heq Her Hee. split.
  - exact: (bvz_eq_eval_ebexp2 Heq Hee).
  - exact: Her.
Qed.

(** Convert bvState to zState. *)

Definition bv2z_state bs : zDSL.State.t :=
  fun v => toPosZ (State.acc v bs).

Lemma bv2z_state_eq bs :
  bvz_eq bs (bv2z_state bs).
Proof.
  move=> x; reflexivity.
Qed.

(** Well-formedness *)

Lemma lvs_bv2z_instr i :
  VS.Equal (zDSL.lvs_program (bv2z_instr i)) (lvs_instr i).
Proof.
  case: i => /=; intros;
  (let rec tac :=
       match goal with
       | |- context f [VS.union _ VS.empty] =>
         rewrite zDSL.VSLemmas.union_emptyr; tac
       | |- VS.Equal ?s ?s => reflexivity
       | |- VS.Equal
              (VS.union
                 (VS.add ?v1 (VS.singleton ?v2))
                 (VS.singleton ?v1))
              (VS.add ?v1 (VS.singleton ?v2)) =>
         rewrite VSLemmas.union_add1 zDSL.VSLemmas.OP.P.union_sym
                 -VSLemmas.union_add1
                 (VSLemmas.add_equal
                    (VSLemmas.mem_singleton2 (eqxx v1)))
                 -VSLemmas.OP.P.add_union_singleton;
         reflexivity
       | |- _ => idtac
       end in
   tac).
Qed.

Lemma bv2z_atomic_vars a :
  VS.Equal (zDSL.vars_exp (bv2z_atomic a)) (vars_atomic a).
Proof.
  case: a => /=; reflexivity.
Qed.

Lemma bv2z_eexp_vars (e : eexp) : VS.Equal (zDSL.vars_exp (bv2z_eexp e)) (vars_eexp e).
Proof.
  elim: e => /=.
  - reflexivity.
  - reflexivity.
  - move=> _ e IH. exact: IH.
  - move=> _ e1 IH1 e2 IH2. rewrite IH1 IH2. reflexivity.
Qed.

(* Convert (vars_* (bv2z_* _)) to (vars_* _). *)
Ltac vars_to_bvdsl :=
  match goal with
  | |- context f [VS.union _ VS.empty] =>
    rewrite VSLemmas.union_emptyr; vars_to_bvdsl
  | |- context f [vars_exp (bv2z_atomic _)] =>
    rewrite !bv2z_atomic_vars; vars_to_bvdsl
  | |- context f [vars_exp (bv2z_eexp _)] =>
    rewrite !bv2z_eexp_vars; vars_to_bvdsl
  | |- _ => idtac
  end.

Lemma vars_bv2z_instr i :
  VS.Equal (zDSL.vars_program (bv2z_instr i)) (vars_instr i).
Proof.
  case: i => /=; intros; vars_to_bvdsl; VSLemmas.dp_Equal.
Qed.

Lemma vars_bv2z_program p :
  VS.Equal (zDSL.vars_program (bv2z_program p)) (vars_program p).
Proof.
  elim: p => /=.
  - reflexivity.
  - move=> hd tl IH. rewrite (zDSL.vars_program_concat) IH vars_bv2z_instr.
    reflexivity.
Qed.

Lemma eqn_bexp_vars_subset f :
  VS.subset (zDSL.vars_bexp (bv2z_ebexp (eqn_bexp f))) (vars_bexp f).
Proof.
  case: f => e r /=. apply: VSLemmas.subset_union1 => /= {r}.
  elim: e => /=; intros; vars_to_bvdsl; VSLemmas.dp_subset.
Qed.

Lemma bv2z_instr_well_formed vs i :
  well_formed_instr vs i ->
  zDSL.well_formed_program vs (bv2z_instr i).
Proof.
  case: i => /=; intros;
  (let rec tac :=
       match goal with
       | |- is_true true => done
       | |- is_true (_ && _) => apply/andP; split; tac
       | H : is_true (_ && _) |- _ =>
         let H1 := fresh in
         let H2 := fresh in
         move/andP: H => [H1 H2]; tac
       | H : is_true (?x != ?y) |- is_true (?x != ?y) => exact: H
       | |- is_true (VS.subset _ _) => vars_to_bvdsl; VSLemmas.dp_subset
       | |- _ => idtac
       end in
   tac).
Qed.

Lemma bv2z_program_well_formed vs p :
  well_formed_program vs p ->
  zDSL.well_formed_program vs (bv2z_program p).
Proof.
  elim: p vs => /=.
  - done.
  - move=> hd tl IH vs /andP [Hwellhd Hwelltl].
    rewrite zDSL.well_formed_program_concat.
    rewrite (bv2z_instr_well_formed Hwellhd) /=.
    apply: (@zDSL.well_formed_program_replace (VS.union vs (lvs_instr hd))).
  - exact: (IH _ Hwelltl).
  - rewrite lvs_bv2z_instr. reflexivity.
Qed.

Lemma bv2z_spec_rng_well_formed vs sp :
  well_formed_spec vs sp ->
  well_formed_spec vs (bv2z_spec_rng sp).
Proof.
  destruct sp as [f p g]. move=> /andP /= [/andP [Hf Hp] Hg].
  rewrite /well_formed_spec /=. rewrite /vars_bexp /=.
  rewrite 2!VSLemmas.union_emptyl Hp.
  rewrite (VSLemmas.subset_trans (vars_rbexp_subset f) Hf).
  rewrite (VSLemmas.subset_trans (vars_rbexp_subset g) Hg).
  done.
Qed.

Lemma bv2z_spec_eqn_well_formed vs sp :
  well_formed_spec vs sp ->
  zDSL.well_formed_spec vs (bv2z_spec_eqn sp).
Proof.
  destruct sp as [f p g].
  move=> /andP /= [/andP [Hf Hp] Hg].
  apply/andP => /=; split; first (apply/andP; split).
  - apply: (@VSLemmas.subset_trans _ (vars_bexp f) _ _ Hf).
    exact: eqn_bexp_vars_subset.
  - exact: bv2z_program_well_formed.
  - apply: (VSLemmas.subset_trans (eqn_bexp_vars_subset g)).
    rewrite vars_bv2z_program. assumption.
Qed.

(** Soundness *)

Theorem bv2z_spec_sound sp :
  bv2z_spec_safe sp ->
  valid_rspec (bv2z_spec_rng sp) ->
  zDSL.valid_spec (bv2z_spec_eqn sp) ->
  valid_spec sp.
Proof.
  destruct sp as [f p g] => /=.
  move=> Hsafe Hrng Heqn bs1 bs2 /= Hbf Hbp.
  move: (Hrng bs1 bs2 (eval_bexp_rng Hbf) Hbp) => {Hrng} /= Hrng.
  set zs1 := bv2z_state bs1.
  set zs2 := zDSL.eval_program zs1 (bv2z_program p).
  move: (Heqn zs1 zs2
              (bvz_eq_eval_ebexp1 (bv2z_state_eq bs1) (eval_bexp_eqn Hbf))
              (Logic.eq_refl zs2)) => {Heqn} /= Heqn.
  apply: (@eval_bexp_combine g bs2 zs2 _ Hrng Heqn). rewrite -Hbp.
  exact: (bvz_eq_eval_program (bv2z_state_eq bs1) (Hsafe _ (eval_bexp_rng Hbf))).
Qed.


(** PRF Example

  Inspired by "State Separation for Code-Based Game-Playing Proofs"
  by Brzuska et al.

  Appendix A.

  "Given a pseudorandom function (PRF) we construct a symmetric encryption
  scheme that is indistinguishable under chosen plaintext attacks (IND-CPA)."

*)

From Relational Require Import OrderEnrichedCategory GenericRulesSimple.

Set Warnings "-notation-overridden,-ambiguous-paths".
From mathcomp Require Import all_ssreflect all_algebra reals distr realsum
  ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice seq.
Set Warnings "notation-overridden,ambiguous-paths".

From Mon Require Import SPropBase.
From Crypt Require Import Axioms ChoiceAsOrd SubDistr Couplings
  UniformDistrLemmas FreeProbProg Theta_dens RulesStateProb
  pkg_core_definition chUniverse pkg_composition pkg_rhl Package Prelude.

From Coq Require Import Utf8.
From extructures Require Import ord fset fmap.

Import SPropNotations.

Import PackageNotation.

From Equations Require Import Equations.
Require Equations.Prop.DepElim.

Set Equations With UIP.

Set Bullet Behavior "Strict Subproofs".
Set Default Goal Selector "!".
Set Primitive Projections.

Import Num.Def.
Import Num.Theory.
Import Order.POrderTheory.

Section PRF_example.

  Context (n : nat).

  Definition Words_N : nat := 2^n.
  Definition Words_N_pos : Positive Words_N := _.
  Definition Words : chUniverse := chFin (mkpos Words_N).
  Definition Key_N : nat := 2^n.
  Definition Key_N_pos : Positive Key_N := _.
  Definition Key : chUniverse := chFin (mkpos Key_N).

  (* TW: Is this normal that this definition is so big? *)
  #[program] Definition plus : Words → Key → Words :=
    λ w k,
      @Ordinal _ (BinNat.N.to_nat (BinNat.N.lxor (BinNat.N.of_nat (nat_of_ord w)) (BinNat.N.of_nat (nat_of_ord k)))) _.
  Next Obligation.
    destruct w as [w Hw], k as [k Hk].
    destruct w as [|Pw], k as [|Pk].
    1:{ simpl. assumption. }
    1:{
      simpl.
      rewrite Pnat.SuccNat2Pos.id_succ.
      assumption.
    }
    1:{
      simpl.
      rewrite Pnat.SuccNat2Pos.id_succ.
      assumption.
    }
    remember (succn Pw) as w.
    remember (succn Pk) as k.
    assert (
      ∀ m,
        (2 ^ m)%nat = BinNat.N.to_nat (BinNat.N.pow (BinNums.Npos (BinNums.xO 1%AC)) (BinNat.N.of_nat m))
    ) as H.
    { induction m.
      - reflexivity.
      - rewrite expnSr.
        rewrite Nnat.Nat2N.inj_succ.
        rewrite BinNat.N.pow_succ_r'.
        rewrite Nnat.N2Nat.inj_mul.
        rewrite PeanoNat.Nat.mul_comm.
        apply f_equal2.
        + apply IHm.
        + reflexivity.
    }
    unfold Words_N, Key_N in *.
    move: (BinNat.N.log2_lxor (BinNat.N.of_nat w) (BinNat.N.of_nat k)) => Hbound.
    assert (
      BinNat.N.lt (BinNat.N.log2 (BinNat.N.of_nat w)) (BinNat.N.of_nat n)
    ) as H1.
    { rewrite -BinNat.N.log2_lt_pow2.
      2:{
        rewrite Heqw. rewrite Nnat.Nat2N.inj_succ.
        apply BinNat.N.lt_0_succ.
      }
      unfold BinNat.N.lt.
      rewrite Nnat.N2Nat.inj_compare.
      rewrite PeanoNat.Nat.compare_lt_iff.
      rewrite Nnat.Nat2N.id.
      rewrite -H.
      apply /ltP.
      apply Hw.
    }
    assert (
      BinNat.N.lt (BinNat.N.log2 (BinNat.N.of_nat k)) (BinNat.N.of_nat n)
    ) as H2.
    { rewrite -BinNat.N.log2_lt_pow2.
      2:{
        rewrite Heqk. rewrite Nnat.Nat2N.inj_succ.
        apply BinNat.N.lt_0_succ.
      }
      unfold BinNat.N.lt.
      rewrite Nnat.N2Nat.inj_compare.
      rewrite PeanoNat.Nat.compare_lt_iff.
      rewrite Nnat.Nat2N.id.
      rewrite -H.
      apply /ltP.
      apply Hk.
    }
    move: (BinNat.N.max_lub_lt _ _ _ H1 H2) => Hm.
    destruct ((BinNat.N.lxor (BinNat.N.of_nat w) (BinNat.N.of_nat k)) == BinNat.N0) eqn:H0.
    1:{
      simpl. move: H0. move /eqP => H0. rewrite H0. simpl.
      rewrite expn_gt0. apply /orP. left. auto.
    }
    move: (BinNat.N.le_lt_trans _ _ _ Hbound Hm).
    rewrite -BinNat.N.log2_lt_pow2.
    2:{
      apply BinNat.N.neq_0_lt_0.
      move: H0. move /eqP. auto.
    }
    unfold BinNat.N.lt.
    rewrite Nnat.N2Nat.inj_compare.
    rewrite PeanoNat.Nat.compare_lt_iff.
    move => Hlt.
    apply /ltP.
    simpl in *.
    rewrite H.
    assumption.
  Qed.

  Notation "m ⊕ k" := (plus m k) (at level 70).

  Lemma plus_involutive :
    ∀ m k, (m ⊕ k) ⊕ k = m.
  Proof.
    intros m k.
    move: ord_inj => Hordinj.
    unfold injective in Hordinj.
    apply Hordinj.
    destruct m. cbn.
    rewrite Nnat.N2Nat.id.
    rewrite BinNat.N.lxor_assoc.
    rewrite BinNat.N.lxor_nilpotent.
    rewrite BinNat.N.lxor_0_r.
    rewrite Nnat.Nat2N.id.
    reflexivity.
  Qed.

  #[local] Open Scope package_scope.

  Definition key_location : Location := ('option Key ; 0).
  Definition plain_location : Location := (Words ; 1).
  Definition cipher_location : Location := (Words ; 2).
  Definition i0 : nat := 3.
  Definition i1 : nat := 4.
  Definition i2 : nat := 5.
  Definition salt_location : Location := ('nat ; 6).
  Definition table_location : Location :=
    (chMap 'nat ('fin (2^n)%N) ; 7).

  Definition rel_loc : {fset Location} :=
    fset [:: key_location ; table_location ].

  Context (PRF : Words → Key → Key).

  Notation " 'word " := ('fin (2^n)%N) (in custom pack_type at level 2).
  Notation " 'key " := ('fin (2^n)%N) (in custom pack_type at level 2).
  Definition i_key : nat := 2^n.
  Definition i_words : nat := 2^n.

  Definition enc {L : { fset Location }} (m : Words) (k : Key) :
    code L [interface] ('fin (2^n) × 'fin (2^n)) :=
      {code
        r ← sample uniform i_words ;;
        let pad := PRF r k in
        let c := m ⊕ pad in
        ret (r, c)
      }.

  Definition kgen : code fset0 [interface] 'fin (2^n) :=
    {code
      k ← sample uniform i_key ;;
      ret k
    }.

  Definition dec (c : Words) (k : Key) :
    code
      (fset [:: key_location; table_location])
      [interface]
      ('fin (2^n) × 'fin (2^n)) :=
    enc k c.

  Definition EVAL_location_tt := (fset [:: key_location]).
  Definition EVAL_location_ff := (fset [:: table_location]).

  Definition EVAL_pkg_tt :
    package EVAL_location_tt [interface]
      [interface val #[i0] : 'word → 'key ] :=
    [package
      def #[i0] (r : 'word) : 'key
      {
        k_init ← get key_location ;;
        match k_init with
        | None =>
            k ← sample uniform i_key ;;
            put key_location := Some k ;;
            ret (PRF r k)
        | Some k_val =>
            ret (PRF r k_val)
        end
      }
    ].

  Definition EVAL_pkg_ff :
    package EVAL_location_ff [interface]
      [interface val #[i0] : 'word → 'key ] :=
    [package
      def #[i0] (r : 'word) : 'key
      {
        T ← get table_location ;;
        match getm T r with
        | None =>
            T_key ← sample uniform i_key ;;
            put table_location := (setm T r T_key) ;;
            ret T_key
        | Some T_key => ret T_key
        end
      }
    ].

  (* TODO Not the most satisfying, it would be nice to think of something else
    This might come with more automation to deal with the GamePair type.
  *)
  Definition EVAL : loc_GamePair [interface val #[i0] : 'word → 'key ] :=
    λ b, if b then {locpackage EVAL_pkg_tt } else {locpackage EVAL_pkg_ff }.

  Definition MOD_CPA_location : {fset Location} := fset0.

  Definition MOD_CPA_tt_pkg :
    package MOD_CPA_location [interface val #[i0] : 'word → 'key ]
      [interface val #[i1] : 'word → 'word × 'word ] :=
    [package
      def #[i1] (m : 'word) : 'word × 'word
      {
        #import {sig #[i0] : 'word → 'key } as eval ;;
        r ← sample uniform i_words ;;
        pad ← eval r ;;
        let c := m ⊕ pad in
        ret (r, c)
      }
    ].

  Definition MOD_CPA_ff_pkg :
    package MOD_CPA_location [interface val #[i0] : 'word → 'key]
      [interface val #[i1] : 'word → 'word × 'word ]:=
    [package
      def #[i1] (m : 'word) : 'word × 'word
      {
        #import {sig #[i0] : 'word → 'key } as eval ;;
        r ← sample uniform i_words ;;
        m' ← sample uniform i_words ;;
        pad ← eval r ;;
        let c := (m' ⊕ pad) in
        ret (r, c)
      }
    ].

  Definition IND_CPA_location : {fset Location} := fset [:: key_location].

  Definition IND_CPA_pkg_tt :
    package IND_CPA_location
      [interface]
      [interface val #[i1] : 'word → 'word × 'word ] :=
    [package
      def #[i1] (m : 'word) : 'word × 'word
      {
        k ← get key_location ;;
        match k with
        | None =>
          k_val ← sample uniform i_key ;;
          put key_location := Some k_val ;;
          enc m k_val
        | Some k_val =>
          enc m k_val
        end
      }
   ].

  Definition IND_CPA_pkg_ff :
    package IND_CPA_location
      [interface]
      [interface val #[i1] : 'word → 'word × 'word ] :=
    [package
      def #[i1] (m : 'word) : 'word × 'word
      {
        k ← get key_location ;;
        match k with
        | None =>
          k_val ← sample uniform i_key ;;
          put key_location := Some k_val ;;
          m' ← sample uniform i_words ;;
          enc m' k_val
        | Some k_val =>
          m' ← sample uniform i_words ;;
          enc m' k_val
        end
      }
    ].

  Definition IND_CPA :
    loc_GamePair [interface val #[i1] : 'word → 'word × 'word ] :=
    λ b,
      if b then {locpackage IND_CPA_pkg_tt } else {locpackage IND_CPA_pkg_ff }.

  Local Open Scope ring_scope.

  Definition prf_epsilon A := Advantage EVAL A.

  Definition statistical_gap :=
    AdvantageE (MOD_CPA_ff_pkg ∘ EVAL false) (MOD_CPA_tt_pkg ∘ EVAL false).

  Lemma IND_CPA_equiv_false :
    IND_CPA false ≈₀ MOD_CPA_ff_pkg ∘ (EVAL true).
  Proof.
    (* We go to the relation logic using equality as invariant. *)
    eapply eq_rel_perf_ind_eq.
    simplify_eq_rel m.
    simplify_linking.
    (* We now conduct the proof in relational logic. *)
    ssprove_swap_rhs 1%N.
    ssprove_swap_rhs 0%N.
    ssprove_sync_eq. cbn. intros [k|].
    - cbn. ssprove_swap_rhs 0%N.
      eapply rpost_weaken_rule.
      1: eapply rreflexivity_rule.
      cbn. intros [? ?] [? ?] e. inversion e. intuition auto.
    - cbn.
      ssprove_swap_rhs 0%N.
      ssprove_swap_rhs 1%N.
      ssprove_swap_rhs 0%N.
      ssprove_swap_rhs 2%N.
      ssprove_swap_rhs 1%N.
      eapply rpost_weaken_rule. 1: eapply rreflexivity_rule.
      cbn. intros [? ?] [? ?] e. inversion e. intuition auto.
  Qed.

  Lemma IND_CPA_equiv_true :
    MOD_CPA_tt_pkg ∘ (EVAL true) ≈₀ IND_CPA true.
  Proof.
    (* We go to the relation logic using equality as invariant. *)
    eapply eq_rel_perf_ind_eq.
    simplify_eq_rel m.
    simplify_linking.
    (* We now conduct the proof in relational logic. *)
    ssprove_swap_lhs 0%N.
    ssprove_sync_eq. cbn. intros [k|].
    - cbn. eapply rpost_weaken_rule. 1: eapply rreflexivity_rule.
      cbn. intros [? ?] [? ?] e. inversion e. intuition auto.
    - cbn.
      ssprove_swap_rhs 1%N.
      ssprove_swap_rhs 0%N.
      eapply rpost_weaken_rule. 1: eapply rreflexivity_rule.
      cbn. intros [? ?] [? ?] e. inversion e. intuition auto.
  Qed.

  (** Security of PRF

    The bound is given by using the triangle inequality several times,
    using the following chain:
    IND_CPA false ≈ MOD_CPA_ff_pkg ∘ EVAL true
                  ≈ MOD_CPA_ff_pkg ∘ EVAL false
                  ≈ MOD_CPA_tt_pkg ∘ EVAL false
                  ≈ MOD_CPA_tt_pkg ∘ EVAL true
                  ≈ IND_CPA true

  *)
  Theorem security_based_on_prf :
    ∀ LA A,
      ValidPackage LA
        [interface val #[i1] : 'word → 'word × 'word ] A_export A →
      fdisjoint LA (IND_CPA false).(locs) →
      fdisjoint LA (IND_CPA true).(locs) →
      Advantage IND_CPA A <=
      prf_epsilon (A ∘ MOD_CPA_ff_pkg) +
      statistical_gap A +
      prf_epsilon (A ∘ MOD_CPA_tt_pkg).
  Proof.
    intros LA A vA hd₀ hd₁. unfold prf_epsilon, statistical_gap.
    rewrite !Advantage_E.
    ssprove triangle (IND_CPA false) [::
      MOD_CPA_ff_pkg ∘ EVAL true ;
      MOD_CPA_ff_pkg ∘ EVAL false ;
      MOD_CPA_tt_pkg ∘ EVAL false ;
      MOD_CPA_tt_pkg ∘ EVAL true
    ] (IND_CPA true) A
    as ineq.
    eapply le_trans. 1: exact ineq.
    clear ineq.
    erewrite IND_CPA_equiv_false. all: eauto.
    2:{ simpl. unfold MOD_CPA_location. rewrite fset0U. auto. }
    erewrite IND_CPA_equiv_true. all: eauto.
    2:{ simpl. unfold MOD_CPA_location. rewrite fset0U. auto. }
    rewrite GRing.add0r GRing.addr0.
    rewrite !Advantage_link. rewrite Advantage_sym. auto.
  Qed.

End PRF_example.