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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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).

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 53, 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 53, 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 53, 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 53, i_bisect phi, i_taylor phi).
Qed.
End Rel_err_geodesic.

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

(** MetiTarski_JAR2010 paper *)

(* 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, i_bisect x, i_taylor x).
Qed.

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

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 53).
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 53, 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 53, 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 53).
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 53).
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 53).
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 53, 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 53, 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 53, 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 53, 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 53).
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 53).
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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53, 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 53).
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 53).
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 53).
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 53).
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 53).
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.


(** Reification is the mechanism used to transmit values from OCaml to Coq. *)
Require Import Setoid.
Require Import NArith.
Require Import PArith.
Require Import Map.

Set Implicit Arguments.

(** A S-expression, basically a binary tree, can reify almost any data value. *)
Module SExpr.
  Inductive t: Type :=
  | I: t
  | B: t -> t -> t.
End SExpr.

(** A reifiable type is a type equipped with reification functions. *)
Module Reifiable.
  Import SExpr.

  Record t (T: Type): Type := New {
    Export: T -> SExpr.t;
    Import: SExpr.t -> T}.

  (** We expect to get the original value from a reified one. *)
  Definition IsSound (T: Type) (r: t T): Prop :=
    forall (v: T), Import r (Export r v) = v.

  (** If we can reify [A] to [B] and reify [B], then we can reify [A]. *)
  Definition Morphism (A B: Type) (r: t B)
    (export: A -> B) (import: B -> A): t A := New
    (fun a => Export r (export a))
    (fun s => import (Import r s)).

  (** [unit] is reifiable. *)
  Definition Unit: t unit := New
    (fun _ => I)
    (fun _ => tt).

  (** [bool] is reifiable. *)
  Definition Bool: t bool := New
    (fun b =>
      match b with
      | false => I
      | true => B I I
      end)
    (fun s =>
      match s with
      | I => false
      | _ => true
      end).

  (** [positive] is reifiable. *)
  Definition BinPos: t positive := New
    (fix export n :=
      match n with
      | xH => I
      | xO n' => B I (export n')
      | xI n' => B (B I I) (export n')
      end)
    (fix import s :=
      match s with
      | I => xH
      | B I s' => xO (import s')
      | B _ s' => xI (import s')
      end).

  (** [N] is reifiable. *)
  Definition BinNat: t N := New
    (fun n =>
      match n with
      | N0 => I
      | Npos pos => B I (Export BinPos pos)
      end)
    (fun s =>
      match s with
      | I => N0
      | B _ s' => Npos (Import BinPos s')
      end).

  (** [nat] is reifiable. We do a binary encoding. *)
  Definition Nat: t nat :=
    Morphism BinNat N.of_nat N.to_nat.

  (** A product type is reifiable. *)
  Definition Product (T1 T2: Type) (r1: t T1) (r2: t T2)
    : t (T1 * T2) := New
    (fun v =>
      B (Export r1 (fst v)) (Export r2 (snd v)))
    (fun s =>
      match s with
      | I => (Import r1 I, Import r2 I)
      | B s1 s2 => (Import r1 s1, Import r2 s2)
      end).

  (** A sum type is reifiable. *)
  Definition Sum (T1 T2: Type) (r1: t T1) (r2: t T2)
    : t (T1 + T2) := New
    (fun v =>
      match v with
      | inl v' => B I (Export r1 v')
      | inr v' => B (B I I) (Export r2 v')
      end)
    (fun v =>
      match v with
      | I => inl (Import r1 I)
      | B I s' => inl (Import r1 s')
      | B _ s' => inr (Import r2 s')
      end).

  (** A list is reifiable. *)
  Definition List (T: Type) (r: t T)
    : t (list T) := New
    (fix export v :=
      match v with
      | nil => I
      | cons x v' => B (Export r x) (export v')
      end)
    (fix import s :=
      match s with
      | I => nil
      | B s1 s2 => cons (Import r s1) (import s2)
      end).

  (** A map is reifiable. *)
  Module Map (Map: IMap).
    Definition Map (T: Type) (r_key: t Map.key) (r: t T)
      : t (Map.t T) := Morphism
      (List (Product r_key r))
      (fun map =>
        Map.fold (fun k v l => cons (k, v) l) map nil)
      (fun l =>
        List.fold_left (fun map (kv: _ * _) =>
          let (k, v) := kv in
          Map.add k v map) l (Map.empty _)).
  End Map.

  (** The above definitions are sound. *)
  Module Facts.
    Lemma MorphismIsSound: forall (A B: Type) (r: t B)
      (export: A -> B) (import: B -> A),
      (forall (v: A), import (export v) = v) -> IsSound r ->
      IsSound (Morphism r export import).
      intros A B r export import Ha Hr v.
      simpl.
      now rewrite Hr.
    Qed.

    Lemma UnitIsSound: IsSound Unit.
      intro v.
      now destruct v.
    Qed.

    Lemma BoolIsSound: IsSound Bool.
      intro v.
      now destruct v.
    Qed.

    Lemma BinPosIsSound: IsSound BinPos.
      intro v.
      induction v; trivial;
      now rewrite <- IHv at 2.
    Qed.

    Lemma BinNatIsSound: IsSound BinNat.
      intro v.
      destruct v; trivial.
      simpl.
      now rewrite BinPosIsSound.
    Qed.

    Lemma NatIsSound: IsSound Nat.
      intro v.
      unfold Nat.
      rewrite MorphismIsSound; trivial.
        exact Nat2N.id.

        exact BinNatIsSound.
    Qed.

    Lemma ProductIsSound: forall (T1 T2: Type) (r1: t T1) (r2: t T2),
      IsSound r1 -> IsSound r2 -> IsSound (Product r1 r2).
      intros T1 T2 r1 r2 H1 H2 v.
      destruct v as [v1 v2].
      simpl.
      now rewrite H1; rewrite H2.
    Qed.

    Lemma SumIsSound: forall (T1 T2: Type) (r1: t T1) (r2: t T2),
      IsSound r1 -> IsSound r2 -> IsSound (Sum r1 r2).
      intros T1 T2 r1 r2 H1 H2 v.
      destruct v as [v1 | v2]; simpl.
        now rewrite H1.

        now rewrite H2.
    Qed.

    Lemma ListIsSound: forall (T: Type) (r: t T),
      IsSound r -> IsSound (List r).
      intros T r H v.
      induction v; trivial.
      rewrite <- IHv at 2.
      simpl.
      now rewrite H.
    Qed.
  End Facts.
End Reifiable.


(***************************************************************************
* A Library for Finite Sets with Leibnitz Equality                         *
* Brian Aydemir & Arthur Charguéraud, March 2007, Coq v8.1                 *
***************************************************************************)

Set Implicit Arguments.
Require Import OrderedTypeEx.
Require Import Lib_Tactic Lib_MyFSetInterface.

(* ********************************************************************** *)
(** * Interface for Finite Sets *)

Declare Scope set_scope.

Module Type FinSet.
Declare Module E : UsualOrderedType.

(** These finite sets are compatible with Coq's FSet library, except with
  respect to [Hint]s.  [MyFSetInterface.S] is a redeclaration of
  [FSetInterface.S] with all the [Hint]s placed in the [sets] database
  instead of [core].  This is mainly to avoid polluting the [core] database
  with lemmas that are only usable by [eauto]. *)

Declare Module S : Lib_MyFSetInterface.S with Module E := E.

(** Define aliases. *)

Definition fset := S.t.
Definition elt := S.elt.

(** Equality on these sets is extensional. *)

Parameter eq_ext :
  forall s s' : fset, (forall a : elt, S.In a s <-> S.In a s') -> s = s'.

Parameter eq_if_Equal :
  forall s s' : fset, S.Equal s s' -> s = s'.

(** Notations. *)

Notation "{}" := (S.empty) : set_scope.

Notation "{{ x }}" := (S.singleton x) : set_scope.

Notation "E \u F" := (S.union E F)
  (at level 68, left associativity) : set_scope.

Notation "x \in E" := (S.In x E) (at level 69) : set_scope.

Notation "x \notin E" := (~(S.In x E)) (at level 69) : set_scope.

Notation "E << F" := (S.Subset E F) (at level 70) : set_scope.

Bind Scope set_scope with S.t.
Bind Scope set_scope with fset.

End FinSet.

(* ********************************************************************** *)
(** * Facts *)

Module FinSetFacts (M : FinSet).

Import M.
Local Open Scope set_scope.

