(** * Functors

Authors: Benedikt Ahrens, Chris Kapulkin, Mike Shulman (January 2013)

*)

(** ** Contents:

  - preserve isos, inverses
  - Conservative functors ([conservative])
  - Composition of functors, identity functors
  - fully faithful functors
    - preserve isos, inverses, composition backwards
  - (Split) essentially surjective functors
  - faithful
  - full
  - fully faithful is the same as full and faithful
  - Image of a functor, full subcat specified by a functor

*)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.MoreFoundations.PartA.
Require Import UniMath.MoreFoundations.Univalence.
Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.TransportMorphisms.
Require Import UniMath.CategoryTheory.Core.Univalence.

Local Open Scope cat.

(** * Functors : Morphisms of precategories *)
Section functors.

Definition functor_data (C C' : precategory_ob_mor) : UU :=
  total2 ( fun F : ob C -> ob C' =>  ∏ a b : ob C, a --> b -> F a --> F b).

Definition make_functor_data {C C' : precategory_ob_mor} (F : ob C -> ob C')
           (H : ∏ a b : ob C, a --> b -> F a --> F b) : functor_data C C' := tpair _ F H.

Lemma functor_data_isaset (C C' : precategory_ob_mor) (hs : has_homsets C') (hsC' : isaset C') :
  isaset (functor_data C C').
Proof.
  change isaset with (isofhlevel 2).
  apply isofhleveltotal2.
  apply impred; intro.
  apply hsC'.
  intro.
  do 3 (apply impred; intro).
  apply hs.
Qed.

Definition functor_data_constr (C C' : precategory_ob_mor)
           (F : ob C -> ob C') (Fm : ∏ a b : ob C, a --> b -> F a --> F b) :
  functor_data C C' := tpair _ F Fm .

Definition functor_on_objects {C C' : precategory_ob_mor}
     (F : functor_data C C') :  ob C -> ob C' := pr1 F.
Coercion functor_on_objects : functor_data >-> Funclass.

Definition functor_on_morphisms {C C' : precategory_ob_mor} (F : functor_data C C')
  { a b : ob C} :  a --> b -> F a --> F b := pr2 F a b.

Notation "# F" := (functor_on_morphisms F) (at level 3) : cat.

Definition functor_idax {C C' : precategory_data} (F : functor_data C C') :=
  ∏ a : ob C, #F (identity a) = identity (F a).

Definition functor_compax {C C' : precategory_data} (F : functor_data C C') :=
  ∏ a b c : ob C, ∏ f : a --> b, ∏ g : b --> c, #F (f · g) = #F f · #F g .

Definition is_functor {C C' : precategory_data} (F : functor_data C C') :=
  ( functor_idax F ) × ( functor_compax F ) .

Lemma isaprop_is_functor (C C' : precategory_data) (hs: has_homsets C')
      (F : functor_data C C') : isaprop (is_functor F).
Proof.
  apply isofhleveldirprod.
  apply impred; intro.
  apply hs.
  do 5 (apply impred; intro).
  apply hs.
Qed.

Definition functor (C C' : precategory_data) : UU :=
  total2 ( λ F : functor_data C C', is_functor F ).

Notation "a ⟶ b" := (functor a b) : cat.
(* to input: type "\-->" with Agda input method *)

Definition make_functor {C C' : precategory_data} (F : functor_data C C') (H : is_functor F) :
  functor C C'.
Proof.
exists F.
exact H.
Defined.

Lemma functor_data_eq_prf (C C': precategory_ob_mor) (F F' : functor_data C C')
      (H : ∏ c, F c = F' c)
      (H1 : ∏ C1 C2 (f : C1 --> C2),
            double_transport (H C1) (H C2) (pr2 F C1 C2 f) =
            pr2 F' C1 C2 f) :
  transportf (λ x : C → C', ∏ a b : C, C ⟦ a, b ⟧ → C' ⟦ x a, x b ⟧)
    (funextfun F F' (λ c : C, H c)) (pr2 F) = pr2 F'.
Proof.
use funextsec. intros C1. use funextsec. intros C2. use funextsec. intros f.
assert (e : transportf (λ x, ∏ a b : C, a --> b → x a --> x b)
                       (funextfun F F' (λ c : C, H c)) (pr2 F) C1 C2 f =
            transportf (λ x, x C1 --> x C2)
                       (funextfun F F' (λ c : C, H c)) (pr2 F C1 C2 f)).
{ now induction (funextfun F F' (λ c, H c)). }
rewrite e, transport_mor_funextfun, transport_source_funextfun, transport_target_funextfun.
exact (H1 C1 C2 f).
Qed.

Lemma functor_data_eq (C C': precategory_ob_mor) (F F' : functor_data C C')
      (H : F ~ F') (H1 : ∏ C1 C2 (f : C1 --> C2),
            double_transport (H C1) (H C2) (pr2 F C1 C2 f) =
            pr2 F' C1 C2 f) :
      F = F'.
Proof.
use total2_paths_f.
- use funextfun. intros c. exact (H c).
- now apply functor_data_eq_prf.
Defined.

Lemma functor_eq (C C' : precategory_data) (hs: has_homsets C') (F F': functor C C'):
    pr1 F = pr1 F' -> F = F'.
Proof.
  intro H.
  apply (total2_paths_f H).
  apply proofirrelevance.
  apply isaprop_is_functor.
  apply hs.
Defined.

Lemma functor_isaset (C C' : precategory_data) (hs : has_homsets C') (hsC' : isaset C') :
  isaset (functor C C').
Proof.
  change isaset with (isofhlevel 2).
  apply isofhleveltotal2.
  apply (functor_data_isaset C C' hs hsC').
  intros x.
  apply isasetaprop.
  apply (isaprop_is_functor C C' hs).
Qed.

Definition functor_data_from_functor (C C': precategory_data)
     (F : functor C C') : functor_data C C' := pr1 F.
Coercion functor_data_from_functor : functor >-> functor_data.

Definition functor_eq_eq_from_functor_ob_eq (C C' : precategory_data) (hs: has_homsets C')
   (F G : functor C C') (p q : F = G)
   (H : base_paths _ _ (base_paths _ _  p) =
         base_paths _ _ (base_paths _ _ q)) :
    p = q.
Proof.
  apply (invmaponpathsweq (total2_paths_equiv _ _ _ )); simpl.
  assert (H' : base_paths _ _ p = base_paths _ _ q).
  { apply (invmaponpathsweq (total2_paths_equiv _ _ _ )); simpl.
    apply (two_arg_paths_f H), uip.
    apply impred_isaset; intro a; apply impred_isaset; intro b; apply impred_isaset; intro f.
    apply hs.
  }
  apply (two_arg_paths_f H'), uip, isasetaprop, isaprop_is_functor, hs.
Defined.

Definition functor_id {C C' : precategory_data}(F : functor C C'):
       ∏ a : ob C, #F (identity a) = identity (F a) := pr1 (pr2 F).

Definition functor_comp {C C' : precategory_data}
           (F : functor C C') {a b c : C} (f : a --> b) (g : b --> c)
  : #F (f · g) = #F f · #F g
  := pr2 (pr2 F) _ _ _ _ _ .

Lemma functor_id_id (A B : precategory) (G : functor A B) (a : A) (f : a --> a)
  : f = identity _ -> #G f = identity _ .
Proof.
  intro e.
  intermediate_path (#G (identity a )).
  - apply maponpaths. apply e.
  - apply functor_id.
Defined.

Lemma functor_comp_id (A B : precategory) (G : functor A B) (a a' : A) (f : a --> a') (g : a' --> a)
  : f · g = identity _ -> #G f · #G g = identity _ .
Proof.
  intro e.
  intermediate_path (#G (identity a )).
  - rewrite <- e. apply (! functor_comp _ _ _).
  - apply functor_id_id.
    apply idpath.
Qed.

(** ** Functors preserve isomorphisms *)

Lemma is_inverse_functor_image (C C' : precategory) (F : functor C C')
    (a b : C) (f : iso a b):
   is_inverse_in_precat (#F f) (#F (inv_from_iso f)).
Proof.
  simpl; split; simpl.
  rewrite <- functor_comp.
  rewrite iso_inv_after_iso.
  apply functor_id.

  rewrite <- functor_comp.
  rewrite iso_after_iso_inv.
  apply functor_id.
Qed.

Lemma functor_on_is_iso_is_iso {C C' : precategory} (F : functor C C')
      {a b : ob C} {f : a --> b} (H : is_iso f)  : is_iso (#F f).
Proof.
  apply (is_iso_qinv _ (#F (inv_from_iso (make_iso _ H)))).
  apply (is_inverse_functor_image _ _ _ _ _ (make_iso _ H)).
Qed.

Lemma functor_on_iso_is_iso (C C' : precategory) (F : functor C C')
    (a b : ob C) (f : iso a b) : is_iso (#F f).
Proof.
  apply (is_iso_qinv _ (#F (inv_from_iso f))).
  apply is_inverse_functor_image.
Defined.

Definition functor_on_iso {C C' : precategory} (F : functor C C')
    {a b : ob C}(f : iso a b) : iso (F a) (F b).
Proof.
  exists (#F f).
  apply functor_on_iso_is_iso.
Defined.

Lemma functor_on_iso_inv (C C' : precategory) (F : functor C C')
    (a b : ob C) (f : iso a b) :
   functor_on_iso F (iso_inv_from_iso f) =
       iso_inv_from_iso (functor_on_iso F f).
Proof.
  apply eq_iso; simpl.
  apply inv_iso_unique'; simpl.
  unfold precomp_with. rewrite <- functor_comp.
  rewrite iso_inv_after_iso.
  apply functor_id.
Defined.

Lemma functor_on_inv_from_iso' {C C' : precategory} (F : functor C C')
      {a b : ob C} {f : a --> b} (H : is_iso f) :
  inv_from_iso (make_iso _ (functor_on_is_iso_is_iso F H)) = # F (inv_from_iso (make_iso _ H)).
Proof.
  apply pathsinv0. use inv_iso_unique'. cbn. unfold precomp_with.
  rewrite <- functor_comp. set (tmp := iso_inv_after_iso (make_iso _ H)). cbn in tmp.
  rewrite tmp. apply functor_id.
Qed.

Section functors_on_iso_with_inv.

  Lemma functor_on_is_inverse_in_precat {C C' : precategory} (F : functor C C')
        {a b : ob C} {f : a --> b} {g : b --> a} (H : is_inverse_in_precat f g) :
    is_inverse_in_precat (# F f) (# F g).
  Proof.
    use make_is_inverse_in_precat.
    - rewrite <- functor_comp. rewrite (is_inverse_in_precat1 H). apply functor_id.
    - rewrite <- functor_comp. rewrite (is_inverse_in_precat2 H). apply functor_id.
  Qed.

  Definition functor_on_is_z_isomorphism {C C' : precategory} (F : functor C C')
             {a b : ob C} {f : a --> b} (I : is_z_isomorphism f) :
    is_z_isomorphism (# F f).
  Proof.
    use make_is_z_isomorphism.
    - exact (# F (is_z_isomorphism_mor I)).
    - exact (functor_on_is_inverse_in_precat F I).
  Defined.

  Lemma functor_is_inverse_in_precat_inv_from_iso {C D : precategory} {c c' : ob C}
        (F : functor C D) (f : iso c c') :
    is_inverse_in_precat (# F f) (# F (inv_from_iso f)).
  Proof.
    apply functor_on_is_inverse_in_precat.
    split.
    + apply is_inverse_in_precat1.
      split.
      * apply (iso_inv_after_iso f).
      * apply (iso_after_iso_inv f).
    + apply is_inverse_in_precat2.
      split.
      * apply (iso_inv_after_iso f).
      * apply (iso_after_iso_inv f).
  Qed.

  Lemma functor_is_inverse_in_precat_inv_from_z_iso {C D : precategory} {c c' : ob C}
        (F : functor C D) (f : z_iso c c') :
    is_inverse_in_precat (# F f) (# F (inv_from_z_iso f)).
  Proof.
    apply functor_on_is_inverse_in_precat.
    split.
    - apply z_iso_inv_after_z_iso.
    - apply z_iso_after_z_iso_inv.
  Qed.

  Definition functor_on_z_iso {C C' : precategory} (F : functor C C') {a b : ob C}
             (f : z_iso a b) : z_iso (F a) (F b).
  Proof.
    use make_z_iso.
    - exact (# F f).
    - exact (# F (inv_from_z_iso f)).
    - exact (functor_on_is_inverse_in_precat F f).
  Defined.

  Lemma functor_on_z_iso_inv (C C' : category) (F : functor C C')
    (a b : ob C) (f : z_iso a b) :
   functor_on_z_iso F (z_iso_inv_from_z_iso f) =
       z_iso_inv_from_z_iso (functor_on_z_iso F f).
  Proof.
    apply z_iso_eq; simpl.
    apply idpath.
  Defined.

  Lemma functor_on_inv_from_z_iso' {C C' : precategory} (F : functor C C')
      {a b : ob C} {f : a --> b} (H : is_z_isomorphism f) :
  inv_from_z_iso (make_z_iso _ _ (functor_on_is_z_isomorphism F H)) = # F (inv_from_z_iso (make_z_iso _ _ H)).
  Proof.
    apply idpath.
  Qed.

End functors_on_iso_with_inv.

(** ** Functors and [idtoiso] *)

Section functors_and_idtoiso.

Variables C D : category.
Variable F : functor C D.

Lemma maponpaths_idtoiso (a b : C) (e : a = b)
: idtoiso (maponpaths (functor_on_objects F) e)
  =
  functor_on_z_iso F (idtoiso e).
Proof.
  induction e.
  apply z_iso_eq.
  apply (! functor_id _ _ ).
Qed.

Hypothesis HC : is_univalent C.
Hypothesis HD : is_univalent D.

Lemma maponpaths_isotoid (a b : C) (i : z_iso a b)
: maponpaths (functor_on_objects F) (isotoid _ HC i)
  =
  isotoid _ HD (functor_on_z_iso F i).
Proof.
  apply (invmaponpathsweq (make_weq (idtoiso) (HD _ _ ))).
  simpl.
  rewrite maponpaths_idtoiso.
  repeat rewrite idtoiso_isotoid.
  apply idpath.
Qed.

End functors_and_idtoiso.

Definition pr1_maponpaths_idtoiso
           {C D : category}
           (F : C ⟶ D)
           {a b : C}
           (e : a = b)
  : pr1 (idtoiso (maponpaths F e)) = #F (pr1 (idtoiso e)).
Proof.
  exact (maponpaths pr1 (maponpaths_idtoiso _ _ F _ _ e)).
Qed.

Notation "# F" := (functor_on_morphisms F)(at level 3) : cat. (* Notations do not survive the end of sections.  *)

Lemma idtoiso_functor_precompose
      {C₁ C₂ : category}
      (F : C₁ ⟶ C₂)
      {y : C₂}
      {x₁ x₂ : C₁}
      (p : x₁ = x₂)
      (f : F x₁ --> y)
  : idtoiso (maponpaths (λ z, F z) (!p)) · f
    =
    transportf (λ z, F z --> y) p f.
Proof.
  induction p.
  cbn.
  apply id_left.
Qed.

Lemma idtoiso_functor_precompose'
      {C₁ C₂ : category}
      (F : C₁ ⟶ C₂)
      {y : C₂}
      {x₁ x₂ : C₁}
      (p : x₁ = x₂)
      (f : y --> F x₁)
  : f · idtoiso (maponpaths (λ z, F z) p)
    =
      transportf (λ z, y --> F z) p f.
Proof.
  induction p.
  cbn.
  apply id_right.
Qed.

Definition transportf_functor_isotoid
           {C₁ C₂ : category}
           (HC₁ : is_univalent C₁)
           (F : C₁ ⟶ C₂)
           {y : C₂}
           {x₁ x₂ : C₁}
           (i : z_iso x₁ x₂)
           (f : F x₁ --> y)
  : transportf
      (λ z, F z --> y)
      (isotoid _ HC₁ i)
      f
    =
    #F (inv_from_z_iso i) · f.
Proof.
  rewrite <- idtoiso_functor_precompose.
  rewrite maponpaths_idtoiso.
  rewrite idtoiso_inv.
  rewrite idtoiso_isotoid.
  apply idpath.
Qed.

Lemma transportf_functor_isotoid'
      {C₁ C₂ : category}
      (HC₁ : is_univalent C₁)
      (F : C₁ ⟶ C₂)
      {y : C₂}
      {x₁ x₂ : C₁}
      (i : z_iso x₁ x₂)
      (f : y --> F x₁)
  : transportf
      (λ z, y --> F z)
      (isotoid _ HC₁ i)
      f
    =
      f · #F i.
Proof.
  rewrite <- idtoiso_functor_precompose'.
  rewrite maponpaths_idtoiso.
  rewrite idtoiso_isotoid.
  apply idpath.
Qed.

(** ** Functors preserve inverses *)

Lemma functor_on_inv_from_z_iso {C C' : precategory} (F : functor C C')
    {a b : ob C}(f : z_iso a b) :
      #F (inv_from_z_iso f) = inv_from_z_iso (functor_on_z_iso F f) .
Proof.
  destruct f.
  apply functor_on_inv_from_z_iso'.
Qed.

(** ** Conservative functors *)

(** The generic property of "reflecting" a property of a morphism. *)

Definition reflects_morphism {C D : category} (F : functor C D)
           (P : ∏ (C : category) (a b : ob C), C⟦a, b⟧ → UU) : UU :=
  ∏ a b f, P D (F a) (F b) (# F f) → P C a b f.

(** These are functors that reflect isomorphisms. F : C ⟶ D is conservative
    if whenever # F f is an iso, so is f. *)

Definition conservative {C D : category} (F : functor C D) : UU :=
  reflects_morphism F (@is_z_isomorphism).

Definition isaprop_conservative
           {C D : category}
           (F : functor C D)
  : isaprop (conservative F).
Proof.
  do 4 (use impred ; intro).
  apply isaprop_is_z_isomorphism.
Qed.

(** ** Composition of functors, identity functors *)

(** *** Composition *)

Definition functor_composite_data {C C' C'' : precategory_ob_mor } (F : functor_data C C')
           (F' : functor_data C' C'') : functor_data C C'' :=
  functor_data_constr C C'' (λ a, F' (F a))  (λ (a b : ob C) f, #F' (#F f)) .

Lemma is_functor_composite {C C' C'' : precategory_data}
       (F : functor C C') (F' : functor C' C'') :
 is_functor ( functor_composite_data F F' ) .
Proof.
  split; simpl.
  intro a.
  assert ( e1 := functor_id F a ) .
  assert ( e2 := functor_id F' ( F a ) ) .
  apply ( ( maponpaths ( # F' ) e1 ) @ e2 ) .

  unfold functor_compax .  intros .
  assert ( e1 := functor_comp F f g ) .
  assert ( e2 := functor_comp F' ( # F f ) ( # F g ) ) .
  apply ( ( maponpaths ( # F' ) e1 ) @ e2 ) .
Defined.

Definition functor_composite {C C' C'' : precategory_data} (F : functor C C') (F' : functor C' C'') :
  functor C C'' := tpair _ _ (is_functor_composite F F').

(** *** Identity functor *)

Definition functor_identity_data ( C  : precategory_data ) : functor_data C C :=
  functor_data_constr C C (λ a, a) (λ (a b : ob C) f, f) .

Lemma is_functor_identity (C : precategory_data) : is_functor ( functor_identity_data C ) .
Proof.
  split; simpl.
  unfold functor_idax. intros; apply idpath.
  unfold functor_compax. intros; apply idpath.
Defined.

Definition functor_identity (C : precategory_data) : functor C C :=
  tpair _ _ ( is_functor_identity C ) .

(** *** Constant functor *)

Section Constant_Functor.
Variables C D : precategory.
Variable d : D.

Definition constant_functor_data: functor_data C D :=
   functor_data_constr C D (λ _, d) (λ _ _ _ , identity _) .

Lemma is_functor_constant: is_functor constant_functor_data.
Proof.
  split; simpl.
  red; intros; apply idpath.
  red; intros; simpl.
  apply pathsinv0.
  apply id_left.
Qed.

Definition constant_functor: functor C D := tpair _ _ is_functor_constant.

End Constant_Functor.

Definition iter_functor {C : precategory} (F : functor C C) (n : nat) : functor C C.
Proof.
  induction n as [ | n IHn].
  - apply functor_identity.
  - apply (functor_composite IHn F).
Defined.

End functors.

(** Notations do not survive the end of sections, so we redeclare them here. *)
Notation "a ⟶ b" := (functor a b) : cat.
Notation "# F" := (functor_on_morphisms F) (at level 3) : cat.

(** ** Fully faithful functors *)

Definition fully_faithful {C D : precategory_data} (F : functor C D) :=
  ∏ a b : ob C,
    isweq (functor_on_morphisms F (a:=a) (b:=b)).

Lemma isaprop_fully_faithful (C D : precategory_data) (F : functor C D) :
   isaprop (fully_faithful F).
Proof.
  apply impred; intro a.
  apply impred; intro b.
  apply isapropisweq.
Qed.

Lemma identity_functor_is_fully_faithful { C : precategory_data }
  : fully_faithful (functor_identity C).
Proof.
  intros a b.
  apply idisweq.
Defined.

Definition weq_from_fully_faithful {C D : precategory_data}{F : functor C D}
      (FF : fully_faithful F) (a b : ob C) :
   (a --> b) ≃ (F a --> F b).
Proof.
  exists (functor_on_morphisms F (a:=a) (b:=b)).
  exact (FF a b).
Defined.

Definition fully_faithful_inv_hom {C D : precategory_data} {F : functor C D}
      (FF : fully_faithful F) (a b : ob C) :
      F a --> F b -> a --> b :=
 invweq (weq_from_fully_faithful FF a b).

Local Notation "FF ^-1" := (fully_faithful_inv_hom FF _ _ ).

(** FF^1 is indeed post-inverse to # F. *)
Lemma fully_faithful_inv_hom_is_inv {C D : precategory} {F : functor C D}
      (FF : fully_faithful F) {a b : ob C} (f : C⟦a, b⟧) :
  FF^-1 (# F f) = f.
Proof.
  cbn.
  apply invmap_eq.
  reflexivity.
Defined.

Definition functor_on_fully_faithful_inv_hom
           {C₁ C₂ : category}
           (F : C₁ ⟶ C₂)
           (HF : fully_faithful F)
           {x y : C₁}
           (f : F x --> F y)
  : #F (fully_faithful_inv_hom HF x y f) = f.
Proof.
  unfold fully_faithful_inv_hom.
  exact (homotweqinvweq (weq_from_fully_faithful HF x y) f).
Qed.

Lemma fully_faithful_inv_identity (C D : precategory_data) (F : functor C D)
      (FF : fully_faithful F) (a : ob C) :
         FF^-1 (identity (F a)) = identity _.
Proof.
  apply (invmaponpathsweq (weq_from_fully_faithful FF a a)).
  unfold fully_faithful_inv_hom.
  set (HFaa:=homotweqinvweq (weq_from_fully_faithful FF a a)(identity _ )).
  simpl in *.
  rewrite HFaa.
  rewrite functor_id; apply idpath.
Qed.

Lemma fully_faithful_inv_comp (C D : precategory_data) (F : functor C D)
      (FF : fully_faithful F) (a b c : ob C)
      (f : F a --> F b) (g : F b --> F c) :
        FF^-1 (f · g) = FF^-1 f · FF^-1 g.
Proof.
  apply (invmaponpathsweq (weq_from_fully_faithful FF a c)).
  set (HFFac := homotweqinvweq (weq_from_fully_faithful FF a c)
                 (f · g)).
  unfold fully_faithful_inv_hom.
  simpl in *.
  rewrite HFFac; clear HFFac.
  rewrite functor_comp.
  set (HFFab := homotweqinvweq (weq_from_fully_faithful FF a b) f).
  set (HFFbc := homotweqinvweq (weq_from_fully_faithful FF b c) g).
  simpl in *.
  rewrite HFFab; clear HFFab.
  rewrite HFFbc; clear HFFbc.
  apply idpath.
Qed.

(** *** Fully faithful functors reflect isos *)

Lemma inv_of_ff_inv_is_inv (C D : precategory) (F : functor C D)
   (FF : fully_faithful F) (a b : C) (f : z_iso (F a) (F b)) :
  is_inverse_in_precat ((FF ^-1) f) ((FF ^-1) (inv_from_z_iso f)).
Proof.
  unfold fully_faithful_inv_hom; simpl.
  split.
  apply (invmaponpathsweq (weq_from_fully_faithful FF a a)).
  set (HFFab := homotweqinvweq (weq_from_fully_faithful FF a b)).
  set (HFFba := homotweqinvweq (weq_from_fully_faithful FF b a)).
  simpl in *.
  rewrite functor_comp.
  rewrite HFFab; clear HFFab.
  rewrite HFFba; clear HFFba.
  rewrite functor_id.
  apply z_iso_inv_after_z_iso.

  apply (invmaponpathsweq (weq_from_fully_faithful FF b b)).
  set (HFFab := homotweqinvweq (weq_from_fully_faithful FF a b)).
  set (HFFba := homotweqinvweq (weq_from_fully_faithful FF b a)).
  simpl in *.
  rewrite functor_comp.
  rewrite HFFab.
  rewrite HFFba.
  rewrite functor_id.
  apply z_iso_after_z_iso_inv.
Qed.

Lemma fully_faithful_reflects_iso_proof (C D : precategory)(F : functor C D)
        (FF : fully_faithful F)
    (a b : ob C) (f : z_iso (F a) (F b)) :
     is_z_isomorphism (FF^-1 f).
Proof.
  exists (FF^-1 (inv_from_z_iso f)).
  apply inv_of_ff_inv_is_inv.
Defined.

(** A slight restatement of the above: fully faithful functors are conservative. *)
Lemma fully_faithful_conservative {C D : category} (F : functor C D)
      (FF : fully_faithful F) : conservative F.
Proof.
  unfold conservative.
  intros a b f is_iso_Ff.
  use transportf.
  - exact (FF^-1 (# F f)).
  - apply fully_faithful_inv_hom_is_inv.
  - apply (fully_faithful_reflects_iso_proof _ _ _ _ _ _ (_,,is_iso_Ff)).
Defined.

Definition  iso_from_fully_faithful_reflection {C D : precategory} {F : functor C D}
        (HF : fully_faithful F)
    {a b : ob C} (f : z_iso (F a) (F b)) :
      z_iso a b.
Proof.
  exists (fully_faithful_inv_hom HF a b f).
  apply fully_faithful_reflects_iso_proof.
Defined.

Lemma functor_on_iso_iso_from_fully_faithful_reflection (C : precategory)(D : category)
      (F : functor C D) (HF : fully_faithful F) (a b : ob C)
   (f : z_iso (F a) (F b)) :
      functor_on_z_iso F
        (iso_from_fully_faithful_reflection HF f) = f.
Proof.
  apply z_iso_eq.
  simpl;
  apply (homotweqinvweq (weq_from_fully_faithful HF a b)).
Qed.

Lemma iso_from_fully_faithful_reflection_functor_on_iso (C : category)(D : precategory)
      (F : functor C D) (HF : fully_faithful F) (a b : ob C)
   (f : z_iso a b) :
      iso_from_fully_faithful_reflection HF (functor_on_z_iso F f) = f.
Proof.
  apply z_iso_eq.
  simpl;
  apply (homotinvweqweq (weq_from_fully_faithful HF a b)).
Qed.

Definition weq_ff_functor_on_z_iso {C D : category}{F : functor C D}
           (HF : fully_faithful F) (a b : ob C)
  : z_iso a b ≃ z_iso (F a) (F b).
Proof.
  exists (functor_on_z_iso F).
  apply (isweq_iso _ (iso_from_fully_faithful_reflection HF (a:=a)(b:=b))).
  - apply iso_from_fully_faithful_reflection_functor_on_iso.
  - apply functor_on_iso_iso_from_fully_faithful_reflection.
Defined.

(** Computation check *)

Lemma weq_ff_functor_on_iso_compute {C D : category} (F : functor C D)
      (HF : fully_faithful F) {a b : C} (f : z_iso a b)
: #F f = weq_ff_functor_on_z_iso HF _ _ f.
Proof.
apply idpath.
Qed.

Lemma functor_on_iso_iso_from_ff_reflection (C : precategory)(D : category)
      (F : functor C D) (HF : fully_faithful F) (a b : C)
      (f : z_iso (F a) (F b)):
  functor_on_z_iso F
                 (iso_from_fully_faithful_reflection HF f) = f.
Proof.
  apply z_iso_eq.
  simpl.
  apply (homotweqinvweq (weq_from_fully_faithful HF a b ) ).
Qed.

(** Alternative implementation of [weq_ff_functor_on_iso] *)

Definition reflects_isos {C D : precategory} (F : C ⟶ D) :=
  ∏ c c' (f : C⟦c,c'⟧), is_z_isomorphism (# F f) → is_z_isomorphism f.

Lemma isaprop_reflects_isos {C : category} {D : precategory} (F : C ⟶ D) : isaprop (reflects_isos F).
Proof.
apply impred; intros c; apply impred; intros c'.
apply impred; intros f; apply impred; intros f'.
apply isaprop_is_z_isomorphism.
Qed.

Lemma ff_reflects_is_iso (C D : precategory) (F : functor C D)
  (HF : fully_faithful F) : reflects_isos F.
Proof.
  intros a b f H.
  set (X:= fully_faithful_reflects_iso_proof _ _ F HF _ _ (_,,H)).
  simpl in X.
  set (T:= homotinvweqweq (weq_from_fully_faithful HF a b ) ).
  simpl in T.
  unfold fully_faithful_inv_hom in X.
  simpl in X.
  rewrite T in X.
  apply X.
Defined.

Definition weq_ff_functor_on_weq_isobandf {C D : category}
  {F : functor C D}
  (HF : fully_faithful F) (a b : C)
  : z_iso a b ≃ z_iso (F a) (F b).
Proof.
  use weqbandf.
  - apply (make_weq _ (HF a b)).
  - simpl; intro f.
    apply weqimplimpl.
    + intro H.
      exact (pr2(functor_on_z_iso _ (_,,H))).
    + apply ff_reflects_is_iso. apply HF.
    + apply isaprop_is_z_isomorphism.
    + apply isaprop_is_z_isomorphism.
Defined.

(** Computation check *)

Lemma weq_ff_functor_on_weq_isobandf_compute {C D : category} (F : functor C D)
      (HF : fully_faithful F) {a b : C} (f : z_iso a b)
: #F f = weq_ff_functor_on_weq_isobandf HF _ _ f.
Proof.
  apply idpath.
Defined.

Lemma ff_is_inclusion_on_objects {C D : category}
      (HC : is_univalent C) (HD : is_univalent D)
      (F : functor C D) (HF : fully_faithful F)
      : isofhlevelf 1 (functor_on_objects F).
Proof.
  intro d.
  apply invproofirrelevance.
  intros [c e] [c' e'].
  use total2_paths_f.
  - simpl.
    set (X := idtoiso (e @ ! e')).
    (* set (X' := invmap (@weq_ff_functor_on_iso _ _ _ HF _ _ ) X). *)
        (* we cannot use X' because we lack the preceding, commented-out,
           lemma *)
    set (X2 := iso_from_fully_faithful_reflection HF X).
    apply (isotoid _ HC X2).
  - simpl.
    set (T:=@functtransportf _ _ (functor_on_objects F)).
    set (T' := T (λ c, c = d)). simpl in T'.
    rewrite T'.
    rewrite (maponpaths_isotoid _ _ _ HC HD).
    rewrite functor_on_iso_iso_from_ff_reflection.
    rewrite isotoid_idtoiso.
    rewrite transportf_id2.
    rewrite pathscomp_inv.
    rewrite pathsinv0inv0.
    rewrite <- path_assoc.
    rewrite pathsinv0l.
    apply pathscomp0rid.
Qed.

(** ** (Split) essentially surjective functors *)

(** See [CategoryTheory.equivalences] for more lemmas about (split) essential
    surjectivity, especially where the domain is a [univalent_category]. *)

(** See "Univalent categories and the Rezk completion" (arXiv:1303.0584v2)
    Definition 6.5. *)
Definition split_essentially_surjective {C D : precategory_data} (F : functor C D) :=
  ∏ b, (∑ a : ob C, z_iso (F a) b).

(** Split essentially surjective functors have "inverses" on objects, where we
    map d : ob D to the c : ob C such that F c ≅ d. *)
Definition split_essentially_surjective_inv_on_obj {C D : precategory_data}
           (F : functor C D) (HF : split_essentially_surjective F) : ob D → ob C :=
  λ d, (pr1 (HF d)).

Definition essentially_surjective {C D : precategory_data} (F : functor C D) :=
  ∏ b, ishinh (total2 (λ a, z_iso (F a) b)).

Lemma isaprop_essentially_surjective {C D : precategory_data} (F : functor C D) :
   isaprop (essentially_surjective F).
Proof.
  apply impred; intro; apply isapropishinh.
Defined.

(** Composition of essentially surjective functors yields an essentially
    surjective functor. *)

(** Let e : E. Since G is essentially surjective, there is some g
    such that e ≅ G g. Since F is essentially surjective, there is some f
    such that G g ≅ F f. Composing these isomorphisms proves the goal.
 *)
Lemma comp_essentially_surjective {C D E : precategory}
      (F : functor C D) (esF : essentially_surjective F)
      (G : functor D E) (esG : essentially_surjective G) :
  essentially_surjective (functor_composite F G).
Proof.
  unfold essentially_surjective.
  intros e.
  apply (squash_to_prop (esG e)); [apply isapropishinh|]; intros isoGe.
  apply (squash_to_prop (esF (pr1 isoGe))); [apply isapropishinh|]; intros isoFGe.
  apply hinhpr.
  exists (pr1 isoFGe); unfold functor_composite; cbn.
  apply (@z_iso_comp E _ (G (pr1 isoGe))).
  - apply functor_on_z_iso.
    exact (pr2 isoFGe).
  - apply (pr2 isoGe).
Defined.

(** ** Faithful functors *)

Definition faithful {C D : precategory_data} (F : functor C D) :=
  ∏ a b : ob C, isincl (fun f : a --> b => #F f).

Lemma isaprop_faithful (C D : precategory_data) (F : functor C D) :
   isaprop (faithful F).
Proof.
  unfold faithful.
  do 2 (apply impred; intro).
  apply isapropisincl.
Qed.

(** Composition of faithful functors yields a faithful functor. *)

Lemma comp_faithful_is_faithful (C D E : precategory)
      (F : functor C D) (faithF : faithful F)
      (G : functor D E) (faithG : faithful G) : faithful (functor_composite F G).
Proof.
  unfold faithful in *.
  intros ? ?; apply (isinclcomp (_,, faithF _ _) (_,, faithG _ _)).
Qed.

(** Faithful functors reflect commutative triangles. If F f · F g = F h,
    in D, then f · g = h in C. (Really, this is true more generally for any
    diagram.) *)

Lemma faithful_reflects_commutative_triangle {C D : precategory} (F : functor C D)
      (FF : faithful F) {a b c : ob C} (f : C ⟦a, b⟧) (g : C ⟦b, c⟧) (h : C ⟦a, c⟧) :
  # F f · # F g = # F h → f · g = h.
Proof.
  intros feq.
  apply (Injectivity (# F)).
  - apply isweqonpathsincl, FF.
  - exact (functor_comp F f g @ feq).
Defined.

(** ** Full functors *)

Definition full {C D : precategory_data} (F : functor C D) :=
   ∏ a b: C, issurjective (fun f : a --> b => #F f).

Lemma isaprop_full (C D : precategory_data) (F : functor C D) :
   isaprop (full F).
Proof.
  unfold full.
  do 2 (apply impred; intro).
  apply isapropissurjective.
Qed.

(** Composition of full functors yields a full functor *)

Lemma comp_full_is_full (C D E : precategory)
      (F : functor C D) (fullF : full F)
      (G : functor D E) (fullG : full G) : full (functor_composite F G).
Proof.
  unfold full in *.
  intros ? ?; apply (issurjcomp _ _ (fullF _ _) (fullG _ _)).
Qed.

(** ** Fully faithful is the same as full and faithful *)

Definition full_and_faithful {C D : precategory_data} (F : functor C D) :=
   (full F) × (faithful F).

Lemma fully_faithful_implies_full_and_faithful (C D : precategory_data) (F : functor C D) :
   fully_faithful F -> full_and_faithful F.
Proof.
  intro H.
  split; simpl.
  unfold full. intros a b.
  apply issurjectiveweq.
  apply H.
  intros a b.
  apply isinclweq.
  apply H.
Qed.

Lemma full_and_faithful_implies_fully_faithful (C D : precategory_data) (F : functor C D) :
   full_and_faithful F -> fully_faithful F.
Proof.
  intros [Hfull Hfaith].
  intros a b.
  simpl in *.
  apply isweqinclandsurj.
  - apply Hfaith.
  - apply Hfull.
Defined.

Lemma isaprop_full_and_faithful (C D : precategory_data) (F : functor C D) :
   isaprop (full_and_faithful F).
Proof.
  apply isapropdirprod.
  - apply isaprop_full.
  - apply isaprop_faithful.
Qed.

Definition weq_fully_faithful_full_and_faithful (C D : precategory_data) (F : functor C D) :
   (fully_faithful F) ≃ (full_and_faithful F) :=
  weqimplimpl (fully_faithful_implies_full_and_faithful _ _ F)
              (full_and_faithful_implies_fully_faithful _ _ F)
              (isaprop_fully_faithful _ _ F)
              (isaprop_full_and_faithful _ _ F).

(** Composition of fully faithful functors yields a fully faithful functor. *)

Lemma comp_full_and_faithful_is_full_and_faithful (C D E : precategory)
      (F : functor C D) (f_and_f_F : full_and_faithful F)
      (G : functor D E) (f_and_f_G : full_and_faithful G) :
  full_and_faithful (functor_composite F G).
Proof.
  split.
  - apply comp_full_is_full; [apply (pr1 f_and_f_F)|apply (pr1 f_and_f_G)].
  - apply comp_faithful_is_faithful; [apply (pr2 f_and_f_F)|apply (pr2 f_and_f_G)].
Qed.

Lemma comp_ff_is_ff (C D E : precategory)
      (F : functor C D) (ffF : fully_faithful F)
      (G : functor D E) (ffG : fully_faithful G) :
  fully_faithful (functor_composite F G).
Proof.
  unfold fully_faithful in *.
  intros ? ?; apply (pr2 (weqcomp (_,, ffF _ _) (_,, ffG _ _))).
Qed.

(** Fully faithful functors induce equivalences on commutative triangles

    Compare to [faithful_reflects_commutative_triangle]. *)
Lemma fully_faithful_commutative_triangle_weq
      {C D : precategory} (F : functor C D) (fff : fully_faithful F)
      {X Y Z : ob C} (f : X --> Y) (g : Y --> Z) (h : X --> Z) :
  (f · g = h) ≃ (#F f · #F g = #F h).
Proof.
  apply (@weqcomp _ (# F (f · g) = # F h)).
  - eapply make_weq.
    apply (isweqmaponpaths (weq_from_fully_faithful fff _ _) (f · g) h).
  - use weq_iso; intros p.
    + refine (_ @ p).
      apply (!functor_comp _ _ _).
    + refine (_ @ p).
      apply (functor_comp _ _ _).
    + refine (path_assoc _ _ _ @ _).
      refine (maponpaths (λ pp, pp @ _) (pathsinv0r _) @ _).
      reflexivity.
    + cbn.
      refine (path_assoc _ _ _ @ _).
      refine (maponpaths (λ pp, pp @ _) (pathsinv0l _) @ _).
      reflexivity.
Qed.

(** ** Image on objects of a functor  *)
(** is used later to define the full image subcategory of a category [D]
       defined by a functor [F : C -> D] *)

Definition is_in_img_functor {C D : precategory_data} (F : functor C D)
      (d : ob D) :=
  ishinh (
  total2 (λ c : ob C, z_iso (F c) d)).

Definition sub_img_functor {C D : precategory_data}(F : functor C D) :
    hsubtype (ob D) :=
       λ d : ob D, is_in_img_functor F d.

Section functor_equalities.

Lemma functor_identity_left (C D : precategory) (F : functor C D) :
  functor_composite (functor_identity C) F = F.
Proof.
  destruct F as [ [ Fob Fmor ] is ].
  destruct is as [ idax compax ] .
  apply idpath .
Defined.

Lemma functor_identity_right (C D : precategory) (F : functor C D) :
  functor_composite F (functor_identity D) = F.
Proof.
  destruct F as [ [ Fob Fmor ] is ] .
  apply ( maponpaths ( λ p, tpair is_functor (tpair _ Fob Fmor) p ) ) .
  destruct is as [ idax compax ] .
  apply pathsdirprod .
  simpl . apply funextsec . intro t . unfold functor_identity .  unfold functor_id . simpl .
  rewrite maponpathsidfun .
  rewrite pathscomp0rid .
  apply idpath .

  apply funextsec . intro t . apply funextsec . intro t0 . apply funextsec . intro t1 .
  apply funextsec . intro f . apply funextsec . intro g . unfold functor_identity . simpl .
  unfold functor_comp . simpl .
  rewrite maponpathsidfun .
  rewrite pathscomp0rid .
  apply idpath.

Defined.

Lemma functor_assoc (C0 C1 C2 C3 : precategory)
  (F0 : functor C0 C1) (F1 : functor C1 C2) (F2 : functor C2 C3) :
    functor_composite (functor_composite F0 F1) F2 =
    functor_composite F0 (functor_composite F1 F2).
Proof.
  destruct F0 as [ [ F0ob F0mor ] is0 ] .
  destruct F1 as [ [ F1ob F1mor ] is1 ] .
  destruct F2 as [ [ F2ob F2mor ] is2 ] . simpl .
  unfold functor_composite . simpl .
  apply ( maponpaths ( λ p, tpair is_functor _ p ) ) . simpl .
  apply pathsdirprod .
  apply funextsec .
  intro t .

  simpl .
  unfold functor_comp . simpl . unfold functor_id . simpl . unfold functor_id . simpl .
  destruct is0 as [ is0id is0comp ] .
  destruct is1 as [ is1id is1comp ] .
  destruct is2 as [ is2id is2comp ] .
  simpl .

  rewrite path_assoc.
  apply ( maponpaths ( λ e, pathscomp0 e ( is2id (F1ob (F0ob t)) ) ) ) .
  rewrite maponpathscomp0 .
  apply ( maponpaths ( λ e, pathscomp0 e ( maponpaths
                                                 (F2mor (F1ob (F0ob t)) (F1ob (F0ob t)))
                                                 (is1id (F0ob t)) ) ) ) .
  apply maponpathscomp .

  apply funextsec . intro t . apply funextsec . intro t0 . apply funextsec . intro t1 .
  apply funextsec . intro f . apply funextsec . intro g .

  simpl .
  unfold functor_comp . simpl . unfold functor_comp .  simpl .
  destruct is0 as [ is0id is0comp ] .
  destruct is1 as [ is1id is1comp ] .
  destruct is2 as [ is2id is2comp ] .
  simpl .

  rewrite path_assoc.
  apply ( maponpaths ( λ e,
                         pathscomp0 e ( is2comp (F1ob (F0ob t)) (F1ob (F0ob t0)) (F1ob (F0ob t1))
                                                (F1mor (F0ob t) (F0ob t0) (F0mor t t0 f))
                                                (F1mor (F0ob t0) (F0ob t1) (F0mor t0 t1 g)) ) ) ) .
  rewrite maponpathscomp0 .
  apply ( maponpaths ( λ e,
                         pathscomp0 e ( maponpaths (F2mor (F1ob (F0ob t)) (F1ob (F0ob t1)))
                                                   (is1comp (F0ob t) (F0ob t0) (F0ob t1)
                                                            (F0mor t t0 f) (F0mor t0 t1 g)) ))).
  apply maponpathscomp .
Defined.

End functor_equalities.

(**
 Pseudomonic functors
 *)
Definition full_on_iso
           {C₁ C₂ : category}
           (F : C₁ ⟶ C₂)
  : UU
  := ∏ (x y : C₁),
     issurjective (λ (f : z_iso x y), functor_on_z_iso F f).

Definition pseudomonic
           {C₁ C₂ : category}
           (F : C₁ ⟶ C₂)
  : UU
  := faithful F × full_on_iso F.

Definition isweq_functor_on_iso_pseudomonic
           {C₁ C₂ : category}
           {F : C₁ ⟶ C₂}
           (HF : pseudomonic F)
           (x y : C₁)
  : isweq (@functor_on_z_iso _ _ F x y).
Proof.
  intro g.
  use (factor_through_squash _ _ (pr2 HF x y g)).
  {
    apply isapropiscontr.
  }
  intro inv.
  use iscontraprop1.
  - abstract
      (use invproofirrelevance ;
       intros φ₁ φ₂ ;
       use subtypePath ; [ intro ; apply isaset_z_iso ; apply homset_property | ] ;
       use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ] ;
       use (maponpaths pr1 (proofirrelevance _ (pr1 HF x y g) (_ ,, _) (_ ,, _))) ;
       [ exact (maponpaths pr1 (pr2 φ₁)) | exact (maponpaths pr1 (pr2 φ₂)) ]).
  - exact inv.
Defined.

Definition isaprop_pseudomonic
           {C₁ C₂ : category}
           (F : C₁ ⟶ C₂)
  : isaprop (pseudomonic F).
Proof.
  use isapropdirprod.
  - apply isaprop_faithful.
  - do 2 (use impred ; intro).
    apply isapropissurjective.
Qed.

Notation "F ∙ G" := (functor_composite F G) : cat.
(* to input: type "\." with Agda input method *)
(* the old notation had the arguments in the opposite order *)

(* Notation "G □ F" := (functor_composite F G) (at level 35, only parsing) : cat. *)
(* to input: type "\Box" or "\square" or "\sqw" or "\sq" with Agda input method *)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import Rbase.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Rtrigo.
Require Import Ranalysis1.
Require Import PSeries_reg.
Require Import Div2.
Require Import Even.
Require Import Max.
Open Local Scope nat_scope.
Open Local Scope R_scope.

Definition E1 (x:R) (N:nat) : R :=
  sum_f_R0 (fun k:nat => / INR (fact k) * x ^ k) N.

Lemma E1_cvg : forall x:R, Un_cv (E1 x) (exp x).
Proof.
  intro; unfold exp in |- *; unfold projT1 in |- *.
  case (exist_exp x); intro.
  unfold exp_in, Un_cv in |- *; unfold infinite_sum, E1 in |- *; trivial.
Qed.

Definition Reste_E (x y:R) (N:nat) : R :=
  sum_f_R0
  (fun k:nat =>
    sum_f_R0
    (fun l:nat =>
      / INR (fact (S (l + k))) * x ^ S (l + k) *
      (/ INR (fact (N - l)) * y ^ (N - l))) (
        pred (N - k))) (pred N).

Lemma exp_form :
  forall (x y:R) (n:nat),
    (0 < n)%nat -> E1 x n * E1 y n - Reste_E x y n = E1 (x + y) n.
Proof.
  intros; unfold E1 in |- *.
  rewrite cauchy_finite.
  unfold Reste_E in |- *; unfold Rminus in |- *; rewrite Rplus_assoc;
    rewrite Rplus_opp_r; rewrite Rplus_0_r; apply sum_eq;
      intros.
  rewrite binomial.
  rewrite scal_sum; apply sum_eq; intros.
  unfold C in |- *; unfold Rdiv in |- *; repeat rewrite Rmult_assoc;
    rewrite (Rmult_comm (INR (fact i))); repeat rewrite Rmult_assoc;
      rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; rewrite Rinv_mult_distr.
  ring.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply H.
Qed.

Definition maj_Reste_E (x y:R) (N:nat) : R :=
  4 *
  (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * N) /
    Rsqr (INR (fact (div2 (pred N))))).

Lemma Rle_Rinv : forall x y:R, 0 < x -> 0 < y -> x <= y -> / y <= / x.
Proof.
  intros; apply Rmult_le_reg_l with x.
  apply H.
  rewrite <- Rinv_r_sym.
  apply Rmult_le_reg_l with y.
  apply H0.
  rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc;
    rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; apply H1.
  red in |- *; intro; rewrite H2 in H0; elim (Rlt_irrefl _ H0).
  red in |- *; intro; rewrite H2 in H; elim (Rlt_irrefl _ H).
Qed.

(**********)
Lemma div2_double : forall N:nat, div2 (2 * N) = N.
Proof.
  intro; induction  N as [| N HrecN].
  reflexivity.
  replace (2 * S N)%nat with (S (S (2 * N))).
  simpl in |- *; simpl in HrecN; rewrite HrecN; reflexivity.
  ring.
Qed.

Lemma div2_S_double : forall N:nat, div2 (S (2 * N)) = N.
Proof.
  intro; induction  N as [| N HrecN].
  reflexivity.
  replace (2 * S N)%nat with (S (S (2 * N))).
  simpl in |- *; simpl in HrecN; rewrite HrecN; reflexivity.
  ring.
Qed.

Lemma div2_not_R0 : forall N:nat, (1 < N)%nat -> (0 < div2 N)%nat.
Proof.
  intros; induction  N as [| N HrecN].
  elim (lt_n_O _ H).
  cut ((1 < N)%nat \/ N = 1%nat).
  intro; elim H0; intro.
  assert (H2 := even_odd_dec N).
  elim H2; intro.
  rewrite <- (even_div2 _ a); apply HrecN; assumption.
  rewrite <- (odd_div2 _ b); apply lt_O_Sn.
  rewrite H1; simpl in |- *; apply lt_O_Sn.
  inversion H.
  right; reflexivity.
  left; apply lt_le_trans with 2%nat; [ apply lt_n_Sn | apply H1 ].
Qed.

Lemma Reste_E_maj :
  forall (x y:R) (N:nat),
    (0 < N)%nat -> Rabs (Reste_E x y N) <= maj_Reste_E x y N.
Proof.
  intros; set (M := Rmax 1 (Rmax (Rabs x) (Rabs y))).
  apply Rle_trans with
    (M ^ (2 * N) *
      sum_f_R0
      (fun k:nat =>
        sum_f_R0 (fun l:nat => / Rsqr (INR (fact (div2 (S N)))))
        (pred (N - k))) (pred N)).
  unfold Reste_E in |- *.
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
        Rabs
        (sum_f_R0
          (fun l:nat =>
            / INR (fact (S (l + k))) * x ^ S (l + k) *
            (/ INR (fact (N - l)) * y ^ (N - l))) (
              pred (N - k)))) (pred N)).
  apply
    (Rsum_abs
      (fun k:nat =>
        sum_f_R0
        (fun l:nat =>
          / INR (fact (S (l + k))) * x ^ S (l + k) *
          (/ INR (fact (N - l)) * y ^ (N - l))) (
            pred (N - k))) (pred N)).
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
        sum_f_R0
        (fun l:nat =>
          Rabs
          (/ INR (fact (S (l + k))) * x ^ S (l + k) *
            (/ INR (fact (N - l)) * y ^ (N - l)))) (
              pred (N - k))) (pred N)).
  apply sum_Rle; intros.
  apply
    (Rsum_abs
      (fun l:nat =>
        / INR (fact (S (l + n))) * x ^ S (l + n) *
        (/ INR (fact (N - l)) * y ^ (N - l)))).
  apply Rle_trans with
    (sum_f_R0
      (fun k:nat =>
        sum_f_R0
        (fun l:nat =>
          M ^ (2 * N) * / INR (fact (S l)) * / INR (fact (N - l)))
        (pred (N - k))) (pred N)).
  apply sum_Rle; intros.
  apply sum_Rle; intros.
  repeat rewrite Rabs_mult.
  do 2 rewrite <- RPow_abs.
  rewrite (Rabs_right (/ INR (fact (S (n0 + n))))).
  rewrite (Rabs_right (/ INR (fact (N - n0)))).
  replace
  (/ INR (fact (S (n0 + n))) * Rabs x ^ S (n0 + n) *
    (/ INR (fact (N - n0)) * Rabs y ^ (N - n0))) with
  (/ INR (fact (N - n0)) * / INR (fact (S (n0 + n))) * Rabs x ^ S (n0 + n) *
    Rabs y ^ (N - n0)); [ idtac | ring ].
  rewrite <- (Rmult_comm (/ INR (fact (N - n0)))).
  repeat rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rle_trans with
    (/ INR (fact (S n0)) * Rabs x ^ S (n0 + n) * Rabs y ^ (N - n0)).
  rewrite (Rmult_comm (/ INR (fact (S (n0 + n)))));
    rewrite (Rmult_comm (/ INR (fact (S n0)))); repeat rewrite Rmult_assoc;
      apply Rmult_le_compat_l.
  apply pow_le; apply Rabs_pos.
  rewrite (Rmult_comm (/ INR (fact (S n0)))); apply Rmult_le_compat_l.
  apply pow_le; apply Rabs_pos.
  apply Rle_Rinv.
  apply INR_fact_lt_0.
  apply INR_fact_lt_0.
  apply le_INR; apply fact_le; apply le_n_S.
  apply le_plus_l.
  rewrite (Rmult_comm (M ^ (2 * N))); rewrite Rmult_assoc;
    apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rle_trans with (M ^ S (n0 + n) * Rabs y ^ (N - n0)).
  do 2 rewrite <- (Rmult_comm (Rabs y ^ (N - n0))).
  apply Rmult_le_compat_l.
  apply pow_le; apply Rabs_pos.
  apply pow_incr; split.
  apply Rabs_pos.
  apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
  apply RmaxLess1.
  unfold M in |- *; apply RmaxLess2.
  apply Rle_trans with (M ^ S (n0 + n) * M ^ (N - n0)).
  apply Rmult_le_compat_l.
  apply pow_le; apply Rle_trans with 1.
  left; apply Rlt_0_1.
  unfold M in |- *; apply RmaxLess1.
  apply pow_incr; split.
  apply Rabs_pos.
  apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
  apply RmaxLess2.
  unfold M in |- *; apply RmaxLess2.
  rewrite <- pow_add; replace (S (n0 + n) + (N - n0))%nat with (N + S n)%nat.
  apply Rle_pow.
  unfold M in |- *; apply RmaxLess1.
  replace (2 * N)%nat with (N + N)%nat; [ idtac | ring ].
  apply plus_le_compat_l.
  replace N with (S (pred N)).
  apply le_n_S; apply H0.
  symmetry  in |- *; apply S_pred with 0%nat; apply H.
  apply INR_eq; do 2 rewrite plus_INR; do 2 rewrite S_INR; rewrite plus_INR;
    rewrite minus_INR.
  ring.
  apply le_trans with (pred (N - n)).
  apply 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).
  apply H0.
  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).
  apply H0.
  apply lt_pred_n_n.
  apply H.
  apply le_trans with (pred N).
  apply H0.
  apply le_pred_n.
  apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rle_ge; left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  rewrite scal_sum.
  apply sum_Rle; intros.
  rewrite <- Rmult_comm.
  rewrite scal_sum.
  apply sum_Rle; intros.
  rewrite (Rmult_comm (/ Rsqr (INR (fact (div2 (S N)))))).
  rewrite Rmult_assoc; apply Rmult_le_compat_l.
  apply pow_le.
  apply Rle_trans with 1.
  left; apply Rlt_0_1.
  unfold M in |- *; apply RmaxLess1.
  assert (H2 := even_odd_cor N).
  elim H2; intros N0 H3.
  elim H3; intro.
  apply Rle_trans with (/ INR (fact n0) * / INR (fact (N - n0))).
  do 2 rewrite <- (Rmult_comm (/ INR (fact (N - n0)))).
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rle_Rinv.
  apply INR_fact_lt_0.
  apply INR_fact_lt_0.
  apply le_INR.
  apply fact_le.
  apply le_n_Sn.
  replace (/ INR (fact n0) * / INR (fact (N - n0))) with
  (C N n0 / INR (fact N)).
  pattern N at 1 in |- *; rewrite H4.
  apply Rle_trans with (C N N0 / INR (fact N)).
  unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ INR (fact N))).
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  rewrite H4.
  apply C_maj.
  rewrite <- H4; apply le_trans with (pred (N - n)).
  apply 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).
  apply H0.
  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).
  apply H0.
  apply lt_pred_n_n.
  apply H.
  apply le_trans with (pred N).
  apply H0.
  apply le_pred_n.
  replace (C N N0 / INR (fact N)) with (/ Rsqr (INR (fact N0))).
  rewrite H4; rewrite div2_S_double; right; reflexivity.
  unfold Rsqr, C, Rdiv in |- *.
  repeat rewrite Rinv_mult_distr.
  rewrite (Rmult_comm (INR (fact N))).
  repeat rewrite Rmult_assoc.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; replace (N - N0)%nat with N0.
  ring.
  replace N with (N0 + N0)%nat.
  symmetry  in |- *; apply minus_plus.
  rewrite H4.
  ring.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  unfold C, Rdiv in |- *.
  rewrite (Rmult_comm (INR (fact N))).
  repeat rewrite Rmult_assoc.
  rewrite <- Rinv_r_sym.
  rewrite Rinv_mult_distr.
  rewrite Rmult_1_r; ring.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  replace (/ INR (fact (S n0)) * / INR (fact (N - n0))) with
  (C (S N) (S n0) / INR (fact (S N))).
  apply Rle_trans with (C (S N) (S N0) / INR (fact (S N))).
  unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ INR (fact (S N)))).
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  cut (S N = (2 * S N0)%nat).
  intro; rewrite H5; apply C_maj.
  rewrite <- H5; apply le_n_S.
  apply le_trans with (pred (N - n)).
  apply 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).
  apply H0.
  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).
  apply H0.
  apply lt_pred_n_n.
  apply H.
  apply le_trans with (pred N).
  apply H0.
  apply le_pred_n.
  rewrite H4; ring.
  cut (S N = (2 * S N0)%nat).
  intro.
  replace (C (S N) (S N0) / INR (fact (S N))) with (/ Rsqr (INR (fact (S N0)))).
  rewrite H5; rewrite div2_double.
  right; reflexivity.
  unfold Rsqr, C, Rdiv in |- *.
  repeat rewrite Rinv_mult_distr.
  replace (S N - S N0)%nat with (S N0).
  rewrite (Rmult_comm (INR (fact (S N)))).
  repeat rewrite Rmult_assoc.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; reflexivity.
  apply INR_fact_neq_0.
  replace (S N) with (S N0 + S N0)%nat.
  symmetry  in |- *; apply minus_plus.
  rewrite H5; ring.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  rewrite H4; ring.
  unfold C, Rdiv in |- *.
  rewrite (Rmult_comm (INR (fact (S N)))).
  rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; rewrite Rinv_mult_distr.
  reflexivity.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  unfold maj_Reste_E in |- *.
  unfold Rdiv in |- *; rewrite (Rmult_comm 4).
  rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  apply pow_le.
  apply Rle_trans with 1.
  left; apply Rlt_0_1.
  apply RmaxLess1.
  apply Rle_trans with
    (sum_f_R0 (fun k:nat => INR (N - k) * / Rsqr (INR (fact (div2 (S N)))))
      (pred N)).
  apply sum_Rle; intros.
  rewrite sum_cte.
  replace (S (pred (N - n))) with (N - n)%nat.
  right; apply Rmult_comm.
  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).
  apply H0.
  apply lt_pred_n_n.
  apply H.
  apply le_trans with (pred N).
  apply H0.
  apply le_pred_n.
  apply Rle_trans with
    (sum_f_R0 (fun k:nat => INR N * / Rsqr (INR (fact (div2 (S N))))) (pred N)).
  apply sum_Rle; intros.
  do 2 rewrite <- (Rmult_comm (/ Rsqr (INR (fact (div2 (S N)))))).
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt.
  apply INR_fact_neq_0.
  apply le_INR.
  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).
  apply H0.
  apply le_pred_n.
  rewrite sum_cte; replace (S (pred N)) with N.
  cut (div2 (S N) = S (div2 (pred N))).
  intro; rewrite H0.
  rewrite fact_simpl; rewrite mult_comm; rewrite mult_INR; rewrite Rsqr_mult.
  rewrite Rinv_mult_distr.
  rewrite (Rmult_comm (INR N)); repeat rewrite Rmult_assoc;
    apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt; apply INR_fact_neq_0.
  rewrite <- H0.
  cut (INR N <= INR (2 * div2 (S N))).
  intro; apply Rmult_le_reg_l with (Rsqr (INR (div2 (S N)))).
  apply Rsqr_pos_lt.
  apply not_O_INR; red in |- *; intro.
  cut (1 < S N)%nat.
  intro; assert (H4 := div2_not_R0 _ H3).
  rewrite H2 in H4; elim (lt_n_O _ H4).
  apply lt_n_S; apply H.
  repeat rewrite <- Rmult_assoc.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_l.
  replace (INR N * INR N) with (Rsqr (INR N)); [ idtac | reflexivity ].
  rewrite Rmult_assoc.
  rewrite Rmult_comm.
  replace 4 with (Rsqr 2); [ idtac | ring_Rsqr ].
  rewrite <- Rsqr_mult.
  apply Rsqr_incr_1.
  replace 2 with (INR 2).
  rewrite <- mult_INR; apply H1.
  reflexivity.
  left; apply lt_INR_0; apply H.
  left; apply Rmult_lt_0_compat.
  prove_sup0.
  apply lt_INR_0; apply div2_not_R0.
  apply lt_n_S; apply H.
  cut (1 < S N)%nat.
  intro; unfold Rsqr in |- *; apply prod_neq_R0; apply not_O_INR; intro;
    assert (H4 := div2_not_R0 _ H2); rewrite H3 in H4;
      elim (lt_n_O _ H4).
  apply lt_n_S; apply H.
  assert (H1 := even_odd_cor N).
  elim H1; intros N0 H2.
  elim H2; intro.
  pattern N at 2 in |- *; rewrite H3.
  rewrite div2_S_double.
  right; rewrite H3; reflexivity.
  pattern N at 2 in |- *; rewrite H3.
  replace (S (S (2 * N0))) with (2 * S N0)%nat.
  rewrite div2_double.
  rewrite H3.
  rewrite S_INR; do 2 rewrite mult_INR.
  rewrite (S_INR N0).
  rewrite Rmult_plus_distr_l.
  apply Rplus_le_compat_l.
  rewrite Rmult_1_r.
  simpl in |- *.
  pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
    apply Rlt_0_1.
  ring.
  unfold Rsqr in |- *; apply prod_neq_R0; apply INR_fact_neq_0.
  unfold Rsqr in |- *; apply prod_neq_R0; apply not_O_INR; discriminate.
  assert (H0 := even_odd_cor N).
  elim H0; intros N0 H1.
  elim H1; intro.
  cut (0 < N0)%nat.
  intro; rewrite H2.
  rewrite div2_S_double.
  replace (2 * N0)%nat with (S (S (2 * pred N0))).
  replace (pred (S (S (2 * pred N0)))) with (S (2 * pred N0)).
  rewrite div2_S_double.
  apply S_pred with 0%nat; apply H3.
  reflexivity.
  omega.
  omega.
  rewrite H2.
  replace (pred (S (2 * N0))) with (2 * N0)%nat; [ idtac | reflexivity ].
  replace (S (S (2 * N0))) with (2 * S N0)%nat.
  do 2 rewrite div2_double.
  reflexivity.
  ring.
  apply S_pred with 0%nat; apply H.
Qed.

Lemma maj_Reste_cv_R0 : forall x y:R, Un_cv (maj_Reste_E x y) 0.
Proof.
  intros; assert (H := Majxy_cv_R0 x y).
  unfold Un_cv in H; unfold Un_cv in |- *; intros.
  cut (0 < eps / 4);
    [ intro
      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
        [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
  elim (H _ H1); intros N0 H2.
  exists (max (2 * S N0) 2); intros.
  unfold R_dist in H2; unfold R_dist in |- *; rewrite Rminus_0_r;
    unfold Majxy in H2; unfold maj_Reste_E in |- *.
  rewrite Rabs_right.
  apply Rle_lt_trans with
    (4 *
      (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n))) /
        INR (fact (div2 (pred n))))).
  apply Rmult_le_compat_l.
  left; prove_sup0.
  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr.
  rewrite (Rmult_comm (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * n)));
    rewrite
      (Rmult_comm (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n)))))
      ; rewrite Rmult_assoc; apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply Rle_trans with (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * n)).
  rewrite Rmult_comm;
    pattern (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * n)) at 2 in |- *;
      rewrite <- Rmult_1_r; apply Rmult_le_compat_l.
  apply pow_le; apply Rle_trans with 1.
  left; apply Rlt_0_1.
  apply RmaxLess1.
  apply Rmult_le_reg_l with (INR (fact (div2 (pred n)))).
  apply INR_fact_lt_0.
  rewrite Rmult_1_r; rewrite <- Rinv_r_sym.
  replace 1 with (INR 1); [ apply le_INR | reflexivity ].
  apply lt_le_S.
  apply INR_lt.
  apply INR_fact_lt_0.
  apply INR_fact_neq_0.
  apply Rle_pow.
  apply RmaxLess1.
  assert (H4 := even_odd_cor n).
  elim H4; intros N1 H5.
  elim H5; intro.
  cut (0 < N1)%nat.
  intro.
  rewrite H6.
  replace (pred (2 * N1)) with (S (2 * pred N1)).
  rewrite div2_S_double.
  omega.
  omega.
  assert (0 < n)%nat.
  apply lt_le_trans with 2%nat.
  apply lt_O_Sn.
  apply le_trans with (max (2 * S N0) 2).
  apply le_max_r.
  apply H3.
  omega.
  rewrite H6.
  replace (pred (S (2 * N1))) with (2 * N1)%nat.
  rewrite div2_double.
  replace (4 * S N1)%nat with (2 * (2 * S N1))%nat.
  apply (fun m n p:nat => mult_le_compat_l p n m).
  replace (2 * S N1)%nat with (S (S (2 * N1))).
  apply le_n_Sn.
  ring.
  ring.
  reflexivity.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply Rmult_lt_reg_l with (/ 4).
  apply Rinv_0_lt_compat; prove_sup0.
  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l; rewrite Rmult_comm.
  replace
  (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n))) /
    INR (fact (div2 (pred n)))) with
  (Rabs
    (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n))) /
      INR (fact (div2 (pred n))) - 0)).
  apply H2; unfold ge in |- *.
  cut (2 * S N0 <= n)%nat.
  intro; apply le_S_n.
  apply INR_le; apply Rmult_le_reg_l with (INR 2).
  simpl in |- *; prove_sup0.
  do 2 rewrite <- mult_INR; apply le_INR.
  apply le_trans with n.
  apply H4.
  assert (H5 := even_odd_cor n).
  elim H5; intros N1 H6.
  elim H6; intro.
  cut (0 < N1)%nat.
  intro.
  rewrite H7.
  apply (fun m n p:nat => mult_le_compat_l p n m).
  replace (pred (2 * N1)) with (S (2 * pred N1)).
  rewrite div2_S_double.
  replace (S (pred N1)) with N1.
  apply le_n.
  apply S_pred with 0%nat; apply H8.
  replace (2 * N1)%nat with (S (S (2 * pred N1))).
  reflexivity.
  pattern N1 at 2 in |- *; replace N1 with (S (pred N1)).
  ring.
  symmetry  in |- *; apply S_pred with 0%nat; apply H8.
  apply INR_lt.
  apply Rmult_lt_reg_l with (INR 2).
  simpl in |- *; prove_sup0.
  rewrite Rmult_0_r; rewrite <- mult_INR.
  apply lt_INR_0.
  rewrite <- H7.
  apply lt_le_trans with 2%nat.
  apply lt_O_Sn.
  apply le_trans with (max (2 * S N0) 2).
  apply le_max_r.
  apply H3.
  rewrite H7.
  replace (pred (S (2 * N1))) with (2 * N1)%nat.
  rewrite div2_double.
  replace (2 * S N1)%nat with (S (S (2 * N1))).
  apply le_n_Sn.
  ring.
  reflexivity.
  apply le_trans with (max (2 * S N0) 2).
  apply le_max_l.
  apply H3.
  rewrite Rminus_0_r; apply Rabs_right.
  apply Rle_ge.
  unfold Rdiv in |- *; apply Rmult_le_pos.
  apply pow_le.
  apply Rle_trans with 1.
  left; apply Rlt_0_1.
  apply RmaxLess1.
  left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  discrR.
  apply Rle_ge.
  unfold Rdiv in |- *; apply Rmult_le_pos.
  left; prove_sup0.
  apply Rmult_le_pos.
  apply pow_le.
  apply Rle_trans with 1.
  left; apply Rlt_0_1.
  apply RmaxLess1.
  left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt; apply INR_fact_neq_0.
Qed.

(**********)
Lemma Reste_E_cv : forall x y:R, Un_cv (Reste_E x y) 0.
Proof.
  intros; assert (H := maj_Reste_cv_R0 x y).
  unfold Un_cv in H; unfold Un_cv in |- *; intros; elim (H _ H0); intros.
  exists (max x0 1); intros.
  unfold R_dist in |- *; rewrite Rminus_0_r.
  apply Rle_lt_trans with (maj_Reste_E x y n).
  apply Reste_E_maj.
  apply lt_le_trans with 1%nat.
  apply lt_O_Sn.
  apply le_trans with (max x0 1).
  apply le_max_r.
  apply H2.
  replace (maj_Reste_E x y n) with (R_dist (maj_Reste_E x y n) 0).
  apply H1.
  unfold ge in |- *; apply le_trans with (max x0 1).
  apply le_max_l.
  apply H2.
  unfold R_dist in |- *; rewrite Rminus_0_r; apply Rabs_right.
  apply Rle_ge; apply Rle_trans with (Rabs (Reste_E x y n)).
  apply Rabs_pos.
  apply Reste_E_maj.
  apply lt_le_trans with 1%nat.
  apply lt_O_Sn.
  apply le_trans with (max x0 1).
  apply le_max_r.
  apply H2.
Qed.

(**********)
Lemma exp_plus : forall x y:R, exp (x + y) = exp x * exp y.
Proof.
  intros; assert (H0 := E1_cvg x).
  assert (H := E1_cvg y).
  assert (H1 := E1_cvg (x + y)).
  eapply UL_sequence.
  apply H1.
  assert (H2 := CV_mult _ _ _ _ H0 H).
  assert (H3 := CV_minus _ _ _ _ H2 (Reste_E_cv x y)).
  unfold Un_cv in |- *; unfold Un_cv in H3; intros.
  elim (H3 _ H4); intros.
  exists (S x0); intros.
  rewrite <- (exp_form x y n).
  rewrite Rminus_0_r in H5.
  apply H5.
  unfold ge in |- *; apply le_trans with (S x0).
  apply le_n_Sn.
  apply H6.
  apply lt_le_trans with (S x0).
  apply lt_O_Sn.
  apply H6.
Qed.

(**********)
Lemma exp_pos_pos : forall x:R, 0 < x -> 0 < exp x.
Proof.
  intros; set (An := fun N:nat => / INR (fact N) * x ^ N).
  cut (Un_cv (fun n:nat => sum_f_R0 An n) (exp x)).
  intro; apply Rlt_le_trans with (sum_f_R0 An 0).
  unfold An in |- *; simpl in |- *; rewrite Rinv_1; rewrite Rmult_1_r;
    apply Rlt_0_1.
  apply sum_incr.
  assumption.
  intro; unfold An in |- *; left; apply Rmult_lt_0_compat.
  apply Rinv_0_lt_compat; apply INR_fact_lt_0.
  apply (pow_lt _ n H).
  unfold exp in |- *; unfold projT1 in |- *; case (exist_exp x); intro.
  unfold exp_in in |- *; unfold infinite_sum, Un_cv in |- *; trivial.
Qed.

(**********)
Lemma exp_pos : forall x:R, 0 < exp x.
Proof.
  intro; case (total_order_T 0 x); intro.
  elim s; intro.
  apply (exp_pos_pos _ a).
  rewrite <- b; rewrite exp_0; apply Rlt_0_1.
  replace (exp x) with (1 / exp (- x)).
  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
  apply Rlt_0_1.
  apply Rinv_0_lt_compat; apply exp_pos_pos.
  apply (Ropp_0_gt_lt_contravar _ r).
  cut (exp (- x) <> 0).
  intro; unfold Rdiv in |- *; apply Rmult_eq_reg_l with (exp (- x)).
  rewrite Rmult_1_l; rewrite <- Rinv_r_sym.
  rewrite <- exp_plus.
  rewrite Rplus_opp_l; rewrite exp_0; reflexivity.
  apply H.
  apply H.
  assert (H := exp_plus x (- x)).
  rewrite Rplus_opp_r in H; rewrite exp_0 in H.
  red in |- *; intro; rewrite H0 in H.
  rewrite Rmult_0_r in H.
  elim R1_neq_R0; assumption.
Qed.

(* ((exp h)-1)/h -> 0 quand h->0 *)
Lemma derivable_pt_lim_exp_0 : derivable_pt_lim exp 0 1.
Proof.
  unfold derivable_pt_lim in |- *; intros.
  set (fn := fun (N:nat) (x:R) => x ^ N / INR (fact (S N))).
  cut (CVN_R fn).
  intro; cut (forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }).
  intro cv; cut (forall n:nat, continuity (fn n)).
  intro; cut (continuity (SFL fn cv)).
  intro; unfold continuity in H1.
  assert (H2 := H1 0).
  unfold continuity_pt in H2; unfold continue_in in H2; unfold limit1_in in H2;
    unfold limit_in in H2; simpl in H2; unfold R_dist in H2.
  elim (H2 _ H); intros alp H3.
  elim H3; intros.
  exists (mkposreal _ H4); intros.
  rewrite Rplus_0_l; rewrite exp_0.
  replace ((exp h - 1) / h) with (SFL fn cv h).
  replace 1 with (SFL fn cv 0).
  apply H5.
  split.
  unfold D_x, no_cond in |- *; split.
  trivial.
  apply (sym_not_eq H6).
  rewrite Rminus_0_r; apply H7.
  unfold SFL in |- *.
  case (cv 0); intros.
  eapply UL_sequence.
  apply u.
  unfold Un_cv, SP in |- *.
  intros; exists 1%nat; intros.
  unfold R_dist in |- *; rewrite decomp_sum.
  rewrite (Rplus_comm (fn 0%nat 0)).
  replace (fn 0%nat 0) with 1.
  unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_r;
    rewrite Rplus_0_r.
  replace (sum_f_R0 (fun i:nat => fn (S i) 0) (pred n)) with 0.
  rewrite Rabs_R0; apply H8.
  symmetry  in |- *; apply sum_eq_R0; intros.
  unfold fn in |- *.
  simpl in |- *.
  unfold Rdiv in |- *; do 2 rewrite Rmult_0_l; reflexivity.
  unfold fn in |- *; simpl in |- *.
  unfold Rdiv in |- *; rewrite Rinv_1; rewrite Rmult_1_r; reflexivity.
  apply lt_le_trans with 1%nat; [ apply lt_n_Sn | apply H9 ].
  unfold SFL, exp in |- *.
  case (cv h); case (exist_exp h); simpl; intros.
  eapply UL_sequence.
  apply u.
  unfold Un_cv in |- *; intros.
  unfold exp_in in e.
  unfold infinite_sum in e.
  cut (0 < eps0 * Rabs h).
  intro; elim (e _ H9); intros N0 H10.
  exists N0; intros.
  unfold R_dist in |- *.
  apply Rmult_lt_reg_l with (Rabs h).
  apply Rabs_pos_lt; assumption.
  rewrite <- Rabs_mult.
  rewrite Rmult_minus_distr_l.
  replace (h * ((x - 1) / h)) with (x - 1).
  unfold R_dist in H10.
  replace (h * SP fn n h - (x - 1)) with
  (sum_f_R0 (fun i:nat => / INR (fact i) * h ^ i) (S n) - x).
  rewrite (Rmult_comm (Rabs h)).
  apply H10.
  unfold ge in |- *.
  apply le_trans with (S N0).
  apply le_n_Sn.
  apply le_n_S; apply H11.
  rewrite decomp_sum.
  replace (/ INR (fact 0) * h ^ 0) with 1.
  unfold Rminus in |- *.
  rewrite Ropp_plus_distr.
  rewrite Ropp_involutive.
  rewrite <- (Rplus_comm (- x)).
  rewrite <- (Rplus_comm (- x + 1)).
  rewrite Rplus_assoc; repeat apply Rplus_eq_compat_l.
  replace (pred (S n)) with n; [ idtac | reflexivity ].
  unfold SP in |- *.
  rewrite scal_sum.
  apply sum_eq; intros.
  unfold fn in |- *.
  replace (h ^ S i) with (h * h ^ i).
  unfold Rdiv in |- *; ring.
  simpl in |- *; ring.
  simpl in |- *; rewrite Rinv_1; rewrite Rmult_1_r; reflexivity.
  apply lt_O_Sn.
  unfold Rdiv in |- *.
  rewrite <- Rmult_assoc.
  symmetry  in |- *; apply Rinv_r_simpl_m.
  assumption.
  apply Rmult_lt_0_compat.
  apply H8.
  apply Rabs_pos_lt; assumption.
  apply SFL_continuity; assumption.
  intro; unfold fn in |- *.
  replace (fun x:R => x ^ n / INR (fact (S n))) with
  (pow_fct n / fct_cte (INR (fact (S n))))%F; [ idtac | reflexivity ].
  apply continuity_div.
  apply derivable_continuous; apply (derivable_pow n).
  apply derivable_continuous; apply derivable_const.
  intro; unfold fct_cte in |- *; apply INR_fact_neq_0.
  apply (CVN_R_CVS _ X).
  assert (H0 := Alembert_exp).
  unfold CVN_R in |- *.
  intro; unfold CVN_r in |- *.
  exists (fun N:nat => r ^ N / INR (fact (S N))).
  cut
    { l:R |
        Un_cv
        (fun n:nat =>
          sum_f_R0 (fun k:nat => Rabs (r ^ k / INR (fact (S k)))) n) l }.
  intro X.
  elim X; intros.
  exists x; intros.
  split.
  apply p.
  unfold Boule in |- *; intros.
  rewrite Rminus_0_r in H1.
  unfold fn in |- *.
  unfold Rdiv in |- *; rewrite Rabs_mult.
  cut (0 < INR (fact (S n))).
  intro.
  rewrite (Rabs_right (/ INR (fact (S n)))).
  do 2 rewrite <- (Rmult_comm (/ INR (fact (S n)))).
  apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; apply H2.
  rewrite <- RPow_abs.
  apply pow_maj_Rabs.
  rewrite Rabs_Rabsolu; left; apply H1.
  apply Rle_ge; left; apply Rinv_0_lt_compat; apply H2.
  apply INR_fact_lt_0.
  cut ((r:R) <> 0).
  intro; apply Alembert_C2.
  intro; apply Rabs_no_R0.
  unfold Rdiv in |- *; apply prod_neq_R0.
  apply pow_nonzero; assumption.
  apply Rinv_neq_0_compat; apply INR_fact_neq_0.
  unfold Un_cv in H0.
  unfold Un_cv in |- *; intros.
  cut (0 < eps0 / r);
    [ intro
      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
        [ assumption | apply Rinv_0_lt_compat; apply (cond_pos r) ] ].
  elim (H0 _ H3); intros N0 H4.
  exists N0; intros.
  cut (S n >= N0)%nat.
  intro hyp_sn.
  assert (H6 := H4 _ hyp_sn).
  unfold R_dist in H6; rewrite Rminus_0_r in H6.
  rewrite Rabs_Rabsolu in H6.
  unfold R_dist in |- *; rewrite Rminus_0_r.
  rewrite Rabs_Rabsolu.
  replace
  (Rabs (r ^ S n / INR (fact (S (S n)))) / Rabs (r ^ n / INR (fact (S n))))
    with (r * / INR (fact (S (S n))) * / / INR (fact (S n))).
  rewrite Rmult_assoc; rewrite Rabs_mult.
  rewrite (Rabs_right r).
  apply Rmult_lt_reg_l with (/ r).
  apply Rinv_0_lt_compat; apply (cond_pos r).
  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l; rewrite <- (Rmult_comm eps0).
  apply H6.
  assumption.
  apply Rle_ge; left; apply (cond_pos r).
  unfold Rdiv in |- *.
  repeat rewrite Rabs_mult.
  repeat rewrite Rabs_Rinv.
  rewrite Rinv_mult_distr.
  repeat rewrite Rabs_right.
  rewrite Rinv_involutive.
  rewrite (Rmult_comm r).
  rewrite (Rmult_comm (r ^ S n)).
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  rewrite (Rmult_comm r).
  rewrite <- Rmult_assoc; rewrite <- (Rmult_comm (INR (fact (S n)))).
  apply Rmult_eq_compat_l.
  simpl in |- *.
  rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
  ring.
  apply pow_nonzero; assumption.
  apply INR_fact_neq_0.
  apply Rle_ge; left; apply INR_fact_lt_0.
  apply Rle_ge; left; apply pow_lt; apply (cond_pos r).
  apply Rle_ge; left; apply INR_fact_lt_0.
  apply Rle_ge; left; apply pow_lt; apply (cond_pos r).
  apply Rabs_no_R0; apply pow_nonzero; assumption.
  apply Rinv_neq_0_compat; apply Rabs_no_R0; apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  unfold ge in |- *; apply le_trans with n.
  apply H5.
  apply le_n_Sn.
  assert (H1 := cond_pos r); red in |- *; intro; rewrite H2 in H1;
    elim (Rlt_irrefl _ H1).
Qed.

(**********)
Lemma derivable_pt_lim_exp : forall x:R, derivable_pt_lim exp x (exp x).
Proof.
  intro; assert (H0 := derivable_pt_lim_exp_0).
  unfold derivable_pt_lim in H0; unfold derivable_pt_lim in |- *; intros.
  cut (0 < eps / exp x);
    [ intro
      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
        [ apply H | apply Rinv_0_lt_compat; apply exp_pos ] ].
  elim (H0 _ H1); intros del H2.
  exists del; intros.
  assert (H5 := H2 _ H3 H4).
  rewrite Rplus_0_l in H5; rewrite exp_0 in H5.
  replace ((exp (x + h) - exp x) / h - exp x) with
  (exp x * ((exp h - 1) / h - 1)).
  rewrite Rabs_mult; rewrite (Rabs_right (exp x)).
  apply Rmult_lt_reg_l with (/ exp x).
  apply Rinv_0_lt_compat; apply exp_pos.
  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l; rewrite <- (Rmult_comm eps).
  apply H5.
  assert (H6 := exp_pos x); red in |- *; intro; rewrite H7 in H6;
    elim (Rlt_irrefl _ H6).
  apply Rle_ge; left; apply exp_pos.
  rewrite Rmult_minus_distr_l.
  rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite <- Rmult_assoc;
    rewrite Rmult_minus_distr_l.
  rewrite Rmult_1_r; rewrite exp_plus; reflexivity.
Qed.


(**
This file is part of the Elfic library

Copyright (C) Boldo, Clément, Faissole, Martin, Mayero

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

Require Export Reals Coquelicot.Coquelicot.

(** AbelianGroup-compatibility *)

Section AboutCompatibleG.

Context {E : AbelianGroup}.

Definition compatible_g (P: E -> Prop) : Prop :=
   (forall (x y:E), P x -> P y -> P (plus x (opp y))) /\
      (exists (x:E), P x).

Lemma compatible_g_zero: forall P, compatible_g P -> P zero.
Proof.
intros P HP; destruct HP as (H1,(e,He)).
specialize (H1 e e).
rewrite plus_opp_r in H1.
now apply H1.
Qed.

Lemma compatible_g_opp: forall P x, compatible_g P
    -> P x -> P (opp x).
Proof.
intros P x HP Hx.
rewrite <- plus_zero_l.
apply HP; try assumption.
now apply compatible_g_zero.
Qed.

Lemma compatible_g_plus: forall P x y, compatible_g P
    -> P x -> P y -> P (plus x y).
Proof.
intros P x y HP Hx Hy.
rewrite <- (opp_opp y).
apply HP; try assumption.
now apply compatible_g_opp.
Qed.

End AboutCompatibleG.

(** ModuleSpace-compatibility *)

Section AboutCompatibleM.

Context {E : ModuleSpace R_Ring}.

Definition compatible_m (phi:E->Prop):=
  compatible_g phi /\
  (forall (x:E) (l:R), phi x -> phi (scal l x)).

Lemma compatible_m_zero: forall P, compatible_m P -> P zero.
Proof.
intros. destruct H.
apply (compatible_g_zero P); trivial.
Qed.

Lemma compatible_m_plus: forall P x y, compatible_m P
    -> P x -> P y -> P (plus x y).
Proof.
intros P x y Hp Hx Hy.
destruct Hp.
apply (compatible_g_plus P x y); trivial.
Qed.

Lemma compatible_m_scal: forall P a y, compatible_m P
    -> P y -> P (scal a y).
Proof.
intros P x y HP Hy.
apply HP; trivial.
Qed.

Lemma compatible_m_opp: forall P x, compatible_m P
    -> P x -> P (opp x).
Proof.
intros. destruct H.
apply (compatible_g_opp P); trivial.
Qed.

End AboutCompatibleM.

(** Sums and direct sums  *)

Section Compat_m.

Context {E : ModuleSpace R_Ring}.

Variable phi:E->Prop.
Variable phi':E->Prop.

Definition m_plus (phi phi':E -> Prop)
   := (fun (x:E) => exists u u', phi u -> phi' u' -> x=plus u u').

Hypothesis Cphi: compatible_m phi.
Hypothesis Cphi': compatible_m phi'.

Lemma compatible_m_plus2: compatible_m (m_plus phi phi').
unfold compatible_m in *; unfold compatible_g in *.
destruct Cphi as ((Cphi1,(a,Cphi2)),Cphi3).
destruct Cphi' as ((Cphi1',(a',Cphi2')),Cphi3').
unfold m_plus in *.
split.
split; intros. exists (plus x (opp y)). exists zero.
intros. rewrite plus_zero_r. reflexivity.
exists (plus a a'). exists a. exists a'. intros.
reflexivity.
intros. exists (scal l x). exists (scal zero x).
intros. rewrite <- scal_distr_r. rewrite plus_zero_r.
reflexivity.
Qed.

Definition direct_sumable := forall x, phi x -> phi' x -> x = zero.

Lemma direct_sum_eq1:
   direct_sumable ->
    (forall u u' , phi u -> phi' u' -> plus u u' = zero -> u=zero /\ u'=zero).
intros. split.
unfold compatible_m in *.
unfold compatible_g in *.
assert (u = opp u').
rewrite <- plus_opp_r with u' in H2.
rewrite plus_comm in H2.
apply plus_reg_l in H2.
trivial.
assert (phi' u).
rewrite H3 in H2.
rewrite H3.
rewrite <- scal_opp_one.
apply (proj2 Cphi'). trivial.
apply H; trivial.
assert (u' = opp u).
rewrite <- plus_opp_r with u in H2.
apply plus_reg_l in H2. trivial.
assert (phi u').
rewrite H3 in H2.
rewrite H3.
rewrite <- scal_opp_one.
apply (proj2 Cphi). trivial.
apply H; trivial.
Qed.

Lemma plus_u_opp_v : forall (u v : E), u = v <-> (plus u (opp v) = zero).
intros; split.
+ intros. rewrite H. rewrite plus_opp_r. reflexivity.
+ intros. apply plus_reg_r with (opp v). rewrite plus_opp_r; trivial.
Qed.

Lemma plus_assoc_gen : forall (a b c d : E),
     plus (plus a b) (plus c d) = plus (plus a c) (plus b d).
intros. rewrite plus_assoc. symmetry. rewrite plus_assoc.
assert (plus a (plus b c) = plus (plus a b) c).
apply plus_assoc.
assert (plus a (plus c b) = plus (plus a c) b).
apply plus_assoc.
rewrite <- H; rewrite <-H0.
rewrite (plus_comm c b). reflexivity.
Qed.

Lemma direct_sum_eq2:
  (forall u u' , phi u -> phi' u' -> plus u u' = zero -> u=zero /\ u'=zero) ->
   (forall u v u' v', phi u -> phi v -> phi' u' -> phi' v' -> plus u u' = plus v v' -> u=v /\ u'=v').
intros. unfold compatible_m in *; unfold compatible_g in *.
destruct Cphi as ((Cphi1,(x,Cphi2)),Cphi3).
destruct Cphi' as ((Cphi'1,(x',Cphi'2)),Cphi'3).
assert (plus (plus u (opp v)) (plus u' (opp v')) = zero).
rewrite plus_assoc_gen. rewrite H4.
rewrite plus_assoc_gen. rewrite plus_opp_r. rewrite plus_opp_r.
rewrite plus_zero_r. reflexivity.
rewrite plus_u_opp_v.
rewrite (plus_u_opp_v u' v').
apply H.
apply Cphi1; trivial.
apply Cphi'1; trivial.
trivial.
Qed.

Lemma direct_sum_eq3:
   (forall u v u' v', phi u -> phi v -> phi' u' -> phi' v' -> plus u u' = plus v v' -> u=v /\ u'=v')
     -> direct_sumable.
intros.
unfold compatible_m in *; unfold compatible_g in *; unfold direct_sumable.
intros.
destruct Cphi as ((Cphi1,(y,Cphi2)),Cphi3).
destruct Cphi' as ((Cphi'1,(y',Cphi'2)),Cphi'3).
apply (Cphi3 y zero) in Cphi2.
apply (Cphi'3 y' zero) in Cphi'2.
apply (Cphi'3 x (opp one)) in H1.
assert ((x = zero) /\ (opp x = zero)).
apply H. trivial. rewrite <- (scal_zero_l y). trivial.
rewrite <- scal_opp_one. trivial.
rewrite <- (scal_zero_l y'). trivial.
rewrite plus_opp_r.
rewrite plus_zero_l. reflexivity.
intuition.
Qed.

End Compat_m.


Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import Coq.Init.Peano.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.PArith.BinPosDef.
Require Import Coq.ZArith.BinInt Coq.ZArith.ZArith Coq.ZArith.Zdiv Coq.ZArith.Znumtheory Coq.NArith.NArith. (* import Zdiv before Znumtheory *)
Require Import Coq.NArith.Nnat.

Require Import Crypto.Algebra.Hierarchy Crypto.Algebra.Field.
Require Import Crypto.Spec.ModularArithmetic.
Require Import Crypto.Arithmetic.ModularArithmeticTheorems Crypto.Arithmetic.PrimeFieldTheorems.

Require Import Crypto.Util.Decidable. (* Crypto.Util.Notations. *)
Require Import Coq.setoid_ring.Ring_theory Coq.setoid_ring.Field_theory Coq.setoid_ring.Field_tac.
Require Import Ring.

From Circom Require Import Circom Default Util DSL Tuple ListUtil LibTactics Simplify.
From Circom Require Import Repr ReprZ.
From Circom.CircomLib Require Import Bitify.

From Circom.BigInt.Definition Require Import BigAdd BigMult BigLessThan.
From Circom.BigInt.Proof Require Import BigAdd BigMult BigLessThan.
From Circom.BigInt.Definition Require Import BigMod.
From Circom Require Import Signed.
(* Circuit:
* https://github.com/yi-sun/circom-pairing/blob/master/circuits/bigint.circom
*)

Module BigMod.

Module B := Bitify.
Module D := DSL.
Module Cmp := Comparators.
Module RZS := ReprZSigned.
Module RZ := RZS.RZ.
Module Add := BigAdd.BigAdd.
Module Mult := BigMult.BigMult.
Module LessThan := BigLessThan.BigLessThan.
Import B.
Local Open Scope list_scope.
Local Open Scope Z_scope.
Local Open Scope F_scope.
Local Open Scope circom_scope.
Local Open Scope tuple_scope.

Local Coercion Z.of_nat: nat >-> Z.
Local Coercion N.of_nat: nat >-> N.

Section _BigMod.
Context {n k: nat}.

(* // leading register of b should be non-zero
template BigMod(n, k) {
    signal input a[2 * k];
    signal input b[k];

    signal output div[k + 1];
    signal output mod[k];

    component div_range_checks[k + 1];
    for (var i = 0; i <= k; i++) {
        div_range_checks[i] = Num2Bits(n);
        div_range_checks[i].in <== div[i];
    }
    component mod_range_checks[k];
    for (var i = 0; i < k; i++) {
        mod_range_checks[i] = Num2Bits(n);
        mod_range_checks[i].in <== mod[i];
    }

    component mul = BigMult(n, k + 1);
    for (var i = 0; i < k; i++) {
        mul.a[i] <== div[i];
        mul.b[i] <== b[i];
    }
    mul.a[k] <== div[k];
    mul.b[k] <== 0;

    component add = BigAdd(n, 2 * k + 2);
    for (var i = 0; i < 2 * k; i++) {
        add.a[i] <== mul.out[i];
        if (i < k) {
            add.b[i] <== mod[i];
        } else {
            add.b[i] <== 0;
        }
    }

    add.a[2 * k] <== mul.out[2 * k];
    add.a[2 * k + 1] <== mul.out[2 * k + 1];
    add.b[2 * k] <== 0;
    add.b[2 * k + 1] <== 0;

    for (var i = 0; i < 2 * k; i++) {
        add.out[i] === a[i];
    }
    add.out[2 * k] === 0;
    add.out[2 * k + 1] === 0;

    component lt = BigLessThan(n, k);
    for (var i = 0; i < k; i++) {
        lt.a[i] <== mod[i];
        lt.b[i] <== b[i];
    }
    lt.out === 1;
} *)

Definition cons (a: F^(2 * k)) (b: F^k) (div: F^(k+1)) (_mod: F^k) :=
  exists (div_range_checks: (@Num2Bits.t n) ^ (k + 1)) (mod_range_checks: (@Num2Bits.t n) ^ (k))
         (mul: @Mult.t (k+1)%nat) (add: @Add.t n (2 * k + 2))
         (lt: @LessThan.t n k),
  (* range check for div *)
  D.iter (fun (i: nat) (_cons: Prop) => _cons /\
    div_range_checks[i].(Num2Bits._in) = div[i]) (k+1) True /\
  (* range check for mod *)
  D.iter (fun (i: nat) (_cons: Prop) => _cons /\
    mod_range_checks[i].(Num2Bits._in) = _mod[i]) (k) True /\
  (* mul *)
  D.iter (fun (i: nat) (_cons: Prop) => _cons /\
    mul.(Mult.a)[i] = div[i] /\
    mul.(Mult.b)[i] = b[i]) k True /\
  mul.(Mult.a)[k] = div[k] /\
  mul.(Mult.b)[k] = 0 /\
  (* add *)
  D.iter (fun (i: nat) (_cons: Prop) => _cons /\
    add.(Add.a)[i] = mul.(Mult.out)[i] /\
    if (i < k)? then
      add.(Add.b)[i] = _mod[i]
    else
      add.(Add.b)[i] = 0) (2 * k) True /\
  add.(Add.a)[2 * k] = mul.(Mult.out)[2 * k] /\
  add.(Add.a)[2 * k + 1] = mul.(Mult.out)[2 * k + 1] /\
  add.(Add.b)[2 * k] = 0 /\
  add.(Add.b)[2 * k + 1] = 0 /\
  (* a and add.out *)
  D.iter (fun (i: nat) (_cons: Prop) => _cons /\
    add.(Add.out)[i] = a[i]) (2 * k) True /\
  add.(Add.out)[2 * k] = 0 /\
  add.(Add.out)[2 * k + 1] = 0 /\
  (* less than *)
  D.iter (fun (i: nat) (_cons: Prop) => _cons /\
    lt.(LessThan.a)[i] = _mod[i] /\
    lt.(LessThan.b)[i] = b[i]) k True /\
  lt.(LessThan.out) = 1
.

Record t := { a: F^(2 * k); b: F^k; div: F^(k+1); _mod: F^k; _cons: cons a b div _mod }.
Local Notation "[| xs |]" := (RZ.as_le n xs).

(* Lemma firstn_congruence: forall i *)
Local Notation "xs !! i" := (List.nth i xs _) (at level 10).

Create HintDb DSL discriminated.

#[local]Hint Extern 10 (_ < _) => lia : core.
#[local]Hint Extern 10 (_ <= _) => lia : core.
#[local]Hint Extern 10 (_ > _) => lia : core.
#[local]Hint Extern 10 (_ >= _) => lia : core.
#[local]Hint Extern 10 (_ = _) => lia : core.

Ltac rewrite_length :=
  repeat match goal with
  | [ H: length ?xs = ?l |- context[length ?xs] ] =>
    rewrite H
  | [ H: length ?xs = ?l, H': context[length ?xs] |- _] =>
    rewrite H in H'
  end.

Ltac lrewrite :=
  repeat match goal with
  | [ H: ?x = _ |- context[?x] ] => rewrite H
  end.
Ltac rrewrite :=
  repeat match goal with
  | [ H: _ = ?x |- context[?x] ] => rewrite H
  end.

Ltac solve_to_Z := repeat (autorewrite with F_to_Z; simplify; try (simpl; lia)).
Ltac solve_to_Z' H := autorewrite with F_to_Z in H; simplify' H; try (simpl in H; lia).
Ltac simplify_all :=
  repeat match goal with [ H: _ |- _] => progress simplify' H end.
Ltac split_dec_f :=
  repeat match goal with
  | [H: context[dec (@eq F ?a ?b)] |- _ ] => destruct (dec (a=b))
  | [ |- context[dec (@eq F ?a ?b)] ] => destruct (dec (a=b))
  end.

(* dec (x <=z q//2) *)
Lemma all_zero_repr: forall n,
  [|List.repeat 0 n|] = 0%Z.
Proof.
  induction n0;simpl;auto.
  rewrite IHn0.
  unfold RZ.ToZ.to_Z. rewrite Signed.to_Z_0. auto.
Qed.

Theorem soundness: forall (c: t),
  0 < n ->
  0 < k ->
  n + 2 <= C.k ->
  'c.(a) |: (n) ->
  'c.(b) |: (n) ->
  'c.(div) |: (n) /\
  'c.(_mod) |: (n) /\
  ([|'c.(a)|] = [|'c.(div)|] * [|'c.(b)|] + [|'c.(_mod)|])%Z.
Proof.
  unwrap_C.
  intros c Hn Hk Hnk Ha Hb.
  destruct c as [a b div _mod [div_range_checks [mod_range_checks [mul [add [lt prog]]]]]].
  simpl in *.
  destruct prog as [Prange [Prange1 [Pmul [Pmul1 [Pmul2 [Padd [Padd1 [Padd2 [Padd3 [Padd4 [Pa [Pa1 [Pa2 [Plt Plt1]]]]]]]]]]]]]].
  rem_iter.
  simplify_all.
  pose_lengths. replace (2 * (k + 1))%nat with (2 * k + 2)%nat in _Hlen7 by lia.
  pose (Inv1 := fun (i: nat) (_cons: Prop) => _cons ->
                '(Mult.a mul)[:i] = 'div[:i] /\
                '(Mult.b mul)[:i] = 'b[:i]).
  assert (HInv1: Inv1 k (D.iter f2 k True)) by connection Inv1.
  pose (Inv2_1 := fun (i: nat) (_cons: Prop) => _cons ->
                '(Add.a add)[:i] = '(Mult.out mul)[:i]).
  assert (HInv2_1: Inv2_1 (k + k)%nat (D.iter f1 (k + k) True)) by connection Inv2_1.
  pose (Inv2_2 := fun (i: nat) (_cons: Prop) => _cons ->
                            (if dec (i<k) then '(Add.b add)[:i] = '(_mod)[:i]
                              else '(Add.b add)[:i] = '(_mod)[:k] ++ (List.repeat 0 (i - k)))).
  assert (HInv2_2: Inv2_2 (k + k)%nat (D.iter f1 (k + k) True)).
  { apply DSL.iter_inv; unfold Inv2_2; try easy.
    + intros. destruct dec;try easy.
    + intros i _cons IH Hi Hstep;
      subst; lift_to_list; intuition.
      destruct (dec (S i < k));try easy.
      ++ destruct dec;try lia.
         eapply firstn_congruence; fold_default; (lia || eauto).
      ++ destruct dec;try lia.
         +++ assert(k = S i)%nat by lia. subst.
             assert((S i - S i) = 0)%nat by lia. rewrite H3. cbv [List.repeat].
             rewrite app_nil_r. eapply firstn_congruence; fold_default; (lia || eauto).
         +++ assert(List.repeat (@F.zero q) (S i - k) = (List.repeat 0 (i - k)) ++ (0::nil))%F.
             { assert(S i - k = (i - k) + 1)%nat by lia. rewrite H3. rewrite repeat_app;auto. }
             rewrite H3. rewrite app_assoc. rewrite <- H0.
             erewrite firstn_S;try lia. fold_default. rewrite H2. auto.
  }
  pose (Inv3 := fun (i: nat) (_cons: Prop) => _cons ->
                '( Add.out add)[:i] = 'a[:i]).
  assert (HInv3: Inv3 (k + k)%nat (D.iter f0 (k + k) True)) by connection Inv3.
  pose (Inv4 := fun (i: nat) (_cons: Prop) => _cons ->
                '(LessThan.a lt)[:i] = '_mod[:i] /\
                '(LessThan.b lt)[:i] = 'b[:i]).
  assert (HInv4: Inv4 k (D.iter f k True)) by connection Inv4.
  pose (Inv0n := fun (i: nat) (_cons: Prop) => _cons ->
                'div[:i] |: (n)).
  assert (HInv0n: Inv0n (k+1)%nat (D.iter f4 (k+1) True)).
  { apply DSL.iter_inv; unfold Inv0n; try easy.
    + intros. simpl. easy.
    + intros i _cons IH Hi Hstep;
      subst; lift_to_list; intuition.
      eapply Forall_firstn_and_last. all: rewrite firstn_length;try lia. all: rewrite _Hlen10.
      all: replace (Init.Nat.min (S i) (k + 1) - 1)%nat with i by lia.
      rewrite firstn_firstn. replace (Init.Nat.min i (S i)) with i by lia;auto.
      rewrite firstn_nth;try lia. fold_default. rewrite <- H0.
      pose proof (Num2Bits.range_check ((' div_range_checks ! i))). apply H2;auto. }
  pose (Inv0m := fun (i: nat) (_cons: Prop) => _cons ->
                '_mod[:i] |: (n)).
  assert (HInv0m: Inv0m (k)%nat (D.iter f3 (k) True)).
  { apply DSL.iter_inv; unfold Inv0m; try easy.
    + intros. simpl. easy.
    + intros i _cons IH Hi Hstep;
      subst; lift_to_list; intuition.
      eapply Forall_firstn_and_last. all: rewrite firstn_length;try lia. all: rewrite _Hlen2.
      all: replace (Init.Nat.min (S i) k - 1)%nat with i by lia.
      rewrite firstn_firstn. replace (Init.Nat.min i (S i)) with i by lia;auto.
      rewrite firstn_nth;try lia. fold_default. rewrite <- H0.
      pose proof (Num2Bits.range_check ((' mod_range_checks ! i))). apply H2;auto. }
  (* generate result *)
  pose proof (HInv4 Plt) as HInv4k. clear Plt HInv4.
  pose proof (HInv3 Pa) as HInv3k. clear Pa HInv3.
  pose proof (HInv2_2 Padd) as HInv2_2k. clear HInv2_2.
  pose proof (HInv2_1 Padd) as HInv2_1k. clear HInv2_1.
  pose proof (HInv1 Pmul) as HInv1k. clear HInv1.
  pose proof (HInv0n Prange) as HInv0nk. clear Prange HInv0n.
  pose proof (HInv0m Prange1) as HInv0mk. clear Prange1 HInv0m.
  assert (Hdiv: ' div |: (n)).
  { intuition. rewrite <- firstn_all. rewrite _Hlen10;auto. } split;auto.
  assert (Hmod: '_mod |: (n)).
  { intuition. rewrite <- firstn_all. rewrite _Hlen2;auto. } split;auto.
  (* prove correctness *)
  pose (Inv1_n := fun (i: nat) (_cons: Prop) => _cons ->
                '(Mult.a mul)[:i] |: (n) /\
                '(Mult.b mul)[:i] |: (n)).
  assert (HInv1_n: Inv1_n k (D.iter f2 k True)).
  { intuition. apply DSL.iter_inv; unfold Inv1_n; try easy. simpl;easy.
    intros i _cons IH Hi Hstep;
    subst; lift_to_list; intuition.
    + eapply Forall_firstn_S with (i:=i). rewrite firstn_length. rewrite _Hlen9. lia.
      rewrite firstn_firstn. replace (Init.Nat.min i (S i)) with i by lia;auto.
      rewrite firstn_nth;try lia. fold_default;try lia. rewrite H5. unfold_default.
      apply Forall_nth;auto. lia.
    + eapply Forall_firstn_S with (i:=i). rewrite firstn_length. rewrite _Hlen8. lia.
      rewrite firstn_firstn. replace (Init.Nat.min i (S i)) with i by lia;auto.
      rewrite firstn_nth;try lia. fold_default;try lia. rewrite H6. unfold_default.
      apply Forall_nth;auto. lia. }
  pose proof (HInv1_n Pmul) as [HInv1n1 HInv1n2]. clear Pmul HInv1_n.
  (* main proof *)
  assert(mul_a_rng: ' Mult.a mul |: (n)).
  { eapply Forall_firstn_and_last;try lia. rewrite _Hlen9. replace (k + 1 - 1)%nat with k by lia;auto.
    rewrite _Hlen9. replace (k + 1 - 1)%nat with k by lia. fold_default.
    rewrite nth_Default_List_tuple. rewrite Pmul1.
    rewrite <- nth_Default_List_tuple. unfold_default.
    apply Forall_nth;auto. lia. }
  assert(mul_b_rng: ' Mult.b mul |: (n)).
  { eapply Forall_firstn_and_last;try lia. rewrite _Hlen8. replace (k + 1 - 1)%nat with k by lia;auto.
    rewrite _Hlen8. replace (k + 1 - 1)%nat with k by lia. fold_default.
    rewrite nth_Default_List_tuple. rewrite Pmul2. solve_to_Z. }
  pose proof (@Mult.soundness n _ mul mul_a_rng mul_b_rng) as [mul_rng mul_sound].
  pose (Inv2_1n := fun (i: nat) (_cons: Prop) => _cons ->
                '(Add.a add)[:i] |: (n)).
  assert (HInv2_1n: Inv2_1n (k + k)%nat (D.iter f1 (k + k) True)).
  { apply DSL.iter_inv; unfold Inv2_1n; try easy. simpl;easy.
    intros i _cons IH Hi Hstep;
    subst; lift_to_list; intuition.
    eapply Forall_firstn_S with (i:=i). rewrite firstn_length. rewrite _Hlen6. lia.
      rewrite firstn_firstn. replace (Init.Nat.min i (S i)) with i by lia;auto.
      rewrite firstn_nth;try lia. fold_default.
      replace ((' Add.a add) ! i) with ((' Mult.out mul) ! i).
      unfold_default. apply Forall_nth;auto;lia. }
  pose proof (HInv2_1n Padd) as HInv2n1. clear HInv2_1n.
  assert(add_a_rng: ' Add.a add |: (n)).
  { eapply Forall_firstn_and_last;try lia. rewrite _Hlen6. replace (k + (k + 0) + 2 - 1)%nat with (k + k + 1)%nat by lia;auto.
    eapply Forall_firstn_and_last;try lia. rewrite firstn_length;lia.
    rewrite firstn_length. rewrite _Hlen6. rewrite firstn_firstn.
    replace (Init.Nat.min (Init.Nat.min (k + k + 1) (k + (k + 0) + 2) - 1) (k + k + 1))%nat with (k + k)%nat by lia;auto.
    rewrite firstn_length. rewrite _Hlen6.
    replace (Init.Nat.min (k + k + 1) (k + (k + 0) + 2) - 1)%nat with (k + (k + 0))%nat by lia;auto.
    rewrite firstn_nth;try lia. fold_default.
    replace ((' Add.a add) ! (k + (k + 0))) with ((' Mult.out mul) ! (k + (k + 0))).
    unfold_default. apply Forall_nth;auto. rewrite _Hlen7;lia.
    do 2 rewrite nth_Default_List_tuple;auto. rewrite _Hlen6. fold_default.
    replace (' Add.a add ! (k + (k + 0) + 2 - 1)) with (' Mult.out mul ! (k + (k + 0) + 2 - 1)).
    unfold_default. apply Forall_nth;auto. rewrite _Hlen7;lia.
    do 2 rewrite nth_Default_List_tuple. replace (k + (k + 0) + 2 - 1)%nat with (k + (k + 0) + 1)%nat by lia;auto. }
  pose (Inv2_2n := fun (i: nat) (_cons: Prop) => _cons ->
                '(Add.b add)[:i] |: (n)).
  assert (HInv2_2n: Inv2_2n (k + k)%nat (D.iter f1 (k + k) True)).
  { apply DSL.iter_inv; unfold Inv2_2n; try easy. simpl;easy.
    intros i _cons IH Hi Hstep;
    subst; lift_to_list; intuition.
    eapply Forall_firstn_S with (i:=i). rewrite firstn_length. rewrite _Hlen5. lia.
    rewrite firstn_firstn. replace (Init.Nat.min i (S i)) with i by lia;auto.
    rewrite firstn_nth;try lia. fold_default.
    destruct dec in H6; rewrite H6.
    + unfold_default. apply Forall_nth;auto;lia.
    + solve_to_Z. }
  pose proof (HInv2_2n Padd) as HInv2n2. clear Padd HInv2_2n.
  assert(add_b_rng: ' Add.b add |: (n)).
  { eapply Forall_firstn_and_last;try lia. rewrite _Hlen5. replace (k + (k + 0) + 2 - 1)%nat with (k + k + 1)%nat by lia;auto.
    eapply Forall_firstn_and_last;try lia. rewrite firstn_length;lia.
    rewrite firstn_length. rewrite _Hlen5. rewrite firstn_firstn.
    replace (Init.Nat.min (Init.Nat.min (k + k + 1) (k + (k + 0) + 2) - 1) (k + k + 1))%nat with (k + k)%nat by lia;auto.
    rewrite firstn_length. rewrite _Hlen5.
    replace (Init.Nat.min (k + k + 1) (k + (k + 0) + 2) - 1)%nat with (k + (k + 0))%nat by lia;auto.
    rewrite firstn_nth;try lia. fold_default.
    rewrite nth_Default_List_tuple;auto. rewrite Padd3. solve_to_Z.
    rewrite _Hlen5. fold_default. rewrite nth_Default_List_tuple;auto.
    replace (k + (k + 0) + 2 - 1)%nat with (k + (k + 0) + 1)%nat by lia. rewrite Padd4. solve_to_Z. }
  pose proof (Add.soundnessZ add) as add_sound.
  assert(Pa3: add.(Add.out)[k + (k + 0) + 2] = 0 ).
  { destruct add_sound;auto;try easy. destruct (dec (add.(Add.out)[k + (k + 0) + 2] = 0));try easy.
    assert ([|' Add.out add|] <> ([|' Add.a add|] + [|' Add.b add|])%Z).
    pose proof (Add.soundness_lemma add) as add_sound_lemma. edestruct add_sound_lemma;try lia;auto.
     easy. }
  (* loop 1 *)
  assert(L1: [|' Mult.a mul |] = [|' div |]).
  { intuition. replace (' Mult.a mul) with ((' Mult.a mul [:k]) ++  (' Mult.a mul ! k) :: nil).
    replace (' div) with ((' div [:k]) ++  (' div ! k) :: nil).
    do 2 rewrite RZ.as_le_app. do 2 rewrite firstn_length.
    rewrite _Hlen10, _Hlen9. rewrite H1. rewrite nth_Default_List_tuple. rewrite Pmul1.
    rewrite nth_Default_List_tuple. auto.
    erewrite <- firstn_split_last. fold_default;auto. all:try lia.
    erewrite <- firstn_split_last. fold_default;auto. all:try lia. }
  assert(L2: [|' Mult.b mul |] = [|' b |]).
  { intuition. replace (' Mult.b mul) with ((' Mult.b mul [:k]) ++  (' Mult.b mul ! k) :: nil).
    replace (' b) with ((' b [:k])).
    rewrite RZ.as_le_app. rewrite firstn_length.
    rewrite _Hlen8. rewrite H2. rewrite nth_Default_List_tuple. rewrite Pmul2.
    solve_to_Z. simpl. unfold RZ.ToZ.to_Z. rewrite Signed.to_Z_0. auto. rewrite <- firstn_all. rewrite _Hlen;auto.
    erewrite <- firstn_split_last. fold_default;auto. all:try lia. }
  (* loop 2 *)
  assert(L3: [|' Add.a add |] = [|' Mult.out mul |]).
  { intuition. replace (' Add.a add) with ((' Add.a add [:k + k]) ++  (' Add.a add ! (k + k)) :: (' Add.a add ! (k + k + 1)) :: nil).
    replace (' Mult.out mul) with ((' Mult.out mul [:k + k]) ++ (' Mult.out mul ! (k + k)) :: (' Mult.out mul ! (k + k + 1)) :: nil).
    repeat rewrite RZ.as_le_app. repeat rewrite firstn_length.
    rewrite _Hlen6, _Hlen7. rewrite HInv2_1k. repeat rewrite nth_Default_List_tuple.
    replace (k + k)%nat with (k + (k + 0))%nat by lia.
    rewrite Padd1, Padd2. auto.
    erewrite <- firstn_split_last with (n:=(k + k + 1)%nat). fold_default;auto. all:try lia.
    rewrite ListUtil.app_cons_app_app. f_equal.
    erewrite <- firstn_split_last with (n:=(k + k)%nat). rewrite firstn_firstn. rewrite firstn_nth;try lia.
    replace (Init.Nat.min (k + k) (k + k + 1)) with (k+k)%nat by lia;fold_default;auto.
    rewrite firstn_length. rewrite _Hlen7. lia.
    erewrite <- firstn_split_last with (n:=(k + k + 1)%nat). fold_default;auto. all:try lia.
    rewrite ListUtil.app_cons_app_app. f_equal.
    erewrite <- firstn_split_last with (n:=(k + k)%nat). rewrite firstn_firstn. rewrite firstn_nth;try lia.
    replace (Init.Nat.min (k + k) (k + k + 1)) with (k+k)%nat by lia;fold_default;auto.
    rewrite firstn_length. rewrite _Hlen6. lia. }
  assert(L4: [|' Add.b add |] = [|' _mod |]).
  { destruct dec in HInv2_2k;try lia.
    replace (' Add.b add) with (' _mod [:k] ++ List.repeat 0 (k + k - k + 2)).
    replace (' _mod) with (' _mod [:k]).
    repeat rewrite RZ.as_le_app. repeat rewrite firstn_length. rewrite all_zero_repr. solve_to_Z.
    replace ((' _mod [:k]) [:k]) with ((' _mod [:k]));auto. replace (' _mod [:k]) with (' _mod) at 2;auto.
    rewrite <- firstn_all at 1. rewrite _Hlen2;auto. rewrite <- firstn_all. rewrite _Hlen2;auto.
    replace (' _mod [:k] ++ List.repeat 0 (k + k - k + 2)) with ((' _mod [:k]) ++ List.repeat 0 (k + k - k) ++ 0 :: 0 :: nil);auto.
    rewrite app_assoc. rewrite <- HInv2_2k.
    rewrite <- firstn_skipn with (n:=k) in HInv2_2k at 1.
    rewrite <- firstn_all. rewrite _Hlen5.
    assert (LEN: (length (' Add.b add [:k + (k + 0) + 2]) = k+k+2)%nat).
    { rewrite firstn_length. rewrite _Hlen5. lia. }
    erewrite <- firstn_split_last with (n:=(k + (k + 0) + 1)%nat). all:try lia.
    rewrite firstn_firstn. rewrite firstn_nth;try lia.  fold_default;auto.
    replace (Init.Nat.min (k + (k + 0) + 1) (k + (k + 0) + 2)) with (k + (k + 0) + 1)%nat by lia.
    rewrite nth_Default_List_tuple. rewrite Padd4.
    replace (' Add.b add [:k + (k + 0) + 1]) with (' Add.b add [:k + k] ++ (' Add.b add ! (k + (k + 0))) :: nil).
    rewrite nth_Default_List_tuple. rewrite Padd3. rewrite <- app_assoc. auto.
    assert (LEN1: (length (' Add.b add [:k + (k + 0) + 1]) = k+k+1)%nat).
    { rewrite firstn_length. rewrite _Hlen5. lia. }
    erewrite <- firstn_split_last with (n:=(k + (k+0))%nat). all:try lia.
    rewrite firstn_firstn. rewrite firstn_nth;try lia.  fold_default;auto.
    replace (Init.Nat.min (k + (k + 0)) (k + (k + 0) + 1)) with (k + (k + 0))%nat by lia.
    replace (k+k)%nat with (k + (k + 0))%nat by lia. auto.
    rewrite repeat_app. simpl;auto. }
  (* loop 3 *)
  assert(L5: [|' Add.out add |] = [|' a |]).
  { replace (' Add.out add) with ((' Add.out add [:k + k]) ++ (' Add.out add ! (k + k)) :: (' Add.out add ! (k + k + 1)) :: (' Add.out add ! (k + k + 2)) :: nil).
    replace (' a) with ((' a [:k + k])).
    repeat rewrite RZ.as_le_app. repeat rewrite firstn_length.
    rewrite _Hlen4. rewrite HInv3k. repeat rewrite nth_Default_List_tuple.
    replace (k + k)%nat with (k + (k + 0))%nat by lia.
    rewrite Pa1, Pa2, Pa3. solve_to_Z.  simpl. unfold RZ.ToZ.to_Z. rewrite Signed.to_Z_0. auto.
    rewrite <- firstn_all. rewrite _Hlen0. replace (k + k)%nat with (k + (k + 0))%nat by lia;auto.
    erewrite <- firstn_split_last with (n:=(k + k + 2)%nat). fold_default;auto. all:try lia.
    do 2 rewrite ListUtil.app_cons_app_app. f_equal.
    erewrite <- firstn_split_last with (n:=(k + k + 1)%nat). rewrite firstn_firstn. rewrite firstn_nth;try lia.
    replace (Init.Nat.min (k + k + 1) (k + k + 2)) with (k + k +1)%nat by lia;fold_default;auto. f_equal.
    erewrite <- firstn_split_last with (n:=(k + k)%nat). rewrite firstn_firstn. rewrite firstn_nth;try lia.
    replace (Init.Nat.min (k + k) (k + k + 1)) with (k + k)%nat by lia;fold_default;auto.
    rewrite firstn_length. rewrite _Hlen4. lia.
    rewrite firstn_length. rewrite _Hlen4. lia. }
  (* loop 4 *)
  assert(L6: [|' LessThan.a lt |] = [|' _mod |]).
  { intuition. replace (' LessThan.a lt) with (' LessThan.a lt [:k]).
    replace (' _mod) with (' _mod [:k]).
    rewrite H;auto.
    rewrite <- firstn_all. rewrite _Hlen2;auto.
    rewrite <- firstn_all. rewrite _Hlen1;auto. }
  assert(L7: [|' LessThan.b lt |] = [|' b |]).
  { intuition. replace (' LessThan.b lt) with (' LessThan.b lt [:k]).
    replace (' b) with (' b [:k]).
    rewrite H0;auto.
    rewrite <- firstn_all. rewrite _Hlen;auto.
    rewrite <- firstn_all. rewrite _Hlen3;auto. }
  pose proof (LessThan.soundness lt) as lt_sound.
  try rewrite L1, L2, L3, L4, L5, L6, L7 in *.
  destruct add_sound;auto;try easy.
  (* range checks *)
Unshelve. all:exact 0.
Qed.

End _BigMod.
End BigMod.