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

Require Import XRbase.
Require Import XRfunctions.
Require Import XSeqSeries.
Require Import XRtrigo_def.
Require Import XCos_rel.
Require Import Max.
Require Import Omega.

Local Open Scope nat_scope.
Local Open Scope XR_scope.

Definition Majxy (x y:R) (n:nat) : R :=
  Rmax R1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S n) / INR (fact n).

Lemma Majxy_cv_R0 : forall x y:R, Un_cv (Majxy x y) R0.
Proof.
  intros.
  set (C := Rmax R1 (Rmax (Rabs x) (Rabs y))).
  set (C0 := C ^ 4).
  cut (R0 < C).
  intro.
  cut (R0 < C0).
  intro.
  assert (H1 := cv_speed_pow_fact C0).
  unfold Un_cv in H1; unfold R_dist in H1.
  unfold Un_cv; unfold R_dist; intros.
  cut (R0 < eps / C0);
    [ intro
      | unfold Rdiv; apply Rmult_lt_0_compat;
	[ assumption | apply Rinv_0_lt_compat; assumption ] ].
  elim (H1 (eps / C0) H3); intros N0 H4.
  exists N0; intros.
  replace (Majxy x y n) with (C0 ^ S n / INR (fact n)).
  simpl.
  apply Rmult_lt_reg_l with (Rabs (/ C0)).
  apply Rabs_pos_lt.
  apply Rinv_neq_0_compat.
  red; intro; rewrite H6 in H0; elim (Rlt_irrefl _ H0).
  rewrite <- Rabs_mult.
  unfold Rminus; rewrite Rmult_plus_distr_l.
  rewrite Ropp_0; rewrite Rmult_0_r.
  unfold Rdiv; repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l.
  rewrite (Rabs_right (/ C0)).
  rewrite <- (Rmult_comm eps).
  replace (C0 ^ n * / INR (fact n) + R0) with (C0 ^ n * / INR (fact n) - R0).
2:{
unfold Rminus. rewrite Ropp_0.
reflexivity.
}
  unfold Rdiv in H4; apply H4; assumption.
  left; apply Rinv_0_lt_compat; assumption.
  red; intro; rewrite H6 in H0; elim (Rlt_irrefl _ H0).
  unfold Majxy.
  unfold C0.
  rewrite pow_mult.
  unfold C; reflexivity.
  unfold C0; apply pow_lt; assumption.
  apply Rlt_le_trans with R1.
  apply Rlt_0_1.
  unfold C.
  apply RmaxLess1.
Qed.

Lemma reste1_maj :
  forall (x y:R) (N:nat),
    (0 < N)%nat -> Rabs (Reste1 x y N) <= Majxy x y (pred N).
Proof.
  intros.
  set (C := Rmax R1 (Rmax (Rabs x) (Rabs y))).
  unfold Reste1.
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	Rabs
        (sum_f_R0
          (fun l:nat =>
            (-R1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
            x ^ (2 * S (l + k)) *
            ((-R1) ^ (N - l) / INR (fact (2 * (N - l)))) *
            y ^ (2 * (N - l))) (pred (N - k)))) (
	      pred N)).
  apply
    (Rsum_abs
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          (-R1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
          x ^ (2 * S (l + k)) * ((-R1) ^ (N - l) / INR (fact (2 * (N - l)))) *
          y ^ (2 * (N - l))) (pred (N - k))) (pred N)).
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          Rabs
          ((-R1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
            x ^ (2 * S (l + k)) *
            ((-R1) ^ (N - l) / INR (fact (2 * (N - l)))) *
            y ^ (2 * (N - l)))) (pred (N - k))) (
	      pred N)).
  apply sum_Rle.
  intros.
  apply
    (Rsum_abs
      (fun l:nat =>
	(-R1) ^ S (l + n) / INR (fact (2 * S (l + n))) * x ^ (2 * S (l + n)) *
	((-R1) ^ (N - l) / INR (fact (2 * (N - l)))) *
	y ^ (2 * (N - l))) (pred (N - n))).
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          / INR (fact (2 * S (l + k)) * fact (2 * (N - l))) *
          C ^ (2 * S (N + k))) (pred (N - k))) (pred N)).
  apply sum_Rle; intros.
  apply sum_Rle; intros.
  unfold Rdiv; repeat rewrite Rabs_mult.
  do 2 rewrite pow_1_abs.
  do 2 rewrite Rmult_1_l.
  rewrite (Rabs_right (/ INR (fact (2 * S (n0 + n))))).
  rewrite (Rabs_right (/ INR (fact (2 * (N - n0))))).
  rewrite mult_INR.
  rewrite Rinv_mult_distr.
  repeat rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  rewrite <- Rmult_assoc.
  rewrite <- (Rmult_comm (/ INR (fact (2 * (N - n0))))).
  rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  do 2 rewrite <- RPow_abs.
  apply Rle_trans with (Rabs x ^ (2 * S (n0 + n)) * C ^ (2 * (N - n0))).
  apply Rmult_le_compat_l.
  apply pow_le; apply Rabs_pos.
  apply pow_incr.
  split.
  apply Rabs_pos.
  unfold C.
  apply Rle_trans with (Rmax (Rabs x) (Rabs y)); apply RmaxLess2.
  apply Rle_trans with (C ^ (2 * S (n0 + n)) * C ^ (2 * (N - n0))).
  do 2 rewrite <- (Rmult_comm (C ^ (2 * (N - n0)))).
  apply Rmult_le_compat_l.
  apply pow_le.
  apply Rle_trans with R1.
  left; apply Rlt_0_1.
  unfold C; apply RmaxLess1.
  apply pow_incr.
  split.
  apply Rabs_pos.
  unfold C; apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
  apply RmaxLess1.
  apply RmaxLess2.
  right.
  replace (2 * S (N + n))%nat with (2 * (N - n0) + 2 * S (n0 + n))%nat.
  rewrite pow_add.
  apply Rmult_comm.
  apply INR_eq; rewrite plus_INR; do 3 rewrite mult_INR.
  rewrite minus_INR.
  repeat rewrite S_INR; do 2 rewrite plus_INR.
{
  unfold Rminus.
  repeat rewrite Rmult_plus_distr_r.
  repeat rewrite Rmult_plus_distr_l.
  repeat rewrite <- Rplus_assoc.
  repeat rewrite Rmult_1_l.
  repeat rewrite Rmult_1_r.
  repeat apply Rplus_eq_compat_r.

  simpl.
  repeat rewrite Rmult_0_l.
  repeat rewrite Rplus_0_r.
  repeat rewrite Rplus_0_l.
  repeat rewrite Rplus_assoc.
  rewrite (Rplus_comm (-(INR n0))).
  repeat rewrite Rplus_assoc.
  rewrite Rplus_opp_r.
  rewrite Rplus_0_r.
  apply Rplus_eq_compat_l.
  rewrite (Rplus_comm R1).
  repeat rewrite <- Rplus_assoc.
  apply Rplus_eq_compat_r.
  repeat rewrite Rplus_assoc.
  rewrite Rplus_comm.
  repeat rewrite <- Rplus_assoc.
  rewrite Rplus_opp_l.
  rewrite Rplus_0_l.
  reflexivity.

}
  apply le_trans with (pred (N - n)).
  exact H1.
  apply le_S_n.
  replace (S (pred (N - n))) with (N - n)%nat.
  apply le_trans with N.
  apply (fun p n m:nat => plus_le_reg_l n m p) with n.
  rewrite <- le_plus_minus.
  apply le_plus_r.
  apply le_trans with (pred N).
  assumption.
  apply le_pred_n.
  apply le_n_Sn.
  apply S_pred with 0%nat.
  apply plus_lt_reg_l with n.
  rewrite <- le_plus_minus.
  replace (n + 0)%nat with n; [ idtac | ring ].
  apply le_lt_trans with (pred N).
  assumption.
  apply lt_pred_n_n; assumption.
  apply le_trans with (pred N).
  assumption.
  apply le_pred_n.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          / INR (fact (2 * S (l + k)) * fact (2 * (N - l))) * C ^ (4 * N))
        (pred (N - k))) (pred N)).
  apply sum_Rle; intros.
  apply sum_Rle; intros.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat.
  rewrite mult_INR; apply Rmult_lt_0_compat; apply INR_fact_lt_0.
  apply Rle_pow.
  unfold C; apply RmaxLess1.
  replace (4 * N)%nat with (2 * (2 * N))%nat; [ idtac | ring ].
  apply (fun m n p:nat => mult_le_compat_l p n m).
  replace (2 * N)%nat with (S (N + pred N)).
  apply le_n_S.
  apply plus_le_compat_l; assumption.
  rewrite pred_of_minus.
  omega.
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0 (fun l:nat => C ^ (4 * N) * Rsqr (/ INR (fact (S (N + k)))))
        (pred (N - k))) (pred N)).
  apply sum_Rle; intros.
  apply sum_Rle; intros.
  rewrite <- (Rmult_comm (C ^ (4 * N))).
  apply Rmult_le_compat_l.
  apply pow_le.
  left; apply Rlt_le_trans with R1.
  apply Rlt_0_1.
  unfold C; apply RmaxLess1.
  replace (/ INR (fact (2 * S (n0 + n)) * fact (2 * (N - n0)))) with
    (XBinomial.C (2 * S (N + n)) (2 * S (n0 + n)) / INR (fact (2 * S (N + n)))).
  apply Rle_trans with
    (XBinomial.C (2 * S (N + n)) (S (N + n)) / INR (fact (2 * S (N + n)))).
  unfold Rdiv;
    do 2 rewrite <- (Rmult_comm (/ INR (fact (2 * S (N + n))))).
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply C_maj.
  omega.
  right.
  unfold Rdiv; rewrite Rmult_comm.
  unfold XBinomial.C.
  unfold Rdiv; repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l.
  replace (2 * S (N + n) - S (N + n))%nat with (S (N + n)).
  rewrite Rinv_mult_distr.
  unfold Rsqr; reflexivity.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  omega.
  apply INR_fact_neq_0.
  unfold Rdiv; rewrite Rmult_comm.
  unfold XBinomial.C.
  unfold Rdiv; repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l.
  replace (2 * S (N + n) - 2 * S (n0 + n))%nat with (2 * (N - n0))%nat.
  rewrite mult_INR.
  reflexivity.
  omega.
  apply INR_fact_neq_0.
  apply Rle_trans with
    (sum_f_R0 (fun k:nat => INR N / INR (fact (S N)) * C ^ (4 * N)) (pred N)).
  apply sum_Rle; intros.
  rewrite <-
    (scal_sum (fun _:nat => C ^ (4 * N)) (pred (N - n))
      (Rsqr (/ INR (fact (S (N + n)))))).
  rewrite sum_cte.
  rewrite <- Rmult_assoc.
  do 2 rewrite <- (Rmult_comm (C ^ (4 * N))).
  rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  apply pow_le.
  left; apply Rlt_le_trans with R1.
  apply Rlt_0_1.
  unfold C; apply RmaxLess1.
  apply Rle_trans with (Rsqr (/ INR (fact (S (N + n)))) * INR N).
  apply Rmult_le_compat_l.
  apply Rle_0_sqr.
  apply le_INR.
  omega.
  rewrite Rmult_comm; unfold Rdiv; apply Rmult_le_compat_l.
  apply pos_INR.
  apply Rle_trans with (/ INR (fact (S (N + n)))).
  pattern (/ INR (fact (S (N + n)))) at 2; rewrite <- Rmult_1_r.
  unfold Rsqr.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rmult_le_reg_l with (INR (fact (S (N + n)))).
  apply INR_fact_lt_0.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r.
  apply (le_INR 1).
  apply lt_le_S.
  apply INR_lt; apply INR_fact_lt_0.
  apply INR_fact_neq_0.
  apply Rmult_le_reg_l with (INR (fact (S (N + n)))).
  apply INR_fact_lt_0.
  rewrite <- Rinv_r_sym.
  apply Rmult_le_reg_l with (INR (fact (S N))).
  apply INR_fact_lt_0.
  rewrite Rmult_1_r.
  rewrite (Rmult_comm (INR (fact (S N)))).
  rewrite Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r.
  apply le_INR.
  apply fact_le.
  apply le_n_S.
  apply le_plus_l.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  rewrite sum_cte.
  apply Rle_trans with (C ^ (4 * N) / INR (fact (pred N))).
  rewrite <- (Rmult_comm (C ^ (4 * N))).
  unfold Rdiv; rewrite Rmult_assoc; apply Rmult_le_compat_l.
  apply pow_le.
  left; apply Rlt_le_trans with R1.
  apply Rlt_0_1.
  unfold C; apply RmaxLess1.
  cut (S (pred N) = N).
  intro; rewrite H0.
  pattern N at 2; rewrite <- H0.
  do 2 rewrite fact_simpl.
  rewrite H0.
  repeat rewrite mult_INR.
  repeat rewrite Rinv_mult_distr.
  rewrite (Rmult_comm (/ INR (S N))).
  repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_l.
  pattern (/ INR (fact (pred N))) at 2; rewrite <- Rmult_1_r.
  rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rmult_le_reg_l with (INR (S N)).
  apply lt_INR_0; apply lt_O_Sn.
  rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; rewrite Rmult_1_l.
  apply le_INR; apply le_n_Sn.
  apply not_O_INR; discriminate.
  apply not_O_INR.
  red; intro; rewrite H1 in H; elim (lt_irrefl _ H).
  apply not_O_INR.
  red; intro; rewrite H1 in H; elim (lt_irrefl _ H).
  apply INR_fact_neq_0.
  apply not_O_INR; discriminate.
  apply prod_neq_R0.
  apply not_O_INR.
  red; intro; rewrite H1 in H; elim (lt_irrefl _ H).
  apply INR_fact_neq_0.
  symmetry ; apply S_pred with 0%nat; assumption.
  right.
  unfold Majxy.
  unfold C.
  replace (S (pred N)) with N.
  reflexivity.
  apply S_pred with 0%nat; assumption.
