(* Deprecated file with minimal-working precision with BigZ/Int63 floats,
   which is kept for informative purpose only, because the corresponding
   timings are not intended to be optimal in any sense. *)

Require Import Reals Interval.Tactic.
Local Open Scope R_scope.

(* From bench-ineqs/benchmarks/coq/multi_poly.v *)

Optimize Heap.
Lemma RD : forall x1 x2 x3 : R, -5 <= x1 <= 5 -> -5 <= x2 <= 5 -> -5 <= x3 <= 5 -> -367126907/10000000 <= -x1 + 2*x2 - x3 - 835634534/1000000000 * x2 * (1 + x2).
idtac "RD".
Time intros x1 x2 x3 H1 H2 H3; interval with (i_native_compute, i_prec 32, i_bisect x2).
Qed.

Optimize Heap.
Lemma adaptiveLV : forall x1 x2 x3 x4 : R,
    -2 <= x1 <= 2 -> -2 <= x2 <= 2 -> -2 <= x3 <= 2 -> -2 <= x4 <= 2 ->
    -20801/1000 <= x1*x2^2 + x1 * x3^2 + x1*x4^2 - 11/10 * x1 + 1.
idtac "adaptiveLV".
Time intros x1 x2 x3 x4 H1 H2 H3 H4; interval with (i_native_compute, i_prec 13, i_bisect x1, i_autodiff x1).
Qed.

Optimize Heap.
Lemma butcher : forall x1 x2 x3 x4 x5 x6 : R,
    -1 <= x1 <= 0 -> -1/10 <= x2 <= 9/10 -> -1/10 <= x3 <= 1/2 ->
    -1 <= x4 <= -1/10 -> -1/10 <= x5 <= -5/100 -> -1/10 <= x6 <= -3/100 ->
    -144/100 <= x6 * x2^2 + x5 * x3 ^2 - x1 * x4^2 + x4^3 + x4^2 - x1/3 + 4*x4/3.
idtac "butcher".
Time intros x1 x2 x3 x4 x5 x6 H1 H2 H3 H4 H5 H6;
  interval with (i_native_compute, i_prec 12, i_bisect x4, i_autodiff x4).
Qed.

Optimize Heap.
Lemma magnetism : forall x1 x2 x3 x4 x5 x6 x7 : R,
    -1 <= x1 <= 1 -> -1 <= x2 <= 1 -> -1 <= x3 <= 1 -> -1 <= x4 <= 1 ->
    -1 <= x5 <= 1 -> -1 <= x6 <= 1 -> -1 <= x7 <= 1 ->
    -25001/100000 <= x1^2 + 2*x2^2 + 2*x3^2 + 2*x4^2 + 2*x5^2 + 2*x6^2 + 2*x7^2 - x1.
idtac "magnetism".
Time intros x1 x2 x3 x4 x5 x6 x7 H1 H2 H3 H4 H5 H6 H7;
interval with (i_native_compute, i_prec 1, i_bisect x1, i_autodiff x1).
Qed.

(* From bench-ineqs/benchmarks/coq/univ_metitarski.v *)

Notation eps := (1/1024)%R (only parsing).
Notation meps := (-1/1024)%R (only parsing).

(** MetiTarski_JAR2010 paper *)

(* plot(2 * abs(x) / (2 + x) - abs(log(1+x)), [-1, 10]); *)
Optimize Heap.
Lemma MT1 :
  forall x : R, -1 + eps <= x <= 10 ->
           2 * Rabs x / (2 + x) <= Rabs (ln (1 + x)) + eps.
Proof.
idtac "MT1".
Time intros x H; apply Rminus_le; interval with (i_native_compute, i_prec 17, i_bisect x).
Qed.

(* plot(abs(log(1+x)) + log(1 - abs(x)), [-1, 1]); *)
Optimize Heap.
Lemma MT2 :
  forall x : R, -1 + eps <= x <= 1 - eps ->
           Rabs (ln (1 + x)) <= - ln (1 - Rabs x) + eps.
Proof.
idtac "MT2".
Time intros x H; apply Rminus_le; interval with (i_native_compute, i_prec 16, i_bisect x, i_taylor x).
Qed.

(* plot(abs(x)/(1 + abs(x)) - abs(log(1+x)), [-1, 1]); *)
Optimize Heap.
Lemma MT3 :
  forall x : R, -1 + eps <= x <= 1 ->
           Rabs x / (1 + Rabs x) <= Rabs (ln (1 + x)) + eps.
Proof.
idtac "MT3".
Time intros x H; apply Rminus_le; interval with (i_native_compute, i_prec 12, i_bisect x).
Qed.

(* plot(abs(log(1+x)) - abs(x)*(1+abs(x))/abs(1+x), [-1, 10]); *)
Optimize Heap.
Lemma MT4 :
  forall x : R, -1 + eps <= x <= 1 ->
                Rabs (ln (1 + x)) <= (Rabs x) * (1 + Rabs x) / Rabs (1 + x) + eps.
Proof.
idtac "MT4".
Time intros x H; apply Rminus_le; interval with (i_native_compute, i_prec 12, i_bisect x).
Qed.

(* plot(abs(x) / 4 - abs(exp(x) - 1), [-1, 1]); *)
Optimize Heap.
Lemma MT5 :
  forall x : R, (-1 <= x <= meps \/ eps <= x <= 1) ->
           Rabs x / 4 < Rabs (exp x - 1).
Proof.
idtac "MT5".
Time intros x [H|H]; apply Rminus_lt; interval with (i_native_compute, i_prec 11, i_bisect x).
Qed.

(* plot(abs(exp(x) - 1) - 7 * abs(x)/4, [0, 1]); *)
Optimize Heap.
Lemma MT6 :
  forall x : R, (-1 <= x <= meps \/ eps <= x <= 1) ->
                Rabs (exp x - 1) < 7 * (Rabs x) / 4.
Proof.
idtac "MT6".
Time intros x [H|H]; apply Rminus_lt; interval with (i_native_compute, i_prec 11, i_bisect x).
Qed.

(* plot(abs(exp(x) - 1) - (exp(abs(x)) - 1), [-10, 10]); *)
Optimize Heap.
Lemma MT7 : forall x : R, -10 <= x <= meps -> Rabs (exp x - 1) <= exp (Rabs x) - 1.
Proof.
idtac "MT7".
Time intros x H; apply Rminus_le; interval with (i_native_compute, i_prec 19, i_bisect x, i_autodiff x).
Qed.

(* plot(abs(exp(x)-(1+x)) - abs(exp(abs(x))-(1+abs(x))), [-10, 10]); *)
Optimize Heap.
Lemma MT8 :
  forall x : R, -10 <= x <= meps ->
  Rabs (exp x - (1 + x)) <= Rabs (exp (Rabs x) - (1 + Rabs x)).
Proof.
idtac "MT8".
Time intros x H; apply Rminus_le; interval with (i_native_compute, i_prec 35, i_bisect x, i_taylor x).
Qed.

(* plot(abs(exp(x)-(1+x/2)^2) - abs(exp(abs(x))-(1+abs(x)/2)^2), [-10, 10]); *)
Optimize Heap.
Lemma MT9 :
  forall x : R, -10 <= x <= meps ->
  Rabs (exp x - (1 + x / 2) ^ 2) <= Rabs (exp (Rabs x) - (1 + (Rabs x) / 2) ^ 2).
Proof.
idtac "MT9".
Time intros x H; apply Rminus_le; interval with (i_native_compute, i_prec 35, i_bisect x, i_taylor x).
Qed.

(* plot(2*x/(2+x) - log(1+x), [0, 10]); *)
Optimize Heap.
Lemma MT10 :
  forall x : R, 0 <= x <= 10 -> 2 * x / (2 + x) <= ln (1 + x) + eps.
Proof.
idtac "MT10".
Time intros x H; apply Rminus_le; interval with (i_native_compute, i_prec 15, i_bisect x).
Qed.

(* plot(x/sqrt(1+x) - log(1+x), [-1/3,0]); *)
Optimize Heap.
Lemma MT11 :
  forall x : R, -1/3 <= x <= 0 -> x / sqrt (1 + x) <= ln (1 + x) + eps.
Proof.
idtac "MT11".
Time intros x H; apply Rminus_le; interval with (i_native_compute, i_prec 13, i_bisect x).
Qed.

(* plot(log((1+x)/x)-(12*x^2 + 12*x + 1)/(12*x^3 + 18*x^2 + 6*x), [1/3, 10]); *)
Optimize Heap.
Lemma MT12 :
  forall x : R, 1/3 <= x <= 10 ->
  ln ((1 + x) / x) <= (12*x^2 + 12*x + 1) / (12*x^3 + 18*x^2 + 6*x).
Proof.
idtac "MT12".
Time intros x H; apply Rminus_le; interval with (i_native_compute, i_prec 28, i_bisect x, i_taylor x).
Qed.

(* plot(log((1+x)/x)-1/sqrt(x^2 + x), [1/3, 10]); *)
Optimize Heap.
Lemma MT13 :
  forall x : R, 1/3 <= x <= 10 ->
  ln ((1 + x) / x) <= 1 / sqrt (x ^ 2 + x).
Proof.
idtac "MT13".
Time intros x H; apply Rminus_le; interval with (i_native_compute, i_prec 23, i_bisect x).
Qed.

(* plot(exp(x - x^2) - 1 - x, [0, 1]); *)
Optimize Heap.
Lemma MT14 : forall x : R, 0 <= x <= 1 -> exp (x - x^2) <= 1 + x + eps.
Proof.
idtac "MT14".
Time intros x H; apply Rminus_le; interval with (i_native_compute, i_prec 11, i_bisect x, i_autodiff x).
Qed.

(* plot(exp(-x/(1-x))-(1-x), [-10,1/2]); *)
Optimize Heap.
Lemma MT15 : forall x : R, -10 <= x <= 1/2 -> exp(-x/(1 - x)) <= 1 - x + eps.
Proof.
idtac "MT15".
Time intros x H; apply Rminus_le; interval with (i_native_compute, i_prec 11, i_bisect x, i_autodiff x).
Qed.

(* plot(abs(sin(x)) - 6/5 * abs(x), [-1, 1]); *)
Optimize Heap.
Lemma MT16 : forall x : R, -1 <= x <= 1 -> Rabs (sin x) <= 6/5 * Rabs x + eps.
Proof.
idtac "MT16".
Time intros x H; apply Rminus_le; interval with (i_native_compute, i_prec 1, i_bisect x, i_autodiff x).
Qed.

(* plot(1 - 2 * x - cos(pi * x), [0, 1/2]); *)
Optimize Heap.
Lemma MT17 : forall x : R, eps <= x <= 100/201 -> cos (PI * x) > 1 - 2 * x.
Proof.
idtac "MT17".
Time intros x H; apply Rminus_lt; interval with (i_native_compute, i_prec 11, i_bisect x).
Qed.

(* plot(cos(x) - 1 + x^2/2, [-10,10]); *)
Optimize Heap.
Lemma MT18 : forall x : R, -10 <= x <= 10 -> cos x - 1 + x^2 / 2 + eps >= 0.
Proof.
idtac "MT18".
Time intros x H; apply Rminus_ge; interval with (i_native_compute, i_prec 12, i_bisect x).
Qed.

(* plot(8 * sqrt(3) * x / (3 * sqrt(3) + sqrt(75 + 80 * x^2)) - atan(x), [0, 10]); *)
Optimize Heap.
Lemma MT19 :
  forall x : R, 0 <= x <= 10 ->
  eps + atan x >= 8 * sqrt 3 * x / (3 * sqrt 3 + sqrt (75 + 80 * x^2)).
Proof.
idtac "MT19".
Time intros x H; apply Rminus_ge; interval with (i_native_compute, i_prec 12, i_bisect x, i_autodiff x).
Qed.

(* plot((x + 1/x) * arctan(x) - 1, [0,5]); *)
Optimize Heap.
Lemma MT20 : forall x : R, eps <= x <= 10 -> (x + 1 / x) * atan x > 1.
Proof.
idtac "MT20".
Time intros x H; interval with (i_native_compute, i_prec 25, i_bisect x, i_autodiff x, i_depth 25).
Qed.

(* TODO: try to remove Rminus_alt etc. *)
(* plot(3 * x / (1 + 2 * sqrt(1 + x^2)) - atan(x), [0, 10]); *)
Optimize Heap.
Lemma MT21 :
  forall x : R, 0 <= x <= 10 -> eps + atan x > 3 * x / (1 + 2 * sqrt (1 + x^2)).
Proof.
idtac "MT21".
Time intros x H; apply Rminus_lt; interval with (i_native_compute, i_prec 11, i_bisect x, i_autodiff x).
Qed.

(* plot(cos(x)-sin(x)/x, [0, pi]); *)
(* TODO Plot *)
Optimize Heap.
Lemma MT22 : forall x : R, eps <= x <= PI -> cos x <= sin x / x.
Proof.
idtac "MT22".
Time intros x H; apply Rminus_le; interval with (i_native_compute, i_prec 27, i_bisect x, i_taylor x, i_depth 16).
Qed.

(* plot(cos(x) - (sin(x)/x)^2, [0, pi/2]); *)
Optimize Heap.
Lemma MT23 : forall x : R, eps <= x <= PI / 2 -> cos x < (sin x / x) ^ 2.
Proof.
idtac "MT23".
Time intros x H; apply Rminus_lt; interval with (i_native_compute, i_prec 29, i_bisect x, i_taylor x).
Qed.

(* plot(sin(x)/3 + sin(3*x)/6, [pi/3-1, 2*pi/3+1]); *)
Optimize Heap.
Lemma MT24 :
  forall x : R, PI/3 <= x <= 2*PI/3 - eps -> (sin x) / 3 + (sin (3*x)) / 6 > 0.
Proof.
idtac "MT24".
Time intros x H; interval with (i_native_compute, i_prec 3, i_bisect x).
Qed.

(* plot(12-14.2*exp(-.318*x)+(3.25*cos(1.16*x)-.155*sin(1.16*x))*exp(-1.34*x),[-1/2,2]); *)
Optimize Heap.
Lemma MT25 :
  forall x : R, 0 <= x <= 2 ->
  12 - 142/10 * exp(-318/1000*x) + (325/100*cos(116/100*x) - 155/1000*sin(116/100*x)) * exp(-134/100*x) > 0.
Proof.
idtac "MT25".
Time intros x H; interval with (i_native_compute, i_prec 6, i_bisect x).
Qed.

(* From bench-ineqs/benchmarks/coq/univ_transcend.v *)