(** Interaction of in with constructions *)

Lemma in_empty : forall x,
  x \in {} -> False.
Proof.
  intros.
  assert (S.Empty {}) by auto using S.empty_1. unfold S.Empty in *.
  assert (x \notin {}) by auto.
  intuition.
Qed.

Lemma in_singleton : forall x y,
  x \in {{y}} <-> x = y.
Proof.
  intros; split.
  intro H. symmetry. apply S.singleton_1. trivial.
  intro H. apply S.singleton_2. unfold S.E.eq. auto.
Qed.

Lemma in_union : forall x E F,
  x \in (E \u F) <-> (x \in E) \/ (x \in F).
Proof.
  intros; split.
  auto using S.union_1.
  intro H; destruct H as [ H | H ]; auto using S.union_2, S.union_3.
Qed.

(** Properties of union *)

Lemma union_same : forall E,
  E \u E = E.
Proof.
  intros. apply eq_if_Equal.
  split; repeat rewrite in_union; intuition.
Qed.

Lemma union_comm : forall E F,
  E \u F = F \u E.
Proof.
  intros. apply eq_if_Equal.
  split; repeat rewrite in_union; intuition.
Qed.

Lemma union_assoc : forall E F G,
  E \u (F \u G) = (E \u F) \u G.
Proof.
  intros. apply eq_if_Equal.
  split; repeat rewrite in_union; intuition.
Qed.

Lemma union_empty_l : forall E,
  {} \u E = E.
Proof.
  intros. apply eq_if_Equal.
  split; repeat rewrite in_union; intuition.
  contradictions. apply* in_empty.
Qed.

(** More properties of in *)

Lemma in_same : forall x,
  x \in {{x}}.
intros. rewrite* in_singleton.
Qed.

(** More properties of union *)

Lemma union_empty_r : forall E,
  E \u {} = E.
intros. rewrite union_comm.
apply union_empty_l.
Qed.

Lemma union_comm_assoc : forall E F G,
  E \u (F \u G) = F \u (E \u G).
intros. rewrite union_assoc.
rewrite (union_comm E F).
rewrite* <- union_assoc.
Qed.

(** Subset relation properties *)

Lemma subset_refl : forall E,
  E << E.
introz. auto.
Qed.

Lemma subset_trans : forall F E G,
  E << F -> F << G -> E << G.
introz. auto.
Qed.

(** Interaction of subset with constructions *)

Lemma subset_empty_l : forall E,
  {} << E.
introz. contradictions. apply* in_empty.
Qed.

Lemma subset_singleton : forall x E,
  x \in E <-> {{x}} << E.
unfold S.Subset. split; intros.
rewrite in_singleton in H0. subst*.
apply (H x). apply in_same.
Qed.

Lemma subset_union_weak_l : forall E F,
  E << (E \u F).
introz. rewrite* in_union.
Qed.

Lemma subset_union_weak_r : forall E F,
  F << (E \u F).
introz. rewrite* in_union.
Qed.

Lemma subset_union_l : forall E F G,
  (E \u F) << G <-> (E << G) /\ (F << G).
unfold S.Subset. splits; introz.
apply H. apply* subset_union_weak_l.
apply H. apply* subset_union_weak_r.
rewrite in_union in H0. intuition auto.
Qed.

(** Interaction of notin with constructions *)

Lemma notin_empty : forall x,
  x \notin {}.
introz. apply* in_empty.
Qed.

Lemma notin_singleton : forall x y,
  x \notin {{y}} <-> x <> y.
split; introz.
apply H. rewrite* in_singleton.
apply H. rewrite* <- in_singleton.
Qed.

Lemma notin_same : forall x,
  x \notin {{x}} -> False.
intros. use in_same.
Qed.

Lemma notin_union : forall x E F,
  x \notin (E \u F) <-> (x \notin E) /\ (x \notin F).
splits; intros.
rewrite in_union in H. auto*.
rewrite in_union in H. auto*.
rewrite* in_union.
Qed.

End FinSetFacts.


Require Import Equalities.
Require Import HahnBase.
Require Import List.
Require Import ListSet.
Require Import Permutation.
Require Import PermutationTactic.
Require Import Setoid.
Require Import Utf8.
Require Import ZArith.

Import ListNotations.

Set Implicit Arguments.

Lemma ex_iff :
  forall A p q (EQ: forall x : A, p x <-> q x),
  (exists x, p x) <-> (exists x, q x).
Proof.
  firstorder.
Qed.

Lemma all_iff :
  forall A p q (EQ: forall x : A, p x <-> q x),
  (forall x, p x) <-> (forall x, q x).
Proof.
  firstorder.
Qed.

Lemma option_not_none {T} :
  forall x : option T,
  ~ x = None <-> exists v, x = Some v.
Proof.
  intros x. split; intro H1.
  - intuition. destruct x; vauto.
  - intro. desf.
Qed.

(** ** Functions *)

(** Auxiliary results and lemmas on functions. *)

(** Here [update] is the _modification_ of a function [f] at [x] by value [v]. *)

Definition update {A} (f : Z -> A)(x : Z)(v : A) : Z -> A :=
  fun y : Z => if Z.eq_dec x y then v else f y.

Lemma update_apply {A} f x (v : A) :
  (update f x v) x = v.
Proof.
  unfold update.
  destruct (Z.eq_dec x x); intuition omega.
Qed.

Lemma update_idemp {A} f x (v : A) :
  update (update f x v) x v = update f x v.
Proof.
  unfold update.
  extensionality v'.
  desf.
Qed.

Lemma update_eq_dep {A} f g x (v : A) :
  update f x v = update g x v ->
  forall y, x <> y -> f y = g y.
Proof.
  intros H1 y H2.
  unfold update in H1.
  apply equal_f with y in H1.
  desf.
Qed.

Lemma update_idle {A} (f : Z -> A) :
  forall x,
  f = update f x (f x).
Proof.
  intro x.
  unfold update.
  extensionality y.
  desf.
Qed.

Lemma update_idle2 {A} (f : Z -> A) :
  forall (x : Z)(v : A),
  f x = v -> update f x v = f.
Proof.
  intros x v H.
  unfold update.
  extensionality y. desf.
Qed.

(** ** Lists *)

Definition disjoint A (X Y : A -> Prop) :=
  forall x, X x -> Y x -> False.

Definition disjoint_list A (xl yl : list A) :=
  forall x (IN1 : In x xl) (IN2 : In x yl), False.

Definition pred_of_list A (l : list A) (x : A) := In x l.

Coercion pred_of_list : list >-> Funclass.

Lemma disjoint_conv :
  forall A (l1 l2 : list A),
  disjoint l1 l2 -> disjoint_list l1 l2.
Proof.
  done.
Qed.

(** Auxiliary results and lemmas on lists. *)

Fixpoint updatelist {A} (f : Z -> A) (xs : list (Z*A)) : Z -> A :=
  match xs with
    | (x,y)::xs' => updatelist (update f x y) xs'
    | nil => f
  end.

Fixpoint list_zip {A B} (xs : list A) (ys : list B) : list (A * B) :=
  match (xs, ys) with
    | (x::xs', y::ys') => (x, y) :: list_zip xs' ys'
    | _ => nil
  end.

