Require Import Coq.Logic.Eqdep.

Require Export CatSem.CAT.cat_INDEXED_TYPE.
Require Export CatSem.CAT.monad_h_morphism_gen.

Set Implicit Arguments.
Unset Strict Implicit.

Unset Automatic Introduction.

Section retyping.

Variables U U' : Type.

Variable T : U -> U'.

(** for T : U -> U' define a functor RETYPE : Set/U -> Set/U' *)

Inductive retype (V : ITYPE U) : ITYPE U' :=
  | ctype : forall t, V t -> retype V (T t).

Inductive backtype (V : ITYPE U') : ITYPE U :=
  | bt : forall t : U, V (T t) -> backtype V t.

Notation "' V" := (retype V) (at level 20).

Definition retype_map V W (f : V ---> W) : 'V ---> 'W :=
    fun t x => match x with
    | ctype t v => ctype (f _ v)
    end.

Instance retype_eq V W : Proper (equiv ==> equiv) (@retype_map V W).
Proof.
  unfold Proper.
  red.
  intros V W f g H t x.
  induction x.
  simpl.
  rewrite H.
  auto.
Qed.

Obligation Tactic := idtac.

Program Instance retype_func : Functor_struct (fun V W => @retype_map V W).
Next Obligation.
Proof.
  simpl.
  intros a t x.
  induction x;
  simpl;
  auto.
Qed.
Next Obligation.
Proof.
  simpl;
  intros a b c f g u x.
  induction x;
  simpl;
  auto.
Qed.

Definition RETYPE := Build_Functor retype_func.

Definition der_comm t (V : ITYPE U) : ' (opt t V) ---> opt (T t) (' V) :=
   fun (t0 : U') (X : (' opt t V) t0) =>
   match X in ((' _) u) return (opt (T t) (' V) u) with
   | ctype _ o =>
     match o in (opt _ _ y) return (opt (T t) (' V) (T y)) with
       | some t2 v => some (T t)(A:=' V)(t:=T t2)(ctype (V:=V) (t:=t2) v)
       | none => none (T t) (' V)
    end
end.

Lemma retype_nt (V W : ITYPE U) (f : V ---> W) t (v : V t) :
   retype_map f (ctype v) = ctype (f t v).
Proof.
  reflexivity.
Qed.

Section bla.

Variable P : Monad (ITYPE U).
Variable Q : Monad (ITYPE U').

Variable M : colax_Monad_Hom P Q (RETYPE).

Variable s : U.

(** constructors without binding can use this in each component
    as left vertical morphism *)

Program Instance blalb : Module_Hom_struct
         (S := ITFIB_MOD _ s P)
         (T := ITFIB_MOD _ (T s) (PModule M Q))
         (fun x X => M _ _ (ctype X)).
Next Obligation.
Proof.
  simpl.
  intros.
  assert (H:= gen_monad_hom_kl (colax_Monad_Hom_struct := M)).
  simpl in H.
  rewrite <- H.
  apply f_equal.
  simpl.
  auto.
Qed.

Definition FFib_Mod_Hom := Build_Module_Hom blalb.

(** this version already commutes pullback with fibre at
    the target, but is not used at the moment

    i choose to do retyping P [T s] -> P [s'] before
    commuting pullback and fibre
*)

Program Instance blalb2 : Module_Hom_struct
         (S := ITFIB_MOD _ s P)
         (T := PModule M (ITFIB_MOD _ (T s) Q))
         (fun x X => M _ _ (ctype X)).
Next Obligation.
Proof.
  simpl.
  intros.
  assert (H:= gen_monad_hom_kl (colax_Monad_Hom_struct := M)).
  simpl in H.
  rewrite <- H.
  apply f_equal.
  simpl.
  auto.
Qed.

Definition FFib_PM_Mod_Hom := Build_Module_Hom blalb.

(** now we try to produce D_r P [s] -> D_(T r) f* Q [T s] *)

Variable r : U.

(*
Lemma useful W t' t x:
lift (M:= Q) (@der_comm _ _ ) (T t')
  (M (opt t W) (T t') (retype_map (W:=P (opt t W))
   (lift (some t (A:=W))) x)) =
lift (M:= Q) (some (T t) (A:=' W)) (T t') (M W (T t') x) .
Proof.
  assert (H := trafo_ax (NatTrans := gen_Monad_Hom_NatTrans M)).
  simpl in H.
  intros.
  rewrite <- H.
  simpl.
  assert (H1:=lift_lift Q).
  simpl in H1.
  rewrite H1.
  assert (H2 := lift_eq Q).
  unfold Proper in H2.
  red in H2.
  apply H2.
  simpl.
  intros.
  destruct x0.
  simpl.
  auto.
Qed.
*)

Program Instance blalb3 : Module_Hom_struct
     (S := ITFIB_MOD _ s (ITDER_MOD _ _ r P))
     (T := ITFIB_MOD _ (T s) (PModule M (ITDER_MOD _ _ (T r) Q)))
    (fun t X => lift (M:=Q)(@der_comm _ _ ) _ (M _ _ (ctype X))).
Next Obligation.
Proof.
 simpl.
 intros V W f x.

 rewrite <- retype_nt.
(* transitivity ( lift (M:=Q) (@der_comm _ _ ) (T s)
                  (M (opt r W) (T s)
        (retype_map (kleisli (shift (P:=P)(W:=W) f))
            (ctype (V:=P (opt r V)) (t:=s)  x)))).
  auto.*)
  assert (H'':= gen_monad_hom_kl (colax_Monad_Hom_struct := M)).
  simpl in H''.
  rewrite H''.

  assert (H:= lift_kleisli (M:=Q)).
  simpl in H.
  rewrite H.

  assert (H':=kleisli_lift (M:=Q)).
  simpl in H'.
  rewrite H'.
  unfold lift.
  simpl.

  assert (H5 := kl_eq Q).
  simpl in *.
  apply H5.

  intros.

  destruct x0.
  simpl.
  destruct o.

  Focus 1.

  simpl.

  generalize (f t v).
  clear v.
  intro v.
  rewrite <- retype_nt.
  assert (H4 := NTcomm (colax_Monad_Hom_NatTrans M)).
  simpl in H4.
  rewrite <- H4.
  rewrite H.
  unfold lift.
  simpl.
  apply H5.
  intros.
  apply f_equal.
  destruct x0.
  simpl.
  auto.  (* end of 1 *)

  simpl.
  rewrite <- retype_nt.
  assert (H4 := NTcomm (colax_Monad_Hom_NatTrans M)).
  assert (H12 := gen_monad_hom_weta (colax_Monad_Hom_struct := M)).
  simpl in H12.
  rewrite H12.
  assert (H13 := etakl Q).
  simpl in H13.
  rewrite H13.
  auto.
Qed.

Canonical Structure FFib_DER_Mod_Hom :
     ITFIB_MOD _ s (ITDER_MOD _ _ r P) --->
            ITFIB_MOD _ (T s) (PModule M (ITDER_MOD _ _ (T r) Q)):=
      Build_Module_Hom blalb3.

Variable r' : U'.
Hypothesis Hr : T r = r'.

Program Instance blalb_eqrect : Module_Hom_struct
     (S := ITFIB_MOD _ s (ITDER_MOD _ _ r P))
     (T := ITFIB_MOD _ (T s) (PModule M (ITDER_MOD _ _ (r') Q)))
    (fun V x => eq_rect (T r)
             (fun r' : U' => Q (opt r' (' V)) (T s))
 (lift (M:=Q)(@der_comm _ _ ) _ ((gen_monad_hom M) _ _ (ctype x))) r' Hr).
Next Obligation.
Proof.
  rewrite <- Hr.
  simpl.
  intros V W f x.
  simpl.

  rewrite <- retype_nt.
  assert (H'':= gen_monad_hom_kl (colax_Monad_Hom_struct := M)).
  simpl in H''.
  rewrite H''.

  assert (H:= lift_kleisli (M:=Q)).
  simpl in H.
  rewrite H.

  assert (H':=kleisli_lift (M:=Q)).
  simpl in H'.
  rewrite H'.
  unfold lift.
  simpl.

  assert (H5 := kl_eq Q).
  apply H5.
  simpl.

  intros.

  destruct x0.
  simpl.
  destruct o.

  Focus 1.

  simpl.

  generalize (f t v).
  clear v.
  intro v.
  rewrite <- retype_nt.
  assert (H4 := NTcomm (colax_Monad_Hom_NatTrans M)).
  simpl in H4.
  rewrite <- H4.
  rewrite H.
  unfold lift.
  simpl.
  apply H5.
  simpl.
  intros.
  apply f_equal.
  destruct x0.
  simpl.
  auto.  (* end of 1 *)

  simpl.
  rewrite <- retype_nt.
  assert (H4 := NTcomm (colax_Monad_Hom_NatTrans M)).
  assert (H12 := gen_monad_hom_weta (colax_Monad_Hom_struct := M)).
  simpl in H12.
  rewrite H12.

  assert (H13 := etakl Q).
  simpl in H13.
  simpl in H13.
  rewrite H13.
  apply f_equal.
  simpl.
  auto.
Qed.

Canonical Structure FFib_DER_Mod_Hom_eqrect :
     ITFIB_MOD _ s (ITDER_MOD _ _ r P) --->
            ITFIB_MOD _ (T s) (PModule M (ITDER_MOD _ _ (r') Q)):=
      Build_Module_Hom blalb_eqrect.

Variable obD : Type.
Variable morD : obD -> obD -> Type.
Variable D : Cat_struct morD.

Variable N : MOD Q (ITYPE U').

Program Instance PM_DER (t : U) : Module_Hom_struct
      (S := ITDER_MOD _ _ t (PModule M N))
      (T := PModule M (ITDER_MOD _ _ (T t) N))
      (fun x => mlift N (@der_comm _ _ )).
Next Obligation.
Proof.
  intros t V W f.
  assert (H6 := mlift_mkleisli N).
  assert (H7 := mkleisli_mlift N).
  simpl in *.

  intros t' x.
  rewrite H6.
  rewrite H7.

  assert (H5 := mkleisli_oid (Module_struct := N)).
  unfold Proper in H5.
  red in H5.
  apply H5.
  clear H5 H6 H7.
  clear x t'.
  intros t' x.
  destruct x as [t' x] .
  simpl.
  destruct x as [t' x | ].
  simpl.

  Focus 1.
  generalize (f t' x).
  clear x.
  clear f.
  intro x.
  clear V.
  assert (H'':= gen_monad_hom_kl (colax_Monad_Hom_struct := M)).
  simpl in H''.

  rewrite <- retype_nt.

  generalize (ctype x).
  clear x.
  intro x.
  clear dependent obD.
  assert (H := NTcomm (colax_Monad_Hom_NatTrans M)).
  simpl in H.
  rewrite <- H.
  simpl.
  assert (H1:=lift_lift Q).
  simpl in H1.
  rewrite H1.
  assert (H2 := lift_eq Q).
  unfold Proper in H2.
  red in H2.
  apply H2.
  simpl.
  intros.
  destruct x0.
  simpl.
  auto.

  simpl.
  clear dependent V.
  clear dependent obD.

  assert (H := NTcomm (colax_Monad_Hom_NatTrans M)).
  rewrite <- retype_nt.
  auto.

  simpl in H.

  assert (H12 := gen_monad_hom_weta (colax_Monad_Hom_struct := M)).
  simpl in H12.
  rewrite H12.

  assert (H13 := lift_weta Q).
  simpl in H13.
  rewrite H13.
  simpl.
  auto.
Qed.

End bla.

Section eq_DER.

Variable P : Monad (ITYPE U).

Variable M : MOD P (ITYPE U).

Variables u u' : U.
Hypothesis H : u = u'.

Definition eq_type_der_c :
(forall x : ITYPE U,
   (((ITDER_MOD P _ u) M) x) ---> (((ITDER_MOD P _ u') M) x)).
  intro x.
  rewrite <- H.
  apply id.
Defined.

Program Instance eq_type_der_mod_s : Module_Hom_struct
       (S := ITDER_MOD P _ u M)
       (T := ITDER_MOD _ _ u' M) eq_type_der_c.
Next Obligation.
Proof.
  intros c d f t.
  simpl.
  unfold eq_type_der_c.
  simpl in *.
  rewrite H.
  simpl.
  auto.
Qed.

Definition eq_type_der_mod := Build_Module_Hom eq_type_der_mod_s.

End eq_DER.

End retyping.

Section lemmata.

Variables U U' : Type.
Variable f : U -> U'.
Variable P : Monad (ITYPE U).
Variable Q : Monad (ITYPE U').

Variable M : colax_Monad_Hom P Q (RETYPE f).
Variables V W : ITYPE U.
Variable f' : V ---> P W.
Variable t : U.
Variable y : P V t.

Lemma MonadHomKl :
M W (f t) (ctype f (V:=P W) (t:=t) (kleisli f' t y)) =
     kleisli (Monad_struct := Q)
       (fun (t : U') (x : retype f V t) => M W t (retype_map (W:=P W) f' x))
       (f t) (M V (f t) (ctype f (V:=P V) (t:=t) y)).

Proof.
  assert (H:= gen_monad_hom_kl (colax_Monad_Hom_struct := M)).
  simpl in H.
  assert (H':= H _ _ f' _ (ctype _ y)).
  simpl in H'.
  apply H'.
Qed.

Variable z : V t.

Lemma MonadHomWe :
    M V (f t) (ctype f (V:=P V) (t:=t)
           (weta (Monad_struct := P) V t z)) =
     weta (Monad_struct := Q)
        (retype f V) (f t) (ctype f (V:=V) (t:=t) z).
Proof.
  assert (H:= gen_monad_hom_weta (colax_Monad_Hom_struct := M)).
  simpl in H.
  assert (H':= H _ _ (ctype _ z)).
  simpl in H'.
  auto.
Qed.

Variable g : V ---> W.

Lemma MonadHomLift :
  lift (retype_map (W:=W) g) (f t) (M V (f t) (ctype f (V:=P V) (t:=t) y)) =
     M W (f t) (ctype f (V:=P W) (t:=t) (lift g t y)).
Proof.
  assert (H3 := NTcomm (colax_Monad_Hom_NatTrans M)).
  simpl in H3.
  assert (H4:= H3 _ _ g _ (ctype _ y)).
  simpl in H4.
  auto.
Qed.

End lemmata.

(**  this is V^{f} -> V^{g} where forall t, f t = g t   *)

Section transp.
Variables U U': Type.
Variables f g : U -> U'.
Hypothesis H : forall t, g t = f t.

Definition transp : forall V : ITYPE U,
     (RETYPE (fun t : U => f t)) V --->
     (RETYPE (fun t : U => g t)) V :=
  fun (V : U -> Type) (t : U')
      (Y : retype (fun t0 : U => f t0) V t) =>
    match Y in (retype _ _ y) return
         (retype (fun t0 : U => g t0) V y) with
    | ctype t0 v =>
           eq_rect (g t0)
            (fun u : U' => retype (fun t1 : U => g t1) V u)
            (ctype (fun t1 : U => g t1) (V:=V) (t:=t0) v) (f t0) (H t0)
end.

Obligation Tactic := idtac.

Program Instance transp_NT :
    NT_struct (F:=RETYPE (fun t => f t))
           (G := RETYPE (fun t => g t)) transp.
Next Obligation.
Proof.
  simpl.
  intros V W f' t y.
  induction y.
  simpl.
  rewrite <- H.
  simpl.
  auto.
Qed.

Definition Transp : NT (RETYPE (fun t => f t))
         (RETYPE (fun t => g t)) := Build_NT transp_NT.

End transp.

Section transp_id.

(** retyping with the identity function is the identity *)

Variables U U' : Type.
Variable f : U -> U'.
Variable H : forall t, f t = f t.

Lemma transp_id : forall V, transp H (V:=V) == id _.
Proof.
  simpl.
  intros V t y.
  induction y.
  simpl.
  rewrite (UIP_refl _ _ (H t)).
  simpl.
  auto.
Qed.

End transp_id.

Section transp_lift_id.

Variables U U' : Type.
Variable f : U -> U'.
(*Variable P : Monad (ITYPE U).*)
Variable Q : Monad (ITYPE U').

Hypothesis H : forall t, f t = f t.
Variable V : ITYPE U.
Variable t' : U'.

Lemma lift_transp_id : forall y : Q (retype (fun t => f t) V) t',
   lift (M:=Q) (transp (f:= f)(g:= f) H (V:=V))
           _ y = y.
Proof.
  intro y.
  assert (H'' := lift_eq_id Q).
  apply H''.
  apply transp_id.
Qed.

End transp_lift_id.

Section id_retype.
Variable U : Type.

Definition id_retype V : V ---> retype (U':=U) (fun t => t) V :=
    fun t y => ctype (fun t0 => t0) y.

End id_retype.

Section double_retype.

Variables U U' U'' : Type.
Variable f : U -> U'.
Variable f' : U' -> U''.

Definition double_retype_1 (V : ITYPE U) :
   retype (fun t => f' t) (retype (fun t => f t) V) --->
        retype (fun t => f' (f t)) V :=
 fun  (t : U'')
  (y : retype (fun t0 : U' => f' t0)
     (retype (fun t0 : U => f t0) V) t) =>
   match y in (retype _ _ y0) return
       (retype (fun t0 : U => f' (f t0)) V y0)
   with | ctype _ r =>
       match r in (retype _ _ y0) return
               (retype (fun t1 : U => f' (f t1)) V (f' y0))
       with | ctype t1 v =>
         ctype (fun t2 : U => f' (f t2)) (V:=V) (t:=t1) v
    end
end.

Definition double_retype_2 (V : ITYPE U) :
    retype (fun t => f' (f t)) V --->
    retype (fun t => f' t) (retype (fun t => f t) V) :=
  fun (t : U'') (y : retype (fun t0 : U => f' (f t0)) V t) =>
  match y in (retype _ _ y0) return
      (retype (fun t0 : U' => f' t0)
         (retype (fun t0 : U => f t0) V) y0)
  with | ctype t0 v =>
         ctype (fun t1 : U' => f' t1)
        (V:=retype (fun t1 : U => f t1) V) (t:= f t0)
            (ctype (fun t1 : U => f t1) (V:=V) (t:=t0) v)
end.

End double_retype.

Section comp_monad.

Variables U U' U'' : Type.
Variable f : U -> U'.
Variable f' : U' -> U''.

Variable P : Monad (ITYPE U).
Variable Q : Monad (ITYPE U').
Variable R : Monad (ITYPE U'').

Variable M : colax_Monad_Hom P Q (RETYPE (fun t => f t)).
Variable N : colax_Monad_Hom Q R (RETYPE (fun t => f' t)).

Definition comp_rep_car : (forall c : ITYPE U,
        RETYPE (fun t => f' (f t)) (P c) --->
     R ((RETYPE (fun t => f' (f t))) c)) :=

  fun (V : ITYPE U) t
    (y : retype (fun t => f' (f t)) (P V) t) =>
   match y with ctype _ z =>
    (lift (M:=R) (double_retype_1 (f:=f)
                            (f':=f') (V:=V))) _
          (N _ _ (ctype (fun t => f' t)
               (M _ _ (ctype (fun t => f t) z ))))end.

Obligation Tactic := idtac.

Program Instance comp_rep_mon_hom_s :
       colax_Monad_Hom_struct (P:=P) (Q:=R)
       (F0:=RETYPE (fun t => f' (f t)))
       comp_rep_car.
Next Obligation.
Proof.
  simpl.
  intros V W g t y.
  simpl.
  destruct y as [t y].
  simpl.

  rewrite (MonadHomKl M).
  simpl.
  rewrite (MonadHomKl N).
  assert (H':=lift_kleisli (M:=R)).
  simpl in H'.
  rewrite H'.
  assert (H3:=kleisli_lift (M:=R)).
  simpl in H3.
  rewrite H3.
  apply (kl_eq R).

  intros t0 z.
  destruct z.
  simpl.
  destruct r.
  simpl.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros V t y.
  destruct y.
  simpl.

  rewrite (MonadHomWe M).
  rewrite (MonadHomWe N).
  assert (H:= lift_weta R).
  simpl in H.
  rewrite H.
  auto.
Qed.

Definition comp_Rep_monad :=
    Build_colax_Monad_Hom comp_rep_mon_hom_s.

End comp_monad.


Require Import HoTT.
Require Import MyTacs MyLemmas.
Require Import KernelPair_v2.

Local Open Scope path_scope.
Generalizable All Variables.

Context `{Funext}.

Definition KP'_dont_add_paths `{f: A -> B} (a b: A) (p: a = b)
  : kp_eq a b (ap f p) = ap kp p.
Proof.
  destruct p. apply kp_eq2.
Defined.

(* Here we show that there is a cocone over the 3-truncated Cech into KP'(f) *)
Module Cocone.
  Section Cocone.
    Context `(f: A -> B).

    Let A2 := ∃ x y, f x = f y.
    Let A3 := ∃ x y z, (f x = f y) * (f y = f z).

    Let π1 : A2 -> A := λ w, w.1.
    Let π2 : A2 -> A := λ w, w.2.1.

    Let f1 : A3 -> A2 := λ w, (w.2.1; (w.2.2.1; snd w.2.2.2)).
    Let f2 : A3 -> A2 := λ w, (w.1; (w.2.2.1; fst w.2.2.2 @ snd w.2.2.2)).
    Let f3 : A3 -> A2 := λ w, (w.1; (w.2.1; fst w.2.2.2)).

    Let δ : A -> A2 := λ x, (x; (x; 1)).

    Let δ1 : A2 -> A3 := λ w, (w.1; (w.1; (w.2.1; (1, w.2.2)))).
    Let δ2 : A2 -> A3 := λ w, (w.1; (w.2.1; (w.2.1; (w.2.2, 1)))).

    Record cech3_cocone Z :=
      { q1 : A -> Z;
        q2 : A2 -> Z;
        q3 : A3 -> Z;
        Hπ1 : q1 o π1 == q2;
        Hπ2 : q1 o π2 == q2;
        Hf1 : q2 o f1 == q3;
        Hf2 : q2 o f2 == q3;
        Hf3 : q2 o f3 == q3;
        Hδ  : q2 o δ  == q1;
        Hδ1 : q3 o δ1 == q2;
        Hδ2 : q3 o δ2 == q2;
        coh1  : forall x, Hπ1 (f1 x) @ Hf1 x = Hπ2 (f3 x) @ Hf3 x;
        coh2  : forall x, Hπ1 (f2 x) @ Hf2 x = Hπ1 (f3 x) @ Hf3 x;
        coh3  : forall x, Hπ2 (f1 x) @ Hf1 x = Hπ2 (f2 x) @ Hf2 x;
        coh4  : forall x, Hδ1 (δ x) @ Hδ x = Hδ2 (δ x) @ Hδ x;
        coh5  : forall x, Hπ1 (δ x) @ Hδ x = 1;
        coh6  : forall x, Hπ2 (δ x) @ Hδ x = 1;
        coh7  : forall x, Hf1 (δ2 x) @ Hδ2 x = Hδ (π2 x) @ Hπ2 x;
        coh8  : forall x, Hf3 (δ1 x) @ Hδ1 x = Hδ (π1 x) @ Hπ1 x;
        coh9  : forall x, Hf1 (δ1 x) @ Hδ1 x = 1;
        coh10 : forall x, Hf2 (δ1 x) @ Hδ1 x
                          = ap q2 (path_sigma' _ 1 (path_sigma' _ 1 (concat_1p _)));
        coh11 : forall x, Hf2 (δ2 x) @ Hδ2 x
                          = ap q2 (path_sigma' _ 1 (path_sigma' _ 1 (concat_p1 _)));
        coh12 : forall x, Hf3 (δ2 x) @ Hδ2 x = 1
      }.

    Let f' := KP_rec B f (λ _ _ h, h) (λ _, 1). (* f' is lift(f) *)

    Arguments kp_eq {_ _} _ _ _ _.

    Lemma kp_eq_is_ap_kp a b (p: f a =  f b)
      : ap kp (kp_eq f a b p) = kp_eq f' (kp a) (kp b) p.
    Proof.
      refine ((KP'_dont_add_paths _ _ _)^ @ _). apply ap.
      unfold f'; rapply @KP_rec_beta_kp_eq.
    Defined.

    Lemma kp_eq_concat (a b c: A) (p: f a = f b) (q: f b = f c)
      : kp_eq f' (kp a) (kp c) (p @ q) =
        kp_eq f' (kp a) (kp b) p @ kp_eq f' (kp b) (kp c) q.
    Proof.
      clear. pose (kp_eq f _ _ p).
      pose (X := apD (λ w, kp_eq f' w (kp c)) p0); cbn in X.
      pose (X' := ap10 X q); subst X p0.
      rewrite transport_arrow in X'.
      rewrite !transport_paths_Fl in X'.
      rewrite ap_V, inv_V in X'. unfold f' in X'; rewrite KP_rec_beta_kp_eq in X'.
      apply moveL_Mp. rewrite kp_eq_is_ap_kp in X'. assumption.
    Defined.

    Goal cech3_cocone (KP' f').
      simple refine (Build_cech3_cocone _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _).
      exact (kp o kp).
      exact (kp o kp o π2).
      exact (kp o kp o π2 o f2).
      all: intro x; unfold f1, f2, f3; cbn.
      exact (kp_eq _ (kp x.1) (kp x.2.1) x.2.2).
      reflexivity. reflexivity. reflexivity.
      exact (ap kp (kp_eq _ _ _ (snd x.2.2.2))).
      reflexivity. reflexivity. reflexivity.
      all: cbn; try reflexivity.
      simple refine (concat_p1 _ @ (kp_eq_is_ap_kp _ _ _)^ @ (concat_1p _)^).
      simple refine (concat_p1 _ @ kp_eq_concat _ _ _ _ _ @ ap _ (kp_eq_is_ap_kp _ _ _)^).
      exact (kp_eq2 _ @@ 1).
      simple refine (concat_p1 _ @ kp_eq_is_ap_kp _ _ _ @ (concat_1p _)^).
      symmetry. rewrite (ap_compose π2 (kp o kp)).
      simple refine (ap (y:=1) (ap (kp o kp)) _).
      simple refine (ap_path_sigma_1 (P:=λ x, ∃ y, f x = f y) (λ x y, y.1)
                              _ (path_sigma' (λ y, f x.1 = f y) 1 (concat_1p (x.2).2)) @ _).
      unfold path_sigma'. pose @pr1_path_sigma. unfold pr1_path in p. apply p.
      symmetry. rewrite (ap_compose π2 (kp o kp)).
      simple refine (ap (y:=1) (ap (kp o kp)) _).
      simple refine (ap_path_sigma_1 (P:=λ x, ∃ y, f x = f y) (λ x y, y.1)
                              _ (path_sigma' (λ y, f x.1 = f y) 1 (concat_p1 (x.2).2)) @ _).
      unfold path_sigma'. pose @pr1_path_sigma. unfold pr1_path in p. apply p.
      simple refine (concat_p1 _ @ ap (y:=1) (ap kp) _).
      apply kp_eq2.
    Defined.
  End Cocone.
End Cocone.

(* Here we show that KP'(f) is the colimit with identities of the kernel pair *)
Module Cocone2.
  Section Cocone.
    Context `(f: A -> B).

    Let A2 := ∃ x y, f x = f y.

    Let π1 : A2 -> A := λ w, w.1.
    Let π2 : A2 -> A := λ w, w.2.1.
    Let δ : A -> A2 := λ x, (x; (x; 1)).

    Record cech2_delta_cocone {Z} :=
      { q1 : A -> Z;
        q2 : A2 -> Z;
        H1 : q1 o π1 == q2;
        H2 : q1 o π2 == q2;
        K : q1 == q2 o δ;
        coh1 : forall x, H1 (δ x) = K x;
        coh2 : forall x, H2 (δ x) = K x
      }.

    Arguments cech2_delta_cocone Z : clear implicits.

    Definition path_cocone Z (C C': cech2_delta_cocone Z)
               (q1' : q1 C == q1 C')
               (q2' : q2 C == q2 C')
               (H1' : ∀ x, H1 C x @ q2' _ = q1' (π1 x) @ H1 C' x)
               (H2' : ∀ x, H2 C x @ q2' _ = q1' (π2 x) @ H2 C' x)
               (K' : ∀ x, K C x @ q2' (δ x) = q1' x @ K C' x)
               (coh1': ∀ x, (coh1 C x @@ 1) @ K' x = H1' (δ x) @ (1 @@ coh1 C' x))
               (coh2': ∀ x, (coh2 C x @@ 1) @ K' x = H2' (δ x) @ (1 @@ coh2 C' x))
      : C = C'.
    Admitted.

    Record cech2_delta_cocone' {Z} :=
      { q : A -> Z;
        Hq : q o π1 == q o π2;
        cohq : ∀ x, Hq (δ x) = 1
      }.

    Arguments cech2_delta_cocone' Z : clear implicits.

    Definition path_cocone' Z (C C': cech2_delta_cocone' Z)
               (q' : q C == q C')
               (Hq' : ∀ x, Hq C x @ q' _ = q' (π1 x) @ Hq C' x)
               (cohq': ∀ x, (cohq C x @@ 1) @ (concat_1p _ @ (concat_p1 _)^)
                            = Hq' (δ x) @ (1 @@ cohq C' x))
      : C = C'.
    Admitted.

    Definition equiv_delta_cocone Z : cech2_delta_cocone Z <~> cech2_delta_cocone' Z.
    Proof.
      simple refine (equiv_adjointify _ _ _ _).
      - intros [q1 q2 H1 H2 K coh1 coh2].
        unshelve rapply @Build_cech2_delta_cocone'.
        exact q1. intro x. exact (H1 x @ (H2 _)^).
        intro x; cbn.
        exact ((coh1 x @@ inverse2 (coh2 x)) @ concat_pV _).
      - intros [q H H1].
        unshelve rapply @Build_cech2_delta_cocone.
        exact q. exact (q o π2). exact H. exact (λ _, 1).
        exact (λ _, 1).
        exact H1. intro; reflexivity.
      - intros [q H H1].
        unshelve rapply path_cocone'; intro x; cbn.
        + reflexivity.
        + exact (concat_p1 _ @ concat_p1 _ @ (concat_1p _)^).
        + cbn. set (H1' := H1 x) in *; clearbody H1'; clear H1.
          set (H' := H (δ x)) in *; clearbody H'; clear H.
          rewrite <- (inv_V H1').
          destruct H1'^. reflexivity.
      - intros [q1 q2 H1 H2 K coh1 coh2].
        unshelve rapply path_cocone; intro x; cbn; try reflexivity.
        simple refine (concat_pp_p @ _).
        simple refine ((1 @@ concat_Vp _) @ _).
        exact (concat_p1 _ @ (concat_1p _)^).
        set (coh1' := coh1 x); clearbody coh1'; clear coh1.
        set (coh2' := coh2 x); clearbody coh2'; clear coh2.
        set (H1' := H1 (δ x)) in *; clearbody H1'; clear H1.
        set (H2' := H2 (δ x)) in *; clearbody H2'; clear H2.
        set (K' := K x) in *; clearbody K'; clear K.
        destruct coh2', coh1'. cbn in *.
        set (q1' := q1 x) in *; clearbody q1'; clear q1.
        destruct H1'. reflexivity.
    Defined.

    Definition postcompose_cocone {X} (C: cech2_delta_cocone X) Y (g: X -> Y)
      : @cech2_delta_cocone Y.
    Proof.
      unshelve rapply @Build_cech2_delta_cocone.
      exact (g o (q1 C)). exact (g o (q2 C)).
      all: intro x; cbn; apply ap.
      apply H1. apply H2. apply K. apply coh1. apply coh2.
    Defined.

    Definition is_colimit Z :=
      ∃ (C: cech2_delta_cocone Z), ∀ Y, IsEquiv (postcompose_cocone C Y).

    Definition postcompose_cocone' {X} (C: cech2_delta_cocone' X) Y (g: X -> Y)
      : @cech2_delta_cocone' Y.
    Proof.
      unshelve rapply @Build_cech2_delta_cocone'.
      exact (g o (q C)).
      all: intro x; cbn.
      apply ap, Hq. exact (ap (ap g) (cohq C x)).
    Defined.

    Definition is_colimit' Z :=
      ∃ (C: cech2_delta_cocone' Z), ∀ Y, IsEquiv (postcompose_cocone' C Y).

    Definition colimit'_colimit Z : is_colimit' Z -> is_colimit Z.
    Proof.
      intros [C HC].
      exists ((equiv_delta_cocone _)^-1 C).
      intro Y.
      simple refine (isequiv_homotopic
                ((equiv_delta_cocone Y)^-1 o (postcompose_cocone' C Y))
                (H:=isequiv_compose) _).
      intro g. unshelve rapply path_cocone.
      all: intro; try reflexivity.
      exact (concat_p1 _ @ (concat_1p _)^).
      simple refine (concat_p1 _ @ _).
      change ( ap (ap g) (cohq C x) @@ 1
               = (concat_p1 (ap g (Hq C (δ x)))
                            @ (concat_1p (ap g (Hq C (δ x))))^)
                   @ (1 @@ ap (ap g) (cohq C x)) ).
      set (coh := cohq C x); clearbody coh.
      set (Hq := Hq C (δ x)) in *; clearbody Hq.
      rewrite <- (inv_V coh). destruct coh^.
      reflexivity.
    Defined.

    Goal is_colimit (KP' f).
    Proof.
      apply colimit'_colimit.
      unshelve rapply @exist.
      - unshelve rapply @Build_cech2_delta_cocone'.
        exact kp. all: intro x; cbn.
        exact (kp_eq _ _ x.2.2).
        apply kp_eq2.
      - intro Y. unshelve rapply @isequiv_adjointify.
        + intro C. unshelve rapply @KP_rec.
          exact (q C).
          intros a b p. exact (Hq C (a; (b; p))).
          intro a; cbn. exact (cohq C _ ).
        + intros [q Hq cohq].
          unshelve rapply @path_cocone'; cbn.
          all: intro x; try reflexivity; cbn.
          simple refine (concat_p1 _ @ _ @ (concat_1p _)^).
          apply KP_rec_beta_kp_eq.
          cbn. simple refine (concat_p1 _ @ _).
          set ((ap (KP_rec Y q (λ (a b : A) (p : f a = f b), Hq (a; (b; p))) (λ a : A, cohq a))
                   (kp_eq x x 1))).
          set (KP_rec Y q (λ (a b : A) (p0 : f a = f b), Hq (a; (b; p0))) (λ a : A, cohq a)).
          set (KP_rec_beta_kp_eq Y q (λ (a b : A) (p0 : f a = f b), Hq (a; (b; p0)))
                                 (λ a : A, cohq a) x x 1).
          rewrite concat2_p1.
          rewrite concat2_1p.
          rewrite concat_pp_p.
          pose (whiskerL_1p (cohq x)).
          pose (moveL_pV _ _ _ p1).
          rewrite p2. clear.
          pose (whiskerR_p1 (ap (ap y) (kp_eq2 x))).
          pose (moveL_pV _ _ _ p1).
          pose (moveL_Vp _ _ _ p2).
          simple refine (p3 @ _). clear. cbn. hott_simpl.
          simple refine (concat_p1 _ @ _ @ concat_p_pp).
          assert (p0 @ cohq x = ap (ap y) (kp_eq2 x)). {
            simple refine (_^ @ ap02_is_ap y (kp_eq2 x)).
            simple refine (KP_rec_beta_kp_eq2 _ _ _ _ _). }
          rewrite X. f_ap.
        + intro g; cbn.
          apply path_forall; intro x.
          admit.                  (* ok : KP_eta *)
    Defined.
  End Cocone.
End Cocone2.


(*** BEGIN HIDE **)

(* And now the final result: warning, the proof script still needs a
   serious clean up... *)
Section ForArthur.

(* We instanciate manually the various bigO constants and bounds. *)
Let M := nat2R 6.
Let M' := nat2R 2.
Let N2 := 2%nat.
Let N1 := 5%nat.

Lemma harm: forall j : nat, (N2 <= j)%nat ->
  (\sum_(1 <= i < j.+1) / nat2R i) <= M' * ((log \o nat2R) j).
Proof.
move=> j le2j.
apply: Rle_trans (Rle_harmonic_log j _) _; first by apply: leq_trans le2j.
rewrite RIneq.double; apply: Rplus_le_compat => //=; rewrite -log_2 -[2]/(nat2R 2).
apply: log_increasingW; first by apply: lt_0_nat2R.
by apply: le_nat2R.
Qed.

Let le2N : (2 <= N1)%nat.
Proof. by []. Qed.

Let le3M'M: nat2R 3 * M' <= M.
Proof. by rewrite /M' -mult_nat2R. Qed.

Let le0M' : 0 <= M'.
  by rewrite -[0]/(nat2R 0); apply: le_nat2R.
Qed.

Let le0M : 0 <= M.
by apply: le_0_nat2R.
Qed.

Let ltN2ltN1 : nat2R N2 < log (nat2R N1).
Proof.
rewrite -[nat2R N2]log_pow.
have -> : 2 ^ N2 = nat2R 4 by rewrite -[4%nat]/(2 ^ 2)%nat nat2Rpow.
apply: log_increasing; last by apply: lt_nat2R.
by apply: lt_0_nat2R.
Qed.

Lemma log_log_ge0 n : (N1 <= n)%nat -> 0 <= log (log (nat2R n)).
Proof.
move=> leN1n; apply: log_ge_0; apply: log_ge_1; apply: (le_nat2R 2).
by apply: leq_trans leN1n.
Qed.

Theorem bigO_sum_primeV n : (N1 <= n)%nat ->
 \sum_(1 <= p < n.+1 | prime p) / (nat2R p) <= M * (log (log (nat2R n))).
Proof.
move=> leNn; set S := (X in X <= _).
(* We introduce the least m such that n <= 2 ^ m, and its properties *)
(* may be better with up? *)
have /nfloor_ex [m [lemlogn lelogmSm]]: 0 <= log (nat2R n).
  apply: Rlt_le; apply: log_gt_0; apply: (lt_nat2R 1).
  by apply: leq_trans leNn.
rewrite -nat2RE in lemlogn.
have {lelogmSm} lelogmSm: log (nat2R n) < nat2R m.+1 by rewrite S_nat2R.
have lt0n : (0 < n)%nat by apply: leq_trans leNn; apply: ltn_trans le2N.
have lt0N : 0 < nat2R n by apply: (lt_nat2R 0).
have le1logn : 1 <= log (nat2R n).
  rewrite -log_2. apply: log_increasingW; auto; apply: (le_nat2R 2).
  by apply: leq_trans leNn.
have lt0m : (0 < m)%nat.
  by case: (posnP m)=> // em0; move/Rgt_not_le: lelogmSm; rewrite em0.
have lenm : (n.+1 <= (2 ^ m.+1).+1)%nat.
  rewrite ltnS; apply: nat2R_le.
  apply: log_le_inv => //; first by apply: lt_0_nat2R; rewrite expn_gt0.
  by rewrite nat2Rpow log_pow; apply: Rlt_le.
have leNm : (N2 <= m)%nat.
 rewrite -ltnS; apply: nat2R_lt. apply: Rlt_trans lelogmSm.
 apply: Rlt_le_trans ltN2ltN1 _; apply: log_increasingW.
   by apply: lt_0_nat2R; apply: ltn_trans le2N.
 by apply: le_nat2R.
(* We majorize S by the same sum up to 2^m.+1 *)
have t1 : S <= \sum_(1 <= p < (2 ^ m.+1).+1 | prime p) / nat2R p.
  rewrite (big_cat_nat _ _ _ _ lenm) //= -(Rplus_0_r S).
  apply: Rplus_le_compat_l; apply sumR_ge0=> i; rewrite mem_iota; case/andP=> ltin.
  move=> _ _. apply: Rlt_le; apply: Rinv_0_lt_compat; apply: (lt_nat2R 0).
  by apply: ltn_trans ltin.
apply: Rle_trans t1 _ => {S}; set S := (X in X <= _).
have t2 : M * (log (nat2R m)) <= M * log (log (nat2R n)).
  apply: Rmult_le_compat_l => //.
  apply: log_increasingW=> //; exact: lt_0_nat2R.
apply: Rle_trans t2=> {lt0n lelogmSm lt0N lenm leNn lemlogn le1logn n}.
(* We express S as a double sum. *)
have {S} -> : S = / nat2R 2 +
   \sum_(1 <= k < m.+1) \sum_((2 ^ k).+1 <= p <
      (2 ^ k.+1).+1 | prime p) / nat2R p.
  rewrite {}/S; elim: m lt0m {leNm} => [|m ihm] // _.
  rewrite [in RHS]big_nat_recr //=.
  have le2m: ((2 ^ m.+1).+1 <= (2 ^ m.+2).+1)%nat by rewrite ltnS leq_exp2l.
  rewrite [LHS](big_cat_nat _ _ _ _ le2m) ?expn_gt0 //= -[RHS]Rplus_assoc.
  congr (_ + _) => //; case: (posnP m) => [-> | lt0m]; last exact: ihm.
  rewrite expn1 [in RHS]big_nil big_mkcond /= 2?big_nat_recr //= big_nil.
  by rewrite !Rplus_0_l Rplus_0_r.
(* We introduce the harmonic sum S' and majorize S using S' *)
pose S' := \sum_(1 <= k < m.+1) / nat2R k. set S := (X in _ + X <= _).
have majSS' : S <= nat2R 2 * S'.
  rewrite /S' big_distrr /=; apply: leR_sum=> /= i; rewrite mem_iota subn1 /=.
  rewrite  add1n => /andP [lt0i ltiSm] _.
  have -> : (2 ^ i.+1 = (2 ^ i).*2)%nat by rewrite expnS mul2n.
  apply: Rle_trans (le_sum_inv (2 ^ i)%nat _) _.
    by rewrite -[1%nat]/(2 ^ 0)%nat ltn_exp2l.
  apply: Rmult_le_compat_l; first by apply: (le_nat2R 0 2).
  apply: Rinv_le_contravar; first by apply: lt_0_nat2R.
  by rewrite nat2Rpow log_pow.
have {majSS'} majSS' : / nat2R 2 +  S <= / nat2R 2 + nat2R 2 * S'.
   by apply: Rplus_le_compat_l.
apply: Rle_trans majSS' _.
have {S} majS' : / nat2R 2 + nat2R 2 * S' <= nat2R 3 * S'.
  have -> : nat2R 3 * S' = S' + nat2R 2 * S'.
    rewrite -[X in _ = X + _]Rmult_1_l -Rmult_plus_distr_r.
    by rewrite  -[nat2R 1 + _]plus_nat2R.
  apply: Rplus_le_compat_r. rewrite /S' big_nat_recl //.
  rewrite -[/ 2]Rplus_0_r; apply: Rplus_le_compat.
    apply:  Rinv_le_contravar => //.
    by apply: (le_nat2R 1 2).
  apply: sumR_ge0 => i; rewrite mem_iota; case/andP=> lt0i _ _.
  apply: Rlt_le; apply: Rinv_0_lt_compat.
  by apply: lt_0_nat2R.
apply: Rle_trans majS' _.
(* Std majorization of the harmonic series *)
have maj_harm : nat2R 3 * S' <= nat2R 3 * M' * (log (nat2R m)).
  rewrite Rmult_assoc; apply: Rmult_le_compat_l; last first.
    exact: Rle_trans (harm _ leNm) _.
  by rewrite -[0]Rplus_0_l; apply Rplus_le_compat.
apply: Rle_trans maj_harm _; apply: Rmult_le_compat_r=> //.
by apply: log_ge_0; apply: (le_nat2R 1).
Qed.

End ForArthur.

(** END HIDE **)