Qed.

Lemma reste2_maj :
  forall (x y:R) (N:nat), (0 < N)%nat -> Rabs (Reste2 x y N) <= Majxy x y N.
Proof.
  intros.
  set (C := Rmax R1 (Rmax (Rabs x) (Rabs y))).
  unfold Reste2.
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	Rabs
        (sum_f_R0
          (fun l:nat =>
            (-R1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
            x ^ (2 * S (l + k) + 1) *
            ((-R1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
            y ^ (2 * (N - l) + 1)) (pred (N - k)))) (
	      pred N)).
  apply
    (Rsum_abs
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          (-R1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
          x ^ (2 * S (l + k) + 1) *
          ((-R1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
          y ^ (2 * (N - l) + 1)) (pred (N - k))) (
	    pred N)).
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          Rabs
          ((-R1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
            x ^ (2 * S (l + k) + 1) *
            ((-R1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
            y ^ (2 * (N - l) + 1))) (pred (N - k))) (
	      pred N)).
  apply sum_Rle.
  intros.
  apply
    (Rsum_abs
      (fun l:nat =>
	(-R1) ^ S (l + n) / INR (fact (2 * S (l + n) + 1)) *
	x ^ (2 * S (l + n) + 1) *
	((-R1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
	y ^ (2 * (N - l) + 1)) (pred (N - n))).
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          / INR (fact (2 * S (l + k) + 1) * fact (2 * (N - l) + 1)) *
          C ^ (2 * S (S (N + k)))) (pred (N - k))) (
	    pred N)).
  apply sum_Rle; intros.
  apply sum_Rle; intros.
  unfold Rdiv; repeat rewrite Rabs_mult.
  do 2 rewrite pow_1_abs.
  do 2 rewrite Rmult_1_l.
  rewrite (Rabs_right (/ INR (fact (2 * S (n0 + n) + 1)))).
  rewrite (Rabs_right (/ INR (fact (2 * (N - n0) + 1)))).
  rewrite mult_INR.
  rewrite Rinv_mult_distr.
  repeat rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  rewrite <- Rmult_assoc.
  rewrite <- (Rmult_comm (/ INR (fact (2 * (N - n0) + 1)))).
  rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  do 2 rewrite <- RPow_abs.
  apply Rle_trans with (Rabs x ^ (2 * S (n0 + n) + 1) * C ^ (2 * (N - n0) + 1)).
  apply Rmult_le_compat_l.
  apply pow_le; apply Rabs_pos.
  apply pow_incr.
  split.
  apply Rabs_pos.
  unfold C.
  apply Rle_trans with (Rmax (Rabs x) (Rabs y)); apply RmaxLess2.
  apply Rle_trans with (C ^ (2 * S (n0 + n) + 1) * C ^ (2 * (N - n0) + 1)).
  do 2 rewrite <- (Rmult_comm (C ^ (2 * (N - n0) + 1))).
  apply Rmult_le_compat_l.
  apply pow_le.
  apply Rle_trans with R1.
  left; apply Rlt_0_1.
  unfold C; apply RmaxLess1.
  apply pow_incr.
  split.
  apply Rabs_pos.
  unfold C; apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
  apply RmaxLess1.
  apply RmaxLess2.
  right.
  replace (2 * S (S (N + n)))%nat with
    (2 * (N - n0) + 1 + (2 * S (n0 + n) + 1))%nat.
  repeat rewrite pow_add.
{
simpl (pow _ 1).
repeat rewrite Rmult_1_r.
repeat rewrite Rmult_assoc.
rewrite Rmult_comm.
repeat rewrite Rmult_assoc.
rewrite Rmult_comm.
repeat rewrite Rmult_assoc.
apply Rmult_eq_compat_l.
reflexivity.
}
  omega.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  left; apply Rinv_0_lt_compat.
  apply INR_fact_lt_0.
  left; apply Rinv_0_lt_compat.
  apply INR_fact_lt_0.
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0
        (fun l:nat =>
          / INR (fact (2 * S (l + k) + 1) * fact (2 * (N - l) + 1)) *
          C ^ (4 * S N)) (pred (N - k))) (pred N)).
  apply sum_Rle; intros.
  apply sum_Rle; intros.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat.
  rewrite mult_INR; apply Rmult_lt_0_compat; apply INR_fact_lt_0.
  apply Rle_pow.
  unfold C; apply RmaxLess1.
  replace (4 * S N)%nat with (2 * (2 * S N))%nat; [ idtac | ring ].
  apply (fun m n p:nat => mult_le_compat_l p n m).
  replace (2 * S N)%nat with (S (S (N + N))).
  repeat apply le_n_S.
  apply plus_le_compat_l.
  apply le_trans with (pred N).
  assumption.
  apply le_pred_n.
  ring.
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
	sum_f_R0
        (fun l:nat => C ^ (4 * S N) * Rsqr (/ INR (fact (S (S (N + k))))))
        (pred (N - k))) (pred N)).
  apply sum_Rle; intros.
  apply sum_Rle; intros.
  rewrite <- (Rmult_comm (C ^ (4 * S N))).
  apply Rmult_le_compat_l.
  apply pow_le.
  left; apply Rlt_le_trans with R1.
  apply Rlt_0_1.
  unfold C; apply RmaxLess1.
  replace (/ INR (fact (2 * S (n0 + n) + 1) * fact (2 * (N - n0) + 1))) with
    (XBinomial.C (2 * S (S (N + n))) (2 * S (n0 + n) + 1) /
      INR (fact (2 * S (S (N + n))))).
  apply Rle_trans with
    (XBinomial.C (2 * S (S (N + n))) (S (S (N + n))) /
      INR (fact (2 * S (S (N + n))))).
  unfold Rdiv;
    do 2 rewrite <- (Rmult_comm (/ INR (fact (2 * S (S (N + n)))))).
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply C_maj.
  apply le_trans with (2 * S (S (n0 + n)))%nat.
  replace (2 * S (S (n0 + n)))%nat with (S (2 * S (n0 + n) + 1)).
  apply le_n_Sn.
  ring.
  omega.
  right.
  unfold Rdiv; rewrite Rmult_comm.
  unfold XBinomial.C.
  unfold Rdiv; repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l.
  replace (2 * S (S (N + n)) - S (S (N + n)))%nat with (S (S (N + n))).
  rewrite Rinv_mult_distr.
  unfold Rsqr; reflexivity.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  omega.
  apply INR_fact_neq_0.
  unfold Rdiv; rewrite Rmult_comm.
  unfold XBinomial.C.
  unfold Rdiv; repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l.
  replace (2 * S (S (N + n)) - (2 * S (n0 + n) + 1))%nat with
    (2 * (N - n0) + 1)%nat.
  rewrite mult_INR.
  reflexivity.
  omega.
  apply INR_fact_neq_0.
  apply Rle_trans with
    (sum_f_R0 (fun k:nat => INR N / INR (fact (S (S N))) * C ^ (4 * S N))
      (pred N)).
  apply sum_Rle; intros.
  rewrite <-
    (scal_sum (fun _:nat => C ^ (4 * S N)) (pred (N - n))
      (Rsqr (/ INR (fact (S (S (N + n))))))).
  rewrite sum_cte.
  rewrite <- Rmult_assoc.
  do 2 rewrite <- (Rmult_comm (C ^ (4 * S N))).
  rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  apply pow_le.
  left; apply Rlt_le_trans with R1.
  apply Rlt_0_1.
  unfold C; apply RmaxLess1.
  apply Rle_trans with (Rsqr (/ INR (fact (S (S (N + n))))) * INR N).
  apply Rmult_le_compat_l.
  apply Rle_0_sqr.
  replace (S (pred (N - n))) with (N - n)%nat.
  apply le_INR.
  omega.
  omega.
  rewrite Rmult_comm; unfold Rdiv; apply Rmult_le_compat_l.
  apply pos_INR.
  apply Rle_trans with (/ INR (fact (S (S (N + n))))).
  pattern (/ INR (fact (S (S (N + n))))) at 2; rewrite <- Rmult_1_r.
  unfold Rsqr.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rmult_le_reg_l with (INR (fact (S (S (N + n))))).
  apply INR_fact_lt_0.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r.
  apply (le_INR 1).
  apply lt_le_S.
  apply INR_lt; apply INR_fact_lt_0.
  apply INR_fact_neq_0.
  apply Rmult_le_reg_l with (INR (fact (S (S (N + n))))).
  apply INR_fact_lt_0.
  rewrite <- Rinv_r_sym.
  apply Rmult_le_reg_l with (INR (fact (S (S N)))).
  apply INR_fact_lt_0.
  rewrite Rmult_1_r.
  rewrite (Rmult_comm (INR (fact (S (S N))))).
  rewrite Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r.
  apply le_INR.
  apply fact_le.
  omega.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  rewrite sum_cte.
  apply Rle_trans with (C ^ (4 * S N) / INR (fact N)).
  rewrite <- (Rmult_comm (C ^ (4 * S N))).
  unfold Rdiv; rewrite Rmult_assoc; apply Rmult_le_compat_l.
  apply pow_le.
  left; apply Rlt_le_trans with R1.
  apply Rlt_0_1.
  unfold C; apply RmaxLess1.
  cut (S (pred N) = N).
  intro; rewrite H0.
  do 2 rewrite fact_simpl.
  repeat rewrite mult_INR.
  repeat rewrite Rinv_mult_distr.
  apply Rle_trans with
    (INR (S (S N)) * (/ INR (S (S N)) * (/ INR (S N) * / INR (fact N))) * INR N).
  repeat rewrite Rmult_assoc.
  rewrite (Rmult_comm (INR N)).
  rewrite (Rmult_comm (INR (S (S N)))).
  apply Rmult_le_compat_l.
  repeat apply Rmult_le_pos.
  left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
  left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
  left; apply Rinv_0_lt_compat.
  apply INR_fact_lt_0.
  apply pos_INR.
  apply le_INR.
  apply le_trans with (S N); apply le_n_Sn.
  repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_l.
  apply Rle_trans with (/ INR (S N) * / INR (fact N) * INR (S N)).
  repeat rewrite Rmult_assoc.
  repeat apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply le_INR; apply le_n_Sn.
  rewrite (Rmult_comm (/ INR (S N))).
  rewrite Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; right; reflexivity.
  apply not_O_INR; discriminate.
  apply not_O_INR; discriminate.
  apply not_O_INR; discriminate.
  apply INR_fact_neq_0.
  apply not_O_INR; discriminate.
  apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
  symmetry ; apply S_pred with 0%nat; assumption.
  right.
  unfold Majxy.
  unfold C.
  reflexivity.
