Require Import Reals Coquelicot.Coquelicot Psatz.
Require Import filter_Rlt atan_derivative_improper_integral.
Require Import arcsinh.
Require Import Interval.Tactic.
Import mathcomp.ssreflect.ssreflect.

#[export]
Hint Mode ProperFilter' - + : typeclass_instances.

Ltac lt0 :=
  match goal with
  | |- _ => assumption
  | |- 0 < exp _ => apply exp_pos
  | |- 0 < pos _ => apply cond_pos
  | |- _ > 0 => unfold Rgt; lt0
  | |- 0 < 1 =>  apply Rlt_0_1
  | |- 0 < 2 => apply Rlt_0_2
  | |- 0 < PI => apply PI_RGT_0
  | |- _ <> 0 => apply Rgt_not_eq; lt0
  | |- 0 < Rabs _ + _ => apply (Rplus_le_lt_0_compat _ _ (Rabs_pos _)); lt0
  | |- 0 < _ * _ => apply Rmult_lt_0_compat; lt0
  | |- 0 < _ + _ => apply Rplus_lt_0_compat; lt0
  | |- 0 < Rmin _ _ => apply Rmin_glb_lt; lt0
  | |- 0 < / _ => apply Rinv_0_lt_compat; lt0
  | |- 0 < sqrt _ => apply sqrt_lt_R0; lt0
  | |- 0 < _ / _ => unfold Rdiv; apply Rmult_lt_0_compat; lt0
  | |- 0 < _ ^ _ => apply pow_lt; lt0
  | |- 0 < _ ^ 2 + _ => apply Rplus_le_lt_0_compat;[apply pow2_ge_0 | lt0]
  | |- 0 < (?x * (?x * 1))%R + _ =>
                        apply Rplus_le_lt_0_compat;[apply pow2_ge_0 | lt0]
  | |- 0 <= Rabs _ => apply Rabs_pos
  | |- _ <= _ => apply Rlt_le; lt0
  | |- _ => psatzl R
  end.

(* TODO : move to coquelicot. *)
Lemma filter_prod_le {T : Type} (F G F' G' : (T -> Prop) -> Prop) :
  filter_le F F' -> filter_le G G' -> filter_le (filter_prod F G)
    (filter_prod F' G').
Proof.  now intros FF GG S [S1 S2 FS GS Imp]; exists S1 S2; auto. Qed.

Lemma is_RInt_gen_filter_le {T : NormedModule R_AbsRing}
  F G F' G' {FF : Filter F} {FG : Filter G}
  {FF' : Filter F'} {FG' : Filter G'} (f : R -> T) v :
  filter_le F' F -> filter_le G' G -> is_RInt_gen f F G v ->
  is_RInt_gen f F' G' v.
Proof.
intros lef leg intf P PP; unfold filtermapi.
now apply (filter_prod_le _ _ _ _ lef leg), intf.
Qed.

Lemma is_RInt_gen_comp {Fa Fb : (R -> Prop) -> Prop} {FFa : Filter Fa}
  {FFb : Filter Fb} (f : R -> R) (dg g : R -> R) l :
  filter_prod Fa Fb (fun p =>
      forall y, Rmin (fst p) (snd p) <= y <= Rmax (fst p) (snd p) ->
             continuous f (g y) /\
             is_derive g y (dg y) /\ continuous dg y) ->
  is_RInt_gen f (filtermap g Fa) (filtermap g Fb) l ->
  is_RInt_gen (fun x => scal (dg x) (f (g x))) Fa Fb l.