Fixpoint list_zipped {A B} (xs : list A) (ys : list B) (zs : list (A * B)) : Prop :=
  match (xs, ys, zs) with
    | (x::xs', y::ys', (z1, z2)::zs') => x = z1 /\ y = z2 /\ list_zipped xs' ys' zs'
    | (nil, nil, nil) => True
    | _ => False
  end.

Fixpoint list_disj {A} (xs ys : list A) : Prop :=
  match xs with
    | nil => True
    | x::xs' => ~ In x ys /\ list_disj xs' ys
  end.

Lemma in_app {T} :
  forall (xs ys : list T)(x : T),
  In x xs -> In x (xs ++ ys).
Proof.
  intros xs ys x H.
  assert (In x xs \/ In x ys).
  by left.
  by apply in_or_app in H0.
Qed.

Lemma list_member_not_split {T} :
  forall (x : T)(xs1 xs2 : list T),
  ~ In x (xs1 ++ xs2) ->
  ~ In x xs1 /\ ~ In x xs2.
Proof.
  intros x xs1 xs2 H.
  intuition.
Qed.

Lemma remove_In_neq {T} (eq_dec : forall x y : T, { x = y } + { x <> y }) :
  forall xs x y,
  x <> y ->
  In x xs <-> In x (remove eq_dec y xs).
Proof.
  induction xs; intros x y H1; simpls.
  split; intro H2.
  (* left to right *)
  - destruct H2 as [H2 | H2]; clarify.
    desf; vauto.
    desf. by apply IHxs.
    by apply in_cons, IHxs.
  (* right to left *)
  - desf; vauto.
    right. by apply IHxs in H2.
    simpls.
    destruct H2 as [H2 | H2]; clarify.
    by left. right.
    rewrite <- IHxs in H2; auto.
Qed.

Lemma map_eq_In {T U} :
  forall (xs : list T)(x : T)(f1 f2 : T -> U),
  In x xs ->
  map f1 xs = map f2 xs ->
  f1 x = f2 x.
Proof.
  induction xs; intros x f1 f2 H1 H2; simpls.
  destruct H1 as [H1 | H1]. clarify.
  apply IHxs; auto.
  repeat rewrite <- map_cons in H2.
  desf.
Qed.

(** *** List partitioning *)

(** Properties of the [partition] operation that are not in the standard library. *)

Lemma partition_permut {T} :
  forall (xs ys1 ys2 : list T)(f : T -> bool),
  partition f xs = (ys1, ys2) ->
  Permutation xs (ys1 ++ ys2).
Proof.
  induction xs as [|x xs IH]; intros ys1 ys2 f H1.
  (* base case *)
  - simpls. vauto.
  (* induction case *)
  - simpls. desf; simpls.
    + apply perm_skip. by apply IH with f.
    + transitivity (x :: ys1 ++ l0); [|by list_permutation].
      apply perm_skip. by apply IH with f.
Qed.

Lemma partition_f_left {T} :
  forall (xs ys1 ys2 : list T)(f : T -> bool),
  partition f xs = (ys1, ys2) ->
  forall x : T, In x ys1 -> f x = true.
Proof.
  induction xs as [|x xs IH]; intros ys1 ys2 f H1 y H2.
  (* base case *)
  - simpls. vauto.
  (* induction case *)
  - simpls. desf; simpls; desf; vauto.
    + by apply IH with l ys2.
    + by apply IH with ys1 l0.
Qed.

Lemma partition_f_right {T} :
  forall (xs ys1 ys2 : list T)(f : T -> bool),
  partition f xs = (ys1, ys2) ->
  forall x : T, In x ys2 -> f x = false.
Proof.
  induction xs as [|x xs IH]; intros ys1 ys2 f H1 y H2.
  (* base case *)
  - simpls. vauto.
  (* induction case *)
  - simpls. desf; simpls; desf; vauto.
    + by apply IH with l ys2.
    + by apply IH with ys1 l0.
Qed.

Lemma partition_exists {T} :
  forall (xs : list T)(f : T -> bool),
  exists ys, partition f xs = ys.
Proof.
  induction xs as [|x xs IH]. vauto.
  intros f. specialize IH with f.
  destruct IH as ((ys1 & ys2) & H1). simpls. desf.
  (* [f x] is true *)
  - by exists (x :: ys1, ys2).
  (* [f x] is false *)
  - by exists (ys1, x :: ys2).
Qed.

Lemma partition_res {T} :
  forall (xs : list T)(f : T -> bool),
  partition f xs = (fst (partition f xs), snd (partition f xs)).
Proof.
  induction xs as [|x xs IH]. vauto.
  intros f. simpl. desf.
Qed.

(** *** Lists of natural numbers *)

Open Scope nat_scope.

Fixpoint list_nat_max (xs : list nat) : nat :=
  match xs with
    | nil => 0
    | x :: xs' => max x (list_nat_max xs')
  end.

Lemma list_nat_max_app :
  forall xs x,
  list_nat_max (x :: xs) = max x (list_nat_max xs).
Proof.
  induction xs; intro x; simpls.
Qed.

Lemma list_nat_max_tail :
  forall xs x,
  list_nat_max xs <= list_nat_max (x :: xs).
Proof.
  induction xs; intro x; simpls.
  rewrite Max.max_0_r.
  apply Peano.le_0_n.
  apply Nat.le_trans with (max a (max x (list_nat_max xs))).
  by apply Nat.max_le_compat_l.
  rewrite Max.max_assoc.
  rewrite Max.max_comm with a x.
  by rewrite <- Max.max_assoc.
Qed.

Lemma list_nat_max_le_app :
  forall xs x,
  x <= list_nat_max (x :: xs).
Proof.
  induction xs; intro x; simpls.
  by rewrite Max.max_0_r.
  apply Nat.le_trans with (list_nat_max (x :: xs)); simpls.
  apply Nat.max_le_compat_l.
  rewrite <- list_nat_max_app.
  apply list_nat_max_tail.
Qed.

Lemma list_nat_max_In :
  forall xs x,
  In x xs -> x <= list_nat_max xs.
Proof.
  induction xs; intros x H; simpls.
  destruct H as [H | H]. clarify.
  rewrite <- list_nat_max_app.
  apply list_nat_max_le_app.
  apply Nat.le_trans with (list_nat_max xs); auto.
  rewrite <- list_nat_max_app.
  apply list_nat_max_tail.
Qed.

Lemma list_nat_max_In_neg :
  forall xs,
  ~ In ((list_nat_max xs) + 1) xs.
Proof.
  intros xs H.
  apply list_nat_max_In in H.
  apply Nat.nle_succ_diag_l with (n := list_nat_max xs).
  omega.
Qed.

(** Given any list of natural numbers, one can always find a natural number
    that is not in this list. *)

Lemma list_nat_max_notin :
  forall xs : list nat,
  exists x : nat, ~ In x xs.
Proof.
  intro xs. exists ((list_nat_max xs) + 1).
  intro H. by apply list_nat_max_In_neg in H.
Qed.

Close Scope nat_scope.

(** *** Lists of integers *)

Open Scope Z_scope.

Fixpoint list_Z_max (xs : list Z) : Z :=
  match xs with
    | nil => 0
    | x :: xs' => Z.max x (list_Z_max xs')
  end.

Lemma list_Z_max_app :
  forall xs x,
  list_Z_max (x :: xs) = Z.max x (list_Z_max xs).
Proof.
  induction xs; intro x; simpls.
Qed.

Lemma list_Z_max_tail :
  forall xs x,
  list_Z_max xs <= list_Z_max (x :: xs).
Proof.
  induction xs; intro x; simpls.
  apply Z.le_max_r.
  apply Z.le_trans with (Z.max a (Z.max x (list_Z_max xs))).
  by apply Z.max_le_compat_l.
  rewrite Z.max_assoc.
  rewrite Z.max_comm with a x.
  rewrite <- Z.max_assoc.
  reflexivity.
Qed.

Lemma list_Z_max_le_app :
  forall xs x,
  x <= list_Z_max (x :: xs).
Proof.
  induction xs; intro x; simpls.
  apply Z.le_max_l.
  apply Z.le_trans with (list_Z_max (x :: xs)); simpls.
  apply Z.max_le_compat_l.
  rewrite <- list_Z_max_app.
  apply list_Z_max_tail.
Qed.

Lemma list_Z_max_In :
  forall xs x,
  In x xs -> x <= list_Z_max xs.
Proof.
  induction xs; intros x H; simpls.
  destruct H as [H | H]. clarify.
  rewrite <- list_Z_max_app.
  apply list_Z_max_le_app.
  apply Z.le_trans with (list_Z_max xs); auto.
  rewrite <- list_Z_max_app.
  apply list_Z_max_tail.
Qed.

Lemma list_Z_max_In_neg :
  forall xs,
  ~ In ((list_Z_max xs) + 1) xs.
Proof.
  intros xs H.
  apply list_Z_max_In in H.
  apply Z.nle_succ_diag_l with (n := list_Z_max xs).
  omega.
Qed.

(** Given any (finite) list of integers, one can always find an
    integer that is not in this list. *)

Lemma list_Z_max_notin :
  forall xs : list Z,
  exists x : Z, ~ In x xs.
Proof.
  intro xs. exists ((list_Z_max xs) + 1).
  intro H. by apply list_Z_max_In_neg in H.
Qed.

Close Scope Z_scope.

(** *** List removal *)

(** The [removeFirst] operation removes only the _first_ occurrence of a
    given element [x] in a given list [xs]. *)

Section ListRemoval.

Variable T : Type.
Hypothesis eq_dec : forall x y : T, { x = y } + { x <> y }.

