(** Calculation of an abstract machine for the call-by-need lambda
calculus + arithmetic. *)

Require Import List.
Require Import ListIndex.
Require Import Tactics.
Require Import Heap.

(** * Syntax *)

Inductive Expr : Set :=
| Val : nat -> Expr
| Add : Expr -> Expr -> Expr
| Var : nat -> Expr
| Abs : Expr -> Expr
| App : Expr -> Expr -> Expr.

(** * Semantics *)

(** The evaluator for this language is taken from Ager et al. "A
functional correspondence between call-by-need evaluators and lazy
abstract machines". We use Haskell syntax to define the
evaluator. Moreover, we use an abstract interface to a heap
implementation:
<<
type Heap a
type Loc

empty :: Heap a
deref :: Heap a -> Loc -> a
update :: Heap a -> Loc -> a -> Heap a
alloc :: Heap a -> a -> (Heap a, Loc)
>>
Moreover, we assume that `Heap` forms a functor with an associated function
<<
hmap :: (a -> b) -> Heap a -> Heap b
>>
which in addition to functoriality also satisfies the following laws:
<<
hmap f empty = empty                                             (hmap-empty)
deref (hmap f h) l = f (deref h l)                               (hmap-deref)
hmap f (update h l e) = update (hmap f h) l (f e)                (hmap-update)
alloc (hmap f h) (f e) = (h', l) <=> alloc h e = (hmap f h', l)  (hmap-alloc)
>>

The evaluator itself is defined as follows:
<<
type Env   = [Loc]
data HElem = Thunk (Heap HElem -> (Value, Heap HElem)) | Value Value
data Value = Num Int | Clo (Loc -> Heap HElem -> (Value, Heap HElem))

eval :: Expr -> Env -> Heap HElem -> (Value, Heap HElem)
eval (Val n)   e h = (Num n, h)
eval (Add x y) e h = case eval x e h of
                       (Num n, h') -> case eval y e h' of
                                        (Num m, h'') -> (Num (n + m), h'')
eval (Var i)   e h = case deref h (e !! i) of
                       Thunk t -> let (v, h') = t h
                                  in (v, update h' (e !! i) (Value v))
                       Value v -> (v, h)
eval (Abs x)   e h = (Clo (\ l h' -> eval x (l : e) h') , h)
eval (App x y) e h = case eval x e h of
                       (Clo , h') -> let (h'',l) = alloc h' (Thunk (\h -> eval y e h))
                                     in f l h''
>>
After defunctionalisation and translation into relational form we
obtain the semantics below.  *)

Definition Env : Set := list Loc.

Inductive Value : Set :=
| Num : nat -> Value
| Clo : Expr -> Env -> Value.

Inductive HElem : Set  :=
  | thunk : Expr -> Env -> HElem
  | value : Value -> HElem.

Definition Heap := Heap.Heap HElem.

Reserved Notation "x ⇓[ e , h , h' ] y" (at level 80, no associativity).

Inductive eval : Expr -> Env -> Heap -> Heap -> Value -> Prop :=
| eval_val e n (h h' : Heap) : Val n ⇓[e,h,h] Num n
| eval_add e x y m n h h' h'' : x ⇓[e,h,h'] Num n -> y ⇓[e,h',h''] Num m -> Add x y ⇓[e,h,h''] Num (n + m)
| eval_var_thunk e e' x i l v h h' : nth e i = Some l -> deref h l = Some (thunk x e') -> x ⇓[e',h,h'] v ->
                          Var i ⇓[e,h,update h' l (value v)] v
| eval_var_val e i l v h : nth e i = Some l -> deref h l = Some (value v) ->
                          Var i ⇓[e,h,h] v
| eval_abs e x h : Abs x ⇓[e,h,h] Clo x e
| eval_app e e' x x' x'' y l h h' h'' h''' : x ⇓[e,h,h'] Clo x' e' -> alloc h' (thunk y e) = (h'',l) ->
                              x' ⇓[l :: e',h'',h'''] x'' -> App x y ⇓[e,h,h'''] x''
where "x ⇓[ e , h , h' ] y" := (eval x e h h' y).

(** * Abstract machine *)

Inductive CONT : Set :=
| ADD : nat -> CONT -> CONT
| NEXT : Expr -> Env -> CONT -> CONT
| UPDATE : Loc -> CONT -> CONT
| APP : Expr -> Env -> CONT -> CONT
| HALT : CONT
.

Inductive Conf : Set :=
| eval'' : Expr -> Env -> Heap -> CONT -> Conf
| apply : CONT -> Heap -> Value -> Conf.

Notation "⟨ x , e , h , c ⟩" := (eval'' x e h c).
Notation "⟪ c , h , v ⟫" := (apply c h v).

Reserved Notation "x ==> y" (at level 80, no associativity).
Inductive AM : Conf -> Conf -> Prop :=
| am_val n e h c :  ⟨Val n, e, h, c⟩ ==> ⟪c, h, Num n⟫
| am_add x y e h c : ⟨Add x y, e, h, c ⟩ ==> ⟨x, e, h, NEXT y e c⟩
| am_var i e h c l x e' :   nth e i = Some l -> deref h l = Some (thunk x e') ->
                            ⟨Var i, e, h, c⟩ ==> ⟨x, e', h, UPDATE l c⟩
| am_var_val i e h c l v : nth e i = Some l -> deref h l = Some (value v) ->
                           ⟨Var i, e, h, c⟩ ==> ⟪c, h, v⟫
| am_abs x e h c : ⟨Abs x, e, h, c ⟩ ==> ⟪c, h, Clo x e ⟫
| am_app x y e h c : ⟨App x y, e, h, c ⟩ ==> ⟨x, e, h, APP y e c⟩
| am_ADD n c h'' m : ⟪ADD n c, h'', Num m⟫ ==> ⟪c, h'', Num (n + m)⟫
| am_NEXT y e c h' n : ⟪NEXT y e c, h', Num n ⟫ ==> ⟨y, e, h', ADD n c⟩
| am_UPDATE l c h' v : ⟪UPDATE l c, h', v ⟫ ==> ⟪c, update h' l (value v), v ⟫
| am_APP y e c h' x' e' h'' l : alloc h' (thunk y e) = (h'', l) ->
                                ⟪APP y e c, h', Clo x' e' ⟫ ==> ⟨x', l :: e', h'', c ⟩

where "x ==> y" := (AM x y).

(** * Calculation *)

(** Boilerplate to import calculation tactics *)

Module VM <: Preorder.
Definition Conf := Conf.
Definition VM := AM.
End VM.
Module VMCalc := Calculation VM.
Import VMCalc.

(** Specification of the abstract machine *)

Theorem spec x e v c h h' : x ⇓[e,h,h'] v -> ⟨x, e, h, c⟩
                                 =>> ⟪c, h' , v⟫.

(** Setup the induction proof *)

Proof.
  intros.
  generalize dependent c.
  induction H;intros.

(** Calculation of the abstract machine *)

(** - [Val n ⇓[e,h,h] Num n]: *)

  begin
  ⟪c, h, Num n⟫.
  <== { apply am_val }
  ⟨Val n, e, h, c⟩.
  [].

(** - [Add x y ⇓[e,h,h''] Num (m + n)]: *)

  begin
    ⟪c, h'', Num (n + m)⟫.
  <== { apply am_ADD }
    ⟪ADD n c, h'', Num m⟫.
  <<= { apply IHeval2 }
   ⟨y, e, h', ADD n c⟩.
  <== { apply am_NEXT }
   ⟪NEXT y e c, h', Num n ⟫.
  <<= { apply IHeval1 }
   ⟨x, e, h, NEXT y e c⟩.
  <== {apply am_add}
   ⟨Add x y, e, h, c ⟩.
  [].

(** - [Var i ⇓[e,h,update h' l (value v)] v] *)

  (* assert (deref (convH h) l = Some (thunk' (comp' x WRITE) e')) *)
  (*   by (unfold convH; rewrite hmap_deref; rewrite H0; reflexivity). *)
  begin
    ⟪c, update h' l (value v), v ⟫.
  <== {apply am_UPDATE }
    ⟪UPDATE l c, h', v ⟫.
  <<= {apply IHeval}
    ⟨x, e', h, UPDATE l c⟩.
  <== {apply am_var}
    ⟨Var i, e, h, c⟩.
  [].

(** - [Var i ⇓[e,h,h] v] *)

  begin
    ⟪c, h, v ⟫.
  <== {eapply am_var_val}
    ⟨Var i, e, h, c⟩.
  [].

(** - [Abs x ⇓[e,h,h] Clo x e] *)

  begin
    ⟪c, h, Clo x e ⟫.
  <== { apply am_abs }
    ⟨Abs x, e, h, c ⟩.
  [].

(** - [App x y ⇓[e,h,h'''] x''] *)

  begin
    ⟪c, h''', x'' ⟫.
  <<= { apply IHeval2 }
    ⟨x', l :: e', h'', c ⟩.
  <== { apply am_APP }
    ⟪APP y e c, h', Clo x' e' ⟫.
  <<= { apply IHeval1 }
    ⟨x, e, h, APP y e c⟩.
  <== { apply am_app }
    ⟨App x y, e, h, c ⟩.
  [].
Qed.

(** * Soundness *)

(** Custom tactic to apply inversion *)
Ltac inv := match goal with
              | [H1 : nth ?e ?i = Some ?l1,
                 H2 : nth ?e ?i = Some ?l2 |- _] => rewrite H1 in H2; inversion H2; subst; clear H1 H2
              | [H1 : deref ?h ?l = Some ?v1,
                 H2 : deref ?h ?l = Some ?v2 |- _] => rewrite H1 in H2; inversion H2; subst; clear H1 H2
              | [H1 : alloc ?h ?l = _,
                 H2 : alloc ?h ?l = _ |- _] => rewrite H1 in H2; inversion H2; subst; clear H1 H2
              | _ => idtac
            end.

Lemma determ_vm : determ AM.
  intros C C1 C2 V. induction V; intro V'; inversion V'; subst; repeat inv; reflexivity.
Qed.

Definition terminates (p : Expr) : Prop := exists r h, p ⇓[nil,empty,h] r.

Theorem sound x C : terminates x -> ⟨x, nil, empty , HALT⟩ =>>! C ->
                          exists v h, C = ⟪HALT, h, v⟫ /\ x ⇓[nil,empty,h] v.
Proof.
  unfold terminates. intros. destruct H as [r T]. destruct T as [h T].

  pose (spec x nil r HALT) as H'. exists r. exists h. split. pose (determ_trc determ_vm) as D.
  unfold determ in D. eapply D. eassumption. split. apply H'. assumption. intro Con. destruct Con.
  inversion H. assumption.
Qed.


From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat div seq.
From mathcomp Require Import choice fintype prime tuple finfun finset bigop.
Require Import tree_traversal rank_select.

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

Section insert_delete.

  Variable T : Type.

  Definition insert (s t : seq T) i :=
    take i s ++ t ++ drop i s.

  Lemma insert_nil s i : insert s [::] i = s.
  Proof. by rewrite /insert /= cat_take_drop. Qed.

  Definition insert1 s x i := insert s [:: x] i.

  Lemma insert_catL s b i t : i < size s ->
    insert (s ++ t) b i = insert s b i ++ t.
  Proof. move=> si; by rewrite /insert take_cat drop_cat si -2!catA. Qed.

  Lemma insert_catR s b i t : i >= size s ->
    insert (s ++ t) b i = s ++ insert t b (i - size s).
  Proof. move=> si; by rewrite /insert take_cat drop_cat ltnNge si /= -catA. Qed.

  Lemma size_insert (s : seq T) x i : size (insert s x i) = size s + size x.
  Proof. by rewrite /insert -{3}(cat_take_drop i s) !size_cat addnAC addnA. Qed.

  Lemma size_insert1 s (x : T) n : size (insert1 s x n) = (size s).+1.
  Proof. by rewrite size_insert addn1. Qed.

  Lemma size_insert1_pos (s : seq T) x i : size (insert1 s x i) > 0.
  Proof. by rewrite size_insert1. Qed.

  Lemma nth_insert1 (s : seq T) x0 x i :
    i <= size s -> nth x0 (insert1 s x i) i = x.
  Proof.
    move=> His. rewrite /insert1 nth_cat.
    by rewrite ifF size_takel // ?ltnn // subnn.
  Qed.

  Lemma insert_cat s t v i :
    insert s (t ++ v) i = insert (insert s t i) v (i + size t).
  Proof.
  elim: s t v i => [s1 s2 i|x1 x2 IH x v [|i]]; rewrite /insert.
    by rewrite ?(take_oversize,leq_addl,drop_oversize,cats0).
  by rewrite /= add0n ?(take_cat,ltnn,subnn,take0,cats0,drop_cat,drop0,catA).
  by rewrite addSn /= -/(insert _ _ _) IH.
  Qed.

  Lemma insert_head (s xs : seq T) x i :
    insert s (x :: xs) i = insert (insert1 s x i) xs i.+1.
  Proof. by rewrite -cat1s insert_cat addn1. Qed.

  Definition delete (s : seq T) i :=
    take i s ++ drop (i.+1) s.

  Lemma delete_nil i : delete [::] i = [::].
  Proof. by []. Qed.

  Lemma size_take_leq i (s : seq T) : size (take i s) <= i.
  Proof. rewrite size_take; case: ifP => Hi //; by rewrite leqNgt Hi. Qed.

  Lemma nth_delete (s : seq T) i x0 n :
    nth x0 (delete s i) n = if n >= i then nth x0 s (n.+1)
                            else nth x0 s n.
  Proof.
    elim: s n i => [|h t IHt] //= n i.
      by rewrite delete_nil nth_nil if_same.
    rewrite /delete in IHt *.
    case: i => /= [|i]. by rewrite drop0.
    case: n => // n. by rewrite ltnS -IHt.
  Qed.

  Lemma size_delete (s : seq T) i :
    i < size s -> size (delete s i) = (size s).-1.
  Proof.
    rewrite /delete size_cat size_take size_drop => Hi.
    rewrite Hi -addn1 -subn1 addnBA addnC //=.
    by rewrite subnDA addnK.
  Qed.

  Lemma delete_insert1 (s : seq T) x i :
    i <= size s -> delete (insert1 s x i) i = s.
  Proof.
    move=> His.
    rewrite /delete /insert1 take_cat ifF size_takel // ?ltnn //.
    rewrite subnn /= cats0 drop_cat size_takel // ifF.
      by rewrite -addn1 addKn /= drop0 cat_take_drop.
    by rewrite ltnNge leqnSn.
  Qed.

  Lemma delete_oversize (s : seq T) i : i >= size s -> delete s i = s.
  Proof.
    move => H. rewrite /delete take_oversize. rewrite drop_oversize.
    by rewrite cats0.
    apply: leq_trans. apply: H. by rewrite leq_eqVlt ltnSn orbT. exact.
  Qed.

  Lemma delete_catL s i t : i < size s ->
    delete (s ++ t) i = delete s i ++ t.
  Proof.
    move => H. rewrite /delete take_cat H.
    rewrite drop_cat.
    case: ifP => Hif. rewrite catA //=.
    move/negbT: (Hif). rewrite -leqNgt leq_eqVlt.
    rewrite ltnNge H //= orbF. move/eqP => ->.
    rewrite subnn drop0 [in RHS]drop_oversize //=.
    rewrite cats0 //=. by rewrite leqNgt Hif.
  Qed.

  Lemma delete_catR s i t : i >= size s ->
    delete (s ++ t) i = s ++ delete t (i - size s).
  Proof.
    move => H. rewrite /delete take_cat ltnNge H //= drop_cat ltnNge.
    by rewrite leqW //= catA subSn.
  Qed.

  Lemma delete_cat s t i:
    delete (s ++ t) i =
    if i < size s then delete s i ++ t
                  else s ++ delete t (i - size s).
  Proof.
    case:ifP => H; first by apply delete_catL.
    by rewrite delete_catR // leqNgt H.
  Qed.

End insert_delete.

Section insert_delete_eqtype.
  Variable T : eqType.

  Lemma in_drop_take (s : seq T) x i :
    x \in s -> (x \in (take i s)) || (x \in (drop i s)).
  Proof. by rewrite -mem_cat cat_take_drop. Qed.

  Lemma in_insert1 (s : seq T) x0 x i :
    x0 \in s -> x0 \in (insert1 s x i).
  Proof. move=> Hi; by rewrite mem_cat in_cons orbCA in_drop_take // orbT. Qed.

  Lemma count_insert (b : T) s t n :
    count_mem b (insert s t n) = count_mem b s + count_mem b t.
  Proof. by rewrite !count_cat addnCA -count_cat cat_take_drop addnC. Qed.

  Lemma count_insert1 (b : T) s x n :
    count_mem b (insert1 s x n) = count_mem b s + (x == b).
  Proof. by rewrite /insert1 count_insert /= addn0. Qed.

End insert_delete_eqtype.

Section insert_delete_rank.
Variable A : eqType.

  Lemma rank_insert1 (s : seq A) b0 b i :
    rank b0 (size (insert1 s b i)) (insert1 s b i) =
    if b == b0 then 1 + rank b0 (size s) s else rank b0 (size s) s.
  Proof. rewrite /rank !take_size count_insert1 addnC; by case: ifP. Qed.

  (* Obvious corollary *)
  Corollary rank_insert1_geq (s : seq A) b0 b i :
    rank b0 (size (insert1 s b i)) (insert1 s b i) >= rank b0 (size s) s.
  Proof. rewrite rank_insert1. case: (b == b0) => //. Qed.

  Lemma rank_insert (s t : seq A) b0 i :
    rank b0 (size (insert s t i)) (insert s t i) =
    rank b0 (size s) s + rank b0 (size t) t.
  Proof. by rewrite /rank !take_size count_insert addnC. Qed.

End insert_delete_rank.

Section delete_with_return.

  Variable T : Type.

  Definition delete_ret x0 (s : seq T) i := (take i s ++ drop (i.+1) s,
                                             nth x0 s i).

  Lemma delete_delete_ret x0 (s : seq T) i :
    delete_ret x0 s i = (delete s i, nth x0 s i).
  Proof. by rewrite /delete /delete_ret. Qed.

  Lemma delete_ret_oversize x0 (s : seq T) i :
    i >= size s -> delete_ret x0 s i = (s, x0).
  Proof.
    move => H.
    rewrite /delete_ret take_oversize // drop_oversize.
      by rewrite cats0 nth_default.
    by apply (leq_trans H).
  Qed.

  Lemma delete_ret_insert1 x0 (s : seq T) x i :
    i <= size s -> delete_ret x0 (insert1 s x i) i = (s, x).
  Proof.
    move => His.
    by rewrite delete_delete_ret delete_insert1 ?nth_insert1.
  Qed.

End delete_with_return.

Section insert_delete_bit.

  Definition count_one := count_mem true.

  Definition access := nth false.

  Lemma count_delete s i : count_one s - access s i = count_one (delete s i).
  Proof.
    rewrite /count_one /access /delete.
    case Hi: (i < size s).
    rewrite -(cat_take_drop i s) !count_cat cat_take_drop (drop_nth false) //=.
    case: (nth false s i) => //=. by rewrite addnCA addnC addnK.
    by rewrite add0n subn0.
    rewrite count_cat drop_oversize. rewrite take_oversize;
    try rewrite /= addn0 nth_default /=; try (by rewrite subn0);
    try (by rewrite leqNgt Hi).
    move/negbT: Hi. rewrite ltnNge. move/negbNE => Hi.
    apply: leq_trans. apply: Hi. apply: leqnSn.
  Qed.

End insert_delete_bit.


Add LoadPath "../Coq".

Require Import Homotopy.

Set Implicit Arguments.

(* Jesse McKeown, Wednesday 23 May 2012
  While a PhD student in the Department of Mathematics
  at the University of Toronto *)

Section Sections.

  Hypothesis A : Type.
  Hypothesis P Q : A -> Type.
  Hypothesis f : section P -> section Q.
  Hypothesis s : section P.
  Hypothesis t : section Q.
  Hypothesis h k : f s == t.

  Lemma happly_htp_of_sectn :
   forall hh : h == k,
    forall a : A,
    happly_dep h a == happly_dep k a.
    intro H. intro a.
    apply_happly.
    apply map.
    auto.
  Defined.

End Sections.

Section TransHomotopy.

  Hypothesis A B : Type.
  Hypothesis P : B -> Type.

   Hypothesis f g : A -> section P.
   Hypothesis x y : A.

  Section TQ.

   Hypothesis p : x == y.
   Hypothesis q : f x === g x.

   Definition tq : f y === g y.
    apply (transport (P := fun a => f a === g a) p).
    exact q.
   Defined.

   End TQ.

   Lemma trans_hpaths :
    forall (p : x == y) (q : f x === g x) b,
     tq p q b == ! happly_dep (map f p) b @ q b @ happly_dep (map g p) b.
     intro p.
     intro q.
     intro b.
     unfold tq.
     induction p.
     simpl.
     set (w := q b).
     clearbody w.
     induction w. simpl. auto.
   Defined.

End TransHomotopy.

(**  Polymorphism over Set would allow us to define pushouts as the representing
  domain for maps from a disjoint union satisfying a parametrized family of
  equations. That is, *)

Definition polyMorphicNonDepPushout {A B C : Type} (f : A -> B) (g : A -> C)
 := forall (X : Type)(F : B -> X)(G : C -> X)(h : F o f == G o g), X.

  (** ... and that would work very well. so far as it goes, but Mike Shulman
  doubts one can prove dependent induction for these things. So we do the next-
  best thing. *)

Axiom pushout : forall { A B C : Type } (f : A -> B) (g : A -> C), Type.

Axiom pushout_ends : forall { A B C : Type } (f : A -> B) (g : A -> C),
 B + C -> pushout f g.

Definition po_from_b { A B C : Type} (f : A -> B)( g: A -> C)
  := (pushout_ends f g) o (@inl B C).

Definition po_from_c { A B C : Type} (f : A -> B)( g: A -> C)
 := (pushout_ends f g) o (@inr B C).

Axiom pushout_cyl : forall { A B C : Type } (f : A -> B) (g : A -> C),
 (po_from_b f g o f) == (po_from_c f g o g).

(** We have declared a space with two maps into it and some relations between
  them. The defining character of the pushout is that it's weakly-initial among
  such spaces-with-maps. *)

Section PushOutImplicitPolymorphism.

  Hypotheses A B C : Type.
  Hypotheses (f : A -> B) (g : A -> C).

  Let po := pushout f g.
  Let p_from_b := po_from_b f g.
  Let p_from_c := po_from_c f g.
  Let p_cyl := pushout_cyl f g.

  (** our by polymorphism we mean universalizing over dependent types over the
  assumed space po *)

  Hypotheses X : po -> Type.

  Let GlobalSection := forall p : po, X p.
  Let BSection := section ( X o p_from_b ).
  Let CSection := section ( X o p_from_c ).

  (** Sections localize in various ways *)

  Let B_From_P : GlobalSection -> BSection.
   intros ss b.
   apply ss.
  Defined.
  Let C_From_P : GlobalSection -> CSection.
   intros ss c.
   apply ss.
  Defined.

  (** there ISN'T a canonical map from [A] to [po]; rather, there are too many *)

  Let ASection ( F : A -> po ) := section (X o F).
  Let ABSection := ASection (p_from_b o f).
  Let ACSection := ASection (p_from_c o g).

  (** more restriction maps *)

  Let AB_From_B : BSection -> ABSection.
   intros ss a. apply ss.
  Defined.
  Let AC_From_C : CSection -> ACSection.
   intros ss a. apply ss.
  Defined.

  (** There are two obvious ways to restrict from global sections down to [A];
    they are equivalent in a natural way. *)

  Let Compare_B_C : ABSection -> ACSection.
   intros ss a.
   assert ( path_in_po := happly p_cyl a).
   exact (transport (path_in_po) (ss a)).
  Defined.
  Let Compare_C_B : ACSection -> ABSection.
   intros ss a.
   exact (transport (happly (! p_cyl) a) (ss a)).
  Defined.

  (** This isn't used that I can think of, but it's reassuring,
   and surely someone else might want it. Might be rewritten using trans_is_equiv? *)

  Lemma Compare_is_equiv :
   is_equiv Compare_B_C.
   apply (hequiv_is_equiv Compare_B_C Compare_C_B).
   intro y.
   unfold Compare_B_C, Compare_C_B.
   apply funext_dep. intro a.
   path_via (transport (happly p_cyl a) (transport (! happly p_cyl a) (y a))).
    apply (map (fun pp => transport (A := po) pp (y a))).
    apply happly_opp.
   apply (trans_trans_opp (happly p_cyl a)).
   intro x.
   unfold Compare_B_C, Compare_C_B.
   apply funext_dep. intro a.
   path_via (transport (! happly p_cyl a) (transport (happly p_cyl a) (x a))).
    apply (map (fun pp => transport pp (transport (happly p_cyl a) (x a)))).
    apply happly_opp.
   apply (trans_opp_trans (happly p_cyl a)).
  Defined.

  (** This IS used, fairly-soon *)

  Lemma either_way :
  Compare_B_C o AB_From_B o B_From_P == AC_From_C o C_From_P.
   apply funext. intro ss.
   apply funext_dep. intro a.
   unfold Compare_B_C.
   unfold compose.
   unfold AC_From_C, C_From_P, AB_From_B, B_From_P.
   apply map_dep.
  Defined.

  (** Abstraction: the idea Type of restricted data satisfying conditions *)

  Definition sect_data :=
  { bc : BSection * CSection &
       ( Compare_B_C o AB_From_B ) (fst bc) == AC_From_C (snd bc) }.

  (** And define a map of Types *)

  Definition global_section_data : GlobalSection -> sect_data
   := fun gs => ( ( B_From_P gs, C_From_P gs) ; (happly either_way gs)).

  (** The point of having a natural map from hypothetically-derived stuff
   to stuff we already knew about is that we can ask it be an equivalence. *)

  Axiom gsd_is_equiv : is_equiv global_section_data.

  Let pushout_equiv : GlobalSection <~> sect_data
   := (global_section_data ; gsd_is_equiv ).
  Definition pushout_rect := pushout_equiv ^-1.
  Definition pushout_comps : forall y : sect_data, global_section_data (pushout_rect y) == y
  := inverse_is_section pushout_equiv.

  (** OK, this doesn't need to be its own section, but it's sufficiently long
  ago since the last [Hypothesis], it seemed natural to add a layer of
  referential locality *)

  Section POCompRules.

    Hypotheses (sb : BSection)
                      (sc : CSection)
                      ( sh : (Compare_B_C o AB_From_B) sb == AC_From_C sc).
    Let gs : sect_data := ( (sb, sc) ; sh ).

    Let gsr := pushout_rect gs.
    Let rect_data := global_section_data gsr.
    Let gs_comps := pushout_comps gs.

    Definition pushout_comp_bc : pr1 rect_data == ( sb, sc )
     := map pr1 gs_comps.
    Definition pushout_comp_b : fst (pr1 rect_data) == sb
     := map (@fst _ _) pushout_comp_bc.
    Definition pushout_comp_c : snd (pr1 rect_data) == sc
     := map (@snd _ _) pushout_comp_bc.

    Definition pushout_comp_cyl : transport pushout_comp_bc (pr2 rect_data) == sh
    := fiber_path gs_comps.

  End POCompRules.

  Section POPtCompRules.
     Definition psect_data := { bc : BSection * CSection &
       forall a : A, transport (happly p_cyl a) (fst bc (f a)) == snd bc (g a) }.

     Lemma fibrMap : forall (bc : BSection * CSection),
       ( Compare_B_C o AB_From_B ) (fst bc) == AC_From_C (snd  bc) ->
        forall a : A, transport (happly p_cyl a) (fst (idmap _ bc) (f a)) == snd (idmap _ bc) (g a).
       unfold idmap.
       intros bc sh.
       apply (happly_dep sh).
     Defined.

     Let tg := total_map
        (Q := fun bc : BSection * CSection
          => forall a : A, transport (happly p_cyl a) (fst bc (f a)) == snd bc (g a))
       (idmap _ ) fibrMap .

     Lemma sect_psect_equiv : sect_data <~> psect_data.
       exists tg.
       apply total_is_equiv.
       intro.
       unfold fibrMap.
       apply strong_funext_dep.
     Defined.

     Definition pushout_pt_equiv : GlobalSection <~> psect_data :=
       equiv_compose pushout_equiv sect_psect_equiv.

     Definition pushout_pt_rect := pushout_pt_equiv ^-1.
     Definition pushout_pt_comps := inverse_is_section pushout_pt_equiv.

     Hypotheses (sb : BSection)
                       (sc : CSection)
                       ( ph : forall a : A, transport (happly p_cyl a) (sb (f a)) == sc (g a)).
     Let gpd : psect_data := ( (sb, sc) ; ph ).
     Let prect := pushout_pt_rect gpd.
     Let prect_data := tg (global_section_data prect).
     Let pr_comps := pushout_pt_comps ( (sb, sc); ph).

     Definition pushout_pt_comp_bc : pr1 ( prect_data ) == (sb, sc).
       exact (map pr1 pr_comps).
     Defined.
     Definition pushout_pt_comp_b : fst (pr1 prect_data) == sb.
       exact (map (@fst _ _ ) pushout_pt_comp_bc).
     Defined.
     Definition pushout_pt_comp_c : snd (pr1 prect_data) == sc.
       exact (map (@snd _ _) pushout_pt_comp_bc).
     Defined.

     Definition pushout_pt_comp_cyl : transport pushout_pt_comp_bc (pr2 (prect_data)) == ph := fiber_path pr_comps.

     Hypothesis a : A.

     Lemma explicit_ptwise_cyl :  ! map (transport (happly p_cyl a)) (happly_dep pushout_pt_comp_b (f a)) @
       map_dep prect (happly p_cyl a)
          == ph a @ ! (happly_dep pushout_pt_comp_c (g a)).
       moveleft_onright.
       set (help1 := happly_dep pushout_pt_comp_cyl a).
       apply (fun p => p @ help1 ).
       unfold fibrMap in tg.
       unfold total_map in tg.
       assert (help2 := trans_hpaths  (Compare_B_C o AB_From_B o @fst _ _)
                                                    (AC_From_C o @snd _ _)
                      (pushout_pt_comp_bc)).
       simpl in help2.
       unfold idmap in help2.
       unfold tq in help2.
       set ( W := pr2 prect_data ).
       simpl in W.
       unfold Compare_B_C, AB_From_B, AC_From_C, compose in help2.
       simpl in help2.
       set ( help3 := help2 W a).
       unfold happly_dep in help3.
       unfold happly_dep.
       apply (fun p => p @ ! help3).
       unfold W.
       unfold pushout_pt_comp_b.
       unfold pushout_pt_comp_c.
       unfold happly_dep.

       assert ( map (fun h => h (g a)) (map (snd (B := CSection)) pushout_pt_comp_bc) ==
                  map (fun h => h a) (map (fun x a0 => snd x (g  a0)) pushout_pt_comp_bc ) ).
       undo_compose_map.
       apply (fun q => concat2 q X0).

       assert ( map (transport (happly p_cyl a))
                    (map (fun h => h (f a)) (map (fst (B := CSection)) pushout_pt_comp_bc)) ==
                  map (fun h => h a) (map (fun (x : BSection * CSection ) a0 => transport (happly p_cyl a0) (fst x (f a0))) pushout_pt_comp_bc) ).
       undo_compose_map.
       apply (concat2 (map opposite X1)).

       unfold either_way. simpl.

       assert ( help4 := funext_compute (fun ss : GlobalSection =>
                                                              funext_dep (fun a0 => map_dep ss (happly p_cyl a0))) prect).
       fold funext in help4.
       path_via (map (fun h : ACSection => h a) (funext_dep (fun a0 => map_dep prect (happly p_cyl a0)))).

       unfold ACSection. unfold ASection.
       path_via (happly_dep (funext_dep (fun a0 => map_dep prect (happly p_cyl a0))) a ).
       assert (help5 := funext_dep_compute (fun a0 => map_dep prect (happly p_cyl a0)) a).
       fold funext_dep in help5.
       simpl in help5.
       exact (! help5 ).
    Defined.
  End POPtCompRules.

End PushOutImplicitPolymorphism.


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