Proof.
intros dp intf P PP.
destruct dp as [S1 S2 FS1 FS2 dp].
destruct (intf P PP) as [S S' FS FS' fp1].
exists (fun x => S (g x) /\ S1 x) (fun x => S' (g x) /\ S2 x);
      try now apply filter_and; auto.
intros x y [sgx s1x] [sgy s2y]; simpl.
exists (RInt f (g x) (g y)); split.
  destruct (fp1 (g x) (g y)); try tauto.
  apply (is_RInt_comp f g dg).
     intros z zcond.
     now destruct (dp x y s1x s2y z); auto.
  intros z zcond.
  now destruct (dp x y s1x s2y z); auto.
destruct (fp1 (g x) (g y) sgx sgy) as [v [isint Pv]]; simpl in isint.
now rewrite -> (is_RInt_unique _ _ _ _ isint).
Qed.

Lemma is_RInt_gen_equiv F G F' G' (f : R -> R) v:
  (forall s, F s <-> F' s) -> (forall s, G s <-> G' s) ->
  is_RInt_gen f F G v -> is_RInt_gen f F' G' v.
Proof.
intros eqF eqG intf P PP'; unfold filtermapi.
assert (tmp := filter_prod_le F' G' F G); unfold filter_le in tmp; apply tmp.
    now intros A; rewrite eqF.
  now intros A; rewrite eqG.
now apply (intf P PP').
Qed.

Lemma ex_RInt_gen_unique
  (F G : (R -> Prop) -> Prop) {FF : ProperFilter F}
  {FG : ProperFilter G} (f : R -> R) :
  ex_RInt_gen f F G -> exists ! v, is_RInt_gen f F G v.
Proof.
intros [v Pv]; exists (RInt_gen f F G); unfold unique.
rewrite -> (is_RInt_gen_unique _ _ Pv) at 1; split;[assumption | ].
now intros v' Pv'; rewrite -> (is_RInt_gen_unique _ _ Pv').
Qed.

(* TODO : move to standard. *)
Lemma inv_sqrt x : 0 < x -> / sqrt x = sqrt (/ x).
Proof.
intros x0.
assert (sqrt x <> 0) by (apply Rgt_not_eq; lt0).
apply Rmult_eq_reg_r with (sqrt x); auto.
rewrite Rinv_l; auto.
rewrite <- sqrt_mult_alt; try lt0.
rewrite -> Rinv_l, sqrt_1; auto with real.
Qed.

(* TODO : move to standard. *)
Lemma sqrt_pow_2 x : 0 <= x -> sqrt x ^ 2 = x.
Proof. now intros x0; simpl; rewrite -> Rmult_1_r, sqrt_sqrt. Qed.

Lemma ints : 0 < /sqrt 2 < 1.
Proof. split; interval. Qed.

(* standard *)
Lemma CVU_derivable :
  forall f f' g g' c r,
   CVU f' g' c r ->
   (forall x, Boule c r x -> Un_cv (fun n => f n x) (g x)) ->
   (forall n x, Boule c r x -> derivable_pt_lim (f n) x (f' n x)) ->
   forall x, Boule c r x -> derivable_pt_lim g x (g' x).
Proof.
intros f f' g g' c d cvu cvp dff' x bx.
set (rho_ :=
       fun n y =>
           match Req_EM_T y x with
              left _ => f' n x
           |right _ => ((f n y - f n x)/ (y - x)) end).
set (rho := fun y =>
               match Req_EM_T y x with
                 left _ => g' x
               | right _ => (g y - g x)/(y - x) end).
assert (ctrho : forall n z, Boule c d z -> continuity_pt (rho_ n) z).
 intros n z bz.
 destruct (Req_EM_T x z) as [xz | xnz].
  rewrite <- xz.
  intros eps' ep'.
  destruct (dff' n x bx eps' ep') as [alp Pa].
  exists (pos alp);split;[apply cond_pos | ].
  intros z'; unfold rho_, D_x, dist, R_met; simpl; intros [[_ xnz'] dxz'].
   destruct (Req_EM_T z' x) as [abs | _].
    case xnz'; symmetry; exact abs.
   destruct (Req_EM_T x x) as [_ | abs];[ | case abs; reflexivity].
  pattern z' at 1; replace z' with (x + (z' - x)) by ring.
  apply Pa;[psatzl R | exact dxz'].
 destruct (Ball_in_inter c c d d z bz bz) as [delta Pd].
 assert (dz :  0 < Rmin delta (Rabs (z - x))).
  apply Rmin_glb_lt;[apply cond_pos | apply Rabs_pos_lt; psatzl R].
 assert (t' : forall y : R,
      R_dist y z < Rmin delta (Rabs (z - x)) ->
      (fun z : R => (f n z - f n x) / (z - x)) y = rho_ n y).
  intros y dyz; unfold rho_; destruct (Req_EM_T y x) as [xy | xny].
   rewrite xy in dyz.
   destruct (Rle_dec  delta (Rabs (z - x))).
    rewrite -> Rmin_left, R_dist_sym in dyz; unfold R_dist in dyz; psatz R.
   rewrite -> Rmin_right, R_dist_sym in dyz; unfold R_dist in dyz; psatzl R.
  reflexivity.
 apply (continuity_pt_ext_loc (fun z => (f n z - f n x)/(z - x))).
 exists (mkposreal _ dz); exact t'.
 reg;[ | psatzl R].
 apply derivable_continuous_pt; eapply exist.
 apply dff'; assumption.
assert (CVU rho_ rho c d ).
 intros eps ep.
 assert (ep8 : 0 < eps/8) by psatzl R.
 destruct (cvu _ ep8) as [N Pn1].
 assert (cauchy1 : forall n p, (N <= n)%nat -> (N <= p)%nat ->
           forall z, Boule c d z -> Rabs (f' n z - f' p z) < eps/4).
  intros n p nN pN z bz; replace (eps/4) with (eps/8 + eps/8) by field.
  rewrite <- Rabs_Ropp.
  replace (-(f' n z - f' p z)) with (g' z - f' n z - (g' z - f' p z)) by ring.
  apply Rle_lt_trans with (1 := Rabs_triang _ _); rewrite Rabs_Ropp.
  apply Rplus_lt_compat; apply Pn1; assumption.
 assert (step_2 : forall n p, (N <= n)%nat -> (N <= p)%nat ->
         forall y, Boule c d y -> x <> y ->
         Rabs ((f n y - f n x)/(y - x) - (f p y - f p x)/(y - x)) < eps/4).
  intros n p nN pN y b_y xny.
  assert (mm0 : (Rmin x y = x /\ Rmax x y = y) \/
                (Rmin x y = y /\ Rmax x y = x)).
   destruct (Rle_dec x y).
    rewrite -> Rmin_left, Rmax_right; psatzl R.
   now rewrite -> Rmin_right, Rmax_left; psatzl R.
  assert (mm : Rmin x y < Rmax x y).
   destruct mm0 as [[q1 q2] | [q1 q2]]; generalize (Rmin_Rmax x y).
   now rewrite -> q1, q2; intros; psatzl R.
   now psatzl R.
  assert (dm : forall z, Rmin x y <= z <= Rmax x y ->
            derivable_pt_lim (fun x => f n x - f p x) z (f' n z - f' p z)).
   intros z intz; rewrite <- is_derive_Reals; apply: is_derive_minus.
    rewrite is_derive_Reals.
    apply dff'; apply Boule_convex with (Rmin x y) (Rmax x y);
      destruct mm0 as [[q1 q2] | [q1 q2]]; revert intz; rewrite -> ?q1, ?q2; intros;
     try assumption.
   rewrite is_derive_Reals.
   apply dff'; apply Boule_convex with (Rmin x y) (Rmax x y);
      destruct mm0 as [[q1 q2] | [q1 q2]]; revert intz; rewrite -> ?q1, ?q2;
    intros;
     try assumption.

  replace ((f n y - f n x) / (y - x) - (f p y - f p x) / (y - x))
    with (((f n y - f p y) - (f n x - f p x))/(y - x)) by (field; psatzl R).
  destruct (MVT_cor2 (fun x => f n x - f p x) (fun x => f' n x - f' p x)
             (Rmin x y) (Rmax x y) mm dm) as [z [Pz inz]].
  destruct mm0 as [[q1 q2] | [q1 q2]].
   replace ((f n y - f p y - (f n x - f p x))/(y - x)) with
    ((f n (Rmax x y) - f p (Rmax x y) - (f  n (Rmin x y) - f p (Rmin x y)))/
      (Rmax x y - Rmin x y)) by (rewrite -> q1, q2; reflexivity).
   unfold Rdiv; rewrite -> Pz, Rmult_assoc, Rinv_r, Rmult_1_r.
    apply cauchy1; auto.
    apply Boule_convex with (Rmin x y) (Rmax x y);
      revert inz; rewrite -> ?q1, ?q2; intros;
     assumption || psatzl R.
   rewrite -> q1, q2; psatzl R.
  replace ((f n y - f p y - (f n x - f p x))/(y - x)) with
    ((f n (Rmax x y) - f p (Rmax x y) - (f  n (Rmin x y) - f p (Rmin x y)))/
      (Rmax x y - Rmin x y)).
   unfold Rdiv; rewrite -> Pz, Rmult_assoc, Rinv_r, Rmult_1_r.
    apply cauchy1; auto.
    apply Boule_convex with (Rmin x y) (Rmax x y);
     revert inz; rewrite -> ?q1, ?q2; intros;
    assumption || psatzl R.
   rewrite -> q1, q2; psatzl R.
  rewrite -> q1, q2; field; psatzl R.
 assert (unif_ac :
  forall n p, (N <= n)%nat -> (N <= p)%nat ->
     forall y, Boule c d y ->
       Rabs (rho_ n y - rho_ p y) <= eps/2).
  intros n p nN pN y b_y.
  destruct (Req_dec x y) as [xy | xny].
   destruct (Ball_in_inter c c d d x bx bx) as [delta Pdelta].
   destruct (ctrho n y b_y _ ep8) as [d' [dp Pd]].
   destruct (ctrho p y b_y _ ep8) as [d2 [dp2 Pd2]].
   assert (0 < (Rmin (Rmin d' d2) delta)/2) by lt0.
   apply Rle_trans with (1 := R_dist_tri _ _ (rho_ n (y + Rmin (Rmin d' d2) delta/2))).
   replace (eps/2) with (eps/8 + (eps/4 + eps/8)) by field.
   apply Rplus_le_compat.
    rewrite R_dist_sym; apply Rlt_le, Pd;split;[split;[exact I | psatzl R] | ].
    simpl; unfold R_dist.
    unfold Rminus; rewrite -> (Rplus_comm y), Rplus_assoc, Rplus_opp_r, Rplus_0_r.
    rewrite Rabs_pos_eq;[ | psatzl R].
    apply Rlt_le_trans with (Rmin (Rmin d' d2) delta);[psatzl R | ].
    apply Rle_trans with (Rmin d' d2); apply Rmin_l.
   apply Rle_trans with (1 := R_dist_tri _ _ (rho_ p (y + Rmin (Rmin d' d2) delta/2))).
   apply Rplus_le_compat.
    apply Rlt_le.
     replace (rho_ n (y + Rmin (Rmin d' d2) delta / 2)) with
          ((f n (y + Rmin (Rmin d' d2) delta / 2) - f n x)/
            ((y + Rmin (Rmin d' d2) delta / 2) - x)).
     replace (rho_ p (y + Rmin (Rmin d' d2) delta / 2)) with
          ((f p (y + Rmin (Rmin d' d2) delta / 2) - f p x)/
             ((y + Rmin (Rmin d' d2) delta / 2) - x)).
      apply step_2; auto; try psatzl R.
      assert (0 < pos delta) by (apply cond_pos).
      apply Boule_convex with y (y + delta/2).
        assumption.
       destruct (Pdelta (y + delta/2)); auto.
       rewrite xy; unfold Boule; rewrite Rabs_pos_eq; try psatzl R; auto.
      split; try psatzl R.
      apply Rplus_le_compat_l, Rmult_le_compat_r;[lt0 | apply Rmin_r].
     unfold rho_.
     destruct (Req_EM_T (y + Rmin (Rmin d' d2) delta/2) x);psatzl R.
    unfold rho_.
    destruct (Req_EM_T (y + Rmin (Rmin d' d2) delta / 2) x); psatzl R.
   apply Rlt_le, Pd2; split;[split;[exact I | psatzl R] | ].
   simpl; unfold R_dist.
   unfold Rminus; rewrite -> (Rplus_comm y), Rplus_assoc, Rplus_opp_r, Rplus_0_r.
   rewrite Rabs_pos_eq;[ | psatzl R].
   apply Rlt_le_trans with (Rmin (Rmin d' d2) delta); [psatzl R |].
   apply Rle_trans with (Rmin d' d2).
    solve[apply Rmin_l].
   solve[apply Rmin_r].
  apply Rlt_le, Rlt_le_trans with (eps/4);[ | psatzl R].
  unfold rho_; destruct (Req_EM_T y x); solve[auto].
 assert (unif_ac' : forall p, (N <= p)%nat ->
           forall y, Boule c d y -> Rabs (rho y - rho_ p y) < eps).
  assert (cvrho : forall y, Boule c d y -> Un_cv (fun n => rho_ n y) (rho y)).
   intros y b_y; unfold rho_, rho; destruct (Req_EM_T y x).
    intros eps' ep'; destruct (cvu eps' ep') as [N2 Pn2].
    exists N2; intros n nN2; rewrite R_dist_sym; apply Pn2; assumption.
   apply CV_mult.
    apply CV_minus.
     apply cvp; assumption.
    apply cvp; assumption.
   intros eps' ep'; simpl; exists 0%nat; intros; rewrite R_dist_eq; assumption.
  intros p pN y b_y.
  replace eps with (eps/2 + eps/2) by field.
  assert (ep2 : 0 < eps/2) by psatzl R.
  destruct (cvrho y b_y _ ep2) as [N2 Pn2].
  apply Rle_lt_trans with (1 := R_dist_tri _ _ (rho_ (max N N2) y)).
  apply Rplus_lt_le_compat.
   solve[rewrite R_dist_sym; apply Pn2, Nat.le_max_r].
  apply unif_ac; auto; solve [apply Nat.le_max_l].
 exists N; intros; apply unif_ac'; solve[auto].
intros eps ep.
destruct (CVU_continuity _ _ _ _ H ctrho x bx eps ep) as [delta [dp Pd]].
exists (mkposreal _ dp); intros h hn0 dh.
replace ((g (x + h) - g x) / h) with (rho (x + h)).
 replace (g' x) with (rho x).
  apply Pd; unfold D_x, no_cond;split;[split;[auto | psatzl R] | ].
  simpl; unfold R_dist; replace (x + h - x) with h by ring; exact dh.
 unfold rho; destruct (Req_EM_T x x) as [ _ | abs];[ | case abs]; reflexivity.
unfold rho; destruct (Req_EM_T (x + h) x) as [abs | _];[psatzl R | ].
replace (x + h - x) with h by ring; reflexivity.
Qed.

Lemma cv_div2 a : is_lim_seq (fun n => a / 2 ^ n) 0.
Proof.
apply is_lim_seq_mult with a 0.
    now apply is_lim_seq_const.
  apply (is_lim_seq_ext (fun n => (/2) ^ n)).
    now apply: pow_inv.
apply is_lim_seq_geom; rewrite Rabs_right; lt0.
now unfold is_Rbar_mult; simpl; rewrite Rmult_0_r.
Qed.

Lemma filterlim_sqrt_0 : filterlim sqrt (at_right 0) (at_right 0).
Proof.
intros P [eps peps].
assert (ep2 : 0 < eps * eps) by (destruct eps; simpl; lt0).
exists (mkposreal _ ep2); intros y bay y0.
assert (0 < sqrt y) by lt0; apply peps; auto.
change (Rabs (sqrt y - 0) < eps); rewrite -> Rabs_right, Rminus_0_r; try lt0.
replace (pos eps) with (sqrt (eps * eps)); [ |  now rewrite sqrt_square; lt0].
apply sqrt_lt_1_alt; split;[lt0 | ].
change (Rabs (y - 0) < eps * eps) in bay; revert bay.
now rewrite -> Rabs_right, Rminus_0_r; lt0.
Qed.

Lemma int_arcsinh x :
  0 < x -> RInt (fun y => / sqrt (y ^ 2 + x ^ 2)) 0 (sqrt x) =
           arcsinh (/ sqrt x).
Proof.
intros x0; apply is_RInt_unique.
assert (s0 : 0 < sqrt x) by lt0.
assert (heq  : forall y,  /sqrt (y ^ 2 + x ^ 2) =
                   / x * /sqrt ((y / x) ^ 2 + 1)).
intros y; replace (y ^ 2 + x ^ 2) with (x ^ 2 * ((y / x) ^ 2 + 1))
   by (field; lt0).
  now rewrite -> sqrt_mult, sqrt_pow2; try lt0; field; split; lt0.
apply (is_RInt_ext (fun y => / x * / sqrt ((y / x) ^ 2 + 1))).
  now intros; rewrite heq.
evar_last.
  apply: (is_RInt_comp (fun t => / sqrt (t ^ 2 + 1)) (fun y => y / x)
          (fun _ => / x)).
    now intros; apply: ex_derive_continuous; auto_derive; repeat split; lt0.
  now intros z _; split;[auto_derive; lt0 | apply continuous_const].
lazy beta; replace (sqrt x / x) with (/ sqrt x); cycle 1.
  now rewrite <- (sqrt_sqrt x) at 3; try lt0; field; lt0.
replace (0 / x) with 0 by (unfold Rdiv; ring).
rewrite <- (Rminus_0_r (arcsinh _)); rewrite <- arcsinh_0 at 2.
apply is_RInt_unique. apply (is_RInt_derive arcsinh).
  now intros z intz; rewrite is_derive_Reals; apply derivable_pt_lim_arcsinh.
now intros; apply: ex_derive_continuous; auto_derive; repeat split; lt0.
Qed.

Lemma equiv_trans F {FF : Filter F} (f g h : R -> R) :
  F (fun x => g x <> 0) -> F (fun x => h x <> 0) ->
  filterlim (fun x => f x / g x) F (locally 1) ->
  filterlim (fun x => g x / h x) F (locally 1) ->
  filterlim (fun x => f x / h x) F (locally 1).
Proof.
intros g0 h0 fg gh P [eps Peps].
set eps' := Rmin eps 1.
assert (ep' : 0 < eps').
  now apply Rmin_pos;[destruct eps; simpl; assumption | lt0].
assert (ep4 : 0 < eps' / 4) by lt0.
assert (ep1 : eps' <= 1) by now unfold eps'; apply Rmin_r.
assert (fg4 := fg _ (locally_ball _ (mkposreal _ ep4))); simpl in fg4.
assert (gh4 := gh _ (locally_ball _ (mkposreal _ ep4))); simpl in gh4.
unfold filtermap in fg4, gh4;
  assert (fh4 := filter_and _ _ g0
                  (filter_and _ _ h0 (filter_and _ _ fg4 gh4))).
apply filter_imp with (2 := fh4); intros x cx; apply Peps.
change (Rabs (f x / h x - 1) < eps).
apply Rlt_le_trans with eps'; [ | apply Rmin_l].
replace (f x / h x - 1) with ( (f x / g x - 1) + (f x / g x) * (g x / h x - 1));
  cycle 1.
  field; tauto.
replace eps' with (eps'/4 + 3 / 4 * eps') by field.
apply Rle_lt_trans with (1 := Rabs_triang _ _); apply Rplus_lt_compat.
  change (ball 1 (eps' / 4) (f x / g x)); tauto.
apply Rlt_le_trans with (3 * (eps' / 4)); [ | psatzl R].
rewrite Rabs_mult; apply Rmult_le_0_lt_compat; cycle 3.
      change (ball 1 (eps' / 4) (g x / h x)); tauto.
    now apply Rabs_pos.
  now apply Rabs_pos.
replace (f x / g x) with ((f x / g x - 1) + 1) by ring.
change 3 with (1 + 2).
apply Rle_lt_trans with (1 := Rabs_triang _ _); apply Rplus_lt_compat; cycle 1.
  now rewrite Rabs_right; lt0.
apply Rlt_trans with (eps' / 4).
  change (ball 1 (eps' / 4) (f x / g x)); tauto.
now psatzl R.
Qed.

Lemma ln_arcinh_equiv_infty :
  filterlim (fun x => arcsinh x / ln x)
       (Rbar_locally p_infty) (locally 1).
Proof.
assert (gt1 : Rbar_locally p_infty (Rlt 1)) by (now exists 1).
intros P [eps Peps].
set (delta := Rmax (exp (ln 3 / eps)) 1).
exists delta; intros x px; apply Peps.
assert (x1 : 1 < x).
  now apply Rle_lt_trans with (2 := px); unfold delta; apply Rmax_r.
assert (0 < sqrt (x ^ 2 + 1)) by lt0.
assert (0 < ln x).
  now rewrite <- ln_1; apply ln_increasing; auto; psatzl R.
change (Rabs (arcsinh x / ln x - 1) < eps).
rewrite Rabs_right; cycle 1.
  apply Rle_ge, Raux.Rle_0_minus.
  apply Rmult_le_reg_r with (ln x); auto.
  unfold Rdiv; rewrite -> Rmult_1_l, Rmult_assoc, Rinv_l, Rmult_1_r; cycle 1.
    now psatzl R.
  unfold arcsinh; apply Rlt_le, ln_increasing;[psatzl R | ].
  now psatzl R.
apply Rlt_trans with (ln (3 * x) / ln x - 1); cycle 1.
  apply Rmult_lt_reg_r with (ln x); auto; unfold Rdiv.
  rewrite -> Rmult_minus_distr_r, Rmult_1_l, Rmult_assoc, Rinv_l; try psatzl R.
  rewrite -> Rmult_1_r, ln_mult; try psatzl R.
  replace (ln 3 + ln x - ln x) with (ln 3) by ring.
  apply Rmult_lt_reg_l with (/ eps).
    now destruct eps; simpl; lt0.
  rewrite <- Rmult_assoc, Rinv_l, Rmult_1_l;[ | destruct eps; simpl; lt0].
  rewrite <- (ln_exp (_ * _)), Rmult_comm; apply ln_increasing.
    now apply exp_pos.
  now apply Rle_lt_trans with (2 := px), Rmax_l.
apply Rplus_lt_compat_r, Rmult_lt_compat_r;[lt0 | ].
apply ln_increasing;[lt0 | ].
assert (1 < 3 * x ^ 2).
  apply Rle_lt_trans with (x ^ 2).
    replace 1 with (1 ^ 2) at 1 by ring.
    now apply pow_incr; psatzl R.
  assert (0 < x ^ 2) by lt0; psatzl R.
apply Rlt_le_trans with (x + sqrt (x ^ 2 + 3 * x ^ 2)).
  now apply Rplus_lt_compat_l, sqrt_lt_1; lt0.
replace (x ^ 2 + 3 * x ^ 2) with ((2 * x) ^ 2) by ring.
rewrite sqrt_pow2;[psatzl R | lt0].
Qed.

(* standard *)
Lemma sqrt_lt : forall x, 1 < x -> sqrt x < x.
Proof.
intros x x1.
 assert (x0 : 0 < x) by (apply Rlt_trans with (1 := Rlt_0_1)(2 := x1)).
 assert (s0 : 0 < sqrt x) by (apply sqrt_lt_R0; assumption).
 pattern x at 2; rewrite <- sqrt_sqrt;[|apply Rlt_le; assumption].
 pattern (sqrt x) at 1; rewrite <- Rmult_1_l.
 apply Rmult_lt_compat_r;[assumption | ].
 rewrite <- sqrt_1; apply sqrt_lt_1_alt;split;[apply Rlt_le, Rlt_0_1|assumption].
Qed.

Lemma small_taylor_lagrange2 :
  forall f f1 f2 x z, x < z ->
    (forall y, x < y < z -> is_derive f y (f1 y)) ->
    (forall y, x < y < z -> is_derive f1 y (f2 y)) ->
    forall u v, x < u < v -> v < z ->
    exists zeta, u < zeta < v /\
    f v = f u + f1 u * (v - u) + f2 zeta * (v - u)^2/2.
Proof.
intros f f1 f2 x z xz d1 d2 u v xuv vz.
set (delta := Rmin (u - x) (z - v)).
assert (delta0 : 0 < delta).
 unfold delta; apply Rmin_glb_lt; psatzl R.
assert (delta <= u - x) by apply Rmin_l.
assert (delta <= z - v) by apply Rmin_r.
assert (dn : forall y, u <= y <= v ->
             forall k, (k <= 2)%nat -> ex_derive_n f k y).
 intros y xyz [ | [ | [ | k]]]; simpl.
    now trivial.
   intros _; exists (f1 y); apply d1; psatzl R.
  intros _; apply (ex_derive_ext_loc f1).
   exists (mkposreal _ delta0); intros t int; symmetry.
   apply is_derive_unique, d1.
   apply ball_Rabs in int; apply Rabs_def2 in int; simpl in int.
   now unfold minus, plus, opp in int; simpl in int; psatzl R.
  now exists (f2 y); apply d2; psatzl R.
 now lia.
assert (uv : u < v) by psatzl R.
destruct (Taylor_Lagrange f 1 u v uv dn) as [zeta [inzeta qq]].
exists zeta; split; [assumption | rewrite qq].
simpl; replace (1 / 1) with 1 by field; rewrite !Rmult_1_l; rewrite !Rmult_1_r.
replace (Derive (fun y => Derive (fun z => f z) y) zeta) with (f2 zeta).
  replace (Derive (fun y => f y) u) with (f1 u).
    field.
  now symmetry; apply is_derive_unique, d1; psatzl R.
symmetry; apply is_derive_unique.
apply (is_derive_ext_loc f1).
  exists (mkposreal _ delta0); simpl; intros t int.
  apply ball_Rabs in int; apply Rabs_def2 in int; simpl in int.
  unfold minus, plus, opp in int; simpl in int.
  now symmetry; apply is_derive_unique, d1; psatzl R.
apply d2; psatzl R.
Qed.

Lemma Rpower_Rinv x y : 0 < x -> Rpower (/ x) y = / (Rpower x y).
Proof.
intros x0; rewrite <- (Rpower_1 x) at 1; auto; rewrite <- Rpower_Ropp.
now rewrite -> Rpower_mult, <- Ropp_mult_distr_l, Rmult_1_l, Rpower_Ropp.
Qed.

Lemma gt1_imp_sqrt_lt x : 1 < x -> sqrt x < x.
Proof.
intros x1; set (y := x - 1); replace x with (y + 1) by (unfold y; ring).
rewrite <- (sqrt_pow2 (y + 1)) at 2; [ | unfold y; psatzl R].
apply sqrt_lt_1; try (unfold y; lt0).
now rewrite <- (Rmult_1_r (y + 1)) at 1; simpl; apply Rmult_lt_compat_l;
  unfold y; lt0.
Qed.

Lemma is_RInt_gen_at_right_at_point (f : R -> R) (a : R) F {FF : ProperFilter F}
  v :
  locally a (continuous f) -> is_RInt_gen f (at_right a) F v ->
  is_RInt_gen f (at_point a) F v.
Proof.
intros [delta1 pd1].
destruct (pd1 a (ball_center a delta1)
          (ball (f a) (mkposreal _ Rlt_0_1)) (locally_ball _ _)) as
    [delta2 Pd2].
intros intf.
set (M := Rabs (f a) + 1).
assert (M0 : 0 < M) by (assert (t:= Rabs_pos (f a)); unfold M; lra).
assert (close : forall y, y <> a -> ball a delta2 y -> Rabs (f y) < M).
  intros y ay b_y; unfold M.
  replace (f y) with (f a + (f y - f a)) by ring.
  apply Rle_lt_trans with (1 := Rabs_triang _ _).
  now apply Rplus_lt_compat_l, Pd2; auto.
assert (atrd1 : at_right a (ball a delta1)) by (exists delta1; tauto).
assert (exrint_close : forall a', ball a delta1 a' -> ex_RInt f a a').
  intros a' baa'.
  apply (ex_RInt_continuous f); intros z pz; apply pd1.
  destruct (Rle_dec a a') as [aa' | a'a].
    rewrite -> Rmin_left, Rmax_right in pz; auto.
    change (Rabs (z - a) < delta1).
    rewrite Rabs_right; cycle 1.
      destruct pz; lra.
    destruct pz; apply Rle_lt_trans with (a' - a); try lra.
    rewrite <- (Rabs_right (a' - a)); try lra.
    tauto.
  change (Rabs (z - a) < delta1).
  apply Rnot_le_lt in a'a.
  destruct (Rle_dec a z) as [az | za].
    rewrite -> Rmin_right, Rmax_left in pz; destruct pz; try lra.
    rewrite Rabs_right; try lra.
    case delta1; intros; simpl; lra.
  apply Rnot_le_lt in za.
  rewrite -> Rmin_right, Rmax_left in pz; try lra.
  rewrite Rabs_left; [ | lra].
  destruct pz; apply Rle_lt_trans with (a - a'); try lra.
  rewrite <- (Rabs_right (a - a')); try lra.
  now change (ball a' delta1 a); apply ball_sym; tauto.
intros P [eps Peps].
assert (pre_ep2 : 0 < eps / 2 * /M).
  apply Rmult_lt_0_compat;[ | now apply Rinv_0_lt_compat].
  now destruct eps; simpl; lra.
set (ep2 := mkposreal _ pre_ep2).
destruct (intf (ball v (pos_div_2 eps))) as [Q R FQ FR vfi'].
  now apply locally_ball.
exists (eq a) R; auto.
  now easy.
intros x y ax Ry; simpl; rewrite <- ax; clear ax x.
assert (atrd2 : at_right a (ball a delta2)) by (exists delta2; tauto).
assert (atre2 : at_right a (ball a ep2)) by (exists ep2; tauto).
destruct (filter_ex _ (filter_and _ _ atrd1 (filter_and _ _ atrd2
                          (filter_and _ _ FQ atre2)))) as
      [a' Pa'].
assert (ex_RInt f a a') by (apply exrint_close; tauto).
exists (RInt f a y); split; cycle 1.
  apply Peps.
  replace (pos eps) with (eps/2 + M * (eps / 2 * / M)); cycle 1.
    now field; apply Rgt_not_eq.
  apply ball_triangle with (RInt f a' y).
    destruct (vfi' a' y) as [a'y Pa'y]; try tauto.
    now rewrite (is_RInt_unique _ _ _ _ (proj1 Pa'y)); tauto.
  assert (ex_RInt f a' y).
   destruct (vfi' a' y) as [a'y Pa'y]; try tauto; exists a'y; tauto.
  change (Rabs (RInt f a y - RInt f a' y) < M * (eps / 2 * / M)).
  apply Rle_lt_trans with (RInt (fun x => Rabs (f x)) (Rmin a a') (Rmax a a')).
    replace (RInt f a y - RInt f a' y) with (RInt f a a'); cycle 1.
      apply Rplus_eq_reg_r with (RInt f a' y).
      assert (tmp := RInt_Chasles f a a' y); change plus with Rplus in tmp.
      (* BUG: need to figure out how to make ring work without the Rplus_0_r. *)
      now rewrite -> tmp;[symmetry; ring | | ]; auto.
    destruct (Rle_dec a a') as [aa' | a'a].
      rewrite -> Rmin_left, Rmax_right; try lra.
      apply abs_RInt_le; assumption.
    apply Rnot_le_lt in a'a.
    rewrite <- (opp_RInt_swap f), Rabs_Ropp, Rmin_right, Rmax_left; try lra; cycle 1.
      now apply ex_RInt_swap.
    apply abs_RInt_le;[ apply Rlt_le | apply ex_RInt_swap]; assumption.
  apply Rle_lt_trans with (RInt (fun _ => M) (Rmin a a') (Rmax a a')).
  apply RInt_le.
          now apply Rminmax.
        apply (ex_RInt_continuous (fun x => Rabs (f x))).
        rewrite -> Rmin_left, Rmax_right; try apply Rminmax.
        intros z pz; apply continuous_comp;[ | now apply continuous_Rabs].
        apply pd1, Rle_lt_trans with (Rabs (a' - a));[ | tauto].
        unfold abs, minus, plus, opp; simpl.
        destruct (Rle_dec a a') as [aa' | a'a].
          now rewrite -> Rmin_left, Rmax_right in pz; destruct pz;
            try rewrite !Rabs_right; lra.
        rewrite -> Rmin_right, Rmax_left in pz; destruct pz;
          apply Rnot_le_lt in a'a;
          try rewrite (Rabs_left (a' - a)); try lra.
        destruct (Req_dec z a) as [za | nza].
          rewrite -> za,Rplus_opp_r, Rabs_R0; lra.
        now rewrite Rabs_left; lra.
      now apply ex_RInt_const.
    intros z pz; apply Rlt_le, close.
      destruct (Rle_dec a a') as [aa' | a'a].
        now rewrite -> Rmin_left, Rmax_right in pz; destruct pz; lra.
      rewrite -> Rmin_right, Rmax_left in pz; destruct pz;
      now apply Rnot_le_lt in a'a; lra.
    apply Rlt_trans with (Rabs (a' - a));[ | tauto].
    unfold abs, minus, plus, opp; simpl.
    destruct (Rle_dec a a') as [aa' | a'a].
      now rewrite -> Rmin_left, Rmax_right in pz; destruct pz;
        try rewrite !Rabs_right; lra.
    rewrite -> Rmin_right, Rmax_left in pz; destruct pz;
      try rewrite (Rabs_left (a' - a)); apply Rnot_le_lt in a'a; try lra.
    destruct (Req_dec z a) as [za | nza].
      now rewrite -> za,Rplus_opp_r, Rabs_R0; lra.
    now rewrite Rabs_left; lra.
  rewrite -> RInt_const, Rmult_comm.
  apply Rmult_lt_compat_l;[lra | ].
  destruct (Rle_dec a a') as [aa' | a'a].
    rewrite -> Rmax_right, Rmin_left; try lra.
    now rewrite <- (Rabs_right (a' - a));[tauto | lra].
  rewrite -> Rmax_left, Rmin_right; apply Rnot_le_lt in a'a ; try lra.
  replace (a - a') with (- (a' - a)) by ring.
  now rewrite <- (Rabs_left (a' - a)); try lra; tauto.
apply (RInt_correct f).
apply (ex_RInt_Chasles f a a' y); auto.
now destruct (vfi' a' y) as [a'y pa'y]; try tauto; exists a'y.
Qed.


Require Import Sets.
Require Import FunctionalExtensionality.
Require Import ProofIrrelevance.
Require Import Classical.
Include CoqSet.

Definition set := @τ.

Class Theory := {
  B : Type ;
  ident : Type ;
  any_B : B ;
  eq_dec_ident : forall x y : ident, {x = y} + {x <> y} ;
  in_dec_ident : forall (v : ident) (d : set ident), {v ∈ d} + {v ∉ d}
}.

Section theory_defined.

Context {theo : Theory}.

Instance discr_ident : Discr ident := {eq_dec := eq_dec_ident}.

Definition domain : Type := set ident.

Section one_domain.

Variable d : domain.
Definition var := { v : ident | v ∈ d }.
Definition state : Type :=  forall x : {v : ident | v ∈ d}, B.
Definition assertion : Type := set state.
Definition component := assertion.
Definition environment := component.
Record contract : Type := mkContract {A : assertion ; G : assertion}.

Definition state_equiv (s1 : state) (s2 : state) : Prop :=
  forall x : {v : ident | v ∈ d}, s1 x = s2 x.

Theorem state_extensionality : forall (s1 s2 : state),
  state_equiv s1 s2 -> s1 = s2.
Proof.
  unfold state_equiv, state, domain.
  intros.
  extensionality x.
  apply H.
Qed.

Definition satisfies (s : state) (c : contract) : Prop :=
  s ∈ ¬ c.(A) ∪ c.(G).

Definition implements (σ : component) (c : contract) :  Prop :=
  forall s, s  ∈ σ -> satisfies s c.

Notation "σ ⊢ c" := (implements σ c) (at level 70, no associativity).

Definition provides (e : environment) (c : contract) : Prop :=
  e ⊆ c.(A).

Definition saturate (c : contract) : contract :=
  mkContract (c.(A)) (¬ c.(A) ∪ c.(G)).

Notation "# c" := (saturate c) (at level 80, no associativity).

Definition is_saturated (c : contract) : Prop := SubsetEq (¬ c.(A)) (c.(G)).

Definition refines (c1 : contract) (c2 : contract) : Prop :=
  let c1' := saturate c1 in let c2' := saturate c2 in
  (c2'.(A)) ⊆ (c1'.(A)) /\ (c1'.(G)) ⊆ (c2'.(G)).

Notation "c1 ≼ c2" := (refines c1 c2) (at level 70, no associativity).

Definition equiv (c1 : contract) (c2 : contract) : Prop := refines c1 c2 /\ refines c2 c1.

Notation "c1 ≍ c2" := (equiv c1 c2) (at level 70 , no associativity).

Theorem contract_extensionality : forall (c1 c2 : contract), c1 ≍ c2 -> saturate c1 = saturate c2.
Proof.
  intros [a1 g1] [a2 g2].
  unfold equiv, refines, saturate.
  simpl.
  intros.
  f_equal ; apply Eq_extensionality ; apply SubsetEq_Asym ; tauto.
Qed.

Definition compose (c1 c2 : contract) : contract :=
  let c1' := saturate c1 in let c2' := saturate c2 in
  let g := c1'.(G) ∩ c2'.(G) in let a := (c1'.(A) ∩ c2'.(A)) ∪ ¬ g in
  mkContract a g.

Notation "c1 ⊗ c2" := (compose c1 c2) (at level 61, left associativity).

Definition glb (c1 : contract) (c2 : contract) : contract :=
  let c1' := saturate c1 in let c2' := saturate c2 in
  mkContract (c1'.(A) ∪ c2'.(A)) (c1'.(G) ∩ c2'.(G)).

Notation "c1 ⊓ c2" := (glb c1 c2) (at level 61, left associativity).

Definition lub (c1 c2 : contract) : contract :=
  let c1' := saturate c1 in let c2' := saturate c2 in
  mkContract (c1'.(A) ∩ c2'.(A)) (c1'.(G) ∪ c2'.(G)).

Notation "c1 ⊔ c2" := (lub c1 c2) (at level 61, left associativity).

Definition conforms (c : contract) (e : assertion) : Prop :=
  (c.(A) ∩ c.(G)) ⊆ e.

Definition is_consistent (c : contract) : Prop := exists s : state, satisfies s c.

Definition is_compatible (c : contract) : Prop := exists s : state, s ∈ (c.(A)).

Lemma is_satured_sature : forall c : contract, is_saturated (saturate c).
Proof.
  firstorder.
Qed.

Lemma implements_saturate_implements : forall (σ : component) (c : contract),
  σ ⊢ (saturate c) -> σ ⊢ c.
Proof.
  firstorder.
Qed.

Theorem saturate_sound : forall (s : state) (c : contract),
  satisfies s c <-> satisfies s (saturate c).
Proof.
  firstorder.
Qed.

Lemma implements_implements_saturate : forall (σ : component) (c : contract),
  σ ⊢ c -> σ ⊢ (saturate c).
Proof.
  firstorder.
Qed.

Theorem implements_refines_implements : forall (σ : component) (c1 c2 : contract),
  σ ⊢ c1 -> c1 ≼ c2 -> σ ⊢ c2.
Proof.
  firstorder.
Qed.

Theorem provides_refines_provides : forall (e : environment) (c1 c2 : contract),
  provides e c2 -> c1 ≼ c2 -> provides e c1.
Proof.
  firstorder.
Qed.

Theorem implements_refines : forall (c1 c2 : contract),
  (forall σ : component, σ ⊢ c1 -> σ ⊢ c2) ->
  (forall e : environment, provides e c2 -> provides e c1) ->
  c1 ≼ c2.
Proof.
  intros [a1 g1] [a2 g2] H1 H2.
  unfold refines.
  simpl.
  split.
  unfold SubsetEq.
  intros s Hs.
  generalize (H2 {s}).
  unfold provides.
  simpl.
  unfold singleton, add, SubsetEq, In.
  intro Hx.
  apply Hx.
  firstorder.
  rewrite H.
  exact Hs.
  left ; reflexivity.
  unfold SubsetEq.
  intros s Hs.
  generalize (H1 {s}).
  unfold implements.
  simpl.
  unfold singleton, add, SubsetEq, In.
  intro Hx.
  apply Hx.
  intros x [Hxs | Hnul].
  subst.
  exact Hs.
  exfalso.
  exact Hnul.
  left ; reflexivity.
Qed.

Theorem refines_implements : forall (c1 c2 : contract), c1 ≼ c2 ->
  (forall σ : component, σ ⊢ c1 -> σ ⊢ c2) /\
  (forall e : environment, provides e c2 -> provides e c1).
Proof.
  intros c1 c2 Href.
  split.
  intros σ Hσ.
  apply (implements_refines_implements σ c1 c2) ; assumption.
  intros e He.
  apply (provides_refines_provides e c1 c2) ; assumption.
Qed.

Theorem refines_correct : forall (c1 c2 : contract), c1 ≼ c2 <->
  (forall σ : component, σ ⊢ c1 -> σ ⊢ c2) /\
  (forall e : environment, provides e c2 -> provides e c1).
Proof.
  split.
  apply refines_implements.
  intro H; apply implements_refines ; tauto.
Qed.

Theorem refines_refl : forall c1 : contract, c1 ≼ c1.
Proof.
  firstorder.
Qed.

Theorem refines_trans : forall c1 c2 c3 : contract, c1 ≼ c2 -> c2 ≼ c3 -> c1 ≼ c3.
Proof.
  firstorder.
Qed.

Theorem refines_antisym : forall c1 c2 : contract, c1 ≼ c2 -> c2 ≼ c1 -> c1 ≍ c2.
Proof.
  unfold equiv ; auto.
Qed.

Theorem equiv_refl : forall c : contract, c ≍ c.
Proof.
  unfold equiv ; split ; apply refines_refl.
Qed.

Theorem equiv_sym : forall c1 c2 : contract, c1 ≍ c2 -> c2 ≍ c1.
Proof.
  unfold equiv ; tauto.
Qed.

Theorem equiv_trans : forall c1 c2 c3 : contract, c1 ≍ c2 -> c2 ≍ c3 -> c1 ≍ c3.
Proof.
  unfold equiv ; split ; apply refines_trans with (c2 := c2) ; tauto.
Qed.

Theorem saturate_idempotent : forall c : contract, saturate (saturate c) ≍ saturate c.
Proof.
  firstorder.
Qed.

Theorem saturate_satisfies : forall (s : state) (c : contract),
  satisfies s c <-> satisfies s (saturate c).
Proof.
  firstorder.
Qed.

Theorem glb_refines_l : forall c1 c2 : contract, (c1 ⊓ c2) ≼ c2.
Proof.
  firstorder.
Qed.

Theorem glb_refines_r : forall c1 c2 : contract, (c1 ⊓ c2) ≼ c1.
Proof.
  firstorder.
Qed.

Theorem glb_greatest : forall c c1 c2 : contract, c ≼ c1 -> c ≼ c2 -> c ≼ (c1 ⊓ c2).
Proof.
  intros [a g] [a1 g1] [a2 g2].
  unfold refines ; simpl ; split.
  firstorder.
  unfold SubsetEq, inter, union, compl, In in *.
  intro x.
  firstorder.
Qed.

Theorem glb_correct : forall c1 c2 : contract, (c1 ⊓ c2) ≼ c1 /\ (c1 ⊓ c2) ≼ c2 /\
  (forall c, c ≼ c1 -> c ≼ c2 -> c ≼ (c1 ⊓ c2)).
Proof.
  split.
  apply glb_refines_r.
  split.
  apply glb_refines_l.
  intro c.
  apply (glb_greatest c c1 c2).
Qed.

Theorem glb_sym : forall c1 c2 : contract, (c1 ⊓ c2) ≍ (c2 ⊓ c1).
Proof.
  unfold equiv.
  firstorder.
Qed.

Theorem lub_refines_l : forall c1 c2 : contract, c1 ≼ (c1 ⊔ c2).
Proof.
  firstorder.
Qed.

Theorem lub_refines_r : forall c1 c2 : contract, c2 ≼ (c1 ⊔ c2) .
Proof.
  firstorder.
Qed.

Theorem lub_lowest : forall c c1 c2 : contract, c1 ≼ c -> c2 ≼ c -> (c1 ⊔ c2) ≼ c.
Proof.
  firstorder.
Qed.

Theorem lub_sym : forall c1 c2 : contract, (c1 ⊔ c2) ≍ (c2 ⊔ c1).
Proof.
  firstorder.
Qed.

Theorem compose_correct_implements : forall (σ1 σ2 : component) (c1 c2 : contract),
  σ1 ⊢ c1 -> σ2 ⊢ c2 -> σ1 ∩ σ2 ⊢ c1 ⊗ c2.
Proof.
  firstorder.
Qed.

Theorem compose_correct_provides : forall (e1 e2 : environment) (c1 c2 : contract),
  provides e1 c1 -> provides e2 c2 -> provides (e1 ∩ e2) (c1 ⊗ c2).
Proof.
  firstorder.
Qed.

Theorem compose_assumption : forall c1 c2 : contract,
  A (c1 ⊗ c2) ⊆ (c1).(A) ∪ ¬ (c2).(G).
Proof.
  intros [A1 G1] [A2 G2].
  simpl.
  unfold inter, union, compl, SubsetEq, In.
  intro s.
  firstorder.
  classical_right.
  firstorder.
Qed.

Lemma morgan : forall a b : assertion,  ¬ a ∩ ¬ b = ¬ (a ∪ b).
Proof.
  intros.
  apply Eq_extensionality.
  firstorder.
Qed.

Lemma morgan2 : forall a b : assertion, ¬ (a ∩ b) = ¬ a ∪ ¬ b.
Proof.
  intros.
  apply Eq_extensionality.
  split ; try firstorder.
  case classic with (x ∈ a).
  intro.
  right.
  tauto.
  left.
  tauto.
Qed.

Lemma inter_commut_eq : forall s₁ s₂: assertion, s₁ ∩ s₂ = s₂ ∩ s₁.
Proof.
  intros.
  apply Eq_extensionality.
  firstorder.
Qed.

Lemma inter_distrib : forall a b c : assertion, a ∩ (b ∪ c) = (a ∩ b) ∪ (a ∩ c).
Proof.
  intros.
  apply Eq_extensionality.
  firstorder.
Qed.

Lemma inter_anoa : forall a : assertion, a ∩ ¬ a = emptyset.
Proof.
  intros.
  apply Eq_extensionality.
  firstorder.
Qed.

Lemma comp_comp : forall a : assertion, ¬ (¬ a) = a.
Proof.
  intro.
  apply Eq_extensionality.
  split ;
  case classic with (x ∈ a) ; firstorder.
Qed.

Theorem compose_correct : forall (c1 c2 : contract) (σ1 σ2 : component) (e : environment),
  σ1 ⊢ c1 -> σ2 ⊢ c2 -> provides e (c1 ⊗ c2) ->
  (σ1 ∩ σ2 ⊢ c1 ⊗ c2 /\ provides (e ∩ σ2) c1 /\ provides (e ∩ σ1) c2).
Proof.
  intros [A1 G1] [A2 G2].
  unfold compose, implements, provides, satisfies.
  simpl.
  intros.
  split.
  firstorder.
  split.
  apply SubsetEq_Trans with ((A1 ∩ A2 ∪ ¬ ((¬ A1 ∪ G1) ∩ (¬ A2 ∪ G2))) ∩ σ2).
  firstorder.
  apply SubsetEq_Trans with ((A1 ∩ A2 ∪ ¬ ((¬ A1 ∪ G1) ∩ (¬ A2 ∪ G2))) ∩ (¬ A2 ∪ G2)).
  firstorder.
  rewrite inter_commut_eq.
  rewrite inter_distrib.
  rewrite morgan2.
  rewrite inter_distrib.
  rewrite inter_anoa.
  rewrite <- morgan.
  rewrite comp_comp.
  firstorder.
  apply SubsetEq_Trans with ((A1 ∩ A2 ∪ ¬ ((¬ A1 ∪ G1) ∩ (¬ A2 ∪ G2))) ∩ σ1).
  firstorder.
  apply SubsetEq_Trans with ((A1 ∩ A2 ∪ ¬ ((¬ A1 ∪ G1) ∩ (¬ A2 ∪ G2))) ∩ (¬ A1 ∪ G1)).
  firstorder.
  rewrite inter_commut_eq.
  rewrite inter_distrib.
  rewrite morgan2.
  rewrite inter_distrib.
  rewrite inter_anoa.
  rewrite <- morgan.
  rewrite comp_comp.
  firstorder.
Qed.

Lemma inter_idem_eq : forall (a : assertion), a ∩ a = a.
Proof.
  intros.
  apply Eq_extensionality.
  apply inter_idem.
Qed.

Lemma inter_add : forall (s e : state), e  ∈ inter {s} {s} -> e = s.
Proof.
  intros.
  rewrite inter_idem_eq in H.
  generalize H.
  unfold  singleton, add, In, emptyset.
  tauto.
Qed.

Theorem compose_set : forall (c1 c2 c : contract),
  (forall (σ1 σ2 : component) (e : environment), σ1 ⊢ c1 -> σ2 ⊢ c2 -> provides e c ->
  (σ1 ∩ σ2 ⊢ c /\ provides (e ∩ σ2) c1 /\ provides (e ∩ σ1) c2)) ->
  (# c1).(G) ∩ (# c2).(G) ⊆ (# c).(G) /\
  (# c).(A) ∩ (# c2).(G) ⊆ (# c1).(A) /\ (# c).(A) ∩ (# c1).(G) ⊆ (# c2).(A).
Proof.
  intros.
  unfold saturate.
  simpl.
  apply H ; try firstorder.
Qed.

Lemma union_distrib : forall (a b c : assertion), (a ∩ b) ∪ c = (a ∪ c) ∩ (b ∪ c).
Proof.
  intros.
  apply Eq_extensionality.
  firstorder.
Qed.

Lemma union_anoa : forall a : assertion, a ∪ ¬ a = Univ.
Proof.
  intros.
  apply Eq_extensionality.
  split.
  firstorder.
  firstorder.
  case classic with (x ∈ a) ; firstorder.
Qed.

Lemma inter_univ : forall a : assertion, a ∩ Univ = a.
Proof.
  intros.
  apply Eq_extensionality.
  firstorder.
Qed.

Lemma inter_abac : forall (a b c : assertion), a ∩ b ∩ a ∩ c = a ∩ (b ∩ c).
Proof.
  intros.
  apply Eq_extensionality.
  firstorder.
Qed.

Lemma inter_inter_commut : forall (a b c : assertion), a ∩ (b ∩ c) = a ∩ (c ∩ b).
Proof.
  intros.
  apply Eq_extensionality.
  firstorder.
Qed.

Lemma inter_union_abb : forall (a b : assertion), (a ∩ b) ∪ b =  b.
Proof.
  intros.
  apply Eq_extensionality.
  firstorder.
Qed.

Lemma inter_monotonic_lr : forall (a b c d : assertion), a ⊆ b -> c ⊆ d -> a ∩ c ⊆ b ∩ d.
Proof.
  firstorder.
Qed.

Lemma inter_assoc_eq : forall (a b c : assertion), a ∩ b ∩ c = a ∩ (b ∩ c).
Proof.
  intros.
  apply Eq_extensionality.
  firstorder.
Qed.

Theorem compose_lowest : forall (c1 c2 c : contract),
  (forall (σ1 σ2 : component) (e : environment), σ1 ⊢ c1 -> σ2 ⊢ c2 -> provides e c ->
  (σ1 ∩ σ2 ⊢ c /\ provides (e ∩ σ2) c1 /\ provides (e ∩ σ1) c2)) -> c1 ⊗ c2 ≼ c.
Proof.
  intros c1 c2 c H0.
  apply compose_set in H0.
  unfold saturate in H0.
  generalize H0.
  simpl.
  intros [H1 [H2 H3]].
  unfold refines, compose.
  simpl.
  assert (A c ∩ (¬ A c2 ∪ G c2) ∩ A c ∩ (¬ A c1 ∪ G c1) = A c ∩ ((¬ A c1 ∪ G c1) ∩ (¬ A c2 ∪ G c2))).
  rewrite inter_abac.
  rewrite inter_inter_commut.
  reflexivity.
  split.
  apply SubsetEq_Trans with
    ((A c ∩ (¬ A c2 ∪ G c2) ∩ A c ∩ (¬ A c1 ∪ G c1)) ∪ ¬ ((¬ A c1 ∪ G c1) ∩ (¬ A c2 ∪ G c2))).
  rewrite H.
  rewrite union_distrib.
  rewrite union_anoa.
  rewrite inter_univ.
  apply union_monotonic_l.
  apply union_monotonic_lr.
  rewrite inter_assoc_eq.
  apply inter_monotonic_lr ; assumption.
  apply SubsetEq_Refl.
  rewrite <- morgan.
  rewrite comp_comp.
  rewrite inter_union_abb.
  firstorder.
Qed.

End one_domain.

(* Definition extend_assert {d1 d2 : domain} (a1 : assertion d1) : assertion (d1 ∪ d2):= *)
(*     fun (e : state (d1 ∪ d2)) => exists e1 : state d1, e1 ∈ a1 -> *)
(*       forall v : ident, forall (pv12 : v ∈ d1 ∪ d2) (pv1 : v ∈ d1), *)
(*         e (exist _ v pv12) = e1 (exist _ v pv1). *)

Section two_domains.

Context {d1 d2 : domain}.
Variable H12 : d1 ⊆ d2.

Definition H'12 (v1 : var d1) : var d2 := let (i,H1) := v1 in exist _ i (H12 i H1).

Definition project (e2 : state d2) : state d1 :=
  fun v1 => e2 (H'12 v1).

Definition extend_state (e1 : state d1) : assertion d2 :=
  fun e2 => project e2 = e1.

Definition project_assertion_forall (a : assertion d2) : assertion d1 :=
  fun e1 => extend_state e1 ⊆ a.

Definition project_assertion (a : assertion d2) : assertion d1 :=
  fun e1 => exists e2,  e2 ∈ a /\ project e2 = e1.

Definition extend_assertion (a1 : assertion d1) : assertion d2 :=
  fun e2 => project e2 ∈ a1.

Definition extend_state_default (e1 : state d1) : state d2 :=
  fun x => let (v, pd2) := x in match in_dec_ident v d1 with
                                | left in_proof => e1 (exist _ v in_proof)
                                | right _ => any_B
                                end
.

Definition project_contract (c2 : contract d2)  : contract d1 :=
  let c2' := saturate _ c2 in
  mkContract _ (project_assertion_forall (c2'.(A _))) (project_assertion (G _ c2')).

Definition extend_contract (c1 : contract d1) : contract d2 :=
  let c1' := saturate _ c1 in
  mkContract _ (extend_assertion (A _ c1')) (extend_assertion (G _ c1')).

Lemma project_extend_state : forall (e1 : state d1),
  project (extend_state_default e1) = e1.
Proof.
  intros e1.
  unfold extend_state_default, project.
  extensionality x.
  destruct x.
  simpl.
  case (in_dec_ident x d1).
  intro i0.
  cut (i = i0).
  intro H ; rewrite H ; tauto.
  apply proof_irrelevance.
  tauto.
Qed.

Lemma extend_project_1 : forall (a1 : assertion d1),
  a1 ⊆ project_assertion (extend_assertion a1).
Proof.
  intros.
  unfold SubsetEq.
  intros e1 Hea.
  unfold project_assertion, In, extend_assertion.
  exists (extend_state_default e1).
  rewrite project_extend_state.
  tauto.
Qed.

Lemma extend_project_2 : forall (a1 : assertion d1),
  project_assertion (extend_assertion a1) ⊆ a1.
Proof.
  intros a1 e1 [e2 [H1 H2]].
  rewrite <- H2.
  tauto.
Qed.

Lemma extend_project : forall (a1 : assertion d1),
  project_assertion (extend_assertion a1) = a1.
Proof.
  intros a1.
  apply Eq_extensionality.
  apply SubsetEq_Asym.
  apply extend_project_2.
  apply extend_project_1.
Qed.

Lemma extend_project_forall_1 : forall (a1 : assertion d1),
  a1 ⊆ project_assertion_forall (extend_assertion a1).
Proof.
  unfold SubsetEq.
  intros a1 e1 H1.
  unfold project_assertion_forall, In, extend_state, extend_assertion, SubsetEq, In.
  intros  e2 Hr.
  rewrite Hr.
  assumption.
Qed.

Lemma extend_project_forall_2 : forall (a1 : assertion d1),
  project_assertion_forall (extend_assertion a1) ⊆ a1.
Proof.
  intros a1 e1.
  unfold project_assertion_forall, extend_assertion, In.
  cut (exists e2 : state d2, project e2 = e1).
  intros [e2 Hr] Hin.
  rewrite <- Hr.
  apply Hin ; tauto.
  exists (extend_state_default e1).
  apply project_extend_state.
Qed.

Lemma extend_project_forall : forall (a1 : assertion d1),
  project_assertion_forall (extend_assertion a1) = a1.
Proof.
  intros a1.
  apply Eq_extensionality.
  apply SubsetEq_Asym.
  apply extend_project_forall_2.
  apply extend_project_forall_1.
Qed.

Lemma extend_union_1 : forall (a b : assertion d1),
  extend_assertion (a ∪ b) ⊆ extend_assertion a ∪ extend_assertion b.
Proof.
  firstorder.
Qed.

Lemma extend_union_2 : forall (a b : assertion d1),
  extend_assertion a ∪ extend_assertion b ⊆ extend_assertion (a ∪ b).
Proof.
  firstorder.
Qed.

Lemma extend_union : forall (a b : assertion d1),
  extend_assertion a ∪ extend_assertion b = extend_assertion (a ∪ b).
Proof.
  intros a b.
  apply Eq_extensionality.
  apply SubsetEq_Asym.
  apply extend_union_2.
  apply extend_union_1.
Qed.

Lemma extend_neg_1 : forall (a : assertion d1),
  extend_assertion (¬ a) ⊆ ¬ (extend_assertion a).
Proof.
  firstorder.
Qed.

Lemma extend_neg_2 : forall (a : assertion d1),
  ¬ (extend_assertion a) ⊆ extend_assertion (¬ a).
Proof.
  firstorder.
Qed.

Lemma extend_neg : forall (a : assertion d1),
  ¬ (extend_assertion a) = extend_assertion (¬ a).
Proof.
  intros a.
  apply Eq_extensionality.
  apply SubsetEq_Asym.
  apply extend_neg_2.
  apply extend_neg_1.
Qed.

Lemma project_extend_contract : forall (c1 : contract d1),
  (project_contract (extend_contract c1)) = saturate _ c1.
Proof.
  intros[a1 g1].
  unfold project_contract, extend_contract, saturate.
  simpl.
  f_equal.
  apply extend_project_forall.
  rewrite extend_neg, extend_union, extend_project.
  apply Eq_extensionality.
  firstorder.
Qed.

Lemma extend_subset : forall (a b : assertion d1),
  a ⊆ b -> extend_assertion a ⊆ extend_assertion b.
Proof.
  firstorder.
Qed.

Lemma implements_extension : forall (c : contract d1) (σ : component d1),
  implements d1 σ c -> implements d2 (extend_assertion σ) (extend_contract c).
Proof.
  firstorder.
Qed.

End two_domains.

Section three_domains.
Context {d1 d2 d3 : domain}.
Variable H1 : d1 ⊆ d3.
Variable H2 : d2 ⊆ d3.

Definition extended_compose (c1 : contract d1) (c2 : contract d2) : contract d3 :=
  compose _ (extend_contract H1 c1) (extend_contract H2 c2).

Definition refines_extended (c1 : contract d1) (c2: contract d2) : Prop :=
  refines _ (extend_contract H1 c1) (extend_contract H2 c2).

Notation "c1 ≼ c2" := (refines_extended c1 c2) (at level 70, no associativity).

(* Relation d'ordre *)

Definition implements_extended (c1 : contract d1) (σ2 : component d2) : Prop :=
  implements _ (extend_assertion H2 σ2) (extend_contract H1 c1).

Notation "σ ⊢ c" := (implements_extended σ c) (at level 70, no associativity).

Theorem extended_compose_correct : forall (c1 : contract d1) (c2 : contract d2)
  (σ1 : component d1) (σ2 : component d2),
  implements _ σ1 c1 -> implements _ σ2 c2 ->
  implements _ (extend_assertion H1 σ1 ∩ extend_assertion H2 σ2) (extended_compose c1 c2).
Proof.
  intros.
  apply compose_correct_implements.
  apply implements_extension ; exact H.
  apply implements_extension ; assumption.
Qed.

Lemma extend_assertion_refl : forall (a1 : assertion d1),
  extend_assertion (SubsetEq_Refl d1) a1 = a1.
Proof.
  intros a1.
  apply Eq_extensionality.
  unfold Eq.
  unfold extend_assertion, project, In.
  intro e1.
  cut ((fun v1 : {v : ident | d1 v} => e1 (H'12 (SubsetEq_Refl d1) v1)) = e1).
   intros Hr.
   rewrite Hr.
   tauto.
   apply state_extensionality.
   unfold state_equiv.
   intros [v pv].
   f_equal.
   unfold H'12.
   f_equal.
   apply proof_irrelevance.
Qed.

Lemma extension_contract_refl : forall (c1 : contract d1),
  equiv d1 (extend_contract (SubsetEq_Refl d1) c1) c1.
Proof.
  intros [a1 g1].
  unfold equiv, refines, extend_contract.
  simpl.
  rewrite extend_assertion_refl.
  rewrite extend_assertion_refl.
  repeat split ; apply SubsetEq_Refl ; firstorder.
Qed.
End three_domains.

End theory_defined.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(****************************************************************************)
(*                                                                          *)
(*                         Naive Set Theory in Coq                          *)
(*                                                                          *)
(*                     INRIA                        INRIA                   *)
(*              Rocquencourt                        Sophia-Antipolis        *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*				 Gerard Huet				    *)
(*									    *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
(* to the Newton Institute for providing an exceptional work environment    *)
(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
(****************************************************************************)

(*i $Id: Powerset_Classical_facts.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Export Ensembles.
Require Export Constructive_sets.
Require Export Relations_1.
Require Export Relations_1_facts.
Require Export Partial_Order.
Require Export Cpo.
Require Export Powerset.
Require Export Powerset_facts.
Require Export Classical_Type.
Require Export Classical_sets.

Section Sets_as_an_algebra.

  Variable U : Type.

  Lemma sincl_add_x :
    forall (A B:Ensemble U) (x:U),
      ~ In U A x ->
      Strict_Included U (Add U A x) (Add U B x) -> Strict_Included U A B.
  Proof.
    intros A B x H' H'0; red in |- *.
    lapply (Strict_Included_inv U (Add U A x) (Add U B x)); auto with sets.
    clear H'0; intro H'0; split.
    apply incl_add_x with (x := x); tauto.
    elim H'0; intros H'1 H'2; elim H'2; clear H'0 H'2.
    intros x0 H'0.
    red in |- *; intro H'2.
    elim H'0; clear H'0.
    rewrite <- H'2; auto with sets.
  Qed.

  Lemma incl_soustr_in :
    forall (X:Ensemble U) (x:U), In U X x -> Included U (Subtract U X x) X.
  Proof.
    intros X x H'; red in |- *.
    intros x0 H'0; elim H'0; auto with sets.
  Qed.

  Lemma incl_soustr :
    forall (X Y:Ensemble U) (x:U),
      Included U X Y -> Included U (Subtract U X x) (Subtract U Y x).
  Proof.
    intros X Y x H'; red in |- *.
    intros x0 H'0; elim H'0.
    intros H'1 H'2.
    apply Subtract_intro; auto with sets.
  Qed.

  Lemma incl_soustr_add_l :
    forall (X:Ensemble U) (x:U), Included U (Subtract U (Add U X x) x) X.
  Proof.
    intros X x; red in |- *.
    intros x0 H'; elim H'; auto with sets.
    intro H'0; elim H'0; auto with sets.
    intros t H'1 H'2; elim H'2; auto with sets.
  Qed.

  Lemma incl_soustr_add_r :
    forall (X:Ensemble U) (x:U),
      ~ In U X x -> Included U X (Subtract U (Add U X x) x).
  Proof.
    intros X x H'; red in |- *.
    intros x0 H'0; try assumption.
    apply Subtract_intro; auto with sets.
    red in |- *; intro H'1; apply H'; rewrite H'1; auto with sets.
  Qed.
  Hint Resolve incl_soustr_add_r: sets v62.

  Lemma add_soustr_2 :
    forall (X:Ensemble U) (x:U),
      In U X x -> Included U X (Add U (Subtract U X x) x).
  Proof.
    intros X x H'; red in |- *.
    intros x0 H'0; try assumption.
    elim (classic (x = x0)); intro K; auto with sets.
    elim K; auto with sets.
  Qed.

  Lemma add_soustr_1 :
    forall (X:Ensemble U) (x:U),
      In U X x -> Included U (Add U (Subtract U X x) x) X.
  Proof.
    intros X x H'; red in |- *.
    intros x0 H'0; elim H'0; auto with sets.
    intros y H'1; elim H'1; auto with sets.
    intros t H'1; try assumption.
    rewrite <- (Singleton_inv U x t); auto with sets.
  Qed.

  Lemma add_soustr_xy :
    forall (X:Ensemble U) (x y:U),
      x <> y -> Subtract U (Add U X x) y = Add U (Subtract U X y) x.
  Proof.
    intros X x y H'; apply Extensionality_Ensembles.
    split; red in |- *.
    intros x0 H'0; elim H'0; auto with sets.
    intro H'1; elim H'1.
    intros u H'2 H'3; try assumption.
    apply Add_intro1.
    apply Subtract_intro; auto with sets.
    intros t H'2 H'3; try assumption.
    elim (Singleton_inv U x t); auto with sets.
    intros u H'2; try assumption.
    elim (Add_inv U (Subtract U X y) x u); auto with sets.
    intro H'0; elim H'0; auto with sets.
    intro H'0; rewrite <- H'0; auto with sets.
  Qed.

  Lemma incl_st_add_soustr :
    forall (X Y:Ensemble U) (x:U),
      ~ In U X x ->
      Strict_Included U (Add U X x) Y -> Strict_Included U X (Subtract U Y x).
  Proof.
    intros X Y x H' H'0; apply sincl_add_x with (x := x); auto using add_soustr_1 with sets.
    split.
    elim H'0.
    intros H'1 H'2.
    generalize (Inclusion_is_transitive U).
    intro H'4; red in H'4.
    apply H'4 with (y := Y); auto using add_soustr_2 with sets.
    red in H'0.
    elim H'0; intros H'1 H'2; try exact H'1; clear H'0. (* PB *)
    red in |- *; intro H'0; apply H'2.
    rewrite H'0; auto 8 using add_soustr_xy, add_soustr_1, add_soustr_2 with sets.
  Qed.

  Lemma Sub_Add_new :
    forall (X:Ensemble U) (x:U), ~ In U X x -> X = Subtract U (Add U X x) x.
  Proof.
    auto using incl_soustr_add_l with sets.
  Qed.

  Lemma Simplify_add :
    forall (X X0:Ensemble U) (x:U),
      ~ In U X x -> ~ In U X0 x -> Add U X x = Add U X0 x -> X = X0.
  Proof.
    intros X X0 x H' H'0 H'1; try assumption.
    rewrite (Sub_Add_new X x); auto with sets.
    rewrite (Sub_Add_new X0 x); auto with sets.
    rewrite H'1; auto with sets.
  Qed.

  Lemma Included_Add :
    forall (X A:Ensemble U) (x:U),
      Included U X (Add U A x) ->
      Included U X A \/ (exists A' : _, X = Add U A' x /\ Included U A' A).
  Proof.
    intros X A x H'0; try assumption.
    elim (classic (In U X x)).
    intro H'1; right; try assumption.
    exists (Subtract U X x).
    split; auto using incl_soustr_in, add_soustr_xy, add_soustr_1, add_soustr_2 with sets.
    red in H'0.
    red in |- *.
    intros x0 H'2; try assumption.
    lapply (Subtract_inv U X x x0); auto with sets.
    intro H'3; elim H'3; intros K K'; clear H'3.
    lapply (H'0 x0); auto with sets.
    intro H'3; try assumption.
    lapply (Add_inv U A x x0); auto with sets.
    intro H'4; elim H'4;
      [ intro H'5; try exact H'5; clear H'4 | intro H'5; clear H'4 ].
    elim K'; auto with sets.
    intro H'1; left; try assumption.
    red in H'0.
    red in |- *.
    intros x0 H'2; try assumption.
    lapply (H'0 x0); auto with sets.
    intro H'3; try assumption.
    lapply (Add_inv U A x x0); auto with sets.
    intro H'4; elim H'4;
      [ intro H'5; try exact H'5; clear H'4 | intro H'5; clear H'4 ].
    absurd (In U X x0); auto with sets.
    rewrite <- H'5; auto with sets.
  Qed.

  Lemma setcover_inv :
    forall A x y:Ensemble U,
      covers (Ensemble U) (Power_set_PO U A) y x ->
      Strict_Included U x y /\
      (forall z:Ensemble U, Included U x z -> Included U z y -> x = z \/ z = y).
  Proof.
    intros A x y H'; elim H'.
    unfold Strict_Rel_of in |- *; simpl in |- *.
    intros H'0 H'1; split; [ auto with sets | idtac ].
    intros z H'2 H'3; try assumption.
    elim (classic (x = z)); auto with sets.
    intro H'4; right; try assumption.
    elim (classic (z = y)); auto with sets.
    intro H'5; try assumption.
    elim H'1.
    exists z; auto with sets.
  Qed.

  Theorem Add_covers :
    forall A a:Ensemble U,
      Included U a A ->
      forall x:U,
	In U A x ->
	~ In U a x -> covers (Ensemble U) (Power_set_PO U A) (Add U a x) a.
  Proof.
    intros A a H' x H'0 H'1; try assumption.
    apply setcover_intro; auto with sets.
    red in |- *.
    split; [ idtac | red in |- *; intro H'2; try exact H'2 ]; auto with sets.
    apply H'1.
    rewrite H'2; auto with sets.
    red in |- *; intro H'2; elim H'2; clear H'2.
    intros z H'2; elim H'2; intros H'3 H'4; try exact H'3; clear H'2.
    lapply (Strict_Included_inv U a z); auto with sets; clear H'3.
    intro H'2; elim H'2; intros H'3 H'5; elim H'5; clear H'2 H'5.
    intros x0 H'2; elim H'2.
    intros H'5 H'6; try assumption.
    generalize H'4; intro K.
    red in H'4.
    elim H'4; intros H'8 H'9; red in H'8; clear H'4.
    lapply (H'8 x0); auto with sets.
    intro H'7; try assumption.
    elim (Add_inv U a x x0); auto with sets.
    intro H'15.
    cut (Included U (Add U a x) z).
    intro H'10; try assumption.
    red in K.
    elim K; intros H'11 H'12; apply H'12; clear K; auto with sets.
    rewrite H'15.
    red in |- *.
    intros x1 H'10; elim H'10; auto with sets.
    intros x2 H'11; elim H'11; auto with sets.
  Qed.

  Theorem covers_Add :
    forall A a a':Ensemble U,
      Included U a A ->
      Included U a' A ->
      covers (Ensemble U) (Power_set_PO U A) a' a ->
      exists x : _, a' = Add U a x /\ In U A x /\ ~ In U a x.
  Proof.
    intros A a a' H' H'0 H'1; try assumption.
    elim (setcover_inv A a a'); auto with sets.
    intros H'6 H'7.
    clear H'1.
    elim (Strict_Included_inv U a a'); auto with sets.
    intros H'5 H'8; elim H'8.
    intros x H'1; elim H'1.
    intros H'2 H'3; try assumption.
    exists x.
    split; [ try assumption | idtac ].
    clear H'8 H'1.
    elim (H'7 (Add U a x)); auto with sets.
    intro H'1.
    absurd (a = Add U a x); auto with sets.
    red in |- *; intro H'8; try exact H'8.
    apply H'3.
    rewrite H'8; auto with sets.
    auto with sets.
    red in |- *.
    intros x0 H'1; elim H'1; auto with sets.
    intros x1 H'8; elim H'8; auto with sets.
    split; [ idtac | try assumption ].
    red in H'0; auto with sets.
  Qed.

  Theorem covers_is_Add :
    forall A a a':Ensemble U,
      Included U a A ->
      Included U a' A ->
      (covers (Ensemble U) (Power_set_PO U A) a' a <->
	(exists x : _, a' = Add U a x /\ In U A x /\ ~ In U a x)).
  Proof.
    intros A a a' H' H'0; split; intro K.
    apply covers_Add with (A := A); auto with sets.
    elim K.
    intros x H'1; elim H'1; intros H'2 H'3; rewrite H'2; clear H'1.
    apply Add_covers; intuition.
  Qed.

  Theorem Singleton_atomic :
    forall (x:U) (A:Ensemble U),
      In U A x ->
      covers (Ensemble U) (Power_set_PO U A) (Singleton U x) (Empty_set U).
  Proof.
    intros x A H'.
    rewrite <- (Empty_set_zero' U x).
    apply Add_covers; auto with sets.
  Qed.

  Lemma less_than_singleton :
    forall (X:Ensemble U) (x:U),
      Strict_Included U X (Singleton U x) -> X = Empty_set U.
  Proof.
    intros X x H'; try assumption.
    red in H'.
    lapply (Singleton_atomic x (Full_set U));
      [ intro H'2; try exact H'2 | apply Full_intro ].
    elim H'; intros H'0 H'1; try exact H'1; clear H'.
    elim (setcover_inv (Full_set U) (Empty_set U) (Singleton U x));
      [ intros H'6 H'7; try exact H'7 | idtac ]; auto with sets.
    elim (H'7 X); [ intro H'5; try exact H'5 | intro H'5 | idtac | idtac ];
      auto with sets.
    elim H'1; auto with sets.
  Qed.

End Sets_as_an_algebra.

Hint Resolve incl_soustr_in: sets v62.
Hint Resolve incl_soustr: sets v62.
Hint Resolve incl_soustr_add_l: sets v62.
Hint Resolve incl_soustr_add_r: sets v62.
Hint Resolve add_soustr_1 add_soustr_2: sets v62.
Hint Resolve add_soustr_xy: sets v62.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)

Require Import ssreflect.

Variables P G : Prop.

Lemma test1 : (P -> G) -> P -> G.
Proof.
move=> pg p.
have suff {pg} H : P.
  match goal with |- P -> G => move=> _; exact: pg p | _ => fail end.
match goal with H : P -> G |- G => exact: H p | _ => fail end.
Qed.

Lemma test2 : (P -> G) -> P -> G.
Proof.
move=> pg p.
have suffices {pg} H : P.
  match goal with |- P -> G => move=> _; exact: pg p | _ => fail end.
match goal with H : P -> G |- G => exact: H p | _ => fail end.
Qed.

Lemma test3 : (P -> G) -> P -> G.
Proof.
move=> pg p.
suff have {pg} H : P.
  match goal with H : P |- G => exact: pg H | _ => fail end.
match goal with |- (P -> G) -> G => move=> H; exact: H p | _ => fail end.
Qed.

Lemma test4 : (P -> G) -> P -> G.
Proof.
move=> pg p.
suffices have {pg} H: P.
  match goal with H : P |- G => exact: pg H | _ => fail end.
match goal with |- (P -> G) -> G => move=> H; exact: H p | _ => fail end.
Qed.

(*
Lemma test5 : (P -> G) -> P -> G.
Proof.
move=> pg p.
suff have {pg} H : P := pg H.
match goal with |- (P -> G) -> G => move=> H; exact: H p | _ => fail end.
Qed.
*)

(*
Lemma test6 : (P -> G) -> P -> G.
Proof.
move=> pg p.
suff have {pg} H := pg H.
match goal with |- (P -> G) -> G => move=> H; exact: H p | _ => fail end.
Qed.
*)

Lemma test7 : (P -> G) -> P -> G.
Proof.
move=> pg p.
have suff {pg} H : P := pg.
match goal with H : P -> G |- G => exact: H p | _ => fail end.
Qed.

Lemma test8 : (P -> G) -> P -> G.
Proof.
move=> pg p.
have suff {pg} H := pg.
match goal with H : P -> G |- G => exact: H p | _ => fail end.
Qed.

Goal forall x y : bool, x = y -> x = y.
move=> x y E.
by have {x E} -> : x = y by [].
Qed.


(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)
Require Import OrderedType.

(** * An alternative (but equivalent) presentation for an Ordered Type
   inferface. *)

(** NB: [comparison], defined in [Datatypes.v] is [Eq|Lt|Gt]
whereas [compare], defined in [OrderedType.v] is [EQ _ | LT _ | GT _ ]
*)

Module Type OrderedTypeAlt.

 Parameter t : Type.

 Parameter compare : t -> t -> comparison.

 Infix "?=" := compare (at level 70, no associativity).

 Parameter compare_sym :
   forall x y, (y?=x) = CompOpp (x?=y).
 Parameter compare_trans :
   forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c.

End OrderedTypeAlt.

(** From this new presentation to the original one. *)

Module OrderedType_from_Alt (O:OrderedTypeAlt) <: OrderedType.
 Import O.

 Definition t := t.

 Definition eq x y := (x?=y) = Eq.
 Definition lt x y := (x?=y) = Lt.

 Lemma eq_refl : forall x, eq x x.
 Proof.
 intro x.
 unfold eq.
 assert (H:=compare_sym x x).
 destruct (x ?= x); simpl in *; try discriminate; auto.
 Qed.

 Lemma eq_sym : forall x y, eq x y -> eq y x.
 Proof.
 unfold eq; intros.
 rewrite compare_sym.
 rewrite H; simpl; auto.
 Qed.

 Definition eq_trans := (compare_trans Eq).

 Definition lt_trans := (compare_trans Lt).

 Lemma lt_not_eq : forall x y, lt x y -> ~eq x y.
 Proof.
 unfold eq, lt; intros.
 rewrite H; discriminate.
 Qed.

 Definition compare : forall x y, Compare lt eq x y.
 Proof.
 intros.
 case_eq (x ?= y); intros.
 apply EQ; auto.
 apply LT; auto.
 apply GT; red.
 rewrite compare_sym; rewrite H; auto.
 Defined.

 Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }.
 Proof.
 intros; unfold eq.
 case (x ?= y); [ left | right | right ]; auto; discriminate.
 Defined.

End OrderedType_from_Alt.

(** From the original presentation to this alternative one. *)

Module OrderedType_to_Alt (O:OrderedType) <: OrderedTypeAlt.
 Import O.
 Module MO:=OrderedTypeFacts(O).
 Import MO.

 Definition t := t.

 Definition compare x y := match compare x y with
   | LT _ => Lt
   | EQ _ => Eq
   | GT _ => Gt
  end.

 Infix "?=" := compare (at level 70, no associativity).

 Lemma compare_sym :
   forall x y, (y?=x) = CompOpp (x?=y).
 Proof.
 intros x y; unfold compare.
 destruct O.compare; elim_comp; simpl; auto.
 Qed.

 Lemma compare_trans :
   forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c.
 Proof.
 intros c x y z.
 destruct c; unfold compare;
 do 2 (destruct O.compare; intros; try discriminate);
 elim_comp; auto.
 Qed.

End OrderedType_to_Alt.


(** In this file, we show that the monoids in the monoidal category of endofunctors correspond to the monads.

*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.

Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Import BifunctorNotations.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.

Require Import UniMath.CategoryTheory.Monoidal.CategoriesOfMonoids.
Require Import UniMath.Bicategories.MonoidalCategories.EndofunctorsWhiskeredMonoidal.
Require Import UniMath.CategoryTheory.Monads.Monads.

Local Open Scope cat.

Section FixTheContext.

  Context {C : category}.

  Let ENDO : category := cat_of_endofunctors C.
  Let M_ENDO : monoidal ENDO := monoidal_of_endofunctors C.
  Let MON : category := category_of_monoids_in_monoidal_cat M_ENDO.

  Section MonoidToMonadOb.

  Context (M : MON).

  Let x : ENDO := monoid_carrier _ M.
  Let η : ENDO ⟦ monoidal_unit M_ENDO, x ⟧ := monoid_unit _ M.
  Let μ : ENDO ⟦ x ⊗_{M_ENDO} x, x⟧ := monoid_multiplication _ M.

  Definition monoid_to_monad_multiplication : functor_with_μ C.
  Proof.
    exists x.
    exact μ.
  Defined.

  Definition monoid_to_monad_data : Monad_data C.
  Proof.
    exists monoid_to_monad_multiplication.
    exact η.
  Defined.

  Lemma monoid_to_monoid_laws : Monad_laws monoid_to_monad_data.
  Proof.
    repeat split.
    - intro c.
      set (t := monoid_right_unit_law _ M).
      exact (eqtohomot (base_paths _ _ t) c).
    - intro c.
      set (t := monoid_left_unit_law _ M).
      exact (eqtohomot (base_paths _ _ t) c).
    - intro c.
      set (t := monoid_assoc_law _ M).
      refine (! (eqtohomot (base_paths _ _ t) c) @ _).
      etrans.
      1: apply assoc'.
      apply id_left.
  Qed.

  Definition monoid_to_monad : Monad C
    := _ ,, monoid_to_monoid_laws.

End MonoidToMonadOb.

Section MonadToMonoidOb.

  Context (M : Monad C).

  Let x : ENDO := M : functor _ _.
  Let η : ENDO ⟦ monoidal_unit M_ENDO, x ⟧ := η M.
  Let μ : ENDO ⟦ x ⊗_{M_ENDO} x, x⟧ := μ M.

  Definition monad_to_monoid_data : monoid_data M_ENDO x := μ ,, η.

  Lemma monad_to_monoid_laws : monoid_laws M_ENDO monad_to_monoid_data.
  Proof.
    repeat split; apply (nat_trans_eq C); intro c; cbn.
    - apply Monad_law2.
    - apply Monad_law1.
    - rewrite id_left. apply pathsinv0, Monad_law3.
  Qed.

  Definition monad_to_monoid : MON := x ,, monad_to_monoid_data ,, monad_to_monoid_laws.

End MonadToMonoidOb.

  Definition monoid_equiv_monoid : MON ≃ Monad C.
  Proof.
    use weq_iso.
    - apply monoid_to_monad.
    - apply monad_to_monoid.
    - abstract (intro M;
                use total2_paths_f;
                [apply idpath |
                  use total2_paths_f;
                  [apply idpath |
                    apply isaprop_monoid_laws]]).
    - abstract (intro M;
                use total2_paths_f;
                [apply idpath |
                  apply isaprop_Monad_laws]).
  Defined.

Section MonoidToMonadMor.

  Context (M N : MON) (f : M --> N).

  Lemma monoid_to_monad_mor_laws : Monad_Mor_laws (pr1 f : monoid_to_monad M ⟹ monoid_to_monad N).
  Proof.
    split.
    - intro c.
      set (t := pr12 f).
      apply pathsinv0.
      etrans.
      2: { exact (eqtohomot (base_paths _ _ t) c). }
      rewrite (bifunctor_equalwhiskers M_ENDO).
      apply idpath.
    - intro c.
      set (t := pr22 f).
      exact (eqtohomot (base_paths _ _ t) c).
  Qed.

  Definition monoid_to_monad_mor : category_Monad C ⟦monoid_to_monad M, monoid_to_monad N⟧
    := pr1 f ,, monoid_to_monad_mor_laws.

End MonoidToMonadMor.

Section MonadToMonoidMor.

  Context (M N : Monad C) (f : category_Monad C ⟦M, N⟧).

  Lemma monad_to_monoid_mor_laws : pr2 (monad_to_monoid M) -->[ pr1 f] pr2 (monad_to_monoid N).
  Proof.
    split.
    - red.
      rewrite (bifunctor_equalwhiskers M_ENDO).
      apply (nat_trans_eq C); intro c.
      apply pathsinv0, Monad_Mor_μ.
    - apply (nat_trans_eq C); intro c.
      apply Monad_Mor_η.
  Qed.

  Definition monad_to_monoid_mor : monad_to_monoid M --> monad_to_monoid N
    := pr1 f ,, monad_to_monoid_mor_laws.

End MonadToMonoidMor.

End FixTheContext.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

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


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ A D /\ (wd_ B D /\ (wd_ C D /\ (col_ D B C /\ col_ D B A))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.