(** http://lipforge.ens-lyon.fr/www/crlibm/ *)
(** http://lipforge.ens-lyon.fr/frs/download.php/162/crlibm-1.0beta4.tar.gz *)

Section CRlibm_exp.
Let p_2_55 : R := 36028797018963968.
Let c3 := 6004799504235417 / p_2_55.
Let c4 := 1501199876148417 / p_2_55.
Notation p x := (x + 1/2 * x^2 + c3 * x^3 + c4 * x^4)%R (only parsing).
Notation eps' := (1/1048576)%R (only parsing).
Notation meps' := (-1/1048576)%R (only parsing).

(* TODO: try to remove the unfold here *)
Optimize Heap.
Lemma crlibm_exp :
  forall x : R,
  (-355/4194304 <= x <= meps') \/ (eps' <= x <= 355/4194304) ->
  Rabs ((p x - exp x + 1) / (exp x - 1)) <= 1/4611686018427387904.
idtac "crlibm_exp".
Time intros x [H|H]; unfold c3, c4, p_2_55;
  interval with (i_native_compute, i_bisect x, i_taylor x, i_prec 90). (* NOT i_prec 53 *)
Qed.
End CRlibm_exp.

(** Melquiond_IJCAR2008 paper *)

(* plot(abs(sqrt(x) - (((((122 / 7397 * x + (-1733) / 13547) * x
  + 529 / 1274) * x + (-767) / 999) * x
  + 407 / 334) * x + 227 / 925)) - 5/65536, [1/2, 2]); *)
Optimize Heap.
Lemma remez_sqrt :
  forall x, 1/2 <= x <= 2 ->
  Rabs (sqrt x - (((((122 / 7397 * x + (-1733) / 13547) * x
                   + 529 / 1274) * x + (-767) / 999) * x
                   + 407 / 334) * x + 227 / 925))
    <= 5/65536.
idtac "remez_sqrt".
Time intros x H;
  (* interval with (i_native_compute, i_prec 53, i_bisect x, i_autodiff x). OK but slower *)
  interval with (i_native_compute, i_prec 22, i_bisect x, i_taylor x).
Qed.

(** Daumas_Lester_Munoz_TC2009 paper with a tighter bound *)

(* plot(abs(atan(x)-(x-(11184811/33554432)*x^3-(13421773/67108864)*x^5))-5/2^28, [-1/30, 1/30]); *)
Optimize Heap.
Lemma abs_err_atan :
  forall x : R, -1/30 <= x <= 1/30 ->
  Rabs (atan x - (x - (11184811/33554432) * x^3 - (13421773/67108864) * x^5))
  <= 5/268435456.
idtac "abs_err_atan".
Time intros x H;
  interval with (i_native_compute, i_prec 26, i_bisect x, i_autodiff x).
Qed.

(** Daumas_Melquiond_Munoz_ARITH2005 paper *)

Section Rel_err_geodesic.
Let a := 6378137.
Let f := 1000000000/298257223563.
Let umf2 := (1 - f) ^ 2.
Let max := 715/512.
Notation rp phi := (a / sqrt (1 + umf2 * (tan phi) ^ 2)) (only parsing).
Notation arp phi :=
  (let: x := max ^ 2 - phi ^ 2 in
  4439091/4 + x * (9023647/4 + x * (
    13868737/64 + x * (13233647/2048 + x * (
      -1898597/16384 + x * (-6661427/131072)))))) (only parsing).

Optimize Heap.
Lemma rel_err_geodesic :
  forall phi, 0 <= phi <= max ->
  Rabs ((rp phi - arp phi) / rp phi) <= 23/16777216.
Proof.
idtac "rel_err_geodesic".
Time unfold (*rp, arp,*) a, umf2, f, max; intros phi Hphi;
  interval with (i_native_compute, i_prec 24, i_bisect phi, i_autodiff phi).
Qed.

Optimize Heap.
Lemma rel_err_geodesic' :
  forall phi, 0 <= phi <= max ->
  Rabs ((rp phi - arp phi) / rp phi) <= 23/16777216.
Proof.
idtac "rel_err_geodesic'".
Time unfold (*rp, arp,*) a, umf2, f, max; intros phi Hphi;
  interval with (i_native_compute, i_prec 25, i_bisect phi, i_taylor phi).
Qed.
End Rel_err_geodesic.

(* From bench-ineqs/benchmarks/coq/univ_metitarski_Rlt.v *)

(** MetiTarski_JAR2010 paper *)

(* TODO Maybe merge lemmas if there's too many lines in the array *)
(* plot(abs(sin(x)) - 6/5 * abs(x), [-1, 1]); *)
Optimize Heap.
Lemma MT16__1 : forall x : R, (-1 <= x <= 0) -> (sin x) > - (6/5 * - x + eps).
Proof.
idtac "MT16__1".
Time intros x H; apply Rminus_lt; interval with (i_native_compute, i_prec 1, i_bisect x, i_autodiff x).
Qed.

Optimize Heap.
Lemma MT16__2 : forall x : R, (-1 <= x <= 0) -> (sin x) < 6/5 * - x + eps.
Proof.
idtac "MT16__2".
Time intros x H; apply Rminus_lt; interval with (i_native_compute, i_prec 1, i_bisect x).
Qed.

Optimize Heap.
Lemma MT16__3 : forall x : R, (0 <= x <= 1) -> (sin x) > - (6/5 * x + eps).
Proof.
idtac "MT16__3".
Time intros x H; apply Rminus_lt; interval with (i_native_compute, i_prec 1, i_bisect x).
Qed.

Optimize Heap.
Lemma MT16__4 : forall x : R, (0 <= x <= 1) -> (sin x) < 6/5 * x + eps.
Proof.
idtac "MT16__4".
Time intros x H; apply Rminus_lt; interval with (i_native_compute, i_prec 1, i_bisect x, i_autodiff x).
Qed.

(* plot(1 - 2 * x - cos(pi * x), [0, 1/2]); *)
Optimize Heap.
Lemma MT17' : forall x : R, eps <= x <= 100/201 -> cos (PI * x) > 1 - 2 * x.
Proof.
idtac "MT17'".
Time intros x H; apply Rminus_lt; interval with (i_native_compute, i_prec 11, i_bisect x).
Qed.

(* plot(cos(x) - 1 + x^2/2, [-10,10]); *)
Optimize Heap.
Lemma MT18' : forall x : R, -10 <= x <= 10 -> cos x - 1 + x^2 / 2 + eps > 0.
Proof.
idtac "MT18'".
Time intros x H; interval with (i_native_compute, i_prec 12, i_bisect x).
Qed.

(* plot(8 * sqrt(3) * x / (3 * sqrt(3) + sqrt(75 + 80 * x^2)) - atan(x), [0, 10]); *)
Optimize Heap.
Lemma MT19' :
  forall x : R, 0 <= x <= 10 ->
  eps + atan x > 8 * sqrt 3 * x / (3 * sqrt 3 + sqrt (75 + 80 * x^2)).
Proof.
idtac "MT19'".
Time intros x H; apply Rminus_lt; interval with (i_native_compute, i_prec 12, i_bisect x, i_autodiff x).
Qed.

(* plot((x + 1/x) * arctan(x) - 1, [0,5]); *)
Optimize Heap.
Lemma MT20' : forall x : R, eps <= x <= 10 -> (x + 1 / x) * atan x > 1.
Proof.
idtac "MT20'".
Time intros x H; interval with (i_native_compute, i_prec 25, i_bisect x, i_autodiff x, i_depth 25).
Qed.

(* plot(3 * x / (1 + 2 * sqrt(1 + x^2)) - atan(x), [0, 10]); *)
Optimize Heap.
Lemma MT21' :
  forall x : R, 0 <= x <= 10 -> eps + atan x > 3 * x / (1 + 2 * sqrt (1 + x^2)).
Proof.
idtac "MT21'".
Time intros x H; apply Rminus_lt; interval with (i_native_compute, i_prec 11, i_bisect x, i_autodiff x).
Qed.

(* OK en flottants primitifs *)
(* plot(cos(x)-sin(x)/x, [0, pi]); *)
Optimize Heap.
Lemma MT22' : forall x : R, eps <= x <= PI -> cos x < sin x / x.
idtac "MT22'".
Time intros x H; apply Rminus_lt; interval with (i_native_compute, i_prec 27, i_bisect x, i_taylor x, i_depth 16).
Qed.

(* plot(cos(x) - (sin(x)/x)^2, [0, pi/2]); *)
Optimize Heap.
Lemma MT23' : forall x : R, eps <= x <= PI / 2 ->
  cos x < (sin x / x) * (sin x / x).
Proof.
idtac "MT23'".
Time intros x H; apply Rminus_lt; interval with (i_native_compute, i_prec 29, i_bisect x, i_taylor x).
Qed.

(* plot(sin(x)/3 + sin(3*x)/6, [pi/3-1, 2*pi/3+1]); *)
Optimize Heap.
Lemma MT24' :
  forall x : R, PI/3 <= x <= 2*PI/3 - eps -> (sin x) / 3 + (sin (3*x)) / 6 > 0.
Proof.
idtac "MT24'".
Time intros x H; interval with (i_native_compute, i_prec 3, i_bisect x).
Qed.

(* From bench-ineqs/benchmarks/coq/fpminmax.v *)

(** Facilities to parse negative powers and pre-compute powers of 2 *)
Notation "a * b ^(- n )" := (a / b ^ n)%R
  (at level 40, b at next level, only parsing) : R_scope.

(** FP minimax polynomials for cos(3/2 * cos(x)), generated using Sollya *)
Notation f x := (cos (3/2 * cos x)) (only parsing).
Notation D x := (-1 <= x <= 1/2) (only parsing).

(** Degree-2 *)
Notation p2 x := (5009597 * 2^(-26) + x * (-3452481 * 2^(-36) + x * (10948483 * 2^(-24)))) (only parsing).
Notation eps2 := (57 * 2^(-10)) (only parsing).

Optimize Heap.
Lemma cos_cos_d2 :
  forall x, D x -> Rabs ((p2 x - f x) / f x) <= eps2.
Proof.
idtac "cos_cos_d2".
Time intros x H; interval with (i_native_compute, i_prec 17, i_bisect x, i_taylor x).
Qed.

(** Degree-3 *)
Notation p3 x := (9578005 * 2^(-27) + x * (-8411879 * 2^(-29) + x * (6079307 * 2^(-23) + x * (14167647 * 2^(-27))))) (only parsing).
Notation eps3 := (51 * 2^(-11)) (only parsing).

Optimize Heap.
Lemma cos_cos_d3 :
  forall x, D x -> Rabs ((p3 x - f x) / f x) <= eps3.
Proof.
idtac "cos_cos_d3".
Time intros x H; interval with (i_native_compute, i_prec 20, i_bisect x, i_taylor x).
Qed.

(** Degree-4 *)
Notation p4 x := (2366509 * 2^(-25) + x * (10537089 * 2^(-34) + x * (1593929 * 2^(-21) + x * (-3609977 * 2^(-29) + x * (-609875 * 2^(-22)))))) (only parsing).
Notation eps4 := (51 * 2^(-14)) (only parsing).

Optimize Heap.
Lemma cos_cos_d4 :
  forall x, D x -> Rabs ((p4 x - f x) / f x) <= eps4.
Proof.
idtac "cos_cos_d4".
Time intros x H; interval with (i_native_compute, i_prec 22, i_bisect x, i_taylor x).
Qed.

(** Degree-5 *)
Notation p5 x := (9491875 * 2^(-27) + x * (1388077 * 2^(-31) + x * (12575645 * 2^(-24) + x * (-3473267 * 2^(-28) + x * (-13477879 * 2^(-27) + x * (11406127 * 2^(-28))))))) (only parsing).
Notation eps5 := (3 * 2^(-12)) (only parsing).

Optimize Heap.
Lemma cos_cos_d5 :
  forall x, D x -> Rabs ((p5 x - f x) / f x) <= eps5.
Proof.
idtac "cos_cos_d5".
Time intros x H; interval with (i_native_compute, i_prec 24, i_bisect x, i_taylor x).
Qed.

(** Degree-6 *)
Notation p6 x := (9492545 * 2^(-27) + x * (12716483 * 2^(-36) + x * (3142515 * 2^(-22) + x * (-8980587 * 2^(-31) + x * (-12736139 * 2^(-27) + x * (8061261 * 2^(-29) + x * (-13450525 * 2^(-29)))))))) (only parsing).
Notation eps6 := (17 * 2^(-16)) (only parsing).

Optimize Heap.
Lemma cos_cos_d6 :
  forall x, D x -> Rabs ((p6 x - f x) / f x) <= eps6.
Proof.
idtac "cos_cos_d6".
Time intros x H; interval with (i_native_compute, i_prec 24, i_bisect x, i_taylor x).
Qed.

(** Degree-7 *)
Notation p7 x := (4747227 * 2^(-26) + x * (5795109 * 2^(-37) + x * (784233 * 2^(-20) + x * (-6099871 * 2^(-32) + x * (-10729417 * 2^(-27) + x * (12242037 * 2^(-30) + x * (-8892053 * 2^(-27) + x * (-14339757 * 2^(-29))))))))) (only parsing).
Notation eps7 := (25 * 2^(-19)) (only parsing).

Optimize Heap.
Lemma cos_cos_d7 :
  forall x, D x -> Rabs ((p7 x - f x) / f x) <= eps7.
Proof.
idtac "cos_cos_d7".
Time intros x H; interval with (i_native_compute, i_prec 27, i_bisect x, i_taylor x).
Qed.

(** Degree-8 *)
Notation p8 x := (9494185 * 2^(-27) + x * (12149587 * 2^(-41) + x * (6275713 * 2^(-23) + x * (-14107149 * 2^(-36) + x * (-2763427 * 2^(-25) + x * (14503039 * 2^(-33) + x * (-530509 * 2^(-23) + x * (-8256955 * 2^(-31) + x * (3638503 * 2^(-28)))))))))) (only parsing).
Notation eps8 := (5 * 2^(-20)) (only parsing).

Optimize Heap.
Lemma cos_cos_d8 :
  forall x, D x -> Rabs ((p8 x - f x) / f x) <= eps8.
Proof.
idtac "cos_cos_d8".
Time intros x H; interval with (i_native_compute, i_prec 30, i_bisect x, i_taylor x).
Qed.

(* From bench-ineqs/benchmarks/coq/fpminmax.v *)

(** Facilities to parse negative powers and pre-compute powers of 2 *)
Notation "a * b ^(- n )" := (a / b ^ n)%R
  (at level 40, b at next level, only parsing) : R_scope.

Optimize Heap.
Lemma cos_cos_d2__1 :
  forall x, D x -> (p2 x - f x) / f x > - eps2.
Proof.
idtac "cos_cos_d2__1".
Time intros x H; interval with (i_native_compute, i_prec 16, i_bisect x, i_taylor x).
Qed.

Optimize Heap.
Lemma cos_cos_d2__2 :
  forall x, D x -> (p2 x - f x) / f x < eps2.
Proof.
idtac "cos_cos_d2__2".
Time intros x H; interval with (i_native_compute, i_prec 17, i_bisect x, i_taylor x).
Qed.

Optimize Heap.
Lemma cos_cos_d3__1 :
  forall x, D x -> (p3 x - f x) / f x > - eps3.
Proof.
idtac "cos_cos_d3__1".
Time intros x H; interval with (i_native_compute, i_prec 18, i_bisect x, i_taylor x).
Qed.

Optimize Heap.
Lemma cos_cos_d3__2 :
  forall x, D x -> (p3 x - f x) / f x < eps3.
Proof.
idtac "cos_cos_d3__2".
Time intros x H; interval with (i_native_compute, i_prec 20, i_bisect x, i_taylor x).
Qed.

Optimize Heap.
Lemma cos_cos_d4__1 :
  forall x, D x -> (p4 x - f x) / f x > - eps4.
Proof.
idtac "cos_cos_d4__1".
Time intros x H; interval with (i_native_compute, i_prec 22, i_bisect x, i_taylor x).
Qed.

Optimize Heap.
Lemma cos_cos_d4__2 :
  forall x, D x -> (p4 x - f x) / f x < eps4.
Proof.
idtac "cos_cos_d4__2".
Time intros x H; interval with (i_native_compute, i_prec 20, i_bisect x, i_taylor x).
Qed.

Optimize Heap.
Lemma cos_cos_d5__1 :
  forall x, D x -> (p5 x - f x) / f x > - eps5.
Proof.
idtac "cos_cos_d5__1".
Time intros x H; interval with (i_native_compute, i_prec 23, i_bisect x, i_taylor x).
Qed.

Optimize Heap.
Lemma cos_cos_d5__2 :
  forall x, D x -> (p5 x - f x) / f x < eps5.
Proof.
idtac "cos_cos_d5__2".
Time intros x H; interval with (i_native_compute, i_prec 24, i_bisect x, i_taylor x).
Qed.

Optimize Heap.
Lemma cos_cos_d6__1 :
  forall x, D x -> (p6 x - f x) / f x > - eps6.
Proof.
idtac "cos_cos_d6__1".
Time intros x H; interval with (i_native_compute, i_prec 23, i_bisect x, i_taylor x).
Qed.

Optimize Heap.
Lemma cos_cos_d6__2 :
  forall x, D x -> (p6 x - f x) / f x < eps6.
Proof.
idtac "cos_cos_d6__2".
Time intros x H; interval with (i_native_compute, i_prec 24, i_bisect x, i_taylor x).
Qed.

Optimize Heap.
Lemma cos_cos_d7__1 :
  forall x, D x -> (p7 x - f x) / f x > - eps7.
Proof.
idtac "cos_cos_d7__1".
Time intros x H; interval with (i_native_compute, i_prec 27, i_bisect x, i_taylor x).
Qed.

Optimize Heap.
Lemma cos_cos_d7__2 :
  forall x, D x -> (p7 x - f x) / f x < eps7.
Proof.
idtac "cos_cos_d7__2".
Time intros x H; interval with (i_native_compute, i_prec 27, i_bisect x, i_taylor x).
Qed.

Optimize Heap.
Lemma cos_cos_d8__1 :
  forall x, D x -> (p8 x - f x) / f x > - eps8.
Proof.
idtac "cos_cos_d8__1".
Time intros x H; interval with (i_native_compute, i_prec 30, i_bisect x, i_taylor x).
Qed.

Optimize Heap.
Lemma cos_cos_d8__2 :
  forall x, D x -> (p8 x - f x) / f x < eps8.
Proof.
idtac "cos_cos_d8__2".
Time intros x H; interval with (i_native_compute, i_prec 30, i_bisect x, i_taylor x).
Qed.

(* From coq-interval/testsuite/bug-20120927.v *)

(* TODO: Remove these lemmas from the "optimal prec" column *)
Optimize Heap.
Lemma bug20120927 :
  forall x, (-1/2 <= x <= 0)%R ->
  True.
Proof.
intros x Hx.
idtac "bug20120927".
Time interval_intro (Rabs x + x)%R upper with (i_native_compute, i_prec 53, i_bisect x, i_autodiff x, i_depth 5).
exact I.
Qed.

(* From coq-interval/testsuite/bug-20140723.v *)

Optimize Heap.
Lemma bug20140723_1 : True.
idtac "bug20140723_1".
Time interval_intro PI lower with (i_native_compute, i_prec 53).
exact I.
Qed.

Optimize Heap.
Lemma bug20140723_2 : True.
idtac "bug20140723_2".
Time interval_intro (PI/2)%R upper with (i_native_compute, i_prec 53).
exact I.
Qed.

(* From coq-interval/testsuite/bug-20140728.v *)

Optimize Heap.
Lemma bug20140728 : forall x : R, exp x >= 0.
idtac "bug20140728".
Time intros; interval with (i_native_compute, i_prec 1).
Qed.

(* OK with emulated floats *)

(* From coq-interval/testsuite/bug-20150924.v *)

Optimize Heap.
Lemma bug20150924 : forall x : R,
  (Rabs (x - x) <= 1/5)%R.
Proof.
intros x.
idtac "bug20150924".
Time interval with (i_native_compute, i_prec 1, i_autodiff x).
Qed.

(* From coq-interval/testsuite/bug-20150925.v *)

Optimize Heap.
Lemma bug20150925 : forall x, (-1 / 3 <= x - x <= 1 / 7)%R.
Proof.
intros x.
idtac "bug20150925".
Time interval with (i_native_compute, i_prec 1, i_autodiff x).
Qed.

(* From coq-interval/testsuite/example_20071016.v *)

Optimize Heap.
Lemma example20071016_1 :
  forall x, -1 <= x <= 1 ->
  sqrt (1 - x) <= 3/2.
Proof.
  intros.
idtac "example20071016_1".
  Time interval with (i_native_compute, i_prec 2).
Qed.

Optimize Heap.
Lemma example20071016_2 :
  forall x, -1 <= x <= 1 ->
  sqrt (1 - x) <= 141422/100000.
Proof.
  intros.
idtac "example20071016_2".
  Time interval with (i_native_compute, i_prec 16).
Qed.

Optimize Heap.
Lemma example20071016_3 :
  forall x, -1 <= x <= 1 ->
  sqrt (1 - x) <= 141422/100000.
Proof.
  intros.
idtac "example20071016_3".
  Time interval_intro (sqrt (1 - x)) upper with (i_native_compute, i_prec 53) as H'.
  apply Rle_trans with (1 := H').
idtac "example20071016_3'".
  Time interval with (i_native_compute, i_prec 16).
Qed.

Optimize Heap.
Lemma example20071016_4 :
  forall x, 3/2 <= x <= 2 ->
  forall y, 1 <= y <= 33/32 ->
  Rabs (sqrt(1 + x/sqrt(x+y)) - 144/1000*x - 118/100) <= 71/32768.
Proof.
  intros.
idtac "example20071016_4".
  Time interval with (i_native_compute, i_prec 19, i_bisect x).
Qed.

Optimize Heap.
Lemma example20071016_5 :
  forall x, 1/2 <= x <= 2 ->
  Rabs (sqrt x - (((((122 / 7397 * x + (-1733) / 13547) * x
                   + 529 / 1274) * x + (-767) / 999) * x
                   + 407 / 334) * x + 227 / 925))
    <= 5/65536.
Proof.
  intros.
idtac "example20071016_5".
  Time interval with (i_native_compute, i_prec 22, i_bisect x, i_taylor x).
Qed.

Optimize Heap.
Lemma example20071016_6 :
  forall x, -1 <= x ->
  x < 1 + powerRZ x 3.
Proof.
  intros.
  apply Rminus_lt.
idtac "example20071016_6".
  Time interval with (i_native_compute, i_prec 1, i_bisect x, i_autodiff x).
Qed.

Require Import Coquelicot.Coquelicot.

Optimize Heap.
Lemma example20071016_7 :
  Rabs (RInt (fun x => atan (sqrt (x*x + 2)) / (sqrt (x*x + 2) * (x*x + 1))) 0 1
        - 5/96*PI*PI) <= 1/1000.
Proof.
idtac "example20071016_7".
(* Time interval with (i_native_compute, i_prec 53, i_integral_prec 9, i_integral_depth 1, i_integral_deg 5). **)
Time integral with (i_native_compute, i_prec 14, i_fuel 2, i_degree 5).
Qed.

Optimize Heap.
Lemma example20071016_8 :
  RInt_gen (fun x => 1 * (powerRZ x 3 * ln x^2))
           (at_right 0) (at_point 1) = 1/32.
Proof.
  refine ((fun H => Rle_antisym _ _ (proj2 H) (proj1 H)) _).
idtac "example20071016_8".
  Time integral with (i_native_compute, i_prec 1).
Qed.

(* TODO/FIXME: Ltac bug?
Optimize Heap.
Lemma example20071016_9 :
  Rabs (RInt_gen (fun t => 1/sqrt t * exp (-(1*t)))
                 (at_point 1) (Rbar_locally p_infty)
        - 2788/10000) <= 1/1000.
Proof.
idtac "example20071016_9".
Time integral with (i_native_compute).
Qed. *)

(* From coq-interval/testsuite/example-20120205.v *)

Optimize Heap.
Lemma example20120205_1 :
  forall x, (1 <= x)%R -> (0 < x)%R.
Proof.
intros.
idtac "example20120205_1".
Time interval with (i_native_compute, i_prec 1).
Qed.

Optimize Heap.
Lemma example20120205_2 : forall x, (1 <= x)%R -> (x <= x * x)%R.
Proof.
intros.
apply Rminus_le.
idtac "example20120205_2".
Time interval with (i_native_compute, i_prec 1, i_bisect x, i_autodiff x).
Qed.

Optimize Heap.
Lemma example20120205_3 : forall x, (2 <= x)%R -> (x < x * x)%R.
Proof.
intros.
apply Rminus_lt.
idtac "example20120205_3".
Time interval with (i_native_compute, i_prec 1, i_bisect x, i_autodiff x).
Qed.

Optimize Heap.
Lemma example20120205_4 : forall x, (-1 <= x)%R -> (x < 1 + powerRZ x 3)%R.
Proof.
intros.
apply Rminus_lt.
idtac "example20120205_4".
Time interval with (i_native_compute, i_prec 1, i_bisect x, i_autodiff x).
Qed.

(* From coq-interval/testsuite/example-20140221.v *)

(* plot(abs((exp(x)-1)-(x+(8388676/2^24)*x^2+(11184876/2^26)*x^3))-((23/27)/(2^33)), [-10831/1000000, 10831/1000000]); *)

(*
Example taken from:
John Harrison, Verifying the Accuracy of Polynomial Approximations in HOL.
In TPHOLs, pages 137-152, 1997.
*)

Optimize Heap.
Lemma example20140221_1 :
  forall x : R,
    (-10831/1000000 <= x /\ x <= 10831/1000000) -> (* TODO Rabs *)
    Rabs ((exp x - 1) - (x + (8388676/2^24) * x^2 + (11184876/2^26) * x^3))
    <= (23/27) / (2^33).
Proof.
intros x H.
idtac "example20140221_1".
Time interval with (i_native_compute, i_prec 43, i_bisect x, i_autodiff x, i_depth 16).
Qed.

Optimize Heap.
Lemma example20140221_2 :
  forall x : R,
    (-10831/1000000 <= x /\ x <= 10831/1000000) ->
    Rabs ((exp x - 1) - (x + (8388676/2^24) * x^2 + (11184876/2^26) * x^3))
    <= (23/27) / (2^33).
Proof.
intros x H.
idtac "example20140221_2".
Time interval with (i_native_compute, i_prec 43, i_bisect x, i_taylor x).
Qed.

(* From coq-interval/testsuite/example-20140610.v *)

(*
Example taken from:
Marc Daumas and Guillaume Melquiond and César Muñoz,
Guaranteed Proofs Using Interval Arithmetic.
In IEEE ARITH 17, pages 188-195, 2005.
*)

Definition a := 6378137.
Definition f' := 1000000000/298257223563.
Definition umf2 := (1 - f')².
Definition max := 715/512.
Definition rp phi := a / sqrt (1 + umf2 * (tan phi)²).
Definition arp phi :=
  let x := max² - phi² in
  4439091/4 + x * (9023647/4 + x * (
    13868737/64 + x * (13233647/2048 + x * (
      -1898597/16384 + x * (-6661427/131072))))).

Optimize Heap.
Lemma example20140610_1 : forall phi, 0 <= phi <= max ->
  Rabs ((rp phi - arp phi) / rp phi) <= 23/16777216.
Proof.
unfold rp, arp, umf2, a, f', max.
intros phi Hphi.
idtac "example20140610_1".
Time interval with (i_native_compute, i_prec 25, i_bisect phi, i_autodiff phi).
Qed.

Optimize Heap.
Lemma example20140610_2 : forall phi, 0 <= phi <= max ->
  Rabs ((rp phi - arp phi) / rp phi) <= 23/16777216.
Proof.
unfold rp, arp, umf2, a, f', max.
intros phi Hphi.
idtac "example20140610_2".
Time interval with (i_native_compute, i_prec 25, i_bisect phi, i_taylor phi).
Qed.

(* From coq-interval/testsuite/example-20150105.v *)

Notation pow2 := (Raux.bpow Zaux.radix2).

(*
Example taken from:
William J. Cody Jr. and William Waite
Software Manual for the Elementary Functions
*)

Optimize Heap.
Lemma example20150105 : forall x : R, Rabs x <= 35/100 ->
  let p := fun t => 1 * pow2 (-2) + t * (1116769 * pow2 (-28)) in
  let q := fun t => 1 * pow2 (-1) + t * (13418331 * pow2 (-28)) in
  let r := 2 * (x * p (x^2) / (q (x^2) - x * p (x^2)) + 1 * pow2 (-1)) in
  Rabs ((r - exp x) / exp x) <= 17 * pow2 (-34).
Proof.
intros x Hx p q r.
unfold r, p, q.
idtac "example20150105".
Time interval with (i_native_compute, i_prec 40, i_bisect x, i_taylor x).
Qed.

(* From coq-interval/testsuite/example-20160218.v *)

Optimize Heap.
Lemma exp_0_3 :
  Rabs (RInt (fun x => exp x) 0 3 - (exp(1) ^ 3 - 1)) <= 1/(1000*1000).
Proof.
idtac "exp_0_3".
Time integral with (i_native_compute, i_prec 28, i_fuel 1).
Qed.

Optimize Heap.
Lemma x_ln1p_0_1 :
  Rabs (RInt (fun x => x * ln(1 + x)) 0 1 - 1/4) <= 1/1000.
Proof.
idtac "x_ln1p_0_1".
Time integral with (i_native_compute, i_prec 12, i_fuel 1).
Qed.

Optimize Heap.
Lemma circle :
  Rabs (RInt (fun x => sqrt(1 - x * x)) 0 1 - PI / 4) <= 1/100.
Proof.
idtac "circle".
Time integral with (i_native_compute, i_prec 17, i_fuel 7, i_degree 1).
Qed.

Optimize Heap.
Lemma exp_cos_0_1 :
  Rabs (RInt (fun x => sin(x) * exp(cos x)) 0 1 - (exp 1 - exp(cos 1))) <= 1/1000.
Proof.
idtac "exp_cos_0_1".
Time integral with (i_native_compute, i_prec 15, i_fuel 1).
Qed.

Optimize Heap.
Lemma arctan_0_1 :
  Rabs (RInt (fun x => 1 / (1 + x*x)) 0 1 - PI / 4) <= 1/1000.
Proof.
idtac "arctan_0_1".
Time integral with (i_native_compute, i_prec 13, i_fuel 1).
Qed.

(* From coq-interval/testsuite/example-20171018.v *)

Optimize Heap.
Lemma h_54_ln_2  h :
  -53 <= h <= 0 ->
  -  Basic.Rnearbyint Basic.rnd_DN (h * ln 2 / ln 5) * ln 5 <= 54 * ln 2.
Proof.
intros.
idtac "h_54_ln_2 ".
Time interval with (i_native_compute, i_prec 9).
Qed.

(* From coq-interval/testsuite/example_ln.v *)

Optimize Heap.
Lemma example_ln_1 : forall x : R, (0 <= x <= 1 -> ln (exp x) <= 1 + 1/1024)%R.
idtac "example_ln_1".
Time intros; interval with (i_native_compute, i_prec 11).
Qed.

Optimize Heap.
Lemma example_ln_2 : (693/1000 < ln 2 < 694/1000)%R.
idtac "example_ln_2".
Time split; interval with (i_native_compute, i_prec 14).
Qed.

(* From [Formally Verified Approx. of Definite Integrals by Mahboubi, Melquiond, Sibut-Pinote] *)

Optimize Heap.
Lemma bissect :
  Rabs (RInt (fun x => x * sin x / (1 + cos x * cos x)) 0 PI - PI*PI/4) <= 1/1000000000000.
idtac "bissect".
Time integral with (i_native_compute, i_degree 13, i_fuel 13, i_prec 46).
Qed.

Optimize Heap.
Lemma Chebyshev :
  (RInt (fun x => (2048 * x^12 - 6144 * x^10 + 6912 * x^8 - 3584 * x^6 + 840 * x^4 - 72 * x^2 + 1) * exp (-(x - 3/4)^2) * sqrt (1 - x*x)) (-1) 1 + 32555895745 / 10000000000000000) <= 1/100000000000.
idtac "Chebyshev".
Time integral with (i_native_compute, i_degree 10, i_fuel 100, i_prec 49).
Qed.

Optimize Heap.
Lemma Rump_Tucker :
  Rabs (RInt (fun x => sin (x + exp x)) 0 8 - 3474/10000) <= 1/1000000.
idtac "Rump_Tucker".
Time integral with (i_native_compute, i_degree 7, i_fuel 4000, i_prec 53).
Qed.


Require Import Reals Psatz Lra RelationClasses List.
From Coquelicot Require Import Continuity
  Rcomplements Derive Hierarchy AutoDerive Rbar Complex
  RInt RInt_analysis Derive_2d Compactness
  Series PSeries Lim_seq.
From Coq Require Import ssreflect ssrfun ssrbool.
Close Scope boolean_if_scope.
Require Import Program.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".

Require Import helpers complex_core path_independence cauchy_integral compact_convergence.

Lemma Cminus_eq_0: forall z, z - z = 0.
Proof. move => *. field_simplify_eq; auto. Qed.

Definition contour_equiv g1 g2 :=
  (l_end g1 = l_end g2) /\
  (r_end g1 = r_end g2) /\
  (forall t, l_end g1 <= t <= r_end g1 ->
    gamma g1 t = gamma g2 t) /\
  (forall t, l_end g1 <= t <= r_end g1 ->
    gamma' g1 t = gamma' g2 t).

Lemma CInt_gamma_ext: forall g1 g2 f,
  contour_equiv g1 g2 ->
  CInt g1 f = CInt g2 f.
Proof.
  move => g1 g2 f [lend [rend [ext ext']]].
  rewrite /CInt lend rend.
  under RInt_ext => t.
    rewrite Rmin_left; last by (left; apply endpoint_interval).
    rewrite Rmax_right; last by (left; apply endpoint_interval).
    move => bd.
    rewrite ext; last by lra.
    rewrite ext'; last by lra.
  over.
  auto.
Qed.

Lemma bounded_derive_contour: forall g1, exists g2,
  contour_equiv g1 g2 /\
  exists M : posreal, forall z, norm (gamma' g2 z) < M.
Proof.
  move => g1.
  pose gam2 := {|
    gamma := extension_C1 (gamma g1) (gamma' g1) (l_end g1) (r_end g1);
    gamma' := extension_C0 (gamma' g1) (l_end g1) (r_end g1);
    l_end := l_end g1;
    r_end := r_end g1;
    endpoint_interval := endpoint_interval g1;
    contour_derive := ltac:( move => *; apply:extension_C1_is_derive;
    [ rewrite /Rbar_le; left; apply: endpoint_interval
    | rewrite /Rbar_le; move => *; apply contour_derive; auto
    ]);
    cts_derive := ltac:(move => *; apply: extension_C0_continuous;
    [ rewrite /Rbar_le; left; apply: endpoint_interval
    | rewrite /Rbar_le; move => *; apply cts_derive; auto
    ])
      |}.
  exists gam2.
  repeat split.
  - move => * //=. symmetry. apply: extension_C1_ext; simpl; auto; lra.
  - move => * //=. symmetry. apply: extension_C0_ext; simpl; auto; lra.
  - have := bounded_continuity (gamma' g1) (l_end gam2) (r_end gam2).
    case. {
        move => t tbd.
        simpl.
        apply: cts_derive.
        auto.
    }
    move => M Mbd.
    have: (0 < M ). {
      apply: Rle_lt_trans.
      apply: norm_ge_0 (gamma' gam2 (l_end gam2)).
      simpl.
      rewrite extension_C0_ext; simpl;
        [| reflexivity | left; apply: endpoint_interval].
      apply Mbd.
      split; [reflexivity | left; apply: endpoint_interval ].
    }
    move => Q.
    exists (mkposreal _ Q).
    simpl.
    move => z.
    rewrite /extension_C0.
      destruct_match.
      destruct_match.
      all: apply Mbd; auto.
      all: split; try reflexivity;
           try (left; apply: endpoint_interval).
Qed.

Definition contour_inside (g:Contour) D:=
  forall t, l_end g <= t <= r_end g -> D (gamma g t).

Hint Extern 3 (continuous (gamma' _) _) => apply: cts_derive : teardown_leaf.

Section FilterlimFunc.

Context {T:Type} {F: (T -> Prop) -> Prop } {FF: Filter F}.

Open Scope C.
Import FunctionalExtensionality.
Context {FF': ProperFilter F}.
Open Scope C.
Lemma uniform_limits_CInt : forall
  (f_: T -> C -> C)
  (flim : C -> C)
  (gam: Contour),
  filterlim (fun u z => f_ u (extension_C0 (gamma gam) (l_end gam) (r_end gam) z)) F
    (@locally (fct_UniformSpace _ _)
    (fun z => flim (extension_C0 (gamma gam) (l_end gam) (r_end gam) z))) ->
  (forall u, cts_on_contour (f_ u) gam) ->
  filterlim (fun u => CInt gam (f_ u)) F (locally (CInt gam flim)).
Proof.
  move => f_ flim gam  unif cts.

  wlog: gam unif cts /
    exists M : posreal, forall z : R_UniformSpace, norm (gamma' gam z) < M. {
      have:= bounded_derive_contour gam.
      move => [gam2 [eqv bdd]] H'.
      rewrite (@CInt_gamma_ext gam gam2); auto.
      eapply filterlim_ext.
        move => t.
        rewrite (@CInt_gamma_ext gam gam2); auto.
      reflexivity.
      move: eqv => [lends [rends[ext1 ext2]]].
      pose gamma_bar2 :=extension_C0 (gamma gam2) (l_end gam2) (r_end gam2).
      pose gamma_bar :=extension_C0 (gamma gam) (l_end gam) (r_end gam).
      have H: (forall t, gamma_bar2 t= gamma_bar t). {
        move => t.
        rewrite /gamma_bar /gamma_bar2 /extension_C0.
        rewrite -rends -lends.
        destruct_match.
        destruct_match.
        all: symmetry; apply ext1; auto; split; try reflexivity.
        all: left;apply endpoint_interval.
      }
      apply (@H' gam2).
      - apply: (@filterlim_ext _ _ _ _ _ (fun u z => (f_ u (gamma_bar z)))).
          move => x.
          apply functional_extensionality => t.
          f_equal.
          symmetry.
          apply H.
        set h := (x in locally x).
        have ->: (h = (fun z => flim (gamma_bar z))).
        2: auto.
        apply functional_extensionality => t.
        rewrite /h.
        f_equal.
        apply H.
      - move => u t tbd.
        rewrite -ext1; first apply cts.
        all: rewrite lends rends; lra.
      - auto.
  }
  move => bounded.
  have ? : l_end gam < r_end gam by apply endpoint_interval.

  rewrite /CInt.
  eapply filterlim_ext.
    move => x.
    eapply RInt_ext. move => t tbd.
      rewrite Rmin_left in tbd; last by left.
      rewrite Rmax_right in tbd; last by left.
      rewrite -(extension_C0_ext (gamma gam) (l_end gam) (r_end gam)).
      2,3: simpl; left; apply tbd.
  reflexivity.
  erewrite RInt_ext. 2: {
     move => t tbd.
    rewrite Rmin_left in tbd; last by left.
    rewrite Rmax_right in tbd; last by left.
    rewrite -(extension_C0_ext (gamma gam) (l_end gam) (r_end gam)).
    2,3: simpl; left; apply tbd.
    reflexivity.
  }
  pose gamma_bar :=extension_C0 (gamma gam) (l_end gam) (r_end gam).
  have := @filterlim_RInt T
          (C_R_CompleteNormedModule)
          (fun u t => f_ u (
            (gamma_bar t)) *
            gamma' gam t)
          (l_end gam)
          (r_end gam)
          F
          (ltac:(auto))
          (fun t => flim (gamma_bar t) * gamma' gam t)
          (fun u =>  RInt (V:=C_R_CompleteNormedModule)
                     (fun t : R => f_ u (
                       gamma_bar t) *
                       gamma' gam t)
                     (l_end gam) (r_end gam)  ).
  case.
  - move => u.
    apply: RInt_correct.
    apply: ex_RInt_continuous. move => t tbd.
    rewrite Rmin_left in tbd; last by left.
    rewrite Rmax_right in tbd; last by left.
    auto_cts.
    apply continuous_comp.
    + rewrite /gamma_bar.
      apply: extension_C0_continuous; simpl; first by left.
      move => *. apply: is_derive_continuous.
      apply: contour_derive; auto.
    + rewrite /gamma_bar extension_C0_ext; simpl.
      2,3: apply tbd.
      apply/cts_topology_2.
      apply cts.
      auto.
  - apply: filterlim_filter_le_2.
    1: apply filter_uniformly_global_local.
    apply: uniformly_bounded_mult.
    move: bounded => [M H].
    exists M =>*;apply H.
    apply: filterlim_filter_le_2.
    1: apply filter_locally_le_uniformly.
    auto.
  - move => z [+ /is_RInt_unique ->].
    apply.
Qed.

Lemma compact_limit_contour: forall
  (f_: T -> C -> C)
  (flim : C -> C)
  (gam: Contour)
  (D: C -> Prop),
  open D ->
  (forall u, D u \/ ~ D u) ->
  (exists u0, D u0) ->
  contour_inside gam D ->
  filterlim f_ F (compactly D flim) ->
  filterlim (fun u z => f_ u (extension_C0 (gamma gam) (l_end gam) (r_end gam) z)) F
    (@locally (fct_UniformSpace _ _)
    (fun z => flim (extension_C0 (gamma gam) (l_end gam) (r_end gam) z))).
Proof.
  move => f_ flim gam D openD decD nonempty gam_in_D compact_lim.

  pose gamma_bar :=extension_C0 (gamma gam) (l_end gam) (r_end gam).
  rewrite /filterlim.
  apply: (@filterlim_compose_fam).
    1: apply compactly_non_trivial; eauto.
    1: auto.
    have := @path_in_circles gamma_bar D (l_end gam) (r_end gam)
             openD (ltac:(auto)) (ltac:(auto)).
    rewrite path_independence.not_not_impl.
    have?:= endpoint_interval gam.
    case.
    + auto.
    + move => *.
      rewrite /gamma_bar /extension_C0.
      destruct_match; last apply gam_in_D.
      destruct_match; apply gam_in_D.
      all: split; try reflexivity; auto; left; auto.
    + move => *.
      apply: extension_C0_continuous; first by left.
      move => t tbd1 tbd2.
      apply: is_derive_continuous.
      apply contour_derive.
      auto.
    + move => cov [sqrs cover].
      exists (fun z => Exists (@^~ z) cov).
      split; first by (
        exists cov;
        split; auto;
        move => *; tauto
      ).
      move => t.
      rewrite /gamma_bar /extension_C0.
      have r_eq: gamma_bar (r_end gam) = gamma gam (r_end gam). {
        rewrite /gamma_bar /extension_C0.
        repeat destruct_match.
        1,2: auto.
        simpl in *.
        lra.
      }
      have l_eq: gamma_bar (l_end gam) = gamma gam (l_end gam). {
        rewrite /gamma_bar /extension_C0.
        repeat destruct_match.
        1,3: auto.
        simpl in *.
        lra.
      }

      repeat (destruct_match).
      * rewrite -(extension_C0_ext _ (l_end gam) (r_end gam)); auto.
      * move: cover => /(_ (r_end gam) (ltac:(lra))).
        rewrite r_eq //=.
      * move: cover => /(_ (l_end gam) (ltac:(lra))).
        rewrite l_eq //=.
Qed.

Lemma compact_limit_CInt: forall
  (f_: T -> C -> C)
  (flim : C -> C)
  (gam: Contour)
  (D: C -> Prop),
  open D ->
  (forall u, D u \/ ~ D u) ->
  (exists u0, D u0) ->
  contour_inside gam D ->
  filterlim f_ F (compactly D flim) ->
  (forall u, cts_on_contour (f_ u) gam) ->
  filterlim (fun u => CInt gam (f_ u)) F (locally (CInt gam flim)).
Proof.
  move => *.
  apply uniform_limits_CInt; auto.
  apply: compact_limit_contour; eauto.
Qed.
End FilterlimFunc.

Open Scope C.
Lemma C_sum_pow_n: forall (z : C) (n : nat),
  z <> 1 ->
  sum_n [eta pow_n z] n = ((1 - (pow_n z (S n))) / (1 - z)).
Proof.
  move => z + neq1.
  have?:(1 - z <> 0) by
    move => H; contradict neq1;
    rewrite -[LHS]Cplus_0_l -H;
    field_simplify_eq.
  elim.
  - simpl.
    rewrite sum_O.
    simpl.
    rewrite mult_one_r.
    rewrite /one /=.
    field_simplify_eq; auto.
  - move => n IH.
    simpl.
    rewrite sum_Sn /plus /= IH //= /mult/=.
    field_simplify_eq; last by auto.
    auto.
Qed.

Lemma Cmod_lt_1_neq_1: forall z, Cmod z < 1 -> z <> 1.
Proof.
  move => z lt1 H.
  rewrite H Cmod_1 in lt1.
  lra.
Qed.

Definition pos1: posreal := (mkposreal 1 (ltac:(lra))).
Lemma geometric_compact:
  filterlim (fun (n : nat) (z0 : C) => sum_n (pow_n z0) n) eventually
  (compactly (@ball (AbsRing_UniformSpace C_AbsRing) (0,0) pos1 ) (fun z0 : C => 1 / (1 - z0))).
Proof.
  apply filterlim_on_family.
  1: apply eventually_filter.
  move => E [sub [a[del Esqr]]].
  have ?:= cond_pos del.
  have ?:= Rlt_sqrt2_0.
  have: {p | forall z, E z -> Cmod z <= p < 1}.  {
    simpl in *.
    have {}sub: forall z, E z -> Cmod z < 1 by
      move => z Ez; rewrite -[z]Cplus_0_r -Copp_0; apply sub.
    wlog: E a Esqr sub/ 0 <= a.1 /\ 0 <= a.2. {
      destruct (Rle_dec 0 a.1); destruct (Rle_dec 0 a.2).
      - apply; eauto.
      - move => /(_
          (fun z =>  a.1 - del <= z.1 <= a.1 + del /\
                     (-a.2) - del <= z.2 <= (-a.2) + del) (a.1, -a.2))%R.

        case.
        + move => z /=. lra.
        + move => [z1 z2] H; rewrite Cmod_opp_imaginary;
          apply sub; apply /Esqr; simpl in *; lra.
        + simpl; lra.
        + move => r' rH; exists r'; move => [z1 z2] /Esqr Ez.
          rewrite Cmod_opp_imaginary; apply rH; simpl in *; lra.
      - move => /(_
          (fun z =>  (-a.1) - del <= z.1 <= (-a.1) + del /\
                     a.2 - del <= z.2 <= a.2 + del) (-a.1, a.2))%R.

        case.
        + move => z /=. lra.
        + move => [z1 z2] H; rewrite Cmod_opp_real;
          apply sub; apply /Esqr; simpl in *; lra.
        + simpl; lra.
        + move => r' rH; exists r'; move => [z1 z2] /Esqr Ez.
          rewrite Cmod_opp_real; apply rH; simpl in *; lra.
      - move => /(_
          (fun z =>  (-a.1) - del <= z.1 <= (-a.1) + del /\
                     (-a.2) - del <= z.2 <= (-a.2) + del) (-a.1, -a.2))%R.

        case.
        + move => z /=. lra.
        + move => [z1 z2] H; rewrite Cmod_opp_real Cmod_opp_imaginary;
          apply sub; apply /Esqr; simpl in *; lra.
        + simpl; lra.
        + move => r' rH; exists r'; move => [z1 z2] /Esqr Ez.
          rewrite Cmod_opp_real Cmod_opp_imaginary; apply rH; simpl in *; lra.
    }
    move => [??].
    exists (Cmod (a.1 + del, a.2+del))%R => z /Esqr Ez.
    split.
    - apply sqr_Cmod_bound; lra.
    - apply sub.
      apply/Esqr.
      simpl.
      lra.
  }
  move => [r rH].
  have rlt1 : r < 1 by move: (rH a); rewrite Esqr; move => /(_ (ltac: (lra))) [].
  have rpos : 0 <= r by
    move: (rH a); rewrite Esqr; move => /(_ (ltac: (lra)))[??];
    apply: Rle_trans; first (by apply Cmod_ge_0); eauto.

  apply/filterlim_uniformly_on => eps.

  have L: Rabs r < 1 by rewrite Rabs_pos_eq.
  pose eps' := (eps * (1-r)%R)%R.
  have?: 0 < eps by apply cond_pos.
  have eps'pos: 0 < eps' by rewrite /eps'; apply Rmult_lt_0_compat; try lra.
  have := @is_lim_seq_geom r L.
  move => /filterlim_locally /(_ (mkposreal _ eps'pos) ) [N nH].
  exists N => n nbd w Ew.
  apply: norm_compat1.
  unfold_alg.
  rewrite -/(Cminus _ _).
  have wneq: (w <> 1) by
    apply Cmod_lt_1_neq_1; apply: Rle_lt_trans;
    [ apply rH
    | apply rlt1
    ].
  rewrite C_sum_pow_n //.
  set p := (x in Cmod x).
  replace p with (- (pow_n w (S n)/(1-w))).
  2: rewrite /p /mult /=; field_simplify; auto.
  2,3: apply/ Cminus_0_eq; apply nesym; auto.
  rewrite Cmod_opp Cmod_mult pow_n_abs_C.
  rewrite pow_n_pow.
  apply Rlt_div_r; rewrite Cmod_inv.
  1: apply Rinv_0_lt_compat; apply Cmod_gt_0.
  1,2,4: apply/Cminus_0_eq; apply nesym; auto.
  have ?: ( 0 < Cmod (1-w)) by
    apply Cmod_gt_0; apply/ Cminus_0_eq; apply nesym.
  rewrite /Rdiv Rinv_involutive.
  2: move => /Cmod_eq_0 /Cminus_0_eq; contradict wneq; auto.
  have lt3: (1-r)%R <= Cmod (1-w). {
    apply: Rle_trans.
    2: apply Cmod_triangle_inverse.
    rewrite Cmod_1.
    apply Rplus_le_compat_l.
    move: (rH w Ew); lra.
  }
  apply: (@Rlt_le_trans _ (eps * (1-r)%R)).
  2: apply Rmult_le_compat_l; auto; left;apply cond_pos.
  apply (@Rle_lt_trans _ (r ^(S n))).
  1: by apply pow_incr; split; [apply Cmod_ge_0| apply rH].
  rewrite -/eps'.
  move: (nH (S n) (ltac:(auto))).
  unfold_ball;unfold_alg.
  rewrite Rabs_pos_eq.
  lra.
  field_simplify.
  rewrite -/(pow _ (S n)).
  destruct rpos; subst.
  1: left; apply pow_lt; auto.
  rewrite pow_i.
  1: lra.
  lia.
Qed.

Lemma Cplus_plus_complete: forall (z w:C_R_CompleteNormedModule), plus z w = z + w.
Proof.
  repeat unfold_alg; move => *.
  simplify_as_R2 RHS.
  auto.
Qed.
Lemma Cplus_plus_C: forall (z w:C), plus z w = z + w.
Proof.
  repeat unfold_alg; move => *.
  auto.
Qed.

Lemma cts_contour_sum: forall f gam n,
  (forall m, cts_on_contour (fun z => f m z) gam) ->
  cts_on_contour ( fun z => sum_n (fun n => f n z) n) gam.
Proof.
  move => f gam + cts.
  elim.
  - move => t tbd.
    apply: continuous_ext.
      move => x.
      rewrite sum_O.
    reflexivity.
    apply cts.
    auto.
  - move => n IH.
    move => t tbd.
    apply: continuous_ext.
      move => x.
      rewrite sum_Sn Cplus_plus_C.
    reflexivity.
    apply: continuous_plus.
    1: apply IH; auto.
     apply: cts; auto.
Qed.

Lemma sum_n_CInt : forall f gam n,
  (forall m, cts_on_contour (f m) gam) ->
  sum_n (fun m => CInt gam (fun z => f m z)) n =
  CInt gam (fun z => sum_n (fun m => f m z) n).
Proof.
  move => f gam  + cts.
  elim.
  { rewrite sum_O.
    symmetry.
    under CInt_ext.
      move => t tbd.
      rewrite sum_O.
    over.
    auto.
  }
  move => n IH.
  rewrite sum_Sn.
  rewrite Cplus_plus_complete IH.
  rewrite -CInt_plus.
  2: apply: cts.
  2: apply: cts_contour_sum; auto.
  rewrite (@CInt_ext _ (fun z:C => sum_n (f^~ z) (S n))); auto.
  move => t tbd.
  rewrite sum_Sn Cplus_plus_C.
  auto.
Qed.

Lemma contour_puncture: forall a (r:posreal) t z,
  @ball (AbsRing_UniformSpace C_AbsRing) a r z ->
  a + c_circle r t <> z.
Proof.
  move => a r t z ball ?.
  have H: (z-a = c_circle r t) by subst; field_simplify_eq; auto.
  contradict H.
  apply Cmod_lt_neq.
  rewrite c_circle_norm_2 Rabs_pos_eq.
  2: left; apply cond_pos.
  apply ball.
Qed.

Lemma CInt_puncuture_ext: forall f g a (r:posreal),
  (forall z, z <> a -> f z = g z) ->
  CInt (circC a r) f = CInt (circC a r) g.
Proof.
  move => f g a r ext.
  apply CInt_ext.
  move => t tbd.
  apply ext.
  apply contour_puncture.
  apply ball_center.
Qed.

Lemma pow_n_div: forall (z w:C) n , w <> (0,0) ->
  pow_n z n /(pow_n w n) = pow_n (z/w) n.
Proof.
  move => z w + neq.
  elim.
  - simpl.
    rewrite /one /=.
    field_simplify; auto.
    move => /pair_equal_spec [? _].
    lra.
  - move => n IH.
    simpl.
    rewrite -IH.
    rewrite /mult /=.
    field_simplify_eq; auto.
    split; [apply pow_n_neq_0; auto| auto].
Qed.

Lemma cts_puncture_contour: forall f a (r:posreal),
  (forall w, w <> a -> continuous f w) ->
  cts_on_contour f (circC a r).
Proof.
  move => f a r cts t _.
  apply cts.
  apply contour_puncture.
  apply ball_center.
Qed.

Import Logic.Classical_Prop.
Theorem holo_analytic : forall (f:C -> C) (r: posreal) D a z,
  open D ->
  CHolo_on D f ->
  (forall w, Cmod (a - w) <= r -> D w) ->
  @ball (AbsRing_UniformSpace C_AbsRing) a r z ->
  @is_pseries C_AbsRing C_NormedModule
    (fun n => PCoef * CInt (circC a r)
      (fun w => f(w)/(pow_n (w-a) (S n)))
    ) (z-a) (f z).
Proof.
  move => f r D a z openD CHolo subset aball.
  have ?:= Rgt_2PI_0.
  rewrite -(@cauchy_integral_formula f r D a z ) -/PCoef; auto.
  rewrite /is_pseries /is_series.
  eapply filterlim_ext.
    move => x.
    eapply sum_n_ext.
      move => n.
      set p := CInt _ _.
      set q := RHS.
      replace q with (PCoef * (scal (pow_n (z- a) n) p)); last by (
        rewrite /q; unfold_alg; field_simplify_eq;
        rewrite -Cmult_assoc [_*p]Cmult_comm Cmult_assoc).
        rewrite /p.
  reflexivity.
  eapply filterlim_ext.
    move => x.
    rewrite sum_n_mult_l.
  reflexivity.
  set p := (q in PCoef * q).
  replace (PCoef * p) with (mult PCoef p ); last by unfold_alg.
  apply: filterlim_comp_2.
  1: apply filterlim_const.
  2:{
    apply: filterlim_filter_le_2.
    2: apply: filterlim_filter_le_1.
    3: apply: @filterlim_mult C_AbsRing PCoef p.
    1: move => *; apply locally_C; auto.
    move => P [Q R F1 F2 impl].
    apply: Filter_prod .
    2: apply/locally_C; apply F2.
    1: apply/locally_C; apply F1.
    auto.
  }
  rewrite /p.
  eapply filterlim_ext.
    move => x.
    eapply sum_n_ext.
      move => n.
        rewrite /scal /=/mult /= -CInt_mult.
      eapply CInt_puncuture_ext => w neq.
      move =>{p}.
      set p := RHS.
      replace p with ( mult (pow_n ((z-a)/(w-a)) n)  (f(w) / (w-a)) ).
  reflexivity.
  have?: (w-a <> 0) by move => /Cminus_0_eq ?; contradict neq.
  2: {
    auto_cts_on_contour.
    apply cts_puncture_contour.
    move => w neq.
    have?: (w-a <> 0) by move => /Cminus_0_eq ?; contradict neq.
    apply continuous_comp.
    2: apply continuous_Cinv; apply Cmult_neq_0; auto; apply pow_n_neq_0; auto.
    auto_cts.
    apply/cts_topology_2.
    apply: (@continuous_comp _ _ _ (fun w => w - a) (fun w => pow_n w n));
    auto_cts.
  }
  1:{
    rewrite -pow_n_div /p; auto.
    unfold_alg.
    field_simplify_eq; auto.
    split; auto.
    apply pow_n_neq_0.
    auto.
  }
  eapply filterlim_ext.
    move => x.
    rewrite [RHS]sum_n_CInt.
    eapply CInt_puncuture_ext.
      move => w neq.
      rewrite sum_n_mult_r.
      rewrite /mult /=.
  reflexivity.
  1: {
    move => n.
    rewrite {2}/Cdiv.
    auto_cts_on_contour.
    apply cts_puncture_contour => w neq.
    apply (@continuous_comp _ _ _ (fun w:C => (z-a)/(w - a))%C
            (fun w:C => pow_n w n));
    auto_cts.
    apply/cts_topology_2.
    apply: continuous_Cinv.
    apply/ Cminus_0_eq; auto.
  }
  rewrite (@CInt_ext _ (fun w => 1/(1-((z-a)/(w-a))) * (f w /(w-a)))).
  2: {
    move => w neq.
    field_simplify_eq; auto.
    split.
    - apply/Cminus_0_eq.
      apply contour_puncture.
      apply ball_center.
    - move => H.
      field_simplify in H.
      contradict H.
      apply/ Cminus_0_eq.
      apply contour_puncture.
      auto.
  }
  pose h := extension_C0 (gamma (circC a r)) 0 (2*PI)%R.
  apply uniform_limits_CInt.
  all: rewrite -?/h.
  2:{
    move => n.
    rewrite {2}/Cdiv.
    auto_cts_on_contour.
    apply cts_contour_sum => m.
    apply: cts_puncture_contour => w neq.
    apply: (@continuous_comp _ _ _ (fun w:C => (z-a)/(w - a))%C
            (fun w:C => pow_n w m)); auto_cts.
    apply/cts_topology_2; apply: continuous_Cinv; apply/Cminus_0_eq; auto.
  }
  clear p.
  apply: filterlim_filter_le_2.
  1: apply filter_uniformly_global_local.
  apply: uniformly_bounded_mult.
  - destruct (@bounded_continuity (C_AbsRing) (C_NormedModule)
    (fun t => f (a + c_circle r t) / (a + c_circle r t - a)) 0 (2*PI)%R).
    + move => t tbd.
      rewrite -/(continuous _ _).
      auto_cts.
      1: apply: continuous_comp.
      1: auto_cts.
      1,3: rewrite /c_circle; auto_cts;
        apply: is_derive_continuous;
        auto_derive; auto.
      2: simplify_term (x in _ _ x); apply/cts_topology_2; apply: continuous_Cinv.
      2: apply nesym, Cmod_lt_neq; rewrite c_circle_norm_2 Cmod_0 Rabs_pos_eq.
      2: apply cond_pos.
      2: left; apply cond_pos.
      apply /cts_topology_2.
      have:= @holo_ball_contour f a r D subset CHolo.
      apply.
      simpl; lra.
    + have xpos: (0 < x). {
        apply: Rle_lt_trans.
        1: apply: norm_ge_0.
        2: apply (r0 0).
        split.
        1: lra.
        left.
        apply Rgt_2PI_0.
      }
      exists (mkposreal _ xpos).
      simpl.
      move => t.
      rewrite /h /extension_C0.
      repeat destruct_match; move => _.
      * apply (r0 t); split; auto; apply Rgt_2PI_0.
      * apply r0; split; [left; apply Rgt_2PI_0| reflexivity].
      * apply r0; split; [reflexivity | left; apply Rgt_2PI_0].
  - pose g t := (z-a)/(h t  -a).
    eapply filterlim_ext.
      move => x.
      apply functional_extensionality.
      move => x'.
      eapply sum_n_ext.
      move => n.
      rewrite -/(g x').
    reflexivity.
    apply: filterlim_filter_le_2.
    1: apply: filter_locally_le_uniformly.
    rewrite [x in locally x](@functional_extensionality _ _
      _ (fun t => (1/(1-g t)))).
    2: move => *; rewrite /g //=.

    pose odisk := (@ball (AbsRing_UniformSpace C_AbsRing) (0,0) pos1).
    pose dom: Domain odisk := BallDom pos1 (0,0).
    apply: (@filterlim_compose_fam _ _ _ _
      _
      (fun n (z:C) => sum_n (pow_n z) n)
      (fun z => 1/(1-z))
         ).
    1: apply compactly_non_trivial.
    have:= open_dom dom.
    simpl; apply.
    1: exists(0,0);
       apply (@ball_center (AbsRing_UniformSpace C_AbsRing) (0,0) pos1 ).
    2: {
    have := @path_in_circles g odisk 0 (2*PI)
             (open_dom dom) (ltac: (lra)).
    rewrite path_independence.not_not_impl.
    case.
    + move => w.
      apply classic.
    + move => t tbd.
      rewrite /odisk.
      unfold_ball; unfold_alg.
      rewrite /Cminus Copp_0 Cplus_0_r /g/h /Cdiv Cmod_mult.
      rewrite extension_C0_ext; simpl.
      2,3:lra.
      set p := (a + _ - a).
      replace p with (c_circle r t).
      2: rewrite /p; field_simplify_eq; auto.
      rewrite Cmod_inv.
      2: move => H; symmetry in H; contradict H; apply Cmod_lt_neq;
         rewrite c_circle_norm_2 Cmod_0 Rabs_pos_eq;[|left]; apply cond_pos.
      rewrite c_circle_norm_2 Rabs_pos_eq;[|left].
      2:apply cond_pos.
      rewrite -Rdiv_lt_1.
      2: apply cond_pos.
      apply aball.
    + move => t tbd. rewrite /g /h.
      auto_cts.
      1: apply: extension_C0_continuous.
      1: simpl; lra.
      1: move => *; apply: is_derive_continuous; apply contour_derive.
      1: simpl in *; lra.
      apply/cts_topology_2.
      apply: continuous_Cinv.
      simpl.
      rewrite /h extension_C0_ext.
      2,3: simpl; lra.
      simpl.
      apply nesym, Cmod_lt_neq.
      rewrite Cmod_0.
      set p := (a + _ -a).
      replace p with (c_circle r t).
      2: rewrite /p; field_simplify; auto.
      rewrite c_circle_norm_2 Rabs_pos_eq; [|left]; apply cond_pos.
    + move => cov [sqrs cover].
      exists (fun z => Exists (@^~ z) cov).
      split; first by (
        exists cov;
        split; auto;
        move => *; tauto
      ).
      move => t.
      rewrite /h /extension_C0.
      have r_eq: h 0 = gamma (circC a r) 0. {
        rewrite /h /extension_C0.
        repeat destruct_match.
        1,2: auto.
        simpl in *.
        lra.
        auto.
      }
      have l_eq: h (2*PI)%R = gamma(circC a r) (2*PI)%R. {
        rewrite /h /extension_C0.
        repeat destruct_match.
        1,3: auto.
        simpl in *.
        lra.
        auto.
      }
      rewrite /g/h/extension_C0.
      repeat destruct_match.
      * rewrite //= -(extension_C0_ext (fun t => a + c_circle r t)  0 (2*PI)%R); auto.
        apply: cover.
        auto.
      * rewrite -l_eq //=.
        apply: cover.
        lra.
      * rewrite -r_eq //=.
        apply: cover; lra.
    }
    apply geometric_compact.
Qed.


From mathcomp Require Import all_ssreflect all_algebra ssrnum.
From mathcomp Require Import boolp classical_sets Rstruct topology complex normedtype.
Require Import Reals Lra.
From infotheo Require Import ssrR Reals_ext logb ssr_ext ssralg_ext bigop_ext Rbigop f2.
(*Require Import lens.*)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Reserved Notation "A ^†" (at level 8, format "A ^†").
Reserved Notation "A ・ B" (at level 7, format "A ・ B").  (* katakana middle dot (U+30FB) *)

Reserved Notation "∣ x1 , .. , xn ⟩" (at level 0). (* mid (U+2223) and rangle (U+27E9) *)
Reserved Notation "'∣' x '⟩'".  (* mid (U+2223) and rangle (U+27E9) *)
Reserved Notation "'⟨' x '¦'".  (* langle (U+27E8) and brvbar (U+00A6) *)

Declare Scope quantum_scope.

(*Delimit Scope R_scope with real.*)

Import GRing.Theory.
Import Num.Theory.
Import Order.POrderTheory.

Local Open Scope ring_scope.
Local Open Scope complex_scope.
Local Open Scope quantum_scope.

(*** Complex field ***)
Definition C := R[i].

Check [normedZmodType _ of C].
Check [normedZmodType _ of C] : normedZmodType C.
Check [normedZmodType C of C].

(*** ffun_hilbertType ***)

Module Hilbert.
Section def.
Record mixin_of (T : lmodType C) := Mixin {
 op : T -> T -> C;
(* _ : forall x, op 0 x = 0;*)
(* _ : forall x, op x 0 = 0;*)
 _ : forall x y z, op (x + y) z = op x z + op y z;
 _ : forall x y z, op x (y + z) = op x y + op x z;
 _ : forall c x y, op (c *: x) y = c^* * op x y;
 _ : forall c x y, op x (c *: y) = c * op x y;
 _ : forall x y, op x y = (op y x)^*
}.
Record class_of (T : Type) := Class {
 base: GRing.Zmodule.class_of T;
 base2: GRing.Lmodule.class_of [ringType of C] T;
 mixin: mixin_of (GRing.Lmodule.Pack _ base2)
}.
Structure t := Pack {car : Type; class : class_of car}.
End def.
Module Exports.
Notation hilbertType := t.
Coercion base2 : class_of >-> GRing.Lmodule.class_of.
Coercion car : hilbertType >-> Sortclass.
End Exports.
End Hilbert.
Export Hilbert.Exports.

(*** states as qubit tuples ***)
Section nvect.
Variable R : numDomainType.
Variable M : normedModType R.
Variable n : nat.
Variable I : finType.
Definition nvect := {ffun n.-tuple I -> M}.

(*** Complex conjugate transpose and complex inner product ***)
Fact admx_key : unit. Proof. by []. Qed.
Definition admx m n (A : 'M[C]_(m,n)) := \matrix[admx_key]_(i, j) (A j i)^*.
Notation "A ^†" := (admx A) : complex_scope.

Definition inner_product n (u v : 'cV[C]_n) : C :=  (u ^† *m v) 0 0.
Notation "u ・ v" := (inner_product u v) : complex_scope.

(* Definition Hermitian n (A : 'M[C]_n) := admx A = A. *)

(*** bra and ket ***)

Definition ket_type := 'cV[C]_2.
Definition bra_type := 'rV[C]_2.

Record qubit := mkQubit {
  base_ket :> ket_type ;
  norm1 : base_ket ・ base_ket == 1 }.
Canonical qubit_subType := Eval hnf in [subType for base_ket].
Canonical qubit_eqType := Eval hnf in EqType _ [eqMixin of qubit by <:].

(*
Module Qubit.
Record t := mk {
  v :> ket_type ;
  Norm1 : v ・ v == 1 }.
Definition norm1 (x : t) : (v x) ・ (v x) == 1 := Norm1 x.
Arguments norm1 : simpl never.
Module Exports.
Notation qubit := t.
Notation "q %:qubit" := (@mk q (@norm1 _)).
Canonical qubit_subType := Eval hnf in [subType for v].
Definition qubit_eqMixin := [eqMixin of qubit by <:].
Canonical qubit_eqType := Eval hnf in EqType _ qubit_eqMixin.
End Exports.
End Qubit.
Export Qubit.Exports.
Coercion Qubit.v : qubit >-> ket_type.
*)

Check [lmodType C of ket_type].

Definition ket (x : 'I_2) : ket_type := \col_(i < 2) (i == x)%:R.
Definition bra (x : 'I_2) : bra_type := \row_(i < 2) (i == x)%:R.

Notation "'∣' x '⟩'" := (ket x) : quantum_scope.
Notation "'⟨' x '¦'" := (bra x) : quantum_scope.
Check  ∣ 0 ⟩.
Check  ⟨ 1 ¦.

Check  ∣0⟩ *m ⟨1¦.
Check  ⟨1¦ *m ∣0⟩.

Notation "∣ x1 , .. , xn ⟩" := [tuple of ∣x1⟩ :: .. [:: ∣xn⟩ ] ..] : quantum_scope.

Check ∣ 0, 1, 0 ⟩ : 3.-tuple ket_type.
Fail Check ∣ 0, 1, 0 ⟩ : 3.-tuple qubit.

End nvect.

(*** Unitary transformation ***)

Module Unitary.
Section ClassDef.
Notation "u ・ v" := (inner_product u v) : complex_scope.

(* Variable (A B : Hilbert C).*)
Variable n : nat.
Local Notation A := 'cV[C]_n (only parsing).
Local Notation B := 'cV[C]_n (only parsing).
Definition axiom (f : {linear A -> B}) :=
  forall x y : A, (f x) ・ (f y) = x ・ y.
Record class_of (f : A -> B) : Prop :=
  Class {base : GRing.Linear.class_of *:%R f ;
         mixin : axiom (GRing.Linear.Pack _ base)}.
Local Coercion base : class_of >-> GRing.Linear.class_of.
Structure map (phAB : phant (A -> B)) :=
  Pack {apply; _ : class_of apply}.
Local Coercion apply : map >-> Funclass.

Variables (phAB : phant (A -> B)) (f g: A -> B) (cF : map phAB).
Definition class := let: Pack _ c as cF' := cF return class_of cF' in c.
Definition clone fL of phant_id g (apply cF) & phant_id fL class :=
  @Pack phAB f fL.
Canonical additive := GRing.Additive.Pack phAB class.
Canonical linear := GRing.Linear.Pack phAB class.
End ClassDef.

Module Exports.
Notation unitary_for s f := (class_of s f).
Notation unitary f := (lrmorphism_for *:%R f).
Coercion base : unitary_for >-> GRing.Linear.class_of.
Coercion apply : map >-> Funclass.
Notation Unitary f_lrM := (Pack (Phant _) (Class f_lrM f_lrM)).
Notation "{ 'unitary' fAB | s }" := (map s (Phant fAB))
  (at level 0, format "{ 'unitary'  fAB  |  s }") : ring_scope.
Notation "{ 'unitary' fAB }" := {unitary fAB | *:%R}
  (at level 0, format "{ 'unitary'  fAB }") : ring_scope.
Notation "[ 'unitary' 'of' f 'as' g ]" := (@clone _ _ _ _ _ f g _ _ idfun id)
  (at level 0, format "[ 'unitary'  'of'  f  'as'  g ]") : form_scope.
Notation "[ 'unitary' 'of' f ]" := (@clone _ _ _ _ _ f f _ _ id id)
  (at level 0, format "[ 'unitary'  'of'  f ]") : form_scope.

Coercion additive : map >-> GRing.Additive.map.
Canonical additive.
Coercion linear : map >-> GRing.Linear.map.
Canonical linear.
End Exports.

End Unitary.
Include Unitary.Exports.


(** * HoareAsLogic: Hoare Logic as a Logic *)

(** The presentation of Hoare logic in chapter [Hoare] could be
    described as "model-theoretic": the proof rules for each of the
    constructors were presented as _theorems_ about the evaluation
    behavior of programs, and proofs of program correctness (validity
    of Hoare triples) were constructed by combining these theorems
    directly in Coq.

    Another way of presenting Hoare logic is to define a completely
    separate proof system -- a set of axioms and inference rules that
    talk about commands, Hoare triples, etc. -- and then say that a
    proof of a Hoare triple is a valid derivation in _that_ logic.  We
    can do this by giving an inductive definition of _valid
    derivations_ in this new logic.

    This chapter is optional.  Before reading it, you'll want to read
    the [ProofObjects] chapter in _Logical
    Foundations_ (_Software Foundations_, volume 1). *)

From PLF Require Import Imp.
From PLF Require Import Hoare.

(* ################################################################# *)
(** * Definitions *)

Inductive hoare_proof : Assertion -> com -> Assertion -> Type :=
  | H_Skip : forall P,
      hoare_proof P (SKIP) P
  | H_Asgn : forall Q V a,
      hoare_proof (assn_sub V a Q) (V ::= a) Q
  | H_Seq  : forall P c Q d R,
      hoare_proof P c Q -> hoare_proof Q d R -> hoare_proof P (c;;d) R
  | H_If : forall P Q b c1 c2,
    hoare_proof (fun st => P st /\ bassn b st) c1 Q ->
    hoare_proof (fun st => P st /\ ~(bassn b st)) c2 Q ->
    hoare_proof P (IFB b THEN c1 ELSE c2 FI) Q
  | H_While : forall P b c,
    hoare_proof (fun st => P st /\ bassn b st) c P ->
    hoare_proof P (WHILE b DO c END) (fun st => P st /\ ~ (bassn b st))
  | H_Consequence  : forall (P Q P' Q' : Assertion) c,
    hoare_proof P' c Q' ->
    (forall st, P st -> P' st) ->
    (forall st, Q' st -> Q st) ->
    hoare_proof P c Q.

(** We don't need to include axioms corresponding to
    [hoare_consequence_pre] or [hoare_consequence_post], because
    these can be proven easily from [H_Consequence]. *)

Lemma H_Consequence_pre : forall (P Q P': Assertion) c,
    hoare_proof P' c Q ->
    (forall st, P st -> P' st) ->
    hoare_proof P c Q.
Proof.
  intros. eapply H_Consequence.
    apply X.  apply H.  intros. apply H0. Qed.

Lemma H_Consequence_post  : forall (P Q Q' : Assertion) c,
    hoare_proof P c Q' ->
    (forall st, Q' st -> Q st) ->
    hoare_proof P c Q.
Proof.
  intros. eapply H_Consequence.
    apply X. intros. apply H0.  apply H. Qed.

(** As an example, let's construct a proof object representing a
    derivation for the hoare triple

      {{(X=3) [X |-> X + 2] [X |-> X + 1]}}
      X::=X+1 ;; X::=X+2
      {{X=3}}.

    We can use Coq's tactics to help us construct the proof object. *)

Example sample_proof :
  hoare_proof
    ((fun st:state => st X = 3) [X |-> X + 2] [X |-> X + 1])
    (X ::= X + 1;; X ::= X + 2)
    (fun st:state => st X = 3).
Proof.
  eapply H_Seq; apply H_Asgn.
Qed.

(*
Print sample_proof.

====>
  H_Seq
  (((fun st : state => st X = 3) [X |-> X + 2]) [X |-> X + 1])
  (X ::= X + 1)
  ((fun st : state => st X = 3) [X |-> X + 2])
  (X ::= X + 2)
  (fun st : state => st X = 3)
  (H_Asgn
     ((fun st : state => st X = 3) [X |-> X + 2])
     X (X + 1))
  (H_Asgn
     (fun st : state => st X = 3)
     X (X + 2))
*)

(* ################################################################# *)
(** * Properties *)

(** **** Exercise: 2 stars (hoare_proof_sound)  *)
(** Prove that such proof objects represent true claims. *)

Theorem hoare_proof_sound : forall P c Q,
  hoare_proof P c Q -> {{P}} c {{Q}}.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** We can also use Coq's reasoning facilities to prove metatheorems
    about Hoare Logic.  For example, here are the analogs of two
    theorems we saw in chapter [Hoare] -- this time expressed in terms
    of the syntax of Hoare Logic derivations (provability) rather than
    directly in terms of the semantics of Hoare triples.

    The first one says that, for every [P] and [c], the assertion
    [{{P}} c {{True}}] is _provable_ in Hoare Logic.  Note that the
    proof is more complex than the semantic proof in [Hoare]: we
    actually need to perform an induction over the structure of the
    command [c]. *)

Theorem H_Post_True_deriv:
  forall c P, hoare_proof P c (fun _ => True).
Proof.
  intro c.
  induction c; intro P.
  - (* SKIP *)
    eapply H_Consequence.
    apply H_Skip.
    intros. apply H.
    (* Proof of True *)
    intros. apply I.
  - (* ::= *)
    eapply H_Consequence_pre.
    apply H_Asgn.
    intros. apply I.
  - (* ;; *)
    eapply H_Consequence_pre.
    eapply H_Seq.
    apply (IHc1 (fun _ => True)).
    apply IHc2.
    intros. apply I.
  - (* IFB *)
    apply H_Consequence_pre with (fun _ => True).
    apply H_If.
    apply IHc1.
    apply IHc2.
    intros. apply I.
  - (* WHILE *)
    eapply H_Consequence.
    eapply H_While.
    eapply IHc.
    intros; apply I.
    intros; apply I.
Qed.

(** Similarly, we can show that [{{False}} c {{Q}}] is provable for
    any [c] and [Q]. *)

Lemma False_and_P_imp: forall P Q,
  False /\ P -> Q.
Proof.
  intros P Q [CONTRA HP].
  destruct CONTRA.
Qed.

Tactic Notation "pre_false_helper" constr(CONSTR) :=
  eapply H_Consequence_pre;
    [eapply CONSTR | intros ? CONTRA; destruct CONTRA].

Theorem H_Pre_False_deriv:
  forall c Q, hoare_proof (fun _ => False) c Q.
Proof.
  intros c.
  induction c; intro Q.
  - (* SKIP *) pre_false_helper H_Skip.
  - (* ::= *) pre_false_helper H_Asgn.
  - (* ;; *) pre_false_helper H_Seq. apply IHc1. apply IHc2.
  - (* IFB *)
    apply H_If; eapply H_Consequence_pre.
    apply IHc1. intro. eapply False_and_P_imp.
    apply IHc2. intro. eapply False_and_P_imp.
  - (* WHILE *)
    eapply H_Consequence_post.
    eapply H_While.
    eapply H_Consequence_pre.
      apply IHc.
      intro. eapply False_and_P_imp.
    intro. simpl. eapply False_and_P_imp.
Qed.

(** As a last step, we can show that the set of [hoare_proof] axioms
    is sufficient to prove any true fact about (partial) correctness.
    More precisely, any semantic Hoare triple that we can prove can
    also be proved from these axioms.  Such a set of axioms is said to
    be _relatively complete_.  Our proof is inspired by this one:

      http://www.ps.uni-saarland.de/courses/sem-ws11/script/Hoare.html

    To carry out the proof, we need to invent some intermediate
    assertions using a technical device known as _weakest
    preconditions_.  Given a command [c] and a desired postcondition
    assertion [Q], the weakest precondition [wp c Q] is an assertion
    [P] such that [{{P}} c {{Q}}] holds, and moreover, for any other
    assertion [P'], if [{{P'}} c {{Q}}] holds then [P' -> P].  We can
    more directly define this as follows: *)

Definition wp (c:com) (Q:Assertion) : Assertion :=
  fun s => forall s', c / s \\ s' -> Q s'.

(** **** Exercise: 1 star (wp_is_precondition)  *)

Lemma wp_is_precondition: forall c Q,
  {{wp c Q}} c {{Q}}.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star (wp_is_weakest)  *)

Lemma wp_is_weakest: forall c Q P',
   {{P'}} c {{Q}} -> forall st, P' st -> wp c Q st.
(* FILL IN HERE *) Admitted.

(** The following utility lemma will also be useful. *)

Lemma bassn_eval_false : forall b st, ~ bassn b st -> beval st b = false.
Proof.
  intros b st H. unfold bassn in H. destruct (beval st b).
    exfalso. apply H. reflexivity.
    reflexivity.
Qed.
(** [] *)

(** **** Exercise: 5 stars (hoare_proof_complete)  *)
(** Complete the proof of the theorem. *)

Theorem hoare_proof_complete: forall P c Q,
  {{P}} c {{Q}} -> hoare_proof P c Q.
Proof.
  intros P c. generalize dependent P.
  induction c; intros P Q HT.
  - (* SKIP *)
    eapply H_Consequence.
     eapply H_Skip.
      intros.  eassumption.
      intro st. apply HT.  apply E_Skip.
  - (* ::= *)
    eapply H_Consequence.
      eapply H_Asgn.
      intro st. apply HT. econstructor. reflexivity.
      intros; assumption.
  - (* ;; *)
    apply H_Seq with (wp c2 Q).
     eapply IHc1.
       intros st st' E1 H. unfold wp. intros st'' E2.
         eapply HT. econstructor; eassumption. assumption.
     eapply IHc2. intros st st' E1 H. apply H; assumption.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Finally, we might hope that our axiomatic Hoare logic is
    _decidable_; that is, that there is an (terminating) algorithm (a
    _decision procedure_) that can determine whether or not a given
    Hoare triple is valid (derivable).  But such a decision procedure
    cannot exist!

    Consider the triple [{{True}} c {{False}}]. This triple is valid
    if and only if [c] is non-terminating.  So any algorithm that
    could determine validity of arbitrary triples could solve the
    Halting Problem.

    Similarly, the triple [{{True}} SKIP {{P}}] is valid if and only if
    [forall s, P s] is valid, where [P] is an arbitrary assertion of
    Coq's logic. But it is known that there can be no decision
    procedure for this logic.

    Overall, this axiomatic style of presentation gives a clearer
    picture of what it means to "give a proof in Hoare logic."
    However, it is not entirely satisfactory from the point of view of
    writing down such proofs in practice: it is quite verbose.  The
    section of chapter [Hoare2] on formalizing decorated programs
    shows how we can do even better. *)


Require Import Arith.
Require Import List.
Require Import msl.base.
Require Import msl.eq_dec.

Definition table (A B : Type) := list (A*B).

Fixpoint table_get {A B}{H: EqDec A} (rho: table A B) (x: A) : option B :=
  match rho with
  | (y,v)::ys => if eq_dec x y then Some v else table_get ys x
  | nil => None
 end.

Definition table_set {A B}{H: EqDec A} (x: A) (v: B) (rho: table A B)  : table A B := (x,v)::rho.

Lemma table_gss {A B}{H: EqDec A}: forall rho x (v: B), table_get (table_set x v rho) x = Some v.
Proof.
intros.
simpl. destruct (eq_dec x x); auto. contradiction n; auto.
Qed.

Lemma table_gso {A B}{H: EqDec A}: forall rho x y (v:B), x<>y -> table_get (table_set x v rho) y = table_get rho y.
Proof.
intros.
simpl. destruct (eq_dec y x); auto.  contradiction H0; auto.
Qed.

Definition var := nat.
Instance EqDec_var: EqDec var := _.
Opaque var.

Definition adr := nat.
Instance EqDec_adr : EqDec adr := _.
Opaque adr.

Definition locals := table var adr.
Definition heap := adr -> option adr.

Inductive expr :=
 | Const: adr -> expr
 | Var: var -> expr
 | Offset: expr -> nat -> expr
 | Mem: expr -> expr.

Coercion Var : var >-> expr.
Coercion Const: adr >-> expr.
Notation " a '.+' n " := (Offset a n) (at level 87, no associativity).

Inductive control :=
| Assign: expr -> expr -> control -> control
| IfThenElse: expr -> control -> control -> control
| Go: expr -> list expr -> control.

Definition program := table adr (list var * control).

Definition bind_option (A B: Type) (f: option A) (g: A -> option B) : option B :=
  match f with None => None | Some x => g x end.

Implicit Arguments bind_option [A B].

Notation "'do1' X '<-' A ';' B" := (bind_option A (fun X => B))
   (at level 200, X ident, A at level 100, B at level 200).

Definition emptyheap : heap := fun _ => None.
Definition heap_get (h: heap) (a: adr) : option adr := h a.
Definition heap_set (a v: adr) (h: heap) :=
   fun i => if eq_dec i a then Some v else h i.

Lemma heap_gss: forall h x v, heap_get (heap_set x v h) x = Some v.
Proof.
unfold heap_get, heap_set; intros. destruct (eq_dec x x); auto. contradiction n; auto.
Qed.

Lemma heap_gso: forall h x y v, x<>y -> heap_get (heap_set x v h) y = heap_get h y.
Proof.
unfold heap_get, heap_set;  intros.
simpl. destruct (eq_dec y x); auto.  contradiction H; auto.
Qed.

Opaque heap.

Fixpoint expr_get (s: locals)(h: heap) (e: expr) : option adr :=
 match e with
 | Const n => Some n
 | Var x => table_get s x
 | Offset e n => do1 v <- expr_get s h e; Some (v+n)
 | Mem e => do1 v <- expr_get s h e; heap_get h v
 end.

Fixpoint get_list s h (xs: list expr) : option (list adr) :=
  match xs with
  | nil => Some nil
  | e :: es => do1 v <- expr_get s h e; do1 vs <- get_list s h es; Some (v::vs)
 end.

Definition mk_locals  (xs: list var) (ys: list adr) : locals := combine xs ys.

Definition state := (locals * heap * control)%type.

Definition step (p: program) (sk: state) : option state :=
 match sk with
 | ((stk,hp), Assign (Var x) y c) =>
                           do1 v <- expr_get stk hp y;
                           Some ((table_set x v stk, hp), c)
 | ((stk,hp), Assign (Mem x) y c) =>
                           do1 v <- expr_get stk hp y;
                           do1 p <- expr_get stk hp x;
                           Some ((stk, heap_set p v hp), c)
 | (_, Assign _ y c) => None
 | ((stk,hp), IfThenElse x c1 c2) =>
                           do1 v <- expr_get stk hp x;
                           Some (if eq_dec v 0 then ((stk,hp), c2) else ((stk,hp), c1))
 | ((stk, hp), Go x ys) =>
                           do1 v <- expr_get stk hp x;
                           do1 k <- table_get p v;
                           do1 vs <- get_list stk hp ys;
                           Some ((mk_locals (fst k) vs, hp), snd k)
 end.

Fixpoint stepN (p: program) (sk: state) (n: nat) : option state :=
  match n with O => Some sk
  | S n' => match step p sk with Some sk' => stepN p sk' n' | _ => None end
  end.

Fixpoint boundary (p: program) : nat :=
  match p with (n, _)::p' => Max.max (S n) (boundary p') | nil => 2 end.

Definition initial_locals (p: program) : locals := (0, boundary p)::nil.

Definition initial_heap (p: program) : heap :=
    fun i => if lt_dec i (boundary p) then None else Some 0.

Definition run (p: program) (n: nat) : option state :=
    stepN p (nil, initial_heap p, Go (Const 0) (Const (boundary p) :: nil)) n.

Notation "'Do' x ':=' v ';' c" := (Assign x v c) (at level 200, x at level 1, v at level 90, c at level 200).
Notation "'If' x 'Then' c1 'Else' c2" := (IfThenElse x c1 c2)  (at level 200, x at level 90, c1 at level 200, c2 at level 200).

Definition safe (p: program) : Prop :=  forall n, exists sk', run p n = Some sk'.

(* LOCAL VARIABLE ENVIRONMENTS *)

Definition env := var -> adr.

Definition env_set (f: env) (x: var) (y: adr) :=
   fun i => if eq_dec i x then y else f i.

Lemma env_gss : forall s x y, env_set s x y x = y.
Proof. unfold env_set; intros.  destruct (eq_dec x x); auto. congruence.
Qed.
Lemma env_gso: forall s x y z, x<>z -> env_set s x y z = s z.
Proof. unfold env_set; intros. destruct (eq_dec z x); auto. congruence.
Qed.

Definition locals2env (s: locals) : env :=
   fun x => match table_get s x with Some a => a | None => 0 end.

Fixpoint eval (e: expr) : env -> adr :=
 fun s =>
 match e with
 | Const n => n
 | Var x => s x
 | Offset e n => n + eval e s
 | Mem e => 0
 end.

Definition eval_list (xs: list expr) : env -> (list adr) := fun s => map (fun e => eval e s) xs.

Lemma offset_zero:  forall a, eval (a .+ 0) = eval a.
Proof. intros. extensionality s; simpl; destruct (eval a s); simpl; f_equal; auto.
Qed.

Lemma offset_offset: forall a n m,
  eval ((a .+ n) .+ m) = eval (a .+ (n+m)).
Proof.
 intros.
 extensionality s. simpl.
Transparent adr. unfold adr; omega.
Opaque adr.
Qed.

Definition arguments (vars: list var) (vl: list adr) : env :=
      locals2env (mk_locals vars vl).
Opaque arguments.

Lemma locals2env_table_set:
  forall x y s, locals2env (table_set x y s) = env_set (locals2env s) x y.
Proof. intros; extensionality i. unfold locals2env, env_set, table_set.
  simpl. destruct (eq_dec i x); auto.
Qed.

Definition subst{A} (x: var) (v: adr) (P: env -> A) : env -> A :=
   fun s => P (env_set s x v).

(* TYPE-CHECKING OF LOCAL VARIABLES *)
Require Import msl.Coqlib2.

Require ListSet.
Definition varset : Type := ListSet.set var.
Definition vs_mem: var -> varset -> bool := ListSet.set_mem EqDec_var.
Definition vs_add: var -> varset -> varset := ListSet.set_add EqDec_var.

Definition varcompat (vars: varset) (s: locals) :=
   forall i, vs_mem i vars = true -> table_get s i <> None.

Fixpoint expcheck (vars: varset) (e: expr) :=
  match e with
  | Const _ => true
  | Var v => vs_mem v vars
  | Offset e n => expcheck vars e
  | Mem _ => false
  end.

Fixpoint typecheck (vars: varset) (c: control) : bool :=
 match c with
  | Assign (Var v) (Mem e) c' => andb (expcheck vars e)
                                         (typecheck (vs_add v vars) c')
  | Assign (Var v) e c' => andb (expcheck vars e)
                                         (typecheck (vs_add v vars) c')
  | Assign (Mem e1) e2 c' => andb (andb (expcheck vars e1)  (expcheck vars e2))
                                         (typecheck vars c')
  | IfThenElse e c1 c2 => andb (expcheck vars e)
                                            (andb (typecheck vars c1) (typecheck vars c2))
  | Go e el => andb (expcheck vars e)  (forallb (expcheck vars) el)
  | _ => false
  end.

Lemma eval_expr_get:
  forall vars s h e,
              expcheck vars e = true ->
              varcompat vars s ->
              expr_get s h e = Some (eval e (locals2env s)).
Proof. induction e; simpl; auto; intros.
  apply H0 in H. unfold locals2env.
 destruct (table_get s v); auto. congruence.
  specialize (IHe H H0). rewrite IHe. simpl.   f_equal; omega.
  inv H.
Qed.

Lemma eval_expr_get_list:
  forall vars s h el,
              forallb (expcheck vars) el = true ->
              varcompat vars s ->
              get_list s h el = Some (eval_list el (locals2env s)).
Proof. induction el; simpl; auto; intros.
 rewrite andb_true_iff in H; destruct H.
  rewrite (eval_expr_get vars s h a); auto. simpl.
  rewrite (IHel H1 H0); auto.
Qed.

Lemma varcompat_add:
  forall x vars z s, varcompat vars s -> varcompat (vs_add x vars) (table_set x z s).
Proof.
 intros. intros i ?. specialize (H i).
 unfold vs_mem, vs_add in *.
 apply ListSet.set_mem_correct1 in H0.
 destruct (eq_dec i x).
 subst. rewrite table_gss. congruence.
 rewrite table_gso; auto. apply H.
 apply ListSet.set_add_elim2 in H0; auto.
 apply ListSet.set_mem_correct2; auto.
Qed.

Lemma varcompat_mk_locals:
  forall xl vl, length xl <= length vl -> varcompat xl (mk_locals xl vl).
Proof.
 unfold varcompat, vs_mem, mk_locals. intros.
 revert vl H H0; induction xl; destruct vl; intros.
 apply ListSet.set_mem_correct1 in H0. inv H0.
 apply ListSet.set_mem_correct1 in H0. inv H0.
 inv H. simpl in H.
 specialize (IHxl vl). spec IHxl ; [ omega |].
 apply ListSet.set_mem_correct1 in H0. simpl in H0. destruct H0.
 subst. simpl.
destruct (eq_dec i i); auto. congruence.
 simpl. destruct (eq_dec i a). congruence.
 apply IHxl.
 apply ListSet.set_mem_correct2. auto.
Qed.

Definition inlist {A: Type}{EA: EqDec A} (x: A) (vl: list A) : bool :=
   existsb (fun y => if eq_dec x y then true else false) vl.

Lemma inlist_notIn {A: Type}{EA: EqDec A}:
  forall (x: A) (vl: list A), inlist x vl = false -> ~ In x vl.
Proof.
  induction vl; simpl; intros; intuition.
  subst. destruct (eq_dec x x); auto. inv H.
  destruct (eq_dec x a). inv H. simpl in H. auto.
Qed.

Fixpoint list_nodups {A: Type}{EA: EqDec A} (vl: list A) : bool :=
  match vl with
  | nil => true
  | x::xl => andb (negb (inlist x xl)) (list_nodups xl)
  end.

Inductive list_norepet {A: Type} : list A -> Prop :=
  | list_norepet_nil:
      list_norepet nil
  | list_norepet_cons:
      forall hd tl,
      ~(In hd tl) -> list_norepet tl -> list_norepet (hd :: tl).

Lemma nodups_norepet  {A: Type}{EA: EqDec A} :
    forall l, list_nodups l = true -> list_norepet l.
Proof. induction l; intros.
  constructor.
  simpl in H. apply andb_true_iff in H.
  destruct H.
  constructor; auto.
  apply inlist_notIn. destruct (inlist a l); auto; inv H.
Qed.

(* SAFE FOR N STEPS *)

Definition safeN (p: program) (sk: state) (n: nat) : Prop :=
   exists sk', stepN p sk n = Some sk'.

Lemma stepN_plus: forall p sk1 n1 n2 sk3,
   stepN p sk1 (n1+n2) = Some sk3 <->
   (exists sk2, stepN p sk1 n1 = Some sk2 /\ stepN p sk2 n2 = Some sk3).
Proof.
 induction n1; intros.
 simpl; split; eauto. intros [sk2 [? ?]]. inv H; auto.
 replace (S n1 + n2) with (n1 + S n2) by omega.
 rewrite (IHn1 (S n2) sk3).
 split; intros [sk2 [? ?]].
 simpl in H0; invSome.
 exists s. split; auto.
 replace (S n1) with (n1 + 1) by omega.
 rewrite (IHn1 1). exists sk2; split; simpl; auto. rewrite H0; auto.
 replace (S n1) with (n1 + 1) in H by omega.
 rewrite (IHn1 1) in H. destruct H as [sk4 [? ?]].
 exists sk4; split; simpl; auto. simpl in H1.  invSome. auto.
Qed.

Lemma safeN_less: forall p sk n1 n2, n1 <= n2 -> safeN p sk n2 -> safeN p sk n1.
Proof.
 intros.
 assert (n2 = n1 + (n2-n1)) by omega.
 rewrite H1 in H,H0.
 forget (n2-n1) as k.
 clear n2 H1 H.
 destruct H0 as [sk' ?].
 rewrite stepN_plus in H.
 destruct H as [sk2 [? ?]]; exists sk2; auto.
Qed.

Lemma safeN_step:
  forall p sk sk' n, step p sk = Some sk' -> (safeN p sk (S n) <-> safeN p sk' n).
Proof.
  unfold safeN; intros.
  split; intros [sk2 ?].
  exists sk2.
 simpl in H0. rewrite H in H0. auto.
  exists sk2; simpl.  rewrite H; auto.
Qed.


Require Import ZArith.
Require Import Coq.Bool.Bool.

From Flocq Require Import Binary Bits.

Require Import MathClasses.interfaces.abstract_algebra.

Require Import Helix.MSigmaHCOL.CType.

(* Defining these before importing math classes to avoid name collisions,
   e.g. on [Lt] *)
Section MinMax.

  Definition Float64Min (a b: binary64) :=
    match a, b with
    | B754_nan _ _ _ _ _, _ | _, B754_nan _ _ _ _ _ => build_nan _ _ (binop_nan_pl64 a b)
    | _, _ =>
      match Bcompare _ _ a b with
      | Some Datatypes.Lt => a
      | _ => b
      end
    end.

  Definition Float64Max (a b: binary64): binary64 :=
    match a, b with
    | B754_nan _ _ _ _ _, _ | _, B754_nan _ _ _ _ _ => build_nan _ _ (binop_nan_pl64 a b)
    | _, _ =>
      match Bcompare _ _ a b with
      | Some Datatypes.Lt => b
      | _ => a
      end
    end.

End MinMax.

Require Import MathClasses.interfaces.canonical_names.
Require Import MathClasses.interfaces.abstract_algebra.
Require Import MathClasses.interfaces.orders.

Definition FT_Rounding:mode := mode_NE.

Require Import Coq.micromega.Lia.

Definition Float64Zero : binary64 := B754_zero _ _ false.
Program Definition Float64One : binary64 := Bone _ _ eq_refl eq_refl.

Instance binary64_Equiv: Equiv binary64 := eq.

(* Should be somewhere in stdlib but I could not find it *)
Lemma positive_dec : forall p1 p2 : positive, {p1 ≡ p2} + {p1 ≢ p2}.
Proof.
  decide equality.
Defined.

Instance binary64_equiv_dec: forall x y: binary64, Decision (x = y).
Proof.
  intros.
  unfold Decision, equiv, binary64_Equiv.
  unfold binary64 in *.

  destruct x,y; try (right; unfold not; intros C; inversion C; reflexivity).
  1,2:
    destruct (bool_dec s s0) as [HB|NB] ;
    [left; subst; reflexivity| right; contradict NB; inversion NB; auto].
  -
    destruct (bool_dec s s0) as [HB|NB].
    +
      subst.
      destruct (positive_dec pl pl0) as [HP|NP].
      *
        left; subst; f_equiv; apply proof_irrelevance.
      *
        right; contradict NP; inversion NP; auto.
    +
      right; contradict NB; inversion NB; auto.
  -
    destruct (bool_dec s s0) as [HB|NB], (Z.eq_dec e e1) as [HZ|NZ], (positive_dec m m0) as [HP|NP]; subst; try (replace e0 with e2 by (apply proof_irrelevance); clear e0).
    + left; reflexivity.
    + right; contradict NP; inversion NP; auto.
    + right; contradict NZ; inversion NZ; auto.
    + right; contradict NZ; inversion NZ; auto.
    + right; contradict NB; inversion NB; auto.
    + right; contradict NB; inversion NB; auto.
    + right; contradict NB; inversion NB; auto.
    + right; contradict NB; inversion NB; auto.
Qed.

Instance binary64_Setoid: Setoid binary64.
Proof.
  split.
  -
    intros x.
    unfold equiv, binary64_Equiv.
    reflexivity.
  -
    intros x y E.
    unfold equiv, binary64_Equiv in *.
    auto.
  -
    intros x y z Exy Eyz.
    unfold equiv, binary64_Equiv in *.
    rewrite Exy, Eyz.
    reflexivity.
Qed.

Module MFloat64asCT <: CType.

  Definition t := binary64.

  Definition CTypeEquiv := binary64_Equiv.
  Definition CTypeSetoid := binary64_Setoid.

  Definition CTypeZero := Float64Zero.
  Definition CTypeOne  := Float64One.

  Lemma CTypeZeroOneApart: Float64Zero ≠ Float64One.
  Proof.
    unfold Float64Zero, Float64One.
    intros H.
    inversion H.
  Qed.

  Definition CTypeEquivDec := binary64_equiv_dec.

  Definition CTypePlus     := b64_plus FT_Rounding.
  Definition CTypeNeg      := b64_opp.
  Definition CTypeMult     := b64_mult FT_Rounding.
  Definition CTypeAbs      := b64_abs.

  (* For "regular" floating point numbers the comparison is
    straighforward. However we need to handle NaNs. From point of
    view of DHCOL<->FHCOL semantics equivalence, NaNs does not matter,
    as we are going to constant the proof to input data which does not
    contain NaNs and furthermore prove that NaNs will not appear as
    result of any internal computations. So any NaN behaviour will do.

    To simplify FHCOL->IR compiler proofs we will chose to handle NaNs
    as similiar as possible as it is done in [fcmp olt] instruction
    which this one is compiled to. Per IR spec it "yields true if both
    operands are not a QNAN and op1 is less than op2"

  *)
  Definition CTypeZLess (a b: binary64) : binary64 :=
    match a, b with
    | B754_nan _ _ _ _ _, _ | _, B754_nan _ _ _ _ _ => CTypeZero
    | _, _ =>
      match Bcompare _ _ a b with
      | Some Datatypes.Lt => CTypeOne
      | _ => CTypeZero
      end
    end.

  (* Quick test that definitoin we have is indeed different from
     directly using [Bcompare]:

  Definition CTypeZLess' (a b: binary64) : binary64 :=
    match Bcompare _ _ a b with
    | Some Datatypes.Lt => CTypeOne
      | _ => CTypeZero
    end.

  Require Import HelixTactics.
  Lemma Foo: forall a b, CTypeZLess' a b ≡ CTypeZLess a b.
  Proof.
    intros.
    unfold CTypeZLess, CTypeZLess'.
    repeat break_match; auto; try reflexivity.
    (* could not be proven. *)
  Qed.
   *)

  Definition CTypeMin      := Float64Min.
  Definition CTypeMax      := Float64Max.
  Definition CTypeSub      := b64_minus FT_Rounding.

  Instance Zless_proper: Proper ((=) ==> (=) ==> (=)) CTypeZLess.
  Proof. solve_proper. Qed.

  Instance abs_proper: Proper ((=) ==> (=)) b64_abs.
  Proof. solve_proper. Qed.

  Instance plus_proper: Proper ((=) ==> (=) ==> (=)) (b64_plus FT_Rounding).
  Proof. solve_proper. Qed.

  Instance sub_proper: Proper ((=) ==> (=) ==> (=)) (b64_minus FT_Rounding).
  Proof. solve_proper. Qed.

  Instance mult_proper: Proper ((=) ==> (=) ==> (=)) (b64_mult FT_Rounding).
  Proof. solve_proper. Qed.

  Instance min_proper: Proper ((=) ==> (=) ==> (=)) (Float64Min).
  Proof. solve_proper. Qed.

  Instance max_proper: Proper ((=) ==> (=) ==> (=)) (Float64Max).
  Proof. solve_proper. Qed.

End MFloat64asCT.


Welcome to Coq 8.4pl4 (November 2015)

Coq < Definition andb (b1:bool) (b2:bool) : bool := match b1 with | true => b2 | false => false end.
andb is defined

Coq < Theorem andb_commutative : forall b c, andb b c = andb c b.
1 subgoal

  ============================
   forall b c : bool, andb b c = andb c b

andb_commutative < Proof.
1 subgoal

  ============================
   forall b c : bool, andb b c = andb c b

andb_commutative < info_auto.
(* info auto : *)
idtac.
1 subgoal

  ============================
   forall b c : bool, andb b c = andb c b

andb_commutative < intros b c.
1 subgoal

  b : bool
  c : bool
  ============================
   andb b c = andb c b

andb_commutative < destruct b.
2 subgoals

  c : bool
  ============================
   andb true c = andb c true

subgoal 2 is:
 andb false c = andb c false

andb_commutative < destruct c.
3 subgoals

  ============================
   andb true true = andb true true

subgoal 2 is:
 andb true false = andb false true
subgoal 3 is:
 andb false c = andb c false

andb_commutative < info_auto.
(* info auto : *)
 apply @eq_refl.
2 subgoals

  ============================
   andb true false = andb false true

subgoal 2 is:
 andb false c = andb c false

andb_commutative < reflexivity.
1 subgoal

  c : bool
  ============================
   andb false c = andb c false

andb_commutative < destruct c.
2 subgoals

  ============================
   andb false true = andb true false

subgoal 2 is:
 andb false false = andb false false

andb_commutative < reflexivity.
1 subgoal

  ============================
   andb false false = andb false false

andb_commutative < reflexivity.
No more subgoals.

andb_commutative < Qed.
info_auto.
intros b c.
destruct b.
 destruct c.
  info_auto.

  reflexivity.

 destruct c.
  reflexivity.

  reflexivity.

andb_commutative is defined

Coq <