Qed.

Lemma reste1_cv_R0 : forall x y:R, Un_cv (Reste1 x y) R0.
Proof.
  intros.
  assert (H := Majxy_cv_R0 x y).
  unfold Un_cv in H; unfold R_dist in H.
  unfold Un_cv; unfold R_dist; intros.
  elim (H eps H0); intros N0 H1.
  exists (S N0); intros.
  unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r.
  apply Rle_lt_trans with (Rabs (Majxy x y (pred n))).
  rewrite (Rabs_right (Majxy x y (pred n))).
  apply reste1_maj.
  apply lt_le_trans with (S N0).
  apply lt_O_Sn.
  assumption.
  unfold Majxy.
  unfold Rdiv; apply Rmult_le_pos.
  apply pow_le.
  apply Rle_trans with R1.
  left; apply Rlt_0_1.
  apply RmaxLess1.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  replace (Majxy x y (pred n)) with (Majxy x y (pred n) - R0).
2:{
unfold Rminus. rewrite Ropp_0. rewrite Rplus_0_r. reflexivity.
}
  apply H1.
  unfold ge; apply le_S_n.
  replace (S (pred n)) with n.
  assumption.
  apply S_pred with 0%nat.
  apply lt_le_trans with (S N0); [ apply lt_O_Sn | assumption ].