Fixpoint removeFirst (x : T)(xs : list T) : list T :=
  match xs with
    | [] => []
    | y :: xs' => if eq_dec x y then xs' else y :: removeFirst x xs'
  end.

Lemma Permutation_moveleft :
  forall (xs : list T)(x : T),
  In x xs -> Permutation xs (x :: removeFirst x xs).
Proof.
  induction xs; intros x H; simpls.
  destruct H as [H | H]. clarify.
  apply perm_skip. destruct (eq_dec x x); vauto.
  destruct (eq_dec x a); vauto.
  transitivity (a :: x :: removeFirst x xs).
  apply perm_skip. by apply IHxs.
  apply perm_swap.
Qed.

End ListRemoval.

(** *** Permutations *)

(** Different results on permutations on certain substructures and operations on lists. *)

Lemma map_permut {T U} :
  forall (xs ys : list T)(f : T -> U),
  Permutation xs ys ->
  Permutation (map f xs) (map f ys).
Proof.
  intros xs ys f PERM.
  induction PERM; simpls.
  by apply perm_skip.
  by apply perm_swap.
  by transitivity (map f l').
Qed.

Add Parametric Morphism {T U} : (@map T U)
  with signature eq ==> @Permutation T ==> @Permutation U
    as map_permut_mor.
Proof.
  intros f xs ys H.
  by apply map_permut.
Qed.

(** ** Finite sets *)

(** *** Auxiliary results *)

(** Some results that are not present in the ListSet library. *)

Lemma set_In_permutation {T}:
  forall (xs ys : set T)(e : T),
  Permutation xs ys -> set_In e xs -> set_In e ys.
Proof.
  intros xs ys e H.
  induction H; simpls; desf; intuition vauto.
Qed.

Add Parametric Morphism {T} : (@set_In T)
  with signature eq ==> (@Permutation T) ==> iff
    as set_In_permut_mor.
Proof.
  intros e xs ys H1. split; intro H2.
  by apply set_In_permutation with xs.
  apply set_In_permutation with ys; auto.
Qed.

Lemma set_remove_permutation {T} (eq_dec : forall x y : T, { x = y } + { x <> y }) :
  forall (xs ys : set T)(e : T),
  Permutation xs ys ->
  Permutation (set_remove eq_dec e xs) (set_remove eq_dec e ys).
Proof.
  intros xs ys e H.
  induction H; simpls; desf; intuition vauto.
Qed.

Hint Resolve set_remove_permutation.

Add Parametric Morphism {T} : (@set_remove T)
  with signature eq ==> eq ==> (@Permutation T) ==> (@Permutation T)
    as set_remove_permut_mor.
Proof.
  intros eq_dec e xs ys H.
  by apply set_remove_permutation.
Qed.

Lemma set_In_remove {T} (eq_dec : forall x y : T, { x = y } + { x <> y }) :
  forall xs x y,
  x <> y -> set_In x (set_remove eq_dec y xs) <-> set_In x xs.
Proof.
  induction xs; ins; desf; simpls; intuition vauto.
  right. by apply IHxs with y.
  right. by apply IHxs.
Qed.

Lemma set_remove_swap {T} (eq_dec : forall x y : T, { x = y } + { x <> y }):
  forall xs x y,
  set_remove eq_dec x (set_remove eq_dec y xs) =
  set_remove eq_dec y (set_remove eq_dec x xs).
Proof.
  induction xs; ins; simpls; desf; simpls; desf; intuition vauto.
  by rewrite IHxs.
Qed.

Lemma set_remove_cons {T} (eq_dec : forall x y : T, { x = y } + { x <> y }) :
  forall (xs : set T)(x y : T),
  x <> y -> y :: set_remove eq_dec x xs = set_remove eq_dec x (y :: xs).
Proof.
  induction xs; ins; desf.
Qed.

(** *** Subset *)

Definition subset {T} (X Y : set T) : Prop :=
  forall e : T, set_In e X -> set_In e Y.

Instance subset_refl {T} :
  Reflexive (@subset T).
Proof.
  by repeat red.
Qed.

Hint Resolve subset_refl.

Instance subset_trans {T} :
  Transitive (@subset T).
Proof.
  red. intros ???????.
  by apply H0, H.
Qed.

Section Subset.

Variable T : Type.
Hypothesis eq_dec : forall x y : T, { x = y } + { x <> y }.

Lemma subset_add :
  forall (e : T)(X : set T),
  subset [e] (set_add eq_dec e X).
Proof.
  red. red. ins. desf.
  by apply set_add_intro2.
Qed.

Lemma subset_add_mono :
  forall (e : T)(X : set T),
  subset X (set_add eq_dec e X).
Proof.
  red. ins. by apply set_add_intro1.
Qed.

Lemma subset_union_mono_l :
  forall (X Y : set T),
  subset X (set_union eq_dec X Y).
Proof.
  red. red. ins.
  by apply set_union_intro1.
Qed.

Lemma subset_union_mono_r :
  forall (X Y : set T),
  subset X (set_union eq_dec Y X).
Proof.
  red. red. ins.
  by apply set_union_intro2.
Qed.

Lemma subset_union_l :
  forall (X1 X2 Y : set T),
  subset X1 X2 -> subset (set_union eq_dec X1 Y) (set_union eq_dec X2 Y).
Proof.
  intros X1 X2 Y H1 e H2.
  apply set_union_intro.
  apply set_union_elim in H2. des.
  left. by apply H1.
  by right.
Qed.

Lemma subset_union_r :
  forall (X Y1 Y2 : set T),
  subset Y1 Y2 -> subset (set_union eq_dec X Y1) (set_union eq_dec X Y2).
Proof.
  intros X1 X2 Y H1 e H2.
  apply set_union_intro.
  apply set_union_elim in H2. des.
  by left.
  right. by apply H1.
Qed.

End Subset.

Add Parametric Morphism {T} (eq_dec : forall x y : T, { x = y } + { x <> y }) : (set_union eq_dec)
  with signature (@subset T) ==> (@subset T) ==> (@subset T)
    as set_union_subset_mor.
Proof.
  intros X1 Y1 H1 X2 Y2 H2.
  transitivity (set_union eq_dec Y1 X2).
  by apply subset_union_l.
  by apply subset_union_r.
Qed.

(** *** Sublists *)

(** A slightly different definition than [subset]; here elements are allowed to
    occur multiple times in the specified lists. *)

(** TODO: prove antisymmetry. *)

Section Sublist.

Variable T : Type.
Hypothesis eq_dec : forall x y : T, { x = y } + { x <> y }.

Fixpoint sublist (xs ys : set T) : Prop :=
  match xs with
    | nil => True
    | x :: xs' => set_In x ys /\ sublist xs' (set_remove eq_dec x ys)
  end.

Lemma sublist_In :
  forall (xs ys : set T)(x : T),
  sublist xs ys -> set_In x xs -> set_In x ys.
Proof.
  induction xs; ins; simpls; desf; intuition vauto.
  assert (x = a \/ x <> a). tauto. desf.
  apply IHxs with (x := x) in H1; vauto.
  by rewrite set_In_remove in H1.
Qed.

Lemma sublist_cons :
  forall (xs ys : set T)(x : T),
  sublist xs (x :: ys) <-> sublist (set_remove eq_dec x xs) ys.
Proof.
  induction xs; ins; simpls; desf; simpls;
    desf; intuition vauto; by apply IHxs.
Qed.

Lemma sublist_nil :
  forall xs : set T,
  sublist xs nil -> xs = nil.
Proof.
  induction xs; ins; simpls; desf.
Qed.

Lemma sublist_remove_In :
  forall (ys xs : set T)(x : T),
  set_In x ys ->
  sublist xs (set_remove eq_dec x ys) <-> sublist (x :: xs) ys.
Proof.
  induction ys; ins; simpls; desf; intuition vauto.
Qed.

Lemma sublist_remove :
  forall (xs ys : set T)(x : T),
  sublist xs ys -> sublist (set_remove eq_dec x xs) (set_remove eq_dec x ys).
Proof.
  induction xs, ys; ins; simpls; desf; simpls; desf; intuition vauto;
    try by apply IHxs.
  - by rewrite <- sublist_cons.
  - right. rewrite set_In_remove; auto.
  - repeat rewrite set_remove_cons; auto.
    rewrite set_remove_swap.
    apply IHxs. by rewrite <- set_remove_cons.
Qed.

Instance sublist_refl :
  Reflexive sublist.
Proof.
  red. induction x; simpls; intuition vauto; desf.
Qed.

Hint Resolve sublist_refl.

Instance sublist_trans :
  Transitive sublist.
Proof.
  red. induction x, y; simpls; desf; intuition vauto.
  - by apply IHx with y.
  - by apply IHx with y.
  - rewrite <- set_In_remove; vauto.
    apply sublist_In with y; vauto.
  - apply IHx with (t :: set_remove eq_dec a y); auto.
    rewrite set_remove_cons; vauto.
    apply sublist_remove.
    by apply sublist_remove_In.
Qed.

Lemma sublist_permutation_r :
  forall xs ys1 ys2 : set T,
  Permutation ys1 ys2 -> sublist xs ys1 -> sublist xs ys2.
Proof.
  induction xs; ins; intuition vauto.
  by rewrite <- H.
  apply IHxs with (set_remove eq_dec a ys1); vauto.
  by apply set_remove_permutation.
Qed.

Lemma sublist_permutation_l :
  forall xs1 xs2 : set T,
  Permutation xs1 xs2 ->
  forall ys, sublist xs1 ys -> sublist xs2 ys.
Proof.
  intros xs1 xs2 H.
  induction H; ins; simpls; desf; intuition vauto.
  - by apply IHPermutation.
  - assert (x = y \/ x <> y). tauto. desf.
    by rewrite set_In_remove in H0.
  - assert (x = y \/ x <> y). tauto. desf.
    rewrite set_In_remove. done. intro. by apply H2.
  - by rewrite set_remove_swap.
  - by apply IHPermutation2, IHPermutation1.
Qed.

Add Parametric Morphism : sublist
  with signature (@Permutation T) ==> (@Permutation T) ==> iff
    as sublist_permut_mor.
Proof.
  intros xs1 ys1 H1 xs2 ys2 H2. split; intro H3.
  apply sublist_permutation_l with xs1; vauto.
  apply sublist_permutation_r with xs2; vauto.
  apply sublist_permutation_l with ys1. by symmetry.
  apply sublist_permutation_r with ys2; auto.
Qed.

Lemma sublist_permutation :
  forall xs ys,
  Permutation xs ys -> sublist xs ys.
Proof.
  intros xs ys H.
  destruct H; simpls; desf; simpls; desf; intuition vauto.
  by rewrite H.
  by rewrite H, H0.
Qed.

Hint Resolve sublist_permutation.

End Sublist.

(** ** Finite maps *)

(** A list of pairs is a _finite map_ if there are no duplicates among the left elements *)

Definition fmap_dom {T U} (xs : list (T * U)) : list T :=
  fst (split xs).

Definition fmap {T U} (xs : list (T * U)) : Prop :=
  NoDup (fmap_dom xs).

Lemma fmap_dom_cons {T U} :
  forall (xs : list (T * U))(x : T * U),
  fmap_dom (x :: xs) = fst x :: fmap_dom xs.
Proof.
  induction xs; intro x; simpls;
    unfold fmap_dom; simpls; desf.
Qed.

Lemma fmap_dom_In {T U} :
  forall (xs : list (T * U))(x : T * U),
  In x xs -> In (fst x) (fmap_dom xs).
Proof.
  induction xs; intros x H; simpls.
  destruct H as [H | H]. clarify.
  rewrite fmap_dom_cons.
  by apply in_eq.
  rewrite fmap_dom_cons.
  by apply in_cons, IHxs.
Qed.

(** The following definition determines whether a list of pairs is
    _projected_ onto a given mapping. *)

Definition projected {T U} (xs : list (T * U))(f : T -> U) : Prop :=
  forall x : T * U, In x xs -> f (fst x) = snd x.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor Functor.Const_Func.
From Categories Require Import NatTrans.NatTrans NatTrans.Func_Cat.

(** The functor that maps each object c in C to the
    constant functor that maps each object of D to c in Func_Cat D C. *)
Section Const_Func_Functor.
  Context (C D : Category).

  Program Definition Const_Func_Functor : (C --> (Func_Cat D C))%functor :=
    {|
      FO := fun c => Const_Func D c;
      FA := fun _ _ h => {|Trans := fun c => h|}
    |}.

End Const_Func_Functor.


(** * SfLib: Software Foundations Library *)

(** Here we collect together several useful definitions and theorems
    from Basics.v, List.v, Poly.v, Ind.v, and Logic.v that are not
    already in the Coq standard library.  From now on we can [Import]
    or [Export] this file, instead of cluttering our environment with
    all the examples and false starts in those files. *)

(** * From the Coq Standard Library *)

Require Omega.   (* needed for using the [omega] tactic *)
Require Export Bool.
Require Export List.
Export ListNotations.
Require Export Arith.
Require Export Arith.EqNat.  (* Contains [beq_nat], among other things *)

(** * From Basics.v *)

Definition admit {T: Type} : T.  Admitted.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Fixpoint ble_nat (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => ble_nat n' m'
      end
  end.

Theorem andb_true_elim1 : forall b c,
  andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true".
    reflexivity.
  Case "b = false".
    rewrite <- H. reflexivity.  Qed.

Theorem andb_true_elim2 : forall b c,
  andb b c = true -> c = true.
Proof.
(* An exercise in Basics.v *)
Admitted.

Theorem beq_nat_sym : forall (n m : nat),
  beq_nat n m = beq_nat m n.
(* An exercise in Lists.v *)
Admitted.

(** * From Props.v *)

Inductive ev : nat -> Prop :=
  | ev_0 : ev O
  | ev_SS : forall n:nat, ev n -> ev (S (S n)).

(** * From Logic.v *)

Theorem andb_true : forall b c,
  andb b c = true -> b = true /\ c = true.
Proof.
  intros b c H.
  destruct b.
    destruct c.
      apply conj. reflexivity. reflexivity.
      inversion H.
    inversion H.  Qed.

Theorem false_beq_nat: forall n n' : nat,
     n <> n' ->
     beq_nat n n' = false.
Proof.
(* An exercise in Logic.v *)
Admitted.

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  inversion contra.  Qed.

Theorem ev_not_ev_S : forall n,
  ev n -> ~ ev (S n).
Proof.
(* An exercise in Logic.v *)
Admitted.

Theorem ble_nat_true : forall n m,
  ble_nat n m = true -> n <= m.
(* An exercise in Logic.v *)
Admitted.

Theorem ble_nat_false : forall n m,
  ble_nat n m = false -> ~(n <= m).
(* An exercise in Logic.v *)
Admitted.

Inductive appears_in (n : nat) : list nat -> Prop :=
| ai_here : forall l, appears_in n (n::l)
| ai_later : forall m l, appears_in n l -> appears_in n (m::l).

Inductive next_nat (n:nat) : nat -> Prop :=
  | nn : next_nat n (S n).

Inductive total_relation : nat -> nat -> Prop :=
  tot : forall n m : nat, total_relation n m.

Inductive empty_relation : nat -> nat -> Prop := .

(** * From Later Files *)

Definition relation (X:Type) := X -> X -> Prop.

Definition deterministic {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Inductive multi (X:Type) (R: relation X)
                            : X -> X -> Prop :=
  | multi_refl  : forall (x : X),
                 multi X R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi X R y z ->
                    multi X R x z.
Implicit Arguments multi [[X]].

Tactic Notation "multi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "multi_refl" | Case_aux c "multi_step" ].

Theorem multi_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> multi R x y.
Proof.
  intros X R x y r.
  apply multi_step with y. apply r. apply multi_refl.   Qed.

Theorem multi_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      multi R x y  ->
      multi R y z ->
      multi R x z.
Proof.
  (* FILL IN HERE *) Admitted.

(**  Identifiers and polymorphic partial maps. *)

Inductive id : Type :=
  Id : nat -> id.

Theorem eq_id_dec : forall id1 id2 : id, {id1 = id2} + {id1 <> id2}.
Proof.
   intros id1 id2.
   destruct id1 as [n1]. destruct id2 as [n2].
   destruct (eq_nat_dec n1 n2) as [Heq | Hneq].
   Case "n1 = n2".
     left. rewrite Heq. reflexivity.
   Case "n1 <> n2".
     right. intros contra. inversion contra. apply Hneq. apply H0.
Defined.

Lemma eq_id : forall (T:Type) x (p q:T),
              (if eq_id_dec x x then p else q) = p.
Proof.
  intros.
  destruct (eq_id_dec x x); try reflexivity.
  apply ex_falso_quodlibet; auto.
Qed.

Lemma neq_id : forall (T:Type) x y (p q:T), x <> y ->
               (if eq_id_dec x y then p else q) = q.
Proof.
  (* FILL IN HERE *) Admitted.

Definition partial_map (A:Type) := id -> option A.

Definition empty {A:Type} : partial_map A := (fun _ => None).

Notation "'\empty'" := empty.

Definition extend {A:Type} (Gamma : partial_map A) (x:id) (T : A) :=
  fun x' => if eq_id_dec x x' then Some T else Gamma x'.

Lemma extend_eq : forall A (ctxt: partial_map A) x T,
  (extend ctxt x T) x = Some T.
Proof.
  intros. unfold extend. rewrite eq_id; auto.
Qed.

Lemma extend_neq : forall A (ctxt: partial_map A) x1 T x2,
  x2 <> x1 ->
  (extend ctxt x2 T) x1 = ctxt x1.
Proof.
  intros. unfold extend. rewrite neq_id; auto.
Qed.

Lemma extend_shadow : forall A (ctxt: partial_map A) t1 t2 x1 x2,
  extend (extend ctxt x2 t1) x2 t2 x1 = extend ctxt x2 t2 x1.
Proof with auto.
  intros. unfold extend. destruct (eq_id_dec x2 x1)...
Qed.

(** -------------------- *)

(** * Some useful tactics *)

Tactic Notation "solve_by_inversion_step" tactic(t) :=
  match goal with
  | H : _ |- _ => solve [ inversion H; subst; t ]
  end
  || fail "because the goal is not solvable by inversion.".

Tactic Notation "solve" "by" "inversion" "1" :=
  solve_by_inversion_step idtac.
Tactic Notation "solve" "by" "inversion" "2" :=
  solve_by_inversion_step (solve by inversion 1).
Tactic Notation "solve" "by" "inversion" "3" :=
  solve_by_inversion_step (solve by inversion 2).
Tactic Notation "solve" "by" "inversion" :=
  solve by inversion 1.

(** $Date: 2014-12-31 12:04:02 -0500 (Wed, 31 Dec 2014) $ *)


Require Import HSet Limits.Pullback.
Require Import WildCat Pointed Homotopy.ExactSequence.
Require Import Modalities.ReflectiveSubuniverse.
Require Import AbGroups.AbelianGroup AbGroups.AbPullback AbGroups.Biproduct.
Require Import AbSES.Core AbSES.DirectSum.

Local Open Scope abses_scope.

(** * Pullbacks of short exact sequences *)

(** A short exact sequence [A -> E -> B] can be pulled back along a map [B' -> B]. We start by defining the underlying map, then the pointed version. *)
Definition abses_pullback {A B B' : AbGroup} (f : B' $-> B)
  : AbSES B A -> AbSES B' A.
Proof.
  intro E.
  snrapply (Build_AbSES (ab_pullback (projection E) f)
                        (grp_pullback_corec _ _ (inclusion _) grp_homo_const _)
                        (grp_pullback_pr2 (projection _) f)).
  - intro x.
    nrefine (_ @ (grp_homo_unit f)^).
    apply isexact_inclusion_projection.
  - exact (cancelL_isembedding (g:= grp_pullback_pr1 _ _)).
  - rapply conn_map_pullback'.
  - snrapply Build_IsExact.
    + snrapply phomotopy_homotopy_hset.
      * exact _.
      * reflexivity.
    + nrefine (cancelR_equiv_conn_map
                 _ _ (hfiber_pullback_along_pointed f (projection _) (grp_homo_unit _))).
      nrefine (conn_map_homotopic _ _ _ _ (conn_map_isexact (IsExact:=isexact_inclusion_projection _))).
      intro a.
      by apply path_sigma_hprop.
Defined.

(** ** The universal property of [abses_pullback_morphism] *)

(** The natural map from the pulled back sequence. *)
Definition abses_pullback_morphism {A B B' : AbGroup@{u}}
  (E : AbSES B A) (f : B' $-> B)
  : AbSESMorphism (abses_pullback f E) E.
Proof.
  snrapply (Build_AbSESMorphism grp_homo_id _ f).
  - apply grp_pullback_pr1.
  - reflexivity.
  - apply pullback_commsq.
Defined.

(** Any map [f : E -> F] of short exact sequences factors (uniquely) through [abses_pullback F f3]. *)
Definition abses_pullback_morphism_corec {A B X Y : AbGroup@{u}}
  {E : AbSES B A} {F : AbSES Y X} (f : AbSESMorphism E F)
  : AbSESMorphism E (abses_pullback (component3 f) F).
Proof.
  snrapply (Build_AbSESMorphism (component1 f) _ grp_homo_id).
  - apply (grp_pullback_corec (projection F) (component3 f)
                              (component2 f) (projection E)).
    apply right_square.
  - intro x; cbn.
    apply equiv_path_pullback_hset; cbn; split.
    + apply left_square.
    + symmetry; apply iscomplex_abses.
  - reflexivity.
Defined.

(** The original map factors via the induced map. *)
Definition abses_pullback_morphism_corec_beta `{Funext}
  {A B X Y : AbGroup@{u}} {E : AbSES B A} {F : AbSES Y X}
  (f : AbSESMorphism E F)
  : f = absesmorphism_compose (abses_pullback_morphism F (component3 f))
                              (abses_pullback_morphism_corec f).
Proof.
  apply (equiv_ap issig_AbSESMorphism^-1 _ _).
  srapply path_sigma_hprop.
  apply path_prod.
  1: apply path_prod.
  all: by apply equiv_path_grouphomomorphism.
Defined.

Definition abses_pullback_component1_id' `{Funext}
  {A B B' : AbGroup@{u}} {E : AbSES B A} {F : AbSES B' A}
  (f : AbSESMorphism E F) (h : component1 f == grp_homo_id)
  : E $== abses_pullback (component3 f) F.
Proof.
  pose (g := abses_pullback_morphism_corec f).
  nrapply abses_path_data_to_iso.
  exists (component2 g); split.
  - exact (fun a => (left_square g a)^ @ ap _ (h a)).
  - reflexivity.
Defined.

(** In particular, if [component1] of a morphism is the identity, then it exhibits the domain as the pullback of the codomain. *)
Definition abses_pullback_component1_id `{Univalence} {A B B' : AbGroup}
  {E : AbSES B A} {F : AbSES B' A}
  (f : AbSESMorphism E F) (h : component1 f == grp_homo_id)
  : E = abses_pullback (component3 f) F
  := equiv_path_abses_iso (abses_pullback_component1_id' f h).

(** For any two [E, F : AbSES B A] and [f, g : B' $-> B], there is a morphism [Ef + Fg -> E + F] induced by the universal properties of the pullbacks of E and F, respectively. *)
Definition abses_directsum_pullback_morphism `{Funext}
  {A B B' C D D' : AbGroup@{u}} {E : AbSES B A} {F : AbSES D C}
  (f : B' $-> B) (g : D' $-> D)
  : AbSESMorphism
      (abses_direct_sum (abses_pullback f E) (abses_pullback g F))
      (abses_direct_sum E F)
  := functor_abses_directsum
       (abses_pullback_morphism E f) (abses_pullback_morphism F g).

(** For any two [E, F : AbSES B A] and [f, g : B' $-> B], we have (E + F)(f + g) = Ef + Eg, where + denotes the direct sum. *)
Definition abses_directsum_distributive_pullbacks `{Univalence}
  {A B B' C D D' : AbGroup@{u}}
  {E : AbSES B A} {F : AbSES D C} (f : B' $-> B) (g : D' $-> D)
  : abses_pullback (functor_ab_biprod f g) (abses_direct_sum E F)
    = abses_direct_sum (abses_pullback f E) (abses_pullback g F)
  := (abses_pullback_component1_id (abses_directsum_pullback_morphism f g)
        (fun _ => idpath))^.

Definition abses_path_pullback_projection_commsq `{Univalence}
  {A B B' : AbGroup@{u}} (bt : B' $-> B)
  (E : AbSES B A) (F : AbSES B' A) (p : abses_pullback bt E = F)
  : exists phi : middle F $-> E, projection E o phi == bt o projection F.
Proof.
  induction p.
  exists (grp_pullback_pr1 _ _); intro x.
  nrapply pullback_commsq.
Defined.

(** ** Functoriality of [abses_pullback f] for [f : B' $-> B] *)

(** As any function, [abses_pullback f] acts on paths. By explicitly describing the analogous action on path data we get an action which computes, this turn out to be useful. *)

Global Instance is0functor_abses_pullback {A B B' : AbGroup} (f : B' $-> B)
  : Is0Functor (abses_pullback (A:=A) f).
Proof.
  srapply Build_Is0Functor;
    intros E F p.
  snrefine (_; (_,_)).
  - srapply equiv_functor_grp_pullback.
    1,3: exact grp_iso_id.
    1: exact p.1.
    2: reflexivity.
    intro x.
    exact (snd p.2 x)^.
  - intro x.
    srapply equiv_path_pullback_hset; split; cbn.
    2: reflexivity.
    exact (fst p.2 x).
  - reflexivity.
Defined.

Global Instance is1functor_abses_pullback {A B B' : AbGroup} (f : B' $-> B)
  : Is1Functor (abses_pullback (A:=A) f).
Proof.
  snrapply Build_Is1Functor.
  - intros E F p q h x.
    srapply equiv_path_pullback_hset; split; cbn.
    2: reflexivity.
    exact (h _).
  - intros E x.
    by srapply equiv_path_pullback_hset.
  - intros E F G p q x.
    by srapply equiv_path_pullback_hset.
Defined.

Lemma ap_abses_pullback `{Univalence} {A B B' : AbGroup} (f : B' $-> B)
  {E F : AbSES B A} (p : E = F)
  : ap (abses_pullback f) p
    = equiv_path_abses_iso (fmap (abses_pullback f) (equiv_path_abses_iso^-1 p)).
Proof.
  induction p.
  nrefine (_ @ ap equiv_path_abses_iso _).
  2: refine ((fmap_id_strong _ _)^ @ ap _ equiv_path_absesV_1^).
  exact equiv_path_abses_1^.
Defined.

Lemma ap_abses_pullback_data `{Univalence} {A B B' : AbGroup} (f : B' $-> B) {E F : AbSES B A}
  (p : abses_path_data_iso E F)
  : ap (abses_pullback f) (equiv_path_abses_iso p)
    = equiv_path_abses_iso (fmap (abses_pullback f) p).
Proof.
  refine (ap_abses_pullback _ _ @ _).
  apply (ap (equiv_path_abses_iso o _)).
  apply eissect.
Defined.

Definition abses_pullback_point' {A B B' : AbGroup} (f : B' $-> B)
  : (abses_pullback f pt) $== (point (AbSES B' A)).
Proof.
  snrefine (_; (_, _)).
  - snrapply Build_GroupIsomorphism.
    + srapply ab_biprod_corec.
      * refine (ab_biprod_pr1 $o _).
        apply grp_pullback_pr1.
      * apply projection.
    + srapply isequiv_adjointify.
      * snrapply grp_pullback_corec.
        -- exact (functor_ab_biprod grp_homo_id f).
        -- exact ab_biprod_pr2.
        -- reflexivity.
      * reflexivity.
      * intros [[a b] [b' c]].
        srapply equiv_path_pullback_hset; split; cbn.
        2: reflexivity.
        exact (path_prod' idpath c^).
  - reflexivity.
  - reflexivity.
Defined.

Definition abses_pullback_point `{Univalence} {A B B' : AbGroup} (f : B' $-> B)
  : abses_pullback f pt = pt :> AbSES B' A
  := equiv_path_abses_iso (abses_pullback_point' f).

Definition abses_pullback' {A B B' : AbGroup} (f : B' $-> B)
  : AbSES B A -->* AbSES B' A
  := Build_BasepointPreservingFunctor (abses_pullback f) (abses_pullback_point' f).

(** Pullback of short exact sequences as a pointed map. *)
Definition abses_pullback_pmap `{Univalence} {A B B' : AbGroup} (f : B' $-> B)
  : AbSES B A ->* AbSES B' A
  := to_pointed (abses_pullback' f).

(** ** Functoriality of [abses_pullback] *)

(** [abses_pullback] is psuedo-functorial, and we can state this in terms of actual homotopies or "path data homotopies." We decorate the latter with the suffix ('). *)

(** For every [E : AbSES B A], the pullback of [E] along [id_B] is [E]. *)
Definition abses_pullback_id `{Univalence} {A B : AbGroup}
  : abses_pullback (A:=A) (@grp_homo_id B) == idmap.
Proof.
  intro E.
  apply equiv_path_abses_iso; srefine (_; (_, _)).
  1: rapply (Build_GroupIsomorphism _ _ (grp_pullback_pr1 _ _)).
  1: reflexivity.
  intros [a [p q]]; cbn.
  exact q^.
Defined.

Definition abses_pullback_pmap_id `{Univalence} {A B : AbGroup}
  : abses_pullback_pmap (A:=A) (@grp_homo_id B) ==* pmap_idmap.
Proof.
  srapply Build_pHomotopy.
  1: apply abses_pullback_id.
  refine (_ @ (concat_p1 _)^).
  nrapply (ap equiv_path_abses_iso).
  apply path_sigma_hprop.
  apply equiv_path_groupisomorphism.
  intros [[a b] [b' p]]; cbn; cbn in p.
  by apply path_prod'.
Defined.

Definition abses_pullback_compose' {A B0 B1 B2 : AbGroup@{u}}
  (f : B0 $-> B1) (g : B1 $-> B2)
  : abses_pullback (A:=A) f o abses_pullback g $=> abses_pullback (g $o f).
Proof.
  intro E; srefine (_; (_,_)).
  - apply equiv_grp_pullback_compose_r.
  - intro a.
    by srapply equiv_path_pullback_hset.
  - reflexivity.
Defined.

(** The analog of [abses_pullback_compose'] with actual homotopies. *)
Definition abses_pullback_compose `{Univalence}
  {A B0 B1 B2 : AbGroup@{u}} (f : B0 $-> B1) (g : B1 $-> B2)
  : abses_pullback (A:=A) f o abses_pullback g == abses_pullback (g $o f)
  := fun x => equiv_path_abses_iso (abses_pullback_compose' f g x).

(** We now work towards *pointed* composition of pullback ([abses_pullback_pcompose]). The proof of pointedness will matter when we later prove that pulling back along a short exact sequence is exact (i.e. that the complex [iscomplex_pullback_abses] below is exact). For this reason we carefully construct the proof of pointedness in terms of the analog [abses_pullback_pcompose'] on path data, which computes. *)

Definition abses_pullback_pcompose' {B0 B1 B2 A : AbGroup}
  (f : B0 $-> B1) (g : B1 $-> B2)
  : abses_pullback' f $o* abses_pullback' g $=>* abses_pullback' (A:=A) (g $o f).
Proof.
  exists (abses_pullback_compose' f g).
  intros [[[a b2] [b1 c]] [b0 c']]; cbn in c, c'.
  srapply equiv_path_pullback_hset; split; cbn.
  2: reflexivity.
  exact (path_prod' idpath (c @ ap g c')).
Defined.

Definition abses_pullback_pcompose `{Univalence} {A B0 B1 B2 : AbGroup}
  (f : B0 $-> B1) (g : B1 $-> B2)
  : abses_pullback_pmap (A:=A) f o* abses_pullback_pmap g ==* abses_pullback_pmap (g $o f).
Proof.
  refine (to_pointed_compose _ _ @* _).
  apply equiv_ptransformation_phomotopy.
  apply abses_pullback_pcompose'.
Defined.

(** *** Pulling back along constant maps *)

Lemma abses_pullback_const' `{Funext} {A B B' : AbGroup}
  : const pt $=> (@abses_pullback A B B' grp_homo_const).
Proof.
  intro E.
  simpl.
  nrapply abses_path_data_to_iso.
  srefine (_;(_,_)); cbn.
  - srapply grp_pullback_corec.
    + exact (inclusion _ $o ab_biprod_pr1).
    + exact ab_biprod_pr2.
    + intro x; cbn.
      apply iscomplex_abses.
  - intro a; cbn.
    by srapply equiv_path_pullback_hset; split.
  - reflexivity.
Defined.

Definition abses_pullback_const `{Univalence} {A B B' : AbGroup}
  : const pt == @abses_pullback A B B' grp_homo_const
  := fun x => (equiv_path_abses_iso (abses_pullback_const' x)).

Lemma abses_pullback_pconst' `{Funext} {A B B' : AbGroup}
  : @pmap_abses_const B' A B A $=>* abses_pullback' grp_homo_const.
Proof.
  srefine (_; _).
  1: rapply abses_pullback_const'.
  lazy beta.
  intro x; reflexivity.
Defined.

Definition abses_pullback_pconst `{Univalence} {A B B' : AbGroup}
  : pconst ==* @abses_pullback_pmap _ A B B' grp_homo_const.
Proof.
  refine (pmap_abses_const_to_pointed @* _).
  rapply equiv_ptransformation_phomotopy.
  exact abses_pullback_pconst'.
Defined.

(** *** Pulling [E] back along [projection E] is trivial *)

Definition abses_pullback_projection_morphism `{Univalence} {B A : AbGroup} (E : AbSES B A)
  : AbSESMorphism (pt : AbSES E A) E.
Proof.
  srapply (Build_AbSESMorphism grp_homo_id _ (projection E)).
  - cbn. exact (ab_biprod_rec (inclusion E) grp_homo_id).
  - intro x; cbn.
    exact (right_identity _)^.
  - intros [a e]; cbn.
    refine (grp_homo_op _ _ _ @ _).
    refine (ap (fun x => sg_op x _) _ @ _).
    1: apply isexact_inclusion_projection.
    apply left_identity.
Defined.

Definition abses_pullback_projection `{Univalence} {B A : AbGroup} (E : AbSES B A)
  : pt = abses_pullback (projection E) E
  := abses_pullback_component1_id
       (abses_pullback_projection_morphism E) (fun _ => idpath).

(** *** Pulling back along homotopic maps *)

Lemma abses_pullback_homotopic' {A B B' : AbGroup}
  (f f' : B $-> B') (h : f == f')
  : abses_pullback (A:=A) f $=> abses_pullback f'.
Proof.
  intro E.
  srefine (_; (_, _)).
  - srapply equiv_functor_grp_pullback.
    1-3: exact grp_iso_id.
    1: reflexivity.
    apply h.
  - intro a; cbn.
    by srapply equiv_path_pullback_hset; split.
  - reflexivity.
Defined.

Lemma abses_pullback_homotopic `{Univalence} {A B B' : AbGroup}
  (f f' : B $-> B') (h : f == f')
  : abses_pullback (A:=A) f == abses_pullback f'.
Proof.
  intro E.
  apply equiv_path_abses_iso.
  exact (abses_pullback_homotopic' _ _ h _).
Defined.

Lemma abses_pullback_phomotopic' {A B B' : AbGroup}
  (f f' : B $-> B') (h : f == f')
  : abses_pullback' (A:=A) f $=>* abses_pullback' f'.
Proof.
  exists (abses_pullback_homotopic' f f' h); cbn.
  intros [[a b'] [b c]]; cbn in c.
  srapply equiv_path_pullback_hset; split; cbn.
  2: reflexivity.
  exact (path_prod' idpath (c @ h b)).
Defined.

Definition abses_pullback_phomotopic `{Univalence} {A B B' : AbGroup}
  (f f' : B $-> B') (h : f == f')
  : abses_pullback_pmap (A:=A) f ==* abses_pullback_pmap f'
  := equiv_ptransformation_phomotopy (abses_pullback_phomotopic' f f' h).

(** *** Pulling back along a complex *)

Definition iscomplex_abses_pullback' `{Univalence} {A B0 B1 B2 : AbGroup}
  (f : B0 $-> B1) (g : B1 $-> B2) (h : g $o f == grp_homo_const)
  : abses_pullback' f $o* abses_pullback' g $=>* @pmap_abses_const _ _ _ A.
Proof.
  refine (abses_pullback_pcompose' _ _ $@* _).
  refine (abses_pullback_phomotopic' _ _ h $@* _).
  exact abses_pullback_pconst'^*$.
Defined.

Definition iscomplex_abses_pullback `{Univalence} {A B0 B1 B2 : AbGroup}
  (f : B0 $-> B1) (g : B1 $-> B2) (h : g $o f == grp_homo_const)
  : IsComplex (abses_pullback_pmap (A:=A) g) (abses_pullback_pmap f).
Proof.
  refine (_ @* _).
  2: symmetry; exact pmap_abses_const_to_pointed.
  refine (to_pointed_compose _ _ @* _).
  apply equiv_ptransformation_phomotopy.
  by rapply iscomplex_abses_pullback'.
Defined.

(** A consequence is that pulling back along a short exact sequence forms a complex. *)

Definition iscomplex_pullback_abses `{Univalence} {A B C : AbGroup} (E : AbSES C B)
  : IsComplex (abses_pullback_pmap (A:=A) (projection E)) (abses_pullback_pmap (inclusion E)).
Proof.
  rapply iscomplex_abses_pullback.
  rapply iscomplex_abses.
Defined.

(** In fact, pulling back along a short exact sequence is (purely) exact. See [AbSES.PullbackFiberSequence]. *)

(** *** Fibers of pullback in terms of path data *)

Definition equiv_hfiber_abses `{Univalence} {X : Type} {A B : AbGroup}
  (f : X -> AbSES B A) (E : AbSES B A)
  : graph_hfiber f E <~> hfiber f E
  := equiv_functor_sigma_id (fun _ => equiv_path_abses_iso).

Definition hfiber_abses_path {A B B' : AbGroup} {f : B' $-> B} {X : AbSES B' A}
  (E F : graph_hfiber (abses_pullback f) X)
  := {p : E.1 $-> F.1 & (fmap (abses_pullback f) p)^$ $@ E.2 $-> F.2}.

Definition transport_path_data_hfiber_abses_pullback_l `{Univalence} {A B B' : AbGroup} {f : B' $-> B}
  {Y : AbSES B' A} {X0 : graph_hfiber (abses_pullback f) Y} {X1 : AbSES B A} (p : X0.1 = X1)
  : transport (fun x : AbSES B A => abses_pullback f x $== Y) p X0.2
    = fmap (abses_pullback f) (equiv_path_abses_iso^-1 p^) $@ X0.2.
Proof.
  induction p.
  refine (transport_1 _ _ @ _).
  nrefine (_ @ (ap (fun x => x $@ _)) _).
  2: { refine (_ @ ap _ equiv_path_absesV_1^).
       exact (fmap_id_strong _ _)^. }
  exact (cat_idr_strong _)^.
Defined.

Definition equiv_hfiber_abses_pullback `{Univalence} {A B B' : AbGroup} {f : B' $-> B}
  (Y : AbSES B' A) (U V : graph_hfiber (abses_pullback f) Y)
  : hfiber_abses_path U V <~> U = V.
Proof.
  refine (equiv_path_sigma _ _ _ oE _).
  srapply (equiv_functor_sigma' equiv_path_abses_iso);
    intro p; lazy beta.
  refine (equiv_concat_l _ _ oE _).
  { refine (transport_path_data_hfiber_abses_pullback_l _ @ _).
    refine (ap (fun x => (fmap (abses_pullback f) x) $@ _) _ @ _).
    { refine (ap _ (abses_path_data_V p) @ _).
      apply eissect. }
    refine (ap (fun x => x $@ _) _).
    rapply gpd_strong_1functor_V. }
  refine (equiv_path_sigma_hprop _ _ oE _).
  apply equiv_path_groupisomorphism.
Defined.

(** *** [AbSES] and [AbSES'] become contravariant functors in the first variable by pulling back *)

Global Instance is0functor_abses'10 {A : AbGroup}
  : Is0Functor (fun B : AbGroup^op => AbSES' B A).
Proof.
  apply Build_Is0Functor.
  exact (fun _ _ f => abses_pullback f).
Defined.

Global Instance is1functor_abses'10 `{Univalence} {A : AbGroup}
  : Is1Functor (fun B : AbGroup^op => AbSES' B A).
Proof.
  apply Build_Is1Functor; intros; cbn.
  - by apply abses_pullback_homotopic.
  - apply abses_pullback_id.
  - symmetry; apply abses_pullback_compose.
Defined.

Global Instance is0functor_abses10 `{Univalence} {A : AbGroup}
  : Is0Functor (fun B : AbGroup^op => AbSES B A).
Proof.
  apply Build_Is0Functor.
  exact (fun _ _ f => abses_pullback_pmap f).
Defined.

Global Instance is1functor_abses10 `{Univalence} {A : AbGroup}
  : Is1Functor (fun B : AbGroup^op => AbSES B A).
Proof.
  apply Build_Is1Functor; intros; cbn.
  - by apply abses_pullback_phomotopic.
  - apply abses_pullback_pmap_id.
  - symmetry; apply abses_pullback_pcompose.
Defined.