Qed.

Lemma reste2_cv_R0 : forall x y:R, Un_cv (Reste2 x y) R0.
Proof.
  intros.
  assert (H := Majxy_cv_R0 x y).
  unfold Un_cv in H; unfold R_dist in H.
  unfold Un_cv; unfold R_dist; intros.
  elim (H eps H0); intros N0 H1.
  exists (S N0); intros.
  unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r.
  apply Rle_lt_trans with (Rabs (Majxy x y n)).
  rewrite (Rabs_right (Majxy x y n)).
  apply reste2_maj.
  apply lt_le_trans with (S N0).
  apply lt_O_Sn.
  assumption.
  unfold Majxy.
  unfold Rdiv; apply Rmult_le_pos.
  apply pow_le.
  apply Rle_trans with R1.
  left; apply Rlt_0_1.
  apply RmaxLess1.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  replace (Majxy x y n) with (Majxy x y n - R0).
2:{ unfold Rminus. rewrite Ropp_0. rewrite Rplus_0_r. reflexivity. }
  apply H1.
  unfold ge; apply le_trans with (S N0).
  apply le_n_Sn.
  exact H2.
Qed.

Lemma reste_cv_R0 : forall x y:R, Un_cv (Reste x y) R0.
Proof.
  intros.
  unfold Reste.
  set (An := fun n:nat => Reste2 x y n).
  set (Bn := fun n:nat => Reste1 x y (S n)).
  cut
    (Un_cv (fun n:nat => An n - Bn n) (R0 - R0) ->
      Un_cv (fun N:nat => Reste2 x y N - Reste1 x y (S N)) R0).
  intro.
  apply H.
  apply CV_minus.
  unfold An.
  replace (fun n:nat => Reste2 x y n) with (Reste2 x y).
  apply reste2_cv_R0.
  reflexivity.
  unfold Bn.
  assert (H0 := reste1_cv_R0 x y).
  unfold Un_cv in H0; unfold R_dist in H0.
  unfold Un_cv; unfold R_dist; intros.
  elim (H0 eps H1); intros N0 H2.
  exists N0; intros.
  apply H2.
  unfold ge; apply le_trans with (S N0).
  apply le_n_Sn.
  apply le_n_S; assumption.
  unfold An, Bn.
  intro.
  replace R0 with (R0 - R0).
2:{
unfold Rminus. rewrite Ropp_0. rewrite Rplus_0_r. reflexivity.
}
  exact H.
Qed.

Theorem cos_plus : forall x y:R, cos (x + y) = cos x * cos y - sin x * sin y.
Proof.
  intros.
  cut (Un_cv (C1 x y) (cos x * cos y - sin x * sin y)).
  cut (Un_cv (C1 x y) (cos (x + y))).
  intros.
  apply UL_sequence with (C1 x y); assumption.
  apply C1_cvg.
  unfold Un_cv; unfold R_dist.
  intros.
  assert (H0 := A1_cvg x).
  assert (H1 := A1_cvg y).
  assert (H2 := B1_cvg x).
  assert (H3 := B1_cvg y).
  assert (H4 := CV_mult _ _ _ _ H0 H1).
  assert (H5 := CV_mult _ _ _ _ H2 H3).
  assert (H6 := reste_cv_R0 x y).
  unfold Un_cv in H4; unfold Un_cv in H5; unfold Un_cv in H6.
  unfold R_dist in H4; unfold R_dist in H5; unfold R_dist in H6.
  cut (R0 < eps / R3).
  intro.
2:{
      unfold Rdiv; apply Rmult_lt_0_compat.
assumption.
apply Rinv_0_lt_compat. exact Rlt_0_3.
}
  elim (H4 (eps / R3) H7); intros N1 H8.
  elim (H5 (eps / R3) H7); intros N2 H9.
  elim (H6 (eps / R3) H7); intros N3 H10.
  set (N := S (S (max (max N1 N2) N3))).
  exists N.
  intros.
  cut (n = S (pred n)).
  intro; rewrite H12.
  rewrite <- cos_plus_form.
  rewrite <- H12.
  apply Rle_lt_trans with
    (Rabs (A1 x n * A1 y n - cos x * cos y) +
      Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n))).
  replace
    (A1 x n * A1 y n - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n) -
      (cos x * cos y - sin x * sin y)) with
    (A1 x n * A1 y n - cos x * cos y +
      (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n))).
2:{
unfold Rminus.
repeat rewrite Rplus_assoc.
apply Rplus_eq_compat_l.
rewrite Ropp_plus_distr.
rewrite Ropp_involutive.
symmetry.
rewrite Rplus_comm.
repeat rewrite Rplus_assoc.
rewrite Rplus_comm.
repeat rewrite Rplus_assoc.
apply Rplus_eq_compat_l.
reflexivity.
}
    apply Rabs_triang.
  replace eps with (eps / R3 + (eps / R3 + eps / R3)).
  apply Rplus_lt_compat.
  apply H8.
  unfold ge; apply le_trans with N.
  unfold N.
  apply le_trans with (max N1 N2).
  apply le_max_l.
  apply le_trans with (max (max N1 N2) N3).
  apply le_max_l.
  apply le_trans with (S (max (max N1 N2) N3)); apply le_n_Sn.
  assumption.
  apply Rle_lt_trans with
    (Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n)) +
      Rabs (Reste x y (pred n))).
  apply Rabs_triang.
  apply Rplus_lt_compat.
  rewrite <- Rabs_Ropp.
  rewrite Ropp_minus_distr.
  apply H9.
  unfold ge; apply le_trans with (max N1 N2).
  apply le_max_r.
  apply le_S_n.
  rewrite <- H12.
  apply le_trans with N.
  unfold N.
  apply le_n_S.
  apply le_trans with (max (max N1 N2) N3).
  apply le_max_l.
  apply le_n_Sn.
  assumption.
  replace (Reste x y (pred n)) with (Reste x y (pred n) - R0).
  apply H10.
  unfold ge.
  apply le_S_n.
  rewrite <- H12.
  apply le_trans with N.
  unfold N.
  apply le_n_S.
  apply le_trans with (max (max N1 N2) N3).
  apply le_max_r.
  apply le_n_Sn.
  assumption.
{
unfold Rminus. rewrite Ropp_0. rewrite Rplus_0_r. reflexivity.
}
  pattern eps at 4; replace eps with (R3 * (eps / R3)).
  rewrite <- Rplus_assoc.
  rewrite split_3.
  unfold Rdiv.
  rewrite Rmult_comm.
  rewrite Rmult_assoc.
  rewrite Rinv_l.
  rewrite Rmult_1_r.
  reflexivity.
  exact Neq_3_0.
  unfold Rdiv.
  rewrite <- Rmult_assoc.
  apply Rinv_r_simpl_m.
  exact Neq_3_0.
  apply lt_le_trans with (pred N).
  unfold N; simpl; apply lt_O_Sn.
  apply le_S_n.
  rewrite <- H12.
  replace (S (pred N)) with N.
  assumption.
  unfold N; simpl; reflexivity.
  cut (0 < N)%nat.
  intro.
  cut (0 < n)%nat.
  intro.
  apply S_pred with 0%nat; assumption.
  apply lt_le_trans with N; assumption.
  unfold N; apply lt_O_Sn.
Qed.


Require Import equiv.
Require Import register_type after.

Lemma afterR_well_defined :
  forall phi b,
    is_equiv_rel phi -> lat phi |= b ->
  forall j,
    ~((exists l1, phi (X j) (X' l1) /\ b l1) /\
       exists l2, ~(phi (X j) (X' l2) <-> b l2)).
Proof.
  intros phi b phi_equiv lat_phi_b j.
  destruct phi_equiv as [eqref [eqsym eqtran]].
  intros [[l1 [pjl1 bl1]] [l2 H2]].
  apply lat_phi_b in bl1.
  apply H2.
  split; intros H.
  - apply bl1.
    apply eqsym in pjl1.
    apply (eqtran _ (X j) _).
    auto.
  - apply bl1 in H.
    apply (eqtran _ (X' l1) _).
    auto.
Qed.

(* another representation of the above lemma *)
Lemma afterR_well_defined'1 :
  forall phi b,
    is_equiv_rel phi -> lat phi |= b ->
  forall j,
    (exists l1, phi (X j) (X' l1) /\ b l1) ->
     forall l2, phi (X j) (X' l2) <-> b l2.
Proof.
  intros phi b phi_equiv lat_phi_b j.
  intros el1 l2.
  destruct phi_equiv as [_ [eqsym eqtran]].
  destruct el1 as [l1 [pjl1 bl1]].
  apply lat_phi_b in bl1.
  split; intros H.
  - apply bl1.
    apply eqsym in pjl1.
    apply (eqtran _ (X j) _).
    auto.
  - apply bl1 in H.
    apply (eqtran _ (X' l1) _).
    auto.
Qed.

Lemma afterR_well_defined'2 :
   forall phi b,
    is_equiv_rel phi -> lat phi |= b ->
  forall j,
    (exists l1, ~ (phi (X j) (X' l1) <-> b l1)) ->
     forall l2, ~ (phi (X j) (X' l2) /\ b l2).
Proof.
  intros phi b phi_equiv lat_phi_b j.
  intros el1 l2 [pjl2 bl2].
  destruct phi_equiv as [_ [eqsym eqtran]].
  apply lat_phi_b in bl2.
  unfold lat in bl2.
  destruct el1 as [l1 npjl1].
  apply npjl1.
  split; intros H.
  - apply bl2.
    apply eqsym in pjl2.
    apply (eqtran _ (X j) _).
    auto.
  - apply bl2 in H.
    apply (eqtran _ (X' l2) _).
    auto.
Qed.

Lemma afterR_exists_core' :
  forall (theta theta' : assignment) d b,
    (theta, d) |= b ->
    forall j l, (theta' j = theta l /\ b l -> theta' j = d) /\
             (~ (theta' j = theta l <-> b l) -> theta' j <> d).
Proof.
  intros theta theta' d b theta_d_b.
  intros j l.
  split.
  - intros [theta_jl bl].
    rewrite theta_jl.
    apply theta_d_b.
    assumption.
  - intros thjl_neq_bl th'j_d.
    apply thjl_neq_bl.
    split; intros H.
    + apply theta_d_b.
      rewrite <- H. assumption.
    + rewrite th'j_d.
      apply theta_d_b in H.
      auto.
Qed.

Lemma afterR_exists_core :
  forall (phi phi' : Rel) theta theta' b d,
    (theta', theta) |= phi ->
    (theta, d) |= b ->
    forall i : nat,
      (theta', update theta i d) |= phi' ->
        forall j l, (phi (X j) (X' l) /\ b l -> phi' (X j) (X' i)) /\
                 (~ (phi (X j) (X' l) <-> b l) -> ~ phi' (X j) (X' i)).
Proof.
  intros phi phi' theta theta' b d;
  intros theta_phi theta_d_b i theta_phi'.
  intros j l.
  split.
  - intros [pjl bl].
    apply theta_phi'.
    apply theta_phi in pjl.
    unfold update.
    rewrite <- beq_nat_refl.
    rewrite pjl.
    apply theta_d_b. assumption.
  - intros pjl_neq_bl p'ji.
    apply pjl_neq_bl.
    apply theta_phi' in p'ji.
    unfold update in p'ji.
    rewrite <- beq_nat_refl in p'ji.
    split; intros H.
    + apply theta_d_b.
      apply theta_phi in H.
      rewrite <- H.
      assumption.
    + apply theta_phi.
      apply theta_d_b in H.
      rewrite H.
      assumption.
Qed.

Lemma deriv_implies_afterR :
  forall phi phi' theta theta' b i d,
    (theta', theta) |= phi ->
    (theta, d) |= b ->
    (theta', update theta i d) |= phi' ->
      afterR phi b i phi'.
Proof.
  intros phi phi' theta theta' b i d;
  intros theta_phi theta_d_b theta_phi'.
  unfold afterR.
  repeat split. (* many cases *)
  - (* former phi' = former phi *)
    apply rel_extensionality.
    intros x y.
    split; intros H.
  + (* -> *)
    case x, y; try auto.
    { apply theta_phi.
      apply theta_phi' in H.
      assumption. }
  + (* <- *)
    case x, y; try auto.
    { apply theta_phi'.
      apply theta_phi in H.
      assumption. }
  - (* lat phi' = after (lat phi) b i *)
    apply rel_extensionality.
    intros x y.
    split; intros H.
  + (* -> *)
    case x, y; try auto.
    { unfold after.
      unfold lat in H.
      apply theta_phi' in H.
      unfold update in H.
      case_eq (i0 =? i); intros i0i.
      - rewrite i0i in H.
        case_eq (i1 =? i); intros i1i.
      + right. apply beq_nat_true. assumption.
      + rewrite i1i in H.
        symmetry in H.
        apply theta_d_b in H. auto.
      - rewrite i0i in H.
        case_eq (i1 =? i); intros i1i.
      + rewrite i1i in H.
        apply theta_d_b in H. assumption.
      + rewrite i1i in H.
        unfold lat.
        apply theta_phi. assumption. }
  + (* <- *)
    case x, y; try auto.
    { unfold lat.
      apply theta_phi'.
      unfold update.
      unfold after in H.
      case_eq (i0 =? i); intros i0i.
    - rewrite i0i in H.
      case_eq (i1 =? i); intros i1i.
    + reflexivity.
    + destruct H as [H | H].
    * symmetry. apply theta_d_b. assumption.
    * apply beq_nat_false in i1i. contradiction.
    - rewrite i0i in H.
      case_eq (i1 =? i); intros i1i.
    + rewrite i1i in H.
      apply theta_d_b in H. assumption.
    + rewrite i1i in H.
      unfold lat in H.
      apply theta_phi in H. assumption. }
  - (* phi (X j) (X' l) /\ b l <-> phi' (X j) (X' i) *)
    apply (afterR_exists_core _ _ _ _ _ _ theta_phi theta_d_b _ theta_phi').
  - apply (afterR_exists_core _ _ _ _ _ _ theta_phi theta_d_b _ theta_phi').
  - (* phi (X j) (X' l) <-> phi' (X j) (X' l) *)
    case_eq (l =? i); intros li.
  + apply beq_nat_true in li. contradiction.
  + intros phi_jl.
    apply theta_phi'.
    unfold update.
    rewrite li.
    apply theta_phi.
    assumption.
  - case_eq (l =? i); intros li.
  + apply beq_nat_true in li. contradiction.
  + intros phi'_jl.
    apply theta_phi' in phi'_jl.
    unfold update in phi'_jl.
    rewrite li in phi'_jl.
    apply theta_phi.
    assumption.
  - intros H0.
    apply theta_phi'.
    apply theta_phi' in H0.
    symmetry; assumption.
  - intros H0.
    apply theta_phi'.
    apply theta_phi' in H0.
    symmetry; assumption.
Qed.

Lemma lat_phi_after :
  forall phi phi' b i,
  is_equiv_rel phi ->
  lat phi |= b ->
  afterR phi b i phi' ->
    lat phi' = after (lat phi) b i.
Proof.
  intros phi phi' b i phi_equiv lat_phi_b phi'_afterR.
  destruct phi'_afterR as [fo [la [Ha Ha']]].
  apply rel_extensionality.
  unfold lat; unfold after.
  case x, y; try reflexivity.
- case_eq (i0 =? i); case_eq (i1 =? i); intros i1i i0i.
+ apply beq_nat_true in i0i;
  apply beq_nat_true in i1i.
  rewrite i0i; rewrite i1i.
  split; intros H.
* right; reflexivity.
* rewrite <- elim_lat.
  rewrite la.
  assert (after_eq: is_equiv_rel (after (lat phi) b i)).
  { apply (after_is_equiv_rel (lat phi) b i).
  - apply lat_phi_is_equiv_rel. assumption.
  - assumption.
  }
  apply (equiv_rel_refl (after (lat phi) b i)).
  assumption.
+ apply beq_nat_true in i0i.
  rewrite i0i.
  split; intros H.
* rewrite <- elim_lat in H.
  rewrite la in H.
  unfold after in H.
  rewrite <- beq_nat_refl in H.
  exact H.
* rewrite <- elim_lat.
  rewrite la.
  unfold after.
  rewrite <- beq_nat_refl.
  exact H.
+ apply beq_nat_true in i1i.
  rewrite i1i.
  split; intros H.
* rewrite <- elim_lat in H.
  rewrite la in H.
  unfold after in H.
  rewrite i0i in H.
  rewrite <- beq_nat_refl in H.
  exact H.
* rewrite <- elim_lat.
  rewrite la.
  unfold after.
  rewrite i0i.
  rewrite <- beq_nat_refl.
  exact H.
+ split; intros H.
* rewrite <- elim_lat in H.
  rewrite la in H.
  unfold after in H.
  rewrite i0i in H; rewrite i1i in H.
  rewrite elim_lat in H.
  exact H.
* rewrite <- elim_lat.
  rewrite la.
  unfold after.
  rewrite i0i; rewrite i1i.
  rewrite elim_lat.
  exact H.
Qed.

Lemma afterR_implies_deriv :
  classic ->
  forall phi phi' theta theta' b,
    is_equiv_rel phi -> is_equiv_rel phi' ->
    (theta', theta) |= phi ->
    lat phi |= b ->
  forall i : nat,
    afterR phi b i phi' ->
  exists d : D, (theta, d) |= b /\ (theta', update theta i d) |= phi'.
Proof.
  intros Classic.
  intros phi phi' theta theta' b;
  intros phi_equiv phi'_equiv theta_phi lat_phi_b;
  intros i phi'_in_after.
  unfold afterR in phi'_in_after.
  destruct phi'_in_after as [fo [la [Hi [Ho Htran]]]].
  destruct phi_equiv  as [_ [phi_sym _]].
  destruct phi'_equiv as [phi'_refl [phi'_sym phi'_tran]].
  assert (phi_phi': forall i j, phi (X i) (X j) <-> phi' (X i) (X j)).
  {
    intros l j.
    split; intros H.
    - rewrite <- elim_former.
      rewrite fo.
      rewrite -> elim_former. assumption.
    - rewrite <- elim_former.
      rewrite <- fo.
      rewrite -> elim_former. assumption.
  }
  destruct (b_is_empty_or_not b) as [b_empty | [j bj]].
  - (* b_empty: forall i, ~ b i *)
    destruct (phi_ji_or_not Classic phi' i) as [[j phi'_ji] | not_phi'_ji].
  + (* phi'_ji: phi' (X j) (X' i) *)
    exists (theta' j).
    split.
  * (* theta, theta' j) |= b *)
    unfold models. unfold assignmentD_models_guard.
    intros l.
    split; intros H.
  -- (* theta l = theta' j -> b l *)
    apply theta_phi in H.
    destruct (Hi j l) as [_ Hi1].
    elim Hi1.
  ++ (* ~ (phi (X j) (X' l) <-> b l) *)
    intros pjl_bl.
    apply phi_sym in H.
    rewrite pjl_bl in H.
    apply b_empty in H. contradiction.
  ++ (* phi' (X j) (X' i) *)
    assumption.
  -- (* b l -> theta l = theta' j *)
    apply b_empty in H. contradiction.

  * (* (theta', update theta i (theta' j)) |= phi' *)
    unfold models. unfold two_assignments_model_rel.
    intros i0 j0.
    split.
  { (* theta' i0 = theta' j0 <-> phi' (X i0) (X j0) *)
    split; intros H.
  - (* -> *)
    apply theta_phi in H.
    apply phi_phi'. assumption.
  - (* <- *)
    apply theta_phi.
    apply phi_phi'. assumption.
  }
  split.
  { (* update theta i (theta' j) i0 = update theta i (theta' j) j0
       <-> phi' (X' i0) (X' j0) *)
    unfold update.
    split; intros H.
  - (* -> *)
    rewrite <- elim_lat.
    rewrite la.
    unfold after.
    case_eq (i0 =? i); intros i0i.
  + case_eq (j0 =? i); intros j0i.
  * right. apply beq_nat_true. assumption.
  * rewrite i0i in H. rewrite j0i in H.
    apply theta_phi in H.
    destruct (Hi j j0) as [_ Hi1].
    elim Hi1.
      intros pjj0_bj0.
      apply pjj0_bj0 in H.
      apply b_empty in H. contradiction.
    assumption.
  + rewrite i0i in H.
    case_eq (j0 =? i); intros j0i.
  * rewrite j0i in H.
    apply theta_phi in H.
    apply phi_sym in H.
    destruct (Hi j i0) as [_ Hi1].
    elim Hi1.
      intros pji0_bi0.
      apply pji0_bi0 in H.
      apply b_empty in H. contradiction.
    assumption.
  * rewrite j0i in H.
    unfold lat.
    apply theta_phi.
    assumption.
  - (* <- *)
    rewrite <- elim_lat in H.
    rewrite la in H.
    unfold after in H.
    case_eq (i0 =? i); intros i0i.
  + case_eq (j0 =? i); intros j0i.
  * reflexivity.
  * rewrite i0i in H.
    destruct H as [H | H].
      apply b_empty in H. contradiction.
    apply beq_nat_false in j0i. contradiction.
  + rewrite i0i in H.
    case_eq (j0 =? i); intros j0i.
  * rewrite j0i in H.
    apply b_empty in H. contradiction.
  * rewrite j0i in H.
    unfold lat in H.
    apply theta_phi. assumption.
  }
  split.
  { (* theta' i0 = update theta i (theta' j) j0 <-> phi' (X i0) (X' j0) *)
    split; intros H.
  - (* -> *)
    unfold update in H.
    case_eq (j0 =? i); intros j0i.
  + rewrite j0i in H.
    apply beq_nat_true in j0i.
    rewrite j0i.
    apply theta_phi in H.
    apply phi_phi' in H.
    apply (phi'_tran _ (X j) _).
    auto.
  + rewrite j0i in H.
    apply theta_phi in H.
    apply Ho.
      apply beq_nat_false. assumption.
    assumption.
  - (* <- *)
    unfold update.
    case_eq (j0 =? i); intros j0i.
  + apply theta_phi.
    apply phi_phi'.
    apply (phi'_tran _ (X' i) _).
    apply beq_nat_true in j0i.
    rewrite j0i in H.
    apply phi'_sym in phi'_ji.
    auto.
  + apply theta_phi.
    apply Ho.
      apply beq_nat_false. assumption.
    assumption.
  }
  { (* update theta i (theta' j) i0 = theta' j0 <-> phi' (X' i0) (X j0) *)
    split; intros H.
  - (* -> *)
    unfold update in H.
    case_eq (i0 =? i); intros i0i.
  + rewrite i0i in H.
    apply beq_nat_true in i0i.
    rewrite i0i.
    apply theta_phi in H.
    apply phi_phi' in H.
    apply (phi'_tran _ (X j) _).
    auto.
  + rewrite i0i in H.
    apply theta_phi in H.
    apply phi'_sym.
    apply Ho.
      apply beq_nat_false. assumption.
    apply phi_sym. assumption.
  - (* <- *)
    unfold update.
    case_eq (i0 =? i); intros i0i.
  + apply theta_phi.
    apply phi_phi'.
    apply (phi'_tran _ (X' i) _).
    apply beq_nat_true in i0i.
    rewrite i0i in H.
    apply phi'_sym in phi'_ji.
    auto.
  + apply theta_phi.
    apply phi_sym.
    apply Ho.
      apply beq_nat_false. assumption.
    auto.
  }
  + (* not_phi'_ji: forall j, ~ phi' (X j) (X' i) *)
    destruct (outside_data_exists' theta theta') as [d [theta_nd theta'_nd]].
    exists d.
    split.
  * (* theta, d) |= b *)
    unfold models. unfold assignmentD_models_guard.
    intros l.
    split; intros H.
  -- (* theta l = d -> b l *)
    apply theta_nd in H.
    contradiction.
  -- (* b l -> theta l = d *)
    apply b_empty in H. contradiction.

  * (* (theta', update theta i d) |= phi' *)
    unfold models. unfold two_assignments_model_rel.
    intros i0 j0.
    split.
  { (* theta' i0 = theta' j0 <-> phi' (X i0) (X j0) *)
    split; intros H.
  - (* -> *)
    apply theta_phi in H.
    apply phi_phi'. assumption.
  - (* <- *)
    apply theta_phi.
    apply phi_phi'. assumption.
  }
  split.
  { (* update theta i d i0 = update theta i d j0 <-> phi' (X' i0) (X' j0) *)
    unfold update.
    split; intros H.
  - (* -> *)
    rewrite <- elim_lat.
    rewrite la.
    unfold after.
    case_eq (i0 =? i); intros i0i.
  + case_eq (j0 =? i); intros j0i.
  * right. apply beq_nat_true. assumption.
  * rewrite i0i in H. rewrite j0i in H.
    symmetry in H. apply theta_nd in H. contradiction.
  + rewrite i0i in H.
    case_eq (j0 =? i); intros j0i.
  * rewrite j0i in H.
    apply theta_nd in H. contradiction.
  * rewrite j0i in H.
    unfold lat.
    apply theta_phi.
    assumption.
  - (* <- *)
    rewrite <- elim_lat in H.
    rewrite la in H.
    unfold after in H.
    case_eq (i0 =? i); intros i0i.
  + case_eq (j0 =? i); intros j0i.
  * reflexivity.
  * rewrite i0i in H.
    destruct H as [H | H].
      apply b_empty in H. contradiction.
    apply beq_nat_false in j0i. contradiction.
  + rewrite i0i in H.
    case_eq (j0 =? i); intros j0i.
  * rewrite j0i in H.
    apply b_empty in H. contradiction.
  * rewrite j0i in H.
    unfold lat in H.
    apply theta_phi. assumption.
  }
  split.
  { (* theta' i0 = update theta i d j0 <-> phi' (X i0) (X' j0) *)
    split; intros H.
  - (* -> *)
    unfold update in H.
    case_eq (j0 =? i); intros j0i.
  + rewrite j0i in H.
    apply theta'_nd in H. contradiction.
  + rewrite j0i in H.
    apply theta_phi in H.
    apply Ho.
      apply beq_nat_false. assumption.
    assumption.
  - (* <- *)
    unfold update.
    case_eq (j0 =? i); intros j0i.
  + apply beq_nat_true in j0i.
    rewrite j0i in H.
    apply not_phi'_ji in H.
    contradiction.
  + apply theta_phi.
    apply (Ho i0 j0).
      apply beq_nat_false. assumption.
    assumption.
  }
  { (* update theta i d i0 = theta' j0 <-> phi' (X' i0) (X j0) *)
    split; intros H.
  - (* -> *)
    unfold update in H.
    case_eq (i0 =? i); intros i0i.
  + rewrite i0i in H.
    symmetry in H. apply theta'_nd in H. contradiction.
  + rewrite i0i in H.
    apply phi'_sym.
    apply (Ho j0 i0).
      apply beq_nat_false. assumption.
    apply theta_phi. symmetry. assumption.
  - (* <- *)
    unfold update.
    case_eq (i0 =? i); intros i0i.
  + apply beq_nat_true in i0i.
    rewrite i0i in H.
    apply phi'_sym in H.
    apply not_phi'_ji in H. contradiction.
  + apply theta_phi.
    apply phi_sym.
    apply (Ho j0 i0).
      apply beq_nat_false. assumption.
    auto.
  }

  - (* bj: b j *)
    exists (theta j).
    split.
  * (* theta, theta j) |= b *)
    unfold models. unfold assignmentD_models_guard.
    intros l.
    split; intros H.
  -- (* theta l = theta' j -> b l *)
    apply theta_phi in H.
    apply phi_sym in H.
    rewrite <- elim_lat in H.
    apply lat_phi_b in H.
      assumption.
    assumption.
  -- (* b l -> theta l = theta j *)
    apply theta_phi.
    apply lat_phi_b.
      assumption.
    assumption.
  * (* (theta', update theta i (theta j)) |= phi' *)
    unfold models. unfold two_assignments_model_rel.
    intros i0 j0.
    split.
  { (* theta' i0 = theta' j0 <-> phi' (X i0) (X j0) *)
    split; intros H.
  - (* -> *)
    apply theta_phi in H.
    apply phi_phi'. assumption.
  - (* <- *)
    apply theta_phi.
    apply phi_phi'. assumption.
  }
  split.
  { (* update theta i (theta j) i0 = update theta i (theta j) j0
       <-> phi' (X' i0) (X' j0) *)
    unfold update.
    split; intros H.
  - (* -> *)
    case_eq (i0 =? i); intros i0i.
  + case_eq (j0 =? i); intros j0i.
  * apply beq_nat_true in i0i. rewrite i0i.
    apply beq_nat_true in j0i. rewrite j0i.
    apply phi'_refl.
  * rewrite i0i in H. rewrite j0i in H.
    rewrite <- elim_lat.
    rewrite la.
    unfold after.
    rewrite i0i.
    apply theta_phi in H.
    apply lat_phi_b in H.
      auto.
    assumption.
  + rewrite <- elim_lat.
    rewrite la.
    unfold after.
    rewrite i0i.
    rewrite i0i in H.
    case_eq (j0 =? i); intros j0i.
  * rewrite j0i in H.
    symmetry in H.
    apply theta_phi in H.
    apply lat_phi_b in H.
      assumption.
    assumption.
  * rewrite j0i in H.
    apply theta_phi in H.
    rewrite elim_lat.
    assumption.
  - (* <- *)
    rewrite <- elim_lat in H.
    rewrite la in H.
    unfold after in H.
    case_eq (i0 =? i); intros i0i.
  + case_eq (j0 =? i); intros j0i.
  * reflexivity.
  * rewrite i0i in H.
    destruct H as [H | H].
      apply theta_phi.
      apply lat_phi_b.
        assumption.
      assumption.
    apply beq_nat_false in j0i. contradiction.
  + rewrite i0i in H.
    case_eq (j0 =? i); intros j0i.
  * rewrite j0i in H.
    apply theta_phi.
    apply lat_phi_b.
      assumption.
    assumption.
  * rewrite j0i in H.
    unfold lat in H.
    apply theta_phi. assumption.
  }
  split.
  { (* theta' i0 = update theta i (theta j) j0 <-> phi' (X i0) (X' j0) *)
    split; intros H.
  - (* -> *)
    unfold update in H.
    case_eq (j0 =? i); intros j0i.
  + rewrite j0i in H.
    apply beq_nat_true in j0i.
    rewrite j0i.
    destruct (Hi i0 j) as [Hi0 _].
    apply Hi0.
    split.
    * apply theta_phi. assumption.
    * assumption.
  + rewrite j0i in H.
    apply theta_phi in H.
    apply Ho.
      apply beq_nat_false. assumption.
    assumption.
  - (* <- *)
    unfold update.
    case_eq (j0 =? i); intros j0i.
  + apply beq_nat_true in j0i.
    rewrite j0i in H.
    destruct (Hi i0 j) as [_ Hi1].
    apply (contrapositive Classic (phi (X i0) (X' j) <-> b j) _)
    in Hi1; try auto.
    apply Hi1 in bj.
    apply theta_phi.
    assumption.
  + apply theta_phi.
    apply (Ho i0 j0).
      apply beq_nat_false. assumption.
    assumption.
  }
  { (* update theta i (theta j) i0 = theta' j0 <-> phi' (X' i0) (X j0) *)
    split; intros H.
  - (* -> *)
    unfold update in H.
    case_eq (i0 =? i); intros i0i.
  + rewrite i0i in H.
    apply beq_nat_true in i0i.
    rewrite i0i.
    destruct (Hi j0 j) as [Hi0 _].
    apply phi'_sym.
    apply Hi0.
    split.
    * apply theta_phi. symmetry. assumption.
    * assumption.
  + rewrite i0i in H.
    apply theta_phi in H.
    apply phi'_sym.
    apply Ho.
      apply beq_nat_false. assumption.
    apply phi_sym. assumption.
  - (* <- *)
    unfold update.
    case_eq (i0 =? i); intros i0i.
  + apply beq_nat_true in i0i.
    rewrite i0i in H.
    destruct (Hi j0 j) as [_ Hi1].
    apply (contrapositive Classic (phi (X j0) (X' j) <-> b j) _)
    in Hi1; try auto.
    apply Hi1 in bj.
    apply theta_phi.
    apply phi_sym.
    assumption.
  + apply theta_phi.
    apply phi_sym.
    apply (Ho j0 i0).
      apply beq_nat_false. assumption.
    apply phi'_sym.
    assumption.
  }
Qed.


Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.theory.jections.

Section contents.
Context `{StrongSetoid A}.

Global Instance: Setoid A.
Proof.
  split.
    intros x. rewrite <-tight_apart. now apply (irreflexivity (≶)).
   intros x y. rewrite <-?tight_apart. now apply not_symmetry.
  intros x y z. rewrite <-?tight_apart. intros E1 E2 E3.
  destruct (cotransitive E3 y); contradiction.
Qed.

Global Instance apart_proper: Proper ((=) ==> (=) ==> iff) (≶).
Proof.
  assert (∀ x₁ y x₂, x₁ ≶ y → x₁ = x₂ → x₂ ≶ y) as P1.
   intros ? ? ? E Ex.
   destruct (cotransitive E x₂); trivial.
   apply tight_apart in Ex. destruct Ex.
   now symmetry.
  assert (∀ x₁ y₁ x₂ y₂, x₁ ≶ y₁ → x₁ = x₂ → y₁ = y₂ → x₂ ≶ y₂) as P2.
   intros ? ? ? ? E Ex Ey.
   apply P1 with x₁; trivial.
   symmetry. apply P1 with y₁; trivial. now symmetry.
  intros ? ? E1 ? ? E2.
  split; intro; eapply P2; eauto; now symmetry.
Qed.

Instance apart_ne x y : PropHolds (x ≶ y) → PropHolds (x ≠ y).
Proof. firstorder. Qed.

Global Instance: ∀ x y, Stable (x = y).
Proof.
  intros x y. unfold Stable, DN.
  rewrite <-tight_apart. tauto.
Qed.
End contents.

(* Due to bug #2528 *)
#[global]
Hint Extern 3 (PropHolds (_ ≠ _)) => eapply @apart_ne : typeclass_instances.

Lemma projected_strong_setoid `{StrongSetoid B} `{Equiv A} `{Apart A} (f: A → B)
  (eq_correct : ∀ x y, x = y ↔ f x = f y) (apart_correct : ∀ x y, x ≶ y ↔ f x ≶ f y) : StrongSetoid A.
Proof.
  split.
     intros x. red. rewrite apart_correct. apply (irreflexivity (≶)).
    intros x y. rewrite !apart_correct. now symmetry.
   intros x y E z. rewrite !apart_correct. apply cotransitive. now apply apart_correct.
  intros x y. rewrite apart_correct, eq_correct. now apply tight_apart.
Qed.

#[global]
Instance sig_strong_setoid `{StrongSetoid A} (P: A → Prop): StrongSetoid (sig P).
Proof. now apply (projected_strong_setoid (@proj1_sig _ P)). Qed.

Section morphisms.
  Context `{Equiv A} `{Apart A} `{Equiv B} `{Apart B} `{Equiv C} `{Apart C}.

  Existing Instance strong_setoidmor_a.
  Existing Instance strong_setoidmor_b.

  Global Instance strong_morphism_proper `{!StrongSetoid_Morphism (f : A → B)} :
    Setoid_Morphism f | 10.
  Proof.
    split; try apply _.
    intros ? ?. rewrite <-!tight_apart. intros E1 E2.
    destruct E1. now apply (strong_extensionality f).
  Qed.

  Global Instance strong_injective_injective `{!StrongInjective (f : A → B)} :
    Injective f.
  Proof.
    pose proof (strong_injective_mor f).
    split; try apply _.
    intros ? ?. rewrite <-!tight_apart. intros E1 E2.
    destruct E1. now apply (strong_injective f).
  Qed.

  (* If a morphism satisfies the binary strong extensionality property, it is
    strongly extensional in both coordinates. *)
  Global Instance strong_setoid_morphism_1 `{!StrongSetoid_BinaryMorphism (f : A → B → C)} :
    ∀ z, StrongSetoid_Morphism (f z).
  Proof.
    pose proof (strong_binary_setoidmor_a f).
    pose proof (strong_binary_setoidmor_b f).
    pose proof (strong_binary_setoidmor_c f).
    intros z.
    split; try apply _.
    intros x y E.
    destruct (strong_binary_extensionality f z x z y); trivial.
    now destruct (irreflexivity (≶) z).
  Qed.

  Global Instance strong_setoid_morphism_unary_2 `{!StrongSetoid_BinaryMorphism (f : A → B → C)} :
    ∀ z, StrongSetoid_Morphism (λ x, f x z).
  Proof.
    pose proof (strong_binary_setoidmor_a f).
    pose proof (strong_binary_setoidmor_b f).
    pose proof (strong_binary_setoidmor_c f).
    intros z.
    split; try apply _.
    intros x y E.
    destruct (strong_binary_extensionality f x z y z); trivial.
    now destruct (irreflexivity (≶) z).
  Qed.

  (* Conversely, if a morphism is strongly extensional in both coordinates, it
    satisfies the binary strong extensionality property. We don't make this an
    instance in order to avoid loops. *)
  Lemma strong_binary_setoid_morphism_both_coordinates
    `{!StrongSetoid A} `{!StrongSetoid B} `{!StrongSetoid C} {f : A → B → C}
    `{∀ z, StrongSetoid_Morphism (f z)} `{∀ z, StrongSetoid_Morphism (λ x, f x z)} : StrongSetoid_BinaryMorphism f.
  Proof.
    split; try apply _.
    intros x₁ y₁ x₂ y₂ E.
    destruct (cotransitive E (f x₂ y₁)).
     left. now apply (strong_extensionality (λ x, f x y₁)).
    right. now apply (strong_extensionality (f x₂)).
  Qed.

  Global Instance binary_strong_morphism_proper `{!StrongSetoid_BinaryMorphism (f : A → B → C)} :
    Proper ((=) ==> (=) ==> (=)) f.
  Proof.
    pose proof (strong_binary_setoidmor_a f).
    pose proof (strong_binary_setoidmor_b f).
    pose proof (strong_binary_setoidmor_c f).
    intros x₁ y₁ E1 x₂ y₂ E2.
    rewrite <-tight_apart in E1. rewrite <-tight_apart in E2.
    apply tight_apart. intros E3.
    edestruct (cotransitive E3 (f y₁ x₂)).
     destruct E1. now apply (strong_extensionality (λ x, f x x₂)).
    destruct E2. now apply (strong_extensionality (f y₁)).
  Qed.
End morphisms.

Section more_morphisms.
  Context `{StrongSetoid A} `{StrongSetoid B}.

  Lemma strong_binary_setoid_morphism_commutative {f : A → A → B} `{!Commutative f}
    `{∀ z, StrongSetoid_Morphism (f z)} : StrongSetoid_BinaryMorphism f.
  Proof.
    assert (∀ z, StrongSetoid_Morphism (λ x, f x z)).
     split; try apply _. intros x y. rewrite !(commutativity _ z). now apply (strong_extensionality (f z)).
    apply strong_binary_setoid_morphism_both_coordinates.
  Qed.
End more_morphisms.

#[global]
Instance default_apart `{Equiv A} : Apart A | 20 := (≠).

Set Warnings "-unsupported-attributes". (* FIXME: remove when minimal Coq version is enough *)

#[global]
Typeclasses Opaque default_apart.

Set Warnings "+unsupported-attributes".

#[global]
Instance default_apart_trivial `{Equiv A} : TrivialApart A (Aap:=default_apart).
Proof. red. reflexivity. Qed.

(* In case we have a decidable setoid, we can construct a strong setoid. Again
  we do not make this an instance as it will cause loops *)
Section dec_setoid.
  Context `{Setoid A} `{Apart A} `{!TrivialApart A} `{∀ x y, Decision (x = y)}.

  (* Not Global in order to avoid loops *)
  Instance ne_apart x y : PropHolds (x ≠ y) → PropHolds (x ≶ y).
  Proof. rewrite trivial_apart. easy. Qed.

  Instance dec_strong_setoid: StrongSetoid A.
  Proof.
    split; try apply _.
       firstorder.
      intros x y. rewrite !trivial_apart. firstorder.
     intros x y E1 z. rewrite !trivial_apart.
     destruct (decide (x = z)) as [E2|E2]; [|tauto].
     right. intros E3. rewrite trivial_apart in E1. apply E1. now rewrite E2.
    intros x y. rewrite trivial_apart. split.
     intros E. now apply stable.
    firstorder.
  Qed.
End dec_setoid.

(* And a similar result for morphisms *)
Section dec_setoid_morphisms.
  Context `{StrongSetoid A} `{!TrivialApart A} `{StrongSetoid B}.

  Instance dec_strong_morphism (f : A → B) `{!Setoid_Morphism f} :
    StrongSetoid_Morphism f.
  Proof.
    split; try apply _.
    intros x y E. apply trivial_apart, (setoids.morphism_ne f). now apply apart_ne.
  Qed.

  Context `{!TrivialApart B}.

  Instance dec_strong_injective (f : A → B) `{!Injective f} :
    StrongInjective f.
  Proof.
    pose proof (injective_mor f).
    split; try apply _.
    intros x y. rewrite !trivial_apart. now apply (injective_ne f).
  Qed.

  Context `{StrongSetoid C}.

  Instance dec_strong_binary_morphism (f : A → B → C) `{!Proper ((=) ==> (=) ==> (=)) f} :
    StrongSetoid_BinaryMorphism f.
  Proof.
    split; try apply _.
    intros x₁ y₁ x₂ y₂ E1.
    case (cotransitive E1 (f x₂ y₁)); rewrite !trivial_apart; intros E2.
     left. intros E3. destruct (apart_ne _ _ E2). now rewrite E3.
    right. intros E3. destruct (apart_ne _ _ E2). now rewrite E3.
  Qed.
End dec_setoid_morphisms.


Require Import HoTT.
From GR Require Import
     bicategories.bicategory.bicategory
     bicategories.bicategory.examples.lax_functors_bicat
     bicategories.bicategory.examples.opposite_2.

Definition OpLax `{Univalence} (C D : BiCategory) := Lax (op2 C) (op2 D).


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 Aprime Bprime Cprime O : Universe, ((wd_ B O /\ (wd_ C O /\ (wd_ Bprime O /\ (wd_ Cprime O /\ (wd_ A O /\ (wd_ Aprime O /\ (wd_ A Aprime /\ (col_ O A B /\ (col_ O B C /\ (col_ O Aprime Bprime /\ col_ O Bprime Cprime)))))))))) -> col_ O A C)).
Proof.
  time tac.
Qed.

End FOFProblem.